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.

895 lines
30 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 : Type) -> 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. cong : {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. cong f p i = f (p i)
  92. -- These satisfy definitional equalities, like congComp and congId, which are
  93. -- propositional in vanilla MLTT.
  94. congComp : {A : Type} {B : Type} {C : Type}
  95. {f : A -> B} {g : B -> C} {x : A} {y : A}
  96. (p : Path x y)
  97. -> Path (cong g (cong f p)) (cong (\x -> g (f x)) p)
  98. congComp p = refl
  99. congId : {A : Type} {x : A} {y : A}
  100. (p : Path x y)
  101. -> Path (cong (id {A}) p) p
  102. congId p = refl
  103. -- Just like rearranging parentheses gives us cong, 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. -- Associated with every element i : I of the interval, we have the type
  112. -- IsOne i which is inhabited only when i = i1. In the model, this
  113. -- corresponds to the map [φ] from the interval cubical set to the
  114. -- subobject classifier.
  115. IsOne : I -> Pretype
  116. {-# PRIMITIVE IsOne #-}
  117. -- The value itIs1 witnesses the fact that i1 = i1.
  118. itIs1 : IsOne i1
  119. {-# PRIMITIVE itIs1 #-}
  120. -- Partial elements
  121. -------------------
  122. --
  123. -- Since a function I -> A has two endpoints, and a function I -> I -> A
  124. -- has four endpoints + four functions I -> A as "sides" (obtained by
  125. -- varying argument while holding the other as a bound variable), we
  126. -- refer to elements of I^n -> A as "cubes".
  127. -- This justifies the existence of partial elements, which are, as the
  128. -- name implies, partial cubes. Namely, a Partial φ A is an element of A
  129. -- which depends on a proof that IsOne φ.
  130. Partial : I -> Type -> Pretype
  131. {-# PRIMITIVE Partial #-}
  132. -- There is also a dependent version where the type A is itself a
  133. -- partial element.
  134. PartialP : (phi : I) -> Partial phi Type -> Pretype
  135. {-# PRIMITIVE PartialP #-}
  136. -- Why is Partial φ A not just defined as φ -> A? The difference is that
  137. -- Partial φ A has an internal representation which definitionally relates
  138. -- any two partial elements which "agree everywhere", that is, have
  139. -- equivalent values for every possible assignment of variables which
  140. -- makes IsOne φ hold.
  141. -- Cubical Subtypes
  142. --------------------
  143. -- Given A : Type, phi : I, and a partial element u : A defined on φ,
  144. -- we have the type Sub A phi u, notated A[phi -> u] in the output of
  145. -- the type checker, whose elements are "extensions" of u.
  146. -- That is, element of A[phi -> u] is an element of A defined everywhere
  147. -- (a total element), which, when IsOne φ, agrees with u.
  148. Sub : (A : Type) (phi : I) -> Partial phi A -> Pretype
  149. {-# PRIMITIVE Sub #-}
  150. -- Every total element u : A can be made partial on φ by ignoring the
  151. -- constraint. Furthermore, this "totally partial" element agrees with
  152. -- the original total element on φ.
  153. inS : {A : Type} {phi : I} (u : A) -> Sub A phi (\x -> u)
  154. {-# PRIMITIVE inS #-}
  155. -- When IsOne φ, outS {A} {φ} {u} x reduces to u itIs1.
  156. -- This implements the fact that x agrees with u on φ.
  157. outS : {A : Type} {phi : I} {u : Partial phi A} -> Sub A phi u -> A
  158. {-# PRIMITIVE outS #-}
  159. -- The composition operation
  160. ----------------------------
  161. -- Now that we have syntax for specifying partial cubes,
  162. -- and specifying that an element agrees with a partial cube,
  163. -- we can describe the composition operation.
  164. comp : (A : I -> Type) {phi : I} (u : (i : I) -> Partial phi (A i)) -> Sub (A i0) phi (u i0) -> A i1
  165. {-# PRIMITIVE comp #-}
  166. -- In particular, when φ is a disjunction of the form
  167. -- (j = 0) || (j = 1), we can draw u as being a pair of lines forming a
  168. -- "tube", an open square with no floor or roof:
  169. --
  170. -- Given u = \j [ (i = i0) -> x, (i = i1) -> q j] on the extent i || ~i,
  171. -- we draw:
  172. --
  173. -- x q i1
  174. -- | |
  175. -- \j -> x | | \j -> q j
  176. -- | |
  177. -- x q i0
  178. --
  179. -- The composition operation says that, as long as we can provide a
  180. -- "floor" connecting x -- q i0, as a total element of A which, on
  181. -- phi, extends u i0, then we get the "roof" connecting x and q i1
  182. -- for free.
  183. --
  184. -- If we have a path p : x ≡ y, and q : y ≡ z, then we do get the
  185. -- "floor", and composition gets us the dotted line:
  186. --
  187. -- x..........z
  188. -- | |
  189. -- x | | q j
  190. -- | |
  191. -- x----------y
  192. -- p i
  193. trans : {A : Type} {x : A} {y : A} {z : A} -> PathP (\i -> A) x y -> PathP (\i -> A) y z -> PathP (\i -> A) x z
  194. trans {A} {x} p q i =
  195. comp (\i -> A)
  196. {ior i (inot i)}
  197. (\j [ (i = i0) -> x, (i = i1) -> q j ])
  198. (inS (p i))
  199. -- In particular when the formula φ = i0 we get the "opposite face" to a
  200. -- single point, which corresponds to transport.
  201. transp : (A : I -> Type) (x : A i0) -> A i1
  202. transp A x = comp A {i0} (\i [ ]) (inS x)
  203. -- Since we have the iand operator, we can also derive the *filler* of a cube,
  204. -- which connects the given face and the output of composition.
  205. fill : (A : I -> Type) {phi : I} (u : (i : I) -> Partial phi (A i)) -> Sub (A i0) phi (u i0) -> (i : I) -> A i
  206. fill A {phi} u a0 i =
  207. comp (\j -> A (iand i j))
  208. {ior phi (inot i)}
  209. (\j [ (phi = i1) as p -> u (iand i j) p, (i = i0) -> outS a0 ])
  210. (inS (outS a0))
  211. hfill : {A : Type} {phi : I} (u : (i : I) -> Partial phi A) -> Sub A phi (u i0) -> I -> A
  212. hfill {A} {phi} u a0 i = fill (\i -> A) {phi} u a0 i
  213. hcomp : {A : Type} {phi : I} (u : (i : I) -> Partial phi A) -> Sub A phi (u i0) -> A
  214. hcomp {A} {phi} u a0 = comp (\i -> A) {phi} u a0
  215. -- For instance, the filler of the previous composition square
  216. -- tells us that trans p refl = p:
  217. transRefl : {A : Type} {x : A} {y : A} (p : Path x y) -> Path (trans p refl) p
  218. transRefl p j i = fill (\i -> A) {ior i (inot i)} (\k [ (i = i0) -> x, (i = i1) -> y ]) (inS (p i)) (inot j)
  219. -- Reduction of composition
  220. ---------------------------
  221. --
  222. -- Composition reduces on the structure of the family A : I -> Type to create
  223. -- the element a1 : (A i1)[phi -> u i1].
  224. --
  225. -- For instance, when filling a cube of functions, the behaviour is to
  226. -- first transport backwards along the domain, apply the function, then
  227. -- forwards along the codomain.
  228. transpFun : {A : Type} {B : Type} {C : Type} {D : Type} (p : Path A B) (q : Path C D)
  229. -> (f : A -> C) -> Path (transp (\i -> p i -> q i) f)
  230. (\x -> transp (\i -> q i) (f (transp (\i -> p (inot i)) x)))
  231. transpFun p q f = refl
  232. -- transpDFun : {A : I -> Type} {B : (i : I) -> A i -> Type}
  233. -- -> (f : (x : A i0) -> B i0 x)
  234. -- -> Path (transp (\i -> (x : A i) -> B i x) f)
  235. -- (\x -> transp (\i -> B i (fill (\j -> A (inot j)) (\k []) (inS x) (inot i))) (f (fill (\j -> A (inot j)) (\k []) (inS x) i1)))
  236. -- transpDFun f = refl
  237. -- When considering the more general case of a composition respecing sides,
  238. -- the outer transport becomes a composition.
  239. -- Glueing and Univalence
  240. -------------------------
  241. -- First, let's get some definitions out of the way.
  242. --
  243. -- The *fiber* of a function f : A -> B at a point y : B is the type of
  244. -- inputs x : A which f takes to y, that is, for which there exists a
  245. -- path f(x) = y.
  246. fiber : {A : Type} {B : Type} -> (A -> B) -> B -> Type
  247. fiber f y = (x : A) * Path (f x) y
  248. -- An *equivalence* is a function where every fiber is contractible.
  249. -- That is, for every point in the codomain y : B, there is exactly one
  250. -- point in the input which f maps to y.
  251. isEquiv : {A : Type} {B : Type} -> (A -> B) -> Type
  252. isEquiv {A} {B} f = (y : B) -> isContr (fiber {A} {B} f y)
  253. -- By extracting this point, which must exist because the fiber is contractible,
  254. -- we can get an inverse of f:
  255. inverse : {A : Type} {B : Type} {f : A -> B} -> isEquiv f -> B -> A
  256. inverse eqv y = (eqv y) .1 .1
  257. -- We can prove that «inverse eqv» is a section of f:
  258. section : {A : Type} {B : Type} (f : A -> B) (eqv : isEquiv f) -> Path (\x -> f (inverse eqv x)) id
  259. section f eqv i y = (eqv y) .1 .2 i
  260. contr : {A : Type} {phi : I} -> isContr A -> (u : Partial phi A) -> A
  261. contr {A} {phi} p u = comp (\i -> A) {phi} (\i is1 -> p.2 (u is1) i) (inS (p.1))
  262. -- Proving that it's also a retraction is left as an exercise to the
  263. -- reader. We can package together a function and a proof that it's an
  264. -- equivalence to get a capital-E Equivalence.
  265. Equiv : (A : Type) (B : Type) -> Type
  266. Equiv A B = (f : A -> B) * isEquiv {A} {B} f
  267. -- The identity function is an equivalence between any type A and
  268. -- itself.
  269. idEquiv : {A : Type} -> isEquiv (id {A})
  270. idEquiv y = ((y, \i -> y), \u i -> (u.2 (inot i), \j -> u.2 (ior (inot i) j)))
  271. -- The glue operation expresses that "extensibility is invariant under
  272. -- equivalence". Less concisely, the Glue type and its constructor,
  273. -- glue, let us extend a partial element of a partial type to a total
  274. -- element of a total type, by "gluing" the partial type T using a
  275. -- partial equivalence e onto a total type A.
  276. -- In particular, we have that when φ = i1, Glue A [i1 -> (T, f)] = T.
  277. primGlue : (A : Type) {phi : I}
  278. (T : Partial phi Type)
  279. (e : PartialP phi (\o -> Equiv (T o) A))
  280. -> Type
  281. {-# PRIMITIVE Glue primGlue #-}
  282. -- The glue constructor extends the partial element t : T to a total
  283. -- element of Glue A [φ -> (T, e)] as long as we have a total im : A
  284. -- which is the image of f(t).
  285. --
  286. -- Agreeing with the condition that Glue A [i1 -> (T, e)] = T,
  287. -- we have that glue {A} {i1} t im => t.
  288. prim'glue : {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)}
  289. -> (t : PartialP phi T)
  290. -> (im : Sub A phi (\o -> (e o).1 (t o)))
  291. -> primGlue A T e
  292. {-# PRIMITIVE glue prim'glue #-}
  293. -- The unglue operation undoes a glueing. Since when φ = i1,
  294. -- Glue A [φ -> (T, f)] = T, the argument to primUnglue {A} {i1} ...
  295. -- will have type T, and so to get back an A we need to apply the
  296. -- partial equivalence f (defined everywhere).
  297. primUnglue : {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)}
  298. -> primGlue A {phi} T e -> A
  299. {-# PRIMITIVE unglue primUnglue #-}
  300. -- Diagramatically, i : I |- Glue A [(i \/ ~i) -> (T, e)] can be drawn
  301. -- as giving us the dotted line in:
  302. --
  303. -- T i0 ......... T i1
  304. -- | |
  305. -- | |
  306. -- e i0 |~ ~| e i1
  307. -- | |
  308. -- | |
  309. -- A i0 --------- A i1
  310. -- A
  311. --
  312. -- Where the the two "e" sides are equivalences, and the bottom side is
  313. -- the line i : I |- A.
  314. --
  315. -- Thus, by choosing a base type, a set of partial types and partial
  316. -- equivalences, we can make a line between two types (T i0) and (T i1).
  317. Glue : (A : Type) {phi : I} -> Partial phi ((X : Type) * Equiv X A) -> Type
  318. Glue A {phi} u = primGlue A {phi} (\o -> (u o).1) (\o -> (u o).2)
  319. -- For example, we can glue together the type A and the type B as long
  320. -- as there exists an Equiv A B.
  321. --
  322. -- A ............ B
  323. -- | |
  324. -- | |
  325. -- equiv |~ ua equiv ~| idEquiv {B}
  326. -- | |
  327. -- | |
  328. -- B ------------ B
  329. -- \i → B
  330. --
  331. univalence : {A : Type} {B : Type} -> Equiv A B -> Path A B
  332. univalence {A} {B} equiv i =
  333. Glue B (\[ (i = i0) -> (A, equiv),
  334. (i = i1) -> (B, the B, idEquiv {B}) ])
  335. -- The fact that this diagram has 2 filled-in B sides explains the
  336. -- complication in the proof below.
  337. --
  338. -- In particular, the actual behaviour of transp (\i -> univalence f i)
  339. -- (x : A) is not just to apply f x to get a B (the left side), it also
  340. -- needs to:
  341. --
  342. -- * For the bottom side, compose along (\i -> B) (the bottom side)
  343. -- * For the right side, apply the inverse of the identity, which
  344. -- is just identity, to get *some* b : B
  345. --
  346. -- But that b : B might not agree with the sides of the composition
  347. -- operation in a more general case, so it composes along (\i -> B)
  348. -- *again*!
  349. --
  350. -- Thus the proof: a simple cubical argument suffices, since
  351. -- for any composition, its filler connects either endpoints. So
  352. -- we need to come up with a filler for the bottom and right faces.
  353. univalenceBeta : {A : Type} {B : Type} (f : Equiv A B) -> Path (transp (\i -> univalence f i)) f.1
  354. univalenceBeta {A} {B} f i a =
  355. let
  356. -- The bottom left corner
  357. botLeft : B
  358. botLeft = transp (\i -> B) (f.1 a)
  359. -- The "bottom face" filler connects the bottom-left corner, f.1 a,
  360. -- and the bottom-right corner, which is the transport of f.1 a
  361. -- along \i -> B.
  362. botFace : Path (f.1 a) botLeft
  363. botFace i = fill (\i -> B) (\j []) (inS (f.1 a)) i
  364. -- The "right face" filler connects the bottom-right corner and the
  365. -- upper-right corner, which is again a simple transport along
  366. -- \i -> B.
  367. rightFace : Path (transp (\i -> B) botLeft) botLeft
  368. rightFace i = fill (\i -> B) (\j []) (inS botLeft) (inot i)
  369. -- The goal is a path between the bottom-left and top-right corners,
  370. -- which we can get by composing (in the path sense) the bottom and
  371. -- right faces.
  372. goal : Path (transp (\i -> B) botLeft) (f.1 a)
  373. goal = trans rightFace (\i -> botFace (inot i))
  374. in goal i
  375. -- The terms univalence + univalenceBeta suffice to prove the "full"
  376. -- univalence axiom of Voevodsky, as can be seen in the paper
  377. --
  378. -- Ian Orton, & Andrew M. Pitts. (2017). Decomposing the Univalence Axiom.
  379. --
  380. -- Available freely here: https://arxiv.org/abs/1712.04890v3
  381. J : {A : Type} {x : A}
  382. (P : (y : A) -> Path x y -> Type)
  383. (d : P x (\i -> x))
  384. {y : A} (p : Path x y)
  385. -> P y p
  386. J P d p = transp (\i -> P (p i) (\j -> p (iand i j))) d
  387. -- Isomorphisms
  388. ---------------
  389. --
  390. -- Since isomorphisms are a much more convenient notion of equivalence
  391. -- than contractible fibers, it's natural to ask why the CCHM paper, and
  392. -- this implementation following that, decided on the latter for our
  393. -- definition of equivalence.
  394. isIso : {A : Type} -> {B : Type} -> (A -> B) -> Type
  395. isIso {A} {B} f = (g : B -> A) * ((y : B) -> Path (f (g y)) y) * ((x : A) -> Path (g (f x)) x)
  396. -- The reason is that the family of types IsIso is not a proposition!
  397. -- This means that there can be more than one way for a function to be
  398. -- an equivalence. This is Lemma 4.1.1 of the HoTT book.
  399. Iso : Type -> Type -> Type
  400. Iso A B = (f : A -> B) * isIso f
  401. -- Nevertheless, we can prove that any function with an isomorphism
  402. -- structure has contractible fibers, using a cubical argument adapted
  403. -- from CCHM's implementation of cubical type theory:
  404. --
  405. -- https://github.com/mortberg/cubicaltt/blob/master/experiments/isoToEquiv.ctt#L7-L55
  406. IsoToEquiv : {A : Type} {B : Type} -> Iso A B -> Equiv A B
  407. IsoToEquiv {A} {B} iso = (f, \y -> (fCenter y, fIsCenter y)) where
  408. f = iso.1
  409. g = iso.2.1
  410. s = iso.2.2.1
  411. t = iso.2.2.2
  412. lemIso : (y : B) (x0 : A) (x1 : A) (p0 : Path (f x0) y) (p1 : Path (f x1) y)
  413. -> PathP (\i -> fiber f y) (x0, p0) (x1, p1)
  414. lemIso y x0 x1 p0 p1 =
  415. let
  416. rem0 : Path x0 (g y)
  417. rem0 i = comp (\i -> A) (\k [ (i = i0) -> t x0 k, (i = i1) -> g y ]) (inS (g (p0 i)))
  418. rem1 : Path x1 (g y)
  419. rem1 i = comp (\i -> A) (\k [ (i = i0) -> t x1 k, (i = i1) -> g y ]) (inS (g (p1 i)))
  420. p : Path x0 x1
  421. p i = comp (\i -> A) (\k [ (i = i0) -> rem0 (inot k), (i = i1) -> rem1 (inot k) ]) (inS (g y))
  422. fill0 : I -> I -> A
  423. fill0 i j = comp (\i -> A) (\k [ (i = i0) -> t x0 (iand j k)
  424. , (i = i1) -> g y
  425. , (j = i0) -> g (p0 i)
  426. ])
  427. (inS (g (p0 i)))
  428. fill1 : I -> I -> A
  429. fill1 i j = comp (\i -> A) (\k [ (i = i0) -> t x1 (iand j k)
  430. , (i = i1) -> g y
  431. , (j = i0) -> g (p1 i) ])
  432. (inS (g (p1 i)))
  433. fill2 : I -> I -> A
  434. fill2 i j = comp (\i -> A) (\k [ (i = i0) -> rem0 (ior j (inot k))
  435. , (i = i1) -> rem1 (ior j (inot k))
  436. , (j = i1) -> g y ])
  437. (inS (g y))
  438. sq : I -> I -> A
  439. sq i j = comp (\i -> A) (\k [ (i = i0) -> fill0 j (inot k)
  440. , (i = i1) -> fill1 j (inot k)
  441. , (j = i1) -> g y
  442. , (j = i0) -> t (p i) (inot k) ])
  443. (inS (fill2 i j))
  444. sq1 : I -> I -> B
  445. sq1 i j = comp (\i -> B) (\k [ (i = i0) -> s (p0 j) k
  446. , (i = i1) -> s (p1 j) k
  447. , (j = i0) -> s (f (p i)) k
  448. , (j = i1) -> s y k
  449. ])
  450. (inS (f (sq i j)))
  451. in \i -> (p i, \j -> sq1 i j)
  452. fCenter : (y : B) -> fiber f y
  453. fCenter y = (g y, s y)
  454. fIsCenter : (y : B) (w : fiber f y) -> Path (fCenter y) w
  455. fIsCenter y w = lemIso y (fCenter y).1 w.1 (fCenter y).2 w.2
  456. -- We can prove that any involutive function is an isomorphism, since
  457. -- such a function is its own inverse.
  458. involToIso : {A : Type} (f : A -> A) -> ((x : A) -> Path (f (f x)) x) -> isIso f
  459. involToIso {A} f inv = (f, inv, inv)
  460. -- An example of univalence
  461. ---------------------------
  462. --
  463. -- The classic example of univalence is the equivalence
  464. -- not : Bool \simeq Bool.
  465. --
  466. -- We define it here.
  467. data Bool : Type where
  468. true : Bool
  469. false : Bool
  470. not : Bool -> Bool
  471. not = \case
  472. true -> false
  473. false -> true
  474. elimBool : (P : Bool -> Type) -> P true -> P false -> (b : Bool) -> P b
  475. elimBool P x y = \case
  476. true -> x
  477. false -> y
  478. if : {A : Type} -> A -> A -> Bool -> A
  479. if x y = \case
  480. true -> x
  481. false -> y
  482. -- By pattern matching it suffices to prove (not (not true)) ≡ true and
  483. -- not (not false) ≡ false. Since not (not true) computes to true (resp.
  484. -- false), both proofs go through by refl.
  485. notInvol : (x : Bool) -> Path (not (not x)) x
  486. notInvol = elimBool (\b -> Path (not (not b)) b) refl refl
  487. notp : Path Bool Bool
  488. notp = univalence (IsoToEquiv (not, involToIso not notInvol))
  489. -- This path actually serves to prove a simple lemma about the universes
  490. -- of HoTT, namely, that any univalent universe is not a 0-type. If we
  491. -- had HITs, we could prove that this fact holds for any n, but for now,
  492. -- proving it's not an h-set is the furthest we can go.
  493. -- First we define what it means for something to be false. In type theory,
  494. -- we take ¬P = P → ⊥, where the bottom type is the only type satisfying
  495. -- the elimination principle
  496. --
  497. -- elimBottom : (P : bottom -> Type) -> (b : bottom) -> P b
  498. --
  499. -- This follows from setting bottom := ∀ A, A.
  500. bottom : Type
  501. bottom = {A : Type} -> A
  502. elimBottom : (P : bottom -> Type) -> (b : bottom) -> P b
  503. elimBottom P x = x
  504. -- We prove that true != false by transporting along the path
  505. --
  506. -- \i -> if (Bool -> Bool) A (p i)
  507. -- (Bool -> Bool) ------------------------------------ A
  508. --
  509. -- To verify that this has the correct endpoints, check out the endpoints
  510. -- for p:
  511. --
  512. -- true ------------------------------------ false
  513. --
  514. -- and evaluate the if at either end.
  515. trueNotFalse : Path true false -> bottom
  516. trueNotFalse p {A} = transp (\i -> if (Bool -> Bool) A (p i)) id
  517. -- To be an h-Set is to have no "higher path information". Alternatively,
  518. --
  519. -- isHSet A = (x : A) (y : A) -> isHProp (Path x y)
  520. --
  521. isHSet : Type -> Type
  522. isHSet A = {x : A} {y : A} (p : Path x y) (q : Path x y) -> Path p q
  523. -- We can prove *a* contradiction (note: this is a direct proof!) by adversarially
  524. -- choosing two paths p, q that we know are not equal. Since "equal" paths have
  525. -- equal behaviour when transporting, we can choose two paths p, q and a point x
  526. -- such that transporting x along p gives a different result from x along q.
  527. --
  528. -- Since transp notp = not but transp refl = id, that's what we go with. The choice
  529. -- of false as the point x is just from the endpoints of trueNotFalse.
  530. universeNotSet : isHSet Type -> bottom
  531. universeNotSet itIs = trueNotFalse (\i -> transp (\j -> itIs notp refl i j) false)
  532. -- Funext is an inverse of happly
  533. ---------------------------------
  534. --
  535. -- Above we proved function extensionality, namely, that functions
  536. -- pointwise equal everywhere are themselves equal.
  537. -- However, this formulation of the axiom is known as "weak" function
  538. -- extensionality. The strong version is as follows:
  539. Hom : {A : Type} {B : A -> Type} (f : (x : A) -> B x) -> (g : (x : A) -> B x) -> Type
  540. Hom {A} f g = (x : A) -> Path (f x) (g x)
  541. happly : {A : Type} {B : A -> Type} {f : (x : A) -> B x} {g : (x : A) -> B x}
  542. -> (p : Path f g) -> Hom f g
  543. happly p x i = p i x
  544. -- Strong function extensionality: happly is an equivalence.
  545. happlyIsIso : {A : Type} {B : A -> Type} {f : (x : A) -> B x} {g : (x : A) -> B x}
  546. -> isIso {Path f g} {Hom f g} happly
  547. happlyIsIso {A} {B} {f} {g} = (funext {A} {B} {f} {g}, \hom -> refl, \path -> refl)
  548. pathIsHom : {A : Type} {B : A -> Type} {f : (x : A) -> B x} {g : (x : A) -> B x}
  549. -> Path (Path f g) (Hom f g)
  550. pathIsHom {A} {B} {f} {g} =
  551. let
  552. theIso : Iso (Path f g) (Hom f g)
  553. theIso = (happly {A} {B} {f} {g}, happlyIsIso {A} {B} {f} {g})
  554. in univalence (IsoToEquiv theIso)
  555. -- Inductive types
  556. -------------------
  557. --
  558. -- An inductive type is a type freely generated by a finite set of
  559. -- constructors. For instance, the type of natural numbers is generated
  560. -- by the constructors for "zero" and "successor".
  561. data Nat : Type where
  562. zero : Nat
  563. succ : Nat -> Nat
  564. -- Pattern matching allows us to prove that these initial types are
  565. -- initial algebras for their corresponding functors.
  566. Nat_elim : (P : Nat -> Type) -> P zero -> ((x : Nat) -> P x -> P (succ x)) -> (x : Nat) -> P x
  567. Nat_elim P pz ps = \case
  568. zero -> pz
  569. succ x -> ps x (Nat_elim P pz ps x)
  570. -- The type of integers can be defined as A + B, where "pos n" means +n
  571. -- and "neg n" means -(n + 1).
  572. data Int : Type where
  573. pos : Nat -> Int
  574. neg : Nat -> Int
  575. -- On this representation we can define the successor and predecessor
  576. -- functions by (nested) induction.
  577. sucZ : Int -> Int
  578. sucZ = \case
  579. pos n -> pos (succ n)
  580. neg n ->
  581. let suc_neg : Nat -> Int
  582. suc_neg = \case
  583. zero -> pos zero
  584. succ n -> neg n
  585. in suc_neg n
  586. predZ : Int -> Int
  587. predZ = \case
  588. pos n ->
  589. let pred_pos : Nat -> Int
  590. pred_pos = \case
  591. zero -> neg zero
  592. succ n -> pos n
  593. in pred_pos n
  594. neg n -> neg (succ n)
  595. -- And prove that the successor function is an isomorphism, and thus, an
  596. -- equivalence.
  597. sucEquiv : isIso sucZ
  598. sucEquiv =
  599. let
  600. sucPredZ : (x : Int) -> Path (sucZ (predZ x)) x
  601. sucPredZ = \case
  602. pos n ->
  603. let k : (n : Nat) -> Path (sucZ (predZ (pos n))) (pos n)
  604. k = \case
  605. zero -> refl
  606. succ n -> refl
  607. in k n
  608. neg n -> refl
  609. predSucZ : (x : Int) -> Path (predZ (sucZ x)) x
  610. predSucZ = \case
  611. pos n -> refl
  612. neg n ->
  613. let k : (n : Nat) -> Path (predZ (sucZ (neg n))) (neg n)
  614. k = \case
  615. zero -> refl
  616. succ n -> refl
  617. in k n
  618. in (predZ, sucPredZ, predSucZ)
  619. -- Univalence gives us a path between integers such that transp intPath
  620. -- x = suc x, transp (sym intPath) x = pred x
  621. intPath : Path Int Int
  622. intPath = univalence (IsoToEquiv (sucZ, sucEquiv))
  623. -- Higher inductive types
  624. -------------------------
  625. --
  626. -- While inductive types let us generate discrete spaces like the
  627. -- naturals or integers, they do not support defining higher-dimensional
  628. -- structures given by spaces with points and paths.
  629. -- A very simple higher inductive type is the interval, given by
  630. data Interval : Type where
  631. ii0 : Interval
  632. ii1 : Interval
  633. seg i : Interval [ (i = i0) -> ii0, (i = i1) -> ii1 ]
  634. -- This expresses that we have two points ii0 and ii1 and a path (\i ->
  635. -- seg i) with endpoints ii0 and ii1.
  636. -- With this type we can reproduce the proof of Lemma 6.3.2 from the
  637. -- HoTT book:
  638. iFunext : {A : Type} {B : A -> Type} (f : (x : A) -> B x) (g : (x : A) -> B x) -> ((x : A) -> Path (f x) (g x)) -> Path f g
  639. iFunext f g p i = h' (seg i) where
  640. h : (x : A) -> Interval -> B x
  641. h x = \case
  642. ii0 -> f x
  643. ii1 -> g x
  644. seg i -> p x i
  645. h' : Interval -> (x : A) -> B x
  646. h' i x = h x i
  647. -- Of course, Cubical Type Theory also has an interval (pre)type, but
  648. -- that, unlike the Interval here, is not Kan: it has no composition
  649. -- structure.
  650. -- Another simple higher-inductive type is the circle, with a point and
  651. -- a non-trivial loop, (\i -> loop i).
  652. data S1 : Type where
  653. base : S1
  654. loop i : S1 [ (i = i1) -> base, (i = i0) -> base ]
  655. -- By writing a function from the circle to the universe of types Type,
  656. -- we can calculate winding numbers along the circle.
  657. helix : S1 -> Type
  658. helix = \case
  659. base -> Int
  660. loop i -> intPath i
  661. winding : Path base base -> Int
  662. winding p = transp (\i -> helix (p i)) (pos zero)
  663. -- For instance, going around the loop once has a winding number of +1,
  664. windingLoop : Path (winding (\i -> loop i)) (pos (succ zero))
  665. windingLoop = refl
  666. -- Going backwards has a winding number of -1 (remember the
  667. -- representation of integers),
  668. windingSymLoop : Path (winding (\i -> loop (inot i))) (neg zero)
  669. windingSymLoop = refl
  670. -- And going around the trivial loop (\i -> base) goes around the the
  671. -- non-trivial loop (\i -> loop) zero times.
  672. windingBase : Path (winding (\i -> base)) (pos zero)
  673. windingBase = refl
  674. -- One particularly general higher inductive type is the homotopy pushout,
  675. -- which can be seen as a kind of sum B + C with the extra condition that
  676. -- whenever x and y are in the image of f (resp. g), inl x ≡ inr y.
  677. data Pushout {A : Type} {B : Type} {C : Type} (f : A -> B) (g : A -> C) : Type where
  678. inl : (x : B) -> Pushout f g
  679. inr : (y : C) -> Pushout f g
  680. push i : (a : A) -> Pushout f g [ (i = i0) -> inl (f a), (i = i1) -> inr (g a) ]
  681. -- The name is due to the category-theoretical notion of pushout.
  682. -- TODO: finish writing this tomorrow lol
  683. data Susp (A : Type) : Type where
  684. north : Susp A
  685. south : Susp A
  686. merid i : A -> Susp A [ (i = i0) -> north, (i = i1) -> south ]
  687. data Unit : Type where
  688. tt : Unit
  689. poSusp : Type -> Type
  690. poSusp A = Pushout {A} {Unit} {Unit} (\x -> tt) (\x -> tt)
  691. poSusp_to_Susp : {A : Type} -> poSusp A -> Susp A
  692. poSusp_to_Susp = \case
  693. inl x -> north
  694. inr x -> south
  695. push x i -> merid x i
  696. Susp_to_poSusp : {A : Type} -> Susp A -> poSusp A
  697. Susp_to_poSusp = \case
  698. north -> inl tt
  699. south -> inr tt
  700. merid x i -> push x i
  701. Susp_to_poSusp_to_Susp : {A : Type} -> (x : Susp A) -> Path (poSusp_to_Susp (Susp_to_poSusp x)) x
  702. Susp_to_poSusp_to_Susp = \case
  703. north -> refl
  704. south -> refl
  705. merid x i -> refl
  706. unitEta : (x : Unit) -> Path x tt
  707. unitEta = \case tt -> refl
  708. poSusp_to_Susp_to_poSusp : {A : Type} -> (x : poSusp A) -> Path (Susp_to_poSusp (poSusp_to_Susp x)) x
  709. poSusp_to_Susp_to_poSusp {A} = \case
  710. inl x -> cong inl (sym (unitEta x))
  711. inr x -> cong inr (sym (unitEta x))
  712. push x i -> refl
  713. Susp_is_poSusp : {A : Type} -> Path (Susp A) (poSusp A)
  714. 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}))