Use arrowIsSet to simplify equality constructor for functors

This commit is contained in:
Frederik Hanghøj Iversen 2018-02-07 20:19:17 +01:00
parent 9349b37550
commit 56d689fb4b
3 changed files with 53 additions and 22 deletions

View file

@ -1,4 +1,4 @@
{-# OPTIONS --allow-unsolved-metas #-} {-# OPTIONS --allow-unsolved-metas --cubical #-}
module Cat.Categories.Fun where module Cat.Categories.Fun where
open import Agda.Primitive open import Agda.Primitive
@ -9,6 +9,9 @@ open import Data.Product
open import Cat.Category open import Cat.Category
open import Cat.Category.Functor open import Cat.Category.Functor
open import Cat.Equality
open Equality.Data.Product
module _ {c c' d d' : Level} { : Category c c'} {𝔻 : Category d d'} where module _ {c c' d d' : Level} { : Category c c'} {𝔻 : Category d d'} where
open Category hiding ( _∘_ ; Arrow ) open Category hiding ( _∘_ ; Arrow )
open Functor open Functor
@ -86,12 +89,20 @@ module _ {c c' d d' : Level} { : Category c c'} {𝔻 : Cat
NatComp = _:⊕:_ NatComp = _:⊕:_
private private
module _ {F G : Functor 𝔻} where
naturalTransformationIsSets : IsSet (NaturalTransformation F G)
naturalTransformationIsSets {θ , θNat} {η , ηNat} p q i j
= (λ C 𝔻.arrowIsSet (λ l proj₁ (p l) C) (λ l proj₁ (q l) C) i j)
, λ f k 𝔻.arrowIsSet (λ l proj₂ (p l) f {!!}) (λ l proj₂ (p l) f {!!}) {!!} {!!}
where
module 𝔻 = IsCategory (isCategory 𝔻)
module _ {A B C D : Functor 𝔻} {f : NaturalTransformation A B} module _ {A B C D : Functor 𝔻} {f : NaturalTransformation A B}
{g : NaturalTransformation B C} {h : NaturalTransformation C D} where {g : NaturalTransformation B C} {h : NaturalTransformation C D} where
_g⊕f_ = _:⊕:_ {A} {B} {C} _g⊕f_ = _:⊕:_ {A} {B} {C}
_h⊕g_ = _:⊕:_ {B} {C} {D} _h⊕g_ = _:⊕:_ {B} {C} {D}
:assoc: : (_:⊕:_ {A} {C} {D} h (_:⊕:_ {A} {B} {C} g f)) (_:⊕:_ {A} {B} {D} (_:⊕:_ {B} {C} {D} h g) f) :assoc: : (_:⊕:_ {A} {C} {D} h (_:⊕:_ {A} {B} {C} g f)) (_:⊕:_ {A} {B} {D} (_:⊕:_ {B} {C} {D} h g) f)
:assoc: = {!!} :assoc: = Σ≡ (funExt λ x {!Fun.arrowIsSet!}) {!!}
module _ {A B : Functor 𝔻} {f : NaturalTransformation A B} where module _ {A B : Functor 𝔻} {f : NaturalTransformation A B} where
ident-r : (_:⊕:_ {A} {A} {B} f (identityNat A)) f ident-r : (_:⊕:_ {A} {A} {B} f (identityNat A)) f
ident-r = {!!} ident-r = {!!}
@ -116,7 +127,7 @@ module _ {c c' d d' : Level} { : Category c c'} {𝔻 : Cat
:isCategory: = record :isCategory: = record
{ assoc = λ {A B C D} :assoc: {A} {B} {C} {D} { assoc = λ {A B C D} :assoc: {A} {B} {C} {D}
; ident = λ {A B} :ident: {A} {B} ; ident = λ {A B} :ident: {A} {B}
; arrowIsSet = {!!} ; arrowIsSet = λ {F} {G} naturalTransformationIsSets {F} {G}
; univalent = {!!} ; univalent = {!!}
} }

View file

@ -26,6 +26,10 @@ syntax ∃!-syntax (λ x → B) = ∃![ x ] B
IsSet : { : Level} (A : Set ) Set IsSet : { : Level} (A : Set ) Set
IsSet A = {x y : A} (p q : x y) p q IsSet A = {x y : A} (p q : x y) p q
-- This follows from [HoTT-book: §7.1.10]
-- Andrea says the proof is in `cubical` but I can't find it.
postulate isSetIsProp : { : Level} {A : Set } isProp (IsSet A)
record RawCategory ( ' : Level) : Set (lsuc (' )) where record RawCategory ( ' : Level) : Set (lsuc (' )) where
-- adding no-eta-equality can speed up type-checking. -- adding no-eta-equality can speed up type-checking.
-- ONLY IF you define your categories with copatterns though. -- ONLY IF you define your categories with copatterns though.
@ -53,6 +57,7 @@ record RawCategory ( ' : Level) : Set (lsuc (' ⊔ )) where
-- (univalent). -- (univalent).
record IsCategory {a b : Level} ( : RawCategory a b) : Set (lsuc (a b)) where record IsCategory {a b : Level} ( : RawCategory a b) : Set (lsuc (a b)) where
open RawCategory open RawCategory
module Raw = RawCategory
field field
assoc : {A B C D : Object} { f : Arrow A B } { g : Arrow B C } { h : Arrow C D } assoc : {A B C D : Object} { f : Arrow A B } { g : Arrow B C } { h : Arrow C D }
h (g f) (h g) f h (g f) (h g) f
@ -91,22 +96,40 @@ module _ {a} {b} { : RawCategory a b} where
-- This lemma will be useful to prove the equality of two categories. -- This lemma will be useful to prove the equality of two categories.
IsCategory-is-prop : isProp (IsCategory ) IsCategory-is-prop : isProp (IsCategory )
IsCategory-is-prop x y i = record IsCategory-is-prop x y i = record
-- Why choose `x`'s `arrowIsSet`?
{ assoc = x.arrowIsSet x.assoc y.assoc i { assoc = x.arrowIsSet x.assoc y.assoc i
; ident = ; ident =
( x.arrowIsSet (fst x.ident) (fst y.ident) i ( x.arrowIsSet (fst x.ident) (fst y.ident) i
, x.arrowIsSet (snd x.ident) (snd y.ident) i , x.arrowIsSet (snd x.ident) (snd y.ident) i
) )
; arrowIsSet = λ p q ; arrowIsSet = isSetIsProp x.arrowIsSet y.arrowIsSet i
let ; univalent = {!!}
golden : x.arrowIsSet p q y.arrowIsSet p q
golden = {!!}
in
golden i
; univalent = λ y₁ {!!}
} }
where where
module x = IsCategory x module x = IsCategory x
module y = IsCategory y module y = IsCategory y
xuni : x.Univalent
xuni = x.univalent
yuni : y.Univalent
yuni = y.univalent
open RawCategory
T : I Set (a b)
T i = {A B : Object}
isEquiv (A B) (A x.≅ B)
(λ A≡B
transp
(λ j
Σ-syntax (Arrow A (A≡B j))
(λ f Σ-syntax (Arrow (A≡B j) A) (λ g g f 𝟙 × f g 𝟙)))
( 𝟙
, 𝟙
, x.arrowIsSet (fst x.ident) (fst y.ident) i
, x.arrowIsSet (snd x.ident) (snd y.ident) i
)
)
eqUni : T [ xuni yuni ]
eqUni = {!!}
record Category (a b : Level) : Set (lsuc (a b)) where record Category (a b : Level) : Set (lsuc (a b)) where
field field

View file

@ -1,3 +1,4 @@
{-# OPTIONS --cubical #-}
module Cat.Category.Functor where module Cat.Category.Functor where
open import Agda.Primitive open import Agda.Primitive
@ -78,14 +79,11 @@ module _
IsProp' : { : Level} (A : I Set ) Set IsProp' : { : Level} (A : I Set ) Set
IsProp' A = (a0 : A i0) (a1 : A i1) A [ a0 a1 ] IsProp' A = (a0 : A i0) (a1 : A i1) A [ a0 a1 ]
postulate IsFunctorIsProp' : IsProp' λ i IsFunctor _ _ (F i) IsFunctorIsProp' : IsProp' λ i IsFunctor _ _ (F i)
-- IsFunctorIsProp' isF0 isF1 i = record IsFunctorIsProp' isF0 isF1 = lemPropF {B = IsFunctor 𝔻}
-- { ident = {!𝔻.arrowIsSet {!isF0.ident!} {!isF1.ident!} i!} (\ F IsFunctorIsProp {F = F}) (\ i F i)
-- ; distrib = {!𝔻.arrowIsSet {!isF0.distrib!} {!isF1.distrib!} i!} where
-- } open import Cubical.GradLemma using (lemPropF)
-- where
-- module isF0 = IsFunctor isF0
-- module isF1 = IsFunctor isF1
module _ { ' : Level} { 𝔻 : Category '} where module _ { ' : Level} { 𝔻 : Category '} where
Functor≡ : {F G : Functor 𝔻} Functor≡ : {F G : Functor 𝔻}
@ -95,14 +93,13 @@ module _ { ' : Level} { 𝔻 : Category '} where
F G F G
Functor≡ {F} {G} eq* eq→ i = record Functor≡ {F} {G} eq* eq→ i = record
{ raw = eqR i { raw = eqR i
; isFunctor = f i ; isFunctor = eqIsF i
} }
where where
eqR : raw F raw G eqR : raw F raw G
eqR i = record { func* = eq* i ; func→ = eq→ i } eqR i = record { func* = eq* i ; func→ = eq→ i }
postulate T : isSet (IsFunctor _ _ (raw F)) eqIsF : (λ i IsFunctor 𝔻 (eqR i)) [ isFunctor F isFunctor G ]
f : (λ i IsFunctor 𝔻 (eqR i)) [ isFunctor F isFunctor G ] eqIsF = IsFunctorIsProp' (isFunctor F) (isFunctor G)
f = IsFunctorIsProp' (isFunctor F) (isFunctor G)
module _ { ' : Level} {A B C : Category '} (F : Functor B C) (G : Functor A B) where module _ { ' : Level} {A B C : Category '} (F : Functor B C) (G : Functor A B) where
private private