Make sets a category according to HoTT

This commit is contained in:
Frederik Hanghøj Iversen 2018-02-21 13:37:07 +01:00
parent ed40824edc
commit 57d7eab4cb
2 changed files with 106 additions and 75 deletions

View file

@ -9,55 +9,95 @@ import Function
open import Cat.Category
open import Cat.Category.Functor
open import Cat.Category.Product
open Category
module _ { : Level} where
SetsRaw : RawCategory (lsuc )
RawCategory.Object SetsRaw = Set
RawCategory.Arrow SetsRaw = λ T U T U
RawCategory.𝟙 SetsRaw = Function.id
RawCategory._∘_ SetsRaw = Function._∘_
module _ ( : Level) where
private
open RawCategory
open IsCategory
open import Cubical.Univalence
open import Cubical.NType.Properties
open import Cubical.Universe
SetsRaw : RawCategory (lsuc )
Object SetsRaw = Cubical.Universe.0-Set
Arrow SetsRaw (T , _) (U , _) = T U
𝟙 SetsRaw = Function.id
_∘_ SetsRaw = Function._∘_
setIsSet : (A : Set ) isSet A
setIsSet A x y p q = {!ua!}
SetsIsCategory : IsCategory SetsRaw
assoc SetsIsCategory = refl
proj₁ (ident SetsIsCategory) = funExt λ _ refl
proj₂ (ident SetsIsCategory) = funExt λ _ refl
arrowIsSet SetsIsCategory = {!!}
arrowIsSet SetsIsCategory {B = (_ , s)} = setPi λ _ s
univalent SetsIsCategory = {!!}
Sets : Category (lsuc )
raw Sets = SetsRaw
isCategory Sets = SetsIsCategory
𝓢𝓮𝓽 Sets : Category (lsuc )
Category.raw 𝓢𝓮𝓽 = SetsRaw
Category.isCategory 𝓢𝓮𝓽 = SetsIsCategory
Sets = 𝓢𝓮𝓽
module _ { : Level} where
private
𝓢 = 𝓢𝓮𝓽
open Category 𝓢
open import Cubical.Sigma
module _ (0A 0B : Object) where
private
A : Set
A = proj₁ 0A
sA : isSet A
sA = proj₂ 0A
B : Set
B = proj₁ 0B
sB : isSet B
sB = proj₂ 0B
0A×0B : Object
0A×0B = (A × B) , sigPresSet sA λ _ sB
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
lem : Sets [ proj₁ (f &&& g)] f × Sets [ proj₂ (f &&& g)] g
module _ {0X : Object} where
X = proj₁ 0X
module _ (f : X A ) (g : X B) where
lem : proj₁ Function.∘′ (f &&& g) f × proj₂ Function.∘′ (f &&& g) g
proj₁ lem = refl
proj₂ lem = refl
instance
isProduct : {A B : Object Sets} IsProduct Sets {A} {B} proj₁ proj₂
isProduct f g = f &&& g , lem f g
isProduct : IsProduct 𝓢 {0A} {0B} {0A×0B} proj₁ proj₂
isProduct {X = X} f g = (f &&& g) , lem {0X = X} f g
product : (A B : Object Sets) Product { = Sets} A B
product A B = record { obj = A × B ; proj₁ = proj₁ ; proj₂ = proj₂ ; isProduct = isProduct }
product : Product { = 𝓢} 0A 0B
product = record
{ obj = 0A×0B
; proj₁ = Data.Product.proj₁
; proj₂ = Data.Product.proj₂
; isProduct = λ { {X} isProduct {X = X}}
}
instance
SetsHasProducts : HasProducts Sets
SetsHasProducts : HasProducts 𝓢
SetsHasProducts = record { product = product }
-- Covariant Presheaf
Representable : { ' : Level} ( : Category ') Set ( lsuc ')
Representable {' = '} = Functor (Sets {'})
module _ {a b : Level} where
module _ ( : Category a b) where
-- Covariant Presheaf
Representable : Set (a lsuc b)
Representable = Functor (𝓢𝓮𝓽 b)
-- The "co-yoneda" embedding.
representable : { '} { : Category '} Category.Object Representable
representable { = } A = record
-- Contravariant Presheaf
Presheaf : Set (a lsuc b)
Presheaf = Functor (Opposite ) (𝓢𝓮𝓽 b)
-- The "co-yoneda" embedding.
representable : { : Category a b} Category.Object Representable
representable { = } A = record
{ raw = record
{ func* = λ B [ A , B ]
{ func* = λ B [ A , B ] , arrowIsSet
; func→ = [_∘_]
}
; isFunctor = record
@ -66,17 +106,13 @@ representable { = } A = record
}
}
where
open IsCategory (isCategory )
open Category
-- Contravariant Presheaf
Presheaf : { '} ( : Category ') Set ( lsuc ')
Presheaf {' = '} = Functor (Opposite ) (Sets {'})
-- Alternate name: `yoneda`
presheaf : { ' : Level} { : Category '} Category.Object (Opposite ) Presheaf
presheaf { = } B = record
-- Alternate name: `yoneda`
presheaf : { : Category a b} Category.Object (Opposite ) Presheaf
presheaf { = } B = record
{ raw = record
{ func* = λ A [ A , B ]
{ func* = λ A [ A , B ] , arrowIsSet
; func→ = λ f g [ g f ]
}
; isFunctor = record
@ -85,4 +121,4 @@ presheaf { = } B = record
}
}
where
open IsCategory (isCategory )
open Category

View file

@ -84,6 +84,7 @@ module Univalence {a b : Level} ( : RawCategory a b) where
idIso : (A : Object) A A
idIso A = 𝟙 , (𝟙 , ident)
-- Lemma 9.1.4 in [HoTT]
id-to-iso : (A B : Object) A B A B
id-to-iso A B eq = transp (\ i A eq i) (idIso A)
@ -93,12 +94,6 @@ module Univalence {a b : Level} ( : RawCategory a b) where
Univalent : Set (a b)
Univalent = {A B : Object} isEquiv (A B) (A B) (id-to-iso A B)
-- Thierry: All projections must be `isProp`'s
-- 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
open Univalence public
@ -192,14 +187,16 @@ record Category (a b : Level) : Set (lsuc (a ⊔ b)) where
{{isCategory}} : IsCategory raw
open RawCategory raw public
open IsCategory isCategory public
module _ {a b : Level} ( : Category a b) where
open Category
_[_,_] : (A : Object) (B : Object) Set b
_[_,_] = Arrow
_[_∘_] : {A B C : Object} (g : Arrow B C) (f : Arrow A B) Arrow A C
_[_∘_] = _∘_
module _ {a b : Level} ( : Category a b) where
private
open Category
@ -210,8 +207,6 @@ module _ {a b : Level} ( : Category a b) where
RawCategory.𝟙 OpRaw = 𝟙
RawCategory._∘_ OpRaw = Function.flip _∘_
open IsCategory isCategory
OpIsCategory : IsCategory OpRaw
IsCategory.assoc OpIsCategory = sym assoc
IsCategory.ident OpIsCategory = swap ident