Martin Escardo 8th May 2020.
An old version of this file is at UF.Classifiers-Old.
This version is ported from the Midlands Graduate School 2019 lecture notes
https://www.cs.bham.ac.uk/~mhe/HoTT-UF.in-Agda-Lecture-Notes/HoTT-UF-Agda.html
https://github.com/martinescardo/HoTT-UF.Agda-Lecture-Notes
but with the universe levels generalized and Ξ£-fibers added in
September 2022.
* Universes are map classifiers.
* Ξ© π€ is the embedding classifier.
* The type of pointed types is the retraction classifier.
* The type inhabited types is the surjection classifier.
* The fiber of Ξ£ are non-dependent function types.
\begin{code}
{-# OPTIONS --without-K --exact-split --safe --auto-inline #-}
module UF.Classifiers where
open import MLTT.Spartan
open import UF.Base
open import UF.Embeddings
open import UF.Equiv
open import UF.Univalence
open import UF.FunExt
open import UF.UA-FunExt
open import UF.Subsingletons
open import UF.Subsingletons-FunExt
open import UF.Powerset hiding (π)
open import UF.EquivalenceExamples
open import UF.Retracts
\end{code}
The slice type:
\begin{code}
_/_ : (π€ : Universe) β π₯ Μ β π€ βΊ β π₯ Μ
π€ / Y = Ξ£ X κ π€ Μ , (X β Y)
\end{code}
A modification of the slice type, where P doesn't need to be
proposition-valued and so can add structure. An example is P = id,
which is studied below in connection with retractions.
\begin{code}
_/[_]_ : (π€ : Universe) β (π€ β π₯ Μ β π¦ Μ ) β π₯ Μ β π€ βΊ β π₯ β π¦ Μ
π€ /[ P ] Y = Ξ£ X κ π€ Μ , Ξ£ f κ (X β Y) , ((y : Y) β P (fiber f y))
\end{code}
We first consider the original situation of the MGS development with a
single universe for comparison.
\begin{code}
module classifier-single-universe (π€ : Universe) where
Ο : (Y : π€ Μ ) β π€ / Y β (Y β π€ Μ )
Ο Y (X , f) = fiber f
universe-is-classifier : π€ βΊ Μ
universe-is-classifier = (Y : π€ Μ ) β is-equiv (Ο Y)
π : (Y : π€ Μ ) β (Y β π€ Μ ) β π€ / Y
π Y A = Ξ£ A , prβ
ΟΞ· : is-univalent π€
β (Y : π€ Μ ) (Ο : π€ / Y) β π Y (Ο Y Ο) οΌ Ο
ΟΞ· ua Y (X , f) = r
where
e : Ξ£ (fiber f) β X
e = total-fiber-is-domain f
p : Ξ£ (fiber f) οΌ X
p = eqtoid ua (Ξ£ (fiber f)) X e
NB : β e ββ»ΒΉ οΌ (Ξ» x β f x , x , refl)
NB = refl
q = transport (Ξ» - β - β Y) p prβ οΌβ¨ transport-is-pre-comp' ua e prβ β©
prβ β β e ββ»ΒΉ οΌβ¨ refl β©
f β
r : (Ξ£ (fiber f) , prβ) οΌ (X , f)
r = to-Ξ£-οΌ (p , q)
ΟΞ΅ : is-univalent π€
β funext π€ (π€ βΊ)
β (Y : π€ Μ ) (A : Y β π€ Μ ) β Ο Y (π Y A) οΌ A
ΟΞ΅ ua fe Y A = dfunext fe Ξ³
where
f : β y β fiber prβ y β A y
f y ((y , a) , refl) = a
g : β y β A y β fiber prβ y
g y a = (y , a) , refl
Ξ· : β y Ο β g y (f y Ο) οΌ Ο
Ξ· y ((y , a) , refl) = refl
Ξ΅ : β y a β f y (g y a) οΌ a
Ξ΅ y a = refl
Ξ³ : β y β fiber prβ y οΌ A y
Ξ³ y = eqtoid ua _ _ (qinveq (f y) (g y , Ξ· y , Ξ΅ y))
universes-are-classifiers : is-univalent π€
β funext π€ (π€ βΊ)
β universe-is-classifier
universes-are-classifiers ua fe Y = qinvs-are-equivs (Ο Y)
(π Y , ΟΞ· ua Y , ΟΞ΅ ua fe Y)
classification : is-univalent π€
β funext π€ (π€ βΊ)
β (Y : π€ Μ ) β π€ / Y β (Y β π€ Μ )
classification ua fe Y = Ο Y , universes-are-classifiers ua fe Y
module special-classifier-single-universe (π€ : Universe) where
open classifier-single-universe π€
Ο-special : (P : π€ Μ β π₯ Μ ) (Y : π€ Μ ) β π€ /[ P ] Y β (Y β Ξ£ P)
Ο-special P Y (X , f , Ο) y = fiber f y , Ο y
universe-is-special-classifier : (π€ Μ β π₯ Μ ) β π€ βΊ β π₯ Μ
universe-is-special-classifier P = (Y : π€ Μ ) β is-equiv (Ο-special P Y)
classifier-gives-special-classifier : universe-is-classifier
β (P : π€ Μ β π₯ Μ )
β universe-is-special-classifier P
classifier-gives-special-classifier s P Y = Ξ³
where
e = (π€ /[ P ] Y) ββ¨ a β©
(Ξ£ Ο κ π€ / Y , ((y : Y) β P ((Ο Y) Ο y))) ββ¨ b β©
(Ξ£ A κ (Y β π€ Μ ), ((y : Y) β P (A y))) ββ¨ c β©
(Y β Ξ£ P) β
where
a = β-sym Ξ£-assoc
b = Ξ£-change-of-variable (Ξ» A β Ξ (P β A)) (Ο Y) (s Y)
c = β-sym Ξ Ξ£-distr-β
NB : Ο-special P Y οΌ β e β
NB = refl
Ξ³ : is-equiv (Ο-special P Y)
Ξ³ = ββ-is-equiv e
Ο-special-is-equiv : is-univalent π€
β funext π€ (π€ βΊ)
β (P : π€ Μ β π₯ Μ ) (Y : π€ Μ )
β is-equiv (Ο-special P Y)
Ο-special-is-equiv ua fe P Y = classifier-gives-special-classifier (universes-are-classifiers ua fe) P Y
special-classification : is-univalent π€
β funext π€ (π€ βΊ)
β (P : π€ Μ β π₯ Μ ) (Y : π€ Μ )
β π€ /[ P ] Y β (Y β Ξ£ P)
special-classification ua fe P Y = Ο-special P Y , Ο-special-is-equiv ua fe P Y
\end{code}
Some examples of special classifiers follow.
The universe of pointed types classifies retractions:
\begin{code}
module retraction-classifier (π€ : Universe) where
open special-classifier-single-universe π€
retractions-into : π€ Μ β π€ βΊ Μ
retractions-into Y = Ξ£ X κ π€ Μ , Y β X
pointed-types : (π€ : Universe) β π€ βΊ Μ
pointed-types π€ = Ξ£ X κ π€ Μ , X
retraction-classifier : Univalence
β (Y : π€ Μ ) β retractions-into Y β (Y β pointed-types π€)
retraction-classifier ua Y =
retractions-into Y ββ¨ i β©
((π€ /[ id ] Y)) ββ¨ ii β©
(Y β pointed-types π€) β
where
i = β-sym (Ξ£-cong (Ξ» X β Ξ£-cong (Ξ» f β Ξ Ξ£-distr-β)))
ii = special-classification (ua π€)
(univalence-gives-funext' π€ (π€ βΊ) (ua π€) (ua (π€ βΊ)))
id Y
\end{code}
The universe of inhabited types classifies surjections:
\begin{code}
module surjection-classifier (π€ : Universe) where
open special-classifier-single-universe π€
open import UF.PropTrunc
module _ (pt : propositional-truncations-exist) where
open PropositionalTruncation pt public
open import UF.ImageAndSurjection pt public
surjections-into : π€ Μ β π€ βΊ Μ
surjections-into Y = Ξ£ X κ π€ Μ , X β Y
inhabited-types : π€ βΊ Μ
inhabited-types = Ξ£ X κ π€ Μ , β₯ X β₯
surjection-classification : Univalence
β (Y : π€ Μ )
β surjections-into Y β (Y β inhabited-types)
surjection-classification ua =
special-classification (ua π€)
(univalence-gives-funext' π€ (π€ βΊ) (ua π€) (ua (π€ βΊ)))
β₯_β₯
\end{code}
Added 11th September 2022. We now generalize the universe levels of
the classifier and special classifier modules.
\begin{code}
module classifier (π€ π₯ : Universe) where
Ο : (Y : π€ Μ ) β (π€ β π₯) / Y β (Y β π€ β π₯ Μ )
Ο Y (X , f) = fiber f
\end{code}
Definition of when the given pair of universes is a classifier,
\begin{code}
universe-is-classifier : (π€ β π₯)βΊ Μ
universe-is-classifier = (Y : π€ Μ ) β is-equiv (Ο Y)
π : (Y : π€ Μ ) β (Y β π€ β π₯ Μ ) β (π€ β π₯) / Y
π Y A = Ξ£ A , prβ
ΟΞ· : is-univalent (π€ β π₯)
β (Y : π€ Μ ) (Ο : (π€ β π₯) / Y) β π Y (Ο Y Ο) οΌ Ο
ΟΞ· ua Y (X , f) = r
where
e : Ξ£ (fiber f) β X
e = total-fiber-is-domain f
p : Ξ£ (fiber f) οΌ X
p = eqtoid ua (Ξ£ (fiber f)) X e
NB : β e ββ»ΒΉ οΌ (Ξ» x β f x , x , refl)
NB = refl
q = transport (Ξ» - β - β Y) p prβ οΌβ¨ transport-is-pre-comp' ua e prβ β©
prβ β β e ββ»ΒΉ οΌβ¨ refl β©
f β
r : (Ξ£ (fiber f) , prβ) οΌ (X , f)
r = to-Ξ£-οΌ (p , q)
ΟΞ΅ : is-univalent (π€ β π₯)
β funext π€ ((π€ β π₯)βΊ)
β (Y : π€ Μ ) (A : Y β π€ β π₯ Μ ) β Ο Y (π Y A) οΌ A
ΟΞ΅ ua fe Y A = dfunext fe Ξ³
where
f : β y β fiber prβ y β A y
f y ((y , a) , refl) = a
g : β y β A y β fiber prβ y
g y a = (y , a) , refl
Ξ· : β y Ο β g y (f y Ο) οΌ Ο
Ξ· y ((y , a) , refl) = refl
Ξ΅ : β y a β f y (g y a) οΌ a
Ξ΅ y a = refl
Ξ³ : β y β fiber prβ y οΌ A y
Ξ³ y = eqtoid ua _ _ (qinveq (f y) (g y , Ξ· y , Ξ΅ y))
universes-are-classifiers : is-univalent (π€ β π₯)
β funext π€ ((π€ β π₯)βΊ)
β universe-is-classifier
universes-are-classifiers ua fe Y = qinvs-are-equivs (Ο Y)
(π Y , ΟΞ· ua Y , ΟΞ΅ ua fe Y)
classification : is-univalent (π€ β π₯)
β funext π€ ((π€ β π₯)βΊ)
β (Y : π€ Μ ) β (π€ β π₯) / Y β (Y β π€ β π₯ Μ )
classification ua fe Y = Ο Y , universes-are-classifiers ua fe Y
\end{code}
In the case of special classifiers we now need to assume a further
universe π¦.
\begin{code}
module special-classifier (π€ π₯ π¦ : Universe) where
open classifier π€ π₯ public
Ο-special : (P : π€ β π₯ Μ β π¦ Μ ) (Y : π€ Μ ) β (π€ β π₯) /[ P ] Y β (Y β Ξ£ P)
Ο-special P Y (X , f , Ο) y = fiber f y , Ο y
universe-is-special-classifier : (π€ β π₯ Μ β π¦ Μ ) β (π€ β π₯)βΊ β π¦ Μ
universe-is-special-classifier P = (Y : π€ Μ ) β is-equiv (Ο-special P Y)
classifier-gives-special-classifier : universe-is-classifier
β (P : π€ β π₯ Μ β π¦ Μ )
β universe-is-special-classifier P
classifier-gives-special-classifier s P Y = Ξ³
where
e = ((π€ β π₯) /[ P ] Y) ββ¨ a β©
(Ξ£ Ο κ (π€ β π₯) / Y , ((y : Y) β P ((Ο Y) Ο y))) ββ¨ b β©
(Ξ£ A κ (Y β π€ β π₯ Μ ), ((y : Y) β P (A y))) ββ¨ c β©
(Y β Ξ£ P) β
where
a = β-sym Ξ£-assoc
b = Ξ£-change-of-variable (Ξ» A β Ξ (P β A)) (Ο Y) (s Y)
c = β-sym Ξ Ξ£-distr-β
NB : Ο-special P Y οΌ β e β
NB = refl
Ξ³ : is-equiv (Ο-special P Y)
Ξ³ = ββ-is-equiv e
Ο-special-is-equiv : is-univalent (π€ β π₯)
β funext π€ ((π€ β π₯)βΊ)
β (P : π€ β π₯ Μ β π¦ Μ ) (Y : π€ Μ )
β is-equiv (Ο-special P Y)
Ο-special-is-equiv ua fe P Y = classifier-gives-special-classifier
(universes-are-classifiers ua fe) P Y
special-classification : is-univalent (π€ β π₯)
β funext π€ ((π€ β π₯)βΊ)
β (P : π€ β π₯ Μ β π¦ Μ ) (Y : π€ Μ )
β (π€ β π₯) /[ P ] Y β (Y β Ξ£ P)
special-classification ua fe P Y = Ο-special P Y , Ο-special-is-equiv ua fe P Y
\end{code}
The subtype classifier with general universes:
\begin{code}
Ξ©-is-subtype-classifier' : is-univalent (π€ β π₯)
β funext π€ ((π€ β π₯)βΊ)
β (Y : π€ Μ )
β Subtypes' (π€ β π₯) Y β (Y β Ξ© (π€ β π₯))
Ξ©-is-subtype-classifier' {π€} {π₯} ua fe = special-classification ua fe
is-subsingleton
where
open special-classifier π€ π₯ (π€ β π₯)
Ξ©-is-subtype-classifier : is-univalent π€
β funext π€ (π€ βΊ)
β (Y : π€ Μ )
β Subtypes Y β (Y β Ξ© π€)
Ξ©-is-subtype-classifier {π€} = Ξ©-is-subtype-classifier' {π€} {π€}
subtypes-form-set : Univalence β (Y : π€ Μ ) β is-set (Subtypes' (π€ β π₯) Y)
subtypes-form-set {π€} {π₯} ua Y =
equiv-to-set
(Ξ©-is-subtype-classifier' {π€} {π₯}
(ua (π€ β π₯))
(univalence-gives-funext' π€ ((π€ β π₯)βΊ)
(ua π€)
(ua ((π€ β π₯)βΊ)))
Y)
(powersets-are-sets''
(univalence-gives-funext' _ _ (ua π€) (ua ((π€ β π₯)βΊ)))
(univalence-gives-funext' _ _ (ua (π€ β π₯)) (ua (π€ β π₯)))
(univalence-gives-propext (ua (π€ β π₯))))
\end{code}
9th September 2022, with universe levels generalized 11
September. Here is an application of the above.
\begin{code}
Ξ£-fibers-β : {π€ π₯ : Universe}
β is-univalent (π€ β π₯)
β funext π€ ((π€ β π₯)βΊ)
β {X : π€ β π₯ Μ } {Y : π€ Μ }
β (Ξ£ A κ (Y β π€ β π₯ Μ ) , Ξ£ A β X) β (X β Y)
Ξ£-fibers-β {π€} {π₯} ua feβΊ {X} {Y} =
(Ξ£ A κ (Y β π€ β π₯ Μ ) , Ξ£ A β X) ββ¨ I β©
(Ξ£ (Z , g) κ (π€ β π₯) / Y , (Ξ£ y κ Y , fiber g y) β X) ββ¨ II β©
(Ξ£ Z κ π€ β π₯ Μ , Ξ£ g κ (Z β Y) , (Ξ£ y κ Y , fiber g y) β X) ββ¨ III β©
(Ξ£ Z κ π€ β π₯ Μ , (Z β Y) Γ (Z β X)) ββ¨ IV β©
(Ξ£ Z κ π€ β π₯ Μ , (Z β X) Γ (Z β Y)) ββ¨ V β©
(Ξ£ Z κ π€ β π₯ Μ , (X β Z) Γ (Z β Y)) ββ¨ VI β©
(Ξ£ (Z , _) κ (Ξ£ Z κ π€ β π₯ Μ , X β Z) , (Z β Y)) ββ¨ VII β©
(X β Y) β
where
open classifier π€ π₯
open import UF.Equiv-FunExt
open import UF.PropIndexedPiSigma
open import UF.Yoneda
fe : funext (π€ β π₯) (π€ β π₯)
fe = univalence-gives-funext ua
I = β-sym (Ξ£-change-of-variable (Ξ» A β Ξ£ A β X) (Ο Y)
(universes-are-classifiers ua feβΊ Y))
II = Ξ£-assoc
III = Ξ£-cong (Ξ» Z β Ξ£-cong (Ξ» g β β-cong-left' fe fe fe fe fe
(total-fiber-is-domain g)))
IV = Ξ£-cong (Ξ» Z β Γ-comm)
V = Ξ£-cong (Ξ» Z β Γ-cong (β-Sym' fe fe fe fe) (β-refl (Z β Y)))
VI = β-sym Ξ£-assoc
VII = prop-indexed-sum
(singletons-are-props
(univalence-via-singletonsβ ua X))
(X , β-refl X)
private
β : {π€ π₯ : Universe} (X : π€ Μ ) (Y : X β π₯ Μ ) β π€ β π₯ Μ
β X Y = Ξ£ Y
\end{code}
The use of equality rather than equivalence prevents us from having
more general universes in the following:
\begin{code}
Ξ£-fibers : is-univalent π€
β funext π€ (π€ βΊ)
β {X : π€ Μ } {Y : π€ Μ }
β fiber (β Y) X β (X β Y)
Ξ£-fibers {π€} ua feβΊ {X} {Y} =
(Ξ£ A κ (Y β π€ Μ ) , Ξ£ A οΌ X) ββ¨ Ξ£-cong (Ξ» A β univalence-β ua (Ξ£ A) X) β©
(Ξ£ A κ (Y β π€ Μ ) , Ξ£ A β X) ββ¨ Ξ£-fibers-β {π€} {π€} ua feβΊ β©
(X β Y) β