cat/src/Category.agda

196 lines
6.9 KiB
Agda
Raw Normal View History

2017-11-10 15:00:00 +00:00
{-# OPTIONS --cubical #-}
module Category where
open import Agda.Primitive
open import Data.Unit.Base
open import Data.Product
open import Cubical.PathPrelude
2017-11-15 21:56:04 +00:00
open import Data.Empty
2017-11-10 15:00:00 +00:00
postulate undefined : { : Level} {A : Set } A
record Category { '} : Set (lsuc (' )) where
field
Object : Set
Arrow : Object Object Set '
𝟙 : {o : Object} Arrow o o
_⊕_ : { a b c : Object } Arrow b c Arrow a b Arrow a c
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
infixl 45 _⊕_
dom : { a b : Object } Arrow a b Object
dom {a = a} _ = a
cod : { a b : Object } Arrow a b Object
cod {b = b} _ = b
open Category public
record Functor {c c' d d'} (C : Category {c} {c'}) (D : Category {d} {d'})
: Set (c c' d d') where
private
open module C = Category C
open module D = Category D
field
F : C.Object D.Object
f : {c c' : C.Object} C.Arrow c c' D.Arrow (F c) (F c')
ident : { c : C.Object } f (C.𝟙 {c}) D.𝟙 {F c}
-- TODO: Avoid use of ugly explicit arguments somehow.
-- This guy managed to do it:
-- https://github.com/copumpkin/categories/blob/master/Categories/Functor/Core.agda
distrib : { c c' c'' : C.Object} {a : C.Arrow c c'} {a' : C.Arrow c' c''}
f (a' C.⊕ a) f a' D.⊕ f a
FunctorComp : { '} {a b c : Category {} {'}} Functor b c Functor a b Functor a c
FunctorComp {a = a} {b = b} {c = c} F G =
record
{ F = F.F G.F
; f = F.f G.f
; ident = λ { {c = obj}
let --t : (F.f ∘ G.f) (𝟙 a) ≡ (𝟙 c)
g-ident = G.ident
k : F.f (G.f {c' = obj} (𝟙 a)) F.f (G.f (𝟙 a))
k = refl {x = F.f (G.f (𝟙 a))}
t : F.f (G.f (𝟙 a)) (𝟙 c)
-- t = subst F.ident (subst G.ident k)
t = undefined
in t }
; distrib = undefined -- subst F.distrib (subst G.distrib refl)
}
where
open module F = Functor F
open module G = Functor G
-- The identity functor
Identity : { ' : Level} {C : Category {} {'}} Functor C C
Identity = record { F = λ x x ; f = λ x x ; ident = refl ; distrib = refl }
module _ { ' : Level} { : Category {} {'}} { A B : Object } where
private
open module = Category
_+_ = ._⊕_
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₁
iso-is-epi : {X} (f : .Arrow A B) Isomorphism f Epimorphism {X = X} f
-- Idea: Pre-compose with f- on both sides of the equality of eq to get
-- g₀ + f + f- ≡ g₁ + f + f-
-- which by left-inv reduces to the goal.
iso-is-epi f (f- , left-inv , right-inv) g₀ g₁ eq =
trans (sym (fst .ident))
( trans (cong (_+_ g₀) (sym right-inv))
( trans .assoc
( trans (cong (λ x x + f-) eq)
( trans (sym .assoc)
( trans (cong (_+_ g₁) right-inv) (fst .ident))
)
)
)
)
iso-is-mono : {X} (f : .Arrow A B ) Isomorphism f Monomorphism {X = X} f
-- For the next goal we do something similar: Post-compose with f- and use
-- right-inv to get the goal.
iso-is-mono f (f- , (left-inv , right-inv)) g₀ g₁ eq =
trans (sym (snd .ident))
( trans (cong (λ x x + g₀) (sym left-inv))
( trans (sym .assoc)
( trans (cong (_+_ f-) eq)
( trans .assoc
( trans (cong (λ x x + g₁) left-inv) (snd .ident)
)
)
)
)
)
iso-is-epi-mono : {X} (f : .Arrow A B ) Isomorphism f Epimorphism {X = X} f × Monomorphism {X = X} f
iso-is-epi-mono f iso = iso-is-epi f iso , iso-is-mono f iso
¬_ : { : Level} Set Set
¬ A = A
{-
epi-mono-is-not-iso : { '} ¬ (( : Category {} {'}) {A B X : Object } (f : Arrow A B ) Epimorphism { = } {X = X} f Monomorphism { = } {X = X} f Isomorphism { = } f)
epi-mono-is-not-iso f =
let k = f {!!} {!!} {!!} {!!}
in {!!}
-}
_≅_ : { ' : Level } { : Category {} {'} } ( A B : Object ) Set '
_≅_ { = } A B = Σ[ f .Arrow A B ] (Isomorphism { = } f)
where
open module = Category
Product : { : Level} ( C D : Category {} {} ) Category {} {}
Product C D =
record
{ Object = C.Object × D.Object
; Arrow = λ { (c , d) (c' , d')
let carr = C.Arrow c c'
darr = D.Arrow d d'
in carr × darr}
; 𝟙 = C.𝟙 , D.𝟙
; _⊕_ = λ { (bc∈C , bc∈D) (ab∈C , ab∈D) bc∈C C.⊕ ab∈C , bc∈D D.⊕ ab∈D}
; assoc = eqpair C.assoc D.assoc
; ident =
let (Cl , Cr) = C.ident
(Dl , Dr) = D.ident
in eqpair Cl Dl , eqpair Cr Dr
}
where
open module C = Category C
open module D = Category D
-- Two pairs are equal if their components are equal.
eqpair : { : Level} { A : Set } { B : Set } { a a' : A } { b b' : B } a a' b b' (a , b) (a' , b')
eqpair {a = a} {b = b} eqa eqb = subst eqa (subst eqb (refl {x = (a , b)}))
Opposite : { '} Category {} {'} Category {} {'}
Opposite =
record
{ Object = .Object
; Arrow = λ A B .Arrow B A
; 𝟙 = .𝟙
; _⊕_ = λ g f f .⊕ g
; assoc = sym .assoc
; ident = swap .ident
}
where
open module = Category
CatCat : { ' : Level} Category {-suc ( ')} { '}
CatCat {} {'} =
record
{ Object = Category {} {'}
; Arrow = Functor
; 𝟙 = Identity
; _⊕_ = FunctorComp
; assoc = undefined
; ident = λ { {f = f}
let eq : f f
eq = refl
in undefined , undefined}
}
Hom : { ' : Level} { : Category {} {'}} (A B : Object ) Set '
Hom { = } A B = Arrow A B
module _ { ' : Level} { : Category {} {'}} where
private
Obj = Object
Arr = Arrow
_+_ = _⊕_
HomFromArrow : (A : Obj) {B B' : Obj} (g : Arr B B')
Hom { = } A B Hom { = } A B'
HomFromArrow _A g = λ f g + f