├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── dune-project ├── ptt.opam ├── src ├── bin │ ├── dune │ └── main.ml └── lib │ ├── check.ml │ ├── check.mli │ ├── concrete_syntax.ml │ ├── concrete_syntax.mli │ ├── domain.ml │ ├── domain.mli │ ├── driver.ml │ ├── driver.mli │ ├── dune │ ├── eval.ml │ ├── eval.mli │ ├── grammar.mly │ ├── lex.mll │ ├── load.ml │ ├── load.mli │ ├── mode.ml │ ├── mode.mli │ ├── option.ml │ ├── option.mli │ ├── quote.ml │ ├── quote.mli │ ├── syntax.ml │ └── syntax.mli ├── test.sh └── test ├── basic.ptt ├── bch.ptt ├── binary_to_quarternary.ptt ├── church_naturals.ptt ├── codisc.ptt ├── const_nat.ptt ├── discrete.ptt ├── extent.ptt ├── gel.ptt ├── identity.ptt ├── leibniz.ptt ├── line.ptt ├── n-ary.ptt ├── nat_nullary_const.ptt ├── no-lem.ptt ├── no-wlem.ptt ├── queue.ptt └── relativity.ptt /.gitignore: -------------------------------------------------------------------------------- 1 | _opam 2 | *.install 3 | doc/syntax.pdf 4 | 5 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/Emacs.gitignore 6 | 7 | # -*- mode: gitignore; -*- 8 | *~ 9 | \#*\# 10 | /.emacs.desktop 11 | /.emacs.desktop.lock 12 | *.elc 13 | auto-save-list 14 | tramp 15 | .\#* 16 | 17 | # Org-mode 18 | .org-id-locations 19 | *_archive 20 | 21 | # flymake-mode 22 | *_flymake.* 23 | 24 | # eshell files 25 | /eshell/history 26 | /eshell/lastdir 27 | 28 | # elpa packages 29 | /elpa/ 30 | 31 | # reftex files 32 | *.rel 33 | 34 | # AUCTeX auto folder 35 | auto/ 36 | 37 | # cask packages 38 | .cask/ 39 | dist/ 40 | 41 | # Flycheck 42 | flycheck_*.el 43 | 44 | # server auth directory 45 | /server/ 46 | 47 | # projectiles files 48 | .projectile 49 | 50 | # directory configuration 51 | .dir-locals.el 52 | 53 | 54 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/Linux.gitignore 55 | 56 | *~ 57 | 58 | # temporary files which can be created if a process still has a handle open of a deleted file 59 | .fuse_hidden* 60 | 61 | # KDE directory preferences 62 | .directory 63 | 64 | # Linux trash folder which might appear on any partition or disk 65 | .Trash-* 66 | 67 | # .nfs files are created when an open file is removed but is still being accessed 68 | .nfs* 69 | 70 | 71 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/macOS.gitignore 72 | 73 | # General 74 | .DS_Store 75 | .AppleDouble 76 | .LSOverride 77 | 78 | # Icon must end with two \r 79 | Icon 80 | 81 | 82 | # Thumbnails 83 | ._* 84 | 85 | # Files that might appear in the root of a volume 86 | .DocumentRevisions-V100 87 | .fseventsd 88 | .Spotlight-V100 89 | .TemporaryItems 90 | .Trashes 91 | .VolumeIcon.icns 92 | .com.apple.timemachine.donotpresent 93 | 94 | # Directories potentially created on remote AFP share 95 | .AppleDB 96 | .AppleDesktop 97 | Network Trash Folder 98 | Temporary Items 99 | .apdisk 100 | 101 | 102 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/OCaml.gitignore 103 | 104 | *.annot 105 | *.cmo 106 | *.cma 107 | *.cmi 108 | *.a 109 | *.o 110 | *.cmx 111 | *.cmxs 112 | *.cmxa 113 | 114 | # ocamlbuild working directory 115 | _build/ 116 | 117 | # ocamlbuild targets 118 | *.byte 119 | *.native 120 | 121 | # oasis generated files 122 | setup.data 123 | setup.log 124 | 125 | # Merlin configuring file for Vim and Emacs 126 | .merlin 127 | 128 | 129 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/SublimeText.gitignore 130 | 131 | # Cache files for Sublime Text 132 | *.tmlanguage.cache 133 | *.tmPreferences.cache 134 | *.stTheme.cache 135 | 136 | # Workspace files are user-specific 137 | *.sublime-workspace 138 | 139 | # Project files should be checked into the repository, unless a significant 140 | # proportion of contributors will probably not be using Sublime Text 141 | # *.sublime-project 142 | 143 | # SFTP configuration file 144 | sftp-config.json 145 | 146 | # Package control specific files 147 | Package Control.last-run 148 | Package Control.ca-list 149 | Package Control.ca-bundle 150 | Package Control.system-ca-bundle 151 | Package Control.cache/ 152 | Package Control.ca-certs/ 153 | Package Control.merged-ca-bundle 154 | Package Control.user-ca-bundle 155 | oscrypto-ca-bundle.crt 156 | bh_unicode_properties.cache 157 | 158 | # Sublime-github package stores a github token in this file 159 | # https://packagecontrol.io/packages/sublime-github 160 | GitHub.sublime-settings 161 | 162 | 163 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/TeX.gitignore 164 | 165 | ## Core latex/pdflatex auxiliary files: 166 | *.aux 167 | *.lof 168 | *.log 169 | *.lot 170 | *.fls 171 | *.out 172 | *.toc 173 | *.fmt 174 | *.fot 175 | *.cb 176 | *.cb2 177 | 178 | ## Intermediate documents: 179 | *.dvi 180 | *.xdv 181 | *-converted-to.* 182 | # these rules might exclude image files for figures etc. 183 | # *.ps 184 | # *.eps 185 | # *.pdf 186 | 187 | ## Generated if empty string is given at "Please type another file name for output:" 188 | .pdf 189 | 190 | ## Bibliography auxiliary files (bibtex/biblatex/biber): 191 | *.bbl 192 | *.bcf 193 | *.blg 194 | *-blx.aux 195 | *-blx.bib 196 | *.run.xml 197 | 198 | ## Build tool auxiliary files: 199 | *.fdb_latexmk 200 | *.synctex 201 | *.synctex(busy) 202 | *.synctex.gz 203 | *.synctex.gz(busy) 204 | *.pdfsync 205 | 206 | ## Auxiliary and intermediate files from other packages: 207 | # algorithms 208 | *.alg 209 | *.loa 210 | 211 | # achemso 212 | acs-*.bib 213 | 214 | # amsthm 215 | *.thm 216 | 217 | # beamer 218 | *.nav 219 | *.pre 220 | *.snm 221 | *.vrb 222 | 223 | # changes 224 | *.soc 225 | 226 | # cprotect 227 | *.cpt 228 | 229 | # elsarticle (documentclass of Elsevier journals) 230 | *.spl 231 | 232 | # endnotes 233 | *.ent 234 | 235 | # fixme 236 | *.lox 237 | 238 | # feynmf/feynmp 239 | *.mf 240 | *.mp 241 | *.t[1-9] 242 | *.t[1-9][0-9] 243 | *.tfm 244 | 245 | #(r)(e)ledmac/(r)(e)ledpar 246 | *.end 247 | *.?end 248 | *.[1-9] 249 | *.[1-9][0-9] 250 | *.[1-9][0-9][0-9] 251 | *.[1-9]R 252 | *.[1-9][0-9]R 253 | *.[1-9][0-9][0-9]R 254 | *.eledsec[1-9] 255 | *.eledsec[1-9]R 256 | *.eledsec[1-9][0-9] 257 | *.eledsec[1-9][0-9]R 258 | *.eledsec[1-9][0-9][0-9] 259 | *.eledsec[1-9][0-9][0-9]R 260 | 261 | # glossaries 262 | *.acn 263 | *.acr 264 | *.glg 265 | *.glo 266 | *.gls 267 | *.glsdefs 268 | 269 | # gnuplottex 270 | *-gnuplottex-* 271 | 272 | # gregoriotex 273 | *.gaux 274 | *.gtex 275 | 276 | # hyperref 277 | *.brf 278 | 279 | # knitr 280 | *-concordance.tex 281 | # TODO Comment the next line if you want to keep your tikz graphics files 282 | *.tikz 283 | *-tikzDictionary 284 | 285 | # listings 286 | *.lol 287 | 288 | # makeidx 289 | *.idx 290 | *.ilg 291 | *.ind 292 | *.ist 293 | 294 | # minitoc 295 | *.maf 296 | *.mlf 297 | *.mlt 298 | *.mtc[0-9]* 299 | *.slf[0-9]* 300 | *.slt[0-9]* 301 | *.stc[0-9]* 302 | 303 | # minted 304 | _minted* 305 | *.pyg 306 | 307 | # morewrites 308 | *.mw 309 | 310 | # nomencl 311 | *.nlo 312 | 313 | # pax 314 | *.pax 315 | 316 | # pdfpcnotes 317 | *.pdfpc 318 | 319 | # sagetex 320 | *.sagetex.sage 321 | *.sagetex.py 322 | *.sagetex.scmd 323 | 324 | # scrwfile 325 | *.wrt 326 | 327 | # sympy 328 | *.sout 329 | *.sympy 330 | sympy-plots-for-*.tex/ 331 | 332 | # pdfcomment 333 | *.upa 334 | *.upb 335 | 336 | # pythontex 337 | *.pytxcode 338 | pythontex-files-*/ 339 | 340 | # thmtools 341 | *.loe 342 | 343 | # TikZ & PGF 344 | *.dpth 345 | *.md5 346 | *.auxlock 347 | 348 | # todonotes 349 | *.tdo 350 | 351 | # easy-todo 352 | *.lod 353 | 354 | # xindy 355 | *.xdy 356 | 357 | # xypic precompiled matrices 358 | *.xyc 359 | 360 | # endfloat 361 | *.ttt 362 | *.fff 363 | 364 | # Latexian 365 | TSWLatexianTemp* 366 | 367 | ## Editors: 368 | # WinEdt 369 | *.bak 370 | *.sav 371 | 372 | # Texpad 373 | .texpadtmp 374 | 375 | # Kile 376 | *.backup 377 | 378 | # KBibTeX 379 | *~[0-9]* 380 | 381 | # auto folder when using emacs and auctex 382 | /auto/* 383 | 384 | # expex forward references with \gathertags 385 | *-tags.tex 386 | 387 | 388 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/Vim.gitignore 389 | 390 | # Swap 391 | [._]*.s[a-v][a-z] 392 | [._]*.sw[a-p] 393 | [._]s[a-v][a-z] 394 | [._]sw[a-p] 395 | 396 | # Session 397 | Session.vim 398 | 399 | # Temporary 400 | .netrwhist 401 | *~ 402 | # Auto-generated tag files 403 | tags 404 | 405 | 406 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/VisualStudioCode.gitignore 407 | 408 | .vscode/* 409 | !.vscode/settings.json 410 | !.vscode/tasks.json 411 | !.vscode/launch.json 412 | !.vscode/extensions.json 413 | 414 | 415 | # redtt is also writing something! Taste It! 416 | *.rot 417 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Original Copyright 2019 Daniel Gratzer, Jonathan Sterling, Lars Birkedal 2 | Modified Copyright 2020 Evan Cavallo 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and 5 | associated documentation files (the "Software"), to deal in the Software without restriction, 6 | including without limitation the rights to use, copy, modify, merge, publish, distribute, 7 | sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all copies or substantial 11 | portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT 14 | NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 15 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES 16 | OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 17 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 18 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | OPAM=opam 2 | EXEC=${OPAM} config exec 3 | DUNE=${EXEC} dune -- 4 | 5 | .PHONY: all build clean test top test 6 | 7 | all: build 8 | 9 | build: 10 | @${DUNE} build @install 11 | 12 | clean: 13 | @${DUNE} clean 14 | 15 | doc: 16 | @${DUNE} build @doc 17 | 18 | install: 19 | ${OPAM} reinstall ptt 20 | 21 | test: 22 | @./test.sh 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ptt 2 | 3 | An experimental implementation of normalization by evaluation (nbe) & semantic type checking for a Martin-Löf 4 | Type Theory with *n*-ary internal parametricity. This repository uses 5 | [`blott`](https://github.com/jozefg/blott), an implementation of modal dependent type theory, as a base; the modal constructs have been removed and replaced with internal parametricity primitives. 6 | 7 | The type theory implemented here is roughly that of [Cavallo and Harper](https://doi.org/10.4230/LIPIcs.CSL.2020.13), but is based on intensional Martin-Löf type theory rather than cubical type theory. It is thus in turn similar to that of [Bernardy, Coquand, and Moulin](https://research.chalmers.se/publication/230735). One change relative to these theories, motivated by implementation concerns, is the formulation of Gel/Ψ-types as positive (with an elimination principle) rather than negative (with a projection and eta-principle). 8 | 9 | To enable experimentation, we include *n*-ary parametricity primitives for every (concrete) *n*. We observe, however, that iterated binary parametricity suffices to encode *n*-ary parametricity for all *n*. There is no direct interaction between parametricity primitives of different arity. 10 | 11 | For examples, see the `test/` directory. 12 | 13 | ## Syntax 14 | 15 | Syntax | Description 16 | --- | --- 17 | `[x] A {a0; ...; an}` | Type of bridges across `A` in dimension `x` with endpoints `a1`,...,`an` 18 | `bri x -> a` | Bridge abstraction 19 | `p @ x` | Bridge application 20 | `Gel x {A1; ...; An} (a1 ... an -> R)` | Gel-type for an *n*-ary relation `R(a1,...,an)` on types `A1`,...,`An`. As a special case, 0-ary Gel types are simply written `Gel x A` 21 | `gel x {a1; ...; an} b` | Constructor for elements of Gel-type 22 | `ungel x : n -> p at q -> C with`
`\| gel b -> t` | Elimination from bridges `x.p` over an *n*-ary Gel-type into a type family `q.C` 23 | `extent x of t in y -> A at y a -> B with`
`\| a0 -> b0`
`\| ...`
`\| an -> bn`
`\| a1 ... an q y -> b` | *n*-ary extent term mapping from `A` to `B`, casing on `x` in `t : A`, with endpoint cases `b0`,...`bn` and bridge case `b` 24 | 25 | Bridge-types with partially-specified endpoints can be defined using the wildcard `*`; for example, `[x] A {a0; *}` is the type of binary bridges whose `0` endpoint is `a0`. The type `[x] A {a0; a1}` is a sub-type of `[x] A {a0; *}`, but a term `p : [x] A {a0; *}` cannot be used as an element of `[x] A {a0; p @ 1}` without eta-expansion. 26 | 27 | ## Building 28 | 29 | ptt has been built with OCaml 4.06.1 and 4.07.1 with [opam 2.0](https://opam.ocaml.org/). Once 30 | these dependencies are installed ptt can be built with the following set of commands. 31 | 32 | ``` 33 | $ opam update 34 | $ opam pin add -y ptt . # first time 35 | $ opam upgrade # after packages change 36 | ``` 37 | 38 | After this, the executable `ptt` should be available. The makefile can be used to rebuild the 39 | package for small tests. Locally, ptt is built with [dune](https://dune.build), running the above 40 | commands will also install dune. Once dune is available the executable can be locally changed and 41 | run on a file `[file]` with the following: 42 | 43 | ``` 44 | $ dune exec ./src/bin/main.exe [file] # from the `ptt` top-level directory 45 | ``` 46 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (using menhir 1.0) 3 | -------------------------------------------------------------------------------- /ptt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "ptt" 3 | version: "0.0" 4 | depends: [ 5 | "dune" {build} 6 | "ppx_deriving" {> "4.0"} 7 | "cmdliner" {>= "1.0" & < "1.1"} 8 | "menhir" {>= "20180703"} 9 | ] 10 | build: [["dune" "build" "-p" name "-j" jobs]] 11 | -------------------------------------------------------------------------------- /src/bin/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names main) 3 | (libraries ptt.core cmdliner)) 4 | 5 | (install 6 | (section bin) 7 | (package ptt) 8 | (files (main.exe as ptt))) 9 | -------------------------------------------------------------------------------- /src/bin/main.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Cmdliner 3 | 4 | let execute input = Load.load_file input |> Driver.process_sign 5 | 6 | let main input = 7 | try execute input; 0 with 8 | | Invalid_argument s -> Printf.eprintf "Internal error (invalid argument): %s\n" s; 1 9 | | Failure s -> Printf.eprintf "Internal error (Failure): %s\n" s; 1 10 | | Load.Parse_error s -> Printf.eprintf "Frontend error: %s" s; 1 11 | | Eval.Eval_failed s -> Printf.eprintf "Internal error (Failed to evaluate): %s\n" s; 1 12 | | Quote.Quote_failed s -> Printf.eprintf "Internal error (Failed to quote): %s\n" s; 1 13 | | Check.Type_error e -> 14 | Printf.eprintf "Type error: "; 15 | Check.pp_error Format.err_formatter e; 16 | Format.pp_print_flush Format.err_formatter (); 17 | 1 18 | 19 | let input_file = 20 | let doc = "File containing the program to type-check" in 21 | Arg.(required & pos ~rev:true 0 (some string) None & info [] ~doc ~docv:"FILE") 22 | 23 | let info = 24 | let doc = "TODO" in 25 | let err_exit = Term.exit_info ~doc:"on an ill-formed types or terms." 1 in 26 | Term.info "ptt" ~version:"0.0" ~doc ~exits:(err_exit :: Term.default_exits) 27 | 28 | let () = 29 | let t = Term.(const main $ input_file) in 30 | Term.exit_status @@ Term.eval (t, info) 31 | -------------------------------------------------------------------------------- /src/lib/check.ml: -------------------------------------------------------------------------------- 1 | (* This file implements the semantic type-checking algorithm described in the paper. *) 2 | module M = Mode 3 | module D = Domain 4 | module Syn = Syntax 5 | module E = Eval 6 | module Q = Quote 7 | 8 | type env_entry = 9 | | DVar of {level : D.lvl; width : int} 10 | | Var of {level : D.lvl; tp : D.t; modality : M.modality} 11 | | Def of {term : D.t; tp : D.t} 12 | | Restrict of Syn.idx 13 | | Lock of M.modality 14 | | TopLevel of {mode : M.mode; term : D.t; tp : D.t} 15 | | Postulate of {mode : M.mode; level : D.lvl; tp : D.t} 16 | [@@deriving show, eq] 17 | type env = env_entry list 18 | [@@deriving show, eq] 19 | 20 | type error = 21 | Cannot_synth_term of Syn.t 22 | | Mode_mismatch of M.mode * M.mode 23 | | Dim_mismatch of D.dim * D.dim 24 | | Type_mismatch of Syn.t * Syn.t 25 | | Expecting_universe of D.t 26 | | Expecting_term of D.lvl 27 | | Expecting_of of string * D.t 28 | | Misc of string 29 | 30 | let pp_error fmt = function 31 | | Cannot_synth_term t -> 32 | Format.fprintf fmt "@[ Cannot synthesize the type of: @[ "; 33 | Syn.pp fmt t; 34 | Format.fprintf fmt "@]@]@," 35 | | Mode_mismatch (m1, m2) -> 36 | Format.fprintf fmt "@[Cannot equate mode@,@[ "; 37 | M.pp_mode fmt m1; 38 | Format.fprintf fmt "@]@ with@,@[ "; 39 | M.pp_mode fmt m2; 40 | Format.fprintf fmt "@]@]@," 41 | | Dim_mismatch (b1, b2) -> 42 | Format.fprintf fmt "@[Cannot equate dimension@,@[ "; 43 | D.pp_dim fmt b1; 44 | Format.fprintf fmt "@]@ with@,@[ "; 45 | D.pp_dim fmt b2; 46 | Format.fprintf fmt "@]@]@," 47 | | Type_mismatch (t1, t2) -> 48 | Format.fprintf fmt "@[Cannot equate@,@[ "; 49 | Syn.pp fmt t2; 50 | Format.fprintf fmt "@]@ with@,@[ "; 51 | Syn.pp fmt t1; 52 | Format.fprintf fmt "@]@]@," 53 | | Expecting_universe d -> 54 | Format.fprintf fmt "@[Expected some universe but found@ @["; 55 | D.pp fmt d; 56 | Format.fprintf fmt "@]@]@," 57 | | Expecting_term j -> 58 | Format.fprintf fmt "@[Expected term variable but found dimension@ @["; 59 | Format.pp_print_int fmt j; 60 | Format.fprintf fmt "@]@]@," 61 | | Expecting_of (s, t) -> 62 | Format.fprintf fmt "@[Expecting@,@[ "; 63 | Format.pp_print_string fmt s; 64 | Format.fprintf fmt "@]@ but found@,@[ "; 65 | D.pp fmt t; 66 | Format.fprintf fmt "@]@]@," 67 | | Misc s -> Format.pp_print_string fmt s 68 | 69 | exception Type_error of error 70 | 71 | let tp_error e = raise (Type_error e) 72 | 73 | let rec env_to_sem_env = function 74 | | [] -> [] 75 | | DVar {level; _} :: env -> D.Dim (D.DVar level) :: env_to_sem_env env 76 | | Var {level; tp} :: env -> D.Tm (D.Neutral {tp; term = D.root (D.Var level)}) :: env_to_sem_env env 77 | | Def {term; _} :: env -> D.Tm term :: env_to_sem_env env 78 | | Restrict _ :: env -> env_to_sem_env env 79 | | Lock _ :: env -> env_to_sem_env env 80 | | TopLevel {term; _} :: env -> D.TopLevel term :: env_to_sem_env env 81 | | Postulate {level; tp; _} :: env -> 82 | D.TopLevel (D.Neutral {tp; term = D.root (D.Var level)}) :: env_to_sem_env env 83 | 84 | let rec env_to_quote_env = function 85 | | [] -> [] 86 | | DVar {level; _} :: env -> Q.DVar level :: env_to_quote_env env 87 | | Var {level; tp} :: env -> Q.Var {level; tp} :: env_to_quote_env env 88 | | Def {term; _} :: env -> Q.Def term :: env_to_quote_env env 89 | | Restrict _ :: env -> env_to_quote_env env 90 | | Lock _ :: env -> env_to_quote_env env 91 | | TopLevel {term; _} :: env -> Q.TopLevel term :: env_to_quote_env env 92 | | Postulate {level; tp; _} :: env -> Q.Postulate {level; tp} :: env_to_quote_env env 93 | 94 | let assert_mode_equal m1 m2 = 95 | if m1 = m2 then () 96 | else tp_error (Mode_mismatch (m1, m2)) 97 | 98 | let modality_dst mode m = 99 | try M.dst mode m 100 | with M.Mode_mismatch _ -> tp_error (Misc ("Modality " ^ M.show_modality m ^ " does not have source " ^ M.show_mode mode ^ "\n")) 101 | 102 | let assert_modality_leq m1 m2 = 103 | if M.leq m1 m2 104 | then () 105 | else tp_error (Misc ("Tried to use variable behind modality: " ^ M.show_modality m1 ^ " ≰ " ^ M.show_modality m2 ^ "\n")) 106 | 107 | let synth_var ~mode env x = 108 | let rec go synth_mod env x = 109 | match x, env with 110 | | _, [] -> tp_error (Misc "Tried to access non-existent variable\n") 111 | | x, Restrict j :: env -> 112 | if x < j 113 | then 114 | if M.dst M.Parametric synth_mod = M.Pointwise 115 | then 116 | if M.leq synth_mod M.Components 117 | then go synth_mod env x 118 | else tp_error (Misc "Tried to use restricted term variable\n") 119 | else tp_error (Misc "Tried to use restricted term variable\n") 120 | else go synth_mod env x 121 | | x, Lock m :: env -> go (M.compose synth_mod m) env x 122 | | 0, Var {tp; modality; _} :: _ -> 123 | assert_modality_leq synth_mod modality; tp 124 | | 0, Def {tp; _} :: _ -> 125 | assert_modality_leq synth_mod M.Id; tp 126 | | 0, DVar {level; _} :: _ -> tp_error (Expecting_term level) 127 | | 0, TopLevel {mode = m; tp; _} :: _ -> 128 | assert_mode_equal mode m; tp 129 | | 0, Postulate {mode = m; tp; _} :: _ -> 130 | assert_mode_equal mode m; tp 131 | | x, _ :: env -> go synth_mod env (x - 1) 132 | in 133 | go M.Id env x 134 | 135 | let mk_bvar width env size = 136 | (D.DVar size, DVar {level = size; width} :: env) 137 | 138 | let mk_modal_var modality tp env size = 139 | (D.Neutral {tp; term = D.root (D.Var size)}, Var {level = size; tp; modality = modality} :: env) 140 | 141 | let mk_var tp env size = 142 | mk_modal_var M.Id tp env size 143 | 144 | let mk_vars tps env size = 145 | (List.mapi (fun i tp -> D.Neutral {tp; term = D.root (D.Var (size + i))}) tps, 146 | List.rev_append 147 | (List.mapi (fun i tp -> Var {level = size + i; tp; modality = M.Id}) tps) 148 | env) 149 | 150 | let restrict_env r env = 151 | match r with 152 | | Syn.DVar i -> Restrict i :: env 153 | | Syn.Const _ -> env 154 | 155 | let assert_subtype env size t1 t2 = 156 | if Q.check_tp ~subtype:true env size t1 t2 157 | then () 158 | else tp_error (Type_mismatch (Q.read_back_tp env size t1, Q.read_back_tp env size t2)) 159 | 160 | let assert_equal env size t1 t2 tp = 161 | if Q.check_nf env size (D.Normal {tp; term = t1}) (D.Normal {tp; term = t2}) 162 | then () 163 | else tp_error (Type_mismatch (Q.read_back_tp env size t1, Q.read_back_tp env size t2)) 164 | 165 | let assert_dim_equal b1 b2 = 166 | if b1 = b2 then () 167 | else tp_error (Dim_mismatch (b1, b2)) 168 | 169 | let check_dim ~mode ~env ~dim ~width = 170 | let rec go check_mod i env = 171 | match i, env with 172 | | _, [] -> tp_error (Misc "Tried to access non-existent variable\n") 173 | | i, Restrict j :: env -> 174 | if i = j 175 | then tp_error (Misc "Tried to use restricted dimension\n") 176 | else go check_mod i env 177 | | i, Lock m :: env -> 178 | go (M.compose check_mod m) i env 179 | | 0, DVar {width = w; _} :: _ -> 180 | assert_modality_leq check_mod M.Id; 181 | if width = w 182 | then () 183 | else tp_error (Misc "Dimension width mismatch\n") 184 | | 0, _ :: _ -> tp_error (Misc "Expected bridge dimension\n") 185 | | i, _ :: env -> go check_mod (i - 1) env 186 | in 187 | assert_mode_equal mode M.Parametric; 188 | match dim with 189 | | Syn.DVar i -> 190 | go M.Id i env 191 | | Syn.Const o -> 192 | if o < width 193 | then () 194 | else tp_error (Misc "Dimension constant out of bounds\n") 195 | 196 | let rec check ~mode ~env ~size ~term ~tp = 197 | match tp with 198 | | D.Neutral {term = (D.Ext e, tp_spine); _} -> 199 | begin 200 | match Q.reduce_extent (env_to_quote_env env) size (e, tp_spine) with 201 | | Some tp -> check ~mode ~env ~size ~term ~tp 202 | | None -> check_inert ~mode ~env ~size ~term ~tp 203 | end 204 | | _ -> check_inert ~mode ~env ~size ~term ~tp 205 | 206 | and check_inert ~mode ~env ~size ~term ~tp = 207 | match term with 208 | | Syn.Let (def, body) -> 209 | let def_tp = synth ~mode ~env ~size ~term:def in 210 | let def_val = E.eval def (env_to_sem_env env) size in 211 | check ~mode ~env:(Def {term = def_val; tp = def_tp} :: env) ~size ~term:body ~tp 212 | | Unit -> 213 | begin 214 | match tp with 215 | | D.Uni _ -> () 216 | | t -> tp_error (Expecting_universe t) 217 | end 218 | | Nat -> 219 | begin 220 | match tp with 221 | | D.Uni _ -> () 222 | | t -> tp_error (Expecting_universe t) 223 | end 224 | | List term -> 225 | begin 226 | match tp with 227 | | D.Uni _ -> check ~mode ~env ~size ~term ~tp 228 | | t -> tp_error (Expecting_universe t) 229 | end 230 | | Nil -> 231 | begin 232 | match tp with 233 | | D.List _ -> () 234 | | t -> tp_error (Expecting_of ("List", t)) 235 | end 236 | | Cons (a, t) -> 237 | begin 238 | match tp with 239 | | D.List tp -> 240 | check ~mode ~env ~size ~term:a ~tp; 241 | check ~mode ~env ~size ~term:t ~tp:(D.List tp) 242 | | t -> tp_error (Expecting_of ("List", t)) 243 | end 244 | | Bool -> 245 | begin 246 | match tp with 247 | | D.Uni _ -> () 248 | | t -> tp_error (Expecting_universe t) 249 | end 250 | | Coprod (left, right) -> 251 | begin 252 | match tp with 253 | | D.Uni _ -> 254 | check ~mode ~env ~size ~term:left ~tp; 255 | check ~mode ~env ~size ~term:right ~tp 256 | | t -> tp_error (Expecting_universe t) 257 | end 258 | | Inl a -> 259 | begin 260 | match tp with 261 | | D.Coprod (left, _) -> check ~mode ~env ~size ~term:a ~tp:left 262 | | t -> tp_error (Expecting_of ("Coprod", t)) 263 | end 264 | | Inr b -> 265 | begin 266 | match tp with 267 | | D.Coprod (_, right) -> check ~mode ~env ~size ~term:b ~tp:right 268 | | t -> tp_error (Expecting_of ("Coprod", t)) 269 | end 270 | | Void -> 271 | begin 272 | match tp with 273 | | D.Uni _ -> () 274 | | t -> tp_error (Expecting_universe t) 275 | end 276 | | Id (tp', l, r) -> 277 | begin 278 | match tp with 279 | | D.Uni _ -> 280 | check ~mode ~env ~size ~term:tp' ~tp; 281 | let tp' = E.eval tp' (env_to_sem_env env) size in 282 | check ~mode ~env ~size ~term:l ~tp:tp'; 283 | check ~mode ~env ~size ~term:r ~tp:tp' 284 | | t -> tp_error (Expecting_universe t) 285 | end 286 | | Refl term -> 287 | begin 288 | match tp with 289 | | D.Id (tp, left, right) -> 290 | check ~mode ~env ~size ~term ~tp; 291 | let quote_env = env_to_quote_env env in 292 | let sem_env = Q.env_to_sem_env quote_env in 293 | let term = E.eval term sem_env size in 294 | assert_equal quote_env size term left tp; 295 | assert_equal quote_env size term right tp 296 | | t -> tp_error (Expecting_of ("Id", t)) 297 | end 298 | | Pi (m, l, r) -> 299 | begin 300 | match tp with 301 | | D.Uni _ -> 302 | check ~mode:(modality_dst mode m) ~env:(Lock m :: env) ~size ~term:l ~tp; 303 | let l_sem = E.eval l (env_to_sem_env env) size in 304 | let (_, arg_env) = mk_modal_var m l_sem env size in 305 | check ~mode ~env:arg_env ~size:(size + 1) ~term:r ~tp 306 | | t -> tp_error (Expecting_universe t) 307 | end 308 | | Lam body -> 309 | begin 310 | match tp with 311 | | D.Pi (m, arg_tp, clos) -> 312 | let (arg, arg_env) = mk_modal_var m arg_tp env size in 313 | let dest_tp = E.do_clos (size + 1) clos (D.Tm arg) in 314 | check ~mode ~env:arg_env ~size:(size + 1) ~term:body ~tp:dest_tp; 315 | | t -> tp_error (Expecting_of ("Pi", t)) 316 | end 317 | | Sg (l, r) -> 318 | begin 319 | match tp with 320 | | D.Uni _ -> 321 | check ~mode ~env ~size ~term:l ~tp; 322 | let l_sem = E.eval l (env_to_sem_env env) size in 323 | let (_, arg_env) = mk_var l_sem env size in 324 | check ~mode ~env:arg_env ~size:(size + 1) ~term:r ~tp 325 | | t -> tp_error (Expecting_universe t) 326 | end 327 | | Pair (left, right) -> 328 | begin 329 | match tp with 330 | | D.Sg (left_tp, right_tp) -> 331 | check ~mode ~env ~size ~term:left ~tp:left_tp; 332 | let left_sem = E.eval left (env_to_sem_env env) size in 333 | check ~mode ~env ~size ~term:right ~tp:(E.do_clos size right_tp (D.Tm left_sem)) 334 | | t -> tp_error (Expecting_of ("Sigma", t)) 335 | end 336 | | Bridge (term, ends) -> 337 | assert_mode_equal mode Parametric; 338 | begin 339 | match tp with 340 | | Uni _ -> 341 | let width = List.length ends in 342 | let (_, arg_env) = mk_bvar width env size in 343 | check ~mode ~env:arg_env ~size:(size + 1) ~term ~tp; 344 | let width = List.length ends in 345 | let tps = E.do_consts size (D.Clos {term; env = env_to_sem_env env}) width in 346 | List.iter2 (fun tp -> Option.fold () (fun term -> check ~mode ~env ~size ~term ~tp)) tps ends 347 | | t -> tp_error (Expecting_universe t) 348 | end 349 | | BLam body -> 350 | assert_mode_equal mode Parametric; 351 | begin 352 | match tp with 353 | | Bridge (clos, ends) -> 354 | let width = List.length ends in 355 | let (arg, arg_env) = mk_bvar width env size in 356 | let dest_tp = E.do_clos (size + 1) clos (D.Dim arg) in 357 | check ~mode ~env:arg_env ~size:(size + 1) ~term:body ~tp:dest_tp; 358 | let quote_env = env_to_quote_env env in 359 | let sem_env = Q.env_to_sem_env quote_env in 360 | List.iteri 361 | (fun o -> 362 | Option.fold () 363 | (fun pt -> 364 | let body_o = E.eval body (D.Dim (D.Const o) :: sem_env) size in 365 | let tp = E.do_clos size clos (D.Dim (D.Const o)) in 366 | assert_equal quote_env size body_o pt tp)) 367 | ends 368 | | t -> tp_error (Expecting_of ("Bridge", t)) 369 | end 370 | | Gel (r, ends, rel) -> 371 | assert_mode_equal mode Parametric; 372 | begin 373 | match tp with 374 | | Uni _ -> 375 | let width = List.length ends in 376 | check_dim ~mode ~env ~dim:r ~width; 377 | let res_env = restrict_env r env in 378 | List.iter (fun term -> check ~mode ~env:res_env ~size ~term ~tp) ends; 379 | let sem_env = env_to_sem_env res_env in 380 | let ends' = List.map (fun t -> E.eval t sem_env size) ends in 381 | let (_, rel_env) = mk_vars ends' res_env size in 382 | check ~mode ~env:rel_env ~size:(size + width) ~term:rel ~tp; 383 | | t -> tp_error (Expecting_universe t) 384 | end 385 | | Engel (i, ts, term) -> 386 | assert_mode_equal mode Parametric; 387 | begin 388 | match tp with 389 | | Gel (j, ends, rel) -> 390 | let r = Syn.DVar i in 391 | let width = List.length ts in 392 | check_dim ~mode ~env ~dim:r ~width; 393 | let sem_env = env_to_sem_env env in 394 | assert_dim_equal (E.eval_dim r sem_env) (D.DVar j); 395 | let res_env = restrict_env r env in 396 | List.iter2 (fun term tp -> check ~mode ~env:res_env ~size ~term ~tp) ts ends; 397 | let ts' = List.map (fun t -> E.eval t sem_env size) ts in 398 | check ~mode ~env:res_env ~size ~term ~tp:(E.do_closN size rel ts') 399 | | t -> tp_error (Misc ("Expecting Gel but found\n" ^ D.show t)) 400 | end 401 | | Codisc term -> 402 | assert_mode_equal mode Parametric; 403 | begin 404 | match tp with 405 | | D.Uni _ -> 406 | check ~mode:Pointwise ~env:(Lock M.Global :: env) ~size ~term ~tp; 407 | | t -> tp_error (Expecting_universe t) 408 | end 409 | | Encodisc term -> 410 | assert_mode_equal mode Parametric; 411 | begin 412 | match tp with 413 | | D.Codisc tp -> 414 | check ~mode:Pointwise ~env:(Lock M.Global :: env) ~size ~term ~tp; 415 | | t -> tp_error (Expecting_of ("Codisc", t)) 416 | end 417 | | Global term -> 418 | assert_mode_equal mode Pointwise; 419 | begin 420 | match tp with 421 | | D.Uni _ -> 422 | check ~mode:Parametric ~env:(Lock M.Discrete :: env) ~size ~term ~tp; 423 | | t -> tp_error (Expecting_universe t) 424 | end 425 | | Englobe term -> 426 | assert_mode_equal mode Pointwise; 427 | begin 428 | match tp with 429 | | D.Global tp -> 430 | check ~mode:Parametric ~env:(Lock M.Discrete :: env) ~size ~term ~tp; 431 | | t -> tp_error (Expecting_of ("Global", t)) 432 | end 433 | | Disc term -> 434 | assert_mode_equal mode Parametric; 435 | begin 436 | match tp with 437 | | D.Uni _ -> 438 | check ~mode:Pointwise ~env:(Lock M.Components :: env) ~size ~term ~tp; 439 | | t -> tp_error (Expecting_universe t) 440 | end 441 | | Endisc term -> 442 | assert_mode_equal mode Parametric; 443 | begin 444 | match tp with 445 | | D.Disc tp -> 446 | check ~mode:Pointwise ~env:(Lock M.Components :: env) ~size ~term ~tp; 447 | | t -> tp_error (Expecting_universe t) 448 | end 449 | | Uni i -> 450 | begin 451 | match tp with 452 | | Uni j when i < j -> () 453 | | t -> 454 | let msg = 455 | "Expecting universe over " ^ string_of_int i ^ " but found\n" ^ D.show t ^ "\n" in 456 | tp_error (Misc msg) 457 | end 458 | | term -> assert_subtype (env_to_quote_env env) size (synth ~mode ~env ~size ~term) tp 459 | 460 | and synth ~mode ~env ~size ~term = 461 | let rec go tp = 462 | match tp with 463 | | D.Neutral {term = (D.Ext e, tp_spine); _} -> 464 | begin 465 | match Q.reduce_extent (env_to_quote_env env) size (e, tp_spine) with 466 | | Some tp -> go tp 467 | | None -> tp 468 | end 469 | | _ -> tp 470 | in 471 | go (synth_quasi ~mode ~env ~size ~term) 472 | 473 | and synth_quasi ~mode ~env ~size ~term = 474 | match term with 475 | | Syn.Var i -> synth_var ~mode env i 476 | | Check (term, tp') -> 477 | let tp = E.eval tp' (env_to_sem_env env) size in 478 | check ~mode ~env ~size ~term ~tp; 479 | tp 480 | | Triv -> D.Unit 481 | | Zero -> D.Nat 482 | | Suc term -> check ~mode ~env ~size ~term ~tp:Nat; D.Nat 483 | | True -> D.Bool 484 | | False -> D.Bool 485 | | Fst p -> 486 | begin 487 | match synth ~mode ~env ~size ~term:p with 488 | | Sg (left_tp, _) -> left_tp 489 | | t -> tp_error (Expecting_of ("Sg", t)) 490 | end 491 | | Snd p -> 492 | begin 493 | match synth ~mode ~env ~size ~term:p with 494 | | Sg (_, right_tp) -> 495 | let proj = E.eval (Fst p) (env_to_sem_env env) size in 496 | E.do_clos size right_tp (D.Tm proj) 497 | | t -> tp_error (Expecting_of ("Sg", t)) 498 | end 499 | | Ap (f, a) -> 500 | begin 501 | match synth ~mode ~env ~size ~term:f with 502 | | Pi (m, src, dest) -> 503 | check ~mode:(modality_dst mode m) ~env:(Lock m :: env) ~size ~term:a ~tp:src; 504 | let a_sem = E.eval a (env_to_sem_env env) size in 505 | E.do_clos size dest (D.Tm a_sem) 506 | | t -> tp_error (Expecting_of ("Pi", t)) 507 | end 508 | | NRec (mot, zero, suc, n) -> 509 | check ~mode ~env ~size ~term:n ~tp:Nat; 510 | let sem_env = env_to_sem_env env in 511 | let (nat_arg, nat_env) = mk_var Nat env size in 512 | check_tp ~mode ~env:nat_env ~size:(size + 1) ~term:mot; 513 | let zero_tp = E.eval mot (D.Tm D.Zero :: sem_env) size in 514 | check ~mode ~env ~size ~term:zero ~tp:zero_tp; 515 | let ih_tp = E.eval mot (env_to_sem_env nat_env) (size + 1) in 516 | let (_, ih_env) = mk_var ih_tp nat_env (size + 1) in 517 | let suc_tp = E.eval mot (D.Tm (Suc nat_arg) :: sem_env) (size + 2) in 518 | check ~mode ~env:ih_env ~size:(size + 2) ~term:suc ~tp:suc_tp; 519 | E.eval mot (D.Tm (E.eval n sem_env size) :: sem_env) size 520 | | ListRec (mot, nil, cons, l) -> 521 | begin 522 | match synth ~mode ~env ~size ~term:l with 523 | | D.List tp' -> 524 | let sem_env = env_to_sem_env env in 525 | let (_, mot_env) = mk_var (D.List tp') env size in 526 | check_tp ~mode ~env:mot_env ~size:(size + 1) ~term:mot; 527 | check ~mode ~env ~size ~term:nil ~tp:(E.eval mot (D.Tm D.Nil :: sem_env) size); 528 | let (cons_arg1, cons_env1) = mk_var tp' env size in 529 | let (cons_arg2, cons_env2) = mk_var (D.List tp') cons_env1 (size + 1) in 530 | let rec_mot = E.eval mot (D.Tm cons_arg2 :: sem_env) (size + 2) in 531 | let (_, cons_env3) = mk_var rec_mot cons_env2 (size + 2) in 532 | check ~mode ~env:cons_env3 ~size:(size + 3) ~term:cons 533 | ~tp:(E.eval mot (D.Tm (D.Cons (cons_arg1, cons_arg2)) :: sem_env) (size + 3)); 534 | E.eval mot (D.Tm (E.eval l sem_env size) :: sem_env) size 535 | | t -> tp_error (Expecting_of ("List", t)) 536 | end 537 | | If (mot, tt, ff, b) -> 538 | check ~mode ~env ~size ~term:b ~tp:Bool; 539 | let sem_env = env_to_sem_env env in 540 | let (_, bool_env) = mk_var Bool env size in 541 | check_tp ~mode ~env:bool_env ~size:(size + 1) ~term:mot; 542 | let tt_tp = E.eval mot (D.Tm D.True :: sem_env) size in 543 | check ~mode ~env ~size ~term:tt ~tp:tt_tp; 544 | let ff_tp = E.eval mot (D.Tm D.False :: sem_env) size in 545 | check ~mode ~env ~size ~term:ff ~tp:ff_tp; 546 | E.eval mot (D.Tm (E.eval b sem_env size) :: sem_env) size 547 | | Case (mot, inl, inr, co) -> 548 | begin 549 | match synth ~mode ~env ~size ~term:co with 550 | | D.Coprod (left, right) -> 551 | let sem_env = env_to_sem_env env in 552 | let (_, mot_env) = mk_var (D.Coprod (left, right)) env size in 553 | check_tp ~mode ~env:mot_env ~size:(size + 1) ~term:mot; 554 | let (inl_arg, inl_env) = mk_var left env size in 555 | check ~mode ~env:inl_env ~size:(size + 1) ~term:inl 556 | ~tp:(E.eval mot (D.Tm (D.Inl inl_arg) :: sem_env) (size + 1)); 557 | let (inr_arg, inr_env) = mk_var right env size in 558 | check ~mode ~env:inr_env ~size:(size + 1) ~term:inr 559 | ~tp:(E.eval mot (D.Tm (D.Inr inr_arg) :: sem_env) (size + 1)); 560 | E.eval mot (D.Tm (E.eval co sem_env size) :: sem_env) size 561 | | t -> tp_error (Expecting_of ("Coprod", t)) 562 | end 563 | | Abort (mot, vd) -> 564 | check ~mode ~env ~size ~term:vd ~tp:Void; 565 | let sem_env = env_to_sem_env env in 566 | let (_, mot_env) = mk_var Void env size in 567 | check_tp ~mode ~env:mot_env ~size:(size + 1) ~term:mot; 568 | E.eval mot (D.Tm (E.eval vd sem_env size) :: sem_env) size 569 | | BApp (term, r) -> 570 | let restricted_env = restrict_env r env in 571 | begin 572 | match synth ~mode ~env:restricted_env ~size ~term with 573 | | Bridge (clos, ends) -> 574 | let width = List.length ends in 575 | check_dim ~mode ~width ~env ~dim:r; 576 | let r' = E.eval_dim r (env_to_sem_env env) in 577 | E.do_clos size clos (D.Dim r') 578 | | t -> tp_error (Expecting_of ("Bridge", t)) 579 | end 580 | | J (mot, refl, eq) -> 581 | begin 582 | match synth ~mode ~env ~size ~term:eq with 583 | | D.Id (tp', left, right) -> 584 | let sem_env = env_to_sem_env env in 585 | let (mot_arg1, mot_env1) = mk_var tp' env size in 586 | let (mot_arg2, mot_env2) = mk_var tp' mot_env1 (size + 1) in 587 | let (_, mot_env3) = mk_var (D.Id (tp', mot_arg1, mot_arg2)) mot_env2 (size + 2) in 588 | check_tp ~mode ~env:mot_env3 ~size:(size + 3) ~term:mot; 589 | let refl_tp = 590 | E.eval mot 591 | (D.Tm (D.Refl mot_arg1) :: D.Tm mot_arg1 :: D.Tm mot_arg1 :: sem_env) 592 | (size + 1) in 593 | check ~mode ~env:mot_env1 ~size:(size + 1) ~term:refl ~tp:refl_tp; 594 | E.eval mot (D.Tm (E.eval eq sem_env size) :: D.Tm right :: D.Tm left :: sem_env) size 595 | | t -> tp_error (Expecting_of ("Id", t)) 596 | end 597 | | Extent (r, dom, mot, ctx, endcase, varcase) -> 598 | assert_mode_equal mode Parametric; 599 | let width = List.length endcase in 600 | check_dim ~mode ~env ~dim:r ~width; 601 | let sem_env = env_to_sem_env env in 602 | let r' = E.eval_dim r sem_env in 603 | let res_env = restrict_env r env in 604 | let (_, dim_env) = mk_bvar width res_env size in 605 | check_tp ~mode ~env:dim_env ~size:(size + 1) ~term:dom; 606 | let dom' = E.eval dom (env_to_sem_env dim_env) (size + 1) in 607 | let (_, dom_env) = mk_var dom' dim_env (size + 1) in 608 | check_tp ~mode ~env:dom_env ~size:(size + 2) ~term:mot; 609 | let dom_r = E.eval dom (D.Dim r' :: sem_env) size in 610 | check ~mode ~env ~size ~term:ctx ~tp:dom_r; 611 | List.iteri 612 | (fun o case -> 613 | let dom_o = E.eval dom (D.Dim (D.Const o) :: sem_env) size in 614 | let (case_arg, case_env) = mk_var dom_o res_env size in 615 | let mot_o = E.eval mot (D.Tm case_arg :: D.Dim (D.Const o) :: sem_env) size in 616 | check ~mode ~env:case_env ~size:(size + 1) ~term:case ~tp:mot_o) 617 | endcase; 618 | let end_tps = E.do_consts size (D.Clos {term = dom; env = sem_env}) width in 619 | let (end_vars, ends_env) = mk_vars end_tps res_env size in 620 | let dom_bridge = D.Bridge (D.Clos {term = dom; env = sem_env}, List.map Option.some end_vars) in 621 | let (bridge_arg, bridge_env) = mk_var dom_bridge ends_env (size + width) in 622 | let (varcase_barg, varcase_benv) = mk_bvar width bridge_env (size + width + 1) in 623 | let varcase_inst = E.do_bapp (size + width + 2) bridge_arg varcase_barg in 624 | let varcase_mot = 625 | E.eval mot (D.Tm varcase_inst :: D.Dim varcase_barg :: sem_env) (size + width + 2) in 626 | check ~mode ~env:varcase_benv ~size:(size + width + 2) ~term:varcase ~tp:varcase_mot; 627 | E.eval mot (D.Tm (E.eval ctx sem_env size) :: D.Dim r' :: sem_env) size 628 | | Ungel (width, mot, term, case) -> 629 | assert_mode_equal mode Parametric; 630 | let (var_arg, var_env) = mk_bvar width env size in 631 | begin 632 | match synth ~mode ~env:var_env ~size:(size + 1) ~term with 633 | | D.Gel (i, end_tps, rel) -> 634 | assert_dim_equal (D.DVar i) var_arg; 635 | let sem_env = env_to_sem_env env in 636 | let end_tms = E.do_consts size (D.Clos {term; env = sem_env}) width in 637 | let mot_hyp = 638 | D.Bridge 639 | (D.Pseudo {var = size; term = D.Gel (size, end_tps, rel); ends = end_tps}, 640 | List.map Option.some end_tms) in 641 | let (_, hyp_env) = mk_var mot_hyp env size in 642 | check_tp ~mode ~env:hyp_env ~size:(size + 1) ~term:mot; 643 | let applied_rel = E.do_closN size rel end_tms in 644 | let (wit_arg, wit_env) = mk_var applied_rel env size in 645 | let gel_term = 646 | D.BLam (D.Pseudo {var = size + 1; term = D.Engel (size + 1, end_tms, wit_arg); ends = end_tms}) in 647 | let gel_tp = E.eval mot (D.Tm gel_term :: sem_env) (size + 1) in 648 | check ~mode ~env:wit_env ~size:(size + 1) ~term:case ~tp:gel_tp; 649 | E.eval mot (D.Tm (D.BLam (D.Clos {term; env = sem_env})) :: sem_env) size 650 | | t -> tp_error (Expecting_of ("Gel", t)) 651 | end 652 | | Uncodisc term -> 653 | assert_mode_equal mode Pointwise; 654 | begin 655 | match synth ~mode:Parametric ~env:(Lock M.Discrete :: env) ~size ~term with 656 | | Codisc tp -> tp 657 | | t -> tp_error (Expecting_of ("Codisc", t)) 658 | end 659 | | Unglobe term -> 660 | assert_mode_equal mode Parametric; 661 | begin 662 | match synth ~mode:Pointwise ~env:(Lock M.Components :: env) ~size ~term with 663 | | Global tp -> tp 664 | | t -> tp_error (Expecting_of ("Global", t)) 665 | end 666 | | Letdisc (m, mot, case, d) -> 667 | assert_mode_equal (modality_dst mode m) M.Parametric; 668 | begin 669 | match synth ~mode:M.Parametric ~env:(Lock m :: env) ~size ~term:d with 670 | | Disc tp -> 671 | let sem_env = env_to_sem_env env in 672 | let (_, mot_env) = mk_modal_var m (D.Disc tp) env size in 673 | check_tp ~mode ~env:mot_env ~size:(size + 1) ~term:mot; 674 | let (case_arg, case_env) = mk_modal_var (M.compose M.Components m) tp env size in 675 | check ~mode ~env:case_env ~size:(size + 1) ~term:case 676 | ~tp:(E.eval mot (D.Tm (D.Endisc case_arg) :: sem_env) (size + 1)); 677 | E.eval mot (D.Tm (E.eval d sem_env size) :: sem_env) size 678 | | t -> tp_error (Expecting_of ("Disc", t)) 679 | end 680 | | Letdiscbridge (m, width, mot, case, d) -> 681 | assert_mode_equal (modality_dst mode m) M.Parametric; 682 | let (_, var_env) = mk_bvar width (Lock m :: env) size in 683 | begin 684 | match synth ~mode:M.Parametric ~env:var_env ~size:(size + 1) ~term:d with 685 | | D.Disc tp -> 686 | let sem_env = env_to_sem_env env in 687 | let mot_hyp = D.Bridge (D.ConstClos (D.Disc tp), List.init width (fun _ -> None)) in 688 | let (_, mot_env) = mk_modal_var m mot_hyp env size in 689 | check_tp ~mode ~env:mot_env ~size:(size + 1) ~term:mot; 690 | let (case_arg, case_env) = mk_modal_var (M.compose M.Components m) tp env size in 691 | check ~mode ~env:case_env ~size:(size + 1) ~term:case 692 | ~tp:(E.eval mot (D.Tm (D.BLam (D.ConstClos (D.Endisc case_arg))) :: sem_env) (size + 1)); 693 | E.eval mot (D.Tm (D.BLam (D.Clos {term = d; env = sem_env})) :: sem_env) size 694 | | t -> tp_error (Expecting_of ("Disc", t)) 695 | end 696 | | _ -> tp_error (Cannot_synth_term term) 697 | 698 | and check_tp ~mode ~env ~size ~term = 699 | match term with 700 | | Syn.Unit -> () 701 | | Syn.Nat -> () 702 | | Syn.List term -> check_tp ~mode ~env ~size ~term 703 | | Syn.Bool -> () 704 | | Syn.Coprod (left, right) -> 705 | check_tp ~mode ~env ~size ~term:left; 706 | check_tp ~mode ~env ~size ~term:right 707 | | Syn.Void -> () 708 | | Uni _ -> () 709 | | Bridge (term, ends) -> 710 | let width = List.length ends in 711 | let (_, var_env) = mk_bvar width env size in 712 | check_tp ~mode ~env:var_env ~size:(size + 1) ~term; 713 | let sem_env = env_to_sem_env env in 714 | List.iteri 715 | (fun o -> 716 | Option.fold () 717 | (fun pt -> 718 | check ~mode ~env ~size ~term:pt ~tp:(E.eval term (D.Dim (D.Const o) :: sem_env) size))) 719 | ends 720 | | Pi (m, l, r) -> 721 | check_tp ~mode:(modality_dst mode m) ~env:(Lock m :: env) ~size ~term:l; 722 | let sem_env = env_to_sem_env env in 723 | let l_sem = E.eval l sem_env size in 724 | let (_, var_env) = mk_modal_var m l_sem env size in 725 | check_tp ~mode ~env:var_env ~size:(size + 1) ~term:r 726 | | Sg (l, r) -> 727 | check_tp ~mode ~env ~size ~term:l; 728 | let sem_env = env_to_sem_env env in 729 | let l_sem = E.eval l sem_env size in 730 | let (_, var_env) = mk_var l_sem env size in 731 | check_tp ~mode ~env:var_env ~size:(size + 1) ~term:r 732 | | Let (def, body) -> 733 | let def_tp = synth ~mode ~env ~size ~term:def in 734 | let def_val = E.eval def (env_to_sem_env env) size in 735 | check_tp ~mode ~env:(Def {term = def_val; tp = def_tp} :: env) ~size ~term:body 736 | | Id (tp, l, r) -> 737 | check_tp ~mode ~env ~size ~term:tp; 738 | let tp = E.eval tp (env_to_sem_env env) size in 739 | check ~mode ~env ~size ~term:l ~tp; 740 | check ~mode ~env ~size ~term:r ~tp 741 | | Gel (r, ends, rel) -> 742 | let width = List.length ends in 743 | check_dim ~mode ~env ~dim:r ~width; 744 | let res_env = restrict_env r env in 745 | let sem_env = env_to_sem_env res_env in 746 | List.iter (fun term -> check_tp ~mode ~env:res_env ~size ~term) ends; 747 | let ends' = List.map (fun term -> E.eval term sem_env size) ends in 748 | let (_, rel_env) = mk_vars ends' res_env size in 749 | check_tp ~mode ~env:rel_env ~size:(size + width) ~term:rel 750 | | Codisc tp -> 751 | assert_mode_equal mode Parametric; 752 | check_tp ~mode:Pointwise ~env:(Lock M.Global :: env) ~size ~term:tp 753 | | Global tp -> 754 | assert_mode_equal mode Pointwise; 755 | check_tp ~mode:Parametric ~env:(Lock M.Discrete :: env) ~size ~term:tp 756 | | Disc tp -> 757 | assert_mode_equal mode Parametric; 758 | check_tp ~mode:Pointwise ~env:(Lock M.Components :: env) ~size ~term:tp 759 | | term -> 760 | begin 761 | match synth ~mode ~env ~size ~term with 762 | | D.Uni _ -> () 763 | | t -> tp_error (Expecting_universe t) 764 | end 765 | -------------------------------------------------------------------------------- /src/lib/check.mli: -------------------------------------------------------------------------------- 1 | type error = 2 | Cannot_synth_term of Syntax.t 3 | | Mode_mismatch of Mode.mode * Mode.mode 4 | | Dim_mismatch of Domain.dim * Domain.dim 5 | | Type_mismatch of Syntax.t * Syntax.t 6 | | Expecting_universe of Domain.t 7 | | Expecting_term of Domain.lvl 8 | | Expecting_of of string * Domain.t 9 | | Misc of string 10 | 11 | val pp_error : Format.formatter -> error -> unit 12 | 13 | exception Type_error of error 14 | 15 | type env_entry = 16 | | DVar of {level : Domain.lvl; width : int} 17 | | Var of {level : Domain.lvl; tp : Domain.t; modality : Mode.modality} 18 | | Def of {term : Domain.t; tp : Domain.t} 19 | | Restrict of Syntax.idx 20 | | Lock of Mode.modality 21 | | TopLevel of {mode : Mode.mode; term : Domain.t; tp : Domain.t} 22 | | Postulate of {mode : Mode.mode; level : Domain.lvl; tp : Domain.t} 23 | 24 | type env = env_entry list 25 | 26 | val env_to_sem_env : env -> Domain.env 27 | val env_to_quote_env : env -> Quote.env 28 | 29 | val check : mode:Mode.mode -> env:env -> size:Domain.lvl -> term:Syntax.t -> tp:Domain.t -> unit 30 | val synth : mode:Mode.mode -> env:env -> size:Domain.lvl -> term:Syntax.t -> Domain.t 31 | val check_tp : mode:Mode.mode -> env:env -> size:Domain.lvl -> term:Syntax.t -> unit 32 | -------------------------------------------------------------------------------- /src/lib/concrete_syntax.ml: -------------------------------------------------------------------------------- 1 | type ident = string 2 | type uni_level = int 3 | 4 | type dim = 5 | | DVar of ident 6 | | Const of int 7 | 8 | type binder = Binder of {name : ident; body : t} 9 | and bindern = BinderN of {names : ident list; body : t} 10 | and binder2 = Binder2 of {name1 : ident; name2 : ident; body : t} 11 | and binder3 = Binder3 of {name1 : ident; name2 : ident; name3 : ident; body : t} 12 | and cell = Cell of {m : Mode.modality; name : ident; ty : t} 13 | and spine = Term of t | Dim of dim 14 | and t = 15 | | Var of ident 16 | | Let of t * binder 17 | | Check of {term : t; tp : t} 18 | | Unit 19 | | Triv 20 | | Nat 21 | | Suc of t 22 | | Lit of int 23 | | NRec of {mot : binder; zero : t; suc : binder2; nat : t} 24 | | List of t 25 | | Nil 26 | | Cons of t * t 27 | | ListRec of {mot : binder; nil : t; cons : binder3; list : t} 28 | | Bool 29 | | True 30 | | False 31 | | If of {mot : binder; tt : t; ff : t; bool : t} 32 | | Coprod of t * t 33 | | Inl of t 34 | | Inr of t 35 | | Case of {mot : binder; inl : binder; inr : binder; coprod : t} 36 | | Void 37 | | Abort of {mot : binder; void : t} 38 | | Pi of cell list * t 39 | | Lam of bindern 40 | | Ap of t * spine list 41 | | Sg of cell list * t 42 | | Pair of t * t 43 | | Fst of t 44 | | Snd of t 45 | | Id of t * t * t 46 | | Refl of t 47 | | J of {mot : binder3; refl : binder; eq : t} 48 | | Bridge of binder * t option list 49 | | BLam of bindern 50 | | Extent of {dim : dim; dom : binder; mot : binder2; ctx : t; endcase : binder list; varcase : bindern} 51 | | Gel of dim * t list * bindern 52 | | Engel of ident * t list * t 53 | | Ungel of {width : int; mot : binder; gel : binder; case : binder} 54 | | Codisc of t 55 | | Encodisc of t 56 | | Uncodisc of t 57 | | Global of t 58 | | Englobe of t 59 | | Unglobe of t 60 | | Disc of t 61 | | Endisc of t 62 | | Letdisc of {modality : Mode.modality; mot : binder; case : binder; disc : t} 63 | | Letdiscbridge of {modality : Mode.modality; width : int; mot: binder; case : binder; disc : binder} 64 | | Uni of uni_level 65 | 66 | type decl = 67 | Def of {name : ident; mode : Mode.mode; def : t; tp : t} 68 | | Postulate of {name : ident; mode : Mode.mode; tp : t} 69 | | NormalizeDef of ident 70 | | NormalizeTerm of {term : t; mode : Mode.mode; tp : t} 71 | | Quit 72 | 73 | type signature = decl list 74 | -------------------------------------------------------------------------------- /src/lib/concrete_syntax.mli: -------------------------------------------------------------------------------- 1 | type ident = string 2 | type uni_level = int 3 | 4 | type dim = 5 | | DVar of ident 6 | | Const of int 7 | 8 | type binder = Binder of {name : ident; body : t} 9 | and bindern = BinderN of {names : ident list; body : t} 10 | and binder2 = Binder2 of {name1 : ident; name2 : ident; body : t} 11 | and binder3 = Binder3 of {name1 : ident; name2 : ident; name3 : ident; body : t} 12 | and cell = Cell of {m : Mode.modality; name : ident; ty : t} 13 | and spine = Term of t | Dim of dim 14 | and t = 15 | | Var of ident 16 | | Let of t * binder 17 | | Check of {term : t; tp : t} 18 | | Unit 19 | | Triv 20 | | Nat 21 | | Suc of t 22 | | Lit of int 23 | | NRec of {mot : binder; zero : t; suc : binder2; nat : t} 24 | | List of t 25 | | Nil 26 | | Cons of t * t 27 | | ListRec of {mot : binder; nil : t; cons : binder3; list : t} 28 | | Bool 29 | | True 30 | | False 31 | | If of {mot : binder; tt : t; ff : t; bool : t} 32 | | Coprod of t * t 33 | | Inl of t 34 | | Inr of t 35 | | Case of {mot : binder; inl : binder; inr : binder; coprod : t} 36 | | Void 37 | | Abort of {mot : binder; void : t} 38 | | Pi of cell list * t 39 | | Lam of bindern 40 | | Ap of t * spine list 41 | | Sg of cell list * t 42 | | Pair of t * t 43 | | Fst of t 44 | | Snd of t 45 | | Id of t * t * t 46 | | Refl of t 47 | | J of {mot : binder3; refl : binder; eq : t} 48 | | Bridge of binder * t option list 49 | | BLam of bindern 50 | | Extent of {dim : dim; dom : binder; mot : binder2; ctx : t; endcase : binder list; varcase : bindern} 51 | | Gel of dim * t list * bindern 52 | | Engel of ident * t list * t 53 | | Ungel of {width : int; mot : binder; gel : binder; case : binder} 54 | | Codisc of t 55 | | Encodisc of t 56 | | Uncodisc of t 57 | | Global of t 58 | | Englobe of t 59 | | Unglobe of t 60 | | Disc of t 61 | | Endisc of t 62 | | Letdisc of {modality : Mode.modality; mot : binder; case : binder; disc : t} 63 | | Letdiscbridge of {modality : Mode.modality; width : int; mot: binder; case : binder; disc : binder} 64 | | Uni of uni_level 65 | 66 | type decl = 67 | Def of {name : ident; mode : Mode.mode; def : t; tp : t} 68 | | Postulate of {name : ident; mode : Mode.mode; tp : t} 69 | | NormalizeDef of ident 70 | | NormalizeTerm of {term : t; mode : Mode.mode; tp : t} 71 | | Quit 72 | 73 | type signature = decl list 74 | -------------------------------------------------------------------------------- /src/lib/domain.ml: -------------------------------------------------------------------------------- 1 | type lvl = int 2 | [@@deriving show{ with_path = false }, eq] 3 | 4 | type dim = 5 | | DVar of lvl 6 | | Const of int 7 | [@@deriving show, eq] 8 | 9 | type env_entry = 10 | | TopLevel of t 11 | | Dim of dim 12 | | Tm of t 13 | and env = env_entry list 14 | [@@deriving show, eq] 15 | and clos = 16 | | ConstClos of t 17 | | Clos of {term : Syntax.t; env : env} 18 | | Pseudo of {var : lvl; term : t; ends : t list} 19 | [@@deriving show, eq] 20 | and clos2 = Clos2 of {term : Syntax.t; env : env} 21 | [@@deriving show, eq] 22 | and clos3 = Clos3 of {term : Syntax.t; env : env} 23 | [@@deriving show, eq] 24 | and closN = ClosN of {term : Syntax.t; env : env} 25 | [@@deriving show, eq] 26 | and t = 27 | | Lam of clos 28 | | Neutral of {tp : t; term : ne} 29 | | Unit 30 | | Triv 31 | | Nat 32 | | Zero 33 | | Suc of t 34 | | List of t 35 | | Nil 36 | | Cons of t * t 37 | | Bool 38 | | True 39 | | False 40 | | Coprod of t * t 41 | | Inl of t 42 | | Inr of t 43 | | Void 44 | | Pi of Mode.modality * t * clos 45 | | Sg of t * clos 46 | | Pair of t * t 47 | | Bridge of clos * t option list 48 | | BLam of clos 49 | | Refl of t 50 | | Id of t * t * t 51 | | Gel of lvl * t list * closN 52 | | Engel of lvl * t list * t 53 | | Codisc of t 54 | | Encodisc of t 55 | | Global of t 56 | | Englobe of t 57 | | Disc of t 58 | | Endisc of t 59 | | Uni of Syntax.uni_level 60 | [@@deriving show, eq] 61 | and extent_head = {var : lvl; dom : clos; mot : clos2; ctx : t; endcase : clos list; varcase : closN} 62 | [@@deriving show, eq] 63 | and head = 64 | | Var of lvl 65 | | Ext of extent_head 66 | [@@deriving show, eq] 67 | and cell = 68 | | Ap of nf 69 | | Fst 70 | | Snd 71 | | BApp of dim 72 | | NRec of clos * t * clos2 73 | | ListRec of t * clos * t * clos3 74 | | If of clos * t * t 75 | | Case of t * t * clos * clos * clos 76 | | Abort of clos 77 | | J of clos3 * clos * t * t * t 78 | | Ungel of t list * t * t * clos * (* BBINDER *) lvl * clos 79 | | Uncodisc 80 | | Unglobe 81 | | Letdisc of Mode.modality * t * clos * clos 82 | | Letdiscbridge of Mode.modality * t * t list * clos * clos * (* BBINDER *) lvl 83 | | Quasi of quasi_cell 84 | [@@deriving show, eq] 85 | and quasi_cell = 86 | | PiDom 87 | | PiCod of t 88 | | SgDom 89 | | SgCod of t 90 | | ListTp 91 | | CoprodLeft 92 | | CoprodRight 93 | | IdTp 94 | | IdLeft 95 | | IdRight 96 | | BridgeCod of dim 97 | | BridgeEndpoint of ne * int 98 | | GelRel of t list 99 | | GelBridge of t list 100 | | CodiscTp 101 | | GlobalTp 102 | | DiscTp 103 | [@@deriving show, eq] 104 | and spine = cell list 105 | [@@deriving show, eq] 106 | and ne = head * spine 107 | [@@deriving show, eq] 108 | and nf = 109 | | Normal of {tp : t; term : t} 110 | [@@deriving show, eq] 111 | 112 | let root h = (h, []) 113 | let (@:) cell (h, s) = (h, cell :: s) 114 | 115 | let instantiate_bvar r i j = 116 | if j = i then r else j 117 | 118 | let instantiate_dim r i = function 119 | | DVar j -> DVar (instantiate_bvar r i j) 120 | | Const o -> Const o 121 | 122 | let rec instantiate_entry r i = function 123 | | TopLevel t -> TopLevel t 124 | | Dim s -> Dim (instantiate_dim r i s) 125 | | Tm t -> Tm (instantiate r i t) 126 | 127 | and instantiate_env r i env = 128 | List.map (instantiate_entry r i) env 129 | 130 | and instantiate_clos r i = function 131 | | ConstClos t -> ConstClos (instantiate r i t) 132 | | Clos {term; env} -> 133 | Clos {term; env = instantiate_env r i env} 134 | | Pseudo {var; term; ends} -> 135 | let var' = if i = var then var else max (r + 1) var in 136 | let term' = if i = var then term else instantiate r i (instantiate var' var term) in 137 | let ends' = List.map (instantiate r i) ends in 138 | Pseudo {var = var'; term = term'; ends = ends'} 139 | 140 | and instantiate_clos2 r i (Clos2 {term; env}) = 141 | Clos2 {term; env = instantiate_env r i env} 142 | 143 | and instantiate_clos3 r i (Clos3 {term; env}) = 144 | Clos3 {term; env = instantiate_env r i env} 145 | 146 | and instantiate_closN r i (ClosN {term; env}) = 147 | ClosN {term; env = instantiate_env r i env} 148 | 149 | and instantiate r i = function 150 | | Lam clo -> Lam (instantiate_clos r i clo) 151 | | Neutral {tp; term} -> 152 | Neutral {tp = instantiate r i tp; term = instantiate_ne r i term} 153 | | Unit -> Unit 154 | | Triv -> Triv 155 | | Nat -> Nat 156 | | Zero -> Zero 157 | | Suc t -> Suc (instantiate r i t) 158 | | List t -> List (instantiate r i t) 159 | | Nil -> Nil 160 | | Cons (a, t) -> Cons (instantiate r i a, instantiate r i t) 161 | | Bool -> Bool 162 | | True -> True 163 | | False -> False 164 | | Coprod (t1, t2) -> Coprod (instantiate r i t1, instantiate r i t2) 165 | | Inl t -> Inl (instantiate r i t) 166 | | Inr t -> Inr (instantiate r i t) 167 | | Void -> Void 168 | | Pi (m, src, dst) -> Pi (m, instantiate r i src, instantiate_clos r i dst) 169 | | Sg (src, dst) -> Sg (instantiate r i src, instantiate_clos r i dst) 170 | | Pair (t, u) -> Pair (instantiate r i t, instantiate r i u) 171 | | Bridge (dst, ts) -> Bridge (instantiate_clos r i dst, List.map (Option.map (instantiate r i)) ts) 172 | | BLam clo -> BLam (instantiate_clos r i clo) 173 | | Refl t -> Refl (instantiate r i t) 174 | | Id (ty, t, u) -> Id (instantiate r i ty, instantiate r i t, instantiate r i u) 175 | | Gel (j, ts, t) -> Gel (instantiate_bvar r i j, List.map (instantiate r i) ts, instantiate_closN r i t) 176 | | Engel (j, ts, t) -> Engel (instantiate_bvar r i j, List.map (instantiate r i) ts, instantiate r i t) 177 | | Codisc t -> Codisc (instantiate r i t) 178 | | Encodisc t -> Encodisc (instantiate r i t) 179 | | Global t -> Global (instantiate r i t) 180 | | Englobe t -> Englobe (instantiate r i t) 181 | | Disc t -> Disc (instantiate r i t) 182 | | Endisc t -> Endisc (instantiate r i t) 183 | | Uni i -> Uni i 184 | 185 | and instantiate_extent_head r i {var; dom; mot; ctx; endcase; varcase} = 186 | {var = instantiate_bvar r i var; 187 | dom = instantiate_clos r i dom; 188 | mot = instantiate_clos2 r i mot; 189 | ctx = instantiate r i ctx; 190 | endcase = List.map (instantiate_clos r i) endcase; 191 | varcase = instantiate_closN r i varcase} 192 | 193 | and instantiate_spine : 'a. (lvl -> lvl -> 'a -> 'a) -> lvl -> lvl -> 'a * spine -> 'a * spine = 194 | fun head_inst -> 195 | let rec go r i (h, s) = 196 | match s with 197 | | [] -> root (head_inst r i h) 198 | | Ap t :: s -> Ap (instantiate_nf r i t) @: go r i (h, s) 199 | | Fst :: s -> Fst @: go r i (h, s) 200 | | Snd :: s -> Snd @: go r i (h, s) 201 | | BApp t :: s -> BApp (instantiate_dim r i t) @: go r i (h, s) 202 | | NRec (tp, zero, suc) :: s -> 203 | NRec 204 | (instantiate_clos r i tp, 205 | instantiate r i zero, 206 | instantiate_clos2 r i suc) 207 | @: go r i (h, s) 208 | | ListRec (tp, mot, nil, cons) :: s -> 209 | ListRec 210 | (instantiate r i tp, 211 | instantiate_clos r i mot, 212 | instantiate r i nil, 213 | instantiate_clos3 r i cons) 214 | @: go r i (h, s) 215 | | If (mot, tt, ff) :: s -> 216 | If 217 | (instantiate_clos r i mot, 218 | instantiate r i tt, 219 | instantiate r i ff) 220 | @: go r i (h, s) 221 | | Case (left, right, mot, inl, inr) :: s -> 222 | Case 223 | (instantiate r i left, 224 | instantiate r i right, 225 | instantiate_clos r i mot, 226 | instantiate_clos r i inl, 227 | instantiate_clos r i inr) 228 | @: go r i (h, s) 229 | | Abort mot :: s -> 230 | Abort (instantiate_clos r i mot) 231 | @: go r i (h, s) 232 | | J (mot, refl, tp, left, right) :: s -> 233 | J 234 | (instantiate_clos3 r i mot, 235 | instantiate_clos r i refl, 236 | instantiate r i tp, 237 | instantiate r i left, 238 | instantiate r i right) 239 | @: go r i (h, s) 240 | | Ungel (ends, ty, bri, mot, j, case) :: s -> 241 | let j' = if i = j then j else max (r + 1) j in 242 | let ne = if i = j then (h, s) else go r i (go j' j (h, s)) 243 | in 244 | Ungel 245 | (List.map (instantiate r i) ends, 246 | instantiate r i ty, 247 | instantiate r i bri, 248 | instantiate_clos r i mot, 249 | j', 250 | instantiate_clos r i case) 251 | @: ne 252 | | Quasi q :: s -> Quasi (instantiate_quasi_cell r i q) @: go r i (h, s) 253 | | Unglobe :: s -> Unglobe @: go r i (h, s) 254 | | Uncodisc :: s -> Uncodisc @: go r i (h, s) 255 | | Letdisc (m, tp, mot, case) :: s -> 256 | Letdisc 257 | (m, 258 | instantiate r i tp, 259 | instantiate_clos r i mot, 260 | instantiate_clos r i case) 261 | @: go r i (h, s) 262 | | Letdiscbridge (m, tp, ends, mot, case, j) :: s -> 263 | let j' = if i = j then j else max (r + 1) j in 264 | let ne = if i = j then (h, s) else go r i (go j' j (h, s)) 265 | in 266 | Letdiscbridge 267 | (m, 268 | instantiate r i tp, 269 | List.map (instantiate r i) ends, 270 | instantiate_clos r i mot, 271 | instantiate_clos r i case, 272 | j') 273 | @: ne 274 | in 275 | go 276 | 277 | and instantiate_quasi_cell r i = 278 | function 279 | | PiDom -> PiDom 280 | | PiCod v -> PiCod (instantiate r i v) 281 | | SgDom -> SgDom 282 | | SgCod v -> SgCod (instantiate r i v) 283 | | ListTp -> ListTp 284 | | CoprodLeft -> CoprodLeft 285 | | CoprodRight -> CoprodRight 286 | | IdLeft -> IdLeft 287 | | IdRight -> IdRight 288 | | IdTp -> IdTp 289 | | BridgeCod s -> BridgeCod (instantiate_dim r i s) 290 | | BridgeEndpoint (t, o) -> BridgeEndpoint (instantiate_ne r i t, o) 291 | | GelRel ts -> GelRel (List.map (instantiate r i) ts) 292 | | GelBridge ts -> GelBridge (List.map (instantiate r i) ts) 293 | | CodiscTp -> CodiscTp 294 | | GlobalTp -> GlobalTp 295 | | DiscTp -> DiscTp 296 | 297 | and instantiate_ne r i ne = 298 | let headf r i = function 299 | | Var j -> Var (instantiate_bvar r i j) 300 | | Ext e -> Ext (instantiate_extent_head r i e) 301 | in 302 | instantiate_spine headf r i ne 303 | 304 | and instantiate_nf r i (Normal {tp; term}) = 305 | Normal {tp = instantiate r i tp; term = instantiate r i term} 306 | -------------------------------------------------------------------------------- /src/lib/domain.mli: -------------------------------------------------------------------------------- 1 | type lvl = int 2 | 3 | type dim = 4 | | DVar of lvl 5 | | Const of int 6 | 7 | type env_entry = 8 | | TopLevel of t 9 | | Dim of dim 10 | | Tm of t 11 | and env = env_entry list 12 | and clos = 13 | | ConstClos of t 14 | | Clos of {term : Syntax.t; env : env} 15 | | Pseudo of {var : lvl; term : t; ends : t list} 16 | and clos2 = Clos2 of {term : Syntax.t; env : env} 17 | and clos3 = Clos3 of {term : Syntax.t; env : env} 18 | and closN = ClosN of {term : Syntax.t; env : env} 19 | and t = 20 | | Lam of clos 21 | | Neutral of {tp : t; term : ne} 22 | | Unit 23 | | Triv 24 | | Nat 25 | | Zero 26 | | Suc of t 27 | | List of t 28 | | Nil 29 | | Cons of t * t 30 | | Bool 31 | | True 32 | | False 33 | | Coprod of t * t 34 | | Inl of t 35 | | Inr of t 36 | | Void 37 | | Pi of Mode.modality * t * clos 38 | | Sg of t * clos 39 | | Pair of t * t 40 | | Bridge of clos * t option list 41 | | BLam of clos 42 | | Refl of t 43 | | Id of t * t * t 44 | | Gel of lvl * t list * closN 45 | | Engel of lvl * t list * t 46 | | Codisc of t 47 | | Encodisc of t 48 | | Global of t 49 | | Englobe of t 50 | | Disc of t 51 | | Endisc of t 52 | | Uni of Syntax.uni_level 53 | and extent_head = {var : lvl; dom : clos; mot : clos2; ctx : t; endcase : clos list; varcase : closN} 54 | and head = 55 | | Var of lvl 56 | | Ext of extent_head 57 | and cell = 58 | | Ap of nf 59 | | Fst 60 | | Snd 61 | | BApp of dim 62 | | NRec of clos * t * clos2 63 | | ListRec of t * clos * t * clos3 64 | | If of clos * t * t 65 | | Case of t * t * clos * clos * clos 66 | | Abort of clos 67 | | J of clos3 * clos * t * t * t 68 | | Ungel of t list * t * t * clos * (* BBINDER *) lvl * clos 69 | | Uncodisc 70 | | Unglobe 71 | | Letdisc of Mode.modality * t * clos * clos 72 | | Letdiscbridge of Mode.modality * t * t list * clos * clos * (* BBINDER *) lvl 73 | | Quasi of quasi_cell 74 | and quasi_cell = 75 | | PiDom 76 | | PiCod of t 77 | | SgDom 78 | | SgCod of t 79 | | ListTp 80 | | CoprodLeft 81 | | CoprodRight 82 | | IdTp 83 | | IdLeft 84 | | IdRight 85 | | BridgeCod of dim 86 | | BridgeEndpoint of ne * int 87 | | GelRel of t list 88 | | GelBridge of t list 89 | | CodiscTp 90 | | GlobalTp 91 | | DiscTp 92 | and spine = cell list 93 | and ne = head * spine 94 | and nf = 95 | | Normal of {tp : t; term : t} 96 | 97 | val root : 'a -> 'a * spine 98 | val (@:) : cell -> 'a * spine -> 'a * spine 99 | 100 | val instantiate : lvl -> lvl -> t -> t 101 | val instantiate_bvar : lvl -> lvl -> lvl -> lvl 102 | val instantiate_extent_head : lvl -> lvl -> extent_head -> extent_head 103 | val instantiate_spine : (lvl -> lvl -> 'a -> 'a) -> lvl -> lvl -> 'a * spine -> 'a * spine 104 | val instantiate_ne : lvl -> lvl -> ne -> ne 105 | 106 | val equal : t -> t -> bool 107 | val equal_lvl : lvl -> lvl -> bool 108 | val equal_ne : ne -> ne -> bool 109 | val equal_nf : nf -> nf -> bool 110 | 111 | val pp : Format.formatter -> t -> unit 112 | val pp_lvl : Format.formatter -> lvl -> unit 113 | val pp_dim : Format.formatter -> dim -> unit 114 | val pp_nf : Format.formatter -> nf -> unit 115 | val pp_ne : Format.formatter -> ne -> unit 116 | val pp_env : Format.formatter -> env -> unit 117 | 118 | val show : t -> string 119 | val show_nf : nf -> string 120 | val show_ne : ne -> string 121 | -------------------------------------------------------------------------------- /src/lib/driver.ml: -------------------------------------------------------------------------------- 1 | module CS = Concrete_syntax 2 | module S = Syntax 3 | module D = Domain 4 | 5 | type env_entry = 6 | | Dim of string 7 | | Term of string 8 | 9 | type env = Env of {check_env : Check.env; bindings : env_entry list; size : int} 10 | 11 | let initial_env = Env {check_env = []; bindings = []; size = 0} 12 | 13 | type output = 14 | | NoOutput of env 15 | | NF_term of S.t * S.t 16 | | NF_def of CS.ident * S.t 17 | | Quit 18 | 19 | let update_env env = function 20 | | NoOutput env -> env 21 | | NF_term _ | NF_def _ | Quit -> env 22 | 23 | let output = function 24 | | NoOutput _ -> () 25 | | NF_term (s, t) -> 26 | Format.fprintf Format.std_formatter "Computed normal form of@ @["; 27 | S.pp Format.std_formatter s; 28 | Format.fprintf Format.std_formatter "@] as @ @["; 29 | S.pp Format.std_formatter t; 30 | Format.fprintf Format.std_formatter "@]@," 31 | | NF_def (name, t) -> 32 | Format.fprintf Format.std_formatter "Computed normal form of [%s]:@ @[" name; 33 | Syntax.pp Format.std_formatter t; 34 | Format.fprintf Format.std_formatter "@]@," 35 | | Quit -> exit 0 36 | 37 | let find_idx key = 38 | let rec go i = function 39 | | [] -> raise (Check.Type_error (Check.Misc ("Unbound variable: " ^ key ^ "\n"))) 40 | | Dim x :: xs -> if String.equal x key then i else go (i + 1) xs 41 | | Term x :: xs -> if String.equal x key then i else go (i + 1) xs 42 | in 43 | go 0 44 | 45 | let rec int_to_term = function 46 | | 0 -> S.Zero 47 | | n -> S.Suc (int_to_term (n - 1)) 48 | 49 | let rec unravel_spine f = function 50 | | [] -> f 51 | | x :: xs -> unravel_spine (x f) xs 52 | 53 | let rec extent_env env = function 54 | | [var_bridge; var_dim] -> Dim var_dim :: Term var_bridge :: env 55 | | name :: names -> extent_env (Term name :: env) names 56 | | _ -> raise (Check.Type_error (Check.Misc ("Bad length in extent"))) 57 | 58 | let bind_dim env = function 59 | | CS.DVar i -> S.DVar (find_idx i env) 60 | | CS.Const o -> S.Const o 61 | 62 | let rec bind env = function 63 | | CS.Var i -> S.Var (find_idx i env) 64 | | CS.Let (tp, Binder {name; body}) -> 65 | S.Let (bind env tp, bind (Term name :: env) body) 66 | | CS.Check {term; tp} -> S.Check (bind env term, bind env tp) 67 | | CS.Unit -> S.Unit 68 | | CS.Triv -> S.Triv 69 | | CS.Nat -> S.Nat 70 | | CS.Suc t -> S.Suc (bind env t) 71 | | CS.Lit i -> int_to_term i 72 | | CS.NRec 73 | {mot = Binder {name = mot_name; body = mot_body}; 74 | zero; 75 | suc = Binder2 {name1 = suc_name1; name2 = suc_name2; body = suc_body}; 76 | nat} -> 77 | S.NRec 78 | (bind (Term mot_name :: env) mot_body, 79 | bind env zero, 80 | bind (Term suc_name2 :: Term suc_name1 :: env) suc_body, 81 | bind env nat) 82 | | CS.List t -> S.List (bind env t) 83 | | CS.Nil -> S.Nil 84 | | CS.Cons (a, t) -> S.Cons (bind env a, bind env t) 85 | | CS.ListRec 86 | {mot = Binder {name = mot_name; body = mot_body}; 87 | nil; 88 | cons = Binder3 {name1 = cons_name1; name2 = cons_name2; name3 = cons_name3; body = cons_body}; 89 | list} -> 90 | S.ListRec 91 | (bind (Term mot_name :: env) mot_body, 92 | bind env nil, 93 | bind (Term cons_name3 :: Term cons_name2 :: Term cons_name1 :: env) cons_body, 94 | bind env list) 95 | | CS.Bool -> S.Bool 96 | | CS.True -> S.True 97 | | CS.False -> S.False 98 | | CS.If {mot = Binder {name = mot_name; body = mot_body}; tt; ff; bool} -> 99 | S.If (bind (Term mot_name :: env) mot_body, bind env tt, bind env ff, bind env bool) 100 | | CS.Coprod (left, right) -> S.Coprod (bind env left, bind env right) 101 | | CS.Inl t -> S.Inl (bind env t) 102 | | CS.Inr t -> S.Inr (bind env t) 103 | | CS.Case 104 | {mot = Binder {name = mot_name; body = mot_body}; 105 | inl = Binder {name = inl_name; body = inl_body}; 106 | inr = Binder {name = inr_name; body = inr_body}; 107 | coprod} -> 108 | S.Case 109 | (bind (Term mot_name :: env) mot_body, 110 | bind (Term inl_name :: env) inl_body, 111 | bind (Term inr_name :: env) inr_body, 112 | bind env coprod) 113 | | CS.Void -> S.Void 114 | | CS.Abort {mot = Binder {name = mot_name; body = mot_body}; void} -> 115 | S.Abort (bind (Term mot_name :: env) mot_body, bind env void) 116 | | CS.Lam (BinderN {names = []; body}) -> 117 | bind env body 118 | | CS.Lam (BinderN {names = x :: names; body}) -> 119 | let lam = CS.Lam (BinderN {names; body}) in 120 | S.Lam (bind (Term x :: env) lam) 121 | | CS.Ap (f, args) -> 122 | unravel_spine (bind env f) (List.map (bind_spine env) args) 123 | | CS.Sg ([], body) -> 124 | bind env body 125 | | CS.Sg (Cell cell :: tele, body) -> 126 | if cell.m = Mode.Id 127 | then S.Sg (bind env cell.ty, bind (Term cell.name :: env) (CS.Sg (tele, body))) 128 | else raise (Failure "Modal sigma-types are not supported") 129 | | CS.Pi ([], body) -> 130 | bind env body 131 | | CS.Pi (Cell cell :: tele, body) -> 132 | S.Pi (cell.m, bind env cell.ty, bind (Term cell.name :: env) (CS.Pi (tele, body))) 133 | | CS.Pair (l, r) -> S.Pair (bind env l, bind env r) 134 | | CS.Fst p -> S.Fst (bind env p) 135 | | CS.Snd p -> S.Snd (bind env p) 136 | | CS.J 137 | {mot = Binder3 {name1 = left; name2 = right; name3 = prf; body = mot_body}; 138 | refl = Binder {name = refl_name; body = refl_body}; 139 | eq} -> 140 | S.J 141 | (bind (Term prf :: Term right :: Term left :: env) mot_body, 142 | bind (Term refl_name :: env) refl_body, 143 | bind env eq) 144 | | CS.Id (tp, left, right) -> 145 | S.Id (bind env tp, bind env left, bind env right) 146 | | CS.Refl t -> S.Refl (bind env t) 147 | | CS.Bridge (Binder {name; body}, endpoints) -> 148 | S.Bridge (bind (Dim name :: env) body, List.map (Option.map (bind env)) endpoints) 149 | | CS.BLam (BinderN {names = []; body}) -> 150 | bind env body 151 | | CS.BLam (BinderN {names = i :: names; body}) -> 152 | let blam = CS.BLam (BinderN {names; body}) in 153 | S.BLam (bind (Dim i :: env) blam) 154 | | CS.Extent 155 | {dim; 156 | dom = Binder {name = dom_dim; body = dom_body}; 157 | mot = Binder2 {name1 = mot_dim; name2 = mot_dom; body = mot_body}; 158 | ctx; 159 | endcase; 160 | varcase = BinderN {names; body = var_body}} -> 161 | S.Extent 162 | (bind_dim env dim, 163 | bind (Dim dom_dim :: env) dom_body, 164 | bind (Term mot_dom :: Dim mot_dim :: env) mot_body, 165 | bind env ctx, 166 | List.map (function (CS.Binder {name; body}) -> bind (Term name :: env) body) endcase, 167 | bind (extent_env env names) var_body) 168 | | CS.Gel (r, ends, BinderN {names; body}) -> 169 | S.Gel 170 | (bind_dim env r, 171 | List.map (bind env) ends, 172 | bind (List.rev_append (List.map (fun t -> Term t) names) env) body) 173 | | CS.Engel (i, ts, t) -> 174 | S.Engel (find_idx i env, List.map (bind env) ts, bind env t) 175 | | CS.Ungel 176 | {width; 177 | mot = Binder {name = mot_name; body = mot_body}; 178 | gel = Binder {name = gel_name; body = gel_body}; 179 | case = Binder {name = case_name; body = case_body}} -> 180 | S.Ungel 181 | (width, 182 | bind (Term mot_name :: env) mot_body, 183 | bind (Dim gel_name :: env) gel_body, 184 | bind (Term case_name :: env) case_body) 185 | | CS.Codisc t -> S.Codisc (bind env t) 186 | | CS.Encodisc t -> S.Encodisc (bind env t) 187 | | CS.Uncodisc t -> S.Uncodisc (bind env t) 188 | | CS.Global t -> S.Global (bind env t) 189 | | CS.Englobe t -> S.Englobe (bind env t) 190 | | CS.Unglobe t -> S.Unglobe (bind env t) 191 | | CS.Disc t -> S.Disc (bind env t) 192 | | CS.Endisc t -> S.Endisc (bind env t) 193 | | CS.Letdisc 194 | {modality; 195 | mot = Binder {name = mot_name; body = mot_body}; 196 | case = Binder {name = case_name; body = case_body}; 197 | disc} -> 198 | S.Letdisc 199 | (modality, 200 | bind (Term mot_name :: env) mot_body, 201 | bind (Term case_name :: env) case_body, 202 | bind env disc) 203 | | CS.Letdiscbridge 204 | {modality; 205 | width; 206 | mot = Binder {name = mot_name; body = mot_body}; 207 | case = Binder {name = case_name; body = case_body}; 208 | disc = Binder {name = disc_name; body = disc_body}} -> 209 | S.Letdiscbridge 210 | (modality, 211 | width, 212 | bind (Term mot_name :: env) mot_body, 213 | bind (Term case_name :: env) case_body, 214 | bind (Term disc_name :: env) disc_body) 215 | | CS.Uni i -> S.Uni i 216 | 217 | and bind_spine env = function 218 | | CS.Term t -> fun f -> S.Ap (f, bind env t) 219 | | CS.Dim b -> fun f -> S.BApp (f, bind_dim env b) 220 | 221 | let process_decl (Env {check_env; bindings; size}) = function 222 | | CS.Def {name; mode; def; tp} -> 223 | let def = bind bindings def in 224 | let tp = bind bindings tp in 225 | Check.check_tp ~mode ~env:check_env ~size ~term:tp; 226 | let sem_env = Check.env_to_sem_env check_env in 227 | let sem_tp = Eval.eval tp sem_env size in 228 | Check.check ~mode ~env:check_env ~size ~term:def ~tp:sem_tp; 229 | let sem_def = Eval.eval def sem_env size in 230 | let new_env = Check.TopLevel {mode; term = sem_def; tp = sem_tp} :: check_env in 231 | NoOutput (Env {check_env = new_env; bindings = Term name :: bindings; size}) 232 | | CS.Postulate {name; mode; tp} -> 233 | let tp = bind bindings tp in 234 | Check.check_tp ~mode ~env:check_env ~size ~term:tp; 235 | let sem_env = Check.env_to_sem_env check_env in 236 | let sem_tp = Eval.eval tp sem_env size in 237 | let new_env = Check.Postulate {level = size; mode; tp = sem_tp} :: check_env in 238 | NoOutput (Env {check_env = new_env; bindings = Term name :: bindings; size = size + 1}) 239 | | CS.NormalizeDef name -> 240 | let err = Check.Type_error (Check.Misc ("Unbound variable: " ^ name ^ "\n")) in 241 | begin 242 | let i = find_idx name bindings in 243 | match List.nth check_env i with 244 | | Check.TopLevel {term; tp; _} -> 245 | let quote_env = Check.env_to_quote_env check_env in 246 | NF_def (name, Quote.read_back_nf quote_env size (D.Normal {term; tp})) 247 | | _ -> raise err 248 | | exception Failure _ -> raise err 249 | end 250 | | CS.NormalizeTerm {mode; term; tp} -> 251 | let term = bind bindings term in 252 | let tp = bind bindings tp in 253 | Check.check_tp ~mode ~env:check_env ~size ~term:tp; 254 | let quote_env = Check.env_to_quote_env check_env in 255 | let sem_env = Quote.env_to_sem_env quote_env in 256 | let sem_tp = Eval.eval tp sem_env size in 257 | Check.check ~mode ~env:check_env ~size ~term ~tp:sem_tp; 258 | let sem_term = Eval.eval term sem_env size in 259 | let norm_term = Quote.read_back_nf quote_env size (D.Normal {term = sem_term; tp = sem_tp}) in 260 | NF_term (term, norm_term) 261 | | CS.Quit -> Quit 262 | 263 | let rec process_sign ?env = function 264 | | [] -> () 265 | | d :: ds -> 266 | let env = match env with 267 | None -> initial_env 268 | | Some e -> e in 269 | let o = process_decl env d in 270 | output o; 271 | process_sign ?env:(Some (update_env env o)) ds 272 | 273 | let process_sign : Concrete_syntax.signature -> unit = process_sign 274 | -------------------------------------------------------------------------------- /src/lib/driver.mli: -------------------------------------------------------------------------------- 1 | (* This is the top-level driver for the proof assistant. Given 2 | * a signature (a list of commands/declarations) process each 3 | * command in sequence *) 4 | val process_sign : Concrete_syntax.signature -> unit 5 | -------------------------------------------------------------------------------- /src/lib/dune: -------------------------------------------------------------------------------- 1 | (menhir 2 | (flags --strict --explain --interpret-show-cst --table) 3 | (modules grammar)) 4 | 5 | (ocamllex lex) 6 | 7 | (library 8 | (name Core) 9 | (libraries menhirLib) 10 | (preprocess (pps ppx_deriving.std)) 11 | (flags (:standard -w -9-32-37)) 12 | (public_name ptt.core)) 13 | -------------------------------------------------------------------------------- /src/lib/eval.ml: -------------------------------------------------------------------------------- 1 | module Syn = Syntax 2 | module D = Domain 3 | 4 | exception Eval_failed of string 5 | 6 | let eval_dim r (env : D.env) = 7 | match r with 8 | | Syn.DVar i -> 9 | begin 10 | match List.nth env i with 11 | | D.TopLevel _ -> raise (Eval_failed "Not a dimension term") 12 | | D.Dim s -> s 13 | | D.Tm _ -> raise (Eval_failed "Not a dimension term") 14 | end 15 | | Syn.Const o -> D.Const o 16 | 17 | let rec do_clos size clo a = 18 | match clo with 19 | | D.ConstClos t -> t 20 | | D.Clos {term; env} -> eval term (a :: env) size 21 | | D.Pseudo {var; term; ends} -> 22 | begin 23 | match a with 24 | | D.TopLevel _ -> raise (Eval_failed "Applied psuedo-closure to term") 25 | | D.Dim (D.DVar i) -> D.instantiate i var term 26 | | D.Dim (D.Const o) -> List.nth ends o 27 | | D.Tm _ -> raise (Eval_failed "Applied psuedo-closure to term") 28 | end 29 | 30 | and do_clos2 size (D.Clos2 {term; env}) a1 a2 = 31 | eval term (a2 :: a1 :: env) size 32 | 33 | and do_clos3 size (D.Clos3 {term; env}) t1 t2 t3 = 34 | eval term (D.Tm t3 :: D.Tm t2 :: D.Tm t1 :: env) size 35 | 36 | and do_closN size (D.ClosN {term; env}) tN = 37 | eval term (List.rev_append (List.map (fun t -> D.Tm t) tN) env) size 38 | 39 | and do_clos_extent size (D.ClosN {term; env}) tN t r = 40 | eval term (D.Dim r :: D.Tm t :: List.rev_append (List.map (fun t -> D.Tm t) tN) env) size 41 | 42 | and do_consts size clo width = 43 | match clo with 44 | | D.ConstClos t -> 45 | List.init width (fun _ -> t) 46 | | D.Clos {term; env} -> 47 | List.init width (fun o -> eval term (D.Dim (D.Const o) :: env) size) 48 | | D.Pseudo {ends; _} -> ends 49 | 50 | and do_rec size tp zero suc n = 51 | match n with 52 | | D.Zero -> zero 53 | | D.Suc n -> do_clos2 size suc (D.Tm n) (D.Tm (do_rec size tp zero suc n)) 54 | | D.Neutral {term; _} -> 55 | let final_tp = do_clos size tp (D.Tm n) in 56 | D.Neutral {tp = final_tp; term = D.(NRec (tp, zero, suc) @: term)} 57 | | _ -> raise (Eval_failed "Not a number") 58 | 59 | and do_list_rec size mot nil cons l = 60 | match l with 61 | | D.Nil -> nil 62 | | D.Cons (a, l) -> 63 | do_clos3 size cons a l (do_list_rec size mot nil cons l) 64 | | D.Neutral {term; tp} -> 65 | let dom = do_list_tp tp in 66 | let final_tp = do_clos size mot (D.Tm l) in 67 | D.Neutral {tp = final_tp; term = D.(ListRec (dom, mot, nil, cons) @: term)} 68 | | _ -> raise (Eval_failed "Not a list") 69 | 70 | and do_if size mot tt ff b = 71 | match b with 72 | | D.True -> tt 73 | | D.False -> ff 74 | | D.Neutral {term; _} -> 75 | let final_tp = do_clos size mot (D.Tm b) in 76 | D.Neutral {tp = final_tp; term = D.(If (mot, tt, ff) @: term)} 77 | | _ -> raise (Eval_failed "Not a boolean") 78 | 79 | and do_case size mot inl inr co = 80 | match co with 81 | | D.Inl t -> do_clos size inl (D.Tm t) 82 | | D.Inr t -> do_clos size inr (D.Tm t) 83 | | D.Neutral {term; tp} -> 84 | let left = do_coprod_left tp in 85 | let right = do_coprod_right tp in 86 | let final_tp = do_clos size mot (D.Tm co) in 87 | D.Neutral {tp = final_tp; term = D.(Case (left, right, mot, inl, inr) @: term)} 88 | | _ -> raise (Eval_failed "Not a coproduct") 89 | 90 | and do_abort size mot vd = 91 | match vd with 92 | | D.Neutral {term; _} -> 93 | let final_tp = do_clos size mot (D.Tm vd) in 94 | D.Neutral {tp = final_tp; term = D.(Abort mot @: term)} 95 | | _ -> raise (Eval_failed "Not a void") 96 | 97 | and do_fst p = 98 | match p with 99 | | D.Pair (p1, _) -> p1 100 | | D.Neutral {tp; term} -> 101 | D.Neutral {tp = do_sg_dom tp; term = D.(Fst @: term)} 102 | | _ -> raise (Eval_failed "Couldn't fst argument in do_fst") 103 | 104 | and do_snd size p = 105 | match p with 106 | | D.Pair (_, p2) -> p2 107 | | D.Neutral {tp; term} -> 108 | let fst = do_fst p in 109 | D.Neutral {tp = do_sg_cod size tp fst; term = D.(Snd @: term)} 110 | | _ -> raise (Eval_failed "Couldn't snd argument in do_snd") 111 | 112 | and do_bapp size t r = 113 | match t with 114 | | D.BLam bclo -> do_clos size bclo (D.Dim r) 115 | | D.Neutral {tp; term} -> 116 | begin 117 | match r with 118 | | D.DVar _ -> 119 | let dst = do_bridge_cod size tp r in 120 | D.Neutral {tp = dst; term = D.(BApp r @: term)} 121 | | Const o -> 122 | do_bridge_endpoint size tp term o 123 | end 124 | | _ -> raise (Eval_failed "Not a bridge or neutral in bapp") 125 | 126 | and do_j size mot refl eq = 127 | match eq with 128 | | D.Refl t -> do_clos size refl (D.Tm t) 129 | | D.Neutral {tp; term = term} -> 130 | let dom = do_id_tp tp in 131 | let left = do_id_left tp in 132 | let right = do_id_right tp in 133 | D.Neutral 134 | {tp = do_clos3 size mot left right eq; 135 | term = D.(J (mot, refl, dom, left, right) @: term)} 136 | | _ -> raise (Eval_failed "Not a refl or neutral in do_j") 137 | 138 | and do_ap size f a = 139 | match f with 140 | | D.Lam clos -> do_clos size clos (D.Tm a) 141 | | D.Neutral {tp; term} -> 142 | let src = do_pi_dom tp in 143 | let dst = do_pi_cod size tp a in 144 | D.Neutral {tp = dst; term = D.(Ap (D.Normal {tp = src; term = a}) @: term)} 145 | | _ -> raise (Eval_failed "Not a function in do_ap") 146 | 147 | 148 | and do_ungel size ends mot gel case = 149 | begin 150 | match gel with 151 | | D.Engel (_, _, t) -> do_clos size case (D.Tm t) 152 | | D.Neutral {tp; term} -> 153 | let rel = do_gel_rel size tp ends in 154 | let bri = do_gel_bridge size tp ends in 155 | let final_tp = 156 | do_clos size mot (D.Tm (D.BLam (D.Pseudo {var = size; term = gel; ends}))) in 157 | D.Neutral {tp = final_tp; term = D.(Ungel (ends, rel, bri, mot, size, case) @: term)} 158 | | _ -> raise (Eval_failed "Not a gel or neutral in do_ungel") 159 | end 160 | 161 | and do_uncodisc t = 162 | match t with 163 | | D.Encodisc t -> t 164 | | D.Neutral {tp; term} -> 165 | D.Neutral {tp = do_codisc_tp tp; term = D.(Uncodisc @: term)} 166 | | _ -> raise (Eval_failed "Couldn't uncodisc argument in do_uncodisc") 167 | 168 | and do_unglobe t = 169 | match t with 170 | | D.Englobe t -> t 171 | | D.Neutral {tp; term} -> 172 | D.Neutral {tp = do_global_tp tp; term = D.(Unglobe @: term)} 173 | | _ -> raise (Eval_failed "Couldn't unglobe argument in do_unglobe") 174 | 175 | and do_letdisc size m mot case d = 176 | match d with 177 | | D.Endisc t -> do_clos size case (D.Tm t) 178 | | D.Neutral {tp; term} -> 179 | let inner_tp = do_disc_tp tp in 180 | D.Neutral {tp = do_clos size mot (D.Tm d); term = D.(Letdisc (m, inner_tp, mot, case) @: term)} 181 | | _ -> raise (Eval_failed "Not an endisc or neutral in do_letdisc") 182 | 183 | and do_letdiscbridge size m ends mot case d = 184 | match d with 185 | | D.Endisc t -> do_clos size case (D.Tm t) 186 | | D.Neutral {tp; term} -> 187 | let inner_tp = do_disc_tp tp in 188 | let final_tp = 189 | do_clos size mot (D.Tm (D.BLam (D.Pseudo {var = size; term = d; ends}))) in 190 | D.Neutral {tp = final_tp; term = D.(Letdiscbridge (m, inner_tp, ends, mot, case, size) @: term)} 191 | | _ -> raise (Eval_failed "Not an endisc or neutral in do_letdiscbridge") 192 | 193 | and do_list_tp tp = 194 | match tp with 195 | | D.List tp -> tp 196 | | D.Neutral {tp; term} -> 197 | D.Neutral {tp; term = D.(Quasi ListTp @: term)} 198 | | _ -> raise (Eval_failed "Not something that can become a list type") 199 | 200 | and do_coprod_left tp = 201 | match tp with 202 | | D.Coprod (t, _) -> t 203 | | D.Neutral {tp; term} -> 204 | D.Neutral {tp; term = D.(Quasi CoprodLeft @: term)} 205 | | _ -> raise (Eval_failed "Not something that can become a coproduct type") 206 | 207 | and do_coprod_right tp = 208 | match tp with 209 | | D.Coprod (_, t) -> t 210 | | D.Neutral {tp; term} -> 211 | D.Neutral {tp; term = D.(Quasi CoprodRight @: term)} 212 | | _ -> raise (Eval_failed "Not something that can become a coproduct type") 213 | 214 | and do_id_tp tp = 215 | match tp with 216 | | D.Id (tp, _, _) -> tp 217 | | D.Neutral {tp; term} -> 218 | D.Neutral {tp; term = D.(Quasi IdTp @: term)} 219 | | _ -> raise (Eval_failed "Not something that can become a identity type") 220 | 221 | and do_id_left tp = 222 | match tp with 223 | | D.Id (_, l, _) -> l 224 | | D.Neutral {tp; term} -> 225 | D.Neutral {tp = D.(Neutral {tp; term = Quasi IdTp @: term}); term = D.(Quasi IdLeft @: term)} 226 | | _ -> raise (Eval_failed "Not something that can become a identity type") 227 | 228 | 229 | and do_id_right tp = 230 | match tp with 231 | | D.Id (_, _, r) -> r 232 | | D.Neutral {tp; term} -> 233 | D.Neutral {tp = D.(Neutral {tp; term = Quasi IdTp @: term}); term = D.(Quasi IdRight @: term)} 234 | | _ -> raise (Eval_failed "Not something that can become a identity type") 235 | 236 | and do_bridge_cod size tp s = 237 | match tp with 238 | | D.Bridge (clos, _) -> 239 | do_clos size clos (D.Dim s) 240 | | D.Neutral {tp; term} -> 241 | D.Neutral {tp; term = D.(Quasi (BridgeCod s) @: term)} 242 | | _ -> raise (Eval_failed "Not something that can be come a bridge type") 243 | 244 | and do_bridge_endpoint size tp ne o = 245 | match tp with 246 | | D.Bridge (_, ts) -> 247 | begin 248 | match List.nth ts o with 249 | | Some t -> t 250 | | None -> 251 | let dst = do_bridge_cod size tp (D.Const o) in 252 | D.Neutral {tp = dst; term = D.(BApp (Const o) @: ne)} 253 | end 254 | | D.Neutral {tp; term} -> 255 | D.Neutral 256 | {tp = D.Neutral {tp; term = D.(Quasi (BridgeCod (D.Const o)) @: term)}; 257 | term = D.(Quasi (BridgeEndpoint (term, o)) @: term)} 258 | | _ -> raise (Eval_failed "Not something that can be come a bridge type") 259 | 260 | and do_pi_dom f = 261 | match f with 262 | | D.Pi (_, tp, _) -> tp 263 | | D.Neutral {tp; term} -> 264 | D.Neutral {tp; term = D.(Quasi PiDom @: term)} 265 | | _ -> raise (Eval_failed "Not something that can become a pi type") 266 | 267 | and do_pi_cod size f a = 268 | match f with 269 | | D.Pi (_, _, dst) -> do_clos size dst (D.Tm a) 270 | | D.Neutral {tp; term} -> 271 | D.Neutral {tp; term = D.(Quasi (PiCod a) @: term)} 272 | | _ -> raise (Eval_failed "Not something that can become a pi type") 273 | 274 | 275 | and do_sg_dom f = 276 | match f with 277 | | D.Sg (tp, _) -> tp 278 | | D.Neutral {tp; term} -> 279 | D.Neutral {tp; term = D.(Quasi SgDom @: term)} 280 | | _ -> raise (Eval_failed "Not something that can become a sigma type") 281 | 282 | and do_sg_cod size f a = 283 | match f with 284 | | D.Sg (_,dst) -> do_clos size dst (D.Tm a) 285 | | D.Neutral {tp; term} -> 286 | D.Neutral {tp; term = D.(Quasi (SgCod a) @: term)} 287 | | _ -> raise (Eval_failed "Not something that can become a sigma type") 288 | 289 | and do_gel_rel size f end_tms = 290 | match f with 291 | | D.Gel (_, _, rel) -> do_closN size rel end_tms 292 | | D.Neutral {tp; term} -> 293 | D.Neutral {tp; term = D.(Quasi (GelRel end_tms) @: term)} 294 | | _ -> raise (Eval_failed "Not something that can become a gel type") 295 | 296 | and do_gel_bridge size f end_tms = 297 | match f with 298 | | D.Gel (_, end_tps, rel) -> 299 | D.Bridge 300 | (D.Pseudo {var = size; term = D.Gel (size, end_tps, rel); ends = end_tps}, 301 | List.map Option.some end_tms) 302 | | D.Neutral {tp; term} -> 303 | D.Neutral {tp; term = D.(Quasi (GelBridge end_tms) @: term)} 304 | | _ -> raise (Eval_failed "Not something that can become a gel type") 305 | 306 | and do_codisc_tp f = 307 | match f with 308 | | D.Codisc tp -> tp 309 | | D.Neutral {tp; term} -> 310 | D.Neutral {tp; term = D.(Quasi CodiscTp @: term)} 311 | | _ -> raise (Eval_failed "Not something that can become a discrete type") 312 | 313 | and do_global_tp f = 314 | match f with 315 | | D.Global tp -> tp 316 | | D.Neutral {tp; term} -> 317 | D.Neutral {tp; term = D.(Quasi GlobalTp @: term)} 318 | | _ -> raise (Eval_failed "Not something that can become a global type") 319 | 320 | and do_disc_tp f = 321 | match f with 322 | | D.Disc tp -> tp 323 | | D.Neutral {tp; term} -> 324 | D.Neutral {tp; term = D.(Quasi DiscTp @: term)} 325 | | _ -> raise (Eval_failed "Not something that can become a discrete type") 326 | 327 | and eval t (env : D.env) size = 328 | match t with 329 | | Syn.Var i -> 330 | begin 331 | match List.nth env i with 332 | | D.TopLevel t -> t 333 | | D.Tm t -> t 334 | | D.Dim _-> raise (Eval_failed "Not a term variable") 335 | end 336 | | Syn.Let (def, body) -> eval body (D.Tm (eval def env size) :: env) size 337 | | Syn.Check (term, _) -> eval term env size 338 | | Syn.Unit -> D.Unit 339 | | Syn.Triv -> D.Triv 340 | | Syn.Nat -> D.Nat 341 | | Syn.List t -> D.List (eval t env size) 342 | | Syn.Zero -> D.Zero 343 | | Syn.Suc t -> D.Suc (eval t env size) 344 | | Syn.NRec (tp, zero, suc, n) -> 345 | do_rec size 346 | (Clos {term = tp; env}) 347 | (eval zero env size) 348 | (Clos2 {term = suc; env}) 349 | (eval n env size) 350 | | Syn.Nil -> D.Nil 351 | | Syn.Cons (a, t) -> D.Cons (eval a env size, eval t env size) 352 | | Syn.ListRec (mot, nil, cons, l) -> 353 | do_list_rec size 354 | (Clos {term = mot; env}) 355 | (eval nil env size) 356 | (Clos3 {term = cons; env}) 357 | (eval l env size) 358 | | Syn.Bool -> D.Bool 359 | | Syn.True -> D.True 360 | | Syn.False -> D.False 361 | | Syn.If (mot, tt, ff, b) -> 362 | do_if size 363 | (Clos {term = mot; env}) 364 | (eval tt env size) 365 | (eval ff env size) 366 | (eval b env size) 367 | | Syn.Coprod (t1, t2) -> D.Coprod (eval t1 env size, eval t2 env size) 368 | | Syn.Inl t -> D.Inl (eval t env size) 369 | | Syn.Inr t -> D.Inr (eval t env size) 370 | | Syn.Case (mot, inl, inr, co) -> 371 | do_case size 372 | (Clos {term = mot; env}) 373 | (Clos {term = inl; env}) 374 | (Clos {term = inr; env}) 375 | (eval co env size) 376 | | Syn.Void -> D.Void 377 | | Syn.Abort (mot, vd) -> 378 | do_abort size (Clos {term = mot; env}) (eval vd env size) 379 | | Syn.Pi (m, src, dest) -> 380 | D.Pi (m, eval src env size, (Clos {term = dest; env})) 381 | | Syn.Lam t -> D.Lam (Clos {term = t; env}) 382 | | Syn.Ap (t1, t2) -> do_ap size (eval t1 env size) (eval t2 env size) 383 | | Syn.Uni i -> D.Uni i 384 | | Syn.Sg (t1, t2) -> D.Sg (eval t1 env size, (Clos {term = t2; env})) 385 | | Syn.Pair (t1, t2) -> D.Pair (eval t1 env size, eval t2 env size) 386 | | Syn.Fst t -> do_fst (eval t env size) 387 | | Syn.Snd t -> do_snd size (eval t env size) 388 | | Syn.Bridge (dest, ts) -> 389 | D.Bridge (Clos {term = dest; env}, List.map (Option.map (fun t -> eval t env size)) ts) 390 | | Syn.BApp (t,r) -> 391 | let r' = eval_dim r env in 392 | do_bapp size (eval t env size) r' 393 | | Syn.BLam t -> D.BLam (Clos {term = t; env}) 394 | | Syn.Refl t -> D.Refl (eval t env size) 395 | | Syn.Id (tp, left, right) -> D.Id (eval tp env size, eval left env size, eval right env size) 396 | | Syn.J (mot, refl, eq) -> 397 | do_j size (D.Clos3 {term = mot; env}) (D.Clos {term = refl; env}) (eval eq env size) 398 | | Syn.Extent (r, dom, mot, ctx, endcase, varcase) -> 399 | let r' = eval_dim r env in 400 | let ctx' = eval ctx env size in 401 | begin 402 | match r' with 403 | | D.DVar i -> 404 | let final_tp = eval mot (D.Tm ctx' :: D.Dim r' :: env) size in 405 | let ext = 406 | D.Ext 407 | {var = i; 408 | dom = D.Clos {term = dom; env}; 409 | mot = D.Clos2 {term = mot; env}; 410 | ctx = ctx'; 411 | endcase = List.map (fun t -> D.Clos {term = t; env}) endcase; 412 | varcase = D.ClosN {term = varcase; env}} 413 | in 414 | D.Neutral {tp = final_tp; term = D.root ext} 415 | | D.Const o -> 416 | eval (List.nth endcase o) (D.Tm ctx' :: env) size 417 | end 418 | | Syn.Gel (r, endtps, rel) -> 419 | begin 420 | let r' = eval_dim r env in 421 | match r' with 422 | | D.DVar i -> D.Gel (i, List.map (fun t -> eval t env size) endtps, D.ClosN {term = rel; env}) 423 | | D.Const o -> eval (List.nth endtps o) env size 424 | end 425 | | Syn.Engel (i, ts, t) -> 426 | begin 427 | let r' = eval_dim (Syn.DVar i) env in 428 | match r' with 429 | | D.DVar i' -> D.Engel (i', List.map (fun t -> eval t env size) ts, eval t env size) 430 | | Const o -> eval (List.nth ts o) env size 431 | end 432 | | Syn.Ungel (width, mot, gel, case) -> 433 | do_ungel 434 | size 435 | (do_consts size (D.Clos {term = gel; env}) width) 436 | (D.Clos {term = mot; env}) 437 | (eval gel (D.Dim (D.DVar size) :: env) (size + 1)) 438 | (D.Clos {term = case; env}) 439 | | Syn.Codisc t -> D.Codisc (eval t env size) 440 | | Syn.Encodisc t -> D.Encodisc (eval t env size) 441 | | Syn.Uncodisc t -> do_uncodisc (eval t env size) 442 | | Syn.Global t -> D.Global (eval t env size) 443 | | Syn.Englobe t -> D.Englobe (eval t env size) 444 | | Syn.Unglobe t -> do_unglobe (eval t env size) 445 | | Syn.Disc t -> D.Disc (eval t env size) 446 | | Syn.Endisc t -> D.Endisc (eval t env size) 447 | | Syn.Letdisc (m, mot, case, d) -> 448 | do_letdisc 449 | size 450 | m 451 | (D.Clos {term = mot; env}) 452 | (D.Clos {term = case; env}) 453 | (eval d env size) 454 | | Syn.Letdiscbridge (m, width, mot, case, d) -> 455 | do_letdiscbridge 456 | size 457 | m 458 | (do_consts size (D.Clos {term = d; env}) width) 459 | (D.Clos {term = mot; env}) 460 | (D.Clos {term = case; env}) 461 | (eval d (D.Dim (D.DVar size) :: env) (size + 1)) 462 | -------------------------------------------------------------------------------- /src/lib/eval.mli: -------------------------------------------------------------------------------- 1 | exception Eval_failed of string 2 | 3 | (* Evaluation *) 4 | val eval_dim : Syntax.dim -> Domain.env -> Domain.dim 5 | val eval : Syntax.t -> Domain.env -> Domain.lvl -> Domain.t 6 | 7 | (* Functions to manipulate elements of the semantic domain *) 8 | val do_ap : Domain.lvl -> Domain.t -> Domain.t -> Domain.t 9 | val do_bapp : Domain.lvl -> Domain.t -> Domain.dim -> Domain.t 10 | val do_rec : Domain.lvl -> Domain.clos -> Domain.t -> Domain.clos2 -> Domain.t -> Domain.t 11 | val do_list_rec : Domain.lvl -> Domain.clos -> Domain.t -> Domain.clos3 -> Domain.t -> Domain.t 12 | val do_if : Domain.lvl -> Domain.clos -> Domain.t -> Domain.t -> Domain.t -> Domain.t 13 | val do_case : Domain.lvl -> Domain.clos -> Domain.clos -> Domain.clos -> Domain.t -> Domain.t 14 | val do_abort : Domain.lvl -> Domain.clos -> Domain.t -> Domain.t 15 | val do_fst : Domain.t -> Domain.t 16 | val do_snd : Domain.lvl -> Domain.t -> Domain.t 17 | val do_j : Domain.lvl -> Domain.clos3 -> Domain.clos -> Domain.t -> Domain.t 18 | val do_ungel : Domain.lvl -> Domain.t list -> Domain.clos -> Domain.t -> Domain.clos -> Domain.t 19 | val do_uncodisc : Domain.t -> Domain.t 20 | val do_unglobe : Domain.t -> Domain.t 21 | val do_letdisc : Domain.lvl -> Mode.modality -> Domain.clos -> Domain.clos -> Domain.t -> Domain.t 22 | val do_letdiscbridge : Domain.lvl -> Mode.modality -> Domain.t list -> Domain.clos -> Domain.clos -> Domain.t -> Domain.t 23 | 24 | val do_pi_dom : Domain.t -> Domain.t 25 | val do_pi_cod : Domain.lvl -> Domain.t -> Domain.t -> Domain.t 26 | val do_sg_dom : Domain.t -> Domain.t 27 | val do_sg_cod : Domain.lvl -> Domain.t -> Domain.t -> Domain.t 28 | val do_list_tp : Domain.t -> Domain.t 29 | val do_coprod_left : Domain.t -> Domain.t 30 | val do_coprod_right : Domain.t -> Domain.t 31 | val do_id_left : Domain.t -> Domain.t 32 | val do_id_right : Domain.t -> Domain.t 33 | val do_id_tp : Domain.t -> Domain.t 34 | val do_bridge_cod : Domain.lvl -> Domain.t -> Domain.dim -> Domain.t 35 | val do_bridge_endpoint : Domain.lvl -> Domain.t -> Domain.ne -> int -> Domain.t 36 | val do_gel_rel : Domain.lvl -> Domain.t -> Domain.t list -> Domain.t 37 | val do_gel_bridge : Domain.lvl -> Domain.t -> Domain.t list -> Domain.t 38 | val do_codisc_tp : Domain.t -> Domain.t 39 | val do_global_tp : Domain.t -> Domain.t 40 | val do_disc_tp : Domain.t -> Domain.t 41 | 42 | val do_clos : Domain.lvl -> Domain.clos -> Domain.env_entry -> Domain.t 43 | val do_clos2 : Domain.lvl -> Domain.clos2 -> Domain.env_entry -> Domain.env_entry -> Domain.t 44 | val do_clos3 : Domain.lvl -> Domain.clos3 -> Domain.t -> Domain.t -> Domain.t -> Domain.t 45 | val do_closN : Domain.lvl -> Domain.closN -> Domain.t list -> Domain.t 46 | val do_clos_extent : Domain.lvl -> Domain.closN -> Domain.t list -> Domain.t -> Domain.dim -> Domain.t 47 | val do_consts : Domain.lvl -> Domain.clos -> int -> Domain.t list 48 | -------------------------------------------------------------------------------- /src/lib/grammar.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Concrete_syntax 3 | %} 4 | 5 | %token NUMERAL 6 | %token ATOM 7 | %token COLON SEMI PIPE AT DOT COMMA RIGHT_ARROW UNDERSCORE 8 | %token LPR RPR LANGLE RANGLE LBR RBR LCU RCU 9 | %token EQUALS 10 | %token TIMES FST SND 11 | %token LAM LET IN WITH OF DEF POSTULATE 12 | %token BRI ATSIGN EXTENT 13 | %token GEL ENGEL UNGEL 14 | %token GLOBAL ENGLOBE UNGLOBE 15 | %token CODISC ENCODISC UNCODISC 16 | %token DISC ENDISC UNDISC 17 | %token UNIT TRIV 18 | %token NAT ZERO SUC REC 19 | %token LIST NIL CONS LISTREC 20 | %token BOOL TRUE FALSE IF 21 | %token PLUS INL INR CASE 22 | %token VOID ABORT 23 | %token ID REFL MATCH 24 | %token UNIV 25 | %token QUIT NORMALIZE 26 | %token PAR PT 27 | %token CMP GLB DSC 28 | %token EOF 29 | 30 | %start sign 31 | %% 32 | 33 | name: 34 | | s = ATOM 35 | { s } 36 | | UNDERSCORE 37 | { "_" } 38 | 39 | mode: 40 | | { Mode.Parametric } 41 | | PAR { Mode.Parametric } 42 | | PT { Mode.Pointwise } 43 | 44 | decl: 45 | | LET; mode = mode; nm = name; COLON; tp = term; EQUALS; body = term 46 | { Def {mode; name = nm; def = body; tp} } 47 | | POSTULATE; mode = mode; nm = name; COLON; tp = term 48 | { Postulate {mode; name = nm; tp} } 49 | | QUIT { Quit } 50 | | NORMALIZE; DEF; a = name 51 | { NormalizeDef a } 52 | | NORMALIZE; mode = mode; tm = term; AT; tp = term { NormalizeTerm {mode; term = tm; tp} }; 53 | 54 | sign: 55 | | EOF { [] } 56 | | d = decl; s = sign { d :: s }; 57 | 58 | dim: 59 | | r = name { DVar r } 60 | | n = NUMERAL { Const n }; 61 | 62 | generating_modality: 63 | | CMP { Mode.Components } 64 | | GLB { Mode.Global } 65 | | DSC { Mode.Discrete } 66 | 67 | modality: 68 | | { Mode.Id } 69 | | gen = generating_modality { gen } 70 | | gen = generating_modality; DOT; m = modality { Mode.compose m gen } 71 | 72 | endpoints: 73 | | LCU; endpoints = separated_list(SEMI, term); RCU { endpoints }; 74 | 75 | term_option: 76 | | t = term { Some t } 77 | | TIMES { None }; 78 | 79 | endpoint_options: 80 | | LCU; endpoints = separated_list(SEMI, term_option); RCU { endpoints }; 81 | 82 | atomic: 83 | | LPR; t = term; RPR 84 | { t } 85 | | a = name 86 | { Var a } 87 | | UNIT 88 | { Unit } 89 | | TRIV 90 | { Triv } 91 | | ZERO 92 | { Lit 0 } 93 | | NIL 94 | { Nil } 95 | | TRUE 96 | { True } 97 | | FALSE 98 | { False } 99 | | n = NUMERAL 100 | { Lit n } 101 | | UNIV; LANGLE; i = NUMERAL; RANGLE 102 | { Uni i } 103 | | NAT { Nat } 104 | | BOOL { Bool } 105 | | VOID { Void } 106 | | LANGLE left = term; COMMA; right = term; RANGLE 107 | { Pair (left, right) } 108 | | LBR; name = name; RBR; body = term; endpoints = endpoint_options 109 | { Bridge(Binder {name; body}, endpoints) } 110 | | FST; t = atomic { Fst t } 111 | | SND; t = atomic { Snd t } 112 | 113 | spine: 114 | | t = atomic { Term t } 115 | | ATSIGN; b = dim { Dim b }; 116 | 117 | extent_cases: 118 | | name = name; RIGHT_ARROW; body = term; PIPE; ext = extent_cases 119 | { let (endcases, varcase) = ext in (Binder {name; body} :: endcases, varcase) } 120 | | name = name; names = nonempty_list(name); RIGHT_ARROW; varcase = term; 121 | { ([], BinderN {names = name :: names; body = varcase}) }; 122 | 123 | term: 124 | | f = atomic; args = list(spine) 125 | { Ap (f, args) } 126 | | LET; name = name; COLON; tp = term; EQUALS; def = term; IN; body = term 127 | { Let (Check {term = def; tp}, Binder {name; body}) } 128 | | LET; name = name; EQUALS; def = term; IN; body = term 129 | { Let (def, Binder {name; body}) } 130 | | LPR t = term; AT; tp = term RPR 131 | { Check {term = t; tp} } 132 | | SUC; t = atomic { Suc t } 133 | | REC; n = term; AT; mot_name = name; RIGHT_ARROW; mot = term; WITH; 134 | PIPE; ZERO; RIGHT_ARROW; zero_case = term; 135 | PIPE; SUC; suc_var = name; COMMA; ih_var = name; RIGHT_ARROW; suc_case = term 136 | { NRec { 137 | mot = Binder {name = mot_name; body = mot}; 138 | zero = zero_case; 139 | suc = Binder2 {name1 = suc_var; name2 = ih_var; body = suc_case}; 140 | nat = n 141 | } } 142 | | LIST; t = atomic { List t } 143 | | CONS; a = atomic; t = atomic { Cons (a, t) } 144 | | LISTREC; l = term; AT; mot_name = name; RIGHT_ARROW; mot = term; WITH; 145 | PIPE; NIL; RIGHT_ARROW; nil_case = term; 146 | PIPE; CONS; a_var = name; t_var = name; COMMA; ih_var = name; RIGHT_ARROW; cons_case = term 147 | { ListRec { 148 | mot = Binder {name = mot_name; body = mot}; 149 | nil = nil_case; 150 | cons = Binder3 {name1 = a_var; name2 = t_var; name3 = ih_var; body = cons_case}; 151 | list = l 152 | } } 153 | | IF; b = term; AT; mot_name = name; RIGHT_ARROW; mot = term; WITH; 154 | PIPE; TRUE; RIGHT_ARROW; true_case = term; 155 | PIPE; FALSE; RIGHT_ARROW; false_case = term; 156 | { If { 157 | mot = Binder {name = mot_name; body = mot}; 158 | tt = true_case; 159 | ff = false_case; 160 | bool = b 161 | } } 162 | | left = atomic; PLUS; right = atomic { Coprod(left, right) } 163 | | INL; t = atomic { Inl t } 164 | | INR; t = atomic { Inr t } 165 | | CASE; coprod = term; AT; mot_name = name; RIGHT_ARROW; mot = term; WITH; 166 | PIPE; INL; inl_name = name; RIGHT_ARROW; inl = term; 167 | PIPE; INR; inr_name = name; RIGHT_ARROW; inr = term 168 | { Case { 169 | mot = Binder {name = mot_name; body = mot}; 170 | inl = Binder {name = inl_name; body = inl}; 171 | inr = Binder {name = inr_name; body = inr}; 172 | coprod 173 | } } 174 | | ABORT; void = term; AT; name = name; RIGHT_ARROW; body = term 175 | { Abort {mot = Binder {name; body}; void} } 176 | | ID; tp = atomic; left = atomic; right = atomic 177 | { Id (tp, left, right) } 178 | | REFL; t = atomic 179 | { Refl t } 180 | | MATCH; eq = term; AT; name1 = name; name2 = name; name3 = name; RIGHT_ARROW; mot_term = term; WITH 181 | PIPE; REFL; name = name; RIGHT_ARROW; refl = term; 182 | { J {mot = Binder3 {name1; name2; name3; body = mot_term}; refl = Binder {name; body = refl}; eq} } 183 | | EXTENT; dim = dim; OF; ctx = term; 184 | IN; dom_dim = name; RIGHT_ARROW; dom = term; 185 | AT; mot_dim = name; mot_var = name; RIGHT_ARROW; mot = term; 186 | WITH; PIPE; 187 | cases = extent_cases 188 | { let (endcase, varcase) = cases in 189 | Extent 190 | {dim; 191 | dom = Binder {name = dom_dim; body = dom}; 192 | mot = Binder2 {name1 = mot_dim; name2 = mot_var; body = mot}; 193 | ctx; 194 | endcase; 195 | varcase} } 196 | | LAM; names = nonempty_list(name); RIGHT_ARROW; body = term 197 | { Lam (BinderN {names; body}) } 198 | | BRI; names = nonempty_list(name); RIGHT_ARROW; body = term 199 | { BLam (BinderN {names; body}) } 200 | | tele = nonempty_list(tele_cell); RIGHT_ARROW; cod = term 201 | { Pi (tele, cod) } 202 | | tele = nonempty_list(tele_cell); TIMES; cod = term 203 | { Sg (tele, cod) } 204 | | dom = atomic RIGHT_ARROW; cod = term 205 | { Pi ([Cell {m = Mode.Id; name = ""; ty = dom}], cod)} 206 | | LPR; m = modality; PIPE; dom = term; RPR; RIGHT_ARROW; cod = term 207 | { Pi ([Cell {m; name = ""; ty = dom}], cod)} 208 | | dom = atomic; TIMES; cod = term 209 | { Sg ([Cell {m = Mode.Id; name = ""; ty = dom}], cod)} 210 | | GEL; dim = dim; endpoints = endpoints; LPR; names = nonempty_list(name); RIGHT_ARROW; body = term; RPR 211 | { Gel (dim, endpoints, BinderN {names; body}) } 212 | | GEL; dim = dim; body = atomic 213 | { Gel (dim, [], BinderN {names = []; body}) } 214 | | ENGEL; name = name; endpoints = endpoints; t = atomic 215 | { Engel (name, endpoints, t) } 216 | | ENGEL; name = name; t = atomic 217 | { Engel (name, [], t) } 218 | | UNGEL; gel_name = name; COLON; width = NUMERAL; RIGHT_ARROW; gel_body = term; AT; 219 | mot_name = name; RIGHT_ARROW; mot_body = term; WITH 220 | PIPE; ENGEL; case_name = name; RIGHT_ARROW; case_body = term; 221 | { Ungel 222 | {width; 223 | mot = Binder {name = mot_name; body = mot_body}; 224 | gel = Binder {name = gel_name; body = gel_body}; 225 | case = Binder {name = case_name; body = case_body}} } 226 | | CODISC; t = atomic { Codisc t } 227 | | ENCODISC; t = atomic { Encodisc t } 228 | | UNCODISC; t = atomic { Uncodisc t } 229 | | GLOBAL; t = atomic { Global t } 230 | | ENGLOBE; t = atomic { Englobe t } 231 | | UNGLOBE; t = atomic { Unglobe t } 232 | | DISC; t = atomic { Disc t } 233 | | ENDISC; t = atomic { Endisc t } 234 | | UNDISC; LCU; modality = modality; RCU; disc = atomic; AT; mot_name = name; RIGHT_ARROW; mot_body = term; WITH; 235 | PIPE; ENDISC; case_name = name; RIGHT_ARROW; case_body = term 236 | { Letdisc 237 | {modality; 238 | mot = Binder {name = mot_name; body = mot_body}; 239 | case = Binder {name = case_name; body = case_body}; 240 | disc} } 241 | | UNDISC; LCU; modality = modality; RCU; disc_name = name; COLON; width = NUMERAL; RIGHT_ARROW; disc_body = term; 242 | AT; mot_name = name; RIGHT_ARROW; mot_body = term; WITH; 243 | PIPE; ENDISC; case_name = name; RIGHT_ARROW; case_body = term 244 | { Letdiscbridge 245 | {modality; 246 | width; 247 | mot = Binder {name = mot_name; body = mot_body}; 248 | case = Binder {name = case_name; body = case_body}; 249 | disc = Binder {name = disc_name; body = disc_body}} } 250 | 251 | tele_cell: 252 | | LPR; name = name; COLON; ty = term; RPR 253 | { Cell {m = Mode.Id; name; ty} } 254 | | LPR; m = modality; PIPE; name = name; COLON; ty = term; RPR 255 | { Cell {m; name; ty} } 256 | ; 257 | -------------------------------------------------------------------------------- /src/lib/lex.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | open Grammar 4 | 5 | exception SyntaxError of string 6 | 7 | let next_line lexbuf = 8 | let pos = lexbuf.lex_curr_p in 9 | lexbuf.lex_curr_p <- 10 | { pos with pos_bol = lexbuf.lex_curr_pos; 11 | pos_lnum = pos.pos_lnum + 1 12 | } 13 | 14 | let make_table num elems = 15 | let table = Hashtbl.create num in 16 | List.iter (fun (k, v) -> Hashtbl.add table k v) elems; 17 | table 18 | 19 | let keywords = 20 | make_table 0 [ 21 | ("unit", UNIT); 22 | ("triv", TRIV); 23 | ("nat", NAT); 24 | ("zero", ZERO); 25 | ("suc", SUC); 26 | ("list", LIST); 27 | ("nil", NIL); 28 | ("cons", CONS); 29 | ("listrec", LISTREC); 30 | ("bool", BOOL); 31 | ("tt", TRUE); 32 | ("ff", FALSE); 33 | ("inl", INL); 34 | ("inr", INR); 35 | ("case", CASE); 36 | ("void", VOID); 37 | ("abort", ABORT); 38 | ("let", LET); 39 | ("in", IN); 40 | ("with", WITH); 41 | ("if", IF); 42 | ("rec", REC); 43 | ("fst", FST); 44 | ("snd", SND); 45 | ("fun", LAM); 46 | ("bri", BRI); 47 | ("U", UNIV); 48 | ("match", MATCH); 49 | ("Id", ID); 50 | ("refl", REFL); 51 | ("extent", EXTENT); 52 | ("Gel", GEL); 53 | ("gel", ENGEL); 54 | ("ungel", UNGEL); 55 | ("Codisc", CODISC); 56 | ("codisc", ENCODISC); 57 | ("uncodisc", UNCODISC); 58 | ("Global", GLOBAL); 59 | ("glob", ENGLOBE); 60 | ("unglob", UNGLOBE); 61 | ("Disc", DISC); 62 | ("disc", ENDISC); 63 | ("undisc", UNDISC); 64 | ("at", AT); 65 | ("of", OF); 66 | ("def", DEF); 67 | ("postulate", POSTULATE); 68 | ("normalize", NORMALIZE); 69 | ("par", PAR); 70 | ("pt", PT); 71 | ("cmp", CMP); 72 | ("glb", GLB); 73 | ("dsc", DSC); 74 | ("quit", QUIT); 75 | ] 76 | } 77 | 78 | let number = ['0'-'9']['0'-'9']* 79 | let whitespace = [' ' '\t']+ 80 | let line_ending = '\r' | '\n' | "\r\n" 81 | let atom_first = ['a'-'z' 'A'-'Z' '_'] 82 | let atom_next = ['a'-'z' 'A'-'Z' '_' '-' '*' '/' '0'-'9' '\''] 83 | let atom = atom_first atom_next* 84 | 85 | rule token = parse 86 | | number 87 | { (NUMERAL (int_of_string (Lexing.lexeme lexbuf))) } 88 | | '(' 89 | { LPR } 90 | | ')' 91 | { RPR } 92 | | '|' 93 | { PIPE } 94 | | '.' 95 | { DOT } 96 | | ',' 97 | { COMMA } 98 | | '*' 99 | { TIMES } 100 | | "×" 101 | { TIMES } 102 | | "+" 103 | { PLUS } 104 | | ':' 105 | { COLON } 106 | | ';' 107 | { SEMI } 108 | | "=" 109 | { EQUALS } 110 | | "->" 111 | { RIGHT_ARROW } 112 | | "<" 113 | { LANGLE } 114 | | ">" 115 | { RANGLE } 116 | | "[" 117 | { LBR } 118 | | "]" 119 | { RBR } 120 | | "{" 121 | { LCU } 122 | | "}" 123 | { RCU } 124 | | "λ" 125 | { LAM } 126 | | '_' 127 | { UNDERSCORE } 128 | | '@' 129 | { ATSIGN } 130 | | "--" 131 | { comment lexbuf } 132 | | line_ending 133 | { new_line lexbuf; token lexbuf } 134 | | whitespace 135 | { token lexbuf } 136 | | eof 137 | { EOF } 138 | | atom 139 | { 140 | let input = lexeme lexbuf in 141 | begin try 142 | let kwd = Hashtbl.find keywords input in 143 | kwd 144 | with Not_found -> 145 | (Grammar.ATOM input) 146 | end 147 | } 148 | | _ 149 | { Printf.eprintf "Unexpected char: %s" (lexeme lexbuf); token lexbuf } 150 | and comment = parse 151 | | line_ending 152 | { new_line lexbuf; token lexbuf } 153 | | _ 154 | { comment lexbuf } 155 | -------------------------------------------------------------------------------- /src/lib/load.ml: -------------------------------------------------------------------------------- 1 | open Lex 2 | open Lexing 3 | 4 | exception Parse_error of string 5 | 6 | let print_position lexbuf = 7 | let pos = lexbuf.lex_curr_p in 8 | Printf.sprintf "%s:%d:%d" pos.pos_fname 9 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 10 | 11 | let parse_with_error lexbuf = 12 | try Grammar.sign Lex.token lexbuf with 13 | | SyntaxError msg -> 14 | let location = print_position lexbuf in 15 | let msg = Printf.sprintf "%s: %s\n" location msg in 16 | raise (Parse_error msg) 17 | | Grammar.Error -> 18 | let location = print_position lexbuf in 19 | let msg = Printf.sprintf "%s: syntax error.\n" location in 20 | raise (Parse_error msg) 21 | 22 | let load_file filename = 23 | let ch = open_in filename in 24 | let lexbuf = Lexing.from_channel ch in 25 | lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; 26 | let sign = parse_with_error lexbuf in 27 | close_in ch; sign 28 | -------------------------------------------------------------------------------- /src/lib/load.mli: -------------------------------------------------------------------------------- 1 | exception Parse_error of string 2 | 3 | (* Load and parse a file *) 4 | val load_file : string -> Concrete_syntax.signature 5 | -------------------------------------------------------------------------------- /src/lib/mode.ml: -------------------------------------------------------------------------------- 1 | type mode = 2 | | Pointwise 3 | | Parametric 4 | [@@deriving eq] 5 | 6 | type modality = 7 | | Id 8 | | Components 9 | | Discrete 10 | | Global 11 | | DiscreteComponents 12 | | DiscreteGlobal 13 | [@@deriving eq] 14 | 15 | exception Mode_mismatch of string 16 | 17 | let show_mode = function 18 | | Pointwise -> "pt" 19 | | Parametric -> "par" 20 | 21 | let pp_mode fmt mode = Format.pp_print_string fmt (show_mode mode) 22 | 23 | let show_modality = function 24 | | Id -> "." 25 | | Components -> ".components" 26 | | Discrete -> ".discrete" 27 | | Global -> ".global" 28 | | DiscreteComponents -> ".components.discrete" 29 | | DiscreteGlobal -> ".global.discrete" 30 | 31 | let pp_modality fmt m = Format.pp_print_string fmt (show_modality m) 32 | 33 | let assert_mode m1 m2 = 34 | if m1 = m2 then () else raise (Mode_mismatch (show_mode m1 ^ " ≠ " ^ show_mode m2)) 35 | 36 | let src m = function 37 | | Id -> m 38 | | Components -> assert_mode m Pointwise; Parametric 39 | | Discrete -> assert_mode m Parametric; Pointwise 40 | | Global -> assert_mode m Pointwise; Parametric 41 | | DiscreteComponents -> assert_mode m Parametric; Parametric 42 | | DiscreteGlobal -> assert_mode m Parametric; Parametric 43 | 44 | let dst m = function 45 | | Id -> m 46 | | Components -> assert_mode m Parametric; Pointwise 47 | | Discrete -> assert_mode m Pointwise; Parametric 48 | | Global -> assert_mode m Parametric; Pointwise 49 | | DiscreteComponents -> assert_mode m Parametric; Parametric 50 | | DiscreteGlobal -> assert_mode m Parametric; Parametric 51 | 52 | let compose m1 m2 = 53 | match m1, m2 with 54 | | Id, _ -> m2 55 | | _, Id -> m1 56 | | Components, Discrete -> Id 57 | | Components, DiscreteComponents -> Components 58 | | Components, DiscreteGlobal -> Global 59 | | Discrete, Components -> DiscreteComponents 60 | | Discrete, Global -> DiscreteGlobal 61 | | Global, Discrete -> Id 62 | | Global, DiscreteComponents -> Components 63 | | Global, DiscreteGlobal -> Global 64 | | DiscreteComponents, Discrete -> Discrete 65 | | DiscreteComponents, DiscreteComponents -> DiscreteComponents 66 | | DiscreteComponents, DiscreteGlobal -> DiscreteGlobal 67 | | DiscreteGlobal, Discrete -> Discrete 68 | | DiscreteGlobal, DiscreteComponents -> DiscreteComponents 69 | | DiscreteGlobal, DiscreteGlobal -> DiscreteGlobal 70 | | _ -> raise (Mode_mismatch ("cannot compose " ^ show_modality m1 ^ " with " ^ show_modality m2)) 71 | 72 | let leq m1 m2 = 73 | match m1, m2 with 74 | | Id, Id -> true 75 | | Id, DiscreteComponents -> true 76 | | Id, DiscreteGlobal -> false 77 | | Components, Components -> true 78 | | Components, Global -> false 79 | | Discrete, Discrete -> true 80 | | Global, Components -> true 81 | | Global, Global -> true 82 | | DiscreteComponents, Id -> false 83 | | DiscreteComponents, DiscreteComponents -> true 84 | | DiscreteComponents, DiscreteGlobal -> false 85 | | DiscreteGlobal, Id -> true 86 | | DiscreteGlobal, DiscreteComponents -> true 87 | | DiscreteGlobal, DiscreteGlobal -> true 88 | | _ -> raise (Mode_mismatch ("cannot compare " ^ show_modality m1 ^ " with " ^ show_modality m2)) 89 | -------------------------------------------------------------------------------- /src/lib/mode.mli: -------------------------------------------------------------------------------- 1 | type mode = 2 | | Pointwise 3 | | Parametric 4 | 5 | type modality = 6 | | Id 7 | | Components 8 | | Discrete 9 | | Global 10 | | DiscreteComponents 11 | | DiscreteGlobal 12 | 13 | exception Mode_mismatch of string 14 | 15 | val equal_mode : mode -> mode -> bool 16 | val equal_modality : modality -> modality -> bool 17 | 18 | val pp_mode : Format.formatter -> mode -> unit 19 | val pp_modality : Format.formatter -> modality -> unit 20 | 21 | val show_mode : mode -> string 22 | val show_modality : modality -> string 23 | 24 | val src : mode -> modality -> mode 25 | val dst : mode -> modality -> mode 26 | val compose : modality -> modality -> modality 27 | val leq : modality -> modality -> bool 28 | -------------------------------------------------------------------------------- /src/lib/option.ml: -------------------------------------------------------------------------------- 1 | let some a = Some a 2 | 3 | let map f = 4 | function 5 | | Some a -> Some (f a) 6 | | None -> None 7 | 8 | let fold d f = 9 | function 10 | | Some a -> f a 11 | | None -> d 12 | -------------------------------------------------------------------------------- /src/lib/option.mli: -------------------------------------------------------------------------------- 1 | val some : 'a -> 'a option 2 | val map : ('a -> 'b) -> 'a option -> 'b option 3 | val fold : 'b -> ('a -> 'b) -> 'a option -> 'b 4 | -------------------------------------------------------------------------------- /src/lib/quote.mli: -------------------------------------------------------------------------------- 1 | exception Quote_failed of string 2 | 3 | type env_entry = 4 | | DVar of int 5 | | Var of {level : Domain.lvl; tp : Domain.t} 6 | | Def of Domain.t 7 | | TopLevel of Domain.t 8 | | Postulate of {level : Domain.lvl; tp : Domain.t} 9 | type env = env_entry list 10 | 11 | val mk_bvar : env -> Domain.lvl -> Domain.dim * env 12 | val mk_var : Domain.t -> env -> Domain.lvl -> Domain.t * env 13 | 14 | val env_to_sem_env : env -> Domain.env 15 | 16 | val reduce_extent : env -> Domain.lvl -> Domain.extent_head * Domain.spine -> Domain.t option 17 | 18 | (* Quotation *) 19 | val read_back_level : env -> Domain.lvl -> Domain.lvl 20 | val read_back_nf : env -> Domain.lvl -> Domain.nf -> Syntax.t 21 | val read_back_tp : env -> Domain.lvl -> Domain.t -> Syntax.t 22 | 23 | val check_nf : env -> Domain.lvl -> Domain.nf -> Domain.nf -> bool 24 | val check_tp : subtype:bool -> env -> Domain.lvl -> Domain.t -> Domain.t -> bool 25 | 26 | -------------------------------------------------------------------------------- /src/lib/syntax.ml: -------------------------------------------------------------------------------- 1 | type idx = int 2 | [@@deriving show{ with_path = false }, eq] 3 | 4 | type uni_level = int 5 | [@@deriving show{ with_path = false }, eq] 6 | 7 | type dim = 8 | | DVar of idx 9 | | Const of int 10 | [@@deriving eq] 11 | 12 | type t = 13 | | Var of idx (* DeBruijn indices for variables *) 14 | | Let of t * (* BINDS *) t | Check of t * t 15 | | Unit | Triv 16 | | Nat | Zero | Suc of t | NRec of (* BINDS *) t * t * (* BINDS 2 *) t * t 17 | | List of t | Nil | Cons of t * t | ListRec of (* BINDS *) t * t * (* BINDS 3 *) t * t 18 | | Bool | True | False | If of (* BINDS *) t * t * t * t 19 | | Coprod of t * t | Inl of t | Inr of t | Case of (* BINDS *) t * (* BINDS *) t * (* BINDS *) t * t 20 | | Void | Abort of (* BINDS *) t * t 21 | | Pi of Mode.modality * t * (* BINDS *) t | Lam of (* BINDS *) t | Ap of t * t 22 | | Sg of t * (* BINDS *) t | Pair of t * t | Fst of t | Snd of t 23 | | Id of t * t * t | Refl of t | J of (* BINDS 3 *) t * (* BINDS *) t * t 24 | | Bridge of (* BBINDS *) t * t option list | BApp of t * dim | BLam of (* BBINDS *) t 25 | | Extent of dim * (* BBINDS *) t * (* BBINDS & BINDS *) t * t * (* BINDS *) t list * (* BINDS n & BBINDS *) t 26 | | Gel of dim * t list * (* BINDS n *) t | Engel of idx * t list * t 27 | | Ungel of int * (* BINDS *) t * (* BBINDS *) t * (* BINDS *) t 28 | | Codisc of t | Encodisc of t | Uncodisc of t 29 | | Global of t | Englobe of t | Unglobe of t 30 | | Disc of t | Endisc of t | Letdisc of Mode.modality * (* BINDS *) t * (* BINDS *) t * t 31 | | Letdiscbridge of Mode.modality * int * (* BINDS *) t * (* BINDS *) t * (* BBINDS *) t 32 | | Uni of uni_level 33 | [@@deriving eq] 34 | 35 | exception Indirect_use 36 | 37 | let unsubst_bvar i t = 38 | let go_dvar depth j = 39 | if j < depth then j 40 | else if j = i + depth then depth 41 | else j + 1 42 | in 43 | let go_dim depth = function 44 | | DVar j -> DVar (go_dvar depth j) 45 | | Const o -> Const o 46 | in 47 | let rec go depth = function 48 | | Var j -> 49 | if j < depth then Var j 50 | else if j < i + depth then raise Indirect_use 51 | else Var (j + 1) 52 | | Let (def, body) -> Let (go depth def, go (depth + 1) body) 53 | | Check (term, tp) -> Check (go depth term, go depth tp) 54 | | Unit -> Unit 55 | | Triv -> Triv 56 | | Nat -> Nat 57 | | Zero -> Zero 58 | | Suc t -> Suc (go depth t) 59 | | NRec (mot, zero, suc, n) -> 60 | NRec (go (depth + 1) mot, go depth zero, go (depth + 2) suc, go depth n) 61 | | List t -> List (go depth t) 62 | | Nil -> Nil 63 | | Cons (a, t) -> Cons (go depth a, go depth t) 64 | | ListRec (mot, nil, cons, l) -> 65 | ListRec (go (depth + 1) mot, go depth nil, go (depth + 3) cons, go depth l) 66 | | Bool -> Bool 67 | | True -> True 68 | | False -> False 69 | | If (mot, tt, ff, b) -> 70 | If (go (depth + 1) mot, go depth tt, go depth ff, go depth b) 71 | | Coprod (t1, t2) -> Coprod (go depth t1, go depth t2) 72 | | Inl t -> Inl (go depth t) 73 | | Inr t -> Inr (go depth t) 74 | | Case (mot, inl, inr, co) -> 75 | Case (go (depth + 1) mot, go (depth + 1) inl, go (depth + 1) inr, go depth co) 76 | | Void -> Void 77 | | Abort (mot, vd) -> Abort (go (depth + 1) mot, go depth vd) 78 | | Pi (m, l, r) -> Pi (m, go depth l, go (depth + 1) r) 79 | | Lam body -> Lam (go (depth + 1) body) 80 | | Ap (l, r) -> Ap (go depth l, go depth r) 81 | | Sg (l, r) -> Sg (go depth l, go (depth + 1) r) 82 | | Fst body -> Fst (go depth body) 83 | | Snd body -> Snd (go depth body) 84 | | Pair (l, r) -> Pair (go depth l, go depth r) 85 | | Id (tp, l, r) -> Id (go depth tp, go depth l, go depth r) 86 | | Refl t -> Refl (go depth t) 87 | | J (mot, refl, eq) -> 88 | J (go (depth + 3) mot, go (depth + 1) refl, go depth eq) 89 | | Bridge (t, ts) -> Bridge (go (depth + 1) t, List.map (Option.map (go depth)) ts) 90 | | BLam t -> BLam (go (depth + 1) t) 91 | | BApp (t, r) -> BApp (go depth t, go_dim depth r) 92 | | Extent (r, dom, mot, ctx, endcase, varcase) -> 93 | Extent 94 | (go_dim depth r, 95 | go (depth + 1) dom, 96 | go (depth + 2) mot, 97 | go depth ctx, 98 | List.map (go (depth + 1)) endcase, 99 | go (depth + List.length endcase + 2) varcase) 100 | | Gel (r, ts, t) -> Gel (go_dim depth r, List.map (go depth) ts, go (depth + List.length ts) t) 101 | | Engel (i, ts, t) -> Engel (go_dvar depth i, List.map (go depth) ts, go depth t) 102 | | Ungel (width, mot, gel, case) -> 103 | Ungel (width, go (depth + 1) mot, go (depth + 1) gel, go (depth + 1) case) 104 | | Global t -> Global (go depth t) 105 | | Englobe t -> Englobe (go depth t) 106 | | Unglobe t -> Unglobe (go depth t) 107 | | Codisc t -> Codisc (go depth t) 108 | | Encodisc t -> Encodisc (go depth t) 109 | | Uncodisc t -> Uncodisc (go depth t) 110 | | Disc t -> Disc (go depth t) 111 | | Endisc t -> Endisc (go depth t) 112 | | Letdisc (m, mot, case, d) -> Letdisc (m, go (depth + 1) mot, go (depth + 1) case, go depth d) 113 | | Letdiscbridge (m, width, mot, case, d) -> Letdiscbridge (m, width, go (depth + 1) mot, go (depth + 1) case, go (depth + 1) d) 114 | | Uni j -> Uni j 115 | in 116 | try 117 | Some (go 0 t) 118 | with 119 | Indirect_use -> None 120 | 121 | let rec condense = function 122 | | Zero -> Some 0 123 | | Suc t -> 124 | begin 125 | match condense t with 126 | | Some n -> Some (n + 1) 127 | | None -> None 128 | end 129 | | _ -> None 130 | 131 | let pp_dim fmt = 132 | let open Format in 133 | function 134 | | DVar i -> fprintf fmt "#%d" i 135 | | Const o -> fprintf fmt "%d" o 136 | 137 | let pp_option pp fmt = 138 | function 139 | | None -> Format.fprintf fmt "*" 140 | | Some a -> pp fmt a 141 | 142 | let pp_list pp fmt = 143 | Format.fprintf fmt "[%a]" (Format.pp_print_list ~pp_sep:(fun fmt _ -> Format.fprintf fmt "; ") pp) 144 | 145 | let rec pp fmt = 146 | let open Format in 147 | function 148 | | Var i -> fprintf fmt "#%d" i 149 | | Let (def, body) -> 150 | fprintf fmt "let@,@[%a@]@,in@,@[ 152 | fprintf fmt "(@[%a@]@ :@,@[%a@])" pp term pp tp 153 | | Unit -> fprintf fmt "unit" 154 | | Triv -> fprintf fmt "triv" 155 | | Nat -> fprintf fmt "nat" 156 | | Zero -> fprintf fmt "0" 157 | | Suc t -> 158 | begin 159 | match condense t with 160 | | Some n -> 161 | fprintf fmt "%d" (n + 1) 162 | | None -> 163 | fprintf fmt "suc(@[%a@])" pp t 164 | end 165 | | NRec (mot, zero, suc, n) -> 166 | fprintf fmt "rec(@[@[%a@],@ @[%a@],@ @[%a@],@ @[%a@]@])" 167 | pp mot pp zero pp suc pp n; 168 | | List t -> fprintf fmt "list(@[%a@])" pp t 169 | | Nil -> fprintf fmt "nil" 170 | | Cons (a, t) -> fprintf fmt "cons(@[@[%a@],@ @[%a@]@])" pp a pp t 171 | | ListRec (mot, nil, cons, l) -> 172 | fprintf fmt "listrec(@[@[%a@],@ @[%a@],@ @[%a@],@ @[%a@]@])" 173 | pp mot pp nil pp cons pp l; 174 | | Bool -> fprintf fmt "bool" 175 | | True -> fprintf fmt "true" 176 | | False -> fprintf fmt "false" 177 | | If (mot, tt, ff, b) -> 178 | fprintf fmt "if(@[@[%a@],@ @[%a@],@ @[%a@],@ @[%a@]@])" 179 | pp mot pp tt pp ff pp b; 180 | | Coprod (t1, t2) -> fprintf fmt "coprod(@[@[%a@],@ @[%a@]@])" pp t1 pp t2 181 | | Inl t -> fprintf fmt "inl(@[%a@])" pp t 182 | | Inr t -> fprintf fmt "inr(@[%a@])" pp t 183 | | Case (mot, inl, inr, co) -> 184 | fprintf fmt "case(@[@[%a@],@ @[%a@],@ @[%a@],@ @[%a@]@])" 185 | pp mot pp inl pp inr pp co; 186 | | Void -> fprintf fmt "void" 187 | | Abort (mot, vd) -> 188 | fprintf fmt "abort(@[@[%a@],@ @[%a@]@])" pp mot pp vd; 189 | | Pi (m, l, r) -> 190 | fprintf fmt "Pi(@[@[%a@],@ @[%a@],@ @[%a@]@])" Mode.pp_modality m pp l pp r; 191 | | Lam body -> 192 | fprintf fmt "lam(@[%a@])" pp body 193 | | Ap (l, r) -> 194 | fprintf fmt "app(@[@[%a@],@ @[%a@]@])" pp l pp r 195 | | Sg (l, r) -> 196 | fprintf fmt "Sg(@[@[%a@],@ @[%a@]@])" pp l pp r 197 | | Fst body -> 198 | fprintf fmt "fst(@[%a@])" pp body 199 | | Snd body -> 200 | fprintf fmt "snd(@[%a@])" pp body 201 | | Pair (l, r) -> 202 | fprintf fmt "pair(@[@[%a@],@ @[%a@]@])" pp l pp r 203 | | Id (tp, l, r) -> 204 | fprintf fmt "Id(@[@[%a@],@ @[%a@],@ @[%a@]@])" pp tp pp l pp r; 205 | | Refl t -> 206 | fprintf fmt "refl(@[%a@])" pp t 207 | | J (mot, refl, eq) -> 208 | fprintf fmt "J(@[@[%a@],@ @[%a@],@ @[%a@]@])" pp mot pp refl pp eq; 209 | | Bridge (t, ts) -> 210 | fprintf fmt "Bridge(@[@[%a@],@ @[%a@]@])" 211 | pp t (pp_list (pp_option pp)) ts; 212 | | BLam t -> 213 | fprintf fmt "blam(@[%a@])" pp t; 214 | | BApp (t, r) -> 215 | fprintf fmt "bapp(@[@[%a@],@ @[%a@]@])" pp t pp_dim r; 216 | | Extent (r, dom, mot, ctx, endcase, varcase) -> 217 | fprintf fmt "extent(@[@[%a@],@ @[%a@],@ @[%a@],@ @[%a@],@ @[%a@],@ @[%a@]@])" 218 | pp_dim r pp dom pp mot pp ctx (pp_list pp) endcase pp varcase; 219 | | Gel (r, ts, t) -> 220 | fprintf fmt "Gel(@[@[%a@],@ @[%a@],@ @[%a@]@])" pp_dim r (pp_list pp) ts pp t; 221 | | Engel (i, ts, t) -> 222 | fprintf fmt "gel(@[@[%a@],@ @[%a@],@ @[%a@]@])" pp_dim (DVar i) (pp_list pp) ts pp t; 223 | | Ungel (width, mot, gel, case) -> 224 | fprintf fmt "ungel(@[@[%d@],@ @[%a@],@ @[%a@],@ @[%a@]@])" width pp mot pp gel pp case 225 | | Global t -> 226 | fprintf fmt "Global(@[%a@])" pp t 227 | | Englobe t -> 228 | fprintf fmt "englobe(@[%a@])" pp t 229 | | Unglobe t -> 230 | fprintf fmt "unglobe(@[%a@])" pp t 231 | | Codisc t -> 232 | fprintf fmt "Codisc(@[%a@])" pp t 233 | | Encodisc t -> 234 | fprintf fmt "encodisc(@[%a@])" pp t 235 | | Uncodisc t -> 236 | fprintf fmt "uncodisc(@[%a@])" pp t 237 | | Disc t -> 238 | fprintf fmt "Disc(@[%a@])" pp t 239 | | Endisc t -> 240 | fprintf fmt "endisc(@[%a@])" pp t 241 | | Letdisc (m, mot, case, d) -> 242 | fprintf fmt "letdisc(@[@[%a@],@ @[%a@],@ @[%a@],@ @[%a@]@])" 243 | Mode.pp_modality m pp mot pp case pp d 244 | | Letdiscbridge (m, width, mot, case, d) -> 245 | fprintf fmt "letdisc(@[@[%a@],@ @[%d@],@ @[%a@],@ @[%a@],@ @[%a@]@])" 246 | Mode.pp_modality m width pp mot pp case pp d 247 | | Uni i -> fprintf fmt "U<%d>" i 248 | 249 | let show t = 250 | let b = Buffer.create 100 in 251 | let fmt = Format.formatter_of_buffer b in 252 | pp fmt t; 253 | Format.pp_print_flush fmt (); 254 | Buffer.contents b 255 | -------------------------------------------------------------------------------- /src/lib/syntax.mli: -------------------------------------------------------------------------------- 1 | type idx = int 2 | type uni_level = int 3 | 4 | type dim = 5 | | DVar of idx (* DeBruijn indices for variables *) 6 | | Const of int 7 | 8 | type t = 9 | | Var of idx (* DeBruijn indices for variables *) 10 | | Let of t * (* BINDS *) t | Check of t * t 11 | | Unit | Triv 12 | | Nat | Zero | Suc of t | NRec of (* BINDS *) t * t * (* BINDS 2 *) t * t 13 | | List of t | Nil | Cons of t * t | ListRec of (* BINDS *) t * t * (* BINDS 3 *) t * t 14 | | Bool | True | False | If of (* BINDS *) t * t * t * t 15 | | Coprod of t * t | Inl of t | Inr of t | Case of (* BINDS *) t * (* BINDS *) t * (* BINDS *) t * t 16 | | Void | Abort of (* BINDS *) t * t 17 | | Pi of Mode.modality * t * (* BINDS *) t | Lam of (* BINDS *) t | Ap of t * t 18 | | Sg of t * (* BINDS *) t | Pair of t * t | Fst of t | Snd of t 19 | | Id of t * t * t | Refl of t | J of (* BINDS 3 *) t * (* BINDS *) t * t 20 | | Bridge of (* BBINDS *) t * t option list | BApp of t * dim | BLam of (* BBINDS *) t 21 | | Extent of dim * (* BBINDS *) t * (* BBINDS & BINDS *) t * t * (* BINDS *) t list * (* BINDS & BBINDS *) t 22 | | Gel of dim * t list * (* BINDS n *) t | Engel of idx * t list * t 23 | | Ungel of int * (* BINDS *) t * (* BBINDS *) t * (* BINDS *) t 24 | | Codisc of t | Encodisc of t | Uncodisc of t 25 | | Global of t | Englobe of t | Unglobe of t 26 | | Disc of t | Endisc of t | Letdisc of Mode.modality * (* BINDS *) t * (* BINDS *) t * t 27 | | Letdiscbridge of Mode.modality * int * (* BINDS *) t * (* BINDS *) t * (* BBINDS *) t 28 | | Uni of uni_level 29 | 30 | val equal_uni_level : uni_level -> uni_level -> bool 31 | val equal_idx : idx -> idx -> bool 32 | val equal : t -> t -> bool 33 | 34 | val unsubst_bvar : idx -> t -> t option 35 | 36 | val pp_uni_level : Format.formatter -> uni_level -> unit 37 | val show_uni_level : uni_level -> string 38 | 39 | val pp_idx : Format.formatter -> idx -> unit 40 | val pp_dim : Format.formatter -> dim -> unit 41 | 42 | val pp : Format.formatter -> t -> unit 43 | val show : t -> string 44 | 45 | -------------------------------------------------------------------------------- /test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | for file in test/*.ptt; do 4 | echo "Checking ${file}" 5 | dune exec ptt -- $file 6 | echo $'' # print newline ??? 7 | done 8 | 9 | echo DONE 10 | -------------------------------------------------------------------------------- /test/basic.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Very basic tests 3 | -------------------------------------------------------------------------------- 4 | 5 | let fun_id : (A : U<0>) (B : A -> U<0>) -> ((x : A) -> B x) -> ((x : A) -> B x) = 6 | fun A B f -> f 7 | 8 | normalize def fun_id 9 | 10 | let swap : (A : [_] [_] U<0> {*; *} {*; *}) 11 | -> (sq : [x] [y] A @ x @ y {*; *} {*; *}) 12 | -> ([x] [y] A @ y @ x {sq @ 0 @ x; sq @ 1 @ x} {bri y -> sq @ y @ 0; bri y -> sq @ y @ 1}) 13 | = 14 | fun A sq -> bri x y -> sq @ y @ x 15 | 16 | normalize def swap 17 | 18 | -- Should not check 19 | -- let diagonal : (A : U<0>) (p : [x] [y] A {*; *} {*; *}) -> ([x] A {p @ 0 @ 0; p @ 1 @ 1}) = 20 | -- fun A p -> bri x -> p @ x @ x 21 | -------------------------------------------------------------------------------- /test/binary_to_quarternary.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- A "proof by example" that iterated binary parametricity can be used to 3 | -- simulate quarternary parametricity. By iterating this construction we can 4 | -- expect to recover n-ary parametricity for all n. However, it isn't clear to 5 | -- me whether we can get binary from unary parametricity. 6 | -------------------------------------------------------------------------------- 7 | 8 | let quarternary_Gel : 9 | (A : U<0>) (B : U<0>) (C : U<0>) (D : U<0>) 10 | (R : A -> B -> C -> D -> U<0>) 11 | -> [x] [y] U<0> {Gel x {A;B} (_ _ -> unit); Gel x {C;D} (_ _ -> unit)} 12 | {bri y -> Gel y {A;C} (_ _ -> unit); bri y -> Gel y {B;D} (_ _ -> unit)} 13 | = 14 | fun A B C D R -> 15 | bri x y -> 16 | Gel x 17 | { Gel y {A;C} (_ _ -> unit) 18 | ; Gel y {B;D} (_ _ -> unit) 19 | } 20 | (ac bd -> 21 | extent y of in 22 | z -> (Gel z {A;C} (_ _ -> unit)) * (Gel z {B;D} (_ _ -> unit)) at 23 | _ _ -> U<0> with 24 | | _ -> unit 25 | | _ -> unit 26 | | ab cd _ z -> 27 | Gel z {unit; unit} (_ _ -> R (fst ab) (snd ab) (fst cd) (snd cd))) 28 | 29 | let quarternary_engel : 30 | (A : U<0>) (B : U<0>) (C : U<0>) (D : U<0>) 31 | (R : A -> B -> C -> D -> U<0>) 32 | (a : A) (b : B) (c : C) (d : D) 33 | -> (R a b c d) 34 | -> [x] [y] quarternary_Gel A B C D R @ x @ y {gel x {a;b} triv; gel x {c;d} triv} 35 | {bri y -> gel y {a;c} triv; bri y -> gel y {b;d} triv} 36 | = 37 | fun A B C D R a b c d r -> bri x y -> 38 | gel x {gel y {a;c} triv; gel y {b;d} triv} (gel y {triv;triv} r) 39 | 40 | let quarternary_gelproj : 41 | (A : U<0>) (B : U<0>) (C : U<0>) (D : U<0>) 42 | (R : A -> B -> C -> D -> U<0>) 43 | (a : A) (b : B) (c : C) (d : D) 44 | (ab : [x] Gel x {A;B} (_ _ -> unit) {a;b}) (cd : [x] Gel x {C;D} (_ _ -> unit) {c;d}) 45 | (ac : [y] Gel y {A;C} (_ _ -> unit) {a;c}) (bd : [y] Gel y {B;D} (_ _ -> unit) {b;d}) 46 | -> [x] [y] quarternary_Gel A B C D R @ x @ y {ab @ x; cd @ x} {ac; bd} 47 | -> R a b c d 48 | = 49 | fun A B C D R a b c d ab cd ac bd g -> 50 | ungel y : 2 -> 51 | (ungel x : 2 -> g @ x @ y at _ -> Gel y {unit; unit} (_ _ -> R a b c d) with 52 | | gel g' -> g') 53 | at 54 | _ -> R a b c d with 55 | | gel r -> r 56 | 57 | let quarternary_example : (F : (X : U<0>) -> X -> X) 58 | (A : U<0>) (B : U<0>) (C : U<0>) (D : U<0>) 59 | (R : A -> B -> C -> D -> U<0>) 60 | (a : A) (b : B) (c : C) (d : D) 61 | -> (R a b c d) -> R (F A a) (F B b) (F C c) (F D d) 62 | = 63 | fun F A B C D R a b c d r -> 64 | quarternary_gelproj A B C D R (F A a) (F B b) (F C c) (F D d) 65 | (bri x -> F (Gel x {A;B} (_ _ -> unit)) (gel x {a;b} triv)) 66 | (bri x -> F (Gel x {C;D} (_ _ -> unit)) (gel x {c;d} triv)) 67 | (bri y -> F (Gel y {A;C} (_ _ -> unit)) (gel y {a;c} triv)) 68 | (bri y -> F (Gel y {B;D} (_ _ -> unit)) (gel y {b;d} triv)) 69 | (bri x y -> 70 | F (quarternary_Gel A B C D R @ x @ y) 71 | (quarternary_engel A B C D R a b c d r @ x @ y)) 72 | -------------------------------------------------------------------------------- /test/church_naturals.ptt: -------------------------------------------------------------------------------- 1 | let cong : (A : U<0>) (B : U<0>) (f : A -> B) (a0 : A) (a1 : A) 2 | -> (Id A a0 a1) -> Id B (f a0) (f a1) 3 | = 4 | fun A B f a0 a1 eq -> 5 | match eq at x0 x1 _ -> Id B (f x0) (f x1) with 6 | | refl z -> refl (f z) 7 | 8 | let gelproj : (A : U<0>) (B : U<0>) (R : A -> B -> U<0>) 9 | (a : A) (b : B) -> [x] Gel x {A; B} (a b -> R a b) {a; b} -> R a b 10 | = 11 | fun A B R a b p -> 12 | ungel x : 2 -> p @ x at _ -> R a b with | gel r -> r 13 | 14 | normalize def gelproj 15 | 16 | let iter : (A : U<0>) (f : A -> A) -> nat -> A -> A = 17 | fun A f n a -> 18 | rec n at _ -> A with 19 | | zero -> a 20 | | suc _, b -> f b 21 | 22 | normalize def iter 23 | 24 | let church_param : (F : (A : U<0>) -> (A -> A) -> (A -> A)) 25 | -> (A : U<0>) (f : A -> A) (a : A) 26 | -> Id A (F A f a) (iter A f (F nat (fun n -> suc n) zero) a) 27 | = 28 | fun F A f a -> 29 | let R : A -> nat -> U<0> = fun b n -> Id A b (iter A f n a) in 30 | let G : [x] U<0> {A; nat} = bri x -> Gel x {A; nat} (a b -> R a b) in 31 | gelproj A nat (fun b n -> R b n) (F A f a) (F nat (fun n -> suc n) zero) 32 | (bri x -> 33 | let fx : (G @ x) -> G @ x = 34 | fun g -> 35 | extent x of g in y -> G @ y at y _ -> G @ y with 36 | | b -> f b 37 | | n -> suc n 38 | | b n q y -> 39 | gel y {f b; suc n} 40 | (cong A A f b (iter A f n a) 41 | (gelproj A nat (fun b n -> R b n) b n q)) 42 | in 43 | F (G @ x) fx (gel x {a; zero} (refl a))) 44 | 45 | normalize def church_param 46 | 47 | normalize church_param (fun A f -> f) at 48 | (A : U<0>) (f : A -> A) (a : A) -> Id A (f a) (f a) 49 | 50 | normalize church_param (fun A f a -> (f (f a))) at 51 | (A : U<0>) (f : A -> A) (a : A) -> Id A (f (f a)) (f (f a)) -------------------------------------------------------------------------------- /test/codisc.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Codiscrete modality tests 3 | -------------------------------------------------------------------------------- 4 | 5 | let par modal_id : Codisc ((A : U<0>) -> A -> A) = 6 | codisc (fun A a -> a) 7 | 8 | let pt modal_id : (A : U<0>) -> A -> A = 9 | fun A a -> a 10 | 11 | let pt _ : (Global U<0>) -> U<0> = 12 | fun A -> Global (unglob A) 13 | 14 | let par _ : (Codisc U<0>) -> U<0> = 15 | fun A -> Codisc (uncodisc A) 16 | 17 | let pt into : (A : U<0>) -> A -> Global (Codisc A) = 18 | fun A a -> glob (codisc a) 19 | 20 | let pt out : (A : U<0>) -> (Global (Codisc A)) -> A = 21 | fun A p -> uncodisc (unglob p) 22 | 23 | let pt into_out : (A : U<0>) (p : Global (Codisc A)) 24 | -> Id (Global (Codisc A)) (into A (out A p)) p 25 | = 26 | fun A p -> refl p 27 | 28 | let pt out_into : (A : U<0>) (a : A) 29 | -> Id A (out A (into A a)) a 30 | = 31 | fun A a -> refl a 32 | 33 | let par into2 : (A : U<0>) -> A -> Codisc (Global A) = 34 | fun A a -> codisc (glob a) 35 | 36 | -- Should not check 37 | -- let par out2 : (A : U<0>) -> (Codisc (Global A)) -> A = 38 | -- fun A a -> unglob (uncodisc a) 39 | 40 | -------------------------------------------------------------------------------- 41 | -- Polymorphic endofunction 42 | -------------------------------------------------------------------------------- 43 | 44 | let pt readOff : (dsc | ((A : U<0>) -> A -> A)) -> (A : U<0>) -> A -> A = 45 | fun F A a -> uncodisc (F (Codisc A) (codisc a)) 46 | 47 | normalize pt readOff (fun A a -> a) at (A : U<0>) -> A -> A 48 | 49 | let gelproj : (A : U<0>) (P : A -> U<0>) (a : A) -> [x] Gel x {A} (a -> P a) {a} -> P a = 50 | fun A P a p -> 51 | ungel x : 1 -> p @ x at _ -> P a with | gel r -> r 52 | 53 | let id_param : (F : (A : U<0>) -> A -> A) -> (A : U<0>) (a : A) -> Id A (F A a) a = 54 | fun F A a -> 55 | let P : A -> U<0> = fun b -> Id A b a in 56 | gelproj A (fun b -> P b) (F A a) (bri x -> F (Gel x {A} (b -> P b)) (gel x {a} (refl a))) 57 | 58 | let pt uncong_codisc : (A : U<0>) (a0 : A) (a1 : A) 59 | -> (dsc | Id (Codisc A) (codisc a0) (codisc a1)) 60 | -> Id A a0 a1 61 | = 62 | fun A a0 a1 eq -> 63 | uncodisc 64 | (match eq at b0 b1 _ -> Codisc (Id A (uncodisc b0) (uncodisc b1)) with 65 | | refl z -> codisc (refl (uncodisc z))) 66 | 67 | let pt id_param' : (dsc | F : (A : U<0>) -> A -> A) 68 | (A : U<0>) (a : A) -> Id A (readOff F A a) a 69 | = 70 | fun F A a -> 71 | uncong_codisc A (readOff F A a) a (id_param F (Codisc A) (codisc a)) 72 | 73 | -------------------------------------------------------------------------------- 74 | -- Polymorphic endofunction on coproduct 75 | -------------------------------------------------------------------------------- 76 | 77 | let pt Coprod_pt : U<0> -> U<0> -> U<0> = 78 | fun A B -> (b : bool) * if b at _ -> U<0> with | tt -> A | ff -> B 79 | 80 | let pt case_pt : (A : U<0>) (B : U<0>) (P : (Coprod_pt A B) -> U<0>) 81 | -> ((a : A) -> P ) 82 | -> ((b : B) -> P ) 83 | -> ((c : Coprod_pt A B) -> P c) 84 | = 85 | fun A B P f g c -> 86 | (if fst c at b -> (t : if b at _ -> U<0> with | tt -> A | ff -> B) -> P with 87 | | tt -> fun a -> f a 88 | | ff -> fun b -> g b) 89 | (snd c) 90 | 91 | let Coprod_par : U<0> -> U<0> -> U<0> = 92 | fun A B -> (b : bool) * if b at _ -> U<0> with | tt -> A | ff -> B 93 | 94 | let case_par : (A : U<0>) (B : U<0>) (P : (Coprod_par A B) -> U<0>) 95 | -> ((a : A) -> P ) 96 | -> ((b : B) -> P ) 97 | -> ((c : Coprod_par A B) -> P c) 98 | = 99 | fun A B P f g c -> 100 | (if fst c at b -> (t : if b at _ -> U<0> with | tt -> A | ff -> B) -> P with 101 | | tt -> fun a -> f a 102 | | ff -> fun b -> g b) 103 | (snd c) 104 | 105 | let fwd : (cmp | A : U<0>) (cmp | B : U<0>) 106 | -> (Coprod_par (Codisc A) (Codisc B)) -> Codisc (Coprod_pt A B) 107 | = 108 | fun A B -> 109 | case_par (Codisc A) (Codisc B) 110 | (fun _ -> Codisc (Coprod_pt A B)) 111 | (fun ca -> codisc ) 112 | (fun cb -> codisc ) 113 | 114 | let bwd : (cmp | A : U<0>) (cmp | B : U<0>) 115 | -> (cmp | Coprod_pt A B) 116 | -> Coprod_par (Codisc A) (Codisc B) 117 | = 118 | fun A B c -> 119 | unglob 120 | (case_pt A B 121 | (fun _ -> Global (Coprod_par (Codisc A) (Codisc B))) 122 | (fun a -> glob ()) 123 | (fun b -> glob ()) 124 | c) 125 | 126 | let pt readOff : (dsc | (A : U<0>) (B : U<0>) -> (Coprod_par A B) -> Coprod_par A B) 127 | -> (A : U<0>) (B : U<0>) -> (Coprod_pt A B) -> Coprod_pt A B 128 | = 129 | fun F A B c -> 130 | uncodisc (fwd A B (F (Codisc A) (Codisc B) (bwd A B c))) 131 | 132 | normalize pt readOff (fun A B c -> c) at (A : U<0>) (B : U<0>) -> (Coprod_pt A B) -> Coprod_pt A B 133 | 134 | let pt _ : 135 | Id ((A : U<0>) (B : U<0>) -> (Coprod_pt A B) -> Coprod_pt A B) 136 | (readOff (fun A B c -> c)) 137 | (fun A B c -> uncodisc (fwd A B (bwd A B c))) 138 | = 139 | refl (readOff (fun A B c -> c)) -------------------------------------------------------------------------------- /test/const_nat.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Part of a proof that nat is bridge-discrete 3 | -------------------------------------------------------------------------------- 4 | 5 | -- Identity type lemmas 6 | 7 | let subst : (A : U<0>) (B : A -> U<0>) 8 | (a0 : A) (a1 : A) (eq : Id A a0 a1) 9 | -> (B a0) -> B a1 10 | = 11 | fun A B a0 a1 eq -> 12 | match eq at a0 a1 _ -> (B a0) -> B a1 with 13 | | refl _ -> fun b -> b 14 | 15 | let subst2 : (A : U<0>) (B : U<0>) (C : A -> B -> U<0>) 16 | (a0 : A) (a1 : A) (eqA : Id A a0 a1) 17 | (b0 : B) (b1 : B) (eqB : Id B b0 b1) 18 | -> (C a0 b0) -> C a1 b1 19 | = 20 | fun A B C a0 a1 eq -> 21 | match eq at a0 a1 _ -> (b0 : B) (b1 : B) -> (Id B b0 b1) -> (C a0 b0) -> C a1 b1 with 22 | | refl a -> subst B (C a) 23 | 24 | let trans : (A : U<0>) (a : A) (b : A) (c : A) -> (Id A a b) -> (Id A b c) -> Id A a c = 25 | fun A a b c eq0 -> 26 | match eq0 at x y _ -> (Id A y c) -> Id A x c with 27 | | refl z -> fun eq1 -> eq1 28 | 29 | let comp : (A : U<0>) 30 | (a0 : A) (a1 : A) (eq : Id A a0 a1) 31 | (a0' : A) (eq0 : Id A a0 a0') 32 | (a1' : A) (eq1 : Id A a1 a1') 33 | -> Id A a0' a1' 34 | = 35 | fun A a0 a1 eq a0' eq0 a1' eq1 -> 36 | subst2 A A (fun t0 t1 -> Id A t0 t1) 37 | a0 a0' eq0 38 | a1 a1' eq1 39 | eq 40 | 41 | let cong : (A : U<0>) (B : U<0>) (f : A -> B) (a0 : A) (a1 : A) 42 | -> (Id A a0 a1) -> Id B (f a0) (f a1) 43 | = 44 | fun A B f a0 a1 eq -> 45 | match eq at x0 x1 _ -> Id B (f x0) (f x1) with 46 | | refl z -> refl (f z) 47 | 48 | let cong_comp : (A : U<0>) (B : U<0>) (f : A -> B) 49 | (a0 : A) (a1 : A) (eq : Id A a0 a1) 50 | (a0' : A) (eq0 : Id A a0 a0') 51 | (a1' : A) (eq1 : Id A a1 a1') 52 | -> Id (Id B (f a0') (f a1')) 53 | (comp B (f a0) (f a1) (cong A B f a0 a1 eq) 54 | (f a0') (cong A B f a0 a0' eq0) (f a1') (cong A B f a1 a1' eq1)) 55 | (cong A B f a0' a1' (comp A a0 a1 eq a0' eq0 a1' eq1)) 56 | = 57 | fun A B f -> 58 | let Goal : (a0 : A) (a1 : A) (eq : Id A a0 a1) 59 | (a0' : A) (eq0 : Id A a0 a0') (a1' : A) (eq1 : Id A a1 a1') 60 | -> U<0> 61 | = 62 | fun a0 a1 eq a0' eq0 a1' eq1 -> 63 | Id (Id B (f a0') (f a1')) 64 | (comp B (f a0) (f a1) (cong A B f a0 a1 eq) 65 | (f a0') (cong A B f a0 a0' eq0) (f a1') (cong A B f a1 a1' eq1)) 66 | (cong A B f a0' a1' (comp A a0 a1 eq a0' eq0 a1' eq1)) 67 | in 68 | fun a0 a1 eq a0' eq0 a1' eq1 -> 69 | (match eq0 at 70 | a0 a0' eq0 -> (a1 : A) (a1' : A) (eq1 : Id A a1 a1') (eq : Id A a0 a1) -> Goal a0 a1 eq a0' eq0 a1' eq1 71 | with 72 | | refl a0 -> 73 | fun a1 a1' eq1 -> 74 | match eq1 at 75 | a1 a1' eq1 -> (eq : Id A a0 a1) -> Goal a0 a1 eq a0 (refl a0) a1' eq1 76 | with 77 | | refl a1 -> fun eq -> refl (cong A B f a0 a1 eq)) 78 | a1 a1' eq1 eq 79 | 80 | -- Gel type lemmas 81 | 82 | let gelproj : (A : U<0>) (B : U<0>) (R : A -> B -> U<0>) 83 | -> (p : [x] Gel x {A; B} (a b -> R a b) {*; *}) -> R (p @ 0) (p @ 1) 84 | = 85 | fun A B R p -> 86 | ungel x : 2 -> p @ x at _ -> R (p @ 0) (p @ 1) with | gel r -> r 87 | 88 | -- -- nat is a retract of [x] nat {} 89 | 90 | let loosen : (m : nat) (n : nat) -> (Id nat m n) -> [x] nat {m; n} = 91 | fun m n eq -> subst nat (fun k -> [x] nat {m; k}) m n eq (bri _ -> m) 92 | 93 | let nat_id : nat -> nat = 94 | fun n -> 95 | rec n at _ -> nat with 96 | | zero -> zero 97 | | suc _, n -> suc n 98 | 99 | let nat_eta : (n : nat) -> Id nat (nat_id n) n = 100 | fun n -> 101 | rec n at n -> Id nat (nat_id n) n with 102 | | zero -> refl zero 103 | | suc n, eq -> cong nat nat (fun t -> suc t) (nat_id n) n eq 104 | 105 | let tighten_aux : [x] nat -> Gel x {nat; nat} (m n -> Id nat m n) {nat_id; nat_id} = 106 | bri x -> fun k -> 107 | rec k at _ -> Gel x {nat; nat} (m n -> Id nat m n) with 108 | | zero -> gel x {zero; zero} (refl zero) 109 | | suc _, g -> 110 | extent x of g in 111 | y -> Gel y {nat; nat} (m n -> Id nat m n) at 112 | y _ -> Gel y {nat; nat} (m n -> Id nat m n) with 113 | | m -> suc m 114 | | n -> suc n 115 | | m n q y -> 116 | gel y {suc m; suc n} 117 | (cong nat nat (fun t -> suc t) m n 118 | (gelproj nat nat (fun m n -> Id nat m n) q)) 119 | 120 | let tighten : (p : [x] nat {*; *}) -> Id nat (p @ 0) (p @ 1) = 121 | fun p -> 122 | comp nat 123 | (nat_id (p @ 0)) (nat_id (p @ 1)) 124 | (gelproj nat nat (fun m n -> Id nat m n) 125 | (bri x -> tighten_aux @ x (p @ x))) 126 | (p @ 0) (nat_eta (p @ 0)) 127 | (p @ 1) (nat_eta (p @ 1)) 128 | 129 | let tighten_loosen_refl : (m : nat) 130 | -> Id (Id nat m m) (tighten (loosen m m (refl m))) (refl m) 131 | = 132 | fun m -> 133 | rec m at m -> Id (Id nat m m) (tighten (loosen m m (refl m))) (refl m) with 134 | | zero -> (refl (refl zero)) 135 | | suc m, pf -> 136 | trans (Id nat (suc m) (suc m)) 137 | (tighten (loosen (suc m) (suc m) (refl (suc m)))) 138 | (cong nat nat (fun k -> suc k) m m (tighten (loosen m m (refl m)))) 139 | (refl (suc m)) 140 | (cong_comp nat nat (fun k -> suc k) 141 | (nat_id m) (nat_id m) 142 | (gelproj nat nat (fun m n -> Id nat m n) 143 | (bri x -> tighten_aux @ x m)) 144 | m (nat_eta m) 145 | m (nat_eta m)) 146 | (cong (Id nat m m) (Id nat (suc m) (suc m)) (cong nat nat (fun k -> suc k) m m) 147 | (tighten (loosen m m (refl m))) 148 | (refl m) 149 | pf) 150 | 151 | let tighten_loosen : (m : nat) (n : nat) (eq : Id nat m n) 152 | -> Id (Id nat m n) (tighten (loosen m n eq)) eq 153 | = 154 | fun m n eq -> 155 | match eq at m n eq -> Id (Id nat m n) (tighten (loosen m n eq)) eq with 156 | | refl m -> tighten_loosen_refl m 157 | -------------------------------------------------------------------------------- /test/discrete.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Discrete modality tests 3 | -------------------------------------------------------------------------------- 4 | 5 | let _ : (cmp | A : U<0>) (cmp | a : A) -> Disc A = 6 | fun A a -> disc a 7 | 8 | let pt discproj : (A : U<0>) -> (dsc | Disc A) -> A = 9 | fun A d -> undisc{dsc} d at _ -> A with | disc a -> a 10 | 11 | let pt projeta : (A : U<0>) (dsc | d : Disc A) 12 | -> Global (Id (Disc A) (disc (discproj A d)) d) 13 | = 14 | fun A d -> 15 | undisc{dsc} d at d -> Global (Id (Disc A) (disc (discproj A d)) d) with 16 | | disc a -> glob (refl (disc a)) 17 | 18 | let par _ : (cmp | A : U<0>) -> (Disc A) -> Codisc A = 19 | fun A d -> codisc (discproj A d) 20 | 21 | let pt go : (A : U<0>) (B : U<0>) -> (A -> B) -> Global ((Disc A) -> Disc B) 22 | = 23 | fun A B f -> 24 | glob (fun d -> undisc{} d at _ -> Disc B with | disc a -> disc (f a)) 25 | 26 | let pt stop : (A : U<0>) (B : U<0>) -> (Global ((Disc A) -> Disc B)) -> (A -> B) 27 | = 28 | fun A B u a -> 29 | discproj B ((unglob u) (disc a)) 30 | 31 | let pt inv1 : (A : U<0>) (B : U<0>) (f : A -> B) 32 | -> Id (A -> B) (stop A B (go A B f)) f 33 | = 34 | fun A B f -> refl f 35 | 36 | let pt inv2 : (A : U<0>) (B : U<0>) (u : Global ((Disc A) -> Disc B)) (dsc | d : Disc A) 37 | -> Global (Id (Disc B) ((unglob (go A B (stop A B u))) d) ((unglob u) d)) 38 | = 39 | fun A B u d -> 40 | glob 41 | (undisc{} d at d -> Id (Disc B) ((unglob (go A B (stop A B u))) d) ((unglob u) d) with 42 | | disc a -> unglob (projeta B ((unglob u) (disc a)))) 43 | 44 | -------------------------------------------------------------------------------- 45 | -- Global (Disc A) ≃ A 46 | -------------------------------------------------------------------------------- 47 | 48 | let pt into : (A : U<0>) -> A -> Global (Disc A) = 49 | fun A a -> glob (disc a) 50 | 51 | let pt out : (A : U<0>) -> (Global (Disc A)) -> A = 52 | fun A g -> discproj A (unglob g) 53 | 54 | let pt out_into : (A : U<0>) (a : A) -> Id A (out A (into A a)) a = 55 | fun A a -> refl a 56 | 57 | let pt into_out : (A : U<0>) (g : Global (Disc A)) 58 | -> Id (Global (Disc A)) (into A (out A g)) g 59 | = 60 | fun A g -> 61 | undisc{dsc} (unglob g) at d -> 62 | Id (Global (Disc A)) (glob (disc (discproj A d))) (glob d) 63 | with 64 | | disc a -> refl (glob (disc a)) 65 | 66 | -------------------------------------------------------------------------------- 67 | -- Booleans 68 | -- Example of colimits commuting with Disc (unlike Codisc) 69 | -------------------------------------------------------------------------------- 70 | 71 | let pt into_global : bool -> Global bool = 72 | fun b -> 73 | if b at _ -> Global bool with 74 | | tt -> glob tt 75 | | ff -> glob ff 76 | 77 | let into_disc : bool -> Disc bool = 78 | fun b -> 79 | if b at _ -> Disc bool with 80 | | tt -> disc tt 81 | | ff -> disc ff 82 | 83 | let out_disc : (Disc bool) -> bool = 84 | fun d -> 85 | undisc{} d at _ -> bool with | disc b -> unglob (into_global b) 86 | 87 | let out_into_disc : (b : bool) -> Id bool (out_disc (into_disc b)) b = 88 | fun b -> 89 | if b at b -> Id bool (out_disc (into_disc b)) b with 90 | | tt -> refl tt 91 | | ff -> refl ff 92 | 93 | let into_out_disc : (d : Disc bool) -> Id (Disc bool) (into_disc (out_disc d)) d = 94 | fun d -> 95 | undisc{} d at d -> Id (Disc bool) (into_disc (out_disc d)) d with 96 | | disc b -> 97 | unglob 98 | (if b at b -> Global (Id (Disc bool) (into_disc (unglob (into_global b))) (disc b)) with 99 | | tt -> glob (refl (disc tt)) 100 | | ff -> glob (refl (disc ff))) 101 | 102 | -------------------------------------------------------------------------------- 103 | -- Identity types in Disc 104 | -------------------------------------------------------------------------------- 105 | 106 | let Code : (cmp | A : U<0>) -> (Disc A) -> (Disc A) -> U<0> = 107 | fun A d0 -> 108 | undisc{} d0 at _ -> (Disc A) -> U<0> with 109 | | disc a0 -> fun d1 -> 110 | undisc{} d1 at _ -> U<0> with 111 | | disc a1 -> Disc (Id A a0 a1) 112 | 113 | let encode_refl : (cmp | A : U<0>) (d : Disc A) -> Code A d d 114 | = 115 | fun A d -> 116 | undisc{} d at d -> Code A d d with 117 | | disc a -> disc (refl a) 118 | 119 | let encode : (cmp | A : U<0>) (d0 : Disc A) (d1 : Disc A) 120 | -> (Id (Disc A) d0 d1) -> Code A d0 d1 121 | = 122 | fun A d0 d1 eq -> 123 | match eq at d0 d1 _ -> Code A d0 d1 with 124 | | refl d -> encode_refl A d 125 | 126 | let pt disc_injective : (A : U<0>) (a0 : A) (a1 : A) 127 | -> (dsc | Id (Disc A) (disc a0) (disc a1)) 128 | -> Id A a0 a1 129 | = 130 | fun A a0 a1 g -> 131 | undisc{dsc} (encode A (disc a0) (disc a1) g) at _ -> Id A a0 a1 with 132 | | disc eq -> eq 133 | 134 | -- can this be proven without using Codisc? 135 | let pt cong_discproj : (A : U<0>) 136 | (dsc | d0 : Disc A) (dsc | d1 : Disc A) (dsc | eq : Id (Disc A) d0 d1) 137 | -> Id A (discproj A d0) (discproj A d1) 138 | = 139 | fun A d0 d1 eq -> 140 | uncodisc 141 | (match eq at d0 d1 _ -> Codisc (Id A (discproj A d0) (discproj A d1)) 142 | with 143 | | refl d -> codisc (refl (discproj A d))) 144 | 145 | -------------------------------------------------------------------------------- 146 | -- Polymorphic endofunction 147 | -------------------------------------------------------------------------------- 148 | 149 | let pt readOff : (dsc | ((A : U<0>) -> A -> A)) -> (A : U<0>) -> A -> A = 150 | fun F A a -> discproj A (F (Disc A) (disc a)) 151 | 152 | let gelproj : (A : U<0>) (P : A -> U<0>) (a : A) -> [x] Gel x {A} (a -> P a) {a} -> P a = 153 | fun A P a p -> 154 | ungel x : 1 -> p @ x at _ -> P a with | gel r -> r 155 | 156 | let id_param : (F : (A : U<0>) -> A -> A) -> (A : U<0>) (a : A) -> Id A (F A a) a = 157 | fun F A a -> 158 | let P : A -> U<0> = fun b -> Id A b a in 159 | gelproj A (fun b -> P b) (F A a) (bri x -> F (Gel x {A} (b -> P b)) (gel x {a} (refl a))) 160 | 161 | let pt id_param' : (dsc | F : (A : U<0>) -> A -> A) 162 | (A : U<0>) (a : A) -> Id A (readOff F A a) a 163 | = 164 | fun F A a -> 165 | cong_discproj A (F (Disc A) (disc a)) (disc a) (id_param F (Disc A) (disc a)) 166 | 167 | -------------------------------------------------------------------------------- 168 | -- Discrete types are bridge-discrete 169 | -------------------------------------------------------------------------------- 170 | 171 | let id_to_bridge : (A : U<0>) (a : A) (b : A) 172 | -> (Id A a b) -> [_] A {a; b} 173 | = 174 | fun A a b eq -> 175 | match eq at a b _ -> [_] A {a; b} with 176 | | refl a -> bri _ -> a 177 | 178 | let disc_to_gel : (cmp | A : U<0>) 179 | -> [x] (Disc A) -> Gel x {Disc A; Disc A} (d0 d1 -> Id (Disc A) d0 d1) {*;*} 180 | = 181 | fun A -> bri x -> fun d -> 182 | undisc{} d at _ -> Gel x {Disc A; Disc A} (d0 d1 -> Id (Disc A) d0 d1) with 183 | | disc a -> gel x {disc a; disc a} (refl (disc a)) 184 | 185 | let disc_id : (cmp | A : U<0>) -> (Disc A) -> Disc A 186 | = 187 | fun A d -> undisc{} d at _ -> Disc A with | disc a -> disc a 188 | 189 | let disc_bridge_to_id : (cmp | A : U<0>) 190 | (a : Disc A) (b : Disc A) (p : [_] Disc A {a; b}) -> Id (Disc A) (disc_id A a) (disc_id A b) 191 | = 192 | fun A a b p -> 193 | ungel x : 2 -> disc_to_gel A @ x (p @ x) at _ -> Id (Disc A) (disc_id A a) (disc_id A b) with | gel q -> q 194 | -------------------------------------------------------------------------------- /test/extent.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Basic tests for (nullary) extent 3 | -------------------------------------------------------------------------------- 4 | 5 | -- Should not check 6 | -- let diagonal_extent : (A : U<0>) -> [x] A -> A {} = 7 | -- fun A -> bri x -> fun a -> 8 | -- extent x of a in _ -> A at _ _ -> A with 9 | -- | q _ -> q @ x 10 | 11 | let extent_test : (A : U<0>) -> [x] (A -> [y] A {}) {} = 12 | fun A -> bri x -> fun a -> 13 | extent x of a in _ -> A at _ _ -> [y] A {} with 14 | | q _ -> q 15 | 16 | normalize def extent_test 17 | 18 | let extent_test2 : (A : U<0>) (B : U<0>) -> ([x] A {} -> [x] B {}) -> [x] A {} -> [x] B {} = 19 | fun A B f q -> bri x -> 20 | extent x of q @ x in _ -> A at _ _ -> B with 21 | | q y -> f q @ y 22 | 23 | normalize def extent_test2 24 | 25 | let bunext : (A : U<0>) (B : U<0>) -> ([x] A {} -> [x] B {}) -> [x] A -> B {} = 26 | fun A B f -> bri x -> fun a -> 27 | extent x of a in _ -> A at _ _ -> B with 28 | | q y -> f q @ y 29 | 30 | normalize def bunext 31 | 32 | let bunapp : (A : U<0>) (B : U<0>) -> [x] A -> B {} -> [x] A {} -> [x] B {} = 33 | fun A B p q -> bri x -> p @ x (q @ x) 34 | 35 | normalize def bunapp 36 | 37 | let extent_test3 : (A : U<0>) (B : U<0>) -> ([x] A {} -> [x] B {}) -> [x] A {} -> [x] B {} = 38 | fun A B f -> bunapp A B (bunext A B f) 39 | 40 | normalize def extent_test3 41 | 42 | let bunext_inv : (A : U<0>) (B : U<0>) (f : [x] A {} -> [x] B {}) (q : [x] A {}) 43 | -> [x] Id B (bunapp A B (bunext A B f) q @ x) (f q @ x) {} 44 | = 45 | fun A B f q -> bri x -> refl (f q @ x) 46 | 47 | normalize def bunext_inv 48 | 49 | let bunext_inv2 : (A : U<0>) (B : U<0>) (f : [x] A {} -> [x] B {}) 50 | -> Id ([x] A {} -> [x] B {}) (bunapp A B (bunext A B f)) f 51 | = 52 | fun A B f -> refl f 53 | 54 | normalize def bunext_inv2 55 | 56 | -- Should not check 57 | -- let bunapp_inv_bad : (A : U<0>) (B : U<0>) (p : [x] A -> B {}) 58 | -- -> [x] (a : A) -> Id B (bunext A B (bunapp A B p) @ x a) (p @ x a) {} 59 | -- = 60 | -- fun A B p -> bri x -> fun a -> refl (p @ x a) 61 | 62 | let bunapp_inv : (A : U<0>) (B : U<0>) (p : [x] A -> B {}) 63 | -> [x] (a : A) -> Id B (bunext A B (bunapp A B p) @ x a) (p @ x a) {} 64 | = 65 | fun A B p -> bri x -> fun a -> 66 | extent x of a in _ -> A at y c -> Id B (bunext A B (bunapp A B p) @ y c) (p @ y c) with 67 | | q y -> refl (p @ y (q @ y)) 68 | 69 | normalize def bunapp_inv 70 | 71 | let extent_type_test : (A : U<0>) 72 | -> A -> [x] extent x of A in _ -> U<0> at _ _ -> U<0> with | q y -> q @ y {} 73 | = 74 | fun A a -> bri x -> a 75 | 76 | normalize def extent_type_test 77 | 78 | let extent_type_test2 : (A : U<0>) 79 | -> [x] A -> extent x of A in _ -> U<0> at _ _ -> U<0> with | q y -> q @ y {} 80 | = 81 | fun A -> bri x -> fun a -> a 82 | 83 | normalize def extent_type_test2 84 | 85 | -- Should not check 86 | -- let extent_type_test_bad : 87 | -- [x] (A : U<0>) -> A -> extent x of A in _ -> U<0> at _ _ -> U<0> with | q y -> q @ y {} 88 | -- = 89 | -- bri x -> fun A a -> a 90 | 91 | let extent_test4 : (A : U<0>) (B : U<0>) (f : [x] A {} -> [x] B {}) (q : [x] A {}) 92 | -> [x] Id B (f q @ x) (bunapp A B (bunext A B (bunapp A B (bunext A B f))) q @ x) {} 93 | = 94 | fun A B f q -> bri x -> refl (f q @ x) 95 | 96 | normalize def extent_test4 97 | 98 | -- Make sure that extent reduces correctly inside the context argument of another extent 99 | 100 | let extent_test5 : [y] nat -> [x] nat {} {} 101 | = 102 | bri y -> fun n -> bri x -> 103 | extent x of 104 | (extent y of n in _ -> nat at _ _ -> nat with | q y -> suc zero) in 105 | _ -> nat at 106 | _ _ -> nat with 107 | | p x -> zero 108 | 109 | normalize def extent_test5 110 | 111 | let extent_test5a : Id ([y] nat -> [x] nat {} {}) extent_test5 (bri y -> fun n -> bri x -> zero) 112 | = 113 | refl (bri y -> fun n -> bri x -> zero) 114 | 115 | let extent_test6 : [x] nat -> [y] nat {} {} 116 | = 117 | bri x -> fun n -> bri y -> 118 | extent x of 119 | (extent y of n in _ -> nat at _ _ -> nat with | q y -> suc zero) in 120 | _ -> nat at 121 | _ _ -> nat with 122 | | p x -> zero 123 | 124 | normalize def extent_test6 125 | 126 | let extent_test6a : Id ([x] nat -> [y] nat {} {}) extent_test6 (bri x -> fun n -> bri y -> zero) 127 | = 128 | refl (bri x -> fun n -> bri y -> zero) 129 | 130 | let extent_test7 : (A : U<0>) (B : U<0>) -> 131 | [x] (extent x of triv in _ -> unit at _ _ -> U<0> with | _ _ -> A -> B) -> A -> B {} 132 | = 133 | fun A B -> bri x -> fun f a -> f a 134 | 135 | normalize def extent_test7 136 | -------------------------------------------------------------------------------- /test/gel.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Basic tests for (nullary) Gel-types 3 | -------------------------------------------------------------------------------- 4 | 5 | let gel_test1 : (A : U<0>) -> A -> [x] Gel x A {} = 6 | fun A a -> bri x -> gel x a 7 | 8 | normalize def gel_test1 9 | 10 | let gel_test2 : (A : U<0>) -> [x] (Gel x A) -> Gel x A {} = 11 | fun A -> bri x -> fun p -> p 12 | 13 | normalize def gel_test2 14 | 15 | let gel_test3 : (A : U<0>) -> [x] Gel x A {} -> [x] Gel x A {} = 16 | fun A p -> p 17 | 18 | normalize def gel_test3 19 | 20 | let gel_test4 : (A : U<0>) -> [x] Gel x A {} -> A = 21 | fun A p -> ungel x : 0 -> p @ x at _ -> A with | gel a -> a 22 | 23 | normalize def gel_test4 24 | 25 | let gel_test5 : (A : U<0>) -> (a : A) -> Id A (gel_test4 A (bri x -> gel x a)) a = 26 | fun A a -> refl a 27 | 28 | normalize def gel_test5 29 | 30 | -- should not check with positive Gel 31 | -- let gel_test6_bad : (A : U<0>) -> (p : [x] Gel x A {}) 32 | -- -> Id ([x] Gel x A {}) (bri x -> gel x (gel_test4 A p)) p 33 | -- = 34 | -- fun A p -> refl p 35 | 36 | let gel_test6 : (A : U<0>) -> (p : [x] Gel x A {}) 37 | -> Id ([x] Gel x A {}) (bri x -> gel x (gel_test4 A p)) p 38 | = 39 | fun A p -> 40 | ungel x : 0 -> p @ x at q -> Id ([x] Gel x A {}) (bri x -> gel x (gel_test4 A q)) q with 41 | | gel a -> refl (bri x -> gel x a) 42 | 43 | normalize def gel_test6 44 | 45 | let gel_test7 : (A : U<0>) -> [x] [y] Gel y (Gel x A) {} {} -> A = 46 | fun A g -> gel_test4 A (bri x -> (gel_test4 (Gel x A) (g @ x))) 47 | 48 | normalize def gel_test7 49 | 50 | let gel_test8 : (A : U<0>) (B : U<0>) (f : A -> B) -> [x] Gel x A {} -> B = 51 | fun A B f p -> ungel x : 0 -> p @ x at _ -> B with | gel a -> f a 52 | 53 | normalize def gel_test8 54 | 55 | -- test of capture-avoiding substitution in ungel 56 | 57 | let gel_test10 : (A : U<0>) (g : [x] [y] Gel y (Gel x A) {} {}) (b : bool) 58 | -> Id A (gel_test7 A g) (gel_test7 A g) 59 | = 60 | fun A g -> 61 | let t : A = gel_test4 A (bri x -> (gel_test4 (Gel x A) (g @ x))) 62 | in 63 | fun _ -> refl t 64 | 65 | normalize def gel_test10 -------------------------------------------------------------------------------- /test/identity.ptt: -------------------------------------------------------------------------------- 1 | let gelproj : (A : U<0>) (P : A -> U<0>) (a : A) -> [x] Gel x {A} (a -> P a) {a} -> P a = 2 | fun A P a p -> 3 | ungel x : 1 -> p @ x at _ -> P a with | gel r -> r 4 | 5 | normalize def gelproj 6 | 7 | let id_param1 : (F : (A : U<0>) -> A -> A) -> (A : U<0>) (a : A) -> Id A (F A a) a = 8 | fun F A a -> 9 | let P : A -> U<0> = fun b -> Id A b a in 10 | gelproj A (fun b -> P b) (F A a) (bri x -> F (Gel x {A} (b -> P b)) (gel x {a} (refl a))) 11 | 12 | normalize def id_param1 13 | 14 | normalize id_param1 (fun A a -> a) at (A : U<0>) (a : A) -> Id A a a -------------------------------------------------------------------------------- /test/leibniz.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Any operator that transports properties from a0,a1 : A for A bridge-discrete 3 | -- must be substitution along a path from a0 to a1. This would be one part of 4 | -- a proof that Id A a0 a1 is equivalent to Leibniz equality: 5 | -- (B : A -> U<0>) -> B a0 -> B a1 6 | -- but we would need function extensionality to prove the complete result. 7 | -------------------------------------------------------------------------------- 8 | 9 | let subst : (A : U<0>) (a0 : A) (a1 : A) (eq : Id A a0 a1) 10 | (B : A -> U<0>) -> (B a0) -> B a1 = 11 | fun A a0 a1 eq B -> 12 | match eq at x y _ -> (B x) -> B y with 13 | | refl _ -> fun b -> b 14 | 15 | let symm : (A : U<0>) (a : A) (b : A) -> (Id A a b) -> Id A b a = 16 | fun A a b eq -> 17 | match eq at x y _ -> Id A y x with 18 | | refl z -> refl z 19 | 20 | let trans : (A : U<0>) (a : A) (b : A) (c : A) -> (Id A a b) -> (Id A b c) -> Id A a c = 21 | fun A a b c eq0 -> 22 | match eq0 at x y _ -> (Id A y c) -> Id A x c with 23 | | refl z -> fun eq1 -> eq1 24 | 25 | let cong : (A : U<0>) (B : U<0>) (f : A -> B) (a0 : A) (a1 : A) 26 | -> (Id A a0 a1) -> Id B (f a0) (f a1) 27 | = 28 | fun A B f a0 a1 eq -> 29 | match eq at x0 x1 _ -> Id B (f x0) (f x1) with 30 | | refl z -> refl (f z) 31 | 32 | let gelproj : (A : U<0>) (B : U<0>) (R : A -> B -> U<0>) 33 | (a : A) (b : B) -> [x] Gel x {A; B} (a b -> R a b) {a; b} -> R a b 34 | = 35 | fun A B R a b p -> 36 | ungel x : 2 -> p @ x at _ -> R a b with | gel r -> r 37 | 38 | let is_equiv : (A : U<0>) (B : U<0>) (f : A -> B) -> U<0> = 39 | fun A B f -> 40 | ((l : B -> A) * (a : A) -> Id A (l (f a)) a) 41 | * ((r : B -> A) * (b : B) -> Id B (f (r b)) b) 42 | 43 | let id_to_bridge : (A : U<0>) (a0 : A) (a1 : A) -> (Id A a0 a1) -> [_] A {a0; a1} = 44 | fun A a0 a1 eq -> 45 | subst A a0 a1 eq (fun a -> [_] A {a0;a}) (bri _ -> a0) 46 | 47 | let is_bdisc : U<0> -> U<0> = 48 | fun A -> 49 | (a0 : A) (a1 : A) -> 50 | is_equiv (Id A a0 a1) ([_] A {a0; a1}) (id_to_bridge A a0 a1) 51 | 52 | let subst_unique : (A : U<0>) (_ : is_bdisc A) (a0 : A) (a1 : A) 53 | (F : (B : A -> U<0>) -> (B a0) -> B a1) 54 | (B : A -> U<0>) (b0 : B a0) 55 | -> Id (B a1) (F B b0) (subst A a0 a1 (F (fun a -> Id A a0 a) (refl a0)) B b0) 56 | = 57 | fun A bd a0 a1 F B b0 -> 58 | let R : (c0 : A) (c1 : A) (eq : Id A c0 c1) -> (B c0) -> (Id A a0 c1) -> U<0> = 59 | fun c0 c1 ceq b eq -> 60 | Id (B c1) 61 | (subst A c0 c1 ceq B b) 62 | (subst A a0 c1 eq B b0) 63 | in 64 | let G : [x] A -> U<0> {B; fun a -> Id A a0 a} = 65 | bri x -> fun a -> 66 | extent x of a in _ -> A at _ _ -> U<0> with 67 | | c0 -> B c0 68 | | c1 -> Id A a0 c1 69 | | c0 c1 q y -> 70 | Gel y {B c0; Id A a0 c1} (b eq -> R c0 c1 (fst (fst (bd c0 c1)) q) b eq) 71 | in 72 | let g : [x] G @ x a0 {b0; refl a0} = 73 | bri x -> 74 | gel x {b0; refl a0} 75 | (cong (Id A a0 a0) (B a0) 76 | (fun eq -> subst A a0 a0 eq B b0) 77 | (fst (fst (bd a0 a0)) (bri _ -> a0)) 78 | (refl a0) 79 | (snd (fst (bd a0 a0)) (refl a0))) 80 | in 81 | let FGg : [x] G @ x a1 {F B b0; F (fun a -> Id A a0 a) (refl a0)} = 82 | bri x -> F (G @ x) (g @ x) 83 | in 84 | let adjust : Id (B a1) (F B b0) (subst A a1 a1 (fst (fst (bd a1 a1)) (bri _ -> a1)) B (F B b0)) = 85 | symm (B a1) 86 | (subst A a1 a1 (fst (fst (bd a1 a1)) (bri _ -> a1)) B (F B b0)) 87 | (F B b0) 88 | (cong (Id A a1 a1) (B a1) 89 | (fun eq -> subst A a1 a1 eq B (F B b0)) 90 | (fst (fst (bd a1 a1)) (bri _ -> a1)) 91 | (refl a1) 92 | (snd (fst (bd a1 a1)) (refl a1))) 93 | in 94 | let main : Id (B a1) 95 | (subst A a1 a1 (fst (fst (bd a1 a1)) (bri _ -> a1)) B (F B b0)) 96 | (subst A a0 a1 (F (fun a -> Id A a0 a) (refl a0)) B b0) 97 | = 98 | gelproj (B a1) (Id A a0 a1) 99 | (R a1 a1 (fst (fst (bd a1 a1)) (bri _ -> a1))) 100 | (F B b0) 101 | (F (fun a -> Id A a0 a) (refl a0)) 102 | FGg 103 | in 104 | trans (B a1) 105 | (F B b0) 106 | (subst A a1 a1 (fst (fst (bd a1 a1)) (bri _ -> a1)) B (F B b0)) 107 | (subst A a0 a1 (F (fun a -> Id A a0 a) (refl a0)) B b0) 108 | adjust 109 | main 110 | -------------------------------------------------------------------------------- /test/line.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Basic tests of line-types (bridge-types with incompletely specified 3 | -- endpoints) 4 | -------------------------------------------------------------------------------- 5 | 6 | let line_map : (A : U<0>) (B : U<0>) -> (A -> B) -> ([_] A {*; *}) -> [_] B {*; *} = 7 | fun A B f p -> bri x -> f (p @ x) 8 | 9 | normalize def line_map 10 | 11 | let learn_ends : (A : U<0>) -> (p : [_] A {*;*}) -> [_] A {p @ 0; p @ 1} = 12 | fun A p -> bri x -> p @ x 13 | 14 | normalize def learn_ends 15 | 16 | let forget : (A : U<0>) (a0 : A) (a1 : A) -> ([_] A {a0; a1}) -> [_] A {*; *} = 17 | fun A a0 a1 p -> bri x -> p @ x 18 | 19 | normalize def forget 20 | 21 | let switch : (A : U<0>) (a0 : A) -> (p : [_] A {a0; *}) -> [_] A {*; p @ 1} = 22 | fun A a0 p -> bri x -> p @ x 23 | 24 | normalize def switch -------------------------------------------------------------------------------- /test/n-ary.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Basic tests of n-ary bridge/extent/gel for various n 3 | -------------------------------------------------------------------------------- 4 | 5 | let ap1 : (A : U<0>) (B : U<0>) (f : A -> B) (a : A) -> [_] A {a} -> [_] B {f a} = 6 | fun A B f a p -> bri x -> f (p @ x) 7 | 8 | normalize def ap1 9 | 10 | let ap2 : (A : U<0>) (B : U<0>) (f : A -> B) (a0 : A) (a1 : A) -> [_] A {a0; a1} -> [_] B {f a0; f a1} = 11 | fun A B f a0 a1 p -> bri x -> f (p @ x) 12 | 13 | normalize def ap2 14 | 15 | let ap3 : (A : U<0>) (B : U<0>) (f : A -> B) (a0 : A) (a1 : A) (a2 : A) 16 | -> [_] A {a0; a1; a2} -> [_] B {f a0; f a1; f a2} 17 | = 18 | fun A B f a0 a1 a2 p -> bri x -> f (p @ x) 19 | 20 | normalize def ap3 21 | 22 | let two : (A : U<0>) (B : U<0>) (f : A -> B) (a0 : A) (a1 : A) (a2 : A) 23 | -> [_] A {a0; a1; a2} -> B 24 | = 25 | fun A B f a0 a1 a2 p -> ap3 A B f a0 a1 a2 p @ 2 26 | 27 | normalize def two 28 | 29 | let bunext1 : (A : U<0>) (B : U<0>) (f : A -> B) 30 | -> ((a : A) -> [x] A {a} -> [x] B {f a}) -> [x] A -> B {f} 31 | = 32 | fun A B f g -> bri x -> fun a -> 33 | extent x of a in _ -> A at _ _ -> B with 34 | | a0 -> f a0 35 | | a0 q y -> g a0 q @ y 36 | 37 | normalize def bunext1 38 | 39 | let bunext2 : (A : U<0>) (B : U<0>) (f0 : A -> B) (f1 : A -> B) 40 | -> ((a0 : A) (a1 : A) -> [x] A {a0; a1} -> [x] B {f0 a0; f1 a1}) -> [x] A -> B {f0; f1} 41 | = 42 | fun A B f0 f1 g -> bri x -> fun a -> 43 | extent x of a in _ -> A at _ _ -> B with 44 | | a0 -> f0 a0 45 | | a1 -> f1 a1 46 | | a0 a1 q y -> g a0 a1 q @ y 47 | 48 | normalize def bunext2 49 | 50 | let bunext2_at1 : (A : U<0>) (B : U<0>) (f0 : A -> B) (f1 : A -> B) 51 | -> ((a0 : A) (a1 : A) -> [x] A {a0; a1} -> [x] B {f0 a0; f1 a1}) -> (A -> B) 52 | = 53 | fun A B f0 f1 g -> bunext2 A B f0 f1 g @ 1 54 | 55 | normalize def bunext2_at1 56 | 57 | let gel_test1 : (A : U<0>) (B : U<0>) (R : A -> B -> U<0>) 58 | (a : A) (b : B) (r : R a b) -> [x] Gel x {A; B} (a b -> R a b) {a; b} 59 | = 60 | fun A B R a b r -> bri x -> gel x {a; b} r 61 | 62 | normalize def gel_test1 63 | -------------------------------------------------------------------------------- /test/nat_nullary_const.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Proof that [_] nat {} = nat (assuming univalence for Id or cubical equality) 3 | -------------------------------------------------------------------------------- 4 | 5 | -- Consequence of univalence 6 | 7 | postulate bridgeext : (A : [_] U<1> {}) 8 | (p0 : [x] A @ x {}) (p1 : [x] A @ x {}) 9 | -> [x] Id (A @ x) (p0 @ x) (p1 @ x) {} 10 | -> Id ([x] A @ x {}) p0 p1 11 | 12 | -- Identity type lemmas 13 | 14 | let cong : (A : U<0>) (B : U<0>) (f : A -> B) (a0 : A) (a1 : A) 15 | -> (Id A a0 a1) -> Id B (f a0) (f a1) 16 | = 17 | fun A B f a0 a1 eq -> 18 | match eq at x0 x1 _ -> Id B (f x0) (f x1) with 19 | | refl z -> refl (f z) 20 | 21 | -- Gel type lemmas 22 | 23 | let gelproj : (A : U<0>) (p : [x] Gel x A {}) -> A = 24 | fun A p -> 25 | ungel x : 0 -> p @ x at _ -> A with | gel a -> a 26 | 27 | -- Main proof 28 | 29 | let loosen : nat -> [_] nat {} = 30 | fun n -> bri _ -> n 31 | 32 | let nat_id : nat -> nat = 33 | fun n -> 34 | rec n at _ -> nat with 35 | | zero -> zero 36 | | suc _, n -> suc n 37 | 38 | let tighten_aux : [x] nat -> Gel x nat {} = 39 | bri x -> fun n -> 40 | rec n at _ -> Gel x nat with 41 | | zero -> gel x zero 42 | | suc _, g -> 43 | extent x of g in x -> Gel x nat at x _ -> Gel x nat with 44 | | p x -> gel x (suc (gelproj nat p)) 45 | 46 | let tighten : (p : [_] nat {}) -> nat = 47 | fun p -> gelproj nat (bri x -> tighten_aux @ x (p @ x)) 48 | 49 | let tighten_loosen : (n : nat) 50 | -> Id nat (tighten (loosen n)) n 51 | = 52 | fun n -> 53 | rec n at n -> Id nat (tighten (loosen n)) n with 54 | | zero -> refl zero 55 | | suc m, pf -> cong nat nat (fun k -> suc k) (tighten (loosen m)) m pf 56 | 57 | let lt : [_] nat -> nat {} = 58 | bri x -> fun n -> 59 | extent x of n in _ -> nat at _ _ -> nat with 60 | | p x -> loosen (tighten p) @ x 61 | 62 | let loosen_tighten_aux : [x] (n : nat) -> Id nat (lt @ x n) n {} 63 | = 64 | bri x -> fun n -> 65 | rec n at n -> Id nat (lt @ x n) n with 66 | | zero -> refl zero 67 | | suc m, pf -> 68 | extent x of 69 | in x -> (m : nat) * Id nat (lt @ x m) m at 70 | x mpf -> Id nat (lt @ x (suc (fst mpf))) (suc (fst mpf)) with 71 | | mpf x -> 72 | cong nat nat (fun k -> suc k) (lt @ x (fst (mpf @ x))) (fst (mpf @ x)) (snd (mpf @ x)) 73 | 74 | let loosen_tighten : (p : [_] nat {}) 75 | -> Id ([_] nat {}) (loosen (tighten p)) p 76 | = 77 | fun p -> 78 | bridgeext (bri _ -> nat) (loosen (tighten p)) p 79 | (bri x -> loosen_tighten_aux @ x (p @ x)) 80 | -------------------------------------------------------------------------------- /test/no-lem.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Refutation of the law of the excluded middle for homotopy propositions. 3 | -- The main lemma in this proof is the fact that the universe of propositions 4 | -- is closed under Gel-types, that is, that a Gel-type made from propositional 5 | -- endpoints and a proposition-valued relation is itself a proposition. 6 | -------------------------------------------------------------------------------- 7 | -------------------------------------------------------------------------------- 8 | -- General definitions and lemmas 9 | -------------------------------------------------------------------------------- 10 | 11 | let is_prop : U<0> -> U<0> = 12 | fun A -> (a : A) (b : A) -> Id A a b 13 | 14 | let Uprop : U<1> = (A : U<0>) * is_prop A 15 | 16 | let or : U<0> -> U<0> -> U<0> = 17 | fun A B -> 18 | (b : bool) * if b at _ -> U<0> with | tt -> A | ff -> B 19 | 20 | let symm : (A : U<0>) (a : A) (b : A) -> (Id A a b) -> Id A b a = 21 | fun A a b eq -> 22 | match eq at x y _ -> Id A y x with 23 | | refl z -> refl z 24 | 25 | let trans : (A : U<0>) (a : A) (b : A) (c : A) -> (Id A a b) -> (Id A b c) -> Id A a c = 26 | fun A a b c eq0 -> 27 | match eq0 at x y _ -> (Id A y c) -> Id A x c with 28 | | refl z -> fun eq1 -> eq1 29 | 30 | let cong : (A : U<0>) (B : U<0>) (f : A -> B) (a0 : A) (a1 : A) 31 | -> (Id A a0 a1) -> Id B (f a0) (f a1) 32 | = 33 | fun A B f a0 a1 eq -> 34 | match eq at x0 x1 _ -> Id B (f x0) (f x1) with 35 | | refl z -> refl (f z) 36 | 37 | let subst : (A : U<0>) (B : A -> U<0>) (a0 : A) (a1 : A) 38 | -> (Id A a0 a1) -> (B a0) -> B a1 39 | = 40 | fun A B a0 a1 eq -> 41 | match eq at x y _ -> (B x) -> B y with 42 | | refl _ -> fun b -> b 43 | 44 | let subst2 : (A : U<0>) (B : U<0>) (C : A -> B -> U<0>) 45 | (a0 : A) (a1 : A) (b0 : B) (b1 : B) 46 | -> (Id A a0 a1) -> (Id B b0 b1) -> (C a0 b0) -> C a1 b1 47 | = 48 | fun A B C a0 a1 b0 b1 eqa -> 49 | match eqa at x y _ -> (Id B b0 b1) -> (C x b0) -> C y b1 with 50 | | refl a -> subst B (C a) b0 b1 51 | 52 | let cong_bapp : (A0 : U<0>) (A1 : U<0>) (A : [_] U<0> {A0; A1}) (a0 : A0) (a1 : A1) 53 | (b0 : [x] A @ x {a0; a1}) (b1 : [x] A @ x {a0; a1}) 54 | -> (Id ([x] A @ x {a0; a1}) b0 b1) 55 | -> [x] Id (A @ x) (b0 @ x) (b1 @ x) {refl a0; refl a1} 56 | = 57 | fun A0 A1 A a0 a1 b0 b1 eq -> 58 | match eq at c0 c1 _ -> [x] Id (A @ x) (c0 @ x) (c1 @ x) {refl a0; refl a1} with 59 | | refl c -> bri x -> refl (c @ x) 60 | 61 | let gelproj : (A : U<0>) (B : U<0>) (R : A -> B -> U<0>) 62 | (a : A) (b : B) -> [x] Gel x {A; B} (a b -> R a b) {a; b} -> R a b 63 | = 64 | fun A B R a b p -> 65 | ungel x : 2 -> p @ x at _ -> R a b with | gel r -> r 66 | 67 | let gel_eta : (A : U<0>) (B : U<0>) (R : A -> B -> U<0>) (a : A) (b : B) 68 | -> (p : [x] Gel x {A; B} (a b -> R a b) {a; b}) 69 | -> Id ([x] Gel x {A; B} (a b -> R a b) {a; b}) 70 | p 71 | (bri x -> gel x {a; b} (gelproj A B R a b p)) 72 | = 73 | fun A B R a b p -> 74 | ungel x : 2 -> p @ x at 75 | q -> Id ([x] Gel x {A; B} (a b -> R a b) {a; b}) q (bri x -> gel x {a; b} (gelproj A B R a b q)) 76 | with 77 | | gel r -> refl (bri x -> gel x {a;b} r) 78 | 79 | -------------------------------------------------------------------------------- 80 | -- Uprop is closed under Gel-types 81 | -------------------------------------------------------------------------------- 82 | 83 | let cong_gel : (A : U<0>) (B : U<0>) (R : A -> B -> U<0>) 84 | (a : A) (a' : A) (eqa : Id A a a') 85 | (b : B) (b' : B) (eqb : Id B b b') 86 | (r : R a b) (r' : R a' b') 87 | -> (Id (R a' b') (subst2 A B R a a' b b' eqa eqb r) r') 88 | -> [x] (Id (Gel x {A;B} (a b -> R a b)) (gel x {a;b} r) (gel x {a';b'} r')) {eqa; eqb} 89 | = 90 | fun A B R a a' eqa -> 91 | match eqa at 92 | a a' eqa -> 93 | (b : B) (b' : B) (eqb : Id B b b') 94 | (r : R a b) (r' : R a' b') 95 | -> (Id (R a' b') (subst2 A B R a a' b b' eqa eqb r) r') 96 | -> [x] (Id (Gel x {A;B} (a b -> R a b)) (gel x {a;b} r) (gel x {a';b'} r')) {eqa; eqb} 97 | with 98 | | refl a -> fun b b' eqb -> 99 | match eqb at 100 | b b' eqb -> 101 | (r : R a b) (r' : R a b') 102 | -> (Id (R a b') (subst B (R a) b b' eqb r) r') 103 | -> [x] (Id (Gel x {A;B} (a b -> R a b)) (gel x {a;b} r) (gel x {a;b'} r')) {refl a; eqb} 104 | with 105 | | refl b -> fun r r' eqr -> 106 | match eqr at 107 | r r' _ -> 108 | [x] (Id (Gel x {A;B} (a b -> R a b)) (gel x {a;b} r) (gel x {a;b} r')) {refl a; refl b} 109 | with 110 | | refl r -> bri x -> refl (gel x {a; b} r) 111 | 112 | let Gel_is_prop : (A0 : Uprop) (A1 : Uprop) (R : (fst A0) -> (fst A1) -> Uprop) 113 | -> [x] is_prop (Gel x {fst A0; fst A1} (a0 a1 -> fst (R a0 a1))) {snd A0; snd A1} 114 | = 115 | fun A0p A1p Rp -> 116 | let A0 : U<0> = fst A0p in 117 | let A1 : U<0> = fst A1p in 118 | let R : A0 -> A1 -> U<0> = fun a0 a1 -> fst (Rp a0 a1) in 119 | let G : [x] U<0> {A0; A1} = bri x -> Gel x {A0; A1} (a0 a1 -> R a0 a1) in 120 | bri x -> 121 | fun g -> 122 | extent x of g in y -> G @ y at y g -> (g' : G @ y) -> Id (G @ y) g g' with 123 | | a0 -> fun a0' -> snd A0p a0 a0' 124 | | a1 -> fun a1' -> snd A1p a1 a1' 125 | | a0 a1 q y -> fun g' -> 126 | extent y of g' in z -> G @ z at z g' -> Id (G @ z) (q @ z) g' with 127 | | a0' -> snd A0p a0 a0' 128 | | a1' -> snd A1p a1 a1' 129 | | a0' a1' q' z -> 130 | trans (G @ z) (q @ z) (gel z {a0; a1} (gelproj A0 A1 R a0 a1 q)) (q' @ z) 131 | (cong_bapp A0 A1 G a0 a1 q (bri z -> gel z {a0; a1} (gelproj A0 A1 R a0 a1 q)) 132 | (gel_eta A0 A1 R a0 a1 q) 133 | @ z) 134 | (trans (G @ z) 135 | (gel z {a0; a1} (gelproj A0 A1 R a0 a1 q)) 136 | (gel z {a0'; a1'} (gelproj A0 A1 R a0' a1' q')) 137 | (q' @ z) 138 | (cong_gel A0 A1 R 139 | a0 a0' (snd A0p a0 a0') 140 | a1 a1' (snd A1p a1 a1') 141 | (gelproj A0 A1 R a0 a1 q) (gelproj A0 A1 R a0' a1' q') 142 | (snd (Rp a0' a1') 143 | (subst2 A0 A1 R a0 a0' a1 a1' (snd A0p a0 a0') (snd A1p a1 a1') 144 | (gelproj A0 A1 R a0 a1 q)) 145 | (gelproj A0 A1 R a0' a1' q')) 146 | @ z) 147 | (symm (G @ z) (q' @ z) (gel z {a0'; a1'} (gelproj A0 A1 R a0' a1' q')) 148 | (cong_bapp A0 A1 G a0' a1' q' (bri z -> gel z {a0'; a1'} (gelproj A0 A1 R a0' a1' q')) 149 | (gel_eta A0 A1 R a0' a1' q') 150 | @ z))) 151 | 152 | let Gel_prop : (A0 : Uprop) (A1 : Uprop) (R : (fst A0) -> (fst A1) -> Uprop) 153 | -> [x] Uprop {A0; A1} 154 | = 155 | fun A0 A1 R -> bri x -> 156 | fst (R a0 a1)), Gel_is_prop A0 A1 R @ x> 157 | 158 | -------------------------------------------------------------------------------- 159 | -- unit is a proposition 160 | -------------------------------------------------------------------------------- 161 | 162 | let unit_is_prop : is_prop unit = 163 | fun _ _ -> refl triv 164 | 165 | let unit_prop : Uprop = 166 | 167 | -------------------------------------------------------------------------------- 168 | -- empty is a proposition 169 | -------------------------------------------------------------------------------- 170 | 171 | let empty : U<0> = Id bool tt ff 172 | 173 | let empty_is_prop : is_prop empty = 174 | fun no0 no1 -> 175 | cong bool empty 176 | (fun b -> if b at _ -> empty with | tt -> no0 | ff -> no1) 177 | tt ff no0 178 | 179 | let empty_prop : Uprop = 180 | 181 | -------------------------------------------------------------------------------- 182 | -- Bridge-discreteness of bool (one direction) 183 | -------------------------------------------------------------------------------- 184 | 185 | let shannon : bool -> bool = 186 | fun b -> 187 | if b at _ -> bool with | tt -> tt | ff -> ff 188 | 189 | let bool_eta : (b : bool) -> Id bool (shannon b) b = 190 | fun b -> 191 | if b at b -> Id bool (shannon b) b with 192 | | tt -> refl tt 193 | | ff -> refl ff 194 | 195 | let bridge_to_id : (b0 : bool) (b1 : bool) -> [_] bool {b0; b1} -> Id bool b0 b1 = 196 | fun b0 b1 p -> 197 | let lemma : Id bool (shannon b0) (shannon b1) = 198 | gelproj bool bool (fun c d -> Id bool c d) (shannon b0) (shannon b1) 199 | (bri x -> 200 | if (p @ x) at _ -> Gel x {bool; bool} (c d -> Id bool c d) with 201 | | tt -> gel x {tt; tt} (refl tt) 202 | | ff -> gel x {ff; ff} (refl ff)) 203 | in 204 | trans bool b0 (shannon b1) b1 205 | (trans bool b0 (shannon b0) (shannon b1) 206 | (symm bool (shannon b0) b0 (bool_eta b0)) 207 | lemma) 208 | (bool_eta b1) 209 | 210 | -------------------------------------------------------------------------------- 211 | -- Refutation of LEM 212 | -------------------------------------------------------------------------------- 213 | 214 | let not : U<0> -> U<0> = fun A -> A -> empty 215 | 216 | let LEM : U<1> = (A : Uprop) -> or (fst A) (not (fst A)) 217 | 218 | let LEM_is_not_const : (lem : LEM) 219 | -> (Id bool (fst (lem unit_prop)) (fst (lem empty_prop))) -> empty 220 | = 221 | fun lem p -> 222 | let P : Uprop -> bool -> U<0> = 223 | fun T b -> if b at _ -> U<0> with | tt -> fst T | ff -> not (fst T) 224 | in 225 | (if (fst (lem unit_prop)) at 226 | b -> (P unit_prop b) -> (Id bool b (fst (lem empty_prop))) -> empty 227 | with 228 | | tt -> 229 | fun a q1 -> 230 | (if (fst (lem empty_prop)) at c -> (P empty_prop c) -> (Id bool tt c) -> empty with 231 | | tt -> fun e _ -> e 232 | | ff -> fun _ q2 -> q2) 233 | (snd (lem empty_prop)) 234 | q1 235 | | ff -> fun no _ -> no triv) 236 | (snd (lem unit_prop)) 237 | p 238 | 239 | let LEM_is_false : LEM -> empty = 240 | fun lem -> 241 | LEM_is_not_const lem 242 | (bridge_to_id (fst (lem unit_prop)) (fst (lem empty_prop)) 243 | (bri x -> fst (lem (Gel_prop unit_prop empty_prop (fun _ _ -> empty_prop) @ x)))) 244 | -------------------------------------------------------------------------------- /test/no-wlem.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Refutation of the weak law of the excluded middle, which decides negated 3 | -- types. In cubical type theory this would suffice to refute the excluded 4 | -- middle for homotopy propositions, but that implication requires function 5 | -- extensionality (to show that negated types are always propositions). 6 | -- See no-lem.ptt for a separate refutation of that principle. 7 | -------------------------------------------------------------------------------- 8 | 9 | -------------------------------------------------------------------------------- 10 | -- General definitions and lemmas 11 | -------------------------------------------------------------------------------- 12 | 13 | let symm : (A : U<0>) (a : A) (b : A) -> (Id A a b) -> Id A b a = 14 | fun A a b eq -> 15 | match eq at x y _ -> Id A y x with 16 | | refl z -> refl z 17 | 18 | let trans : (A : U<0>) (a : A) (b : A) (c : A) -> (Id A a b) -> (Id A b c) -> Id A a c = 19 | fun A a b c eq0 -> 20 | match eq0 at x y _ -> (Id A y c) -> Id A x c with 21 | | refl z -> fun eq1 -> eq1 22 | 23 | let gelproj : (A : U<0>) (B : U<0>) (R : A -> B -> U<0>) 24 | (a : A) (b : B) -> [x] Gel x {A; B} (a b -> R a b) {a; b} -> R a b 25 | = 26 | fun A B R a b p -> 27 | ungel x : 2 -> p @ x at _ -> R a b with | gel r -> r 28 | 29 | let empty : U<0> = Id bool tt ff 30 | 31 | let not : U<0> -> U<0> = fun A -> A -> empty 32 | 33 | let or : U<0> -> U<0> -> U<0> = 34 | fun A B -> 35 | (b : bool) * if b at _ -> U<0> with | tt -> A | ff -> B 36 | 37 | -------------------------------------------------------------------------------- 38 | -- Bridge-discreteness of bool (one direction) 39 | -------------------------------------------------------------------------------- 40 | 41 | let shannon : bool -> bool = 42 | fun b -> 43 | if b at _ -> bool with | tt -> tt | ff -> ff 44 | 45 | let bool_eta : (b : bool) -> Id bool (shannon b) b = 46 | fun b -> 47 | if b at b -> Id bool (shannon b) b with 48 | | tt -> refl tt 49 | | ff -> refl ff 50 | 51 | let bridge_to_id : (b0 : bool) (b1 : bool) -> [_] bool {b0; b1} -> Id bool b0 b1 = 52 | fun b0 b1 p -> 53 | let lemma : Id bool (shannon b0) (shannon b1) = 54 | gelproj bool bool (fun c d -> Id bool c d) (shannon b0) (shannon b1) 55 | (bri x -> 56 | if (p @ x) at _ -> Gel x {bool; bool} (c d -> Id bool c d) with 57 | | tt -> gel x {tt; tt} (refl tt) 58 | | ff -> gel x {ff; ff} (refl ff)) 59 | in 60 | trans bool b0 (shannon b1) b1 61 | (trans bool b0 (shannon b0) (shannon b1) 62 | (symm bool (shannon b0) b0 (bool_eta b0)) 63 | lemma) 64 | (bool_eta b1) 65 | 66 | -------------------------------------------------------------------------------- 67 | -- Refutation of WLEM 68 | -------------------------------------------------------------------------------- 69 | 70 | let WLEM : U<1> = (A : U<0>) -> or (not A) (not (not A)) 71 | 72 | let WLEM_is_not_const : (wlem : WLEM) (A : U<0>) 73 | -> (Id bool (fst (wlem A)) (fst (wlem (not A)))) -> empty 74 | = 75 | fun wlem A p -> 76 | let P : U<0> -> bool -> U<0> = 77 | fun T b -> if b at _ -> U<0> with | tt -> not T | ff -> not (not T) 78 | in 79 | (if (fst (wlem A)) at b -> (P A b) -> (Id bool b (fst (wlem (not A)))) -> empty with 80 | | tt -> 81 | fun na q1 -> 82 | (if (fst (wlem (not A))) at c -> (P (not A) c) -> (Id bool tt c) -> empty with 83 | | tt -> fun nna _ -> nna na 84 | | ff -> fun _ q2 -> q2) 85 | (snd (wlem (not A))) 86 | q1 87 | | ff -> 88 | fun nna q1 -> 89 | (if (fst (wlem (not A))) at c -> (P (not A) c) -> (Id bool ff c) -> empty with 90 | | tt -> fun _ q2 -> symm bool ff tt q2 91 | | ff -> fun nnna _ -> nnna nna) 92 | (snd (wlem (not A))) 93 | q1) 94 | (snd (wlem A)) 95 | p 96 | 97 | let WLEM_is_false : WLEM -> empty = 98 | fun wlem -> 99 | let T : U<0> = bool in -- choice of type is arbitrary 100 | WLEM_is_not_const wlem T 101 | (bridge_to_id (fst (wlem T)) (fst (wlem (not T))) 102 | (bri x -> fst (wlem (Gel x {T; not T} (_ _ -> empty))))) 103 | -------------------------------------------------------------------------------- /test/relativity.ptt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- Parts of the proof of (nullary) relativity that can be defined without 3 | -- univalence. With no endpoints, the expected principle says [_] U<0> is 4 | -- equivalent to U<0>. 5 | -------------------------------------------------------------------------------- 6 | 7 | let cong : (A : U<0>) (B : U<0>) (f : A -> B) (a0 : A) (a1 : A) 8 | -> (Id A a0 a1) -> Id B (f a0) (f a1) 9 | = 10 | fun A B f a0 a1 eq -> 11 | match eq at x0 x1 _ -> Id B (f x0) (f x1) with 12 | | refl z -> refl (f z) 13 | 14 | normalize def cong 15 | 16 | -------------------------------------------------------------------------------- 17 | -- Functions back and forth 18 | -------------------------------------------------------------------------------- 19 | 20 | let ra : U<0> -> [_] U<0> {} = 21 | fun A -> bri x -> Gel x A 22 | 23 | normalize def ra 24 | 25 | let Bridge : [_] U<0> {} -> U<0> = 26 | fun P -> [x] P @ x {} 27 | 28 | normalize def Bridge 29 | 30 | let bapp_cong : (P : [_] U<0> {}) (p0 : Bridge P) (p1 : Bridge P) 31 | -> (Id (Bridge P) p0 p1) -> [x] Id (P @ x) (p0 @ x) (p1 @ x) {} 32 | = 33 | fun P p0 p1 eq -> 34 | match eq at q0 q1 _ -> [x] Id (P @ x) (q0 @ x) (q1 @ x) {} with 35 | | refl q -> bri x -> refl (q @ x) 36 | 37 | normalize def bapp_cong 38 | 39 | -------------------------------------------------------------------------------- 40 | -- Functions and inverses for the beta-equivalence 41 | -------------------------------------------------------------------------------- 42 | 43 | let ra_beta_fwd : (A : U<0>) -> (Bridge (ra A)) -> A = 44 | fun A p -> 45 | ungel x : 0 -> p @ x at _ -> A with | gel a -> a 46 | 47 | normalize def ra_beta_fwd 48 | 49 | let ra_beta_bwd : (A : U<0>) -> A -> Bridge (ra A) = 50 | fun A a -> bri x -> gel x a 51 | 52 | normalize def ra_beta_bwd 53 | 54 | let ra_beta_fwd_bwd : (A : U<0>) -> (a : A) -> Id A (ra_beta_fwd A (ra_beta_bwd A a)) a = 55 | fun A a -> refl a 56 | 57 | normalize def ra_beta_fwd_bwd 58 | 59 | let ra_beta_bwd_fwd : (A : U<0>) -> (p : Bridge (ra A)) 60 | -> Id (Bridge (ra A)) (ra_beta_bwd A (ra_beta_fwd A p)) p 61 | = 62 | fun A p -> 63 | ungel x : 0 -> p @ x at q -> Id ([x] Gel x A {}) (ra_beta_bwd A (ra_beta_fwd A q)) q with 64 | | gel a -> refl (bri x -> gel x a) 65 | 66 | normalize def ra_beta_bwd_fwd 67 | 68 | -------------------------------------------------------------------------------- 69 | -- Functions and inverses for the eta-equivalence 70 | -------------------------------------------------------------------------------- 71 | 72 | let ra_eta_fwd : (P : [_] U<0> {}) -> [x] (ra (Bridge P) @ x) -> P @ x {} = 73 | fun P -> bri x -> fun g -> 74 | extent x of g in y -> ra (Bridge P) @ y at y _ -> P @ y with 75 | | q y -> (ungel z : 0 -> q @ z at _ -> Bridge P with | gel t -> t) @ y 76 | 77 | normalize def ra_eta_fwd 78 | 79 | let ra_eta_bwd : (P : [_] U<0> {}) -> [x] (P @ x) -> ra (Bridge P) @ x {} = 80 | fun P -> bri x -> fun a -> 81 | extent x of a in y -> P @ y at y _ -> ra (Bridge P) @ y with 82 | | p y -> gel y p 83 | 84 | normalize def ra_eta_bwd 85 | 86 | let ra_eta_fwd_bwd : (P : [_] U<0> {}) 87 | -> [x] (a : P @ x) -> Id (P @ x) (ra_eta_fwd P @ x (ra_eta_bwd P @ x a)) a {} 88 | = 89 | fun P -> bri x -> fun a -> 90 | extent x of a in 91 | y -> P @ y at 92 | y b -> Id (P @ y) (ra_eta_fwd P @ y (ra_eta_bwd P @ y b)) b with 93 | | p y -> refl (p @ y) 94 | 95 | normalize def ra_eta_fwd_bwd 96 | 97 | normalize (bri x -> ra_eta_fwd_bwd (bri _ -> nat) @ x zero) at [x] Id nat zero zero {} 98 | 99 | let ra_eta_bwd_fwd : (P : [_] U<0> {}) -> 100 | [x] (g : ra (Bridge P) @ x) -> Id (ra (Bridge P) @ x) (ra_eta_bwd P @ x (ra_eta_fwd P @ x g)) g {} 101 | = 102 | fun P -> bri x -> fun g -> 103 | extent x of g in 104 | y -> (ra (Bridge P)) @ y at 105 | y h -> Id (ra (Bridge P) @ y) (ra_eta_bwd P @ y (ra_eta_fwd P @ y h)) h with 106 | | q y -> 107 | bapp_cong 108 | (bri z -> ra (Bridge P) @ z) 109 | (bri z -> ra_eta_bwd P @ z (ra_eta_fwd P @ z (q @ z))) 110 | q 111 | (ra_beta_bwd_fwd (Bridge P) q) 112 | @ y 113 | 114 | normalize def ra_eta_bwd_fwd 115 | --------------------------------------------------------------------------------