less prototype, less bad code implementation of CCHM type theory
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

1652 lines
58 KiB

  1. -- We begin by adding some primitive bindings using the PRIMITIVE pragma.
  2. --
  3. -- It goes like this: PRIMITIVE primName varName.
  4. --
  5. -- If the varName is dropped, then it's taken to be the same as primName.
  6. --
  7. -- If there is a previous declaration for the varName, then the type
  8. -- is checked against the internally-known "proper" type for the primitive.
  9. -- Universe of fibrant types
  10. {-# PRIMITIVE Type #-}
  11. -- Universe of non-fibrant types
  12. {-# PRIMITIVE Pretype #-}
  13. -- Fibrant is a fancy word for "has a composition structure". Most types
  14. -- we inherit from MLTT are fibrant:
  15. --
  16. -- Stuff like products Π, sums Σ, naturals, booleans, lists, etc., all
  17. -- have composition structures.
  18. --
  19. -- The non-fibrant types are part of the structure of cubical
  20. -- categories: The interval, partial elements, cubical subtypes, ...
  21. -- The interval
  22. ---------------
  23. -- The interval has two endpoints i0 and i1.
  24. -- These form a de Morgan algebra.
  25. I : Pretype
  26. {-# PRIMITIVE Interval I #-}
  27. i0, i1 : I
  28. {-# PRIMITIVE i0 #-}
  29. {-# PRIMITIVE i1 #-}
  30. -- "minimum" on the interval
  31. iand : I -> I -> I
  32. {-# PRIMITIVE iand #-}
  33. -- "maximum" on the interval.
  34. ior : I -> I -> I
  35. {-# PRIMITIVE ior #-}
  36. -- The interpretation of iand as min and ior as max justifies the fact that
  37. -- ior i (inot i) != i1, since that equality only holds for the endpoints.
  38. -- inot i = 1 - i is a de Morgan involution.
  39. inot : I -> I
  40. {-# PRIMITIVE inot #-}
  41. -- Paths
  42. --------
  43. -- Since every function in type theory is internally continuous,
  44. -- and the two endpoints i0 and i1 are equal, we can take the type of
  45. -- equalities to be continuous functions out of the interval.
  46. -- That is, x ≡ y iff. ∃ f : I -> A, f i0 = x, f i1 = y.
  47. -- The type PathP generalises this to dependent products (i : I) -> A i.
  48. PathP : (A : I -> Type) -> A i0 -> A i1 -> Type
  49. {-# PRIMITIVE PathP #-}
  50. -- By taking the first argument to be constant we get the equality type
  51. -- Path.
  52. Path : {A : Type} -> A -> A -> Type
  53. Path {A} = PathP (\i -> A)
  54. -- reflexivity is given by constant paths
  55. refl : {A : Type} {x : A} -> Path x x
  56. refl {A} {x} i = x
  57. -- Symmetry (for dpeendent paths) is given by inverting the argument to the path, such that
  58. -- sym p i0 = p (inot i0) = p i1
  59. -- sym p i1 = p (inot i1) = p i0
  60. -- This has the correct endpoints.
  61. sym : {A : I -> Type} {x : A i0} {y : A i1} -> PathP A x y -> PathP (\i -> A (inot i)) y x
  62. sym p i = p (inot i)
  63. id : {A : Type} -> A -> A
  64. id x = x
  65. the : (A : Pretype) -> A -> A
  66. the A x = x
  67. -- The eliminator for the interval says that if you have x : A i0 and y : A i1,
  68. -- and x ≡ y, then you can get a proof A i for every element of the interval.
  69. iElim : {A : I -> Type} {x : A i0} {y : A i1} -> PathP A x y -> (i : I) -> A i
  70. iElim p i = p i
  71. -- This corresponds to the elimination principle for the HIT
  72. -- data I : Pretype where
  73. -- i0 i1 : I
  74. -- seg : i0 ≡ i1
  75. -- The singleton subtype of A at x is the type of elements of y which
  76. -- are equal to x.
  77. Singl : (A : Type) -> A -> Type
  78. Singl A x = (y : A) * Path x y
  79. -- Contractible types are those for which there exists an element to which
  80. -- all others are equal.
  81. isContr : Type -> Type
  82. isContr A = (x : A) * ((y : A) -> Path x y)
  83. -- Using the connection \i j -> y.2 (iand i j), we can prove that
  84. -- singletons are contracible. Together with transport later on,
  85. -- we get the J elimination principle of paths.
  86. singContr : {A : Type} {a : A} -> isContr (Singl A a)
  87. singContr {A} {a} = ((a, \i -> a), \y i -> (y.2 i, \j -> y.2 (iand i j)))
  88. -- Some more operations on paths. By rearranging parentheses we get a
  89. -- proof that the images of equal elements are themselves equal.
  90. ap : {A : Type} {B : A -> Type} (f : (x : A) -> B x) {x : A} {y : A} (p : Path x y) -> PathP (\i -> B (p i)) (f x) (f y)
  91. ap f p i = f (p i)
  92. -- These satisfy definitional equalities, like apComp and apId, which are
  93. -- propositional in vanilla MLTT.
  94. apComp : {A : Type} {B : Type} {C : Type}
  95. {f : A -> B} {g : B -> C} {x : A} {y : A}
  96. (p : Path x y)
  97. -> Path (ap g (ap f p)) (ap (\x -> g (f x)) p)
  98. apComp p = refl
  99. apId : {A : Type} {x : A} {y : A}
  100. (p : Path x y)
  101. -> Path (ap (id {A}) p) p
  102. apId p = refl
  103. -- Just like rearranging parentheses gives us ap, swapping the value
  104. -- and interval binders gives us function extensionality.
  105. funext : {A : Type} {B : A -> Type} {f : (x : A) -> B x} {g : (x : A) -> B x}
  106. (h : (x : A) -> Path (f x) (g x))
  107. -> Path f g
  108. funext h i x = h x i
  109. -- The proposition associated with an element of the interval
  110. -------------------------------------------------------------
  111. Eq_s : {A : Pretype} -> A -> A -> Pretype
  112. {-# PRIMITIVE Eq_s #-}
  113. refl_s : {A : Pretype} {x : A} -> Eq_s x x
  114. {-# PRIMITIVE refl_s #-}
  115. J_s : {A : Pretype} {x : A} (P : (y : A) -> Eq_s x y -> Pretype) -> P x (refl_s {A} {x}) -> {y : A} -> (p : Eq_s x y) -> P y p
  116. {-# PRIMITIVE J_s #-}
  117. K_s : {A : Pretype} {x : A} (P : Eq_s x x -> Pretype) -> P (refl_s {A} {x}) -> (p : Eq_s x x) -> P p
  118. {-# PRIMITIVE K_s #-}
  119. -- Associated with every element i : I of the interval, we have the type
  120. -- IsOne i which is inhabited only when i = i1. In the model, this
  121. -- corresponds to the map [φ] from the interval cubical set to the
  122. -- subobject classifier.
  123. IsOne : I -> Pretype
  124. IsOne i = Eq_s i i1
  125. -- The value itIs1 witnesses the fact that i1 = i1.
  126. itIs1 : IsOne i1
  127. itIs1 = refl_s
  128. -- Partial elements
  129. -------------------
  130. --
  131. -- Since a function I -> A has two endpoints, and a function I -> I -> A
  132. -- has four endpoints + four functions I -> A as "sides" (obtained by
  133. -- varying argument while holding the other as a bound variable), we
  134. -- refer to elements of I^n -> A as "cubes".
  135. -- This justifies the existence of partial elements, which are, as the
  136. -- name implies, partial cubes. Namely, a Partial φ A is an element of A
  137. -- which depends on a proof that IsOne φ.
  138. Partial : I -> Type -> Pretype
  139. {-# PRIMITIVE Partial #-}
  140. -- There is also a dependent version where the type A is itself a
  141. -- partial element.
  142. PartialP : (phi : I) -> Partial phi Type -> Pretype
  143. {-# PRIMITIVE PartialP #-}
  144. -- Why is Partial φ A not just defined as φ -> A? The difference is that
  145. -- Partial φ A has an internal representation which definitionally relates
  146. -- any two partial elements which "agree everywhere", that is, have
  147. -- equivalent values for every possible assignment of variables which
  148. -- makes IsOne φ hold.
  149. -- Cubical Subtypes
  150. --------------------
  151. -- Given A : Type, phi : I, and a partial element u : A defined on φ,
  152. -- we have the type Sub A phi u, notated A[phi -> u] in the output of
  153. -- the type checker, whose elements are "extensions" of u.
  154. -- That is, element of A[phi -> u] is an element of A defined everywhere
  155. -- (a total element), which, when IsOne φ, agrees with u.
  156. Sub : (A : Type) (phi : I) -> Partial phi A -> Pretype
  157. {-# PRIMITIVE Sub #-}
  158. -- Every total element u : A can be made partial on φ by ignoring the
  159. -- constraint. Furthermore, this "totally partial" element agrees with
  160. -- the original total element on φ.
  161. inS : {A : Type} {phi : I} (u : A) -> Sub A phi (\x -> u)
  162. {-# PRIMITIVE inS #-}
  163. -- When IsOne φ, outS {A} {φ} {u} x reduces to u itIs1.
  164. -- This implements the fact that x agrees with u on φ.
  165. outS : {A : Type} {phi : I} {u : Partial phi A} -> Sub A phi u -> A
  166. {-# PRIMITIVE outS #-}
  167. -- The composition operation
  168. ----------------------------
  169. -- Now that we have syntax for specifying partial cubes,
  170. -- and specifying that an element agrees with a partial cube,
  171. -- we can describe the composition operation.
  172. primComp : (A : I -> Type) {phi : I} (u : (i : I) -> Partial phi (A i)) -> Sub (A i0) phi (u i0) -> Sub (A i1) phi (u i1)
  173. {-# PRIMITIVE comp primComp #-}
  174. comp : (A : I -> Type) {phi : I} (u : (i : I) -> Partial phi (A i)) -> Sub (A i0) phi (u i0) -> A i1
  175. comp A {phi} u a0 = outS (primComp A {phi} u a0)
  176. -- In particular, when φ is a disjunction of the form
  177. -- (j = 0) || (j = 1), we can draw u as being a pair of lines forming a
  178. -- "tube", an open square with no floor or roof:
  179. --
  180. -- Given u = \j [ (i = i0) -> x, (i = i1) -> q j] on the extent i || ~i,
  181. -- we draw:
  182. --
  183. -- x q i1
  184. -- | |
  185. -- \j -> x | | \j -> q j
  186. -- | |
  187. -- x q i0
  188. --
  189. -- The composition operation says that, as long as we can provide a
  190. -- "floor" connecting x -- q i0, as a total element of A which, on
  191. -- phi, extends u i0, then we get the "roof" connecting x and q i1
  192. -- for free.
  193. --
  194. -- If we have a path p : x ≡ y, and q : y ≡ z, then we do get the
  195. -- "floor", and composition gets us the dotted line:
  196. --
  197. -- x..........z
  198. -- | |
  199. -- x | | q j
  200. -- | |
  201. -- x----------y
  202. -- p i
  203. trans : {A : Type} {x : A} {y : A} {z : A} -> PathP (\i -> A) x y -> PathP (\i -> A) y z -> PathP (\i -> A) x z
  204. trans {A} {x} p q i =
  205. comp (\i -> A)
  206. {ior i (inot i)}
  207. (\j [ (i = i0) -> x, (i = i1) -> q j ])
  208. (inS (p i))
  209. -- In particular when the formula φ = i0 we get the "opposite face" to a
  210. -- single point, which corresponds to transport.
  211. transp : (A : I -> Type) (x : A i0) -> A i1
  212. transp A x = comp A {i0} (\i [ ]) (inS x)
  213. subst : {A : Type} (P : A -> Type) {x : A} {y : A} -> Path x y -> P x -> P y
  214. subst P p x = transp (\i -> P (p i)) x
  215. -- Since we have the iand operator, we can also derive the *filler* of a cube,
  216. -- which connects the given face and the output of composition.
  217. fill : (A : I -> Type) {phi : I} (u : (i : I) -> Partial phi (A i)) (a0 : Sub (A i0) phi (u i0))
  218. -> PathP A (outS a0) (comp A {phi} u a0)
  219. fill A {phi} u a0 i =
  220. comp (\j -> A (iand i j))
  221. {ior phi (inot i)}
  222. (\j [ (phi = i1) -> u (iand i j) itIs1
  223. , (i = i0) -> outS a0
  224. ])
  225. (inS (outS a0))
  226. hcomp : {A : Type} {phi : I} (u : (i : I) -> Partial phi A) -> Sub A phi (u i0) -> A
  227. hcomp {A} {phi} u a0 = comp (\i -> A) {phi} u a0
  228. hfill : {A : Type} {phi : I} (u : (i : I) -> Partial phi A) -> (a0 : Sub A phi (u i0)) -> Path (outS a0) (hcomp u a0)
  229. hfill {A} {phi} u a0 i = fill (\i -> A) {phi} u a0 i
  230. -- For instance, the filler of the previous composition square
  231. -- tells us that trans p refl = p:
  232. transRefl : {A : Type} {x : A} {y : A} (p : Path x y) -> Path (trans p refl) p
  233. transRefl p j i = fill (\i -> A) {ior i (inot i)} (\k [ (i = i0) -> x, (i = i1) -> y ]) (inS (p i)) (inot j)
  234. rightCancel : {A : Type} {x : A} {y : A} (p : Path x y) -> Path (trans p (sym p)) refl
  235. rightCancel p j i = cube p i1 j i where
  236. cube : {A : Type} {x : A} {y : A} (p : Path x y) -> I -> I -> I -> A
  237. cube {A} {x} p k j i =
  238. hfill {A} (\ k [ (i = i0) -> x
  239. , (i = i1) -> p (iand (inot k) (inot j))
  240. , (j = i1) -> x
  241. ])
  242. (inS (p (iand i (inot j)))) k
  243. leftCancel : {A : Type} {x : A} {y : A} (p : Path x y) -> Path (trans (sym p) p) refl
  244. leftCancel p = rightCancel (sym p)
  245. transpFill : {A : I -> Type} (x : A i0) -> PathP A x (transp (\i -> A i) x)
  246. transpFill {A} x i = fill (\i -> A i) (\k []) (inS x) i
  247. -- Reduction of composition
  248. ---------------------------
  249. --
  250. -- Composition reduces on the structure of the family A : I -> Type to create
  251. -- the element a1 : (A i1)[phi -> u i1].
  252. --
  253. -- For instance, when filling a cube of functions, the behaviour is to
  254. -- first transport backwards along the domain, apply the function, then
  255. -- forwards along the codomain.
  256. transpFun : {A : Type} {B : Type} {C : Type} {D : Type} (p : Path A B) (q : Path C D)
  257. -> (f : A -> C) -> Path (transp (\i -> p i -> q i) f)
  258. (\x -> transp (\i -> q i) (f (transp (\i -> p (inot i)) x)))
  259. transpFun p q f = refl
  260. transpDFun : {A : I -> Type} {B : (i : I) -> A i -> Type}
  261. -> (f : (x : A i0) -> B i0 x)
  262. -> Path (transp (\i -> (x : A i) -> B i x) f)
  263. (\x -> transp (\i -> B i (fill (\j -> A (inot j)) (\k []) (inS x) (inot i)))
  264. (f (fill (\j -> A (inot j)) (\k []) (inS x) i1)))
  265. transpDFun f = refl
  266. -- When considering the more general case of a composition respecing sides,
  267. -- the outer transport becomes a composition.
  268. -- Glueing and Univalence
  269. -------------------------
  270. -- First, let's get some definitions out of the way.
  271. --
  272. -- The *fiber* of a function f : A -> B at a point y : B is the type of
  273. -- inputs x : A which f takes to y, that is, for which there exists a
  274. -- path f(x) = y.
  275. fiber : {A : Type} {B : Type} -> (A -> B) -> B -> Type
  276. fiber f y = (x : A) * Path y (f x)
  277. -- An *equivalence* is a function where every fiber is contractible.
  278. -- That is, for every point in the codomain y : B, there is exactly one
  279. -- point in the input which f maps to y.
  280. isEquiv : {A : Type} {B : Type} -> (A -> B) -> Type
  281. isEquiv {A} {B} f = (y : B) -> isContr (fiber {A} {B} f y)
  282. -- By extracting this point, which must exist because the fiber is contractible,
  283. -- we can get an inverse of f:
  284. invert : {A : Type} {B : Type} {f : A -> B} -> isEquiv f -> B -> A
  285. invert eqv y = (eqv y) .1 .1
  286. retract : {A : Type} {B : Type} -> (A -> B) -> (B -> A) -> Type
  287. retract {A} {B} f g = (a : A) -> Path (g (f a)) a
  288. contr : {A : Type} {phi : I} -> isContr A -> (u : Partial phi A) -> A
  289. contr {A} {phi} p u = comp (\i -> A) {phi} (\i is1 -> p.2 (u is1) i) (inS (p.1))
  290. -- Proving that it's also a retraction is left as an exercise to the
  291. -- reader. We can package together a function and a proof that it's an
  292. -- equivalence to get a capital-E Equivalence.
  293. Equiv : (A : Type) (B : Type) -> Type
  294. Equiv A B = (f : A -> B) * isEquiv {A} {B} f
  295. -- The identity function is an equivalence between any type A and
  296. -- itself.
  297. idEquiv : {A : Type} -> isEquiv (id {A})
  298. idEquiv y = ((y, \i -> y), \u i -> (u.2 i, \j -> u.2 (iand i j)))
  299. -- The glue operation expresses that "extensibility is invariant under
  300. -- equivalence". Less concisely, the Glue type and its constructor,
  301. -- glue, let us extend a partial element of a partial type to a total
  302. -- element of a total type, by "gluing" the partial type T using a
  303. -- partial equivalence e onto a total type A.
  304. -- In particular, we have that when φ = i1, Glue A [i1 -> (T, f)] = T.
  305. primGlue : (A : Type) {phi : I}
  306. (T : Partial phi Type)
  307. (e : PartialP phi (\o -> Equiv (T o) A))
  308. -> Type
  309. {-# PRIMITIVE Glue primGlue #-}
  310. -- The glue constructor extends the partial element t : T to a total
  311. -- element of Glue A [φ -> (T, e)] as long as we have a total im : A
  312. -- which is the image of f(t).
  313. --
  314. -- Agreeing with the condition that Glue A [i1 -> (T, e)] = T,
  315. -- we have that glue {A} {i1} t im => t.
  316. prim'glue : {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)}
  317. -> (t : PartialP phi T)
  318. -> (im : Sub A phi (\o -> (e o).1 (t o)))
  319. -> primGlue A T e
  320. {-# PRIMITIVE glue prim'glue #-}
  321. glue : {A : Type} {phi : I} {Te : Partial phi ((T : Type) * Equiv T A)}
  322. -> (t : PartialP phi (\o -> (Te o).1))
  323. -> (im : Sub A phi (\o -> (Te o).2.1 (t o)))
  324. -> primGlue A {phi} (\o -> (Te o).1) (\o -> (Te o).2)
  325. glue {A} {phi} {Te} t im = prim'glue {A} {phi} {\o -> (Te o).1} {\o -> (Te o).2} t im
  326. -- The unglue operation undoes a glueing. Since when φ = i1,
  327. -- Glue A [φ -> (T, f)] = T, the argument to primUnglue {A} {i1} ...
  328. -- will have type T, and so to get back an A we need to apply the
  329. -- partial equivalence f (defined everywhere).
  330. primUnglue : {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)}
  331. -> primGlue A {phi} T e -> A
  332. {-# PRIMITIVE unglue primUnglue #-}
  333. unglue : {A : Type} (phi : I) {Te : Partial phi ((T : Type) * Equiv T A)}
  334. -> primGlue A {phi} (\o -> (Te o).1) (\o -> (Te o).2) -> A
  335. unglue {A} phi {Te} = primUnglue {A} {phi} {\o -> (Te o).1} {\o -> (Te o).2}
  336. -- Diagramatically, i : I |- Glue A [(i \/ ~i) -> (T, e)] can be drawn
  337. -- as giving us the dotted line in:
  338. --
  339. -- T i0 ......... T i1
  340. -- | |
  341. -- | |
  342. -- e i0 |~ ~| e i1
  343. -- | |
  344. -- | |
  345. -- A i0 --------- A i1
  346. -- A
  347. --
  348. -- Where the the two "e" sides are equivalences, and the Bottom side is
  349. -- the line i : I |- A.
  350. --
  351. -- Thus, by choosing a base type, a set of partial types and partial
  352. -- equivalences, we can make a line between two types (T i0) and (T i1).
  353. Glue : (A : Type) {phi : I} -> Partial phi ((X : Type) * Equiv X A) -> Type
  354. Glue A {phi} u = primGlue A {phi} (\o -> (u o).1) (\o -> (u o).2)
  355. -- For example, we can glue together the type A and the type B as long
  356. -- as there exists an Equiv A B.
  357. --
  358. -- A ............ B
  359. -- | |
  360. -- | |
  361. -- equiv |~ ua equiv ~| idEquiv {B}
  362. -- | |
  363. -- | |
  364. -- B ------------ B
  365. -- \i → B
  366. --
  367. univalence : {A : Type} {B : Type} -> Equiv A B -> Path A B
  368. univalence {A} {B} equiv i =
  369. Glue B (\[ (i = i0) -> (A, equiv),
  370. (i = i1) -> (B, the B, idEquiv {B}) ])
  371. lineToEquiv : (A : I -> Type) -> Equiv (A i0) (A i1)
  372. {-# PRIMITIVE lineToEquiv #-}
  373. idToEquiv : {A : Type} {B : Type} -> Path A B -> Equiv A B
  374. idToEquiv p = lineToEquiv (\i -> p i)
  375. isEquivTransport : (A : I -> Type) -> isEquiv (transp A)
  376. isEquivTransport A = (lineToEquiv A).2
  377. -- The fact that this diagram has 2 filled-in B sides explains the
  378. -- complication in the proof below.
  379. --
  380. -- In particular, the actual behaviour of transp (\i -> univalence f i)
  381. -- (x : A) is not just to apply f x to get a B (the left side), it also
  382. -- needs to:
  383. --
  384. -- * For the Bottom side, compose along (\i -> B) (the Bottom side)
  385. -- * For the right side, apply the inverse of the identity, which
  386. -- is just identity, to get *some* b : B
  387. --
  388. -- But that b : B might not agree with the sides of the composition
  389. -- operation in a more general case, so it composes along (\i -> B)
  390. -- *again*!
  391. --
  392. -- Thus the proof: a simple cubical argument suffices, since
  393. -- for any composition, its filler connects either endpoints. So
  394. -- we need to come up with a filler for the Bottom and right faces.
  395. univalenceBeta : {A : Type} {B : Type} (f : Equiv A B) -> Path (transp (\i -> univalence f i)) f.1
  396. univalenceBeta {A} {B} f i a = transpFill {\i -> B} (f.1 a) (inot i)
  397. -- The terms univalence + univalenceBeta suffice to prove the "full"
  398. -- univalence axiom of Voevodsky, as can be seen in the paper
  399. --
  400. -- Ian Orton, & Andrew M. Pitts. (2017). Decomposing the Univalence Axiom.
  401. --
  402. -- Available freely here: https://arxiv.org/abs/1712.04890v3
  403. J : {A : Type} {x : A}
  404. (P : (y : A) -> Path x y -> Type)
  405. (d : P x (\i -> x))
  406. {y : A} (p : Path x y)
  407. -> P y p
  408. J P d p = transp (\i -> P (p i) (\j -> p (iand i j))) d
  409. JRefl : {A : Type} {x : A}
  410. (P : (y : A) -> Path x y -> Type)
  411. (d : P x (\i -> x))
  412. -> Path (J {A} {x} P d {x} (\i -> x)) d
  413. JRefl P d i = transpFill {\i -> P x (\j -> x)} d (inot i)
  414. Jay : {A : Type} {x : A}
  415. (P : ((y : A) * Path x y) -> Type)
  416. (d : P (x, refl))
  417. (s : (y : A) * Path x y)
  418. -> P s
  419. Jay P d s = transp (\i -> P ((singContr {A} {x}).2 s i)) d
  420. -- Isomorphisms
  421. ---------------
  422. --
  423. -- Since isomorphisms are a much more convenient notion of equivalence
  424. -- than contractible fibers, it's natural to ask why the CCHM paper, and
  425. -- this implementation following that, decided on the latter for our
  426. -- definition of equivalence.
  427. isIso : {A : Type} -> {B : Type} -> (A -> B) -> Type
  428. isIso {A} {B} f = (g : B -> A) * ((y : B) -> Path (f (g y)) y) * ((x : A) -> Path (g (f x)) x)
  429. -- The reason is that the family of types IsIso is not a proposition!
  430. -- This means that there can be more than one way for a function to be
  431. -- an equivalence. This is Lemma 4.1.1 of the HoTT book.
  432. Iso : Type -> Type -> Type
  433. Iso A B = (f : A -> B) * isIso f
  434. -- Nevertheless, we can prove that any function with an isomorphism
  435. -- structure has contractible fibers, using a cubical argument adapted
  436. -- from CCHM's implementation of cubical type theory:
  437. --
  438. -- https://github.com/mortberg/cubicaltt/blob/master/experiments/isoToEquiv.ctt#L7-L55
  439. IsoToEquiv : {A : Type} {B : Type} -> Iso A B -> Equiv A B
  440. IsoToEquiv {A} {B} iso = (f, \y -> (fCenter y, fIsCenter y)) where
  441. f = iso.1
  442. g = iso.2.1
  443. s = iso.2.2.1
  444. t = iso.2.2.2
  445. lemIso : (y : B) (x0 : A) (x1 : A) (p0 : Path y (f x0)) (p1 : Path y (f x1))
  446. -> PathP (\i -> fiber f y) (x0, p0) (x1, p1)
  447. lemIso y x0 x1 p0 p1 =
  448. let
  449. rem0 : Path x0 (g y)
  450. rem0 i = comp (\i -> A) (\k [ (i = i0) -> t x0 k, (i = i1) -> g y ]) (inS (g (p0 (inot i))))
  451. rem1 : Path x1 (g y)
  452. rem1 i = comp (\i -> A) (\k [ (i = i0) -> t x1 k, (i = i1) -> g y ]) (inS (g (p1 (inot i))))
  453. p : Path x0 x1
  454. p i = comp (\i -> A) (\k [ (i = i0) -> rem0 (inot k), (i = i1) -> rem1 (inot k) ]) (inS (g y))
  455. fill0 : I -> I -> A
  456. fill0 i j = comp (\i -> A) (\k [ (i = i0) -> t x0 (iand j k)
  457. , (i = i1) -> g y
  458. , (j = i0) -> g (p0 (inot i))
  459. ])
  460. (inS (g (p0 (inot i))))
  461. fill1 : I -> I -> A
  462. fill1 i j = comp (\i -> A) (\k [ (i = i0) -> t x1 (iand j k)
  463. , (i = i1) -> g y
  464. , (j = i0) -> g (p1 (inot i)) ])
  465. (inS (g (p1 (inot i))))
  466. fill2 : I -> I -> A
  467. fill2 i j = comp (\i -> A) (\k [ (i = i0) -> rem0 (ior j (inot k))
  468. , (i = i1) -> rem1 (ior j (inot k))
  469. , (j = i1) -> g y ])
  470. (inS (g y))
  471. sq : I -> I -> A
  472. sq i j = comp (\i -> A) (\k [ (i = i0) -> fill0 j (inot k)
  473. , (i = i1) -> fill1 j (inot k)
  474. , (j = i1) -> g y
  475. , (j = i0) -> t (p i) (inot k) ])
  476. (inS (fill2 i j))
  477. sq1 : I -> I -> B
  478. sq1 i j = comp (\i -> B) (\k [ (i = i0) -> s (p0 (inot j)) k
  479. , (i = i1) -> s (p1 (inot j)) k
  480. , (j = i0) -> s (f (p i)) k
  481. , (j = i1) -> s y k
  482. ])
  483. (inS (f (sq i j)))
  484. in \i -> (p i, \j -> sq1 i (inot j))
  485. fCenter : (y : B) -> fiber f y
  486. fCenter y = (g y, sym (s y))
  487. fIsCenter : (y : B) (w : fiber f y) -> Path (fCenter y) w
  488. fIsCenter y w = lemIso y (fCenter y).1 w.1 (fCenter y).2 w.2
  489. IsoToId : {A : Type} {B : Type} -> Iso A B -> Path A B
  490. IsoToId i = univalence (IsoToEquiv i)
  491. -- We can prove that any involutive function is an isomorphism, since
  492. -- such a function is its own inverse.
  493. involToIso : {A : Type} (f : A -> A) -> ((x : A) -> Path (f (f x)) x) -> isIso f
  494. involToIso {A} f inv = (f, inv, inv)
  495. -- An example of univalence
  496. ---------------------------
  497. --
  498. -- The classic example of univalence is the equivalence
  499. -- not : Bool \simeq Bool.
  500. --
  501. -- We define it here.
  502. data Bool : Type where
  503. true : Bool
  504. false : Bool
  505. not : Bool -> Bool
  506. not = \case
  507. true -> false
  508. false -> true
  509. elimBool : (P : Bool -> Type) -> P true -> P false -> (b : Bool) -> P b
  510. elimBool P x y = \case
  511. true -> x
  512. false -> y
  513. if : {A : Type} -> A -> A -> Bool -> A
  514. if x y = \case
  515. true -> x
  516. false -> y
  517. -- By pattern matching it suffices to prove (not (not true)) ≡ true and
  518. -- not (not false) ≡ false. Since not (not true) computes to true (resp.
  519. -- false), both proofs go through by refl.
  520. notInvol : (x : Bool) -> Path (not (not x)) x
  521. notInvol = elimBool (\b -> Path (not (not b)) b) refl refl
  522. notp : Path Bool Bool
  523. notp = univalence (IsoToEquiv (not, involToIso not notInvol))
  524. -- This path actually serves to prove a simple lemma about the universes
  525. -- of HoTT, namely, that any univalent universe is not a 0-type. If we
  526. -- had HITs, we could prove that this fact holds for any n, but for now,
  527. -- proving it's not an h-set is the furthest we can go.
  528. -- First we define what it means for something to be false. In type theory,
  529. -- we take ¬P = P → ⊥, where the Bottom type is the only type satisfying
  530. -- the elimination principle
  531. --
  532. -- elimBottom : (P : Bottom -> Type) -> (b : Bottom) -> P b
  533. --
  534. -- This follows from setting Bottom := ∀ A, A.
  535. data Bottom : Type where {}
  536. elimBottom : (P : Bottom -> Pretype) -> (b : Bottom) -> P b
  537. elimBottom P = \case {}
  538. absurd : {P : Pretype} -> Bottom -> P
  539. absurd = \case {}
  540. -- We prove that true != false by transporting along the path
  541. --
  542. -- \i -> if (Bool -> Bool) A (p i)
  543. -- (Bool -> Bool) ------------------------------------ A
  544. --
  545. -- To verify that this has the correct endpoints, check out the endpoints
  546. -- for p:
  547. --
  548. -- true ------------------------------------ false
  549. --
  550. -- and evaluate the if at either end.
  551. trueNotFalse : Path true false -> Bottom
  552. trueNotFalse p = transp (\i -> if (Bool -> Bool) Bottom (p i)) id
  553. -- To be an h-Set is to have no "higher path information". Alternatively,
  554. --
  555. -- isHSet A = (x : A) (y : A) -> isHProp (Path x y)
  556. --
  557. isProp : Type -> Type
  558. isProp A = (x : A) (y : A) -> Path x y
  559. isHSet : Type -> Type
  560. isHSet A = (x : A) (y : A) -> isProp (Path x y)
  561. -- We can prove *a* contradiction (note: this is a direct proof!) by adversarially
  562. -- choosing two paths p, q that we know are not equal. Since "equal" paths have
  563. -- equal behaviour when transporting, we can choose two paths p, q and a point x
  564. -- such that transporting x along p gives a different result from x along q.
  565. --
  566. -- Since transp notp = not but transp refl = id, that's what we go with. The choice
  567. -- of false as the point x is just from the endpoints of trueNotFalse.
  568. universeNotSet : isHSet Type -> Bottom
  569. universeNotSet itIs = trueNotFalse (\i -> transp (\j -> itIs Bool Bool notp refl i j) false)
  570. -- Funext is an inverse of happly
  571. ---------------------------------
  572. --
  573. -- Above we proved function extensionality, namely, that functions
  574. -- pointwise equal everywhere are themselves equal.
  575. -- However, this formulation of the axiom is known as "weak" function
  576. -- extensionality. The strong version is as follows:
  577. Hom : {A : Type} {B : A -> Type} (f : (x : A) -> B x) -> (g : (x : A) -> B x) -> Type
  578. Hom {A} f g = (x : A) -> Path (f x) (g x)
  579. happly : {A : Type} {B : A -> Type} {f : (x : A) -> B x} {g : (x : A) -> B x}
  580. -> (p : Path f g) -> Hom f g
  581. happly p x i = p i x
  582. -- Strong function extensionality: happly is an equivalence.
  583. happlyIsIso : {A : Type} {B : A -> Type} {f : (x : A) -> B x} {g : (x : A) -> B x}
  584. -> isIso {Path f g} {Hom f g} happly
  585. happlyIsIso {A} {B} {f} {g} = (funext {A} {B} {f} {g}, \hom -> refl, \path -> refl)
  586. pathIsHom : {A : Type} {B : A -> Type} {f : (x : A) -> B x} {g : (x : A) -> B x}
  587. -> Path (Path f g) (Hom f g)
  588. pathIsHom {A} {B} {f} {g} =
  589. let
  590. theIso : Iso (Path f g) (Hom f g)
  591. theIso = (happly {A} {B} {f} {g}, happlyIsIso {A} {B} {f} {g})
  592. in univalence (IsoToEquiv theIso)
  593. -- Inductive types
  594. -------------------
  595. --
  596. -- An inductive type is a type freely generated by a finite set of
  597. -- constructors. For instance, the type of natural numbers is generated
  598. -- by the constructors for "zero" and "successor".
  599. data Nat : Type where
  600. zero : Nat
  601. succ : Nat -> Nat
  602. -- Pattern matching allows us to prove that these initial types are
  603. -- initial algebras for their corresponding functors.
  604. Nat_elim : (P : Nat -> Type) -> P zero -> ((x : Nat) -> P x -> P (succ x)) -> (x : Nat) -> P x
  605. Nat_elim P pz ps = \case
  606. zero -> pz
  607. succ x -> ps x (Nat_elim P pz ps x)
  608. zeroNotSucc : {x : Nat} -> Path zero (succ x) -> Bottom
  609. zeroNotSucc p = transp (\i -> fun (p i)) (p i0) where
  610. fun : Nat -> Type
  611. fun = \case
  612. zero -> Nat
  613. succ x -> Bottom
  614. succInj : {x : Nat} {y : Nat} -> Path (succ x) (succ y) -> Path x y
  615. succInj p i = pred (p i) where
  616. pred : Nat -> Nat
  617. pred = \case
  618. zero -> zero
  619. succ x -> x
  620. -- The type of integers can be defined as A + B, where "pos n" means +n
  621. -- and "neg n" means -(n + 1).
  622. data Int : Type where
  623. pos : Nat -> Int
  624. neg : Nat -> Int
  625. -- On this representation we can define the successor and predecessor
  626. -- functions by (nested) induction.
  627. sucZ : Int -> Int
  628. sucZ = \case
  629. pos n -> pos (succ n)
  630. neg n ->
  631. let suc_neg : Nat -> Int
  632. suc_neg = \case
  633. zero -> pos zero
  634. succ n -> neg n
  635. in suc_neg n
  636. predZ : Int -> Int
  637. predZ = \case
  638. pos n ->
  639. let pred_pos : Nat -> Int
  640. pred_pos = \case
  641. zero -> neg zero
  642. succ n -> pos n
  643. in pred_pos n
  644. neg n -> neg (succ n)
  645. -- And prove that the successor function is an isomorphism, and thus, an
  646. -- equivalence.
  647. sucPredZ : (x : Int) -> Path (sucZ (predZ x)) x
  648. sucPredZ = \case
  649. pos n ->
  650. let k : (n : Nat) -> Path (sucZ (predZ (pos n))) (pos n)
  651. k = \case
  652. zero -> refl
  653. succ n -> refl
  654. in k n
  655. neg n -> refl
  656. predSucZ : (x : Int) -> Path (predZ (sucZ x)) x
  657. predSucZ = \case
  658. pos n -> refl
  659. neg n ->
  660. let k : (n : Nat) -> Path (predZ (sucZ (neg n))) (neg n)
  661. k = \case
  662. zero -> refl
  663. succ n -> refl
  664. in k n
  665. sucEquiv : Equiv Int Int
  666. sucEquiv = IsoToEquiv (sucZ, (predZ, sucPredZ, predSucZ))
  667. -- Univalence gives us a path between integers such that transp intPath
  668. -- x = suc x, transp (sym intPath) x = pred x
  669. intPath : Path Int Int
  670. intPath = univalence sucEquiv
  671. -- Higher inductive types
  672. -------------------------
  673. --
  674. -- While inductive types let us generate discrete spaces like the
  675. -- naturals or integers, they do not support defining higher-dimensional
  676. -- structures given by spaces with points and paths.
  677. -- A very simple higher inductive type is the interval, given by
  678. data Interval : Type where
  679. ii0 : Interval
  680. ii1 : Interval
  681. seg i : Interval [ (i = i0) -> ii0, (i = i1) -> ii1 ]
  682. -- This expresses that we have two points ii0 and ii1 and a path (\i ->
  683. -- seg i) with endpoints ii0 and ii1.
  684. -- With this type we can reproduce the proof of Lemma 6.3.2 from the
  685. -- HoTT book:
  686. iFunext : {A : Type} {B : A -> Type} (f : (x : A) -> B x) (g : (x : A) -> B x)
  687. -> ((x : A) -> Path (f x) (g x)) -> Path f g
  688. iFunext f g p i = h' (seg i) where
  689. h : (x : A) -> Interval -> B x
  690. h x = \case
  691. ii0 -> f x
  692. ii1 -> g x
  693. seg i -> p x i
  694. h' : Interval -> (x : A) -> B x
  695. h' i x = h x i
  696. -- Of course, Cubical Type Theory also has an interval (pre)type, but
  697. -- that, unlike the Interval here, is not Kan: it has no composition
  698. -- structure.
  699. -- Another simple higher-inductive type is the circle, with a point and
  700. -- a non-trivial loop, (\i -> loop i).
  701. data S1 : Type where
  702. base : S1
  703. loop i : S1 [ (i = i1) -> base, (i = i0) -> base ]
  704. -- By writing a function from the circle to the universe of types Type,
  705. -- we can calculate winding numbers along the circle.
  706. helix : S1 -> Type
  707. helix = \case
  708. base -> Int
  709. loop i -> intPath i
  710. loopP : Path base base
  711. loopP i = loop i
  712. winding : Path base base -> Int
  713. winding p = transp (\i -> helix (p i)) (pos zero)
  714. -- For instance, going around the loop once has a winding number of +1,
  715. windingLoop : Path (winding (\i -> loop i)) (pos (succ zero))
  716. windingLoop = refl
  717. -- Going backwards has a winding number of -1 (remember the
  718. -- representation of integers),
  719. windingSymLoop : Path (winding (\i -> loop (inot i))) (neg zero)
  720. windingSymLoop = refl
  721. -- And going around the trivial loop (\i -> base) goes around the the
  722. -- non-trivial loop (\i -> loop) zero times.
  723. windingBase : Path (winding (\i -> base)) (pos zero)
  724. windingBase = refl
  725. goAround : Int -> Path base base
  726. goAround =
  727. \case
  728. pos n -> forwards n
  729. neg n -> backwards n
  730. where
  731. forwards : Nat -> Path base base
  732. forwards = \case
  733. zero -> refl
  734. succ n -> trans (goAround (pos n)) (\i -> loop i)
  735. backwards : Nat -> Path base base
  736. backwards = \case
  737. zero -> \i -> loop (inot i)
  738. succ n -> trans (goAround (neg n)) (\i -> loop (inot i))
  739. windingGoAround : (n : Int) -> Path (winding (goAround n)) n
  740. windingGoAround =
  741. \case
  742. pos n -> posCase n
  743. neg n -> negCase n
  744. where
  745. posCase : (n : Nat) -> Path (winding (goAround (pos n))) (pos n)
  746. posCase = \case
  747. zero -> refl
  748. succ n -> ap sucZ (posCase n)
  749. negCase : (n : Nat) -> Path (winding (goAround (neg n))) (neg n)
  750. negCase = \case
  751. zero -> refl
  752. succ n -> ap predZ (negCase n)
  753. decodeSquare : (n : Int) -> PathP (\i -> Path base (loop i)) (goAround (predZ n)) (goAround n)
  754. decodeSquare = \case
  755. pos n -> posCase n
  756. neg n -> \i j -> hfill (\k [ (j = i1) -> loop (inot k), (j = i0) -> base ]) (inS (goAround (neg n) j)) (inot i)
  757. where
  758. posCase : (n : Nat) -> PathP (\i -> Path base (loop i)) (goAround (predZ (pos n))) (goAround (pos n))
  759. posCase = \case
  760. zero -> \i j -> loop (ior i (inot j))
  761. succ n -> \i j -> hfill (\k [ (j = i1) -> loop k, (j = i0) -> base ]) (inS (goAround (pos n) j)) i
  762. -- One particularly general higher inductive type is the homotopy pushout,
  763. -- which can be seen as a kind of sum B + C with the extra condition that
  764. -- whenever x and y are in the image of f (resp. g), inl x ≡ inr y.
  765. data Pushout {A : Type} {B : Type} {C : Type} (f : A -> B) (g : A -> C) : Type where
  766. inl : (x : B) -> Pushout f g
  767. inr : (y : C) -> Pushout f g
  768. push i : (a : A) -> Pushout f g [ (i = i0) -> inl (f a), (i = i1) -> inr (g a) ]
  769. -- The name is due to the category-theoretical notion of pushout.
  770. -- TODO: finish writing this tomorrow lol
  771. data Susp (A : Type) : Type where
  772. north : Susp A
  773. south : Susp A
  774. merid i : A -> Susp A [ (i = i0) -> north, (i = i1) -> south ]
  775. data Unit : Type where
  776. tt : Unit
  777. unitEta : (x : Unit) -> Path x tt
  778. unitEta = \case tt -> refl
  779. unitContr : isContr Unit
  780. unitContr = (tt, \x -> sym (unitEta x))
  781. poSusp : Type -> Type
  782. poSusp A = Pushout {A} {Unit} {Unit} (\x -> tt) (\x -> tt)
  783. Susp_is_poSusp : {A : Type} -> Path (Susp A) (poSusp A)
  784. Susp_is_poSusp {A} = univalence (IsoToEquiv (Susp_to_poSusp {A}, poSusp_to_Susp {A}, poSusp_to_Susp_to_poSusp {A}, Susp_to_poSusp_to_Susp {A})) where
  785. poSusp_to_Susp : {A : Type} -> poSusp A -> Susp A
  786. poSusp_to_Susp = \case
  787. inl x -> north
  788. inr x -> south
  789. push x i -> merid x i
  790. Susp_to_poSusp : {A : Type} -> Susp A -> poSusp A
  791. Susp_to_poSusp = \case
  792. north -> inl tt
  793. south -> inr tt
  794. merid x i -> push x i
  795. Susp_to_poSusp_to_Susp : {A : Type} -> (x : Susp A) -> Path (poSusp_to_Susp (Susp_to_poSusp x)) x
  796. Susp_to_poSusp_to_Susp = \case
  797. north -> refl
  798. south -> refl
  799. merid x i -> refl
  800. poSusp_to_Susp_to_poSusp : {A : Type} -> (x : poSusp A) -> Path (Susp_to_poSusp (poSusp_to_Susp x)) x
  801. poSusp_to_Susp_to_poSusp {A} = \case
  802. inl x -> ap inl (sym (unitEta x))
  803. inr x -> ap inr (sym (unitEta x))
  804. push x i -> refl
  805. data T2 : Type where
  806. baseT : T2
  807. pathOne i : T2 [ (i = i0) -> baseT, (i = i1) -> baseT ]
  808. pathTwo i : T2 [ (i = i0) -> baseT, (i = i1) -> baseT ]
  809. square i j : T2 [
  810. (j = i0) -> pathTwo i,
  811. (j = i1) -> pathTwo i,
  812. (i = i0) -> pathOne j,
  813. (i = i1) -> pathOne j
  814. ]
  815. TorusIsTwoCircles : Path T2 (S1 * S1)
  816. TorusIsTwoCircles = univalence (IsoToEquiv theIso) where
  817. torusToCircs : T2 -> S1 * S1
  818. torusToCircs = \case
  819. baseT -> (base, base)
  820. pathOne i -> (loop i, base)
  821. pathTwo i -> (base, loop i)
  822. square i j -> (loop i, loop j)
  823. circsToTorus : (S1 * S1) -> T2
  824. circsToTorus pair = go pair.1 pair.2
  825. where
  826. baseCase : S1 -> T2
  827. baseCase = \case
  828. base -> baseT
  829. loop j -> pathTwo j
  830. loopCase : Path baseCase baseCase
  831. loopCase i = \case
  832. base -> pathOne i
  833. loop j -> square i j
  834. go : S1 -> S1 -> T2
  835. go = \case
  836. base -> baseCase
  837. loop i -> loopCase i
  838. torusToCircsToTorus : (x : T2) -> Path (circsToTorus (torusToCircs x)) x
  839. torusToCircsToTorus = \case
  840. baseT -> refl
  841. pathOne i -> refl
  842. pathTwo i -> refl
  843. square i j -> refl
  844. circsToTorusToCircs : (p : S1 * S1) -> Path (torusToCircs (circsToTorus p)) p
  845. circsToTorusToCircs pair = go pair.1 pair.2 where
  846. baseCase : (y : S1) -> Path (torusToCircs (circsToTorus (base, y))) (base, y)
  847. baseCase = \case
  848. base -> refl
  849. loop j -> refl
  850. loopCase : (i : I) (y : S1) -> Path (torusToCircs (circsToTorus (loop i, y))) (loop i, y )
  851. loopCase i = \case
  852. base -> refl
  853. loop j -> refl
  854. go : (x : S1) (y : S1) -> Path (torusToCircs (circsToTorus (x, y))) (x, y)
  855. go = \case
  856. base -> baseCase
  857. loop i -> loopCase i
  858. theIso : Iso T2 (S1 * S1)
  859. theIso = (torusToCircs, circsToTorus, circsToTorusToCircs, torusToCircsToTorus)
  860. abs : Int -> Nat
  861. abs = \case
  862. pos n -> n
  863. neg n -> succ n
  864. sign : Int -> Bool
  865. sign = \case
  866. pos n -> true
  867. neg n -> false
  868. boolAnd : Bool -> Bool -> Bool
  869. boolAnd = \case
  870. true -> \case
  871. true -> true
  872. false -> false
  873. false -> \case
  874. true -> false
  875. false -> false
  876. plusNat : Nat -> Nat -> Nat
  877. plusNat = \case
  878. zero -> \x -> x
  879. succ n -> \x -> succ (plusNat n x)
  880. plusZero : (x : Nat) -> Path (plusNat zero x) x
  881. plusZero = \case
  882. zero -> refl
  883. succ n -> \i -> succ (plusZero n i)
  884. multNat : Nat -> Nat -> Nat
  885. multNat = \case
  886. zero -> \x -> zero
  887. succ n -> \x -> plusNat x (multNat n x)
  888. multInt : Int -> Int -> Int
  889. multInt x y = signify (multNat (abs x) (abs y)) (boolAnd (sign x) (sign y)) where
  890. signify : Nat -> Bool -> Int
  891. signify = \case
  892. zero -> \x -> pos zero
  893. succ n -> \case
  894. true -> pos (succ n)
  895. false -> neg n
  896. two : Int
  897. two = pos (succ (succ zero))
  898. four : Int
  899. four = multInt two two
  900. sixteen : Int
  901. sixteen = multInt four four
  902. Prop : Type
  903. Prop = (A : Type) * isProp A
  904. data Sq (A : Type) : Type where
  905. inc : A -> Sq A
  906. sq i : (x : Sq A) (y : Sq A) -> Sq A [ (i = i0) -> x, (i = i1) -> y ]
  907. isProp_isSet : {A : Type} -> isProp A -> isHSet A
  908. isProp_isSet h a b p q j i =
  909. hcomp {A}
  910. (\k [ (i = i0) -> h a a k
  911. , (i = i1) -> h a b k
  912. , (j = i0) -> h a (p i) k
  913. , (j = i1) -> h a (q i) k
  914. ])
  915. (inS a)
  916. isProp_isProp : {A : Type} -> isProp (isProp A)
  917. isProp_isProp f g i a b = isProp_isSet f a b (f a b) (g a b) i
  918. isProp_isContr : {A : Type} -> isProp (isContr A)
  919. isProp_isContr {A} z0 z1 j =
  920. ( z0.2 z1.1 j
  921. , \x i -> hcomp {A} (\k [ (i = i0) -> z0.2 z1.1 j
  922. , (i = i1) -> z0.2 x (ior j k)
  923. , (j = i0) -> z0.2 x (iand i k)
  924. , (j = i1) -> z1.2 x i ])
  925. (inS (z0.2 (z1.2 x i) j))
  926. )
  927. isContr_isProp : {A : Type} -> isContr A -> isProp A
  928. isContr_isProp x a b i = hcomp (\k [ (i = i0) -> x.2 a k, (i = i1) -> x.2 b k ]) (inS x.1)
  929. sigmaPath : {A : Type} {B : A -> Type} {s1 : (x : A) * B x} {s2 : (x : A) * B x}
  930. -> (p : Path s1.1 s2.1)
  931. -> PathP (\i -> B (p i)) s1.2 s2.2
  932. -> Path s1 s2
  933. sigmaPath p q i = (p i, q i)
  934. propExt : {A : Type} {B : Type}
  935. -> isProp A -> isProp B
  936. -> (A -> B)
  937. -> (B -> A)
  938. -> Equiv A B
  939. propExt {A} {B} propA propB f g = (f, contract) where
  940. contract : (y : B) -> isContr (fiber f y)
  941. contract y =
  942. let arg : A
  943. arg = g y
  944. in ( (arg, propB y (f arg))
  945. , \fib -> sigmaPath (propA _ _) (isProp_isSet {B} propB y (f fib.1) _ _))
  946. Sq_rec : {A : Type} {B : Type}
  947. -> isProp B
  948. -> (f : A -> B)
  949. -> Sq A -> B
  950. Sq_rec prop f =
  951. \case
  952. inc x -> f x
  953. sq x y i -> prop (work x) (work y) i
  954. where
  955. work : Sq A -> B
  956. work = \case
  957. inc x -> f x
  958. hitTranspExample : Path (inc false) (inc true)
  959. hitTranspExample i = transp (\i -> Sq (notp i)) (sq (inc true) (inc false) i)
  960. data S2 : Type where
  961. base2 : S2
  962. surf2 i j : S2 [ (i = i0) -> base2, (i = i1) -> base2, (j = i0) -> base2, (j = i1) -> base2]
  963. S2IsSuspS1 : Path S2 (Susp S1)
  964. S2IsSuspS1 = univalence (IsoToEquiv iso) where
  965. toS2 : Susp S1 -> S2
  966. toS2 = \case { north -> base2; south -> base2; merid x i -> sphMerid x i } where
  967. sphMerid = \case
  968. base -> \i -> base2
  969. loop j -> \i -> surf2 i j
  970. suspSurf : I -> I -> I -> Susp S1
  971. suspSurf i j = hfill {Susp S1} (\k [ (i = i0) -> north
  972. , (i = i1) -> merid base (inot k)
  973. , (j = i0) -> merid base (iand (inot k) i)
  974. , (j = i1) -> merid {S1} base (iand (inot k) i)
  975. ])
  976. (inS (merid (loop j) i))
  977. fromS2 : S2 -> Susp S1
  978. fromS2 = \case { base2 -> north; surf2 i j -> suspSurf i j i1 }
  979. toFromS2 : (x : S2) -> Path (toS2 (fromS2 x)) x
  980. toFromS2 = \case { base2 -> refl; surf2 i j -> \k -> toS2 (suspSurf i j (inot k)) }
  981. fromToS2 : (x : Susp S1) -> Path (fromS2 (toS2 x)) x
  982. fromToS2 = \case { north -> refl; south -> \i -> merid base i; merid x i -> meridCase i x } where
  983. meridCase : (i : I) (x : S1) -> Path (fromS2 (toS2 (merid x i))) (merid x i)
  984. meridCase i = \case
  985. base -> \k -> merid base (iand i k)
  986. loop j -> \k -> suspSurf i j (inot k)
  987. iso : Iso S2 (Susp S1)
  988. iso = (fromS2, toS2, fromToS2, toFromS2)
  989. data S3 : Type where
  990. base3 : S3
  991. surf3 i j k : S3 [ (i = i0) -> base3, (i = i1) -> base3, (j = i0) -> base3, (j = i1) -> base3, (k = i0) -> base3, (k = i1) -> base3 ]
  992. S3IsSuspS2 : Path S3 (Susp S2)
  993. S3IsSuspS2 = univalence (IsoToEquiv iso) where
  994. toS3 : Susp S2 -> S3
  995. toS3 = \case { north -> base3; south -> base3; merid x i -> sphMerid x i } where
  996. sphMerid = \case
  997. base2 -> \i -> base3
  998. surf2 j k -> \i -> surf3 i j k
  999. suspSurf : I -> I -> I -> I -> Susp S2
  1000. suspSurf i j k = hfill {Susp S2} (\l [ (i = i0) -> north
  1001. , (i = i1) -> merid base2 (inot l)
  1002. , (j = i0) -> merid base2 (iand (inot l) i)
  1003. , (j = i1) -> merid {S2} base2 (iand (inot l) i)
  1004. , (k = i0) -> merid base2 (iand (inot l) i)
  1005. , (k = i1) -> merid {S2} base2 (iand (inot l) i)
  1006. ])
  1007. (inS (merid (surf2 j k) i))
  1008. fromS3 : S3 -> Susp S2
  1009. fromS3 = \case { base3 -> north; surf3 i j k -> suspSurf i j k i1 }
  1010. toFromS3 : (x : S3) -> Path (toS3 (fromS3 x)) x
  1011. toFromS3 = \case { base3 -> refl; surf3 i j k -> \l -> toS3 (suspSurf i j k (inot l)) }
  1012. fromToS3 : (x : Susp S2) -> Path (fromS3 (toS3 x)) x
  1013. fromToS3 = \case { north -> refl; south -> \i -> merid base2 i; merid x i -> meridCase i x } where
  1014. meridCase : (i : I) (x : S2) -> Path (fromS3 (toS3 (merid x i))) (merid x i)
  1015. meridCase i = \case
  1016. base2 -> \k -> merid base2 (iand i k)
  1017. surf2 j k -> \l -> suspSurf i j k (inot l)
  1018. iso : Iso S3 (Susp S2)
  1019. iso = (fromS3, toS3, fromToS3, toFromS3)
  1020. ap_s : {A : Pretype} {B : Pretype} (f : A -> B) {x : A} {y : A} -> Eq_s x y -> Eq_s (f x) (f y)
  1021. ap_s {A} {B} f {x} {y} = J_s (\y p -> Eq_s (f x) (f y)) refl_s
  1022. subst_s : {A : Pretype} (P : A -> Pretype) {x : A} {y : A} -> Eq_s x y -> P x -> P y
  1023. subst_s {A} P {x} {z} p px = J_s {A} {x} (\y p -> P x -> P y) id p px
  1024. sym_s : {A : Pretype} {x : A} {y : A} -> Eq_s x y -> Eq_s y x
  1025. sym_s {A} {x} {y} = J_s {A} {x} (\y p -> Eq_s y x) refl_s
  1026. UIP : {A : Pretype} {x : A} {y : A} (p : Eq_s x y) (q : Eq_s x y) -> Eq_s p q
  1027. UIP {A} {x} {y} p q = J_s (\y p -> (q : Eq_s x y) -> Eq_s p q) (uipRefl A x) p q where
  1028. uipRefl : (A : Pretype) (x : A) (p : Eq_s x x) -> Eq_s refl_s p
  1029. uipRefl A x p = K_s {A} {x} (\q -> Eq_s refl_s q) refl_s p
  1030. strictEq_pathEq : {A : Type} {x : A} {y : A} -> Eq_s x y -> Path x y
  1031. strictEq_pathEq {A} {x} {y} eq = J_s {A} {x} (\y p -> Path x y) (\i -> x) {y} eq
  1032. seq_pathRefl : {A : Type} {x : A} (p : Eq_s x x) -> Eq_s (strictEq_pathEq p) (refl {A} {x})
  1033. seq_pathRefl {A} {x} p = K_s (\p -> Eq_s (strictEq_pathEq {A} {x} {x} p) (refl {A} {x})) refl_s p
  1034. Path_nat_strict_nat : (x : Nat) (y : Nat) -> Path x y -> Eq_s x y
  1035. Path_nat_strict_nat = \case { zero -> zeroCase; succ x -> succCase x } where
  1036. zeroCase : (y : Nat) -> Path zero y -> Eq_s zero y
  1037. zeroCase = \case
  1038. zero -> \p -> refl_s
  1039. succ x -> \p -> absurd (zeroNotSucc p)
  1040. succCase : (x : Nat) (y : Nat) -> Path (succ x) y -> Eq_s (succ x) y
  1041. succCase x = \case
  1042. zero -> \p -> absurd (zeroNotSucc (sym p))
  1043. succ y -> \p -> ap_s succ (Path_nat_strict_nat x y (succInj p))
  1044. pathToEqS_K : {A : Type} {x : A}
  1045. -> (s : {x : A} {y : A} -> Path x y -> Eq_s x y)
  1046. -> (P : Path x x -> Type) -> P refl -> (p : Path x x) -> P p
  1047. pathToEqS_K {A} {x} p_to_s P pr loop = transp (\i -> P (inv x loop i)) psloop where
  1048. psloop : P (strictEq_pathEq (p_to_s loop))
  1049. psloop = K_s (\l -> P (strictEq_pathEq {A} {x} {x} l)) pr (p_to_s {x} {x} loop)
  1050. inv : (y : A) (l : Path x y) -> Path (strictEq_pathEq (p_to_s l)) l
  1051. inv y l = J {A} {x} (\y l -> Path (strictEq_pathEq (p_to_s l)) l) (strictEq_pathEq aux) {y} l where
  1052. aux : Eq_s (strictEq_pathEq (p_to_s (\i -> x))) (\i -> x)
  1053. aux = seq_pathRefl (p_to_s (\i -> x))
  1054. pathToEq_isSet : {A : Type} -> ({x : A} {y : A} -> Path x y -> Eq_s x y) -> isHSet A
  1055. pathToEq_isSet {A} p_to_s = axK_to_isSet {A} (\{x} -> pathToEqS_K {A} {x} p_to_s) where
  1056. axK_to_isSet : {A : Type} -> ({x : A} -> (P : Path x x -> Type) -> P refl -> (p : Path x x) -> P p) -> isHSet A
  1057. axK_to_isSet K x y p q = J (\y p -> (q : Path x y) -> Path p q) (uipRefl x) p q where
  1058. uipRefl : (x : A) (p : Path x x) -> Path refl p
  1059. uipRefl x p = K {x} (\q -> Path refl q) refl p
  1060. Nat_isSet : isHSet Nat
  1061. Nat_isSet = pathToEq_isSet {Nat} (\{x} {y} -> Path_nat_strict_nat x y)
  1062. Bool_isSet : isHSet Bool
  1063. Bool_isSet = pathToEq_isSet {Bool} (\{x} {y} -> p x y) where
  1064. p : (x : Bool) (y : Bool) -> Path x y -> Eq_s x y
  1065. p = \case
  1066. true -> \case
  1067. true -> \p -> refl_s
  1068. false -> \p -> absurd (trueNotFalse p)
  1069. false -> \case
  1070. false -> \p -> refl_s
  1071. true -> \p -> absurd (trueNotFalse (sym p))
  1072. equivCtr : {A : Type} {B : Type} (e : Equiv A B) (y : B) -> fiber e.1 y
  1073. equivCtr e y = (e.2 y).1
  1074. equivCtrPath : {A : Type} {B : Type} (e : Equiv A B) (y : B)
  1075. -> (v : fiber e.1 y) -> Path (equivCtr e y) v
  1076. equivCtrPath e y = (e.2 y).2
  1077. contr : {A : Type} {phi : I} -> isContr A -> (u : Partial phi A) -> Sub A phi u
  1078. contr {A} {phi} p u = primComp (\i -> A) (\i [ (phi = i1) as c -> p.2 (u c) i ]) (inS p.1)
  1079. contr' : {A : Type} -> ({phi : I} -> (u : Partial phi A) -> Sub A phi u) -> isContr A
  1080. contr' {A} contr = (x, \y i -> outS (contr (\ [ (i = i0) -> x, (i = i1) -> y ])) ) where
  1081. x : A
  1082. x = outS (contr (\ []))
  1083. leftIsOne : {a : I} {b : I} -> Eq_s a i1 -> Eq_s (ior a b) i1
  1084. leftIsOne {a} {b} p = J_s {I} {i1} (\i p -> IsOne (ior i b)) refl_s (sym_s p)
  1085. rightIsOne : {a : I} {b : I} -> Eq_s b i1 -> Eq_s (ior a b) i1
  1086. rightIsOne {a} {b} p = J_s {I} {i1} (\i p -> IsOne (ior a i)) refl_s (sym_s p)
  1087. bothAreOne : {a : I} {b : I} -> Eq_s a i1 -> Eq_s b i1 -> Eq_s (iand a b) i1
  1088. bothAreOne {a} {b} p q = J_s {I} {i1} (\i p -> IsOne (iand i b)) q (sym_s p)
  1089. S1Map_to_baseLoop : {X : Type} -> (S1 -> X) -> (a : X) * Path a a
  1090. S1Map_to_baseLoop {X} f = (f base, \i -> f (loop i))
  1091. baseLoop_to_S1Map : {X : Type} -> ((a : X) * Path a a) -> S1 -> X
  1092. baseLoop_to_S1Map {X} p = \case
  1093. base -> p.1
  1094. loop i -> p.2 i
  1095. S1_univ : {X : Type} -> Path (S1 -> X) ((a : X) * Path a a)
  1096. S1_univ = IsoToId {S1 -> X} {(a : X) * Path a a} (S1Map_to_baseLoop, baseLoop_to_S1Map, ret, sec) where
  1097. to = S1Map_to_baseLoop
  1098. fro = baseLoop_to_S1Map
  1099. sec : {X : Type} -> (f : S1 -> X) -> Path (fro (to f)) f
  1100. sec {X} f = funext {S1} {\s -> X} {\x -> fro (to f) x} {f} h where
  1101. h : (x : S1) -> Path (fro (to f) x) (f x)
  1102. h = \case
  1103. base -> refl
  1104. loop i -> refl
  1105. ret : {X : Type} -> (x : (a : X) * Path a a) -> Path (to (fro x)) x
  1106. ret x = refl
  1107. -- HoTT book lemma 8.9.1
  1108. encodeDecode : {A : Type} {a0 : A}
  1109. -> (code : A -> Type)
  1110. -> (c0 : code a0)
  1111. -> (decode : (x : A) -> code x -> (Path a0 x))
  1112. -> ((c : code a0) -> Path (transp (\i -> code (decode a0 c i)) c0) c)
  1113. -> Path (decode a0 c0) refl
  1114. -> Path (Path a0 a0) (code a0)
  1115. encodeDecode code c0 decode encDec based = IsoToId (encode {a0}, decode _, encDec, decEnc) where
  1116. encode : {x : A} -> Path a0 x -> code x
  1117. encode alpha = transp (\i -> code (alpha i)) c0
  1118. encodeRefl : Path (encode refl) c0
  1119. encodeRefl = sym (transpFill {\i -> code a0} c0)
  1120. decEnc : {x : A} (p : Path a0 x) -> Path (decode _ (encode p)) p
  1121. decEnc p = J (\x p -> Path (decode _ (encode p)) p) q p where
  1122. q : Path (decode _ (encode refl)) refl
  1123. q = transp (\i -> Path (decode _ (encodeRefl (inot i))) refl) based
  1124. S1_elim : (P : S1 -> Type)
  1125. -> (pb : P base)
  1126. -> PathP (\i -> P (loop i)) pb pb
  1127. -> (x : S1) -> P x
  1128. S1_elim P pb pq = \case
  1129. base -> pb
  1130. loop i -> pq i
  1131. PathP_is_Path : (P : I -> Type) (p : P i0) (q : P i1) -> Path (PathP P p q) (Path {P i1} (transp (\i -> P i) p) q)
  1132. PathP_is_Path P p q i = PathP (\j -> P (ior i j)) (transpFill {\j -> P j} p i) q
  1133. Constant : {A : Type} {B : Type} -> (A -> B) -> Type
  1134. Constant f = (y : B) * (x : A) -> Path y (f x)
  1135. Weakly : {A : Type} {B : Type} -> (A -> B) -> Type
  1136. Weakly f = (x : A) (y : A) -> Path (f x) (f y)
  1137. Conditionally : {A : Type} {B : Type} -> (A -> B) -> Type
  1138. Conditionally f = (f' : Sq A -> B) * Path f (\x -> f' (inc x))
  1139. Constant_weakly : {A : Type} {B : Type} (f : A -> B) -> Constant f -> Weakly f
  1140. Constant_weakly f p x y = trans (sym (p.2 x)) (p.2 y)
  1141. Constant_conditionally : {A : Type} {B : Type} -> (f : A -> B) -> Constant f -> Conditionally f
  1142. Constant_conditionally {A} {B} f p = transp (\i -> Conditionally (c_const (inot i))) (const_c p.1) where
  1143. c_const : Path f (\y -> p.1)
  1144. c_const i x = p.2 x (inot i)
  1145. const_c : (y : B) -> Conditionally {A} (\x -> y)
  1146. const_c y = (\x -> y, refl)
  1147. S1_connected : (f : S1 -> Bool) -> Constant f
  1148. S1_connected f = (f'.1, p) where
  1149. f' : (x : Bool) * Path x x
  1150. f' = S1Map_to_baseLoop f
  1151. p : (y : S1) -> Path f'.1 (f y)
  1152. p = S1_elim P refl loopc where
  1153. P : S1 -> Type
  1154. P = \y -> Path f'.1 (f y)
  1155. rr = refl {Bool} {f base}
  1156. loopc : PathP (\i -> P (loop i)) rr rr
  1157. loopc = transp (\i -> PathP_is_Path (\i -> P (loop i)) rr rr (inot i))
  1158. (Bool_isSet _ _ rr (transp (\i -> P (loop i)) rr))
  1159. isProp_isEquiv : {A : Type} {B : Type} {f : A -> B} -> isProp (isEquiv f)
  1160. isProp_isEquiv {f} p q i y =
  1161. let
  1162. p2 = (p y).2
  1163. q2 = (q y).2
  1164. in
  1165. ( p2 (q y).1 i
  1166. , \w j -> hcomp (\k [ (i = i0) -> p2 w j
  1167. , (i = i1) -> q2 w (ior j (inot k))
  1168. , (j = i0) -> p2 (q2 w (inot k)) i
  1169. , (j = i1) -> w ])
  1170. (inS (p2 w (ior i j)))
  1171. )
  1172. isProp_EqvSq : {P : Type} (x : Equiv P (Sq P)) (y : Equiv P (Sq P)) -> Path x y
  1173. isProp_EqvSq x y = sigmaPath x1_is_y1 (isProp_isEquiv {P} {Sq P} {y.1} (transp (\i -> isEquiv (x1_is_y1 i)) x.2) y.2) where
  1174. x1_is_y1 : Path x.1 y.1
  1175. x1_is_y1 i e = sq (x.1 e) (y.1 e) i
  1176. equivLemma : {A : Type} {B : Type} {e : Equiv A B} {e' : Equiv A B}
  1177. -> Path e.1 e'.1
  1178. -> Path e e'
  1179. equivLemma {A} {B} {e} {e'} p = sigmaPath p (isProp_isEquiv {A} {B} {e'.1} (transp (\i -> isEquiv (p i)) e.2) e'.2)
  1180. isProp_to_Sq_equiv : {P : Type} -> isProp P -> Equiv P (Sq P)
  1181. isProp_to_Sq_equiv {P} prop = propExt prop sqProp inc proj where
  1182. proj : Sq P -> P
  1183. proj = Sq_rec prop (\x -> x)
  1184. sqProp : isProp (Sq P)
  1185. sqProp x y i = sq x y i
  1186. Sq_equiv_to_isProp : {P : Type} -> Equiv P (Sq P) -> isProp P
  1187. Sq_equiv_to_isProp eqv = transp (\i -> isProp (univalence eqv (inot i))) (\x y i -> sq x y i)
  1188. exercise_3_21 : {P : Type} -> Equiv (isProp P) (Equiv P (Sq P))
  1189. exercise_3_21 {P} = propExt (isProp_isProp {P}) (isProp_EqvSq {P}) isProp_to_Sq_equiv Sq_equiv_to_isProp
  1190. uaret : {A : Type} {B : Type} -> retract {Equiv A B} {Path A B} (univalence {A} {B}) (idToEquiv {A} {B})
  1191. uaret eqv = equivLemma (univalenceBeta eqv)
  1192. f1 : {A : Type} -> (p : (B : Type) * Equiv A B) -> (B : Type) * Path A B
  1193. f1 {A} p = (p.1, univalence p.2)
  1194. f2 : {A : Type} -> (p : (B : Type) * Path A B) -> (B : Type) * Equiv A B
  1195. f2 {A} p = (p.1, idToEquiv p.2)
  1196. uaretSig : {A : Type} (a : (B : Type) * Equiv A B) -> Path (f2 (f1 a)) a
  1197. uaretSig {A} p = sigmaPath (\i -> p.1) (uaret {A} {p.1} p.2)
  1198. retContr : {A : Type} {B : Type}
  1199. -> (f : A -> B) -> (g : B -> A)
  1200. -> (h : retract f g)
  1201. -> isContr B -> isContr A
  1202. retContr {A} {B} f g h v = (g b, p) where
  1203. b = v.1
  1204. p : (x : A) -> Path (g b) x
  1205. p x i = comp (\i -> A) (\j [ (i = i0) -> g b, (i = i1) -> h x j ]) (inS (g (v.2 (f x) i)))
  1206. curry : {A : Type} {B : A -> Type} {C : (x : A) -> B x -> Type}
  1207. -> Path ((x : A) (y : B x) -> C x y) ((p : (x : A) * B x) -> C p.1 p.2)
  1208. curry {A} {B} {C} = IsoToId (to, from, \f -> refl, \g -> refl) where
  1209. to : ((x : A) (y : B x) -> C x y) -> (p : (x : A) * B x) -> C p.1 p.2
  1210. to f p = f p.1 p.2
  1211. from : ((p : (x : A) * B x) -> C p.1 p.2) -> (x : A) (y : B x) -> C x y
  1212. from f x y = f (x, y)
  1213. ft2 : {A : Type} -> Path (T2 -> A) (S1 -> S1 -> A)
  1214. ft2 {A} = transp (\i -> Path (T2 -> A) (curry {S1} {\x -> S1} {\x y -> A} (inot i))) p where
  1215. p : Path (T2 -> A) ((S1 * S1) -> A)
  1216. p i = TorusIsTwoCircles i -> A
  1217. data coeq {A : Type} {B : Type} (f : B -> A) (g : B -> A) : Type where
  1218. c : A -> coeq {A} {B} f g
  1219. p i : (b : B) -> coeq {A} {B} f g [ (i = i0) -> c (f b), (i = i1) -> c (g b) ]
  1220. coeq_S1 : Type
  1221. coeq_S1 = coeq {Unit} {Unit} id id
  1222. coeq_base : coeq_S1
  1223. coeq_base = c tt
  1224. coeq_loop : Path coeq_base coeq_base
  1225. coeq_loop i = p tt i
  1226. coeq_S1_elim : (P : coeq_S1 -> Type) (base : P coeq_base)
  1227. -> PathP (\i -> P (coeq_loop i)) base base
  1228. -> (x : coeq_S1)
  1229. -> P x
  1230. coeq_S1_elim P base loop =
  1231. \case
  1232. c x -> baseCase x
  1233. p x i -> loopCase x i
  1234. where
  1235. baseCase : (x : Unit) -> P (c x)
  1236. baseCase = \case
  1237. tt -> base
  1238. loopCase : (x : Unit) -> PathP (\i -> P (p x i)) (baseCase x) (baseCase x)
  1239. loopCase = \case
  1240. tt -> loop
  1241. ContractibleIfInhabited : {A : Type} -> Path (A -> isContr A) (isProp A)
  1242. ContractibleIfInhabited {A} = IsoToId (to, from, toFrom, fromTo) where
  1243. to : (A -> isContr A) -> isProp A
  1244. to cont x y = trans (sym (p.2 x)) (p.2 y) where
  1245. p = cont x
  1246. from : isProp A -> A -> isContr A
  1247. from prop x = (x, prop x)
  1248. toFrom : (y : isProp A) -> Path (to (from y)) y
  1249. toFrom y = isProp_isProp {A} (to (from y)) y
  1250. fromTo : (y : A -> isContr A) -> Path (from (to y)) y
  1251. fromTo y i a = isProp_isContr {A} (from (to y) a) (y a) i
  1252. data cone (A : Type) : Type where
  1253. point : cone A
  1254. base : A -> cone A
  1255. side i : (x : A) -> cone A [ (i = i0) -> point, (i = i1) -> base x ]
  1256. ConeA_contr : {A : Type} -> isContr (cone A)
  1257. ConeA_contr {A} = (point, contr) where
  1258. contr : (y : cone A) -> Path point y
  1259. contr = \case
  1260. point -> refl
  1261. base x -> \i -> side x i
  1262. side x i -> \j -> side x (iand i j)
  1263. contrSinglEquiv : {B : Type} -> isContr ((A : Type) * Equiv A B)
  1264. contrSinglEquiv {B} = (center, contract) where
  1265. center : (A : Type) * Equiv A B
  1266. center = (B, the B, idEquiv {B})
  1267. contract : (p : (A : Type) * Equiv A B) -> Path center p
  1268. contract w i =
  1269. let
  1270. sys : Partial (ior (inot i) i) ((A : Type) * Equiv A B)
  1271. sys = \ [ (i = i0) -> center, (i = i1) -> w ]
  1272. GlueB = Glue B sys
  1273. unglueB : GlueB -> B
  1274. unglueB x = unglue {B} (ior (inot i) i) {sys} x
  1275. unglueEquiv : isEquiv {GlueB} {B} unglueB
  1276. unglueEquiv b =
  1277. let
  1278. ctr : fiber unglueB b
  1279. ctr = ( glue {B} {ior (inot i) i} {sys} (\[ (i = i0) -> b, (i = i1) -> (w.2.2 b).1.1 ])
  1280. (primComp (\i -> B) (\j [ (i = i0) -> b, (i = i1) -> (w.2.2 b).1.2 j ]) (inS b))
  1281. , fill (\i -> B) (\j [ (i = i0) -> b, (i = i1) -> (w.2.2 b).1.2 j ]) (inS b))
  1282. contr : (v : fiber unglueB b) -> Path ctr v
  1283. contr v j = ( glue {B} {ior (inot i) i} {sys}
  1284. (\[ (i = i0) -> v.2 j, (i = i1) -> ((w.2.2 b).2 v j).1 ])
  1285. (inS (comp (\i -> B)
  1286. (\k [ (i = i0) -> v.2 (iand j k)
  1287. , (i = i1) -> ((w.2.2 b).2 v j).2 k
  1288. , (j = i0) -> fill (\j -> B) (\k [ (i = i0) -> b, (i = i1) -> (w.2.2 b).1.2 k ]) (inS b) k
  1289. , (j = i1) -> v.2 k
  1290. ])
  1291. (inS b)))
  1292. , fill (\j -> B) (\k [ (i = i0) -> v.2 (iand j k)
  1293. , (i = i1) -> ((w.2.2 b).2 v j).2 k
  1294. , (j = i0) -> fill (\j -> B) (\k [ (i = i0) -> b, (i = i1) -> (w.2.2 b).1.2 k ]) (inS b) k
  1295. , (j = i1) -> v.2 k
  1296. ])
  1297. (inS b)
  1298. )
  1299. in (ctr, contr)
  1300. in (GlueB, unglueB, unglueEquiv)
  1301. uaIdEquiv : {A : Type} -> Path (univalence (the A, idEquiv {A})) (\i -> A)
  1302. uaIdEquiv {A} i j = Glue A {ior i (ior (inot j) j)} (\o -> (A, the A, idEquiv {A}))
  1303. EquivJ : {X : Type}
  1304. (P : (Y : Type) -> Equiv Y X -> Type)
  1305. (d : P X (the X, idEquiv {X}))
  1306. {Y : Type} (E : Equiv Y X)
  1307. -> P Y E
  1308. EquivJ {X} P d {Y} e = subst {(Y : Type) * Equiv Y X} (\x -> P x.1 x.2) path d where
  1309. path : Path {(Y : Type) * Equiv Y X} (X, the X, idEquiv {X}) (Y, e)
  1310. path = isContr_isProp {(Y : Type) * Equiv Y X} contrSinglEquiv (X, the X, idEquiv {X}) (Y, e)
  1311. uaIso : {A : Type} {B : Type} -> Iso (Path A B) (Equiv A B)
  1312. uaIso = (pathToEquiv, univalence, pathToEquiv_univalence, univalence_pathToEquiv) where
  1313. pathToEquiv : {A : Type} {B : Type} -> Path A B -> Equiv A B
  1314. pathToEquiv {A} {B} = J {Type} {A} (\B p -> Equiv A B) (the A, idEquiv {A})
  1315. pathToEquiv_refl : {A : Type} -> Path (pathToEquiv (refl {Type} {A})) (the A, idEquiv {A})
  1316. pathToEquiv_refl {A} = JRefl (\B p -> Equiv A B) (the A, idEquiv {A})
  1317. univalence_pathToEquiv : {A : Type} {B : Type} (p : Path A B) -> Path (univalence (pathToEquiv p)) p
  1318. univalence_pathToEquiv {A} {B} p = J {Type} {A} (\B p -> Path (univalence {A} {B} (pathToEquiv {A} {B} p)) p) lemma p where
  1319. lemma : Path (univalence (pathToEquiv (\i -> A))) (\i -> A)
  1320. lemma = transp (\i -> Path (univalence (pathToEquiv_refl {A} (inot i))) (\i -> A)) uaIdEquiv
  1321. pathToEquiv_univalence : {A : Type} {B : Type} (p : Equiv A B) -> Path (pathToEquiv (univalence p)) p
  1322. pathToEquiv_univalence {A} {B} p = EquivJ {B} (\A e -> Path (pathToEquiv (univalence e)) e) lemma p where
  1323. lemma : Path (pathToEquiv (univalence (the B, idEquiv {B}))) (the B, idEquiv {B})
  1324. lemma = transp (\i -> Path (pathToEquiv (uaIdEquiv {B} (inot i))) (the B, idEquiv {B})) pathToEquiv_refl
  1325. uaEquiv : {A : Type} {B : Type} -> isEquiv (pathToEquiv {A} {B})
  1326. uaEquiv {A} {B} = (IsoToEquiv (uaIso {A} {B})).2