├── .gitattributes ├── .gitignore ├── CNAME ├── LEAN.md ├── LICENSE ├── README.md ├── agda ├── Hopf.agda └── src │ └── Mahlo.agda ├── axio.html ├── cubicaltt ├── .travis.yml ├── HOPF.md ├── LICENSE ├── README.md ├── doc │ └── ctt.syntax └── src │ ├── adj.ctt │ ├── algebra.ctt │ ├── bishop.ctt │ ├── bool.ctt │ ├── bool_theory.ctt │ ├── buddhism.ctt │ ├── bundle.ctt │ ├── cat.ctt │ ├── category.ctt │ ├── coeq.ctt │ ├── complex.ctt │ ├── cones.ctt │ ├── control.ctt │ ├── csystem.ctt │ ├── cw.ctt │ ├── cwf.ctt │ ├── em.ctt │ ├── eq.ctt │ ├── equiv.ctt │ ├── eqv.ctt │ ├── etale.ctt │ ├── fun.ctt │ ├── functor.ctt │ ├── hedberg.ctt │ ├── helix.ctt │ ├── homology.ctt │ ├── homotopy.ctt │ ├── hopf.ctt │ ├── hubspokes.ctt │ ├── hvec.ctt │ ├── impredicative.ctt │ ├── infinitesimal.ctt │ ├── infinity.ctt │ ├── int.ctt │ ├── interval.ctt │ ├── iso.ctt │ ├── iso_pi.ctt │ ├── iso_sigma.ctt │ ├── join.ctt │ ├── k_theory.ctt │ ├── lambek.ctt │ ├── list.ctt │ ├── list_theory.ctt │ ├── localization.ctt │ ├── logic.ctt │ ├── manifold.ctt │ ├── maybe.ctt │ ├── maybe_nat.ctt │ ├── maybe_theory.ctt │ ├── mltt.ctt │ ├── modality.ctt │ ├── model.htt │ ├── nat.ctt │ ├── nat_theory.ctt │ ├── null.ctt │ ├── ordinal.ctt │ ├── path.ctt │ ├── pi.ctt │ ├── pointed.ctt │ ├── process.ctt │ ├── prop.ctt │ ├── proto.ctt │ ├── pullback.ctt │ ├── pushout.ctt │ ├── quot.ctt │ ├── quotient.ctt │ ├── real.ctt │ ├── recursion.ctt │ ├── retract.ctt │ ├── s1.ctt │ ├── s2.ctt │ ├── seq.ctt │ ├── set.ctt │ ├── sigma.ctt │ ├── sip.ctt │ ├── stream.ctt │ ├── stream_theory.ctt │ ├── subtype.ctt │ ├── suspension.ctt │ ├── swaptrans.ctt │ ├── topos.ctt │ ├── trunc.ctt │ ├── ump.ctt │ ├── univ.ctt │ └── vector.ctt ├── doc ├── bsc.pdf ├── bsc.tex ├── msc.pdf ├── msc.tex └── pl1.pdf ├── footer.pug ├── framework.js ├── header.pug ├── index.html ├── index.pug ├── main.css ├── package.json └── theorems └── Fermat's Last Theorem.md /.gitattributes: -------------------------------------------------------------------------------- 1 | *.js linguist-detectable=false 2 | *.css linguist-detectable=false 3 | *.scss linguist-detectable=false 4 | *.tex linguist-detectable=false 5 | *.sh linguist-detectable=false 6 | *.html linguist-detectable=false 7 | *.htm linguist-detectable=false 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | node_modules/* 2 | package-lock.json 3 | header.html 4 | footer.html 5 | *.aux 6 | *.bbl 7 | *.blg 8 | *.log 9 | *.out 10 | *.toc 11 | -------------------------------------------------------------------------------- /CNAME: -------------------------------------------------------------------------------- 1 | axio.groupoid.space -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | DHARMA License 2 | 3 | Copyright (c) 2016—2022 Groupoid Infinity 4 | 5 | Permission to use, copy, modify, and/or distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | YOU CANNOT USE THIS SOFTWARE IN ANY (PROVABLE BY MONEY TRACE) 10 | PROCESS CHAIN OF EXTERMINATING UKRAINIANS BY ANY MEANS OF FASCIST 11 | ACTIONS AGAINST OUR TERRITORIAL INTEGRITY, CULTURAL DIVERSITY BY 12 | APPLYING MILITARY INVASIONS, ECONOMICAL WARS, HUMANITARIAN DISASTERS, 13 | ARTFICIAL HOLODOMORS, GENOCIDE, RAPING, LOOTING, ROBBERIES, SPREADING 14 | FAKE INFORMATION, AND OTHER CONTEMPORARY WEAPONS OF WAR AT SCALE 15 | OR IN INVIDIVUAL MANNER. 16 | 17 | YOU CANNOT USE THIS SOFTWARE BY ANY MEANS IN INTEREST OF LEGAL 18 | ENTITIES OR INDIVIDUALS WHO IS SUPPORTING NOW OR WAS SUPPORTING 19 | BACK THEN FASCISM, RUSCISM, COMMUNISM, CHAUVINISM, HUMILIATION, 20 | AND OTHER SUPPRESSIVE IDEOLOGIES IN DIFFERENT EXPRESSIONS. 21 | 22 | STOP KILLING UKRAINIANS, 23 | THE COUNTER RENDERS TENS OF MILLIONS. 24 | 25 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 26 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 27 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 28 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 29 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 30 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 31 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 32 | -------------------------------------------------------------------------------- /agda/Hopf.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --cubical --safe #-} 2 | 3 | module Hopf where 4 | 5 | open import Cubical.Core.Everything 6 | open import Cubical.Foundations.Prelude 7 | 8 | -- S¹: Circle 9 | data S¹ : Set where 10 | base : S¹ 11 | loop : base ≡ base 12 | 13 | -- S²: 2-Sphere 14 | data S² : Set where 15 | base : S² 16 | surf : PathP (λ i → base ≡ base) refl refl 17 | 18 | -- S³: 3-Sphere (simplified with a point and a 3D generator) 19 | data S³ : Set where 20 | base : S³ 21 | loop3 : PathP (λ i → PathP (λ j → base ≡ base) refl refl) refl refl 22 | 23 | -- S⁴: 4-Sphere 24 | data S⁴ : Set where 25 | base : S⁴ 26 | surf4 : PathP (λ i → PathP (λ j → PathP (λ k → base ≡ base) refl refl) refl refl) refl refl 27 | 28 | -- H₁: Hopf fibration total space (S³) 29 | data H₁ : Set where 30 | h₁ : S² → S¹ → H₁ 31 | twist₁ : (b : S²) (f : S¹) → h₁ b f ≡ h₁ b f 32 | twist₁-coh : (b : S²) → twist₁ b base ≡ λ j → h₁ b (loop j) 33 | 34 | loop3-path : (i j : I) → S³ 35 | loop3-path i j = loop3 i j j 36 | 37 | -- H₂: Complex Hopf fibration total space (S⁷) 38 | data H₂ : Set where 39 | h₂ : S⁴ → S³ → H₂ 40 | twist₂ : (b : S⁴) (f : S³) → h₂ b f ≡ h₂ b f 41 | twist₂-coh : (b : S⁴) → Square (twist₂ b base) (twist₂ b base) refl (λ j → h₂ b (loop3-path i1 j)) 42 | 43 | -- Projection 44 | π₁ : H₁ → S² 45 | π₁ (h₁ b f) = b 46 | π₁ (twist₁ b f i) = b 47 | π₁ (twist₁-coh b i j) = b 48 | 49 | -- Projection 50 | π₂ : H₂ → S⁴ 51 | π₂ (h₂ b f) = b 52 | π₂ (twist₂ b f i) = b 53 | π₂ (twist₂-coh b i j) = b 54 | 55 | -- Hopf path in H₁ 56 | hopf-path : h₁ base base ≡ h₁ base base 57 | hopf-path = twist₁ base base 58 | 59 | -- Projected loop in S² 60 | hopf-loop : base ≡ base 61 | hopf-loop = cong π₁ hopf-path 62 | 63 | -- Hopf path in H₂ (1D path over S³’s loop) 64 | hopf-path-2 : h₂ base base ≡ h₂ base base 65 | hopf-path-2 = twist₂ base base 66 | 67 | -- Element of π₂(S²) using S²’s surf 68 | π₂-s₂-elem : PathP (λ i → base ≡ base) refl refl 69 | π₂-s₂-elem = surf 70 | 71 | record Real-Hopf-Fib-Rules : Set where 72 | -- Formation: Fib₁ is a type family over S² 73 | field 74 | Fib₁ : S² → Set 75 | 76 | -- Introduction Rules (Constructors for the fiber) 77 | field 78 | fib₁-intro : (b : S²) → S¹ → Fib₁ b 79 | twist₁-fib : (b : S²) (f : S¹) → fib₁-intro b f ≡ fib₁-intro b f 80 | twist₁-coh-fib : (b : S²) (i : I) → twist₁-fib b base i ≡ fib₁-intro b (loop i) 81 | 82 | -- Elimination Rule (Dependent elimination over the fibration) 83 | field 84 | Fib₁-elim : {C : (b : S²) → Fib₁ b → Set} 85 | → (c-h₁ : (b : S²) (f : S¹) → C b (fib₁-intro b f)) 86 | → (c-twist₁ : (b : S²) (f : S¹) → PathP (λ i → C b (twist₁-fib b f i)) (c-h₁ b f) (c-h₁ b f)) 87 | → (c-twist₁-coh : (b : S²) → PathP (λ i → C b (fib₁-intro b (loop i))) (c-h₁ b base) (c-h₁ b (loop i1))) 88 | → (b : S²) (x : Fib₁ b) → C b x 89 | 90 | -- Computation Rules 91 | field 92 | Fib₁-comp : {C : (b : S²) → Fib₁ b → Set} 93 | → (c-h₁ : (b : S²) (f : S¹) → C b (fib₁-intro b f)) 94 | → (c-twist₁ : (b : S²) (f : S¹) → PathP (λ i → C b (twist₁-fib b f i)) (c-h₁ b f) (c-h₁ b f)) 95 | → (c-twist₁-coh : (b : S²) → PathP (λ i → C b (fib₁-intro b (loop i))) (c-h₁ b base) (c-h₁ b (loop i1))) 96 | → (b : S²) (f : S¹) 97 | → Fib₁-elim c-h₁ c-twist₁ c-twist₁-coh b (fib₁-intro b f) ≡ c-h₁ b f 98 | -------------------------------------------------------------------------------- /agda/src/Mahlo.agda: -------------------------------------------------------------------------------- 1 | open import Agda.Primitive 2 | 3 | mutual 4 | data V : Set₁ where 5 | pi_ : (x : V) → (Elv x → V) → V 6 | uni_ : (f : (x : V) → (Elv x → V) → V) 7 | (g : (x : V) → (y : Elv x → V) → (Elv (f x y) → V) → V) → V 8 | 9 | Elv : V → Set₁ -- Changed from Set to Set₁ 10 | Elv (pi_ a b) = (x : Elv a) → Elv (b x) 11 | Elv (uni_ f g) = Universe f g 12 | 13 | data Universe (F : (x : V) → (Elv x → V) → V) (G : (x : V) → (y : Elv x → V) → (Elv (F x y) → V) → V) 14 | : Set₁ where -- Changed to Set₁ 15 | fun_ : (x : Universe F G) → (V → Universe F G) → Universe F G 16 | f_ : (x : Universe F G) → (V → Universe F G) → Universe F G 17 | g_ : (x : Universe F G) (y : Elv (Elt F G x) → V) 18 | (z : Elv (F (Elt F G x) (λ (a : Elv (Elt F G x)) → y a))) → Universe F G 19 | 20 | data Elt (f : (x : V) → (Elv x → V) → V) (g : (x : V) → (y : Elv x → V) → (Elv (f x y) → V) → V) 21 | : Universe f g → Set₁ where -- Changed to Set₁ 22 | elt : {u : Universe f g} → V → Elt f g u 23 | -------------------------------------------------------------------------------- /cubicaltt/.travis.yml: -------------------------------------------------------------------------------- 1 | language: generic 2 | 3 | notifications: 4 | email: 5 | - maxim@synrc.com 6 | webhooks: 7 | on_success: change 8 | on_failure: change 9 | on_start: always 10 | 11 | cache: 12 | directories: 13 | - $HOME/.stack 14 | 15 | addons: 16 | apt: 17 | packages: 18 | - libgmp-dev 19 | 20 | before_install: 21 | - mkdir -p ~/.local/bin 22 | - export PATH=$HOME/.local/bin:$PATH 23 | - ARCH=https://www.stackage.org/stack/linux-x86_64 24 | - travis_retry curl -L $ARCH | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 25 | 26 | install: 27 | - git clone git://github.com/mortberg/cubicaltt && cd cubicaltt 28 | - stack build 29 | - CUBICAL=$(stack path --local-install-root)/bin/cubical 30 | - cd .. 31 | - for i in src/*.ctt; do $CUBICAL -b $i; done 32 | -------------------------------------------------------------------------------- /cubicaltt/HOPF.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/groupoid/hopf.svg?branch=master)](https://travis-ci.org/groupoid/hopf) 2 | 3 | Groupoid Infinity 4 | ================= 5 | 6 | The Groupoid Infinity Cubical Base Library is compatible with `hcomptrans` branch of `cubicaltt` that fully supports recursive HITs. As example Hopf fibration is given formally due to Guillaume Brunerie: 7 | 8 | ``` 9 | rot: (x : S1) -> Path S1 x x = split 10 | base -> loop1 11 | loop @ i -> constSquare S1 base loop1 @ i 12 | 13 | mu : S1 -> equiv S1 S1 = split 14 | base -> idEquiv S1 15 | loop @ i -> equivPath S1 S1 (idEquiv S1) 16 | (idEquiv S1) ( \(x : S1) -> rot x @ j) @ i 17 | 18 | H : S2 -> U = split 19 | north -> S1 20 | south -> S1 21 | merid x @ i -> ua S1 S1 (mu x) @ i 22 | 23 | total : U = (c : S2) * H c 24 | ``` 25 | 26 | Credits 27 | ------- 28 | 29 | * Maxim Sokhatsky 30 | 31 | -------------------------------------------------------------------------------- /cubicaltt/LICENSE: -------------------------------------------------------------------------------- 1 | DHARMA License 2 | 3 | Copyright (c) 2016—2022 Groupoid Infinity 4 | 5 | Permission to use, copy, modify, and/or distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | YOU CANNOT USE THIS SOFTWARE IN ANY (PROVABLE BY MONEY TRACE) 10 | PROCESS CHAIN OF EXTERMINATING UKRAINIANS BY ANY MEANS OF FASCIST 11 | ACTIONS AGAINST OUR TERRITORIAL INTEGRITY, CULTURAL DIVERSITY BY 12 | APPLYING MILITARY INVASIONS, ECONOMICAL WARS, HUMANITARIAN DISASTERS, 13 | ARTFICIAL HOLODOMORS, GENOCIDE, RAPING, LOOTING, ROBBERIES, SPREADING 14 | FAKE INFORMATION, AND OTHER CONTEMPORARY WEAPONS OF WAR AT SCALE 15 | OR IN INVIDIVUAL MANNER. 16 | 17 | YOU CANNOT USE THIS SOFTWARE BY ANY MEANS IN INTEREST OF LEGAL 18 | ENTITIES OR INDIVIDUALS WHO IS SUPPORTING NOW OR WAS SUPPORTING 19 | BACK THEN FASCISM, RUSCISM, COMMUNISM, CHAUVINISM, HUMILIATION, 20 | AND OTHER SUPPRESSIVE IDEOLOGIES IN DIFFERENT EXPRESSIONS. 21 | 22 | STOP KILLING UKRAINIANS, 23 | THE COUNTER RENDERS TENS OF MILLIONS. 24 | 25 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 26 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 27 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 28 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 29 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 30 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 31 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 32 | -------------------------------------------------------------------------------- /cubicaltt/README.md: -------------------------------------------------------------------------------- 1 | CCHM 2 | ==== 3 | 4 | The Groupoid Infinity CCHM cubical base library 5 | is dedicated to [cubical](https://github.com/mortberg/cubicaltt)-compatible 6 | type checkers based on homotopy interval [0,1] and MLTT as a core. 7 | The library follows HoTT foundation and mathematics partitioning: the `Foundations` 8 | chapter covers the very basics of the cubical programming language; the `Mathematics` 9 | chapter covers the formal mathematics library of models and theorems. 10 | This library is best to read with HoTT book at http://groupoid.space/misc/library/ 11 | 12 | -------------------------------------------------------------------------------- /cubicaltt/doc/ctt.syntax: -------------------------------------------------------------------------------- 1 | # Cubical Syntax for Midnight Commander 2 | 3 | context default 4 | keyword whole Pi white 5 | keyword whole lam white 6 | keyword whole app white 7 | keyword whole ap white 8 | keyword whole fiber white 9 | keyword whole subst white 10 | keyword whole contr white 11 | keyword whole inv white 12 | keyword whole isContr white 13 | keyword whole transport white 14 | keyword whole cong white 15 | keyword whole Sigma white 16 | keyword whole pi1 white 17 | keyword whole pi2 white 18 | keyword whole pr1 white 19 | keyword whole pr2 white 20 | keyword whole fst white 21 | keyword whole snd white 22 | keyword whole funext white 23 | keyword whole happly white 24 | keyword whole Path white 25 | keyword whole PathP white 26 | keyword whole J white 27 | keyword whole refl white 28 | keyword whole sym white 29 | keyword whole trans white 30 | keyword whole isSet white 31 | keyword whole isProp white 32 | keyword whole isGroupoid white 33 | keyword whole propQuot white 34 | keyword whole setQuot white 35 | keyword whole grpdQuot white 36 | keyword whole propTrunc white 37 | keyword whole setTrunc white 38 | keyword whole grpdTrunc white 39 | keyword whole diff white 40 | keyword whole conjugate white 41 | keyword whole empty white 42 | keyword whole unit white 43 | keyword whole data cyan 44 | keyword whole split cyan 45 | keyword whole opaque cyan 46 | keyword whole import cyan 47 | keyword whole module cyan 48 | keyword whole where cyan 49 | keyword .1 cyan 50 | keyword .2 cyan 51 | keyword whole comp cyan 52 | keyword whole fill cyan 53 | keyword > cyan 54 | keyword < cyan 55 | keyword * cyan 56 | keyword | cyan 57 | keyword - cyan 58 | keyword whole /\\ cyan 59 | keyword whole \\/ cyan 60 | keyword @ cyan 61 | keyword = cyan 62 | keyword [ cyan 63 | keyword ] cyan 64 | keyword ( cyan 65 | keyword ) cyan 66 | keyword { cyan 67 | keyword } cyan 68 | keyword , cyan 69 | keyword : cyan 70 | keyword ; cyan 71 | 72 | context exclusive -- \n brightred 73 | context exclusive {- -} brightred 74 | 75 | # context exclusive -- \n yellow 76 | # context exclusive {- -} yellow 77 | -------------------------------------------------------------------------------- /cubicaltt/src/adj.ctt: -------------------------------------------------------------------------------- 1 | {- Category Theory: 2 | - Natural Transformations; 3 | - Kan Extensions; 4 | - Limits; 5 | - Adjunctions. 6 | Copyright (c) Groupoid Infinity, 2017-2018. 7 | 8 | HoTT 9.3 Adjunctions. -} 9 | 10 | module adj where 11 | import cat 12 | import fun 13 | 14 | unitCat: precategory = ((Ob,Hom),id,c,HomSet,L,R,Q) where 15 | Ob: U = unit 16 | Hom (A B: Ob): U = unit 17 | id (A: Ob): Hom A A = tt 18 | c (A B C: Ob) (f: Hom A B) (g: Hom B C): Hom A C = tt 19 | HomSet (A B: Ob): isSet (Hom A B) = setUnit 20 | L (A B: Ob): (f: unit) -> Path unit (c A A B (id A) f) f = split tt -> tt 21 | R (A B: Ob): (f: unit) -> Path unit (c A B B f (id B)) f = split tt -> tt 22 | Q (A B C D: Ob) (f: Hom A B) (g: Hom B C) (h: Hom C D) 23 | : Path (Hom A D) (c A C D (c A B C f g) h) (c A B D f (c B C D g h)) = refl unit tt 24 | 25 | isNaturalTrans (C D: precategory) 26 | (F G: catfunctor C D) 27 | (eta: (x: carrier C) -> hom D (F.1 x) (G.1 x)): U 28 | = (x y: carrier C) (h: hom C x y) -> 29 | Path (hom D (F.1 x) (G.1 y)) 30 | (compose D (F.1 x) (F.1 y) (G.1 y) (F.2.1 x y h) (eta y)) 31 | (compose D (F.1 x) (G.1 x) (G.1 y) (eta x) (G.2.1 x y h)) 32 | 33 | -- Awodey CT 7.6. Natural transformation 34 | -- Natural Transformation 35 | ntrans (C D: precategory) (F G: catfunctor C D): U 36 | = (eta: (x: carrier C) -> hom D (F.1 x) (G.1 x)) 37 | * (isNaturalTrans C D F G eta) 38 | 39 | -- Kan Extensions 40 | extension (A B C: precategory) (K: catfunctor A B) (G: catfunctor A C) : U 41 | = (F: catfunctor B C) 42 | * (counit: ntrans A C (compFunctor A B C K F) G) 43 | * unit 44 | 45 | -- Functor to Unit Category 46 | unitFunc (C: precategory): catfunctor C unitCat 47 | = undefined 48 | 49 | -- Cone as Kan Extension 50 | cone (J C: precategory) (D: catfunctor J C): U 51 | = extension J unitCat C (unitFunc J) D 52 | 53 | -- universality of Kan Extension 54 | universality (A B C: precategory) 55 | (K: catfunctor A B) (G: catfunctor A C) 56 | (s t: extension A B C K G) : U 57 | = undefined 58 | 59 | -- Right Kan Extension 60 | ran (A B C: precategory) (K: catfunctor A B) (G: catfunctor A C) : U 61 | = (x: extension A B C K G) * ((y: extension A B C K G) 62 | -> isContr (universality A B C K G x y)) 63 | 64 | -- Limit 65 | limit (J C: precategory) (D: catfunctor J C): U 66 | = ran J unitCat C (unitFunc J) D 67 | 68 | -- ExtUniv : Extension K G → Set _ 69 | -- ExtUniv (extension S (nt α _)) = Σ (S ⇒ F) λ { (nt β _) → (∀ X → ε X ∘ β (apply K X) ≡ α X) } 70 | 71 | ntransL (C D: precategory) (F G: catfunctor C D) (f: ntrans C D F G) (B: precategory) (H: catfunctor B C) 72 | : ntrans B D (compFunctor B C D H F) (compFunctor B C D H G) 73 | = (eta, p) where 74 | F': catfunctor B D = compFunctor B C D H F 75 | G': catfunctor B D = compFunctor B C D H G 76 | eta (x: carrier B): hom D (F'.1 x) (G'.1 x) = f.1 (H.1 x) 77 | p (x y: carrier B) (h: hom B x y): Path (hom D (F'.1 x) (G'.1 y)) 78 | (compose D (F'.1 x) (F'.1 y) (G'.1 y) (F'.2.1 x y h) (eta y)) 79 | (compose D (F'.1 x) (G'.1 x) (G'.1 y) (eta x) (G'.2.1 x y h)) 80 | = f.2 (H.1 x) (H.1 y) (H.2.1 x y h) 81 | 82 | ntransR (C D: precategory) (F G: catfunctor C D) (f: ntrans C D F G) (E: precategory) (H: catfunctor D E) 83 | : ntrans C E (compFunctor C D E F H) (compFunctor C D E G H) 84 | = (eta, p) where 85 | F': catfunctor C E = compFunctor C D E F H 86 | G': catfunctor C E = compFunctor C D E G H 87 | eta (x: carrier C): hom E (F'.1 x) (G'.1 x) = H.2.1 (F.1 x) (G.1 x) (f.1 x) 88 | p (x y: carrier C) (h: hom C x y): Path (hom E (F'.1 x) (G'.1 y)) 89 | (compose E (F'.1 x) (F'.1 y) (G'.1 y) (F'.2.1 x y h) (eta y)) 90 | (compose E (F'.1 x) (G'.1 x) (G'.1 y) (eta x) (G'.2.1 x y h)) 91 | = comp (<_> hom E (F'.1 x) (G'.1 y)) (H.2.1 (F.1 x) (G.1 y) (f.2 x y h @ i)) 92 | [ (i = 0) -> H.2.2.2 (F.1 x) (F.1 y) (G.1 y) (F.2.1 x y h) (f.1 y), 93 | (i = 1) -> H.2.2.2 (F.1 x) (G.1 x) (G.1 y) (f.1 x) (G.2.1 x y h) ] 94 | 95 | hom3 (C D: precategory) 96 | (F: catfunctor C D) 97 | (G: catfunctor C D) 98 | (left: ntrans C D F G) 99 | (right: ntrans C D F G): U = undefined 100 | 101 | -- Adjointness Property 102 | -- NOTE: Adjunction is a special case of signature class of 3-morphisms 103 | areAdjoint (C D: precategory) 104 | (F: catfunctor D C) 105 | (G: catfunctor C D) 106 | (unit: ntrans D D (idFunctor D) (compFunctor D C D F G)) 107 | (counit: ntrans C C (compFunctor C D C G F) (idFunctor C)): U 108 | = prod ((x: carrier C) -> Path (hom D (G.1 x) (G.1 x)) (path D (G.1 x)) (h0 x)) 109 | ((x: carrier D) -> Path (hom C (F.1 x) (F.1 x)) (path C (F.1 x)) (h1 x)) where 110 | h0 (x: carrier C) : hom D (G.1 x) (G.1 x) = compose D (G.1 x) (G.1 (F.1 (G.1 x))) (G.1 x) 111 | ((ntransL D D (idFunctor D) (compFunctor D C D F G) unit C G).1 x) 112 | ((ntransR C C (compFunctor C D C G F) (idFunctor C) counit D G).1 x) 113 | h1 (x: carrier D) : hom C (F.1 x) (F.1 x) = compose C (F.1 x) (F.1 (G.1 (F.1 x))) (F.1 x) 114 | ((ntransR D D (idFunctor D) (compFunctor D C D F G) unit C F).1 x) 115 | ((ntransL C C (compFunctor C D C G F) (idFunctor C) counit D F).1 x) 116 | 117 | -- Adjoint of two Natural Transformations 118 | adjoint (C D: precategory) (F: catfunctor D C) (G: catfunctor C D): U 119 | = (unit: ntrans D D (idFunctor D) (compFunctor D C D F G)) 120 | * (counit: ntrans C C (compFunctor C D C G F) (idFunctor C)) 121 | * areAdjoint C D F G unit counit 122 | 123 | -------------------------------------------------------------------------------- /cubicaltt/src/bishop.ctt: -------------------------------------------------------------------------------- 1 | {- Bishop Equivalence: 2 | - Equivalence Classes. 3 | Copyright (c) Groupoid Infinity, 2017-2018. -} 4 | 5 | module bishop where 6 | import proto 7 | import subtype 8 | import path 9 | 10 | -- Propositional Equality By Errett Bishop 11 | hrel (X: U): U = X -> X -> PROP 12 | isrefl (X: U) (R: hrel X): U = (x: X) -> (R x x).1 13 | issymm (X: U) (R: hrel X): U = (x1 x2: X) -> (R x1 x2).1 -> (R x2 x1).1 14 | istrans (X: U) (R: hrel X): U = (x1 x2 x3: X) -> (R x1 x2).1 -> (R x2 x3).1 -> (R x1 x3).1 15 | ispreorder (X: U) (R: hrel X): U = prod (istrans X R) (isrefl X R) 16 | iseqrel (X: U) (R: hrel X): U = prod (ispreorder X R) (issymm X R) 17 | eqrel (X: U) : U = (R: hrel X) * (iseqrel X R) 18 | eqrelrefl (X: U) (R: eqrel X): isrefl X R.1 = R.2.1.2 19 | eqrelsymm (X: U) (R: eqrel X): issymm X R.1 = R.2.2 20 | eqreltrans (X: U) (R: eqrel X): istrans X R.1 = R.2.1.1 21 | 22 | iseqrelpair (A B: U) (R0: hrel A) (R1: hrel B) (E0: iseqrel A R0) (E1: iseqrel B R1): iseqrel (prod A B) (hrelpair A B R0 R1) 23 | = ((tax, rax), sax) where 24 | T : U = prod A B 25 | R : hrel T = hrelpair A B R0 R1 26 | rax : isrefl T R = \ (t0 : T) -> (E0.1.2 t0.1, E1.1.2 t0.2) 27 | sax : issymm T R = \ (t0 t1 : T) (e : (R t0 t1).1) -> (E0.2 t0.1 t1.1 e.1, E1.2 t0.2 t1.2 e.2) 28 | tax : istrans T R = \ (t0 t1 t2 : T) (e0 : (R t0 t1).1) (e1 : (R t1 t2).1) -> 29 | (E0.1.1 t0.1 t1.1 t2.1 e0.1 e1.1, E1.1.1 t0.2 t1.2 t2.2 e0.2 e1.2) 30 | 31 | eqrelpair (A B : U) (R0 : eqrel A) (R1 : eqrel B) : eqrel (prod A B) 32 | = (hrelpair A B R0.1 R1.1, iseqrelpair A B R0.1 R1.1 R0.2 R1.2) 33 | 34 | iseqclasspair (A B : U) (R0 : hrel A) (R1 : hrel B) (H0 : hsubtypes A) 35 | (H1 : hsubtypes B) (E0 : iseqclass A R0 H0) (E1 : iseqclass B R1 H1) 36 | : iseqclass (prod A B) (hrelpair A B R0 R1) (hsubtypespair A B H0 H1) 37 | = let 38 | H : hsubtypes (prod A B) = hsubtypespair A B H0 H1 39 | a (P : PROP) (f : carr (prod A B) H -> P.1) : P.1 40 | = let 41 | g (x0 : carr A H0) : P.1 = let h (x1 : carr B H1) : P.1 = f ((x0.1, x1.1), (x0.2, x1.2)) in E1.1.1 P h 42 | in E0.1.1 P g 43 | b (x0 x1 : prod A B) (r : (hrelpair A B R0 R1 x0 x1).1) (h0 : (H x0).1) : (H x1).1 44 | = (E0.1.2 x0.1 x1.1 r.1 h0.1, E1.1.2 x0.2 x1.2 r.2 h0.2) 45 | c (x0 x1 : prod A B) (h0 : (H x0).1) (h1 : (H x1).1) : (hrelpair A B R0 R1 x0 x1).1 46 | = (E0.2 x0.1 x1.1 h0.1 h1.1, E1.2 x0.2 x1.2 h0.2 h1.2) 47 | in ((a, b), c) 48 | -------------------------------------------------------------------------------- /cubicaltt/src/bool.ctt: -------------------------------------------------------------------------------- 1 | {- Run-time Bool Type: 2 | - Bool type. 3 | - Theorems are in bool_theory module. 4 | Copyright (c) Groupoid Infinity, 2014-2018. 5 | 6 | HoTT 1.8 The type of booleans -} 7 | 8 | module bool where 9 | import proto 10 | 11 | data bool = false | true 12 | 13 | negation: bool -> bool = split { false -> true ; true -> false } 14 | or: bool -> bool -> bool = split { false -> idfun bool ; true -> lambda bool bool true } 15 | and: bool -> bool -> bool = split { false -> lambda bool bool false ; true -> idfun bool } 16 | 17 | boolEq: bool -> bool -> bool = lambda bool (bool -> bool) negation 18 | boolRec (A: U) (f t: A): bool -> A = split { false -> f ; true -> t } 19 | boolInd (A:bool->U) (f:A false) (t: A true): (n:bool) -> A n = split { false -> f ; true -> t } 20 | -------------------------------------------------------------------------------- /cubicaltt/src/buddhism.ctt: -------------------------------------------------------------------------------- 1 | module buddhism where 2 | import path 3 | 4 | -- from Favonia's PhD 5 | 6 | concept (o: U): U = o -> U 7 | allpaths (o: U): U = (x y: o) -> Path o x y 8 | nondual (o: U) (p: concept o): U = (x y: o) -> Path U (p x) (p y) 9 | 10 | encode (o:U): ((p: concept o) -> nondual o p) -> allpaths o 11 | = \(nd: (p: concept o) -> nondual o p) (a b: o) 12 | -> coerce (Path o a a) (Path o a b) (nd (\(z:o)->Path o a z) a b) (refl o a) 13 | 14 | decode (o:U): allpaths o -> ((p: concept o) -> nondual o p) 15 | = \(all: allpaths o)(p: concept o)(x y: o) -> cong o U p x y (all x y) 16 | -------------------------------------------------------------------------------- /cubicaltt/src/bundle.ctt: -------------------------------------------------------------------------------- 1 | {- Fiber Bundle: https://groupoid.space/mltt/types/bundle/ 2 | - Fiber Bundle; 3 | - Trivial Fiber Bundle, Trivial = Pi; 4 | - Local F-Bundle (4 definitions). 5 | Copyright (c) Groupoid Infinity, 2014-2018. -} 6 | 7 | module bundle where 8 | import iso 9 | import infinitesimal 10 | import pullback 11 | import trunc 12 | 13 | -- Fiber Bundle 14 | 15 | -- A fiber bundle p : E -> B is required to be locally trivial, 16 | -- which might be witnessed by a pullback square like this: 17 | 18 | -- V × F ------> E 19 | -- |_| | 20 | -- v*p | (pb) | p 21 | -- | | 22 | -- v v 23 | -- V ---v--> B 24 | 25 | -- NOTE: there is twisted hidden structure in p 26 | -- U = neighborhood in base B 27 | -- fibers locally behave like a products, but could be twisted 28 | 29 | -- h 30 | -- | 31 | -- p-inv (V) -> V * F 32 | -- | / 33 | -- p --| /-- pi1 34 | -- v / 35 | -- V 36 | -- 37 | -- pr_1 o h = p 38 | 39 | -- F_B -> E -> B -- fiber bundle (F_B,E,p,B), 40 | -- F: B -> U -- fiber, ex. Vector Space, Section Space, Dependent Product 41 | -- E -- total topological space 42 | -- B -- base space 43 | -- h: F -> E -- homeomorphism 44 | -- p: E -> B -- surjective projection map 45 | -- p^-1: B -> E -- section (y: B) = (x: E) * p (x) = y 46 | -- E=(y:B)*p^-1 y -- total space 47 | -- p^-1 = F -- fiber is iso F_B 48 | -- T. E = B * F_B -- fiber bundle called trivial if total space is a cartesian product 49 | 50 | Family (B: U): U = B -> U 51 | Fibration (B: U): U = (X: U) * (X -> B) 52 | 53 | -- Trivial Fiber Bundle (F,B*F,pi1,B) equals Dependent Family F:B->U 54 | -- 55 | -- Agda Syntax: 56 | -- https://paolocapriotti.com/blog/2013/02/20/families-and-fibrations/ 57 | -- 58 | -- F y = fiber (total B F) B (trivial B F) y (A) 59 | -- = (z: E) * Path B z.1 y 60 | -- = (z: B) * (k: F z) * Path B z y (B) 61 | -- = (x y: B) * (_: Path B x y) * (F y) 62 | -- = (_: isContr B) * (F y) (C) 63 | -- = F y (D) 64 | 65 | fiber (A B: U) (f: A -> B) (y: B) 66 | : U 67 | = (x: A) * Path B (f x) y 68 | 69 | encode (B: U) (F: B -> U) (y: B) 70 | : fiber (Sigma B F) B (pi1 B F) y -> F y 71 | = \ (x: fiber (Sigma B F) B (pi1 B F) y) 72 | -> subst B F x.1.1 y x.2 x.1.2 73 | 74 | decode (B: U) (F: B -> U) (y: B) 75 | : F y -> fiber (Sigma B F) B (pi1 B F) y 76 | = \ (x: F y) -> ((y,x),refl B y) 77 | 78 | 79 | lem2 (B: U) (F: B -> U) (y: B) (x: F y) 80 | : Path (F y) (comp (F (refl B y @ i)) x []) x 81 | = comp (F (refl B y @ j/\i)) x [(j=1) -> x] 82 | 83 | lem3 (B: U) (F: B -> U) (y: B) (x: fiber (Sigma B F) B (pi1 B F) y) 84 | : Path (fiber (Sigma B F) B (pi1 B F) y) ((y,encode B F y x),refl B y) x 85 | = ((x.2 @ -i,comp ( F (x.2 @ -i /\ j)) 86 | x.1.2 [(i=1) -> <_> x.1.2 ]), x.2 @ -i \/ j) 87 | 88 | TrivialEqualsPi (B: U) (F: B -> U) (y: B) 89 | : Path U (fiber (Sigma B F) B (pi1 B F) y) (F y) 90 | = isoPath T A f g s t where 91 | T: U = fiber (Sigma B F) B (pi1 B F) y 92 | A: U = F y 93 | f: T -> A = encode B F y 94 | g: A -> T = decode B F y 95 | s (x: A): Path A (f (g x)) x = lem2 B F y x 96 | t (x: T): Path T (g (f x)) x = lem3 B F y x 97 | 98 | -- Local F-Bundle 99 | 100 | -- Definition (1) Dependent 101 | isFBundle1 (B: U) (p: B -> U) (F: U): U 102 | = (_: (b: B) -> isContr (Path U (p b) F)) 103 | * ((x: Sigma B p) -> B) 104 | 105 | -- Definition (2) Dependent 106 | isFBundle2 (B: U) (p: B -> U) (F: U): U 107 | = (V: U) 108 | * (v: surjective V B) 109 | * ((x: V) -> Path U (p (v.1 x)) F) 110 | 111 | -- Definition (3) Non-Dependent 112 | im1 (A B: U) (f: A -> B): U = (b: B) * propTrunc ((a:A) * Path B (f a) b) 113 | BAut (F: U): U = im1 unit U (\(x: unit) -> F) 114 | unitIm1 (A B: U) (f: A -> B): im1 A B f -> B = \(x: im1 A B f) -> x.1 115 | unitBAut (F: U): BAut F -> U = unitIm1 unit U (\(x: unit) -> F) 116 | isFBundle3 (E B: U) (p: E -> B) (F: U): U 117 | = (X: B -> BAut F) 118 | * (classify B (BAut F) (\(b: B) -> fiber E B p b) (unitBAut F) X) where 119 | classify (A' A: U) (E': A' -> U) (E: A -> U) (f: A' -> A): U 120 | = (x: A') -> Path U (E'(x)) (E(f(x))) 121 | 122 | -- Definition (4) Non-Dependent 123 | isFBundle4 (E B: U) (p: E -> B) (F: U): U 124 | = (V: U) 125 | * (v: surjective V B) 126 | * (v': prod V F -> E) 127 | * pullbackSq (prod V F) E V B p v.1 v' (\(x: prod V F) -> x.1) 128 | 129 | -- Theorem 4.3.7 130 | unifamOverBAut (F: U): U = (x: BAut F) * U 131 | FBundle (E B: U) (p: E -> B) (F: U) (x: isFBundle3 E B p F) (b: B) 132 | : pullbackSq E B (unifamOverBAut F) (BAut F) 133 | x.1 (\(x: unifamOverBAut F) -> x.1) 134 | p (\(y: E) -> (x.1 (p y),F)) 135 | = undefined 136 | 137 | -------------------------------------------------------------------------------- /cubicaltt/src/coeq.ctt: -------------------------------------------------------------------------------- 1 | module coeq where 2 | import nat 3 | 4 | data coeq (A B: U) (f g: A -> B) 5 | = inC (_: B) 6 | | glueC (a: A) [(i=0) -> inC (f a), (i=1) -> inC (g a) ] 7 | 8 | coequRec (A B C : U) (f g : A -> B) (h: B -> C) (y: (x : A) -> Path C (h (f x)) (h (g x))) 9 | : (z : coeq A B f g) -> C 10 | = split@((z : coeq A B f g) -> C) with { inC x -> h x ; glueC x @ i -> y x @ i } 11 | 12 | coequInd (A B : U) (f g : A -> B) (C : coeq A B f g -> U) (ix : (b : B) -> C (inC b)) 13 | (y: (x : A) -> PathP ( C (glueC {coeq A B f g} x @ i)) (ix (f x)) (ix (g x))) 14 | : (z : coeq A B f g) -> C z 15 | = split@((z : coeq A B f g) -> C z) with { inC x -> ix x ; glueC x @ i -> y x @ i } 16 | 17 | data coeqP (A B: U) (p : A -> (b1 b2: B) * (_: Path B b1 b2) * (Path B b1 b2)) 18 | = inP (b: B) 19 | | glueP (a:A) [(i=0) -> inP (((p a).2.2.1) @ 0), (i=1) -> inP (((p a).2.2.2) @ 1) ] 20 | 21 | data pushout (A B C: U) (f: A -> B) (g: A -> C) 22 | = inl (_: B) 23 | | inr (_: C) 24 | | push (a: A) [ (i=0) -> inl (f a), (i=1) -> inr (g a) ] 25 | 26 | data colimit (A : nat -> U) (f : (n : nat) -> A n -> A (succ n)) 27 | = inc (n : nat) (x: A n) 28 | | com (n : nat) (a: A n) [ (i=0) -> inc (succ n) (f n a), (i=1) -> inc n a] 29 | -------------------------------------------------------------------------------- /cubicaltt/src/complex.ctt: -------------------------------------------------------------------------------- 1 | {- Simplicial Comlexes: 2 | - Simple, Complex, Simplicial Set. 3 | Copyright (c) Groupoid Infinity, 2016-2018. -} 4 | 5 | module complex where 6 | -------------------------------------------------------------------------------- /cubicaltt/src/cones.ctt: -------------------------------------------------------------------------------- 1 | {- Category Theory: 2 | - Cones; 3 | - Pullbacks. 4 | Copyright (c) Groupoid Infinity, 2014-2018. -} 5 | 6 | module cones where 7 | import sip 8 | import set 9 | import algebra 10 | 11 | isCospanConeHomProp (C: precategory) (D: cospan C) (E1 E2: cospanCone C D) (h: hom C E1.1 E2.1) 12 | : isProp (isCospanConeHom C D E1 E2 h) 13 | = propAnd (Path (hom C E1.1 D.2.1.1) (compose C E1.1 E2.1 D.2.1.1 h E2.2.1) E1.2.1) 14 | (Path (hom C E1.1 D.2.2.1) (compose C E1.1 E2.1 D.2.2.1 h E2.2.2.1) E1.2.2.1) 15 | (homSet C E1.1 D.2.1.1 (compose C E1.1 E2.1 D.2.1.1 h E2.2.1) E1.2.1) 16 | (homSet C E1.1 D.2.2.1 (compose C E1.1 E2.1 D.2.2.1 h E2.2.2.1) E1.2.2.1) 17 | 18 | cospanConePath (C: precategory) (D: cospan C) (E: cospanCone C D) 19 | : cospanConeHom C D E E 20 | = (path C E.1, pathL C E.1 D.2.1.1 E.2.1, pathL C E.1 D.2.2.1 E.2.2.1) 21 | 22 | cospanConeComp (C: precategory) (D: cospan C) (X Y Z: cospanCone C D) 23 | (F: cospanConeHom C D X Y) (G: cospanConeHom C D Y Z) 24 | : cospanConeHom C D X Z 25 | = (compose C X.1 Y.1 Z.1 F.1 G.1, 26 | composition (hom C X.1 D.2.1.1) 27 | (compose C X.1 Z.1 D.2.1.1 (compose C X.1 Y.1 Z.1 F.1 G.1) Z.2.1) 28 | (compose C X.1 Y.1 D.2.1.1 F.1 (compose C Y.1 Z.1 D.2.1.1 G.1 Z.2.1)) 29 | X.2.1 30 | (pathC C X.1 Y.1 Z.1 D.2.1.1 F.1 G.1 Z.2.1) 31 | (composition (hom C X.1 D.2.1.1) 32 | (compose C X.1 Y.1 D.2.1.1 F.1 (compose C Y.1 Z.1 D.2.1.1 G.1 Z.2.1)) 33 | (compose C X.1 Y.1 D.2.1.1 F.1 Y.2.1) 34 | X.2.1 35 | ( compose C X.1 Y.1 D.2.1.1 F.1 (G.2.1 @ i)) 36 | F.2.1), 37 | composition (hom C X.1 D.2.2.1) 38 | (compose C X.1 Z.1 D.2.2.1 (compose C X.1 Y.1 Z.1 F.1 G.1) Z.2.2.1) 39 | (compose C X.1 Y.1 D.2.2.1 F.1 (compose C Y.1 Z.1 D.2.2.1 G.1 Z.2.2.1)) 40 | X.2.2.1 41 | (pathC C X.1 Y.1 Z.1 D.2.2.1 F.1 G.1 Z.2.2.1) 42 | (composition (hom C X.1 D.2.2.1) 43 | (compose C X.1 Y.1 D.2.2.1 F.1 (compose C Y.1 Z.1 D.2.2.1 G.1 Z.2.2.1)) 44 | (compose C X.1 Y.1 D.2.2.1 F.1 Y.2.2.1) 45 | X.2.2.1 46 | ( compose C X.1 Y.1 D.2.2.1 F.1 (G.2.2 @ i)) 47 | F.2.2)) 48 | 49 | 50 | isPullbackProp (C : precategory) (D : cospan C) (E : cospanCone C D) 51 | : isProp (isPullback C D E) 52 | = propPi (cospanCone C D) (\(h : cospanCone C D) -> isContr (cospanConeHom C D h E)) 53 | (\(h : cospanCone C D) -> propIsContr (cospanConeHom C D h E)) 54 | 55 | cospanConeStructure (C: precategory) (D: cospan C) 56 | : structure C 57 | = (hasCospanCone C D 58 | ,\(x y: carrier C) (a: hasCospanCone C D x) (b: hasCospanCone C D y) -> isCospanConeHom C D (x, a) (y, b) 59 | ,\(x y: carrier C) (a: hasCospanCone C D x) (b: hasCospanCone C D y) -> isCospanConeHomProp C D (x, a) (y, b) 60 | ,\(x: carrier C) (a: hasCospanCone C D x) -> (cospanConePath C D (x, a)).2 61 | ,\(x y z: carrier C) (a: hasCospanCone C D x) (b: hasCospanCone C D y) (c: hasCospanCone C D z) 62 | (f: hom C x y) (g: hom C y z) 63 | (Hf: isCospanConeHom C D (x, a) (y, b) f) 64 | (Hg: isCospanConeHom C D (y, b) (z, c) g) -> (cospanConeComp C D (x, a) (y, b) (z, c) (f, Hf) (g, Hg)).2 65 | ) 66 | 67 | cospanConePrecategory (C: precategory) (D: cospan C) 68 | : precategory 69 | = sipPrecategory C (cospanConeStructure C D) 70 | 71 | isCategoryCospanCone (C: precategory) (D: cospan C) (isC: isCategory C) 72 | : isCategory (cospanConePrecategory C D) 73 | = sip C isC (cospanConeStructure C D) hole 74 | where 75 | hole: isStandardStructure C (cospanConeStructure C D) 76 | = \(x: carrier C) (a b: hasCospanCone C D x) 77 | (c: isCospanConeHom C D (x, a) (x, b) (path C x)) 78 | (d: isCospanConeHom C D (x, b) (x, a) (path C x)) -> 79 | (composition (hom C x D.2.1.1) a.1 (compose C x x D.2.1.1 (path C x) a.1) b.1 (pathL C x D.2.1.1 a.1 @-i) d.1 @ i 80 | ,composition (hom C x D.2.2.1) a.2.1 (compose C x x D.2.2.1 (path C x) a.2.1) b.2.1 (pathL C x D.2.2.1 a.2.1 @-i) d.2 @ i 81 | ,lemPathPProp (Path (hom C x D.1) (compose C x D.2.1.1 D.1 a.1 D.2.1.2) (compose C x D.2.2.1 D.1 a.2.1 D.2.2.2)) 82 | (Path (hom C x D.1) (compose C x D.2.1.1 D.1 b.1 D.2.1.2) (compose C x D.2.2.1 D.1 b.2.1 D.2.2.2)) 83 | (homSet C x D.1 (compose C x D.2.1.1 D.1 a.1 D.2.1.2) (compose C x D.2.2.1 D.1 a.2.1 D.2.2.2)) 84 | (Path (hom C x D.1) 85 | (compose C x D.2.1.1 D.1 (composition (hom C x D.2.1.1) a.1 (compose C x x D.2.1.1 (path C x) a.1) b.1 86 | (pathL C x D.2.1.1 a.1 @-i) d.1 @ i) D.2.1.2) 87 | (compose C x D.2.2.1 D.1 (composition (hom C x D.2.2.1) a.2.1 (compose C x x D.2.2.1 (path C x) a.2.1) b.2.1 88 | (pathL C x D.2.2.1 a.2.1 @-i) d.2 @ i) D.2.2.2)) 89 | a.2.2 b.2.2 @ i) 90 | 91 | hasPullbackProp (C: precategory) (isC: isCategory C) (D: cospan C) 92 | : isProp (hasPullback C D) 93 | = terminalProp (cospanConePrecategory C D) (isCategoryCospanCone C D isC) 94 | 95 | -- f g 96 | -- A ---> B ---> C 97 | -- j | k | l | 98 | -- v v v 99 | -- D ---> E ---> F 100 | -- h i 101 | 102 | pullbackPasting 103 | (X: precategory) 104 | (A B C D E F: carrier X) 105 | (f: hom X A B) (g: hom X B C) 106 | (h: hom X D E) (i: hom X E F) 107 | (j: hom X A D) (k: hom X B E) (l: hom X C F) 108 | (cc1: isComm X A B D E f h j k) 109 | (cc2: isComm X B C E F g i k l) 110 | (cc3: isComm X A C D F (compose X A B C f g) (compose X D E F h i) j l) 111 | (pb2: isPullback X (F, (E, i), (C, l)) (B, k, g, cc2)) 112 | (pb3: isPullback X (F, (D, compose X D E F h i), (C, l)) (A, j, compose X A B C f g, cc3)) 113 | : isPullback X (E, (D, h), (B, k)) (A, j, f, cc1) 114 | = undefined 115 | 116 | -------------------------------------------------------------------------------- /cubicaltt/src/control.ctt: -------------------------------------------------------------------------------- 1 | {- Control Structures: 2 | - Pure; 3 | - Applicative; 4 | - Monad. 5 | Copyright (c) Groupoid Infinity, 2014-2018. -} 6 | 7 | module control where 8 | import proto 9 | import path 10 | 11 | -- Signature equations 12 | pure_sig (F:U->U):U= (A: U) -> A -> F A 13 | extract_sig (F:U->U):U= (A: U) -> F A -> A 14 | extend_sig (F:U->U):U= (A B: U) -> (F A -> B) -> F A -> F B 15 | appl_sig (F:U->U):U= (A B: U) -> F (A -> B) -> F A -> F B 16 | fmap_sig (F:U->U):U= (A B: U) -> (A -> B) -> F A -> F B 17 | unmap_sig (F:U->U):U= (A B: U) -> (F A -> F B) -> (A -> B) 18 | contra_sig (F:U->U):U= (A B: U) -> (B -> A) -> F A -> F B 19 | uncontra_sig (F:U->U):U= (A B: U) -> (F A -> F B) -> (B -> A) 20 | cofmap_sig (F:U->U):U= (A B: U) -> (B -> A) -> F B -> F A 21 | uncofmap_sig (F:U->U):U= (A B: U) -> (F B -> F A) -> (B -> A) 22 | cocontra_sig (F:U->U):U= (A B: U) -> (A -> B) -> F B -> F A 23 | uncocontra_sig (F:U->U):U= (A B: U) -> (F B -> F A) -> (A -> B) 24 | join_sig (F:U->U):U= (A: U) -> F (F A) -> F A 25 | dup_sig (F:U->U):U= (A: U) -> F A -> F (F A) 26 | bind_sig (F:U->U):U= (A B: U) -> F A ->(A -> F B)-> F B 27 | 28 | {- The signatures are made external for code compactification. 29 | Then we select F: U -> U functor as common head for sigma types. 30 | All quantifiers for members and laws are carried within projections. 31 | Projections contains full signature except F. 32 | These types could be considered for run-time. 33 | Also you may read Oleg Kiselev Type-Classes in ML. 34 | Here is we encode type-classes with Sigma and instances with nested tuples. 35 | -} 36 | 37 | pure: U = (F: U -> U) 38 | * pure_sig F 39 | 40 | functor: U = (F: U -> U) 41 | * fmap_sig F 42 | 43 | applicative: U = (F: U -> U) 44 | * (_: pure_sig F) 45 | * (_: fmap_sig F) 46 | * appl_sig F 47 | 48 | monad: U = (F: U -> U) 49 | * (_: pure_sig F) 50 | * (_: fmap_sig F) 51 | * (_: appl_sig F) 52 | * bind_sig F 53 | 54 | {- Accessor are common technique in Type Refinement approach 55 | for beautifying the code. -} 56 | 57 | -- Accessors 58 | fmap (a: functor): fmap_sig a.1 = a.2 59 | apure (a: applicative): pure_sig a.1 = a.2.1 60 | amap (a: applicative): fmap_sig a.1 = a.2.2.1 61 | ap (a: applicative): appl_sig a.1 = a.2.2.2 62 | mpure (a: monad): pure_sig a.1 = a.2.1 63 | bind (a: monad): bind_sig a.1 = a.2.2.2.2 64 | 65 | kleisli_compose (A B C: U) 66 | (M: monad) 67 | (f: B -> M.1 C) 68 | (g: A -> M.1 B) 69 | (x: A): M.1 C = bind M B C (g x) f 70 | 71 | -- Theorems. Erased in run-time. 72 | 73 | -- fmap(id(x)) = id(x) 74 | -- fmap(o(g,h)) = o(fmap(g),fmap(h)) 75 | 76 | isFunctor (F: functor): U 77 | = (id: (A: U) -> (x: F.1 A) -> Path (F.1 A) (fmap F A A (idfun A) x) x) 78 | * (compose: (A B C: U) (f: B -> C) (g: A -> B) (x: F.1 A) -> 79 | Path (F.1 C) (F.2 A C (o A B C f g) x) 80 | ((o (F.1 A) (F.1 B) (F.1 C) 81 | (F.2 B C f) (F.2 A B g)) x)) * unit 82 | 83 | -- ap(pure(id),x) = id(x) 84 | -- ap(pure(f),pure(x)) = pure(f(x)) 85 | -- ap(ap(ap(pure(o),u),v),w) = ap(u,ap(v,w)) 86 | -- ap(u,pure(y)) == ap(pure(\f.f(y)),u) 87 | 88 | isApplicative (F: applicative): U 89 | = (id: (A:U) -> (x: F.1 A) -> 90 | Path (F.1 A) x (ap F A A (apure F (id A) (idfun A)) x)) 91 | * (hom: (A B:U)(f:A->B)(x: A) -> 92 | Path (F.1 B) (apure F B (f x)) (ap F A B (apure F (A->B) f) (apure F A x))) 93 | * (cmp: (A B C:U)(v: F.1(A->B))(u:F.1(B->C))(w:F.1 A) -> 94 | Path (F.1 C) (ap F B C u (ap F A B v w)) 95 | (ap F A C (ap F (A->B) (A->C) (ap F(B->C)((A->B)->(A->C)) 96 | (apure F (ot A B C) (o A B C)) u) v) w)) 97 | * (xchg: (A B:U)(x:A)(u:F.1(A->B))(f:A->B) -> 98 | Path (F.1 B) (ap F A B u ((apure F) A x)) 99 | (ap F (A->B) B (apure F ((A->B)->B) (\(f:A->B)->f(x))) u)) * unit 100 | 101 | isMonad (F: monad): U 102 | = (one: (A B:U) (f:A->F.1 B)(x:A) -> Path (F.1 B) (bind F A B (mpure F A x) f) (f x)) 103 | * (coone: (A:U) (m: F.1 A) -> Path (F.1 A) (bind F A A m (mpure F A)) m) 104 | * (assoc: (A B C: U) (f: A -> F.1 B) (g: B -> F.1 C) (m: F.1 A) -> 105 | Path (F.1 C) (bind F B C (bind F A B m f) g) 106 | (bind F A C m (\(x: A) -> bind F B C (f x) g))) * unit 107 | 108 | FUNCTOR: U = (f: functor) 109 | * isFunctor f 110 | 111 | APPLICATIVE: U = (f: applicative) 112 | * (_: isFunctor (f.1,f.2.2.1)) 113 | * isApplicative f 114 | 115 | MONAD: U = (f: monad) 116 | * (_: isFunctor (f.1,f.2.2.1)) 117 | * (_: isApplicative (f.1,f.2.1,f.2.2.1,f.2.2.2.1)) 118 | * isMonad f 119 | 120 | -------------------------------------------------------------------------------- /cubicaltt/src/cw.ctt: -------------------------------------------------------------------------------- 1 | {- CW-Comlexes 2 | Copyright (c) Groupoid Infinity, 2014-2020. 3 | 4 | HoTT 6.6 Cell Complexes -} 5 | 6 | module cw where 7 | import suspension 8 | import nat 9 | import pushout 10 | 11 | -- Cell complexes as attachment cells 12 | attaching (A B C: U): U = B -> C -> A 13 | attached (A B C: U) (a: attaching A B C): U 14 | = pushout A B (prod B C) (\(x: prod B C) -> a x.1 x.2) 15 | (\(x: prod B C) -> x.1) 16 | 17 | -------------------------------------------------------------------------------- /cubicaltt/src/cwf.ctt: -------------------------------------------------------------------------------- 1 | module cwf where 2 | 3 | {- 4 | 5 | Here is a short informal description of 6 | categorical semantics of dependent type theory given by Peter Dybjer. 7 | The code is by Thierry Coquand ported to cubical by 5HT. 8 | 9 | http://www.cse.chalmers.se/~peterd/papers/Ise2008.pdf 10 | 11 | Another good intro to LCCC was a 80-514 course at CMU: 12 | 13 | http://math.cmu.edu/~cnewstea/talks/20170301.pdf 14 | 15 | Definition (Fam). The Fam is the category of families 16 | of sets where objects are dependent function 17 | spaces (x:A)->B(x) and morphisms with domain 18 | Pi(A,B) and codomain Pi(A',B') are pairs of 19 | functions A',g(x:A):B(x)->B'(f(x))>. 20 | 21 | Definition (Derivability). Ctx|-A = (c:Ctx) -> A(c). 22 | Definition (Comprehension). Ctx;A = (c:Ctx) * A(c). 23 | Statement. Comprehension is not assoc. 24 | 25 | G;A;B =/= G;B;A 26 | 27 | Definition (Context).The C is context category where 28 | objects are contexts and morphisms are substitutions. 29 | Terminal object G=0 in C is called empty context. 30 | Context comprehension operation G;A = (x:G)*A(x) and 31 | its eliminators: p:G;A |- G, q: G;A |- A(p) such that 32 | universal property holds: for any D:ob(C), morphism g:D->G, 33 | and term a:D->A there is a unique morphism s=:D->G;A 34 | such that p.s=g and q(s)=a. Statement. Subst is assoc. 35 | 36 | g(g(G,x,a),y,b) = g(g(G,y,b),x,a) 37 | 38 | Definition (CwF-object). A CwF-object is a Sigma(C,C->Fam) 39 | of context category C with contexts as objects and 40 | substitutions as morphisms and functor T:C->Fam where 41 | object part is a map from a context G of C to famility 42 | of sets of terms G |- A and morphism part is a map from 43 | substitution g:D->G to a pair of functions which perform 44 | substitutions of g in terms and types respectively. 45 | 46 | Definition (CwF-morphism). Let (C,T):ob(C) where T:C->Fam. 47 | A CwF-morphism m: (C,T)->(C',T') is a pair C',s:T->T'(F)> 48 | where F is a functor and s is a natural transformation. 49 | 50 | Definition (Category of Types). Let we have CwF with (C,T) objects 51 | and (C,T)->(C',T') mophisms. For a given context G in Ob(C) we can 52 | construct a Type(G) -- the category of types in context G with 53 | set of types in contexts as objects as and functions f:G;A->B(p) as morphisms. 54 | 55 | Definition (Local Cartesian Closed Category). 56 | 57 | LCCC(C) = Sigma(C,(A:ob C)->CCC(C/A)). 58 | 59 | [1]. Alexandre Buisse, Peter Dybjer. 60 | The Interpretation of Intuitionistic Type Theory 61 | in Locally Cartesian Closed Categories -- an Intuitionistic Perspective. 62 | [2]. Martin Hofmann, Thomas Streicher. 63 | The groupoid interpretation of type theory. 64 | [3]. Pierre Clairambault. 65 | From Categories with Families to Locally Cartesian Closed Categories. 66 | [4]. Andreas Abel, Thierry Coquand, Peter Dybjer. 67 | On the Algebraic Foundation of Proof Assistants for Intuitionistic Type Theory. 68 | [5]. R.A.G. Seely. 69 | Locally cartesian closed categories and type theory. 70 | [6]. Pierre-Louis Curien, Richard Garner, Martin Hofmann. 71 | Revisiting the categorical interpretation of dependent type theory. 72 | [7]. Simon Castellan. 73 | Dependent type theory as the initial category with families. 74 | [8]. Peter Dybjer. 75 | Internal Type Theory. 76 | -} 77 | 78 | import cat 79 | import fun 80 | import nat 81 | import list 82 | import bool 83 | import maybe 84 | 85 | {- 86 | 87 | The type checker based on Categories with Families (CwF) model. 88 | The contexts modeled as lists of initial objects of internal language. 89 | Here is example of two contexts and substitution between them. 90 | 91 | Ctx: Vec Exp 3 = [ A:U, B:A->U, Pi(A,B) ] 92 | Ctx: Vec Exp 5 = [ A:U, B:A->U, Pi(A,B), Sigma(A,B), A->A ] 93 | Subst: Vec Exp 2 = [ Sigma (Var 1) (Var 2), Pi (Var 1) (Var 1) ] 94 | 95 | -} 96 | 97 | data Exp = Star (_: nat) 98 | | Var (_: nat) 99 | | Pi (_ _: Exp) 100 | | Lam (_: Exp) 101 | | App (_ _: Exp) 102 | 103 | Ty: U = Exp 104 | Ctx: U = list Ty 105 | Subst: U = list Exp 106 | 107 | seq (start: nat): list Exp = cons (Var start) (seq (succ start)) 108 | 109 | mutual 110 | 111 | p: Subst = seq one 112 | q: Exp = Var zero 113 | ide: Subst = seq zero 114 | cmp: Subst -> Subst -> Subst = split 115 | nil -> \(ts: Subst) -> nil 116 | cons x xs -> \(ts: Subst) -> cons (sub ts x) (cmp xs ts) 117 | 118 | lift (ts: Subst): Subst = cons q (cmp ts p) 119 | unwrap: maybe Exp -> Exp = split { nothing -> q ; just x -> x } 120 | shift (t: Exp) (i: nat): Exp = sub (seq i) t 121 | 122 | isCo: Ctx -> bool = split 123 | nil -> true 124 | cons x xs -> and (isCo xs) (isTy xs x) 125 | 126 | isU (c:Ctx)(a b:Exp): Exp -> bool = split 127 | Star i -> (and (isTm c (Star i) a) (isTm (cons a c) (Star i) b)) 128 | Var i -> false 129 | Pi a b -> false 130 | Lam x -> false 131 | App a b -> false 132 | 133 | isPi (c:Ctx)(e:Exp): Exp -> bool = split 134 | Star i -> false 135 | Var i -> false 136 | Pi a b -> isTm (cons a c) b e 137 | Lam x -> false 138 | App a b -> false 139 | 140 | isTy (c:Ctx): Ty -> bool = split 141 | Star i -> true 142 | Var i -> isTm c (Star zero) (Var i) 143 | Pi a b -> and (isTy c a) (isTy (cons a c) b) 144 | Lam x -> isTm c (Star zero) (Lam x) 145 | App a b -> isTm c (Star zero) (App a b) 146 | 147 | isTm (c:Ctx)(e:Exp): Ty -> bool = split 148 | Star i -> false 149 | Var i -> false 150 | Pi a b -> isU c a b e 151 | Lam x -> isPi c x e 152 | App a b -> false 153 | 154 | app (s: Exp): Exp -> Exp = split 155 | Star i -> App (Star i) s 156 | Var i -> App (Var i) s 157 | Pi a b -> App (Pi a b) s 158 | Lam x -> sub (cons s ide) x 159 | App a b -> App (App a b) s 160 | 161 | sub (ts: Subst): Exp -> Exp = split 162 | Star i -> Star i 163 | Var i -> unwrap (nth Exp i ts) 164 | Pi a b -> Pi (sub ts a) (sub (lift ts) b) 165 | Lam x -> Lam (sub (lift ts) x) 166 | App s t -> app (sub ts t) (sub ts s) 167 | 168 | inferTy (c: Ctx): Exp -> maybe Ty = split 169 | Star i -> just (Star i) 170 | Var i -> just (shift (unwrap (nth Exp i c)) (succ i)) 171 | Pi a b -> just (Star one) -- implement 172 | Lam x -> just (Star zero) -- implement 173 | App s t -> just (Star zero) -- implement 174 | 175 | Fam: precategory = undefined 176 | isContext (C: precategory): U = undefined 177 | isTerminal (C: precategory): U = undefined 178 | isComprehension(C: precategory)(T: catfunctor C Fam): U = undefined 179 | 180 | CwF: U 181 | = (C: precategory) 182 | * (T: catfunctor C Fam) 183 | * (context: isContext C) 184 | * (terminal: isTerminal C) 185 | * (pullback: isComprehension C T) 186 | * unit 187 | -------------------------------------------------------------------------------- /cubicaltt/src/em.ctt: -------------------------------------------------------------------------------- 1 | {- Eilenberg-MacLane Spaces: 2 | Copyright (c) Groupoid Infinity, 2014-2020. 3 | 4 | HoTT 8.10.3 K(G,n) Spaces -} 5 | 6 | module em where 7 | import algebra 8 | import trunc 9 | import pointed 10 | import suspension 11 | import hubspokes 12 | import nat 13 | 14 | -- K0' is a group G with the discrete toplogy 15 | discreteTopology (G: abgroup): U = group -- 16 | 17 | -- K1' is not yet truncated K(G,1) 18 | data K1' (G : group) 19 | = pt 20 | | id (x : G.1.1) 21 | [ (i = 0) -> pt , 22 | (i = 1) -> pt ] 23 | | mul (a b : G.1.1) 24 | [ (i = 0) -> composition (K1' G) pt pt pt ( id {K1' G} a @ k) ( id {K1' G} b @ k) @ j , 25 | (i = 1) -> id {K1' G} (opGroup G a b) @ j , 26 | (j = 0) -> pt , 27 | (j = 1) -> pt ] 28 | 29 | -- Nat-indexed Abelian K(G,n) suitable for EM-spectrum HZ, n≥1 30 | -- Properties: π_{n}(K(G,n))=G \/ π_{k/=n}(K(G,n))=1 31 | KGn (G: abgroup) 32 | : nat -> U 33 | = split 34 | zero -> discreteTopology G 35 | succ n -> nTrunc (suspension (K1' (G.1,G.2.1)) n) (succ n) 36 | 37 | -- Direct Encoding 38 | K1 (G: group): U = grpdTrunc (K1' G) 39 | K2 (G: group): U = grpd2Trunc (susp (K1' G)) 40 | K3 (G: group): U = grpd3Trunc (susp (susp (K1' G))) 41 | 42 | baseK1 (G : group) : K1 G = inc pt 43 | loopSpaceK1 (G : group) : U = Path (K1 G) (baseK1 G) (baseK1 G) 44 | loopK1 (G : group) (x : G.1.1) : loopSpaceK1 G = inc (id {K1' G} x @ i) 45 | 46 | multK1 (G : group) (a b : loopSpaceK1 G) 47 | : loopSpaceK1 G 48 | = composition (K1 G) (baseK1 G) (baseK1 G) (baseK1 G) a b 49 | 50 | loopMulK1 (G : group) (a b : G.1.1) 51 | : Path (loopSpaceK1 G) (multK1 G (loopK1 G a) (loopK1 G b)) (loopK1 G (opGroup G a b)) 52 | = composition 53 | (loopSpaceK1 G) 54 | (multK1 G (loopK1 G a) (loopK1 G b)) 55 | ( inc (composition (K1' G) pt pt pt ( id {K1' G} a @ j) ( id {K1' G} b @ j) @ i)) 56 | (loopK1 G (opGroup G a b)) 57 | (mapOverComp (K1' G) (K1 G) (\(x:K1' G)->inc x) pt pt pt ( id {K1' G} a @ j) ( id {K1' G} b @ j)) 58 | ( inc (mul{K1' G} a b @ i @ j)) 59 | -------------------------------------------------------------------------------- /cubicaltt/src/eq.ctt: -------------------------------------------------------------------------------- 1 | module eq where 2 | import bool 3 | 4 | eq_: U = (type: U) * (type -> type -> bool) 5 | eq (type: U): U = type -> type -> bool 6 | 7 | -------------------------------------------------------------------------------- /cubicaltt/src/eqv.ctt: -------------------------------------------------------------------------------- 1 | module eqv where 2 | 3 | idfun (A: U) (a: A): A = a 4 | Path (A: U) (a b: A): U = PathP ( A) a b 5 | HPath (A B: U) (a: A) (b: B) (P: Path U A B) : U = PathP P a b 6 | refl (A: U) (a: A): Path A a a = a 7 | singl (A: U) (a: A): U = (x: A) * Path A a x 8 | eta (A: U) (a: A): singl A a = (a,refl A a) 9 | contr (A: U) (a b: A) (p: Path A a b): Path (singl A a) (eta A a) (b,p) = (p @ i, p @ i/\j) 10 | subst (A: U) (P: A->U) (a b: A) (p: Path A a b) (e: P a): P b = comp ( P (p @ i)) e [] 11 | isContr (A: U): U = (x: A) * ((y: A) -> Path A x y) 12 | fiber (A B: U) (f: A -> B) (y: B): U = (x: A) * Path B y (f x) 13 | isSingleton (X:U): U = (c:X) * ((x:X) -> Path X c x) 14 | isEquiv (A B: U) (f: A -> B): U = (y: B) -> isContr (fiber A B f y) 15 | equiv (A B: U): U = (f: A -> B) * isEquiv A B f 16 | isContrSingl (A:U) (a:A): isContr (singl A a) = ((a,refl A a),\ (z:singl A a) -> contr A a z.1 z.2) 17 | idIsEquiv (A: U): isEquiv A A (idfun A) = \(a: A) -> ((a, refl A a),\(z: fiber A A (idfun A) a) -> contr A a z.1 z.2) 18 | idEquiv (A:U): equiv A A = (\ (x:A) -> x, isContrSingl A) 19 | equivPath (T A: U) (f: T -> A) (p: isEquiv T A f): Path U T A = Glue A [ (i=0) -> (T,f,p), (i=1) -> (A,idfun A, idIsEquiv A)] 20 | invEq (A B:U)(w:equiv A B)(y:B): A = (w.2 y).1.1 21 | retEq (A B:U)(w:equiv A B)(y:B): Path B (w.1 (invEq A B w y)) y = (w.2 y).1.2@-i 22 | secEq (A B:U)(w:equiv A B)(x:A): Path A (invEq A B w (w.1 x)) x = ((w.2(w.1 x)).2(x,w.1 x)@i).1 23 | 24 | univ_Formation (A B: U): U = equiv A B -> Path U A B 25 | equivToPath (A B: U): univ_Formation A B = \(p: equiv A B) -> Glue B [(i=0) -> (A,p), (i=1) -> (B, subst U (equiv B) B B (<_>B) (idEquiv B)) ] 26 | pathToEquiv (A B: U) (p: Path U A B): equiv A B = subst U (equiv A) A B p (idEquiv A) 27 | eqToEq (A B : U) (p : Path U A B) : Path (Path U A B) (equivToPath A B (pathToEquiv A B p)) p 28 | = let Ai: U = p@i in Glue B [ (i=0) -> (A,pathToEquiv A B p), 29 | (i=1) -> (B,pathToEquiv B B ( B)), 30 | (j=1) -> (p@i,pathToEquiv Ai B ( p @ (i \/ k))) ] 31 | -------------------------------------------------------------------------------- /cubicaltt/src/etale.ctt: -------------------------------------------------------------------------------- 1 | {- Étale Maps: 2 | - Etale. 3 | Copyright (c) Groupoid Infinity, 2014-2018. 4 | 5 | EGA4 4.1 Etale maps -} 6 | 7 | module etale where 8 | import path 9 | import pullback 10 | import infinitesimal 11 | 12 | -- w 13 | -- A ----> Im A 14 | -- f | | x 15 | -- V V 16 | -- B ----> Im B 17 | -- y 18 | 19 | isÉtaleMap (A B: U) (f: A -> B): U 20 | = isPullbackSq A iA B (Im B) x y w f h where 21 | iA : U = Im A 22 | iB : U = Im B 23 | x: iA -> iB = ImApp A B f 24 | y: B -> iB = ImUnit B 25 | w: A -> iA = ImUnit A 26 | c1: A -> iB = o A iA iB x w 27 | c2: A -> iB = o A B iB y f 28 | T2: U = (a:A) -> Path iB (c1 a) (c2 a) 29 | h: T2 = \(a : A) -> ImNaturality A B f a @ -i 30 | 31 | EtaleMap (A B: U): U 32 | = (f: A -> B) 33 | * isÉtaleMap A B f 34 | -------------------------------------------------------------------------------- /cubicaltt/src/functor.ctt: -------------------------------------------------------------------------------- 1 | {- Control Structures. Functor Instances: 2 | - Identity; 3 | - Id; 4 | - Compose; 5 | - Higher Order Compose. 6 | Copyright (c) Groupoid Infinity, 2014-2018. -} 7 | 8 | module functor where 9 | import proto 10 | import path 11 | import pi 12 | import control 13 | 14 | functor_id: FUNCTOR = ((\(A:U)->A,apply),(id,compose,tt)) where 15 | id: (A: U) -> (a: A) -> Path A a a = refl 16 | compose (A B C: U) (f: B->C) (g: A->B) (x: A): 17 | Path C (f(g(x))) (f(g(x))) = refl C (o A B C f g x) 18 | 19 | functor_const (A: U): FUNCTOR = ((const A,fmap),(id,compose,tt)) where 20 | fmap (B C: U) (_: B -> C): A -> A = idfun A 21 | id (_ : U): (x : A) -> Path A x x = refl A 22 | compose (X B C: U) (f: B->C) (g: X->B): (x: A) -> Path A x x = refl A 23 | 24 | functor_fun (T: U): FUNCTOR = ((\(B:U)->T->B,fmap),(id,compose,tt)) where 25 | fmap (A B: U) (map: A -> B): (T -> A) -> (T -> B) = o T A B map 26 | id (A: U): (x: T->A) -> Path (T->A) x x = refl (T->A) 27 | compose (A B C: U) (f: B->C) (g: A->B) (x: T->A): 28 | Path (T->C) (\(y: T) -> f (g (x y))) 29 | (\(y: T) -> f (g (x y))) 30 | = refl (T->C) (\(y: T) -> f (g (x y))) 31 | 32 | functor_comptype (f g: FUNCTOR): FUNCTOR = ((O F G,fmap),(id,compose,tt)) where 33 | F: U -> U = f.1.1 34 | G: U -> U = g.1.1 35 | T: U -> U = O F G 36 | functorIdFunExt (x: FUNCTOR) (A: U): Path (x.1.1 A -> x.1.1 A) (x.1.2 A A (idfun A)) (idfun (x.1.1 A)) 37 | = funext (x.1.1 A) (x.1.1 A) (x.1.2 A A (idfun A)) (idfun (x.1.1 A)) (x.2.1 A) 38 | functorComposeFunExt (x: FUNCTOR) (A B C: U) (fx: B -> C) (gy: A -> B): 39 | Path (x.1.1 A -> x.1.1 C) (x.1.2 A C (o A B C fx gy)) 40 | (o (x.1.1 A) (x.1.1 B) (x.1.1 C) (x.1.2 B C fx) (x.1.2 A B gy)) 41 | = funext (x.1.1 A) (x.1.1 C) (x.1.2 A C (o A B C fx gy)) 42 | ((o (x.1.1 A) (x.1.1 B) (x.1.1 C) (x.1.2 B C fx) (x.1.2 A B gy))) (x.2.2.1 A B C fx gy) 43 | lemma1 (A B: U) (g: A -> B) (x y: A) (z: B) (pxy: Path A x y) (pgyz: Path B (g y) z): Path B (g x) z 44 | = substInv A (\(X: A) -> Path B (g X) z) x y pxy pgyz 45 | fmapF: (A B: U) -> (A -> B) -> F A -> F B = f.1.2 46 | fmapG: (A B: U) -> (A -> B) -> G A -> G B = g.1.2 47 | idF: (A: U) -> (x: F A) -> Path (F A) (fmapF A A (idfun A) x) x = f.2.1 48 | idG: (A: U) -> (x: G A) -> Path (G A) (fmapG A A (idfun A) x) x = g.2.1 49 | fmap (A B: U) (arg: A -> B): F (G A) -> F (G B) = fmapF (G A) (G B) (fmapG A B arg) 50 | id (A: U) (x: F (G A)) : Path (F (G A)) (fmapF (G A) (G A) (fmapG A A (idfun A)) x) x 51 | = lemma1 (G A -> G A) (F (G A)) lemma1g (fmapG A A (idfun A)) (idfun (G A)) x (functorIdFunExt g A) (idF (G A) x) 52 | where lemma1g (y: G A -> G A): F (G A) = fmapF (G A) (G A) y x 53 | compose (A B C: U) (ff: B -> C) (gg: A -> B) (x: T A): 54 | Path (F (G C)) (fmapF (G A) (G C) (fmapG A C ((\(y : A) -> ff (gg y)))) x) 55 | (fmapF (G B) (G C) (fmapG B C ff) (fmapF (G A) (G B) (fmapG A B gg) x)) 56 | = substInv (G A -> G C) P AAA BBB compGinst compFinst where 57 | fff : G B -> G C = fmapG B C ff 58 | ggg : G A -> G B = fmapG A B gg 59 | AAA: G A -> G C = fmapG A C (o A B C ff gg) 60 | BBB: G A -> G C = o (G A) (G B) (G C) fff ggg 61 | P (aaa: G A -> G C): U = Path (F (G C)) 62 | (fmapF (G A) (G C) aaa x) 63 | (fmapF (G B) (G C) fff (fmapF (G A) (G B) ggg x)) 64 | compFinst: P BBB = f.2.2.1 (G A) (G B) (G C) fff ggg x 65 | compGinst : Path (G A -> G C) AAA BBB = functorComposeFunExt g A B C ff gg 66 | -------------------------------------------------------------------------------- /cubicaltt/src/hedberg.ctt: -------------------------------------------------------------------------------- 1 | {- Set Theory: 2 | - Stability and Discretness leads to Set 3 | Copyright (c) Groupoid Infinity, 2014-2018. -} 4 | 5 | module hedberg where 6 | import proto 7 | import path 8 | import iso 9 | 10 | hedbergLemma (A: U) (a b:A) (f: (x: A) -> Path A a x -> Path A a x) (p: Path A a b): 11 | Square A a a a b (refl A a) p (f a (refl A a)) (f b p) = 12 | comp ( Square A a a a (p @ i) (<_> a) ( p @ i /\ j) 13 | (f a (<_> a)) (f (p @ i) ( p @ i /\ j))) ( f a (<_> a)) [] 14 | 15 | hedbergStable (A: U) (a b: A) (h: (x: A) -> stable (Path A a x)) 16 | (p q: Path A a b): Path (Path A a b) p q = 17 | comp (<_> A) a [ (j = 0) -> (hedbergLemma A a b f p) @ i, 18 | (j = 1) -> (hedbergLemma A a b f q) @ i, 19 | (i = 0) -> ((rem1 a).1) (refl A a), 20 | (i = 1) -> (fConst b p q) @ j ] where 21 | rem1 (x: A): exConst (Path A a x) = stableConst (Path A a x) (h x) 22 | f (x: A): Path A a x -> Path A a x = (rem1 x).1 23 | fConst (x: A): isConst (Path A a x) (f x) = (rem1 x).2 24 | 25 | hedbergS (A:U) (h: (a x:A) -> stable (Path A a x)): isSet A 26 | = \ (a b: A) -> hedbergStable A a b (h a) 27 | 28 | hedberg (A:U) (h: discrete A): isSet A 29 | = \ (a b: A) -> hedbergStable A a b (\(b : A) -> decStable (Path A a b) (h a b)) 30 | 31 | -------------------------------------------------------------------------------- /cubicaltt/src/homology.ctt: -------------------------------------------------------------------------------- 1 | {- Homology Theory: 2 | - Chain Complexes. 3 | - Ker, Im, B, Z, H; 4 | - Isomorphism theorems; 5 | - Homology Group. 6 | Copyright (c) Groupoid Infinity, 2016-2020. -} 7 | 8 | module homology where 9 | import int 10 | import algebra 11 | 12 | isGroupHom (G H: group) (f: G.1.1 -> H.1.1): U 13 | = (g1 g2: G.1.1) -> Path H.1.1 (f ((opGroup G) g1 g2)) ((opGroup H) (f g1) (f g2)) 14 | 15 | isGroupKer (G H: group) (f: G.1.1 -> H.1.1) (x: G.1.1): U 16 | = Path H.1.1 (f x) (idGroup H) 17 | 18 | isGroupIm (G H: group) (f: G.1.1 -> H.1.1) (g: H.1.1): U 19 | = propTrunc (fiber G.1.1 H.1.1 f g) 20 | 21 | kerProp (G H: group) (phi: grouphom G H) 22 | : subgroupProp G 23 | = (prop,level,ident,inv,op) where 24 | prop (x: G.1.1): U = isGroupKer G H phi.1 x 25 | ident: prop (idGroup G) = phi.2.2 26 | level (x: G.1.1): isProp (prop x) = \(p q: prop x) -> H.1.2 (phi.1 x) (idGroup H) p q 27 | inv (x: G.1.1) (p : prop x) : prop ((invGroup G) x) = 28 | comp (<_> H.1.1) ((invGroup H) (p @ i)) 29 | [ (i = 0) -> lem_grouphom_inv G H phi x @ -j 30 | , (i = 1) -> lemma_group_inv_id H ] 31 | op (g1 g2: G.1.1) (p : prop g1) (q : prop g2) : prop ((opGroup G) g1 g2) = 32 | comp (<_> H.1.1) ((opGroup H) (p @ i) (q @ i)) 33 | [ (i = 0) -> phi.2.1 g1 g2 @ -j 34 | , (i = 1) -> (hasIdGroup H).1 (idGroup H) ] 35 | 36 | imProp (G H: group) (phi: grouphom G H) 37 | : subgroupProp H 38 | = (prop, level, ident, inv, op) where 39 | prop (x: H.1.1): U = isGroupIm G H phi.1 x 40 | ident: prop (idGroup H) = inc ((idGroup G), phi.2.2 @ -i) 41 | level (x: H.1.1): isProp (prop x) = propTruncIsProp (fiber G.1.1 H.1.1 phi.1 x) 42 | fib (x : H.1.1) : U = fiber G.1.1 H.1.1 phi.1 x 43 | inv (x: H.1.1) : prop x -> prop ((invGroup H) x) = 44 | propTruncLift (fib x) (fib ((invGroup H) x)) 45 | (\(u : fib x) -> 46 | ((invGroup G) u.1, 47 | comp (<_> H.1.1) ((invGroup H) (u.2 @ i)) 48 | [ (i = 0) -> <_> (invGroup H) x 49 | , (i = 1) -> lem_grouphom_inv G H phi u.1 @ -j ])) 50 | op (g1 g2: H.1.1) : prop g1 -> prop g2 -> prop ((opGroup H) g1 g2) = 51 | propTruncBinLift (fib g1) (fib g2) (fib ((opGroup H) g1 g2)) 52 | (\(u : fib g1) (v : fib g2) -> 53 | ((opGroup G) u.1 v.1, 54 | comp (<_> H.1.1) (phi.2.1 u.1 v.1 @ -i) 55 | [ (i = 0) -> (opGroup H) (u.2 @ -j) (v.2 @ -j) 56 | , (i = 1) -> <_> phi.1 ((opGroup G) u.1 v.1) ])) 57 | 58 | kerGroup (G: group) (H: group) (phi: grouphom G H): group 59 | = subgroup G (kerProp G H phi) 60 | 61 | imGroup (G: group) (H: group) (psi: grouphom G H): group 62 | = subgroup H (imProp G H psi) 63 | 64 | relKerIm (G H: group) (phi: grouphom G H) (x y: H.1.1): U 65 | = propTrunc (fiber G.1.1 H.1.1 phi.1 (rdiv H x y)) 66 | 67 | elKerIm (G H: group) (phi: grouphom G H): U 68 | = quot H.1.1 (relKerIm G H phi) 69 | 70 | -- Theorems 71 | 72 | -- phiUnfold 73 | -- φ (g1 * g2 * g1⁻¹) - - - - - - > φ g1 * φ g2 * (φ g1)⁻¹ 74 | -- ^ ^ 75 | -- | | 76 | -- | | 77 | -- | | 78 | -- φ (g1 * g2) * φ g1⁻¹ ------------> φ g1 * φ g2 * φ g1⁻¹ 79 | 80 | phiUnfold (G H : group) (phi : grouphom G H) (g1 g2 : G.1.1) : 81 | Path H.1.1 (phi.1 (conjugate G g1 g2)) ((opGroup H) ((opGroup H) (phi.1 g1) (phi.1 g2)) ((invGroup H) (phi.1 g1))) = 82 | comp (<_> H.1.1) ((opGroup H) (phi.2.1 g1 g2 @ i) (phi.1 ((invGroup G) g1))) 83 | [ (i = 0) -> phi.2.1 ((opGroup G) g1 g2) ((invGroup G) g1) @ -j 84 | , (i = 1) -> ((opGroup H) ((opGroup H) (phi.1 g1) (phi.1 g2)) (lem_grouphom_inv G H phi g1 @ j)) ] 85 | 86 | -- conjOne 87 | -- φ g1 * φ g2 * (φ g1)⁻¹ - - - - - - > 1 88 | -- ^ ^ 89 | -- | | 90 | -- | | 91 | -- | | 92 | -- φ g1 * 1 * (φ g1)⁻¹ --------> φ g1 * (φ g1)⁻¹ 93 | 94 | conjOne (G H : group) (phi : grouphom G H) (g1 g2 : G.1.1) (p : Path H.1.1 (phi.1 g2) (idGroup H)) : 95 | Path H.1.1 ((opGroup H) ((opGroup H) (phi.1 g1) (phi.1 g2)) ((invGroup H) (phi.1 g1))) (idGroup H) = 96 | comp (<_> H.1.1) ((opGroup H) ((hasIdGroup H).2 (phi.1 g1) @ i) ((invGroup H) (phi.1 g1))) 97 | [ (i = 0) -> (opGroup H) ((opGroup H) (phi.1 g1) (p @ -j)) ((invGroup H) (phi.1 g1)) 98 | , (i = 1) -> (hasInvGroup H).2 (phi.1 g1) ] 99 | 100 | kernelIsNormalSubgroup (G H : group) (phi : grouphom G H) 101 | : normalSubgroupProp G 102 | = (ker, cond) where 103 | ker: subgroupProp G = kerProp G H phi 104 | phiConj (g1 g2: G.1.1) (p : Path H.1.1 (phi.1 g2) (idGroup H)) : 105 | Path H.1.1 (phi.1 (conjugate G g1 g2)) (idGroup H) 106 | = comp (<_> H.1.1) (conjOne G H phi g1 g2 p @ i) 107 | [ (i = 0) -> phiUnfold G H phi g1 g2 @ -j 108 | , (i = 1) -> <_> idGroup H ] 109 | cond: isNormal G ker = (G, phiConj) 110 | 111 | chainComplex : U 112 | = (K : nat -> abgroup) 113 | * (hom : (n : nat) -> abgrouphom (K (succ n)) (K n)) 114 | * ((n : nat) -> Path (abgrouphom (K (succ2 n)) (K n)) 115 | (abgrouphomcomp (K (succ2 n)) (K (succ n)) (K n) (hom (succ n)) (hom n)) 116 | (trivabgrouphom (K (succ2 n)) (K n))) 117 | 118 | K (C : chainComplex) : nat -> abgroup = C.1 119 | K' (C : chainComplex) (n : nat) : group = abgroup' (K C n) 120 | 121 | hom (C : chainComplex) : (n : nat) -> abgrouphom (K C (succ n)) (K C n) = C.2.1 122 | 123 | propZ (C : chainComplex) (n : nat) : subgroupProp (K' C (succ n)) 124 | = kerProp (K' C (succ n)) (K' C n) (hom C n) 125 | 126 | Z (C : chainComplex) (n : nat) : group = subgroup (K' C (succ n)) (propZ C n) 127 | 128 | B (C : chainComplex) (n : nat) : normalSubgroupProp (Z C n) 129 | = abelianSubgroupIsNormal (abelianSubgroupIsAbelian (K C (succ n)) (propZ C n)) 130 | (subgroupSubgroup (K' C (succ n)) 131 | (imProp (K' C (succ (succ n))) (K' C (succ n)) (hom C (succ n))) (propZ C n)) 132 | 133 | H (C : chainComplex) (n : nat) : group = factorGroup (Z C n) (B C n) -------------------------------------------------------------------------------- /cubicaltt/src/homotopy.ctt: -------------------------------------------------------------------------------- 1 | {- Homotopy Theory: 2 | - Homotopy Groups of Spheres; 3 | - Loop Space of S1 equals to Z. 4 | Copyright (c) Groupoid Infinity, 2016-2018 -} 5 | 6 | module homotopy where 7 | import s1 8 | import trunc 9 | import pointed 10 | import suspension 11 | 12 | -- Homogeneous Structure on A = (A) 13 | homogeneous (A: U): U 14 | = (e: A) 15 | * (translationsFamily: (x: A) -> Path U A A) -- could be non-trivial 16 | * ((x: A) -> Path A (transport (translationsFamily x) e) x) 17 | 18 | -- Definition. Homotopy Groups of Spheres : \pi_{n}S^{m} = ||\Omega^{n}(S^{m})||_0 19 | piS (n: nat): (m: nat) -> U = split 20 | zero -> setTrunc (space (omega n (bool,false))) 21 | succ x -> setTrunc (space (omega n (Sn (succ x),north))) 22 | 23 | -- Theorem. Loop Space of S1 equals to Z : \Omega^{1}(S^{1}) = Z 24 | encode (x:S1) (p:Path S1 base x) 25 | : helix x 26 | = subst S1 helix base x p zeroZ 27 | 28 | decode : (x:S1) -> helix x -> Path S1 base x = split 29 | base -> loopIt 30 | loop @ i -> rem @ i where 31 | p : Path U (Z -> loopS1) (Z -> loopS1) 32 | = helix (loop1@j) -> Path S1 base (loop1@j) 33 | rem : PathP p loopIt loopIt 34 | = corFib1 S1 helix (\(x:S1)->Path S1 base x) base 35 | loopIt loopIt loop1 (\(n:Z) -> 36 | comp ( Path loopS1 (oneTurn (loopIt n)) 37 | (loopIt (testIsoPath Z Z sucZ predZ 38 | sucpredZ predsucZ n @ i))) 39 | ((lem1It n)@-i) []) 40 | 41 | lemTurn (n: nat): (b: bool) -> Path Z (comp (hlx b) (ze n b) []) (ze (succ n) b) = split 42 | false -> inl (succ (comp (<_>nat) (comp (<_>nat) n [(i=1) -> <_>n]) [(i=1) -> <_>n])) 43 | true -> inr (succ (comp (<_>nat) (comp (<_>nat) n [(i=1) -> <_>n]) [(i=1) -> <_>n])) 44 | 45 | encodeNeg: (n: nat)-> Path Z (comp ( helix (loopZ n false @ x)) zeroZ []) (ze n false) = split 46 | zero -> refl Z (ze zero false) 47 | succ n -> (comp ( Path Z (htz n false) (lemTurn n false @ i)) 48 | (comp ( Path Z (htz n false) (comp (hlx false) (encodeNeg n @ i) [])) 49 | ( lemFib2 S1 helix base base (lnb n false) zeroZ base (inversion false) @ -i) []) []) 50 | 51 | encodePos: (n: nat)-> Path Z (comp ( helix (loopZ n true @ x)) zeroZ []) (ze n true) = split 52 | zero -> refl Z (ze zero true) 53 | succ n -> (comp ( Path Z (htz n true) (lemTurn n true @ i)) 54 | (comp ( Path Z (htz n true) (comp (hlx true) (encodePos n @ i) [])) 55 | ( lemFib2 S1 helix base base (lnb n true) zeroZ base (inversion true) @ -i) []) []) 56 | 57 | retractBaseZ : (n : Z) -> Path Z (encode base (decode base n)) n = split 58 | inl n -> encodeNeg n 59 | inr n -> encodePos n 60 | 61 | encodeDecode : U 62 | = (n : Z) -> Path Z (encode base (decode base n)) n 63 | 64 | encodeDecodeLoop : Path U encodeDecode encodeDecode 65 | = (n : helix (loop{S1} @ i)) -> 66 | Path (helix (loop{S1} @ i)) 67 | (encode (loop{S1} @ i) (decode (loop{S1} @ i) n)) n 68 | 69 | retractBaseLoop : (n : Z) -> Path Z (encode base (decode base n)) n 70 | = transport encodeDecodeLoop retractBaseZ 71 | 72 | retractTransport : Path encodeDecode retractBaseLoop retractBaseZ 73 | = \(n : Z) -> ZSet (encode base (decode base n)) n (retractBaseLoop n) (retractBaseZ n) @ i 74 | 75 | retractZ : (x : S1) -> (n : helix x) -> Path (helix x) (encode x (decode x n)) n = split 76 | base -> retractBaseZ 77 | loop @ i -> \(n : helix (loop{S1} @ i)) -> 78 | (substPathP encodeDecode encodeDecode encodeDecodeLoop 79 | retractBaseZ retractBaseZ retractTransport @ i) n 80 | 81 | sectionZ (x : S1) (p: Path S1 base x) : Path (Path S1 base x) (decode x (encode x p)) p 82 | = comp (Path (Path S1 base (p@i)) (decode (p@i) (encode (p@i) (p@(i/\j)))) (p@(i/\j))) 83 | (refl loopS1 triv) [] 84 | 85 | helixFamily (x : S1) : Path U (helix x) (Path S1 base x) 86 | = isoPath (helix x) (Path S1 base x) (decode x) (encode x) (sectionZ x) (retractZ x) 87 | 88 | loopS1eqZ : Path U Z loopS1 89 | = helixFamily base 90 | 91 | -------------------------------------------------------------------------------- /cubicaltt/src/hubspokes.ctt: -------------------------------------------------------------------------------- 1 | {- Hub and Spokes: 2 | - Total, Groupoid Truncations. 3 | Copyright (c) Groupoid Infinity, 2014-2020. 4 | 5 | HoTT 6.7 Hub and Spokes 6 | HoTT 7.3 Truncations -} 7 | 8 | module hubspokes where 9 | import suspension 10 | import nat 11 | 12 | -- 2-disc aka Hub and Spokes 13 | -- Eq constructors are redundant when n≥1 but give contractibility when n=0. 14 | data hubSpokes (S A: U) 15 | = base (x: A) 16 | | hub (f: S -> hubSpokes S A) 17 | | spoke (f: S -> hubSpokes S A) (s:S) 18 | [ (i=0) -> hub {hubSpokes S A} f @ i , (i=1) -> f s ] 19 | | hubEq (x y: A) (p: S -> Path A x y) 20 | [ (i=0) -> base x , (i=1) -> base y ] 21 | | spokeEq (x y: A) (p: S -> Path A x y) (s: S) 22 | [ (i=0) -> hubEq {hubSpokes S A} x y p @ i , (i=1) -> base (p s @ i) ] 23 | 24 | nTruncTotal (A: U) (n: nat): U = hubSpokes (Sn n) A 25 | 26 | -- Simple direct n-truncation as HIT (n≥-1) 27 | data nTrunc (A : U) (n : nat) 28 | = base (x: A) 29 | | hub (f : (Sn (succ n)) -> nTrunc A n) 30 | | spoke (f : (Sn (succ n)) -> nTrunc A n) (x : Sn (succ n)) 31 | [ (i=0) -> hub f , (i=1) -> f x ] 32 | 33 | gTrunc1 (A: U) (n: nat): U = nTrunc A three 34 | gTrunc2 (A: U) (n: nat): U = nTrunc A five 35 | gTrunc3 (A: U) (n: nat): U = nTrunc A six 36 | gTrunc4 (A: U) (n: nat): U = nTrunc A seven 37 | -------------------------------------------------------------------------------- /cubicaltt/src/hvec.ctt: -------------------------------------------------------------------------------- 1 | module hvec where 2 | import nat 3 | import suspension 4 | 5 | data HVec (n: nat) 6 | = hvnil 7 | | hvcons (A: U) (x: A) (xs: HVec (pred n)) 8 | 9 | e1 : HVec zero = hvnil 10 | e2 : HVec one = hvcons U S1 e1 11 | e3 : HVec two = hvcons U S2 e2 12 | e4 : HVec three = hvcons U S2 e3 13 | -------------------------------------------------------------------------------- /cubicaltt/src/impredicative.ctt: -------------------------------------------------------------------------------- 1 | {- Impredicative Encoding of Inductive Types: 2 | - Unit. 3 | Copyright (c) Groupoid Infinity, 2014-2018. -} 4 | 5 | module impredicative where 6 | import proto 7 | import path 8 | -- import iso_pi 9 | -- iso_sigma 10 | 11 | {- 12 | Church Encoding Nat: 13 | 14 | Nat = (X: U) -> (X -> X) -> X -> X 15 | 16 | Impredicative Encoding Unit: 17 | 18 | Unit = (X: U) -> isSet X -> X -> X 19 | Unit_Encoding = (one: Unit) 20 | * ((X Y: U) (x: isSet X) (y:isSet Y) (f:X->Y) 21 | -> naturality X Y f (one X x) (one Y y)) 22 | 23 | Impredicative Encoding Nat: 24 | 25 | Nat = (X: U) -> isSet X -> (X -> X) -> (X -> X) 26 | Nat_Encoding = (one: Nat) 27 | * ((X Y: U) (x: isSet X) (y:isSet Y) (f:X->Y) 28 | -> naturality X Y f (one X x) (one Y y)) 29 | 30 | Motivation is to have algebra structure that could be used with any coherent carrier. 31 | Impredicativity means that we can land inductive type in any universe. 32 | E.g. one can change the predicate from isSet to isProp for truncations or to higher n-types. 33 | You can also model HIT using impredicative encoding. Universes could be impredicative 34 | and univalent at the same time. 35 | 36 | Truncation ||A|| parametrized by (A:U) type = (X: U) -> isProp X -> (A -> X) -> X 37 | S^1 = (X:U) -> isGroupoid X -> (x:X) -> Path X x x -> X 38 | Arbitrary (A:U) type = (X: U) -> isSet X -> (A -> X) -> X 39 | -} 40 | 41 | -- (1) Signature 42 | unitEnc': U = (X: U) -> isSet X -> X -> X 43 | 44 | -- (2) Property 45 | naturality (X Y:U)(f:X->Y)(a:X->X)(b:Y->Y): U = Path (X->Y)(o X X Y f a)(o X Y Y b f) 46 | isUnitEnc (one: unitEnc'): U = (X Y:U)(x:isSet X)(y:isSet Y)(f:X->Y)->naturality X Y f (one X x)(one Y y) 47 | 48 | -- (3) Former/Intro/Elim/Beta/Eta Full-pack 49 | unitEnc: U = (x: unitEnc') * isUnitEnc x 50 | unitEncStar: unitEnc = (\(X:U)(_:isSet X)->idfun X,\(X Y: U)(_:isSet X)(_:isSet Y)->refl(X->Y)) 51 | unitEncRec (C: U) (s: isSet C) (c: C): unitEnc -> C = \(z: unitEnc) -> z.1 C s c 52 | unitEncBeta (C: U) (s: isSet C) (c: C): Path C (unitEncRec C s c unitEncStar) c = refl C c 53 | unitEncEta (z: unitEnc): Path unitEnc unitEncStar z = undefined 54 | unitEncInd (P: unitEnc -> U) (a: unitEnc): P unitEncStar -> P a 55 | = subst unitEnc P unitEncStar a (unitEncEta a) 56 | unitEncCondition (n: unitEnc'): isProp (isUnitEnc n) 57 | = \ (f g: isUnitEnc n) -> \ (x y: U) -> \ (X: isSet x) -> \ (Y: isSet y) 58 | -> \ (F: x -> y) -> \ (R: x) -> Y (F (n x X R)) (n y Y (F R)) 59 | ( (f x y X Y F @ j) R) ( (g x y X Y F @ j) R) @ h @ i 60 | 61 | {- 62 | [1]. https://github.com/sspeight93/Papers/ 63 | [2]. https://homotopytypetheory.org/2017/10/11/impredicative-encodings-of-inductive-types-in-hott/ 64 | [3]. https://www.newton.ac.uk/files/seminar/20170711090010001-1009680.pdf 65 | -} 66 | -------------------------------------------------------------------------------- /cubicaltt/src/infinitesimal.ctt: -------------------------------------------------------------------------------- 1 | {- The modality of shape infinitesimal in cohesive infinity topos. 2 | - \Im modality type. 3 | Copyright (c) Groupoid Infinity, 2014-2018. 4 | 5 | HoTT 7.7 Modalities 6 | https://ncatlab.org/schreiber/show/thesis+Wellen 7 | https://arxiv.org/pdf/1806.05966.pdf 8 | -} 9 | 10 | module infinitesimal where 11 | import path 12 | import equiv 13 | import trunc 14 | 15 | -- Infinitesimal modality, represents infinitesimal shape constructions 16 | 17 | -- Formation 18 | Im : U -> U = undefined 19 | 20 | -- Introduction 21 | ImUnit (A: U) : A -> Im A = undefined 22 | 23 | isCoreduced (A:U): U = isEquiv A (Im A) (ImUnit A) 24 | ImCoreduced (A:U): isCoreduced (Im A) = undefined 25 | 26 | ImRecursion (A B: U) (c: isCoreduced B) (f: A -> B) 27 | : Im A -> B 28 | = undefined 29 | 30 | ImComputeRecursion (A B: U) (c: isCoreduced B) (f: A -> B) (a: A) 31 | : PathP ( B) ((ImRecursion A B c f) (ImUnit A a)) (f a) 32 | = undefined 33 | 34 | ImApp (A B: U) (f: A -> B) 35 | : Im A -> Im B 36 | = ImRecursion A (Im B) (ImCoreduced B) (o A B (Im B) (ImUnit B) f) 37 | 38 | ImNaturality (A B: U) (f: A -> B) 39 | : (a: A) -> Path (Im B) ((ImUnit B) (f a)) ((ImApp A B f) (ImUnit A a)) 40 | = undefined 41 | 42 | -- Elimination 43 | ImInduction (A: U) (B: Im A -> U) (x: (a: Im A) -> isCoreduced (B a)) (y: (a: A) -> B (ImUnit A a)) 44 | : (a: Im A) -> B a 45 | = undefined 46 | 47 | -- Beta 48 | ImComputeInduction (A: U) (B: Im A -> U) (c: (a: Im A) -> isCoreduced (B a)) (f: (a:A) -> B (ImUnit A a))(a:A) 49 | : Path (B (ImUnit A a)) (f a) ((ImInduction A B c f) (ImUnit A a)) 50 | = undefined 51 | 52 | -- Formal Disk Bundle 53 | 54 | isInfinitesimalClose (X: U) (a x': X): U = Path (Im X) (ImUnit X a) (ImUnit X x') 55 | formalDisc (X: U) (a: X): U = (x': X) * isInfinitesimalClose X a x' 56 | unitDisc (X: U) (x: Im X): U = (x': X) * Path (Im X) x (ImUnit X x') 57 | starDisc (X: U) (x: X): formalDisc X x = (x, refl (Im X) (ImUnit X x)) 58 | differential (X Y: U) (f: X -> Y) (x: X) : formalDisc X x -> formalDisc Y (f x) = undefined 59 | formalDiscBundle (A: U): U = (a: A) * formalDisc A a -- T_\infty(A) := \Sigma_{a:A}\mathbb{D}_a 60 | 61 | lemma45 (A B C: U) (f: A -> B) (g: B -> C) (x: A) 62 | : Path (formalDisc A x -> formalDisc C ((o A B C g f) x)) 63 | (differential A C (o A B C g f) x) 64 | (o (formalDisc A x) (formalDisc B (f x)) (formalDisc C ((o A B C g f) x)) 65 | (differential B C g (f x)) (differential A B f x)) = undefined 66 | 67 | preservesInifinitesimalProximity (X Y: U) (x x': X) (f: X -> Y) 68 | : isInfinitesimalClose X x x' -> isInfinitesimalClose Y (f x) (f x') 69 | = undefined 70 | -------------------------------------------------------------------------------- /cubicaltt/src/infinity.ctt: -------------------------------------------------------------------------------- 1 | {- Infinity Language: 2 | - Syntax. 3 | Copyright (c) Groupoid Infinity, 2014-2018. -} 4 | 5 | module infinity where 6 | import list 7 | import control 8 | import path 9 | import pi 10 | 11 | name: U = list nat 12 | data alg = z | o | v (_: name) | max (a b: alg) 13 | | min (a b: alg) | inv (a: alg) 14 | 15 | data pts (lang: U) 16 | = star (n: nat) 17 | | var (x: name) (l: nat) 18 | | pi (x: name) (l: nat) (f: lang) 19 | | lambda (x: name) (l: nat) (f: lang) 20 | | app (f a: lang) 21 | 22 | data PTS 23 | = ppure (_: pts PTS) 24 | 25 | data exists (lang: U) 26 | = sigma (n: name) (a b: lang) 27 | | pair (a b: lang) 28 | | fst (p: lang) 29 | | snd (p: lang) 30 | 31 | data identity (lang: U) 32 | = id (t a b: lang) 33 | | idpair (a b: lang) 34 | | idelim (a b c d e: lang) 35 | 36 | data MLTT 37 | = mpure (_: pts MLTT) 38 | | msigma (_: exists MLTT) 39 | | mid (_: identity MLTT) 40 | 41 | data tele (A: U) = emp | tel (n: name) (b: A) (t: tele A) 42 | data branch (A: U) = br (n: name) (args: list name) (term: A) 43 | data label (A: U) = lab (n: name) (t: tele A) 44 | | com (n: name) (t: tele A) (dim: list name) 45 | (str: list (prod (prod name bool) A)) 46 | 47 | data ind (lang: U) 48 | = data_ (n: name) (t: tele lang) (labels: list (label lang)) 49 | | case (n: name) (t: lang) (branches: list (branch lang)) 50 | | ctor (n: name) (args: list lang) 51 | 52 | data IND 53 | = ipure (_: pts IND) 54 | | isigma (_: exists IND) 55 | | iid (_: identity IND) 56 | | iind (_: ind IND) 57 | 58 | data hts (lang: U) 59 | = path (t a b: lang) 60 | | plam (n: name) (a: alg) (b: lang) 61 | | papp (f: name) (a: lang) (p: alg) 62 | | comp_ (a b: lang) 63 | | fill_ (a b c: lang) 64 | | glue_ (a b c: lang) 65 | | glue_elem (a b: lang) 66 | | unglue_elem (a b: lang) 67 | 68 | data HTS 69 | = hpure (_: pts HTS) 70 | | hsigma (_: exists HTS) 71 | | hid (_: identity HTS) 72 | | hind (_: ind HTS) 73 | | homotopy (_: hts HTS) 74 | -------------------------------------------------------------------------------- /cubicaltt/src/int.ctt: -------------------------------------------------------------------------------- 1 | {- Integers: 2 | - Z=N+N, Z=Z. 3 | Copyright (c) Groupoid Infinity, 2014-2018 -} 4 | 5 | module int where 6 | import nat_theory 7 | import hedberg 8 | 9 | Z : U = either nat nat 10 | 11 | {- +2 = inr (succ (succ zero)) 12 | +1 = inr (succ zero) 13 | 0 = inr zero 14 | -1 = inl zero 15 | -2 = inl (succ zero) -} 16 | 17 | zeroZ : Z = inr zero 18 | 19 | sucZ : Z -> Z = split 20 | inl u -> auxsucZ u where 21 | auxsucZ : nat -> Z = split 22 | zero -> inr zero 23 | succ n -> inl n 24 | inr v -> inr (succ v) 25 | 26 | predZ : Z -> Z = split 27 | inl u -> inl (succ u) 28 | inr v -> auxpredZ v where 29 | auxpredZ : nat -> Z = split 30 | zero -> inl zero 31 | succ n -> inr n 32 | 33 | sucpredZ : (x : Z) -> Path Z (sucZ (predZ x)) x = split 34 | inl u -> refl Z (inl u) 35 | inr v -> lem v where 36 | lem : (u : nat) -> Path Z (sucZ (predZ (inr u))) (inr u) = split 37 | zero -> refl Z (inr zero) 38 | succ n -> refl Z (inr (succ n)) 39 | 40 | predsucZ : (x : Z) -> Path Z (predZ (sucZ x)) x = split 41 | inl u -> lem u where 42 | lem : (u : nat) -> Path Z (predZ (sucZ (inl u))) (inl u) = split 43 | zero -> refl Z (inl zero) 44 | succ n -> refl Z (inl (succ n)) 45 | inr v -> refl Z (inr v) 46 | 47 | -- Non-trivial Equality Z=Z 48 | sucPathZ : Path U Z Z = isoPath Z Z sucZ predZ sucpredZ predsucZ 49 | 50 | -- We can transport along the proof forward and backwards: 51 | testOneZ : Z = transport sucPathZ zeroZ 52 | testNOneZ : Z = transport ( sucPathZ @ - i) zeroZ 53 | 54 | ----------- 55 | 56 | inlNotinr (A B:U) (a:A) (b:B) (h: Path (either A B) (inl a) (inr b)) : empty = 57 | subst (either A B) T (inl a) (inr b) h tt 58 | where 59 | T : either A B -> U = split 60 | inl _ -> unit 61 | inr _ -> empty 62 | 63 | inrNotinl (A B:U) (a:A) (b:B) (h : Path (either A B) (inr b) (inl a)) : empty = 64 | subst (either A B) T (inr b) (inl a) h tt 65 | where 66 | T : either A B -> U = split 67 | inl _ -> empty 68 | inr _ -> unit 69 | 70 | injInl (A B :U) (x0 x1:A) (h : Path (either A B) (inl x0) (inl x1)) : Path A x0 x1 = 71 | subst (either A B) T (inl x0) (inl x1) h (refl A x0) 72 | where 73 | T : either A B -> U = split 74 | inl x -> Path A x0 x 75 | inr _ -> empty 76 | 77 | injInr (A B :U) (x0 x1:B) (h: Path (either A B) (inr x0) (inr x1)) : Path B x0 x1 = 78 | subst (either A B) T (inr x0) (inr x1) h (refl B x0) 79 | where 80 | T : either A B -> U = split 81 | inl _ -> empty 82 | inr x -> Path B x0 x 83 | 84 | -- If A and B are discrete then "A either B" is discrete 85 | orDisc (A B : U) (dA : discrete A) (dB : discrete B) : 86 | (z z1 : either A B) -> dec (Path (either A B) z z1) = split 87 | inl a -> rem1 88 | where rem1 : (z1:either A B) -> dec (Path (either A B) (inl a) z1) = split 89 | inl a1 -> rem (dA a a1) 90 | where rem : dec (Path A a a1) -> dec (Path (either A B) (inl a) (inl a1)) = split 91 | inl p -> inl ( inl (p @ i)) 92 | inr h -> inr (\ (p:Path (either A B) (inl a) (inl a1)) -> h (injInl A B a a1 p)) 93 | inr b -> inr (inlNotinr A B a b) 94 | inr b -> rem1 95 | where rem1 : (z1:either A B) -> dec (Path (either A B) (inr b) z1) = split 96 | inl a -> inr (inrNotinl A B a b) 97 | inr b1 -> rem (dB b b1) 98 | where rem : dec (Path B b b1) -> dec (Path (either A B) (inr b) (inr b1)) = split 99 | inl p -> inl ( inr (p @ i)) 100 | inr h -> inr (\ (p:Path (either A B) (inr b) (inr b1)) -> h (injInr A B b b1 p)) 101 | 102 | 103 | ZSet : isSet Z = hedberg Z (orDisc nat nat natDec natDec) 104 | -------------------------------------------------------------------------------- /cubicaltt/src/interval.ctt: -------------------------------------------------------------------------------- 1 | {- Interval Type: 2 | Copyright (c) Groupoid Infinity, 2014-2018. 3 | 4 | HoTT 6.3 The interval -} 5 | 6 | module interval where 7 | import equiv 8 | import iso 9 | import prop 10 | 11 | -- I = (X:U) -> isSet X -> (x y: X) -> Path X x y -> X 12 | 13 | data I = i0 14 | | i1 15 | | seg [(i=0) -> i0, 16 | (i=1) -> i1] 17 | 18 | pathToHtpy (A: U) (x y: A) (p: Path A x y): I -> A 19 | = split { i0 -> x; i1 -> y; seg @ i -> p @ i } 20 | 21 | -- H_{f,g:X→Y}: X × [0,1] → Y, f(x)=g(x) 22 | homotopy (X Y: U) 23 | (f g: X -> Y) 24 | (p: (x: X) -> Path Y (f x) (g x)) 25 | (x: X): I -> Y = pathToHtpy Y (f x) (g x) (p x) 26 | 27 | -- Proof of funext from the interval 28 | fext (A B: U) (f g: A -> B) (p: (x: A) -> Path B (f x) (g x)): Path (A -> B) f g 29 | = (\(x : A) -> homotopy A B f g p x (seg{I} @ j)) 30 | 31 | toUnit : I -> unit = split { i0 -> tt; i1 -> tt; seg @ i -> tt } 32 | fromUnit : unit -> I = split tt -> i0 33 | toUnitK : (a : unit) -> Path unit (toUnit (fromUnit a)) a = split tt -> tt 34 | fromUnitK : (a : I) -> Path I (fromUnit (toUnit a)) a 35 | = split { i0 -> i0; i1 -> seg {I} @ i; seg @ i -> seg {I} @ i /\ j } 36 | 37 | unitEqI: Path U unit I = isoPath unit I fromUnit toUnit fromUnitK toUnitK 38 | propI: isProp I = subst U isProp unit I unitEqI propUnit 39 | 40 | T: U = Path I i0 i0 41 | p0: T = refl I i0 42 | test: T = propI i0 i0 43 | -------------------------------------------------------------------------------- /cubicaltt/src/iso.ctt: -------------------------------------------------------------------------------- 1 | {- Iso Type: 2 | - Commutative Square 3 | - Iso To Path 4 | Copyright (c) Groupoid Infinity, 2014-2018. -} 5 | 6 | module iso where 7 | import retract 8 | import equiv 9 | import set 10 | 11 | -- u 12 | -- a ------> b 13 | -- | | 14 | -- p | | q 15 | -- | | 16 | -- V V 17 | -- c ------> d 18 | -- v 19 | 20 | Square (A: U)(a b c d: A)(u: Path A a b)(v: Path A c d)(p: Path A a c)(q: Path A b d): U 21 | = PathP ( (PathP ( A) (u @ i) (v @ i))) p q 22 | 23 | constSquare (A: U) (a: A) (p: Path A a a): Square A a a a a p p p p 24 | = comp (<_> A) a [ (i = 0) -> p @ j \/ - k, 25 | (i = 1) -> p @ j /\ k, 26 | (j = 0) -> p @ i \/ - k, 27 | (j = 1) -> p @ i /\ k ] 28 | 29 | isIso (A B: U): U 30 | = (f: A -> B) 31 | * (g: B -> A) 32 | * (s: section A B f g) 33 | * ( retract A B f g) 34 | 35 | ISO: U 36 | = (A: U) 37 | * (B: U) 38 | * isIso A B 39 | 40 | lemIso (A B: U) (f: A -> B) (g: B -> A) (s: section A B f g) (t: retract A B f g) 41 | (y: B) (x0 x1: A) (p0: Path B y (f x0)) (p1: Path B y (f x1)) 42 | : Path (fiber A B f y) (x0,p0) (x1,p1) = (p @ i,sq1 @ i) where 43 | rem0: Path A (g y) x0 = comp ( A) (g (p0 @ i)) [ (i = 1) -> t x0, (i = 0) -> g y ] 44 | rem1: Path A (g y) x1 = comp ( A) (g (p1 @ i)) [ (i = 1) -> t x1, (i = 0) -> g y ] 45 | p: Path A x0 x1 = comp ( A) (g y) [ (i = 0) -> rem0, (i = 1) -> rem1 ] 46 | fill0: Square A (g y)(g (f x0)) (g y) x0 ( g (p0 @ i)) rem0 ( g y) (t x0) = 47 | comp ( A) (g (p0 @ i)) [ (i = 1) -> t x0 @ j /\ k, 48 | (i = 0) -> g y, 49 | (j = 0) -> g (p0 @ i) ] 50 | fill1: Square A(g y)(g(f x1))(g y) x1 (g (p1@i)) rem1 ( g y) (t x1) = 51 | comp ( A) (g (p1 @ i)) [ (i = 1) -> t x1 @ j /\ k, 52 | (i = 0) -> g y, 53 | (j = 0) -> g (p1 @ i) ] 54 | fill2: Square A (g y) (g y) x0 x1 ( g y) p rem0 rem1 = 55 | comp ( A) (g y) [ (i = 0) -> rem0 @ j /\ k, 56 | (i = 1) -> rem1 @ j /\ k, 57 | (j = 0) -> g y ] 58 | sq: Square A(g y)(g y)(g(f x0))(g(f x1))(g y) (g (f(p@i)))(g(p0@j))(g(p1@j)) = 59 | comp ( A) (fill2 @ i @ j) [ (i = 0) -> fill0 @ j @ -k, 60 | (i = 1) -> fill1 @ j @ -k, 61 | (j = 0) -> g y, 62 | (j = 1) -> t (p @ i) @ -k ] 63 | sq1: Square B y y (f x0) (f x1) (y) ( f (p @ i)) p0 p1 = 64 | comp ( B) (f (sq @ i @j)) [ (i = 0) -> s (p0 @ j), 65 | (i = 1) -> s (p1 @ j), 66 | (j = 1) -> s (f (p @ i)), 67 | (j = 0) -> s y ] 68 | 69 | isoToEquiv (A B: U) (f: A -> B) (g: B -> A) (s: section A B f g) (t: retract A B f g): isEquiv A B f 70 | = \(y:B) -> ((g y,s y@-i),\ (z:fiber A B f y) -> lemIso A B f g s t y (g y) z.1 (s y@-i) z.2) 71 | 72 | equivProp (A B: U) (a: isProp A) (b: isProp B) (f: A -> B) (g: B -> A): equiv A B 73 | = (f, isoToEquiv A B f g (\(y:B)->b(f(g y))y) (\(x:A)->a(g(f x))x)) 74 | 75 | -- pi version of isoPath 76 | isoPath (A B: U) (f: A -> B) (g: B -> A) 77 | (s: section A B f g) (t: retract A B f g): Path U A B 78 | = Glue B [ (i = 0) -> (A,f,isoToEquiv A B f g s t), 79 | (i = 1) -> (B,idfun B,idIsEquiv B) ] 80 | 81 | testIsoPath (A B : U) (f : A -> B) (g : B -> A) 82 | (s : (y : B) -> Path B (f (g y)) y) 83 | (t : (x : A) -> Path A (g (f x)) x) (a:A) 84 | : Path B (f a) (trans A B (isoPath A B f g s t) a) = 85 | comp (<_>B) (comp (<_>B) (f a) [(i=0) -> <_> f a]) [(i=0) -> <_> f a] 86 | 87 | -- sigma version of isoPath 88 | isoToPath (i: ISO): Path U i.1 i.2.1 89 | = isoPath i.1 i.2.1 i.2.2.1 i.2.2.2.1 i.2.2.2.2.1 i.2.2.2.2.2 90 | 91 | -- A proof that two propositions with maps between them can be identified with each other 92 | propPath (A B: U) (f: A -> B) (g: B -> A) (pa: isProp A) (pb: isProp B): Path U A B 93 | = isoToPath (A,B,f,g,(\ (b: B) -> pb (f (g b)) b),(\ (a: A) -> pa (g (f a)) a)) 94 | 95 | iso_Form (A B: U) 96 | : U 97 | = isIso A B -> Path U A B 98 | 99 | iso_Intro (A B: U) 100 | : iso_Form A B 101 | = \(x: isIso A B) -> isoToPath (A,B,x) 102 | 103 | 104 | iso_Elim (A B: U) 105 | : Path U A B -> isIso A B 106 | = \(p: Path U A B) -> 107 | (coerce A B p,coerce B A (p@-i), x p,y p) where 108 | x (p: Path U A B): section A B (coerce A B p) (coerce B A (p@-i)) = undefined 109 | y (p: Path U A B): retract A B (coerce A B p) (coerce B A (p@-i)) = undefined 110 | 111 | iso_Comp (A B : U) (p : Path U A B) 112 | : Path (Path U A B) (iso_Intro A B (iso_Elim A B p)) p 113 | = undefined 114 | 115 | iso_Uniq (A B : U) (p: isIso A B) 116 | : Path (isIso A B) (iso_Elim A B (iso_Intro A B p)) p 117 | = undefined 118 | 119 | IsoPathType (A B: U): isIso (isIso A B) (Path U A B) 120 | = (iso_Intro A B,iso_Elim A B,iso_Comp A B,iso_Uniq A B) 121 | 122 | PiType (A: U) (B: A -> U): isIso (Pi A B) (Pi A B) 123 | = (app A B,app A B,Pi_Eta A B,Pi_Eta A B) 124 | 125 | UnivType (A B: U): isIso (equiv A B) (Path U A B) 126 | = (equivToPath A B, pathToEquiv A B,eqToEq A B,idToPath A B) 127 | -------------------------------------------------------------------------------- /cubicaltt/src/iso_pi.ctt: -------------------------------------------------------------------------------- 1 | module iso_pi where 2 | 3 | import pi 4 | import iso 5 | 6 | pathPi (A:U) (B:A->U) (f g : Pi A B) 7 | : Path U (Path (Pi A B) f g) ((x:A) -> Path (B x) (f x) (g x)) 8 | = isoPath (Path (Pi A B) f g) ((x:A) -> Path (B x) (f x) (g x)) F G S T where 9 | T0 : U = Path (Pi A B) f g 10 | T1 : U = (x:A) -> Path (B x) (f x) (g x) 11 | F (p:T0) : T1 = \ (x:A) -> p@i x 12 | G (p:T1) : T0 = \ (x:A) -> p x @ i 13 | S (p:T1) : Path T1 (F (G p)) p = refl T1 p 14 | T (p:T0) : Path T0 (G (F p)) p = refl T0 p 15 | 16 | groupoidPi (A: U) (B: A -> U) (h: (x: A) -> isGroupoid (B x)) (f g: Pi A B) 17 | : isSet (Path (Pi A B) f g) 18 | = subst U isSet T (Path (Pi A B) f g) ( pathPi A B f g @ -i) rem where 19 | T: U = (x:A) -> Path (B x) (f x) (g x) 20 | rem: isSet T = setPi A (\ (x:A) -> Path (B x) (f x) (g x)) (\ (x:A) -> h x (f x) (g x)) 21 | 22 | -------------------------------------------------------------------------------- /cubicaltt/src/iso_sigma.ctt: -------------------------------------------------------------------------------- 1 | module iso_sigma where 2 | import path 3 | import pi 4 | import sigma 5 | import iso 6 | 7 | -- used in grothedieck.ctt and below 8 | pathSig (A:U) (B : A -> U) (t u : Sigma A B) : 9 | Path U (Path (Sigma A B) t u) ((p : Path A t.1 u.1) * PathP ( B (p @ i)) t.2 u.2) 10 | = isoPath T0 T1 f g s t where 11 | T0 : U = Path (Sigma A B) t u 12 | T1 : U = (p:Path A t.1 u.1) * PathP ( B (p@i)) t.2 u.2 13 | f (q:T0) : T1 = ( (q@i).1, (q@i).2) 14 | g (z:T1) : T0 = (z.1 @i,z.2 @i) 15 | s (z:T1) : Path T1 (f (g z)) z = refl T1 z 16 | t (q:T0) : Path T0 (g (f q)) q = refl T0 q 17 | 18 | -- used in algstruct 19 | setSig (A:U) (B: A-> U) (sA: isSet A) (sB : (x:A) -> isSet (B x)): isSet (Sigma A B) = goal where 20 | goal (t u : Sigma A B) : isProp (Path (Sigma A B) t u) 21 | = substInv U isProp (Path (Sigma A B) t u) ((p:T) * C p) rem3 rem2 where 22 | T : U = Path A t.1 u.1 23 | C (p:T) : U = PathP ( B (p@i)) t.2 u.2 24 | rem (p : T) : isProp (C p) = corSigSet A B sB t u p 25 | rem1 : isProp T = sA t.1 u.1 26 | rem2 : isProp ((p:T) * C p) = propSig T C rem1 rem 27 | rem3 : Path U (Path (Sigma A B) t u) ((p:T) * C p) = pathSig A B t u 28 | 29 | pathSig2 (A:U) (P: A -> U) (t u: Sigma A P) 30 | (p: Path A t.1 u.1) 31 | (s: PathP ( P (p @ i)) t.2 u.2) 32 | : Path (Sigma A P) t u 33 | = comp ( pathSig A P t u @ -i) (p,s) [] 34 | 35 | pathSig3 (A:U) (P : A -> U) (t u : Sigma A P) (pp: (p : Path A t.1 u.1) * Path (P u.1) (transport (P (p @ i)) t.2) u.2): Path (Sigma A P) t u 36 | = pathSig2 A P t u (pp.1, transport foo pp.2) where 37 | p: Path A t.1 u.1 = pp.1 38 | P' : Path U (P t.1) (P u.1) = P (p@i) 39 | T0 : U = PathP P' t.2 u.2 40 | T1 : U = Path (P u.1) (transport P' t.2) u.2 41 | foo : Path U T1 T0 = sym U T0 T1 (pathSig0 A P t u p) 42 | pathSig2 (A:U) (P : A -> U) (t u : Sigma A P) (pp: (p : Path A t.1 u.1) * PathP ( P (p @ i)) t.2 u.2): Path (Sigma A P) t u 43 | = comp ( pathSig A P t u @ -i) pp [] 44 | 45 | pathSigHoTT (A: U) (P: A -> U) (t u: Sigma A P) (p: Path A t.1 u.1) 46 | (s: Path (P u.1) (transport ( P (p @ i)) t.2) u.2) 47 | : Path (Sigma A P) t u 48 | = pathSig2 A P t u p (transport f s) where 49 | P': Path U (P t.1) (P u.1) = P (p@i) 50 | T0: U = PathP P' t.2 u.2 51 | T1: U = Path (P u.1) (transport P' t.2) u.2 52 | f: Path U T1 T0 = sym U T0 T1 (pathSig0 A P t u p) 53 | 54 | lemContr (A:U) (pA:isProp A) (a:A) : isContr A = (a,rem) 55 | where rem (y:A) : Path A a y = pA a y 56 | 57 | lem3 (A:U) (B:A-> U) (pB : (x:A) -> isProp (B x)) (t u : Sigma A B) (p:Path A t.1 u.1) : 58 | isContr (PathP (B (p@i)) t.2 u.2) = lemContr T0 (substInv U isProp T0 T1 rem rem1) rem2 59 | where P : Path U (B t.1) (B u.1) = B (p@i) 60 | T0 : U = PathP P t.2 u.2 61 | T1 : U = Path (B u.1) (transport P t.2) u.2 62 | rem : Path U T0 T1 = pathSig0 A B t u p 63 | v2 : B u.1 = transport P t.2 64 | rem1 : isProp T1 = propSet (B u.1) (pB u.1) v2 u.2 65 | rem2 : T0 = transport (rem@-i) (pB u.1 v2 u.2) 66 | 67 | lem6 (A:U) (P:A-> U) (cA:(x:A) -> isContr (P x)) : Path U ((x:A)*P x) A = isoPath T A f g t s 68 | where 69 | T : U = (x:A) * P x 70 | f (z:T) : A = z.1 71 | g (x:A) : T = (x,(cA x).1) 72 | s (z:T) : Path T (g (f z)) z = (z.1,((cA z.1).2 z.2)@ i) 73 | t (x:A) : Path A (f (g x)) x = refl A x 74 | 75 | lemSigProp (A:U) (B:A-> U) (pB : (x:A) -> isProp (B x)) (t u : Sigma A B) : Path U (Path (Sigma A B) t u) (Path A t.1 u.1) = 76 | composition U (Path (Sigma A B) t u) ((p:Path A t.1 u.1) * PathP ( B (p@i)) t.2 u.2) (Path A t.1 u.1) rem2 rem1 77 | where 78 | T : U = Path A t.1 u.1 79 | C (p:T) : U = PathP ( B (p@i)) t.2 u.2 80 | rem (p : T) : isContr (C p) = lem3 A B pB t u p 81 | rem1 : Path U ((p:T) * C p) T = lem6 T C rem 82 | rem2 : Path U (Path (Sigma A B) t u) ((p:T) * C p) = pathSig A B t u 83 | 84 | flipfunIso (A B C: U): Path U (A -> B -> C) (B -> A -> C) 85 | = isoPath AB BA from to toK fromK where 86 | AB: U = A -> B -> C 87 | BA: U = B -> A -> C 88 | from: AB -> BA = flip A B C 89 | to: BA -> AB = flip B A C 90 | fromK: (f: AB) -> Path AB (to (from f)) f = refl AB 91 | toK: (f: BA) -> Path BA (from (to f)) f = refl BA 92 | -------------------------------------------------------------------------------- /cubicaltt/src/join.ctt: -------------------------------------------------------------------------------- 1 | module join where 2 | import proto 3 | import iso 4 | import s1 5 | import pointed 6 | import suspension 7 | 8 | data join (A B : U) = inl (a : A) 9 | | inr (b : B) 10 | | pushC (a : A) (b : B) [ (i = 0) -> inl a 11 | , (i = 1) -> inr b ] 12 | 13 | pushP (A B : U) (a : A) (b : B) : Path (join A B) (inl a) (inr b) = 14 | pushC {join A B} a b @ i 15 | 16 | joinpt (A : pointed) (B : U) : pointed = (join A.1 B,inl (point A)) 17 | 18 | r2lInr (A B C : U) : join B C -> join (join A B) C = split 19 | inl b -> inl (inr b) 20 | inr c -> inr c 21 | pushC b c @ i -> pushP (join A B) C (inr b) c @ i 22 | 23 | r2lPushInl (A B C : U) (a : A) (b : B) : 24 | Path (join (join A B) C) (inl (inl a)) (inl (inr b)) = inl (pushP A B a b @ i) 25 | 26 | r2lSquare (A B C : U) (a : A) (b : B) (c : C) : 27 | PathP ( Path (join (join A B) C) (inl (pushP A B a b @ i)) (inr c)) 28 | (pushP (join A B) C (inl a) c) (pushP (join A B) C (inr b) c) 29 | = pushP (join A B) C (pushP A B a b @ i) c @ j 30 | 31 | opr2l (A : U) (a b c : A) (p : Path A a c) (q : Path A a b) (r : Path A b c) 32 | (sq : Square A a b c c q (<_> c) p r) : 33 | Square A a a b c (<_> a) r q p = 34 | comp (<_> A) (p @ i) [ (i = 0) -> q @ j /\ k 35 | , (i = 1) -> p @ j \/ -k 36 | , (j = 0) -> p @ i /\ -k 37 | , (j = 1) -> sq @ k @ i ] 38 | 39 | r2lPushPush (A B C : U) (a : A) (b : B) (c : C) : 40 | Square (join (join A B) C) (inl (inl a)) (inl (inl a)) (inl (inr b)) (inr c) 41 | (<_> inl (inl a)) (pushP (join A B) C (inr b) c) 42 | (r2lPushInl A B C a b) (pushP (join A B) C (inl a) c) = 43 | opr2l (join (join A B) C) (inl (inl a)) (inl (inr b)) (inr c) 44 | (pushP (join A B) C (inl a) c) (r2lPushInl A B C a b) 45 | (pushP (join A B) C (inr b) c) (r2lSquare A B C a b c) 46 | 47 | r2lPush (A B C : U) (a : A) : 48 | (bc : join B C) -> Path (join (join A B) C) (inl (inl a)) (r2lInr A B C bc) = split 49 | inl b -> r2lPushInl A B C a b 50 | inr c -> pushP (join A B) C (inl a) c 51 | pushC b c @ i -> r2lPushPush A B C a b c @ i 52 | 53 | joinassoc1 (A B C : U) : join A (join B C) -> join (join A B) C = split 54 | inl a -> inl (inl a) 55 | inr bc -> r2lInr A B C bc 56 | pushC a bc @ i -> r2lPush A B C a bc @ i 57 | 58 | mapJoin (A A' B B' : U) (f : A -> A') (g : B -> B') : join A B -> join A' B' = split 59 | inl a -> inl (f a) 60 | inr b -> inr (g b) 61 | pushC a b @ i -> pushP A' B' (f a) (g b) @ i 62 | 63 | psi (A : U) : susp A -> join bool A = split 64 | north -> inl true 65 | south -> inl false 66 | merid a @ i -> composition (join bool A) (inl true) (inr a) (inl false) 67 | (pushP bool A true a) ( pushP bool A false a @ -i) @ i 68 | 69 | psiinv (A : U) : join bool A -> susp A = split 70 | inl b -> 71 | let case : (b : bool) -> susp A = split 72 | false -> south 73 | true -> north 74 | in case b 75 | inr a -> south 76 | pushC b a @ i -> 77 | let case (a : A) : (b : bool) -> Path (susp A) (psiinv A (inl b)) south = split 78 | false -> <_> south 79 | true -> merid1 A a 80 | in case a b @ i 81 | 82 | c (x : join bool bool) : S1 = suspS1 (psiinv bool x) 83 | 84 | cinv (x : S1) : join bool bool = psi bool (S1susp x) 85 | 86 | -- The map e 87 | e (x : S3) : join S1 S1 = 88 | let x1 : join bool S2 = psi S2 x 89 | x2 : join bool (join bool S1) = 90 | mapJoin bool bool S2 (join bool S1) (idfun bool) (psi S1) x1 91 | x3 : join (join bool bool) S1 = joinassoc1 bool bool S1 x2 92 | res : join S1 S1 = mapJoin (join bool bool) S1 S1 S1 c (idfun S1) x3 93 | in res 94 | 95 | prealpha : join S1 S1 -> S2 = split 96 | inl x -> north 97 | inr y -> north 98 | pushC x y @ i -> composition S2 north south north (merid1 S1 x) ( merid1 S1 y @ -i) @ i 99 | 100 | alpha : pmap (joinpt S1pt S1) S2pt = (prealpha, <_> north) 101 | -------------------------------------------------------------------------------- /cubicaltt/src/lambek.ctt: -------------------------------------------------------------------------------- 1 | {- Lambek Encoding: 2 | Copyright (c) Groupoid Infinity, 2014-2018 3 | 4 | see HoTT 5.4 Inductive types are initial algebras -} 5 | 6 | module lambek where 7 | import proto 8 | import path 9 | import nat 10 | import set 11 | import iso_sigma 12 | import iso_pi 13 | 14 | {- Definition 5.4.1. A Nat-algebra 15 | Definition 5.4.2. Nat Homomorphism -} 16 | 17 | natOb: U 18 | = (X: U) 19 | * (zero: X) 20 | * (succ: X -> X) 21 | * unit 22 | 23 | natHom (x1 x2: natOb): U 24 | = (map: x1.1 -> x2.1) 25 | * (mapZero: Path x2.1 (map (x1.2.1)) (x2.2.1)) 26 | * (mapSucc: (x: x1.1) -> Path x2.1 (map (x1.2.2.1 x)) (x2.2.2.1 (map x))) 27 | * unit 28 | 29 | isHomotopyInitialNat (I: natOb): U 30 | = (C: natOb) 31 | * (x: natHom I C) 32 | * ((y: natHom I C) -> Path (natHom I C) x y) 33 | 34 | listOb (A: U): U = (X: U) * (nil: X) * (cons: A -> X -> X) * unit 35 | listHom (A: U) (x1 x2: listOb A): U 36 | = (map: x1.1 -> x2.1) 37 | * (mapNil: Path x2.1 (map (x1.2.1)) (x2.2.1)) 38 | * (mapCons: (a:A) (x: x1.1) -> Path x2.1 (map (x1.2.2.1 a x)) (x2.2.2.1 a (map x))) * unit 39 | 40 | isHomotopyInitialList (A: U) (I: listOb A): U = (C: listOb A) -> isContr(listHom A I C) 41 | 42 | -------------------------------------------------------------------------------- /cubicaltt/src/list.ctt: -------------------------------------------------------------------------------- 1 | {- Run-Time List Type: 2 | - List; 3 | - Polymorphic funtions. 4 | Copyright (c) Groupoid Infinity, 2014-2018. -} 5 | 6 | module list where 7 | 8 | import eq 9 | import nat 10 | import maybe 11 | import proto 12 | 13 | data list (A: U) = nil | cons (a: A) (as: list A) 14 | 15 | listCase (A C:U) (a b: C): list A -> C 16 | = split { nil -> a ; cons x xs -> b } 17 | 18 | listRec (A C:U) (z: C) (s: A->list A->C->C): (n:list A) -> C 19 | = split { nil -> z ; cons x xs -> s x xs (listRec A C z s xs) } 20 | 21 | listElim (A: U) (C:list A->U) (z: C nil) (s: (x:A)(xs:list A)->C(cons x xs)): (n:list A) -> C(n) 22 | = split { nil -> z ; cons x xs -> s x xs } 23 | 24 | listInd (A: U) (C:list A->U) (z: C nil) (s: (x:A)(xs:list A)->C(xs)->C(cons x xs)): (n:list A) -> C(n) 25 | = split { nil -> z ; cons x xs -> s x xs (listInd A C z s xs) } 26 | 27 | null (A: U): list A -> bool = split 28 | nil -> true 29 | cons x xs -> false 30 | 31 | head (A: U): list A -> maybe A = split 32 | nil -> nothing 33 | cons x xs -> just x 34 | 35 | tail (A: U): list A -> maybe (list A) = split 36 | nil -> nothing 37 | cons x xs -> just xs 38 | 39 | nth (A: U): nat -> list A -> maybe A = split 40 | zero -> split@(list A -> maybe A) with 41 | nil -> nothing 42 | cons x xs -> just x 43 | succ i -> split@(list A -> maybe A) with 44 | nil -> nothing 45 | cons x xs -> nth A (pred i) xs 46 | 47 | append (A: U): list A -> list A -> list A = split 48 | nil -> idfun (list A) 49 | cons x xs -> \(ys: list A) -> cons x (append A xs ys) 50 | 51 | reverse (A: U): list A -> list A = rev nil where 52 | rev (acc: list A): list A -> list A = split 53 | nil -> acc 54 | cons x xs -> rev (cons x acc) xs 55 | 56 | map (A B: U) (f: A -> B) : list A -> list B = split 57 | nil -> nil 58 | cons x xs -> cons (f x) (map A B f xs) 59 | 60 | zipWith (A B C: U) (f: A -> B -> C): list A -> list B -> list C = go where 61 | go: list A -> list B -> list C = split 62 | nil -> split@(list B->list C) with { nil -> nil ; cons y ys -> nil } 63 | cons x xs -> split@(list B->list C) with { nil->nil ; cons y ys -> cons (f x y) (go xs ys) } 64 | 65 | zip (A B: U): list A -> list B -> list (tuple A B) 66 | = zipWith A B (tuple A B) (\(x:A)(y:B) -> pair x y) 67 | 68 | foldr (A B: U) (f: A -> B -> B) (Z: B): list A -> B = split 69 | nil -> Z 70 | cons x xs -> f x (foldr A B f Z xs) 71 | 72 | foldl (A B: U) (f: B -> A -> B) (Z: B): list A -> B = split 73 | nil -> Z 74 | cons x xs -> foldl A B f (f Z x) xs 75 | 76 | switch (A: U) (a b: unit -> list A) : bool -> list A = split 77 | false -> b tt 78 | true -> a tt 79 | 80 | filter (A: U) (p: A -> bool) : list A -> list A = split 81 | nil -> nil 82 | cons x xs -> switch A (\(_:unit) -> cons x (filter A p xs)) 83 | (\(_:unit) -> filter A p xs) (p x) 84 | 85 | uncons (A: U): list A -> maybe ((a: A) * (list A)) = split 86 | nil -> nothing 87 | cons x xs -> just (x,xs) 88 | 89 | length (A: U): list A -> nat = split 90 | nil -> zero 91 | cons x xs -> add one (length A xs) 92 | 93 | list_eq (A: eq_): list A.1 -> list A.1 -> bool = split 94 | nil -> split@(list A.1 -> bool) with 95 | nil -> true 96 | cons b bs -> false 97 | cons x xs -> split@(list A.1 -> bool) with 98 | nil -> false 99 | cons a as -> or (A.2 a x) (list_eq A xs as) 100 | 101 | -------------------------------------------------------------------------------- /cubicaltt/src/list_theory.ctt: -------------------------------------------------------------------------------- 1 | {- List Theorems: 2 | - Functor and Inductive instances 3 | Copyright (c) Groupoid Infinity, 2014-2018. -} 4 | 5 | module list_theory where 6 | 7 | import proto 8 | import list 9 | import control 10 | import recursion 11 | import nat_theory 12 | 13 | -- theorems 14 | assoc (A:U) : (xs ys zs : list A) -> 15 | Path (list A) (append A (append A xs ys) zs) (append A xs (append A ys zs)) = split 16 | nil -> \ (ys zs:list A) -> append A ys zs 17 | cons x xs -> \ (ys zs:list A) -> cons x (assoc A xs ys zs@i) 18 | 19 | lem (A B C:U) (f:A->B) (g:B -> C) : (xs:list A) -> 20 | Path (list C) (map B C g (map A B f xs)) (map A C (\ (x:A) -> g (f x)) xs) = split 21 | nil -> nil 22 | cons x xs -> cons (g (f x)) (lem A B C f g xs@i) 23 | 24 | lem2 (A:U) : (xs:list A) -> Path (list A) (append A xs nil) xs = split 25 | nil -> nil 26 | cons x xs -> cons x (lem2 A xs@i) 27 | 28 | list_id (A:U) : (xs:list A) -> Path (list A) (map A A (idfun A) xs) xs = split 29 | nil -> nil 30 | cons x xs -> cons x (list_id A xs@i) 31 | 32 | list_compose (A B C: U) (f: B->C) (g: A->B): (x: list A) -> 33 | Path (list C) (map A C (o A B C f g) x) 34 | ((o (list A) (list B) (list C) (map B C f) (map A B g)) x) = split 35 | nil -> nil 36 | cons x xs -> cons ((o A B C f g) x) (list_compose A B C f g xs@i) 37 | 38 | -- Type-class instances 39 | eq_list_nat: eq_ = (list nat, list_eq eq_nat) 40 | eq_list_list_nat: eq_ = (list (list nat), list_eq eq_list_nat) 41 | pure_list: pure = (list,\(A:U)(x:A)->cons x nil) 42 | functor_list: functor = (list,map) 43 | functor_laws: FUNCTOR = (functor_list,list_id,list_compose,tt) 44 | ind_list (T:U): ind list T = inductive (list,map) T 45 | coind_list (T:U): coind list T = coinductive (list,map) T 46 | 47 | -------------------------------------------------------------------------------- /cubicaltt/src/localization.ctt: -------------------------------------------------------------------------------- 1 | module localization where 2 | import proto 3 | import path 4 | 5 | -- This definition of localization is internal, stronger than 6 | -- standard sort of localization in homotopy theory; 7 | - but remains equivalent. 8 | 9 | -- Localization Modality (S=B, T=C) 10 | 11 | data Localize (A X: U) (S T: A -> U) (F : (x:A) -> S x -> T x) 12 | = center (x: X) 13 | | ext (a: A) (f: S a -> Localize A X S T F) (t: T a) 14 | | isExt (a: A) (f: S a -> Localize A X S T F) (s: S a) 15 | [ (i=0) -> ext a f (F a s) , (i=1) -> f s ] 16 | | extEq (a: A) (g h: T a -> Localize A X S T F) 17 | (p: (s : S a) -> Path (Localize A X S T F) (g (F a s)) (h (F a s))) 18 | (t : T a) [ (i=0) -> g t , (i=1) -> h t ] 19 | | isExtEq (a: A) (g h : T a -> Localize A X S T F) 20 | (p: (s : S a) -> Path (Localize A X S T F) (g (F a s)) (h (F a s))) 21 | (s : S a) [ (i=0) -> extEq {Localize A X S T F} a g h p (F a s) @ i, (i=1) -> p s @ i] 22 | 23 | isLocal (A X: U) (S T: A -> U) (F : (x:A) -> S x -> T x) : U = undefined 24 | 25 | LocalizationRec (A X: U) (S T: A -> U) (F : (x:A) -> S x -> T x) 26 | (Y : U) 27 | (locality : isLocal A Y S T F) 28 | (f: X -> Y) 29 | : Localize A X S T F -> Y 30 | = undefined 31 | 32 | LocalizationInd (A X : U) (S T : A -> U) (F : (x:A) -> S x -> T x) 33 | (P : Localize A X S T F -> U) 34 | (n : (x : X) -> P (center x)) 35 | (r : (a : A) (f: S a -> Localize A X S T F) 36 | (g: (b: S a) -> P (f b)) 37 | (t: T a) -> P (ext a f t)) 38 | (s : (a : A) (f: S a -> Localize A X S T F) 39 | (g: (b: S a) -> P (f b)) 40 | (b: S a) -> PathP ( P (isExt {Localize A X S T F} a f b @ i)) 41 | (r a f g (F a b)) (g b)) 42 | : (x : Localize A X S T F) -> P x 43 | = undefined 44 | 45 | -------------------------------------------------------------------------------- /cubicaltt/src/logic.ctt: -------------------------------------------------------------------------------- 1 | module logic where 2 | 3 | -- https://github.com/jonaprieto/agda-prop 4 | -- Cai, L., Kaposi, A., & Altenkirch, T. (2015) 5 | -- Formalising the Completeness Theorem of Classical Propositional Logic in Agda. 6 | -- Retrieved from https://akaposi.github.io/proplogic.pdf 7 | 8 | -- data PropFormula : Set where 9 | -- Var : Fin n → PropFormula 10 | -- ⊤ : PropFormula 11 | -- ⊥ : PropFormula 12 | -- _∧_ _∨_ _⊃_ _⇔_ : (φ ψ : PropFormula) → PropFormula 13 | -- ¬_ : (φ : PropFormula) → PropFormula 14 | 15 | -- _,_ : Ctxt → PropFormula → Ctxt 16 | -- Γ , φ = Γ ++ [ φ ] 17 | 18 | -- ∅ : Ctxt 19 | -- ∅ = [] 20 | 21 | -- infix 30 _⨆_ 22 | -- _⨆_ : Ctxt → Ctxt → Ctxt 23 | -- Γ ⨆ Δ = Γ ++ Δ 24 | 25 | -- Ctxt : Set 26 | -- Ctxt = List PropFormula 27 | 28 | -- infix 11 ¬_ 29 | -- infixl 8 _∧_ _∨_ 30 | -- infixr 7 _⊃_ _⇔_ 31 | 32 | -- data _⊢_ : Ctxt → PropFormula → Set where 33 | -- assume : ∀ {Γ} → (φ : PropFormula) → Γ , φ ⊢ φ 34 | -- axiom : ∀ {Γ} → (φ : PropFormula) → φ ∈ Γ → Γ ⊢ φ 35 | -- weaken : ∀ {Γ} {φ} → (ψ : PropFormula) → Γ ⊢ φ → Γ , ψ ⊢ φ 36 | -- weaken₂ : ∀ {Γ} {φ} → (ψ : PropFormula) → Γ ⊢ φ → ψ ∷ Γ ⊢ φ 37 | -- ⊤-intro : ∀ {Γ} → Γ ⊢ ⊤ 38 | -- ⊥-elim : ∀ {Γ} → (φ : PropFormula) → Γ ⊢ ⊥ → Γ ⊢ φ 39 | -- ¬-intro : ∀ {Γ} {φ} → Γ , φ ⊢ ⊥ → Γ ⊢ ¬ φ 40 | -- ¬-elim : ∀ {Γ} {φ} → Γ ⊢ ¬ φ → Γ ⊢ φ → Γ ⊢ ⊥ 41 | -- ∧-intro : ∀ {Γ} {φ ψ} → Γ ⊢ φ → Γ ⊢ ψ → Γ ⊢ φ ∧ ψ 42 | -- ∧-proj₁ : ∀ {Γ} {φ ψ} → Γ ⊢ φ ∧ ψ → Γ ⊢ φ 43 | -- ∧-proj₂ : ∀ {Γ} {φ ψ} → Γ ⊢ φ ∧ ψ → Γ ⊢ ψ 44 | -- ∨-intro₁ : ∀ {Γ} {φ} → (ψ : PropFormula) → Γ ⊢ φ → Γ ⊢ φ ∨ ψ 45 | -- ∨-intro₂ : ∀ {Γ} {ψ} → (φ : PropFormula) → Γ ⊢ ψ → Γ ⊢ φ ∨ ψ 46 | -- ∨-elim : ∀ {Γ} {φ ψ χ} → Γ , φ ⊢ χ → Γ , ψ ⊢ χ → Γ , φ ∨ ψ ⊢ χ 47 | -- ⊃-intro : ∀ {Γ} {φ ψ} → Γ , φ ⊢ ψ → Γ ⊢ φ ⊃ ψ 48 | -- ⊃-elim : ∀ {Γ} {φ ψ} → Γ ⊢ φ ⊃ ψ → Γ ⊢ φ → Γ ⊢ ψ 49 | -- ⇔-intro : ∀ {Γ} {φ ψ} → Γ , φ ⊢ ψ → Γ , ψ ⊢ φ → Γ ⊢ φ ⇔ ψ 50 | -- ⇔-elim₁ : ∀ {Γ} {φ ψ} → Γ ⊢ φ → Γ ⊢ φ ⇔ ψ → Γ ⊢ ψ 51 | -- ⇔-elim₂ : ∀ {Γ} {φ ψ} → Γ ⊢ ψ → Γ ⊢ φ ⇔ ψ → Γ ⊢ φ 52 | 53 | -------------------------------------------------------------------------------- /cubicaltt/src/manifold.ctt: -------------------------------------------------------------------------------- 1 | module manifold where 2 | import etale 3 | 4 | HomogeneousStructure (V: U): U = undefined 5 | et (A B: U): EtaleMap A B -> (A -> B) = undefined 6 | isSurjective (A B: U) (f: A -> B): U = undefined 7 | 8 | manifold (V': U) (V: HomogeneousStructure V'): U 9 | = (M: U) 10 | * (W: U) 11 | * (w: EtaleMap W M) 12 | * (covers: isSurjective W M (et W M w)) 13 | * ( EtaleMap W V') 14 | 15 | -------------------------------------------------------------------------------- /cubicaltt/src/maybe.ctt: -------------------------------------------------------------------------------- 1 | {- Run-time Maybe Type: 2 | Copyright (c) Groupoid Infinity, 2014-2018. -} 3 | 4 | module maybe where 5 | import proto 6 | import path 7 | 8 | data maybe (A: U) = nothing | just (a: A) 9 | 10 | fromMaybe (A: U) (n: A): maybe A->A = split { nothing -> n; just a -> a} 11 | maybeMap (A B: U) (f: A->B): maybe A->maybe B = split { nothing -> nothing; just x -> just (f x) } 12 | maybeRec (A P: U) (n: P) (j: A->P): maybe A->P = split { nothing -> n; just a -> j a} 13 | maybeInd (A: U) (P: maybe A -> U) (n: P nothing) (j: (a: A) -> P (just a)): 14 | (a: maybe A) -> P a = split { nothing -> n ; just x -> j x } 15 | 16 | maybeId (A: U): maybe A->maybe A = maybeMap A A (idfun A) 17 | maybeRefl (A: U) (a: maybe A): Path (maybe A) a a = refl (maybe A) a 18 | maybeIsElim (A: U): (a: maybe A) -> Path (maybe A) a (maybeRec A (maybe A) nothing (\(a:A) -> just a) a) 19 | = split { nothing -> maybeRefl A nothing ; just x -> maybeRefl A (just x) } 20 | -- usage 21 | -- maybeElim nat nat zero (\ (x: nat) -> x) (just zero) 22 | -- law of maybeElim 23 | -- maybe_ nothing just a == a 24 | -------------------------------------------------------------------------------- /cubicaltt/src/maybe_nat.ctt: -------------------------------------------------------------------------------- 1 | module maybe_nat where 2 | -- by @esmolanka 3 | -- here is simple one tweet equality sample with transport 4 | 5 | -- Nat ~ Fix Maybe 6 | -- Z ~ Nothing 7 | -- S ~ Fix . Just 8 | 9 | import nat 10 | import maybe 11 | import control 12 | import recursion 13 | import proto 14 | import path 15 | import set 16 | import iso 17 | 18 | three: fix maybe = Fix (just (Fix (just (Fix (just (Fix nothing)))))) 19 | 20 | natToMaybe: nat -> fix maybe = split 21 | zero -> Fix nothing 22 | succ n -> Fix (just (natToMaybe n)) 23 | 24 | maybeToNat: fix maybe -> nat = split 25 | Fix m -> go m where go: maybe (fix maybe) -> nat = split 26 | nothing -> zero 27 | just f -> succ (maybeToNat f) 28 | 29 | natMaybeIso: (a: nat) -> Path nat (maybeToNat (natToMaybe a)) a = split 30 | zero -> zero 31 | succ n -> succ (natMaybeIso n @ i) 32 | 33 | maybeNatIso : (a : fix maybe) -> Path (fix maybe) (natToMaybe (maybeToNat a)) a = split 34 | Fix m -> go m where go: (a: maybe (fix maybe)) -> Path (fix maybe) (natToMaybe (maybeToNat (Fix a))) (Fix a) = split 35 | nothing -> Fix nothing 36 | just f -> Fix (just (maybeNatIso f @ i)) 37 | 38 | maybenat: Path U (fix maybe) nat = isoPath (fix maybe) nat maybeToNat natToMaybe natMaybeIso maybeNatIso 39 | 40 | HeteroEqu (A B:U)(a:A)(b:B)(P:Path U A B):U = PathP P a b 41 | 42 | -- > HeteroEqu (fix maybe) nat (Fix nothing) zero maybenat 43 | 44 | -- > transNeg (fix maybe) (nat) maybenat (succ (succ zero)) 45 | -- EVAL: Fix (just (Fix (just (Fix nothing)))) 46 | -- > trans (fix maybe) (nat) maybenat (Fix nothing) 47 | -- EVAL: zero 48 | 49 | -- import univalence 50 | 51 | -- natEquiv : isEquiv nat (fix maybe) natToMaybe = 52 | -- isoToEquiv 53 | -- nat (fix maybe) 54 | -- natToMaybe maybeToNat 55 | -- maybeNatIso natMaybeIso 56 | 57 | -- natEq : Path U nat (fix maybe) = 58 | -- ua nat (fix maybe) (natToMaybe, natEquiv) 59 | 60 | -- > transport natEq (succ (succ zero)) 61 | -- EVAL: Fix (just (Fix (just (Fix nothing)))) 62 | -- > transport ( natEq @ -i) (Fix (just (Fix (just (Fix (just (Fix nothing))))))) 63 | -- EVAL: succ (succ (succ zero)) 64 | -------------------------------------------------------------------------------- /cubicaltt/src/maybe_theory.ctt: -------------------------------------------------------------------------------- 1 | module maybe_theory where 2 | 3 | import functor 4 | import maybe 5 | 6 | -- maybeMap idfun a == a 7 | functorMaybeId (A: U): (a: maybe A) -> Path (maybe A) (maybeId A a) a 8 | = split { nothing -> maybeRefl A nothing ; just x -> maybeRefl A (just x) } 9 | 10 | -- maybeMap id == id 11 | functorMaybeIdFunExt (A: U): Path (maybe A -> maybe A) (maybeId A) (idfun (maybe A)) 12 | = funext (maybe A) (maybe A) (maybeId A) (idfun (maybe A)) (functorMaybeId A) 13 | 14 | -- an alternative proof of functorMaybeId using maybeDElim 15 | functorMaybeId2 (A: U): (a: maybe A) -> Path (maybe A) (maybeId A a) a 16 | = maybeInd A P (maybeRefl A nothing) (\(c:A) -> maybeRefl A (just c)) where 17 | P (x: maybe A): U = Path (maybe A) (maybeId A x) x 18 | 19 | functorMaybeComp (A B C: U) (f: B -> C) (g: A -> B): 20 | (x: maybe A) -> Path (maybe C) (maybeMap A C (o A B C f g) x) 21 | ((o (maybe A) (maybe B) (maybe C) (maybeMap B C f) (maybeMap A B g)) x) 22 | = split { nothing -> maybeRefl C ((maybeMap A C (o A B C f g)) nothing) ; 23 | just x -> maybeRefl C ((maybeMap A C (o A B C f g)) (just x)) } 24 | 25 | functor_maybe: FUNCTOR = ((maybe,maybeMap),(functorMaybeId,functorMaybeComp,tt)) 26 | 27 | -------------------------------------------------------------------------------- /cubicaltt/src/mltt.ctt: -------------------------------------------------------------------------------- 1 | {- MLTT Reality Check: 2 | - Empty, Pi, Sigma, Equ, W. 3 | Copyright (c) Groupoid Infinity, 2014-2018. -} 4 | 5 | module mltt where 6 | 7 | 8 | -- Pi built-in type (axioms) 9 | Pi (A: U) (B: A -> U): U = (x: A) -> B x 10 | lambda (A: U) (B: A -> U) (b: Pi A B): Pi A B = \(x: A) -> b x 11 | app (A: U) (B: A -> U) (f: Pi A B) (a: A): B a = f a 12 | 13 | -- Sigma built-in type (optional) 14 | Sigma (A: U) (B: A -> U): U = (x: A) * B x 15 | pair (A: U) (B: A -> U) (a: A) (b: B a): Sigma A B = (a,b) 16 | pr1 (A: U) (B: A -> U) (x: Sigma A B): A = x.1 17 | pr2 (A: U) (B: A -> U) (x: Sigma A B): B (pr1 A B x) = x.2 18 | 19 | -- W-Types (Well Founded Trees) 20 | W (A:U) (B:A->U): U = (x:A) * (B(x) -> W A B) 21 | Wrec (A:U) (B:A->U) (P:U) (alg: (a:A) -> (B(a)->W A B) -> ((b:B(a))->P) -> P) 22 | : (w: W A B) -> P = \(w:W A B) -> alg w.1 w.2 (\(b:B(w.1)) -> Wrec A B P alg (w.2 b)) 23 | Wind (A:U) (B:A->U) (P:W A B -> U) (alg: (a:A) (f:B(a)->W A B) -> ((b:B(a))->P (f b)) -> P (a,f)) 24 | : (w: W A B) -> P w = \(w:W A B) -> alg w.1 w.2 (\(b:B(w.1)) -> Wind A B P alg (w.2 b)) 25 | 26 | -- Heterogeneous built-in type (Path formation axioms) 27 | Path (A: U) (a b: A): U = PathP (A) a b 28 | HeteroEqu (A B: U) (a: A) (b: B) (P: Path U A B) : U = PathP P a b 29 | 30 | -- Equality Type, mostly built-in (trans, subst, refl, cong, contr axioms) 31 | Equ (A: U) (x y: A): U = HeteroEqu A A x y (A) 32 | reflect (A: U) (a: A): Equ A a a = a 33 | D (A: U) : U = (x y: A) -> Equ A x y -> U 34 | singl (A: U) (a: A): U = (x: A) * Equ A a x 35 | ap (A B: U) (f: A->B) (a b: A) (p: Equ A a b): Equ B (f a) (f b) = f (p @ i) 36 | eta (A: U) (a: A): singl A a = (a,reflect A a) 37 | contr (A: U) (a b: A) (p: Equ A a b): Equ (singl A a) (eta A a) (b,p) = (p@i,p@i/\j) 38 | subst (A: U) (P: A->U) (a b: A) (p: Equ A a b) (e: P a): P b = transport (ap A U P a b p) e 39 | trans (A B: U) (p: Path U A B) (a : A): B = comp p a [] 40 | 41 | -- Theorems: 42 | -- 1) Diagonal Version of J 43 | J (A: U) (x: A) (C: D A) (d: C x x (reflect A x)) (y: A) (p: Equ A x y) : C x y p 44 | = subst (singl A x) (\(z: singl A x) -> C x (z.1) (z.2)) (eta A x) (y, p) (contr A x y p) d 45 | -- T (z: singl A x): U = C x (z.1) (z.2) 46 | 47 | -- 2) Computational Rules 48 | trans_comp (A:U)(a:A): Path A a (trans A A ( A) a) = fill ( A) a [] 49 | subst_comp (A:U)(P:A->U)(a:A)(e:P(a)): Path (P a) e (subst A P a a (reflect A a) e) = trans_comp (P a) e 50 | 51 | comp1 (A:U)(B:A->U)(a:A)(f: Pi A B): Equ (B a) (app A B (lambda A B f) a) (f a) = reflect (B a) (f a) -- beta 52 | comp2 (A:U)(B:A->U)(a:A)(f: Pi A B): Equ (Pi A B) f (\(x:A) -> f x) = reflect (Pi A B) f -- eta 53 | comp3 (A:U)(B:A->U)(a:A)(b: B a): Equ A a (pr1 A B (a,b)) = reflect A a -- 1 54 | comp4 (A:U)(B:A->U)(a:A)(b: B a): Equ (B a) b (pr2 A B (a,b)) = reflect (B a) b -- 2 55 | comp5 (A:U)(B:A->U)(p: Sigma A B): Equ (Sigma A B) p (pr1 A B p,pr2 A B p) = reflect (Sigma A B) p -- 3 56 | comp6 (A:U)(a:A)(C: D A) (d: C a a (reflect A a)) 57 | : Path (C a a (reflect A a)) d (J A a C d a (reflect A a)) 58 | = subst_comp (singl A a) T (eta A a) d where T (z: singl A a) : U = C a (z.1) (z.2) 59 | 60 | -- 3a) MLTT Model 61 | MLTT (A: U): U 62 | = (Pi_Former: (A -> U) -> U) 63 | * (Pi_Intro: (B: A -> U) -> Pi A B -> Pi A B) 64 | * (Pi_Elim: (B: A -> U) -> Pi A B -> Pi A B) 65 | * (Pi_Comp1: (B: A -> U) (a: A) (f: Pi A B) -> Equ (B a) (Pi_Elim B (Pi_Intro B f) a) (f a)) 66 | * (Pi_Comp2: (B: A -> U) (a: A) (f: Pi A B) -> Equ (Pi A B) f (\(x:A) -> f x)) 67 | * (Sigma_Former: (A -> U) -> U) 68 | * (Sigma_Intro: (B: A -> U) (a: A) -> (b: B a) -> Sigma A B) 69 | * (Sigma_Elim1: (B: A -> U) (_: Sigma A B) -> A) 70 | * (Sigma_Elim2: (B: A -> U) (x: Sigma A B) -> B (pr1 A B x)) 71 | * (Sigma_Comp1: (B: A -> U) (a: A) (b: B a) -> Equ A a (Sigma_Elim1 B (Sigma_Intro B a b))) 72 | * (Sigma_Comp2: (B: A -> U) (a: A) (b: B a) -> Equ (B a) b (Sigma_Elim2 B (a,b))) 73 | * (Sigma_Comp3: (B: A -> U) (p: Sigma A B) -> Equ (Sigma A B) p (pr1 A B p,pr2 A B p)) 74 | * (Id_Former: A -> A -> U) 75 | * (Id_Intro: (a: A) -> Equ A a a) 76 | * (Id_Elim: (x: A) (C: D A) (d: C x x (Id_Intro x)) (y: A) (p: Equ A x y) -> C x y p) 77 | * (Id_Comp: (a:A)(C: D A) (d: C a a (Id_Intro a)) -> 78 | Path (C a a (Id_Intro a)) d (Id_Elim a C d a (Id_Intro a))) * U 79 | 80 | -- 3b) MLTT Instantiation 81 | instance (A: U): MLTT A 82 | = (Pi A, lambda A, app A, comp1 A, comp2 A, 83 | Sigma A, pair A, pr1 A, pr2 A, comp3 A, comp4 A, comp5 A, 84 | Equ A, reflect A, J A, comp6 A, A) 85 | -------------------------------------------------------------------------------- /cubicaltt/src/modality.ctt: -------------------------------------------------------------------------------- 1 | module modality where 2 | import proto 3 | import path 4 | 5 | Modality : U 6 | = (isModal : U -> U) 7 | * (isPropIsModal : (A : U) -> isProp (isModal A)) 8 | * (modality: U -> U) 9 | * (modalityIsModal : (A : U) -> isModal (modality A)) 10 | * (eta: (A : U) -> A -> modality A) 11 | * (elim: (A : U) (B : modality A -> U) 12 | (BModal : (x : modality A) -> isModal (B x)) 13 | (f: (x : A) -> (B (eta A x))) -> ((x : modality A) -> B x)) 14 | * (elimBeta : (A : U) (B : modality A -> U) 15 | (BModal : (x : modality A) -> isModal (B x)) 16 | (f : (x : A) -> (B (eta A x))) 17 | (a : A) -> Path (B (eta A a)) (elim A B BModal f (eta A a)) (f a)) 18 | * (isModal: (A : U) (x y : modality A) -> isModal (Path (modality A) x y)) 19 | * unit 20 | 21 | -- MODALITIES IN HOMOTOPY TYPE THEORY 22 | -- Egbert Rijke, Michael Shulman, Bas Spitters 23 | -- https://arxiv.org/pdf/1706.07526v4.pdf 24 | -------------------------------------------------------------------------------- /cubicaltt/src/model.htt: -------------------------------------------------------------------------------- 1 | {- Homotopical Algebra: 2 | - Model Categories 3 | - Model Structures 4 | Copyright (c) Groupoid Infinity, 2020. -} 5 | 6 | module model where 7 | import category 8 | 9 | -- https://www.matem.unam.mx/~omar/notes/modelcatsets.html 10 | -- https://web.math.rochester.edu/people/faculty/doug/otherpapers/pshmain.pdf 11 | -- https://www.uio.no/studier/emner/matnat/math/MAT9580/v18/documents/modcat.pdf 12 | 13 | -- Definition. (Quillen) model structure. 14 | -- By a model category we mean a category C 15 | -- with three classes of maps: 16 | -- 1) fibrations, 17 | -- 2) cofibrations, 18 | -- 3) weak equivalences. 19 | 20 | modelStructure (C: U): U 21 | = (fibrations: fib C) 22 | * (cofibrations: cofib C) 23 | * (weakEqivalences: weak C) 24 | * unit 25 | 26 | -- 5 out of 9 model structures on category of sets 27 | 28 | set0: modelStructure Set = (any,any,bijections) 29 | set1: modelStructure Set = (bijections,any,any) 30 | set2: modelStructure Set = (any,bijections,any) 31 | set3: modelStructure Set = (surjections,injections,any) 32 | set4: modelStructure Set = (injections,surjections,any) 33 | 34 | -- 2 model structures on category of topological spaces 35 | 36 | quillen67: modelStructure Top = (serreFibrations,retractsCW,weakHomotopyEquivalence) 37 | strom1972: modelStructure Top = (hurewiczFibrations,cofibrations,strongHomotopyEquivalence) 38 | 39 | -- Simplicial model structure 40 | 41 | simplicial: modelStructure sSet = (kanComplexes,monos,simplicialBijections) 42 | -------------------------------------------------------------------------------- /cubicaltt/src/nat.ctt: -------------------------------------------------------------------------------- 1 | {- Run-Time Nat Type: 2 | - Nat and Fin; 3 | - Polymorphic funtions. 4 | Copyright (c) Groupoid Infinity, 2014-2018. 5 | 6 | HoTT 1.9 The natural numbers 7 | HoTT 2.13 Natural numbers -} 8 | 9 | module nat where 10 | 11 | import maybe 12 | import bool 13 | import proto 14 | import sigma 15 | 16 | data nat -- ℕ 17 | = zero 18 | | succ (n: nat) 19 | 20 | data natinf -- ℕ-∞ 21 | = zero 22 | | succ (n: natinf) 23 | | inf 24 | | succ_inf 25 | [ (i=0) -> inf {natinf} @ i , 26 | (i=1) -> succ {natinf} inf @ i ] 27 | 28 | one : nat = succ zero 29 | two : nat = succ one 30 | three : nat = succ two 31 | four : nat = succ three 32 | five : nat = succ four 33 | six : nat = succ five 34 | seven : nat = succ six 35 | 36 | natCase (C:U) (a b: C): nat -> C 37 | = split { zero -> a ; succ n -> b } 38 | 39 | natRec (C:U) (z: C) (s: nat->C->C): (n:nat) -> C 40 | = split { zero -> z ; succ n -> s n (natRec C z s n) } 41 | 42 | natElim (C:nat->U) (z: C zero) (s: (n:nat)->C(succ n)): (n:nat) -> C(n) 43 | = split { zero -> z ; succ n -> s n } 44 | 45 | natInd (C:nat->U) (z: C zero) (s: (n:nat)->C(n)->C(succ n)): (n:nat) -> C(n) 46 | = split { zero -> z ; succ n -> s n (natInd C z s n) } 47 | 48 | natEq: nat -> nat -> bool = split 49 | zero -> split@(nat -> bool) with { zero -> true; succ n -> false } 50 | succ m -> split@(nat -> bool) with { zero -> false; succ n -> natEq m n } 51 | 52 | pred: nat -> nat = split { zero -> zero ; succ n -> n } 53 | add (m: nat): nat -> nat = split { zero -> m; succ n -> succ (add m n) } 54 | 55 | mult: nat -> nat -> nat 56 | = natRec (nat->nat) (\(_:nat) -> zero) 57 | (\(_:nat) (mult_:nat->nat) (m:nat) -> add m (mult_ m)) 58 | 59 | exponent : nat -> nat -> nat = 60 | \(x:nat) (power:nat) -> 61 | (natRec (nat->nat) (\(_:nat) -> one) 62 | (\(_:nat) (exponent_:nat->nat) (m:nat) -> mult m (exponent_ m))) 63 | power x 64 | 65 | succ2 (x : nat) : nat = succ (succ x) 66 | succ3 (x : nat) : nat = succ (succ2 x) 67 | succ4 (x : nat) : nat = succ (succ3 x) 68 | succ5 (x : nat) : nat = succ (succ4 x) 69 | 70 | n0 : nat = zero 71 | n1 : nat = succ n0 72 | n2 : nat = succ n1 73 | n3 : nat = succ n2 74 | n4 : nat = succ n3 75 | n5 : nat = succ n4 76 | n6 : nat = succ n5 77 | n7 : nat = succ n6 78 | n8 : nat = succ n7 79 | n9 : nat = succ n8 80 | n10 : nat = succ n9 81 | n11 : nat = succ n10 82 | n12 : nat = succ n11 83 | n13 : nat = succ n12 84 | n14 : nat = succ n13 85 | n15 : nat = succ n14 86 | n16 : nat = succ n15 87 | n17 : nat = succ n16 88 | n18 : nat = succ n17 89 | n19 : nat = succ n18 90 | n20 : nat = succ n19 91 | 92 | {- Finite Set Datatype -} 93 | 94 | data Fin (n: nat) = fzero | fsucc (_: Fin (pred n)) 95 | fz (n: nat): Fin (succ n) = fzero 96 | fs (n: nat): Fin n -> Fin (succ n) = \(x: Fin n) -> fsucc x 97 | 98 | opaque Fin 99 | 100 | fin11: Fin one = fz zero 101 | fin21: Fin two = fz one 102 | fin22: Fin two = fs one fin11 103 | fin31: Fin three = fz two 104 | fin32: Fin three = fs two fin21 105 | fin33: Fin three = fs two fin22 106 | 107 | -- realityCheck : Equ nat (add n4 n5) n0 = refl nat n9 108 | -------------------------------------------------------------------------------- /cubicaltt/src/nat_theory.ctt: -------------------------------------------------------------------------------- 1 | {- Nat Theory: 2 | Copyright (c) Groupoid Infinity, 2014-2018. -} 3 | 4 | module nat_theory where 5 | import path 6 | import prop 7 | import pi 8 | import iso 9 | import nat 10 | import eq 11 | import hedberg 12 | 13 | add_zero : (n : nat) -> Path nat (add zero n) n = split 14 | zero -> zero 15 | succ n -> succ (add_zero n @ i) 16 | 17 | add_succ (a:nat) : (n : nat) -> Path nat (add (succ a) n) (succ (add a n)) = split 18 | zero -> succ a 19 | succ m -> succ (add_succ a m @ i) 20 | 21 | add_comm (a : nat) : (n : nat) -> Path nat (add a n) (add n a) = split 22 | zero -> add_zero a @ -i 23 | succ m -> comp (<_> nat) (succ (add_comm a m @ i)) 24 | [ (i = 0) -> succ (add a m) 25 | , (i = 1) -> add_succ m a @ -j ] 26 | 27 | assocAdd (a b:nat) : (c:nat) -> Path nat (add a (add b c)) (add (add a b) c) = split 28 | zero -> add a b 29 | succ c1 -> succ (assocAdd a b c1@i) 30 | 31 | add' : nat -> nat -> nat = split 32 | zero -> \(x : nat) -> x 33 | succ n -> \(x : nat) -> succ (add' n x) 34 | 35 | sucInj (n m : nat) (p : Path nat (succ n) (succ m)) : Path nat n m = 36 | pred (p @ i) 37 | 38 | addZero : (a : nat) -> Path nat (add zero a) a = split 39 | zero -> zero 40 | succ a' -> succ (addZero a' @ i) 41 | 42 | add_comm3 (a b c : nat) : Path nat (add a (add b c)) (add c (add b a)) = 43 | let rem : Path nat (add a (add b c)) (add a (add c b)) = add a (add_comm b c @ i) 44 | rem1 : Path nat (add a (add c b)) (add (add c b) a) = add_comm a (add c b) 45 | rem2 : Path nat (add (add c b) a) (add c (add b a)) = assocAdd c b a @ -i 46 | in comp (<_> nat) (rem1 @ i) [ (i = 0) -> rem @ -j, (i = 1) -> rem2 ] 47 | 48 | natcancelr (a b : nat) : (x : nat) -> Path nat (add a x) (add b x) -> Path nat a b = split 49 | zero -> \(h : Path nat a b) -> h 50 | succ x' -> \(h : Path nat (succ (add a x')) (succ (add b x'))) -> 51 | natcancelr a b x' (sucInj (add a x') (add b x') h) 52 | 53 | idnat : nat -> nat = split 54 | zero -> zero 55 | succ n -> succ (idnat n) 56 | 57 | test : Path (nat -> nat) idnat (idfun nat) = piext nat (\(_ : nat) -> nat) idnat (idfun nat) rem 58 | where rem : (n : nat) -> Path nat (idnat n) n = split 59 | zero -> refl nat zero 60 | succ n -> mapOnPath nat nat (\(x : nat) -> succ x) (idnat n) n (rem n) 61 | 62 | znots (n : nat) : neg (Path nat zero (succ n)) = 63 | \ (h:Path nat zero (succ n)) -> subst nat (natCase U nat empty) zero (succ n) h zero 64 | 65 | snotz (n : nat) : neg (Path nat (succ n) zero) = 66 | \ (h:Path nat (succ n) zero) -> znots n (inv nat (succ n) zero h) 67 | 68 | natDec : (n m:nat) -> dec (Path nat n m) = split 69 | zero -> natElim (\ (m:nat) -> dec (Path nat zero m)) (inl (refl nat zero)) (\ (m:nat) -> inr (znots m)) 70 | succ n -> natElim (\ (m:nat) -> dec (Path nat (succ n) m)) (inr (snotz n)) 71 | (\ (m:nat) -> decEqCong (Path nat n m) (Path nat (succ n) (succ m)) (\ (p:Path nat n m) -> succ (p @ i)) 72 | (sucInj n m) (natDec n m)) 73 | 74 | natSet : isSet nat = hedberg nat natDec 75 | 76 | eq_nat : eq_ = (nat, natEq) 77 | eq_nat_ : eq nat = natEq 78 | 79 | mutual 80 | even : nat -> bool = split 81 | zero -> true 82 | succ n -> odd n 83 | 84 | odd : nat -> bool = split 85 | zero -> false 86 | succ n -> even n 87 | 88 | mutual 89 | evenodd : (n : nat) -> Path bool (even n) (odd (succ n)) = split 90 | zero -> true 91 | succ x -> (oddeven x) @ i 92 | oddeven : (n :nat) -> Path bool (odd n) (even (succ n)) = split 93 | zero -> false 94 | succ x -> (evenodd x) @ i 95 | 96 | -- examples 1.9.1 and 1.9.2 97 | double_via_rec_nat : nat -> nat = natRec nat zero (\(_:nat) (y:nat) -> succ (succ y)) 98 | add_via_rec_nat : nat -> nat -> nat = natRec (nat->nat) (\(x:nat)->x) (\(_:nat) (add_:nat->nat) (m:nat) -> succ(add_ m)) 99 | 100 | -- exercise 1.9: Define the type family Fin : N → U mentioned at the end of §1.3, and the dependent 101 | -- function fmax : ∏(n:N) Fin(n + 1) mentioned in §1.4. 102 | 103 | fmax: (n:nat) -> Fin (succ n) = split { zero -> fz zero ; succ n -> fs (succ n) (fmax n) } 104 | 105 | -- exercise 1.10: Show that the Ackermann function ack : N → N → N is definable using only rec_nat 106 | -- satisfying the following equations: 107 | -- ack(0, n) ≡ succ(n), 108 | -- ack(succ(m), 0) ≡ ack(m, 1), 109 | -- ack(succ(m),succ(n)) ≡ ack(m, ack(succ(m), n)). 110 | 111 | ack : nat -> nat -> nat = 112 | natRec (nat->nat) (\(n:nat) -> succ n) 113 | (\(m:nat) (_:nat->nat) (n:nat) -> natRec nat (ack m one) 114 | (\(p:nat) (_:nat) -> ack m (ack (succ m) p)) n) 115 | 116 | -- As a lead-in to exercice 1.8, part three (prove that nat is a semi-ring) 117 | -- lets prove that double x = add x x 118 | 119 | double : nat -> nat = split 120 | zero -> zero 121 | succ n -> succ (succ (double n)) 122 | 123 | double_n_is_add_n_n : (n:nat) -> Path nat (double n) (add n n) = split 124 | zero -> zero 125 | succ x -> composition nat (succ (succ (double x))) 126 | (succ (succ (add x x))) 127 | (succ (add (succ x) x)) 128 | ( (succ (succ (double_n_is_add_n_n x @ j)))) 129 | ( succ (add_succ x x @ -k)) 130 | 131 | -- Same result, but with cryptic comp application obtained by expanding composition 132 | -- Note the empty third argument to comp 133 | double_n_is_add_n_n_via_cryptic_comp : (n:nat) -> Path nat (double n) (add n n) = split 134 | zero -> zero 135 | succ x -> comp ( Path nat (succ (succ (double x))) (succ (add_succ x x @ -i))) 136 | ( (succ (succ (double_n_is_add_n_n x @ j)))) [] 137 | 138 | -- Same result, but with more typical comp application 139 | double_n_is_add_n_n_via_comp : (n:nat) -> Path nat (double n) (add n n) = split 140 | zero -> zero 141 | succ x -> comp (<_> nat) (succ (succ (double_n_is_add_n_n x @ i))) 142 | [ (i=0) -> (succ (succ (double x))) -- 2+(double x) => 2+(add x x) 143 | , (i=1) -> (succ (add_succ x x @ -j)) -- 2+(add x x) => 1+(add (x+1) x) 144 | ] 145 | -------------------------------------------------------------------------------- /cubicaltt/src/null.ctt: -------------------------------------------------------------------------------- 1 | module null where 2 | import proto 3 | import path 4 | 5 | -- Nullification Modality 6 | -- is the Hub and Spokes HIT 7 | -- is a Localization at a family of maps (S a -> 1) 8 | 9 | data Null (A X: U) (S: A -> U) 10 | = center (x: X) 11 | | hub (x: A) (f: S x -> Null A X S) 12 | | spoke (x: A) (f: S x -> Null A X S) (s: S x) 13 | [ (i=0) -> hub {Null A X S} x f @ i , 14 | (i=1) -> f s ] 15 | | hubEq (x y: X) (a: A) (p: S a -> Path X x y) 16 | [ (i=0) -> center x , 17 | (i=1) -> center y ] 18 | | spokeEq (x y: X) (a: A) (p: S a -> Path X x y) (s: S a) 19 | [ (i=0) -> hubEq {Null A X S} x y a p @ i , 20 | (i=1) -> center (p s @ i) ] 21 | 22 | isNull (A X: U) (S: A -> U): U = undefined 23 | 24 | NullRec (A : U) (S: A -> U) (X Y : U) (f: isNull A Y S) (g: X -> Y) 25 | : Null A X S -> Y 26 | = undefined 27 | 28 | NullInd (A X: U) (S: A -> U) (Y: Null A X S -> U) 29 | (n : (x : Null A X S) -> Null A (Y x) S) 30 | (b : (x : X) -> Y (center x)) 31 | : (x : Null A X S) -> Y x 32 | = undefined 33 | 34 | {- 35 | split 36 | center x -> g x 37 | hub x f -> 38 | spoke x f s @ i -> 39 | hubEq x y a p @ i -> 40 | spokeEq x y a p s @ i -> 41 | -} 42 | 43 | -------------------------------------------------------------------------------- /cubicaltt/src/ordinal.ctt: -------------------------------------------------------------------------------- 1 | {- Ordinals: 2 | Copyright (c) Groupoid Infinity, 2014-2018. -} 3 | 4 | 5 | module ordinal where 6 | 7 | import nat 8 | 9 | -- from the JSL 89 paper of Stan Wainer 10 | -- by @coquand 11 | 12 | -- http://www.cse.chalmers.se/~coquand/ordinal.ps 13 | data ord = zero 14 | | succ (n: ord) 15 | | lim (f: nat -> ord) 16 | 17 | data ord2 = zero 18 | | succ (n: ord2) 19 | | lim (f: nat -> ord2) 20 | | lim2 (f: ord -> ord2) 21 | 22 | data ord3 = zero 23 | | succ (n: ord3) 24 | | lim (f: nat -> ord3) 25 | | lim2 (f: ord -> ord3) 26 | | lim3 (f: ord2 -> ord3) 27 | 28 | inj0 : nat -> ord = split 29 | zero -> zero 30 | succ n -> succ (inj0 n) 31 | 32 | inj12 : ord -> ord2 = split 33 | zero -> zero 34 | succ z -> succ (inj12 z) 35 | lim f -> lim (\ (n:nat) -> inj12 (f n)) 36 | 37 | omega : ord = lim inj0 38 | omega1 : ord2 = lim2 inj12 39 | 40 | G1 : ord -> nat -> nat = split 41 | zero -> \ (x:nat) -> zero 42 | succ z -> \ (x:nat) -> succ (G1 z x) 43 | lim f -> \ (x:nat) -> G1 (f x) x 44 | 45 | G2 : ord2 -> nat -> ord = split 46 | zero -> \ (x:nat) -> zero 47 | succ z -> \ (x:nat) -> succ (G2 z x) 48 | lim f -> \ (x:nat) -> G2 (f x) x 49 | lim2 f -> \ (x:nat) -> lim (\ (n:nat) -> G2 (f (inj0 n)) x) 50 | 51 | and (A B : U) : U = (_:A) * B 52 | 53 | O2 (n:nat) : ord2 -> U = split 54 | zero -> unit 55 | succ z -> O2 n z 56 | lim f -> (p:nat) -> O2 n (f p) 57 | lim2 f -> (x:ord) -> and (O2 n (f x)) (Path ord (G2 (f x) n) (G2 (f (inj0 (G1 x n))) n)) 58 | 59 | 60 | H1 : ord -> nat -> nat = split 61 | zero -> \ (x:nat) -> x 62 | succ z -> \ (x:nat) -> H1 z (succ x) 63 | lim f -> \ (x:nat) -> H1 (f x) x 64 | 65 | H2 : ord2 -> ord -> ord = split 66 | zero -> \ (x:ord) -> x 67 | succ z -> \ (x:ord) -> H2 z (succ x) 68 | lim f -> \ (x:ord) -> lim (\ (n:nat) -> H2 (f n) x) 69 | lim2 f -> \ (x:ord) -> H2 (f x) x 70 | 71 | collapsing (n:nat) : 72 | (x:ord2) (y:ord) -> O2 n x -> Path nat (G1 (H2 x y) n) (H1 (G2 x n) (G1 y n)) = split 73 | zero -> \ (y:ord) (h:O2 n zero) -> G1 y n 74 | succ z -> \ (y:ord) (h:O2 n (succ z)) -> collapsing n z (succ y) h 75 | lim f -> \ (y:ord) (h:O2 n (lim f)) -> collapsing n (f n) y (h n) 76 | lim2 f -> \ (y:ord) (h:O2 n (lim2 f)) -> 77 | let 78 | rem : Path ord (G2 (f y) n) (G2 (f (inj0 (G1 y n))) n) = (h y).2 79 | rem1 : Path nat (G1 (H2 (f y) y) n) (H1 (G2 (f y) n) (G1 y n)) = collapsing n (f y) y (h y).1 80 | in comp (Path nat (G1 (H2 (f y) y) n) (H1 (rem@i) (G1 y n))) rem1 [] 81 | 82 | -- an application 83 | 84 | 85 | lemOmega1 (n:nat) : O2 n omega1 = \ (x:ord) -> (rem x,rem1 x) 86 | where rem : (x:ord) -> O2 n (inj12 x) = split 87 | zero -> tt 88 | succ z -> rem z 89 | lim f -> \ (p:nat) -> rem (f p) 90 | rem1 : (x:ord) -> Path ord (G2 (inj12 x) n) (G2 (inj12 (inj0 (G1 x n))) n) = split 91 | zero -> zero 92 | succ z -> succ ((rem1 z)@i) 93 | lim f -> rem1 (f n) 94 | 95 | corr1 (n:nat) : Path nat (G1 (H2 omega1 omega) n) (H1 (G2 omega1 n) (G1 omega n)) = 96 | collapsing n omega1 omega (lemOmega1 n) 97 | 98 | lem : (n p:nat) -> Path nat (G1 (inj0 n) p) n = split 99 | zero -> \ (p:nat) -> zero 100 | succ q -> \ (p:nat) -> succ (lem q p@i) 101 | 102 | lem1 (n:nat) : Path nat (G1 omega n) n = lem n n 103 | 104 | lem2 : (n p:nat) -> Path ord (G2 (inj12 (inj0 n)) p) (inj0 n) = split 105 | zero -> \ (p:nat) -> inj0 zero 106 | succ q -> \ (p:nat) -> succ (lem2 q p@i) 107 | 108 | test (n:nat) : ord = G2 omega1 n 109 | 110 | lem3 (n:nat) : Path ord (G2 (inj12 (inj0 n)) n) (inj0 n) = lem2 n n 111 | -------------------------------------------------------------------------------- /cubicaltt/src/pi.ctt: -------------------------------------------------------------------------------- 1 | {- Pi Type: 2 | - Pi; 3 | - FunExt. 4 | Copyright (c) Groupoid Infinity, 2014-2018. 5 | 6 | HoTT 1.5 Product types 7 | HoTT 2.9 Pi-types and the function extensionality axiom. -} 8 | 9 | module pi where 10 | import proto 11 | import prop 12 | import path 13 | 14 | -- Pi Formation 15 | Pi (A: U) (B: A -> U) : U = (x:A) -> B(x) 16 | 17 | -- Pi Intro 18 | lam (A: U) (B: A -> U) (b: Pi A B): Pi A B = \(x: A) -> b x 19 | 20 | -- Pi Elim 21 | app (A: U) (B: A -> U) (f: Pi A B) (a: A): B a = f a 22 | 23 | -- Pi Computation 24 | Pi_Beta (A: U) (B: A -> U) (f: Pi A B) 25 | : Path (Pi A B) (\(x:A) -> f x) f 26 | = refl (Pi A B) f 27 | 28 | -- Pi Uniqueness 29 | Pi_Eta (A: U) (B: A -> U) (f: Pi A B) 30 | : Path (Pi A B) f (\(x:A) -> f x) 31 | = refl (Pi A B) f 32 | 33 | -- FunExt Type 34 | funext_form (A B: U) (f g: A -> B): U 35 | = Path (A -> B) f g 36 | 37 | -- funext Intro 38 | funext (A B: U) (f g: A -> B) (p: (x:A) -> Path B (f x) (g x)) 39 | : funext_form A B f g 40 | = \(a: A) -> p a @ i 41 | 42 | -- funext Elim 43 | happly (A B: U) (f g: A -> B) (p: funext_form A B f g) (x: A) 44 | : Path B (f x) (g x) 45 | = cong (A -> B) B (\(h: A -> B) -> apply A B h x) f g p 46 | 47 | -- funext Computation 48 | funext_Beta (A B: U) (f g: A -> B) (p: (x:A) -> Path B (f x) (g x)) 49 | : (x:A) -> Path B (f x) (g x) 50 | = \(x:A) -> happly A B f g (funext A B f g p) x 51 | 52 | -- funext Uniqueness 53 | funext_Eta (A B: U) (f g: A -> B) (p: Path (A -> B) f g) 54 | : Path (Path (A -> B) f g) (funext A B f g (happly A B f g p)) p 55 | = refl (Path (A -> B) f g) p 56 | 57 | -- dependent funext 58 | piext (A: U) (B: A -> U) (f g: (x:A) -> B x) (p: (x:A) -> Path (B x) (f x) (g x)) 59 | : Path ((y:A) -> B y) f g 60 | = \(a: A) -> (p a) @ i 61 | 62 | -- if pi is set and two functions are equal in two ways then these ways are contractible 63 | setPi (A: U) (B: A -> U) (h: (x: A) -> isSet (B x)) (f g: Pi A B) (p q: Path (Pi A B) f g) 64 | : Path (Path (Pi A B) f g) p q 65 | = \(x: A) -> (h x (f x) (g x) ((p@i)x) ((q@i)x)) @ i @ j 66 | 67 | -- pi is set on codomain 68 | setFun' (X Y: U) (p: X -> isSet Y) 69 | : isSet (X -> Y) 70 | = setPi X (\(_: X) -> Y) p 71 | 72 | setFun (A B : U) (sB: isSet B) 73 | : isSet (A -> B) 74 | = setPi A (\(x: A) -> B) (\(x: A) -> sB) 75 | 76 | -- if pi is contractible on domain and codomain then whole space is contractible 77 | piIsContr (A: U) (B: A -> U) (u: isContr A) (q: (x: A) -> isContr (B x)) 78 | : isContr (Pi A B) 79 | = (g,r) where 80 | -- a: A = u.1 81 | -- p: (x:A) -> Path A a x = u.2 82 | g (x:A): B x = (q x).1 83 | h (x:A): (y:B x) -> Path (B x) (g x) y = (q x).2 84 | r (z:Pi A B): Path (Pi A B) g z = piext A B g z (\(x:A) -> h x (z x)) 85 | -------------------------------------------------------------------------------- /cubicaltt/src/pointed.ctt: -------------------------------------------------------------------------------- 1 | {- Pointed Types: 2 | - Pointed; 3 | - Loop Space; 4 | - Their Maps. 5 | Copyright (c) Groupoid Infinity, 2014-2018. 6 | 7 | HoTT 2.1 Types are higher groupoids 8 | HoTT 8.2 Connectedness of suspensions 9 | HoTT 8.4 Fiber sequences and the long exact sequence -} 10 | 11 | module pointed where 12 | import trunc 13 | import path 14 | import nat 15 | 16 | -- Definition 2.1.7 17 | pointed: U = (A: U) * A 18 | ptSpace (A: U): U = (point: A) * unit 19 | point (A: pointed): A.1 = A.2 20 | space (A: pointed): U = A.1 21 | 22 | -- Definition 2.1.8 23 | -- Loop Spaces 24 | omega1 (A: pointed): pointed = (Path (space A) (point A) (point A), refl A.1 (point A)) 25 | omega2 (A: pointed): pointed = omega1 (omega1 A) 26 | omega3 (A: pointed): pointed = omega2 (omega1 A) 27 | 28 | omega : nat -> pointed -> pointed = split 29 | zero -> idfun pointed 30 | succ n -> \(A: pointed) -> omega n (omega1 A) 31 | 32 | -- Definition 8.4.1 33 | pmap (A B: pointed): U = (f: A.1 -> B.1) * (Path B.1 (f (point A)) (point B)) 34 | zmap (X Y: pointed): space X -> space Y = \ (x: space X) -> point Y 35 | 36 | omegaMap (A B: pointed) (f: pmap A B) : pmap (omega1 A) (omega1 B) 37 | = (space,prf) where 38 | space (p: (omega1 A).1) : (omega1 B).1 39 | = kanOp B.1 (f.1 (point A)) (f.1 (p@i)) (point B) f.2 40 | prf : Path (omega1 B).1 (space (point (omega1 A))) (point (omega1 B)) 41 | = kanOpRefl B.1 (f.1 (point A)) (point B) f.2 42 | 43 | omegaMap2 (A B: pointed) (f: pmap A B): pmap (omega2 A) (omega2 B) 44 | = omegaMap (omega1 A) (omega1 B) (omegaMap A B f) 45 | 46 | omegaMap3 (A B: pointed) (f: pmap A B): pmap (omega3 A) (omega3 B) 47 | = omegaMap (omega2 A) (omega2 B) (omegaMap2 A B f) 48 | 49 | omegaMapRefl (A: pointed) (B: U) (h: A.1 -> B) (p: (omega1 A).1) 50 | : (omega1 (B, h (point A))).1 51 | = h (p @ i) 52 | 53 | omegaMapRefl2 (A: pointed) (B: U) (h: A.1 -> B) (p: (omega2 A).1) 54 | : (omega2 (B, h (point A))).1 55 | = h (p @ i @ j) 56 | 57 | omegaMapRefl3 (A: pointed) (B: U) (h: A.1 -> B) (p: (omega3 A).1) 58 | : (omega3 (B, h (point A))).1 59 | = h (p @ i @ j @ k) 60 | 61 | -- The Wegde Sum : X \vee Y = X \times \{ y_0 \} \cup \{ x_0 \} \times Y 62 | data Wedge (A : pointed) (B : pointed) 63 | = winl (a : A.1) 64 | | winr (b : B.1) 65 | | wglue [ (x = 0) -> winl A.2 , 66 | (x = 1) -> winr B.2 ] 67 | 68 | -- The Smash Product : X \wedge Y = X \times Y / X \vee Y 69 | data Smash (A : pointed) (B : pointed) 70 | = spair (a : A.1) (b : B.1) 71 | | smash (a : A.1) (b : B.1) [(x=0) -> spair a B.2, (x=1) -> spair A.2 b] 72 | | smashpt [(x=0) -> smash {Smash A B} A.2 B.2 @ y, 73 | (x=1) -> spair A.2 B.2, 74 | (y=0) -> spair A.2 B.2, 75 | (y=1) -> spair A.2 B.2] 76 | 77 | data Join (A : U) (B : U) 78 | = joinl (a : A) 79 | | joinr (b : B) 80 | | join (a:A) (b:B) [(i=0) -> joinl a, 81 | (i=1) -> joinr b] 82 | 83 | SmashPt (A : pointed) (B : pointed) : pointed = (Smash A B, spair A.2 B.2) 84 | WedgePt (A : pointed) (B : pointed) : pointed = (Wedge A B, winl A.2) 85 | JoinPt (A : pointed) (B : pointed) : pointed = (Join A.1 B.1, joinl A.2) 86 | -------------------------------------------------------------------------------- /cubicaltt/src/process.ctt: -------------------------------------------------------------------------------- 1 | {- Process Calculus: 2 | - Process, Spawn, Execute. 3 | Copyright (c) Groupoid Infinity, 2014-2018. -} 4 | 5 | module process where 6 | import proto 7 | import list 8 | 9 | storage: U -> U = list 10 | 11 | -- Type Former 12 | process : U 13 | = (protocol state: U) -- Process Signature 14 | * (current: prod protocol state) -- In-Memory State 15 | * (act: id (prod protocol state)) -- Monoidal Action 16 | * (storage (prod protocol state)) -- In-Storage Signed Chain 17 | 18 | -- Intruduction Rule 19 | spawn (protocol state: U) (init: prod protocol state) 20 | (action: id (prod protocol state)) : process 21 | = (protocol,state,init,action,nil) 22 | 23 | -- Accessors 24 | protocol (p: process): U = p.1 25 | context (p: process): U = p.2.1 26 | signature (p: process): U = prod p.1 p.2.1 27 | current (p: process): signature p = p.2.2.1 28 | action (p: process): id (signature p) = p.2.2.2.1 29 | trace (p: process): storage (signature p) = p.2.2.2.2 30 | 31 | -- Isomorphic Signatures 32 | 33 | -- P x S -> S -- semigroup 34 | -- P x S -> P x S -- monoid 35 | 36 | -- Eliminators 37 | send (p: process) (message: protocol p) : unit = undefined 38 | receive (p: process) : protocol p = undefined 39 | execute (p: process) (message: protocol p) : process 40 | = let step: signature p = (action p) (message, (current p).2) 41 | in (protocol p, context p, step, action p, cons step (trace p)) 42 | 43 | -- > run simple ping 44 | data PING = ping | pong 45 | data STATE = init | stop | run 46 | simple : process = spawn PING STATE (ping,init) (\(_:prod PING STATE)->(pong,run)) 47 | run (p : process) (start: protocol p) : process 48 | = let a : process = execute p start 49 | b : process = execute a (current a).1 50 | c : process = execute b (current b).1 51 | in c 52 | -------------------------------------------------------------------------------- /cubicaltt/src/prop.ctt: -------------------------------------------------------------------------------- 1 | {- Prop Module: 2 | - Prop Theorems; 3 | Copyright (c) Groupoid Infinity, 2014-2018. 4 | 5 | HoTT 3.3 Mere propositions. -} 6 | 7 | module prop where 8 | import proto 9 | import path 10 | import sigma 11 | 12 | -- datatype properties: decideability, discretness, stability 13 | efq (A: U): empty -> A = emptyRec A 14 | neg (A: U): U = A -> empty 15 | dneg (A:U) (a:A): neg (neg A) = \(h: neg A) -> h a 16 | neg (A: U): U = A -> empty 17 | dec (A: U): U = either A (neg A) 18 | stable (A: U): U = neg (neg A) -> A 19 | discrete (A: U): U = (a b: A) -> dec (Path A a b) 20 | 21 | -- see HoTT 3.4 Classical vs. intuitionistic logic 22 | 23 | propUnit : isProp unit = split tt -> split@((x:unit) -> Path unit tt x) with { tt -> tt } 24 | 25 | fununit (A: U) (f g: A -> unit) 26 | (p: (x: A) -> Path unit (f x) (g x)) 27 | : Path (A -> unit) f g 28 | = \(a: A) -> p a @ i 29 | 30 | -- Exists(A,B) = ||Sigma(A,B)|| 31 | 32 | lemPropF (A : U) (P : A -> U) (pP : (x : A) -> isProp (P x)) (a0 a1 :A) 33 | (p : Path A a0 a1) (b0 : P a0) (b1 : P a1) 34 | : PathP (P (p@i)) b0 b1 35 | = pP (p@i) (comp (P (p@i/\j)) b0 [(i=0) -> <_>b0]) 36 | (comp (P (p@i\/-j)) b1 [(i=1) -> <_>b1]) @ i 37 | 38 | lemSig (A : U) (B : A -> U) (pB : (x : A) -> isProp (B x)) 39 | (u v : (x:A) * B x) (p : Path A u.1 v.1) 40 | : Path ((x:A) * B x) u v 41 | = (p@i,(lemPropF A B pB u.1 v.1 p u.2 v.2)@i) 42 | 43 | propSig (A : U) (B : A -> U) (pA : isProp A) 44 | (pB : (x : A) -> isProp (B x)) (t u : (x:A) * B x) 45 | : Path ((x:A) * B x) t u 46 | = lemSig A B pB t u (pA t.1 u.1) 47 | 48 | -- Forall(A,B) = ||Pi(A,B)|| 49 | 50 | propPi (A : U) (B: A -> U) (h: (x : A) -> isProp (B x)) (f0 f1: (x: A) -> B x) : Path ((x: A) -> B x) f0 f1 51 | = \ (x:A) -> (h x (f0 x) (f1 x)) @ i 52 | 53 | propPi2 (A: U) (B: A -> A -> U) (h: (x y: A) -> isProp (B x y)): isProp ((x y: A) -> B x y) 54 | = let p (a: A): isProp ((b: A) -> B a b) = propPi A (B a) (h a) 55 | B1 (a: A): U = (b: A) -> B a b 56 | in propPi A B1 p 57 | 58 | propPi3 (A: U) (B: A -> A -> A -> U) (h: (x y z: A) -> isProp (B x y z)): isProp ((x y z: A) -> B x y z) 59 | = let p (a b: A): isProp ((c : A) -> B a b c) = propPi A (B a b) (h a b) 60 | B1 (a b: A): U = (c: A) -> B a b c 61 | in propPi2 A B1 p 62 | 63 | --------- 64 | 65 | propN0 : isProp empty = \ (x y: empty) -> efq (Path empty x y) x 66 | 67 | propNeg (A:U) : isProp (neg A) = \ (f g:neg A) -> \(x:A) -> (propN0 (f x) (g x))@i 68 | 69 | propOr (A B : U) (hA : isProp A) (hB : isProp B) (h : A -> neg B) : isProp (either A B) = split 70 | inl a' -> split@((b : either A B) -> Path (either A B) (inl a') b) with 71 | inl b' -> inl (hA a' b' @ i) 72 | inr b' -> efq (Path (either A B) (inl a') (inr b')) (h a' b') 73 | inr a' -> split@((b : either A B) -> Path (either A B) (inr a') b) with 74 | inl b' -> efq (Path (either A B) (inr a') (inl b')) (h b' a') 75 | inr b' -> inr (hB a' b' @ i) 76 | 77 | propDec (A : U) (h : isProp A) : isProp (dec A) = 78 | propOr A (neg A) h (propNeg A) (\(x : A) (h : neg A) -> h x) 79 | 80 | propAnd (A B : U) (pA : isProp A) (pB : isProp B) : isProp (prod A B) = 81 | propSig A (\(_ : A) -> B) pA (\(_ : A) -> pB) 82 | 83 | --------- 84 | 85 | decEqCong (A B : U) (f : A -> B) (g : B -> A) : dec A -> dec B = split 86 | inl a -> inl (f a) 87 | inr h -> inr (\ (b:B) -> h (g b)) 88 | 89 | decStable (A:U) : dec A -> stable A = split 90 | inl a -> \ (h :neg (neg A)) -> a 91 | inr b -> \ (h :neg (neg A)) -> efq A (h b) 92 | 93 | decConst (A : U) : dec A -> exConst A = split 94 | inl a -> (\ (x:A) -> a, \ (x y:A) -> refl A a) 95 | inr h -> (\ (x:A) -> x, \ (x y:A) -> efq (Path A x y) (h x)) 96 | 97 | stableConst (A : U) (sA: stable A) : exConst A = 98 | (\ (x:A) -> sA (dneg A x),\ (x y:A) -> sA (propNeg (neg A) (dneg A x) (dneg A y) @ i)) 99 | 100 | ---------------------- 101 | isContrProp (A : U) (h : isContr A) : isProp A = 102 | \(a b : A) -> comp (<_> A) h.1 [ (i = 0) -> h.2 a, (i = 1) -> h.2 b ] 103 | 104 | isPropContr (A : U) (h : isProp A) : isContr A = undefined 105 | 106 | lemProp (A : U) (h : A -> isProp A) : isProp A = \(a : A) -> h a a 107 | 108 | propSet (A : U) (h : isProp A) : isSet A = 109 | \(a b : A) (p q : Path A a b) -> 110 | comp (<_> A) a [ (i=0) -> h a a 111 | , (i=1) -> h a b 112 | , (j=0) -> h a (p @ i) 113 | , (j=1) -> h a (q @ i)] 114 | 115 | propIsContr (A : U) : isProp (isContr A) = lemProp (isContr A) rem where 116 | rem (t : isContr A) : isProp (isContr A) = propSig A Tx pA pB where 117 | Tx (x : A) : U = (y : A) -> Path A x y 118 | pA (x y : A) : Path A x y = composition A x t.1 y ( t.2 x @ -i) (t.2 y) 119 | pB (x : A) : isProp (Tx x) = propPi A (\ (y : A) -> Path A x y) (propSet A pA x) 120 | 121 | propIsProp (A : U) : isProp (isProp A) = 122 | \(f g : isProp A) -> \(a b : A) -> 123 | propSet A f a b (f a b) (g a b) @ i 124 | 125 | 126 | corSigProp (A:U) (B:A-> U) (pB : (x:A) -> isProp (B x)) (t u : Sigma A B) (p:Path A t.1 u.1) : 127 | isProp (PathP (B (p@i)) t.2 u.2) = substInv U isProp T0 T1 rem rem1 128 | where P : Path U (B t.1) (B u.1) = B (p@i) 129 | T0 : U = PathP P t.2 u.2 130 | T1 : U = Path (B u.1) (transport P t.2) u.2 131 | rem : Path U T0 T1 = pathSig0 A B t u p 132 | v2 : B u.1 = transport P t.2 133 | rem1 : isProp T1 = propSet (B u.1) (pB u.1) v2 u.2 134 | -------------------------------------------------------------------------------- /cubicaltt/src/proto.ctt: -------------------------------------------------------------------------------- 1 | {- Proto Module: 2 | - Empty and Unit; 3 | - Tuple and Either; 4 | - Id, Const, Composition; 5 | - Decideability, Discretness, Stability. 6 | Copyright (c) Groupoid Infinity, 2014-2018. -} 7 | 8 | module proto where 9 | 10 | -- basic types 11 | data empty = 12 | data unit = tt 13 | data tuple (A B: U) = pair (a: A) (b: B) 14 | data either (A B: U) = inl (a: A) | inr (b: B) 15 | data exists (A: U) (B: A -> U) = sigma (a: A) (b: B(a)) 16 | 17 | fst (A B: U): tuple A B -> A = split pair a b -> a 18 | snd (A B: U): tuple A B -> B = split pair a b -> b 19 | pr1 (A: U) (B: A -> U): exists A B -> A = split sigma a b -> a 20 | pr2 (A: U) (B: A -> U): (x:exists A B) -> B (pr1 A B x) = split sigma a b -> b 21 | prod (A B: U): U = (_:A) * B 22 | 23 | {- Type Former Elims Desc 24 | ----------- ------- ---------------------------- 25 | prod .1 .2 non-dependent sigma 26 | Sigma pi1 pi2 dependent sigma 27 | tuple fst snd non-dependent inductive type 28 | exists pr1 pr2 dependent inductive type -} 29 | 30 | -- recursors and induction 31 | emptyRec (C: U): empty -> C = split {} 32 | emptyInd (C: empty->U): (z:empty) -> C z = split {} 33 | unitRec (C: U) (x: C): unit -> C = split tt -> x 34 | unitInd (C: unit -> U) (x: C tt): (z:unit) -> C z = split tt -> x 35 | tupleRec (A B C: U) (c: (x:A) (y:B) -> C): (x: tuple A B) -> C = split pair a b -> c a b 36 | tupleInd (A B:U)(C:tuple A B->U)(c:(x:A)(y:B)->C(pair x y)):(x:tuple A B)->C x=split pair a b -> c a b 37 | eitherRec (A B C: U) (b: A -> C) (c: B -> C): either A B -> C = split { inl x -> b(x) ; inr y -> c(y) } 38 | eitherInd (A B: U) (C: either A B -> U) 39 | (x: (a: A) -> C (inl a)) 40 | (y: (b: B) -> C (inr b)) 41 | : (x: either A B) -> C x 42 | = split { inl i -> x i ; inr j -> y j } 43 | 44 | -- HoTT 1.7 Coproduct types 45 | -- HoTT 2.12 Coproducts 46 | -- HoTT 2.6 Cartesian product types 47 | -- HoTT 2.8 The unit type 48 | 49 | -- functions proto_pi ? 50 | id (A: U): U = A -> A 51 | idfun (A: U) (a: A): A = a 52 | const (A B: U): U = A 53 | lam (A: U) (B: A -> U) (x: A) (b: B(x)): A -> B(x) = \(x: A) -> b --\ dependent 54 | app (A: U) (B: A -> U) (x: A) (f: A -> B(x)): B(x) = f(x) --/ version 55 | lambda (A B: U) (b: B): A -> B = \(_:A) -> b --\ non-dependent 56 | apply (A B: U) (f: A -> B) (x: A): B = f(x) --/ version 57 | ot (A B C: U) : U = (B -> C) -> (A -> B) -> (A -> C) 58 | o (A B C: U) : ot A B C = \ (g: B -> C) (f: A -> B) (x: A) -> g (f x) 59 | O (F G: U -> U) (t: U): U = F (G t) 60 | flip (A B C: U) (f: A -> B -> C) (b: B) (a: A): C = f a b 61 | uncurry (A: U) (B: U) (C : prod A B -> U) (f: (x: A) -> (y: B) -> C (x,y)) 62 | : (p: prod A B) -> C p = \ (p: prod A B) -> f p.1 p.2 63 | -------------------------------------------------------------------------------- /cubicaltt/src/pullback.ctt: -------------------------------------------------------------------------------- 1 | {- Homotopy Pullback: https://groupoid.space/mltt/types/pullback/ 2 | Copyright (c) Groupoid Infinity, 2014-2018. 3 | 4 | HoTT 2.15 -} 5 | 6 | module pullback where 7 | import proto 8 | import path 9 | import equiv 10 | 11 | -- z2 12 | -- Z ----> B 13 | -- z1 | pb | g 14 | -- V V 15 | -- A ----> C 16 | -- f 17 | 18 | 19 | -- Homotopy Limit 20 | pullback (A B C:U) (f: A -> C) (g: B -> C): U 21 | = (a: A) 22 | * (b: B) 23 | * Path C (f a) (g b) 24 | 25 | kernel (A B: U) (f: A -> B): U = pullback A A B f f 26 | hofiber (A B: U) (f: A -> B) (y: B): U = pullback A unit B f (\(x: unit) -> y) 27 | 28 | pb1 (A B C: U) (f: A -> C) (g: B -> C): pullback A B C f g -> A = \(x: pullback A B C f g) -> x.1 29 | pb2 (A B C: U) (f: A -> C) (g: B -> C): pullback A B C f g -> B = \(x: pullback A B C f g) -> x.2.1 30 | pb3 (A B C: U) (f: A -> C) (g: B -> C): (x: pullback A B C f g) -> Path C (f x.1) (g x.2.1) 31 | = \(x: pullback A B C f g) -> x.2.2 32 | 33 | induced (Z A B C: U) (f: A -> C) (g: B -> C) 34 | (z1: Z -> A) (z2: Z -> B) 35 | (h: (z:Z) -> Path C ((o Z A C f z1) z) (((o Z B C g z2)) z)) 36 | : Z -> pullback A B C f g 37 | = \(z: Z) -> ((z1 z),(z2 z),h z) 38 | 39 | pullbackSq (Z A B C: U) (f: A -> C) (g: B -> C) (z1: Z -> A) (z2: Z -> B): U 40 | = (h: (z:Z) -> Path C ((o Z A C f z1) z) (((o Z B C g z2)) z)) 41 | * isEquiv Z (pullback A B C f g) (induced Z A B C f g z1 z2 h) 42 | 43 | isPullbackSq (Z A B C: U) (f: A -> C) (g: B -> C) (z1: Z -> A) (z2: Z -> B) 44 | (h: (z:Z) -> Path C ((o Z A C f z1) z) (((o Z B C g z2)) z)): U 45 | = isEquiv Z (pullback A B C f g) (induced Z A B C f g z1 z2 h) 46 | 47 | -- Exercise 2.11. Prove that the pullback P :≡ A x_C B defined in (2.15.11) is the corner of a pullback square. 48 | completePullback (A B C: U) (f: A -> C) (g: B -> C) 49 | : pullbackSq (pullback A B C f g) A B C f g (pb1 A B C f g) (pb2 A B C f g) 50 | = (\(z:Z) -> pb3 A B C f g z,P) where 51 | Z: U = pullback A B C f g 52 | p: Path U Z Z = Z 53 | s (z: Z): Z = comp p z [] 54 | z1: Z -> A = (pb1 A B C f g) 55 | z2: Z -> B = (pb2 A B C f g) 56 | z3: U = (z:Z) -> Path C ((o Z A C f z1) z) (((o Z B C g z2)) z) 57 | I: Z -> Z = induced Z A B C f g z1 z2 (\(z:Z) -> pb3 A B C f g z) 58 | lem1 (z:Z): PathP p z z = z 59 | lem2 (z:Z): PathP p (s z) z = comp p z [(i=1) -> z] 60 | x1 (z:Z): fiber Z Z I z = (s z, comp p (s z) [(i=0) -> lem2 z, (i=1) -> lem1 (s z)]) 61 | lem3 (z:Z): PathP p z (s z) = comp p (s z) [(i=0) -> lem2 z, (i=1) -> lem1 (s z)] 62 | lem4 (y:Z): PathP (Path (p@i) (lem2 y@i) ((lem1(s y))@i)) (s y) (lem3 y) 63 | = fill p (s y) [(i=0)->lem2 y, (i=1)->lem1 (s y)]@j 64 | lem5 (y x: Z) (q: Path Z y x): Path Z (s y) x = comp p (q@i) [(i=0)->lem2 y@-j, (i=1)->lem1 x] 65 | lem6 (y x: Z) (q: Path Z y x): PathP (Path (p@i) (lem2 y@i) (lem1 x@i)) (lem5 y x q) q 66 | = fill p (q@i) [(i=0) -> lem2 y@-k, (i=1) -> lem1 x@-k] @ -j 67 | lem7 (y x: Z) (q: Path Z y x): PathP (Path Z y (lem5 y x q@i)) (lem3 y) q = comp p (lem5 y x q @i/\j) 68 | [(i=0) -> lem2 y, (i=1) -> lem5 y x q @ j, (j=0) -> lem4 y @ k @ i, (j=1) -> lem6 y x q@k@i] 69 | lem9 (z:Z) (x2: fiber Z Z I z): Path (fiber Z Z I z) (x1 z) x2 = (lem5 z x2.1 x2.2@i,lem7 z x2.1 x2.2@i) 70 | P (z: Z): isContr (fiber Z Z I z) = ((x1 z),lem9 z) 71 | 72 | -- fiber_f(y) ----> A 73 | -- | pb | f 74 | -- V V 75 | -- 1 ----> B 76 | -- \_.y 77 | 78 | fiberPullback (A B: U) (f: A -> B) (y: B) 79 | : pullbackSq (hofiber A B f y) 80 | A unit B f (\(x: unit) -> y) 81 | (pb1 A unit B f (\(x: unit) -> y)) 82 | (pb2 A unit B f (\(x: unit) -> y)) 83 | = completePullback A unit B f (\(x: unit) -> y) 84 | -------------------------------------------------------------------------------- /cubicaltt/src/pushout.ctt: -------------------------------------------------------------------------------- 1 | {- Homotopy Pushout: 2 | Copyright (c) Groupoid Infinity, 2014-2018. 3 | 4 | HoTT 6.8 Pushouts -} 5 | 6 | module pushout where 7 | import proto 8 | import pullback 9 | import nat 10 | 11 | -- Homotopy Colimit 12 | data pushout (A B C: U) (f: C -> A) (g: C -> B) 13 | = po1 (_: A) 14 | | po2 (_: B) 15 | | po3 (c: C) [ (i=0) -> po1 (f c) , 16 | (i=1) -> po2 (g c) ] 17 | 18 | 19 | -- data |-| (A : U) = f (x: A) | e (a b : A), f a = f b 20 | 21 | -- Colimit of Propositional Truncations A_{n+1} = pTrunc_{A_n} 22 | data colimit (A : nat -> U) 23 | (f : (n : nat) -> A n -> A (succ n)) 24 | = ix (n : nat) (x: A n) 25 | | gx (n : nat) (a: A n) [ (i=0) -> ix (succ n) (f n a) 26 | , (i=1) -> ix n a] 27 | 28 | cofiber (A B: U) (f: A -> B): U = pushout B unit A f (\(x: A) -> tt) 29 | cokernel (A B: U) (f: B -> A): U = pushout A A B f f 30 | 31 | -- f 32 | -- A ----> B 33 | -- | po | po2 34 | -- V V 35 | -- 1 ----> cofiber_f 36 | -- po1 37 | 38 | -- TODO: cofiberPushout 39 | 40 | -------------------------------------------------------------------------------- /cubicaltt/src/quotient.ctt: -------------------------------------------------------------------------------- 1 | {- Quotient Type: 2 | Copyright (c) Groupoid Infinity, 2016-2020. 3 | 4 | HoTT 6.10 Quotients -} 5 | 6 | module quotient where 7 | import set 8 | 9 | -- Quotient A by R 10 | data quot (A: U) (R: A -> A -> U) 11 | = quotient (a: A) 12 | | identification (a b: A) (r: R a b) 13 | [ (i = 0) -> quotient a , (i = 1) -> quotient b ] 14 | 15 | -- Set quotient of A by R 16 | data setQuot (A: U) (R: A -> A -> U) 17 | = quotient (a: A) 18 | | identification (a b: A) (r: R a b) 19 | [ (i=0) -> quotient a, (i=1) -> quotient b ] 20 | | trunc (a b : setQuot A R) (p q : Path (setQuot A R) a b) 21 | [ (i = 0) -> p @ j , (i = 1) -> q @ j , 22 | (j = 0) -> a , (j = 1) -> b ] 23 | 24 | -- Groupoid quotient of A by R 25 | data grpdQuot (A: U) (R: A -> A -> U) 26 | = quotient (a: A) 27 | | identification (a b: A) (r: R a b) 28 | [ (i = 0) -> quotient a, (i = 1) -> quotient b ] 29 | | trunc (a b : grpdQuot A R) (p q : Path (grpdQuot A R) a b) 30 | (x y: Path (Path (grpdQuot A R) a b) p q) 31 | [ (i = 0) -> x @ j @ k , (i = 1) -> y @ j @ k , 32 | (j = 0) -> p @ k , (j = 1) -> q @ k , 33 | (k = 0) -> a , (k = 1) -> b ] 34 | 35 | quotId (A: U) (R: A -> A -> U) (a b: A) (r: R a b) 36 | : Path (quot A R) (quotient a) (quotient b) 37 | = identification {quot A R} a b r @ i 38 | 39 | setQuotId (A : U) (R : A -> A -> U) (a b : A) (r : R a b) : 40 | Path (setQuot A R) (quotient a) (quotient b) 41 | = identification {setQuot A R} a b r @ i 42 | 43 | setQuotIsSet (A : U) (R : A -> A -> U) : isSet (setQuot A R) = 44 | \(a b : setQuot A R) (p q : Path (setQuot A R) a b) -> 45 | trunc {setQuot A R} a b p q @ i @ j 46 | 47 | setQuotLift (A B : U) (R : A -> A -> U) (H : isSet B) (f : A -> B) 48 | (G : (a b : A) -> R a b -> Path B (f a) (f b)) : setQuot A R -> B = split 49 | quotient x -> f x 50 | identification a b r @ i -> G a b r @ i 51 | trunc a b p q @ i j -> H (lift a) (lift b) ( lift (p @ k)) ( lift (q @ k)) @ i @ j 52 | where lift : setQuot A R -> B = setQuotLift A B R H f G 53 | 54 | lemPropF (A : U) (B : A -> U) (h : (x : A) -> isProp (B x)) 55 | (x y : A) (p : Path A x y) (u : B x) (v : B y) : PathP ( B (p @ i)) u v 56 | = substPathP (B x) (B y) ( B (p @ i)) u v q 57 | where 58 | u' : B y = transport ( B (p @ i)) u 59 | q : Path (B y) u' v = h y u' v 60 | 61 | setQuotLem (A : U) (P : A -> U) (sP : (x : A) -> isSet (P x)) (a : A) : 62 | (b : A) (p q : Path A a b) (r : Path (Path A a b) p q) (a1 : P a) (b1 : P b) 63 | (p1 : PathP ( P (p @ i)) a1 b1) (q1 : PathP ( P (q @ i)) a1 b1) -> 64 | PathP ( PathP ( P (r @ i @ j)) a1 b1) p1 q1 = 65 | J A a (\(b : A) (p : Path A a b) -> (q : Path A a b) 66 | (r : Path (Path A a b) p q) (a1 : P a) (b1 : P b) 67 | (p1 : PathP ( P (p @ i)) a1 b1) (q1 : PathP (P (q @ i)) a1 b1) -> 68 | PathP ( PathP ( P (r @ i @ j)) a1 b1) p1 q1) rem 69 | where 70 | rem : (q : Path A a a) (r : Path (Path A a a) (refl A a) q) 71 | (a1 b1 : P a) (p1 : Path (P a) a1 b1) (q1 : PathP ( P (q @ i)) a1 b1) -> 72 | PathP ( PathP ( P (r @ i @ j)) a1 b1) p1 q1 = 73 | J (Path A a a) (refl A a) 74 | (\(q : Path A a a) (r : Path (Path A a a) (refl A a) q) -> 75 | (a1 b1 : P a) (p1 : Path (P a) a1 b1) (q1 : PathP ( P (q @ i)) a1 b1) -> 76 | PathP ( PathP ( P (r @ i @ j)) a1 b1) p1 q1) (sP a) 77 | 78 | setQuotElim (A : U) (R : A -> A -> U) (B : setQuot A R -> U) 79 | (sB : (x : setQuot A R) -> isSet (B x)) (f : (x : A) -> B (quotient x)) 80 | (g : (a b : A) (r : R a b) -> PathP ( B (setQuotId A R a b r @ i)) (f a) (f b)) : 81 | (x : setQuot A R) -> B x = split 82 | quotient a -> f a 83 | identification a b r @ i -> g a b r @ i 84 | trunc a b p q @ i j -> 85 | setQuotLem (setQuot A R) B sB a b p q 86 | ( trunc{setQuot A R} a b p q @ i @ j) 87 | (f' a) (f' b) ( f' (p @ k)) ( f' (q @ k)) @ i @ j 88 | where 89 | f' : (z : setQuot A R) -> B z = setQuotElim A R B sB f g 90 | 91 | setQuotIndProp (A : U) (R : A -> A -> U) (B : setQuot A R -> U) 92 | (f : (x : A) -> B (quotient x)) (g : (x : setQuot A R) -> isProp (B x)) : 93 | (x : setQuot A R) -> B x = 94 | setQuotElim A R B 95 | (\(x : setQuot A R) -> propSet (B x) (g x)) f 96 | (\(a b : A) (r : R a b) -> 97 | lemPropF (setQuot A R) B g (quotient a) (quotient b) 98 | (setQuotId A R a b r) (f a) (f b)) 99 | 100 | setQuotLift2 (A B C : U) (X : A -> A -> U) (Y : B -> B -> U) 101 | (reflA : (a : A) -> X a a) (reflB : (b : B) -> Y b b) (h : isSet C) (f : A -> B -> C) 102 | (p : (a1 b1 : A) (a2 b2 : B) -> X a1 b1 -> Y a2 b2 -> Path C (f a1 a2) (f b1 b2)) : 103 | setQuot A X -> setQuot B Y -> C = 104 | setQuotLift A (setQuot B Y -> C) X 105 | (setPi (setQuot B Y) (\(_ : setQuot B Y) -> C) (\(_ : setQuot B Y) -> h)) 106 | lift (\(a1 b1 : A) (r : X a1 b1) -> 107 | funext (setQuot B Y) C (lift a1) (lift b1) 108 | (setQuotIndProp B Y (\(x : setQuot B Y) -> Path C (lift a1 x) (lift b1 x)) 109 | (\(x : B) -> p a1 b1 x x r (reflB x)) 110 | (\(x : setQuot B Y) -> h (lift a1 x) (lift b1 x)))) 111 | where 112 | lift (a : A) : setQuot B Y -> C = 113 | setQuotLift B C Y h (f a) (\(a2 b2 : B) (r : Y a2 b2) -> p a a a2 b2 (reflA a) r) 114 | 115 | {- 116 | 117 | -- Test to define circle as a quotient of unit 118 | 119 | import s1 120 | import quotient 121 | 122 | RS1 (a b: unit): U = unit 123 | s1quot : U = quot unit RS1 124 | 125 | f1: s1quot -> S1 = split 126 | quotient _ -> base 127 | identification a b r @ i -> loop1 @ i 128 | 129 | f2: S1 -> s1quot = split 130 | base -> quotient tt 131 | loop @ i -> identification {s1quot} tt tt tt @ i 132 | 133 | rem: (a: unit) -> Path s1quot (quotient tt) (quotient a) = split 134 | tt -> quotient tt 135 | -} 136 | 137 | -------------------------------------------------------------------------------- /cubicaltt/src/real.ctt: -------------------------------------------------------------------------------- 1 | {- Real Cohesive Homotopy Type Theory: 2 | - Flat, Shape, Crisp modalities. 3 | Copyright (c) Groupoid Infinity, 2016-2018. -} 4 | 5 | module real where 6 | import homotopy 7 | import pullback 8 | 9 | -- Homotopy Reals 10 | data R 11 | = cz (x: Z) 12 | | sz (z: Z) [(i=0) -> cz z, (i=1) -> cz (sucZ z)] 13 | 14 | zeroR : R = cz zeroZ 15 | 16 | glueR (z : Z) : Path R (cz z) (cz (sucZ z)) = 17 | sz{R} z @ i 18 | 19 | vectPos : (x : nat) -> Path R zeroR (cz (inr x)) = split 20 | zero -> <_> zeroR 21 | succ z -> composition R zeroR (cz (inr z)) (cz (inr (succ z))) (vectPos z) (glueR (inr z)) 22 | 23 | vectNeg : (x : nat) -> Path R zeroR (cz (inl x)) = split 24 | zero -> glueR (predZ zeroZ) @ -i 25 | succ z -> composition R zeroR (cz (inl z)) (cz (inl (succ z))) 26 | (vectNeg z) ( glueR (inl (succ z)) @ -i) 27 | 28 | vectR : (x : Z) -> Path R zeroR (cz x) = split 29 | inl a -> vectNeg a 30 | inr b -> vectPos b 31 | 32 | vectNegComp : (z : nat) -> 33 | Path (Path R zeroR (cz (sucZ (inl z)))) 34 | (composition R zeroR (cz (inl z)) (cz (sucZ (inl z))) 35 | (vectR (inl z)) (glueR (inl z))) 36 | (vectR (sucZ (inl z))) = split 37 | zero -> compInvPath R (cz (predZ zeroZ)) zeroR (glueR (predZ zeroZ)) 38 | succ z -> compInv R zeroR (cz (inl z)) (vectNeg z) (cz (inl (succ z))) ( glueR (inl (succ z)) @ -j) @ -i 39 | 40 | vectComp : (z : Z) -> 41 | Path (Path R zeroR (cz (sucZ z))) 42 | (composition R zeroR (cz z) (cz (sucZ z)) (vectR z) (glueR z)) 43 | (vectR (sucZ z)) = split 44 | inl a -> vectNegComp a 45 | inr b -> <_> vectR (inr (succ b)) 46 | 47 | vectOverTransport (z : Z) : PathP ( Path R zeroR (glueR z @ i)) (vectR z) (vectR (sucZ z)) = 48 | substPathP (Path R zeroR (cz z)) (Path R zeroR (cz (sucZ z))) 49 | ( Path R zeroR (glueR z @ i)) (vectR z) (vectR (sucZ z)) 50 | (comp ( Path (Path R zeroR (cz (sucZ z))) 51 | (composition R zeroR (cz z) (cz (sucZ z)) (vectR z) (glueR z)) 52 | (vectComp z @ j)) 53 | (substToComp R zeroR (cz z) (cz (sucZ z)) (glueR z) (vectR z)) []) 54 | 55 | zeroPath : (x : R) -> Path R zeroR x = split 56 | cz x -> vectR x 57 | sz z @ i -> vectOverTransport z @ i 58 | 59 | contrR : isContr R = (zeroR, zeroPath) 60 | 61 | distR (x y : R) : Path R x y = 62 | composition R x zeroR y ( zeroPath x @ -i) (zeroPath y) 63 | 64 | RtoHelix: R -> U = split 65 | cz x -> helix base 66 | sz z @ i -> helix (loop {S1} @ i) 67 | 68 | cis : R -> S1 = split 69 | cz x -> base 70 | sz z @ i -> loop{S1} @ i 71 | 72 | helixOverCis (x : R) : Path U (helix (cis x)) Z = 73 | helix (cis (distR x zeroR @ i)) 74 | 75 | ttPath : (x : unit) -> Path unit tt x = split 76 | tt -> <_> tt 77 | 78 | contrUnitPath (A : U) (p : isContr A) : Path U A unit 79 | = isoPath A unit (\(_ : A) -> tt) (\(_ : unit) -> p.1) ttPath p.2 80 | 81 | unitProdPath (A : U) : Path U (prod unit A) A 82 | = isoPath (prod unit A) A (\(p : prod unit A) -> p.2) (\(x : A) -> (tt, x)) 83 | (\(x : A) -> <_> x) (\(x : prod unit A) -> (ttPath x.1 @ i, x.2)) 84 | 85 | homoOverPath (A : U) (p : isContr A) (f : A -> S1) (q : Path S1 (f p.1) base) 86 | (x : S1) (z : A) : Path U (Path S1 x (f z)) (Path S1 x base) 87 | = Path S1 x (composition S1 (f z) (f p.1) base ( f (p.2 z @ -j)) q @ i) 88 | 89 | pathInvEquiv (A : U) (a b : A) : Path U (Path A a b) (Path A b a) 90 | = isoPath (Path A a b) (Path A b a) (inv A a b) (inv A b a) 91 | (\(p : Path A b a) -> <_> p) (\(p : Path A a b) -> <_> p) 92 | 93 | contrProd (A B : U) (p : isContr A) : Path U (prod A B) B 94 | = composition U (prod A B) (prod unit B) B 95 | ( prod (contrUnitPath A p @ i) B) (unitProdPath B) 96 | 97 | fibOfHomo (A : U) (p : isContr A) (f : A -> S1) (q : Path S1 (f p.1) base) 98 | (x : S1) : Path U (fiber A S1 f x) (helix x) 99 | = comp (<_> U) (lem @ i) 100 | [ (i = 0) -> (z : A) * (homoOverPath A p f q x z @ -j), 101 | (i = 1) -> helixFamily x @ -j ] 102 | where 103 | lem : Path U (prod A (Path S1 x base)) (Path S1 base x) 104 | = composition U (prod A (Path S1 x base)) (Path S1 x base) (Path S1 base x) 105 | (contrProd A (Path S1 x base) p) (pathInvEquiv S1 x base) 106 | 107 | kerOfHomo (A : U) (p : isContr A) (f : A -> S1) (q : Path S1 (f p.1) base) : 108 | Path U (fiber A S1 f base) Z 109 | = fibOfHomo A p f q base 110 | 111 | Euler : Path U (fiber R S1 cis base) Z 112 | = kerOfHomo R contrR cis (<_> base) 113 | 114 | -- Flat Modality 115 | data flat (A: U) 116 | = con (x: flat A) 117 | 118 | flatInd (A: U) (C: flat A -> U) 119 | (f: (u: flat A) -> C (con u)) 120 | : (x: flat A) -> C x 121 | = split con x -> f x 122 | 123 | -- Shape Modality (Fundamental $\infty$-groupoid) 124 | data shape (A: U) 125 | = sig' (_: A) 126 | | kap (_: R -> shape A) 127 | | kap' (_: R -> shape A) 128 | 129 | shapeRec (A B: U) (f: A -> B) 130 | (k: (R -> B) -> B) 131 | (k': (R -> B) -> B) 132 | (p1': (g: R -> B) (x: R) -> Path B (g x) (k g)) 133 | (p2': (x: B) -> Path B x (k' (\(_:R) -> x))) 134 | : shape A -> B = split 135 | sig' a -> f a 136 | kap g -> k (\(x:R) -> shapeRec A B f k k' p1' p2' (g x)) 137 | kap' g -> k' (\(x:R) -> shapeRec A B f k k' p1' p2' (g x)) 138 | 139 | -- Discrete Types 140 | IsDiscrete (A: U) 141 | : U 142 | = (f: A -> (R -> A)) 143 | * isEquiv A (R -> A) f 144 | -------------------------------------------------------------------------------- /cubicaltt/src/recursion.ctt: -------------------------------------------------------------------------------- 1 | {- Recursion Schemes: 2 | - Ana, Cata, Futu, Histo; 3 | - Inductive and Coinductive types. 4 | Copyright (c) Groupoid Infinity, 2014-2018. -} 5 | 6 | module recursion where 7 | 8 | {- Here is model of F-algebras with their recursors cana and ana. 9 | This is fixpoint version of recursion schemes which is defined 10 | in control module along with functor definition. -} 11 | 12 | import control 13 | 14 | -- Fixpoint Equations: 15 | -- A B : U , F : U -> U 16 | -- mu (F) = A + F(B) 17 | -- fix (F) = F(fix(F)) 18 | -- nu (F) = A * F(B) 19 | 20 | -- Fixpoint Functor 21 | data fix (F:U->U) = Fix (point: F (fix F)) 22 | out_ (F:U->U) : fix F -> F (fix F) = split Fix f -> f 23 | in_ (F:U->U) : F (fix F) -> fix F = \(x: F (fix F)) -> Fix x 24 | 25 | -- Mu and Nu Functors 26 | data mu (F:U->U) (A B:U) = Return (a: A) | Bind (f: F B) 27 | data nu (F:U->U) (A B:U) = CoBind (a: A) (f: F B) 28 | 29 | -- Free and CoFree Functors 30 | data free (F:U->U) (A:U) = Free (_: fix (mu F A)) 31 | data cofree (F:U->U) (A:U) = CoFree (_: fix (nu F A)) 32 | unfree (F:U->U) (A:U): free F A -> fix (mu F A) = split Free a -> a 33 | uncofree (F:U->U) (A:U): cofree F A -> fix (nu F A) = split CoFree a -> a 34 | 35 | cata (A: U) (F: functor) (alg: F.1 A -> A) (f: fix F.1): A 36 | = alg (F.2 (fix F.1) A (cata A F alg) (out_ F.1 f)) 37 | 38 | ana (A: U) (F: functor) (coalg: A -> F.1 A) (a: A): fix F.1 39 | = Fix (F.2 A (fix F.1) (ana A F coalg) (coalg a)) 40 | 41 | para (A: U) (F: functor) (alg: F.1 (tuple (fix F.1) A)->A) (f: fix F.1): A 42 | = alg (F.2 (fix F.1) (tuple (fix F.1) A) 43 | (\(m: fix F.1) -> pair m (para A F alg m)) (out_ F.1 f)) 44 | 45 | hylo (A B: U) (F: functor) (alg: F.1 B -> B) (coalg: A-> F.1 A) (a: A): B 46 | = alg (F.2 A B (hylo A B F alg coalg) (coalg a)) 47 | 48 | zygo (A B: U) (F: functor) (g: F.1 A -> A) 49 | (alg: F.1 (tuple A B) -> B) (f: fix F.1): B 50 | = snd A B (cata (tuple A B) F 51 | (\(x: F.1 (tuple A B)) -> pair (g (F.2 (tuple A B) A 52 | (\(y: tuple A B) -> fst A B y) x)) (alg x)) f) 53 | 54 | prepro (A: U) (F: functor) (nt: F.1(fix F.1) -> F.1(fix F.1)) 55 | (alg: F.1 A -> A) (f: fix F.1): A 56 | = alg (F.2 (fix F.1) A (\(x: fix F.1) -> 57 | prepro A F nt alg (cata (fix F.1) F (\(y: F.1(fix F.1)) 58 | -> Fix (nt y)) x)) (out_ F.1 f)) 59 | 60 | postpro (A: U) (F: functor) (nt : F.1(fix F.1) -> F.1(fix F.1)) 61 | (coalg: A -> F.1 A) (a: A): fix F.1 62 | = Fix (F.2 A (fix F.1) (\(x: A) -> ana (fix F.1) F (\(y: fix F.1) 63 | -> nt (out_ F.1 y)) (postpro A F nt coalg x)) (coalg a)) 64 | 65 | apo (A: U) (F: functor) 66 | (coalg: A -> F.1 (either (fix F.1) A)) (a: A): fix F.1 67 | = Fix (F.2 (either (fix F.1) A) (fix F.1) (\(x: either (fix F.1) A) 68 | -> eitherRec (fix F.1) A (fix F.1) (idfun (fix F.1)) (apo A F coalg) x) (coalg a)) 69 | 70 | gapo (A B: U) (F: functor) 71 | (coalg: A -> F.1 A) (coalg2: B -> F.1(either A B)) (b: B): fix F.1 72 | = Fix ((F.2 (either A B) (fix F.1) (\(x: either A B) 73 | -> eitherRec A B (fix F.1) (\(y: A) -> ana A F coalg y) (\(z: B) 74 | -> gapo A B F coalg coalg2 z) x) (coalg2 b))) 75 | 76 | futu (A: U) (F: functor) 77 | (f: A -> F.1 (free F.1 A)) (a: A): fix F.1 78 | = Fix (F.2 (free F.1 A) (fix F.1) (\(z: free F.1 A) -> w z) (f a)) where 79 | w: free F.1 A -> fix F.1 = split 80 | Free x -> unpack_fix x where 81 | unpack_free: mu F.1 A (fix (mu F.1 A)) -> fix F.1 = split 82 | Return x -> futu A F f x 83 | Bind g -> Fix (F.2 (fix (mu F.1 A)) (fix F.1) 84 | (\(x: fix (mu F.1 A)) -> w (Free x)) g) 85 | unpack_fix: fix (mu F.1 A) -> fix F.1 = split 86 | Fix x -> unpack_free x 87 | 88 | histo (A:U) (F: functor) 89 | (f: F.1 (cofree F.1 A) -> A) (z: fix F.1): A 90 | = extract A ((cata (cofree F.1 A) F (\(x: F.1 (cofree F.1 A)) -> 91 | CoFree (Fix (CoBind (f x) ((F.2 (cofree F.1 A) 92 | (fix (nu F.1 A)) (uncofree F.1 A) x)))))) z) where 93 | extract (A: U): cofree F.1 A -> A = split 94 | CoFree f -> unpack_fix f where 95 | unpack_fix: fix (nu F.1 A) -> A = split 96 | Fix f -> unpack_cofree f where 97 | unpack_cofree: nu F.1 A (fix (nu F.1 A)) -> A = split 98 | CoBind a -> a 99 | 100 | chrono (A B: U) (F: functor) 101 | (f: F.1 (cofree F.1 B) -> B) 102 | (g: A -> F.1 (free F.1 A)) 103 | (a: A): B = histo B F f (futu A F g a) 104 | 105 | -- Mendler's cata 106 | mcata (T: U) (F: U -> U) 107 | (phi: ((fix F) -> T) -> F (fix F) -> T) (t: fix F): T 108 | = phi (\(x: fix F) -> mcata T F phi x) (out_ F t) 109 | 110 | meta (A B: U) (F: functor) 111 | (f: A -> F.1 A) (e: B -> A) 112 | (g: F.1 B -> B) (t: fix F.1): fix F.1 113 | = ana A F f (e (cata B F g t)) 114 | 115 | mutu (A B: U) (F: functor) 116 | (f: F.1 (tuple A B) -> B) 117 | (g: F.1 (tuple B A) -> A) 118 | (t: fix F.1): A 119 | = g (F.2 (fix F.1) (tuple B A) (\(x: fix F.1) -> 120 | pair (mutu B A F g f x) (mutu A B F f g x)) (out_ F.1 t)) 121 | 122 | -- model of inductive types as F-algebras squares 123 | ind (F: U -> U) (A: U): U 124 | = (i: F (fix F) -> fix F) 125 | * (o: fix F -> F (fix F)) 126 | * (fold_: (F A -> A) -> fix F -> A) 127 | * ((F (cofree F A) -> A) -> fix F -> A) 128 | 129 | coind (F: U -> U) (A: U): U 130 | = (o: fix F -> F (fix F)) 131 | * (i: F (fix F) -> fix F) 132 | * (unfold_: (A -> F A) -> A -> fix F) 133 | * ((A -> F (free F A)) -> A -> fix F) 134 | 135 | inductive (F: functor) (A: U): ind F.1 A = (in_ F.1,out_ F.1,cata A F,histo A F) 136 | coinductive (F: functor) (A: U): coind F.1 A = (out_ F.1,in_ F.1,ana A F,futu A F) 137 | 138 | data W (A:U) (B:A->U) = sup (x:A) (f:B(x) -> W A B) 139 | 140 | whead (A:U)(B:A->U): W A B -> A = split sup x f -> x 141 | wtail (A:U)(B:A->U): (x:W A B) -> B (whead A B x) -> W A B = split sup x f -> f 142 | 143 | Wrec (A:U) (B:A->U) (P: U) 144 | (alg: (a:A) -> (B(a)->W A B) -> ((b:B(a)) -> P) -> P) 145 | : W A B -> P = split sup x g -> alg x g (\(h:B(x)) -> Wrec A B P alg (g h)) 146 | 147 | Wind (A:U) (B:A->U) (P:W A B -> U) 148 | (alg: (a:A) (f:B(a)->W A B) -> ((b:B(a))->P (f b)) -> P (sup a f)) 149 | : (w: W A B) -> P w = split sup x g -> alg x g (\(b:B(x)) -> Wind A B P alg (g b)) 150 | -------------------------------------------------------------------------------- /cubicaltt/src/retract.ctt: -------------------------------------------------------------------------------- 1 | {- Retract Types: 2 | Copyright (c) Groupoid Infinity, 2014-2018. -} 3 | 4 | module retract where 5 | import path 6 | 7 | section (A B: U) (f: A -> B) (g: B -> A): U = (b: B) -> Path B (f (g b)) b 8 | retract (A B: U) (f: A -> B) (g: B -> A): U = (a: A) -> Path A (g (f a)) a 9 | 10 | compUp (A: U) (a a' b b' : A) 11 | (p: Path A a a') (q: Path A b b') (r: Path A a b) 12 | : Path A a' b' 13 | = comp (A) (r @ i) [(i = 0) -> p, (i = 1) -> q] 14 | 15 | compDown (A: U) (a a' b b': A) 16 | (p: Path A a a') (q: Path A b b') 17 | : Path A a' b' -> Path A a b 18 | = compUp A a' a b' b (inv A a a' p) (inv A b b' q) 19 | 20 | -- if contraction space is conractible then image space is contractible too 21 | retIsContr (A B: U) (f: A -> B) (g: B -> A) 22 | (h: retract A B f g) (v: isContr B) 23 | : isContr A 24 | = (g b,p) where 25 | b : B = v.1 26 | q : (y:B) -> Path B b y = v.2 27 | p (x:A) : Path A (g b) x 28 | = comp (<_> A) (g (q (f x) @ i)) [(i=0) -> g b,(i=1) -> h x] 29 | -------------------------------------------------------------------------------- /cubicaltt/src/s1.ctt: -------------------------------------------------------------------------------- 1 | {- HIT: 2 | - 1-Sphere HIT. 3 | Copyright (c) Groupoid Infinity, 2014-2018. 4 | 5 | HoTT 6.4 Circles and spheres -} 6 | 7 | module s1 where 8 | import int 9 | 10 | data S1 = base 11 | | loop [ (i=0) -> base , 12 | (i=1) -> base ] 13 | 14 | loopS1 : U = Path S1 base base 15 | compS1 : loopS1 -> loopS1 -> loopS1 = composition S1 base base base 16 | 17 | -- All of these should be equal to "posZ (suc zero)": 18 | loop1 : loopS1 = loop{S1} @ i 19 | loop2 : loopS1 = compS1 loop1 loop1 20 | loop3 : loopS1 = composition S1 base base base loop1 loop1 21 | loop4 : loopS1 = compS1 loop2 loop1 22 | 23 | triv : loopS1 = base 24 | invLoop : loopS1 = inv S1 base base loop1 25 | oneTurn : loopS1 -> loopS1 = \(l: loopS1) -> compS1 l loop1 26 | backTurn : loopS1 -> loopS1 = \(l: loopS1) -> compS1 l invLoop 27 | l0 : loopS1 = triv 28 | l1 : loopS1 = oneTurn l0 29 | loopPos : nat -> loopS1 = split { zero -> triv ; succ n -> oneTurn (loopPos n) } 30 | loopNeg : nat -> loopS1 = split { zero -> invLoop ; succ n -> backTurn (loopNeg n) } 31 | ze (x: nat): bool -> Z = split { false -> inl x ; true -> inr x } 32 | loopZ (x: nat): bool -> loopS1 = split { false -> loopNeg x ; true -> loopPos x } 33 | turnZ (x: loopS1): bool -> loopS1 = split { false -> backTurn x ; true -> oneTurn x } 34 | inversion: bool -> loopS1 = split { false -> loop1 @ -i ; true -> loop1 } 35 | lnb (n: nat) (b: bool): loopS1 = loopZ n b 36 | loopIt : Z -> loopS1 = split { inl n -> loopNeg n ; inr n -> loopPos n } 37 | compInvS1 : Path loopS1 (refl S1 base) (compS1 invLoop loop1) = 38 | compInv' S1 base base loop1 39 | 40 | -- Helix for Winding 41 | helix : S1 -> U = split { base -> Z ; loop @ i -> sucPathZ @ i } 42 | winding (p : loopS1) : Z = trans Z Z ( helix (p @ i)) zeroZ 43 | htl (n: nat) (b: bool): Path U Z Z = helix (turnZ (loopZ n b) b @ i) 44 | htl' (n: nat) (b: bool): Path U Z Z = helix (loopZ n b @ i) 45 | hlx: bool-> Path U Z Z = split { false -> helix (loop1@-i) ; true -> helix (loop1@i) } 46 | htz (n: nat) (b: bool): Z = comp (htl n b) (inr zero) [] 47 | 48 | -- More examples: 49 | loopZ1 : Z = winding loop1 50 | loopZ2 : Z = winding (compS1 loop1 loop1) 51 | loopZ3 : Z = winding (compS1 loop1 (compS1 loop1 loop1)) 52 | loopZN1 : Z = winding invLoop 53 | loopZ0 : Z = winding (compS1 loop1 invLoop) 54 | 55 | mLoop : (x : S1) -> Path S1 x x = split 56 | base -> loop1 57 | loop @ i -> (constSquare S1 base loop1) @ i 58 | 59 | mult (x : S1) : S1 -> S1 = split 60 | base -> x 61 | loop @ i -> mLoop x @ i 62 | 63 | square (x : S1) : S1 = mult x x 64 | doubleLoop (l : loopS1) : loopS1 = square (l @ i) 65 | tripleLoop (l : loopS1) : loopS1 = mult (l @ i) (square (l @ i)) 66 | 67 | loopZ4 : Z = winding (doubleLoop (compS1 loop1 loop1)) 68 | loopZ8 : Z = winding (doubleLoop (doubleLoop (compS1 loop1 loop1))) 69 | 70 | -- A nice example of a homotopy on the circle. The path going halfway 71 | -- around the circle and then back is contractible: 72 | circ_hmtpy : Path loopS1 ( base) ( loop{S1} @ (i /\ -i)) = 73 | loop{S1} @ j /\ i /\ -i 74 | 75 | circleelim (X : U) (x : X) (p : Path X x x) : S1 -> X = split 76 | base -> x 77 | loop @ i -> p @ i 78 | 79 | apcircleelim (A B : U) (x : A) (p : Path A x x) (f : A -> B) : 80 | (z : S1) -> Path B (f (circleelim A x p z)) 81 | (circleelim B (f x) ( f (p @ i)) z) = split 82 | base -> <_> f x 83 | loop @ i -> <_> f (p @ i) 84 | 85 | -- a special case, Lemmas 6.2.5-6.2.9 in the book 86 | 87 | aLoop (A:U) : U = (a:A) * Path A a a 88 | 89 | phi (A:U) (al : aLoop A) : S1 -> A = split 90 | base -> al.1 91 | loop @ i -> (al.2)@ i 92 | 93 | psi (A:U) (f:S1 -> A) : aLoop A = (f base,f (loop1@i)) 94 | 95 | rem (A:U) (f : S1 -> A) : (u : S1) -> Path A (phi A (psi A f) u) (f u) = split 96 | base -> refl A (f base) 97 | loop @ i -> f (loop1@i) 98 | 99 | lem (A:U) (f : S1 -> A) : Path (S1 -> A) (phi A (psi A f)) f = 100 | \ (x:S1) -> (rem A f x) @ i 101 | 102 | thm (A:U) : Path U (aLoop A) (S1 -> A) = isoPath T0 T1 f g t s 103 | where T0 : U = aLoop A 104 | T1 : U = S1 -> A 105 | f : T0 -> T1 = phi A 106 | g : T1 -> T0 = psi A 107 | s (x:T0) : Path T0 (g (f x)) x = refl T0 x 108 | t : (y:T1) -> Path T1 (f (g y)) y = lem A 109 | 110 | lem1ItPos : (n:nat) -> Path loopS1 (loopIt (sucZ (inr n))) (oneTurn ((loopIt (inr n)))) = split 111 | zero -> refl loopS1 l1 112 | succ p -> oneTurn (lem1ItPos p@i) 113 | 114 | lem1ItNeg : (n:nat) -> Path loopS1 (loopIt (sucZ (inl n))) (oneTurn (loopIt (inl n))) = split 115 | zero -> compInvS1 116 | succ p -> compInv S1 base base (loopIt (inl p)) base invLoop 117 | 118 | lem1It : (n:Z) -> Path loopS1 (loopIt (sucZ n)) (oneTurn (loopIt n)) = split 119 | inl n -> lem1ItNeg n 120 | inr n -> lem1ItPos n 121 | -------------------------------------------------------------------------------- /cubicaltt/src/s2.ctt: -------------------------------------------------------------------------------- 1 | {- HIT: 2 | - 2-Sphere HIT. 3 | Copyright (c) Groupoid Infinity, 2014-2018. 4 | 5 | HoTT 6.4 Circles and spheres -} 6 | 7 | module s2 where 8 | import path 9 | import proto 10 | 11 | data S1 = base | loop [ (i=0) -> base, (i=1) -> base ] 12 | data susp (A: U) = north | south | merid (a : A) [ (i=0) -> north, (i=1) -> south ] 13 | data sph = pt | surf [ (i=0) -> pt, (i=1) -> pt, (j=0) -> pt, (j=1) -> pt ] 14 | 15 | LOOP: U = Path S1 base base 16 | loopS1 : LOOP = loop {S1} @ i 17 | 18 | S2: U = susp S1 19 | 20 | I2 (A: U) (a0 a1 b0 b1: A) (u: Path A a0 a1) (v: Path A b0 b1) 21 | (r0: Path A a0 b0) (r1: Path A a1 b1) : U 22 | = PathP ( (PathP ( A) (u@i) (v@i))) r0 r1 23 | 24 | plain (A: U) (x: A): I2 A x x x x ( x) ( x) ( x) ( x) 25 | = comp (<_>A) x [(i = 0) -> x, (i=1) -> x, 26 | (j = 0) -> x, (j=1) -> x ] 27 | 28 | loop2 : Path (Path sph pt pt) (pt) (pt) = plain sph pt 29 | loop3 : Path sph pt pt = loop2 @ 0 30 | loopSph : Path (Path sph pt pt) (pt) (pt) = surf {sph} @ i @ j 31 | loop4 : Path sph pt pt = loopSph @ 1 32 | loopEq : Path (Path (Path sph pt pt) (pt) (pt)) loop2 loopSph = undefined 33 | 34 | data D3 (x: sph) = bo (x: sph) 35 | | spc [ (i=0) -> bo x, (i=1) -> bo x , 36 | (j=0) -> bo x, (j=1) -> bo x , 37 | (k=0) -> bo x, (k=1) -> bo x ] 38 | 39 | loopD1 : Path (Path (D3 pt) (bo pt) (bo pt)) (bo pt) (bo pt) = (bo pt) 40 | loopD3 : Path (Path (Path (D3 pt) (bo pt) (bo pt)) (bo pt) (bo pt)) (loopD1) (loopD1) 41 | = spc {D3 pt} @ i @ j @ k 42 | 43 | -------------------------------------------------------------------------------- /cubicaltt/src/seq.ctt: -------------------------------------------------------------------------------- 1 | {- Type Sequences 2 | - Chain Complex; 3 | - Fiber Sequence; 4 | - Pointed Map Sequence; 5 | - Group Sequence; 6 | - Abelian Group Sequence. 7 | Copyrigh (c) Groupoid Infinity, 2014-2018. -} 8 | 9 | module seq where 10 | import algebra 11 | import pointed 12 | import nat 13 | import fun 14 | 15 | -- Cohomology Sequences 16 | data Seq (A: U) (B: A -> A -> U) (X Y: A) 17 | = seqNil (_: A) 18 | | seqCons (X Y Z: A) (_: B X Y) (_: Seq A B Y Z) 19 | 20 | -- Fiber Sequence 21 | fibSeq: pointed -> pointed -> U = Seq pointed pmap 22 | fibNil (X: pointed): fibSeq X X = seqNil X 23 | fibCons (X Y Z: pointed) (h: pmap X Y) (t: fibSeq Y Z): fibSeq X Z = seqCons X Y Z h t 24 | 25 | -- Group Homomorphism Sequence 26 | homSeq: group -> group -> U = Seq group grouphom 27 | homNil (X: group): homSeq X X = seqNil X 28 | homCons (X Y Z: group) (h: grouphom X Y) (t: homSeq Y Z): homSeq X Z = seqCons X Y Z h t 29 | 30 | -- Abelian Group Homomorphism Sequence 31 | abSeq: abgroup -> abgroup -> U = Seq abgroup abgrouphom 32 | abNil (X: abgroup): abSeq X X = seqNil X 33 | abCons (X Y Z: abgroup) (h: abgrouphom X Y) (t: abSeq Y Z): abSeq X Z = seqCons X Y Z h t 34 | 35 | -- Functor Sequence 36 | catSeq: precategory -> precategory -> U = Seq precategory catfunctor 37 | catNil (X: precategory): catSeq X X = seqNil X 38 | catCons (X Y Z: precategory) (h: catfunctor X Y) (t: catSeq Y Z): catSeq X Z = seqCons X Y Z h t 39 | 40 | opaque Seq 41 | -------------------------------------------------------------------------------- /cubicaltt/src/set.ctt: -------------------------------------------------------------------------------- 1 | {- Set Theory: 2 | - Injectivity; 3 | Copyright (c) Groupoid Infinity, 2014-2018. 4 | 5 | HoTT 3.1 Sets and n-types -} 6 | 7 | module set where 8 | import proto 9 | import path 10 | import prop 11 | import pi 12 | import sigma 13 | import equiv 14 | 15 | -- Contractible is a Prop 16 | 17 | setIsProp (A : U) : isProp (isSet A) = 18 | \(f g : isSet A) -> \(a b :A) -> 19 | propIsProp (Path A a b) (f a b) (g a b) @ i 20 | 21 | setUnit : isSet unit = propSet unit propUnit 22 | 23 | setInj (A B : U) (f : A -> B) (sA : isSet A) (sB : isSet B) : U 24 | = (b : B) -> isProp ((a : A) * Path B (f a) b) 25 | 26 | prop_inj (A B: U) (f: A -> B) (sA: isSet A) (sB: isSet B): isProp (setInj A B f sA sB) 27 | = propPi B Q h where 28 | P: B -> U = \(b: B) -> (a: A) * Path B (f a) b 29 | Q: B -> U = \(b: B) -> isProp (P b) 30 | h: (b: B) -> isProp (Q b) = \(b: B) -> propIsProp (P b) 31 | 32 | {- 33 | sqDepPath (A:U) (F:A->U) (sF: (x:A) -> (F x)) (a0 a1:A) (p: Path A a0 a1) (u0 : F a0) (u1 : F a1) 34 | (q r : PathP ( F (p@i)) u0 u1) 35 | : Path (PathP ( F (p@i)) u0 u1) q r = rem @ j @ i 36 | where 37 | rem : PathP ( Path (F (p@i)) (q@i) (r@i)) (u0) (u1) 38 | = let xi : A = p@i 39 | ui0 : F xi = transport (F (p @ i/\j)) u0 40 | ui1 : F xi = transport (F (p @ i\/-j)) u1 41 | qi : Id (F xi) ui0 ui1 = transport (F (p@(i/\-j/\k)\/(i/\j)\/(j/\-k)\/(i/\k))) (q@j) 42 | ri : Id (F xi) ui0 ui1 = transport (F (p@(i/\-j/\k)\/(i/\j)\/(j/\-k)\/(i/\k))) (r@j) 43 | in (sF xi ui0 ui1 qi ri @ j @ i) 44 | -} -------------------------------------------------------------------------------- /cubicaltt/src/sigma.ctt: -------------------------------------------------------------------------------- 1 | {- Sigma Type: 2 | Copyright (c) Groupoid Infinity, 2014-2018. 3 | 4 | HoTT 2.7 Sigma-types 5 | HoTT 1.6 Dependent pair types (Sigma-types) -} 6 | 7 | module sigma where 8 | import path 9 | 10 | Sigma (A:U)(B:A->U): U = (x:A) * B(x) 11 | dpair (A:U)(B:A->U)(a: A) (b: B a): Sigma A B = (a,b) 12 | pi1 (A:U)(B:A->U)(x: Sigma A B): A = x.1 13 | pi2 (A:U)(B:A->U)(x: Sigma A B): B (pi1 A B x) = x.2 14 | sigRec (A:U)(B:A->U)(C: U) (g:(x:A)->B(x)->C) (p: Sigma A B): C = g p.1 p.2 15 | sigInd (A:U)(B:A->U)(C: Sigma A B->U) (p: Sigma A B) (g:(a:A)(b:B(a))->C(a,b)): C p = g p.1 p.2 16 | 17 | -- Axiom of Choice 18 | ac (A B: U) (R: A -> B -> U): 19 | (p: (x:A)->(y:B)*(R x y)) -> (f:A->B)*((x:A)->R(x)(f x)) 20 | = \(g: (x:A)->(y:B)*(R x y)) -> (\(i:A)->(g i).1,\(j:A)->(g j).2) 21 | 22 | total (A:U) (B C : A->U) (f : (x:A) -> B x -> C x) (w:Sigma A B) 23 | : Sigma A C = (w.1,f (w.1) (w.2)) 24 | 25 | sigmaIsContr (A: U) (B: A -> U) (u: isContr A) 26 | (q: (x: A) -> isContr (B x)) 27 | : isContr (Sigma A B) 28 | = ((a,g a),r) where 29 | a : A = u.1 30 | p : (x:A) -> Path A a x = u.2 31 | g (x:A) : B x = (q x).1 32 | h (x:A) : (y:B x) -> Path (B x) (g x) y = (q x).2 33 | r (z:Sigma A B): Path (Sigma A B) (a,g a) z 34 | = (p z.1@i,h (p z.1@i) (comp (B (p z.1@i\/-j)) z.2 [(i=1)->z.2])@i) 35 | 36 | funDepTr (A:U) (P: A -> U) (a0 a1: A) 37 | (p: Path A a0 a1) (u0: P a0) (u1: P a1) 38 | : Path U (PathP ( P (p@i)) u0 u1) 39 | (Path (P a1) (transport ( P (p@i)) u0) u1) 40 | = PathP (P (p@j\/i)) (comp (P (p@j/\i)) u0 [(j=0)-><_>u0]) u1 41 | 42 | pathSig0 (A:U) (B: A -> U) (t u: Sigma A B) 43 | (p:Path A t.1 u.1) 44 | : Path U (PathP (B (p@i)) t.2 u.2) 45 | (Path (B u.1) (transport (B (p@i)) t.2) u.2) 46 | = funDepTr A B t.1 u.1 p t.2 u.2 47 | 48 | corSigSet (A:U) (B:A-> U) (sB : (x:A) -> isSet (B x)) (t u : Sigma A B) (p:Path A t.1 u.1) : 49 | isProp (PathP (B (p@i)) t.2 u.2) = substInv U isProp T0 T1 rem rem1 50 | where P : Path U (B t.1) (B u.1) = B (p@i) 51 | T0 : U = PathP P t.2 u.2 52 | T1 : U = Path (B u.1) (transport P t.2) u.2 53 | rem : Path U T0 T1 = pathSig0 A B t u p -- funDepTr (B t.1) (B u.1) P t.2 u.2 54 | v2 : B u.1 = transport P t.2 55 | rem1 : isProp T1 = sB u.1 v2 u.2 56 | 57 | sigSecondPath (A: U) (P: A -> U) (t u: Sigma A P) (p: Path A t.1 u.1): U 58 | = Path (P u.1) (transport p' t.2) u.2 where 59 | p' : Path U (P t.1) (P u.1) = mapOnPath A U P t.1 u.1 p 60 | 61 | -------------------------------------------------------------------------------- /cubicaltt/src/stream.ctt: -------------------------------------------------------------------------------- 1 | {- Stream Run-Time Type: 2 | Copyright (c) Groupoid Infinity, 2014-2018. -} 3 | 4 | module stream where 5 | import nat 6 | 7 | data stream (A: U) = cons (x: A) (xs: stream A) 8 | 9 | tail (A: U): stream A -> stream A = split cons x xs -> xs 10 | head (A: U): stream A -> A = split cons x xs -> x 11 | 12 | fib (a b: nat) : stream nat = cons a (fib b (add a b)) 13 | seq (start: nat) : stream nat = cons start (seq (succ start)) 14 | 15 | ones: stream nat = cons one ones 16 | zeros: stream nat = cons zero zeros 17 | nats: stream nat = seq zero 18 | -------------------------------------------------------------------------------- /cubicaltt/src/stream_theory.ctt: -------------------------------------------------------------------------------- 1 | {- Stream Theory: 2 | Copyright (c) Groupoid Infinity, 2014-2018. -} 3 | 4 | module stream_theory where 5 | import stream 6 | import iso 7 | 8 | eta (A: U): (xs: stream A) -> Path (stream A) (cons (head A xs) (tail A xs)) xs 9 | = split cons x xs -> cons x xs 10 | 11 | data Bisimilar (A: U) (xs ys: stream A) 12 | = consB (h: Path A (head A xs) (head A ys)) 13 | (t: Bisimilar A (tail A xs) (tail A ys)) 14 | 15 | bisimilarityToPath2 16 | (rec : (A : U) (xs : stream A) (ys : stream A) -> Bisimilar A xs ys -> Path (stream A) xs ys) 17 | (A : U) (x : A) (xs : stream A) (y : A) (ys : stream A) : 18 | Bisimilar A (cons x xs) (cons y ys) -> 19 | Path (stream A) (cons x xs) (cons y ys) = 20 | split consB h t -> cons (h @ i) ((rec A xs ys t) @ i) 21 | 22 | bisimilarityToPath1 23 | (rec : (A : U) (xs : stream A) (ys : stream A) -> Bisimilar A xs ys -> Path (stream A) xs ys) 24 | (A : U) (x : A) (xs : stream A) : 25 | (ys : stream A) -> Bisimilar A (cons x xs) ys -> 26 | Path (stream A) (cons x xs) ys = 27 | split cons y ys -> bisimilarityToPath2 rec A x xs y ys 28 | 29 | bisimilarityToPath 30 | (A : U) : 31 | (xs : stream A) (ys : stream A) -> 32 | Bisimilar A xs ys -> Path (stream A) xs ys = 33 | split cons x xs -> bisimilarityToPath1 bisimilarityToPath A x xs 34 | 35 | -- Equality implies bisimilarity. 36 | 37 | PathToBisimilarity1 38 | (rec: (A: U) (xs ys: stream A) (eq: Path (stream A) xs ys) -> Bisimilar A xs ys) 39 | (A: U) (x: A) (xs: stream A): (ys: stream A) (eq: Path (stream A) (cons x xs) ys) -> 40 | Bisimilar A (cons x xs) ys = split 41 | cons y ys -> \(eq : Path (stream A) (cons x xs) (cons y ys)) -> 42 | consB ( head A (eq @ i)) 43 | (rec A xs ys ( tail A (eq @ i))) 44 | 45 | PathToBisimilarity (A: U): (xs ys: stream A) (eq: Path (stream A) xs ys) -> Bisimilar A xs ys 46 | = split cons x xs -> PathToBisimilarity1 PathToBisimilarity A x xs 47 | 48 | -- Round-tripping lemmas. 49 | bisimilarityToBisimilarity2 50 | (rec: (A: U) (xs ys: stream A) (b: Bisimilar A xs ys) -> 51 | Path (Bisimilar A xs ys) 52 | (PathToBisimilarity A xs ys (bisimilarityToPath A xs ys b)) b) 53 | (A: U) (x: A) (xs: stream A) (y: A) (ys : stream A) : 54 | (b: Bisimilar A (cons x xs) (cons y ys)) -> 55 | Path (Bisimilar A (cons x xs) (cons y ys)) 56 | (PathToBisimilarity A (cons x xs) (cons y ys) 57 | (bisimilarityToPath A (cons x xs) (cons y ys) b)) 58 | b = split consB h t -> consB h ((rec A xs ys t) @ i) 59 | 60 | bisimilarityToBisimilarity1 61 | (rec: (A: U) (xs ys: stream A) (b: Bisimilar A xs ys) -> 62 | Path (Bisimilar A xs ys) 63 | (PathToBisimilarity A xs ys (bisimilarityToPath A xs ys b)) b) 64 | (A: U) (x: A) (xs: stream A): (ys: stream A) (b: Bisimilar A (cons x xs) ys) -> 65 | Path (Bisimilar A (cons x xs) ys) 66 | (PathToBisimilarity A (cons x xs) ys 67 | (bisimilarityToPath A (cons x xs) ys b)) 68 | b = split cons y ys -> bisimilarityToBisimilarity2 rec A x xs y ys 69 | 70 | bisimilarityToBisimilarity (A: U) 71 | : (xs ys: stream A) (b: Bisimilar A xs ys) -> 72 | Path (Bisimilar A xs ys) 73 | (PathToBisimilarity A xs ys (bisimilarityToPath A xs ys b)) 74 | b = split cons x xs -> bisimilarityToBisimilarity1 bisimilarityToBisimilarity A x xs 75 | 76 | idToId2 (rec: (A: U) (xs ys: stream A) (eq: Path (stream A) xs ys) -> 77 | Path (Path (stream A) xs ys) 78 | (bisimilarityToPath A xs ys (PathToBisimilarity A xs ys eq)) eq) 79 | (A: U) (x: A) (xs: stream A) (y: A) (ys: stream A) 80 | (eq: Path (stream A) (cons x xs) (cons y ys)) 81 | : Path (Path (stream A) (cons x xs) (cons y ys)) 82 | (bisimilarityToPath A (cons x xs) (cons y ys) (PathToBisimilarity A (cons x xs) (cons y ys) eq)) 83 | eq = undefined 84 | 85 | -- comp (stream A) 86 | -- (cons (head A (eq @ j)) (((rec A xs ys ( tail A (eq @ k))) @ i) @ j)) 87 | -- [ (i = 1) -> (eta A (eq @ j)) @ k ] 88 | 89 | idToId1 (rec: (A: U) (xs ys: stream A) 90 | (eq: Path (stream A) xs ys) -> 91 | Path (Path (stream A) xs ys) 92 | (bisimilarityToPath A xs ys (PathToBisimilarity A xs ys eq)) eq) 93 | (A: U) (x: A) (xs: stream A) 94 | : (ys: stream A) (eq: Path (stream A) (cons x xs) ys) -> 95 | Path (Path (stream A) (cons x xs) ys) 96 | (bisimilarityToPath A (cons x xs) ys (PathToBisimilarity A (cons x xs) ys eq)) 97 | eq = split cons y ys -> idToId2 rec A x xs y ys 98 | 99 | idToId (A: U) : (xs ys: stream A) (eq: Path (stream A) xs ys) -> 100 | Path (Path (stream A) xs ys) 101 | (bisimilarityToPath A xs ys (PathToBisimilarity A xs ys eq)) 102 | eq = split cons x xs -> idToId1 idToId A x xs 103 | 104 | -- Bisimilarity is equal to equality. 105 | bisimilarityIsPath 106 | (A: U) (xs ys: stream A) : 107 | Path U (Bisimilar A xs ys) (Path (stream A) xs ys) = 108 | isoPath (Bisimilar A xs ys) 109 | (Path (stream A) xs ys) 110 | (bisimilarityToPath A xs ys) 111 | (PathToBisimilarity A xs ys) 112 | (idToId A xs ys) 113 | (bisimilarityToBisimilarity A xs ys) 114 | -------------------------------------------------------------------------------- /cubicaltt/src/subtype.ctt: -------------------------------------------------------------------------------- 1 | module subtype where 2 | import path 3 | import pi 4 | import equiv 5 | import iso_sigma 6 | import univ 7 | 8 | -- Subtype 9 | hsubtypes (X: U): U = X -> PROP 10 | hrel (X: U): U = X -> X -> PROP 11 | funresprel (A B: U) (f: A->B) (R: hrel A): U = (a a': A) (r: (R a a').1) -> Path B (f a) (f a') 12 | funresprel2 (A B C: U) (f: A->B->C) (R0: hrel A) (R1: hrel B): U = (a a': A) (b b': B)->(R0 a a').1->(R1 b b').1 -> Path C (f a b) (f a' b') 13 | ishinh_UU (X: U): U = (P: PROP) -> ((X -> P.1) -> P.1) 14 | propishinh (X: U): isProp (ishinh_UU X) = propPi PROP (\(P:PROP)->((X->P.1)->P.1)) (\(P:PROP)->propPi (X->P.1) (\(_: X->P.1)->P.1) (\(f: X->P.1)->P.2)) 15 | ishinh (X: U): PROP = (ishinh_UU X,propishinh X) 16 | hinhpr (X: U): X -> (ishinh X).1 = \(x: X) (P: PROP) (f: X -> P.1) -> f x 17 | exists (A: U) (B: A -> U): PROP = ishinh ((x: A) * B x) 18 | existspr (A: U) (B: A -> U) (a: A) (b: B a): (exists A B).1 = hinhpr ((x : A) * B x) (a, b) 19 | hProppair (X Y: PROP): PROP = (prod X.1 Y.1, propAnd X.1 Y.1 X.2 Y.2) 20 | hrelpair (A B: U) (R0 : hrel A) (R1 : hrel B) (x y: prod A B): PROP = hProppair (R0 x.1 y.1) (R1 x.2 y.2) 21 | hsubtypespair (A B: U) (H0: hsubtypes A) (H1: hsubtypes B) (x: prod A B): PROP = hProppair (H0 x.1) (H1 x.2) 22 | hinhuniv (X: U) (P: PROP) (f: X -> P.1) (inhX: (ishinh X).1): P.1 = inhX P f 23 | existsel (A:U)(B:A->U)(P:PROP)(f:(x:A)->(B x)->P.1)(e:(exists A B).1):P.1=hinhuniv((x:A)*B x)P(\(z:(x:A)*(B x))->f z.1 z.2)e 24 | carr (X: U) (A: hsubtypes X) : U = (x : X) * (A x).1 25 | propidU (X Y: U): Path U X Y -> isProp Y -> isProp X = substInv U isProp X Y 26 | propequiv (X Y: U) (H: isProp Y) (f g : equiv X Y) : Path (equiv X Y) f g = equivLemma X Y f g ( \(x : X) -> H (f.1 x) (g.1 x) @ i) 27 | 28 | iseqclass (X : U) (R : hrel X) (A : hsubtypes X) : U = 29 | prod (prod (ishinh (carr X A)).1 30 | ((x1 x2 : X) -> (R x1 x2).1 -> (A x1).1 -> (A x2).1)) 31 | ((x1 x2 : X) -> (A x1).1 -> (A x2).1 -> (R x1 x2).1) 32 | 33 | propiseqclass (X : U) (R : hrel X) (A : hsubtypes X) : isProp (iseqclass X R A) = 34 | propAnd (prod (ishinh (carr X A)).1 35 | ((x1 x2 : X) -> (R x1 x2).1 -> (A x1).1 -> (A x2).1)) 36 | ((x1 x2 : X) -> (A x1).1 -> (A x2).1 -> (R x1 x2).1) 37 | (propAnd (ishinh (carr X A)).1 38 | ((x1 x2 : X) -> (R x1 x2).1 -> (A x1).1 -> (A x2).1) p1 p2) p3 39 | where 40 | p1 : isProp (ishinh (carr X A)).1 = propishinh (carr X A) 41 | p2 (f g : (x1 x2 : X) -> (R x1 x2).1 -> (A x1).1 -> (A x2).1) : 42 | Path ((x1 x2 : X) -> (R x1 x2).1 -> (A x1).1 -> (A x2).1) f g = 43 | \(x1 x2 : X) (h1 : (R x1 x2).1) (h2 : (A x1).1) -> 44 | (A x2).2 (f x1 x2 h1 h2) (g x1 x2 h1 h2) @ i 45 | p3 (f g : (x1 x2 : X) -> (A x1).1 -> (A x2).1 -> (R x1 x2).1) : 46 | Path ((x1 x2 : X) -> (A x1).1 -> (A x2).1 -> (R x1 x2).1) f g = 47 | \(x1 x2 : X) (h1 : (A x1).1) (h2 : (A x2).1) -> 48 | (R x1 x2).2 (f x1 x2 h1 h2) (g x1 x2 h1 h2) @ i 49 | 50 | existsel2 (A : U) (B : A -> U) (C : U) (D : C -> U) 51 | (P: PROP) (f : (x : A) (_ : B x) (y : C) (_ : D y) -> P.1) 52 | (e0 : (exists A B).1) (e1 : (exists C D).1) : P.1 53 | = let 54 | T0 : U = (c : C) (d : D c) -> P.1 55 | pT0 : isProp T0 = propPi C (\(c : C) -> (D c) -> P.1) 56 | (\(c : C) -> propPi (D c) (\(_ : D c) -> P.1) (\(_ : D c) -> P.2)) 57 | in existsel C D P (existsel A B (T0, pT0) f e0) e1 58 | 59 | -- require iso_sigma 60 | sethProp (P P': PROP) : isProp (Path PROP P P') 61 | = propidU (Path PROP P P') (equiv P.1 P'.1) rem (propequiv P.1 P'.1 P'.2) 62 | where 63 | rem1: Path U (Path PROP P P') (Path U P.1 P'.1) = lemSigProp U isProp propIsProp P P' 64 | rem2: Path U (Path U P.1 P'.1) (equiv P.1 P'.1) = corrUniv P.1 P'.1 65 | rem: Path U (Path PROP P P') (equiv P.1 P'.1) = 66 | composition U (Path PROP P P') (Path U P.1 P'.1) (equiv P.1 P'.1) rem1 rem2 67 | 68 | subtypeEquality (A: U) (B: A -> U) (pB: (x : A) -> isProp (B x)) 69 | (s t: Sigma A B) : Path A s.1 t.1 -> Path (Sigma A B) s t = 70 | trans (Path A s.1 t.1) (Path (Sigma A B) s t) ( lemSigProp A B pB s t @ -i) 71 | 72 | sethsubtypes (X : U) : isSet (hsubtypes X) = setPi X (\(_ : X) -> PROP) (\(_ : X) -> sethProp) 73 | 74 | -- Subset 75 | subset (A: U) (_: isSet A): U = A -> PROP 76 | lem (A:U) (P:A->U) (pP:(x:A) -> isProp (P x)) (u v:(x:A) * P x) (p:Path A u.1 v.1) : 77 | Path ((x:A)*P x) u v = (p@i,(lemPropF A P pP u.1 v.1 p u.2 v.2)@i) 78 | 79 | -------------------------------------------------------------------------------- /cubicaltt/src/suspension.ctt: -------------------------------------------------------------------------------- 1 | module suspension where 2 | import proto 3 | import iso 4 | import s1 5 | import pointed 6 | 7 | data susp (A : U) = north | south| merid (a : A) [ (i=0) -> north , (i=1) -> south ] 8 | 9 | suspension (A: U): nat -> U = split { zero -> A ; succ x -> susp (suspension A x) } 10 | Sn: nat -> U = suspension bool 11 | sn: nat -> U = split { zero -> bool ; succ x -> susp (Sn x) } 12 | 13 | S2 : U = susp S1 14 | S3 : U = susp S2 15 | S4 : U = susp S3 16 | 17 | merid1 (A : U) (a : A) : Path (susp A) north south = merid {susp A} a @ i 18 | susppt (A : U) : pointed = (susp A,north) 19 | S1pt : pointed = (S1,base) 20 | S2pt : pointed = susppt S1 21 | S3pt : pointed = susppt S2 22 | 23 | suspS1 : susp bool -> S1 = split 24 | north -> base 25 | south -> base 26 | merid b @ i -> let case : bool -> Path S1 base base = split 27 | false -> loop1 28 | true -> <_> base 29 | in case b @ i 30 | 31 | S1susp : S1 -> susp bool = split 32 | base -> north 33 | loop @ i -> composition (susp bool) north south north 34 | (merid1 bool false) ( merid1 bool true @ -i) @ i 35 | 36 | suspOf (A X : U) : U = (u:X) * (v:X) * (A -> Path X u v) 37 | 38 | funToL (A X:U) (f:susp A -> X) : suspOf A X = (f north,f south,\ (a:A) -> f (merid{susp A} a@i)) 39 | lToFun (A X:U) (z:suspOf A X) : susp A -> X = split 40 | north -> z.1 41 | south -> z.2.1 42 | merid a @ i-> z.2.2 a @ i 43 | 44 | suspOfLem (A X:U) (f:susp A ->X) 45 | : (u:susp A) -> Path X (lToFun A X (funToL A X f) u) (f u) 46 | = split 47 | north -> refl X (f north) 48 | south -> refl X (f south) 49 | merid a @ i -> refl X (f (merid{susp A} a @ i)) 50 | 51 | test1 (A X:U) (z:suspOf A X) 52 | : Path (suspOf A X) (funToL A X (lToFun A X z)) z 53 | = refl (suspOf A X) z 54 | 55 | test2 (A X:U) (f:susp A ->X) 56 | : Path (susp A ->X) (lToFun A X (funToL A X f)) f 57 | = \ (u:susp A) -> suspOfLem A X f u @ i 58 | 59 | funSusp (A X:U) 60 | : Path U (susp A -> X) (suspOf A X) 61 | = isoPath (susp A -> X) (suspOf A X) (funToL A X) (lToFun A X) (test1 A X) (test2 A X) 62 | -------------------------------------------------------------------------------- /cubicaltt/src/topos.ctt: -------------------------------------------------------------------------------- 1 | {- Topos Theory: 2 | - Category, Pullback, Mono, Epi, Set, subobjectClassifier, CCC; 3 | - setSig, setPi, SET, Path; 4 | - Topos, Set Topos. 5 | Copyright (c) Groupoid Infinity, 2014-2018 -} 6 | 7 | -- https://groupoid.space/math/topos/ 8 | 9 | module topos where 10 | import cat 11 | import fun 12 | import pi 13 | import iso_sigma 14 | 15 | epi (P: precategory) (X Y: carrier P) (f: hom P X Y): U 16 | = (Z: carrier P) (g1 g2: hom P Y Z) 17 | -> Path (hom P X Z) (compose P X Y Z f g1) (compose P X Y Z f g2) 18 | -> Path (hom P Y Z) g1 g2 19 | 20 | mono (P: precategory) (Y Z: carrier P) (f: hom P Y Z): U 21 | = (X: carrier P) (g1 g2: hom P X Y) 22 | -> Path (hom P X Z) (compose P X Y Z g1 f) (compose P X Y Z g2 f) 23 | -> Path (hom P X Y) g1 g2 24 | 25 | -- Lawvere Topos 26 | subobjectClassifier (C: precategory): U 27 | = (omega: carrier C) 28 | * (end: terminal C) 29 | * (trueHom: hom C end.1 omega) 30 | * (xi: (V X: carrier C) (j: hom C V X) -> hom C X omega) 31 | * (square: (V X: carrier C) (j: hom C V X) -> mono C V X j 32 | -> hasPullback C (omega,(end.1,trueHom),(X,xi V X j))) 33 | * ((V X: carrier C) (j: hom C V X) (k: hom C X omega) 34 | -> mono C V X j 35 | -> hasPullback C (omega,(end.1,trueHom),(X,k)) 36 | -> Path (hom C X omega) (xi V X j) k) 37 | 38 | Set: precategory = ((Ob,Hom),id,c,HomSet,L,R,Q) where 39 | Ob: U = SET 40 | Hom (A B: Ob): U = A.1 -> B.1 41 | id (A: Ob): Hom A A = idfun A.1 42 | c (A B C: Ob) (f: Hom A B) (g: Hom B C): Hom A C = o A.1 B.1 C.1 g f 43 | HomSet (A B: Ob): isSet (Hom A B) = setFun A.1 B.1 B.2 44 | L (A B: Ob) (f: Hom A B): Path (Hom A B) (c A A B (id A) f) f = refl (Hom A B) f 45 | R (A B: Ob) (f: Hom A B): Path (Hom A B) (c A B B f (id B)) f = refl (Hom A B) f 46 | Q (A B C D: Ob) (f: Hom A B) (g: Hom B C) (h: Hom C D) 47 | : Path (Hom A D) (c A C D (c A B C f g) h) (c A B D f (c B C D g h)) 48 | = refl (Hom A D) (c A B D f (c B C D g h)) 49 | 50 | isCCC (C: precategory): U 51 | = (Exp: (A B: carrier C) -> carrier C) 52 | * (Prod: (A B: carrier C) -> carrier C) 53 | * (Apply: (A B: carrier C) -> hom C (Prod (Exp A B) A) B) 54 | * (P1: (A B: carrier C) -> hom C (Prod A B) A) 55 | * (P2: (A B: carrier C) -> hom C (Prod A B) B) 56 | * (Term: terminal C) 57 | * unit -- Beta, Eta rules, Either, CoCartesian, DepTypes ? 58 | 59 | cartesianClosed : isCCC Set 60 | = (expo,prod,appli,proj1,proj2,term,tt) where 61 | exp (A B: SET): SET = (A.1 -> B.1, setFun A.1 B.1 B.2) 62 | pro (A B: SET): SET = (prod A.1 B.1, setSig A.1 (\(_ : A.1) -> B.1) A.2 (\(_ : A.1) -> B.2)) 63 | expo: (A B: SET) -> SET = \(A B: SET) -> exp A B 64 | prod: (A B: SET) -> SET = \(A B: SET) -> pro A B 65 | appli: (A B: SET) -> hom Set (pro (exp A B) A) B = \(A B:SET)-> \(x:(pro(exp A B)A).1)-> x.1 x.2 66 | proj1: (A B: SET) -> hom Set (pro A B) A = \(A B: SET) (x: (pro A B).1) -> x.1 67 | proj2: (A B: SET) -> hom Set (pro A B) B = \(A B: SET) (x: (pro A B).1) -> x.2 68 | unitContr (x: SET) (f: x.1 -> unit) : isContr (x.1 -> unit) 69 | = (f, \(z: x.1 -> unit) -> propPi x.1 (\(_:x.1)->unit) (\(x:x.1) ->propUnit) f z) 70 | term: terminal Set = ((unit,setUnit),\(x: SET) -> unitContr x (\(z: x.1) -> tt)) 71 | 72 | hasSubobject : subobjectClassifier Set = undefined 73 | 74 | Topos (cat: precategory) : U 75 | = (cartesianClosed: isCCC cat) 76 | * subobjectClassifier cat 77 | 78 | internal : Topos Set 79 | = (cartesianClosed,hasSubobject) 80 | 81 | presheaf (C: precategory): U 82 | = catfunctor (opCat C) Set 83 | 84 | prestack (C: precategory) (X: U): U 85 | = grpfunctor (opCat C) (PathGrpd X) 86 | 87 | Co (C: precategory) (cod: carrier C) : U 88 | = (dom: carrier C) 89 | * (morphism: hom C dom cod) 90 | * unit 91 | 92 | Delta (C: precategory) (d: carrier C) : U 93 | = (index: U) 94 | * (family: index -> Co C d) 95 | * unit 96 | 97 | Coverage (C: precategory): U 98 | = (cod: carrier C) 99 | * (fam: Delta C cod) 100 | * (coverings: carrier C -> Delta C cod -> U) 101 | * (coverings cod fam) 102 | 103 | site (C: precategory): U 104 | = (C: precategory) 105 | * Coverage C 106 | 107 | sheaf (C: precategory): U 108 | = (S: site C) 109 | * presheaf S.1 110 | 111 | --- http://www.ams.org/notices/200409/what-is-illusie.pdf 112 | -------------------------------------------------------------------------------- /cubicaltt/src/univ.ctt: -------------------------------------------------------------------------------- 1 | {- Univalence: 2 | - univ. 3 | Copyright (c) Groupoid Infinity, 2014-2018. -} 4 | 5 | module univ where 6 | import retract 7 | import equiv 8 | import sigma 9 | import path 10 | import iso 11 | 12 | {- Univalence theorems are isomorphic at any level of equality: 13 | 14 | univalence (B: U): isContr ((A: U) * equiv B A) = undefined 15 | 16 | 1. Path (A = B) - path 17 | 2. Equiv (A ~ B) - sigma, fibrant 18 | 3. Iso (A == B) - adjoints 19 | 20 | Path: built-in 21 | 22 | Equiv: 23 | 24 | isContr (A: U): U = (x: A) * ((y: A) -> Path A x y) 25 | fiber (A B: U) (f: A -> B) (y: B): U = (x: A) * Path B y (f x) 26 | isEquiv (A B: U) (f: A -> B): U = (y: B) -> isContr (fiber A B f y) 27 | 28 | Iso: 29 | 30 | isIso (A B: U): U 31 | = (f: A -> B) 32 | * (g: B -> A) 33 | * (s: section A B f g) 34 | * (t: retract A B f g) 35 | * unit 36 | 37 | Iso(Equiv,Path) -- equivToPath, pathToEquiv 38 | Equiv(swap(Equiv),Iso(Equ,Equiv)) -- univalence, (slow) 39 | Equiv(Equiv,Iso(Path,Equiv)) -- univalence, (fast) 40 | Path(Path,Equiv) -- pathEqEquiv 41 | Equiv(Path,Equiv) -- pathEquivEquiv -} 42 | 43 | -- This is Corollary 10 of the cubical type theory paper 44 | -- (the proof of theorem 9 is inlined) (due to Fabian Ruch). 45 | univalenceAlt (B: U): isContr ((A: U) * equiv A B) 46 | = ((B,idEquiv B), \(w: (X:U) * equiv X B) -> 47 | let GlueB: U = Glue B [(i=0) -> (B,idEquiv B), (i=1) -> w] 48 | unglueB (g: GlueB): B = unglue g [(i=0) -> (B,idEquiv B),(i=1) -> w] 49 | in (GlueB,unglueB, \(b: B) -> 50 | ((glue (comp ( B) b [(i=0) -> b,(i=1) -> (w.2.2 b).1.2]) 51 | [(i=0) -> b, (i=1) -> (w.2.2 b).1.1] , 52 | fill ( B) b [(i=0) -> b, (i=1) -> (w.2.2 b).1.2]), 53 | \(v: fiber GlueB B unglueB b) -> 54 | (glue (comp ( B) b [(i=0) -> v.2 @ (j /\ k), 55 | (i=1) -> ((w.2.2 b).2 v @ j).2, 56 | (j=0) -> fill ( B) b [(i=0) -> b, (i=1) -> (w.2.2 b).1.2], 57 | (j=1) -> v.2]) 58 | [(i=0)-> v.2 @ j,(i=1) -> ((w.2.2 b).2 v @ j).1], 59 | fill ( B) b [(i=0) -> v.2 @ (j /\ l), 60 | (i=1) -> ((w.2.2 b).2 v @ j).2, 61 | (j=0) -> fill ( B) b [(i=0) -> b, (i=1) -> (w.2.2 b).1.2], 62 | (j=1) -> v.2])))) 63 | 64 | -- A version univalence. This is Corollary 11 of the cubical type theory paper. 65 | thmUniv (t: (A X: U) -> Path U X A -> equiv X A) (A: U) 66 | : (X: U) -> isEquiv (Path U X A) (equiv X A) (t A X) 67 | = equivFunFib U (\(X : U) -> Path U X A) (\(X: U) -> equiv X A) 68 | (t A) (isContrSingl' U A) (univalenceAlt A) 69 | 70 | univalence (A X: U) : isEquiv (Path U X A) (equiv X A) (transEquiv' A X) 71 | = thmUniv transEquiv' A X 72 | 73 | -- Univalence Intro 74 | ua (A B: U) (e: equiv A B): Path U A B 75 | = Glue B [ (i = 0) -> (A,e), (i = 1) -> (B,idEquiv B) ] 76 | 77 | uabeta (A B: U) (e: equiv A B): Path (A -> B) (trans A B (ua A B e)) e.1 78 | = \(a: A) -> fill (<_> B) (fill (<_> B) (e.1 a) [] @ -i) [] @ -i 79 | 80 | uabetaTransEquiv (A B: U) (e: equiv A B) : Path (A -> B) (transEquiv A B (ua A B e)).1 e.1 81 | = \(a: A) -> (uabeta A B e @ i) (fill (<_> A) a [] @ -i) 82 | 83 | uaret (A B: U): retract (equiv A B) (Path U A B) (ua A B) (transEquiv A B) 84 | = \(e: equiv A B) -> equivLemma A B (transEquiv A B (ua A B e)) e (uabetaTransEquiv A B e) 85 | 86 | f1 (A: U) (p: (B: U) * equiv A B): singl U A 87 | = (p.1,ua A p.1 p.2) 88 | 89 | f2 (A: U) (p: singl U A): ((B: U) * equiv A B) 90 | = (p.1,transEquiv A p.1 p.2) 91 | corrUniv (A B: U) : Path U (Path U A B) (equiv A B) 92 | = equivPath (Path U A B) (equiv A B) (transEquiv' B A) (univalence B A) 93 | 94 | corrUniv' (A B: U): equiv (Path U A B) (equiv A B) 95 | = (transEquiv' B A,univalence B A) 96 | 97 | -- Elimination principle for equivalences 98 | contrSinglEquiv (A B: U) (f: equiv A B): Path ((X: U) * equiv X B) (B,idEquiv B) (A,f) 99 | = isContrProp ((X: U) * equiv X B) (univalenceAlt B) (B,idEquiv B) (A,f) 100 | 101 | elimEquiv (B: U) (P: (A: U) -> (A -> B) -> U) (d: P B (idfun B)) 102 | (A: U) (f: equiv A B): P A f.1 103 | = subst((X: U) * equiv X B) T (B,idEquiv B) (A,f) (contrSinglEquiv A B f) d where 104 | T (z:(X: U) * equiv X B): U = P z.1 z.2.1 105 | 106 | -- Elimination principle for iso 107 | elimIso (B: U) (Q: (A: U) -> (A -> B) -> (B -> A) -> U) 108 | (h1: Q B (idfun B) (idfun B)) (A: U) (f: A -> B): (g: B -> A) -> 109 | section A B f g -> retract A B f g -> Q A f g = rem1 A f where 110 | P (A: U) (f: A -> B): U 111 | = (g: B -> A) -> section A B f g -> retract A B f g -> Q A f g 112 | rem: P B (idfun B) = \ (g: B -> B) (sg: section B B (idfun B) g) (rg: retract B B (idfun B) g) -> 113 | substInv (B -> B) (Q B (idfun B)) g (idfun B) ( \(b: B) -> (sg b) @ i) h1 114 | rem1 (A: U) (f: A -> B): P A f = \(g: B -> A) (sg: section A B f g) (rg: retract A B f g) -> 115 | elimEquiv B P rem A (f,isoToEquiv A B f g sg rg) g sg rg 116 | 117 | elimIsIso (A : U) (Q : (B : U) -> (A -> B) -> (B -> A) -> U) 118 | (d : Q A (idfun A) (idfun A)) (B : U) (f : A -> B) (g : B -> A) 119 | (sg : section A B f g) (rg : retract A B f g) : Q B f g = 120 | elimIso A (\(B : U) (f : B -> A) (g : A -> B) -> Q B g f) d B g f rg sg 121 | 122 | ------------------------------------------ VERY SLOW 123 | {- 124 | uaretsig (A: U): retract ((B: U) * equiv A B) (singl U A) (f1 A) (f2 A) 125 | = \(p: (B: U) * equiv A B) -> (p.1,uaret A p.1 p.2 @ i) 126 | 127 | univalenceAlt' (B: U) : isContr ((A: U) * equiv B A) 128 | = retIsContr ((A:U) * equiv B A) (singl U B) (f1 B) (f2 B) (uaretsig B) (isContrPath B) 129 | 130 | thmUniv' (t: (A X: U) -> Path U A X -> equiv A X) (A: U) 131 | : (X: U) -> isEquiv (Path U A X) (equiv A X) (t A X) 132 | = equivFunFib U (\(X: U) -> Path U A X) (\(X: U) -> equiv A X) 133 | (t A) (isContrSingl U A) (univalenceAlt' A) 134 | 135 | univalence' (A X: U): isEquiv (Path U A X) (equiv A X) (transEquiv A X) 136 | = thmUniv' transEquiv A X 137 | -} 138 | ----------------- 139 | -------------------------------------------------------------------------------- /cubicaltt/src/vector.ctt: -------------------------------------------------------------------------------- 1 | {- Vector: 2 | Copyright (c) Groupoid Infinity, 2014-2018. -} 3 | 4 | module vector where 5 | import nat 6 | import list 7 | 8 | data vector (A: U) (n: nat) 9 | = vzero 10 | | vsucc (x: A) (xs: vector A (pred n)) 11 | 12 | vz (A: U): vector A zero = vzero 13 | vs (A: U) (x: A) (n: nat) (xs: vector A n): vector A (succ n) = vsucc x xs 14 | 15 | opaque vector 16 | 17 | vector2 (n: nat) (A: U): U 18 | = (c: list nat) 19 | * (Path nat (length nat c) n) 20 | 21 | -------------------------------------------------------------------------------- /doc/bsc.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupoid/axio/70d23ed54f4b28bbd3feb5ba534717df38fd2be5/doc/bsc.pdf -------------------------------------------------------------------------------- /doc/msc.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupoid/axio/70d23ed54f4b28bbd3feb5ba534717df38fd2be5/doc/msc.pdf -------------------------------------------------------------------------------- /doc/pl1.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/groupoid/axio/70d23ed54f4b28bbd3feb5ba534717df38fd2be5/doc/pl1.pdf -------------------------------------------------------------------------------- /footer.pug: -------------------------------------------------------------------------------- 1 | 2 | footer.footer 3 | a(href='https://5ht.co/license/') 4 | img.footer__logo(src='https://longchenpa.guru/seal.png',width=50) 5 | span.footer__copy 2016—2025 © Максим Сохацький 6 | script(src='https://groupoid.space/highlight.js') 7 | script(src='https://groupoid.space/bundle.js') 8 | -------------------------------------------------------------------------------- /framework.js: -------------------------------------------------------------------------------- 1 | // Mixin usages in PUG: 2 | 3 | // +tex(false, false). 4 | // $\mathbf{Definition}$ (Space of Sections). Let $\mathbf{H}$ be 5 | // a $(\infty,1)$-topos, and let $E \rightarrow B : \mathbf{H}_{/B}$ a bundle in 6 | // $\mathbf{H}$, object in the slice topos. Then the space of sections $\Gamma_\Sigma(E)$ 7 | // of this bundle is the Dependent Product. 8 | 9 | // +tex(true, false). 10 | // $$ 11 | // \Gamma_\Sigma(E) = \Pi_\Sigma (E) \in \mathbf{H}. 12 | // $$ 13 | 14 | // +code. 15 | // def Pi (A : U) (B : A → U) : U := Π (x : A), B x 16 | 17 | const {mathjax} = require('mathjax-full/js/mathjax.js'); 18 | const {TeX} = require('mathjax-full/js/input/tex.js'); 19 | const {SVG} = require('mathjax-full/js/output/svg.js'); 20 | const {liteAdaptor} = require('mathjax-full/js/adaptors/liteAdaptor.js'); 21 | const {RegisterHTMLHandler} = require('mathjax-full/js/handlers/html.js'); 22 | const {AssistiveMmlHandler} = require('mathjax-full/js/a11y/assistive-mml.js'); 23 | const {AllPackages} = require('mathjax-full/js/input/tex/AllPackages.js'); 24 | 25 | const adaptor = liteAdaptor(); 26 | const handler = RegisterHTMLHandler(adaptor); 27 | 28 | const tex = new TeX({ 29 | packages: ['base', 'autoload', 'require', 'ams', 'amscd', 'newcommand', 'configmacros'], 30 | inlineMath: [ ["$", "$"] ], 31 | macros: { // Plug your Glyphs here 32 | llparenthesis: '\\mathopen{\u2987}', 33 | rrparenthesis: '\\mathclose{\u2988}', 34 | llbracket: '\\mathopen{\u27E6}', 35 | rrbracket: '\\mathclose{\u27E7}', 36 | incmap: '\\mathclose{\u21AA}', 37 | meet: '\\mathopen{\u2227}', 38 | map: '\\mathopen{\u21A6}', 39 | join: '\\mathopen{\u2228}', 40 | trans: '\\, \\mathbin{\\vcenter{\\rule{.3ex}{.3ex}}} \\,', 41 | mapright: ['\\xrightarrow{{#1}}', 1], 42 | mapdown: ['\\Big\\downarrow\\rlap{\\raise2pt{\\scriptstyle{#1}}}', 1], 43 | mapdiagl: ['\\vcenter{\\searrow}\\rlap{\\raise2pt{\\scriptstyle{#1}}}', 1], 44 | mapdiagr: ['\\vcenter{\\swarrow}\\rlap{\\raise2pt{\\scriptstyle{#1}}}', 1], 45 | } 46 | }); 47 | 48 | tex.postFilters.add(({math, data}) => { 49 | if (!data.error) return; 50 | data.root.walkTree((node) => { 51 | if (node.isKind('merror')) { 52 | console.log('TeX error:\n ' + node.attributes.get('data-mjx-error')); 53 | } 54 | }); 55 | }); 56 | 57 | const svg = new SVG({fontCache: 'local'}); 58 | 59 | function renderPug(block) { 60 | var recv; with({pug_html: ""}){ 61 | eval(`(${block})();`); recv = pug_html; 62 | }; return recv 63 | } 64 | 65 | function renderTeX(formulae) { 66 | return adaptor.innerHTML(mathjax.document(formulae, { 67 | InputJax: tex, OutputJax: svg 68 | }).render().document.body); 69 | } 70 | 71 | exports.tex = function (block) { 72 | return renderTeX(renderPug(block)); 73 | } 74 | 75 | exports.highlight = function (block) { 76 | return renderPug(block) 77 | .replace(/([(){}→=]+|:|:=)/g, 78 | '$1') 79 | .replace(/\b(∀|Π|Σ|W|λ|glue|unglue|Glue|transp|hcomp|where|def|begin|end|module|import|option|false|true|indᵂ|sup|.1|.2|𝟎|𝟏|𝟐|ind₂|ind₁|ind₀|★|0₂|1₂|PathP|PartialP|inc|ouc|axiom|theorem|lemdata|ma|U|V)\b(?!:)/g, 80 | '$1'); 81 | } 82 | -------------------------------------------------------------------------------- /header.pug: -------------------------------------------------------------------------------- 1 | mixin tex(center=false, paragraph=true) 2 | if paragraph 3 | p(style=center ? {'text-align': 'center' } : null)!= tex(`${block}`) 4 | else 5 | span(style=center ? { 6 | 'text-align': 'center', 7 | 'display': 'block', 8 | 'padding-top': '8px', 9 | 'padding-bottom': '8px', 10 | } : null)!= tex(`${block}`) 11 | 12 | mixin tex2(center=false, paragraph=true) 13 | p(style=center ? { 14 | 'text-align': 'center', 15 | 'display': 'block', 16 | 'padding-top': '8px', 17 | 'padding-bottom': '8px', 18 | } : null)!= tex(`${block}`) 19 | 20 | mixin code 21 | code!= highlight(`${block}`) 22 | 23 | mixin header(logo, title, subtitle) 24 | header.header 25 | .header__titles 26 | h1.header__title!= title 27 | h4.header__subtitle!= subtitle 28 | 29 | doctype html 30 | html 31 | head 32 | meta(charset='utf-8') 33 | meta(http-equiv='x-ua-compatible' content='ie=edge') 34 | meta(property='fb:app_id' content='118554188236439') 35 | meta(name='viewport' content='width=device-width, initial-scale=1') 36 | meta(name='author' content='Maxim Sokhatsky') 37 | meta(name='twitter:site' content='@5HT') 38 | meta(name='twitter:creator' content='@5HT') 39 | meta(property='og:type' content='website') 40 | meta(property='og:image' content='https://avatars.githubusercontent.com/u/17128096?s=400&u=66a63d4cdd9625b2b4b37d724cc00fe6401e5bd8&v=4') 41 | meta(name='msapplication-TileColor' content='#ffffff') 42 | meta(name='msapplication-TileImage' content='https://anders.groupoid.space/images/ms-icon-144x144.png') 43 | meta(name='theme-color' content='#ffffff') 44 | 45 | link(rel='stylesheet' href='https://anders.groupoid.space/main.css?v=1') 46 | link(rel='apple-touch-icon' sizes='57x57' href='https://anders.groupoid.space/images/apple-icon-57x57.png') 47 | link(rel='apple-touch-icon' sizes='60x60' href='https://anders.groupoid.space/images/apple-icon-60x60.png') 48 | link(rel='apple-touch-icon' sizes='72x72' href='https://anders.groupoid.space/images/apple-icon-72x72.png') 49 | link(rel='apple-touch-icon' sizes='76x76' href='https://anders.groupoid.space/images/apple-icon-76x76.png') 50 | link(rel='apple-touch-icon' sizes='114x114' href='https://anders.groupoid.space/images/apple-icon-114x114.png') 51 | link(rel='apple-touch-icon' sizes='120x120' href='https://anders.groupoid.space/images/apple-icon-120x120.png') 52 | link(rel='apple-touch-icon' sizes='144x144' href='https://anders.groupoid.space/images/apple-icon-144x144.png') 53 | link(rel='apple-touch-icon' sizes='152x152' href='https://anders.groupoid.space/images/apple-icon-152x152.png') 54 | link(rel='apple-touch-icon' sizes='180x180' href='https://anders.groupoid.space/images//apple-icon-180x180.png') 55 | link(rel='icon' type='image/png' sizes='192x192' href='https://anders.groupoid.space/images/android-icon-192x192.png') 56 | link(rel='icon' type='image/png' sizes='32x32' href='https://anders.groupoid.space/images/favicon-32x32.png') 57 | link(rel='icon' type='image/png' sizes='96x96' href='https://anders.groupoid.space/images/favicon-96x96.png') 58 | link(rel='icon' type='image/png' sizes='16x16' href='https://anders.groupoid.space/images/favicon-16x16.png') 59 | link(rel='manifest' href='https://anders.groupoid.space/images/manifest.json') 60 | 61 | style. 62 | p {font-size: 16px} 63 | svg a{fill:blue;stroke:blue} 64 | [data-mml-node="merror"]>g{fill:red;stroke:red} 65 | [data-mml-node="merror"]>rect[data-background]{fill:yellow;stroke:none} 66 | [data-frame],[data-line]{stroke-width:70px;fill:none} 67 | .mjx-dashed{stroke-dasharray:140} 68 | .mjx-dotted{stroke-linecap:round;stroke-dasharray:0,140} 69 | use[data-c]{stroke-width:3px} 70 | 71 | body.content 72 | block vars 73 | block content 74 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "formalsystem", 3 | "version": "1.0.1", 4 | "description": "FORMAL/1: Groupoid Infinity Formal System", 5 | "main": "", 6 | "scripts": { 7 | "start": "node-sass ../groupoid.space/styles -o ./ && pug -O ./framework.js index.pug ", 8 | "test": "echo \"Error: no test specified\" && exit 1" 9 | }, 10 | "repository": { 11 | "type": "git", 12 | "url": "git://github.com/groupoid/axiom.dev" 13 | }, 14 | "author": "Namdak Tonpa", 15 | "license": "DHARMA", 16 | "preinstall": "npm i -g node-sass && npm i -g pug-cli", 17 | "devDependencies": { 18 | "mathjax-full": "^3.2.0", 19 | "node-sass": "^7.0.1", 20 | "npm": "^7.20.6", 21 | "pug": "^3.0.2", 22 | "pug-cli": "^1.0.0-alpha6", 23 | "sass": "^1.2.1" 24 | } 25 | } 26 | -------------------------------------------------------------------------------- /theorems/Fermat's Last Theorem.md: -------------------------------------------------------------------------------- 1 | Number Theory: Fermat’s Last Theorem 2 | ==================================== 3 | 4 | Theorem: For integers 𝑛 > 2, there are no positive integers 𝑎,𝑏,𝑐 such that 𝑎ⁿ + 𝑏ⁿ = 𝑐ⁿ. 5 | 6 | ⊢ ∀ 𝑎 𝑏 𝑐 𝑛 : ℕ, 𝑎 > 0, 𝑏 > 0, 𝑐 > 0, 𝑛 > 2 → ¬(𝑎ⁿ + 𝑏ⁿ = 𝑐ⁿ) 7 | 8 | Type Formers: 9 | 10 | * Use ℕ,Π,Σ,Id from Anders. 11 | * R: Type: Reals (for integers via embedding), (L,U): R: Dedekind cuts (though we’ll use 𝑍) from Julius. 12 | * V: Type: Cumulative hierarchy for sets (e.g., elliptic curves), Z:V (integers as a Set), LEM:P∨¬P: Classical logic (used in Wiles’ proof) from Ernst. 13 | * Group,Ring: Type: Algebraic structures, Simplicial: Type: Simplicial sets for modular forms and stacks from Dan. 14 | * G→A:Type: Group actions (e.g., Galois groups), ∣ʃA: Type: Homotopy types from Urs. 15 | 16 | Encoding: 17 | 18 | * Z:V (Julius), defined as Z={(m,n):N×N}/∼, where (m,n)∼(p,q) if m+q=n+p. 19 | * Z+ ={z:Z∣z>0}:V (Julius). 20 | * ⊢ a:Z,n:N ⊢ pow(a,n):Z (exponentiation 𝑎ⁿ): pow : ℕ → ℕ → ℤ. 21 | * Statement: Γ ⊢ ∀ a b c n : ℕ, a > 0, b > 0, c > 0, n > 2 → ¬(pow a n + pow b n = pow c n) : Prop. 22 | * ⊢ Fermat(n):Prop=Σ(a:Z+).Σ(c:Z+).Id_Z(pow(a,n)+pow(b,n),pow(c,n)). 23 | * Goal: ⊢ Π(𝑛:𝑁).(𝑛>2) → ¬Fermat(n), where ¬𝐴 ≡ 𝐴 → ∅. 24 | 25 | Proof Sketch: 26 | 27 | * Wiles’ proof uses elliptic curves, modular forms, and Galois representations. 28 | * Define elliptic curves in V (ZFC type) as sets of points satisfying 𝑦2=𝑥3+𝑎𝑥+𝑏. 29 | * Use group actions (𝔾 → A) from Super Type Theory for Galois groups. 30 | * Encode modular forms via simplicial sets (e.g., modular curves as simplicial objects). 31 | * Requires LEM for classical steps (e.g., reductio ad absurdum). 32 | 33 | Lemmas: 34 | 35 | * Elliptic Curves (a stack over 𝑄 via Dan Kan). 36 | * Frey Curve Semistable, minimal discriminant Δ=2^8(𝑎𝑏𝑐)^{2n}. 37 | * Modular Forms (a moduli stack of elliptic curves with level structure, Hecke algebra acting on modular forms). 38 | * Galois Representations (ρ_E : G_Q → GL_2(Z_p)) (via group action in Equivariant Super Type Theory). 39 | * Ribet-Serre Theorem. 40 | * Modularity Theorem. 41 | 42 | --------------------------------------------------------------------------------