{-# OPTIONS --without-K --exact-split --safe --auto-inline #-}

module HoTT where

open import Universes public

variable
 ๐“ค ๐“ฅ ๐“ฆ ๐“ฃ : Universe

data ๐Ÿ™ : ๐“คโ‚€ ฬ‡  where
 โ‹† : ๐Ÿ™

๐Ÿ™-induction : (A : ๐Ÿ™ โ†’ ๐“คโ€Šฬ‡ ) โ†’ A โ‹† โ†’ (x : ๐Ÿ™) โ†’ A x
๐Ÿ™-induction A a โ‹† = a

๐Ÿ™-recursion : (B : ๐“คโ€Šฬ‡ ) โ†’ B โ†’ (๐Ÿ™ โ†’ B)
๐Ÿ™-recursion B b x = ๐Ÿ™-induction (ฮป _ โ†’ B) b x

!๐Ÿ™' : (X : ๐“คโ€Šฬ‡ ) โ†’ X โ†’ ๐Ÿ™
!๐Ÿ™' X x = โ‹†

!๐Ÿ™ : {X : ๐“คโ€Šฬ‡ } โ†’ X โ†’ ๐Ÿ™
!๐Ÿ™ x = โ‹†

data ๐Ÿ˜ : ๐“คโ‚€โ€Šฬ‡  where

๐Ÿ˜-induction : (A : ๐Ÿ˜ โ†’ ๐“ค ฬ‡ ) โ†’ (x : ๐Ÿ˜) โ†’ A x
๐Ÿ˜-induction A ()

๐Ÿ˜-recursion : (A : ๐“ค ฬ‡ ) โ†’ ๐Ÿ˜ โ†’ A
๐Ÿ˜-recursion A a = ๐Ÿ˜-induction (ฮป _ โ†’ A) a

!๐Ÿ˜ : (A : ๐“ค ฬ‡ ) โ†’ ๐Ÿ˜ โ†’ A
!๐Ÿ˜ = ๐Ÿ˜-recursion

is-empty : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
is-empty X = X โ†’ ๐Ÿ˜

ยฌ : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
ยฌ X = X โ†’ ๐Ÿ˜

data โ„• : ๐“คโ‚€ ฬ‡  where
 zero : โ„•
 succ : โ„• โ†’ โ„•

{-# BUILTIN NATURAL โ„• #-}

โ„•-induction : (A : โ„• โ†’ ๐“ค ฬ‡ )
            โ†’ A 0
            โ†’ ((n : โ„•) โ†’ A n โ†’ A (succ n))
            โ†’ (n : โ„•) โ†’ A n

โ„•-induction A aโ‚€ f = h
 where
  h : (n : โ„•) โ†’ A n
  h 0        = aโ‚€
  h (succ n) = f n (h n)

โ„•-recursion : (X : ๐“ค ฬ‡ )
            โ†’ X
            โ†’ (โ„• โ†’ X โ†’ X)
            โ†’ โ„• โ†’ X

โ„•-recursion X = โ„•-induction (ฮป _ โ†’ X)

โ„•-iteration : (X : ๐“ค ฬ‡ )
            โ†’ X
            โ†’ (X โ†’ X)
            โ†’ โ„• โ†’ X

โ„•-iteration X x f = โ„•-recursion X x (ฮป _ x โ†’ f x)

module Arithmetic where

  _+_  _ร—_ : โ„• โ†’ โ„• โ†’ โ„•

  x + 0      = x
  x + succ y = succ (x + y)

  x ร— 0      = 0
  x ร— succ y = x + x ร— y

  infixl 20 _+_
  infixl 21 _ร—_

module Arithmetic' where

  _+_  _ร—_ : โ„• โ†’ โ„• โ†’ โ„•

  x + y = h y
   where
    h : โ„• โ†’ โ„•
    h = โ„•-iteration โ„• x succ

  x ร— y = h y
   where
    h : โ„• โ†’ โ„•
    h = โ„•-iteration โ„• 0 (x +_)

  infixl 20 _+_
  infixl 21 _ร—_

module โ„•-order where

  _โ‰ค_ _โ‰ฅ_ : โ„• โ†’ โ„• โ†’ ๐“คโ‚€ ฬ‡
  0      โ‰ค y      = ๐Ÿ™
  succ x โ‰ค 0      = ๐Ÿ˜
  succ x โ‰ค succ y = x โ‰ค y

  x โ‰ฅ y = y โ‰ค x

  infix 10 _โ‰ค_
  infix 10 _โ‰ฅ_

data _+_ {๐“ค ๐“ฅ} (X : ๐“ค ฬ‡ ) (Y : ๐“ฅ ฬ‡ ) : ๐“ค โŠ” ๐“ฅ ฬ‡  where
 inl : X โ†’ X + Y
 inr : Y โ†’ X + Y

+-induction : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (A : X + Y โ†’ ๐“ฆ ฬ‡ )
            โ†’ ((x : X) โ†’ A (inl x))
            โ†’ ((y : Y) โ†’ A (inr y))
            โ†’ (z : X + Y) โ†’ A z

+-induction A f g (inl x) = f x
+-induction A f g (inr y) = g y

+-recursion : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {A : ๐“ฆ ฬ‡ } โ†’ (X โ†’ A) โ†’ (Y โ†’ A) โ†’ X + Y โ†’ A
+-recursion {๐“ค} {๐“ฅ} {๐“ฆ} {X} {Y} {A} = +-induction (ฮป _ โ†’ A)

๐Ÿš : ๐“คโ‚€ ฬ‡
๐Ÿš = ๐Ÿ™ + ๐Ÿ™

pattern โ‚€ = inl โ‹†
pattern โ‚ = inr โ‹†

๐Ÿš-induction : (A : ๐Ÿš โ†’ ๐“ค ฬ‡ ) โ†’ A โ‚€ โ†’ A โ‚ โ†’ (n : ๐Ÿš) โ†’ A n
๐Ÿš-induction A aโ‚€ aโ‚ โ‚€ = aโ‚€
๐Ÿš-induction A aโ‚€ aโ‚ โ‚ = aโ‚

๐Ÿš-induction' : (A : ๐Ÿš โ†’ ๐“ค ฬ‡ ) โ†’ A โ‚€ โ†’ A โ‚ โ†’ (n : ๐Ÿš) โ†’ A n
๐Ÿš-induction' A aโ‚€ aโ‚ = +-induction A
                         (๐Ÿ™-induction (ฮป (x : ๐Ÿ™) โ†’ A (inl x)) aโ‚€)
                         (๐Ÿ™-induction (ฮป (y : ๐Ÿ™) โ†’ A (inr y)) aโ‚)

record ฮฃ {๐“ค ๐“ฅ} {X : ๐“ค ฬ‡ } (Y : X โ†’ ๐“ฅ ฬ‡ ) : ๐“ค โŠ” ๐“ฅ ฬ‡  where
  constructor
   _,_
  field
   x : X
   y : Y x

prโ‚ : {X : ๐“ค ฬ‡ } {Y : X โ†’ ๐“ฅ ฬ‡ } โ†’ ฮฃ Y โ†’ X
prโ‚ (x , y) = x

prโ‚‚ : {X : ๐“ค ฬ‡ } {Y : X โ†’ ๐“ฅ ฬ‡ } โ†’ (z : ฮฃ Y) โ†’ Y (prโ‚ z)
prโ‚‚ (x , y) = y

-ฮฃ : {๐“ค ๐“ฅ : Universe} (X : ๐“ค ฬ‡ ) (Y : X โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
-ฮฃ X Y = ฮฃ Y

syntax -ฮฃ X (ฮป x โ†’ y) = ฮฃ x ๊ž‰ X , y

ฮฃ-induction : {X : ๐“ค ฬ‡ } {Y : X โ†’ ๐“ฅ ฬ‡ } {A : ฮฃ Y โ†’ ๐“ฆ ฬ‡ }
            โ†’ ((x : X) (y : Y x) โ†’ A (x , y))
            โ†’ ((x , y) : ฮฃ Y) โ†’ A (x , y)

ฮฃ-induction g (x , y) = g x y

curry : {X : ๐“ค ฬ‡ } {Y : X โ†’ ๐“ฅ ฬ‡ } {A : ฮฃ Y โ†’ ๐“ฆ ฬ‡ }
      โ†’ (((x , y) : ฮฃ Y) โ†’ A (x , y))
      โ†’ ((x : X) (y : Y x) โ†’ A (x , y))

curry f x y = f (x , y)

_ร—_ : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
X ร— Y = ฮฃ x ๊ž‰ X , Y

ฮ  : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
ฮ  {๐“ค} {๐“ฅ} {X} A = (x : X) โ†’ A x

-ฮ  : {๐“ค ๐“ฅ : Universe} (X : ๐“ค ฬ‡ ) (Y : X โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
-ฮ  X Y = ฮ  Y

syntax -ฮ  A (ฮป x โ†’ b) = ฮ  x ๊ž‰ A , b

id : {X : ๐“ค ฬ‡ } โ†’ X โ†’ X
id x = x

๐‘–๐‘‘ : (X : ๐“ค ฬ‡ ) โ†’ X โ†’ X
๐‘–๐‘‘ X = id

_โˆ˜_ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : Y โ†’ ๐“ฆ ฬ‡ }
    โ†’ ((y : Y) โ†’ Z y)
    โ†’ (f : X โ†’ Y)
    โ†’ (x : X) โ†’ Z (f x)

g โˆ˜ f = ฮป x โ†’ g (f x)

domain : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค ฬ‡
domain {๐“ค} {๐“ฅ} {X} {Y} f = X

codomain : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ฅ ฬ‡
codomain {๐“ค} {๐“ฅ} {X} {Y} f = Y

type-of : {X : ๐“ค ฬ‡ } โ†’ X โ†’ ๐“ค ฬ‡
type-of {๐“ค} {X} x = X

data Id {๐“ค} (X : ๐“ค ฬ‡ ) : X โ†’ X โ†’ ๐“ค ฬ‡  where
 refl : (x : X) โ†’ Id X x x

_โ‰ก_ : {X : ๐“ค ฬ‡ } โ†’ X โ†’ X โ†’ ๐“ค ฬ‡
x โ‰ก y = Id _ x y

๐• : (X : ๐“ค ฬ‡ ) (A : (x y : X) โ†’ x โ‰ก y โ†’ ๐“ฅ ฬ‡ )
  โ†’ ((x : X) โ†’ A x x (refl x))
  โ†’ (x y : X) (p : x โ‰ก y) โ†’ A x y p

๐• X A f x x (refl x) = f x

โ„ : {X : ๐“ค ฬ‡ } (x : X) (B : (y : X) โ†’ x โ‰ก y โ†’ ๐“ฅ ฬ‡ )
  โ†’ B x (refl x)
  โ†’ (y : X) (p : x โ‰ก y) โ†’ B y p

โ„ x B b x (refl x) = b

๐•' : (X : ๐“ค ฬ‡ ) (A : (x y : X) โ†’ x โ‰ก y โ†’ ๐“ฅ ฬ‡ )
   โ†’ ((x : X) โ†’ A x x (refl x))
   โ†’ (x y : X) (p : x โ‰ก y) โ†’ A x y p

๐•' X A f x = โ„ x (A x) (f x)

๐•s-agreement : (X : ๐“ค ฬ‡ ) (A : (x y : X) โ†’ x โ‰ก y โ†’ ๐“ฅ ฬ‡ )
               (f : (x : X) โ†’ A x x (refl x)) (x y : X) (p : x โ‰ก y)
             โ†’ ๐• X A f x y p โ‰ก ๐•' X A f x y p

๐•s-agreement X A f x x (refl x) = refl (f x)

transport : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) {x y : X}
          โ†’ x โ‰ก y โ†’ A x โ†’ A y

transport A (refl x) = ๐‘–๐‘‘ (A x)

transport๐• : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) {x y : X}
           โ†’ x โ‰ก y โ†’ A x โ†’ A y

transport๐• {๐“ค} {๐“ฅ} {X} A {x} {y} = ๐• X (ฮป x y _ โ†’ A x โ†’ A y) (ฮป x โ†’ ๐‘–๐‘‘ (A x)) x y

nondep-โ„ : {X : ๐“ค ฬ‡ } (x : X) (A : X โ†’ ๐“ฅ ฬ‡ )
         โ†’ A x โ†’ (y : X) โ†’ x โ‰ก y โ†’ A y
nondep-โ„ x A = โ„ x (ฮป y _ โ†’ A y)

transportโ„ : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) {x y : X}
           โ†’ x โ‰ก y โ†’ A x โ†’ A y
transportโ„ A {x} {y} p a = nondep-โ„ x A a y p

transports-agreement : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) {x y : X} (p : x โ‰ก y)
                     โ†’ (transportโ„ A p โ‰ก transport A p)
                     ร— (transport๐• A p โ‰ก transport A p)

transports-agreement A (refl x) = refl (transport A (refl x)) ,
                                  refl (transport A (refl x))

lhs : {X : ๐“ค ฬ‡ } {x y : X} โ†’ x โ‰ก y โ†’ X
lhs {๐“ค} {X} {x} {y} p = x

rhs : {X : ๐“ค ฬ‡ } {x y : X} โ†’ x โ‰ก y โ†’ X
rhs {๐“ค} {X} {x} {y} p = y

_โˆ™_ : {X : ๐“ค ฬ‡ } {x y z : X} โ†’ x โ‰ก y โ†’ y โ‰ก z โ†’ x โ‰ก z
p โˆ™ q = transport (lhs p โ‰ก_) q p

_โ‰กโŸจ_โŸฉ_ : {X : ๐“ค ฬ‡ } (x : X) {y z : X} โ†’ x โ‰ก y โ†’ y โ‰ก z โ†’ x โ‰ก z
x โ‰กโŸจ p โŸฉ q = p โˆ™ q

_โˆŽ : {X : ๐“ค ฬ‡ } (x : X) โ†’ x โ‰ก x
x โˆŽ = refl x

_โปยน : {X : ๐“ค ฬ‡ } โ†’ {x y : X} โ†’ x โ‰ก y โ†’ y โ‰ก x
p โปยน = transport (_โ‰ก lhs p) p (refl (lhs p))

_โˆ™'_ : {X : ๐“ค ฬ‡ } {x y z : X} โ†’ x โ‰ก y โ†’ y โ‰ก z โ†’ x โ‰ก z
p โˆ™' q = transport (_โ‰ก rhs q) (p โปยน) q

โˆ™agreement : {X : ๐“ค ฬ‡ } {x y z : X} (p : x โ‰ก y) (q : y โ‰ก z)
           โ†’ p โˆ™' q โ‰ก p โˆ™ q

โˆ™agreement (refl x) (refl x) = refl (refl x)

rdnel : {X : ๐“ค ฬ‡ } {x y : X} (p : x โ‰ก y)
      โ†’ p โˆ™ refl y โ‰ก p

rdnel p = refl p

rdner : {X : ๐“ค ฬ‡ } {y z : X} (q : y โ‰ก z)
      โ†’ refl y  โˆ™' q โ‰ก q

rdner q = refl q

ap : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) {x x' : X} โ†’ x โ‰ก x' โ†’ f x โ‰ก f x'
ap f {x} {x'} p = transport (ฮป - โ†’ f x โ‰ก f -) p (refl (f x))

_โˆผ_ : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } โ†’ ฮ  A โ†’ ฮ  A โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
f โˆผ g = โˆ€ x โ†’ f x โ‰ก g x

ยฌยฌ ยฌยฌยฌ : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
ยฌยฌ  A = ยฌ(ยฌ A)
ยฌยฌยฌ A = ยฌ(ยฌยฌ A)

dni : (A : ๐“ค ฬ‡ ) โ†’ A โ†’ ยฌยฌ A
dni A a u = u a

contrapositive : {A : ๐“ค ฬ‡ } {B : ๐“ฅ ฬ‡ } โ†’ (A โ†’ B) โ†’ (ยฌ B โ†’ ยฌ A)
contrapositive f v a = v (f a)

tno : (A : ๐“ค ฬ‡ ) โ†’ ยฌยฌยฌ A โ†’ ยฌ A
tno A = contrapositive (dni A)

_โ‡”_ : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
X โ‡” Y = (X โ†’ Y) ร— (Y โ†’ X)

lr-implication : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ‡” Y) โ†’ (X โ†’ Y)
lr-implication = prโ‚

rl-implication : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ‡” Y) โ†’ (Y โ†’ X)
rl-implication = prโ‚‚

absurdityยณ-is-absurdity : {A : ๐“ค ฬ‡ } โ†’ ยฌยฌยฌ A โ‡” ยฌ A
absurdityยณ-is-absurdity {๐“ค} {A} = firstly , secondly
 where
  firstly : ยฌยฌยฌ A โ†’ ยฌ A
  firstly = contrapositive (dni A)

  secondly : ยฌ A โ†’ ยฌยฌยฌ A
  secondly = dni (ยฌ A)

_โ‰ข_ : {X : ๐“ค ฬ‡ } โ†’ X โ†’ X โ†’ ๐“ค ฬ‡
x โ‰ข y = ยฌ(x โ‰ก y)

โ‰ข-sym : {X : ๐“ค ฬ‡ } {x y : X} โ†’ x โ‰ข y โ†’ y โ‰ข x
โ‰ข-sym {๐“ค} {X} {x} {y} u = ฮป (p : y โ‰ก x) โ†’ u (p โปยน)

Idโ†’Fun : {X Y : ๐“ค ฬ‡ } โ†’ X โ‰ก Y โ†’ X โ†’ Y
Idโ†’Fun {๐“ค} = transport (๐‘–๐‘‘ (๐“ค ฬ‡ ))

Idโ†’Fun' : {X Y : ๐“ค ฬ‡ } โ†’ X โ‰ก Y โ†’ X โ†’ Y
Idโ†’Fun' (refl X) = ๐‘–๐‘‘ X

Idโ†’Funs-agree : {X Y : ๐“ค ฬ‡ } (p : X โ‰ก Y)
              โ†’ Idโ†’Fun p โ‰ก Idโ†’Fun' p

Idโ†’Funs-agree (refl X) = refl (๐‘–๐‘‘ X)

๐Ÿ™-is-not-๐Ÿ˜ : ๐Ÿ™ โ‰ข ๐Ÿ˜
๐Ÿ™-is-not-๐Ÿ˜ p = Idโ†’Fun p โ‹†

โ‚-is-not-โ‚€ : โ‚ โ‰ข โ‚€
โ‚-is-not-โ‚€ p = ๐Ÿ™-is-not-๐Ÿ˜ q
 where
  f : ๐Ÿš โ†’ ๐“คโ‚€ ฬ‡
  f โ‚€ = ๐Ÿ˜
  f โ‚ = ๐Ÿ™

  q : ๐Ÿ™ โ‰ก ๐Ÿ˜
  q = ap f p

โ‚-is-not-โ‚€[not-an-MLTT-proof] : ยฌ(โ‚ โ‰ก โ‚€)
โ‚-is-not-โ‚€[not-an-MLTT-proof] ()

decidable : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
decidable A = A + ยฌ A

has-decidable-equality : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
has-decidable-equality X = (x y : X) โ†’ decidable (x โ‰ก y)

๐Ÿš-has-decidable-equality : has-decidable-equality ๐Ÿš
๐Ÿš-has-decidable-equality โ‚€ โ‚€ = inl (refl โ‚€)
๐Ÿš-has-decidable-equality โ‚€ โ‚ = inr (โ‰ข-sym โ‚-is-not-โ‚€)
๐Ÿš-has-decidable-equality โ‚ โ‚€ = inr โ‚-is-not-โ‚€
๐Ÿš-has-decidable-equality โ‚ โ‚ = inl (refl โ‚)

not-zero-is-one : (n : ๐Ÿš) โ†’ n โ‰ข โ‚€ โ†’ n โ‰ก โ‚
not-zero-is-one โ‚€ f = !๐Ÿ˜ (โ‚€ โ‰ก โ‚) (f (refl โ‚€))
not-zero-is-one โ‚ f = refl โ‚

inl-inr-disjoint-images : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {x : X} {y : Y} โ†’ inl x โ‰ข inr y
inl-inr-disjoint-images {๐“ค} {๐“ฅ} {X} {Y} p = ๐Ÿ™-is-not-๐Ÿ˜ q
 where
  f : X + Y โ†’ ๐“คโ‚€ ฬ‡
  f (inl x) = ๐Ÿ™
  f (inr y) = ๐Ÿ˜

  q : ๐Ÿ™ โ‰ก ๐Ÿ˜
  q = ap f p

right-fails-gives-left-holds : {P : ๐“ค ฬ‡ } {Q : ๐“ฅ ฬ‡ } โ†’ P + Q โ†’ ยฌ Q โ†’ P
right-fails-gives-left-holds (inl p) u = p
right-fails-gives-left-holds (inr q) u = !๐Ÿ˜ _ (u q)

module twin-primes where

 open Arithmetic renaming (_ร—_ to _*_ ; _+_ to _โˆ”_)
 open โ„•-order

 is-prime : โ„• โ†’ ๐“คโ‚€ ฬ‡
 is-prime n = (n โ‰ฅ 2) ร— ((x y : โ„•) โ†’ x * y โ‰ก n โ†’ (x โ‰ก 1) + (x โ‰ก n))

 twin-prime-conjecture : ๐“คโ‚€ ฬ‡
 twin-prime-conjecture = (n : โ„•) โ†’ ฮฃ p ๊ž‰ โ„• , (p โ‰ฅ n)
                                           ร— is-prime p
                                           ร— is-prime (p โˆ” 2)

positive-not-zero : (x : โ„•) โ†’ succ x โ‰ข 0
positive-not-zero x p = ๐Ÿ™-is-not-๐Ÿ˜ (g p)
 where
  f : โ„• โ†’ ๐“คโ‚€ ฬ‡
  f 0        = ๐Ÿ˜
  f (succ x) = ๐Ÿ™

  g : succ x โ‰ก 0 โ†’ ๐Ÿ™ โ‰ก ๐Ÿ˜
  g = ap f

pred : โ„• โ†’ โ„•
pred 0        = 0
pred (succ n) = n

succ-lc : {x y : โ„•} โ†’ succ x โ‰ก succ y โ†’ x โ‰ก y
succ-lc = ap pred

โ„•-has-decidable-equality : has-decidable-equality โ„•
โ„•-has-decidable-equality 0 0               = inl (refl 0)
โ„•-has-decidable-equality 0 (succ y)        = inr (โ‰ข-sym (positive-not-zero y))
โ„•-has-decidable-equality (succ x) 0        = inr (positive-not-zero x)
โ„•-has-decidable-equality (succ x) (succ y) = f (โ„•-has-decidable-equality x y)
 where
  f : decidable (x โ‰ก y) โ†’ decidable (succ x โ‰ก succ y)
  f (inl p) = inl (ap succ p)
  f (inr k) = inr (ฮป (s : succ x โ‰ก succ y) โ†’ k (succ-lc s))

module basic-arithmetic-and-order where

  open โ„•-order public
  open Arithmetic renaming (_+_ to _โˆ”_) hiding (_ร—_)

  +-assoc : (x y z : โ„•) โ†’ (x โˆ” y) โˆ” z โ‰ก x โˆ” (y โˆ” z)

  +-assoc x y 0        = (x โˆ” y) โˆ” 0 โ‰กโŸจ refl _ โŸฉ
                         x โˆ” (y โˆ” 0) โˆŽ

  +-assoc x y (succ z) = (x โˆ” y) โˆ” succ z   โ‰กโŸจ refl _     โŸฉ
                         succ ((x โˆ” y) โˆ” z) โ‰กโŸจ ap succ IH โŸฉ
                         succ (x โˆ” (y โˆ” z)) โ‰กโŸจ refl _     โŸฉ
                         x โˆ” (y โˆ” succ z)   โˆŽ
   where
    IH : (x โˆ” y) โˆ” z โ‰ก x โˆ” (y โˆ” z)
    IH = +-assoc x y z

  +-assoc' : (x y z : โ„•) โ†’ (x โˆ” y) โˆ” z โ‰ก x โˆ” (y โˆ” z)
  +-assoc' x y zero     = refl _
  +-assoc' x y (succ z) = ap succ (+-assoc' x y z)

  +-base-on-first : (x : โ„•) โ†’ 0 โˆ” x โ‰ก x

  +-base-on-first 0        = refl 0

  +-base-on-first (succ x) = 0 โˆ” succ x   โ‰กโŸจ refl _     โŸฉ
                             succ (0 โˆ” x) โ‰กโŸจ ap succ IH โŸฉ
                             succ x       โˆŽ
   where
    IH : 0 โˆ” x โ‰ก x
    IH = +-base-on-first x

  +-step-on-first : (x y : โ„•) โ†’ succ x โˆ” y โ‰ก succ (x โˆ” y)

  +-step-on-first x zero     = refl (succ x)

  +-step-on-first x (succ y) = succ x โˆ” succ y   โ‰กโŸจ refl _     โŸฉ
                               succ (succ x โˆ” y) โ‰กโŸจ ap succ IH โŸฉ
                               succ (x โˆ” succ y) โˆŽ
   where
    IH : succ x โˆ” y โ‰ก succ (x โˆ” y)
    IH = +-step-on-first x y

  +-comm : (x y : โ„•) โ†’ x โˆ” y โ‰ก y โˆ” x

  +-comm 0 y = 0 โˆ” y โ‰กโŸจ +-base-on-first y โŸฉ
               y     โ‰กโŸจ refl _ โŸฉ
               y โˆ” 0 โˆŽ

  +-comm (succ x) y = succ x โˆ” y  โ‰กโŸจ +-step-on-first x y โŸฉ
                      succ(x โˆ” y) โ‰กโŸจ ap succ IH          โŸฉ
                      succ(y โˆ” x) โ‰กโŸจ refl _              โŸฉ
                      y โˆ” succ x  โˆŽ
    where
     IH : x โˆ” y โ‰ก y โˆ” x
     IH = +-comm x y

  +-lc : (x y z : โ„•) โ†’ x โˆ” y โ‰ก x โˆ” z โ†’ y โ‰ก z

  +-lc 0        y z p = y     โ‰กโŸจ (+-base-on-first y)โปยน โŸฉ
                        0 โˆ” y โ‰กโŸจ p                     โŸฉ
                        0 โˆ” z โ‰กโŸจ +-base-on-first z     โŸฉ
                        z     โˆŽ

  +-lc (succ x) y z p = IH
   where
    q = succ (x โˆ” y) โ‰กโŸจ (+-step-on-first x y)โปยน โŸฉ
        succ x โˆ” y   โ‰กโŸจ p                       โŸฉ
        succ x โˆ” z   โ‰กโŸจ +-step-on-first x z     โŸฉ
        succ (x โˆ” z) โˆŽ

    IH : y โ‰ก z
    IH = +-lc x y z (succ-lc q)

  _โ‰ผ_ : โ„• โ†’ โ„• โ†’ ๐“คโ‚€ ฬ‡
  x โ‰ผ y = ฮฃ z ๊ž‰ โ„• , x โˆ” z โ‰ก y

  โ‰ค-gives-โ‰ผ : (x y : โ„•) โ†’ x โ‰ค y โ†’ x โ‰ผ y
  โ‰ค-gives-โ‰ผ 0 0               l = 0 , refl 0
  โ‰ค-gives-โ‰ผ 0 (succ y)        l = succ y , +-base-on-first (succ y)
  โ‰ค-gives-โ‰ผ (succ x) 0        l = !๐Ÿ˜ (succ x โ‰ผ zero) l
  โ‰ค-gives-โ‰ผ (succ x) (succ y) l = ฮณ
   where
    IH : x โ‰ผ y
    IH = โ‰ค-gives-โ‰ผ x y l

    z : โ„•
    z = prโ‚ IH

    p : x โˆ” z โ‰ก y
    p = prโ‚‚ IH

    ฮณ : succ x โ‰ผ succ y
    ฮณ = z , (succ x โˆ” z   โ‰กโŸจ +-step-on-first x z โŸฉ
             succ (x โˆ” z) โ‰กโŸจ ap succ p           โŸฉ
             succ y       โˆŽ)

  โ‰ผ-gives-โ‰ค : (x y : โ„•) โ†’ x โ‰ผ y โ†’ x โ‰ค y

  โ‰ผ-gives-โ‰ค 0 0               (z , p) = โ‹†

  โ‰ผ-gives-โ‰ค 0 (succ y)        (z , p) = โ‹†

  โ‰ผ-gives-โ‰ค (succ x) 0        (z , p) = positive-not-zero (x โˆ” z) q
   where
    q = succ (x โˆ” z) โ‰กโŸจ (+-step-on-first x z)โปยน โŸฉ
        succ x โˆ” z   โ‰กโŸจ p                       โŸฉ
        zero         โˆŽ

  โ‰ผ-gives-โ‰ค (succ x) (succ y) (z , p) = IH
   where
    q = succ (x โˆ” z) โ‰กโŸจ (+-step-on-first x z)โปยน โŸฉ
        succ x โˆ” z   โ‰กโŸจ p                       โŸฉ
        succ y       โˆŽ

    IH : x โ‰ค y
    IH = โ‰ผ-gives-โ‰ค x y (z , succ-lc q)

  โ‰ค-refl : (n : โ„•) โ†’ n โ‰ค n
  โ‰ค-refl zero     = โ‹†
  โ‰ค-refl (succ n) = โ‰ค-refl n

  โ‰ค-trans : (l m n : โ„•) โ†’ l โ‰ค m โ†’ m โ‰ค n โ†’ l โ‰ค n
  โ‰ค-trans zero     m        n        p q = โ‹†
  โ‰ค-trans (succ l) zero     n        p q = !๐Ÿ˜ (succ l โ‰ค n) p
  โ‰ค-trans (succ l) (succ m) zero     p q = q
  โ‰ค-trans (succ l) (succ m) (succ n) p q = โ‰ค-trans l m n p q

  โ‰ค-anti : (m n : โ„•) โ†’ m โ‰ค n โ†’ n โ‰ค m โ†’ m โ‰ก n
  โ‰ค-anti zero     zero     p q = refl zero
  โ‰ค-anti zero     (succ n) p q = !๐Ÿ˜ (zero โ‰ก succ n) q
  โ‰ค-anti (succ m) zero     p q = !๐Ÿ˜ (succ m โ‰ก zero) p
  โ‰ค-anti (succ m) (succ n) p q = ap succ (โ‰ค-anti m n p q)

  โ‰ค-succ : (n : โ„•) โ†’ n โ‰ค succ n
  โ‰ค-succ zero     = โ‹†
  โ‰ค-succ (succ n) = โ‰ค-succ n

  zero-minimal : (n : โ„•) โ†’ zero โ‰ค n
  zero-minimal n = โ‹†

  unique-minimal : (n : โ„•) โ†’ n โ‰ค zero โ†’ n โ‰ก zero
  unique-minimal zero     p = refl zero
  unique-minimal (succ n) p = !๐Ÿ˜ (succ n โ‰ก zero) p

  โ‰ค-split : (m n : โ„•) โ†’ m โ‰ค succ n โ†’ (m โ‰ค n) + (m โ‰ก succ n)
  โ‰ค-split zero     n        l = inl l
  โ‰ค-split (succ m) zero     l = inr (ap succ (unique-minimal m l))
  โ‰ค-split (succ m) (succ n) l = +-recursion inl (inr โˆ˜ ap succ) (โ‰ค-split m n l)

  _<_ : โ„• โ†’ โ„• โ†’ ๐“คโ‚€ ฬ‡
  x < y = succ x โ‰ค y

  infix 10 _<_

  not-<-gives-โ‰ฅ : (m n : โ„•) โ†’ ยฌ(n < m) โ†’ m โ‰ค n
  not-<-gives-โ‰ฅ zero     n        u = zero-minimal n
  not-<-gives-โ‰ฅ (succ m) zero     u = dni (zero < succ m) (zero-minimal m) u
  not-<-gives-โ‰ฅ (succ m) (succ n) u = not-<-gives-โ‰ฅ m n u

  bounded-โˆ€-next : (A : โ„• โ†’ ๐“ค ฬ‡ ) (k : โ„•)
                 โ†’ A k
                 โ†’ ((n : โ„•) โ†’ n < k โ†’ A n)
                 โ†’ (n : โ„•) โ†’ n < succ k โ†’ A n
  bounded-โˆ€-next A k a ฯ† n l = +-recursion f g s
   where
    s : (n < k) + (succ n โ‰ก succ k)
    s = โ‰ค-split (succ n) k l

    f : n < k โ†’ A n
    f = ฯ† n

    g : succ n โ‰ก succ k โ†’ A n
    g p = transport A ((succ-lc p)โปยน) a

  root : (โ„• โ†’ โ„•) โ†’ ๐“คโ‚€ ฬ‡
  root f = ฮฃ n ๊ž‰ โ„• , f n โ‰ก 0

  _has-no-root<_ : (โ„• โ†’ โ„•) โ†’ โ„• โ†’ ๐“คโ‚€ ฬ‡
  f has-no-root< k = (n : โ„•) โ†’ n < k โ†’ f n โ‰ข 0

  is-minimal-root : (โ„• โ†’ โ„•) โ†’ โ„• โ†’ ๐“คโ‚€ ฬ‡
  is-minimal-root f m = (f m โ‰ก 0) ร— (f has-no-root< m)

  at-most-one-minimal-root : (f : โ„• โ†’ โ„•) (m n : โ„•)
                           โ†’ is-minimal-root f m โ†’ is-minimal-root f n โ†’ m โ‰ก n

  at-most-one-minimal-root f m n (p , ฯ†) (q , ฯˆ) = c m n a b
   where
    a : ยฌ(m < n)
    a u = ฯˆ m u p

    b : ยฌ(n < m)
    b v = ฯ† n v q

    c : (m n : โ„•) โ†’ ยฌ(m < n) โ†’ ยฌ(n < m) โ†’ m โ‰ก n
    c m n u v = โ‰ค-anti m n (not-<-gives-โ‰ฅ m n v) (not-<-gives-โ‰ฅ n m u)

  minimal-root : (โ„• โ†’ โ„•) โ†’ ๐“คโ‚€ ฬ‡
  minimal-root f = ฮฃ m ๊ž‰ โ„• , is-minimal-root f m

  minimal-root-is-root : โˆ€ f โ†’ minimal-root f โ†’ root f
  minimal-root-is-root f (m , p , _) = m , p

  bounded-โ„•-search : โˆ€ k f โ†’ (minimal-root f) + (f has-no-root< k)
  bounded-โ„•-search zero f = inr (ฮป n โ†’ !๐Ÿ˜ (f n โ‰ข 0))
  bounded-โ„•-search (succ k) f = +-recursion ฯ† ฮณ (bounded-โ„•-search k f)
   where
    A : โ„• โ†’ (โ„• โ†’ โ„•) โ†’ ๐“คโ‚€ ฬ‡
    A k f = (minimal-root f) + (f has-no-root< k)

    ฯ† : minimal-root f โ†’ A (succ k) f
    ฯ† = inl

    ฮณ : f has-no-root< k โ†’ A (succ k) f
    ฮณ u = +-recursion ฮณโ‚€ ฮณโ‚ (โ„•-has-decidable-equality (f k) 0)
     where
      ฮณโ‚€ : f k โ‰ก 0 โ†’ A (succ k) f
      ฮณโ‚€ p = inl (k , p , u)

      ฮณโ‚ : f k โ‰ข 0 โ†’ A (succ k) f
      ฮณโ‚ v = inr (bounded-โˆ€-next (ฮป n โ†’ f n โ‰ข 0) k v u)

  root-gives-minimal-root : โˆ€ f โ†’ root f โ†’ minimal-root f
  root-gives-minimal-root f (n , p) = ฮณ
   where
    g : ยฌ(f has-no-root< (succ n))
    g ฯ† = ฯ† n (โ‰ค-refl n) p

    ฮณ : minimal-root f
    ฮณ = right-fails-gives-left-holds (bounded-โ„•-search (succ n) f) g

is-singleton : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
is-singleton X = ฮฃ c ๊ž‰ X , ((x : X) โ†’ c โ‰ก x)

is-center : (X : ๐“ค ฬ‡ ) โ†’ X โ†’ ๐“ค ฬ‡
is-center X c = (x : X) โ†’ c โ‰ก x

๐Ÿ™-is-singleton : is-singleton ๐Ÿ™
๐Ÿ™-is-singleton = โ‹† , ๐Ÿ™-induction (ฮป x โ†’ โ‹† โ‰ก x) (refl โ‹†)

center : (X : ๐“ค ฬ‡ ) โ†’ is-singleton X โ†’ X
center X (c , ฯ†) = c

centrality : (X : ๐“ค ฬ‡ ) (i : is-singleton X) (x : X) โ†’ center X i โ‰ก x
centrality X (c , ฯ†) = ฯ†

is-subsingleton : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
is-subsingleton X = (x y : X) โ†’ x โ‰ก y

๐Ÿ˜-is-subsingleton : is-subsingleton ๐Ÿ˜
๐Ÿ˜-is-subsingleton x y = !๐Ÿ˜ (x โ‰ก y) x

singletons-are-subsingletons : (X : ๐“ค ฬ‡ ) โ†’ is-singleton X โ†’ is-subsingleton X
singletons-are-subsingletons X (c , ฯ†) x y = x โ‰กโŸจ (ฯ† x)โปยน โŸฉ
                                             c โ‰กโŸจ ฯ† y     โŸฉ
                                             y โˆŽ

๐Ÿ™-is-subsingleton : is-subsingleton ๐Ÿ™
๐Ÿ™-is-subsingleton = singletons-are-subsingletons ๐Ÿ™ ๐Ÿ™-is-singleton

pointed-subsingletons-are-singletons : (X : ๐“ค ฬ‡ )
                                     โ†’ X โ†’ is-subsingleton X โ†’ is-singleton X

pointed-subsingletons-are-singletons X x s = (x , s x)

singleton-iff-pointed-and-subsingleton : {X : ๐“ค ฬ‡ }
                                       โ†’ is-singleton X โ‡” (X ร— is-subsingleton X)

singleton-iff-pointed-and-subsingleton {๐“ค} {X} = (a , b)
 where
  a : is-singleton X โ†’ X ร— is-subsingleton X
  a s = center X s , singletons-are-subsingletons X s

  b : X ร— is-subsingleton X โ†’ is-singleton X
  b (x , t) = pointed-subsingletons-are-singletons X x t

is-prop is-truth-value : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
is-prop        = is-subsingleton
is-truth-value = is-subsingleton

is-set : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
is-set X = (x y : X) โ†’ is-subsingleton (x โ‰ก y)

EM EM' : โˆ€ ๐“ค โ†’ ๐“ค โบ ฬ‡
EM  ๐“ค = (X : ๐“ค ฬ‡ ) โ†’ is-subsingleton X โ†’ X + ยฌ X
EM' ๐“ค = (X : ๐“ค ฬ‡ ) โ†’ is-subsingleton X โ†’ is-singleton X + is-empty X

EM-gives-EM' : EM ๐“ค โ†’ EM' ๐“ค
EM-gives-EM' em X s = ฮณ (em X s)
 where
  ฮณ : X + ยฌ X โ†’ is-singleton X + is-empty X
  ฮณ (inl x) = inl (pointed-subsingletons-are-singletons X x s)
  ฮณ (inr x) = inr x

EM'-gives-EM : EM' ๐“ค โ†’ EM ๐“ค
EM'-gives-EM em' X s = ฮณ (em' X s)
 where
  ฮณ : is-singleton X + is-empty X โ†’ X + ยฌ X
  ฮณ (inl i) = inl (center X i)
  ฮณ (inr x) = inr x

no-unicorns : ยฌ(ฮฃ X ๊ž‰ ๐“ค ฬ‡ , is-subsingleton X ร— ยฌ(is-singleton X) ร— ยฌ(is-empty X))
no-unicorns (X , i , f , g) = c
 where
  e : is-empty X
  e x = f (pointed-subsingletons-are-singletons X x i)

  c : ๐Ÿ˜
  c = g e

module magmas where

 Magma : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
 Magma ๐“ค = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , is-set X ร— (X โ†’ X โ†’ X)

 โŸจ_โŸฉ : Magma ๐“ค โ†’ ๐“ค ฬ‡
 โŸจ X , i , _ยท_ โŸฉ = X

 magma-is-set : (M : Magma ๐“ค) โ†’ is-set โŸจ M โŸฉ
 magma-is-set (X , i , _ยท_) = i

 magma-operation : (M : Magma ๐“ค) โ†’ โŸจ M โŸฉ โ†’ โŸจ M โŸฉ โ†’ โŸจ M โŸฉ
 magma-operation (X , i , _ยท_) = _ยท_

 syntax magma-operation M x y = x ยทโŸจ M โŸฉ y

 is-magma-hom : (M N : Magma ๐“ค) โ†’ (โŸจ M โŸฉ โ†’ โŸจ N โŸฉ) โ†’ ๐“ค ฬ‡
 is-magma-hom M N f = (x y : โŸจ M โŸฉ) โ†’ f (x ยทโŸจ M โŸฉ y) โ‰ก f x ยทโŸจ N โŸฉ f y

 id-is-magma-hom : (M : Magma ๐“ค) โ†’ is-magma-hom M M (๐‘–๐‘‘ โŸจ M โŸฉ)
 id-is-magma-hom M = ฮป (x y : โŸจ M โŸฉ) โ†’ refl (x ยทโŸจ M โŸฉ y)

 is-magma-iso : (M N : Magma ๐“ค) โ†’ (โŸจ M โŸฉ โ†’ โŸจ N โŸฉ) โ†’ ๐“ค ฬ‡
 is-magma-iso M N f = is-magma-hom M N f
                    ร— (ฮฃ g ๊ž‰ (โŸจ N โŸฉ โ†’ โŸจ M โŸฉ), is-magma-hom N M g
                                            ร— (g โˆ˜ f โˆผ ๐‘–๐‘‘ โŸจ M โŸฉ)
                                            ร— (f โˆ˜ g โˆผ ๐‘–๐‘‘ โŸจ N โŸฉ))

 id-is-magma-iso : (M : Magma ๐“ค) โ†’ is-magma-iso M M (๐‘–๐‘‘ โŸจ M โŸฉ)
 id-is-magma-iso M = id-is-magma-hom M ,
                     ๐‘–๐‘‘ โŸจ M โŸฉ ,
                     id-is-magma-hom M ,
                     refl ,
                     refl

 Idโ†’iso : {M N : Magma ๐“ค} โ†’ M โ‰ก N โ†’ โŸจ M โŸฉ โ†’ โŸจ N โŸฉ
 Idโ†’iso p = transport โŸจ_โŸฉ p

 Idโ†’iso-is-iso : {M N : Magma ๐“ค} (p : M โ‰ก N) โ†’ is-magma-iso M N (Idโ†’iso p)
 Idโ†’iso-is-iso (refl M) = id-is-magma-iso M

 _โ‰…โ‚˜_ : Magma ๐“ค โ†’ Magma ๐“ค โ†’ ๐“ค ฬ‡
 M โ‰…โ‚˜ N = ฮฃ f ๊ž‰ (โŸจ M โŸฉ โ†’ โŸจ N โŸฉ), is-magma-iso M N f

 magma-Idโ†’iso : {M N : Magma ๐“ค} โ†’ M โ‰ก N โ†’ M โ‰…โ‚˜ N
 magma-Idโ†’iso p = (Idโ†’iso p , Idโ†’iso-is-iso p)

 โˆž-Magma : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
 โˆž-Magma ๐“ค = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , (X โ†’ X โ†’ X)

module monoids where

 left-neutral : {X : ๐“ค ฬ‡ } โ†’ X โ†’ (X โ†’ X โ†’ X) โ†’ ๐“ค ฬ‡
 left-neutral e _ยท_ = โˆ€ x โ†’ e ยท x โ‰ก x

 right-neutral : {X : ๐“ค ฬ‡ } โ†’ X โ†’ (X โ†’ X โ†’ X) โ†’ ๐“ค ฬ‡
 right-neutral e _ยท_ = โˆ€ x โ†’ x ยท e โ‰ก x

 associative : {X : ๐“ค ฬ‡ } โ†’ (X โ†’ X โ†’ X) โ†’ ๐“ค ฬ‡
 associative _ยท_ = โˆ€ x y z โ†’ (x ยท y) ยท z โ‰ก x ยท (y ยท z)

 Monoid : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
 Monoid ๐“ค = ฮฃ X ๊ž‰ ๐“ค  ฬ‡ , is-set X
                      ร— (ฮฃ ยท ๊ž‰ (X โ†’ X โ†’ X) , (ฮฃ e ๊ž‰ X , (left-neutral e ยท)
                                                      ร— (right-neutral e ยท)
                                                      ร— (associative ยท)))

refl-left : {X : ๐“ค ฬ‡ } {x y : X} {p : x โ‰ก y} โ†’ refl x โˆ™ p โ‰ก p
refl-left {๐“ค} {X} {x} {x} {refl x} = refl (refl x)

refl-right : {X : ๐“ค ฬ‡ } {x y : X} {p : x โ‰ก y} โ†’ p โˆ™ refl y โ‰ก p
refl-right {๐“ค} {X} {x} {y} {p} = refl p

โˆ™assoc : {X : ๐“ค ฬ‡ } {x y z t : X} (p : x โ‰ก y) (q : y โ‰ก z) (r : z โ‰ก t)
       โ†’ (p โˆ™ q) โˆ™ r โ‰ก p โˆ™ (q โˆ™ r)

โˆ™assoc p q (refl z) = refl (p โˆ™ q)

โปยน-leftโˆ™ : {X : ๐“ค ฬ‡ } {x y : X} (p : x โ‰ก y)
         โ†’ p โปยน โˆ™ p โ‰ก refl y

โปยน-leftโˆ™ (refl x) = refl (refl x)

โปยน-rightโˆ™ : {X : ๐“ค ฬ‡ } {x y : X} (p : x โ‰ก y)
          โ†’ p โˆ™ p โปยน โ‰ก refl x

โปยน-rightโˆ™ (refl x) = refl (refl x)

โปยน-involutive : {X : ๐“ค ฬ‡ } {x y : X} (p : x โ‰ก y)
              โ†’ (p โปยน)โปยน โ‰ก p

โปยน-involutive (refl x) = refl (refl x)

ap-refl : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) (x : X)
        โ†’ ap f (refl x) โ‰ก refl (f x)

ap-refl f x = refl (refl (f x))

ap-โˆ™ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) {x y z : X} (p : x โ‰ก y) (q : y โ‰ก z)
     โ†’ ap f (p โˆ™ q) โ‰ก ap f p โˆ™ ap f q

ap-โˆ™ f p (refl y) = refl (ap f p)

apโปยน : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) {x y : X} (p : x โ‰ก y)
     โ†’ (ap f p)โปยน โ‰ก ap f (p โปยน)

apโปยน f (refl x) = refl (refl (f x))

ap-id : {X : ๐“ค ฬ‡ } {x y : X} (p : x โ‰ก y)
      โ†’ ap id p โ‰ก p

ap-id (refl x) = refl (refl x)

ap-โˆ˜ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ }
       (f : X โ†’ Y) (g : Y โ†’ Z) {x y : X} (p : x โ‰ก y)
     โ†’ ap (g โˆ˜ f) p โ‰ก (ap g โˆ˜ ap f) p

ap-โˆ˜ f g (refl x) = refl (refl (g (f x)))

transportโˆ™ : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) {x y z : X} (p : x โ‰ก y) (q : y โ‰ก z)
           โ†’ transport A (p โˆ™ q) โ‰ก transport A q โˆ˜ transport A p

transportโˆ™ A p (refl y) = refl (transport A p)

Nat : {X : ๐“ค ฬ‡ } โ†’ (X โ†’ ๐“ฅ ฬ‡ ) โ†’ (X โ†’ ๐“ฆ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ โŠ” ๐“ฆ ฬ‡
Nat A B = (x : domain A) โ†’ A x โ†’ B x

Nats-are-natural : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (B : X โ†’ ๐“ฆ ฬ‡ ) (ฯ„ : Nat A B)
                 โ†’ {x y : X} (p : x โ‰ก y)
                 โ†’ ฯ„ y โˆ˜ transport A p โ‰ก transport B p โˆ˜ ฯ„ x

Nats-are-natural A B ฯ„ (refl x) = refl (ฯ„ x)

Natฮฃ : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {B : X โ†’ ๐“ฆ ฬ‡ } โ†’ Nat A B โ†’ ฮฃ A โ†’ ฮฃ B
Natฮฃ ฯ„ (x , a) = (x , ฯ„ x a)

transport-ap : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (A : Y โ†’ ๐“ฆ ฬ‡ )
               (f : X โ†’ Y) {x x' : X} (p : x โ‰ก x') (a : A (f x))
             โ†’ transport (A โˆ˜ f) p a โ‰ก transport A (ap f p) a

transport-ap A f (refl x) a = refl a

data Color : ๐“คโ‚€ ฬ‡  where
 Black White : Color

apd : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } (f : (x : X) โ†’ A x) {x y : X}
      (p : x โ‰ก y) โ†’ transport A p (f x) โ‰ก f y

apd f (refl x) = refl (f x)

to-ฮฃ-โ‰ก : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {ฯƒ ฯ„ : ฮฃ A}
       โ†’ (ฮฃ p ๊ž‰ prโ‚ ฯƒ โ‰ก prโ‚ ฯ„ , transport A p (prโ‚‚ ฯƒ) โ‰ก prโ‚‚ ฯ„)
       โ†’ ฯƒ โ‰ก ฯ„

to-ฮฃ-โ‰ก (refl x , refl a) = refl (x , a)

from-ฮฃ-โ‰ก : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {ฯƒ ฯ„ : ฮฃ A}
         โ†’ ฯƒ โ‰ก ฯ„
         โ†’ ฮฃ p ๊ž‰ prโ‚ ฯƒ โ‰ก prโ‚ ฯ„ , transport A p (prโ‚‚ ฯƒ) โ‰ก prโ‚‚ ฯ„

from-ฮฃ-โ‰ก (refl (x , a)) = (refl x , refl a)

to-ฮฃ-โ‰ก-again : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {(x , a) (y , b) : ฮฃ A}
             โ†’ ฮฃ p ๊ž‰ x โ‰ก y , transport A p a โ‰ก b
             โ†’ (x , a) โ‰ก (y , b)

to-ฮฃ-โ‰ก-again (refl x , refl a) = refl (x , a)

from-ฮฃ-โ‰ก-again : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {(x , a) (y , b) : ฮฃ A}
               โ†’ (x , a) โ‰ก (y , b)
               โ†’ ฮฃ p ๊ž‰ x โ‰ก y , transport A p a โ‰ก b

from-ฮฃ-โ‰ก-again (refl (x , a)) = (refl x , refl a)

to-ฮฃ-โ‰ก' : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {x : X} {a a' : A x}
        โ†’ a โ‰ก a' โ†’ Id (ฮฃ A) (x , a) (x , a')

to-ฮฃ-โ‰ก' {๐“ค} {๐“ฅ} {X} {A} {x} = ap (ฮป - โ†’ (x , -))

transport-ร— : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (B : X โ†’ ๐“ฆ ฬ‡ )
              {x y : X} (p : x โ‰ก y) {(a , b) : A x ร— B x}

            โ†’ transport (ฮป x โ†’ A x ร— B x) p (a , b)
            โ‰ก (transport A p a , transport B p b)

transport-ร— A B (refl _) = refl _

transportd : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (B : (x : X) โ†’ A x โ†’ ๐“ฆ ฬ‡ )
             {x : X} ((a , b) : ฮฃ a ๊ž‰ A x , B x a) {y : X} (p : x โ‰ก y)
           โ†’ B x a โ†’ B y (transport A p a)

transportd A B (a , b) (refl x) = id

transport-ฮฃ : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (B : (x : X) โ†’ A x โ†’ ๐“ฆ ฬ‡ )
              {x : X} {y : X} (p : x โ‰ก y) {(a , b) : ฮฃ a ๊ž‰ A x , B x a}

            โ†’ transport (ฮป - โ†’ ฮฃ (B -)) p (a , b)
            โ‰ก transport A p a , transportd A B (a , b) p b

transport-ฮฃ A B (refl x) {a , b} = refl (a , b)

_is-of-hlevel_ : ๐“ค ฬ‡ โ†’ โ„• โ†’ ๐“ค ฬ‡
X is-of-hlevel 0        = is-singleton X
X is-of-hlevel (succ n) = (x x' : X) โ†’ ((x โ‰ก x') is-of-hlevel n)

wconstant : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
wconstant f = (x x' : domain f) โ†’ f x โ‰ก f x'

wconstant-endomap : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
wconstant-endomap X = ฮฃ f ๊ž‰ (X โ†’ X), wconstant f

wcmap : (X : ๐“ค ฬ‡ ) โ†’ wconstant-endomap X โ†’ (X โ†’ X)
wcmap X (f , w) = f

wcmap-constancy : (X : ๐“ค ฬ‡ ) (c : wconstant-endomap X)
                โ†’ wconstant (wcmap X c)
wcmap-constancy X (f , w) = w

Hedberg : {X : ๐“ค ฬ‡ } (x : X)
        โ†’ ((y : X) โ†’ wconstant-endomap (x โ‰ก y))
        โ†’ (y : X) โ†’ is-subsingleton (x โ‰ก y)

Hedberg {๐“ค} {X} x c y p q =

 p                         โ‰กโŸจ a y p                                     โŸฉ
 (f x (refl x))โปยน โˆ™ f y p  โ‰กโŸจ ap (ฮป - โ†’ (f x (refl x))โปยน โˆ™ -) (ฮบ y p q) โŸฉ
 (f x (refl x))โปยน โˆ™ f y q  โ‰กโŸจ (a y q)โปยน                                 โŸฉ
 q                         โˆŽ

 where
  f : (y : X) โ†’ x โ‰ก y โ†’ x โ‰ก y
  f y = wcmap (x โ‰ก y) (c y)

  ฮบ : (y : X) (p q : x โ‰ก y) โ†’ f y p โ‰ก f y q
  ฮบ y = wcmap-constancy (x โ‰ก y) (c y)

  a : (y : X) (p : x โ‰ก y) โ†’ p โ‰ก (f x (refl x))โปยน โˆ™ f y p
  a x (refl x) = (โปยน-leftโˆ™ (f x (refl x)))โปยน

wconstant-โ‰ก-endomaps : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
wconstant-โ‰ก-endomaps X = (x y : X) โ†’ wconstant-endomap (x โ‰ก y)

sets-have-wconstant-โ‰ก-endomaps : (X : ๐“ค ฬ‡ ) โ†’ is-set X โ†’ wconstant-โ‰ก-endomaps X
sets-have-wconstant-โ‰ก-endomaps X s x y = (f , ฮบ)
 where
  f : x โ‰ก y โ†’ x โ‰ก y
  f p = p

  ฮบ : (p q : x โ‰ก y) โ†’ f p โ‰ก f q
  ฮบ p q = s x y p q

types-with-wconstant-โ‰ก-endomaps-are-sets : (X : ๐“ค ฬ‡ )
                                         โ†’ wconstant-โ‰ก-endomaps X โ†’ is-set X

types-with-wconstant-โ‰ก-endomaps-are-sets X c x = Hedberg x
                                                  (ฮป y โ†’ wcmap (x โ‰ก y) (c x y) ,
                                                   wcmap-constancy (x โ‰ก y) (c x y))

subsingletons-have-wconstant-โ‰ก-endomaps : (X : ๐“ค ฬ‡ )
                                        โ†’ is-subsingleton X
                                        โ†’ wconstant-โ‰ก-endomaps X

subsingletons-have-wconstant-โ‰ก-endomaps X s x y = (f , ฮบ)
 where
  f : x โ‰ก y โ†’ x โ‰ก y
  f p = s x y

  ฮบ : (p q : x โ‰ก y) โ†’ f p โ‰ก f q
  ฮบ p q = refl (s x y)

subsingletons-are-sets : (X : ๐“ค ฬ‡ ) โ†’ is-subsingleton X โ†’ is-set X
subsingletons-are-sets X s = types-with-wconstant-โ‰ก-endomaps-are-sets X
                               (subsingletons-have-wconstant-โ‰ก-endomaps X s)

singletons-are-sets : (X : ๐“ค ฬ‡ ) โ†’ is-singleton X โ†’ is-set X
singletons-are-sets X = subsingletons-are-sets X โˆ˜ singletons-are-subsingletons X

๐Ÿ˜-is-set : is-set ๐Ÿ˜
๐Ÿ˜-is-set = subsingletons-are-sets ๐Ÿ˜ ๐Ÿ˜-is-subsingleton

๐Ÿ™-is-set : is-set ๐Ÿ™
๐Ÿ™-is-set = subsingletons-are-sets ๐Ÿ™ ๐Ÿ™-is-subsingleton

subsingletons-are-of-hlevel-1 : (X : ๐“ค ฬ‡ )
                              โ†’ is-subsingleton X
                              โ†’ X is-of-hlevel 1

subsingletons-are-of-hlevel-1 X = g
 where
  g : ((x y : X) โ†’ x โ‰ก y) โ†’ (x y : X) โ†’ is-singleton (x โ‰ก y)
  g t x y = t x y , subsingletons-are-sets X t x y (t x y)

types-of-hlevel-1-are-subsingletons : (X : ๐“ค ฬ‡ )
                                    โ†’ X is-of-hlevel 1
                                    โ†’ is-subsingleton X

types-of-hlevel-1-are-subsingletons X = f
 where
  f : ((x y : X) โ†’ is-singleton (x โ‰ก y)) โ†’ (x y : X) โ†’ x โ‰ก y
  f s x y = center (x โ‰ก y) (s x y)

sets-are-of-hlevel-2 : (X : ๐“ค ฬ‡ ) โ†’ is-set X โ†’ X is-of-hlevel 2
sets-are-of-hlevel-2 X = g
 where
  g : ((x y : X) โ†’ is-subsingleton (x โ‰ก y)) โ†’ (x y : X) โ†’ (x โ‰ก y) is-of-hlevel 1
  g t x y = subsingletons-are-of-hlevel-1 (x โ‰ก y) (t x y)

types-of-hlevel-2-are-sets : (X : ๐“ค ฬ‡ ) โ†’ X is-of-hlevel 2 โ†’ is-set X
types-of-hlevel-2-are-sets X = f
 where
  f : ((x y : X) โ†’ (x โ‰ก y) is-of-hlevel 1) โ†’ (x y : X) โ†’ is-subsingleton (x โ‰ก y)
  f s x y = types-of-hlevel-1-are-subsingletons (x โ‰ก y) (s x y)

hlevel-upper : (X : ๐“ค ฬ‡ ) (n : โ„•) โ†’ X is-of-hlevel n โ†’ X is-of-hlevel (succ n)
hlevel-upper X zero = ฮณ
 where
  ฮณ : is-singleton X โ†’ (x y : X) โ†’ is-singleton (x โ‰ก y)
  ฮณ h x y = p , subsingletons-are-sets X k x y p
   where
    k : is-subsingleton X
    k = singletons-are-subsingletons X h

    p : x โ‰ก y
    p = k x y

hlevel-upper X (succ n) = ฮป h x y โ†’ hlevel-upper (x โ‰ก y) n (h x y)

_has-minimal-hlevel_ : ๐“ค ฬ‡ โ†’ โ„• โ†’ ๐“ค ฬ‡
X has-minimal-hlevel 0        = X is-of-hlevel 0
X has-minimal-hlevel (succ n) = (X is-of-hlevel (succ n)) ร— ยฌ(X is-of-hlevel n)

_has-minimal-hlevel-โˆž : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
X has-minimal-hlevel-โˆž = (n : โ„•) โ†’ ยฌ(X is-of-hlevel n)

pointed-types-have-wconstant-endomap : {X : ๐“ค ฬ‡ } โ†’ X โ†’ wconstant-endomap X
pointed-types-have-wconstant-endomap x = ((ฮป y โ†’ x) , (ฮป y y' โ†’ refl x))

empty-types-have-wconstant-endomap : {X : ๐“ค ฬ‡ } โ†’ is-empty X โ†’ wconstant-endomap X
empty-types-have-wconstant-endomap e = (id , (ฮป x x' โ†’ !๐Ÿ˜ (x โ‰ก x') (e x)))

decidable-has-wconstant-endomap : {X : ๐“ค ฬ‡ } โ†’ decidable X โ†’ wconstant-endomap X
decidable-has-wconstant-endomap (inl x) = pointed-types-have-wconstant-endomap x
decidable-has-wconstant-endomap (inr e) = empty-types-have-wconstant-endomap e

hedberg-lemma : {X : ๐“ค ฬ‡ } โ†’ has-decidable-equality X โ†’ wconstant-โ‰ก-endomaps X
hedberg-lemma {๐“ค} {X} d x y = decidable-has-wconstant-endomap (d x y)

hedberg : {X : ๐“ค ฬ‡ } โ†’ has-decidable-equality X โ†’ is-set X
hedberg {๐“ค} {X} d = types-with-wconstant-โ‰ก-endomaps-are-sets X (hedberg-lemma d)

โ„•-is-set : is-set โ„•
โ„•-is-set = hedberg โ„•-has-decidable-equality

๐Ÿš-is-set : is-set ๐Ÿš
๐Ÿš-is-set = hedberg ๐Ÿš-has-decidable-equality

has-section : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
has-section r = ฮฃ s ๊ž‰ (codomain r โ†’ domain r), r โˆ˜ s โˆผ id

_โ—_ : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
X โ— Y = ฮฃ r ๊ž‰ (Y โ†’ X), has-section r

retraction : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ X โ— Y โ†’ Y โ†’ X
retraction (r , s , ฮท) = r

section : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ X โ— Y โ†’ X โ†’ Y
section (r , s , ฮท) = s

retract-equation : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (ฯ : X โ— Y)
                 โ†’ retraction ฯ โˆ˜ section ฯ โˆผ ๐‘–๐‘‘ X

retract-equation (r , s , ฮท) = ฮท

retraction-has-section : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (ฯ : X โ— Y)
                       โ†’ has-section (retraction ฯ)

retraction-has-section (r , h) = h

id-โ— : (X : ๐“ค ฬ‡ ) โ†’ X โ— X
id-โ— X = ๐‘–๐‘‘ X , ๐‘–๐‘‘ X , refl

_โ—โˆ˜_ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ } โ†’ X โ— Y โ†’ Y โ— Z โ†’ X โ— Z

(r , s , ฮท) โ—โˆ˜ (r' , s' , ฮท') = (r โˆ˜ r' , s' โˆ˜ s , ฮท'')
 where
  ฮท'' = ฮป x โ†’ r (r' (s' (s x))) โ‰กโŸจ ap r (ฮท' (s x)) โŸฉ
              r (s x)           โ‰กโŸจ ฮท x             โŸฉ
              x                 โˆŽ

_โ—โŸจ_โŸฉ_ : (X : ๐“ค ฬ‡ ) {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ } โ†’ X โ— Y โ†’ Y โ— Z โ†’ X โ— Z
X โ—โŸจ ฯ โŸฉ ฯƒ = ฯ โ—โˆ˜ ฯƒ

_โ—€ : (X : ๐“ค ฬ‡ ) โ†’ X โ— X
X โ—€ = id-โ— X

ฮฃ-retract : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {B : X โ†’ ๐“ฆ ฬ‡ }
          โ†’ ((x : X) โ†’ A x โ—  B x) โ†’ ฮฃ A โ— ฮฃ B

ฮฃ-retract {๐“ค} {๐“ฅ} {๐“ฆ} {X} {A} {B} ฯ = Natฮฃ r , Natฮฃ s , ฮท'
 where
  r : (x : X) โ†’ B x โ†’ A x
  r x = retraction (ฯ x)

  s : (x : X) โ†’ A x โ†’ B x
  s x = section (ฯ x)

  ฮท : (x : X) (a : A x) โ†’ r x (s x a) โ‰ก a
  ฮท x = retract-equation (ฯ x)

  ฮท' : (ฯƒ : ฮฃ A) โ†’ Natฮฃ r (Natฮฃ s ฯƒ) โ‰ก ฯƒ
  ฮท' (x , a) = x , r x (s x a) โ‰กโŸจ to-ฮฃ-โ‰ก' (ฮท x a) โŸฉ
               x , a           โˆŽ

transport-is-retraction : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) {x y : X} (p : x โ‰ก y)
                        โ†’ transport A p โˆ˜ transport A (p โปยน) โˆผ ๐‘–๐‘‘ (A y)

transport-is-retraction A (refl x) = refl

transport-is-section : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) {x y : X} (p : x โ‰ก y)
                     โ†’ transport A (p โปยน) โˆ˜ transport A p โˆผ ๐‘–๐‘‘ (A x)

transport-is-section A (refl x) = refl

ฮฃ-reindexing-retract : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {A : X โ†’ ๐“ฆ ฬ‡ } (r : Y โ†’ X)
                     โ†’ has-section r
                     โ†’ (ฮฃ x ๊ž‰ X , A x) โ— (ฮฃ y ๊ž‰ Y , A (r y))

ฮฃ-reindexing-retract {๐“ค} {๐“ฅ} {๐“ฆ} {X} {Y} {A} r (s , ฮท) = ฮณ , ฯ† , ฮณฯ†
 where
  ฮณ : ฮฃ (A โˆ˜ r) โ†’ ฮฃ A
  ฮณ (y , a) = (r y , a)

  ฯ† : ฮฃ A โ†’ ฮฃ (A โˆ˜ r)
  ฯ† (x , a) = (s x , transport A ((ฮท x)โปยน) a)

  ฮณฯ† : (ฯƒ : ฮฃ A) โ†’ ฮณ (ฯ† ฯƒ) โ‰ก ฯƒ
  ฮณฯ† (x , a) = p
   where
    p : (r (s x) , transport A ((ฮท x)โปยน) a) โ‰ก (x , a)
    p = to-ฮฃ-โ‰ก (ฮท x , transport-is-retraction A (ฮท x) a)

singleton-type : {X : ๐“ค ฬ‡ } โ†’ X โ†’ ๐“ค ฬ‡
singleton-type {๐“ค} {X} x = ฮฃ y ๊ž‰ X , y โ‰ก x

singleton-type-center : {X : ๐“ค ฬ‡ } (x : X) โ†’ singleton-type x
singleton-type-center x = (x , refl x)

singleton-type-centered : {X : ๐“ค ฬ‡ } (x : X) (ฯƒ : singleton-type x)
                        โ†’ singleton-type-center x โ‰ก ฯƒ

singleton-type-centered x (x , refl x) = refl (x , refl x)

singleton-types-are-singletons : (X : ๐“ค ฬ‡ ) (x : X)
                               โ†’ is-singleton (singleton-type x)

singleton-types-are-singletons X x = singleton-type-center x ,
                                     singleton-type-centered x

retract-of-singleton : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                     โ†’ Y โ— X โ†’ is-singleton X โ†’ is-singleton Y

retract-of-singleton (r , s , ฮท) (c , ฯ†) = r c , ฮณ
 where
  ฮณ = ฮป y โ†’ r c     โ‰กโŸจ ap r (ฯ† (s y)) โŸฉ
            r (s y) โ‰กโŸจ ฮท y            โŸฉ
            y       โˆŽ

singleton-type' : {X : ๐“ค ฬ‡ } โ†’ X โ†’ ๐“ค ฬ‡
singleton-type' {๐“ค} {X} x = ฮฃ y ๊ž‰ X , x โ‰ก y

singleton-type'-center : {X : ๐“ค ฬ‡ } (x : X) โ†’ singleton-type' x
singleton-type'-center x = (x , refl x)

singleton-type'-centered : {X : ๐“ค ฬ‡ } (x : X) (ฯƒ : singleton-type' x)
                         โ†’ singleton-type'-center x โ‰ก ฯƒ

singleton-type'-centered x (x , refl x) = refl (x , refl x)

singleton-types'-are-singletons : (X : ๐“ค ฬ‡ ) (x : X)
                                โ†’ is-singleton (singleton-type' x)

singleton-types'-are-singletons X x = singleton-type'-center x ,
                                      singleton-type'-centered x

invertible : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
invertible f = ฮฃ g ๊ž‰ (codomain f โ†’ domain f) , (g โˆ˜ f โˆผ id) ร— (f โˆ˜ g โˆผ id)

fiber : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) โ†’ Y โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
fiber f y = ฮฃ x ๊ž‰ domain f , f x โ‰ก y

fiber-point : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {f : X โ†’ Y} {y : Y}
            โ†’ fiber f y โ†’ X

fiber-point (x , p) = x

fiber-identification : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {f : X โ†’ Y} {y : Y}
                     โ†’ (w : fiber f y) โ†’ f (fiber-point w) โ‰ก y

fiber-identification (x , p) = p

is-equiv : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
is-equiv f = (y : codomain f) โ†’ is-singleton (fiber f y)

inverse : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) โ†’ is-equiv f โ†’ (Y โ†’ X)
inverse f e y = fiber-point (center (fiber f y) (e y))

inverses-are-sections : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) (e : is-equiv f)
                      โ†’ f โˆ˜ inverse f e โˆผ id

inverses-are-sections f e y = fiber-identification (center (fiber f y) (e y))

inverse-centrality : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                     (f : X โ†’ Y) (e : is-equiv f) (y : Y) (t : fiber f y)
                   โ†’ (inverse f e y , inverses-are-sections f e y) โ‰ก t

inverse-centrality f e y = centrality (fiber f y) (e y)

inverses-are-retractions : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) (e : is-equiv f)
                         โ†’ inverse f e โˆ˜ f โˆผ id

inverses-are-retractions f e x = ap fiber-point p
 where
  p : inverse f e (f x) , inverses-are-sections f e (f x) โ‰ก x , refl (f x)
  p = inverse-centrality f e (f x) (x , (refl (f x)))

equivs-are-invertible : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                      โ†’ is-equiv f โ†’ invertible f

equivs-are-invertible f e = inverse f e ,
                            inverses-are-retractions f e ,
                            inverses-are-sections f e

invertibles-are-equivs : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                       โ†’ invertible f โ†’ is-equiv f

invertibles-are-equivs {๐“ค} {๐“ฅ} {X} {Y} f (g , ฮท , ฮต) yโ‚€ = iii
 where
  i : (y : Y) โ†’ (f (g y) โ‰ก yโ‚€) โ— (y โ‰ก yโ‚€)
  i y =  r , s , transport-is-section (_โ‰ก yโ‚€) (ฮต y)
   where
    s : f (g y) โ‰ก yโ‚€ โ†’ y โ‰ก yโ‚€
    s = transport (_โ‰ก yโ‚€) (ฮต y)

    r : y โ‰ก yโ‚€ โ†’ f (g y) โ‰ก yโ‚€
    r = transport (_โ‰ก yโ‚€) ((ฮต y)โปยน)

  ii : fiber f yโ‚€ โ— singleton-type yโ‚€
  ii = (ฮฃ x ๊ž‰ X , f x โ‰ก yโ‚€)     โ—โŸจ ฮฃ-reindexing-retract g (f , ฮท) โŸฉ
       (ฮฃ y ๊ž‰ Y , f (g y) โ‰ก yโ‚€) โ—โŸจ ฮฃ-retract i                    โŸฉ
       (ฮฃ y ๊ž‰ Y , y โ‰ก yโ‚€)       โ—€

  iii : is-singleton (fiber f yโ‚€)
  iii = retract-of-singleton ii (singleton-types-are-singletons Y yโ‚€)

inverses-are-equivs : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) (e : is-equiv f)
                    โ†’ is-equiv (inverse f e)

inverses-are-equivs f e = invertibles-are-equivs
                           (inverse f e)
                           (f , inverses-are-sections f e , inverses-are-retractions f e)

inversion-involutive : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) (e : is-equiv f)
                     โ†’ inverse (inverse f e) (inverses-are-equivs f e) โ‰ก f

inversion-involutive f e = refl f

id-invertible : (X : ๐“ค ฬ‡ ) โ†’ invertible (๐‘–๐‘‘ X)
id-invertible X = ๐‘–๐‘‘ X , refl , refl

โˆ˜-invertible : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ } {f : X โ†’ Y} {f' : Y โ†’ Z}
             โ†’ invertible f' โ†’ invertible f โ†’ invertible (f' โˆ˜ f)

โˆ˜-invertible {๐“ค} {๐“ฅ} {๐“ฆ} {X} {Y} {Z} {f} {f'} (g' , gf' , fg') (g , gf , fg) =
  g โˆ˜ g' , ฮท , ฮต
 where
  ฮท = ฮป x โ†’ g (g' (f' (f x))) โ‰กโŸจ ap g (gf' (f x)) โŸฉ
            g (f x)           โ‰กโŸจ gf x             โŸฉ
            x                 โˆŽ

  ฮต = ฮป z โ†’ f' (f (g (g' z))) โ‰กโŸจ ap f' (fg (g' z)) โŸฉ
            f' (g' z)         โ‰กโŸจ fg' z             โŸฉ
            z                 โˆŽ

id-is-equiv : (X : ๐“ค ฬ‡ ) โ†’ is-equiv (๐‘–๐‘‘ X)
id-is-equiv = singleton-types-are-singletons

โˆ˜-is-equiv : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ } {f : X โ†’ Y} {g : Y โ†’ Z}
           โ†’ is-equiv g โ†’ is-equiv f โ†’ is-equiv (g โˆ˜ f)

โˆ˜-is-equiv {๐“ค} {๐“ฅ} {๐“ฆ} {X} {Y} {Z} {f} {g} i j = ฮณ
 where
  abstract
   ฮณ : is-equiv (g โˆ˜ f)
   ฮณ = invertibles-are-equivs (g โˆ˜ f)
         (โˆ˜-invertible (equivs-are-invertible g i)
                       (equivs-are-invertible f j))

inverse-of-โˆ˜ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ }
               (f : X โ†’ Y) (g : Y โ†’ Z)
               (i : is-equiv f) (j : is-equiv g)
             โ†’ inverse f i โˆ˜ inverse g j โˆผ inverse (g โˆ˜ f) (โˆ˜-is-equiv j i)

inverse-of-โˆ˜ f g i j z =

  f' (g' z)             โ‰กโŸจ (ap (f' โˆ˜ g') (s z))โปยน                         โŸฉ
  f' (g' (g (f (h z)))) โ‰กโŸจ ap f' (inverses-are-retractions g j (f (h z))) โŸฉ
  f' (f (h z))          โ‰กโŸจ inverses-are-retractions f i (h z)             โŸฉ
  h z                   โˆŽ

 where
  f' = inverse f i
  g' = inverse g j
  h  = inverse (g โˆ˜ f) (โˆ˜-is-equiv j i)

  s : g โˆ˜ f โˆ˜ h โˆผ id
  s = inverses-are-sections (g โˆ˜ f) (โˆ˜-is-equiv j i)

_โ‰ƒ_ : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
X โ‰ƒ Y = ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f

Eqโ†’fun โŒœ_โŒ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ X โ‰ƒ Y โ†’ X โ†’ Y
Eqโ†’fun (f , i) = f
โŒœ_โŒ            = Eqโ†’fun

Eqโ†’fun-is-equiv โŒœโŒ-is-equiv : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (e : X โ‰ƒ Y) โ†’ is-equiv (โŒœ e โŒ)
Eqโ†’fun-is-equiv (f , i) = i
โŒœโŒ-is-equiv             = Eqโ†’fun-is-equiv

invertibility-gives-โ‰ƒ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                      โ†’ invertible f โ†’ X โ‰ƒ Y

invertibility-gives-โ‰ƒ f i = f , invertibles-are-equivs f i

ฮฃ-induction-โ‰ƒ : {X : ๐“ค ฬ‡ } {Y : X โ†’ ๐“ฅ ฬ‡ } {A : ฮฃ Y โ†’ ๐“ฆ ฬ‡ }
              โ†’ ((x : X) (y : Y x) โ†’ A (x , y)) โ‰ƒ ((z : ฮฃ Y) โ†’ A z)

ฮฃ-induction-โ‰ƒ = invertibility-gives-โ‰ƒ ฮฃ-induction (curry , refl , refl)

ฮฃ-flip : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {A : X โ†’ Y โ†’ ๐“ฆ ฬ‡ }
       โ†’ (ฮฃ x ๊ž‰ X , ฮฃ y ๊ž‰ Y , A x y) โ‰ƒ (ฮฃ y ๊ž‰ Y , ฮฃ x ๊ž‰ X , A x y)

ฮฃ-flip = invertibility-gives-โ‰ƒ
          (ฮป (x , y , p) โ†’ (y , x , p))
          ((ฮป (y , x , p) โ†’ (x , y , p)) , refl , refl)

ร—-comm : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
       โ†’ (X ร— Y) โ‰ƒ (Y ร— X)

ร—-comm = invertibility-gives-โ‰ƒ
          (ฮป (x , y) โ†’ (y , x))
          ((ฮป (y , x) โ†’ (x , y)) , refl , refl)

id-โ‰ƒ : (X : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ X
id-โ‰ƒ X = ๐‘–๐‘‘ X , id-is-equiv X

_โ—_ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ } โ†’ X โ‰ƒ Y โ†’ Y โ‰ƒ Z โ†’ X โ‰ƒ Z
(f , d) โ— (f' , e) = f' โˆ˜ f , โˆ˜-is-equiv e d

โ‰ƒ-sym : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ X โ‰ƒ Y โ†’ Y โ‰ƒ X
โ‰ƒ-sym (f , e) = inverse f e , inverses-are-equivs f e

_โ‰ƒโŸจ_โŸฉ_ : (X : ๐“ค ฬ‡ ) {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ } โ†’ X โ‰ƒ Y โ†’ Y โ‰ƒ Z โ†’ X โ‰ƒ Z
_ โ‰ƒโŸจ d โŸฉ e = d โ— e

_โ–  : (X : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ X
_โ–  = id-โ‰ƒ

transport-is-equiv : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) {x y : X} (p : x โ‰ก y)
                   โ†’ is-equiv (transport A p)

transport-is-equiv A (refl x) = id-is-equiv (A x)

ฮฃ-โ‰ก-โ‰ƒ : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } (ฯƒ ฯ„ : ฮฃ A)
      โ†’ (ฯƒ โ‰ก ฯ„) โ‰ƒ (ฮฃ p ๊ž‰ prโ‚ ฯƒ โ‰ก prโ‚ ฯ„ , transport A p (prโ‚‚ ฯƒ) โ‰ก prโ‚‚ ฯ„)

ฮฃ-โ‰ก-โ‰ƒ {๐“ค} {๐“ฅ} {X} {A}  ฯƒ ฯ„ = invertibility-gives-โ‰ƒ from-ฮฃ-โ‰ก (to-ฮฃ-โ‰ก , ฮท , ฮต)
 where
  ฮท : (q : ฯƒ โ‰ก ฯ„) โ†’ to-ฮฃ-โ‰ก (from-ฮฃ-โ‰ก q) โ‰ก q
  ฮท (refl ฯƒ) = refl (refl ฯƒ)

  ฮต : (w : ฮฃ p ๊ž‰ prโ‚ ฯƒ โ‰ก prโ‚ ฯ„ , transport A p (prโ‚‚ ฯƒ) โ‰ก prโ‚‚ ฯ„)
    โ†’ from-ฮฃ-โ‰ก (to-ฮฃ-โ‰ก w) โ‰ก w

  ฮต (refl p , refl q) = refl (refl p , refl q)

to-ร—-โ‰ก : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {z t : X ร— Y}
       โ†’ (prโ‚ z โ‰ก prโ‚ t) ร— (prโ‚‚ z โ‰ก prโ‚‚ t) โ†’ z โ‰ก t

to-ร—-โ‰ก (refl x , refl y) = refl (x , y)

from-ร—-โ‰ก : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {z t : X ร— Y}
         โ†’ z โ‰ก t โ†’ (prโ‚ z โ‰ก prโ‚ t) ร— (prโ‚‚ z โ‰ก prโ‚‚ t)

from-ร—-โ‰ก {๐“ค} {๐“ฅ} {X} {Y} (refl (x , y)) = (refl x , refl y)

ร—-โ‰ก-โ‰ƒ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (z t : X ร— Y)
      โ†’ (z โ‰ก t) โ‰ƒ (prโ‚ z โ‰ก prโ‚ t) ร— (prโ‚‚ z โ‰ก prโ‚‚ t)

ร—-โ‰ก-โ‰ƒ {๐“ค} {๐“ฅ} {X} {Y} z t = invertibility-gives-โ‰ƒ from-ร—-โ‰ก (to-ร—-โ‰ก , ฮท , ฮต)
 where
  ฮท : (p : z โ‰ก t) โ†’ to-ร—-โ‰ก (from-ร—-โ‰ก p) โ‰ก p
  ฮท (refl z) = refl (refl z)

  ฮต : (q : (prโ‚ z โ‰ก prโ‚ t) ร— (prโ‚‚ z โ‰ก prโ‚‚ t)) โ†’ from-ร—-โ‰ก (to-ร—-โ‰ก q) โ‰ก q
  ฮต (refl x , refl y) = refl (refl x , refl y)

ap-prโ‚-to-ร—-โ‰ก : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {z t : X ร— Y}
              โ†’ (pโ‚ : prโ‚ z โ‰ก prโ‚ t)
              โ†’ (pโ‚‚ : prโ‚‚ z โ‰ก prโ‚‚ t)
              โ†’ ap prโ‚ (to-ร—-โ‰ก (pโ‚ , pโ‚‚)) โ‰ก pโ‚

ap-prโ‚-to-ร—-โ‰ก (refl x) (refl y) = refl (refl x)

ap-prโ‚‚-to-ร—-โ‰ก : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {z t : X ร— Y}
              โ†’ (pโ‚ : prโ‚ z โ‰ก prโ‚ t)
              โ†’ (pโ‚‚ : prโ‚‚ z โ‰ก prโ‚‚ t)
              โ†’ ap prโ‚‚ (to-ร—-โ‰ก (pโ‚ , pโ‚‚)) โ‰ก pโ‚‚

ap-prโ‚‚-to-ร—-โ‰ก (refl x) (refl y) = refl (refl y)

ฮฃ-cong : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {B : X โ†’ ๐“ฆ ฬ‡ }
       โ†’ ((x : X) โ†’ A x โ‰ƒ B x) โ†’ ฮฃ A โ‰ƒ ฮฃ B

ฮฃ-cong {๐“ค} {๐“ฅ} {๐“ฆ} {X} {A} {B} ฯ† =
  invertibility-gives-โ‰ƒ (Natฮฃ f) (Natฮฃ g , Natฮฃ-ฮท , Natฮฃ-ฮต)
 where
  f : (x : X) โ†’ A x โ†’ B x
  f x = โŒœ ฯ† x โŒ

  g : (x : X) โ†’ B x โ†’ A x
  g x = inverse (f x) (โŒœโŒ-is-equiv (ฯ† x))

  ฮท : (x : X) (a : A x) โ†’ g x (f x a) โ‰ก a
  ฮท x = inverses-are-retractions (f x) (โŒœโŒ-is-equiv (ฯ† x))

  ฮต : (x : X) (b : B x) โ†’ f x (g x b) โ‰ก b
  ฮต x = inverses-are-sections (f x) (โŒœโŒ-is-equiv (ฯ† x))

  Natฮฃ-ฮท : (w : ฮฃ A) โ†’ Natฮฃ g (Natฮฃ f w) โ‰ก w
  Natฮฃ-ฮท (x , a) = x , g x (f x a) โ‰กโŸจ to-ฮฃ-โ‰ก' (ฮท x a) โŸฉ
                   x , a           โˆŽ

  Natฮฃ-ฮต : (t : ฮฃ B) โ†’ Natฮฃ f (Natฮฃ g t) โ‰ก t
  Natฮฃ-ฮต (x , b) = x , f x (g x b) โ‰กโŸจ to-ฮฃ-โ‰ก' (ฮต x b) โŸฉ
                   x , b           โˆŽ

โ‰ƒ-gives-โ— : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ X โ‰ƒ Y โ†’ X โ— Y
โ‰ƒ-gives-โ— (f , e) = (inverse f e , f , inverses-are-retractions f e)

โ‰ƒ-gives-โ–ท : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ X โ‰ƒ Y โ†’ Y โ— X
โ‰ƒ-gives-โ–ท (f , e) = (f , inverse f e , inverses-are-sections f e)

equiv-to-singleton : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                   โ†’ X โ‰ƒ Y โ†’ is-singleton Y โ†’ is-singleton X

equiv-to-singleton e = retract-of-singleton (โ‰ƒ-gives-โ— e)

Idโ†’Eq : (X Y : ๐“ค ฬ‡ ) โ†’ X โ‰ก Y โ†’ X โ‰ƒ Y
Idโ†’Eq X X (refl X) = id-โ‰ƒ X

is-univalent : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
is-univalent ๐“ค = (X Y : ๐“ค ฬ‡ ) โ†’ is-equiv (Idโ†’Eq X Y)

univalence-โ‰ƒ : is-univalent ๐“ค โ†’ (X Y : ๐“ค ฬ‡ ) โ†’ (X โ‰ก Y) โ‰ƒ (X โ‰ƒ Y)
univalence-โ‰ƒ ua X Y = Idโ†’Eq X Y , ua X Y

Eqโ†’Id : is-univalent ๐“ค โ†’ (X Y : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ X โ‰ก Y
Eqโ†’Id ua X Y = inverse (Idโ†’Eq X Y) (ua X Y)

Idโ†’fun : {X Y : ๐“ค ฬ‡ } โ†’ X โ‰ก Y โ†’ X โ†’ Y
Idโ†’fun {๐“ค} {X} {Y} p = โŒœ Idโ†’Eq X Y p โŒ

Idโ†’funs-agree : {X Y : ๐“ค ฬ‡ } (p : X โ‰ก Y)
              โ†’ Idโ†’fun p โ‰ก Idโ†’Fun p
Idโ†’funs-agree (refl X) = refl (๐‘–๐‘‘ X)

swapโ‚‚ : ๐Ÿš โ†’ ๐Ÿš
swapโ‚‚ โ‚€ = โ‚
swapโ‚‚ โ‚ = โ‚€

swapโ‚‚-involutive : (n : ๐Ÿš) โ†’ swapโ‚‚ (swapโ‚‚ n) โ‰ก n
swapโ‚‚-involutive โ‚€ = refl โ‚€
swapโ‚‚-involutive โ‚ = refl โ‚

swapโ‚‚-is-equiv : is-equiv swapโ‚‚
swapโ‚‚-is-equiv = invertibles-are-equivs
                  swapโ‚‚
                  (swapโ‚‚ , swapโ‚‚-involutive , swapโ‚‚-involutive)

module example-of-a-nonset (ua : is-univalent ๐“คโ‚€) where

 eโ‚€ eโ‚ : ๐Ÿš โ‰ƒ ๐Ÿš
 eโ‚€ = id-โ‰ƒ ๐Ÿš
 eโ‚ = swapโ‚‚ , swapโ‚‚-is-equiv

 eโ‚€-is-not-eโ‚ : eโ‚€ โ‰ข eโ‚
 eโ‚€-is-not-eโ‚ p = โ‚-is-not-โ‚€ r
  where
   q : id โ‰ก swapโ‚‚
   q = ap โŒœ_โŒ p

   r : โ‚ โ‰ก โ‚€
   r = ap (ฮป - โ†’ - โ‚) q

 pโ‚€ pโ‚ : ๐Ÿš โ‰ก ๐Ÿš
 pโ‚€ = Eqโ†’Id ua ๐Ÿš ๐Ÿš eโ‚€
 pโ‚ = Eqโ†’Id ua ๐Ÿš ๐Ÿš eโ‚

 pโ‚€-is-not-pโ‚ : pโ‚€ โ‰ข pโ‚
 pโ‚€-is-not-pโ‚ q = eโ‚€-is-not-eโ‚ r
  where
   r = eโ‚€            โ‰กโŸจ (inverses-are-sections (Idโ†’Eq ๐Ÿš ๐Ÿš) (ua ๐Ÿš ๐Ÿš) eโ‚€)โปยน โŸฉ
       Idโ†’Eq ๐Ÿš ๐Ÿš pโ‚€  โ‰กโŸจ ap (Idโ†’Eq ๐Ÿš ๐Ÿš) q                                  โŸฉ
       Idโ†’Eq ๐Ÿš ๐Ÿš pโ‚  โ‰กโŸจ inverses-are-sections (Idโ†’Eq ๐Ÿš ๐Ÿš) (ua ๐Ÿš ๐Ÿš) eโ‚     โŸฉ
       eโ‚            โˆŽ

 ๐“คโ‚€-is-not-a-set : ยฌ(is-set (๐“คโ‚€ ฬ‡ ))
 ๐“คโ‚€-is-not-a-set s = pโ‚€-is-not-pโ‚ q
  where
   q : pโ‚€ โ‰ก pโ‚
   q = s ๐Ÿš ๐Ÿš pโ‚€ pโ‚

subsingleton-criterion : {X : ๐“ค ฬ‡ }
                       โ†’ (X โ†’ is-singleton X)
                       โ†’ is-subsingleton X

subsingleton-criterion' : {X : ๐“ค ฬ‡ }
                        โ†’ (X โ†’ is-subsingleton X)
                        โ†’ is-subsingleton X

retract-of-subsingleton : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                        โ†’ Y โ— X โ†’ is-subsingleton X โ†’ is-subsingleton Y

left-cancellable : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
left-cancellable f = {x x' : domain f} โ†’ f x โ‰ก f x' โ†’ x โ‰ก x'

lc-maps-reflect-subsingletons : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                              โ†’ left-cancellable f
                              โ†’ is-subsingleton Y
                              โ†’ is-subsingleton X

has-retraction : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
has-retraction s = ฮฃ r ๊ž‰ (codomain s โ†’ domain s), r โˆ˜ s โˆผ id

sections-are-lc : {X : ๐“ค ฬ‡ } {A : ๐“ฅ ฬ‡ } (s : X โ†’ A)
                โ†’ has-retraction s โ†’ left-cancellable s

equivs-have-retractions : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                        โ†’ is-equiv f โ†’ has-retraction f

equivs-have-sections : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                     โ†’ is-equiv f โ†’ has-section f

equivs-are-lc : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
              โ†’ is-equiv f โ†’ left-cancellable f

equiv-to-subsingleton : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                      โ†’ X โ‰ƒ Y
                      โ†’ is-subsingleton Y
                      โ†’ is-subsingleton X

comp-inverses : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ }
                (f : X โ†’ Y) (g : Y โ†’ Z)
                (i : is-equiv f) (j : is-equiv g)
                (f' : Y โ†’ X) (g' : Z โ†’ Y)
              โ†’ f' โˆผ inverse f i
              โ†’ g' โˆผ inverse g j
              โ†’ f' โˆ˜ g' โˆผ inverse (g โˆ˜ f) (โˆ˜-is-equiv j i)

equiv-to-set : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
             โ†’ X โ‰ƒ Y
             โ†’ is-set Y
             โ†’ is-set X

sections-closed-under-โˆผ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f g : X โ†’ Y)
                        โ†’ has-retraction f
                        โ†’ g โˆผ f
                        โ†’ has-retraction g

retractions-closed-under-โˆผ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f g : X โ†’ Y)
                           โ†’ has-section f
                           โ†’ g โˆผ f
                           โ†’ has-section g

is-joyal-equiv : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
is-joyal-equiv f = has-section f ร— has-retraction f

one-inverse : (X : ๐“ค ฬ‡ ) (Y : ๐“ฅ ฬ‡ )
              (f : X โ†’ Y) (r s : Y โ†’ X)
            โ†’ (r โˆ˜ f โˆผ id)
            โ†’ (f โˆ˜ s โˆผ id)
            โ†’ r โˆผ s

joyal-equivs-are-invertible : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                            โ†’ is-joyal-equiv f โ†’ invertible f

joyal-equivs-are-equivs : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                        โ†’ is-joyal-equiv f โ†’ is-equiv f

invertibles-are-joyal-equivs : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                             โ†’ invertible f โ†’ is-joyal-equiv f

equivs-are-joyal-equivs : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                        โ†’ is-equiv f โ†’ is-joyal-equiv f

equivs-closed-under-โˆผ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {f g : X โ†’ Y}
                      โ†’ is-equiv f
                      โ†’ g โˆผ f
                      โ†’ is-equiv g

equiv-to-singleton' : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                    โ†’ X โ‰ƒ Y โ†’ is-singleton X โ†’ is-singleton Y

subtypes-of-sets-are-sets : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (m : X โ†’ Y)
                          โ†’ left-cancellable m โ†’ is-set Y โ†’ is-set X

prโ‚-lc : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
       โ†’ ((x : X) โ†’ is-subsingleton (A x))
       โ†’ left-cancellable (ฮป (t : ฮฃ A) โ†’ prโ‚ t)

subsets-of-sets-are-sets : (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ )
                         โ†’ is-set X
                         โ†’ ((x : X) โ†’ is-subsingleton (A x))
                         โ†’ is-set (ฮฃ x ๊ž‰ X , A x)

to-subtype-โ‰ก : {X : ๐“ฆ ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
               {x y : X} {a : A x} {b : A y}
             โ†’ ((x : X) โ†’ is-subsingleton (A x))
             โ†’ x โ‰ก y
             โ†’ (x , a) โ‰ก (y , b)

prโ‚-is-equiv : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
             โ†’ ((x : X) โ†’ is-singleton (A x))
             โ†’ is-equiv (ฮป (t : ฮฃ A) โ†’ prโ‚ t)

prโ‚-โ‰ƒ : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
      โ†’ ((x : X) โ†’ is-singleton (A x))
      โ†’ ฮฃ A โ‰ƒ X

prโ‚-โ‰ƒ i = prโ‚ , prโ‚-is-equiv i

ฮ ฮฃ-distr-โ‰ƒ : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {P : (x : X) โ†’ A x โ†’ ๐“ฆ ฬ‡ }
           โ†’ (ฮ  x ๊ž‰ X , ฮฃ a ๊ž‰ A x , P x a)
           โ‰ƒ (ฮฃ f ๊ž‰ ฮ  A , ฮ  x ๊ž‰ X , P x (f x))

ฮฃ-assoc : {X : ๐“ค ฬ‡ } {Y : X โ†’ ๐“ฅ ฬ‡ } {Z : ฮฃ Y โ†’ ๐“ฆ ฬ‡ }
        โ†’ ฮฃ Z โ‰ƒ (ฮฃ x ๊ž‰ X , ฮฃ y ๊ž‰ Y x , Z (x , y))

โปยน-โ‰ƒ : {X : ๐“ค ฬ‡ } (x y : X) โ†’ (x โ‰ก y) โ‰ƒ (y โ‰ก x)

singleton-types-โ‰ƒ : {X : ๐“ค ฬ‡ } (x : X) โ†’ singleton-type' x โ‰ƒ singleton-type x

singletons-โ‰ƒ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
             โ†’ is-singleton X โ†’ is-singleton Y โ†’ X โ‰ƒ Y

maps-of-singletons-are-equivs : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                              โ†’ is-singleton X โ†’ is-singleton Y โ†’ is-equiv f

logically-equivalent-subsingletons-are-equivalent : (X : ๐“ค ฬ‡ ) (Y : ๐“ฅ ฬ‡ )
                                                  โ†’ is-subsingleton X
                                                  โ†’ is-subsingleton Y
                                                  โ†’ X โ‡” Y
                                                  โ†’ X โ‰ƒ Y

singletons-are-equivalent : (X : ๐“ค ฬ‡ ) (Y : ๐“ฅ ฬ‡ )
                          โ†’ is-singleton X
                          โ†’ is-singleton Y
                          โ†’ X โ‰ƒ Y

Natฮฃ-fiber-equiv : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (B : X โ†’ ๐“ฆ ฬ‡ ) (ฯ† : Nat A B)
                   (x : X) (b : B x)
                 โ†’ fiber (ฯ† x) b โ‰ƒ fiber (Natฮฃ ฯ†) (x , b)

Natฮฃ-equiv-gives-fiberwise-equiv : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {B : X โ†’ ๐“ฆ ฬ‡ }
                                   (ฯ† : Nat A B)
                                 โ†’ is-equiv (Natฮฃ ฯ†)
                                 โ†’ ((x : X) โ†’ is-equiv (ฯ† x))

ฮฃ-is-subsingleton : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
                  โ†’ is-subsingleton X
                  โ†’ ((x : X) โ†’ is-subsingleton (A x))
                  โ†’ is-subsingleton (ฮฃ A)

ร—-is-singleton : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                  โ†’ is-singleton X
                  โ†’ is-singleton Y
                  โ†’ is-singleton (X ร— Y)

ร—-is-subsingleton : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                  โ†’ is-subsingleton X
                  โ†’ is-subsingleton Y
                  โ†’ is-subsingleton (X ร— Y)

ร—-is-subsingleton' : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                   โ†’ ((Y โ†’ is-subsingleton X) ร— (X โ†’ is-subsingleton Y))
                   โ†’ is-subsingleton (X ร— Y)

ร—-is-subsingleton'-back : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                        โ†’ is-subsingleton (X ร— Y)
                        โ†’ (Y โ†’ is-subsingleton X) ร— (X โ†’ is-subsingleton Y)

apโ‚‚ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ } (f : X โ†’ Y โ†’ Z) {x x' : X} {y y' : Y}
    โ†’ x โ‰ก x' โ†’ y โ‰ก y' โ†’ f x y โ‰ก f x' y'

subsingleton-criterion = sol
 where
  sol : {X : ๐“ค ฬ‡ } โ†’ (X โ†’ is-singleton X) โ†’ is-subsingleton X
  sol f x = singletons-are-subsingletons (domain f) (f x) x

subsingleton-criterion' = sol
 where
  sol : {X : ๐“ค ฬ‡ } โ†’ (X โ†’ is-subsingleton X) โ†’ is-subsingleton X
  sol f x y = f x x y

retract-of-subsingleton = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
      โ†’ Y โ— X โ†’ is-subsingleton X โ†’ is-subsingleton Y
  sol (r , s , ฮท) i =  subsingleton-criterion
                        (ฮป x โ†’ retract-of-singleton (r , s , ฮท)
                                (pointed-subsingletons-are-singletons
                                  (codomain s) (s x) i))

lc-maps-reflect-subsingletons = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
      โ†’ left-cancellable f โ†’ is-subsingleton Y โ†’ is-subsingleton X
  sol f l s x x' = l (s (f x) (f x'))

sections-are-lc = sol
 where
  sol : {X : ๐“ค ฬ‡ } {A : ๐“ฅ ฬ‡ } (s : X โ†’ A)
      โ†’ has-retraction s โ†’ left-cancellable s
  sol s (r , ฮต) {x} {y} p = x       โ‰กโŸจ (ฮต x)โปยน โŸฉ
                            r (s x) โ‰กโŸจ ap r p  โŸฉ
                            r (s y) โ‰กโŸจ ฮต y     โŸฉ
                            y       โˆŽ

equivs-have-retractions = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) โ†’ is-equiv f โ†’ has-retraction f
  sol f e = (inverse f e , inverses-are-retractions f e)

equivs-have-sections = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) โ†’ is-equiv f โ†’ has-section f
  sol f e = (inverse f e , inverses-are-sections f e)

equivs-are-lc = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) โ†’ is-equiv f โ†’ left-cancellable f
  sol f e = sections-are-lc f (equivs-have-retractions f e)

equiv-to-subsingleton = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ X โ‰ƒ Y โ†’ is-subsingleton Y โ†’ is-subsingleton X
  sol (f , i) = lc-maps-reflect-subsingletons f (equivs-are-lc f i)

comp-inverses = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ }
        (f : X โ†’ Y) (g : Y โ†’ Z)
        (i : is-equiv f) (j : is-equiv g)
        (f' : Y โ†’ X) (g' : Z โ†’ Y)
      โ†’ f' โˆผ inverse f i
      โ†’ g' โˆผ inverse g j
      โ†’ f' โˆ˜ g' โˆผ inverse (g โˆ˜ f) (โˆ˜-is-equiv j i)
  sol f g i j f' g' h k z =
   f' (g' z)                          โ‰กโŸจ h (g' z)               โŸฉ
   inverse f i (g' z)                 โ‰กโŸจ ap (inverse f i) (k z) โŸฉ
   inverse f i (inverse g j z)        โ‰กโŸจ inverse-of-โˆ˜ f g i j z โŸฉ
   inverse (g โˆ˜ f) (โˆ˜-is-equiv j i) z โˆŽ

equiv-to-set = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ X โ‰ƒ Y โ†’ is-set Y โ†’ is-set X
  sol e = subtypes-of-sets-are-sets โŒœ e โŒ (equivs-are-lc โŒœ e โŒ (โŒœโŒ-is-equiv e))

sections-closed-under-โˆผ = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f g : X โ†’ Y)
      โ†’ has-retraction f โ†’ g โˆผ f โ†’ has-retraction g
  sol f g (r , rf) h = (r ,
                        ฮป x โ†’ r (g x) โ‰กโŸจ ap r (h x) โŸฉ
                              r (f x) โ‰กโŸจ rf x       โŸฉ
                              x       โˆŽ)

retractions-closed-under-โˆผ = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f g : X โ†’ Y)
      โ†’ has-section f โ†’ g โˆผ f โ†’ has-section g
  sol f g (s , fs) h = (s ,
                        ฮป y โ†’ g (s y) โ‰กโŸจ h (s y) โŸฉ
                              f (s y) โ‰กโŸจ fs y    โŸฉ
                              y โˆŽ)

one-inverse = sol
 where
  sol : (X : ๐“ค ฬ‡ ) (Y : ๐“ฅ ฬ‡ )
        (f : X โ†’ Y) (r s : Y โ†’ X)
      โ†’ (r โˆ˜ f โˆผ id)
      โ†’ (f โˆ˜ s โˆผ id)
      โ†’ r โˆผ s
  sol X Y f r s h k y = r y         โ‰กโŸจ ap r ((k y)โปยน) โŸฉ
                        r (f (s y)) โ‰กโŸจ h (s y)        โŸฉ
                        s y         โˆŽ

joyal-equivs-are-invertible = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
      โ†’ is-joyal-equiv f โ†’ invertible f
  sol f ((s , ฮต) , (r , ฮท)) = (s , sf , ฮต)
   where
    sf = ฮป (x : domain f) โ†’ s(f x)       โ‰กโŸจ (ฮท (s (f x)))โปยน โŸฉ
                            r(f(s(f x))) โ‰กโŸจ ap r (ฮต (f x))  โŸฉ
                            r(f x)       โ‰กโŸจ ฮท x             โŸฉ
                            x            โˆŽ

joyal-equivs-are-equivs = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
      โ†’ is-joyal-equiv f โ†’ is-equiv f
  sol f j = invertibles-are-equivs f (joyal-equivs-are-invertible f j)

invertibles-are-joyal-equivs = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
      โ†’ invertible f โ†’ is-joyal-equiv f
  sol f (g , ฮท , ฮต) = ((g , ฮต) , (g , ฮท))

equivs-are-joyal-equivs = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
      โ†’ is-equiv f โ†’ is-joyal-equiv f
  sol f e = invertibles-are-joyal-equivs f (equivs-are-invertible f e)

equivs-closed-under-โˆผ = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {f g : X โ†’ Y}
      โ†’ is-equiv f โ†’ g โˆผ f โ†’ is-equiv g
  sol {๐“ค} {๐“ฅ} {X} {Y} {f} {g} e h = joyal-equivs-are-equivs g
                                      (retractions-closed-under-โˆผ f g
                                       (equivs-have-sections f e) h ,
                                      sections-closed-under-โˆผ f g
                                       (equivs-have-retractions f e) h)

equiv-to-singleton' = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
      โ†’ X โ‰ƒ Y โ†’ is-singleton X โ†’ is-singleton Y
  sol e = retract-of-singleton (โ‰ƒ-gives-โ–ท e)

subtypes-of-sets-are-sets = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (m : X โ†’ Y)
      โ†’ left-cancellable m โ†’ is-set Y โ†’ is-set X
  sol {๐“ค} {๐“ฅ} {X} m i h = types-with-wconstant-โ‰ก-endomaps-are-sets X c
   where
    f : (x x' : X) โ†’ x โ‰ก x' โ†’ x โ‰ก x'
    f x x' r = i (ap m r)

    ฮบ : (x x' : X) (r s : x โ‰ก x') โ†’ f x x' r โ‰ก f x x' s
    ฮบ x x' r s = ap i (h (m x) (m x') (ap m r) (ap m s))

    c : wconstant-โ‰ก-endomaps X
    c x x' = f x x' , ฮบ x x'

prโ‚-lc = sol
 where
  sol : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
      โ†’ ((x : X) โ†’ is-subsingleton (A x))
      โ†’ left-cancellable  (ฮป (t : ฮฃ A) โ†’ prโ‚ t)
  sol i p = to-ฮฃ-โ‰ก (p , i _ _ _)

subsets-of-sets-are-sets = sol
 where
  sol : (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ )
     โ†’ is-set X
     โ†’ ((x : X) โ†’ is-subsingleton (A x))
     โ†’ is-set (ฮฃ x ๊ž‰ X , A x)
  sol X A h p = subtypes-of-sets-are-sets prโ‚ (prโ‚-lc p) h

to-subtype-โ‰ก = sol
 where
  sol : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
        {x y : X} {a : A x} {b : A y}
      โ†’ ((x : X) โ†’ is-subsingleton (A x))
      โ†’ x โ‰ก y
      โ†’ (x , a) โ‰ก (y , b)
  sol {๐“ค} {๐“ฅ} {X} {A} {x} {y} {a} {b} s p = to-ฮฃ-โ‰ก (p , s y (transport A p a) b)

prโ‚-is-equiv = sol
 where
  sol : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
      โ†’ ((x : X) โ†’ is-singleton (A x))
      โ†’ is-equiv (ฮป (t : ฮฃ A) โ†’ prโ‚ t)
  sol {๐“ค} {๐“ฅ} {X} {A} s = invertibles-are-equivs prโ‚ (g , ฮท , ฮต)
   where
    g : X โ†’ ฮฃ A
    g x = x , prโ‚(s x)

    ฮต : (x : X) โ†’ prโ‚ (g x) โ‰ก x
    ฮต x = refl (prโ‚ (g x))

    ฮท : (ฯƒ : ฮฃ A) โ†’ g (prโ‚ ฯƒ) โ‰ก ฯƒ
    ฮท (x , a) = to-subtype-โ‰ก (ฮป x โ†’ singletons-are-subsingletons (A x) (s x)) (ฮต x)

ฮ ฮฃ-distr-โ‰ƒ = sol
 where
  sol : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {P : (x : X) โ†’ A x โ†’ ๐“ฆ ฬ‡ }
      โ†’ (ฮ  x ๊ž‰ X , ฮฃ a ๊ž‰ A x , P x a)
      โ‰ƒ (ฮฃ f ๊ž‰ ฮ  A , ฮ  x ๊ž‰ X , P x (f x))
  sol {๐“ค} {๐“ฅ} {๐“ฆ} {X} {A} {P} = invertibility-gives-โ‰ƒ ฯ† (ฮณ , ฮท , ฮต)
   where
    ฯ† : (ฮ  x ๊ž‰ X , ฮฃ a ๊ž‰ A x , P x a)
      โ†’ ฮฃ f ๊ž‰ ฮ  A , ฮ  x ๊ž‰ X , P x (f x)
    ฯ† g = ((ฮป x โ†’ prโ‚ (g x)) , ฮป x โ†’ prโ‚‚ (g x))

    ฮณ : (ฮฃ f ๊ž‰ ฮ  A , ฮ  x ๊ž‰ X , P x (f x))
      โ†’ ฮ  x ๊ž‰ X , ฮฃ a ๊ž‰ A x , P x a
    ฮณ (f , ฯ†) x = f x , ฯ† x

    ฮท : ฮณ โˆ˜ ฯ† โˆผ id
    ฮท = refl

    ฮต : ฯ† โˆ˜ ฮณ โˆผ id
    ฮต = refl

ฮฃ-assoc = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : X โ†’ ๐“ฅ ฬ‡ } {Z : ฮฃ Y โ†’ ๐“ฆ ฬ‡ }
      โ†’ ฮฃ Z โ‰ƒ (ฮฃ x ๊ž‰ X , ฮฃ y ๊ž‰ Y x , Z (x , y))
  sol {๐“ค} {๐“ฅ} {๐“ฆ} {X} {Y} {Z} = invertibility-gives-โ‰ƒ f (g , refl , refl)
   where
    f : ฮฃ Z โ†’ ฮฃ x ๊ž‰ X , ฮฃ y ๊ž‰ Y x , Z (x , y)
    f ((x , y) , z) = (x , (y , z))

    g : (ฮฃ x ๊ž‰ X , ฮฃ y ๊ž‰ Y x , Z (x , y)) โ†’ ฮฃ Z
    g (x , (y , z)) = ((x , y) , z)

โปยน-is-equiv : {X : ๐“ค ฬ‡ } (x y : X)
            โ†’ is-equiv (ฮป (p : x โ‰ก y) โ†’ p โปยน)
โปยน-is-equiv x y = invertibles-are-equivs _โปยน
                   (_โปยน , โปยน-involutive , โปยน-involutive)

โปยน-โ‰ƒ = sol
 where
  sol : {X : ๐“ค ฬ‡ } (x y : X) โ†’ (x โ‰ก y) โ‰ƒ (y โ‰ก x)
  sol x y = (_โปยน , โปยน-is-equiv x y)

singleton-types-โ‰ƒ = sol
 where
  sol : {X : ๐“ค ฬ‡ } (x : X) โ†’ singleton-type' x โ‰ƒ singleton-type x
  sol x = ฮฃ-cong (ฮป y โ†’ โปยน-โ‰ƒ x y)

singletons-โ‰ƒ = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
      โ†’ is-singleton X โ†’ is-singleton Y โ†’ X โ‰ƒ Y
  sol {๐“ค} {๐“ฅ} {X} {Y} i j = invertibility-gives-โ‰ƒ f (g , ฮท , ฮต)
   where
    f : X โ†’ Y
    f x = center Y j

    g : Y โ†’ X
    g y = center X i

    ฮท : (x : X) โ†’ g (f x) โ‰ก x
    ฮท = centrality X i

    ฮต : (y : Y) โ†’ f (g y) โ‰ก y
    ฮต = centrality Y j

maps-of-singletons-are-equivs = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
      โ†’ is-singleton X โ†’ is-singleton Y โ†’ is-equiv f

  sol {๐“ค} {๐“ฅ} {X} {Y} f i j = invertibles-are-equivs f (g , ฮท , ฮต)
   where
    g : Y โ†’ X
    g y = center X i

    ฮท : (x : X) โ†’ g (f x) โ‰ก x
    ฮท = centrality X i

    ฮต : (y : Y) โ†’ f (g y) โ‰ก y
    ฮต y = singletons-are-subsingletons Y j (f (g y)) y

logically-equivalent-subsingletons-are-equivalent = sol
 where
  sol : (X : ๐“ค ฬ‡ ) (Y : ๐“ฅ ฬ‡ )
      โ†’ is-subsingleton X โ†’ is-subsingleton Y โ†’ X โ‡” Y โ†’ X โ‰ƒ Y
  sol  X Y i j (f , g) = invertibility-gives-โ‰ƒ f
                          (g ,
                           (ฮป x โ†’ i (g (f x)) x) ,
                           (ฮป y โ†’ j (f (g y)) y))

singletons-are-equivalent = sol
 where
  sol : (X : ๐“ค ฬ‡ ) (Y : ๐“ฅ ฬ‡ )
      โ†’ is-singleton X โ†’ is-singleton Y โ†’ X โ‰ƒ Y
  sol  X Y i j = invertibility-gives-โ‰ƒ (ฮป _ โ†’ center Y j)
                  ((ฮป _ โ†’ center X i) ,
                   centrality X i ,
                   centrality Y j)

Natฮฃ-fiber-equiv = sol
 where
  sol : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (B : X โ†’ ๐“ฆ ฬ‡ ) (ฯ† : Nat A B)
        (x : X) (b : B x)
      โ†’ fiber (ฯ† x) b โ‰ƒ fiber (Natฮฃ ฯ†) (x , b)
  sol A B ฯ† x b = invertibility-gives-โ‰ƒ f (g , ฮต , ฮท)
   where
    f : fiber (ฯ† x) b โ†’ fiber (Natฮฃ ฯ†) (x , b)
    f (a , refl _) = ((x , a) , refl (x , ฯ† x a))

    g : fiber (Natฮฃ ฯ†) (x , b) โ†’ fiber (ฯ† x) b
    g ((x , a) , refl _) = (a , refl (ฯ† x a))

    ฮต : (w : fiber (ฯ† x) b) โ†’ g (f w) โ‰ก w
    ฮต (a , refl _) = refl (a , refl (ฯ† x a))

    ฮท : (t : fiber (Natฮฃ ฯ†) (x , b)) โ†’ f (g t) โ‰ก t
    ฮท ((x , a) , refl _) = refl ((x , a) , refl (Natฮฃ ฯ† (x , a)))

Natฮฃ-equiv-gives-fiberwise-equiv = sol
 where
  sol : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {B : X โ†’ ๐“ฆ ฬ‡ } (ฯ† : Nat A B)
      โ†’ is-equiv (Natฮฃ ฯ†) โ†’ ((x : X) โ†’ is-equiv (ฯ† x))
  sol {๐“ค} {๐“ฅ} {๐“ฆ} {X} {A} {B} ฯ† e x b = ฮณ
   where
    d : fiber (ฯ† x) b โ‰ƒ fiber (Natฮฃ ฯ†) (x , b)
    d = Natฮฃ-fiber-equiv A B ฯ† x b

    s : is-singleton (fiber (Natฮฃ ฯ†) (x , b))
    s = e (x , b)

    ฮณ : is-singleton (fiber (ฯ† x) b)
    ฮณ = equiv-to-singleton d s

ฮฃ-is-subsingleton = sol
 where
  sol : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
      โ†’ is-subsingleton X
      โ†’ ((x : X) โ†’ is-subsingleton (A x))
      โ†’ is-subsingleton (ฮฃ A)
  sol i j (x , _) (y , _) = to-subtype-โ‰ก j (i x y)

ร—-is-singleton = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
      โ†’ is-singleton X
      โ†’ is-singleton Y
      โ†’ is-singleton (X ร— Y)
  sol (x , ฯ†) (y , ฮณ) = (x , y) , ฮด
   where
    ฮด : โˆ€ z โ†’ (x , y) โ‰ก z
    ฮด (x' , y' ) = to-ร—-โ‰ก (ฯ† x' , ฮณ y')

ร—-is-subsingleton = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
      โ†’ is-subsingleton X โ†’ is-subsingleton Y โ†’ is-subsingleton (X ร— Y)
  sol i j = ฮฃ-is-subsingleton i (ฮป _ โ†’ j)

ร—-is-subsingleton' = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
      โ†’ ((Y โ†’ is-subsingleton X) ร— (X โ†’ is-subsingleton Y))
      โ†’ is-subsingleton (X ร— Y)
  sol {๐“ค} {๐“ฅ} {X} {Y} (i , j) = k
   where
    k : is-subsingleton (X ร— Y)
    k (x , y) (x' , y') = to-ร—-โ‰ก (i y x x' , j x y y')

ร—-is-subsingleton'-back = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
      โ†’ is-subsingleton (X ร— Y)
      โ†’ (Y โ†’ is-subsingleton X) ร— (X โ†’ is-subsingleton Y)
  sol {๐“ค} {๐“ฅ} {X} {Y} k = i , j
   where
    i : Y โ†’ is-subsingleton X
    i y x x' = ap prโ‚ (k (x , y) (x' , y))

    j : X โ†’ is-subsingleton Y
    j x y y' = ap prโ‚‚ (k (x , y) (x , y'))

apโ‚‚ = sol
 where
  sol : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ } (f : X โ†’ Y โ†’ Z) {x x' : X} {y y' : Y}
      โ†’ x โ‰ก x' โ†’ y โ‰ก y' โ†’ f x y โ‰ก f x' y'
  sol f (refl x) (refl y) = refl (f x y)

equiv-singleton-lemma : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } (x : X)
                        (f : (y : X) โ†’ x โ‰ก y โ†’ A y)
                      โ†’ ((y : X) โ†’ is-equiv (f y))
                      โ†’ is-singleton (ฮฃ A)

equiv-singleton-lemma {๐“ค} {๐“ฅ} {X} {A} x f i = ฮณ
 where
  abstract
   e : (y : X) โ†’ (x โ‰ก y) โ‰ƒ A y
   e y = (f y , i y)

   d : singleton-type' x โ‰ƒ ฮฃ A
   d = ฮฃ-cong e

   ฮณ : is-singleton (ฮฃ A)
   ฮณ = equiv-to-singleton (โ‰ƒ-sym d) (singleton-types'-are-singletons X x)

singleton-equiv-lemma : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } (x : X)
                        (f : (y : X) โ†’ x โ‰ก y โ†’ A y)
                      โ†’ is-singleton (ฮฃ A)
                      โ†’ (y : X) โ†’ is-equiv (f y)

singleton-equiv-lemma {๐“ค} {๐“ฅ} {X} {A} x f i = ฮณ
 where
  abstract
   g : singleton-type' x โ†’ ฮฃ A
   g = Natฮฃ f

   e : is-equiv g
   e = maps-of-singletons-are-equivs g (singleton-types'-are-singletons X x) i

   ฮณ : (y : X) โ†’ is-equiv (f y)
   ฮณ = Natฮฃ-equiv-gives-fiberwise-equiv f e

univalenceโ‡’ : is-univalent ๐“ค
            โ†’ (X : ๐“ค ฬ‡ ) โ†’ is-singleton (ฮฃ Y ๊ž‰ ๐“ค ฬ‡ , X โ‰ƒ Y)

univalenceโ‡’ ua X = equiv-singleton-lemma X (Idโ†’Eq X) (ua X)

โ‡’univalence : ((X : ๐“ค ฬ‡ ) โ†’ is-singleton (ฮฃ Y ๊ž‰ ๐“ค ฬ‡ , X โ‰ƒ Y))
            โ†’ is-univalent ๐“ค

โ‡’univalence i X = singleton-equiv-lemma X (Idโ†’Eq X) (i X)

univalenceโ†’ : is-univalent ๐“ค
            โ†’ (X : ๐“ค ฬ‡ ) โ†’ is-subsingleton (ฮฃ Y ๊ž‰ ๐“ค ฬ‡ , X โ‰ƒ Y)

univalenceโ†’ ua X = singletons-are-subsingletons
                    (ฮฃ (X โ‰ƒ_)) (univalenceโ‡’ ua X)

โ†’univalence : ((X : ๐“ค ฬ‡ ) โ†’ is-subsingleton (ฮฃ Y ๊ž‰ ๐“ค ฬ‡ , X โ‰ƒ Y))
            โ†’ is-univalent ๐“ค

โ†’univalence i = โ‡’univalence (ฮป X โ†’ pointed-subsingletons-are-singletons
                                    (ฮฃ (X โ‰ƒ_)) (X , id-โ‰ƒ X) (i X))

๐”พ-โ‰ƒ : is-univalent ๐“ค
    โ†’ (X : ๐“ค ฬ‡ ) (A : (ฮฃ Y ๊ž‰ ๐“ค ฬ‡ , X โ‰ƒ Y) โ†’ ๐“ฅ ฬ‡ )
    โ†’ A (X , id-โ‰ƒ X) โ†’ (Y : ๐“ค ฬ‡ ) (e : X โ‰ƒ Y) โ†’ A (Y , e)

๐”พ-โ‰ƒ {๐“ค} ua X A a Y e = transport A p a
 where
  t : ฮฃ Y ๊ž‰ ๐“ค ฬ‡ , X โ‰ƒ Y
  t = (X , id-โ‰ƒ X)

  p : t โ‰ก (Y , e)
  p = univalenceโ†’ {๐“ค} ua X t (Y , e)

๐”พ-โ‰ƒ-equation : (ua : is-univalent ๐“ค)
             โ†’ (X : ๐“ค ฬ‡ ) (A : (ฮฃ Y ๊ž‰ ๐“ค ฬ‡ , X โ‰ƒ Y) โ†’ ๐“ฅ ฬ‡ ) (a : A (X , id-โ‰ƒ X))
             โ†’ ๐”พ-โ‰ƒ ua X A a X (id-โ‰ƒ X) โ‰ก a

๐”พ-โ‰ƒ-equation {๐“ค} {๐“ฅ} ua X A a =

  ๐”พ-โ‰ƒ ua X A a X (id-โ‰ƒ X) โ‰กโŸจ refl _                       โŸฉ
  transport A p a         โ‰กโŸจ ap (ฮป - โ†’ transport A - a) q โŸฉ
  transport A (refl t) a  โ‰กโŸจ refl _                       โŸฉ
  a                       โˆŽ

 where
  t : ฮฃ Y ๊ž‰ ๐“ค ฬ‡ , X โ‰ƒ Y
  t = (X , id-โ‰ƒ X)

  p : t โ‰ก t
  p = univalenceโ†’ {๐“ค} ua X t t

  q : p โ‰ก refl t
  q = subsingletons-are-sets (ฮฃ Y ๊ž‰ ๐“ค ฬ‡ , X โ‰ƒ Y)
       (univalenceโ†’ {๐“ค} ua X) t t p (refl t)

โ„-โ‰ƒ : is-univalent ๐“ค
    โ†’ (X : ๐“ค ฬ‡ ) (A : (Y : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฅ ฬ‡ )
    โ†’ A X (id-โ‰ƒ X) โ†’ (Y : ๐“ค ฬ‡ ) (e : X โ‰ƒ Y) โ†’ A Y e

โ„-โ‰ƒ ua X A = ๐”พ-โ‰ƒ ua X (ฮฃ-induction A)

โ„-โ‰ƒ-equation : (ua : is-univalent ๐“ค)
             โ†’ (X : ๐“ค ฬ‡ ) (A : (Y : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฅ ฬ‡ ) (a : A X  (id-โ‰ƒ X))
             โ†’ โ„-โ‰ƒ ua X A a X (id-โ‰ƒ X) โ‰ก a

โ„-โ‰ƒ-equation ua X A = ๐”พ-โ‰ƒ-equation ua X (ฮฃ-induction A)

๐•-โ‰ƒ : is-univalent ๐“ค
    โ†’ (A : (X Y : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฅ ฬ‡ )
    โ†’ ((X : ๐“ค ฬ‡ ) โ†’ A X X (id-โ‰ƒ X))
    โ†’ (X Y : ๐“ค ฬ‡ ) (e : X โ‰ƒ Y) โ†’ A X Y e

๐•-โ‰ƒ ua A ฯ† X = โ„-โ‰ƒ ua X (A X) (ฯ† X)

๐•-โ‰ƒ-equation : (ua : is-univalent ๐“ค)
             โ†’ (A : (X Y : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฅ ฬ‡ )
             โ†’ (ฯ† : (X : ๐“ค ฬ‡ ) โ†’ A X X (id-โ‰ƒ X))
             โ†’ (X : ๐“ค ฬ‡ ) โ†’ ๐•-โ‰ƒ ua A ฯ† X X (id-โ‰ƒ X) โ‰ก ฯ† X

๐•-โ‰ƒ-equation ua A ฯ† X = โ„-โ‰ƒ-equation ua X (A X) (ฯ† X)

โ„-equiv : is-univalent ๐“ค
        โ†’ (X : ๐“ค ฬ‡ ) (A : (Y : ๐“ค ฬ‡ ) โ†’ (X โ†’ Y) โ†’ ๐“ฅ ฬ‡ )
        โ†’ A X (๐‘–๐‘‘ X) โ†’ (Y : ๐“ค ฬ‡ ) (f : X โ†’ Y) โ†’ is-equiv f โ†’ A Y f

โ„-equiv {๐“ค} {๐“ฅ} ua X A a Y f i = ฮณ (f , i)
 where
  B : (Y : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฅ ฬ‡
  B Y (f , i) = A Y f

  b : B X (id-โ‰ƒ X)
  b = a

  ฮณ : (e : X โ‰ƒ Y) โ†’ B Y e
  ฮณ = โ„-โ‰ƒ ua X B b Y

๐•-equiv : is-univalent ๐“ค
        โ†’ (A : (X Y : ๐“ค ฬ‡ ) โ†’ (X โ†’ Y) โ†’ ๐“ฅ ฬ‡ )
        โ†’ ((X : ๐“ค ฬ‡ ) โ†’ A X X (๐‘–๐‘‘ X))
        โ†’ (X Y : ๐“ค ฬ‡ ) (f : X โ†’ Y) โ†’ is-equiv f โ†’ A X Y f

๐•-equiv ua A ฯ† X = โ„-equiv ua X (A X) (ฯ† X)

๐•-invertible : is-univalent ๐“ค
             โ†’ (A : (X Y : ๐“ค ฬ‡ ) โ†’ (X โ†’ Y) โ†’ ๐“ฅ ฬ‡ )
             โ†’ ((X : ๐“ค ฬ‡ ) โ†’ A X X (๐‘–๐‘‘ X))
             โ†’ (X Y : ๐“ค ฬ‡ ) (f : X โ†’ Y) โ†’ invertible f โ†’ A X Y f

๐•-invertible ua A ฯ† X Y f i = ๐•-equiv ua A ฯ† X Y f (invertibles-are-equivs f i)

automatic-equiv-functoriality :

      (F : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡ )
      (๐“• : {X Y : ๐“ค ฬ‡ }  โ†’ (X โ†’ Y) โ†’ F X โ†’ F Y)
      (๐“•-id : {X : ๐“ค ฬ‡ } โ†’ ๐“• (๐‘–๐‘‘ X) โ‰ก ๐‘–๐‘‘ (F X))
      {X Y Z : ๐“ค ฬ‡ }
      (f : X โ†’ Y)
      (g : Y โ†’ Z)

    โ†’ is-univalent ๐“ค
    โ†’ is-equiv f + is-equiv g
    โ†’ ๐“• (g โˆ˜ f) โ‰ก ๐“• g โˆ˜ ๐“• f

automatic-equiv-functoriality {๐“ค} F ๐“• ๐“•-id {X} {Y} {Z} f g ua = ฮณ
  where
   ฮณ :  is-equiv f + is-equiv g โ†’ ๐“• (g โˆ˜ f) โ‰ก ๐“• g โˆ˜ ๐“• f
   ฮณ (inl i) = โ„-equiv ua X A a Y f i g
    where
     A : (Y : ๐“ค ฬ‡ ) โ†’ (X โ†’ Y) โ†’ ๐“ค ฬ‡
     A Y f = (g : Y โ†’ Z) โ†’ ๐“• (g โˆ˜ f) โ‰ก ๐“• g โˆ˜ ๐“• f

     a : (g : X โ†’ Z) โ†’ ๐“• g โ‰ก ๐“• g โˆ˜ ๐“• id
     a g = ap (๐“• g โˆ˜_) (๐“•-id โปยน)

   ฮณ (inr j) = โ„-equiv ua Y B b Z g j f
    where
     B : (Z : ๐“ค ฬ‡ ) โ†’ (Y โ†’ Z) โ†’ ๐“ค ฬ‡
     B Z g = (f : X โ†’ Y) โ†’ ๐“• (g โˆ˜ f) โ‰ก ๐“• g โˆ˜ ๐“• f

     b : (f : X โ†’ Y) โ†’ ๐“• f โ‰ก ๐“• (๐‘–๐‘‘ Y) โˆ˜ ๐“• f
     b f = ap (_โˆ˜ ๐“• f) (๐“•-id โปยน)

ฮฃ-change-of-variable' : is-univalent ๐“ค
                      โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (f : X โ†’ Y)
                      โ†’ (i : is-equiv f)
                      โ†’ (ฮฃ x ๊ž‰ X , A x) โ‰ก (ฮฃ y ๊ž‰ Y , A (inverse f i y))

ฮฃ-change-of-variable' {๐“ค} {๐“ฅ} ua {X} {Y} A f i = โ„-โ‰ƒ ua X B b Y (f , i)
 where
   B : (Y : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ Y โ†’  (๐“ค โŠ” ๐“ฅ)โบ ฬ‡
   B Y (f , i) = ฮฃ A โ‰ก (ฮฃ (A โˆ˜ inverse f i))

   b : B X (id-โ‰ƒ X)
   b = refl (ฮฃ A)

ฮฃ-change-of-variable'' : is-univalent ๐“ค
                       โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ค ฬ‡ } (A : Y โ†’ ๐“ฅ ฬ‡ ) (f : X โ†’ Y)
                       โ†’ is-equiv f
                       โ†’ (ฮฃ y ๊ž‰ Y , A y) โ‰ก (ฮฃ x ๊ž‰ X , A (f x))

ฮฃ-change-of-variable'' ua A f i = ฮฃ-change-of-variable' ua A
                                  (inverse f i)
                                  (inverses-are-equivs f i)

transport-map-along-โ‰ก : {X Y Z : ๐“ค ฬ‡ }
                        (p : X โ‰ก Y) (g : X โ†’ Z)
                      โ†’ transport (ฮป - โ†’ - โ†’ Z) p g
                      โ‰ก g โˆ˜ Idโ†’fun (p โปยน)

transport-map-along-โ‰ก (refl X) = refl

transport-map-along-โ‰ƒ : (ua : is-univalent ๐“ค) {X Y Z : ๐“ค ฬ‡ }
                        (e : X โ‰ƒ Y) (g : X โ†’ Z)
                      โ†’ transport (ฮป - โ†’ - โ†’ Z) (Eqโ†’Id ua X Y e) g
                      โ‰ก g โˆ˜ โŒœ โ‰ƒ-sym e โŒ

transport-map-along-โ‰ƒ {๐“ค} ua {X} {Y} {Z} = ๐•-โ‰ƒ ua A a X Y
 where
  A : (X Y : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ค ฬ‡
  A X Y e = (g : X โ†’ Z) โ†’ transport (ฮป - โ†’ - โ†’ Z) (Eqโ†’Id ua X Y e) g
                        โ‰ก g โˆ˜ โŒœ โ‰ƒ-sym e โŒ
  a : (X : ๐“ค ฬ‡ ) โ†’ A X X (id-โ‰ƒ X)
  a X g = transport (ฮป - โ†’ - โ†’ Z) (Eqโ†’Id ua X X (id-โ‰ƒ X)) g โ‰กโŸจ q      โŸฉ
          transport (ฮป - โ†’ - โ†’ Z) (refl X) g                โ‰กโŸจ refl _ โŸฉ
          g                                                 โˆŽ
    where
     p : Eqโ†’Id ua X X (id-โ‰ƒ X) โ‰ก refl X
     p = inverses-are-retractions (Idโ†’Eq X X) (ua X X) (refl X)

     q = ap (ฮป - โ†’ transport (ฮป - โ†’ - โ†’ Z) - g) p

is-hae : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
is-hae f = ฮฃ g ๊ž‰ (codomain f โ†’ domain f)
         , ฮฃ ฮท ๊ž‰ g โˆ˜ f โˆผ id
         , ฮฃ ฮต ๊ž‰ f โˆ˜ g โˆผ id
         , ((x : domain f) โ†’ ap f (ฮท x) โ‰ก ฮต (f x))

haes-are-invertible : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                    โ†’ is-hae f โ†’ invertible f

haes-are-invertible f (g , ฮท , ฮต , ฯ„) = g , ฮท , ฮต

transport-ap-โ‰ƒ : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                 {x x' : X} (a : x' โ‰ก x) (b : f x' โ‰ก f x)
               โ†’ (transport (ฮป - โ†’ f - โ‰ก f x) a b โ‰ก refl (f x))
               โ‰ƒ (ap f a โ‰ก b)

transport-ap-โ‰ƒ f (refl x) b = ฮณ
 where
  ฮณ : (b โ‰ก refl (f x)) โ‰ƒ (refl (f x) โ‰ก b)
  ฮณ = โปยน-โ‰ƒ b (refl (f x))

haes-are-equivs : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                โ†’ is-hae f โ†’ is-equiv f

haes-are-equivs f (g , ฮท , ฮต , ฯ„) y = ฮณ
 where
  c : (ฯ† : fiber f y) โ†’ (g y , ฮต y) โ‰ก ฯ†
  c (x , refl .(f x)) = q
   where
    p : transport (ฮป - โ†’ f - โ‰ก f x) (ฮท x) (ฮต (f x)) โ‰ก refl (f x)
    p = โŒœ โ‰ƒ-sym (transport-ap-โ‰ƒ f (ฮท x) (ฮต (f x))) โŒ (ฯ„ x)

    q : (g (f x) , ฮต (f x)) โ‰ก (x , refl (f x))
    q = to-ฮฃ-โ‰ก (ฮท x , p)

  ฮณ : is-singleton (fiber f y)
  ฮณ = (g y , ฮต y) , c

id-is-hae : (X : ๐“ค ฬ‡ ) โ†’ is-hae (๐‘–๐‘‘ X)
id-is-hae X = ๐‘–๐‘‘ X , refl , refl , (ฮป x โ†’ refl (refl x))

ua-equivs-are-haes : is-univalent ๐“ค
                   โ†’ {X Y : ๐“ค ฬ‡ } (f : X โ†’ Y)
                   โ†’ is-equiv f โ†’ is-hae f

ua-equivs-are-haes ua {X} {Y} = ๐•-equiv ua (ฮป X Y f โ†’ is-hae f) id-is-hae X Y

equivs-are-haes : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                โ†’ is-equiv f โ†’ is-hae f

equivs-are-haes {๐“ค} {๐“ฅ} {X} {Y} f i = (g , ฮท , ฮต , ฯ„)
 where
  g : Y โ†’ X
  g = inverse f i

  ฮท : g โˆ˜ f โˆผ id
  ฮท = inverses-are-retractions f i

  ฮต : f โˆ˜ g โˆผ id
  ฮต = inverses-are-sections f i

  ฯ„ : (x : X) โ†’ ap f (ฮท x) โ‰ก ฮต (f x)
  ฯ„ x = ฮณ
   where
    ฯ† : fiber f (f x)
    ฯ† = center (fiber f (f x)) (i (f x))

    by-definition-of-g : g (f x) โ‰ก fiber-point ฯ†
    by-definition-of-g = refl _

    p : ฯ† โ‰ก (x , refl (f x))
    p = centrality (fiber f (f x)) (i (f x)) (x , refl (f x))

    a : g (f x) โ‰ก x
    a = ap fiber-point p

    b : f (g (f x)) โ‰ก f x
    b = fiber-identification ฯ†

    by-definition-of-ฮท : ฮท x โ‰ก a
    by-definition-of-ฮท = refl _

    by-definition-of-ฮต : ฮต (f x) โ‰ก b
    by-definition-of-ฮต = refl _

    q = transport (ฮป - โ†’ f - โ‰ก f x)       a          b         โ‰กโŸจ refl _    โŸฉ
        transport (ฮป - โ†’ f - โ‰ก f x)       (ap prโ‚ p) (prโ‚‚ ฯ†)   โ‰กโŸจ t         โŸฉ
        transport (ฮป - โ†’ f (prโ‚ -) โ‰ก f x) p          (prโ‚‚ ฯ†)   โ‰กโŸจ apd prโ‚‚ p โŸฉ
        refl (f x)                                             โˆŽ
     where
      t = (transport-ap (ฮป - โ†’ f - โ‰ก f x) prโ‚ p b)โปยน

    ฮณ : ap f (ฮท x) โ‰ก ฮต (f x)
    ฮณ = โŒœ transport-ap-โ‰ƒ f a b โŒ q

equivs-are-haes' : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                 โ†’ is-equiv f โ†’ is-hae f

equivs-are-haes' f e = (inverse f e ,
                        inverses-are-retractions f e ,
                        inverses-are-sections f e ,
                        ฯ„)
 where
  ฯ„ : โˆ€ x โ†’ ap f (inverses-are-retractions f e x) โ‰ก inverses-are-sections f e (f x)
  ฯ„ x = โŒœ transport-ap-โ‰ƒ f (ap prโ‚ p) (prโ‚‚ ฯ†) โŒ q
   where
    ฯ† : fiber f (f x)
    ฯ† = prโ‚ (e (f x))

    p : ฯ† โ‰ก (x , refl (f x))
    p = prโ‚‚ (e (f x)) (x , refl (f x))

    q : transport (ฮป - โ†’ f - โ‰ก f x) (ap prโ‚ p) (prโ‚‚ ฯ†) โ‰ก refl (f x)
    q = (transport-ap (ฮป - โ†’ f - โ‰ก f x) prโ‚ p ((prโ‚‚ ฯ†)))โปยน โˆ™ apd prโ‚‚ p

equiv-invertible-hae-factorization : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                                   โ†’ equivs-are-invertible f
                                   โˆผ haes-are-invertible f โˆ˜ equivs-are-haes f

equiv-invertible-hae-factorization f e = refl (equivs-are-invertible f e)

half-adjoint-condition : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y) (e : is-equiv f) (x : X)
                       โ†’ ap f (inverses-are-retractions f e x) โ‰ก inverses-are-sections f e (f x)

half-adjoint-condition f e = prโ‚‚ (prโ‚‚ (prโ‚‚ (equivs-are-haes f e)))

ฮฃ-change-of-variable : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (A : Y โ†’ ๐“ฆ ฬ‡ ) (f : X โ†’ Y)
                     โ†’ is-equiv f โ†’ (ฮฃ y ๊ž‰ Y , A y) โ‰ƒ (ฮฃ x ๊ž‰ X , A (f x))

ฮฃ-change-of-variable {๐“ค} {๐“ฅ} {๐“ฆ} {X} {Y} A f i = ฮณ
 where
  g = inverse f i
  ฮท = inverses-are-retractions f i
  ฮต = inverses-are-sections f i
  ฯ„ = half-adjoint-condition f i

  ฯ† : ฮฃ A โ†’ ฮฃ (A โˆ˜ f)
  ฯ† (y , a) = (g y , transport A ((ฮต y)โปยน) a)

  ฯˆ : ฮฃ (A โˆ˜ f) โ†’ ฮฃ A
  ฯˆ (x , a) = (f x , a)

  ฯˆฯ† : (z : ฮฃ A) โ†’ ฯˆ (ฯ† z) โ‰ก z
  ฯˆฯ† (y , a) = p
   where
    p : (f (g y) , transport A ((ฮต y)โปยน) a) โ‰ก (y , a)
    p = to-ฮฃ-โ‰ก (ฮต y , transport-is-retraction A (ฮต y) a)

  ฯ†ฯˆ : (t : ฮฃ (A โˆ˜ f)) โ†’ ฯ† (ฯˆ t) โ‰ก t
  ฯ†ฯˆ (x , a) = p
   where
    a' : A (f (g (f x)))
    a' = transport A ((ฮต (f x))โปยน) a

    q = transport (A โˆ˜ f) (ฮท x)  a' โ‰กโŸจ transport-ap A f (ฮท x) a'             โŸฉ
        transport A (ap f (ฮท x)) a' โ‰กโŸจ ap (ฮป - โ†’ transport A - a') (ฯ„ x)     โŸฉ
        transport A (ฮต (f x))    a' โ‰กโŸจ transport-is-retraction A (ฮต (f x)) a โŸฉ
        a                           โˆŽ

    p : (g (f x) , transport A ((ฮต (f x))โปยน) a) โ‰ก (x , a)
    p = to-ฮฃ-โ‰ก (ฮท x , q)

  ฮณ : ฮฃ A โ‰ƒ ฮฃ (A โˆ˜ f)
  ฮณ = invertibility-gives-โ‰ƒ ฯ† (ฯˆ , ฯˆฯ† , ฯ†ฯˆ)

~-naturality : {X : ๐“ค ฬ‡ } {A : ๐“ฅ ฬ‡ }
               (f g : X โ†’ A) (H : f โˆผ g) {x y : X} {p : x โ‰ก y}
             โ†’ H x โˆ™ ap g p โ‰ก ap f p โˆ™ H y

~-naturality f g H {x} {_} {refl a} = refl-left โปยน

~-naturality' : {X : ๐“ค ฬ‡ } {A : ๐“ฅ ฬ‡ }
                (f g : X โ†’ A) (H : f โˆผ g) {x y : X} {p : x โ‰ก y}
              โ†’ H x โˆ™ ap g p โˆ™ (H y)โปยน โ‰ก ap f p

~-naturality' f g H {x} {x} {refl x} = โปยน-rightโˆ™ (H x)

~-id-naturality : {X : ๐“ค ฬ‡ }
                  (h : X โ†’ X) (ฮท : h โˆผ id) {x : X}
                โ†’ ฮท (h x) โ‰ก ap h (ฮท x)

~-id-naturality h ฮท {x} =

   ฮท (h x)                         โ‰กโŸจ refl _ โŸฉ
   ฮท (h x) โˆ™ refl (h x)            โ‰กโŸจ i      โŸฉ
   ฮท (h x) โˆ™ (ฮท x โˆ™ (ฮท x)โปยน)       โ‰กโŸจ ii     โŸฉ
   ฮท (h x) โˆ™ ฮท x โˆ™ (ฮท x)โปยน         โ‰กโŸจ iii    โŸฉ
   ฮท (h x) โˆ™ ap id (ฮท x) โˆ™ (ฮท x)โปยน โ‰กโŸจ iv     โŸฉ
   ap h (ฮท x)                      โˆŽ

 where
  i   = ap (ฮท(h x) โˆ™_) ((โปยน-rightโˆ™ (ฮท x))โปยน)
  ii  = (โˆ™assoc (ฮท (h x)) (ฮท x) (ฮท x โปยน))โปยน
  iii = ap (ฮป - โ†’ ฮท (h x) โˆ™ - โˆ™ ฮท x โปยน) ((ap-id (ฮท x))โปยน)
  iv  = ~-naturality' h id ฮท {h x} {x} {ฮท x}

invertibles-are-haes : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                     โ†’ invertible f โ†’ is-hae f

invertibles-are-haes f (g , ฮท , ฮต) = g , ฮท , ฮต' , ฯ„
 where
  ฮต' = ฮป y โ†’ f (g y)         โ‰กโŸจ (ฮต (f (g y)))โปยน โŸฉ
             f (g (f (g y))) โ‰กโŸจ ap f (ฮท (g y))  โŸฉ
             f (g y)         โ‰กโŸจ ฮต y โŸฉ
             y               โˆŽ

  module _ (x : domain f) where

   p = ฮท (g (f x))       โ‰กโŸจ ~-id-naturality (g โˆ˜ f) ฮท  โŸฉ
       ap (g โˆ˜ f) (ฮท x)  โ‰กโŸจ ap-โˆ˜ f g (ฮท x)             โŸฉ
       ap g (ap f (ฮท x)) โˆŽ

   q = ap f (ฮท (g (f x))) โˆ™ ฮต (f x)          โ‰กโŸจ by-p            โŸฉ
       ap f (ap g (ap f (ฮท x))) โˆ™ ฮต (f x)    โ‰กโŸจ by-ap-โˆ˜         โŸฉ
       ap (f โˆ˜ g) (ap f (ฮท x))  โˆ™ ฮต (f x)    โ‰กโŸจ by-~-naturality โŸฉ
       ฮต (f (g (f x))) โˆ™ ap id (ap f (ฮท x))  โ‰กโŸจ by-ap-id        โŸฉ
       ฮต (f (g (f x))) โˆ™ ap f (ฮท x)          โˆŽ
    where
     by-p            = ap (ฮป - โ†’ ap f - โˆ™ ฮต (f x)) p
     by-ap-โˆ˜         = ap (_โˆ™ ฮต (f x)) ((ap-โˆ˜ g f (ap f (ฮท x)))โปยน)
     by-~-naturality = (~-naturality (f โˆ˜ g) id ฮต {f (g (f x))} {f x} {ap f (ฮท x)})โปยน
     by-ap-id        = ap (ฮต (f (g (f x))) โˆ™_) (ap-id (ap f (ฮท x)))

   ฯ„ = ap f (ฮท x)                                           โ‰กโŸจ refl-left โปยน โŸฉ
       refl (f (g (f x)))                     โˆ™ ap f (ฮท x)  โ‰กโŸจ by-โปยน-leftโˆ™  โŸฉ
       (ฮต (f (g (f x))))โปยน โˆ™  ฮต (f (g (f x))) โˆ™ ap f (ฮท x)  โ‰กโŸจ by-โˆ™assoc    โŸฉ
       (ฮต (f (g (f x))))โปยน โˆ™ (ฮต (f (g (f x))) โˆ™ ap f (ฮท x)) โ‰กโŸจ by-q         โŸฉ
       (ฮต (f (g (f x))))โปยน โˆ™ (ap f (ฮท (g (f x))) โˆ™ ฮต (f x)) โ‰กโŸจ refl _       โŸฉ
       ฮต' (f x)                                             โˆŽ
    where
     by-โปยน-leftโˆ™ = ap (_โˆ™ ap f (ฮท x)) ((โปยน-leftโˆ™ (ฮต (f (g (f x)))))โปยน)
     by-โˆ™assoc   = โˆ™assoc ((ฮต (f (g (f x))))โปยน) (ฮต (f (g (f x)))) (ap f (ฮท x))
     by-q        = ap ((ฮต (f (g (f x))))โปยน โˆ™_) (q โปยน)

funext : โˆ€ ๐“ค ๐“ฅ โ†’ (๐“ค โŠ” ๐“ฅ)โบ ฬ‡
funext ๐“ค ๐“ฅ = {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {f g : X โ†’ Y} โ†’ f โˆผ g โ†’ f โ‰ก g

precomp-is-equiv : is-univalent ๐“ค
                 โ†’ (X Y : ๐“ค ฬ‡ ) (f : X โ†’ Y)
                 โ†’ is-equiv f
                 โ†’ (Z : ๐“ค ฬ‡ ) โ†’ is-equiv (ฮป (g : Y โ†’ Z) โ†’ g โˆ˜ f)

precomp-is-equiv {๐“ค} ua =
   ๐•-equiv ua
     (ฮป X Y (f : X โ†’ Y) โ†’ (Z : ๐“ค ฬ‡ ) โ†’ is-equiv (ฮป g โ†’ g โˆ˜ f))
     (ฮป X Z โ†’ id-is-equiv (X โ†’ Z))

univalence-gives-funext : is-univalent ๐“ค โ†’ funext ๐“ฅ ๐“ค
univalence-gives-funext {๐“ค} {๐“ฅ} ua {X} {Y} {fโ‚€} {fโ‚} = ฮณ
 where
  ฮ” : ๐“ค ฬ‡
  ฮ” = ฮฃ yโ‚€ ๊ž‰ Y , ฮฃ yโ‚ ๊ž‰ Y , yโ‚€ โ‰ก yโ‚

  ฮด : Y โ†’ ฮ”
  ฮด y = (y , y , refl y)

  ฯ€โ‚€ ฯ€โ‚ : ฮ” โ†’ Y
  ฯ€โ‚€ (yโ‚€ , yโ‚ , p) = yโ‚€
  ฯ€โ‚ (yโ‚€ , yโ‚ , p) = yโ‚

  ฮด-is-equiv : is-equiv ฮด
  ฮด-is-equiv = invertibles-are-equivs ฮด (ฯ€โ‚€ , ฮท , ฮต)
   where
    ฮท : (y : Y) โ†’ ฯ€โ‚€ (ฮด y) โ‰ก y
    ฮท y = refl y

    ฮต : (d : ฮ”) โ†’ ฮด (ฯ€โ‚€ d) โ‰ก d
    ฮต (y , y , refl y) = refl (y , y , refl y)

  ฯ† : (ฮ” โ†’ Y) โ†’ (Y โ†’ Y)
  ฯ† ฯ€ = ฯ€ โˆ˜ ฮด

  ฯ†-is-equiv : is-equiv ฯ†
  ฯ†-is-equiv = precomp-is-equiv ua Y ฮ” ฮด ฮด-is-equiv Y

  p : ฯ† ฯ€โ‚€ โ‰ก ฯ† ฯ€โ‚
  p = refl (๐‘–๐‘‘ Y)

  q : ฯ€โ‚€ โ‰ก ฯ€โ‚
  q = equivs-are-lc ฯ† ฯ†-is-equiv p

  ฮณ : fโ‚€ โˆผ fโ‚ โ†’ fโ‚€ โ‰ก fโ‚
  ฮณ h = ap (ฮป ฯ€ x โ†’ ฯ€ (fโ‚€ x , fโ‚ x , h x)) q

  ฮณ' : fโ‚€ โˆผ fโ‚ โ†’ fโ‚€ โ‰ก fโ‚
  ฮณ' h = fโ‚€                             โ‰กโŸจ refl _                               โŸฉ
         (ฮป x โ†’ fโ‚€ x)                   โ‰กโŸจ refl _                               โŸฉ
         (ฮป x โ†’ ฯ€โ‚€ (fโ‚€ x , fโ‚ x , h x)) โ‰กโŸจ ap (ฮป - x โ†’ - (fโ‚€ x , fโ‚ x , h x)) q โŸฉ
         (ฮป x โ†’ ฯ€โ‚ (fโ‚€ x , fโ‚ x , h x)) โ‰กโŸจ refl _                               โŸฉ
         (ฮป x โ†’ fโ‚ x)                   โ‰กโŸจ refl _                               โŸฉ
         fโ‚                             โˆŽ

dfunext : โˆ€ ๐“ค ๐“ฅ โ†’ (๐“ค โŠ” ๐“ฅ)โบ ฬ‡
dfunext ๐“ค ๐“ฅ = {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {f g : ฮ  A} โ†’ f โˆผ g โ†’ f โ‰ก g

happly : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } (f g : ฮ  A) โ†’ f โ‰ก g โ†’ f โˆผ g
happly f g p x = ap (ฮป - โ†’ - x) p

hfunext : โˆ€ ๐“ค ๐“ฅ โ†’ (๐“ค โŠ” ๐“ฅ)โบ ฬ‡
hfunext ๐“ค ๐“ฅ = {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } (f g : ฮ  A) โ†’ is-equiv (happly f g)

hfunext-gives-dfunext : hfunext ๐“ค ๐“ฅ โ†’ dfunext ๐“ค ๐“ฅ
hfunext-gives-dfunext hfe {X} {A} {f} {g} = inverse (happly f g) (hfe f g)

vvfunext : โˆ€ ๐“ค ๐“ฅ โ†’ (๐“ค โŠ” ๐“ฅ)โบ ฬ‡
vvfunext ๐“ค ๐“ฅ = {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
             โ†’ ((x : X) โ†’ is-singleton (A x))
             โ†’ is-singleton (ฮ  A)

dfunext-gives-vvfunext : dfunext ๐“ค ๐“ฅ โ†’ vvfunext ๐“ค ๐“ฅ
dfunext-gives-vvfunext fe {X} {A} i = ฮณ
 where
  f : ฮ  A
  f x = center (A x) (i x)

  c : (g : ฮ  A) โ†’ f โ‰ก g
  c g = fe (ฮป (x : X) โ†’ centrality (A x) (i x) (g x))

  ฮณ : is-singleton (ฮ  A)
  ฮณ = f , c

vvfunext-gives-hfunext : vvfunext ๐“ค ๐“ฅ โ†’ hfunext ๐“ค ๐“ฅ
vvfunext-gives-hfunext vfe {X} {Y} f = ฮณ
 where
  a : (x : X) โ†’ is-singleton (ฮฃ y ๊ž‰ Y x , f x โ‰ก y)
  a x = singleton-types'-are-singletons (Y x) (f x)

  c : is-singleton (ฮ  x ๊ž‰ X , ฮฃ y ๊ž‰ Y x , f x โ‰ก y)
  c = vfe a

  ฯ : (ฮฃ g ๊ž‰ ฮ  Y , f โˆผ g) โ— (ฮ  x ๊ž‰ X , ฮฃ y ๊ž‰ Y x , f x โ‰ก y)
  ฯ = โ‰ƒ-gives-โ–ท ฮ ฮฃ-distr-โ‰ƒ

  d : is-singleton (ฮฃ g ๊ž‰ ฮ  Y , f โˆผ g)
  d = retract-of-singleton ฯ c

  e : (ฮฃ g ๊ž‰ ฮ  Y , f โ‰ก g) โ†’ (ฮฃ g ๊ž‰ ฮ  Y , f โˆผ g)
  e = Natฮฃ (happly f)

  i : is-equiv e
  i = maps-of-singletons-are-equivs e (singleton-types'-are-singletons (ฮ  Y) f) d

  ฮณ : (g : ฮ  Y) โ†’ is-equiv (happly f g)
  ฮณ = Natฮฃ-equiv-gives-fiberwise-equiv (happly f) i

postcomp-invertible : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {A : ๐“ฆ ฬ‡ }
                    โ†’ funext ๐“ฆ ๐“ค
                    โ†’ funext ๐“ฆ ๐“ฅ
                    โ†’ (f : X โ†’ Y)
                    โ†’ invertible f
                    โ†’ invertible (ฮป (h : A โ†’ X) โ†’ f โˆ˜ h)

postcomp-invertible {๐“ค} {๐“ฅ} {๐“ฆ} {X} {Y} {A} fe fe' f (g , ฮท , ฮต) = ฮณ
 where
  f' : (A โ†’ X) โ†’ (A โ†’ Y)
  f' h = f โˆ˜ h

  g' : (A โ†’ Y) โ†’ (A โ†’ X)
  g' k = g โˆ˜ k

  ฮท' : (h : A โ†’ X) โ†’ g' (f' h) โ‰ก h
  ฮท' h = fe (ฮท โˆ˜ h)

  ฮต' : (k : A โ†’ Y) โ†’ f' (g' k) โ‰ก k
  ฮต' k = fe' (ฮต โˆ˜ k)

  ฮณ : invertible f'
  ฮณ = (g' , ฮท' , ฮต')

postcomp-is-equiv : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {A : ๐“ฆ ฬ‡ }
                  โ†’ funext ๐“ฆ ๐“ค
                  โ†’ funext ๐“ฆ ๐“ฅ
                  โ†’ (f : X โ†’ Y)
                  โ†’ is-equiv f
                  โ†’ is-equiv (ฮป (h : A โ†’ X) โ†’ f โˆ˜ h)

postcomp-is-equiv fe fe' f e =
 invertibles-are-equivs
  (ฮป h โ†’ f โˆ˜ h)
  (postcomp-invertible fe fe' f (equivs-are-invertible f e))

funext-gives-vvfunext : funext ๐“ค (๐“ค โŠ” ๐“ฅ) โ†’ funext ๐“ค ๐“ค โ†’ vvfunext ๐“ค ๐“ฅ
funext-gives-vvfunext {๐“ค} {๐“ฅ} fe fe' {X} {A} ฯ† = ฮณ
 where
  f : ฮฃ A โ†’ X
  f = prโ‚

  f-is-equiv : is-equiv f
  f-is-equiv = prโ‚-is-equiv ฯ†

  g : (X โ†’ ฮฃ A) โ†’ (X โ†’ X)
  g h = f โˆ˜ h

  e : is-equiv g
  e = postcomp-is-equiv fe fe' f f-is-equiv

  i : is-singleton (ฮฃ h ๊ž‰ (X โ†’ ฮฃ A), f โˆ˜ h โ‰ก ๐‘–๐‘‘ X)
  i = e (๐‘–๐‘‘ X)

  r : (ฮฃ h ๊ž‰ (X โ†’ ฮฃ A), f โˆ˜ h โ‰ก ๐‘–๐‘‘ X) โ†’ ฮ  A
  r (h , p) x = transport A (happly (f โˆ˜ h) (๐‘–๐‘‘ X) p x) (prโ‚‚ (h x))

  s : ฮ  A โ†’ (ฮฃ h ๊ž‰ (X โ†’ ฮฃ A), f โˆ˜ h โ‰ก ๐‘–๐‘‘ X)
  s ฯˆ = (ฮป x โ†’ x , ฯˆ x) , refl (๐‘–๐‘‘ X)

  ฮท : โˆ€ ฯˆ โ†’ r (s ฯˆ) โ‰ก ฯˆ
  ฮท ฯˆ = refl (r (s ฯˆ))

  ฮณ : is-singleton (ฮ  A)
  ฮณ = retract-of-singleton (r , s , ฮท) i

abstract
 funext-gives-hfunext       : funext ๐“ค (๐“ค โŠ” ๐“ฅ) โ†’ funext ๐“ค ๐“ค โ†’ hfunext ๐“ค ๐“ฅ
 dfunext-gives-hfunext      : dfunext ๐“ค ๐“ฅ โ†’ hfunext ๐“ค ๐“ฅ
 funext-gives-dfunext       : funext ๐“ค (๐“ค โŠ” ๐“ฅ) โ†’ funext ๐“ค ๐“ค โ†’ dfunext ๐“ค ๐“ฅ
 univalence-gives-dfunext'  : is-univalent ๐“ค โ†’ is-univalent (๐“ค โŠ” ๐“ฅ) โ†’ dfunext ๐“ค ๐“ฅ
 univalence-gives-hfunext'  : is-univalent ๐“ค โ†’ is-univalent (๐“ค โŠ” ๐“ฅ) โ†’ hfunext ๐“ค ๐“ฅ
 univalence-gives-vvfunext' : is-univalent ๐“ค โ†’ is-univalent (๐“ค โŠ” ๐“ฅ) โ†’ vvfunext ๐“ค ๐“ฅ
 univalence-gives-hfunext   : is-univalent ๐“ค โ†’ hfunext ๐“ค ๐“ค
 univalence-gives-dfunext   : is-univalent ๐“ค โ†’ dfunext ๐“ค ๐“ค
 univalence-gives-vvfunext  : is-univalent ๐“ค โ†’ vvfunext ๐“ค ๐“ค

 funext-gives-hfunext fe fe' = vvfunext-gives-hfunext (funext-gives-vvfunext fe fe')

 funext-gives-dfunext fe fe' = hfunext-gives-dfunext (funext-gives-hfunext fe fe')

 dfunext-gives-hfunext fe = vvfunext-gives-hfunext (dfunext-gives-vvfunext fe)

 univalence-gives-dfunext' ua ua' = funext-gives-dfunext
                                     (univalence-gives-funext ua')
                                     (univalence-gives-funext ua)

 univalence-gives-hfunext' ua ua' = funext-gives-hfunext
                                      (univalence-gives-funext ua')
                                      (univalence-gives-funext ua)

 univalence-gives-vvfunext' ua ua' = funext-gives-vvfunext
                                      (univalence-gives-funext ua')
                                      (univalence-gives-funext ua)

 univalence-gives-hfunext ua = univalence-gives-hfunext' ua ua

 univalence-gives-dfunext ua = univalence-gives-dfunext' ua ua

 univalence-gives-vvfunext ua = univalence-gives-vvfunext' ua ua

_/_ : (๐“ค : Universe) โ†’ ๐“ฅ ฬ‡ โ†’ ๐“ค โบ โŠ” ๐“ฅ ฬ‡
๐“ค / Y = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , (X โ†’ Y)

total-fiber-is-domain : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                      โ†’ ฮฃ (fiber f) โ‰ƒ X

total-fiber-is-domain {๐“ค} {๐“ฅ} {X} {Y} f = invertibility-gives-โ‰ƒ g (h , ฮท , ฮต)
 where
  g : (ฮฃ y ๊ž‰ Y , ฮฃ x ๊ž‰ X , f x โ‰ก y) โ†’ X
  g (y , x , p) = x

  h : X โ†’ ฮฃ y ๊ž‰ Y , ฮฃ x ๊ž‰ X , f x โ‰ก y
  h x = (f x , x , refl (f x))

  ฮท : โˆ€ t โ†’ h (g t) โ‰ก t
  ฮท (_ , x , refl _) = refl (f x , x , refl _)

  ฮต : (x : X) โ†’ g (h x) โ‰ก x
  ฮต = refl

ฯ‡ : (Y : ๐“ค ฬ‡ ) โ†’ ๐“ค / Y  โ†’ (Y โ†’ ๐“ค ฬ‡ )
ฯ‡ Y (X , f) = fiber f

is-map-classifier : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
is-map-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 = Eqโ†’Id ua (ฮฃ (fiber f)) X e

  observation : โŒœ โ‰ƒ-sym e โŒ โ‰ก (ฮป x โ†’ f x , x , refl (f x))
  observation = refl _

  q = transport (ฮป - โ†’ - โ†’ Y) p prโ‚ โ‰กโŸจ transport-map-along-โ‰ƒ ua e prโ‚ โŸฉ
      prโ‚ โˆ˜ โŒœ โ‰ƒ-sym e โŒ             โ‰กโŸจ refl _                         โŸฉ
      f                             โˆŽ

  r : (ฮฃ (fiber f) , prโ‚) โ‰ก (X , f)
  r = to-ฮฃ-โ‰ก (p , q)

ฯ‡ฮต : is-univalent ๐“ค
   โ†’ dfunext ๐“ค (๐“ค โบ)
   โ†’ (Y : ๐“ค ฬ‡ ) (A : Y โ†’ ๐“ค ฬ‡ ) โ†’ ฯ‡ Y (๐•‹ Y A) โ‰ก A

ฯ‡ฮต ua fe Y A = fe ฮณ
 where
  f : โˆ€ y โ†’ fiber prโ‚ y โ†’ A y
  f y ((y , a) , refl p) = a

  g : โˆ€ y โ†’ A y โ†’ fiber prโ‚ y
  g y a = (y , a) , refl y

  ฮท : โˆ€ y ฯƒ โ†’ g y (f y ฯƒ) โ‰ก ฯƒ
  ฮท y ((y , a) , refl p) = refl ((y , a) , refl p)

  ฮต : โˆ€ y a โ†’ f y (g y a) โ‰ก a
  ฮต y a = refl a

  ฮณ : โˆ€ y โ†’ fiber prโ‚ y โ‰ก A y
  ฮณ y = Eqโ†’Id ua _ _ (invertibility-gives-โ‰ƒ (f y) (g y , ฮท y , ฮต y))

universes-are-map-classifiers : is-univalent ๐“ค
                              โ†’ dfunext ๐“ค (๐“ค โบ)
                              โ†’ is-map-classifier ๐“ค

universes-are-map-classifiers ua fe Y = invertibles-are-equivs (ฯ‡ Y)
                                         (๐•‹ Y , ฯ‡ฮท ua Y , ฯ‡ฮต ua fe Y)

map-classification : is-univalent ๐“ค
                   โ†’ dfunext ๐“ค (๐“ค โบ)
                   โ†’ (Y : ๐“ค ฬ‡ ) โ†’ ๐“ค / Y โ‰ƒ (Y โ†’ ๐“ค ฬ‡ )

map-classification ua fe Y = ฯ‡ Y , universes-are-map-classifiers ua fe Y

ฮ -is-subsingleton : dfunext ๐“ค ๐“ฅ
                  โ†’ {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
                  โ†’ ((x : X) โ†’ is-subsingleton (A x))
                  โ†’ is-subsingleton (ฮ  A)

ฮ -is-subsingleton fe i f g = fe (ฮป x โ†’ i x (f x) (g x))

being-singleton-is-subsingleton : dfunext ๐“ค ๐“ค
                                โ†’ {X : ๐“ค ฬ‡ } โ†’ is-subsingleton (is-singleton X)

being-singleton-is-subsingleton fe {X} (x , ฯ†) (y , ฮณ) = p
 where
  i : is-subsingleton X
  i = singletons-are-subsingletons X (y , ฮณ)

  s : is-set X
  s = subsingletons-are-sets X i

  a : (z : X) โ†’ is-subsingleton ((t : X) โ†’ z โ‰ก t)
  a z = ฮ -is-subsingleton fe (s z)

  b : x โ‰ก y
  b = ฯ† y

  p : (x , ฯ†) โ‰ก (y , ฮณ)
  p = to-subtype-โ‰ก a b

being-equiv-is-subsingleton : dfunext ๐“ฅ (๐“ค โŠ” ๐“ฅ)
                            โ†’ dfunext (๐“ค โŠ” ๐“ฅ) (๐“ค โŠ” ๐“ฅ)
                            โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                            โ†’ is-subsingleton (is-equiv f)

being-equiv-is-subsingleton fe fe' f = ฮ -is-subsingleton fe
                                        (ฮป x โ†’ being-singleton-is-subsingleton fe')

subsingletons-are-retracts-of-logically-equivalent-types : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                                                         โ†’ is-subsingleton X
                                                         โ†’ (X โ‡” Y)
                                                         โ†’ X โ— Y

subsingletons-are-retracts-of-logically-equivalent-types i (f , g) = g , f , ฮท
 where
  ฮท : g โˆ˜ f โˆผ id
  ฮท x = i (g (f x)) x

equivalence-property-is-retract-of-invertibility-data : dfunext ๐“ฅ (๐“ค โŠ” ๐“ฅ)
                                                      โ†’ dfunext (๐“ค โŠ” ๐“ฅ) (๐“ค โŠ” ๐“ฅ)
                                                      โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                                                      โ†’ is-equiv f โ— invertible f

equivalence-property-is-retract-of-invertibility-data fe fe' f =
  subsingletons-are-retracts-of-logically-equivalent-types
   (being-equiv-is-subsingleton fe fe' f)
   (equivs-are-invertible f , invertibles-are-equivs f)

univalence-is-subsingleton : is-univalent (๐“ค โบ)
                           โ†’ is-subsingleton (is-univalent ๐“ค)

univalence-is-subsingleton {๐“ค} uaโบ = subsingleton-criterion' ฮณ
 where
  ฮณ : is-univalent ๐“ค โ†’ is-subsingleton (is-univalent ๐“ค)
  ฮณ ua = i
   where
    dfeโ‚ : dfunext  ๐“ค    (๐“ค โบ)
    dfeโ‚‚ : dfunext (๐“ค โบ) (๐“ค โบ)

    dfeโ‚ = univalence-gives-dfunext' ua uaโบ
    dfeโ‚‚ = univalence-gives-dfunext uaโบ

    i : is-subsingleton (is-univalent ๐“ค)
    i = ฮ -is-subsingleton dfeโ‚‚
         (ฮป X โ†’ ฮ -is-subsingleton dfeโ‚‚
         (ฮป Y โ†’ being-equiv-is-subsingleton dfeโ‚ dfeโ‚‚ (Idโ†’Eq X Y)))

Univalence : ๐“คฯ‰
Univalence = โˆ€ ๐“ค โ†’ is-univalent ๐“ค

univalence-is-subsingletonฯ‰ : Univalence โ†’ is-subsingleton (is-univalent ๐“ค)
univalence-is-subsingletonฯ‰ {๐“ค} ฮณ = univalence-is-subsingleton (ฮณ (๐“ค โบ))

univalence-is-a-singleton : Univalence โ†’ is-singleton (is-univalent ๐“ค)
univalence-is-a-singleton {๐“ค} ฮณ = pointed-subsingletons-are-singletons
                                   (is-univalent ๐“ค)
                                   (ฮณ ๐“ค)
                                   (univalence-is-subsingletonฯ‰ ฮณ)

global-dfunext : ๐“คฯ‰
global-dfunext = โˆ€ {๐“ค ๐“ฅ} โ†’ dfunext ๐“ค ๐“ฅ

univalence-gives-global-dfunext : Univalence โ†’ global-dfunext
univalence-gives-global-dfunext ua {๐“ค} {๐“ฅ} = univalence-gives-dfunext'
                                               (ua ๐“ค) (ua (๐“ค โŠ” ๐“ฅ))

global-hfunext : ๐“คฯ‰
global-hfunext = โˆ€ {๐“ค ๐“ฅ} โ†’ hfunext ๐“ค ๐“ฅ

univalence-gives-global-hfunext : Univalence โ†’ global-hfunext
univalence-gives-global-hfunext ua {๐“ค} {๐“ฅ} = univalence-gives-hfunext'
                                               (ua ๐“ค) (ua (๐“ค โŠ” ๐“ฅ))

ฮ -is-subsingleton' : dfunext ๐“ค ๐“ฅ
                   โ†’ {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
                   โ†’ ((x : X) โ†’ is-subsingleton (A x))
                   โ†’ is-subsingleton ({x : X} โ†’ A x)

ฮ -is-subsingleton' fe {X} {A} i = ฮณ
 where
  ฯ : ({x : X} โ†’ A x) โ— ฮ  A
  ฯ = (ฮป f {x} โ†’ f x) , (ฮป g x โ†’ g {x}) , refl

  ฮณ : is-subsingleton ({x : X} โ†’ A x)
  ฮณ = retract-of-subsingleton ฯ (ฮ -is-subsingleton fe i)

vv-and-hfunext-are-subsingletons-lemma  : dfunext (๐“ค โบ)       (๐“ค โŠ” (๐“ฅ โบ))
                                        โ†’ dfunext (๐“ค โŠ” (๐“ฅ โบ)) (๐“ค โŠ” ๐“ฅ)
                                        โ†’ dfunext (๐“ค โŠ” ๐“ฅ)     (๐“ค โŠ” ๐“ฅ)

                                        โ†’ is-subsingleton (vvfunext ๐“ค ๐“ฅ)
                                        ร— is-subsingleton (hfunext  ๐“ค ๐“ฅ)

vv-and-hfunext-are-subsingletons-lemma {๐“ค} {๐“ฅ} dfe dfe' dfe'' = ฯ† , ฮณ
 where
  ฯ† : is-subsingleton (vvfunext ๐“ค ๐“ฅ)
  ฯ† = ฮ -is-subsingleton' dfe
       (ฮป X โ†’ ฮ -is-subsingleton' dfe'
       (ฮป A โ†’ ฮ -is-subsingleton dfe''
       (ฮป i โ†’ being-singleton-is-subsingleton dfe'')))

  ฮณ : is-subsingleton (hfunext ๐“ค ๐“ฅ)
  ฮณ = ฮ -is-subsingleton' dfe
       (ฮป X โ†’ ฮ -is-subsingleton' dfe'
       (ฮป A โ†’ ฮ -is-subsingleton dfe''
       (ฮป f โ†’ ฮ -is-subsingleton dfe''
       (ฮป g โ†’ being-equiv-is-subsingleton dfe'' dfe''
               (happly f g)))))

vv-and-hfunext-are-singletons : Univalence
                              โ†’ is-singleton (vvfunext ๐“ค ๐“ฅ)
                              ร— is-singleton (hfunext  ๐“ค ๐“ฅ)

vv-and-hfunext-are-singletons {๐“ค} {๐“ฅ} ua =

 f (vv-and-hfunext-are-subsingletons-lemma
     (univalence-gives-dfunext' (ua (๐“ค โบ))       (ua ((๐“ค โบ) โŠ” (๐“ฅ โบ))))
     (univalence-gives-dfunext' (ua (๐“ค โŠ” (๐“ฅ โบ))) (ua (๐“ค โŠ” (๐“ฅ โบ))))
     (univalence-gives-dfunext' (ua (๐“ค โŠ” ๐“ฅ))     (ua (๐“ค โŠ” ๐“ฅ))))

 where
  f : is-subsingleton (vvfunext ๐“ค ๐“ฅ) ร— is-subsingleton (hfunext ๐“ค ๐“ฅ)
    โ†’ is-singleton (vvfunext ๐“ค ๐“ฅ) ร— is-singleton (hfunext ๐“ค ๐“ฅ)

  f (i , j) = pointed-subsingletons-are-singletons (vvfunext ๐“ค ๐“ฅ)
                (univalence-gives-vvfunext' (ua ๐“ค) (ua (๐“ค โŠ” ๐“ฅ))) i ,

              pointed-subsingletons-are-singletons (hfunext ๐“ค ๐“ฅ)
                (univalence-gives-hfunext' (ua ๐“ค) (ua (๐“ค โŠ” ๐“ฅ))) j

โˆƒ! : {X : ๐“ค ฬ‡ } โ†’ (X โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
โˆƒ! A = is-singleton (ฮฃ A)

-โˆƒ! : {๐“ค ๐“ฅ : Universe} (X : ๐“ค ฬ‡ ) (Y : X โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
-โˆƒ! X Y = โˆƒ! Y

syntax -โˆƒ! A (ฮป x โ†’ b) = โˆƒ! x ๊ž‰ A , b

โˆƒ!-is-subsingleton : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ )
                   โ†’ dfunext (๐“ค โŠ” ๐“ฅ) (๐“ค โŠ” ๐“ฅ)
                   โ†’ is-subsingleton (โˆƒ! A)

โˆƒ!-is-subsingleton A fe = being-singleton-is-subsingleton fe

unique-existence-gives-weak-unique-existence : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ )

  โ†’ (โˆƒ! x ๊ž‰ X , A x)
  โ†’ (ฮฃ x ๊ž‰ X , A x) ร— ((x y : X) โ†’ A x โ†’ A y โ†’ x โ‰ก y)

unique-existence-gives-weak-unique-existence A s = center (ฮฃ A) s , u
 where
  u : โˆ€ x y โ†’ A x โ†’ A y โ†’ x โ‰ก y
  u x y a b = ap prโ‚ (singletons-are-subsingletons (ฮฃ A) s (x , a) (y , b))

weak-unique-existence-gives-unique-existence-sometimes : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ )

  โ†’  ((x : X) โ†’ is-subsingleton (A x))
  โ†’ ((ฮฃ x ๊ž‰ X , A x) ร— ((x y : X) โ†’ A x โ†’ A y โ†’ x โ‰ก y))
  โ†’ (โˆƒ! x ๊ž‰ X , A x)

weak-unique-existence-gives-unique-existence-sometimes A i ((x , a) , u) = (x , a) , ฯ†
 where
  ฯ† : (ฯƒ : ฮฃ A) โ†’ x , a โ‰ก ฯƒ
  ฯ† (y , b) = to-subtype-โ‰ก i (u x y a b)

โ„•-is-nno : hfunext ๐“คโ‚€ ๐“ค
         โ†’ (Y : ๐“ค ฬ‡ ) (yโ‚€ : Y) (g : Y โ†’ Y)
         โ†’ โˆƒ! h ๊ž‰ (โ„• โ†’ Y), (h 0 โ‰ก yโ‚€) ร— (h โˆ˜ succ โˆผ g โˆ˜ h)

โ„•-is-nno {๐“ค} hfe Y yโ‚€ g = ฮณ
 where

  lemmaโ‚€ : (h : โ„• โ†’ Y) โ†’ ((h 0 โ‰ก yโ‚€) ร— (h โˆ˜ succ โˆผ g โˆ˜ h)) โ— (h โˆผ โ„•-iteration Y yโ‚€ g)
  lemmaโ‚€ h = r , s , ฮท
   where
    s : (h 0 โ‰ก yโ‚€) ร— (h โˆ˜ succ โˆผ g โˆ˜ h) โ†’ h โˆผ โ„•-iteration Y yโ‚€ g
    s (p , K) 0        = p
    s (p , K) (succ n) = h (succ n)                  โ‰กโŸจ K n                โŸฉ
                         g (h n)                     โ‰กโŸจ ap g (s (p , K) n) โŸฉ
                         โ„•-iteration Y yโ‚€ g (succ n) โˆŽ

    r : codomain s โ†’ domain s
    r H = H 0 , (ฮป n โ†’ h (succ n)                  โ‰กโŸจ H (succ n)     โŸฉ
                       g (โ„•-iteration Y yโ‚€ g n)    โ‰กโŸจ ap g ((H n)โปยน) โŸฉ
                       g (h n )                    โˆŽ)

    ฮท : (z : (h 0 โ‰ก yโ‚€) ร— (h โˆ˜ succ โˆผ g โˆ˜ h)) โ†’ r (s z) โ‰ก z
    ฮท (p , K) = v
     where
      i = ฮป n โ†’
       K n โˆ™  ap g (s (p , K) n) โˆ™  ap g ((s (p , K) n) โปยน)                    โ‰กโŸจ ii  n โŸฉ
       K n โˆ™ (ap g (s (p , K) n) โˆ™  ap g ((s (p , K) n) โปยน))                   โ‰กโŸจ iii n โŸฉ
       K n โˆ™ (ap g (s (p , K) n) โˆ™ (ap g  (s (p , K) n))โปยน)                    โ‰กโŸจ iv  n โŸฉ
       K n                                                                     โˆŽ
        where
         ii  = ฮป n โ†’ โˆ™assoc (K n) (ap g (s (p , K) n)) (ap g ((s (p , K) n)โปยน))
         iii = ฮป n โ†’ ap (ฮป - โ†’ K n โˆ™ (ap g (s (p , K) n) โˆ™ -)) (apโปยน g (s (p , K) n) โปยน)
         iv  = ฮป n โ†’ ap (K n โˆ™_) (โปยน-rightโˆ™ (ap g (s (p , K) n)))

      v : (p , (ฮป n โ†’ s (p , K) (succ n) โˆ™ ap g ((s (p , K) n)โปยน))) โ‰ก (p , K)
      v = ap (p ,_) (hfunext-gives-dfunext hfe i)

  lemmaโ‚ = ฮป h โ†’ (h 0 โ‰ก yโ‚€) ร— (h โˆ˜ succ โˆผ g โˆ˜ h) โ—โŸจ lemmaโ‚€ h โŸฉ
                 (h โˆผ โ„•-iteration Y yโ‚€ g)        โ—โŸจ i h      โŸฉ
                 (h โ‰ก โ„•-iteration Y yโ‚€ g)        โ—€
   where
    i = ฮป h โ†’ โ‰ƒ-gives-โ–ท (happly h (โ„•-iteration Y yโ‚€ g) , hfe _ _)

  lemmaโ‚‚ : (ฮฃ h ๊ž‰ (โ„• โ†’ Y), (h 0 โ‰ก yโ‚€) ร— (h โˆ˜ succ โˆผ g โˆ˜ h))
         โ— (ฮฃ h ๊ž‰ (โ„• โ†’ Y), h โ‰ก โ„•-iteration Y yโ‚€ g)

  lemmaโ‚‚ = ฮฃ-retract lemmaโ‚

  ฮณ : is-singleton (ฮฃ h ๊ž‰ (โ„• โ†’ Y), (h 0 โ‰ก yโ‚€) ร— (h โˆ˜ succ โˆผ g โˆ˜ h))
  ฮณ = retract-of-singleton
       lemmaโ‚‚
       (singleton-types-are-singletons (โ„• โ†’ Y) (โ„•-iteration Y yโ‚€ g))

module finite-types (hfe : hfunext ๐“คโ‚€ ๐“คโ‚) where

 fin :  โˆƒ! Fin ๊ž‰ (โ„• โ†’ ๐“คโ‚€ ฬ‡ )
               , (Fin 0 โ‰ก ๐Ÿ˜)
               ร— ((n : โ„•) โ†’ Fin (succ  n) โ‰ก Fin n + ๐Ÿ™)

 fin = โ„•-is-nno hfe (๐“คโ‚€ ฬ‡ ) ๐Ÿ˜ (_+ ๐Ÿ™)

 Fin : โ„• โ†’ ๐“คโ‚€ ฬ‡
 Fin = prโ‚ (center _ fin)

 Fin-equationโ‚€ : Fin 0 โ‰ก ๐Ÿ˜
 Fin-equationโ‚€ = refl _

 Fin-equation-succ : Fin โˆ˜ succ โ‰ก ฮป n โ†’ Fin n + ๐Ÿ™
 Fin-equation-succ = refl _

 Fin-equation-succ' : (n : โ„•) โ†’ Fin (succ n) โ‰ก Fin n + ๐Ÿ™
 Fin-equation-succ' n = refl _

 Fin-equationโ‚ : Fin 1 โ‰ก ๐Ÿ˜ + ๐Ÿ™
 Fin-equationโ‚ = refl _

 Fin-equationโ‚‚ : Fin 2 โ‰ก (๐Ÿ˜ + ๐Ÿ™) + ๐Ÿ™
 Fin-equationโ‚‚ = refl _

 Fin-equationโ‚ƒ : Fin 3 โ‰ก ((๐Ÿ˜ + ๐Ÿ™) + ๐Ÿ™) + ๐Ÿ™
 Fin-equationโ‚ƒ = refl _

being-subsingleton-is-subsingleton : dfunext ๐“ค ๐“ค
                                   โ†’  {X : ๐“ค ฬ‡ }
                                   โ†’ is-subsingleton (is-subsingleton X)

being-subsingleton-is-subsingleton fe {X} i j = c
 where
  l : is-set X
  l = subsingletons-are-sets X i

  a : (x y : X) โ†’ i x y โ‰ก j x y
  a x y = l x y (i x y) (j x y)

  b : (x : X) โ†’ i x โ‰ก j x
  b x = fe (a x)

  c : i โ‰ก j
  c = fe b

being-center-is-subsingleton : dfunext ๐“ค ๐“ค
                             โ†’ {X : ๐“ค ฬ‡ } (c : X)
                             โ†’ is-subsingleton (is-center X c)

being-center-is-subsingleton fe {X} c ฯ† ฮณ = k
 where
  i : is-singleton X
  i = c , ฯ†

  j : (x : X) โ†’ is-subsingleton (c โ‰ก x)
  j x = singletons-are-sets X i c x

  k : ฯ† โ‰ก ฮณ
  k = fe (ฮป x โ†’ j x (ฯ† x) (ฮณ x))

ฮ -is-set : hfunext ๐“ค ๐“ฅ
         โ†’ {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
         โ†’ ((x : X) โ†’ is-set (A x))
         โ†’ is-set (ฮ  A)

ฮ -is-set hfe s f g = b
 where
  a : is-subsingleton (f โˆผ g)
  a p q = ฮณ
   where
    h : โˆ€ x โ†’  p x โ‰ก q x
    h x = s x (f x) (g x) (p x) (q x)
    ฮณ : p โ‰ก  q
    ฮณ = hfunext-gives-dfunext hfe h

  e : (f โ‰ก g) โ‰ƒ (f โˆผ g)
  e = (happly f g , hfe f g)

  b : is-subsingleton (f โ‰ก g)
  b = equiv-to-subsingleton e a

being-set-is-subsingleton : dfunext ๐“ค ๐“ค
                          โ†’ {X : ๐“ค ฬ‡ }
                          โ†’ is-subsingleton (is-set X)

being-set-is-subsingleton fe = ฮ -is-subsingleton fe
                                (ฮป x โ†’ ฮ -is-subsingleton fe
                                (ฮป y โ†’ being-subsingleton-is-subsingleton fe))

hlevel-relation-is-subsingleton : dfunext ๐“ค ๐“ค
                                โ†’ (n : โ„•) (X : ๐“ค ฬ‡ )
                                โ†’ is-subsingleton (X is-of-hlevel n)

hlevel-relation-is-subsingleton {๐“ค} fe zero X =
 being-singleton-is-subsingleton fe

hlevel-relation-is-subsingleton fe (succ n) X =
 ฮ -is-subsingleton fe
  (ฮป x โ†’ ฮ -is-subsingleton fe
  (ฮป x' โ†’ hlevel-relation-is-subsingleton fe n (x โ‰ก x')))

โ—-assoc : dfunext ๐“ฃ (๐“ค โŠ” ๐“ฃ)
        โ†’ dfunext (๐“ค โŠ” ๐“ฃ) (๐“ค โŠ” ๐“ฃ)
        โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ } {T : ๐“ฃ ฬ‡ }
          (ฮฑ : X โ‰ƒ Y) (ฮฒ : Y โ‰ƒ Z) (ฮณ : Z โ‰ƒ T)
        โ†’ ฮฑ โ— (ฮฒ โ— ฮณ) โ‰ก (ฮฑ โ— ฮฒ) โ— ฮณ

โ—-assoc fe fe' (f , a) (g , b) (h , c) = ap (h โˆ˜ g โˆ˜ f ,_) q
 where
  d e : is-equiv (h โˆ˜ g โˆ˜ f)
  d = โˆ˜-is-equiv (โˆ˜-is-equiv c b) a
  e = โˆ˜-is-equiv c (โˆ˜-is-equiv b a)

  q : d โ‰ก e
  q = being-equiv-is-subsingleton fe fe' (h โˆ˜ g โˆ˜ f) _ _

โ‰ƒ-sym-involutive : dfunext ๐“ฅ (๐“ค โŠ” ๐“ฅ)
                 โ†’ dfunext (๐“ค โŠ” ๐“ฅ) (๐“ค โŠ” ๐“ฅ) โ†’
                   {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (ฮฑ : X โ‰ƒ Y)
                 โ†’ โ‰ƒ-sym (โ‰ƒ-sym ฮฑ) โ‰ก ฮฑ

โ‰ƒ-sym-involutive fe fe' (f , a) = to-subtype-โ‰ก
                                   (being-equiv-is-subsingleton fe fe')
                                   (inversion-involutive f a)

โ‰ƒ-sym-is-equiv : dfunext ๐“ฅ (๐“ค โŠ” ๐“ฅ)
               โ†’ dfunext ๐“ค (๐“ค โŠ” ๐“ฅ)
               โ†’ dfunext (๐“ค โŠ” ๐“ฅ) (๐“ค โŠ” ๐“ฅ)
               โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
               โ†’ is-equiv (โ‰ƒ-sym {๐“ค} {๐“ฅ} {X} {Y})

โ‰ƒ-sym-is-equiv feโ‚€ feโ‚ feโ‚‚ = invertibles-are-equivs โ‰ƒ-sym
                              (โ‰ƒ-sym ,
                               โ‰ƒ-sym-involutive feโ‚€ feโ‚‚ ,
                               โ‰ƒ-sym-involutive feโ‚ feโ‚‚)

โ‰ƒ-sym-โ‰ƒ : dfunext ๐“ฅ (๐“ค โŠ” ๐“ฅ)
        โ†’ dfunext ๐“ค (๐“ค โŠ” ๐“ฅ)
        โ†’ dfunext (๐“ค โŠ” ๐“ฅ) (๐“ค โŠ” ๐“ฅ)
        โ†’ (X : ๐“ค ฬ‡ ) (Y : ๐“ฅ ฬ‡ )
        โ†’ (X โ‰ƒ Y) โ‰ƒ (Y โ‰ƒ X)

โ‰ƒ-sym-โ‰ƒ feโ‚€ feโ‚ feโ‚‚ X Y = โ‰ƒ-sym , โ‰ƒ-sym-is-equiv feโ‚€ feโ‚ feโ‚‚

ฮ -cong : dfunext ๐“ค ๐“ฅ
       โ†’ dfunext ๐“ค ๐“ฆ
       โ†’ {X : ๐“ค ฬ‡ } {Y : X โ†’ ๐“ฅ ฬ‡ } {Y' : X โ†’ ๐“ฆ ฬ‡ }
       โ†’ ((x : X) โ†’ Y x โ‰ƒ Y' x) โ†’ ฮ  Y โ‰ƒ ฮ  Y'

ฮ -cong fe fe' {X} {Y} {Y'} ฯ† = invertibility-gives-โ‰ƒ F (G , GF , FG)
 where
  f : (x : X) โ†’ Y x โ†’ Y' x
  f x = โŒœ ฯ† x โŒ

  e : (x : X) โ†’ is-equiv (f x)
  e x = โŒœโŒ-is-equiv (ฯ† x)

  g : (x : X) โ†’ Y' x โ†’ Y x
  g x = inverse (f x) (e x)

  fg : (x : X) (y' : Y' x) โ†’ f x (g x y') โ‰ก y'
  fg x = inverses-are-sections (f x) (e x)

  gf : (x : X) (y : Y x) โ†’ g x (f x y) โ‰ก y
  gf x = inverses-are-retractions (f x) (e x)

  F : ((x : X) โ†’ Y x) โ†’ ((x : X) โ†’ Y' x)
  F ฯ† x = f x (ฯ† x)

  G : ((x : X) โ†’ Y' x) โ†’ (x : X) โ†’ Y x
  G ฮณ x = g x (ฮณ x)

  FG : (ฮณ : ((x : X) โ†’ Y' x)) โ†’ F(G ฮณ) โ‰ก ฮณ
  FG ฮณ = fe' (ฮป x โ†’ fg x (ฮณ x))

  GF : (ฯ† : ((x : X) โ†’ Y x)) โ†’ G(F ฯ†) โ‰ก ฯ†
  GF ฯ† = fe (ฮป x โ†’ gf x (ฯ† x))

hfunext-โ‰ƒ : hfunext ๐“ค ๐“ฅ
          โ†’ {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } (f g : ฮ  A)
          โ†’ (f โ‰ก g) โ‰ƒ (f โˆผ g)

hfunext-โ‰ƒ hfe f g = (happly f g , hfe f g)

hfunextโ‚‚-โ‰ƒ : hfunext ๐“ค (๐“ฅ โŠ” ๐“ฆ) โ†’ hfunext ๐“ฅ ๐“ฆ
           โ†’ {X : ๐“ค ฬ‡ } {Y : X โ†’ ๐“ฅ ฬ‡ } {A : (x : X) โ†’ Y x โ†’ ๐“ฆ ฬ‡ }
             (f g : (x : X) (y : Y x) โ†’ A x y)
           โ†’ (f โ‰ก g) โ‰ƒ (โˆ€ x y โ†’ f x y โ‰ก g x y)

hfunextโ‚‚-โ‰ƒ fe fe' {X} f g =

 (f โ‰ก g)                  โ‰ƒโŸจ i  โŸฉ
 (โˆ€ x โ†’ f x โ‰ก g x)        โ‰ƒโŸจ ii โŸฉ
 (โˆ€ x y โ†’ f x y โ‰ก g x y)  โ– 

 where
  i  = hfunext-โ‰ƒ fe f g
  ii = ฮ -cong
        (hfunext-gives-dfunext fe)
        (hfunext-gives-dfunext fe)
        (ฮป x โ†’ hfunext-โ‰ƒ fe' (f x) (g x))

precomp-invertible : dfunext ๐“ฅ ๐“ฆ
                   โ†’ dfunext ๐“ค ๐“ฆ
                   โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ } (f : X โ†’ Y)
                   โ†’ invertible f
                   โ†’ invertible (ฮป (h : Y โ†’ Z) โ†’ h โˆ˜ f)

precomp-invertible fe fe' {X} {Y} {Z} f (g , ฮท , ฮต) = (g' , ฮท' , ฮต')
 where
  f' : (Y โ†’ Z) โ†’ (X โ†’ Z)
  f' h = h โˆ˜ f

  g' : (X โ†’ Z) โ†’ (Y โ†’ Z)
  g' k = k โˆ˜ g

  ฮท' : (h : Y โ†’ Z) โ†’ g' (f' h) โ‰ก h
  ฮท' h = fe (ฮป y โ†’ ap h (ฮต y))

  ฮต' : (k : X โ†’ Z) โ†’ f' (g' k) โ‰ก k
  ฮต' k = fe' (ฮป x โ†’ ap k (ฮท x))

precomp-is-equiv' : dfunext ๐“ฅ ๐“ฆ
                  โ†’ dfunext ๐“ค ๐“ฆ
                  โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ } (f : X โ†’ Y)
                  โ†’ is-equiv f
                  โ†’ is-equiv (ฮป (h : Y โ†’ Z) โ†’ h โˆ˜ f)

precomp-is-equiv' fe fe' {X} {Y} {Z} f i = invertibles-are-equivs (_โˆ˜ f)
                                            (precomp-invertible fe fe' f
                                              (equivs-are-invertible f i))

dprecomp : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (A : Y โ†’ ๐“ฆ ฬ‡ ) (f : X โ†’ Y)
         โ†’ ฮ  A โ†’ ฮ  (A โˆ˜ f)

dprecomp A f = _โˆ˜ f

dprecomp-is-equiv : dfunext ๐“ค ๐“ฆ
                  โ†’ dfunext ๐“ฅ ๐“ฆ
                  โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (A : Y โ†’ ๐“ฆ ฬ‡ ) (f : X โ†’ Y)
                  โ†’ is-equiv f
                  โ†’ is-equiv (dprecomp A f)

dprecomp-is-equiv fe fe' {X} {Y} A f i = invertibles-are-equivs ฯ† (ฯˆ , ฯˆฯ† , ฯ†ฯˆ)
 where
  g = inverse f i
  ฮท = inverses-are-retractions f i
  ฮต = inverses-are-sections f i

  ฯ„ : (x : X) โ†’ ap f (ฮท x) โ‰ก ฮต (f x)
  ฯ„ = half-adjoint-condition f i

  ฯ† : ฮ  A โ†’ ฮ  (A โˆ˜ f)
  ฯ† = dprecomp A f

  ฯˆ : ฮ  (A โˆ˜ f) โ†’ ฮ  A
  ฯˆ k y = transport A (ฮต y) (k (g y))

  ฯ†ฯˆโ‚€ : (k : ฮ  (A โˆ˜ f)) (x : X) โ†’ transport A (ฮต (f x)) (k (g (f x))) โ‰ก k x
  ฯ†ฯˆโ‚€ k x = transport A (ฮต (f x))   (k (g (f x))) โ‰กโŸจ a โŸฉ
            transport A (ap f (ฮท x))(k (g (f x))) โ‰กโŸจ b โŸฉ
            transport (A โˆ˜ f) (ฮท x) (k (g (f x))) โ‰กโŸจ c โŸฉ
            k x                                   โˆŽ
    where
     a = ap (ฮป - โ†’ transport A - (k (g (f x)))) ((ฯ„ x)โปยน)
     b = (transport-ap A f (ฮท x) (k (g (f x))))โปยน
     c = apd k (ฮท x)

  ฯ†ฯˆ : ฯ† โˆ˜ ฯˆ โˆผ id
  ฯ†ฯˆ k = fe (ฯ†ฯˆโ‚€ k)

  ฯˆฯ†โ‚€ : (h : ฮ  A) (y : Y) โ†’ transport A (ฮต y) (h (f (g y))) โ‰ก h y
  ฯˆฯ†โ‚€ h y = apd h (ฮต y)

  ฯˆฯ† : ฯˆ โˆ˜ ฯ† โˆผ id
  ฯˆฯ† h = fe' (ฯˆฯ†โ‚€ h)

ฮ -change-of-variable : dfunext ๐“ค ๐“ฆ
                     โ†’ dfunext ๐“ฅ ๐“ฆ
                     โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (A : Y โ†’ ๐“ฆ ฬ‡ ) (f : X โ†’ Y)
                     โ†’ is-equiv f
                     โ†’ (ฮ  y ๊ž‰ Y , A y) โ‰ƒ (ฮ  x ๊ž‰ X , A (f x))

ฮ -change-of-variable fe fe' A f i = dprecomp A f , dprecomp-is-equiv fe fe' A f i

at-most-one-section : dfunext ๐“ฅ ๐“ค
                    โ†’ hfunext ๐“ฅ ๐“ฅ
                    โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                    โ†’ has-retraction f
                    โ†’ is-subsingleton (has-section f)

at-most-one-section {๐“ฅ} {๐“ค} fe hfe {X} {Y} f (g , gf) (h , fh) = d
 where
  fe' : dfunext ๐“ฅ ๐“ฅ
  fe' = hfunext-gives-dfunext hfe

  a : invertible f
  a = joyal-equivs-are-invertible f ((h , fh) , (g , gf))

  b : is-singleton (fiber (ฮป h โ†’  f โˆ˜ h) id)
  b = invertibles-are-equivs (ฮป h โ†’ f โˆ˜ h) (postcomp-invertible fe fe' f a) id

  r : fiber (ฮป h โ†’  f โˆ˜ h) id โ†’ has-section f
  r (h , p) = (h , happly (f โˆ˜ h) id p)

  s : has-section f โ†’ fiber (ฮป h โ†’ f โˆ˜ h) id
  s (h , ฮท) = (h , fe' ฮท)

  rs : (ฯƒ : has-section f) โ†’ r (s ฯƒ) โ‰ก ฯƒ
  rs (h , ฮท) = to-ฮฃ-โ‰ก' q
   where
    q : happly (f โˆ˜ h) id (inverse (happly (f โˆ˜ h) id) (hfe (f โˆ˜ h) id) ฮท) โ‰ก ฮท
    q = inverses-are-sections (happly (f โˆ˜ h) id) (hfe (f โˆ˜ h) id) ฮท

  c : is-singleton (has-section f)
  c = retract-of-singleton (r , s , rs) b

  d : (ฯƒ : has-section f) โ†’ h , fh โ‰ก ฯƒ
  d = singletons-are-subsingletons (has-section f) c (h , fh)

at-most-one-retraction : hfunext ๐“ค ๐“ค
                       โ†’ dfunext ๐“ฅ ๐“ค
                       โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                       โ†’ has-section f
                       โ†’ is-subsingleton (has-retraction f)

at-most-one-retraction {๐“ค} {๐“ฅ} hfe fe' {X} {Y} f (g , fg) (h , hf) = d
 where
  fe : dfunext ๐“ค ๐“ค
  fe = hfunext-gives-dfunext hfe

  a : invertible f
  a = joyal-equivs-are-invertible f ((g , fg) , (h , hf))

  b : is-singleton (fiber (ฮป h โ†’  h โˆ˜ f) id)
  b = invertibles-are-equivs (ฮป h โ†’ h โˆ˜ f) (precomp-invertible fe' fe f a) id

  r : fiber (ฮป h โ†’  h โˆ˜ f) id โ†’ has-retraction f
  r (h , p) = (h , happly (h โˆ˜ f) id p)

  s : has-retraction f โ†’ fiber (ฮป h โ†’  h โˆ˜ f) id
  s (h , ฮท) = (h , fe ฮท)

  rs : (ฯƒ : has-retraction f) โ†’ r (s ฯƒ) โ‰ก ฯƒ
  rs (h , ฮท) = to-ฮฃ-โ‰ก' q
   where
    q : happly (h โˆ˜ f) id (inverse (happly (h โˆ˜ f) id) (hfe (h โˆ˜ f) id) ฮท) โ‰ก ฮท
    q = inverses-are-sections (happly (h โˆ˜ f) id) (hfe (h โˆ˜ f) id) ฮท

  c : is-singleton (has-retraction f)
  c = retract-of-singleton (r , s , rs) b

  d : (ฯ : has-retraction f) โ†’ h , hf โ‰ก ฯ
  d = singletons-are-subsingletons (has-retraction f) c (h , hf)

being-joyal-equiv-is-subsingleton : hfunext ๐“ค ๐“ค
                                  โ†’ hfunext ๐“ฅ ๐“ฅ
                                  โ†’ dfunext ๐“ฅ ๐“ค
                                  โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                                  โ†’ (f : X โ†’ Y)
                                  โ†’ is-subsingleton (is-joyal-equiv f)

being-joyal-equiv-is-subsingleton feโ‚€ feโ‚ feโ‚‚ f = ร—-is-subsingleton'
                                                   (at-most-one-section    feโ‚‚ feโ‚ f ,
                                                    at-most-one-retraction feโ‚€ feโ‚‚ f)

being-hae-is-subsingleton : dfunext ๐“ฅ ๐“ค
                          โ†’ hfunext ๐“ฅ ๐“ฅ
                          โ†’ dfunext ๐“ค (๐“ฅ โŠ” ๐“ค)
                          โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                          โ†’ is-subsingleton (is-hae f)

being-hae-is-subsingleton feโ‚€ feโ‚ feโ‚‚ {X} {Y} f = subsingleton-criterion' ฮณ
 where
  a = ฮป g ฮต x
    โ†’ ((g (f x) , ฮต (f x)) โ‰ก (x , refl (f x)))                                   โ‰ƒโŸจ i  g ฮต x โŸฉ
      (ฮฃ p ๊ž‰ g (f x) โ‰ก x , transport (ฮป - โ†’ f - โ‰ก f x) p (ฮต (f x)) โ‰ก refl (f x)) โ‰ƒโŸจ ii g ฮต x โŸฉ
      (ฮฃ p ๊ž‰ g (f x) โ‰ก x , ap f p โ‰ก ฮต (f x))                                     โ– 
   where
    i  = ฮป g ฮต x โ†’ ฮฃ-โ‰ก-โ‰ƒ (g (f x) , ฮต (f x)) (x , refl (f x))
    ii = ฮป g ฮต x โ†’ ฮฃ-cong (ฮป p โ†’ transport-ap-โ‰ƒ f p (ฮต (f x)))

  b = (ฮฃ (g , ฮต) ๊ž‰ has-section f , โˆ€ x โ†’ (g (f x) , ฮต (f x)) โ‰ก (x , refl (f x)))         โ‰ƒโŸจ i   โŸฉ
      (ฮฃ (g , ฮต) ๊ž‰ has-section f , โˆ€ x โ†’ ฮฃ  p ๊ž‰ g (f x) โ‰ก x , ap f p โ‰ก ฮต (f x))          โ‰ƒโŸจ ii  โŸฉ
      (ฮฃ g ๊ž‰ (Y โ†’ X) , ฮฃ ฮต ๊ž‰ f โˆ˜ g โˆผ id , โˆ€ x โ†’ ฮฃ  p ๊ž‰ g (f x) โ‰ก x , ap f p โ‰ก ฮต (f x))   โ‰ƒโŸจ iii โŸฉ
      (ฮฃ g ๊ž‰ (Y โ†’ X) , ฮฃ ฮต ๊ž‰ f โˆ˜ g โˆผ id , ฮฃ ฮท ๊ž‰ g โˆ˜ f โˆผ id , โˆ€ x โ†’ ap f (ฮท x) โ‰ก ฮต (f x)) โ‰ƒโŸจ iv  โŸฉ
      is-hae f                                                                           โ– 
   where
    i   = ฮฃ-cong (ฮป (g , ฮต) โ†’ ฮ -cong feโ‚‚ feโ‚‚ (a g ฮต))
    ii  = ฮฃ-assoc
    iii = ฮฃ-cong (ฮป g โ†’ ฮฃ-cong (ฮป ฮต โ†’ ฮ ฮฃ-distr-โ‰ƒ))
    iv  = ฮฃ-cong (ฮป g โ†’ ฮฃ-flip)

  ฮณ : is-hae f โ†’ is-subsingleton (is-hae f)
  ฮณ (gโ‚€ , ฮตโ‚€ , ฮทโ‚€ , ฯ„โ‚€) = i
   where
    c : (x : X) โ†’ is-set (fiber f (f x))
    c x = singletons-are-sets (fiber f (f x)) (haes-are-equivs f (gโ‚€ , ฮตโ‚€ , ฮทโ‚€ , ฯ„โ‚€) (f x))

    d : ((g , ฮต) : has-section f) โ†’ is-subsingleton (โˆ€ x โ†’ (g (f x) , ฮต (f x)) โ‰ก (x , refl (f x)))
    d (g , ฮต) = ฮ -is-subsingleton feโ‚‚ (ฮป x โ†’ c x (g (f x) , ฮต (f x)) (x , refl (f x)))

    e : is-subsingleton (ฮฃ (g , ฮต) ๊ž‰ has-section f , โˆ€ x โ†’ (g (f x) , ฮต (f x)) โ‰ก (x , refl (f x)))
    e = ฮฃ-is-subsingleton (at-most-one-section feโ‚€ feโ‚ f (gโ‚€ , ฮตโ‚€)) d

    i : is-subsingleton (is-hae f)
    i = equiv-to-subsingleton (โ‰ƒ-sym b) e

emptiness-is-subsingleton : dfunext ๐“ค ๐“คโ‚€ โ†’ (X : ๐“ค ฬ‡ )
                          โ†’ is-subsingleton (is-empty X)

emptiness-is-subsingleton fe X f g = fe (ฮป x โ†’ !๐Ÿ˜ (f x โ‰ก g x) (f x))

+-is-subsingleton : {P : ๐“ค ฬ‡ } {Q : ๐“ฅ ฬ‡ }
                  โ†’ is-subsingleton P
                  โ†’ is-subsingleton Q
                  โ†’ (P โ†’ Q โ†’ ๐Ÿ˜) โ†’ is-subsingleton (P + Q)

+-is-subsingleton {๐“ค} {๐“ฅ} {P} {Q} i j f = ฮณ
 where
  ฮณ : (x y : P + Q) โ†’ x โ‰ก y
  ฮณ (inl p) (inl p') = ap inl (i p p')
  ฮณ (inl p) (inr q)  = !๐Ÿ˜ (inl p โ‰ก inr q) (f p q)
  ฮณ (inr q) (inl p)  = !๐Ÿ˜ (inr q โ‰ก inl p) (f p q)
  ฮณ (inr q) (inr q') = ap inr (j q q')

+-is-subsingleton' : dfunext ๐“ค ๐“คโ‚€
                   โ†’ {P : ๐“ค ฬ‡ } โ†’ is-subsingleton P โ†’ is-subsingleton (P + ยฌ P)

+-is-subsingleton' fe {P} i = +-is-subsingleton i
                               (emptiness-is-subsingleton fe P)
                               (ฮป p n โ†’ n p)

EM-is-subsingleton : dfunext (๐“ค โบ) ๐“ค
                   โ†’ dfunext ๐“ค ๐“ค
                   โ†’ dfunext ๐“ค ๐“คโ‚€
                   โ†’ is-subsingleton (EM ๐“ค)

EM-is-subsingleton feโบ fe feโ‚€ = ฮ -is-subsingleton feโบ
                                 (ฮป P โ†’ ฮ -is-subsingleton fe
                                         (ฮป i โ†’ +-is-subsingleton' feโ‚€ i))

propext : โˆ€ ๐“ค  โ†’ ๐“ค โบ ฬ‡
propext ๐“ค = {P Q : ๐“ค ฬ‡ } โ†’ is-prop P โ†’ is-prop Q โ†’ (P โ†’ Q) โ†’ (Q โ†’ P) โ†’ P โ‰ก Q

global-propext : ๐“คฯ‰
global-propext = โˆ€ {๐“ค} โ†’ propext ๐“ค

univalence-gives-propext : is-univalent ๐“ค โ†’ propext ๐“ค
univalence-gives-propext ua {P} {Q} i j f g = Eqโ†’Id ua P Q ฮณ
 where
  ฮณ : P โ‰ƒ Q
  ฮณ = logically-equivalent-subsingletons-are-equivalent P Q i j (f , g)

ฮฉ : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
ฮฉ ๐“ค = ฮฃ P ๊ž‰ ๐“ค ฬ‡ , is-subsingleton P

_holds : ฮฉ ๐“ค โ†’ ๐“ค ฬ‡
_holds (P , i) = P

holds-is-subsingleton : (p : ฮฉ ๐“ค) โ†’ is-subsingleton (p holds)
holds-is-subsingleton (P , i) = i

ฮฉ-ext : dfunext ๐“ค ๐“ค โ†’ propext ๐“ค โ†’ {p q : ฮฉ ๐“ค}
      โ†’ (p holds โ†’ q holds) โ†’ (q holds โ†’ p holds) โ†’ p โ‰ก q

ฮฉ-ext {๐“ค} fe pe {p} {q} f g = to-subtype-โ‰ก
                                 (ฮป _ โ†’ being-subsingleton-is-subsingleton fe)
                                 (pe (holds-is-subsingleton p) (holds-is-subsingleton q) f g)

ฮฉ-is-a-set : dfunext ๐“ค ๐“ค โ†’ propext ๐“ค โ†’ is-set (ฮฉ ๐“ค)
ฮฉ-is-a-set {๐“ค} fe pe = types-with-wconstant-โ‰ก-endomaps-are-sets (ฮฉ ๐“ค) c
 where
  A : (p q : ฮฉ ๐“ค) โ†’ ๐“ค ฬ‡
  A p q = (p holds โ†’ q holds) ร— (q holds โ†’ p holds)

  i : (p q : ฮฉ ๐“ค) โ†’ is-subsingleton (A p q)
  i p q = ฮฃ-is-subsingleton
           (ฮ -is-subsingleton fe
             (ฮป _ โ†’ holds-is-subsingleton q))
             (ฮป _ โ†’ ฮ -is-subsingleton fe (ฮป _ โ†’ holds-is-subsingleton p))

  g : (p q : ฮฉ ๐“ค) โ†’ p โ‰ก q โ†’ A p q
  g p q e = (u , v)
   where
    a : p holds โ‰ก q holds
    a = ap _holds e

    u : p holds โ†’ q holds
    u = Idโ†’fun a

    v : q holds โ†’ p holds
    v = Idโ†’fun (a โปยน)

  h : (p q : ฮฉ ๐“ค) โ†’ A p q โ†’ p โ‰ก q
  h p q (u , v) = ฮฉ-ext fe pe u v

  f : (p q : ฮฉ ๐“ค) โ†’ p โ‰ก q โ†’ p โ‰ก q
  f p q e = h p q (g p q e)

  k : (p q : ฮฉ ๐“ค) (d e : p โ‰ก q) โ†’ f p q d โ‰ก f p q e
  k p q d e = ap (h p q) (i p q (g p q d) (g p q e))

  c : (p q : ฮฉ ๐“ค) โ†’ ฮฃ f ๊ž‰ (p โ‰ก q โ†’ p โ‰ก q), wconstant f
  c p q = (f p q , k p q)

powersets-are-sets : hfunext ๐“ค (๐“ฅ โบ)
                   โ†’ dfunext ๐“ฅ ๐“ฅ
                   โ†’ propext ๐“ฅ
                   โ†’ {X : ๐“ค ฬ‡ } โ†’ is-set (X โ†’ ฮฉ ๐“ฅ)

powersets-are-sets fe fe' pe = ฮ -is-set fe (ฮป x โ†’ ฮฉ-is-a-set fe' pe)

๐“Ÿ : ๐“ค ฬ‡ โ†’ ๐“ค โบ ฬ‡
๐“Ÿ {๐“ค} X = X โ†’ ฮฉ ๐“ค

powersets-are-sets' : Univalence
                    โ†’ {X : ๐“ค ฬ‡ } โ†’ is-set (๐“Ÿ X)

powersets-are-sets' {๐“ค} ua = powersets-are-sets
                               (univalence-gives-hfunext' (ua ๐“ค) (ua (๐“ค โบ)))
                               (univalence-gives-dfunext (ua ๐“ค))
                               (univalence-gives-propext (ua ๐“ค))

_โˆˆ_ : {X : ๐“ค ฬ‡ } โ†’ X โ†’ ๐“Ÿ X โ†’ ๐“ค ฬ‡
x โˆˆ A = A x holds

_โˆ‰_ : {X : ๐“ค ฬ‡ } โ†’ X โ†’ ๐“Ÿ X โ†’ ๐“ค ฬ‡
x โˆ‰ A = ยฌ(x โˆˆ A)

_โŠ†_ : {X : ๐“ค ฬ‡ } โ†’ ๐“Ÿ X โ†’ ๐“Ÿ X โ†’ ๐“ค ฬ‡
A โŠ† B = โˆ€ x โ†’ x โˆˆ A โ†’ x โˆˆ B

โˆˆ-is-subsingleton : {X : ๐“ค ฬ‡ } (A : ๐“Ÿ X) (x : X) โ†’ is-subsingleton (x โˆˆ A)
โˆˆ-is-subsingleton A x = holds-is-subsingleton (A x)

โŠ†-is-subsingleton : dfunext ๐“ค ๐“ค
                  โ†’ {X : ๐“ค ฬ‡ } (A B : ๐“Ÿ X) โ†’ is-subsingleton (A โŠ† B)

โŠ†-is-subsingleton fe A B = ฮ -is-subsingleton fe
                            (ฮป x โ†’ ฮ -is-subsingleton fe
                            (ฮป _ โ†’ โˆˆ-is-subsingleton B x))

โŠ†-refl : {X : ๐“ค ฬ‡ } (A : ๐“Ÿ X) โ†’ A โŠ† A
โŠ†-refl A x = ๐‘–๐‘‘ (x โˆˆ A)

โŠ†-refl-consequence : {X : ๐“ค ฬ‡ } (A B : ๐“Ÿ X)
                   โ†’ A โ‰ก B โ†’ (A โŠ† B) ร— (B โŠ† A)

โŠ†-refl-consequence {X} A A (refl A) = โŠ†-refl A , โŠ†-refl A

subset-extensionality : propext ๐“ค
                      โ†’ dfunext ๐“ค ๐“ค
                      โ†’ dfunext ๐“ค (๐“ค โบ)
                      โ†’ {X : ๐“ค ฬ‡ } {A B : ๐“Ÿ X}
                      โ†’ A โŠ† B โ†’ B โŠ† A โ†’ A โ‰ก B

subset-extensionality pe fe fe' {X} {A} {B} h k = fe' ฯ†
 where
  ฯ† : (x : X) โ†’ A x โ‰ก B x
  ฯ† x = to-subtype-โ‰ก
           (ฮป _ โ†’ being-subsingleton-is-subsingleton fe)
           (pe (holds-is-subsingleton (A x)) (holds-is-subsingleton (B x))
               (h x) (k x))

subset-extensionality' : Univalence
                       โ†’ {X : ๐“ค ฬ‡ } {A B : ๐“Ÿ X}
                       โ†’ A โŠ† B โ†’ B โŠ† A โ†’ A โ‰ก B

subset-extensionality' {๐“ค} ua = subset-extensionality
                                 (univalence-gives-propext (ua ๐“ค))
                                 (univalence-gives-dfunext (ua ๐“ค))
                                 (univalence-gives-dfunext' (ua ๐“ค) (ua (๐“ค โบ)))

prop-univalence prop-univalence' : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
prop-univalence  ๐“ค = (A : ๐“ค ฬ‡ ) โ†’ is-prop A โ†’ (X : ๐“ค ฬ‡ ) โ†’ is-equiv (Idโ†’Eq A X)
prop-univalence' ๐“ค = (A : ๐“ค ฬ‡ ) โ†’ is-prop A โ†’ (X : ๐“ค ฬ‡ ) โ†’ is-prop X โ†’ is-equiv (Idโ†’Eq A X)

prop-univalence-agreement : prop-univalence' ๐“ค โ‡” prop-univalence ๐“ค
prop-univalence-agreement = (ฮป pu' A i X e โ†’ pu' A i X (equiv-to-subsingleton (โ‰ƒ-sym e) i) e) ,
                            (ฮป pu  A i X _ โ†’ pu  A i X)

props-form-exponential-ideal
 props-are-closed-under-ฮ 
 prop-vvfunext
 prop-hfunext : โˆ€ ๐“ค โ†’ ๐“ค โบ ฬ‡

props-form-exponential-ideal ๐“ค = (X A : ๐“ค ฬ‡ ) โ†’ is-prop A โ†’ is-prop (X โ†’ A)

props-are-closed-under-ฮ  ๐“ค = {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ค ฬ‡ }
                           โ†’ is-prop X
                           โ†’ ((x : X) โ†’ is-prop (A x))
                           โ†’ is-prop (ฮ  A)

prop-vvfunext ๐“ค = {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ค ฬ‡ }
                โ†’ is-prop X
                โ†’ ((x : X) โ†’ is-singleton (A x))
                โ†’ is-singleton (ฮ  A)

prop-hfunext ๐“ค = {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ค ฬ‡ }
               โ†’ is-prop X
               โ†’ (f g : ฮ  A) โ†’ is-equiv (happly f g)

first-propositional-function-extensionality-agreement :

    (props-are-closed-under-ฮ  ๐“ค โ†’ prop-vvfunext ๐“ค)
  ร— (prop-vvfunext ๐“ค            โ†’ prop-hfunext ๐“ค)
  ร— (prop-hfunext ๐“ค             โ†’ props-are-closed-under-ฮ  ๐“ค)

second-propositional-function-extensionality-agreement :

    propext ๐“ค โ†’ (props-form-exponential-ideal ๐“ค โ‡” props-are-closed-under-ฮ  ๐“ค)

characterization-of-propositional-univalence : prop-univalence ๐“ค
                                             โ‡” (propext ๐“ค ร— props-are-closed-under-ฮ  ๐“ค)

prop-univalence-gives-propext : prop-univalence ๐“ค โ†’ propext ๐“ค
prop-univalence-gives-propext pu {P} {Q} i j f g = ฮด
 where
  ฮณ : P โ‰ƒ Q
  ฮณ = logically-equivalent-subsingletons-are-equivalent P Q i j (f , g)

  ฮด : P โ‰ก Q
  ฮด = inverse (Idโ†’Eq P Q) (pu P i Q) ฮณ

prop-โ‰ƒ-induction : (๐“ค ๐“ฅ : Universe) โ†’ (๐“ค โŠ” ๐“ฅ)โบ ฬ‡
prop-โ‰ƒ-induction ๐“ค ๐“ฅ = (P : ๐“ค ฬ‡ )
                     โ†’ is-prop P
                     โ†’ (A : (X : ๐“ค ฬ‡ ) โ†’ P โ‰ƒ X โ†’ ๐“ฅ ฬ‡ )
                     โ†’ A P (id-โ‰ƒ P) โ†’ (X : ๐“ค ฬ‡ ) (e : P โ‰ƒ X) โ†’ A X e

prop-J-equiv : prop-univalence ๐“ค
             โ†’ (๐“ฅ : Universe) โ†’ prop-โ‰ƒ-induction ๐“ค ๐“ฅ
prop-J-equiv {๐“ค} pu ๐“ฅ P i A a X e = ฮณ
 where
  A' : (X : ๐“ค ฬ‡ ) โ†’ P โ‰ก X โ†’ ๐“ฅ ฬ‡
  A' X q = A X (Idโ†’Eq P X q)

  f : (X : ๐“ค ฬ‡ ) (q : P โ‰ก X) โ†’ A' X q
  f = โ„ P A' a

  r : P โ‰ก X
  r = inverse (Idโ†’Eq P X) (pu P i X) e

  g : A X (Idโ†’Eq P X r)
  g = f X r

  ฮณ : A X (id e)
  ฮณ = transport (A X) (inverses-are-sections (Idโ†’Eq P X) (pu P i X) e) g

prop-precomp-is-equiv : prop-univalence ๐“ค
                      โ†’ (X Y Z : ๐“ค ฬ‡ )
                      โ†’ is-prop X
                      โ†’ (f : X โ†’ Y)
                      โ†’ is-equiv f
                      โ†’ is-equiv (ฮป (g : Y โ†’ Z) โ†’ g โˆ˜ f)
prop-precomp-is-equiv {๐“ค} pu X Y Z i f f-is-equiv =
   prop-J-equiv pu ๐“ค X i (ฮป _ e โ†’ is-equiv (ฮป g โ†’ g โˆ˜ โŒœ e โŒ))
     (id-is-equiv (X โ†’ Z)) Y (f , f-is-equiv)

prop-univalence-gives-props-form-exponential-ideal : prop-univalence ๐“ค
                                                   โ†’ props-form-exponential-ideal ๐“ค

prop-univalence-gives-props-form-exponential-ideal {๐“ค} pu X A A-is-prop = ฮณ
 where
  ฮ” : ๐“ค ฬ‡
  ฮ” = ฮฃ aโ‚€ ๊ž‰ A , ฮฃ aโ‚ ๊ž‰ A , aโ‚€ โ‰ก aโ‚

  ฮด : A โ†’ ฮ”
  ฮด a = (a , a , refl a)

  ฯ€โ‚€ ฯ€โ‚ : ฮ” โ†’ A
  ฯ€โ‚€ (aโ‚€ , aโ‚ , a) = aโ‚€
  ฯ€โ‚ (aโ‚€ , aโ‚ , a) = aโ‚

  ฮด-is-equiv : is-equiv ฮด
  ฮด-is-equiv = invertibles-are-equivs ฮด (ฯ€โ‚€ , ฮท , ฮต)
   where
    ฮท : (a : A) โ†’ ฯ€โ‚€ (ฮด a) โ‰ก a
    ฮท a = refl a

    ฮต : (d : ฮ”) โ†’ ฮด (ฯ€โ‚€ d) โ‰ก d
    ฮต (a , a , refl a) = refl (a , a , refl a)

  ฯ† : (ฮ” โ†’ A) โ†’ (A โ†’ A)
  ฯ† ฯ€ = ฯ€ โˆ˜ ฮด

  ฯ†-is-equiv : is-equiv ฯ†
  ฯ†-is-equiv = prop-precomp-is-equiv pu A ฮ” A A-is-prop ฮด ฮด-is-equiv

  p : ฯ† ฯ€โ‚€ โ‰ก ฯ† ฯ€โ‚
  p = refl (๐‘–๐‘‘ A)

  q : ฯ€โ‚€ โ‰ก ฯ€โ‚
  q = equivs-are-lc ฯ† ฯ†-is-equiv p

  h : (fโ‚€ fโ‚ : X โ†’ A) โ†’ fโ‚€ โˆผ fโ‚
  h fโ‚€ fโ‚ x = A-is-prop (fโ‚€ x) (fโ‚ x)

  ฮณ : (fโ‚€ fโ‚ : X โ†’ A) โ†’ fโ‚€ โ‰ก fโ‚
  ฮณ fโ‚€ fโ‚ = ap (ฮป ฯ€ x โ†’ ฯ€ (fโ‚€ x , fโ‚ x , h fโ‚€ fโ‚ x)) q

props-are-closed-under-ฮ -gives-prop-vvfunext : props-are-closed-under-ฮ  ๐“ค โ†’ prop-vvfunext ๐“ค
props-are-closed-under-ฮ -gives-prop-vvfunext c {X} {A} X-is-prop A-is-prop-valued = ฮณ
 where
  f : ฮ  A
  f x = center (A x) (A-is-prop-valued x)

  d : (g : ฮ  A) โ†’ f โ‰ก g
  d = c X-is-prop (ฮป (x : X) โ†’ singletons-are-subsingletons (A x) (A-is-prop-valued x)) f

  ฮณ : is-singleton (ฮ  A)
  ฮณ = f , d

prop-vvfunext-gives-prop-hfunext : prop-vvfunext ๐“ค โ†’ prop-hfunext ๐“ค
prop-vvfunext-gives-prop-hfunext vfe {X} {Y} X-is-prop f = ฮณ
 where
  a : (x : X) โ†’ is-singleton (ฮฃ y ๊ž‰ Y x , f x โ‰ก y)
  a x = singleton-types'-are-singletons (Y x) (f x)

  c : is-singleton (ฮ  x ๊ž‰ X , ฮฃ y ๊ž‰ Y x , f x โ‰ก y)
  c = vfe X-is-prop a

  ฯ : (ฮฃ g ๊ž‰ ฮ  Y , f โˆผ g) โ— (ฮ  x ๊ž‰ X , ฮฃ y ๊ž‰ Y x , f x โ‰ก y)
  ฯ = โ‰ƒ-gives-โ–ท ฮ ฮฃ-distr-โ‰ƒ

  d : is-singleton (ฮฃ g ๊ž‰ ฮ  Y , f โˆผ g)
  d = retract-of-singleton ฯ c

  e : (ฮฃ g ๊ž‰ ฮ  Y , f โ‰ก g) โ†’ (ฮฃ g ๊ž‰ ฮ  Y , f โˆผ g)
  e = Natฮฃ (happly f)

  i : is-equiv e
  i = maps-of-singletons-are-equivs e (singleton-types'-are-singletons (ฮ  Y) f) d

  ฮณ : (g : ฮ  Y) โ†’ is-equiv (happly f g)
  ฮณ = Natฮฃ-equiv-gives-fiberwise-equiv (happly f) i

prop-hfunext-gives-props-are-closed-under-ฮ  : prop-hfunext ๐“ค โ†’ props-are-closed-under-ฮ  ๐“ค
prop-hfunext-gives-props-are-closed-under-ฮ  hfe {X} {A} X-is-prop A-is-prop-valued f g = ฮณ
 where
  ฮณ : f โ‰ก g
  ฮณ = inverse (happly f g) (hfe X-is-prop f g) (ฮป x โ†’ A-is-prop-valued x (f x) (g x))

first-propositional-function-extensionality-agreement =
  props-are-closed-under-ฮ -gives-prop-vvfunext ,
  prop-vvfunext-gives-prop-hfunext ,
  prop-hfunext-gives-props-are-closed-under-ฮ 

prop-vvfunext-gives-props-are-closed-under-ฮ  : prop-vvfunext ๐“ค โ†’ props-are-closed-under-ฮ  ๐“ค
prop-vvfunext-gives-props-are-closed-under-ฮ  vfe =
    prop-hfunext-gives-props-are-closed-under-ฮ  (prop-vvfunext-gives-prop-hfunext vfe)

being-prop-is-prop : prop-vvfunext ๐“ค
                   โ†’ {X : ๐“ค ฬ‡ } โ†’ is-prop (is-prop X)

being-prop-is-prop vfe {X} i j = ฮณ
 where
  k : is-set X
  k = subsingletons-are-sets X i

  a : (x y : X) โ†’ i x y โ‰ก j x y
  a x y = k x y (i x y) (j x y)

  b : (x : X) โ†’ i x โ‰ก j x
  b x = prop-vvfunext-gives-props-are-closed-under-ฮ  vfe i
            (subsingletons-are-sets X i x) (i x) (j x)

  c : (x : X) โ†’ is-prop ((y : X) โ†’ x โ‰ก y)
  c x = singletons-are-subsingletons ((y : X) โ†’ x โ‰ก y)
            (vfe i (ฮป y โ†’ pointed-subsingletons-are-singletons (x โ‰ก y) (i x y) (k x y)))

  ฮณ : i โ‰ก j
  ฮณ = prop-vvfunext-gives-props-are-closed-under-ฮ  vfe i c i j

being-singleton-is-prop : props-are-closed-under-ฮ  ๐“ค
                        โ†’  {X : ๐“ค ฬ‡ } โ†’ is-prop (is-singleton X)

being-singleton-is-prop c {X} (x , ฯ†) (y , ฮณ) = p
 where
  i : is-subsingleton X
  i = singletons-are-subsingletons X (y , ฮณ)

  s : is-set X
  s = subsingletons-are-sets X i

  a : (z : X) โ†’ is-subsingleton ((t : X) โ†’ z โ‰ก t)
  a z = c i (ฮป x โ†’ s z x)

  b : x โ‰ก y
  b = ฯ† y

  p : (x , ฯ†) โ‰ก (y , ฮณ)
  p = to-subtype-โ‰ก a b

Id-of-props-is-prop : propext ๐“ค
                    โ†’ prop-vvfunext ๐“ค
                    โ†’ (P : ๐“ค ฬ‡ )
                    โ†’ is-prop P
                    โ†’ (X : ๐“ค ฬ‡ ) โ†’ is-prop (P โ‰ก X)

Id-of-props-is-prop {๐“ค} pe vfe P i = Hedberg P (ฮป X โ†’ h X , k X)
 where
  module _ (X : ๐“ค ฬ‡ ) where
   f : P โ‰ก X โ†’ is-prop X ร— (P โ‡” X)
   f p = transport is-prop p i , Idโ†’fun p , (Idโ†’fun (p โปยน))

   g : is-prop X ร— (P โ‡” X) โ†’ P โ‰ก X
   g (l , ฯ† , ฯˆ) = pe i l ฯ† ฯˆ

   h : P โ‰ก X โ†’ P โ‰ก X
   h = g โˆ˜ f

   j : is-prop (is-prop X ร— (P โ‡” X))
   j = ร—-is-subsingleton'
        ((ฮป (_ : P โ‡” X) โ†’ being-prop-is-prop vfe) ,
         (ฮป (l : is-prop X)
               โ†’ ร—-is-subsingleton
                  (prop-vvfunext-gives-props-are-closed-under-ฮ  vfe i (ฮป _ โ†’ l))
                  (prop-vvfunext-gives-props-are-closed-under-ฮ  vfe l (ฮป _ โ†’ i))))

   k : wconstant h
   k p q = ap g (j (f p) (f q))

being-equiv-of-props-is-prop : props-are-closed-under-ฮ  ๐“ค
                             โ†’ {X Y : ๐“ค ฬ‡ }
                             โ†’ is-prop X
                             โ†’ is-prop Y
                             โ†’ (f : X โ†’ Y) โ†’ is-prop (is-equiv f)

being-equiv-of-props-is-prop c i j f = c j (ฮป y โ†’ being-singleton-is-prop c)

propext-and-props-are-closed-under-ฮ -give-prop-univalence : propext ๐“ค
                                                          โ†’ props-are-closed-under-ฮ  ๐“ค
                                                          โ†’ prop-univalence ๐“ค

propext-and-props-are-closed-under-ฮ -give-prop-univalence pe c A i X = ฮณ
 where
  l : A โ‰ƒ X โ†’ is-subsingleton X
  l e = equiv-to-subsingleton (โ‰ƒ-sym e) i

  eqtoid : A โ‰ƒ X โ†’ A โ‰ก X
  eqtoid e = pe i
                (equiv-to-subsingleton (โ‰ƒ-sym e) i)
                โŒœ e โŒ
                โŒœ โ‰ƒ-sym e โŒ

  m : is-subsingleton (A โ‰ƒ X)
  m (fโ‚€ , kโ‚€) (fโ‚ , kโ‚) = ฮด
    where
     j : (f : A โ†’ X) โ†’ is-prop (is-equiv f)
     j = being-equiv-of-props-is-prop c i
              (equiv-to-subsingleton (โ‰ƒ-sym (fโ‚€ , kโ‚€)) i)

     p : fโ‚€ โ‰ก fโ‚
     p = c i (ฮป (a : A) โ†’ l (fโ‚ , kโ‚)) fโ‚€ fโ‚

     ฮด : (fโ‚€ , kโ‚€) โ‰ก (fโ‚ , kโ‚)
     ฮด = to-subtype-โ‰ก j p

  ฮต : (e : A โ‰ƒ X) โ†’ Idโ†’Eq A X (eqtoid e) โ‰ก e
  ฮต e = m (Idโ†’Eq A X (eqtoid e)) e

  ฮท : (q : A โ‰ก X) โ†’ eqtoid (Idโ†’Eq A X q) โ‰ก q
  ฮท q = Id-of-props-is-prop pe
          (props-are-closed-under-ฮ -gives-prop-vvfunext c)
          A i X
          (eqtoid (Idโ†’Eq A X q)) q

  ฮณ : is-equiv (Idโ†’Eq A X)
  ฮณ = invertibles-are-equivs (Idโ†’Eq A X) (eqtoid , ฮท , ฮต)

prop-postcomp-invertible : {X Y A : ๐“ค ฬ‡ }
                         โ†’ props-form-exponential-ideal ๐“ค
                         โ†’ is-prop X
                         โ†’ is-prop Y
                         โ†’ (f : X โ†’ Y)
                         โ†’ invertible f
                         โ†’ invertible (ฮป (h : A โ†’ X) โ†’ f โˆ˜ h)

prop-postcomp-invertible {๐“ค} {X} {Y} {A} pei i j f (g , ฮท , ฮต) = ฮณ
 where
  f' : (A โ†’ X) โ†’ (A โ†’ Y)
  f' h = f โˆ˜ h

  g' : (A โ†’ Y) โ†’ (A โ†’ X)
  g' k = g โˆ˜ k

  ฮท' : (h : A โ†’ X) โ†’ g' (f' h) โ‰ก h
  ฮท' h = pei A X i (g' (f' h)) h

  ฮต' : (k : A โ†’ Y) โ†’ f' (g' k) โ‰ก k
  ฮต' k = pei A Y j (f' (g' k)) k

  ฮณ : invertible f'
  ฮณ = (g' , ฮท' , ฮต')

prop-postcomp-is-equiv : {X Y A : ๐“ค ฬ‡ }
                       โ†’ props-form-exponential-ideal ๐“ค
                       โ†’ is-prop X
                       โ†’ is-prop Y
                       โ†’ (f : X โ†’ Y)
                       โ†’ is-equiv f
                       โ†’ is-equiv (ฮป (h : A โ†’ X) โ†’ f โˆ˜ h)

prop-postcomp-is-equiv pei i j f e =
 invertibles-are-equivs
  (ฮป h โ†’ f โˆ˜ h)
  (prop-postcomp-invertible pei i j f (equivs-are-invertible f e))

props-form-exponential-ideal-gives-vvfunext : props-form-exponential-ideal ๐“ค โ†’ prop-vvfunext ๐“ค
props-form-exponential-ideal-gives-vvfunext {๐“ค} pei {X} {A} X-is-prop ฯ† = ฮณ
 where
  f : ฮฃ A โ†’ X
  f = prโ‚

  A-is-prop-valued : (x : X) โ†’ is-prop (A x)
  A-is-prop-valued x = singletons-are-subsingletons (A x) (ฯ† x)

  k : is-prop (ฮฃ A)
  k = ฮฃ-is-subsingleton X-is-prop A-is-prop-valued

  f-is-equiv : is-equiv f
  f-is-equiv = prโ‚-is-equiv ฯ†

  g : (X โ†’ ฮฃ A) โ†’ (X โ†’ X)
  g h = f โˆ˜ h

  e : is-equiv g
  e = prop-postcomp-is-equiv pei k X-is-prop f f-is-equiv

  i : is-singleton (ฮฃ h ๊ž‰ (X โ†’ ฮฃ A), f โˆ˜ h โ‰ก ๐‘–๐‘‘ X)
  i = e (๐‘–๐‘‘ X)

  r : (ฮฃ h ๊ž‰ (X โ†’ ฮฃ A), f โˆ˜ h โ‰ก ๐‘–๐‘‘ X) โ†’ ฮ  A
  r (h , p) x = transport A (happly (f โˆ˜ h) (๐‘–๐‘‘ X) p x) (prโ‚‚ (h x))

  s : ฮ  A โ†’ (ฮฃ h ๊ž‰ (X โ†’ ฮฃ A), f โˆ˜ h โ‰ก ๐‘–๐‘‘ X)
  s ฯˆ = (ฮป x โ†’ x , ฯˆ x) , refl (๐‘–๐‘‘ X)

  ฮท : โˆ€ ฯˆ โ†’ r (s ฯˆ) โ‰ก ฯˆ
  ฮท ฯˆ = refl (r (s ฯˆ))

  ฮณ : is-singleton (ฮ  A)
  ฮณ = retract-of-singleton (r , s , ฮท) i

prop-univalence-gives-props-are-closed-under-ฮ  : prop-univalence ๐“ค โ†’ props-are-closed-under-ฮ  ๐“ค
prop-univalence-gives-props-are-closed-under-ฮ  pu =
    prop-vvfunext-gives-props-are-closed-under-ฮ 
        (props-form-exponential-ideal-gives-vvfunext
              (prop-univalence-gives-props-form-exponential-ideal pu))

propext-and-props-closed-under-ฮ -give-props-form-exponential-ideal :

    propext ๐“ค
  โ†’ props-are-closed-under-ฮ  ๐“ค
  โ†’ props-form-exponential-ideal ๐“ค

propext-and-props-closed-under-ฮ -give-props-form-exponential-ideal pe c =
  prop-univalence-gives-props-form-exponential-ideal
      (propext-and-props-are-closed-under-ฮ -give-prop-univalence pe c)

props-form-exponential-ideal-gives-props-are-closed-under-ฮ  :

    props-form-exponential-ideal ๐“ค
  โ†’ props-are-closed-under-ฮ  ๐“ค

props-form-exponential-ideal-gives-props-are-closed-under-ฮ  pei =
     prop-vvfunext-gives-props-are-closed-under-ฮ 
         (props-form-exponential-ideal-gives-vvfunext pei)

characterization-of-propositional-univalence {๐“ค} = ฮฑ , ฮฒ
 where
  ฮฑ : prop-univalence ๐“ค โ†’ propext ๐“ค ร— props-are-closed-under-ฮ  ๐“ค
  ฮฑ pu =  prop-univalence-gives-propext pu , prop-univalence-gives-props-are-closed-under-ฮ  pu

  ฮฒ : propext ๐“ค ร— props-are-closed-under-ฮ  ๐“ค โ†’ prop-univalence ๐“ค
  ฮฒ (pe , fe) = propext-and-props-are-closed-under-ฮ -give-prop-univalence pe fe

second-propositional-function-extensionality-agreement {๐“ค} pe =
  props-form-exponential-ideal-gives-props-are-closed-under-ฮ  ,
  propext-and-props-closed-under-ฮ -give-props-form-exponential-ideal pe

id-โ‰ƒ-left : dfunext ๐“ฅ (๐“ค โŠ” ๐“ฅ)
          โ†’ dfunext (๐“ค โŠ” ๐“ฅ) (๐“ค โŠ” ๐“ฅ)
          โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (ฮฑ : X โ‰ƒ Y)
          โ†’ id-โ‰ƒ X โ— ฮฑ โ‰ก ฮฑ

id-โ‰ƒ-left fe fe' ฮฑ = to-subtype-โ‰ก (being-equiv-is-subsingleton fe fe') (refl _)

โ‰ƒ-sym-left-inverse : dfunext ๐“ฅ ๐“ฅ
                   โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (ฮฑ : X โ‰ƒ Y)
                   โ†’ โ‰ƒ-sym ฮฑ โ— ฮฑ โ‰ก id-โ‰ƒ Y

โ‰ƒ-sym-left-inverse fe (f , e) = to-subtype-โ‰ก (being-equiv-is-subsingleton fe fe) p
 where
  p : f โˆ˜ inverse f e โ‰ก id
  p = fe (inverses-are-sections f e)

โ‰ƒ-sym-right-inverse : dfunext ๐“ค ๐“ค
                    โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (ฮฑ : X โ‰ƒ Y)
                    โ†’ ฮฑ โ— โ‰ƒ-sym ฮฑ โ‰ก id-โ‰ƒ X

โ‰ƒ-sym-right-inverse fe (f , e) = to-subtype-โ‰ก (being-equiv-is-subsingleton fe fe) p
 where
  p : inverse f e โˆ˜ f โ‰ก id
  p = fe (inverses-are-retractions f e)

โ‰ƒ-Sym : dfunext ๐“ฅ (๐“ค โŠ” ๐“ฅ)
      โ†’ dfunext ๐“ค (๐“ค โŠ” ๐“ฅ)
      โ†’ dfunext (๐“ค โŠ” ๐“ฅ) (๐“ค โŠ” ๐“ฅ)
      โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
      โ†’ (X โ‰ƒ Y) โ‰ƒ (Y โ‰ƒ X)

โ‰ƒ-Sym feโ‚€ feโ‚ feโ‚‚ = โ‰ƒ-sym , โ‰ƒ-sym-is-equiv feโ‚€ feโ‚ feโ‚‚

โ‰ƒ-Comp : dfunext ๐“ฆ (๐“ฅ โŠ” ๐“ฆ)
       โ†’ dfunext (๐“ฅ โŠ” ๐“ฆ) (๐“ฅ โŠ” ๐“ฆ )
       โ†’ dfunext ๐“ฅ ๐“ฅ
       โ†’ dfunext ๐“ฆ (๐“ค โŠ” ๐“ฆ)
       โ†’ dfunext (๐“ค โŠ” ๐“ฆ) (๐“ค โŠ” ๐“ฆ )
       โ†’ dfunext ๐“ค ๐“ค
       โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (Z : ๐“ฆ ฬ‡ )
       โ†’ X โ‰ƒ Y โ†’ (Y โ‰ƒ Z) โ‰ƒ (X โ‰ƒ Z)

โ‰ƒ-Comp feโ‚€ feโ‚ feโ‚‚ feโ‚ƒ feโ‚„ feโ‚… Z ฮฑ = invertibility-gives-โ‰ƒ (ฮฑ โ—_)
                                      ((โ‰ƒ-sym ฮฑ โ—_) , p , q)
 where
  p = ฮป ฮฒ โ†’ โ‰ƒ-sym ฮฑ โ— (ฮฑ โ— ฮฒ) โ‰กโŸจ โ—-assoc feโ‚€ feโ‚ (โ‰ƒ-sym ฮฑ) ฮฑ ฮฒ        โŸฉ
            (โ‰ƒ-sym ฮฑ โ— ฮฑ) โ— ฮฒ โ‰กโŸจ ap (_โ— ฮฒ) (โ‰ƒ-sym-left-inverse feโ‚‚ ฮฑ) โŸฉ
            id-โ‰ƒ _ โ— ฮฒ        โ‰กโŸจ id-โ‰ƒ-left feโ‚€ feโ‚ _                  โŸฉ
            ฮฒ                 โˆŽ

  q = ฮป ฮณ โ†’ ฮฑ โ— (โ‰ƒ-sym ฮฑ โ— ฮณ) โ‰กโŸจ โ—-assoc feโ‚ƒ feโ‚„ ฮฑ (โ‰ƒ-sym ฮฑ) ฮณ         โŸฉ
            (ฮฑ โ— โ‰ƒ-sym ฮฑ) โ— ฮณ โ‰กโŸจ ap (_โ— ฮณ) (โ‰ƒ-sym-right-inverse feโ‚… ฮฑ) โŸฉ
            id-โ‰ƒ _ โ— ฮณ        โ‰กโŸจ id-โ‰ƒ-left feโ‚ƒ feโ‚„ _                   โŸฉ
            ฮณ                 โˆŽ

Eq-Eq-cong' : dfunext ๐“ฅ (๐“ค โŠ” ๐“ฅ)
            โ†’ dfunext (๐“ค โŠ” ๐“ฅ) (๐“ค โŠ” ๐“ฅ)
            โ†’ dfunext ๐“ค ๐“ค
            โ†’ dfunext ๐“ฅ (๐“ฅ โŠ” ๐“ฆ)
            โ†’ dfunext (๐“ฅ โŠ” ๐“ฆ) (๐“ฅ โŠ” ๐“ฆ)
            โ†’ dfunext ๐“ฆ ๐“ฆ
            โ†’ dfunext ๐“ฆ (๐“ฅ โŠ” ๐“ฆ)
            โ†’ dfunext ๐“ฅ ๐“ฅ
            โ†’ dfunext ๐“ฆ (๐“ฆ โŠ” ๐“ฃ)
            โ†’ dfunext (๐“ฆ โŠ” ๐“ฃ) (๐“ฆ โŠ” ๐“ฃ)
            โ†’ dfunext ๐“ฃ ๐“ฃ
            โ†’ dfunext ๐“ฃ (๐“ฆ โŠ” ๐“ฃ)
            โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {A : ๐“ฆ ฬ‡ } {B : ๐“ฃ ฬ‡ }
            โ†’ X โ‰ƒ A โ†’ Y โ‰ƒ B โ†’ (X โ‰ƒ Y) โ‰ƒ (A โ‰ƒ B)

Eq-Eq-cong' feโ‚€ feโ‚ feโ‚‚ feโ‚ƒ feโ‚„ feโ‚… feโ‚† feโ‚‡ feโ‚ˆ feโ‚‰ feโ‚โ‚€ feโ‚โ‚ {X} {Y} {A} {B} ฮฑ ฮฒ =

  X โ‰ƒ Y   โ‰ƒโŸจ โ‰ƒ-Comp feโ‚€ feโ‚ feโ‚‚ feโ‚ƒ feโ‚„ feโ‚… Y (โ‰ƒ-sym ฮฑ)  โŸฉ
  A โ‰ƒ Y   โ‰ƒโŸจ โ‰ƒ-Sym feโ‚ƒ feโ‚† feโ‚„                           โŸฉ
  Y โ‰ƒ A   โ‰ƒโŸจ โ‰ƒ-Comp feโ‚† feโ‚„ feโ‚‡ feโ‚ˆ feโ‚‰ feโ‚โ‚€ A (โ‰ƒ-sym ฮฒ) โŸฉ
  B โ‰ƒ A   โ‰ƒโŸจ โ‰ƒ-Sym feโ‚ˆ feโ‚โ‚ feโ‚‰                          โŸฉ
  A โ‰ƒ B   โ– 

Eq-Eq-cong : global-dfunext
           โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {A : ๐“ฆ ฬ‡ } {B : ๐“ฃ ฬ‡ }
           โ†’ X โ‰ƒ A โ†’ Y โ‰ƒ B โ†’ (X โ‰ƒ Y) โ‰ƒ (A โ‰ƒ B)

Eq-Eq-cong fe = Eq-Eq-cong' fe fe fe fe fe fe fe fe fe fe fe fe

is-embedding : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
is-embedding f = (y : codomain f) โ†’ is-subsingleton (fiber f y)

being-embedding-is-subsingleton : global-dfunext
                                โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                                โ†’ is-subsingleton (is-embedding f)

being-embedding-is-subsingleton fe f =
 ฮ -is-subsingleton fe
  (ฮป x โ†’ being-subsingleton-is-subsingleton fe)

prโ‚‚-embedding : (A : ๐“ค ฬ‡ ) (X : ๐“ฅ ฬ‡ )
              โ†’ is-subsingleton A
              โ†’ is-embedding (ฮป (z : A ร— X) โ†’ prโ‚‚ z)

prโ‚‚-embedding A X i x ((a , x) , refl x) ((b , x) , refl x) = p
 where
  p : ((a , x) , refl x) โ‰ก ((b , x) , refl x)
  p = ap (ฮป - โ†’ ((- , x) , refl x)) (i a b)

prโ‚-is-embedding : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
                 โ†’ ((x : X) โ†’ is-subsingleton (A x))
                 โ†’ is-embedding (ฮป (ฯƒ : ฮฃ A) โ†’ prโ‚ ฯƒ)

prโ‚-is-embedding i x ((x , a) , refl x) ((x , a') , refl x) = ฮณ
 where
  p : a โ‰ก a'
  p = i x a a'

  ฮณ : (x , a) , refl x โ‰ก (x , a') , refl x
  ฮณ = ap (ฮป - โ†’ (x , -) , refl x) p

equivs-are-embeddings : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ }
                        (f : X โ†’ Y)
                      โ†’ is-equiv f
                      โ†’ is-embedding f

equivs-are-embeddings f i y = singletons-are-subsingletons (fiber f y) (i y)

id-is-embedding : {X : ๐“ค ฬ‡ } โ†’ is-embedding (๐‘–๐‘‘ X)
id-is-embedding {๐“ค} {X} = equivs-are-embeddings id (id-is-equiv X)

โˆ˜-embedding : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } {Z : ๐“ฆ ฬ‡ }
              {f : X โ†’ Y} {g : Y โ†’ Z}
            โ†’ is-embedding g
            โ†’ is-embedding f
            โ†’ is-embedding (g โˆ˜ f)

โˆ˜-embedding {๐“ค} {๐“ฅ} {๐“ฆ} {X} {Y} {Z} {f} {g} d e = h
 where
  A : (z : Z) โ†’ ๐“ค โŠ” ๐“ฅ โŠ” ๐“ฆ ฬ‡
  A z = ฮฃ (y , p) ๊ž‰ fiber g z , fiber f y

  i : (z : Z) โ†’ is-subsingleton (A z)
  i z = ฮฃ-is-subsingleton (d z) (ฮป w โ†’ e (prโ‚ w))

  ฯ† : (z : Z) โ†’ fiber (g โˆ˜ f) z โ†’ A z
  ฯ† z (x , p) = (f x , p) , x , refl (f x)

  ฮณ : (z : Z) โ†’ A z โ†’ fiber (g โˆ˜ f) z
  ฮณ z ((_ , p) , x , refl _) = x , p

  ฮท : (z : Z) (t : fiber (g โˆ˜ f) z) โ†’ ฮณ z (ฯ† z t) โ‰ก t
  ฮท _ (x , refl _) = refl (x , refl ((g โˆ˜ f) x))

  h : (z : Z) โ†’ is-subsingleton (fiber (g โˆ˜ f) z)
  h z = lc-maps-reflect-subsingletons (ฯ† z) (sections-are-lc (ฯ† z) (ฮณ z , ฮท z)) (i z)

embedding-lemma : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                โ†’ ((x : X) โ†’ is-singleton (fiber f (f x)))
                โ†’ is-embedding f

embedding-lemma f ฯ† = ฮณ
 where
  ฮณ : (y : codomain f) (u v : fiber f y) โ†’ u โ‰ก v
  ฮณ y (x , p) v = j (x , p) v
   where
    q : fiber f (f x) โ‰ก fiber f y
    q = ap (fiber f) p

    i : is-singleton (fiber f y)
    i = transport is-singleton q (ฯ† x)

    j : is-subsingleton (fiber f y)
    j = singletons-are-subsingletons (fiber f y) i

embedding-criterion : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                    โ†’ ((x x' : X) โ†’ (f x โ‰ก f x') โ‰ƒ (x โ‰ก x'))
                    โ†’ is-embedding f

embedding-criterion f e = embedding-lemma f b
 where
  X = domain f

  a : (x : X) โ†’ (ฮฃ x' ๊ž‰ X , f x' โ‰ก f x) โ‰ƒ (ฮฃ x' ๊ž‰ X , x' โ‰ก x)
  a x = ฮฃ-cong (ฮป x' โ†’ e x' x)

  a' : (x : X) โ†’ fiber f (f x) โ‰ƒ singleton-type x
  a' = a

  b : (x : X) โ†’ is-singleton (fiber f (f x))
  b x = equiv-to-singleton (a' x) (singleton-types-are-singletons X x)

ap-is-equiv-gives-embedding : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                            โ†’ ((x x' : X) โ†’ is-equiv (ap f {x} {x'}))
                            โ†’ is-embedding f

ap-is-equiv-gives-embedding f i = embedding-criterion f
                                   (ฮป x' x โ†’ โ‰ƒ-sym (ap f {x'} {x} , i x' x))

embedding-gives-ap-is-equiv : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                            โ†’ is-embedding f
                            โ†’ (x x' : X) โ†’ is-equiv (ap f {x} {x'})

embedding-gives-ap-is-equiv {๐“ค} {๐“ฅ} {X} f e = ฮณ
 where
  d : (x' : X) โ†’ (ฮฃ x ๊ž‰ X , f x' โ‰ก f x) โ‰ƒ (ฮฃ x ๊ž‰ X , f x โ‰ก f x')
  d x' = ฮฃ-cong (ฮป x โ†’ โปยน-โ‰ƒ (f x') (f x))

  s : (x' : X) โ†’ is-subsingleton (ฮฃ x ๊ž‰ X , f x' โ‰ก f x)
  s x' = equiv-to-subsingleton (d x') (e (f x'))

  ฮณ : (x x' : X) โ†’ is-equiv (ap f {x} {x'})
  ฮณ x = singleton-equiv-lemma x (ฮป x' โ†’ ap f {x} {x'})
         (pointed-subsingletons-are-singletons
           (ฮฃ x' ๊ž‰ X , f x โ‰ก f x') (x , (refl (f x))) (s x))

embedding-criterion-converse : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                             โ†’ is-embedding f
                             โ†’ ((x' x : X) โ†’ (f x' โ‰ก f x) โ‰ƒ (x' โ‰ก x))

embedding-criterion-converse f e x' x = โ‰ƒ-sym
                                         (ap f {x'} {x} ,
                                          embedding-gives-ap-is-equiv f e x' x)

embeddings-are-lc : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                  โ†’ is-embedding f
                  โ†’ left-cancellable f

embeddings-are-lc f e {x} {y} = โŒœ embedding-criterion-converse f e x y โŒ

lc-maps-into-sets-are-embeddings : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                                 โ†’ left-cancellable f
                                 โ†’ is-set Y
                                 โ†’ is-embedding f
lc-maps-into-sets-are-embeddings {๐“ค} {๐“ฅ} {X} {Y} f lc i y = ฮณ
 where
  ฮณ : is-subsingleton (ฮฃ x ๊ž‰ X , f x โ‰ก y)
  ฮณ (x , p) (x' , p') = to-subtype-โ‰ก j q
   where
    j : (x : X) โ†’ is-subsingleton (f x โ‰ก y)
    j x = i (f x) y

    q : x โ‰ก x'
    q = lc (f x  โ‰กโŸจ p     โŸฉ
            y    โ‰กโŸจ p' โปยน โŸฉ
            f x' โˆŽ)

embedding-with-section-is-equiv : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                                โ†’ is-embedding f
                                โ†’ has-section f
                                โ†’ is-equiv f
embedding-with-section-is-equiv f i (g , ฮท) y = pointed-subsingletons-are-singletons
                                                 (fiber f y) (g y , ฮท y) (i y)

Natฮ  : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {B : X โ†’ ๐“ฆ ฬ‡ } โ†’ Nat A B โ†’ ฮ  A โ†’ ฮ  B
Natฮ  ฯ„ f x = ฯ„ x (f x)

Natฮ -is-embedding : hfunext ๐“ค ๐“ฅ
                  โ†’ hfunext ๐“ค ๐“ฆ
                  โ†’ {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {B : X โ†’ ๐“ฆ ฬ‡ }
                  โ†’ (ฯ„ : Nat A B)
                  โ†’ ((x : X) โ†’ is-embedding (ฯ„ x))
                  โ†’ is-embedding (Natฮ  ฯ„)

Natฮ -is-embedding v w {X} {A} ฯ„ i = embedding-criterion (Natฮ  ฯ„) ฮณ
 where
  ฮณ : (f g : ฮ  A) โ†’ (Natฮ  ฯ„ f โ‰ก Natฮ  ฯ„ g) โ‰ƒ (f โ‰ก g)
  ฮณ f g = (Natฮ  ฯ„ f โ‰ก Natฮ  ฯ„ g) โ‰ƒโŸจ hfunext-โ‰ƒ w (Natฮ  ฯ„ f) (Natฮ  ฯ„ g) โŸฉ
          (Natฮ  ฯ„ f โˆผ Natฮ  ฯ„ g) โ‰ƒโŸจ b                                 โŸฉ
          (f โˆผ g)               โ‰ƒโŸจ โ‰ƒ-sym (hfunext-โ‰ƒ v f g)           โŸฉ
          (f โ‰ก g)               โ– 

   where
    a : (x : X) โ†’ (Natฮ  ฯ„ f x โ‰ก Natฮ  ฯ„ g x) โ‰ƒ (f x โ‰ก g x)
    a x = embedding-criterion-converse (ฯ„ x) (i x) (f x) (g x)

    b : (Natฮ  ฯ„ f โˆผ Natฮ  ฯ„ g) โ‰ƒ (f โˆผ g)
    b = ฮ -cong (hfunext-gives-dfunext w) (hfunext-gives-dfunext v) a

triangle-lemma : dfunext ๐“ฆ (๐“ค โŠ” ๐“ฅ)
               โ†’ {Y : ๐“ค ฬ‡ } {A : ๐“ฅ ฬ‡ } (g : Y โ†’ A)
               โ†’ is-embedding g
               โ†’ {X : ๐“ฆ ฬ‡ } (f : X โ†’ A) โ†’ is-subsingleton (ฮฃ h ๊ž‰ (X โ†’ Y) , g โˆ˜ h โˆผ f)

triangle-lemma fe {Y} {A} g i {X} f = iv
 where
  ii : (x : X) โ†’ is-subsingleton (ฮฃ y ๊ž‰ Y , g y โ‰ก f x)
  ii x = i (f x)

  iii : is-subsingleton (ฮ  x ๊ž‰ X , ฮฃ y ๊ž‰ Y , g y โ‰ก f x)
  iii = ฮ -is-subsingleton fe ii

  iv : is-subsingleton (ฮฃ h ๊ž‰ (X โ†’ Y) , g โˆ˜ h โˆผ f)
  iv = equiv-to-subsingleton (โ‰ƒ-sym ฮ ฮฃ-distr-โ‰ƒ) iii

postcomp-is-embedding : dfunext ๐“ฆ (๐“ค โŠ” ๐“ฅ) โ†’ hfunext ๐“ฆ ๐“ฅ
                      โ†’ {Y : ๐“ค ฬ‡ } {A : ๐“ฅ ฬ‡ } (g : Y โ†’ A)
                      โ†’ is-embedding g
                      โ†’ (X : ๐“ฆ ฬ‡ ) โ†’ is-embedding (ฮป (h : X โ†’ Y) โ†’ g โˆ˜ h)

postcomp-is-embedding fe hfe {Y} {A} g i X = ฮณ
 where
  ฮณ : (f : X โ†’ A) โ†’ is-subsingleton (ฮฃ h ๊ž‰ (X โ†’ Y) , g โˆ˜ h โ‰ก f)
  ฮณ f = equiv-to-subsingleton u (triangle-lemma fe g i f)
   where
    u : (ฮฃ h ๊ž‰ (X โ†’ Y) , g โˆ˜ h โ‰ก f) โ‰ƒ (ฮฃ h ๊ž‰ (X โ†’ Y) , g โˆ˜ h โˆผ f)
    u = ฮฃ-cong (ฮป h โ†’ hfunext-โ‰ƒ hfe (g โˆ˜ h) f)

_โ†ช_ : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
X โ†ช Y = ฮฃ f ๊ž‰ (X โ†’ Y), is-embedding f

Embโ†’fun : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†ช Y) โ†’ (X โ†’ Y)
Embโ†’fun (f , i) = f

๐“จ : {X : ๐“ค ฬ‡ } โ†’ X โ†’ (X โ†’ ๐“ค ฬ‡ )
๐“จ {๐“ค} {X} = Id X

๐‘Œ : (X : ๐“ค ฬ‡ ) โ†’ X โ†’ (X โ†’ ๐“ค ฬ‡ )
๐‘Œ {๐“ค} X = ๐“จ {๐“ค} {X}

transport-lemma : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (x : X)
                โ†’ (ฯ„ : Nat (๐“จ x) A)
                โ†’ (y : X) (p : x โ‰ก y) โ†’ ฯ„ y p โ‰ก transport A p (ฯ„ x (refl x))

transport-lemma A x ฯ„ x (refl x) = refl (ฯ„ x (refl x))

๐“” : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (x : X) โ†’ Nat (๐“จ x) A โ†’ A x
๐“” A x ฯ„ = ฯ„ x (refl x)

๐“ : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (x : X) โ†’ A x โ†’ Nat (๐“จ x) A
๐“ A x a y p = transport A p a

yoneda-ฮท : dfunext ๐“ค (๐“ค โŠ” ๐“ฅ)
         โ†’ dfunext ๐“ค ๐“ฅ
         โ†’ {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (x : X)
         โ†’ ๐“ A x โˆ˜ ๐“” A x โˆผ id

yoneda-ฮท fe fe' A x = ฮณ
 where
  ฮณ : (ฯ„ : Nat (๐“จ x) A) โ†’ (ฮป y p โ†’ transport A p (ฯ„ x (refl x))) โ‰ก ฯ„
  ฮณ ฯ„ = fe (ฮป y โ†’ fe' (ฮป p โ†’ (transport-lemma A x ฯ„ y p)โปยน))

yoneda-ฮต : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (x : X)
         โ†’ ๐“” A x โˆ˜ ๐“ A x โˆผ id

yoneda-ฮต A x = ฮณ
 where
  ฮณ : (a : A x) โ†’ transport A (refl x) a โ‰ก a
  ฮณ = refl

is-fiberwise-equiv : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {B : X โ†’ ๐“ฆ ฬ‡ } โ†’ Nat A B โ†’ ๐“ค โŠ” ๐“ฅ โŠ” ๐“ฆ ฬ‡
is-fiberwise-equiv ฯ„ = โˆ€ x โ†’ is-equiv (ฯ„ x)

๐“”-is-equiv : dfunext ๐“ค (๐“ค โŠ” ๐“ฅ)
           โ†’ dfunext ๐“ค ๐“ฅ
           โ†’ {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ )
           โ†’ is-fiberwise-equiv (๐“” A)

๐“”-is-equiv fe fe' A x = invertibles-are-equivs (๐“” A x )
                         (๐“ A x , yoneda-ฮท fe fe' A x , yoneda-ฮต A x)

๐“-is-equiv : dfunext ๐“ค (๐“ค โŠ” ๐“ฅ)
           โ†’ dfunext ๐“ค ๐“ฅ
           โ†’ {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ )
           โ†’ is-fiberwise-equiv (๐“ A)

๐“-is-equiv fe fe' A x = invertibles-are-equivs (๐“ A x)
                         (๐“” A x , yoneda-ฮต A x , yoneda-ฮท fe fe' A x)

Yoneda-Lemma : dfunext ๐“ค (๐“ค โŠ” ๐“ฅ)
             โ†’ dfunext ๐“ค ๐“ฅ
             โ†’ {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (x : X)
             โ†’ Nat (๐“จ x) A โ‰ƒ A x

Yoneda-Lemma fe fe' A x = ๐“” A x , ๐“”-is-equiv fe fe' A x

retract-universal-lemma : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (x : X)
                        โ†’ ((y : X) โ†’ A y โ— (x โ‰ก y))
                        โ†’ โˆƒ! A

retract-universal-lemma A x ฯ = i
 where
  ฯƒ : ฮฃ A โ— singleton-type' x
  ฯƒ = ฮฃ-retract ฯ

  i : โˆƒ! A
  i = retract-of-singleton ฯƒ (singleton-types'-are-singletons (domain A) x)

fiberwise-equiv-universal : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ )
                            (x : X) (ฯ„ : Nat (๐“จ x) A)
                          โ†’ is-fiberwise-equiv ฯ„
                          โ†’ โˆƒ! A

fiberwise-equiv-universal A x ฯ„ e = retract-universal-lemma A x ฯ
 where
  ฯ : โˆ€ y โ†’ A y โ— (x โ‰ก y)
  ฯ y = โ‰ƒ-gives-โ–ท ((ฯ„ y) , e y)

universal-fiberwise-equiv : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ )
                          โ†’ โˆƒ! A
                          โ†’ (x : X) (ฯ„ : Nat (๐“จ x) A) โ†’ is-fiberwise-equiv ฯ„

universal-fiberwise-equiv {๐“ค} {๐“ฅ} {X} A u x ฯ„ = ฮณ
 where
  g : singleton-type' x โ†’ ฮฃ A
  g = Natฮฃ ฯ„

  e : is-equiv g
  e = maps-of-singletons-are-equivs g (singleton-types'-are-singletons X x) u

  ฮณ : is-fiberwise-equiv ฯ„
  ฮณ = Natฮฃ-equiv-gives-fiberwise-equiv ฯ„ e

hfunextโ†’ : hfunext ๐“ค ๐“ฅ
         โ†’ ((X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ ) (f : ฮ  A) โ†’ โˆƒ! g ๊ž‰ ฮ  A , f โˆผ g)

hfunextโ†’ hfe X A f = fiberwise-equiv-universal (f โˆผ_) f (happly f) (hfe f)

โ†’hfunext : ((X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ ) (f : ฮ  A) โ†’ โˆƒ! g ๊ž‰ ฮ  A , f โˆผ g)
         โ†’ hfunext ๐“ค ๐“ฅ

โ†’hfunext ฯ† {X} {A} f = universal-fiberwise-equiv (f โˆผ_) (ฯ† X A f) f (happly f)

fiberwise-equiv-criterion : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ )
                            (x : X)
                          โ†’ ((y : X) โ†’ A y โ— (x โ‰ก y))
                          โ†’ (ฯ„ : Nat (๐“จ x) A) โ†’ is-fiberwise-equiv ฯ„

fiberwise-equiv-criterion A x ฯ ฯ„ = universal-fiberwise-equiv A
                                     (retract-universal-lemma A x ฯ) x ฯ„

fiberwise-equiv-criterion' : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ )
                            (x : X)
                          โ†’ ((y : X) โ†’ (x โ‰ก y) โ‰ƒ A y)
                          โ†’ (ฯ„ : Nat (๐“จ x) A) โ†’ is-fiberwise-equiv ฯ„

fiberwise-equiv-criterion' A x e = fiberwise-equiv-criterion A x
                                    (ฮป y โ†’ โ‰ƒ-gives-โ–ท (e y))

_โ‰ƒฬ‡_ : {X : ๐“ค ฬ‡ } โ†’ (X โ†’ ๐“ฅ ฬ‡ ) โ†’ (X โ†’ ๐“ฆ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ โŠ” ๐“ฆ ฬ‡
A โ‰ƒฬ‡ B = โˆ€ x โ†’ A x โ‰ƒ B x

is-representable : {X : ๐“ค ฬ‡ } โ†’ (X โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
is-representable A = ฮฃ x ๊ž‰ domain A , ๐“จ x โ‰ƒฬ‡ A

representable-universal : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ )
                        โ†’ is-representable A
                        โ†’ โˆƒ! A

representable-universal A (x , e) = retract-universal-lemma A x
                                     (ฮป x โ†’ โ‰ƒ-gives-โ–ท (e x))

universal-representable : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ }
                        โ†’ โˆƒ! A
                        โ†’ is-representable A

universal-representable {๐“ค} {๐“ฅ} {X} {A} ((x , a) , p) = x , ฯ†
 where
  e : is-fiberwise-equiv (๐“ A x a)
  e = universal-fiberwise-equiv A ((x , a) , p) x (๐“ A x a)

  ฯ† : (y : X) โ†’ (x โ‰ก y) โ‰ƒ A y
  ฯ† y = (๐“ A x a y , e y)

fiberwise-retractions-are-equivs : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (x : X)
                                 โ†’ (ฯ„ : Nat (๐“จ x) A)
                                 โ†’ ((y : X) โ†’ has-section (ฯ„ y))
                                 โ†’ is-fiberwise-equiv ฯ„

fiberwise-retractions-are-equivs {๐“ค} {๐“ฅ} {X} A x ฯ„ s = ฮณ
 where
  ฯ : (y : X) โ†’ A y โ— (x โ‰ก y)
  ฯ y = ฯ„ y , s y

  i : โˆƒ! A
  i = retract-universal-lemma A x ฯ

  ฮณ : is-fiberwise-equiv ฯ„
  ฮณ = universal-fiberwise-equiv A i x ฯ„

fiberwise-โ—-gives-โ‰ƒ : (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ ) (x : X)
                    โ†’ ((y : X) โ†’ A y โ— (x โ‰ก y))
                    โ†’ ((y : X) โ†’ A y โ‰ƒ (x โ‰ก y))

fiberwise-โ—-gives-โ‰ƒ X A x ฯ = ฮณ
 where
  f : (y : X) โ†’ (x โ‰ก y) โ†’ A y
  f y = retraction (ฯ y)

  e : is-fiberwise-equiv f
  e = fiberwise-retractions-are-equivs A x f (ฮป y โ†’ retraction-has-section (ฯ y))

  ฮณ : (y : X) โ†’ A y โ‰ƒ (x โ‰ก y)
  ฮณ y = โ‰ƒ-sym(f y , e y)

embedding-criterion' : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                     โ†’ ((x x' : X) โ†’ (f x โ‰ก f x') โ— (x โ‰ก x'))
                     โ†’ is-embedding f

embedding-criterion' f ฯ = embedding-criterion f
                            (ฮป x โ†’ fiberwise-โ—-gives-โ‰ƒ (domain f)
                                    (ฮป - โ†’ f x โ‰ก f -) x (ฯ x))

being-fiberwise-equiv-is-subsingleton : global-dfunext
                                      โ†’ {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {B : X โ†’ ๐“ฆ ฬ‡ }
                                      โ†’ (ฯ„ : Nat A B)
                                      โ†’ is-subsingleton (is-fiberwise-equiv ฯ„)

being-fiberwise-equiv-is-subsingleton fe ฯ„ =
 ฮ -is-subsingleton fe (ฮป y โ†’ being-equiv-is-subsingleton fe fe (ฯ„ y))

being-representable-is-subsingleton : global-dfunext
                                    โ†’ {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ )
                                    โ†’ is-subsingleton (is-representable A)

being-representable-is-subsingleton fe {X} A rโ‚€ rโ‚ = ฮณ
 where
  u : โˆƒ! A
  u = representable-universal A rโ‚€

  i : (x : X) (ฯ„ : Nat (๐“จ x) A) โ†’ is-singleton (is-fiberwise-equiv ฯ„)
  i x ฯ„ = pointed-subsingletons-are-singletons
           (is-fiberwise-equiv ฯ„)
           (universal-fiberwise-equiv A u x ฯ„)
           (being-fiberwise-equiv-is-subsingleton fe ฯ„)

  ฮต : (x : X) โ†’ (๐“จ x โ‰ƒฬ‡ A) โ‰ƒ A x
  ฮต x = ((y : X) โ†’ ๐“จ x y โ‰ƒ A y)                       โ‰ƒโŸจ ฮ ฮฃ-distr-โ‰ƒ             โŸฉ
        (ฮฃ ฯ„ ๊ž‰ Nat (๐“จ x) A , is-fiberwise-equiv ฯ„)    โ‰ƒโŸจ prโ‚-โ‰ƒ (i x)            โŸฉ
        Nat (๐“จ x) A                                   โ‰ƒโŸจ Yoneda-Lemma fe fe A x โŸฉ
        A x                                           โ– 

  ฮด : is-representable A โ‰ƒ ฮฃ A
  ฮด = ฮฃ-cong ฮต

  v : is-singleton (is-representable A)
  v = equiv-to-singleton ฮด u

  ฮณ : rโ‚€ โ‰ก rโ‚
  ฮณ = singletons-are-subsingletons (is-representable A) v rโ‚€ rโ‚

๐“จ-is-embedding : Univalence โ†’ (X : ๐“ค ฬ‡ ) โ†’ is-embedding (๐‘Œ X)
๐“จ-is-embedding {๐“ค} ua X A = ฮณ
 where
  hfe : global-hfunext
  hfe = univalence-gives-global-hfunext ua

  dfe : global-dfunext
  dfe = univalence-gives-global-dfunext ua

  p = ฮป x โ†’ (๐“จ x โ‰ก A)                 โ‰ƒโŸจ i  x โŸฉ
            ((y : X) โ†’ ๐“จ x y โ‰ก A y)   โ‰ƒโŸจ ii x โŸฉ
            ((y : X) โ†’ ๐“จ x y โ‰ƒ A y)   โ– 
    where
     i  = ฮป x โ†’ (happly (๐“จ x) A , hfe (๐“จ x) A)
     ii = ฮป x โ†’ ฮ -cong dfe dfe
                 (ฮป y โ†’ univalence-โ‰ƒ (ua ๐“ค)
                         (๐“จ x y) (A y))

  e : fiber ๐“จ A โ‰ƒ is-representable A
  e = ฮฃ-cong p

  ฮณ : is-subsingleton (fiber ๐“จ A)
  ฮณ = equiv-to-subsingleton e (being-representable-is-subsingleton dfe A)

module function-graphs
        (ua : Univalence)
        {๐“ค ๐“ฅ : Universe}
        (X : ๐“ค ฬ‡ )
        (A : X โ†’ ๐“ฅ ฬ‡ )
       where

 hfe : global-hfunext
 hfe = univalence-gives-global-hfunext ua

 fe : global-dfunext
 fe = univalence-gives-global-dfunext ua

 Function : ๐“ค โŠ” ๐“ฅ ฬ‡
 Function = (x : X) โ†’ A x

 Relation : ๐“ค โŠ” (๐“ฅ โบ) ฬ‡
 Relation = (x : X) โ†’ A x โ†’ ๐“ฅ ฬ‡

 is-functional : Relation โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
 is-functional R = (x : X) โ†’ โˆƒ! a ๊ž‰ A x , R x a

 being-functional-is-subsingleton : (R : Relation)
                                  โ†’ is-subsingleton (is-functional R)

 being-functional-is-subsingleton R = ฮ -is-subsingleton fe
                                       (ฮป x โ†’ โˆƒ!-is-subsingleton (R x) fe)

 Functional-Relation : ๐“ค โŠ” (๐“ฅ โบ) ฬ‡
 Functional-Relation = ฮฃ R ๊ž‰ Relation , is-functional R

 ฯ : Function โ†’ Relation
 ฯ f = ฮป x a โ†’ f x โ‰ก a

 ฯ-is-embedding : is-embedding ฯ
 ฯ-is-embedding = Natฮ -is-embedding hfe hfe
                   (ฮป x โ†’ ๐‘Œ (A x))
                   (ฮป x โ†’ ๐“จ-is-embedding ua (A x))
  where

   ฯ„ : (x : X) โ†’ A x โ†’ (A x โ†’ ๐“ฅ ฬ‡ )
   ฯ„ x a b = a โ‰ก b

   remarkโ‚€ : ฯ„ โ‰ก ฮป x โ†’ ๐‘Œ (A x)
   remarkโ‚€ = refl _

   remarkโ‚ : ฯ โ‰ก Natฮ  ฯ„
   remarkโ‚ = refl _

 ฯ-is-functional : (f : Function) โ†’ is-functional (ฯ f)
 ฯ-is-functional f = ฯƒ
  where
   ฯƒ : (x : X) โ†’ โˆƒ! a ๊ž‰ A x , f x โ‰ก a
   ฯƒ x = singleton-types'-are-singletons (A x) (f x)

 ฮ“ : Function โ†’ Functional-Relation
 ฮ“ f = ฯ f , ฯ-is-functional f

 ฮฆ : Functional-Relation โ†’ Function
 ฮฆ (R , ฯƒ) = ฮป x โ†’ prโ‚ (center (ฮฃ a ๊ž‰ A x , R x a) (ฯƒ x))

 ฮ“-is-equiv : is-equiv ฮ“
 ฮ“-is-equiv = invertibles-are-equivs ฮ“ (ฮฆ , ฮท , ฮต)
  where
   ฮท : ฮฆ โˆ˜ ฮ“ โˆผ id
   ฮท = refl

   ฮต : ฮ“ โˆ˜ ฮฆ โˆผ id
   ฮต (R , ฯƒ) = a
    where
     f : Function
     f = ฮฆ (R , ฯƒ)

     e : (x : X) โ†’ R x (f x)
     e x = prโ‚‚ (center (ฮฃ a ๊ž‰ A x , R x a) (ฯƒ x))

     ฯ„ : (x : X) โ†’ Nat (๐“จ (f x)) (R x)
     ฯ„ x = ๐“ (R x) (f x) (e x)

     ฯ„-is-fiberwise-equiv : (x : X) โ†’ is-fiberwise-equiv (ฯ„ x)
     ฯ„-is-fiberwise-equiv x = universal-fiberwise-equiv (R x) (ฯƒ x) (f x) (ฯ„ x)

     d : (x : X) (a : A x) โ†’ (f x โ‰ก a) โ‰ƒ R x a
     d x a = ฯ„ x a , ฯ„-is-fiberwise-equiv x a

     c : (x : X) (a : A x) โ†’ (f x โ‰ก a) โ‰ก R x a
     c x a = Eqโ†’Id (ua ๐“ฅ) _ _ (d x a)

     b : ฯ f โ‰ก R
     b = fe (ฮป x โ†’ fe (c x))

     a : (ฯ f , ฯ-is-functional f) โ‰ก (R , ฯƒ)
     a = to-subtype-โ‰ก being-functional-is-subsingleton b

 functions-amount-to-functional-relations : Function โ‰ƒ Functional-Relation
 functions-amount-to-functional-relations = ฮ“ , ฮ“-is-equiv

ฮ โ‚š : {X : ๐“ค ฬ‡ } โ†’ (X โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โŠ” (๐“ฅ โบ) ฬ‡
ฮ โ‚š {๐“ค} {๐“ฅ} {X} A = ฮฃ R ๊ž‰ ((x : X) โ†’ A x โ†’ ๐“ฅ ฬ‡ )
                       , ((x : X) โ†’ is-subsingleton (ฮฃ a ๊ž‰ A x , R x a))

_โ‡€_ : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ โ†’ ๐“ค โŠ” (๐“ฅ โบ) ฬ‡
X โ‡€ Y = ฮ โ‚š (ฮป (_ : X) โ†’ Y)

is-defined : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } โ†’ ฮ โ‚š A โ†’ X โ†’ ๐“ฅ ฬ‡
is-defined (R , ฯƒ) x = ฮฃ a ๊ž‰ _ , R x a

being-defined-is-subsingleton : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } (f : ฮ โ‚š A) (x : X)
                              โ†’ is-subsingleton (is-defined f x)

being-defined-is-subsingleton (R , ฯƒ) x = ฯƒ x

_[_,_] :  {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } (f : ฮ โ‚š A) (x : X) โ†’ is-defined f x โ†’ A x
(R , s) [ x , (a , r)] = a

_โ‰กโ‚–_ : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } โ†’ ฮ โ‚š A โ†’ ฮ โ‚š A โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
f โ‰กโ‚– g = โˆ€ x โ†’ (is-defined f x โ‡” is-defined g x)
             ร— ((i : is-defined f x) (j : is-defined g x) โ†’ f [ x , i ] โ‰ก g [ x , j ])

module ฮผ-operator (fe : dfunext ๐“คโ‚€ ๐“คโ‚€) where

 open basic-arithmetic-and-order

 being-minimal-root-is-subsingleton : (f : โ„• โ†’ โ„•) (m : โ„•)
                                    โ†’ is-subsingleton (is-minimal-root f m)

 being-minimal-root-is-subsingleton f m = ร—-is-subsingleton
                                           (โ„•-is-set (f m) 0)
                                           (ฮ -is-subsingleton fe
                                              (ฮป _ โ†’ ฮ -is-subsingleton fe
                                              (ฮป _ โ†’ ฮ -is-subsingleton fe
                                              (ฮป _ โ†’ ๐Ÿ˜-is-subsingleton))))

 minimal-root-is-subsingleton : (f : โ„• โ†’ โ„•)
                              โ†’ is-subsingleton (minimal-root f)

 minimal-root-is-subsingleton f (m , p , ฯ†) (m' , p' , ฯ†') =
   to-subtype-โ‰ก
    (being-minimal-root-is-subsingleton f)
    (at-most-one-minimal-root f m m' (p , ฯ†) (p' , ฯ†'))

 ฮผ : (โ„• โ†’ โ„•) โ‡€ โ„•
 ฮผ = is-minimal-root , minimal-root-is-subsingleton

 ฮผ-propertyโ‚€ : (f : โ„• โ†’ โ„•) โ†’ (ฮฃ n ๊ž‰ โ„• , f n โ‰ก 0) โ†’ is-defined ฮผ f
 ฮผ-propertyโ‚€ = root-gives-minimal-root

 ฮผ-propertyโ‚ : (f : โ„• โ†’ โ„•) (i : is-defined ฮผ f)
             โ†’ (f (ฮผ [ f , i ]) โ‰ก 0)
             ร— ((n : โ„•) โ†’ n < ฮผ [ f , i ] โ†’ f n โ‰ข 0)

 ฮผ-propertyโ‚ f = prโ‚‚

is-total : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } โ†’ ฮ โ‚š A โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
is-total f = โˆ€ x โ†’ is-defined f x

record Lift {๐“ค : Universe} (๐“ฅ : Universe) (X : ๐“ค ฬ‡ ) : ๐“ค โŠ” ๐“ฅ ฬ‡  where
 constructor
  lift
 field
  lower : X

open Lift public

type-of-Lift  :             type-of (Lift  {๐“ค} ๐“ฅ)       โ‰ก (๐“ค ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡ )
type-of-lift  : {X : ๐“ค ฬ‡ } โ†’ type-of (lift  {๐“ค} {๐“ฅ} {X}) โ‰ก (X โ†’ Lift ๐“ฅ X)
type-of-lower : {X : ๐“ค ฬ‡ } โ†’ type-of (lower {๐“ค} {๐“ฅ} {X}) โ‰ก (Lift ๐“ฅ X โ†’ X)

type-of-Lift  = refl _
type-of-lift  = refl _
type-of-lower = refl _

Lift-induction : โˆ€ {๐“ค} ๐“ฅ (X : ๐“ค ฬ‡ ) (A : Lift ๐“ฅ X โ†’ ๐“ฆ ฬ‡ )
               โ†’ ((x : X) โ†’ A (lift x))
               โ†’ (l : Lift ๐“ฅ X) โ†’ A l

Lift-induction ๐“ฅ X A ฯ† (lift x) = ฯ† x

Lift-recursion : โˆ€ {๐“ค} ๐“ฅ {X : ๐“ค ฬ‡ } {B : ๐“ฆ ฬ‡ }
               โ†’ (X โ†’ B) โ†’ Lift ๐“ฅ X โ†’ B

Lift-recursion ๐“ฅ {X} {B} = Lift-induction ๐“ฅ X (ฮป _ โ†’ B)

lower-lift : {X : ๐“ค ฬ‡ } (x : X) โ†’ lower {๐“ค} {๐“ฅ} (lift x) โ‰ก x
lower-lift = refl

lift-lower : {X : ๐“ค ฬ‡ } (l : Lift ๐“ฅ X) โ†’ lift (lower l) โ‰ก l
lift-lower = refl

Lift-โ‰ƒ : (X : ๐“ค ฬ‡ ) โ†’ Lift ๐“ฅ X โ‰ƒ X
Lift-โ‰ƒ {๐“ค} {๐“ฅ} X = invertibility-gives-โ‰ƒ lower
                     (lift , lift-lower , lower-lift {๐“ค} {๐“ฅ})

โ‰ƒ-Lift : (X : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ Lift ๐“ฅ X
โ‰ƒ-Lift {๐“ค} {๐“ฅ} X = invertibility-gives-โ‰ƒ lift
                     (lower , lower-lift {๐“ค} {๐“ฅ} , lift-lower)

lower-dfunext : โˆ€ ๐“ฆ ๐“ฃ ๐“ค ๐“ฅ โ†’ dfunext (๐“ค โŠ” ๐“ฆ) (๐“ฅ โŠ” ๐“ฃ) โ†’ dfunext ๐“ค ๐“ฅ
lower-dfunext ๐“ฆ ๐“ฃ ๐“ค ๐“ฅ fe {X} {A} {f} {g} h = p
 where
  A' : Lift ๐“ฆ X โ†’ ๐“ฅ โŠ” ๐“ฃ ฬ‡
  A' y = Lift ๐“ฃ (A (lower y))

  f' g' : ฮ  A'
  f' y = lift (f (lower y))
  g' y = lift (g (lower y))

  h' : f' โˆผ g'
  h' y = ap lift (h (lower y))

  p' : f' โ‰ก g'
  p' = fe h'

  p : f โ‰ก g
  p = ap (ฮป f' x โ†’ lower (f' (lift x))) p'

universe-embedding-criterion : is-univalent ๐“ค
                             โ†’ is-univalent (๐“ค โŠ” ๐“ฅ)
                             โ†’ (f : ๐“ค ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡ )
                             โ†’ ((X : ๐“ค ฬ‡ ) โ†’ f X โ‰ƒ X)
                             โ†’ is-embedding f

universe-embedding-criterion {๐“ค} {๐“ฅ} ua ua' f e = embedding-criterion f ฮณ
 where
  fe : dfunext (๐“ค โŠ” ๐“ฅ) (๐“ค โŠ” ๐“ฅ)
  fe = univalence-gives-dfunext ua'

  feโ‚€ : dfunext ๐“ค ๐“ค
  feโ‚€ = lower-dfunext ๐“ฅ ๐“ฅ ๐“ค ๐“ค fe

  feโ‚ : dfunext ๐“ค (๐“ค โŠ” ๐“ฅ)
  feโ‚ = lower-dfunext ๐“ฅ ๐“ฅ ๐“ค (๐“ค โŠ” ๐“ฅ) fe

  ฮณ : (X X' : ๐“ค ฬ‡ ) โ†’ (f X โ‰ก f X') โ‰ƒ (X โ‰ก X')
  ฮณ X X' =  (f X โ‰ก f X')  โ‰ƒโŸจ i   โŸฉ
            (f X โ‰ƒ f X')  โ‰ƒโŸจ ii  โŸฉ
            (X โ‰ƒ X')      โ‰ƒโŸจ iii โŸฉ
            (X โ‰ก X')      โ– 
   where
    i   = univalence-โ‰ƒ ua' (f X) (f X')
    ii  = Eq-Eq-cong' fe fe fe fe fe feโ‚€ feโ‚ fe feโ‚€ feโ‚€ feโ‚€ feโ‚€ (e X) (e X')
    iii = โ‰ƒ-sym (univalence-โ‰ƒ ua X X')

Lift-is-embedding : is-univalent ๐“ค โ†’ is-univalent (๐“ค โŠ” ๐“ฅ)
                  โ†’ is-embedding (Lift {๐“ค} ๐“ฅ)

Lift-is-embedding {๐“ค} {๐“ฅ} ua ua' = universe-embedding-criterion {๐“ค} {๐“ฅ} ua ua'
                                    (Lift ๐“ฅ) Lift-โ‰ƒ

module _ {๐“ค ๐“ฅ : Universe}
         (ua : is-univalent ๐“ฅ)
         (ua' : is-univalent (๐“ค โŠ” ๐“ฅ))
 where

 private
  fe : dfunext (๐“ค โŠ” ๐“ฅ) (๐“ค โŠ” ๐“ฅ)
  fe = univalence-gives-dfunext ua'

  feโ‚€ : dfunext ๐“ฅ (๐“ค โŠ” ๐“ฅ)
  feโ‚€ = lower-dfunext ๐“ค ๐“ค ๐“ฅ (๐“ค โŠ” ๐“ฅ) fe

  feโ‚ : dfunext ๐“ค (๐“ค โŠ” ๐“ฅ)
  feโ‚ = lower-dfunext (๐“ค โŠ” ๐“ฅ) ๐“ค ๐“ค (๐“ค โŠ” ๐“ฅ) fe

  feโ‚‚ : dfunext ๐“ฅ ๐“ฅ
  feโ‚‚ = lower-dfunext ๐“ค ๐“ค ๐“ฅ ๐“ฅ fe

  feโ‚ƒ : dfunext ๐“ค ๐“ค
  feโ‚ƒ = lower-dfunext ๐“ฅ ๐“ฅ ๐“ค ๐“ค fe

 univalenceโ†’' : (X : ๐“ค ฬ‡ ) โ†’ is-subsingleton (ฮฃ Y ๊ž‰ ๐“ฅ ฬ‡ , X โ‰ƒ Y)
 univalenceโ†’' X = s
  where
   e : (Y : ๐“ฅ ฬ‡ ) โ†’ (X โ‰ƒ Y) โ‰ƒ (Lift ๐“ค Y โ‰ก Lift ๐“ฅ X)
   e Y = (X โ‰ƒ Y)                 โ‰ƒโŸจ i   โŸฉ
         (Y โ‰ƒ X)                 โ‰ƒโŸจ ii  โŸฉ
         (Lift ๐“ค Y โ‰ƒ Lift ๐“ฅ X)   โ‰ƒโŸจ iii โŸฉ
         (Lift ๐“ค Y โ‰ก Lift ๐“ฅ X)   โ– 
    where
     i   = โ‰ƒ-Sym feโ‚€ feโ‚ fe
     ii  = Eq-Eq-cong' feโ‚ fe feโ‚‚ feโ‚ fe fe fe feโ‚ƒ
             fe fe fe fe (โ‰ƒ-Lift Y) (โ‰ƒ-Lift X)
     iii = โ‰ƒ-sym (univalence-โ‰ƒ ua' (Lift ๐“ค Y) (Lift ๐“ฅ X))

   d : (ฮฃ Y ๊ž‰ ๐“ฅ ฬ‡ , X โ‰ƒ Y) โ‰ƒ (ฮฃ Y ๊ž‰ ๐“ฅ ฬ‡ , Lift ๐“ค Y โ‰ก Lift ๐“ฅ X)
   d = ฮฃ-cong e

   j : is-subsingleton (ฮฃ Y ๊ž‰ ๐“ฅ ฬ‡ , Lift ๐“ค Y โ‰ก Lift ๐“ฅ X)
   j = Lift-is-embedding ua ua' (Lift ๐“ฅ X)

   abstract
    s : is-subsingleton (ฮฃ Y ๊ž‰ ๐“ฅ ฬ‡ , X โ‰ƒ Y)
    s = equiv-to-subsingleton d j

 univalenceโ†’'-dual : (Y : ๐“ค ฬ‡ ) โ†’ is-subsingleton (ฮฃ X ๊ž‰ ๐“ฅ ฬ‡ , X โ‰ƒ Y)
 univalenceโ†’'-dual Y = equiv-to-subsingleton e i
  where
   e : (ฮฃ X ๊ž‰ ๐“ฅ ฬ‡ , X โ‰ƒ Y) โ‰ƒ (ฮฃ X ๊ž‰ ๐“ฅ ฬ‡ , Y โ‰ƒ X)
   e = ฮฃ-cong (ฮป X โ†’ โ‰ƒ-Sym feโ‚ feโ‚€ fe)

   i : is-subsingleton (ฮฃ X ๊ž‰ ๐“ฅ ฬ‡ , Y โ‰ƒ X)
   i = univalenceโ†’' Y

univalenceโ†’'' : is-univalent (๐“ค โŠ” ๐“ฅ)
              โ†’ (X : ๐“ค ฬ‡ ) โ†’ is-subsingleton (ฮฃ Y ๊ž‰ ๐“ค โŠ” ๐“ฅ ฬ‡ , X โ‰ƒ Y)

univalenceโ†’'' ua = univalenceโ†’' ua ua

univalenceโ†’''-dual : is-univalent (๐“ค โŠ” ๐“ฅ)
                   โ†’ (Y : ๐“ค ฬ‡ ) โ†’ is-subsingleton (ฮฃ X ๊ž‰ ๐“ค โŠ” ๐“ฅ ฬ‡ , X โ‰ƒ Y)

univalenceโ†’''-dual ua = univalenceโ†’'-dual ua ua

Gโ†‘-โ‰ƒ : is-univalent (๐“ค โŠ” ๐“ฅ)
     โ†’ (X : ๐“ค ฬ‡ ) (A : (ฮฃ Y ๊ž‰ ๐“ค โŠ” ๐“ฅ ฬ‡ , X โ‰ƒ Y) โ†’ ๐“ฆ ฬ‡ )
     โ†’ A (Lift ๐“ฅ X , โ‰ƒ-Lift X) โ†’ (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (e : X โ‰ƒ Y) โ†’ A (Y , e)

Gโ†‘-โ‰ƒ {๐“ค} {๐“ฅ} ua X A a Y e = transport A p a
 where
  t : ฮฃ Y ๊ž‰ ๐“ค โŠ” ๐“ฅ ฬ‡ , X โ‰ƒ Y
  t = (Lift ๐“ฅ X , โ‰ƒ-Lift X)

  p : t โ‰ก (Y , e)
  p = univalenceโ†’'' {๐“ค} {๐“ฅ} ua X t (Y , e)

Hโ†‘-โ‰ƒ : is-univalent (๐“ค โŠ” ๐“ฅ)
     โ†’ (X : ๐“ค ฬ‡ ) (A : (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฆ ฬ‡ )
     โ†’ A (Lift ๐“ฅ X) (โ‰ƒ-Lift X) โ†’ (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (e : X โ‰ƒ Y) โ†’ A Y e

Hโ†‘-โ‰ƒ ua X A = Gโ†‘-โ‰ƒ ua X (ฮฃ-induction A)

Jโ†‘-โ‰ƒ : is-univalent (๐“ค โŠ” ๐“ฅ)
     โ†’ (A : (X : ๐“ค ฬ‡ ) (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฆ ฬ‡ )
     โ†’ ((X : ๐“ค ฬ‡ ) โ†’ A X (Lift ๐“ฅ X) (โ‰ƒ-Lift X))
     โ†’ (X : ๐“ค ฬ‡ ) (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (e : X โ‰ƒ Y) โ†’ A X Y e

Jโ†‘-โ‰ƒ ua A ฯ† X = Hโ†‘-โ‰ƒ ua X (A X) (ฯ† X)

Hโ†‘-equiv : is-univalent (๐“ค โŠ” ๐“ฅ)
         โ†’ (X : ๐“ค ฬ‡ ) (A : (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) โ†’ (X โ†’ Y) โ†’ ๐“ฆ ฬ‡ )
         โ†’ A (Lift ๐“ฅ X) lift โ†’ (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (f : X โ†’ Y) โ†’ is-equiv f โ†’ A Y f

Hโ†‘-equiv {๐“ค} {๐“ฅ} {๐“ฆ} ua X A a Y f i = ฮณ (f , i)
 where
  B : (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฆ ฬ‡
  B Y (f , i) = A Y f

  b : B (Lift ๐“ฅ X) (โ‰ƒ-Lift X)
  b = a

  ฮณ : (e : X โ‰ƒ Y) โ†’ B Y e
  ฮณ = Hโ†‘-โ‰ƒ ua X B b Y

Jโ†‘-equiv : is-univalent (๐“ค โŠ” ๐“ฅ)
         โ†’ (A : (X : ๐“ค ฬ‡ ) (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) โ†’ (X โ†’ Y) โ†’ ๐“ฆ ฬ‡ )
         โ†’ ((X : ๐“ค ฬ‡ ) โ†’ A X (Lift ๐“ฅ X) lift)
         โ†’ (X : ๐“ค ฬ‡ ) (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (f : X โ†’ Y) โ†’ is-equiv f โ†’ A X Y f

Jโ†‘-equiv ua A ฯ† X = Hโ†‘-equiv ua X (A X) (ฯ† X)

Jโ†‘-invertible : is-univalent (๐“ค โŠ” ๐“ฅ)
              โ†’ (A : (X : ๐“ค ฬ‡ ) (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) โ†’ (X โ†’ Y) โ†’ ๐“ฆ ฬ‡ )
              โ†’ ((X : ๐“ค ฬ‡ ) โ†’ A X (Lift ๐“ฅ X) lift)
              โ†’ (X : ๐“ค ฬ‡ ) (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (f : X โ†’ Y) โ†’ invertible f โ†’ A X Y f

Jโ†‘-invertible ua A ฯ† X Y f i = Jโ†‘-equiv ua A ฯ† X Y f (invertibles-are-equivs f i)

lift-is-hae : (X : ๐“ค ฬ‡ ) โ†’ is-hae {๐“ค} {๐“ค โŠ” ๐“ฅ} {X} {Lift ๐“ฅ X} (lift {๐“ค} {๐“ฅ})
lift-is-hae {๐“ค} {๐“ฅ} X = lower ,
                        lower-lift {๐“ค} {๐“ฅ} ,
                        lift-lower ,
                        ฮป x โ†’ refl (refl (lift x))

equivs-are-haesโ†‘ : is-univalent (๐“ค โŠ” ๐“ฅ)
                 โ†’ {X : ๐“ค ฬ‡ } {Y : ๐“ค โŠ” ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                 โ†’ is-equiv f โ†’ is-hae f

equivs-are-haesโ†‘ {๐“ค} {๐“ฅ} ua {X} {Y} = Jโ†‘-equiv {๐“ค} {๐“ฅ} ua (ฮป X Y f โ†’ is-hae f)
                                       lift-is-hae X Y

Gโ†“-โ‰ƒ : is-univalent (๐“ค โŠ” ๐“ฅ)
     โ†’ (Y : ๐“ค ฬ‡ ) (A : (ฮฃ X ๊ž‰ ๐“ค โŠ” ๐“ฅ ฬ‡ , X โ‰ƒ Y) โ†’ ๐“ฆ ฬ‡ )
     โ†’ A (Lift ๐“ฅ Y , Lift-โ‰ƒ Y) โ†’ (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (e : X โ‰ƒ Y) โ†’ A (X , e)

Gโ†“-โ‰ƒ {๐“ค} {๐“ฅ} ua Y A a X e = transport A p a
 where
  t : ฮฃ X ๊ž‰ ๐“ค โŠ” ๐“ฅ ฬ‡ , X โ‰ƒ Y
  t = (Lift ๐“ฅ Y , Lift-โ‰ƒ Y)

  p : t โ‰ก (X , e)
  p = univalenceโ†’'-dual {๐“ค} {๐“ค โŠ” ๐“ฅ} ua ua Y t (X , e)

Hโ†“-โ‰ƒ : is-univalent (๐“ค โŠ” ๐“ฅ)
     โ†’ (Y : ๐“ค ฬ‡ ) (A : (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฆ ฬ‡ )
     โ†’ A (Lift ๐“ฅ Y) (Lift-โ‰ƒ Y) โ†’ (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (e : X โ‰ƒ Y) โ†’ A X e

Hโ†“-โ‰ƒ ua Y A = Gโ†“-โ‰ƒ ua Y (ฮฃ-induction A)

Jโ†“-โ‰ƒ : is-univalent (๐“ค โŠ” ๐“ฅ)
     โ†’ (A : (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (Y : ๐“ค ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฆ ฬ‡ )
     โ†’ ((Y : ๐“ค ฬ‡ ) โ†’ A (Lift ๐“ฅ Y) Y (Lift-โ‰ƒ Y))
     โ†’ (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (Y : ๐“ค ฬ‡ ) (e : X โ‰ƒ Y) โ†’ A X Y e

Jโ†“-โ‰ƒ ua A ฯ† X Y = Hโ†“-โ‰ƒ ua Y (ฮป X โ†’ A X Y) (ฯ† Y) X

Hโ†“-equiv : is-univalent (๐“ค โŠ” ๐“ฅ)
         โ†’ (Y : ๐“ค ฬ‡ ) (A : (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) โ†’ (X โ†’ Y) โ†’ ๐“ฆ ฬ‡ )
         โ†’ A (Lift ๐“ฅ Y) lower โ†’ (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (f : X โ†’ Y) โ†’ is-equiv f โ†’ A X f

Hโ†“-equiv {๐“ค} {๐“ฅ} {๐“ฆ} ua Y A a X f i = ฮณ (f , i)
 where
  B : (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฆ ฬ‡
  B X (f , i) = A X f

  b : B (Lift ๐“ฅ Y) (Lift-โ‰ƒ Y)
  b = a

  ฮณ : (e : X โ‰ƒ Y) โ†’ B X e
  ฮณ = Hโ†“-โ‰ƒ ua Y B b X

Jโ†“-equiv : is-univalent (๐“ค โŠ” ๐“ฅ)
         โ†’ (A : (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (Y : ๐“ค ฬ‡ ) โ†’ (X โ†’ Y) โ†’ ๐“ฆ ฬ‡ )
         โ†’ ((Y : ๐“ค ฬ‡ ) โ†’ A (Lift ๐“ฅ Y) Y lower)
         โ†’ (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (Y : ๐“ค ฬ‡ ) (f : X โ†’ Y) โ†’ is-equiv f โ†’ A X Y f

Jโ†“-equiv ua A ฯ† X Y = Hโ†“-equiv ua Y (ฮป X โ†’ A X Y) (ฯ† Y) X

Jโ†“-invertible : is-univalent (๐“ค โŠ” ๐“ฅ)
              โ†’ (A : (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (Y : ๐“ค ฬ‡ ) โ†’ (X โ†’ Y) โ†’ ๐“ฆ ฬ‡ )
              โ†’ ((Y : ๐“ค ฬ‡ ) โ†’ A (Lift ๐“ฅ Y) Y lower)
              โ†’ (X : ๐“ค โŠ” ๐“ฅ ฬ‡ ) (Y : ๐“ค ฬ‡ ) (f : X โ†’ Y) โ†’ invertible f โ†’ A X Y f

Jโ†“-invertible ua A ฯ† X Y f i = Jโ†“-equiv ua A ฯ† X Y f (invertibles-are-equivs f i)

lower-is-hae : (X : ๐“ค ฬ‡ ) โ†’ is-hae (lower {๐“ค} {๐“ฅ} {X})
lower-is-hae {๐“ค} {๐“ฅ} X = lift ,
                         lift-lower ,
                         lower-lift {๐“ค} {๐“ฅ} ,
                         (ฮป x โ†’ refl (refl (lower x)))

equivs-are-haesโ†“ : is-univalent (๐“ค โŠ” ๐“ฅ)
                 โ†’ {X : ๐“ค โŠ” ๐“ฅ ฬ‡ } {Y : ๐“ค ฬ‡ } (f : X โ†’ Y)
                 โ†’ is-equiv f โ†’ is-hae f

equivs-are-haesโ†“ {๐“ค} {๐“ฅ} ua {X} {Y} = Jโ†“-equiv {๐“ค} {๐“ฅ} ua (ฮป X Y f โ†’ is-hae f)
                                       lower-is-hae X Y

Idโ†’Eq-is-hae' : is-univalent ๐“ค โ†’ is-univalent (๐“ค โบ)
              โ†’ {X Y : ๐“ค ฬ‡ } โ†’ is-hae (Idโ†’Eq X Y)

Idโ†’Eq-is-hae' ua uaโบ {X} {Y} = equivs-are-haesโ†“ uaโบ (Idโ†’Eq X Y) (ua X Y)

Idโ†’Eq-is-hae : is-univalent ๐“ค
             โ†’ {X Y : ๐“ค ฬ‡ } โ†’ is-hae (Idโ†’Eq X Y)

Idโ†’Eq-is-hae ua {X} {Y} = invertibles-are-haes (Idโ†’Eq X Y)
                           (equivs-are-invertible (Idโ†’Eq X Y) (ua X Y))

global-property-of-types : ๐“คฯ‰
global-property-of-types = {๐“ค : Universe} โ†’ ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡

cumulative : global-property-of-types โ†’ ๐“คฯ‰
cumulative A = {๐“ค ๐“ฅ : Universe} (X : ๐“ค ฬ‡ ) โ†’ A X โ‰ƒ A (Lift ๐“ฅ X)

global-โ‰ƒ-ap : Univalence
            โ†’ (A : global-property-of-types)
            โ†’ cumulative A
            โ†’ (X : ๐“ค ฬ‡ ) (Y : ๐“ฅ ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ A X โ‰ƒ A Y

global-โ‰ƒ-ap' : Univalence
             โ†’ (F : Universe โ†’ Universe)
             โ†’ (A : {๐“ค : Universe} โ†’ ๐“ค ฬ‡ โ†’ (F ๐“ค) ฬ‡ )
             โ†’ ({๐“ค ๐“ฅ : Universe} (X : ๐“ค ฬ‡ ) โ†’ A X โ‰ƒ A (Lift ๐“ฅ X))
             โ†’ (X : ๐“ค ฬ‡ ) (Y : ๐“ฅ ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ A X โ‰ƒ A Y

global-โ‰ƒ-ap' {๐“ค} {๐“ฅ} ua F A ฯ† X Y e =

  A X          โ‰ƒโŸจ ฯ† X                                   โŸฉ
  A (Lift ๐“ฅ X) โ‰ƒโŸจ Idโ†’Eq (A (Lift ๐“ฅ X)) (A (Lift ๐“ค Y)) q โŸฉ
  A (Lift ๐“ค Y) โ‰ƒโŸจ โ‰ƒ-sym (ฯ† Y)                           โŸฉ
  A Y          โ– 
 where
  d : Lift ๐“ฅ X โ‰ƒ Lift ๐“ค Y
  d = Lift ๐“ฅ X โ‰ƒโŸจ Lift-โ‰ƒ X         โŸฉ
      X        โ‰ƒโŸจ e                โŸฉ
      Y        โ‰ƒโŸจ โ‰ƒ-sym (Lift-โ‰ƒ Y) โŸฉ
      Lift ๐“ค Y โ– 

  p : Lift ๐“ฅ X โ‰ก Lift ๐“ค Y
  p = Eqโ†’Id (ua (๐“ค โŠ” ๐“ฅ)) (Lift ๐“ฅ X) (Lift ๐“ค Y) d

  q : A (Lift ๐“ฅ X) โ‰ก A (Lift ๐“ค Y)
  q = ap A p

global-โ‰ƒ-ap ua = global-โ‰ƒ-ap' ua id

Subtype : ๐“ค ฬ‡ โ†’ ๐“ค โบ ฬ‡
Subtype {๐“ค} Y = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , X โ†ช Y

_/[_]_ : (๐“ค : Universe) โ†’ (๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค ฬ‡ โ†’ ๐“ค โบ โŠ” ๐“ฅ ฬ‡
๐“ค /[ P ] Y = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ f ๊ž‰ (X โ†’ Y) , ((y : Y) โ†’ P (fiber f y))

ฯ‡-special : (P : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ ) (Y : ๐“ค ฬ‡ ) โ†’ ๐“ค /[ P ] Y  โ†’ (Y โ†’ ฮฃ P)
ฯ‡-special P Y (X , f , ฯ†) y = fiber f y , ฯ† y

is-special-map-classifier : (๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โบ โŠ” ๐“ฅ ฬ‡
is-special-map-classifier {๐“ค} P = (Y : ๐“ค ฬ‡ ) โ†’ is-equiv (ฯ‡-special P Y)

mc-gives-sc : is-map-classifier ๐“ค
            โ†’ (P : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ ) โ†’ is-special-map-classifier P

mc-gives-sc {๐“ค} s P Y = ฮณ
 where
  e = (๐“ค /[ P ] Y)                               โ‰ƒโŸจ โ‰ƒ-sym a โŸฉ
      (ฮฃ ฯƒ ๊ž‰ ๐“ค / Y , ((y : Y) โ†’ P ((ฯ‡ Y) ฯƒ y)))  โ‰ƒโŸจ โ‰ƒ-sym b โŸฉ
      (ฮฃ A ๊ž‰ (Y โ†’ ๐“ค ฬ‡ ), ((y : Y) โ†’ P (A y)))     โ‰ƒโŸจ โ‰ƒ-sym c โŸฉ
      (Y โ†’ ฮฃ P)                                  โ– 
   where
    a = ฮฃ-assoc
    b = ฮฃ-change-of-variable (ฮป A โ†’ ฮ  (P โˆ˜ A)) (ฯ‡ Y) (s Y)
    c = ฮ ฮฃ-distr-โ‰ƒ

  observation : ฯ‡-special P Y โ‰ก โŒœ e โŒ
  observation = refl _

  ฮณ : is-equiv (ฯ‡-special P Y)
  ฮณ = โŒœโŒ-is-equiv e

ฯ‡-special-is-equiv : is-univalent ๐“ค
                   โ†’ dfunext ๐“ค (๐“ค โบ)
                   โ†’ (P : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ ) (Y : ๐“ค ฬ‡ )
                   โ†’ is-equiv (ฯ‡-special P Y)

ฯ‡-special-is-equiv {๐“ค} ua fe P Y = mc-gives-sc (universes-are-map-classifiers ua fe) P Y

special-map-classifier : is-univalent ๐“ค
                       โ†’ dfunext ๐“ค (๐“ค โบ)
                       โ†’ (P : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ ) (Y : ๐“ค ฬ‡ )
                       โ†’ ๐“ค /[ P ] Y โ‰ƒ (Y โ†’ ฮฃ P)

special-map-classifier {๐“ค} ua fe P Y = ฯ‡-special P Y , ฯ‡-special-is-equiv ua fe P Y

ฮฉ-is-subtype-classifier : Univalence
                        โ†’ (Y : ๐“ค ฬ‡ ) โ†’ Subtype Y โ‰ƒ (Y โ†’ ฮฉ ๐“ค)

ฮฉ-is-subtype-classifier {๐“ค} ua = special-map-classifier (ua ๐“ค)
                                  (univalence-gives-dfunext' (ua ๐“ค) (ua (๐“ค โบ)))
                                  is-subsingleton

subtypes-form-set : Univalence โ†’ (Y : ๐“ค ฬ‡ ) โ†’ is-set (Subtype Y)
subtypes-form-set {๐“ค} ua Y = equiv-to-set
                              (ฮฉ-is-subtype-classifier ua Y)
                              (powersets-are-sets' ua)

๐“ข : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
๐“ข ๐“ค = ฮฃ S ๊ž‰ ๐“ค ฬ‡ , is-singleton S

equiv-classification : Univalence
                     โ†’ (Y : ๐“ค ฬ‡ ) โ†’ (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , X โ‰ƒ Y) โ‰ƒ (Y โ†’ ๐“ข ๐“ค)

equiv-classification {๐“ค} ua = special-map-classifier (ua ๐“ค)
                               (univalence-gives-dfunext' (ua ๐“ค) (ua (๐“ค โบ)))
                               is-singleton

the-singletons-form-a-singleton : propext ๐“ค โ†’ dfunext ๐“ค ๐“ค โ†’ is-singleton (๐“ข ๐“ค)
the-singletons-form-a-singleton {๐“ค} pe fe = c , ฯ†
 where
  i : is-singleton (Lift ๐“ค ๐Ÿ™)
  i = equiv-to-singleton (Lift-โ‰ƒ ๐Ÿ™) ๐Ÿ™-is-singleton

  c : ๐“ข ๐“ค
  c = Lift ๐“ค ๐Ÿ™ , i

  ฯ† : (x : ๐“ข ๐“ค) โ†’ c โ‰ก x
  ฯ† (S , s) = to-subtype-โ‰ก (ฮป _ โ†’ being-singleton-is-subsingleton fe) p
   where
    p : Lift ๐“ค ๐Ÿ™ โ‰ก S
    p = pe (singletons-are-subsingletons (Lift ๐“ค ๐Ÿ™) i)
           (singletons-are-subsingletons S s)
           (ฮป _ โ†’ center S s) (ฮป _ โ†’ center (Lift ๐“ค ๐Ÿ™) i)

univalenceโ†’-again : Univalence
                  โ†’ (Y : ๐“ค ฬ‡ ) โ†’ is-singleton (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , X โ‰ƒ Y)

univalenceโ†’-again {๐“ค} ua Y = equiv-to-singleton (equiv-classification ua Y) i
 where
  i : is-singleton (Y โ†’ ๐“ข ๐“ค)
  i = univalence-gives-vvfunext' (ua ๐“ค) (ua (๐“ค โบ))
        (ฮป y โ†’ the-singletons-form-a-singleton
                (univalence-gives-propext (ua ๐“ค))
                (univalence-gives-dfunext (ua ๐“ค)))

module magma-equivalences (ua : Univalence) where

 open magmas

 dfe : global-dfunext
 dfe = univalence-gives-global-dfunext ua

 hfe : global-hfunext
 hfe = univalence-gives-global-hfunext ua

 being-magma-hom-is-subsingleton : (M N : Magma ๐“ค) (f : โŸจ M โŸฉ โ†’ โŸจ N โŸฉ)
                                 โ†’ is-subsingleton (is-magma-hom M N f)

 being-magma-hom-is-subsingleton M N f =

  ฮ -is-subsingleton dfe
   (ฮป x โ†’ ฮ -is-subsingleton dfe
   (ฮป y โ†’ magma-is-set N (f (x ยทโŸจ M โŸฉ y)) (f x ยทโŸจ N โŸฉ f y)))

 being-magma-iso-is-subsingleton : (M N : Magma ๐“ค) (f : โŸจ M โŸฉ โ†’ โŸจ N โŸฉ)
                                 โ†’ is-subsingleton (is-magma-iso M N f)

 being-magma-iso-is-subsingleton M N f (h , g , k , ฮท , ฮต) (h' , g' , k' , ฮท' , ฮต') = ฮณ
  where
   p : h โ‰ก h'
   p = being-magma-hom-is-subsingleton M N f h h'

   q : g โ‰ก g'
   q = dfe (ฮป y โ†’ g y          โ‰กโŸจ (ap g (ฮต' y))โปยน โŸฉ
                  g (f (g' y)) โ‰กโŸจ ฮท (g' y)        โŸฉ
                  g' y         โˆŽ)

   i : is-subsingleton (is-magma-hom N M g' ร— (g' โˆ˜ f โˆผ id) ร— (f โˆ˜ g' โˆผ id))
   i = ร—-is-subsingleton
         (being-magma-hom-is-subsingleton N M g')
         (ร—-is-subsingleton
            (ฮ -is-subsingleton dfe (ฮป x โ†’ magma-is-set M (g' (f x)) x))
            (ฮ -is-subsingleton dfe (ฮป y โ†’ magma-is-set N (f (g' y)) y)))

   ฮณ : (h , g , k , ฮท , ฮต) โ‰ก (h' , g' , k' , ฮท' , ฮต')
   ฮณ = to-ร—-โ‰ก (p , to-ฮฃ-โ‰ก (q , i _ _))

 is-magma-equiv : (M N : Magma ๐“ค) โ†’ (โŸจ M โŸฉ โ†’ โŸจ N โŸฉ) โ†’ ๐“ค ฬ‡
 is-magma-equiv M N f = is-equiv f ร— is-magma-hom M N f

 being-magma-equiv-is-subsingleton : (M N : Magma ๐“ค) (f : โŸจ M โŸฉ โ†’ โŸจ N โŸฉ)
                                   โ†’ is-subsingleton (is-magma-equiv M N f)

 being-magma-equiv-is-subsingleton M N f =
  ร—-is-subsingleton
   (being-equiv-is-subsingleton dfe dfe f)
   (being-magma-hom-is-subsingleton M N f)

 magma-isos-are-magma-equivs : (M N : Magma ๐“ค) (f : โŸจ M โŸฉ โ†’ โŸจ N โŸฉ)
                             โ†’ is-magma-iso M N f
                             โ†’ is-magma-equiv M N f

 magma-isos-are-magma-equivs M N f (h , g , k , ฮท , ฮต) = i , h
  where
   i : is-equiv f
   i = invertibles-are-equivs f (g , ฮท , ฮต)

 magma-equivs-are-magma-isos : (M N : Magma ๐“ค) (f : โŸจ M โŸฉ โ†’ โŸจ N โŸฉ)
                             โ†’ is-magma-equiv M N f
                             โ†’ is-magma-iso M N f

 magma-equivs-are-magma-isos M N f (i , h) = h , g , k , ฮท , ฮต
  where
   g : โŸจ N โŸฉ โ†’ โŸจ M โŸฉ
   g = inverse f i

   ฮท : g โˆ˜ f โˆผ id
   ฮท = inverses-are-retractions f i

   ฮต : f โˆ˜ g โˆผ id
   ฮต = inverses-are-sections f i

   k : (a b : โŸจ N โŸฉ) โ†’ g (a ยทโŸจ N โŸฉ b) โ‰ก g a ยทโŸจ M โŸฉ g b
   k a b = g (a ยทโŸจ N โŸฉ b)             โ‰กโŸจ apโ‚‚ (ฮป a b โ†’ g (a ยทโŸจ N โŸฉ b)) ((ฮต a)โปยน)
                                             ((ฮต b)โปยน)                          โŸฉ
           g (f (g a) ยทโŸจ N โŸฉ f (g b)) โ‰กโŸจ ap g ((h (g a) (g b))โปยน)               โŸฉ
           g (f (g a ยทโŸจ M โŸฉ g b))     โ‰กโŸจ ฮท (g a ยทโŸจ M โŸฉ g b)                     โŸฉ
           g a ยทโŸจ M โŸฉ g b             โˆŽ

 magma-iso-charac : (M N : Magma ๐“ค) (f : โŸจ M โŸฉ โ†’ โŸจ N โŸฉ)
                  โ†’ is-magma-iso M N f โ‰ƒ is-magma-equiv M N f

 magma-iso-charac M N f = logically-equivalent-subsingletons-are-equivalent
                           (is-magma-iso M N f)
                           (is-magma-equiv M N f)
                           (being-magma-iso-is-subsingleton M N f)
                           (being-magma-equiv-is-subsingleton M N f)
                           (magma-isos-are-magma-equivs M N f ,
                            magma-equivs-are-magma-isos M N f)

 magma-iso-charac' : (M N : Magma ๐“ค) (f : โŸจ M โŸฉ โ†’ โŸจ N โŸฉ)
                   โ†’ is-magma-iso M N f โ‰ก is-magma-equiv M N f

 magma-iso-charac' M N f = Eqโ†’Id (ua (universe-of โŸจ M โŸฉ))
                            (is-magma-iso M N f)
                            (is-magma-equiv M N f)
                            (magma-iso-charac M N f)

 magma-iso-charac'' : (M N : Magma ๐“ค)
                    โ†’ is-magma-iso M N โ‰ก is-magma-equiv M N

 magma-iso-charac'' M N = dfe (magma-iso-charac' M N)

 _โ‰ƒโ‚˜_ : Magma ๐“ค โ†’ Magma ๐“ค โ†’ ๐“ค ฬ‡
 M โ‰ƒโ‚˜ N = ฮฃ f ๊ž‰ (โŸจ M โŸฉ โ†’ โŸจ N โŸฉ), is-magma-equiv M N f

 โ‰…โ‚˜-charac : (M N : Magma ๐“ค)
           โ†’ (M โ‰…โ‚˜ N) โ‰ƒ (M โ‰ƒโ‚˜ N)

 โ‰…โ‚˜-charac M N = ฮฃ-cong (magma-iso-charac M N)

 โ‰…โ‚˜-charac' : (M N : Magma ๐“ค)
            โ†’ (M โ‰…โ‚˜ N) โ‰ก (M โ‰ƒโ‚˜ N)

 โ‰…โ‚˜-charac' M N = ap ฮฃ (magma-iso-charac'' M N)

module sip where

 โŸจ_โŸฉ : {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } โ†’ ฮฃ S โ†’ ๐“ค ฬ‡
 โŸจ X , s โŸฉ = X

 structure : {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } (A : ฮฃ S) โ†’ S โŸจ A โŸฉ
 structure (X , s) = s

 canonical-map : {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ }
                 (ฮน : (A B : ฮฃ S) โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ฆ ฬ‡ )
                 (ฯ : (A : ฮฃ S) โ†’ ฮน A A (id-โ‰ƒ โŸจ A โŸฉ))
                 {X : ๐“ค ฬ‡ }
                 (s t : S X)

               โ†’ s โ‰ก t โ†’ ฮน (X , s) (X , t) (id-โ‰ƒ X)

 canonical-map ฮน ฯ {X} s s (refl s) = ฯ (X , s)

 SNS : (๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ ) โ†’ (๐“ฆ : Universe) โ†’ ๐“ค โบ โŠ” ๐“ฅ โŠ” (๐“ฆ โบ) ฬ‡

 SNS {๐“ค} {๐“ฅ} S ๐“ฆ = ฮฃ ฮน ๊ž‰ ((A B : ฮฃ S) โ†’ (โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ฆ ฬ‡ ))
                  , ฮฃ ฯ ๊ž‰ ((A : ฮฃ S) โ†’ ฮน A A (id-โ‰ƒ โŸจ A โŸฉ))
                  , ({X : ๐“ค ฬ‡ } (s t : S X) โ†’ is-equiv (canonical-map ฮน ฯ s t))

 homomorphic : {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } โ†’ SNS S ๐“ฆ
             โ†’ (A B : ฮฃ S) โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ฆ ฬ‡

 homomorphic (ฮน , ฯ , ฮธ) = ฮน

 _โ‰ƒ[_]_ : {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } โ†’ ฮฃ S โ†’ SNS S ๐“ฆ โ†’ ฮฃ S โ†’ ๐“ค โŠ” ๐“ฆ ฬ‡

 A โ‰ƒ[ ฯƒ ] B = ฮฃ f ๊ž‰ (โŸจ A โŸฉ โ†’ โŸจ B โŸฉ)
            , ฮฃ i ๊ž‰ is-equiv f
            , homomorphic ฯƒ A B (f , i)

 Idโ†’homEq : {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } (ฯƒ : SNS S ๐“ฆ)
          โ†’ (A B : ฮฃ S) โ†’ (A โ‰ก B) โ†’ (A โ‰ƒ[ ฯƒ ] B)

 Idโ†’homEq (_ , ฯ , _) A A (refl A) = id , id-is-equiv โŸจ A โŸฉ , ฯ A

 homomorphism-lemma : {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } (ฯƒ : SNS S ๐“ฆ)
                      (A B : ฮฃ S) (p : โŸจ A โŸฉ โ‰ก โŸจ B โŸฉ)
                    โ†’
                      (transport S p (structure A) โ‰ก structure B)
                    โ‰ƒ  homomorphic ฯƒ A B (Idโ†’Eq โŸจ A โŸฉ โŸจ B โŸฉ p)

 homomorphism-lemma (ฮน , ฯ , ฮธ) (X , s) (X , t) (refl X) = ฮณ
  where
   ฮณ : (s โ‰ก t) โ‰ƒ ฮน (X , s) (X , t) (id-โ‰ƒ X)
   ฮณ = (canonical-map ฮน ฯ s t , ฮธ s t)

 characterization-of-โ‰ก : is-univalent ๐“ค
                       โ†’ {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } (ฯƒ : SNS S ๐“ฆ)
                       โ†’ (A B : ฮฃ S)

                       โ†’ (A โ‰ก B) โ‰ƒ (A โ‰ƒ[ ฯƒ ] B)

 characterization-of-โ‰ก ua {S} ฯƒ A B =

    (A โ‰ก B)                                                           โ‰ƒโŸจ i   โŸฉ
    (ฮฃ p ๊ž‰ โŸจ A โŸฉ โ‰ก โŸจ B โŸฉ , transport S p (structure A) โ‰ก structure B) โ‰ƒโŸจ ii  โŸฉ
    (ฮฃ p ๊ž‰ โŸจ A โŸฉ โ‰ก โŸจ B โŸฉ , ฮน A B (Idโ†’Eq โŸจ A โŸฉ โŸจ B โŸฉ p))               โ‰ƒโŸจ iii โŸฉ
    (ฮฃ e ๊ž‰ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ , ฮน A B e)                                   โ‰ƒโŸจ iv  โŸฉ
    (A โ‰ƒ[ ฯƒ ] B)                                                      โ– 

  where
   ฮน   = homomorphic ฯƒ

   i   = ฮฃ-โ‰ก-โ‰ƒ A B
   ii  = ฮฃ-cong (homomorphism-lemma ฯƒ A B)
   iii = โ‰ƒ-sym (ฮฃ-change-of-variable (ฮน A B) (Idโ†’Eq โŸจ A โŸฉ โŸจ B โŸฉ) (ua โŸจ A โŸฉ โŸจ B โŸฉ))
   iv  = ฮฃ-assoc

 Idโ†’homEq-is-equiv : (ua : is-univalent ๐“ค) {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } (ฯƒ : SNS S ๐“ฆ)
                   โ†’ (A B : ฮฃ S) โ†’ is-equiv (Idโ†’homEq ฯƒ A B)

 Idโ†’homEq-is-equiv ua {S} ฯƒ A B = ฮณ
  where
   h : (A B : ฮฃ S) โ†’ Idโ†’homEq ฯƒ A B โˆผ โŒœ characterization-of-โ‰ก ua ฯƒ A B โŒ
   h A A (refl A) = refl _

   ฮณ : is-equiv (Idโ†’homEq ฯƒ A B)
   ฮณ = equivs-closed-under-โˆผ
       (โŒœโŒ-is-equiv (characterization-of-โ‰ก ua ฯƒ A B))
       (h A B)

 module _ {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ }
          (ฮน : (A B : ฮฃ S) โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ฆ ฬ‡ )
          (ฯ : (A : ฮฃ S) โ†’ ฮน A A (id-โ‰ƒ โŸจ A โŸฉ))
          {X : ๐“ค ฬ‡ }

        where

  canonical-map-charac : (s t : S X) (p : s โ‰ก t)

                       โ†’ canonical-map ฮน ฯ s t p
                       โ‰ก transport (ฮป - โ†’ ฮน (X , s) (X , -) (id-โ‰ƒ X)) p (ฯ (X , s))

  canonical-map-charac s = transport-lemma (ฮป t โ†’ ฮน (X , s) (X , t) (id-โ‰ƒ X)) s
                            (canonical-map ฮน ฯ s)

  when-canonical-map-is-equiv : ((s t : S X) โ†’ is-equiv (canonical-map ฮน ฯ s t))
                              โ‡” ((s : S X) โ†’ โˆƒ! t ๊ž‰ S X , ฮน (X , s) (X , t) (id-โ‰ƒ X))

  when-canonical-map-is-equiv = (ฮป e s โ†’ fiberwise-equiv-universal (A s) s (ฯ„ s) (e s)) ,
                                (ฮป ฯ† s โ†’ universal-fiberwise-equiv (A s) (ฯ† s) s (ฯ„ s))
   where
    A = ฮป s t โ†’ ฮน (X , s) (X , t) (id-โ‰ƒ X)
    ฯ„ = canonical-map ฮน ฯ

  canonical-map-equiv-criterion : ((s t : S X) โ†’ (s โ‰ก t) โ‰ƒ ฮน (X , s) (X , t) (id-โ‰ƒ X))
                                โ†’ (s t : S X) โ†’ is-equiv (canonical-map ฮน ฯ s t)

  canonical-map-equiv-criterion ฯ† s = fiberwise-equiv-criterion'
                                       (ฮป t โ†’ ฮน (X , s) (X , t) (id-โ‰ƒ X))
                                       s (ฯ† s) (canonical-map ฮน ฯ s)

  canonical-map-equiv-criterion' : ((s t : S X) โ†’ ฮน (X , s) (X , t) (id-โ‰ƒ X) โ— (s โ‰ก t))
                                 โ†’ (s t : S X) โ†’ is-equiv (canonical-map ฮน ฯ s t)

  canonical-map-equiv-criterion' ฯ† s = fiberwise-equiv-criterion
                                        (ฮป t โ†’ ฮน (X , s) (X , t) (id-โ‰ƒ X))
                                        s (ฯ† s) (canonical-map ฮน ฯ s)

module โˆž-magma {๐“ค : Universe} where

 open sip

 โˆž-magma-structure : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
 โˆž-magma-structure X = X โ†’ X โ†’ X

 โˆž-Magma : ๐“ค โบ ฬ‡
 โˆž-Magma = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , โˆž-magma-structure X

 sns-data : SNS โˆž-magma-structure ๐“ค
 sns-data = (ฮน , ฯ , ฮธ)
  where
   ฮน : (A B : โˆž-Magma) โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ค ฬ‡
   ฮน (X , _ยท_) (Y , _*_) (f , _) = (ฮป x x' โ†’ f (x ยท x')) โ‰ก (ฮป x x' โ†’ f x * f x')

   ฯ : (A : โˆž-Magma) โ†’ ฮน A A (id-โ‰ƒ โŸจ A โŸฉ)
   ฯ (X , _ยท_) = refl _ยท_

   h : {X : ๐“ค ฬ‡ } {_ยท_ _*_ : โˆž-magma-structure X}
     โ†’ canonical-map ฮน ฯ _ยท_ _*_ โˆผ ๐‘–๐‘‘ (_ยท_ โ‰ก _*_)

   h (refl _ยท_) = refl (refl _ยท_)

   ฮธ : {X : ๐“ค ฬ‡ } (_ยท_ _*_ : โˆž-magma-structure X)
     โ†’ is-equiv (canonical-map ฮน ฯ _ยท_ _*_)

   ฮธ _ยท_ _*_ = equivs-closed-under-โˆผ (id-is-equiv (_ยท_ โ‰ก _*_)) h

 _โ‰…_ : โˆž-Magma โ†’ โˆž-Magma โ†’ ๐“ค ฬ‡

 (X , _ยท_) โ‰… (Y , _*_) =

           ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                        ร— ((ฮป x x' โ†’ f (x ยท x')) โ‰ก (ฮป x x' โ†’ f x * f x'))

 characterization-of-โˆž-Magma-โ‰ก : is-univalent ๐“ค โ†’ (A B : โˆž-Magma) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰… B)
 characterization-of-โˆž-Magma-โ‰ก ua = characterization-of-โ‰ก ua sns-data

 characterization-of-characterization-of-โˆž-Magma-โ‰ก :

    (ua : is-univalent ๐“ค) (A : โˆž-Magma)
  โ†’
    โŒœ characterization-of-โˆž-Magma-โ‰ก ua A A โŒ (refl A)
  โ‰ก
    (๐‘–๐‘‘ โŸจ A โŸฉ , id-is-equiv โŸจ A โŸฉ , refl _)

 characterization-of-characterization-of-โˆž-Magma-โ‰ก ua A = refl _

module sip-with-axioms where

 open sip

 [_] : {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } {axioms : (X : ๐“ค ฬ‡ ) โ†’ S X โ†’ ๐“ฆ ฬ‡ }
     โ†’ (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ s ๊ž‰ S X , axioms X s) โ†’ ฮฃ S

 [ X , s , _ ] = (X , s)

 โŸช_โŸซ : {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } {axioms : (X : ๐“ค ฬ‡ ) โ†’ S X โ†’ ๐“ฆ ฬ‡ }
     โ†’ (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ s ๊ž‰ S X , axioms X s) โ†’ ๐“ค ฬ‡

 โŸช X , _ , _ โŸซ = X

 add-axioms : {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ }
              (axioms : (X : ๐“ค ฬ‡ ) โ†’ S X โ†’ ๐“ฆ ฬ‡ )
            โ†’ ((X : ๐“ค ฬ‡ ) (s : S X) โ†’ is-subsingleton (axioms X s))

            โ†’ SNS S ๐“ฃ
            โ†’ SNS (ฮป X โ†’ ฮฃ s ๊ž‰ S X , axioms X s) ๐“ฃ

 add-axioms {๐“ค} {๐“ฅ} {๐“ฆ} {๐“ฃ} {S} axioms i (ฮน , ฯ , ฮธ) = ฮน' , ฯ' , ฮธ'
  where
   S' : ๐“ค ฬ‡ โ†’ ๐“ฅ โŠ” ๐“ฆ  ฬ‡
   S' X = ฮฃ s ๊ž‰ S X , axioms X s

   ฮน' : (A B : ฮฃ S') โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ฃ ฬ‡
   ฮน' A B = ฮน [ A ] [ B ]

   ฯ' : (A : ฮฃ S') โ†’ ฮน' A A (id-โ‰ƒ โŸจ A โŸฉ)
   ฯ' A = ฯ [ A ]

   ฮธ' : {X : ๐“ค ฬ‡ } (s' t' : S' X) โ†’ is-equiv (canonical-map ฮน' ฯ' s' t')
   ฮธ' {X} (s , a) (t , b) = ฮณ
    where
     ฯ€ : S' X โ†’ S X
     ฯ€ (s , _) = s

     j : is-embedding ฯ€
     j = prโ‚-is-embedding (i X)

     k : {s' t' : S' X} โ†’ is-equiv (ap ฯ€ {s'} {t'})
     k {s'} {t'} = embedding-gives-ap-is-equiv ฯ€ j s' t'

     l : canonical-map ฮน' ฯ' (s , a) (t , b)
       โˆผ canonical-map ฮน ฯ s t โˆ˜ ap ฯ€ {s , a} {t , b}

     l (refl (s , a)) = refl (ฯ (X , s))

     e : is-equiv (canonical-map ฮน ฯ s t โˆ˜ ap ฯ€ {s , a} {t , b})
     e = โˆ˜-is-equiv (ฮธ s t) k

     ฮณ : is-equiv (canonical-map ฮน' ฯ' (s , a) (t , b))
     ฮณ = equivs-closed-under-โˆผ e l

 characterization-of-โ‰ก-with-axioms :

     is-univalent ๐“ค
   โ†’ {S : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ }
     (ฯƒ : SNS S ๐“ฃ)
     (axioms : (X : ๐“ค ฬ‡ ) โ†’ S X โ†’ ๐“ฆ ฬ‡ )
   โ†’ ((X : ๐“ค ฬ‡ ) (s : S X) โ†’ is-subsingleton (axioms X s))
   โ†’ (A B : ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ s ๊ž‰ S X , axioms X s)

   โ†’ (A โ‰ก B) โ‰ƒ ([ A ] โ‰ƒ[ ฯƒ ] [ B ])

 characterization-of-โ‰ก-with-axioms ua ฯƒ axioms i =
   characterization-of-โ‰ก ua (add-axioms axioms i ฯƒ)

module magma {๐“ค : Universe} where

 open sip-with-axioms

 Magma : ๐“ค โบ ฬ‡
 Magma = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , (X โ†’ X โ†’ X) ร— is-set X

 _โ‰…_ : Magma โ†’ Magma โ†’ ๐“ค ฬ‡

 (X , _ยท_ , _) โ‰… (Y , _*_ , _) =

               ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                            ร— ((ฮป x x' โ†’ f (x ยท x')) โ‰ก (ฮป x x' โ†’ f x * f x'))

 characterization-of-Magma-โ‰ก : is-univalent ๐“ค โ†’ (A B : Magma ) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰… B)
 characterization-of-Magma-โ‰ก ua =
   characterization-of-โ‰ก-with-axioms ua
     โˆž-magma.sns-data
     (ฮป X s โ†’ is-set X)
     (ฮป X s โ†’ being-set-is-subsingleton (univalence-gives-dfunext ua))

module pointed-type {๐“ค : Universe} where

 open sip

 Pointed : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
 Pointed X = X

 sns-data : SNS Pointed ๐“ค
 sns-data = (ฮน , ฯ , ฮธ)
  where
   ฮน : (A B : ฮฃ Pointed) โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ค ฬ‡
   ฮน (X , xโ‚€) (Y , yโ‚€) (f , _) = (f xโ‚€ โ‰ก yโ‚€)

   ฯ : (A : ฮฃ Pointed) โ†’ ฮน A A (id-โ‰ƒ โŸจ A โŸฉ)
   ฯ (X , xโ‚€) = refl xโ‚€

   ฮธ : {X : ๐“ค ฬ‡ } (xโ‚€ xโ‚ : Pointed X) โ†’ is-equiv (canonical-map ฮน ฯ xโ‚€ xโ‚)
   ฮธ xโ‚€ xโ‚ = equivs-closed-under-โˆผ (id-is-equiv (xโ‚€ โ‰ก xโ‚)) h
    where
     h : canonical-map ฮน ฯ xโ‚€ xโ‚ โˆผ ๐‘–๐‘‘ (xโ‚€ โ‰ก xโ‚)
     h (refl xโ‚€) = refl (refl xโ‚€)

 _โ‰…_ : ฮฃ Pointed โ†’ ฮฃ Pointed โ†’ ๐“ค ฬ‡
 (X , xโ‚€) โ‰… (Y , yโ‚€) = ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f ร— (f xโ‚€ โ‰ก yโ‚€)

 characterization-of-pointed-type-โ‰ก : is-univalent ๐“ค
                                    โ†’ (A B : ฮฃ Pointed) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰… B)

 characterization-of-pointed-type-โ‰ก ua = characterization-of-โ‰ก ua sns-data

module sip-join where

 technical-lemma :
     {X : ๐“ค ฬ‡ } {A : X โ†’ X โ†’ ๐“ฅ ฬ‡ }
     {Y : ๐“ฆ ฬ‡ } {B : Y โ†’ Y โ†’ ๐“ฃ ฬ‡ }
     (f : (xโ‚€ xโ‚ : X) โ†’ xโ‚€ โ‰ก xโ‚ โ†’ A xโ‚€ xโ‚)
     (g : (yโ‚€ yโ‚ : Y) โ†’ yโ‚€ โ‰ก yโ‚ โ†’ B yโ‚€ yโ‚)
   โ†’ ((xโ‚€ xโ‚ : X) โ†’ is-equiv (f xโ‚€ xโ‚))
   โ†’ ((yโ‚€ yโ‚ : Y) โ†’ is-equiv (g yโ‚€ yโ‚))

   โ†’ ((xโ‚€ , yโ‚€) (xโ‚ , yโ‚) : X ร— Y) โ†’ is-equiv (ฮป (p : (xโ‚€ , yโ‚€) โ‰ก (xโ‚ , yโ‚)) โ†’ f xโ‚€ xโ‚ (ap prโ‚ p) ,
                                                                               g yโ‚€ yโ‚ (ap prโ‚‚ p))
 technical-lemma {๐“ค} {๐“ฅ} {๐“ฆ} {๐“ฃ} {X} {A} {Y} {B} f g i j (xโ‚€ , yโ‚€) = ฮณ
  where
   u : โˆƒ! xโ‚ ๊ž‰ X , A xโ‚€ xโ‚
   u = fiberwise-equiv-universal (A xโ‚€) xโ‚€ (f xโ‚€) (i xโ‚€)

   v : โˆƒ! yโ‚ ๊ž‰ Y , B yโ‚€ yโ‚
   v = fiberwise-equiv-universal (B yโ‚€) yโ‚€ (g yโ‚€) (j yโ‚€)

   C : X ร— Y โ†’ ๐“ฅ โŠ” ๐“ฃ ฬ‡
   C (xโ‚ , yโ‚) = A xโ‚€ xโ‚ ร— B yโ‚€ yโ‚

   w : (โˆƒ! xโ‚ ๊ž‰ X , A xโ‚€ xโ‚)
     โ†’ (โˆƒ! yโ‚ ๊ž‰ Y , B yโ‚€ yโ‚)
     โ†’  โˆƒ! (xโ‚ , yโ‚) ๊ž‰ X ร— Y , C (xโ‚ , yโ‚)
   w ((xโ‚ , aโ‚) , ฯ†) ((yโ‚ , bโ‚) , ฯˆ) = ((xโ‚ , yโ‚) , (aโ‚ , bโ‚)) , ฮด
    where
     p : โˆ€ x y a b
       โ†’ (xโ‚ , aโ‚) โ‰ก (x , a)
       โ†’ (yโ‚ , bโ‚) โ‰ก (y , b)
       โ†’ (xโ‚ , yโ‚) , (aโ‚ , bโ‚) โ‰ก (x , y) , (a , b)
     p xโ‚ yโ‚ aโ‚ bโ‚ (refl (xโ‚ , aโ‚)) (refl (yโ‚ , bโ‚)) = refl ((xโ‚ , yโ‚) , (aโ‚ , bโ‚))

     ฮด : (((x , y) , (a , b)) : ฮฃ C) โ†’ (xโ‚ , yโ‚) , (aโ‚ , bโ‚) โ‰ก ((x , y) , (a , b))
     ฮด ((x , y) , (a , b)) = p x y a b (ฯ† (x , a)) (ฯˆ (y , b))

   ฯ„ : Nat (๐“จ (xโ‚€ , yโ‚€)) C
   ฯ„ (xโ‚ , yโ‚) p = f xโ‚€ xโ‚ (ap prโ‚ p) , g yโ‚€ yโ‚ (ap prโ‚‚ p)

   ฮณ : is-fiberwise-equiv ฯ„
   ฮณ = universal-fiberwise-equiv C (w u v) (xโ‚€ , yโ‚€) ฯ„

 variable
  ๐“ฅโ‚€ ๐“ฅโ‚ ๐“ฆโ‚€ ๐“ฆโ‚ : Universe

 open sip

 โŸช_โŸซ : {Sโ‚€ : ๐“ค ฬ‡ โ†’ ๐“ฅโ‚€ ฬ‡ } {Sโ‚ : ๐“ค ฬ‡ โ†’ ๐“ฅโ‚ ฬ‡ }
     โ†’ (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , Sโ‚€ X ร— Sโ‚ X) โ†’ ๐“ค ฬ‡

 โŸช X , sโ‚€ , sโ‚ โŸซ = X

 [_]โ‚€ : {Sโ‚€ : ๐“ค ฬ‡ โ†’ ๐“ฅโ‚€ ฬ‡ } {Sโ‚ : ๐“ค ฬ‡ โ†’ ๐“ฅโ‚ ฬ‡ }
      โ†’ (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , Sโ‚€ X ร— Sโ‚ X) โ†’ ฮฃ Sโ‚€

 [ X , sโ‚€ , sโ‚ ]โ‚€ = (X , sโ‚€)

 [_]โ‚ : {Sโ‚€ : ๐“ค ฬ‡ โ†’ ๐“ฅโ‚€ ฬ‡ } {Sโ‚ : ๐“ค ฬ‡ โ†’ ๐“ฅโ‚ ฬ‡ }
      โ†’ (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , Sโ‚€ X ร— Sโ‚ X) โ†’ ฮฃ Sโ‚

 [ X , sโ‚€ , sโ‚ ]โ‚ = (X , sโ‚)

 join : {Sโ‚€ : ๐“ค ฬ‡ โ†’ ๐“ฅโ‚€ ฬ‡ } {Sโ‚ : ๐“ค ฬ‡ โ†’ ๐“ฅโ‚ ฬ‡ }
      โ†’ SNS Sโ‚€ ๐“ฆโ‚€
      โ†’ SNS Sโ‚ ๐“ฆโ‚
      โ†’ SNS (ฮป X โ†’ Sโ‚€ X ร— Sโ‚ X) (๐“ฆโ‚€ โŠ” ๐“ฆโ‚)

 join {๐“ค} {๐“ฅโ‚€} {๐“ฅโ‚} {๐“ฆโ‚€} {๐“ฆโ‚} {Sโ‚€} {Sโ‚} (ฮนโ‚€ , ฯโ‚€ , ฮธโ‚€) (ฮนโ‚ , ฯโ‚ , ฮธโ‚) = ฮน , ฯ , ฮธ
  where
   S : ๐“ค ฬ‡ โ†’ ๐“ฅโ‚€ โŠ” ๐“ฅโ‚ ฬ‡
   S X = Sโ‚€ X ร— Sโ‚ X

   ฮน : (A B : ฮฃ S) โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ฆโ‚€ โŠ” ๐“ฆโ‚ ฬ‡
   ฮน A B e = ฮนโ‚€ [ A ]โ‚€ [ B ]โ‚€ e  ร—  ฮนโ‚ [ A ]โ‚ [ B ]โ‚ e

   ฯ : (A : ฮฃ S) โ†’ ฮน A A (id-โ‰ƒ โŸจ A โŸฉ)
   ฯ A = (ฯโ‚€ [ A ]โ‚€ , ฯโ‚ [ A ]โ‚)

   ฮธ : {X : ๐“ค ฬ‡ } (s t : S X) โ†’ is-equiv (canonical-map ฮน ฯ s t)
   ฮธ {X} (sโ‚€ , sโ‚) (tโ‚€ , tโ‚) = ฮณ
    where
     c : (p : sโ‚€ , sโ‚ โ‰ก tโ‚€ , tโ‚) โ†’ ฮนโ‚€ (X , sโ‚€) (X , tโ‚€) (id-โ‰ƒ X)
                                 ร— ฮนโ‚ (X , sโ‚) (X , tโ‚) (id-โ‰ƒ X)

     c p = (canonical-map ฮนโ‚€ ฯโ‚€ sโ‚€ tโ‚€ (ap prโ‚ p) ,
            canonical-map ฮนโ‚ ฯโ‚ sโ‚ tโ‚ (ap prโ‚‚ p))

     i : is-equiv c
     i = technical-lemma
          (canonical-map ฮนโ‚€ ฯโ‚€)
          (canonical-map ฮนโ‚ ฯโ‚)
          ฮธโ‚€ ฮธโ‚ (sโ‚€ , sโ‚) (tโ‚€ , tโ‚)

     e : canonical-map ฮน ฯ (sโ‚€ , sโ‚) (tโ‚€ , tโ‚) โˆผ c
     e (refl (sโ‚€ , sโ‚)) = refl (ฯโ‚€ (X , sโ‚€) , ฯโ‚ (X , sโ‚))

     ฮณ : is-equiv (canonical-map ฮน ฯ (sโ‚€ , sโ‚) (tโ‚€ , tโ‚))
     ฮณ = equivs-closed-under-โˆผ i e

 _โ‰ƒโŸฆ_,_โŸง_ : {Sโ‚€ : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } {Sโ‚ : ๐“ค ฬ‡ โ†’ ๐“ฅโ‚ ฬ‡ }

          โ†’ (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , Sโ‚€ X ร— Sโ‚ X)
          โ†’ SNS Sโ‚€ ๐“ฆโ‚€
          โ†’ SNS Sโ‚ ๐“ฆโ‚
          โ†’ (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , Sโ‚€ X ร— Sโ‚ X)

          โ†’ ๐“ค โŠ” ๐“ฆโ‚€ โŠ” ๐“ฆโ‚ ฬ‡

 A โ‰ƒโŸฆ ฯƒโ‚€ , ฯƒโ‚ โŸง B = ฮฃ f ๊ž‰ (โŸช A โŸซ โ†’ โŸช B โŸซ)
                  , ฮฃ i ๊ž‰ is-equiv f , homomorphic ฯƒโ‚€ [ A ]โ‚€ [ B ]โ‚€ (f , i)
                                     ร— homomorphic ฯƒโ‚ [ A ]โ‚ [ B ]โ‚ (f , i)

 characterization-of-join-โ‰ก : is-univalent ๐“ค
                            โ†’ {Sโ‚€ : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ } {Sโ‚ : ๐“ค ฬ‡ โ†’ ๐“ฅโ‚ ฬ‡ }
                              (ฯƒโ‚€ : SNS Sโ‚€ ๐“ฆโ‚€)  (ฯƒโ‚ : SNS Sโ‚ ๐“ฆโ‚)
                              (A B : ฮฃ X ๊ž‰ ๐“ค ฬ‡ , Sโ‚€ X ร— Sโ‚ X)

                            โ†’ (A โ‰ก B) โ‰ƒ (A โ‰ƒโŸฆ ฯƒโ‚€ , ฯƒโ‚ โŸง B)

 characterization-of-join-โ‰ก ua ฯƒโ‚€ ฯƒโ‚ = characterization-of-โ‰ก ua (join ฯƒโ‚€ ฯƒโ‚)

module pointed-โˆž-magma {๐“ค : Universe} where

 open sip-join

 โˆž-Magmaยท : ๐“ค โบ ฬ‡
 โˆž-Magmaยท = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , (X โ†’ X โ†’ X) ร— X

 _โ‰…_ : โˆž-Magmaยท โ†’ โˆž-Magmaยท โ†’ ๐“ค ฬ‡

 (X ,  _ยท_ , xโ‚€) โ‰… (Y ,  _*_ , yโ‚€) =

                 ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                              ร— ((ฮป x x' โ†’ f (x ยท x')) โ‰ก (ฮป x x' โ†’ f x * f x'))
                              ร— (f xโ‚€ โ‰ก yโ‚€)

 characterization-of-pointed-magma-โ‰ก : is-univalent ๐“ค
                                     โ†’ (A B : โˆž-Magmaยท) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰… B)

 characterization-of-pointed-magma-โ‰ก ua = characterization-of-join-โ‰ก ua
                                            โˆž-magma.sns-data
                                            pointed-type.sns-data

module monoid {๐“ค : Universe} (ua : is-univalent ๐“ค) where

 dfe : dfunext ๐“ค ๐“ค
 dfe = univalence-gives-dfunext ua

 open sip
 open sip-join
 open sip-with-axioms
 open monoids hiding (Monoid)

 monoid-structure : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
 monoid-structure X = (X โ†’ X โ†’ X) ร— X

 monoid-axioms : (X : ๐“ค ฬ‡ ) โ†’ monoid-structure X โ†’ ๐“ค ฬ‡
 monoid-axioms X (_ยท_ , e) = is-set X
                           ร— left-neutral  e _ยท_
                           ร— right-neutral e _ยท_
                           ร— associative     _ยท_

 Monoid : ๐“ค โบ ฬ‡
 Monoid = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ s ๊ž‰ monoid-structure X , monoid-axioms X s

 monoid-axioms-subsingleton : (X : ๐“ค ฬ‡ ) (s : monoid-structure X)
                            โ†’ is-subsingleton (monoid-axioms X s)

 monoid-axioms-subsingleton X (_ยท_ , e) = subsingleton-criterion' ฮณ
  where
   ฮณ : monoid-axioms X (_ยท_ , e) โ†’ is-subsingleton (monoid-axioms X (_ยท_ , e))
   ฮณ (i , _) = ร—-is-subsingleton
                 (being-set-is-subsingleton dfe)
              (ร—-is-subsingleton
                 (ฮ -is-subsingleton dfe
                   (ฮป x โ†’ i (e ยท x) x))
              (ร—-is-subsingleton
                 (ฮ -is-subsingleton dfe
                   (ฮป x โ†’ i (x ยท e) x))
                 (ฮ -is-subsingleton dfe
                   (ฮป x โ†’ ฮ -is-subsingleton dfe
                   (ฮป y โ†’ ฮ -is-subsingleton dfe
                   (ฮป z โ†’ i ((x ยท y) ยท z) (x ยท (y ยท z))))))))

 sns-data : SNS (ฮป X โ†’ ฮฃ s ๊ž‰ monoid-structure X , monoid-axioms X s) ๐“ค
 sns-data = add-axioms
              monoid-axioms monoid-axioms-subsingleton
              (join
                 โˆž-magma.sns-data
                 pointed-type.sns-data)

 _โ‰…_ : Monoid โ†’ Monoid โ†’ ๐“ค ฬ‡

 (X , (_ยท_ , d) , _) โ‰… (Y , (_*_ , e) , _) =

                     ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                                  ร— ((ฮป x x' โ†’ f (x ยท x')) โ‰ก (ฮป x x' โ†’ f x * f x'))
                                  ร— (f d โ‰ก e)

 characterization-of-monoid-โ‰ก : (A B : Monoid) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰… B)
 characterization-of-monoid-โ‰ก = characterization-of-โ‰ก ua sns-data

 monoid-structure' : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
 monoid-structure' X = X โ†’ X โ†’ X

 has-unit : {X : ๐“ค ฬ‡ } โ†’ monoid-structure' X โ†’ ๐“ค ฬ‡
 has-unit {X} _ยท_ = ฮฃ e ๊ž‰ X , left-neutral  e _ยท_ ร— right-neutral e _ยท_

 monoid-axioms' : (X : ๐“ค ฬ‡ ) โ†’ monoid-structure' X โ†’ ๐“ค ฬ‡
 monoid-axioms' X _ยท_ = is-set X ร— has-unit _ยท_ ร— associative _ยท_

 Monoid' : ๐“ค โบ ฬ‡
 Monoid' = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ s ๊ž‰ monoid-structure' X , monoid-axioms' X s

 to-Monoid : Monoid' โ†’ Monoid
 to-Monoid (X , _ยท_ , i , (e , l , r) , a) = (X , (_ยท_ , e) , (i , l , r , a))

 from-Monoid : Monoid โ†’ Monoid'
 from-Monoid (X , (_ยท_ , e) , (i , l , r , a)) = (X , _ยท_ , i , (e , l , r) , a)

 to-Monoid-is-equiv : is-equiv to-Monoid
 to-Monoid-is-equiv = invertibles-are-equivs to-Monoid (from-Monoid , refl , refl)

 from-Monoid-is-equiv : is-equiv from-Monoid
 from-Monoid-is-equiv = invertibles-are-equivs from-Monoid (to-Monoid , refl , refl)

 the-two-types-of-monoids-coincide : Monoid' โ‰ƒ Monoid
 the-two-types-of-monoids-coincide = to-Monoid , to-Monoid-is-equiv

 monoid-axioms'-subsingleton : (X : ๐“ค ฬ‡ ) (s : monoid-structure' X)
                             โ†’ is-subsingleton (monoid-axioms' X s)

 monoid-axioms'-subsingleton X _ยท_ = subsingleton-criterion' ฮณ
  where
   ฮณ : monoid-axioms' X _ยท_ โ†’ is-subsingleton (monoid-axioms' X _ยท_)
   ฮณ (i , _ , _) =
     ร—-is-subsingleton
      (being-set-is-subsingleton dfe)
    (ร—-is-subsingleton
      k
     (ฮ -is-subsingleton dfe (ฮป x โ†’
      ฮ -is-subsingleton dfe (ฮป y โ†’
      ฮ -is-subsingleton dfe (ฮป z โ†’ i ((x ยท y) ยท z) (x ยท (y ยท z)))))))
    where
     j : (e : X) โ†’ is-subsingleton (left-neutral e _ยท_ ร— right-neutral e _ยท_)
     j e = ร—-is-subsingleton
            (ฮ -is-subsingleton dfe (ฮป x โ†’ i (e ยท x) x))
            (ฮ -is-subsingleton dfe (ฮป x โ†’ i (x ยท e) x))

     k : is-subsingleton (has-unit _ยท_)
     k (e , l , r) (e' , l' , r') = to-subtype-โ‰ก j p
      where
       p = e        โ‰กโŸจ (r' e)โปยน โŸฉ
           (e ยท e') โ‰กโŸจ l e'     โŸฉ
           e'       โˆŽ

 sns-data' : SNS (ฮป X โ†’ ฮฃ s ๊ž‰ monoid-structure' X , monoid-axioms' X s) ๐“ค
 sns-data' = add-axioms
              monoid-axioms' monoid-axioms'-subsingleton
              โˆž-magma.sns-data

 _โ‰…'_ : Monoid' โ†’ Monoid' โ†’ ๐“ค ฬ‡
 (X , _ยท_ , _) โ‰…' (Y , _*_ , _) =

               ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                            ร— ((ฮป x x' โ†’ f (x ยท x')) โ‰ก (ฮป x x' โ†’ f x * f x'))

 characterization-of-monoid'-โ‰ก : (A B : Monoid') โ†’ (A โ‰ก B) โ‰ƒ (A โ‰…' B)
 characterization-of-monoid'-โ‰ก = characterization-of-โ‰ก ua sns-data'

 _โ‰…โ‚›_ : Monoid โ†’ Monoid โ†’ ๐“ค ฬ‡

 (X , (_ยท_ , _) , _) โ‰…โ‚› (Y , (_*_ , _) , _) =

                     ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                                  ร— ((ฮป x x' โ†’ f (x ยท x')) โ‰ก (ฮป x x' โ†’ f x * f x'))

 2nd-characterization-of-monoid-โ‰ก : (A B : Monoid) โ†’ (A โ‰ก B) โ‰ƒ A โ‰…โ‚› B
 2nd-characterization-of-monoid-โ‰ก A B = (A โ‰ก B)                          โ‰ƒโŸจ i   โŸฉ
                                        (from-Monoid A โ‰ก from-Monoid B)  โ‰ƒโŸจ ii  โŸฉ
                                        (from-Monoid A โ‰…' from-Monoid B) โ‰ƒโŸจ iii โŸฉ
                                        (A โ‰…โ‚› B)                         โ– 

  where
   ฯ† : A โ‰ก B โ†’ from-Monoid A โ‰ก from-Monoid B
   ฯ† = ap from-Monoid

   from-Monoid-is-embedding : is-embedding from-Monoid
   from-Monoid-is-embedding = equivs-are-embeddings from-Monoid from-Monoid-is-equiv

   ฯ†-is-equiv : is-equiv ฯ†
   ฯ†-is-equiv = embedding-gives-ap-is-equiv from-Monoid from-Monoid-is-embedding A B

   clearly : (from-Monoid A โ‰…' from-Monoid B) โ‰ก (A โ‰…โ‚› B)
   clearly = refl _

   i   = (ฯ† , ฯ†-is-equiv)
   ii  = characterization-of-monoid'-โ‰ก _ _
   iii = Idโ†’Eq _ _ clearly

module associative-โˆž-magma
        {๐“ค : Universe}
        (ua : is-univalent ๐“ค)
       where

 fe : dfunext ๐“ค ๐“ค
 fe = univalence-gives-dfunext ua

 associative : {X : ๐“ค ฬ‡ } โ†’ (X โ†’ X โ†’ X) โ†’ ๐“ค ฬ‡
 associative _ยท_ = โˆ€ x y z โ†’ (x ยท y) ยท z โ‰ก x ยท (y ยท z)

 โˆž-amagma-structure : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
 โˆž-amagma-structure X = ฮฃ _ยท_ ๊ž‰ (X โ†’ X โ†’ X), (associative _ยท_)

 โˆž-aMagma : ๐“ค โบ ฬ‡
 โˆž-aMagma = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , โˆž-amagma-structure X

 homomorphic : {X Y : ๐“ค ฬ‡ } โ†’ (X โ†’ X โ†’ X) โ†’ (Y โ†’ Y โ†’ Y) โ†’ (X โ†’ Y) โ†’ ๐“ค ฬ‡
 homomorphic _ยท_ _*_ f = (ฮป x y โ†’ f (x ยท y)) โ‰ก (ฮป x y โ†’ f x * f y)

 respect-assoc : {X A : ๐“ค ฬ‡ } (_ยท_ : X โ†’ X โ†’ X) (_*_ : A โ†’ A โ†’ A)
               โ†’ associative _ยท_
               โ†’ associative _*_
               โ†’ (f : X โ†’ A) โ†’ homomorphic _ยท_ _*_ f โ†’ ๐“ค ฬ‡

 respect-assoc _ยท_ _*_ ฮฑ ฮฒ f h  =  fฮฑ โ‰ก ฮฒf
  where
   l = ฮป x y z โ†’ f ((x ยท y) ยท z)   โ‰กโŸจ ap (ฮป - โ†’ - (x ยท y) z) h โŸฉ
                 f (x ยท y) * f z   โ‰กโŸจ ap (ฮป - โ†’ - x y * f z) h โŸฉ
                 (f x * f y) * f z โˆŽ

   r = ฮป x y z โ†’ f (x ยท (y ยท z))   โ‰กโŸจ ap (ฮป - โ†’ - x (y ยท z)) h โŸฉ
                 f x * f (y ยท z)   โ‰กโŸจ ap (ฮป - โ†’ f x * - y z) h โŸฉ
                 f x * (f y * f z) โˆŽ

   fฮฑ ฮฒf : โˆ€ x y z โ†’ (f x * f y) * f z โ‰ก f x * (f y * f z)
   fฮฑ x y z = (l x y z)โปยน โˆ™ ap f (ฮฑ x y z) โˆ™ r x y z
   ฮฒf x y z = ฮฒ (f x) (f y) (f z)

 remark : {X : ๐“ค ฬ‡ } (_ยท_ : X โ†’ X โ†’ X) (ฮฑ ฮฒ : associative _ยท_ )
        โ†’ respect-assoc _ยท_ _ยท_ ฮฑ ฮฒ id (refl _ยท_)
        โ‰ก ((ฮป x y z โ†’ refl ((x ยท y) ยท z) โˆ™ ap id (ฮฑ x y z)) โ‰ก ฮฒ)

 remark _ยท_ ฮฑ ฮฒ = refl _

 open sip hiding (homomorphic)

 sns-data : SNS โˆž-amagma-structure ๐“ค
 sns-data = (ฮน , ฯ , ฮธ)
  where
   ฮน : (๐“ง ๐“ : โˆž-aMagma) โ†’ โŸจ ๐“ง โŸฉ โ‰ƒ โŸจ ๐“ โŸฉ โ†’ ๐“ค ฬ‡
   ฮน (X , _ยท_ , ฮฑ) (A , _*_ , ฮฒ) (f , i) = ฮฃ h ๊ž‰ homomorphic _ยท_ _*_ f
                                               , respect-assoc _ยท_ _*_ ฮฑ ฮฒ f h

   ฯ : (๐“ง : โˆž-aMagma) โ†’ ฮน ๐“ง ๐“ง (id-โ‰ƒ โŸจ ๐“ง โŸฉ)
   ฯ (X , _ยท_ , ฮฑ) = h , p
    where
     h : homomorphic _ยท_ _ยท_ id
     h = refl _ยท_

     p : (ฮป x y z โ†’ refl ((x ยท y) ยท z) โˆ™ ap id (ฮฑ x y z)) โ‰ก ฮฑ
     p = fe (ฮป x โ†’ fe (ฮป y โ†’ fe (ฮป z โ†’ refl-left โˆ™ ap-id (ฮฑ x y z))))

   u : (X : ๐“ค ฬ‡ ) โ†’ โˆ€ s โ†’ โˆƒ! t ๊ž‰ โˆž-amagma-structure X , ฮน (X , s) (X , t) (id-โ‰ƒ X)
   u X (_ยท_ , ฮฑ) = c , ฯ†
    where
     c : ฮฃ t ๊ž‰ โˆž-amagma-structure X , ฮน (X , _ยท_ , ฮฑ) (X , t) (id-โ‰ƒ X)
     c = (_ยท_ , ฮฑ) , ฯ (X , _ยท_ , ฮฑ)

     ฯ† : (ฯƒ : ฮฃ t ๊ž‰ โˆž-amagma-structure X , ฮน (X , _ยท_ , ฮฑ) (X , t) (id-โ‰ƒ X)) โ†’ c โ‰ก ฯƒ
     ฯ† ((_ยท_ , ฮฒ) , refl _ยท_ , k) = ฮณ
      where
       a : associative _ยท_
       a x y z = refl ((x ยท y) ยท z) โˆ™ ap id (ฮฑ x y z)

       g : singleton-type' a โ†’ ฮฃ t ๊ž‰ โˆž-amagma-structure X , ฮน (X , _ยท_ , ฮฑ) (X , t) (id-โ‰ƒ X)
       g (ฮฒ , k) = (_ยท_ , ฮฒ) , refl _ยท_ , k

       i : is-subsingleton (singleton-type' a)
       i = singletons-are-subsingletons _ (singleton-types'-are-singletons _ a)

       q : ฮฑ , prโ‚‚ (ฯ (X , _ยท_ , ฮฑ)) โ‰ก ฮฒ , k
       q = i _ _

       ฮณ : c โ‰ก (_ยท_ , ฮฒ) , refl _ยท_ , k
       ฮณ = ap g q

   ฮธ : {X : ๐“ค ฬ‡ } (s t : โˆž-amagma-structure X) โ†’ is-equiv (canonical-map ฮน ฯ s t)
   ฮธ {X} s = universal-fiberwise-equiv (ฮป t โ†’ ฮน (X , s) (X , t) (id-โ‰ƒ X))
              (u X s) s (canonical-map ฮน ฯ s)

 _โ‰…_ : โˆž-aMagma โ†’ โˆž-aMagma โ†’ ๐“ค ฬ‡
 (X , _ยท_ , ฮฑ) โ‰… (Y , _*_ , ฮฒ) = ฮฃ f ๊ž‰ (X โ†’ Y)
                                     , is-equiv f
                                     ร— (ฮฃ h ๊ž‰ homomorphic _ยท_ _*_ f
                                            , respect-assoc _ยท_ _*_ ฮฑ ฮฒ f h)

 characterization-of-โˆž-aMagma-โ‰ก : (A B : โˆž-aMagma) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰… B)
 characterization-of-โˆž-aMagma-โ‰ก = characterization-of-โ‰ก ua sns-data

module group {๐“ค : Universe} (ua : is-univalent ๐“ค) where

 hfe : hfunext ๐“ค ๐“ค
 hfe = univalence-gives-hfunext ua

 open sip
 open sip-with-axioms
 open monoid {๐“ค} ua hiding (sns-data ; _โ‰…_ ; _โ‰…'_)

 group-structure : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
 group-structure X = ฮฃ s ๊ž‰ monoid-structure X , monoid-axioms X s

 group-axiom : (X : ๐“ค ฬ‡ ) โ†’ monoid-structure X โ†’ ๐“ค ฬ‡
 group-axiom X (_ยท_ , e) = (x : X) โ†’ ฮฃ x' ๊ž‰ X , (x ยท x' โ‰ก e) ร— (x' ยท x โ‰ก e)

 Group : ๐“ค โบ ฬ‡
 Group = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ ((_ยท_ , e) , a) ๊ž‰ group-structure X , group-axiom X (_ยท_ , e)

 inv-lemma : (X : ๐“ค ฬ‡ ) (_ยท_ : X โ†’ X โ†’ X) (e : X)
           โ†’ monoid-axioms X (_ยท_ , e)
           โ†’ (x y z : X)
           โ†’ (y ยท x) โ‰ก e
           โ†’ (x ยท z) โ‰ก e
           โ†’ y โ‰ก z

 inv-lemma X _ยท_  e (s , l , r , a) x y z q p =

    y             โ‰กโŸจ (r y)โปยน          โŸฉ
    (y ยท e)       โ‰กโŸจ ap (y ยท_) (p โปยน) โŸฉ
    (y ยท (x ยท z)) โ‰กโŸจ (a y x z)โปยน      โŸฉ
    ((y ยท x) ยท z) โ‰กโŸจ ap (_ยท z) q      โŸฉ
    (e ยท z)       โ‰กโŸจ l z              โŸฉ
    z             โˆŽ

 group-axiom-is-subsingleton : (X : ๐“ค ฬ‡ )
                             โ†’ (s : group-structure X)
                             โ†’ is-subsingleton (group-axiom X (prโ‚ s))

 group-axiom-is-subsingleton X ((_ยท_ , e) , (s , l , r , a)) = ฮณ
  where
   i : (x : X) โ†’ is-subsingleton (ฮฃ x' ๊ž‰ X , (x ยท x' โ‰ก e) ร— (x' ยท x โ‰ก e))
   i x (y , _ , q) (z , p , _) = u
    where
     t : y โ‰ก z
     t = inv-lemma X _ยท_ e (s , l , r , a) x y z q p

     u : (y , _ , q) โ‰ก (z , p , _)
     u = to-subtype-โ‰ก (ฮป x' โ†’ ร—-is-subsingleton (s (x ยท x') e) (s (x' ยท x) e)) t

   ฮณ : is-subsingleton (group-axiom X (_ยท_ , e))
   ฮณ = ฮ -is-subsingleton dfe i

 sns-data : SNS (ฮป X โ†’ ฮฃ s ๊ž‰ group-structure X , group-axiom X (prโ‚ s)) ๐“ค
 sns-data = add-axioms
             (ฮป X s โ†’ group-axiom X (prโ‚ s)) group-axiom-is-subsingleton
             (monoid.sns-data ua)

 _โ‰…_ : Group โ†’ Group โ†’ ๐“ค ฬ‡

 (X , ((_ยท_ , d) , _) , _) โ‰… (Y , ((_*_ , e) , _) , _) =

            ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                         ร— ((ฮป x x' โ†’ f (x ยท x')) โ‰ก (ฮป x x' โ†’ f x * f x'))
                         ร— (f d โ‰ก e)

 characterization-of-group-โ‰ก : (A B : Group) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰… B)
 characterization-of-group-โ‰ก = characterization-of-โ‰ก ua sns-data

 _โ‰…'_ : Group โ†’ Group โ†’ ๐“ค ฬ‡

 (X , ((_ยท_ , d) , _) , _) โ‰…' (Y , ((_*_ , e) , _) , _) =

            ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                         ร— ((ฮป x x' โ†’ f (x ยท x')) โ‰ก (ฮป x x' โ†’ f x * f x'))

 group-structure-of : (G : Group) โ†’ group-structure โŸจ G โŸฉ
 group-structure-of (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) = (_ยท_ , e) , i , l , r , a

 monoid-structure-of : (G : Group) โ†’ monoid-structure โŸจ G โŸฉ
 monoid-structure-of (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) = (_ยท_ , e)

 monoid-axioms-of : (G : Group) โ†’ monoid-axioms โŸจ G โŸฉ (monoid-structure-of G)
 monoid-axioms-of (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) = i , l , r , a

 multiplication : (G : Group) โ†’ โŸจ G โŸฉ โ†’ โŸจ G โŸฉ โ†’ โŸจ G โŸฉ
 multiplication (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) = _ยท_

 syntax multiplication G x y = x ยทโŸจ G โŸฉ y

 unit : (G : Group) โ†’ โŸจ G โŸฉ
 unit (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) = e

 group-is-set : (G : Group)
              โ†’ is-set โŸจ G โŸฉ

 group-is-set (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) = i

 unit-left : (G : Group) (x : โŸจ G โŸฉ)
           โ†’ unit G ยทโŸจ G โŸฉ x โ‰ก x

 unit-left (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) x = l x

 unit-right : (G : Group) (x : โŸจ G โŸฉ)
            โ†’ x ยทโŸจ G โŸฉ unit G โ‰ก x

 unit-right (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) x = r x

 assoc : (G : Group) (x y z : โŸจ G โŸฉ)
       โ†’ (x ยทโŸจ G โŸฉ y) ยทโŸจ G โŸฉ z โ‰ก x ยทโŸจ G โŸฉ (y ยทโŸจ G โŸฉ z)

 assoc (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) = a

 inv : (G : Group) โ†’ โŸจ G โŸฉ โ†’ โŸจ G โŸฉ
 inv (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) x = prโ‚ (ฮณ x)

 inv-left : (G : Group) (x : โŸจ G โŸฉ)
          โ†’ inv G x ยทโŸจ G โŸฉ x โ‰ก unit G

 inv-left (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) x = prโ‚‚ (prโ‚‚ (ฮณ x))

 inv-right : (G : Group) (x : โŸจ G โŸฉ)
           โ†’ x ยทโŸจ G โŸฉ inv G x โ‰ก unit G

 inv-right (X , ((_ยท_ , e) , i , l , r , a) , ฮณ) x = prโ‚ (prโ‚‚ (ฮณ x))

 preserves-multiplication : (G H : Group) โ†’ (โŸจ G โŸฉ โ†’ โŸจ H โŸฉ) โ†’ ๐“ค ฬ‡
 preserves-multiplication G H f = (ฮป (x y : โŸจ G โŸฉ) โ†’ f (x ยทโŸจ G โŸฉ y))
                                โ‰ก (ฮป (x y : โŸจ G โŸฉ) โ†’ f x ยทโŸจ H โŸฉ f y)

 preserves-unit : (G H : Group) โ†’ (โŸจ G โŸฉ โ†’ โŸจ H โŸฉ) โ†’ ๐“ค ฬ‡
 preserves-unit G H f = f (unit G) โ‰ก unit H

 idempotent-is-unit : (G : Group) (x : โŸจ G โŸฉ)
                    โ†’ x ยทโŸจ G โŸฉ x โ‰ก x
                    โ†’ x โ‰ก unit G

 idempotent-is-unit G x p = ฮณ
  where
   x' = inv G x
   ฮณ = x                        โ‰กโŸจ (unit-left G x)โปยน                        โŸฉ
       unit G ยทโŸจ G โŸฉ x          โ‰กโŸจ (ap (ฮป - โ†’ - ยทโŸจ G โŸฉ x) (inv-left G x))โปยน โŸฉ
       (x' ยทโŸจ G โŸฉ x) ยทโŸจ G โŸฉ x   โ‰กโŸจ assoc G x' x x                           โŸฉ
       x' ยทโŸจ G โŸฉ (x ยทโŸจ G โŸฉ x)   โ‰กโŸจ ap (ฮป - โ†’ x' ยทโŸจ G โŸฉ -) p                 โŸฉ
       x' ยทโŸจ G โŸฉ x              โ‰กโŸจ inv-left G x                             โŸฉ
       unit G                   โˆŽ

 unit-preservation-lemma : (G H : Group) (f : โŸจ G โŸฉ โ†’ โŸจ H โŸฉ)
                         โ†’ preserves-multiplication G H f
                         โ†’ preserves-unit G H f

 unit-preservation-lemma G H f m = idempotent-is-unit H e p
  where
   e  = f (unit G)

   p = e ยทโŸจ H โŸฉ e               โ‰กโŸจ ap (ฮป - โ†’ - (unit G) (unit G)) (m โปยน)    โŸฉ
       f (unit G ยทโŸจ G โŸฉ unit G) โ‰กโŸจ ap f (unit-left G (unit G))              โŸฉ
       e                        โˆŽ

 inv-Lemma : (G : Group) (x y z : โŸจ G โŸฉ)
           โ†’ (y ยทโŸจ G โŸฉ x) โ‰ก unit G
           โ†’ (x ยทโŸจ G โŸฉ z) โ‰ก unit G
           โ†’ y โ‰ก z

 inv-Lemma G = inv-lemma โŸจ G โŸฉ (multiplication G) (unit G) (monoid-axioms-of G)

 one-left-inv : (G : Group) (x x' : โŸจ G โŸฉ)
              โ†’ (x' ยทโŸจ G โŸฉ x) โ‰ก unit G
              โ†’ x' โ‰ก inv G x

 one-left-inv G x x' p = inv-Lemma G x x' (inv G x) p (inv-right G x)

 one-right-inv : (G : Group) (x x' : โŸจ G โŸฉ)
               โ†’ (x ยทโŸจ G โŸฉ x') โ‰ก unit G
               โ†’ x' โ‰ก inv G x

 one-right-inv G x x' p = (inv-Lemma G x (inv G x) x' (inv-left G x) p)โปยน

 preserves-inv : (G H : Group) โ†’ (โŸจ G โŸฉ โ†’ โŸจ H โŸฉ) โ†’ ๐“ค ฬ‡
 preserves-inv G H f = (x : โŸจ G โŸฉ) โ†’ f (inv G x) โ‰ก inv H (f x)

 inv-preservation-lemma : (G H : Group) (f : โŸจ G โŸฉ โ†’ โŸจ H โŸฉ)
                        โ†’ preserves-multiplication G H f
                        โ†’ preserves-inv G H f

 inv-preservation-lemma G H f m x = ฮณ
  where
   p = f (inv G x) ยทโŸจ H โŸฉ f x โ‰กโŸจ (ap (ฮป - โ†’ - (inv G x) x) m)โปยน  โŸฉ
       f (inv G x ยทโŸจ G โŸฉ x)   โ‰กโŸจ ap f (inv-left G x)             โŸฉ
       f (unit G)             โ‰กโŸจ unit-preservation-lemma G H f m โŸฉ
       unit H                 โˆŽ

   ฮณ : f (inv G x) โ‰ก inv H (f x)
   ฮณ = one-left-inv H (f x) (f (inv G x)) p

 is-homomorphism : (G H : Group) โ†’ (โŸจ G โŸฉ โ†’ โŸจ H โŸฉ) โ†’ ๐“ค ฬ‡
 is-homomorphism G H f = preserves-multiplication G H f
                       ร— preserves-unit G H f

 preservation-of-mult-is-subsingleton : (G H : Group) (f : โŸจ G โŸฉ โ†’ โŸจ H โŸฉ)
                                      โ†’ is-subsingleton (preserves-multiplication G H f)
 preservation-of-mult-is-subsingleton G H f = j
  where
   j : is-subsingleton (preserves-multiplication G H f)
   j = ฮ -is-set hfe
        (ฮป _ โ†’ ฮ -is-set hfe
        (ฮป _ โ†’ group-is-set H))
        (ฮป (x y : โŸจ G โŸฉ) โ†’ f (x ยทโŸจ G โŸฉ y))
        (ฮป (x y : โŸจ G โŸฉ) โ†’ f x ยทโŸจ H โŸฉ f y)

 being-homomorphism-is-subsingleton : (G H : Group) (f : โŸจ G โŸฉ โ†’ โŸจ H โŸฉ)
                                    โ†’ is-subsingleton (is-homomorphism G H f)
 being-homomorphism-is-subsingleton G H f = i
  where

   i : is-subsingleton (is-homomorphism G H f)
   i = ร—-is-subsingleton
        (preservation-of-mult-is-subsingleton G H f)
        (group-is-set H (f (unit G)) (unit H))

 notions-of-homomorphism-agree : (G H : Group) (f : โŸจ G โŸฉ โ†’ โŸจ H โŸฉ)
                               โ†’ is-homomorphism G H f
                               โ‰ƒ preserves-multiplication G H f

 notions-of-homomorphism-agree G H f = ฮณ
  where
   ฮฑ : is-homomorphism G H f โ†’ preserves-multiplication G H f
   ฮฑ = prโ‚

   ฮฒ : preserves-multiplication G H f โ†’ is-homomorphism G H f
   ฮฒ m = m , unit-preservation-lemma G H f m

   ฮณ : is-homomorphism G H f โ‰ƒ preserves-multiplication G H f
   ฮณ = logically-equivalent-subsingletons-are-equivalent _ _
        (being-homomorphism-is-subsingleton G H f)
        (preservation-of-mult-is-subsingleton G H f)
        (ฮฑ , ฮฒ)

 โ‰…-agreement : (G H : Group) โ†’ (G โ‰… H) โ‰ƒ (G โ‰…' H)
 โ‰…-agreement G H = ฮฃ-cong (ฮป f โ†’ ฮฃ-cong (ฮป _ โ†’ notions-of-homomorphism-agree G H f))

 forget-unit-preservation : (G H : Group) โ†’ (G โ‰… H) โ†’ (G โ‰…' H)
 forget-unit-preservation G H (f , e , m , _) = f , e , m

 NB : (G H : Group) โ†’ โŒœ โ‰…-agreement G H โŒ โ‰ก forget-unit-preservation G H
 NB G H = refl _

 forget-unit-preservation-is-equiv : (G H : Group)
                                   โ†’ is-equiv (forget-unit-preservation G H)

 forget-unit-preservation-is-equiv G H = โŒœโŒ-is-equiv (โ‰…-agreement G H)

module slice
        {๐“ค ๐“ฅ : Universe}
        (R : ๐“ฅ ฬ‡ )
       where

 open sip

 S : ๐“ค ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
 S X = X โ†’ R

 sns-data : SNS S (๐“ค โŠ” ๐“ฅ)
 sns-data = (ฮน , ฯ , ฮธ)
  where
   ฮน : (A B : ฮฃ S) โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
   ฮน (X , g) (Y , h) (f , _) = (g โ‰ก h โˆ˜ f)

   ฯ : (A : ฮฃ S) โ†’ ฮน A A (id-โ‰ƒ โŸจ A โŸฉ)
   ฯ (X , g) = refl g

   k : {X : ๐“ค ฬ‡ } {g h : S X} โ†’ canonical-map ฮน ฯ g h โˆผ ๐‘–๐‘‘ (g โ‰ก h)
   k (refl g) = refl (refl g)

   ฮธ : {X : ๐“ค ฬ‡ } (g h : S X) โ†’ is-equiv (canonical-map ฮน ฯ g h)
   ฮธ g h = equivs-closed-under-โˆผ (id-is-equiv (g โ‰ก h)) k

 _โ‰…_  : ๐“ค / R โ†’ ๐“ค / R โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
 (X , g) โ‰… (Y , h) = ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f ร— (g โ‰ก h โˆ˜ f)

 characterization-of-/-โ‰ก : is-univalent ๐“ค โ†’ (A B : ๐“ค / R) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰… B)
 characterization-of-/-โ‰ก ua = characterization-of-โ‰ก ua sns-data

module subgroup
        (๐“ค  : Universe)
        (ua : Univalence)
       where

 gfe : global-dfunext
 gfe = univalence-gives-global-dfunext ua

 open sip
 open monoid {๐“ค} (ua ๐“ค) hiding (sns-data ; _โ‰…_)
 open group {๐“ค} (ua ๐“ค)

 module ambient (G : Group) where

  _ยท_ : โŸจ G โŸฉ โ†’ โŸจ G โŸฉ โ†’ โŸจ G โŸฉ
  x ยท y = x ยทโŸจ G โŸฉ y

  infixl 42 _ยท_

  group-closed : (โŸจ G โŸฉ โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
  group-closed ๐“ = ๐“ (unit G)
                 ร— ((x y : โŸจ G โŸฉ) โ†’ ๐“ x โ†’ ๐“ y โ†’ ๐“ (x ยท y))
                 ร— ((x : โŸจ G โŸฉ) โ†’ ๐“ x โ†’ ๐“ (inv G x))

  Subgroup : ๐“ค โบ ฬ‡
  Subgroup = ฮฃ A ๊ž‰ ๐“Ÿ โŸจ G โŸฉ , group-closed (_โˆˆ A)

  โŸช_โŸซ : Subgroup โ†’ ๐“Ÿ โŸจ G โŸฉ
  โŸช A , u , c , ฮน โŸซ = A

  being-group-closed-subset-is-subsingleton : (A : ๐“Ÿ โŸจ G โŸฉ) โ†’ is-subsingleton (group-closed (_โˆˆ A))
  being-group-closed-subset-is-subsingleton A = ร—-is-subsingleton
                                                  (โˆˆ-is-subsingleton A (unit G))
                                               (ร—-is-subsingleton
                                                  (ฮ -is-subsingleton dfe
                                                     (ฮป x โ†’ ฮ -is-subsingleton dfe
                                                     (ฮป y โ†’ ฮ -is-subsingleton dfe
                                                     (ฮป _ โ†’ ฮ -is-subsingleton dfe
                                                     (ฮป _ โ†’ โˆˆ-is-subsingleton A (x ยท y))))))
                                                  (ฮ -is-subsingleton dfe
                                                     (ฮป x โ†’ ฮ -is-subsingleton dfe
                                                     (ฮป _ โ†’ โˆˆ-is-subsingleton A (inv G x)))))

  โŸชโŸซ-is-embedding : is-embedding โŸช_โŸซ
  โŸชโŸซ-is-embedding = prโ‚-is-embedding being-group-closed-subset-is-subsingleton

  ap-โŸชโŸซ : (S T : Subgroup) โ†’ S โ‰ก T โ†’ โŸช S โŸซ โ‰ก โŸช T โŸซ
  ap-โŸชโŸซ S T = ap โŸช_โŸซ

  ap-โŸชโŸซ-is-equiv : (S T : Subgroup) โ†’ is-equiv (ap-โŸชโŸซ S T)
  ap-โŸชโŸซ-is-equiv = embedding-gives-ap-is-equiv โŸช_โŸซ โŸชโŸซ-is-embedding

  subgroups-form-a-set : is-set Subgroup
  subgroups-form-a-set S T = equiv-to-subsingleton
                              (ap-โŸชโŸซ S T , ap-โŸชโŸซ-is-equiv S T)
                              (powersets-are-sets' ua โŸช S โŸซ โŸช T โŸซ)

  subgroup-equality : (S T : Subgroup)
                    โ†’ (S โ‰ก T)
                    โ‰ƒ ((x : โŸจ G โŸฉ) โ†’ (x โˆˆ โŸช S โŸซ) โ‡” (x โˆˆ โŸช T โŸซ))

  subgroup-equality S T = ฮณ
   where
    f : S โ‰ก T โ†’ (x : โŸจ G โŸฉ) โ†’ x โˆˆ โŸช S โŸซ โ‡” x โˆˆ โŸช T โŸซ
    f p x = transport (ฮป - โ†’ x โˆˆ โŸช - โŸซ) p , transport (ฮป - โ†’ x โˆˆ โŸช - โŸซ) (p โปยน)

    h : ((x : โŸจ G โŸฉ) โ†’ x โˆˆ โŸช S โŸซ โ‡” x โˆˆ โŸช T โŸซ) โ†’ โŸช S โŸซ โ‰ก โŸช T โŸซ
    h ฯ† = subset-extensionality' ua ฮฑ ฮฒ
     where
      ฮฑ : โŸช S โŸซ โŠ† โŸช T โŸซ
      ฮฑ x = lr-implication (ฯ† x)

      ฮฒ : โŸช T โŸซ โŠ† โŸช S โŸซ
      ฮฒ x = rl-implication (ฯ† x)

    g : ((x : โŸจ G โŸฉ) โ†’ x โˆˆ โŸช S โŸซ โ‡” x โˆˆ โŸช T โŸซ) โ†’ S โ‰ก T
    g = inverse (ap-โŸชโŸซ S T) (ap-โŸชโŸซ-is-equiv S T) โˆ˜ h

    ฮณ : (S โ‰ก T) โ‰ƒ ((x : โŸจ G โŸฉ) โ†’ x โˆˆ โŸช S โŸซ โ‡” x โˆˆ โŸช T โŸซ)
    ฮณ = logically-equivalent-subsingletons-are-equivalent _ _
          (subgroups-form-a-set S T)
          (ฮ -is-subsingleton dfe
             (ฮป x โ†’ ร—-is-subsingleton
                      (ฮ -is-subsingleton dfe (ฮป _ โ†’ โˆˆ-is-subsingleton โŸช T โŸซ x))
                      (ฮ -is-subsingleton dfe (ฮป _ โ†’ โˆˆ-is-subsingleton โŸช S โŸซ x))))
          (f , g)

  Subgroup' : ๐“ค โบ ฬ‡
  Subgroup' = ฮฃ H ๊ž‰ Group
            , ฮฃ h ๊ž‰ (โŸจ H โŸฉ โ†’ โŸจ G โŸฉ)
            , is-embedding h
            ร— is-homomorphism H G h

  T : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
  T X = ฮฃ ((_ยท_ , e) , a) ๊ž‰ group-structure X , group-axiom X (_ยท_ , e)

  module _ {X : ๐“ค ฬ‡ } (h : X โ†’ โŸจ G โŸฉ) (h-is-embedding : is-embedding h) where

   private
    h-lc : left-cancellable h
    h-lc = embeddings-are-lc h h-is-embedding

   having-group-closed-fiber-is-subsingleton : is-subsingleton (group-closed (fiber h))
   having-group-closed-fiber-is-subsingleton = being-group-closed-subset-is-subsingleton A
    where
     A : ๐“Ÿ โŸจ G โŸฉ
     A y = (fiber h y , h-is-embedding y)

   at-most-one-homomorphic-structure : is-subsingleton (ฮฃ ฯ„ ๊ž‰ T X , is-homomorphism (X , ฯ„) G h)
   at-most-one-homomorphic-structure
      ((((_*_ ,  unitH) ,  maxioms) ,  gaxiom) ,  (pmult ,  punit))
      ((((_*'_ , unitH') , maxioms') , gaxiom') , (pmult' , punit'))
    = ฮณ
    where
     ฯ„ ฯ„' : T X
     ฯ„  = ((_*_ ,  unitH) ,  maxioms) ,  gaxiom
     ฯ„' = ((_*'_ , unitH') , maxioms') , gaxiom'

     i :  is-homomorphism (X , ฯ„)  G h
     i  = (pmult ,  punit)

     i' : is-homomorphism (X , ฯ„') G h
     i' = (pmult' , punit')

     p : _*_ โ‰ก _*'_
     p = gfe (ฮป x โ†’ gfe (ฮป y โ†’ h-lc (h (x * y)  โ‰กโŸจ  ap (ฮป - โ†’ - x y) pmult     โŸฉ
                                     h x ยท h y  โ‰กโŸจ (ap (ฮป - โ†’ - x y) pmult')โปยน โŸฉ
                                     h (x *' y) โˆŽ)))
     q : unitH โ‰ก unitH'
     q = h-lc (h unitH  โ‰กโŸจ  punit     โŸฉ
               unit G   โ‰กโŸจ  punit' โปยน โŸฉ
               h unitH' โˆŽ)

     r : (_*_ , unitH) โ‰ก (_*'_ , unitH')
     r = to-ร—-โ‰ก (p , q)

     ฮด : ฯ„ โ‰ก ฯ„'
     ฮด = to-subtype-โ‰ก
           (group-axiom-is-subsingleton X)
           (to-subtype-โ‰ก
              (monoid-axioms-subsingleton X)
              r)

     ฮณ : (ฯ„  , i) โ‰ก (ฯ„' , i')
     ฮณ = to-subtype-โ‰ก (ฮป ฯ„ โ†’ being-homomorphism-is-subsingleton (X , ฯ„) G h) ฮด

   homomorphic-structure-gives-group-closed-fiber : (ฮฃ ฯ„ ๊ž‰ T X , is-homomorphism (X , ฯ„) G h)
                                                  โ†’ group-closed (fiber h)

   homomorphic-structure-gives-group-closed-fiber
       ((((_*_ , unitH) , maxioms) , gaxiom) , (pmult , punit))
     = (unitc , mulc , invc)
    where
     H : Group
     H = X , ((_*_ , unitH) , maxioms) , gaxiom

     unitc : fiber h (unit G)
     unitc = unitH , punit

     mulc : ((x y : โŸจ G โŸฉ) โ†’ fiber h x โ†’ fiber h y โ†’ fiber h (x ยท y))
     mulc x y (a , p) (b , q) = (a * b) ,
                                (h (a * b) โ‰กโŸจ ap (ฮป - โ†’ - a b) pmult    โŸฉ
                                 h a ยท h b โ‰กโŸจ apโ‚‚ (ฮป - -' โ†’ - ยท -') p q โŸฉ
                                 x ยท y     โˆŽ)

     invc : ((x : โŸจ G โŸฉ) โ†’ fiber h x โ†’ fiber h (inv G x))
     invc x (a , p) = inv H a ,
                      (h (inv H a) โ‰กโŸจ inv-preservation-lemma H G h pmult a โŸฉ
                       inv G (h a) โ‰กโŸจ ap (inv G) p                         โŸฉ
                       inv G x     โˆŽ)

   group-closed-fiber-gives-homomorphic-structure : group-closed (fiber h)
                                                  โ†’ (ฮฃ ฯ„ ๊ž‰ T X , is-homomorphism (X , ฯ„) G h)

   group-closed-fiber-gives-homomorphic-structure (unitc , mulc , invc) = ฯ„ , i
    where
     ฯ† : (x : X) โ†’ fiber h (h x)
     ฯ† x = (x , refl (h x))

     unitH : X
     unitH = fiber-point unitc

     _*_ : X โ†’ X โ†’ X
     x * y = fiber-point (mulc (h x) (h y) (ฯ† x) (ฯ† y))

     invH : X โ†’ X
     invH x = fiber-point (invc (h x) (ฯ† x))

     pmul : (x y : X) โ†’ h (x * y) โ‰ก h x ยท h y
     pmul x y = fiber-identification (mulc (h x) (h y) (ฯ† x) (ฯ† y))

     punit : h unitH โ‰ก unit G
     punit = fiber-identification unitc

     pinv : (x : X) โ†’ h (invH x) โ‰ก inv G (h x)
     pinv x = fiber-identification (invc (h x) (ฯ† x))

     unitH-left : (x : X) โ†’ unitH * x โ‰ก x
     unitH-left x = h-lc (h (unitH * x) โ‰กโŸจ pmul unitH x      โŸฉ
                          h unitH ยท h x โ‰กโŸจ ap (_ยท h x) punit โŸฉ
                          unit G ยท h x  โ‰กโŸจ unit-left G (h x) โŸฉ
                          h x           โˆŽ)

     unitH-right : (x : X) โ†’ x * unitH โ‰ก x
     unitH-right x = h-lc (h (x * unitH) โ‰กโŸจ pmul x unitH       โŸฉ
                           h x ยท h unitH โ‰กโŸจ ap (h x ยท_) punit  โŸฉ
                           h x ยท unit G  โ‰กโŸจ unit-right G (h x) โŸฉ
                           h x           โˆŽ)

     assocH : (x y z : X) โ†’ ((x * y) * z) โ‰ก (x * (y * z))
     assocH x y z = h-lc (h ((x * y) * z)   โ‰กโŸจ pmul (x * y) z             โŸฉ
                          h (x * y) ยท h z   โ‰กโŸจ ap (_ยท h z) (pmul x y)     โŸฉ
                          (h x ยท h y) ยท h z โ‰กโŸจ assoc G (h x) (h y) (h z)  โŸฉ
                          h x ยท (h y ยท h z) โ‰กโŸจ (ap (h x ยท_) (pmul y z))โปยน โŸฉ
                          h x ยท h (y * z)   โ‰กโŸจ (pmul x (y * z))โปยน         โŸฉ
                          h (x * (y * z))   โˆŽ)

     group-axiomH : (x : X) โ†’ ฮฃ x' ๊ž‰ X , (x * x' โ‰ก unitH) ร— (x' * x โ‰ก unitH)
     group-axiomH x = invH x ,

                      h-lc (h (x * invH x)     โ‰กโŸจ pmul x (invH x)      โŸฉ
                            h x ยท h (invH x)   โ‰กโŸจ ap (h x ยท_) (pinv x) โŸฉ
                            h x ยท inv G (h x)  โ‰กโŸจ inv-right G (h x)    โŸฉ
                            unit G             โ‰กโŸจ punit โปยน             โŸฉ
                            h unitH            โˆŽ),

                      h-lc ((h (invH x * x)    โ‰กโŸจ pmul (invH x) x      โŸฉ
                             h (invH x) ยท h x  โ‰กโŸจ ap (_ยท h x) (pinv x) โŸฉ
                             inv G (h x) ยท h x โ‰กโŸจ inv-left G (h x)     โŸฉ
                             unit G            โ‰กโŸจ punit โปยน             โŸฉ
                             h unitH           โˆŽ))

     j : is-set X
     j = subtypes-of-sets-are-sets h h-lc (group-is-set G)

     ฯ„ : T X
     ฯ„ = ((_*_ , unitH) , (j , unitH-left , unitH-right , assocH)) , group-axiomH

     i : is-homomorphism (X , ฯ„) G h
     i = gfe (ฮป x โ†’ gfe (pmul x)) , punit

   fiber-structure-lemma : group-closed (fiber h)
                         โ‰ƒ (ฮฃ ฯ„ ๊ž‰ T X , is-homomorphism (X , ฯ„) G h)

   fiber-structure-lemma = logically-equivalent-subsingletons-are-equivalent _ _
                             having-group-closed-fiber-is-subsingleton
                             at-most-one-homomorphic-structure
                             (group-closed-fiber-gives-homomorphic-structure ,
                              homomorphic-structure-gives-group-closed-fiber)

  characterization-of-the-type-of-subgroups :  Subgroup โ‰ƒ Subgroup'
  characterization-of-the-type-of-subgroups =

   Subgroup                                                                                        โ‰ƒโŸจ i    โŸฉ
   (ฮฃ A ๊ž‰ ๐“Ÿ โŸจ G โŸฉ , group-closed (_โˆˆ A))                                                           โ‰ƒโŸจ ii   โŸฉ
   (ฮฃ (X , h , e) ๊ž‰ Subtype โŸจ G โŸฉ , group-closed (fiber h))                                        โ‰ƒโŸจ iii  โŸฉ
   (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ (h , e) ๊ž‰ X โ†ช โŸจ G โŸฉ , group-closed (fiber h))                                     โ‰ƒโŸจ iv   โŸฉ
   (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ (h , e) ๊ž‰ X โ†ช โŸจ G โŸฉ , ฮฃ ฯ„ ๊ž‰ T X , is-homomorphism (X , ฯ„) G h)                    โ‰ƒโŸจ v    โŸฉ
   (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ h ๊ž‰ (X โ†’ โŸจ G โŸฉ) , ฮฃ e ๊ž‰ is-embedding h , ฮฃ ฯ„ ๊ž‰ T X , is-homomorphism (X , ฯ„) G h) โ‰ƒโŸจ vi   โŸฉ
   (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ h ๊ž‰ (X โ†’ โŸจ G โŸฉ) , ฮฃ ฯ„ ๊ž‰ T X , ฮฃ e ๊ž‰ is-embedding h , is-homomorphism (X , ฯ„) G h) โ‰ƒโŸจ vii  โŸฉ
   (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ ฯ„ ๊ž‰ T X , ฮฃ h ๊ž‰ (X โ†’ โŸจ G โŸฉ) , is-embedding h ร— is-homomorphism (X , ฯ„) G h)       โ‰ƒโŸจ viii โŸฉ
   (ฮฃ H ๊ž‰ Group , ฮฃ h ๊ž‰ (โŸจ H โŸฉ โ†’ โŸจ G โŸฉ) , is-embedding h ร— is-homomorphism H G h)                  โ‰ƒโŸจ ix   โŸฉ
   Subgroup'                                                                                       โ– 

      where
       ฯ† : Subtype โŸจ G โŸฉ โ†’ ๐“Ÿ โŸจ G โŸฉ
       ฯ† = ฯ‡-special is-subsingleton โŸจ G โŸฉ

       j : is-equiv ฯ†
       j = ฯ‡-special-is-equiv (ua ๐“ค) gfe is-subsingleton โŸจ G โŸฉ

       i    = Idโ†’Eq _ _ (refl Subgroup)
       ii   = ฮฃ-change-of-variable (ฮป (A : ๐“Ÿ โŸจ G โŸฉ) โ†’ group-closed (_โˆˆ A)) ฯ† j
       iii  = ฮฃ-assoc
       iv   = ฮฃ-cong (ฮป X โ†’ ฮฃ-cong (ฮป (h , e) โ†’ fiber-structure-lemma h e))
       v    = ฮฃ-cong (ฮป X โ†’ ฮฃ-assoc)
       vi   = ฮฃ-cong (ฮป X โ†’ ฮฃ-cong (ฮป h โ†’ ฮฃ-flip))
       vii  = ฮฃ-cong (ฮป X โ†’ ฮฃ-flip)
       viii = โ‰ƒ-sym ฮฃ-assoc
       ix   = Idโ†’Eq _ _ (refl Subgroup')

  induced-group : Subgroup โ†’ Group
  induced-group S = prโ‚ (โŒœ characterization-of-the-type-of-subgroups โŒ S)

  forgetful-map : Subgroup' โ†’ ๐“ค / โŸจ G โŸฉ
  forgetful-map ((X , _)  , h  , _) = (X , h)

  forgetful-map-is-embedding : is-embedding forgetful-map
  forgetful-map-is-embedding = ฮณ
   where
    Subtype' : ๐“ค ฬ‡ โ†’ ๐“ค โบ ฬ‡
    Subtype' X = ฮฃ (X , h) ๊ž‰ ๐“ค / โŸจ G โŸฉ , is-embedding h

    fโ‚€ : Subgroup' โ†’ Subtype โŸจ G โŸฉ
    fโ‚€ ((X , _)  , h  , e , _) = (X , h , e)

    fโ‚ : Subtype โŸจ G โŸฉ โ†’ Subtype' โŸจ G โŸฉ
    fโ‚ (X , h , e) = ((X , h) , e)

    fโ‚‚ : Subtype' โŸจ G โŸฉ โ†’ ๐“ค / โŸจ G โŸฉ
    fโ‚‚ ((X , h) , e) = (X , h)

    by-construction : forgetful-map โ‰ก fโ‚‚ โˆ˜ fโ‚ โˆ˜ fโ‚€
    by-construction = refl _

    fโ‚€-lc : left-cancellable fโ‚€
    fโ‚€-lc {(X , ฯ„) , h , e , i} {(X , ฯ„') , h , e , i'} (refl (X , h , e)) = ฮด
     where
      p : (ฯ„ , i) โ‰ก (ฯ„' , i')
      p = at-most-one-homomorphic-structure h e (ฯ„ , i) (ฯ„' , i')

      ฯ† : (ฮฃ ฯ„ ๊ž‰ T X , is-homomorphism (X , ฯ„) G h) โ†’ Subgroup'
      ฯ† (ฯ„ , i) = ((X , ฯ„) , h , e , i)

      ฮด : ((X , ฯ„) , h , e , i) โ‰ก ((X , ฯ„') , h , e , i')
      ฮด = ap ฯ† p

    fโ‚€-is-embedding : is-embedding fโ‚€
    fโ‚€-is-embedding = lc-maps-into-sets-are-embeddings fโ‚€ fโ‚€-lc (subtypes-form-set ua โŸจ G โŸฉ)

    fโ‚-is-equiv : is-equiv fโ‚
    fโ‚-is-equiv = invertibles-are-equivs fโ‚ ((ฮป ((X , h) , e) โ†’ (X , h , e)) , refl , refl)

    fโ‚-is-embedding : is-embedding fโ‚
    fโ‚-is-embedding = equivs-are-embeddings fโ‚ fโ‚-is-equiv

    fโ‚‚-is-embedding : is-embedding fโ‚‚
    fโ‚‚-is-embedding = prโ‚-is-embedding (ฮป (X , h) โ†’ being-embedding-is-subsingleton gfe h)

    ฮณ : is-embedding forgetful-map
    ฮณ = โˆ˜-embedding fโ‚‚-is-embedding (โˆ˜-embedding fโ‚-is-embedding fโ‚€-is-embedding)

  _โ‰กโ‚›_ : Subgroup' โ†’  Subgroup' โ†’ ๐“ค ฬ‡
  (H , h , _ ) โ‰กโ‚› (H' , h' , _ ) = ฮฃ f ๊ž‰ (โŸจ H โŸฉ โ†’ โŸจ H' โŸฉ) , is-equiv f ร— (h โ‰ก h' โˆ˜ f)

  subgroup'-equality : (S T : Subgroup') โ†’ (S โ‰ก T) โ‰ƒ (S โ‰กโ‚› T)
  subgroup'-equality S T = (S โ‰ก T)                             โ‰ƒโŸจ i  โŸฉ
                           (forgetful-map S โ‰ก forgetful-map T) โ‰ƒโŸจ ii โŸฉ
                           (S โ‰กโ‚› T)                            โ– 
   where
    open slice โŸจ G โŸฉ hiding (S)
    i  = โ‰ƒ-sym (embedding-criterion-converse forgetful-map forgetful-map-is-embedding S T)
    ii = characterization-of-/-โ‰ก (ua ๐“ค) (forgetful-map S) (forgetful-map T)

  subgroups'-form-a-set : is-set Subgroup'
  subgroups'-form-a-set = equiv-to-set
                           (โ‰ƒ-sym characterization-of-the-type-of-subgroups)
                           subgroups-form-a-set

  โ‰กโ‚›-is-subsingleton-valued : (S T : Subgroup') โ†’ is-subsingleton (S โ‰กโ‚› T)
  โ‰กโ‚›-is-subsingleton-valued S T = ฮณ
   where
    i : is-subsingleton (S โ‰ก T)
    i = subgroups'-form-a-set S T

    ฮณ : is-subsingleton (S โ‰กโ‚› T)
    ฮณ = equiv-to-subsingleton (โ‰ƒ-sym (subgroup'-equality S T)) i

  โ‰กโ‚›-is-subsingleton-valued' : (S S' : Subgroup') โ†’ is-subsingleton (S โ‰กโ‚› S')
  โ‰กโ‚›-is-subsingleton-valued' (H , h , e , i) (H' , h' , e' , i') = ฮณ
   where
    S  = (H  , h  , e  , i )
    S' = (H' , h' , e' , i')

    A = ฮฃ f ๊ž‰ (โŸจ H โŸฉ โ†’ โŸจ H' โŸฉ) , h' โˆ˜ f โ‰ก h
    B = ฮฃ (f , p) ๊ž‰ A , is-equiv f

    A-is-subsingleton : is-subsingleton A
    A-is-subsingleton = postcomp-is-embedding gfe hfe h' e' โŸจ H โŸฉ h

    B-is-subsingleton : is-subsingleton B
    B-is-subsingleton = ฮฃ-is-subsingleton
                         A-is-subsingleton
                         (ฮป (f , p) โ†’ being-equiv-is-subsingleton gfe gfe f)

    ฮด : (S โ‰กโ‚› S') โ‰ƒ B
    ฮด = invertibility-gives-โ‰ƒ ฮฑ (ฮฒ , ฮท , ฮต)
     where
      ฮฑ = ฮป (f , i , p) โ†’ ((f , (p โปยน)) , i)
      ฮฒ = ฮป ((f , p) , i) โ†’ (f , i , (p โปยน))
      ฮท = ฮป (f , i , p) โ†’ ap (ฮป - โ†’ (f , i , -)) (โปยน-involutive p)
      ฮต = ฮป ((f , p) , i) โ†’ ap (ฮป - โ†’ ((f , -) , i)) (โปยน-involutive p)

    ฮณ : is-subsingleton (S โ‰กโ‚› S')
    ฮณ = equiv-to-subsingleton ฮด B-is-subsingleton

module ring {๐“ค : Universe} (ua : Univalence) where

 open sip hiding (โŸจ_โŸฉ)
 open sip-with-axioms
 open sip-join

 fe : global-dfunext
 fe = univalence-gives-global-dfunext ua

 hfe : global-hfunext
 hfe = univalence-gives-global-hfunext ua

 rng-structure : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
 rng-structure X = (X โ†’ X โ†’ X) ร— (X โ†’ X โ†’ X)

 rng-axioms : (R : ๐“ค ฬ‡ ) โ†’ rng-structure R โ†’ ๐“ค ฬ‡
 rng-axioms R (_+_ , _ยท_) = I ร— II ร— III ร— IV ร— V ร— VI ร— VII
  where
    I   = is-set R
    II  = (x y z : R) โ†’ (x + y) + z โ‰ก x + (y + z)
    III = (x y : R) โ†’ x + y โ‰ก y + x
    IV  = ฮฃ O ๊ž‰ R , ((x : R) โ†’ x + O โ‰ก x) ร— ((x : R) โ†’ ฮฃ x' ๊ž‰ R , x + x' โ‰ก O)
    V   = (x y z : R) โ†’ (x ยท y) ยท z โ‰ก x ยท (y ยท z)
    VI  = (x y z : R) โ†’ x ยท (y + z) โ‰ก (x ยท y) + (x ยท z)
    VII = (x y z : R) โ†’ (y + z) ยท x โ‰ก (y ยท x) + (z ยท x)

 Rng : ๐“ค โบ ฬ‡
 Rng = ฮฃ R ๊ž‰ ๐“ค ฬ‡ , ฮฃ s ๊ž‰ rng-structure R , rng-axioms R s

 rng-axioms-is-subsingleton : (R : ๐“ค ฬ‡ ) (s : rng-structure R)
                            โ†’ is-subsingleton (rng-axioms R s)

 rng-axioms-is-subsingleton R (_+_ , _ยท_) (i , ii , iii , iv-vii) = ฮด
  where
    A   = ฮป (O : R) โ†’ ((x : R) โ†’ x + O โ‰ก x)
                    ร— ((x : R) โ†’ ฮฃ x' ๊ž‰ R , x + x' โ‰ก O)

    IV  = ฮฃ A

    a : (O O' : R) โ†’ ((x : R) โ†’ x + O โ‰ก x) โ†’ ((x : R) โ†’ x + O' โ‰ก x) โ†’ O โ‰ก O'
    a O O' f f' = O       โ‰กโŸจ (f' O)โปยน โŸฉ
                 (O + O') โ‰กโŸจ iii O O' โŸฉ
                 (O' + O) โ‰กโŸจ f O'     โŸฉ
                  O'      โˆŽ

    b : (O : R) โ†’ is-subsingleton ((x : R) โ†’ x + O โ‰ก x)
    b O = ฮ -is-subsingleton fe (ฮป x โ†’ i (x + O) x)

    c : (O : R)
      โ†’ ((x : R) โ†’ x + O โ‰ก x)
      โ†’ (x : R) โ†’ is-subsingleton (ฮฃ x' ๊ž‰ R , x + x' โ‰ก O)
    c O f x (x' , p') (x'' , p'') = to-subtype-โ‰ก (ฮป x' โ†’ i (x + x') O) r
     where
      r : x' โ‰ก x''
      r = x'               โ‰กโŸจ (f x')โปยน               โŸฉ
          (x' + O)         โ‰กโŸจ ap (x' +_) (p'' โปยน)    โŸฉ
          (x' + (x + x'')) โ‰กโŸจ (ii x' x x'')โปยน        โŸฉ
          ((x' + x) + x'') โ‰กโŸจ ap (_+ x'') (iii x' x) โŸฉ
          ((x + x') + x'') โ‰กโŸจ ap (_+ x'') p'         โŸฉ
          (O + x'')        โ‰กโŸจ iii O x''              โŸฉ
          (x'' + O)        โ‰กโŸจ f x''                  โŸฉ
          x''              โˆŽ

    d : (O : R) โ†’ is-subsingleton (A O)
    d O (f , g) = ฯ† (f , g)
     where
      ฯ† : is-subsingleton (A O)
      ฯ† = ร—-is-subsingleton (b O) (ฮ -is-subsingleton fe (ฮป x โ†’ c O f x))

    IV-is-subsingleton : is-subsingleton IV
    IV-is-subsingleton (O , f , g) (O' , f' , g') = e
     where
      e : (O , f , g) โ‰ก (O' , f' , g')
      e = to-subtype-โ‰ก d (a O O' f f')

    ฮณ : is-subsingleton (rng-axioms R (_+_ , _ยท_))
    ฮณ = ร—-is-subsingleton
          (being-set-is-subsingleton fe)
       (ร—-is-subsingleton
          (ฮ -is-subsingleton fe
          (ฮป x โ†’ ฮ -is-subsingleton fe
          (ฮป y โ†’ ฮ -is-subsingleton fe
          (ฮป z โ†’ i ((x + y) + z) (x + (y + z))))))
       (ร—-is-subsingleton
          (ฮ -is-subsingleton fe
          (ฮป x โ†’ ฮ -is-subsingleton fe
          (ฮป y โ†’ i (x + y) (y + x))))
       (ร—-is-subsingleton
          IV-is-subsingleton
       (ร—-is-subsingleton
          (ฮ -is-subsingleton fe
          (ฮป x โ†’ ฮ -is-subsingleton fe
          (ฮป y โ†’ ฮ -is-subsingleton fe
          (ฮป z โ†’ i ((x ยท y) ยท z) (x ยท (y ยท z))))))
       (ร—-is-subsingleton
          (ฮ -is-subsingleton fe
          (ฮป x โ†’ ฮ -is-subsingleton fe
          (ฮป y โ†’ ฮ -is-subsingleton fe
          (ฮป z โ†’ i (x ยท (y + z)) ((x ยท y) + (x ยท z))))))

          (ฮ -is-subsingleton fe
          (ฮป x โ†’ ฮ -is-subsingleton fe
          (ฮป y โ†’ ฮ -is-subsingleton fe
          (ฮป z โ†’ i ((y + z) ยท x) ((y ยท x) + (z ยท x)))))))))))

    ฮด : (ฮฑ : rng-axioms R (_+_ , _ยท_)) โ†’ (i , ii , iii , iv-vii) โ‰ก ฮฑ
    ฮด = ฮณ (i , ii , iii , iv-vii)

 _โ‰…[Rng]_ : Rng โ†’ Rng โ†’ ๐“ค ฬ‡

 (R , (_+_ , _ยท_) , _) โ‰…[Rng] (R' , (_+'_ , _ยท'_) , _) =

                       ฮฃ f ๊ž‰ (R โ†’ R')
                           , is-equiv f
                           ร— ((ฮป x y โ†’ f (x + y)) โ‰ก (ฮป x y โ†’ f x +' f y))
                           ร— ((ฮป x y โ†’ f (x ยท y)) โ‰ก (ฮป x y โ†’ f x ยท' f y))

 characterization-of-rng-โ‰ก : (๐“ก ๐“ก' : Rng) โ†’ (๐“ก โ‰ก ๐“ก') โ‰ƒ (๐“ก โ‰…[Rng] ๐“ก')
 characterization-of-rng-โ‰ก = characterization-of-โ‰ก (ua ๐“ค)
                              (add-axioms
                                rng-axioms
                                rng-axioms-is-subsingleton
                                (join
                                  โˆž-magma.sns-data
                                  โˆž-magma.sns-data))

 โŸจ_โŸฉ : (๐“ก : Rng) โ†’ ๐“ค ฬ‡
 โŸจ R , _ โŸฉ = R

 ring-structure : ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
 ring-structure X = X ร— rng-structure X

 ring-axioms : (R : ๐“ค ฬ‡ ) โ†’ ring-structure R โ†’ ๐“ค ฬ‡
 ring-axioms R (๐Ÿ , _+_ , _ยท_) = rng-axioms R (_+_ , _ยท_) ร— VIII
  where
   VIII = (x : R) โ†’ (x ยท ๐Ÿ โ‰ก x) ร— (๐Ÿ ยท x โ‰ก x)

 ring-axioms-is-subsingleton : (R : ๐“ค ฬ‡ ) (s : ring-structure R)
                             โ†’ is-subsingleton (ring-axioms R s)

 ring-axioms-is-subsingleton R (๐Ÿ , _+_ , _ยท_) ((i , ii-vii) , viii) = ฮณ ((i , ii-vii) , viii)
  where
   ฮณ : is-subsingleton (ring-axioms R (๐Ÿ , _+_ , _ยท_))
   ฮณ = ร—-is-subsingleton
         (rng-axioms-is-subsingleton R (_+_ , _ยท_))
         (ฮ -is-subsingleton fe (ฮป x โ†’ ร—-is-subsingleton (i (x ยท ๐Ÿ) x) (i (๐Ÿ ยท x) x)))

 Ring : ๐“ค โบ ฬ‡
 Ring = ฮฃ R ๊ž‰ ๐“ค ฬ‡ , ฮฃ s ๊ž‰ ring-structure R , ring-axioms R s

 _โ‰…[Ring]_ : Ring โ†’ Ring โ†’ ๐“ค ฬ‡

 (R , (๐Ÿ , _+_ , _ยท_) , _) โ‰…[Ring] (R' , (๐Ÿ' , _+'_ , _ยท'_) , _) =

                           ฮฃ f ๊ž‰ (R โ†’ R')
                               , is-equiv f
                               ร— (f ๐Ÿ โ‰ก ๐Ÿ')
                               ร— ((ฮป x y โ†’ f (x + y)) โ‰ก (ฮป x y โ†’ f x +' f y))
                               ร— ((ฮป x y โ†’ f (x ยท y)) โ‰ก (ฮป x y โ†’ f x ยท' f y))

 characterization-of-ring-โ‰ก : (๐“ก ๐“ก' : Ring) โ†’ (๐“ก โ‰ก ๐“ก') โ‰ƒ (๐“ก โ‰…[Ring] ๐“ก')
 characterization-of-ring-โ‰ก = characterization-of-โ‰ก (ua ๐“ค)
                                (add-axioms
                                  ring-axioms
                                  ring-axioms-is-subsingleton
                                  (join
                                    pointed-type.sns-data
                                      (join
                                        โˆž-magma.sns-data
                                        โˆž-magma.sns-data)))

module generalized-metric-space
        {๐“ค ๐“ฅ : Universe}
        (R : ๐“ฅ ฬ‡ )
        (axioms  : (X : ๐“ค ฬ‡ ) โ†’ (X โ†’ X โ†’ R) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡ )
        (axiomss : (X : ๐“ค ฬ‡ ) (d : X โ†’ X โ†’ R) โ†’ is-subsingleton (axioms X d))
       where

 open sip
 open sip-with-axioms

 S : ๐“ค ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
 S X = X โ†’ X โ†’ R

 sns-data : SNS S (๐“ค โŠ” ๐“ฅ)
 sns-data = (ฮน , ฯ , ฮธ)
  where
   ฮน : (A B : ฮฃ S) โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
   ฮน (X , d) (Y , e) (f , _) = (d โ‰ก ฮป x x' โ†’ e (f x) (f x'))

   ฯ : (A : ฮฃ S) โ†’ ฮน A A (id-โ‰ƒ โŸจ A โŸฉ)
   ฯ (X , d) = refl d

   h : {X : ๐“ค ฬ‡ } {d e : S X} โ†’ canonical-map ฮน ฯ d e โˆผ ๐‘–๐‘‘ (d โ‰ก e)
   h (refl d) = refl (refl d)

   ฮธ : {X : ๐“ค ฬ‡ } (d e : S X) โ†’ is-equiv (canonical-map ฮน ฯ d e)
   ฮธ d e = equivs-closed-under-โˆผ (id-is-equiv (d โ‰ก e)) h

 M : ๐“ค โบ โŠ” ๐“ฅ  ฬ‡
 M = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ d ๊ž‰ (X โ†’ X โ†’ R) , axioms X d

 _โ‰…_  : M โ†’ M โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
 (X , d , _) โ‰… (Y , e , _) = ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                                          ร— (d โ‰ก ฮป x x' โ†’ e (f x) (f x'))

 characterization-of-M-โ‰ก : is-univalent ๐“ค
                         โ†’ (A B : M) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰… B)

 characterization-of-M-โ‰ก ua = characterization-of-โ‰ก-with-axioms ua
                                sns-data
                                axioms axiomss

module generalized-topological-space
        (๐“ค ๐“ฅ : Universe)
        (R : ๐“ฅ ฬ‡ )
        (axioms  : (X : ๐“ค ฬ‡ ) โ†’ ((X โ†’ R) โ†’ R) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡ )
        (axiomss : (X : ๐“ค ฬ‡ ) (๐“ž : (X โ†’ R) โ†’ R) โ†’ is-subsingleton (axioms X ๐“ž))
       where

 open sip
 open sip-with-axioms

 โ„™ : ๐“ฆ ฬ‡ โ†’ ๐“ฅ โŠ” ๐“ฆ ฬ‡
 โ„™ X = X โ†’ R

 _โˆŠ_ : {X : ๐“ฆ ฬ‡ } โ†’ X โ†’ โ„™ X โ†’ R
 x โˆŠ A = A x

 inverse-image : {X Y : ๐“ค ฬ‡ } โ†’ (X โ†’ Y) โ†’ โ„™ Y โ†’ โ„™ X
 inverse-image f B = ฮป x โ†’ f x โˆŠ B

 โ„™โ„™ : ๐“ค ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
 โ„™โ„™ X = โ„™ (โ„™ X)

 Space : ๐“ค โบ โŠ” ๐“ฅ  ฬ‡
 Space = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ ๐“ž ๊ž‰ โ„™โ„™ X , axioms X ๐“ž

 sns-data : SNS โ„™โ„™ (๐“ค โŠ” ๐“ฅ)
 sns-data = (ฮน , ฯ , ฮธ)
  where
   ฮน : (A B : ฮฃ โ„™โ„™) โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
   ฮน (X , ๐“žX) (Y , ๐“žY) (f , _) = (ฮป (V : โ„™ Y) โ†’ inverse-image f V โˆŠ ๐“žX) โ‰ก ๐“žY

   ฯ : (A : ฮฃ โ„™โ„™) โ†’ ฮน A A (id-โ‰ƒ โŸจ A โŸฉ)
   ฯ (X , ๐“ž) = refl ๐“ž

   h : {X : ๐“ค ฬ‡ } {๐“ž ๐“ž' : โ„™โ„™ X} โ†’ canonical-map ฮน ฯ ๐“ž ๐“ž' โˆผ ๐‘–๐‘‘ (๐“ž โ‰ก ๐“ž')
   h (refl ๐“ž) = refl (refl ๐“ž)

   ฮธ : {X : ๐“ค ฬ‡ } (๐“ž ๐“ž' : โ„™โ„™ X) โ†’ is-equiv (canonical-map ฮน ฯ ๐“ž ๐“ž')
   ฮธ {X} ๐“ž ๐“ž' = equivs-closed-under-โˆผ (id-is-equiv (๐“ž โ‰ก ๐“ž')) h

 _โ‰…_  : Space โ†’ Space โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡

 (X , ๐“žX , _) โ‰… (Y , ๐“žY , _) =

              ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                           ร— ((ฮป V โ†’ inverse-image f V โˆŠ ๐“žX) โ‰ก ๐“žY)

 characterization-of-Space-โ‰ก : is-univalent ๐“ค
                             โ†’ (A B : Space) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰… B)

 characterization-of-Space-โ‰ก ua = characterization-of-โ‰ก-with-axioms ua
                                   sns-data axioms axiomss

 _โ‰…'_  : Space โ†’ Space โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡

 (X , F , _) โ‰…' (Y , G , _) =

             ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                          ร— ((ฮป (v : Y โ†’ R) โ†’ F (v โˆ˜ f)) โ‰ก G)

 characterization-of-Space-โ‰ก' : is-univalent ๐“ค
                              โ†’ (A B : Space) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰…' B)

 characterization-of-Space-โ‰ก' = characterization-of-Space-โ‰ก

module selection-space
        (๐“ค ๐“ฅ : Universe)
        (R : ๐“ฅ ฬ‡ )
        (axioms  : (X : ๐“ค ฬ‡ ) โ†’ ((X โ†’ R) โ†’ X) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡ )
        (axiomss : (X : ๐“ค ฬ‡ ) (ฮต : (X โ†’ R) โ†’ X) โ†’ is-subsingleton (axioms X ฮต))
       where

 open sip
 open sip-with-axioms

 S : ๐“ค ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
 S X = (X โ†’ R) โ†’ X

 SelectionSpace : ๐“ค โบ โŠ” ๐“ฅ  ฬ‡
 SelectionSpace = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ ฮต ๊ž‰ S X , axioms X ฮต

 sns-data : SNS S (๐“ค โŠ” ๐“ฅ)
 sns-data = (ฮน , ฯ , ฮธ)
  where
   ฮน : (A B : ฮฃ S) โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
   ฮน (X , ฮต) (Y , ฮด) (f , _) = (ฮป (q : Y โ†’ R) โ†’ f (ฮต (q โˆ˜ f))) โ‰ก ฮด

   ฯ : (A : ฮฃ S) โ†’ ฮน A A (id-โ‰ƒ โŸจ A โŸฉ)
   ฯ (X , ฮต) = refl ฮต

   ฮธ : {X : ๐“ค ฬ‡ } (ฮต ฮด : S X) โ†’ is-equiv (canonical-map ฮน ฯ ฮต ฮด)
   ฮธ {X} ฮต ฮด = ฮณ
    where
     h : canonical-map ฮน ฯ ฮต ฮด โˆผ ๐‘–๐‘‘ (ฮต โ‰ก ฮด)
     h (refl ฮต) = refl (refl ฮต)

     ฮณ : is-equiv (canonical-map ฮน ฯ ฮต ฮด)
     ฮณ = equivs-closed-under-โˆผ (id-is-equiv (ฮต โ‰ก ฮด)) h

 _โ‰…_  :  SelectionSpace โ†’ SelectionSpace โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡

 (X , ฮต , _) โ‰… (Y , ฮด , _) =

             ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f
                          ร— ((ฮป (q : Y โ†’ R) โ†’ f (ฮต (q โˆ˜ f))) โ‰ก ฮด)

 characterization-of-selection-space-โ‰ก : is-univalent ๐“ค
                                       โ†’ (A B : SelectionSpace) โ†’ (A โ‰ก B) โ‰ƒ (A โ‰… B)

 characterization-of-selection-space-โ‰ก ua = characterization-of-โ‰ก-with-axioms ua
                                             sns-data
                                             axioms axiomss

module contrived-example (๐“ค : Universe) where

 open sip

 contrived-โ‰ก : is-univalent ๐“ค โ†’

    (X Y : ๐“ค ฬ‡ ) (ฯ† : (X โ†’ X) โ†’ X) (ฮณ : (Y โ†’ Y) โ†’ Y)
  โ†’
    ((X , ฯ†) โ‰ก (Y , ฮณ)) โ‰ƒ (ฮฃ f ๊ž‰ (X โ†’ Y)
                         , ฮฃ i ๊ž‰ is-equiv f
                         , (ฮป (g : Y โ†’ Y) โ†’ f (ฯ† (inverse f i โˆ˜ g โˆ˜ f))) โ‰ก ฮณ)

 contrived-โ‰ก ua X Y ฯ† ฮณ =
   characterization-of-โ‰ก ua
    ((ฮป (X , ฯ†) (Y , ฮณ) (f , i) โ†’ (ฮป (g : Y โ†’ Y) โ†’ f (ฯ† (inverse f i โˆ˜ g โˆ˜ f))) โ‰ก ฮณ) ,
     (ฮป (X , ฯ†) โ†’ refl ฯ†) ,
     (ฮป ฯ† ฮณ โ†’ equivs-closed-under-โˆผ (id-is-equiv (ฯ† โ‰ก ฮณ)) (ฮป {(refl ฯ†) โ†’ refl (refl ฯ†)})))
    (X , ฯ†) (Y , ฮณ)

module generalized-functor-algebra
         {๐“ค ๐“ฅ : Universe}
         (F : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ )
         (๐“• : {X Y : ๐“ค ฬ‡ } โ†’ (X โ†’ Y) โ†’ F X โ†’ F Y)
         (๐“•-id : {X : ๐“ค ฬ‡ } โ†’ ๐“• (๐‘–๐‘‘ X) โ‰ก ๐‘–๐‘‘ (F X))
       where

 open sip

 S : ๐“ค ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
 S X = F X โ†’ X

 sns-data : SNS S (๐“ค โŠ” ๐“ฅ)
 sns-data = (ฮน , ฯ , ฮธ)
  where
   ฮน : (A B : ฮฃ S) โ†’ โŸจ A โŸฉ โ‰ƒ โŸจ B โŸฉ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
   ฮน (X , ฮฑ) (Y , ฮฒ) (f , _) = f โˆ˜ ฮฑ โ‰ก ฮฒ โˆ˜ ๐“• f

   ฯ : (A : ฮฃ S) โ†’ ฮน A A (id-โ‰ƒ โŸจ A โŸฉ)
   ฯ (X , ฮฑ) = ฮฑ        โ‰กโŸจ ap (ฮฑ โˆ˜_) (๐“•-id โปยน) โŸฉ
               ฮฑ โˆ˜ ๐“• id โˆŽ

   ฮธ : {X : ๐“ค ฬ‡ } (ฮฑ ฮฒ : S X) โ†’ is-equiv (canonical-map ฮน ฯ ฮฑ ฮฒ)
   ฮธ {X} ฮฑ ฮฒ = ฮณ
    where
     c : ฮฑ โ‰ก ฮฒ โ†’ ฮฑ โ‰ก ฮฒ โˆ˜ ๐“• id
     c = transport (ฮฑ โ‰ก_) (ฯ (X , ฮฒ))

     i : is-equiv c
     i = transport-is-equiv (ฮฑ โ‰ก_) (ฯ (X , ฮฒ))

     h : canonical-map ฮน ฯ ฮฑ ฮฒ โˆผ c
     h (refl _) = ฯ (X , ฮฑ)          โ‰กโŸจ refl-left โปยน โŸฉ
                  refl ฮฑ โˆ™ ฯ (X , ฮฑ) โˆŽ

     ฮณ : is-equiv (canonical-map ฮน ฯ ฮฑ ฮฒ)
     ฮณ = equivs-closed-under-โˆผ i h

 characterization-of-functor-algebra-โ‰ก : is-univalent ๐“ค
   โ†’ (X Y : ๐“ค ฬ‡ ) (ฮฑ : F X โ†’ X) (ฮฒ : F Y โ†’ Y)

   โ†’ ((X , ฮฑ) โ‰ก (Y , ฮฒ))  โ‰ƒ  (ฮฃ f ๊ž‰ (X โ†’ Y), is-equiv f ร— (f โˆ˜ ฮฑ โ‰ก ฮฒ โˆ˜ ๐“• f))

 characterization-of-functor-algebra-โ‰ก ua X Y ฮฑ ฮฒ =
   characterization-of-โ‰ก ua sns-data (X , ฮฑ) (Y , ฮฒ)

type-valued-preorder-S : ๐“ค ฬ‡ โ†’ ๐“ค โŠ” (๐“ฅ โบ) ฬ‡
type-valued-preorder-S {๐“ค} {๐“ฅ} X = ฮฃ _โ‰ค_ ๊ž‰ (X โ†’ X โ†’ ๐“ฅ ฬ‡ )
                                         , ((x : X) โ†’ x โ‰ค x)
                                         ร— ((x y z : X) โ†’ x โ‰ค y โ†’ y โ‰ค z โ†’ x โ‰ค z)

module type-valued-preorder
        (๐“ค ๐“ฅ : Universe)
        (ua : Univalence)
       where

 open sip

 fe : global-dfunext
 fe = univalence-gives-global-dfunext ua

 hfe : global-hfunext
 hfe = univalence-gives-global-hfunext ua

 S : ๐“ค ฬ‡ โ†’ ๐“ค โŠ” (๐“ฅ โบ) ฬ‡
 S = type-valued-preorder-S {๐“ค} {๐“ฅ}

 Type-valued-preorder : (๐“ค โŠ” ๐“ฅ) โบ ฬ‡
 Type-valued-preorder = ฮฃ S

 Ob : ฮฃ S โ†’ ๐“ค ฬ‡
 Ob (X , homX , idX , compX ) = X

 hom : (๐“ง : ฮฃ S) โ†’ Ob ๐“ง โ†’ Ob ๐“ง โ†’ ๐“ฅ ฬ‡
 hom (X , homX , idX , compX) = homX

 ๐’พ๐’น : (๐“ง : ฮฃ S) (x : Ob ๐“ง) โ†’ hom ๐“ง x x
 ๐’พ๐’น (X , homX , idX , compX) = idX

 comp : (๐“ง : ฮฃ S) (x y z : Ob ๐“ง) โ†’ hom ๐“ง x y โ†’ hom ๐“ง y z โ†’ hom ๐“ง x z
 comp (X , homX , idX , compX) = compX

 functorial : (๐“ง ๐“ : ฮฃ S)
            โ†’ (F : Ob ๐“ง โ†’ Ob ๐“)
            โ†’ ((x y : Ob ๐“ง) โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y))
            โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡

 functorial ๐“ง ๐“ F ๐“•' = pidentity ร— pcomposition
  where

   _o_ : {x y z : Ob ๐“ง} โ†’ hom ๐“ง y z โ†’ hom ๐“ง x y โ†’ hom ๐“ง x z
   g o f = comp ๐“ง _ _ _ f g

   _โ–ก_ : {a b c : Ob ๐“} โ†’ hom ๐“ b c โ†’ hom ๐“ a b โ†’ hom ๐“ a c
   g โ–ก f = comp ๐“ _ _ _ f g

   ๐“• : {x y : Ob ๐“ง} โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y)
   ๐“• f = ๐“•' _ _ f

   pidentity = (ฮป x โ†’ ๐“• (๐’พ๐’น ๐“ง x)) โ‰ก (ฮป x โ†’ ๐’พ๐’น ๐“ (F x))

   pcomposition = (ฮป x y z (f : hom ๐“ง x y) (g : hom ๐“ง y z) โ†’ ๐“• (g o f))
                โ‰ก (ฮป x y z (f : hom ๐“ง x y) (g : hom ๐“ง y z) โ†’ ๐“• g โ–ก ๐“• f)

 sns-data : SNS S (๐“ค โŠ” (๐“ฅ โบ))
 sns-data = (ฮน , ฯ , ฮธ)
  where
   ฮน : (๐“ง ๐“ : ฮฃ S) โ†’ โŸจ ๐“ง โŸฉ โ‰ƒ โŸจ ๐“ โŸฉ โ†’ ๐“ค โŠ” (๐“ฅ โบ) ฬ‡
   ฮน ๐“ง ๐“ (F , _) = ฮฃ p ๊ž‰ hom ๐“ง โ‰ก (ฮป x y โ†’ hom ๐“ (F x) (F y))
                       , functorial ๐“ง ๐“ F (ฮป x y โ†’ transport (ฮป - โ†’ - x y) p)

   ฯ : (๐“ง : ฮฃ S) โ†’ ฮน ๐“ง ๐“ง (id-โ‰ƒ โŸจ ๐“ง โŸฉ)
   ฯ ๐“ง = refl (hom ๐“ง) , refl (๐’พ๐’น ๐“ง) , refl (comp ๐“ง)

   ฮธ : {X : ๐“ค ฬ‡ } (s t : S X) โ†’ is-equiv (canonical-map ฮน ฯ s t)
   ฮธ {X} (homX , idX , compX) (homA , idA , compA) = g
    where
     ฯ† = canonical-map ฮน ฯ (homX , idX , compX) (homA , idA , compA)

     ฮณ : codomain ฯ† โ†’ domain ฯ†
     ฮณ (refl _ , refl _ , refl _) = refl _

     ฮท : ฮณ โˆ˜ ฯ† โˆผ id
     ฮท (refl _) = refl _

     ฮต : ฯ† โˆ˜ ฮณ โˆผ id
     ฮต (refl _ , refl _ , refl _) = refl _

     g : is-equiv ฯ†
     g = invertibles-are-equivs ฯ† (ฮณ , ฮท , ฮต)

 lemma : (๐“ง ๐“ : ฮฃ S) (F : Ob ๐“ง โ†’ Ob ๐“)
       โ†’
         (ฮฃ p ๊ž‰ hom ๐“ง โ‰ก (ฮป x y โ†’ hom ๐“ (F x) (F y))
              , functorial ๐“ง ๐“ F (ฮป x y โ†’ transport (ฮป - โ†’ - x y) p))
       โ‰ƒ
         (ฮฃ ๐“• ๊ž‰ ((x y : Ob ๐“ง) โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y))
              , (โˆ€ x y โ†’ is-equiv (๐“• x y))
              ร— functorial ๐“ง ๐“ F ๐“•)

 lemma ๐“ง ๐“ F = ฮณ
  where
   e = (hom ๐“ง โ‰ก ฮป x y โ†’ hom ๐“ (F x) (F y))                            โ‰ƒโŸจ i   โŸฉ
       (โˆ€ x y โ†’ hom ๐“ง x y โ‰ก hom ๐“ (F x) (F y))                        โ‰ƒโŸจ ii  โŸฉ
       (โˆ€ x y โ†’ hom ๐“ง x y โ‰ƒ hom ๐“ (F x) (F y))                        โ‰ƒโŸจ iii โŸฉ
       (โˆ€ x โ†’ ฮฃ ฯ† ๊ž‰ (โˆ€ y โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y))
                  , โˆ€ y โ†’ is-equiv (ฯ† y))                             โ‰ƒโŸจ iv  โŸฉ
       (ฮฃ ๐“• ๊ž‰ ((x y : Ob ๐“ง) โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y))
            , (โˆ€ x y โ†’ is-equiv (๐“• x y)))                             โ– 
    where
     i   = hfunextโ‚‚-โ‰ƒ hfe hfe (hom ๐“ง )  ฮป x y โ†’ hom ๐“ (F x) (F y)
     ii  = ฮ -cong fe fe
            (ฮป x โ†’ ฮ -cong fe fe
            (ฮป y โ†’ univalence-โ‰ƒ (ua ๐“ฅ) (hom ๐“ง x y) (hom ๐“ (F x) (F y))))
     iii = ฮ -cong fe fe (ฮป y โ†’ ฮ ฮฃ-distr-โ‰ƒ)
     iv  = ฮ ฮฃ-distr-โ‰ƒ

   v : (p : hom ๐“ง โ‰ก ฮป x y โ†’ hom ๐“ (F x) (F y))
     โ†’ functorial ๐“ง ๐“ F (ฮป x y โ†’ transport (ฮป - โ†’ - x y) p)
     โ‰ƒ functorial ๐“ง ๐“ F (prโ‚ (โŒœ e โŒ p))

   v (refl _) = Idโ†’Eq _ _ (refl _)

   ฮณ =

    (ฮฃ p ๊ž‰ hom ๐“ง โ‰ก (ฮป x y โ†’ hom ๐“ (F x) (F y))
         , functorial ๐“ง ๐“ F (ฮป x y โ†’ transport (ฮป - โ†’ - x y) p)) โ‰ƒโŸจ vi   โŸฉ

    (ฮฃ p ๊ž‰ hom ๐“ง โ‰ก (ฮป x y โ†’ hom ๐“ (F x) (F y))
         , functorial ๐“ง ๐“ F (prโ‚ (โŒœ e โŒ p)))                     โ‰ƒโŸจ vii  โŸฉ

    (ฮฃ ฯƒ ๊ž‰ (ฮฃ ๐“• ๊ž‰ ((x y : Ob ๐“ง) โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y))
                , (โˆ€ x y โ†’ is-equiv (๐“• x y)))
         , functorial ๐“ง ๐“ F (prโ‚ ฯƒ))                             โ‰ƒโŸจ viii โŸฉ

    (ฮฃ ๐“• ๊ž‰ ((x y : Ob ๐“ง) โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y))
                  , (โˆ€ x y โ†’ is-equiv (๐“• x y))
                  ร— functorial ๐“ง ๐“ F ๐“•)                          โ– 
    where
     vi   = ฮฃ-cong v
     vii  = โ‰ƒ-sym (ฮฃ-change-of-variable _ โŒœ e โŒ (โŒœโŒ-is-equiv e))
     viii = ฮฃ-assoc

 characterization-of-type-valued-preorder-โ‰ก :

      (๐“ง ๐“ : ฮฃ S)
    โ†’
      (๐“ง โ‰ก ๐“)
    โ‰ƒ
      (ฮฃ F ๊ž‰ (Ob ๐“ง โ†’ Ob ๐“)
           , is-equiv F
           ร— (ฮฃ ๐“• ๊ž‰ ((x y : Ob ๐“ง) โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y))
                  , (โˆ€ x y โ†’ is-equiv (๐“• x y))
                  ร— functorial ๐“ง ๐“ F ๐“•))

 characterization-of-type-valued-preorder-โ‰ก ๐“ง ๐“ =

   (๐“ง โ‰ก ๐“)                                                              โ‰ƒโŸจ i  โŸฉ
   (ฮฃ F ๊ž‰ (Ob ๐“ง โ†’ Ob ๐“)
        , is-equiv F
        ร— (ฮฃ p ๊ž‰ hom ๐“ง โ‰ก (ฮป x y โ†’ hom ๐“ (F x) (F y))
               , functorial ๐“ง ๐“ F (ฮป x y โ†’ transport (ฮป - โ†’ - x y) p))) โ‰ƒโŸจ ii โŸฉ
   (ฮฃ F ๊ž‰ (Ob ๐“ง โ†’ Ob ๐“)
     , is-equiv F
     ร— (ฮฃ ๐“• ๊ž‰ ((x y : Ob ๐“ง) โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y))
            , (โˆ€ x y โ†’ is-equiv (๐“• x y))
            ร— functorial ๐“ง ๐“ F ๐“•))                                      โ– 

  where
   i  = characterization-of-โ‰ก (ua ๐“ค) sns-data ๐“ง ๐“
   ii = ฮฃ-cong (ฮป F โ†’ ฮฃ-cong (ฮป _ โ†’ lemma ๐“ง ๐“ F))

module type-valued-preorder-with-axioms
        (๐“ค ๐“ฅ ๐“ฆ : Universe)
        (ua : Univalence)
        (axioms  : (X : ๐“ค ฬ‡ ) โ†’ type-valued-preorder-S {๐“ค} {๐“ฅ} X โ†’ ๐“ฆ ฬ‡ )
        (axiomss : (X : ๐“ค ฬ‡ ) (s : type-valued-preorder-S X) โ†’ is-subsingleton (axioms X s))
       where

 open sip
 open sip-with-axioms
 open type-valued-preorder ๐“ค ๐“ฅ ua

 S' : ๐“ค ฬ‡ โ†’ ๐“ค โŠ” (๐“ฅ โบ) โŠ” ๐“ฆ ฬ‡
 S' X = ฮฃ s ๊ž‰ S X , axioms X s

 sns-data' : SNS S' (๐“ค โŠ” (๐“ฅ โบ))
 sns-data' = add-axioms axioms axiomss sns-data

 characterization-of-type-valued-preorder-โ‰ก-with-axioms :

      (๐“ง' ๐“' : ฮฃ S')
    โ†’
      (๐“ง' โ‰ก ๐“')
    โ‰ƒ
      (ฮฃ F ๊ž‰ (Ob [ ๐“ง' ] โ†’ Ob [ ๐“' ])
           , is-equiv F
           ร— (ฮฃ ๐“• ๊ž‰ ((x y : Ob [ ๐“ง' ]) โ†’ hom [ ๐“ง' ] x y โ†’ hom [ ๐“' ] (F x) (F y))
                    , (โˆ€ x y โ†’ is-equiv (๐“• x y))
                    ร— functorial [ ๐“ง' ] [ ๐“' ] F ๐“•))

 characterization-of-type-valued-preorder-โ‰ก-with-axioms ๐“ง' ๐“' =

  (๐“ง' โ‰ก ๐“')                     โ‰ƒโŸจ i  โŸฉ
  ([ ๐“ง' ] โ‰ƒ[ sns-data ] [ ๐“' ]) โ‰ƒโŸจ ii โŸฉ
  _                              โ– 

  where
   i  = characterization-of-โ‰ก-with-axioms (ua ๐“ค) sns-data axioms axiomss ๐“ง' ๐“'
   ii = ฮฃ-cong (ฮป F โ†’ ฮฃ-cong (ฮป _ โ†’ lemma [ ๐“ง' ] [ ๐“' ] F))

module category
        (๐“ค ๐“ฅ : Universe)
        (ua : Univalence)
       where

 open type-valued-preorder-with-axioms ๐“ค ๐“ฅ (๐“ค โŠ” ๐“ฅ) ua

 fe : global-dfunext
 fe = univalence-gives-global-dfunext ua

 S : ๐“ค ฬ‡ โ†’ ๐“ค โŠ” (๐“ฅ โบ) ฬ‡
 S = type-valued-preorder-S {๐“ค} {๐“ฅ}

 category-axioms : (X : ๐“ค ฬ‡ ) โ†’ S X โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
 category-axioms X (homX , idX , compX) = hom-sets ร— identityl ร— identityr ร— associativity
  where
   _o_ : {x y z : X} โ†’ homX y z โ†’ homX x y โ†’ homX x z
   g o f = compX _ _ _ f g

   hom-sets      = โˆ€ x y โ†’ is-set (homX x y)

   identityl     = โˆ€ x y (f : homX x y) โ†’ f o (idX x) โ‰ก f

   identityr     = โˆ€ x y (f : homX x y) โ†’ (idX y) o f โ‰ก f

   associativity = โˆ€ x y z t (f : homX x y) (g : homX y z) (h : homX z t)
                 โ†’ (h o g) o f โ‰ก h o (g o f)

 category-axioms-subsingleton : (X : ๐“ค ฬ‡ ) (s : S X) โ†’ is-subsingleton (category-axioms X s)
 category-axioms-subsingleton X (homX , idX , compX) ca = ฮณ ca
  where
   i : โˆ€ x y โ†’ is-set (homX x y)
   i = prโ‚ ca

   ฮณ : is-subsingleton (category-axioms X (homX , idX , compX))
   ฮณ = ร—-is-subsingleton ss (ร—-is-subsingleton ls (ร—-is-subsingleton rs as))
    where
     ss = ฮ -is-subsingleton fe
           (ฮป x โ†’ ฮ -is-subsingleton fe
           (ฮป y โ†’ being-set-is-subsingleton fe))

     ls = ฮ -is-subsingleton fe
           (ฮป x โ†’ ฮ -is-subsingleton fe
           (ฮป y โ†’ ฮ -is-subsingleton fe
           (ฮป f โ†’ i x y (compX x x y (idX x) f) f)))

     rs = ฮ -is-subsingleton fe
           (ฮป x โ†’ ฮ -is-subsingleton fe
           (ฮป y โ†’ ฮ -is-subsingleton fe
           (ฮป f โ†’ i x y (compX x y y f (idX y)) f)))

     as = ฮ -is-subsingleton fe
           (ฮป x โ†’ ฮ -is-subsingleton fe
           (ฮป y โ†’ ฮ -is-subsingleton fe
           (ฮป z โ†’ ฮ -is-subsingleton fe
           (ฮป t โ†’ ฮ -is-subsingleton fe
           (ฮป f โ†’ ฮ -is-subsingleton fe
           (ฮป g โ†’ ฮ -is-subsingleton fe
           (ฮป h โ†’ i x t (compX x y t f (compX y z t g h))
                        (compX x z t (compX x y z f g) h))))))))

 Cat : (๐“ค โŠ” ๐“ฅ)โบ ฬ‡
 Cat = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ s ๊ž‰ S X , category-axioms X s

 Ob : Cat โ†’ ๐“ค ฬ‡
 Ob (X , (homX , idX , compX) , _) = X

 hom : (๐“ง : Cat) โ†’ Ob ๐“ง โ†’ Ob ๐“ง โ†’ ๐“ฅ ฬ‡
 hom (X , (homX , idX , compX) , _) = homX

 ๐’พ๐’น : (๐“ง : Cat) (x : Ob ๐“ง) โ†’ hom ๐“ง x x
 ๐’พ๐’น (X , (homX , idX , compX) , _) = idX

 comp : (๐“ง : Cat) (x y z : Ob ๐“ง) (f : hom ๐“ง x y) (g : hom ๐“ง y z) โ†’ hom ๐“ง x z
 comp (X , (homX , idX , compX) , _) = compX

 is-functorial : (๐“ง ๐“ : Cat)
               โ†’ (F : Ob ๐“ง โ†’ Ob ๐“)
               โ†’ ((x y : Ob ๐“ง) โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y))
               โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡

 is-functorial ๐“ง ๐“ F ๐“•' = pidentity ร— pcomposition
  where
   _o_ : {x y z : Ob ๐“ง} โ†’ hom ๐“ง y z โ†’ hom ๐“ง x y โ†’ hom ๐“ง x z
   g o f = comp ๐“ง _ _ _ f g

   _โ–ก_ : {a b c : Ob ๐“} โ†’ hom ๐“ b c โ†’ hom ๐“ a b โ†’ hom ๐“ a c
   g โ–ก f = comp ๐“ _ _ _ f g

   ๐“• : {x y : Ob ๐“ง} โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y)
   ๐“• f = ๐“•' _ _ f

   pidentity    = (ฮป x โ†’ ๐“• (๐’พ๐’น ๐“ง x)) โ‰ก (ฮป x โ†’ ๐’พ๐’น ๐“ (F x))

   pcomposition = (ฮป x y z (f : hom ๐“ง x y) (g : hom ๐“ง y z) โ†’ ๐“• (g o f))
                โ‰ก (ฮป x y z (f : hom ๐“ง x y) (g : hom ๐“ง y z) โ†’ ๐“• g โ–ก ๐“• f)

 _โ‹_ : Cat โ†’ Cat โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡

 ๐“ง โ‹ ๐“ = ฮฃ F ๊ž‰ (Ob ๐“ง โ†’ Ob ๐“)
              , is-equiv F
              ร— (ฮฃ ๐“• ๊ž‰ ((x y : Ob ๐“ง) โ†’ hom ๐“ง x y โ†’ hom ๐“ (F x) (F y))
                     , (โˆ€ x y โ†’ is-equiv (๐“• x y))
                     ร— is-functorial ๐“ง ๐“ F ๐“•)

 Idโ†’EqCat : (๐“ง ๐“ : Cat) โ†’ ๐“ง โ‰ก ๐“ โ†’ ๐“ง โ‹ ๐“
 Idโ†’EqCat ๐“ง ๐“ง (refl ๐“ง) = ๐‘–๐‘‘ (Ob ๐“ง ) ,
                         id-is-equiv (Ob ๐“ง ) ,
                         (ฮป x y โ†’ ๐‘–๐‘‘ (hom ๐“ง x y)) ,
                         (ฮป x y โ†’ id-is-equiv (hom ๐“ง x y)) ,
                         refl (๐’พ๐’น ๐“ง) ,
                         refl (comp ๐“ง)

 characterization-of-category-โ‰ก : (๐“ง ๐“ : Cat) โ†’ (๐“ง โ‰ก ๐“) โ‰ƒ (๐“ง โ‹ ๐“)
 characterization-of-category-โ‰ก = characterization-of-type-valued-preorder-โ‰ก-with-axioms
                                   category-axioms category-axioms-subsingleton

 Idโ†’EqCat-is-equiv : (๐“ง ๐“ : Cat) โ†’ is-equiv (Idโ†’EqCat ๐“ง ๐“)
 Idโ†’EqCat-is-equiv ๐“ง ๐“ = equivs-closed-under-โˆผ
                           (โŒœโŒ-is-equiv (characterization-of-category-โ‰ก ๐“ง ๐“))
                           (ฮณ ๐“ง ๐“)
  where
   ฮณ : (๐“ง ๐“ : Cat) โ†’ Idโ†’EqCat ๐“ง ๐“ โˆผ โŒœ characterization-of-category-โ‰ก ๐“ง ๐“ โŒ
   ฮณ ๐“ง ๐“ง (refl ๐“ง) = refl _

is-inhabited : ๐“ค ฬ‡ โ†’ ๐“ค โบ ฬ‡
is-inhabited {๐“ค} X = (P : ๐“ค ฬ‡ ) โ†’ is-subsingleton P โ†’ (X โ†’ P) โ†’ P

inhabitation-is-subsingleton : global-dfunext
                             โ†’ (X : ๐“ค ฬ‡ )
                             โ†’ is-subsingleton (is-inhabited X)

inhabitation-is-subsingleton fe X =
 ฮ -is-subsingleton fe
   (ฮป P โ†’ ฮ -is-subsingleton fe
   (ฮป (s : is-subsingleton P) โ†’ ฮ -is-subsingleton fe
   (ฮป (f : X โ†’ P) โ†’ s)))

inhabited-intro : {X : ๐“ค ฬ‡ } โ†’ X โ†’ is-inhabited X
inhabited-intro x = ฮป P s f โ†’ f x

inhabited-recursion : {X P : ๐“ค ฬ‡ } โ†’ is-subsingleton P โ†’ (X โ†’ P) โ†’ is-inhabited X โ†’ P
inhabited-recursion s f ฯ† = ฯ† (codomain f) s f

inhabited-recursion-computation : {X P : ๐“ค ฬ‡ }
                                  (i : is-subsingleton P)
                                  (f : X โ†’ P)
                                  (x : X)
                                โ†’ inhabited-recursion i f (inhabited-intro x) โ‰ก f x

inhabited-recursion-computation i f x = refl (f x)

inhabited-induction : global-dfunext
                    โ†’ {X : ๐“ค ฬ‡ } {P : is-inhabited X โ†’ ๐“ค ฬ‡ }
                      (i : (s : is-inhabited X) โ†’ is-subsingleton (P s))
                      (f : (x : X) โ†’ P (inhabited-intro x))
                    โ†’ (s : is-inhabited X) โ†’ P s

inhabited-induction fe {X} {P} i f s = ฯ†' s
 where
  ฯ† : X โ†’ P s
  ฯ† x = transport P (inhabitation-is-subsingleton fe X (inhabited-intro x) s) (f x)

  ฯ†' : is-inhabited X โ†’ P s
  ฯ†' = inhabited-recursion (i s) ฯ†

inhabited-computation : (fe : global-dfunext) {X : ๐“ค ฬ‡ } {P : is-inhabited X โ†’ ๐“ค ฬ‡ }
                        (i : (s : is-inhabited X) โ†’ is-subsingleton (P s))
                        (f : (x : X) โ†’ P (inhabited-intro x))
                        (x : X)
                      โ†’ inhabited-induction fe i f (inhabited-intro x) โ‰ก f x

inhabited-computation fe i f x = i (inhabited-intro x)
                                   (inhabited-induction fe i f (inhabited-intro x))
                                   (f x)

inhabited-subsingletons-are-pointed : (P : ๐“ค ฬ‡ )
                                    โ†’ is-subsingleton P โ†’ is-inhabited P โ†’ P

inhabited-subsingletons-are-pointed P s = inhabited-recursion s (๐‘–๐‘‘ P)

inhabited-functorial : global-dfunext โ†’ (X : ๐“ค โบ ฬ‡ ) (Y : ๐“ค ฬ‡ )
                     โ†’ (X โ†’ Y) โ†’ is-inhabited X โ†’ is-inhabited Y

inhabited-functorial fe X Y f = inhabited-recursion
                                  (inhabitation-is-subsingleton fe Y)
                                  (inhabited-intro โˆ˜ f)

image' : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ (๐“ค โŠ” ๐“ฅ)โบ ฬ‡
image' f = ฮฃ y ๊ž‰ codomain f , is-inhabited (ฮฃ x ๊ž‰ domain f , f x โ‰ก y)

restriction' : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
             โ†’ image' f โ†’ Y

restriction' f (y , _) = y

corestriction' : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
               โ†’ X โ†’ image' f

corestriction' f x = f x , inhabited-intro (x , refl (f x))

is-surjection' : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ (๐“ค โŠ” ๐“ฅ)โบ ฬ‡
is-surjection' f = (y : codomain f) โ†’ is-inhabited (ฮฃ x ๊ž‰ domain f , f x โ‰ก y)

record subsingleton-truncations-exist : ๐“คฯ‰ where
 field
  โˆฅ_โˆฅ                  : {๐“ค : Universe} โ†’ ๐“ค ฬ‡ โ†’ ๐“ค ฬ‡
  โˆฅโˆฅ-is-subsingleton   : {๐“ค : Universe} {X : ๐“ค ฬ‡ } โ†’ is-subsingleton โˆฅ X โˆฅ
  โˆฃ_โˆฃ                  : {๐“ค : Universe} {X : ๐“ค ฬ‡ } โ†’ X โ†’ โˆฅ X โˆฅ
  โˆฅโˆฅ-recursion         : {๐“ค ๐“ฅ : Universe} {X : ๐“ค ฬ‡ } {P : ๐“ฅ ฬ‡ }
                       โ†’ is-subsingleton P โ†’ (X โ†’ P) โ†’ โˆฅ X โˆฅ โ†’ P
 infix 0 โˆฅ_โˆฅ

module basic-truncation-development
        (pt  : subsingleton-truncations-exist)
        (hfe : global-hfunext)
       where

  open subsingleton-truncations-exist pt public

  hunapply : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {f g : ฮ  A} โ†’ f โˆผ g โ†’ f โ‰ก g
  hunapply = hfunext-gives-dfunext hfe

  โˆฅโˆฅ-recursion-computation : {X : ๐“ค ฬ‡ } {P :  ๐“ฅ ฬ‡ }
                           โ†’ (i : is-subsingleton P)
                           โ†’ (f : X โ†’ P)
                           โ†’ (x : X)
                           โ†’ โˆฅโˆฅ-recursion i f โˆฃ x โˆฃ โ‰ก f x

  โˆฅโˆฅ-recursion-computation i f x = i (โˆฅโˆฅ-recursion i f โˆฃ x โˆฃ) (f x)

  โˆฅโˆฅ-induction : {X : ๐“ค ฬ‡ } {P : โˆฅ X โˆฅ โ†’ ๐“ฅ ฬ‡ }
              โ†’ ((s : โˆฅ X โˆฅ) โ†’ is-subsingleton (P s))
              โ†’ ((x : X) โ†’ P โˆฃ x โˆฃ)
              โ†’ (s : โˆฅ X โˆฅ) โ†’ P s

  โˆฅโˆฅ-induction {๐“ค} {๐“ฅ} {X} {P} i f s = ฯ†' s
   where
    ฯ† : X โ†’ P s
    ฯ† x = transport P (โˆฅโˆฅ-is-subsingleton โˆฃ x โˆฃ s) (f x)
    ฯ†' : โˆฅ X โˆฅ โ†’ P s
    ฯ†' = โˆฅโˆฅ-recursion (i s) ฯ†

  โˆฅโˆฅ-computation : {X : ๐“ค ฬ‡ } {P : โˆฅ X โˆฅ โ†’ ๐“ฅ ฬ‡ }
                 โ†’ (i : (s : โˆฅ X โˆฅ) โ†’ is-subsingleton (P s))
                 โ†’ (f : (x : X) โ†’ P โˆฃ x โˆฃ)
                 โ†’ (x : X)
                 โ†’ โˆฅโˆฅ-induction i f โˆฃ x โˆฃ โ‰ก f x

  โˆฅโˆฅ-computation i f x = i โˆฃ x โˆฃ (โˆฅโˆฅ-induction i f โˆฃ x โˆฃ) (f x)

  โˆฅโˆฅ-functor : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ โˆฅ X โˆฅ โ†’ โˆฅ Y โˆฅ
  โˆฅโˆฅ-functor f = โˆฅโˆฅ-recursion โˆฅโˆฅ-is-subsingleton (ฮป x โ†’ โˆฃ f x โˆฃ)

  โˆฅโˆฅ-agrees-with-inhabitation : (X : ๐“ค ฬ‡ ) โ†’ โˆฅ X โˆฅ โ‡” is-inhabited X
  โˆฅโˆฅ-agrees-with-inhabitation X = a , b
   where
    a : โˆฅ X โˆฅ โ†’ is-inhabited X
    a = โˆฅโˆฅ-recursion (inhabitation-is-subsingleton hunapply X) inhabited-intro

    b : is-inhabited X โ†’ โˆฅ X โˆฅ
    b = inhabited-recursion โˆฅโˆฅ-is-subsingleton โˆฃ_โˆฃ

  _โˆจ_ : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
  A โˆจ B = โˆฅ A + B โˆฅ

  infixl 20 _โˆจ_

  โˆƒ : {X : ๐“ค ฬ‡ } โ†’ (X โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
  โˆƒ A = โˆฅ ฮฃ A โˆฅ

  -โˆƒ : {๐“ค ๐“ฅ : Universe} (X : ๐“ค ฬ‡ ) (Y : X โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
  -โˆƒ X Y = โˆƒ Y

  syntax -โˆƒ A (ฮป x โ†’ b) = โˆƒ x ๊ž‰ A , b

  infixr -1 -โˆƒ

  โˆจ-is-subsingleton : {A : ๐“ค ฬ‡ } {B : ๐“ฅ ฬ‡ } โ†’ is-subsingleton (A โˆจ B)
  โˆจ-is-subsingleton = โˆฅโˆฅ-is-subsingleton

  โˆƒ-is-subsingleton : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } โ†’ is-subsingleton (โˆƒ A)
  โˆƒ-is-subsingleton = โˆฅโˆฅ-is-subsingleton

  image : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
  image f = ฮฃ y ๊ž‰ codomain f , โˆƒ x ๊ž‰ domain f , f x โ‰ก y

  restriction : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
              โ†’ image f โ†’ Y

  restriction f (y , _) = y

  corestriction : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                โ†’ X โ†’ image f

  corestriction f x = f x , โˆฃ (x , refl (f x)) โˆฃ

  is-surjection : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } โ†’ (X โ†’ Y) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
  is-surjection f = (y : codomain f) โ†’ โˆƒ x ๊ž‰ domain f , f x โ‰ก y

  being-surjection-is-subsingleton : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                                   โ†’ is-subsingleton (is-surjection f)

  being-surjection-is-subsingleton f = ฮ -is-subsingleton hunapply
                                        (ฮป y โ†’ โˆƒ-is-subsingleton)

  corestriction-surjection : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                           โ†’ is-surjection (corestriction f)

  corestriction-surjection f (y , s) = โˆฅโˆฅ-functor g s
   where
    g : (ฮฃ x ๊ž‰ domain f , f x โ‰ก y) โ†’ ฮฃ x ๊ž‰ domain f , corestriction f x โ‰ก (y , s)
    g (x , p) = x , to-subtype-โ‰ก (ฮป _ โ†’ โˆƒ-is-subsingleton) p

  surjection-induction : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                       โ†’ is-surjection f
                       โ†’ (P : Y โ†’ ๐“ฆ ฬ‡ )
                       โ†’ ((y : Y) โ†’ is-subsingleton (P y))
                       โ†’ ((x : X) โ†’ P (f x))
                       โ†’ (y : Y) โ†’ P y

  surjection-induction f i P j ฮฑ y = โˆฅโˆฅ-recursion (j y) ฯ† (i y)
   where
    ฯ† : fiber f y โ†’ P y
    ฯ† (x , r) = transport P r (ฮฑ x)

  โˆฃโˆฃ-is-surjection : (X : ๐“ค ฬ‡ ) โ†’ is-surjection (ฮป (x : X) โ†’ โˆฃ x โˆฃ)
  โˆฃโˆฃ-is-surjection X s = ฮณ
   where
    f : X โ†’ โˆƒ x ๊ž‰ X , โˆฃ x โˆฃ โ‰ก s
    f x = โˆฃ (x , โˆฅโˆฅ-is-subsingleton โˆฃ x โˆฃ s) โˆฃ

    ฮณ : โˆƒ x ๊ž‰ X , โˆฃ x โˆฃ โ‰ก s
    ฮณ = โˆฅโˆฅ-recursion โˆฅโˆฅ-is-subsingleton f s

  singletons-are-inhabited : (X : ๐“ค ฬ‡ )
                           โ†’ is-singleton X
                           โ†’ โˆฅ X โˆฅ

  singletons-are-inhabited X s = โˆฃ center X s โˆฃ

  inhabited-subsingletons-are-singletons : (X : ๐“ค ฬ‡ )
                                         โ†’ โˆฅ X โˆฅ
                                         โ†’ is-subsingleton X
                                         โ†’ is-singleton X

  inhabited-subsingletons-are-singletons X t i = c , ฯ†
   where
    c : X
    c = โˆฅโˆฅ-recursion i (๐‘–๐‘‘ X) t

    ฯ† : (x : X) โ†’ c โ‰ก x
    ฯ† = i c

  singleton-iff-inhabited-subsingleton : (X : ๐“ค ฬ‡ )
                                       โ†’ is-singleton X
                                       โ‡” (โˆฅ X โˆฅ ร— is-subsingleton X)

  singleton-iff-inhabited-subsingleton X =

    (ฮป (s : is-singleton X) โ†’ singletons-are-inhabited     X s ,
                              singletons-are-subsingletons X s) ,
    ฮฃ-induction (inhabited-subsingletons-are-singletons X)

  equiv-iff-embedding-and-surjection : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                                     โ†’  is-equiv f
                                     โ‡” (is-embedding f ร— is-surjection f)

  equiv-iff-embedding-and-surjection f = (a , b)
   where
    a : is-equiv f โ†’ is-embedding f ร— is-surjection f
    a e = (ฮป y โ†’ singletons-are-subsingletons (fiber f y) (e y)) ,
          (ฮป y โ†’ singletons-are-inhabited     (fiber f y) (e y))

    b : is-embedding f ร— is-surjection f โ†’ is-equiv f
    b (e , s) y = inhabited-subsingletons-are-singletons (fiber f y) (s y) (e y)

  equiv-โ‰ก-embedding-and-surjection : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                                   โ†’ propext (๐“ค โŠ” ๐“ฅ)
                                   โ†’  is-equiv f
                                   โ‰ก (is-embedding f ร— is-surjection f)

  equiv-โ‰ก-embedding-and-surjection f pe =
    pe (being-equiv-is-subsingleton hunapply hunapply f)
       (ร—-is-subsingleton
         (being-embedding-is-subsingleton hunapply f)
         (being-surjection-is-subsingleton f))
       (lr-implication (equiv-iff-embedding-and-surjection f))
       (rl-implication (equiv-iff-embedding-and-surjection f))

fix : {X : ๐“ค ฬ‡ } โ†’ (X โ†’ X) โ†’ ๐“ค ฬ‡
fix f = ฮฃ x ๊ž‰ domain f , f x โ‰ก x

from-fix : {X : ๐“ค ฬ‡ } (f : X โ†’ X)
         โ†’ fix f โ†’ X

from-fix f = prโ‚

to-fix : {X : ๐“ค ฬ‡ } (f : X โ†’ X) โ†’ wconstant f
       โ†’ X โ†’ fix f

to-fix f ฮบ x = f x , ฮบ (f x) x

fix-is-subsingleton : {X : ๐“ค ฬ‡ } (f : X โ†’ X)
                    โ†’ wconstant f โ†’ is-subsingleton (fix f)

fix-is-subsingleton {๐“ค} {X} f ฮบ = ฮณ
 where
  a : (y x : X) โ†’ (f x โ‰ก x) โ‰ƒ (f y โ‰ก x)
  a y x = transport (_โ‰ก x) (ฮบ x y) , transport-is-equiv (_โ‰ก x) (ฮบ x y)

  b : (y : X) โ†’ fix f โ‰ƒ singleton-type' (f y)
  b y = ฮฃ-cong (a y)

  c : X โ†’ is-singleton (fix f)
  c y = equiv-to-singleton (b y) (singleton-types'-are-singletons X (f y))

  d : fix f โ†’ is-singleton (fix f)
  d = c โˆ˜ from-fix f

  ฮณ : is-subsingleton (fix f)
  ฮณ = subsingleton-criterion d

choice-function : ๐“ค ฬ‡ โ†’ ๐“ค โบ ฬ‡
choice-function X = is-inhabited X โ†’ X

wconstant-endomap-gives-choice-function : {X : ๐“ค ฬ‡ }
                                        โ†’ wconstant-endomap X โ†’ choice-function X

wconstant-endomap-gives-choice-function {๐“ค} {X} (f , ฮบ) = from-fix f โˆ˜ ฮณ
 where
  ฮณ : is-inhabited X โ†’ fix f
  ฮณ = inhabited-recursion (fix-is-subsingleton f ฮบ) (to-fix f ฮบ)

choice-function-gives-wconstant-endomap : global-dfunext
                                        โ†’ {X : ๐“ค ฬ‡ }
                                        โ†’ choice-function X โ†’ wconstant-endomap X

choice-function-gives-wconstant-endomap fe {X} c = f , ฮบ
 where
  f : X โ†’ X
  f = c โˆ˜ inhabited-intro

  ฮบ : wconstant f
  ฮบ x y = ap c (inhabitation-is-subsingleton fe X (inhabited-intro x)
                                                  (inhabited-intro y))

module find-hidden-root where

 open basic-arithmetic-and-order public

 ฮผฯ : (f : โ„• โ†’ โ„•) โ†’ root f โ†’ root f
 ฮผฯ f r = minimal-root-is-root f (root-gives-minimal-root f r)

 ฮผฯ-root : (f : โ„• โ†’ โ„•) โ†’ root f โ†’ โ„•
 ฮผฯ-root f r = prโ‚ (ฮผฯ f r)

 ฮผฯ-root-is-root : (f : โ„• โ†’ โ„•) (r : root f) โ†’ f (ฮผฯ-root f r) โ‰ก 0
 ฮผฯ-root-is-root f r = prโ‚‚ (ฮผฯ f r)

 ฮผฯ-root-minimal : (f : โ„• โ†’ โ„•) (m : โ„•) (p : f m โ‰ก 0)
                 โ†’ (n : โ„•) โ†’ f n โ‰ก 0 โ†’ ฮผฯ-root f (m , p) โ‰ค n

 ฮผฯ-root-minimal f m p n q = not-<-gives-โ‰ฅ (ฮผฯ-root f (m , p)) n ฮณ
  where
   ฯ† : ยฌ(f n โ‰ข 0) โ†’ ยฌ(n < ฮผฯ-root f (m , p))
   ฯ† = contrapositive (prโ‚‚(prโ‚‚ (root-gives-minimal-root f (m , p))) n)

   ฮณ : ยฌ (n < ฮผฯ-root f (m , p))
   ฮณ = ฯ† (dni (f n โ‰ก 0) q)

 ฮผฯ-wconstant : (f : โ„• โ†’ โ„•) โ†’ wconstant (ฮผฯ f)
 ฮผฯ-wconstant f (n , p) (n' , p') = r
  where
   m m' : โ„•
   m  = ฮผฯ-root f (n , p)
   m' = ฮผฯ-root f (n' , p')

   l : m โ‰ค m'
   l = ฮผฯ-root-minimal f n p m' (ฮผฯ-root-is-root f (n' , p'))

   l' : m' โ‰ค m
   l' = ฮผฯ-root-minimal f n' p' m (ฮผฯ-root-is-root f (n , p))

   q : m โ‰ก m'
   q = โ‰ค-anti _ _ l l'

   r : ฮผฯ f (n , p) โ‰ก ฮผฯ f (n' , p')
   r = to-subtype-โ‰ก (ฮป _ โ†’ โ„•-is-set (f _) 0) q

 find-existing-root : (f : โ„• โ†’ โ„•) โ†’ is-inhabited (root f) โ†’ root f
 find-existing-root f = h โˆ˜ g
   where
    ฮณ : root f โ†’ fix (ฮผฯ f)
    ฮณ = to-fix (ฮผฯ f) (ฮผฯ-wconstant f)

    g : is-inhabited (root f) โ†’ fix (ฮผฯ f)
    g = inhabited-recursion (fix-is-subsingleton (ฮผฯ f) (ฮผฯ-wconstant f)) ฮณ

    h : fix (ฮผฯ f) โ†’ root f
    h = from-fix (ฮผฯ f)

 module find-existing-root-example where

  f : โ„• โ†’ โ„•
  f 0 = 1
  f 1 = 1
  f 2 = 0
  f 3 = 1
  f 4 = 0
  f 5 = 1
  f 6 = 1
  f 7 = 0
  f (succ (succ (succ (succ (succ (succ (succ (succ x)))))))) = x

  root-existence : is-inhabited (root f)
  root-existence = inhabited-intro (8 , refl 0)

  r : root f
  r = find-existing-root f root-existence

  x : โ„•
  x = prโ‚ r

  x-is-root : f x โ‰ก 0
  x-is-root = prโ‚‚ r

  p : x โ‰ก 2
  p = refl _

module exit-โˆฅโˆฅ
        (pt  : subsingleton-truncations-exist)
        (hfe : global-hfunext)
       where

 open basic-truncation-development pt hfe
 open find-hidden-root

 find-โˆฅโˆฅ-existing-root : (f : โ„• โ†’ โ„•)
                       โ†’ (โˆƒ n ๊ž‰ โ„• , f n โ‰ก 0)
                       โ†’  ฮฃ n ๊ž‰ โ„• , f n โ‰ก 0

 find-โˆฅโˆฅ-existing-root f = k
  where
   ฮณ : root f โ†’ fix (ฮผฯ f)
   ฮณ = to-fix (ฮผฯ f) (ฮผฯ-wconstant f)

   g : โˆฅ root f โˆฅ โ†’ fix (ฮผฯ f)
   g = โˆฅโˆฅ-recursion (fix-is-subsingleton (ฮผฯ f) (ฮผฯ-wconstant f)) ฮณ

   h : fix (ฮผฯ f) โ†’ root f
   h = from-fix (ฮผฯ f)

   k : โˆฅ root f โˆฅ โ†’ root f
   k = h โˆ˜ g

 module find-โˆฅโˆฅ-existing-root-example where

  f : โ„• โ†’ โ„•
  f 0 = 1
  f 1 = 1
  f 2 = 0
  f 3 = 1
  f 4 = 0
  f 5 = 1
  f 6 = 1
  f 7 = 0
  f (succ (succ (succ (succ (succ (succ (succ (succ x)))))))) = x

  root-โˆฅโˆฅ-existence : โˆฅ root f โˆฅ
  root-โˆฅโˆฅ-existence = โˆฃ 8 , refl 0 โˆฃ

  r : root f
  r = find-โˆฅโˆฅ-existing-root f root-โˆฅโˆฅ-existence

  x : โ„•
  x = prโ‚ r

  x-is-root : f x โ‰ก 0
  x-is-root = prโ‚‚ r

  NB : find-โˆฅโˆฅ-existing-root f
     โ‰ก from-fix (ฮผฯ f) โˆ˜ โˆฅโˆฅ-recursion
                          (fix-is-subsingleton (ฮผฯ f) (ฮผฯ-wconstant f))
                          (to-fix (ฮผฯ f) (ฮผฯ-wconstant f))
  NB = refl _

  p : x โ‰ก 2
  p = ap (prโ‚ โˆ˜ from-fix (ฮผฯ f))
         (โˆฅโˆฅ-recursion-computation
            (fix-is-subsingleton (ฮผฯ f) (ฮผฯ-wconstant f))
            (to-fix (ฮผฯ f) (ฮผฯ-wconstant f))
            (8 , refl _))

 wconstant-endomap-gives-โˆฅโˆฅ-choice-function : {X : ๐“ค ฬ‡ }
                                            โ†’ wconstant-endomap X
                                            โ†’ (โˆฅ X โˆฅ โ†’ X)

 wconstant-endomap-gives-โˆฅโˆฅ-choice-function {๐“ค} {X} (f , ฮบ) = from-fix f โˆ˜ ฮณ
  where
   ฮณ : โˆฅ X โˆฅ โ†’ fix f
   ฮณ = โˆฅโˆฅ-recursion (fix-is-subsingleton f ฮบ) (to-fix f ฮบ)

 โˆฅโˆฅ-choice-function-gives-wconstant-endomap : {X : ๐“ค ฬ‡ }
                                            โ†’ (โˆฅ X โˆฅ โ†’ X)
                                            โ†’ wconstant-endomap X

 โˆฅโˆฅ-choice-function-gives-wconstant-endomap {๐“ค} {X} c = f , ฮบ
  where
   f : X โ†’ X
   f = c โˆ˜ โˆฃ_โˆฃ

   ฮบ : wconstant f
   ฮบ x y = ap c (โˆฅโˆฅ-is-subsingleton โˆฃ x โˆฃ โˆฃ y โˆฃ)

 โˆฅโˆฅ-recursion-set : (X : ๐“ค ฬ‡ ) (Y : ๐“ฅ ฬ‡ )
                  โ†’ is-set Y
                  โ†’ (f : X โ†’ Y)
                  โ†’ wconstant f
                  โ†’ โˆฅ X โˆฅ โ†’ Y

 โˆฅโˆฅ-recursion-set {๐“ค} {๐“ฅ} X Y s f ฮบ = f'
  where
   ฯˆ : (y y' : Y) โ†’  (ฮฃ x ๊ž‰ X , f x โ‰ก y) โ†’ (ฮฃ x' ๊ž‰ X , f x' โ‰ก y') โ†’ y โ‰ก y'
   ฯˆ y y' (x , r) (x' , r') = y    โ‰กโŸจ r โปยน   โŸฉ
                              f x  โ‰กโŸจ ฮบ x x' โŸฉ
                              f x' โ‰กโŸจ r'     โŸฉ
                              y'   โˆŽ

   ฯ† : (y y' : Y) โ†’ (โˆƒ x ๊ž‰ X , f x โ‰ก y) โ†’ (โˆƒ x' ๊ž‰ X , f x' โ‰ก y') โ†’ y โ‰ก y'
   ฯ† y y' u u' = โˆฅโˆฅ-recursion (s y y') (ฮป - โ†’ โˆฅโˆฅ-recursion (s y y') (ฯˆ y y' -) u') u

   P : ๐“ค โŠ” ๐“ฅ ฬ‡
   P = image f

   i : is-subsingleton P
   i (y , u) (y' , u') = to-subtype-โ‰ก (ฮป _ โ†’ โˆƒ-is-subsingleton) (ฯ† y y' u u')

   g : โˆฅ X โˆฅ โ†’ P
   g = โˆฅโˆฅ-recursion i (corestriction f)

   h : P โ†’ Y
   h = restriction f

   f' : โˆฅ X โˆฅ โ†’ Y
   f' = h โˆ˜ g

module noetherian-local-ring
        (pt : subsingleton-truncations-exist)
        {๐“ค : Universe}
        (ua : Univalence)
       where

 open ring {๐“ค} ua
 open basic-truncation-development pt hfe
 open โ„•-order

 is-left-ideal : (๐“ก : Rng) โ†’ ๐“Ÿ โŸจ ๐“ก โŸฉ โ†’ ๐“ค ฬ‡
 is-left-ideal (R , (_+_ , _ยท_) , (i , ii , iii , (O , _) , _)) I =

     (O โˆˆ I)
   ร— ((x y : R) โ†’ x โˆˆ I โ†’ y โˆˆ I โ†’ (x + y) โˆˆ I)
   ร— ((x y : R) โ†’ y โˆˆ I โ†’ (x ยท y) โˆˆ I)

 is-left-noetherian : (๐“ก : Rng) โ†’ ๐“ค โบ ฬ‡
 is-left-noetherian ๐“ก = (I : โ„• โ†’ ๐“Ÿ โŸจ ๐“ก โŸฉ)
                      โ†’ ((n : โ„•) โ†’ is-left-ideal ๐“ก (I n))
                      โ†’ ((n : โ„•) โ†’ I n โŠ† I (succ n))
                      โ†’ โˆƒ m ๊ž‰ โ„• , ((n : โ„•) โ†’ m โ‰ค n โ†’ I m โ‰ก I n)

 LNRng : ๐“ค โบ ฬ‡
 LNRng = ฮฃ ๐“ก ๊ž‰ Rng , is-left-noetherian ๐“ก

 being-ln-is-subsingleton : (๐“ก : Rng) โ†’ is-subsingleton (is-left-noetherian ๐“ก)
 being-ln-is-subsingleton ๐“ก = ฮ -is-subsingleton fe
                               (ฮป I โ†’ ฮ -is-subsingleton fe
                               (ฮป _ โ†’ ฮ -is-subsingleton fe
                               (ฮป _ โ†’ โˆƒ-is-subsingleton)))

 forget-LN : LNRng โ†’ Rng
 forget-LN (๐“ก , _) = ๐“ก

 forget-LN-is-embedding : is-embedding forget-LN
 forget-LN-is-embedding = prโ‚-is-embedding being-ln-is-subsingleton

 _โ‰…[LNRng]_ : LNRng โ†’ LNRng โ†’ ๐“ค ฬ‡

 ((R , (_+_ , _ยท_) , _) , _) โ‰…[LNRng] ((R' , (_+'_ , _ยท'_) , _) , _) =

                             ฮฃ f ๊ž‰ (R โ†’ R')
                                 , is-equiv f
                                 ร— ((ฮป x y โ†’ f (x + y)) โ‰ก (ฮป x y โ†’ f x +' f y))
                                 ร— ((ฮป x y โ†’ f (x ยท y)) โ‰ก (ฮป x y โ†’ f x ยท' f y))

 NB : (๐“ก ๐“ก' : LNRng) โ†’ (๐“ก โ‰…[LNRng] ๐“ก') โ‰ก (forget-LN ๐“ก โ‰…[Rng] forget-LN ๐“ก')
 NB ๐“ก ๐“ก' = refl _

 characterization-of-LNRng-โ‰ก : (๐“ก ๐“ก' : LNRng) โ†’ (๐“ก โ‰ก ๐“ก') โ‰ƒ (๐“ก โ‰…[LNRng] ๐“ก')
 characterization-of-LNRng-โ‰ก ๐“ก ๐“ก' = (๐“ก โ‰ก ๐“ก')                    โ‰ƒโŸจ i  โŸฉ
                                    (forget-LN ๐“ก โ‰ก forget-LN ๐“ก') โ‰ƒโŸจ ii โŸฉ
                                    (๐“ก โ‰…[LNRng] ๐“ก')              โ– 
   where
    i = โ‰ƒ-sym (embedding-criterion-converse forget-LN
                 forget-LN-is-embedding ๐“ก ๐“ก')
    ii = characterization-of-rng-โ‰ก (forget-LN ๐“ก) (forget-LN ๐“ก')

 isomorphic-LNRng-transport : (A : LNRng โ†’ ๐“ฅ ฬ‡ ) (๐“ก ๐“ก' : LNRng)
                            โ†’ ๐“ก โ‰…[LNRng] ๐“ก' โ†’ A ๐“ก โ†’ A ๐“ก'

 isomorphic-LNRng-transport A ๐“ก ๐“ก' i a = a'
  where
   p : ๐“ก โ‰ก ๐“ก'
   p = โŒœ โ‰ƒ-sym (characterization-of-LNRng-โ‰ก ๐“ก ๐“ก') โŒ i

   a' : A ๐“ก'
   a' = transport A p a

 is-commutative : Rng โ†’ ๐“ค ฬ‡
 is-commutative (R , (_+_ , _ยท_) , _) = (x y : R) โ†’ x ยท y โ‰ก y ยท x

 being-commutative-is-subsingleton : (๐“ก : Rng) โ†’ is-subsingleton (is-commutative ๐“ก)
 being-commutative-is-subsingleton (R , (_+_ , _ยท_) , i , ii-vii) =
   ฮ -is-subsingleton fe
    (ฮป x โ†’ ฮ -is-subsingleton fe
    (ฮป y โ†’ i (x ยท y) (y ยท x)))

 is-Noetherian-Local : Ring โ†’ ๐“ค โบ ฬ‡
 is-Noetherian-Local (R , (๐Ÿ , _+_ , _ยท_) , i-vii , viii) = is-commutative ๐“ก
                                                          ร— is-noetherian
                                                          ร— is-local
  where
   ๐“ก : Rng
   ๐“ก = (R , (_+_ , _ยท_) , i-vii)

   is-ideal      = is-left-ideal ๐“ก
   is-noetherian = is-left-noetherian ๐“ก

   is-proper-ideal : ๐“Ÿ R โ†’ ๐“ค ฬ‡
   is-proper-ideal I = is-ideal I ร— (โˆƒ x ๊ž‰ โŸจ ๐“ก โŸฉ , x โˆ‰ I)

   is-local = โˆƒ! I ๊ž‰ ๐“Ÿ R , is-proper-ideal I
                         ร— ((J : ๐“Ÿ R) โ†’ is-proper-ideal J โ†’ J โŠ† I)

 being-NL-is-subsingleton : (๐“ก : Ring) โ†’ is-subsingleton (is-Noetherian-Local ๐“ก)
 being-NL-is-subsingleton (R , (๐Ÿ , _+_ , _ยท_) , i-vii , viii) =

    ร—-is-subsingleton (being-commutative-is-subsingleton ๐“ก)
   (ร—-is-subsingleton (being-ln-is-subsingleton ๐“ก)
                      (โˆƒ!-is-subsingleton _ fe))
  where
   ๐“ก : Rng
   ๐“ก = (R , (_+_ , _ยท_) , i-vii)

 NL-Ring : ๐“ค โบ ฬ‡
 NL-Ring = ฮฃ ๐“ก ๊ž‰ Ring , is-Noetherian-Local ๐“ก

 _โ‰…[NL]_ : NL-Ring โ†’ NL-Ring โ†’ ๐“ค ฬ‡

 ((R , (๐Ÿ , _+_ , _ยท_) , _) , _) โ‰…[NL] ((R' , (๐Ÿ' , _+'_ , _ยท'_) , _) , _) =

                                 ฮฃ f ๊ž‰ (R โ†’ R')
                                     , is-equiv f
                                     ร— (f ๐Ÿ โ‰ก ๐Ÿ')
                                     ร— ((ฮป x y โ†’ f (x + y)) โ‰ก (ฮป x y โ†’ f x +' f y))
                                     ร— ((ฮป x y โ†’ f (x ยท y)) โ‰ก (ฮป x y โ†’ f x ยท' f y))

 forget-NL : NL-Ring โ†’ Ring
 forget-NL (๐“ก , _) = ๐“ก

 forget-NL-is-embedding : is-embedding forget-NL
 forget-NL-is-embedding = prโ‚-is-embedding being-NL-is-subsingleton

 NB' : (๐“ก ๐“ก' : NL-Ring) โ†’ (๐“ก โ‰…[NL] ๐“ก') โ‰ก (forget-NL ๐“ก โ‰…[Ring] forget-NL ๐“ก')
 NB' ๐“ก ๐“ก' = refl _

 characterization-of-NL-ring-โ‰ก : (๐“ก ๐“ก' : NL-Ring) โ†’ (๐“ก โ‰ก ๐“ก') โ‰ƒ (๐“ก โ‰…[NL] ๐“ก')
 characterization-of-NL-ring-โ‰ก ๐“ก ๐“ก' = (๐“ก โ‰ก ๐“ก')                     โ‰ƒโŸจ i  โŸฉ
                                       (forget-NL ๐“ก โ‰ก forget-NL ๐“ก') โ‰ƒโŸจ ii โŸฉ
                                       (๐“ก โ‰…[NL] ๐“ก')                 โ– 
    where
     i  = โ‰ƒ-sym (embedding-criterion-converse forget-NL
                   forget-NL-is-embedding ๐“ก ๐“ก')
     ii = characterization-of-ring-โ‰ก (forget-NL ๐“ก) (forget-NL ๐“ก')

 isomorphic-NL-Ring-transport : (A : NL-Ring โ†’ ๐“ฅ ฬ‡ ) (๐“ก ๐“ก' : NL-Ring)
                              โ†’ ๐“ก โ‰…[NL] ๐“ก' โ†’ A ๐“ก โ†’ A ๐“ก'

 isomorphic-NL-Ring-transport A ๐“ก ๐“ก' i a = a'
  where
   p : ๐“ก โ‰ก ๐“ก'
   p = โŒœ โ‰ƒ-sym (characterization-of-NL-ring-โ‰ก ๐“ก ๐“ก') โŒ i

   a' : A ๐“ก'
   a' = transport A p a

simple-unique-choice : (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ ) (R : (x : X) โ†’ A x โ†’ ๐“ฆ ฬ‡ )

                     โ†’ ((x : X) โ†’ โˆƒ! a ๊ž‰ A x , R x a)
                     โ†’ ฮฃ f ๊ž‰ ฮ  A , ((x : X) โ†’ R x (f x))

simple-unique-choice X A R s = f , ฯ†
 where
  f : (x : X) โ†’ A x
  f x = prโ‚ (center (ฮฃ a ๊ž‰ A x , R x a) (s x))

  ฯ† : (x : X) โ†’ R x (f x)
  ฯ† x = prโ‚‚ (center (ฮฃ a ๊ž‰ A x , R x a) (s x))

Unique-Choice : (๐“ค ๐“ฅ ๐“ฆ : Universe) โ†’ (๐“ค โŠ” ๐“ฅ โŠ” ๐“ฆ)โบ ฬ‡
Unique-Choice ๐“ค ๐“ฅ ๐“ฆ = (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ ) (R : (x : X) โ†’ A x โ†’ ๐“ฆ ฬ‡ )
                     โ†’ ((x : X) โ†’ โˆƒ! a ๊ž‰ A x , R x a)
                     โ†’ โˆƒ! f ๊ž‰ ฮ  A , ((x : X) โ†’ R x (f x))

vvfunext-gives-unique-choice : vvfunext ๐“ค (๐“ฅ โŠ” ๐“ฆ) โ†’ Unique-Choice ๐“ค ๐“ฅ ๐“ฆ
vvfunext-gives-unique-choice vv X A R s = c
 where
  a : ((x : X) โ†’ ฮฃ a ๊ž‰ A x , R x a)
    โ‰ƒ (ฮฃ f ๊ž‰ ((x : X) โ†’ A x), ((x : X) โ†’ R x (f x)))

  a = ฮ ฮฃ-distr-โ‰ƒ

  b : is-singleton ((x : X) โ†’ ฮฃ a ๊ž‰ A x , R x a)
  b = vv s

  c : is-singleton (ฮฃ f ๊ž‰ ((x : X) โ†’ A x), ((x : X) โ†’ R x (f x)))
  c = equiv-to-singleton' a b

unique-choice-gives-vvfunext : Unique-Choice ๐“ค ๐“ฅ ๐“ฅ โ†’ vvfunext ๐“ค ๐“ฅ
unique-choice-gives-vvfunext {๐“ค} {๐“ฅ} uc {X} {A} ฯ† = ฮณ
 where
  R : (x : X) โ†’ A x โ†’ ๐“ฅ  ฬ‡
  R x a = A x

  s' : (x : X) โ†’ is-singleton (A x ร— A x)
  s' x = ร—-is-singleton (ฯ† x) (ฯ† x)

  s : (x : X) โ†’ โˆƒ! y ๊ž‰ A x , R x y
  s = s'

  e : โˆƒ! f ๊ž‰ ฮ  A , ((x : X) โ†’ R x (f x))
  e = uc X A R s

  e' : is-singleton (ฮ  A ร— ฮ  A)
  e' = e

  ฯ : ฮ  A โ— ฮ  A ร— ฮ  A
  ฯ = prโ‚ , (ฮป y โ†’ y , y) , refl

  ฮณ : is-singleton (ฮ  A)
  ฮณ = retract-of-singleton ฯ e'

unique-choice-gives-hfunext : Unique-Choice ๐“ค ๐“ฅ ๐“ฅ โ†’ hfunext ๐“ค ๐“ฅ
unique-choice-gives-hfunext {๐“ค} {๐“ฅ} uc = โ†’hfunext ฮณ
 where
  ฮณ : (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ ) (f : ฮ  A) โ†’ โˆƒ! g ๊ž‰ ฮ  A , f โˆผ g
  ฮณ X A f = uc X A R e
   where
    R : (x : X) โ†’ A x โ†’ ๐“ฅ ฬ‡
    R x a = f x โ‰ก a
    e : (x : X) โ†’ โˆƒ! a ๊ž‰ A x , f x โ‰ก a
    e x = singleton-types'-are-singletons (A x) (f x)

unique-choiceโ‡”vvfunext : Unique-Choice ๐“ค ๐“ฅ ๐“ฅ โ‡” vvfunext ๐“ค ๐“ฅ
unique-choiceโ‡”vvfunext = unique-choice-gives-vvfunext ,
                         vvfunext-gives-unique-choice

module _ (hfe : global-hfunext) where

 private
   hunapply : {X : ๐“ค ฬ‡ } {A : X โ†’ ๐“ฅ ฬ‡ } {f g : ฮ  A} โ†’ f โˆผ g โ†’ f โ‰ก g
   hunapply = inverse (happly _ _) (hfe _ _)

 transport-hunapply : {X : ๐“ค ฬ‡ } (A : X โ†’ ๐“ฅ ฬ‡ ) (R : (x : X) โ†’ A x โ†’ ๐“ฆ ฬ‡ )
                      (f g : ฮ  A)
                      (ฯ† : (x : X) โ†’ R x (f x))
                      (h : f โˆผ g)
                      (x : X)
                    โ†’ transport (ฮป - โ†’ (x : X) โ†’ R x (- x)) (hunapply h) ฯ† x
                    โ‰ก transport (R x) (h x) (ฯ† x)

 transport-hunapply A R f g ฯ† h x =

   transport (ฮป - โ†’ โˆ€ x โ†’ R x (- x)) (hunapply h) ฯ† x โ‰กโŸจ i  โŸฉ
   transport (R x) (happly f g (hunapply h) x) (ฯ† x)  โ‰กโŸจ ii โŸฉ
   transport (R x) (h x) (ฯ† x)                        โˆŽ

  where
   a : {f g : ฮ  A} {ฯ† : โˆ€ x โ†’ R x (f x)} (p : f โ‰ก g) (x : domain A)
     โ†’ transport (ฮป - โ†’ โˆ€ x โ†’ R x (- x)) p ฯ† x
     โ‰ก transport (R x) (happly f g p x) (ฯ† x)

   a (refl _) x = refl _

   b : happly f g (hunapply h) โ‰ก h
   b = inverses-are-sections (happly f g) (hfe f g) h

   i  = a (hunapply h) x
   ii = ap (ฮป - โ†’ transport (R x) (- x) (ฯ† x)) b

 unique-choice : (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ ) (R : (x : X) โ†’ A x โ†’ ๐“ฆ ฬ‡ )

               โ†’ ((x : X) โ†’ โˆƒ! a ๊ž‰ A x , R x a)
               โ†’ โˆƒ! f ๊ž‰ ((x : X) โ†’ A x), ((x : X) โ†’ R x (f x))

 unique-choice X A R s = C , ฮฆ
  where
   fโ‚€ : (x : X) โ†’ A x
   fโ‚€ x = prโ‚ (center (ฮฃ a ๊ž‰ A x , R x a) (s x))

   ฯ†โ‚€ : (x : X) โ†’ R x (fโ‚€ x)
   ฯ†โ‚€ x = prโ‚‚ (center (ฮฃ a ๊ž‰ A x , R x a) (s x))

   C : ฮฃ f ๊ž‰ ((x : X) โ†’ A x), ((x : X) โ†’ R x (f x))
   C = fโ‚€ , ฯ†โ‚€

   c : (x : X) โ†’ (ฯ„ : ฮฃ a ๊ž‰ A x , R x a) โ†’ fโ‚€ x , ฯ†โ‚€ x โ‰ก ฯ„
   c x = centrality (ฮฃ a ๊ž‰ A x , R x a) (s x)

   cโ‚ : (x : X) (a : A x) (r : R x a) โ†’ fโ‚€ x โ‰ก a
   cโ‚ x a r = ap prโ‚ (c x (a , r))

   cโ‚‚ : (x : X) (a : A x) (r : R x a)
      โ†’ transport (ฮป - โ†’ R x (prโ‚ -)) (c x (a , r)) (ฯ†โ‚€ x) โ‰ก r

   cโ‚‚ x a r = apd prโ‚‚ (c x (a , r))

   ฮฆ : (ฯƒ : ฮฃ f ๊ž‰ ((x : X) โ†’ A x), ((x : X) โ†’ R x (f x))) โ†’ C โ‰ก ฯƒ
   ฮฆ (f , ฯ†) = to-ฮฃ-โ‰ก (p , hunapply q)
    where
     p : fโ‚€ โ‰ก f
     p = hunapply (ฮป x โ†’ cโ‚ x (f x) (ฯ† x))

     q : transport (ฮป - โ†’ (x : X) โ†’ R x (- x)) p ฯ†โ‚€ โˆผ ฯ†
     q x = transport (ฮป - โ†’ (x : X) โ†’ R x (- x)) p ฯ†โ‚€ x           โ‰กโŸจ i   โŸฉ
           transport (R x) (ap prโ‚ (c x (f x , ฯ† x))) (ฯ†โ‚€ x)      โ‰กโŸจ ii  โŸฉ
           transport (ฮป ฯƒ โ†’ R x (prโ‚ ฯƒ)) (c x (f x , ฯ† x)) (ฯ†โ‚€ x) โ‰กโŸจ iii โŸฉ
           ฯ† x                                                    โˆŽ
      where
       i   = transport-hunapply A R fโ‚€ f ฯ†โ‚€ (ฮป x โ†’ cโ‚ x (f x) (ฯ† x)) x
       ii  = (transport-ap (R x) prโ‚ (c x (f x , ฯ† x)) (ฯ†โ‚€ x))โปยน
       iii = cโ‚‚ x (f x) (ฯ† x)

module choice
        (pt  : subsingleton-truncations-exist)
        (hfe : global-hfunext)
       where

  open basic-truncation-development pt hfe public

  simple-unique-choice' : (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ ) (R : (x : X) โ†’ A x โ†’ ๐“ฆ ฬ‡ )

                        โ†’ ((x : X) โ†’ is-subsingleton (ฮฃ a ๊ž‰ A x , R x a))

                        โ†’ ((x : X) โ†’ โˆƒ a ๊ž‰ A x , R x a)
                        โ†’ ฮฃ f ๊ž‰ ฮ  A , ((x : X) โ†’ R x (f x))

  simple-unique-choice' X A R u ฯ† = simple-unique-choice X A R s
   where
    s : (x : X) โ†’ โˆƒ! a ๊ž‰ A x , R x a
    s x = inhabited-subsingletons-are-singletons (ฮฃ a ๊ž‰ A x , R x a) (ฯ† x) (u x)

  AC : โˆ€ ๐“ฃ (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ )
     โ†’ is-set X โ†’ ((x : X) โ†’ is-set (A x)) โ†’ ๐“ฃ โบ โŠ” ๐“ค โŠ” ๐“ฅ ฬ‡

  AC ๐“ฃ X A i j = (R : (x : X) โ†’ A x โ†’ ๐“ฃ ฬ‡ )
               โ†’ ((x : X) (a : A x) โ†’ is-subsingleton (R x a))

               โ†’ ((x : X) โ†’ โˆƒ a ๊ž‰ A x , R x a)
               โ†’ โˆƒ f ๊ž‰ ฮ  A , ((x : X) โ†’ R x (f x))

  Choice : โˆ€ ๐“ค โ†’ ๐“ค โบ ฬ‡
  Choice ๐“ค = (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ค ฬ‡ ) (i : is-set X) (j : (x : X) โ†’ is-set (A x))
           โ†’ AC ๐“ค X A i j

  IAC : (X : ๐“ค ฬ‡ ) (Y : X โ†’ ๐“ฅ ฬ‡ ) โ†’ is-set X โ†’ ((x : X) โ†’ is-set (Y x)) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
  IAC X Y i j = ((x : X) โ†’ โˆฅ Y x โˆฅ) โ†’ โˆฅ ฮ  Y โˆฅ

  IChoice : โˆ€ ๐“ค โ†’ ๐“ค โบ ฬ‡
  IChoice ๐“ค = (X : ๐“ค ฬ‡ ) (Y : X โ†’ ๐“ค ฬ‡ ) (i : is-set X) (j : (x : X) โ†’ is-set (Y x))
            โ†’ IAC X Y i j

  Choice-gives-IChoice : Choice ๐“ค โ†’ IChoice ๐“ค
  Choice-gives-IChoice {๐“ค} ac X Y i j ฯ† = ฮณ
   where
    R : (x : X) โ†’ Y x โ†’ ๐“ค ฬ‡
    R x y = x โ‰ก x -- Any singleton type in ๐“ค will do.

    k : (x : X) (y : Y x) โ†’ is-subsingleton (R x y)
    k x y = i x x

    h : (x : X) โ†’ Y x โ†’ ฮฃ y ๊ž‰ Y x , R x y
    h x y = (y , refl x)

    g : (x : X) โ†’ โˆƒ y ๊ž‰ Y x , R x y
    g x = โˆฅโˆฅ-functor (h x) (ฯ† x)

    c : โˆƒ f ๊ž‰ ฮ  Y , ((x : X) โ†’ R x (f x))
    c = ac X Y i j R k g

    ฮณ : โˆฅ ฮ  Y โˆฅ
    ฮณ = โˆฅโˆฅ-functor prโ‚ c

  IChoice-gives-Choice : IChoice ๐“ค โ†’ Choice ๐“ค
  IChoice-gives-Choice {๐“ค} iac X A i j R k ฯˆ = ฮณ
   where
    Y : X โ†’ ๐“ค ฬ‡
    Y x = ฮฃ a ๊ž‰ A x , R x a

    l : (x : X) โ†’ is-set (Y x)
    l x = subsets-of-sets-are-sets (A x) (R x) (j x) (k x)

    a : โˆฅ ฮ  Y โˆฅ
    a = iac X Y i l ฯˆ

    h : ฮ  Y โ†’ ฮฃ f ๊ž‰ ฮ  A , ((x : X) โ†’ R x (f x))
    h g = (ฮป x โ†’ prโ‚ (g x)) , (ฮป x โ†’ prโ‚‚ (g x))

    ฮณ : โˆƒ f ๊ž‰ ฮ  A , ((x : X) โ†’ R x (f x))
    ฮณ = โˆฅโˆฅ-functor h a

  TAC : (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ฅ ฬ‡ ) โ†’ is-set X โ†’ ((x : X) โ†’ is-set (A x)) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
  TAC X A i j = โˆฅ((x : X) โ†’ โˆฅ A x โˆฅ โ†’ A x)โˆฅ

  TChoice : โˆ€ ๐“ค โ†’ ๐“ค โบ ฬ‡
  TChoice ๐“ค = (X : ๐“ค ฬ‡ ) (A : X โ†’ ๐“ค ฬ‡ ) (i : is-set X) (j : (x : X) โ†’ is-set (A x))
            โ†’ TAC X A i j

  IChoice-gives-TChoice : IChoice ๐“ค โ†’ TChoice ๐“ค
  IChoice-gives-TChoice {๐“ค} iac X A i j = ฮณ
   where
    B : (x : X) โ†’ โˆฅ A x โˆฅ โ†’ ๐“ค ฬ‡
    B x s = A x

    k : (x : X) (s : โˆฅ A x โˆฅ) โ†’ is-set (B x s)
    k x s = j x

    l : (x : X) โ†’ is-set โˆฅ A x โˆฅ
    l x = subsingletons-are-sets โˆฅ A x โˆฅ โˆฅโˆฅ-is-subsingleton

    m : (x : X) โ†’  is-set (โˆฅ A x โˆฅ โ†’ A x)
    m x = ฮ -is-set hfe (ฮป s โ†’ j x)

    ฯ† : (x : X) โ†’ โˆฅ (โˆฅ A x โˆฅ โ†’ A x) โˆฅ
    ฯ† x = iac โˆฅ A x โˆฅ (B x) (l x) (k x) (๐‘–๐‘‘ โˆฅ A x โˆฅ)

    ฮณ : โˆฅ((x : X) โ†’ โˆฅ A x โˆฅ โ†’ A x)โˆฅ
    ฮณ = iac X (ฮป x โ†’ โˆฅ A x โˆฅ โ†’ A x) i m ฯ†

  TChoice-gives-IChoice : TChoice ๐“ค โ†’ IChoice ๐“ค
  TChoice-gives-IChoice tac X A i j = ฮณ
   where
    ฮณ : ((x : X) โ†’ โˆฅ A x โˆฅ) โ†’ โˆฅ ฮ  A โˆฅ
    ฮณ g = โˆฅโˆฅ-functor ฯ† (tac X A i j)
     where
      ฯ† : ((x : X) โ†’ โˆฅ A x โˆฅ โ†’ A x) โ†’ ฮ  A
      ฯ† f x = f x (g x)

  decidable-equality-criterion : {X : ๐“ค ฬ‡ } (ฮฑ : ๐Ÿš โ†’ X)
                               โ†’ ((x : X) โ†’ (โˆƒ n ๊ž‰ ๐Ÿš , ฮฑ n โ‰ก x)
                                          โ†’ (ฮฃ n ๊ž‰ ๐Ÿš , ฮฑ n โ‰ก x))
                               โ†’ decidable(ฮฑ โ‚€ โ‰ก ฮฑ โ‚)

  decidable-equality-criterion ฮฑ c = ฮณ d
   where
    r : ๐Ÿš โ†’ image ฮฑ
    r = corestriction ฮฑ

    ฯƒ : (y : image ฮฑ) โ†’ ฮฃ n ๊ž‰ ๐Ÿš , r n โ‰ก y
    ฯƒ (x , t) = f u
     where
      u : ฮฃ n ๊ž‰ ๐Ÿš , ฮฑ n โ‰ก x
      u = c x t

      f : (ฮฃ n ๊ž‰ ๐Ÿš , ฮฑ n โ‰ก x) โ†’ ฮฃ n ๊ž‰ ๐Ÿš , r n โ‰ก (x , t)
      f (n , p) = n , to-subtype-โ‰ก (ฮป _ โ†’ โˆƒ-is-subsingleton) p

    s : image ฮฑ โ†’ ๐Ÿš
    s y = prโ‚ (ฯƒ y)

    ฮท : (y : image ฮฑ) โ†’ r (s y) โ‰ก y
    ฮท y = prโ‚‚ (ฯƒ y)

    l : left-cancellable s
    l = sections-are-lc s (r , ฮท)

    ฮฑr : {m n : ๐Ÿš} โ†’ ฮฑ m โ‰ก ฮฑ n โ†’ r m โ‰ก r n
    ฮฑr p = to-subtype-โ‰ก (ฮป _ โ†’ โˆƒ-is-subsingleton) p

    rฮฑ : {m n : ๐Ÿš} โ†’ r m โ‰ก r n โ†’ ฮฑ m โ‰ก ฮฑ n
    rฮฑ = ap prโ‚

    ฮฑs : {m n : ๐Ÿš} โ†’ ฮฑ m โ‰ก ฮฑ n โ†’ s (r m) โ‰ก s (r n)
    ฮฑs p = ap s (ฮฑr p)

    sฮฑ : {m n : ๐Ÿš} โ†’ s (r m) โ‰ก s (r n) โ†’ ฮฑ m โ‰ก ฮฑ n
    sฮฑ p = rฮฑ (l p)

    ฮณ : decidable (s (r โ‚€) โ‰ก s (r โ‚)) โ†’ decidable(ฮฑ โ‚€ โ‰ก ฮฑ โ‚)
    ฮณ (inl p) = inl (sฮฑ p)
    ฮณ (inr u) = inr (contrapositive ฮฑs u)

    d : decidable (s (r โ‚€) โ‰ก s (r โ‚))
    d = ๐Ÿš-has-decidable-equality (s (r โ‚€)) (s (r โ‚))

  choice-gives-decidable-equality : TChoice ๐“ค
                                  โ†’ (X : ๐“ค ฬ‡ ) โ†’ is-set X โ†’ has-decidable-equality X

  choice-gives-decidable-equality {๐“ค} tac X i xโ‚€ xโ‚ = ฮณ
   where
    ฮฑ : ๐Ÿš โ†’ X
    ฮฑ โ‚€ = xโ‚€
    ฮฑ โ‚ = xโ‚

    A : X โ†’ ๐“ค ฬ‡
    A x = ฮฃ n ๊ž‰ ๐Ÿš , ฮฑ n โ‰ก x

    l : is-subsingleton (decidable (xโ‚€ โ‰ก xโ‚))
    l = +-is-subsingleton' hunapply (i (ฮฑ โ‚€) (ฮฑ โ‚))

    ฮด : โˆฅ((x : X) โ†’ โˆฅ A x โˆฅ โ†’ A x)โˆฅ โ†’ decidable(xโ‚€ โ‰ก xโ‚)
    ฮด = โˆฅโˆฅ-recursion l (decidable-equality-criterion ฮฑ)

    j : (x : X) โ†’ is-set (A x)
    j x = subsets-of-sets-are-sets ๐Ÿš (ฮป n โ†’ ฮฑ n โ‰ก x) ๐Ÿš-is-set (ฮป n โ†’ i (ฮฑ n) x)

    h : โˆฅ((x : X) โ†’ โˆฅ A x โˆฅ โ†’ A x)โˆฅ
    h = tac X A i j

    ฮณ : decidable (xโ‚€ โ‰ก xโ‚)
    ฮณ = ฮด h

  choice-gives-EM : propext ๐“ค โ†’ TChoice (๐“ค โบ) โ†’ EM ๐“ค
  choice-gives-EM {๐“ค} pe tac = em
   where
    โŠค : ฮฉ ๐“ค
    โŠค = (Lift ๐“ค ๐Ÿ™ , equiv-to-subsingleton (Lift-โ‰ƒ ๐Ÿ™) ๐Ÿ™-is-subsingleton)

    ฮด : (ฯ‰ : ฮฉ ๐“ค) โ†’ decidable (โŠค โ‰ก ฯ‰)
    ฮด = choice-gives-decidable-equality tac (ฮฉ ๐“ค) (ฮฉ-is-a-set hunapply pe) โŠค

    em : (P : ๐“ค ฬ‡ ) โ†’ is-subsingleton P โ†’ P + ยฌ P
    em P i = ฮณ (ฮด (P , i))
     where
      ฮณ : decidable (โŠค โ‰ก (P , i)) โ†’ P + ยฌ P

      ฮณ (inl r) = inl (Idโ†’fun s (lift โ‹†))
       where
        s : Lift ๐“ค ๐Ÿ™ โ‰ก P
        s = ap prโ‚ r

      ฮณ (inr n) = inr (contrapositive f n)
       where
        f : P โ†’ โŠค โ‰ก P , i
        f p = ฮฉ-ext hunapply pe (ฮป (_ : Lift ๐“ค ๐Ÿ™) โ†’ p) (ฮป (_ : P) โ†’ lift โ‹†)

  global-choice : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
  global-choice ๐“ค = (X : ๐“ค ฬ‡ ) โ†’ X + is-empty X

  global-โˆฅโˆฅ-choice : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
  global-โˆฅโˆฅ-choice ๐“ค = (X : ๐“ค ฬ‡ ) โ†’ โˆฅ X โˆฅ โ†’ X

  open exit-โˆฅโˆฅ pt hfe

  global-choice-gives-wconstant : global-choice ๐“ค
                                โ†’ (X : ๐“ค ฬ‡ ) โ†’ wconstant-endomap X

  global-choice-gives-wconstant g X = decidable-has-wconstant-endomap (g X)

  global-choice-gives-global-โˆฅโˆฅ-choice : global-choice  ๐“ค
                                       โ†’ global-โˆฅโˆฅ-choice ๐“ค

  global-choice-gives-global-โˆฅโˆฅ-choice {๐“ค} c X = ฮณ (c X)
   where
    ฮณ : X + is-empty X โ†’ โˆฅ X โˆฅ โ†’ X
    ฮณ (inl x) s = x
    ฮณ (inr n) s = !๐Ÿ˜ X (โˆฅโˆฅ-recursion ๐Ÿ˜-is-subsingleton n s)

  global-โˆฅโˆฅ-choice-gives-all-types-are-sets : global-โˆฅโˆฅ-choice ๐“ค
                                            โ†’ (X : ๐“ค ฬ‡ ) โ†’ is-set X

  global-โˆฅโˆฅ-choice-gives-all-types-are-sets {๐“ค} c X =
    types-with-wconstant-โ‰ก-endomaps-are-sets X
        (ฮป x y โ†’ โˆฅโˆฅ-choice-function-gives-wconstant-endomap (c (x โ‰ก y)))

  global-โˆฅโˆฅ-choice-gives-universe-is-set : global-โˆฅโˆฅ-choice (๐“ค โบ)
                                         โ†’ is-set (๐“ค ฬ‡ )

  global-โˆฅโˆฅ-choice-gives-universe-is-set {๐“ค} c =
    global-โˆฅโˆฅ-choice-gives-all-types-are-sets c (๐“ค ฬ‡ )

  global-โˆฅโˆฅ-choice-gives-choice : global-โˆฅโˆฅ-choice ๐“ค
                                โ†’ TChoice ๐“ค

  global-โˆฅโˆฅ-choice-gives-choice {๐“ค} c X A i j = โˆฃ(ฮป x โ†’ c (A x))โˆฃ

  global-โˆฅโˆฅ-choice-gives-EM : propext ๐“ค
                            โ†’ global-โˆฅโˆฅ-choice (๐“ค โบ)
                            โ†’ EM  ๐“ค

  global-โˆฅโˆฅ-choice-gives-EM {๐“ค} pe c =
    choice-gives-EM pe (global-โˆฅโˆฅ-choice-gives-choice c)

  global-โˆฅโˆฅ-choice-gives-global-choice : propext ๐“ค
                                       โ†’ global-โˆฅโˆฅ-choice ๐“ค
                                       โ†’ global-โˆฅโˆฅ-choice (๐“ค โบ)
                                       โ†’ global-choice ๐“ค

  global-โˆฅโˆฅ-choice-gives-global-choice {๐“ค} pe c cโบ X = ฮณ
   where
    d : decidable โˆฅ X โˆฅ
    d = global-โˆฅโˆฅ-choice-gives-EM pe cโบ โˆฅ X โˆฅ โˆฅโˆฅ-is-subsingleton

    f : decidable โˆฅ X โˆฅ โ†’ X + is-empty X
    f (inl i) = inl (c X i)
    f (inr ฯ†) = inr (contrapositive โˆฃ_โˆฃ ฯ†)

    ฮณ : X + is-empty X
    ฮณ = f d

  Global-Choice Global-โˆฅโˆฅ-Choice : ๐“คฯ‰
  Global-Choice    = โˆ€ ๐“ค โ†’ global-choice  ๐“ค
  Global-โˆฅโˆฅ-Choice = โˆ€ ๐“ค โ†’ global-โˆฅโˆฅ-choice ๐“ค

  Global-Choice-gives-Global-โˆฅโˆฅ-Choice : Global-Choice โ†’ Global-โˆฅโˆฅ-Choice
  Global-Choice-gives-Global-โˆฅโˆฅ-Choice c ๐“ค =
    global-choice-gives-global-โˆฅโˆฅ-choice (c ๐“ค)

  Global-โˆฅโˆฅ-Choice-gives-Global-Choice : global-propext
                                       โ†’ Global-โˆฅโˆฅ-Choice โ†’ Global-Choice

  Global-โˆฅโˆฅ-Choice-gives-Global-Choice pe c ๐“ค =
    global-โˆฅโˆฅ-choice-gives-global-choice pe (c ๐“ค) (c (๐“ค โบ))

  global-โˆฅโˆฅ-choice-inconsistent-with-univalence : Global-โˆฅโˆฅ-Choice
                                                โ†’ Univalence
                                                โ†’ ๐Ÿ˜

  global-โˆฅโˆฅ-choice-inconsistent-with-univalence g ua = ฮณ (g ๐“คโ‚) (ua ๐“คโ‚€)
   where
    open example-of-a-nonset

    ฮณ : global-โˆฅโˆฅ-choice ๐“คโ‚ โ†’ is-univalent ๐“คโ‚€ โ†’ ๐Ÿ˜
    ฮณ g ua = ๐“คโ‚€-is-not-a-set ua (global-โˆฅโˆฅ-choice-gives-universe-is-set g)

  global-choice-inconsistent-with-univalence : Global-Choice
                                             โ†’ Univalence
                                             โ†’ ๐Ÿ˜

  global-choice-inconsistent-with-univalence g =
    global-โˆฅโˆฅ-choice-inconsistent-with-univalence
      (Global-Choice-gives-Global-โˆฅโˆฅ-Choice g)

  global-choice-gives-all-types-are-sets : global-choice ๐“ค
                                         โ†’ (X : ๐“ค ฬ‡ ) โ†’ is-set X

  global-choice-gives-all-types-are-sets {๐“ค} c X = hedberg (ฮป x y โ†’ c (x โ‰ก y))

_has-size_ : ๐“ค ฬ‡ โ†’ (๐“ฅ : Universe) โ†’ ๐“ฅ โบ โŠ” ๐“ค ฬ‡
X has-size ๐“ฅ = ฮฃ Y ๊ž‰ ๐“ฅ ฬ‡ , X โ‰ƒ Y

propositional-resizing : (๐“ค ๐“ฅ : Universe) โ†’ (๐“ค โŠ” ๐“ฅ)โบ ฬ‡
propositional-resizing ๐“ค ๐“ฅ = (P : ๐“ค ฬ‡ ) โ†’ is-subsingleton P โ†’ P has-size ๐“ฅ

Propositional-resizing : ๐“คฯ‰
Propositional-resizing = {๐“ค ๐“ฅ : Universe} โ†’ propositional-resizing ๐“ค ๐“ฅ

upper-resizing : โˆ€ {๐“ค} ๐“ฅ (X : ๐“ค ฬ‡ ) โ†’ X has-size (๐“ค โŠ” ๐“ฅ)
upper-resizing ๐“ฅ X = (Lift ๐“ฅ X , โ‰ƒ-Lift X)

has-size-is-upper : (X : ๐“ค ฬ‡ ) โ†’ X has-size ๐“ฅ โ†’ X has-size (๐“ฅ โŠ” ๐“ฆ)
has-size-is-upper {๐“ค} {๐“ฅ} {๐“ฆ} X (Y , e) =  Z , c
 where
  Z : ๐“ฅ โŠ” ๐“ฆ ฬ‡
  Z = Lift ๐“ฆ Y

  d : Y โ‰ƒ Z
  d = โ‰ƒ-Lift Y

  c : X โ‰ƒ Z
  c = e โ— d

upper-propositional-resizing : propositional-resizing ๐“ค (๐“ค โŠ” ๐“ฅ)
upper-propositional-resizing {๐“ค} {๐“ฅ} P i = upper-resizing ๐“ฅ P

is-small : ๐“ค ฬ‡  โ†’ ๐“ค โŠ” ๐“คโ‚ ฬ‡
is-small X = X has-size ๐“คโ‚€

all-propositions-are-small : โˆ€ ๐“ค โ†’ ๐“ค โบ ฬ‡
all-propositions-are-small ๐“ค = (P : ๐“ค ฬ‡ ) โ†’ is-prop P โ†’ is-small P

all-propositions-are-small-means-PRโ‚€ : all-propositions-are-small ๐“ค
                                     โ‰ก propositional-resizing ๐“ค ๐“คโ‚€

all-propositions-are-small-means-PRโ‚€ = refl _

all-propositions-are-small-gives-PR : all-propositions-are-small ๐“ค
                                    โ†’ propositional-resizing ๐“ค ๐“ฅ

all-propositions-are-small-gives-PR {๐“ค} {๐“ฅ} a P i = ฮณ
 where
  ฮด : P has-size ๐“คโ‚€
  ฮด = a P i

  ฮณ : P has-size ๐“ฅ
  ฮณ = has-size-is-upper P ฮด

All-propositions-are-small : ๐“คฯ‰
All-propositions-are-small = โˆ€ ๐“ค โ†’ all-propositions-are-small ๐“ค

PR-gives-All-propositions-are-small : Propositional-resizing
                                    โ†’ All-propositions-are-small

PR-gives-All-propositions-are-small PR ๐“ค = PR

All-propositions-are-small-gives-PR : All-propositions-are-small
                                    โ†’ Propositional-resizing

All-propositions-are-small-gives-PR a {๐“ค} {๐“ฅ} = all-propositions-are-small-gives-PR (a ๐“ค)

resize : propositional-resizing ๐“ค ๐“ฅ
       โ†’ (P : ๐“ค ฬ‡ ) (i : is-subsingleton P) โ†’ ๐“ฅ ฬ‡

resize ฯ P i = prโ‚ (ฯ P i)

resize-is-subsingleton : (ฯ : propositional-resizing ๐“ค ๐“ฅ)
                         (P : ๐“ค ฬ‡ ) (i : is-subsingleton P)
                       โ†’ is-subsingleton (resize ฯ P i)

resize-is-subsingleton ฯ P i = equiv-to-subsingleton (โ‰ƒ-sym (prโ‚‚ (ฯ P i))) i

to-resize : (ฯ : propositional-resizing ๐“ค ๐“ฅ)
            (P : ๐“ค ฬ‡ ) (i : is-subsingleton P)
          โ†’ P โ†’ resize ฯ P i

to-resize ฯ P i = โŒœ prโ‚‚ (ฯ P i) โŒ

from-resize : (ฯ : propositional-resizing ๐“ค ๐“ฅ)
              (P : ๐“ค ฬ‡ ) (i : is-subsingleton P)
            โ†’ resize ฯ P i โ†’ P

from-resize ฯ P i = โŒœ โ‰ƒ-sym(prโ‚‚ (ฯ P i)) โŒ

EM-gives-all-propositions-are-small : EM ๐“ค โ†’ all-propositions-are-small ๐“ค
EM-gives-all-propositions-are-small em P i = ฮณ
 where
   Q : P + ยฌ P โ†’ ๐“คโ‚€ ฬ‡
   Q (inl _) = ๐Ÿ™
   Q (inr _) = ๐Ÿ˜

   j : (d : P + ยฌ P) โ†’ is-subsingleton (Q d)
   j (inl p) = ๐Ÿ™-is-subsingleton
   j (inr n) = ๐Ÿ˜-is-subsingleton

   f : (d : P + ยฌ P) โ†’ P โ†’ Q d
   f (inl _) _ = โ‹†
   f (inr n) p  = !๐Ÿ˜ ๐Ÿ˜ (n p)

   g : (d : P + ยฌ P) โ†’ Q d โ†’ P
   g (inl p) _ = p
   g (inr _) q = !๐Ÿ˜ P q

   e : P โ‰ƒ Q (em P i)
   e = logically-equivalent-subsingletons-are-equivalent
        P (Q (em P i)) i (j (em P i)) (f (em P i) , g (em P i))

   ฮณ : is-small P
   ฮณ = Q (em P i) , e

EM-gives-PR : EM ๐“ค โ†’ propositional-resizing ๐“ค ๐“ฅ
EM-gives-PR {๐“ค} {๐“ฅ} em = all-propositions-are-small-gives-PR
                           (EM-gives-all-propositions-are-small em)

has-size-is-subsingleton : Univalence
                         โ†’ (X : ๐“ค ฬ‡ ) (๐“ฅ :  Universe)
                         โ†’ is-subsingleton (X has-size ๐“ฅ)

has-size-is-subsingleton {๐“ค} ua X ๐“ฅ = univalenceโ†’' (ua ๐“ฅ) (ua (๐“ค โŠ” ๐“ฅ)) X

PR-is-subsingleton : Univalence โ†’ is-subsingleton (propositional-resizing ๐“ค ๐“ฅ)
PR-is-subsingleton {๐“ค} {๐“ฅ} ua =
 ฮ -is-subsingleton (univalence-gives-global-dfunext ua)
  (ฮป P โ†’ ฮ -is-subsingleton (univalence-gives-global-dfunext ua)
  (ฮป i โ†’ has-size-is-subsingleton ua P ๐“ฅ))

Impredicativity : (๐“ค ๐“ฅ : Universe) โ†’ (๐“ค โŠ” ๐“ฅ )โบ ฬ‡
Impredicativity ๐“ค ๐“ฅ = ฮฉ ๐“ค has-size ๐“ฅ

is-impredicative : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
is-impredicative ๐“ค = Impredicativity ๐“ค ๐“ค

is-relatively-small : ๐“ค โบ ฬ‡  โ†’ ๐“ค โบ ฬ‡
is-relatively-small {๐“ค} X = X has-size ๐“ค

impredicativity-is-ฮฉ-smallness : โˆ€ {๐“ค} โ†’ is-impredicative ๐“ค โ‰ก is-relatively-small (ฮฉ ๐“ค)
impredicativity-is-ฮฉ-smallness {๐“ค} = refl _

PR-gives-Impredicativityโบ : global-propext
                          โ†’ global-dfunext
                          โ†’ propositional-resizing ๐“ฅ ๐“ค
                          โ†’ propositional-resizing ๐“ค ๐“ฅ
                          โ†’ Impredicativity ๐“ค (๐“ฅ โบ)

PR-gives-Impredicativityโบ {๐“ฅ} {๐“ค} pe fe ฯ ฯƒ = ฮณ
 where
  ฯ† : ฮฉ ๐“ฅ โ†’ ฮฉ ๐“ค
  ฯ† (Q , j) = resize ฯ Q j , resize-is-subsingleton ฯ Q j

  ฯˆ : ฮฉ ๐“ค โ†’ ฮฉ ๐“ฅ
  ฯˆ (P , i) = resize ฯƒ P i , resize-is-subsingleton ฯƒ P i

  ฮท : (p : ฮฉ ๐“ค) โ†’ ฯ† (ฯˆ p) โ‰ก p
  ฮท (P , i) = ฮฉ-ext fe pe a b
   where
    Q : ๐“ฅ ฬ‡
    Q = resize ฯƒ P i

    j : is-subsingleton Q
    j = resize-is-subsingleton ฯƒ P i

    a : resize ฯ Q j โ†’ P
    a = from-resize ฯƒ P i โˆ˜ from-resize ฯ Q j

    b : P โ†’ resize ฯ Q j
    b = to-resize ฯ Q j โˆ˜ to-resize ฯƒ P i

  ฮต : (q : ฮฉ ๐“ฅ) โ†’ ฯˆ (ฯ† q) โ‰ก q
  ฮต (Q , j) = ฮฉ-ext fe pe a b
   where
    P : ๐“ค ฬ‡
    P = resize ฯ Q j

    i : is-subsingleton P
    i = resize-is-subsingleton ฯ Q j

    a : resize ฯƒ P i โ†’ Q
    a = from-resize ฯ Q j โˆ˜ from-resize ฯƒ P i

    b : Q โ†’ resize ฯƒ P i
    b = to-resize ฯƒ P i โˆ˜ to-resize ฯ Q j

  ฮณ : (ฮฉ ๐“ค) has-size (๐“ฅ โบ)
  ฮณ = ฮฉ ๐“ฅ , invertibility-gives-โ‰ƒ ฯˆ (ฯ† , ฮท , ฮต)

PR-gives-impredicativityโบ : global-propext
                          โ†’ global-dfunext
                          โ†’ propositional-resizing (๐“ค โบ) ๐“ค
                          โ†’ is-impredicative (๐“ค โบ)

PR-gives-impredicativityโบ {๐“ค} pe fe = PR-gives-Impredicativityโบ
                                        pe fe (ฮป P i โ†’ upper-resizing (๐“ค โบ) P)

PR-gives-impredicativityโ‚ : global-propext
                          โ†’ global-dfunext
                          โ†’ propositional-resizing ๐“ค ๐“คโ‚€
                          โ†’ Impredicativity ๐“ค ๐“คโ‚

PR-gives-impredicativityโ‚ {๐“ค} pe fe = PR-gives-Impredicativityโบ
                                       pe fe (ฮป P i โ†’ upper-resizing ๐“ค P)

all-propositions-are-small-gives-impredicativityโ‚ :

     global-propext
   โ†’ global-dfunext
   โ†’ all-propositions-are-small ๐“ค
   โ†’ ฮฉ ๐“ค has-size ๐“คโ‚

all-propositions-are-small-gives-impredicativityโ‚ = PR-gives-impredicativityโ‚

Impredicativity-gives-PR : propext ๐“ค
                         โ†’ dfunext ๐“ค ๐“ค
                         โ†’ Impredicativity ๐“ค ๐“ฅ
                         โ†’ propositional-resizing ๐“ค ๐“ฅ

Impredicativity-gives-PR {๐“ค} {๐“ฅ} pe fe (O , e) P i = Q , ฮต
 where
  ๐Ÿ™' : ๐“ค ฬ‡
  ๐Ÿ™' = Lift ๐“ค ๐Ÿ™

  k : is-subsingleton ๐Ÿ™'
  k (lift โ‹†) (lift โ‹†) = refl (lift โ‹†)

  down : ฮฉ ๐“ค โ†’ O
  down = โŒœ e โŒ

  O-is-set : is-set O
  O-is-set = equiv-to-set (โ‰ƒ-sym e) (ฮฉ-is-a-set fe pe)

  Q : ๐“ฅ ฬ‡
  Q = down (๐Ÿ™' , k) โ‰ก down (P , i)

  j : is-subsingleton Q
  j = O-is-set (down (Lift ๐“ค ๐Ÿ™ , k)) (down (P , i))

  ฯ† : Q โ†’ P
  ฯ† q = Idโ†’fun
         (ap _holds (equivs-are-lc down (โŒœโŒ-is-equiv e) q))
         (lift โ‹†)

  ฮณ : P โ†’ Q
  ฮณ p = ap down (to-subtype-โ‰ก
                    (ฮป _ โ†’ being-subsingleton-is-subsingleton fe)
                    (pe k i (ฮป _ โ†’ p) (ฮป _ โ†’ lift โ‹†)))

  ฮต : P โ‰ƒ Q
  ฮต = logically-equivalent-subsingletons-are-equivalent P Q i j (ฮณ , ฯ†)

PR-gives-existence-of-truncations : global-dfunext
                                  โ†’ Propositional-resizing
                                  โ†’ subsingleton-truncations-exist

PR-gives-existence-of-truncations fe R =
 record
 {
   โˆฅ_โˆฅ =

    ฮป {๐“ค} X โ†’ resize R
               (is-inhabited X)
               (inhabitation-is-subsingleton fe X) ;

   โˆฅโˆฅ-is-subsingleton =

    ฮป {๐“ค} {X} โ†’ resize-is-subsingleton R
                 (is-inhabited X)
                 (inhabitation-is-subsingleton fe X) ;

   โˆฃ_โˆฃ =

    ฮป {๐“ค} {X} x โ†’ to-resize R
                   (is-inhabited X)
                   (inhabitation-is-subsingleton fe X)
                   (inhabited-intro x) ;

   โˆฅโˆฅ-recursion =

    ฮป {๐“ค} {๐“ฅ} {X} {P} i u s โ†’ from-resize R P i
                                (inhabited-recursion
                                  (resize-is-subsingleton R P i)
                                  (to-resize R P i โˆ˜ u)
                                  (from-resize R
                                    (is-inhabited X)
                                    (inhabitation-is-subsingleton fe X) s))
 }

module powerset-union-existence
        (pt  : subsingleton-truncations-exist)
        (hfe : global-hfunext)
       where

 open basic-truncation-development pt hfe

 family-union : {X : ๐“ค โŠ” ๐“ฅ ฬ‡ } {I : ๐“ฅ ฬ‡ } โ†’ (I โ†’ ๐“Ÿ X) โ†’ ๐“Ÿ X
 family-union {๐“ค} {๐“ฅ} {X} {I} A = ฮป x โ†’ (โˆƒ i ๊ž‰ I , x โˆˆ A i) , โˆƒ-is-subsingleton

 ๐“Ÿ๐“Ÿ : ๐“ค ฬ‡ โ†’ ๐“ค โบโบ ฬ‡
 ๐“Ÿ๐“Ÿ X = ๐“Ÿ (๐“Ÿ X)

 existence-of-unions : (๐“ค : Universe) โ†’ ๐“ค โบโบ ฬ‡
 existence-of-unions ๐“ค =
  (X : ๐“ค ฬ‡ ) (๐“ : ๐“Ÿ๐“Ÿ X) โ†’ ฮฃ B ๊ž‰ ๐“Ÿ X , ((x : X) โ†’ (x โˆˆ B) โ‡” (โˆƒ A ๊ž‰ ๐“Ÿ X , (A โˆˆ ๐“) ร— (x โˆˆ A)))

 existence-of-unionsโ‚ : (๐“ค :  Universe) โ†’ _ ฬ‡
 existence-of-unionsโ‚ ๐“ค =
  (X : ๐“ค ฬ‡ )
  (๐“ : (X โ†’ ฮฉ _) โ†’ ฮฉ _)
     โ†’ ฮฃ B ๊ž‰ (X โ†’ ฮฉ _) , ((x : X) โ†’ (x โˆˆ B) โ‡” (โˆƒ A ๊ž‰ (X โ†’ ฮฉ _) , (A โˆˆ ๐“) ร— (x โˆˆ A)))

 existence-of-unionsโ‚‚ : (๐“ค :  Universe) โ†’ ๐“ค โบโบ ฬ‡
 existence-of-unionsโ‚‚ ๐“ค =
  (X : ๐“ค ฬ‡ )
  (๐“ : (X โ†’ ฮฉ ๐“ค) โ†’ ฮฉ (๐“ค โบ))
     โ†’ ฮฃ B ๊ž‰ (X โ†’ ฮฉ ๐“ค) , ((x : X) โ†’ (x โˆˆ B) โ‡” (โˆƒ A ๊ž‰ (X โ†’ ฮฉ ๐“ค) , (A โˆˆ ๐“) ร— (x โˆˆ A)))

 existence-of-unions-agreement : existence-of-unions ๐“ค โ‰ก existence-of-unionsโ‚‚ ๐“ค
 existence-of-unions-agreement = refl _

 existence-of-unions-gives-PR : existence-of-unions ๐“ค
                              โ†’ propositional-resizing (๐“ค โบ) ๐“ค

 existence-of-unions-gives-PR {๐“ค} ฮฑ = ฮณ
  where
   ฮณ : (P : ๐“ค โบ ฬ‡ ) โ†’ (i : is-subsingleton P) โ†’ P has-size ๐“ค
   ฮณ P i = Q , e
    where
    ๐Ÿ™แตค : ๐“ค ฬ‡
    ๐Ÿ™แตค = Lift ๐“ค ๐Ÿ™

    โ‹†แตค : ๐Ÿ™แตค
    โ‹†แตค = lift โ‹†

    ๐Ÿ™แตค-is-subsingleton : is-subsingleton ๐Ÿ™แตค
    ๐Ÿ™แตค-is-subsingleton = equiv-to-subsingleton (Lift-โ‰ƒ ๐Ÿ™) ๐Ÿ™-is-subsingleton

    ๐“ : ๐“Ÿ๐“Ÿ ๐Ÿ™แตค
    ๐“ = ฮป (A : ๐“Ÿ ๐Ÿ™แตค) โ†’ P , i

    B : ๐“Ÿ ๐Ÿ™แตค
    B = prโ‚ (ฮฑ ๐Ÿ™แตค ๐“)

    ฯ† : (x : ๐Ÿ™แตค) โ†’ (x โˆˆ B) โ‡” (โˆƒ A ๊ž‰ ๐“Ÿ ๐Ÿ™แตค , (A โˆˆ ๐“) ร— (x โˆˆ A))
    ฯ† = prโ‚‚ (ฮฑ ๐Ÿ™แตค ๐“)

    Q : ๐“ค ฬ‡
    Q = โ‹†แตค โˆˆ B

    j : is-subsingleton Q
    j = โˆˆ-is-subsingleton B โ‹†แตค

    f : P โ†’ Q
    f p = b
     where
      a : ฮฃ A ๊ž‰ ๐“Ÿ ๐Ÿ™แตค , (A โˆˆ ๐“) ร— (โ‹†แตค โˆˆ A)
      a = (ฮป (x : ๐Ÿ™แตค) โ†’ ๐Ÿ™แตค , ๐Ÿ™แตค-is-subsingleton) , p , โ‹†แตค

      b : โ‹†แตค โˆˆ B
      b = rl-implication (ฯ† โ‹†แตค) โˆฃ a โˆฃ

    g : Q โ†’ P
    g q = โˆฅโˆฅ-recursion i b a
     where
      a : โˆƒ A ๊ž‰ ๐“Ÿ ๐Ÿ™แตค , (A โˆˆ ๐“) ร— (โ‹†แตค โˆˆ A)
      a = lr-implication (ฯ† โ‹†แตค) q

      b : (ฮฃ A ๊ž‰ ๐“Ÿ ๐Ÿ™แตค , (A โˆˆ ๐“) ร— (โ‹†แตค โˆˆ A)) โ†’ P
      b (A , m , _) = m

    e : P โ‰ƒ Q
    e = logically-equivalent-subsingletons-are-equivalent P Q i j (f , g)

 PR-gives-existence-of-unions : propositional-resizing (๐“ค โบ) ๐“ค
                              โ†’ existence-of-unions ๐“ค

 PR-gives-existence-of-unions {๐“ค} ฯ X ๐“ = B , (ฮป x โ†’ lr x , rl x)
  where
   ฮฒ : X โ†’ ๐“ค โบ ฬ‡
   ฮฒ x = โˆƒ A ๊ž‰ ๐“Ÿ X , (A โˆˆ ๐“) ร— (x โˆˆ A)

   i : (x : X) โ†’ is-subsingleton (ฮฒ x)
   i x = โˆƒ-is-subsingleton

   B : ๐“Ÿ X
   B x = (resize ฯ (ฮฒ x) (i x) , resize-is-subsingleton ฯ (ฮฒ x) (i x))

   lr : (x : X) โ†’ x โˆˆ B โ†’ โˆƒ A ๊ž‰ ๐“Ÿ X , (A โˆˆ ๐“) ร— (x โˆˆ A)
   lr x = from-resize ฯ (ฮฒ x) (i x)

   rl : (x : X) โ†’ (โˆƒ A ๊ž‰ ๐“Ÿ X , (A โˆˆ ๐“) ร— (x โˆˆ A)) โ†’ x โˆˆ B
   rl x = to-resize ฯ (ฮฒ x) (i x)

module basic-powerset-development
        (hfe : global-hfunext)
        (ฯ   : Propositional-resizing)
       where

  pt : subsingleton-truncations-exist
  pt = PR-gives-existence-of-truncations (hfunext-gives-dfunext hfe) ฯ

  open basic-truncation-development pt hfe
  open powerset-union-existence pt hfe

  โ‹ƒ : {X : ๐“ค ฬ‡ } โ†’ ๐“Ÿ๐“Ÿ X โ†’ ๐“Ÿ X
  โ‹ƒ ๐“ = prโ‚ (PR-gives-existence-of-unions ฯ _ ๐“)

  โ‹ƒ-property : {X : ๐“ค ฬ‡ } (๐“ : ๐“Ÿ๐“Ÿ X)
             โ†’ (x : X) โ†’ (x โˆˆ โ‹ƒ ๐“) โ‡” (โˆƒ A ๊ž‰ ๐“Ÿ X , (A โˆˆ ๐“) ร— (x โˆˆ A))

  โ‹ƒ-property ๐“ = prโ‚‚ (PR-gives-existence-of-unions ฯ _ ๐“)

  intersections-exist :
    (X : ๐“ค ฬ‡ )
    (๐“ : ๐“Ÿ๐“Ÿ X)
       โ†’ ฮฃ B ๊ž‰ ๐“Ÿ X , ((x : X) โ†’ (x โˆˆ B) โ‡” ((A : ๐“Ÿ X) โ†’ A โˆˆ ๐“ โ†’ x โˆˆ A))

  intersections-exist {๐“ค} X ๐“ = B , (ฮป x โ†’ lr x , rl x)
   where
    ฮฒ : X โ†’ ๐“ค โบ ฬ‡
    ฮฒ x = (A : ๐“Ÿ X) โ†’ A โˆˆ ๐“ โ†’ x โˆˆ A

    i : (x : X) โ†’ is-subsingleton (ฮฒ x)
    i x = ฮ -is-subsingleton hunapply
           (ฮป A โ†’ ฮ -is-subsingleton hunapply
           (ฮป _ โ†’ โˆˆ-is-subsingleton A x))

    B : ๐“Ÿ X
    B x = (resize ฯ (ฮฒ x) (i x) , resize-is-subsingleton ฯ (ฮฒ x) (i x))

    lr : (x : X) โ†’ x โˆˆ B โ†’ (A : ๐“Ÿ X) โ†’ A โˆˆ ๐“ โ†’ x โˆˆ A
    lr x = from-resize ฯ (ฮฒ x) (i x)

    rl : (x : X) โ†’ ((A : ๐“Ÿ X) โ†’ A โˆˆ ๐“ โ†’ x โˆˆ A) โ†’ x โˆˆ B
    rl x = to-resize ฯ (ฮฒ x) (i x)

  โ‹‚ : {X : ๐“ค ฬ‡ } โ†’ ๐“Ÿ๐“Ÿ X โ†’ ๐“Ÿ X
  โ‹‚ {๐“ค} {X} ๐“ = prโ‚ (intersections-exist X ๐“)

  โ‹‚-property : {X : ๐“ค ฬ‡ } (๐“ : ๐“Ÿ๐“Ÿ X)
             โ†’ (x : X) โ†’ (x โˆˆ โ‹‚ ๐“) โ‡” ((A : ๐“Ÿ X) โ†’ A โˆˆ ๐“ โ†’ x โˆˆ A)

  โ‹‚-property {๐“ค} {X} ๐“ = prโ‚‚ (intersections-exist X ๐“)

  โˆ… full : {X : ๐“ค ฬ‡ } โ†’ ๐“Ÿ X

  โˆ…    = ฮป x โ†’ (Lift _ ๐Ÿ˜ , equiv-to-subsingleton (Lift-โ‰ƒ ๐Ÿ˜) ๐Ÿ˜-is-subsingleton)

  full = ฮป x โ†’ (Lift _ ๐Ÿ™ , equiv-to-subsingleton (Lift-โ‰ƒ ๐Ÿ™) ๐Ÿ™-is-subsingleton)

  โˆ…-property : (X : ๐“ค ฬ‡ ) โ†’ (x : X) โ†’ ยฌ(x โˆˆ โˆ…)
  โˆ…-property X x = lower

  full-property : (X : ๐“ค ฬ‡ ) โ†’ (x : X) โ†’ x โˆˆ full
  full-property X x = lift โ‹†

  _โˆฉ_ _โˆช_ : {X : ๐“ค ฬ‡ } โ†’ ๐“Ÿ X โ†’ ๐“Ÿ X โ†’ ๐“Ÿ X

  (A โˆช B) = ฮป x โ†’ ((x โˆˆ A) โˆจ (x โˆˆ B)) , โˆจ-is-subsingleton

  (A โˆฉ B) = ฮป x โ†’ ((x โˆˆ A) ร— (x โˆˆ B)) ,
                  ร—-is-subsingleton
                    (โˆˆ-is-subsingleton A x)
                    (โˆˆ-is-subsingleton B x)

  โˆช-property : {X : ๐“ค ฬ‡ } (A B : ๐“Ÿ X)
             โ†’ (x : X) โ†’ x โˆˆ (A โˆช B) โ‡” (x โˆˆ A) โˆจ (x โˆˆ B)

  โˆช-property {๐“ค} {X} A B x = id , id

  โˆฉ-property : {X : ๐“ค ฬ‡ } (A B : ๐“Ÿ X)
             โ†’ (x : X) โ†’ x โˆˆ (A โˆฉ B) โ‡” (x โˆˆ A) ร— (x โˆˆ B)

  โˆฉ-property {๐“ค} {X} A B x = id , id

  infix  20 _โˆฉ_
  infix  20 _โˆช_

  Top : (๐“ค : Universe) โ†’ ๐“ค โบโบ ฬ‡
  Top ๐“ค = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , is-set X
                    ร— (ฮฃ ๐“ž ๊ž‰ ๐“Ÿ๐“Ÿ X , full โˆˆ ๐“ž
                                  ร— ((U V : ๐“Ÿ X) โ†’ U โˆˆ ๐“ž โ†’ V โˆˆ ๐“ž โ†’ (U โˆฉ V) โˆˆ ๐“ž)
                                  ร— ((๐“– : ๐“Ÿ๐“Ÿ X) โ†’ ๐“– โŠ† ๐“ž โ†’ โ‹ƒ ๐“– โˆˆ ๐“ž))

is-subsingleton-valued
 reflexive
 symmetric
 transitive
 is-equivalence-relation :

 {X : ๐“ค ฬ‡ } โ†’ (X โ†’ X โ†’ ๐“ฅ ฬ‡ ) โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡

is-subsingleton-valued  _โ‰ˆ_ = โˆ€ x y โ†’ is-subsingleton (x โ‰ˆ y)
reflexive               _โ‰ˆ_ = โˆ€ x โ†’ x โ‰ˆ x
symmetric               _โ‰ˆ_ = โˆ€ x y โ†’ x โ‰ˆ y โ†’ y โ‰ˆ x
transitive              _โ‰ˆ_ = โˆ€ x y z โ†’ x โ‰ˆ y โ†’ y โ‰ˆ z โ†’ x โ‰ˆ z

is-equivalence-relation _โ‰ˆ_ = is-subsingleton-valued _โ‰ˆ_
                            ร— reflexive _โ‰ˆ_
                            ร— symmetric _โ‰ˆ_
                            ร— transitive _โ‰ˆ_

module quotient
       {๐“ค ๐“ฅ : Universe}
       (pt  : subsingleton-truncations-exist)
       (hfe : global-hfunext)
       (pe  : propext ๐“ฅ)
       (X   : ๐“ค ฬ‡ )
       (_โ‰ˆ_ : X โ†’ X โ†’ ๐“ฅ ฬ‡ )
       (โ‰ˆp  : is-subsingleton-valued _โ‰ˆ_)
       (โ‰ˆr  : reflexive _โ‰ˆ_)
       (โ‰ˆs  : symmetric _โ‰ˆ_)
       (โ‰ˆt  : transitive _โ‰ˆ_)
      where

 open basic-truncation-development pt hfe

 equiv-rel : X โ†’ (X โ†’ ฮฉ ๐“ฅ)
 equiv-rel x y = (x โ‰ˆ y) , โ‰ˆp x y

 X/โ‰ˆ : ๐“ฅ โบ โŠ” ๐“ค  ฬ‡
 X/โ‰ˆ = image equiv-rel

 X/โ‰ˆ-is-set : is-set X/โ‰ˆ
 X/โ‰ˆ-is-set = subsets-of-sets-are-sets (X โ†’ ฮฉ ๐“ฅ) _
               (powersets-are-sets (dfunext-gives-hfunext hunapply) hunapply pe)
               (ฮป _ โ†’ โˆƒ-is-subsingleton)

 ฮท : X โ†’ X/โ‰ˆ
 ฮท = corestriction equiv-rel

 ฮท-surjection : is-surjection ฮท
 ฮท-surjection = corestriction-surjection equiv-rel

 ฮท-induction : (P : X/โ‰ˆ โ†’ ๐“ฆ ฬ‡ )
             โ†’ ((x' : X/โ‰ˆ) โ†’ is-subsingleton (P x'))
             โ†’ ((x : X) โ†’ P (ฮท x))
             โ†’ (x' : X/โ‰ˆ) โ†’ P x'

 ฮท-induction = surjection-induction ฮท ฮท-surjection

 ฮท-equiv-equal : {x y : X} โ†’ x โ‰ˆ y โ†’ ฮท x โ‰ก ฮท y
 ฮท-equiv-equal {x} {y} e =
  to-subtype-โ‰ก
    (ฮป _ โ†’ โˆƒ-is-subsingleton)
    (hunapply (ฮป z โ†’ to-subtype-โ‰ก
                        (ฮป _ โ†’ being-subsingleton-is-subsingleton hunapply)
                        (pe (โ‰ˆp x z) (โ‰ˆp y z) (โ‰ˆt y x z (โ‰ˆs x y e)) (โ‰ˆt x y z e))))

 ฮท-equal-equiv : {x y : X} โ†’ ฮท x โ‰ก ฮท y โ†’ x โ‰ˆ y
 ฮท-equal-equiv {x} {y} p = equiv-rel-reflect (ap prโ‚ p)
  where
   equiv-rel-reflect : equiv-rel x โ‰ก equiv-rel y โ†’ x โ‰ˆ y
   equiv-rel-reflect q = b (โ‰ˆr y)
    where
     a : (y โ‰ˆ y) โ‰ก (x โ‰ˆ y)
     a = ap (ฮป - โ†’ prโ‚(- y)) (q โปยน)

     b : y โ‰ˆ y โ†’ x โ‰ˆ y
     b = Idโ†’fun a

 universal-property : (A : ๐“ฆ ฬ‡ )
                    โ†’ is-set A
                    โ†’ (f : X โ†’ A)
                    โ†’ ({x x' : X} โ†’ x โ‰ˆ x' โ†’ f x โ‰ก f x')
                    โ†’ โˆƒ! f' ๊ž‰ (X/โ‰ˆ โ†’ A), f' โˆ˜ ฮท โ‰ก f

 universal-property {๐“ฆ} A i f ฯ„ = e
  where
   G : X/โ‰ˆ โ†’ ๐“ฅ โบ โŠ” ๐“ค โŠ” ๐“ฆ ฬ‡
   G x' = ฮฃ a ๊ž‰ A , โˆƒ x ๊ž‰ X , (ฮท x โ‰ก x') ร— (f x โ‰ก a)

   ฯ† : (x' : X/โ‰ˆ) โ†’ is-subsingleton (G x')
   ฯ† = ฮท-induction _ ฮณ induction-step
    where
     induction-step : (y : X) โ†’ is-subsingleton (G (ฮท y))
     induction-step x (a , d) (b , e) = to-subtype-โ‰ก (ฮป _ โ†’ โˆƒ-is-subsingleton) p
      where
       h : (ฮฃ x' ๊ž‰ X , (ฮท x' โ‰ก ฮท x) ร— (f x' โ‰ก a))
         โ†’ (ฮฃ y' ๊ž‰ X , (ฮท y' โ‰ก ฮท x) ร— (f y' โ‰ก b))
         โ†’ a โ‰ก b
       h (x' , r , s) (y' , t , u) = a    โ‰กโŸจ s โปยน                         โŸฉ
                                     f x' โ‰กโŸจ ฯ„ (ฮท-equal-equiv (r โˆ™ t โปยน)) โŸฉ
                                     f y' โ‰กโŸจ u                            โŸฉ
                                     b    โˆŽ

       p : a โ‰ก b
       p = โˆฅโˆฅ-recursion (i a b) (ฮป ฯƒ โ†’ โˆฅโˆฅ-recursion (i a b) (h ฯƒ) e) d

     ฮณ : (x' : X/โ‰ˆ) โ†’ is-subsingleton (is-subsingleton (G x'))
     ฮณ x' = being-subsingleton-is-subsingleton hunapply

   k : (x' : X/โ‰ˆ) โ†’ G x'
   k = ฮท-induction _ ฯ† induction-step
    where
     induction-step : (y : X) โ†’ G (ฮท y)
     induction-step x = f x , โˆฃ x , refl (ฮท x) , refl (f x) โˆฃ

   f' : X/โ‰ˆ โ†’ A
   f' x' = prโ‚ (k x')

   r : f' โˆ˜ ฮท โ‰ก f
   r = hunapply h
    where
     g : (y : X) โ†’ โˆƒ x ๊ž‰ X , (ฮท x โ‰ก ฮท y) ร— (f x โ‰ก f' (ฮท y))
     g y = prโ‚‚ (k (ฮท y))

     j : (y : X) โ†’ (ฮฃ x ๊ž‰ X , (ฮท x โ‰ก ฮท y) ร— (f x โ‰ก f' (ฮท y))) โ†’ f'(ฮท y) โ‰ก f y
     j y (x , p , q) = f' (ฮท y) โ‰กโŸจ q โปยน                โŸฉ
                       f x      โ‰กโŸจ ฯ„ (ฮท-equal-equiv p) โŸฉ
                       f y      โˆŽ

     h : (y : X) โ†’ f'(ฮท y) โ‰ก f y
     h y = โˆฅโˆฅ-recursion (i (f' (ฮท y)) (f y)) (j y) (g y)

   c : (ฯƒ : ฮฃ f'' ๊ž‰ (X/โ‰ˆ โ†’ A), f'' โˆ˜ ฮท โ‰ก f) โ†’ (f' , r) โ‰ก ฯƒ
   c (f'' , s) = to-subtype-โ‰ก (ฮป g โ†’ ฮ -is-set hfe (ฮป _ โ†’ i) (g โˆ˜ ฮท) f) t
    where
     w : โˆ€ x โ†’ f'(ฮท x) โ‰ก f''(ฮท x)
     w = happly (f' โˆ˜ ฮท) (f'' โˆ˜ ฮท) (r โˆ™ s โปยน)

     t : f' โ‰ก f''
     t = hunapply (ฮท-induction _ (ฮป x' โ†’ i (f' x') (f'' x')) w)

   e : โˆƒ! f' ๊ž‰ (X/โ‰ˆ โ†’ A), f' โˆ˜ ฮท โ‰ก f
   e = (f' , r) , c

module โ„•-order-exercise-solution where

  _โ‰ค'_ : โ„• โ†’ โ„• โ†’ ๐“คโ‚€ ฬ‡
  _โ‰ค'_ = โ„•-iteration (โ„• โ†’ ๐“คโ‚€ ฬ‡ ) (ฮป y โ†’ ๐Ÿ™)
          (ฮป f โ†’ โ„•-recursion (๐“คโ‚€ ฬ‡ ) ๐Ÿ˜ (ฮป y P โ†’ f y))

  open โ„•-order

  โ‰ค-and-โ‰ค'-coincide : (x y : โ„•) โ†’ (x โ‰ค y) โ‰ก (x โ‰ค' y)
  โ‰ค-and-โ‰ค'-coincide 0 y = refl _
  โ‰ค-and-โ‰ค'-coincide (succ x) 0 = refl _
  โ‰ค-and-โ‰ค'-coincide (succ x) (succ y) = โ‰ค-and-โ‰ค'-coincide x y

module โ„•-more where

  open Arithmetic renaming (_+_ to _โˆ”_)
  open basic-arithmetic-and-order

  โ‰ค-prop-valued : (x y : โ„•) โ†’ is-subsingleton (x โ‰ค y)
  โ‰ค-prop-valued 0 y               = ๐Ÿ™-is-subsingleton
  โ‰ค-prop-valued (succ x) zero     = ๐Ÿ˜-is-subsingleton
  โ‰ค-prop-valued (succ x) (succ y) = โ‰ค-prop-valued x y

  โ‰ผ-prop-valued : (x y : โ„•) โ†’ is-subsingleton (x โ‰ผ y)
  โ‰ผ-prop-valued x y (z , p) (z' , p') = ฮณ
   where
    q : z โ‰ก z'
    q = +-lc x z z' (x โˆ” z  โ‰กโŸจ p     โŸฉ
                     y      โ‰กโŸจ p' โปยน โŸฉ
                     x โˆ” z' โˆŽ)

    ฮณ : z , p โ‰ก z' , p'
    ฮณ = to-subtype-โ‰ก (ฮป z โ†’ โ„•-is-set (x โˆ” z) y) q

  โ‰ค-charac : propext ๐“คโ‚€ โ†’ (x y : โ„•) โ†’ (x โ‰ค y) โ‰ก (x โ‰ผ y)
  โ‰ค-charac pe x y = pe (โ‰ค-prop-valued x y) (โ‰ผ-prop-valued x y)
                       (โ‰ค-gives-โ‰ผ x y) (โ‰ผ-gives-โ‰ค x y)

the-subsingletons-are-the-subtypes-of-a-singleton : (X : ๐“ค ฬ‡ )
                                                  โ†’ is-subsingleton X โ‡” (X โ†ช ๐Ÿ™)
the-subsingletons-are-the-subtypes-of-a-singleton X = ฯ† , ฯˆ
 where
  i : is-subsingleton X โ†’ is-embedding (!๐Ÿ™' X)
  i s โ‹† (x , refl โ‹†) (y , refl โ‹†) = ap (ฮป - โ†’ - , refl โ‹†) (s x y)

  ฯ† : is-subsingleton X โ†’ X โ†ช ๐Ÿ™
  ฯ† s = !๐Ÿ™ , i s

  ฯˆ : X โ†ช ๐Ÿ™ โ†’ is-subsingleton X
  ฯˆ (f , e) x y = d
   where
    a : x โ‰ก y โ†’ f x โ‰ก f y
    a = ap f {x} {y}

    b : is-equiv a
    b = embedding-gives-ap-is-equiv f e x y

    c : f x โ‰ก f y
    c = ๐Ÿ™-is-subsingleton (f x) (f y)

    d : x โ‰ก y
    d = inverse a b c

the-subsingletons-are-the-subtypes-of-a-singleton' : propext ๐“ค โ†’ global-dfunext
                                                   โ†’ (X : ๐“ค ฬ‡ )
                                                   โ†’ is-subsingleton X โ‰ก (X โ†ช ๐Ÿ™)
the-subsingletons-are-the-subtypes-of-a-singleton' pe fe X = ฮณ
 where
  a : is-subsingleton X โ‡” (X โ†ช ๐Ÿ™)
  a = the-subsingletons-are-the-subtypes-of-a-singleton X

  b : is-subsingleton (X โ†ช ๐Ÿ™)
  b (f , e) (f' , e') = to-subtype-โ‰ก
                           (being-embedding-is-subsingleton fe)
                           (fe (ฮป x โ†’ ๐Ÿ™-is-subsingleton (f x) (f' x)))

  ฮณ : is-subsingleton X โ‰ก (X โ†ช ๐Ÿ™)
  ฮณ = pe (being-subsingleton-is-subsingleton fe) b (prโ‚ a) (prโ‚‚ a)

Gโ†‘-โ‰ƒ-equation : (ua : is-univalent (๐“ค โŠ” ๐“ฅ))
              โ†’ (X : ๐“ค ฬ‡ )
              โ†’ (A : (ฮฃ Y ๊ž‰ ๐“ค โŠ” ๐“ฅ ฬ‡ , X โ‰ƒ Y) โ†’ ๐“ฆ ฬ‡ )
              โ†’ (a : A (Lift ๐“ฅ X , โ‰ƒ-Lift X))
              โ†’ Gโ†‘-โ‰ƒ ua X A a (Lift ๐“ฅ X) (โ‰ƒ-Lift X) โ‰ก a
Gโ†‘-โ‰ƒ-equation {๐“ค} {๐“ฅ} {๐“ฆ} ua X A a =
  Gโ†‘-โ‰ƒ ua X A a (Lift ๐“ฅ X) (โ‰ƒ-Lift X) โ‰กโŸจ refl (transport A p a)       โŸฉ
  transport A p a                     โ‰กโŸจ ap (ฮป - โ†’ transport A - a) q โŸฉ
  transport A (refl t) a              โ‰กโŸจ refl a                       โŸฉ
  a                                   โˆŽ
 where
  t : (ฮฃ Y ๊ž‰ ๐“ค โŠ” ๐“ฅ ฬ‡ , X โ‰ƒ Y)
  t = (Lift ๐“ฅ X , โ‰ƒ-Lift X)

  p : t โ‰ก t
  p = univalenceโ†’'' {๐“ค} {๐“ค โŠ” ๐“ฅ} ua X t t

  q : p โ‰ก refl t
  q = subsingletons-are-sets (ฮฃ Y ๊ž‰ ๐“ค โŠ” ๐“ฅ ฬ‡ , X โ‰ƒ Y)
       (univalenceโ†’'' {๐“ค} {๐“ค โŠ” ๐“ฅ} ua X) t t p (refl t)

Hโ†‘-โ‰ƒ-equation : (ua : is-univalent (๐“ค โŠ” ๐“ฅ))
              โ†’ (X : ๐“ค ฬ‡ )
              โ†’ (A : (Y : ๐“ค โŠ” ๐“ฅ ฬ‡ ) โ†’ X โ‰ƒ Y โ†’ ๐“ฆ ฬ‡ )
              โ†’ (a : A (Lift ๐“ฅ X) (โ‰ƒ-Lift X))
              โ†’ Hโ†‘-โ‰ƒ ua X A a (Lift ๐“ฅ X) (โ‰ƒ-Lift X) โ‰ก a
Hโ†‘-โ‰ƒ-equation ua X A = Gโ†‘-โ‰ƒ-equation ua X (ฮฃ-induction A)

has-section-charac : {X : ๐“ค ฬ‡ } {Y : ๐“ฅ ฬ‡ } (f : X โ†’ Y)
                   โ†’ ((y : Y) โ†’ ฮฃ x ๊ž‰ X , f x โ‰ก y) โ‰ƒ has-section f
has-section-charac f = ฮ ฮฃ-distr-โ‰ƒ

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   โŸฉ
 (ฮฃ X ๊ž‰ ๐“ค ฬ‡ , ฮฃ f ๊ž‰ (X โ†’ Y) , ((y : Y) โ†’ ฮฃ x ๊ž‰ X , f x โ‰ก y))     โ‰ƒโŸจ ii   โŸฉ
 ((๐“ค /[ id ] Y))                                                 โ‰ƒโŸจ iii โŸฉ
 (Y โ†’ pointed-types ๐“ค)                                           โ– 
 where
  i   = โ‰ƒ-sym (ฮฃ-cong (ฮป X โ†’ ฮฃ-cong (ฮป f โ†’ ฮ ฮฃ-distr-โ‰ƒ)))
  ii  = Idโ†’Eq _ _ (refl _)
  iii = special-map-classifier (ua ๐“ค)
         (univalence-gives-dfunext' (ua ๐“ค) (ua (๐“ค โบ)))
         id Y

module surjection-classifier
         (pt : subsingleton-truncations-exist)
         (ua : Univalence)
       where

  hfe : global-hfunext
  hfe = univalence-gives-global-hfunext ua

  open basic-truncation-development pt hfe public

  _โ† _ : ๐“ค ฬ‡ โ†’ ๐“ฅ ฬ‡ โ†’ ๐“ค โŠ” ๐“ฅ ฬ‡
  X โ†  Y = ฮฃ f ๊ž‰ (X โ†’ Y), is-surjection f

  surjections-into : ๐“ค ฬ‡ โ†’ ๐“ค โบ ฬ‡
  surjections-into {๐“ค} Y = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , X โ†  Y

  inhabited-types : (๐“ค : Universe) โ†’ ๐“ค โบ ฬ‡
  inhabited-types ๐“ค = ฮฃ X ๊ž‰ ๐“ค ฬ‡ , โˆฅ X โˆฅ

  surjection-classifier : Univalence
                        โ†’ (Y : ๐“ค ฬ‡ )
                        โ†’ surjections-into Y โ‰ƒ (Y โ†’ inhabited-types ๐“ค)
  surjection-classifier {๐“ค} ua = special-map-classifier (ua ๐“ค)
                                  (univalence-gives-dfunext' (ua ๐“ค) (ua (๐“ค โบ)))
                                  โˆฅ_โˆฅ

positive-cantors-diagonal : (e : โ„• โ†’ (โ„• โ†’ โ„•)) โ†’ ฮฃ ฮฑ ๊ž‰ (โ„• โ†’ โ„•), ((n : โ„•) โ†’ ฮฑ โ‰ข e n)

cantors-diagonal : ยฌ(ฮฃ e ๊ž‰ (โ„• โ†’ (โ„• โ†’ โ„•)) , ((ฮฑ : โ„• โ†’ โ„•) โ†’ ฮฃ n ๊ž‰ โ„• , ฮฑ โ‰ก e n))

๐Ÿš-has-๐Ÿš-automorphisms : dfunext ๐“คโ‚€ ๐“คโ‚€ โ†’ (๐Ÿš โ‰ƒ ๐Ÿš) โ‰ƒ ๐Ÿš

lifttwo : is-univalent ๐“คโ‚€ โ†’ is-univalent ๐“คโ‚ โ†’ (๐Ÿš โ‰ก ๐Ÿš) โ‰ก Lift ๐“คโ‚ ๐Ÿš

DNE : โˆ€ ๐“ค โ†’ ๐“ค โบ ฬ‡
DNE ๐“ค = (P : ๐“ค ฬ‡ ) โ†’ is-subsingleton P โ†’ ยฌยฌ P โ†’ P

ne : (X : ๐“ค ฬ‡ ) โ†’ ยฌยฌ(X + ยฌ X)

DNE-gives-EM : dfunext ๐“ค ๐“คโ‚€ โ†’ DNE ๐“ค โ†’ EM ๐“ค

EM-gives-DNE : EM ๐“ค โ†’ DNE ๐“ค

SN : โˆ€ ๐“ค โ†’ ๐“ค โบ ฬ‡
SN ๐“ค = (P : ๐“ค ฬ‡ ) โ†’ is-subsingleton P โ†’ ฮฃ X ๊ž‰ ๐“ค ฬ‡ , P โ‡” ยฌ X

SN-gives-DNE : SN ๐“ค โ†’ DNE ๐“ค

DNE-gives-SN : DNE ๐“ค โ†’ SN ๐“ค

succ-no-fixed-point : (n : โ„•) โ†’ succ n โ‰ข n
succ-no-fixed-point 0        = positive-not-zero 0
succ-no-fixed-point (succ n) = ฮณ
 where
  IH : succ n โ‰ข n
  IH = succ-no-fixed-point n

  ฮณ : succ (succ n) โ‰ข succ n
  ฮณ p = IH (succ-lc p)

positive-cantors-diagonal = sol
 where
  sol : (e : โ„• โ†’ (โ„• โ†’ โ„•)) โ†’ ฮฃ ฮฑ ๊ž‰ (โ„• โ†’ โ„•), ((n : โ„•) โ†’ ฮฑ โ‰ข e n)
  sol e = (ฮฑ , ฯ†)
   where
    ฮฑ : โ„• โ†’ โ„•
    ฮฑ n = succ(e n n)

    ฯ† : (n : โ„•) โ†’ ฮฑ โ‰ข e n
    ฯ† n p = succ-no-fixed-point (e n n) q
     where
      q = succ (e n n)  โ‰กโŸจ refl (ฮฑ n)       โŸฉ
          ฮฑ n           โ‰กโŸจ ap (ฮป - โ†’ - n) p โŸฉ
          e n n         โˆŽ

cantors-diagonal = sol
 where
  sol : ยฌ(ฮฃ e ๊ž‰ (โ„• โ†’ (โ„• โ†’ โ„•)) , ((ฮฑ : โ„• โ†’ โ„•) โ†’ ฮฃ n ๊ž‰ โ„• , ฮฑ โ‰ก e n))
  sol (e , ฮณ) = c
   where
    ฮฑ : โ„• โ†’ โ„•
    ฮฑ = prโ‚ (positive-cantors-diagonal e)

    ฯ† : (n : โ„•) โ†’ ฮฑ โ‰ข e n
    ฯ† = prโ‚‚ (positive-cantors-diagonal e)

    b : ฮฃ n ๊ž‰ โ„• , ฮฑ โ‰ก e n
    b = ฮณ ฮฑ

    c : ๐Ÿ˜
    c = ฯ† (prโ‚ b) (prโ‚‚ b)

๐Ÿš-has-๐Ÿš-automorphisms = sol
 where
  sol : dfunext ๐“คโ‚€ ๐“คโ‚€ โ†’ (๐Ÿš โ‰ƒ ๐Ÿš) โ‰ƒ ๐Ÿš
  sol fe = invertibility-gives-โ‰ƒ f (g , ฮท , ฮต)
   where
    f : (๐Ÿš โ‰ƒ ๐Ÿš) โ†’ ๐Ÿš
    f (h , e) = h โ‚€

    g : ๐Ÿš โ†’ (๐Ÿš โ‰ƒ ๐Ÿš)
    g โ‚€ = id , id-is-equiv ๐Ÿš
    g โ‚ = swapโ‚‚ , swapโ‚‚-is-equiv

    ฮท : (e : ๐Ÿš โ‰ƒ ๐Ÿš) โ†’ g (f e) โ‰ก e
    ฮท (h , e) = ฮณ (h โ‚€) (h โ‚) (refl (h โ‚€)) (refl (h โ‚))
     where
      ฮณ : (m n : ๐Ÿš) โ†’ h โ‚€ โ‰ก m โ†’ h โ‚ โ‰ก n โ†’ g (h โ‚€) โ‰ก (h , e)

      ฮณ โ‚€ โ‚€ p q = !๐Ÿ˜ (g (h โ‚€) โ‰ก (h , e))
                     (โ‚-is-not-โ‚€ (equivs-are-lc h e (h โ‚ โ‰กโŸจ q    โŸฉ
                                                     โ‚€   โ‰กโŸจ p โปยน โŸฉ
                                                     h โ‚€ โˆŽ)))

      ฮณ โ‚€ โ‚ p q = to-subtype-โ‰ก
                     (being-equiv-is-subsingleton fe fe)
                     (fe (๐Ÿš-induction (ฮป n โ†’ prโ‚ (g (h โ‚€)) n โ‰ก h n)
                               (prโ‚ (g (h โ‚€)) โ‚€ โ‰กโŸจ ap (ฮป - โ†’ prโ‚ (g -) โ‚€) p โŸฉ
                                prโ‚ (g โ‚€) โ‚€     โ‰กโŸจ refl โ‚€                   โŸฉ
                                โ‚€               โ‰กโŸจ p โปยน                     โŸฉ
                                h โ‚€             โˆŽ)
                               (prโ‚ (g (h โ‚€)) โ‚ โ‰กโŸจ ap (ฮป - โ†’ prโ‚ (g -) โ‚) p โŸฉ
                                prโ‚ (g โ‚€) โ‚     โ‰กโŸจ refl โ‚                   โŸฉ
                                โ‚               โ‰กโŸจ q โปยน                     โŸฉ
                                h โ‚             โˆŽ)))

      ฮณ โ‚ โ‚€ p q = to-subtype-โ‰ก
                     (being-equiv-is-subsingleton fe fe)
                     (fe (๐Ÿš-induction (ฮป n โ†’ prโ‚ (g (h โ‚€)) n โ‰ก h n)
                               (prโ‚ (g (h โ‚€)) โ‚€ โ‰กโŸจ ap (ฮป - โ†’ prโ‚ (g -) โ‚€) p โŸฉ
                                prโ‚ (g โ‚) โ‚€     โ‰กโŸจ refl โ‚                   โŸฉ
                                โ‚               โ‰กโŸจ p โปยน                     โŸฉ
                                h โ‚€             โˆŽ)
                               (prโ‚ (g (h โ‚€)) โ‚ โ‰กโŸจ ap (ฮป - โ†’ prโ‚ (g -) โ‚) p โŸฉ
                                prโ‚ (g โ‚) โ‚     โ‰กโŸจ refl โ‚€                   โŸฉ
                                โ‚€               โ‰กโŸจ q โปยน                     โŸฉ
                                h โ‚             โˆŽ)))

      ฮณ โ‚ โ‚ p q = !๐Ÿ˜ (g (h โ‚€) โ‰ก (h , e))
                     (โ‚-is-not-โ‚€ (equivs-are-lc h e (h โ‚ โ‰กโŸจ q    โŸฉ
                                                     โ‚   โ‰กโŸจ p โปยน โŸฉ
                                                     h โ‚€ โˆŽ)))

    ฮต : (n : ๐Ÿš) โ†’ f (g n) โ‰ก n
    ฮต โ‚€ = refl โ‚€
    ฮต โ‚ = refl โ‚

lifttwo = sol
 where
  sol : is-univalent ๐“คโ‚€ โ†’ is-univalent ๐“คโ‚ โ†’ (๐Ÿš โ‰ก ๐Ÿš) โ‰ก Lift ๐“คโ‚ ๐Ÿš
  sol uaโ‚€ uaโ‚ = Eqโ†’Id uaโ‚ (๐Ÿš โ‰ก ๐Ÿš) (Lift ๐“คโ‚ ๐Ÿš) e
   where
    e = (๐Ÿš โ‰ก ๐Ÿš)   โ‰ƒโŸจ Idโ†’Eq ๐Ÿš ๐Ÿš , uaโ‚€ ๐Ÿš ๐Ÿš                                  โŸฉ
        (๐Ÿš โ‰ƒ ๐Ÿš)   โ‰ƒโŸจ ๐Ÿš-has-๐Ÿš-automorphisms (univalence-gives-dfunext uaโ‚€) โŸฉ
        ๐Ÿš         โ‰ƒโŸจ โ‰ƒ-sym (Lift-โ‰ƒ ๐Ÿš)                                     โŸฉ
        Lift ๐“คโ‚ ๐Ÿš โ– 

hde-is-subsingleton : dfunext ๐“ค ๐“คโ‚€
                    โ†’ dfunext ๐“ค ๐“ค
                    โ†’ (X : ๐“ค ฬ‡ )
                    โ†’ is-subsingleton (has-decidable-equality X)
hde-is-subsingleton feโ‚€ fe X h h' = c h h'
 where
  a : (x y : X) โ†’ is-subsingleton (decidable (x โ‰ก y))
  a x y = +-is-subsingleton' feโ‚€ b
   where
    b : is-subsingleton (x โ‰ก y)
    b = hedberg h x y

  c : is-subsingleton (has-decidable-equality X)
  c = ฮ -is-subsingleton fe (ฮป x โ†’ ฮ -is-subsingleton fe (a x))

ne = sol
 where
  sol : (X : ๐“ค ฬ‡ ) โ†’ ยฌยฌ(X + ยฌ X)
  sol X = ฮป (f : ยฌ(X + ยฌ X)) โ†’ f (inr (ฮป (x : X) โ†’ f (inl x)))

DNE-gives-EM = sol
 where
  sol : dfunext ๐“ค ๐“คโ‚€ โ†’ DNE ๐“ค โ†’ EM ๐“ค
  sol fe dne P i = dne (P + ยฌ P) (+-is-subsingleton' fe i) (ne P)

EM-gives-DNE = sol
 where
  sol : EM ๐“ค โ†’ DNE ๐“ค
  sol em P i = ฮณ (em P i)
   where
    ฮณ : P + ยฌ P โ†’ ยฌยฌ P โ†’ P
    ฮณ (inl p) ฯ† = p
    ฮณ (inr n) ฯ† = !๐Ÿ˜ P (ฯ† n)

SN-gives-DNE = sol
 where
  sol : SN ๐“ค โ†’ DNE ๐“ค
  sol {๐“ค} sn P i = h
   where
    X : ๐“ค ฬ‡
    X = prโ‚ (sn P i)

    f : P โ†’ ยฌ X
    f = prโ‚ (prโ‚‚ (sn P i))

    g : ยฌ X โ†’ P
    g = prโ‚‚ (prโ‚‚ (sn P i))

    f' : ยฌยฌ P โ†’ ยฌ(ยฌยฌ X)
    f' = contrapositive (contrapositive f)

    h : ยฌยฌ P โ†’ P
    h = g โˆ˜ tno X โˆ˜ f'

    h' : ยฌยฌ P โ†’ P
    h' ฯ† = g (ฮป (x : X) โ†’ ฯ† (ฮป (p : P) โ†’ f p x))

DNE-gives-SN = sol
 where
  sol : DNE ๐“ค โ†’ SN ๐“ค
  sol dne P i = ยฌ P , dni P , dne P i

infix   0 _โˆผ_
infixr 50 _,_
infixr 30 _ร—_
infixr 20 _+_
infixl 70 _โˆ˜_
infix   0 Id
infix   0 _โ‰ก_
infix  10 _โ‡”_
infixl 30 _โˆ™_
infixr  0 _โ‰กโŸจ_โŸฉ_
infix   1 _โˆŽ
infix  40 _โปยน
infix  10 _โ—_
infixr  0 _โ—โŸจ_โŸฉ_
infix   1 _โ—€
infix  10 _โ‰ƒ_
infixl 30 _โ—_
infixr  0 _โ‰ƒโŸจ_โŸฉ_
infix   1 _โ– 
infix  40 _โˆˆ_
infix  30 _[_,_]
infixr -1 -ฮฃ
infixr -1 -ฮ 
infixr -1 -โˆƒ!