Move opposite- and span- category to own modules

doc/implementation.tex

@@ -10,19 +10,20 @@ Name & Link \\
 \hline
 Categories & \sourcelink{Cat.Category} \\
 Functors & \sourcelink{Cat.Category.Functor} \\
-Products & \sourcelink{Cat.Category.Products} \\
+Products & \sourcelink{Cat.Category.Product} \\
-Exponentials & \sourcelink{Cat.Category.Exponentials} \\
+Exponentials & \sourcelink{Cat.Category.Exponential} \\
 Cartesian closed categories & \sourcelink{Cat.Category.CartesianClosed} \\
 Natural transformations & \sourcelink{Cat.Category.NaturalTransformation} \\
 Yoneda embedding & \sourcelink{Cat.Category.Yoneda} \\
-Monads & \sourcelink{Cat.Category.Monads} \\
+Monads & \sourcelink{Cat.Category.Monad} \\
+Kleisli Monads & \sourcelink{Cat.Category.Monad.Kleisli} \\
+Monoidal Monads & \sourcelink{Cat.Category.Monad.Monoidal} \\
+Voevodsky's construction & \sourcelink{Cat.Category.Monad.Voevodsky} \\
 %% Categories & \null \\
 %%
-Opposite category &
+Opposite category & \sourcelink{Cat.Categories.Opposite} \\
-\href{\sourcebasepath Cat.Category.html#22744}{\texttt{Cat.Category.Opposite}} \\
 Category of sets & \sourcelink{Cat.Categories.Sets} \\
-Span category &
+Span category & \sourcelink{Cat.Categories.Span} \\
-\href{\sourcebasepath Cat.Category.Product.html#2919}{\texttt{Cat.Category.Product.Span}} \\
   %%
 \end{tabular}
 \end{center}

src/Cat.agda

@@ -14,6 +14,7 @@ open import Cat.Category.Monad.Monoidal
 open import Cat.Category.Monad.Kleisli
 open import Cat.Category.Monad.Voevodsky
 
+open import Cat.Categories.Opposite
 open import Cat.Categories.Sets
 open import Cat.Categories.Cat
 open import Cat.Categories.Rel

src/Cat/Categories/CwF.agda

@@ -5,6 +5,7 @@ open import Cat.Prelude
 open import Cat.Category
 open import Cat.Category.Functor
 open import Cat.Categories.Fam
+open import Cat.Categories.Opposite
 
 module _ {ℓa ℓb : Level} where
   record CwF : Set (lsuc (ℓa ⊔ ℓb)) where

src/Cat/Categories/Fun.agda

@@ -3,11 +3,11 @@ module Cat.Categories.Fun where
 
 open import Cat.Prelude
 open import Cat.Equivalence
-
 open import Cat.Category
 open import Cat.Category.Functor
 import Cat.Category.NaturalTransformation
   as NaturalTransformation
+open import Cat.Categories.Opposite
 
 module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : Category ℓd ℓd') where
   open NaturalTransformation ℂ 𝔻 public hiding (module Properties)

src/Cat/Categories/Opposite.agda

@@ -0,0 +1,96 @@
+{-# OPTIONS --cubical #-}
+module Cat.Categories.Opposite where
+
+open import Cat.Prelude
+open import Cat.Equivalence
+open import Cat.Category
+
+-- | The opposite category
+--
+-- The opposite category is the category where the direction of the arrows are
+-- flipped.
+module _ {ℓa ℓb : Level} where
+  module _ (ℂ : Category ℓa ℓb) where
+    private
+      module _ where
+        module ℂ = Category ℂ
+        opRaw : RawCategory ℓa ℓb
+        RawCategory.Object   opRaw = ℂ.Object
+        RawCategory.Arrow    opRaw = flip ℂ.Arrow
+        RawCategory.identity opRaw = ℂ.identity
+        RawCategory._<<<_    opRaw = ℂ._>>>_
+
+        open RawCategory opRaw
+
+        isPreCategory : IsPreCategory opRaw
+        IsPreCategory.isAssociative isPreCategory = sym ℂ.isAssociative
+        IsPreCategory.isIdentity    isPreCategory = swap ℂ.isIdentity
+        IsPreCategory.arrowsAreSets isPreCategory = ℂ.arrowsAreSets
+
+      open IsPreCategory isPreCategory
+
+      module _ {A B : ℂ.Object} where
+        open Σ (toIso _ _ (ℂ.univalent {A} {B}))
+          renaming (fst to idToIso* ; snd to inv*)
+        open AreInverses {f = ℂ.idToIso A B} {idToIso*} inv*
+
+        shuffle : A ≊ B → A ℂ.≊ B
+        shuffle (f , g , inv) = g , f , inv
+
+        shuffle~ : A ℂ.≊ B → A ≊ B
+        shuffle~ (f , g , inv) = g , f , inv
+
+        lem : (p : A ≡ B) → idToIso A B p ≡ shuffle~ (ℂ.idToIso A B p)
+        lem p = isoEq refl
+
+        isoToId* : A ≊ B → A ≡ B
+        isoToId* = idToIso* ∘ shuffle
+
+        inv : AreInverses (idToIso A B) isoToId*
+        inv =
+          ( funExt (λ x → begin
+            (isoToId* ∘ idToIso A B) x
+              ≡⟨⟩
+            (idToIso*  ∘ shuffle ∘ idToIso A B) x
+              ≡⟨ cong (λ φ → φ x) (cong (λ φ → idToIso* ∘ shuffle ∘ φ) (funExt lem)) ⟩
+            (idToIso*  ∘ shuffle ∘ shuffle~ ∘ ℂ.idToIso A B) x
+              ≡⟨⟩
+            (idToIso*  ∘ ℂ.idToIso A B) x
+              ≡⟨ (λ i → verso-recto i x) ⟩
+            x ∎)
+          , funExt (λ x → begin
+            (idToIso A B ∘ idToIso* ∘ shuffle) x
+              ≡⟨ cong (λ φ → φ x) (cong (λ φ → φ ∘ idToIso* ∘ shuffle) (funExt lem)) ⟩
+            (shuffle~ ∘ ℂ.idToIso A B ∘ idToIso* ∘ shuffle) x
+              ≡⟨ cong (λ φ → φ x) (cong (λ φ → shuffle~ ∘ φ ∘ shuffle) recto-verso) ⟩
+            (shuffle~ ∘ shuffle) x
+              ≡⟨⟩
+            x ∎)
+          )
+
+      isCategory : IsCategory opRaw
+      IsCategory.isPreCategory isCategory = isPreCategory
+      IsCategory.univalent     isCategory
+        = univalenceFromIsomorphism (isoToId* , inv)
+
+    opposite : Category ℓa ℓb
+    Category.raw        opposite = opRaw
+    Category.isCategory opposite = isCategory
+
+  -- As demonstrated here a side-effect of having no-eta-equality on constructors
+  -- means that we need to pick things apart to show that things are indeed
+  -- definitionally equal. I.e; a thing that would normally be provable in one
+  -- line now takes 13!! Admittedly it's a simple proof.
+  module _ {ℂ : Category ℓa ℓb} where
+    open Category ℂ
+    private
+      -- Since they really are definitionally equal we just need to pick apart
+      -- the data-type.
+      rawInv : Category.raw (opposite (opposite ℂ)) ≡ raw
+      RawCategory.Object   (rawInv _) = Object
+      RawCategory.Arrow    (rawInv _) = Arrow
+      RawCategory.identity (rawInv _) = identity
+      RawCategory._<<<_    (rawInv _) = _<<<_
+
+    oppositeIsInvolution : opposite (opposite ℂ) ≡ ℂ
+    oppositeIsInvolution = Category≡ rawInv

src/Cat/Categories/Sets.agda

@@ -3,11 +3,11 @@
 module Cat.Categories.Sets where
 
 open import Cat.Prelude as P
-
+open import Cat.Equivalence
 open import Cat.Category
 open import Cat.Category.Functor
 open import Cat.Category.Product
-open import Cat.Equivalence
+open import Cat.Categories.Opposite
 
 _⊙_ : {ℓa ℓb ℓc : Level} {A : Set ℓa} {B : Set ℓb} {C : Set ℓc} → (A ≃ B) → (B ≃ C) → A ≃ C
 eqA ⊙ eqB = Equivalence.compose eqA eqB

src/Cat/Categories/Span.agda

@@ -0,0 +1,173 @@
+{-# OPTIONS --cubical --caching #-}
+module Cat.Categories.Span where
+
+open import Cat.Prelude as P hiding (_×_ ; fst ; snd)
+open import Cat.Equivalence
+open import Cat.Category
+
+module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb)
+  (let module ℂ = Category ℂ) (𝒜 ℬ : ℂ.Object) where
+
+  open P
+
+  private
+    module _ where
+      raw : RawCategory _ _
+      raw = record
+        { Object = Σ[ X ∈ ℂ.Object ] ℂ.Arrow X 𝒜 × ℂ.Arrow X ℬ
+        ; Arrow = λ{ (A , a0 , a1) (B , b0 , b1)
+          → Σ[ f ∈ ℂ.Arrow A B ]
+              ℂ [ b0 ∘ f ] ≡ a0
+            × ℂ [ b1 ∘ f ] ≡ a1
+            }
+        ; identity = λ{ {X , f , g} → ℂ.identity {X} , ℂ.rightIdentity , ℂ.rightIdentity}
+        ; _<<<_ = λ { {_ , a0 , a1} {_ , b0 , b1} {_ , c0 , c1} (f , f0 , f1) (g , g0 , g1)
+          → (f ℂ.<<< g)
+            , (begin
+                ℂ [ c0 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
+                ℂ [ ℂ [ c0 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f0 ⟩
+                ℂ [ b0 ∘ g ] ≡⟨ g0 ⟩
+                a0 ∎
+              )
+            , (begin
+               ℂ [ c1 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
+               ℂ [ ℂ [ c1 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f1 ⟩
+               ℂ [ b1 ∘ g ] ≡⟨ g1 ⟩
+                a1 ∎
+              )
+          }
+        }
+
+      module _ where
+        open RawCategory raw
+
+        propEqs : ∀ {X' : Object}{Y' : Object} (let X , xa , xb = X') (let Y , ya , yb = Y')
+                    → (xy : ℂ.Arrow X Y) → isProp (ℂ [ ya ∘ xy ] ≡ xa × ℂ [ yb ∘ xy ] ≡ xb)
+        propEqs xs = propSig (ℂ.arrowsAreSets _ _) (\ _ → ℂ.arrowsAreSets _ _)
+
+        arrowEq : {X Y : Object} {f g : Arrow X Y} → fst f ≡ fst g → f ≡ g
+        arrowEq {X} {Y} {f} {g} p = λ i → p i , lemPropF propEqs p {snd f} {snd g} i
+
+        isAssociative : IsAssociative
+        isAssociative {f = f , f0 , f1} {g , g0 , g1} {h , h0 , h1} = arrowEq ℂ.isAssociative
+
+        isIdentity : IsIdentity identity
+        isIdentity {AA@(A , a0 , a1)} {BB@(B , b0 , b1)} {f , f0 , f1} = arrowEq ℂ.leftIdentity , arrowEq ℂ.rightIdentity
+
+        arrowsAreSets : ArrowsAreSets
+        arrowsAreSets {X , x0 , x1} {Y , y0 , y1}
+          = sigPresSet ℂ.arrowsAreSets λ a → propSet (propEqs _)
+
+        isPreCat : IsPreCategory raw
+        IsPreCategory.isAssociative isPreCat = isAssociative
+        IsPreCategory.isIdentity    isPreCat = isIdentity
+        IsPreCategory.arrowsAreSets isPreCat = arrowsAreSets
+
+      open IsPreCategory isPreCat
+
+      module _ {𝕏 𝕐 : Object} where
+        open Σ 𝕏 renaming (fst to X ; snd to x)
+        open Σ x renaming (fst to xa ; snd to xb)
+        open Σ 𝕐 renaming (fst to Y ; snd to y)
+        open Σ y renaming (fst to ya ; snd to yb)
+        open import Cat.Equivalence using (composeIso) renaming (_≅_ to _≅_)
+        step0
+          : ((X , xa , xb) ≡ (Y , ya , yb))
+          ≅ (Σ[ p ∈ (X ≡ Y) ] (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb))
+        step0
+          = (λ p → cong fst p , cong-d (fst ∘ snd) p , cong-d (snd ∘ snd) p)
+          -- , (λ x  → λ i → fst x i , (fst (snd x) i) , (snd (snd x) i))
+          , (λ{ (p , q , r) → Σ≡ p λ i → q i , r i})
+          , funExt (λ{ p → refl})
+          , funExt (λ{ (p , q , r) → refl})
+
+        step1
+          : (Σ[ p ∈ (X ≡ Y) ] (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb))
+          ≅ Σ (X ℂ.≊ Y) (λ iso
+            → let p = ℂ.isoToId iso
+            in
+            ( PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya)
+            × PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb
+            )
+        step1
+          = symIso
+              (isoSigFst
+                {A = (X ℂ.≊ Y)}
+                {B = (X ≡ Y)}
+                (ℂ.groupoidObject _ _)
+                {Q = \ p → (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb)}
+                ℂ.isoToId
+                (symIso (_ , ℂ.asTypeIso {X} {Y}) .snd)
+              )
+
+        step2
+          : Σ (X ℂ.≊ Y) (λ iso
+            → let p = ℂ.isoToId iso
+            in
+            ( PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya)
+            × PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb
+            )
+          ≅ ((X , xa , xb) ≊ (Y , ya , yb))
+        step2
+          = ( λ{ (iso@(f , f~ , inv-f) , p , q)
+              → ( f  , sym (ℂ.domain-twist-sym  iso p) , sym (ℂ.domain-twist-sym iso q))
+              , ( f~ , sym (ℂ.domain-twist      iso p) , sym (ℂ.domain-twist     iso q))
+              , arrowEq (fst inv-f)
+              , arrowEq (snd inv-f)
+              }
+            )
+          , (λ{ (f , f~ , inv-f , inv-f~) →
+            let
+              iso : X ℂ.≊ Y
+              iso = fst f , fst f~ , cong fst inv-f , cong fst inv-f~
+              p : X ≡ Y
+              p = ℂ.isoToId iso
+              pA : ℂ.Arrow X 𝒜 ≡ ℂ.Arrow Y 𝒜
+              pA = cong (λ x → ℂ.Arrow x 𝒜) p
+              pB : ℂ.Arrow X ℬ ≡ ℂ.Arrow Y ℬ
+              pB = cong (λ x → ℂ.Arrow x ℬ) p
+              k0 = begin
+                coe pB xb ≡⟨ ℂ.coe-dom iso ⟩
+                xb ℂ.<<< fst f~ ≡⟨ snd (snd f~) ⟩
+                yb ∎
+              k1 = begin
+                coe pA xa ≡⟨ ℂ.coe-dom iso ⟩
+                xa ℂ.<<< fst f~ ≡⟨ fst (snd f~) ⟩
+                ya ∎
+            in iso , coe-lem-inv k1 , coe-lem-inv k0})
+          , funExt (λ x → lemSig
+              (λ x → propSig prop0 (λ _ → prop1))
+              _ _
+              (Σ≡ refl (ℂ.propIsomorphism _ _ _)))
+          , funExt (λ{ (f , _) → lemSig propIsomorphism _ _ (Σ≡ refl (propEqs _ _ _))})
+            where
+            prop0 : ∀ {x} → isProp (PathP (λ i → ℂ.Arrow (ℂ.isoToId x i) 𝒜) xa ya)
+            prop0 {x} = pathJ (λ y p → ∀ x → isProp (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa x)) (λ x → ℂ.arrowsAreSets _ _) Y (ℂ.isoToId x) ya
+            prop1 : ∀ {x} → isProp (PathP (λ i → ℂ.Arrow (ℂ.isoToId x i) ℬ) xb yb)
+            prop1 {x} = pathJ (λ y p → ∀ x → isProp (PathP (λ i → ℂ.Arrow (p i) ℬ) xb x)) (λ x → ℂ.arrowsAreSets _ _) Y (ℂ.isoToId x) yb
+        -- One thing to watch out for here is that the isomorphisms going forwards
+        -- must compose to give idToIso
+        iso
+          : ((X , xa , xb) ≡ (Y , ya , yb))
+          ≅ ((X , xa , xb) ≊ (Y , ya , yb))
+        iso = step0 ⊙ step1 ⊙ step2
+          where
+          infixl 5 _⊙_
+          _⊙_ = composeIso
+        equiv1
+          : ((X , xa , xb) ≡ (Y , ya , yb))
+          ≃ ((X , xa , xb) ≊ (Y , ya , yb))
+        equiv1 = _ , fromIso _ _ (snd iso)
+
+      univalent : Univalent
+      univalent = univalenceFrom≃ equiv1
+
+      isCat : IsCategory raw
+      IsCategory.isPreCategory isCat = isPreCat
+      IsCategory.univalent     isCat = univalent
+
+  span : Category _ _
+  span = record
+    { raw = raw
+    ; isCategory = isCat
+    }

src/Cat/Category.agda

@@ -631,95 +631,3 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
 
   _[_∘_] : {A B C : Object} → (g : Arrow B C) → (f : Arrow A B) → Arrow A C
   _[_∘_] = _<<<_
-
--- | The opposite category
---
--- The opposite category is the category where the direction of the arrows are
--- flipped.
-module Opposite {ℓa ℓb : Level} where
-  module _ (ℂ : Category ℓa ℓb) where
-    private
-      module _ where
-        module ℂ = Category ℂ
-        opRaw : RawCategory ℓa ℓb
-        RawCategory.Object   opRaw = ℂ.Object
-        RawCategory.Arrow    opRaw = flip ℂ.Arrow
-        RawCategory.identity opRaw = ℂ.identity
-        RawCategory._<<<_    opRaw = ℂ._>>>_
-
-        open RawCategory opRaw
-
-        isPreCategory : IsPreCategory opRaw
-        IsPreCategory.isAssociative isPreCategory = sym ℂ.isAssociative
-        IsPreCategory.isIdentity    isPreCategory = swap ℂ.isIdentity
-        IsPreCategory.arrowsAreSets isPreCategory = ℂ.arrowsAreSets
-
-      open IsPreCategory isPreCategory
-
-      module _ {A B : ℂ.Object} where
-        open Σ (toIso _ _ (ℂ.univalent {A} {B}))
-          renaming (fst to idToIso* ; snd to inv*)
-        open AreInverses {f = ℂ.idToIso A B} {idToIso*} inv*
-
-        shuffle : A ≊ B → A ℂ.≊ B
-        shuffle (f , g , inv) = g , f , inv
-
-        shuffle~ : A ℂ.≊ B → A ≊ B
-        shuffle~ (f , g , inv) = g , f , inv
-
-        lem : (p : A ≡ B) → idToIso A B p ≡ shuffle~ (ℂ.idToIso A B p)
-        lem p = isoEq refl
-
-        isoToId* : A ≊ B → A ≡ B
-        isoToId* = idToIso* ∘ shuffle
-
-        inv : AreInverses (idToIso A B) isoToId*
-        inv =
-          ( funExt (λ x → begin
-            (isoToId* ∘ idToIso A B) x
-              ≡⟨⟩
-            (idToIso*  ∘ shuffle ∘ idToIso A B) x
-              ≡⟨ cong (λ φ → φ x) (cong (λ φ → idToIso* ∘ shuffle ∘ φ) (funExt lem)) ⟩
-            (idToIso*  ∘ shuffle ∘ shuffle~ ∘ ℂ.idToIso A B) x
-              ≡⟨⟩
-            (idToIso*  ∘ ℂ.idToIso A B) x
-              ≡⟨ (λ i → verso-recto i x) ⟩
-            x ∎)
-          , funExt (λ x → begin
-            (idToIso A B ∘ idToIso* ∘ shuffle) x
-              ≡⟨ cong (λ φ → φ x) (cong (λ φ → φ ∘ idToIso* ∘ shuffle) (funExt lem)) ⟩
-            (shuffle~ ∘ ℂ.idToIso A B ∘ idToIso* ∘ shuffle) x
-              ≡⟨ cong (λ φ → φ x) (cong (λ φ → shuffle~ ∘ φ ∘ shuffle) recto-verso) ⟩
-            (shuffle~ ∘ shuffle) x
-              ≡⟨⟩
-            x ∎)
-          )
-
-      isCategory : IsCategory opRaw
-      IsCategory.isPreCategory isCategory = isPreCategory
-      IsCategory.univalent     isCategory
-        = univalenceFromIsomorphism (isoToId* , inv)
-
-    opposite : Category ℓa ℓb
-    Category.raw        opposite = opRaw
-    Category.isCategory opposite = isCategory
-
-  -- As demonstrated here a side-effect of having no-eta-equality on constructors
-  -- means that we need to pick things apart to show that things are indeed
-  -- definitionally equal. I.e; a thing that would normally be provable in one
-  -- line now takes 13!! Admittedly it's a simple proof.
-  module _ {ℂ : Category ℓa ℓb} where
-    open Category ℂ
-    private
-      -- Since they really are definitionally equal we just need to pick apart
-      -- the data-type.
-      rawInv : Category.raw (opposite (opposite ℂ)) ≡ raw
-      RawCategory.Object   (rawInv _) = Object
-      RawCategory.Arrow    (rawInv _) = Arrow
-      RawCategory.identity (rawInv _) = identity
-      RawCategory._<<<_    (rawInv _) = _<<<_
-
-    oppositeIsInvolution : opposite (opposite ℂ) ≡ ℂ
-    oppositeIsInvolution = Category≡ rawInv
-
-open Opposite public

src/Cat/Category/Product.agda

@@ -55,16 +55,18 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
         ×  ℂ [ g ∘ snd ]
         ]
 
-module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} {A B : Category.Object ℂ} where
+module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb}
+  (let module ℂ = Category ℂ) {𝒜 ℬ : ℂ.Object} where
   private
-    open Category ℂ
+    module _ (raw : RawProduct ℂ 𝒜 ℬ) where
-    module _ (raw : RawProduct ℂ A B) where
+      private
-      module _ (x y : IsProduct ℂ A B raw) where
+        open Category ℂ hiding (raw)
+        module _ (x y : IsProduct ℂ 𝒜 ℬ raw) where
           private
             module x = IsProduct x
             module y = IsProduct y
 
-        module _ {X : Object} (f : ℂ [ X , A ]) (g : ℂ [ X , B ]) where
+          module _ {X : Object} (f : ℂ [ X , 𝒜 ]) (g : ℂ [ X , ℬ ]) where
             module _ (f×g : Arrow X y.object) where
               help : isProp (∀{y} → (ℂ [ y.fst ∘ y ] ≡ f) P.× (ℂ [ y.snd ∘ y ] ≡ g) → f×g ≡ y)
               help = propPiImpl (λ _ → propPi (λ _ → arrowsAreSets _ _))
@@ -77,188 +79,22 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} {A B : Category.Object
           propIsProduct' : x ≡ y
           propIsProduct' i = record { ump = λ f g → prodAux f g i }
 
-      propIsProduct : isProp (IsProduct ℂ A B raw)
+      propIsProduct : isProp (IsProduct ℂ 𝒜 ℬ raw)
       propIsProduct = propIsProduct'
 
-  Product≡ : {x y : Product ℂ A B} → (Product.raw x ≡ Product.raw y) → x ≡ y
+    Product≡ : {x y : Product ℂ 𝒜 ℬ} → (Product.raw x ≡ Product.raw y) → x ≡ y
     Product≡ {x} {y} p i = record { raw = p i ; isProduct = q i }
       where
-    q : (λ i → IsProduct ℂ A B (p i)) [ Product.isProduct x ≡ Product.isProduct y ]
+      q : (λ i → IsProduct ℂ 𝒜 ℬ (p i)) [ Product.isProduct x ≡ Product.isProduct y ]
       q = lemPropF propIsProduct p
 
-module Try0 {ℓa ℓb : Level} {ℂ : Category ℓa ℓb}
-  (let module ℂ = Category ℂ) {𝒜 ℬ : ℂ.Object} where
-
     open P
+    open import Cat.Categories.Span
 
-  module _ where
+    open Category (span ℂ 𝒜 ℬ)
-    raw : RawCategory _ _
-    raw = record
-      { Object = Σ[ X ∈ ℂ.Object ] ℂ.Arrow X 𝒜 × ℂ.Arrow X ℬ
-      ; Arrow = λ{ (A , a0 , a1) (B , b0 , b1)
-        → Σ[ f ∈ ℂ.Arrow A B ]
-            ℂ [ b0 ∘ f ] ≡ a0
-          × ℂ [ b1 ∘ f ] ≡ a1
-          }
-      ; identity = λ{ {X , f , g} → ℂ.identity {X} , ℂ.rightIdentity , ℂ.rightIdentity}
-      ; _<<<_ = λ { {_ , a0 , a1} {_ , b0 , b1} {_ , c0 , c1} (f , f0 , f1) (g , g0 , g1)
-        → (f ℂ.<<< g)
-          , (begin
-              ℂ [ c0 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
-              ℂ [ ℂ [ c0 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f0 ⟩
-              ℂ [ b0 ∘ g ] ≡⟨ g0 ⟩
-              a0 ∎
-            )
-          , (begin
-             ℂ [ c1 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
-             ℂ [ ℂ [ c1 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f1 ⟩
-             ℂ [ b1 ∘ g ] ≡⟨ g1 ⟩
-              a1 ∎
-            )
-        }
-      }
-
-    module _ where
-      open RawCategory raw
-
-      propEqs : ∀ {X' : Object}{Y' : Object} (let X , xa , xb = X') (let Y , ya , yb = Y')
-                  → (xy : ℂ.Arrow X Y) → isProp (ℂ [ ya ∘ xy ] ≡ xa × ℂ [ yb ∘ xy ] ≡ xb)
-      propEqs xs = propSig (ℂ.arrowsAreSets _ _) (\ _ → ℂ.arrowsAreSets _ _)
-
-      arrowEq : {X Y : Object} {f g : Arrow X Y} → fst f ≡ fst g → f ≡ g
-      arrowEq {X} {Y} {f} {g} p = λ i → p i , lemPropF propEqs p {snd f} {snd g} i
-
-      private
-        isAssociative : IsAssociative
-        isAssociative {f = f , f0 , f1} {g , g0 , g1} {h , h0 , h1} = arrowEq ℂ.isAssociative
-
-        isIdentity : IsIdentity identity
-        isIdentity {AA@(A , a0 , a1)} {BB@(B , b0 , b1)} {f , f0 , f1} = arrowEq ℂ.leftIdentity , arrowEq ℂ.rightIdentity
-
-        arrowsAreSets : ArrowsAreSets
-        arrowsAreSets {X , x0 , x1} {Y , y0 , y1}
-          = sigPresSet ℂ.arrowsAreSets λ a → propSet (propEqs _)
-
-      isPreCat : IsPreCategory raw
-      IsPreCategory.isAssociative isPreCat = isAssociative
-      IsPreCategory.isIdentity    isPreCat = isIdentity
-      IsPreCategory.arrowsAreSets isPreCat = arrowsAreSets
-
-    open IsPreCategory isPreCat
-
-    module _ {𝕏 𝕐 : Object} where
-      open Σ 𝕏 renaming (fst to X ; snd to x)
-      open Σ x renaming (fst to xa ; snd to xb)
-      open Σ 𝕐 renaming (fst to Y ; snd to y)
-      open Σ y renaming (fst to ya ; snd to yb)
-      open import Cat.Equivalence using (composeIso) renaming (_≅_ to _≅_)
-      step0
-        : ((X , xa , xb) ≡ (Y , ya , yb))
-        ≅ (Σ[ p ∈ (X ≡ Y) ] (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb))
-      step0
-        = (λ p → cong fst p , cong-d (fst ∘ snd) p , cong-d (snd ∘ snd) p)
-        -- , (λ x  → λ i → fst x i , (fst (snd x) i) , (snd (snd x) i))
-        , (λ{ (p , q , r) → Σ≡ p λ i → q i , r i})
-        , funExt (λ{ p → refl})
-        , funExt (λ{ (p , q , r) → refl})
-
-      step1
-        : (Σ[ p ∈ (X ≡ Y) ] (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb))
-        ≅ Σ (X ℂ.≊ Y) (λ iso
-          → let p = ℂ.isoToId iso
-          in
-          ( PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya)
-          × PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb
-          )
-      step1
-        = symIso
-            (isoSigFst
-              {A = (X ℂ.≊ Y)}
-              {B = (X ≡ Y)}
-              (ℂ.groupoidObject _ _)
-              {Q = \ p → (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb)}
-              ℂ.isoToId
-              (symIso (_ , ℂ.asTypeIso {X} {Y}) .snd)
-            )
-
-      step2
-        : Σ (X ℂ.≊ Y) (λ iso
-          → let p = ℂ.isoToId iso
-          in
-          ( PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya)
-          × PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb
-          )
-        ≅ ((X , xa , xb) ≊ (Y , ya , yb))
-      step2
-        = ( λ{ (iso@(f , f~ , inv-f) , p , q)
-            → ( f  , sym (ℂ.domain-twist-sym  iso p) , sym (ℂ.domain-twist-sym iso q))
-            , ( f~ , sym (ℂ.domain-twist      iso p) , sym (ℂ.domain-twist     iso q))
-            , arrowEq (fst inv-f)
-            , arrowEq (snd inv-f)
-            }
-          )
-        , (λ{ (f , f~ , inv-f , inv-f~) →
-          let
-            iso : X ℂ.≊ Y
-            iso = fst f , fst f~ , cong fst inv-f , cong fst inv-f~
-            p : X ≡ Y
-            p = ℂ.isoToId iso
-            pA : ℂ.Arrow X 𝒜 ≡ ℂ.Arrow Y 𝒜
-            pA = cong (λ x → ℂ.Arrow x 𝒜) p
-            pB : ℂ.Arrow X ℬ ≡ ℂ.Arrow Y ℬ
-            pB = cong (λ x → ℂ.Arrow x ℬ) p
-            k0 = begin
-              coe pB xb ≡⟨ ℂ.coe-dom iso ⟩
-              xb ℂ.<<< fst f~ ≡⟨ snd (snd f~) ⟩
-              yb ∎
-            k1 = begin
-              coe pA xa ≡⟨ ℂ.coe-dom iso ⟩
-              xa ℂ.<<< fst f~ ≡⟨ fst (snd f~) ⟩
-              ya ∎
-          in iso , coe-lem-inv k1 , coe-lem-inv k0})
-        , funExt (λ x → lemSig
-            (λ x → propSig prop0 (λ _ → prop1))
-            _ _
-            (Σ≡ refl (ℂ.propIsomorphism _ _ _)))
-        , funExt (λ{ (f , _) → lemSig propIsomorphism _ _ (Σ≡ refl (propEqs _ _ _))})
-          where
-          prop0 : ∀ {x} → isProp (PathP (λ i → ℂ.Arrow (ℂ.isoToId x i) 𝒜) xa ya)
-          prop0 {x} = pathJ (λ y p → ∀ x → isProp (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa x)) (λ x → ℂ.arrowsAreSets _ _) Y (ℂ.isoToId x) ya
-          prop1 : ∀ {x} → isProp (PathP (λ i → ℂ.Arrow (ℂ.isoToId x i) ℬ) xb yb)
-          prop1 {x} = pathJ (λ y p → ∀ x → isProp (PathP (λ i → ℂ.Arrow (p i) ℬ) xb x)) (λ x → ℂ.arrowsAreSets _ _) Y (ℂ.isoToId x) yb
-      -- One thing to watch out for here is that the isomorphisms going forwards
-      -- must compose to give idToIso
-      iso
-        : ((X , xa , xb) ≡ (Y , ya , yb))
-        ≅ ((X , xa , xb) ≊ (Y , ya , yb))
-      iso = step0 ⊙ step1 ⊙ step2
-        where
-        infixl 5 _⊙_
-        _⊙_ = composeIso
-      equiv1
-        : ((X , xa , xb) ≡ (Y , ya , yb))
-        ≃ ((X , xa , xb) ≊ (Y , ya , yb))
-      equiv1 = _ , fromIso _ _ (snd iso)
-
-    univalent : Univalent
-    univalent = univalenceFrom≃ equiv1
-
-    isCat : IsCategory raw
-    IsCategory.isPreCategory isCat = isPreCat
-    IsCategory.univalent     isCat = univalent
-
-    cat : Category _ _
-    cat = record
-      { raw = raw
-      ; isCategory = isCat
-      }
-
-  open Category cat
 
     lemma : Terminal ≃ Product ℂ 𝒜 ℬ
     lemma = fromIsomorphism Terminal (Product ℂ 𝒜 ℬ) (f , g , inv)
-  -- C-x 8 RET MATHEMATICAL BOLD SCRIPT CAPITAL A
-  -- 𝒜
       where
       f : Terminal → Product ℂ 𝒜 ℬ
       f ((X , x0 , x1) , uniq) = p
@@ -348,10 +184,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} {A B : Category.Object
         module y = HasProducts y
 
       productEq : x.product ≡ y.product
-      productEq = funExt λ A → funExt λ B → Try0.propProduct _ _
+      productEq = funExt λ A → funExt λ B → propProduct _ _
 
   propHasProducts : isProp (HasProducts ℂ)
   propHasProducts x y i = record { product = productEq x y i }
-
-fmap≡ : {A : Set} {a0 a1 : A} {B : Set} → (f : A → B) → Path a0 a1 → Path (f a0) (f a1)
-fmap≡ = cong

src/Cat/Category/Yoneda.agda

@@ -9,9 +9,9 @@ open import Cat.Category.Functor
 open import Cat.Category.NaturalTransformation
   renaming (module Properties to F)
   using ()
-
+open import Cat.Categories.Opposite
-open import Cat.Categories.Fun using (module Fun)
 open import Cat.Categories.Sets hiding (presheaf)
+open import Cat.Categories.Fun using (module Fun)
 
 -- There is no (small) category of categories. So we won't use _⇑_ from
 -- `HasExponential`