├── .editorconfig ├── .gitignore ├── .gitmodules ├── .travis.yml ├── .vscode ├── extensions.json ├── settings.json └── tasks.json ├── CONTRIBUTING.md ├── LICENSE ├── Makefile ├── NOTICE ├── README.md ├── dune-project ├── emacs └── redtt.el ├── library ├── Makefile ├── README.md ├── basics │ ├── biinv-equiv.red │ ├── ha-equiv.red │ ├── hedberg.red │ ├── isotoequiv.red │ └── retract.red ├── cool │ ├── biinv-int.red │ ├── complete-induction.red │ ├── free-monoid.red │ ├── gcd.red │ ├── hopf.red │ ├── invariance.red │ ├── isos.red │ ├── logic.red │ ├── moebius-boundary.red │ ├── nat-prime.red │ ├── nats.red │ ├── parametric-smash.red │ ├── patch-theory.red │ ├── problem.red │ ├── pullback.red │ ├── quotient.red │ ├── redml-examples.red │ ├── s3-to-join.red │ ├── sphere1-to-s1.red │ ├── torus.red │ └── ua-beta.red ├── data │ ├── bool.red │ ├── int.red │ ├── join.red │ ├── list.red │ ├── nat.red │ ├── or.red │ ├── quotient.red │ ├── s1.red │ ├── s2.red │ ├── s3.red │ ├── smash.red │ ├── susp.red │ ├── torus.red │ ├── truncation.red │ ├── unit.red │ └── void.red ├── paths │ ├── biinv-equiv.red │ ├── bool.red │ ├── equivalence.red │ ├── ha-equiv.red │ ├── hlevel.red │ ├── int.red │ ├── list.red │ ├── nat.red │ ├── pi.red │ ├── s1.red │ ├── s2.red │ ├── sigma.red │ └── truncation.red ├── pointed │ ├── bool.red │ ├── loops.red │ ├── smash.red │ └── unit.red ├── prelude.red ├── prelude │ ├── connection.red │ ├── equivalence.red │ ├── hlevel.red │ ├── path.red │ ├── pointed.red │ └── univalence.red └── redlib ├── redtt.opam ├── src ├── basis │ ├── Bwd.ml │ ├── Bwd.mli │ ├── Combinators.ml │ ├── Combinators.mli │ ├── DisjointSet.ml │ ├── DisjointSet.mli │ ├── IxMonad.ml │ ├── IxMonad.mli │ ├── IxStateMonad.ml │ ├── IxStateMonad.mli │ ├── ListUtil.ml │ ├── MapAsPersistentTable.ml │ ├── Monad.ml │ ├── Monad.mli │ ├── Option.ml │ ├── Option.mli │ ├── PersistentTable.ml │ ├── PersistentTable.mli │ ├── ReaderMonad.ml │ ├── ReaderMonad.mli │ ├── StateMonad.ml │ ├── StateMonad.mli │ ├── SysUtil.ml │ ├── SysUtil.mli │ ├── Tree.ml │ ├── Tree.mli │ └── dune ├── bin │ ├── dune │ └── main.ml ├── core │ ├── Cx.ml │ ├── Cx.mli │ ├── Desc.ml │ ├── Desc.mli │ ├── Diagnostics.ml │ ├── Diagnostics.mli │ ├── Dir.ml │ ├── Dir.mli │ ├── Domain.ml │ ├── Domain.mli │ ├── DomainData.ml │ ├── Eq.ml │ ├── Eq.mli │ ├── Face.ml │ ├── Face.mli │ ├── GlobalEnv.ml │ ├── GlobalEnv.mli │ ├── I.ml │ ├── I.mli │ ├── IAbs.ml │ ├── IAbs.mli │ ├── Kind.ml │ ├── Kind.mli │ ├── LocallyNameless.ml │ ├── Lvl.ml │ ├── Lvl.mli │ ├── Name.ml │ ├── Name.mli │ ├── Occurs.ml │ ├── Pp.ml │ ├── Pp.mli │ ├── PpExn.ml │ ├── PpExn.mli │ ├── Quote.ml │ ├── Quote.mli │ ├── Restriction.ml │ ├── Restriction.mli │ ├── Sort.ml │ ├── Sort.mli │ ├── Tm.ml │ ├── Tm.mli │ ├── TmData.ml │ ├── TmUtil.ml │ ├── Typing.ml │ ├── Typing.mli │ ├── Val.ml │ ├── Val.mli │ ├── ValSig.ml │ └── dune └── frontend │ ├── Contextual.ml │ ├── Contextual.mli │ ├── Dev.ml │ ├── Dev.mli │ ├── Elaborator.ml │ ├── Elaborator.mli │ ├── FileRes.ml │ ├── FileRes.mli │ ├── Frontend.ml │ ├── Frontend.mli │ ├── Grammar.mly │ ├── Importer.ml │ ├── Importer.mli │ ├── Lex.mll │ ├── Log.ml │ ├── Log.mli │ ├── ML.ml │ ├── ParseError.ml │ ├── Refiner.ml │ ├── Refiner.mli │ ├── ResEnv.ml │ ├── ResEnv.mli │ ├── RotData.ml │ ├── RotIO.ml │ ├── RotIO.mli │ ├── Unify.ml │ ├── Unify.mli │ └── dune └── vim ├── README.md ├── ftdetect └── redtt.vim ├── ftplugin └── redtt.vim ├── install.sh └── syntax └── redtt.vim /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*] 4 | indent_style = space 5 | indent_size = 2 6 | end_of_line = lf 7 | charset = utf-8 8 | trim_trailing_whitespace = true 9 | insert_final_newline = true 10 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "doc/references"] 2 | path = doc/references 3 | url = git@github.com:jonsterling/bibtex-references.git 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | cache: 3 | directories: 4 | - /home/travis/.opam/ 5 | env: 6 | - OCAML_VERSION=4.09 OPAM_VERSION=2.0.5 7 | before_install: 8 | # Install OPAM and OCaml 9 | - sh <(curl -sL https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-ocaml.sh) 10 | - opam --version 11 | - eval $(opam config env) 12 | - ocaml --version 13 | install: 14 | - opam pin add -y redtt . 15 | script: 16 | - make build 17 | - make library 18 | -------------------------------------------------------------------------------- /.vscode/extensions.json: -------------------------------------------------------------------------------- 1 | { 2 | "recommendations": ["EditorConfig.EditorConfig"] 3 | } 4 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "editor.detectIndentation": false, 3 | "editor.insertSpaces": true, 4 | "editor.tabSize": 2, 5 | "editor.trimAutoWhitespace": true, 6 | "files.exclude": { 7 | "_build": true, 8 | "_opam": true, 9 | "**/.merlin": true, 10 | "**/*.install": true 11 | }, 12 | "search.exclude": {} 13 | } 14 | -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | // See https://go.microsoft.com/fwlink/?LinkId=733558 3 | // for the documentation about the tasks.json format 4 | "version": "2.0.0", 5 | "tasks": [ 6 | { 7 | "label": "make", 8 | "type": "shell", 9 | "group": { 10 | "kind": "build", 11 | "isDefault": true 12 | }, 13 | "command": "make" 14 | } 15 | ] 16 | } 17 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Copyright Assignment 2 | 3 | Thank you for your contribution. Here is some important legal stuff. 4 | 5 | By submitting a pull request for this project, unless explicitly stated otherwise, you agree to assign your copyright of the contribution to **The RedPRL Development Team** when it is accepted (merged with or without minor changes). You assert that you have full power to assign the copyright, and that any copyright owned by or shared with a third party has been clearly marked with appropriate copyright notices. If you are employed, please check with your employer about the owernership of your contribution. 6 | 7 | This would allow us to, for example, change the license of the codebase or transfer the ownership of the project to someone else *without your further consent*. We demand this assignment so that we do not have to ask *everyone* who has ever contributed for these activities. This requires trust, and if you feel uncomfortable about this assignment, please make an explicit note. 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | OPAM=opam 2 | EXEC=${OPAM} exec 3 | DUNE=${EXEC} dune -- 4 | 5 | .PHONY: all build clean doc help library install reinstall top 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 | help: 19 | @${DUNE} exec -- redtt help 20 | 21 | library: 22 | $(MAKE) -C library all 23 | 24 | install: 25 | ${OPAM} install redtt 26 | 27 | reinstall: 28 | ${OPAM} reinstall redtt 29 | 30 | top: 31 | @${DUNE} utop src/core 32 | -------------------------------------------------------------------------------- /NOTICE: -------------------------------------------------------------------------------- 1 | redtt 2 | Copyright 2018 The RedPRL Development Team 3 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.1) 2 | (using menhir 2.0) ; required for dune to pass --infer to menhir 3 | -------------------------------------------------------------------------------- /library/Makefile: -------------------------------------------------------------------------------- 1 | OPAM=opam 2 | EXEC=${OPAM} exec 3 | DUNE=${EXEC} dune -- 4 | 5 | RED_FILES=$(wildcard ./**/*.red) 6 | 7 | all: 8 | for f in ${RED_FILES}; do ${DUNE} exec -- redtt load-file $${f} || exit -1 ; done 9 | -------------------------------------------------------------------------------- /library/README.md: -------------------------------------------------------------------------------- 1 | redtt mathematical library 2 | ========================== 3 | 4 | This is the home of the `redtt` mathematical library. 5 | 6 | 7 | Style and conventions 8 | --------------------- 9 | 10 | We have no absolute rules, but try to adhere to the following: 11 | 12 | - Generally use lowercase 13 | - Keep line lengths reasonably short (< 90 characters) 14 | - Write multi-word semantic units with hyphen (`is-contr`, `weak-connection`) 15 | - Write subordinate semantic units with slash (`plus/assoc`, `symm/unit`) 16 | - Reserve `is-` and `has-` for h-propositions (`is-contr`, `has-hlevel`) 17 | 18 | Library structure 19 | ----------------- 20 | 21 | - `prelude/` contains definitions that are expected to be needed in all `redtt` 22 | developments. 23 | 24 | - `data/` contains the bare definitions of datatypes, and whatever functions can 25 | be defined without needing other constructions and lemmas. 26 | 27 | - `basics/` contains basic theorems of cubical type theory, which might not be 28 | needed everywhere. 29 | 30 | - `paths/` contains theorems about the higher dimensional structure of types in 31 | cubical type theory, such as characterizations of loop spaces, etc. 32 | 33 | - `cool/` contains cool constructions and theorems which aren't needed by anything; 34 | many new developments will first start in `cool/`, and become their own folders as 35 | become more complex and mature. 36 | -------------------------------------------------------------------------------- /library/basics/biinv-equiv.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import basics.isotoequiv 3 | import basics.retract 4 | 5 | -- Bi-invertible map definition of equivalence 6 | 7 | def is-biinv-equiv (A B : type) (f : A → B) : type = 8 | section A B f × retraction A B f 9 | 10 | def biinv-equiv (A B : type) : type = (f : A → B) × is-biinv-equiv A B f 11 | 12 | def biinv-equiv→iso (A B : type) : biinv-equiv A B → iso A B = 13 | λ (f,(g,α),h,β) → 14 | let β' (a : A) : path _ (g (f a)) a = 15 | λ i → 16 | comp 0 1 (h (α (f a) i)) [ 17 | | i=0 j → β (g (f a)) j 18 | | i=1 j → β a j 19 | ] 20 | in 21 | (f,g,α,β') 22 | -------------------------------------------------------------------------------- /library/basics/ha-equiv.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import basics.retract 3 | 4 | -- Half-adjoint equivalence 5 | 6 | def lcoh (A B : type) (f : A → B) (g : B → A) (f-g : (b : _) → path _ (f (g b)) b) : type = 7 | (g-f : (a : _) → path _ (g (f a)) a) 8 | × (a : A) → path (path _ (f (g (f a))) (f a)) (λ i → f (g-f a i)) (f-g (f a)) 9 | 10 | def is-ha-equiv (A B : type) (f : A → B) : type = 11 | (g : B → A) 12 | × (f-g : (b : _) → path _ (f (g b)) b) 13 | × lcoh A B f g f-g 14 | 15 | def ha-equiv (A B : type) : type = (f : A → B) × is-ha-equiv A B f 16 | 17 | -- this symmetry function is exactly involutive on all but the highest coherence 18 | def ha-equiv/symm (A B : type) (e : ha-equiv A B) : ha-equiv B A = 19 | let (f, g, f-g, g-f, adj) = e in 20 | let adj' (b : B) : path (path _ (g (f (g b))) (g b)) (λ i → g (f-g b i)) (g-f (g b)) = 21 | λ j i → 22 | let cap0 : A = 23 | comp 1 0 (g (f-g (f-g b i) j)) [ 24 | | i=0 k → g (adj (g b) k j) 25 | | i=1 | ∂[j] → refl 26 | ] 27 | in 28 | let filler (x k : 𝕀) : A = 29 | comp 0 x (g-f (g b) k) [ 30 | | k=0 x → g (f-g b x) 31 | | k=1 → refl 32 | ] 33 | in 34 | let cap1 : A = 35 | comp 0 1 cap0 [ 36 | | i=0 k → g-f (g-f (g b) j) k 37 | | i=1 → filler j 38 | | j=0 k → g-f (g (f-g b i)) k 39 | | j=1 → filler i 40 | ] 41 | in 42 | comp 1 0 cap1 [ 43 | | i=0 k → weak-connection/and A (g-f (g b)) j k 44 | | i=1 → refl 45 | | j=0 → refl 46 | | j=1 k → weak-connection/or A (g-f (g b)) i k 47 | ] 48 | in 49 | (g, f, g-f, f-g, adj') 50 | 51 | def equiv→ha-equiv (A B : type) (e : equiv A B) : ha-equiv A B = 52 | let (f, c) = e in 53 | let g (b : B) = c b .fst .fst in 54 | let f-g (b : B) = c b .fst .snd in 55 | let p (a : A) = symm (fiber A B f (f a)) (c (f a) .snd (a, refl)) in 56 | ( f 57 | , g 58 | , f-g 59 | , λ a i → p a i .fst 60 | , λ a j i → 61 | comp 1 0 (p a i .snd j) [ 62 | | i=0 k → weak-connection/and B (f-g (f a)) j k 63 | | i=1 → refl 64 | | j=0 → refl 65 | | j=1 k → weak-connection/or B (f-g (f a)) i k 66 | ] 67 | ) 68 | -------------------------------------------------------------------------------- /library/basics/hedberg.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import basics.retract 3 | import data.void 4 | import data.or 5 | 6 | def stable (A : type) : type = 7 | neg (neg A) → A 8 | 9 | def dec (A : type) : type = 10 | or A (neg A) 11 | 12 | def discrete (A : type) : type = 13 | (x y : A) → dec (path A x y) 14 | 15 | def dec→stable (A : type) : dec A → stable A = 16 | elim [ 17 | | inl a → λ _ → a 18 | | inr f → λ g → elim (g f) [] 19 | ] 20 | 21 | def neg/is-prop-over (A : 𝕀 → type) 22 | : is-prop-over (λ i → neg (A i)) 23 | = prop→prop-over (λ i → neg (A i)) (neg/prop (A 1)) 24 | 25 | -- Hedberg's theorem for stable path types 26 | def paths-stable→set (A : type) (st : (x y : A) → stable (path A x y)) : is-set A = 27 | λ a b p q i j → 28 | let square (k m : 𝕀) : A = 29 | comp 0 k a [ 30 | | m=0 → p 31 | | m=1 → q 32 | ] 33 | in 34 | let mycap (k m : 𝕀) = st (p k) (q k) (λ c → c (square k)) m in 35 | comp 0 1 (mycap j i) [ 36 | | i=0 k → 37 | st (p j) (p j) 38 | (neg/is-prop-over (λ j → neg (path A (p j) (p j))) 39 | (λ c → c (square 0)) 40 | (λ c → c (square 1)) 41 | j) 42 | k 43 | | i=1 → refl 44 | | ∂[j] k → weak-connection/or A (mycap j) i k 45 | ] 46 | 47 | -- Hedberg's theorem for decidable path types 48 | def discrete→set (A : type) (d : discrete A) : is-set A = 49 | paths-stable→set A (λ x y → dec→stable (path A x y) (d x y)) 50 | 51 | def hrel/set-equiv 52 | (A : type) (R : A → A → type) 53 | (R/prop : (x y : A) → is-prop (R x y)) 54 | (R/refl : (x : A) → R x x) 55 | (R/id : (x y : A) → R x y → path A x y) 56 | : (is-set A) × ((x y : A) → equiv (R x y) (path A x y)) 57 | = 58 | let eq = path-retract/equiv A R (λ a b → 59 | ( R/id a b 60 | , λ p → coe 0 1 (R/refl a) in λ j → R a (p j) 61 | , λ rab → R/prop a b (coe 0 1 (R/refl a) in λ j → R a (R/id a b rab j)) rab 62 | )) in 63 | ( λ x y → coe 0 1 (R/prop x y) in λ j → is-prop (ua _ _ (eq x y) j) 64 | , eq 65 | ) 66 | 67 | -- Hedberg's theorem is a corollary of above 68 | def paths-stable→set/alt (A : type) (st : (x y : A) → stable (path A x y)) : is-set A = 69 | (hrel/set-equiv A (λ x y → neg (neg (path A x y))) 70 | (λ x y → neg/prop (neg (path A x y))) 71 | (λ _ np → np refl) 72 | st 73 | ).fst 74 | -------------------------------------------------------------------------------- /library/basics/isotoequiv.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | -- yacctt: https://github.com/mortberg/yacctt/blob/master/examples/prelude.ytt#L374 4 | -- RedPRL: https://github.com/RedPRL/sml-redprl/blob/bd73932409ddc3479c8ded5ac32ae0d93d31874a/example/isotoequiv.prl 5 | -- cubicaltt: https://github.com/mortberg/cubicaltt/blob/a331f1d355c5d2fc608a59c1cbbf016ea09d6deb/experiments/isoToEquiv.ctt 6 | 7 | def iso (A B : type) : type = 8 | (f : A → B) 9 | × (g : B → A) 10 | × ((b : _) → path _ (f (g b)) b) 11 | × (a : _) → path _ (g (f a)) a 12 | 13 | def iso/refl (A : type) : iso A A = 14 | ( λ f → f 15 | , λ g → g 16 | , λ _ → refl 17 | , λ _ → refl 18 | ) 19 | 20 | def iso/symm (A B : type) (I : iso A B) : iso B A = 21 | let (f,g,α,β) = I in (g,f,β,α) 22 | 23 | def iso/trans (A B C : type) (I1 : iso A B) (I2 : iso B C) : iso A C = 24 | let (f1,g1,α1,β1) = I1 in 25 | let (f2,g2,α2,β2) = I2 in 26 | ( λ a → f2 (f1 a) 27 | , λ c → g1 (g2 c) 28 | , λ c → trans _ (λ j → f2 (α1 (g2 c) j)) (α2 c) 29 | , λ a → trans _ (λ j → g1 (β2 (f1 a) j)) (β1 a) 30 | ) 31 | 32 | def iso/fiber/prop-over 33 | (A B : type) 34 | (I : iso A B) (b : 𝕀 → B) 35 | : is-prop-over (λ i → fiber _ _ (I.fst) (b i)) 36 | = 37 | let (f, g, α, β) = I in 38 | let sq (b : B) (fib : fiber _ _ f b) (j k : 𝕀) : A = 39 | comp k j (β (fib.fst) k) [ 40 | | k=1 → refl 41 | | k=0 j → g (fib.snd j) 42 | ] 43 | in 44 | λ fib0 fib1 → 45 | let sq2 (i k : 𝕀) : A = 46 | comp 0 k (g (b i)) [ 47 | | i=0 → sq (b 0) fib0 1 48 | | i=1 → sq (b 1) fib1 1 49 | ] 50 | in 51 | λ i → 52 | ( refl 53 | , λ j → 54 | let aux : A = 55 | comp j 0 (β (sq2 i 1) j) [ 56 | | j=1 → sq2 i 57 | | i=0 → sq (b 0) fib0 j 58 | | i=1 → sq (b 1) fib1 j 59 | ] 60 | in 61 | comp 0 1 (f aux) [ 62 | | i=0 → α (fib0.snd j) 63 | | i=1 → α (fib1.snd j) 64 | | j=0 → α (f (sq2 i 1)) 65 | | j=1 → α (b i) 66 | ] 67 | ) 68 | 69 | def iso→equiv (A B : type) (I : iso A B) : equiv A B = 70 | let (f, g, α, β) = I in 71 | (f , λ b → ((g b, α b), λ fib → iso/fiber/prop-over _ _ I (λ _ → b) fib (g b, α b))) 72 | 73 | /- 74 | def iso→equiv-over (A B : type) (I : iso A B) : equiv-over A B = 75 | let (f, g, α, β) = I in 76 | (f , (λ b → (g b, α b), λ b fib → iso/fiber/prop-over _ _ I b fib (g (b 1), α (b 1)))) 77 | -/ 78 | 79 | def equiv→iso (A B : type) (e : equiv A B) : iso A B = 80 | ( e .fst 81 | , λ b → e .snd b .fst .fst 82 | , λ b → e .snd b .fst .snd 83 | , λ a i → symm (fiber A B (e .fst) (e .fst a)) (e .snd (e .fst a) .snd (a, refl)) i .fst 84 | ) 85 | -------------------------------------------------------------------------------- /library/basics/retract.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import basics.isotoequiv 3 | 4 | def retraction (A B : type) (f : A → B) : type = 5 | (g : B → A) × (a : A) → path A (g (f a)) a 6 | 7 | def section (A B : type) (f : A → B) : type = 8 | (g : B → A) × (b : B) → path B (f (g b)) b 9 | 10 | def retract (A B : type) : type = 11 | (f : A → B) × retraction A B f 12 | 13 | def retract/path-action (A B : type) 14 | (f : A → B) (retr : retraction A B f) (a a' : A) 15 | : retract (path _ a a') (path B (f a) (f a')) 16 | = 17 | let (g,α) = retr in 18 | ( λ p i → f (p i) 19 | , λ q i → comp 0 1 (g (q i)) [i=0 → α a | i=1 → α a'] 20 | , λ p j i → comp j 1 (α (p i) j) [i=0 → α a | i=1 → α a'] 21 | ) 22 | 23 | def retract/hlevel : (l : hlevel) (A B : type) 24 | → retract A B → has-hlevel l B → has-hlevel l A 25 | = 26 | elim [ 27 | | contr → λ A B (f,g,α) B/contr → 28 | ( g (B/contr .fst) 29 | , λ a i → 30 | comp 0 1 (g (B/contr .snd (f a) i)) [ 31 | | i=0 → α a 32 | | i=1 → refl 33 | ] 34 | ) 35 | | hsuc l → 36 | elim l [ 37 | | contr → λ A B (f,g,α) B/prop a a' i → 38 | comp 0 1 (g (B/prop (f a) (f a') i)) [ 39 | | i=0 → α a 40 | | i=1 → α a' 41 | ] 42 | | hsuc (l → l/ih) → λ A B (f,retr) B/level a a' → 43 | l/ih (path _ a a') (path B (f a) (f a')) 44 | (retract/path-action A B f retr a a') 45 | (B/level (f a) (f a')) 46 | ] 47 | ] 48 | 49 | -- Adapted from https://github.com/HoTT/book/issues/718 50 | -- Any family of retracts of the path family preserves refl through the other round-trip 51 | def path-retract/preserves-refl (A : type) (R : A → A → type) 52 | (ret : (x y : A) → retract (R x y) (path A x y)) (x : A) 53 | : path _ (ret x x .fst (ret x x .snd .fst refl)) refl 54 | = 55 | let s (x y : A) : R x y → path A x y = ret x y .fst in 56 | let r (x y : A) : path A x y → R x y = ret x y .snd .fst in 57 | let q = s x x (r x x refl) in 58 | let cap1 : [i j] A [ 59 | | j=0 → x 60 | | j=1 → q i 61 | | i=0 → q j 62 | | i=1 → s x x (r x x q) j 63 | ] 64 | = 65 | λ i j → 66 | s x (q i) (r x (q i) (λ k → weak-connection/and A q i k)) j 67 | in 68 | let cap2 : [i j] A [ 69 | | j=0 → x 70 | | j=1 → q i 71 | | ∂[i] → q j 72 | ] 73 | = 74 | λ i j → 75 | comp 0 1 (cap1 i j) [ 76 | | ∂[j] | i=0 → refl 77 | | i=1 k → s x x (ret x x .snd .snd (r x x refl) k) j 78 | ] 79 | in 80 | let face (m k : 𝕀) : A = 81 | comp 0 m x [ 82 | | k=0 → q 83 | | k=1 → refl 84 | ] 85 | in 86 | λ i j → 87 | comp 0 1 (cap2 i j) [ 88 | | j=0 | i=0 → refl 89 | | j=1 → face i 90 | | i=1 → face j 91 | ] 92 | 93 | -- a family of retracts of the path family gives rise to a family of equivalences 94 | 95 | def path-retract/equiv (A : type) (R : A → A → type) 96 | (ret : (x y : A) → retract (R x y) (path A x y)) (a b : A) 97 | : equiv (R a b) (path A a b) 98 | = 99 | let preserves-refl = path-retract/preserves-refl A R ret a in 100 | iso→equiv (R a b) (path A a b) 101 | ( ret a b .fst 102 | , ret a b .snd .fst 103 | , λ p → J A p (λ q → path _ (ret a (q 1) .fst (ret a (q 1) .snd .fst q)) q) preserves-refl 104 | , ret a b .snd .snd 105 | ) 106 | 107 | def equiv-section/prop (A B : type) (f : A → B) (c : is-equiv A B f) 108 | : is-prop (section A B f) = 109 | λ (g0,p0) (g1,p1) i → 110 | let α (b : B) : path (fiber A B f b) (g0 b, p0 b) (g1 b, p1 b) = 111 | contr→prop (fiber A B f b) (c b) (g0 b, p0 b) (g1 b, p1 b) 112 | in 113 | (λ b → α b i .fst, λ b → α b i .snd) 114 | 115 | -- TODO this does not really belong in this file 116 | def precompose-equiv (A B C : type) (e : equiv A B) : equiv (B → C) (A → C) = 117 | let (f,g,α,β) = equiv→iso _ _ e in 118 | iso→equiv (B → C) (A → C) 119 | ( λ h a → h (f a) 120 | , λ k b → k (g b) 121 | , λ k i a → k (β a i) 122 | , λ h i b → h (α b i) 123 | ) 124 | 125 | def equiv-retraction/prop (A B : type) (f : A → B) (c : is-equiv A B f) 126 | : is-prop (retraction A B f) = 127 | λ (g0,q0) (g1,q1) i → 128 | let p = 129 | contr→prop _ (precompose-equiv A B A (f,c) .snd (λ a → a)) 130 | (g0, λ j b → q0 b j) (g1, λ j b → q1 b j) 131 | in 132 | (p i .fst, λ b j → p i .snd j b) 133 | -------------------------------------------------------------------------------- /library/cool/complete-induction.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.nat 3 | import data.unit 4 | import data.void 5 | import data.or 6 | 7 | def le : nat → nat → type = 8 | elim [ 9 | | zero → λ _ → unit 10 | | suc (m → f) → 11 | elim [ 12 | | zero → void 13 | | suc n → f n 14 | ] 15 | ] 16 | 17 | def le/suc/right : (n m : nat) → le n m → le n (suc m) = 18 | elim [ 19 | | zero → λ _ _ → ★ 20 | | suc (n' → f) → 21 | elim [ 22 | | zero → elim [] 23 | | suc m' → λ l → f m' l 24 | ] 25 | ] 26 | 27 | def le/suc : (n m : nat) → le n m → le (suc n) (suc m) = 28 | elim [ 29 | | zero → λ _ _ → ★ 30 | | suc _ → λ _ l → l 31 | ] 32 | 33 | def le/refl : (n : nat) → le n n = 34 | elim [ 35 | | zero → ★ 36 | | suc (_ → f) → f 37 | ] 38 | 39 | def le/zero/implies/zero : (n : nat) → (le n zero) → path nat zero n = 40 | elim [ 41 | | zero → λ _ → refl 42 | | suc n' → elim [] 43 | ] 44 | 45 | def le/case : (m n : nat) → (le n (suc m)) → or (path nat n (suc m)) (le n m) = 46 | elim [ 47 | | zero → 48 | elim [ 49 | | zero → λ _ → inr ★ 50 | | suc n' → 51 | elim n' [ 52 | | zero → λ _ → inl refl 53 | | suc _ → λ p → inr p 54 | ] 55 | ] 56 | | suc (m' → c) → 57 | elim [ 58 | | zero → λ _ → inr ★ 59 | | suc n' → λ p → 60 | elim (c n' p) [ 61 | | inl p → inl (λ i → suc (p i)) 62 | | inr l → inr (le/suc n' m' l) 63 | ] 64 | ] 65 | ] 66 | 67 | def weak/induction (P : nat → type) : type = 68 | P zero 69 | → ((n : nat) → P n → P (suc n)) 70 | → (n : nat) 71 | → P n 72 | 73 | def realize/weak/induction (P : nat → type) : weak/induction P = 74 | λ p0 ps → 75 | elim [ 76 | | zero → p0 77 | | suc (n' → pn') → ps n' pn' 78 | ] 79 | 80 | def complete/induction (P : nat → type) : type = 81 | P zero 82 | → ((n : nat) → ((k : nat) → (le k n) → P k) → P (suc n)) 83 | → (n : nat) 84 | → P n 85 | 86 | def complete/implies/weak 87 | (P : nat → type) 88 | (complete : complete/induction P) 89 | : weak/induction P 90 | = 91 | λ p0 ps → 92 | complete p0 (λ n f → ps n (f n (le/refl n))) 93 | 94 | def weak/implies/complete 95 | (P : nat → type) 96 | (weak : (P' : nat → type) → weak/induction P') 97 | : complete/induction P 98 | = 99 | λ p0 ps → 100 | let P' (n : nat) : type = (k : nat) → (le k n) → P k in 101 | let P'0 : P' zero = 102 | λ k k/le/0 → 103 | coe 0 1 p0 in λ i → 104 | P (le/zero/implies/zero k k/le/0 i) 105 | in 106 | let f (n : nat) (p'n : P' n) : (P' (suc n)) = 107 | λ k k/le/sn → 108 | elim (le/case n k k/le/sn) [ 109 | | inl p → coe 1 0 (ps n p'n) in λ i → P (p i) 110 | | inr l → p'n k l 111 | ] 112 | in 113 | let P'n : (n : nat) → P' n = weak P' P'0 f in 114 | λ n → P'n n n (le/refl n) 115 | 116 | -- prove that a gcd exists for any m, n using complete induction 117 | -- examine the running code for its time complexity 118 | -- consider other representations of natural numbers and their associated induction princ's 119 | -- (0, 2n, 2n+1) doesn't help gcd, what would? 120 | -- understanding information flow in a proof in terms of homotopy levels, eg, and consider suppressing irrelevant information 121 | -------------------------------------------------------------------------------- /library/cool/free-monoid.red: -------------------------------------------------------------------------------- 1 | import data.list 2 | 3 | -- In this file, we try to relate the weak free monoid on a set (presented as a HIT) to the 4 | -- strict free monoid, presented as a list. 5 | 6 | -- Probably need to truncate this to get the right type 7 | data (A : type) ⊢ F where 8 | | η (a : A) 9 | | ☆ (s t : F) 10 | | ε 11 | | idn/r (s : F) (i : 𝕀) [ 12 | | i=0 → ☆ s ε 13 | | i=1 → s 14 | ] 15 | | idn/l (s : F) (i : 𝕀) [ 16 | | i=0 → ☆ ε s 17 | | i=1 → s 18 | ] 19 | | ass (s t u : F) (i : 𝕀) [ 20 | | i=0 → ☆ s (☆ t u) 21 | | i=1 → ☆ (☆ s t) u 22 | ] 23 | 24 | def quote (A : type) : list A → F A = 25 | elim [ 26 | | nil → ε 27 | | cons x (xs → ih) → 28 | ☆ (η x) ih 29 | ] 30 | 31 | def eval (A : type) : F A → list A = 32 | elim [ 33 | | η a → 34 | cons a nil 35 | | ☆ (s → ih/s) (t → ih/t) → 36 | append A ih/s ih/t 37 | | ε → 38 | nil 39 | | idn/l s i → 40 | refl 41 | | idn/r (s → ih/s) i → 42 | append/idn/r A ih/s i 43 | | ass (s → ih/s) (t → ih/t) (u → ih/u) i → 44 | append/ass A ih/s ih/t ih/u i 45 | ] 46 | 47 | def nbe (A : type) (s : F A) : F A = 48 | quote A (eval A s) 49 | 50 | 51 | /- 52 | -- need to do some kind of gluing thing I guess 53 | def soundness (A : type) : (s : F A) → path _ s (nbe A s) = 54 | elim [ 55 | 56 | | ☆ (s → ih/s) (t → ih/t) → 57 | ? 58 | 59 | | idn/l s i → 60 | ?_ 61 | | idn/r (s → ih/s) i → 62 | ?_ 63 | | ass (s → ih/s) (t → ih/t) (u → ih/u) i → 64 | ?_ 65 | 66 | | * → refl 67 | ] 68 | -/ 69 | -------------------------------------------------------------------------------- /library/cool/hopf.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.s1 3 | import data.s2 4 | import basics.isotoequiv 5 | 6 | def rotate/loop : (a : s1) → path _ a a = 7 | elim [ 8 | | base → λ j → loop j 9 | | loop i → λ j → connection/both s1 (λ k → loop k) (λ k → loop k) i j 10 | ] 11 | 12 | def unrotate/loop (a : s1) : path _ a a = 13 | symm s1 (rotate/loop a) 14 | 15 | def rotate-unrotate/loop (a : s1) 16 | : pathd (λ i → path s1 (rotate/loop (unrotate/loop a i) i) a) refl refl 17 | = 18 | λ i j → 19 | comp 0 1 (rotate/loop a i) [ 20 | | i=0 k → rotate/loop a k 21 | | i=1 → refl 22 | | j=0 k → rotate/loop (symm/filler s1 (λ i → rotate/loop a i) k i) i 23 | | j=1 k → weak-connection/or s1 (λ i → rotate/loop a i) i k 24 | ] 25 | 26 | def unrotate-rotate/loop (a : s1) 27 | : pathd (λ i → path s1 (unrotate/loop (rotate/loop a i) i) a) refl refl 28 | = 29 | λ i j → 30 | let filler (m : 𝕀) : s1 = 31 | comp 1 m a [ 32 | | j=0 m → rotate/loop a m 33 | | j=1 → refl 34 | ] 35 | in 36 | comp 0 1 (filler i) [ 37 | | i=0 → filler 38 | | i=1 | j=1 → refl 39 | ] 40 | 41 | def rotate/loop/equiv (i : 𝕀) : equiv s1 s1 = 42 | iso→equiv s1 s1 43 | ( λ a → rotate/loop a i 44 | , λ a → unrotate/loop a i 45 | , λ a → rotate-unrotate/loop a i 46 | , λ a → unrotate-rotate/loop a i 47 | ) 48 | 49 | def hopf : s2 → type = 50 | elim [ 51 | | base → s1 52 | | surf i j → 53 | comp 0 1 s1 [ 54 | | ∂[j] | i=0 → ua s1 s1 (rotate/loop/equiv 0) 55 | | i=1 → ua s1 s1 (rotate/loop/equiv j) 56 | ] 57 | ] 58 | -------------------------------------------------------------------------------- /library/cool/isos.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import basics.isotoequiv 3 | import data.unit 4 | import data.void 5 | import data.or 6 | 7 | -- pair isos 8 | 9 | def iso/pair/comm (A B : type) : iso (A × B) (B × A) = 10 | ( λ (a,b) → (b,a) 11 | , λ (b,a) → (a,b) 12 | , λ _ → refl 13 | , λ _ → refl 14 | ) 15 | 16 | def iso/pair/assoc (A B C : type) : iso (A × B × C) ((A × B) × C) = 17 | ( λ (a,b,c) → ((a,b),c) 18 | , λ ((a,b),c) → (a,b,c) 19 | , λ _ → refl 20 | , λ _ → refl 21 | ) 22 | 23 | def iso/pair/unit (A : type) : iso (A × unit) A = 24 | ( λ (a,_) → a 25 | , λ a → (a,★) 26 | , λ _ → refl 27 | , λ (a,u) i → (a, unit/prop ★ u i) 28 | ) 29 | 30 | def iso/pair/void (A : type) : iso (A × void) void = 31 | ( λ (_,v) → exfalso _ v 32 | , λ v → exfalso _ v 33 | , λ v → exfalso _ v 34 | , λ (_,v) → exfalso _ v 35 | ) 36 | 37 | -- or isos 38 | 39 | def iso/or/comm (A B : type) : iso (or A B) (or B A) = 40 | ( elim [ inl a → inr a | inr b → inl b ] 41 | , elim [ inl b → inr b | inr a → inl a ] 42 | , elim [ inl _ → refl | inr _ → refl ] 43 | , elim [ inl _ → refl | inr _ → refl ] 44 | ) 45 | 46 | def iso/or/assoc (A B C : type) : iso (or A (or B C)) (or (or A B) C) = 47 | ( elim [ inl a → inl (inl a) | inr bc → elim bc [ inl b → inl (inr b) | inr c → inr c ] ] 48 | , elim [ inl ab → elim ab [ inl a → inl a | inr b → inr (inl b) ] | inr c → inr (inr c) ] 49 | , elim [ inl ab → elim ab [ inl _ → refl | inr _ → refl ] | inr _ → refl ] 50 | , elim [ inl _ → refl | inr bc → elim bc [ inl _ → refl | inr _ → refl ] ] 51 | ) 52 | 53 | def iso/or/void (A : type) : iso (or A void) A = 54 | ( elim [ inl a → a | inr v → exfalso _ v ] 55 | , λ a → inl a 56 | , λ _ → refl 57 | , elim [ inl _ → refl | inr v → exfalso _ v ] 58 | ) 59 | 60 | -- function isos 61 | 62 | def curry (A B C : type) : ((A × B) → C) → (A → B → C) = 63 | λ f a b → f (a, b) 64 | 65 | def uncurry (A B C : type) : (A → B → C) → ((A × B) → C) = 66 | λ f (a, b) → f a b 67 | 68 | def iso/curry (A B C : type) : iso (A → B → C) ((A × B) → C) = 69 | ( uncurry _ _ _ 70 | , curry _ _ _ 71 | , λ _ → refl 72 | , λ _ → refl 73 | ) 74 | 75 | def iso/lhs (A B C : type) (I : iso A B) : iso (A → C) (B → C) = 76 | let (f,g,α,β) = I in 77 | ( λ ac b → ac (g b) 78 | , λ bc a → bc (f a) 79 | , λ bc i b → bc (α b i) 80 | , λ ac i a → ac (β a i) 81 | ) 82 | 83 | def iso/rhs (A B C : type) (I : iso A B) : iso (C → A) (C → B) = 84 | let (f,g,α,β) = I in 85 | ( λ ca c → f (ca c) 86 | , λ cb c → g (cb c) 87 | , λ cb i c → α (cb c) i 88 | , λ ca i c → β (ca c) i 89 | ) 90 | 91 | def iso/flip (A B C : type) : iso (A → B → C) (B → A → C) = 92 | ( λ f b a → f a b 93 | , λ f a b → f b a 94 | , λ _ → refl 95 | , λ _ → refl 96 | ) 97 | 98 | -- we can also compose the flip iso 99 | 100 | def iso/flip/2 (A B C : type) : iso (A → B → C) (B → A → C) = 101 | iso/trans _ _ _ (iso/curry A B C) 102 | (iso/trans _ _ _ (iso/lhs (A × B) (B × A) C (iso/pair/comm A B)) 103 | (iso/symm _ _ (iso/curry B A C))) 104 | -------------------------------------------------------------------------------- /library/cool/logic.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.void 3 | import data.bool 4 | import paths.bool 5 | import basics.hedberg 6 | 7 | def no-double-neg-elim (f : (A : type) → stable A) : void = 8 | let f2 = f bool in 9 | 10 | -- transport along the path induced from `not` by univalence 11 | let tf2 = coe 0 1 f2 in λ i → stable (not/path i) in 12 | 13 | -- transporting a dependent function produces a path to the original 14 | let apdf : path _ tf2 f2 = λ i → coe i 1 (f (not/path i)) in λ j → stable (not/path j) in 15 | 16 | -- tf2 is equal to a composition of transporting the argument backwards along `neg (neg (symm not/path))`... 17 | let inner (u : neg (neg bool)) : neg (neg bool) = coe 0 1 u in λ i → neg (neg (symm^1 type not/path i)) in 18 | 19 | -- ... and then `f2` applied to result forwards along `not/path` 20 | -- however transporting along an univalence-induced path equals applying the original iso 21 | -- thus `tf2 u = not (f2 (inner u))` 22 | 23 | -- `neg A` is a prop, so there is a path 24 | let u→inner (u : neg (neg bool)) : path _ u (inner u) = neg/prop (neg bool) u (inner u) in 25 | 26 | -- lift it to a path into `tf2` 27 | let notf2→tf2 (u : neg (neg bool)) : path _ (not (f2 u)) (tf2 u) = λ i → not (f2 (u→inner u i)) in 28 | 29 | -- and compose with `apdf` to obtain a contradictory path 30 | let contra (u : neg (neg bool)) : path _ (not (f2 u)) (f2 u) = trans _ (notf2→tf2 u) (λ i → apdf i u) in 31 | 32 | let nnb : neg (neg bool) = λ negb → negb tt in 33 | not/neg (f2 nnb) (contra nnb) 34 | 35 | def no-excluded-middle (g : (A : type) → dec A) : void = 36 | no-double-neg-elim (λ A → dec→stable A (g A)) 37 | -------------------------------------------------------------------------------- /library/cool/moebius-boundary.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.bool 3 | import data.s1 4 | import paths.bool 5 | import data.int 6 | import paths.s1 7 | 8 | def moebius-boundary/fiber : s1 → type = 9 | elim [ 10 | | base → bool 11 | | loop i → not/path i 12 | ] 13 | 14 | def moebius-boundary : type = (x : s1) × moebius-boundary/fiber x 15 | 16 | def moebius-boundary→s1/loop-base (i : 𝕀) : bool → s1 = 17 | elim [ tt → loop i | ff → base ] 18 | 19 | def moebius-boundary→s1/commuting : 20 | (y : bool) → 21 | path _ 22 | (moebius-boundary→s1/loop-base 0 y) 23 | (moebius-boundary→s1/loop-base 1 (coe 0 1 y in not/path)) 24 | = 25 | elim [ tt → refl | ff → refl ] 26 | 27 | def moebius-boundary→s1/loop/filler (i j : 𝕀) (y : not/path i) : s1 = 28 | let z : bool = coe i 1 y in not/path in 29 | comp 1 j (moebius-boundary→s1/loop-base i z) [ 30 | | i=0 → moebius-boundary→s1/commuting y 31 | | i=1 → refl 32 | ] 33 | 34 | def moebius-boundary→s1' : (x : s1) → moebius-boundary/fiber x → s1 = 35 | elim [ 36 | | base → moebius-boundary→s1/loop-base 0 37 | | loop i → moebius-boundary→s1/loop/filler i 0 38 | ] 39 | 40 | def moebius-boundary→s1 (x : moebius-boundary) : s1 = 41 | moebius-boundary→s1' (x .fst) (x .snd) 42 | 43 | def s1→moebius-boundary/base : moebius-boundary = 44 | (base, ff) 45 | 46 | def loop-path (b : bool) : path moebius-boundary (base, b) (base, not b) = 47 | λ i → (loop i , `(vin i b (not b))) 48 | 49 | def s1→moebius-boundary/loop/filler (i j : 𝕀) : moebius-boundary = 50 | comp 0 j (loop-path ff i) [i=0 → refl | i=1 → loop-path tt] 51 | 52 | def s1→moebius-boundary : s1 → moebius-boundary = 53 | elim [ 54 | | base → s1→moebius-boundary/base 55 | | loop i → s1→moebius-boundary/loop/filler i 1 56 | ] 57 | 58 | opaque def s1→moebius-boundary→s1/loop : 59 | [i j] s1 [ 60 | | ∂[i] → base 61 | | j=0 → moebius-boundary→s1 (s1→moebius-boundary/loop/filler i 1) 62 | | j=1 → loop i 63 | ] 64 | = 65 | λ i j → 66 | comp 0 1 (moebius-boundary→s1/loop/filler i j (loop-path ff i .snd)) [ 67 | | i=0 → refl 68 | | i=1 k → moebius-boundary→s1/loop/filler k j (loop-path tt k .snd) 69 | | j=0 k → moebius-boundary→s1 (s1→moebius-boundary/loop/filler i k) 70 | | j=1 → refl 71 | ] 72 | 73 | /- 74 | This will force re-typechecking `box`, but why? 75 | -/ 76 | def s1→moebius-boundary→s1 : 77 | (x : s1) → path s1 (moebius-boundary→s1 (s1→moebius-boundary x)) x 78 | = 79 | elim [ 80 | | base → refl 81 | | loop i → λ j → s1→moebius-boundary→s1/loop i j 82 | ] 83 | 84 | def test (i : 𝕀) : moebius-boundary = 85 | s1→moebius-boundary (loop i) 86 | 87 | def test1 (i : 𝕀) : s1 = 88 | moebius-boundary→s1 (s1→moebius-boundary (loop i)) 89 | 90 | def double : s1 → s1 = λ x → s1→moebius-boundary x .fst 91 | 92 | def test0 : path int (winding (λ i → double (loopn (pos (suc zero)) i))) (pos (suc (suc zero))) = 93 | refl 94 | 95 | -------------------------------------------------------------------------------- /library/cool/nat-prime.red: -------------------------------------------------------------------------------- 1 | import data.list 2 | import prelude 3 | import data.nat 4 | import data.bool 5 | import cool.gcd 6 | 7 | data factor where 8 | | o 9 | | s (f : factor) 10 | 11 | def nat' : type = list factor 12 | 13 | def is-prime-from : nat → nat → nat → bool = 14 | elim [ 15 | | zero → λ _ _ → tt 16 | | suc (n' → f) → λ n k → 17 | elim (mod n k) [ 18 | | zero → ff 19 | | suc _ → f n (suc k) 20 | ] 21 | ] 22 | 23 | def le/bool : nat → nat → bool = 24 | elim [ 25 | | zero → λ _ → tt 26 | | suc (m → f) → 27 | elim [ 28 | | zero → ff 29 | | suc n → f n 30 | ] 31 | ] 32 | 33 | def and : bool → bool → bool = 34 | elim [ 35 | | tt → 36 | elim [ 37 | | tt → tt 38 | | ff → ff 39 | ] 40 | | ff → λ _ → ff 41 | ] 42 | 43 | def is-prime (n : nat) = and (is-prime-from (nat-pred (nat-pred n)) n n2) 44 | (not (le/bool n n1)) 45 | 46 | def check' : path bool (is-prime n8) ff = refl 47 | -------------------------------------------------------------------------------- /library/cool/nats.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.bool 3 | import data.nat 4 | import basics.isotoequiv 5 | 6 | data binnat where 7 | | nil -- 0 8 | | cons1 (x : binnat) -- 2n + 1 9 | | cons2 (x : binnat) -- 2n + 2 10 | 11 | def double/nat : nat → nat = 12 | elim [ 13 | | zero → zero 14 | | suc (_ → ih) → suc (suc ih) 15 | ] 16 | 17 | def binnat→nat : binnat → nat = 18 | elim [ 19 | | nil → zero 20 | | cons1 (_ → ih) → suc (double/nat ih) 21 | | cons2 (_ → ih) → suc (suc (double/nat ih)) 22 | ] 23 | 24 | def suc/binnat : binnat → binnat = 25 | elim [ 26 | | nil → cons1 nil 27 | | cons1 n → cons2 n 28 | | cons2 (_ → ih) → cons1 ih 29 | ] 30 | 31 | def nat→binnat : nat → binnat = 32 | elim [ 33 | | zero → nil 34 | | suc (_ → ih) → suc/binnat ih 35 | ] 36 | 37 | def binnat→nat-suc (n : binnat) 38 | : path _ (binnat→nat (suc/binnat n)) (suc (binnat→nat n)) = 39 | elim n [ 40 | | nil → refl 41 | | cons1 _ → refl 42 | | cons2 (_ → ih) → λ i → suc (double/nat (ih i)) 43 | ] 44 | 45 | def nat→binnat→nat (n : nat) 46 | : path _ (binnat→nat (nat→binnat n)) n = 47 | elim n [ 48 | | zero → refl 49 | | suc (n → ih) → trans nat (binnat→nat-suc (nat→binnat n)) (λ i → suc (ih i)) 50 | ] 51 | 52 | def suc-nat→binnat-double (n : nat) 53 | : path binnat (suc/binnat (nat→binnat (double/nat n))) (cons1 (nat→binnat n)) = 54 | elim n [ 55 | | zero → refl 56 | | suc (_ → ih) → λ i → suc/binnat (suc/binnat (ih i)) 57 | ] 58 | 59 | def binnat→nat→binnat (n : binnat) 60 | : path _ (nat→binnat (binnat→nat n)) n = 61 | elim n [ 62 | | nil → refl 63 | | cons1 (n → ih) → trans binnat (suc-nat→binnat-double (binnat→nat n)) (λ i → cons1 (ih i)) 64 | | cons2 (n → ih) → trans binnat (λ i → suc/binnat (suc-nat→binnat-double (binnat→nat n) i)) (λ i → cons2 (ih i)) 65 | ] 66 | 67 | def nat≃binnat : equiv nat binnat = 68 | iso→equiv _ _ 69 | (nat→binnat, 70 | binnat→nat, 71 | binnat→nat→binnat, 72 | nat→binnat→nat) 73 | 74 | def n≈bn : path^1 type nat binnat = ua _ _ nat≃binnat 75 | 76 | 77 | 78 | -- We can transport functions between these two types, and run them! 79 | -- From nat → nat → nat to binnat → binnat → binnat... 80 | 81 | def plus/binnat : binnat → binnat → binnat = 82 | coe 0 1 plus in λ i → n≈bn i → n≈bn i → n≈bn i 83 | -- i=0: nat → nat → nat 84 | -- i=1: binnat → binnat → binnat 85 | 86 | -- plus and plus/binnat are equal, modulo n≈bn 87 | def plus/n≈bn : pathd^1 (λ i → n≈bn i → n≈bn i → n≈bn i) plus plus/binnat = 88 | λ i → coe 0 i plus in λ i → n≈bn i → n≈bn i → n≈bn i 89 | 90 | def test : binnat = plus/binnat (cons1 nil) (cons1 nil) 91 | meta ⦉ print normalize test ⦊ 92 | 93 | -- From binnat → bool to nat → bool... 94 | 95 | def oddq : binnat → bool = 96 | elim [ 97 | | nil → ff 98 | | cons1 _ → tt 99 | | cons2 _ → ff 100 | ] 101 | 102 | def oddq/n≈bn (i : 𝕀) : (n≈bn i) → bool = 103 | coe 1 i oddq in λ i → (n≈bn i) → bool 104 | 105 | def oddq/nat : nat → bool = oddq/n≈bn 0 106 | 107 | -- nat and binnat are equal implementations of the 'nat' interface. 108 | 109 | def impl : type^1 = (A : type) × A × (A → A) 110 | def impl/nat : impl = (nat, zero, λ n → suc n) 111 | def impl/binnat : impl = (binnat, nil, suc/binnat) 112 | 113 | def impl/n≈bn : path^1 impl impl/nat impl/binnat = 114 | λ i → 115 | (n≈bn i, 116 | coe 0 i zero in n≈bn, 117 | -- MORTAL 118 | λ v → let v' : n≈bn i = (suc v, suc/binnat (v .vproj)) in v' 119 | ) 120 | 121 | -- We can also transport proofs *about* these functions. 122 | 123 | def oddq/suc : (n : binnat) → path bool (oddq n) (not (oddq (suc/binnat n))) = 124 | λ * → refl 125 | 126 | def oddq/nat/suc : (n : nat) → path bool (oddq/nat n) (not (oddq/nat (suc n))) = 127 | coe 1 0 oddq/suc 128 | in λ i → (n : n≈bn i) → 129 | path bool (oddq/n≈bn i n) (not (oddq/n≈bn i (impl/n≈bn i .snd.snd n))) 130 | 131 | def oddq/nat/direct : nat → bool = 132 | elim [ 133 | | zero → ff 134 | | suc (_ → ih) → not ih 135 | ] 136 | 137 | /- MORTAL 138 | def oddq/n≈bn : (n : nat) → path bool (oddq/nat n) (oddq/nat/direct n) = 139 | let pf : (n : nat) → path _ (suc/binnat (nat→binnat n)) (nat→binnat (suc n)) = 140 | λ * → refl 141 | in 142 | elim [ 143 | | zero → refl 144 | | suc (n → ih) → λ i → not (trans bool (λ i → oddq (pf n i)) ih i) 145 | ] 146 | -/ 147 | -------------------------------------------------------------------------------- /library/cool/patch-theory.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.int 3 | import paths.int 4 | import paths.equivalence 5 | import paths.sigma 6 | 7 | data patch where 8 | | num 9 | | add1 (i : 𝕀) [∂[i] → num] 10 | 11 | def Interp : patch → type = 12 | elim [ 13 | | num → int 14 | | add1 i → ua _ _ isuc/equiv i 15 | ] 16 | 17 | def int-equiv = equiv int int 18 | 19 | def int-equiv/path (f g : int-equiv) : path _ (f.fst) (g.fst) → path _ f g = 20 | subtype/path (int → int) (is-equiv int int) (is-equiv/prop int int) f g 21 | 22 | def interp (p : path patch num num) : equiv int int = 23 | path→equiv int int (λ i → Interp (p i)) 24 | 25 | def test : path (equiv int int) (interp (λ i → add1 i)) isuc/equiv = 26 | int-equiv/path (interp (λ i → add1 i)) isuc/equiv refl 27 | -------------------------------------------------------------------------------- /library/cool/problem.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.s1 3 | import data.s2 4 | import data.s3 5 | import data.join 6 | import data.int 7 | import paths.s1 8 | import pointed.loops 9 | import cool.s3-to-join 10 | import cool.hopf 11 | 12 | -- from https://github.com/mortberg/cubicaltt/blob/pi4s3/examples/problem.ctt 13 | 14 | def pΩ² (pA : ptype) : ptype = pΩ (pΩ pA) 15 | def pΩ³ (pA : ptype) : ptype = pΩ (pΩ² pA) 16 | 17 | def pΩ³/reflmap (pA : ptype) (B : type) (f : pA.fst → B) 18 | : pmap (pΩ³ pA) (pΩ³ (B , f (pA.snd))) 19 | = 20 | ( λ c i j k → f (c i j k) 21 | , refl 22 | ) 23 | 24 | def ps2 : ptype = (s2, base) 25 | def ps3 : ptype = (s3, base) 26 | def pjoin : ptype = (join s1 s1, inl base) 27 | 28 | def test0-2 : pΩ³ ps3 .fst = 29 | λ i j k → cube i j k 30 | 31 | def f3 : pΩ³ ps3 .fst → pΩ³ pjoin .fst = 32 | pΩ³/reflmap ps3 (join s1 s1) s3→join .fst 33 | 34 | def test0-3 : pΩ³ pjoin .fst = f3 test0-2 35 | 36 | def f4 : pΩ³ pjoin .fst → pΩ³ ps2 .fst = 37 | pΩ³/reflmap pjoin s2 join→s2 .fst 38 | 39 | def test0-4 : pΩ³ ps2 .fst = f4 test0-3 40 | 41 | def innerpath (i j : 𝕀) : s1 = 42 | coe 0 1 base in λ k → hopf (test0-4 i j k) 43 | 44 | --def problem : path int (pos zero) (pos zero) = 45 | -- λ i → coe 0 1 (pos zero) in λ j → s1-univ-cover (innerpath i j) 46 | -------------------------------------------------------------------------------- /library/cool/pullback.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | def pullback (A B C : type) (f : A → C) (g : B → C) : type = 4 | (a : _) × (b : _) × path _ (f a) (g b) 5 | 6 | def comm-square (P A B C : type) : type = 7 | (f : A → C) × (g : B → C) × (h : P → A) × (k : P → B) × path (P → C) (λ x → f (h x)) (λ x → g (k x)) 8 | 9 | def pullback→comm (A B C : type) (f : A → C) (g : B → C) : comm-square (pullback A B C f g) A B C = 10 | (f, g, λ p → p.fst, λ p → p.snd.fst, λ i p → p.snd.snd i) 11 | 12 | def comm→pullback (P A B C : type) (sq : comm-square P A B C) : pullback (P → A) (P → B) (P → C) (λ pa p → sq.fst (pa p)) (λ pb p → sq.snd.fst (pb p)) = 13 | let (f, g, h, k, p) = sq in 14 | (h, k, p) 15 | 16 | def induced (X P A B C : type) (sq : comm-square P A B C) : (X → P) → pullback (X → A) (X → B) (X → C) (λ xa x → sq.fst (xa x)) (λ xb x → sq.snd.fst (xb x)) = 17 | λ xp → 18 | let (f, g, h, k, p) = sq in 19 | (λ x → h (xp x), λ x → k (xp x), λ i x → p i (xp x)) 20 | 21 | def is-pullback-square (P A B C : type) (sq : comm-square P A B C) : type^1 = 22 | (X : type) → is-equiv _ _ (induced X P A B C sq) 23 | 24 | def pullback/corner (A B C : type) (f : A → C) (g : B → C) : is-pullback-square (pullback _ _ _ f g) A B C (pullback→comm _ _ _ f g) = 25 | λ X pbx → 26 | let (h,k,p) = pbx in 27 | ( 28 | ((λ x → (h x, k x, λ i → p i x)), refl), 29 | λ d i → 30 | let d2 = d.snd in 31 | (λ x → ((d2 i).fst x, (d2 i).snd.fst x, λ j → (d2 i).snd.snd j x), 32 | λ j → connection/or _ d2 i j) 33 | ) -------------------------------------------------------------------------------- /library/cool/quotient.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.truncation 3 | import data.quotient 4 | import basics.isotoequiv 5 | import basics.retract 6 | 7 | -- A "quotient" by a "0-coherent groupoid" is effective 8 | def quotient/effective 9 | (A : type) (R : A → A → type) 10 | (R/refl : (a : A) → R a a) 11 | (R/symm : (a b : A) → R a b → R b a) 12 | (R/trans : (a b c : A) → R a b → R b c → R a c) 13 | (R/assoc 14 | : (a b c d : A) (p : R a b) (q : R b c) (r : R c d) 15 | → path (R a d) (R/trans _ _ _ (R/trans _ _ _ p q) r) (R/trans _ _ _ p (R/trans _ _ _ q r))) 16 | (R/inv/l : (a b : A) (p : R a b) → path _ (R/trans _ _ _ (R/symm _ _ p) p) (R/refl _)) 17 | (R/inv/r : (a b : A) (p : R a b) → path _ (R/trans _ _ _ p (R/symm _ _ p)) (R/refl _)) 18 | (R/idn/l : (a b : A) (p : R a b) → path _ (R/trans _ _ _ (R/refl _) p) p) 19 | (R/idn/r : (a b : A) (p : R a b) → path _ (R/trans _ _ _ p (R/refl _)) p) 20 | : (a b : A) 21 | → retract (R a b) (path (quotient A R) (pt a) (pt b)) 22 | = 23 | λ a b → 24 | ( λ p i → 25 | gl a b p i 26 | 27 | , λ p → 28 | coe 0 1 (R/refl a) in λ i → 29 | elim (p i) [ 30 | | pt b → 31 | R a b 32 | | gl b0 b1 b01 i → 33 | let g0 (x : R a b0) : R a b1 = R/trans _ _ _ x b01 in 34 | let g1 (x : R a b1) : R a b0 = R/trans _ _ _ x (R/symm _ _ b01) in 35 | let α0 (p : R a b1) = 36 | trans _ 37 | (trans _ 38 | (R/assoc a b1 b0 b1 p (R/symm b0 b1 b01) b01) 39 | (λ j → R/trans a b1 b1 p (R/inv/l b0 b1 b01 j))) 40 | (R/idn/r _ _ p) 41 | in 42 | let α1 (p : R a b0) = 43 | trans _ 44 | (trans _ 45 | (R/assoc a b0 b1 b0 p b01 (R/symm b0 b1 b01)) 46 | (λ j → R/trans _ _ _ p (R/inv/r b0 b1 b01 j))) 47 | (R/idn/r _ _ p) 48 | in 49 | ua _ _ (iso→equiv _ _ (g0, g1, α0, α1)) i 50 | ] 51 | 52 | , λ p → 53 | trans 54 | (R a b) 55 | (λ i → coe i 1 (R/trans a a b (R/refl a) p) in λ _ → R a b) 56 | (R/idn/l _ _ _) 57 | ) 58 | 59 | 60 | -- Corollary: a quotient by a propositional equivalence relation is effective 61 | def quotient/prop-valued/effective 62 | (A : type) (R : A → A → type) 63 | (R/prop : (a b : A) → is-prop (R a b)) 64 | (R/refl : (a : A) → R a a) 65 | (R/symm : (a b : A) → R a b → R b a) 66 | (R/trans : (a b c : A) → R a b → R b c → R a c) 67 | (a b : A) 68 | : path (quotient A R) (pt a) (pt b) 69 | → R a b 70 | = 71 | quotient/effective A R 72 | R/refl 73 | R/symm 74 | R/trans 75 | (λ _ _ _ _ _ _ _ → R/prop _ _ _ _) 76 | (λ _ _ _ → R/prop _ _ _ _) 77 | (λ _ _ _ → R/prop _ _ _ _) 78 | (λ _ _ _ → R/prop _ _ _ _) 79 | (λ _ _ _ → R/prop _ _ _ _) 80 | a b 81 | .snd 82 | .fst 83 | -------------------------------------------------------------------------------- /library/cool/redml-examples.red: -------------------------------------------------------------------------------- 1 | import data.bool 2 | 3 | meta ⦉ 4 | 5 | /- For intuition, think of having the following types in Idealized RedML: 6 | 7 | vtype goal 8 | vtype proof 9 | ctype tactic = goal → ^proof 10 | 11 | We define a custom tactical using the type `{{tactic} → tactic}` 12 | -/ 13 | 14 | let mytac = { 15 | -- Using the braces {} we have opened a thunk 16 | 17 | print "foo! α☆β"; 18 | 19 | fun tac → 20 | « -- inside these brackets, we are using the redtt term notation; 21 | -- we use the redtt tactic to introduce a sigma type, and then fill 22 | -- the first cell with the result of calling the user-provided 23 | -- tactic, and fill the second cell with the redtt term 'tt'. 24 | (⦉ !tac ⦊, tt) 25 | » 26 | } 27 | ⦊ 28 | 29 | -- Now, we can create a pair of booleans by calling the tactic. 30 | def foo : bool × bool = 31 | ⦉ !mytac -- force the thunk 32 | { « ff » } -- apply it to a thunk of a tactic which produces the constant 'ff' 33 | ⦊ 34 | 35 | -- observe that we get (pair ff tt) as the resulting proof term 36 | meta ⦉ print normalize foo ⦊ 37 | 38 | -------------------------------------------------------------------------------- /library/cool/s3-to-join.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.s1 3 | import data.s2 4 | import data.s3 5 | import data.join 6 | import basics.isotoequiv 7 | 8 | -- forward map 9 | 10 | -- pseudo-connection 11 | def s3→join/cnx (b : s1) (i m : 𝕀) : join s1 s1 = 12 | comp 0 i (inl base) [ 13 | | m=0 → refl 14 | | m=1 i → push base b i 15 | ] 16 | 17 | def s3→join/k01 : 18 | [i j m] join s1 s1 [ 19 | | i=1 | ∂[j] → s3→join/cnx base i m 20 | | m=0 → inl base 21 | | m=1 → push (loop j) base i 22 | ] 23 | = 24 | λ i j m → 25 | comp 1 i (s3→join/cnx base 1 m) [ 26 | | ∂[j] i → s3→join/cnx base i m 27 | | m=0 → refl 28 | | m=1 i → push (loop j) base i 29 | ] 30 | 31 | def s3→join/cube/filler (i j k m : 𝕀) : join s1 s1 = 32 | comp 1 m (push (loop j) (loop k) i) [ 33 | | i=1 | ∂[j] → s3→join/cnx (loop k) i 34 | | (i=0 | ∂[k]) m → s3→join/k01 i j m 35 | ] 36 | 37 | def s3→join : s3 → join s1 s1 = 38 | elim [ 39 | | base → inl base 40 | | cube i j k → s3→join/cube/filler i j k 0 41 | ] 42 | 43 | -- inverse map 44 | 45 | def join→s3/push/loop : s1 → [i j] s3 [ ∂[i j] → base ] = 46 | elim [ 47 | | base → refl 48 | | loop k → λ i j → cube i j k 49 | ] 50 | 51 | def join→s3/push (a b : s1) : path s3 base base = 52 | elim a [ 53 | | base → refl 54 | | loop j → λ i → join→s3/push/loop b i j 55 | ] 56 | 57 | def join→s3 : join s1 s1 → s3 = 58 | elim [ 59 | | push a b i → join→s3/push a b i 60 | | * → base 61 | ] 62 | 63 | -- join-s3-join inverse homotopy 64 | 65 | def join-s3-join/inl : (a : s1) → path (join s1 s1) (inl base) (inl a) = 66 | elim [ 67 | | base → refl 68 | | loop j → λ m → s3→join/k01 0 j m 69 | ] 70 | 71 | def join-s3-join/push/loop 72 | : (b : s1) → 73 | [i j m] join s1 s1 [ 74 | | i=0 → s3→join/k01 0 j m 75 | | i=1 | ∂[j] → s3→join/cnx b i m 76 | | m=0 → s3→join (join→s3/push/loop b i j) 77 | | m=1 → push (loop j) b i 78 | ] 79 | = 80 | elim [ 81 | | base → s3→join/k01 82 | | loop k → λ i j m → s3→join/cube/filler i j k m 83 | ] 84 | 85 | def join-s3-join/push 86 | : (a b : s1) → 87 | [i m] join s1 s1 [ 88 | | i=0 → join-s3-join/inl a m 89 | | i=1 → s3→join/cnx b 1 m 90 | | m=0 → s3→join (join→s3/push a b i) 91 | | m=1 → push a b i 92 | ] 93 | = 94 | elim [ 95 | | base → λ b i m → s3→join/cnx b i m 96 | | loop j → λ b i m → join-s3-join/push/loop b i j m 97 | ] 98 | 99 | def join-s3-join : (c : join s1 s1) → path _ (s3→join (join→s3 c)) c = 100 | elim [ 101 | | inl a → join-s3-join/inl a 102 | | inr b → s3→join/cnx b 1 103 | | push a b i → λ m → join-s3-join/push a b i m 104 | ] 105 | 106 | -- s3-join-s3 inverse homotopy 107 | 108 | def s3-join-s3 : (d : s3) → path _ (join→s3 (s3→join d)) d = 109 | elim [ 110 | | base → refl 111 | | cube i j k → λ x → 112 | let cnx/filler (i m x : 𝕀) : s3 = 113 | comp 0 i base [∂[m] | x=1 → refl] 114 | in 115 | let k01/filler (i m x : 𝕀) : s3 = 116 | comp 1 i (cnx/filler 1 m x) [ 117 | | ∂[j] i → cnx/filler i m x 118 | | ∂[m] | x=1 → refl 119 | ] 120 | in 121 | comp 1 0 (cube i j k) [ 122 | | (i=1 | ∂[j]) m → cnx/filler i m x 123 | | (i=0 | ∂[k]) m → k01/filler i m x 124 | | x=0 m → join→s3 (s3→join/cube/filler i j k m) 125 | | x=1 → refl 126 | ] 127 | ] 128 | 129 | -- equivalence 130 | 131 | def s3→join/iso : iso s3 (join s1 s1) = 132 | (s3→join, join→s3, join-s3-join, s3-join-s3) 133 | 134 | def s3→join/equiv : equiv s3 (join s1 s1) = 135 | iso→equiv s3 (join s1 s1) s3→join/iso 136 | 137 | -- adapted from "alpha" in cubicaltt: 138 | -- https://github.com/mortberg/cubicaltt/blob/d3afca5a744a96de4831610e76d6c4b629478362/examples/brunerie2.ctt#L322 139 | 140 | def s2/merid : s1 → path s2 base base = 141 | elim [ 142 | | base → refl 143 | | loop i → λ j → surf i j 144 | ] 145 | 146 | def join→s2 : join s1 s1 → s2 = 147 | elim [ 148 | | push a b i → trans s2 (s2/merid a) (s2/merid b) i 149 | | * → base 150 | ] 151 | -------------------------------------------------------------------------------- /library/cool/sphere1-to-s1.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.bool 3 | import data.nat 4 | import data.s1 5 | import data.susp 6 | import basics.isotoequiv 7 | 8 | def sphere1 : type = sphere (suc zero) 9 | 10 | def sphere1→s1 : sphere1 → s1 = 11 | elim [ 12 | | north → base 13 | | south → base 14 | | merid b i → 15 | elim b in λ _ → path s1 base base [ 16 | | ff → λ j → loop j 17 | | tt → refl 18 | ] i 19 | ] 20 | 21 | def s1→sphere1 : s1 → sphere1 = 22 | elim [ 23 | | base → north 24 | | loop i → comp 1 0 (merid ff i) [i=0 → refl | i=1 j → merid tt j] 25 | ] 26 | 27 | def sphere1→s1→sphere1 : (s : sphere1) → path _ (s1→sphere1 (sphere1→s1 s)) s = 28 | elim [ 29 | | north → refl 30 | | south → λ j → merid tt j 31 | | merid b i → 32 | let mot (b : bool) : type = 33 | pathd (λ i → path _ (s1→sphere1 (sphere1→s1 (merid b i))) (merid b i)) refl (λ j → merid tt j) 34 | in 35 | elim b in mot [ 36 | | tt → λ i j → weak-connection/and sphere1 (λ n → merid tt n) i j 37 | | ff → λ i j → comp 1 j (merid ff i) [i=0 → refl | i=1 j → merid tt j] 38 | ] i 39 | ] 40 | 41 | def s1→sphere1→s1 : (c : s1) → path _ (sphere1→s1 (s1→sphere1 c)) c = 42 | elim [ 43 | | base → refl 44 | | loop i → λ j → comp 1 j (loop i) [∂[i] → refl] 45 | ] 46 | 47 | def sphere1→s1/equiv : equiv sphere1 s1 = 48 | iso→equiv _ _ (sphere1→s1, s1→sphere1, s1→sphere1→s1, sphere1→s1→sphere1) 49 | -------------------------------------------------------------------------------- /library/cool/torus.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.s1 3 | import data.torus 4 | import basics.isotoequiv 5 | 6 | -- cubicaltt version: https://github.com/mortberg/cubicaltt/blob/master/examples/torus.ctt 7 | -- cubical agda version: https://github.com/Saizan/cubical-demo/blob/hits-transp/examples/Cubical/Examples/Torus.agda 8 | 9 | def t2c : torus → s1 × s1 = 10 | elim [ 11 | | pt → (base, base) 12 | | p/one i → (loop i, base) 13 | | p/two i → (base, loop i) 14 | | square i j → (loop j, loop i) 15 | ] 16 | 17 | def c2t : (s1 × s1) → torus = 18 | λ [,] → -- now the goal is s1 → s1 → torus 19 | elim [ -- now the goal is s1 → torus 20 | | base → 21 | elim [ 22 | | base → pt 23 | | loop j → p/two j 24 | ] 25 | | loop i → 26 | elim [ 27 | | base → p/one i 28 | | loop j → square j i 29 | ] 30 | ] 31 | 32 | def t2c2t : (t : torus) → path torus (c2t (t2c t)) t = 33 | -- wildcard patterns call the elimination tactic, with the rhs in all cases 34 | λ * → refl 35 | 36 | def c2t2c : (cs : s1 × s1) → path (s1 × s1) (t2c (c2t cs)) cs = 37 | -- combination of wildcard pattern with sigma type inversion pattern 38 | λ (*, *) → refl 39 | 40 | def torus/s1s1/iso : iso (s1 × s1) torus = 41 | ( c2t 42 | , t2c 43 | , t2c2t 44 | , c2t2c 45 | ) 46 | 47 | def torus/s1s1/equiv : equiv (s1 × s1) torus = 48 | iso→equiv (s1 × s1) torus torus/s1s1/iso 49 | 50 | def torus/s1s1/path : path^1 type (s1 × s1) torus = 51 | ua (s1 × s1) torus torus/s1s1/equiv 52 | -------------------------------------------------------------------------------- /library/cool/ua-beta.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import basics.retract 3 | import paths.sigma 4 | import paths.equivalence 5 | 6 | -- the code in this file is adapted from yacctt and redprl 7 | 8 | -- per Dan Licata, ua and ua/beta suffice for full univalence: 9 | -- https://groups.google.com/forum/#!topic/homotopytypetheory/j2KBIvDw53s 10 | 11 | def ua/beta (A B : type) (E : equiv A B) (a : A) : path _ (coe 0 1 a in ua _ _ E) (E.fst a) = 12 | λ i → coe i 1 (E.fst a) in refl 13 | 14 | def equiv→path/based (A : type) (X : (B : type) × equiv A B) : (B : type) × path^1 type A B = 15 | ( X.fst 16 | , ua _ (X.fst) (X.snd) 17 | ) 18 | 19 | def path→equiv/based (A : type) (X : (B : type) × path^1 type A B) : (B : type) × equiv A B = 20 | ( X.fst 21 | , path→equiv _ (X.fst) (X.snd) 22 | ) 23 | 24 | def ua/retract (A B : type) : retract^1 (equiv A B) (path^1 type A B) = 25 | ( ua A B 26 | , path→equiv A B 27 | , λ E → 28 | subtype/path _ (is-equiv _ _ ) (is-equiv/prop _ _) (path→equiv _ _ (ua A B E)) E 29 | (λ i a → ua/beta A B E (coe 1 i a in λ _ → A) i) 30 | ) 31 | 32 | def ua/retract/sig (A : type) : retract^1 ((B : type) × equiv A B) ((B : type) × path^1 type A B) = 33 | ( equiv→path/based A 34 | , path→equiv/based A 35 | , λ singl i → 36 | ( singl.fst 37 | , ua/retract A (singl.fst) .snd .snd (singl.snd) i 38 | ) 39 | ) 40 | 41 | def ua/id-equiv (A : type) : path^1 _ (ua _ _ (id-equiv A)) refl = 42 | trans^1 _ 43 | (λ i → ua A A (coe 0 i (id-equiv A) in λ _ → equiv A A)) 44 | (path-retract/preserves-refl^1 _ equiv ua/retract A) 45 | 46 | -- The following is a formulation of univalence proposed by Martin Escardo: 47 | -- https://groups.google.com/forum/#!msg/homotopytypetheory/HfCB_b-PNEU/Ibb48LvUMeUJ 48 | -- See also Theorem 5.8.4 of the HoTT Book. 49 | 50 | def univalence/alt (A : type) : is-contr^1 ((B : type) × equiv A B) = 51 | retract/hlevel^1 contr 52 | ((B : type) × equiv A B) 53 | ((B : type) × path^1 type A B) 54 | (ua/retract/sig A) 55 | (path/based/contr^1 type A) 56 | -------------------------------------------------------------------------------- /library/data/bool.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | data bool where 4 | | tt 5 | | ff 6 | 7 | def not : bool → bool = 8 | elim [ tt → ff | ff → tt ] 9 | 10 | def not∘not (x : bool) : _ = 11 | not (not x) 12 | 13 | def not∘not/id/pt : (x : bool) → path _ (not∘not x) x = 14 | λ * → refl 15 | 16 | -- Dedicated to Bob ;-) 17 | def shannon (A : type) (f : bool → A) : bool → A = 18 | elim [ tt → f tt | ff → f ff ] 19 | 20 | def shannon/path (A : type) (f : bool → A) : path _ f (shannon A f) = 21 | funext _ _ f (shannon A f) (λ * → refl) 22 | -------------------------------------------------------------------------------- /library/data/int.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.nat 3 | 4 | data int where 5 | | pos (n : nat) 6 | | negsuc (n : nat) 7 | 8 | def pred : int → int = 9 | elim [ 10 | | pos n → 11 | elim n [ 12 | | zero → negsuc zero 13 | | suc n → pos n 14 | ] 15 | | negsuc n → negsuc (suc n) 16 | ] 17 | 18 | def isuc : int → int = 19 | elim [ 20 | | pos n → pos (suc n) 21 | | negsuc n → 22 | elim n [ 23 | | zero → pos zero 24 | | suc n → negsuc n 25 | ] 26 | ] 27 | 28 | def pred-isuc : (n : int) → path int (pred (isuc n)) n = 29 | elim [ 30 | | negsuc * → refl 31 | | * → refl 32 | ] 33 | 34 | def isuc-pred : (n : int) → path int (isuc (pred n)) n = 35 | elim [ 36 | | pos * → refl 37 | | * → refl 38 | ] 39 | 40 | def iplus (m n : int) : int = 41 | elim m [ 42 | | pos m → 43 | elim m [ 44 | | zero → n 45 | | suc (n → m+n) → isuc m+n 46 | ] 47 | | negsuc m → 48 | elim m [ 49 | | zero → pred n 50 | | suc (n → m+n) → pred m+n 51 | ] 52 | ] 53 | 54 | def izero : int = pos zero 55 | 56 | def iplus/unit-r : (n : int) → path int (iplus n izero) n = 57 | elim [ 58 | | pos n → 59 | elim n [ 60 | | zero → refl 61 | | suc (n → n+0) → λ i → isuc (n+0 i) 62 | ] 63 | | negsuc n → 64 | elim n [ 65 | | zero → refl 66 | | suc (n → n+0) → λ i → pred (n+0 i) 67 | ] 68 | ] 69 | 70 | def int-repr : int → nat = 71 | elim [ pos m → m | negsuc m → m ] 72 | -------------------------------------------------------------------------------- /library/data/join.red: -------------------------------------------------------------------------------- 1 | data (A B : type) ⊢ join where 2 | | inl (a : A) 3 | | inr (b : B) 4 | | push (a : A) (b : B) (i : 𝕀) [ 5 | | i=0 → inl a 6 | | i=1 → inr b 7 | ] 8 | -------------------------------------------------------------------------------- /library/data/list.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.nat 3 | 4 | data (A : type) ⊢ list where 5 | | nil 6 | | cons (x : A) (xs : list) 7 | 8 | def tail (A : type) : list A → list A = 9 | elim [ 10 | | nil → nil 11 | | cons _ xs → xs 12 | ] 13 | 14 | def length (A : type) : list A → nat = 15 | elim [ 16 | | nil → zero 17 | | cons _ (_ → n) → suc n 18 | ] 19 | 20 | def append (A : type) : list A → list A → list A = 21 | elim [ 22 | | nil → λ ys → ys 23 | | cons x (xs → ih) → λ ys → cons x (ih ys) 24 | ] 25 | 26 | def append/idn/r (A : type) : (xs : list A) → path _ (append A xs nil) xs = 27 | elim [ 28 | | nil → refl 29 | | cons x (xs → ih) → λ i → cons x (ih i) 30 | ] 31 | 32 | def append/ass (A : type) 33 | : (xs ys zs : list A) 34 | → path _ (append A xs (append A ys zs)) (append A (append A xs ys) zs) 35 | = 36 | elim [ 37 | | nil → refl 38 | | cons x (xs → xs/ih) → 39 | λ ys zs i → cons x (xs/ih ys zs i) 40 | ] 41 | 42 | def concatenate (A : type) : list (list A) → list A = 43 | elim [ 44 | | nil → nil 45 | | cons xs (_ → ih) → append A xs ih 46 | ] 47 | -------------------------------------------------------------------------------- /library/data/nat.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | data nat where 4 | | zero 5 | | suc (x : nat) 6 | 7 | def nat-pred : nat → nat = 8 | elim [ 9 | | zero → zero 10 | | suc n → n 11 | ] 12 | 13 | def nat-pred/suc (x : nat) : path nat x (nat-pred (suc x)) = 14 | refl 15 | 16 | def plus (m n : nat) : nat = 17 | elim m [ 18 | | zero → n 19 | | suc (m → plus/m/n) → suc plus/m/n 20 | ] 21 | 22 | def plus/unit/l (n : nat) : path nat (plus zero n) n = 23 | refl 24 | 25 | def plus/unit/r : (n : nat) → path nat (plus n zero) n = 26 | elim [ 27 | | zero → refl 28 | | suc (n → path/n) → λ i → suc (path/n i) 29 | ] 30 | 31 | def plus/assoc : (n m o : nat) → path nat (plus n (plus m o)) (plus (plus n m) o) = 32 | elim [ 33 | | zero → refl 34 | | suc (n → plus/assoc/n) → λ m o i → suc (plus/assoc/n m o i) 35 | ] 36 | 37 | def plus/suc/r : (n m : nat) → path nat (plus n (suc m)) (suc (plus n m)) = 38 | elim [ 39 | | zero → refl 40 | | suc (n → plus/n/suc/r) → λ m i → suc (plus/n/suc/r m i) 41 | ] 42 | 43 | 44 | def plus/comm : (m n : nat) → path nat (plus n m) (plus m n) = 45 | elim [ 46 | | zero → plus/unit/r 47 | | suc (m → plus/comm/m) → λ n → trans _ (plus/suc/r n m) (λ i → suc (plus/comm/m n i)) 48 | ] 49 | -------------------------------------------------------------------------------- /library/data/or.red: -------------------------------------------------------------------------------- 1 | data (A B : type) ⊢ or where 2 | | inl (a : A) 3 | | inr (b : B) 4 | -------------------------------------------------------------------------------- /library/data/quotient.red: -------------------------------------------------------------------------------- 1 | data (A : type) (R : A → A → type) ⊢ quotient where 2 | | pt (a : A) 3 | | gl (a b : A) (p : R a b) (i : 𝕀) [ 4 | | i=0 → pt a 5 | | i=1 → pt b 6 | ] 7 | -------------------------------------------------------------------------------- /library/data/s1.red: -------------------------------------------------------------------------------- 1 | data s1 where 2 | | base 3 | | loop (i : 𝕀) [∂[i] → base] 4 | -------------------------------------------------------------------------------- /library/data/s2.red: -------------------------------------------------------------------------------- 1 | data s2 where 2 | | base 3 | | surf (i j : 𝕀) [∂[i j] → base] 4 | -------------------------------------------------------------------------------- /library/data/s3.red: -------------------------------------------------------------------------------- 1 | data s3 where 2 | | base 3 | | cube (i j k : 𝕀) [∂[i j k] → base] 4 | -------------------------------------------------------------------------------- /library/data/smash.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | data (X Y : ptype) ⊢ smash where 4 | | basel 5 | | baser 6 | | proj (a : X .fst) (b : Y .fst) 7 | | gluel (b : Y .fst) (i : 𝕀) [i=0 → basel | i=1 → proj (X .snd) b ] 8 | | gluer (a : X .fst) (i : 𝕀) [i=0 → baser | i=1 → proj a (Y .snd) ] 9 | 10 | def smash/map (X Y Z W : ptype) (f : pmap X Z) (g : pmap Y W) : smash X Y → smash Z W = 11 | elim [ 12 | | basel → basel 13 | | baser → baser 14 | | proj a b → proj (f .fst a) (g .fst b) 15 | | gluel b i → comp 1 0 (gluel (g .fst b) i) [i=0 → refl | i=1 j → proj (f .snd j) (g .fst b) ] 16 | | gluer a i → comp 1 0 (gluer (f .fst a) i) [i=0 → refl | i=1 j → proj (f .fst a) (g .snd j) ] 17 | ] 18 | -------------------------------------------------------------------------------- /library/data/susp.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.bool 3 | import data.nat 4 | import data.s1 5 | 6 | -- adapted from https://github.com/mortberg/cubicaltt/blob/master/examples/susp.ctt 7 | 8 | data (A : type) ⊢ susp where 9 | | north 10 | | south 11 | | merid (a : A) (i : 𝕀) [ 12 | | i=0 → north 13 | | i=1 → south 14 | ] 15 | 16 | def sphere : nat → type = 17 | elim [ 18 | | zero → bool 19 | | suc (n → sphere/n) → susp sphere/n 20 | ] 21 | -------------------------------------------------------------------------------- /library/data/torus.red: -------------------------------------------------------------------------------- 1 | data torus where 2 | | pt 3 | | p/one (i : 𝕀) [∂[i] → pt] 4 | | p/two (i : 𝕀) [∂[i] → pt] 5 | | square (i j : 𝕀) 6 | [ ∂[i] → p/one j 7 | | ∂[j] → p/two i 8 | ] 9 | -------------------------------------------------------------------------------- /library/data/truncation.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | data (A : type) ⊢ trunc where 4 | | ret (a : A) 5 | | glue (x y : trunc) (i : 𝕀) [ 6 | | i=0 → x 7 | | i=1 → y 8 | ] 9 | 10 | def trunc/bind (A B : type) (f : A → trunc B) (m : trunc A) : trunc B = 11 | elim m [ 12 | | ret a → f a 13 | | glue (x → x/ih) (y → y/ih) i → glue x/ih y/ih i 14 | ] 15 | 16 | def trunc/bind/ret (A : type) : path _ (trunc/bind A A (λ a → ret a)) (λ x → x) = 17 | funext _ _ (trunc/bind A A (λ a → ret a)) (λ x → x) 18 | (elim [ 19 | | ret a → refl 20 | | glue (x → x/ih) (y → y/ih) i → 21 | λ j → glue (x/ih j) (y/ih j) i 22 | ]) 23 | 24 | def trunc/prop (A : type) : is-prop (trunc A) = 25 | λ x y i → glue x y i 26 | 27 | def trunc/map (A B : type) (f : A → B) : trunc A → trunc B = 28 | elim [ 29 | | ret a → ret (f a) 30 | | glue (x → x/ih) (y → y/ih) i → 31 | glue x/ih y/ih i 32 | ] 33 | -------------------------------------------------------------------------------- /library/data/unit.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | data unit where 4 | | ★ 5 | 6 | def unit/prop : is-prop unit = 7 | λ * * → refl 8 | 9 | def unit/contr : is-contr unit = 10 | ( ★ , λ a → unit/prop a ★ ) 11 | -------------------------------------------------------------------------------- /library/data/void.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | data void where 4 | 5 | def exfalso (A : type) : void → A = 6 | elim [] 7 | 8 | def void/prop : is-prop void = 9 | elim [] 10 | 11 | def neg (A : type) : type = 12 | A → void 13 | 14 | def neg/prop (A : type) : is-prop (neg A) = 15 | λ u v → funext A (λ _ → void) u v (λ n → elim (u n) []) -------------------------------------------------------------------------------- /library/paths/biinv-equiv.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import basics.isotoequiv 3 | import basics.retract 4 | import basics.biinv-equiv 5 | 6 | def is-biinv-equiv/prop (A B : type) (f : A → B) : is-prop (is-biinv-equiv A B f) = 7 | λ (s0,r0) (s1,r1) i → 8 | let c = iso→equiv _ _ (biinv-equiv→iso _ _ (f,s0,r0)) .snd in 9 | (equiv-section/prop A B f c s0 s1 i, equiv-retraction/prop A B f c r0 r1 i) 10 | -------------------------------------------------------------------------------- /library/paths/bool.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.void 3 | import data.unit 4 | import data.bool 5 | import basics.isotoequiv 6 | import basics.hedberg 7 | 8 | def bool-path/code : bool → bool → type = 9 | elim [ 10 | | tt → elim [tt → unit | ff → void] 11 | | ff → elim [tt → void | ff → unit] 12 | ] 13 | 14 | def bool-refl : (x : bool) → bool-path/code x x = 15 | λ * → ★ 16 | 17 | def bool-path/encode (x y : bool) (p : path bool x y) : bool-path/code x y = 18 | coe 0 1 (bool-refl x) in λ i → bool-path/code x (p i) 19 | 20 | def not/neg : (x : bool) → neg (path bool (not x) x) = 21 | λ * → bool-path/encode _ _ 22 | 23 | def not/equiv : equiv bool bool = 24 | iso→equiv _ _ (not, (not, (not∘not/id/pt, not∘not/id/pt))) 25 | 26 | def not/path : path^1 type bool bool = 27 | ua _ _ not/equiv 28 | 29 | def bool/discrete : discrete bool = 30 | elim [ 31 | | tt → 32 | elim [ 33 | | tt → inl refl 34 | | ff → inr (not/neg ff) 35 | ] 36 | | ff → 37 | elim [ 38 | | tt → inr (not/neg tt) 39 | | ff → inl refl 40 | ] 41 | ] 42 | 43 | def bool/set : is-set bool = 44 | discrete→set bool bool/discrete 45 | -------------------------------------------------------------------------------- /library/paths/equivalence.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import paths.sigma 3 | import paths.pi 4 | import paths.hlevel 5 | 6 | -- hlevels of is-equiv and equiv 7 | 8 | opaque 9 | def is-equiv/prop (A B : type) (f : A → B) : is-prop (is-equiv A B f) = 10 | λ e0 e1 i b → is-contr/prop (fiber A B f b) (e0 b) (e1 b) i 11 | 12 | -- A direct proof that is-equiv f is a prop, ported from cubicaltt to yacctt to redtt 13 | def is-equiv/prop/direct (A B : type) (f : A → B) : is-prop (is-equiv _ _ f) = 14 | λ ise ise' i y → 15 | let ((a, p), c) = ise y in 16 | let ((a', p'), c') = ise' y in 17 | 18 | ( c' (a , p) i 19 | , λ w → 20 | let mycap (j k : 𝕀) : fiber A B f y = 21 | comp 1 j (c' w k) [ 22 | | k=0 → refl 23 | | k=1 → c' w 24 | ] 25 | in 26 | let face/i0 (j k : 𝕀) : fiber A B f y = 27 | comp 0 j w [ 28 | | k=0 → mycap 0 29 | | k=1 → c w 30 | ] 31 | in 32 | λ j → 33 | comp 0 1 (mycap i j) [ 34 | | i=0 → face/i0 j 35 | | i=1 | j=0 → refl 36 | | j=1 k → c' (face/i0 1 k) i 37 | ] 38 | ) 39 | 40 | def equiv/level : (l : hlevel) (A B : type) 41 | (A/level : has-hlevel l A) (B/level : has-hlevel l B) 42 | → has-hlevel l (equiv A B) 43 | = 44 | elim [ 45 | | contr → λ A B A/contr B/contr → 46 | ( contr-equiv A B A/contr B/contr 47 | , λ e i → 48 | ( λ a → B/contr .snd (e .fst a) i 49 | , prop→prop-over (λ j → is-equiv A B (λ a → B/contr .snd (e .fst a) j)) 50 | (is-equiv/prop/direct A B (λ _ → B/contr .fst)) 51 | (e .snd) (contr-equiv A B A/contr B/contr .snd) 52 | i 53 | ) 54 | ) 55 | | hsuc l → λ A B A/level B/level → 56 | sigma/hlevel (hsuc l) (A → B) (λ f → is-equiv _ _ f) 57 | (pi/hlevel (hsuc l) A (λ _ → B) (λ _ → B/level)) 58 | (λ f → prop→hlevel l (is-equiv _ _ f) (is-equiv/prop/direct A B f)) 59 | ] 60 | -------------------------------------------------------------------------------- /library/paths/ha-equiv.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import basics.isotoequiv 3 | import basics.retract 4 | import basics.ha-equiv 5 | import paths.pi 6 | 7 | -- this is actually an equivalence, but we don't need that 8 | def lcoh/retract-of-fiber-path (A B : type) (f : A → B) (c : is-equiv A B f) 9 | (g : B → A) (f-g : (b : _) → path _ (f (g b)) b) 10 | : retract 11 | (lcoh A B f g f-g) 12 | ((a : A) → path (fiber A B f (f a)) (g (f a), f-g (f a)) (a, refl)) 13 | = 14 | ( λ (g-f,adj) a i → 15 | ( g-f a i 16 | , λ j → 17 | comp 1 0 (adj a j i) [ 18 | | i=0 k → symm/filler B (λ n → f-g (f a) n) j k 19 | | i=1 | j=0 → refl 20 | | j=1 k → weak-connection/or-not B (λ v → f-g (f a) v) i k 21 | ] 22 | ) 23 | , λ p → 24 | ( λ a i → p a i .fst 25 | , λ a j i → 26 | comp 0 1 (p a i .snd j) [ 27 | | i=0 k → symm/filler B (λ n → f-g (f a) n) j k 28 | | i=1 | j=0 → refl 29 | | j=1 k → weak-connection/or-not B (λ v → f-g (f a) v) i k 30 | ] 31 | ) 32 | , λ (g-f,adj) k → 33 | ( g-f 34 | , λ a j i → 35 | let capk : B = 36 | comp 1 k (adj a j i) [ 37 | | i=0 k → symm/filler B (λ n → f-g (f a) n) j k 38 | | i=1 | j=0 → refl 39 | | j=1 k → weak-connection/or-not B (λ v → f-g (f a) v) i k 40 | ] 41 | in 42 | comp k 1 capk [ 43 | | i=0 k → symm/filler B (λ n → f-g (f a) n) j k 44 | | i=1 | j=0 → refl 45 | | j=1 k → weak-connection/or-not B (λ v → f-g (f a) v) i k 46 | ] 47 | ) 48 | ) 49 | 50 | def equiv-lcoh/prop (A B : type) (f : A → B) (c : is-equiv A B f) 51 | (g : B → A) (f-g : (b : _) → path _ (f (g b)) b) 52 | : is-prop (lcoh A B f g f-g) 53 | = 54 | retract/hlevel prop _ _ 55 | (lcoh/retract-of-fiber-path A B f c g f-g) 56 | (pi/hlevel prop A _ 57 | (λ a → 58 | prop→set (fiber A B f (f a)) 59 | (contr→prop (fiber A B f (f a)) (c (f a))) 60 | (g (f a), f-g (f a)) (a, refl))) 61 | 62 | def is-ha-equiv/prop (A B : type) (f : A → B) : is-prop (is-ha-equiv A B f) = 63 | λ (g0,f-g0,g0-f,adj0) (g1,f-g1,g1-f,adj1) i → 64 | let c = iso→equiv _ _ (f,g0,f-g0,g0-f) .snd in 65 | let p = equiv-section/prop A B f c (g0,f-g0) (g1,f-g1) in 66 | let q = prop→prop-over (λ i → lcoh A B f (p i .fst) (p i .snd)) 67 | (equiv-lcoh/prop A B f c g1 f-g1) (g0-f,adj0) (g1-f,adj1) 68 | in 69 | (p i .fst, p i .snd, q i .fst, q i .snd) 70 | 71 | 72 | -------------------------------------------------------------------------------- /library/paths/hlevel.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.unit 3 | import basics.isotoequiv 4 | import paths.sigma 5 | import paths.pi 6 | 7 | def prop/unit (A : type) (A/prop : is-prop A) (x0 : A) : equiv A unit = 8 | iso→equiv A unit (λ _ → ★, λ _ → x0, unit/prop ★, A/prop x0) 9 | 10 | def prop/equiv (P Q : type) (P/prop : is-prop P) (Q/prop : is-prop Q) (f : P → Q) (g : Q → P) : equiv P Q = 11 | iso→equiv P Q (f, g, λ p → Q/prop (f (g p)) p, λ q → P/prop (g (f q)) q) 12 | 13 | def contr-equiv (A B : type) (A/contr : is-contr A) (B/contr : is-contr B) 14 | : equiv A B 15 | = 16 | ( λ _ → B/contr .fst 17 | , λ b → 18 | ( (A/contr .fst, symm B (B/contr .snd b)) 19 | , λ (a,p) i → 20 | ( A/contr .snd a i 21 | , raise-hlevel prop B (raise-hlevel contr B B/contr) 22 | (B/contr .fst) b p (symm B (B/contr .snd b)) i 23 | ) 24 | ) 25 | ) 26 | 27 | def is-contr/prop (A : type) : is-prop (is-contr A) = 28 | λ A/contr → 29 | let A/prop : is-prop A = raise-hlevel contr A A/contr in 30 | sigma/hlevel prop _ (λ a → (b : A) → path A b a) A/prop 31 | (λ a → pi/hlevel prop A (λ b → path A b a) (λ b → prop→set _ A/prop b a)) 32 | A/contr 33 | 34 | def has-hlevel/prop : (l : hlevel) (A : type) → is-prop (has-hlevel l A) = 35 | elim [ 36 | | contr → is-contr/prop 37 | | hsuc l → elim l [ 38 | | contr → λ A A/prop A/prop' i a a' → 39 | prop→set A A/prop a a' (A/prop a a') (A/prop' a a') i 40 | | hsuc (l → l/ih) → λ A A/level A/level' i a a' → 41 | l/ih (path A a a') (A/level a a') (A/level' a a') i 42 | ] 43 | ] 44 | -------------------------------------------------------------------------------- /library/paths/int.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.void 3 | import data.nat 4 | import data.int 5 | import basics.isotoequiv 6 | import basics.hedberg 7 | import paths.nat 8 | 9 | def isuc/equiv : equiv int int = 10 | iso→equiv _ _ (isuc, (pred, (isuc-pred, pred-isuc))) 11 | 12 | def int-path/code : int → int → type = 13 | elim [ 14 | | pos m → λ y → 15 | elim y [ 16 | | pos n → nat/path/code m n 17 | | negsuc _ → void 18 | ] 19 | | negsuc m → λ y → 20 | elim y [ 21 | | pos _ → void 22 | | negsuc n → nat/path/code m n 23 | ] 24 | ] 25 | 26 | def int-refl : (x : int) → int-path/code x x = 27 | elim [ 28 | | pos m → nat-refl m 29 | | negsuc m → nat-refl m 30 | ] 31 | 32 | def int-path/encode (x y : int) (p : path int x y) 33 | : int-path/code x y 34 | = 35 | coe 0 1 (int-refl x) in λ i → int-path/code x (p i) 36 | 37 | def int/discrete : discrete int = 38 | elim [ 39 | | pos m → 40 | elim [ 41 | | pos n → 42 | elim (nat/discrete m n) [ 43 | | inl l → inl (λ i → pos (l i)) 44 | | inr r → inr (λ p → r (λ i → int-repr (p i))) 45 | ] 46 | | negsuc n → inr (int-path/encode _ _) 47 | ] 48 | | negsuc m → 49 | elim [ 50 | | pos n → inr (int-path/encode _ _) 51 | | negsuc n → 52 | elim (nat/discrete m n) [ 53 | | inl l → inl (λ i → negsuc (l i)) 54 | | inr r → inr (λ p → r (λ i → int-repr (p i))) 55 | ] 56 | ] 57 | ] 58 | 59 | def int/set : is-set int = 60 | discrete→set int int/discrete 61 | -------------------------------------------------------------------------------- /library/paths/list.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.void 3 | import data.unit 4 | import data.list 5 | import basics.retract 6 | import paths.sigma 7 | 8 | def list/code (A : type) : list A → list A → type = 9 | elim [ 10 | | nil → 11 | elim [ 12 | | nil → unit 13 | | cons _ _ → void 14 | ] 15 | | cons x (xs → code/xs) → 16 | elim [ 17 | | nil → void 18 | | cons y ys → path A x y × code/xs ys 19 | ] 20 | ] 21 | 22 | def list/refl (A : type) : (xs : list A) → list/code A xs xs = 23 | elim [ 24 | | nil → ★ 25 | | cons x (xs → refl/xs) → (refl, refl/xs) 26 | ] 27 | 28 | def list/encode (A : type) (xs ys : list A) (q : path (list A) xs ys) : list/code A xs ys = 29 | coe 0 1 (list/refl A xs) in λ i → list/code A xs (q i) 30 | 31 | def list/encode/refl (A : type) (xs : list A) 32 | : path (list/code A xs xs) (list/encode A xs xs refl) (list/refl A xs) 33 | = 34 | λ i → coe i 1 (list/refl A xs) in λ i → list/code A xs xs 35 | 36 | def list/decode (A : type) : (xs ys : list A) → list/code A xs ys → path (list A) xs ys = 37 | elim [ 38 | | nil → 39 | elim [ 40 | | nil → refl 41 | | cons _ _ → elim [] 42 | ] 43 | | cons x (xs → decode/xs) → 44 | elim [ 45 | | nil → elim [] 46 | | cons y ys → λ (p, c) i → cons (p i) (decode/xs ys c i) 47 | ] 48 | ] 49 | 50 | def list/decode/refl (A : type) 51 | : (xs : list A) → path (path (list A) xs xs) (list/decode A xs xs (list/refl A xs)) refl 52 | = 53 | elim [ 54 | | nil → refl 55 | | cons x (xs → decode/refl/xs) → λ i j → cons x (decode/refl/xs i j) 56 | ] 57 | 58 | def list/decode-encode/refl (A : type) (xs : list A) 59 | : path (path (list A) xs xs) (list/decode A xs xs (list/encode A xs xs refl)) refl 60 | = 61 | trans (path (list A) xs xs) 62 | (λ i → list/decode A xs xs (list/encode/refl A xs i)) 63 | (list/decode/refl A xs) 64 | 65 | def list/decode-encode (A : type) (xs ys : list A) (q : path (list A) xs ys) 66 | : path (path (list A) xs ys) (list/decode A xs ys (list/encode A xs ys q)) q 67 | = 68 | J _ q 69 | (λ q → path (path (list A) xs (q 1)) (list/decode A xs (q 1) (list/encode A xs (q 1) q)) q) 70 | (list/decode-encode/refl A xs) 71 | 72 | def list/encode/cons (A : type) (x y : A) (p : path A x y) (xs ys : list A) (q : path (list A) xs ys) 73 | : path (list/code A (cons x xs) (cons y ys)) 74 | (list/encode A (cons x xs) (cons y ys) (λ i → cons (p i) (q i))) 75 | (p, list/encode A xs ys q) 76 | = 77 | λ i → 78 | coe i 1 79 | ( λ j → weak-connection/and A p i j 80 | , coe 0 i (list/refl A xs) in λ i → list/code A xs (q i) 81 | ) 82 | in 83 | λ i → list/code A (cons x xs) (cons (p i) (q i)) 84 | 85 | def list/encode-decode (A : type) 86 | : (xs ys : list A) (c : list/code A xs ys) 87 | → path (list/code A xs ys) (list/encode A xs ys (list/decode A xs ys c)) c 88 | = 89 | elim [ 90 | | nil → λ * * → refl 91 | | cons x (xs → encode-decode/xs) → 92 | elim [ 93 | | nil → elim [] 94 | | cons y ys → λ (p, c) → 95 | trans (path A x y × list/code A xs ys) 96 | (list/encode/cons A x y p xs ys (list/decode A xs ys c)) 97 | (λ i → (p, encode-decode/xs ys c i)) 98 | ] 99 | ] 100 | 101 | -- list preserves hlevels >= set 102 | 103 | def list/code/hlevel (l : hlevel) (A : type) (A/level : has-hlevel (hsuc (hsuc l)) A) 104 | : (xs ys : list A) → has-hlevel (hsuc l) (list/code A xs ys) 105 | = 106 | elim [ 107 | | nil → 108 | elim [ 109 | | nil → prop→hlevel l unit unit/prop 110 | | cons y ys → prop→hlevel l void void/prop 111 | ] 112 | | cons x (xs → xs/ih) → 113 | elim [ 114 | | nil → prop→hlevel l void void/prop 115 | | cons y ys → 116 | sigma/hlevel (hsuc l) (path A x y) (λ _ → list/code A xs ys) 117 | (A/level x y) 118 | (λ _ → xs/ih ys) 119 | ] 120 | ] 121 | 122 | def list/hlevel (l : hlevel) (A : type) (A/level : has-hlevel (hsuc (hsuc l)) A) 123 | : has-hlevel (hsuc (hsuc l)) (list A) = 124 | λ xs ys → 125 | retract/hlevel (hsuc l) 126 | (path (list A) xs ys) 127 | (list/code A xs ys) 128 | (list/encode A xs ys, list/decode A xs ys, list/decode-encode A xs ys) 129 | (list/code/hlevel l A A/level xs ys) 130 | 131 | -------------------------------------------------------------------------------- /library/paths/nat.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.void 3 | import data.unit 4 | import data.nat 5 | import basics.hedberg 6 | 7 | def nat/path/code : nat → nat → type = 8 | elim [ 9 | | zero → 10 | elim [ 11 | | zero → unit 12 | | suc _ → void 13 | ] 14 | | suc (m' → code/m') → 15 | elim [ 16 | | zero → void 17 | | suc n' → code/m' n' 18 | ] 19 | ] 20 | 21 | def nat-refl : (m : nat) → nat/path/code m m = 22 | elim [ 23 | | zero → ★ 24 | | suc (m' → nat-refl/m') → nat-refl/m' 25 | ] 26 | 27 | def nat-path/encode (m n : nat) (p : path nat m n) 28 | : nat/path/code m n 29 | = 30 | coe 0 1 (nat-refl m) in λ i → nat/path/code m (p i) 31 | 32 | def nat/discrete : discrete nat = 33 | elim [ 34 | | zero → 35 | elim [ 36 | | zero → inl refl 37 | | suc n' → inr (nat-path/encode zero (suc n')) 38 | ] 39 | | suc (m' → nat/discrete/m') → 40 | elim [ 41 | | zero → inr (nat-path/encode (suc m') zero) 42 | | suc n' → 43 | elim (nat/discrete/m' n') [ 44 | | inl l → inl (λ i → suc (l i)) 45 | | inr r → inr (λ p → r (λ i → nat-pred (p i))) 46 | ] 47 | ] 48 | ] 49 | 50 | def nat/set : is-set nat = 51 | discrete→set nat nat/discrete 52 | -------------------------------------------------------------------------------- /library/paths/pi.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import basics.isotoequiv 3 | import basics.retract 4 | 5 | def pi/path (A : type) (B : A → type) (f f' : (a : A) → B a) 6 | : equiv ((a : A) → path (B a) (f a) (f' a)) (path ((a : A) → B a) f f') 7 | = 8 | iso→equiv 9 | ((a : A) → path (B a) (f a) (f' a)) 10 | (path ((a : A) → B a) f f') 11 | ( λ g i a → g a i 12 | , λ p a i → p i a 13 | , λ _ → refl 14 | , λ _ → refl 15 | ) 16 | 17 | def pi/hlevel : (l : hlevel) (A : type) (B : A → type) 18 | (B/level : (a : A) → has-hlevel l (B a)) 19 | → has-hlevel l ((a : A) → B a) 20 | = 21 | elim [ 22 | | contr → λ A B B/contr → (λ a → B/contr a .fst, λ f i a → B/contr a .snd (f a) i) 23 | | hsuc l → 24 | elim l [ 25 | | contr → λ A B B/prop f f' i a → B/prop a (f a) (f' a) i 26 | | hsuc (l → l/ih) → λ A B B/level f f' → 27 | retract/hlevel (hsuc l) 28 | (path ((a : A) → B a) f f') 29 | ((a : A) → path (B a) (f a) (f' a)) 30 | ( λ p a i → p i a 31 | , λ g i a → g a i 32 | , λ _ → refl 33 | ) 34 | (l/ih A (λ a → path (B a) (f a) (f' a)) (λ a → B/level a (f a) (f' a))) 35 | ] 36 | ] 37 | -------------------------------------------------------------------------------- /library/paths/s1.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.s1 3 | import data.int 4 | import basics.isotoequiv 5 | import basics.retract 6 | import paths.pi 7 | import paths.int 8 | import paths.hlevel 9 | 10 | def s1-univ-cover : s1 → type = 11 | elim [ 12 | | base → int 13 | | loop i → ua _ _ isuc/equiv i 14 | ] 15 | 16 | def Ω1s1 : type = path s1 base base 17 | 18 | def loopn : int → Ω1s1 = 19 | elim [ 20 | | pos n → 21 | elim n [ 22 | | zero → refl 23 | | suc (n → loopn) → 24 | -- this is trans, but let's expand the definition 25 | λ i → comp 0 1 (loopn i) [ i=0 → refl | i=1 j → loop j ] 26 | ] 27 | | negsuc n → 28 | elim n [ 29 | | zero → 30 | λ i → comp 1 0 base [ i=0 → refl | i=1 j → loop j ] 31 | | suc (n → loopn) → 32 | λ i → comp 1 0 (loopn i) [ i=0 → refl | i=1 j → loop j ] 33 | ] 34 | ] 35 | 36 | def encode (x : s1) (p : path s1 base x) : s1-univ-cover x = 37 | coe 0 1 (pos zero) in λ i → s1-univ-cover (p i) 38 | 39 | def winding (l : path s1 base base) : int = encode base l 40 | 41 | def winding-loopn : (n : int) → path int (winding (loopn n)) n = 42 | elim [ 43 | | pos n → 44 | elim n [ 45 | | zero → refl 46 | | suc (n → loopn) → λ i → isuc (loopn i) 47 | ] 48 | | negsuc n → 49 | elim n [ 50 | | zero → refl 51 | | suc (n → loopn) → λ i → pred (loopn i) 52 | ] 53 | ] 54 | 55 | def decode-square 56 | : (n : int) 57 | → [i j] s1 [ 58 | | i=0 → loopn (pred n) j 59 | | i=1 → loopn n j 60 | | j=0 → base 61 | | j=1 → loop i 62 | ] 63 | = 64 | elim [ 65 | | pos n → 66 | elim n [ 67 | | zero → λ i j → comp 1 i base [ j=0 → refl | j=1 i → loop i ] 68 | | suc n → λ i j → comp 0 i (loopn (pos n) j) [ j=0 → refl | j=1 i → loop i ] 69 | ] 70 | | negsuc n → λ i j → comp 1 i (loopn (negsuc n) j) [ j=0 → refl | j=1 i → loop i ] 71 | ] 72 | 73 | def decode : (x : s1) → s1-univ-cover x → path s1 base x = 74 | elim [ 75 | | base → loopn 76 | | loop i → λ y j → 77 | let n : int = y .vproj in 78 | comp 0 1 (decode-square n i j) [ 79 | | ∂[j] | i=1 → refl 80 | | i=0 k → loopn (pred-isuc y k) j 81 | ] 82 | ] 83 | 84 | def loopn-winding (l : Ω1s1) : path _ (loopn (winding l)) l = 85 | J _ l (λ p → path (path s1 base (p 1)) (decode (p 1) (encode (p 1) p)) p) refl 86 | 87 | def winding/equiv : equiv Ω1s1 int = 88 | iso→equiv _ _ (winding, (loopn, (winding-loopn, loopn-winding))) 89 | 90 | def winding/path : path^1 _ Ω1s1 int = 91 | ua Ω1s1 int winding/equiv 92 | 93 | opaque 94 | def Ω1s1/set : has-hlevel set Ω1s1 = 95 | retract/hlevel set Ω1s1 int (winding, loopn, loopn-winding) int/set 96 | 97 | opaque 98 | def s1/groupoid : is-groupoid s1 = 99 | let from-base : (s : s1) → is-set (path s1 base s) = 100 | elim [ 101 | | base → Ω1s1/set 102 | | loop i → 103 | prop→prop-over (λ j → is-set (path s1 base (loop j))) 104 | (has-hlevel/prop set Ω1s1) 105 | Ω1s1/set Ω1s1/set i 106 | ] 107 | in 108 | elim [ 109 | | base → from-base 110 | | loop i → 111 | prop→prop-over (λ j → (s : s1) → is-set (path s1 (loop j) s)) 112 | (pi/hlevel prop s1 (λ s → is-set (path s1 base s)) 113 | (λ s → has-hlevel/prop set (path s1 base s))) 114 | from-base from-base i 115 | ] 116 | -------------------------------------------------------------------------------- /library/paths/sigma.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import basics.isotoequiv 3 | import basics.retract 4 | 5 | def sigma/assoc (A : type) (B : A → type) (C : ((x : A) × B x) → type) 6 | : equiv ((x : A) × (y : B x) × C (x, y)) ((p : ((x : A) × B x)) × C p) 7 | = 8 | ( λ x → ((x.fst, x.snd.fst), x.snd.snd) 9 | , λ b → ( ((b.fst.fst, b.fst.snd, b.snd), refl) 10 | , λ c i → 11 | ( ((c.snd i).fst.fst, (c.snd i).fst.snd, (c.snd i).snd) 12 | , λ j → weak-connection/or _ (c.snd) i j 13 | ) 14 | ) 15 | ) 16 | 17 | def sigma/contr/equiv/fst (A : type) (P : A → type) (P/contr : (x : A) → is-contr (P x)) 18 | : equiv ((x : A) × P x) A 19 | = 20 | iso→equiv ((x : A) × P x) A 21 | ( λ s → s.fst 22 | , λ x → (x, (P/contr x).fst) 23 | , refl 24 | , λ s i → (s.fst, symm _ ((P/contr (s.fst)).snd (s.snd)) i) 25 | ) 26 | 27 | def sigma/path (A : type) (B : A → type) (a : A) (b : B a) (a' : A) (b' : B a') 28 | : equiv ((p : path A a a') × pathd (λ i → B (p i)) b b') (path ((a : A) × B a) (a,b) (a',b')) 29 | = 30 | iso→equiv 31 | ((p : path A a a') × pathd (λ i → B (p i)) b b') 32 | (path ((a : A) × B a) (a,b) (a',b')) 33 | ( λ (p,q) i → (p i, q i) 34 | , λ r → (λ i → r i .fst, λ i → r i .snd) 35 | , λ _ → refl 36 | , λ _ → refl 37 | ) 38 | 39 | def sigma/hlevel : (l : hlevel) (A : type) (B : A → type) 40 | (A/level : has-hlevel l A) (B/level : (a : A) → has-hlevel l (B a)) 41 | → has-hlevel l ((a : A) × B a) 42 | = 43 | elim [ 44 | | contr → λ A B A/contr B/contr → 45 | ( (A/contr .fst, B/contr (A/contr .fst) .fst) 46 | , λ (a,b) i → 47 | ( A/contr .snd a i 48 | , B/contr (A/contr .snd a i) .snd 49 | (coe 0 i b in λ j → B (A/contr .snd a j)) 50 | i 51 | ) 52 | ) 53 | | hsuc l → 54 | elim l [ 55 | | contr → λ A B A/prop B/prop (a,b) (a',b') i → 56 | let A/path = A/prop a a' in 57 | (A/path i, prop→prop-over (λ j → B (A/path j)) (B/prop a') b b' i) 58 | | hsuc (l → l/ih) → λ A B A/level B/level (a,b) (a',b') → 59 | retract/hlevel (hsuc l) 60 | (path ((a : A) × B a) (a,b) (a',b')) 61 | ((p : path A a a') × pathd (λ i → B (p i)) b b') 62 | ( λ r → (λ i → r i .fst, λ i → r i .snd) 63 | , λ (p,q) i → (p i, q i) 64 | , λ _ → refl 65 | ) 66 | (l/ih (path A a a') (λ p → pathd (λ i → B (p i)) b b') 67 | (A/level a a') (λ p → pathd/hlevel (hsuc l) A B p (B/level a') b b')) 68 | ] 69 | ] 70 | 71 | def subtype/path 72 | (A : type) (B : A → type) 73 | (B/prop : (a : A) → is-prop (B a)) 74 | (u v : (a : A) × B a) 75 | (P : path A (u.fst) (v.fst)) 76 | : path ((a : A) × B a) u v 77 | = 78 | λ i → 79 | ( P i 80 | , prop→prop-over (λ i → B (P i)) (B/prop (P 1)) (u.snd) (v.snd) i 81 | ) 82 | -------------------------------------------------------------------------------- /library/paths/truncation.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import basics.isotoequiv 3 | import data.truncation 4 | import paths.hlevel 5 | 6 | def prop/trunc (A : type) (A/prop : is-prop A) : equiv A (trunc A) = 7 | prop/equiv _ _ A/prop (trunc/prop A) 8 | (λ x → ret x) (elim [ ret a → a | glue (x → x/ih) (y → y/ih) i → A/prop x/ih y/ih i ]) 9 | 10 | def unique-choice (A : type) (P : A → type) 11 | (P/prop : (x : A) → is-prop (P x)) (P/trunc : (x : A) → trunc (P x)) 12 | : (x : A) → P x 13 | = 14 | λ x → coe 0 1 (P/trunc x) in symm^1 _ (ua _ _ (prop/trunc (P x) (P/prop x))) 15 | -------------------------------------------------------------------------------- /library/pointed/bool.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.bool 3 | import basics.isotoequiv 4 | 5 | def pbool : ptype = (bool, tt) 6 | 7 | def from-pbool (pA : ptype) : pequiv (p→ pbool pA) pA = 8 | let fwd : pmap (p→ pbool pA) pA = 9 | (λ f → f.fst ff , refl) 10 | in 11 | 12 | let bwd (a : pA.fst) : pmap pbool pA = 13 | ( elim [ tt → pA.snd | ff → a ] 14 | , refl 15 | ) 16 | in 17 | 18 | let bwdfwd (f : pmap pbool pA) : path _ (bwd (fwd.fst f)) f = 19 | let bwdfwd/pt (i j : 𝕀) : pA.fst = 20 | comp 1 j (pA.snd) [ 21 | | i=0 → refl 22 | | i=1 → f.snd 23 | ] 24 | in 25 | let bwdfwd/map : (b : bool) → path _ (bwd (fwd.fst f) .fst b) (f.fst b) = 26 | elim [ 27 | | tt → λ i → bwdfwd/pt i 0 28 | | ff → refl 29 | ] 30 | in 31 | λ i → (λ b → bwdfwd/map b i, bwdfwd/pt i) 32 | in 33 | (fwd, iso→equiv _ _ (fwd.fst, bwd, refl, bwdfwd) .snd) 34 | -------------------------------------------------------------------------------- /library/pointed/loops.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | def pΩ (pA : ptype) : ptype = 4 | ( path _ (pA.snd) (pA.snd) 5 | , refl 6 | ) 7 | 8 | def pΩ/map (pA pB : ptype) (pf : pmap pA pB) : pmap (pΩ pA) (pΩ pB) = 9 | ( λ p i → comp 0 1 (pf.fst (p i)) [∂[i] → pf.snd] 10 | , λ j i → comp j 1 (pf.snd j) [∂[i] → pf.snd] 11 | ) 12 | 13 | def pΩ/map/trans (pA pB : ptype) (pf : pmap pA pB) (p q : pΩ pA .fst) 14 | : path _ 15 | (pΩ/map pA pB pf .fst (trans _ p q)) 16 | (trans _ 17 | (pΩ/map pA pB pf .fst p) 18 | (pΩ/map pA pB pf .fst q)) 19 | = 20 | let face : [i j] (pB.fst) [i=0 → pB.snd] = 21 | λ i j → 22 | comp 0 1 (pf .fst (comp 0 j (p i) [i=0 → refl | i=1 → q])) 23 | [ i=0 → pf.snd 24 | | i=1 k → comp 0 k (pf .fst (q j)) [∂[j] → pf.snd] 25 | ] 26 | in 27 | λ k i → 28 | comp 0 1 (face i 0) [ 29 | | i=0 j → pB.snd 30 | | (k=0 | i=1) j → face i j 31 | ] 32 | -------------------------------------------------------------------------------- /library/pointed/unit.red: -------------------------------------------------------------------------------- 1 | import prelude 2 | import data.unit 3 | 4 | def punit : ptype = (unit, ★) 5 | -------------------------------------------------------------------------------- /library/prelude.red: -------------------------------------------------------------------------------- 1 | public import prelude.path 2 | public import prelude.connection 3 | public import prelude.hlevel 4 | public import prelude.equivalence 5 | public import prelude.univalence 6 | public import prelude.pointed 7 | -------------------------------------------------------------------------------- /library/prelude/connection.red: -------------------------------------------------------------------------------- 1 | import prelude.path 2 | 3 | def connection/or 4 | (A : type) 5 | (p : 𝕀 → A) 6 | : [i j] A [ 7 | | j=0 | i=j → p i 8 | | j=1 | i=1 → p 1 9 | | i=0 → p j 10 | ] 11 | = 12 | λ i j → 13 | /- this is an example of something that is much nicer here than in redprl. 14 | we can define using line types all the faces of the composition at once. 15 | definitional equivalence kicks in to make this work. 16 | -/ 17 | let face (l k : 𝕀) : A = 18 | comp 1 l (p 1) [ 19 | | k=1 → refl 20 | | k=0 → p 21 | ] 22 | in 23 | comp 1 0 (p 1) [ 24 | | i=0 → face j 25 | | j=0 | i=j → face i 26 | | i=1 | j=1 → refl 27 | ] 28 | 29 | def connection/and 30 | (A : type) 31 | (p : 𝕀 → A) 32 | : [i j] A [ 33 | | j=0 | i=0 → p 0 34 | | j=1 | i=j → p i 35 | | i=1 → p j 36 | ] 37 | = 38 | λ i j → 39 | let face (l k : 𝕀) : A = 40 | comp 0 l (p 0) [ 41 | | k=0 → refl 42 | | k=1 → p 43 | ] 44 | in 45 | comp 0 1 (p 0) [ 46 | | i=0 | j=0 → refl 47 | | i=1 → face j 48 | | j=1 | i=j → face i 49 | ] 50 | 51 | def connection/both 52 | (A : type) 53 | (p : 𝕀 → A) (q : [k] A [k=0 → p 1]) 54 | : [i j] A [ 55 | | i=0 → p j 56 | | i=1 → q j 57 | | j=0 → p i 58 | | j=1 → q i 59 | ] 60 | = 61 | λ i j → 62 | let pface (m k : 𝕀) : A = 63 | comp 1 m (p 1) [ 64 | | k=0 → refl 65 | | k=1 → p 66 | ] 67 | in 68 | let qface (m k : 𝕀) : A = 69 | comp 0 m (p 1) [ 70 | | k=0 → refl 71 | | k=1 → q 72 | ] 73 | in 74 | comp 0 1 (p 1) [ 75 | | i=0 → pface j 76 | | i=1 → qface j 77 | | j=0 → pface i 78 | | j=1 → qface i 79 | ] 80 | 81 | def weak-connection/or 82 | (A : type) 83 | (p : 𝕀 → A) 84 | : [i j] A [ 85 | | i=0 → p j 86 | | j=0 → p i 87 | | i=1 | j=1 → p 1 88 | ] 89 | = 90 | λ i j → 91 | let face (l k : 𝕀) : A = 92 | comp 1 l (p 1) [ 93 | | k=1 → refl 94 | | k=0 → p 95 | ] 96 | in 97 | comp 1 0 (p 1) [ 98 | | i=0 → face j 99 | | j=0 → face i 100 | | i=1 | j=1 → refl 101 | ] 102 | 103 | def weak-connection/and 104 | (A : type) 105 | (p : 𝕀 → A) 106 | : [i j] A [ 107 | | i=0 | j=0 → p 0 108 | | i=1 → p j 109 | | j=1 → p i 110 | ] 111 | = 112 | λ i j → 113 | let face (l k : 𝕀) : A = 114 | comp 0 l (p 0) [ 115 | | k=0 → refl 116 | | k=1 → p 117 | ] 118 | in 119 | comp 0 1 (p 0) [ 120 | | i=0 | j=0 → refl 121 | | i=1 → face j 122 | | j=1 → face i 123 | ] 124 | 125 | def weak-connection/or-not -- i \/ ~j 126 | (A : type) 127 | (p : 𝕀 → A) 128 | : [i j] A [ 129 | | i=0 → symm A p j 130 | | i=1 | j=0 → p 1 131 | | j=1 → p i 132 | ] 133 | = 134 | λ i j → 135 | comp 0 1 (p 0) [ 136 | | j=0 | i=1 → p 137 | | j=1 k → connection/and A p i k 138 | ] 139 | 140 | 141 | -------------------------------------------------------------------------------- /library/prelude/equivalence.red: -------------------------------------------------------------------------------- 1 | import prelude.path 2 | import prelude.connection 3 | import prelude.hlevel 4 | 5 | def fiber (A B : type) (f : A → B) (b : B) : type = 6 | (a : _) × path _ (f a) b 7 | 8 | def is-equiv (A B : type) (f : A → B) : type = 9 | (b : B) → is-contr (fiber _ _ f b) 10 | 11 | def equiv (A B : type) : type = 12 | (f : A → B) × is-equiv _ _ f 13 | 14 | -- identity equivalences 15 | 16 | def id-equiv (A : type) : equiv A A = 17 | ( λ a → a 18 | , λ a → 19 | ( (a, refl) 20 | , λ p i → 21 | let aux (j : 𝕀) : A = 22 | comp 1 j a [ 23 | | i=0 → p.snd 24 | | i=1 → refl 25 | ] 26 | in 27 | (aux 0, aux) 28 | ) 29 | ) 30 | 31 | def id-equiv/weak-connection (B : type) : equiv B B = 32 | ( λ b → b 33 | , λ b → 34 | ( (b, refl) 35 | , λ v i → (v.snd i, λ j → weak-connection/or B (v.snd) i j) 36 | ) 37 | ) 38 | 39 | def path→equiv (A B : type) (P : path^1 type A B) : equiv A B = 40 | coe 0 1 (id-equiv A) in λ i → equiv A (P i) 41 | -------------------------------------------------------------------------------- /library/prelude/hlevel.red: -------------------------------------------------------------------------------- 1 | import prelude.path 2 | import prelude.connection 3 | 4 | def is-contr (C : type) : type = 5 | (c : _) × (c' : _) → path C c' c 6 | 7 | /- 8 | let is-param-contr-over (A : type) (B : A → type) : type = 9 | (c : (a : _) → B a) × (a : 𝕀 → A) (c' : B (a 0)) → pathd (λ i → B (a i)) c' (c (a 1)) 10 | -/ 11 | 12 | def is-prop (C : type) : type = 13 | (c c' : _) 14 | → path C c c' 15 | 16 | data hlevel where 17 | | contr 18 | | hsuc (l : hlevel) 19 | 20 | def has-hlevel : hlevel → type → type = 21 | elim [ 22 | | contr → is-contr 23 | | hsuc l → 24 | elim l [ 25 | | contr → is-prop 26 | | hsuc (l → l/ih) → λ A → (a a' : A) → l/ih (path _ a a') 27 | ] 28 | ] 29 | 30 | def prop : hlevel = hsuc contr 31 | def set : hlevel = hsuc prop 32 | def groupoid : hlevel = hsuc set 33 | 34 | def is-set = has-hlevel set 35 | def is-groupoid = has-hlevel groupoid 36 | 37 | def type/of-level (l : hlevel) : type^1 = (A : type) × has-hlevel l A 38 | def type/prop = type/of-level prop 39 | def type/set = type/of-level set 40 | def type/groupoid = type/of-level groupoid 41 | 42 | -- lower hlevels imply higher hlevels 43 | 44 | def contr→prop (A : type) (A/contr : is-contr A) : is-prop A = 45 | λ a a' → trans A (A/contr .snd a) (symm A (A/contr .snd a')) 46 | 47 | def prop→set (A : type) (A/prop : is-prop A) : is-set A = 48 | λ a b p q i j → 49 | comp 0 1 a [ 50 | | ∂[j] → A/prop a (p j) 51 | | i=0 → A/prop a (p j) 52 | | i=1 → A/prop a (q j) 53 | ] 54 | 55 | def raise-hlevel : (l : hlevel) (A : type) → has-hlevel l A → has-hlevel (hsuc l) A = 56 | elim [ 57 | | contr → contr→prop 58 | | hsuc l → 59 | elim l [ 60 | | contr → prop→set 61 | | hsuc (l → l/ih) → λ A A/level a a' → l/ih (path _ a a') (A/level a a') 62 | ] 63 | ] 64 | 65 | def prop→hlevel : (l : hlevel) (A : type) → is-prop A → has-hlevel (hsuc l) A = 66 | elim [ 67 | | contr → λ _ A/prop → A/prop 68 | | hsuc (l → l/ih) → λ A A/prop → raise-hlevel (hsuc l) A (l/ih A A/prop) 69 | ] 70 | 71 | -- propositional type lines 72 | 73 | def is-prop-over (A : 𝕀 → type) : type = 74 | (a : A 0) → (b : A 1) → pathd A a b 75 | 76 | def prop→prop-over (A : 𝕀 → type) (p : is-prop (A 1)) 77 | : is-prop-over A 78 | = 79 | λ a b i → 80 | comp 0 1 (coe 0 i a in A) [ 81 | | i=0 → refl 82 | | i=1 → p (coe 0 1 a in A) b 83 | ] 84 | 85 | -- hlevel of path types 86 | 87 | def path/hlevel 88 | : (l : hlevel) (A : type) (A/level : has-hlevel (hsuc l) A) (a a' : A) 89 | → has-hlevel l (path _ a a') 90 | = 91 | elim [ 92 | | contr → λ A A/prop a a' → 93 | (A/prop a a', λ p → prop→set A A/prop a a' p (A/prop a a')) 94 | | hsuc l → λ A A/level a a' → A/level a a' 95 | ] 96 | 97 | def pathd/hlevel (l : hlevel) (A : type) (B : A → type) (p : 𝕀 → A) 98 | (B/level : has-hlevel (hsuc l) (B (p 1))) 99 | (b : B (p 0)) (b' : B (p 1)) 100 | : has-hlevel l (pathd (λ i → B (p i)) b b') 101 | = 102 | coe 1 0 (path/hlevel l (B (p 1)) B/level (coe 0 1 b in λ j → B (p j)) b') in λ i → 103 | has-hlevel l 104 | (pathd (λ j → weak-connection/or^1 type (λ n → B (p n)) i j) 105 | (coe 0 i b in λ j → B (p j)) 106 | b') 107 | 108 | def path/based/contr (A : type) (a : A) 109 | : is-contr ((x : _) × path _ a x) = 110 | ( (a, refl) 111 | , λ x i → 112 | let aux (j : dim) : A = 113 | comp 0 j a [ 114 | | i=0 → x.snd 115 | | i=1 → refl 116 | ] 117 | in 118 | (aux 1, aux) 119 | ) 120 | -------------------------------------------------------------------------------- /library/prelude/path.red: -------------------------------------------------------------------------------- 1 | def pathd (A : 𝕀 → type) (M : A 0) (N : A 1) : type = 2 | [i] A i [ 3 | | i=0 → M 4 | | i=1 → N 5 | ] 6 | 7 | def path (A : type) (M N : A) : type = 8 | [i] A [ 9 | | i=0 → M 10 | | i=1 → N 11 | ] 12 | 13 | def square 14 | (A : type) 15 | (M N : 𝕀 → A) 16 | (O : path A (M 0) (N 0)) 17 | (P : path A (M 1) (N 1)) 18 | : type 19 | = 20 | [i j] A [ 21 | | j=0 → M i 22 | | j=1 → N i 23 | | i=0 → O j 24 | | i=1 → P j 25 | ] 26 | 27 | def funext 28 | (A : type) 29 | (B : A → type) 30 | (f g : (x : A) → B x) 31 | (p : (x : A) → path (B x) (f x) (g x)) 32 | : path ((x : A) → B x) f g 33 | = 34 | λ i x → 35 | p _ i 36 | 37 | def apd 38 | (A : type) (P : A → type) 39 | (f : (x : A) → P x) (x y : A) (p : path A x y) 40 | : path (P y) (coe 0 1 (f x) in λ i → P (p i)) (f y) = 41 | λ i → coe i 1 (f (p i)) in λ j → P (p j) 42 | 43 | def symm/filler (A : type) (p : 𝕀 → A) (j i : 𝕀) : A = 44 | comp 0 j (p 0) [ 45 | | i=0 → p 46 | | i=1 → refl 47 | ] 48 | 49 | def symm (A : type) (p : 𝕀 → A) : path A (p 1) (p 0) = 50 | symm/filler _ p 1 51 | 52 | def symm/unit (A : type) (a : A) : path (path _ a a) refl (symm _ (λ _ → a)) = 53 | symm/filler _ (λ _ → a) 54 | 55 | def symm'/filler (A : type) (p : 𝕀 → A) (j i : 𝕀) : A = 56 | comp 1 j (p 1) [ 57 | | i=0 → refl 58 | | i=1 → p 59 | ] 60 | 61 | def symm' (A : type) (p : 𝕀 → A) : path A (p 1) (p 0) = 62 | symm'/filler _ p 0 63 | 64 | def trans/filler (A : type) (p : 𝕀 → A) (q : [i] A [i=0 → p 1]) (j i : 𝕀) : A = 65 | comp 0 j (p i) [ 66 | | i=0 → refl 67 | | i=1 → q 68 | ] 69 | 70 | def trans (A : type) (p : 𝕀 → A) (q : [i] A [i=0 → p 1]) : path _ (p 0) (q 1) = 71 | trans/filler _ p q 1 72 | 73 | def trans/unit/r (A : type) (p : 𝕀 → A) : path (path _ (p 0) (p 1)) p (trans _ p (λ _ → p 1)) = 74 | trans/filler _ p (λ _ → p 1) 75 | 76 | def trans/unit/l (A : type) (p : 𝕀 → A) : path (path _ (p 0) (p 1)) p (trans _ (λ _ → p 0) p) = 77 | λ k i → 78 | comp 0 1 (p 0) [ 79 | | k=0 j → 80 | comp 0 1 (p 0) [ 81 | | j=1 l → comp 0 i (p 0) [ l=0 → refl | l=1 → p ] 82 | | i=1 l → comp 0 j (p 0) [ l=0 → refl | l=1 → p ] 83 | | j=0 | i=0 → refl 84 | ] 85 | | i=0 → refl 86 | | i=1 → p 87 | ] 88 | 89 | -- This proof gets simpler when dead tubes are deleted! 90 | def trans/sym/r (A : type) (p : 𝕀 → A) : path (path _ (p 0) (p 0)) refl (trans _ p (symm _ p)) = 91 | λ k i → 92 | comp 0 1 (p i) [ 93 | | i=0 → refl 94 | | i=1 → symm A p 95 | | k=0 → symm/filler A p i 96 | -- | k=1 j → trans/filler A p (symm A p) j i 97 | ] 98 | 99 | def trans/sym/l (A : type) (p : 𝕀 → A) : path (path _ (p 1) (p 1)) refl (trans _ (symm _ p) p) = 100 | λ k i → 101 | comp 0 1 (symm/filler A p k i) [ 102 | | i=0 j → 103 | comp 0 1 (p 1) [ 104 | | j=0 l → comp 1 k (p 1) [ l=0 → refl | l=1 → p ] 105 | | k=0 l → comp 1 j (p 1) [ l=0 → refl | l=1 → p ] 106 | | j=1 | k=1 → refl 107 | ] 108 | | i=1 | k=0 → p 109 | -- | k=1 j → trans/filler A (symm A p) p j i 110 | ] 111 | 112 | -- Perhaps we could parallelize this proof? ;) 113 | def symmd (A : 𝕀 → type) (p : (i : 𝕀) → A i) : pathd (symm^1 _ A) (p 1) (p 0) = 114 | λ i → 115 | comp 0 1 (p 0) in λ j → symm/filler^1 _ A j i [ 116 | | i=0 → p 117 | | i=1 → refl 118 | ] 119 | 120 | -- transporting backwards is transporting forwards along inverted path (up to composition) 121 | def coe/symm/d (A : type) (P : A → type) (p : 𝕀 → A) (p1 : P (p 1)) 122 | : pathd 123 | (trans^1 _ (λ k → P (p k)) (λ k → P (symm _ p k))) 124 | (coe 1 0 p1 in λ k → P (p k)) 125 | (coe 0 1 p1 in λ k → P (symm _ p k)) 126 | = 127 | λ i → 128 | comp 0 1 (coe 1 i p1 in λ k → P (p k)) in 129 | λ j → trans/filler^1 _ (λ k → P (p k)) (λ k → P (symm _ p k)) j i [ 130 | | i=0 → refl 131 | | i=1 → λ k → coe 0 k p1 in λ l → P (symm A p l) 132 | ] 133 | 134 | def J (A : type) (p : 𝕀 → A) (C : [i] A [i=0 → p 0] → type) (d : C refl) : C p = 135 | coe 0 1 d in λ i → 136 | C (λ j → comp 0 j (p 0) [i=0 → refl | i=1 → p]) 137 | 138 | def J/eq 139 | (A : type) (a : A) 140 | (C : [i] A [i=0 → a] → type) (d : C refl) 141 | : path (C refl) (J _ (λ _ → a) C d) d 142 | = 143 | let square (i j : 𝕀) : A = comp 0 j a [∂[i] → refl] in 144 | λ k → 145 | let mot (i : 𝕀) = C (λ j → comp 0 j a [k=0 → square i | k=1 | ∂[i] → refl]) in 146 | comp 0 1 d in mot [ 147 | | k=0 → λ i → coe 0 i d in λ j → C (square j) 148 | | k=1 → refl 149 | ] 150 | 151 | -------------------------------------------------------------------------------- /library/prelude/pointed.red: -------------------------------------------------------------------------------- 1 | import prelude.path 2 | import prelude.equivalence 3 | 4 | def ptype : type^1 = (A : type) × A 5 | 6 | def pmap (pA pB : ptype) : type = 7 | (f : pA.fst → pB.fst) × path _ (f (pA.snd)) (pB.snd) 8 | 9 | def pidf (X : ptype) : pmap X X = (λ a → a, refl) 10 | 11 | def p∘ (X Y Z : ptype) (g : pmap Y Z) (f : pmap X Y) : pmap X Z = 12 | (λ a → g .fst (f .fst a), trans (Z .fst) (λ i → g .fst (f .snd i)) (g .snd)) 13 | 14 | def p→ (pA pB : ptype) : ptype = 15 | (pmap pA pB, λ _ → pB.snd, refl) 16 | 17 | def pequiv (pA pB : ptype) : type = 18 | (f : pmap pA pB) × is-equiv (pA.fst) (pB.fst) (f.fst) 19 | -------------------------------------------------------------------------------- /library/prelude/univalence.red: -------------------------------------------------------------------------------- 1 | import prelude.path 2 | import prelude.connection 3 | import prelude.hlevel 4 | import prelude.equivalence 5 | 6 | def ua (A B : type) (e : equiv A B) : path^1 type A B = 7 | λ i → V i A B e 8 | 9 | def univalence (B : type) : is-contr^1 ((A : type) × equiv A B) = 10 | ( (B, id-equiv B) 11 | , λ (A,e) i → 12 | let VB : type = V i A B e in 13 | let proj/B (g : VB) : B = g .vproj in 14 | ( _ 15 | , proj/B 16 | , λ b → 17 | let ctr/B (j : 𝕀) : B = 18 | comp 1 j b [ 19 | | i=0 → e .snd b .fst .snd 20 | | i=1 → refl 21 | ] 22 | in 23 | let ctr : fiber VB B proj/B b = 24 | ((e .snd b .fst .fst, ctr/B 0), ctr/B) 25 | in 26 | ( ctr 27 | , λ v j → 28 | let aux (k : 𝕀) : B = 29 | comp 1 k b [ 30 | | j=0 → v .snd 31 | | j=1 → refl 32 | ] 33 | in 34 | let filler (l : 𝕀) : B = 35 | comp 1 l b [ 36 | | i=0 → e .snd b .snd v j .snd 37 | | i=1 → aux 38 | | j=0 → v.snd 39 | | j=1 → ctr/B 40 | ] 41 | in 42 | -- MORTAL this should be: e .snd b .snd v j .fst 43 | ( `(vin i (fst (@ ((snd ((snd e) b)) v) j)) (@ filler 0)) 44 | , filler 45 | ) 46 | ) 47 | ) 48 | ) 49 | -------------------------------------------------------------------------------- /library/redlib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RedPRL/redtt/ae76658873a647eb43d8cf84365a9d68e9a3273c/library/redlib -------------------------------------------------------------------------------- /redtt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "redtt" 3 | version: "0.0" 4 | maintainer: "jmsterli@cs.cmu.edu" 5 | authors: ["The RedPRL Development Team"] 6 | homepage: "https://github.com/RedPRL/redtt" 7 | bug-reports: "https://github.com/RedPRL/redtt/issues" 8 | dev-repo: "git://github.com/RedPRL/redtt.git" 9 | license: "Apache-2.0" 10 | synopsis: "The redtt proof assistant" 11 | depends: [ 12 | "cmdliner" {>= "1.0.4"} 13 | "uuseg" {>= "12.0.0"} 14 | "uutf" {>= "1.0.2"} 15 | "dune" {build & >= "2.1.1"} 16 | "lwt" {>= "5.1.1"} 17 | "menhir" {>= "20190924"} 18 | "ezjsonm" {= "1.1.0"} 19 | "ezgzip" {= "0.2.3"} 20 | ] 21 | build: [ 22 | ["dune" "build" "-p" name "@install" "-j" jobs] 23 | ] 24 | -------------------------------------------------------------------------------- /src/basis/Bwd.ml: -------------------------------------------------------------------------------- 1 | type 'a bwd = 2 | | Emp 3 | | Snoc of 'a bwd * 'a 4 | 5 | module BwdNotation = 6 | struct 7 | let (#<) xs x = 8 | Snoc (xs, x) 9 | 10 | let rec (<.>) xs ys = 11 | match ys with 12 | | Emp -> xs 13 | | Snoc (ys, y) -> 14 | Snoc (xs <.> ys, y) 15 | 16 | 17 | let rec (<><) xs ys = 18 | match ys with 19 | | [] -> xs 20 | | y :: ys -> (xs #< y) <>< ys 21 | 22 | let rec (<>>) xs ys = 23 | match xs with 24 | | Emp -> ys 25 | | Snoc (xs, x) -> xs <>> x :: ys 26 | end 27 | 28 | module Bwd = 29 | struct 30 | open BwdNotation 31 | 32 | let rec nth xs i = 33 | match xs with 34 | | Emp -> 35 | failwith "Bwd.nth" 36 | | Snoc (_, x) when i = 0 -> x 37 | | Snoc (xs, _) -> nth xs @@ i - 1 38 | 39 | let rec mem a xs = 40 | match xs with 41 | | Emp -> false 42 | | Snoc (xs, x) -> 43 | a = x || (mem[@tailcall]) a xs 44 | 45 | let rec exists p xs = 46 | match xs with 47 | | Emp -> false 48 | | Snoc (xs, x) -> 49 | p x || (exists[@tailcall]) p xs 50 | 51 | let rec for_all p xs = 52 | match xs with 53 | | Emp -> true 54 | | Snoc (xs, x) -> 55 | p x && (for_all[@tailcall]) p xs 56 | 57 | let rec iter p xs = 58 | match xs with 59 | | Emp -> () 60 | | Snoc (xs, x) -> 61 | p x; (iter[@tailcall]) p xs 62 | 63 | let rec length = 64 | function 65 | | Emp -> 0 66 | | Snoc (xs, _) -> 67 | 1 + length xs 68 | 69 | let rec map f = 70 | function 71 | | Emp -> Emp 72 | | Snoc (xs, x) -> Snoc (map f xs, f x) 73 | 74 | let mapi f = 75 | let rec go i = 76 | function 77 | | Emp -> Emp 78 | | Snoc (xs, x) -> Snoc (go (i + 1) xs, f i x) 79 | in 80 | go 0 81 | 82 | let rec flat_map f = 83 | function 84 | | Emp -> Emp 85 | | Snoc (xs, x) -> flat_map f xs <>< f x 86 | 87 | let rec filter f = 88 | function 89 | | Emp -> Emp 90 | | Snoc (xs, x) -> 91 | let xs' = filter f xs in 92 | if f x then Snoc (xs', x) else xs' 93 | 94 | let rec fold_left f e = 95 | function 96 | | Emp -> e 97 | | Snoc (xs, x) -> 98 | f (fold_left f e xs) x 99 | 100 | let rec fold_right f l e = 101 | match l with 102 | | Emp -> e 103 | | Snoc (l, x) -> 104 | let e = f x e in 105 | (fold_right[@tailcall]) f l e 106 | 107 | let rec fold_right2 f l0 l1 e = 108 | match l0, l1 with 109 | | Emp, Emp -> e 110 | | Snoc (l0, x0), Snoc (l1, x1) -> 111 | let e = f x0 x1 e in 112 | (fold_right2[@tailcall]) f l0 l1 e 113 | | _ -> raise @@ Invalid_argument "Bwd.fold_right2" 114 | let to_list xs = 115 | xs <>> [] 116 | 117 | let from_list xs = 118 | Emp <>< xs 119 | 120 | (* favonia: the following is considered ILL-TYPED! 121 | * 122 | * let rev xs = from_list @@ List.rev @@ to_list xs *) 123 | end 124 | -------------------------------------------------------------------------------- /src/basis/Bwd.mli: -------------------------------------------------------------------------------- 1 | (** Backward lists (notation inspired by Conor McBride) *) 2 | 3 | type 'a bwd = 4 | | Emp 5 | | Snoc of 'a bwd * 'a 6 | 7 | 8 | module BwdNotation : 9 | sig 10 | val (<.>) : 'a bwd -> 'a bwd -> 'a bwd 11 | val (#<) : 'a bwd -> 'a -> 'a bwd 12 | val (<><) : 'a bwd -> 'a list -> 'a bwd 13 | val (<>>) : 'a bwd -> 'a list -> 'a list 14 | end 15 | 16 | module Bwd : 17 | sig 18 | val nth : 'a bwd -> int -> 'a 19 | val length : 'a bwd -> int 20 | val mem : 'a -> 'a bwd -> bool 21 | val exists : ('a -> bool) -> 'a bwd -> bool 22 | val for_all : ('a -> bool) -> 'a bwd -> bool 23 | val iter : ('a -> unit) -> 'a bwd -> unit 24 | val map : ('a -> 'b) -> 'a bwd -> 'b bwd 25 | val mapi : (int -> 'a -> 'b) -> 'a bwd -> 'b bwd 26 | val flat_map : ('a -> 'b list) -> 'a bwd -> 'b bwd 27 | val filter : ('a -> bool) -> 'a bwd -> 'a bwd 28 | val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b bwd -> 'a 29 | val fold_right : ('a -> 'b -> 'b) -> 'a bwd -> 'b -> 'b 30 | val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a bwd -> 'b bwd -> 'c -> 'c 31 | val to_list : 'a bwd -> 'a list 32 | val from_list : 'a list -> 'a bwd 33 | end 34 | -------------------------------------------------------------------------------- /src/basis/Combinators.ml: -------------------------------------------------------------------------------- 1 | let flip f x y = f y x 2 | let const x _ = x 3 | -------------------------------------------------------------------------------- /src/basis/Combinators.mli: -------------------------------------------------------------------------------- 1 | val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c 2 | val const : 'a -> 'b -> 'a 3 | -------------------------------------------------------------------------------- /src/basis/DisjointSet.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type 'a t 4 | 5 | val init : size:int -> 'a t 6 | val union : 'a -> 'a -> 'a t -> 'a t 7 | val find : 'a -> 'a t -> 'a 8 | end 9 | 10 | module Make (T : PersistentTable.S) : S = 11 | struct 12 | type 'a t = 13 | {rank : ('a, int) T.t; 14 | mutable parent : ('a, 'a) T.t} 15 | 16 | let init ~size = 17 | {rank = T.init ~size; 18 | parent = T.init ~size} 19 | 20 | 21 | let rec find_aux (x : 'a) (f : ('a, 'a) T.t) = 22 | try 23 | let fx = T.get x f in 24 | if fx == x then 25 | f, x 26 | else 27 | let f, y = find_aux fx f in 28 | let f = T.set x y f in 29 | f, y 30 | with 31 | | _ -> 32 | let f = T.set x x f in 33 | f, x 34 | 35 | let find (x : 'a) (h : 'a t) : 'a = 36 | let f, cx = find_aux x h.parent in 37 | h.parent <- f; 38 | cx 39 | 40 | let get_rank cx h = 41 | try 42 | T.get cx h.rank 43 | with 44 | | _ -> 45 | 0 46 | 47 | let union (x : 'a) (y : 'a) (h : 'a t) = 48 | let cx = find x h in 49 | let cy = find y h in 50 | if cx != cy then 51 | begin 52 | let rx = get_rank cx h in 53 | let ry = get_rank cy h in 54 | if rx > ry then 55 | {h with 56 | parent = T.set cy cx h.parent} 57 | else if rx < ry then 58 | {h with 59 | parent = T.set cx cy h.parent} 60 | else 61 | {rank = T.set cx (rx + 1) h.rank; 62 | parent = T.set cy cx h.parent} 63 | end 64 | else 65 | h 66 | end 67 | -------------------------------------------------------------------------------- /src/basis/DisjointSet.mli: -------------------------------------------------------------------------------- 1 | (* Due to Conchon & Filliatre *) 2 | 3 | module type S = 4 | sig 5 | type 'a t 6 | 7 | val init : size:int -> 'a t 8 | val union : 'a -> 'a -> 'a t -> 'a t 9 | val find : 'a -> 'a t -> 'a 10 | end 11 | 12 | module Make (T : PersistentTable.S) : S 13 | -------------------------------------------------------------------------------- /src/basis/IxMonad.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type ('i, 'o, 'a) m 4 | val ret : 'a -> ('i, 'i, 'a) m 5 | val bind : ('i, 'j, 'a) m -> ('a -> ('j, 'k, 'b) m) -> ('i, 'k, 'b) m 6 | end 7 | 8 | module type Notation = 9 | sig 10 | type ('i, 'o, 'a) m 11 | 12 | val (>>=) : ('i, 'j, 'a) m -> ('a -> ('j, 'k, 'b) m) -> ('i, 'k, 'b) m 13 | val (>>) : ('i, 'j, 'a) m -> ('j, 'k, 'b) m -> ('i, 'k, 'b) m 14 | val (<$>) : ('a -> 'b) -> ('i, 'o, 'a) m -> ('i, 'o, 'b) m 15 | end 16 | 17 | module Notation (M : S) = 18 | struct 19 | let (>>=) = M.bind 20 | let (>>) m n = 21 | m >>= fun _ -> n 22 | 23 | let (<$>) f m = 24 | m >>= fun x -> 25 | M.ret @@ f x 26 | end 27 | -------------------------------------------------------------------------------- /src/basis/IxMonad.mli: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type ('i, 'o, 'a) m 4 | val ret : 'a -> ('i, 'i, 'a) m 5 | val bind : ('i, 'j, 'a) m -> ('a -> ('j, 'k, 'b) m) -> ('i, 'k, 'b) m 6 | end 7 | 8 | module type Notation = 9 | sig 10 | type ('i, 'o, 'a) m 11 | 12 | val (>>=) : ('i, 'j, 'a) m -> ('a -> ('j, 'k, 'b) m) -> ('i, 'k, 'b) m 13 | val (>>) : ('i, 'j, 'a) m -> ('j, 'k, 'b) m -> ('i, 'k, 'b) m 14 | val (<$>) : ('a -> 'b) -> ('i, 'o, 'a) m -> ('i, 'o, 'b) m 15 | end 16 | 17 | module Notation (M : S) : Notation 18 | with type ('i, 'o, 'a) m := ('i, 'o, 'a) M.m 19 | 20 | -------------------------------------------------------------------------------- /src/basis/IxStateMonad.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type 'i state 4 | 5 | include IxMonad.S 6 | 7 | val run : 'i state -> ('i, 'o, 'a) m -> 'a * 'o state 8 | 9 | val get : ('i, 'i, 'i state) m 10 | val set : 'o state -> ('i, 'o, unit) m 11 | end 12 | 13 | module M (X : sig type 'i t end) : S with type 'i state := 'i X.t = 14 | struct 15 | type 'i state = 'i X.t 16 | 17 | type ('i, 'o, 'a) m = 'i state -> 'a * 'o state 18 | 19 | let ret a st = a, st 20 | 21 | let bind m k st = 22 | let a, st' = m st in 23 | k a st' 24 | 25 | let get st = 26 | st, st 27 | 28 | let set st _ = 29 | (), st 30 | 31 | let run st m = 32 | m st 33 | end 34 | -------------------------------------------------------------------------------- /src/basis/IxStateMonad.mli: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type 'i state 4 | 5 | include IxMonad.S 6 | 7 | val run : 'i state -> ('i, 'o, 'a) m -> 'a * 'o state 8 | 9 | val get : ('i, 'i, 'i state) m 10 | val set : 'o state -> ('i, 'o, unit) m 11 | end 12 | 13 | module M (X : sig type 'i t end) : S 14 | with type 'i state := 'i X.t 15 | -------------------------------------------------------------------------------- /src/basis/ListUtil.ml: -------------------------------------------------------------------------------- 1 | let is_nil = 2 | function 3 | | [] -> true 4 | | _ -> false 5 | 6 | let rec split n xs = 7 | match n, xs with 8 | | 0, _ -> 9 | [], xs 10 | | n, x :: xs -> 11 | let ys, zs = split (n - 1) xs in 12 | x :: ys, zs 13 | | _ -> 14 | failwith "ListUtil.take" 15 | 16 | let rec flat_map f xs = 17 | match xs with 18 | | [] -> [] 19 | | x :: xs -> 20 | f x @ flat_map f xs 21 | 22 | let rec flat_map2 f xs ys = 23 | match xs, ys with 24 | | [], [] -> [] 25 | | x :: xs, y :: ys -> 26 | f x y @ flat_map2 f xs ys 27 | | _ -> invalid_arg "flat_map2: unequal length" 28 | 29 | let rec index_of pred xs = 30 | match xs with 31 | | [] -> 32 | failwith "index_of: not found" 33 | | x :: _ when pred x -> 34 | 0 35 | | _ :: xs -> 36 | 1 + index_of pred xs 37 | 38 | 39 | let rec split_last l = 40 | match l with 41 | | [] -> failwith "split_last: empty list" 42 | | [x] -> ([], x) 43 | | x :: y :: ys -> 44 | let zs, z = split_last (y :: ys) in 45 | x :: zs, z 46 | 47 | let split_head l = 48 | match l with 49 | | [] -> failwith "split_head_append: empty list" 50 | | x :: xs -> x, xs 51 | 52 | 53 | let rec filter_map f xs = 54 | match xs with 55 | | [] -> [] 56 | | x :: xs -> 57 | match f x with 58 | | Some y -> y :: filter_map f xs 59 | | None -> filter_map f xs 60 | 61 | let rec find_map_opt f xs = 62 | match xs with 63 | | [] -> None 64 | | x :: xs -> 65 | match f x with 66 | | Some y -> Some y 67 | | None -> find_map_opt f xs 68 | 69 | let foreach l f = List.map f l 70 | let foreach2 l0 l1 f = List.map2 f l0 l1 71 | 72 | let flat_foreach l f = flat_map f l 73 | let flat_foreach2 l0 l1 f = flat_map2 f l0 l1 74 | 75 | let pp sep pp_elem fmt l = 76 | let pp_sep fmt () = Format.fprintf fmt "%s@," sep in 77 | Format.pp_print_list ~pp_sep pp_elem fmt l 78 | -------------------------------------------------------------------------------- /src/basis/MapAsPersistentTable.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type key 4 | type 'a t 5 | 6 | val init : size:int -> 'a t 7 | val size : 'a t -> int 8 | val get : key -> 'a t -> 'a 9 | val set : key -> 'a -> 'a t -> 'a t 10 | val mem : key -> 'a t -> bool 11 | val remove : key -> 'a t -> 'a t 12 | val set_opt : key -> 'a option -> 'a t -> 'a t 13 | val find : key -> 'a t -> 'a option 14 | val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 15 | val merge : 'a t -> 'a t -> 'a t 16 | val to_list : 'a t -> (key * 'a) list 17 | val to_list_keys : 'a t -> key list 18 | val to_list_values : 'a t -> 'a list 19 | end 20 | 21 | module M (Ord : Map.OrderedType) : S with type key = Ord.t = 22 | struct 23 | module M = Map.Make (Ord) 24 | 25 | type key = Ord.t 26 | type 'a t = 'a M.t 27 | 28 | let init ~size:_ = M.empty 29 | 30 | let size = M.cardinal 31 | 32 | let get = M.find 33 | 34 | let mem = M.mem 35 | 36 | let find = M.find_opt 37 | 38 | let set = M.add 39 | 40 | let remove = M.remove 41 | 42 | let set_opt k ov t = 43 | match ov with 44 | | None -> remove k t 45 | | Some v -> set k v t 46 | 47 | let fold = M.fold 48 | 49 | let merge t0 t1 = M.union (fun _ a _ -> Some a) t0 t1 50 | 51 | let to_list t = List.of_seq (M.to_seq t) 52 | 53 | let to_list_keys t = List.of_seq @@ Seq.map (fun (k, _) -> k) @@ M.to_seq t 54 | 55 | let to_list_values t = List.of_seq @@ Seq.map (fun (_, v) -> v) @@ M.to_seq t 56 | end 57 | -------------------------------------------------------------------------------- /src/basis/Monad.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type 'a m 4 | val bind : 'a m -> ('a -> 'b m) -> 'b m 5 | val try_ : 'a m -> (exn -> 'a m) -> 'a m 6 | val ret : 'a -> 'a m 7 | end 8 | 9 | module type Notation = 10 | sig 11 | type 'a m 12 | 13 | val (>>=) : 'a m -> ('a -> 'b m) -> 'b m 14 | val (>>) : 'a m -> 'b m -> 'b m 15 | val (<@>>) : ('a -> 'b) -> 'a m -> 'b m 16 | val (<<@>) : 'a m -> ('a -> 'b) -> 'b m 17 | val (<*>) : ('a -> 'b) m -> 'a m -> 'b m 18 | val (<&>) : 'a m -> 'b m -> ('a * 'b) m 19 | val (<||) : bool m -> unit m -> unit m 20 | end 21 | 22 | module Notation (M : S) : Notation with type 'a m := 'a M.m = 23 | struct 24 | let (>>=) = M.bind 25 | let (>>) m n = 26 | m >>= fun _ -> n 27 | 28 | let (<@>>) f m = 29 | m >>= fun x -> 30 | M.ret @@ f x 31 | 32 | let (<<@>) m f = f <@>> m 33 | 34 | let (<*>) m n = 35 | m >>= fun f -> 36 | f <@>> n 37 | 38 | let (<&>) m n = 39 | m >>= fun x -> 40 | n >>= fun y -> 41 | M.ret (x, y) 42 | 43 | let (<||) a b = 44 | a >>= fun x -> 45 | if x then M.ret () else b 46 | end 47 | 48 | module Util (M : S) = 49 | struct 50 | module N = Notation (M) 51 | open N 52 | 53 | let rec traverse f = 54 | function 55 | | [] -> M.ret [] 56 | | x::xs -> 57 | f x >>= fun y -> 58 | traverse f xs >>= fun ys -> 59 | M.ret @@ y :: ys 60 | 61 | let rec filter_traverse f = 62 | function 63 | | [] -> M.ret [] 64 | | x::xs -> 65 | f x >>= fun y -> 66 | filter_traverse f xs >>= fun ys -> 67 | match y with 68 | | None -> M.ret ys 69 | | Some y -> M.ret @@ y :: ys 70 | 71 | let rec fold_left f acc xs = 72 | match xs with 73 | | [] -> 74 | M.ret acc 75 | | x :: xs -> 76 | f acc x >>= fun a -> 77 | fold_left f a xs 78 | 79 | let rec iter f xs = 80 | match xs with 81 | | [] -> 82 | M.ret () 83 | | x :: xs -> 84 | f x >> iter f xs 85 | 86 | end 87 | -------------------------------------------------------------------------------- /src/basis/Monad.mli: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type 'a m 4 | val bind : 'a m -> ('a -> 'b m) -> 'b m 5 | val try_ : 'a m -> (exn -> 'a m) -> 'a m 6 | val ret : 'a -> 'a m 7 | end 8 | 9 | module type Notation = 10 | sig 11 | type 'a m 12 | 13 | val (>>=) : 'a m -> ('a -> 'b m) -> 'b m 14 | val (>>) : 'a m -> 'b m -> 'b m 15 | val (<@>>) : ('a -> 'b) -> 'a m -> 'b m 16 | val (<<@>) : 'a m -> ('a -> 'b) -> 'b m 17 | val (<*>) : ('a -> 'b) m -> 'a m -> 'b m 18 | val (<&>) : 'a m -> 'b m -> ('a * 'b) m 19 | val (<||) : bool m -> unit m -> unit m 20 | end 21 | 22 | module Notation (M : S) : Notation with type 'a m := 'a M.m 23 | 24 | module Util (M : S) : 25 | sig 26 | val traverse : ('a -> 'b M.m) -> 'a list -> 'b list M.m 27 | val filter_traverse : ('a -> 'b option M.m) -> 'a list -> 'b list M.m 28 | val fold_left : ('a -> 'b -> 'a M.m) -> 'a -> 'b list -> 'a M.m 29 | val iter : ('a -> unit M.m) -> 'a list -> unit M.m 30 | end 31 | 32 | -------------------------------------------------------------------------------- /src/basis/Option.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 'a option 2 | 3 | let some x = Some x 4 | 5 | let map f = 6 | function 7 | | Some a -> Some (f a) 8 | | None -> None 9 | 10 | let foreach m f = map f m 11 | 12 | let iter f = 13 | function 14 | | Some a -> f a 15 | | None -> () 16 | 17 | let rec filter_map f = 18 | function 19 | | [] -> [] 20 | | (x :: xs) -> 21 | match f x with 22 | | Some y -> y :: filter_map f xs 23 | | None -> filter_map f xs 24 | 25 | let filter_foreach l f = filter_map f l 26 | 27 | let default a = 28 | function 29 | | None -> a 30 | | Some a -> a 31 | 32 | exception WasNone 33 | 34 | let get_exn m = 35 | match m with 36 | | Some x -> x 37 | | None -> 38 | Printexc.print_raw_backtrace stderr (Printexc.get_callstack 20); 39 | Format.eprintf "@."; 40 | raise WasNone 41 | -------------------------------------------------------------------------------- /src/basis/Option.mli: -------------------------------------------------------------------------------- 1 | type 'a t = 'a option 2 | val some : 'a -> 'a option 3 | val map : ('a -> 'b) -> 'a t -> 'b t 4 | val foreach : 'a t -> ('a -> 'b) -> 'b t 5 | val iter : ('a -> unit) -> 'a option -> unit 6 | val filter_map : ('a -> 'b option) -> 'a list -> 'b list 7 | val filter_foreach : 'a list -> ('a -> 'b option) -> 'b list 8 | val default : 'a -> 'a option -> 'a 9 | val get_exn : 'a t -> 'a 10 | exception WasNone 11 | -------------------------------------------------------------------------------- /src/basis/PersistentTable.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type ('k, 'a) t 4 | 5 | val init : size:int -> ('k, 'a) t 6 | val size : ('k, 'a) t -> int 7 | val get : 'k -> ('k, 'a) t -> 'a 8 | val set : 'k -> 'a -> ('k, 'a) t -> ('k, 'a) t 9 | val mem : 'k -> ('k, 'a) t -> bool 10 | val remove : 'k -> ('k, 'a) t -> ('k, 'a) t 11 | val set_opt : 'k -> 'a option -> ('k, 'a) t -> ('k, 'a) t 12 | val find : 'k -> ('k, 'a) t -> 'a option 13 | val fold : ('k -> 'a -> 'b -> 'b) -> ('k, 'a) t -> 'b -> 'b 14 | val merge : ('k, 'a) t -> ('k, 'a) t -> ('k, 'a) t 15 | val to_list : ('k, 'a) t -> ('k * 'a) list 16 | val to_list_keys : ('k, 'a) t -> 'k list 17 | val to_list_values : ('k, 'a) t -> 'a list 18 | end 19 | 20 | module M : S = 21 | struct 22 | type ('k, 'a) t = ('k, 'a) node ref 23 | and ('k, 'a) node = 24 | | Tbl of ('k, 'a) Hashtbl.t 25 | | Diff of 'k * 'a option * ('k, 'a) t 26 | 27 | exception Fatal 28 | 29 | let init ~size = 30 | ref @@ Tbl (Hashtbl.create size) 31 | 32 | let raw_set_opt tbl k ov = 33 | match ov with 34 | | None -> Hashtbl.remove tbl k 35 | | Some v -> Hashtbl.replace tbl k v 36 | 37 | let rec reroot t = 38 | match !t with 39 | | Tbl _ -> 40 | () 41 | | Diff (k, ov, t') -> 42 | reroot t'; 43 | match !t' with 44 | | Tbl a as n -> 45 | let ov' = Hashtbl.find_opt a k in 46 | raw_set_opt a k ov; 47 | t := n; 48 | t' := Diff (k, ov', t) 49 | | _ -> 50 | raise Fatal 51 | 52 | let size t = 53 | reroot t; 54 | match !t with 55 | | Tbl a -> 56 | Hashtbl.length a 57 | | _ -> 58 | raise Fatal 59 | 60 | let get k t = 61 | reroot t; 62 | match !t with 63 | | Tbl a -> 64 | Hashtbl.find a k 65 | | _ -> 66 | raise Fatal 67 | 68 | let mem k t = 69 | reroot t; 70 | match !t with 71 | | Tbl a -> 72 | Hashtbl.mem a k 73 | | _ -> 74 | raise Fatal 75 | 76 | let find k t = 77 | try 78 | Some (get k t) 79 | with 80 | | _ -> None 81 | 82 | let set k v t = 83 | reroot t; 84 | match !t with 85 | | Tbl a as n -> 86 | let old = Hashtbl.find_opt a k in 87 | Hashtbl.replace a k v; 88 | let res = ref n in 89 | t := Diff (k, old, res); 90 | res 91 | | _ -> 92 | raise Fatal 93 | 94 | let remove k t = 95 | reroot t; 96 | match !t with 97 | | Tbl a as n -> 98 | let old = Hashtbl.find_opt a k in 99 | Hashtbl.remove a k; 100 | let res = ref n in 101 | t := Diff (k, old, res); 102 | res 103 | | _ -> 104 | raise Fatal 105 | 106 | let set_opt k ov t = 107 | match ov with 108 | | None -> remove k t 109 | | Some v -> set k v t 110 | 111 | let fold f t e = 112 | reroot t; 113 | match !t with 114 | | Tbl a -> 115 | Hashtbl.fold f a e 116 | | _ -> 117 | raise Fatal 118 | 119 | let merge t0 t1 = fold set t0 t1 120 | 121 | let to_list t = 122 | reroot t; 123 | match !t with 124 | | Tbl a -> 125 | List.of_seq (Hashtbl.to_seq a) 126 | | _ -> 127 | raise Fatal 128 | 129 | let to_list_keys t = 130 | reroot t; 131 | match !t with 132 | | Tbl a -> 133 | List.of_seq (Hashtbl.to_seq_keys a) 134 | | _ -> 135 | raise Fatal 136 | 137 | let to_list_values t = 138 | reroot t; 139 | match !t with 140 | | Tbl a -> 141 | List.of_seq (Hashtbl.to_seq_values a) 142 | | _ -> 143 | raise Fatal 144 | 145 | end 146 | -------------------------------------------------------------------------------- /src/basis/PersistentTable.mli: -------------------------------------------------------------------------------- 1 | (* Due to Conchon & Filliatre *) 2 | 3 | module type S = 4 | sig 5 | type ('k, 'a) t 6 | 7 | val init : size:int -> ('k, 'a) t 8 | val size : ('k, 'a) t -> int 9 | val get : 'k -> ('k, 'a) t -> 'a 10 | val set : 'k -> 'a -> ('k, 'a) t -> ('k, 'a) t 11 | val mem : 'k -> ('k, 'a) t -> bool 12 | val remove : 'k -> ('k, 'a) t -> ('k, 'a) t 13 | val set_opt : 'k -> 'a option -> ('k, 'a) t -> ('k, 'a) t 14 | val find : 'k -> ('k, 'a) t -> 'a option 15 | val fold : ('k -> 'a -> 'b -> 'b) -> ('k, 'a) t -> 'b -> 'b 16 | 17 | (** entries from the first argument overwrite the ones from the second. *) 18 | val merge : ('k, 'a) t -> ('k, 'a) t -> ('k, 'a) t 19 | 20 | val to_list : ('k, 'a) t -> ('k * 'a) list 21 | val to_list_keys : ('k, 'a) t -> 'k list 22 | val to_list_values : ('k, 'a) t -> 'a list 23 | end 24 | 25 | module M : S 26 | -------------------------------------------------------------------------------- /src/basis/ReaderMonad.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type state 4 | 5 | include Monad.S 6 | val get : state m 7 | val local : (state -> state) -> 'a m -> 'a m 8 | val run : state -> 'a m -> 'a 9 | end 10 | 11 | module M (X : sig type t end) : S with type state := X.t = 12 | struct 13 | type 'a m = X.t -> 'a 14 | let ret a _ = a 15 | 16 | let bind (m : 'a m) (f : 'a -> 'b m) : 'b m = 17 | fun st -> 18 | f (m st) st 19 | 20 | let try_ (m : 'a m) (ferr : exn -> 'a m) : 'a m = 21 | fun st -> 22 | try 23 | m st 24 | with exn -> 25 | ferr exn st 26 | 27 | let get st = 28 | st 29 | 30 | let local f m st = 31 | m (f st) 32 | 33 | let run st m = 34 | m st 35 | end 36 | -------------------------------------------------------------------------------- /src/basis/ReaderMonad.mli: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type state 4 | 5 | include Monad.S 6 | val get : state m 7 | val local : (state -> state) -> 'a m -> 'a m 8 | val run : state -> 'a m -> 'a 9 | end 10 | 11 | module M (X : sig type t end) : S with type state := X.t 12 | -------------------------------------------------------------------------------- /src/basis/StateMonad.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type state 4 | 5 | include Monad.S 6 | 7 | val get : state m 8 | val set : state -> unit m 9 | 10 | val run : state -> 'a m -> 'a * state 11 | end 12 | 13 | module M (X : sig type t end) : S with type state := X.t = 14 | struct 15 | type state = X.t 16 | 17 | type 'a m = state -> 'a * state 18 | 19 | let ret a st = a, st 20 | 21 | let bind m k st = 22 | let a, st' = m st in 23 | k a st' 24 | 25 | let try_ m kerr st = 26 | try 27 | m st 28 | with exn -> 29 | kerr exn st 30 | 31 | let get st = 32 | st, st 33 | 34 | let set st _ = 35 | (), st 36 | 37 | let run st m = 38 | m st 39 | end 40 | -------------------------------------------------------------------------------- /src/basis/StateMonad.mli: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type state 4 | 5 | include Monad.S 6 | 7 | val get : state m 8 | val set : state -> unit m 9 | 10 | val run : state -> 'a m -> 'a * state 11 | end 12 | 13 | module M (X : sig type t end) : S with type state := X.t 14 | -------------------------------------------------------------------------------- /src/basis/SysUtil.ml: -------------------------------------------------------------------------------- 1 | exception Not_found = Not_found 2 | 3 | let protect_cwd f = 4 | let dir = Sys.getcwd () in 5 | match f dir with 6 | | ans -> Sys.chdir dir; ans 7 | | exception ext -> Sys.chdir dir; raise ext 8 | 9 | let normalize ?(dirs=[]) path = 10 | protect_cwd @@ fun _ -> 11 | try 12 | List.iter Sys.chdir dirs; 13 | Sys.chdir (Filename.dirname path); 14 | Filename.concat (Sys.getcwd ()) (Filename.basename path) 15 | with Sys_error _ -> raise Not_found 16 | 17 | let () : unit = 18 | if Filename.is_relative (Sys.getcwd ()) then 19 | failwith "Sys.getcwd returns a relative path." 20 | else 21 | () 22 | -------------------------------------------------------------------------------- /src/basis/SysUtil.mli: -------------------------------------------------------------------------------- 1 | exception Not_found 2 | 3 | (** portable and reasonable normalization of a mix of absolute and relative paths 4 | into an absolute path based on chdir/getcwd. *) 5 | val normalize : ?dirs : string list -> string -> string 6 | 7 | (** run a {b gyve} and then restore the current cwd. *) 8 | val protect_cwd : (string -> 'a) -> 'a 9 | -------------------------------------------------------------------------------- /src/basis/Tree.ml: -------------------------------------------------------------------------------- 1 | type 'a tree = 2 | | Node of {label : 'a; children : 'a forest} 3 | 4 | and 'a forest = 'a tree list 5 | 6 | type 'a frame = 7 | {label : 'a; 8 | lefts : 'a forest; 9 | rights : 'a forest} 10 | 11 | type 'a dtree = 12 | {below : 'a forest; 13 | above : 'a frame list} 14 | 15 | type 'a zip = {label : 'a; ctx : 'a dtree} 16 | 17 | let init label = 18 | let ctx = {below = []; above = []} in 19 | {label; ctx} 20 | 21 | let cursor {label; _} = 22 | label 23 | 24 | let insert lbl {label; ctx} = 25 | let node = Node {label = lbl; children = []} in 26 | let below = node :: ctx.below in 27 | let ctx' = {ctx with below} in 28 | {label; ctx = ctx'} 29 | 30 | type move0 = [`Down | `Up | `Left | `Right] 31 | type move = [`Id of move0 | `Star of move0] 32 | exception InvalidMove of move0 33 | 34 | let down {label; ctx} = 35 | match ctx.below with 36 | | [] -> 37 | raise @@ InvalidMove `Down 38 | 39 | | Node node :: xs -> 40 | let below = node.children in 41 | let frame = {label; lefts = []; rights = xs} in 42 | let above = frame :: ctx.above in 43 | let ctx' = {below; above} in 44 | {label = node.label; ctx = ctx'} 45 | 46 | let up {label; ctx} = 47 | match ctx.above with 48 | | [] -> 49 | raise @@ InvalidMove `Up 50 | 51 | | frame :: above -> 52 | let node = Node {label; children = ctx.below} in 53 | let below = List.rev frame.lefts @ node :: frame.rights in 54 | let ctx' = {below; above} in 55 | {label = frame.label; ctx = ctx'} 56 | 57 | let left {label; ctx} = 58 | match ctx.above with 59 | | [] -> 60 | raise @@ InvalidMove `Left 61 | 62 | | frame :: above -> 63 | match frame.lefts with 64 | | [] -> 65 | raise @@ InvalidMove `Left 66 | 67 | | Node x :: lefts -> 68 | let node = Node {label; children = ctx.below} in 69 | let frame' = {label = frame.label; lefts; rights = node :: frame.rights} in 70 | let ctx' = {below = x.children; above = frame' :: above} in 71 | {label = x.label; ctx = ctx'} 72 | 73 | let right {label; ctx} = 74 | match ctx.above with 75 | | [] -> 76 | raise @@ InvalidMove `Right 77 | 78 | | frame :: above -> 79 | match frame.rights with 80 | | [] -> 81 | raise @@ InvalidMove `Right 82 | 83 | | Node x :: rights -> 84 | let node = Node {label; children = ctx.below} in 85 | let frame' = {label = frame.label; lefts = node :: frame.lefts; rights = rights} in 86 | let ctx' = {below = x.children; above = frame' :: above} in 87 | {label = x.label; ctx = ctx'} 88 | 89 | 90 | let move0 m = 91 | match m with 92 | | `Down -> down 93 | | `Up -> up 94 | | `Left -> left 95 | | `Right -> right 96 | 97 | let move m = 98 | match m with 99 | | `Id m0 -> 100 | move0 m0 101 | | `Star m0 -> 102 | let rec go zip = 103 | try go @@ move0 m0 zip with 104 | | _ -> zip 105 | in go 106 | -------------------------------------------------------------------------------- /src/basis/Tree.mli: -------------------------------------------------------------------------------- 1 | (** A rose tree zipper. *) 2 | type 'a zip 3 | 4 | val init : 'a -> 'a zip 5 | val cursor : 'a zip -> 'a 6 | 7 | 8 | type move0 = [`Down | `Up | `Left | `Right] 9 | type move = [`Id of move0 | `Star of move0] 10 | exception InvalidMove of move0 11 | 12 | (** May raise [InvalidMove]. *) 13 | val move : move -> 'a zip -> 'a zip 14 | 15 | (** Inserts a new node into the children of the current node. Does not move focus. 16 | To focus the new node, go 'down'. *) 17 | val insert : 'a -> 'a zip -> 'a zip 18 | -------------------------------------------------------------------------------- /src/basis/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name RedBasis) 3 | (public_name redtt.basis)) 4 | -------------------------------------------------------------------------------- /src/bin/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names main) 3 | (libraries cmdliner lwt.unix redtt)) 4 | 5 | (install 6 | (section bin) 7 | (package redtt) 8 | (files (main.exe as redtt))) 9 | -------------------------------------------------------------------------------- /src/bin/main.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | open RedTT 3 | 4 | type command = unit Cmd.t 5 | 6 | let opt_margin = 7 | let doc = "Set pretty-printing margin to $(docv) characters." in 8 | Arg.(value & opt int 80 & info ["line-width"] ~docv:"WIDTH" ~doc) 9 | 10 | let opt_file_name = 11 | Arg. 12 | ( required 13 | & pos ~rev:true 0 (some string) None 14 | & info [] ~doc:"The name of the file being loaded" ~docv:"FILE" 15 | ) 16 | 17 | let opt_debug = 18 | let doc = "Execute in debug mode." in 19 | Arg.(value & flag & info ["d"; "debug"] ~doc) 20 | 21 | let opt_shell = 22 | let doc = "Allow custom scripts for dependency checking." in 23 | Arg.(value & flag & info ["allow-shell"] ~doc) 24 | 25 | let opt_recheck = 26 | let doc = "Ignore the cache in the rot files (re-typecheck everything)." in 27 | Arg.(value & flag & info ["ignore-cache"] ~doc) 28 | 29 | let opts_config = 30 | let open Term in 31 | let make file_name line_width debug_mode shell_mode recheck = 32 | Frontend.{file_name; line_width; debug_mode; shell_mode; recheck} 33 | in 34 | const make $ opt_file_name $ opt_margin $ opt_debug $ opt_shell $ opt_recheck 35 | 36 | let term_default = 37 | Term.(ret @@ const @@ `Help ( `Pager, None )) 38 | 39 | let info_default = 40 | Cmd.(info "redtt" ~version:"0.1.0") 41 | 42 | let cmd_help = 43 | let doc = "show help" in 44 | Cmd.(v @@ info "help" ~doc) 45 | Term.(ret @@ const @@ `Help ( `Pager, None )) 46 | 47 | let cmd_load_file = 48 | let doc = "load file" in 49 | Cmd.(v @@ info "load-file" ~doc) 50 | Term.(const Frontend.load_file $ opts_config) 51 | 52 | let cmd_from_stdin = 53 | let doc = "read from stdin" in 54 | Cmd.(v @@ info "from-stdin" ~doc) 55 | Term.(const Frontend.load_from_stdin $ opts_config) 56 | 57 | 58 | let cmds : command list = [ 59 | cmd_load_file; 60 | cmd_from_stdin; 61 | cmd_help; 62 | ] 63 | 64 | let main () = 65 | Stdlib.exit @@ Cmd.eval @@ Cmd.group ~default:term_default info_default cmds 66 | 67 | let () = 68 | if not !Sys.interactive then 69 | main () 70 | -------------------------------------------------------------------------------- /src/core/Cx.mli: -------------------------------------------------------------------------------- 1 | type cx 2 | type t = cx 3 | type value = Domain.value 4 | 5 | val init : GlobalEnv.t -> t 6 | val globals : t -> GlobalEnv.t 7 | val env : t -> Domain.env 8 | val ppenv : t -> Pp.env 9 | val qenv : t -> Quote.env 10 | 11 | val clear_locals : t -> t 12 | 13 | 14 | val ext_ty : t -> nm:string option -> value -> t * value 15 | val ext_dim : t -> nm:string option -> t * I.atom 16 | val ext_dims : t -> nms:string option list -> t * I.atom list 17 | 18 | (** Might raise I.Inconsistent *) 19 | val restrict : t -> I.t -> I.t -> t * I.action 20 | 21 | val def : t -> nm:string option -> ty:value -> el:value -> t 22 | val def_dim : t -> nm:string option -> I.t -> t 23 | 24 | 25 | 26 | (** Look up the classifier (either a type or the interval) of a local variable. *) 27 | val lookup : int -> t -> [`Ty of value | `I] 28 | 29 | (** Look up the type of a named constant. *) 30 | val lookup_constant : Name.t -> Tm.twin -> t -> Tm.tm 31 | 32 | val make_closure : t -> Tm.tm Tm.bnd -> Domain.clo 33 | 34 | 35 | val eval : t -> Tm.tm -> value 36 | val eval_cmd : t -> Tm.tm Tm.cmd -> value 37 | val eval_head : t -> Tm.tm Tm.head -> value 38 | val eval_frame : t -> value -> Tm.tm Tm.frame -> value 39 | val eval_dim : t -> Tm.tm -> I.t 40 | val eval_tm_sys : t -> (Tm.tm, Tm.tm) Tm.system -> Domain.val_sys 41 | 42 | 43 | val check_eq : t -> ty:value -> value -> value -> unit 44 | val check_subtype : t -> value -> value -> unit 45 | val quote : t -> ty:value -> value -> Tm.tm 46 | val quote_ty : t -> value -> Tm.tm 47 | val quote_dim : t -> I.t -> Tm.tm 48 | val check_eq_ty : t -> value -> value -> unit 49 | val check_eq_dim : t -> I.t -> I.t -> unit 50 | 51 | val evaluator : t -> (module Val.S) 52 | val quoter : t -> (module Quote.S) 53 | -------------------------------------------------------------------------------- /src/core/Desc.mli: -------------------------------------------------------------------------------- 1 | open Tm 2 | 3 | (** Recursive argument types; currently this includes only [Self]; in the future, this will be extended with an indexed 4 | version of [Self], as well a formal function type. *) 5 | type rec_spec = 6 | | Self 7 | 8 | type arg_spec = 9 | [ `Const of tm 10 | | `Rec of rec_spec 11 | | `Dim 12 | ] 13 | 14 | 15 | type ('a, 'e) telescope = 16 | | TNil of 'e 17 | | TCons of 'a * ('a, 'e) telescope Tm.bnd 18 | 19 | type constr = (arg_spec, (tm, tm) system) telescope 20 | 21 | module Constr : 22 | sig 23 | include LocallyNameless.S with type t = constr 24 | val bind : Name.t -> t -> t TmData.bnd 25 | 26 | val specs : t -> (string option * arg_spec) list 27 | val boundary : t -> (tm, tm) system 28 | 29 | val pp : t Pp.t0 30 | end 31 | 32 | type param = tm 33 | type constrs = (string * constr) list 34 | type body = (param, constrs) telescope 35 | 36 | module Body : 37 | sig 38 | include LocallyNameless.S with type t = body 39 | val bind : Name.t -> t -> t Tm.bnd 40 | 41 | (** Invariant: first argument is locally closed. *) 42 | val unbind_with : Tm.tm Tm.cmd -> t Tm.bnd -> t 43 | 44 | (** Invariant: first argument is locally closed. *) 45 | val instance : Tm.tm list -> t -> constrs 46 | end 47 | 48 | type desc = 49 | {kind : Kind.t; 50 | lvl : Lvl.t; 51 | body : body; 52 | status : [`Complete | `Partial]} 53 | 54 | val constrs : desc -> constrs 55 | val add_constr : desc -> string * constr -> desc 56 | 57 | 58 | exception ConstructorNotFound of string 59 | val lookup_constr : string -> constrs -> constr 60 | 61 | (** Returns 'yes' if the description specifies strictly no higher dimensional structure, like the natural numbers. *) 62 | val is_strict_set : desc -> bool 63 | 64 | val pp_constr : ?dlbl:string -> constr Pp.t 65 | val pp_constrs : ?dlbl:string -> constrs Pp.t 66 | val pp_desc : ?dlbl:string -> desc Pp.t 67 | -------------------------------------------------------------------------------- /src/core/Diagnostics.ml: -------------------------------------------------------------------------------- 1 | let termination_queue = Queue.create () 2 | 3 | let on_termination f = Queue.add f termination_queue 4 | 5 | let terminated () = 6 | Queue.iter (fun f -> f ()) termination_queue 7 | -------------------------------------------------------------------------------- /src/core/Diagnostics.mli: -------------------------------------------------------------------------------- 1 | val on_termination : (unit -> unit) -> unit 2 | val terminated : unit -> unit 3 | -------------------------------------------------------------------------------- /src/core/Dir.ml: -------------------------------------------------------------------------------- 1 | type t = I.t * I.t 2 | 3 | type 'a m = [`Ok of 'a | `Same of t] 4 | 5 | let make r r' = 6 | if r = r' then `Same (r, r') else `Ok (r, r') 7 | 8 | let gen_const x epsilon : t = 9 | `Atom x, 10 | match epsilon with 11 | | `Dim0 -> `Dim0 12 | | `Dim1 -> `Dim1 13 | 14 | let swap (r, r') = r', r 15 | let unleash p = p 16 | 17 | let act phi (r, r') : t m = 18 | make (I.act phi r) (I.act phi r') 19 | -------------------------------------------------------------------------------- /src/core/Dir.mli: -------------------------------------------------------------------------------- 1 | type t 2 | type 'a m = [`Ok of 'a | `Same of I.t * I.t] 3 | 4 | val make : I.t -> I.t -> t m 5 | val gen_const : I.atom -> [`Dim0 | `Dim1] -> t 6 | 7 | val swap : t -> t 8 | val unleash : t -> I.t * I.t 9 | val act : I.action -> t -> t m 10 | -------------------------------------------------------------------------------- /src/core/Domain.mli: -------------------------------------------------------------------------------- 1 | open RedBasis.Bwd 2 | include module type of DomainData 3 | 4 | val clo_name : clo -> string option 5 | 6 | val pp_abs : Format.formatter -> abs -> unit 7 | val pp_ext_abs : Format.formatter -> ext_abs -> unit 8 | val pp_value : Format.formatter -> value -> unit 9 | val pp_dims : Format.formatter -> I.t list -> unit 10 | val pp_neu : Format.formatter -> neu -> unit 11 | val pp_comp_face : Format.formatter -> rigid_abs_face -> unit 12 | val pp_val_face : Format.formatter -> ('x, value) face -> unit 13 | val pp_val_sys : Format.formatter -> ('x, value) face list -> unit 14 | val pp_comp_sys : Format.formatter -> comp_sys -> unit 15 | val pp_names : Format.formatter -> Name.t bwd -> unit 16 | 17 | val pp_clo : Format.formatter -> clo -> unit 18 | val pp_nclo : Format.formatter -> nclo -> unit 19 | 20 | val pp_env_cell : Format.formatter -> env_el -> unit 21 | val pp_env : Format.formatter -> env -> unit 22 | 23 | 24 | exception ProjAbs of abs 25 | exception ProjVal of value 26 | 27 | val force_val_face : val_face -> ('a, value) face option 28 | val force_abs_face : ([`Any], abs) face -> ('a, abs) face option 29 | val force_val_sys : val_face list -> [`Ok of ('a, value) face list | `Proj of value] 30 | val force_abs_sys : ([`Any], abs) face list -> [`Ok of ('a, abs) face list | `Proj of abs] 31 | 32 | 33 | module Env : 34 | sig 35 | include Sort.S 36 | with type t = env 37 | with type 'a m = 'a 38 | val emp : dim DimEnv.t -> env 39 | val clear_locals : env -> env 40 | 41 | (* What direction do these go? Think of the environment as a snoc list, where things are projected by counting from the *right*. 42 | So, if I have an environment [E], then [append E [x0; x1; x2]] is [E #< x0 #< x1 #< x2] 43 | *) 44 | 45 | val snoc : env -> env_el -> env 46 | val append : env -> env_el list -> env 47 | 48 | val act_env_el : I.action -> env_el -> env_el 49 | end 50 | 51 | module Value : Sort.S 52 | with type t = value 53 | with type 'a m = 'a 54 | 55 | module Neu : Sort.S 56 | with type t = neu 57 | with type 'a m = 'a 58 | 59 | module Nf : Sort.S 60 | with type t = nf 61 | with type 'a m = 'a 62 | 63 | 64 | module NeuAbs : IAbs.S 65 | with type el = neu * val_sys 66 | 67 | module ExtAbs : IAbs.S 68 | with type el = value * val_sys 69 | 70 | module Abs : IAbs.S 71 | with type el = value 72 | 73 | module ValFace : Face.S with type body := value 74 | module AbsFace : Face.S with type body := abs 75 | 76 | module Clo : Sort.S 77 | with type t = clo 78 | with type 'a m = 'a 79 | 80 | module NClo : Sort.S 81 | with type t = nclo 82 | with type 'a m = 'a 83 | 84 | 85 | module CompSys : 86 | sig 87 | include Sort.S 88 | with type t = comp_sys 89 | with type 'a m = [`Ok of comp_sys | `Proj of abs] 90 | val forall : I.atom -> t -> t 91 | val forallm : I.atom -> t m -> t m 92 | end 93 | 94 | module BoxSys : Sort.S 95 | with type t = box_sys 96 | with type 'a m = [`Ok of box_sys | `Proj of value] 97 | 98 | module ValSys : 99 | sig 100 | include Sort.S 101 | with type t = val_sys 102 | with type 'a m = 'a 103 | 104 | val from_rigid : rigid_val_sys -> t 105 | val forall : I.atom -> t -> t 106 | end 107 | 108 | 109 | val make : con -> value 110 | -------------------------------------------------------------------------------- /src/core/DomainData.ml: -------------------------------------------------------------------------------- 1 | open RedBasis.Bwd 2 | module DimEnv = Map.Make (Name) 3 | 4 | type atom = I.atom 5 | type dir = Dir.t 6 | type dim = I.t 7 | 8 | type ('x, 'a) face = ('x, 'a) Face.face 9 | 10 | 11 | type con = 12 | | Pi of {dom : value; cod : clo} 13 | | Sg of {dom : value; cod : clo} 14 | | Restrict of val_face 15 | | Ext of ext_abs 16 | 17 | | Coe of {dir : dir; abs : abs; el : value} 18 | | HCom of {dir : dir; ty : value; cap : value; sys : comp_sys} 19 | | GHCom of {dir : dir; ty : value; cap : value; sys : comp_sys} 20 | | FHCom of {dir : dir; cap : value; sys : comp_sys} 21 | | Box of {dir : dir; cap : value; sys : box_sys} 22 | 23 | | Univ of {kind : Kind.t; lvl : Lvl.t} 24 | | V of {x : atom; ty0 : value; ty1 : value; equiv : value} 25 | | VIn of {x : atom; el0 : value; el1 : value} 26 | 27 | | Lam of clo 28 | | ExtLam of nclo 29 | | RestrictThunk of val_face 30 | 31 | | Cons of value * value 32 | 33 | | Up of {ty : value; neu : neu; sys : rigid_val_sys} 34 | 35 | | Data of {lbl : Name.t; params : env_el list} 36 | 37 | | Intro of 38 | {dlbl : Name.t; 39 | clbl : string; 40 | args : env_el list; 41 | sys : rigid_val_sys} 42 | 43 | | FortyTwo 44 | 45 | and neu = 46 | | Lvl of string option * int 47 | | Var of {name : Name.t; twin : Tm.twin; ushift : int} 48 | | Meta of {name : Name.t; ushift : int} 49 | 50 | | NHComAtType of {dir : dir; univ : value; ty : neu; ty_sys : rigid_val_sys; cap : value; sys : comp_sys} 51 | | NHComAtCap of {dir : dir; ty : value; cap : neu; sys : comp_sys} 52 | | NCoe of {dir : dir; abs : abs; neu : neu} 53 | 54 | | NCoeAtType of {dir : dir; abs : neu_abs; el : value} 55 | 56 | | FunApp of neu * nf 57 | | ExtApp of neu * dim list 58 | | Fst of neu 59 | | Snd of neu 60 | 61 | | Elim of 62 | {dlbl : Name.t; 63 | params : env_el list; 64 | mot : clo; 65 | neu : neu; 66 | clauses : (string * nclo) list} 67 | 68 | (* Invariant: neu \in vty, vty is a V type *) 69 | | VProj of {x : atom; func : nf; neu : neu} 70 | | Cap of {dir : dir; ty : value; sys : comp_sys; neu : neu} 71 | 72 | | RestrictForce of neu 73 | 74 | and nf = {ty : value; el : value} 75 | 76 | and abs = value IAbs.abs 77 | 78 | and clo = 79 | | Clo of {bnd : Tm.tm Tm.bnd; rho : env} 80 | 81 | and nclo = 82 | | NClo of {nbnd : Tm.tm Tm.nbnd; rho : env} 83 | | NCloConst of value Lazy.t 84 | 85 | and rigid_abs_face = ([`Rigid], abs) face 86 | and val_face = ([`Any], value) face 87 | and rigid_val_face = ([`Rigid], value) face 88 | 89 | and comp_sys = rigid_abs_face list 90 | and val_sys = val_face list 91 | and rigid_val_sys = rigid_val_face list 92 | and box_sys = rigid_val_sys 93 | and ext_abs = (value * val_sys) IAbs.abs 94 | and neu_abs = (neu * val_sys) IAbs.abs 95 | 96 | and value = Node of {con : con; action : I.action} 97 | 98 | and env_el = [`Val of value | `Dim of I.t] 99 | and env = {cells : env_el bwd; global : dim DimEnv.t} 100 | -------------------------------------------------------------------------------- /src/core/Eq.ml: -------------------------------------------------------------------------------- 1 | type t = I.t * I.t 2 | 3 | type 'a m = [`Ok of 'a | `Same of t | `Apart of t] 4 | 5 | let make r r' = 6 | match I.compare r r' with 7 | | `Same -> `Same (r, r') 8 | | `Apart -> `Apart (r, r') 9 | | `Indet -> `Ok (r, r') 10 | 11 | let gen_const x epsilon : t = 12 | `Atom x, 13 | match epsilon with 14 | | `Dim0 -> `Dim0 15 | | `Dim1 -> `Dim1 16 | 17 | let from_dir dir = 18 | let r, r' = Dir.unleash dir in 19 | match I.compare r r' with 20 | | `Apart -> `Apart (r, r') 21 | | `Indet -> `Ok (r, r') 22 | | `Same -> failwith "impossible" 23 | 24 | let swap (r, r') = r', r 25 | let unleash p = p 26 | 27 | let act phi (r, r') : t m = 28 | make (I.act phi r) (I.act phi r') 29 | -------------------------------------------------------------------------------- /src/core/Eq.mli: -------------------------------------------------------------------------------- 1 | type t 2 | type 'a m = [`Ok of 'a | `Same of I.t * I.t | `Apart of I.t * I.t] 3 | 4 | val make : I.t -> I.t -> t m 5 | val gen_const : I.atom -> [`Dim0 | `Dim1] -> t 6 | val from_dir : Dir.t -> [`Ok of t | `Apart of I.t * I.t] 7 | 8 | val swap : t -> t 9 | val unleash : t -> I.t * I.t 10 | val act : I.action -> t -> t m 11 | -------------------------------------------------------------------------------- /src/core/Face.ml: -------------------------------------------------------------------------------- 1 | type (_, 'a) face = 2 | | False : I.t * I.t -> ([`Any], 'a) face 3 | | True : I.t * I.t * 'a lazy_t -> ([`Any], 'a) face 4 | | Indet : Eq.t * 'a lazy_t -> ('x, 'a) face 5 | 6 | let map : type x. (I.t -> I.t -> 'a -> 'b) -> (x, 'a) face -> (x, 'b) face = 7 | fun f face -> 8 | match face with 9 | | False (r, r') -> 10 | False (r, r') 11 | | True (r, r', v) -> 12 | True (r, r', lazy (f r r' (Lazy.force v))) 13 | | Indet (p, v) -> 14 | let r, r' = Eq.unleash p in 15 | Indet (p, lazy (f r r' (Lazy.force v))) 16 | 17 | let get_cond : type x. (x, 'a) face -> I.t * I.t = 18 | fun face -> 19 | match face with 20 | | False (r, r') -> 21 | r, r' 22 | | True (r, r', _) -> 23 | r, r' 24 | | Indet (p, _) -> 25 | Eq.unleash p 26 | 27 | let forall : type x. I.atom -> (x, 'a) face -> [`Delete | `Keep] = 28 | fun x face -> 29 | let r, r' = get_cond face in 30 | if I.absent x r && I.absent x r' then `Keep else `Delete 31 | 32 | module type S = 33 | sig 34 | type body 35 | type 'x t = ('x, body) face 36 | 37 | val rigid : I.action -> Eq.t -> (I.action -> body) -> 'x t 38 | 39 | val make_from_dir : I.action -> Dir.t -> (I.action -> body) -> [`Any] t 40 | 41 | val make : I.action -> I.t -> I.t -> (I.action -> body) -> [`Any] t 42 | 43 | (* convenience function for generating faces x = ε *) 44 | val gen_const : I.action -> I.atom -> [`Dim0 | `Dim1] -> (I.action -> body) -> 'a t 45 | 46 | val act : I.action -> 'x t -> [`Any] t 47 | end 48 | 49 | 50 | module M (X : Sort.S with type 'a m = 'a) : S with type body := X.t = 51 | struct 52 | type 'x t = ('x, X.t) face 53 | 54 | let rigid : I.action -> Eq.t -> (I.action -> X.t) -> 'x t = 55 | fun phi eq a -> 56 | let r, r' = Eq.unleash eq in 57 | Indet (eq, lazy begin a (I.cmp (I.equate r r') phi) end) 58 | 59 | let make : I.action -> I.t -> I.t -> (I.action -> X.t) -> [`Any] t = 60 | fun phi r r' a -> 61 | match Eq.make r r' with 62 | | `Ok p -> 63 | rigid phi p a 64 | | `Apart _ -> 65 | False (r, r') 66 | | `Same _ -> 67 | True (r, r', lazy begin a phi end) 68 | 69 | let make_from_dir : I.action -> Dir.t -> (I.action -> X.t) -> [`Any] t = 70 | fun phi dir a -> 71 | match Eq.from_dir dir with 72 | | `Ok p -> 73 | rigid phi p a 74 | | `Apart (r, r') -> 75 | False (r, r') 76 | 77 | let gen_const : I.action -> I.atom -> [`Dim0 | `Dim1] -> (I.action -> X.t) -> 'x t = 78 | fun phi x eps a -> 79 | rigid phi (Eq.gen_const x eps) a 80 | 81 | 82 | let act : type x. I.action -> x t -> _ t = 83 | fun phi face -> 84 | match face with 85 | | True (c, d, t) -> 86 | True (I.act phi c, I.act phi d, lazy begin X.act phi @@ Lazy.force t end) 87 | | False (r, r') -> 88 | begin 89 | match Eq.make (I.act phi r) (I.act phi r') with 90 | | `Apart (r, r') -> False (r, r') 91 | | _ -> failwith "Unexpected thing happened in Face.act" 92 | end 93 | | Indet (p, t) -> 94 | begin 95 | match Eq.act phi p with 96 | | `Same (c, d) -> 97 | let t' = lazy begin X.act phi @@ Lazy.force t end in 98 | True (c, d, t') 99 | | `Apart (c, d) -> 100 | False (c, d) 101 | | `Ok p' -> 102 | rigid phi p' (fun phi -> X.act phi @@ Lazy.force t) 103 | end 104 | end 105 | 106 | -------------------------------------------------------------------------------- /src/core/Face.mli: -------------------------------------------------------------------------------- 1 | type (_, 'a) face = 2 | | False : I.t * I.t -> ([`Any], 'a) face 3 | | True : I.t * I.t * 'a lazy_t -> ([`Any], 'a) face 4 | | Indet : Eq.t * 'a lazy_t -> ('x, 'a) face 5 | 6 | val map : (I.t -> I.t -> 'a -> 'b) -> ('x, 'a) face -> ('x, 'b) face 7 | 8 | val forall : I.atom -> ('x, 'a) face -> [`Delete | `Keep] 9 | 10 | module type S = 11 | sig 12 | type body 13 | type 'x t = ('x, body) face 14 | 15 | val rigid : I.action -> Eq.t -> (I.action -> body) -> 'x t 16 | 17 | val make_from_dir : I.action -> Dir.t -> (I.action -> body) -> [`Any] t 18 | 19 | val make : I.action -> I.t -> I.t -> (I.action -> body) -> [`Any] t 20 | 21 | (* convenience function for generating faces x = ε *) 22 | val gen_const : I.action -> I.atom -> [`Dim0 | `Dim1] -> (I.action -> body) -> 'a t 23 | 24 | val act : I.action -> 'x t -> [`Any] t 25 | end 26 | 27 | module M (X : Sort.S with type 'a m = 'a) : S with type body := X.t 28 | -------------------------------------------------------------------------------- /src/core/GlobalEnv.ml: -------------------------------------------------------------------------------- 1 | type ty = Tm.tm 2 | type tm = Tm.tm 3 | 4 | type entry = 5 | [ `P of ty 6 | | `Def of ty * tm 7 | | `Tw of ty * ty 8 | | `I 9 | | `Desc of Desc.desc 10 | ] 11 | 12 | module T = Map.Make (Name) 13 | 14 | type t = 15 | {rel : Restriction.t; 16 | table : entry T.t} 17 | 18 | 19 | let emp () = 20 | {table = T.empty; 21 | rel = Restriction.emp ()} 22 | 23 | 24 | 25 | let ext (sg : t) nm param : t = 26 | {sg with 27 | table = T.add nm param sg.table} 28 | 29 | let define (sg : t) nm ~ty ~tm = 30 | ext sg nm @@ `Def (ty, tm) 31 | 32 | let ext_meta (sg : t) nm ~ty = 33 | ext sg nm @@ `P ty 34 | 35 | let ext_dim (sg : t) nm : t = 36 | ext sg nm `I 37 | 38 | let declare_datatype dlbl desc (sg : t) : t = 39 | ext sg dlbl @@ `Desc desc 40 | 41 | let replace_datatype dlbl desc (sg : t) : t = 42 | {sg with 43 | table = T.update dlbl (function Some (`Desc _) -> Some (`Desc desc) | _ -> raise Not_found) sg.table} 44 | 45 | 46 | 47 | let rec index_of pred xs = 48 | match xs with 49 | | [] -> failwith "index_of" 50 | | x :: xs -> 51 | if pred x then 0 else 1 + index_of pred xs 52 | 53 | let lookup_ty sg nm tw = 54 | let prm = T.find nm sg.table in 55 | match prm, tw with 56 | | `P a, _ -> a 57 | | `Def (a, _), _ -> a 58 | | `Tw (a, _), `TwinL -> a 59 | | `Tw (_, a), `TwinR -> a 60 | | `Desc info, _ -> Tm.univ ~kind:info.kind ~lvl:info.lvl 61 | | exception Not_found -> 62 | failwith "GlobalEnv.lookup_ty: entry not found" 63 | | _ -> 64 | failwith "GlobalEnv.lookup_entry: wrong kind of entry" 65 | 66 | let lookup sg nm = 67 | T.find nm sg.table 68 | 69 | let lookup_with_twin sg nm tw = 70 | let param = 71 | try 72 | lookup sg nm 73 | with 74 | | _ -> 75 | Format.eprintf "Failed to find: %a@." Name.pp nm; 76 | Printexc.print_raw_backtrace stderr (Printexc.get_callstack 20); 77 | Format.eprintf "@."; 78 | failwith "GlobalEnv.M.lookup: not found" 79 | in 80 | match param, tw with 81 | | `P ty, _ -> 82 | ty, None 83 | | `Def (ty, tm), _ -> 84 | ty, Some tm 85 | | `Tw (ty, _), `TwinL -> 86 | ty, None 87 | | `Tw (_, ty), `TwinR -> 88 | ty, None 89 | | _ -> 90 | failwith "GlobalEnv.lookup_with_twin: twin mismatch" 91 | 92 | let lookup_datatype sg dlbl = 93 | match T.find dlbl sg.table with 94 | | `Desc desc -> desc 95 | | _ -> 96 | Format.eprintf "The name %a does not refer to a datatype.@." Name.pp dlbl; 97 | raise Not_found 98 | | exception Not_found -> 99 | Format.eprintf "Datatype not found: %a.@." Name.pp dlbl; 100 | raise Not_found 101 | 102 | let restriction sg = 103 | sg.rel 104 | 105 | let restrict tr0 tr1 sg = 106 | let ev_dim tr = 107 | match Tm.unleash tr with 108 | | Tm.Up (Tm.Var {name; _}, []) -> `Atom name 109 | | Tm.Dim0 -> `Dim0 110 | | Tm.Dim1 -> `Dim1 111 | | _ -> 112 | Printexc.print_raw_backtrace stderr (Printexc.get_callstack 20); 113 | Format.eprintf "@."; 114 | failwith "Restrict: expected dimension" 115 | in 116 | let rel', _ = Restriction.equate (ev_dim tr0) (ev_dim tr1) sg.rel in 117 | {sg with rel = rel'} 118 | 119 | let pp fmt sg = 120 | let pp_sep fmt () = Format.fprintf fmt "; " in 121 | let go fmt (nm, p) = 122 | match p with 123 | | `Tw _ -> 124 | Format.fprintf fmt "%a[twin]" 125 | Name.pp nm 126 | | (`I | `P _ | `Def _ | `Desc _) -> 127 | Format.fprintf fmt "%a" 128 | Name.pp nm 129 | in 130 | Format.pp_print_list ~pp_sep go fmt @@ T.bindings sg.table 131 | 132 | let pp_twin fmt = 133 | function 134 | | `Only -> 135 | Format.fprintf fmt "Only" 136 | | `TwinL -> 137 | Format.fprintf fmt "TwinL" 138 | | `TwinR -> 139 | Format.fprintf fmt "TwinR" 140 | 141 | 142 | let global_dims globals = 143 | T.fold 144 | (fun x prm tbl -> 145 | match prm with 146 | | `I -> T.add x (I.act (Restriction.as_action globals.rel) (`Atom x)) tbl 147 | | _ -> tbl) 148 | globals.table 149 | T.empty 150 | 151 | module M (Sig : sig val globals : t end) : Val.Sig = 152 | struct 153 | 154 | let restriction = Sig.globals.rel 155 | 156 | let global_dims = global_dims Sig.globals 157 | 158 | let lookup_datatype = 159 | lookup_datatype Sig.globals 160 | 161 | let lookup_with_twin = 162 | lookup_with_twin Sig.globals 163 | end 164 | -------------------------------------------------------------------------------- /src/core/GlobalEnv.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | type ty = Tm.tm 4 | type tm = Tm.tm 5 | 6 | type entry = 7 | [ `P of ty 8 | | `Def of ty * tm 9 | | `Tw of ty * ty 10 | | `I 11 | | `Desc of Desc.desc 12 | ] 13 | 14 | val emp : unit -> t 15 | 16 | val ext : t -> Name.t -> entry -> t 17 | val define : t -> Name.t -> ty:Tm.tm -> tm:Tm.tm -> t 18 | val ext_meta : t -> Name.t -> ty:Tm.tm -> t 19 | val ext_dim : t -> Name.t -> t 20 | val declare_datatype : Name.t -> Desc.desc -> t -> t 21 | val replace_datatype : Name.t -> Desc.desc -> t -> t (* [Not_found] if the datatype is not there *) 22 | 23 | val restrict : Tm.tm -> Tm.tm -> t -> t 24 | 25 | 26 | module T : module type of (Map.Make (Name)) 27 | 28 | val global_dims : t -> I.t T.t 29 | 30 | val lookup_ty : t -> Name.t -> Tm.twin -> Tm.tm 31 | val lookup : t -> Name.t -> entry 32 | val lookup_datatype : t -> Name.t -> Desc.desc 33 | val lookup_with_twin : t -> Name.t -> Tm.twin -> Tm.tm * Tm.tm option 34 | 35 | 36 | val restriction : t -> Restriction.t 37 | 38 | 39 | val pp : t Pp.t0 40 | 41 | module M (Sig : sig val globals : t end) : Val.Sig 42 | -------------------------------------------------------------------------------- /src/core/I.ml: -------------------------------------------------------------------------------- 1 | open RedBasis.Bwd 2 | 3 | type atom = Name.t 4 | 5 | type 'a f = 6 | [ `Dim0 7 | | `Dim1 8 | | `Atom of 'a 9 | ] 10 | 11 | let map f = 12 | function 13 | | `Dim0 -> `Dim0 14 | | `Dim1 -> `Dim1 15 | | `Atom a -> `Atom (f a) 16 | 17 | let bind m k = 18 | match m with 19 | | `Dim0 -> `Dim0 20 | | `Dim1 -> `Dim1 21 | | `Atom a -> k a 22 | 23 | type t = atom f 24 | 25 | type action = 26 | | Subst of t * atom 27 | | Swap of atom * atom 28 | | Idn 29 | | Cmp of action * action 30 | 31 | let idn = Idn 32 | let swap a b = Swap (a, b) 33 | let subst r a = Subst (r, a) 34 | 35 | let cmp phi1 phi0 = 36 | match phi1, phi0 with 37 | | Idn, _ -> phi0 38 | | _, Idn -> phi1 39 | | _ -> Cmp (phi1, phi0) 40 | 41 | 42 | exception Inconsistent 43 | 44 | let equate r0 r1 = 45 | match r0, r1 with 46 | | `Dim0, `Dim0 -> 47 | Idn 48 | | `Dim1, `Dim1 -> 49 | Idn 50 | | `Dim0, `Dim1 -> 51 | raise Inconsistent 52 | | `Dim1, `Dim0 -> 53 | raise Inconsistent 54 | | `Atom a, (`Dim0 | `Dim1) -> 55 | Subst (r1, a) 56 | | (`Dim0 | `Dim1), `Atom a -> 57 | Subst (r0, a) 58 | | `Atom a, `Atom b when a < b -> 59 | Subst (r0, b) 60 | | `Atom a, `Atom b when a > b -> 61 | Subst (r1, a) 62 | | `Atom _, `Atom _ -> 63 | Idn 64 | 65 | let rec act phi = 66 | function 67 | | (`Dim0 | `Dim1) as r -> r 68 | | `Atom a as r -> 69 | match phi with 70 | | Idn -> r 71 | | Swap (b, c) when a = b -> `Atom c 72 | | Swap (b, c) when a = c -> `Atom b 73 | | Subst (s, b) when a = b -> s 74 | | Cmp (psi1, psi0) -> act psi1 @@ act psi0 r 75 | | _ -> r 76 | 77 | let occurs_in_action xs = 78 | let rec go = 79 | function 80 | | Idn -> 81 | false 82 | | Swap (y, z) -> 83 | Bwd.mem y xs || Bwd.mem z xs 84 | | Subst (`Atom y, _) -> 85 | Bwd.mem y xs 86 | | Subst (_, _) -> 87 | false 88 | | Cmp (phi0, phi1) -> 89 | go phi1 || go phi0 90 | in go 91 | 92 | 93 | 94 | type compare = 95 | [ `Same 96 | | `Apart 97 | | `Indet 98 | ] 99 | 100 | let compare r r' = 101 | match r, r' with 102 | | `Dim0, `Dim0 -> 103 | `Same 104 | | `Dim1, `Dim1 -> 105 | `Same 106 | | `Dim0, `Dim1 -> 107 | `Apart 108 | | `Dim1, `Dim0 -> 109 | `Apart 110 | | `Atom x, `Atom y -> 111 | if x = y then `Same else `Indet 112 | | `Atom _, _ -> 113 | `Indet 114 | | _, `Atom _ -> 115 | `Indet 116 | 117 | let absent x r = 118 | match r with 119 | | `Dim0 -> true 120 | | `Dim1 -> true 121 | | `Atom y -> x <> y 122 | 123 | 124 | let pp fmt = 125 | function 126 | | `Dim0 -> 127 | Format.fprintf fmt "0" 128 | | `Dim1 -> 129 | Format.fprintf fmt "1" 130 | | `Atom x -> 131 | Name.pp fmt x 132 | 133 | 134 | let rec pp_action fmt = 135 | function 136 | | Idn -> 137 | Format.fprintf fmt "idn" 138 | | Swap (a, b) -> 139 | Format.fprintf fmt "%a <-> %a" Name.pp a Name.pp b 140 | | Subst (r, x) -> 141 | Format.fprintf fmt "[%a/%a]" pp r Name.pp x 142 | | Cmp (phi1, phi0) -> 143 | Format.fprintf fmt "%a@ %a %a" pp_action phi1 Uuseg_string.pp_utf_8 "∘" pp_action phi0 144 | -------------------------------------------------------------------------------- /src/core/I.mli: -------------------------------------------------------------------------------- 1 | open RedBasis.Bwd 2 | 3 | type atom = Name.t 4 | 5 | type 'a f = 6 | [ `Dim0 7 | | `Dim1 8 | | `Atom of 'a 9 | ] 10 | 11 | val map : ('a -> 'b) -> 'a f -> 'b f 12 | val bind : 'a f -> ('a -> 'b f) -> 'b f 13 | 14 | 15 | 16 | 17 | type t = atom f 18 | 19 | type action 20 | val idn : action 21 | val swap : atom -> atom -> action 22 | val subst : t -> atom -> action 23 | val cmp : action -> action -> action 24 | val equate : t -> t -> action 25 | 26 | val occurs_in_action : atom bwd -> action -> bool 27 | 28 | 29 | val act : action -> t -> t 30 | 31 | type compare = 32 | [ `Same 33 | | `Apart 34 | | `Indet 35 | ] 36 | 37 | val compare : t -> t -> compare 38 | 39 | val absent : atom -> t -> bool 40 | 41 | 42 | val pp : t Pp.t0 43 | val pp_action : action Pp.t0 44 | 45 | 46 | exception Inconsistent 47 | -------------------------------------------------------------------------------- /src/core/IAbs.ml: -------------------------------------------------------------------------------- 1 | open RedBasis.Bwd 2 | open BwdNotation 3 | 4 | type atom = Name.t 5 | type 'a abs = {atoms : atom bwd; node : 'a} 6 | 7 | let pp ih fmt {atoms; node} = 8 | let pp_atoms fmt atoms = 9 | let pp_sep fmt () = Format.fprintf fmt " " in 10 | Format.pp_print_list ~pp_sep Name.pp fmt (Bwd.to_list atoms) 11 | in 12 | Format.fprintf fmt "@[<%a>@ %a@]" 13 | pp_atoms atoms 14 | ih node 15 | 16 | module type S = 17 | sig 18 | type el 19 | 20 | include Sort.S with type 'a m = 'a with type t = el abs 21 | 22 | val unsafe_map : (el -> el) -> t -> t 23 | 24 | val bind : atom bwd -> el -> t 25 | val unleash : t -> atom bwd * el 26 | val unsafe_unleash : t -> atom bwd * el 27 | val inst : t -> I.t bwd -> el 28 | 29 | val len : t -> int 30 | 31 | val bind1 : atom -> el -> t 32 | val unleash1 : t -> atom * el 33 | val unsafe_unleash1 : t -> atom * el 34 | val inst1 : t -> I.t -> el 35 | 36 | val make1 : (atom -> el) -> t 37 | end 38 | 39 | module M (X : Sort.S with type 'a m = 'a) : S with type el = X.t = 40 | struct 41 | type el = X.t 42 | type 'a m = 'a 43 | type t = X.t abs 44 | 45 | let len abs = Bwd.length abs.atoms 46 | 47 | let rec inst_atoms xs rs phi = 48 | match xs, rs with 49 | | Emp, Emp -> phi 50 | | Snoc (xs, x), Snoc (rs, r) -> 51 | inst_atoms xs rs @@ 52 | I.cmp phi @@ I.subst r x 53 | | _ -> failwith "inst_atoms" 54 | 55 | let rec swap_atoms xs ys phi = 56 | match xs, ys with 57 | | Emp, Emp -> phi 58 | | Snoc (xs, x), Snoc (ys, y) -> 59 | swap_atoms xs ys @@ 60 | I.cmp phi @@ I.swap y x 61 | | _ -> failwith "inst_atoms" 62 | 63 | let inst abs rs = 64 | let phi = inst_atoms abs.atoms rs I.idn in 65 | X.act phi abs.node 66 | 67 | let bind atoms node = 68 | {atoms; node} 69 | 70 | let unleash abs = 71 | let xs = Bwd.map (fun x -> Name.named @@ Name.name x) abs.atoms in 72 | xs, X.act (swap_atoms xs abs.atoms I.idn) abs.node 73 | 74 | let unsafe_unleash abs = 75 | abs.atoms, abs.node 76 | 77 | 78 | let bind1 x el = 79 | bind (Emp #< x) el 80 | 81 | let unsafe_map f abs = 82 | {abs with node = f abs.node} 83 | 84 | 85 | let unleash1 abs = 86 | let xs, el = unleash abs in 87 | match xs with 88 | | Snoc (Emp, x) -> x, el 89 | | _ -> 90 | Printexc.print_raw_backtrace stderr (Printexc.get_callstack 20); 91 | Format.eprintf "@."; 92 | failwith "unleash1: incorrect binding depth" 93 | 94 | let unsafe_unleash1 abs = 95 | let xs, el = unsafe_unleash abs in 96 | match xs with 97 | | Snoc (Emp, x) -> x, el 98 | | _ -> 99 | Printexc.print_raw_backtrace stderr (Printexc.get_callstack 20); 100 | Format.eprintf "@."; 101 | failwith "unsafe_unleash1: incorrect binding depth" 102 | 103 | let inst1 el r = 104 | inst el @@ Emp #< r 105 | 106 | let make1 gen = 107 | let x = Name.fresh () in 108 | bind1 x @@ gen x 109 | 110 | let act phi abs = 111 | if I.occurs_in_action abs.atoms phi then 112 | let xs = Bwd.map (fun x -> Name.named @@ Name.name x) abs.atoms in 113 | let phi' = I.cmp phi @@ swap_atoms xs abs.atoms I.idn in 114 | bind xs @@ X.act phi' abs.node 115 | else 116 | bind abs.atoms @@ X.act phi abs.node 117 | end 118 | 119 | -------------------------------------------------------------------------------- /src/core/IAbs.mli: -------------------------------------------------------------------------------- 1 | open RedBasis.Bwd 2 | 3 | type 'a abs 4 | 5 | type atom = Name.t 6 | 7 | val pp : 'a Pp.t0 -> 'a abs Pp.t0 8 | 9 | module type S = 10 | sig 11 | type el 12 | 13 | include Sort.S with type 'a m = 'a with type t = el abs 14 | 15 | val unsafe_map : (el -> el) -> t -> t 16 | 17 | val bind : atom bwd -> el -> t 18 | val unleash : t -> atom bwd * el 19 | val unsafe_unleash : t -> atom bwd * el 20 | val inst : t -> I.t bwd -> el 21 | 22 | val len : t -> int 23 | 24 | val bind1 : atom -> el -> t 25 | val unleash1 : t -> atom * el 26 | val unsafe_unleash1 : t -> atom * el 27 | val inst1 : t -> I.t -> el 28 | val make1 : (atom -> el) -> t 29 | end 30 | 31 | module M (X : Sort.S with type 'a m = 'a) : S with type el = X.t 32 | 33 | -------------------------------------------------------------------------------- /src/core/Kind.ml: -------------------------------------------------------------------------------- 1 | type t = [`Reg | `Kan | `Pre] 2 | 3 | let pp fmt = 4 | function 5 | | `Reg -> 6 | Format.fprintf fmt "reg" 7 | | `Kan -> 8 | Format.fprintf fmt "kan" 9 | | `Pre -> 10 | Format.fprintf fmt "pre" 11 | 12 | let lte k0 k1 = 13 | match k0, k1 with 14 | | `Reg, _ -> true 15 | | _, `Reg -> false 16 | | `Kan, _ -> true 17 | | _, `Kan -> false 18 | | `Pre, `Pre -> true 19 | -------------------------------------------------------------------------------- /src/core/Kind.mli: -------------------------------------------------------------------------------- 1 | type t = [`Reg | `Kan | `Pre] 2 | 3 | val lte : t -> t -> bool 4 | val pp : t Pp.t0 5 | -------------------------------------------------------------------------------- /src/core/LocallyNameless.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type t 4 | 5 | val open_var : int -> Name.t -> t -> t 6 | val close_var : Name.t -> int -> t -> t 7 | 8 | val subst : Tm.tm Tm.cmd Tm.subst -> t -> t 9 | end 10 | 11 | module List (M : S) : S with type t = M.t list = 12 | struct 13 | type t = M.t list 14 | 15 | let open_var i a = List.map @@ M.open_var i a 16 | let close_var a i = List.map @@ M.close_var a i 17 | let subst sub = List.map @@ M.subst sub 18 | end 19 | 20 | module Pair (M0 : S) (M1 : S) : S with type t = M0.t * M1.t = 21 | struct 22 | type t = M0.t * M1.t 23 | 24 | let open_var i a (t0, t1) = 25 | M0.open_var i a t0, M1.open_var i a t1 26 | 27 | let close_var a i (t0, t1) = 28 | M0.close_var a i t0, M1.close_var a i t1 29 | 30 | let subst sub (t0, t1) = 31 | M0.subst sub t0, M1.subst sub t1 32 | end 33 | 34 | 35 | module Const (M : sig type t end) : S with type t = M.t = 36 | struct 37 | type t = M.t 38 | let open_var _ _ x = x 39 | let close_var _ _ x = x 40 | let subst _ x = x 41 | end 42 | -------------------------------------------------------------------------------- /src/core/Lvl.ml: -------------------------------------------------------------------------------- 1 | type t = [`Omega | `Const of int] 2 | 3 | let greater l0 l1 = 4 | match l0, l1 with 5 | | `Omega, _ -> true 6 | (* The above is wrong, but it lets us work around some annoying complications with defining large eliminations; 7 | it's harmless, because the user is not able to type in the Omega universe. *) 8 | 9 | | `Const i0, `Const i1 -> i0 > i1 10 | | _ -> false 11 | 12 | let max l0 l1 = 13 | match l0, l1 with 14 | | `Const i0, `Const i1 -> `Const (max i0 i1) 15 | | _ -> `Omega 16 | 17 | let lte l0 l1 = l0 = l1 || greater l1 l0 18 | 19 | let shift k = 20 | function 21 | | `Omega -> `Omega 22 | | `Const i -> `Const (i + k) 23 | 24 | let pp fmt l = 25 | match l with 26 | | `Omega -> 27 | Uuseg_string.pp_utf_8 fmt "ω" 28 | | `Const i -> 29 | Format.fprintf fmt "%i" i 30 | -------------------------------------------------------------------------------- /src/core/Lvl.mli: -------------------------------------------------------------------------------- 1 | type t = [`Omega | `Const of int] 2 | 3 | val greater : t -> t -> bool 4 | val lte : t -> t -> bool 5 | val shift : int -> t -> t 6 | val pp : t Pp.t0 7 | 8 | val max : t -> t -> t 9 | -------------------------------------------------------------------------------- /src/core/Name.ml: -------------------------------------------------------------------------------- 1 | let debug_mode_flag = ref false 2 | 3 | let counter = ref 0 4 | let names = Hashtbl.create 1000 5 | 6 | type t = int 7 | 8 | let named nm = 9 | let i = !counter in 10 | counter := i + 1; 11 | Hashtbl.add names i nm; 12 | i 13 | 14 | let fresh () = 15 | named None 16 | 17 | let compare = 18 | Stdlib.compare 19 | 20 | let name i = 21 | match Hashtbl.find names i with 22 | | Some x -> Some x 23 | | None -> None 24 | 25 | let to_string i = 26 | match Hashtbl.find names i with 27 | | Some x -> x 28 | | None -> "%" ^ string_of_int i 29 | 30 | let pp fmt i = 31 | match Hashtbl.find names i with 32 | | Some x -> 33 | begin 34 | Uuseg_string.pp_utf_8 fmt x; 35 | if !debug_mode_flag then 36 | Format.fprintf fmt "%s%i" "%" i 37 | end 38 | | None -> 39 | Format.fprintf fmt "%s%i" "%" i 40 | 41 | 42 | let set_debug_mode b = 43 | debug_mode_flag := b 44 | -------------------------------------------------------------------------------- /src/core/Name.mli: -------------------------------------------------------------------------------- 1 | include Map.OrderedType 2 | 3 | val set_debug_mode : bool -> unit 4 | 5 | val named : string option -> t 6 | val fresh : unit -> t 7 | 8 | val to_string : t -> string 9 | val name : t -> string option 10 | 11 | val pp : t Pp.t0 12 | -------------------------------------------------------------------------------- /src/core/Occurs.ml: -------------------------------------------------------------------------------- 1 | open RedBasis.Bwd 2 | 3 | type flavor = [`Vars | `RigVars | `Metas] 4 | 5 | module Set = Set.Make (Name) 6 | 7 | module type S = 8 | sig 9 | type t 10 | val free : flavor -> t -> Set.t 11 | end 12 | 13 | module List (M : S) : S with type t = M.t list = 14 | struct 15 | type t = M.t list 16 | let free fl = 17 | let rec go xs acc = 18 | match xs with 19 | | [] -> acc 20 | | x::xs -> 21 | go xs @@ 22 | Set.union acc @@ 23 | M.free fl x 24 | in 25 | fun xs -> 26 | go xs Set.empty 27 | end 28 | 29 | module Bwd (M : S) : S with type t = M.t bwd = 30 | struct 31 | type t = M.t bwd 32 | let free fl = 33 | let rec go xs acc = 34 | match xs with 35 | | Emp -> acc 36 | | Snoc (xs, x) -> 37 | go xs @@ 38 | Set.union acc @@ 39 | M.free fl x 40 | in 41 | fun xs -> 42 | go xs Set.empty 43 | end 44 | -------------------------------------------------------------------------------- /src/core/Pp.ml: -------------------------------------------------------------------------------- 1 | open RedBasis open Bwd open BwdNotation 2 | 3 | module Env = 4 | struct 5 | type t = string bwd 6 | 7 | let emp = Emp 8 | 9 | let var i xs = 10 | if i < Bwd.length xs then 11 | Bwd.nth xs i 12 | else 13 | "{" ^ string_of_int i ^ "}" 14 | (* failwith "Pp printer: tried to resolve bound variable out of range" *) 15 | 16 | let proj xs = 17 | match xs with 18 | | Emp -> failwith "ppenv/proj" 19 | | Snoc (xs, _) -> xs 20 | 21 | let nat_to_suffix n = 22 | let formatted = string_of_int n in 23 | let lookup : int -> string = List.nth ["₀";"₁";"₂";"₃";"₄";"₅";"₆";"₇";"₈";"₉"] in 24 | String.concat "" @@ 25 | List.init (String.length formatted) @@ 26 | fun n -> lookup (Char.code (String.get formatted n) - Char.code '0') 27 | 28 | let rec rename xs x i = 29 | let suffix = nat_to_suffix i in 30 | let new_x = x ^ suffix in 31 | if Bwd.mem new_x xs then (rename [@tailcall]) xs x (i + 1) else new_x 32 | 33 | let choose_name xs x = 34 | if Bwd.mem x xs then rename xs x 1 else x 35 | 36 | (* FIXME what if there is a datatype called "x"? *) 37 | let bind xs nm = 38 | let x = 39 | match nm with 40 | | None | Some "_" -> choose_name xs "x" 41 | | Some x -> choose_name xs x 42 | in 43 | x, xs #< x 44 | 45 | let rec bindn env (nms : string option list) = 46 | match nms with 47 | | [] -> 48 | [], env 49 | | nm :: nms -> 50 | let x, env' = bind env nm in 51 | let xs, env'' = bindn env' nms in 52 | (x :: xs), env'' 53 | end 54 | 55 | type env = Env.t 56 | 57 | 58 | type 'a t0 = Format.formatter -> 'a -> unit 59 | type 'a t = env -> 'a t0 60 | 61 | let pp_list pp fmt xs = 62 | let pp_sep fmt () = Format.fprintf fmt ", " in 63 | Format.fprintf fmt "@[[%a]@]" 64 | (Format.pp_print_list ~pp_sep pp) xs 65 | 66 | let pp_bwd pp fmt xs = pp_list pp fmt (Bwd.to_list xs) 67 | -------------------------------------------------------------------------------- /src/core/Pp.mli: -------------------------------------------------------------------------------- 1 | module Env : 2 | sig 3 | type t 4 | val emp : t 5 | val var : int -> t -> string 6 | val bind : t -> string option -> string * t 7 | val bindn : t -> string option list -> string list * t 8 | 9 | val proj : t -> t 10 | end 11 | 12 | type env = Env.t 13 | 14 | type 'a t0 = Format.formatter -> 'a -> unit 15 | type 'a t = env -> 'a t0 16 | 17 | val pp_list : 'a t0 -> 'a list t0 18 | val pp_bwd : 'a t0 -> 'a RedBasis.Bwd.bwd t0 19 | -------------------------------------------------------------------------------- /src/core/PpExn.ml: -------------------------------------------------------------------------------- 1 | exception Unrecognized 2 | 3 | type printer = Format.formatter -> exn -> unit 4 | 5 | let printers = Stack.create () 6 | 7 | let install_printer printer = 8 | Stack.push printer printers; 9 | Printexc.register_printer @@ fun exn -> 10 | try 11 | printer Format.str_formatter exn; 12 | Some (Format.flush_str_formatter ()) 13 | with 14 | | Unrecognized -> 15 | None 16 | 17 | let pp fmt exn = 18 | let exception Break in 19 | let go printer = 20 | try 21 | printer fmt exn; 22 | raise Break 23 | with 24 | | Unrecognized -> () 25 | in 26 | try 27 | Stack.iter go printers; 28 | Format.fprintf fmt "%s" @@ Printexc.to_string exn 29 | with 30 | | Break -> () 31 | -------------------------------------------------------------------------------- /src/core/PpExn.mli: -------------------------------------------------------------------------------- 1 | exception Unrecognized 2 | 3 | type printer = Format.formatter -> exn -> unit 4 | val pp : printer 5 | 6 | val install_printer : printer -> unit 7 | -------------------------------------------------------------------------------- /src/core/Quote.mli: -------------------------------------------------------------------------------- 1 | open Domain 2 | 3 | module Env : 4 | sig 5 | type t 6 | 7 | val len : t -> int 8 | 9 | val emp : t 10 | val make : int -> t 11 | val succ : t -> t 12 | val abs : t -> Name.t list -> t 13 | 14 | val ix_of_lvl : int -> t -> int 15 | val ix_of_atom : Name.t -> t -> int 16 | end 17 | 18 | type env = Env.t 19 | 20 | module Error : sig 21 | type t 22 | val pp : t Pp.t0 23 | exception E of t 24 | end 25 | 26 | module type S = 27 | sig 28 | val quote_nf : env -> nf -> Tm.tm 29 | val quote_neu : env -> neu -> Tm.tm Tm.cmd 30 | val quote_ty : env -> value -> Tm.tm 31 | val quote_val_sys : env -> value -> val_sys -> (Tm.tm, Tm.tm) Tm.system 32 | val equate_data_params : env -> Name.t -> Desc.body -> env_el list -> env_el list -> Tm.tm list 33 | val quote_data_params : env -> Name.t -> Desc.body -> env_el list -> Tm.tm list 34 | 35 | val quote_dim : env -> I.t -> Tm.tm 36 | 37 | val equiv : env -> ty:value -> value -> value -> unit 38 | val equiv_ty : env -> value -> value -> unit 39 | val equiv_dim : env -> I.t -> I.t -> unit 40 | val equiv_data_params : env -> Name.t -> Desc.body -> env_el list -> env_el list -> unit 41 | val subtype : env -> value -> value -> unit 42 | 43 | val approx_restriction : env -> value -> value -> val_sys -> val_sys -> unit 44 | 45 | end 46 | 47 | module M (V : Val.S) : S 48 | -------------------------------------------------------------------------------- /src/core/Restriction.ml: -------------------------------------------------------------------------------- 1 | open RedBasis 2 | 3 | type atom = I.atom 4 | type dim = I.t 5 | 6 | type eqn = dim * dim 7 | 8 | module UF = DisjointSet.Make (PersistentTable.M) 9 | 10 | type t = 11 | {classes : dim UF.t; 12 | chronicle : eqn list; 13 | size : int} 14 | 15 | let pp_eqn fmt (r, r') = 16 | Format.fprintf fmt "%a=%a" I.pp r I.pp r' 17 | 18 | let pp_chronicle fmt chr = 19 | let comma fmt () = Format.fprintf fmt ", " in 20 | Format.pp_print_list ~pp_sep:comma pp_eqn fmt chr 21 | 22 | let pp fmt rst = 23 | pp_chronicle fmt rst.chronicle 24 | 25 | let chronicle rst = rst.chronicle 26 | 27 | 28 | let emp () = 29 | {classes = UF.init ~size:100; 30 | chronicle = []; 31 | size = 0} 32 | 33 | let equate_ r r' t = 34 | let dl = [r, r'] in 35 | {chronicle = dl @ t.chronicle; 36 | classes = UF.union r r' t.classes; 37 | size = t.size + 1} 38 | 39 | exception Inconsistent = I.Inconsistent 40 | 41 | let find r t = 42 | try 43 | UF.find r t.classes 44 | with 45 | | _ -> r 46 | 47 | let canonize r t = 48 | let rr = find r t in 49 | let res = 50 | if rr = find `Dim0 t then 51 | `Dim0 52 | else if rr = find `Dim1 t then 53 | `Dim1 54 | else 55 | rr 56 | in 57 | (* Format.printf "%a |= 0 ==> %a@." pp t D.pp_repr (find D.Dim0 t); 58 | Format.printf "Canonizing %a in %a as %a@." D.pp_repr r pp t D.pp_repr res; *) 59 | res 60 | 61 | let compare r r' t = 62 | let cr = canonize r t in 63 | let cr' = canonize r' t in 64 | I.compare cr cr' 65 | 66 | 67 | let equate r0 r1 t = 68 | let res = equate_ r0 r1 t in 69 | begin 70 | match compare `Dim0 `Dim1 res with 71 | | `Same -> 72 | raise Inconsistent 73 | | _ -> () 74 | end; 75 | res, I.equate r0 r1 76 | 77 | let as_action t = 78 | let rec go = 79 | function 80 | | [] -> I.idn 81 | | (r, r') :: chr -> 82 | I.cmp (I.equate r r') (go chr) 83 | in 84 | go t.chronicle 85 | 86 | (* poor man's tests *) 87 | let _ = 88 | try 89 | let x = `Atom (Name.named (Some "i")) in 90 | let rst, _ = equate x `Dim1 @@ emp () in 91 | let rst, _ = equate x `Dim0 rst in 92 | Format.printf "Test failure: {@[<1>%a@]}@.\n" pp_chronicle rst.chronicle; 93 | failwith "Test failed" 94 | with 95 | | Inconsistent -> () 96 | 97 | let _ = 98 | let x = `Atom (Name.named (Some "i")) in 99 | let rst, _ = equate x `Dim0 @@ emp () in 100 | assert (canonize x rst = `Dim0) 101 | 102 | 103 | -------------------------------------------------------------------------------- /src/core/Restriction.mli: -------------------------------------------------------------------------------- 1 | type atom = I.atom 2 | type dim = I.t 3 | 4 | type t 5 | 6 | val emp : unit -> t 7 | 8 | (* May raise I.Inconsistent *) 9 | val equate : dim -> dim -> t -> t * I.action 10 | 11 | val compare : dim -> dim -> t -> I.compare 12 | 13 | val as_action : t -> I.action 14 | val pp : Format.formatter -> t -> unit 15 | 16 | 17 | val chronicle : t -> (dim * dim) list 18 | -------------------------------------------------------------------------------- /src/core/Sort.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type t 4 | type 'a m 5 | val act : I.action -> t -> t m 6 | end 7 | 8 | module Prod (X1 : S with type 'a m = 'a) (X2 : S with type 'a m = 'a) : S with type t = X1.t * X2.t with type 'a m = 'a = 9 | struct 10 | type t = X1.t * X2.t 11 | type 'a m = 'a 12 | 13 | let act phi (x1, x2) = 14 | X1.act phi x1, X2.act phi x2 15 | end 16 | -------------------------------------------------------------------------------- /src/core/Sort.mli: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type t 4 | type 'a m 5 | val act : I.action -> t -> t m 6 | end 7 | 8 | module Prod (X1 : S with type 'a m = 'a) (X2 : S with type 'a m = 'a) : S with type t = X1.t * X2.t with type 'a m = 'a 9 | -------------------------------------------------------------------------------- /src/core/Tm.mli: -------------------------------------------------------------------------------- 1 | open RedBasis.Bwd 2 | include module type of TmData 3 | 4 | 5 | type tm 6 | 7 | module Error : 8 | sig 9 | type t 10 | val pp : t Pp.t0 11 | exception E of t 12 | end 13 | 14 | val map_head : (tm -> tm) -> tm head -> tm head 15 | val map_frame : (tm -> tm) -> tm frame -> tm frame 16 | val map_spine : (tm -> tm) -> tm spine -> tm spine 17 | val map_tmf : (tm -> tm) -> tm tmf -> tm tmf 18 | val map_tm_sys : (tm -> tm) -> (tm, tm) system -> (tm, tm) system 19 | 20 | 21 | type 'a subst 22 | 23 | val shift : int -> 'a subst 24 | val dot : 'a -> 'a subst -> 'a subst 25 | 26 | 27 | val make : tm tmf -> tm 28 | val unleash : tm -> tm tmf 29 | 30 | val open_var : int -> ?twin:twin option -> Name.t -> tm -> tm 31 | val close_var : Name.t -> ?twin:twin option -> int -> tm -> tm 32 | 33 | val bind : Name.t -> tm -> tm bnd 34 | val bindn : Name.t bwd -> tm -> tm nbnd 35 | val unbind : tm bnd -> Name.t * tm 36 | val unbindn : tm nbnd -> Name.t bwd * tm 37 | val unbind_ext : (tm * (tm, tm) system) nbnd -> Name.t bwd * tm * (tm, tm) system 38 | val unbind_ext_with : tm cmd list -> (tm * (tm, tm) system) nbnd -> tm * (tm, tm) system 39 | val bind_ext : Name.t bwd -> tm -> (tm, tm) system -> (tm * (tm, tm) system) nbnd 40 | 41 | val unbind_with : tm cmd -> tm bnd -> tm 42 | val unbindn_with : tm cmd list -> tm nbnd -> tm 43 | 44 | val lift : tm cmd subst -> tm cmd subst 45 | 46 | val subst : tm cmd subst -> tm -> tm 47 | val subst_cmd : tm cmd subst -> tm cmd -> tm cmd 48 | 49 | val shift_univ : int -> tm -> tm 50 | 51 | (* make sure you know what you are doing, LOL *) 52 | val eta_contract : tm -> tm 53 | 54 | 55 | val forty_two : tm 56 | 57 | val up : tm cmd -> tm 58 | val ann : ty:tm -> tm:tm -> tm cmd 59 | 60 | val ix : ?twin:twin -> int -> tm cmd 61 | val var : ?twin:twin -> Name.t -> tm cmd 62 | val let_ : string option -> tm cmd -> tm -> tm 63 | 64 | val lam : string option -> tm -> tm 65 | val ext_lam : string option bwd -> tm -> tm 66 | val pi : string option -> tm -> tm -> tm 67 | val sg : string option -> tm -> tm -> tm 68 | val cons : tm -> tm -> tm 69 | val univ : kind:Kind.t -> lvl:Lvl.t -> tm 70 | 71 | 72 | val arr : tm -> tm -> tm 73 | val times : tm -> tm -> tm 74 | 75 | (* non-dependent path *) 76 | val path : tm -> tm -> tm -> tm 77 | val refl : tm -> tm 78 | val is_contr : tm -> tm 79 | val fiber : ty0:tm -> ty1:tm -> f:tm -> x:tm -> tm 80 | val equiv : tm -> tm -> tm 81 | 82 | (** boundary refinement *) 83 | val refine_ty : tm -> (tm, tm) system -> tm 84 | val refine_thunk : tm -> tm 85 | val refine_force : 'a cmd -> 'a cmd 86 | 87 | 88 | val pp : tm Pp.t 89 | val pp0 : tm Pp.t0 90 | val pp_cmd : tm cmd Pp.t 91 | val pp_head : tm head Pp.t 92 | val pp_frame : tm frame Pp.t 93 | val pp_spine : tm spine Pp.t 94 | val pp_sys : (tm, tm) system Pp.t 95 | val pp_bnd : tm bnd Pp.t 96 | val pp0_bnd : tm bnd Pp.t0 97 | val pp_nbnd : tm nbnd Pp.t 98 | val pp0_nbnd : tm nbnd Pp.t0 99 | 100 | include Occurs.S with type t := tm 101 | 102 | module Sp : 103 | sig 104 | include Occurs.S with type t = tm spine 105 | end 106 | 107 | 108 | module Notation : 109 | sig 110 | val (@<) : 'a cmd -> 'a frame -> 'a cmd 111 | end 112 | -------------------------------------------------------------------------------- /src/core/TmData.ml: -------------------------------------------------------------------------------- 1 | open RedBasis.Bwd 2 | 3 | type twin = [`Only | `TwinL | `TwinR] 4 | 5 | type 'a bnd = B of string option * 'a 6 | type 'a nbnd = NB of string option bwd * 'a 7 | 8 | type ('r, 'a) face = 'r * 'r * 'a 9 | type ('r, 'a) system = ('r, 'a) face list 10 | 11 | 12 | type 'a tmf = 13 | | FHCom of {r : 'a; r' : 'a; cap : 'a; sys : ('a, 'a bnd) system} 14 | 15 | | Univ of {kind : Kind.t; lvl : Lvl.t} 16 | | Pi of 'a * 'a bnd 17 | | Ext of ('a * ('a, 'a) system) nbnd 18 | | Restrict of ('a, 'a) face 19 | | Sg of 'a * 'a bnd 20 | 21 | | V of {r : 'a; ty0 : 'a; ty1 : 'a; equiv : 'a} 22 | | VIn of {r : 'a; tm0 : 'a; tm1 : 'a} 23 | 24 | | Lam of 'a bnd 25 | | ExtLam of 'a nbnd 26 | | RestrictThunk of ('a, 'a) face 27 | 28 | | Cons of 'a * 'a 29 | 30 | | Dim0 31 | | Dim1 32 | 33 | | Box of {r : 'a; r' : 'a; cap : 'a; sys : ('a, 'a) system} 34 | 35 | | Up of 'a cmd 36 | | Let of 'a cmd * 'a bnd 37 | 38 | | Data of {lbl : Name.t; params : 'a list} 39 | | Intro of Name.t * string * 'a list * 'a list (* TODO: turn this into inline record *) 40 | 41 | | FortyTwo 42 | 43 | and 'a head = 44 | | Meta of {name: Name.t; ushift : int} 45 | | Var of {name : Name.t; twin : twin; ushift : int} 46 | | Ix of int * twin 47 | | Down of {ty : 'a; tm : 'a} 48 | | DownX of 'a 49 | | Coe of {r : 'a; r' : 'a; ty : 'a bnd; tm : 'a} 50 | | HCom of {r : 'a; r' : 'a; ty : 'a; cap : 'a; sys : ('a, 'a bnd) system} 51 | | Com of {r : 'a; r' : 'a; ty : 'a bnd; cap : 'a; sys : ('a, 'a bnd) system} 52 | | GHCom of {r : 'a; r' : 'a; ty : 'a; cap : 'a; sys : ('a, 'a bnd) system} 53 | | GCom of {r : 'a; r' : 'a; ty : 'a bnd; cap : 'a; sys : ('a, 'a bnd) system} 54 | 55 | 56 | and 'a frame = 57 | | Fst 58 | | Snd 59 | | FunApp of 'a 60 | | ExtApp of 'a list 61 | | VProj of {r : 'a; ty0 : 'a; ty1 : 'a; func : 'a} 62 | | Cap of {r : 'a; r' : 'a; ty : 'a; sys : ('a, 'a bnd) system} 63 | | RestrictForce 64 | 65 | | Elim of {dlbl : Name.t; params : 'a list; mot : 'a bnd; clauses : (string * 'a nbnd) list} 66 | 67 | and 'a spine = 'a frame list 68 | and 'a cmd = 'a head * 'a spine 69 | -------------------------------------------------------------------------------- /src/core/TmUtil.ml: -------------------------------------------------------------------------------- 1 | open RedBasis.Bwd 2 | 3 | let make_node _start _stop con = 4 | Tm.make con 5 | 6 | type tele = 7 | | TCons of string option * Tm.tm * tele 8 | | TEnd of Tm.tm 9 | 10 | type 'a multibind = 11 | | MBConsVar of string option * 'a multibind 12 | | MBConsDims of string option list * 'a multibind 13 | | MBEnd of 'a 14 | 15 | let rec pi_from_tele info tele = 16 | match tele with 17 | | TEnd ty -> ty 18 | | TCons (nm, ty, tele) -> 19 | Tm.pi nm ty @@ 20 | pi_from_tele info tele 21 | 22 | let rec sg_from_tele info tele = 23 | match tele with 24 | | TEnd ty -> ty 25 | | TCons (nm, ty, tele) -> 26 | Tm.sg nm ty @@ 27 | sg_from_tele info tele 28 | 29 | let rec lam_from_multibind info mb = 30 | match mb with 31 | | MBEnd bdy -> bdy 32 | | MBConsVar (nm, mb) -> 33 | Tm.lam nm @@ 34 | lam_from_multibind info mb 35 | | MBConsDims (nms, mb) -> 36 | Tm.ext_lam (Bwd.from_list nms) @@ 37 | lam_from_multibind info mb 38 | 39 | let rec ext_from_multibind start stop mb = 40 | match mb with 41 | | MBConsDims (nms, MBEnd (ty, sys)) -> 42 | Tm.make @@ Tm.Ext (Tm.NB (Bwd.from_list nms, (ty, sys))) 43 | 44 | | MBConsDims (nms, mb) -> 45 | Tm.make @@ Tm.Ext (Tm.NB (Bwd.from_list nms, (ext_from_multibind start stop mb, []))) 46 | 47 | | _ -> 48 | failwith "ext_from_multibind" 49 | 50 | 51 | let make_dim_const start stop i = 52 | match i with 53 | | 0 -> make_node start stop Tm.Dim0 54 | | 1 -> make_node start stop Tm.Dim1 55 | | _ -> failwith "make_dim_const" 56 | -------------------------------------------------------------------------------- /src/core/Typing.mli: -------------------------------------------------------------------------------- 1 | type value = Domain.value 2 | type cx = Cx.t 3 | 4 | module Error : 5 | sig 6 | type t 7 | exception E of t 8 | val pp : t Pp.t0 9 | end 10 | 11 | val check_ : cx -> value -> Domain.val_sys -> Tm.tm -> unit 12 | val check : cx -> value -> Tm.tm -> unit 13 | val infer : cx -> Tm.tm Tm.cmd -> value 14 | 15 | 16 | val check_tm_sys : cx -> value -> (Tm.tm, Tm.tm) Tm.system -> unit 17 | -------------------------------------------------------------------------------- /src/core/Val.mli: -------------------------------------------------------------------------------- 1 | include module type of ValSig 2 | 3 | module Error : 4 | sig 5 | type t 6 | val pp : t Pp.t0 7 | exception E of t 8 | end 9 | 10 | 11 | module M (Sig : Sig) : S with module Sig = Sig 12 | -------------------------------------------------------------------------------- /src/core/ValSig.ml: -------------------------------------------------------------------------------- 1 | open Domain 2 | 3 | module type Sig = 4 | sig 5 | val restriction : Restriction.t 6 | 7 | val global_dims : dim DimEnv.t 8 | 9 | (** Return the type and definition of a global variable *) 10 | val lookup_with_twin : Name.t -> Tm.twin -> Tm.tm * Tm.tm option 11 | 12 | val lookup_datatype : Name.t -> Desc.desc 13 | end 14 | 15 | exception MissingElimClause of string 16 | 17 | module type S = 18 | sig 19 | val empty_env : env 20 | 21 | val unleash : value -> con 22 | 23 | val reflect : value -> neu -> val_sys -> value 24 | 25 | val eval : env -> Tm.tm -> value 26 | val eval_cmd : env -> Tm.tm Tm.cmd -> value 27 | val eval_head : env -> Tm.tm Tm.head -> value 28 | val eval_frame : env -> value -> Tm.tm Tm.frame -> value 29 | val eval_dim : env -> Tm.tm -> I.t 30 | val eval_tm_sys : env -> (Tm.tm, Tm.tm) Tm.system -> val_sys 31 | 32 | val make_closure : env -> Tm.tm Tm.bnd -> clo 33 | 34 | val apply : value -> value -> value 35 | val ext_apply : value -> dim list -> value 36 | 37 | val do_fst : value -> value 38 | val do_snd : value -> value 39 | val restriction_force : value -> value 40 | 41 | val rigid_vproj : atom -> func:value -> el:value -> value 42 | val rigid_cap : dir -> value -> comp_sys -> value -> value 43 | val rigid_coe : dir -> abs -> value -> value 44 | val make_coe : dir Dir.m -> abs -> value -> value 45 | 46 | val inst_clo : clo -> value -> value 47 | val inst_nclo : nclo -> env_el list -> value 48 | 49 | val unleash_pi : value -> value * clo 50 | val unleash_sg : value -> value * clo 51 | val unleash_v : value -> atom * value * value * value 52 | val unleash_ext_with : value -> dim list -> value * val_sys 53 | val unleash_restriction_ty : value -> val_face 54 | 55 | 56 | val realize_rec_spec : dlbl:Name.t -> params:env_el list -> Desc.rec_spec -> value 57 | val realize_rec_spec_ih : dlbl:Name.t -> params:env_el list -> mot:clo -> Desc.rec_spec -> value -> value 58 | 59 | val elim_data : dlbl:Name.t -> params:env_el list -> mot:clo -> scrut:value -> clauses:(string * nclo) list -> value 60 | val make_intro : dlbl:Name.t -> params:env_el list -> clbl:string -> env_el list -> value 61 | 62 | module Sig : Sig 63 | 64 | module Macro : sig 65 | val equiv : value -> value -> value 66 | val func : value -> value -> value 67 | end 68 | end 69 | -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name RedTT_Core) 3 | (flags 4 | (:standard -w -32-26-27-37)) 5 | (public_name redtt.core) 6 | (libraries redtt.basis uuseg uuseg.string uutf)) 7 | -------------------------------------------------------------------------------- /src/frontend/Contextual.mli: -------------------------------------------------------------------------------- 1 | open RedTT_Core 2 | open RedBasis 3 | open Dev 4 | 5 | include Monad.S 6 | 7 | val ask : params m 8 | val local : (params -> params) -> 'a m -> 'a m 9 | val fix : ('a m -> 'a m) -> 'a m 10 | 11 | val assert_top_level : unit m 12 | 13 | val modify_mlenv : (ML.mlenv -> ML.mlenv) -> unit m 14 | val mlenv : ML.mlenv m 15 | val mlconf : ML.mlconf m 16 | 17 | val resolver : ResEnv.t m 18 | val modify_top_resolver : (ResEnv.t -> ResEnv.t) -> unit m 19 | val declare_datatype : src:string -> ResEnv.visibility -> Name.t -> Desc.desc -> unit m 20 | val replace_datatype : Name.t -> Desc.desc -> unit m 21 | 22 | val source_stem : Name.t -> FileRes.filepath option m 23 | 24 | exception CyclicDependency 25 | type rotted_resolver = ResEnv.t * Digest.t 26 | val retrieve_module : stem:FileRes.filepath -> rotted_resolver option m 27 | val store_module : stem:FileRes.filepath -> rotted_resolver -> unit m 28 | val touch_module : stem:FileRes.filepath -> unit m 29 | 30 | val isolate_local : 'a m -> 'a m 31 | val isolate_module : mlconf : ML.mlconf -> 'a m -> 'a m 32 | val run : mlconf : ML.mlconf -> 'a m -> 'a 33 | 34 | val popl : entry m 35 | val popr : entry m 36 | val popr_opt : entry option m 37 | 38 | val push_update : Name.t -> unit m 39 | 40 | val optional : 'a m -> 'a option m 41 | 42 | val pushl : entry -> unit m 43 | val pushr : entry -> unit m 44 | val pushls : entry list -> unit m 45 | 46 | val go_to_top : unit m 47 | val go_left : unit m 48 | 49 | val in_scope : Name.t -> ty param -> 'a m -> 'a m 50 | val in_scopes : (Name.t * ty param) list -> 'a m -> 'a m 51 | val under_restriction : tm -> tm -> 'a m -> 'a option m 52 | 53 | val lookup_var : Name.t -> twin -> ty m 54 | val lookup_meta : Name.t -> (ty * [`Rigid | `Flex]) m 55 | 56 | val postpone : status -> problem -> unit m 57 | val active : problem -> unit m 58 | val block : problem -> unit m 59 | 60 | 61 | val check : ty:ty -> ?sys:(tm, tm) Tm.system -> tm -> [`Ok | `Exn of exn * Printexc.raw_backtrace] m 62 | val check_subtype : ty -> ty -> [`Ok | `Exn of exn * Printexc.raw_backtrace] m 63 | val check_eq : ty:ty -> tm -> tm -> [`Ok | `Exn of exn * Printexc.raw_backtrace] m 64 | val compare_dim : tm -> tm -> I.compare m 65 | val check_eq_dim : tm -> tm -> bool m 66 | 67 | 68 | val global_env : Subst.t m 69 | val base_cx : Cx.t m 70 | 71 | val dump_state : Format.formatter -> string -> [`All | `Constraints | `Unsolved] -> unit m 72 | 73 | val abort_unsolved : loc:Log.location -> unit m 74 | 75 | (* these two are for rot files *) 76 | val lookup_top : Name.t -> (Subst.entry * [`Rigid | `Flex] option) m 77 | val restore_top : 78 | Name.t 79 | -> stem : FileRes.filepath 80 | -> Subst.entry * [`Rigid | `Flex] option 81 | -> unit m 82 | -------------------------------------------------------------------------------- /src/frontend/Dev.mli: -------------------------------------------------------------------------------- 1 | open RedBasis.Bwd 2 | open RedTT_Core 3 | 4 | type tm = Tm.tm 5 | type ty = Tm.tm 6 | 7 | type 'a decl = 8 | | Hole of [`Rigid | `Flex] 9 | (** a hole during the development *) 10 | | Auxiliary of 'a 11 | (** this means a variable can be expanded into a term, 12 | and this is not generated by the user. *) 13 | | UserDefn of 14 | {source : FileRes.filepath; 15 | visibility : ResEnv.visibility; 16 | opacity : [`Transparent | `Opaque]; 17 | tm : 'a} 18 | (** this is a definition given by the user and has been type-checked *) 19 | | Guess of {ty : 'a; tm : 'a} 20 | (** we have a term [tm] of type [ty], which is not yet the same as 21 | the hole we are trying to fill *) 22 | 23 | type status = 24 | | Blocked 25 | | Active 26 | 27 | type ('a, 'b) equation = 28 | {ty0 : ty; 29 | tm0 : 'a; 30 | ty1 : ty; 31 | tm1 : 'b} 32 | 33 | (* The [param] and [params] types are really dumb; it should not be any kind of list. Instead it should be an ordinary datatype. 34 | Right now we're going through such stupid contortions to make it a last. For instance, not every cell 35 | should be binding a variable, lmao! *) 36 | type 'a param = 37 | [ `I (** a local binder for a dimension variable. *) 38 | | `NullaryExt (** a local binder that binds nothing but imposes a system. *) 39 | | `P of 'a (** a local binder for an expression variable. the argument is the type *) 40 | | `Def of 'a * 'a (** a local binder for user definitions. the first argument is the type and the second is the term. *) 41 | | `Tw of 'a * 'a (** a local binder which binds a twin variable, with a type for each side of a unification problem *) 42 | | `R of 'a * 'a (** a local binder that binds nothing but restricts the context. *) 43 | ] 44 | 45 | type params = (Name.t * ty param) bwd 46 | 47 | type 'a bind 48 | 49 | type problem = 50 | | Unify of (tm, tm) equation 51 | | Subtype of {ty0 : ty; ty1 : ty} 52 | | All of ty param * problem bind 53 | 54 | type entry = 55 | | E of Name.t * ty * tm decl 56 | | Q of status * problem 57 | 58 | val bind : Name.t -> 'a param -> problem -> problem bind 59 | val unbind : 'a param -> problem bind -> Name.t * problem 60 | 61 | val inst_with_vars : Name.t list -> problem -> [`Unify of (tm, tm) equation | `Subtype of tm * tm] option 62 | 63 | 64 | val pp_params : params Pp.t0 65 | val pp_entry : entry Pp.t0 66 | 67 | 68 | type twin = Tm.twin 69 | 70 | module Subst = GlobalEnv 71 | 72 | module type DevSort = 73 | sig 74 | include Occurs.S 75 | val pp : t Pp.t0 76 | val subst : Subst.t -> t -> t 77 | end 78 | 79 | module Problem : 80 | sig 81 | include DevSort with type t = problem 82 | val eqn : ty0:ty -> tm0:tm -> ty1:ty -> tm1:tm -> problem 83 | val all : Name.t -> ty -> problem -> problem 84 | val all_twins : Name.t -> ty -> ty -> problem -> problem 85 | val all_dims : Name.t list -> problem -> problem 86 | end 87 | 88 | module Param : DevSort with type t = ty param 89 | 90 | module Params : Occurs.S with type t = ty param bwd 91 | 92 | module Equation : 93 | sig 94 | include DevSort with type t = (tm, tm) equation 95 | val sym : ('a, 'b) equation -> ('b, 'a) equation 96 | end 97 | 98 | module Decl : Occurs.S with type t = tm decl 99 | 100 | module Entry : 101 | sig 102 | include DevSort with type t = entry 103 | val is_incomplete : t -> bool 104 | end 105 | 106 | module Entries : Occurs.S with type t = entry list 107 | -------------------------------------------------------------------------------- /src/frontend/Elaborator.mli: -------------------------------------------------------------------------------- 1 | module type Import = 2 | sig 3 | val top_load_file : FileRes.filepath -> unit Contextual.m 4 | val top_load_stdin : red : FileRes.filepath -> unit Contextual.m 5 | val import : selector : FileRes.selector -> Contextual.rotted_resolver Contextual.m 6 | end 7 | 8 | module type S = 9 | sig 10 | val eval_cmd : ML.mlcmd -> ML.semcmd Contextual.m 11 | end 12 | 13 | module Make (I : Import) : S 14 | -------------------------------------------------------------------------------- /src/frontend/FileRes.ml: -------------------------------------------------------------------------------- 1 | open RedBasis 2 | 3 | let redlib_name = "redlib" 4 | let red_extention = ".red" 5 | let rot_extention = ".rot" 6 | 7 | type filepath = string 8 | type selector = string list 9 | 10 | let pp_selector = 11 | let pp_sep fmt () = Format.eprintf "." in 12 | Format.pp_print_list ~pp_sep Format.pp_print_string 13 | 14 | let find_redlib_root (base_dir : string) : string option = 15 | SysUtil.protect_cwd @@ fun cur -> 16 | let rec go cur = 17 | if Sys.file_exists redlib_name then 18 | Some cur 19 | else 20 | let () = Sys.chdir Filename.parent_dir_name in 21 | let up = Sys.getcwd () in 22 | if up = cur then begin 23 | Log.pp_message ~loc:None ~lvl:`Warn 24 | Format.pp_print_string 25 | Format.std_formatter 26 | "You are using the special local import mode. This is not recommended. You have been warned."; 27 | None 28 | end else 29 | go up 30 | in 31 | Sys.chdir base_dir; 32 | go (Sys.getcwd ()) 33 | 34 | let selector_to_stem ~stem selector = 35 | let module_path = String.concat Filename.dir_sep selector in 36 | let base_dir = Filename.dirname stem in 37 | let base_dir = Option.default base_dir (find_redlib_root base_dir) in 38 | Filename.concat base_dir module_path 39 | 40 | let stem_to_red stem = stem ^ red_extention 41 | 42 | let stem_to_rot stem = stem ^ rot_extention 43 | 44 | let red_to_stem red = 45 | match String.sub red (String.length red - 4) 4 with 46 | | str when str = red_extention -> String.sub red 0 @@ String.length red - 4 47 | | _ -> invalid_arg "red_to_stem" 48 | | exception Invalid_argument _ -> invalid_arg "red_to_stem" 49 | -------------------------------------------------------------------------------- /src/frontend/FileRes.mli: -------------------------------------------------------------------------------- 1 | open RedTT_Core 2 | 3 | type filepath = string 4 | type selector = string list 5 | 6 | val selector_to_stem : stem : filepath -> selector -> filepath 7 | val red_to_stem : filepath -> filepath 8 | val stem_to_red : filepath -> filepath 9 | val stem_to_rot : filepath -> filepath 10 | 11 | val pp_selector : selector Pp.t0 12 | -------------------------------------------------------------------------------- /src/frontend/Frontend.ml: -------------------------------------------------------------------------------- 1 | open RedBasis 2 | open RedTT_Core 3 | 4 | type options = 5 | {file_name : string; 6 | line_width : int; 7 | debug_mode : bool; 8 | shell_mode : bool; 9 | recheck : bool} 10 | 11 | let print_position outx lexbuf = 12 | let open Lexing in 13 | let pos = lexbuf.lex_curr_p in 14 | Format.fprintf outx "%s:%d:%d" pos.pos_fname 15 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 16 | 17 | let set_options options = 18 | Format.set_margin options.line_width; 19 | Name.set_debug_mode options.debug_mode; 20 | RotIO.set_unsafe_mode options.shell_mode; 21 | Importer.set_ignore_rot options.recheck 22 | 23 | (* MORTAL there's actually already a copy of [Elab] in [Importer]. *) 24 | module Elab = Elaborator.Make (Importer.M) 25 | 26 | let execute_ml ~mlconf cmd = 27 | ignore @@ Contextual.run ~mlconf @@ Elab.eval_cmd cmd 28 | 29 | let load options source = 30 | try 31 | set_options options; 32 | let red = SysUtil.normalize options.file_name in 33 | let mlconf : ML.mlconf = ML.TopModule {indent = ""} in 34 | execute_ml ~mlconf @@ 35 | match source with 36 | | `Stdin -> ML.MlTopLoadStdin {red} 37 | | `File -> ML.MlTopLoadFile red 38 | with 39 | | ParseError.E (posl, posr) -> 40 | let loc = Some (posl, posr) in 41 | let pp fmt () = Format.fprintf fmt "Parse error" in 42 | Log.pp_message ~loc ~lvl:`Error pp Format.err_formatter (); 43 | exit 1 44 | 45 | let load_file options = 46 | load options `File 47 | 48 | let load_from_stdin options = 49 | load options `Stdin 50 | -------------------------------------------------------------------------------- /src/frontend/Frontend.mli: -------------------------------------------------------------------------------- 1 | type options = 2 | {file_name : string; 3 | line_width : int; 4 | debug_mode : bool; 5 | shell_mode : bool; 6 | recheck : bool} 7 | 8 | val load_file : options -> unit 9 | val load_from_stdin : options -> unit 10 | -------------------------------------------------------------------------------- /src/frontend/Importer.mli: -------------------------------------------------------------------------------- 1 | open Contextual 2 | 3 | val set_ignore_rot : bool -> unit 4 | 5 | module M : 6 | sig 7 | (** load the content of file at the top module. *) 8 | val top_load_file : FileRes.filepath -> unit m 9 | 10 | (** load from the standard input at the top module. *) 11 | val top_load_stdin : red : FileRes.filepath -> unit m 12 | 13 | (** import some module. *) 14 | val import : selector : FileRes.selector -> rotted_resolver m 15 | end 16 | -------------------------------------------------------------------------------- /src/frontend/Log.ml: -------------------------------------------------------------------------------- 1 | type level = [`Info | `Error | `Warn] 2 | 3 | type location = (Lexing.position * Lexing.position) option 4 | 5 | let pp_lvl fmt = 6 | function 7 | | `Info -> 8 | Format.fprintf fmt "Info" 9 | | `Error -> 10 | Format.fprintf fmt "Error" 11 | | `Warn -> 12 | Format.fprintf fmt "Warn" 13 | 14 | let pp_message ~loc ~lvl pp fmt data = 15 | match loc with 16 | | None -> 17 | pp fmt data 18 | | Some (start_pos, end_pos) -> 19 | let open Lexing in 20 | Format.fprintf fmt "@.@.@[%a:%i.%i-%i.%i [%a]:@, %a@]@.@." 21 | Uuseg_string.pp_utf_8 start_pos.pos_fname 22 | start_pos.pos_lnum 23 | (start_pos.pos_cnum - start_pos.pos_bol) 24 | end_pos.pos_lnum 25 | (end_pos.pos_cnum - end_pos.pos_bol) 26 | pp_lvl lvl 27 | pp data 28 | -------------------------------------------------------------------------------- /src/frontend/Log.mli: -------------------------------------------------------------------------------- 1 | open RedTT_Core 2 | 3 | type level = [`Info | `Error | `Warn] 4 | 5 | type location = (Lexing.position * Lexing.position) option 6 | 7 | (* TODO: would be nice to figure out how to turn this into our own printf-style function *) 8 | val pp_message 9 | : loc:location 10 | -> lvl:level 11 | -> 'a Pp.t0 12 | -> Format.formatter 13 | -> 'a 14 | -> unit 15 | -------------------------------------------------------------------------------- /src/frontend/ParseError.ml: -------------------------------------------------------------------------------- 1 | exception E of Lexing.position * Lexing.position 2 | -------------------------------------------------------------------------------- /src/frontend/Refiner.mli: -------------------------------------------------------------------------------- 1 | open Dev 2 | open RedTT_Core 3 | open Contextual 4 | 5 | type sys = (tm, tm) Tm.system 6 | type goal = {ty : ty; sys : sys} 7 | type chk_tac = goal -> tm m 8 | type inf_tac = (ty * tm) m 9 | 10 | exception ChkMatch 11 | 12 | (** Decompose the current goal and try to solve it by reflexivity automatically. *) 13 | val tac_refl : chk_tac 14 | 15 | (** Try to solve the current goal using the current restriction, and/or unification. *) 16 | val tac_hope : chk_tac 17 | 18 | 19 | val inspect_goal : loc:Log.location -> name:string option -> goal -> unit m 20 | 21 | (** Unleash a hole named [name]. *) 22 | val tac_hole : loc:Log.location -> name:string option -> chk_tac 23 | 24 | (** Run the input tactic without the restriction, and then store the result 25 | as a guess for the current hole in the proof state. *) 26 | val tac_guess : chk_tac -> chk_tac 27 | 28 | 29 | val tac_fix : (chk_tac -> chk_tac) -> chk_tac 30 | val match_goal : (goal -> chk_tac) -> chk_tac 31 | 32 | 33 | (** Try to run a tactic against the current type, but if it raises [ChkMatch], re-run it after normalizing the type. *) 34 | val tac_wrap_nf : chk_tac -> chk_tac 35 | 36 | (** Multi-introduction tactic *) 37 | val tac_lambda : ML.einvpat list -> chk_tac -> chk_tac 38 | 39 | (** Introduce a sigma type *) 40 | val tac_pair : chk_tac -> chk_tac -> chk_tac 41 | 42 | (** Call a data elimination rule. *) 43 | val tac_elim 44 | : loc:Log.location 45 | -> tac_mot:chk_tac option 46 | -> tac_scrut:inf_tac 47 | -> clauses:(string * ML.einvpat ML.epatbind list * chk_tac) list 48 | -> default:chk_tac option 49 | -> chk_tac 50 | 51 | (** Call a data elimination rule. *) 52 | val tac_elim_inf 53 | : loc:Log.location 54 | -> tac_mot:chk_tac 55 | -> tac_scrut:inf_tac 56 | -> clauses:(string * ML.einvpat ML.epatbind list * chk_tac) list 57 | -> default:chk_tac option 58 | -> inf_tac 59 | 60 | val tac_generalize 61 | : tac_scrut:inf_tac 62 | -> chk_tac 63 | -> chk_tac 64 | 65 | (** Introduce a let-binding. *) 66 | val tac_let : Name.t -> inf_tac -> chk_tac -> chk_tac 67 | val tac_inv_let : ML.einvpat -> inf_tac -> chk_tac -> chk_tac 68 | 69 | (** Try to solve a goal with a term, unifying it against the ambient restriction. *) 70 | val guess_restricted : tm -> chk_tac 71 | 72 | 73 | val normalize_ty : ty -> ty m 74 | 75 | val name_of : [`User of string | `Gen of Name.t] -> Name.t 76 | 77 | 78 | val unify : unit m 79 | -------------------------------------------------------------------------------- /src/frontend/ResEnv.mli: -------------------------------------------------------------------------------- 1 | open RedTT_Core 2 | 3 | (** This module has two responsibilities: 4 | 5 | 1. maintain the mapping from strings to names. 6 | 2. keep track of items to be serialized. *) 7 | 8 | type resolution = 9 | [ `Ix of int 10 | | `Name of Name.t 11 | ] 12 | 13 | type visibility = 14 | [ `Private | `Public ] 15 | 16 | 17 | type t 18 | val init : unit -> t 19 | val bind : string -> t -> t 20 | val bindn : string list -> t -> t 21 | val bind_opt : string option -> t -> t 22 | 23 | val add_native_global : visibility:visibility -> Name.t -> t -> t 24 | val import_global : visibility:visibility -> Name.t -> t -> t 25 | val import_public : visibility:visibility -> t -> t -> t 26 | 27 | val get : string -> t -> resolution 28 | val get_name : string -> t -> Name.t 29 | 30 | val native_of_name : Name.t -> t -> int option 31 | val name_of_native : int -> t -> Name.t option 32 | type exported_natives = (string option * Name.t) list 33 | type exported_foreigners = Name.t list 34 | val export_native_globals : t -> exported_natives 35 | val export_foreign_globals : t -> exported_foreigners 36 | 37 | val pp_visibility : visibility Pp.t0 38 | -------------------------------------------------------------------------------- /src/frontend/RotData.ml: -------------------------------------------------------------------------------- 1 | open RedTT_Core 2 | 3 | let version : string = "Where do correct ideas come from?" 4 | 5 | type dep = 6 | | True 7 | | False 8 | | Libsum (* always true, for now *) 9 | | Self of {stem : FileRes.filepath; redsum : Digest.t} 10 | | Import of {sel : FileRes.selector; stem : FileRes.filepath; rotsum : Digest.t} 11 | | Shell of {cmd : string; exit: int} 12 | 13 | type entry = GlobalEnv.entry 14 | type rigidity = Unify.rigidity option 15 | type info = entry * rigidity 16 | 17 | type reexported = Name.t list 18 | 19 | type repo = (string option * info) list 20 | 21 | (* this is not really used, but is useful as an overview 22 | 23 | type rot = 24 | Rot of 25 | {ver : string; 26 | deps : dep list; 27 | reexported : reexported; 28 | repo : repo} 29 | *) 30 | -------------------------------------------------------------------------------- /src/frontend/RotIO.mli: -------------------------------------------------------------------------------- 1 | open Contextual 2 | 3 | val set_unsafe_mode : bool -> unit 4 | 5 | val try_read : 6 | redsum : Digest.t option -> (* if you already know the redsum *) 7 | importer : (selector : FileRes.selector -> rotted_resolver Contextual.m) -> 8 | stem : FileRes.filepath -> 9 | rotted_resolver option m 10 | 11 | (* this writes the rot file and returns the checksum of 12 | the supposed rot file. *) 13 | val write : rotted_resolver m 14 | -------------------------------------------------------------------------------- /src/frontend/Unify.mli: -------------------------------------------------------------------------------- 1 | open Dev 2 | open RedTT_Core 3 | open Contextual 4 | 5 | type rigidity = [`Rigid | `Flex] 6 | 7 | type telescope = params 8 | val telescope : ty -> telescope * ty 9 | val telescope_to_spine : telescope -> tm Tm.spine 10 | 11 | val push_guess : telescope -> ty0:ty -> ty1:ty -> tm -> tm m 12 | val push_hole : rigidity -> telescope -> ty -> tm Tm.cmd m 13 | val hole : rigidity -> telescope -> ty -> (tm Tm.cmd -> 'a m) -> 'a m 14 | 15 | val user_define : telescope -> Name.t -> FileRes.filepath -> ResEnv.visibility -> [ `Transparent | `Opaque ] -> ty:ty -> tm -> unit m 16 | 17 | 18 | 19 | val to_var : tm -> Name.t option 20 | 21 | val abstract_ty : telescope -> ty -> ty 22 | val abstract_tm : telescope -> tm -> tm 23 | 24 | (** Run this in a proof state to solve unification problems. *) 25 | val ambulando : unit m 26 | 27 | val eval : tm -> Domain.value m 28 | -------------------------------------------------------------------------------- /src/frontend/dune: -------------------------------------------------------------------------------- 1 | (menhir 2 | (flags --explain --interpret-show-cst) 3 | (modules Grammar)) 4 | 5 | (ocamllex Lex) 6 | 7 | (library 8 | (name RedTT) 9 | (public_name redtt) 10 | ; for warning numbers (the part after "-w") see "ocamlc -warn-help" 11 | (flags 12 | (:standard -w +a-3-4-6-9-22-26-27-30-32-39-40-41-42-44-48-60 -safe-string -short-paths -strict-formats -strict-sequence)) 13 | (ocamlopt_flags 14 | (:standard -w +a-3-4-6-9-22-26-27-30-32-39-40-41-42-44-48-60 -safe-string -short-paths -strict-formats -strict-sequence -O3 -bin-annot -unbox-closures -inlining-report)) 15 | (libraries 16 | lwt.unix 17 | redtt.basis 18 | redtt.core 19 | uuseg 20 | uuseg.string 21 | uutf 22 | menhirLib 23 | ezjsonm 24 | ezgzip)) 25 | -------------------------------------------------------------------------------- /vim/README.md: -------------------------------------------------------------------------------- 1 | # redtt.vim 2 | 3 | This vim plugin requires Vim 8 (released September 2016). 4 | 5 | ## Use 6 | 7 | While editing a .red file, run `:Redtt` or `l` (`l` for `load`) in 8 | the command (normal) mode to check the current buffer and display the output in 9 | a separate buffer. Run `p` (`p` for `partial`) to check the current 10 | buffer, ignoring lines below the cursor's current position. The `L` 11 | and `P` commands are analogous but use the `--ignore-cache` option. 12 | 13 | ### Typing special characters 14 | 15 | `redtt` uses several unicode characters in its concrete notation; each of these 16 | can be typed easily in the Vim mode using the `digraph` feature; alternatively, 17 | they replaced with ASCII equivalents. 18 | 19 | | Char | Digraph | ASCII | 20 | |------|-----------|-------| 21 | | 𝕀 | `C-k II` | `dim` | 22 | | ⊢ | `C-k !-` | `!-` | 23 | | ⦉ | `C-k <:` | `<:` | 24 | | ⦊ | `C-k :>` | `:>` | 25 | | « | `C-k <<` | `<<` | 26 | | » | `C-k >>` | `>>` | 27 | | λ | `C-k *l` | `\` | 28 | | → | `C-k ->` | `->` | 29 | 30 | ## Setup 31 | 32 | This plugin is compatible with Vim 8's package system. You can (re)install it by 33 | running the following shell command from the current directory: 34 | 35 | ./install.sh 36 | 37 | If the `redtt` binary is not in your `PATH`, add the following line to your 38 | `.vimrc`: 39 | 40 | let g:redtt_path = '/path/to/the-redtt-binary' 41 | -------------------------------------------------------------------------------- /vim/ftdetect/redtt.vim: -------------------------------------------------------------------------------- 1 | " vim-redtt ftdetect 2 | " Language: redtt 3 | " Author: Carlo Angiuli 4 | " Last Change: 2018 August 13 5 | 6 | au BufNewFile,BufRead *.red setf redtt 7 | -------------------------------------------------------------------------------- /vim/ftplugin/redtt.vim: -------------------------------------------------------------------------------- 1 | " vim-redtt ftplugin 2 | " Language: redtt 3 | " Author: Carlo Angiuli 4 | " Last Change: 2018 November 12 5 | 6 | if (exists("b:did_ftplugin") || !has('job')) 7 | finish 8 | endif 9 | 10 | if (!exists('g:redtt_path')) 11 | let g:redtt_path = 'redtt' 12 | endif 13 | 14 | if (!exists('g:redtt_options')) 15 | let g:redtt_options = '' 16 | endif 17 | 18 | command! Redtt :call CheckBuffer('') 19 | nnoremap l :call CheckBuffer('') 20 | nnoremap L :call CheckBuffer('--ignore-cache') 21 | nnoremap p :call CheckBufferToCursor('') 22 | nnoremap P :call CheckBufferToCursor('--ignore-cache') 23 | autocmd QuitPre call s:CloseBuffer() 24 | 25 | digraph !- 8866 26 | digraph II 120128 27 | digraph <: 10633 28 | digraph :> 10634 29 | 30 | " Optional argument: the last line to send to redtt (default: all). 31 | function! CheckBuffer(options, ...) 32 | if (exists('s:job')) 33 | call job_stop(s:job, 'int') 34 | endif 35 | 36 | let l:toCheck = bufname('%') 37 | 38 | if (!bufexists('redtt') || (winbufnr(bufwinnr('redtt')) != bufnr('redtt'))) 39 | belowright vsplit redtt 40 | call s:InitBuffer() 41 | else 42 | execute bufwinnr('redtt') . 'wincmd w' 43 | endif 44 | let b:active = l:toCheck 45 | silent %d _ 46 | wincmd p 47 | 48 | let s:job = job_start(g:redtt_path . 49 | \' from-stdin ' . l:toCheck . 50 | \' ' . a:options . 51 | \' ' . g:redtt_options . 52 | \' --line-width ' . s:EditWidth(), { 53 | \'in_io': 'buffer', 'in_buf': bufnr('%'), 54 | \'in_bot': exists('a:1') ? a:1 : line('$'), 55 | \'out_io': 'buffer', 'out_name': 'redtt', 'out_msg': 0, 56 | \'err_io': 'buffer', 'err_name': 'redtt', 'err_msg': 0}) 57 | endfunction 58 | 59 | function! CheckBufferToCursor(options) 60 | call CheckBuffer(a:options, line('.')) 61 | endfunction 62 | 63 | " Call this only from redtt output buffer. 64 | function! g:CheckFromOutputBuffer(options) 65 | if (bufexists(b:active) && (winbufnr(bufwinnr(b:active)) == bufnr(b:active))) 66 | execute bufwinnr(b:active) . 'wincmd w' 67 | call CheckBuffer(a:options) 68 | endif 69 | endfunction 70 | 71 | function! s:InitBuffer() 72 | set buftype=nofile 73 | set syntax=redtt 74 | set noswapfile 75 | nnoremap l :call CheckFromOutputBuffer('') 76 | nnoremap L :call CheckFromOutputBuffer('--ignore-cache') 77 | endfunction 78 | 79 | function! s:EditWidth() 80 | execute bufwinnr('redtt') . 'wincmd w' 81 | 82 | let l:width = winwidth(winnr()) 83 | if (has('linebreak') && (&number || &relativenumber)) 84 | let l:width -= &numberwidth 85 | endif 86 | if (has('folding')) 87 | let l:width -= &foldcolumn 88 | endif 89 | if (has('signs')) 90 | redir => l:signs 91 | silent execute 'sign place buffer=' . bufnr('%') 92 | redir END 93 | if (&signcolumn == "yes" || len(split(l:signs, "\n")) > 2) 94 | let l:width -= 2 95 | endif 96 | endif 97 | 98 | wincmd p 99 | return l:width 100 | endfunction 101 | 102 | function! s:CloseBuffer() 103 | if (bufexists('redtt') && !getbufvar('redtt', '&modified')) 104 | if (getbufvar('redtt', 'active') == bufname('%')) 105 | bdelete redtt 106 | endif 107 | endif 108 | endfunction 109 | 110 | let b:did_ftplugin = 1 111 | -------------------------------------------------------------------------------- /vim/install.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | DEST=~/.vim/pack/redprl-org/start ; 4 | [ -d $DEST/vim-redtt ] && rm -r $DEST/vim-redtt ; 5 | mkdir -p $DEST && cp -r . $DEST/vim-redtt 6 | -------------------------------------------------------------------------------- /vim/syntax/redtt.vim: -------------------------------------------------------------------------------- 1 | " vim-redtt syntax 2 | " Language: redtt 3 | " Author: Carlo Angiuli, Favonia 4 | " Last Change: 2018 October 31 5 | 6 | if exists("b:current_syntax") 7 | finish 8 | endif 9 | 10 | setlocal iskeyword=a-z,A-Z,48-57,-,',/ 11 | 12 | syn sync minlines=50 13 | syn sync maxlines=1000 14 | 15 | syn match redttGuillemetsErr '>>' 16 | syn match redttGuillemetsErr '»' 17 | syn match redttTriangleErr ':>' 18 | syn match redttTriangleErr '⦊' 19 | syn match redttParenErr ')' 20 | syn match redttBrackErr ']' 21 | 22 | syn region redttEncl transparent matchgroup=redttSymb start="<<" end=">>" contains=ALLBUT,redttGuillemetsErr 23 | syn region redttEncl transparent matchgroup=redttSymb start="«" end="»" contains=ALLBUT,redttGuillemetsErr 24 | syn region redttEncl transparent matchgroup=redttSymb start="<:" end=":>" contains=ALLBUT,redttTriangleErr 25 | syn region redttEncl transparent matchgroup=redttSymb start="⦉" end="⦊" contains=ALLBUT,redttTriangleErr 26 | syn region redttEncl transparent matchgroup=redttSymb start="(" end=")" contains=ALLBUT,redttParenErr 27 | syn region redttEncl transparent matchgroup=redttSymb start="\[" end="\]" contains=ALLBUT,redttBrackErr 28 | 29 | syn region redttImport matchgroup=redttDecl start="import" end="$\|\(/-\|--\)\@=" 30 | 31 | syn match redttHole '?\k*' 32 | 33 | syn keyword redttKeyw V in with where begin end dim elim fst snd coe com pair 34 | syn keyword redttKeyw fun hcom comp vproj vin cap box lam refl pre 35 | syn keyword redttKeyw kan U type 36 | 37 | syn keyword redttDecl meta def do let data debug print normalize public private quit opaque 38 | 39 | syn match redttSymb '[#@`|^*×:,.∙✓□=∂→λ𝕀]\|->' 40 | 41 | syn region redttComm excludenl start="\k\@1