\begin{code}
{-# OPTIONS --without-K #-}
module GeneralizedHedberg where
open import mini-library
\end{code}
\begin{code}
Type = Set
Type₁ = Set₁
\end{code}
\begin{code}
hprop : Type → Type
hprop X = (x y : X) → x ≡ y
\end{code}
\begin{code}
∅-is-hprop : hprop ∅
∅-is-hprop x y = ∅-elim x
\end{code}
\begin{code}
hset : Type → Type
hset X = {x y : X} → hprop(x ≡ y)
\end{code}
\begin{code}
constant : {X Y : Type} → (X → Y) → Type
constant {X} {Y} f = (x y : X) → f x ≡ f y
collapsible : Type → Type
collapsible X = Σ \(f : X → X) → constant f
path-collapsible : Type → Type
path-collapsible X = {x y : X} → collapsible(x ≡ y)
\end{code}
\begin{code}
hset-is-path-collapsible : {X : Type} → hset X → path-collapsible X
hset-is-path-collapsible u = (id , u)
path-collapsible-is-hset : {X : Type} → path-collapsible X → hset X
path-collapsible-is-hset {X} pc p q = claim₂
where
f : {x y : X} → x ≡ y → x ≡ y
f = π₀ pc
g : {x y : X} (p q : x ≡ y) → f p ≡ f q
g = π₁ pc
claim₀ : {x y : X} (r : x ≡ y) → r ≡ (f refl)⁻¹ • (f r)
claim₀ = J (λ r → r ≡ ((f refl)⁻¹) • (f r)) (sym-is-inverse(f refl))
claim₁ : (f refl)⁻¹ • (f p) ≡ (f refl)⁻¹ • (f q)
claim₁ = ap (λ h → (f refl)⁻¹ • h) (g p q)
claim₂ : p ≡ q
claim₂ = (claim₀ p) • claim₁ • (claim₀ q)⁻¹
\end{code}
\begin{code}
hprop-is-path-collapsible : {X : Type} → hprop X → path-collapsible X
hprop-is-path-collapsible h {x} {y} = ((λ p → h x y) , (λ p q → refl))
hprop-is-hset : {X : Type} → hprop X → hset X
hprop-is-hset h = path-collapsible-is-hset(hprop-is-path-collapsible h)
\end{code}
\begin{code}
∅-is-collapsible : collapsible ∅
∅-is-collapsible = (λ x → x) , (λ x → λ ())
inhabited : Type → Type
inhabited X = X
inhabited-is-collapsible : {X : Type} → inhabited X → collapsible X
inhabited-is-collapsible x = ((λ y → x) , λ y y' → refl)
\end{code}
\begin{code}
empty : Type → Type
empty X = inhabited(X → ∅)
empty-is-collapsible : {X : Type} → empty X → collapsible X
empty-is-collapsible u = (id , (λ x x' → ∅-elim(u x)))
∅-is-collapsible-as-a-particular-case : collapsible ∅
∅-is-collapsible-as-a-particular-case = empty-is-collapsible id
\end{code}
\begin{code}
decidable : Type → Type
decidable X = inhabited X + empty X
decidable-is-collapsible : {X : Type} → decidable X → collapsible X
decidable-is-collapsible (in₀ x) = inhabited-is-collapsible x
decidable-is-collapsible (in₁ u) = empty-is-collapsible u
EM : Type₁
EM = (X : Type) → decidable X
all-types-are-collapsible-under-EM : EM → (X : Type) → collapsible X
all-types-are-collapsible-under-EM em X = decidable-is-collapsible (em X)
all-types-are-hsets-under-EM : EM → (X : Type) → hset X
all-types-are-hsets-under-EM em X = path-collapsible-is-hset(λ {x} {y} → all-types-are-collapsible-under-EM em (x ≡ y))
\end{code}
\begin{code}
discrete : Type → Type
discrete X = {x y : X} → decidable(x ≡ y)
discrete-is-path-collapsible : {X : Type} → discrete X → path-collapsible X
discrete-is-path-collapsible d = decidable-is-collapsible d
\end{code}
\begin{code}
discrete-is-hset : {X : Type} → discrete X → hset X
discrete-is-hset d = path-collapsible-is-hset(discrete-is-path-collapsible d)
\end{code}
\begin{code}
nonempty : Type → Type
nonempty X = empty(empty X)
stable : Type → Type
stable X = nonempty X → inhabited X
decidable-is-stable : {X : Type} → decidable X → stable X
decidable-is-stable (in₀ x) φ = x
decidable-is-stable (in₁ u) φ = ∅-elim(φ u)
separated : Type → Type
separated X = {x y : X} → stable(x ≡ y)
discrete-is-separated : {X : Type} → discrete X → separated X
discrete-is-separated {X} d = decidable-is-stable d
\end{code}
\begin{code}
funext : Type → Type → Type
funext X Y = {f g : X → Y} → ((x : X) → f x ≡ g x) → f ≡ g
funext-special-case₀ : Type → Type
funext-special-case₀ X = funext (empty X) ∅
stable-is-collapsible : {X : Type} → funext-special-case₀ X → stable X → collapsible X
stable-is-collapsible {X} e s = (f , g)
where
f : X → X
f x = s(λ u → u x)
claim₀ : (x y : X) → (u : empty X) → u x ≡ u y
claim₀ x y u = ∅-elim(u x)
claim₁ : (x y : X) → (λ u → u x) ≡ (λ u → u y)
claim₁ x y = e (claim₀ x y)
g : (x y : X) → f x ≡ f y
g x y = ap s (claim₁ x y)
funext-special-case₁ : Type → Type
funext-special-case₁ X = {x y : X} → funext-special-case₀(x ≡ y)
separated-is-path-collapsible : {X : Type} → funext-special-case₁ X → separated X → path-collapsible X
separated-is-path-collapsible e s = stable-is-collapsible e s
\end{code}
\begin{code}
separated-is-hset : {X : Type} → funext-special-case₁ X → separated X → hset X
separated-is-hset e s = path-collapsible-is-hset(separated-is-path-collapsible e s)
\end{code}
\begin{code}
postulate hinhabited : Type → Type
postulate hprop-hinhabited : {X : Type} → hprop(hinhabited X)
postulate η : {X : Type} → X → hinhabited X
postulate hinhabited-elim : (X P : Type) → hprop P → (X → P) → (hinhabited X → P)
postulate hinhabited-ind : {X : Type} {P : hinhabited X → Type} → ((s : hinhabited X) → hprop(P s)) → ((x : X) → P (η x)) → (s : hinhabited X) → P s
\end{code}
\begin{code}
hinhabited₁ : Type → Type₁
hinhabited₁ X = (P : Type) → hprop P → (X → P) → P
\end{code}
\begin{code}
hinhabited-elim' : (X : Type) → hinhabited X → hinhabited₁ X
hinhabited-elim' X p P f g = hinhabited-elim X P f g p
hinhabited-elim'-converse : (X : Type) → hinhabited₁ X → hinhabited X
hinhabited-elim'-converse X f = f (hinhabited X) hprop-hinhabited η
hstable : Type → Type
hstable X = hinhabited X → inhabited X
hseparated : Type → Type
hseparated X = {x y : X} → hstable(x ≡ y)
\end{code}
\begin{code}
inhabited-is-hinhabited : {X : Type} → inhabited X → hinhabited X
inhabited-is-hinhabited = η
hinhabited-is-nonempty : {X : Type} → hinhabited X → nonempty X
hinhabited-is-nonempty {X} a u = hinhabited-elim X ∅ ∅-is-hprop u a
\end{code}
\begin{code}
stable-is-hstable : {X : Type} → stable X → hstable X
stable-is-hstable {X} s a = s(hinhabited-is-nonempty a)
separated-is-hseparated : {X : Type} → separated X → hseparated X
separated-is-hseparated s a = s(hinhabited-is-nonempty a)
\end{code}
\begin{code}
hstable-is-collapsible : {X : Type} → hstable X → collapsible X
hstable-is-collapsible {X} s = (f , g)
where
f : X → X
f x = s(η x)
claim₀ : (x y : X) → η x ≡ η y
claim₀ x y = hprop-hinhabited (η x) (η y)
g : (x y : X) → f x ≡ f y
g x y = ap s (claim₀ x y)
hseparated-is-path-collapsible : {X : Type} → hseparated X → path-collapsible X
hseparated-is-path-collapsible s = hstable-is-collapsible s
\end{code}
\begin{code}
hseparated-is-hset : {X : Type} → hseparated X → hset X
hseparated-is-hset s = path-collapsible-is-hset(hseparated-is-path-collapsible s)
\end{code}
\begin{code}
hprop-is-hstable : {X : Type} → hprop X → hstable X
hprop-is-hstable {X} h a = hinhabited-elim X X h id a
hset-is-hseparated : {X : Type} → hset X → hseparated X
hset-is-hseparated h a = hprop-is-hstable h a
\end{code}
\begin{code}
₂-discrete : discrete ₂
₂-discrete {₀} {₀} = in₀ refl
₂-discrete {₀} {₁} = in₁(λ())
₂-discrete {₁} {₀} = in₁(λ())
₂-discrete {₁} {₁} = in₀ refl
totally-separated : Type → Type
totally-separated X = {x y : X} → ((p : X → ₂) → p x ≡ p y) → x ≡ y
dependent-funext : Type₁
dependent-funext = {X : Type} {Y : X → Type} {f g : (x : X) → Y x} → ((x : X) → f x ≡ g x) → f ≡ g
totally-separated-is-hset : dependent-funext → (X : Type) → totally-separated X → hset X
totally-separated-is-hset de X t = path-collapsible-is-hset h
where
f : {x y : X} → x ≡ y → x ≡ y
f r = t(λ p → ap p r)
b : {x y : X} (φ γ : (p : X → ₂) → p x ≡ p y) → φ ≡ γ
b φ γ = de(λ p → discrete-is-hset ₂-discrete (φ p) (γ p))
c : {x y : X} (r s : x ≡ y) → (λ p → ap p r) ≡ (λ p → ap p s)
c r s = b(λ p → ap p r) (λ p → ap p s)
g : {x y : X} → constant(f {x} {y})
g r s = ap t (c r s)
h : path-collapsible X
h {x} {y} = f , g
\end{code}
\begin{code}
contra-positive : {R X Y : Type} → (X → Y) → (Y → R) → (X → R)
contra-positive f p x = p(f x)
₂-separated : separated ₂
₂-separated = discrete-is-separated ₂-discrete
totally-separated-is-separated : {X : Type} → totally-separated X → separated X
totally-separated-is-separated {X} t {x} {y} φ = t h
where
a : (p : X → ₂) → nonempty(p x ≡ p y)
a p = φ ∘ contra-positive(ap p)
h : (p : X → ₂) → p x ≡ p y
h p = ₂-separated(a p)
totally-separated-is-hset' : {X : Type} → funext-special-case₁ X → totally-separated X → hset X
totally-separated-is-hset' e t = separated-is-hset e (totally-separated-is-separated t)
\end{code}
\begin{code}
injective : {X Y : Type} → (f : X → Y) → Type
injective {X} f = {x x' : X} → f x ≡ f x' → x ≡ x'
subtype-of-hset-is-hset : {X Y : Type} (m : X → Y) → injective m → hset Y → hset X
subtype-of-hset-is-hset {X} m i h = path-collapsible-is-hset(f , g)
where
f : {x x' : X} → x ≡ x' → x ≡ x'
f r = i(ap m r)
g : {x x' : X} (r s : x ≡ x') → f r ≡ f s
g r s = ap i (h (ap m r) (ap m s))
π₀-injective : {X : Type} {Y : X → Type} → ({x : X} → hprop(Y x)) → injective π₀
π₀-injective {X} {Y} f {u} {v} r = lemma r (π₁ u) (π₁ v) (f(transport {X} {Y} r (π₁ u)) (π₁ v))
where
A : {x x' : X} → x ≡ x' → Type
A {x} {x'} r = (y : Y x) (y' : Y x') → transport r y ≡ y' → (x , y) ≡ (x' , y')
lemma : {x x' : X} (r : x ≡ x') → A {x} {x'} r
lemma = J A (λ {x} x' y → ap (λ y → (x , y)))
subset-of-hset-is-hset : (X : Type) (Y : X → Type) → hset X → ({x : X} → hprop(Y x)) → hset(Σ \(x : X) → Y x)
subset-of-hset-is-hset X Y h p = subtype-of-hset-is-hset π₀ (π₀-injective p) h
\end{code}
\begin{code}
fix : {X : Type} → (f : X → X) → Type
fix f = Σ \x → x ≡ f x
\end{code}
\begin{code}
Kraus-Lemma₀ : {X Y : Type} (f : X → Y) (g : constant f) {x y : X} (p : x ≡ y) → ap f p ≡ (g x x)⁻¹ • (g x y)
Kraus-Lemma₀ f g {x} {y} = J (λ {x} {y} p → ap f p ≡ (g x x)⁻¹ • (g x y)) (λ {x} → sym-is-inverse(g x x))
Kraus-Lemma₁ : {X Y : Type} (f : X → Y) → constant f → {x : X} (p : x ≡ x) → ap f p ≡ refl
Kraus-Lemma₁ f g p = (Kraus-Lemma₀ f g p) • ((sym-is-inverse(g _ _))⁻¹)
\end{code}
\begin{code}
transport-paths-along-paths : {X Y : Type} {x y : X} (p : x ≡ y) (h k : X → Y) (q : h x ≡ k x)
→ transport p q ≡ (ap h p)⁻¹ • q • (ap k p)
transport-paths-along-paths {X} {Y} {x} p h k q =
J' x (λ p → transport p q ≡ ((ap h p)⁻¹) • q • (ap k p)) (refl-is-right-id q) p
transport-paths-along-paths' : {X : Type} {x : X} (p : x ≡ x) (f : X → X) (q : x ≡ f x)
→ transport {X} {λ z → z ≡ f z} p q ≡ p ⁻¹ • q • (ap f p)
transport-paths-along-paths' {X} {x} p f q =
(transport-paths-along-paths p (λ z → z) f q) • (ap (λ pr → pr ⁻¹ • q • (ap f p)) ((ap-id-is-id p)⁻¹))
\end{code}
\begin{code}
Kraus-Lemma : {X : Type} (f : X → X) → constant f → hprop(fix f)
Kraus-Lemma {X} f g (x , p) (y , q) =
(x , p) ≡⟨ Σ-≡ x y p p' r refl ⟩
(y , p') ≡⟨ Σ-≡ y y p' q s t ⟩∎
(y , q) ∎
where
r : x ≡ y
r = x ≡⟨ p ⟩
f x ≡⟨ g x y ⟩
f y ≡⟨ q ⁻¹ ⟩∎
y ∎
p' : y ≡ f y
p' = transport r p
s : y ≡ y
s = y ≡⟨ p' ⟩
f y ≡⟨ q ⁻¹ ⟩∎
y ∎
q' : y ≡ f y
q' = transport {X} {λ y → y ≡ f y} s p'
t : q' ≡ q
t = q' ≡⟨ transport-paths-along-paths' s f p' ⟩
s ⁻¹ • (p' • ap f s) ≡⟨ ap (λ pr → s ⁻¹ • (p' • pr)) (Kraus-Lemma₁ f g s) ⟩
s ⁻¹ • (p' • refl) ≡⟨ ap (λ pr → s ⁻¹ • pr) ((refl-is-right-id p')⁻¹) ⟩
s ⁻¹ • p' ≡⟨ refl ⟩
(p' • (q ⁻¹))⁻¹ • p' ≡⟨ ap (λ pr → pr • p') ((sym-trans p' (q ⁻¹))⁻¹) ⟩
((q ⁻¹)⁻¹ • (p' ⁻¹)) • p' ≡⟨ ap (λ pr → (pr • (p' ⁻¹)) • p') ((sym-sym-trivial q)⁻¹) ⟩
(q • (p' ⁻¹)) • p' ≡⟨ trans-assoc q (p' ⁻¹) p' ⟩
q • ((p' ⁻¹) • p') ≡⟨ ap (λ pr → q • pr) ((sym-is-inverse p')⁻¹) ⟩
q • refl ≡⟨ (refl-is-right-id q)⁻¹ ⟩∎
q ∎
\end{code}
\begin{code}
from-fix : {X : Type} (f : X → X) → fix f → X
from-fix f = π₀
to-fix : {X : Type} (f : X → X) → constant f → X → fix f
to-fix f g x = (f x , g x (f x))
collapsible-is-hstable : {X : Type} → collapsible X → hstable X
collapsible-is-hstable {X} (f , g) hi = from-fix f l
where
h : X → fix f
h = to-fix f g
k : hinhabited X → fix f
k = hinhabited-elim X (fix f) (Kraus-Lemma f g) h
l : fix f
l = k hi
\end{code}
\begin{code}
populated₁ : Type → Type₁
populated₁ X = (P : Type) → hprop P → (P → X) → (X → P) → P
hinhabited-is-populated₁ : {X : Type} → hinhabited X → populated₁ X
hinhabited-is-populated₁ {X} hi P h a b = hinhabited-elim X P h b hi
populated₁-is-hinhabited-under-hstability : {X : Type} → hstable X → populated₁ X → hinhabited X
populated₁-is-hinhabited-under-hstability {X} s po = po (hinhabited X) hprop-hinhabited s η
\end{code}
\begin{code}
populated₁-is-nonempty : {X : Type} → populated₁ X → nonempty X
populated₁-is-nonempty p = p ∅ (∅-is-hprop) ∅-elim
\end{code}
\begin{code}
D : Type → Type
D X = collapsible X → X
populated₁-is-D : {X : Type} → populated₁ X → D X
populated₁-is-D {X} p (f , g) = from-fix f (p (fix f) (Kraus-Lemma f g) (from-fix f) (to-fix f g))
D-is-populated₁ : {X : Type} → D X → populated₁ X
D-is-populated₁ {X} d P h a b = b x
where
f : X → X
f x = a(b x)
g : constant f
g x y = ap a (h (b x) (b y))
x : X
x = d(f , g)
\end{code}
\begin{code}
collapsible-is-hstable-bis : {X : Type} → collapsible X → hstable X
collapsible-is-hstable-bis c hi = populated₁-is-D (hinhabited-is-populated₁ hi) c
\end{code}
\begin{code}
path-collapsible-is-hset-bis : {X : Type} → path-collapsible X → hset X
path-collapsible-is-hset-bis c = hseparated-is-hset(collapsible-is-hstable c)
\end{code}
\begin{code}
both-directions-combined : {X : Type} → ((populated₁ X → X) → X) → populated₁ X
both-directions-combined {X} hypothesis = D-is-populated₁ fact₁
where
fact₀ : collapsible X → (populated₁ X → X)
fact₀ c p = populated₁-is-D p c
fact₁ : D X
fact₁ c = hypothesis(fact₀ c)
both-directions-combined-converse : {X : Type} → populated₁ X → ((populated₁ X → X) → X)
both-directions-combined-converse p u = u p
both-directions-combined-bis : {X : Type} → ((hinhabited X → X) → X) → populated₁ X
both-directions-combined-bis {X} hypothesis = D-is-populated₁(λ c → hypothesis(collapsible-is-hstable c))
\end{code}
\begin{code}
postulate funext-special-case₂ : {X : Type} → funext (collapsible X) X
φ : (X : Type) → D X → D X
φ X h (f , g) = f(h(f , g))
\end{code}
\begin{code}
φ-constant : (X : Type) → constant(φ X)
φ-constant X h k = funext-special-case₂(claim₁ h k)
where
claim₀ : (h k : D X) → (f : X → X) → (g : constant f) → φ X h (f , g) ≡ φ X k (f , g)
claim₀ h k f g = g (h(f , g)) (k(f , g))
claim₁ : (h k : D X) → (c : collapsible X) → φ X h c ≡ φ X k c
claim₁ h k (f , g) = claim₀ h k f g
populated : Type → Type
populated X = fix(φ X)
hprop-populated : (X : Type) → hprop(populated X)
hprop-populated X = Kraus-Lemma (φ X) (φ-constant X)
populated-is-D : {X : Type} → populated X → D X
populated-is-D {X} = from-fix (φ X)
D-is-populated : {X : Type} → D X → populated X
D-is-populated {X} = to-fix (φ X) (φ-constant X)
populated-is-populated₁ : {X : Type} → populated X → populated₁ X
populated-is-populated₁ po = D-is-populated₁(populated-is-D po)
populated₁-is-populated : {X : Type} → populated₁ X → populated X
populated₁-is-populated po = D-is-populated(populated₁-is-D po)
\end{code}
\begin{code}
inhabited-is-populated : {X : Type} → X → populated X
inhabited-is-populated {X} x = D-is-populated (λ c → x)
populated-is-nonempty : {X : Type} → populated X → nonempty X
populated-is-nonempty {X} (f , g) u = u(f(h , h-constant))
where
h : X → X
h = ∅-elim ∘ u
h-constant : (x y : X) → h x ≡ h y
h-constant x y = ∅-elim(u x)
\end{code}
\begin{code}
hinhabited-extension : {X Y : Type} → (X → hinhabited Y) → (hinhabited X → hinhabited Y)
hinhabited-extension {X} {Y} f p = hinhabited-elim X (hinhabited Y) hprop-hinhabited f p
\end{code}
\begin{code}
kleisli-law₀ : {X : Type} (p : hinhabited X) → hinhabited-extension η p ≡ p
kleisli-law₀ p = hprop-hinhabited (hinhabited-extension η p) p
kleisli-law₁ : {X Y : Type} → (f : X → hinhabited Y) → (x : X) → (hinhabited-extension f)(η x) ≡ f x
kleisli-law₁ {X} {Y} f x = hprop-hinhabited ((hinhabited-extension f)(η x)) (f x)
kleisli-law₂ : {X Y Z : Type} → (f : X → hinhabited Y) → (g : Y → hinhabited Z) → (p : hinhabited X) →
hinhabited-extension((hinhabited-extension g) ∘ f) p ≡ (hinhabited-extension g)(hinhabited-extension f p)
kleisli-law₂ f g p =
hprop-hinhabited (hinhabited-extension((hinhabited-extension g) ∘ f) p) ((hinhabited-extension g)(hinhabited-extension f p))
\end{code}
\begin{code}
hinhabited-functor : {X Y : Type} → (X → Y) → hinhabited X → hinhabited Y
hinhabited-functor f = hinhabited-extension(η ∘ f)
μ : {X : Type} → hinhabited(hinhabited X) → hinhabited X
μ = hinhabited-extension id
\end{code}
\begin{code}
hinhabited-strength : {X Y : Type} → X × hinhabited Y → hinhabited(X × Y)
hinhabited-strength (x , q) = hinhabited-functor(λ y → (x , y)) q
hinhabited-shift : {X Y : Type} → hinhabited X × hinhabited Y → hinhabited(X × Y)
hinhabited-shift (p , q) = hinhabited-extension(λ x → hinhabited-strength(x , q)) p
\end{code}
\begin{code}
hstable-example : (X : Type) → hstable(D X)
hstable-example X h c = x
where
p : hinhabited(collapsible X × D X)
p = hinhabited-strength(c , h)
f : collapsible X × D X → X
f(c , φ) = φ c
q : hinhabited X
q = hinhabited-functor f p
x : X
x = collapsible-is-hstable c q
collapsible-example-bis : (X : Type) → collapsible(D X)
collapsible-example-bis X = hstable-is-collapsible(hstable-example X)
\end{code}
\begin{code}
φ-bis : (X : Type) → D X → D X
φ-bis X = π₀(collapsible-example-bis X)
φ-constant-bis : (X : Type) → constant(φ-bis X)
φ-constant-bis X = π₁(collapsible-example-bis X)
\end{code}
\begin{code}
HoTT-taboo : Type₁
HoTT-taboo = (X : Type) → hset X
all-types-are-hstable-is-a-HoTT-taboo : ((X : Type) → hstable X) → HoTT-taboo
all-types-are-hstable-is-a-HoTT-taboo h _ = hseparated-is-hset(h(_ ≡ _))
\end{code}
\begin{code}
pstable : Type → Type
pstable X = populated X → X
pstable-is-hstable : (X : Type) → pstable X → hstable X
pstable-is-hstable X p h = p(populated₁-is-populated(hinhabited-is-populated₁ h))
hstable-is-pstable : (X : Type) → hstable X → pstable X
hstable-is-pstable X h p = populated-is-D p (hstable-is-collapsible h)
\end{code}
\begin{code}
populated₁-hstable : {X : Type} → populated₁(hstable X)
populated₁-hstable {X} P h a b = b hs
where
u : X → P
u x = b(λ _ → x)
g : hinhabited X → P
g hi = hinhabited-elim X P h u hi
hs : hinhabited X → X
hs hi = a (g hi) hi
populated-hstable : {X : Type} → populated(hstable X)
populated-hstable = populated₁-is-populated populated₁-hstable
nonempty-hstable : {X : Type} → nonempty(hstable X)
nonempty-hstable = populated₁-is-nonempty populated₁-hstable
\end{code}
\begin{code}
populated-inhabited-charac : ((X : Type) → populated X → hinhabited X) → ((X : Type) → hinhabited(hstable X))
populated-inhabited-charac f X = f (hstable X) populated-hstable
populated-inhabited-charac' : ((X : Type) → hinhabited(hstable X)) → ((X : Type) → populated X → hinhabited X)
populated-inhabited-charac' f X po =
hinhabited-extension (λ h → populated₁-is-hinhabited-under-hstability h (populated-is-populated₁ po)) (f X)
\end{code}
\begin{code}
nonempty-decidable : {X : Type} → nonempty(decidable X)
nonempty-decidable d = d(in₁(λ x → d(in₀ x)))
postulate funext-special-case₃ : {X : Type} → funext X ∅
∅-valued-functions-are-equal : {X : Type} → hprop(empty X)
∅-valued-functions-are-equal {X} f g = funext-special-case₃ {X} (λ x → ∅-elim(f x))
hhd : {P : Type} → hprop P → hprop(decidable P)
hhd h (in₀ p) (in₀ q) = ap in₀ (h p q)
hhd h (in₀ p) (in₁ v) = ∅-elim(v p)
hhd h (in₁ u) (in₀ q) = ∅-elim(u q)
hhd h (in₁ u) (in₁ v) = ap in₁ (∅-valued-functions-are-equal u v)
hcd : {P : Type} → hprop P → collapsible(decidable P)
hcd h = (id , hhd h)
\end{code}
\begin{code}
hEM : Type₁
hEM = (P : Type) → hprop P → decidable P
wEM : Type₁
wEM = (X : Type) → decidable(empty X)
hEM-implies-wEM : hEM → wEM
hEM-implies-wEM hem X = hem (empty X) ∅-valued-functions-are-equal
all-nonempty-types-are-populated-taboo : ((X : Type) → nonempty X → populated X) → hEM
all-nonempty-types-are-populated-taboo a P h = populated-is-D p c
where
p : populated(decidable P)
p = a (decidable P) nonempty-decidable
c : collapsible(decidable P)
c = hcd h
\end{code}
\begin{code}
pAC : {X Y : Type} → (X → populated₁ Y) → populated₁(X → Y)
pAC {X} {Y} h P hP a b = b hs
where
u : X → Y → P
u x y = b(λ _ → y)
g : X → populated₁ Y → P
g x po = po P hP (λ p → a p x) (λ y → u x y)
hs : X → Y
hs x = a (g x (h x)) x
mixed-AC : {X Y : Type} → (X → hinhabited Y) → populated₁(X → Y)
mixed-AC f = pAC (λ x → hinhabited-is-populated₁(f x))
weak-mixed-AC : {X Y : Type} → (X → hinhabited Y) → nonempty(X → Y)
weak-mixed-AC {X} {Y} p = populated₁-is-nonempty (mixed-AC p)
DN : {R X Y : Type} → (X → Y) → ((X → R) → R) → ((Y → R) → R)
DN f = contra-positive(contra-positive f)
weak-hAC : hEM → {X Y : Type} → (X → hinhabited Y) → hinhabited(X → Y)
weak-hAC hem {X} {Y} h = f hEM-special-case
where
hEM-special-case : hinhabited(X → Y) + empty(hinhabited(X → Y))
hEM-special-case = hem (hinhabited(X → Y)) hprop-hinhabited
fact : nonempty(X → Y)
fact = weak-mixed-AC h
claim : nonempty(X → Y) → nonempty(hinhabited(X → Y))
claim = DN η
f : hinhabited(X → Y) + empty(hinhabited(X → Y)) → hinhabited(X → Y)
f (in₀ hi) = hi
f (in₁ nhi) = ∅-elim(claim fact nhi)
very-weak-hAC : hEM → {X : Type} → hinhabited(hstable X)
very-weak-hAC hem {X} = weak-hAC hem id
\end{code}
\begin{code}
hh→hh : ((X : Type) → hinhabited(hstable X)) → (X Y : Type) → (X → hinhabited Y) → hinhabited(X → Y)
hh→hh hh X Y f = hinhabited-functor (λ p → (π₁ p) ∘ (π₀ p)) lemma
where
lemma : hinhabited ((X → hinhabited Y) × (hinhabited Y → Y))
lemma = hinhabited-strength (f , hh Y)
hh←hh : ((X Y : Type) → (X → hinhabited Y) → hinhabited(X → Y)) → (X : Type) → hinhabited(hstable X)
hh←hh hh X = hh (hinhabited X) X id
\end{code}
\begin{code}
local-hedberg : {X : Type} → (x : X)
→ ({y : X} → collapsible(x ≡ y))
→ (y : X) → hprop(x ≡ y)
local-hedberg {X} x pc y p q = claim₂
where
f : {y : X} → x ≡ y → x ≡ y
f = π₀ pc
g : {y : X} (p q : x ≡ y) → f p ≡ f q
g = π₁ pc
claim₀ : {y : X} (r : x ≡ y) → r ≡ (f refl)⁻¹ • (f r)
claim₀ = J' x (λ r → r ≡ ((f refl)⁻¹) • (f r)) (sym-is-inverse(f refl))
claim₁ : (f refl)⁻¹ • (f p) ≡ (f refl)⁻¹ • (f q)
claim₁ = ap (λ h → (f refl)⁻¹ • h) (g p q)
claim₂ : p ≡ q
claim₂ = (claim₀ p) • claim₁ • (claim₀ q)⁻¹
path-collapsible-is-hset-as-a-special-case : {X : Type} → path-collapsible X → hset X
path-collapsible-is-hset-as-a-special-case {X} pc {x} {y} p q = local-hedberg x (λ {y} → (π₀(pc {x} {y})) , (π₁(pc {x} {y}))) y p q
\end{code}
\begin{code}
global-choice-lemma : (X : Type) → (a : ₂ → X) → ({x : X} → hstable(Σ \(i : ₂) → a i ≡ x)) → decidable(a ₀ ≡ a ₁)
global-choice-lemma X a choice = equal-or-different
where
E : Type
E = Σ \(x : X) → hinhabited(Σ \(i : ₂) → a i ≡ x)
r : ₂ → E
r i = a i , η(i , refl)
r-Σ-≡s : (e : E) → Σ \(i : ₂) → r i ≡ e
r-Σ-≡s (x , p) = π₀ p' , Σ-≡ (a(π₀ p')) x (η((π₀ p') , refl)) p (π₁ p') (hprop-hinhabited _ p)
where
p' : Σ \(i : ₂) → a i ≡ x
p' = choice p
s : E → ₂
s e = π₀(r-Σ-≡s e)
r-retract : (e : E) → r(s e) ≡ e
r-retract e = π₁(r-Σ-≡s e)
s-injective : (e e' : E) → s e ≡ s e' → e ≡ e'
s-injective e e' p = (r-retract e)⁻¹ • ap r p • r-retract e'
a-r : (i j : ₂) → a i ≡ a j → r i ≡ r j
a-r i j p = Σ-≡ (a i) (a j) (η(i , refl)) (η(j , refl)) p (hprop-hinhabited _ (η(j , refl)))
r-a : (i j : ₂) → r i ≡ r j → a i ≡ a j
r-a i j q = ap π₀ q
a-s : (i j : ₂) → a i ≡ a j → s(r i) ≡ s(r j)
a-s i j p = ap s (a-r i j p)
s-a : (i j : ₂) → s(r i) ≡ s(r j) → a i ≡ a j
s-a i j p = r-a i j (s-injective (r i) (r j) p)
equal-or-different : (a ₀ ≡ a ₁) + (a ₀ ≡ a ₁ → ∅)
equal-or-different = claim(₂-discrete {s(r ₀)} {s(r ₁)})
where
claim : (s(r ₀) ≡ s(r ₁)) + (s(r ₀) ≡ s(r ₁) → ∅) → (a ₀ ≡ a ₁) + (a ₀ ≡ a ₁ → ∅)
claim (in₀ p) = in₀ (s-a ₀ ₁ p)
claim (in₁ u) = in₁ (λ p → u (a-s ₀ ₁ p))
global-choice-constructive-taboo : ({X : Type} → hinhabited X → X) → (X : Type) → discrete X
global-choice-constructive-taboo global-choice X {a₀} {a₁} = global-choice-lemma X a (λ {x} → global-choice)
where
a : ₂ → X
a ₀ = a₀
a ₁ = a₁
\end{code}
\begin{code}
p→h : {X : Type} → populated₁ X → hinhabited(hinhabited X → X) → hinhabited X
p→h {X} po = hinhabited-elim (hinhabited X → X) (hinhabited X) hprop-hinhabited lemma
where
lemma : (hinhabited X → X) → hinhabited X
lemma s = po (hinhabited X) hprop-hinhabited s η
h→p : {X : Type} → (hinhabited(hinhabited X → X) → hinhabited X) → populated₁ X
h→p {X} φ P h a b = b'(lemma(a ∘ b'))
where
b' : hinhabited X → P
b' = hinhabited-elim X P h b
lemma : (hinhabited X → X) → hinhabited X
lemma = φ ∘ η
\end{code}
\begin{code}
hprop-choice-gives-hypothesis :
((P : Type)(Y : P → Type) → hprop P → ((p : P) → hinhabited(Y p)) → hinhabited((p : P) → Y p))
→ ((X : Type) → hinhabited(hinhabited X → X))
hprop-choice-gives-hypothesis hprop-AC X = hprop-AC (hinhabited X) (λ p → X) hprop-hinhabited id
Σ-hinhabited-shift : {X : Type} {Y : X → Type} → (Σ \(x : X) → hinhabited(Y x)) → hinhabited(Σ \(x : X) → Y x)
Σ-hinhabited-shift {X} {Y} (x , h) = lemma x h
where
lemma : ∀(x : X) → hinhabited(Y x) → hinhabited(Σ \(x : X) → Y x)
lemma x = hinhabited-functor(λ y → (x , y))
hypothesis-gives-hprop-choice :
((X : Type) → hinhabited(hinhabited X → X))
→ (P : Type)(Y : P → Type) → hprop P → ((p : P) → hinhabited(Y p)) → hinhabited((p : P) → Y p)
hypothesis-gives-hprop-choice φ P Y h f = hinhabited-functor claim₅ claim₄
where
X : Type
X = Σ \(p : P) → Y p
φ' : hinhabited(hinhabited X → X)
φ' = φ X
claim₀ : (p : P) → Σ \(p' : P) → hinhabited(Y p')
claim₀ p = (p , f p)
claim₁ : P → hinhabited X
claim₁ p = Σ-hinhabited-shift(claim₀ p)
claim₂ : hinhabited((P → hinhabited X) × (hinhabited X → X))
claim₂ = hinhabited-strength(claim₁ , φ')
claim₃ : (P → hinhabited X) × (hinhabited X → X) → P → X
claim₃ (g , h) = h ∘ g
claim₄ : hinhabited(P → X)
claim₄ = hinhabited-functor claim₃ claim₂
claim₅ : (P → X) → (p : P) → Y p
claim₅ ψ p = transport {P} {Y} e y
where
p' : P
p' = π₀(ψ p)
y : Y p'
y = π₁ (ψ p)
e : p' ≡ p
e = h p' p
\end{code}
\begin{code}
tt-TC : {X : Type}{Y : X → Type}{A : (x : X) → Y x → Type}
→ (∀(x : X) → Σ \(y : Y x) → A x y) → Σ \(f : (x : X) → Y x) → ∀(x : X) → A x (f x)
tt-TC f = (λ x → π₀(f x)) , (λ x → π₁(f x))
∃ : {X : Type}(Y : X → Type) → Type
∃ Y = hinhabited(Σ Y)
hypothesis-gives-hprop-choice' :
((X : Type) → hinhabited(hinhabited X → X))
→ (P : Type)(Y : P → Type) → (A : (p : P) → Y p → Type) → hprop P
→ (∀(p : P) → ∃ \(y : Y p) → A p y) → ∃ \(f : (p : P) → Y p) → ∀(p : P) → A p (f p)
hypothesis-gives-hprop-choice' φ P Y A h = hinhabited-functor tt-TC ∘ hshift
where
hshift : (∀(p : P) → hinhabited(Σ \(y : Y p) → A p y)) → hinhabited(∀(p : P) → Σ \(y : Y p) → A p y)
hshift = hypothesis-gives-hprop-choice φ P (λ p → Σ \(y : Y p) → A p y) h
\end{code}
\begin{code}
hypothesis-gives-funny-choice :
((Z : Type) → hinhabited(hinhabited Z → Z))
→ (X : Type)(Y : X → Type) → ((x : X) → hinhabited(Y x)) → hinhabited(X → Σ \(x : X) → Y x)
hypothesis-gives-funny-choice φ X Y f = claim₄
where
Z : Type
Z = Σ \(x : X) → Y x
φ' : hinhabited(hinhabited Z → Z)
φ' = φ Z
claim₀ : (x : X) → Σ \(x' : X) → hinhabited(Y x')
claim₀ x = (x , f x)
claim₁ : X → hinhabited Z
claim₁ x = Σ-hinhabited-shift(claim₀ x)
claim₂ : hinhabited((X → hinhabited Z) × (hinhabited Z → Z))
claim₂ = hinhabited-strength(claim₁ , φ')
claim₃ : (X → hinhabited Z) × (hinhabited Z → Z) → X → Z
claim₃ (g , h) = h ∘ g
claim₄ : hinhabited(X → Z)
claim₄ = hinhabited-functor claim₃ claim₂
\end{code}
\begin{code}
∥_∥ : Type → Type
∥ X ∥ = hinhabited X
∣_∣ : {X : Type} → X → ∥ X ∥
∣ x ∣ = η x
postulate hprop-hprop : {X : Type} → hprop(hprop X)
\end{code}
\begin{code}
module HoTT-list-discussion
(X : Type)
(f : X → X)
(s : ∥ constant f ∥)
where
\end{code}
\begin{code}
lemma₀ : constant f → hprop(fix f)
lemma₀ = Kraus-Lemma f
lemma₁ : ∥ constant f ∥ → hprop(fix f)
lemma₁ = hinhabited-elim (constant f) (hprop(fix f)) hprop-hprop lemma₀
F : constant f → X → fix f
F κ x = f x , κ x (f x)
G : ∥ constant f ∥ → X → fix f
G s x = hinhabited-elim (constant f) (fix f) (lemma₁ s) (λ κ → F κ x) s
\end{code}
\begin{code}
choice : ∥ X ∥ → X
choice t = π₀ (hinhabited-elim X (fix f) (lemma₁ s) (G s) t)
\end{code}
\begin{code}
g : X → X
g x = π₀(G s x)
g-fixes-f : (x : X) → g x ≡ f(g x)
g-fixes-f x = π₁(G s x)
g-constant : constant g
g-constant x y = ap π₀ p
where
p : G s x ≡ G s y
p = lemma₁ s _ _
g-is-f-truncated : ∥ ((x : X) → g x ≡ f x) ∥
g-is-f-truncated = hinhabited-functor conditional-agreement s
where
conditional-agreement : constant f → (x : X) → g x ≡ f x
conditional-agreement κ x = g-fixes-f x • κ (g x) x
\end{code}