Merge pull request #248 from TOTBWF/spans-bicategory

Show that Monads in Span(Setoid) are categories

src/Categories/Bicategory/Construction/Spans/Properties.agda

@@ -0,0 +1,133 @@
+{-# OPTIONS --without-K --safe #-}
+
+module Categories.Bicategory.Construction.Spans.Properties where
+
+open import Level
+
+open import Data.Product using (_,_; _×_)
+open import Relation.Binary.Bundles using (Setoid)
+import Relation.Binary.Reasoning.Setoid as SR
+open import Function.Equality as SΠ renaming (id to ⟶-id)
+
+open import Categories.Category
+open import Categories.Category.Helper
+open import Categories.Category.Instance.Setoids
+open import Categories.Category.Instance.Properties.Setoids.Limits.Canonical
+
+open import Categories.Diagram.Pullback
+
+open import Categories.Bicategory
+open import Categories.Bicategory.Monad
+
+import Categories.Category.Diagram.Span as Span
+import Categories.Bicategory.Construction.Spans as Spans
+
+--------------------------------------------------------------------------------
+-- Monads in the Bicategory of Spans are Categories
+
+module _ {o ℓ : Level} (T : Monad (Spans.Spans (pullback o ℓ))) where
+
+  private
+    module T = Monad T
+
+    open Span (Setoids (o ⊔ ℓ) ℓ)
+    open Spans (pullback o ℓ)
+    open Span⇒
+    open Bicategory Spans
+
+    open Setoid renaming (_≈_ to [_][_≈_])
+
+
+  -- We can view the roof of the span as a hom set! However, we need to partition
+  -- this big set up into small chunks with known domains/codomains.
+  record Hom (X Y : Carrier T.C) : Set (o ⊔ ℓ) where
+    field
+      hom : Carrier (Span.M T.T)
+      dom-eq : [ T.C ][ Span.dom T.T ⟨$⟩ hom ≈ X ]
+      cod-eq : [ T.C ][ Span.cod T.T ⟨$⟩ hom ≈ Y ]
+
+  open Hom
+
+  private
+    ObjSetoid : Setoid (o ⊔ ℓ) ℓ
+    ObjSetoid = T.C
+
+    HomSetoid : Setoid (o ⊔ ℓ) ℓ
+    HomSetoid = Span.M T.T
+
+    module ObjSetoid = Setoid ObjSetoid
+    module HomSetoid = Setoid HomSetoid
+
+    id⇒ : (X : Carrier T.C) → Hom X X
+    id⇒ X = record
+      { hom = arr T.η ⟨$⟩ X
+      ; dom-eq = commute-dom T.η (refl T.C)
+      ; cod-eq = commute-cod T.η (refl T.C)
+      }
+
+    _×ₚ_ : ∀ {A B C} → (f : Hom B C) → (g : Hom A B) → FiberProduct (Span.cod T.T) (Span.dom T.T)
+    _×ₚ_ {B = B} f g = record
+      { elem₁ = hom g
+      ; elem₂ = hom f
+      ; commute = begin
+        Span.cod T.T ⟨$⟩ hom g ≈⟨ cod-eq g ⟩
+        B                      ≈⟨ ObjSetoid.sym (dom-eq f) ⟩
+        Span.dom T.T ⟨$⟩ hom f ∎
+      }
+      where
+        open SR ObjSetoid
+
+    _∘⇒_ : ∀ {A B C} (f : Hom B C) → (g : Hom A B) → Hom A C
+    _∘⇒_ {A = A} {C = C} f g = record
+      { hom = arr T.μ ⟨$⟩ (f ×ₚ g)
+      ; dom-eq = begin
+        Span.dom T.T ⟨$⟩ (arr T.μ ⟨$⟩ (f ×ₚ g)) ≈⟨ (commute-dom T.μ {f ×ₚ g} {f ×ₚ g} (HomSetoid.refl , HomSetoid.refl)) ⟩
+        Span.dom T.T ⟨$⟩ hom g                  ≈⟨ dom-eq g ⟩
+        A                                       ∎
+      ; cod-eq = begin
+        Span.cod T.T ⟨$⟩ (arr T.μ ⟨$⟩ (f ×ₚ g)) ≈⟨ commute-cod T.μ {f ×ₚ g} {f ×ₚ g} (HomSetoid.refl , HomSetoid.refl) ⟩
+        Span.cod T.T ⟨$⟩ hom f                  ≈⟨ cod-eq f ⟩
+        C                                       ∎
+      }
+      where
+        open SR ObjSetoid
+
+  SpanMonad⇒Category : Category (o ⊔ ℓ) (o ⊔ ℓ) ℓ
+  SpanMonad⇒Category = categoryHelper record
+    { Obj = Setoid.Carrier T.C
+    ; _⇒_ = Hom
+    ; _≈_ = λ f g → [ HomSetoid ][ hom f ≈ hom g ]
+    ; id = λ {X} → id⇒ X
+    ; _∘_ = _∘⇒_
+    ; assoc = λ {A} {B} {C} {D} {f} {g} {h} →
+      let f×ₚ⟨g×ₚh⟩ = record
+            { elem₁ = record
+              { elem₁ = hom f
+              ; elem₂ = hom g
+              ; commute = FiberProduct.commute (g ×ₚ f)
+              }
+            ; elem₂ = hom h
+            ; commute = FiberProduct.commute (h ×ₚ g)
+            }
+      in begin
+        arr T.μ ⟨$⟩ ((h ∘⇒ g) ×ₚ f) ≈⟨ cong (arr T.μ) (HomSetoid.refl , cong (arr T.μ) (HomSetoid.refl , HomSetoid.refl)) ⟩
+        arr T.μ ⟨$⟩ _                ≈⟨ T.sym-assoc {f×ₚ⟨g×ₚh⟩} {f×ₚ⟨g×ₚh⟩} ((HomSetoid.refl , HomSetoid.refl) , HomSetoid.refl) ⟩
+        arr T.μ ⟨$⟩ _                ≈⟨ (cong (arr T.μ) (cong (arr T.μ) (HomSetoid.refl , HomSetoid.refl) , HomSetoid.refl)) ⟩
+        arr T.μ ⟨$⟩ (h ×ₚ (g ∘⇒ f)) ∎
+    ; identityˡ = λ {A} {B} {f} → begin
+      arr T.μ ⟨$⟩ (id⇒ B ×ₚ f) ≈⟨ cong (arr T.μ) (HomSetoid.refl , cong (arr T.η) (ObjSetoid.sym (cod-eq f))) ⟩
+      arr T.μ ⟨$⟩ _             ≈⟨ T.identityʳ HomSetoid.refl ⟩
+      hom f                     ∎
+    ; identityʳ = λ {A} {B} {f} → begin
+      arr T.μ ⟨$⟩ (f ×ₚ id⇒ A) ≈⟨ cong (arr T.μ) (cong (arr T.η) (ObjSetoid.sym (dom-eq f)) , HomSetoid.refl) ⟩
+      arr T.μ ⟨$⟩ _             ≈⟨ T.identityˡ HomSetoid.refl ⟩
+      hom f                     ∎
+    ; equiv = record
+      { refl = HomSetoid.refl
+      ; sym = HomSetoid.sym
+      ; trans = HomSetoid.trans
+      }
+    ; ∘-resp-≈ = λ f≈h g≈i → cong (arr T.μ) (g≈i , f≈h)
+    }
+      where
+        open SR HomSetoid

src/Categories/Bicategory/Monad.agda

@@ -0,0 +1,27 @@
+{-# OPTIONS --without-K --safe #-}
+
+-- A Monad in a Bicategory.
+-- For the more elementary version of Monads, see 'Categories.Monad'.
+module Categories.Bicategory.Monad where
+
+open import Level
+open import Data.Product using (_,_)
+
+open import Categories.Bicategory
+import Categories.Bicategory.Extras as Bicat
+open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism)
+
+
+record Monad {o ℓ e t} (𝒞 : Bicategory o ℓ e t) : Set (o ⊔ ℓ ⊔ e ⊔ t) where
+  open Bicat 𝒞
+
+  field
+    C : Obj
+    T : C ⇒₁ C
+    η : id₁ ⇒₂ T
+    μ : (T ⊚₀ T) ⇒₂ T
+
+    assoc     : μ ∘ᵥ (T ▷ μ) ∘ᵥ associator.from ≈ (μ ∘ᵥ (μ ◁ T))
+    sym-assoc : μ ∘ᵥ (μ ◁ T) ∘ᵥ associator.to ≈ (μ ∘ᵥ (T ▷ μ))
+    identityˡ : μ ∘ᵥ (T ▷ η) ∘ᵥ unitorʳ.to ≈ id₂
+    identityʳ : μ ∘ᵥ (η ◁ T) ∘ᵥ unitorˡ.to ≈ id₂

src/Categories/Bicategory/Monad/Properties.agda

@@ -0,0 +1,93 @@
+{-# OPTIONS --without-K --safe #-}
+module Categories.Bicategory.Monad.Properties where
+
+open import Categories.Category
+open import Categories.Bicategory.Instance.Cats
+open import Categories.NaturalTransformation using (NaturalTransformation)
+open import Categories.Functor using (Functor)
+
+import Categories.Bicategory.Monad as BicatMonad
+import Categories.Monad as ElemMonad
+
+import Categories.Morphism.Reasoning as MR
+
+--------------------------------------------------------------------------------
+-- Bicategorical Monads in Cat are the same as the more elementary
+-- definition of Monads.
+
+CatMonad⇒Monad : ∀ {o ℓ e} → (T : BicatMonad.Monad (Cats o ℓ e)) → ElemMonad.Monad (BicatMonad.Monad.C T)
+CatMonad⇒Monad T = record
+  { F = T.T
+  ; η = T.η
+  ; μ = T.μ
+  ; assoc = λ {X} → begin
+    η T.μ X ∘ F₁ T.T (η T.μ X)               ≈⟨ intro-ids ⟩
+    (η T.μ X ∘ (F₁ T.T (η T.μ X) ∘ id) ∘ id) ≈⟨ T.assoc ⟩
+    (η T.μ X ∘ F₁ T.T id ∘ η T.μ (F₀ T.T X)) ≈⟨ ∘-resp-≈ʳ (∘-resp-≈ˡ (identity T.T) ○ identityˡ) ⟩
+    η T.μ X ∘ η T.μ (F₀ T.T X)               ∎
+  ; sym-assoc = λ {X} → begin
+    η T.μ X ∘ η T.μ (F₀ T.T X)                    ≈⟨ intro-F-ids ⟩
+    η T.μ X ∘ (F₁ T.T id ∘ η T.μ (F₀ T.T X)) ∘ id ≈⟨ T.sym-assoc ⟩
+    η T.μ X ∘ F₁ T.T (η T.μ X) ∘ id               ≈⟨ ∘-resp-≈ʳ identityʳ ⟩
+    η T.μ X ∘ F₁ T.T (η T.μ X)                    ∎
+  ; identityˡ = λ {X} → begin
+    η T.μ X ∘ F₁ T.T (η T.η X)             ≈⟨ intro-ids ⟩
+    η T.μ X ∘ (F₁ T.T (η T.η X) ∘ id) ∘ id ≈⟨ T.identityˡ ⟩
+    id                                     ∎
+  ; identityʳ = λ {X} → begin
+    η T.μ X ∘ η T.η (F₀ T.T X)                    ≈⟨ intro-F-ids ⟩
+    η T.μ X ∘ (F₁ T.T id ∘ η T.η (F₀ T.T X)) ∘ id ≈⟨ T.identityʳ ⟩
+    id                                            ∎
+  }
+  where
+    module T = BicatMonad.Monad T
+    open Category (BicatMonad.Monad.C T)
+    open HomReasoning
+    open Equiv
+    open MR (BicatMonad.Monad.C T)
+
+    open NaturalTransformation
+    open Functor
+
+    intro-ids : ∀ {X Y Z} {f : Y ⇒ Z} {g : X ⇒ Y} → f ∘ g ≈ f ∘ (g ∘ id) ∘ id
+    intro-ids = ⟺ (∘-resp-≈ʳ identityʳ) ○ ⟺ (∘-resp-≈ʳ identityʳ)
+
+    intro-F-ids : ∀ {X Y Z} {f : F₀ T.T Y ⇒ Z} {g : X ⇒ F₀ T.T Y} → f ∘ g ≈ f ∘ (F₁ T.T id ∘ g) ∘ id
+    intro-F-ids = ∘-resp-≈ʳ (⟺ identityˡ ○  ⟺ (∘-resp-≈ˡ (identity T.T))) ○ ⟺ (∘-resp-≈ʳ identityʳ)
+
+Monad⇒CatMonad : ∀ {o ℓ e} {𝒞 : Category o ℓ e} → (T : ElemMonad.Monad 𝒞) → BicatMonad.Monad (Cats o ℓ e)
+Monad⇒CatMonad {𝒞 = 𝒞} T = record
+  { C = 𝒞
+  ; T = T.F
+  ; η = T.η
+  ; μ = T.μ
+  ; assoc = λ {X} → begin
+    T.μ.η X ∘ (T.F.F₁ (T.μ.η X) ∘ id) ∘ id ≈⟨ eliminate-ids ⟩
+    T.μ.η X ∘ T.F.F₁ (T.μ.η X)             ≈⟨ T.assoc ⟩
+    T.μ.η X ∘ T.μ.η (T.F.F₀ X)             ≈⟨ ∘-resp-≈ʳ (⟺ identityˡ ○ ∘-resp-≈ˡ (⟺ T.F.identity)) ⟩
+    T.μ.η X ∘ T.F.F₁ id ∘ T.μ.η (T.F.F₀ X) ∎
+  ; sym-assoc = λ {X} → begin
+    T.μ.η X ∘ (T.F.F₁ id ∘ T.μ.η (T.F.F₀ X)) ∘ id ≈⟨ eliminate-F-ids ⟩
+    T.μ.η X ∘ T.μ.η (T.F.F₀ X)                    ≈⟨ T.sym-assoc ⟩
+    T.μ.η X ∘ T.F.F₁ (T.μ.η X)                    ≈⟨ ∘-resp-≈ʳ (⟺ identityʳ) ⟩
+    T.μ.η X ∘ T.F.F₁ (T.μ.η X) ∘ id               ∎
+  ; identityˡ = λ {X} → begin
+    T.μ.η X ∘ (T.F.F₁ (T.η.η X) ∘ id) ∘ id ≈⟨ eliminate-ids ⟩
+    T.μ.η X ∘ T.F.F₁ (T.η.η X)             ≈⟨ T.identityˡ ⟩
+    id                                     ∎
+  ; identityʳ = λ {X} → begin
+    (T.μ.η X ∘ (T.F.F₁ id ∘ T.η.η (T.F.F₀ X)) ∘ id) ≈⟨ eliminate-F-ids ⟩
+    T.μ.η X ∘ T.η.η (T.F.F₀ X)                      ≈⟨ T.identityʳ ⟩
+    id                                              ∎
+  }
+  where
+    module T = ElemMonad.Monad T
+    open Category 𝒞
+    open HomReasoning
+    open MR 𝒞
+
+    eliminate-ids : ∀ {X Y Z} {f : Y ⇒ Z} {g : X ⇒ Y} →  f ∘ (g ∘ id) ∘ id ≈ f ∘ g
+    eliminate-ids = ∘-resp-≈ʳ identityʳ ○ ∘-resp-≈ʳ identityʳ
+
+    eliminate-F-ids : ∀ {X Y Z} {f : T.F.F₀ Y ⇒ Z} {g : X ⇒ T.F.F₀ Y} →  f ∘ (T.F.F₁ id ∘ g) ∘ id ≈ f ∘ g
+    eliminate-F-ids = ∘-resp-≈ʳ identityʳ ○ ∘-resp-≈ʳ (∘-resp-≈ˡ T.F.identity ○ identityˡ)

src/Categories/Category/Instance/Properties/Setoids/Limits/Canonical.agda

@@ -0,0 +1,62 @@
+{-# OPTIONS --without-K --safe #-}
+
+-- A "canonical" presentation of limits in Setoid.
+--
+-- These limits are obviously isomorphic to those created by
+-- the Completeness proof, but are far less unweildy to work with.
+-- This isomorphism is witnessed by Categories.Diagram.Pullback.up-to-iso
+
+module Categories.Category.Instance.Properties.Setoids.Limits.Canonical where
+
+open import Level
+
+open import Data.Product using (_,_; _×_)
+
+open import Relation.Binary.Bundles using (Setoid)
+open import Function.Equality as SΠ renaming (id to ⟶-id)
+import Relation.Binary.Reasoning.Setoid as SR
+
+open import Categories.Diagram.Pullback
+
+open import Categories.Category.Instance.Setoids
+
+open Setoid renaming (_≈_ to [_][_≈_])
+
+--------------------------------------------------------------------------------
+-- Pullbacks
+
+record FiberProduct {o ℓ} {X Y Z : Setoid o ℓ} (f : X ⟶ Z) (g : Y ⟶ Z) : Set (o ⊔ ℓ) where
+  field
+    elem₁ : Carrier X
+    elem₂ : Carrier Y
+    commute : [ Z ][ f ⟨$⟩ elem₁ ≈ g ⟨$⟩ elem₂ ]
+
+open FiberProduct
+
+pullback : ∀ (o ℓ : Level) {X Y Z : Setoid (o ⊔ ℓ) ℓ} → (f : X ⟶ Z) → (g : Y ⟶ Z) → Pullback (Setoids (o ⊔ ℓ) ℓ) f g
+pullback _ _ {X = X} {Y = Y} {Z = Z} f g = record
+  { P = record
+    { Carrier = FiberProduct f g
+    ; _≈_ =  λ p q → [ X ][ elem₁ p ≈ elem₁ q ] × [ Y ][ elem₂ p ≈ elem₂ q ]
+    ; isEquivalence = record
+      { refl = (refl X) , (refl Y)
+      ; sym = λ (eq₁ , eq₂) → sym X eq₁ , sym Y eq₂
+      ; trans = λ (eq₁ , eq₂) (eq₁′ , eq₂′) → (trans X eq₁ eq₁′) , (trans Y eq₂ eq₂′)
+      }
+    }
+    ; p₁ = record { _⟨$⟩_ = elem₁ ; cong = λ (eq₁ , _) → eq₁ }
+    ; p₂ = record { _⟨$⟩_ = elem₂ ; cong = λ (_ , eq₂) → eq₂ }
+    ; isPullback = record
+      { commute = λ {p} {q} (eq₁ , eq₂) → trans Z (cong f eq₁) (commute q)
+      ; universal = λ {A} {h₁} {h₂} eq → record
+        { _⟨$⟩_ = λ a → record
+          { elem₁ = h₁ ⟨$⟩ a
+          ; elem₂ = h₂ ⟨$⟩ a
+          ; commute = eq (refl A)
+          }
+        ; cong = λ eq → cong h₁ eq , cong h₂ eq }
+      ; unique = λ eq₁ eq₂ x≈y → eq₁ x≈y , eq₂ x≈y
+      ; p₁∘universal≈h₁ = λ {_} {h₁} {_} eq → cong h₁ eq
+      ; p₂∘universal≈h₂ = λ {_} {_} {h₂} eq → cong h₂ eq
+      }
+    }