cat/src/Cat/Category.agda

206 lines
7.8 KiB
Agda
Raw Normal View History

2017-11-10 15:00:00 +00:00
{-# OPTIONS --cubical #-}
module Cat.Category where
2017-11-10 15:00:00 +00:00
open import Agda.Primitive
open import Data.Unit.Base
open import Data.Product renaming
( proj₁ to fst
; proj₂ to snd
; ∃! to ∃!≈
)
2017-11-15 21:56:04 +00:00
open import Data.Empty
import Function
2017-12-12 11:39:58 +00:00
open import Cubical
2017-11-10 15:00:00 +00:00
∃! : {a b} {A : Set a}
(A Set b) Set (a b)
∃! = ∃!≈ _≡_
∃!-syntax : {a b} {A : Set a} (A Set b) Set (a b)
∃!-syntax =
syntax ∃!-syntax (λ x B) = ∃![ x ] B
-- All projections must be `isProp`'s
record IsCategory { ' : Level}
(Object : Set )
(Arrow : Object Object Set ')
(𝟙 : {o : Object} Arrow o o)
(_⊕_ : { a b c : Object } Arrow b c Arrow a b Arrow a c)
: Set (lsuc (' )) where
field
assoc : {A B C D : Object} { f : Arrow A B } { g : Arrow B C } { h : Arrow C D }
h (g f) (h g) f
ident : {A B : Object} {f : Arrow A B}
f 𝟙 f × 𝟙 f f
-- open IsCategory public
record Category ( ' : Level) : Set (lsuc (' )) where
-- adding no-eta-equality can speed up type-checking.
no-eta-equality
2017-11-10 15:00:00 +00:00
field
-- Need something like:
-- Object : Σ (Set ) isGroupoid
2017-11-10 15:00:00 +00:00
Object : Set
-- And:
-- Arrow : Object → Object → Σ (Set ') isSet
2017-11-10 15:00:00 +00:00
Arrow : Object Object Set '
𝟙 : {o : Object} Arrow o o
_∘_ : {A B C : Object} Arrow B C Arrow A B Arrow A C
{{isCategory}} : IsCategory Object Arrow 𝟙 _∘_
infixl 10 _∘_
domain : { a b : Object } Arrow a b Object
domain {a = a} _ = a
codomain : { a b : Object } Arrow a b Object
codomain {b = b} _ = b
2017-11-10 15:00:00 +00:00
open Category
2017-11-10 15:00:00 +00:00
_[_,_] : { '} ( : Category ') (A : .Object) (B : .Object) Set '
_[_,_] = Arrow
_[_∘_] : { '} ( : Category ') {A B C : .Object} (g : [ B , C ]) (f : [ A , B ]) [ A , C ]
_[_∘_] = _∘_
module _ { ' : Level} { : Category '} where
module _ { A B : .Object } where
Isomorphism : (f : .Arrow A B) Set '
Isomorphism f = Σ[ g .Arrow B A ] [ g f ] .𝟙 × [ f g ] .𝟙
Epimorphism : {X : .Object } (f : .Arrow A B) Set '
Epimorphism {X} f = ( g₀ g₁ : .Arrow B X ) [ g₀ f ] [ g₁ f ] g₀ g₁
Monomorphism : {X : .Object} (f : .Arrow A B) Set '
Monomorphism {X} f = ( g₀ g₁ : .Arrow X A ) [ f g₀ ] [ f g₁ ] g₀ g₁
-- Isomorphism of objects
_≅_ : (A B : Object ) Set '
_≅_ A B = Σ[ f .Arrow A B ] (Isomorphism f)
module _ { ' : Level} ( : Category ') {A B obj : Object } where
IsProduct : (π₁ : Arrow obj A) (π₂ : Arrow obj B) Set ( ')
IsProduct π₁ π₂
= {X : .Object} (x₁ : .Arrow X A) (x₂ : .Arrow X B)
∃![ x ] ( [ π₁ x ] x₁ × [ π₂ x ] x₂)
-- Tip from Andrea; Consider this style for efficiency:
-- record IsProduct { ' : Level} ( : Category {} {'})
-- {A B obj : Object } (π₁ : Arrow obj A) (π₂ : Arrow obj B) : Set (') where
-- field
-- isProduct : ∀ {X : .Object} (x₁ : .Arrow X A) (x₂ : .Arrow X B)
-- → ∃![ x ] ( ._⊕_ π₁ x ≡ x₁ × . _⊕_ π₂ x ≡ x₂)
record Product { ' : Level} { : Category '} (A B : .Object) : Set ( ') where
no-eta-equality
field
obj : .Object
proj₁ : .Arrow obj A
proj₂ : .Arrow obj B
{{isProduct}} : IsProduct proj₁ proj₂
2018-01-24 15:38:28 +00:00
2018-01-21 20:29:15 +00:00
arrowProduct : {X} (π₁ : Arrow X A) (π₂ : Arrow X B)
Arrow X obj
arrowProduct π₁ π₂ = fst (isProduct π₁ π₂)
record HasProducts { ' : Level} ( : Category ') : Set ( ') where
field
product : (A B : .Object) Product { = } A B
2018-01-24 15:38:28 +00:00
open Product
objectProduct : (A B : .Object) .Object
objectProduct A B = Product.obj (product A B)
-- The product mentioned in awodey in Def 6.1 is not the regular product of arrows.
-- It's a "parallel" product
parallelProduct : {A A' B B' : .Object} .Arrow A A' .Arrow B B'
.Arrow (objectProduct A B) (objectProduct A' B')
parallelProduct {A = A} {A' = A'} {B = B} {B' = B'} a b = arrowProduct (product A' B')
( [ a (product A B) .proj₁ ])
( [ b (product A B) .proj₂ ])
2018-01-24 15:38:28 +00:00
module _ { ' : Level} ( : Category ') where
Opposite : Category '
Opposite =
record
{ Object = .Object
; Arrow = Function.flip ( .Arrow)
; 𝟙 = .𝟙
; _∘_ = Function.flip ( ._∘_)
; isCategory = record { assoc = sym assoc ; ident = swap ident }
}
where
open IsCategory ( .isCategory)
2017-11-10 15:00:00 +00:00
-- A consequence of no-eta-equality; `Opposite-is-involution` is no longer
-- definitional - i.e.; you must match on the fields:
--
-- Opposite-is-involution : ∀ { '} → {C : Category {} {'}} → Opposite (Opposite C) ≡ C
-- Object (Opposite-is-involution {C = C} i) = Object C
-- Arrow (Opposite-is-involution i) = {!!}
-- 𝟙 (Opposite-is-involution i) = {!!}
-- _⊕_ (Opposite-is-involution i) = {!!}
-- assoc (Opposite-is-involution i) = {!!}
-- ident (Opposite-is-involution i) = {!!}
Hom : { ' : Level} ( : Category ') (A B : Object ) Set '
2018-01-17 11:10:18 +00:00
Hom A B = Arrow A B
2017-11-10 15:00:00 +00:00
module _ { ' : Level} { : Category '} where
HomFromArrow : (A : .Object) {B B' : .Object} (g : .Arrow B B')
2018-01-17 11:10:18 +00:00
Hom A B Hom A B'
HomFromArrow _A = ._∘_
2018-01-24 15:38:28 +00:00
2018-01-25 11:01:37 +00:00
module _ { '} ( : Category ') {{hasProducts : HasProducts }} where
open HasProducts hasProducts
2018-01-24 15:38:28 +00:00
open Product hiding (obj)
private
_×p_ : (A B : .Object) .Object
_×p_ A B = Product.obj (product A B)
module _ (B C : .Category.Object) where
IsExponential : (Cᴮ : .Object) .Arrow (Cᴮ ×p B) C Set ( ')
IsExponential Cᴮ eval = (A : .Object) (f : .Arrow (A ×p B) C)
∃![ f~ ] ( [ eval parallelProduct f~ ( .𝟙)] f)
2018-01-24 15:38:28 +00:00
record Exponential : Set ( ') where
field
-- obj ≡ Cᴮ
obj : .Object
eval : .Arrow ( obj ×p B ) C
{{isExponential}} : IsExponential obj eval
-- If I make this an instance-argument then the instance resolution
-- algorithm goes into an infinite loop. Why?
2018-01-25 11:01:37 +00:00
exponentialsHaveProducts : HasProducts
exponentialsHaveProducts = hasProducts
2018-01-24 15:38:28 +00:00
transpose : (A : .Object) .Arrow (A ×p B) C .Arrow A obj
transpose A f = fst (isExponential A f)
record HasExponentials { ' : Level} ( : Category ') {{_ : HasProducts }} : Set ( ') where
field
exponent : (A B : .Object) Exponential A B
record CartesianClosed { ' : Level} ( : Category ') : Set ( ') where
field
{{hasProducts}} : HasProducts
{{hasExponentials}} : HasExponentials
module _ {a b : Level} ( : Category a b) where
unique = isContr
IsInitial : .Object Set (a b)
IsInitial I = {X : .Object} unique ( .Arrow I X)
IsTerminal : .Object Set (a b)
-- ∃![ ? ] ?
IsTerminal T = {X : .Object} unique ( .Arrow X T)
Initial : Set (a b)
Initial = Σ ( .Object) IsInitial
Terminal : Set (a b)
Terminal = Σ ( .Object) IsTerminal