Merge branch 'dev'

This commit is contained in:
Frederik Hanghøj Iversen 2018-02-05 11:51:13 +01:00
commit 36d10b0556
19 changed files with 786 additions and 441 deletions

View file

@ -7,3 +7,6 @@ depend:
cubical
include:
src
-- libraries:
-- libs/agda-stdlib
-- libs/cubical

@ -1 +1 @@
Subproject commit de23244a73d6dab55715fd5a107a5de805c55764
Subproject commit b5bfbc3c170b0bd0c9aaac1b4d4b3f9b06832bf6

@ -1 +1 @@
Subproject commit a83f5f4c63e5dfd8143ac03163868c63a56802de
Subproject commit 1d6730c4999daa2b04e9dd39faa0791d0b5c3b48

46
proposal/Makefile Normal file
View file

@ -0,0 +1,46 @@
# Latex Makefile using latexmk
# Modified by Dogukan Cagatay <dcagatay@gmail.com>
# Originally from : http://tex.stackexchange.com/a/40759
#
# Change only the variable below to the name of the main tex file.
PROJNAME=proposal
# You want latexmk to *always* run, because make does not have all the info.
# Also, include non-file targets in .PHONY so they are run regardless of any
# file of the given name existing.
.PHONY: $(PROJNAME).pdf all clean
# The first rule in a Makefile is the one executed by default ("make"). It
# should always be the "all" rule, so that "make" and "make all" are identical.
all: $(PROJNAME).pdf
# CUSTOM BUILD RULES
# In case you didn't know, '$@' is a variable holding the name of the target,
# and '$<' is a variable holding the (first) dependency of a rule.
# "raw2tex" and "dat2tex" are just placeholders for whatever custom steps
# you might have.
%.tex: %.raw
./raw2tex $< > $@
%.tex: %.dat
./dat2tex $< > $@
# MAIN LATEXMK RULE
# -pdf tells latexmk to generate PDF directly (instead of DVI).
# -pdflatex="" tells latexmk to call a specific backend with specific options.
# -use-make tells latexmk to call make for generating missing files.
# -interactive=nonstopmode keeps the pdflatex backend from stopping at a
# missing file reference and interactively asking you for an alternative.
$(PROJNAME).pdf: $(PROJNAME).tex
latexmk -pdf -pdflatex="pdflatex -interactive=nonstopmode" -use-make $<
cleanall:
latexmk -C
clean:
latexmk -c

View file

@ -6,7 +6,7 @@
\newcommand{\bN}{\mathbb{N}}
\newcommand{\bC}{\mathbb{C}}
\newcommand{\bX}{\mathbb{X}}
\newcommand{\to}{\rightarrow}
% \newcommand{\to}{\rightarrow}
\newcommand{\mto}{\mapsto}
\newcommand{\UU}{\ensuremath{\mathcal{U}}\xspace}
\let\type\UU

View file

@ -1,13 +1,14 @@
module Cat where
import Cat.Cubical
import Cat.Category
import Cat.Functor
import Cat.CwF
import Cat.Category.Pathy
import Cat.Category.Bij
import Cat.Category.Free
import Cat.Category.Properties
import Cat.Categories.Sets
import Cat.Categories.Cat
-- import Cat.Categories.Cat
import Cat.Categories.Rel
import Cat.Categories.Fun
import Cat.Categories.Cube

View file

@ -1,3 +1,4 @@
-- There is no category of categories in our interpretation
{-# OPTIONS --cubical --allow-unsolved-metas #-}
module Cat.Categories.Cat where
@ -10,40 +11,39 @@ open import Data.Product renaming (proj₁ to fst ; proj₂ to snd)
open import Cat.Category
open import Cat.Functor
-- Tip from Andrea:
-- Use co-patterns - they help with showing more understandable types in goals.
lift-eq : {} {A B : Set } {a a' : A} {b b' : B} a a' b b' (a , b) (a' , b')
fst (lift-eq a b i) = a i
snd (lift-eq a b i) = b i
eqpair : {a b} {A : Set a} {B : Set b} {a a' : A} {b b' : B}
a a' b b' (a , b) (a' , b')
eqpair eqa eqb i = eqa i , eqb i
open import Cat.Equality
open Equality.Data.Product
open Functor
open Category
open IsFunctor
open Category hiding (_∘_)
-- The category of categories
module _ ( ' : Level) where
private
module _ {A B C D : Category '} {f : Functor A B} {g : Functor B C} {h : Functor C D} where
module _ {𝔸 𝔹 𝔻 : Category '} {F : Functor 𝔸 𝔹} {G : Functor 𝔹 } {H : Functor 𝔻} where
private
eq* : func* (h ∘f (g ∘f f)) func* ((h ∘f g) ∘f f)
eq* : func* (H ∘f (G ∘f F)) func* ((H ∘f G) ∘f F)
eq* = refl
eq→ : PathP
(λ i {x y : A .Object} A .Arrow x y D .Arrow (eq* i x) (eq* i y))
(func→ (h ∘f (g ∘f f))) (func→ ((h ∘f g) ∘f f))
(λ i {A B : 𝔸 .Object} 𝔸 [ A , B ] 𝔻 [ eq* i A , eq* i B ])
(func→ (H ∘f (G ∘f F))) (func→ ((H ∘f G) ∘f F))
eq→ = refl
postulate eqI : PathP
(λ i {c : A .Object} eq→ i (A .𝟙 {c}) D .𝟙 {eq* i c})
(ident ((h ∘f (g ∘f f))))
(ident ((h ∘f g) ∘f f))
postulate eqD : PathP (λ i { c c' c'' : A .Object} {a : A .Arrow c c'} {a' : A .Arrow c' c''}
eq→ i (A ._⊕_ a' a) D ._⊕_ (eq→ i a') (eq→ i a))
(distrib (h ∘f (g ∘f f))) (distrib ((h ∘f g) ∘f f))
postulate
eqI
: (λ i {A : 𝔸 .Object} eq→ i (𝔸 .𝟙 {A}) 𝔻 .𝟙 {eq* i A})
[ (H ∘f (G ∘f F)) .isFunctor .ident
((H ∘f G) ∘f F) .isFunctor .ident
]
eqD
: (λ i {A B C} {f : 𝔸 [ A , B ]} {g : 𝔸 [ B , C ]}
eq→ i (𝔸 [ g f ]) 𝔻 [ eq→ i g eq→ i f ])
[ (H ∘f (G ∘f F)) .isFunctor .distrib
((H ∘f G) ∘f F) .isFunctor .distrib
]
assc : h ∘f (g ∘f f) (h ∘f g) ∘f f
assc = Functor≡ eq* eq→ eqI eqD
assc : H ∘f (G ∘f F) (H ∘f G) ∘f F
assc = Functor≡ eq* eq→ (IsFunctor≡ eqI eqD)
module _ { 𝔻 : Category '} {F : Functor 𝔻} where
module _ where
@ -57,16 +57,17 @@ module _ ( ' : Level) where
(func→ (F ∘f identity)) (func→ F)
eq→ = refl
postulate
eqI-r : PathP (λ i {c : .Object}
PathP (λ _ Arrow 𝔻 (func* F c) (func* F c)) (func→ F ( .𝟙)) (𝔻 .𝟙))
(ident (F ∘f identity)) (ident F)
eqI-r
: (λ i {c : .Object} (λ _ 𝔻 [ func* F c , func* F c ])
[ func→ F ( .𝟙) 𝔻 .𝟙 ])
[(F ∘f identity) .isFunctor .ident F .isFunctor .ident ]
eqD-r : PathP
(λ i
{A B C : .Object} {f : .Arrow A B} {g : .Arrow B C}
eq→ i ( ._⊕_ g f) 𝔻 ._⊕_ (eq→ i g) (eq→ i f))
((F ∘f identity) .distrib) (distrib F)
eq→ i ( [ g f ]) 𝔻 [ eq→ i g eq→ i f ])
((F ∘f identity) .isFunctor .distrib) (F .isFunctor .distrib)
ident-r : F ∘f identity F
ident-r = Functor≡ eq* eq→ eqI-r eqD-r
ident-r = Functor≡ eq* eq→ (IsFunctor≡ eqI-r eqD-r)
module _ where
private
postulate
@ -74,13 +75,14 @@ module _ ( ' : Level) where
eq→ : PathP
(λ i {x y : Object } .Arrow x y 𝔻 .Arrow (eq* i x) (eq* i y))
((identity ∘f F) .func→) (F .func→)
eqI : PathP (λ i {A : .Object} eq→ i ( .𝟙 {A}) 𝔻 .𝟙 {eq* i A})
(ident (identity ∘f F)) (ident F)
eqI : (λ i {A : .Object} eq→ i ( .𝟙 {A}) 𝔻 .𝟙 {eq* i A})
[ ((identity ∘f F) .isFunctor .ident) (F .isFunctor .ident) ]
eqD : PathP (λ i {A B C : .Object} {f : .Arrow A B} {g : .Arrow B C}
eq→ i ( ._⊕_ g f) 𝔻 ._⊕_ (eq→ i g) (eq→ i f))
(distrib (identity ∘f F)) (distrib F)
eq→ i ( [ g f ]) 𝔻 [ eq→ i g eq→ i f ])
((identity ∘f F) .isFunctor .distrib) (F .isFunctor .distrib)
-- (λ z → eq* i z) (eq→ i)
ident-l : identity ∘f F F
ident-l = Functor≡ eq* eq→ eqI eqD
ident-l = Functor≡ eq* eq→ λ i record { ident = eqI i ; distrib = eqD i }
Cat : Category (lsuc ( ')) ( ')
Cat =
@ -88,19 +90,18 @@ module _ ( ' : Level) where
{ Object = Category '
; Arrow = Functor
; 𝟙 = identity
; __ = _∘f_
; __ = _∘f_
-- What gives here? Why can I not name the variables directly?
; isCategory = record
{ assoc = λ {_ _ _ _ f g h} assc {f = f} {g = g} {h = h}
{ assoc = λ {_ _ _ _ F G H} assc {F = F} {G = G} {H = H}
; ident = ident-r , ident-l
}
}
module _ { ' : Level} where
Catt = Cat '
module _ ( 𝔻 : Category ') where
private
Catt = Cat '
:Object: = .Object × 𝔻 .Object
:Arrow: : :Object: :Object: Set '
:Arrow: (c , d) (c' , d') = Arrow c c' × Arrow 𝔻 d d'
@ -111,15 +112,15 @@ module _ { ' : Level} where
:Arrow: b c
:Arrow: a b
:Arrow: a c
_:⊕:_ = λ { (bc∈C , bc∈D) (ab∈C , ab∈D) ( ._⊕_) bc∈C ab∈C , 𝔻 ._⊕_ bc∈D ab∈D}
_:⊕:_ = λ { (bc∈C , bc∈D) (ab∈C , ab∈D) [ bc∈C ab∈C ] , 𝔻 [ bc∈D ab∈D ]}
instance
:isCategory: : IsCategory :Object: :Arrow: :𝟙: _:⊕:_
:isCategory: = record
{ assoc = eqpair C.assoc D.assoc
{ assoc = Σ≡ C.assoc D.assoc
; ident
= eqpair (fst C.ident) (fst D.ident)
, eqpair (snd C.ident) (snd D.ident)
= Σ≡ (fst C.ident) (fst D.ident)
, Σ≡ (snd C.ident) (snd D.ident)
}
where
open module C = IsCategory ( .isCategory)
@ -130,41 +131,49 @@ module _ { ' : Level} where
{ Object = :Object:
; Arrow = :Arrow:
; 𝟙 = :𝟙:
; __ = _:⊕:_
; __ = _:⊕:_
}
proj₁ : Arrow Catt :product:
proj₁ = record { func* = fst ; func→ = fst ; ident = refl ; distrib = refl }
proj₁ : Catt [ :product: , ]
proj₁ = record { func* = fst ; func→ = fst ; isFunctor = record { ident = refl ; distrib = refl } }
proj₂ : Arrow Catt :product: 𝔻
proj₂ = record { func* = snd ; func→ = snd ; ident = refl ; distrib = refl }
proj₂ : Catt [ :product: , 𝔻 ]
proj₂ = record { func* = snd ; func→ = snd ; isFunctor = record { ident = refl ; distrib = refl } }
module _ {X : Object Catt} (x₁ : Arrow Catt X ) (x₂ : Arrow Catt X 𝔻) where
module _ {X : Object Catt} (x₁ : Catt [ X , ]) (x₂ : Catt [ X , 𝔻 ]) where
open Functor
-- ident' : {c : Object X} → ((func→ x₁) {dom = c} (𝟙 X) , (func→ x₂) {dom = c} (𝟙 X)) ≡ 𝟙 (catProduct C D)
-- ident' {c = c} = lift-eq (ident x₁) (ident x₂)
x : Functor X :product:
x = record
{ func* = λ x (func* x₁) x , (func* x₂) x
{ func* = λ x x₁ .func* x , x₂ .func* x
; func→ = λ x func→ x₁ x , func→ x₂ x
; ident = lift-eq (ident x₁) (ident x₂)
; distrib = lift-eq (distrib x₁) (distrib x₂)
; isFunctor = record
{ ident = Σ≡ x₁.ident x₂.ident
; distrib = Σ≡ x₁.distrib x₂.distrib
}
}
where
open module x = IsFunctor (x₁ .isFunctor)
open module x = IsFunctor (x₂ .isFunctor)
-- Need to "lift equality of functors"
-- If I want to do this like I do it for pairs it's gonna be a pain.
postulate isUniqL : (Catt proj₁) x x₁
-- isUniqL = Functor≡ refl refl {!!} {!!}
isUniqL : Catt [ proj₁ x ] x₁
isUniqL = Functor≡ eq* eq→ eqIsF -- Functor≡ refl refl λ i → record { ident = refl i ; distrib = refl i }
where
eq* : (Catt [ proj₁ x ]) .func* x₁ .func*
eq* = refl
eq→ : (λ i {A : X .Object} {B : X .Object} X [ A , B ] [ eq* i A , eq* i B ])
[ (Catt [ proj₁ x ]) .func→ x₁ .func→ ]
eq→ = refl
postulate eqIsF : (Catt [ proj₁ x ]) .isFunctor x₁ .isFunctor
-- eqIsF = IsFunctor≡ {!refl!} {!!}
postulate isUniqR : (Catt proj₂) x x₂
postulate isUniqR : Catt [ proj₂ x ] x₂
-- isUniqR = Functor≡ refl refl {!!} {!!}
isUniq : (Catt proj₁) x x₁ × (Catt proj₂) x x₂
isUniq : Catt [ proj₁ x ] x₁ × Catt [ proj₂ x ] x₂
isUniq = isUniqL , isUniqR
uniq : ∃![ x ] ((Catt proj₁) x x₁ × (Catt proj₂) x x₂)
uniq : ∃![ x ] (Catt [ proj₁ x ] x₁ × Catt [ proj₂ x ] x₂)
uniq = x , isUniq
instance
@ -193,9 +202,6 @@ module _ ( : Level) where
Cat = Cat
module _ ( 𝔻 : Category ) where
private
_𝔻⊕_ = 𝔻 ._⊕_
_⊕_ = ._⊕_
:obj: : Cat .Object
:obj: = Fun { = } {𝔻 = 𝔻}
@ -227,13 +233,13 @@ module _ ( : Level) where
G→f : 𝔻 .Arrow (G .func* A) (G .func* B)
G→f = G .func→ f
l : 𝔻 .Arrow (F .func* A) (G .func* B)
l = θB 𝔻⊕ F→f
l = 𝔻 [ θB F→f ]
r : 𝔻 .Arrow (F .func* A) (G .func* B)
r = G→f 𝔻⊕ θA
r = 𝔻 [ G→f θA ]
-- There are two choices at this point,
-- but I suppose the whole point is that
-- by `θNat f` we have `l ≡ r`
-- lem : θ B 𝔻⊕ F .func→ f ≡ G .func→ f 𝔻⊕ θ A
-- lem : 𝔻 [ θ B ∘ F .func→ f ] ≡ 𝔻 [ G .func→ f ∘ θ A ]
-- lem = θNat f
result : 𝔻 .Arrow (F .func* A) (G .func* B)
result = l
@ -251,19 +257,20 @@ module _ ( : Level) where
-- :ident: : :func→: {c} {c} (identityNat F , .𝟙) 𝔻 .𝟙
-- :ident: = trans (proj₂ 𝔻.ident) (F .ident)
-- where
-- _𝔻⊕_ = 𝔻 ._⊕_
-- open module 𝔻 = IsCategory (𝔻 .isCategory)
-- Unfortunately the equational version has some ambigous arguments.
:ident: : :func→: {c} {c} (identityNat F , .𝟙 {o = proj₂ c}) 𝔻 .𝟙
:ident: = begin
:func→: {c} {c} ((:obj: ×p ) .Product.obj .𝟙 {c}) ≡⟨⟩
:func→: {c} {c} (identityNat F , .𝟙) ≡⟨⟩
(identityTrans F C 𝔻⊕ F .func→ ( .𝟙)) ≡⟨⟩
𝔻 .𝟙 𝔻⊕ F .func→ ( .𝟙) ≡⟨ proj₂ 𝔻.ident
F .func→ ( .𝟙) ≡⟨ F .ident
𝔻 .𝟙
𝔻 [ identityTrans F C F .func→ ( .𝟙)] ≡⟨⟩
𝔻 [ 𝔻 .𝟙 F .func→ ( .𝟙)] ≡⟨ proj₂ 𝔻.ident
F .func→ ( .𝟙) ≡⟨ F.ident
𝔻 .𝟙
where
open module 𝔻 = IsCategory (𝔻 .isCategory)
open module F = IsFunctor (F .isFunctor)
module _ {F×A G×B H×C : Functor 𝔻 × .Object} where
F = F×A .proj₁
A = F×A .proj₂
@ -272,7 +279,7 @@ module _ ( : Level) where
H = H×C .proj₁
C = H×C .proj₂
-- Not entirely clear what this is at this point:
_P⊕_ = (:obj: ×p ) .Product.obj ._⊕_ {F×A} {G×B} {H×C}
_P⊕_ = (:obj: ×p ) .Product.obj .Category._∘_ {F×A} {G×B} {H×C}
module _
-- NaturalTransformation F G × .Arrow A B
{θ×f : NaturalTransformation F G × .Arrow A B}
@ -292,35 +299,45 @@ module _ ( : Level) where
g = proj₂ η×g
ηθNT : NaturalTransformation F H
ηθNT = Fun ._⊕_ {F} {G} {H} (η , ηNat) (θ , θNat)
ηθNT = Fun .Category._∘_ {F} {G} {H} (η , ηNat) (θ , θNat)
ηθ = proj₁ ηθNT
ηθNat = proj₂ ηθNT
:distrib: :
(η C 𝔻⊕ θ C) 𝔻⊕ F .func→ (g ℂ⊕ f)
(η C 𝔻⊕ G .func→ g) 𝔻⊕ (θ B 𝔻⊕ F .func→ f)
𝔻 [ 𝔻 [ η C θ C ] F .func→ ( [ g f ] ) ]
𝔻 [ 𝔻 [ η C G .func→ g ] 𝔻 [ θ B F .func→ f ] ]
:distrib: = begin
(ηθ C) 𝔻⊕ F .func→ (g ℂ⊕ f) ≡⟨ ηθNat (g ℂ⊕ f)
H .func→ (g ℂ⊕ f) 𝔻⊕ (ηθ A) ≡⟨ cong (λ φ φ 𝔻⊕ ηθ A) (H .distrib)
(H .func→ g 𝔻⊕ H .func→ f) 𝔻⊕ (ηθ A) ≡⟨ sym assoc
H .func→ g 𝔻⊕ (H .func→ f 𝔻⊕ (ηθ A)) ≡⟨⟩
H .func→ g 𝔻⊕ (H .func→ f 𝔻⊕ (ηθ A)) ≡⟨ cong (λ φ H .func→ g 𝔻⊕ φ) assoc
H .func→ g 𝔻⊕ ((H .func→ f 𝔻⊕ η A) 𝔻⊕ θ A) ≡⟨ cong (λ φ H .func→ g 𝔻⊕ φ) (cong (λ φ φ 𝔻⊕ θ A) (sym (ηNat f)))
H .func→ g 𝔻⊕ ((η B 𝔻⊕ G .func→ f) 𝔻⊕ θ A) ≡⟨ cong (λ φ H .func→ g 𝔻⊕ φ) (sym assoc)
H .func→ g 𝔻⊕ (η B 𝔻⊕ (G .func→ f 𝔻⊕ θ A)) ≡⟨ assoc
(H .func→ g 𝔻⊕ η B) 𝔻⊕ (G .func→ f 𝔻⊕ θ A) ≡⟨ cong (λ φ φ 𝔻⊕ (G .func→ f 𝔻⊕ θ A)) (sym (ηNat g))
(η C 𝔻⊕ G .func→ g) 𝔻⊕ (G .func→ f 𝔻⊕ θ A) ≡⟨ cong (λ φ (η C 𝔻⊕ G .func→ g) 𝔻⊕ φ) (sym (θNat f))
(η C 𝔻⊕ G .func→ g) 𝔻⊕ (θ B 𝔻⊕ F .func→ f)
𝔻 [ (ηθ C) F .func→ ( [ g f ]) ]
≡⟨ ηθNat ( [ g f ])
𝔻 [ H .func→ ( [ g f ]) (ηθ A) ]
≡⟨ cong (λ φ 𝔻 [ φ ηθ A ]) (H.distrib)
𝔻 [ 𝔻 [ H .func→ g H .func→ f ] (ηθ A) ]
≡⟨ sym assoc
𝔻 [ H .func→ g 𝔻 [ H .func→ f ηθ A ] ]
≡⟨ cong (λ φ 𝔻 [ H .func→ g φ ]) assoc
𝔻 [ H .func→ g 𝔻 [ 𝔻 [ H .func→ f η A ] θ A ] ]
≡⟨ cong (λ φ 𝔻 [ H .func→ g φ ]) (cong (λ φ 𝔻 [ φ θ A ]) (sym (ηNat f)))
𝔻 [ H .func→ g 𝔻 [ 𝔻 [ η B G .func→ f ] θ A ] ]
≡⟨ cong (λ φ 𝔻 [ H .func→ g φ ]) (sym assoc)
𝔻 [ H .func→ g 𝔻 [ η B 𝔻 [ G .func→ f θ A ] ] ] ≡⟨ assoc
𝔻 [ 𝔻 [ H .func→ g η B ] 𝔻 [ G .func→ f θ A ] ]
≡⟨ cong (λ φ 𝔻 [ φ 𝔻 [ G .func→ f θ A ] ]) (sym (ηNat g))
𝔻 [ 𝔻 [ η C G .func→ g ] 𝔻 [ G .func→ f θ A ] ]
≡⟨ cong (λ φ 𝔻 [ 𝔻 [ η C G .func→ g ] φ ]) (sym (θNat f))
𝔻 [ 𝔻 [ η C G .func→ g ] 𝔻 [ θ B F .func→ f ] ]
where
open IsCategory (𝔻 .isCategory)
open module H = IsFunctor (H .isFunctor)
:eval: : Functor ((:obj: ×p ) .Product.obj) 𝔻
:eval: = record
{ func* = :func*:
; func→ = λ {dom} {cod} :func→: {dom} {cod}
; ident = λ {o} :ident: {o}
; distrib = λ {f u n k y} :distrib: {f} {u} {n} {k} {y}
; isFunctor = record
{ ident = λ {o} :ident: {o}
; distrib = λ {f u n k y} :distrib: {f} {u} {n} {k} {y}
}
}
module _ (𝔸 : Category ) (F : Functor ((𝔸 ×p ) .Product.obj) 𝔻) where
@ -328,9 +345,9 @@ module _ ( : Level) where
postulate
transpose : Functor 𝔸 :obj:
eq : Cat ._⊕_ :eval: (parallelProduct transpose (Cat .𝟙 {o = })) F
eq : Cat [ :eval: (parallelProduct transpose (Cat .𝟙 {o = })) ] F
catTranspose : ∃![ F~ ] (Cat ._⊕_ :eval: (parallelProduct F~ (Cat .𝟙 {o = })) F)
catTranspose : ∃![ F~ ] (Cat [ :eval: (parallelProduct F~ (Cat .𝟙 {o = }))] F )
catTranspose = transpose , eq
:isExponential: : IsExponential Cat 𝔻 :obj: :eval:

View file

@ -0,0 +1,79 @@
{-# OPTIONS --allow-unsolved-metas #-}
module Cat.Categories.Cube where
open import Level
open import Data.Bool hiding (T)
open import Data.Sum hiding ([_,_])
open import Data.Unit
open import Data.Empty
open import Data.Product
open import Cubical
open import Function
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Cat.Category
open import Cat.Functor
open import Cat.Equality
open Equality.Data.Product
-- See chapter 1 for a discussion on how presheaf categories are CwF's.
-- See section 6.8 in Huber's thesis for details on how to implement the
-- categorical version of CTT
open Category hiding (_∘_)
open Functor
module _ { ' : Level} (Ns : Set ) where
-- Ns is the "namespace"
o = (suc zero )
FiniteDecidableSubset : Set
FiniteDecidableSubset = Ns Dec
isTrue : Bool Set
isTrue false =
isTrue true =
elmsof : FiniteDecidableSubset Set
elmsof P = Σ Ns (λ σ True (P σ)) -- (σ : Ns) → isTrue (P σ)
𝟚 : Set
𝟚 = Bool
module _ (I J : FiniteDecidableSubset) where
private
Hom' : Set
Hom' = elmsof I elmsof J 𝟚
isInl : {a b : Level} {A : Set a} {B : Set b} A B Set
isInl (inj₁ _) =
isInl (inj₂ _) =
Def : Set
Def = (f : Hom') Σ (elmsof I) (λ i isInl (f i))
rules : Hom' Set
rules f = (i j : elmsof I)
case (f i) of λ
{ (inj₁ (fi , _)) case (f j) of λ
{ (inj₁ (fj , _)) fi fj i j
; (inj₂ _) Lift
}
; (inj₂ _) Lift
}
Hom = Σ Hom' rules
-- The category of names and substitutions
Raw : RawCategory -- o (lsuc lzero ⊔ o)
Raw = record
{ Object = FiniteDecidableSubset
-- { Object = Ns → Bool
; Arrow = Hom
; 𝟙 = λ { {o} inj₁ , λ { (i , ii) (j , jj) eq Σ≡ eq {!refl!} } }
; _∘_ = {!!}
}
postulate RawIsCategory : IsCategory Raw
: Category
= Raw , RawIsCategory

View file

@ -0,0 +1,54 @@
{-# OPTIONS --allow-unsolved-metas #-}
module Cat.Categories.Fam where
open import Agda.Primitive
open import Data.Product
open import Cubical
import Function
open import Cat.Category
open import Cat.Equality
open Equality.Data.Product
module _ (a b : Level) where
private
Obj' = Σ[ A Set a ] (A Set b)
Arr : Obj' Obj' Set (a b)
Arr (A , B) (A' , B') = Σ[ f (A A') ] ({x : A} B x B' (f x))
one : {o : Obj'} Arr o o
proj₁ one = λ x x
proj₂ one = λ b b
_∘_ : {a b c : Obj'} Arr b c Arr a b Arr a c
(g , g') (f , f') = g Function.∘ f , g' Function.∘ f'
_⟨_∘_⟩ : {a b : Obj'} (c : Obj') Arr b c Arr a b Arr a c
c g f = _∘_ {c = c} g f
module _ {A B C D : Obj'} {f : Arr A B} {g : Arr B C} {h : Arr C D} where
assoc : (D h C g f ) D D h g f
assoc = Σ≡ refl refl
module _ {A B : Obj'} {f : Arr A B} where
ident : B f one f × B one {B} f f
ident = (Σ≡ refl refl) , Σ≡ refl refl
RawFam : RawCategory (lsuc (a b)) (a b)
RawFam = record
{ Object = Obj'
; Arrow = Arr
; 𝟙 = one
; _∘_ = λ {a b c} _∘_ {a} {b} {c}
}
instance
isCategory : IsCategory RawFam
isCategory = record
{ assoc = λ {A} {B} {C} {D} {f} {g} {h} assoc {D = D} {f} {g} {h}
; ident = λ {A} {B} {f} ident {A} {B} {f = f}
; arrow-is-set = ?
; univalent = ?
}
Fam : Category (lsuc (a b)) (a b)
Fam = RawFam , isCategory

View file

@ -10,19 +10,19 @@ open import Cat.Category
open import Cat.Functor
module _ {c c' d d' : Level} { : Category c c'} {𝔻 : Category d d'} where
open Category
open Category hiding ( _∘_ ; Arrow )
open Functor
module _ (F G : Functor 𝔻) where
-- What do you call a non-natural tranformation?
Transformation : Set (c d')
Transformation = (C : .Object) 𝔻 .Arrow (F .func* C) (G .func* C)
Transformation = (C : .Object) 𝔻 [ F .func* C , G .func* C ]
Natural : Transformation Set (c (c' d'))
Natural θ
= {A B : .Object}
(f : .Arrow A B)
𝔻 ._⊕_ (θ B) (F .func→ f) 𝔻 ._⊕_ (G .func→ f) (θ A)
(f : [ A , B ])
𝔻 [ θ B F .func→ f ] 𝔻 [ G .func→ f θ A ]
NaturalTransformation : Set (c c' d')
NaturalTransformation = Σ Transformation Natural
@ -30,43 +30,53 @@ module _ {c c' d d' : Level} { : Category c c'} {𝔻 : Cat
-- NaturalTranformation : Set (c ⊔ (c' ⊔ d'))
-- NaturalTranformation = ∀ (θ : Transformation) {A B : .Object} → (f : .Arrow A B) → 𝔻 ._⊕_ (θ B) (F .func→ f) ≡ 𝔻 ._⊕_ (G .func→ f) (θ A)
module _ {F G : Functor 𝔻} where
NaturalTransformation≡ : {α β : NaturalTransformation F G}
(eq₁ : α .proj₁ β .proj₁)
(eq₂ : PathP
(λ i {A B : .Object} (f : [ A , B ])
𝔻 [ eq₁ i B F .func→ f ]
𝔻 [ G .func→ f eq₁ i A ])
(α .proj₂) (β .proj₂))
α β
NaturalTransformation≡ eq₁ eq₂ i = eq₁ i , eq₂ i
identityTrans : (F : Functor 𝔻) Transformation F F
identityTrans F C = 𝔻 .𝟙
identityNatural : (F : Functor 𝔻) Natural F F (identityTrans F)
identityNatural F {A = A} {B = B} f = begin
identityTrans F B 𝔻⊕ F→ f ≡⟨⟩
𝔻 .𝟙 𝔻⊕ F→ f ≡⟨ proj₂ 𝔻.ident
F→ f ≡⟨ sym (proj₁ 𝔻.ident)
F→ f 𝔻⊕ 𝔻 .𝟙 ≡⟨⟩
F→ f 𝔻⊕ identityTrans F A
𝔻 [ identityTrans F B F→ f ] ≡⟨⟩
𝔻 [ 𝔻 .𝟙 F→ f ] ≡⟨ proj₂ 𝔻.ident
F→ f ≡⟨ sym (proj₁ 𝔻.ident)
𝔻 [ F→ f 𝔻 .𝟙 ] ≡⟨⟩
𝔻 [ F→ f identityTrans F A ]
where
_𝔻⊕_ = 𝔻 ._⊕_
F→ = F .func→
open module 𝔻 = IsCategory (𝔻 .isCategory)
module 𝔻 = IsCategory (isCategory 𝔻)
identityNat : (F : Functor 𝔻) NaturalTransformation F F
identityNat F = identityTrans F , identityNatural F
module _ {F G H : Functor 𝔻} where
private
_𝔻⊕_ = 𝔻 ._⊕_
_∘nt_ : Transformation G H Transformation F G Transformation F H
(θ ∘nt η) C = θ C 𝔻⊕ η C
(θ ∘nt η) C = 𝔻 [ θ C η C ]
NatComp _:⊕:_ : NaturalTransformation G H NaturalTransformation F G NaturalTransformation F H
proj₁ ((θ , _) :⊕: (η , _)) = θ ∘nt η
proj₂ ((θ , θNat) :⊕: (η , ηNat)) {A} {B} f = begin
((θ ∘nt η) B) 𝔻⊕ (F .func→ f) ≡⟨⟩
(θ B 𝔻⊕ η B) 𝔻⊕ (F .func→ f) ≡⟨ sym assoc
θ B 𝔻⊕ (η B 𝔻⊕ (F .func→ f)) ≡⟨ cong (λ φ θ B 𝔻⊕ φ) (ηNat f)
θ B 𝔻⊕ ((G .func→ f) 𝔻⊕ η A) ≡⟨ assoc
(θ B 𝔻⊕ (G .func→ f)) 𝔻⊕ η A ≡⟨ cong (λ φ φ 𝔻⊕ η A) (θNat f)
(((H .func→ f) 𝔻⊕ θ A) 𝔻⊕ η A) ≡⟨ sym assoc
((H .func→ f) 𝔻⊕ (θ A 𝔻⊕ η A)) ≡⟨⟩
((H .func→ f) 𝔻⊕ ((θ ∘nt η) A))
𝔻 [ (θ ∘nt η) B F .func→ f ] ≡⟨⟩
𝔻 [ 𝔻 [ θ B η B ] F .func→ f ] ≡⟨ sym assoc
𝔻 [ θ B 𝔻 [ η B F .func→ f ] ] ≡⟨ cong (λ φ 𝔻 [ θ B φ ]) (ηNat f)
𝔻 [ θ B 𝔻 [ G .func→ f η A ] ] ≡⟨ assoc
𝔻 [ 𝔻 [ θ B G .func→ f ] η A ] ≡⟨ cong (λ φ 𝔻 [ φ η A ]) (θNat f)
𝔻 [ 𝔻 [ H .func→ f θ A ] η A ] ≡⟨ sym assoc
𝔻 [ H .func→ f 𝔻 [ θ A η A ] ] ≡⟨⟩
𝔻 [ H .func→ f (θ ∘nt η) A ]
where
open IsCategory (𝔻 .isCategory)
open IsCategory (isCategory 𝔻)
NatComp = _:⊕:_
private
@ -86,31 +96,35 @@ module _ {c c' d d' : Level} { : Category c c'} {𝔻 : Cat
× (_:⊕:_ {A} {B} {B} (identityNat B) f) f
:ident: = ident-r , ident-l
instance
:isCategory: : IsCategory (Functor 𝔻) NaturalTransformation
(λ {F} identityNat F) (λ {a} {b} {c} _:⊕:_ {a} {b} {c})
:isCategory: = record
{ assoc = λ {A B C D} :assoc: {A} {B} {C} {D}
; ident = λ {A B} :ident: {A} {B}
}
-- Functor categories. Objects are functors, arrows are natural transformations.
Fun : Category (c c' d d') (c c' d')
Fun = record
RawFun : RawCategory (c c' d d') (c c' d')
RawFun = record
{ Object = Functor 𝔻
; Arrow = NaturalTransformation
; 𝟙 = λ {F} identityNat F
; __ = λ {F G H} _:⊕:_ {F} {G} {H}
; _∘_ = λ {F G H} _:⊕:_ {F} {G} {H}
}
instance
:isCategory: : IsCategory RawFun
:isCategory: = record
{ assoc = λ {A B C D} :assoc: {A} {B} {C} {D}
; ident = λ {A B} :ident: {A} {B}
; arrow-is-set = ?
; univalent = ?
}
Fun : Category (c c' d d') (c c' d')
Fun = RawFun , :isCategory:
module _ { ' : Level} ( : Category ') where
open import Cat.Categories.Sets
-- Restrict the functors to Presheafs.
Presh : Category ( lsuc ') ( ')
Presh = record
RawPresh : RawCategory ( lsuc ') ( ')
RawPresh = record
{ Object = Presheaf
; Arrow = NaturalTransformation
; 𝟙 = λ {F} identityNat F
; _⊕_ = λ {F G H} NatComp {F = F} {G = G} {H = H}
; __ = λ {F G H} NatComp {F = F} {G = G} {H = H}
}

View file

@ -1,4 +1,4 @@
{-# OPTIONS --cubical #-}
{-# OPTIONS --cubical --allow-unsolved-metas #-}
module Cat.Categories.Rel where
open import Cubical
@ -154,11 +154,18 @@ module _ {A B C D : Set} {S : Subset (A × B)} {R : Subset (B × C)} {Q : Subset
(Σ[ b B ] (a , b) S × (Σ[ c C ] (b , c) R × (c , d) Q))
is-assoc = equivToPath equi
Rel : Category (lsuc lzero) (lsuc lzero)
Rel = record
RawRel : RawCategory (lsuc lzero) (lsuc lzero)
RawRel = record
{ Object = Set
; Arrow = λ S R Subset (S × R)
; 𝟙 = λ {S} Diag S
; _⊕_ = λ {A B C} S R λ {( a , c ) Σ[ b B ] ( (a , b) R × (b , c) S )}
; isCategory = record { assoc = funExt is-assoc ; ident = funExt ident-l , funExt ident-r }
; _∘_ = λ {A B C} S R λ {( a , c ) Σ[ b B ] ( (a , b) R × (b , c) S )}
}
RawIsCategoryRel : IsCategory RawRel
RawIsCategoryRel = record
{ assoc = funExt is-assoc
; ident = funExt ident-l , funExt ident-r
; arrow-is-set = {!!}
; univalent = {!!}
}

View file

@ -1,41 +1,49 @@
{-# OPTIONS --allow-unsolved-metas #-}
module Cat.Categories.Sets where
open import Cubical
open import Agda.Primitive
open import Data.Product
open import Data.Product renaming (proj₁ to fst ; proj₂ to snd)
import Function
open import Cat.Category
open import Cat.Functor
open Category
module _ { : Level} where
Sets : Category (lsuc )
Sets = record
{ Object = Set
; Arrow = λ T U T U
; 𝟙 = id
; _⊕_ = _∘_
; isCategory = record { assoc = refl ; ident = funExt (λ _ refl) , funExt (λ _ refl) }
SetsRaw : RawCategory (lsuc )
SetsRaw = record
{ Object = Set
; Arrow = λ T U T U
; 𝟙 = Function.id
; _∘_ = Function._∘_
}
SetsIsCategory : IsCategory SetsRaw
SetsIsCategory = record
{ assoc = refl
; ident = funExt (λ _ refl) , funExt (λ _ refl)
; arrow-is-set = {!!}
; univalent = {!!}
}
where
open import Function
Sets : Category (lsuc )
Sets = SetsRaw , SetsIsCategory
private
module _ {X A B : Set } (f : X A) (g : X B) where
_&&&_ : (X A × B)
_&&&_ x = f x , g x
module _ {X A B : Set } (f : X A) (g : X B) where
_S⊕_ = Sets ._⊕_
lem : proj₁ S⊕ (f &&& g) f × snd S⊕ (f &&& g) g
lem : Sets [ proj₁ (f &&& g)] f × Sets [ proj₂ (f &&& g)] g
proj₁ lem = refl
proj₂ lem = refl
instance
isProduct : {A B : Sets .Object} IsProduct Sets {A} {B} fst snd
isProduct : {A B : Sets .Object} IsProduct Sets {A} {B} proj₁ proj₂
isProduct f g = f &&& g , lem f g
product : (A B : Sets .Object) Product { = Sets} A B
product A B = record { obj = A × B ; proj₁ = fst ; proj₂ = snd ; isProduct = isProduct }
product A B = record { obj = A × B ; proj₁ = proj₁ ; proj₂ = proj₂ ; isProduct = isProduct }
instance
SetsHasProducts : HasProducts Sets
@ -49,12 +57,14 @@ Representable {' = '} = Functor (Sets {'})
representable : { '} { : Category '} Category.Object Representable
representable { = } A = record
{ func* = λ B .Arrow A B
; func→ = ._⊕_
; ident = funExt λ _ snd ident
; distrib = funExt λ x sym assoc
; func→ = ._∘_
; isFunctor = record
{ ident = funExt λ _ proj₂ ident
; distrib = funExt λ x sym assoc
}
}
where
open IsCategory ( .isCategory)
open IsCategory (isCategory )
-- Contravariant Presheaf
Presheaf : { '} ( : Category ') Set ( lsuc ')
@ -64,9 +74,11 @@ Presheaf {' = '} = Functor (Opposite ) (Sets {'})
presheaf : { ' : Level} { : Category '} Category.Object (Opposite ) Presheaf
presheaf { = } B = record
{ func* = λ A .Arrow A B
; func→ = λ f g ._⊕_ g f
; ident = funExt λ x fst ident
; distrib = funExt λ x assoc
; func→ = λ f g ._∘_ g f
; isFunctor = record
{ ident = funExt λ x proj₁ ident
; distrib = funExt λ x assoc
}
}
where
open IsCategory ( .isCategory)
open IsCategory (isCategory )

View file

@ -1,4 +1,4 @@
{-# OPTIONS --cubical #-}
{-# OPTIONS --allow-unsolved-metas --cubical #-}
module Cat.Category where
@ -10,8 +10,9 @@ open import Data.Product renaming
; ∃! to ∃!≈
)
open import Data.Empty
open import Function
import Function
open import Cubical
open import Cubical.GradLemma using ( propIsEquiv )
∃! : {a b} {A : Set a}
(A Set b) Set (a b)
@ -22,57 +23,119 @@ open import Cubical
syntax ∃!-syntax (λ x B) = ∃![ x ] B
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
record RawCategory ( ' : Level) : Set (lsuc (' )) where
-- adding no-eta-equality can speed up type-checking.
-- ONLY IF you define your categories with copatterns though.
no-eta-equality
field
-- Need something like:
-- Object : Σ (Set ) isGroupoid
Object : Set
-- And:
-- Arrow : Object → Object → Σ (Set ') isSet
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 45 _⊕_
_∘_ : {A B C : Object} Arrow B C Arrow A B Arrow A C
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
open Category
-- Thierry: All projections must be `isProp`'s
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 .𝟙
-- According to definitions 9.1.1 and 9.1.6 in the HoTT book the
-- arrows of a category form a set (arrow-is-set), and there is an
-- equivalence between the equality of objects and isomorphisms
-- (univalent).
record IsCategory {a b : Level} ( : RawCategory a b) : Set (lsuc (a b)) where
open RawCategory
-- (Object : Set )
-- (Arrow : Object → Object → Set ')
-- (𝟙 : {o : Object} → Arrow o o)
-- (_∘_ : { a b c : Object } → Arrow b c → Arrow a b → Arrow a c)
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
arrow-is-set : {A B : Object} isSet (Arrow A B)
Epimorphism : {X : .Object } (f : .Arrow A B) Set '
Epimorphism {X} f = ( g₀ g₁ : .Arrow B X ) ._⊕_ g₀ f ._⊕_ g₁ f g₀ g₁
Isomorphism : {A B} (f : Arrow A B) Set b
Isomorphism {A} {B} f = Σ[ g Arrow B A ] g f 𝟙 × f g 𝟙
Monomorphism : {X : .Object} (f : .Arrow A B) Set '
Monomorphism {X} f = ( g₀ g₁ : .Arrow X A ) ._⊕_ f g₀ ._⊕_ f g₁ g₀ g₁
_≅_ : (A B : Object) Set b
_≅_ A B = Σ[ f Arrow A B ] (Isomorphism f)
-- Isomorphism of objects
_≅_ : (A B : Object ) Set '
_≅_ A B = Σ[ f .Arrow A B ] (Isomorphism f)
idIso : (A : Object) A A
idIso A = 𝟙 , (𝟙 , ident)
module _ { ' : Level} ( : Category ') {A B obj : Object } where
IsProduct : (π₁ : Arrow obj A) (π₂ : Arrow obj B) Set ( ')
id-to-iso : (A B : Object) A B A B
id-to-iso A B eq = transp (\ i A eq i) (idIso A)
-- TODO: might want to implement isEquiv differently, there are 3
-- equivalent formulations in the book.
field
univalent : {A B : Object} isEquiv (A B) (A B) (id-to-iso A B)
module _ {A B : Object} where
Epimorphism : {X : Object } (f : Arrow A B) Set b
Epimorphism {X} f = ( g₀ g₁ : Arrow B X ) g₀ f g₁ f g₀ g₁
Monomorphism : {X : Object} (f : Arrow A B) Set b
Monomorphism {X} f = ( g₀ g₁ : Arrow X A ) f g₀ f g₁ g₀ g₁
module _ {a} {b} { : RawCategory a b} where
-- TODO, provable by using arrow-is-set and that isProp (isEquiv _ _ _)
-- This lemma will be useful to prove the equality of two categories.
IsCategory-is-prop : isProp (IsCategory )
IsCategory-is-prop x y i = record
{ assoc = x.arrow-is-set _ _ x.assoc y.assoc i
; ident =
( x.arrow-is-set _ _ (fst x.ident) (fst y.ident) i
, x.arrow-is-set _ _ (snd x.ident) (snd y.ident) i
)
-- ; arrow-is-set = {!λ x₁ y₁ p q → x.arrow-is-set _ _ p q!}
; arrow-is-set = λ _ _ p q
let
golden : x.arrow-is-set _ _ p q y.arrow-is-set _ _ p q
golden = λ j k l {!!}
in
golden i
; univalent = λ y₁ {!!}
}
where
module x = IsCategory x
module y = IsCategory y
Category : (a b : Level) Set (lsuc (a b))
Category a b = Σ (RawCategory a b) IsCategory
module Category {a b : Level} ( : Category a b) where
raw = fst
open RawCategory raw public
isCategory = snd
open RawCategory
-- _∈_ : ∀ {a b} ( : Category a b) → ( .fst .Object → Set b) → Set (a ⊔ b)
-- A ∈ =
Obj : {a b} Category a b Set a
Obj = .fst .Object
_[_,_] : { '} ( : Category ') (A : Obj ) (B : Obj ) Set '
[ A , B ] = .fst .Arrow A B
_[_∘_] : { '} ( : Category ') {A B C : Obj } (g : [ B , C ]) (f : [ A , B ]) [ A , C ]
[ g f ] = .fst ._∘_ g f
module _ { ' : Level} ( : Category ') {A B obj : Obj } where
IsProduct : (π₁ : [ obj , A ]) (π₂ : [ obj , B ]) Set ( ')
IsProduct π₁ π₂
= {X : .Object} (x₁ : .Arrow X A) (x₂ : .Arrow X B)
∃![ x ] ( ._⊕_ π₁ x x₁ × ._⊕_ π₂ x x₂)
= {X : Obj } (x₁ : [ X , A ]) (x₂ : [ X , B ])
∃![ x ] ( [ π₁ x ] x₁ × [ π₂ x ] x₂)
-- Tip from Andrea; Consider this style for efficiency:
-- record IsProduct { ' : Level} ( : Category {} {'})
@ -81,46 +144,55 @@ module _ { ' : Level} ( : Category ') {A B obj : Object } whe
-- 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
record Product { ' : Level} { : Category '} (A B : Obj ) : Set ( ') where
no-eta-equality
field
obj : .Object
proj₁ : .Arrow obj A
proj₂ : .Arrow obj B
obj : Obj
proj₁ : [ obj , A ]
proj₂ : [ obj , B ]
{{isProduct}} : IsProduct proj₁ proj₂
arrowProduct : {X} (π₁ : Arrow X A) (π₂ : Arrow X B)
Arrow X obj
arrowProduct : {X} (π₁ : [ X , A ]) (π₂ : [ X , B ])
[ X , obj ]
arrowProduct π₁ π₂ = fst (isProduct π₁ π₂)
record HasProducts { ' : Level} ( : Category ') : Set ( ') where
field
product : (A B : .Object) Product { = } A B
product : (A B : Obj ) Product { = } A B
open Product
objectProduct : (A B : .Object) .Object
objectProduct : (A B : Obj ) Obj
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' B B' : Obj } [ A , A' ] [ B , B' ]
[ 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₂))
( [ a (product A B) .proj₁ ])
( [ b (product A B) .proj₂ ])
module _ { ' : Level} ( : Category ') where
Opposite : Category '
Opposite =
record
{ Object = .Object
; Arrow = flip ( .Arrow)
; 𝟙 = .𝟙
; _⊕_ = flip ( ._⊕_)
; isCategory = record { assoc = sym assoc ; ident = swap ident }
module _ {a b : Level} ( : Category a b) where
private
open Category
module = RawCategory ( .fst)
OpRaw : RawCategory a b
OpRaw = record
{ Object = .Object
; Arrow = Function.flip .Arrow
; 𝟙 = .𝟙
; _∘_ = Function.flip (._∘_)
}
where
open IsCategory ( .isCategory)
open IsCategory isCategory
OpIsCategory : IsCategory OpRaw
OpIsCategory = record
{ assoc = sym assoc
; ident = swap ident
; arrow-is-set = {!!}
; univalent = {!!}
}
Opposite : Category a b
Opposite = OpRaw , OpIsCategory
-- A consequence of no-eta-equality; `Opposite-is-involution` is no longer
-- definitional - i.e.; you must match on the fields:
@ -133,44 +205,52 @@ module _ { ' : Level} ( : Category ') where
-- assoc (Opposite-is-involution i) = {!!}
-- ident (Opposite-is-involution i) = {!!}
Hom : { ' : Level} ( : Category ') (A B : Object ) Set '
Hom A B = Arrow A B
module _ { ' : Level} { : Category '} where
HomFromArrow : (A : .Object) {B B' : .Object} (g : .Arrow B B')
Hom A B Hom A B'
HomFromArrow _A = _⊕_
module _ { '} ( : Category ') {{hasProducts : HasProducts }} where
open HasProducts hasProducts
open Product hiding (obj)
private
_×p_ : (A B : .Object) .Object
_×p_ : (A B : Obj ) Obj
_×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)
module _ (B C : Obj ) where
IsExponential : (Cᴮ : Obj ) [ Cᴮ ×p B , C ] Set ( ')
IsExponential Cᴮ eval = (A : Obj ) (f : [ A ×p B , C ])
∃![ f~ ] ( [ eval parallelProduct f~ (Category.raw .𝟙)] f)
record Exponential : Set ( ') where
field
-- obj ≡ Cᴮ
obj : .Object
eval : .Arrow ( obj ×p B ) C
obj : Obj
eval : [ 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?
exponentialsHaveProducts : HasProducts
exponentialsHaveProducts = hasProducts
transpose : (A : .Object) .Arrow (A ×p B) C .Arrow A obj
transpose : (A : Obj ) [ A ×p B , C ] [ A , obj ]
transpose A f = fst (isExponential A f)
record HasExponentials { ' : Level} ( : Category ') {{_ : HasProducts }} : Set ( ') where
field
exponent : (A B : .Object) Exponential A B
exponent : (A B : Obj ) 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 : Obj Set (a b)
IsInitial I = {X : Obj } unique ( [ I , X ])
IsTerminal : Obj Set (a b)
-- ∃![ ? ] ?
IsTerminal T = {X : Obj } unique ( [ X , T ])
Initial : Set (a b)
Initial = Σ (Obj ) IsInitial
Terminal : Set (a b)
Terminal = Σ (Obj ) IsTerminal

View file

@ -1,3 +1,4 @@
{-# OPTIONS --allow-unsolved-metas #-}
module Cat.Category.Free where
open import Agda.Primitive
@ -9,28 +10,33 @@ open import Cat.Category as C
module _ { ' : Level} ( : Category ') where
private
open module = Category
Obj = .Object
postulate
Path : ( a b : Obj ) Set '
emptyPath : (o : Obj) Path o o
concatenate : {a b c : Obj} Path b c Path a b Path a c
Path : ( a b : Obj ) Set '
emptyPath : (o : Obj ) Path o o
concatenate : {a b c : Obj } Path b c Path a b Path a c
private
module _ {A B C D : Obj} {r : Path A B} {q : Path B C} {p : Path C D} where
module _ {A B C D : Obj } {r : Path A B} {q : Path B C} {p : Path C D} where
postulate
p-assoc : concatenate {A} {C} {D} p (concatenate {A} {B} {C} q r)
concatenate {A} {B} {D} (concatenate {B} {C} {D} p q) r
module _ {A B : Obj} {p : Path A B} where
module _ {A B : Obj } {p : Path A B} where
postulate
ident-r : concatenate {A} {A} {B} p (emptyPath A) p
ident-l : concatenate {A} {B} {B} (emptyPath B) p p
Free : Category '
Free = record
{ Object = Obj
RawFree : RawCategory '
RawFree = record
{ Object = Obj
; Arrow = Path
; 𝟙 = λ {o} emptyPath o
; _⊕_ = λ {a b c} concatenate {a} {b} {c}
; isCategory = record { assoc = p-assoc ; ident = ident-r , ident-l }
; _∘_ = λ {a b c} concatenate {a} {b} {c}
}
RawIsCategoryFree : IsCategory RawFree
RawIsCategoryFree = record
{ assoc = p-assoc
; ident = ident-r , ident-l
; arrow-is-set = {!!}
; univalent = {!!}
}

View file

@ -9,36 +9,37 @@ open import Cubical
open import Cat.Category
open import Cat.Functor
open import Cat.Categories.Sets
open import Cat.Equality
open Equality.Data.Product
module _ { ' : Level} { : Category '} { A B : .Category.Object } {X : .Category.Object} (f : .Category.Arrow A B) where
open Category
open IsCategory (isCategory)
iso-is-epi : Isomorphism { = } f Epimorphism { = } {X = X} f
iso-is-epi (f- , left-inv , right-inv) g₀ g₁ eq =
begin
iso-is-epi : Isomorphism f Epimorphism {X = X} f
iso-is-epi (f- , left-inv , right-inv) g₀ g₁ eq = begin
g₀ ≡⟨ sym (proj₁ ident)
g₀ 𝟙 ≡⟨ cong (__ g₀) (sym right-inv)
g₀ (f f-) ≡⟨ assoc
(g₀ f) f- ≡⟨ cong (λ φ φ f-) eq
(g₁ f) f- ≡⟨ sym assoc
g₁ (f f-) ≡⟨ cong (_⊕_ g₁) right-inv
g₁ 𝟙 ≡⟨ proj₁ ident
g₀ 𝟙 ≡⟨ cong (__ g₀) (sym right-inv)
g₀ (f f-) ≡⟨ assoc
(g₀ f) f- ≡⟨ cong (λ φ φ f-) eq
(g₁ f) f- ≡⟨ sym assoc
g₁ (f f-) ≡⟨ cong (_∘_ g₁) right-inv
g₁ 𝟙 ≡⟨ proj₁ ident
g₁
iso-is-mono : Isomorphism { = } f Monomorphism { = } {X = X} f
iso-is-mono : Isomorphism f Monomorphism {X = X} f
iso-is-mono (f- , (left-inv , right-inv)) g₀ g₁ eq =
begin
g₀ ≡⟨ sym (proj₂ ident)
𝟙 g₀ ≡⟨ cong (λ φ φ g₀) (sym left-inv)
(f- f) g₀ ≡⟨ sym assoc
f- (f g₀) ≡⟨ cong (_⊕_ f-) eq
f- (f g₁) ≡⟨ assoc
(f- f) g₁ ≡⟨ cong (λ φ φ g₁) left-inv
𝟙 g₁ ≡⟨ proj₂ ident
𝟙 g₀ ≡⟨ cong (λ φ φ g₀) (sym left-inv)
(f- f) g₀ ≡⟨ sym assoc
f- (f g₀) ≡⟨ cong (_∘_ f-) eq
f- (f g₁) ≡⟨ assoc
(f- f) g₁ ≡⟨ cong (λ φ φ g₁) left-inv
𝟙 g₁ ≡⟨ proj₂ ident
g₁
iso-is-epi-mono : Isomorphism { = } f Epimorphism { = } {X = X} f × Monomorphism { = } {X = X} f
iso-is-epi-mono : Isomorphism f Epimorphism {X = X} f × Monomorphism {X = X} f
iso-is-epi-mono iso = iso-is-epi iso , iso-is-mono iso
{-
@ -48,45 +49,76 @@ epi-mono-is-not-iso f =
in {!!}
-}
module _ { : Level} { : Category } where
open import Cat.Category
open Category
open import Cat.Categories.Cat using (Cat)
open import Cat.Categories.Fun
open import Cat.Categories.Sets
module Cat = Cat.Categories.Cat
open Exponential
private
Cat = Cat
prshf = presheaf { = }
open import Cat.Category
open Category
open import Cat.Functor
open Functor
-- Exp : Set (lsuc (lsuc ))
-- Exp = Exponential (Cat (lsuc ) )
-- Sets (Opposite )
-- module _ { : Level} { : Category }
-- {isSObj : isSet ( .Object)}
-- {isz2 : ∀ {} → {A B : Set } → isSet (Sets [ A , B ])} where
-- -- open import Cat.Categories.Cat using (Cat)
-- open import Cat.Categories.Fun
-- open import Cat.Categories.Sets
-- -- module Cat = Cat.Categories.Cat
-- open Exponential
-- private
-- Cat = Cat
-- prshf = presheaf { = }
-- module = IsCategory ( .isCategory)
_⇑_ : (A B : Cat .Object) Cat .Object
A B = (exponent A B) .obj
where
open HasExponentials (Cat.hasExponentials )
-- -- Exp : Set (lsuc (lsuc ))
-- -- Exp = Exponential (Cat (lsuc ) )
-- -- Sets (Opposite )
module _ {A B : .Object} (f : .Arrow A B) where
:func→: : NaturalTransformation (prshf A) (prshf B)
:func→: = (λ C x ( ._⊕_ f x)) , λ f₁ funExt λ x lem
where
lem = ( .isCategory) .IsCategory.assoc
module _ {c : .Object} where
eqTrans : (:func→: ( .𝟙 {c})) .proj₁ (Fun .𝟙 {o = prshf c}) .proj₁
eqTrans = funExt λ x funExt λ x .isCategory .IsCategory.ident .proj₂
eqNat : (i : I) Natural (prshf c) (prshf c) (eqTrans i)
eqNat i f = {!!}
-- _⇑_ : (A B : Cat .Object) → Cat .Object
-- A ⇑ B = (exponent A B) .obj
-- where
-- open HasExponentials (Cat.hasExponentials )
:ident: : (:func→: ( .𝟙 {c})) (Fun .𝟙 {o = prshf c})
:ident: i = eqTrans i , eqNat i
-- module _ {A B : .Object} (f : .Arrow A B) where
-- :func→: : NaturalTransformation (prshf A) (prshf B)
-- :func→: = (λ C x [ f x ]) , λ f₁ funExt λ _ .assoc
yoneda : Functor (Fun { = Opposite } {𝔻 = Sets {}})
yoneda = record
{ func* = prshf
; func→ = :func→:
; ident = :ident:
; distrib = {!!}
}
-- module _ {c : .Object} where
-- eqTrans : (λ _ → Transformation (prshf c) (prshf c))
-- [ (λ _ x → [ .𝟙 ∘ x ]) ≡ identityTrans (prshf c) ]
-- eqTrans = funExt λ x → funExt λ x → .ident .proj₂
-- eqNat : (λ i → Natural (prshf c) (prshf c) (eqTrans i))
-- [(λ _ → funExt (λ _ → .assoc)) ≡ identityNatural (prshf c)]
-- eqNat = λ i {A} {B} f →
-- let
-- open IsCategory (Sets .isCategory)
-- lemm : (Sets [ eqTrans i B ∘ prshf c .func→ f ]) ≡
-- (Sets [ prshf c .func→ f ∘ eqTrans i A ])
-- lemm = {!!}
-- lem : (λ _ → Sets [ Functor.func* (prshf c) A , prshf c .func* B ])
-- [ Sets [ eqTrans i B ∘ prshf c .func→ f ]
-- ≡ Sets [ prshf c .func→ f ∘ eqTrans i A ] ]
-- lem
-- = isz2 _ _ lemm _ i
-- -- (Sets [ eqTrans i B ∘ prshf c .func→ f ])
-- -- (Sets [ prshf c .func→ f ∘ eqTrans i A ])
-- -- lemm
-- -- _ i
-- in
-- lem
-- -- eqNat = λ {A} {B} i [B,A] i' [A,c] →
-- -- let
-- -- k : [ {!!} , {!!} ]
-- -- k = [A,c]
-- -- in {! [ ? ∘ ? ]!}
-- :ident: : (:func→: ( .𝟙 {c})) (Fun .𝟙 {o = prshf c})
-- :ident: = Σ≡ eqTrans eqNat
-- yoneda : Functor (Fun { = Opposite } {𝔻 = Sets {}})
-- yoneda = record
-- { func* = prshf
-- ; func→ = :func→:
-- ; isFunctor = record
-- { ident = :ident:
-- ; distrib = {!!}
-- }
-- }

View file

@ -1,101 +0,0 @@
{-# OPTIONS --allow-unsolved-metas #-}
module Cat.Cubical where
open import Agda.Primitive
open import Data.Bool
open import Data.Product
open import Data.Sum
open import Data.Unit
open import Data.Empty
open import Data.Product
open import Cat.Category
open import Cat.Functor
-- See chapter 1 for a discussion on how presheaf categories are CwF's.
-- See section 6.8 in Huber's thesis for details on how to implement the
-- categorical version of CTT
module CwF { ' : Level} ( : Category ') where
open Category
open Functor
open import Function
open import Cubical
module _ {a b : Level} where
private
Obj = Σ[ A Set a ] (A Set b)
Arr : Obj Obj Set (a b)
Arr (A , B) (A' , B') = Σ[ f (A A') ] ({x : A} B x B' (f x))
one : {o : Obj} Arr o o
proj₁ one = λ x x
proj₂ one = λ b b
_:⊕:_ : {a b c : Obj} Arr b c Arr a b Arr a c
(g , g') :⊕: (f , f') = g f , g' f'
module _ {A B C D : Obj} {f : Arr A B} {g : Arr B C} {h : Arr C D} where
:assoc: : (_:⊕:_ {A} {C} {D} h (_:⊕:_ {A} {B} {C} g f)) (_:⊕:_ {A} {B} {D} (_:⊕:_ {B} {C} {D} h g) f)
:assoc: = {!!}
module _ {A B : Obj} {f : Arr A B} where
:ident: : (_:⊕:_ {A} {A} {B} f one) f × (_:⊕:_ {A} {B} {B} one f) f
:ident: = {!!}
instance
:isCategory: : IsCategory Obj Arr one (λ {a b c} _:⊕:_ {a} {b} {c})
:isCategory: = record
{ assoc = λ {A} {B} {C} {D} {f} {g} {h} :assoc: {A} {B} {C} {D} {f} {g} {h}
; ident = {!!}
}
Fam : Category (lsuc (a b)) (a b)
Fam = record
{ Object = Obj
; Arrow = Arr
; 𝟙 = one
; _⊕_ = λ {a b c} _:⊕:_ {a} {b} {c}
}
Contexts = .Object
Substitutions = .Arrow
record CwF : Set {!a ⊔ b!} where
field
Terms : Functor (Opposite ) Fam
module _ { ' : Level} (Ns : Set ) where
-- Ns is the "namespace"
o = (lsuc lzero )
FiniteDecidableSubset : Set
FiniteDecidableSubset = Ns Bool
isTrue : Bool Set
isTrue false =
isTrue true =
elmsof : (Ns Bool) Set
elmsof P = (σ : Ns) isTrue (P σ)
𝟚 : Set
𝟚 = Bool
module _ (I J : FiniteDecidableSubset) where
private
themap : Set {!!}
themap = elmsof I elmsof J 𝟚
rules : (elmsof I elmsof J 𝟚) Set
rules f = (i j : elmsof I) {!!}
Mor = Σ themap rules
-- The category of names and substitutions
: Category -- o (lsuc lzero ⊔ o)
= record
-- { Object = FiniteDecidableSubset
{ Object = Ns Bool
; Arrow = Mor
; 𝟙 = {!!}
; _⊕_ = {!!}
; isCategory = {!!}
}

55
src/Cat/CwF.agda Normal file
View file

@ -0,0 +1,55 @@
module Cat.CwF where
open import Agda.Primitive
open import Data.Product
open import Cat.Category
open import Cat.Functor
open import Cat.Categories.Fam
open Category
open Functor
module _ {a b : Level} where
record CwF : Set (lsuc (a b)) where
-- "A category with families consists of"
field
-- "A base category"
: Category a b
-- It's objects are called contexts
Contexts = .Object
-- It's arrows are called substitutions
Substitutions = .Arrow
field
-- A functor T
T : Functor (Opposite ) (Fam a b)
-- Empty context
[] : Terminal
Type : (Γ : .Object) Set a
Type Γ = proj₁ (T .func* Γ)
module _ {Γ : .Object} {A : Type Γ} where
module _ {A B : .Object} {γ : [ A , B ]} where
k : Σ (proj₁ (func* T B) proj₁ (func* T A))
(λ f
{x : proj₁ (func* T B)}
proj₂ (func* T B) x proj₂ (func* T A) (f x))
k = T .func→ γ
k₁ : proj₁ (func* T B) proj₁ (func* T A)
k₁ = proj₁ k
k₂ : ({x : proj₁ (func* T B)}
proj₂ (func* T B) x proj₂ (func* T A) (k₁ x))
k₂ = proj₂ k
record ContextComprehension : Set (a b) where
field
Γ&A : .Object
proj1 : .Arrow Γ&A Γ
-- proj2 : ????
-- if γ : [ A , B ]
-- then T .func→ γ (written T[γ]) interpret substitutions in types and terms respectively.
-- field
-- ump : {Δ : .Object} → (γ : [ Δ , Γ ])
-- → (a : {!!}) → {!!}

21
src/Cat/Equality.agda Normal file
View file

@ -0,0 +1,21 @@
-- Defines equality-principles for data-types from the standard library.
module Cat.Equality where
open import Level
open import Cubical
-- _[_≡_] = PathP
module Equality where
module Data where
module Product where
open import Data.Product
module _ {a b : Level} {A : Set a} {B : A Set b} {a b : Σ A B}
(proj₁≡ : (λ _ A) [ proj₁ a proj₁ b ])
(proj₂≡ : (λ i B (proj₁≡ i)) [ proj₂ a proj₂ b ]) where
Σ≡ : a b
proj₁ (Σ≡ i) = proj₁≡ i
proj₂ (Σ≡ i) = proj₂≡ i

View file

@ -6,36 +6,54 @@ open import Function
open import Cat.Category
record Functor {c c' d d'} (C : Category c c') (D : Category d d')
: Set (c c' d d') where
open Category
field
func* : C .Object D .Object
func→ : {dom cod : C .Object} C .Arrow dom cod D .Arrow (func* dom) (func* cod)
ident : { c : C .Object } func→ (C .𝟙 {c}) D .𝟙 {func* 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''}
func→ (C ._⊕_ a' a) D ._⊕_ (func→ a') (func→ a)
open Category hiding (_∘_)
module _ {c c' d d'} ( : Category c c') (𝔻 : Category d d') where
record IsFunctor
(func* : Obj Obj 𝔻)
(func→ : {A B : Obj } [ A , B ] 𝔻 [ func* A , func* B ])
: Set (c c' d d') where
field
ident : {c : Obj } func→ ( .𝟙 {c}) 𝔻 .𝟙 {func* 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 : {A B C : .Object} {f : [ A , B ]} {g : [ B , C ]}
func→ ( [ g f ]) 𝔻 [ func→ g func→ f ]
record Functor : Set (c c' d d') where
field
func* : .Object 𝔻 .Object
func→ : {A B} [ A , B ] 𝔻 [ func* A , func* B ]
{{isFunctor}} : IsFunctor func* func→
open IsFunctor
open Functor
open Category
module _ { ' : Level} { 𝔻 : Category '} where
private
_⊕_ = ._⊕_
IsFunctor≡
: {func* : .Object 𝔻 .Object}
{func→ : {A B : .Object} .Arrow A B 𝔻 .Arrow (func* A) (func* B)}
{F G : IsFunctor 𝔻 func* func→}
(eqI
: (λ i {A} func→ ( .𝟙 {A}) 𝔻 .𝟙 {func* A})
[ F .ident G .ident ])
(eqD :
(λ i {A B C} {f : [ A , B ]} {g : [ B , C ]}
func→ ( [ g f ]) 𝔻 [ func→ g func→ f ])
[ F .distrib G .distrib ])
(λ _ IsFunctor 𝔻 (λ i func* i) func→) [ F G ]
IsFunctor≡ eqI eqD i = record { ident = eqI i ; distrib = eqD i }
Functor≡ : {F G : Functor 𝔻}
(eq* : F .func* G .func*)
(eq→ : PathP (λ i {x y} .Arrow x y 𝔻 .Arrow (eq* i x) (eq* i y))
(F .func→) (G .func→))
(eqI : PathP (λ i {A : .Object} eq→ i ( .𝟙 {A}) 𝔻 .𝟙 {eq* i A})
(ident F) (ident G))
(eqD : PathP (λ i {A B C : .Object} {f : .Arrow A B} {g : .Arrow B C}
eq→ i ( ._⊕_ g f) 𝔻 ._⊕_ (eq→ i g) (eq→ i f))
(distrib F) (distrib G))
(eq→ : (λ i {x y} [ x , y ] 𝔻 [ eq* i x , eq* i y ])
[ F .func→ G .func→ ])
-- → (eqIsF : PathP (λ i → IsFunctor 𝔻 (eq* i) (eq→ i)) (F .isFunctor) (G .isFunctor))
(eqIsFunctor : (λ i IsFunctor 𝔻 (eq* i) (eq→ i)) [ F .isFunctor G .isFunctor ])
F G
Functor≡ eq* eq→ eqI eqD i = record { func* = eq* i ; func→ = eq→ i ; ident = eqI i ; distrib = eqD i }
Functor≡ eq* eq→ eqIsFunctor i = record { func* = eq* i ; func→ = eq→ i ; isFunctor = eqIsFunctor i }
module _ { ' : Level} {A B C : Category '} (F : Functor B C) (G : Functor A B) where
private
@ -43,29 +61,28 @@ module _ { ' : Level} {A B C : Category '} (F : Functor B C) (G : F
F→ = F .func→
G* = G .func*
G→ = G .func→
_A⊕_ = A ._⊕_
_B⊕_ = B ._⊕_
_C⊕_ = C ._⊕_
module _ {a0 a1 a2 : A .Object} {α0 : A .Arrow a0 a1} {α1 : A .Arrow a1 a2} where
module _ {a0 a1 a2 : A .Object} {α0 : A [ a0 , a1 ]} {α1 : A [ a1 , a2 ]} where
dist : (F→ G→) (α1 A⊕ α0) (F→ G→) α1 C⊕ (F→ G→) α0
dist : (F→ G→) (A [ α1 α0 ]) C [ (F→ G→) α1 (F→ G→) α0 ]
dist = begin
(F→ G→) (α1 A⊕ α0) ≡⟨ refl
F→ (G→ (α1 A⊕ α0)) ≡⟨ cong F→ (G .distrib)
F→ ((G→ α1) B⊕ (G→ α0)) ≡⟨ F .distrib
(F→ G→) α1 C⊕ (F→ G→) α0
(F→ G→) (A [ α1 α0 ]) ≡⟨ refl
F→ (G→ (A [ α1 α0 ])) ≡⟨ cong F→ (G .isFunctor .distrib)
F→ (B [ G→ α1 G→ α0 ]) ≡⟨ F .isFunctor .distrib
C [ (F→ G→) α1 (F→ G→) α0 ]
_∘f_ : Functor A C
_∘f_ =
record
{ func* = F* G*
; func→ = F→ G→
; ident = begin
(F→ G→) (A .𝟙) ≡⟨ refl
F→ (G→ (A .𝟙)) ≡⟨ cong F→ (G .ident)
F→ (B .𝟙) ≡⟨ F .ident
C .𝟙
; distrib = dist
; isFunctor = record
{ ident = begin
(F→ G→) (A .𝟙) ≡⟨ refl
F→ (G→ (A .𝟙)) ≡⟨ cong F→ (G .isFunctor .ident)
F→ (B .𝟙) ≡⟨ F .isFunctor .ident
C .𝟙
; distrib = dist
}
}
-- The identity functor
@ -73,6 +90,8 @@ identity : ∀ { '} → {C : Category '} → Functor C C
identity = record
{ func* = λ x x
; func→ = λ x x
; ident = refl
; distrib = refl
; isFunctor = record
{ ident = refl
; distrib = refl
}
}