wip symmetric monoidal categories

Signed-off-by: Ali Caglayan <[email protected]>
HoTT · Apr 12, 2024 · 6d1af4e · 6d1af4e
1 parent 506f4fd
commit 6d1af4e
Show file tree

Hide file tree

Showing 2 changed files with 287 additions and 8 deletions.
diff --git a/theories/WildCat/Bifunctor.v b/theories/WildCat/Bifunctor.v
@@ -62,13 +62,36 @@ Definition fmap10 {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C}
   : (F a0 b) $-> (F a1 b)
   := fmap (flip F b) f.
 
+Global Instance iemap10 {A B C : Type} `{HasEquivs A, Is1Cat B, HasEquivs C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 : A} (f : a0 $<~> a1) (b : B)
+  : CatIsEquiv (fmap10 F f b)
+  := iemap (flip F _) f.
+
+Definition emap10 {A B C : Type} `{HasEquivs A, Is1Cat B, HasEquivs C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 : A} (f : a0 $<~> a1) (b : B)
+  : F a0 b $<~> F a1 b
+  := Build_CatEquiv (fmap10 F f b).
+
 (** [fmap] in the second argument *)
 Definition fmap01 {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C}
   (F : A -> B -> C) `{!Is0Bifunctor F} (a : A) {b0 b1 : B} (g : b0 $-> b1)
   : F a b0 $-> F a b1
   := fmap (F a) g.
 
-(** There are two ways to [fmap] in both arguments of a bifunctor. The bifunctor coherence condition ([bifunctor_isbifunctor]) states precisely that these two routes agree. *)
+Global Instance iemap01 {A B C : Type} `{Is1Cat A, HasEquivs B, HasEquivs C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  (a : A) {b0 b1 : B} (g : b0 $<~> b1)
+  : CatIsEquiv (fmap01 F a g)
+  := iemap (F _) g.
+
+Definition emap01 {A B C : Type} `{Is1Cat A, HasEquivs B, HasEquivs C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  (a : A) {b0 b1 : B} (g : b0 $<~> b1)
+  : F a b0 $<~> F a b1
+  := Build_CatEquiv (fmap01 F a g).
+
 Definition fmap11 {A B C : Type} `{IsGraph A, IsGraph B, Is01Cat C}
   (F : A -> B -> C) `{!Is0Bifunctor F} {a0 a1 : A} (f : a0 $-> a1)
   {b0 b1 : B} (g : b0 $-> b1)
@@ -81,6 +104,15 @@ Definition fmap11' {A B C : Type} `{IsGraph A, IsGraph B, Is01Cat C}
   : F a0 b0 $-> F a1 b1
   := fmap (flip F _) f $o fmap (F _) g.
 
+(** There are two ways to [fmap] in both arguments of a bifunctor. The bifunctor coherence condition ([bifunctor_isbifunctor]) states precisely that these two routes agree. *)
+Definition fmap11_coh {A B C : Type}
+  (F : A -> B -> C) `{Is1Bifunctor A B C F}
+  {a0 a1 : A} (f : a0 $-> a1) {b0 b1 : B} (g : b0 $-> b1)
+  : fmap11 F f g $== fmap11' F f g.
+Proof.
+  rapply bifunctor_isbifunctor. 
+Defined.
+
 Definition fmap22 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
   (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
   {a0 a1 : A} {f : a0 $-> a1} {f' : a0 $-> a1}
@@ -92,18 +124,27 @@ Definition fmap22 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
 Global Instance iemap11 {A B C : Type} `{HasEquivs A, HasEquivs B, HasEquivs C}
   (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
   {a0 a1 : A} (f : a0 $<~> a1) {b0 b1 : B} (g : b0 $<~> b1)
-  : CatIsEquiv (fmap11 F f g).
-Proof.
-  rapply compose_catie'.
-  exact (iemap (flip F _) f).
-Defined.
+  : CatIsEquiv (fmap11 F f g)
+  := compose_catie' _ _.
 
 Definition emap11 {A B C : Type} `{HasEquivs A, HasEquivs B, HasEquivs C}
   (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
   {a0 a1 : A} (f : a0 $<~> a1) {b0 b1 : B} (g : b0 $<~> b1)
   : F a0 b0 $<~> F a1 b1
   := Build_CatEquiv (fmap11 F f g).
 
+Definition fmap10_is_fmap11 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 : A} (f : a0 $-> a1) (b : B)
+  : fmap10 F f b $== fmap11 F f (Id b)
+  := ((fmap_id _ _ $@R _) $@ cat_idl _)^$.
+
+Definition fmap01_is_fmap11 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  (a : A) {b0 b1 : B} (g : b0 $-> b1)
+  : fmap01 F a g $== fmap11 F (Id a) g
+  := ((_ $@L fmap_id _ _) $@ cat_idr _)^$.
+
 (** Any 0-bifunctor [A -> B -> C] can be made into a functor from the product category [A * B -> C] in two ways. *)
 Global Instance is0functor_uncurry_bifunctor {A B C : Type}
   `{IsGraph A, IsGraph B, Is01Cat C} (F : A -> B -> C) `{!Is0Bifunctor F}

diff --git a/theories/WildCat/Monoidal.v b/theories/WildCat/Monoidal.v
@@ -2,7 +2,9 @@ Require Import Basics.Overture Basics.Tactics.
 Require Import Types.Forall.
 Require Import WildCat.Core WildCat.Bifunctor WildCat.Prod WildCat.Equiv WildCat.NatTrans.
 
-(** * Monoidal 1-categories *)
+(** * Monoidal Categories *)
+
+(** In this file we define monoidal categories and symmetric monoidal categories. *)
 
 (** ** Typeclasses for common diagrams *)
 
@@ -65,7 +67,44 @@ Class PentagonIdentity {A : Type} `{HasEquivs A}
 Coercion pentagon_identity : PentagonIdentity >-> Funclass.
 Arguments pentagon_identity {A _ _ _ _ _} F {_ _ _} unit {_}.
 
-(** ** Definition *)
+(** *** Symmetors or Braiding *)
+
+Definition is0bifunctor_flip {A B C : Type}
+  (F : A -> B -> C) `{Is0Bifunctor A B C F} : Is0Bifunctor (flip F).
+Proof.
+  snrapply Build_Is0Bifunctor.
+  - exact _.
+  - exact _.
+Defined.
+
+Hint Immediate is0bifunctor_flip : typeclass_instances.
+
+Class Symmetor {A : Type} `{HasEquivs A}
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} := {
+  (** An isomorphism [symmetor] witnessing the symmetry of [F]. *)
+  symmetor a b : F a b $<~> F b a;
+  (** The [symmetor] is a natural isomorphism. *)
+  is1natural_symmetor_uncurried
+    : Is1Natural
+      (uncurry F)
+      (uncurry (flip F))
+      (fun '(a, b) => symmetor a b);
+}.
+
+Coercion symmetor : Symmetor >-> Funclass.
+Arguments symmetor {A _ _ _ _ _ F _ _ _} a b.
+
+(** *** Hexagon identity *)
+
+Class HexagonIdentity {A : Type} `{HasEquivs A}
+  (F : A -> A -> A)
+  `{!Is0Bifunctor F, !Is1Bifunctor F, !Associator F, !Symmetor F}
+  (** The hexagon identity for an associator and symmetor. *)
+  := hexagon_identity a b c
+    : fmap10 F (symmetor b a) c $o associator b a c $o fmap01 F b (symmetor c a)
+      $== associator a b c $o symmetor (F b c) a $o associator b c a.
+
+(** ** Monoidal Categories *)
 
 (** A monoidal 1-category is a 1-category with equivalences together with the following: *)
 Class IsMonoidal (A : Type) `{HasEquivs A}
@@ -89,3 +128,202 @@ Class IsMonoidal (A : Type) `{HasEquivs A}
   (** The pentagon identity. *)
   cat_tensor_pentagon_identity :: PentagonIdentity cat_tensor cat_tensor_unit;
 }.
+
+(** ** Symmetric Monoidal Categories *)
+
+(** A symmetric monoidal 1-category is a 1-category with equivalences together with the following: *)
+Class IsSymmetricMonoidal (A : Type) `{HasEquivs A}
+  (** A binary operation [cat_tensor] called the tensor product. *)
+  (cat_tensor : A -> A -> A)
+  (** A unit object [cat_tensor_unit] called the tensor unit. *)
+  (cat_tensor_unit : A)
+  := {
+  (** A monoidal structure with [cat_tensor] and [cat_tensor_unit]. *) 
+  issymmetricmonoidal_ismonoidal :: IsMonoidal A cat_tensor cat_tensor_unit;
+  (** A natural isomorphism [symmetor] witnessing the symmetry of the tensor product. *) 
+  cat_symm_tensor_symmetor :: Symmetor cat_tensor;
+  (** The hexagon identity. *)
+  cat_symm_tensor_hexagon :: HexagonIdentity cat_tensor;
+}.
+
+(** *** Building Symmetric Monoidal Categories *)
+
+Require Import Square.
+
+Section TwistConstruction.
+
+  Context (A : Type) `{HasEquivs A}
+    (cat_tensor : A -> A -> A) (cat_tensor_unit : A)
+    `{!Is0Bifunctor cat_tensor, !Is1Bifunctor cat_tensor}
+
+    (swap : forall a b, cat_tensor a b $-> cat_tensor b a)
+    (swap_swap : forall a b, swap a b $o swap b a $== Id _)
+    (swap_nat : forall a b c d (f : a $-> c) (g : b $-> d),
+      swap c d $o fmap11 cat_tensor f g
+      $== fmap11 cat_tensor g f $o swap a b)
+
+    (twist : forall a b c, cat_tensor a (cat_tensor b c) $-> cat_tensor b (cat_tensor a c))
+    (twist_twist : forall a b c, twist a b c $o twist b a c $== Id _)
+    (twist_nat : forall a a' b b' c c' (f : a $-> a') (g : b $-> b') (h : c $-> c'),
+      twist a' b' c' $o fmap11 cat_tensor f (fmap11 cat_tensor g h)
+      $== fmap11 cat_tensor g (fmap11 cat_tensor f h) $o twist a b c)
+
+    {left_unitor : LeftUnitor cat_tensor cat_tensor_unit}
+    {right_unitor : RightUnitor cat_tensor cat_tensor_unit}
+
+    (swap_unitor : forall a, cate_fun (left_unitor a)
+      $== right_unitor a $o swap cat_tensor_unit a)
+    (twist_unitor : forall a b, fmap01 cat_tensor a (right_unitor b)
+      $== swap b a $o fmap01 cat_tensor b (right_unitor a) $o twist a b cat_tensor_unit)
+
+    (twist_hexagon : forall a b c,
+      fmap01 cat_tensor c (swap b a) $o twist b c a $o fmap (cat_tensor b) (swap a c)
+      $== twist a c b $o fmap01 cat_tensor a (swap b c) $o twist b a c)
+  .
+
+  Local Definition swape a b
+    : cat_tensor a b $<~> cat_tensor b a
+    := cate_adjointify (swap a b) (swap b a) (swap_swap a b) (swap_swap b a).
+
+  Local Definition twiste a b c
+    : cat_tensor a (cat_tensor b c) $<~> cat_tensor b (cat_tensor a c)
+    := cate_adjointify (twist a b c) (twist b a c)
+        (twist_twist a b c) (twist_twist b a c).
+
+  Local Definition associator_twist' a b c
+    : cat_tensor a (cat_tensor b c) $<~> cat_tensor (cat_tensor a b) c.
+  Proof.
+    (** We can build the associator out of [swape] and [twiste]. *)
+    nrefine (swape _ _ $oE _).
+    nrefine (twiste _ _ _ $oE _).
+    exact (emap01 cat_tensor a (swape _ _)).
+    Show Proof.
+  Defined.
+
+  Local Definition associator_twist'_unfold a b c
+    : cate_fun (associator_twist' a b c)
+    $== swap c (cat_tensor a b) $o (twist a c b $o fmap01 cat_tensor a (swap b c)).
+  Proof.
+    refine (cate_buildequiv_fun _ $@ (_ $@@ cate_buildequiv_fun _)).
+    nrefine (cate_buildequiv_fun _ $@ (_ $@@ cate_buildequiv_fun _)).
+    refine (cate_buildequiv_fun _ $@ fmap2 _ _).
+    apply cate_buildequiv_fun.
+  Defined.
+
+  Local Instance associator_twist : Associator cat_tensor.
+  Proof.
+    snrapply Build_Associator.
+    - exact associator_twist'.
+    - simpl; intros [[a b] c] [[a' b'] c'] [[f g] h]; simpl in f, g, h.
+      (** To prove naturality it will be easier to reason about squares. *)
+      change (?w $o ?x $== ?y $o ?z) with (Square z w x y).
+      (** First we remove all the equivalences from the equation. *)
+      nrapply hconcatL.
+      1: apply associator_twist'_unfold.
+      nrapply hconcatR.
+      2: apply associator_twist'_unfold.
+      (** The first square involving [swap] on its own is a naturality square. *)
+      nrapply vconcat.
+      2: apply swap_nat.
+      (** The second square is just the naturality of twist. *)
+      nrapply vconcat.
+      2: apply twist_nat.
+      (** We rewrite one of the edges to make sure a functor application is grouped together. *)
+      nrapply vconcatL.
+      { refine ((cat_assoc _ _ _)^$ $@ (_^$ $@R _)).
+        rapply fmap_comp. }
+      (** This allows us to compose with bifunctor coherence on one side. *) 
+      nrapply hconcat.
+      1: rapply fmap11_coh.
+      (** Leaving us with a square with a functor application. *) 
+      rapply fmap_square.
+      (** We are finally left with the naturality of swap. *)
+      apply swap_nat. 
+  Defined.
+
+  (** We can prove the triangle identity using two simpler coherences. The first is called [swap_unitor] and asserts that the the left unitor is the right unitor when composed with the [symmetor]. The second is called [twist_unitor] and asserts a reduced version of the triangle identity only mentioning [right_unitor], [swap] and [twist]. *)
+  Local Instance triangle_twist : TriangleIdentity cat_tensor cat_tensor_unit.
+  Proof.
+    intros a b.
+    refine (_ $@ (_ $@L (cate_buildequiv_fun _)^$)).
+    refine (_ $@ cat_assoc _ _ _).
+    refine (_ $@ (_ $@L (cate_buildequiv_fun _)^$)).
+    refine (_ $@ cat_assoc _ _ _).
+    nrapply cate_moveL_eM.
+    nrefine (_ $@L (emap_inv _ _ $@ cate_buildequiv_fun _) $@ _).
+    refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ _).
+    { apply cate_moveR_eV.
+      refine (_ $@ (_ $@L (cate_buildequiv_fun _)^$)).
+      apply swap_unitor. }
+    refine (_ $@ ((_ $@ (_ $@L (cate_buildequiv_fun _)^$)) $@R _)).
+    2: { refine (_ $@ ((fmap10_is_fmap11 _ _ _)^$ $@R _)).
+      apply swap_nat. }
+    refine (_ $@ (_^$ $@@ _)).
+    2: apply cate_buildequiv_fun.
+    2: refine (_ $@L fmap01_is_fmap11 _ _ _).
+    apply twist_unitor.
+  Defined.
+
+  Local Instance pentagon_twist : PentagonIdentity cat_tensor cat_tensor_unit.
+  Proof.
+    hnf.
+    intros a b c d.
+    (** We probably want to unfold equivalences here but we might need to move them around, not quite sure. *)
+    (* refine ((_ $@@ _) $@ _ $@ (_ $@@ (_ $@R _))^$). *)
+  Admitted.
+
+  Local Instance ismonoidal_twist
+    : IsMonoidal A cat_tensor cat_tensor_unit
+    := {}.
+
+  Local Instance symmetor_twist : Symmetor cat_tensor.
+  Proof.
+    snrapply Build_Symmetor.
+    - exact swape.
+    - intros [a b] [c d] [f g].
+      nrefine ((cate_buildequiv_fun _ $@R _) $@ _).
+      refine (_ $@ (_ $@L (cate_buildequiv_fun _)^$)).
+      nrefine (swap_nat _ _ _ _ _ _ $@ (_ $@R _)).
+      rapply bifunctor_isbifunctor.
+  Defined.
+
+  Local Instance hexagon_twist : HexagonIdentity cat_tensor.
+  Proof.
+    intros a b c.
+    refine (((_ $@L _) $@R _) $@ _ $@ (_ $@@ (_ $@R _))^$).
+    1,3,4: apply associator_twist'_unfold.
+    do 2 refine (((cat_assoc _ _ _)^$ $@R _) $@ _).
+    refine (cat_assoc _ _ _ $@ (_ $@L _) $@ _).
+    { refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ fmap_id _ _).
+      refine (_ $@L cate_buildequiv_fun _ $@ _).
+      apply swap_swap. }
+    refine (cat_idr _ $@ _).
+    refine (_ $@ cat_assoc _ _ _).
+    refine (_ $@ ((cat_assoc _ _ _)^$ $@R _)).
+    refine (_ $@ (((cat_idr _)^$ $@ (_ $@L _^$)) $@R _)).
+    2: { refine (cate_buildequiv_fun _ $@R _ $@ _).
+      apply swap_swap. }
+    nrefine ((_ $@R _) $@ _).
+    { refine ((_ $@R _) $@ _^$).
+      1: rapply fmap10_is_fmap11.
+      apply swap_nat. }
+    refine (cat_assoc _ _ _ $@ (_ $@L _) $@ (cat_assoc _ _ _)^$).
+    refine (((fmap01_is_fmap11 _ _ _ $@ fmap22 _ (Id _) _^$)^$ $@R _) $@ _).
+    1: apply cate_buildequiv_fun.
+    refine (_ $@ cat_assoc _ _ _).
+    rapply (cate_epic_equiv (emap01 cat_tensor b (swape a c))).
+    refine (_ $@ (cat_assoc _ _ _)^$).
+    refine (_ $@ (_ $@L (_ $@ (_ $@L _^$)))).
+    3: exact (cate_buildequiv_fun _ $@ fmap2 _ (cate_buildequiv_fun _)).
+    2: refine ((fmap_id _ _)^$ $@ fmap2 _ (swap_swap _ _)^$ $@ fmap_comp _ _ _).
+    refine (_ $@ (cat_idr _)^$).
+    refine ((_ $@L _) $@ _).
+    1: exact (cate_buildequiv_fun _ $@ fmap2 _ (cate_buildequiv_fun _)).
+    apply twist_hexagon.
+  Defined.
+
+  Local Instance issymmetricmonoidal_twist
+    : IsSymmetricMonoidal A cat_tensor cat_tensor_unit
+    := {}.
+
+End TwistConstruction.