2018-02-25 14:21:38 +00:00
|
|
|
|
-- | Univalent categories
|
|
|
|
|
--
|
|
|
|
|
-- This module defines:
|
|
|
|
|
--
|
|
|
|
|
-- Categories
|
|
|
|
|
-- ==========
|
|
|
|
|
--
|
|
|
|
|
-- Types
|
|
|
|
|
-- ------
|
|
|
|
|
--
|
|
|
|
|
-- Object, Arrow
|
|
|
|
|
--
|
|
|
|
|
-- Data
|
|
|
|
|
-- ----
|
2018-04-03 09:36:09 +00:00
|
|
|
|
-- identity; the identity arrow
|
2018-04-11 08:58:50 +00:00
|
|
|
|
-- _<<<_; function composition
|
2018-02-25 14:21:38 +00:00
|
|
|
|
--
|
|
|
|
|
-- Laws
|
|
|
|
|
-- ----
|
|
|
|
|
--
|
|
|
|
|
-- associativity, identity, arrows form sets, univalence.
|
|
|
|
|
--
|
|
|
|
|
-- Lemmas
|
|
|
|
|
-- ------
|
|
|
|
|
--
|
|
|
|
|
-- Propositionality for all laws about the category.
|
2018-02-02 14:33:54 +00:00
|
|
|
|
{-# OPTIONS --allow-unsolved-metas --cubical #-}
|
2017-11-10 15:00:00 +00:00
|
|
|
|
|
2018-01-08 21:48:59 +00:00
|
|
|
|
module Cat.Category where
|
2017-11-10 15:00:00 +00:00
|
|
|
|
|
2018-03-21 13:39:56 +00:00
|
|
|
|
open import Cat.Prelude
|
2018-04-09 16:10:39 +00:00
|
|
|
|
import Cat.Equivalence
|
|
|
|
|
open Cat.Equivalence public using () renaming (Isomorphism to TypeIsomorphism)
|
|
|
|
|
open Cat.Equivalence
|
|
|
|
|
hiding (preorder≅ ; Isomorphism)
|
2018-01-20 23:21:25 +00:00
|
|
|
|
|
2018-03-22 13:27:16 +00:00
|
|
|
|
------------------
|
2018-02-25 14:21:38 +00:00
|
|
|
|
-- * Categories --
|
2018-03-22 13:27:16 +00:00
|
|
|
|
------------------
|
2018-02-25 14:21:38 +00:00
|
|
|
|
|
|
|
|
|
-- | Raw categories
|
|
|
|
|
--
|
|
|
|
|
-- This record desribes the data that a category consist of as well as some laws
|
|
|
|
|
-- about these. The laws defined are the types the propositions - not the
|
|
|
|
|
-- witnesses to them!
|
2018-02-20 15:22:38 +00:00
|
|
|
|
record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where
|
2018-02-05 10:43:38 +00:00
|
|
|
|
no-eta-equality
|
|
|
|
|
field
|
2018-04-03 09:36:09 +00:00
|
|
|
|
Object : Set ℓa
|
|
|
|
|
Arrow : Object → Object → Set ℓb
|
|
|
|
|
identity : {A : Object} → Arrow A A
|
2018-04-11 08:58:50 +00:00
|
|
|
|
_<<<_ : {A B C : Object} → Arrow B C → Arrow A B → Arrow A C
|
2018-02-20 15:22:38 +00:00
|
|
|
|
|
2018-04-19 10:20:44 +00:00
|
|
|
|
-- infixr 8 _<<<_
|
|
|
|
|
-- infixl 8 _>>>_
|
2018-04-11 08:58:50 +00:00
|
|
|
|
infixl 10 _<<<_ _>>>_
|
2018-02-20 15:22:38 +00:00
|
|
|
|
|
2018-02-25 14:21:38 +00:00
|
|
|
|
-- | Operations on data
|
|
|
|
|
|
2018-03-26 12:11:15 +00:00
|
|
|
|
domain : {a b : Object} → Arrow a b → Object
|
|
|
|
|
domain {a} _ = a
|
2018-02-20 15:22:38 +00:00
|
|
|
|
|
2018-03-26 12:11:15 +00:00
|
|
|
|
codomain : {a b : Object} → Arrow a b → Object
|
2018-02-05 10:43:38 +00:00
|
|
|
|
codomain {b = b} _ = b
|
|
|
|
|
|
2018-02-26 18:59:11 +00:00
|
|
|
|
_>>>_ : {A B C : Object} → (Arrow A B) → (Arrow B C) → Arrow A C
|
2018-04-11 08:58:50 +00:00
|
|
|
|
f >>> g = g <<< f
|
2018-02-26 18:59:11 +00:00
|
|
|
|
|
2018-02-25 14:21:38 +00:00
|
|
|
|
-- | Laws about the data
|
|
|
|
|
|
2018-03-08 00:09:40 +00:00
|
|
|
|
-- FIXME It seems counter-intuitive that the normal-form is on the
|
2018-02-24 19:37:21 +00:00
|
|
|
|
-- right-hand-side.
|
2018-02-20 15:22:38 +00:00
|
|
|
|
IsAssociative : Set (ℓa ⊔ ℓb)
|
|
|
|
|
IsAssociative = ∀ {A B C D} {f : Arrow A B} {g : Arrow B C} {h : Arrow C D}
|
2018-04-11 08:58:50 +00:00
|
|
|
|
→ h <<< (g <<< f) ≡ (h <<< g) <<< f
|
2018-02-20 15:22:38 +00:00
|
|
|
|
|
|
|
|
|
IsIdentity : ({A : Object} → Arrow A A) → Set (ℓa ⊔ ℓb)
|
|
|
|
|
IsIdentity id = {A B : Object} {f : Arrow A B}
|
2018-04-11 08:58:50 +00:00
|
|
|
|
→ id <<< f ≡ f × f <<< id ≡ f
|
2018-02-20 15:22:38 +00:00
|
|
|
|
|
2018-02-23 09:35:42 +00:00
|
|
|
|
ArrowsAreSets : Set (ℓa ⊔ ℓb)
|
|
|
|
|
ArrowsAreSets = ∀ {A B : Object} → isSet (Arrow A B)
|
|
|
|
|
|
2018-02-20 15:22:38 +00:00
|
|
|
|
IsInverseOf : ∀ {A B} → (Arrow A B) → (Arrow B A) → Set ℓb
|
2018-04-11 08:58:50 +00:00
|
|
|
|
IsInverseOf = λ f g → g <<< f ≡ identity × f <<< g ≡ identity
|
2018-02-20 15:22:38 +00:00
|
|
|
|
|
|
|
|
|
Isomorphism : ∀ {A B} → (f : Arrow A B) → Set ℓb
|
|
|
|
|
Isomorphism {A} {B} f = Σ[ g ∈ Arrow B A ] IsInverseOf f g
|
|
|
|
|
|
2018-04-19 10:20:44 +00:00
|
|
|
|
_≊_ : (A B : Object) → Set ℓb
|
|
|
|
|
_≊_ A B = Σ[ f ∈ Arrow A B ] (Isomorphism f)
|
2018-02-20 15:22:38 +00:00
|
|
|
|
|
|
|
|
|
module _ {A B : Object} where
|
|
|
|
|
Epimorphism : {X : Object } → (f : Arrow A B) → Set ℓb
|
2018-04-11 08:58:50 +00:00
|
|
|
|
Epimorphism {X} f = (g₀ g₁ : Arrow B X) → g₀ <<< f ≡ g₁ <<< f → g₀ ≡ g₁
|
2018-02-20 15:22:38 +00:00
|
|
|
|
|
|
|
|
|
Monomorphism : {X : Object} → (f : Arrow A B) → Set ℓb
|
2018-04-11 08:58:50 +00:00
|
|
|
|
Monomorphism {X} f = (g₀ g₁ : Arrow X A) → f <<< g₀ ≡ f <<< g₁ → g₀ ≡ g₁
|
2018-02-20 15:22:38 +00:00
|
|
|
|
|
2018-02-21 11:59:31 +00:00
|
|
|
|
IsInitial : Object → Set (ℓa ⊔ ℓb)
|
|
|
|
|
IsInitial I = {X : Object} → isContr (Arrow I X)
|
2018-02-20 17:14:42 +00:00
|
|
|
|
|
|
|
|
|
IsTerminal : Object → Set (ℓa ⊔ ℓb)
|
2018-02-20 17:15:07 +00:00
|
|
|
|
IsTerminal T = {X : Object} → isContr (Arrow X T)
|
2018-02-20 17:14:42 +00:00
|
|
|
|
|
2018-02-21 11:59:31 +00:00
|
|
|
|
Initial : Set (ℓa ⊔ ℓb)
|
|
|
|
|
Initial = Σ Object IsInitial
|
2018-02-20 17:14:42 +00:00
|
|
|
|
|
|
|
|
|
Terminal : Set (ℓa ⊔ ℓb)
|
2018-02-21 11:59:31 +00:00
|
|
|
|
Terminal = Σ Object IsTerminal
|
2018-02-20 17:14:42 +00:00
|
|
|
|
|
2018-03-20 14:19:28 +00:00
|
|
|
|
-- | Univalence is indexed by a raw category as well as an identity proof.
|
2018-04-03 09:36:09 +00:00
|
|
|
|
module Univalence (isIdentity : IsIdentity identity) where
|
2018-03-22 13:27:16 +00:00
|
|
|
|
-- | The identity isomorphism
|
2018-04-19 10:20:44 +00:00
|
|
|
|
idIso : (A : Object) → A ≊ A
|
2018-04-03 09:36:09 +00:00
|
|
|
|
idIso A = identity , identity , isIdentity
|
2018-02-20 17:11:14 +00:00
|
|
|
|
|
2018-03-22 13:27:16 +00:00
|
|
|
|
-- | Extract an isomorphism from an equality
|
|
|
|
|
--
|
|
|
|
|
-- [HoTT §9.1.4]
|
2018-04-19 10:20:44 +00:00
|
|
|
|
idToIso : (A B : Object) → A ≡ B → A ≊ B
|
2018-04-23 15:04:27 +00:00
|
|
|
|
idToIso A B eq = subst eq (idIso A)
|
2018-02-20 17:11:14 +00:00
|
|
|
|
|
|
|
|
|
Univalent : Set (ℓa ⊔ ℓb)
|
2018-04-19 10:20:44 +00:00
|
|
|
|
Univalent = {A B : Object} → isEquiv (A ≡ B) (A ≊ B) (idToIso A B)
|
2018-03-15 10:04:15 +00:00
|
|
|
|
|
2018-04-06 14:54:00 +00:00
|
|
|
|
univalenceFromIsomorphism : {A B : Object}
|
2018-04-19 10:20:44 +00:00
|
|
|
|
→ TypeIsomorphism (idToIso A B) → isEquiv (A ≡ B) (A ≊ B) (idToIso A B)
|
2018-04-06 14:54:00 +00:00
|
|
|
|
univalenceFromIsomorphism = fromIso _ _
|
|
|
|
|
|
2018-03-22 13:27:16 +00:00
|
|
|
|
-- A perhaps more readable version of univalence:
|
2018-04-19 10:20:44 +00:00
|
|
|
|
Univalent≃ = {A B : Object} → (A ≡ B) ≃ (A ≊ B)
|
|
|
|
|
Univalent≅ = {A B : Object} → (A ≡ B) ≅ (A ≊ B)
|
2018-03-22 13:27:16 +00:00
|
|
|
|
|
2018-04-13 13:35:56 +00:00
|
|
|
|
private
|
|
|
|
|
-- | Equivalent formulation of univalence.
|
|
|
|
|
Univalent[Contr] : Set _
|
2018-04-19 10:20:44 +00:00
|
|
|
|
Univalent[Contr] = ∀ A → isContr (Σ[ X ∈ Object ] A ≊ X)
|
2018-04-13 13:35:56 +00:00
|
|
|
|
|
|
|
|
|
-- From: Thierry Coquand <Thierry.Coquand@cse.gu.se>
|
|
|
|
|
-- Date: Wed, Mar 21, 2018 at 3:12 PM
|
|
|
|
|
--
|
|
|
|
|
-- This is not so straight-forward so you can assume it
|
|
|
|
|
postulate from[Contr] : Univalent[Contr] → Univalent
|
|
|
|
|
|
|
|
|
|
univalenceFrom≃ : Univalent≃ → Univalent
|
|
|
|
|
univalenceFrom≃ = from[Contr] ∘ step
|
2018-04-10 15:17:04 +00:00
|
|
|
|
where
|
2018-04-13 13:35:56 +00:00
|
|
|
|
module _ (f : Univalent≃) (A : Object) where
|
2018-04-19 10:20:44 +00:00
|
|
|
|
lem : Σ Object (A ≡_) ≃ Σ Object (A ≊_)
|
2018-04-13 13:35:56 +00:00
|
|
|
|
lem = equivSig λ _ → f
|
2018-04-11 10:27:33 +00:00
|
|
|
|
|
2018-04-11 10:46:22 +00:00
|
|
|
|
aux : isContr (Σ Object (A ≡_))
|
|
|
|
|
aux = (A , refl) , (λ y → contrSingl (snd y))
|
2018-04-10 15:17:04 +00:00
|
|
|
|
|
2018-04-19 10:20:44 +00:00
|
|
|
|
step : isContr (Σ Object (A ≊_))
|
2018-04-11 11:18:34 +00:00
|
|
|
|
step = equivPreservesNType {n = ⟨-2⟩} lem aux
|
2018-04-10 15:17:04 +00:00
|
|
|
|
|
2018-04-19 10:20:44 +00:00
|
|
|
|
univalenceFrom≅ : Univalent≅ → Univalent
|
|
|
|
|
univalenceFrom≅ x = univalenceFrom≃ $ fromIsomorphism _ _ x
|
|
|
|
|
|
2018-04-09 14:03:43 +00:00
|
|
|
|
propUnivalent : isProp Univalent
|
|
|
|
|
propUnivalent a b i = propPi (λ iso → propIsContr) a b i
|
|
|
|
|
|
2018-04-06 15:09:15 +00:00
|
|
|
|
module _ {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where
|
|
|
|
|
record IsPreCategory : Set (lsuc (ℓa ⊔ ℓb)) where
|
|
|
|
|
open RawCategory ℂ public
|
|
|
|
|
field
|
|
|
|
|
isAssociative : IsAssociative
|
|
|
|
|
isIdentity : IsIdentity identity
|
|
|
|
|
arrowsAreSets : ArrowsAreSets
|
|
|
|
|
open Univalence isIdentity public
|
|
|
|
|
|
2018-04-11 08:58:50 +00:00
|
|
|
|
leftIdentity : {A B : Object} {f : Arrow A B} → identity <<< f ≡ f
|
2018-04-06 15:09:15 +00:00
|
|
|
|
leftIdentity {A} {B} {f} = fst (isIdentity {A = A} {B} {f})
|
|
|
|
|
|
2018-04-11 08:58:50 +00:00
|
|
|
|
rightIdentity : {A B : Object} {f : Arrow A B} → f <<< identity ≡ f
|
2018-04-06 15:09:15 +00:00
|
|
|
|
rightIdentity {A} {B} {f} = snd (isIdentity {A = A} {B} {f})
|
|
|
|
|
|
|
|
|
|
------------
|
|
|
|
|
-- Lemmas --
|
|
|
|
|
------------
|
|
|
|
|
|
|
|
|
|
-- | Relation between iso- epi- and mono- morphisms.
|
|
|
|
|
module _ {A B : Object} {X : Object} (f : Arrow A B) where
|
|
|
|
|
iso→epi : Isomorphism f → Epimorphism {X = X} f
|
|
|
|
|
iso→epi (f- , left-inv , right-inv) g₀ g₁ eq = begin
|
2018-04-11 08:58:50 +00:00
|
|
|
|
g₀ ≡⟨ sym rightIdentity ⟩
|
|
|
|
|
g₀ <<< identity ≡⟨ cong (_<<<_ g₀) (sym right-inv) ⟩
|
|
|
|
|
g₀ <<< (f <<< f-) ≡⟨ isAssociative ⟩
|
|
|
|
|
(g₀ <<< f) <<< f- ≡⟨ cong (λ φ → φ <<< f-) eq ⟩
|
|
|
|
|
(g₁ <<< f) <<< f- ≡⟨ sym isAssociative ⟩
|
|
|
|
|
g₁ <<< (f <<< f-) ≡⟨ cong (_<<<_ g₁) right-inv ⟩
|
|
|
|
|
g₁ <<< identity ≡⟨ rightIdentity ⟩
|
|
|
|
|
g₁ ∎
|
2018-04-06 15:09:15 +00:00
|
|
|
|
|
|
|
|
|
iso→mono : Isomorphism f → Monomorphism {X = X} f
|
|
|
|
|
iso→mono (f- , left-inv , right-inv) g₀ g₁ eq =
|
|
|
|
|
begin
|
2018-04-11 08:58:50 +00:00
|
|
|
|
g₀ ≡⟨ sym leftIdentity ⟩
|
|
|
|
|
identity <<< g₀ ≡⟨ cong (λ φ → φ <<< g₀) (sym left-inv) ⟩
|
|
|
|
|
(f- <<< f) <<< g₀ ≡⟨ sym isAssociative ⟩
|
|
|
|
|
f- <<< (f <<< g₀) ≡⟨ cong (_<<<_ f-) eq ⟩
|
|
|
|
|
f- <<< (f <<< g₁) ≡⟨ isAssociative ⟩
|
|
|
|
|
(f- <<< f) <<< g₁ ≡⟨ cong (λ φ → φ <<< g₁) left-inv ⟩
|
|
|
|
|
identity <<< g₁ ≡⟨ leftIdentity ⟩
|
|
|
|
|
g₁ ∎
|
2018-04-06 15:09:15 +00:00
|
|
|
|
|
|
|
|
|
iso→epi×mono : Isomorphism f → Epimorphism {X = X} f × Monomorphism {X = X} f
|
|
|
|
|
iso→epi×mono iso = iso→epi iso , iso→mono iso
|
|
|
|
|
|
|
|
|
|
propIsAssociative : isProp IsAssociative
|
|
|
|
|
propIsAssociative = propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl λ _ → arrowsAreSets _ _))))))
|
|
|
|
|
|
|
|
|
|
propIsIdentity : ∀ {f : ∀ {A} → Arrow A A} → isProp (IsIdentity f)
|
2018-04-09 14:03:43 +00:00
|
|
|
|
propIsIdentity {id} = propPiImpl (λ _ → propPiImpl λ _ → propPiImpl (λ f →
|
2018-04-11 08:58:50 +00:00
|
|
|
|
propSig (arrowsAreSets (id <<< f) f) λ _ → arrowsAreSets (f <<< id) f))
|
2018-04-06 15:09:15 +00:00
|
|
|
|
|
|
|
|
|
propArrowIsSet : isProp (∀ {A B} → isSet (Arrow A B))
|
|
|
|
|
propArrowIsSet = propPiImpl λ _ → propPiImpl (λ _ → isSetIsProp)
|
|
|
|
|
|
|
|
|
|
propIsInverseOf : ∀ {A B f g} → isProp (IsInverseOf {A} {B} f g)
|
|
|
|
|
propIsInverseOf = propSig (arrowsAreSets _ _) (λ _ → arrowsAreSets _ _)
|
|
|
|
|
|
2018-04-10 15:17:04 +00:00
|
|
|
|
module _ {A B : Object} (f : Arrow A B) where
|
|
|
|
|
propIsomorphism : isProp (Isomorphism f)
|
|
|
|
|
propIsomorphism a@(g , η , ε) a'@(g' , η' , ε') =
|
2018-04-06 15:09:15 +00:00
|
|
|
|
lemSig (λ g → propIsInverseOf) a a' geq
|
|
|
|
|
where
|
|
|
|
|
geq : g ≡ g'
|
|
|
|
|
geq = begin
|
2018-04-11 08:58:50 +00:00
|
|
|
|
g ≡⟨ sym rightIdentity ⟩
|
|
|
|
|
g <<< identity ≡⟨ cong (λ φ → g <<< φ) (sym ε') ⟩
|
|
|
|
|
g <<< (f <<< g') ≡⟨ isAssociative ⟩
|
|
|
|
|
(g <<< f) <<< g' ≡⟨ cong (λ φ → φ <<< g') η ⟩
|
|
|
|
|
identity <<< g' ≡⟨ leftIdentity ⟩
|
|
|
|
|
g' ∎
|
2018-04-06 15:09:15 +00:00
|
|
|
|
|
|
|
|
|
propIsInitial : ∀ I → isProp (IsInitial I)
|
|
|
|
|
propIsInitial I x y i {X} = res X i
|
2018-03-29 12:26:47 +00:00
|
|
|
|
where
|
2018-04-06 15:09:15 +00:00
|
|
|
|
module _ (X : Object) where
|
|
|
|
|
open Σ (x {X}) renaming (fst to fx ; snd to cx)
|
|
|
|
|
open Σ (y {X}) renaming (fst to fy ; snd to cy)
|
|
|
|
|
fp : fx ≡ fy
|
|
|
|
|
fp = cx fy
|
|
|
|
|
prop : (x : Arrow I X) → isProp (∀ f → x ≡ f)
|
|
|
|
|
prop x = propPi (λ y → arrowsAreSets x y)
|
|
|
|
|
cp : (λ i → ∀ f → fp i ≡ f) [ cx ≡ cy ]
|
|
|
|
|
cp = lemPropF prop fp
|
|
|
|
|
res : (fx , cx) ≡ (fy , cy)
|
|
|
|
|
res i = fp i , cp i
|
|
|
|
|
|
|
|
|
|
propIsTerminal : ∀ T → isProp (IsTerminal T)
|
|
|
|
|
propIsTerminal T x y i {X} = res X i
|
2018-03-29 12:31:03 +00:00
|
|
|
|
where
|
2018-04-06 15:09:15 +00:00
|
|
|
|
module _ (X : Object) where
|
|
|
|
|
open Σ (x {X}) renaming (fst to fx ; snd to cx)
|
|
|
|
|
open Σ (y {X}) renaming (fst to fy ; snd to cy)
|
|
|
|
|
fp : fx ≡ fy
|
|
|
|
|
fp = cx fy
|
|
|
|
|
prop : (x : Arrow X T) → isProp (∀ f → x ≡ f)
|
|
|
|
|
prop x = propPi (λ y → arrowsAreSets x y)
|
|
|
|
|
cp : (λ i → ∀ f → fp i ≡ f) [ cx ≡ cy ]
|
|
|
|
|
cp = lemPropF prop fp
|
|
|
|
|
res : (fx , cx) ≡ (fy , cy)
|
|
|
|
|
res i = fp i , cp i
|
|
|
|
|
|
|
|
|
|
module _ where
|
|
|
|
|
private
|
2018-04-19 10:20:44 +00:00
|
|
|
|
trans≊ : Transitive _≊_
|
|
|
|
|
trans≊ (f , f~ , f-inv) (g , g~ , g-inv)
|
2018-04-11 08:58:50 +00:00
|
|
|
|
= g <<< f
|
|
|
|
|
, f~ <<< g~
|
2018-04-06 15:09:15 +00:00
|
|
|
|
, ( begin
|
2018-04-11 08:58:50 +00:00
|
|
|
|
(f~ <<< g~) <<< (g <<< f) ≡⟨ isAssociative ⟩
|
|
|
|
|
(f~ <<< g~) <<< g <<< f ≡⟨ cong (λ φ → φ <<< f) (sym isAssociative) ⟩
|
|
|
|
|
f~ <<< (g~ <<< g) <<< f ≡⟨ cong (λ φ → f~ <<< φ <<< f) (fst g-inv) ⟩
|
|
|
|
|
f~ <<< identity <<< f ≡⟨ cong (λ φ → φ <<< f) rightIdentity ⟩
|
|
|
|
|
f~ <<< f ≡⟨ fst f-inv ⟩
|
|
|
|
|
identity ∎
|
2018-04-06 15:09:15 +00:00
|
|
|
|
)
|
|
|
|
|
, ( begin
|
2018-04-11 08:58:50 +00:00
|
|
|
|
g <<< f <<< (f~ <<< g~) ≡⟨ isAssociative ⟩
|
|
|
|
|
g <<< f <<< f~ <<< g~ ≡⟨ cong (λ φ → φ <<< g~) (sym isAssociative) ⟩
|
|
|
|
|
g <<< (f <<< f~) <<< g~ ≡⟨ cong (λ φ → g <<< φ <<< g~) (snd f-inv) ⟩
|
|
|
|
|
g <<< identity <<< g~ ≡⟨ cong (λ φ → φ <<< g~) rightIdentity ⟩
|
|
|
|
|
g <<< g~ ≡⟨ snd g-inv ⟩
|
|
|
|
|
identity ∎
|
2018-04-06 15:09:15 +00:00
|
|
|
|
)
|
2018-04-19 10:20:44 +00:00
|
|
|
|
isPreorder : IsPreorder _≊_
|
|
|
|
|
isPreorder = record { isEquivalence = equalityIsEquivalence ; reflexive = idToIso _ _ ; trans = trans≊ }
|
2018-04-06 15:09:15 +00:00
|
|
|
|
|
2018-04-19 10:20:44 +00:00
|
|
|
|
preorder≊ : Preorder _ _ _
|
|
|
|
|
preorder≊ = record { Carrier = Object ; _≈_ = _≡_ ; _∼_ = _≊_ ; isPreorder = isPreorder }
|
2018-04-06 15:09:15 +00:00
|
|
|
|
|
|
|
|
|
record PreCategory : Set (lsuc (ℓa ⊔ ℓb)) where
|
|
|
|
|
field
|
|
|
|
|
isPreCategory : IsPreCategory
|
|
|
|
|
open IsPreCategory isPreCategory public
|
|
|
|
|
|
|
|
|
|
-- Definition 9.6.1 in [HoTT]
|
|
|
|
|
record StrictCategory : Set (lsuc (ℓa ⊔ ℓb)) where
|
|
|
|
|
field
|
|
|
|
|
preCategory : PreCategory
|
|
|
|
|
open PreCategory preCategory
|
|
|
|
|
field
|
|
|
|
|
objectsAreSets : isSet Object
|
|
|
|
|
|
|
|
|
|
record IsCategory : Set (lsuc (ℓa ⊔ ℓb)) where
|
|
|
|
|
field
|
|
|
|
|
isPreCategory : IsPreCategory
|
|
|
|
|
open IsPreCategory isPreCategory public
|
|
|
|
|
field
|
|
|
|
|
univalent : Univalent
|
|
|
|
|
|
|
|
|
|
-- | The formulation of univalence expressed with _≃_ is trivially admissable -
|
|
|
|
|
-- just "forget" the equivalence.
|
|
|
|
|
univalent≃ : Univalent≃
|
|
|
|
|
univalent≃ = _ , univalent
|
|
|
|
|
|
|
|
|
|
module _ {A B : Object} where
|
2018-04-10 15:17:04 +00:00
|
|
|
|
private
|
|
|
|
|
iso : TypeIsomorphism (idToIso A B)
|
|
|
|
|
iso = toIso _ _ univalent
|
|
|
|
|
|
2018-04-19 10:20:44 +00:00
|
|
|
|
isoToId : (A ≊ B) → (A ≡ B)
|
2018-04-10 15:17:04 +00:00
|
|
|
|
isoToId = fst iso
|
2018-04-06 15:09:15 +00:00
|
|
|
|
|
2018-04-09 16:02:39 +00:00
|
|
|
|
asTypeIso : TypeIsomorphism (idToIso A B)
|
|
|
|
|
asTypeIso = toIso _ _ univalent
|
|
|
|
|
|
2018-04-13 11:24:17 +00:00
|
|
|
|
-- FIXME Rename
|
2018-04-10 15:17:04 +00:00
|
|
|
|
inverse-from-to-iso' : AreInverses (idToIso A B) isoToId
|
|
|
|
|
inverse-from-to-iso' = snd iso
|
|
|
|
|
|
2018-04-19 10:20:44 +00:00
|
|
|
|
module _ {a b : Object} (f : Arrow a b) where
|
|
|
|
|
module _ {a' : Object} (p : a ≡ a') where
|
|
|
|
|
private
|
|
|
|
|
p~ : Arrow a' a
|
|
|
|
|
p~ = fst (snd (idToIso _ _ p))
|
|
|
|
|
|
|
|
|
|
D : ∀ a'' → a ≡ a'' → Set _
|
|
|
|
|
D a'' p' = coe (cong (λ x → Arrow x b) p') f ≡ f <<< (fst (snd (idToIso _ _ p')))
|
|
|
|
|
|
|
|
|
|
9-1-9-left : coe (cong (λ x → Arrow x b) p) f ≡ f <<< p~
|
|
|
|
|
9-1-9-left = pathJ D (begin
|
|
|
|
|
coe refl f ≡⟨ id-coe ⟩
|
|
|
|
|
f ≡⟨ sym rightIdentity ⟩
|
|
|
|
|
f <<< identity ≡⟨ cong (f <<<_) (sym subst-neutral) ⟩
|
2018-04-23 15:04:27 +00:00
|
|
|
|
f <<< _ ≡⟨ {!!} ⟩ _ ∎) a' p
|
2018-04-19 10:20:44 +00:00
|
|
|
|
|
|
|
|
|
module _ {b' : Object} (p : b ≡ b') where
|
|
|
|
|
private
|
|
|
|
|
p* : Arrow b b'
|
|
|
|
|
p* = fst (idToIso _ _ p)
|
|
|
|
|
|
|
|
|
|
D : ∀ b'' → b ≡ b'' → Set _
|
|
|
|
|
D b'' p' = coe (cong (λ x → Arrow a x) p') f ≡ fst (idToIso _ _ p') <<< f
|
|
|
|
|
|
|
|
|
|
9-1-9-right : coe (cong (λ x → Arrow a x) p) f ≡ p* <<< f
|
|
|
|
|
9-1-9-right = pathJ D (begin
|
|
|
|
|
coe refl f ≡⟨ id-coe ⟩
|
|
|
|
|
f ≡⟨ sym leftIdentity ⟩
|
|
|
|
|
identity <<< f ≡⟨ cong (_<<< f) (sym subst-neutral) ⟩
|
|
|
|
|
_ <<< f ∎) b' p
|
|
|
|
|
|
|
|
|
|
-- lemma 9.1.9 in hott
|
2018-04-10 15:33:22 +00:00
|
|
|
|
module _ {a a' b b' : Object}
|
|
|
|
|
(p : a ≡ a') (q : b ≡ b') (f : Arrow a b)
|
|
|
|
|
where
|
|
|
|
|
private
|
2018-04-19 10:20:44 +00:00
|
|
|
|
q* : Arrow b b'
|
|
|
|
|
q* = fst (idToIso _ _ q)
|
|
|
|
|
q~ : Arrow b' b
|
|
|
|
|
q~ = fst (snd (idToIso _ _ q))
|
|
|
|
|
p* : Arrow a a'
|
2018-04-12 09:21:05 +00:00
|
|
|
|
p* = fst (idToIso _ _ p)
|
2018-04-10 15:33:22 +00:00
|
|
|
|
p~ : Arrow a' a
|
|
|
|
|
p~ = fst (snd (idToIso _ _ p))
|
|
|
|
|
pq : Arrow a b ≡ Arrow a' b'
|
|
|
|
|
pq i = Arrow (p i) (q i)
|
|
|
|
|
|
2018-04-13 07:40:09 +00:00
|
|
|
|
U : ∀ b'' → b ≡ b'' → Set _
|
|
|
|
|
U b'' q' = coe (λ i → Arrow a (q' i)) f ≡ fst (idToIso _ _ q') <<< f <<< (fst (snd (idToIso _ _ refl)))
|
|
|
|
|
u : coe (λ i → Arrow a b) f ≡ fst (idToIso _ _ refl) <<< f <<< (fst (snd (idToIso _ _ refl)))
|
|
|
|
|
u = begin
|
|
|
|
|
coe refl f ≡⟨ id-coe ⟩
|
|
|
|
|
f ≡⟨ sym leftIdentity ⟩
|
|
|
|
|
identity <<< f ≡⟨ sym rightIdentity ⟩
|
|
|
|
|
identity <<< f <<< identity ≡⟨ cong (λ φ → identity <<< f <<< φ) lem ⟩
|
|
|
|
|
identity <<< f <<< (fst (snd (idToIso _ _ refl))) ≡⟨ cong (λ φ → φ <<< f <<< (fst (snd (idToIso _ _ refl)))) lem ⟩
|
|
|
|
|
fst (idToIso _ _ refl) <<< f <<< (fst (snd (idToIso _ _ refl))) ∎
|
|
|
|
|
where
|
|
|
|
|
lem : ∀ {x} → PathP (λ _ → Arrow x x) identity (fst (idToIso x x refl))
|
|
|
|
|
lem = sym subst-neutral
|
2018-04-12 08:05:02 +00:00
|
|
|
|
|
2018-04-13 07:40:09 +00:00
|
|
|
|
D : ∀ a'' → a ≡ a'' → Set _
|
|
|
|
|
D a'' p' = coe (λ i → Arrow (p' i) (q i)) f ≡ fst (idToIso b b' q) <<< f <<< (fst (snd (idToIso _ _ p')))
|
2018-04-12 08:05:02 +00:00
|
|
|
|
|
2018-04-13 07:40:09 +00:00
|
|
|
|
d : coe (λ i → Arrow a (q i)) f ≡ fst (idToIso b b' q) <<< f <<< (fst (snd (idToIso _ _ refl)))
|
|
|
|
|
d = pathJ U u b' q
|
2018-04-12 08:05:02 +00:00
|
|
|
|
|
2018-04-11 08:58:50 +00:00
|
|
|
|
9-1-9 : coe pq f ≡ q* <<< f <<< p~
|
2018-04-12 08:05:02 +00:00
|
|
|
|
9-1-9 = pathJ D d a' p
|
2018-04-10 15:33:22 +00:00
|
|
|
|
|
2018-04-12 09:21:05 +00:00
|
|
|
|
9-1-9' : coe pq f <<< p* ≡ q* <<< f
|
|
|
|
|
9-1-9' = begin
|
|
|
|
|
coe pq f <<< p* ≡⟨ cong (_<<< p*) 9-1-9 ⟩
|
|
|
|
|
q* <<< f <<< p~ <<< p* ≡⟨ sym isAssociative ⟩
|
|
|
|
|
q* <<< f <<< (p~ <<< p*) ≡⟨ cong (λ φ → q* <<< f <<< φ) lem ⟩
|
|
|
|
|
q* <<< f <<< identity ≡⟨ rightIdentity ⟩
|
|
|
|
|
q* <<< f ∎
|
|
|
|
|
where
|
|
|
|
|
lem : p~ <<< p* ≡ identity
|
|
|
|
|
lem = fst (snd (snd (idToIso _ _ p)))
|
2018-04-19 10:20:44 +00:00
|
|
|
|
|
|
|
|
|
module _ {A B X : Object} (iso : A ≊ B) where
|
2018-04-13 11:24:17 +00:00
|
|
|
|
private
|
|
|
|
|
p : A ≡ B
|
|
|
|
|
p = isoToId iso
|
|
|
|
|
p-dom : Arrow A X ≡ Arrow B X
|
|
|
|
|
p-dom = cong (λ x → Arrow x X) p
|
|
|
|
|
p-cod : Arrow X A ≡ Arrow X B
|
|
|
|
|
p-cod = cong (λ x → Arrow X x) p
|
2018-04-19 10:20:44 +00:00
|
|
|
|
lem : ∀ {A B} {x : A ≊ B} → idToIso A B (isoToId x) ≡ x
|
2018-04-13 11:24:17 +00:00
|
|
|
|
lem {x = x} i = snd inverse-from-to-iso' i x
|
|
|
|
|
|
|
|
|
|
open Σ iso renaming (fst to ι) using ()
|
|
|
|
|
open Σ (snd iso) renaming (fst to ι~ ; snd to inv)
|
|
|
|
|
|
|
|
|
|
coe-dom : {f : Arrow A X} → coe p-dom f ≡ f <<< ι~
|
|
|
|
|
coe-dom {f} = begin
|
2018-04-23 15:04:27 +00:00
|
|
|
|
coe p-dom f ≡⟨ 9-1-9-left f p ⟩
|
|
|
|
|
f <<< fst (snd (idToIso _ _ (isoToId iso))) ≡⟨⟩
|
|
|
|
|
f <<< fst (snd (idToIso _ _ p)) ≡⟨ cong (f <<<_) (cong (fst ∘ snd) lem) ⟩
|
2018-04-13 11:24:17 +00:00
|
|
|
|
f <<< ι~ ∎
|
|
|
|
|
|
|
|
|
|
coe-cod : {f : Arrow X A} → coe p-cod f ≡ ι <<< f
|
|
|
|
|
coe-cod {f} = begin
|
|
|
|
|
coe p-cod f
|
2018-04-23 15:04:27 +00:00
|
|
|
|
≡⟨ 9-1-9-right f p ⟩
|
|
|
|
|
fst (idToIso _ _ p) <<< f
|
|
|
|
|
≡⟨ cong (λ φ → φ <<< f) (cong fst lem) ⟩
|
2018-04-13 11:24:17 +00:00
|
|
|
|
ι <<< f ∎
|
|
|
|
|
|
|
|
|
|
module _ {f : Arrow A X} {g : Arrow B X} (q : PathP (λ i → p-dom i) f g) where
|
|
|
|
|
domain-twist : g ≡ f <<< ι~
|
|
|
|
|
domain-twist = begin
|
|
|
|
|
g ≡⟨ sym (coe-lem q) ⟩
|
|
|
|
|
coe p-dom f ≡⟨ coe-dom ⟩
|
|
|
|
|
f <<< ι~ ∎
|
|
|
|
|
|
|
|
|
|
-- This can probably also just be obtained from the above my taking the
|
|
|
|
|
-- symmetric isomorphism.
|
2018-04-26 08:20:57 +00:00
|
|
|
|
domain-twist-sym : f ≡ g <<< ι
|
|
|
|
|
domain-twist-sym = begin
|
2018-04-13 11:24:17 +00:00
|
|
|
|
f ≡⟨ sym rightIdentity ⟩
|
|
|
|
|
f <<< identity ≡⟨ cong (f <<<_) (sym (fst inv)) ⟩
|
|
|
|
|
f <<< (ι~ <<< ι) ≡⟨ isAssociative ⟩
|
|
|
|
|
f <<< ι~ <<< ι ≡⟨ cong (_<<< ι) (sym domain-twist) ⟩
|
|
|
|
|
g <<< ι ∎
|
2018-04-12 09:21:05 +00:00
|
|
|
|
|
2018-04-06 15:09:15 +00:00
|
|
|
|
-- | All projections are propositions.
|
|
|
|
|
module Propositionality where
|
|
|
|
|
-- | Terminal objects are propositional - a.k.a uniqueness of terminal
|
|
|
|
|
-- | objects.
|
|
|
|
|
--
|
|
|
|
|
-- Having two terminal objects induces an isomorphism between them - and
|
|
|
|
|
-- because of univalence this is equivalent to equality.
|
|
|
|
|
propTerminal : isProp Terminal
|
|
|
|
|
propTerminal Xt Yt = res
|
|
|
|
|
where
|
|
|
|
|
open Σ Xt renaming (fst to X ; snd to Xit)
|
|
|
|
|
open Σ Yt renaming (fst to Y ; snd to Yit)
|
|
|
|
|
open Σ (Xit {Y}) renaming (fst to Y→X) using ()
|
|
|
|
|
open Σ (Yit {X}) renaming (fst to X→Y) using ()
|
|
|
|
|
-- Need to show `left` and `right`, what we know is that the arrows are
|
|
|
|
|
-- unique. Well, I know that if I compose these two arrows they must give
|
|
|
|
|
-- the identity, since also the identity is the unique such arrow (by X
|
|
|
|
|
-- and Y both being terminal objects.)
|
|
|
|
|
Xprop : isProp (Arrow X X)
|
|
|
|
|
Xprop f g = trans (sym (snd Xit f)) (snd Xit g)
|
|
|
|
|
Yprop : isProp (Arrow Y Y)
|
|
|
|
|
Yprop f g = trans (sym (snd Yit f)) (snd Yit g)
|
2018-04-11 08:58:50 +00:00
|
|
|
|
left : Y→X <<< X→Y ≡ identity
|
2018-04-06 15:09:15 +00:00
|
|
|
|
left = Xprop _ _
|
2018-04-11 08:58:50 +00:00
|
|
|
|
right : X→Y <<< Y→X ≡ identity
|
2018-04-06 15:09:15 +00:00
|
|
|
|
right = Yprop _ _
|
2018-04-19 10:20:44 +00:00
|
|
|
|
iso : X ≊ Y
|
2018-04-06 15:09:15 +00:00
|
|
|
|
iso = X→Y , Y→X , left , right
|
|
|
|
|
p0 : X ≡ Y
|
2018-04-10 15:17:04 +00:00
|
|
|
|
p0 = isoToId iso
|
2018-04-06 15:09:15 +00:00
|
|
|
|
p1 : (λ i → IsTerminal (p0 i)) [ Xit ≡ Yit ]
|
|
|
|
|
p1 = lemPropF propIsTerminal p0
|
|
|
|
|
res : Xt ≡ Yt
|
|
|
|
|
res i = p0 i , p1 i
|
|
|
|
|
|
|
|
|
|
-- Merely the dual of the above statement.
|
|
|
|
|
|
|
|
|
|
propInitial : isProp Initial
|
|
|
|
|
propInitial Xi Yi = res
|
|
|
|
|
where
|
|
|
|
|
open Σ Xi renaming (fst to X ; snd to Xii)
|
|
|
|
|
open Σ Yi renaming (fst to Y ; snd to Yii)
|
|
|
|
|
open Σ (Xii {Y}) renaming (fst to Y→X) using ()
|
|
|
|
|
open Σ (Yii {X}) renaming (fst to X→Y) using ()
|
|
|
|
|
-- Need to show `left` and `right`, what we know is that the arrows are
|
|
|
|
|
-- unique. Well, I know that if I compose these two arrows they must give
|
|
|
|
|
-- the identity, since also the identity is the unique such arrow (by X
|
|
|
|
|
-- and Y both being terminal objects.)
|
|
|
|
|
Xprop : isProp (Arrow X X)
|
|
|
|
|
Xprop f g = trans (sym (snd Xii f)) (snd Xii g)
|
|
|
|
|
Yprop : isProp (Arrow Y Y)
|
|
|
|
|
Yprop f g = trans (sym (snd Yii f)) (snd Yii g)
|
2018-04-11 08:58:50 +00:00
|
|
|
|
left : Y→X <<< X→Y ≡ identity
|
2018-04-06 15:09:15 +00:00
|
|
|
|
left = Yprop _ _
|
2018-04-11 08:58:50 +00:00
|
|
|
|
right : X→Y <<< Y→X ≡ identity
|
2018-04-06 15:09:15 +00:00
|
|
|
|
right = Xprop _ _
|
2018-04-19 10:20:44 +00:00
|
|
|
|
iso : X ≊ Y
|
2018-04-06 15:09:15 +00:00
|
|
|
|
iso = Y→X , X→Y , right , left
|
|
|
|
|
res : Xi ≡ Yi
|
2018-04-10 15:17:04 +00:00
|
|
|
|
res = lemSig propIsInitial _ _ (isoToId iso)
|
2018-04-06 15:09:15 +00:00
|
|
|
|
|
2018-04-13 13:22:13 +00:00
|
|
|
|
groupoidObject : isGrpd Object
|
|
|
|
|
groupoidObject A B = res
|
|
|
|
|
where
|
|
|
|
|
open import Data.Nat using (_≤_ ; z≤n ; s≤s)
|
|
|
|
|
setIso : ∀ x → isSet (Isomorphism x)
|
|
|
|
|
setIso x = ntypeCommulative ((s≤s {n = 1} z≤n)) (propIsomorphism x)
|
2018-04-19 10:20:44 +00:00
|
|
|
|
step : isSet (A ≊ B)
|
2018-04-13 13:22:13 +00:00
|
|
|
|
step = setSig {sA = arrowsAreSets} {sB = setIso}
|
|
|
|
|
res : isSet (A ≡ B)
|
|
|
|
|
res = equivPreservesNType
|
2018-04-19 10:20:44 +00:00
|
|
|
|
{A = A ≊ B} {B = A ≡ B} {n = ⟨0⟩}
|
2018-04-13 13:22:13 +00:00
|
|
|
|
(Equivalence.symmetry (univalent≃ {A = A} {B}))
|
|
|
|
|
step
|
|
|
|
|
|
2018-03-21 11:17:10 +00:00
|
|
|
|
module _ {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where
|
|
|
|
|
open RawCategory ℂ
|
|
|
|
|
open Univalence
|
2018-02-20 15:42:56 +00:00
|
|
|
|
private
|
2018-04-05 12:37:25 +00:00
|
|
|
|
module _ (x y : IsPreCategory ℂ) where
|
|
|
|
|
module x = IsPreCategory x
|
|
|
|
|
module y = IsPreCategory y
|
|
|
|
|
-- In a few places I use the result of propositionality of the various
|
|
|
|
|
-- projections of `IsCategory` - Here I arbitrarily chose to use this
|
|
|
|
|
-- result from `x : IsCategory C`. I don't know which (if any) possibly
|
|
|
|
|
-- adverse effects this may have.
|
|
|
|
|
-- module Prop = X.Propositionality
|
|
|
|
|
|
|
|
|
|
propIsPreCategory : x ≡ y
|
|
|
|
|
IsPreCategory.isAssociative (propIsPreCategory i)
|
|
|
|
|
= x.propIsAssociative x.isAssociative y.isAssociative i
|
|
|
|
|
IsPreCategory.isIdentity (propIsPreCategory i)
|
|
|
|
|
= x.propIsIdentity x.isIdentity y.isIdentity i
|
|
|
|
|
IsPreCategory.arrowsAreSets (propIsPreCategory i)
|
|
|
|
|
= x.propArrowIsSet x.arrowsAreSets y.arrowsAreSets i
|
|
|
|
|
|
2018-03-12 12:51:29 +00:00
|
|
|
|
module _ (x y : IsCategory ℂ) where
|
2018-02-20 15:42:56 +00:00
|
|
|
|
module X = IsCategory x
|
|
|
|
|
module Y = IsCategory y
|
2018-02-20 16:59:48 +00:00
|
|
|
|
-- In a few places I use the result of propositionality of the various
|
2018-03-21 11:17:10 +00:00
|
|
|
|
-- projections of `IsCategory` - Here I arbitrarily chose to use this
|
2018-02-20 16:59:48 +00:00
|
|
|
|
-- result from `x : IsCategory C`. I don't know which (if any) possibly
|
|
|
|
|
-- adverse effects this may have.
|
2018-03-21 11:17:10 +00:00
|
|
|
|
module Prop = X.Propositionality
|
|
|
|
|
|
2018-04-09 14:03:43 +00:00
|
|
|
|
isIdentity= : (λ _ → IsIdentity identity) [ X.isIdentity ≡ Y.isIdentity ]
|
|
|
|
|
isIdentity= = X.propIsIdentity X.isIdentity Y.isIdentity
|
|
|
|
|
|
|
|
|
|
isPreCategory= : X.isPreCategory ≡ Y.isPreCategory
|
|
|
|
|
isPreCategory= = propIsPreCategory X.isPreCategory Y.isPreCategory
|
|
|
|
|
|
|
|
|
|
private
|
|
|
|
|
p = cong IsPreCategory.isIdentity isPreCategory=
|
|
|
|
|
|
|
|
|
|
univalent= : (λ i → Univalent (p i))
|
|
|
|
|
[ X.univalent ≡ Y.univalent ]
|
|
|
|
|
univalent= = lemPropF
|
|
|
|
|
{A = IsIdentity identity}
|
|
|
|
|
{B = Univalent}
|
|
|
|
|
propUnivalent
|
|
|
|
|
{a0 = X.isIdentity}
|
|
|
|
|
{a1 = Y.isIdentity}
|
|
|
|
|
p
|
|
|
|
|
|
2018-03-12 12:36:55 +00:00
|
|
|
|
done : x ≡ y
|
2018-04-09 14:03:43 +00:00
|
|
|
|
IsCategory.isPreCategory (done i) = isPreCategory= i
|
|
|
|
|
IsCategory.univalent (done i) = univalent= i
|
2018-02-07 19:19:17 +00:00
|
|
|
|
|
2018-03-12 12:51:29 +00:00
|
|
|
|
propIsCategory : isProp (IsCategory ℂ)
|
2018-02-20 15:42:56 +00:00
|
|
|
|
propIsCategory = done
|
2018-01-21 13:31:37 +00:00
|
|
|
|
|
2018-04-06 16:27:24 +00:00
|
|
|
|
|
2018-02-25 14:21:38 +00:00
|
|
|
|
-- | Univalent categories
|
|
|
|
|
--
|
2018-03-12 12:36:55 +00:00
|
|
|
|
-- Just bundles up the data with witnesses inhabiting the propositions.
|
2018-04-06 16:27:24 +00:00
|
|
|
|
|
|
|
|
|
-- Question: Should I remove the type `Category`?
|
2018-02-05 13:47:15 +00:00
|
|
|
|
record Category (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where
|
|
|
|
|
field
|
2018-03-12 12:36:55 +00:00
|
|
|
|
raw : RawCategory ℓa ℓb
|
2018-02-05 13:47:15 +00:00
|
|
|
|
{{isCategory}} : IsCategory raw
|
2018-02-05 10:43:38 +00:00
|
|
|
|
|
2018-02-21 12:37:07 +00:00
|
|
|
|
open IsCategory isCategory public
|
2018-02-05 10:43:38 +00:00
|
|
|
|
|
2018-03-12 12:36:55 +00:00
|
|
|
|
-- The fact that being a category is a mere proposition gives rise to this
|
|
|
|
|
-- equality principle for categories.
|
|
|
|
|
module _ {ℓa ℓb : Level} {ℂ 𝔻 : Category ℓa ℓb} where
|
|
|
|
|
private
|
|
|
|
|
module ℂ = Category ℂ
|
|
|
|
|
module 𝔻 = Category 𝔻
|
|
|
|
|
|
|
|
|
|
module _ (rawEq : ℂ.raw ≡ 𝔻.raw) where
|
|
|
|
|
private
|
|
|
|
|
isCategoryEq : (λ i → IsCategory (rawEq i)) [ ℂ.isCategory ≡ 𝔻.isCategory ]
|
2018-04-09 14:03:43 +00:00
|
|
|
|
isCategoryEq = lemPropF {A = RawCategory _ _} {B = IsCategory} propIsCategory rawEq
|
2018-03-12 12:36:55 +00:00
|
|
|
|
|
|
|
|
|
Category≡ : ℂ ≡ 𝔻
|
2018-04-06 16:27:24 +00:00
|
|
|
|
Category.raw (Category≡ i) = rawEq i
|
|
|
|
|
Category.isCategory (Category≡ i) = isCategoryEq i
|
2018-03-08 00:09:40 +00:00
|
|
|
|
|
2018-02-25 14:21:38 +00:00
|
|
|
|
-- | Syntax for arrows- and composition in a given category.
|
2018-02-21 12:37:07 +00:00
|
|
|
|
module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
|
|
|
|
open Category ℂ
|
2018-02-05 11:21:39 +00:00
|
|
|
|
_[_,_] : (A : Object) → (B : Object) → Set ℓb
|
2018-02-20 15:25:49 +00:00
|
|
|
|
_[_,_] = Arrow
|
2017-11-10 15:00:00 +00:00
|
|
|
|
|
2018-02-20 15:25:49 +00:00
|
|
|
|
_[_∘_] : {A B C : Object} → (g : Arrow B C) → (f : Arrow A B) → Arrow A C
|
2018-04-11 08:58:50 +00:00
|
|
|
|
_[_∘_] = _<<<_
|
2017-11-10 15:00:00 +00:00
|
|
|
|
|
2018-02-25 14:21:38 +00:00
|
|
|
|
-- | The opposite category
|
|
|
|
|
--
|
|
|
|
|
-- The opposite category is the category where the direction of the arrows are
|
|
|
|
|
-- flipped.
|
|
|
|
|
module Opposite {ℓa ℓb : Level} where
|
|
|
|
|
module _ (ℂ : Category ℓa ℓb) where
|
|
|
|
|
private
|
2018-04-05 12:37:25 +00:00
|
|
|
|
module _ where
|
|
|
|
|
module ℂ = Category ℂ
|
|
|
|
|
opRaw : RawCategory ℓa ℓb
|
|
|
|
|
RawCategory.Object opRaw = ℂ.Object
|
2018-04-11 09:10:33 +00:00
|
|
|
|
RawCategory.Arrow opRaw = flip ℂ.Arrow
|
2018-04-05 12:37:25 +00:00
|
|
|
|
RawCategory.identity opRaw = ℂ.identity
|
2018-04-11 08:58:50 +00:00
|
|
|
|
RawCategory._<<<_ opRaw = ℂ._>>>_
|
2018-04-05 12:37:25 +00:00
|
|
|
|
|
|
|
|
|
open RawCategory opRaw
|
2018-03-05 15:10:27 +00:00
|
|
|
|
|
2018-04-05 12:37:25 +00:00
|
|
|
|
isPreCategory : IsPreCategory opRaw
|
|
|
|
|
IsPreCategory.isAssociative isPreCategory = sym ℂ.isAssociative
|
2018-04-09 14:03:43 +00:00
|
|
|
|
IsPreCategory.isIdentity isPreCategory = swap ℂ.isIdentity
|
2018-04-05 12:37:25 +00:00
|
|
|
|
IsPreCategory.arrowsAreSets isPreCategory = ℂ.arrowsAreSets
|
2018-03-05 15:10:27 +00:00
|
|
|
|
|
2018-04-05 12:37:25 +00:00
|
|
|
|
open IsPreCategory isPreCategory
|
2018-03-20 14:19:28 +00:00
|
|
|
|
|
2018-03-05 15:10:27 +00:00
|
|
|
|
module _ {A B : ℂ.Object} where
|
2018-04-09 16:10:39 +00:00
|
|
|
|
k : TypeIsomorphism (ℂ.idToIso A B)
|
2018-04-06 16:27:24 +00:00
|
|
|
|
k = toIso _ _ ℂ.univalent
|
2018-04-09 16:02:39 +00:00
|
|
|
|
open Σ k renaming (fst to η ; snd to inv-η)
|
2018-04-11 11:53:33 +00:00
|
|
|
|
open AreInverses {f = ℂ.idToIso A B} {η} inv-η
|
2018-03-26 12:11:15 +00:00
|
|
|
|
|
2018-04-09 16:02:39 +00:00
|
|
|
|
genericly : {ℓa ℓb ℓc : Level} {a : Set ℓa} {b : Set ℓb} {c : Set ℓc}
|
|
|
|
|
→ a × b × c → b × a × c
|
|
|
|
|
genericly (a , b , c) = (b , a , c)
|
|
|
|
|
|
2018-04-19 10:20:44 +00:00
|
|
|
|
shuffle : A ≊ B → A ℂ.≊ B
|
2018-04-09 16:02:39 +00:00
|
|
|
|
shuffle (f , g , inv) = g , f , inv
|
2018-03-26 12:11:15 +00:00
|
|
|
|
|
2018-04-19 10:20:44 +00:00
|
|
|
|
shuffle~ : A ℂ.≊ B → A ≊ B
|
2018-04-09 16:02:39 +00:00
|
|
|
|
shuffle~ (f , g , inv) = g , f , inv
|
2018-03-26 12:11:15 +00:00
|
|
|
|
|
|
|
|
|
-- Shouldn't be necessary to use `arrowsAreSets` here, but we have it,
|
|
|
|
|
-- so why not?
|
2018-04-09 16:02:39 +00:00
|
|
|
|
lem : (p : A ≡ B) → idToIso A B p ≡ shuffle~ (ℂ.idToIso A B p)
|
|
|
|
|
lem p = Σ≡ refl (Σ≡ refl (Σ≡ (ℂ.arrowsAreSets _ _ l-l r-l) (ℂ.arrowsAreSets _ _ l-r r-r)))
|
2018-03-26 12:11:15 +00:00
|
|
|
|
where
|
2018-04-05 13:21:54 +00:00
|
|
|
|
l = idToIso A B p
|
2018-04-09 16:02:39 +00:00
|
|
|
|
r = shuffle~ (ℂ.idToIso A B p)
|
2018-04-05 08:41:56 +00:00
|
|
|
|
open Σ l renaming (fst to l-obv ; snd to l-areInv)
|
|
|
|
|
open Σ l-areInv renaming (fst to l-invs ; snd to l-iso)
|
|
|
|
|
open Σ l-iso renaming (fst to l-l ; snd to l-r)
|
|
|
|
|
open Σ r renaming (fst to r-obv ; snd to r-areInv)
|
|
|
|
|
open Σ r-areInv renaming (fst to r-invs ; snd to r-iso)
|
|
|
|
|
open Σ r-iso renaming (fst to r-l ; snd to r-r)
|
2018-04-09 16:02:39 +00:00
|
|
|
|
|
2018-04-19 10:20:44 +00:00
|
|
|
|
ζ : A ≊ B → A ≡ B
|
2018-04-11 09:10:33 +00:00
|
|
|
|
ζ = η ∘ shuffle
|
2018-03-26 12:11:15 +00:00
|
|
|
|
|
2018-04-05 13:21:54 +00:00
|
|
|
|
-- inv : AreInverses (ℂ.idToIso A B) f
|
2018-04-09 16:02:39 +00:00
|
|
|
|
inv-ζ : AreInverses (idToIso A B) ζ
|
2018-04-19 10:20:44 +00:00
|
|
|
|
-- recto-verso : ℂ.idToIso A B <<< f ≡ idFun (A ℂ.≊ B)
|
2018-04-09 16:02:39 +00:00
|
|
|
|
inv-ζ = record
|
2018-04-11 11:53:33 +00:00
|
|
|
|
{ fst = funExt (λ x → begin
|
2018-04-11 09:10:33 +00:00
|
|
|
|
(ζ ∘ idToIso A B) x ≡⟨⟩
|
|
|
|
|
(η ∘ shuffle ∘ idToIso A B) x ≡⟨ cong (λ φ → φ x) (cong (λ φ → η ∘ shuffle ∘ φ) (funExt lem)) ⟩
|
|
|
|
|
(η ∘ shuffle ∘ shuffle~ ∘ ℂ.idToIso A B) x ≡⟨⟩
|
|
|
|
|
(η ∘ ℂ.idToIso A B) x ≡⟨ (λ i → verso-recto i x) ⟩
|
2018-03-26 12:11:15 +00:00
|
|
|
|
x ∎)
|
2018-04-11 11:53:33 +00:00
|
|
|
|
; snd = funExt (λ x → begin
|
2018-04-11 09:10:33 +00:00
|
|
|
|
(idToIso A B ∘ η ∘ shuffle) x ≡⟨ cong (λ φ → φ x) (cong (λ φ → φ ∘ η ∘ shuffle) (funExt lem)) ⟩
|
|
|
|
|
(shuffle~ ∘ ℂ.idToIso A B ∘ η ∘ shuffle) x ≡⟨ cong (λ φ → φ x) (cong (λ φ → shuffle~ ∘ φ ∘ shuffle) recto-verso) ⟩
|
|
|
|
|
(shuffle~ ∘ shuffle) x ≡⟨⟩
|
2018-03-26 12:11:15 +00:00
|
|
|
|
x ∎)
|
|
|
|
|
}
|
|
|
|
|
|
2018-04-09 16:10:39 +00:00
|
|
|
|
h : TypeIsomorphism (idToIso A B)
|
2018-04-09 16:02:39 +00:00
|
|
|
|
h = ζ , inv-ζ
|
2018-03-05 15:10:27 +00:00
|
|
|
|
|
|
|
|
|
isCategory : IsCategory opRaw
|
2018-04-05 12:37:25 +00:00
|
|
|
|
IsCategory.isPreCategory isCategory = isPreCategory
|
2018-04-09 16:02:39 +00:00
|
|
|
|
IsCategory.univalent isCategory = univalenceFromIsomorphism h
|
2018-02-25 14:21:38 +00:00
|
|
|
|
|
|
|
|
|
opposite : Category ℓa ℓb
|
2018-03-05 15:10:27 +00:00
|
|
|
|
Category.raw opposite = opRaw
|
|
|
|
|
Category.isCategory opposite = isCategory
|
2018-02-25 14:21:38 +00:00
|
|
|
|
|
|
|
|
|
-- As demonstrated here a side-effect of having no-eta-equality on constructors
|
|
|
|
|
-- means that we need to pick things apart to show that things are indeed
|
|
|
|
|
-- definitionally equal. I.e; a thing that would normally be provable in one
|
|
|
|
|
-- line now takes 13!! Admittedly it's a simple proof.
|
|
|
|
|
module _ {ℂ : Category ℓa ℓb} where
|
|
|
|
|
open Category ℂ
|
|
|
|
|
private
|
|
|
|
|
-- Since they really are definitionally equal we just need to pick apart
|
|
|
|
|
-- the data-type.
|
|
|
|
|
rawInv : Category.raw (opposite (opposite ℂ)) ≡ raw
|
|
|
|
|
RawCategory.Object (rawInv _) = Object
|
|
|
|
|
RawCategory.Arrow (rawInv _) = Arrow
|
2018-04-03 09:36:09 +00:00
|
|
|
|
RawCategory.identity (rawInv _) = identity
|
2018-04-11 08:58:50 +00:00
|
|
|
|
RawCategory._<<<_ (rawInv _) = _<<<_
|
2018-02-25 14:21:38 +00:00
|
|
|
|
|
|
|
|
|
oppositeIsInvolution : opposite (opposite ℂ) ≡ ℂ
|
2018-03-08 00:09:40 +00:00
|
|
|
|
oppositeIsInvolution = Category≡ rawInv
|
2018-02-25 14:21:38 +00:00
|
|
|
|
|
2018-02-25 14:23:33 +00:00
|
|
|
|
open Opposite public
|