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

 Monoidal functors

 In this file, we define the several notions of functors between monoidal
 categories. Again we use a displayed approach where we define notions such
 as lax monoidal structures on functors. We also provide examples, such as
 the identity and composition. In the end, we provide bundled versions of
 these defintions.

 Contents
 1. Lax monoidal functors
 2. Strong monoidal functors
 3. Strict monoidal functors
 4. The identity is strong monoidal
 5. Composition preserves lax/strongly monoidal functors
 6. Monoidal natural transformations
 7. Inverses of monoidal natural transformations
 8. Bundled versions

Note: after refactoring on March 10, 2023, the prior Git history of this development is found via
git log -- UniMath/CategoryTheory/Monoidal/MonoidalFunctorsWhiskered.v

 ***************************************************************************)
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.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.

Local Open Scope cat.

Import BifunctorNotations.
Import MonoidalNotations.

Section local_helper_lemmas.
  Lemma iso_stable_under_equality
        {C : category}
        {x y : C}
        {f g : C⟦x,y⟧}
        (p : g = f)
        (Hf : is_z_isomorphism f)
    : is_z_isomorphism g.
  Proof.
    induction p.
    exact Hf.
  Qed.

  Lemma iso_stable_under_transportf
        {C : category}
        {x y z : C}
        {f : C⟦x,y⟧}
        (pf : y=z)
        (Hf : is_z_isomorphism f)
    : is_z_isomorphism (transportf _ pf f).
  Proof.
    induction pf.
    use Hf.
  Qed.

  Lemma iso_stable_under_equalitytransportf
        {C : category}
        {x y z : C}
        {f : C⟦x,y⟧} {g : C⟦x,z⟧}
        {pf : y = z}
        (qg : g = transportf _ pf f)
        (Hf : is_z_isomorphism f)
    : is_z_isomorphism g.
  Proof.
    use (iso_stable_under_equality qg).
    use (iso_stable_under_transportf).
    exact Hf.
  Qed.
End local_helper_lemmas.

Section MonoidalFunctors.
  (**
   1. Lax monoidal functors
   *)
  (** (Weak) Monoidal functors **)
  (* Monoidal functor data *)

  Definition preserves_tensordata
             {C D : category}
             (M : monoidal C)
             (N : monoidal D)
             (F : functor C D)
    : UU
    := ∏ (x y : C), D ⟦ F x ⊗_{ N} F y, F (x ⊗_{ M} y) ⟧.

  Definition preserves_unit
             {C D : category}
             (M : monoidal C)
             (N : monoidal D)
             (F : functor C D)
    : UU
    := D ⟦ I_{N} , F I_{M} ⟧.

  Definition fmonoidal_data
             {C D : category}
             (M : monoidal C)
             (N : monoidal D)
             (F : functor C D)
    : UU
    := preserves_tensordata M N F × preserves_unit M N F.

  Definition fmonoidal_preservestensordata
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (fmd : fmonoidal_data M N F)
    : preserves_tensordata M N F
    := pr1 fmd.

  Definition fmonoidal_preservesunit
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (fmd : fmonoidal_data M N F)
    : preserves_unit M N F
    := pr2 fmd.

  (** Properties **)
  Definition preserves_tensor_nat_left
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (pt : preserves_tensordata M N F)
    : UU
    := ∏ (x y1 y2 : C) (g : C⟦y1,y2⟧),
       F x ⊗^{ N}_{l} # F g · pt x y2
       =
       pt x y1 · # F (x ⊗^{ M}_{l} g).

  Definition preserves_tensor_nat_right
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (pt : preserves_tensordata M N F)
    : UU
    := ∏ (x1 x2 y : C) (f : C⟦x1,x2⟧),
       # F f ⊗^{ N}_{r} F y · pt x2 y
       =
       pt x1 y · # F (f ⊗^{ M}_{r} y).

  Definition preserves_leftunitality
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (pt : preserves_tensordata M N F)
             (pu : preserves_unit M N F)
    : UU
    := ∏ (x : C),
       (pu ⊗^{ N}_{r} F x) · (pt I_{M} x) · (# F lu^{ M }_{ x})
       =
       lu^{ N }_{ F x}.

  Definition preserves_leftunitalityinv
         {C D : category}
         {M : monoidal C}
         {N : monoidal D}
         {F : functor C D}
         (pt : preserves_tensordata M N F)
         (pu : preserves_unit M N F)
    : UU
    := ∏ (x : C),
       luinv^{ N }_{ F x} · (pu ⊗^{ N}_{r} F x) · (pt I_{M} x)
       =
       # F luinv^{ M }_{ x}.

  Definition preserves_rightunitality
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (pt : preserves_tensordata M N F)
             (pu : preserves_unit M N F)
    : UU
    := ∏ (x : C),
       ((F x ⊗^{ N}_{l} pu) · (pt x I_{M}) · (# F ru^{ M }_{ x})
       =
       ru^{ N }_{ F x}).

  Definition preserves_rightunitalityinv
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (pt : preserves_tensordata M N F)
             (pu : preserves_unit M N F)
    : UU
    := ∏ (x : C),
       ruinv^{ N }_{ F x} · F x ⊗^{ N}_{l} pu · pt x I_{M}
       =
       # F ruinv^{ M }_{ x}.

  Definition preserves_associativity
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (pt : preserves_tensordata M N F)
    : UU
    := ∏ (x y z : C),
       ((pt x y) ⊗^{N}_{r} (F z)) · (pt (x ⊗_{M} y) z) · (#F (α^{M}_{x,y,z}))
       =
       α^{N}_{F x, F y, F z} · ((F x) ⊗^{N}_{l} (pt y z)) · (pt x (y ⊗_{M} z)).

  Definition preserves_associativityinv
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (pt : preserves_tensordata M N F)
    : UU
    := ∏ (x y z : C),
       αinv^{N}_{F x, F y, F z} · ((pt x y) ⊗^{N}_{r} (F z)) · (pt (x ⊗_{M} y) z)
       =
       ((F x) ⊗^{N}_{l} (pt y z)) · (pt x (y ⊗_{M} z)) · (#F (αinv^{M}_{x,y,z})).

  Definition fmonoidal_laxlaws
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (fmd : fmonoidal_data M N F)
    : UU
    := (preserves_tensor_nat_left (fmonoidal_preservestensordata fmd)) ×
       (preserves_tensor_nat_right (fmonoidal_preservestensordata fmd)) ×
       (preserves_associativity (fmonoidal_preservestensordata fmd)) ×
       (preserves_leftunitality
          (fmonoidal_preservestensordata fmd)
          (fmonoidal_preservesunit fmd)) ×
       (preserves_rightunitality
          (fmonoidal_preservestensordata fmd)
          (fmonoidal_preservesunit fmd)).

  Definition fmonoidal_lax
             {C D : category}
             (M : monoidal C)
             (N : monoidal D)
             (F : functor C D)
    : UU
    := ∑ (fmd : fmonoidal_data M N F), fmonoidal_laxlaws fmd.

  Definition fmonoidal_fdata
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (fm : fmonoidal_lax M N F)
    : fmonoidal_data M N F
    := pr1 fm.
  Coercion fmonoidal_fdata : fmonoidal_lax >-> fmonoidal_data.

  Definition fmonoidal_flaws
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (fm : fmonoidal_lax M N F)
    : fmonoidal_laxlaws fm
    := pr2 fm.

  Definition fmonoidal_preservestensornatleft
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (fm : fmonoidal_lax M N F)
    : preserves_tensor_nat_left (fmonoidal_preservestensordata fm)
    := pr12 fm.

  Definition fmonoidal_preservestensornatright
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (fm : fmonoidal_lax M N F)
    : preserves_tensor_nat_right (fmonoidal_preservestensordata fm)
    := pr122 fm.

  Definition fmonoidal_preservesassociativity
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (fm : fmonoidal_lax M N F)
    : preserves_associativity (fmonoidal_preservestensordata fm)
    := pr1 (pr222 fm).

  Lemma fmonoidal_preservesassociativityinv
        {C D : category}
        {M : monoidal C}
        {N : monoidal D}
        {F : functor C D}
        (fm : fmonoidal_lax M N F)
    : preserves_associativityinv (fmonoidal_preservestensordata fm).
  Proof.
    intros x y z.
    rewrite assoc'.
    apply (z_iso_inv_on_right _ _ _ (_,,_,, monoidal_associatorisolaw N _ _ _)).
    cbn.
    etrans.
    2: { repeat rewrite assoc. apply cancel_postcomposition.
         apply fmonoidal_preservesassociativity. }
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    2: { apply maponpaths.
         rewrite <- functor_comp.
         apply maponpaths.
         apply pathsinv0, (monoidal_associatorisolaw M). }
    rewrite functor_id.
    apply pathsinv0, id_right.
  Qed.

  Definition fmonoidal_preservesleftunitality
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (fm : fmonoidal_lax M N F)
    : preserves_leftunitality
        (fmonoidal_preservestensordata fm)
        (fmonoidal_preservesunit fm)
    := pr12 (pr222 fm).

  Lemma fmonoidal_preservesleftunitalityinv
        {C D : category}
        {M : monoidal C}
        {N : monoidal D}
        {F : functor C D}
        (fm : fmonoidal_lax M N F)
    : preserves_leftunitalityinv
        (fmonoidal_preservestensordata fm)
        (fmonoidal_preservesunit fm).
  Proof.
    intro x.
    rewrite assoc'.
    apply (z_iso_inv_on_right _ _ _ (_,,_,, monoidal_leftunitorisolaw N (F x))).
    cbn.
    rewrite <- (fmonoidal_preservesleftunitality fm).
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    2: { apply maponpaths.
         apply functor_comp. }
    etrans.
    2: { do 2 apply maponpaths.
         apply pathsinv0, (pr1(monoidal_leftunitorisolaw M x)). }
    rewrite functor_id.
    apply pathsinv0, id_right.
  Qed.

  Definition fmonoidal_preservesrightunitality
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             (fm : fmonoidal_lax M N F)
    : preserves_rightunitality
        (fmonoidal_preservestensordata fm)
        (fmonoidal_preservesunit fm)
    := pr22 (pr222 fm).

  Lemma fmonoidal_preservesrightunitalityinv
        {C D : category}
        {M : monoidal C}
        {N : monoidal D}
        {F : functor C D}
        (fm : fmonoidal_lax M N F)
    : preserves_rightunitalityinv
        (fmonoidal_preservestensordata fm)
        (fmonoidal_preservesunit fm).
  Proof.
    intro x.
    rewrite assoc'.
    apply (z_iso_inv_on_right _ _ _ (_,,_,, monoidal_rightunitorisolaw N (F x))).
    cbn.
    rewrite <- (fmonoidal_preservesrightunitality fm).
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    2: { apply maponpaths.
         apply functor_comp. }
    etrans.
    2: { do 2 apply maponpaths.
         apply pathsinv0, (pr1(monoidal_rightunitorisolaw M x)). }
    rewrite functor_id.
    apply pathsinv0, id_right.
  Qed.

  Definition preserves_tensor_strongly
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             (pt : preserves_tensordata M N F)
    : UU
    := ∏ (x y : C), is_z_isomorphism (pt x y).

  Definition pointwise_z_iso_from_preserves_tensor_strongly
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             {pt : preserves_tensordata M N F}
             (pts : preserves_tensor_strongly pt) (x y : C)
    : z_iso (F x ⊗_{ N} F y) (F (x ⊗_{ M} y))
    := pt x y ,, pts x y.

  Lemma preserves_associativity_of_inverse_preserves_tensor
        {C D : category}
        {M : monoidal C} {N : monoidal D}
        {F : functor C D}
        {pt : preserves_tensordata M N F}
        (ptα : preserves_associativity pt)
        (pts : preserves_tensor_strongly pt) (x y z : C)
    : (is_z_isomorphism_mor (pts (x ⊗_{M} y) z))
      · ((is_z_isomorphism_mor (pts x y)) ⊗^{N}_{r} (F z))
      · α^{N}_{F x, F y, F z}
      =
      (#F (α^{M}_{x,y,z}))
      · (is_z_isomorphism_mor (pts x (y ⊗_{M} z)))
      · ((F x) ⊗^{N}_{l} (is_z_isomorphism_mor (pts y z))).
  Proof.
    set (ptsx_yz := pointwise_z_iso_from_preserves_tensor_strongly pts x (y ⊗_{M} z)).
    set (ptsxy_z := pointwise_z_iso_from_preserves_tensor_strongly pts (x ⊗_{M} y) z).
    set (ptsfx := functor_on_z_iso
          (leftwhiskering_functor N (F x))
          (pointwise_z_iso_from_preserves_tensor_strongly pts y z)).
    set (ptsfz := functor_on_z_iso
          (rightwhiskering_functor N (F z))
          (pointwise_z_iso_from_preserves_tensor_strongly pts x y)).

    apply (z_iso_inv_on_left _ _ _ _ ptsfx).
    apply pathsinv0.
    apply (z_iso_inv_on_left _ _ _ _ ptsx_yz).
    rewrite assoc'.
    rewrite assoc'.
    etrans.
    2: {
      apply maponpaths.
      rewrite assoc.
      exact (ptα x y z).
    }
    etrans.
    2: {
      rewrite assoc'.
      apply maponpaths.
      rewrite assoc.
      apply maponpaths_2.
      rewrite assoc.
      apply maponpaths_2.
      exact (! pr222 ptsfz).
    }
    rewrite id_left.
    etrans.
    2: {
      rewrite assoc.
      apply maponpaths_2.
      exact (! pr222 ptsxy_z).
    }
    apply (! id_left _).
  Qed.

  Lemma preserves_tensorinv_nat_right
        {C D : category}
        {M : monoidal C} {N : monoidal D}
        {F : functor C D}
        {pt : preserves_tensordata M N F}
        (pts : preserves_tensor_strongly pt)
        (ptrn : preserves_tensor_nat_right pt)
        (x1 x2 y : C)
        (f : C⟦x1,x2⟧)
    : (is_z_isomorphism_mor (pts x1 y)) · # F f ⊗^{ N}_{r} F y
      =
      # F (f ⊗^{ M}_{r} y) · (is_z_isomorphism_mor (pts x2 y)).
  Proof.
    set (ptiso := pt x1 y ,, pts x1 y : z_iso _ _).
    apply (z_iso_inv_on_right _ _ _ ptiso).
    rewrite assoc.
    etrans.
    2: {
      apply maponpaths_2.
      apply ptrn.
    }
    rewrite assoc'.
    unfold is_z_isomorphism_mor.
    rewrite (pr12 (pts x2 y)).
    apply (! id_right _).
  Qed.

  Lemma preserves_tensorinv_nat_left
        {C D : category}
        {M : monoidal C} {N : monoidal D}
        {F : functor C D}
        {pt : preserves_tensordata M N F}
        (pts : preserves_tensor_strongly pt)
        (ptrn : preserves_tensor_nat_left pt)
        (x1 x2 y : C)
        (f : C⟦x1,x2⟧)
    : (is_z_isomorphism_mor (pts y x1)) · F y ⊗^{ N}_{l} # F f
      =
      # F (y ⊗^{ M}_{l} f) · (is_z_isomorphism_mor (pts y x2)).
  Proof.
    set (ptiso := pt y x1 ,, pts y x1 : z_iso _ _).
    apply (z_iso_inv_on_right _ _ _ ptiso).
    rewrite assoc.
    etrans.
    2: {
      apply maponpaths_2.
      apply ptrn.
    }
    rewrite assoc'.
    unfold is_z_isomorphism_mor.
    rewrite (pr12 (pts y x2)).
    apply (! id_right _).
  Qed.

  Definition preserves_unit_strongly
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             (pu : preserves_unit M N F)
    : UU
    := is_z_isomorphism pu.

  Definition fmonoidal_stronglaws
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             (pt : preserves_tensordata M N F)
             (pu : preserves_unit M N F)
    : UU
    := preserves_tensor_strongly pt × preserves_unit_strongly pu.

  (**
   2. Strong monoidal functors
   *)
  Definition fmonoidal
             {C D : category}
             (M : monoidal C)
             (N : monoidal D)
             (F : functor C D)
    : UU :=
    ∑ (Fm : fmonoidal_lax M N F),
      fmonoidal_stronglaws (fmonoidal_preservestensordata Fm) (fmonoidal_preservesunit Fm).

  Definition fmonoidal_fmonoidallax
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             (Fm : fmonoidal M N F)
    : fmonoidal_lax M N F
    := pr1 Fm.
  Coercion fmonoidal_fmonoidallax : fmonoidal >-> fmonoidal_lax.

  Definition fmonoidal_preservestensorstrongly
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             (Fm : fmonoidal M N F)
    : preserves_tensor_strongly (fmonoidal_preservestensordata Fm)
    := pr12 Fm.

  Definition fmonoidal_preservesunitstrongly
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             (Fm : fmonoidal M N F)
    : preserves_unit_strongly (fmonoidal_preservesunit Fm)
    := pr22 Fm.

  (** We now show that everything behaves as expected **)
  Definition functor_imageoftensor
             {C D : category}
             (M : monoidal C)
             (F : functor C D)
    : bifunctor C C D
    := compose_bifunctor_with_functor M F.

  Definition functor_tensorofimages
             {C D : category}
             (F : functor C D)
             (N : monoidal D)
    : bifunctor C C D
    := compose_functor_with_bifunctor F F N.

  Definition preserves_tensor_is_nattrans_type
             {C D : category}
             (M : monoidal C)
             (N : monoidal D)
             (F : functor C D)
    : UU
    := binat_trans (functor_tensorofimages F N) (functor_imageoftensor M F).

  (* I really don't know how to call the following lemma *)
  Definition preservestensor_is_nattrans
             {C D : category}
             {M : monoidal C}
             {N : monoidal D}
             {F : functor C D}
             {pt : preserves_tensordata M N F}
             (ptnl : preserves_tensor_nat_left pt)
             (ptnr : preserves_tensor_nat_right pt)
    : preserves_tensor_is_nattrans_type M N F.
  Proof.
    use make_binat_trans.
    - use make_binat_trans_data.
      intros x y.
      apply pt.
    - use tpair.
      + intros x y1 y2 g.
        apply ptnl.
      + intros x1 x2 y f.
        apply ptnr.
  Defined.

  Lemma preservestensor_is_nattrans_full
        {C D : category}
        {M : monoidal C}
        {N : monoidal D}
        {F : functor C D}
        {pt : preserves_tensordata M N F}
        (ptnl : preserves_tensor_nat_left pt)
        (ptnr : preserves_tensor_nat_right pt)
    : ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧),
      # F f ⊗^{ N} # F g · pt x2 y2 = pt x1 y1 · # F (f ⊗^{ M} g).
  Proof.
    intros.
    etrans.
    { unfold functoronmorphisms1.
      rewrite assoc'.
      rewrite ptnl.
      apply assoc. }
    rewrite ptnr.
    rewrite assoc'.
    apply maponpaths.
    apply pathsinv0, functor_comp.
  Qed.

  Definition preserves_tensor_inv_is_nattrans_type
             {C D : category}
             (M : monoidal C) (N : monoidal D)
             (F : functor C D)
    : UU
    := binat_trans (functor_imageoftensor M F) (functor_tensorofimages F N).

  (* name follows [preservestensor_is_nattrans], for lack of a better proposition *)
  Definition preservestensor_inv_is_nattrans
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             {pt : preserves_tensordata M N F}
             (ptnl : preserves_tensor_nat_left pt)
             (ptnr : preserves_tensor_nat_right pt)
             (ptstr: preserves_tensor_strongly pt)
    : preserves_tensor_inv_is_nattrans_type M N F
    := inv_binattrans_from_binatiso(α:=preservestensor_is_nattrans ptnl ptnr) ptstr.

  Definition preserves_leftunitality'
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             {pt : preserves_tensordata M N F}
             {pu : preserves_unit M N F}
             (plu : preserves_leftunitality pt pu)
    : ∏ (x : C),
      (pu ⊗^{N} (identity (F x))) · (pt I_{M} x) · (#F (lu^{M}_{x}))
      =
      lu^{N}_{F x}.
  Proof.
    intro x.
    unfold functoronmorphisms1.
    rewrite (bifunctor_leftid N).
    rewrite id_right.
    apply plu.
  Qed.

  Definition preserves_rightunitality'
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             {pt : preserves_tensordata M N F}
             {pu : preserves_unit M N F}
             (pru : preserves_rightunitality pt pu)
    : ∏ (x : C),
      ((identity (F x)) ⊗^{N} pu) · (pt x I_{M}) · (#F (ru^{M}_{x}))
      =
      ru^{N}_{F x}.
  Proof.
    intro x.
    unfold functoronmorphisms1.
    rewrite (bifunctor_rightid N).
    rewrite id_left.
    apply pru.
  Qed.

  Definition preserves_leftunitality''
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D} (Fm : fmonoidal M N F)
    : ∏ (x : C),
      (pr1 (fmonoidal_preservestensorstrongly Fm I_{M} x))
      · (pr1 (fmonoidal_preservesunitstrongly Fm) ⊗^{N} (identity (F x)))
      · lu^{N}_{F x}
      =
      #F (lu^{M}_{x}).
  Proof.
    intro x.
    set (plu := preserves_leftunitality' (fmonoidal_preservesleftunitality (pr1 Fm)) x).
    rewrite (! plu).
    rewrite ! assoc.

    etrans. {
      apply maponpaths_2.
      apply maponpaths_2.
      rewrite assoc'.
      apply maponpaths.
      unfold functoronmorphisms1.
      do 2 rewrite (bifunctor_leftid N).
      do 2 rewrite id_right.
      rewrite <- (bifunctor_rightcomp N).
      apply maponpaths.
      apply (fmonoidal_preservesunitstrongly Fm).
    }
    rewrite bifunctor_rightid.
    rewrite id_right.
    etrans. {
      apply maponpaths_2.
      apply (fmonoidal_preservestensorstrongly Fm).
    }
    apply id_left.
  Qed.

  (**
   3. Strict monoidal functors
   *)
  (* Strictly preserving monoidal functors *)
  Definition preserves_tensor_strictly
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             (pt : preserves_tensordata M N F)
    : UU
    := ∏ (x y : C), ∑ (pf : (F x) ⊗_{N} (F y) = F (x ⊗_{M} y)),
       pt x y = transportf _ pf (identity ((F x) ⊗_{N} (F y))).

  Lemma strictlytensorpreserving_is_strong
        {C D : category}
        {M : monoidal C} {N : monoidal D}
        {F : functor C D}
        {pt : preserves_tensordata M N F}
        (pst : preserves_tensor_strictly pt)
    : preserves_tensor_strongly pt.
  Proof.
    intros x y.
    use (iso_stable_under_equalitytransportf
           (pr2 (pst x y))
           (is_z_isomorphism_identity (F x ⊗_{N} F y))).
  Qed.

  Definition preserves_unit_strictly
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             (pu : preserves_unit M N F) : UU
    := ∑ (pf : I_{N} = (F I_{M})),
       pu = transportf _ pf (identity I_{N}).

  Definition strictlyunitpreserving_is_strong
             {C D : category}
             {M : monoidal C} {N : monoidal D}
             {F : functor C D}
             {pu : preserves_unit M N F}
             (pus : preserves_unit_strictly pu)
    : preserves_unit_strongly pu.
  Proof.
    use (iso_stable_under_equalitytransportf (pr2 pus) (is_z_isomorphism_identity I_{N})).
  Defined.

  (**
   4. The identity is strong monoidal
   *)
  (** towards a bicategory of monoidal categories *)
  Definition identity_fmonoidal_data
             {C : category}
             (M : monoidal C)
    : fmonoidal_data M M (functor_identity C).
  Proof.
    split.
    - intros x y. apply identity.
    - apply identity.
  Defined.

  Lemma identity_fmonoidal_laxlaws
        {C : category}
        (M : monoidal C)
    : fmonoidal_laxlaws (identity_fmonoidal_data M).
  Proof.
    repeat split; red; unfold fmonoidal_preservesunit, fmonoidal_preservestensordata; cbn; intros.
    - rewrite id_left. apply id_right.
    - rewrite id_left. apply id_right.
    - do 2 rewrite id_right.
      rewrite (bifunctor_rightid M).
      rewrite (bifunctor_leftid M).
      rewrite id_right.
      apply id_left.
    - rewrite id_right.
      rewrite (bifunctor_rightid M).
      apply id_left.
    - rewrite id_right.
      rewrite (bifunctor_leftid M).
      apply id_left.
  Qed.

  Definition identity_fmonoidal_lax
             {C : category}
             (M : monoidal C)
    : fmonoidal_lax M M (functor_identity C)
    := identity_fmonoidal_data M ,, identity_fmonoidal_laxlaws M.

  Definition identity_fmonoidal_stronglaws
             {C : category}
             (M : monoidal C)
    : fmonoidal_stronglaws
        (fmonoidal_preservestensordata (identity_fmonoidal_lax M))
        (fmonoidal_preservesunit (identity_fmonoidal_lax M)).
  Proof.
    split.
    - intros x y. apply is_z_isomorphism_identity.
    - apply is_z_isomorphism_identity.
  Defined.

  Definition identity_fmonoidal
             {C : category}
             (M : monoidal C)
    : fmonoidal M M (functor_identity C)
    := identity_fmonoidal_lax M ,, identity_fmonoidal_stronglaws M.

  (**
   5. Composition preserves lax/strongly monoidal functors
   *)
  Definition comp_fmonoidal_data
             {C D E : category}
             {M : monoidal C} {N : monoidal D} {O : monoidal E}
             {F : C ⟶ D} {G : D ⟶ E}
             (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax N O G)
    : fmonoidal_data M O (F ∙ G).
  Proof.
    split.
    - intros x y.
      exact (fmonoidal_preservestensordata Gm (F x) (F y)
             · #G (fmonoidal_preservestensordata Fm x y)).
    - exact (fmonoidal_preservesunit Gm
            · #G (fmonoidal_preservesunit Fm)).
  Defined.

  Lemma comp_fmonoidal_laxlaws
        {C D E : category}
        {M : monoidal C} {N : monoidal D} {O : monoidal E}
        {F : C ⟶ D} {G : D ⟶ E}
        (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax N O G)
    : fmonoidal_laxlaws (comp_fmonoidal_data Fm Gm).
  Proof.
    repeat split; red; cbn; unfold fmonoidal_preservesunit, fmonoidal_preservestensordata; cbn; intros.
    - etrans.
      2: { rewrite assoc'. apply maponpaths. apply functor_comp. }
      etrans.
      2: { do 2 apply maponpaths. apply fmonoidal_preservestensornatleft. }
      rewrite functor_comp.
      repeat rewrite assoc.
      apply cancel_postcomposition.
      apply fmonoidal_preservestensornatleft.
    - etrans.
      2: { rewrite assoc'. apply maponpaths. apply functor_comp. }
      etrans.
      2: { do 2 apply maponpaths. apply fmonoidal_preservestensornatright. }
      rewrite functor_comp.
      repeat rewrite assoc.
      apply cancel_postcomposition.
      apply fmonoidal_preservestensornatright.
    - assert (auxF := fmonoidal_preservesassociativity Fm x y z).
      unfold fmonoidal_preservestensordata in auxF.
      assert (auxG := fmonoidal_preservesassociativity Gm (F x) (F y) (F z)).
      unfold fmonoidal_preservestensordata in auxG.
      rewrite (bifunctor_leftcomp O).
      rewrite (bifunctor_rightcomp O).
      etrans.
      2: { repeat rewrite assoc. apply cancel_postcomposition.
           repeat rewrite assoc'. do 2 apply maponpaths.
           apply pathsinv0, fmonoidal_preservestensornatleft. }
      etrans.
      2: { apply cancel_postcomposition.
           repeat rewrite assoc. apply cancel_postcomposition.
           exact auxG. }
      repeat rewrite assoc'. apply maponpaths.
      etrans.
      2: { apply maponpaths.
           rewrite <- functor_comp.
           apply functor_comp. }
      etrans.
      2: { do 2 apply maponpaths.
           rewrite assoc.
           exact auxF. }
      do 2 rewrite functor_comp.
      repeat rewrite assoc.
      do 2 apply cancel_postcomposition.
      apply fmonoidal_preservestensornatright.
    - assert (auxF := fmonoidal_preservesleftunitality Fm x).
      assert (auxG := fmonoidal_preservesleftunitality Gm (F x)).
      unfold fmonoidal_preservesunit, fmonoidal_preservestensordata in auxF, auxG.
      etrans; [| exact auxG].
      clear auxG.
      rewrite (bifunctor_rightcomp O).
      rewrite <- auxF.
      clear auxF.
      do 2 rewrite functor_comp.
      repeat rewrite assoc.
      do 2 apply cancel_postcomposition.
      repeat rewrite assoc'.
      apply maponpaths.
      apply fmonoidal_preservestensornatright.
    - assert (auxF := fmonoidal_preservesrightunitality Fm x).
      assert (auxG := fmonoidal_preservesrightunitality Gm (F x)).
      unfold fmonoidal_preservesunit, fmonoidal_preservestensordata in auxF, auxG.
      etrans; [| exact auxG].
      clear auxG.
      rewrite (bifunctor_leftcomp O).
      rewrite <- auxF.
      clear auxF.
      do 2 rewrite functor_comp.
      repeat rewrite assoc.
      do 2 apply cancel_postcomposition.
      repeat rewrite assoc'.
      apply maponpaths.
      apply fmonoidal_preservestensornatleft.
  Qed.

  Definition comp_fmonoidal_lax
             {C D E : category}
             {M : monoidal C} {N : monoidal D} {O : monoidal E}
             {F : C ⟶ D} {G : D ⟶ E}
             (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax N O G)
    : fmonoidal_lax M O (F ∙ G)
    := comp_fmonoidal_data Fm Gm ,, comp_fmonoidal_laxlaws Fm Gm.

  Section CompStrongMonoidal.
    Context {C D E : category}
            {M : monoidal C} {N : monoidal D} {O : monoidal E}
            {F : C ⟶ D} {G : D ⟶ E}
            (Fm : fmonoidal M N F) (Gm : fmonoidal N O G).

    Let comp_fmnoidal_unit_inv
      : G (F I_{M}) --> I_{O}
      := #G (pr1 (fmonoidal_preservesunitstrongly Fm))
         · pr1 (fmonoidal_preservesunitstrongly Gm).

    Let comp_fmonoidal_tensor_inv
        (x y : C)
      : G (F (x ⊗_{ M } y)) --> G (F x) ⊗_{ O } G (F y)
      := #G (pr1 (fmonoidal_preservestensorstrongly Fm x y))
         · pr1 (fmonoidal_preservestensorstrongly Gm (F x) (F y)).

    Lemma comp_fmonoidal_tensor_inv_laws
          (x y : C)
      : is_inverse_in_precat
          (fmonoidal_preservestensordata (comp_fmonoidal_lax Fm Gm) x y)
          (comp_fmonoidal_tensor_inv x y).
    Proof.
      unfold comp_fmonoidal_tensor_inv.
      split.
      - cbn.
        etrans.
        {
          rewrite !assoc'.
          apply maponpaths.
          rewrite assoc.
          apply cancel_postcomposition.
          rewrite <- functor_comp.
          apply maponpaths.
          apply (pr12 (fmonoidal_preservestensorstrongly Fm x y)).
        }
        rewrite functor_id.
        rewrite id_left.
        apply (pr12 (fmonoidal_preservestensorstrongly Gm (F x) (F y))).
      - cbn.
        etrans.
        {
          rewrite !assoc'.
          apply maponpaths.
          rewrite assoc.
          apply cancel_postcomposition.
          apply (pr22 (fmonoidal_preservestensorstrongly Gm (F x) (F y))).
        }
        rewrite id_left.
        rewrite <- functor_comp.
        etrans.
        {
          apply maponpaths.
          apply (pr22 (fmonoidal_preservestensorstrongly Fm x y)).
        }
        apply functor_id.
    Qed.

    Lemma comp_fmonoidal_unit_inv_laws
      : is_inverse_in_precat
          (fmonoidal_preservesunit (comp_fmonoidal_lax Fm Gm))
          comp_fmnoidal_unit_inv.
    Proof.
      unfold comp_fmnoidal_unit_inv.
      split.
      - cbn.
        etrans.
        {
          rewrite !assoc'.
          apply maponpaths.
          rewrite assoc.
          apply cancel_postcomposition.
          rewrite <- functor_comp.
          apply maponpaths.
          apply (pr12 (fmonoidal_preservesunitstrongly Fm)).
        }
        rewrite functor_id.
        rewrite id_left.
        apply (pr12 (fmonoidal_preservesunitstrongly Gm)).
      - cbn.
        etrans.
        {
          rewrite !assoc'.
          apply maponpaths.
          rewrite assoc.
          apply cancel_postcomposition.
          apply (pr22 (fmonoidal_preservesunitstrongly Gm)).
        }
        rewrite id_left.
        rewrite <- functor_comp.
        etrans.
        {
          apply maponpaths.
          apply (pr22 (fmonoidal_preservesunitstrongly Fm)).
        }
        apply functor_id.
    Qed.

    Definition comp_fmonoidal_stronglaws
      : fmonoidal_stronglaws
          (fmonoidal_preservestensordata (comp_fmonoidal_lax Fm Gm))
          (fmonoidal_preservesunit (comp_fmonoidal_lax Fm Gm)).
    Proof.
      split.
      - intros x y.
        use make_is_z_isomorphism.
        + exact (comp_fmonoidal_tensor_inv x y).
        + exact (comp_fmonoidal_tensor_inv_laws x y).
      - use make_is_z_isomorphism.
        + exact comp_fmnoidal_unit_inv.
        + exact comp_fmonoidal_unit_inv_laws.
    Defined.

    Definition comp_fmonoidal
      : fmonoidal M O (F ∙ G)
      := comp_fmonoidal_lax Fm Gm ,, comp_fmonoidal_stronglaws.
  End CompStrongMonoidal.
End MonoidalFunctors.

(**
 6. Monoidal natural transformations
 *)
Section MonoidalNaturalTransformations.

  Context {C D : category}
          {M : monoidal C} {N : monoidal D}
          {F G : functor C D}
          (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax M N G)
          (α : F ⟹ G).

  Definition is_mon_nat_trans_tensorlaw
    : UU
    := ∏ (a a' : C),
       fmonoidal_preservestensordata Fm a a' · α (a ⊗_{M} a')
       =
       α a ⊗^{N} α a' · fmonoidal_preservestensordata Gm a a'.

  Definition is_mon_nat_trans_unitlaw : UU
    := fmonoidal_preservesunit Fm · α I_{M} = fmonoidal_preservesunit Gm.

  Definition is_mon_nat_trans : UU := is_mon_nat_trans_tensorlaw × is_mon_nat_trans_unitlaw.

  Lemma isaprop_is_mon_nat_trans : isaprop is_mon_nat_trans.
  Proof.
    apply isapropdirprod.
    - apply impred; intro a; apply impred; intro a'.
      apply D.
    - apply D.
  Qed.
End MonoidalNaturalTransformations.

(**
 7. Inverses of monoidal natural transformations
 *)
Section InverseMonoidalNaturalTransformation.
  Context {C D : category}
          {M : monoidal C} {N : monoidal D}
          {F G : functor C D}
          (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax M N G)
          (α : F ⟹ G).

  Lemma is_mon_nat_trans_pointwise_inverse
        (isnziα : is_nat_z_iso α)
    : is_mon_nat_trans Fm Gm α
      ->
      is_mon_nat_trans Gm Fm (nat_z_iso_inv (α,,isnziα)).
  Proof.
    intro ismnt. split.
    - intros x y.
      cbn.
      unfold fmonoidal_preservestensordata.
      set (aux := (_,, is_z_iso_bifunctor_z_iso N _ _ (isnziα x) (isnziα y)) : z_iso _ _).
      apply pathsinv0, (z_iso_inv_on_right _ _ _ aux).
      rewrite assoc.
      apply (z_iso_inv_on_left _ _ _ _ (_,,isnziα (x ⊗_{ M} y))).
      cbn.
      apply (!(pr1 ismnt x y)).
    - cbn.
      apply pathsinv0, (z_iso_inv_on_left _ _ _ _ (_,,isnziα I_{M})).
      apply (!(pr2 ismnt)).
  Qed.
End InverseMonoidalNaturalTransformation.

Local Open Scope moncat.

(**
 8. Bundled versions
 *)
Definition lax_monoidal_functor
           (V₁ V₂ : monoidal_cat)
  : UU
  := ∑ (F : V₁ ⟶ V₂), fmonoidal_lax V₁ V₂ F.

Coercion lax_monoidal_functor_to_functor
         {V₁ V₂ : monoidal_cat}
         (F : lax_monoidal_functor V₁ V₂)
  : V₁ ⟶ V₂
  := pr1 F.

Definition strong_monoidal_functor
           (V₁ V₂ : monoidal_cat)
  : UU
  := ∑ (F : V₁ ⟶ V₂), fmonoidal V₁ V₂ F.

Coercion strong_monoidal_functor_to_lax_monoidal_functor
         {V₁ V₂ : monoidal_cat}
         (F : strong_monoidal_functor V₁ V₂)
  : lax_monoidal_functor V₁ V₂
  := pr1 F ,, pr12 F.

Definition mon_functor_unit
           {V₁ V₂ : monoidal_cat}
           (F : lax_monoidal_functor V₁ V₂)
  : I_{V₂} --> F (I_{V₁})
  := pr212 F.

Definition mon_functor_tensor
           {V₁ V₂ : monoidal_cat}
           (F : lax_monoidal_functor V₁ V₂)
           (x y : V₁)
  : F x ⊗ F y --> F(x ⊗ y)
  := pr112 F x y.

Section MonoidalFunctorAccessors.
  Context {V₁ V₂ : monoidal_cat}
          (F : lax_monoidal_functor V₁ V₂).

  Definition tensor_mon_functor_tensor
             {x₁ x₂ y₁ y₂ : V₁}
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
    : #F f #⊗ #F g · mon_functor_tensor F x₂ y₂
      =
      mon_functor_tensor F x₁ y₁ · #F (f #⊗ g).
  Proof.
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      apply (fmonoidal_preservestensornatleft (pr2 F)).
    }
    rewrite !assoc.
    etrans.
    {
      apply maponpaths_2.
      apply (fmonoidal_preservestensornatright (pr2 F)).
    }
    rewrite !assoc'.
    apply maponpaths.
    rewrite <- functor_comp.
    apply idpath.
  Qed.

  Definition mon_functor_lassociator
             (x y z : V₁)
    : mon_functor_tensor F x y #⊗ identity (F z)
      · mon_functor_tensor F (x ⊗ y) z
      · #F (mon_lassociator x y z)
      =
      mon_lassociator (F x) (F y) (F z)
      · identity (F x) #⊗ mon_functor_tensor F y z
      · mon_functor_tensor F x (y ⊗ z).
  Proof.
    refine (_ @ fmonoidal_preservesassociativity (pr2 F) x y z @ _).
    - apply maponpaths_2.
      apply maponpaths_2.
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      refine (_ @ id_right _).
      apply maponpaths.
      apply (bifunctor_leftid V₂).
    - apply maponpaths_2.
      apply maponpaths.
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      refine (!(id_left _) @ _).
      apply maponpaths_2.
      refine (!_).
      apply (bifunctor_rightid V₂).
  Qed.

  Definition mon_functor_rassociator
             (x y z : V₁)
    : mon_rassociator (F x) (F y) (F z)
      · mon_functor_tensor F x y #⊗ identity (F z)
      · mon_functor_tensor F (x ⊗ y) z
      =
      identity (F x) #⊗ mon_functor_tensor F y z
      · mon_functor_tensor F x (y ⊗ z)
      · #F (mon_rassociator x y z).
  Proof.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      refine (!(id_left _) @ _).
      etrans.
      {
        apply maponpaths_2.
        refine (!_).
        apply mon_rassociator_lassociator.
      }
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      refine (!_).
      apply mon_functor_lassociator.
    }
    rewrite !assoc'.
    do 2 apply maponpaths.
    refine (_ @ id_right _).
    apply maponpaths.
    refine (!(functor_comp _ _ _) @ _ @ functor_id _ _).
    apply maponpaths.
    apply mon_lassociator_rassociator.
  Qed.

  Definition mon_functor_lunitor
             (x : V₁)
    : mon_lunitor (F x)
      =
      mon_functor_unit F #⊗ identity (F x)
      · mon_functor_tensor F (I_{V₁}) x
      · #F (mon_lunitor x).
  Proof.
    refine (!(fmonoidal_preservesleftunitality (pr2 F) x) @ _).
    do 2 apply maponpaths_2.
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    refine (!(id_right _) @ _).
    apply maponpaths.
    refine (!_).
    apply (bifunctor_leftid V₂).
  Qed.

  Definition mon_functor_linvunitor
             (x : V₁)
    : #F (mon_linvunitor x)
      =
      mon_linvunitor (F x)
      · mon_functor_unit F #⊗ identity (F x)
      · mon_functor_tensor F (I_{V₁}) x.
  Proof.
    refine (!(id_left _) @ _).
    etrans.
    {
      apply maponpaths_2.
      refine (!_).
      apply mon_linvunitor_lunitor.
    }
    rewrite !assoc'.
    apply maponpaths.
    etrans.
    {
      apply maponpaths_2.
      apply mon_functor_lunitor.
    }
    rewrite !assoc'.
    apply maponpaths.
    refine (_ @ id_right _).
    apply maponpaths.
    refine (!(functor_comp _ _ _) @ _ @ functor_id _ _).
    apply maponpaths.
    apply mon_lunitor_linvunitor.
  Qed.

  Definition mon_functor_runitor
             (x : V₁)
    : mon_runitor (F x)
      =
      identity (F x) #⊗ mon_functor_unit F
      · mon_functor_tensor F x (I_{V₁})
      · #F (mon_runitor x).
  Proof.
    refine (!(fmonoidal_preservesrightunitality (pr2 F) x) @ _).
    do 2 apply maponpaths_2.
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    refine (!(id_left _) @ _).
    apply maponpaths_2.
    refine (!_).
    apply (bifunctor_rightid V₂).
  Qed.

  Definition mon_functor_rinvunitor
             (x : V₁)
    : #F (mon_rinvunitor x)
      =
      mon_rinvunitor (F x)
      · identity (F x) #⊗ mon_functor_unit F
      · mon_functor_tensor F x (I_{V₁}).
  Proof.
    refine (!(id_left _) @ _).
    etrans.
    {
      apply maponpaths_2.
      refine (!_).
      apply mon_rinvunitor_runitor.
    }
    rewrite !assoc'.
    apply maponpaths.
    etrans.
    {
      apply maponpaths_2.
      apply mon_functor_runitor.
    }
    rewrite !assoc'.
    apply maponpaths.
    refine (_ @ id_right _).
    apply maponpaths.
    refine (!(functor_comp _ _ _) @ _ @ functor_id _ _).
    apply maponpaths.
    apply mon_runitor_rinvunitor.
  Qed.
End MonoidalFunctorAccessors.

Section StrongMonoidalFunctorAccessors.
  Context {V₁ V₂ : monoidal_cat}
          (F : strong_monoidal_functor V₁ V₂).

  Definition strong_functor_unit_inv
    : F (I_{V₁}) --> I_{V₂}.
  Proof.
    exact (inv_from_z_iso (_ ,, fmonoidal_preservesunitstrongly (pr2 F))).
  Defined.

  Definition strong_functor_unit_inv_unit
    : strong_functor_unit_inv · mon_functor_unit F = identity _.
  Proof.
    apply z_iso_after_z_iso_inv.
  Qed.

  Definition strong_functor_unit_unit_inv
    : mon_functor_unit F · strong_functor_unit_inv = identity _.
  Proof.
    apply (z_iso_inv_after_z_iso (_ ,, fmonoidal_preservesunitstrongly (pr2 F))).
  Qed.

  Definition strong_functor_tensor_inv
             (x y : V₁)
    : F(x ⊗ y) --> F x ⊗ F y.
  Proof.
    exact (inv_from_z_iso (_ ,, fmonoidal_preservestensorstrongly (pr2 F) x y)).
  Defined.

  Definition strong_functor_tensor_inv_tensor
             (x y : V₁)
    : strong_functor_tensor_inv x y · mon_functor_tensor F x y = identity _.
  Proof.
    apply z_iso_after_z_iso_inv.
  Qed.

  Definition strong_functor_tensor_tensor_inv
             (x y : V₁)
    : mon_functor_tensor F x y · strong_functor_tensor_inv x y = identity _.
  Proof.
    apply (z_iso_inv_after_z_iso (_ ,, fmonoidal_preservestensorstrongly (pr2 F) x y)).
  Qed.

  Definition tensor_strong_functor_tensor_inv
             {x₁ x₂ y₁ y₂ : V₁}
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
    : strong_functor_tensor_inv x₁ y₁ · #F f #⊗ #F g
      =
      #F (f #⊗ g) · strong_functor_tensor_inv x₂ y₂.
  Proof.
    use z_iso_inv_on_right ; cbn.
    rewrite !assoc.
    use z_iso_inv_on_left ; cbn.
    refine (!_).
    apply (tensor_mon_functor_tensor F).
  Qed.
End StrongMonoidalFunctorAccessors.


Require Export unscoped header_extensible.

Class Signature := B_S { Funcs : Type; fun_ar : Funcs -> nat ; Preds : Type; pred_ar : Preds -> nat }.

Section term.
Context {Sigma : Signature}.

Inductive term  : Type :=
  | var_term : ( fin ) -> term
  | Func : forall (f : Funcs), ( vect term (fun_ar f) ) -> term .

Lemma congr_Func { f : Funcs }  { s0 : vect term (fun_ar f) } { t0 : vect term (fun_ar f) } (H1 : s0 = t0) : Func  f s0 = Func  f t0 .
Proof. congruence. Defined.

Fixpoint subst_term   (sigmaterm : ( fin ) -> term ) (s : term ) : term  :=
    match s return term  with
    | var_term  s => sigmaterm s
    | Func  f s0 => Func  f (vect_map (subst_term sigmaterm) s0)
    end.

Definition up_term_term   (sigma : ( fin ) -> term ) : ( fin ) -> term  :=
  (scons) ((var_term ) (var_zero)) ((funcomp) (subst_term ((funcomp) (var_term ) (shift))) sigma).

Definition upId_term_term  (sigma : ( fin ) -> term ) (Eq : forall x, sigma x = (var_term ) x) : forall x, (up_term_term sigma) x = (var_term ) x :=
  fun n => match n with
  | S fin_n => (ap) (subst_term ((funcomp) (var_term ) (shift))) (Eq fin_n)
  | 0  => eq_refl
  end.

Fixpoint idSubst_term  (sigmaterm : ( fin ) -> term ) (Eqterm : forall x, sigmaterm x = (var_term ) x) (s : term ) : subst_term sigmaterm s = s :=
    match s return subst_term sigmaterm s = s with
    | var_term  s => Eqterm s
    | Func  f s0 => congr_Func ((vect_id (idSubst_term sigmaterm Eqterm)) s0)
    end.

Definition upExt_term_term   (sigma : ( fin ) -> term ) (tau : ( fin ) -> term ) (Eq : forall x, sigma x = tau x) : forall x, (up_term_term sigma) x = (up_term_term tau) x :=
  fun n => match n with
  | S fin_n => (ap) (subst_term ((funcomp) (var_term ) (shift))) (Eq fin_n)
  | 0  => eq_refl
  end.
(*
Fixpoint ext_term   (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) (Eqterm : forall x, sigmaterm x = tauterm x) (s : term ) : subst_term sigmaterm s = subst_term tauterm s :=
    match s return subst_term sigmaterm s = subst_term tauterm s with
    | var_term  s => Eqterm s
    | Func  f s0 => congr_Func ((vect_ext (ext_term sigmaterm tauterm Eqterm)) s0)
    end.
*)

Fixpoint compSubstSubst_term    (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) (thetaterm : ( fin ) -> term ) (Eqterm : forall x, ((funcomp) (subst_term tauterm) sigmaterm) x = thetaterm x) (s : term ) : subst_term tauterm (subst_term sigmaterm s) = subst_term thetaterm s :=
    match s return subst_term tauterm (subst_term sigmaterm s) = subst_term thetaterm s with
    | var_term  s => Eqterm s
    | Func  f s0 => congr_Func ((vect_comp (compSubstSubst_term sigmaterm tauterm thetaterm Eqterm)) s0)
    end.

Definition up_subst_subst_term_term    (sigma : ( fin ) -> term ) (tauterm : ( fin ) -> term ) (theta : ( fin ) -> term ) (Eq : forall x, ((funcomp) (subst_term tauterm) sigma) x = theta x) :   forall x, ((funcomp) (subst_term (up_term_term tauterm)) (up_term_term sigma)) x = (up_term_term theta) x :=
  fun n => match n with
  | S fin_n => (eq_trans) (compSubstSubst_term ((funcomp) (var_term ) (shift)) (up_term_term tauterm) ((funcomp) (up_term_term tauterm) (shift)) (fun x => eq_refl) (sigma fin_n))     ((eq_trans) ((eq_sym) (compSubstSubst_term tauterm ((funcomp) (var_term ) (shift)) ((funcomp) (subst_term ((funcomp) (var_term ) (shift))) tauterm) (fun x => eq_refl) (sigma fin_n))) ((ap) (subst_term ((funcomp) (var_term ) (shift))) (Eq fin_n)))
  | 0  => eq_refl
  end.
(*
Lemma instId_term  : subst_term (var_term ) = id .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => idSubst_term (var_term ) (fun n => eq_refl) ((id) x))). Qed.

Lemma varL_term   (sigmaterm : ( fin ) -> term ) : (funcomp) (subst_term sigmaterm) (var_term ) = sigmaterm .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => eq_refl)). Qed.

Lemma compComp_term    (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) (s : term ) : subst_term tauterm (subst_term sigmaterm s) = subst_term ((funcomp) (subst_term tauterm) sigmaterm) s .
Proof. exact (compSubstSubst_term sigmaterm tauterm (_) (fun n => eq_refl) s). Qed.

Lemma compComp'_term    (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) : (funcomp) (subst_term tauterm) (subst_term sigmaterm) = subst_term ((funcomp) (subst_term tauterm) sigmaterm) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compComp_term sigmaterm tauterm n)). Qed.
*)

End term.


Require Import Arith List ListSet Equality CpdtTactics.

(* Lemmas about split *)
Ltac split_solver l := subst; simpl; destruct (split l) eqn:?; crush.

Lemma in_split_l_ht :
  forall {A B: Type} (l: list (A * B)) p a b (eq_dec: forall n m : A, {n = m} + {n <> m}),
    In p (fst (split l)) \/ p = a <->
    In p (fst (split ((a, b) :: l))).
Proof.
  intros.
  intuition.
  * split_solver l.
  * split_solver l.
  * destruct (eq_dec p a).
    - split_solver l.
    - destruct (split l) eqn:?.
      simpl in H.
      rewrite Heqp0 in H.
      crush.
Qed.

Lemma in_split_r_ht :
  forall {A B: Type} (l: list (A * B)) p a b (eq_dec: forall n m : B, {n = m} + {n <> m}),
    In p (snd (split l)) \/ p = b <->
    In p (snd (split ((a, b) :: l))).
Proof.
  intros.
  intuition.
  * split_solver l.
  * split_solver l.
  * destruct (eq_dec p b).
    - split_solver l.
    - destruct (split l) eqn:?.
      simpl in H.
      rewrite Heqp0 in H.
      crush.
Qed.

Lemma in_split_exists_l :
  forall {A B: Type} (l: list (A * B)) (p: A) (eq_dec: forall n m : A, {n = m} + {n <> m}),
    In p (fst (split l)) ->
    exists v, In (p, v) l.
Proof.
  induction l; intros.
  * intuition.
  * destruct a.
    destruct (eq_dec p a).
    - exists b. crush.
    - assert (exists b : B, In (p, b) l).
      + apply IHl. intuition.
        destruct (split l) eqn:?.
        unfold snd in *.
        simpl in H.
        rewrite Heqp0 in H.
        crush.
      + destruct H0.
        exists x.
        crush.
Qed.

Lemma in_split_exists_r :
  forall {A B: Type} (l: list (A * B)) (p: B) (eq_dec: forall n m : B, {n = m} + {n <> m}),
    In p (snd (split l)) ->
    exists v, In (v, p) l.
Proof.
  induction l; intros.
  * intuition.
  * destruct a.
    destruct (eq_dec p b).
    - exists a. crush.
    - assert (exists v : A, In (v, p) l).
      + apply IHl. intuition.
        destruct (split l) eqn:?.
        unfold snd in *.
        simpl in H.
        rewrite Heqp0 in H.
        crush.
      + destruct H0.
        exists x.
        crush.
Qed.

(* Helper lemmas for proofs about lists *)
Lemma nodup_In_fwd :
  forall {A: Type} (p: A) l eq_dec,
    In p (nodup eq_dec l) ->
    In p l.
Proof.
  intros.
  eapply nodup_In.
  apply H.
Qed.

Lemma nodup_In_inv :
  forall {A: Type} (p: A) l eq_dec,
    In p l ->
    In p (nodup eq_dec l).
Proof.
  intros.
  eapply nodup_In.
  apply H.
Qed.

Lemma in_flat_map_fwd : forall {A B: Type} (f:A->set B)(l:list A) y,
    In y (flat_map f l) ->
    exists x, In x l /\ In y (f x).
Proof.
  eapply in_flat_map.
Qed.

Lemma in_flat_map_inv : forall {A B: Type} (f:A->set B)(l:list A) y,
    (exists x, In x l /\ In y (f x)) ->
    In y (flat_map f l).

Proof.
  eapply in_flat_map.
Qed.

(* Lemmas about sets *)
Lemma not_in_set_neq :
  forall {A: Type} (p p': A) ptrs,
    set_In p ptrs ->
    ~ (set_In p' ptrs) ->
    p <> p'
.
Proof.
  crush.
Qed.

Lemma set_add_noop :
  forall {A: Type} (a: A) l eq_dec,
    set_In a l ->
    set_add eq_dec a l = l.
Proof.
  induction l. crush.
  intros.
  unfold set_In in *. unfold In in *.
  destruct H.
  * subst. unfold set_add. destruct (eq_dec a a) eqn:? ; crush.
  * crush. edestruct eq_dec ; reflexivity.
Qed.

Lemma incl_cons_inv :
  forall {A: Type} (a: A) b c,
    incl (a::b) c ->
    incl b c.
Proof.
  intros until c. generalize a c.
  induction b ; induction c ; crush.
  * unfold incl. intros. inversion H0.
  * unfold incl in *.
    intros.
    specialize (H a2).
    assert (In a2 (a1 :: a0 :: b)). crush. intuition.
Qed.

(* currently only proved for nat, should extend to general type later if necessary *)
Theorem set_union_nodup_inv_1 :
  forall l l',
    NoDup (set_union eq_nat_dec l l') ->
    NoDup l.
Proof.
  intros l l'. revert l.
  induction l'.
  * intros.
    induction l; crush.
  * intros.
    unfold set_union in * ; fold set_union in *.
    specialize (IHl' l).
    induction (((fix set_union (x y : set nat) {struct y} : set nat :=
               match y with
               | nil => x
               | a1 :: y1 => set_add eq_nat_dec a1 (set_union x y1)
               end) l l')).
  - eapply IHl'. constructor.
  - simpl in H.
    destruct (eq_nat_dec a a0).
    + eauto.
    + inversion H. subst.
      assert (NoDup s -> NoDup l).
      ** intros.
         assert (~ In a0 s).
         unfold not. intros.
         assert (In a0 (set_add eq_nat_dec a s)). eapply set_add_intro1; auto.
         crush.
         assert (NoDup (a0 :: s)). constructor ; auto.
         intuition.
      ** eauto.
Qed.


(* ******************************************************************************* *)
(** * Biinitial object in a bicategory
    Niccolò Veltri, Niels van der Weide
    April 2019
    Marco Maggesi,
    July 2019

   Contents:
   1. Definition of biinitial objects
   2. Representable definition of biinitial objects
   3. Equivalence between the two definitions
   4. Bicategories with biinitial objects
   5. Biinitial objects are unique
   6. Biinitial objects are closed under equivalence
   7. Strict biinitial objects
 ********************************************************************************* *)

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.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses.
Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.Univalence.

Local Open Scope bicategory_scope.
Local Open Scope cat.

Section Initial.
  Context {B : bicat}.

  (**
   1. Definition of biinitial objects
   *)
  Definition biinitial_1cell_property (X : B) : UU
    := ∏ (Y : B), X --> Y.

  Definition biinitial_2cell_property
             (X Y : B)
    : UU
    := ∏ (f g : X --> Y), f ==> g.

  Definition biinitial_eq_property (X Y : B) : UU
    := ∏ (f g : X --> Y) (α β : f ==> g), α = β.

  Definition is_biinitial
             (X : B)
    := biinitial_1cell_property X
       ×
       ∏ (Y : B), biinitial_2cell_property X Y
                  ×
                  biinitial_eq_property X Y.

  Definition is_biinitial_1cell_property
             {X : B}
             (HX : is_biinitial X)
    : biinitial_1cell_property X
    := pr1 HX.

  Definition is_biinitial_2cell_property
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : biinitial_2cell_property X Y
    := pr1 (pr2 HX Y).

  Definition is_biinitial_eq_property
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : biinitial_eq_property X Y
    := pr2 (pr2 HX Y).

  Definition is_biinitial_invertible_2cell_property
             {X : B}
             (HX : is_biinitial X)
             {Y : B}
             (f g : X --> Y)
    : invertible_2cell f g.
  Proof.
    use make_invertible_2cell.
    - apply (is_biinitial_2cell_property HX Y).
    - use make_is_invertible_2cell.
      + apply (is_biinitial_2cell_property HX Y).
      + apply (is_biinitial_eq_property HX Y).
      + apply (is_biinitial_eq_property HX Y).
  Defined.

  Definition make_is_biinitial
             (X : B)
             (H1 : biinitial_1cell_property X)
             (H2 : ∏ (Y : B), biinitial_2cell_property X Y)
             (H3 : ∏ (Y : B), biinitial_eq_property X Y)
    : is_biinitial X.
  Proof.
    refine (H1,, _).
    intro Y.
    exact (H2 Y,, H3 Y).
  Defined.

  Definition isaprop_biinitial_2cell_property
             {X Y : B}
             (H : biinitial_eq_property X Y)
    : isaprop (biinitial_2cell_property X Y).
  Proof.
    apply impred ; intro f.
    apply impred ; intro g.
    use invproofirrelevance.
    intros α β.
    apply H.
  Qed.

  Definition isaprop_biinitial_eq_property
             (X Y : B)
    : isaprop (biinitial_eq_property X Y).
  Proof.
    repeat (apply impred ; intro).
    apply cellset_property.
  Qed.

  Definition isaprop_is_biinitial
             (H : is_univalent_2_1 B)
             (X : B)
    : isaprop (is_biinitial X).
  Proof.
    apply invproofirrelevance.
    intros x y.
    induction x as [f Hf].
    induction y as [g Hg].
    use subtypePath.
    - intro ; simpl.
      apply impred ; intro Y.
      apply isapropdirprod.
      + apply isaprop_biinitial_2cell_property.
        apply Hf.
      + apply isaprop_biinitial_eq_property.
    - simpl.
    apply funextsec ; intro Y.
    apply (isotoid_2_1 H).
    apply (is_biinitial_invertible_2cell_property (f ,, Hf)).
  Qed.

  (** 2. Representable definition of biinitial objects *)
  Definition is_biinitial_repr (X : B) : UU
    := ∏ (Y : B),
       adj_equivalence_of_cats (functor_to_unit (hom X Y)).

  Definition isaprop_is_biinitial_repr
             (H : is_univalent_2_1 B)
             (X : B)
    : isaprop (is_biinitial_repr X).
  Proof.
    use impred.
    intros Y.
    use (isofhlevelweqf
             _
             (adj_equiv_is_equiv_cat (functor_to_unit (univ_hom H X Y)))).
    apply isaprop_left_adjoint_equivalence.
    exact univalent_cat_is_univalent_2_1.
  Qed.

  (**
   3. Equivalence between the two definitions
   *)
  Definition biinitial_repr_1cell
             {X : B}
             (HX : is_biinitial_repr X)
    : biinitial_1cell_property X
    := λ Y, right_adjoint (HX Y) tt.

  Definition biinitial_repr_2cell
             {X : B}
             (HX : is_biinitial_repr X)
             {Y : B}
    : biinitial_2cell_property X Y.
  Proof.
    intros f g.
    pose (L := functor_to_unit (hom Y X)).
    pose (R := right_adjoint (HX Y)).
    pose (η := unit_nat_z_iso_from_adj_equivalence_of_cats (HX Y)).
    pose (θ₁ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η f)).
    pose (θ₂ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η g)).
    exact (comp_of_invertible_2cell θ₁ (inv_of_invertible_2cell θ₂)).
  Defined.

  Definition biinitial_repr_eq
             {X : B}
             (HX : is_biinitial_repr X)
             {Y : B}
    : biinitial_eq_property X Y.
  Proof.
    intros f g α β.
    pose (L := functor_to_unit (hom Y X)).
    pose (R := right_adjoint (HX Y)).
    pose (η := unit_nat_z_iso_from_adj_equivalence_of_cats (HX Y)).
    pose (θ₁ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η f)).
    pose (θ₂ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η g)).
    use (invmaponpathsincl
           _
           (isinclweq
              _ _ _
              (fully_faithful_from_equivalence _ _ _ (HX Y) _ _))).
    apply idpath.
  Qed.

  Definition is_biinitial_repr_to_is_biinitial
             {X : B}
             (HX : is_biinitial_repr X)
    : is_biinitial X.
  Proof.
    repeat split.
    - exact (biinitial_repr_1cell HX).
    - exact (biinitial_repr_2cell HX).
    - exact (biinitial_repr_eq HX).
  Defined.

  Definition biinitial_inv_data
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : functor_data unit_category (hom X Y).
  Proof.
    use make_functor_data.
    - exact (λ _, is_biinitial_1cell_property HX Y).
    - exact (λ _ _ _, id₂ _).
  Defined.

  Definition biinitial_inv_is_functor
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : is_functor (biinitial_inv_data HX Y).
  Proof.
    split.
    - intro ; intros.
      apply idpath.
    - intro ; intros.
      cbn.
      rewrite id2_left.
      apply idpath.
  Qed.

  Definition biinitial_inv
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : unit_category ⟶ hom X Y.
  Proof.
    use make_functor.
    - exact (biinitial_inv_data HX Y).
    - exact (biinitial_inv_is_functor HX Y).
  Defined.

  Definition biinitial_inv_unit_data
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : nat_trans_data
        (functor_identity (hom X Y))
        (functor_composite
           (functor_to_unit (hom X Y))
           (biinitial_inv HX Y))
    := λ f, is_biinitial_2cell_property HX Y f (is_biinitial_1cell_property HX Y).

  Definition biinitial_inv_unit_is_nat_trans
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : is_nat_trans _ _ (biinitial_inv_unit_data HX Y).
  Proof.
    intros f g α.
    simpl in * ; cbn.
    rewrite id2_right.
    apply (is_biinitial_eq_property HX Y).
  Qed.

  Definition biinitial_inv_unit
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : (functor_identity (hom X Y))
        ⟹
        functor_composite
        (functor_to_unit (hom X Y))
        (biinitial_inv HX Y).
  Proof.
    use make_nat_trans.
    - exact (biinitial_inv_unit_data HX Y).
    - exact (biinitial_inv_unit_is_nat_trans HX Y).
  Defined.

  Definition biinitial_inv_counit_data
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : nat_trans_data
        (functor_composite
           (biinitial_inv HX Y)
           (functor_to_unit (hom X Y)))
        (functor_identity _).
  Proof.
    intros f.
    apply isapropunit.
  Defined.

  Definition biinitial_inv_counit_is_nat_trans
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : is_nat_trans _ _ (biinitial_inv_counit_data HX Y).
  Proof.
    intros f g α.
    apply isasetunit.
  Qed.

  Definition biinitial_inv_counit
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : (functor_composite
         (biinitial_inv HX Y)
         (functor_to_unit (hom X Y)))
        ⟹
        (functor_identity _).
  Proof.
    use make_nat_trans.
    - exact (biinitial_inv_counit_data HX Y).
    - exact (biinitial_inv_counit_is_nat_trans HX Y).
  Defined.

  Definition is_biinitial_to_is_biinitial_repr_help
             {X : B}
             (HX : is_biinitial X)
             (Y : B)
    : equivalence_of_cats (hom X Y) unit_category.
  Proof.
    simple refine ((_ ,, (_ ,, (_ ,, _))) ,, (_ ,, _)).
    - exact (functor_to_unit _).
    - exact (biinitial_inv HX Y).
    - exact (biinitial_inv_unit HX Y).
    - exact (biinitial_inv_counit HX Y).
    - intros f.
      cbn ; unfold biinitial_inv_unit_data.
      apply is_inv2cell_to_is_z_iso.
      apply is_biinitial_invertible_2cell_property.
    - intro g.
      cbn.
      apply path_univalent_groupoid.
  Defined.

  Definition is_biinitial_to_is_biinitial_repr
             {X : B}
             (HX : is_biinitial X)
    : is_biinitial_repr X.
  Proof.
    intros Y.
    exact (adjointificiation (is_biinitial_to_is_biinitial_repr_help HX Y)).
  Defined.

  Definition is_biinitial_weq_is_biinitial_repr
             (H : is_univalent_2_1 B)
             (X : B)
    : is_biinitial X ≃ is_biinitial_repr X.
  Proof.
    use weqimplimpl.
    - exact is_biinitial_to_is_biinitial_repr.
    - exact is_biinitial_repr_to_is_biinitial.
    - exact (isaprop_is_biinitial H X).
    - exact (isaprop_is_biinitial_repr H X).
  Defined.
End Initial.

(**
 4. Bicategories with biinitial objects
 *)
Definition biinitial_obj (B : bicat) : UU
  := ∑ (X : B), is_biinitial X.

Definition has_biinitial (B : bicat) : UU := ∥ biinitial_obj B ∥.

Definition bicat_with_biinitial
  : UU
  := ∑ (B : bicat), biinitial_obj B.

Coercion bicat_with_biinitial_to_bicat
         (B : bicat_with_biinitial)
  : bicat
  := pr1 B.

Definition biinitial_of
           (B : bicat_with_biinitial)
  : biinitial_obj B
  := pr2 B.

(**
 5. Biinitial objects are unique
 *)
Section Uniqueness.
  Context {B : bicat}
          (HB : is_univalent_2 B)
          {X : B} (HX : is_biinitial X)
          {Y : B} (HY : is_biinitial Y).

  Let HC0 : is_univalent_2_0 B := pr1 HB.
  Let HC1 : is_univalent_2_1 B := pr2 HB.

  Definition biinitial_unique_adj_unit
    : id₁ Y
      ==>
      is_biinitial_1cell_property HY X · is_biinitial_1cell_property HX Y
    := is_biinitial_2cell_property HY _ _ _.

  Definition biinitial_unique_adj_counit
    : is_biinitial_1cell_property HX Y · is_biinitial_1cell_property HY X
      ==>
      id₁ X
    := is_biinitial_2cell_property HX _ _ _.

  Definition biinitial_unique_adj_data
    : left_adjoint_data (is_biinitial_1cell_property HY X)
    := is_biinitial_1cell_property HX Y
       ,,
       biinitial_unique_adj_unit
       ,,
       biinitial_unique_adj_counit.

  Lemma biinitial_unique_left_eqv
    : left_equivalence_axioms biinitial_unique_adj_data.
  Proof.
    split.
    - apply is_biinitial_invertible_2cell_property.
    - apply is_biinitial_invertible_2cell_property.
  Qed.

  Definition biinitial_unique_adj_eqv
    : left_adjoint_equivalence (is_biinitial_1cell_property HY X).
  Proof.
    apply equiv_to_isadjequiv.
    unfold left_equivalence.
    exact (biinitial_unique_adj_data ,, biinitial_unique_left_eqv).
  Defined.

  Definition biinitial_unique : Y = X
    := isotoid_2_0 HC0 (_ ,, biinitial_unique_adj_eqv).
End Uniqueness.

(**
 6. Biinitial objects are closed under equivalence
 *)
Section EquivToBiinitial.
  Context {B : bicat}
          {X Y : B}
          (HX : is_biinitial X)
          {l : X --> Y}
          (Hl : left_adjoint_equivalence l).

  Let r : Y --> X
    := left_adjoint_right_adjoint Hl.
  Let ε : invertible_2cell (r · l) (id₁ Y)
    := left_equivalence_counit_iso Hl.

  Definition equiv_from_biinitial
    : is_biinitial Y.
  Proof.
    use make_is_biinitial.
    - exact (λ Z, r · is_biinitial_1cell_property HX Z).
    - exact (λ Z f g,
             linvunitor _
             • (ε^-1 ▹ f)
             • rassociator _ _ _
             • (r ◃ is_biinitial_2cell_property HX _ (l · f) (l · g))
             • lassociator _ _ _
             • (ε ▹ g)
             • lunitor _).
    - abstract
        (intros Z f g α β ;
         use (vcomp_lcancel (lunitor _)) ; [ is_iso | ] ;
         rewrite <- !vcomp_lunitor ;
         apply maponpaths_2 ;
         use (vcomp_lcancel (ε ▹ f)) ; [ is_iso ; apply property_from_invertible_2cell | ] ;
         rewrite !vcomp_whisker ;
         apply maponpaths_2 ;
         use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ] ;
         rewrite <- !lwhisker_lwhisker ;
         apply maponpaths_2 ;
         apply maponpaths ;
         apply (is_biinitial_eq_property HX)).
  Defined.
End EquivToBiinitial.

Definition equiv_to_biinitial
           {B : bicat}
           {X Y : B}
           (HX : is_biinitial X)
           {l : Y --> X}
           (Hl : left_adjoint_equivalence l)
  : is_biinitial Y
  := equiv_from_biinitial HX (inv_adjequiv (l ,, Hl)).

(**
 7. Strict biinitial objects
 *)
Definition biinitial_is_strict_biinitial_obj
           {B : bicat}
           {X : B}
           (HX : is_biinitial X)
  : UU
  := ∏ (Y : B) (f : Y --> X), left_adjoint_equivalence f.

Definition is_strict_biinitial_obj
           {B : bicat}
           (X : B)
  : UU
  := ∑ (HX : is_biinitial X), biinitial_is_strict_biinitial_obj HX.

Definition strict_biinitial_obj
           (B : bicat)
  : UU
  := ∑ (X : B), is_strict_biinitial_obj X.

Definition bicat_with_strict_biinitial
  : UU
  := ∑ (B : bicat), strict_biinitial_obj B.

Coercion bicat_with_strict_biinitial_to_bicat
         (B : bicat_with_strict_biinitial)
  : bicat
  := pr1 B.

Definition strict_biinitial_of
           (B : bicat_with_strict_biinitial)
  : strict_biinitial_obj B
  := pr2 B.

Definition map_to_strict_biinitial_is_biinitial
           {B : bicat}
           {X Y : B}
           (HX : is_strict_biinitial_obj X)
           (f : Y --> X)
  : is_biinitial Y
  := equiv_to_biinitial (pr1 HX) (pr2 HX _ f).


Require Export XR_Rmult_comm.
Require Export XR_Rmult_le_reg_l.

Local Open Scope R_scope.

Lemma Rmult_le_reg_r : forall r r1 r2,
  R0 < r ->
  r1 * r <= r2 * r ->
  r1 <= r2.
Proof.
  intros x y z hx h.
  apply Rmult_le_reg_l with x.
  { exact hx. }
  {
    repeat rewrite (Rmult_comm x).
    exact h.
  }
Qed.