├── .gitignore ├── .gitmodules ├── .travis.yml ├── CONTRIBUTING.md ├── CONTRIBUTORS.md ├── ENGINEERING_NOTES.md ├── LICENSE ├── README.md ├── doc ├── Makefile ├── old │ └── machine.tex └── src │ ├── atomic-judgment.rst │ ├── conf.py │ ├── index.rst │ ├── language.rst │ ├── multiverse.rst │ ├── redprl.py │ ├── refine.rst │ ├── static │ ├── luminaries.png │ ├── luminaries.xcf │ ├── red.css │ └── uphold-cubical-thought.jpg │ └── tutorial.rst ├── emacs └── redprl.el ├── example ├── J.prl ├── README.prl ├── category.prl ├── connection.prl ├── groupoid.prl ├── hlevels.prl ├── invariance.prl ├── isotoequiv.prl ├── metalanguage.prl ├── omega1s1-inductive.prl ├── omega1s1.prl ├── semi-simplicial.prl ├── theorem-of-choice.prl ├── tutorial.prl ├── tutorial1.prl ├── tutorial2.prl └── univalence.prl ├── script ├── doc.sh ├── go-nj.sml ├── mkexec.sh ├── mlton.sh ├── mlyacclex.sh ├── profile.sh ├── run-tests.sh ├── smlnj.sh ├── tc-mlton.sh ├── test-mlton.sh ├── test-no-build.sh ├── test-smlnj.sh └── test-sphinx.sh ├── sml.json ├── src ├── cmlib.cm ├── cmlib.mlb ├── debug.cm ├── debug.mlb ├── debug │ ├── debug.sig │ ├── debug_mlton.sml │ └── debug_smlnj.sml ├── development.cm ├── frontend.cm ├── frontend.mlb ├── frontend │ ├── frontend.sml │ ├── main-mlton.sml │ └── main.sml ├── redprl.cm ├── redprl.mlb └── redprl │ ├── config.sml │ ├── error.sig │ ├── error.sml │ ├── fpp.sml │ ├── inductive_spec.sig │ ├── inductive_spec.sml │ ├── judgment.sml │ ├── lcf.sml │ ├── list_util.sml │ ├── log.sig │ ├── log.sml │ ├── machine.fun │ ├── machine.sig │ ├── metalanguage │ ├── elaborate.fun │ ├── elaborate.sig │ ├── evaluate.sig │ ├── evaluate.sml │ ├── resolver.fun │ ├── resolver.sig │ ├── semantics.sig │ ├── semantics.sml │ ├── syntax.sml │ ├── type.sig │ └── type.sml │ ├── mini_signature.sig │ ├── ml_id.sig │ ├── ml_id.sml │ ├── option_util.sml │ ├── pretty.sml │ ├── redprl.grm │ ├── redprl.lex │ ├── redprl_lexer.sml │ ├── redprl_parser.sml │ ├── refiner.fun │ ├── refiner.sig │ ├── refiner_composition_kit.fun │ ├── refiner_kit.fun │ ├── refiner_misc.fun │ ├── refiner_types.fun │ ├── signature.sig │ ├── signature.sml │ ├── syntax │ ├── abt.sml │ ├── accessor.sig │ ├── accessor.sml │ ├── assert.sml │ ├── atomic_judgment.sig │ ├── atomic_judgment.sml │ ├── kind.sml │ ├── operator.sig │ ├── operator.sml │ ├── restriction.sml │ ├── selector.sig │ ├── selector.sml │ ├── sequent.sig │ ├── sequent.sml │ ├── sort.sig │ ├── sort.sml │ ├── univ_level.sig │ ├── univ_level.sml │ ├── variable_kit.sml │ ├── variance.sig │ ├── variance.sml │ └── view.sml │ ├── tactic_elaborator.fun │ ├── tactical.fun │ └── test.sml ├── test ├── failure │ ├── bad-hcom-empty.prl │ ├── bad-hcom-stuck.prl │ ├── bad-op.prl │ ├── freemeta.prl │ ├── freevar.prl │ ├── incremental-parse.prl │ ├── kind-hcom.prl │ ├── lexical-error.prl │ ├── num.prl │ ├── record0.prl │ ├── record1.prl │ ├── record2.prl │ ├── record3.prl │ ├── record4.prl │ └── undef-custom.prl └── success │ ├── S1-fcom.prl │ ├── S1.prl │ ├── V-types.prl │ ├── bool-pair-test.prl │ ├── dashes-n-slashes.prl │ ├── decomposition.prl │ ├── discrete-types.prl │ ├── empty.prl │ ├── equality-elim.prl │ ├── equality.prl │ ├── fcom-types.prl │ ├── hcom.prl │ ├── inductive-S1.prl │ ├── inductive.prl │ ├── lines.prl │ ├── logical-investigations.prl │ ├── match.prl │ ├── num.prl │ ├── path-ap-const.prl │ ├── primitive-sequencing.prl │ ├── pushout.prl │ ├── record.prl │ ├── strict-bool.prl │ ├── unfold.prl │ └── universes.prl └── vim ├── README.md ├── ftdetect └── redprl.vim ├── ftplugin └── redprl.vim └── syntax └── redprl.vim /.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | *.out 3 | *.x86-darwin 4 | *.aux 5 | *.fdb_latexmk 6 | *.fls 7 | *.log 8 | *.toc 9 | *.bbl 10 | *.blg 11 | test/test 12 | *~ 13 | *.grm.* 14 | *.lex.* 15 | bin 16 | \#* 17 | .#* 18 | *.du 19 | 20 | doc/old/machine.pdf 21 | doc/build 22 | *.pyc 23 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "lib/sml-typed-abts"] 2 | path = lib/sml-typed-abts 3 | url = https://github.com/JonPRL/sml-typed-abts.git 4 | [submodule "lib/cmlib"] 5 | path = lib/cmlib 6 | url = https://github.com/standardml/cmlib.git 7 | [submodule "lib/sml-telescopes"] 8 | path = lib/sml-telescopes 9 | url = https://github.com/jonsterling/sml-telescopes.git 10 | [submodule "lib/sml-dependent-lcf"] 11 | path = lib/sml-dependent-lcf 12 | url = https://github.com/JonPRL/sml-dependent-lcf.git 13 | [submodule "lib/sml-cats"] 14 | path = lib/sml-cats 15 | url = https://github.com/RedPRL/sml-cats.git 16 | [submodule "lib/sml-final-pretty-printer"] 17 | path = lib/sml-final-pretty-printer 18 | url = https://github.com/RedPRL/sml-final-pretty-printer 19 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: generic 2 | env: 3 | - COMPILER=smlnj PACKAGES="smlnj ml-yacc ml-ulex moreutils libsmlnj-smlnj" 4 | - COMPILER=mlton PACKAGES="mlton moreutils" 5 | - COMPILER=sphinx PACKAGES="python3-sphinx" 6 | before_install: 7 | - sudo apt-get update -qq 8 | - sudo apt-get install -y --force-yes ${PACKAGES} 9 | install: 10 | - git submodule init 11 | - git submodule update --init --recursive 12 | script: 13 | - ./script/test-${COMPILER}.sh 14 | 15 | notifications: 16 | email: false 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 to Apache 2.0 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 | -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | The following people have contributed to RedPRL and its theoretical underpinnings, 2 | in no particular order: 3 | 4 | - Jon Sterling 5 | - Daniel Gratzer 6 | - Eugene Akentyev 7 | - James Wilcox 8 | - David Christiansen 9 | - Darin Morrison 10 | - Favonia 11 | - Evan Cavallo 12 | - Carlo Angiuli 13 | - Tim Baumann 14 | - Anders Mörtberg 15 | 16 | 17 | We also thank the following people for their contributions to previous versions 18 | of JonPRL: 19 | 20 | - Daniel Gratzer 21 | - Vincent Rahli 22 | - David Christiansen 23 | - Darin Morrison 24 | - James Wilcox 25 | 26 | Special thanks to David Christiansen for answering all my obnoxious questions 27 | about Emacs. 28 | 29 | Finally, we thank the following people for their guidance and encouragement: 30 | 31 | - Bob Harper 32 | - Mark Bickford 33 | - Bob Constable 34 | - Peter Dybjer 35 | -------------------------------------------------------------------------------- /ENGINEERING_NOTES.md: -------------------------------------------------------------------------------- 1 | ### Engineering Notes 2 | 3 | Having learned a bit from JonPRL's development, I'm compiling a bit of a 4 | manifesto on various matters concerning the new codebase. 5 | 6 | #### MLton first 7 | 8 | We may support SML/NJ if our contributors want to, there we *only* require that 9 | the MLton build work properly. There are a few reasons for favoring MLton: 10 | 11 | - MLton implements Standard ML more faithfully; in addition to the (useful) 12 | extensions that SML/NJ provides to SML, there are a number of cases where its 13 | implementation is in fact incompatible with the definition. Whereas everything 14 | that MLton builds should also build in SML/NJ, I believe. 15 | 16 | - MLton has powerful whole-program optimization. Originally, JonPRL was 17 | intended to be a library, and JonPRL proofs were just ML programs; under 18 | these circumstances, SML/NJ made a lot of sense, because it builds much faster 19 | than MLton. Today, however, JonPRL is a proof assistant, and so the trade-off 20 | is different. 21 | 22 | - It is totally straightforward to produce an honest-to-god binary with MLton. 23 | I still have no idea what this "heap image" crap is about in SML/NJ. 24 | 25 | Downsides of MLton are: 26 | 27 | - Source code cannot contain unicode characters; in practice, this means that 28 | you have to use the decimal code in string literals. 29 | 30 | - Builds take longer. 31 | 32 | - There's no REPL. In practice, the REPL has not been used almost at all for 33 | day-to-day JonPRL/RedPRL development, so I do not see this is a very serious 34 | disadvantage. The only benefit of the REPL is that you can quickly print out some 35 | datastructure without writing your own pretty-printer for it. 36 | 37 | #### No clever stuff 38 | 39 | Code should be straightforward; sometimes this means sacrificing a clever typing guarante 40 | or a bit of abstraction. 41 | 42 | #### Strike a balance with modularity 43 | 44 | In JonPRL, everything was highly functorized; for instance, every module would 45 | take as input an implementation of ABTs. We never actually took advantage of 46 | this at all, and to be honest, it probably made a lot of stuff look more 47 | abstruse than it really was. In the end, we were basically replicating the work 48 | of the linker. 49 | 50 | I'm thinking that this time around, we may wish to have certain "pervasive" 51 | features like syntax exist globally. 52 | 53 | #### Adhere to a common whitespace & lexical style 54 | 55 | The whitespace and lexical style that I prefer is used in JonPRL and the ABT 56 | library. Contributors are *not* required to adhere to this perfectly, but we 57 | will ensure that no code is merged into master which does not match the 58 | surrounding style. 59 | 60 | 61 | #### This is a living document! 62 | 63 | Feel free to submit additions and changes. 64 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015-2018 The RedPRL Development Team 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![PRL: We Can Prove It](https://pbs.twimg.com/media/Ch1klO6U4AAlj62.jpg) 2 | 3 | (image courtesy of [@tranngocma](http://twitter.com/tranngocma)) 4 | 5 | ### What is RedPRL? 6 | 7 | *RedPRL* is the People's Refinement Logic, a next-generation homage 8 | to [Nuprl](http://www.nuprl.org); RedPRL was preceeded by 9 | [JonPRL](http://www.github.com/jonsterling/jonprl), written by Jon Sterling, 10 | Daniel Gratzer and Vincent Rahli. 11 | 12 | The purpose of RedPRL is to provide a practical implementation of Computational 13 | Cubical Type Theory in the Nuprl style, integrating modern advances in proof 14 | refinement. 15 | 16 | ### Literature and background on RedPRL 17 | 18 | RedPRL is (becoming) a proof assistant for Computational Cubical Type Theory, as 19 | described by Angiuli, Favonia, and Harper in [Computational Higher Type Theory 20 | III: Univalent Universes and Exact Equality](https://arxiv.org/abs/1712.01800). 21 | The syntactic framework is inspired by second-order abstract syntax (relevant 22 | names include Aczel, Martin-Löf, Fiore, Plotkin, Turi, Harper, and many others). 23 | 24 | ### What is this repository? 25 | 26 | This is the repository for the nascent development of RedPRL. RedPRL is an 27 | experiment which is constantly changing; we do not yet have strong 28 | documentation, but we have an IRC channel on Freenode (#redprl) where we 29 | encourage anyone to ask any question, no matter how silly it may seem. 30 | 31 | ### How do I build it? 32 | 33 | First, fetch all submodules. If you are cloning for the first time, use 34 | 35 | git clone --recursive git@github.com:RedPRL/sml-redprl.git 36 | 37 | If you have already cloned, then be sure to make sure all submodules are up to date, 38 | as follows: 39 | 40 | git submodule update --init --recursive 41 | 42 | Next, make sure that you have the [MLton compiler](http://mlton.org/) for Standard 43 | ML installed. Then, simply run 44 | 45 | ./script/mlton.sh 46 | 47 | Then, a binary will be placed in `./bin/redprl`, which you may run as 48 | follows 49 | 50 | ./bin/redprl example/README.prl 51 | 52 | ### Editor Support: Vim 53 | 54 | Our best-supported editor is currently Vim. 55 | See the RedPRL plugin under [vim/](vim/). 56 | 57 | ### Contributing 58 | 59 | If you'd like to help, the best place to start are issues with the following labels: 60 | 61 | * [`E-easy`](https://github.com/RedPRL/sml-redprl/issues?q=is%3Aissue+is%3Aopen+label%3AE-easy) 62 | * [`E-help-wanted`](https://github.com/RedPRL/sml-redprl/issues?q=is%3Aissue+is%3Aopen+label%3AE-help-wanted) 63 | 64 | We follow the issue labels used by Rust which are described in detail 65 | [here](https://github.com/rust-lang/rust/blob/master/CONTRIBUTING.md#issue-triage). 66 | 67 | If you find something you want to work on, please leave a comment so that others 68 | can coordinate their efforts with you. Also, please don't hesitate to open a new 69 | issue if you have feedback of any kind. 70 | 71 | *The above text is stolen from [Yggdrasil](https://github.com/freebroccolo/yggdrasil/blob/master/README.md).* 72 | 73 | Please see `CONTRIBUTING.md` for copyright assignment. 74 | 75 | ### Acknowledgments 76 | 77 | This research was sponsored by the Air Force Office of Scientific Research under 78 | grant number FA9550-15-1-0053 and the National Science Foundation under grant 79 | number DMS-1638352. We also thank the Isaac Newton Institute for Mathematical 80 | Sciences for its support and hospitality during the program "Big Proof" when 81 | part of this work was undertaken; the program was supported by the Engineering 82 | and Physical Sciences Research Council under grant number EP/K032208/1. The 83 | views and conclusions contained here are those of the authors and should not be 84 | interpreted as representing the official policies, either expressed or implied, 85 | of any sponsoring institution, government or any other entity. 86 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | # Minimal makefile for Sphinx documentation 2 | # 3 | 4 | # You can set these variables from the command line. 5 | SPHINXOPTS = 6 | SPHINXBUILD = sphinx-build 7 | SPHINXPROJ = RedPRL 8 | SOURCEDIR = src 9 | BUILDDIR = build 10 | 11 | # Put it first so that "make" without argument is like "make help". 12 | help: 13 | @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) 14 | 15 | .PHONY: help Makefile 16 | 17 | # Catch-all target: route all unknown targets to Sphinx using the new 18 | # "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). 19 | %: Makefile 20 | @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) 21 | -------------------------------------------------------------------------------- /doc/src/atomic-judgment.rst: -------------------------------------------------------------------------------- 1 | Atomic judgments 2 | ================ 3 | 4 | |RedPRL| currently has five forms of atomic (non-hypothetical) judgments that may appear in subgoals. 5 | 6 | 1. :ref:`Truth ` asserts that a type is inhabited. 7 | 2. :ref:`Type equality ` asserts an equality between two types. 8 | 3. :ref:`Subtyping ` asserts a subtyping relation. 9 | 4. :ref:`Subkinding ` asserts that some type is actually a universe in which 10 | all types has a particular kind. 11 | 5. :ref:`Term ` lets the user give an expression. 12 | 13 | Note that these judgment forms differ from our semantic presentations in papers. 14 | 15 | .. _jdg-true: 16 | 17 | Truth 18 | ----- 19 | 20 | A *truth* judgment 21 | 22 | :: 23 | 24 | a true 25 | 26 | or simply 27 | 28 | :: 29 | 30 | a 31 | 32 | means ``a`` is an inhabited type. 33 | Any inhabitant can realize this judgment. 34 | For example, the expression ``1`` realizes 35 | 36 | :: 37 | 38 | int 39 | 40 | because ``1`` is in the type ``int``. 41 | This is commonly used 42 | to state a theorem or specify the type of the program to be implemented. 43 | In fact, all top-level theorems (see :ref:`def-theorem`) must be in this judgmental form. 44 | 45 | .. _jdg-eqtype: 46 | 47 | Type equality 48 | ------------- 49 | 50 | A *type equality* judgment 51 | 52 | :: 53 | 54 | a = b type 55 | 56 | means ``a`` are ``b`` are equal types (without regard to universe level), 57 | and its realizer must be ``ax``, the same as the realizer of equality types. 58 | For example, we have 59 | 60 | :: 61 | 62 | int = int type 63 | 64 | realized by ``ax``. 65 | Multiverses are supported through kind markers such as ``kan`` or ``discrete``:: 66 | 67 | a = b discrete type 68 | a = b kan type 69 | a = b coe type 70 | a = b hcom type 71 | a = b pre type 72 | 73 | where ``a = b kan type`` means ``a`` and ``b`` are equal Kan types. 74 | (The judgment ``a = b type`` is really an abbreviation of ``a = b pre type`` 75 | because ``pre`` is the default kind.) 76 | Following the PRL family of proof assistants 77 | which use partial equivalence relations, 78 | well-typedness is defined as the equality of the type and itself; 79 | to save some typing, ``a type`` stands for ``a = a type`` 80 | and ``a kan type`` stands for ``a = a kan type``. 81 | 82 | In the presence of universes and equality types, 83 | one might wonder why we still have a dedicated judgmental form for type equality. 84 | That is, one may intuitively treat the judgment 85 | 86 | :: 87 | 88 | a = b type 89 | 90 | as ``(= (U l) a b) true`` for some unknown universe level ``l``. 91 | It turns out to be very convenient to state type equality without specifying the universe levels; 92 | with this, we survived without a universe level synthesizer as the one in Nuprl, 93 | which was created to alleviate the burden of guessing universe levels. 94 | 95 | .. _jdg-subtype: 96 | 97 | Subtyping 98 | --------- 99 | 100 | A *subtype* judgment 101 | 102 | :: 103 | 104 | a <= b type 105 | 106 | states that ``a`` is a subtype of ``b``. More precisely, the partial equivalence relation 107 | associated with ``a`` is a subrelation of the one associated with ``b``. 108 | The realizer must be ``ax``. 109 | There is no support of kind markers because the subtyping relation 110 | never takes additional structures into consideration. 111 | 112 | This is currently used whenever we only need a subtyping relationship 113 | rather than type equality. For example, if a function ``f`` is in type ``(-> a b)``, 114 | the rule to determine whether the function application ``($ f x)`` is in type ``b'`` 115 | will only demand ``b <= b' type`` rather than ``b = b' type``. 116 | That said, the only non-trivial subtyping relation one can prove in |RedPRL| now 117 | is the cumulativity of universes. One instance would be 118 | 119 | :: 120 | 121 | (U 0 discrete) <= (U 1 kan) 122 | 123 | realized by ``ax``. 124 | 125 | .. _jdg-subkind: 126 | 127 | Subkinding 128 | ---------- 129 | 130 | The following are *subkind* judgments:: 131 | 132 | a <= discrete universe 133 | a <= kan universe 134 | a <= coe universe 135 | a <= hcom universe 136 | a <= pre universe 137 | 138 | They assert that ``a`` is a subuniverse of the universe of the specified kind at the omega level. 139 | Intuitively, ``a <= k universe`` would be the :ref:`subtyping judgment ` ``a <= (U omega k) type`` 140 | if we could internalize universes at the omega level. 141 | The realizer must be ``ax``. 142 | These judgments play the same role as :ref:`subtyping judgments ` 143 | except that they handle the cases where the right hand side is some omega-level universe. 144 | Suppose a function ``f`` is in type ``(-> a b)``. 145 | The rule to determine whether the function application ``($ f x)`` is a type 146 | will demand ``b <= pre universe`` rather than ``b = (U omega) type`` 147 | (or ``b = (U l) type`` for some universe level ``l``). 148 | 149 | .. _jdg-term: 150 | 151 | Term 152 | ---- 153 | 154 | A *term* judgment is displayed in the sort of the expression 155 | it is asking for, for example:: 156 | 157 | dim 158 | exp 159 | 160 | The realizer is the received term from the user. 161 | This is used to obtain motives or dimension expressions. 162 | For example, the ``rewrite`` tactic requires users to specify 163 | the parts to be rewritten by fulfilling *term* subgoals. 164 | -------------------------------------------------------------------------------- /doc/src/conf.py: -------------------------------------------------------------------------------- 1 | # -*- coding: utf-8 -*- 2 | # 3 | # RedPRL documentation build configuration file. 4 | # 5 | # This file is execfile()d with the current directory set to its 6 | # containing dir. 7 | # 8 | # Note that not all possible configuration values are present in this 9 | # autogenerated file. 10 | # 11 | # All configuration values have a default; values that are commented out 12 | # serve to show the default. 13 | 14 | # If extensions (or modules to document with autodoc) are in another directory, 15 | # add these directories to sys.path here. If the directory is relative to the 16 | # documentation root, use os.path.abspath to make it absolute, like shown here. 17 | 18 | import os 19 | import sys 20 | sys.path.insert(0, os.path.abspath('.')) 21 | 22 | 23 | # -- General configuration ------------------------------------------------ 24 | 25 | # If your documentation needs a minimal Sphinx version, state it here. 26 | # 27 | # needs_sphinx = '1.0' 28 | 29 | # Add any Sphinx extension module names here, as strings. They can be 30 | # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom 31 | # ones. 32 | # extensions = ['sphinx.ext.imgmath'] 33 | extensions = ['sphinx.ext.todo'] 34 | 35 | # Add any paths that contain templates here, relative to this directory. 36 | templates_path = ['templates'] 37 | 38 | # The suffix(es) of source filenames. 39 | # You can specify multiple suffix as a list of string: 40 | # 41 | # source_suffix = ['.rst', '.md'] 42 | source_suffix = '.rst' 43 | 44 | # The master toctree document. 45 | master_doc = 'index' 46 | 47 | # General information about the project. 48 | project = u'RedPRL' 49 | copyright = u'2015–2018, The RedPRL Development Team' 50 | author = u'The RedPRL Development Team' 51 | 52 | # The version info for the project you're documenting, acts as replacement for 53 | # |version| and |release|, also used in various other places throughout the 54 | # built documents. 55 | # 56 | # The short X.Y version. 57 | version = u'' 58 | # The full version, including alpha/beta/rc tags. 59 | release = u'' 60 | 61 | # The language for content autogenerated by Sphinx. Refer to documentation 62 | # for a list of supported languages. 63 | # 64 | # This is also used if you do content translation via gettext catalogs. 65 | # Usually you set "language" from the command line for these cases. 66 | language = None 67 | 68 | highlight_language = 'redprl' 69 | 70 | # List of patterns, relative to source directory, that match files and 71 | # directories to ignore when looking for source files. 72 | # This patterns also effect to html_static_path and html_extra_path 73 | exclude_patterns = ['build', 'Thumbs.db', '.DS_Store'] 74 | 75 | # The name of the Pygments (syntax highlighting) style to use. 76 | pygments_style = 'colorful' 77 | 78 | # If true, `todo` and `todoList` produce output, else they produce nothing. 79 | todo_include_todos = True 80 | 81 | rst_prolog = """ 82 | .. role:: revolutionary 83 | .. |RedPRL| replace:: :revolutionary:`Red`\ **PRL** 84 | """ 85 | 86 | # -- Options for HTML output ---------------------------------------------- 87 | 88 | # The theme to use for HTML and HTML Help pages. See the documentation for 89 | # a list of builtin themes. 90 | # 91 | html_theme = 'sphinx_rtd_theme' 92 | 93 | # Theme options are theme-specific and customize the look and feel of a theme 94 | # further. For a list of options available for each theme, see the 95 | # documentation. 96 | # 97 | # html_theme_options = {} 98 | 99 | # Add any paths that contain custom static files (such as style sheets) here, 100 | # relative to this directory. They are copied after the builtin static files, 101 | # so a file named "default.css" will overwrite the builtin "default.css". 102 | html_static_path = ['static'] 103 | 104 | def setup(app): 105 | app.add_stylesheet('https://cs.cmu.edu/~jmsterli/fonts/PragmataPro.css') 106 | app.add_stylesheet('red.css') 107 | from redprl import RedPRLLexer 108 | app.add_lexer('redprl', RedPRLLexer()) 109 | 110 | # -- Options for HTMLHelp output ------------------------------------------ 111 | 112 | # Output file base name for HTML help builder. 113 | htmlhelp_basename = 'RedPRLdoc' 114 | 115 | 116 | # -- Options for LaTeX output --------------------------------------------- 117 | 118 | latex_elements = { 119 | # The font size ('10pt', '11pt' or '12pt'). 120 | # 121 | # 'pointsize': '10pt', 122 | 123 | # Additional stuff for the LaTeX preamble. 124 | # 125 | # 'preamble': '', 126 | 127 | # Latex figure (float) alignment 128 | # 129 | # 'figure_align': 'htbp', 130 | } 131 | 132 | # Grouping the document tree into LaTeX files. List of tuples 133 | # (source start file, target name, title, 134 | # author, documentclass [howto, manual, or own class]). 135 | latex_documents = [ 136 | (master_doc, 'redprl.tex', u'RedPRL Documentation', 137 | u'The RedPRL Development Team', 'manual'), 138 | ] 139 | 140 | 141 | # -- Options for manual page output --------------------------------------- 142 | 143 | # One entry per manual page. List of tuples 144 | # (source start file, name, description, authors, manual section). 145 | man_pages = [ 146 | (master_doc, 'redprl', u'RedPRL Documentation', 147 | [author], 1) 148 | ] 149 | 150 | 151 | # -- Options for Texinfo output ------------------------------------------- 152 | 153 | # Grouping the document tree into Texinfo files. List of tuples 154 | # (source start file, target name, title, author, 155 | # dir menu entry, description, category) 156 | texinfo_documents = [ 157 | (master_doc, 'RedPRL', u'RedPRL Documentation', 158 | author, 'RedPRL', u'The People\'s Refinement Logic', 159 | 'Miscellaneous'), 160 | ] 161 | -------------------------------------------------------------------------------- /doc/src/index.rst: -------------------------------------------------------------------------------- 1 | The |RedPRL| Proof Assistant 2 | ============================ 3 | 4 | .. image:: static/luminaries.png 5 | :alt: Luminaries. 6 | 7 | |RedPRL| is an experimental proof assistant based on cubical computational type 8 | theory, which extends the Nuprl_ semantics by higher-dimensional features 9 | inspired by homotopy type theory. |RedPRL| is created and maintained by the 10 | `RedPRL Development Team`_. 11 | 12 | .. _Nuprl: http://www.nuprl.org/ 13 | .. _RedPRL Development Team: https://github.com/RedPRL/sml-redprl/blob/master/CONTRIBUTORS.md 14 | 15 | |RedPRL| is written in `Standard ML `_, and is available 16 | for download on `GitHub `_. 17 | 18 | Features 19 | -------- 20 | 21 | * computational canonicity and extraction 22 | * univalence as a theorem 23 | * strict (exact) equality types 24 | * coequalizer and pushout types 25 | * functional extensionality 26 | * equality reflection 27 | * proof tactics 28 | 29 | Papers & Talks 30 | -------------- 31 | * Angiuli, Favonia, Harper. `Cartesian Cubical Computational Type Theory: 32 | Constructive Reasoning with Paths and Equalities`_. CSL 2018. 33 | * Angiuli, Cavallo, Favonia, Harper, Sterling. `The RedPRL Proof Assistant`_. 34 | LFMTP 2018 (Invited Paper). 35 | * Favonia. `Cubical Computational Type Theory & RedPRL`_. 2018. 36 | * Harper, Angiuli. `Computational (Higher) Type Theory`_. ACM POPL Tutorial Session 2018. 37 | * Sterling, Harper. `Algebraic Foundations of Proof Refinement`_. Draft, 2016. 38 | 39 | .. _Cartesian Cubical Computational Type Theory\: Constructive Reasoning with Paths and Equalities: 40 | https://www.cs.cmu.edu/~rwh/papers/cartesian/paper.pdf 41 | .. _Computational (Higher) Type Theory: https://www.cs.cmu.edu/~rwh/talks/POPL18-Tutorial.pdf 42 | .. _Cubical Computational Type Theory & RedPRL: http://favonia.org/files/chtt-penn2018-slides.pdf 43 | .. _Algebraic Foundations of Proof Refinement: https://www.cs.cmu.edu/~redprl/afpr.pdf 44 | .. _The RedPRL Proof Assistant: https://www.cs.cmu.edu/~rwh/papers/redprl/lfmtp18.pdf 45 | 46 | RedPRL User Guide 47 | ================= 48 | 49 | .. toctree:: 50 | :maxdepth: 2 51 | 52 | tutorial 53 | language 54 | atomic-judgment 55 | multiverse 56 | refine 57 | 58 | Indices 59 | ------- 60 | * :ref:`genindex` 61 | * :ref:`search` 62 | 63 | Acknowledgments 64 | --------------- 65 | 66 | This research was sponsored by the Air Force Office of Scientific Research under 67 | grant number FA9550-15-1-0053 and the National Science Foundation under grant 68 | number DMS-1638352. We also thank the Isaac Newton Institute for Mathematical 69 | Sciences for its support and hospitality during the program "Big Proof" when 70 | part of this work was undertaken; the program was supported by the Engineering 71 | and Physical Sciences Research Council under grant number EP/K032208/1. The 72 | views and conclusions contained here are those of the authors and should not be 73 | interpreted as representing the official policies, either expressed or implied, 74 | of any sponsoring institution, government or any other entity. 75 | -------------------------------------------------------------------------------- /doc/src/multiverse.rst: -------------------------------------------------------------------------------- 1 | Multiverses 2 | =========== 3 | 4 | .. todo:: 5 | To Infinity... and Beyond! 6 | -------------------------------------------------------------------------------- /doc/src/redprl.py: -------------------------------------------------------------------------------- 1 | from pygments.lexer import RegexLexer, include, bygroups, using, \ 2 | this, combined, ExtendedRegexLexer, default 3 | from pygments.token import * 4 | 5 | class RedPRLLexer(RegexLexer): 6 | """ 7 | Lexer for `RedPRL `_ source code. 8 | """ 9 | 10 | name = 'RedPRL' 11 | aliases = ['redprl'] 12 | filenames = ['*.prl'] 13 | 14 | exprs = ['ax', 'fcom', 'bool', 'tt', 'ff', 'if', 'nat-rec', 'nat', 'zero', 15 | 'succ', 'int-rec', 'int', 'negsucc', 'void', 'S1-rec', 'S1', 16 | 'base', 'loop', 'lam', 'record', 'tuple', 'path', 'line', 17 | 'pushout-rec', 'pushout', 'left', 'right', 'glue', 'coeq-rec', 18 | 'self', 'rec', 'coeq', 'cecod', 'cedom', 'mem', 'ni', 'box', 'cap', 19 | 'V', 'Vin', 'Vproj', 'U', 'abs', 'hcom', 'com', 20 | 'ghcom', 'gcom', 'ecom', 'coe', 'lmax', 'omega'] 21 | tacs = ['auto', 'auto-step', 'case', 'cut-lemma', 'elim', 'else', 'exact', 22 | 'goal', 'hyp', 'id', 'lemma', 'let', 'claim', 'match', 'of', 23 | 'print', 'trace', 'progress', 'query', 'reduce', 'refine', 'repeat', 24 | 'rewrite', 'symmetry', 'then', 'unfold', 'use', 'with', 'without', 25 | 'fail', 'inversion', 'concl', 'assumption', '\;'] 26 | cmds = ['data', 'print', 'extract', 'quit', 'define', 'tactic', 'theorem'] 27 | misc = ['at', 'by', 'in', 'true', 'type', 'synth', 'discrete', 'kan', 'pre', 28 | 'dim', 'hyp', 'exp', 'lvl', 'tac', 'jdg', 'knd'] 29 | types = ['bool', 'nat', 'int', 'void', 's1', 'fun', 'record', 'path', 30 | 'line', 'pushout', 'coeq', 'eq', 'fcom', 'V', 'universe', 'hcom', 31 | 'coe', 'subtype', 'universe'] 32 | 33 | def joiner(arr): 34 | return '|'.join(map(lambda str: '\\b' + str + '\\b', arr)) 35 | 36 | # earlier rules take precedence 37 | tokens = { 38 | 'root': [ 39 | (r'\s+', Text), 40 | 41 | (r'//.*?$', Comment.Singleline), 42 | (r'/\*', Comment.Multiline, 'comment'), 43 | 44 | (joiner(map(lambda str: str + '/[\w/]+', types)), Name.Builtin), 45 | (joiner(exprs), Name.Builtin), 46 | (joiner(types), Name.Builtin), 47 | (r'\$|\*|!|@|=(?!>)|\+|->|~>|<~', Name.Builtin), 48 | 49 | (joiner(tacs), Keyword), 50 | (r';|`|=>|<=', Keyword), 51 | 52 | (joiner(cmds), Keyword.Declaration), 53 | 54 | (joiner(misc), Name.Builtin), 55 | 56 | (r'\#[a-zA-Z0-9\'/-]*', Name.Variable), 57 | (r'\%[a-zA-Z0-9\'/-]*', Name.Variable), 58 | 59 | (r'\(|\)|\[|\]|\.|:|,|\{|\}|_', Punctuation), 60 | (r'\b\d+', Number), 61 | 62 | # for typesetting rules: 63 | (r'^\|', Generic.Traceback), 64 | (r'>>', Name.Keyword), 65 | (r'<-', Name.Keyword), 66 | (r'/=', Name.Keyword), 67 | (r'<', Name.Keyword), 68 | (r'ext', Name.Keyword), 69 | (r'where', Name.Keyword), 70 | 71 | (r'\|', Punctuation), 72 | (r'[A-Z][a-zA-Z0-9\'/-]*', Name.Function), 73 | (r'[a-z][a-zA-Z0-9\'/-]*', Name.Variable), 74 | (r'\?[a-zA-Z0-9\'/-]*', Name.Exception), 75 | (r'-+$', Punctuation), 76 | ], 77 | 78 | 'comment': [ 79 | (r'[^*/]', Comment.Multiline), 80 | (r'/\*', Comment.Multiline, '#push'), 81 | (r'\*/', Comment.Multiline, '#pop'), 82 | (r'[*/]', Comment.Multiline) 83 | ], 84 | } 85 | -------------------------------------------------------------------------------- /doc/src/static/luminaries.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RedPRL/sml-redprl/c72190de76f7ed1cfbe1d2046c96e99ac5022b0c/doc/src/static/luminaries.png -------------------------------------------------------------------------------- /doc/src/static/luminaries.xcf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RedPRL/sml-redprl/c72190de76f7ed1cfbe1d2046c96e99ac5022b0c/doc/src/static/luminaries.xcf -------------------------------------------------------------------------------- /doc/src/static/red.css: -------------------------------------------------------------------------------- 1 | .wy-nav-side { 2 | background-color: #edf0f2; 3 | } 4 | 5 | .wy-nav-content-wrap { 6 | background-color: #fcfcfc; 7 | } 8 | 9 | .wy-side-nav-search, .wy-nav-top { 10 | background-color: #e84644; 11 | } 12 | 13 | .wy-side-nav-search input[type=text] { 14 | border-radius: 0; 15 | border-color: #404040; 16 | } 17 | 18 | .wy-menu-vertical a { 19 | color: black; 20 | } 21 | 22 | .wy-menu-vertical a:hover { 23 | background-color: #ee7977; 24 | color: white; 25 | } 26 | 27 | .wy-menu-vertical li a:hover { 28 | background-color: #ee7977 !important; 29 | color: white !important; 30 | } 31 | 32 | .wy-nav-content a.reference { 33 | text-decoration: underline; 34 | } 35 | 36 | body, h1, h2, h3, h4, h5, h6, pre, code { 37 | font-family: 'PragmataPro' !important; 38 | } 39 | 40 | code { 41 | border: none !important; 42 | background: none !important; 43 | padding: 0 0 0 0 !important; 44 | font-size: 100% !important; 45 | } 46 | 47 | .wy-nav-side { 48 | border-right: 1px solid #c9c9c9; 49 | } 50 | 51 | .wy-menu-vertical li.current a { 52 | color: #333; 53 | border:none !important; 54 | } 55 | 56 | .wy-menu-vertical li a { 57 | padding: 0.5em 2.427em !important; 58 | } 59 | 60 | .wy-menu-vertical li.on a span.toctree-expand, .wy-menu-vertical li.current>a span.toctree-expand { 61 | display: inline; 62 | } 63 | 64 | .wy-menu-vertical li span.toctree-expand { 65 | float: none; 66 | } 67 | 68 | .wy-menu-vertical li.on a span.toctree-expand:before, .wy-menu-vertical li>a span.toctree-expand:before { 69 | padding-right: 0.3em; 70 | } 71 | 72 | .fa-home:before, .icon-home:before { 73 | font-family: 'PragmataPro'; 74 | content: "\2605"; 75 | } 76 | 77 | .wy-nav-content a:visited { 78 | color: #2980B9; 79 | } 80 | 81 | div[class^='highlight'] pre { 82 | font-size: 14px !important; 83 | line-height: 1.5 !important; 84 | padding: 12px 20px; 85 | } 86 | 87 | div[class^='highlight'] { 88 | border: none !important; 89 | background: initial; 90 | } 91 | 92 | .revolutionary { 93 | color: #e84644; 94 | font-weight: 700; 95 | } 96 | 97 | .highlight .gt { 98 | background-color: #f7bcbb; 99 | color: #f7bcbb; 100 | padding: 3px 0; 101 | } 102 | 103 | .rst-content .section ul li { 104 | list-style: none !important; 105 | margin-left: 12px; 106 | } 107 | 108 | .rst-content .section ul li:before { 109 | content: '\2605'; 110 | color: #e84644; 111 | margin-right: 12px; 112 | } 113 | 114 | .rst-content .section ul li.toctree-l2:before { 115 | color: #404040; 116 | margin-right: 12px; 117 | } 118 | -------------------------------------------------------------------------------- /doc/src/static/uphold-cubical-thought.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RedPRL/sml-redprl/c72190de76f7ed1cfbe1d2046c96e99ac5022b0c/doc/src/static/uphold-cubical-thought.jpg -------------------------------------------------------------------------------- /example/J.prl: -------------------------------------------------------------------------------- 1 | define J/square(#i:dim,#j:dim, #ty, #a, #p) = 2 | (hcom 0~>#j #ty #a 3 | [#i=0 [_] #a] 4 | [#i=1 [j] (@ #p j)]) 5 | . 6 | 7 | define J/coe(#j:dim, #ty, #a, #fam, #d, #p) = 8 | (coe 0~>#j 9 | [i] ($ #fam 10 | (J/square i (dim 1) #ty #a #p) 11 | (abs [j] (J/square i j #ty #a #p))) 12 | #d) 13 | . 14 | 15 | theorem J(#l:lvl) : 16 | (-> 17 | [ty : (U #l kan)] 18 | [a : ty] 19 | [fam : (-> [x : ty] (path [_] ty a x) (U #l kan))] 20 | [d : ($ fam a (abs [_] a))] 21 | [x : ty] 22 | [p : (path [_] ty a x)] 23 | ($ fam x p)) 24 | by { 25 | lam ty a fam d x p => `(J/coe (dim 1) ty a fam d p) 26 | }. 27 | 28 | define J/comp/cube(#i:dim,#j:dim,#k:dim, #ty, #a) = 29 | (hcom 0~>#j #ty #a 30 | [#k=0 [j] (J/square #i j #ty #a (abs [_] #a))] 31 | [#k=1 [_] #a] 32 | [#i=0 [_] #a] 33 | [#i=1 [_] #a]) 34 | . 35 | 36 | theorem J/comp(#l:lvl) : 37 | (-> 38 | [ty : (U #l kan)] 39 | [a : ty] 40 | [fam : (-> [x : ty] (path [_] ty a x) (U #l kan))] 41 | [d : ($ fam a (abs [_] a))] 42 | (path [_] ($ fam a (abs [_] a)) 43 | ($ (J #l) ty a fam d a (abs [_] a)) 44 | d)) 45 | by { 46 | lam ty a fam d => abs k => 47 | `(com 0~>1 48 | [i] ($ fam (J/comp/cube i (dim 1) k ty a) 49 | (abs [j] (J/comp/cube i j k ty a))) 50 | d 51 | [k=0 [i] (J/coe i ty a fam d (abs [_] a))] 52 | [k=1 [_] d]) 53 | }. 54 | -------------------------------------------------------------------------------- /example/README.prl: -------------------------------------------------------------------------------- 1 | theorem BoolTest : 2 | (-> bool bool) 3 | by { 4 | // A term/witness can be supplied to the refiner at any point in a tactic script 5 | // using the quotation operator `. 6 | lam x => if x then `tt else `ff 7 | }. 8 | 9 | 10 | theorem PathTest : 11 | (path [_] S1 base base) 12 | by { 13 | abs x => `(loop x) 14 | }. 15 | 16 | theorem LowLevel : 17 | (-> 18 | (-> bool bool) 19 | bool) 20 | by { 21 | refine fun/intro; 22 | [ with f => 23 | elim f; [`tt, with x/eq x => use x] 24 | , refine fun/eqtype; 25 | refine bool/eqtype 26 | ] 27 | }. 28 | 29 | print LowLevel. 30 | 31 | theorem LowLevel2 : 32 | (-> 33 | (-> bool bool) 34 | bool 35 | bool) 36 | by { 37 | repeat {refine fun/intro; [id, auto]}; 38 | with x f => 39 | elim f; 40 | [ use x 41 | , with y/eq y => use y 42 | ] 43 | }. 44 | 45 | 46 | print LowLevel2. 47 | 48 | theorem FunElimTest : 49 | (-> 50 | (-> bool bool) 51 | bool) 52 | by { 53 | lam f => use f [`tt] 54 | }. 55 | 56 | theorem S1ElimTest : (-> S1 S1) by { 57 | lam s => 58 | case s of 59 | base => `base 60 | | loop x => `(loop x) 61 | }. 62 | 63 | tactic Try(#t : tac) = { 64 | #t || id 65 | }. 66 | 67 | // Useful for stepping through a proof RedPRL completes automatically, to see 68 | // what is being done. 69 | tactic TryStep = { 70 | // We can call our Try tactical. But tactics are parsed with a different grammar than terms, 71 | // so to avoid ambiguity, when we need to provide a tactic expression as an argument to 72 | // an operator, we wrap it in (tactic ....). 73 | (Try #tac{auto-step}) 74 | }. 75 | 76 | // 'if' is the recursor for booleans. It takes the motive of induction as an argument 77 | // in order to facilitate type synthesizing. 78 | define BoolEta(#M) = 79 | (if [a] bool #M tt ff) 80 | . 81 | 82 | print BoolEta. 83 | 84 | // If we define such a function in the refiner using tactics, we can use the 85 | // built-in 'if x then t1 else t2' tactical, and the extracted witness will be 86 | // an 'if' form with the motive already filled in. 87 | theorem BoolEtaFunction : 88 | (-> bool bool) 89 | by { 90 | lam b => if b then `tt else `ff 91 | }. 92 | 93 | print BoolEtaFunction. 94 | 95 | // Let's prove the existence of a path between the identity function 96 | // on booleans, and the function that takes a boolean to a vacuous if 97 | // statement. 98 | // 99 | // The most fun way to use RedPRL is interactively! We will write our 100 | // proof in the development calculus. The advantage of this style of 101 | // proof is that we can leave holes, and interactively figure out what 102 | // we need to do. 103 | // 104 | theorem PathTest2 : 105 | (path 106 | [_] (-> bool bool) 107 | (lam [b] b) 108 | (lam [b] (BoolEta b))) 109 | by { 110 | // abstract a dimension 111 | abs x => 112 | // now, we are constructing a line of functions; so we use a 113 | // lambda. 114 | lam b => 115 | // for our b:bool, we will construct a path between b and 116 | // (BoolEta b). 117 | claim p : (path [_] bool b (BoolEta b)) by { 118 | if b then abs y => `tt else abs y => `ff 119 | }; 120 | 121 | // Now, we will project the 'x'-side of our path. In the 122 | // interactive tactic environment, dimension expressions are 123 | // supplied to the refiner using the '@' "dimension quotation" 124 | // operator. 125 | use p [`x] 126 | }. 127 | 128 | 129 | // It turns out that it is just as good to figure out what the witness 130 | // program for this path is by hand, and then tell RedPRL to try and 131 | // prove that it does in fact witness this path. This approach is not 132 | // preferred, because it is not interactive: you must know ahead of 133 | // time the entirety of the program, and cannot take advantage of 134 | // types in order to guide its construction, or even synthesize part 135 | // of it. 136 | theorem PathTest3 : 137 | (path 138 | [_] (-> bool bool) 139 | (lam [b] b) 140 | (lam [b] (BoolEta b))) 141 | by { 142 | // I'm surprised that RedPRL can typecheck this properly! quite 143 | // encouraging. 144 | `(abs [x] 145 | (lam [b] 146 | (@ (if [b] (path [_] bool b (BoolEta b)) b (abs [_] tt) (abs [_] ff)) 147 | x))) 148 | }. 149 | 150 | print PathTest3. 151 | 152 | theorem PairTest : (* [a : S1] (path [_] S1 a base)) by { 153 | {`base, abs x => `(loop x)} 154 | }. 155 | 156 | 157 | define Cmp(#f, #g) = 158 | (lam [x] ($ #f ($ #g x))) 159 | . 160 | 161 | 162 | define MyLoop(#x:dim, #m) = 163 | (tuple [proj1 #m] [proj2 (loop #x)]) 164 | . 165 | 166 | define Test = 167 | (MyLoop (dim 0) (loop 1)) 168 | . 169 | 170 | print Test. 171 | 172 | theorem SNot : (-> bool bool) by { 173 | lam b => if b then `ff else `tt 174 | }. 175 | 176 | theorem StrictBoolTest : SNot = (Cmp SNot (Cmp SNot SNot)) in (-> bool bool) by { 177 | auto 178 | }. 179 | 180 | theorem Not : (-> [_ : bool] bool) by { 181 | lam x => if x then `ff else `tt 182 | }. 183 | 184 | theorem FunExt(#l:lvl) : 185 | (-> 186 | [a b : (U #l)] 187 | [f g : (-> a b)] 188 | [p : (-> [y : a] (path [_] b ($ f y) ($ g y)))] 189 | (path [_] (-> a b) f g)) 190 | by { 191 | lam a b f g p => 192 | abs i => lam x => use p [use x, `i] 193 | }. 194 | 195 | print FunExt. 196 | 197 | tactic FunExtTac(#l : lvl) = { 198 | query gl <- concl; 199 | match gl { 200 | [a b f g | #jdg{(path [_] (-> %a %b) %f %g) true} => 201 | use (FunExt #l) [`%a, `%b, `%f, `%g, id] 202 | ] 203 | } 204 | }. 205 | 206 | print FunExtTac. 207 | 208 | theorem NotNotPath : (path [_] (-> bool bool) (Cmp Not Not) (lam [x] x)) by { 209 | (FunExtTac #lvl{0}); 210 | lam x => if x then abs _ => `tt else abs _ => `ff 211 | }. 212 | 213 | print NotNotPath. 214 | print FunExtTac. 215 | print NotNotPath. 216 | 217 | theorem Singleton : (* [x : bool] (path [_] bool x tt)) by { 218 | {`tt, abs _ => `tt} 219 | }. 220 | 221 | theorem PathElimTest : (-> (path [_] bool tt tt) bool) by { 222 | lam x => use x [`(dim 0)] 223 | }. 224 | 225 | theorem PathEta(#l:lvl) : 226 | (-> 227 | [a : (U #l)] 228 | [m n : a] 229 | (path [_] a m n) 230 | (path [_] a m n)) 231 | by { 232 | lam a m n p => abs j => use p [`j] 233 | }. 234 | 235 | print PathEta. 236 | 237 | print PathElimTest. 238 | -------------------------------------------------------------------------------- /example/category.prl: -------------------------------------------------------------------------------- 1 | theorem Category(#i:lvl) : (U (++ #i)) by { 2 | `(record 3 | [ob : (U #i)] 4 | [hom : (-> ob ob (U #i))] 5 | [idn : (-> [a : ob] ($ hom a a))] 6 | [cmp : (-> [a b c : ob] ($ hom b c) ($ hom a b) ($ hom a c))] 7 | [idn/l : 8 | (-> 9 | [a b : ob] 10 | [f : ($ hom a b)] 11 | (= ($ hom a b) 12 | ($ cmp a b b ($ idn b) f) 13 | f))] 14 | [idn/r : 15 | (-> 16 | [a b : ob] 17 | [f : ($ hom a b)] 18 | (= ($ hom a b) 19 | ($ cmp a a b f ($ idn a)) 20 | f))] 21 | [assoc : 22 | (-> 23 | [a b c d : ob] 24 | [f : ($ hom a b)] 25 | [g : ($ hom b c)] 26 | [h : ($ hom c d)] 27 | (= ($ hom a d) 28 | ($ cmp a c d h ($ cmp a b c g f)) 29 | ($ cmp a b d ($ cmp b c d h g) f) 30 | ))]) 31 | }. 32 | 33 | theorem Test(#l:lvl) : (Category (++#l)) by { 34 | { ob = `(U #l) 35 | , hom = lam ty/a ty/b => `(-> ty/a ty/b) 36 | , idn = lam ty/a x => `x 37 | , cmp = lam ty/a ty/b ty/a f g x => use f [use g [`x]] 38 | , idn/l = lam _ _ _ => auto 39 | , idn/r = lam _ _ _ => auto 40 | , assoc = lam _ _ _ _ _ _ _ => auto 41 | } 42 | }. 43 | 44 | // theorem Op(#l:lvl) : 45 | // (-> (Category #l) (Category #l)) 46 | // by { 47 | // lam {ob = ob, hom = hom, idn = idn, cmp = cmp, idn/l = idn/l, idn/r = idn/r, assoc = assoc} => 48 | // { ob = `ob 49 | // , hom = lam c d => use hom [`d, `c] 50 | // , idn = `idn 51 | // , cmp = lam a b c f g => use cmp [`c, `b, `a, `g, `f] 52 | // , idn/l = lam a b f => use idn/r [`b, `a, `f]; auto; assumption 53 | // , idn/r = lam a b f => use idn/l [`b, `a, `f]; auto; assumption 54 | // , assoc = ? 55 | // } 56 | // }. 57 | -------------------------------------------------------------------------------- /example/connection.prl: -------------------------------------------------------------------------------- 1 | theorem Connection/And(#l:lvl) : 2 | (-> 3 | [ty : (U #l hcom)] 4 | [a b : ty] 5 | [p : (path [_] ty a b)] 6 | (path [i] (path [_] ty a (@ p i)) (abs [_] a) p)) 7 | by { 8 | lam ty a b p => 9 | abs i j => 10 | `(hcom 0~>1 ty a 11 | [i=0 [k] (hcom 1~>0 ty (@ p k) [k=0 [_] a] [k=1 [l] (@ p l)])] 12 | [i=1 [k] (hcom 1~>j ty (@ p k) [k=0 [_] a] [k=1 [l] (@ p l)])] 13 | [j=0 [k] (hcom 1~>0 ty (@ p k) [k=0 [_] a] [k=1 [l] (@ p l)])] 14 | [j=1 [k] (hcom 1~>i ty (@ p k) [k=0 [_] a] [k=1 [l] (@ p l)])] 15 | [i=j [k] (hcom 1~>i ty (@ p k) [k=0 [_] a] [k=1 [l] (@ p l)])]) 16 | }. 17 | 18 | theorem Connection/And/Diagonal (#l:lvl) : 19 | (-> 20 | [ty : (U #l hcom)] 21 | [a b : ty] 22 | [p : (path [_] ty a b)] 23 | (= (path [_] ty a b) (abs [i] (@ ($ (Connection/And #l) ty a b p) i i)) p)) 24 | by { 25 | lam ty a b p => unfold Connection/And; auto 26 | }. 27 | 28 | theorem Connection/Or(#l:lvl) : 29 | (-> 30 | [ty : (U #l hcom)] 31 | [a b : ty] 32 | [p : (path [_] ty a b)] 33 | (path [i] (path [_] ty (@ p i) b) p (abs [_] b))) 34 | by { 35 | lam ty a b p => 36 | abs i j => 37 | `(hcom 1~>0 ty b 38 | [i=0 [k] (hcom 0~>j ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])] 39 | [i=1 [k] (hcom 0~>1 ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])] 40 | [j=0 [k] (hcom 0~>i ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])] 41 | [j=1 [k] (hcom 0~>1 ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])] 42 | [i=j [k] (hcom 0~>i ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])]) 43 | }. 44 | 45 | theorem Connection/Or/Diagonal (#l:lvl) : 46 | (-> 47 | [ty : (U #l hcom)] 48 | [a b : ty] 49 | [p : (path [_] ty a b)] 50 | (= (path [_] ty a b) (abs [i] (@ ($ (Connection/Or #l) ty a b p) i i)) p)) 51 | by { 52 | lam ty a b p => unfold Connection/Or; auto 53 | }. 54 | -------------------------------------------------------------------------------- /example/groupoid.prl: -------------------------------------------------------------------------------- 1 | // Homogeneous groupoid operations 2 | 3 | theorem Refl(#l:lvl) : 4 | (-> 5 | [ty : (U #l kan)] 6 | [a : ty] 7 | (path [_] ty a a)) 8 | by { 9 | lam ty a => abs _ => `a 10 | }. 11 | 12 | theorem Symm(#l:lvl) : 13 | (-> 14 | [ty : (U #l kan)] 15 | [p : (line [_] ty)] 16 | (path [_] ty (@ p 1) (@ p 0))) 17 | by { 18 | lam ty p => abs x => 19 | `(hcom 0~>1 ty (@ p 0) 20 | [x=0 [y] (@ p y)] 21 | [x=1 [_] (@ p 0)]) 22 | }. 23 | 24 | theorem Trans(#l:lvl) : 25 | (-> 26 | [ty : (U #l kan)] 27 | [p : (line [_] ty)] 28 | [q : (line [_] ty)] 29 | [eq : (= ty (@ p 1) (@ q 0))] 30 | (path [_] ty (@ p 0) (@ q 1))) 31 | by { 32 | lam ty p q eq => (abs x => 33 | `(hcom 0~>1 ty (@ p x) 34 | [x=0 [_] (@ p 0)] 35 | [x=1 [z] (@ q z)])); 36 | auto; assumption 37 | }. 38 | 39 | theorem Symm/Unit(#l:lvl) : 40 | (-> 41 | [ty : (U #l kan)] 42 | [a : ty] 43 | (path [_] 44 | (path [_] ty a a) 45 | (abs [_] a) 46 | ($ (Symm #l) ty (abs [_] a)))) 47 | by { 48 | lam ty a => 49 | abs y x => 50 | `(hcom 0~>y ty a [x=0 [_] a] [x=1 [_] a]) 51 | }. 52 | 53 | theorem Trans/Unit/R(#l:lvl) : 54 | (-> 55 | [ty : (U #l kan)] 56 | [p : (line [_] ty)] 57 | (path [_] 58 | (path [_] ty (@ p 0) (@ p 1)) 59 | p 60 | ($ (Trans #l) ty p (abs [_] (@ p 1)) ax))) 61 | by { 62 | lam ty p => 63 | (abs y x => 64 | `(hcom 0~>y ty (@ p x) [x=0 [_] (@ p 0)] [x=1 [_] (@ p 1)])); 65 | 66 | refine path/eq/from-line; auto 67 | }. 68 | 69 | // Thanks to Bruno Bentzen for already doing this and drawing a picture! -Carlo 70 | theorem Trans/Sym/R(#l:lvl) : 71 | (-> 72 | [ty : (U #l kan)] 73 | [p : (line [_] ty)] 74 | (path [_] 75 | (path [_] ty (@ p 0) (@ p 0)) 76 | (abs [_] (@ p 0)) 77 | ($ (Trans #l) ty p ($ (Symm #l) ty p) ax))) 78 | by { 79 | lam ty p => 80 | (abs z x => 81 | `(hcom 0~>1 ty (@ p x) 82 | [x=0 [_] (@ p 0)] 83 | [x=1 [y] (@ ($ (Symm #l) ty p) y)] 84 | [z=0 [y] (hcom 0~>x ty (@ p 0) [y=0 [x] (@ p x)] [y=1 [_] (@ p 0)])] 85 | [z=1 [y] 86 | (hcom 0~>y ty (@ p x) 87 | [x=0 [_] (@ p 0)] 88 | [x=1 [y] (@ ($ (Symm #l) ty p) y)])])); 89 | unfold Symm; auto 90 | }. 91 | 92 | // Heterogeneous groupoid operations 93 | 94 | theorem DSymm(#l:lvl) : 95 | (-> 96 | [ty : (line [_] (U #l kan))] 97 | [p : (line [x] (@ ty x))] 98 | (path [x] 99 | (@ ($ (Symm (++ #l)) (U #l kan) ty) x) 100 | (@ p 1) 101 | (@ p 0))) 102 | by { 103 | lam ty p => 104 | (abs x => 105 | `(com 0~>1 106 | [y] (hcom 0~>y (U #l kan) (@ ty 0) [x=0 [y] (@ ty y)] [x=1 [_] (@ ty 0)]) 107 | (@ p 0) 108 | [x=0 [y] (@ p y)] 109 | [x=1 [_] (@ p 0)])); 110 | unfold Symm; auto 111 | }. 112 | -------------------------------------------------------------------------------- /example/hlevels.prl: -------------------------------------------------------------------------------- 1 | define HasAllPathsTo (#C,#c) = (-> [c' : #C] (path [_] #C c' #c)). 2 | define IsContr (#C) = (* [c : #C] (HasAllPathsTo #C c)). 3 | define IsProp (#A) = (-> [a b : #A] (path [_] #A a b)). 4 | define IsSet (#A) = (-> [a b : #A] (IsProp (path [_] #A a b))). 5 | 6 | theorem InhPropIsContr(#l:lvl) : 7 | (-> 8 | [ty : (U #l kan)] 9 | [h : (IsProp ty)] 10 | [a : ty] 11 | (IsContr ty)) 12 | by { 13 | lam ty h a => {use a, lam x => `($ h x a)} 14 | }. 15 | 16 | theorem PropPi(#l:lvl) : 17 | (-> 18 | [tyA : (U #l kan)] 19 | [tyB : (-> tyA (U #l kan))] 20 | [h : (-> [x : tyA] (IsProp ($ tyB x)))] 21 | (IsProp (-> [x : tyA] ($ tyB x)))) 22 | by { 23 | lam tyA tyB h f g => abs i => lam x => `(@ ($ h x ($ f x) ($ g x)) i) 24 | }. 25 | 26 | theorem PropSet(#l:lvl) : 27 | (-> 28 | [tyA : (U #l kan)] 29 | [h : (IsProp tyA)] 30 | (IsSet tyA)) 31 | by { 32 | lam tyA h a b p q => 33 | abs j i => 34 | `(hcom 0~>1 tyA a 35 | [i=0 [k] (@ ($ h a a) k)] 36 | [i=1 [k] (@ ($ h a b) k)] 37 | [j=0 [k] (@ ($ h a (@ p i)) k)] 38 | [j=1 [k] (@ ($ h a (@ q i)) k)]) 39 | }. 40 | 41 | theorem IsPropIsProp(#l:lvl) : 42 | (-> 43 | [tyA : (U #l kan)] 44 | (IsProp (IsProp tyA))) 45 | by { 46 | lam tyA h1 h2 => 47 | abs i => lam a b => 48 | use (PropSet #l) [`tyA, `h1, `a, `b, `($ h1 a b), `($ h2 a b), `i] 49 | }. 50 | 51 | theorem IsPropIsSet(#l:lvl) : 52 | (-> 53 | [tyA : (U #l kan)] 54 | (IsProp (IsSet tyA))) 55 | by { 56 | lam tyA h1 h2 => 57 | abs i => lam a b => 58 | use (IsPropIsProp #l) [`(path [_] tyA a b), `($ h1 a b), `($ h2 a b), `i] 59 | }. 60 | -------------------------------------------------------------------------------- /example/invariance.prl: -------------------------------------------------------------------------------- 1 | // Representation independence via univalence. 2 | 3 | // (-> bool ty) and (* ty ty) are equivalent by f |-> (f tt, f ff). 4 | // We use this fact to transport 5 | // (1) functions to tuples; 6 | // (2) `swap` on tuples to `swap` on functions; and 7 | // (3) a law about `swap` on tuples to the corresponding law 8 | // about `swap` on functions. 9 | theorem FunToPair : 10 | (-> 11 | [ty : (U 0 kan)] 12 | (-> bool ty) 13 | (* ty ty)) 14 | by { 15 | lam ty fun => 16 | {`($ fun tt), `($ fun ff)} 17 | }. 18 | 19 | // {{{ Univalence 20 | 21 | define HasAllPathsTo (#C,#c) = (-> [c' : #C] (path [_] #C c' #c)). 22 | define IsContr (#C) = (* [c : #C] (HasAllPathsTo #C c)). 23 | define Fiber (#A,#B,#f,#b) = (* [a : #A] (path [_] #B ($ #f a) #b)). 24 | define IsEquiv (#A,#B,#f) = (-> [b : #B] (IsContr (Fiber #A #B #f b))). 25 | define Equiv (#A,#B) = (* [f : (-> #A #B)] (IsEquiv #A #B f)). 26 | 27 | theorem WeakConnection(#l:lvl) : 28 | (-> 29 | [ty : (U #l hcom)] 30 | [a b : ty] 31 | [p : (path [_] ty a b)] 32 | (path [i] (path [_] ty (@ p i) b) p (abs [_] b))) 33 | by { 34 | (lam ty a b p => 35 | abs i j => 36 | `(hcom 1~>0 ty b 37 | [i=0 [k] (hcom 0~>j ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])] 38 | [i=1 [k] (hcom 0~>1 ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])] 39 | [j=0 [k] (hcom 0~>i ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])] 40 | [j=1 [k] (hcom 0~>1 ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])])) 41 | }. 42 | 43 | tactic GetEndpoints(#p, #t:[exp,exp].tac) = { 44 | query pty <- #p; 45 | match pty { 46 | [ty l r | #jdg{(path [_] %ty %l %r)} => 47 | claim p/0 : (@ #p 0) = %l in %ty by {auto}; 48 | claim p/1 : (@ #p 1) = %r in %ty by {auto}; 49 | (#t p/0 p/1) 50 | ] 51 | } 52 | }. 53 | 54 | theorem FunToPairIsEquiv : 55 | (-> 56 | [ty : (U 0 kan)] 57 | (IsEquiv (-> bool ty) (* ty ty) ($ FunToPair ty))) 58 | by { 59 | lam ty pair => 60 | { { lam b => if b then `(!proj1 pair) else `(!proj2 pair) 61 | , abs _ => `pair } 62 | , unfold Fiber; 63 | lam {fun,p} => 64 | (GetEndpoints p [p/0 p/1] #tac{ 65 | (abs x => 66 | {lam b => if b then `(!proj1 (@ p x)) else `(!proj2 (@ p x)), 67 | abs y => 68 | `(@ ($ (WeakConnection #lvl{0}) (* ty ty) ($ FunToPair ty fun) pair p) x y) 69 | }); 70 | [ unfold FunToPair in p/0; reduce in p/0 at right; 71 | inversion; with q3 q2 q1 q0 => 72 | reduce at right in q2; 73 | reduce at right in q3; 74 | auto; with b => 75 | elim b; reduce at right; symmetry; assumption 76 | , unfold FunToPair in p/1; reduce in p/1 at right; 77 | inversion; with q3 q2 q1 q0 => elim pair; 78 | reduce at right in q0; reduce at right in q1; 79 | auto; assumption 80 | ] 81 | }) 82 | } 83 | }. 84 | 85 | // }}} 86 | 87 | // By univalence, there is a path between these two types. 88 | theorem FunEqPair : 89 | (-> 90 | [ty : (U 0 kan)] 91 | (path [_] (U 0 kan) (-> bool ty) (* ty ty))) 92 | by { 93 | lam ty => abs x => 94 | `(V x (-> bool ty) (* ty ty) 95 | (tuple [proj1 ($ FunToPair ty)] [proj2 ($ FunToPairIsEquiv ty)])) 96 | }. 97 | 98 | // We can coerce functions to pairs, and this coercion will compute. 99 | theorem CoerceFunToPair : 100 | (-> 101 | [ty : (U 0 kan)] 102 | (-> bool ty) 103 | (* ty ty)) 104 | by { 105 | lam ty fun => 106 | `(coe 0~>1 [x] (@ ($ FunEqPair ty) x) fun) 107 | }. 108 | 109 | theorem ComputeCoercion : 110 | (= 111 | (* bool bool) 112 | ($ CoerceFunToPair bool (lam [b] b)) 113 | (tuple [proj1 tt] [proj2 ff])) 114 | by { 115 | auto 116 | }. 117 | 118 | // We can define a function on pairs, coerce it to a function on functions, and 119 | // this coercion will compute. 120 | theorem SwapPair : 121 | (-> 122 | [ty : (U 0 kan)] 123 | (* ty ty) 124 | (* ty ty)) 125 | by { 126 | lam ty {p1,p2} => {`p2,`p1} 127 | }. 128 | 129 | define SwapCoe(#ty,#r:dim) = 130 | (coe 1~>#r [x] (-> (@ ($ FunEqPair #ty) x) (@ ($ FunEqPair #ty) x)) ($ SwapPair #ty)). 131 | 132 | theorem SwapFun : 133 | (-> 134 | [ty : (U 0 kan)] 135 | (-> bool ty) 136 | (-> bool ty)) 137 | by { 138 | lam ty => `(SwapCoe ty 0) 139 | }. 140 | 141 | theorem ComputeSwap : 142 | (= 143 | bool 144 | ($ SwapFun bool (lam [b] b) tt) 145 | ff) 146 | by { 147 | auto 148 | }. 149 | 150 | // We can prove that SwapPair o SwapPair = id, and coerce this to the same 151 | // equation on SwapFun. 152 | theorem SwapPairEqn : 153 | (-> 154 | [ty : (U 0 kan)] 155 | [pair : (* ty ty)] 156 | (path [_] (* ty ty) ($ SwapPair ty ($ SwapPair ty pair)) pair)) 157 | by { 158 | lam ty pair => abs x => `pair 159 | }. 160 | 161 | theorem SwapFunEqn : 162 | (-> 163 | [ty : (U 0 kan)] 164 | [fun : (-> bool ty)] 165 | (path [_] (-> bool ty) ($ SwapFun ty ($ SwapFun ty fun)) fun)) 166 | by { 167 | lam ty => 168 | `(coe 1~>0 169 | [x] (-> [elt : (@ ($ FunEqPair ty) x)] 170 | (path [_] (@ ($ FunEqPair ty) x) 171 | ($ (SwapCoe ty x) ($ (SwapCoe ty x) elt)) 172 | elt)) 173 | ($ SwapPairEqn ty)); 174 | refine coe/eq; 175 | #2 { 176 | refine subtype/eq; refine fun/eqtype; 177 | #1 { 178 | refine path/eqtype; unfold FunEqPair; 179 | #1 { 180 | reduce at type; unfold SwapCoe SwapFun 181 | } 182 | } 183 | }; auto 184 | }. 185 | -------------------------------------------------------------------------------- /example/isotoequiv.prl: -------------------------------------------------------------------------------- 1 | define IsContr (#C) = (* [c : #C] (-> [c' : #C] (path [_] #C c' c))). 2 | 3 | define Fiber (#A,#B,#f,#b) = (* [a : #A] (path [_] #B ($ #f a) #b)). 4 | 5 | define IsEquiv (#A,#B,#f) = (-> [b : #B] (IsContr (Fiber #A #B #f b))). 6 | 7 | define Equiv (#A,#B) = (* [f : (-> #A #B)] (IsEquiv #A #B f)). 8 | 9 | define Iso(#A, #B) = 10 | (record 11 | [f : (-> #A #B)] 12 | [g : (-> #B #A)] 13 | [fg : (-> [b : #B] (path [_] #B ($ f ($ g b)) b))] 14 | [gf : (-> [a : #A] (path [_] #A ($ g ($ f a)) a))]). 15 | 16 | define Rem/Sq(#A,#g,#gf,#b,#x,#p,#i:dim,#j:dim) = 17 | (hcom 0~>#j #A ($ #g (@ #p #i)) 18 | [#i=0 [k] (@ ($ #gf #x) k)] 19 | [#i=1 [_] ($ #g #b)]). 20 | 21 | define P/Sq(#A,#g,#b,#sq0,#sq1,#i:dim,#j:dim) = 22 | (hcom 1~>#j #A ($ #g #b) 23 | [#i=0 [k] (@ #sq0 k 1)] 24 | [#i=1 [k] (@ #sq1 k 1)]). 25 | 26 | theorem LemIso(#l:lvl) : 27 | (-> 28 | [ty/a : (U #l kan)] 29 | [ty/b : (U #l kan)] 30 | [iso : (Iso ty/a ty/b)] 31 | [b : ty/b] 32 | [f0 f1 : (Fiber ty/a ty/b (!f iso) b)] 33 | (path [_] (Fiber ty/a ty/b (!f iso) b) f0 f1)) 34 | by { 35 | lam ty/a ty/b {f=f,g=g,fg=fg,gf=gf} b {x0,p0} {x1,p1} => 36 | claim sq0 : (path [i] (path [j] ty/a 37 | ($ g (@ p0 i)) 38 | (Rem/Sq ty/a g gf b x0 p0 i 1)) 39 | ($ gf x0) 40 | (abs [_] ($ g b))) by { 41 | abs i j => `(Rem/Sq ty/a g gf b x0 p0 i j) 42 | }; 43 | claim sq1 : (path [i] (path [j] ty/a 44 | ($ g (@ p1 i)) 45 | (Rem/Sq ty/a g gf b x1 p1 i 1)) 46 | ($ gf x1) 47 | (abs [_] ($ g b))) by { 48 | abs i j => `(Rem/Sq ty/a g gf b x1 p1 i j) 49 | }; 50 | /* 51 | claim sq2 : (path [i] (path [j] ty/a (P/Sq ty/a g b sq0 sq1 i 0) 52 | ($ g b)) 53 | (abs [j] (@ sq0 j 1)) 54 | (abs [j] (@ sq1 j 1))) by { 55 | abs i j => `(P/Sq ty/a g b sq0 sq1 i j) 56 | }; 57 | */ 58 | abs i => 59 | {`(P/Sq ty/a g b sq0 sq1 i 0), id}; 60 | abs j => 61 | `(hcom 0~>1 ty/b 62 | ($ f (hcom 1~>0 ty/a (P/Sq ty/a g b sq0 sq1 i j) 63 | [i=0 [k] (Rem/Sq ty/a g gf b x0 p0 j k)] 64 | [i=1 [k] (Rem/Sq ty/a g gf b x1 p1 j k)] 65 | [j=0 [k] (@ ($ gf (P/Sq ty/a g b sq0 sq1 i 0)) k)] 66 | [j=1 [_] ($ g b)])) 67 | [i=0 [k] (@ ($ fg (@ p0 j)) k)] 68 | [i=1 [k] (@ ($ fg (@ p1 j)) k)] 69 | [j=0 [k] (@ ($ fg ($ f (P/Sq ty/a g b sq0 sq1 i 0))) k)] 70 | [j=1 [k] (@ ($ fg b) k)]) 71 | }. 72 | 73 | theorem IsoToEquiv(#l:lvl) : 74 | (-> 75 | [ty/a : (U #l kan)] 76 | [ty/b : (U #l kan)] 77 | (Iso ty/a ty/b) 78 | (Equiv ty/a ty/b)) 79 | by { 80 | lam ty/a ty/b {f=f,g=g,fg=fg,gf=gf} => 81 | {use f, id}; 82 | lam b => 83 | {{`($ g b), `($ fg b)}, id}; 84 | lam fib => 85 | use (LemIso #l) 86 | [`ty/a, 87 | `ty/b, 88 | `(tuple [f f] [g g] [fg fg] [gf gf]), 89 | `b, 90 | `fib, 91 | {`($ g b), `($ fg b)}] 92 | }. 93 | -------------------------------------------------------------------------------- /example/metalanguage.prl: -------------------------------------------------------------------------------- 1 | // RedPRL's metalanguage is called RedML. RedPRL documents are really sequences of RedML declarations! 2 | // RedML is like "CBPV with nominal characteristics"; later it will develop to a full ML. 3 | 4 | define Op = (lam [x] x). 5 | 6 | // we can suspend a command to execute later. "{ cmd }" turns a command into a value (thunk), 7 | // and "^ val" is the command that returns a value. 8 | val MyCmd = ^ { print Op }. 9 | 10 | let 11 | theorem Bar(#l:lvl) : (-> [ty : (U #l kan)] ty ty) by { 12 | lam ty x => use x 13 | }; 14 | let val M = extract Bar; 15 | print M. 16 | 17 | // Bar no longer in scope 18 | 19 | 20 | // now let's go ahead and run our command 21 | !MyCmd. 22 | 23 | -------------------------------------------------------------------------------- /example/omega1s1-inductive.prl: -------------------------------------------------------------------------------- 1 | data S1' : (U 0 kan) 2 | { base' 3 | , loop' [x : dim] [x=0 (self base')] [x=1 (self base')] 4 | } 5 | by { 6 | auto 7 | }. 8 | 9 | theorem IntPred : 10 | (-> int int) 11 | by { 12 | lam a => elim a; 13 | [ with n => elim n; 14 | [ `(int -1) 15 | , with _ n' => `(pos n') 16 | ] 17 | , with n => `(negsucc (succ n)) 18 | ]; 19 | }. 20 | 21 | theorem IntSucc : 22 | (-> int int) 23 | by { 24 | lam a => elim a; 25 | [ with n => `(pos (succ n)) 26 | , with n => elim n; 27 | [ `(int 0) 28 | , with _ n' => `(negsucc n') 29 | ] 30 | ] 31 | }. 32 | 33 | theorem IntSuccIntPred : 34 | (-> [i : int] (= int ($ IntSucc ($ IntPred i)) i)) 35 | by { 36 | lam i => elim i; 37 | [ with n => elim n; auto 38 | , auto 39 | ] 40 | }. 41 | 42 | theorem IntPredIntSucc : 43 | (-> [i : int] (= int ($ IntPred ($ IntSucc i)) i)) 44 | by { 45 | lam i => elim i; 46 | [ auto 47 | , with n => elim n; auto 48 | ] 49 | }. 50 | 51 | define HasAllPathsTo (#C,#c) = (-> [c' : #C] (path [_] #C c' #c)). 52 | 53 | define IsContr (#C) = (* [c : #C] (HasAllPathsTo #C c)). 54 | 55 | define Fiber (#A,#B,#f,#b) = (* [a : #A] (path [_] #B ($ #f a) #b)). 56 | 57 | define IsEquiv (#A,#B,#f) = (-> [b : #B] (IsContr (Fiber #A #B #f b))). 58 | 59 | define Equiv (#A,#B) = (* [f : (-> #A #B)] (IsEquiv #A #B f)). 60 | 61 | theorem IntSuccIsEquiv : 62 | (IsEquiv int int IntSucc) 63 | by { 64 | lam i => 65 | claim eq : (= int ($ IntSucc ($ IntPred i)) i) by {use IntSuccIntPred [`i]}; 66 | unfold IntSucc IntPred in eq; reduce at left in eq; 67 | { {use IntPred [`i], abs _ => `i}; 68 | auto; assumption 69 | , lam {i',p'} => 70 | claim eq0 : (= int i ($ IntSucc i')) by {`(coe 1~>0 [x] (= int i (@ p' x)) ax)}; 71 | claim eq1 : (= int ($ IntPred i) i') by { 72 | rewrite eq0 at left; 73 | [ with i'' => `($ IntPred i''), `($ IntPredIntSucc i') ]; 74 | auto 75 | }; 76 | 77 | (abs x => 78 | {`($ IntPred i), abs y => `(hcom 1~>y int i [x=0 [y] (@ p' y)] [x=1 [_] i])}); 79 | 80 | auto; unfold IntPred in eq1; reduce at left in eq1; auto; assumption 81 | } 82 | }. 83 | 84 | theorem IntSuccEquiv : 85 | (Equiv int int) 86 | by { 87 | {`IntSucc, `IntSuccIsEquiv} 88 | }. 89 | 90 | theorem IntSuccPath : 91 | (path [_] (U 0 kan) int int) 92 | by { 93 | abs x => `(V x int int IntSuccEquiv) 94 | }. 95 | 96 | theorem S1UnivCover : 97 | (-> (. S1' type) (U 0 kan)) 98 | by { 99 | lam x => `(. S1' rec [_] (U 0 kan) x int [x] (@ IntSuccPath x)); 100 | }. 101 | 102 | theorem Loop : 103 | (path [_] (. S1' type) (. S1' base') (. S1' base')) 104 | by { 105 | abs i => `(. S1' loop' i) 106 | }. 107 | 108 | theorem S1LoopToInt : 109 | (-> (path [_] (. S1' type) (. S1' base') (. S1' base')) int) 110 | by { 111 | lam l => `(coe 0~>1 [x] ($ S1UnivCover (@ l x)) (int 0)); 112 | claim eq : (= (. S1' type) (@ l 1) (. S1' base')) by {auto}; 113 | auto; 114 | [ rewrite eq at type; [with x => `($ S1UnivCover x)]; auto 115 | , rewrite eq at left; [with x => `($ S1UnivCover x)]; auto 116 | ] 117 | }. 118 | 119 | theorem S1LoopConcat : 120 | (-> 121 | (path [_] (. S1' type) (. S1' base') (. S1' base')) 122 | (path [_] (. S1' type) (. S1' base') (. S1' base')) 123 | (path [_] (. S1' type) (. S1' base') (. S1' base'))) 124 | by { 125 | lam p q => abs x => `(hcom 0~>1 (. S1' type) (@ p x) [x=0 [_] (. S1' base')] [x=1 [y] (@ q y)]) 126 | }. 127 | 128 | theorem S1LoopInv : 129 | (-> 130 | (path [_] (. S1' type) (. S1' base') (. S1' base')) 131 | (path [_] (. S1' type) (. S1' base') (. S1' base'))) 132 | by { 133 | lam p => abs x => `(hcom 0~>1 (. S1' type) (. S1' base') [x=0 [y] (@ p y)] [x=1 [_] (. S1' base')]) 134 | }. 135 | 136 | theorem IntToS1Loop : 137 | (-> int (path [_] (. S1' type) (. S1' base') (. S1' base'))) 138 | by { 139 | lam i => elim i; 140 | [ with n => elim n; 141 | [ abs _ => `(. S1' base') 142 | , with ih => `($ S1LoopConcat Loop ih) 143 | ] 144 | , with n => elim n; 145 | [ `($ S1LoopInv Loop) 146 | , with ih => `($ S1LoopConcat ($ S1LoopInv Loop) ih) 147 | ] 148 | ] 149 | }. 150 | 151 | theorem Test0 : 152 | (= int ($ S1LoopToInt ($ IntToS1Loop (int 3))) (int 3)) 153 | by { 154 | unfold IntToS1Loop Loop; auto 155 | }. 156 | 157 | theorem Test1 : 158 | (= int ($ S1LoopToInt ($ IntToS1Loop (int -3))) (int -3)) 159 | by { 160 | unfold IntToS1Loop S1LoopInv Loop; auto 161 | }. 162 | -------------------------------------------------------------------------------- /example/omega1s1.prl: -------------------------------------------------------------------------------- 1 | theorem IntPred : 2 | (-> int int) 3 | by { 4 | lam a => elim a; 5 | [ with n => elim n; 6 | [ `(int -1) 7 | , with _ n' => `(pos n') 8 | ] 9 | , with n => `(negsucc (succ n)) 10 | ]; 11 | }. 12 | 13 | theorem IntSucc : 14 | (-> int int) 15 | by { 16 | lam a => elim a; 17 | [ with n => `(pos (succ n)) 18 | , with n => elim n; 19 | [ `(int 0) 20 | , with _ n' => `(negsucc n') 21 | ] 22 | ] 23 | }. 24 | 25 | theorem IntSuccIntPred : 26 | (-> [i : int] (= int ($ IntSucc ($ IntPred i)) i)) 27 | by { 28 | lam i => elim i; 29 | [ with n => elim n; auto 30 | , auto 31 | ] 32 | }. 33 | 34 | theorem IntPredIntSucc : 35 | (-> [i : int] (= int ($ IntPred ($ IntSucc i)) i)) 36 | by { 37 | lam i => elim i; 38 | [ auto 39 | , with n => elim n; auto 40 | ] 41 | }. 42 | 43 | define HasAllPathsTo (#C,#c) = (-> [c' : #C] (path [_] #C c' #c)). 44 | 45 | define IsContr (#C) = (* [c : #C] (HasAllPathsTo #C c)). 46 | 47 | define Fiber (#A,#B,#f,#b) = (* [a : #A] (path [_] #B ($ #f a) #b)). 48 | 49 | define IsEquiv (#A,#B,#f) = (-> [b : #B] (IsContr (Fiber #A #B #f b))). 50 | 51 | define Equiv (#A,#B) = (* [f : (-> #A #B)] (IsEquiv #A #B f)). 52 | 53 | theorem IntSuccIsEquiv : 54 | (IsEquiv int int IntSucc) 55 | by { 56 | lam i => 57 | claim eq : (= int ($ IntSucc ($ IntPred i)) i) by {use IntSuccIntPred [`i]}; 58 | unfold IntSucc IntPred in eq; reduce at left in eq; 59 | { {use IntPred [`i], abs _ => `i}; 60 | auto; assumption 61 | , lam {i',p'} => 62 | claim eq0 : (= int i ($ IntSucc i')) by {`(coe 1~>0 [x] (= int i (@ p' x)) ax)}; 63 | claim eq1 : (= int ($ IntPred i) i') by { 64 | rewrite eq0 at left; 65 | [ with i'' => `($ IntPred i''), `($ IntPredIntSucc i') ]; 66 | auto 67 | }; 68 | 69 | (abs x => 70 | {`($ IntPred i), abs y => `(hcom 1~>y int i [x=0 [y] (@ p' y)] [x=1 [_] i])}); 71 | 72 | auto; unfold IntPred in eq1; reduce at left in eq1; auto; assumption 73 | } 74 | }. 75 | 76 | theorem IntSuccEquiv : 77 | (Equiv int int) 78 | by { 79 | {`IntSucc, `IntSuccIsEquiv} 80 | }. 81 | 82 | theorem IntSuccPath : 83 | (path [_] (U 0 kan) int int) 84 | by { 85 | abs x => `(V x int int IntSuccEquiv) 86 | }. 87 | 88 | theorem S1UnivCover : 89 | (-> S1 (U 0 kan)) 90 | by { 91 | lam x => `(S1-rec [_] (U 0 kan) x int [x] (@ IntSuccPath x)); 92 | }. 93 | 94 | theorem Loop : 95 | (path [_] S1 base base) 96 | by { 97 | abs i => `(loop i) 98 | }. 99 | 100 | theorem S1LoopToInt : 101 | (-> (path [_] S1 base base) int) 102 | by { 103 | lam l => `(coe 0~>1 [x] ($ S1UnivCover (@ l x)) (int 0)); 104 | claim eq : (= S1 (@ l 1) base) by {auto}; 105 | auto; 106 | [ rewrite eq at type; [with x => `($ S1UnivCover x)]; auto 107 | , rewrite eq at left; [with x => `($ S1UnivCover x)]; auto 108 | ] 109 | }. 110 | 111 | theorem S1LoopConcat : 112 | (-> 113 | (path [_] S1 base base) 114 | (path [_] S1 base base) 115 | (path [_] S1 base base)) 116 | by { 117 | lam p q => abs x => `(hcom 0~>1 S1 (@ p x) [x=0 [_] base] [x=1 [y] (@ q y)]) 118 | }. 119 | 120 | theorem S1LoopInv : 121 | (-> 122 | (path [_] S1 base base) 123 | (path [_] S1 base base)) 124 | by { 125 | lam p => abs x => `(hcom 0~>1 S1 base [x=0 [y] (@ p y)] [x=1 [_] base]) 126 | }. 127 | 128 | theorem IntToS1Loop : 129 | (-> int (path [_] S1 base base)) 130 | by { 131 | lam i => elim i; 132 | [ with n => elim n; 133 | [ abs _ => `base 134 | , with ih => `($ S1LoopConcat Loop ih) 135 | ] 136 | , with n => elim n; 137 | [ `($ S1LoopInv Loop) 138 | , with ih => `($ S1LoopConcat ($ S1LoopInv Loop) ih) 139 | ] 140 | ] 141 | }. 142 | 143 | theorem Test0 : 144 | (= int ($ S1LoopToInt ($ IntToS1Loop (int 3))) (int 3)) 145 | by { 146 | unfold IntToS1Loop Loop; auto 147 | }. 148 | 149 | theorem Test1 : 150 | (= int ($ S1LoopToInt ($ IntToS1Loop (int -3))) (int -3)) 151 | by { 152 | unfold IntToS1Loop S1LoopInv Loop; auto 153 | }. 154 | -------------------------------------------------------------------------------- /example/theorem-of-choice.prl: -------------------------------------------------------------------------------- 1 | theorem Choice(#i:lvl) : 2 | (-> 3 | [a b : (U #i)] 4 | [r : (-> a b (U #i))] 5 | [f : (-> [x : a] (* [y : b] ($ r x y)))] 6 | (* 7 | [f : (-> a b)] 8 | (-> [x : a] ($ r x ($ f x))))) 9 | by { 10 | lam a b r f => 11 | {lam x => let {y,_} = f [`x]; `y, 12 | lam x => let {_,z} = f [`x]; `z}; 13 | 14 | inversion; with _ aux0 => reduce at left in aux0; auto; assumption 15 | }. 16 | 17 | // print Choice. 18 | -------------------------------------------------------------------------------- /example/tutorial1.prl: -------------------------------------------------------------------------------- 1 | // POPL 2018 tutorial, part one 2 | // January 8, 2018 3 | 4 | quit. 5 | 6 | theorem Not : 7 | (-> bool bool) 8 | by { 9 | ? 10 | }. 11 | 12 | quit. 13 | 14 | print Not. 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | theorem NotNot : 35 | (-> 36 | [b : bool] 37 | (= bool ($ Not ($ Not b)) b)) 38 | by { 39 | ? 40 | }. 41 | 42 | quit. 43 | 44 | print NotNot. 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | theorem RespectEquality : 65 | (-> 66 | [family : (-> [b : bool] (U 0))] 67 | [b : bool] 68 | ($ family b) 69 | ($ family ($ Not ($ Not b)))) 70 | by { 71 | ? 72 | }. 73 | 74 | quit. 75 | 76 | print RespectEquality. 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | theorem EqualityIrrelevant : 97 | (= 98 | (-> [b : bool] (= bool ($ Not ($ Not b)) b)) 99 | NotNot 100 | (lam [b] ax)) 101 | by { 102 | ? 103 | }. 104 | 105 | quit. 106 | 107 | print EqualityIrrelevant. 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | theorem FunToPair : 128 | (-> 129 | [ty : (U 0 kan)] 130 | (-> bool ty) 131 | (* ty ty)) 132 | by { 133 | lam ty fun => 134 | {`($ fun tt), `($ fun ff)} 135 | }. 136 | 137 | // {{{ Univalence 138 | 139 | define HasAllPathsTo (#C,#c) = (-> [c' : #C] (path [_] #C c' #c)). 140 | define IsContr (#C) = (* [c : #C] (HasAllPathsTo #C c)). 141 | define Fiber (#A,#B,#f,#b) = (* [a : #A] (path [_] #B ($ #f a) #b)). 142 | define IsEquiv (#A,#B,#f) = (-> [b : #B] (IsContr (Fiber #A #B #f b))). 143 | define Equiv (#A,#B) = (* [f : (-> #A #B)] (IsEquiv #A #B f)). 144 | 145 | theorem WeakConnection(#l:lvl) : 146 | (-> 147 | [ty : (U #l hcom)] 148 | [a b : ty] 149 | [p : (path [_] ty a b)] 150 | (path [i] (path [_] ty (@ p i) b) p (abs [_] b))) 151 | by { 152 | (lam ty a b p => 153 | abs i j => 154 | `(hcom 1~>0 ty b 155 | [i=0 [k] (hcom 0~>j ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])] 156 | [i=1 [k] (hcom 0~>1 ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])] 157 | [j=0 [k] (hcom 0~>i ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])] 158 | [j=1 [k] (hcom 0~>1 ty (@ p k) [k=0 [w] (@ p w)] [k=1 [_] b])])) 159 | }. 160 | 161 | theorem FunToPairIsEquiv : 162 | (-> 163 | [ty : (U 0 kan)] 164 | (IsEquiv (-> bool ty) (* ty ty) ($ FunToPair ty))) 165 | by { 166 | lam ty pair => 167 | { { lam b => if b then `(!proj1 pair) else `(!proj2 pair) 168 | , abs _ => `pair } 169 | , unfold Fiber; 170 | lam {fun,p} => 171 | fresh x:dim -> refine path/intro; [ 172 | {lam b => if b then `(!proj1 (@ p x)) else `(!proj2 (@ p x)), 173 | abs y => 174 | `(@ ($ (WeakConnection #lvl{0}) (* ty ty) ($ FunToPair ty fun) pair p) x y) 175 | } 176 | ]; 177 | 178 | [ symmetry; refine record/eq/tuple; 179 | [ refine fun/eq/eta; #1{auto}; auto; symmetry; 180 | claim p/0 : (@ p 0) = ($ FunToPair ty fun) in (* ty ty) by { auto }; 181 | auto; 182 | [ fresh h -> rewrite p/0; [`(= ty (! proj1 h) ($ fun tt))] 183 | , fresh h -> rewrite p/0; [`(= ty (! proj2 h) ($ fun ff))] 184 | ] 185 | ]; auto 186 | 187 | , refine record/eq/tuple; 188 | [ auto 189 | , refine path/eq/abs; 190 | [ symmetry; unfold WeakConnection; 191 | reduce at right; 192 | refine record/eq/eta; #1 {auto}; 193 | refine record/eq/tuple; #2 {auto}; 194 | [ symmetry; refine hcom/eq/tube; [auto, auto, auto, auto, auto, auto, auto, auto] 195 | , symmetry; refine hcom/eq/tube; [auto, auto, auto, auto, auto, auto, auto, auto] 196 | ] 197 | ] 198 | ]; 199 | auto 200 | ] 201 | } 202 | }. 203 | 204 | theorem PathFunToPair : 205 | (-> 206 | [ty : (U 0 kan)] 207 | (path [_] (U 0 kan) (-> bool ty) (* ty ty))) 208 | by { 209 | lam ty => abs x => 210 | `(V x (-> bool ty) (* ty ty) 211 | (tuple [proj1 ($ FunToPair ty)] [proj2 ($ FunToPairIsEquiv ty)])) 212 | }. 213 | 214 | // }}} 215 | 216 | quit. 217 | 218 | print PathFunToPair. 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | theorem RespectPaths : 239 | (-> 240 | [ty : (U 0 kan)] 241 | (-> bool ty) 242 | (* ty ty)) 243 | by { 244 | lam ty fun => 245 | `(coe 0~>1 [x] (@ ($ PathFunToPair ty) x) fun) 246 | }. 247 | 248 | quit. 249 | 250 | print RespectPaths. 251 | 252 | 253 | 254 | 255 | 256 | 257 | 258 | 259 | 260 | 261 | 262 | 263 | 264 | 265 | 266 | 267 | 268 | 269 | 270 | theorem ComputeCoercion : 271 | (= 272 | (* bool bool) 273 | ($ RespectPaths bool (lam [b] b)) 274 | (tuple [proj1 tt] [proj2 ff])) 275 | by { 276 | auto 277 | }. 278 | -------------------------------------------------------------------------------- /example/tutorial2.prl: -------------------------------------------------------------------------------- 1 | // POPL 2018 tutorial, part two 2 | // January 8, 2018 3 | 4 | quit. 5 | 6 | theorem Refl : 7 | (-> 8 | [ty : (U 0)] 9 | [a : ty] 10 | (path [_] ty a a)) 11 | by { 12 | ? 13 | }. 14 | 15 | quit. 16 | 17 | print Refl. 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | theorem FunPath : 38 | (-> 39 | [a b : (U 0)] 40 | [f g : (-> a b)] 41 | (path [_] (-> a b) f g) 42 | [arg : a] 43 | (path [_] b ($ f arg) ($ g arg))) 44 | by { 45 | ? 46 | }. 47 | 48 | quit. 49 | 50 | print FunPath. 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | theorem PathInv : 71 | (-> 72 | [ty : (U 0 kan)] 73 | [a b : ty] 74 | [p : (path [_] ty a b)] 75 | (path [_] ty b a)) 76 | by { 77 | // a -- x 78 | // ------- | 79 | // | | y 80 | // p | | a 81 | // | | 82 | // b .... a 83 | 84 | ? 85 | }. 86 | 87 | quit. 88 | 89 | print PathInv. 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | theorem PathConcat : 110 | (-> 111 | [ty : (U 0 kan)] 112 | [a b c : ty] 113 | [p : (path [_] ty a b)] 114 | [q : (path [_] ty b c)] 115 | (path [_] ty a c)) 116 | by { 117 | // p -- x 118 | // ------- | 119 | // | | y 120 | // a | | q 121 | // | | 122 | // a .... c 123 | 124 | ? 125 | }. 126 | 127 | quit. 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | theorem InvRefl : 148 | (-> 149 | [ty : (U 0 kan)] 150 | [a : ty] 151 | (path 152 | [_] (path [_] ty a a) 153 | ($ PathInv ty a a (abs [_] a)) 154 | (abs [_] a))) 155 | by { 156 | // See diagram! 157 | lam ty a => 158 | abs x y => 159 | `(hcom 0~>1 ty a 160 | [x=0 [z] (hcom 0~>z ty a [y=0 [_] a] [y=1 [_] a])] 161 | [x=1 [_] a] 162 | [y=0 [_] a] 163 | [y=1 [_] a]) 164 | }. 165 | 166 | quit. 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | // Although the path type is not defined by refl and J 187 | // (as in HoTT), we can still define J using hcom + coe. 188 | // The #l is an example of a parametrized definition. 189 | theorem J(#l:lvl) : 190 | (-> 191 | [ty : (U #l kan)] 192 | [a : ty] 193 | [fam : (-> [x : ty] (path [_] ty a x) (U #l kan))] 194 | [d : ($ fam a (abs [_] a))] 195 | [x : ty] 196 | [p : (path [_] ty a x)] 197 | ($ fam x p)) 198 | by { 199 | lam ty a fam d x p => 200 | `(coe 0~>1 201 | [i] ($ fam 202 | (hcom 0~>1 ty a [i=0 [_] a] [i=1 [j] (@ p j)]) 203 | (abs [j] (hcom 0~>j ty a [i=0 [_] a] [i=1 [j] (@ p j)]))) d) 204 | }. 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | theorem JInv : 227 | (-> 228 | [ty : (U 0 kan)] 229 | [a b : ty] 230 | [p : (path [_] ty a b)] 231 | (path [_] ty b a)) 232 | by { 233 | lam ty a b p => 234 | exact 235 | ($ (J #lvl{0}) 236 | ty 237 | a 238 | (lam [b _] (path [_] ty b a)) 239 | (abs [_] a) 240 | b 241 | p); 242 | ? 243 | }. 244 | -------------------------------------------------------------------------------- /script/doc.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | pushd doc 3 | latexmk -pdf definition.tex 4 | popd 5 | -------------------------------------------------------------------------------- /script/go-nj.sml: -------------------------------------------------------------------------------- 1 | val success = CM.make "src/frontend.cm"; 2 | val () = if success then () else OS.Process.exit OS.Process.failure; 3 | SMLofNJ.exportFn ("bin/.heapimg", Main.main); 4 | -------------------------------------------------------------------------------- /script/mkexec.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Batch File Creator 4 | # 5 | # Arguments: 6 | # $1 = SMLNJ runtime 7 | # $2 = Directory of binaries and heap image 8 | # $3 = Name of executable (e.g. celf) 9 | mkdir -p "$2/bin" 10 | cat > "$2/bin/$3" </dev/null 2>&1 ; then 9 | PROBLEM=1 10 | echo "FAIL: $f should succeed!" 11 | else 12 | echo "Checked $f" 13 | fi 14 | done 15 | 16 | # Ensure that failing tests fail 17 | for f in test/failure/*.prl ; do 18 | if $REDPRL $f >/dev/null 2>&1 ; then 19 | PROBLEM=1 20 | echo "FAIL: $f should fail!" 21 | fi 22 | done 23 | 24 | if [ $PROBLEM -eq 0 ] ; then 25 | echo "All tests ran as expected!" 26 | fi 27 | 28 | exit $PROBLEM 29 | -------------------------------------------------------------------------------- /script/smlnj.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | mkdir -p ./bin 4 | sml script/go-nj.sml < /dev/null || exit 1 5 | script/mkexec.sh `which sml` `pwd` redprl || exit 1 6 | -------------------------------------------------------------------------------- /script/tc-mlton.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | LIBS=$(pwd)/lib 4 | 5 | mlyacc src/redprl/redprl.grm 6 | mllex src/redprl/redprl.lex 7 | 8 | mkdir -p bin 9 | mlton -prefer-abs-paths true -show-def-use frontend.du -stop tc -verbose 1 -mlb-path-var "LIBS $LIBS" -output bin/redprl src/frontend.mlb 10 | -------------------------------------------------------------------------------- /script/test-mlton.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Requires 'chronic' and 'ts' from the 'moreutils' package. 4 | 5 | set -o pipefail 6 | 7 | echo "Building RedPRL with MLton..." 8 | if [ -n "${TRAVIS}" ]; then 9 | ./script/mlton.sh || exit 1; 10 | else 11 | chronic ./script/mlton.sh || { echo "Build failed!"; exit 1; }; 12 | fi 13 | echo "Done!" 14 | 15 | exec ./script/run-tests.sh | ts -i "[%.ss]" 16 | -------------------------------------------------------------------------------- /script/test-no-build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Requires 'ts' from the 'moreutils' package. 4 | 5 | set -o pipefail 6 | exec ./script/run-tests.sh | ts -i "[%.ss]" 7 | -------------------------------------------------------------------------------- /script/test-smlnj.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Requires 'chronic' and 'ts' from the 'moreutils' package. 4 | 5 | set -o pipefail 6 | 7 | echo "Building RedPRL with SML/NJ..." 8 | if [ -n "${TRAVIS}" ]; then 9 | ./script/smlnj.sh || exit 1; 10 | else 11 | chronic ./script/smlnj.sh || { echo "Build failed!"; exit 1; }; 12 | fi 13 | echo "Done!" 14 | 15 | exec ./script/run-tests.sh | ts -i "[%.ss]" 16 | -------------------------------------------------------------------------------- /script/test-sphinx.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -o pipefail 4 | 5 | echo "Building the documentation of RedPRL with Sphinx..." 6 | cd doc; 7 | if [ -n "${TRAVIS}" ]; then 8 | make SPHINXOPTS="-n -W" html || exit 1; 9 | else 10 | make html || exit 1; 11 | fi 12 | echo "Done!" 13 | -------------------------------------------------------------------------------- /sml.json: -------------------------------------------------------------------------------- 1 | { 2 | "cm": { 3 | "make/onSave": "src/development.cm" 4 | } 5 | } -------------------------------------------------------------------------------- /src/cmlib.cm: -------------------------------------------------------------------------------- 1 | Library 2 | signature DICT 3 | signature ORDERED 4 | signature SET 5 | functor SplayDict 6 | functor SplaySet 7 | functor HashTable 8 | structure StringOrdered 9 | structure StringListDict 10 | functor ListSet 11 | structure IntHashable 12 | structure Sum 13 | structure Susp 14 | structure Pos 15 | structure Coord 16 | is 17 | $libs/cmlib/cmlib.cm 18 | -------------------------------------------------------------------------------- /src/cmlib.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(LIBS)/cmlib/cmlib.mlb 3 | in 4 | signature DICT 5 | signature ORDERED 6 | signature SET 7 | functor SplayDict 8 | functor SplaySet 9 | functor HashTable 10 | structure StringOrdered 11 | structure IntHashable 12 | structure StringListDict 13 | functor ListSet 14 | structure Sum 15 | structure Susp 16 | structure Pos 17 | structure Coord 18 | end 19 | 20 | -------------------------------------------------------------------------------- /src/debug.cm: -------------------------------------------------------------------------------- 1 | Library 2 | signature DEBUG 3 | structure Debug 4 | is 5 | $smlnj-tdp/back-trace.cm 6 | debug/debug.sig 7 | debug/debug_smlnj.sml 8 | -------------------------------------------------------------------------------- /src/debug.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | debug/debug.sig 4 | debug/debug_mlton.sml 5 | in 6 | signature DEBUG 7 | structure Debug 8 | end 9 | -------------------------------------------------------------------------------- /src/debug/debug.sig: -------------------------------------------------------------------------------- 1 | signature DEBUG = 2 | sig 3 | val wrap : (unit -> 'a) -> 'a 4 | end 5 | -------------------------------------------------------------------------------- /src/debug/debug_mlton.sml: -------------------------------------------------------------------------------- 1 | structure Debug :> DEBUG = 2 | struct 3 | fun wrap t = t () 4 | end 5 | -------------------------------------------------------------------------------- /src/debug/debug_smlnj.sml: -------------------------------------------------------------------------------- 1 | structure Debug :> DEBUG = 2 | struct 3 | val wrap = BackTrace.monitor 4 | end 5 | -------------------------------------------------------------------------------- /src/development.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | redprl.cm (bind:(anchor:libs value:../lib/)) 4 | frontend/frontend.sml 5 | -------------------------------------------------------------------------------- /src/frontend.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/basis.cm 3 | ../lib/sml-final-pretty-printer/final-pretty-printer.cm 4 | redprl.cm (bind:(anchor:libs value:../lib/)) 5 | debug.cm 6 | frontend/frontend.sml 7 | frontend/main.sml 8 | -------------------------------------------------------------------------------- /src/frontend.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | $(LIBS)/sml-final-pretty-printer/final-pretty-printer.mlb 4 | redprl.mlb 5 | debug.mlb 6 | frontend/frontend.sml 7 | frontend/main.sml 8 | frontend/main-mlton.sml 9 | in 10 | structure Frontend 11 | structure Main 12 | structure MainMLton 13 | end 14 | -------------------------------------------------------------------------------- /src/frontend/frontend.sml: -------------------------------------------------------------------------------- 1 | structure Frontend = 2 | struct 3 | fun stringreader s = 4 | let 5 | val pos = ref 0 6 | val remainder = ref (String.size s) 7 | fun min(a, b) = if a < b then a else b 8 | in 9 | fn n => 10 | let 11 | val m = min(n, !remainder) 12 | val s = String.substring(s, !pos, m) 13 | val () = pos := !pos + m 14 | val () = remainder := !remainder - m 15 | in 16 | s 17 | end 18 | end 19 | 20 | local 21 | structure E = RedPrlError 22 | in 23 | fun error fileName (s, pos, pos') = 24 | E.raiseAnnotatedError 25 | (Pos.pos (pos fileName) (pos' fileName), 26 | E.GENERIC [Fpp.text s]) 27 | end 28 | 29 | local 30 | open Signature 31 | in 32 | (* TODO: more efficient, lol *) 33 | fun processElt sign elt = 34 | List.rev (elt :: List.rev sign) 35 | end 36 | 37 | fun logExn exn = 38 | RedPrlLog.print RedPrlLog.FAIL (RedPrlError.annotation exn, RedPrlError.format exn) 39 | 40 | local 41 | val EOF = RedPrlLrVals.Tokens.EOF (Coord.init, Coord.init) 42 | val DEF = RedPrlLrVals.Tokens.DEFINE (Coord.init, Coord.init) 43 | val THM = RedPrlLrVals.Tokens.THEOREM (Coord.init, Coord.init) 44 | val TAC = RedPrlLrVals.Tokens.TACTIC (Coord.init, Coord.init) 45 | val PRINT = RedPrlLrVals.Tokens.PRINT (Coord.init, Coord.init) 46 | val EXTRACT = RedPrlLrVals.Tokens.EXTRACT (Coord.init, Coord.init) 47 | val QUIT = RedPrlLrVals.Tokens.QUIT (Coord.init, Coord.init) 48 | val DOT = RedPrlLrVals.Tokens.DOT (Coord.init, Coord.init) 49 | 50 | fun isBeginElt tok = 51 | RedPrlParser.Token.sameToken (tok, THM) orelse 52 | RedPrlParser.Token.sameToken (tok, DEF) orelse 53 | RedPrlParser.Token.sameToken (tok, TAC) orelse 54 | RedPrlParser.Token.sameToken (tok, PRINT) orelse 55 | RedPrlParser.Token.sameToken (tok, EXTRACT) orelse 56 | RedPrlParser.Token.sameToken (tok, QUIT) 57 | 58 | fun isEof tok = 59 | RedPrlParser.Token.sameToken (tok, EOF) 60 | 61 | fun isDot tok = 62 | RedPrlParser.Token.sameToken (tok, DOT) 63 | 64 | fun getPos (RedPrlParser.Token.TOKEN (_, (_, c_start, c_end))) = 65 | (c_start, c_end) 66 | 67 | fun skipDot fileName lexer = 68 | let 69 | val (next_tok, lexer') = RedPrlParser.Stream.get lexer 70 | in 71 | if isDot next_tok 72 | then lexer' 73 | else 74 | let 75 | val (c1, c2) = getPos next_tok 76 | in 77 | error fileName ("Expected '.' after element.", c1, c2) 78 | end 79 | end 80 | 81 | fun parseElt fileName lexer = 82 | let 83 | val (elt, lexer) = RedPrlParser.parse (0, lexer, error fileName, fileName) 84 | val lexer = skipDot fileName lexer 85 | in 86 | (elt, lexer) 87 | end 88 | 89 | fun skipToBeginElt lexer = 90 | let 91 | val (next_tok, lexer') = RedPrlParser.Stream.get lexer 92 | in 93 | if isEof next_tok orelse isBeginElt next_tok 94 | then lexer 95 | else skipToBeginElt lexer' 96 | end 97 | 98 | fun recover lexer = 99 | let 100 | val (_, lexer) = RedPrlParser.Stream.get lexer 101 | in 102 | skipToBeginElt lexer 103 | end 104 | 105 | fun doElt fileName lexer sign = 106 | let 107 | val (elt, lexer) = parseElt fileName lexer 108 | in 109 | (true, processElt sign elt, lexer) 110 | end 111 | handle exn => (logExn exn; (false, sign, recover lexer)) 112 | in 113 | fun parseSig fileName buf = 114 | let 115 | fun loop acc lexer sign = 116 | let 117 | val (next_tok, _) = RedPrlParser.Stream.get lexer 118 | in 119 | if RedPrlParser.Token.sameToken (next_tok, EOF) orelse RedPrlParser.Token.sameToken (next_tok, QUIT) 120 | then (acc, sign) 121 | else 122 | let 123 | val (err, sign, lexer) = doElt fileName lexer sign 124 | in 125 | loop (acc andalso err) lexer sign 126 | end 127 | end 128 | 129 | val lexer = RedPrlParser.makeLexer (stringreader buf) fileName 130 | in 131 | loop true lexer [] 132 | end 133 | end 134 | 135 | fun processBuffer fileName buf = 136 | let 137 | val (noParseErrors, sign) = parseSig fileName buf 138 | in 139 | Signature.checkSrcSig sign andalso noParseErrors 140 | end 141 | handle exn => (logExn exn; false) 142 | 143 | fun processStream fileName stream = 144 | let 145 | val input = TextIO.inputAll stream 146 | in 147 | processBuffer fileName input 148 | end 149 | 150 | fun processFile fileName = 151 | processStream fileName (TextIO.openIn fileName) 152 | end 153 | -------------------------------------------------------------------------------- /src/frontend/main-mlton.sml: -------------------------------------------------------------------------------- 1 | structure MainMLton = 2 | struct 3 | val _ = 4 | OS.Process.exit 5 | (Main.main 6 | (CommandLine.name (), 7 | CommandLine.arguments ())) 8 | end 9 | -------------------------------------------------------------------------------- /src/frontend/main.sml: -------------------------------------------------------------------------------- 1 | structure Main = 2 | struct 3 | datatype mode = 4 | PRINT_DEVELOPMENT of string list 5 | | FROM_STDIN of string option 6 | | HELP 7 | 8 | local 9 | fun extractArg n x = 10 | case explode (String.extract (x, n, NONE)) of 11 | #"=" :: rest => SOME (implode rest) 12 | | _ => NONE 13 | fun setWidth x = Option.app (fn n => Config.maxWidth := n) (Option.mapPartial Int.fromString x) 14 | fun go [] mode = mode 15 | | go ("--help" :: xs) _ = go xs (SOME HELP) 16 | | go ("--trace" :: xs) mode = (Config.printTrace := true; go xs mode) 17 | | go (x :: xs) mode = 18 | if String.isPrefix "--from-stdin" x 19 | then go xs (SOME (FROM_STDIN (extractArg (String.size "--from-stdin") x))) 20 | else if String.isPrefix "--width=" x 21 | then (setWidth (extractArg (String.size "--width") x); go xs mode) 22 | else 23 | (case mode of 24 | NONE => go xs (SOME (PRINT_DEVELOPMENT [x])) 25 | | SOME (PRINT_DEVELOPMENT files) => go xs (SOME (PRINT_DEVELOPMENT (files @ [x]))) 26 | | SOME _ => go xs mode) 27 | in 28 | fun getMode args = Option.getOpt (go args NONE, HELP) 29 | end 30 | 31 | val helpMessage = 32 | " A proof assistant for Computational Type Theory \n" ^ 33 | " `. \n" ^ 34 | " `--` %%%%%%% %%%%%%%% %%%%%%% %%%%%%% %%%%%%% %% \n" ^ 35 | " `-:::. -:- %% %% %% %% %% %% %% %% %% %% \n" ^ 36 | " `-::::. -:- %% %% %% %% %% %% %% %% %% %% \n" ^ 37 | " .::-`-::. ::. %%%%%%% %%%%%% %% %% %%%%%%% %%%%%%% %% \n" ^ 38 | " `-::. ::- %% %% %% %% %% %% %% %% %% \n" ^ 39 | " `:::.-::` %% %% %% %% %% %% %% %% %% \n" ^ 40 | " `-:::-...-::::. %% %% %%%%%%%% %%%%%%% %% %% %% %%%%%%%% \n" ^ 41 | " .::-` .-:::::-:::. \n" ^ 42 | " .::. .::. ~ Uphold Cubical Thought! ~ \n" ^ 43 | "\nUsage\n" ^ 44 | " redprl ...\n" ^ 45 | " redprl --help\n" ^ 46 | "Options\n" ^ 47 | " --help Print this message\n" ^ 48 | " --trace Print proof traces with goals\n" ^ 49 | " --width=cols Set output width to cols (default: 80)\n" ^ 50 | " --from-stdin[=filename] Read signature from stdin with optional diagnostic filename\n" 51 | 52 | fun toExitStatus b = if b then OS.Process.success else OS.Process.failure 53 | 54 | fun main (_, args) = 55 | Debug.wrap (fn _ => 56 | case getMode args of 57 | PRINT_DEVELOPMENT files => toExitStatus (List.all Frontend.processFile files) 58 | | FROM_STDIN ofile => toExitStatus (Frontend.processStream (Option.getOpt (ofile, "")) TextIO.stdIn) 59 | | HELP => (print helpMessage; OS.Process.success)) 60 | handle E => 61 | (FppRenderPlainText.render TextIO.stdErr (FinalPrinter.execPP (RedPrlError.format E)); 62 | OS.Process.failure) 63 | end 64 | -------------------------------------------------------------------------------- /src/redprl.cm: -------------------------------------------------------------------------------- 1 | Library 2 | structure RedPrlParser 3 | structure Coord 4 | structure Pos 5 | structure Signature 6 | structure RedPrlLog 7 | structure RedPrlError 8 | structure RedPrlLrVals 9 | structure FinalPrinter 10 | structure Fpp 11 | functor RedPrlMachine 12 | structure Config 13 | is 14 | $/basis.cm 15 | $/ml-yacc-lib.cm 16 | 17 | cmlib.cm 18 | $libs/sml-cats/cats.cm 19 | $libs/sml-telescopes/telescopes.cm 20 | $libs/sml-typed-abts/abt.cm 21 | $libs/sml-typed-abts/abt-unify.cm 22 | $libs/sml-typed-abts/basis/basis.cm 23 | $libs/sml-dependent-lcf/dependent_lcf.cm 24 | $libs/sml-dependent-lcf/lcf_abt.cm 25 | $libs/sml-final-pretty-printer/final-pretty-printer.cm 26 | 27 | 28 | redprl/tactical.fun 29 | 30 | 31 | debug.cm 32 | 33 | redprl/list_util.sml 34 | redprl/option_util.sml 35 | 36 | redprl/fpp.sml 37 | 38 | redprl/ml_id.sig 39 | redprl/ml_id.sml 40 | 41 | redprl/syntax/accessor.sig 42 | redprl/syntax/accessor.sml 43 | redprl/syntax/selector.sig 44 | redprl/syntax/selector.sml 45 | 46 | redprl/syntax/sort.sig 47 | redprl/syntax/sort.sml 48 | redprl/syntax/kind.sml 49 | redprl/syntax/variance.sig 50 | redprl/syntax/variance.sml 51 | redprl/syntax/operator.sig 52 | redprl/syntax/operator.sml 53 | redprl/syntax/abt.sml 54 | redprl/syntax/univ_level.sig 55 | redprl/syntax/univ_level.sml 56 | redprl/syntax/view.sml 57 | redprl/syntax/variable_kit.sml 58 | 59 | redprl/config.sml 60 | 61 | redprl/pretty.sml 62 | 63 | redprl/error.sig 64 | redprl/error.sml 65 | 66 | redprl/syntax/atomic_judgment.sig 67 | redprl/syntax/atomic_judgment.sml 68 | 69 | redprl/syntax/sequent.sig 70 | redprl/syntax/sequent.sml 71 | redprl/syntax/restriction.sml 72 | 73 | redprl/judgment.sml 74 | 75 | redprl/log.sig 76 | redprl/log.sml 77 | 78 | redprl/syntax/assert.sml 79 | redprl/inductive_spec.sig 80 | redprl/inductive_spec.sml 81 | redprl/mini_signature.sig 82 | 83 | redprl/metalanguage/type.sig 84 | redprl/metalanguage/syntax.sml 85 | 86 | redprl/metalanguage/resolver.sig 87 | redprl/metalanguage/elaborate.sig 88 | redprl/metalanguage/semantics.sig 89 | redprl/metalanguage/evaluate.sig 90 | 91 | redprl/metalanguage/type.sml 92 | redprl/metalanguage/resolver.fun 93 | redprl/metalanguage/elaborate.fun 94 | redprl/metalanguage/semantics.sml 95 | redprl/metalanguage/evaluate.sml 96 | 97 | redprl/signature.sig 98 | redprl/signature.sml 99 | redprl/tactic_elaborator.fun 100 | 101 | redprl/redprl.lex 102 | redprl/redprl.grm 103 | 104 | redprl/redprl_lexer.sml 105 | redprl/redprl_parser.sml 106 | 107 | redprl/machine.sig 108 | redprl/machine.fun 109 | 110 | redprl/refiner_kit.fun 111 | redprl/refiner_composition_kit.fun 112 | redprl/refiner_types.fun 113 | redprl/refiner_misc.fun 114 | redprl/refiner.sig 115 | redprl/refiner.fun 116 | redprl/lcf.sml 117 | -------------------------------------------------------------------------------- /src/redprl.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "forceUsed" 3 | "warnUnused true" 4 | in 5 | local 6 | $(SML_LIB)/basis/basis.mlb 7 | $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb 8 | 9 | cmlib.mlb 10 | 11 | $(LIBS)/sml-cats/cats.mlb 12 | $(LIBS)/sml-telescopes/telescopes.mlb 13 | $(LIBS)/sml-typed-abts/abt.mlb 14 | $(LIBS)/sml-typed-abts/abt-unify.mlb 15 | $(LIBS)/sml-typed-abts/basis/basis.mlb 16 | $(LIBS)/sml-dependent-lcf/dependent_lcf.mlb 17 | $(LIBS)/sml-dependent-lcf/lcf_abt.mlb 18 | $(LIBS)/sml-final-pretty-printer/final-pretty-printer.mlb 19 | 20 | 21 | debug.mlb 22 | 23 | redprl/list_util.sml 24 | redprl/option_util.sml 25 | 26 | redprl/config.sml 27 | 28 | redprl/fpp.sml 29 | 30 | 31 | redprl/ml_id.sig 32 | redprl/ml_id.sml 33 | 34 | 35 | redprl/syntax/variance.sig 36 | redprl/syntax/variance.sml 37 | redprl/syntax/accessor.sig 38 | redprl/syntax/accessor.sml 39 | redprl/syntax/selector.sig 40 | redprl/syntax/selector.sml 41 | redprl/syntax/sort.sig 42 | redprl/syntax/sort.sml 43 | redprl/syntax/kind.sml 44 | redprl/syntax/operator.sig 45 | redprl/syntax/operator.sml 46 | redprl/syntax/abt.sml 47 | redprl/pretty.sml 48 | 49 | 50 | redprl/error.sig 51 | redprl/error.sml 52 | redprl/syntax/univ_level.sig 53 | redprl/syntax/univ_level.sml 54 | redprl/syntax/view.sml 55 | redprl/syntax/variable_kit.sml 56 | redprl/syntax/atomic_judgment.sig 57 | redprl/syntax/atomic_judgment.sml 58 | redprl/syntax/sequent.sig 59 | redprl/syntax/sequent.sml 60 | redprl/syntax/restriction.sml 61 | 62 | redprl/judgment.sml 63 | 64 | redprl/lcf.sml 65 | 66 | redprl/log.sig 67 | redprl/log.sml 68 | 69 | 70 | 71 | redprl/tactical.fun 72 | 73 | redprl/syntax/assert.sml 74 | redprl/inductive_spec.sig 75 | redprl/inductive_spec.sml 76 | redprl/mini_signature.sig 77 | 78 | ann 79 | "nonexhaustiveMatch ignore" 80 | in 81 | redprl/machine.sig 82 | redprl/machine.fun 83 | redprl/refiner_kit.fun 84 | redprl/refiner_composition_kit.fun 85 | redprl/refiner_types.fun 86 | redprl/refiner_misc.fun 87 | redprl/refiner.sig 88 | redprl/refiner.fun 89 | redprl/tactic_elaborator.fun 90 | end 91 | 92 | 93 | redprl/metalanguage/type.sig 94 | redprl/metalanguage/type.sml 95 | redprl/metalanguage/syntax.sml 96 | 97 | redprl/metalanguage/resolver.sig 98 | redprl/metalanguage/elaborate.sig 99 | redprl/metalanguage/semantics.sig 100 | redprl/metalanguage/evaluate.sig 101 | 102 | redprl/metalanguage/resolver.fun 103 | redprl/metalanguage/elaborate.fun 104 | redprl/metalanguage/semantics.sml 105 | redprl/metalanguage/evaluate.sml 106 | 107 | redprl/signature.sig 108 | redprl/signature.sml 109 | 110 | ann 111 | "warnUnused false" 112 | in 113 | redprl/redprl.grm.sig 114 | redprl/redprl.grm.sml 115 | redprl/redprl.lex.sml 116 | end 117 | 118 | redprl/redprl_lexer.sml 119 | redprl/redprl_parser.sml 120 | 121 | in 122 | structure RedPrlParser 123 | structure Coord 124 | structure Pos 125 | structure Signature 126 | structure RedPrlLog 127 | structure RedPrlError 128 | structure RedPrlLrVals 129 | structure FinalPrinter 130 | structure Fpp 131 | structure Config 132 | end 133 | end 134 | -------------------------------------------------------------------------------- /src/redprl/config.sml: -------------------------------------------------------------------------------- 1 | structure Config = 2 | struct 3 | val maxWidth : int ref = ref 80 4 | val printTrace : bool ref = ref false 5 | end 6 | -------------------------------------------------------------------------------- /src/redprl/error.sig: -------------------------------------------------------------------------------- 1 | structure RedPrlErrorData = 2 | struct 3 | datatype error = 4 | IMPOSSIBLE of Fpp.doc 5 | | INVALID_ATOMIC_JUDGMENT of Fpp.doc 6 | | INVALID_NATURAL_NUMBER of Fpp.doc 7 | | INVALID_DIMENSION of Fpp.doc 8 | | INVALID_LEVEL of Fpp.doc 9 | | NOT_APPLICABLE of Fpp.doc * Fpp.doc 10 | | UNIMPLEMENTED of Fpp.doc 11 | | GENERIC of Fpp.doc list 12 | | INCORRECT_ARITY of RedPrlOperator.t 13 | end 14 | 15 | signature REDPRL_ERROR = 16 | sig 17 | datatype error = datatype RedPrlErrorData.error 18 | 19 | val addPosition : Pos.t option * exn -> exn 20 | 21 | val errorToExn : Pos.t option * error -> exn 22 | 23 | val raiseError : error -> 'a 24 | 25 | val raiseAnnotatedError : Pos.t * error -> 'a 26 | val raiseAnnotatedError' : Pos.t option * error -> 'a 27 | 28 | val format : exn -> Fpp.doc 29 | val annotation : exn -> Pos.t option 30 | 31 | (* this is obsolete *) 32 | val error : Fpp.doc list -> exn 33 | end 34 | -------------------------------------------------------------------------------- /src/redprl/error.sml: -------------------------------------------------------------------------------- 1 | structure RedPrlError :> REDPRL_ERROR = 2 | struct 3 | open RedPrlErrorData 4 | 5 | exception Err of error 6 | exception Pos of Pos.t * exn 7 | 8 | val errorToExn = 9 | fn (SOME pos, err) => Pos (pos, Err err) 10 | | (NONE, err) => Err err 11 | 12 | fun raiseError err = raise Err err 13 | fun raiseAnnotatedError (pos, err) = raise Pos (pos, Err err) 14 | val raiseAnnotatedError' = 15 | fn (SOME pos, err) => raiseAnnotatedError (pos, err) 16 | | (NONE, err) => raiseError err 17 | 18 | fun addPosition (pos, exn) = 19 | case (pos, exn) of 20 | (_, Pos _) => exn 21 | | (SOME pos, _) => Pos (pos, exn) 22 | | _ => exn 23 | 24 | val formatError = 25 | fn IMPOSSIBLE doc => Fpp.hvsep 26 | [Fpp.text "The impossible happened!", doc, 27 | Fpp.text "Please report this bug."] 28 | | INVALID_ATOMIC_JUDGMENT doc => Fpp.hvsep 29 | [Fpp.text "Not a valid atomic judgment:", Fpp.nest 2 doc] 30 | | INVALID_NATURAL_NUMBER doc => Fpp.hsep 31 | [Fpp.text "Not a valid natural number:", Fpp.nest 2 doc] 32 | | INVALID_DIMENSION doc => Fpp.hsep 33 | [Fpp.text "Not a valid dimension:", Fpp.nest 2 doc] 34 | | INVALID_LEVEL doc => Fpp.hsep 35 | [Fpp.text "Not a valid universe level:", Fpp.nest 2 doc] 36 | | NOT_APPLICABLE (tool, obj) => Fpp.hsep 37 | [tool, Fpp.text "is not applicable to:", Fpp.nest 2 obj] 38 | | UNIMPLEMENTED doc => Fpp.hsep 39 | [Fpp.text "Not implemented:", Fpp.nest 2 doc] 40 | | INCORRECT_ARITY th => 41 | Fpp.vsep 42 | [Fpp.hsep [Fpp.text "Operator", Fpp.seq [Fpp.char #"'", TermPrinter.ppOperator th, Fpp.char #"'"], Fpp.text "applied to an incorrect number of arguments"], 43 | Fpp.hsep [Fpp.text "Expected arity: ", TermPrinter.ppArity (RedPrlOperator.arity th)]] 44 | | GENERIC doc => Fpp.hsep doc 45 | 46 | val rec format = 47 | fn Err err => formatError err 48 | | Pos (_, exn) => format exn 49 | | RedPrlAbt.SortError {description,...} => Fpp.text description 50 | | LcfMonadBT.Refine [] => Fpp.text "No solution found" 51 | | LcfMonadBT.Refine exns => Fpp.vsep (List.map format exns) 52 | | exn => Fpp.text (exnMessage exn) 53 | 54 | val rec annotation = 55 | fn Pos (pos, exn) => 56 | (case annotation exn of 57 | SOME pos' => SOME pos' 58 | | NONE => SOME pos) 59 | | LcfMonadBT.Refine exns => annotationInExns exns 60 | | RedPrlAbt.SortError {annotation = ann,...} => ann 61 | | _ => NONE 62 | and annotationInExns = 63 | fn [] => NONE 64 | | e::es => 65 | (case annotation e of 66 | SOME p => SOME p 67 | | NONE => annotationInExns es) 68 | 69 | (* this is obsolete *) 70 | val error = Err o GENERIC 71 | end 72 | -------------------------------------------------------------------------------- /src/redprl/fpp.sml: -------------------------------------------------------------------------------- 1 | structure FppBasis = FppPrecedenceBasis (FppInitialBasis (FppPlainBasisTypes)) 2 | structure Fpp = FinalPrettyPrinter (FppBasis) 3 | 4 | signature FINAL_PRINTER = 5 | sig 6 | val execPP : Fpp.doc -> (int, unit) FppTypes.output 7 | end 8 | 9 | structure FinalPrinter :> FINAL_PRINTER = 10 | struct 11 | open FppBasis Fpp 12 | 13 | local 14 | fun initialEnv () = 15 | {maxWidth = !Config.maxWidth, 16 | maxRibbon = !Config.maxWidth, 17 | layout = FppTypes.BREAK, 18 | failure = FppTypes.CANT_FAIL, 19 | nesting = 0, 20 | formatting = (), 21 | formatAnn = fn _ => ()} 22 | in 23 | fun execPP (m : unit m) = 24 | #output (m emptyPrecEnv (initialEnv ()) {curLine = [], maxWidthSeen = 0}) 25 | end 26 | end 27 | -------------------------------------------------------------------------------- /src/redprl/inductive_spec.sig: -------------------------------------------------------------------------------- 1 | (* This isolates the parsing and checking of the inductive types 2 | * as much as possible from the rest of RedPRL. *) 3 | signature INDUCTIVE_SPEC = 4 | sig 5 | type conid = string 6 | structure ConstrDict : DICT where type key = conid 7 | type decl 8 | type constr 9 | type constrs = (conid * constr) list (* TODO make constrs abstract *) 10 | 11 | type precomputed_valences 12 | val eqPrecomputedValences : precomputed_valences * precomputed_valences -> bool 13 | 14 | (* Given a data declaration, generate a list of sequents for type-checking. *) 15 | val checkDecl : decl -> Sequent.jdg list 16 | 17 | (* The following functions extract the valences before the elaboration 18 | * so that sort-checking can be easily done. Note that this does not 19 | * handle meta-variables, which are taken care of by the meta language. *) 20 | (* Precompute the valences and keep them into an abstract data structure. *) 21 | val computeValences : RedPrlAst.ast -> precomputed_valences 22 | (* Get the valences of the type. *) 23 | val getTypeValences : precomputed_valences -> RedPrlArity.valence list 24 | (* Get the valences of the constructor. This includes the part associated with the type. *) 25 | val getIntroValences : precomputed_valences -> conid -> RedPrlArity.valence list 26 | (* Get the valences of the eliminator *after* the eliminated term. *) 27 | val getElimCasesValences : precomputed_valences -> RedPrlArity.valence list 28 | (* Get the valences of the constructors in the specification language. *) 29 | val computeAllSpecIntroValences : RedPrlAst.ast -> RedPrlArity.valence list ConstrDict.dict 30 | 31 | (* The following functions are helper functions to extract or manipulate the declaration 32 | * of the inductive types. *) 33 | 34 | (* Get the instance of the inductive type, given a list of arguments. The unused arguments are 35 | * returned as well, which might be useful for handling `elim` and `intro`. *) 36 | val fillFamily : decl -> RedPrlAbt.abt list -> RedPrlAbt.abt list * constrs * RedPrlAbt.abt list 37 | (* Get the boundaries of a particular constructor given the full list of arguments. *) 38 | val realizeIntroBoundaries : MlId.t * (RedPrlArity.valence list * precomputed_valences) * (RedPrlAbt.abt RedPrlAbt.bview list * RedPrlAbt.abt list) 39 | -> constr -> RedPrlAbt.abt list -> RedPrlAbt.abt SyntaxView.boundary list 40 | (* Get the result of a case analysis, given the arguments from the pattern matching. 41 | * The first argument is the function applied to recursive arguments. *) 42 | val fillBranch : (RedPrlAbt.abt -> RedPrlAbt.abt) 43 | -> constr -> Sym.t list * RedPrlAbt.abt -> RedPrlAbt.abt list -> RedPrlAbt.abt 44 | (* The result of the coercion of a constructor. *) 45 | val stepCoeIntro : RedPrlAbt.abt * RedPrlAbt.abt 46 | -> Sym.t * ((MlId.t * (RedPrlArity.valence list * precomputed_valences) * (RedPrlAbt.abt RedPrlAbt.bview list * RedPrlAbt.abt list)) * conid * constr) 47 | -> RedPrlAbt.abt list -> RedPrlAbt.abt 48 | 49 | (* The following functions are the type-checking code isolated from the refiner. 50 | * The principle is that the refiner should not know how exactly an inductive type 51 | * is defined. 52 | * 53 | * They are all generating sequents, not goals! It is the refiner which calls 54 | * these functions and turns sequents into subgoals. *) 55 | 56 | (* This is to compare two lists of arguments to some inductive types (not including meta variables). *) 57 | val EqType : Sequent.hyps -> decl -> RedPrlAbt.abt list * RedPrlAbt.abt list -> AtomicJudgment.View.as_level * RedPrlKind.t -> Sequent.jdg list 58 | (* This is to compare two lists of arguments to some constructor and a list of arguments to the type. *) 59 | val EqIntro : Sequent.hyps -> MlId.t * (RedPrlArity.valence list * precomputed_valences) * RedPrlAbt.abt RedPrlAbt.bview list 60 | -> decl -> conid -> (RedPrlAbt.abt list * RedPrlAbt.abt list) * RedPrlAbt.abt list -> Sequent.jdg list 61 | (* Given the motive and the term to be eliminated, return a list of sequents for type checking, 62 | * a list of lists of variables used in each branch, and a function to generate the coherence conditions. *) 63 | val Elim : Sequent.hyps -> MlId.t * (RedPrlArity.valence list * precomputed_valences) * (RedPrlAbt.abt RedPrlAbt.bview list * RedPrlAbt.abt list) 64 | -> Sym.t * RedPrlAbt.abt -> constrs -> Sequent.jdg list * Sym.t list list * (RedPrlAbt.abt list -> Sequent.jdg list) 65 | (* Given two elims, generate the sequents checking whether the branches are the same and they themselves are coherent. 66 | * Note that this does not type-check the motive(s). It is refiner's job to check the motive itself. *) 67 | val EqElimBranches : Sequent.hyps -> MlId.t * (RedPrlArity.valence list * precomputed_valences) * (RedPrlAbt.abt RedPrlAbt.bview list * RedPrlAbt.abt list) 68 | -> Sym.t * RedPrlAbt.abt -> constrs -> RedPrlAbt.abt RedPrlAbt.bview list * RedPrlAbt.abt RedPrlAbt.bview list 69 | -> Sequent.jdg list 70 | end 71 | -------------------------------------------------------------------------------- /src/redprl/judgment.sml: -------------------------------------------------------------------------------- 1 | structure RedPrlJudgment : LCF_JUDGMENT = 2 | struct 3 | structure AJ = AtomicJudgment 4 | structure S = Sequent 5 | structure Tm = RedPrlAbt 6 | type sort = Tm.valence 7 | type env = Tm.metaenv 8 | type ren = Tm.metavariable Tm.Metavar.Ctx.dict 9 | type jdg = S.jdg 10 | 11 | val subst = S.map o Tm.substMetaenv 12 | val ren = S.map o Tm.renameMetavars 13 | 14 | val eq = S.eq 15 | 16 | local 17 | open S 18 | infix >> 19 | in 20 | fun sort (H >> atjdg) = 21 | (Hyps.foldr (fn (_, jdg, r) => AJ.synthesis jdg :: r) [] H, 22 | AJ.synthesis atjdg) 23 | end 24 | end 25 | -------------------------------------------------------------------------------- /src/redprl/lcf.sml: -------------------------------------------------------------------------------- 1 | structure LcfLanguage = LcfAbtLanguage (RedPrlAbt) 2 | 3 | structure Lcf : 4 | sig 5 | type trace = string list 6 | datatype 'a traced = ::@ of trace * 'a 7 | 8 | include LCF_TACTIC where type 'a I.t = 'a traced 9 | val prettyState : jdg state -> Fpp.doc 10 | end = 11 | struct 12 | structure Tr = LcfListTrace (type e = string) 13 | structure Lcf = TracedLcf (structure L = LcfLanguage and Tr = Tr) 14 | structure Def = LcfTactic (structure J = RedPrlJudgment and Lcf = Lcf and M = LcfMonadBT) 15 | open Def Lcf 16 | infix |> ::@ || 17 | 18 | (* TODO: clean up all this stuff with vsep *) 19 | (* TODO: also try to extend the printer with "concrete name" environments so that we can print without doing 20 | all these renamings. *) 21 | 22 | fun @@ (f, x) = f x 23 | infixr 0 @@ 24 | 25 | fun prettyTrace tr = 26 | Fpp.collection (Fpp.char #"[") (Fpp.char #"]") (Fpp.Atomic.comma) 27 | (List.map Fpp.text tr) 28 | 29 | fun prettyGoal (x, tr ::@ jdg) = 30 | Fpp.nest 2 @@ 31 | Fpp.vsep @@ 32 | (Fpp.seq [Fpp.hsep [Fpp.text "Goal", TermPrinter.ppMeta x], Fpp.text "."]) :: 33 | (if !Config.printTrace 34 | then [Fpp.hsep [Fpp.text "Trace:", Fpp.align @@ prettyTrace tr], Sequent.pretty jdg] 35 | else [Sequent.pretty jdg]) 36 | 37 | val prettyGoals : jdg I.t Tl.telescope -> {doc : Fpp.doc, ren : J.ren, idx : int} = 38 | let 39 | open RedPrlAbt 40 | in 41 | Tl.foldl 42 | (fn (x, tr ::@ jdg, {doc, ren, idx}) => 43 | let 44 | val x' = Metavar.named (Int.toString idx) 45 | val jdg' = J.ren ren jdg 46 | val ren' = Metavar.Ctx.insert ren x x' 47 | in 48 | {doc = Fpp.seq [doc, if idx = 0 then Fpp.empty else Fpp.seq [Fpp.newline, Fpp.newline], prettyGoal (x', tr ::@ jdg')], 49 | ren = ren', 50 | idx = idx + 1} 51 | end) 52 | {doc = Fpp.empty, ren = Metavar.Ctx.empty, idx = 0} 53 | end 54 | 55 | fun prettyState (psi |> _) = 56 | #doc (prettyGoals psi) 57 | end 58 | -------------------------------------------------------------------------------- /src/redprl/list_util.sml: -------------------------------------------------------------------------------- 1 | structure ListUtil = 2 | struct 3 | local 4 | fun findIndex' p i : 'a list -> (int * 'a) option = 5 | fn [] => NONE 6 | | x :: l => 7 | if p x then SOME (i, x) 8 | else findIndex' p (i+1) l 9 | in 10 | fun findIndex p l = findIndex' p 0 l 11 | fun findEqIndex x l = findIndex (fn y => x = y) l 12 | end 13 | 14 | fun joinWith (f : 'a -> string) (sep : string) : 'a list -> string = 15 | let 16 | fun go [] = "" 17 | | go (x :: []) = f x 18 | | go (x :: xs) = f x ^ sep ^ go xs 19 | in 20 | go 21 | end 22 | 23 | fun mapWithIndex f = 24 | let 25 | fun go i [] = [] 26 | | go i (x :: xs) = f (i, x) :: go (i + 1) xs 27 | in 28 | go 0 29 | end 30 | 31 | fun revMap f l = 32 | let 33 | fun go [] acc = acc 34 | | go (x :: xs) acc = go xs (f x :: acc) 35 | in 36 | go l [] 37 | end 38 | 39 | fun concatMap (f : 'a -> 'b list) : 'a list -> 'b list = 40 | fn [] => [] 41 | | x::xs => f x @ concatMap f xs 42 | 43 | (* From MLton: https://github.com/MLton/mlton/blob/master/lib/mlton/basic/list.sml *) 44 | fun splitAt (xs, i) = 45 | let 46 | val rec loop = 47 | fn (0, acc, xs) => (rev acc, xs) 48 | | (_, _, []) => raise Fail "ListUtil.splitAt" 49 | | (i, acc, x::xs) => loop (i - 1, x :: acc, xs) 50 | in 51 | loop (i, [], xs) 52 | end 53 | 54 | local 55 | fun init' l [] = raise List.Empty 56 | | init' l [_] = List.rev l 57 | | init' l (x :: xs) = init' (x :: l) xs 58 | in 59 | fun init l = init' [] l 60 | end 61 | end 62 | 63 | infixr 5 ?:: 64 | val op ?:: = 65 | fn (NONE, l) => l 66 | | (SOME x, l) => x :: l 67 | 68 | structure ListPairUtil = 69 | struct 70 | fun concatMapEq (f : 'a * 'b -> 'c list) : 'a list * 'b list -> 'c list = 71 | fn ([], []) => [] 72 | | (x::xs, y::ys) => f (x, y) @ concatMapEq f (xs, ys) 73 | | _ => raise ListPair.UnequalLengths 74 | 75 | fun mapPartialEq f = 76 | ListPair.foldrEq 77 | (fn (x1, x2, ys) => 78 | case f (x1, x2) of 79 | NONE => ys 80 | | SOME y => y :: ys) 81 | [] 82 | 83 | fun enumPartialInterExceptDiag f = 84 | let 85 | fun enum ([], []) = [] 86 | | enum ((t0 :: ts0), (_ :: ts1)) = List.mapPartial (fn t1 => f (t0, t1)) ts1 :: enum (ts0, ts1) 87 | | enum _ = raise ListPair.UnequalLengths 88 | in 89 | List.concat o enum 90 | end 91 | 92 | fun enumInterExceptDiag f = 93 | let 94 | fun enum ([], []) = [] 95 | | enum ((t0 :: ts0), (_ :: ts1)) = List.map (fn t1 => f (t0, t1)) ts1 :: enum (ts0, ts1) 96 | | enum _ = raise ListPair.UnequalLengths 97 | in 98 | List.concat o enum 99 | end 100 | 101 | fun find p = 102 | fn (nil, _) => NONE 103 | | (_, nil) => NONE 104 | | (x::xs, y::ys) => if p (x, y) then SOME (x, y) else find p (xs, ys) 105 | end 106 | 107 | structure ListTripleUtil = 108 | struct 109 | fun unzip [] = ([], [], []) 110 | | unzip ((x, y, z) :: l) = 111 | let 112 | val (xs, ys, zs) = unzip l 113 | in 114 | (x::xs, y::ys, z::zs) 115 | end 116 | end 117 | -------------------------------------------------------------------------------- /src/redprl/log.sig: -------------------------------------------------------------------------------- 1 | signature REDPRL_LOG = 2 | sig 3 | datatype level = 4 | INFO 5 | | WARN 6 | | DUMP 7 | | FAIL 8 | 9 | val print : level -> Pos.t option * Fpp.doc -> unit 10 | end 11 | -------------------------------------------------------------------------------- /src/redprl/log.sml: -------------------------------------------------------------------------------- 1 | structure RedPrlLog :> REDPRL_LOG = 2 | struct 3 | datatype level = 4 | INFO 5 | | WARN 6 | | DUMP 7 | | FAIL 8 | 9 | fun formatMessage lvl (pos, msg : Fpp.doc) : Fpp.doc = 10 | let 11 | val pos' = 12 | case pos of 13 | SOME pos => Pos.toString pos 14 | | NONE => "[Unknown Location]" 15 | 16 | val prefix = 17 | case lvl of 18 | INFO => "Info" 19 | | DUMP => "Output" 20 | | WARN => "Warning" 21 | | FAIL => "Error" 22 | 23 | val header = 24 | Fpp.hsep 25 | [Fpp.text pos', 26 | Fpp.seq [Fpp.Atomic.squares (Fpp.text prefix), Fpp.Atomic.colon]] 27 | 28 | in 29 | Fpp.vsep [Fpp.nest 2 (Fpp.vsep [header, msg]), Fpp.newline] 30 | end 31 | 32 | val streamForLevel = 33 | fn INFO => TextIO.stdOut 34 | | DUMP => TextIO.stdOut 35 | | WARN => TextIO.stdOut 36 | | FAIL => TextIO.stdErr 37 | 38 | fun print lvl msg = 39 | let 40 | val stream = streamForLevel lvl 41 | val doc = formatMessage lvl msg 42 | val output = FinalPrinter.execPP doc 43 | in 44 | FppRenderPlainText.render stream output; 45 | TextIO.flushOut stream 46 | end 47 | end 48 | -------------------------------------------------------------------------------- /src/redprl/machine.sig: -------------------------------------------------------------------------------- 1 | signature REDPRL_MACHINE = 2 | sig 3 | type sign 4 | type abt 5 | type opid 6 | 7 | exception Unstable 8 | 9 | (* All computation commutes with permutations of dimension names, but some computation 10 | involves observations that are not preserved by general substitutions of dimensions. 11 | 12 | Our machine can be run with respect to these two notions of 'stability'; NOMINAL 13 | stability is the most permissive, whereas steps observed under STABLE must always 14 | commute with cubical substitutions. If the machine is run under STABLE stability 15 | and an unstable observation is made, the Unstable exception is raised.*) 16 | datatype stability = 17 | STABLE 18 | | NOMINAL 19 | 20 | datatype blocker = 21 | VAR of RedPrlAbt.variable 22 | | METAVAR of RedPrlAbt.metavariable 23 | | OPERATOR of opid 24 | 25 | exception Stuck 26 | exception Neutral of blocker 27 | 28 | datatype canonicity = 29 | CANONICAL 30 | | NEUTRAL of blocker 31 | | REDEX 32 | | STUCK 33 | | UNSTABLE 34 | 35 | structure Unfolding : 36 | sig 37 | type regime = opid -> bool 38 | 39 | (* Don't unfold operators for which we have type information! *) 40 | val default : sign -> regime 41 | 42 | (* Don't unfold any operators *) 43 | val never : regime 44 | 45 | (* Always unfold operators *) 46 | val always : regime 47 | end 48 | 49 | val eval : sign -> stability -> Unfolding.regime -> abt -> abt 50 | 51 | (* Execute a term for 'n' steps; compatibility/congruence steps don't count. *) 52 | val steps : sign -> stability -> Unfolding.regime -> int -> abt -> abt 53 | 54 | val canonicity : sign -> stability -> Unfolding.regime -> abt -> canonicity 55 | end 56 | -------------------------------------------------------------------------------- /src/redprl/metalanguage/elaborate.sig: -------------------------------------------------------------------------------- 1 | signature ML_ELABORATE = 2 | sig 3 | type env 4 | type ivalue 5 | type icmd 6 | type evalue 7 | type ecmd 8 | type vty 9 | type cty 10 | 11 | val elabValue : evalue -> env -> ivalue * vty 12 | val elabCmd : ecmd -> env -> icmd * cty 13 | end 14 | -------------------------------------------------------------------------------- /src/redprl/metalanguage/evaluate.sig: -------------------------------------------------------------------------------- 1 | signature ML_EVALUATE = 2 | sig 3 | type env 4 | 5 | type syn_value 6 | type sem_value 7 | 8 | type syn_cmd 9 | type sem_cmd 10 | 11 | type exit_code = bool 12 | 13 | val evalVal : env -> syn_value -> sem_value 14 | val evalCmd : env -> syn_cmd -> sem_cmd * exit_code 15 | end 16 | -------------------------------------------------------------------------------- /src/redprl/metalanguage/resolver.fun: -------------------------------------------------------------------------------- 1 | functor MlResolver (Ty : ML_TYPE) :> RESOLVER where type mltype = Ty.vty and type id = MlId.t = 2 | struct 3 | structure E = RedPrlError 4 | 5 | fun @@ (f, x) = f x 6 | infixr @@ 7 | 8 | type mltype = Ty.vty 9 | type id = MlId.t 10 | 11 | structure Dict = SplayDict (structure Key = MlId) 12 | 13 | type env = 14 | {ids : Ty.vty Dict.dict, 15 | vars : (Tm.variable * Tm.sort) StringListDict.dict, 16 | metas : (Tm.metavariable * Tm.valence) StringListDict.dict} 17 | 18 | type spec_env = 19 | {intros: Tm.valence list InductiveSpec.ConstrDict.dict} 20 | 21 | val init = 22 | {ids = Dict.empty, 23 | vars = StringListDict.empty, 24 | metas = StringListDict.empty} 25 | 26 | val dummy_spec_env = 27 | {intros = InductiveSpec.ConstrDict.empty} 28 | 29 | fun lookupId (env : env) pos (x : id) = 30 | case Dict.find (#ids env) x of 31 | SOME r => r 32 | | NONE => E.raiseAnnotatedError' (pos, E.GENERIC [Fpp.text "Could not resolve id", Fpp.text (MlId.toString x)]) 33 | 34 | fun lookupVar (env : env) pos x = 35 | case StringListDict.find (#vars env) x of 36 | SOME r => r 37 | | NONE => E.raiseAnnotatedError' (pos, E.GENERIC [Fpp.text "Could not resolve variable", Fpp.text x]) 38 | 39 | fun lookupMeta (env : env) pos x = 40 | case StringListDict.find (#metas env) x of 41 | SOME r => r 42 | | NONE => E.raiseAnnotatedError' (pos, E.GENERIC [Fpp.text "Could not resolve metavariable", Fpp.text x]) 43 | 44 | fun lookupSpecIntro (env : spec_env) pos x = 45 | case InductiveSpec.ConstrDict.find (#intros env) x of 46 | SOME r => r 47 | | NONE => E.raiseAnnotatedError' (pos, E.GENERIC [Fpp.text "Could not resolve constructor id", Fpp.text x]) 48 | 49 | (* TODO: proper error message when the name is already used *) 50 | fun extendId {ids, vars, metas} nm vty = 51 | let 52 | val (ids', false) = Dict.insert' ids nm vty 53 | in 54 | {ids = ids', 55 | vars = vars, 56 | metas = metas} 57 | end 58 | 59 | fun extendVars {ids, vars, metas} (xs, taus) = 60 | let 61 | val (gamma, vars') = 62 | ListPair.foldrEq 63 | (fn (x, tau, (gamma, vars)) => 64 | let 65 | val x' = Sym.named x 66 | in 67 | ((x',tau) :: gamma, StringListDict.insert vars x (x', tau)) 68 | end) 69 | ([], vars) 70 | (xs, taus) 71 | val env = {ids = ids, vars = vars', metas = metas} 72 | in 73 | (gamma, env) 74 | end 75 | handle exn => 76 | E.raiseError @@ 77 | E.GENERIC [Fpp.text "extendVars: invalid arguments", Fpp.text @@ exnMessage exn] 78 | 79 | fun extendMetas {ids, vars, metas} (Xs, vls) = 80 | let 81 | val (psi, metas') = 82 | ListPair.foldrEq 83 | (fn (X, vl, (psi, metas)) => 84 | let 85 | val X' = Metavar.named X 86 | in 87 | ((X',vl) :: psi, StringListDict.insert metas X (X', vl)) 88 | end) 89 | ([], metas) 90 | (Xs, vls) 91 | val env = {ids = ids, vars = vars, metas = metas'} 92 | in 93 | (psi, env) 94 | end 95 | handle _ => 96 | E.raiseError @@ 97 | E.GENERIC [Fpp.text "extendMetas: invalid arguments"] 98 | 99 | fun makeSpecEnv intros = {intros = intros} 100 | end 101 | 102 | 103 | -------------------------------------------------------------------------------- /src/redprl/metalanguage/resolver.sig: -------------------------------------------------------------------------------- 1 | structure Tm = RedPrlAbt 2 | 3 | (* This is the core of name resolution for the metalanguage and the object language. *) 4 | signature RESOLVER = 5 | sig 6 | type env 7 | type spec_env 8 | type mltype 9 | 10 | type id 11 | 12 | val init : env 13 | val dummy_spec_env : spec_env 14 | 15 | val lookupId : env -> Pos.t option -> id -> mltype 16 | val extendId : env -> id -> mltype -> env 17 | 18 | val lookupVar : env -> Pos.t option -> string -> Tm.variable * Tm.sort 19 | val lookupMeta : env -> Pos.t option -> string -> Tm.metavariable * Tm.valence 20 | 21 | val extendVars : env -> string list * Tm.sort list -> (Tm.variable * Tm.sort) list * env 22 | val extendMetas : env -> string list * Tm.valence list -> (Tm.metavariable * Tm.valence) list * env 23 | 24 | val lookupSpecIntro : spec_env -> Pos.t option -> InductiveSpec.conid -> Tm.valence list 25 | val makeSpecEnv : Tm.valence list InductiveSpec.ConstrDict.dict -> spec_env 26 | end 27 | -------------------------------------------------------------------------------- /src/redprl/metalanguage/semantics.sig: -------------------------------------------------------------------------------- 1 | (* The semantic domain for metalanguage programs. *) 2 | signature ML_SEMANTICS = 3 | sig 4 | type env 5 | type syn_cmd 6 | type jdg = Sequent.jdg 7 | type term = Tm.abt 8 | type metas = (Tm.metavariable * Tm.valence) list 9 | 10 | datatype value = 11 | THUNK of env * syn_cmd 12 | | THM of jdg * Tm.abs 13 | | DATA_INFO of term * InductiveSpec.precomputed_valences (* XXX Seriously, we should have something better. -favonia *) 14 | | TERM of term 15 | | ABS of value * value 16 | | METAS of metas 17 | | NIL 18 | 19 | datatype cmd = 20 | RET of value 21 | | FN of env * MlId.t * syn_cmd 22 | 23 | 24 | val initEnv : env 25 | val lookup : env -> MlId.t -> value 26 | val lookupMeta : env -> Tm.metavariable -> Tm.metavariable 27 | val term : env -> term -> term 28 | 29 | val extend : env -> MlId.t -> value -> env 30 | val renameEnv : env -> Tm.metavariable Tm.Metavar.Ctx.dict -> env 31 | val renameVal : value -> Tm.metavariable Tm.Metavar.Ctx.dict -> value 32 | 33 | val ppValue : value -> Fpp.doc 34 | end 35 | -------------------------------------------------------------------------------- /src/redprl/metalanguage/semantics.sml: -------------------------------------------------------------------------------- 1 | structure MlSemantics : ML_SEMANTICS = 2 | struct 3 | structure Syn = MlIntSyntax 4 | type term = Syn.term 5 | type jdg = Syn.jdg 6 | type metavariable = Syn.metavariable 7 | type metas = Syn.metas 8 | type syn_cmd = Syn.cmd 9 | 10 | structure Dict = SplayDict (structure Key = MlId) 11 | 12 | datatype value = 13 | THUNK of env * syn_cmd 14 | | THM of jdg * Tm.abs 15 | | DATA_INFO of term * InductiveSpec.precomputed_valences 16 | | TERM of term 17 | | ABS of value * value 18 | | METAS of metas 19 | | NIL 20 | 21 | withtype env = value Dict.dict * metavariable Metavar.Ctx.dict 22 | 23 | datatype cmd = 24 | RET of value 25 | | FN of env * MlId.t * syn_cmd 26 | 27 | val initEnv = (Dict.empty, Metavar.Ctx.empty) 28 | 29 | fun @@ (f, x) = f x 30 | infixr @@ 31 | 32 | fun lookup (env : env) (nm : MlId.t) : value = 33 | case Dict.find (#1 env) nm of 34 | SOME v => v 35 | | NONE => 36 | RedPrlError.raiseError @@ 37 | RedPrlError.GENERIC 38 | [Fpp.text "Could not find value of", 39 | Fpp.text (MlId.toString nm), 40 | Fpp.text "in environment"] 41 | 42 | fun extend (env : env) (nm : MlId.t) (v : value) : env = 43 | (Dict.insert (#1 env) nm v, #2 env) 44 | 45 | 46 | fun renameEnv (env : env) rho = 47 | let 48 | val rho' = Metavar.Ctx.map (fn X => Option.getOpt (Metavar.Ctx.find rho X, X)) (#2 env) 49 | val rho'' = Metavar.Ctx.union rho' rho (fn (_, X, _) => X) 50 | in 51 | (#1 env, rho'') 52 | end 53 | 54 | fun renameVal s ren = 55 | let 56 | fun go ren = 57 | fn THUNK (env, cmd) => THUNK (renameEnv env ren, cmd) 58 | | THM (jdg, abs) => THM (Sequent.map (Tm.renameMetavars ren) jdg, Tm.mapAbs (Tm.renameMetavars ren) abs) 59 | | TERM term => TERM (Tm.renameMetavars ren term) 60 | | ABS (METAS psi, s) => ABS (METAS psi, go (List.foldr (fn ((X, _), ren) => Metavar.Ctx.remove ren X) ren psi) s) 61 | | METAS psi => METAS (List.map (fn (X, vl) => (Option.getOpt (Metavar.Ctx.find ren X, X), vl)) psi) 62 | | NIL => NIL 63 | | DATA_INFO (info, arity) => DATA_INFO (Tm.renameMetavars ren info, arity) 64 | in 65 | go ren s 66 | end 67 | 68 | fun lookupMeta (env : env) (X : metavariable) = 69 | case Metavar.Ctx.find (#2 env) X of 70 | SOME Y => Y 71 | | NONE => 72 | RedPrlError.raiseError @@ 73 | RedPrlError.GENERIC 74 | [Fpp.text "Could not find value of metavariable", 75 | TermPrinter.ppMeta X, 76 | Fpp.text "in environment"] 77 | 78 | 79 | fun term (env : env) m = 80 | Tm.renameMetavars (#2 env) m 81 | 82 | structure AJ = AtomicJudgment 83 | 84 | (* TODO *) 85 | val rec ppValue : value -> Fpp.doc = 86 | fn THUNK _ => Fpp.text "" 87 | | THM (jdg, abs) => 88 | let 89 | val Tm.\ (_, abt) = Tm.outb abs 90 | in 91 | Fpp.seq 92 | [Fpp.text "Thm:", 93 | Fpp.nest 2 @@ Fpp.seq [Fpp.newline, Sequent.pretty jdg], 94 | Fpp.newline, 95 | Fpp.newline, 96 | Fpp.text "Extract:", 97 | Fpp.nest 2 @@ Fpp.seq [Fpp.newline, TermPrinter.ppTerm abt]] 98 | end 99 | 100 | | DATA_INFO _ => 101 | Fpp.text "" 102 | 103 | | TERM abt => 104 | TermPrinter.ppTerm abt 105 | 106 | | METAS psi => 107 | Fpp.collection 108 | (Fpp.char #"[") 109 | (Fpp.char #"]") 110 | Fpp.Atomic.comma 111 | (List.map (fn (X, vl) => Fpp.hsep [TermPrinter.ppMeta X, Fpp.Atomic.colon, TermPrinter.ppValence vl]) psi) 112 | 113 | | ABS (vpsi, v) => 114 | Fpp.seq 115 | [Fpp.hsep 116 | [ppValue vpsi, 117 | Fpp.text "=>"], 118 | Fpp.nest 2 @@ Fpp.seq [Fpp.newline, ppValue v]] 119 | 120 | | NIL => 121 | Fpp.text "()" 122 | end 123 | -------------------------------------------------------------------------------- /src/redprl/metalanguage/syntax.sml: -------------------------------------------------------------------------------- 1 | structure MlExtSyntax = 2 | struct 3 | type sort = RedPrlSort.t 4 | type valence = RedPrlAbt.valence 5 | 6 | type id = MlId.t 7 | type metavariable = string 8 | type jdg = RedPrlAst.ast 9 | type term = RedPrlAst.ast * sort 10 | type vty = MlType.vty 11 | 12 | type metas = (metavariable * valence) list 13 | type arguments = (metavariable * valence) list 14 | 15 | datatype cmd = 16 | DEF of {arguments : arguments, definiens : term} 17 | | THM of {name : string, arguments : arguments, goal : jdg, script : RedPrlAst.ast} 18 | | TAC of {arguments : arguments, script : RedPrlAst.ast} 19 | | DATA_DECL of {name : string, arguments : arguments, decl : RedPrlAst.ast, script : RedPrlAst.ast} 20 | 21 | | PRINT_EXTRACT of Pos.t option * value 22 | | EXTRACT of value 23 | | NU of metas * cmd 24 | 25 | | BIND of cmd * id * cmd 26 | | RET of value 27 | | FORCE of value 28 | | FN of id * vty * cmd 29 | | AP of cmd * value 30 | | PRINT of Pos.t option * value 31 | | REFINE of string option * jdg * RedPrlAst.ast 32 | | FRESH of (string option * valence) list 33 | | MATCH_METAS of value * metavariable list * cmd 34 | | MATCH_ABS of value * id * id * cmd 35 | | MATCH_THM of value * id * id * cmd 36 | | ABORT 37 | 38 | and value = 39 | THUNK of cmd 40 | | VAR of id 41 | | NIL 42 | | ABS of value * value 43 | | METAS of metas 44 | | TERM of term 45 | end 46 | 47 | structure MlIntSyntax = 48 | struct 49 | type id = MlId.t 50 | type valence = RedPrlAbt.valence 51 | type metavariable = RedPrlAbt.metavariable 52 | type jdg = Sequent.jdg 53 | type term = RedPrlAbt.abt 54 | type vty = MlType.vty 55 | type proof_state = Sequent.jdg Lcf.state 56 | 57 | type metas = (metavariable * valence) list 58 | 59 | datatype value = 60 | THUNK of cmd 61 | | VAR of id 62 | | NIL 63 | | ABS of value * value 64 | | METAS of metas 65 | | TERM of term 66 | | DATA_INFO of term * InductiveSpec.precomputed_valences 67 | 68 | and cmd = 69 | BIND of cmd * id * cmd 70 | | RET of value 71 | | FORCE of value 72 | | FN of id * vty * cmd 73 | | AP of cmd * value 74 | | PRINT of Pos.t option * value 75 | | REFINE of string option * jdg * term 76 | | REFINE_MULTI of string option * proof_state * term 77 | | FRESH of (string option * valence) list 78 | | MATCH_METAS of value * metavariable list * cmd 79 | | MATCH_ABS of value * id * id * cmd 80 | | MATCH_THM of value * id * id * cmd 81 | | ABORT 82 | end 83 | -------------------------------------------------------------------------------- /src/redprl/metalanguage/type.sig: -------------------------------------------------------------------------------- 1 | structure MlTypeData = 2 | struct 3 | type sort = RedPrlSort.t 4 | type valence = RedPrlArity.valence 5 | 6 | datatype vty = 7 | ONE 8 | | DOWN of cty 9 | | TERM of sort 10 | | THM of sort 11 | | ABS of valence list * vty 12 | | METAS of valence list 13 | | DATA_INFO of InductiveSpec.precomputed_valences 14 | (* TODO: 15 | | SUM of (string * vty) list 16 | *) 17 | 18 | and cty = 19 | UP of vty 20 | | FUN of vty * cty 21 | (* TODO: 22 | | RECORD of (string * cty) list 23 | *) 24 | end 25 | 26 | signature ML_TYPE = 27 | sig 28 | datatype vty = datatype MlTypeData.vty 29 | datatype cty = datatype MlTypeData.cty 30 | 31 | val eqVty : vty * vty -> bool 32 | val eqCty : cty * cty -> bool 33 | 34 | (* TODO: 35 | 36 | val ppVty : vty -> Fpp.doc 37 | val ppCty : cty -> Fpp.doc 38 | 39 | *) 40 | end 41 | -------------------------------------------------------------------------------- /src/redprl/metalanguage/type.sml: -------------------------------------------------------------------------------- 1 | structure MlType :> ML_TYPE = 2 | struct 3 | datatype vty = datatype MlTypeData.vty 4 | datatype cty = datatype MlTypeData.cty 5 | 6 | val rec eqVty = 7 | fn (ONE, ONE) => true 8 | | (ONE, _) => false 9 | | (DOWN c0, DOWN c1) => eqCty (c0, c1) 10 | | (DOWN _, _) => false 11 | | (TERM s0, TERM s1) => s0 = s1 12 | | (TERM _, _) => false 13 | | (THM s0, THM s1) => s0 = s1 14 | | (THM _, _) => false 15 | | (ABS (vls0, v0), ABS (vls1, v1)) => vls0 = vls1 andalso eqVty (v0, v1) 16 | | (ABS _, _) => false 17 | | (METAS vls0, METAS vls1) => vls0 = vls1 18 | | (METAS _, _) => false 19 | | (DATA_INFO vls0, DATA_INFO vls1) => InductiveSpec.eqPrecomputedValences (vls0, vls1) 20 | | (DATA_INFO _, _) => false 21 | 22 | and eqCty = 23 | fn (UP v0, UP v1) => eqVty (v0, v1) 24 | | (UP _, _) => false 25 | | (FUN (v0, c0), FUN (v1, c1)) => eqVty (v0, v1) andalso eqCty (c0, c1) 26 | | (FUN _, _) => false 27 | end 28 | -------------------------------------------------------------------------------- /src/redprl/mini_signature.sig: -------------------------------------------------------------------------------- 1 | (* This is what is needed to bootstrap the refiner, and thence the tactic elaborator. This 2 | enables rules that depend on the definitions of theorems and other operators. 3 | 4 | TODO: rename to something more sensible 5 | *) 6 | signature MINI_SIGNATURE = 7 | sig 8 | type opid = RedPrlOpData.opid 9 | type abt = RedPrlAbt.abt 10 | 11 | type sign 12 | val theoremSpec : sign -> opid -> abt RedPrlAbt.bview list -> AtomicJudgment.jdg 13 | val unfoldOpid : sign -> opid -> abt RedPrlAbt.bview list -> abt 14 | 15 | val isTheorem : sign -> opid -> bool 16 | 17 | (* TODO explain the following function to someone other than favonia. *) 18 | val dataDeclInfo : sign -> opid -> abt RedPrlAbt.bview list -> 19 | abt RedPrlAbt.bview list * (abt * InductiveSpec.precomputed_valences) * abt list 20 | end 21 | -------------------------------------------------------------------------------- /src/redprl/ml_id.sig: -------------------------------------------------------------------------------- 1 | signature ML_ID = 2 | sig 3 | eqtype t 4 | 5 | val eq : t * t -> bool 6 | val compare : t * t -> order 7 | 8 | val new : unit -> t 9 | val fresh : string -> t 10 | val const : string -> t 11 | val toString : t -> string 12 | end 13 | -------------------------------------------------------------------------------- /src/redprl/ml_id.sml: -------------------------------------------------------------------------------- 1 | structure MlId :> ML_ID = 2 | struct 3 | datatype t = CONST of string | VAR of int * string option 4 | 5 | val eq : t * t -> bool = op= 6 | 7 | val compare = 8 | fn (CONST s1, CONST s2) => String.compare (s1, s2) 9 | | (VAR (i1, _), VAR (i2, _)) => Int.compare (i1, i2) 10 | | (CONST _, VAR _) => LESS 11 | | _ => GREATER 12 | 13 | val counter = ref 0 14 | 15 | fun new () = 16 | (counter := !counter + 1; 17 | VAR (!counter, NONE)) 18 | 19 | fun const a = CONST a 20 | 21 | fun fresh str = 22 | (counter := !counter + 1; 23 | VAR (!counter, SOME str)) 24 | 25 | val toString = 26 | fn CONST str => str 27 | | VAR (i, NONE) => "$" ^ Int.toString i 28 | | VAR (_, SOME str) => str 29 | end 30 | -------------------------------------------------------------------------------- /src/redprl/option_util.sml: -------------------------------------------------------------------------------- 1 | structure OptionUtil = 2 | struct 3 | fun eq f = 4 | fn (NONE, NONE) => true 5 | | (SOME a, SOME b) => f (a, b) 6 | | _ => false 7 | 8 | fun concat f = 9 | fn NONE => [] 10 | | SOME a => f a 11 | end 12 | -------------------------------------------------------------------------------- /src/redprl/redprl_lexer.sml: -------------------------------------------------------------------------------- 1 | structure RedPrlLrVals = 2 | RedPrlLrValsFun(structure Token = LrParser.Token) 3 | 4 | structure RedPrlLex = 5 | RedPrlLexFun(structure Tokens = RedPrlLrVals.Tokens) 6 | -------------------------------------------------------------------------------- /src/redprl/redprl_parser.sml: -------------------------------------------------------------------------------- 1 | structure RedPrlParser = 2 | JoinWithArg 3 | (structure LrParser = LrParser 4 | structure ParserData = RedPrlLrVals.ParserData 5 | structure Lex = RedPrlLex) 6 | -------------------------------------------------------------------------------- /src/redprl/refiner.sig: -------------------------------------------------------------------------------- 1 | signature REFINER = 2 | sig 3 | type sign 4 | type abt 5 | type catjdg 6 | type rule 7 | type tactic 8 | type hyp 9 | type opid 10 | type 'a bview 11 | 12 | val Cut : catjdg -> rule 13 | val CutLemma : sign -> abt -> rule 14 | 15 | val AutoStep : sign -> tactic 16 | val NondetStepJdgFromHyp : sign -> tactic 17 | 18 | val Elim : sign -> hyp -> tactic 19 | val Exact : abt -> tactic 20 | val Rewrite : sign -> hyp Selector.t * Accessor.t list -> abt -> tactic 21 | val Symmetry : tactic 22 | 23 | val Inversion : hyp -> tactic 24 | 25 | (* synthetic elim rule for nested pi, path and line types *) 26 | structure MultiArrow : 27 | sig 28 | val Elim : sign -> int -> hyp -> rule 29 | end 30 | 31 | structure Custom : 32 | sig 33 | val UnfoldAll : sign -> opid list -> rule 34 | val Unfold : sign -> opid list -> hyp Selector.t list -> rule 35 | val UnfoldPart : sign -> opid list -> hyp Selector.t * Accessor.t list -> rule 36 | end 37 | 38 | structure Computation : 39 | sig 40 | val ReduceAll : sign -> tactic 41 | val Reduce : sign -> hyp Selector.t list -> rule 42 | val ReducePart : sign -> hyp Selector.t * Accessor.t list -> rule 43 | end 44 | 45 | structure Hyp : 46 | sig 47 | val Project : hyp -> rule 48 | val Delete : hyp -> rule 49 | end 50 | 51 | structure Tactical : 52 | sig 53 | val NormalizeGoalDelegate : (abt -> tactic) -> sign -> tactic 54 | val NormalizeHypDelegate : (abt -> hyp -> tactic) -> sign -> hyp -> tactic 55 | end 56 | 57 | structure Names : 58 | sig 59 | val Push : hyp list -> rule 60 | val PopAs : hyp list -> rule 61 | end 62 | 63 | type rule_name = string 64 | val lookupRule : sign -> rule_name -> tactic 65 | end 66 | -------------------------------------------------------------------------------- /src/redprl/refiner_kit.fun: -------------------------------------------------------------------------------- 1 | functor RefinerKit (Sig : MINI_SIGNATURE) = 2 | struct 3 | structure Tactical = RedPrlTactical (Lcf) 4 | 5 | open Tactical 6 | infix orelse_ then_ 7 | 8 | structure E = RedPrlError and O = RedPrlOperator and T = TelescopeUtil (Lcf.Tl) and Abt = RedPrlAbt and Syn = SyntaxView and J = RedPrlJudgment 9 | structure K = RedPrlKind 10 | structure L = RedPrlLevel 11 | structure AJ = AtomicJudgment 12 | structure Seq = Sequent 13 | structure Env = RedPrlAbt.Metavar.Ctx 14 | structure Machine = RedPrlMachine (Sig) 15 | 16 | local structure TeleNotation = TelescopeNotation (T) in open TeleNotation end 17 | open Sequent 18 | infix 2 >: >> 19 | 20 | exception todo 21 | fun ?e = raise e 22 | 23 | fun @@ (f, x) = f x 24 | infixr @@ 25 | 26 | local 27 | val counter = ref 0 28 | in 29 | fun newMeta str = 30 | let 31 | val i = !counter 32 | in 33 | counter := i + 1; 34 | Metavar.named @@ str ^ Int.toString i 35 | end 36 | end 37 | 38 | (* assert that the term 'm' has only free variables 'xs' at most. *) 39 | fun assertWellScoped xs m = 40 | let 41 | val vars = List.foldl (fn (x, vars) => Var.Ctx.remove vars x) (Abt.varctx m) xs 42 | fun ppVars us = Fpp.Atomic.squares @@ Fpp.hsep @@ List.map TermPrinter.ppVar us 43 | val varsOk = Var.Ctx.isEmpty vars 44 | in 45 | if varsOk then 46 | () 47 | else 48 | raise E.error 49 | [Fpp.text "Internal Error:", 50 | Fpp.text "Validation term", 51 | TermPrinter.ppTerm m, 52 | Fpp.text "had unbound variables", 53 | ppVars (Var.Ctx.domain vars), 54 | Fpp.text "whereas we expected only", 55 | ppVars xs] 56 | end 57 | 58 | (* hypotheses *) 59 | 60 | fun @> (H, (x, j)) = Hyps.snoc H x j 61 | infix @> 62 | fun |@> h = Hyps.empty @> h 63 | 64 | (* evidence *) 65 | 66 | fun abstractEvidence H m = 67 | let 68 | val (xs, taus) = Hyps.foldr (fn (x, jdg, (xs, taus)) => (x::xs, AJ.synthesis jdg::taus)) ([],[]) H 69 | in 70 | assertWellScoped xs m; 71 | Abt.checkb (Abt.\ (xs, m), (taus, Abt.sort m)) 72 | end 73 | 74 | fun #> (psi, (H, m)) = 75 | Lcf.|> (psi, abstractEvidence H m) 76 | infix #> 77 | 78 | val axiom = Syn.into Syn.AX 79 | 80 | (* telescope combinators *) 81 | 82 | fun |>: g = T.empty >: g 83 | 84 | fun >:+ (tel, list) : 'a telescope = 85 | List.foldl (fn (g, t) => t >: g) tel list 86 | infix 5 >:+ 87 | 88 | fun |>:+ g = T.empty >:+ g 89 | 90 | fun >:? (tel, NONE) = tel 91 | | >:? (tel, SOME g) = tel >: g 92 | infix 5 >:? 93 | 94 | fun |>:? g = T.empty >:? g 95 | 96 | (* making goals *) 97 | 98 | fun makeGoal (tr : string list) (jdg : jdg) : (Lcf.L.var * jdg Lcf.I.t) * abt = 99 | let 100 | open Abt infix 1 $# 101 | val x = newMeta "" 102 | val (_, tau) = J.sort jdg 103 | val ms = 104 | case jdg of 105 | H >> _ => Hyps.toList H 106 | 107 | val hole = check (x $# ms, tau) 108 | in 109 | ((x, Lcf.::@ (tr, jdg)), hole) 110 | end 111 | 112 | fun makeGoalWith tr f = makeGoal tr o Seq.map f 113 | 114 | fun makeGoal' tr jdg = #1 @@ makeGoal tr jdg 115 | fun makeGoal'With tr f = makeGoal' tr o Seq.map f 116 | 117 | (* needing the realizer *) 118 | fun makeTrueWith tr f H ty = makeGoalWith tr f @@ H >> AJ.TRUE ty 119 | fun makeTrue tr H ty = makeGoal tr @@ H >> AJ.TRUE ty 120 | fun makeTerm tr H tau = makeGoal tr @@ H >> AJ.TERM tau 121 | 122 | (* ignoring the trivial realizer *) 123 | fun makeType tr H (a, k) = makeGoal' tr @@ H >> AJ.TYPE (a, k) 124 | fun makeEqTypeWith tr f H ((a, b), k) = makeGoal'With tr f @@ H >> AJ.EQ_TYPE ((a, b), k) 125 | fun makeEqType tr H ((a, b), k) = makeGoal' tr @@ H >> AJ.EQ_TYPE ((a, b), k) 126 | fun makeEqWith tr f H ((m, n), ty) = makeGoal'With tr f @@ H >> AJ.EQ ((m, n), ty) 127 | fun makeEq tr H ((m, n), ty) = makeGoal' tr @@ H >> AJ.EQ ((m, n), ty) 128 | fun makeMem tr H (m, ty) = makeGoal' tr @@ H >> AJ.MEM (m, ty) 129 | fun makeSubType tr H (a, b) = makeGoal' tr @@ H >> AJ.SUB_TYPE (a, b) 130 | fun makeSubKind tr H (u, k) = makeGoal' tr @@ H >> AJ.SUB_KIND (u, k) 131 | 132 | (* conditional goal making *) 133 | 134 | fun makeEqTypeIfDifferent tr H ((m, n), k) = 135 | if Abt.eq (m, n) then NONE 136 | else SOME @@ makeEqType tr H ((m, n), k) 137 | 138 | fun makeEqTypeUnlessSubUniv tr H ((m, n), k) k' = 139 | Option.map 140 | (fn k => makeEqType tr H ((m, n), k)) 141 | (K.residual (k, k')) 142 | 143 | fun makeTypeUnlessSubUniv tr H (m, k) k' = 144 | makeEqTypeUnlessSubUniv tr H ((m, m), k) k' 145 | 146 | fun makeEqTypeIfDifferentOrNotSubUniv tr H ((m, n), k) k' = 147 | if Abt.eq (m, n) then makeTypeUnlessSubUniv tr H (m, k) k' 148 | else SOME @@ makeEqType tr H ((m, n), k) 149 | 150 | fun makeEqIfDifferent tr H ((m, n), ty) = 151 | if Abt.eq (m, n) then NONE 152 | else SOME @@ makeEq tr H ((m, n), ty) 153 | 154 | fun makeEqIfAllDifferent tr H ((m, n), ty) ns = 155 | if List.exists (fn n' => Abt.eq (m, n')) ns then NONE 156 | else makeEqIfDifferent tr H ((m, n), ty) 157 | 158 | (* subtyping *) 159 | 160 | (* It is not clear how exactly the subtyping should be implemented; 161 | * therefore we have a dummy implementation here. *) 162 | fun makeSubTypeIfDifferent tr H (a, b) = 163 | if Abt.eq (a, b) then NONE 164 | else SOME @@ makeSubType tr H (a, b) 165 | 166 | (* functions which blur the difference between EQ and EQ_TYPE *) 167 | structure View = 168 | struct 169 | datatype as_level = datatype AJ.View.as_level 170 | datatype as_type = datatype AJ.View.as_type 171 | 172 | val matchTrueAsEq = AJ.View.matchTrueAsEq 173 | 174 | fun makeEqAsTrue tr H params = makeGoal' tr @@ H >> AJ.View.makeEqAsTrue params 175 | 176 | val matchAsEqType = AJ.View.matchAsEqType 177 | 178 | fun makeAsEqType tr H params = makeGoal' tr @@ H >> AJ.View.makeAsEqType params 179 | 180 | fun makeAsEqTypeWith tr f H params = makeGoal'With tr f @@ H >> AJ.View.makeAsEqType params 181 | 182 | val matchAsEq = AJ.View.matchAsEq 183 | 184 | fun makeAsEq tr H params = makeGoal' tr @@ H >> AJ.View.makeAsEq params 185 | fun makeAsEqWith tr f H params = makeGoal'With tr f @@ H >> AJ.View.makeAsEq params 186 | 187 | fun makeAsEqIfDifferent tr H = 188 | fn ((a, b), INTERNAL_TYPE ty) => makeEqIfDifferent tr H ((a, b), ty) 189 | | ((a, b), UNIV_OMEGA k) => makeEqTypeIfDifferent tr H ((a, b), k) 190 | 191 | fun makeAsMem tr H params = makeGoal' tr @@ H >> AJ.View.makeAsMem params 192 | 193 | fun makeAsSubType tr H params = makeGoal' tr @@ H >> AJ.View.makeAsSubType params 194 | 195 | fun makeAsSubTypeIfDifferent tr H = 196 | fn (a, INTERNAL_TYPE b) => makeSubTypeIfDifferent tr H (a, b) 197 | | (a, UNIV_OMEGA k) => SOME @@ makeSubKind tr H (a, k) 198 | end 199 | end 200 | -------------------------------------------------------------------------------- /src/redprl/refiner_misc.fun: -------------------------------------------------------------------------------- 1 | (* other rules 2 | * 3 | * Currently there are: 4 | * - coe 5 | * - computation 6 | * - custom 7 | * *) 8 | functor RefinerMiscRules (Sig : MINI_SIGNATURE) = 9 | struct 10 | structure Kit = RefinerKit (Sig) 11 | open RedPrlAbt Kit 12 | type hyp = Sym.t 13 | infixr @@ 14 | infix 1 || #> 15 | infix 2 >> >: >:? >:+ $$ $# // \ @> 16 | 17 | structure Coe = 18 | struct 19 | fun Eq jdg = 20 | let 21 | val tr = ["Coe.Eq"] 22 | val H >> ajdg = jdg 23 | val ((lhs, rhs), ty) = View.matchAsEq ajdg 24 | val Syn.COE {dir=dir0, ty=(u, ty0u), coercee=m0} = Syn.out lhs 25 | val Syn.COE {dir=dir1, ty=(v, ty1v), coercee=m1} = Syn.out rhs 26 | val () = Assert.dirEq "Coe.Eq direction" (dir0, dir1) 27 | 28 | (* type *) 29 | val w = Sym.new () 30 | val ty0w = substVar (VarKit.toDim w, u) ty0u 31 | val ty1w = substVar (VarKit.toDim w, v) ty1v 32 | val goalTy0 = makeEqType tr (H @> (w, AJ.TERM O.DIM)) ((ty0w, ty1w), K.COE) 33 | (* after proving the above goal, [ty0r'0] must be a type *) 34 | val ty0r'0 = substVar (#2 dir0, u) ty0u 35 | val goalTy = View.makeAsSubTypeIfDifferent tr H (ty0r'0, ty) 36 | 37 | (* coercee *) 38 | val ty0r0 = substVar (#1 dir0, u) ty0u 39 | val goalCoercees = makeEq tr H ((m0, m1), ty0r0) 40 | in 41 | |>: goalCoercees >: goalTy0 >:? goalTy #> (H, axiom) 42 | end 43 | 44 | fun EqCapL jdg = 45 | let 46 | val tr = ["Coe.EqCapL"] 47 | val H >> ajdg = jdg 48 | val ((coe, other), ty) = View.matchAsEq ajdg 49 | val Syn.COE {dir=(r, r'), ty=(u, ty0u), coercee=m} = Syn.out coe 50 | val () = Assert.alphaEq' "Coe.EqCapL source and target of direction" (r, r') 51 | 52 | (* type *) 53 | val goalTy0 = makeType tr (H @> (u, AJ.TERM O.DIM)) (ty0u, K.COE) 54 | (* after proving the above goal, [ty0r] must be a type *) 55 | val ty0r = substVar (r, u) ty0u 56 | val goalTy = View.makeAsSubTypeIfDifferent tr H (ty0r, ty) 57 | 58 | (* eq *) 59 | val goalEq = View.makeAsEq tr H ((m, other), ty) 60 | in 61 | |>: goalEq >: goalTy0 >:? goalTy #> (H, axiom) 62 | end 63 | end 64 | 65 | structure Computation = 66 | struct 67 | fun reduce sign = 68 | Machine.eval sign Machine.STABLE (Machine.Unfolding.default sign) 69 | 70 | fun SequentReduce sign selectors jdg = 71 | let 72 | val tr = ["Computation.Reduce"] 73 | val H >> ajdg = jdg 74 | val (H', ajdg') = Sequent.multiMapSelector selectors (AJ.map (reduce sign)) (H, ajdg) 75 | val (goal, hole) = makeGoal tr @@ H' >> ajdg' 76 | in 77 | |>: goal #> (H, hole) 78 | end 79 | 80 | fun SequentReduceAll sign jdg = 81 | let 82 | val tr = ["Computation.ReduceAll"] 83 | val H >> _ = jdg 84 | val (goal, hole) = makeGoal tr @@ Seq.map (reduce sign) jdg 85 | in 86 | |>: goal #> (H, hole) 87 | end 88 | 89 | fun SequentReducePart sign (selector, accessors) jdg = 90 | let 91 | val tr = ["Computation.ReducePart"] 92 | val H >> ajdg = jdg 93 | val (H', ajdg') = Sequent.mapSelector selector (AJ.multiMapAccessor accessors (reduce sign)) (H, ajdg) 94 | val (goal, hole) = makeGoal tr @@ H' >> ajdg' 95 | in 96 | |>: goal #> (H, hole) 97 | end 98 | end 99 | 100 | (* everything with custom operators *) 101 | structure Custom = 102 | struct 103 | fun unfold sign opids m : abt = 104 | let 105 | infix $ 106 | fun shallowUnfold m = 107 | case out m of 108 | O.CUST (opid',_) $ _ => 109 | (case List.find (fn opid => opid = opid') opids of 110 | SOME _ => 111 | let 112 | val m' = Machine.steps sign Machine.STABLE Machine.Unfolding.always 1 m 113 | handle exn => E.raiseError @@ E.IMPOSSIBLE @@ Fpp.hvsep 114 | [Fpp.text "unfolding", TermPrinter.ppTerm m, Fpp.text ":", E.format exn] 115 | in 116 | deepUnfold m' 117 | end 118 | | NONE => m) 119 | | _ => m 120 | and deepUnfold m = shallowUnfold (Abt.deepMapSubterms shallowUnfold m) 121 | in 122 | deepUnfold m 123 | end 124 | 125 | fun UnfoldAll sign opids jdg = 126 | let 127 | val tr = ["Custom.UnfoldAll"] 128 | val H = 129 | case jdg of 130 | H >> _ => H 131 | val (goal, hole) = makeGoal tr @@ Seq.map (unfold sign opids) jdg 132 | in 133 | |>: goal #> (H, hole) 134 | end 135 | 136 | fun Unfold sign opids selectors jdg = 137 | let 138 | val tr = ["Custom.Unfold"] 139 | val H >> ajdg = jdg 140 | val (H', ajdg') = Sequent.multiMapSelector selectors (AJ.map (unfold sign opids)) (H, ajdg) 141 | val (goal, hole) = makeGoal tr @@ H' >> ajdg' 142 | in 143 | |>: goal #> (H, hole) 144 | end 145 | 146 | fun UnfoldPart sign opids (selector, accessors) jdg = 147 | let 148 | val tr = ["Custom.UnfoldPart"] 149 | val H >> ajdg = jdg 150 | val (H', ajdg') = Sequent.mapSelector selector (AJ.multiMapAccessor accessors (unfold sign opids)) (H, ajdg) 151 | val (goal, hole) = makeGoal tr @@ H' >> ajdg' 152 | in 153 | |>: goal #> (H, hole) 154 | end 155 | 156 | fun Eq sign jdg = 157 | let 158 | val tr = ["Custom.Eq"] 159 | val H >> ajdg = jdg 160 | val ((m, n), ty) = View.matchAsEq ajdg 161 | 162 | val Abt.$ (O.CUST (name, _), args) = Abt.out m 163 | val _ = Assert.alphaEq (m, n) 164 | 165 | val AJ.TRUE specTy = Sig.theoremSpec sign name args 166 | val goalTy = View.makeAsSubTypeIfDifferent tr H (specTy, ty) 167 | in 168 | |>:? goalTy #> (H, axiom) 169 | end 170 | end 171 | end 172 | -------------------------------------------------------------------------------- /src/redprl/signature.sig: -------------------------------------------------------------------------------- 1 | signature SIGNATURE = 2 | sig 3 | type sort 4 | type ast 5 | 6 | (* source language: to be phased out *) 7 | structure Src : 8 | sig 9 | type arguments = (string * Tm.valence) list 10 | type elt = MlExtSyntax.cmd -> MlExtSyntax.cmd 11 | type sign = elt list 12 | end 13 | 14 | val checkSrcSig : Src.sign -> bool 15 | end 16 | -------------------------------------------------------------------------------- /src/redprl/signature.sml: -------------------------------------------------------------------------------- 1 | structure Signature : SIGNATURE = 2 | struct 3 | structure Ast = RedPrlAst and Tm = RedPrlAbt and AJ = AtomicJudgment and Err = RedPrlError 4 | 5 | type ast = Ast.ast 6 | type sort = RedPrlSort.t 7 | type arity = Tm.O.Ar.t 8 | type abt = Tm.abt 9 | type ajdg = AJ.jdg 10 | type valence = Tm.valence 11 | type metavariable = Tm.metavariable 12 | 13 | exception todo 14 | fun ?e = raise e 15 | 16 | structure Ty = MlType 17 | 18 | fun @@ (f, x) = f x 19 | infixr @@ 20 | 21 | fun fail (pos, msg) = 22 | Err.raiseAnnotatedError' (pos, Err.GENERIC [msg]) 23 | 24 | (* The resolver environment *) 25 | structure Res = MlResolver (Ty) 26 | 27 | structure Src = 28 | struct 29 | type arguments = (string * Tm.valence) list 30 | type elt = MlExtSyntax.cmd -> MlExtSyntax.cmd 31 | type sign = elt list 32 | end 33 | 34 | (* external language *) 35 | structure ESyn = MlExtSyntax 36 | 37 | structure Elab = MlElaborate (Res) 38 | structure Eval = MlEvaluate 39 | 40 | fun checkSrcSig (sign : Src.sign) : bool = 41 | let 42 | val emp = ESyn.RET ESyn.NIL 43 | val ecmd = List.foldr (fn (frame, sign) => frame sign) emp sign 44 | val (icmd, _) = Elab.elabCmd ecmd Res.init 45 | val (scmd, exit) = Eval.evalCmd MlSemantics.initEnv icmd 46 | in 47 | exit 48 | end 49 | end 50 | -------------------------------------------------------------------------------- /src/redprl/syntax/abt.sml: -------------------------------------------------------------------------------- 1 | structure RedPrlSym = AbtSymbol () 2 | structure RedPrlVar = RedPrlSym 3 | structure Metavar = RedPrlSym 4 | 5 | structure Sym = RedPrlSym and Var = RedPrlVar 6 | 7 | local 8 | structure AbtKit = 9 | struct 10 | structure Sym = Sym 11 | structure Var = Var 12 | structure Metavar = Metavar 13 | structure O = RedPrlOperator and Operator = RedPrlOperator 14 | type annotation = Pos.t 15 | end 16 | in 17 | structure RedPrlAst = AstUtil (Ast (AbtKit)) 18 | structure RedPrlAbt = Abt (AbtKit) 19 | structure AstToAbt = AstToAbt (structure Ast = RedPrlAst and Abt = RedPrlAbt) 20 | end 21 | -------------------------------------------------------------------------------- /src/redprl/syntax/accessor.sig: -------------------------------------------------------------------------------- 1 | signature ACCESSOR = 2 | sig 3 | datatype t = WHOLE | PART_TYPE | PART_LEFT | PART_RIGHT 4 | val pretty : t -> Fpp.doc 5 | end -------------------------------------------------------------------------------- /src/redprl/syntax/accessor.sml: -------------------------------------------------------------------------------- 1 | structure Accessor :> ACCESSOR = 2 | struct 3 | datatype t = WHOLE | PART_TYPE | PART_LEFT | PART_RIGHT 4 | 5 | val toString = 6 | fn WHOLE => "whole" 7 | | PART_TYPE => "type" 8 | | PART_LEFT => "left" 9 | | PART_RIGHT => "right" 10 | 11 | val pretty = Fpp.text o toString 12 | end -------------------------------------------------------------------------------- /src/redprl/syntax/atomic_judgment.sig: -------------------------------------------------------------------------------- 1 | structure AtomicJudgmentData = 2 | struct 3 | type kind = RedPrlKind.t 4 | type abt = RedPrlAbt.abt 5 | type sort = RedPrlSort.sort 6 | 7 | datatype jdg = 8 | 9 | (* `TRUE a`: 10 | * The term `a` is associated with a PER and there exists a term `m` 11 | * such that `m` is related to itself in that PER. 12 | * 13 | * The realizer is such an `m` of sort `EXP`. 14 | *) 15 | TRUE of abt 16 | 17 | (* `EQ_TYPE ((a, b), k)`: 18 | * The terms `a` and `b` are equal types and have equal structures 19 | * specified by `k`. This implies they have the same PER. 20 | * 21 | * The realizer is `AX` of sort `EXP`. 22 | *) 23 | | EQ_TYPE of (abt * abt) * kind 24 | 25 | (* `SUB_TYPE (a, b)`: 26 | * The terms `a` and `b` are types and the PER associated with `a` 27 | * is a subrelation of the PER associated with `b`. 28 | * 29 | * The realizer is `AX` of sort `EXP`. 30 | *) 31 | | SUB_TYPE of (abt * abt) 32 | 33 | (* `SUB_KIND (a, k)` 34 | * `a` is a sub-universe of the universe of `k` types at the omega level. 35 | * 36 | * The realizer is `AX` of sort `EXP`. 37 | *) 38 | | SUB_KIND of abt * kind 39 | 40 | (* `TERM tau`: 41 | * There exists some term `m` of sort `tau`. 42 | * The realizer is such an `m` of sort `tau`. 43 | *) 44 | | TERM of sort 45 | end 46 | 47 | signature ATOMIC_JUDGMENT = 48 | sig 49 | datatype jdg = datatype AtomicJudgmentData.jdg 50 | type abt = RedPrlAbt.abt 51 | type kind = RedPrlKind.t 52 | 53 | val TYPE : abt * RedPrlKind.t -> jdg 54 | val EQ : (abt * abt) * abt -> jdg 55 | val MEM : abt * abt -> jdg 56 | 57 | val map : (abt -> abt) -> jdg -> jdg 58 | 59 | val synthesis : jdg -> RedPrlAbt.sort 60 | val into : jdg -> abt 61 | val out : abt -> jdg 62 | val eq : jdg * jdg -> bool 63 | val pretty : jdg -> Fpp.doc 64 | val pretty' : TermPrinter.env -> jdg -> Fpp.doc 65 | 66 | val lookupAccessor : Accessor.t -> jdg -> abt 67 | val mapAccessor : Accessor.t -> (abt -> abt) -> (jdg -> jdg) 68 | val multiMapAccessor : Accessor.t list -> (abt -> abt) -> (jdg -> jdg) 69 | val variance : jdg * Accessor.t -> Variance.t 70 | 71 | structure View : 72 | sig 73 | val matchTrueAsEq : jdg -> (abt * abt) * abt 74 | val makeEqAsTrue : (abt * abt) * abt -> jdg 75 | 76 | datatype as_level = FINITE of RedPrlLevel.t | OMEGA 77 | 78 | val matchAsEqType : jdg -> (abt * abt) * as_level * RedPrlKind.t 79 | val makeAsEqType : (abt * abt) * as_level * RedPrlKind.t -> jdg 80 | 81 | datatype as_type = INTERNAL_TYPE of abt | UNIV_OMEGA of RedPrlKind.t 82 | 83 | val matchAsEq : jdg -> (abt * abt) * as_type 84 | val makeAsEq : (abt * abt) * as_type -> jdg 85 | val makeAsMem : abt * as_type -> jdg 86 | val makeAsSubType : abt * as_type -> jdg 87 | 88 | val classifier : jdg * Accessor.t -> as_type 89 | end 90 | end 91 | -------------------------------------------------------------------------------- /src/redprl/syntax/kind.sml: -------------------------------------------------------------------------------- 1 | structure RedPrlKind = 2 | struct 3 | (* 4 | * DISCRETE < KAN < HCOM < PRE 5 | * < COE < 6 | * 7 | * and KAN = meet (HCOM, COE) 8 | *) 9 | 10 | (* Please keep the following invariants when adding new kinds: 11 | * 12 | * (1) All judgments should still be closed under any substitution! In 13 | * particular, the property that a type A has kind K is closed under any 14 | * substitution. 15 | * (2) If two types are related with respect to a stronger kind (like KAN), 16 | * then they are related with respect to a weaker kind (like PRE). 17 | * A stronger kind might demand more things to be equal. For example, 18 | * the equality between two types with respect to KAN means that they 19 | * are equally Kan, while the equality with respect to PRE only says 20 | * they are equal pretypes. 21 | * (3) The PER associated with A should *never* depend on its kind. Kinds 22 | * should be properties of (the PER of) A. 23 | * (4) We say KAN = meet (HCOM, COE) because if two types are equally "HCOM" 24 | * and equally "COE" then they are equally Kan. Always remember to check 25 | * the binary cases. 26 | *) 27 | datatype kind = DISCRETE | KAN | HCOM | COE | PRE 28 | type t = kind 29 | 30 | val COM = KAN 31 | 32 | val toString = 33 | fn DISCRETE => "discrete" 34 | | KAN => "kan" 35 | | HCOM => "hcom" 36 | | COE => "coe" 37 | | PRE => "pre" 38 | 39 | local 40 | structure Internal : 41 | (* this could be the new meet semi-lattice *) 42 | sig 43 | type t = kind 44 | 45 | val top : t 46 | val <= : t * t -> bool 47 | val eq : t * t -> bool 48 | val meet : t * t -> t 49 | 50 | (* residual (a, b) 51 | * 52 | * Let c be the greatest element such that `meet (b, c) <= a`. 53 | * The return value is SOME c if c is not top, or NONE otherwise. 54 | * *) 55 | val residual : t * t -> t option 56 | end 57 | = 58 | struct 59 | type t = kind 60 | val top = PRE 61 | 62 | val meet = 63 | fn (DISCRETE, _) => DISCRETE 64 | | (_, DISCRETE) => DISCRETE 65 | | (KAN, _) => KAN 66 | | (_, KAN) => KAN 67 | | (HCOM, COE) => KAN 68 | | (COE, HCOM) => KAN 69 | | (HCOM, _) => HCOM 70 | | (_, HCOM) => HCOM 71 | | (COE, _) => COE 72 | | (_, COE) => COE 73 | | (PRE, PRE) => PRE 74 | 75 | val residual = 76 | fn (_, DISCRETE) => NONE 77 | | (DISCRETE, _) => SOME DISCRETE 78 | | (_, KAN) => NONE 79 | | (KAN, HCOM) => SOME COE 80 | | (KAN, COE) => SOME HCOM 81 | | (KAN, _) => SOME KAN 82 | | (COE, HCOM) => SOME COE 83 | | (HCOM, COE) => SOME HCOM 84 | | (_, HCOM) => NONE 85 | | (HCOM, _) => SOME HCOM 86 | | (_, COE) => NONE 87 | | (COE, _) => SOME COE 88 | | (PRE, PRE) => NONE 89 | 90 | fun op <= (a, b) = residual (b, a) = NONE 91 | val eq : t * t -> bool = op= 92 | end 93 | in 94 | open Internal 95 | end 96 | end 97 | -------------------------------------------------------------------------------- /src/redprl/syntax/operator.sig: -------------------------------------------------------------------------------- 1 | structure RedPrlOpData = 2 | struct 3 | type opid = MlId.t 4 | type conid = string 5 | 6 | open RedPrlSort 7 | structure K = RedPrlKind 8 | type kind = RedPrlKind.kind 9 | 10 | datatype 'a dev_pattern = 11 | PAT_VAR of 'a 12 | | PAT_TUPLE of (string * 'a dev_pattern) list 13 | 14 | datatype operator = 15 | (* the trivial realizer of sort EXP for types lacking interesting 16 | * computational content. This is the "ax(iom)" in Nuprl. *) 17 | AX 18 | (* bool *) 19 | | BOOL | TT | FF | IF 20 | (* natural numbers *) 21 | | NAT | ZERO | SUCC | NAT_REC 22 | (* integers *) 23 | | INT | POS | NEGSUCC | INT_REC 24 | (* empty type *) 25 | | VOID 26 | (* circle *) 27 | | S1 | BASE | LOOP | S1_REC 28 | (* function: lambda and app *) 29 | | FUN | LAM | APP 30 | (* record and tuple *) 31 | | RECORD of string list | TUPLE of string list | PROJ of string | TUPLE_UPDATE of string 32 | (* path: path abstraction and application *) 33 | | PATH | ABS | DIM_APP 34 | (* lines: paths without fixed endpoints *) 35 | | LINE 36 | (* pushout *) 37 | | PUSHOUT | LEFT | RIGHT | GLUE | PUSHOUT_REC 38 | (* coequalizer *) 39 | | COEQUALIZER | CECOD | CEDOM | COEQUALIZER_REC 40 | 41 | (* inductive types *) 42 | | IND_SPECTYPE_SELF 43 | | IND_SPECTYPE_FUN 44 | 45 | | IND_SPEC_INTRO of conid * RedPrlArity.valence list option (* actually, sort list is enough *) 46 | | IND_SPEC_FCOM | IND_SPEC_LAM | IND_SPEC_APP 47 | 48 | | IND_CONSTR_FUN | IND_CONSTR_SPEC_FUN | IND_CONSTR_LINE 49 | | IND_CONSTR_KAN | IND_CONSTR_DISCRETE 50 | 51 | | IND_FAM_BASE of conid list 52 | | IND_FAM_FUN 53 | | IND_FAM_LINE 54 | 55 | | IND_TYPE of opid * RedPrlArity.valence list option 56 | | IND_INTRO of opid * conid * RedPrlArity.valence list option 57 | | IND_REC of opid * RedPrlArity.valence list option 58 | 59 | (* equality *) 60 | | EQUALITY 61 | (* universe *) 62 | | UNIVERSE 63 | | V 64 | | VIN 65 | | VPROJ 66 | 67 | | FCOM | BOX | CAP | HCOM | GHCOM | COE | COM | GCOM | ECOM 68 | 69 | | MK_ANY of sort option 70 | 71 | (* dimension expressions *) 72 | 73 | | DIM0 74 | | DIM1 75 | | MK_TUBE of sort 76 | | MK_BDRY of sort 77 | | MK_VEC of sort * int 78 | 79 | (* level expressions *) 80 | | LCONST of IntInf.int 81 | | LPLUS of IntInf.int 82 | | LMAX 83 | 84 | | KCONST of kind 85 | 86 | | JDG_TRUE 87 | | JDG_EQ_TYPE 88 | | JDG_SUB_TYPE 89 | | JDG_SUB_KIND 90 | | JDG_SYNTH 91 | | JDG_TERM of sort 92 | 93 | (* primitive tacticals and multitacticals *) 94 | | MTAC_SEQ | MTAC_ORELSE 95 | | MTAC_REPEAT | MTAC_AUTO | MTAC_PROGRESS 96 | | MTAC_ALL | MTAC_EACH | MTAC_FOCUS of int 97 | | MTAC_HOLE of string option 98 | | TAC_FAIL 99 | | TAC_MTAC 100 | 101 | | TAC_ID | TAC_AUTO_STEP | TAC_SYMMETRY | RULE_EXACT 102 | | RULE_CUT 103 | | RULE_PRIM of string 104 | | TAC_ELIM 105 | | TAC_REWRITE 106 | | TAC_REDUCE_ALL 107 | | TAC_REDUCE 108 | | TAC_REDUCE_PART 109 | | TAC_ASSUMPTION 110 | | TAC_POP of sort list 111 | | TAC_PUSH 112 | 113 | (* development calculus terms *) 114 | | DEV_FUN_INTRO of unit dev_pattern list 115 | | DEV_PATH_INTRO of int | DEV_RECORD_INTRO of string list 116 | | DEV_CLAIM of sort option 117 | | DEV_MATCH of int list 118 | | DEV_MATCH_CLAUSE 119 | | DEV_QUERY 120 | | DEV_PRINT 121 | | DEV_BOOL_ELIM 122 | | DEV_S1_ELIM 123 | | DEV_APPLY_HYP of unit dev_pattern 124 | | DEV_USE_HYP 125 | | DEV_INVERSION 126 | 127 | | SEL_CONCL 128 | | SEL_HYP 129 | 130 | | ACC_WHOLE 131 | | ACC_TYPE 132 | | ACC_LEFT 133 | | ACC_RIGHT 134 | 135 | | PAT_META of sort 136 | 137 | | CUST of opid * RedPrlArity.t option 138 | | TAC_UNFOLD_ALL of opid list 139 | | TAC_UNFOLD of opid list 140 | | TAC_UNFOLD_PART of opid list 141 | 142 | | DEV_USE_LEMMA 143 | | DEV_APPLY_LEMMA of unit dev_pattern 144 | end 145 | 146 | signature REDPRL_OPERATOR = 147 | sig 148 | datatype sort = datatype RedPrlSort.sort 149 | datatype operator = datatype RedPrlOpData.operator 150 | datatype dev_pattern = datatype RedPrlOpData.dev_pattern 151 | 152 | include ABT_OPERATOR 153 | where type t = operator 154 | where type Ar.Vl.S.t = sort 155 | 156 | (* TODO: where should this go? *) 157 | val indexToLabel : int -> string 158 | end 159 | -------------------------------------------------------------------------------- /src/redprl/syntax/restriction.sml: -------------------------------------------------------------------------------- 1 | structure Restriction : 2 | sig 3 | (* This structure used to provide functions that automate the 4 | restriction judgement rules given in "Dependent Cubical 5 | Realizability", page 46. 6 | 7 | On 2017/06/14, favonia implemented a function to handle 8 | all cases. 9 | *) 10 | 11 | (* 2018/04/19 favonia 12 | * 13 | * Consider the following two restricted judgments: 14 | * 15 | * i:dim, x:A_i, j:dim >> J [i=j] 16 | * j:dim, x:A_j, i:dim >> J [i=j] 17 | * 18 | * The correct substitution for `[i=j]` has to take the variable 19 | * ordering in the context into consideration. 20 | *) 21 | 22 | (* Restrict a judgement (as the goal) by a list of equations. 23 | * Returns NONE if the resulting judgement is vacuously true. 24 | *) 25 | val restrict : Sequent.hyps 26 | -> (RedPrlAbt.abt * RedPrlAbt.abt) list 27 | -> (RedPrlAbt.abt -> RedPrlAbt.abt) option 28 | (* This variant gives the caller an opportunity to pre-compute the ordering. 29 | * The numbers associated with the variables in the context should be strictly 30 | * increasing from left to right. *) 31 | val restrictWithOrder : int Sym.Ctx.dict 32 | -> (RedPrlAbt.abt * RedPrlAbt.abt) list 33 | -> (RedPrlAbt.abt -> RedPrlAbt.abt) option 34 | end 35 | = 36 | struct 37 | structure Abt = RedPrlAbt 38 | structure Syn = SyntaxView 39 | open Abt 40 | 41 | val createOrderMapping : Sequent.hyps -> int Sym.Ctx.dict 42 | = #1 o Sequent.Hyps.foldl (fn (v, _, (d, s)) => (Sym.Ctx.insert d v s, s + 1)) (Sym.Ctx.empty, 0) 43 | 44 | (* precondition: all term in equations are of sort `DIM` *) 45 | fun restrict' order [] (f : abt -> abt) = SOME f 46 | | restrict' order ((r1, r2) :: eqs) (f : abt -> abt) = 47 | (case (Syn.out r1, Syn.out r2) of 48 | (Syn.DIM0, Syn.DIM0) => restrict' order eqs f 49 | | (Syn.DIM0, Syn.DIM1) => NONE 50 | | (Syn.DIM1, Syn.DIM1) => restrict' order eqs f 51 | | (Syn.DIM1, Syn.DIM0) => NONE 52 | | (Syn.VAR (v1, _), Syn.VAR (v2, _)) => if Abt.eq (r1, r2) then restrict' order eqs f else mergeVarsAndRestrict' order (v1, v2) eqs f 53 | | (Syn.VAR (v1, _), _) => if Abt.eq (r1, r2) then restrict' order eqs f else substAndRestrict' order (r2, v1) eqs f 54 | | (_, Syn.VAR (v2, _)) => substAndRestrict' order (r1, v2) eqs f) 55 | 56 | and mergeVarsAndRestrict' order (v1, v2) eqs f = 57 | let 58 | val (v1, v2) = 59 | if Sym.Ctx.lookup order v1 <= Sym.Ctx.lookup order v2 then 60 | (v1, v2) 61 | else 62 | (v2, v1) 63 | in 64 | restrict' order 65 | (List.map (fn (r, r') => (VarKit.rename (v2, v1) r, VarKit.rename (v2, v1) r')) eqs) 66 | (VarKit.rename (v2, v1) o f) 67 | end 68 | 69 | and substAndRestrict' order rv eqs f = 70 | restrict' order 71 | (List.map (fn (r, r') => (substVar rv r, substVar rv r')) eqs) 72 | (substVar rv o f) 73 | 74 | fun restrictWithOrder order eqs = restrict' order eqs (fn x => x) 75 | fun restrict hyps = restrictWithOrder (createOrderMapping hyps) 76 | end 77 | -------------------------------------------------------------------------------- /src/redprl/syntax/selector.sig: -------------------------------------------------------------------------------- 1 | signature SELECTOR = 2 | sig 3 | datatype 'a t = IN_CONCL | IN_HYP of 'a 4 | val variance : 'a t -> Variance.t 5 | end 6 | -------------------------------------------------------------------------------- /src/redprl/syntax/selector.sml: -------------------------------------------------------------------------------- 1 | structure Selector :> SELECTOR = 2 | struct 3 | datatype 'a t = IN_CONCL | IN_HYP of 'a 4 | 5 | val variance = 6 | fn IN_CONCL => Variance.COVAR 7 | | IN_HYP _ => Variance.CONTRAVAR 8 | end -------------------------------------------------------------------------------- /src/redprl/syntax/sequent.sig: -------------------------------------------------------------------------------- 1 | signature SEQUENT = 2 | sig 3 | datatype atjdg = datatype AtomicJudgment.jdg 4 | type abt = RedPrlAbt.abt 5 | type variable = RedPrlAbt.variable 6 | 7 | type hyps 8 | 9 | datatype jdg = 10 | (* sequents / formal hypothetical judgment *) 11 | >> of hyps * atjdg 12 | 13 | val map : (abt -> abt) -> jdg -> jdg 14 | 15 | (* specialized to abt *) 16 | val pretty : jdg -> Fpp.doc 17 | val eq : jdg * jdg -> bool 18 | val relabel : Sym.t Sym.Ctx.dict -> jdg -> jdg 19 | 20 | structure Hyps : 21 | sig 22 | val empty : hyps 23 | val isEmpty : hyps -> bool 24 | val snoc : hyps -> variable -> atjdg -> hyps 25 | val foldr : (variable * atjdg * 'b -> 'b) -> 'b -> hyps -> 'b 26 | val foldl : (variable * atjdg * 'b -> 'b) -> 'b -> hyps -> 'b 27 | val toList : hyps -> abt list 28 | val lookup : hyps -> variable -> atjdg 29 | val substAfter : variable * abt -> hyps -> hyps 30 | val remove : variable -> hyps -> hyps 31 | val splice : hyps -> variable -> hyps -> hyps 32 | val singleton : variable -> atjdg -> hyps 33 | val map : (atjdg -> atjdg) -> (hyps -> hyps) 34 | val interposeAfter : variable * hyps -> hyps -> hyps 35 | val interposeThenSubstAfter : variable * hyps * abt -> hyps -> hyps 36 | val modifyAfter : variable -> (atjdg -> atjdg) -> hyps -> hyps 37 | end 38 | 39 | val lookupSelector : Sym.t Selector.t -> hyps * atjdg -> atjdg 40 | val mapSelector : Sym.t Selector.t -> (atjdg -> atjdg) -> hyps * atjdg -> hyps * atjdg 41 | val multiMapSelector : Sym.t Selector.t list -> (atjdg -> atjdg) -> hyps * atjdg -> hyps * atjdg 42 | 43 | (* TODO: I don't like this function. *) 44 | val truncateFrom : Sym.t Selector.t -> hyps -> hyps 45 | 46 | 47 | val push : variable list -> jdg -> jdg 48 | val popAs : variable list -> jdg -> jdg 49 | end 50 | -------------------------------------------------------------------------------- /src/redprl/syntax/sort.sig: -------------------------------------------------------------------------------- 1 | structure SortData = 2 | struct 3 | datatype sort = 4 | EXP 5 | | TAC 6 | | MTAC 7 | | JDG 8 | | MATCH_CLAUSE 9 | | DIM 10 | | TUBE of sort 11 | | BDRY of sort 12 | | VEC of sort 13 | | LVL 14 | | KND 15 | | SEL 16 | | ACC 17 | | ANY 18 | | META_NAME 19 | | IND_SPECTYPE (* argument types in Part IV *) 20 | | IND_SPEC (* boundary terms in Part IV *) 21 | | IND_FAM (* the data associated with an inductive type *) 22 | | IND_CONSTR (* the data associated with a constructor in Part IV *) 23 | end 24 | 25 | signature REDPRL_SORT = 26 | sig 27 | datatype sort = datatype SortData.sort 28 | include ABT_SORT where type t = sort 29 | end 30 | -------------------------------------------------------------------------------- /src/redprl/syntax/sort.sml: -------------------------------------------------------------------------------- 1 | structure RedPrlSort :> REDPRL_SORT = 2 | struct 3 | datatype sort = datatype SortData.sort 4 | type t = sort 5 | 6 | val eq : t * t -> bool = 7 | op= 8 | 9 | val rec toString = 10 | fn EXP => "exp" 11 | | TAC => "tac" 12 | | MTAC => "mtac" 13 | | JDG => "jdg" 14 | | MATCH_CLAUSE => "match-clause" 15 | | DIM => "dim" 16 | | TUBE tau => "tube{" ^ toString tau ^ "}" 17 | | BDRY tau => "bdry{" ^ toString tau ^ "}" 18 | | VEC tau => "vec{" ^ toString tau ^ "}" 19 | | LVL => "lvl" 20 | | KND => "knd" 21 | | SEL => "sel" 22 | | ACC => "acc" 23 | | ANY => "any" 24 | | META_NAME => "meta-name" 25 | | IND_SPECTYPE => "ind-spectype" 26 | | IND_SPEC => "ind-spec" 27 | | IND_FAM => "ind-fam" 28 | | IND_CONSTR => "ind-constr" 29 | end 30 | 31 | structure RedPrlArity = ListAbtArity (structure S = RedPrlSort) 32 | -------------------------------------------------------------------------------- /src/redprl/syntax/univ_level.sig: -------------------------------------------------------------------------------- 1 | signature REDPRL_LEVEL = 2 | sig 3 | type level 4 | type t = level 5 | 6 | type term 7 | 8 | val const : IntInf.int -> level (* the input must >= 0 *) 9 | val zero : level 10 | val plus : level * IntInf.int -> level (* the second argument must >= 0 *) 11 | val succ : level -> level 12 | val join : level * level -> level 13 | val max : level list -> level 14 | 15 | val <= : level * level -> bool 16 | val < : level * level -> bool 17 | val eq : level * level -> bool 18 | 19 | val residual : level * level -> level option 20 | 21 | val into : level -> term 22 | val out : term -> level 23 | val map : (term -> term) -> level -> level 24 | end 25 | -------------------------------------------------------------------------------- /src/redprl/syntax/univ_level.sml: -------------------------------------------------------------------------------- 1 | structure RedPrlRawLevel = 2 | struct 3 | structure E = RedPrlError 4 | structure D = Metavar.Ctx 5 | structure TP = TermPrinter 6 | 7 | (* normal form: minimum distance from zero and other variables *) 8 | type level = IntInf.int * IntInf.int D.dict 9 | type t = level 10 | type term = RedPrlAbt.abt 11 | 12 | (* smart constructors *) 13 | fun const i = (i, D.empty) : level 14 | val zero = const 0 : level 15 | fun plus ((gap, gapmap) : level, i) = 16 | let 17 | fun shift x = x + i 18 | in 19 | (shift gap, D.map shift gapmap) 20 | end 21 | fun succ l = plus (l, 1) 22 | fun join ((gap0, gapmap0), (gap1, gapmap1)) = 23 | (IntInf.max (gap0, gap1), 24 | D.union gapmap0 gapmap1 (fn (_, g0, g1) => IntInf.max (g0, g1))) 25 | val max = List.foldl join zero 26 | 27 | fun allBound f ((gap0, gapmap0), (gap1, gapmap1)) = 28 | f (gap0, gap1) andalso 29 | List.all 30 | (fn (var, g0) => 31 | case D.find gapmap1 var of 32 | SOME g1 => f (g0, g1) 33 | | NONE => false) 34 | (D.toList gapmap0) 35 | val op <= : level * level -> bool = allBound IntInf.<= 36 | val op < : level * level -> bool = allBound IntInf.< 37 | fun eq ((gap0, gapmap0) : level, (gap1, gapmap1) : level) = 38 | gap0 = gap1 andalso 39 | ListPair.allEq 40 | (fn ((v0, g0), (v1, g1)) => Var.eq (v0, v1) andalso g0 = g1) 41 | (D.toList gapmap0, D.toList gapmap1) 42 | 43 | (* augmented semi-lattice *) 44 | fun residual (l0, l1) = if l1 <= l0 then NONE else SOME l0 45 | 46 | local 47 | open RedPrlAbt 48 | structure O = RedPrlOpData 49 | infix $ \ $$ $# 50 | in 51 | (* parser and generator *) 52 | fun out (tm : term) : level = 53 | case RedPrlAbt.out tm of 54 | x $# [] => (0, D.singleton x 0) 55 | | O.LCONST i $ _ => const i 56 | | O.LPLUS i $ [_ \ l] => plus (out l, i) 57 | | O.LMAX $ [_ \ vec] => max (outVec vec) 58 | | _ => E.raiseError (E.INVALID_LEVEL (TermPrinter.ppTerm tm)) 59 | 60 | and outVec tm = 61 | case RedPrlAbt.out tm of 62 | O.MK_VEC _ $ xs => List.map (fn _ \ x => out x) xs 63 | | _ => E.raiseError (E.INVALID_LEVEL (TermPrinter.ppTerm tm)) 64 | 65 | 66 | fun constToTerm i = O.LCONST i $$ [] 67 | 68 | fun makeVar x = 69 | check (x $# [], O.LVL) 70 | 71 | fun makeVec xs = 72 | O.MK_VEC (O.LVL, List.length xs) $$ List.map (fn x => [] \ x) xs 73 | 74 | fun varGapToTerm (x, i) = 75 | if i = 0 then makeVar x 76 | else O.LPLUS i $$ [[] \ makeVar x] 77 | 78 | val maxToTerm : abt list -> abt = 79 | fn [] => constToTerm 0 80 | | [arg] => arg 81 | | args => O.LMAX $$ [[] \ makeVec args] 82 | 83 | fun into ((gap, gapmap) : level) = 84 | let 85 | val varGapList = List.map varGapToTerm (D.toList gapmap) 86 | val gapImpliedByMap = D.foldl (fn (_, a, b) => IntInf.max (a, b)) 0 gapmap 87 | val args = 88 | if gap > gapImpliedByMap 89 | then constToTerm gap :: varGapList 90 | else varGapList 91 | in 92 | maxToTerm args 93 | end 94 | 95 | fun map f = out o f o into 96 | end 97 | end 98 | 99 | functor LevelUtil (L : REDPRL_LEVEL) = 100 | struct 101 | open L 102 | structure WithKind = 103 | struct 104 | fun eq ((l1, k1), (l2, k2)) = L.eq (l1, l2) andalso k1 = k2 105 | fun residual ((l1, k1), (l2, k2)) = 106 | case (L.residual (l1, l2), RedPrlKind.residual (k1, k2)) of 107 | (NONE, NONE) => NONE 108 | | (SOME l, NONE) => SOME (l, RedPrlKind.top) 109 | | (NONE, SOME k) => SOME (l1, k) 110 | | (SOME l, SOME k) => SOME (l, k) 111 | end 112 | structure WK = WithKind 113 | end 114 | 115 | structure RedPrlLevel = LevelUtil (RedPrlRawLevel) 116 | -------------------------------------------------------------------------------- /src/redprl/syntax/variable_kit.sml: -------------------------------------------------------------------------------- 1 | (* variable kit *) 2 | 3 | structure VarKit = 4 | struct 5 | fun ctxFromList l = 6 | List.foldl 7 | (fn ((tm, x), dict) => Var.Ctx.insert dict x tm) 8 | Var.Ctx.empty l 9 | 10 | structure Syn = SyntaxView 11 | fun toExp x = Syn.into (Syn.VAR (x, RedPrlSort.EXP)) 12 | fun toDim x = Syn.into (Syn.VAR (x, RedPrlSort.DIM)) 13 | 14 | fun fromTerm e = 15 | let 16 | val Syn.VAR (x, _) = Syn.out e 17 | in 18 | x 19 | end 20 | 21 | val renameMany = RedPrlAbt.renameVars o ctxFromList 22 | fun rename r = renameMany [r] 23 | 24 | val substMany = RedPrlAbt.substVarenv o ctxFromList 25 | fun subst s = substMany [s] 26 | 27 | fun alphaRenameTubes w = List.map (fn (eq, (u, tube)) => (eq, rename (w, u) tube)) 28 | end 29 | -------------------------------------------------------------------------------- /src/redprl/syntax/variance.sig: -------------------------------------------------------------------------------- 1 | structure VarianceData = 2 | struct 3 | (* favonia: I do not like the current usage of "invariant" in many PLs, 4 | * so I coined the word "anti-variant". *) 5 | datatype variance = COVAR | CONTRAVAR | ANTIVAR 6 | end 7 | 8 | signature VARIANCE = 9 | sig 10 | datatype t = datatype VarianceData.variance 11 | 12 | val compose : t * t -> t 13 | val flip : t -> t 14 | end -------------------------------------------------------------------------------- /src/redprl/syntax/variance.sml: -------------------------------------------------------------------------------- 1 | structure Variance :> VARIANCE = 2 | struct 3 | datatype t = datatype VarianceData.variance 4 | 5 | val compose = 6 | fn (ANTIVAR, _) => ANTIVAR 7 | | (_, ANTIVAR) => ANTIVAR 8 | | (COVAR, COVAR) => COVAR 9 | | (CONTRAVAR, CONTRAVAR) => COVAR 10 | | (COVAR, CONTRAVAR) => CONTRAVAR 11 | | (COTRAVAR, COVAR) => CONTRAVAR 12 | 13 | (* variants *) 14 | val flip = 15 | fn COVAR => CONTRAVAR 16 | | CONTRAVAR => COVAR 17 | | ANTIVAR => ANTIVAR 18 | end -------------------------------------------------------------------------------- /src/redprl/tactical.fun: -------------------------------------------------------------------------------- 1 | functor RedPrlTactical (Lcf : LCF_TACTIC) : 2 | sig 3 | type multitactic = Lcf.jdg Lcf.multitactic 4 | type tactic = Lcf.jdg Lcf.tactic 5 | 6 | val all : tactic -> multitactic 7 | val each : tactic list -> multitactic 8 | val only : int * tactic -> multitactic 9 | val mprogress: multitactic -> multitactic 10 | val progress : tactic -> tactic 11 | val mrec : (multitactic -> multitactic) -> multitactic 12 | val trec : (tactic -> tactic) -> tactic 13 | val multitacToTac : multitactic -> tactic 14 | val seq : multitactic * multitactic -> multitactic 15 | val then_ : tactic * tactic -> tactic 16 | val thenl : tactic * tactic list -> tactic 17 | val orelse_ : tactic * tactic -> tactic 18 | val par : tactic * tactic -> tactic 19 | val morelse : multitactic * multitactic -> multitactic 20 | val mrepeat : multitactic -> multitactic 21 | val repeat : tactic -> tactic 22 | val try : tactic -> tactic 23 | val idn : tactic 24 | end = 25 | struct 26 | open Lcf 27 | 28 | type multitactic = Lcf.jdg Lcf.multitactic 29 | type tactic = Lcf.jdg Lcf.tactic 30 | 31 | fun mrec (f : multitactic -> multitactic) : multitactic = 32 | fn st => 33 | f (mrec f) st 34 | 35 | fun trec (f : tactic -> tactic) : tactic = 36 | fn jdg => 37 | f (trec f) jdg 38 | 39 | 40 | fun multitacToTac (mt : multitactic) : tactic = 41 | fn jdg => 42 | Lcf.M.map (Lcf.mul Lcf.isjdg) (Lcf.M.mul (Lcf.M.map mt (Lcf.idn jdg))) 43 | 44 | 45 | fun seq (mt1 : multitactic, mt2 : multitactic) : multitactic = fn st => 46 | let 47 | val st' = mt1 st 48 | in 49 | Lcf.M.mul (Lcf.M.map (mt2 o Lcf.mul Lcf.isjdg) st') 50 | end 51 | 52 | val all = allSeq 53 | val each = eachSeq 54 | 55 | fun mtry (mt : multitactic) : multitactic = 56 | morelse (mt, all idn) 57 | 58 | fun mrepeat (mt : multitactic) : multitactic = 59 | mrec (fn mt' => mtry (seq (mprogress mt, mt'))) 60 | 61 | fun repeat (t : tactic) : tactic = 62 | trec (fn t' => try (then_ (progress t, t'))) 63 | end 64 | -------------------------------------------------------------------------------- /src/redprl/test.sml: -------------------------------------------------------------------------------- 1 | structure Test = 2 | struct 3 | 4 | fun stringreader s = 5 | let 6 | val pos = ref 0 7 | val remainder = ref (String.size s) 8 | fun min(a, b) = if a < b then a else b 9 | in 10 | fn n => 11 | let 12 | val m = min(n, !remainder) 13 | val s = String.substring(s, !pos, m) 14 | val () = pos := !pos + m 15 | val () = remainder := !remainder - m 16 | in 17 | s 18 | end 19 | end 20 | 21 | fun error (s, pos, pos') = raise Fail (Pos.toString (Pos.pos pos pos') ^ ": " ^ s) 22 | 23 | fun parse text = 24 | let 25 | val lexer = RedPrlParser.makeLexer (stringreader text) "asdfadsf" 26 | val (res,_) = RedPrlParser.parse (1, lexer, error, "welp") 27 | in 28 | res 29 | end 30 | 31 | fun testFile fileName = 32 | let 33 | val input = TextIO.inputAll (TextIO.openIn fileName) 34 | val sign = parse input 35 | in 36 | Signature.check sign 37 | end 38 | 39 | end 40 | -------------------------------------------------------------------------------- /test/failure/bad-hcom-empty.prl: -------------------------------------------------------------------------------- 1 | theorem MalformedTube : 2 | wbool true 3 | by { 4 | `(hcom 0~>1 wbool tt) 5 | }. 6 | -------------------------------------------------------------------------------- /test/failure/bad-hcom-stuck.prl: -------------------------------------------------------------------------------- 1 | theorem Bool : 2 | wbool true 3 | by { 4 | `(hcom 0~>1 wbool tt [0=1 [_] tt]); 5 | auto 6 | }. 7 | -------------------------------------------------------------------------------- /test/failure/bad-op.prl: -------------------------------------------------------------------------------- 1 | define Foo(#a : exp, #b : exp) : exp = (-> #a #b) . 2 | 3 | theorem Foo-bool-type : (Foo bool) typeby { 4 | auto 5 | }. 6 | -------------------------------------------------------------------------------- /test/failure/freemeta.prl: -------------------------------------------------------------------------------- 1 | define Cmp(#f : exp, #g : exp) : exp = 2 | (lam [x] ($ #f ($ #h x))) 3 | . 4 | -------------------------------------------------------------------------------- /test/failure/freevar.prl: -------------------------------------------------------------------------------- 1 | theorem FreeVar : x true by { 2 | auto 3 | }. 4 | -------------------------------------------------------------------------------- /test/failure/incremental-parse.prl: -------------------------------------------------------------------------------- 1 | // Three copies of the same theorem. The second one has a syntax error 2 | // (curlys instead of squares around the proof), but the first and 3 | // last ones are just fine, and should be processed by RedPRL despite 4 | // the error in the middle. 5 | 6 | theorem Foo : tt = tt in bool by { 7 | auto 8 | }. 9 | 10 | theorem Bar : tt = tt in bool ] by { 11 | auto 12 | }. 13 | 14 | Thm Baz : [ tt = tt in bool by { 15 | auto 16 | }. 17 | 18 | print Foo. -------------------------------------------------------------------------------- /test/failure/kind-hcom.prl: -------------------------------------------------------------------------------- 1 | theorem Path/Symm(#l:lvl) : 2 | ty : (U #l) 3 | >> 4 | ty type with hcom 5 | by { 6 | auto 7 | }. 8 | -------------------------------------------------------------------------------- /test/failure/lexical-error.prl: -------------------------------------------------------------------------------- 1 | theorem LexicalError : (-> bool bool) true by { 2 | (lam x => `_tt); auto 3 | }. 4 | -------------------------------------------------------------------------------- /test/failure/num.prl: -------------------------------------------------------------------------------- 1 | theorem NegOne : 2 | -1 in nat 3 | by { 4 | auto 5 | }. 6 | -------------------------------------------------------------------------------- /test/failure/record0.prl: -------------------------------------------------------------------------------- 1 | theorem RecordTest : 2 | tuple in (record [a : bool]) 3 | by { 4 | auto 5 | }. 6 | -------------------------------------------------------------------------------- /test/failure/record1.prl: -------------------------------------------------------------------------------- 1 | theorem RecordTest : 2 | (! a tuple) in bool 3 | by { 4 | auto 5 | }. 6 | -------------------------------------------------------------------------------- /test/failure/record2.prl: -------------------------------------------------------------------------------- 1 | theorem RecordTest : 2 | (! a (tuple [b tt])) in bool 3 | by { 4 | auto 5 | }. 6 | -------------------------------------------------------------------------------- /test/failure/record3.prl: -------------------------------------------------------------------------------- 1 | theorem DuplicateLabel : 2 | (tuple [a tt]) in (record [a a : bool]) 3 | by { 4 | auto 5 | }. 6 | -------------------------------------------------------------------------------- /test/failure/record4.prl: -------------------------------------------------------------------------------- 1 | theorem DuplicateLabel : 2 | (tuple [a tt] [a tt]) in (record [a : bool]) 3 | by { 4 | auto 5 | }. 6 | -------------------------------------------------------------------------------- /test/failure/undef-custom.prl: -------------------------------------------------------------------------------- 1 | define Not : exp = 2 | (lam [x] (if x ff tt)) 3 | . 4 | 5 | print Not. 6 | 7 | // [Not] should still be printed, even though the 8 | // following theorem is malformed. 9 | 10 | theorem Foo : Bar = Bar in bool by { 11 | auto 12 | }. 13 | -------------------------------------------------------------------------------- /test/success/S1-fcom.prl: -------------------------------------------------------------------------------- 1 | theorem Fcom/trans3 : 2 | (-> [a b c d : S1] 3 | (path [_] S1 a b) 4 | (path [_] S1 a c) 5 | (path [_] S1 b d) 6 | (path [_] S1 c d)) 7 | by { 8 | lam a b c d pab pac pbd => 9 | abs i => `(fcom 0~>1 (@ pab i) [i=0 [j] (@ pac j)] [i=1 [j] (@ pbd j)]) 10 | }. 11 | 12 | print Fcom/trans3. 13 | 14 | theorem Fcom/trans2 : 15 | (-> [a b c : S1] 16 | (path [_] S1 a b) 17 | (path [_] S1 b c) 18 | (path [_] S1 a c)) 19 | by { 20 | lam a b c pab pbc => 21 | abs i => `(fcom 0~>1 (@ pab i) [i=0 [_] a] [i=1 [j] (@ pbc j)]) 22 | }. 23 | 24 | theorem Fcom/symm : 25 | (-> [a b : S1] 26 | (path [_] S1 a b) 27 | (path [_] S1 b a)) 28 | by { 29 | lam a b pab => 30 | abs i => `(fcom 0~>1 a [i=0 [j] (@ pab j)] [i=1 [_] a]) 31 | }. 32 | 33 | theorem Tube : 34 | (-> 35 | [x : S1] 36 | (= S1 (fcom 0~>1 x [1=1 [_] x] [0=0 [_] x]) x)) 37 | by { 38 | lam x => auto 39 | }. 40 | 41 | theorem TrueByEvaluation : 42 | (fcom 0~>0 base) in S1 43 | by { 44 | auto 45 | }. 46 | -------------------------------------------------------------------------------- /test/success/S1.prl: -------------------------------------------------------------------------------- 1 | theorem Loop : 2 | (path [_] S1 base base) 3 | by { 4 | abs u => `(loop u) 5 | }. 6 | 7 | theorem LoopBetaEasiest(#i:lvl) : 8 | (-> [u : dim] [a : (U #i)] [x : a] 9 | (= a (S1-rec [_] a (loop u) x [_] x) x)) 10 | by { 11 | abs u => lam a x => 12 | refine s1/beta/loop; 13 | auto 14 | }. 15 | 16 | theorem LoopBetaEasier(#i:lvl) : 17 | (-> [u : dim] [a : (-> S1 (U #i))] 18 | [b : ($ a base)] [l : (path [v] ($ a (loop v)) b b)] 19 | (= ($ a (loop u)) (S1-rec [x] a (loop u) b [v] (@ l v)) (@ l u))) 20 | by { 21 | abs u => lam a b l => 22 | refine s1/beta/loop; 23 | auto 24 | }. 25 | 26 | -------------------------------------------------------------------------------- /test/success/V-types.prl: -------------------------------------------------------------------------------- 1 | define HasAllPathsTo (#C,#c) = (-> [c' : #C] (path [_] #C c' #c)). 2 | 3 | define IsContr (#C) = (* [c : #C] (HasAllPathsTo #C c)). 4 | 5 | define Fiber (#A,#B,#f,#b) = (* [a : #A] (path [_] #B ($ #f a) #b)). 6 | 7 | define IsEquiv (#A,#B,#f) = (-> [b : #B] (IsContr (Fiber #A #B #f b))). 8 | 9 | define Equiv (#A,#B) = (* [f : (-> #A #B)] (IsEquiv #A #B f)). 10 | 11 | define Id = (lam [a] a). 12 | 13 | theorem IdIsEquiv(#l:lvl) : 14 | (-> [ty : (U #l hcom)] (IsEquiv ty ty Id)) 15 | by { 16 | lam ty a => 17 | { {use a, abs _ => use a} 18 | , lam {_,c'} => abs i => 19 | { `(hcom 1~>0 ty a 20 | [i=0 [j] (@ c' j)] 21 | [i=1 [j] a]) 22 | , abs j => 23 | `(hcom 1~>j ty a 24 | [i=0 [j] (@ c' j)] 25 | [i=1 [j] a]) 26 | } 27 | } 28 | }. 29 | 30 | theorem IdEquiv(#l:lvl) : 31 | (-> [ty : (U #l hcom)] (Equiv ty ty)) 32 | by { 33 | lam ty => 34 | {`Id, use (IdIsEquiv #l) [use ty]} 35 | }. 36 | 37 | print IdEquiv. 38 | 39 | define IdV(#i:dim, #l:lvl, #ty) = 40 | (V #i #ty #ty ($ (IdEquiv #l) #ty)) 41 | . 42 | 43 | theorem IdV/Wf(#l:lvl) : 44 | (-> 45 | [i : dim] 46 | [ty : (U #l hcom)] 47 | (mem (U #l) (IdV i #l ty))) 48 | by { 49 | abs i => lam ty => auto 50 | }. 51 | 52 | theorem IdV/Test0(#l:lvl) : 53 | (-> 54 | [i : dim] 55 | [ty : (U #l hcom)] 56 | [a : ty] 57 | (mem (IdV i #l ty) (Vin i a a))) 58 | by { 59 | abs i => lam ty a => auto 60 | }. 61 | 62 | theorem IdV/Test1(#l:lvl) : 63 | (-> 64 | [ty : (U #l hcom)] 65 | [a : ty] 66 | (= ty (Vproj (dim 0) (Vin (dim 0) a a) Id) a)) 67 | by { 68 | lam ty a => auto 69 | }. 70 | 71 | theorem IdV/Test2(#l:lvl) : 72 | (-> 73 | [ty : (U #l kan)] 74 | [a : ty] 75 | (= ty (coe 0~>1 [x] (IdV x #l ty) a) 76 | (coe 0~>1 [_] ty a))) 77 | by { 78 | lam ty a => auto 79 | }. 80 | 81 | print IdV/Test2. 82 | 83 | define Not = (lam [b] (if [_] bool b ff tt)). 84 | 85 | theorem Bool/reflect : 86 | (-> 87 | [a b : bool] 88 | [p : (path [_] bool a b)] 89 | (= bool a b)) 90 | by { 91 | lam a b p => `(coe 0~>1 [x] (= bool a (@ p x)) ax) 92 | }. 93 | 94 | tactic Bool/contra/inverse (#p:exp) = { 95 | query gl <- concl; 96 | match gl { 97 | [a b | #jdg{%a = %b in bool} => 98 | claim eq : (= bool %b %a) by {use Bool/reflect [`%b, `%a, `#p]; auto}; 99 | symmetry; auto 100 | ] 101 | [a | %[a:jdg] => id] 102 | } 103 | }. 104 | 105 | theorem NotIsEquiv : 106 | (IsEquiv bool bool Not) 107 | by { 108 | lam b => 109 | { {`($ Not b), abs _ => use b} 110 | , lam {_,p'} => 111 | (abs i => 112 | { `($ Not (hcom 1~>0 bool b 113 | [i=0 [j] (@ p' j)] 114 | [i=1 [j] b])) 115 | , abs j => 116 | `(hcom 1~>j bool b 117 | [i=0 [j] (@ p' j)] 118 | [i=1 [j] b]) 119 | } 120 | ); auto; (Bool/contra/inverse p'); assumption 121 | } 122 | }. 123 | 124 | theorem NotEquiv : 125 | (Equiv bool bool) 126 | by { 127 | {`Not, `NotIsEquiv} 128 | }. 129 | 130 | define NotV(#i:dim) = (V #i bool bool NotEquiv). 131 | 132 | theorem NotV/Wf : 133 | (-> [i : dim] (mem (U 0 kan) (NotV i))) 134 | by { 135 | abs i => auto 136 | }. 137 | 138 | theorem NotV/Test0 : 139 | (-> 140 | [i : dim] 141 | [a : bool] 142 | (mem (NotV i) (Vin i ($ Not a) a))) 143 | by { 144 | abs i => lam a => auto 145 | }. 146 | 147 | theorem NotV/Test1 : 148 | (-> 149 | [a : bool] 150 | (= bool (coe 0~>1 [x] (NotV x) a) ($ Not a))) 151 | by { 152 | lam a => auto 153 | }. 154 | 155 | theorem NotV/Test2 : 156 | (-> 157 | [a : bool] 158 | (= bool (coe 1~>0 [x] (NotV x) a) ($ Not a))) 159 | by { 160 | lam a => auto 161 | }. 162 | -------------------------------------------------------------------------------- /test/success/bool-pair-test.prl: -------------------------------------------------------------------------------- 1 | theorem Test : (* bool bool) = (* bool bool) type by { 2 | auto 3 | }. 4 | 5 | print Test. -------------------------------------------------------------------------------- /test/success/dashes-n-slashes.prl: -------------------------------------------------------------------------------- 1 | // Identifiers can contain hyphens and slashes 2 | theorem Ident-test/ : bool by { 3 | `tt 4 | }. 5 | -------------------------------------------------------------------------------- /test/success/decomposition.prl: -------------------------------------------------------------------------------- 1 | theorem Decomposition : 2 | (-> 3 | (record [rcd : (record [a : bool] [b : (* bool int)])] [circ : S1]) 4 | bool) 5 | by { 6 | lam x => 7 | let {rcd = {a = a, b = {welp}}, circ = circ} = x; 8 | use welp 9 | }. 10 | 11 | print Decomposition. 12 | 13 | theorem Apply : 14 | (-> 15 | (-> 16 | bool 17 | bool 18 | (path [_] 19 | (record [a : S1]) 20 | (tuple [a base]) 21 | (tuple [a base]))) 22 | S1) 23 | by { 24 | lam f => 25 | let {a = a} = f [`tt, `ff, `(dim 0)]; 26 | use a 27 | }. 28 | 29 | 30 | 31 | print Apply. 32 | 33 | theorem UseHypTest : 34 | (-> bool bool) 35 | by { 36 | lam x => 37 | claim p : (-> bool S1 bool) by {lam b c => use b}; 38 | use p [use x, `(loop 0)] 39 | }. 40 | 41 | print UseHypTest. 42 | 43 | theorem UseLemmaTest : 44 | (-> bool bool) 45 | by { 46 | lam x => 47 | use UseHypTest [use x] 48 | }. 49 | -------------------------------------------------------------------------------- /test/success/discrete-types.prl: -------------------------------------------------------------------------------- 1 | theorem Discrete/reflection(#l:lvl) : 2 | (-> 3 | [ty : (U #l discrete)] 4 | [a b : ty] 5 | [p : (path [_] ty a b)] 6 | (= ty a b)) 7 | by { 8 | lam ty a b p => `(coe 0~>1 [x] (= ty a (@ p x)) ax) 9 | }. 10 | -------------------------------------------------------------------------------- /test/success/empty.prl: -------------------------------------------------------------------------------- 1 | // This is an empty signature 2 | -------------------------------------------------------------------------------- /test/success/equality-elim.prl: -------------------------------------------------------------------------------- 1 | tactic GetHole(#c : [exp].exp, #t : [exp].tac) = { 2 | query gl <- concl; 3 | match gl { 4 | [hole | #jdg{(#c %hole)} => (#t %hole)] 5 | } 6 | }. 7 | 8 | // We can write a cool user-defined tactic for claiming and then rewriting along an equality. 9 | // (Rewrite n a [x] c) matches the goal against the motive "[x] c" and rewrites along 10 | // the equality [_ = n in a]. 11 | tactic Rewrite(#c : [exp].exp, #n, #a, #t : tac) = { 12 | (GetHole [x] (#c x) [hole] #tac{ 13 | claim p : hole = #n in #a by {#t}; 14 | // Use the elimination rule for equality. We bind a new hypothesis which will represent the location 15 | // in the goal #c which is being rewritten. 16 | rewrite p; 17 | [with x => `(#c x), id, auto, auto] 18 | }) 19 | }. 20 | 21 | theorem EqualityElimTest : 22 | (-> [b : bool] (path [_] bool tt (if [_] bool tt tt ff))) 23 | by { 24 | // We're going to prove this in a silly way to illustrate equality elimination. 25 | // We'll rewrite the goal by claiming (if tt tt ff) = tt in bool. 26 | (Rewrite 27 | [x] (-> bool (path [_] bool tt x)) 28 | tt bool #tac{auto}); 29 | // observe that the goal has now been rewritten! 30 | ?check-this-out; 31 | lam b => abs _ => `tt 32 | }. 33 | -------------------------------------------------------------------------------- /test/success/equality.prl: -------------------------------------------------------------------------------- 1 | theorem EqualityKind0(#A) : 2 | (-> 3 | [ty : (U 0 pre)] 4 | [a b : ty] 5 | (= (U 0 hcom) (= ty a b) (= ty a b))) 6 | by { 7 | lam ty a b => auto 8 | }. 9 | 10 | theorem EqualityKind1(#A) : 11 | (-> 12 | [ty : (U 0 discrete)] 13 | [a b : ty] 14 | (= (U 0 kan) (= ty a b) (= ty a b))) 15 | by { 16 | lam ty a b => auto 17 | }. 18 | -------------------------------------------------------------------------------- /test/success/fcom-types.prl: -------------------------------------------------------------------------------- 1 | theorem Fcom/bool : 2 | (-> [i : dim] 3 | (mem (U 0) (fcom 0~>1 bool [i=0 [j] bool] [i=1 [j] bool]))) 4 | by { 5 | abs i => auto 6 | }. 7 | 8 | print Fcom/bool. 9 | 10 | theorem Fcom/Box : 11 | (-> [i : dim] 12 | (mem 13 | (fcom 0~>1 bool [i=0 [j] bool] [i=1 [j] bool]) 14 | (box 0~>1 tt [i=0 tt] [i=1 tt]))) 15 | by { 16 | abs i => auto 17 | }. 18 | 19 | print Fcom/Box. 20 | 21 | theorem Fcom/Reduce : 22 | (fcom 0~>1 bool [0=0 [j] bool]) = bool type 23 | by { 24 | auto 25 | }. 26 | 27 | theorem Fcom/Cap1 : 28 | tt in (fcom 0~>1 bool [0=0 [j] bool]) 29 | by { 30 | auto 31 | }. 32 | 33 | theorem Fcom/Cap2 : 34 | (cap 0<~1 (box 0~>1 tt [0=0 tt]) [0=0 [j] bool]) in bool 35 | by { 36 | auto 37 | }. 38 | -------------------------------------------------------------------------------- /test/success/hcom.prl: -------------------------------------------------------------------------------- 1 | theorem Hcom/Poly(#l:lvl) : 2 | (-> 3 | [ty : (U #l hcom)] 4 | [a b c d : ty] 5 | (path [_] ty a b) 6 | (path [_] ty a c) 7 | (path [_] ty b d) 8 | (path [_] ty c d)) 9 | by { 10 | lam ty a b c d pab pac pbd => 11 | abs i => 12 | `(hcom 0~>1 ty (@ pab i) 13 | [i=0 [j] (@ pac j)] 14 | [i=1 [j] (@ pbd j)]) 15 | }. 16 | 17 | print Hcom/Poly. 18 | 19 | theorem Hcom/trans(#l:lvl) : 20 | (-> 21 | [ty : (U #l hcom)] 22 | [a b c : ty] 23 | (path [_] ty a b) 24 | (path [_] ty b c) 25 | (path [_] ty a c)) 26 | by { 27 | lam ty a b c pab pbc => 28 | abs i => 29 | `(hcom 0 ~> 1 ty (@ pab i) 30 | [i=0 [_] a] 31 | [i=1 [j] (@ pbc j)]) 32 | }. 33 | 34 | print Hcom/trans. 35 | 36 | theorem Hcom/symm(#l:lvl) : 37 | (-> 38 | [ty : (U #l hcom)] 39 | [a b : ty] 40 | (path [_] ty a b) 41 | (path [_] ty b a)) 42 | by { 43 | lam ty a b pab => 44 | abs i => 45 | `(hcom 0~>1 ty a 46 | [i=0 [j] (@ pab j)] 47 | [i=1 [_] a]) 48 | }. 49 | 50 | print Hcom/symm. 51 | 52 | // An example of using the internalized exact equality type. 53 | theorem Cap(#l:lvl) : 54 | (-> 55 | [ty : (U #l hcom)] 56 | [x : ty] 57 | [i : dim] 58 | (= ty 59 | (hcom 0~>0 ty x [i=0 [_] x] [i=1 [_] x]) 60 | x)) 61 | by { 62 | lam ty x => abs i => auto 63 | }. 64 | 65 | 66 | 67 | theorem Tube(#l:lvl) : 68 | (-> 69 | [ty : (U #l hcom)] 70 | [x : ty] 71 | (= ty 72 | (hcom 0~>1 ty x [1=1 [_] x] [0=0 [_] x]) 73 | x)) 74 | by { 75 | lam ty x => auto 76 | }. 77 | 78 | theorem TrueByEvaluation : 79 | (hcom 0~>0 bool tt) in bool 80 | by { 81 | auto 82 | }. 83 | -------------------------------------------------------------------------------- /test/success/inductive-S1.prl: -------------------------------------------------------------------------------- 1 | data S1' : (U 0 kan) 2 | { base' 3 | , loop' [x : dim] [x=0 (self base')] [x=1 (self base')] 4 | } 5 | by { 6 | auto 7 | }. 8 | 9 | theorem Loop' : 10 | (path [_] (. S1' type) (. S1' base') (. S1' base')) 11 | by { 12 | abs u => `(. S1' loop' u) 13 | }. 14 | 15 | print Loop'. 16 | -------------------------------------------------------------------------------- /test/success/inductive.prl: -------------------------------------------------------------------------------- 1 | data S1' : (U 0 kan) 2 | { base' 3 | , loop' [x : dim] [x=0 (self base')] [x=1 (self base')] 4 | } 5 | by { 6 | auto 7 | }. 8 | 9 | data Pushout' (#l:lvl) 10 | [a b c : (U #l coe)] 11 | [f : (-> c a)] 12 | [g : (-> c b)] 13 | : (U #l kan) 14 | { left' a 15 | , right' b 16 | , glue' [x : c] [y : dim] [y=0 (self left' ($ f x))] [y=1 (self right' ($ g x))] 17 | } 18 | by { 19 | auto 20 | }. 21 | 22 | data PropTrunc (#l:lvl) [a : (U 0 coe)] : (U 0 kan) { 23 | pt a, 24 | sq [x y : self] [z : dim] [z=0 x] [z=1 y] 25 | } by { auto }. 26 | -------------------------------------------------------------------------------- /test/success/lines.prl: -------------------------------------------------------------------------------- 1 | theorem Line/Test0 : 2 | (-> 3 | [a : (U 0 kan)] 4 | [l : (-> dim a)] 5 | (= a (coe 0~>1 [_] a (@ l 0)) (@ (coe 0~>1 [_] (-> dim a) l) 0))) 6 | by { 7 | lam a l => `ax 8 | }. 9 | 10 | theorem Line/Test1 : 11 | (-> 12 | [ty : (U 0 kan)] 13 | [p : (line [_] ty)] 14 | (path [_] ty (@ p 0) (@ p 1))) 15 | by { 16 | lam ty p => abs x => `(@ p x) 17 | }. 18 | 19 | 20 | theorem Line/Trans : 21 | (-> 22 | [ty : (U 0 kan)] 23 | [p : (line [_] ty)] 24 | [q : (line [_] ty)] 25 | [eq : (= ty (@ p 1) (@ q 0))] 26 | (path [_] ty (@ p 0) (@ q 1))) 27 | by { 28 | (lam ty p q eq => abs x => 29 | `(hcom 0~>1 ty (@ p x) 30 | [x=0 [_] (@ p 0)] 31 | [x=1 [y] (@ q y)])); 32 | 33 | repeat {assumption || auto-step} 34 | }. 35 | 36 | theorem Line/Symm : 37 | (-> 38 | [ty : (U 0 kan)] 39 | [p : (line [_] ty)] 40 | (path [_] ty (@ p 1) (@ p 0))) 41 | by { 42 | lam ty p => abs x => 43 | `(hcom 0~>1 ty (@ p 0) 44 | [x=0 [y] (@ p y)] 45 | [x=1 [_] (@ p 0)]) 46 | }. 47 | 48 | print Line/Trans. 49 | -------------------------------------------------------------------------------- /test/success/logical-investigations.prl: -------------------------------------------------------------------------------- 1 | // Some theorems from http://www.nuprl.org/MathLibrary/LogicalInvestigations/. 2 | 3 | theorem Thm1 : 4 | (-> 5 | [p q : (U 0)] 6 | p q p) 7 | by { 8 | lam p q a b => use a 9 | }. 10 | 11 | theorem Thm2 : 12 | (-> 13 | [p q r : (U 0)] 14 | (-> p q) 15 | (-> p q r) 16 | p r) 17 | by { 18 | lam p q r f g a => 19 | use g [use a, use f [use a]] 20 | }. 21 | 22 | // It is worthwhile to print out the extract program / evidence for Thm2. 23 | print Thm2. 24 | 25 | // here's a proof using lower-level scripting 26 | theorem Thm3/low-level : 27 | (-> 28 | [p q r : (U 0)] 29 | (-> p q) 30 | (-> q r) 31 | (-> p r)) 32 | by { 33 | // fresh p q r pq qr x -> 34 | repeat {refine fun/intro || id}; 35 | auto; with x qr pq r q p => 36 | elim qr; elim pq; 37 | [ use x 38 | , with _ y => use y 39 | , use x 40 | , with _ _ _ z => use z 41 | ] 42 | }. 43 | 44 | print Thm3/low-level. 45 | 46 | // here's a high-level version of the above proof. proofs using the high-level 47 | // programming calculus may be longer, but they are often easier to engineer, 48 | // and nicely segregate main goals from auxiliary goals. 49 | theorem Thm3/high-level : 50 | (-> 51 | [p q r : (U 0)] 52 | (-> p q) 53 | (-> q r) 54 | (-> p r)) 55 | by { 56 | lam p q r f g x => 57 | use g [use f [use x]] 58 | }. 59 | 60 | print Thm3/high-level. 61 | 62 | define Not(#A) = (-> #A void) . 63 | 64 | theorem Thm4 : 65 | (-> [p q : (U 0)] (Not p) p q) 66 | by { 67 | lam p q r a => 68 | unfold Not; 69 | let boom = r [use a]; 70 | elim boom 71 | }. 72 | 73 | theorem Thm5 : 74 | (-> [p : (U 0)] p (Not (Not p))) 75 | by { 76 | lam p a => unfold Not; lam r => 77 | use r [use a] 78 | }. 79 | 80 | print Thm4. 81 | print Thm5. 82 | 83 | 84 | theorem Thm6(#A,#B) : 85 | (-> [p q : (U 0)] (-> p q) (Not q) (Not p)) 86 | by { 87 | lam p q f g => unfold Not; lam a => 88 | use g [use f [use a]] 89 | }. 90 | 91 | print Thm6. 92 | -------------------------------------------------------------------------------- /test/success/match.prl: -------------------------------------------------------------------------------- 1 | tactic QueryGoalType(#t : [exp].tac) = { 2 | query gl <- concl; 3 | match gl { 4 | [a | #jdg{%a true} => (#t %a)] 5 | } 6 | }. 7 | 8 | theorem MatchGoal : (-> bool bool bool bool bool bool) by { 9 | repeat { 10 | (QueryGoalType [ty] #tac{ 11 | match ty { 12 | [a b | (-> [x:%a] (%b x)) => refine fun/intro; [id, auto]] 13 | } 14 | }) 15 | }; 16 | 17 | with _ _ y => use y 18 | }. 19 | 20 | print MatchGoal. 21 | -------------------------------------------------------------------------------- /test/success/num.prl: -------------------------------------------------------------------------------- 1 | theorem One : 2 | (int 1) in int 3 | by { 4 | auto 5 | }. 6 | 7 | theorem NegOne : 8 | (int -1) in int 9 | by { 10 | auto 11 | }. 12 | 13 | theorem NatOne : 14 | (nat 1) in nat 15 | by { 16 | auto 17 | }. 18 | 19 | theorem NatIsInt : 20 | (-> [x : nat] (mem int (pos x))) 21 | by { 22 | lam x => auto 23 | }. 24 | 25 | theorem Pred : 26 | (-> nat nat) 27 | by { 28 | lam a => 29 | elim a; 30 | [ `zero ]; 31 | [ with a' ind => `a' ] 32 | }. 33 | 34 | theorem Plus : 35 | (-> nat nat nat) 36 | by { 37 | lam a => 38 | elim a; 39 | [ lam x => use x 40 | , with ind a' => 41 | lam x => 42 | let ih/x = ind [use x]; `(succ ih/x) 43 | ] 44 | }. 45 | 46 | theorem Plus/wf : 47 | Plus in (-> nat nat nat) 48 | by { 49 | auto 50 | }. 51 | 52 | theorem Plus/zeroL : 53 | (-> [n : nat] (= nat ($ Plus (nat 0) n) n)) 54 | by { 55 | lam n => auto 56 | }. 57 | 58 | theorem Plus/zero/R : 59 | (-> [n : nat] (= nat ($ Plus n (nat 0)) n)) 60 | by { 61 | lam n => 62 | elim n; 63 | [ `ax 64 | , with ind n' => 65 | rewrite ind at left; 66 | [ with x => `(succ x) ]; 67 | auto 68 | ] 69 | }. 70 | 71 | theorem Plus/succ/L : 72 | (-> [n m : nat] (= nat ($ Plus (succ n) m) (succ ($ Plus n m)))) 73 | by { 74 | lam n m => auto 75 | }. 76 | 77 | theorem Plus/succ/R : 78 | (-> [n m : nat] (= nat ($ Plus n (succ m)) (succ ($ Plus n m)))) 79 | by { 80 | lam n m => elim n; 81 | [ auto 82 | , with n'/ih n' => rewrite ($ Plus/succ/L n' (succ m)) at left; 83 | [ with x => `x 84 | , rewrite ($ Plus/succ/L n' m) at right; 85 | [ with x => `(succ x) 86 | , rewrite n'/ih at left; 87 | [ with x => `(succ x) ] 88 | ] 89 | ] 90 | ]; 91 | 92 | auto 93 | }. 94 | 95 | theorem Plus/test0 : 96 | (-> [n m : nat] [eq : (= nat ($ Plus n zero) m)] (= nat n m)) 97 | by { 98 | lam n m eq => 99 | rewrite ($ Plus/zero/R n) in eq at left; 100 | [ with x => `x ]; auto; use eq 101 | }. 102 | 103 | theorem Eq/sym : 104 | (-> [ty : (U 0)] [a b : ty] (= ty a b) (= ty b a)) 105 | by { 106 | lam ty a b eq => symmetry; use eq 107 | }. 108 | 109 | theorem Plus/comm : 110 | (-> [n m : nat] (= nat ($ Plus n m) ($ Plus m n))) 111 | by { 112 | lam n m => elim n; 113 | [ symmetry; `($ Plus/zero/R m) 114 | , with n'/ih n' => rewrite ($ Plus/succ/L n' m) at left; 115 | [ with x => `x 116 | , rewrite n'/ih at left; 117 | [ with x => `(succ x) 118 | , symmetry; `($ Plus/succ/R m n') 119 | ] 120 | ] 121 | ]; 122 | 123 | auto 124 | }. 125 | 126 | theorem NatSymm : 127 | (-> 128 | [a b : nat] 129 | (path [_] nat a b) 130 | (path [_] nat b a)) 131 | by { 132 | lam a b pab => 133 | abs i => 134 | `(hcom 0~>1 nat a 135 | [i=0 [j] (@ pab j)] 136 | [i=1 [_] a]) 137 | }. 138 | 139 | theorem IntPred : 140 | (-> int int) 141 | by { 142 | lam a => elim a; 143 | [ with n => elim n; 144 | [ `(int -1) 145 | , with _ n' => `(pos n') 146 | ] 147 | , with n => `(negsucc (succ n)) 148 | ]; 149 | }. 150 | 151 | theorem IntSucc : 152 | (-> int int) 153 | by { 154 | lam a => elim a; 155 | [ with n => `(pos (succ n)) 156 | , with n => elim n; 157 | [ `(int 0) 158 | , with _ n' => `(negsucc n') 159 | ] 160 | ] 161 | }. 162 | 163 | theorem IntPlus : 164 | (-> int int int) 165 | by { 166 | lam a => elim a; 167 | [ with n => elim n; 168 | [ lam b => use b 169 | , with ind a' => lam b => `($ IntSucc ($ ind b)) 170 | ] 171 | , with n => elim n; 172 | [ lam b => `($ IntPred b) 173 | , with ind a' => lam b => `($ IntPred ($ ind b)) 174 | ] 175 | ] 176 | }. 177 | 178 | theorem Int4Plus3 : 179 | ($ IntPlus (int 4) (int 3)) = (int 7) in int 180 | by { auto }. 181 | 182 | theorem Int-6Plus10 : 183 | ($ IntPlus (int -6) (int 10)) = (int 4) in int 184 | by { auto }. 185 | 186 | theorem Int-1Plus-9 : 187 | ($ IntPlus (int -1) (int -9)) = (int -10) in int 188 | by { auto }. 189 | -------------------------------------------------------------------------------- /test/success/path-ap-const.prl: -------------------------------------------------------------------------------- 1 | theorem PathApConst : 2 | (-> (path [_] bool tt tt) bool) 3 | by { 4 | lam p => use p [`(dim 0)] 5 | }. 6 | 7 | print PathApConst. 8 | -------------------------------------------------------------------------------- /test/success/primitive-sequencing.prl: -------------------------------------------------------------------------------- 1 | theorem PrimitiveSequencingTest : (-> bool bool bool bool) by { 2 | repeat {refine fun/intro || id}; auto; 3 | with z y x => use y 4 | }. 5 | 6 | print PrimitiveSequencingTest. 7 | -------------------------------------------------------------------------------- /test/success/pushout.prl: -------------------------------------------------------------------------------- 1 | theorem Pushout/Test0 : 2 | (pushout record record bool [_] tuple [_] tuple) 3 | by { 4 | `(left tuple) 5 | }. 6 | 7 | theorem Pushout/Test1 : 8 | (pushout bool bool bool [x] x [x] x) 9 | by { 10 | `(right tt) 11 | }. 12 | 13 | theorem Pushout/Test2 : 14 | (-> dim (pushout bool bool bool [x] x [x] x)) 15 | by { 16 | abs u => `(glue u tt tt tt) 17 | }. 18 | 19 | define S1' = (pushout record record bool [_] tuple [_] tuple). 20 | 21 | // Someone told me the following is an equivalence 22 | theorem PushoutToS1 : 23 | (-> S1' S1) 24 | by { 25 | lam p => elim p; 26 | [ `base 27 | , `base 28 | , with c u:dim => 29 | elim c; 30 | [ `(loop u) 31 | , `base 32 | ] 33 | ]; 34 | auto 35 | }. 36 | 37 | 38 | theorem PushoutToS1/Test0 : 39 | (= (-> S1' S1) PushoutToS1 PushoutToS1) 40 | by { 41 | unfold PushoutToS1; // otherwise too easy 42 | refine fun/eq/lam; 43 | [ refine pushout/eq/pushout-rec; auto 44 | , auto 45 | ] 46 | }. 47 | 48 | theorem PushoutBetaEasiest(#i:lvl) : 49 | (-> [a b c d : (U #i)] [w : d] 50 | [u : dim] [x : a] [y : b] [z : c] 51 | (= d (pushout-rec [_] d (glue u z x y) [_] w [_] w [_ _] w) w)) 52 | by { 53 | lam a b c d w => abs u => lam x y z => 54 | refine pushout/beta/glue; 55 | auto 56 | }. 57 | 58 | theorem PushoutBetaEasier(#i:lvl) : 59 | (-> [a b c : (U #i)] [f : (-> c a)] [g : (-> c b)] 60 | [d : (-> (pushout a b c [z] ($ f z) [z] ($ g z)) (U #i))] 61 | [wl : (-> [x : a] ($ d (left x)))] [wr : (-> [y : b] ($ d (right y)))] 62 | [wg : (-> [z : c] (path [v] ($ d (glue v z ($ f z) ($ g z))) ($ wl ($ f z)) ($ wr ($ g z)))) ] 63 | [u : dim] [m : c] 64 | (= ($ d (glue u m ($ f m) ($ g m))) 65 | (pushout-rec [p] ($ d p) (glue u m ($ f m) ($ g m)) [x] ($ wl x) [y] ($ wr y) [v z] (@ ($ wg z) v)) 66 | (@ ($ wg m) u))) 67 | by { 68 | lam a b c f g d wl wr wg => abs u => lam m => 69 | refine pushout/beta/glue; 70 | auto 71 | }. 72 | -------------------------------------------------------------------------------- /test/success/record.prl: -------------------------------------------------------------------------------- 1 | theorem RecordTypeTest : 2 | (record [a : bool] [b : (path [_] bool a a)] [c : bool] [d : S1]) type 3 | by { 4 | auto 5 | }. 6 | 7 | print RecordTypeTest. 8 | 9 | theorem RecordTest0 : 10 | tuple in record 11 | by { 12 | auto 13 | }. 14 | 15 | theorem RecordTest1 : 16 | (tuple [a tt]) in (record [a : bool]) 17 | by { 18 | auto 19 | }. 20 | 21 | theorem RecordTest2 : 22 | (tuple [a tt] [b tuple]) in (record [b : record] [a : bool]) 23 | by { 24 | auto 25 | }. 26 | 27 | theorem RecordTest3 : 28 | (tuple [a tt] [b ff]) in (record [b a : bool]) 29 | by { 30 | auto 31 | }. 32 | 33 | theorem RecordTest4 : 34 | (! a (tuple [a tt] [b ff])) = tt in bool 35 | by { 36 | auto 37 | }. 38 | 39 | theorem RecordTest5(#p) : 40 | (-> [p : record] (= record p tuple)) 41 | by { 42 | lam _ => auto 43 | }. 44 | 45 | theorem RecordTest6 : 46 | (-> 47 | [p : (record [a : bool] [b c : record])] 48 | bool) 49 | by { 50 | lam {a = a} => use a 51 | }. 52 | 53 | theorem RecordTest7 : 54 | (record 55 | [a : S1] 56 | [b : (path [_] S1 a a)]) 57 | by { 58 | {a = `base, b = abs i => `(loop i)} 59 | }. 60 | 61 | theorem RecordElimTest : 62 | (-> 63 | (record 64 | [b : bool] 65 | [c : S1] 66 | [p : (path [_] bool b b)]) 67 | (* [b : bool] (path [_] bool b b))) 68 | by { 69 | lam {b = welp, p = hello} => 70 | {use welp, use hello} 71 | }. 72 | 73 | print RecordElimTest. -------------------------------------------------------------------------------- /test/success/strict-bool.prl: -------------------------------------------------------------------------------- 1 | define Cmp(#m, #n) = 2 | (lam [x] ($ #m ($ #n x))) 3 | . 4 | 5 | define Bool/Not = 6 | (lam [x] (if [_] bool x ff tt)) 7 | . 8 | 9 | theorem Bool/Not-Not-Id : 10 | (Cmp Bool/Not Bool/Not) = (lam [x] x) in (-> bool bool) 11 | by { 12 | auto 13 | }. 14 | 15 | theorem SBool/Not-Not-Id-Path : 16 | (path 17 | [_] (-> bool bool) 18 | (Cmp Bool/Not Bool/Not) 19 | (lam [x] x)) 20 | by { 21 | abs i => lam x => use x 22 | }. 23 | 24 | print SBool/Not-Not-Id-Path. 25 | -------------------------------------------------------------------------------- /test/success/unfold.prl: -------------------------------------------------------------------------------- 1 | define Times(#A, #B) = 2 | (* #A #B) 3 | . 4 | 5 | tactic Proj1(#z) = { 6 | let {x} = #z; 7 | use x 8 | }. 9 | 10 | tactic Proj2(#z) = { 11 | let {welp, x} = #z; 12 | use x 13 | }. 14 | 15 | theorem Times/Proj : 16 | (-> [ty : (U 0)] (Times bool ty) ty) 17 | by { 18 | lam ty x => (Proj2 x) 19 | }. 20 | 21 | print Times/Proj. 22 | -------------------------------------------------------------------------------- /test/success/universes.prl: -------------------------------------------------------------------------------- 1 | theorem Univ0(#i:lvl, #j:lvl) : 2 | (U #i) in (U (++ (lmax #i #j))) 3 | by { 4 | auto 5 | }. 6 | 7 | theorem Univ1(#i:lvl) : 8 | nat in (U #i discrete) 9 | by { 10 | auto 11 | }. 12 | 13 | theorem Univ2 : 14 | (-> 15 | [a : (U 0 discrete)] 16 | (= (U 1 kan) a a)) 17 | by { 18 | lam a => auto 19 | }. 20 | 21 | theorem Monoid(#i:lvl) : (U (++ #i)) by { 22 | `(record 23 | [ob : (U #i)] 24 | [one : ob] 25 | [mul : (-> ob ob ob)] 26 | [idn/l : (-> [m : ob] (= ob ($ mul one m) m))] 27 | [idn/r : (-> [m : ob] (= ob ($ mul m one) m))] 28 | [assoc : 29 | (-> 30 | [l m n : ob] 31 | (= ob 32 | ($ mul l ($ mul m n)) 33 | ($ mul ($ mul m n) l)))]) 34 | }. 35 | 36 | print Monoid. 37 | -------------------------------------------------------------------------------- /vim/README.md: -------------------------------------------------------------------------------- 1 | # redprl.vim 2 | 3 | This vim plugin requires Vim 8 (released September 2016). 4 | 5 | ## Use 6 | 7 | While editing a .prl file, run `:RedPRL` or `l` (`l` for `load`) 8 | in the command (normal) mode to check the current buffer and display the output 9 | in a separate buffer. Run `p` (`p` for `partial`) to check the current 10 | buffer, ignoring lines below the cursor's current position. 11 | 12 | If there are any syntax errors, the cursor will jump to the first one. 13 | 14 | ## Setup 15 | 16 | This plugin is compatible with Vim 8's package system. You can (re)install it by 17 | running the following shell command from the current directory: 18 | 19 | DEST=~/.vim/pack/redprl-org/start ; 20 | [ -d $DEST/vim-redprl ] && rm -r $DEST/vim-redprl ; 21 | mkdir -p $DEST && cp -r . $DEST/vim-redprl 22 | 23 | If `redprl` is not in your `PATH`, add the following line to your `.vimrc`: 24 | 25 | let g:redprl_path = '/path/to/redprl' 26 | 27 | If you want to enable printing traces, add the following line to your `.vimrc`: 28 | 29 | let g:redprl_trace = 1 30 | -------------------------------------------------------------------------------- /vim/ftdetect/redprl.vim: -------------------------------------------------------------------------------- 1 | " vim-RedPRL ftdetect 2 | " Language: RedPRL 3 | " Author: Carlo Angiuli 4 | " Last Change: 2017 December 5 5 | 6 | au BufNewFile,BufRead *.prl setf redprl 7 | -------------------------------------------------------------------------------- /vim/ftplugin/redprl.vim: -------------------------------------------------------------------------------- 1 | " vim-RedPRL ftplugin 2 | " Language: RedPRL 3 | " Author: Carlo Angiuli 4 | " Last Change: 2018 October 9 5 | 6 | if (exists("b:did_ftplugin") || !has('job')) 7 | finish 8 | endif 9 | 10 | if (!exists('g:redprl_trace')) 11 | let g:redprl_trace = 0 12 | endif 13 | 14 | if (!exists('g:redprl_path')) 15 | let g:redprl_path = 'redprl' 16 | endif 17 | 18 | command! RedPRL :call CheckBuffer() 19 | nnoremap l :RedPRL 20 | nnoremap p :call CheckBufferToCursor() 21 | autocmd QuitPre call s:CloseBuffer() 22 | 23 | set errorformat =%E%f:%l.%c-%*\\d.%*\\d\ [%trror]: 24 | set errorformat+=%Z%m 25 | 26 | " Optional argument: the last line to send to RedPRL (default: all). 27 | function! CheckBuffer(...) 28 | if (exists('s:job')) 29 | call job_stop(s:job, 'int') 30 | endif 31 | 32 | if (!bufexists('RedPRL') || (winbufnr(bufwinnr('RedPRL')) != bufnr('RedPRL'))) 33 | belowright vsplit RedPRL 34 | call s:InitBuffer() 35 | else 36 | execute bufwinnr('RedPRL') . 'wincmd w' 37 | endif 38 | silent %d 39 | wincmd p 40 | 41 | let s:job = job_start(g:redprl_path . 42 | \(g:redprl_trace ? ' --trace' : '') . 43 | \' --width=' . s:EditWidth() . 44 | \' --from-stdin=' . bufname('%'), { 45 | \'in_io': 'buffer', 'in_buf': bufnr('%'), 46 | \'in_bot': exists('a:1') ? a:1 : line('$'), 47 | \'out_io': 'buffer', 'out_name': 'RedPRL', 'out_msg': 0, 48 | \'err_io': 'buffer', 'err_msg': 0, 49 | \'exit_cb': 'CheckBufferExit'}) 50 | endfunction 51 | 52 | function! CheckBufferToCursor() 53 | call CheckBuffer(line('.')) 54 | endfunction 55 | 56 | function! CheckBufferExit(j,status) 57 | let errbuf = ch_getbufnr(a:j, 'err') 58 | if (errbuf != -1) 59 | execute 'cgetbuffer ' . errbuf 60 | execute 'bwipeout ' . errbuf 61 | call setqflist([], 'r', {'title': 'RedPRL Errors'}) 62 | endif 63 | if (len(getqflist()) > 1) 64 | copen 65 | cc 66 | else 67 | cclose 68 | endif 69 | endfunction 70 | 71 | function! s:InitBuffer() 72 | set buftype=nofile 73 | set syntax=redprl 74 | set noswapfile 75 | if (has('folding')) 76 | set foldmethod=expr 77 | set foldexpr=getline(v:lnum)=~'^$'?0:1 78 | set foldlevel=1 79 | endif 80 | endfunction 81 | 82 | function! s:EditWidth() 83 | execute bufwinnr('RedPRL') . 'wincmd w' 84 | 85 | let l:width = winwidth(winnr()) 86 | if (has('linebreak') && (&number || &relativenumber)) 87 | let l:width -= &numberwidth 88 | endif 89 | if (has('folding')) 90 | let l:width -= &foldcolumn 91 | endif 92 | if (has('signs')) 93 | redir => l:signs 94 | silent execute 'sign place buffer=' . bufnr('%') 95 | redir END 96 | if (&signcolumn == "yes" || len(split(l:signs, "\n")) > 2) 97 | let l:width -= 2 98 | endif 99 | endif 100 | 101 | wincmd p 102 | return l:width 103 | endfunction 104 | 105 | function! s:CloseBuffer() 106 | cclose 107 | if (bufexists('RedPRL') && !getbufvar('RedPRL', '&modified')) 108 | bdelete RedPRL 109 | endif 110 | endfunction 111 | 112 | let b:did_ftplugin = 1 113 | -------------------------------------------------------------------------------- /vim/syntax/redprl.vim: -------------------------------------------------------------------------------- 1 | " vim-RedPRL syntax 2 | " Language: RedPRL 3 | " Author: Carlo Angiuli 4 | " Last Change: 2018 March 21 5 | 6 | if exists("b:current_syntax") 7 | finish 8 | endif 9 | 10 | setlocal iskeyword=@,48-57,-,',/ 11 | 12 | syn sync minlines=50 13 | 14 | syn match redprlParenErr ')' 15 | syn match redprlBrackErr ']' 16 | 17 | syn region redprlEncl transparent start="(" end=")" contains=ALLBUT,redprlParenErr 18 | syn region redprlEncl transparent start="\[" end="\]" contains=ALLBUT,redprlBrackErr 19 | 20 | syn keyword redprlDecl data define print theorem tactic quit extract 21 | syn keyword redprlSort dim hyp exp lvl tac jdg knd 22 | syn match redprlHole '?\k*' 23 | syn match redprlMeta '#' 24 | 25 | syn keyword redprlExpr ax fcom bool tt ff if nat 26 | syn keyword redprlExpr zero succ nat-rec int pos negsucc int-rec void S1 base loop 27 | syn keyword redprlExpr S1-rec lam record tuple path line pushout left right glue 28 | syn keyword redprlExpr pushout-rec coeq cecod cedom coeq-rec self rec mem ni box cap ecom V 29 | syn keyword redprlExpr Vin Vproj U abs hcom com ghcom gcom coe lmax omega 30 | syn match redprlExpr '[$*!@=+]\|->\|\~>\|<\~' 31 | 32 | syn keyword redprlTac auto auto-step case cut-lemma elim else exact goal 33 | syn keyword redprlTac hyp id lemma let claim match of print trace progress 34 | syn keyword redprlTac query reduce refine repeat rewrite symmetry 35 | syn keyword redprlTac then unfold use with without fail inversion concl assumption 36 | syn match redprlTac '[;`]' 37 | 38 | syn keyword redprlSeq at by in true type synth discrete kan pre 39 | 40 | syn region redprlComm start="\k\@1