├── .gitignore ├── .travis.yml ├── CTT.hs ├── Connections.hs ├── Eval.hs ├── Exp.cf ├── GNUmakefile ├── LICENSE ├── Main.hs ├── Makefile ├── README.md ├── Resolver.hs ├── Setup.hs ├── TypeChecker.hs ├── cubicaltt.cabal ├── cubicaltt.el ├── cubicaltt.vim ├── examples ├── Makefile ├── README.md ├── algstruct.ctt ├── binnat.ctt ├── bool.ctt ├── brunerie.ctt ├── category.ctt ├── circle.ctt ├── collection.ctt ├── constcubes.ctt ├── control.ctt ├── csystem.ctt ├── demo.ctt ├── discor.ctt ├── equiv.ctt ├── grothendieck.ctt ├── groupoidTrunc.ctt ├── hedberg.ctt ├── helix.ctt ├── hnat.ctt ├── hz.ctt ├── idtypes.ctt ├── injective.ctt ├── int.ctt ├── integer.ctt ├── interval.ctt ├── lambek.ctt ├── list.ctt ├── nat.ctt ├── opposite.ctt ├── ordinal.ctt ├── pi.ctt ├── pointedMaps.ctt ├── prelude.ctt ├── propTrunc.ctt ├── retract.ctt ├── setquot.ctt ├── sigma.ctt ├── subset.ctt ├── summary.ctt ├── susp.ctt ├── torsor.ctt ├── torus.ctt ├── univalence.ctt └── univprop.ctt ├── experiments ├── andrew_puzzle.ctt ├── deppath.ctt ├── equiv.ctt ├── exchange.ctt ├── girard.ctt ├── helix.ctt ├── hopf.ctt ├── implicit_point.ctt ├── isoToEquiv.ctt ├── join.ctt ├── multS1.ctt ├── mystery.ctt ├── other.ctt ├── pi1S2output.ctt ├── pi1s2.ctt ├── pi4s3.ctt ├── pointed.ctt ├── prop.ctt ├── quotient.ctt ├── s2.ctt ├── set.ctt ├── setTrunc.ctt ├── stream.ctt ├── testall.ctt ├── testempty.ctt ├── thm7312.ctt ├── truncS2.ctt ├── uafunext1.ctt ├── uafunext2.ctt ├── univalence.ctt └── univalence_dan.ctt ├── lectures ├── README.md ├── lecture1.ctt ├── lecture2.ctt ├── lecture3.ctt └── lecture4.ctt ├── stack.yaml └── utils ├── graph └── testall /.gitignore: -------------------------------------------------------------------------------- 1 | TAGS 2 | *~ 3 | *.hi 4 | *.ho 5 | *.o 6 | dist/ 7 | Exp/ 8 | cubical 9 | Makefile.bak 10 | Main 11 | .depends-made 12 | .cabal-sandbox 13 | cabal.sandbox.config 14 | .stack-work 15 | .*.sw? 16 | 17 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the simple Travis configuration, which is intended for use 2 | # on applications which do not require cross-platform and 3 | # multiple-GHC-version support. For more information and other 4 | # options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | 11 | # Use new container infrastructure to enable caching 12 | sudo: false 13 | 14 | # Do not choose a language; we provide our own build tools. 15 | language: generic 16 | 17 | # Caching so the next build will be fast too. 18 | cache: 19 | directories: 20 | - $HOME/.stack 21 | 22 | # Ensure necessary system libraries are present 23 | addons: 24 | apt: 25 | packages: 26 | - libgmp-dev 27 | 28 | before_install: 29 | # Download and unpack the stack executable 30 | - mkdir -p ~/.local/bin 31 | - export PATH=$HOME/.local/bin:$PATH 32 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 33 | 34 | install: 35 | # Build dependencies 36 | - stack --no-terminal --install-ghc test --only-dependencies 37 | 38 | script: 39 | # Build the package, its tests, and its docs and run the tests 40 | - stack --no-terminal build --haddock --no-haddock-deps 41 | -------------------------------------------------------------------------------- /Exp.cf: -------------------------------------------------------------------------------- 1 | entrypoints Module, Exp ; 2 | 3 | comment "--" ; 4 | comment "{-" "-}" ; 5 | 6 | layout "where", "let", "split", "mutual", "with" ; 7 | layout stop "in" ; 8 | -- Do not use layout toplevel as it makes pExp fail! 9 | 10 | Module. Module ::= "module" AIdent "where" "{" [Imp] [Decl] "}" ; 11 | 12 | Import. Imp ::= "import" AIdent ; 13 | separator Imp ";" ; 14 | 15 | DeclDef. Decl ::= AIdent [Tele] ":" Exp "=" ExpWhere ; 16 | DeclData. Decl ::= "data" AIdent [Tele] "=" [Label] ; 17 | DeclHData. Decl ::= "hdata" AIdent [Tele] "=" [Label] ; 18 | DeclSplit. Decl ::= AIdent [Tele] ":" Exp "=" "split" "{" [Branch] "}" ; 19 | DeclUndef. Decl ::= AIdent [Tele] ":" Exp "=" "undefined" ; 20 | DeclMutual. Decl ::= "mutual" "{" [Decl] "}" ; 21 | DeclOpaque. Decl ::= "opaque" AIdent ; 22 | DeclTransparent. Decl ::= "transparent" AIdent ; 23 | DeclTransparentAll. Decl ::= "transparent_all" ; 24 | separator Decl ";" ; 25 | 26 | Where. ExpWhere ::= Exp "where" "{" [Decl] "}" ; 27 | NoWhere. ExpWhere ::= Exp ; 28 | 29 | Let. Exp ::= "let" "{" [Decl] "}" "in" Exp ; 30 | Lam. Exp ::= "\\" [PTele] "->" Exp ; 31 | PLam. Exp ::= "<" [AIdent] ">" Exp ; 32 | Split. Exp ::= "split@" Exp "with" "{" [Branch] "}" ; 33 | Fun. Exp1 ::= Exp2 "->" Exp1 ; 34 | Pi. Exp1 ::= [PTele] "->" Exp1 ; 35 | Sigma. Exp1 ::= [PTele] "*" Exp1 ; 36 | AppFormula. Exp2 ::= Exp2 "@" Formula ; 37 | App. Exp2 ::= Exp2 Exp3 ; 38 | PathP. Exp3 ::= "PathP" Exp4 Exp4 Exp4 ; 39 | Comp. Exp3 ::= "comp" Exp4 Exp4 System ; 40 | HComp. Exp3 ::= "hComp" Exp4 Exp4 System ; 41 | Trans. Exp3 ::= "transport" Exp4 Exp4 ; 42 | Fill. Exp3 ::= "fill" Exp4 Exp4 System ; 43 | Glue. Exp3 ::= "Glue" Exp4 System ; 44 | GlueElem. Exp3 ::= "glue" Exp4 System ; 45 | UnGlueElem. Exp3 ::= "unglue" Exp4 System ; 46 | Id. Exp3 ::= "Id" Exp4 Exp4 Exp3 ; 47 | IdPair. Exp3 ::= "idC" Exp4 System ; 48 | IdJ. Exp3 ::= "idJ" Exp4 Exp4 Exp4 Exp4 Exp4 Exp4 ; 49 | Fst. Exp4 ::= Exp4 ".1" ; 50 | Snd. Exp4 ::= Exp4 ".2" ; 51 | Pair. Exp5 ::= "(" Exp "," [Exp] ")" ; 52 | Var. Exp5 ::= AIdent ; 53 | PCon. Exp5 ::= AIdent "{" Exp "}" ; -- c{T A B} x1 x2 @ phi 54 | U. Exp5 ::= "U" ; 55 | Hole. Exp5 ::= HoleIdent ; 56 | coercions Exp 5 ; 57 | separator nonempty Exp "," ; 58 | 59 | Dir0. Dir ::= "0" ; 60 | Dir1. Dir ::= "1" ; 61 | 62 | System. System ::= "[" [Side] "]" ; 63 | 64 | Face. Face ::= "(" AIdent "=" Dir ")" ; 65 | separator Face "" ; 66 | 67 | Side. Side ::= [Face] "->" Exp ; 68 | separator Side "," ; 69 | 70 | Disj. Formula ::= Formula "\\/" Formula1 ; 71 | Conj. Formula1 ::= Formula1 CIdent Formula2 ; 72 | Neg. Formula2 ::= "-" Formula2 ; 73 | Atom. Formula2 ::= AIdent ; 74 | Dir. Formula2 ::= Dir ; 75 | coercions Formula 2 ; 76 | 77 | -- Branches 78 | OBranch. Branch ::= AIdent [AIdent] "->" ExpWhere ; 79 | -- TODO: better have ... @ i @ j @ k -> ... ? 80 | PBranch. Branch ::= AIdent [AIdent] "@" [AIdent] "->" ExpWhere ; 81 | separator Branch ";" ; 82 | 83 | -- Labelled sum alternatives 84 | OLabel. Label ::= AIdent [Tele] ; 85 | PLabel. Label ::= AIdent [Tele] "<" [AIdent] ">" System ; 86 | separator Label "|" ; 87 | 88 | -- Telescopes 89 | Tele. Tele ::= "(" AIdent [AIdent] ":" Exp ")" ; 90 | terminator Tele "" ; 91 | 92 | -- Nonempty telescopes with Exp:s, this is hack to avoid ambiguities 93 | -- in the grammar when parsing Pi 94 | PTele. PTele ::= "(" Exp ":" Exp ")" ; 95 | terminator nonempty PTele "" ; 96 | 97 | position token AIdent ('_')|(letter)(letter|digit|'\''|'_')*|('!')(digit)* ; 98 | separator AIdent "" ; 99 | 100 | token CIdent '/''\\' ; 101 | 102 | position token HoleIdent '?' ; -------------------------------------------------------------------------------- /GNUmakefile: -------------------------------------------------------------------------------- 1 | # ghc and bnfc don't update their output files' timestamps if the contents are 2 | # unchanged, but "make" expects commands to actually produce their output 3 | # files, so this is a poor match. (By contrast, alex and happy do update their 4 | # output files.) To defeat that, we touch the output files when trying to make them. 5 | 6 | GHC ?= ghc 7 | ALEX ?= alex 8 | HAPPY ?= happy 9 | BNFC ?= bnfc 10 | # or: 11 | # GHC = cabal exec ghc -- 12 | INPUT = CTT.hs Connections.hs Eval.hs Main.hs Resolver.hs TypeChecker.hs 13 | GRAMMAR = Exp.cf 14 | GRAMMAR_X_FILES = Exp/Lex.x 15 | GRAMMAR_Y_FILES = Exp/Par.y 16 | GRAMMAR_HS_FILES = Exp/Abs.hs Exp/ErrM.hs Exp/Layout.hs Exp/Print.hs Exp/Skel.hs Exp/Test.hs 17 | GRAMMAR_FILES := $(GRAMMAR_HS_FILES) $(GRAMMAR_X_FILES) $(GRAMMAR_Y_FILES) Exp/Doc.txt 18 | GRAMMAR_HS_FILES += $(GRAMMAR_X_FILES:.x=.hs) 19 | GRAMMAR_HS_FILES += $(GRAMMAR_Y_FILES:.y=.hs) 20 | GRAMMAR_OBJECT_FILES = $(GRAMMAR_HS_FILES:.hs=.o) 21 | GHCOPTIONS = -O2 -rtsopts -v0 22 | 23 | all: cubical 24 | 25 | # There should be a way to make ghc link with the appropriate libraries, 26 | # without using the --make option, but I can't figure it out. The libraries 27 | # used are: 28 | # QuickCheck array bytestring containers deepseq directory filepath haskeline 29 | # mtl old pretty random template terminfo time transformers unix 30 | # This is what I tried: 31 | # cubical: $(INPUT:.hs=.o) $(GRAMMAR_OBJECT_FILES); $(GHC) -o $@ $(GHCOPTIONS) $^ 32 | 33 | cubical: $(INPUT:.hs=.o) $(GRAMMAR_OBJECT_FILES) 34 | $(GHC) -M -dep-suffix "" $(INPUT) $(GRAMMAR_HS_FILES) 35 | $(GHC) --make $(GHCOPTIONS) -o cubical Main 36 | 37 | build-Makefile: $(INPUT) $(GRAMMAR_HS_FILES) 38 | $(GHC) -M -dep-suffix "" $^ 39 | 40 | include Makefile 41 | 42 | %.hi %.o: %.hs 43 | $(GHC) $(GHCOPTIONS) $< 44 | @ touch $*.hi $*.o 45 | %.hs: %.y 46 | $(HAPPY) -gca $< 47 | %.hs: %.x 48 | $(ALEX) -g $< 49 | 50 | bnfc $(GRAMMAR_FILES): Exp.cf 51 | $(BNFC) --haskell -d Exp.cf 52 | @ touch $(GRAMMAR_FILES) 53 | 54 | TAGS:; hasktags --etags $(INPUT) $(GRAMMAR) 55 | 56 | clean:; rm -rf Exp *.log *.aux *.hi *.o cubical TAGS Makefile.bak 57 | git-clean:; git clean -Xdfq 58 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Cyril Cohen, Thierry Coquand, Simon Huber, Anders Mörtberg 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # DO NOT DELETE: Beginning of Haskell dependencies 2 | Exp/ErrM.o : Exp/ErrM.hs 3 | Exp/Abs.o : Exp/Abs.hs 4 | Exp/Skel.o : Exp/Skel.hs 5 | Exp/Skel.o : Exp/ErrM.hi 6 | Exp/Skel.o : Exp/Abs.hi 7 | Exp/Print.o : Exp/Print.hs 8 | Exp/Print.o : Exp/Abs.hi 9 | Exp/Lex.o : Exp/Lex.hs 10 | Exp/Par.o : Exp/Par.hs 11 | Exp/Par.o : Exp/ErrM.hi 12 | Exp/Par.o : Exp/Lex.hi 13 | Exp/Par.o : Exp/Abs.hi 14 | Exp/Layout.o : Exp/Layout.hs 15 | Exp/Layout.o : Exp/Lex.hi 16 | Exp/Test.o : Exp/Test.hs 17 | Exp/Test.o : Exp/ErrM.hi 18 | Exp/Test.o : Exp/Layout.hi 19 | Exp/Test.o : Exp/Abs.hi 20 | Exp/Test.o : Exp/Print.hi 21 | Exp/Test.o : Exp/Skel.hi 22 | Exp/Test.o : Exp/Par.hi 23 | Exp/Test.o : Exp/Lex.hi 24 | Connections.o : Connections.hs 25 | CTT.o : CTT.hs 26 | CTT.o : Connections.hi 27 | Eval.o : Eval.hs 28 | Eval.o : CTT.hi 29 | Eval.o : Connections.hi 30 | Resolver.o : Resolver.hs 31 | Resolver.o : Connections.hi 32 | Resolver.o : Connections.hi 33 | Resolver.o : CTT.hi 34 | Resolver.o : CTT.hi 35 | Resolver.o : Exp/Abs.hi 36 | TypeChecker.o : TypeChecker.hs 37 | TypeChecker.o : Eval.hi 38 | TypeChecker.o : CTT.hi 39 | TypeChecker.o : Connections.hi 40 | Main.o : Main.hs 41 | Main.o : Eval.hi 42 | Main.o : TypeChecker.hi 43 | Main.o : Resolver.hi 44 | Main.o : CTT.hi 45 | Main.o : Exp/ErrM.hi 46 | Main.o : Exp/Layout.hi 47 | Main.o : Exp/Abs.hi 48 | Main.o : Exp/Print.hi 49 | Main.o : Exp/Par.hi 50 | Main.o : Exp/Lex.hi 51 | # DO NOT DELETE: End of Haskell dependencies 52 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Cubical Type Theory 2 | =================== 3 | 4 | Experimental implementation of [Cubical Type 5 | Theory](http://www.cse.chalmers.se/~coquand/cubicaltt.pdf) in which 6 | the user can directly manipulate n-dimensional cubes. The language 7 | extends type theory with: 8 | 9 | * Path abstraction and application 10 | * Composition and transport 11 | * Equivalences can be transformed into equalities (and univalence can 12 | be proved, see "examples/univalence.ctt") 13 | * Identity types (see "examples/idtypes.ctt") 14 | * Some higher inductive types (see "examples/circle.ctt" and 15 | "examples/integer.ctt") 16 | 17 | Because of this it is not necessary to have a special file of 18 | primitives (like in [cubical](https://github.com/simhu/cubical)), for 19 | instance function extensionality is directly provable in the system: 20 | 21 | ``` 22 | funExt (A : U) (B : A -> U) (f g : (x : A) -> B x) 23 | (p : (x : A) -> Id (B x) (f x) (g x)) : 24 | Id ((y : A) -> B y) f g = \(a : A) -> (p a) @ i 25 | ``` 26 | 27 | For examples, including a demo ("examples/demo.ctt"), see the 28 | [examples](https://github.com/mortberg/cubicaltt/tree/master/examples#cubical-type-theory-examples) 29 | folder. For a summary of where to find the main results of the cubical 30 | type theory paper in the examples folder see "examples/summary.ctt". 31 | 32 | The following keywords are reserved: 33 | 34 | ``` 35 | module, where, let, in, split, with, mutual, import, data, hdata, 36 | undefined, PathP, comp, transport, fill, Glue, glue, unglue, U, 37 | opaque, transparent, transparent_all, Id, idC, idJ 38 | ``` 39 | 40 | Install 41 | ------- 42 | 43 | You can compile the project using either `cabal`, `make`, or `stack`. 44 | 45 | ## Cabal 46 | 47 | To compile the project using [cabal](https://www.haskell.org/cabal/), 48 | first install the build-time dependencies (either globally or in a 49 | cabal sandbox): 50 | 51 | `cabal install alex happy bnfc` 52 | 53 | Then the project can be built (and installed): 54 | 55 | `cabal install` 56 | 57 | ## Make 58 | 59 | Alternatively, a `Makefile` is provided: 60 | 61 | ```sh 62 | make 63 | ``` 64 | 65 | 66 | This assumes that the following Haskell packages are installed using cabal: 67 | 68 | ``` 69 | mtl, haskeline, directory, BNFC, alex, happy, QuickCheck 70 | ``` 71 | 72 | To build the TAGS file, run: 73 | 74 | ```sh 75 | make TAGS 76 | ``` 77 | 78 | This assumes that ```hasktags``` has been installed. 79 | 80 | To clean up, run: 81 | 82 | ```sh 83 | make clean 84 | ``` 85 | 86 | ## Stack 87 | 88 | To compile and install the project using [stack](https://haskellstack.org/), run: 89 | 90 | ```sh 91 | stack setup 92 | stack install 93 | ``` 94 | 95 | Usage 96 | ----- 97 | 98 | To run the system type 99 | 100 | `cubical ` 101 | 102 | To see a list of options add the --help flag. In the interaction loop 103 | type :h to get a list of available commands. Note that the current 104 | directory will be taken as the search path for the imports. 105 | 106 | 107 | When using cabal sandboxes, `cubical` can be invoked using 108 | 109 | `cabal exec cubical ` 110 | 111 | 112 | To enable emacs to edit ```*.ctt``` files in ```cubicaltt-mode```, add the following 113 | line to your ```.emacs``` file: 114 | ``` 115 | (autoload 'cubicaltt-mode "cubicaltt" "cubical editing mode" t) 116 | (setq auto-mode-alist (append auto-mode-alist '(("\\.ctt$" . cubicaltt-mode)))) 117 | ``` 118 | and ensure that the file ```cubicaltt.el``` is visible in one of the diretories 119 | on emacs' ```load-path```, or else load it in advance, either manually with 120 | ```M-x load-file```, or with something like the following line in ```.emacs```: 121 | ``` 122 | (load-file "cubicaltt.el") 123 | ``` 124 | 125 | When using `cubicaltt-mode` in Emacs, the command `cubicaltt-load` will launch the 126 | interactive toplevel in an Emacs buffer and load the current file. It 127 | is bound to `C-c C-l` by default. If `cubical` is not on Emacs's 128 | `exec-path`, then set the variable `cubicaltt-command` to the command that 129 | runs it. 130 | 131 | References and notes 132 | -------------------- 133 | 134 | * [Cubical Type Theory: a constructive interpretation of the 135 | univalence 136 | axiom](http://www.cse.chalmers.se/~coquand/cubicaltt.pdf), Cyril 137 | Cohen, Thierry Coquand, Simon Huber, and Anders Mörtberg. This 138 | paper describes the type theory and its model. 139 | 140 | * [Canonicity for Cubical Type 141 | Theory](https://arxiv.org/abs/1607.04156), Simon Huber. Proof of 142 | canonicity for the type theory. 143 | 144 | * Voevodsky's lectures and texts on [univalent 145 | foundations](http://www.math.ias.edu/vladimir/home) 146 | 147 | * HoTT book and webpage: 148 | [http://homotopytypetheory.org/](http://homotopytypetheory.org/) 149 | 150 | * [Cubical Type Theory](http://www.cse.chalmers.se/~coquand/face.pdf) - 151 | Old version of the typing rules of the system. See 152 | [this](http://www.cse.chalmers.se/~coquand/face.pdf) for a 153 | variation using isomorphisms instead of equivalences. 154 | 155 | * [Internal version of the uniform Kan filling 156 | condition](http://www.cse.chalmers.se/~coquand/shape.pdf) 157 | 158 | * [A category of cubical 159 | sets](http://www.cse.chalmers.se/~coquand/vv.pdf) - main 160 | definitions towards a formalization 161 | 162 | * [hoq](https://github.com/valis/hoq/) - A language based on homotopy 163 | type theory with an interval (documentation available 164 | [here](https://docs.google.com/viewer?a=v&pid=forums&srcid=MTgzMDE5NzAyNTk5NDUxMjg3MDABMDQ5MTM3MjY5Nzc5MzY3ODYzNjABT3A0QWRIempiZTBKATAuMQEBdjI)). 165 | 166 | * [A Cubical Approach to Synthetic Homotopy 167 | Theory](http://dlicata.web.wesleyan.edu/pubs/lb15cubicalsynth/lb15cubicalsynth.pdf), 168 | Dan Licata, Guillaume Brunerie. 169 | 170 | * [Type Theory in 171 | Color](http://www.cse.chalmers.se/~bernardy/CCCC.pdf), 172 | Jean-Philippe Bernardy, Guilhem Moulin. 173 | 174 | * [A simple type-theoretic language: 175 | Mini-TT](http://www.cse.chalmers.se/~bengt/papers/GKminiTT.pdf), 176 | Thierry Coquand, Yoshiki Kinoshita, Bengt Nordström and Makoto 177 | Takeyama - This presents the type theory that the system is based 178 | on. 179 | 180 | * [A cubical set model of type 181 | theory](http://www.cse.chalmers.se/~coquand/model1.pdf), Marc 182 | Bezem, Thierry Coquand and Simon Huber. 183 | 184 | * [An equivalent presentation of the Bezem-Coquand-Huber category of 185 | cubical sets](http://arxiv.org/abs/1401.7807), Andrew Pitts - This 186 | gives a presentation of the cubical set model in nominal sets. 187 | 188 | * [Remark on singleton 189 | types](http://www.cse.chalmers.se/~coquand/singl.pdf), Thierry 190 | Coquand. 191 | 192 | * [Note on Kripke 193 | model](http://www.cse.chalmers.se/~coquand/countermodel.pdf), Marc 194 | Bezem and Thierry Coquand. 195 | 196 | 197 | Authors 198 | ------- 199 | 200 | Cyril Cohen, Thierry Coquand, Simon Huber, Anders Mörtberg 201 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | import Distribution.Simple.Program 3 | import System.Process (system) 4 | 5 | main :: IO () 6 | main = defaultMainWithHooks $ simpleUserHooks { 7 | hookedPrograms = [bnfc], 8 | preBuild = \args buildFlags -> do 9 | _ <- system "bnfc --haskell -d Exp.cf" 10 | preBuild simpleUserHooks args buildFlags 11 | } 12 | 13 | bnfc :: Program 14 | bnfc = (simpleProgram "bnfc") { 15 | programFindVersion = findProgramVersion "--version" id 16 | } 17 | -------------------------------------------------------------------------------- /cubicaltt.cabal: -------------------------------------------------------------------------------- 1 | -- Initial cubicaltt.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: cubicaltt 5 | version: 1.0 6 | synopsis: Experimental implementation of a cubical type theory 7 | description: Experimental implementation of a cubical type theory in 8 | which the user can directly manipulate n-dimensional cubes. 9 | license: MIT 10 | license-file: LICENSE 11 | author: Cyril Cohen, Thierry Coquand, Simon Huber, Anders Mörtberg 12 | maintainer: 13 | -- copyright: 14 | category: Language 15 | build-type: Custom 16 | extra-source-files: Makefile, README.md, Exp.cf, examples/*.ctt, cubicaltt.el 17 | cabal-version: >=1.10 18 | 19 | executable cubical 20 | main-is: Main.hs 21 | other-modules: 22 | Connections, 23 | CTT, 24 | Eval, 25 | Resolver, 26 | TypeChecker, 27 | Exp.Abs, 28 | Exp.ErrM, 29 | Exp.Layout, 30 | Exp.Lex, 31 | Exp.Par, 32 | Exp.Print, 33 | Exp.Skel 34 | other-extensions: 35 | TypeSynonymInstances, 36 | FlexibleInstances, 37 | GeneralizedNewtypeDeriving, 38 | TupleSections, 39 | CPP, 40 | MagicHash 41 | build-depends: 42 | base >=4.6 && <5, 43 | containers >=0.5 && <0.7, 44 | pretty >=1.1 && <1.2, 45 | QuickCheck >=2.6 && <2.15, 46 | mtl >=2.2 && <2.3, 47 | time >=1.4 && <1.13, 48 | directory >=1.2 && <1.4, 49 | filepath >=1.4 && <1.5, 50 | haskeline >=0.7 && <0.9, 51 | array >=0.4 && <0.6, 52 | -- Build tool 53 | BNFC >=2.8.1 && <3.0 54 | -- hs-source-dirs: 55 | build-tools: alex, happy, bnfc 56 | default-language: Haskell2010 57 | -------------------------------------------------------------------------------- /cubicaltt.el: -------------------------------------------------------------------------------- 1 | ;;; cubicaltt.el --- Mode for cubical type theory -*- lexical-binding: t -*- 2 | ;; URL: https://github.com/mortberg/cubicaltt 3 | ;; Package-version: 1.0 4 | ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5")) 5 | ;; Keywords: languages 6 | 7 | ;; This file is not part of GNU Emacs. 8 | 9 | ;; Copyright (c) 2015 Cyril Cohen, Thierry Coquand, Simon Huber, Anders Mörtberg 10 | 11 | ;; Permission is hereby granted, free of charge, to any person obtaining 12 | ;; a copy of this software and associated documentation files (the 13 | ;; "Software"), to deal in the Software without restriction, including 14 | ;; without limitation the rights to use, copy, modify, merge, publish, 15 | ;; distribute, sublicense, and/or sell copies of the Software, and to 16 | ;; permit persons to whom the Software is furnished to do so, subject to 17 | ;; the following conditions: 18 | 19 | ;; The above copyright notice and this permission notice shall be included 20 | ;; in all copies or substantial portions of the Software. 21 | 22 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 23 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 24 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 25 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 26 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 27 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 28 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 29 | 30 | ;;; Commentary: 31 | ;; This package provides a major mode for editing proofs or programs 32 | ;; in cubical, an implementation of cubical type theory. 33 | 34 | 35 | ;;; Code: 36 | 37 | (require 'comint) 38 | (require 'cl-lib) 39 | 40 | ;;;; Customization options 41 | 42 | (defgroup cubicaltt nil "Options for cubicaltt-mode for cubical type theory" 43 | :group 'languages 44 | :prefix 'cubicaltt- 45 | :tag "Cubical type theory") 46 | 47 | (defcustom cubicaltt-command "cubical" 48 | "The command to be run for cubical." 49 | :group 'cubicaltt 50 | :type 'string 51 | :tag "Command for cubical" 52 | :options '("cubical" "cabal exec cubical")) 53 | 54 | ;;;; Syntax 55 | 56 | (defvar cubicaltt-keywords 57 | '("hdata" "data" "import" "mutual" "let" "in" "split" 58 | "with" "module" "where" "U" "opaque" "transparent" "transparent_all") 59 | "Keywords for cubical.") 60 | 61 | (defvar cubicaltt-operations 62 | '("PathP" "comp" "transport" "fill" "Glue" "glue" "unglue" "Id" "idC" "idJ") 63 | "Operations for cubical.") 64 | 65 | (defvar cubicaltt-special 66 | '("undefined") 67 | "Special operators for cubical.") 68 | 69 | (defvar cubicaltt-keywords-regexp 70 | (regexp-opt cubicaltt-keywords 'words) 71 | "Regexp that recognizes keywords for cubical.") 72 | 73 | (defvar cubicaltt-operations-regexp 74 | (regexp-opt cubicaltt-operations 'words) 75 | "Regexp that recognizes operations for cubical.") 76 | 77 | (defvar cubicaltt-operators-regexp 78 | (regexp-opt '(":" "->" "=" "|" "\\" "*" "_" "<" ">" "\\/" "/\\" "-" "@") t) 79 | "Regexp that recognizes operators for cubical.") 80 | 81 | (defvar cubicaltt-special-regexp 82 | (regexp-opt cubicaltt-special 'words) 83 | "Regexp that recognizes special operators for cubical.") 84 | 85 | (defvar cubicaltt-def-regexp "^[[:word:]']+" 86 | "Regexp that recognizes the beginning of a cubical definition.") 87 | 88 | (defvar cubicaltt-font-lock-keywords 89 | `((,cubicaltt-keywords-regexp . font-lock-keyword-face) 90 | (,cubicaltt-operations-regexp . font-lock-builtin-face) 91 | (,cubicaltt-operators-regexp . font-lock-variable-name-face) 92 | (,cubicaltt-special-regexp . font-lock-warning-face) 93 | (,cubicaltt-def-regexp . font-lock-function-name-face)) 94 | "Font-lock information, assigning each class of keyword a face.") 95 | 96 | (defvar cubicaltt-syntax-table 97 | (let ((st (make-syntax-table))) 98 | (modify-syntax-entry ?\{ "(}1nb" st) 99 | (modify-syntax-entry ?\} "){4nb" st) 100 | (modify-syntax-entry ?- "_ 123" st) 101 | (modify-syntax-entry ?\n ">" st) 102 | (modify-syntax-entry ?\\ "." st) 103 | st) 104 | "The syntax table for cubical, with Haskell-style comments.") 105 | 106 | 107 | ;;;; The interactive toplevel 108 | 109 | (defvar cubicaltt-cubical-process nil 110 | "The subprocess buffer for cubical.") 111 | 112 | (defvar cubicaltt-loaded-buffer nil 113 | "The currently-loaded buffer for cubical. 114 | 115 | If no buffer is loaded, then this variable is nil.") 116 | 117 | (defun cubicaltt-ensure-process () 118 | "Ensure that a process is running for cubical and return the process buffer." 119 | (if (and cubicaltt-cubical-process (get-buffer-process cubicaltt-cubical-process)) 120 | cubicaltt-cubical-process 121 | (let ((process (make-comint "cubical" cubicaltt-command))) 122 | (setq cubicaltt-cubical-process process) 123 | (save-current-buffer 124 | (set-buffer process) 125 | (set-syntax-table cubicaltt-syntax-table)) 126 | process))) 127 | 128 | (defun cubicaltt-load () 129 | "Start cubical if it is not running, and get the current buffer loaded." 130 | (interactive) 131 | (let ((file (buffer-file-name))) 132 | (unless file 133 | (error "The current buffer is not associated with a file")) 134 | (let ((cubical-proc (cubicaltt-ensure-process)) 135 | (dir (file-name-directory file)) 136 | (f (file-name-nondirectory file))) 137 | (save-buffer) 138 | ;; Get in the right working directory. No space-escaping is 139 | ;; necessary for cubical, which in fact expects filenames to be 140 | ;; written without quotes or space-escaping. 141 | (comint-send-string cubical-proc (concat ":cd " dir "\n")) 142 | ;; Load the file 143 | (comint-send-string cubical-proc (concat ":l " f "\n")) 144 | ;; Show the buffer 145 | (pop-to-buffer cubical-proc '(display-buffer-use-some-window (inhibit-same-window . t)))))) 146 | 147 | ;;;; Completion support 148 | 149 | (defvar cubicaltt--completion-regexp 150 | "^\\(?1:[[:word:]']+\\) [:(]\\|^data \\(?1:[[:word:]']+\\)\\|=\\s-*\\(?1:[[:word:]']\\)\\||\\s-*\\(?1:[[:word:]']\\)" 151 | "Regexp for finding names to complete. 152 | 153 | This regexp matches the following kinds of strings: 154 | 155 | : 156 | ( 157 | data 158 | = 159 | | 160 | 161 | It is overly liberal, but it is better to have too many 162 | suggestions for completion rather than too few.") 163 | 164 | (defun cubicaltt-defined-names () 165 | "Find all names defined in this buffer." 166 | (save-excursion 167 | (let (names) 168 | (goto-char (point-min)) 169 | (while (re-search-forward cubicaltt--completion-regexp nil t) 170 | ;; Do not save if inside comment 171 | (unless (nth 4 (syntax-ppss)) 172 | (push (match-string-no-properties 1) names))) 173 | names))) 174 | 175 | (defun cubicaltt-completion-at-point () 176 | "Attempt to perform completion for cubical's keywords and the definitions in this file." 177 | (when (looking-back "\\w+" nil t) 178 | (let* ((match (match-string-no-properties 0)) 179 | (start-pos (match-beginning 0)) 180 | (end-pos (match-end 0)) 181 | (candidates (cl-remove-if-not 182 | (apply-partially #'string-prefix-p match) 183 | (append cubicaltt-keywords 184 | cubicaltt-special 185 | (cubicaltt-defined-names))))) 186 | (if (null candidates) 187 | nil 188 | (list start-pos end-pos candidates))))) 189 | 190 | ;;;; The mode itself 191 | 192 | ;;;###autoload 193 | (define-derived-mode cubicaltt-mode prog-mode 194 | "ctt" 195 | "Major mode for editing cubical type theory files." 196 | 197 | :syntax-table cubicaltt-syntax-table 198 | 199 | ;; Make comment-dwim do the right thing for Cubical 200 | (set (make-local-variable 'comment-start) "--") 201 | (set (make-local-variable 'comment-end) "") 202 | 203 | ;; Code for syntax highlighting 204 | (setq font-lock-defaults '(cubicaltt-font-lock-keywords)) 205 | 206 | ;; Bind mode-specific commands to keys 207 | (define-key cubicaltt-mode-map (kbd "C-c C-l") 'cubicaltt-load) 208 | 209 | ;; Install the completion handler 210 | (set (make-local-variable 'completion-at-point-functions) 211 | '(cubicaltt-completion-at-point)) 212 | 213 | ;; Setup imenu, to allow tools such as imenu and Helm to jump 214 | ;; directly to names in the current buffer. 215 | (set (make-local-variable 'imenu-generic-expression) 216 | '(("Definitions" "^\\(?1:[[:word:]']+\\) *[:(]" 1) 217 | ("Datatypes" "^\\s-*data\\s-+\\(?1:[[:word:]']+\\)" 1))) 218 | 219 | ;; Clear memory 220 | (setq cubicaltt-keywords-regexp nil) 221 | (setq cubicaltt-operators-regexp nil) 222 | (setq cubicaltt-special-regexp nil)) 223 | 224 | ;;;###autoload 225 | (add-to-list 'auto-mode-alist '("\\.ctt\\'" . cubicaltt-mode)) 226 | 227 | (provide 'cubicaltt) 228 | ;;; cubicaltt.el ends here 229 | -------------------------------------------------------------------------------- /cubicaltt.vim: -------------------------------------------------------------------------------- 1 | " Vim syntax file 2 | " Language: cubicaltt 3 | " Author: Carlo Angiuli 4 | " Last Change: 2017 November 6 5 | " 6 | " For https://github.com/mortberg/cubicaltt 7 | " 8 | " Move this file to ~/.vim/syntax/ and add the following line to your .vimrc: 9 | " au BufNewFile,BufRead *.ctt setf cubicaltt 10 | 11 | if exists("b:current_syntax") 12 | finish 13 | endif 14 | 15 | syn keyword cttKeyword hdata data import mutual let in split with module where 16 | syn keyword cttKeyword opaque transparent[] transparent_all 17 | syn keyword cttOperator U PathP comp transport fill Glue glue unglue Id idC idJ 18 | syn match cttOperator '[:=|*_<>\-@]\|->\|\\\|\\/\|/\\' 19 | syn keyword cttUndef undefined 20 | 21 | syn region cttComment start="--" end="$" 22 | syn region cttComment start="{-" end="-}" 23 | 24 | hi def link cttKeyword Structure 25 | hi def link cttOperator Identifier 26 | hi def link cttUndef Todo 27 | hi def link cttComment Comment 28 | 29 | let b:current_syntax = "cubicaltt" 30 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | CTTFILES := $(shell ls *ctt) 2 | 3 | ETAGSOPTS := \ 4 | --language=none \ 5 | --regex='/^\([[:alnum:]]+\) *:/\1/' \ 6 | --regex='/^data +\([[:alnum:]]+\) +=/\1/' \ 7 | --regex='/^module +\([[:alnum:]]+\) +where/\1/' 8 | 9 | TAGS: Makefile $(CTTFILES); etags $(ETAGSOPTS) $(CTTFILES) 10 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | Cubical Type Theory: examples 2 | ============================= 3 | 4 | This folder contains a lot of examples implemented using 5 | cubicaltt. The files contain: 6 | 7 | * **algstruct.ctt** - Defines some standard algebraic structures and 8 | properties. 9 | 10 | * **binnat.ctt** - Binary natural numbers and isomorphism to unary 11 | numbers. Example of data and program refinement by 12 | doing a proof for unary numbers by computation with 13 | binary numbers. 14 | 15 | * **bool.ctt** - Booleans. Proof that bool = bool by negation and 16 | various other simple examples. 17 | 18 | * **category.ctt** - Categories. Structure identity 19 | principle. Pullbacks. 20 | 21 | * **circle.ctt** - The circle as a HIT. Computation of winding 22 | numbers. 23 | 24 | * **collection.ctt** - This file proves that the collection of all 25 | sets is a groupoid. 26 | 27 | * **csystem.ctt** - Definition of C-systems and universe 28 | categories. Construction of a C-system from a 29 | universe category. 30 | 31 | * **demo.ctt** - Demo of the system. 32 | 33 | * **discor.ctt** - or A B is discrete if A and B are. 34 | 35 | * **equiv.ctt** - Definition of equivalences and various results on 36 | these, including "isoToEquiv". 37 | 38 | * **grothendieck.ctt** - This file contains a constuction of the Grothendieck 39 | group and a proof of its universal property. 40 | 41 | * **groupoidTrunc.ctt** - The groupoid truncation as a HIT. 42 | 43 | * **hedberg.ctt** - Hedberg's lemma: a type with decidable equality is 44 | a set. 45 | 46 | * **helix.ctt** - The loop space of the circle is equal to Z. 47 | 48 | * **hnat.ctt** - Non-standard natural numbers as a HIT without any 49 | path constructor. 50 | 51 | * **hz.ctt** - Z defined as a (impredicative set) quotient of 52 | `nat * nat` 53 | 54 | * **idtypes.ctt** - Identity types (variation of Path types with 55 | definitional equality for J). Including a proof 56 | univalence expressed only using Id. 57 | 58 | * **injective.ctt** - Two definitions of injectivity and proof that 59 | they are equal. 60 | 61 | * **int.ctt** - The integers as nat + nat with proof that suc is an 62 | isomorphism giving a non-trivial path from Z to Z. 63 | 64 | * **integer.ctt** - The integers as a HIT (identifying +0 with -0). 65 | Proof that this representation is isomorphic to 66 | the one in int.ctt 67 | 68 | * **interval.ctt** - The interval as a HIT. Proof of function 69 | extensionality from it. 70 | 71 | * **list.ctt** - Lists. Various basic lemmas in "cubical style". 72 | 73 | * **nat.ctt** - Natural numbers. Various basic lemmas in "cubical 74 | style". 75 | 76 | * **ordinal.ctt** - Ordinals. 77 | 78 | * **opposite.ctt** - Opposite category and a proof that C^op^op = C 79 | definitionally. 80 | 81 | * **pi.ctt** - Characterization of equality in pi types. 82 | 83 | * **prelude.ctt** - The prelude. Definition of Path types and basic 84 | operations on them (refl, mapOnPath, funExt...). 85 | Definition of prop, set and groupoid. Some basic 86 | data types (empty, unit, or, and). 87 | 88 | * **propTrunc.ctt** - Propositional truncation as a HIT. (WARNING: not 89 | working correctly) 90 | 91 | * **retract.ctt** - Definition of retract and section. 92 | 93 | * **setquot.ctt** - Formalization of impredicative set quotients á la 94 | Voevodsky. 95 | 96 | * **sigma.ctt** - Various results about sigma types. 97 | 98 | * **subset.ctt** - Two definitions of a subset and a proof that they 99 | are equal. 100 | 101 | * **summary.ctt** - Summary of where to find the results and examples 102 | from the cubical type theory paper. 103 | 104 | * **susp.ctt** - Suspension. Definition of the circle as the 105 | suspension of bool and a proof that this is equal to 106 | the standard HIT representation of the circle. 107 | 108 | * **torsor.ctt** - Torsors. Proof that S1 is equal to BZ, the 109 | classifying space of Z. 110 | 111 | * **torus.ctt** - Proof that Torus = S1 * S1. 112 | 113 | * **univalence.ctt** - Proofs of the univalence axiom. 114 | 115 | * **univprop.ctt** - Defines natural transformations, universal arrows, and 116 | adjunctions. Also contains a proof that a family of 117 | universal arrows gives rise to an adjunction. This is 118 | then used to prove that the Grothendieck homomorphism is 119 | left adjoint to the forgetful functor. 120 | -------------------------------------------------------------------------------- /examples/circle.ctt: -------------------------------------------------------------------------------- 1 | -- The circle as a HIT. 2 | module circle where 3 | 4 | import bool 5 | import int 6 | 7 | data S1 = base 8 | | loop [ (i=0) -> base 9 | , (i=1) -> base] 10 | 11 | loopS1 : U = Path S1 base base 12 | 13 | loop1 : loopS1 = loop{S1} @ i 14 | 15 | invLoop : loopS1 = inv S1 base base loop1 16 | 17 | moebius : S1 -> U = split 18 | base -> bool 19 | loop @ i -> negBoolEq @ i 20 | 21 | helix : S1 -> U = split 22 | base -> Z 23 | loop @ i -> sucPathZ @ i 24 | 25 | winding (p : loopS1) : Z = trans Z Z rem zeroZ 26 | where 27 | rem : Path U Z Z = helix (p @ i) 28 | 29 | compS1 : loopS1 -> loopS1 -> loopS1 = compPath S1 base base base 30 | 31 | -- All of these should be equal to "posZ (suc zero)": 32 | loop2 : loopS1 = compS1 loop1 loop1 33 | loop2' : loopS1 = compPath' S1 base base base loop1 loop1 34 | loop2'' : loopS1 = compPath'' S1 base base loop1 base loop1 35 | 36 | -- More examples: 37 | loopZ1 : Z = winding loop1 38 | loopZ2 : Z = winding (compS1 loop1 loop1) 39 | loopZ3 : Z = winding (compS1 loop1 (compS1 loop1 loop1)) 40 | loopZN1 : Z = winding invLoop 41 | loopZ0 : Z = winding (compS1 loop1 invLoop) 42 | loopZ5 : Z = winding (compS1 loop1 (compS1 loop1 (compS1 loop1 (compS1 loop1 loop1)))) 43 | 44 | mLoop : (x : S1) -> Path S1 x x = split 45 | base -> loop1 46 | loop @ i -> constSquare S1 base loop1 @ i 47 | 48 | mult (x : S1) : S1 -> S1 = split 49 | base -> x 50 | loop @ i -> mLoop x @ i 51 | 52 | square (x : S1) : S1 = mult x x 53 | 54 | doubleLoop (l : loopS1) : loopS1 = square (l @ i) 55 | tripleLoop (l : loopS1) : loopS1 = mult (l @ i) (square (l @ i)) 56 | 57 | loopZ4 : Z = winding (doubleLoop (compS1 loop1 loop1)) 58 | loopZ8 : Z = winding (doubleLoop (doubleLoop (compS1 loop1 loop1))) 59 | 60 | triv : loopS1 = base 61 | 62 | -- A nice example of a homotopy on the circle. The path going halfway 63 | -- around the circle and then back is contractible: 64 | hmtpy : Path loopS1 ( base) ( loop{S1} @ (i /\ -i)) = 65 | loop{S1} @ j /\ i /\ -i 66 | 67 | circleelim (X : U) (x : X) (p : Path X x x) : S1 -> X = split 68 | base -> x 69 | loop @ i -> p @ i 70 | 71 | apcircleelim (A B : U) (x : A) (p : Path A x x) (f : A -> B) : 72 | (z : S1) -> Path B (f (circleelim A x p z)) 73 | (circleelim B (f x) ( f (p @ i)) z) = split 74 | base -> <_> f x 75 | loop @ i -> <_> f (p @ i) 76 | 77 | 78 | -- a special case, Lemmas 6.2.5-6.2.9 in the book 79 | 80 | aLoop (A:U) : U = (a:A) * Path A a a 81 | 82 | phi (A:U) (al : aLoop A) : S1 -> A = split 83 | base -> al.1 84 | loop @ i -> (al.2)@ i 85 | 86 | psi (A:U) (f:S1 -> A) : aLoop A = (f base,f (loop1@i)) 87 | 88 | rem (A:U) (f : S1 -> A) : (u : S1) -> Path A (phi A (psi A f) u) (f u) = split 89 | base -> refl A (f base) 90 | loop @ i -> f (loop1@i) 91 | 92 | lem (A:U) (f : S1 -> A) : Path (S1 -> A) (phi A (psi A f)) f = 93 | \ (x:S1) -> (rem A f x) @ i 94 | 95 | thm (A:U) : Path U (aLoop A) (S1 -> A) = isoPath T0 T1 f g t s 96 | where T0 : U = aLoop A 97 | T1 : U = S1 -> A 98 | f : T0 -> T1 = phi A 99 | g : T1 -> T0 = psi A 100 | s (x:T0) : Path T0 (g (f x)) x = refl T0 x 101 | t : (y:T1) -> Path T1 (f (g y)) y = lem A 102 | 103 | -------------------------------------------------------------------------------- /examples/collection.ctt: -------------------------------------------------------------------------------- 1 | -- This file proves that the collection of all sets is a groupoid 2 | module collection where 3 | 4 | import univalence 5 | import sigma 6 | import pi 7 | 8 | setFun (A B : U) (sB : set B) : set (A -> B) = 9 | setPi A (\(x : A) -> B) (\(x : A) -> sB) 10 | 11 | eqEquivFst (A B : U) : (t u : equiv A B) -> 12 | Path U (Path (equiv A B) t u) (Path (A -> B) t.1 u.1) 13 | = lemSigProp (A -> B) (isEquiv A B) (propIsEquiv A B) 14 | 15 | -- groupoidFun (A B : U) (gB:groupoid B) : groupoid (A -> B) = 16 | -- groupoidPi A (\(x : A) -> B) (\(x : A) -> gB) 17 | 18 | -- lem5 (A B : U) (gB:groupoid B) (t u:equiv A B) : set (Path (equiv A B) t u) 19 | -- = substInv U set (Path (equiv A B) t u) (Path (A -> B) t.1 u.1) 20 | -- (eqEquivFst A B t u) (groupoidFun A B gB t.1 u.1) 21 | 22 | setPath (A B : U) (sB : set B) : set (Path U A B) = 23 | substInv U set (Path U A B) (equiv A B) (corrUniv A B) (rem A B sB) 24 | where 25 | rem (A B : U) (sB:set B) (t u:equiv A B) : prop (Path (equiv A B) t u) 26 | = substInv U prop (Path (equiv A B) t u) (Path (A -> B) t.1 u.1) 27 | (eqEquivFst A B t u) (setFun A B sB t.1 u.1) 28 | 29 | -- the collection of all sets is a groupoid 30 | groupoidSET : groupoid SET = \(A B : SET) -> 31 | let rem : set (Path U A.1 B.1) = setPath A.1 B.1 B.2 32 | rem1 : Path U (Path SET A B) (Path U A.1 B.1) = 33 | lemSigProp U set setIsProp A B 34 | in substInv U set (Path SET A B) (Path U A.1 B.1) rem1 rem 35 | 36 | -------------------------------------------------------------------------------- /examples/control.ctt: -------------------------------------------------------------------------------- 1 | module control where 2 | 3 | import prelude 4 | 5 | -- Recursion/Corecursion 6 | 7 | data fix (F: U -> U) = Fix (point: F (fix F)) 8 | 9 | out_ (F: U -> U): fix F -> F (fix F) = split Fix f -> f 10 | in_ (F: U -> U): F (fix F) -> fix F = \(x: F (fix F)) -> Fix x 11 | 12 | data freeF (F: U -> U) (A B: U) = ReturnF (a: A) | BindF (f: F B) 13 | data cofreeF (F: U -> U) (A B: U) = CoBindF (a: A) (f: F B) 14 | data free (F: U -> U) (A: U) = Free (_: fix (freeF F A)) 15 | data cofree (F: U -> U) (A: U) = CoFree (_: fix (cofreeF F A)) 16 | 17 | unfree (A: U) (F: U -> U): free F A -> fix (freeF F A) = split Free a -> a 18 | uncofree (A: U) (F: U -> U): cofree F A -> fix (cofreeF F A) = split CoFree a -> a 19 | 20 | -- Control Type-Classes 21 | 22 | pure (A: U) (F: U -> U): U 23 | = (return: A -> F A) 24 | * Unit 25 | 26 | o (A B C: U) (f: B -> C) (g: A -> B): A -> C = \(x:A) -> f (g x) 27 | 28 | functor_ (A B: U) (F: U -> U): U 29 | = (fmap: (A -> B) -> F A -> F B) * Unit 30 | 31 | functor (F: U -> U): U 32 | = (fmap: (A B: U) -> (A -> B) -> F A -> F B) 33 | * (id: (A: U) -> (x: F A) -> Path (F A) (fmap A A (idfun A) x) x) 34 | * (compose: (A B C: U) (f: B -> C) (g: A -> B) (x: F A) -> 35 | Path (F C) (fmap A C (o A B C f g) x) 36 | ((o (F A) (F B) (F C) (fmap B C f) (fmap A B g)) x)) * Unit 37 | 38 | applicative (A B: U) (F: U -> U): U 39 | = (pure_: pure A F) 40 | * (functor_: functor_ A B F) 41 | * (ap: F (A -> B) -> F A -> F B) 42 | * Unit 43 | 44 | monad (A B: U) (F: U -> U): U 45 | = (pure_: pure A F) 46 | * (functor_: functor F) 47 | * (join: F (F A) -> F B) 48 | * Unit 49 | 50 | comonad (A B: U) (F: U -> U): U 51 | = (pure_: pure A F) 52 | * (functor_: functor F) 53 | * (extract: F A -> A) 54 | * (duplicate: F A -> F (F A)) 55 | * (extend: (F A -> B) -> F A -> F B) 56 | * Unit 57 | -------------------------------------------------------------------------------- /examples/discor.ctt: -------------------------------------------------------------------------------- 1 | -- or A B is discrete if A and B are 2 | module discor where 3 | 4 | import prelude 5 | 6 | inlNotinr (A B:U) (a:A) (b:B) (h: Path (or A B) (inl a) (inr b)) : N0 = 7 | subst (or A B) T (inl a) (inr b) h tt 8 | where 9 | T : or A B -> U = split 10 | inl _ -> Unit 11 | inr _ -> N0 12 | 13 | inrNotinl (A B:U) (a:A) (b:B) (h : Path (or A B) (inr b) (inl a)) : N0 = 14 | subst (or A B) T (inr b) (inl a) h tt 15 | where 16 | T : or A B -> U = split 17 | inl _ -> N0 18 | inr _ -> Unit 19 | 20 | injInl (A B :U) (x0 x1:A) (h : Path (or A B) (inl x0) (inl x1)) : Path A x0 x1 = 21 | subst (or A B) T (inl x0) (inl x1) h (refl A x0) 22 | where 23 | T : or A B -> U = split 24 | inl x -> Path A x0 x 25 | inr _ -> N0 26 | 27 | injInr (A B :U) (x0 x1:B) (h: Path (or A B) (inr x0) (inr x1)) : Path B x0 x1 = 28 | subst (or A B) T (inr x0) (inr x1) h (refl B x0) 29 | where 30 | T : or A B -> U = split 31 | inl _ -> N0 32 | inr x -> Path B x0 x 33 | 34 | -- If A and B are discrete then "A or B" is discrete 35 | orDisc (A B : U) (dA : discrete A) (dB : discrete B) : 36 | (z z1 : or A B) -> dec (Path (or A B) z z1) = split 37 | inl a -> rem1 38 | where rem1 : (z1:or A B) -> dec (Path (or A B) (inl a) z1) = split 39 | inl a1 -> rem (dA a a1) 40 | where rem : dec (Path A a a1) -> dec (Path (or A B) (inl a) (inl a1)) = split 41 | inl p -> inl ( inl (p @ i)) 42 | inr h -> inr (\ (p:Path (or A B) (inl a) (inl a1)) -> h (injInl A B a a1 p)) 43 | inr b -> inr (inlNotinr A B a b) 44 | inr b -> rem1 45 | where rem1 : (z1:or A B) -> dec (Path (or A B) (inr b) z1) = split 46 | inl a -> inr (inrNotinl A B a b) 47 | inr b1 -> rem (dB b b1) 48 | where rem : dec (Path B b b1) -> dec (Path (or A B) (inr b) (inr b1)) = split 49 | inl p -> inl ( inr (p @ i)) 50 | inr h -> inr (\ (p:Path (or A B) (inr b) (inr b1)) -> h (injInr A B b b1 p)) 51 | 52 | -------------------------------------------------------------------------------- /examples/groupoidTrunc.ctt: -------------------------------------------------------------------------------- 1 | -- The groupoid truncation as a HIT 2 | module groupoidTrunc where 3 | 4 | import equiv 5 | import sigma 6 | 7 | data gTrunc (A : U) 8 | = inc (a : A) 9 | | squashC (a b : gTrunc A) (p q : Path (gTrunc A) a b) 10 | (r s: Path (Path (gTrunc A) a b) p q) 11 | [ (i=0) -> r @ j @ k 12 | , (i=1) -> s @ j @ k 13 | , (j=0) -> p @ k 14 | , (j=1) -> q @ k 15 | , (k=0) -> a 16 | , (k=1) -> b] 17 | 18 | gTr (A:U) (a b : gTrunc A) (p q : Path (gTrunc A) a b) 19 | (r s: Path (Path (gTrunc A) a b) p q) : 20 | Path (Path (Path (gTrunc A) a b) p q) r s = 21 | squashC{gTrunc A} a b p q r s@ i @ j @k 22 | 23 | gTruncRec (A B : U) (bG : groupoid B) (f : A -> B) : gTrunc A -> B = split 24 | inc a -> f a 25 | squashC a b p q r s @ i j k -> bG (gTruncRec A B bG f a) 26 | (gTruncRec A B bG f b) 27 | ( gTruncRec A B bG f (p @ m)) 28 | ( gTruncRec A B bG f (q @ m)) 29 | ( gTruncRec A B bG f (r @ m @ n)) 30 | ( gTruncRec A B bG f (s @ m @ n)) @ i @ j @ k 31 | 32 | lem1 (A:U) (P:A -> U) (gP:(x:A) -> groupoid (P x)) (a :A) : 33 | (s:Path (Path A a a) (refl A a) (refl A a)) 34 | (t:Path (Path (Path A a a) (refl A a) (refl A a)) (refl (Path A a a) (refl A a)) s) 35 | (a1 b1:P a) (p1 q1: Path (P a) a1 b1) 36 | (r1 : Path (Path (P a) a1 b1) p1 q1) (s1 : PathP (PathP (P (s@i@j)) a1 b1) p1 q1) -> 37 | PathP (PathP (PathP (P (t@i@j@k)) a1 b1) p1 q1) r1 s1 = 38 | J (Path (Path A a a) (refl A a) (refl A a)) (refl (Path A a a) (refl A a)) 39 | (\ (s:Path (Path A a a) (refl A a) (refl A a)) 40 | (t:Path (Path (Path A a a) (refl A a) (refl A a)) (refl (Path A a a) (refl A a)) s) -> 41 | (a1 b1 :P a) (p1 q1: Path (P a) a1 b1) 42 | (r1 : Path (Path (P a) a1 b1) p1 q1) (s1 : PathP (PathP (P (s@i@j)) a1 b1) p1 q1) -> 43 | PathP (PathP (PathP (P (t@i@j@k)) a1 b1) p1 q1) r1 s1) (gP a) 44 | 45 | lem (A:U) (P:A -> U) (gP:(x:A) -> groupoid (P x)) 46 | (a :A) : (b:A) (p q:Path A a b) (r s:Path (Path A a b) p q) (t:Path (Path (Path A a b) p q) r s) 47 | (a1:P a) (b1:P b) (p1: PathP (P (p@i)) a1 b1) (q1: PathP (P (q@i)) a1 b1) 48 | (r1 : PathP (PathP (P (r@i@j)) a1 b1) p1 q1) (s1 : PathP (PathP (P (s@i@j)) a1 b1) p1 q1) -> 49 | PathP (PathP (PathP (P (t@i@j@k)) a1 b1) p1 q1) r1 s1 = 50 | J A a (\ (b:A) (p :Path A a b) -> (q:Path A a b) (r s:Path (Path A a b) p q) (t:Path (Path (Path A a b) p q) r s) 51 | (a1:P a) (b1:P b) (p1: PathP (P (p@i)) a1 b1) (q1: PathP (P (q@i)) a1 b1) 52 | (r1 : PathP (PathP (P (r@i@j)) a1 b1) p1 q1) (s1 : PathP (PathP (P (s@i@j)) a1 b1) p1 q1) -> 53 | PathP (PathP (PathP (P (t@i@j@k)) a1 b1) p1 q1) r1 s1) rem 54 | where 55 | rem : (q:Path A a a) (r s:Path (Path A a a) (refl A a) q) (t:Path (Path (Path A a a) (refl A a) q) r s) 56 | (a1:P a) (b1:P a) (p1: Path (P a) a1 b1) (q1: PathP (P (q@i)) a1 b1) 57 | (r1 : PathP (PathP (P (r@i@j)) a1 b1) p1 q1) (s1 : PathP (PathP (P (s@i@j)) a1 b1) p1 q1) -> 58 | PathP (PathP (PathP (P (t@i@j@k)) a1 b1) p1 q1) r1 s1 = 59 | J (Path A a a) (refl A a) (\ (q:Path A a a) (r:Path (Path A a a) (refl A a) q) -> 60 | (s:Path (Path A a a) (refl A a) q) (t:Path (Path (Path A a a) (refl A a) q) r s) 61 | (a1:P a) (b1:P a) (p1: Path (P a) a1 b1) (q1: PathP (P (q@i)) a1 b1) 62 | (r1 : PathP (PathP (P (r@i@j)) a1 b1) p1 q1) (s1 : PathP (PathP (P (s@i@j)) a1 b1) p1 q1) -> 63 | PathP (PathP (PathP (P (t@i@j@k)) a1 b1) p1 q1) r1 s1) (lem1 A P gP a) 64 | 65 | T:U = (A:U) (P:A -> U) (gP:(x:A) -> groupoid (P x)) 66 | (a b:A) (p q:Path A a b) (r s:Path (Path A a b) p q) (t:Path (Path (Path A a b) p q) r s) 67 | (a1:P a) (b1:P b) (p1: PathP (P (p@i)) a1 b1) (q1: PathP (P (q@i)) a1 b1) 68 | (r1 : PathP (PathP (P (r@i@j)) a1 b1) p1 q1) (s1 : PathP (PathP (P (s@i@j)) a1 b1) p1 q1) -> 69 | PathP (PathP (PathP (P (t@i@j@k)) a1 b1) p1 q1) r1 s1 70 | 71 | gTruncElim1 (lem:T) (A : U) 72 | (B : (gTrunc A) -> U) 73 | (bG : (z:gTrunc A) -> groupoid (B z)) 74 | (f : (x:A) -> B (inc x)) : (z:gTrunc A) -> B z = split 75 | inc a -> f a 76 | squashC a b p q r s @ i j k -> lem (gTrunc A) B bG a b p q r s 77 | (gTr A a b p q r s) 78 | (gTruncElim1 lem A B bG f a) 79 | (gTruncElim1 lem A B bG f b) 80 | ( gTruncElim1 lem A B bG f (p @ m)) 81 | ( gTruncElim1 lem A B bG f (q @ m)) 82 | ( gTruncElim1 lem A B bG f (r @ m @ n)) 83 | ( gTruncElim1 lem A B bG f (s @ m @ n)) @ i @ j @ k 84 | 85 | gTruncElim : (A : U) 86 | (B : (gTrunc A) -> U) 87 | (bG : (z:gTrunc A) -> groupoid (B z)) 88 | (f : (x:A) -> B (inc x)) (z:gTrunc A) -> B z = gTruncElim1 lem 89 | 90 | univG (A B:U) (bG:groupoid B) : Path U ((gTrunc A) -> B) (A -> B) = 91 | isoPath (gTrunc A -> B) (A -> B) F G s t 92 | where 93 | F (h : gTrunc A -> B) (a: A) : B = h (inc a) 94 | G : (A -> B) -> gTrunc A -> B = gTruncRec A B bG 95 | 96 | s (h : A -> B) : Path (A -> B) (F (G h)) h = \ (x:A) -> h x 97 | 98 | t (h : gTrunc A -> B) : Path (gTrunc A -> B) (G (F h)) h = \ (z:gTrunc A) -> rem z @ i 99 | where 100 | P (z:gTrunc A) : U = Path B (G (F h) z) (h z) 101 | 102 | tP (z : gTrunc A) : groupoid (P z) = setGroupoid (P z) (bG (G (F h) z) (h z)) 103 | 104 | rem : (z:gTrunc A) -> P z = gTruncElim A P tP (\ (a:A) -> refl B (h (inc a))) 105 | 106 | -------------------------------------------------------------------------------- /examples/hedberg.ctt: -------------------------------------------------------------------------------- 1 | -- Hedbergs lemma: a type with decidable equality is a set 2 | module hedberg where 3 | 4 | import prelude 5 | 6 | hedbergLemma (A: U) (a b:A) (f : (x : A) -> Path A a x -> Path A a x) (p : Path A a b) : 7 | Square A a a a b (refl A a) p (f a (refl A a)) (f b p) = 8 | comp ( Square A a a a (p @ i) (<_> a) ( p @ i /\ j) 9 | (f a (<_> a)) (f (p @ i) ( p @ i /\ j))) 10 | ( f a (<_> a)) [] 11 | 12 | hedbergStable (A : U) (a b : A) (h : (x : A) -> stable (Path A a x)) 13 | (p q : Path A a b) : Path (Path A a b) p q = 14 | comp (<_> A) a [ (j = 0) -> rem2 @ i 15 | , (j = 1) -> rem3 @ i 16 | , (i = 0) -> r 17 | , (i = 1) -> rem4 @ j] 18 | where 19 | ra : Path A a a = <_> a 20 | rem1 (x : A) : exConst (Path A a x) = stableConst (Path A a x) (h x) 21 | f (x : A) : Path A a x -> Path A a x = (rem1 x).1 22 | fIsConst (x : A) : const (Path A a x) (f x) = (rem1 x).2 23 | rem4 : Square A a a b b ra (refl A b) (f b p) (f b q) = fIsConst b p q 24 | r : Path A a a = f a ra 25 | rem2 : Square A a a a b ra p r (f b p) = hedbergLemma A a b f p 26 | rem3 : Square A a a a b ra q r (f b q) = hedbergLemma A a b f q 27 | 28 | hedbergS (A:U) (h : (a x:A) -> stable (Path A a x)) : set A = 29 | \(a b : A) -> hedbergStable A a b (h a) 30 | 31 | hedberg (A : U) (h : discrete A) : set A = 32 | \(a b : A) -> hedbergStable A a b (\(b : A) -> decStable (Path A a b) (h a b)) 33 | 34 | 35 | 36 | 37 | -- Alternative version: 38 | 39 | -- hedbergLemma (A: U) (f : (a b : A) -> Path A a b -> Path A a b) (a :A) : 40 | -- (b : A) (p : Path A a b) -> 41 | -- Path (Path A a b) (compPath A a a b (f a a (refl A a)) p) (f a b p) = 42 | -- J A a (\ (b:A) (p:Path A a b) -> Path (Path A a b) (compPath A a a b (f a a (refl A a)) p) (f a b p)) 43 | -- (refl (Path A a a) (f a a (refl A a))) 44 | 45 | -- hedberg (A : U) (h : discrete A) : set A = \(a b : A) (p q : Path A a b) -> 46 | -- let rem1 (x y : A) : exConst (Path A x y) = decConst (Path A x y) (h x y) 47 | 48 | -- f (x y : A) : Path A x y -> Path A x y = (rem1 x y).1 49 | 50 | -- fIsConst (x y : A) : const (Path A x y) (f x y) = (rem1 x y).2 51 | 52 | -- r : Path A a a = f a a (refl A a) 53 | 54 | -- rem2 : Path (Path A a b) (compPath A a a b r p) (f a b p) = hedbergLemma A f a b p 55 | 56 | -- rem3 : Path (Path A a b) (compPath A a a b r q) (f a b q) = hedbergLemma A f a b q 57 | 58 | -- rem4 : Path (Path A a b) (f a b p) (f a b q) = fIsConst a b p q 59 | 60 | -- rem5 : Path (Path A a b) (compPath A a a b r p) (compPath A a a b r q) = 61 | -- compDown (Path A a b) (compPath A a a b r p) (f a b p) (compPath A a a b r q) 62 | -- (f a b q) rem2 rem3 rem4 63 | -- in lemSimpl A a a b r p q rem5 64 | -------------------------------------------------------------------------------- /examples/hnat.ctt: -------------------------------------------------------------------------------- 1 | -- Non-standard natural numbers as a HIT without any path constructor 2 | module hnat where 3 | 4 | import nat 5 | import equiv 6 | 7 | -- Non-standard nat: 8 | hdata hnat = nzero 9 | | nsuc (n : hnat) 10 | 11 | -- This reduces to "hComp (hnat) nzero []" 12 | test0 : hnat = comp (<_> hnat) nzero [] 13 | 14 | -- This reduces to "zero" 15 | test1 : nat = comp (<_> nat) zero [] 16 | 17 | test2 : Path hnat nzero (comp (<_> hnat) nzero []) = 18 | fill (<_> hnat) nzero [] 19 | 20 | toNat : hnat -> nat = split 21 | nzero -> zero 22 | nsuc n -> suc (toNat n) 23 | 24 | fromNat : nat -> hnat = split 25 | zero -> nzero 26 | suc n -> nsuc (fromNat n) 27 | 28 | toNatK : (n : hnat) -> Path hnat (fromNat (toNat n)) n = split 29 | nzero -> <_> nzero 30 | nsuc n -> nsuc (toNatK n @ i) 31 | 32 | fromNatK : (n : nat) -> Path nat (toNat (fromNat n)) n = split 33 | zero -> <_> zero 34 | suc n -> suc (fromNatK n @ i) 35 | 36 | hnatEqNat : Path U hnat nat = 37 | isoPath hnat nat toNat fromNat fromNatK toNatK 38 | 39 | -- This is zero 40 | test3 : nat = trans hnat nat hnatEqNat test0 41 | 42 | -- This is "hComp (hnat) nzero []" 43 | test4 : hnat = trans nat hnat ( hnatEqNat @ -i) zero 44 | 45 | -- This is "hComp (hnat) (hComp (hnat) nzero []) []" 46 | test5 : hnat = trans hnat hnat (compPath U hnat nat hnat hnatEqNat ( hnatEqNat @ -i)) nzero 47 | 48 | hnatSet : set hnat = subst U set nat hnat ( hnatEqNat @ -i) natSet 49 | 50 | -------------------------------------------------------------------------------- /examples/hz.ctt: -------------------------------------------------------------------------------- 1 | -- Z defined as a quotient of nat * nat by the relation: 2 | -- (x1,x2) ~ (y1,y2) := (x1 + y2 = x2 + y1) 3 | module hz where 4 | 5 | import nat 6 | import setquot 7 | 8 | -- shorthand for nat x nat 9 | nat2 : U = and nat nat 10 | 11 | natlemma (a b c d : nat) : Path nat (add (add a b) (add c d)) (add (add a d) (add c b)) = 12 | let rem : Path nat (add a (add b (add c d))) (add a (add d (add c b))) = 13 | add a (add_comm3 b c d @ i) 14 | in comp (<_> nat) (rem @ i) [ (i = 0) -> assocAdd a b (add c d) 15 | , (i = 1) -> assocAdd a d (add c b) ] 16 | 17 | rel : eqrel nat2 = (r,rem) 18 | where 19 | r : hrel nat2 = \(x y : nat2) -> 20 | (Path nat (add x.1 y.2) (add x.2 y.1),natSet (add x.1 y.2) (add x.2 y.1)) 21 | 22 | rem : iseqrel nat2 r = ((rem1,rem2),rem3) 23 | where 24 | rem1 : istrans nat2 r = 25 | \(x y z : nat2) 26 | (h1 : Path nat (add x.1 y.2) (add x.2 y.1)) 27 | (h2 : Path nat (add y.1 z.2) (add y.2 z.1)) -> 28 | let rem : Path nat (add (add x.1 y.2) (add y.1 z.2)) (add (add x.2 y.1) (add y.2 z.1)) = 29 | add (h1 @ i) (h2 @ i) 30 | 31 | rem1 : Path nat (add (add x.1 y.2) (add y.1 z.2)) (add (add x.1 z.2) (add y.1 y.2)) = 32 | natlemma x.1 y.2 y.1 z.2 33 | 34 | rem2 : Path nat (add (add x.2 y.1) (add y.2 z.1)) (add (add x.2 z.1) (add y.2 y.1)) = 35 | natlemma x.2 y.1 y.2 z.1 36 | rem3 : Path nat (add (add x.2 z.1) (add y.2 y.1)) (add (add x.2 z.1) (add y.1 y.2)) = 37 | add (add x.2 z.1) (add_comm y.2 y.1 @ i) 38 | rem4 : Path nat (add (add x.2 y.1) (add y.2 z.1)) (add (add x.2 z.1) (add y.1 y.2)) = 39 | comp (<_> nat) (add (add x.2 z.1) (add y.2 y.1)) [ (i = 0) -> rem2 @ -j 40 | , (i = 1) -> rem3 ] 41 | 42 | rem5 : Path nat (add (add x.1 z.2) (add y.1 y.2)) (add (add x.2 z.1) (add y.1 y.2)) = 43 | comp (<_> nat) (rem @ i) [ (i = 0) -> rem1, (i = 1) -> rem4 ] 44 | 45 | in natcancelr (add x.1 z.2) (add x.2 z.1) (add y.1 y.2) rem5 46 | rem2 : isrefl nat2 r = \(x : nat2) -> add_comm x.1 x.2 47 | rem3 : issymm nat2 r = \(x y : nat2) (h : Path nat (add x.1 y.2) (add x.2 y.1)) -> 48 | let rem : Path nat (add x.2 y.1) (add y.2 x.1) = 49 | comp (<_> nat) (add x.1 y.2) [ (i = 0) -> h 50 | , (i = 1) -> add_comm x.1 y.2 ] 51 | in comp (<_> nat) (add x.2 y.1) [ (i = 0) -> add_comm x.2 y.1 52 | , (i = 1) -> rem ] 53 | 54 | hz : U = setquot nat2 rel.1 55 | zeroz : hz = setquotpr nat2 rel (zero,zero) 56 | onez : hz = setquotpr nat2 rel (one,zero) 57 | 58 | discretehz : discrete hz = isdiscretesetquot nat2 rel rem 59 | where 60 | rem (x y : nat2) : isdecprop (rel.1 x y).1 = 61 | (natSet (add x.1 y.2) (add x.2 y.1),natDec (add x.1 y.2) (add x.2 y.1)) 62 | 63 | -- Use the decision procedure to compute if "0 = 1": 64 | test01 : bool = discretetobool hz discretehz zeroz onez 65 | 66 | -- Use the decision procedure to compute if "1 = 1": 67 | test11 : bool = discretetobool hz discretehz onez onez -------------------------------------------------------------------------------- /examples/injective.ctt: -------------------------------------------------------------------------------- 1 | -- Two definitions of injectivity and proof that they can be 2 | -- identified 3 | module injective where 4 | 5 | import equiv 6 | 7 | -- First definition of injectivity, informally: if two elements f a0, f a1 are 8 | -- equal in B, then a0, a1 must be equal in A. 9 | inj0 (A B : U) (f : A -> B) (sA : set A) (sB : set B) : U 10 | = (a0 a1 : A) -> Path B (f a0) (f a1) -> Path A a0 a1 11 | 12 | -- Second definition of injectivity, informally: for any b in B, there are 13 | -- only one elment a in A such that f a is equal to b. 14 | inj1 (A B : U) (f : A -> B) (sA : set A) (sB : set B) : U 15 | = (b : B) -> prop ((a : A) * Path B (f a) b) 16 | 17 | -- A map from the first to the second definition. 18 | inj01 (A B : U) (f : A -> B) (sA : set A) (sB : set B) : inj0 A B f sA sB -> 19 | inj1 A B f sA sB 20 | = \ (i0 : inj0 A B f sA sB) (b : B) (c d : (a : A) * Path B (f a) b) -> let 21 | F (a : A) : U 22 | = Path B (f a) b 23 | pF (a : A) : prop (F a) 24 | = sB (f a) b 25 | p : Path B (f c.1) (f d.1) 26 | = comp ( B) (c.2 @ i) [ (i = 0) -> f c.1 27 | , (i = 1) -> d.2 @ -j ] 28 | q : Path A c.1 d.1 29 | = i0 c.1 d.1 p 30 | in 31 | lemSig A F pF c d q 32 | 33 | -- A map from the second to the first definition. 34 | inj10 (A B : U) (f : A -> B) (sA : set A) (sB : set B) : inj1 A B f sA sB -> 35 | inj0 A B f sA sB 36 | = \ (i1 : inj1 A B f sA sB) (a0 a1 : A) (p : Path B (f a0) (f a1)) -> let 37 | c : (a : A) * Path B (f a) (f a1) 38 | = (a0, p) 39 | d : (a : A) * Path B (f a) (f a1) 40 | = (a1, f a1) 41 | q : Path ((a : A) * Path B (f a) (f a1)) c d 42 | = i1 (f a1) c d 43 | fst : ((a : A) * Path B (f a) (f a1)) -> A 44 | = \ (x : (a : A) * Path B (f a) (f a1)) -> x.1 45 | in 46 | fst (q @ i) 47 | 48 | -- A proof that the first definition of injectivity is a proposition. 49 | prop_inj0 (A B : U) (f : A -> B) (sA : set A) (sB : set B) 50 | : prop (inj0 A B f sA sB) 51 | = let 52 | c (a0 a1 : A) : prop (Path B (f a0) (f a1) -> Path A a0 a1) 53 | = let 54 | P : Path B (f a0) (f a1) -> U 55 | = \ (_ : Path B (f a0) (f a1)) -> Path A a0 a1 56 | h : (x : Path B (f a0) (f a1)) -> prop (P x) 57 | = \ (_ : Path B (f a0) (f a1)) -> sA a0 a1 58 | in 59 | propPi (Path B (f a0) (f a1)) P h 60 | d (a0 : A) : prop ((a1 : A) -> Path B (f a0) (f a1) -> Path A a0 a1) 61 | = let 62 | P : A -> U 63 | = \ (a1 : A) -> ( Path B (f a0) (f a1) -> Path A a0 a1 ) 64 | h : (a1 : A) -> prop (P a1) 65 | = \ (a1 : A) -> c a0 a1 66 | in 67 | propPi A P h 68 | e : prop (inj0 A B f sA sB) 69 | = let 70 | P : A -> U 71 | = \ (a0 : A) -> ( (a1 : A) -> Path B (f a0) (f a1) -> Path A a0 a1 ) 72 | h : (a0 : A) -> prop ( (a1 : A) -> Path B (f a0) (f a1) -> Path A a0 a1 ) 73 | = \ (a0 : A) -> d a0 74 | in 75 | propPi A P h 76 | in 77 | e 78 | 79 | -- A proof that the second definition of injectivity is a proposition. 80 | prop_inj1 (A B : U) (f : A -> B) (sA : set A) (sB : set B) : 81 | prop (inj1 A B f sA sB) 82 | = let 83 | P : B -> U 84 | = \ (b : B) -> (a : A) * Path B (f a) b 85 | Q : B -> U 86 | = \ (b : B) -> prop (P b) 87 | h : (b : B) -> prop (Q b) 88 | = \ (b : B) -> propIsProp (P b) 89 | in 90 | propPi B Q h 91 | 92 | -- A proof that two propositions with maps between them can be identified with 93 | -- each other 94 | propPath (A B : U) (f : A -> B) (g : B -> A) (pA : prop A) (pB : prop B) : 95 | Path U A B 96 | = isoPath A B f g (\ (b : B) -> pB (f (g b)) b) (\ (a : A) -> pA (g (f a)) a) 97 | 98 | -- A proof that the two definitions of injectivity can be identified with each 99 | -- other 100 | injPath (A B : U) (f : A -> B) (sA : set A) (sB : set B) : 101 | Path U (inj0 A B f sA sB) (inj1 A B f sA sB) 102 | = propPath (inj0 A B f sA sB) (inj1 A B f sA sB) 103 | (inj01 A B f sA sB) (inj10 A B f sA sB) 104 | (prop_inj0 A B f sA sB) (prop_inj1 A B f sA sB) 105 | -------------------------------------------------------------------------------- /examples/int.ctt: -------------------------------------------------------------------------------- 1 | -- The integers as nat + nat with proof that suc is an iso giving a 2 | -- non-trivial path from Z to Z 3 | module int where 4 | 5 | import equiv 6 | import nat 7 | import discor 8 | 9 | --------------------------------------------------- 10 | -- Example: Non-trivial equality between Z and Z -- 11 | --------------------------------------------------- 12 | 13 | Z : U = or nat nat 14 | 15 | {- Z represents: 16 | 17 | +2 = inr (suc (suc zero)) 18 | +1 = inr (suc zero) 19 | 0 = inr zero 20 | -1 = inl zero 21 | -2 = inl (suc zero) 22 | 23 | -} 24 | 25 | zeroZ : Z = inr zero 26 | 27 | sucZ : Z -> Z = split 28 | inl u -> auxsucZ u 29 | where 30 | auxsucZ : nat -> Z = split 31 | zero -> inr zero 32 | suc n -> inl n 33 | inr v -> inr (suc v) 34 | 35 | predZ : Z -> Z = split 36 | inl u -> inl (suc u) 37 | inr v -> auxpredZ v 38 | where 39 | auxpredZ : nat -> Z = split 40 | zero -> inl zero 41 | suc n -> inr n 42 | 43 | sucpredZ : (x : Z) -> Path Z (sucZ (predZ x)) x = split 44 | inl u -> refl Z (inl u) 45 | inr v -> lem v 46 | where 47 | lem : (u : nat) -> Path Z (sucZ (predZ (inr u))) (inr u) = split 48 | zero -> refl Z (inr zero) 49 | suc n -> refl Z (inr (suc n)) 50 | 51 | predsucZ : (x : Z) -> Path Z (predZ (sucZ x)) x = split 52 | inl u -> lem u 53 | where 54 | lem : (u : nat) -> Path Z (predZ (sucZ (inl u))) (inl u) = split 55 | zero -> refl Z (inl zero) 56 | suc n -> refl Z (inl (suc n)) 57 | inr v -> refl Z (inr v) 58 | 59 | 60 | sucPathZ : Path U Z Z = isoPath Z Z sucZ predZ sucpredZ predsucZ 61 | 62 | -- We can transport along the proof forward and backwards: 63 | testOneZ : Z = transport sucPathZ zeroZ 64 | testNOneZ : Z = transport ( sucPathZ @ - i) zeroZ 65 | 66 | 67 | 68 | ZSet : set Z = hedberg Z (orDisc nat nat natDec natDec) 69 | -------------------------------------------------------------------------------- /examples/integer.ctt: -------------------------------------------------------------------------------- 1 | -- The integers as a HIT (identifying +0 with -0). Proof that this 2 | -- representation is isomorphic to the one in int.ctt 3 | module integer where 4 | 5 | import int 6 | 7 | ------------------------------------ 8 | -- Example: The integers as a HIT -- 9 | ------------------------------------ 10 | 11 | data int = pos (n : nat) 12 | | neg (n : nat) 13 | | zeroP [ (i = 0) -> pos zero 14 | , (i = 1) -> neg zero ] 15 | 16 | -- Nice version of the zero constructor: 17 | zeroZ : Path int (pos zero) (neg zero) = zeroP {int} @ i 18 | 19 | sucInt : int -> int = split 20 | pos n -> pos (suc n) 21 | neg n -> sucNat n 22 | where sucNat : nat -> int = split 23 | zero -> pos one 24 | suc n -> neg n 25 | zeroP @ i -> pos one 26 | 27 | predInt : int -> int = split 28 | pos n -> predNat n 29 | where predNat : nat -> int = split 30 | zero -> neg one 31 | suc n -> pos n 32 | neg n -> neg (suc n) 33 | zeroP @ i -> neg one 34 | 35 | toZ : int -> Z = split 36 | pos n -> inr n 37 | neg n -> auxToZ n 38 | where auxToZ : nat -> Z = split 39 | zero -> inr zero 40 | suc n -> inl n 41 | zeroP @ i -> inr zero 42 | 43 | fromZ : Z -> int = split 44 | inl n -> neg (suc n) 45 | inr n -> pos n 46 | 47 | toZK : (a : Z) -> Path Z (toZ (fromZ a)) a = split 48 | inl n -> <_> inl n 49 | inr n -> <_> inr n 50 | 51 | fromZK : (a : int) -> Path int (fromZ (toZ a)) a = split 52 | pos n -> <_> pos n 53 | neg n -> rem n 54 | where rem : (n : nat) -> Path int (fromZ (toZ (neg n))) (neg n) = split 55 | zero -> zeroZ 56 | suc m -> <_> neg (suc m) 57 | zeroP @ i -> zeroZ @ i /\ j 58 | 59 | isoIntZ : Path U Z int = isoPath Z int fromZ toZ fromZK toZK 60 | 61 | intSet : set int = subst U set Z int isoIntZ ZSet 62 | 63 | -- a concrete instance 64 | 65 | T : U = Path int (pos zero) (pos zero) 66 | p0 : T = <_> pos zero 67 | p1 : T = compPath int (pos zero) (neg zero) (pos zero) zeroZ (zeroZ@-i) 68 | 69 | test0 : Path (Path Z (inr zero) (inr zero)) (<_> inr zero) (<_> inr zero) = 70 | ZSet (inr zero) (inr zero) (<_> inr zero) (<_> inr zero) 71 | 72 | -- Tests for normal forms: 73 | test1 : Path T p0 p1 = intSet (pos zero) (pos zero) p0 p1 74 | test2 : Path T p0 p0 = intSet (pos zero) (pos zero) p0 p0 75 | 76 | ntest1 : Path T p0 p1 = comp (<_> int) (pos zero) [ (i1 = 0) -> pos zero, (i1 = 1) -> comp (<_> int) (zeroP {int} @ (i2 /\ i3)) [ (i2 = 0) -> pos zero, (i2 = 1) -> zeroP {int} @ (-i4 /\ i3), (i3 = 0) -> pos zero, (i3 = 1) -> comp (<_> int) (zeroP {int} @ i2) [ (i2 = 0) -> pos zero, (i2 = 1) -> zeroP {int} @ (-i4 \/ -i5), (i4 = 0) -> zeroP {int} @ i2 ] ], (i2 = 0) -> pos zero, (i2 = 1) -> pos zero ] 77 | 78 | ntest2 : Path T p0 p0 = comp (<_> int) (pos zero) [ (i1 = 0) -> pos zero, (i1 = 1) -> pos zero, (i2 = 0) -> pos zero, (i2 = 1) -> pos zero ] 79 | 80 | -------------------------------------------------------------------------------- /examples/interval.ctt: -------------------------------------------------------------------------------- 1 | -- The interval as a HIT. Proof of funtion extensionality from it. 2 | module interval where 3 | 4 | import equiv 5 | 6 | data I = zero 7 | | one 8 | | seg [ (i = 0) -> zero 9 | , (i = 1) -> one ] 10 | 11 | -- Proof of funext from the interval 12 | fext (A B : U) (f g : A -> B) (p : (x : A) -> Path B (f x) (g x)) : 13 | Path (A -> B) f g = (\(x : A) -> htpy x (seg{I} @ j)) 14 | where htpy (x : A) : I -> B = split 15 | zero -> f x 16 | one -> g x 17 | seg @ i -> p x @ i 18 | 19 | 20 | toUnit : I -> Unit = split 21 | zero -> tt 22 | one -> tt 23 | seg @ i -> tt 24 | 25 | fromUnit : Unit -> I = split 26 | tt -> zero 27 | 28 | toUnitK : (a : Unit) -> Path Unit (toUnit (fromUnit a)) a = split 29 | tt -> tt 30 | 31 | fromUnitK : (a : I) -> Path I (fromUnit (toUnit a)) a = split 32 | zero -> zero 33 | one -> seg {I} @ i 34 | seg @ i -> seg {I} @ i /\ j 35 | 36 | unitEqI : Path U Unit I = isoPath Unit I fromUnit toUnit fromUnitK toUnitK 37 | 38 | propI : prop I = subst U prop Unit I unitEqI propUnit 39 | 40 | setI : set I = subst U set Unit I unitEqI setUnit 41 | 42 | T : U = Path I zero zero 43 | p0 : T = refl I zero 44 | test : T = propI zero zero 45 | 46 | 47 | 48 | 49 | 50 | 51 | -------------------------------------------------------------------------------- /examples/lambek.ctt: -------------------------------------------------------------------------------- 1 | module lambek where 2 | import prelude 3 | import control 4 | 5 | data either (A B: U) = left (a: A) | right (b: B) 6 | either_ (A B C: U) (b: A -> C) (c: B -> C) : either A B -> C = split 7 | left x -> b x 8 | right y -> c y 9 | 10 | data tuple (A B: U) = pair (a: A) (b: B) 11 | fst (A B: U): tuple A B -> A = split pair a b -> a 12 | snd (A B: U): tuple A B -> B = split pair a b -> b 13 | 14 | cata (A: U) (F: U -> U) (X: functor F) (alg: F A -> A) (f: fix F): A 15 | = alg (X.1 (fix F) A (cata A F X alg) (out_ F f)) 16 | 17 | ana (A: U) (F: U -> U) (X: functor F) (coalg: A -> F A) (a: A): fix F 18 | = Fix (X.1 A (fix F) (ana A F X coalg) (coalg a)) 19 | 20 | hylo (A B: U) (F: U -> U) (X: functor F) (alg: F B -> B) (coalg: A -> F A) (a: A): B 21 | = alg (X.1 A B (hylo A B F X alg coalg) (coalg a)) 22 | 23 | para (A: U) (F: U -> U) (X: functor F) (alg: F (tuple (fix F) A) -> A) (f: fix F): A 24 | = alg (X.1 (fix F) (tuple (fix F) A) (\(m: fix F) -> pair m (para A F X alg m)) (out_ F f)) 25 | 26 | zygo (A B: U) (F: U -> U) (X: functor F) (g: F A -> A) (alg: F (tuple A B) -> B) (f: fix F): B 27 | = snd A B (cata (tuple A B) F X (\(x: F (tuple A B)) 28 | -> pair (g (X.1 (tuple A B) A (\(y: tuple A B) -> fst A B y) x)) (alg x)) f) 29 | 30 | prepro (A: U) (F: U -> U) (X: functor F) (nt: F(fix F) -> F(fix F)) (alg: F A -> A) (f: fix F): A 31 | = alg (X.1 (fix F) A (\(x: fix F) -> prepro A F X nt alg (cata (fix F) F X (\(y: F(fix F)) 32 | -> Fix (nt y)) x)) (out_ F f)) 33 | 34 | postpro (A: U) (F: U -> U) (X: functor F) (nt : F(fix F) -> F(fix F)) (coalg: A -> F A) (a: A): fix F 35 | = Fix (X.1 A (fix F) (\(x: A) -> ana (fix F) F X (\(y: fix F) 36 | -> nt (out_ F y)) (postpro A F X nt coalg x)) (coalg a)) 37 | 38 | apo (A: U) (F: U -> U) (X: functor F) (coalg: A -> F(either (fix F) A)) (a: A): fix F 39 | = Fix (X.1 (either (fix F) A) (fix F) (\(x: either (fix F) A) 40 | -> either_ (fix F) A (fix F) (idfun (fix F)) (apo A F X coalg) x) (coalg a)) 41 | 42 | gapo (A B: U) (F: U -> U) (X: functor F) (coalg: A -> F A) (coalg2: B -> F(either A B)) (b: B): fix F 43 | = Fix ((X.1 (either A B) (fix F) (\(x: either A B) 44 | -> either_ A B (fix F) (\(y: A) -> ana A F X coalg y) (\(z: B) 45 | -> gapo A B F X coalg coalg2 z) x) (coalg2 b))) 46 | 47 | futu (A: U) (F: U -> U) (X: functor F) (f: A -> F (free F A)) (a: A): fix F = 48 | Fix (X.1 (free F A) (fix F) (\(z: free F A) -> w z) (f a)) where 49 | w: free F A -> fix F = split 50 | Free x -> unpack x where 51 | unpack_free: freeF F A (fix (freeF F A)) -> fix F = split 52 | ReturnF x -> futu A F X f x 53 | BindF g -> Fix (X.1 (fix (freeF F A)) (fix F) (\(x: fix (freeF F A)) -> w (Free x)) g) 54 | unpack: fix (freeF F A) -> fix F = split 55 | Fix x -> unpack_free x 56 | 57 | histo (A:U) (F: U->U) (X: functor F) (f: F (cofree F A) -> A) (z: fix F): A = 58 | extract A F ((cata (cofree F A) F X (\(x: F (cofree F A)) -> 59 | CoFree (Fix (CoBindF (f x) ((X.1 (cofree F A) 60 | (fix (cofreeF F A)) (uncofree A F) x)))))) z) where 61 | extract (A: U) (F: U -> U): cofree F A -> A = split 62 | CoFree f -> unpack_fix f where 63 | unpack_fix: fix (cofreeF F A) -> A = split 64 | Fix f -> unpack_cofree f where 65 | unpack_cofree: cofreeF F A (fix (cofreeF F A)) -> A = split 66 | CoBindF a -> a 67 | 68 | chrono (A B: U) (F: U -> U) (X: functor F) 69 | (f: F (cofree F B) -> B) 70 | (g: A -> F (free F A)) 71 | (a: A): B = histo B F X f (futu A F X g a) 72 | 73 | mcata (T: U) (F: U -> U) (phi: ((fix F) -> T) -> F (fix F) -> T) (t: fix F): T 74 | = phi (\(x: fix F) -> mcata T F phi x) (out_ F t) 75 | 76 | meta (A B: U) (F: U -> U) (X: functor F) 77 | (f: A -> F A) (e: B -> A) 78 | (g: F B -> B) (t: fix F): fix F 79 | = ana A F X f (e (cata B F X g t)) 80 | 81 | mutu (A B: U) (F: U -> U) (X: functor F) 82 | (f: F (tuple A B) -> B) 83 | (g: F (tuple B A) -> A) 84 | (t: fix F): A 85 | = g (X.1 (fix F) (tuple B A) (\(x: fix F) -> 86 | pair (mutu B A F X g f x) (mutu A B F X f g x)) (out_ F t)) 87 | 88 | -- inductive types 89 | 90 | ind (A: U) (F: U -> U): U 91 | = (in_: F (fix F) -> fix F) 92 | * (in_rev: fix F -> F (fix F)) 93 | * (fold_: (F A -> A) -> fix F -> A) 94 | * Unit 95 | 96 | inductive (F: U -> U) (A: U) (X: functor F): ind A F 97 | = (in_ F,out_ F,cata A F X,tt) 98 | 99 | coind (A: U) (F: U -> U): U 100 | = (out_: fix F -> F (fix F)) 101 | * (out_rev: F (fix F) -> fix F) 102 | * (unfold_: (A -> F A) -> A -> fix F) 103 | * Unit 104 | 105 | coinductive (F: U -> U) (A: U) (X: functor F): coind A F 106 | = (out_ F,in_ F,ana A F X,tt) 107 | 108 | -- category of F-algebra endofunctors 109 | 110 | listAlg (A : U) : U 111 | = (X: U) 112 | * (nil: X) 113 | * (cons: A -> X -> X) 114 | * Unit 115 | 116 | listMor (A: U) (x1 x2: listAlg A) : U 117 | = (map: x1.1 -> x2.1) 118 | * (mapNil: Path x2.1 (map (x1.2.1)) (x2.2.1)) 119 | * (mapCons: (a:A) (x: x1.1) -> Path x2.1 (map (x1.2.2.1 a x)) (x2.2.2.1 a (map x))) 120 | * Unit 121 | 122 | listObject (A: U) : U 123 | = (point: (x: listAlg A) -> x.1) 124 | * (map: (x1 x2: listAlg A) 125 | (m: listMor A x1 x2) -> 126 | Path x2.1 (m.1 (point x1)) (point x2)) 127 | * Unit 128 | 129 | -------------------------------------------------------------------------------- /examples/list.ctt: -------------------------------------------------------------------------------- 1 | -- Lists 2 | module list where 3 | 4 | import prelude 5 | 6 | data list (A : U) = nil 7 | | cons (a : A) (as : list A) 8 | 9 | append (A : U) : list A -> list A -> list A = split 10 | nil -> idfun (list A) 11 | cons x xs -> \(ys : list A) -> cons x (append A xs ys) 12 | 13 | reverse (A : U) : list A -> list A = split 14 | nil -> nil 15 | cons x xs -> append A (reverse A xs) (cons x nil) 16 | 17 | map (A B:U) (f:A->B) : list A -> list B = split 18 | nil -> nil 19 | cons x xs -> cons (f x) (map A B f xs) 20 | 21 | lem (A B C:U) (f:A->B) (g:B -> C) : 22 | (xs:list A) -> Path (list C) (map B C g (map A B f xs)) (map A C (\ (x:A) -> g (f x)) xs) = split 23 | nil -> nil 24 | cons x xs -> cons (g (f x)) (lem A B C f g xs@i) 25 | 26 | funPath (A:U) (x:A) : A = x 27 | 28 | lem1 (A:U) : (xs:list A) -> Path (list A) (map A A (funPath A) xs) xs = split 29 | nil -> nil 30 | cons x xs -> cons x (lem1 A xs@i) 31 | 32 | reverse (A : U) : list A -> list A = split 33 | nil -> nil 34 | cons x xs -> append A (reverse A xs) (cons x nil) 35 | 36 | lem2 (A:U) : (xs:list A) -> Path (list A) (append A xs nil) xs = split 37 | nil -> nil 38 | cons x xs -> cons x (lem2 A xs@i) 39 | 40 | assoc (A:U) : (xs ys zs : list A) -> Path (list A) (append A (append A xs ys) zs) (append A xs (append A ys zs)) = split 41 | nil -> \ (ys zs:list A) -> append A ys zs 42 | cons x xs -> \ (ys zs:list A) -> cons x (assoc A xs ys zs@i) 43 | 44 | {- 45 | 46 | lem4 (A:U) : (xs ys:list A) -> Path (list A) (reverse A (append A xs ys)) (append A (reverse A ys) (reverse A xs)) = split 47 | nil -> \ (ys:list A) -> lem2 A (reverse A ys)@-i 48 | cons x xs -> \ (ys:list A) -> comp (list A) (append A (lem4 A xs ys@i) (cons x nil)) 49 | [(i=1) -> assoc A (reverse A ys) (reverse A xs) (cons x nil)] 50 | 51 | lem5 (A:U) : (xs:list A) -> Path (list A) (reverse A (reverse A xs)) xs = split 52 | nil -> nil 53 | cons x xs -> comp (list A) (lem4 A (reverse A xs) (cons x nil)@i) [(i=1) -> cons x (lem5 A xs@j)] 54 | 55 | -} 56 | -------------------------------------------------------------------------------- /examples/nat.ctt: -------------------------------------------------------------------------------- 1 | -- Natural numbers 2 | module nat where 3 | 4 | import bool 5 | 6 | data nat = zero | suc (n : nat) 7 | 8 | one : nat = suc zero 9 | two : nat = suc one 10 | three : nat = suc two 11 | four : nat = suc three 12 | five : nat = suc four 13 | 14 | n0 : nat = zero 15 | n1 : nat = suc n0 16 | n2 : nat = suc n1 17 | n3 : nat = suc n2 18 | n4 : nat = suc n3 19 | n5 : nat = suc n4 20 | n6 : nat = suc n5 21 | n7 : nat = suc n6 22 | n8 : nat = suc n7 23 | n9 : nat = suc n8 24 | n10 : nat = suc n9 25 | n11 : nat = suc n10 26 | n12 : nat = suc n11 27 | n13 : nat = suc n12 28 | n14 : nat = suc n13 29 | n15 : nat = suc n14 30 | n16 : nat = suc n15 31 | n17 : nat = suc n16 32 | n18 : nat = suc n17 33 | n19 : nat = suc n18 34 | n20 : nat = suc n19 35 | 36 | pred : nat -> nat = split 37 | zero -> zero 38 | suc n -> n 39 | 40 | add (m : nat) : nat -> nat = split 41 | zero -> m 42 | suc n -> suc (add m n) 43 | 44 | add_zero : (n : nat) -> Path nat (add zero n) n = split 45 | zero -> zero 46 | suc n -> suc (add_zero n @ i) 47 | 48 | add_suc (a:nat) : (n : nat) -> Path nat (add (suc a) n) (suc (add a n)) = split 49 | zero -> suc a 50 | suc m -> suc (add_suc a m @ i) 51 | 52 | add_comm (a : nat) : (n : nat) -> Path nat (add a n) (add n a) = split 53 | zero -> add_zero a @ -i 54 | suc m -> comp (<_> nat) (suc (add_comm a m @ i)) 55 | [ (i = 0) -> suc (add a m) 56 | , (i = 1) -> add_suc m a @ -j ] 57 | 58 | assocAdd (a b:nat) : (c:nat) -> Path nat (add a (add b c)) (add (add a b) c) = split 59 | zero -> add a b 60 | suc c1 -> suc (assocAdd a b c1@i) 61 | 62 | add' : nat -> nat -> nat = split 63 | zero -> \(x : nat) -> x 64 | suc n -> \(x : nat) -> suc (add' n x) 65 | 66 | sucInj (n m : nat) (p : Path nat (suc n) (suc m)) : Path nat n m = 67 | pred (p @ i) 68 | 69 | add_comm3 (a b c : nat) : Path nat (add a (add b c)) (add c (add b a)) = 70 | let rem : Path nat (add a (add b c)) (add a (add c b)) = add a (add_comm b c @ i) 71 | rem1 : Path nat (add a (add c b)) (add (add c b) a) = add_comm a (add c b) 72 | rem2 : Path nat (add (add c b) a) (add c (add b a)) = assocAdd c b a @ -i 73 | in comp (<_> nat) (rem1 @ i) [ (i = 0) -> rem @ -j, (i = 1) -> rem2 ] 74 | 75 | natcancelr (a b : nat) : (x : nat) -> Path nat (add a x) (add b x) -> Path nat a b = split 76 | zero -> \(h : Path nat a b) -> h 77 | suc x' -> \(h : Path nat (suc (add a x')) (suc (add b x'))) -> 78 | natcancelr a b x' (sucInj (add a x') (add b x') h) 79 | 80 | idnat : nat -> nat = split 81 | zero -> zero 82 | suc n -> suc (idnat n) 83 | 84 | test : Path (nat -> nat) idnat (idfun nat) = funExt nat (\(_ : nat) -> nat) idnat (idfun nat) rem 85 | where 86 | rem : (n : nat) -> Path nat (idnat n) n = split 87 | zero -> refl nat zero 88 | suc n -> mapOnPath nat nat (\(x : nat) -> suc x) (idnat n) n (rem n) 89 | 90 | caseNat (A : U) (a0 aS : A) : nat -> A = split 91 | zero -> a0 92 | suc n -> aS 93 | 94 | caseDNat (P:nat -> U) (a0 :P zero) (aS : (n:nat) -> P (suc n)) 95 | : (n:nat) -> P n = split 96 | zero -> a0 97 | suc n -> aS n 98 | 99 | znots (n : nat) : neg (Path nat zero (suc n)) = 100 | \ (h:Path nat zero (suc n)) -> subst nat (caseNat U nat N0) zero (suc n) h zero 101 | 102 | snotz (n : nat) : neg (Path nat (suc n) zero) = 103 | \ (h:Path nat (suc n) zero) -> znots n (inv nat (suc n) zero h) 104 | 105 | natDec : (n m:nat) -> dec (Path nat n m) = split 106 | zero -> caseDNat (\ (m:nat) -> dec (Path nat zero m)) (inl (refl nat zero)) (\ (m:nat) -> inr (znots m)) 107 | suc n -> caseDNat (\ (m:nat) -> dec (Path nat (suc n) m)) (inr (snotz n)) 108 | (\ (m:nat) -> decEqCong (Path nat n m) (Path nat (suc n) (suc m)) (\ (p:Path nat n m) -> suc (p @ i)) 109 | (sucInj n m) (natDec n m)) 110 | 111 | natSet : set nat = hedberg nat natDec 112 | 113 | equalNat : nat -> nat -> bool = split 114 | zero -> split@(nat -> bool) with 115 | zero -> true 116 | suc n -> false 117 | suc m -> split@(nat -> bool) with 118 | zero -> false 119 | suc n -> equalNat m n 120 | 121 | -- Direct proof that nat is a set: 122 | invP : (n m : nat) (p : Path nat n m) -> U = split 123 | zero -> split@((m : nat) (p : Path nat zero m) -> U) with 124 | zero -> \(p : Path nat zero zero) -> 125 | Path (Path nat zero zero) p (<_> zero) 126 | suc m -> \(p : Path nat zero (suc m)) -> N0 127 | suc n -> split@((m : nat) (p : Path nat (suc n) m) -> U) with 128 | zero -> \(p : Path nat (suc n) zero) -> N0 129 | suc m -> \(p : Path nat (suc n) (suc m)) -> 130 | Path (Path nat (suc n) (suc m)) p ( suc (pred (p @ i))) 131 | 132 | -- using J for now 133 | pinv : (n m : nat) (p : Path nat n m) -> invP n m p = split 134 | zero -> J nat zero (invP zero) (<_ _> zero) 135 | suc n -> J nat (suc n) (invP (suc n)) (<_ _> suc n) 136 | 137 | lem : (n : nat) (p : Path nat n n) -> Path (Path nat n n) p (<_> n) = split 138 | zero -> pinv zero zero 139 | suc n -> \(p : Path nat (suc n) (suc n)) -> 140 | compPath (Path nat (suc n) (suc n)) p ( suc (pred (p @ i))) (<_> suc n) 141 | (pinv (suc n) (suc n) p) 142 | ( suc (lem n ( pred (p @ k)) @ i @ j)) 143 | 144 | natset' (n : nat) : (m : nat) (p q : Path nat n m) -> Path (Path nat n m) q p = 145 | J nat n (\(m : nat)(p : Path nat n m) -> 146 | (q : Path nat n m) -> Path (Path nat n m) q p) 147 | (lem n) 148 | 149 | setnat (n m : nat) (p q : Path nat n m) : Path (Path nat n m) p q = natset' n m q p 150 | -------------------------------------------------------------------------------- /examples/opposite.ctt: -------------------------------------------------------------------------------- 1 | -- Definition of the opposite category and verification that C^op^op = C definitionally 2 | module opposite where 3 | 4 | import category 5 | 6 | oppCat (C : precategory) : precategory = (Copp,isPrecategoryCopp) 7 | where 8 | A : U = cA C 9 | homOpp (a b : A) : U = cH C b a 10 | 11 | Copp : categoryData = (A,homOpp) 12 | idOpp (a : A) : homOpp a a = C.2.1 a 13 | compOpp (a b c : A) (f : homOpp a b) (g : homOpp b c) : homOpp a c = 14 | C.2.2.1 c b a g f 15 | 16 | homOppSet (a b : A) : set (homOpp a b) = cHSet C b a 17 | 18 | left_id (a b : A) (f : homOpp a b) : 19 | Path (homOpp a b) (compOpp a a b (idOpp a) f) f = cPathR C b a f 20 | 21 | right_id (a b : A) (f : homOpp a b) : 22 | Path (homOpp a b) (compOpp a b b f (idOpp b)) f = cPathL C b a f 23 | 24 | assoc (a b c d : A) (f : homOpp a b) (g : homOpp b c) (h : homOpp c d) : 25 | Path (homOpp a d) (compOpp a c d (compOpp a b c f g) h) 26 | (compOpp a b d f (compOpp b c d g h)) = 27 | cPathC C d c b a h g f @ -i 28 | 29 | isPrecategory2Copp : isPrecategory2 Copp idOpp compOpp = 30 | (homOppSet,left_id,right_id,assoc) 31 | 32 | isPrecategoryCopp : isPrecategory Copp = (idOpp,compOpp,isPrecategory2Copp) 33 | 34 | oppOppCat (C : precategory) : Path precategory (oppCat (oppCat C)) C = 35 | C 36 | -------------------------------------------------------------------------------- /examples/ordinal.ctt: -------------------------------------------------------------------------------- 1 | -- Ordinals 2 | module ordinal where 3 | 4 | import prelude 5 | 6 | -- from the JSL 89 paper of Stan Wainer 7 | 8 | data nat = zero | succ (n:nat) 9 | 10 | data ord = zero | succ (n:ord) | lim (f : nat -> ord) 11 | 12 | data ord2 = zero | succ (n:ord2) | lim (f : nat -> ord2) | lim2 (f : ord -> ord2) 13 | 14 | inj0 : nat -> ord = split 15 | zero -> zero 16 | succ n -> succ (inj0 n) 17 | 18 | G1 : ord -> nat -> nat = split 19 | zero -> \ (x:nat) -> zero 20 | succ z -> \ (x:nat) -> succ (G1 z x) 21 | lim f -> \ (x:nat) -> G1 (f x) x 22 | 23 | G2 : ord2 -> nat -> ord = split 24 | zero -> \ (x:nat) -> zero 25 | succ z -> \ (x:nat) -> succ (G2 z x) 26 | lim f -> \ (x:nat) -> G2 (f x) x 27 | lim2 f -> \ (x:nat) -> lim (\ (n:nat) -> G2 (f (inj0 n)) x) 28 | 29 | and (A B : U) : U = (_:A) * B 30 | 31 | O2 (n:nat) : ord2 -> U = split 32 | zero -> Unit 33 | succ z -> O2 n z 34 | lim f -> (p:nat) -> O2 n (f p) 35 | lim2 f -> (x:ord) -> and (O2 n (f x)) (Path ord (G2 (f x) n) (G2 (f (inj0 (G1 x n))) n)) 36 | 37 | inj12 : ord -> ord2 = split 38 | zero -> zero 39 | succ z -> succ (inj12 z) 40 | lim f -> lim (\ (n:nat) -> inj12 (f n)) 41 | 42 | H1 : ord -> nat -> nat = split 43 | zero -> \ (x:nat) -> x 44 | succ z -> \ (x:nat) -> H1 z (succ x) 45 | lim f -> \ (x:nat) -> H1 (f x) x 46 | 47 | H2 : ord2 -> ord -> ord = split 48 | zero -> \ (x:ord) -> x 49 | succ z -> \ (x:ord) -> H2 z (succ x) 50 | lim f -> \ (x:ord) -> lim (\ (n:nat) -> H2 (f n) x) 51 | lim2 f -> \ (x:ord) -> H2 (f x) x 52 | 53 | collapsing (n:nat) : 54 | (x:ord2) (y:ord) -> O2 n x -> Path nat (G1 (H2 x y) n) (H1 (G2 x n) (G1 y n)) = split 55 | zero -> \ (y:ord) (h:O2 n zero) -> G1 y n 56 | succ z -> \ (y:ord) (h:O2 n (succ z)) -> collapsing n z (succ y) h 57 | lim f -> \ (y:ord) (h:O2 n (lim f)) -> collapsing n (f n) y (h n) 58 | lim2 f -> \ (y:ord) (h:O2 n (lim2 f)) -> 59 | let 60 | rem : Path ord (G2 (f y) n) (G2 (f (inj0 (G1 y n))) n) = (h y).2 61 | 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 62 | in comp (Path nat (G1 (H2 (f y) y) n) (H1 (rem@i) (G1 y n))) rem1 [] 63 | 64 | -- an application 65 | 66 | omega : ord = lim inj0 67 | 68 | omega1 : ord2 = lim2 inj12 69 | 70 | lemOmega1 (n:nat) : O2 n omega1 = \ (x:ord) -> (rem x,rem1 x) 71 | where rem : (x:ord) -> O2 n (inj12 x) = split 72 | zero -> tt 73 | succ z -> rem z 74 | lim f -> \ (p:nat) -> rem (f p) 75 | rem1 : (x:ord) -> Path ord (G2 (inj12 x) n) (G2 (inj12 (inj0 (G1 x n))) n) = split 76 | zero -> zero 77 | succ z -> succ ((rem1 z)@i) 78 | lim f -> rem1 (f n) 79 | 80 | corr1 (n:nat) : Path nat (G1 (H2 omega1 omega) n) (H1 (G2 omega1 n) (G1 omega n)) = 81 | collapsing n omega1 omega (lemOmega1 n) 82 | 83 | lem : (n p:nat) -> Path nat (G1 (inj0 n) p) n = split 84 | zero -> \ (p:nat) -> zero 85 | succ q -> \ (p:nat) -> succ (lem q p@i) 86 | 87 | lem1 (n:nat) : Path nat (G1 omega n) n = lem n n 88 | 89 | lem2 : (n p:nat) -> Path ord (G2 (inj12 (inj0 n)) p) (inj0 n) = split 90 | zero -> \ (p:nat) -> inj0 zero 91 | succ q -> \ (p:nat) -> succ (lem2 q p@i) 92 | 93 | test (n:nat) : ord = G2 omega1 n 94 | 95 | lem3 (n:nat) : Path ord (G2 (inj12 (inj0 n)) n) (inj0 n) = lem2 n n 96 | 97 | lem4 (n:nat) : Path nat (H1 (G2 omega1 n) n) (H1 omega n) = 98 | H1 (lem3 n@i) n 99 | 100 | -- the G1 and H1 hierarchy coincides: G1 (H2 omega1 omega) and H1 omega are the same function 101 | 102 | corr2 : Path (nat -> nat) (G1 (H2 omega1 omega)) (H1 omega) = 103 | \ (n:nat) -> comp (<_>nat) (H1 (G2 omega1 n) ((lem1 n)@i)) [(i=0) -> corr1 n@-j,(i=1) -> lem4 n] 104 | 105 | -------------------------------------------------------------------------------- /examples/pi.ctt: -------------------------------------------------------------------------------- 1 | -- Characterization of equality in pi types. 2 | module pi where 3 | 4 | import equiv 5 | 6 | ----------------------------------- 7 | -- Example: Equality in pi types -- 8 | ----------------------------------- 9 | 10 | pi (A:U) (P:A->U) : U = (x:A) -> P x 11 | 12 | idPi (A:U) (B:A->U) (f g : pi A B) : Path U (Path (pi A B) f g) ((x:A) -> Path (B x) (f x) (g x)) = 13 | isoPath (Path (pi A B) f g) ((x:A) -> Path (B x) (f x) (g x)) F G S T 14 | where T0 : U = Path (pi A B) f g 15 | T1 : U = (x:A) -> Path (B x) (f x) (g x) 16 | F (p:T0) : T1 = \ (x:A) -> p@i x 17 | G (p:T1) : T0 = \ (x:A) -> p x @ i 18 | S (p:T1) : Path T1 (F (G p)) p = refl T1 p 19 | T (p:T0) : Path T0 (G (F p)) p = refl T0 p 20 | 21 | setPi (A:U) (B:A -> U) (h:(x:A) -> set (B x)) (f g:pi A B) : prop (Path (pi A B) f g) = 22 | rem 23 | where 24 | T : U = (x:A) -> Path (B x) (f x) (g x) 25 | rem1 : prop T = \ (p q : T) -> \ (x:A) -> h x (f x) (g x) (p x) (q x)@i 26 | 27 | rem : prop (Path (pi A B) f g) = 28 | subst U prop T (Path (pi A B) f g) (idPi A B f g@-i) rem1 29 | 30 | groupoidPi (A:U) (B:A -> U) (h:(x:A) -> groupoid (B x)) (f g:pi A B) : set (Path (pi A B) f g) = 31 | subst U set T (Path (pi A B) f g) (idPi A B f g@-i) rem1 32 | where 33 | T : U = (x:A) -> Path (B x) (f x) (g x) 34 | rem1 : set T = setPi A (\ (x:A) -> Path (B x) (f x) (g x)) (\ (x:A) -> h x (f x) (g x)) 35 | 36 | propPi2 (A : U) (B0 : A -> A -> U) (h0 : (x y : A) -> prop (B0 x y)) 37 | : prop ((x y : A) -> B0 x y) 38 | = let 39 | p0 (a : A) : prop ((b : A) -> B0 a b) 40 | = propPi A (B0 a) (h0 a) 41 | B1 (a : A) : U 42 | = (b : A) -> B0 a b 43 | in propPi A B1 p0 44 | 45 | propPi3 (A : U) (B0 : A -> A -> A -> U) (h0 : (x y z : A) -> prop (B0 x y z)) 46 | : prop ((x y z : A) -> B0 x y z) 47 | = let 48 | p0 (a b : A) : prop ((c : A) -> B0 a b c) 49 | = propPi A (B0 a b) (h0 a b) 50 | B1 (a b : A) : U 51 | = (c : A) -> B0 a b c 52 | in propPi2 A B1 p0 53 | 54 | 55 | -------------------------------------------------------------------------------- /examples/pointedMaps.ctt: -------------------------------------------------------------------------------- 1 | module pointedMaps where 2 | 3 | import bool 4 | 5 | -- Pointed types 6 | pType : U = (X : U) * X 7 | 8 | pt (Z : pType) : Z.1 = Z.2 9 | 10 | -- Maps between pointed types 11 | ppi' (A : pType) (B : A.1 -> U) (b0 : B (pt A)) : U = (f : (a : A.1) -> B a) * Path (B (pt A)) (f (pt A)) b0 12 | ppi (A : pType) (B : A.1 -> pType) : U = ppi' A (\(a : A.1) -> (B a).1) (pt (B (pt A))) 13 | pmap (A B : pType) : U = ppi A (\(a : A.1) -> B) 14 | 15 | pid (A : pType) : pmap A A = (\(a : A.1) -> a, <_> pt A) 16 | 17 | pcompose (A B C : pType) (g : pmap B C) (f : pmap A B) : pmap A C = 18 | (\(a : A.1) -> (g.1 (f.1 a)), compPath C.1 (g.1 (f.1 (pt A))) (g.1 (pt B)) (pt C) ( g.1 (f.2 @ i)) g.2) 19 | 20 | -- constant pointed map 21 | pconst (A B : pType) : pmap A B = (\(a:A.1) -> pt B, <_> pt B ) 22 | 23 | ppmap (A B : pType) : pType = (pmap A B, pconst A B) 24 | 25 | -- pointed equivalence 26 | pequiv (A B : pType) : U = (f : pmap A B) * isEquiv A.1 B.1 f.1 27 | 28 | pbool : pType = (bool, false) 29 | 30 | -- first test case: pointed maps from the booleans to A are the same as points in A 31 | ppmapBoolEquiv (A : pType) : pequiv (ppmap pbool A) A = (e, h) where 32 | B : U = pmap pbool A 33 | e1 : B -> A.1 = \(h : B) -> h.1 true 34 | p : Path A.1 (e1 (pconst pbool A)) (pt A) = <_> pt A 35 | e : pmap (ppmap pbool A) A = (e1, p) 36 | inv : A.1 -> B = \(a : A.1) -> (caseBool A.1 (pt A) a, <_> (pt A)) 37 | q (a : A.1) : Path A.1 (e1 (inv a)) a = <_> a 38 | r (f : B) : Path B (inv (e1 f)) f = 39 | (\(b : bool) -> indBool (\(b : bool) -> Path A.1 ((inv (e1 f)).1 b) (f.1 b)) 40 | ( f.2 @ -i) 41 | (<_> f.1 true) b @ i, 42 | f.2 @ (-i \/ j)) 43 | h : isEquiv B A.1 e.1 = isoToEquiv B A.1 e.1 inv q r 44 | 45 | -- reversing the arguments of a binary pointed map 46 | revPpmap (A B C : pType) : pmap (ppmap A (ppmap B C)) (ppmap B (ppmap A C)) = (e1, e0) where 47 | bc : U = pmap B C 48 | ac : U = pmap A C 49 | abc : U = pmap A (ppmap B C) 50 | bac : U = pmap B (ppmap A C) 51 | BC : pType = ppmap B C 52 | AC : pType = ppmap A C 53 | ABC : pType = ppmap A (ppmap B C) 54 | BAC : pType = ppmap B (ppmap A C) 55 | e111 (f : abc) (b : B.1) (a : A.1) : C.1 = (f.1 a).1 b 56 | e110 (f : abc) (b : B.1) : Path C.1 (e111 f b (pt A)) (pt C) = (f.2 @ i).1 b 57 | e11 (f : abc) (b : B.1) : ac = (e111 f b, e110 f b) 58 | e10 (f : abc) : Path ac (e11 f (pt B)) (pconst A C) = 59 | (\(a : A.1) -> (f.1 a).2 @ i, (f.2 @ j).2 @ i) 60 | e1 (f : abc) : bac = (e11 f, e10 f) 61 | e0 : Path bac (e1 (pconst A BC)) (pconst B AC) = 62 | (\(b : B.1) -> (\(a : A.1) -> pt C, <_> pt C), <_> (\(a : A.1) -> pt C, <_> pt C)) 63 | 64 | revRevPpmap (A B C : pType) (f : pmap A (ppmap B C)) : 65 | Path (pmap A (ppmap B C)) ((revPpmap B A C).1 ((revPpmap A B C).1 f)) f = p where 66 | bc : U = pmap B C 67 | ac : U = pmap A C 68 | abc : U = pmap A (ppmap B C) 69 | bac : U = pmap B (ppmap A C) 70 | BC : pType = ppmap B C 71 | AC : pType = ppmap A C 72 | ABC : pType = ppmap A (ppmap B C) 73 | BAC : pType = ppmap B (ppmap A C) 74 | e : pmap ABC BAC = revPpmap A B C 75 | ei : pmap BAC ABC = revPpmap B A C 76 | p1 (a : A.1) : Path bc ((ei.1 (e.1 f)).1 a) (f.1 a) = 77 | (\(b : B.1) -> (f.1 a).1 b, (f.1 a).2 @ j) 78 | p : Path abc (ei.1 (e.1 f)) f = 79 | (\(a : A.1) -> p1 a @ i, 80 | (\(b : B.1) -> (f.2 @ j).1 b, (f.2 @ j).2 @ k)) 81 | 82 | symmPpmap (A B C : pType) : pequiv (ppmap A (ppmap B C)) (ppmap B (ppmap A C)) = 83 | (revPpmap A B C, isoToEquiv (pmap A (ppmap B C)) (pmap B (ppmap A C)) 84 | (revPpmap A B C).1 (revPpmap B A C).1 (revRevPpmap B A C) (revRevPpmap A B C)) 85 | -------------------------------------------------------------------------------- /examples/propTrunc.ctt: -------------------------------------------------------------------------------- 1 | -- Propositional truncation as a HIT. (WARNING: not working correctly) 2 | module propTrunc where 3 | 4 | import prelude 5 | 6 | {- 7 | Warning: as of commit ff8a026, recursive HITs with parameters are not 8 | implemented correctly. Because of that, you may find unexpected results when 9 | using this module. 10 | 11 | See e.g. github issue #35 and pull request #39 for details. 12 | -} 13 | 14 | data pTrunc (A : U) 15 | = inc (a : A) 16 | | inh (x y : pTrunc A) [(i=0) -> x, (i=1) -> y] 17 | 18 | pTruncIsProp (A : U) : prop (pTrunc A) = 19 | \ (x y : pTrunc A) -> inh{pTrunc A} x y @ i 20 | 21 | pTruncRec (A B : U) (pP : prop B) (f : A -> B) : pTrunc A -> B = split 22 | inc a -> f a 23 | inh x y @ i -> pP (pTruncRec A B pP f x) (pTruncRec A B pP f y) @ i 24 | 25 | pTruncElim (A : U) (B : (pTrunc A) -> U) 26 | (pP : (x : pTrunc A) -> prop (B x)) 27 | (f : (a : A) -> B (inc a)) 28 | : (x : pTrunc A) -> B x = split 29 | inc a -> f a 30 | inh x y @ i -> 31 | lemPropF (pTrunc A) B pP x y 32 | ( inh{pTrunc A} x y @ j) 33 | (pTruncElim A B pP f x) 34 | (pTruncElim A B pP f y) 35 | @ i 36 | -------------------------------------------------------------------------------- /examples/retract.ctt: -------------------------------------------------------------------------------- 1 | -- Definition of retract and section 2 | module retract where 3 | 4 | import prelude 5 | 6 | section (A B : U) (f : A -> B) (g : B -> A) : U = (b : B) -> Path B (f (g b)) b 7 | 8 | retract (A B : U) (f : A -> B) (g : B -> A) : U = (a : A) -> Path A (g (f a)) a 9 | 10 | lemRetract (A B : U) (f : A -> B) (g : B -> A) (rfg : retract A B f g) (x y:A) : 11 | Path A (g (f x)) (g (f y)) -> Path A x y 12 | = compUp A (g (f x)) x (g (f y)) y (rfg x) (rfg y) 13 | 14 | retractProp (A B : U) (f : A -> B) (g : B -> A) (rfg : retract A B f g) (pB :prop B) (x y:A) 15 | : Path A x y = lemRetract A B f g rfg x y ( g (pB (f x) (f y) @ i)) 16 | 17 | retractInv (A B : U) (f : A -> B) (g : B -> A) (rfg : retract A B f g) 18 | (x y : A) (q: Path B (f x) (f y)) : Path A x y = 19 | compUp A (g (f x)) x (g (f y)) y (rfg x) (rfg y) ( (g (q @ i))) 20 | 21 | -- lemRSquare (A B : U) (f : A -> B) (g : B -> A) (rfg: retract A B f g)(x y:A) (p : Path A x y) : 22 | -- Square A (g (f x)) (g (f y)) ( g (f (p @ i))) x y 23 | -- (retractInv A B f g rfg x y ( f (p@ i))) (rfg x) (rfg y) = 24 | -- comp A (g (f (p @ j))) [(j=0) -> (rfg x) @ (i/\l), (j=1) -> (rfg y) @ (i/\l)] 25 | 26 | -- retractPath (A B : U)(f : A -> B) (g : B -> A) (rfg : retract A B f g) (x y :A) (p:Path A x y) : 27 | -- Path (Path A x y) (retractInv A B f g rfg x y ( f (p@ i))) p = 28 | -- comp A (g (f (p @ j))) [(j=0) -> rfg x,(j=1) -> rfg y, 29 | -- (i=0) -> (lemRSquare A B f g rfg x y p) @ j,(i=1) -> rfg (p @ j)] 30 | 31 | -- retractSet (A B : U) (f : A -> B) (g : B -> A) (rfg : retract A B f g) 32 | -- (sB : set B) (x y : A) : prop (Path A x y) = 33 | -- retractProp (Path A x y) (Path B (f x) (f y)) (mapOnPath A B f x y) 34 | -- (retractInv A B f g rfg x y) (retractPath A B f g rfg x y) (sB (f x) (f y)) 35 | 36 | -------------------------------------------------------------------------------- /examples/sigma.ctt: -------------------------------------------------------------------------------- 1 | -- Various results about sigma types. 2 | module sigma where 3 | 4 | import equiv 5 | 6 | lemPathSig (A:U) (B : A -> U) (t u : Sigma A B) : 7 | Path U (Path (Sigma A B) t u) ((p : Path A t.1 u.1) * PathP ( B (p @ i)) t.2 u.2) = 8 | isoPath T0 T1 f g s t where 9 | T0 : U = Path (Sigma A B) t u 10 | T1 : U = (p:Path A t.1 u.1) * PathP ( B (p@i)) t.2 u.2 11 | f (q:T0) : T1 = ( (q@i).1, (q@i).2) 12 | g (z:T1) : T0 = (z.1 @i,z.2 @i) 13 | s (z:T1) : Path T1 (f (g z)) z = refl T1 z 14 | t (q:T0) : Path T0 (g (f q)) q = refl T0 q 15 | 16 | lemPathAnd (A B : U) (t u : and A B) : 17 | Path U (Path (and A B) t u) (and (Path A t.1 u.1) (Path B t.2 u.2)) = lemPathSig A (\(_ : A) -> B) t u 18 | 19 | lemTransp (A:U) (a:A) : Path A a (transport (<_>A) a) = fill (<_>A) a [] 20 | 21 | funDepTr (A:U) (P:A->U) (a0 a1 :A) (p:Path A a0 a1) (u0:P a0) (u1:P a1) : 22 | Path U (PathP ( P (p@i)) u0 u1) (Path (P a1) (transport ( P (p@i)) u0) u1) = 23 | PathP (P (p@j\/i)) (comp (P (p@j/\i)) u0 [(j=0)-><_>u0]) u1 24 | 25 | lem2 (A:U) (B:A-> U) (t u : Sigma A B) (p:Path A t.1 u.1) : 26 | Path U (PathP (B (p@i)) t.2 u.2) (Path (B u.1) (transport (B (p@i)) t.2) u.2) = 27 | funDepTr A B t.1 u.1 p t.2 u.2 28 | 29 | corSigProp (A:U) (B:A-> U) (pB : (x:A) -> prop (B x)) (t u : Sigma A B) (p:Path A t.1 u.1) : 30 | prop (PathP (B (p@i)) t.2 u.2) = substInv U prop T0 T1 rem rem1 31 | where P : Path U (B t.1) (B u.1) = B (p@i) 32 | T0 : U = PathP P t.2 u.2 33 | T1 : U = Path (B u.1) (transport P t.2) u.2 34 | rem : Path U T0 T1 = lem2 A B t u p -- funDepTr (B t.1) (B u.1) P t.2 u.2 35 | v2 : B u.1 = transport P t.2 36 | rem1 : prop T1 = propSet (B u.1) (pB u.1) v2 u.2 37 | 38 | corSigSet (A:U) (B:A-> U) (sB : (x:A) -> set (B x)) (t u : Sigma A B) (p:Path A t.1 u.1) : 39 | prop (PathP (B (p@i)) t.2 u.2) = substInv U prop T0 T1 rem rem1 40 | where P : Path U (B t.1) (B u.1) = B (p@i) 41 | T0 : U = PathP P t.2 u.2 42 | T1 : U = Path (B u.1) (transport P t.2) u.2 43 | rem : Path U T0 T1 = lem2 A B t u p -- funDepTr (B t.1) (B u.1) P t.2 u.2 44 | v2 : B u.1 = transport P t.2 45 | rem1 : prop T1 = sB u.1 v2 u.2 46 | 47 | setSig (A:U) (B:A-> U) (sA: set A) (sB : (x:A) -> set (B x)) (t u : Sigma A B) : prop (Path (Sigma A B) t u) = 48 | substInv U prop (Path (Sigma A B) t u) ((p:T) * C p) rem3 rem2 49 | where 50 | T : U = Path A t.1 u.1 51 | C (p:T) : U = PathP ( B (p@i)) t.2 u.2 52 | rem (p : T) : prop (C p) = corSigSet A B sB t u p 53 | rem1 : prop T = sA t.1 u.1 54 | rem2 : prop ((p:T) * C p) = propSig T C rem1 rem 55 | rem3 : Path U (Path (Sigma A B) t u) ((p:T) * C p) = lemPathSig A B t u 56 | 57 | corSigGroupoid (A:U) (B:A-> U) (gB : (x:A) -> groupoid (B x)) (t u : Sigma A B) (p:Path A t.1 u.1) : 58 | set (PathP (B (p@i)) t.2 u.2) = substInv U set T0 T1 rem rem1 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 = lem2 A B t u p -- funDepTr (B t.1) (B u.1) P t.2 u.2 63 | v2 : B u.1 = transport P t.2 64 | rem1 : set T1 = gB u.1 v2 u.2 65 | 66 | groupoidSig (A:U) (B:A-> U) (gA: groupoid A) (gB : (x:A) -> groupoid (B x)) (t u : Sigma A B) : set (Path (Sigma A B) t u) = 67 | substInv U set (Path (Sigma A B) t u) ((p:T) * C p) rem3 rem2 68 | where 69 | T : U = Path A t.1 u.1 70 | C (p:T) : U = PathP ( B (p@i)) t.2 u.2 71 | rem (p : T) : set (C p) = corSigGroupoid A B gB t u p 72 | rem1 : set T = gA t.1 u.1 73 | rem2 : set ((p:T) * C p) = setSig T C rem1 rem 74 | rem3 : Path U (Path (Sigma A B) t u) ((p:T) * C p) = lemPathSig A B t u 75 | 76 | lemContr (A:U) (pA:prop A) (a:A) : isContr A = (a,rem) 77 | where rem (y:A) : Path A a y = pA a y 78 | 79 | lem3 (A:U) (B:A-> U) (pB : (x:A) -> prop (B x)) (t u : Sigma A B) (p:Path A t.1 u.1) : 80 | isContr (PathP (B (p@i)) t.2 u.2) = lemContr T0 (substInv U prop T0 T1 rem rem1) rem2 81 | where P : Path U (B t.1) (B u.1) = B (p@i) 82 | T0 : U = PathP P t.2 u.2 83 | T1 : U = Path (B u.1) (transport P t.2) u.2 84 | rem : Path U T0 T1 = lem2 A B t u p 85 | v2 : B u.1 = transport P t.2 86 | rem1 : prop T1 = propSet (B u.1) (pB u.1) v2 u.2 87 | rem2 : T0 = transport (rem@-i) (pB u.1 v2 u.2) 88 | 89 | 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 90 | where 91 | T : U = (x:A) * P x 92 | f (z:T) : A = z.1 93 | g (x:A) : T = (x,(cA x).1) 94 | s (z:T) : Path T (g (f z)) z = (z.1,((cA z.1).2 z.2)@ i) 95 | t (x:A) : Path A (f (g x)) x = refl A x 96 | 97 | lemSigProp (A:U) (B:A-> U) (pB : (x:A) -> prop (B x)) (t u : Sigma A B) : Path U (Path (Sigma A B) t u) (Path A t.1 u.1) = 98 | compPath 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 99 | where 100 | T : U = Path A t.1 u.1 101 | C (p:T) : U = PathP ( B (p@i)) t.2 u.2 102 | rem (p : T) : isContr (C p) = lem3 A B pB t u p 103 | rem1 : Path U ((p:T) * C p) T = lem6 T C rem 104 | rem2 : Path U (Path (Sigma A B) t u) ((p:T) * C p) = lemPathSig A B t u 105 | 106 | setGroupoid (A:U) (sA:set A) (a0 a1:A) : set (Path A a0 a1) = propSet (Path A a0 a1) (sA a0 a1) 107 | 108 | propGroupoid (A:U) (pA: prop A) : groupoid A = setGroupoid A (propSet A pA) 109 | -------------------------------------------------------------------------------- /examples/subset.ctt: -------------------------------------------------------------------------------- 1 | -- Two definitions of a subset and a proof that they are equal. 2 | module subset where 3 | 4 | import injective 5 | import sigma 6 | import univalence 7 | 8 | -- The first definition of a subset. Informally, there exists a second set B 9 | -- and an injective function from B to A. 10 | subset0 (A : U) (sA : set A) : U 11 | = (B : U) * (sB : set B) * (f : B -> A) * (inj1 B A f sB sA) 12 | 13 | -- The second definition of a subset. Informally, each element of A is tagged 14 | -- with a proposition indicating whether its included in the subset or not. 15 | subset1 (A : U) (sA : set A) : U 16 | = (a : A) -> (X : U) * (prop X) 17 | 18 | -- A map from the first to the second definition of subsets. 19 | subset01 (A : U) (sA : set A) : subset0 A sA -> subset1 A sA 20 | = \ (s : subset0 A sA) (a : A) -> let 21 | -- Take apart s 22 | B : U 23 | = s.1 24 | sB : set B 25 | = s.2.1 26 | f : B -> A 27 | = s.2.2.1 28 | i : inj1 B A f sB sA 29 | = s.2.2.2 30 | -- Construct a proposition to tag the element a with 31 | X : U 32 | = (b : B) * (Path A (f b) a) 33 | pX : prop X 34 | = i a 35 | in 36 | (X, pX) 37 | 38 | lem (A:U) (P:A->U) (pP:(x:A) -> prop (P x)) (u v:(x:A) * P x) (p:Path A u.1 v.1) : 39 | Path ((x:A)*P x) u v = (p@i,(lemPropF A P pP u.1 v.1 p u.2 v.2)@i) 40 | 41 | -- A map from the second to the first definition of subsets. 42 | subset10 (A : U) (sA : set A) 43 | : subset1 A sA -> subset0 A sA 44 | = \ (P : subset1 A sA) -> let 45 | -- Construct a predicate on A 46 | Q : (a : A) -> U 47 | = \ (a : A) -> (P a).1 48 | -- Tag each element of A with the predicate Q to construct B 49 | B : U 50 | = (a : A) * Q a 51 | -- Show that the predicate Q is a set (this follows from it being a 52 | -- proposition) 53 | sQ (a : A) : set (Q a) 54 | = propSet (Q a) (P a).2 55 | -- Using that A and Q are sets we show that B is a set as well. 56 | sB : set B 57 | = setSig A Q sA sQ 58 | -- Construct a map from B to A by taking the first projection of B. 59 | f : B -> A 60 | = \ (b : B) -> b.1 61 | -- Show that f is injective. 62 | inj : inj1 B A f sB sA 63 | = \ (a : A) (c d : (b : B) * Path A (f b) a) -> let 64 | p : Path A c.1.1 d.1.1 65 | = comp ( A) (c.2 @ i) [ (i = 0) -> c.1.1 66 | , (i = 1) -> d.2 @ -j ] 67 | q : Path B c.1 d.1 68 | = lem A Q (\ (x : A) -> (P x).2) c.1 d.1 p 69 | r : Path ((b : B) * Path A (f b) a) c d 70 | = lem B (\(b : B) -> Path A (f b) a) (\ (b : B) -> sA (f b) a) c d q 71 | in 72 | r 73 | in 74 | (B, sB, f, inj) 75 | 76 | opaque lemPropF 77 | opaque subst 78 | 79 | -- Show that subset10 ∘ subset01 can be identified with the identity function 80 | subsetIso0 (A : U) (sA : set A) : (s0 : subset0 A sA) -> 81 | Path (subset0 A sA) (subset10 A sA (subset01 A sA s0)) s0 82 | = \ (s0 : subset0 A sA) -> let 83 | s0' 84 | : subset0 A sA 85 | = subset10 A sA (subset01 A sA s0) 86 | -- Take apart s0 and s0' 87 | B : U 88 | = s0.1 89 | B' : U 90 | = s0'.1 91 | sB : set B 92 | = s0.2.1 93 | sB' : set B' 94 | = s0'.2.1 95 | f : B -> A 96 | = s0.2.2.1 97 | f' : B' -> A 98 | = s0'.2.2.1 99 | inj : inj1 B A f sB sA 100 | = s0.2.2.2 101 | inj' : inj1 B' A f' sB' sA 102 | = s0'.2.2.2 103 | -- Show that B' and B are equivalent 104 | g (b : B) : B' 105 | = (f b, b, f b) 106 | g' (b' : B') : B 107 | = b'.2.1 108 | s (x : B) : Path B (g' (g x)) x 109 | = x 110 | t (x : B') : Path B' (g (g' x)) x 111 | = (x.2.2 @ i, x.2.1, x.2.2 @ i /\ j) 112 | -- Compute a path between B' and B, as well as a path between f'∘g∘g' and f 113 | P (X : U) (h: X -> B) : U 114 | = (p : Path U X B) * (PathP ( p @ i -> A) (\ (x : X) -> f' (g (h x))) f) 115 | q : P B' g' 116 | = elimEquiv B P ( B, f) B' (g', isoToEquiv B' B g' g s t) 117 | idB : Path U B' B 118 | = q.1 119 | -- Show that sB can be identified with sB' 120 | idsB : PathP ( set (idB @ i)) sB' sB 121 | = lemPropF U set setIsProp B' B idB sB' sB 122 | -- Show that f' can be identified with f. This follows from g∘g' ⇔ \x -> x 123 | -- and that there is a path q.2 between f'∘g∘g' and f 124 | idf : PathP ( idB @ i -> A) f' f 125 | = let 126 | Q (h : B' -> B') : U 127 | = PathP ( q.1 @ i -> A) (\ (x : B') -> f' (h x)) f 128 | a : B' -> B' = \ (x : B') -> g (g' x) 129 | b : B' -> B' = \ (x : B') -> x 130 | p : Path (B' -> B') a b = \ (x : B') -> (t x) @ i 131 | in subst (B' -> B') Q a b p q.2 132 | -- Show that inj can be identified with inj' 133 | idinj : PathP ( inj1 (idB @ i) A (idf @ i) (idsB @ i) sA) inj' inj 134 | = let 135 | T : U 136 | = (X : U) * (_ : X -> A) * (set X) 137 | P : T -> U 138 | = \ (t : T) -> inj1 t.1 A t.2.1 t.2.2 sA 139 | pP : (t : T) -> prop (P t) 140 | = \ (t : T) -> prop_inj1 t.1 A t.2.1 t.2.2 sA 141 | t0 : T 142 | = (B', f', sB') 143 | t1 : T 144 | = (B, f, sB) 145 | idT : Path T t0 t1 146 | = (idB @ i, idf @ i, idsB @ i) 147 | in lemPropF T P pP t0 t1 idT inj' inj 148 | in 149 | (idB @ i, idsB @ i, idf @ i, idinj @ i) 150 | 151 | -- Show that subset10 ∘ subset01 can be identified with the identity function 152 | subsetIso1 (A : U) (sA : set A) : (s1 : subset1 A sA) -> 153 | Path (subset1 A sA) (subset01 A sA (subset10 A sA s1)) s1 154 | = \ (s1 : subset1 A sA) -> let 155 | -- Construct the second subset s1' from s1. 156 | s1' : subset1 A sA 157 | = subset01 A sA (subset10 A sA s1) 158 | -- Show that s1' and s1 produces the same result for all a : A 159 | ids1 : (a : A) -> Path ((X : U) * (prop X)) (s1' a) (s1 a) 160 | = \ (a : A) -> let 161 | -- Construct isomorphism between (s1' a).1 and (s1 a).1 to show that 162 | -- (s1' a).1 can be identified with (s1 a).1 163 | f : (s1' a).1 -> (s1 a).1 164 | = \ (x : (s1' a).1) -> subst A (\(a : A) -> (s1 a).1) x.1.1 a x.2 x.1.2 165 | g : (s1 a).1 -> (s1' a).1 166 | = \ (x : (s1 a).1) -> ((a, x), a) 167 | s : (x : (s1 a).1) -> Path (s1 a).1 (f (g x)) x 168 | = \ (x : (s1 a).1) -> (s1 a).2 (f (g x)) x 169 | t : (x : (s1' a).1) -> Path (s1' a).1 (g (f x)) x 170 | = \ (x : (s1' a).1) -> (s1' a).2 (g (f x)) x 171 | p : Path U (s1' a).1 (s1 a).1 172 | = isoPath (s1' a).1 (s1 a).1 f g s t 173 | -- Show that for x : prop (s1' a).1, y : prop (s1 a).1, 174 | -- x can be identified with y. 175 | q : PathP ( prop (p @ i)) (s1' a).2 (s1 a).2 176 | = lemPropF U prop propIsProp (s1' a).1 (s1 a).1 p (s1' a).2 (s1 a).2 177 | in 178 | (p @ i, q @ i) 179 | in 180 | funExt A (\ (_ : A) -> (X : U) * (prop X)) s1' s1 ids1 181 | 182 | -- Show that we can identify the two definitions of subsets with each other 183 | subsetPath (A : U) (sA : set A) : Path U (subset0 A sA) (subset1 A sA) 184 | = isoPath (subset0 A sA) (subset1 A sA) (subset01 A sA) (subset10 A sA) 185 | (subsetIso1 A sA) (subsetIso0 A sA) 186 | -------------------------------------------------------------------------------- /examples/summary.ctt: -------------------------------------------------------------------------------- 1 | -- This file contains a summary of the main results from the cubicaltt 2 | -- paper and where to find them in the examples folder. 3 | module summary where 4 | 5 | import univalence 6 | import idtypes 7 | 8 | {- The examples in section 3.1 and 3.2 can be found in prelude.ctt: 9 | 10 | refl (A : U) (a : A) : Path A a a = a 11 | 12 | inv (A : U) (a b : A) (p : Path A a b) : Path A b a = p @ -i 13 | 14 | mapOnPath (A B : U) (f : A -> B) (a b : A) 15 | (p : Path A a b) : Path B (f a) (f b) = f (p @ i) 16 | 17 | funExt (A : U) (B : A -> U) (f g : (x : A) -> B x) 18 | (p : (x : A) -> Path (B x) (f x) (g x)) : 19 | Path ((y : A) -> B y) f g = \(a : A) -> (p a) @ i 20 | 21 | contrSingl (A : U) (a b : A) (p : Path A a b) : 22 | Path (singl A a) (a,refl A a) (b,p) = (p @ i, p @ i/\j) 23 | 24 | 25 | -- Example 4 in section 4.3 can also be found in the prelude. Note 26 | -- that the j from comp^j is implicit in the implementation. 27 | 28 | compPath (A : U) (a b c : A) (p : Path A a b) (q : Path A b c) : Path A a c = 29 | comp ( A) (p @ i) [ (i=0) -> a, (i = 1) -> q ] 30 | 31 | -} 32 | 33 | -- A variation of the construction of an equivalence from a path in 34 | -- the universe from Section 7.1 has been formalized in 35 | -- equiv.ctt. This is an example of a "very cubical" proof. 36 | section71 (A B : U) (p : Path U A B) : equiv A B = 37 | transEquivDirect A B p 38 | 39 | 40 | -- The three proofs of univalence from section 7.2 and appendix B can 41 | -- all be found in the file univalence.ctt. 42 | 43 | -- Corollary 10 (theorem 9 is inlined in the proof) 44 | corollary10 (B : U) : isContr ((X : U) * equiv X B) = univalenceAlt B 45 | 46 | -- Corollary 11 47 | corollary11 (t : (A X : U) -> Path U X A -> equiv X A) (A : U) : 48 | (X : U) -> isEquiv (Path U X A) (equiv X A) (t A X) = thmUniv t A 49 | 50 | -- Corollary 26, proof 1: 51 | corollary26_1 (A B : U) : 52 | isEquiv (Path U A B) (equiv A B) (transEquiv A B) = 53 | transEquivIsEquiv A B 54 | 55 | -- Corollary 26, proof 2: 56 | corollary26_2 (A : U) : isContr ((B : U) * equiv A B) = 57 | univalenceAlt2 A 58 | 59 | 60 | -- The statement of univalence expressed only using the identity types 61 | -- from section 9.1 is proved in the file idtypes.ctt. 62 | section9_1 (A B : U) : equivId (Id U A B) (equivId A B) = 63 | univalenceId A B 64 | 65 | 66 | -- The implementation also has an experimental implementation of 67 | -- HITs. The two HITs from section 9.2 can be found in circle.ctt and 68 | -- propTrunc.ctt. 69 | -------------------------------------------------------------------------------- /examples/susp.ctt: -------------------------------------------------------------------------------- 1 | -- Suspension. Definition of the circle as the suspension of bool and 2 | -- a proof that this is equal to the standard HIT representation of 3 | -- the circle. 4 | module susp where 5 | 6 | import circle 7 | 8 | data susp (A : U) = north 9 | | south 10 | | merid (a : A) [ (i=0) -> north 11 | , (i=1) -> south ] 12 | 13 | -- n-spheres 14 | sphere : nat -> U = split 15 | zero -> bool 16 | suc n -> susp (sphere n) 17 | 18 | -- The circle (S1) is equal to the 1-sphere (aka the suspension of Bool). 19 | -- (Similar to HoTT Book, Lemma 6.5.1) 20 | sone : U = sphere one 21 | 22 | path : bool -> Path S1 base base = split 23 | false -> loop1 24 | true -> refl S1 base 25 | 26 | s1ToCircle : sone -> S1 = split 27 | north -> base 28 | south -> base 29 | merid b @ i -> path b @ i 30 | 31 | m0 : Path sone north south = merid{sone} false @ i 32 | 33 | m1 : Path sone north south = merid{sone} true @ i 34 | 35 | invm1 : Path sone south north = inv sone north south m1 36 | 37 | circleToS1 : S1 -> sone = split 38 | base -> north 39 | loop @ i -> compPath sone north south north m0 invm1 @ i 40 | 41 | merid1 (b:bool) : Path sone north south = merid{sone} b @ i 42 | 43 | co (x: sone) : sone = circleToS1 (s1ToCircle x) 44 | 45 | lemSquare (A:U) (a b : A) (m0 m1 : Path A a b) : 46 | Square A a a a b (compPath A a b a m0 (inv A a b m1)) m0 (refl A a) m1 = 47 | comp (<_>A) (m0 @ i) [(i=1) -> m1 @ (j \/ -k), 48 | (i=0) -> <_>a, 49 | (j=1) -> <_>m0@i, 50 | (j=0) -> comp (<_>A) (m0 @ i) [(k=0) -> <_>m0@i, (i=0) -> <_>a, (i=1) -> m1 @ (-k \/ -l)]] 51 | 52 | coid : (x : sone) -> Path sone (co x) x = split 53 | north -> refl sone north 54 | south -> m1 55 | merid b @ i -> ind b @ i 56 | where 57 | F (x:sone) : U = Path sone (co x) x 58 | 59 | ind : (b:bool) -> PathS sone F north south (merid1 b) (refl sone north) m1 = split 60 | false -> lemSquare sone north south m0 m1 61 | true -> m1 @ (j /\ k) 62 | 63 | oc (x:S1) : S1 = s1ToCircle (circleToS1 x) 64 | 65 | ocid : (x : S1) -> Path S1 (oc x) x = 66 | split 67 | base -> refl S1 base 68 | loop @ i -> comp (<_>S1) (loop1@i) [(i=0) -> <_>base,(i=1) -> <_>base,(j=1) -> <_>loop1@i, 69 | (j=0) -> comp (<_>S1) (loop1 @ i)[(k=0) -> <_>loop1@i,(i=0) -> <_>base,(i=1)-><_>base]] 70 | 71 | 72 | 73 | s1EqCircle : Path U sone S1 = isoPath sone S1 s1ToCircle circleToS1 ocid coid 74 | 75 | s1EqS1 : Path U S1 S1 = compPath U S1 sone S1 (inv U sone S1 s1EqCircle) s1EqCircle 76 | 77 | lem (A:U) (a:A) : Path A (comp (<_>A) (comp (<_>A) (comp (<_>A) a []) []) []) a = 78 | comp (<_>A) (comp (<_>A) (comp (<_>A) a [(i=1) -> <_>a]) [(i=1) -> <_>a]) [(i=1) -> <_>a] 79 | 80 | 81 | 82 | -- pointed sets 83 | 84 | ptU : U = (X : U) * X 85 | 86 | lemPt (A :U) (B:U) (p:Path U A B) (a:A) : Path ptU (A,a) (B,transport p a) = 87 | (p @ i,comp ( p @ (i/\j)) a [(i=0) -> <_>a]) 88 | 89 | Omega (X:ptU) : ptU = (Path X.1 X.2 X.2,refl X.1 X.2) 90 | 91 | lem (A:U) (a:A) : Path A (comp (<_>A) (comp (<_>A) (comp (<_>A) a []) []) []) a = 92 | comp (<_>A) (comp (<_>A) (comp (<_>A) a [(i=1) -> <_>a]) [(i=1) -> <_>a]) [(i=1) -> <_>a] 93 | 94 | lem1 (A:U) (a:A) : Path ptU (A,comp (<_>A) (comp (<_>A) (comp (<_>A) a []) []) []) (A,a) = 95 | (A,lem A a@i) 96 | 97 | -- s1PtCircle : Path ptU (sone,north) (S1,base) = 98 | -- compPath ptU (sone,north) (S1,comp (<_>S1) (comp (<_>S1) (comp (<_>S1) base []) []) []) (S1,base) (lemPt sone S1 s1EqCircle north) (lem1 S1 base) 99 | 100 | -- windingS : Path sone north north -> Z = rem1 101 | -- where 102 | -- G (X:ptU) : U = (Omega X).1 -> Z 103 | -- rem : G (S1,base) = winding 104 | -- rem1 : G (sone,north) = subst ptU G (S1,base) (sone,north) ( s1PtCircle @ -i) rem 105 | 106 | -- s1ToCPath (p: Path sone north north) : Path S1 base base = transport s1EqCircle (p @ i) 107 | 108 | -- s1ToCPathInv (p : Path S1 base base) : Path sone north north = (transport ( s1EqCircle @ -j) (p @ i)) 109 | 110 | loop1S : Path sone north north = compPath sone north south north m0 invm1 111 | 112 | loop2S : Path sone north north = compPath sone north north north loop1S loop1S 113 | 114 | -- test0S : Z = windingS (refl sone north) 115 | 116 | -- test2S : Z = windingS loop2S 117 | 118 | -- test4S : Z = windingS (compPath sone north north north loop2S loop2S) 119 | 120 | 121 | -- indSusp: 122 | 123 | 124 | suspOf (A X : U) : U = (u:X) * (v:X) * (A -> Path X u v) 125 | 126 | funToL (A X:U) (f:susp A -> X) : suspOf A X = 127 | (f north,f south,\ (a:A) -> f (merid{susp A} a@i)) 128 | 129 | lToFun (A X:U) (z:suspOf A X) : susp A -> X = split 130 | north -> z.1 131 | south -> z.2.1 132 | merid a @ i-> z.2.2 a @ i 133 | 134 | test1 (A X:U) (z:suspOf A X) : Path (suspOf A X) (funToL A X (lToFun A X z)) z 135 | = refl (suspOf A X) z 136 | 137 | rem (A X:U) (f:susp A ->X) : (u:susp A) -> Path X (lToFun A X (funToL A X f) u) (f u) = split 138 | north -> refl X (f north) 139 | south -> refl X (f south) 140 | merid a @ i -> refl X (f (merid{susp A} a @ i)) 141 | 142 | test2 (A X:U) (f:susp A ->X) : Path (susp A ->X) (lToFun A X (funToL A X f)) f 143 | = \ (u:susp A) -> rem A X f u @ i 144 | 145 | funSusp (A X:U) : Path U (susp A -> X) (suspOf A X) = 146 | isoPath (susp A -> X) (suspOf A X) (funToL A X) (lToFun A X) (test1 A X) (test2 A X) 147 | -------------------------------------------------------------------------------- /examples/torus.ctt: -------------------------------------------------------------------------------- 1 | -- Proof that Torus = S1 * S1 by Dan Licata. 2 | module torus where 3 | 4 | import sigma 5 | import circle 6 | 7 | data Torus = ptT 8 | | pathOneT [ (i=0) -> ptT, (i=1) -> ptT ] 9 | | pathTwoT [ (i=0) -> ptT, (i=1) -> ptT ] 10 | | squareT [ (i=0) -> pathOneT {Torus} @ j 11 | , (i=1) -> pathOneT {Torus} @ j 12 | , (j=0) -> pathTwoT {Torus} @ i 13 | , (j=1) -> pathTwoT {Torus} @ i ] 14 | 15 | -- Torus = S1 * S1 proof 16 | 17 | -- pathTwoT x 18 | -- ________________ 19 | -- | | 20 | -- pathOneT y | squareT x y | pathOneT y 21 | -- | | 22 | -- | | 23 | -- ________________ 24 | -- pathTwoT x 25 | 26 | -- pathOneT is (loop,refl) 27 | -- pathTwoT is (refl,loop) 28 | 29 | -- ---------------------------------------------------------------------- 30 | -- function from the torus to two circles 31 | 32 | t2c : Torus -> and S1 S1 = split 33 | ptT -> (base,base) 34 | pathOneT @ y -> (loop1 @ y, base) 35 | pathTwoT @ x -> (base, loop1 @ x) 36 | squareT @ x y -> (loop1 @ y, loop1 @ x) 37 | 38 | -- ---------------------------------------------------------------------- 39 | -- function from two circles to the torus 40 | 41 | -- branch for base 42 | c2t_base : S1 -> Torus = split 43 | base -> ptT 44 | loop @ x -> pathTwoT{Torus} @ x 45 | 46 | -- branch for loop 47 | c2t_loop' : (c : S1) -> PathP (<_>Torus) (c2t_base c) (c2t_base c) = split 48 | base -> < x > pathOneT{Torus} @ x 49 | loop @ y -> < x > squareT{Torus} @ y @ x 50 | 51 | -- use funext to exchange the interval variable and the S1 variable 52 | c2t_loop : PathP (<_>S1 -> Torus) c2t_base c2t_base = 53 | \(c : S1) -> c2t_loop' c @ y 54 | 55 | c2t' : S1 -> S1 -> Torus = split 56 | base -> c2t_base 57 | loop @ y -> c2t_loop @ y 58 | 59 | c2t (cs : and S1 S1) : Torus = c2t' cs.1 cs.2 60 | 61 | ------------------------------------------------------------------------ 62 | -- first composite: induct and reflexivity! 63 | 64 | t2c2t : (t : Torus) -> PathP (<_> Torus) (c2t (t2c t)) t = split 65 | ptT -> <_> ptT 66 | pathOneT @ y -> <_> pathOneT{Torus} @ y 67 | pathTwoT @ x -> <_> pathTwoT{Torus} @ x 68 | squareT @ x y -> <_> squareT{Torus} @ x @ y 69 | 70 | ------------------------------------------------------------------------ 71 | -- second composite: induct and reflexivity! 72 | -- except we need to use the same tricks as in c2t to do the inner 73 | -- induction 74 | 75 | c2t2c_base : (c2 : S1) -> PathP (<_> and S1 S1) (t2c (c2t_base c2)) (base,c2) = split 76 | base -> <_> (base,base) 77 | loop @ y -> <_> (base,loop1 @ y) 78 | 79 | -- the loop goal reduced using the defintional equalties, and with the 80 | -- two binders exchanged. 81 | -- c2t' (loop @ y) c2 = (c2t_loop @ y c2) = c2t_loop' c2 @ y 82 | c2t2c_loop' : (c2 : S1) -> 83 | PathP ( PathP (<_> and S1 S1) (t2c (c2t_loop @ y c2)) (loop1 @ y , c2)) 84 | (c2t2c_base c2) 85 | (c2t2c_base c2) = split 86 | base -> <_> (loop1 @ y, base) 87 | loop @ x -> <_> (loop1 @ y, loop1 @ x) 88 | 89 | c2t2c : (c1 : S1) (c2 : S1) -> PathP (<_> and S1 S1) (t2c (c2t' c1 c2)) (c1,c2) = split 90 | base -> c2t2c_base 91 | -- again, I shouldn't need to do funext here; 92 | -- I should be able to do a split inside of an interval binding 93 | loop @ y -> \(c : S1) -> c2t2c_loop' c @ y 94 | 95 | 96 | ------------------------------------------------------------------------ 97 | -- combine everything to get that Torus = S1 * S1 98 | 99 | S1S1equalsTorus : Path U (and S1 S1) Torus = isoPath (and S1 S1) Torus c2t t2c t2c2t rem 100 | where 101 | rem (c:and S1 S1) : Path (and S1 S1) (t2c (c2t c)) c = c2t2c c.1 c.2 102 | 103 | TorusEqualsS1S1 : Path U Torus (and S1 S1) = S1S1equalsTorus @ -i 104 | 105 | 106 | 107 | loopT : U = Path Torus ptT ptT 108 | 109 | -- funDep (A0 A1 :U) (p:Path U A0 A1) (u0:A0) (u1:A1) : 110 | -- Path U (Path A0 u0 (transport (p@-i) u1)) (Path A1 (transport p u0) u1) = 111 | -- Path (p @ i) (transport ( p @ (i/\l)) u0) (transport ( p @ (i\/-l)) u1) 112 | 113 | -- loopTorusEqualsZZ : Path U loopT (and Z Z) = comp U (rem @ i) [(i = 1) -> rem1] 114 | -- where 115 | -- rem : Path U loopT (Path (and S1 S1) (base,base) (base,base)) = 116 | -- funDep Torus (and S1 S1) TorusEqualsS1S1 ptT (base,base) 117 | 118 | -- rem1 : Path U (Path (and S1 S1) (base,base) (base,base)) (and Z Z) = 119 | -- comp U (lemPathAnd S1 S1 (base,base) (base,base) @ i) 120 | -- [(i = 1) -> and (loopS1equalsZ @ j) (loopS1equalsZ @ j)] 121 | -------------------------------------------------------------------------------- /experiments/andrew_puzzle.ctt: -------------------------------------------------------------------------------- 1 | -- Formalization of a puzzle posted by Andrew Polonsky in: 2 | -- https://groups.google.com/forum/#!topic/homotopytypetheory/ebUESBRBxVc 3 | module andrew_puzzle where 4 | 5 | Path (A : U) (a0 a1 : A) : U = PathP ( A) a0 a1 6 | 7 | mapOnPath (A B : U) (f : A -> B) (a b : A) 8 | (p : Path A a b) : Path B (f a) (f b) = f (p @ i) 9 | 10 | subst (A : U) (P : A -> U) (a b : A) (p : Path A a b) (e : P a) : P b = 11 | transport (mapOnPath A U P a b p) e 12 | 13 | 14 | data Bool = tt | ff 15 | data Unit = uu 16 | 17 | -- f, g : Bool -> Bool -> Bool 18 | -- f x y = if x then y else ff 19 | -- g x y = if y then x else ff 20 | f : Bool -> Bool -> Bool = split 21 | tt -> \(y : Bool) -> y 22 | ff -> \(_ : Bool) -> ff 23 | 24 | g (x : Bool) : Bool -> Bool = split 25 | tt -> x 26 | ff -> ff 27 | 28 | -- e : f = g 29 | e : Path (Bool -> Bool -> Bool) f g = 30 | let p : (x y : Bool) -> Path Bool (f x y) (g x y) = split 31 | tt -> split@((y : Bool) -> Path Bool (f tt y) (g tt y)) with 32 | tt -> <_> tt 33 | ff -> <_> ff 34 | ff -> split@((y : Bool) -> Path Bool (f ff y) (g ff y)) with 35 | tt -> <_> ff 36 | ff -> <_> ff 37 | in \(x y : Bool) -> p x y @ i 38 | 39 | 40 | -- Phi : Bool -> Type 41 | -- Phi tt = Bool 42 | -- Phi ff = Unit 43 | Phi : Bool -> U = split 44 | tt -> Bool 45 | ff -> Unit 46 | 47 | 48 | -- Psi : (Bool->Bool->Bool)->Type 49 | -- Psi = \u. (u tt tt) x (u tt ff) x (u ff tt) x (u ff ff) 50 | Prod (A B : U) : U = (_ : A) * B 51 | 52 | Psi : (Bool -> Bool -> Bool) -> U = 53 | \(u : Bool -> Bool -> Bool) -> Prod (Phi (u tt tt)) 54 | (Prod (Phi (u tt ff)) 55 | (Prod (Phi (u ff tt)) (Phi (u ff ff)))) 56 | 57 | -- X : Psi f 58 | -- X = (tt,*,*,*) 59 | X : Psi f = (tt,uu,uu,uu) 60 | 61 | -- Y : Psi g 62 | -- Y = subst Psi e X 63 | Y : Psi g = subst (Bool -> Bool -> Bool) Psi f g e X 64 | 65 | -- X and Y are definitionally equal: 66 | goal : Path (Psi f) X Y = <_> (tt,uu,uu,uu) 67 | -------------------------------------------------------------------------------- /experiments/deppath.ctt: -------------------------------------------------------------------------------- 1 | module deppath where 2 | 3 | import prelude 4 | 5 | funDepTr (A0 A1 :U) (p:Id U A0 A1) (u0:A0) (u1:A1) : 6 | Id U (IdP p u0 u1) (Id A1 (transport p u0) u1) = 7 | IdP ( p @ (i\/l)) (transport ( p @ (i/\l)) u0) u1 8 | 9 | funDepTrInv (A0 A1 :U) (p:Id U A0 A1) (u0:A0) (u1:A1) : 10 | Id U (Id A0 u0 (transport (p@-i) u1)) (IdP p u0 u1) = 11 | IdP ( p @ (i/\l)) u0 (transport ( p @ (i\/-l)) u1) 12 | 13 | funDep (A0 A1 :U) (p:Id U A0 A1) (u0:A0) (u1:A1) : 14 | Id U (Id A0 u0 (transport (p@-i) u1)) (Id A1 (transport p u0) u1) = 15 | Id (p @ i) (transport ( p @ (i/\l)) u0) (transport ( p @ (i\/-l)) u1) -------------------------------------------------------------------------------- /experiments/exchange.ctt: -------------------------------------------------------------------------------- 1 | module exchange where 2 | 3 | import susp 4 | 5 | r2 : loopS2 = refl S2 north 6 | 7 | Omega2 : U = Id loopS2 r2 r2 8 | 9 | test1 : Omega2 = 10 | comp S2 (merid {S2} (loop1@j)@i) 11 | [(i=1) -> merid{S2} base @-k, 12 | (j=0) -> merid{S2} base @(i/\-k), 13 | (j=1) -> merid{S2} base @(i/\-k)] 14 | 15 | compS2 (p q : loopS2) : loopS2 = compId S2 north north north p q 16 | 17 | -- horizontal and vertical composition 18 | 19 | hcomp (s t : Omega2) : Omega2 = comp S2 (s@i@j) [(i=1) -> t@k@j] 20 | vcomp (s t : Omega2) : Omega2 = comp S2 (s@i@j) [(j=1) -> t@i@k] 21 | 22 | -- constant square 23 | 24 | cs2 : Omega2 = refl loopS2 r2 25 | 26 | -- need to be generalized with squares 27 | 28 | Square (a0 a1 : S2) (u : Id S2 a0 a1) 29 | (b0 b1 : S2) (v : Id S2 b0 b1) 30 | (r0 : Id S2 a0 b0) (r1 : Id S2 a1 b1) : U 31 | = IdP ( (Id S2 (u @ i) (v @ i))) r0 r1 32 | 33 | squareS2 (a0 a1:S2) (q0:Id S2 north a0) (q1:Id S2 north a1) (p0:Id S2 a0 a1) : U = 34 | Square north a0 q0 north a1 q1 r2 p0 35 | 36 | sqS2 (u v:loopS2) : U = Square north north u north north v r2 r2 37 | 38 | -- horizontal and vertical composition 39 | 40 | vComp (a0 a1 a2:S2) (q0:Id S2 north a0) (q1:Id S2 north a1) (q2:Id S2 north a2) 41 | (p0:Id S2 a0 a1) (p1:Id S2 a1 a2) (s:squareS2 a0 a1 q0 q1 p0) (s1:squareS2 a1 a2 q1 q2 p1) : 42 | squareS2 a0 a2 q0 q2 (compId S2 a0 a1 a2 p0 p1) = 43 | comp S2 (s@i@j) [(j=1) -> s1@i@k] 44 | 45 | hComp (a0 a1:S2) (q0 : Id S2 north a0) (q1 : Id S2 north a1) (p0 : Id S2 a0 a1) (u0 u1:loopS2) 46 | (s : squareS2 a0 a1 q0 q1 p0) (t : sqS2 u0 u1) : 47 | squareS2 a0 a1 (compId S2 north north a0 u0 q0) (compId S2 north north a1 u1 q1) p0 = 48 | comp S2 (t@i@j) [(i=1) -> s@k@j] 49 | 50 | -- exchange lemma 51 | 52 | compN (a:S2) (p:Id S2 north a) (q:loopS2) : Id S2 north a = compId S2 north north a q p 53 | 54 | exLem (a0 a1 a2 : S2) (q0 : Id S2 north a0) (q1:Id S2 north a1) (q2 : Id S2 north a2) 55 | (p0 : Id S2 a0 a1) (p1: Id S2 a1 a2) (u0 u1 u2 : loopS2) 56 | (s : squareS2 a0 a1 q0 q1 p0) (s1 : squareS2 a1 a2 q1 q2 p1) 57 | (t : sqS2 u0 u1) (t1 : sqS2 u1 u2) : 58 | Id (squareS2 a0 a2 (compN a0 q0 u0) (compN a2 q2 u2) (compId S2 a0 a1 a2 p0 p1)) 59 | (vComp a0 a1 a2 (compN a0 q0 u0) (compN a1 q1 u1) (compN a2 q2 u2) p0 p1 60 | (hComp a0 a1 q0 q1 p0 u0 u1 s t) 61 | (hComp a1 a2 q1 q2 p1 u1 u2 s1 t1)) 62 | (hComp a0 a2 q0 q2 (compId S2 a0 a1 a2 p0 p1) u0 u2 63 | (vComp a0 a1 a2 q0 q1 q2 p0 p1 s s1) 64 | (vComp north north north u0 u1 u2 r2 r2 t t1)) = 65 | transport 66 | ( Id (squareS2 (q0@i) (q2@i) (compN (q0@i) (q0@i/\j) u0) (compN (q2@i) (q2@i/\j) u2) (compId S2 (q0@i) (q1@i) (q2@i) (s@i@k) (s1@i@k))) 67 | (vComp (q0@i) (q1@i) (q2@i) (compN (q0@i) (q0@i/\j) u0) (compN (q1@i) (q1@i/\j) u1) (compN (q2@i) (q2@i/\j) u2) (s@i@k) (s1@i@k) 68 | (hComp (q0@i) (q1@i) (q0@i/\j) (q1@i/\j) (s@i@k) u0 u1 (s@i/\j@k) t) 69 | (hComp (q1@i) (q2@i) (q1@i/\j) (q2@i/\j) (s1@i@k) u1 u2 (s1@i/\j@k) t1)) 70 | (hComp (q0@i) (q2@i) (q0@i/\j) (q2@i/\j) (compId S2 (q0@i) (q1@i) (q2@i) (s@i@k) (s1@i@k)) u0 u2 71 | (vComp (q0@i) (q1@i) (q2@i) (q0@i/\j) (q1@i/\j) (q2@i/\j) (s@i@k) (s1@i@k) (s@i/\j@k) (s1@i/\j@k)) 72 | (vComp north north north u0 u1 u2 r2 r2 t t1))) 73 | (refl (sqS2 u0 u2) (vComp north north north u0 u1 u2 r2 r2 t t1)) 74 | 75 | corExLem (t t1 s s1 : Omega2) : 76 | Id Omega2 (vcomp (hcomp t s) (hcomp t1 s1)) (hcomp (vcomp t t1) (vcomp s s1)) = 77 | exLem north north north r2 r2 r2 r2 r2 r2 r2 r2 s s1 t t1 78 | 79 | -- we should be able to deduce that vcomp t s = hcomp t s 80 | 81 | rR2 : Omega2 = refl loopS2 r2 82 | 83 | lemIdl (A:U) (a b:A) (p:Id A a b) : Id (Id A a b) (compId A a a b (refl A a) p) p = 84 | transport (Id (Id A a (p@i)) (compId A a a (p@i) (refl A a) (p@i/\j)) (p@i/\j)) 85 | (refl (Id A a a) (refl A a)) 86 | 87 | lemRV (s:Omega2) : Id Omega2 (vcomp rR2 s) s = lemIdl S2 north north (s@i)@k@j 88 | 89 | lemRH (s:Omega2) : Id Omega2 (hcomp rR2 s) s = lemIdl S2 north north (s@l@j)@k@i 90 | 91 | lem1 (s t:Omega2) : Id Omega2 (vcomp t s) (hcomp t s) = 92 | compId Omega2 (vcomp t s) (hcomp t (vcomp rR2 s)) (hcomp t s) 93 | (compId Omega2 (vcomp t s) (vcomp (hcomp t rR2) (hcomp rR2 s)) (hcomp t (vcomp rR2 s)) rem1 rem2) 94 | rem3 95 | where 96 | rem1 : Id Omega2 (vcomp t s) (vcomp (hcomp t rR2) (hcomp rR2 s)) = vcomp t (lemRH s@-i) 97 | rem2 : Id Omega2 (vcomp (hcomp t rR2) (hcomp rR2 s)) (hcomp t (vcomp rR2 s)) = corExLem t rR2 rR2 s 98 | rem3 : Id Omega2 (hcomp t (vcomp rR2 s)) (hcomp t s) = hcomp t (lemRV s@i) 99 | 100 | lemInv (A:U) (a b:A) (p:Id A a b) : Id (Id A a a) (compId A a b a p (p@-i)) (refl A a) = 101 | transport (Id (Id A a a) (compId A a (p@i) a (p@i/\j) (p@i/\-j)) (refl A a)) (refl (Id A a a) (refl A a)) 102 | 103 | g2 : Omega2 = test1 104 | invG2 : Omega2 = g2@i@-j 105 | 106 | -- lem2 : Id Omega2 (hcomp g2 invG2) rR2 = lemInv S2 north north (g2@l@j)@k@i 107 | 108 | lem3 : Id Omega2 (vcomp g2 invG2) rR2 = lemInv S2 north north (g2@i)@k@j 109 | -- compId Omega2 (vcomp g2 invG2) (hcomp h2 invG2) rR2 (lem1 g2 invG2) lem2 110 | 111 | lemInv1 (A:U) (a b:A) (p:Id A a b) : Id (Id A b b) (compId A b a b (p@-i) p) (refl A b) = 112 | transport (Id (Id A b b) (compId A b (p@-i) b (p@-i\/-j) (p@-i\/j)) (refl A b)) (refl (Id A b b) (refl A b)) 113 | 114 | lem4 : Id Omega2 (vcomp invG2 g2) rR2 = lemInv1 S2 north north (g2@i)@k@j 115 | 116 | -- commutativity 117 | 118 | lem5 (s t:Omega2) : Id Omega2 (vcomp t s) (vcomp s t) = 119 | compId Omega2 (vcomp t s) (vcomp (hcomp rR2 s) t) (vcomp s t) 120 | (compId Omega2 (vcomp t s) (hcomp (vcomp rR2 t) s) (vcomp (hcomp rR2 s) t) 121 | (compId Omega2 (vcomp t s) (hcomp t s) (hcomp (vcomp rR2 t) s) (lem1 s t) rem4) 122 | rem5) 123 | rem6 124 | where 125 | rem4 : Id Omega2 (hcomp t s) (hcomp (vcomp rR2 t) s) = hcomp (lemRV t@-i) s 126 | rem5 : Id Omega2 (hcomp (vcomp rR2 t) s) (vcomp (hcomp rR2 s) t) = corExLem rR2 t s rR2@-i 127 | rem6 : Id Omega2 (vcomp (hcomp rR2 s) t) (vcomp s t) = vcomp (lemRH s@i) t 128 | 129 | genPi3S2 : Id Omega2 rR2 rR2 = 130 | compId Omega2 rR2 (vcomp invG2 g2) rR2 (compId Omega2 rR2 (vcomp g2 invG2) (vcomp invG2 g2) rem1 rem2) lem4 131 | where 132 | rem1 : Id Omega2 rR2 (vcomp g2 invG2) = lem3@-i 133 | rem2 : Id Omega2 (vcomp g2 invG2) (vcomp invG2 g2) = lem5 invG2 g2 134 | 135 | 136 | -------------------------------------------------------------------------------- /experiments/girard.ctt: -------------------------------------------------------------------------------- 1 | module girard where 2 | 3 | {- 4 | Modified from: 5 | http://code.haskell.org/Agda/test/succeed/Hurkens.agda 6 | 7 | There are a number of long lambda expressions in this file. 8 | These are simply derived from the untyped lambda expressions in Hurkens' proof. 9 | But since cubicaltt expects explicit types, we have to insert them. 10 | Luckily cubicaltt can also compute them for us, and we can simply feed cubicaltt its own output. 11 | -} 12 | 13 | bot : U = (A : U) -> A 14 | 15 | neg (A : U) : U = A -> bot 16 | 17 | P (A : U) : U = A -> U 18 | 19 | Set : U = (X : U) -> (P (P X) -> X) -> P (P X) 20 | 21 | tau (t : P (P Set)) : Set = 22 | \(X : U) (f : P (P X) -> X) (p : X -> U) -> 23 | t (\(x : (X0 : U) -> (((X0 -> U) -> U) -> X0) -> ((X0 -> U) -> U)) -> p (f (x X f))) 24 | 25 | sigma (s : Set) : P (P Set) = s Set tau 26 | 27 | Delta : P Set = 28 | \(y : (X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> 29 | neg ((p : P Set) -> sigma y p -> p (tau (sigma y))) 30 | 31 | Omega : Set = 32 | tau (\(p : ((X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> U) -> 33 | (x : Set) -> sigma x p -> p x 34 | ) 35 | 36 | D : U = (p : P Set) -> sigma Omega p -> p (tau (sigma Omega)) 37 | 38 | lem1 (p : P Set) (H1 : (x : Set) -> sigma x p -> p x) : p Omega = H1 Omega (\(x : (X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> H1 (tau (sigma x))) 39 | 40 | lem2 : neg D = lem1 Delta (\(x : (X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) (H2 : x ((X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) (\(t : (((X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> U) -> U) -> \(X : U) -> \(f : ((X -> U) -> U) -> X) -> \(p : X -> U) -> t (\(x0 : (X0 : U) -> (((X0 -> U) -> U) -> X0) -> ((X0 -> U) -> U)) -> p (f (x0 X f)))) (\(y : (X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> ((p : ((X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> U) -> (y ((X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) (\(t : (((X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> U) -> U) -> \(X : U) -> \(f : ((X -> U) -> U) -> X) -> \(p0 : X -> U) -> t (\(x0 : (X0 : U) -> (((X0 -> U) -> U) -> X0) -> ((X0 -> U) -> U)) -> p0 (f (x0 X f)))) p) -> (p (\(X : U) -> \(f : ((X -> U) -> U) -> X) -> \(p0 : X -> U) -> y ((X0 : U) -> (((X0 -> U) -> U) -> X0) -> ((X0 -> U) -> U)) (\(t : (((X0 : U) -> (((X0 -> U) -> U) -> X0) -> ((X0 -> U) -> U)) -> U) -> U) -> \(X0 : U) -> \(f0 : ((X0 -> U) -> U) -> X0) -> \(p1 : X0 -> U) -> t (\(x0 : (X00 : U) -> (((X00 -> U) -> U) -> X00) -> ((X00 -> U) -> U)) -> p1 (f0 (x0 X0 f0)))) (\(x0 : (X0 : U) -> (((X0 -> U) -> U) -> X0) -> ((X0 -> U) -> U)) -> p0 (f (x0 X f)))))) -> ((A : U) -> A))) (H3 : (p : ((X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> U) -> (x ((X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) (\(t : (((X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> U) -> U) -> \(X : U) -> \(f : ((X -> U) -> U) -> X) -> \(p0 : X -> U) -> t (\(x0 : (X0 : U) -> (((X0 -> U) -> U) -> X0) -> ((X0 -> U) -> U)) -> p0 (f (x0 X f)))) p) -> (p (\(X : U) -> \(f : ((X -> U) -> U) -> X) -> \(p0 : X -> U) -> x ((X0 : U) -> (((X0 -> U) -> U) -> X0) -> ((X0 -> U) -> U)) (\(t : (((X0 : U) -> (((X0 -> U) -> U) -> X0) -> ((X0 -> U) -> U)) -> U) -> U) -> \(X0 : U) -> \(f0 : ((X0 -> U) -> U) -> X0) -> \(p1 : X0 -> U) -> t (\(x0 : (X00 : U) -> (((X00 -> U) -> U) -> X00) -> ((X00 -> U) -> U)) -> p1 (f0 (x0 X0 f0)))) (\(x0 : (X0 : U) -> (((X0 -> U) -> U) -> X0) -> ((X0 -> U) -> U)) -> p0 (f (x0 X f)))))) -> H3 Delta H2 (\(p : ((X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> U) -> H3 (\(y : (X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> p (tau (sigma y))))) 41 | 42 | lem3 : D = \(p : ((X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> U) -> lem1 (\(y : (X : U) -> (((X -> U) -> U) -> X) -> ((X -> U) -> U)) -> p (tau (sigma y))) 43 | 44 | -- Evaluating "loop" results in a nonterminating computation. 45 | loop : bot = lem2 lem3 46 | -------------------------------------------------------------------------------- /experiments/helix.ctt: -------------------------------------------------------------------------------- 1 | module helix where 2 | 3 | import circle 4 | import equiv 5 | 6 | encode (x:S1) (p:Id S1 base x) : helix x = subst S1 helix base x p zeroZ 7 | 8 | itLoop : nat -> loopS1 = split 9 | zero -> triv 10 | suc n -> compS1 (itLoop n) loop1 11 | 12 | itLoopNeg : nat -> loopS1 = split 13 | zero -> invLoop 14 | suc n -> compS1 (itLoopNeg n) invLoop 15 | 16 | loopIt : Z -> loopS1 = split 17 | inl n -> itLoopNeg n 18 | inr n -> itLoop n 19 | 20 | lemItNat (n:nat) : Id loopS1 (itLoop (suc n)) (transport (Id S1 base (loop{S1} @ i)) (itLoop n)) = 21 | refl loopS1 (itLoop (suc n)) 22 | 23 | lemItNeg : (n:nat) -> Id loopS1 (transport (Id S1 base (loop{S1} @ i)) (loopIt (inl n))) (loopIt (sucZ (inl n))) = split 24 | zero -> lemInv S1 base base loop1 25 | suc n -> lemCompInv S1 base base base (itLoopNeg n) invLoop 26 | 27 | oneTurn (l: loopS1) : loopS1 = transport (Id S1 base (loop{S1} @ i)) l 28 | 29 | lemItPos : (n:nat) -> Id loopS1 (oneTurn (loopIt (predZ (inr n)))) (loopIt (inr n)) = split 30 | zero -> lemInv S1 base base loop1 31 | suc n -> refl loopS1 (loopIt (inr (suc n))) 32 | 33 | lemItNeg (n:nat) : Id loopS1 (oneTurn (loopIt (predZ (inl n)))) (loopIt (inl n)) = 34 | lemCompInv S1 base base base (loopIt (inl n)) invLoop 35 | 36 | lemIt : (n:Z) -> Id loopS1 (oneTurn (loopIt (predZ n))) (loopIt n) = split 37 | inl n -> lemItNeg n 38 | inr n -> lemItPos n 39 | 40 | funDepTr (A0 A1:U) (p:Id U A0 A1) (u0:A0) (u1:A1) : 41 | Id U (IdP p u0 u1) (Id A1 (transport p u0) u1) = 42 | IdP (p @ (i\/l)) (transport (p @ (i/\l)) u0) u1 43 | 44 | decode : (x:S1) -> helix x -> Id S1 base x = split 45 | base -> loopIt 46 | loop @ i -> rem @ i 47 | where T : U = Z -> loopS1 48 | p : Id U T T = helix (loop{S1}@j) -> Id S1 base (loop{S1}@j) 49 | rem1 : Id (Z -> loopS1) (transport p loopIt) loopIt = \ (n:Z) -> (lemIt n)@j 50 | rem : IdP p loopIt loopIt = transport ( (funDepTr T T p loopIt loopIt)@-j) rem1 51 | 52 | encodeDecode : (c : S1) (p : Id S1 base c) -> Id (Id S1 base c) (decode c (encode c p)) p = 53 | J S1 base (\ (c : S1) (p : Id S1 base c) -> Id (Id S1 base c) (decode c (encode c p)) p) 54 | (<_> (<_> base)) 55 | 56 | decodeEncodeBaseNeg : (n : nat) -> Id Z (transport ( helix (itLoopNeg n @ x)) (inr zero)) (inl n) = split 57 | zero -> <_> inl zero 58 | suc n -> predZ (decodeEncodeBaseNeg n @ x) 59 | 60 | decodeEncodeBaseNonneg : (n : nat) -> Id Z (transport ( helix (itLoop n @ x)) (inr zero)) (inr n) = split 61 | zero -> <_> inr zero 62 | suc n -> ( sucZ ( decodeEncodeBaseNonneg n @ x)) 63 | 64 | decodeEncodeBase : (n : Z) -> Id Z (encode base (decode base n)) n = split 65 | inl n -> decodeEncodeBaseNeg n 66 | inr n -> decodeEncodeBaseNonneg n 67 | 68 | loopS1equalsZ : Id U loopS1 Z = 69 | isoId loopS1 Z (encode base) (decode base) decodeEncodeBase (encodeDecode base) 70 | 71 | setLoop : set loopS1 = substInv U set loopS1 Z loopS1equalsZ ZSet 72 | 73 | lemPropFib (P:S1 -> U) (pP:(x:S1) -> prop (P x)) (bP: P base) : (x:S1) -> P x = split 74 | base -> bP 75 | loop @ i -> (lemPropF S1 P pP base base loop1 bP bP) @ i 76 | 77 | -- S1 is a groupoid 78 | isGroupoidS1 : groupoid S1 = lem 79 | where 80 | lem2 : (y : S1) -> set (Id S1 base y) 81 | = lemPropFib (\ (y:S1) -> set (Id S1 base y)) (\ (y:S1) -> setIsProp (Id S1 base y)) setLoop 82 | 83 | lem : (x y : S1) -> set (Id S1 x y) 84 | = lemPropFib (\ (x:S1) -> (y : S1) -> set (Id S1 x y)) pP lem2 85 | where 86 | pP (x:S1) : prop ((y:S1) -> set (Id S1 x y)) = 87 | propPi S1 (\ (y:S1) -> set (Id S1 x y)) (\ (y:S1) -> setIsProp (Id S1 x y)) 88 | 89 | substInv (A : U) (P : A -> U) (a x : A) (p : Id A a x) : P x -> P a = 90 | subst A P x a (p @ -i) 91 | 92 | lemSetTorus (E : S1 -> S1 -> U) (sE : set (E base base)) 93 | (f : (y:S1) -> E base y) (g : (x:S1) -> E x base) 94 | (efg : Id (E base base) (f base) (g base)) : (x y:S1) -> E x y = split 95 | base -> f 96 | loop @ i -> lem2 @ i 97 | where 98 | F (x:S1) : U = (y:S1) -> E x y 99 | 100 | G (y x:S1) : U = E x y 101 | 102 | lem1 : (y:S1) -> IdS S1 (G y) base base loop1 (f y) (f y) = lemPropFib P pP bP 103 | where 104 | P (y:S1) : U = IdS S1 (G y) base base loop1 (f y) (f y) 105 | 106 | sbE : (y : S1) -> set (E base y) 107 | = lemPropFib (\ (y:S1) -> set (E base y)) (\ (y:S1) -> setIsProp (E base y)) sE 108 | 109 | pP (y:S1) : prop (P y) = rem3 110 | where 111 | rem1 : Id U (P y) (Id (E base y) (subst S1 (G y) base base loop1 (f y)) (f y)) 112 | = funDepTr (G y base) (G y base) (G y (loop{S1} @ j)) (f y) (f y) 113 | 114 | rem2 : prop (Id (E base y) (subst S1 (G y) base base loop1 (f y)) (f y)) 115 | = sbE y (subst S1 (G y) base base loop1 (f y)) (f y) 116 | 117 | rem3 : prop (P y) 118 | = substInv U prop (P y) (Id (E base y) (subst S1 (G y) base base loop1 (f y)) (f y)) rem1 rem2 119 | 120 | lem2 : IdS S1 (G base) base base loop1 (g base) (g base) 121 | = g (loop1 @ j) 122 | 123 | bP : P base 124 | = substInv (E base base) (\ (u:E base base) -> IdS S1 (G base) base base loop1 u u) (f base) (g base) efg lem2 125 | 126 | lem2 : IdS S1 F base base loop1 f f = \ (y:S1) -> (lem1 y) @ j 127 | 128 | -- commutativity of mult, at last 129 | 130 | idL : (x : S1) -> Id S1 (mult base x) x = split 131 | base -> refl S1 base 132 | loop @ i -> loop1 @ i 133 | 134 | multCom : (x y : S1) -> Id S1 (mult x y) (mult y x) = 135 | lemSetTorus E sE idL g efg 136 | where 137 | E (x y: S1) : U = Id S1 (mult x y) (mult y x) 138 | sE : set (E base base) = isGroupoidS1 base base 139 | g (x : S1) : E x base = inv S1 (mult base x) (mult x base) (idL x) 140 | efg : Id (E base base) (idL base) (g base) = refl (E base base) (idL base) 141 | 142 | -- associativity 143 | 144 | multAssoc (x :S1) : (y z : S1) -> Id S1 (mult x (mult y z)) (mult (mult x y) z) = 145 | lemSetTorus E sE f g efg 146 | where 147 | E (y z : S1) : U = Id S1 (mult x (mult y z)) (mult (mult x y) z) 148 | sE : set (E base base) = isGroupoidS1 x x 149 | f (z : S1) : E base z = rem 150 | where 151 | rem1 : Id S1 (mult base z) z = multCom base z 152 | 153 | rem : Id S1 (mult x (mult base z)) (mult x z) = mult x (rem1 @ i) 154 | g (y : S1) : E y base = refl S1 (mult x y) 155 | efg : Id (E base base) (f base) (g base) = refl (E base base) (f base) 156 | 157 | -- inverse law 158 | 159 | lemPropRel (P:S1 -> S1 -> U) (pP:(x y:S1) -> prop (P x y)) (bP:P base base) : (x y:S1) -> P x y = 160 | lemPropFib (\ (x:S1) -> (y:S1) -> P x y) 161 | (\ (x:S1) -> propPi S1 (P x) (pP x)) 162 | (lemPropFib (P base) (pP base) bP) 163 | 164 | invLaw : (x y : S1) -> 165 | Id (Id S1 (mult x y) (mult x y)) (refl S1 (mult x y)) 166 | (compId S1 (mult x y) (mult y x) (mult x y) (multCom x y) (multCom y x)) = lemPropRel P pP bP 167 | where 168 | P (x y : S1) : U 169 | = Id (Id S1 (mult x y) (mult x y)) (refl S1 (mult x y)) 170 | (compId S1 (mult x y) (mult y x) (mult x y) (multCom x y) (multCom y x)) 171 | 172 | pP (x y : S1) : prop (P x y) = 173 | isGroupoidS1 (mult x y) (mult x y) (refl S1 (mult x y)) 174 | (compId S1 (mult x y) (mult y x) (mult x y) (multCom x y) (multCom y x)) 175 | 176 | bP : P base base = refl (Id S1 base base) (refl S1 base) 177 | 178 | 179 | -- the multiplication is invertible 180 | 181 | multIsEquiv : (x:S1) -> isEquiv S1 S1 (mult x) = lemPropFib P pP bP 182 | where P (x:S1) : U = isEquiv S1 S1 (mult x) 183 | pP (x:S1) : prop (P x) = propIsEquiv S1 S1 (mult x) 184 | rem : Id (S1 -> S1) (idfun S1) (mult base) = \ (x:S1) -> idL x @ -i 185 | bP : P base = subst (S1->S1) (isEquiv S1 S1) (idfun S1) (mult base) rem (idIsEquiv S1) 186 | 187 | -- inverse of multiplication by x 188 | 189 | invMult (x y:S1) : S1 = (multIsEquiv x y).2.1 190 | 191 | invS1 (x:S1) : S1 = invMult x base 192 | 193 | test2 : Z = winding (invS1 (loop2@i)) 194 | test4 : Z = winding (invS1 (compS1 loop2 loop2 @i)) 195 | 196 | test0 : Z = winding (invMult (loop2@i) (loop2@i)) 197 | 198 | 199 | -- helixSet : (x:S1) -> set (helix x) = lemPropFib (\ (x:S1) -> set (helix x)) rem ZSet 200 | -- where rem (x:S1) : prop (set (helix x)) = setIsProp (helix x) 201 | 202 | -- retHelix (x:S1) (p : Id S1 base x) : Id (Id S1 base x) (decode x (encode x p)) p = 203 | -- transport (Id (Id S1 base (p@i)) (decode (p@i) (encode (p@i) (p@(i/\j)))) (p@(i/\j))) (refl loopS1 triv) 204 | 205 | -- Alternative proof that loopS1 is a set (requires retract.ctt): 206 | -- setLoop' : set loopS1 = retractSet loopS1 Z (encode base) (decode base) (retHelix base) ZSet 207 | -------------------------------------------------------------------------------- /experiments/hopf.ctt: -------------------------------------------------------------------------------- 1 | module hopf where 2 | 3 | import truncS2 4 | import mult 5 | import pointed 6 | import join 7 | 8 | hopf : S2 -> U = split 9 | north -> S1 10 | south -> S1 11 | merid x @ i -> eqS1 x @ i 12 | 13 | funExt1 (C B : U) (F : C -> U) (a :C) : (b : C) (p : Id C a b) 14 | (f : F a -> B) (g : F b -> B) 15 | (h : (x : F a) -> Id B (f x) (g (subst C F a b p x))) 16 | -> IdS C (\ (z:C) -> F z -> B) a b p f g = 17 | J C a (\ (b:C) (p:Id C a b) -> (f : F a -> B) (g : F b -> B) 18 | (h : (x : F a) -> Id B (f x) (g (subst C F a b p x))) 19 | -> IdS C (\ (z:C) -> F z -> B) a b p f g) rem 20 | where rem (f g : F a -> B) (h : (x : F a) -> Id B (f x) (g x)) : Id (F a -> B) f g = 21 | \(x:F a) -> h x @ i 22 | 23 | t : (x : S2) -> hopf x -> join S1 S1 = split 24 | north -> \ (a:S1) -> inl a 25 | south -> \ (a:S1) -> inr a 26 | merid x @ i -> funExt1 S2 (join S1 S1) hopf north south (merid{S2} x@j) (\ (y:S1) -> inl y) (\ (y:S1) -> inr y) 27 | (\ (y:S1) -> pushC{join S1 S1} y (mult x y)@j) @ i 28 | 29 | totalHopfToJoin (xy:(x : S2) * hopf x) : join S1 S1 = t xy.1 xy.2 30 | 31 | one : nat = suc zero 32 | two : nat = suc one 33 | three : nat = suc two 34 | 35 | S3 : U = susp S2 36 | ptS3 : ptType = (S3,north) 37 | ptS2 : ptType = (S2,north) 38 | ptS1 : ptType = (S1,base) 39 | 40 | hopfOne : (itOmega one ptS2).1 -> U = itFibOmega one ptS2 hopf base 41 | 42 | hopfTwo : (itOmega two ptS2).1 -> U = itFibOmega two ptS2 hopf base 43 | 44 | hopfThree : (itOmega three ptS2).1 -> U = itFibOmega three ptS2 hopf base 45 | 46 | ptJoin (pA:ptType) (B:U) : ptType = (join pA.1 B, inl (pt pA)) 47 | 48 | fibContrHopfThree (p : (itOmega three ptS2).1) : hopfThree p = 49 | truncFibOmega (itOmega two ptS2) hopfTwo (refl (Id S1 base base) (refl S1 base)) zero 50 | (truncFibOmega (Omega ptS2) hopfOne (refl S1 base) one 51 | (truncFibOmega ptS2 hopf base two isGroupoidS1 (refl S2 north)) 52 | (refl (Omega ptS2).1 (pt (Omega ptS2)))) p 53 | 54 | 55 | -- The map h from 9.3 56 | hopfLoop (p : (itOmega three ptS2).1) : (itOmega three (ptJoin ptS1 S1)).1 = 57 | itMapOmegaRefl three (Sigma S2 hopf, (north,base)) (join S1 S1) totalHopfToJoin 58 | (itTotalFibOmega three ptS2 hopf base (p, fibContrHopfThree p)) 59 | 60 | 61 | -------------------------------------------------------------------------------- /experiments/implicit_point.ctt: -------------------------------------------------------------------------------- 1 | module implicit_point where 2 | 3 | import equiv 4 | 5 | data NoPoints = 6 | p [] 7 | 8 | propNoPoints : prop NoPoints = split 9 | p @ i -> let rem : (b : NoPoints) -> Path NoPoints (p{NoPoints} @ i) b = split 10 | p @ j -> p{NoPoints} @ (i /\ -k) \/ (j /\ k) 11 | in rem 12 | 13 | point0 : NoPoints = p{NoPoints} @ 0 14 | point1 : NoPoints = p{NoPoints} @ 1 15 | 16 | p' : Path NoPoints point0 point1 = p{NoPoints} @ i 17 | 18 | f1 : NoPoints -> Unit = split 19 | p @ i -> tt 20 | 21 | f2 : Unit -> NoPoints = split 22 | tt -> point0 23 | 24 | test : Path U NoPoints Unit = 25 | isoPath NoPoints Unit f1 f2 rem1 rem2 26 | where 27 | rem1 : (y : Unit) -> Path Unit (f1 (f2 y)) y = split 28 | tt -> tt 29 | rem2 : (x : NoPoints) -> Path NoPoints (f2 (f1 x)) x = split 30 | p @ i -> p{NoPoints} @ j /\ i 31 | 32 | fext (A B : U) (f g : A -> B) (h : (x : A) -> Path B (f x) (g x)) : 33 | Path (A -> B) f g = (\(x : A) -> htpy x (p{NoPoints} @ j)) 34 | where htpy (x : A) : NoPoints -> B = split 35 | p @ i -> h x @ i 36 | -------------------------------------------------------------------------------- /experiments/isoToEquiv.ctt: -------------------------------------------------------------------------------- 1 | -- This file contains a proof of the isoToId using the old version of 2 | -- equivalence 3 | module isoToEquiv where 4 | 5 | import equiv 6 | 7 | lemIso (A B : U) (f : A -> B) (g : B -> A) 8 | (s : (y : B) -> Id B (f (g y)) y) 9 | (t : (x : A) -> Id A (g (f x)) x) 10 | (y : B) (x0 x1 : A) (p0 : Id B (f x0) y) (p1 : Id B (f x1) y) : 11 | Id (fiber A B f y) (x0,p0) (x1,p1) = (p @ i,sq1 @ i) 12 | where 13 | rem0 : Id A x0 (g y) = 14 | comp (<_> A) (g (p0 @ i)) [ (i = 0) -> t x0, (i = 1) -> <_> g y ] 15 | 16 | rem1 : Id A x1 (g y) = 17 | comp (<_> A) (g (p1 @ i)) [ (i = 0) -> t x1, (i = 1) -> <_> g y ] 18 | 19 | p : Id A x0 x1 = 20 | comp (<_> A) (g y) [ (i = 0) -> rem0 @ -j 21 | , (i = 1) -> rem1 @ -j ] 22 | 23 | 24 | fill0 : Square A (g (f x0)) (g y) x0 (g y) 25 | ( g (p0 @ i)) rem0 (t x0) ( g y) = 26 | comp (<_> A) (g (p0 @ i)) [ (i = 0) -> t x0 @ j /\ k 27 | , (i = 1) -> <_> g y 28 | , (j = 0) -> <_> g (p0 @ i) ] 29 | 30 | fill1 : Square A (g (f x1)) (g y) x1 (g y) 31 | ( g (p1 @ i)) rem1 (t x1) ( g y) = 32 | comp (<_> A) (g (p1 @ i)) [ (i = 0) -> t x1 @ j /\ k 33 | , (i = 1) -> <_> g y 34 | , (j = 0) -> <_> g (p1 @ i) ] 35 | 36 | fill2 : Square A x0 x1 (g y) (g y) 37 | p (<_> g y) rem0 rem1 = 38 | comp (<_> A) (g y) [ (i = 0) -> rem0 @ j \/ -k 39 | , (i = 1) -> rem1 @ j \/ -k 40 | , (j = 1) -> <_> g y ] 41 | 42 | sq : Square A (g (f x0)) (g (f x1)) (g y) (g y) 43 | ( g (f (p @ i))) ( g y) 44 | ( g (p0 @ j)) ( g (p1 @ j)) = 45 | comp (<_> A) (fill2 @ i @ j) [ (i = 0) -> fill0 @ j @ -k 46 | , (i = 1) -> fill1 @ j @ -k 47 | , (j = 1) -> <_> g y 48 | , (j = 0) -> t (p @ i) @ -k ] 49 | 50 | sq1 : Square B (f x0) (f x1) y y 51 | ( f (p @ i)) (<_> y) p0 p1 = 52 | comp (<_> B) (f (sq @ i @j)) [ (i = 0) -> s (p0 @ j) 53 | , (i = 1) -> s (p1 @ j) 54 | , (j = 0) -> s (f (p @ i)) 55 | , (j = 1) -> s y ] 56 | 57 | isoToEquiv (A B : U) (f : A -> B) (g : B -> A) 58 | (s : (y : B) -> Id B (f (g y)) y) 59 | (t : (x : A) -> Id A (g (f x)) x) : isEquiv A B f = (fCenter,fIsCenter) 60 | where 61 | fCenter (y : B) : fiber A B f y = (g y,s y) 62 | fIsCenter (y : B) (w : fiber A B f y) : Id (fiber A B f y) (fCenter y) w = 63 | lemIso A B f g s t y (fCenter y).1 w.1 (fCenter y).2 w.2 64 | 65 | 66 | -- OLD CODE: 67 | -- lemIso with equalities on other direction: 68 | -- lemIso (A B : U) (f : A -> B) (g : B -> A) 69 | -- (s : (y:B) -> Id B (f (g y)) y) 70 | -- (t : (x:A) -> Id A (g (f x)) x) 71 | -- (y:B) (x0 x1:A) (p0 : Id B y (f x0)) (p1 : Id B y (f x1)) : 72 | -- Id ((x:A) * Id B y (f x)) (x0,p0) (x1,p1) = (p @ i, sq1 @ i) 73 | -- where 74 | -- rem0 : Id A (g y) x0 = 75 | -- comp (<_> A) (g (p0 @ i)) [ (i = 0) -> <_> g y, (i = 1) -> t x0 ] 76 | -- rem1 : Id A (g y) x1 = 77 | -- comp (<_> A) (g (p1 @ i)) [ (i = 0) -> <_> g y, (i = 1) -> t x1 ] 78 | -- p : Id A x0 x1 = comp (<_> A) (g y) [ (i = 0) -> rem0, (i = 1) -> rem1 ] 79 | 80 | -- fill0 : Square A (g y) (g (f x0)) ( g (p0 @ i)) (g y) x0 rem0 ( g y) (t x0) = 81 | -- comp (<_> A) (g (p0@i)) [ (i = 0) -> <_> g y 82 | -- , (i = 1) -> t x0 @ j /\ k 83 | -- , (j = 0) -> <_> g (p0 @ i) ] 84 | 85 | -- fill1 : Square A (g y) (g (f x1)) ( g (p1 @ i)) (g y) x1 rem1 ( g y) (t x1) = 86 | -- comp (<_> A) (g (p1@i)) [ (i = 0) -> <_> g y 87 | -- , (i = 1) -> t x1 @ j /\ k 88 | -- , (j = 0) -> <_> g (p1 @ i) ] 89 | 90 | -- fill2 : Square A (g y) (g y) (<_> g y) x0 x1 p rem0 rem1 = 91 | -- comp (<_> A) (g y) [ (i = 0) -> rem0 @ j /\ k 92 | -- , (i = 1) -> rem1 @ j /\ k 93 | -- , (j = 0) -> <_> g y ] 94 | 95 | -- sq : Square A (g y) (g y) (<_> g y) (g (f x0)) (g (f x1)) ( g (f (p @ i))) 96 | -- ( g (p0 @ i)) ( g (p1 @ i)) = 97 | -- comp (<_> A) (fill2 @ i @ j) [ (i = 0) -> fill0 @ j @ -k 98 | -- , (i = 1) -> fill1 @ j @ -k 99 | -- , (j = 0) -> <_> g y 100 | -- , (j = 1) -> t (p @ i) @ -k ] 101 | 102 | -- sq1 : Square B y y (<_> y) (f x0) (f x1) ( f (p @ i)) p0 p1 = 103 | -- comp (<_> B) (f (sq @ i @j)) [ (i = 0) -> s (p0 @ j) 104 | -- , (i = 1) -> s (p1 @ j) 105 | -- , (j = 0) -> s y 106 | -- , (j = 1) -> s (f (p @ i)) ] 107 | 108 | -- -- special case 109 | 110 | -- corrIso (A B : U) (f : A -> B) (g : B -> A) 111 | -- (s : (y:B) -> Id B (f (g y)) y) 112 | -- (t : (x:A) -> Id A (g (f x)) x) 113 | -- (x0:A) : 114 | -- Id ((x:A) * Id B (f x0) (f x)) (x0,refl B (f x0)) (g (f x0),((s (f x0))@-i)) = 115 | -- lemIso A B f g s t (f x0) x0 (g (f x0)) (refl B (f x0)) (((s (f x0))@-i)) 116 | -------------------------------------------------------------------------------- /experiments/join.ctt: -------------------------------------------------------------------------------- 1 | module join where 2 | 3 | import susp 4 | 5 | data join (A B:U) = inl (a:A) | inr (b:B) | pushC (a:A) (b:B) [(i=0) -> inl a, (i=1) -> inr b] 6 | 7 | push (A B:U) (a:A) (b:B) : Id (join A B) (inl a) (inr b) = pushC{join A B} a b@i 8 | 9 | -- Map from [join (join A B) C] to [join A (join B C)] 10 | 11 | l2rInl (A B C : U) : join A B -> join A (join B C) = split 12 | inl a -> inl a 13 | inr b -> inr (inl b) 14 | pushC a b @ i -> push A (join B C) a (inl b) @ i 15 | 16 | l2rPushInr (A B C : U) (b : B) (c : C) : Id (join A (join B C)) (inr (inl b)) (inr (inr c)) = 17 | inr (push B C b c@i) 18 | 19 | l2rSquare (A B C : U) (a : A) (b : B) (c : C) : 20 | IdP ( Id (join A (join B C)) (inl a) (inr (push B C b c@i))) 21 | (push A (join B C) a (inl b)@i) (push A (join B C) a (inr c)@i) = 22 | push A (join B C) a (push B C b c@i)@j 23 | 24 | opl2r (A : U) (a b c : A) (p : Id A a c) (q : Id A a b) (r : Id A b c) 25 | (sq : Square A a a (refl A a) b c r q p) : Square A a b q c c (refl A c) p r = 26 | comp A (sq@j@i) [(i=0) -> p@(j/\k),(j=1) -> p@(i\/k)] 27 | 28 | l2rPushPush (A B C : U) (a : A) (b : B) (c : C) : 29 | Square (join A (join B C)) 30 | (inl a) (inr (inl b)) (push A (join B C) a (inl b)) 31 | (inr (inr c)) (inr (inr c)) (refl (join A (join B C)) (inr (inr c))) 32 | (push A (join B C) a (inr c)) 33 | (l2rPushInr A B C b c) = 34 | opl2r (join A (join B C)) (inl a) (inr (inl b)) (inr (inr c)) 35 | (push A (join B C) a (inr c)) (push A (join B C) a (inl b)) (l2rPushInr A B C b c) 36 | (l2rSquare A B C a b c) 37 | 38 | l2rPush (A B C : U) (c : C) : (u : join A B) -> 39 | Id (join A (join B C)) (l2rInl A B C u) (inr (inr c)) = split 40 | inl a -> push A (join B C) a (inr c) 41 | inr b -> l2rPushInr A B C b c 42 | pushC a b @ i -> l2rPushPush A B C a b c @ i 43 | 44 | l2r (A B C : U) : join (join A B) C -> join A (join B C) = split 45 | inl jab -> l2rInl A B C jab 46 | inr c -> inr (inr c) 47 | pushC p q @i -> l2rPush A B C q p @i 48 | 49 | 50 | -- Map from [join A (join B C)] to [join (join A B) C] 51 | 52 | r2lInr (A B C : U) : join B C -> join (join A B) C = split 53 | inl b -> inl (inr b) 54 | inr c -> inr c 55 | pushC b c @i -> push (join A B) C (inr b) c @i 56 | 57 | r2lPushInl (A B C : U) (a : A) (b : B) : Id (join (join A B) C) (inl (inl a)) (inl (inr b)) = 58 | inl (push A B a b@i) -- r2lPushInl A B C a b = mapOnPath (join A B) (join (join A B) C) inl (inl a) (inr b) (push a b) 59 | 60 | r2lSquare (A B C : U) (a : A) (b : B) (c : C) : 61 | IdP ( Id (join (join A B) C) (inl (push A B a b@i)) (inr c)) 62 | (push (join A B) C (inl a) c) (push (join A B) C (inr b) c) 63 | = push (join A B) C (push A B a b@i) c@ j 64 | 65 | opr2l (A : U) (a b c : A) (p : Id A a c) (q : Id A a b) 66 | (r : Id A b c) 67 | (sq : Square A a b q c c (refl A c) p r) : 68 | Square A a a (refl A a) b c r q p = 69 | comp A (sq@j@i) [(j=0) -> p@(i/\-k),(i=1) -> p@(j\/-k)] 70 | 71 | r2lPushPush (A B C : U) (a : A) (b : B) (c : C) : 72 | Square (join (join A B) C) 73 | (inl (inl a)) (inl (inl a)) (refl (join (join A B) C) (inl (inl a))) 74 | (inl (inr b)) (inr c) (push (join A B) C (inr b) c) 75 | (r2lPushInl A B C a b) 76 | (push (join A B) C (inl a) c) = 77 | opr2l (join (join A B) C) (inl (inl a)) (inl (inr b)) (inr c) 78 | (push (join A B) C (inl a) c) (r2lPushInl A B C a b) (push (join A B) C (inr b) c) 79 | (r2lSquare A B C a b c) 80 | 81 | r2lPush (A B C : U) (a : A) : (bc : join B C) -> Id (join (join A B) C) (inl (inl a)) (r2lInr A B C bc) = split 82 | inl b -> r2lPushInl A B C a b 83 | inr c -> push (join A B) C (inl a) c 84 | pushC b c @ i -> r2lPushPush A B C a b c @ i 85 | 86 | r2l (A B C : U) : join A (join B C) -> join (join A B) C = split 87 | inl a -> inl (inl a) 88 | inr bc -> r2lInr A B C bc 89 | pushC a bc @i -> r2lPush A B C a bc @i 90 | 91 | 92 | 93 | -- Other stuff 94 | 95 | mapJoin (A B C D : U) (f : A -> C) (g : B -> D) : join A B -> join C D = split 96 | inl a -> inl (f a) 97 | inr b -> inr (g b) 98 | pushC a b @i -> push C D (f a) (g b)@i 99 | 100 | -- Suspension and join with the booleans 101 | suspJoin (A : U) : susp A -> join bool A = split 102 | north -> inl true 103 | south -> inl false 104 | merid a @ i -> compId (join bool A) (inl true) (inr a) (inl false) 105 | (push bool A true a) 106 | ((push bool A false a)@-i) @ i 107 | 108 | case1 (A:U) : bool -> susp A = split 109 | false -> south 110 | true -> north 111 | 112 | suspJoinInv (A : U) : join bool A -> susp A = split 113 | inl b -> case1 A b 114 | inr a -> south 115 | pushC b a @i -> case2 a b @ i 116 | where case2 (a:A) : (b : bool) -> Id (susp A) (suspJoinInv A (inl b)) south = split 117 | false -> refl (susp A) south 118 | true -> merid{susp A} a @i 119 | -------------------------------------------------------------------------------- /experiments/mystery.ctt: -------------------------------------------------------------------------------- 1 | module mystery where 2 | 3 | import helix 4 | import torus 5 | 6 | -- a function on numbers: 7 | -- (1) start with (Z * Z) * (Z * Z) 8 | -- (2) (loopS1 * loopS1) * (loopS1 * loopS1) 9 | -- (3) loopT * loopT 10 | -- (4) compose them to a loopT 11 | -- (5) convert back to (loopS1 * loopS1) 12 | -- (6) convert back to (Z * Z) 13 | 14 | -- use transport to lift just because we can :) 15 | Zs_to_loopS1s (input : and (and Z Z) (and Z Z)) : and (and loopS1 loopS1) (and loopS1 loopS1) = 16 | transport ( and (and (loopS1equalsZ @ -i) (loopS1equalsZ @ -i)) (and (loopS1equalsZ @ -i) (loopS1equalsZ @ -i))) input 17 | 18 | -- could do this with transport too but would have to prove the equivalence 19 | c2t_on_loops (p : (and loopS1 loopS1)) : loopT = 20 | c2t (p.1 @ x, p.2@x) 21 | 22 | t2cloops (l : loopT) : (and loopS1 loopS1) = 23 | ( ((t2c (l @ x)).1), ((t2c (l @ x)).2)) 24 | 25 | mystery (input : (and (and Z Z) (and Z Z))) : and Z Z = 26 | step6 27 | where 28 | step2 : and (and loopS1 loopS1) (and loopS1 loopS1) = Zs_to_loopS1s input 29 | step3 : (and loopT loopT) = (c2t_on_loops step2.1, c2t_on_loops step2.2) 30 | step4 : loopT = comp Torus (step3.1 @ x) [(x = 1) -> step3.2] 31 | step5 : (and loopS1 loopS1) = (t2cloops step4) 32 | step6 : and Z Z = transport ( and (loopS1equalsZ @ i) (loopS1equalsZ @ i)) step5 33 | 34 | oneZ : Z = sucZ zeroZ 35 | twoZ : Z = sucZ (oneZ) 36 | threeZ : Z = sucZ twoZ 37 | fourZ : Z = sucZ threeZ 38 | fiveZ : Z = sucZ fourZ 39 | sixZ : Z = sucZ fiveZ 40 | sevenZ : Z = sucZ sixZ 41 | 42 | double : nat -> nat = split 43 | zero -> zero 44 | suc n -> suc (suc (double n)) 45 | 46 | sixteenN : nat = (double (double (double (double (double (suc zero)))))) 47 | thirtyTwoN : nat = double sixteenN 48 | sixtyFourN : nat = double thirtyTwoN 49 | oneTwentyEightN : nat = double sixtyFourN 50 | twoFiftySixN : nat = double oneTwentyEightN 51 | 52 | test0 : Id (and Z Z) (mystery ((zeroZ,oneZ),(twoZ,threeZ))) (twoZ,fourZ) = 53 | <_> (twoZ,fourZ) 54 | 55 | test1 : Id (and Z Z) (mystery ((oneZ,twoZ),(twoZ,threeZ))) (threeZ,fiveZ) = 56 | <_> (threeZ,fiveZ) 57 | 58 | test1' : Id (and Z Z) (mystery ((twoZ,threeZ),(oneZ,twoZ))) (threeZ,fiveZ) = 59 | <_> (threeZ,fiveZ) 60 | 61 | test2 : Id (and Z Z) (mystery ((oneZ,twoZ),(threeZ,threeZ))) (fourZ,fiveZ) = 62 | <_> (fourZ,fiveZ) 63 | 64 | test3 : Id (and Z Z) (mystery ((twoZ,twoZ),(threeZ,threeZ))) (fiveZ,fiveZ) = 65 | <_> (fiveZ,fiveZ) 66 | 67 | test4 : Id (and Z Z) (mystery ((oneZ,twoZ),(threeZ,fourZ))) (fourZ,sixZ) = 68 | <_> (fourZ,sixZ) 69 | 70 | test5 : Id (and Z Z) (mystery ((inr sixteenN,inr sixteenN),(inr sixteenN,inr sixteenN))) 71 | (inr thirtyTwoN, inr thirtyTwoN) = 72 | <_> (inr thirtyTwoN, inr thirtyTwoN) 73 | 74 | test6 : Id (and Z Z) (mystery ((inr thirtyTwoN,inr sixteenN),(inr thirtyTwoN,inr sixteenN))) 75 | (inr sixtyFourN, inr thirtyTwoN) = 76 | <_> (inr sixtyFourN, inr thirtyTwoN) 77 | 78 | -- test7 : Id (and Z Z) (mystery ((inr sixtyFourN,inr sixteenN),(inr sixtyFourN,inr sixteenN))) 79 | -- (inr oneTwentyEightN, inr thirtyTwoN) = 80 | -- <_> (inr oneTwentyEightN, inr thirtyTwoN) 81 | 82 | -- test8 : Id (and Z Z) (mystery ((inr oneTwentyEightN,inr sixteenN),(inr oneTwentyEightN,inr sixteenN))) 83 | -- (inr twoFiftySixN, inr thirtyTwoN) = 84 | -- <_> (inr twoFiftySixN, inr thirtyTwoN) 85 | -------------------------------------------------------------------------------- /experiments/other.ctt: -------------------------------------------------------------------------------- 1 | module other where 2 | 3 | import retract 4 | 5 | propSingl (A:U) (a:A) (u v : singl A a) : Id (singl A a) u v = 6 | compId (singl A a) u (a,refl A a) v ((contrSingl A a u.1 u.2)@-i) (contrSingl A a v.1 v.2) 7 | 8 | singlN (A:U) (a:A) : U = (x:A) * neg (neg (Id A a x)) 9 | 10 | injN (A:U) (a:A) : singlN A a = (a,\ (h:neg (Id A a a)) -> h (refl A a)) 11 | 12 | lem1 (A:U) (a:A) (h:(x:A) -> stable (Id A a x)) : prop (singlN A a) = 13 | retractProp T (singl A a) f g rfg (propSingl A a) 14 | where 15 | T :U = (x:A) * neg (neg (Id A a x)) 16 | f (u:T) : singl A a = (u.1,h u.1 u.2) 17 | g (u:singl A a) : T = (u.1,\ (z:neg (Id A a u.1)) -> z u.2) 18 | rfg (u:T) : Id T (g (f u)) u = (u.1,(propNeg (neg (Id A a u.1)) (g (f u)).2 u.2)@i) 19 | 20 | cor1 (A:U) (a:A) (h:(x:A) -> stable (Id A a x)) : set (singlN A a) = 21 | propSet (singlN A a) (lem1 A a h) 22 | 23 | lem2 (A:U) (a:A) (h:(x:A) -> stable (Id A a x)) : prop (Id A a a) = 24 | retractProp (Id A a a) B f g rfg (cor1 A a h ia ia) 25 | where 26 | ia : singlN A a = injN A a 27 | B : U = Id (singlN A a) ia ia 28 | P (x:A) : U = neg (neg (Id A a x)) 29 | pP (x:A) : prop (P x) = propNeg (neg (Id A a x)) 30 | na : P a = \ (h:neg (Id A a a)) -> h (refl A a) 31 | f (p:Id A a a) : B = (p@i,(lemPropF A P pP a a p na na)@i) 32 | g (p:B) : Id A a a = (p@i).1 33 | rfg (p:Id A a a) : Id (Id A a a) (g (f p)) p = refl (Id A a a) p 34 | 35 | lem3 (A:U) (h : (a:A) -> prop (Id A a a)) (a b:A) (p q : Id A a b) : Id (Id A a b) p q = 36 | transport (prop (Id A a (p@i))) (h a) p q 37 | 38 | {- 39 | \(A : U) -> 40 | \(h : (a : A) -> (a0 : IdP ( A) a a) -> (b : IdP ( A) a a) -> IdP ( IdP ( A) a a) a0 b) -> 41 | \(a : A) -> 42 | \(b : A) -> 43 | \(p : IdP ( A) a b) -> \(q : IdP ( A) a b) -> 44 | comp A (comp A (h a ( comp A (p @ j) [ (j = 1) -> p @ -i ]) ( comp A (q @ j) [ (j = 1) -> p @ -i ]) @ j @ k) [ (k = 1) -> p @ i ]) [ (j = 0) -> comp A (comp A (p @ k) [ (k = 1) -> p @ (i \/ -j) ]) [ (k = 1) -> p @ (i \/ j) ], (j = 1) -> comp A (comp A (q @ k) [ (k = 1) -> p @ (i \/ -j) ]) [ (k = 1) -> p @ (i \/ j) ] ] 45 | -} 46 | 47 | hedberg (A:U) (h : (a x:A) -> stable (Id A a x)) : set A = 48 | lem3 A (\ (a:A) -> lem2 A a (h a)) 49 | 50 | {- normal form 51 | \(A : U) -> 52 | \(h : (a x : A) -> (((IdP ( A) a x) -> N0) -> N0) -> (IdP ( A) a x)) -> 53 | \(a b : A) -> 54 | \(p q : IdP ( A) a b) -> 55 | comp A (comp A (comp A a [ (!1 = 0) -> comp A (h a a (\(h0 : (IdP ( A) a a) -> N0) -> h0 ( a)) @ -!3) [ (!3 = 1) -> h a (comp A (p @ !2) [ (!2 = 1) -> p @ -!3 ]) (\(x : (IdP ( A) a (comp A (p @ !2) [ (!2 = 1) -> p @ -!3 ])) -> N0) -> efq (IdP ( N0) (x ( comp A a [ (!4 = 1) -> comp A (p @ (!2 /\ !3)) [ (!2 = 1)(!3 = 1) -> p @ -!4 ] ])) (x ( comp A a [ (!4 = 1) -> comp A (p @ (!2 \/ -!3)) [ (!2 = 1) -> p @ -!4, (!3 = 0) -> p @ -!4 ] ]))) (x ( comp A a [ (!4 = 1) -> comp A (p @ (!2 /\ !5)) [ (!2 = 1)(!5 = 1) -> p @ -!6 ] ])) @ !2) @ !4 ], (!1 = 1) -> comp A (h a a (\(h0 : (IdP ( A) a a) -> N0) -> h0 ( a)) @ -!3) [ (!3 = 1) -> h a (comp A (q @ !2) [ (!2 = 1) -> p @ -!3 ]) (\(x : (IdP ( A) a (comp A (q @ !2) [ (!2 = 1) -> p @ -!3 ])) -> N0) -> efq (IdP ( N0) (x ( comp A a [ (!4 = 1) -> comp A (q @ (!2 /\ !3)) [ (!2 = 1)(!3 = 1) -> p @ -!4 ] ])) (x ( comp A a [ (!4 = 1) -> comp A (q @ (!2 \/ -!3)) [ (!2 = 1) -> p @ -!4, (!3 = 0) -> p @ -!4 ] ]))) (x ( comp A a [ (!4 = 1) -> comp A (q @ (!2 /\ !5)) [ (!2 = 1)(!5 = 1) -> p @ -!6 ] ])) @ !2) @ !4 ], (!2 = 0) -> comp A (h a a (\(h0 : (IdP ( A) a a) -> N0) -> h0 ( a)) @ -!3) [ (!3 = 1) -> h a a (\(h0 : (IdP ( A) a a) -> N0) -> h0 ( a)) @ !4 ], (!2 = 1) -> comp A (h a a (\(h0 : (IdP ( A) a a) -> N0) -> h0 ( a)) @ -!3) [ (!3 = 1) -> h a a (\(h0 : (IdP ( A) a a) -> N0) -> h0 ( a)) @ !4 ] ]) [ (!2 = 1) -> p @ !3 ]) [ (!1 = 0) -> comp A (comp A (p @ !2) [ (!2 = 1) -> p @ (!3 \/ -!4) ]) [ (!2 = 1) -> p @ (!3 \/ !4) ], (!1 = 1) -> comp A (comp A (q @ !2) [ (!2 = 1) -> p @ (!3 \/ -!4) ]) [ (!2 = 1) -> p @ (!3 \/ !4) ] ] 56 | -} -------------------------------------------------------------------------------- /experiments/pi1s2.ctt: -------------------------------------------------------------------------------- 1 | module pi1s2 where 2 | 3 | import truncS2 4 | import thm7312 5 | 6 | pi1S2 : U = sTrunc loopS2 7 | 8 | incN : gTrunc S2 = inc north 9 | 10 | cor7312 : Id U pi1S2 (Id (gTrunc S2) incN incN) = 11 | thm7312 S2 north north 12 | 13 | propPi1S2 : prop pi1S2 = 14 | substInv U prop pi1S2 (Id (gTrunc S2) incN incN) cor7312 15 | (propSet (gTrunc S2) propgTruncS2 incN incN) 16 | 17 | meridS2 : Id S2 north south = merid{S2} base@i 18 | 19 | trivS2 : pi1S2 = inc (refl S2 north) 20 | loopS2 : pi1S2 = inc (compId S2 north south north meridS2 (meridS2@-i)) 21 | 22 | test : Id pi1S2 trivS2 loopS2 = propPi1S2 trivS2 loopS2 23 | test1 : Id pi1S2 trivS2 trivS2 = propPi1S2 trivS2 trivS2 24 | 25 | -- we can transport this since S1 = susp bool 26 | 27 | eqS1 : Id U S1 sone = s1EqCircle@-i 28 | 29 | eqS2 : Id U S2 stwo = susp (eqS1@i) 30 | 31 | pi1stwo : U = sTrunc (Id stwo north north) 32 | 33 | eqPi1 : Id U pi1S2 pi1stwo = sTrunc (Id (susp (eqS1@i)) north north) 34 | 35 | propPi1stwo : prop pi1stwo = subst U prop pi1S2 pi1stwo eqPi1 propPi1S2 36 | 37 | meridNstwo : Id stwo north south = merid{stwo} north@i 38 | meridSstwo : Id stwo north south = merid{stwo} south@i 39 | trivstwo : pi1stwo = inc (refl stwo north) 40 | loopstwo : pi1stwo = inc (compId stwo north south north meridNstwo (meridSstwo@-i)) 41 | 42 | test2 : Id pi1stwo trivstwo trivstwo = propPi1stwo trivstwo trivstwo 43 | 44 | test3 : Id pi1stwo trivstwo loopstwo = propPi1stwo trivstwo loopstwo 45 | 46 | -------------------------------------------------------------------------------- /experiments/pi4s3.ctt: -------------------------------------------------------------------------------- 1 | module pi4s3 where 2 | 3 | import join 4 | import hopf 5 | import exchange 6 | 7 | ptJoin (pA : ptType) (B:U) : ptType = (join pA.1 B, inl (pt pA)) 8 | 9 | ptbool : ptType = (bool,true) 10 | 11 | bjbToS1 (x:join bool bool) : S1 = s1ToCircle (suspJoinInv bool x) 12 | 13 | bjbToS1Inv (x : S1) : join bool bool = suspJoin bool (circleToS1 x) 14 | 15 | -- The map e^-1 from 7.3 16 | s3ToS1JoinS1Inv (x : join S1 S1) : S3 = 17 | suspJoinInv S2 18 | (mapJoin bool (join bool S1) bool S2 (\(b:bool) -> b) (suspJoinInv S1) 19 | (l2r bool bool S1 20 | (mapJoin S1 S1 (join bool bool) S1 bjbToS1Inv (\(z:S1) -> z) x))) 21 | 22 | 23 | -- The map e from 7.3 24 | s3ToS1JoinS1 (x:S3) : join S1 S1 = 25 | mapJoin (join bool bool) S1 S1 S1 bjbToS1 (\(z:S1) -> z) 26 | (r2l bool bool S1 27 | (mapJoin bool S2 bool (join bool S1) (\(b:bool) -> b) (suspJoin S1) 28 | (suspJoin S2 x))) 29 | 30 | 31 | -- A modified version of the main map alpha from 8, which is equal to the 32 | -- other one (to be checked) but pointed by reflexivity 33 | alpha : join S1 S1 -> S2 = split 34 | inl x -> north 35 | inr y -> north 36 | pushC x y @ i -> compId S2 north south north (merid{S2} x@i) (merid{S2} y@-i)@i 37 | 38 | ptAlpha : ptMap (ptJoin ptS1 S1) ptS2 = (alpha, refl S2 north) 39 | 40 | -- Let’s define the twelve maps first 41 | 42 | f0 : Z -> loopS1 = loopIt 43 | 44 | compInvRight (A:U) (a b:A) (p:Id A a b) : Id (Id A a a) (compId A a b a p (p@-i)) (refl A a) = 45 | comp A (p@-i/\j) [(j=1) -> p@(-k/\-i)] 46 | 47 | ptSusp (A : U) : ptType = (susp A, north) 48 | 49 | sigma (A : ptType) : ptMap A (Omega (ptSusp A.1))= 50 | (s,s0) 51 | where s (x:A.1) : Id (susp A.1) north north 52 | = compId (susp A.1) north south north 53 | (merid{susp A.1} x@i) 54 | ((merid{susp A.1} (pt A))@-i) 55 | 56 | s0 : Id (Omega (ptSusp A.1)).1 57 | (s (pt A)) 58 | (refl (susp A.1) north) 59 | = compInvRight (susp A.1) north south (merid{susp A.1} (pt A)@i) 60 | 61 | f1 : loopS1 -> (itOmega two ptS2).1 = (mapOmega ptS1 (Omega ptS2) (sigma ptS1)).1 62 | 63 | f2 : (itOmega two ptS2).1 -> (itOmega three ptS3).1 = 64 | (itMapOmega two ptS2 (Omega ptS3) (sigma ptS2)).1 65 | 66 | f3 : (itOmega three ptS3).1 -> (itOmega three (ptJoin ptS1 S1)).1 67 | = itMapOmegaRefl three ptS3 (join S1 S1) s3ToS1JoinS1 68 | 69 | f4 : (itOmega three (ptJoin ptS1 S1)).1 -> (itOmega three ptS2).1 70 | = itMapOmegaRefl three (ptJoin ptS1 S1) S2 ptAlpha.1 71 | 72 | f5 : (itOmega three ptS2).1 -> (itOmega three (ptJoin ptS1 S1)).1 73 | = hopfLoop 74 | 75 | oneZ : Z = sucZ zeroZ 76 | 77 | -- WORKS 78 | test0To1 : (itOmega two ptS2).1 = f1 (f0 oneZ) 79 | 80 | -- WORKS 81 | test0To2 : (itOmega three ptS3).1 = f2 test0To1 82 | 83 | -- WORKS 84 | test0To3 : (itOmega three (ptJoin ptS1 S1)).1 = f3 test0To2 85 | 86 | -- WORKS 87 | test0To4 : (itOmega three ptS2).1 = f4 test0To3 88 | 89 | -- NOT SURE (takes a long time) 90 | test0To5 : (itOmega three (ptJoin ptS1 S1)).1 = f5 test0To4 91 | 92 | -- Test f5 on a generator given by the exchange law 93 | testf5 : (itOmega three (ptJoin ptS1 S1)).1 = f5 genPi3S2 -------------------------------------------------------------------------------- /experiments/pointed.ctt: -------------------------------------------------------------------------------- 1 | module pointed where 2 | 3 | import nat 4 | import sigma 5 | 6 | -- Pointed types 7 | ptType : U = (X : U) * X 8 | 9 | pt (Z : ptType) : Z.1 = Z.2 10 | 11 | -- Maps between pointed types 12 | isPtMap (A B : ptType) (f : A.1 -> B.1) : U = Id B.1 (f (pt A)) (pt B) 13 | 14 | ptMap (A B : ptType) : U = (f : A.1 -> B.1) * isPtMap A B f 15 | 16 | -- The loop space of a pointed type 17 | Omega (Z : ptType) : ptType = (Id Z.1 (pt Z) (pt Z),refl Z.1 (pt Z)) 18 | 19 | kanOp (A : U) (a : A) (p : Id A a a) (b : A) (q : Id A a b) : Id A b b = 20 | comp A (p@i) [(i=0) -> q, (i=1) -> q] 21 | 22 | kanOpRefl (A : U) (a b : A) (q : Id A a b) : Id (Id A b b) (refl A b) (kanOp A a (refl A a) b q) = 23 | comp A (comp A a [(j=0) -> q@(i/\k),(j=1)-> q@(i/\k)]) 24 | [(j=0)-> q@(i\/k),(j=1)->q@(i\/k), (i=0) -> q] 25 | 26 | mapOmega (A B : ptType) (h : ptMap A B) : ptMap (Omega A) (Omega B) = 27 | (omf,omf0) 28 | where a : A.1 = pt A 29 | b : B.1 = pt B 30 | 31 | f : A.1 -> B.1 = h.1 32 | f0 : Id B.1 (f a) b = h.2 33 | 34 | omf (p : (Omega A).1) : (Omega B).1 = kanOp B.1 (f a) (f (p@i)) b f0 35 | omf0 : Id (Omega B).1 (omf (refl A.1 a)) (refl B.1 b) = kanOpRefl B.1 (f a) b f0@-i 36 | 37 | -- Simplified mapOmega when the function is pointed by reflexivity 38 | mapOmegaRefl (A : ptType) (B : U) (h : A.1 -> B) (p: (Omega A).1) : (Omega (B, h (pt A))).1 = 39 | h (p@i) 40 | 41 | -- Iterated loop space 42 | itOmega : nat -> ptType -> ptType = split 43 | zero -> \ (A:ptType) -> A 44 | suc n -> \(A:ptType) -> itOmega n (Omega A) 45 | 46 | itMapOmega : (n : nat) (A B : ptType) (h : ptMap A B) -> ptMap (itOmega n A) (itOmega n B) = split 47 | zero -> \ (A B : ptType) (h : ptMap A B) -> h 48 | suc n -> \ (A B : ptType) (h : ptMap A B) -> itMapOmega n (Omega A) (Omega B) (mapOmega A B h) 49 | 50 | itMapOmegaRefl : (n : nat) (A : ptType) (B : U) (h : A.1 -> B) -> (itOmega n A).1 -> (itOmega n (B, h (pt A))).1 51 | = split 52 | zero -> \ (A : ptType) (B : U) (h : A.1 -> B) -> h 53 | suc n -> \ (A : ptType) (B : U) (h : A.1 -> B) -> itMapOmegaRefl n (Omega A) (Omega (B, h (pt A))).1 (mapOmegaRefl A B h) 54 | 55 | -- Looping a fibration (9.2) 56 | 57 | fibOmega (B : ptType) (P : B.1 -> U) (f : P (pt B)) (p : (Omega B).1) : U = 58 | IdS B.1 P (pt B) (pt B) p f f 59 | 60 | totalFibOmega (B : ptType) (P : B.1 -> U) (f : P (pt B)) 61 | (p : sig (Omega B).1 (fibOmega B P f)) : (Omega (sig B.1 P, (pt B, f))).1 62 | = (p.1@i,p.2@i) -- pairPath B.1 P (pt B) (pt B) f f p.1 p.2 63 | 64 | itFibOmega : (n : nat) (B : ptType) (P : B.1 -> U) (f : P (pt B)) -> (itOmega n B).1 -> U 65 | = split 66 | zero -> \ (B : ptType) (P : B.1 -> U) (f : P (pt B)) -> P 67 | suc n -> \ (B : ptType) (P : B.1 -> U) (f : P (pt B)) -> itFibOmega n (Omega B) (fibOmega B P f) (refl (P (pt B)) f) 68 | 69 | itTotalFibOmega : (n : nat) (B : ptType) (P : B.1 -> U) (f : P (pt B)) (x:sig (itOmega n B).1 (itFibOmega n B P f)) 70 | -> (itOmega n (sig B.1 P, (pt B, f))).1 71 | = split 72 | zero -> \ (B : ptType) (P : B.1 -> U) (f : P (pt B)) (x:sig B.1 P) -> x 73 | suc n -> \ (B : ptType) (P : B.1 -> U) (f : P (pt B)) 74 | (x:sig (itOmega n (Omega B)).1 (itFibOmega n (Omega B) (fibOmega B P f) (refl (P (pt B)) f))) -> 75 | let 76 | BOm : ptType = Omega B 77 | POm : BOm.1 -> U = fibOmega B P f 78 | fOm : Id (P (pt B)) f f = refl (P (pt B)) f 79 | ih : (sig (itOmega n BOm).1 (itFibOmega n BOm POm fOm)) -> 80 | (itOmega n (sig BOm.1 POm, (pt BOm, fOm))).1 81 | = itTotalFibOmega n (Omega B) (fibOmega B P f) (refl (P (pt B)) f) 82 | in (itMapOmega n (sig BOm.1 POm, (pt BOm, fOm)) 83 | (Omega (sig B.1 P, (pt B, f))) 84 | (totalFibOmega B P f, 85 | refl (Omega (sig B.1 P, (pt B, f))).1 86 | (refl (sig B.1 P) (pt B, f)))).1 87 | (ih x) 88 | 89 | -- TODO: better name! 90 | -- isContr : U -> U 91 | -- isContr A = (a : A) * ((x : A) -> Id A a x) 92 | 93 | inhOrTrunc (A:U) : nat -> U = split 94 | zero -> A 95 | suc n -> (x y : A) -> inhOrTrunc (Id A x y) n 96 | 97 | truncFibOmega (B : ptType) (P : B.1 -> U) (f : P (pt B)) (n : nat) 98 | (tr:inhOrTrunc (P (pt B)) (suc n)) (p : (Omega B).1) : inhOrTrunc (fibOmega B P f p) n 99 | = substInv U (\ (X:U) -> inhOrTrunc X n) 100 | (IdS B.1 P (pt B) (pt B) p f f) (Id (P (pt B)) (subst B.1 P (pt B) (pt B) p f) f) 101 | (funDepTr (P (pt B)) (P (pt B)) (P (p@i)) f f) (tr (subst B.1 P (pt B) (pt B) p f) f) 102 | -------------------------------------------------------------------------------- /experiments/quotient.ctt: -------------------------------------------------------------------------------- 1 | -- Experimental implementation of quotient HIT (not finished) 2 | module quotient where 3 | 4 | import circle 5 | 6 | -- Quotient A by R 7 | data Quot (A : U) (R : A -> A -> U) = 8 | inj (a : A) 9 | | quoteq (a b : A) (r : R a b) 10 | [ (i = 0) -> inj a, (i = 1) -> inj b ] 11 | 12 | quoteq' (A : U) (R : A -> A -> U) (a b : A) (r : R a b) 13 | : Path (Quot A R) (inj a) (inj b) = quoteq {Quot A R} a b r @ i 14 | 15 | 16 | -- Test to define circle as a quotient of unit 17 | RS1 (a b : Unit) : U = Unit 18 | s1quot : U = Quot Unit RS1 19 | 20 | f1 : s1quot -> S1 = split 21 | inj _ -> base 22 | quoteq a b r @ i -> loop1 @ i 23 | 24 | f2 : S1 -> s1quot = split 25 | base -> inj tt 26 | loop @ i -> quoteq{s1quot} tt tt tt @ i 27 | 28 | rem3 : (a : Unit) -> Path s1quot (inj tt) (inj a) = split 29 | tt -> inj tt 30 | 31 | test : Path U s1quot S1 = 32 | isoPath s1quot S1 f1 f2 rem1 rem2 33 | where 34 | rem1 : (y : S1) -> Path S1 (f1 (f2 y)) y = split 35 | base -> base 36 | loop @ i -> loop1 @ i 37 | rem2 : (x : s1quot) -> Path s1quot (f2 (f1 x)) x = split 38 | inj a -> rem3 a 39 | quoteq a b r @ i -> ? 40 | 41 | 42 | -- Set quotient of A by R 43 | data setquot (A : U) (R : A -> A -> U) = 44 | quot (a : A) 45 | | identification (a b : A) (r : R a b) [ (i = 0) -> quot a, (i = 1) -> quot b ] 46 | | setTruncation (a b : setquot A R) (p q : Path (setquot A R) a b) 47 | [ (i = 0) -> p @ j 48 | , (i = 1) -> q @ j 49 | , (j = 0) -> a 50 | , (j = 1) -> b ] 51 | 52 | 53 | {- 54 | b 55 | p q 56 | a 57 | -} 58 | 59 | identsetquot (A : U) (R : A -> A -> U) (a b : A) (r : R a b) 60 | : Path (setquot A R) (quot a) (quot b) = identification {setquot A R} a b r @ i 61 | 62 | setsetquot (A : U) (R : A -> A -> U) : set (setquot A R) = 63 | \(a b : setquot A R) (p q : Path (setquot A R) a b) -> 64 | setTruncation {setquot A R} a b p q @ i @ j 65 | -------------------------------------------------------------------------------- /experiments/s2.ctt: -------------------------------------------------------------------------------- 1 | module s2 where 2 | 3 | import pointed 4 | import pi1s2 5 | 6 | data sph 7 | = base 8 | | surf [ (i=0) -> base 9 | , (i=1) -> base 10 | , (j=0) -> base 11 | , (j=1) -> base 12 | ] 13 | 14 | -- Isomorphism of sph and S2 due to tomjack: 15 | 16 | suspSurf : Id (Id S2 north north) ( north) ( north) 17 | = comp S2 (merid{S2} (loop{S1} @ j) @ k) 18 | [ (j=0) -> merid{S2} base @ -j /\ k 19 | , (j=1) -> merid{S2} base @ -j /\ k 20 | , (k=1) -> merid{S2} base @ -k 21 | ] 22 | 23 | toS2 : sph -> S2 = split 24 | base -> north 25 | surf @ j k -> suspSurf @ j @ k 26 | 27 | sphMerid : S1 -> Id sph base base = split 28 | base -> base 29 | loop @ j -> surf{sph} @ j @ k 30 | 31 | fromS2 : S2 -> sph = split 32 | north -> base 33 | south -> base 34 | merid x @ k -> sphMerid x @ k 35 | 36 | toFromS2 : (x : S2) -> Id S2 (toS2 (fromS2 x)) x = split 37 | north -> north 38 | south -> merid{S2} base @ i 39 | merid x @ k -> rem x @ k 40 | where 41 | rem : (x : S1) 42 | -> IdP ( Id S2 (toS2 (fromS2 (merid{S2} x @ k))) (merid{S2} x @ k)) 43 | ( north) 44 | ( merid{S2} base @ i) 45 | = split 46 | base -> merid{S2} base @ k /\ i 47 | loop @ j -> comp S2 (merid{S2} (loop{S1} @ j) @ k) 48 | [ (j=0) -> merid{S2} base @ -(-i /\ j) /\ k 49 | , (j=1) -> merid{S2} base @ -(-i /\ j) /\ k 50 | , (k=1) -> merid{S2} base @ -(-i /\ k) 51 | ] 52 | 53 | fromToS2 : (x : sph) -> Id sph (fromS2 (toS2 x)) x = split 54 | base -> base 55 | surf @ j k -> surf{sph} @ j @ k 56 | 57 | s2EqSph : Id U S2 sph 58 | = isoId S2 sph fromS2 toS2 fromToS2 toFromS2 59 | 60 | s2EqSphPt : Id ptType (S2, north) (sph, base) 61 | = (s2EqSph @ i, transport ( s2EqSph @ i /\ j) north) 62 | 63 | loopSph : U = Id sph base base 64 | pi1Sph : U = sTrunc loopSph 65 | 66 | pi1 (A : ptType) : U = sTrunc (Id A.1 A.2 A.2) 67 | propPi1 (A : ptType) : U = prop (pi1 A) 68 | 69 | trivSph : pi1Sph = subst ptType pi1 (S2, north) (sph, base) s2EqSphPt trivS2 70 | -- NORMEVAL: inc ( base) 71 | 72 | loopSph : pi1Sph = subst ptType pi1 (S2, north) (sph, base) s2EqSphPt loopS2 73 | -- NORMEVAL: inc ( base) 74 | 75 | loopSph' : pi1Sph = inc ( surf{sph} @ i @ i) 76 | -- NORMEVAL: inc ( surf {sph} @ !0 @ !0) 77 | 78 | propPi1Sph : prop pi1Sph 79 | = subst ptType propPi1 (S2, north) (sph, base) s2EqSphPt propPi1S2 80 | 81 | -- > :n propPi1Sph trivSph loopSph 82 | -- NORMEVAL: inc ( base) 83 | 84 | -- > :n propPi1Sph trivSph loopSph' 85 | npropPi1Sph : Id pi1Sph trivSph loopSph' = 86 | inc ( comp sph (comp sph base [ (i1 = 1) -> comp sph base [ (i3 = 1) -> comp sph base [ (i4 = 1) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i5 = 0) -> comp sph base [ (i6 = 0) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i7 = 0) -> comp sph base [ (i8 = 0) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i9 = 0) -> comp sph base [ (i10 = 0) -> comp sph base [ (i11 = 1) -> comp sph base [ (i12 = 1) -> comp sph base [ (i13 = 1) -> comp sph base [ (i14 = 0) -> comp sph base [ (i2 = 1) -> surf {sph} @ i16 @ i15 ], (i14 = 1) -> comp sph base [ (i2 = 1) -> surf {sph} @ i16 @ (i15 /\ i16) ] ] ] ] ] ] ] ] ] ] ] ] ] ]) [ (i1 = 1) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i3 = 1) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i4 = 0) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ (i5 /\ i6) @ (i5 /\ i6) ]) [ (i2 = 1) -> surf {sph} @ (i5 \/ i6) @ (i5 \/ i6) ], (i4 = 1) -> comp sph (surf {sph} @ (i5 /\ i2) @ (i5 /\ i2)) [ (i2 = 1) -> surf {sph} @ (i5 \/ i6) @ (i5 \/ i6) ] ] ] ]) 87 | 88 | -- Slightly simplified: 89 | npropPi1Sph' : Id pi1Sph trivSph loopSph' = 90 | inc ( comp sph (comp sph base [ (i1 = 1) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i4 = 0) -> comp sph base [ (i6 = 0) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i7 = 0) -> comp sph base [ (i8 = 0) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i9 = 0) -> comp sph base [ (i10 = 0) -> comp sph base [ (i11 = 1) -> comp sph base [ (i12 = 1) -> comp sph base [ (i13 = 1) -> comp sph base [ (i14 = 0) -> comp sph base [ (i2 = 1) -> surf {sph} @ i16 @ i15 ], (i14 = 1) -> comp sph base [ (i2 = 1) -> surf {sph} @ i16 @ (i15 /\ i16) ] ] ] ] ] ] ] ] ] ] ] ]) [ (i1 = 1) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i3 = 1) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i4 = 0) -> comp sph (comp sph base [ (i2 = 1) -> surf {sph} @ (i5 /\ i6) @ (i5 /\ i6) ]) [ (i2 = 1) -> surf {sph} @ (i5 \/ i6) @ (i5 \/ i6) ], (i4 = 1) -> comp sph (surf {sph} @ (i5 /\ i2) @ (i5 /\ i2)) [ (i2 = 1) -> surf {sph} @ (i5 \/ i6) @ (i5 \/ i6) ] ] ] ]) 91 | 92 | -- Comparison with a direct proof of prop pi1Sph 93 | 94 | contrTruncSph : (x : gTrunc sph) -> Id (gTrunc sph) (inc base) x 95 | = gTruncElim sph (\(x : gTrunc sph) -> Id (gTrunc sph) (inc base) x) rem1 rem2 96 | where 97 | rem1 : (x : gTrunc sph) -> groupoid (Id (gTrunc sph) (inc base) x) 98 | = \(x : gTrunc sph) 99 | (p q : Id (gTrunc sph) (inc base) x) 100 | (r s : Id (Id (gTrunc sph) (inc base) x) p q) 101 | (t u : Id (Id (Id (gTrunc sph) (inc base) x) p q) r s) 102 | -> propSet (Id (Id (gTrunc sph) (inc base) x) p q) 103 | (\(r s : Id (Id (gTrunc sph) (inc base) x) p q) 104 | -> squashC{gTrunc sph} (inc base) x p q r s @ i @ j @ k) 105 | r s t u 106 | 107 | rem2 : (x : sph) -> Id (gTrunc sph) (inc base) (inc x) = split 108 | base -> inc base 109 | surf @ i j -> squashC{gTrunc sph} (inc base) (inc base) 110 | ( inc base) ( inc base) 111 | ( inc base) ( inc (surf{sph} @ i @ j)) 112 | @ k @ i @ j 113 | 114 | propTruncSph : prop (gTrunc sph) 115 | = \(x y : gTrunc sph) 116 | -> compId (gTrunc sph) x (inc base) y ( contrTruncSph x @ -i) (contrTruncSph y) 117 | 118 | propPi1SphDirect : prop pi1Sph 119 | = substInv U prop pi1Sph (Id (gTrunc sph) (inc base) (inc base)) (thm7312 sph base base) 120 | (propSet (gTrunc sph) propTruncSph (inc base) (inc base)) 121 | 122 | -- Roughly 30x faster 123 | npropPi1SphDirect : Id pi1Sph trivSph loopSph' 124 | -- = propPi1SphDirect trivSph loopSph' 125 | = inc ( comp (sph) (comp (sph) base [ (i1 = 1) -> comp (sph) base [ (i3 = 1) -> comp (sph) base [ (i4 = 1) -> comp (sph) base [ (i5 = 1) -> comp (sph) base [ (i6 = 0) -> comp (sph) base [ (i2 = 1) -> surf {sph} @ i8 @ i7 ], (i6 = 1) -> comp (sph) base [ (i2 = 1) -> surf {sph} @ i8 @ (i7 /\ i8) ] ] ] ] ] ]) [ (i1 = 1) -> comp (sph) (comp (sph) base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i3 = 1) -> comp (sph) (comp (sph) base [ (i2 = 1) -> surf {sph} @ i3 @ i3 ]) [ (i4 = 0) -> comp (sph) (comp (sph) base [ (i2 = 1) -> surf {sph} @ (i5 /\ i6) @ (i5 /\ i6) ]) [ (i2 = 1) -> surf {sph} @ (i5 \/ i6) @ (i5 \/ i6) ], (i4 = 1) -> comp (sph) (surf {sph} @ (i5 /\ i2) @ (i5 /\ i2)) [ (i2 = 1) -> surf {sph} @ (i5 \/ i6) @ (i5 \/ i6) ] ] ] ]) 126 | -------------------------------------------------------------------------------- /experiments/set.ctt: -------------------------------------------------------------------------------- 1 | module set where 2 | 3 | import prelude 4 | 5 | sqDepPath (A:U) (F:A->U) (sF:(x:A) -> set (F x)) 6 | (a0 a1:A) (p:Id A a0 a1) (u0 : F a0) (u1 : F a1) (q r: IdP ( F (p@i)) u0 u1) : 7 | Id (IdP ( F (p@i)) u0 u1) q r = rem @ j @ i 8 | where 9 | rem : IdP (Id (F (p@i)) (q@i) (r@i)) (u0) (u1) = 10 | let xi : A = p@i 11 | ui0 : F xi = transport (F (p @ i/\j)) u0 12 | ui1 : F xi = transport (F (p @ i\/-j)) u1 13 | qi : Id (F xi) ui0 ui1 = transport (F (p@(i/\-j/\k)\/(i/\j)\/(j/\-k)\/(i/\k))) (q@j) 14 | ri : Id (F xi) ui0 ui1 = transport (F (p@(i/\-j/\k)\/(i/\j)\/(j/\-k)\/(i/\k))) (r@j) 15 | in (sF xi ui0 ui1 qi ri @ j @ i) 16 | 17 | sqDepPathJ (A:U) (F:A->U) (sF:(x:A) -> set (F x)) 18 | (a0 : A) : (a1:A) (p:Id A a0 a1) (u0 : F a0) (u1 : F a1) (q r: IdP ( F (p@i)) u0 u1) -> 19 | Id (IdP ( F (p@i)) u0 u1) q r = 20 | J A a0 (\ (a1:A) (p:Id A a0 a1) -> (u0 : F a0) (u1 : F a1) (q r: IdP ( F (p@i)) u0 u1) -> 21 | Id (IdP ( F (p@i)) u0 u1) q r) (sF a0) 22 | 23 | test (A:U) (F:A->U) (sF:(x:A) -> set (F x)) 24 | (a0 a1:A) (p:Id A a0 a1) (u0 : F a0) (u1 : F a1) (q r: IdP ( F (p@i)) u0 u1) : 25 | Id (IdP ( F (p@i)) u0 u1) q r = sqDepPathJ A F sF a0 a1 p u0 u1 q r 26 | 27 | sqDepPath2 (A:U) (F:A->U) (sF:(x:A) -> set (F x)) 28 | (a0 a1:A) (p :Id A a0 a1) : (q : Id A a0 a1) (spq : Id (Id A a0 a1) p q) 29 | (u0 : F a0) (u1 : F a1) 30 | (r : IdP ( F (p@i)) u0 u1) (s : IdP ( F (q@i)) u0 u1) -> 31 | IdP ( IdP ( F (spq @ i @ j)) u0 u1) r s = 32 | J (Id A a0 a1) p 33 | (\(q : Id A a0 a1) (spq : Id (Id A a0 a1) p q) -> 34 | (u0 : F a0) (u1 : F a1) (r : IdP ( F (p@i)) u0 u1) 35 | (s : IdP ( F (q@i)) u0 u1) -> IdP ( IdP ( F (spq @ i @ j)) u0 u1) r s) rem 36 | where rem : (u0 : F a0) (u1 : F a1) (r s : IdP ( F (p@i)) u0 u1) -> 37 | Id (IdP ( F (p @ j)) u0 u1) r s = sqDepPath A F sF a0 a1 p 38 | 39 | -- rem @ j @ i 40 | -- where 41 | -- rem : IdP ( IdP ( F (spq @ j @ i)) (r@i) (s@i)) (u0) (u1) = 42 | -- let xi : A = p @ i 43 | -- yi : A = q @ i 44 | -- li : Id A xi yi = spq @ j @ i 45 | -- ui0 : F xi = transport (F (p @ i/\j)) u0 46 | -- ui1 : F xi = transport (F (p @ i\/-j)) u1 47 | -- vi0 : F yi = transport (F (q @ i/\j)) u0 48 | -- vi1 : F yi = transport (F (q @ i\/-j)) u1 49 | -- ri : Id (F xi) ui0 ui1 = transport (F (p@(i/\-j/\k)\/(i/\j)\/(j/\-k)\/(i/\k))) (r@j) 50 | -- si : Id (F yi) vi0 vi1 = transport (F (q@(i/\-j/\k)\/(i/\j)\/(j/\-k)\/(i/\k))) (s@j) 51 | -- uvi0 : IdP ( F (li @ j)) ui0 vi0 = transport 52 | -- uvi1 : IdP ( F (li @ j)) ui1 vi1 = 53 | -- test : U = U 54 | -- in (sF xi ui0 ui1 ri si @ j @ i) 55 | 56 | 57 | -------------------------------------------------------------------------------- /experiments/setTrunc.ctt: -------------------------------------------------------------------------------- 1 | module setTrunc where 2 | 3 | import set 4 | 5 | data sTrunc (A : U) 6 | = inc (a : A) 7 | | setTrC (a b : sTrunc A) (p q : Id (sTrunc A) a b) 8 | [ (i=0) -> p @ j 9 | , (i=1) -> q @ j 10 | , (j=0) -> a 11 | , (j=1) -> b] 12 | 13 | sTr (A : U) (a b : sTrunc A) (p q : Id (sTrunc A) a b) : Id (Id (sTrunc A) a b) p q = 14 | setTrC {sTrunc A} a b p q @ i @ j 15 | 16 | -- sTruncSet (A : U) : set (sTrunc A) = 17 | -- \(a b : sTrunc A) (p q : Id (sTrunc A) a b) -> 18 | -- setTrC {sTrunc A} a b p q @ i @ j 19 | 20 | sTruncRec (A : U) 21 | (B : U) 22 | (bS : set B) 23 | (f : A -> B) : 24 | sTrunc A -> B = 25 | split 26 | inc a -> f a 27 | setTrC a b p q @ i j -> (bS (sTruncRec A B bS f a) 28 | (sTruncRec A B bS f b) 29 | ( sTruncRec A B bS f (p @ k)) 30 | ( sTruncRec A B bS f (q @ k))) @ i @ j 31 | 32 | sTruncElim (A : U) (P : sTrunc A -> U) (sP : (z : sTrunc A) -> set (P z)) (h : (x : A) -> P (inc x)) 33 | : (z : sTrunc A) -> P z = split 34 | inc a -> h a 35 | setTrC a b p q @ i j -> sqDepPath2 (sTrunc A) P sP a b p q (sTr A a b p q) 36 | (f a) (f b) ( f (p @ k)) ( f (q @ k)) @ i @ j 37 | where f : (z : sTrunc A) -> P z = sTruncElim A P sP h -------------------------------------------------------------------------------- /experiments/stream.ctt: -------------------------------------------------------------------------------- 1 | module stream where 2 | 3 | -- Things from the prelude: 4 | Id (A : U) (a0 a1 : A) : U = IdP ( A) a0 a1 5 | 6 | refl (A : U) (a : A) : Id A a a = a 7 | 8 | isoId (A B : U) (f : A -> B) (g : B -> A) 9 | (s : (y:B) -> Id B (f (g y)) y) 10 | (t : (x:A) -> Id A (g (f x)) x) : Id U A B = 11 | glue B [ (i = 0) -> (A,f,g,s,t) ] 12 | 13 | 14 | -- Let us pretend that Stream is a coinductive type. 15 | 16 | data Stream (A : U) = cons (x : A) (xs : Stream A) 17 | 18 | -- Projections. 19 | 20 | head (A : U) : Stream A -> A = split 21 | cons x xs -> x 22 | 23 | tail (A : U) : Stream A -> Stream A = split 24 | cons x xs -> xs 25 | 26 | -- Propositional eta-equality for streams. 27 | 28 | eta 29 | (A : U) : 30 | (xs : Stream A) -> 31 | Id (Stream A) (cons (head A xs) (tail A xs)) xs = 32 | split 33 | cons x xs -> cons x xs 34 | 35 | -- Bisimilarity. 36 | 37 | data Bisimilar (A : U) (xs ys : Stream A) = 38 | consB (h : Id A (head A xs) (head A ys)) 39 | (t : Bisimilar A (tail A xs) (tail A ys)) 40 | 41 | -- Bisimilarity implies equality. 42 | 43 | bisimilarityToId2 44 | (rec : (A : U) (xs : Stream A) (ys : Stream A) -> Bisimilar A xs ys -> Id (Stream A) xs ys) 45 | (A : U) (x : A) (xs : Stream A) (y : A) (ys : Stream A) : 46 | Bisimilar A (cons x xs) (cons y ys) -> 47 | Id (Stream A) (cons x xs) (cons y ys) = 48 | split 49 | consB h t -> cons (h @ i) ((rec A xs ys t) @ i) 50 | 51 | bisimilarityToId1 52 | (rec : (A : U) (xs : Stream A) (ys : Stream A) -> Bisimilar A xs ys -> Id (Stream A) xs ys) 53 | (A : U) (x : A) (xs : Stream A) : 54 | (ys : Stream A) -> Bisimilar A (cons x xs) ys -> 55 | Id (Stream A) (cons x xs) ys = 56 | split 57 | cons y ys -> bisimilarityToId2 rec A x xs y ys 58 | 59 | bisimilarityToId 60 | (A : U) : 61 | (xs : Stream A) (ys : Stream A) -> 62 | Bisimilar A xs ys -> Id (Stream A) xs ys = 63 | split 64 | cons x xs -> bisimilarityToId1 bisimilarityToId A x xs 65 | 66 | -- Equality implies bisimilarity. 67 | 68 | idToBisimilarity1 69 | (rec : (A : U) (xs ys : Stream A) (eq : Id (Stream A) xs ys) -> 70 | Bisimilar A xs ys) 71 | (A : U) (x : A) (xs : Stream A) : 72 | (ys : Stream A) (eq : Id (Stream A) (cons x xs) ys) -> 73 | Bisimilar A (cons x xs) ys = 74 | split 75 | cons y ys -> 76 | \(eq : Id (Stream A) (cons x xs) (cons y ys)) -> 77 | consB ( head A (eq @ i)) 78 | (rec A xs ys ( tail A (eq @ i))) 79 | 80 | idToBisimilarity 81 | (A : U) : 82 | (xs ys : Stream A) (eq : Id (Stream A) xs ys) -> 83 | Bisimilar A xs ys = 84 | split 85 | cons x xs -> idToBisimilarity1 idToBisimilarity A x xs 86 | 87 | -- Round-tripping lemmas. 88 | 89 | bisimilarityToBisimilarity2 90 | (rec : (A : U) (xs ys : Stream A) (b : Bisimilar A xs ys) -> 91 | Id (Bisimilar A xs ys) 92 | (idToBisimilarity A xs ys (bisimilarityToId A xs ys b)) 93 | b) 94 | (A : U) (x : A) (xs : Stream A) (y : A) (ys : Stream A) : 95 | (b : Bisimilar A (cons x xs) (cons y ys)) -> 96 | Id (Bisimilar A (cons x xs) (cons y ys)) 97 | (idToBisimilarity A (cons x xs) (cons y ys) 98 | (bisimilarityToId A (cons x xs) (cons y ys) b)) 99 | b = 100 | split 101 | consB h t -> consB h ((rec A xs ys t) @ i) 102 | 103 | bisimilarityToBisimilarity1 104 | (rec : (A : U) (xs ys : Stream A) (b : Bisimilar A xs ys) -> 105 | Id (Bisimilar A xs ys) 106 | (idToBisimilarity A xs ys (bisimilarityToId A xs ys b)) 107 | b) 108 | (A : U) (x : A) (xs : Stream A) : 109 | (ys : Stream A) (b : Bisimilar A (cons x xs) ys) -> 110 | Id (Bisimilar A (cons x xs) ys) 111 | (idToBisimilarity A (cons x xs) ys 112 | (bisimilarityToId A (cons x xs) ys b)) 113 | b = 114 | split 115 | cons y ys -> bisimilarityToBisimilarity2 rec A x xs y ys 116 | 117 | bisimilarityToBisimilarity 118 | (A : U) : 119 | (xs ys : Stream A) (b : Bisimilar A xs ys) -> 120 | Id (Bisimilar A xs ys) 121 | (idToBisimilarity A xs ys (bisimilarityToId A xs ys b)) 122 | b = 123 | split 124 | cons x xs -> bisimilarityToBisimilarity1 125 | bisimilarityToBisimilarity 126 | A x xs 127 | 128 | -- TODO: Figure out if idToId is productive. 129 | 130 | idToId2 131 | (rec : (A : U) (xs ys : Stream A) (eq : Id (Stream A) xs ys) -> 132 | Id (Id (Stream A) xs ys) 133 | (bisimilarityToId A xs ys (idToBisimilarity A xs ys eq)) 134 | eq) 135 | (A : U) (x : A) (xs : Stream A) (y : A) (ys : Stream A) 136 | (eq : Id (Stream A) (cons x xs) (cons y ys)) : 137 | Id (Id (Stream A) (cons x xs) (cons y ys)) 138 | (bisimilarityToId A (cons x xs) (cons y ys) 139 | (idToBisimilarity A (cons x xs) (cons y ys) eq)) 140 | eq = 141 | comp (Stream A) 142 | (cons (head A (eq @ j)) 143 | (((rec A xs ys ( tail A (eq @ k))) @ i) @ j)) 144 | [ (i = 1) -> (eta A (eq @ j)) @ k ] 145 | 146 | idToId1 147 | (rec : (A : U) (xs ys : Stream A) (eq : Id (Stream A) xs ys) -> 148 | Id (Id (Stream A) xs ys) 149 | (bisimilarityToId A xs ys (idToBisimilarity A xs ys eq)) 150 | eq) 151 | (A : U) (x : A) (xs : Stream A) : 152 | (ys : Stream A) (eq : Id (Stream A) (cons x xs) ys) -> 153 | Id (Id (Stream A) (cons x xs) ys) 154 | (bisimilarityToId A (cons x xs) ys 155 | (idToBisimilarity A (cons x xs) ys eq)) 156 | eq = 157 | split 158 | cons y ys -> idToId2 rec A x xs y ys 159 | 160 | idToId 161 | (A : U) : 162 | (xs ys : Stream A) (eq : Id (Stream A) xs ys) -> 163 | Id (Id (Stream A) xs ys) 164 | (bisimilarityToId A xs ys (idToBisimilarity A xs ys eq)) 165 | eq = 166 | split 167 | cons x xs -> idToId1 idToId A x xs 168 | 169 | -- Bisimilarity is equal to equality. 170 | 171 | bisimilarityIsId 172 | (A : U) (xs ys : Stream A) : 173 | Id U (Bisimilar A xs ys) (Id (Stream A) xs ys) = 174 | isoId (Bisimilar A xs ys) 175 | (Id (Stream A) xs ys) 176 | (bisimilarityToId A xs ys) 177 | (idToBisimilarity A xs ys) 178 | (idToId A xs ys) 179 | (bisimilarityToBisimilarity A xs ys) 180 | -------------------------------------------------------------------------------- /experiments/testall.ctt: -------------------------------------------------------------------------------- 1 | module testall where 2 | 3 | import interval 4 | import uafunext2 5 | import prop 6 | import quotient 7 | import s2 8 | import uafunext1 9 | import list 10 | import newhedberg 11 | import other 12 | -- integer has to be after hedberg as it redefines neg 13 | import integer 14 | import pi1s2 15 | import pi4s3 16 | import mystery 17 | -------------------------------------------------------------------------------- /experiments/testempty.ctt: -------------------------------------------------------------------------------- 1 | -- This file tests some things where Coq gets stuck but cubicaltt don't 2 | -- It doesn't compile with the new definition of equiv 3 | module testempty where 4 | 5 | import nat 6 | import sigma 7 | 8 | empty : U = N0 9 | -- the eliminator is efq ("ex falso quodlibet") 10 | 11 | invmap (A B : U) : equiv A B -> B -> A = invEq A B 12 | 13 | homotinvweqweq (A B : U) (f : equiv A B) (x : A) : Id A (invmap A B f (f.1 x)) x = 14 | secEq A B f x 15 | 16 | subtypeEquality (A : U) (B : A -> U) (pB : (x : A) -> prop (B x)) 17 | (s t : (x : A) * B x) : Id A s.1 t.1 -> Id (sig A B) s t = 18 | trans (Id A s.1 t.1) (Id (sig A B) s t) rem 19 | where 20 | rem : Id U (Id A s.1 t.1) (Id (sig A B) s t) = 21 | lemSigProp A B pB s t @ -i 22 | 23 | 24 | -- special case of funext for maps into the empty type 25 | funextempty (A : U) (f g : A -> empty) : Id (A -> empty) f g = 26 | \(a : A) -> (rem a) @ i 27 | where rem (x : A) : Id empty (f x) (g x) = efq (Id empty (f x) (g x)) (f x) 28 | 29 | -- as this term is defined using funextempty Coq gets stuck: 30 | isapropneg (A : U) : prop (neg A) = funextempty A 31 | 32 | -- Nonzero nat 33 | X : U = (m : nat) * neg (Id nat m zero) 34 | 35 | -- nonzero nat is a set 36 | setX : set X = \(a b : X) -> 37 | setSig nat (\(m : nat) -> neg (Id nat m zero)) natSet rem' a b 38 | where 39 | rem' (m : nat) : set (neg (Id nat m zero)) = 40 | propSet (neg (Id nat m zero)) (isapropneg (Id nat m zero)) 41 | 42 | -- helper lemma: m != 0 -> 1 + (m - 1) = m 43 | natsucpredneq0 : (m : nat) -> neg (Id nat m zero) -> Id nat (suc (pred m)) m = split 44 | zero -> \(h : neg (Id nat zero zero)) -> 45 | efq (Id nat (suc (pred zero)) zero) (h ( zero)) 46 | suc n -> \(_ : neg (Id nat (suc n) zero)) -> suc n 47 | 48 | -- nat and nonzero nat are equivalent 49 | f : equiv nat X = (g,rem) 50 | where 51 | -- the map 52 | g (m : nat) : X = (suc m,snotz m) 53 | -- the proof that the map is an equivalence 54 | rem : isEquiv nat X g = (s,rem') 55 | where 56 | -- the fiber of g is inhabited, ie we have a center of contraction 57 | s (y : X) : fiber nat X g y = (x,rem1) 58 | where 59 | x : nat = pred y.1 60 | rem1 : Id X (g x) y = 61 | subtypeEquality nat (\(m : nat) -> neg (Id nat m zero)) rem2 (g x) y rem2' 62 | where 63 | rem2 (m : nat) : prop (neg (Id nat m zero)) = isapropneg (Id nat m zero) 64 | rem2' : Id nat (suc (pred y.1)) y.1 = natsucpredneq0 y.1 y.2 65 | 66 | -- any element in the fiber is equal to the center of contraction 67 | rem' (y : X) (w : fiber nat X g y) : Id (fiber nat X g y) (s y) w = 68 | subtypeEquality nat (\(x : nat) -> Id X (g x) y) 69 | (\(x : nat) -> setX (g x) y) (s y) w rem3' 70 | where 71 | w2 : Id nat (suc w.1) y.1 = (w.2 @ i).1 72 | rem3' : Id nat (pred y.1) w.1 = pred (w2 @ -i) -- this is pretty neat! 73 | 74 | 75 | -- some tests: 76 | 77 | two : nat = suc (suc zero) 78 | x : X = f.1 two 79 | 80 | -- this terminates in Coq: 81 | test1 : Id nat (invmap nat X f x) two = two 82 | 83 | -- this is where Coq gets stuck but cubicaltt works: 84 | test2 : Id (Id nat two two) (homotinvweqweq nat X f two) (refl nat two) = two 85 | 86 | -- The normal form of "homotinvweqweq nat X f two" is refl: 87 | -- > :n homotinvweqweq nat X f two 88 | -- NORMEVAL: suc (suc zero) 89 | -- Time: 0m4.105s 90 | -------------------------------------------------------------------------------- /experiments/thm7312.ctt: -------------------------------------------------------------------------------- 1 | module thm7312 where 2 | 3 | import setTrunc 4 | import groupoidTrunc 5 | import collection 6 | 7 | gTruncElim2 (A : U) (R : gTrunc A -> gTrunc A -> U) 8 | (tR : (x y : gTrunc A) -> groupoid (R x y)) 9 | (g:(a b : A) -> R (inc a) (inc b)) : (x y : gTrunc A) -> R x y = 10 | gTruncElim A P tP hP 11 | where 12 | P (x: gTrunc A) : U = (y : gTrunc A) -> R x y 13 | tP (x : gTrunc A) : groupoid (P x) = groupoidPi (gTrunc A) (R x) (tR x) 14 | hP (a : A) : P (inc a) = gTruncElim A (R (inc a)) (tR (inc a)) (g a) 15 | 16 | -- Theorem 7.3.12 17 | thm7312 (A : U) (x y : A) : Id U (sTrunc (Id A x y)) 18 | (Id (gTrunc A) (inc x) (inc y)) = lem3 (inc x) (inc y) 19 | where 20 | tA : U = gTrunc A 21 | 22 | tAtrunc : groupoid tA = gTr A 23 | 24 | P : tA -> tA -> SET 25 | = gTruncElim2 A (\ (z t: tA) -> SET) (\ (x t:tA) -> groupoidSET) 26 | (\ (x y:A) -> (sTrunc (Id A x y),sTr (Id A x y))) 27 | 28 | Q (u v: tA) : U = (P u v).1 29 | 30 | encode : (u v : tA) -> Q u v -> Id tA u v 31 | = gTruncElim2 A (\(u v:tA) -> Q u v -> Id tA u v) 32 | (\(u v:tA) -> setGroupoid (Q u v -> Id tA u v) (setFun (Q u v) (Id tA u v) (tAtrunc u v))) 33 | rem 34 | where 35 | rem (x y : A) : sTrunc (Id A x y) -> Id tA (inc x) (inc y) 36 | = sTruncRec (Id A x y) (Id tA (inc x) (inc y)) (tAtrunc (inc x) (inc y)) 37 | (\ (p:Id A x y) -> inc (p@i)) 38 | 39 | 40 | test (x : A) : Id U (Q (inc x) (inc x)) (sTrunc (Id A x x)) = refl U (sTrunc (Id A x x)) 41 | 42 | r : (u : tA) -> Q u u 43 | = gTruncElim A (\ (u:tA) -> Q u u) rem1 rem 44 | where 45 | rem1 (u : tA) : groupoid (Q u u) = setGroupoid (Q u u) (P u u).2 46 | rem (x : A) : sTrunc (Id A x x) = inc (refl A x) 47 | 48 | decode (u v : tA) (p:Id tA u v) : Q u v = subst tA (Q u) u v p (r u) -- J tA u (\v p -> Q u v) (r u) 49 | 50 | lem1 (u :tA) : (v : tA) (p : Id tA u v) -> Id (Id tA u v) (encode u v (decode u v p)) p 51 | = J tA u (\(v : tA) (p : Id tA u v) -> Id (Id tA u v) (encode u v (decode u v p)) p) (rem u) 52 | where 53 | T (u : tA) : U = Id (Id tA u u) (encode u u (decode u u (refl tA u))) (refl tA u) 54 | 55 | truncT (u : tA) : groupoid (T u) = 56 | setGroupoid (T u) (rem (encode u u (decode u u (refl tA u))) (refl tA u)) 57 | where 58 | rem : groupoid (Id tA u u) = setGroupoid (Id tA u u) (tAtrunc u u) 59 | 60 | rem : (u : tA) -> T u = gTruncElim A T truncT (\ (x:A) -> refl (Id tA (inc x) (inc x)) (refl tA (inc x))) 61 | 62 | 63 | lem2 : (u v : tA) (p : Q u v) -> Id (Q u v) (decode u v (encode u v p)) p 64 | = gTruncElim2 A R tR rem 65 | where 66 | R (u v : tA) : U = (p : Q u v) -> Id (Q u v) (decode u v (encode u v p)) p 67 | 68 | tR (u v : tA) : groupoid (R u v) 69 | = groupoidPi (Q u v) (\ (p:Q u v) -> Id (Q u v) (decode u v (encode u v p)) p) rem1 70 | where 71 | rem : groupoid (Q u v) = setGroupoid (Q u v) (P u v).2 72 | rem1 (p : Q u v) : groupoid (Id (Q u v) (decode u v (encode u v p)) p) 73 | = setGroupoid (Id (Q u v) (decode u v (encode u v p)) p) (rem (decode u v (encode u v p)) p) 74 | 75 | rem1 (x:A) : (y : A) (p : Id A x y) -> 76 | Id (sTrunc (Id A x y)) (decode (inc x) (inc y) (encode (inc x) (inc y) (inc p))) (inc p) 77 | = J A x (\ (y:A) (p:Id A x y) -> 78 | Id (sTrunc (Id A x y)) (decode (inc x) (inc y) (encode (inc x) (inc y) (inc p))) (inc p)) rem2 79 | where 80 | rem2 : Id (sTrunc (Id A x x)) (decode (inc x) (inc x) (encode (inc x) (inc x) (inc (refl A x)))) (inc (refl A x)) 81 | = refl (sTrunc (Id A x x)) (inc (refl A x)) 82 | 83 | rem (x y : A) : (p : sTrunc (Id A x y)) -> 84 | Id (sTrunc (Id A x y)) (decode (inc x) (inc y) (encode (inc x) (inc y) p)) p 85 | = sTruncElim (Id A x y) T tT (rem1 x y) 86 | where 87 | T (p: sTrunc (Id A x y)) : U = Id (sTrunc (Id A x y)) (decode (inc x) (inc y) (encode (inc x) (inc y) p)) p 88 | 89 | tT (p : sTrunc (Id A x y)) : set (T p) 90 | = setGroupoid (sTrunc (Id A x y)) (sTr (Id A x y)) 91 | (decode (inc x) (inc y) (encode (inc x) (inc y) p)) p 92 | 93 | 94 | lem3 (u v : tA) : Id U (Q u v) (Id tA u v) = 95 | isoId (Q u v) (Id tA u v) (encode u v) (decode u v) (lem1 u v) (lem2 u v) 96 | -------------------------------------------------------------------------------- /experiments/truncS2.ctt: -------------------------------------------------------------------------------- 1 | module truncS2 where 2 | 3 | import ex1 4 | import indSusp 5 | import susp 6 | import groupoidTrunc 7 | 8 | -- is X is a set then Id U (aLoop X) X 9 | 10 | lemLoopSet (X:U) (sX: set X) : Id U (aLoop X) X 11 | = isoId (aLoop X) X f g s t 12 | where 13 | f (z: aLoop X) : X = z.1 14 | g (x: X) : aLoop X = (x,refl X x) 15 | s (y : X) : Id X (f (g y)) y = refl X y 16 | t (z : aLoop X) : Id (aLoop X) (g (f z)) z = (z.1,sX z.1 z.1 (refl X z.1) z.2@i) 17 | 18 | lemS1Set (X : U) (sX: set X) : Id U (S1 -> X) X = 19 | compId U (S1 -> X) (aLoop X) X (thm X@-i) (lemLoopSet X sX) 20 | 21 | lemGrp1 (X : U) (gX: groupoid X) : Id U (suspOf S1 X) ((u:X) * (v : X) * Id X u v) 22 | = (u:X) * (v:X) * (lemS1Set (Id X u v) (gX u v) @ i) 23 | 24 | lemIdSig (X:U) : Id U ((u:X) * (v:X) * Id X u v) X = isoId ((u:X) * (v:X) * Id X u v) X f g s t 25 | where 26 | Z : U = (u:X) * (v:X) * Id X u v 27 | f (z:Z) : X = z.1 28 | g (x : X) : Z = (x,(x,refl X x)) 29 | s (y:X) : Id X (f (g y)) y = refl X y 30 | t (z:Z) : Id Z (g (f z)) z = (z.1,contrSingl X z.1 z.2.1 z.2.2 @ i) 31 | 32 | lemGrp2 (X : U) (gX:groupoid X) : Id U (suspOf S1 X) X = 33 | compId U (suspOf S1 X) ((u:X) * (v:X) * Id X u v) X (lemGrp1 X gX) (lemIdSig X) 34 | 35 | lemGrp3 (X : U) (gX: groupoid X) : Id U (S2 -> X) X = 36 | compId U (S2 -> X) (suspOf S1 X) X (funSusp S1 X) (lemGrp2 X gX) 37 | 38 | test (X:U) (gX: groupoid X) (f:S2 -> X) : X = transport (lemGrp3 X gX) f 39 | 40 | lemGrp4 (X : U) (gX:groupoid X) : Id U (gTrunc S2 -> X) X 41 | = compId U (gTrunc S2 -> X) (S2 -> X) X (univG S2 X gX) (lemGrp3 X gX) 42 | 43 | corr : Id U (gTrunc S2 -> gTrunc S2) (gTrunc S2) = lemGrp4 (gTrunc S2) (gTr S2) 44 | 45 | lemTransport (A B :U) (p : Id U A B) (a0 a1 : A) (h: Id B (transport p a0) (transport p a1)) : Id A a0 a1 = 46 | transport (Id (p@-i) (transport (p@(-i/\j)) a0) (transport (p@(-i/\j)) a1)) h 47 | 48 | 49 | corr1 : Id (gTrunc S2 -> gTrunc S2) (\ (x:gTrunc S2) -> x) (\ (x:gTrunc S2) -> inc north) = 50 | lemTransport (gTrunc S2 -> gTrunc S2) (gTrunc S2) corr 51 | (\ (x:gTrunc S2) -> x) (\ (x:gTrunc S2) -> inc north) (refl (gTrunc S2) (inc north)) 52 | 53 | corr2 (x:gTrunc S2) : Id (gTrunc S2) x (inc north) = corr1@i x 54 | 55 | propgTruncS2 : prop (gTrunc S2) = 56 | \ (x y : gTrunc S2) -> compId (gTrunc S2) x (inc north) y (corr2 x) (corr2 y@-i) 57 | 58 | 59 | test : Id (gTrunc S2) (inc south) (inc north) = corr2 (inc south) 60 | 61 | -- normal form 62 | 63 | test : Id (gTrunc S2) (inc south) (inc north) = 64 | inc (comp S2 north 65 | [ (i = 0) -> comp S2 south 66 | [ (j = 0) -> comp S2 north 67 | [ (k = 0) -> comp S2 south 68 | [ (l = 0) -> comp S2 north 69 | [ (m = 0) -> comp S2 south 70 | [ (n = 0) ->

comp S2 north 71 | [ (p = 0) -> comp S2 north [ (q = 1) -> merid {S2} base @ r ] ] ] ] ] ] ] ]) 72 | 73 | test1 : Id (gTrunc S2) (inc north) (inc north) = corr2 (inc north) 74 | 75 | test1 : Id (gTrunc S2) (inc north) (inc north) = compId (gTrunc S2) (inc north) (inc south) (inc north) (test@-i) test 76 | 77 | -- this should imply that any element in gTrunc (susp sone) is equal to inc north 78 | 79 | stwo : U = susp sone 80 | 81 | corr3 : (x:gTrunc stwo) -> Id (gTrunc stwo) x (inc north) = 82 | transport ((x:gTrunc (susp (s1EqCircle@-i))) -> Id (gTrunc (susp (s1EqCircle@-i))) x (inc north)) corr2 83 | 84 | test2 : Id (gTrunc stwo) (inc south) (inc north) = corr3 (inc south) 85 | 86 | -- normal form 87 | 88 | test2 : Id (gTrunc stwo) (inc south) (inc north) = 89 | inc (comp stwo north 90 | [ (i = 0) -> comp stwo south 91 | [ (j = 0) -> comp stwo north 92 | [ (k = 0) -> comp stwo south 93 | [ (l = 0) -> comp stwo north 94 | [ (m = 0) -> comp stwo south 95 | [ (n = 0) ->

comp stwo north 96 | [ (p = 0) -> comp stwo north 97 | [ (q = 1) -> merid {stwo} north @ r ] ] ] ] ] ] ] ]) 98 | -------------------------------------------------------------------------------- /experiments/uafunext1.ctt: -------------------------------------------------------------------------------- 1 | module uafunext1 where 2 | 3 | import prelude 4 | 5 | -- Proof that univalence implies funtion extensionality based on: 6 | -- http://homotopytypetheory.org/2014/02/17/another-proof-that-univalence-implies-function-extensionality/ 7 | 8 | homotopies (A B :U) : U = 9 | (fg : (_:A->B) * (A->B)) * (x:A) -> Id B (fg.1 x) (fg.2 x) 10 | 11 | Paths (A:U) : U = (x y:A) * Id A x y 12 | 13 | lemPaths (A:U) : Id U (Paths A) A = isoId (Paths A) A f g rems remt 14 | where 15 | f (z: Paths A) : A = z.1 16 | g (x:A) : Paths A = (x,(x,refl A x)) 17 | rems (y:A) : Id A (f (g y)) y = refl A y 18 | rem1t (x y:A) (p:Id A x y) : Id (Paths A) (x,(x,refl A x)) (x,(y,p)) = 19 | (x,(p@ i, p@ (i/\j))) 20 | remt (z:Paths A) : Id (Paths A) (g (f z)) z = rem1t z.1 z.2.1 z.2.2 21 | 22 | lem1 (A B :U) : Id U (A -> Paths B) (homotopies A B) = isoId T0 T1 f g t s 23 | where T0 : U = A -> Paths B 24 | T1 : U = homotopies A B 25 | f (h:T0) : T1 = ((\ (x:A) -> (h x).1,\ (x:A) -> (h x).2.1),\ (x:A) -> (h x).2.2) 26 | g (h : T1) : T0 = \ (x:A) -> (h.1.1 x,(h.1.2 x,h.2 x)) 27 | s (h:T0) : Id T0 (g (f h)) h = refl T0 h 28 | t (h : T1) : Id T1 (f (g h)) h = refl T1 h 29 | 30 | lem2 (A B : U) : Id U (A->B) (homotopies A B) = 31 | compId U (A->B) (A-> Paths B) (homotopies A B) rem (lem1 A B) 32 | where 33 | rem1 : Id U B (Paths B) = inv U (Paths B) B (lemPaths B) 34 | rem : Id U (A->B) (A-> Paths B) = A -> rem1 @ i 35 | 36 | thm (A B:U) : Id U (Paths (A->B)) (homotopies A B) = 37 | compId U (Paths (A->B)) (A->B) (homotopies A B) (lemPaths (A->B)) (lem2 A B) 38 | 39 | test (A B:U) (f:A->B) : Id (A->B) (transport (thm A B) (f,(f,refl (A->B) f))).1.2 f = 40 | refl (A->B) f 41 | 42 | funDepTr (A0 A1 :U) (p:Id U A0 A1) (u0:A0) (u1:A1) : 43 | Id U (IdP p u0 u1) (Id A1 (transport p u0) u1) = 44 | IdP ( p @ (i\/l)) (transport ( p @ (i/\l)) u0) u1 45 | 46 | lem3 (A B:U) (f:A->B) (h:homotopies A B) : Id U (IdP (thm A B) (f,(f,refl (A->B) f)) h) 47 | (Id (homotopies A B) (transport (thm A B) (f,(f,refl (A->B) f))) h) 48 | = funDepTr A0 A1 p u0 u1 49 | where A0 : U = Paths (A -> B) 50 | A1 : U = homotopies A B 51 | p : Id U A0 A1 = thm A B 52 | u0 : A0 = (f,(f,refl (A->B) f)) 53 | u1 : A1 = h 54 | 55 | lem4 (A B:U) (f g : A -> B) (p:Id (A->B) f g) (h:homotopies A B) (h1: IdP (thm A B) (f,(g,p)) h) 56 | : Id (A->B) f h.1.1 = 57 | rem h (transport (IdP (thm A B) (f,(p@-i,p@(-i/\j))) h) h1) 58 | where 59 | rem1 (h:homotopies A B) (h1: IdP (thm A B) (f,(f,refl (A->B) f)) h) : 60 | Id (homotopies A B) (transport (thm A B) (f,(f,refl (A->B) f))) h = transport (lem3 A B f h) h1 61 | rem (h:homotopies A B) (h1: IdP (thm A B) (f,(f,refl (A->B) f)) h) : 62 | Id (A->B) f h.1.1 = ((rem1 h h1) @ i).1.1 63 | 64 | lem5 (A B:U) (f g: A -> B) (p:Id (A->B) f g) (h:homotopies A B) (h1: IdP (thm A B) (f,(g,p)) h) 65 | : Id (A->B) g h.1.2 = 66 | rem h (transport (IdP (thm A B) (p@i,(g,p@(i\/j))) h) h1) 67 | where 68 | rem1 (h:homotopies A B) (h1: IdP (thm A B) (g,(g,refl (A->B) g)) h) : 69 | Id (homotopies A B) (transport (thm A B) (g,(g,refl (A->B) g))) h = transport (lem3 A B g h) h1 70 | 71 | rem (h:homotopies A B) (h1: IdP (thm A B) (g,(g,refl (A->B) g)) h) : 72 | Id (A->B) g h.1.2 = ((rem1 h h1) @ i).1.2 73 | 74 | funDepTrInv (A0 A1 :U) (p:Id U A0 A1) (u1:A1) : 75 | IdP p (transport (p@-i) u1) u1 = transport ( p @ (i\/-l)) u1 76 | 77 | homToP (A B:U) (h: homotopies A B) : Paths (A->B) = transport ((thm A B)@-i) h 78 | 79 | lem6 (A B:U) : (h:homotopies A B) -> IdP (thm A B) (homToP A B h) h = 80 | funDepTrInv (Paths (A->B)) (homotopies A B) (thm A B) 81 | 82 | lem7 (A B:U) (h:homotopies A B) : Id (A->B) (homToP A B h).1 h.1.1 = 83 | lem4 A B p.1 p.2.1 p.2.2 h (lem6 A B h) 84 | where p : Paths (A->B) = homToP A B h 85 | 86 | lem8 (A B:U) (h:homotopies A B) : Id (A->B) (homToP A B h).2.1 h.1.2 = 87 | lem5 A B p.1 p.2.1 p.2.2 h (lem6 A B h) 88 | where p : Paths (A->B) = homToP A B h 89 | 90 | funext (A B:U) (f g :A -> B) (pe : (x:A) -> Id B (f x) (g x)) : Id (A->B) f g = 91 | \ (x:A) -> ((transport rem4 rem3) @ i) x 92 | where 93 | h : homotopies A B = ((f,g),pe) 94 | p : Paths (A->B) = homToP A B h 95 | rem1 : Id (A->B) p.1 f = lem7 A B h 96 | rem2 : Id (A->B) p.2.1 g = lem8 A B h 97 | rem3 : Id (A->B) p.1 p.2.1 = p.2.2 98 | rem4 : Id U (Id (A->B) p.1 p.2.1) (Id (A->B) f g) = Id (A->B) (rem1@i) (rem2@i) 99 | 100 | 101 | -------------------------------------------------------------------------------- /experiments/uafunext2.ctt: -------------------------------------------------------------------------------- 1 | module uafunext2 where 2 | 3 | import retract 4 | import equiv 5 | 6 | lem1 (A:U) (P:A-> U) (cA:(x:A) -> isContr (P x)) : Id U ((x:A)*P x) A = isoId T A f g t s 7 | where 8 | T : U = (x:A) * P x 9 | f (z:T) : A = z.1 10 | g (x:A) : T = (x,(cA x).2) 11 | s (z:T) : Id T (g (f z)) z = (z.1,((cA z.1).1 (cA z.1).2 z.2)@ i) 12 | t (x:A) : Id A (f (g x)) x = refl A x 13 | 14 | lem2 (A:U) (P:A-> U) (cA:(x:A) -> isContr (P x)) : Id U (A -> (x:A)*P x) (A->A) = 15 | A -> (lem1 A P cA)@ i 16 | 17 | alpha (A:U) (P:A-> U) (cA:(x:A) -> isContr (P x)) (u:A -> (x:A)*P x) : A -> A = 18 | transport (lem2 A P cA) u 19 | 20 | test (A:U) (P:A-> U) (cA:(x:A) -> isContr (P x)) (u : A -> (x:A)*P x) (x:A) : 21 | Id A (alpha A P cA u x) (u x).1 = refl A (u x).1 22 | 23 | lemTransFib (A:U) : (B:U) (E:Id U A B) (b:B) -> prop (fiber A B (\ (x:A) -> transport E x) b) = 24 | J U A (\ (B:U) (E:Id U A B) -> (b:B) -> prop (fiber A B (\ (x:A) -> transport E x) b)) (lemIdFib A) 25 | 26 | fibId (A:U) (P:A-> U) (cA:(x:A) -> isContr (P x)) : U = fiber (A -> (x:A)*P x) (A -> A) (alpha A P cA) (idfun A) 27 | 28 | corr1 (A:U) (P:A-> U) (cA:(x:A) -> isContr (P x)) : prop (fibId A P cA) = 29 | lemTransFib (A -> (x:A)*P x) (A -> A) (lem2 A P cA) (idfun A) 30 | 31 | phi (A:U) (P:A-> U) (cA:(x:A) -> isContr (P x)) (f:(x:A) -> P x) : fibId A P cA = 32 | (\ (x:A) -> (x,f x),refl (A->A) (idfun A)) 33 | 34 | psi (A:U) (P:A-> U) (cA:(x:A) -> isContr (P x)) (up : fibId A P cA) (x:A) : P x = 35 | subst (A -> A) (\ (g:A->A) -> P (g x)) (alpha A P cA u) (idfun A) (p@-i) (u x).2 36 | where u : A -> (y:A) * P y = up.1 37 | p : Id (A -> A) (idfun A) (alpha A P cA u) = up.2 38 | 39 | retPhiPsi (A:U) (P:A-> U) (cA:(x:A) -> isContr (P x)) (f : (x:A) -> P x) : 40 | Id ((x:A) -> P x) (psi A P cA (phi A P cA f)) f = refl ((x:A) -> P x) f 41 | 42 | thm (A:U) (P:A-> U) (cA:(x:A) -> isContr (P x)) : prop ((x:A) -> P x) = 43 | retractProp ((x:A) -> P x) (fibId A P cA) (phi A P cA) (psi A P cA) (retPhiPsi A P cA) (corr1 A P cA) 44 | 45 | sumF (A B:U) (f:A -> B) : U = (g:A->B) * (x:A) -> Id B (f x) (g x) 46 | prodF (A B:U) (f:A -> B) : U = (x:A) -> (y:B) * Id B (f x) y 47 | 48 | lemProdF (A B:U) (f:A -> B) : prop (prodF A B f) = thm A P cA 49 | where P (x:A) : U = (y:B) * Id B (f x) y 50 | cA (x:A) : isContr (P x) = (lemIdFib B (f x),(f x,refl B (f x))) 51 | 52 | sumToProd (A B:U) (f:A -> B) (gp : sumF A B f) : prodF A B f = \ (x:A) -> (gp.1 x,gp.2 x) 53 | prodToSum (A B:U) (f:A -> B) (h : prodF A B f) : sumF A B f = (\ (x:A) -> (h x).1,\ (x:A) -> (h x).2) 54 | 55 | retSP (A B:U) (f:A->B) (gp:sumF A B f) : Id (sumF A B f) (prodToSum A B f (sumToProd A B f gp)) gp = 56 | refl (sumF A B f) gp 57 | 58 | corr2 (A B:U) (f:A->B) : prop (sumF A B f) = 59 | retractProp (sumF A B f) (prodF A B f) (sumToProd A B f) (prodToSum A B f) (retSP A B f) (lemProdF A B f) 60 | 61 | funext (A B:U) (f g:A -> B) (h:(x:A) -> Id B (f x) (g x)) : Id (A->B) f g = \ (x:A) -> (rem@i).1 x 62 | where rem : Id (sumF A B f) (f,\ (x:A) -> refl B (f x)) (g,h) = corr2 A B f (f,\ (x:A) -> refl B (f x)) (g,h) 63 | -------------------------------------------------------------------------------- /experiments/univalence.ctt: -------------------------------------------------------------------------------- 1 | -- The old version of univalence using the old definition of equivalences 2 | module univalence where 3 | 4 | import isoToEquiv 5 | 6 | transEquivToId (A B : U) (w : equiv A B) : Id U A B = 7 | glue B [ (i = 1) -> (B,eB) 8 | , (i = 0) -> (A,w) ] 9 | where eB : equiv B B = transDelta B 10 | 11 | eqToEq (A B : U) (p : Id U A B) 12 | : Id (Id U A B) (transEquivToId A B (transEquiv A B p)) p 13 | = let e : equiv A B = transEquiv A B p 14 | f : equiv B B = transDelta B 15 | Ai : U = p@i 16 | g : equiv Ai B = transEquiv Ai B ( p @ (i \/ k)) 17 | in glue B 18 | [ (i = 0) -> (A,e.1,invEq A B e,retEq A B e,secEq A B e) 19 | , (i = 1) -> (B,f.1,invEq B B f,retEq B B f,secEq B B f) 20 | , (j = 1) -> (p@i,g.1,invEq Ai B g,retEq Ai B g,secEq Ai B g) ] 21 | 22 | transIdFun (A B : U) (w : equiv A B) 23 | : Id (A -> B) (trans A B (transEquivToId A B w)) w.1 = 24 | \(a : A) -> let b : B = w.1 a 25 | in addf (f (f (f b))) b (addf (f (f b)) b (addf (f b) b (trf b))) @ i 26 | where f (b : B) : B = comp (<_> B) b [] 27 | trf (b : B) : Id B (f b) b = 28 | fill (<_> B) b [] @ -i 29 | addf (b b' : B) : Id B b b' -> Id B (f b) b' = 30 | compId B (f b) b b' (trf b) 31 | 32 | idToId (A B : U) (w : equiv A B) 33 | : Id (equiv A B) (transEquiv A B (transEquivToId A B w)) w 34 | = equivLemma A B (transEquiv A B (transEquivToId A B w)) w 35 | (transIdFun A B w) 36 | 37 | transEquivIsEquiv (A B : U) 38 | : isEquiv (Id U A B) (equiv A B) (transEquiv A B) 39 | = isoToEquiv (Id U A B) (equiv A B) (transEquiv A B) 40 | (transEquivToId A B) (idToId A B) (eqToEq A B) 41 | 42 | univalence (A B : U) : equiv (Id U A B) (equiv A B) = 43 | (transEquiv A B,transEquivIsEquiv A B) 44 | 45 | univalence1 (A B:U) : Id U (Id U A B) (equiv A B) = 46 | isoId (Id U A B) (equiv A B) (transEquiv A B) (transEquivToId A B) (idToId A B) (eqToEq A B) 47 | 48 | 49 | -- This takes too long to normalize: 50 | test (A : U) : Id (equiv A A) (transEquiv A A (transEquivToId A A (idEquiv A))) (idEquiv A) = 51 | idToId A A (idEquiv A) 52 | 53 | 54 | -- The canonical map defined using J 55 | canIdToEquiv (A : U) : (B : U) -> Id U A B -> equiv A B = 56 | J U A (\ (B : U) (_ : Id U A B) -> equiv A B) (idEquiv A) 57 | 58 | canDiagTrans (A : U) : Id (A -> A) (canIdToEquiv A A (<_> A)).1 (idfun A) = 59 | fill (<_> A -> A) (idfun A) [] @ -i 60 | 61 | transDiagTrans (A : U) : Id (A -> A) (idfun A) (trans A A (<_> A)) = 62 | \ (a : A) -> fill (<_> A) a [] @ i 63 | 64 | canIdToEquivLem (A : U) : (B : U) (p : Id U A B) -> 65 | Id (A -> B) (canIdToEquiv A B p).1 (transEquiv A B p).1 66 | = J U A 67 | (\ (B : U) (p : Id U A B) -> 68 | Id (A -> B) (canIdToEquiv A B p).1 (transEquiv A B p).1) 69 | (compId (A -> A) 70 | (canIdToEquiv A A (<_> A)).1 (idfun A) (trans A A (<_> A)) 71 | (canDiagTrans A) (transDiagTrans A)) 72 | 73 | canIdToEquivIsTransEquiv (A B : U) : 74 | Id (Id U A B -> equiv A B) (canIdToEquiv A B) (transEquiv A B) = 75 | \ (p : Id U A B) -> 76 | equivLemma A B (canIdToEquiv A B p) (transEquiv A B p) 77 | (canIdToEquivLem A B p) @ i 78 | 79 | -- The canonical map is an equivalence 80 | univalence2 (A B : U) : isEquiv (Id U A B) (equiv A B) (canIdToEquiv A B) = 81 | substInv (Id U A B -> equiv A B) 82 | (isEquiv (Id U A B) (equiv A B)) 83 | (canIdToEquiv A B) (transEquiv A B) 84 | (canIdToEquivIsTransEquiv A B) 85 | (transEquivIsEquiv A B) 86 | -------------------------------------------------------------------------------- /lectures/README.md: -------------------------------------------------------------------------------- 1 | Cubical Type Theory: lectures 2 | ============================= 3 | 4 | This folder contains four lectures given by Anders at Inria Sophia 5 | Antipolis in May-June 2017. The lectures cover the main features of 6 | the system and doesn't assume any prior knowledge of homotopy type 7 | theory or univalent foundations. Only basic familiarity with type 8 | theory and proof assistants based on type theory (e.g. Coq or Agda) is 9 | assumed. 10 | 11 | The contents of the lectures are: 12 | 13 | ### lecture1.ctt 14 | * Basic features of the base type theory 15 | * A little bit of Path types (Path abstraction and application) 16 | 17 | ### lecture2.ctt 18 | * More on Path types (symmetry and connections) 19 | * Compositions 20 | 21 | ### lecture3.ctt 22 | * Higher dimensional compositions 23 | * Transport and J for Path types 24 | * Fill 25 | * H-levels (contractible types, propositions, sets, groupoids...) 26 | 27 | ### lecture4.ctt 28 | * Equivalences 29 | * Glue types 30 | * Proofs of the univalence axiom 31 | 32 | The lectures hence give a hands-on introduction covering sections 2-7 33 | of the [paper](https://arxiv.org/abs/1611.02108). -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.12 2 | 3 | packages: 4 | - . 5 | extra-deps: 6 | - BNFC-2.9.5 7 | 8 | flags: {} 9 | 10 | extra-package-dbs: [] 11 | -------------------------------------------------------------------------------- /utils/graph: -------------------------------------------------------------------------------- 1 | (echo "digraph {"; grep import *ctt | sed 's/\(.*\).ctt:import \([a-zA-Z0-9]*\)/\2 -> \1/'; echo "}") | dot -Tpng > graph.png -------------------------------------------------------------------------------- /utils/testall: -------------------------------------------------------------------------------- 1 | # Script for checking that all files compile 2 | 3 | files="binnat bool category circle collection csystem demo discor 4 | equiv groupoidTrunc hedberg helix hnat hz idtypes injective int 5 | integer interval list nat ordinal pi prelude propTrunc retract 6 | setquot sigma subset summary susp torsor torus univalence" 7 | 8 | for file in $files 9 | do 10 | ./cubical -b examples/$file.ctt 11 | done --------------------------------------------------------------------------------