pax_global_header00006660000000000000000000000064147201121710014506gustar00rootroot0000000000000052 comment=5b372d0469dbd3762c6572f3582f0e07090ab512 Mtac2-1.4-coq8.20/000077500000000000000000000000001472011217100134105ustar00rootroot00000000000000Mtac2-1.4-coq8.20/.github/000077500000000000000000000000001472011217100147505ustar00rootroot00000000000000Mtac2-1.4-coq8.20/.github/workflows/000077500000000000000000000000001472011217100170055ustar00rootroot00000000000000Mtac2-1.4-coq8.20/.github/workflows/backport.yml000066400000000000000000000004221472011217100213330ustar00rootroot00000000000000name: Backport on: pull_request: types: - closed - labeled jobs: backport: runs-on: ubuntu-18.04 name: Backport steps: - name: Backport uses: tibdex/backport@v1 with: github_token: ${{ secrets.GITHUB_TOKEN }} Mtac2-1.4-coq8.20/.github/workflows/main.yml000066400000000000000000000046021472011217100204560ustar00rootroot00000000000000# This is a basic workflow to help you get started with Actions name: CI # Controls when the action will run. on: # Triggers the workflow on push or pull request events but only for the master branch push: branches: [ master, master-*, staging, trying ] pull_request: branches: [ master, master-*, staging, trying ] # Allows you to run this workflow manually from the Actions tab workflow_dispatch: # A workflow run is made up of one or more jobs that can run sequentially or in parallel jobs: build: name: build # The type of runner that the job will run on runs-on: ubuntu-latest strategy: matrix: # Browse URL: https://github.com/coq-community/docker-coq/wiki#supported-tags # to get the list of supported (coq, ocaml) versions in coqorg/coq. coq_version: # - '8.15' - '8.20' ocaml_version: - '4.14-flambda' # at most 20 concurrent jobs per free account: # https://help.github.com/en/actions/reference/workflow-syntax-for-github-actions#usage-limits max-parallel: 4 # don't cancel all in-progress jobs if one matrix job fails: fail-fast: false # Steps represent a sequence of tasks that will be executed as part of the job. steps: # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it. - uses: actions/checkout@v2 - uses: coq-community/docker-coq-action@v1 # See https://github.com/coq-community/docker-coq-action#readme # for details on docker-coq-action's syntax and provided features. with: opam_file: 'opam' coq_version: ${{ matrix.coq_version }} ocaml_version: ${{ matrix.ocaml_version }} export: 'OPAMWITHTEST' env: OPAMWITHTEST: 'true' # COPIED FROM # https://github.com/rust-lang/crater/blob/9ab6f9697c901c4a44025cf0a39b73ad5b37d198/.github/workflows/bors.yml#L125-L149 # These jobs doesn't actually test anything, but they're only used to tell # bors the build completed, as there is no practical way to detect when a # workflow is successful listening to webhooks only. # # ALL THE PREVIOUS JOBS NEEDS TO BE ADDED TO THE `needs` SECTION OF THIS JOB! end-success: name: bors build finished if: success() runs-on: ubuntu-latest needs: [build] steps: - name: Mark the job as successful run: exit 0 Mtac2-1.4-coq8.20/.gitignore000066400000000000000000000011611472011217100153770ustar00rootroot00000000000000# Generated Makefile /Makefile /Makefile.conf src/META.coq-mtac2 # Make dependencies *.d # Backup files *.bak # emacs backup files *~ # vim backup files \#*\# # Coq annotation files *.glob # Coq auxiliary files .*.aux # Coq compilation unit *.vo *.vos *.vok *.annot *.cmo *.cma *.cmi *.a *.o *.cmi *.cmt *.cmti *.cmx *.cmxs *.cmxa # ocamlbuild targets *.byte *.native # oasis generated files /setup.data /setup.log # locals for emacs .dir-locals.el # output of tests src/metaCoqInit.ml src/metaCoqTactic.ml /tests/sf-5/Makefile /tests/sf-5/Makefile.conf # ocamlbuild working directory _build/ .merlin *.install Mtac2-1.4-coq8.20/.ocp-indent000066400000000000000000000000341472011217100154460ustar00rootroot00000000000000JaneStreet match_clause = 4 Mtac2-1.4-coq8.20/.travis.yml000066400000000000000000000040071472011217100155220ustar00rootroot00000000000000dist: trusty sudo: required language: generic services: - docker env: matrix: - COQ_IMAGE="coqorg/coq:dev" # As described on https://bors.tech/documentation/getting-started/ we need a # `staging` and a `trying` branch, both of which need to be CI-enabled. branches: only: # This is where pull requests from "bors r+" are built. - staging # This is where pull requests from "bors try" are built. - trying # Uncomment this to enable building pull requests. But bors will not see that travis already built it, so it's kinda useless # - master # (Left commented out until we find that it would be useful to enable) # We want to have CI for all master branches that target specific coq versions. - /master-.*/ install: | # Run the COQ container and display build metadata docker run -d -i --init --name=COQ -v ${TRAVIS_BUILD_DIR}:/home/coq/Mtac2 -w /home/coq/Mtac2 ${COQ_IMAGE} travis_wait docker exec COQ /bin/bash --login -c " export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' export OPAMJOBS="2" set -ex opam config list opam repo list opam list opam update default coqc --version opam pin add https://github.com/unicoq/unicoq.git#master -k git -y opam pin opam list " script: - echo -e "${ANSI_YELLOW}Building Mtac2...${ANSI_RESET}" && echo -en 'travis_fold:start:Mtac2.build\\r' - | docker exec COQ /bin/bash --login -c " export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' set -ex sudo chown -R coq:coq /home/coq/Mtac2 ./configure.sh make make test " - docker stop COQ # optional - echo -en 'travis_fold:end:Mtac2.build\\r' notifications: webhooks: urls: - https://webhooks.gitter.im/e/2fc197f36f7c587c0f59 - https://mattermost.mpi-sws.org/hooks/tyg3f3w7gpdaprgo1krzc94j7o on_success: change # options: [always|never|change] default: always on_failure: always # options: [always|never|change] default: always on_start: never # options: [always|never|change] default: always Mtac2-1.4-coq8.20/CHANGES.md000066400000000000000000000034311472011217100150030ustar00rootroot00000000000000Changes from 1.3 to 1.4 ======================= - Bugfixes, in particular #294, #299, #304 concerning various unsoundnesses uncovered by the *power of formalization*! - New fast `instantiate_evar` primitive which doesn't check types prior to instantiate the evar. This is sound because the type of the evar and of its definition are expected to be unifiable. - Added `RedReduction` reduction constructor that, given a string, reduces the term according to the name of the reduction scheme, as in: ```coq Local Declare Reduction test := lazy beta delta [id]. ... let t := reduce (RedReduction "test") (id (1+1)) in ... ``` - Eta-reduction for `[#]` patterns. - Several bugfixes and performance improvements (see commits for details). Changes from 1.2 to 1.3 ======================= - Bugfixes and performance improvements. Changes from 1.1 to 1.2 ======================= Primitives: - Added the `existing_instance` primitive that mirrors Coq's `Existing Instance` vernacular. Together with `declare`, `existing_instance` can be used to declare type class instances. Debugging: - `Set_Debug_Exceptions` now enables backtraces for uncaught exceptions. The traces show definitions and some internal events encountered on the way to the uncaught exception. Notation: - Combining the `.. <- ..; ..` (`M.bind`) notation and Coq's support for patterns (as in `let '(existT _ x P) = .. in ..`) now works without adding an additional apostrophe `'`. For example, `'(existT _ x P) <- some_function(); ..` is now legal. Previously, one had to write `''(existT _ x P) <- some_function(); ..`. This old syntax is no longer available. Vernacular: - `Mtac Do` now accepts its argument without parentheses. - `Mtac Do` now typechecks its argument and only executes code of type `M _`. Mtac2-1.4-coq8.20/GNUmakefile000066400000000000000000000006441472011217100154660ustar00rootroot00000000000000.PHONY: check cleanall -include Makefile # The workflow is: # 1. Develop in src # 2. Once it compiles and seems correct, use the test-suite # before committing by doing `make check`. check: @ $(MAKE) --silent all install @ $(MAKE) --silent -C tests clean check cleanall:: @ $(MAKE) --silent clean @ $(MAKE) --silent -C tests clean @ $(MAKE) --silent -C stdlib-bench clean bench: @ $(MAKE) -C stdlib-benchs Mtac2-1.4-coq8.20/LICENSE000066400000000000000000000022161472011217100144160ustar00rootroot00000000000000The MIT License (MIT) Copyright (c) 2010-2020 Beta Ziliani Jan-Oliver Kaiser . Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. Mtac2-1.4-coq8.20/Makefile.local000066400000000000000000000023641472011217100161460ustar00rootroot00000000000000.PHONY: test #RED='\033[0;31m' #NC='\033[0m' # No Color #COQC=coqc COQ_SRC_SUBDIRS+=user-contrib/Unicoq CAMLPKGS+= -package coq-unicoq.plugin TESTS=$(wildcard tests/*.v tests/bugs/*.v) TESTRESULTS=$(TESTS:.v=.vo) EXAMPLES=$(wildcard examples/*.v) EXAMPLESRESULTS=$(EXAMPLES:.v=.vo) post-all:: test test: $(TESTRESULTS) $(EXAMPLESRESULTS) sf sf: cd tests/sf-5; ./configure.sh; make clean; make .PHONY=sf TIMINGS=$(wildcard timings/*.v) TIMINGRESULTS=$(TIMINGS:.v=.vo) timing: $(TIMINGRESULTS) tests/%.vo: tests/%.v real-all $(SHOW)COQC $< $(HIDE)(($(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) && echo "[OK] " $<) || ( EXITSTATE="$$?"; echo "\033[0;31m[KO]\033[0m" $<; exit "$$EXITSTATE" )) .PHONY=test examples/%.vo: examples/%.v real-all $(SHOW)COQC $< $(HIDE)(($(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) && echo "[OK] " $<) || ( EXITSTATE="$$?"; echo "\033[0;31m[KO]\033[0m" $<; exit "$$EXITSTATE" )) .PHONY=test timings/%.vo: timings/%.v real-all $(SHOW)COQC $< $(HIDE)(($(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) && echo "[OK] " $<) || ( EXITSTATE="$$?"; echo "\033[0;31m[KO]\033[0m" $<; exit "$$EXITSTATE" )) .PHONY=timing Mtac2-1.4-coq8.20/README.md000066400000000000000000000050461472011217100146740ustar00rootroot00000000000000# Mtac2 A typed tactic language for Coq. Copyright (c) 2020 Jan-Oliver Kaiser Beta Ziliani Distributed under the terms of the MIT License, see LICENSE for details. Accepted contributions will be held under scrutiny to ensure they do not incur in a copyright infringement. This repository contains a plugin for Coq with the tactic language described in the paper [Mtac2: Typed Tactics for Backward Reasoning in Coq](http://plv.mpi-sws.org/mtac). The project has 3 subdirectories: * `src` contains the code of the plugin. - `run.ml` is the interpreter. * `theories` contains support Coq files for the plugin. - `Mtac2.v` declares the plugin on the Coq side and imports all the required theories. - The `intf` folder contains the basics: the `M` monad with its operations documented, exceptions, etc. - The folder `tactics` contains everything relating to tactics: + `Tactics.v` defines the tactic type and several tactics and combinators. + `Ttactics.v` defines the type for typed tactics and combinators. + `IntroPatt.v` defines intro patterns. + `ConstrSelector.v` defines a selector based on the indices of an inductive type's constructors. * `examples` contains simple examples to show the different features of Mtac2. - `tactics.v` shows how to standard, Ltac's like, proving. But with some interesting features not present in Ltac. - `tauto.v` shows many different ways to code a simple tautology prover, with different degrees of certainty and verboseness. * `test-suite` contains several tests, including some uses of the plugin. Installation ============ The plugin works currently with Coq v8.7 (and any minor version). It requires [UniCoq](http://github.com/unicoq/unicoq) to be installed. Mtac2 will be available in OPAM soon. For the moment you should have coqc, ocamlc and make in your path. Then simply do: ``` coq_makefile -f _CoqProject -o Makefile ``` To generate a makefile from the description in `_CoqProject`, then `make`. This will consecutively build the plugin and the supporting theories. You can then either `make install` the plugin or leave it in its current directory. To be able to import it from anywhere in Coq, simply add the following to `~/.coqrc`: ``` Add LoadPath "path_to_mtac2/theories" as Mtac2. Add ML Path "path_to_mtac2/src". ``` # Usage Once installed, you can `Require Import Mtac2.Mtac2` to load the plugin. The plugin defines a tactic `mrun t` to execute code `t` and a proof mode `MProof` where Mtac2's tactic can be executed directly. Mtac2-1.4-coq8.20/_CoqProject000077500000000000000000000026071472011217100155530ustar00rootroot00000000000000src/META.coq-mtac2.in COQMF_WARN = "-warn-error +a-3-23" CAMLDEBUG = "-g" -arg -bt -I src -R theories Mtac2 -Q tests Mtac2Tests -arg "-w -unrecognized-unicode" src/metaCoqInit.mlg src/metaCoqInstr.mli src/constrs.ml src/constrs.mli src/mtacNames.ml src/mtacNames.mli src/mConstr.ml src/mConstr.mli src/run.ml src/run.mli src/metaCoqInterp.ml src/metaCoqInterp.mli src/metaCoqTactic.mlg src/MetaCoqPlugin.mlpack theories/lib/Logic.v theories/lib/Specif.v theories/lib/Datatypes.v theories/lib/List.v theories/lib/Utils.v theories/intf/Sorts.v theories/Base.v theories/DecomposeApp.v theories/tactics/TacticsBase.v theories/tactics/Tactics.v theories/tactics/ImportedTactics.v theories/tactics/IntroPatt.v theories/tactics/CompoundTactics.v theories/tactics/ConstrSelector.v theories/tactics/Ttactics.v theories/Mtac2.v theories/intf/MTele.v theories/meta/MTeleMatchDef.v theories/meta/MTeleMatch.v theories/meta/MFixDef.v theories/meta/MFix.v theories/ideas/SumRun.v theories/Pattern.v theories/intf/Dyn.v theories/intf/Name.v theories/intf/Exceptions.v theories/intf/Reduction.v theories/intf/DeclarationDefs.v theories/intf/Unification.v theories/intf/Case.v theories/intf/Goals.v theories/intf/Lift.v theories/intf/Tm_kind.v theories/intf/M.v theories/meta/Exhaustive.v theories/ideas/Abstract.v theories/ideas/DepDestruct.v theories/ideas/SubgoalsStrict.v theories/ideas/StaticApply.v theories/ideas/Transport.v Mtac2-1.4-coq8.20/bors.toml000066400000000000000000000002001472011217100152420ustar00rootroot00000000000000status = [ "bors build finished" ] # Uncomment this to use a two hour timeout. # The default is one hour. #timeout_sec = 7200 Mtac2-1.4-coq8.20/configure.sh000077500000000000000000000025771472011217100157430ustar00rootroot00000000000000#!/usr/bin/env sh # Makefile generation coq_makefile -f _CoqProject -o Makefile # git pre-commit hooks installation (cd .git/hooks; ln -sf ../../scripts/hooks/pre-commit) # .merlin generation # NOTE: Needed because Coq doesn't install any META files path=`ocamlfind printconf destdir` if [ $? -ne 0 ]; then echo "Warning: Optional command (ocamlfind) not found. Error ignored" exit 0 fi content=" S src\n\ B src\n\ \n\ FLG -rectypes\n\ \n\ PKG camlp4.lib\n\ \n\ # Locates Coq's library\n\ B $path/coq/config\n\ B $path/coq/engine\n\ B $path/coq/grammar\n\ B $path/coq/interp\n\ B $path/coq/intf\n\ B $path/coq/kernel\n\ B $path/coq/lib\n\ B $path/coq/library\n\ B $path/coq/parsing\n\ B $path/coq/plugins\n\ B $path/coq/plugins/btauto\n\ B $path/coq/plugins/cc\n\ B $path/coq/plugins/decl_mode\n\ B $path/coq/plugins/derive\n\ B $path/coq/plugins/extraction\n\ B $path/coq/plugins/firstorder\n\ B $path/coq/plugins/fourier\n\ B $path/coq/plugins/funind\n\ B $path/coq/plugins/micromega\n\ B $path/coq/plugins/nsatz\n\ B $path/coq/plugins/omega\n\ B $path/coq/plugins/quote\n\ B $path/coq/plugins/romega\n\ B $path/coq/plugins/rtauto\n\ B $path/coq/plugins/setoid_ring\n\ B $path/coq/plugins/syntax\n\ B $path/coq/plugins/xml\n\ B $path/coq/pretyping\n\ B $path/coq/printing\n\ B $path/coq/proofs\n\ B $path/coq/stm\n\ B $path/coq/tactics\n\ B $path/coq/toplevel\n\ " echo -n $content > .merlin Mtac2-1.4-coq8.20/coq-mtac2.opam000066400000000000000000000000001472011217100160420ustar00rootroot00000000000000Mtac2-1.4-coq8.20/dune-project000066400000000000000000000000611472011217100157270ustar00rootroot00000000000000(lang dune 1.9) (using coq 0.1) (name coq-mtac2) Mtac2-1.4-coq8.20/examples/000077500000000000000000000000001472011217100152265ustar00rootroot00000000000000Mtac2-1.4-coq8.20/examples/basics_tutorial.v000066400000000000000000000612751472011217100206170ustar00rootroot00000000000000(** * Tutorial for Mtac2 *) (** Author: Beta Ziliani *) (** with fixes from Michael Soegtrop *) (** * Introduction Mtac2 is a typechecked language for proof automation. In its core, it consists of a monadic type [M A] for a type [A], which is interpreted via a tactic [mrun]. The best way of understanding the type [M A] is as _maybe_ [A], so, for instance, a function of type [M nat] _may_ return a natural number. It can also fail or loop forever, but it can never produce a value of a different type (that is, the interpreter is sound). We call functions of type [M A] _Mtactics_, to distinguish them from the usual tactics provided by Coq. *) (** One of the key aspects of Mtac2 is that it subsumes Gallina, the language of Coq, and it inherits from Coq the beta delta iota zeta reduction rules. This makes programming tactics very pleasant, since developers only need to learn the new features and their semantics, since the rest is _exactly the same_. These new features are, among others: - Exceptions, - Unbounded fixpoints, - Unification, - Fresh name generation, - Abstraction of variables. *) (** In this tutorial we illustrate these features, building up from simple examples. In order to execute the code in this file you will need to install our plugin. For details, follow this link: #Mtac2 home page# *) (** * Simple examples *) (** To begin working with the new language we need to import the [M] type. *) Require Import Mtac2.Mtac2. (** In Mtac2 there are two major modules, in our case we are going to use the module with basic operators, called also [M]. We import it alongside with its notations: *) Import M. Import M.notations. (** In addition, we import a couple of modules from the standard library that we are going to use in some examples. *) Require Import Arith.Arith. Require Import Lists.List. Require Import Strings.String. Set Implicit Arguments. Notation "x == y" := (Nat.eqb x y) (at level 60). (** We start by showing the standard _unit_ and _bind_ operators, which in our language are called [ret] (for return) and [bind]. The language also defines the standard notation [x <- a; b] for [bind]. This example computes the value [1] by passing the result of computing [0] to the successor. *) Definition produces_a_value := x <- ret 0; ret (S x). (** We check the type of the definition. It has type [M nat]. *) Check produces_a_value. (** There are different ways to execute it. The first one is to call the tactic [mrun]. *) Definition the_value_tactic : nat. Proof. mrun produces_a_value. Defined. Print the_value_tactic. (** The result should be [the_value = 1 : nat]. As you can see, [mrun produces_a_value] solved the goal with the result of computing the code in [produces_a_value]. *) (** Another option is to use the [MProof] command, which implicitly appends an [mrun] at each line. *) Definition the_value_mproof : nat. MProof. produces_a_value. Defined. (** Finally, it is also possible to use the Ltac keyword [ltac:] to execute the tactic. One advantage is that we can bake it into regular Gallina terms. In our case, this means that we do not need to annotate the type of the definition. *) Definition the_value_ltac := ltac:(mrun produces_a_value). (** Throughout the tutorial we are going to use this last one a lot, so we better make some nice notation: *) Notation "! t" := ltac:(mrun t) (at level 200). (** ** Exceptions *) (** The monad includes exceptions, like the following silly example illustrates. [Exception]s are constructed with the constructor [exception]. In order to make distinguishable exceptions we make them opaque, sealing the definition with the [Qed] word. *) Definition AnException : Exception. exact exception. Qed. (* They can be parametrized as well. *) Definition MyException (s : string) : Exception. exact exception. Qed. (** Note how they are equal to [exception], but we can still differentiate them. *) Definition test_ex e := mtry raise e with | AnException => ret ""%string | MyException "hello"%string => ret "world"%string | [? s] MyException s => ret s end. Definition empty_string := ! test_ex AnException. Definition world_string := ! test_ex (MyException "hello"%string). Definition other_string := ! test_ex (MyException "other"%string). Print empty_string. Print world_string. Print other_string. (** Results should be the empty string, the string "world" and the string "other" respectively. *) (** If an exception is not caught, then we get a meaningful error. The [Fail] command below will show the exception thrown by the code: *) Fail Check (! raise (MyException "This is printed out"%string) : M nat). (** (We need to provide a type to the expression because [ltac:] doesn't like open terms.) *) (** ** Unbounded fixpoints *) (** Fixpoints in Coq should terminate to ensure soundness. Checking termination is hard, so Coq relies on a pretty restrictive syntactic condition to ensure termination. We allow non-termination in our language via an unbounded fixpoint, which we call [mfix]. For instance, an endless loop can be written simply as: *) Definition endless_loop := mfix1 f (n : nat) : M False := f n. (** In this definition we decided to add the type annotation [M False], since otherwise it is impossible for the type inference mechanism to guess the type. It is important to note that the body of [mfix] should always be of type [M]. *) (** Uncomment the code below and execute it: it will loop forever! You will have to interrupt the proof assistant (C-c C-c in Emacs). *) (**[ Check (! endless_loop 0). ]*) (** *** Endless loop... Is it still safe? *) (** The key to understanding why it is perfectly safe to allow for such effects is to notice that [mrun] is not a function living in the kernel typechecker of Coq. That is, for [t] of type [M A], [mrun t] constructs a witness for [A] only if it's safe to do so, but _it itself is not a witness for [A]_. Take as example the definitions we constructed so far: we used [mrun] but when we printed them we saw no [mrun] in their proof terms. As an exercise, we can try to break soundness of Coq by constructing an element of type [False] without any further hypothesis. Take the function [endless_loop] above, which has type [nat -> M False]. To get an element of type [False] we have to execute it through [mrun] as in the commented code. Since it will not terminate, [mrun (endless_loop 0)] doesn't produce an offending witness. *) (** *** Constructing Collatz sequences *) (** To show the use of this unbounded fixpoint we define a function computing the #Collatz sequence#, which cannot be defined in vanilla Coq since its termination is a conjecture. *) (* begin hide *) Fixpoint is_even n := match n with 0 => true | S n' => negb (is_even n') end. (* end hide *) Definition collatz := mfix1 f (n : nat) : M (list nat) := let n := rcbv n in let rest := if n == 1 then ret nil else if is_even n then f (Nat.div2 n) else f (3 * n + 1) in s <- rest; ret (n :: s). (** We perform reduction on the natural number *) (** We try it with the value [6]. *) Definition the_sequence_6 := ! (collatz 6). Print the_sequence_6. (** Result: [(6 :: 3 :: 10 :: 5 :: 16 :: 8 :: 4 :: 2 :: 1 :: nil) : list nat] *) (** ** Unification match *) (** Mtac2 provides a powerful construct: the unification match. Unlike the native Coq pattern matching, the unification match let us specify any term as a pattern, even patterns containing variables bound in the context. For instance, the code below shows a function that searches for an element in a list. *) Mtac Do New Exception NotFound. (** (This is just a handy way of declaring an exception without parameters.) *) Definition inlist A (x : A) := mfix1 f (s : list A) : M (In x s) := mmatch s as s' return M (In x s') with | [? s'] (x :: s') => ret (in_eq _ _) | [? y s'] (y :: s') => r <- f s'; ret (in_cons y _ _ r) | _ => raise NotFound end. Check inlist. (** We also depart from the standard notation for patterns: since they may now refer to variables in the context, we need to specify a list of pattern variables, like [[? s']] in the first pattern. All the variables not included in this list should be bound by the context, like [x] in the same pattern, which is bound to the argument of the definition. That is, this pattern matches a list containing the element [x] in the head. *) (** So far we have constructed the proof terms directly, without using the interactive mode of Coq. We can use any standard tactic ([apply], [refine], [exact], [set], ...) with [run], although not all of them are suitable if we want to avoid writing inferable arguments. For instance, if we have to prove a goal of the form [In x s] for some list [s] and some element [x], then we would like to use [mrun (inlist _ _)], that is, without specifying the arguments. This will help us build more robust proof scripts, since tomorrow we may replace [x] by some other element in the list and still get a valid proof script. *) Example x_in_zyx (x y z : nat) : In x (z :: y :: x :: nil). Proof. mrun (inlist _ _). Qed. (** One tricky thing about our nice notation [!] is that it doesn't work for open terms: *) Fail Example z_in_xyz (x y z : nat) : In z (x :: y :: z :: nil) := ! (inlist _ _). (** We can still call it with the [ltac:] construct directly: *) Example z_in_xyz (x y z : nat) : In z (x :: y :: z :: nil) := ltac:(mrun (inlist _ _)). (** An alternative is to use [eval], which is similar to [mrun], except that it performs the execution of the Mtactic after the type inference mechanism of Coq has done its job: *) Example y_in_zyx (x y z : nat) : In y (z :: y :: x :: nil) := eval (inlist _ _). (** Behinds the scene, [eval] uses the typeclass mechanism. As a drawback, it leaves the tactic code in the proof term: *) Print y_in_zyx. (** Note the call to [inlist] showing up here. *) (** *** Interaction with [Program] *) (** When writing tactics, we can use [Program] to avoid having to write the proof terms ourselves. As an example, we will extend our [inlist] function to handle list concatenation in order to handle more cases and get shorter proof terms. By using [Program], Coq will ask us to provide (interactively) the proof terms for the cases where there is a hole ([_]) and it cannot guess what to fill in that hole. *) Program Definition inlist' A (x : A) := mfix1 f (s : list A) : M (In x s) := mmatch s as s' return M (In x s') with | [? l r] l ++ r => mtry il <- f l; ret _ with _ => ir <- f r; ret _ end | [? s'] (x :: s') => ret (in_eq _ _) | [? y s'] (y :: s') => r <- f s'; ret (in_cons y _ _ r) | _ => raise NotFound end. Next Obligation. intros; apply in_or_app; left; assumption. Qed. Next Obligation. intros; apply in_or_app; right; assumption. Qed. (** If the list is a concatenation of two lists [l] and [r], we first try to search for the element on [l] and, if it fails, on [r]. Notice that the pattern is not a constructor, but the application of the function [++] to two lists. As mentioned before, we can use _any_ Coq term as a pattern! It is important to make this case the first case of the match, as the unification of the scrutinee with the pattern takes into account beta delta iota zeta reductions. That is, if the concatenation case were put third in the match, then the list [(x :: nil) ++ (z :: nil)] will be matched against the pattern [(x :: s')], by reducing it to [(x :: z :: nil)]. *) (** One problem with [Program] is that it tends to generate unnecessarily big proof terms. *) Print inlist'. (** Let's look at the proof terms generated in the obligations and plug those terms into the holes. *) Print inlist'_obligation_1. Print inlist'_obligation_2. (** The important bits are [in_or_app l r x (or_introl H)] and [in_or_app l r x (or_intror H)]. We write our function again filling in the holes with these two terms. *) Definition inlist'' A (x : A) := mfix1 f (s : list A) : M (In x s) := mmatch s as s' return M (In x s') with | [? l r] l ++ r => mtry il <- f l; ret (in_or_app l r x (or_introl il)) with _ => ir <- f r; ret (in_or_app l r x (or_intror ir)) end | [? s'] (x :: s') => ret (in_eq _ _) | [? y s'] (y :: s') => r <- f s'; ret (in_cons y _ _ r) | _ => raise NotFound end. (** Let's prove an example using the three functions just created to compare the proof terms they generate. *) Example ex_inlist (x y z : nat) : In x ((y :: z :: nil)++(x :: z :: nil)). Proof. mrun (inlist _ _). Qed. Example ex_inlist' (x y z : nat) : In x ((y :: z :: nil)++(x :: z :: nil)). Proof. mrun (inlist' _ _). Qed. Example ex_inlist'' (x y z : nat) : In x ((y :: z :: nil)++(x :: z :: nil)). Proof. mrun (inlist'' _ _). Qed. Print ex_inlist. Print ex_inlist'. Print ex_inlist''. (** Inspect the result. The last example has the shortest proof term. *) (** * A simple tautology prover *) (** We show by example some useful constructs for dealing with Higher Order Abstract Syntax (HOAS). As the driving example we will write a rudimentary tautology prover similar to that found in VeriML [[1]] and CPDT [[2]]. Compared to VeriML, our approach has the benefit that it doesn't require any special context treatment, since for us a context is nothing more than a Coq list. And unlike in the Ltac version presented in [[2]], we have meaningful types to prevent ourselves from shooting ourselves in the foot. *) (** ** Warming the engine: a simple propositional prover *) (** We start with a very simple propositional prover. It considers only three cases: - The proposition is [True]. In this case, it returns the trivial proof [I]. - The proposition is a conjunction of [p1] and [p2]. In this case, it proves both propositions and returns the introduction form of the conjunction. - The proposition is a disjunction of [p1] and [p2]. In this case, it tries to prove the proposition [p1], and if it fails it tries to prove the proposition [p2]. The corresponding introduction form of the disjunction is returned. - In any other case, it raises an exception, since no proof could be found. *) Definition simpl_prop_auto := mfix1 f (p : Prop) : M p := mmatch p in Prop as p' return M p' with | True => ret I | [? p1 p2 ] p1 /\ p2 => r1 <- f p1 ; r2 <- f p2 ; ret (conj r1 r2) | [? p1 p2] p1 \/ p2 => mtry r1 <- f p1 ; ret (or_introl r1) with _ => r2 <- f p2 ; ret (or_intror r2) end | _ => raise NotFound end. (** Given this definition we can easily discharge the following example. *) Example ex1 : True /\ (False \/ True). Proof. mrun (simpl_prop_auto _). Qed. Print ex1. (** The proof term is exactly what we would have written by hand: [ex1 = conj I (or_intror I)] *) (** ** Adding a context *) (** Our previous function is very limited since it cannot prove tautologies as simple as [P -> P]. To handle implications we need a list of hypotheses where we can search for a proof of the atom we are considering. We create a record type containing a proposition and a witness for the proposition. *) Record dyn := Dyn { prop : Prop ; elem : prop }. (** We will need to search a list of [dyn]s to find a witness for some proposition. The [search] function below is similar to the [inlist] above, but keying on the [prop] projector of the record. We have to prepend [Program] because it calls a more agressive typechecker, otherwise it fails to notice that the element in the body of the first case should return a [P]. *) Definition search (P : Prop) := mfix1 f (s:list dyn) : M P := mmatch s with | [? (x:P) s'] (Dyn x) :: s' => ret x | [? d s'] d :: s' => f s' | _ => raise NotFound end. (** The proposition in the [Dyn] constructor is implicit, since it can be inferred from the element, so we write [Dyn x] instead of [Dyn A x]. *) (** The tautology prover takes a context [c] (e.g., a list of [dyn]s) and a proposition. The first three cases are the same as before. *) Definition prop_auto' := mfix2 f (c : list dyn) (p : Prop) : M p := mmatch p in Prop as p' return M p' with | True => ret I | [? p1 p2 ] p1 /\ p2 => r1 <- f c p1 ; r2 <- f c p2 ; ret (conj r1 r2) | [? p1 p2] p1 \/ p2 => mtry r1 <- f c p1 ; ret (or_introl r1) with _ => r2 <- f c p2 ; ret (or_intror r2) end | [? (p1 p2 : Prop)] p1 -> p2 => \nu x:p1, r <- f (Dyn x :: c) p2; abs_fun x r | [? p'] p' : Prop => search p' c end. (** Let's look at the new case for handling the implication. We need to return an element of type [M (p1 -> p2)], that is, _maybe_ a function from [p1] to [p2]. Of course, we cannot simply write [ret (fun x:p1 => f (Dyn x :: c) p2)] since this code has type [M (p1 -> M p2)] which is not what we want. Instead, we use two new operators: [nu] and [abs_fun]. The first one is analogous to the nu operator in [[3]] and [[4]], but a bit more low-level. Its type is the following: *) About nu. (* That is: [forall {A B}, name -> moption -> (A -> M B) -> M B]. [name] is a structure to control the naming of the variable to be introduced, and [moption] is a universe polymorphic [option] type. The effect of computing [nu n None (fun x=>b)], where [b : T B], is the result of executing [b], replacing any occurrence of [x] with a fresh _parameter_ [a] named after [n]. If the execution results in a term [ret t] for some [t] with [a] not appearing free in it, then the value [ret t] is used as result for [nu n None (fun x => b)]. Otherwise, a failure is raised. Intuitively, the idea is that it is safe to execute the body of a function as long as it doesn't get stuck (i.e., it shouldn't inspect its argument), and the returning value doesn't return the argument (i.e., it shouldn't violate the context). The name can be generated fresh (this is what the notation [\nu] does); it can be named with a specific name (a string), in which case it shouldn't have a name clash with other variable in scope; or it can be generated fresh from a given string (for instance, with "H" it will generate H0, H1, ...). [abs_fun] abstracts over parameters created by [nu]. It has type [forall A P (x : A), P x -> M (forall x, P x)] where [A] and [P] are left implicit. If [a] is a parameter created by [nu] and [t] is a term with [a] appearing free in it, then [abs_fun a t] is replaced by [ret (fun x=>r)], where [r] is [t] with [a] replaced by [x]. That is, [a] is abstracted from [t]. Coming back to the implication case, we use [nu] to create a parameter [x] as a witness for [p1]. Then we add it to the list of hypothesis to prove [p2] and get the result [r], which may refer to [x]. Therefore, we use [abs_fun x r] to abstract [x] from the result. We encourage the reader to check that the type of the whole expression returned in the implication case indeed has type [M (p1 -> p2)]. Finally, we changed the last case of the algorithm: instead of throwing an error, now we search for a witness for the proposition in the list using the [search] function defined before. *) (** We create a definition to avoid passing the empty list *) Definition prop_auto {P} := @prop_auto' nil P. (** We can now easily prove this tautology. *) Example ex_with_implication (p q : Prop) : p -> q -> p /\ q. Proof. mrun prop_auto. Qed. (** Again, the proof term generated is exactly what we would expect for such a proof. *) Print ex_with_implication. (** Result: [ex_with_implication = fun (p q : Prop) (H : p) (H0 : q) => conj H H0] *) (** * Getting first order *) (** We can generalize our algorithm very easily to deal with [forall] and [exists]. Below is the code, where the first four cases and the last one are the same as before. *) Definition tauto' := mfix2 f (c : list dyn) (p : Prop) : M p := mmatch p as p' return M p' with | True => ret I | [? p1 p2] p1 /\ p2 => r1 <- f c p1 ; r2 <- f c p2 ; ret (conj r1 r2) | [? p1 p2] p1 \/ p2 => mtry r1 <- f c p1 ; ret (or_introl r1) with _ => r2 <- f c p2 ; ret (or_intror r2) end | [? (p1 p2 : Prop)] p1 -> p2 => \nu x:p1, r <- f (Dyn x :: c) p2; abs_fun x r | [? A (q:A -> Prop)] (forall x:A, q x) => \nu x:A, r <- f c (q x); abs_fun x r | [? A (q:A -> Prop)] (exists x:A, q x) => X <- evar A; r <- f c (q X) ; b <- is_evar X; if b then raise NotFound else ret (ex_intro q X r) | [? p'] p':Prop => search p' c end. (** The [forall] case is similar to the implication case from before but taking into account the following: - The type of [x] is any type [A], not just [Prop]. - The possible dependency of [x] in [q], the body of the [forall]. This dependency is marked by making [q] a function from [A] to [Prop]. The unification algorithm used to unify the pattern with the proposition [p] will take care of instantiating [q] with a function taking an element of type [A] and returning the body of the [forall]. - The context is not extended. For the existential case, we create a fresh meta-variable [X] via the command [evar], which takes a type (in this case [A]) and returns a new meta-variable of that type. Then, we call the function recursively with the body [q] of the existential, replacing the argument [x] with [X]. Hopefully, the result will instantiate [X] and we return this as the witness for the existential. If not, that is, if [X] is still an uninstantiated meta-variable, then we raise an error. As before, we create a definition to avoid passing the empty list: *) Definition tauto {P} := @tauto' nil P. (** Here is an example to test [tauto]: *) Example ex_first_order (p q : nat -> Prop) : forall x, p x -> q x -> exists y, p y /\ q y. Proof. mrun tauto. Qed. (** If we cannot instantiate an existential, then an error is thrown. *) Example ex_fail (p q : nat -> Prop) : exists y, p y /\ q y. Proof. Fail mrun tauto. Abort. (** Actually, we can omit the check for the existential and let the user come up with the witness by itself. *) (** * Delayed execution via [eval] *) (** We mentioned brefly that with [eval] we can delay the execution of the Mtactic in order to get arguments from the goal, and that we must use it with care, as the proof term generated is bigger than with [mrun]. This said, [eval] is particularly useful when rewriting procedures returning equalities. Here is an example using boolean equality of natural numbers. *) Program Definition eq_nats := mfix2 f (x : nat) (y : nat) : M (x == y = true) := mmatch (x, y) as xy return M (fst xy == snd xy = true) with | (x, x) => ret _ | [? x1 x2] (x1 + x2, x2 + x1) => ret _ end. Next Obligation. apply Nat.eqb_refl. Qed. Next Obligation. rewrite Nat.eqb_eq. apply Nat.add_comm. Qed. (** Notice how we use the [[H]] notation after the right arrow in the pattern. The name [H] will be instantiated with a proof of equality of the scrutinee with the pattern, which we use to apply [inverstion] on it. Of course, we could (should!) avoid [Program] and write the proof term directly, but that's unnecessary for illustrating the use of [eval] with [rewrite], the purpose of the section. *) (** We call the Mtactic with [eval]: *) Example plus_S n m : n + m == m + n = true /\ m == m = true /\ n == n = true. Proof. rewrite !(eval (eq_nats _ _)). (** Notice how at each rewrite it picks the right terms. *) auto. Qed. (** * Where now? *) (** After seeing the basics of the Mtac2 infrastructure, and until newer documentation comes, you are invited to see the examples in the same directory as this tutorial, and the theory files. Mtac2 comes with a lot of different useful tools. And feel free to ask any question in the Zulip channel! [[6]] *) (** * References *) (** [[1]] VeriML: Typed Computation of Logical Terms inside a Language with Effects. Antonis Stampoulis and Zhong Shao. In Proc. 2010 ACM SIGPLAN International Conference on Functional Programming (ICFP'10). [[2]] http://adam.chlipala.net/cpdt/ [[3]] Aleksandar Nanevski. Meta-programming with names and necessity. In Proceedings of the seventh ACM SIGPLAN international conference on Functional programming, ICFP'02, pages 206-217, New York, NY, USA, 2002. ACM. [[4]] Carsten Schuermann, Adam Poswolsky, and Jeffrey Sarnat. The nabla-calculus. functional programming with higher-order encodings. In Proceedings of the 7th international conference on Typed Lambda Calculi and Applications, TLCA'05, pages 339-353, Berlin, Heidelberg, 2005. Springer-Verlag. [[5]] https://math-comp.github.io/mcb/ [[6]] https://coq.zulipchat.com/#narrow/stream/254619-Mtac2 *) Mtac2-1.4-coq8.20/examples/tactics.v000066400000000000000000000154531472011217100170570ustar00rootroot00000000000000(** This file contains several examples showing the different tactics and tactic operators in Mtac2. Many of the examples are inspired from SF. *) (** Here is a list of basic tactics included in Mtac2, that we present here: - intros, cintros, typed_intros (with and without definitions). - destruct (and its variants). - left, right. - reflexivity. - apply. - fix. - generalize. - assert. - pose. - exists *) (** We start by importing Mtac2. The module [Mtac2] imports most of Mtac2's stuff. *) Require Import Mtac2.Mtac2. (** Since we are going to work with the [Tactics] module, we import the inner [T] module. *) Import T. (** We're going to prove stuff about lists. *) Require Import Lists.List. Import Lists.List.ListNotations. (** A simple example to warm up. *) Theorem surjective_pairing_1 : forall A B (p : A * B), p = (fst p, snd p). MProof. (** [typed_intros] introduces everything of a certain type *) typed_intros Type. (** [destructn] is [destruct] for a certain (0-based) number of binders. *) destructn 0. intros. (** (We must FIX how the goal is presented, now it contains extra stuff about sorts) *) simpl. reflexivity. Qed. (** We can use the [&>] composition operator (left associative) of [Mtac2] to inline the proof. *) Theorem surjective_pairing : forall A B (p : A * B), p = (fst p, snd p). MProof. typed_intros Type &> destructn 0 &> reflexivity. (* [reflexivity] does [intros] *) Qed. (** Mtac2 has intro patterns, with a tactic call [pintros] and a combinator (similar to SSReflect's [=>]) called [asp]. *) Theorem tl_length_pred : forall l: list nat, pred (length l) = length (tl l). MProof. destructn 0 asp [ [] ; ["n" ; "l'"] ]. - (* l = nil *) simpl. reflexivity. - (* l = cons n l' *) simpl. reflexivity. Qed. (** Another example using [assert] and the [rewrite] tactic imported from Coq's own. *) Theorem plus_rearrange : forall n m p q : nat, (n + m) + (p + q) = (m + n) + (p + q). MProof. intros n m p q. assert (H : n + m = m + n). - rewrite -> PeanoNat.Nat.add_comm &> reflexivity. - rewrite -> H &> reflexivity. Qed. (** An example featuring scoped introduction of variables [cintros] and [mexists]. *) Theorem exists_example_2 : forall n, (exists m, n = 4 + m) -> (exists o, n = 2 + o). MProof. cintros n {- destructn 0 &> intros m Hm -}. simpl. mexists (2 + m). (** We need to FIX the beta-expanded goal *) apply Hm. Qed. (** An example featuring the handy [select] tactic to pick an element from the list of hypotheses based on its type. *) Goal forall P Q, (P -> Q) -> P -> Q. MProof. intros. select (_ -> _) >>= apply. assumption. Qed. (** Note that we can't use [&>] to compose [intros] with [select] (try it!). The reason is that the holes in the type (the underscores) are turn into meta-variables, which can't refer to the introduced variables. *) (** We can, however, inline the proof with cintros. In order to avoid parens we need the right-associative composition operator [;;]. *) Goal forall P Q, (P -> Q) -> P -> Q. MProof. cintros _ _ _ _ {- select (_ -> _) >>= apply;; assumption -}. Qed. (** If we want to be able to compose [intros] with [select], we must create the meta-variables for each hole (using the [M.evar] construct). *) Definition apply_fun : tactic := `A B <- M.evar _; select (A -> B) >>= apply. Goal forall P Q, (P -> Q) -> P -> Q. MProof. intros &> apply_fun &> assumption. Qed. (** Of course, we can inline it too as [(`A B <- M.evar _; select (A->B) >>= apply)] *) (** One simple example using the [cut] tactic. *) Example cut_ex P Q R: (P \/ Q -> R) -> P -> R. MProof. intros. cut (P \/ Q). - assumption. - left &> assumption. Qed. (** We can inline the previous proof thanks to the overloading of the [&>] operator. *) Example cut_ex_inline P Q R: (P \/ Q -> R) -> P -> R. MProof. intros. cut (P \/ Q) &> [m: idtac | left] &> assumption. (** Note the notation for a list of tactics. Instead of Coq's lists, we use Mtac2's (with type [mlist]), which are universe polymorphic. We use Ltac's notation, using the pipe instead of the semi-colon for each element of the list. *) Qed. (** We can also apply a tactic to a certain goal using a [selector].*) Example cut_ex_selector P Q R: (P \/ Q -> R) -> P -> R. MProof. intros. (cut (P \/ Q) |2> left) &> assumption. (** We apply the [left] tactic only to the 2nd subgoal, and then we solve every subgoal with [assumption]. We can also use the notation [|n>] for the last subgoal. *) Qed. (** Using the [fix_tac] tactic (similar to Coq's fix) *) Theorem plus_n_O : forall n:nat, n = n + 0. MProof. fix_tac (TheName "IH") 1. destructn 0. - reflexivity. - intro n'. simpl. rewrite <- IH. reflexivity. Qed. (** An example combining standard FP programming with tactic programming: *) (** [apply_one_of] take a list of lemmas and tries to apply each until one succeed. Again, we use Mtac2's own definition for lists. *) Mtac Do New Exception NoneApply. Definition apply_one_of (l: mlist dyn) : tactic := mfold_left (fun a b=>a || (dcase b as e in apply e)) l (raise NoneApply). (** The type [dyn] packs an element with its type. An element of this type is constructed with the [Dyn] constructor, providing an element (implicitly taking its type). [dcase] is notation for taking the element from the [Dyn]. *) Goal forall x y z : nat, In x (z :: y :: x :: nil). MProof. intros &> T.repeat (apply_one_of [m:Dyn in_eq | Dyn in_cons]). Qed. (** Examples showing how to selectively apply a tactic only in certain subgoals, according to the _index_ of the constructor. We import the necessary file: *) Require Import Mtac2.tactics.ConstrSelector. Inductive AVeryDumbOne := This | Is | Dumb. Definition is_this_is d := match d with This => true | Is => true | _ => false end. Definition is_dumb d := match d with Dumb => true | _ => false end. Example dumb_is_dumb_without_except : forall d, d = Dumb -> is_dumb d = true. MProof. destructn 0 &> intros. - (* This *) discriminate. - (* Is *) discriminate. - (* Dumb *) reflexivity. Qed. Example dumb_is_dumb_with_except : forall d, d = Dumb -> is_dumb d = true. MProof. destructn 0 &> intros &> except Dumb do discriminate. reflexivity. Qed. Example dumb_is_not_this_is_with_case : forall d, d = Dumb -> is_this_is d = false. MProof. destructn 0 &> intros &> case Dumb do reflexivity. - discriminate. - discriminate. Qed. (** To conclude, we present a way of hacking the type inference algorithm to execute an Mtactic. We use the [ltac:] escape to be able to write Ltac code inside a term, and then we use Mtac2's (Ocaml) tactic [mrun] to execute, in this case, the [apply] tactic. *) Notation "x ?" := (ltac:(mrun (apply x))) (at level 0). (** With this notation, we can now let Coq infer the number of arguments that a term should have. *) Definition test_question_mark (x y z: nat) : In x [x] := in_eq?. Mtac2-1.4-coq8.20/examples/tauto.v000066400000000000000000000137251472011217100165610ustar00rootroot00000000000000From Mtac2 Require Import Mtac2 Ttactics Sorts. From Coq Require Import List. Import M.notations. Import M. Import ListNotations. (** This file shows different ways to code a simple tautology prover. It uses various features of Mtac2 in an example that is easy enough to understand. *) Module Mtac_V1. (** The first version of the prover will be similar to the one presented in the original paper of Mtac. The prover is an [M] program that encodes in its type the fact that it proves the proposition provided as argument. *) (** The prover uses a list of [dyn]s as the context of the proof. We define a [lookup] function which traverses the list, trying to unify the type of the term with the one provided. We create a new exception for when it can't find the hypothesis. *) Mtac Do New Exception NotFound. (** Note how we code [lookup] with a standard Coq fixpoint and match. This is for performance reasons. *) Fixpoint lookup (P : Prop) (l : list dyn) : M P := match l with | D :: l => mmatch D with | [? (p : P)] Dyn p =u> ret p | _ => lookup P l end | [] => raise NotFound end. (** The tautology prover. It first tries to look for the proposition in the list of hypothesis, and if it fails in tries to break it down into pieces and recurse over each part. *) Mtac Do New Exception TautoFail. Definition solve_tauto : forall (l : list dyn) {P : Prop}, M P := mfix2 f (l : list dyn) (P : Prop) : M P := mtry lookup P l with NotFound => mmatch P in Prop as P' return M P' with | True => ret I | [? Q1 Q2] Q1 /\ Q2 => q1 <- f l Q1; q2 <- f l Q2; ret (conj q1 q2) | [? Q1 Q2] Q1 \/ Q2 => mtry q1 <- f l Q1; ret (or_introl q1) with TautoFail => q2 <- f l Q2; ret (or_intror q2) end | [? (Q1 Q2 : Prop)] Q1 -> Q2 => \nu q1, q2 <- f (Dyn q1 :: l) Q2; abs_fun q1 q2 | [? X (Q : X -> Prop)] (exists x : X, Q x) => x <- evar X; q <- f l (Q x); b <- is_evar x; if b then raise TautoFail else ret (ex_intro Q x q) | _ => raise TautoFail end end. (** For a detailed explanation, it is best to read the paper and/or look at the different primitives that are being used. *) Goal 5 = 7 -> exists x, x = 7. MProof. solve_tauto nil. Qed. End Mtac_V1. Module Mtac_V2. (** The prover in this module uses typed-tactics, mixing static and dynamic knowledge of goals to solve the problem. *) Import TT. Import TT.notations. Definition TautoFail : Exception. constructor. Qed. Import Tactics.T.notations. Definition solve_tauto : tactic := mfix0 solve_tauto : gtactic _ := (match_goal with | [[ |- True ] ] => ret I | [[? Q1 Q2 |- Q1 /\ Q2 ] ] => TT.apply (@conj _ _) <**> TT.by' solve_tauto <**> TT.by' solve_tauto | [[? Q1 Q2 |- Q1 \/ Q2 ] ] => mtry TT.apply (@or_introl _ _) <**> TT.by' solve_tauto with | TautoFail => TT.apply (@or_intror _ _) <**> TT.by' solve_tauto end | [[? (Q1 Q2 : Prop) |- Q1 -> Q2 ] ] => TT.by' (T.introsn 1 &> solve_tauto) | [[? X (Q : X -> Prop) |- (exists x : X, Q x)] ] => TT.by' (T.eexists &> [m: solve_tauto | T.idtac]) | [[? P | (p : P) |- P ] ] => TT.apply p | [[? G |- G ] ] => raise TautoFail end )%TT%MC. Ltac solve_tauto := mrun solve_tauto. Goal 5 = 7 -> exists x, x = 7. Proof. solve_tauto. Qed. End Mtac_V2. Module Mtac_V3. (** The prover in this module uses tactics similar to Ltac's (with similar guarantees). *) Import T. Import T.notations. Mtac Do New Exception TautoFail. Definition solve_tauto : tactic := mfix0 solve_tauto : gtactic _ := assumption || exact I || (split &> solve_tauto) || (left &> solve_tauto) || (right &> solve_tauto) || (introsn_cont solve_tauto 1) || (eexists |1> solve_tauto) || raise TautoFail. Ltac solve_tauto := mrun solve_tauto. Goal 5 = 7 -> exists x, x = 7. Proof. solve_tauto. Qed. End Mtac_V3. Module Mtac_V4. (** The prover in this module uses a combination of the traditional [M] solution from [Mtac_V1] with the typed-tactic approach of [Mtac_V2]. *) Import Sorts.S. Import TT. Import TT.notations. Definition TautoFail : Exception. constructor. Qed. Import M.notations. Import ProdNotations. Polymorphic Definition promote_uninst_evar {X} {A} (x : X) (a : A *m mlist (goal _)) : ttac (A) := let '(m: a, gs) := a in mif is_evar x then ret (m: a, AnyMetavar Typeₛ _ x :m: gs) else ret (m: a, gs). Polymorphic Definition has_open_subgoals {A} (a : A *m mlist (goal gs_any)) : M bool := ret (match msnd a with [m:] => true | _ => false end). Definition solve_tauto : forall {P:Prop}, ttac P := mfix1 solve_tauto (P : Prop) : M _ := mmatch P in Prop as P' return ttac P' with | True => apply I | [? Q1 Q2] Q1 /\ Q2 => apply (@conj _ _) <**> solve_tauto Q1 <**> solve_tauto Q2 | [? Q1 Q2] Q1 \/ Q2 => mtry q1 <- apply (@or_introl _ _) <**> solve_tauto Q1; mif has_open_subgoals q1 then raise TautoFail else ret q1 with TautoFail => apply (@or_intror _ _) <**> solve_tauto Q2 end | [? (Q1 Q2 : Prop)] Q1 -> Q2 => tintro (fun x:Q1=> solve_tauto Q2) | [? X (Q : X -> Prop)] (exists x : X, Q x) => x <- M.evar X; q <- apply (@ex_intro _ _ _) <**> solve_tauto (Q x); promote_uninst_evar x q | _ => TT.use (T.try T.assumption) end. Ltac solve_tauto := mrun solve_tauto. Goal 5 = 7 -> exists x, x = 7. MProof. r <- solve_tauto; M.ret (mfst r). Qed. Goal exists x, x = 7 -> x = 7. MProof. lower (solve_tauto &** apply 1). Qed. Goal exists x : nat, x = x /\ True. MProof. lower (solve_tauto). Abort. End Mtac_V4. Mtac2-1.4-coq8.20/opam000066400000000000000000000011161472011217100142660ustar00rootroot00000000000000opam-version: "1.2" maintainer: "beta.ziliani@gmail.com" homepage: "https://github.com/Mtac2/Mtac2" dev-repo: "https://github.com/Mtac2/Mtac2.git" bug-reports: "https://github.com/Mtac2/Mtac2/issues" authors: ["Beta Ziliani " "Jan-Oliver Kaiser " "Yann Régis-Gianas "] license: "MIT" build: [ ["./configure.sh"] [make "-j%{jobs}%"] ] install: [ [make "install"] ] remove: ["rm" "-R" "%{lib}%/coq/user-contrib/Mtac2"] depends: [ "coq" {>= "8.20"} "coq-unicoq" ] Mtac2-1.4-coq8.20/scripts/000077500000000000000000000000001472011217100150775ustar00rootroot00000000000000Mtac2-1.4-coq8.20/scripts/hooks/000077500000000000000000000000001472011217100162225ustar00rootroot00000000000000Mtac2-1.4-coq8.20/scripts/hooks/pre-commit000077500000000000000000000042541472011217100202310ustar00rootroot00000000000000#!/bin/sh # # An example hook script to verify what is about to be committed. # Called by "git commit" with no arguments. The hook should # exit with non-zero status after issuing an appropriate message if # it wants to stop the commit. # # To enable this hook, rename this file to "pre-commit". if git rev-parse --verify HEAD >/dev/null 2>&1 then against=HEAD else # Initial commit: diff against an empty tree object against=4b825dc642cb6eb9a060e54bf8d69288fbee4904 fi # If you want to allow non-ASCII filenames set this variable to true. allownonascii=$(git config --bool hooks.allownonascii) # Redirect output to stderr. exec 1>&2 # Cross platform projects tend to avoid non-ASCII filenames; prevent # them from being added to the repository. We exploit the fact that the # printable range starts at the space character and ends with tilde. if [ "$allownonascii" != "true" ] && # Note that the use of brackets around a tr range is ok here, (it's # even required, for portability to Solaris 10's /usr/bin/tr), since # the square bracket bytes happen to fall in the designated range. test $(git diff --cached --name-only --diff-filter=A -z $against | LC_ALL=C tr -d '[ -~]\0' | wc -c) != 0 then cat <<\EOF Error: Attempt to add a non-ASCII file name. This can cause problems if you want to work with people on other platforms. To be portable it is advisable to rename the file. If you know what you are doing you can disable this check using: git config hooks.allownonascii true EOF exit 1 fi # If there are whitespace errors, print the offending file names and fail. git diff-index --check --cached $against -- `git ls-files | grep -Ev "^stdlib-benchs/.*.v$"` || exit 1 ## Custom rules # Check indentation for OCaml files # Check if ocp-indent is installed ocp-indent --version > /dev/null if [ $? -ne 0 ]; then echo "Error: ocp-indent not found. It is necessary in order to commit" exit 1 fi # NOTE: command line taken from goblint: https://github.com/goblint/analyzer git diff --cached --name-only | grep -E ".*\.ml(i|l|y)?$" | xargs -I% bash -c 'diff -u <(git show :%) <(git show :% | ocp-indent) || (echo; echo "Indentation not valid in % (diff shown above)."; false)' || exit 1 Mtac2-1.4-coq8.20/src/000077500000000000000000000000001472011217100141775ustar00rootroot00000000000000Mtac2-1.4-coq8.20/src/META.coq-mtac2.in000066400000000000000000000004451472011217100170450ustar00rootroot00000000000000package "plugin" ( directory = "." description = "Coq Mtac2" requires = "coq-core.plugins.ltac coq-unicoq.plugin" archive(byte) = "MetaCoqPlugin.cma" archive(native) = "MetaCoqPlugin.cmxa" plugin(byte) = "MetaCoqPlugin.cma" plugin(native) = "MetaCoqPlugin.cmxs" ) directory = "."Mtac2-1.4-coq8.20/src/MetaCoqPlugin.mlpack000066400000000000000000000001331472011217100200750ustar00rootroot00000000000000MetaCoq MetaCoqInstr Constrs MtacNames MConstr Run MetaCoqInterp MetaCoqInit MetaCoqTactic Mtac2-1.4-coq8.20/src/constrs.ml000066400000000000000000000332431472011217100162310ustar00rootroot00000000000000open Constr open EConstr open Reductionops let reduce_value = Tacred.compute let decompose_appvect sigma c = match kind sigma c with | App (f,cl) -> (f, cl) | _ -> (c,[||]) module Constrs = struct exception Constr_not_found of string exception Constr_poly of string let glob_to_string gr = Libnames.string_of_path (Nametab.path_of_global gr) let mkGlobal name = lazy (Nametab.global_of_path (Libnames.path_of_string name)) let mkConstr_of_global gr = try of_constr @@ UnivGen.constr_of_monomorphic_global (Global.env ()) gr with Not_found -> raise (Constr_not_found (glob_to_string gr)) | Invalid_argument _ -> raise (Constr_poly (glob_to_string gr)) let mkConstr name = lazy (mkConstr_of_global (Lazy.force (mkGlobal name))) let mkUGlobal name = Nametab.global_of_path (Libnames.path_of_string name) let mkUConstr_of_global gr sigma env = try fresh_global env sigma gr with Not_found -> raise (Constr_not_found (glob_to_string gr)) let mkUConstr name sigma env = mkUConstr_of_global (mkUGlobal name) sigma env let isGlobal sigma r c = Constr.isRefX (Lazy.force r) (to_constr sigma c) let isConstr sigma = fun r c -> eq_constr_nounivs sigma (Lazy.force r) c let isUConstr r sigma env = isRefX env sigma r end module ConstrBuilder = struct open Constrs type t = Names.GlobRef.t Lazy.t let from_string (s:string) : t = lazy (Nametab.global_of_path (Libnames.path_of_string s)) let build (s : t) = lazy (mkConstr_of_global (Lazy.force s)) let build_app (s : t) args = mkApp (mkConstr_of_global (Lazy.force s), args) let equal sigma s = isGlobal sigma s let from_coq s (_, sigma) cterm = let (head, args) = decompose_appvect sigma cterm in if equal sigma s head then Some args else None end module UConstrBuilder = struct open Constrs type t = Names.GlobRef.t Lazy.t let from_string (s:string) : t = lazy (Nametab.global_of_path (Libnames.path_of_string s)) let build_app ?univs s sigma env args = let s = Lazy.force s in let sigma, c = match univs with | Some inst -> sigma, EConstr.mkRef (s, inst) | None -> mkUConstr_of_global s sigma env in (sigma, mkApp (c, args)) let equal s = isUConstr (Lazy.force s) let from_coq s (env, sigma) cterm = let (head, args) = decompose_appvect sigma cterm in if equal s sigma env head then Some args else None end module CoqOption = struct open UConstrBuilder let optionBuilder = from_string "Mtac2.lib.Datatypes.moption" let noneBuilder = from_string "Mtac2.lib.Datatypes.mNone" let someBuilder = from_string "Mtac2.lib.Datatypes.mSome" (* let mkType sigma env ty = build_app optionBuilder sigma env [|ty|] *) let mkNone sigma env ty = build_app noneBuilder sigma env [|ty|] let mkSome sigma env ty t = build_app someBuilder sigma env [|ty; t|] exception NotAnOption let from_coq sigma env cterm = match from_coq noneBuilder (env, sigma) cterm with | None -> begin match from_coq someBuilder (env, sigma) cterm with | None -> raise NotAnOption | Some args -> Some args.(1) end | Some _ -> None let to_coq sigma env ty oterm = match oterm with | None -> mkNone sigma env ty | Some t -> mkSome sigma env ty t end module type ListParams = sig val nilname : string val consname : string val typename : string end module type LIST = sig val listBuilder : UConstrBuilder.t val nilBuilder : UConstrBuilder.t val consBuilder : UConstrBuilder.t val mkNil : Evd.evar_map -> Environ.env -> types -> Evd.evar_map * constr val mkCons : Evd.evar_map -> Environ.env -> types -> constr -> constr -> Evd.evar_map * constr val mkType : Evd.evar_map -> Environ.env -> types -> Evd.evar_map * types exception NotAList of constr val from_coq : Evd.evar_map -> Environ.env -> constr -> constr list (** Allows skipping an element in the conversion *) exception Skip val from_coq_conv : Evd.evar_map -> Environ.env -> (Evd.evar_map -> constr -> Evd.evar_map * 'a) -> constr -> Evd.evar_map * 'a list val to_coq : Evd.evar_map -> Environ.env -> types -> (Evd.evar_map -> 'a -> Evd.evar_map * constr) -> 'a list -> Evd.evar_map * constr val pto_coq : Environ.env -> types -> ('a -> Evd.evar_map -> Evd.evar_map * constr) -> 'a list -> Evd.evar_map -> Evd.evar_map * constr end module GenericList (LP : ListParams) = struct open UConstrBuilder let listBuilder = from_string LP.typename let nilBuilder = from_string LP.nilname let consBuilder = from_string LP.consname let mkType sigma env ty = build_app listBuilder sigma env [|ty|] let mkNil sigma env ty = build_app nilBuilder sigma env [|ty|] let mkCons sigma env t x xs = build_app consBuilder sigma env [| t ; x ; xs |] exception Skip exception NotAList of constr (* given a list of terms and a convertion function fconv it creates a list of elements using the converstion function. if fconv raises Skip, that element is not included. if the list is ill-formed, an exception NotAList is raised. *) let from_coq_conv sigma env (fconv : Evd.evar_map -> constr -> Evd.evar_map * 'a) cterm = let rec fcc sigma cterm = match from_coq consBuilder (env, sigma) cterm with | None -> begin match from_coq nilBuilder (env, sigma) cterm with | None -> raise (NotAList cterm) | Some _ -> sigma, [] end | Some args -> let (sigma, tail) = fcc sigma args.(2) in try let (sigma, h) = fconv sigma args.(1) in (sigma, h :: tail) with Skip -> (sigma, tail) in fcc sigma cterm let from_coq sigma env t = (* it is safe to throw away sigma here because we are not changing it *) snd (from_coq_conv sigma env (fun sigma (x:constr)->(sigma, x)) t) let to_coq sigma env ty f l = List.fold_right (fun e (sigma, l) -> let (sigma, t) = f sigma e in mkCons sigma env ty t l) l (mkNil sigma env ty) let pto_coq env ty f l sigma = List.fold_right (fun e (sigma, l) -> let sigma, c = f e sigma in mkCons sigma env ty c l) l (mkNil sigma env ty) end module CoqList = GenericList (struct let nilname = "Mtac2.lib.Datatypes.mnil" let consname = "Mtac2.lib.Datatypes.mcons" let typename = "Mtac2.lib.Datatypes.mlist" end) module CoqEq = struct open UConstrBuilder let eqBuilder = from_string "Mtac2.lib.Logic.meq" let eqReflBuilder = from_string "Mtac2.lib.Logic.meq_refl" let mkType env sigma a x y = build_app eqBuilder env sigma [|a;x;y|] let mkEqRefl env sigma a x = build_app eqReflBuilder env sigma [|a;x|] end module CoqSig = struct let from_coq (env, sigma) constr = (* NOTE: Hightly unsafe *) let (_, args) = decompose_appvect sigma (whd_all env sigma constr) in args.(1) end module CoqPositive = struct open Constrs let xI = mkGlobal "Coq.Numbers.BinNums.xI" let xO = mkGlobal "Coq.Numbers.BinNums.xO" let xH = mkGlobal "Coq.Numbers.BinNums.xH" let isH sigma = isGlobal sigma xH let isI sigma = isGlobal sigma xI let isO sigma = isGlobal sigma xO let from_coq (env, evd) c = let rec fc i c = if isH evd c then 1 else let (s, n) = destApp evd c in begin if isI evd s then (fc (i+1) (n.(0)))*2 + 1 else if isO evd s then (fc (i+1) (n.(0)))*2 else CErrors.user_err Pp.(str "Not a positive") end in let c' = reduce_value env evd c in fc 0 c' let rec to_coq n = if n = 1 then mkConstr_of_global (Lazy.force xH) else if n mod 2 = 0 then mkApp(mkConstr_of_global (Lazy.force xO), [|to_coq (n / 2)|]) else mkApp(mkConstr_of_global (Lazy.force xI), [|to_coq ((n-1)/2)|]) end module CoqN = struct open Constrs (* let tN = Constr.mkConstr "Coq.Numbers.BinNums.N" *) let h0 = mkGlobal "Coq.Numbers.BinNums.N0" let hP = mkGlobal "Coq.Numbers.BinNums.Npos" let is0 sigma = isGlobal sigma h0 let isP sigma = isGlobal sigma hP exception NotAnN let from_coq (env, evd) c = let fc c = if is0 evd c then 0 else let (s, n) = destApp evd c in begin if isP evd s then CoqPositive.from_coq (env, evd) (n.(0)) else raise NotAnN end in let c' = reduce_value env evd c in fc c' let to_coq n = if n = 0 then mkConstr_of_global (Lazy.force h0) else mkApp(mkConstr_of_global (Lazy.force hP), [|CoqPositive.to_coq n|]) end module CoqZ = struct open Constrs let z0 = mkGlobal "Coq.Numbers.BinNums.Z0" let zpos = mkGlobal "Coq.Numbers.BinNums.Zpos" let zneg = mkGlobal "Coq.Numbers.BinNums.Zneg" let to_coq n = if n = 0 then mkConstr_of_global (Lazy.force z0) else if n > 0 then mkApp(mkConstr_of_global (Lazy.force zpos), [|CoqPositive.to_coq n|]) else mkApp(mkConstr_of_global (Lazy.force zneg), [|CoqPositive.to_coq n|]) end module CoqBool = struct open ConstrBuilder let boolBuilder = from_string "Coq.Init.Datatypes.bool" let trueBuilder = from_string "Coq.Init.Datatypes.true" let falseBuilder = from_string "Coq.Init.Datatypes.false" let mkType = build boolBuilder let mkTrue = build trueBuilder let mkFalse = build falseBuilder exception NotABool let to_coq b = if b then Lazy.force mkTrue else Lazy.force mkFalse let from_coq sigma c = if equal sigma trueBuilder c then true else if equal sigma falseBuilder c then false else raise NotABool end module CoqAscii = struct open ConstrBuilder let asciiBuilder = from_string "Coq.Strings.Ascii.Ascii" let from_coq (_, sigma) c = let (h, args) = decompose_appvect sigma c in let rec from_bits n = if n >= Array.length args then 0 else (if CoqBool.from_coq sigma args.(n) then 1 else 0) lsl n + from_bits (n+1) in let n = from_bits 0 in Char.chr n let to_coq c = let c = int_of_char c in let a = Array.init 8 (fun i->(c lsr i) mod 2 = 1) in let a = Array.map CoqBool.to_coq a in build_app asciiBuilder a end module CoqString = struct open ConstrBuilder let emptyBuilder = from_string "Coq.Strings.String.EmptyString" let stringBuilder = from_string "Coq.Strings.String.String" exception NotAString let from_coq (env, sigma as ctx) s = let buf = Buffer.create 128 in let rec fc s = let (h, args) = decompose_appvect sigma s in if equal sigma stringBuilder h then let _ = Buffer.add_char buf (CoqAscii.from_coq ctx args.(0)) in fc args.(1) else if equal sigma emptyBuilder h then () else raise NotAString in fc (reduce_value env sigma s); Buffer.contents buf let to_coq s = let str_cons = build_app stringBuilder [||] in let rec go i coqstr = if i < 0 then coqstr else go (i - 1) ( mkApp (str_cons, [|CoqAscii.to_coq s.[i]; coqstr|])) in go (String.length s - 1) (Lazy.force (build emptyBuilder)) end module CoqUnit = struct open ConstrBuilder let unitBuilder = from_string "Coq.Init.Datatypes.unit" let ttBuilder = from_string "Coq.Init.Datatypes.tt" let mkType = build unitBuilder let mkTT = build ttBuilder end module MCTactics = struct open UConstrBuilder let gTactic = from_string "Mtac2.tactics.TacticsBase.gtactic" (* let mkConstr s = *) (* let open Nametab in let open Libnames in *) (* try Universes.constr_of_global (locate (qualid_of_string s)) *) (* with _ -> raise (Constr.Constr_not_found s) *) let mkGTactic env sigma = build_app gTactic sigma env [||] end module CoqPair = struct open UConstrBuilder let pairBuilder = from_string "Mtac2.lib.Datatypes.mpair" let mkPair sigma env tya tyb a b = build_app pairBuilder sigma env [|tya;tyb;a;b|] exception NotAPair let from_coq ctx cterm = match from_coq pairBuilder ctx cterm with | None -> raise NotAPair | Some args -> (args.(2), args.(3)) end module CoqMTele = struct open UConstrBuilder let mBaseBuilder = from_string "Mtac2.intf.MTele.mBase" let mTeleBuilder = from_string "Mtac2.intf.MTele.mTele" exception NotAnMTele let from_coq sigma env cterm = match from_coq mTeleBuilder (env, sigma) cterm with | None -> begin match from_coq mBaseBuilder (env, sigma) cterm with | None -> raise NotAnMTele | Some _ -> None end | Some args -> Some (args.(0), args.(1)) end module CoqSigT = struct open UConstrBuilder let mexistTBuilder = from_string "Mtac2.lib.Specif.mexistT" exception NotAmexistT let from_coq sigma env cterm = match from_coq mexistTBuilder (env, sigma) cterm with | None -> raise NotAmexistT | Some args -> (args.(2), args.(3)) end module CoqSort = struct open UConstrBuilder let sType = from_string "Mtac2.intf.Sorts.S.Type_sort" let sProp = from_string "Mtac2.intf.Sorts.S.Prop_sort" let mkSType env sigma = build_app sType sigma env [||] let mkSProp env sigma = build_app sProp sigma env [||] exception NotASort type sort = Prop_sort | Type_sort let from_coq sigma env cterm = match from_coq sProp (env, sigma) cterm with | Some args -> Prop_sort | None -> match from_coq sType (env, sigma) cterm with | None -> raise NotASort | Some args -> Type_sort let to_coq sigma env = function | Prop_sort -> mkSProp env sigma | Type_sort -> mkSType env sigma end module CoqInd_Dyn = struct open UConstrBuilder let mkInd_dyn = from_string "Mtac2.intf.Case.mkInd_dyn" exception NotAmkInd_dyn let from_coq sigma env cterm = match from_coq mkInd_dyn (env, sigma) cterm with | None -> raise NotAmkInd_dyn | Some args -> args let to_coq sigma env = build_app mkInd_dyn sigma env end Mtac2-1.4-coq8.20/src/constrs.mli000066400000000000000000000115471472011217100164050ustar00rootroot00000000000000open Evd open EConstr val decompose_appvect : evar_map -> constr -> constr * constr array module Constrs : sig exception Constr_not_found of string exception Constr_poly of string val mkUGlobal : string -> Names.GlobRef.t val mkConstr : string -> constr Lazy.t val mkConstr_of_global : Names.GlobRef.t -> constr val mkUConstr : string -> evar_map -> Environ.env -> (Evd.evar_map * constr) val mkUConstr_of_global : Names.GlobRef.t -> evar_map -> Environ.env -> (Evd.evar_map * constr) val isConstr : evar_map -> constr Lazy.t -> constr -> bool end module ConstrBuilder : sig type t val from_string : string -> t val from_coq : t -> (Environ.env * Evd.evar_map) -> constr -> (constr array) option val build_app : t -> constr array -> constr val equal : evar_map -> t -> constr -> bool end module UConstrBuilder : sig type t val from_string : string -> t val from_coq : t -> (Environ.env * Evd.evar_map) -> constr -> (constr array) option val build_app : ?univs:(EInstance.t) -> t -> Evd.evar_map -> Environ.env -> constr array -> (Evd.evar_map * constr) end module CoqN : sig exception NotAnN val from_coq : (Environ.env * Evd.evar_map) -> constr -> int val to_coq : int -> constr end module CoqZ : sig val to_coq : int -> constr end module CoqString : sig exception NotAString val from_coq : (Environ.env * Evd.evar_map) -> constr -> string val to_coq : string -> constr end module type ListParams = sig val nilname : string val consname : string val typename : string end module type LIST = sig val listBuilder : UConstrBuilder.t val nilBuilder : UConstrBuilder.t val consBuilder : UConstrBuilder.t val mkNil : Evd.evar_map -> Environ.env -> types -> Evd.evar_map * constr val mkCons : Evd.evar_map -> Environ.env -> types -> constr -> constr -> Evd.evar_map * constr val mkType : Evd.evar_map -> Environ.env -> types -> Evd.evar_map * types exception NotAList of constr val from_coq : Evd.evar_map -> Environ.env -> constr -> constr list (** Allows skipping an element in the conversion *) exception Skip val from_coq_conv : Evd.evar_map -> Environ.env -> (Evd.evar_map -> constr -> Evd.evar_map * 'a) -> constr -> Evd.evar_map * 'a list val to_coq : Evd.evar_map -> Environ.env -> types -> (Evd.evar_map -> 'a -> Evd.evar_map * constr) -> 'a list -> Evd.evar_map * constr val pto_coq : Environ.env -> types -> ('a -> Evd.evar_map -> Evd.evar_map * constr) -> 'a list -> Evd.evar_map -> Evd.evar_map * constr end module GenericList : functor (LP : ListParams) -> LIST module CoqList : LIST module CoqOption : sig val optionBuilder : UConstrBuilder.t val noneBuilder : UConstrBuilder.t val someBuilder : UConstrBuilder.t val mkNone : Evd.evar_map -> Environ.env -> types -> Evd.evar_map * constr val mkSome : Evd.evar_map -> Environ.env -> types -> constr -> Evd.evar_map * constr exception NotAnOption val from_coq : Evd.evar_map -> Environ.env -> constr -> constr option (** to_coq ty ot constructs an option type with type ty *) val to_coq : Evd.evar_map -> Environ.env -> types -> constr option -> Evd.evar_map * constr end module CoqUnit : sig val mkType : constr Lazy.t val mkTT : constr Lazy.t end module CoqBool : sig val mkType : constr Lazy.t val mkTrue : constr Lazy.t val mkFalse : constr Lazy.t exception NotABool val to_coq : bool -> constr val from_coq : evar_map -> constr -> bool end module CoqEq : sig val mkType : Evd.evar_map -> Environ.env -> types -> constr -> constr -> Evd.evar_map * constr val mkEqRefl : Evd.evar_map -> Environ.env -> types -> constr -> Evd.evar_map * constr end module CoqSig : sig val from_coq : (Environ.env * Evd.evar_map) -> constr -> constr end module MCTactics : sig val mkGTactic : Environ.env -> Evd.evar_map -> Evd.evar_map * constr end module CoqPair : sig exception NotAPair val mkPair : Evd.evar_map -> Environ.env -> types -> types -> constr -> constr -> Evd.evar_map * constr val from_coq : (Environ.env * Evd.evar_map) -> constr -> constr * constr end module CoqMTele : sig exception NotAnMTele val from_coq : Evd.evar_map -> Environ.env -> constr -> (constr * constr) option end module CoqSigT : sig exception NotAmexistT val from_coq : Evd.evar_map -> Environ.env -> constr -> (constr * constr) end module CoqSort : sig val mkSType : Environ.env -> Evd.evar_map -> Evd.evar_map * EConstr.t val mkSProp : Environ.env -> Evd.evar_map -> Evd.evar_map * EConstr.t exception NotASort type sort = Prop_sort | Type_sort val from_coq : Evd.evar_map -> Environ.env -> EConstr.t -> sort val to_coq : Evd.evar_map -> Environ.env -> sort -> Evd.evar_map * EConstr.t end module CoqInd_Dyn : sig exception NotAmkInd_dyn val from_coq : Evd.evar_map -> Environ.env -> EConstr.t -> EConstr.t array val to_coq : Evd.evar_map -> Environ.env -> EConstr.t array -> Evd.evar_map * EConstr.t end Mtac2-1.4-coq8.20/src/dune000066400000000000000000000006711472011217100150610ustar00rootroot00000000000000(library (name MetaCoqPlugin) (public_name coq-mtac2.plugin) (flags :standard -rectypes -w -9-27-23 -warn-error -3) (modules_without_implementation metaCoqInstr) (modules :standard) (libraries coq.plugins.ltac unicoq.plugin)) (rule (targets metaCoqInit.ml) (deps (:pp-file metaCoqInit.mlg)) (action (run coqpp %{pp-file}))) (rule (targets metaCoqTactic.ml) (deps (:pp-file metaCoqTactic.mlg)) (action (run coqpp %{pp-file}))) Mtac2-1.4-coq8.20/src/mConstr.ml000066400000000000000000000544421472011217100161670ustar00rootroot00000000000000open MtacNames open EConstr type arg = CClosure.fconstr type arg_any = arg type arg_type = arg type arg_fun = arg type arg_string = arg type arg_N = arg type arg_bool = arg type arg_mlist = arg type arg_case = arg type arg_fix1_ty = arg_type type arg_fix1_val = arg_any type arg_fix2_ty = arg_type * arg_type type arg_fix2_val = arg_any * arg_any type arg_fix3_ty = arg_type * arg_type * arg_type type arg_fix3_val = arg_any * arg_any * arg_any type arg_fix4_ty = arg_type * arg_type * arg_type * arg_type type arg_fix4_val = arg_any * arg_any * arg_any * arg_any type arg_fix5_ty = arg_type * arg_type * arg_type * arg_type * arg_type type arg_fix5_val = arg_any * arg_any * arg_any * arg_any * arg_any type 'a mconstr_head = | Mret : (arg_type * arg_any) mconstr_head | Mbind : (arg_type * arg_type * arg_any * arg_fun) mconstr_head | Mmtry' : (arg_type * arg_any * arg_fun) mconstr_head | Mraise' : (arg_type * arg_any) mconstr_head | Mfix1 : (arg_fix1_ty * arg_type * arg_fun * arg_fix1_val) mconstr_head | Mfix2 : (arg_fix2_ty * arg_type * arg_fun * arg_fix2_val) mconstr_head | Mfix3 : (arg_fix3_ty * arg_type * arg_fun * arg_fix3_val) mconstr_head | Mfix4 : (arg_fix4_ty * arg_type * arg_fun * arg_fix4_val) mconstr_head | Mfix5 : (arg_fix5_ty * arg_type * arg_fun * arg_fix5_val) mconstr_head | Mis_var : (arg_type * arg_any) mconstr_head | Mnu : (arg_type * arg_type * arg_string * arg_any * arg_fun) mconstr_head | Mnu_let : (arg_type * arg_type * arg_type * arg_string * arg_any * arg_fun) mconstr_head | Mabs_fun : (arg_type * arg_fun * arg_any * arg_any) mconstr_head | Mabs_let : (arg_type * arg_fun * arg_any * arg_any * arg_any) mconstr_head | Mabs_prod_prop : (arg_type * arg_any * arg_type) mconstr_head | Mabs_prod_type : (arg_type * arg_any * arg_type) mconstr_head | Mabs_fix : (arg_type * arg_any * arg_any * arg_N) mconstr_head | Mget_binder_name : (arg_type * arg_any) mconstr_head | Mremove : (arg_type * arg_type * arg_any * arg_any) mconstr_head | Mgen_evar : (arg_type * arg_any) mconstr_head | Mis_evar : (arg_type * arg_any) mconstr_head | Mhash : (arg_type * arg_any * arg_N) mconstr_head | Msolve_typeclasses | Mprint : (arg_string) mconstr_head | Mpretty_print : (arg_type * arg_any) mconstr_head | Mhyps | Mdestcase : (arg_type * arg_any) mconstr_head | Mconstrs : (arg_type * arg_any) mconstr_head | Mmakecase : (arg_case) mconstr_head | Munify : (arg_type * arg_type * arg_any * arg_any * arg_any * arg_fun * arg_fun) mconstr_head | Munify_cumul : (arg_type * arg_type * arg_type * arg_any * arg_fun * arg_fun) mconstr_head | Mget_reference : (arg_string) mconstr_head | Mget_var : (arg_string) mconstr_head | Mcall_ltac : (arg_any * arg_any * arg_string * arg_mlist) mconstr_head | Mlist_ltac | Mread_line | Mdecompose : (arg_type * arg_any) mconstr_head | Msolve_typeclass : (arg_type) mconstr_head | Mdeclare : (arg_any * arg_string * arg_bool * arg_type * arg_any) mconstr_head | Mdeclare_implicits : (arg_type * arg_any * arg_mlist) mconstr_head | Mos_cmd : (arg_string) mconstr_head | Mget_debug_exceptions | Mset_debug_exceptions : (arg_bool) mconstr_head | Mget_trace | Mset_trace : (arg_bool) mconstr_head | Mdecompose_app' : (arg_type * arg_fun * arg_any * arg_any * arg_any * arg_any * arg_any * arg_any) mconstr_head | Mdecompose_forallT : (arg_fun * arg_type * arg_any * arg_any) mconstr_head | Mdecompose_forallP : (arg_fun * arg_type * arg_any * arg_any) mconstr_head | Mdecompose_app'' : (arg_fun * arg_fun * arg_any * arg_any) mconstr_head | Mnew_timer : (arg_type * arg_any) mconstr_head | Mstart_timer : (arg_type * arg_any * arg_bool) mconstr_head | Mstop_timer : (arg_type * arg_any) mconstr_head | Mreset_timer : (arg_type * arg_any) mconstr_head | Mprint_timer : (arg_type * arg_any) mconstr_head | Mkind_of_term : (arg_type * arg_any) mconstr_head | Mreplace : (arg_type * arg_type * arg_type * arg_any * arg_any * arg_any) mconstr_head | Mdeclare_mind : (arg_any * arg_any * arg_any) mconstr_head | Mexisting_instance : (arg_any * arg_any * arg_bool) mconstr_head | Minstantiate_evar : (arg_type * arg_type * arg_any * arg_any * arg_fun * arg_fun) mconstr_head and mhead = | MHead : 'a mconstr_head -> mhead and mconstr = | MConstr : 'a mconstr_head * 'a -> mconstr let num_args_of_mconstr (type a) (mh : a mconstr_head) = match mh with | Mret -> 2 | Mbind -> 4 | Mmtry' -> 3 | Mraise' -> 2 | Mfix1 -> 2 + 2*1 | Mfix2 -> 2 + 2*2 | Mfix3 -> 2 + 2*3 | Mfix4 -> 2 + 2*4 | Mfix5 -> 2 + 2*5 | Mis_var -> 2 | Mnu -> 5 | Mnu_let -> 6 | Mabs_fun -> 4 | Mabs_let -> 5 | Mabs_prod_prop -> 3 | Mabs_prod_type -> 3 | Mabs_fix -> 4 | Mget_binder_name -> 2 | Mremove -> 4 | Mgen_evar -> 2 | Mis_evar -> 2 | Mhash -> 3 | Msolve_typeclasses -> 0 | Mprint -> 1 | Mpretty_print -> 2 | Mhyps -> 0 | Mdestcase -> 2 | Mconstrs -> 2 | Mmakecase -> 1 | Munify -> 7 | Munify_cumul -> 6 | Mget_reference -> 1 | Mget_var -> 1 | Mcall_ltac -> 4 | Mlist_ltac -> 0 | Mread_line -> 0 | Mdecompose -> 2 | Msolve_typeclass -> 1 | Mdeclare -> 5 | Mdeclare_implicits -> 3 | Mos_cmd -> 1 | Mget_debug_exceptions -> 0 | Mset_debug_exceptions -> 1 | Mget_trace -> 0 | Mset_trace -> 1 | Mdecompose_app' -> 8 | Mdecompose_forallT -> 4 | Mdecompose_forallP -> 4 | Mdecompose_app'' -> 4 | Mnew_timer -> 2 | Mstart_timer -> 3 | Mstop_timer -> 2 | Mreset_timer -> 2 | Mprint_timer -> 2 | Mkind_of_term -> 2 | Mreplace -> 6 | Mdeclare_mind -> 3 | Mexisting_instance -> 3 | Minstantiate_evar -> 6 let _mkconstr s = lazy (let (_, c) = mkUConstr ("M.M." ^ s) Evd.empty (Global.env ()) in c) let _isconstr c h = eq_constr_nounivs Evd.empty (Lazy.force c) h let isconstant n h = Names.Constant.CanOrd.equal (Lazy.force n) h let constant_of_string s = lazy (constant_of_string ("M.M." ^ s)) let name_ret = constant_of_string "ret" (* let mkret = mkconstr name_ret *) let isret = isconstant name_ret let name_bind = constant_of_string "bind" (* let mkbind = mkconstr name_bind *) let isbind = isconstant name_bind let name_try' = constant_of_string "mtry'" (* let mktry' = mkconstr name_try' *) let istry' = isconstant name_try' let name_raise = constant_of_string "raise'" (* let mkraise = mkconstr name_raise *) let israise = isconstant name_raise let name_fix1 = constant_of_string "fix1" (* let mkfix1 = mkconstr name_fix1 *) let isfix1 = isconstant name_fix1 let name_fix2 = constant_of_string "fix2" (* let mkfix2 = mkconstr name_fix2 *) let isfix2 = isconstant name_fix2 let name_fix3 = constant_of_string "fix3" (* let mkfix3 = mkconstr name_fix3 *) let isfix3 = isconstant name_fix3 let name_fix4 = constant_of_string "fix4" (* let mkfix4 = mkconstr name_fix4 *) let isfix4 = isconstant name_fix4 let name_fix5 = constant_of_string "fix5" (* let mkfix5 = mkconstr name_fix5 *) let isfix5 = isconstant name_fix5 let name_is_var = constant_of_string "is_var" (* let mkis_var = mkconstr name_is_var *) let isis_var = isconstant name_is_var let name_nu = constant_of_string "nu" (* let mknu = mkconstr name_nu *) let isnu = isconstant name_nu let name_nu_let = constant_of_string "nu_let" let isnu_let = isconstant name_nu_let let name_abs_fun = constant_of_string "abs_fun" (* let mkabs_fun = mkconstr name_abs_fun *) let isabs_fun = isconstant name_abs_fun let name_abs_let = constant_of_string "abs_let" (* let mkabs_let = mkconstr name_abs_let *) let isabs_let = isconstant name_abs_let let name_abs_prod_prop = constant_of_string "abs_prod_prop" (* let mkabs_prod_prop = mkconstr name_abs_prod_prop *) let isabs_prod_prop = isconstant name_abs_prod_prop let name_abs_prod_type = constant_of_string "abs_prod_type" (* let mkabs_prod_type = mkconstr name_abs_prod_type *) let isabs_prod_type = isconstant name_abs_prod_type let name_abs_fix = constant_of_string "abs_fix" (* let mkabs_fix = mkconstr name_abs_fix *) let isabs_fix = isconstant name_abs_fix let name_get_binder_name = constant_of_string "get_binder_name" (* let mkget_binder_name = mkconstr name_get_binder_name *) let isget_binder_name = isconstant name_get_binder_name let name_remove = constant_of_string "remove" (* let mkremove = mkconstr name_remove *) let isremove = isconstant name_remove let name_gen_evar = constant_of_string "gen_evar" (* let mkgen_evar = mkconstr name_gen_evar *) let isgen_evar = isconstant name_gen_evar let name_is_evar = constant_of_string "is_evar" (* let mkis_evar = mkconstr name_is_evar *) let isis_evar = isconstant name_is_evar let name_hash = constant_of_string "hash" (* let mkhash = mkconstr name_hash *) let ishash = isconstant name_hash let name_solve_typeclasses = constant_of_string "solve_typeclasses" (* let mksolve_typeclasses = mkconstr name_solve_typeclasses *) let issolve_typeclasses = isconstant name_solve_typeclasses let name_print = constant_of_string "print" (* let mkprint = mkconstr name_print *) let isprint = isconstant name_print let name_pretty_print = constant_of_string "pretty_print" (* let mkpretty_print = mkconstr name_pretty_print *) let ispretty_print = isconstant name_pretty_print let name_hyps = constant_of_string "hyps" (* let mkhyps = mkconstr name_hyps *) let ishyps = isconstant name_hyps let name_destcase = constant_of_string "destcase" (* let mkdestcase = mkconstr name_destcase *) let isdestcase = isconstant name_destcase let name_constrs = constant_of_string "constrs" (* let mkconstrs = mkconstr name_constrs *) let isconstrs = isconstant name_constrs let name_makecase = constant_of_string "makecase" (* let mkmakecase = mkconstr name_makecase *) let ismakecase = isconstant name_makecase let name_unify = constant_of_string "unify_cnt" (* let mkunify = mkconstr name_unify *) let isunify = isconstant name_unify let name_unify_cumul = constant_of_string "unify_cumul_cnt" (* let mkunify_cumul = mkconstr name_unify_cumul *) let isunify_cumul = isconstant name_unify_cumul let name_get_reference = constant_of_string "get_reference" (* let mkget_reference = mkconstr name_get_reference *) let isget_reference = isconstant name_get_reference let name_get_var = constant_of_string "get_var" (* let mkget_var = mkconstr name_get_var *) let isget_var = isconstant name_get_var let name_call_ltac = constant_of_string "call_ltac" (* let mkcall_ltac = mkconstr name_call_ltac *) let iscall_ltac = isconstant name_call_ltac let name_list_ltac = constant_of_string "list_ltac" (* let mklist_ltac = mkconstr name_list_ltac *) let islist_ltac = isconstant name_list_ltac let name_read_line = constant_of_string "read_line" (* let mkread_line = mkconstr name_read_line *) let isread_line = isconstant name_read_line (* let name_break = constant_of_string "break" * (\* let mkbreak = mkconstr name_break *\) * let isbreak = isconstant name_break *) let name_decompose = constant_of_string "decompose" (* let mkdecompose = mkconstr name_decompose *) let isdecompose = isconstant name_decompose let name_solve_typeclass = constant_of_string "solve_typeclass" (* let mksolve_typeclass = mkconstr name_solve_typeclass *) let issolve_typeclass = isconstant name_solve_typeclass let name_declare = constant_of_string "declare" (* let mkdeclare = mkconstr name_declare *) let isdeclare = isconstant name_declare let name_declare_implicits = constant_of_string "declare_implicits" (* let mkdeclare_implicits = mkconstr name_declare_implicits *) let isdeclare_implicits = isconstant name_declare_implicits let name_os_cmd = constant_of_string "os_cmd" (* let mkos_cmd = mkconstr name_os_cmd *) let isos_cmd = isconstant name_os_cmd let name_get_debug_ex = constant_of_string "get_debug_exceptions" (* let mkget_debug_ex = mkconstr name_get_debug_ex *) let isget_debug_ex = isconstant name_get_debug_ex let name_set_debug_ex = constant_of_string "set_debug_exceptions" (* let mkset_debug_ex = mkconstr name_set_debug_ex *) let isset_debug_ex = isconstant name_set_debug_ex let name_get_trace = constant_of_string "get_trace" (* let mkget_trace = mkconstr name_get_trace *) let isget_trace = isconstant name_get_trace let name_set_trace = constant_of_string "set_trace" (* let mkset_trace = mkconstr name_set_trace *) let isset_trace = isconstant name_set_trace let name_decompose_app = constant_of_string "is_head" (* let mkdecompose_app = mkconstr name_decompose_app *) let isdecompose_app = isconstant name_decompose_app let name_decompose_forallT = constant_of_string "decompose_forallT" (* let mkdecompose_forallT = mkconstr name_decompose_forallT *) let isdecompose_forallT = isconstant name_decompose_forallT let name_decompose_forallP = constant_of_string "decompose_forallP" (* let mkdecompose_forallP = mkconstr name_decompose_forallP *) let isdecompose_forallP = isconstant name_decompose_forallP let name_decompose_app'' = constant_of_string "decompose_app''" (* let mkdecompose_app'' = mkconstr name_decompose_app'' *) let isdecompose_app'' = isconstant name_decompose_app'' let name_new_timer = constant_of_string "new_timer" (* let mknew_timer = mkconstr name_new_timer *) let isnew_timer = isconstant name_new_timer let name_start_timer = constant_of_string "start_timer" (* let mkstart_timer = mkconstr name_start_timer *) let isstart_timer = isconstant name_start_timer let name_stop_timer = constant_of_string "stop_timer" (* let mkstop_timer = mkconstr name_stop_timer *) let isstop_timer = isconstant name_stop_timer let name_reset_timer = constant_of_string "reset_timer" (* let mkreset_timer = mkconstr name_reset_timer *) let isreset_timer = isconstant name_reset_timer let name_print_timer = constant_of_string "print_timer" (* let mkprint_timer = mkconstr name_print_timer *) let isprint_timer = isconstant name_print_timer let name_kind_of_term = constant_of_string "kind_of_term" (* let mkkind_of_term = mkconstr name_kind_of_term *) let iskind_of_term = isconstant name_kind_of_term let name_replace = constant_of_string "replace" let isreplace = isconstant name_replace let name_declare_mind = constant_of_string "declare_mind" let isdeclare_mind = isconstant name_declare_mind let name_existing_instance = constant_of_string "existing_instance" let isexisting_instance = isconstant name_existing_instance let name_instantiate_evar = constant_of_string "instantiate_evar" let isinstantiate_evar = isconstant name_instantiate_evar let mconstr_head_of h = match h with | _ when isret h -> MHead Mret | _ when isbind h -> MHead Mbind | _ when istry' h -> MHead Mmtry' | _ when israise h -> MHead Mraise' | _ when isfix1 h -> MHead Mfix1 | _ when isfix2 h -> MHead Mfix2 | _ when isfix3 h -> MHead Mfix3 | _ when isfix4 h -> MHead Mfix4 | _ when isfix5 h -> MHead Mfix5 | _ when isis_var h -> MHead Mis_var | _ when isnu h -> MHead Mnu | _ when isnu_let h -> MHead Mnu_let | _ when isabs_fun h -> MHead Mabs_fun | _ when isabs_let h -> MHead Mabs_let | _ when isabs_prod_type h -> MHead Mabs_prod_type | _ when isabs_prod_prop h -> MHead Mabs_prod_prop | _ when isabs_fix h -> MHead Mabs_fix | _ when isget_binder_name h -> MHead Mget_binder_name | _ when isremove h -> MHead Mremove | _ when isgen_evar h -> MHead Mgen_evar | _ when isis_evar h -> MHead Mis_evar | _ when ishash h -> MHead Mhash | _ when issolve_typeclasses h -> MHead Msolve_typeclasses | _ when isprint h -> MHead Mprint | _ when ispretty_print h -> MHead Mpretty_print | _ when ishyps h -> MHead Mhyps | _ when isdestcase h -> MHead Mdestcase | _ when isconstrs h -> MHead Mconstrs | _ when ismakecase h -> MHead Mmakecase | _ when isunify h -> MHead Munify | _ when isunify_cumul h -> MHead Munify_cumul | _ when isget_reference h -> MHead Mget_reference | _ when isget_var h -> MHead Mget_var | _ when iscall_ltac h -> MHead Mcall_ltac | _ when islist_ltac h -> MHead Mlist_ltac | _ when isread_line h -> MHead Mread_line | _ when isdecompose h -> MHead Mdecompose | _ when issolve_typeclass h -> MHead Msolve_typeclass | _ when isdeclare h -> MHead Mdeclare | _ when isdeclare_implicits h -> MHead Mdeclare_implicits | _ when isos_cmd h -> MHead Mos_cmd | _ when isget_debug_ex h -> MHead Mget_debug_exceptions | _ when isset_debug_ex h -> MHead Mset_debug_exceptions | _ when isget_trace h -> MHead Mget_trace | _ when isset_trace h -> MHead Mset_trace | _ when isdecompose_app h -> MHead Mdecompose_app' | _ when isdecompose_forallT h -> MHead Mdecompose_forallT | _ when isdecompose_forallP h -> MHead Mdecompose_forallP | _ when isdecompose_app'' h -> MHead Mdecompose_app'' | _ when isnew_timer h -> MHead Mnew_timer | _ when isstart_timer h -> MHead Mstart_timer | _ when isstop_timer h -> MHead Mstop_timer | _ when isreset_timer h -> MHead Mreset_timer | _ when isprint_timer h -> MHead Mprint_timer | _ when iskind_of_term h -> MHead Mkind_of_term | _ when isreplace h -> MHead Mreplace | _ when isdeclare_mind h -> MHead Mdeclare_mind | _ when isexisting_instance h -> MHead Mexisting_instance | _ when isinstantiate_evar h -> MHead Minstantiate_evar | _ -> raise Not_found let mconstr_head_opt h = match mconstr_head_of h with | mh -> Some(mh) | exception Not_found -> None let mconstr_of (type a) args (h : a mconstr_head) = match h with | Mret -> MConstr (Mret,(args 0, args 1)) | Mbind -> MConstr (Mbind, (args 0, args 1, args 2, args 3)) | Mmtry' -> MConstr (Mmtry', (args 0, args 1, args 2)) | Mraise' -> MConstr (Mraise', (args 0, args 1)) | Mfix1 -> let n = 1 in let m = n+2 in let types = (args 0) in let ret = (args n) in let bod = (args (n+1)) in let vals = (args (m+0)) in MConstr (Mfix1, (types, ret, bod, vals)) | Mfix2 -> let n = 2 in let m = n+2 in let types = (args 0, args 1) in let ret = (args n) in let bod = (args (n+1)) in let vals = (args (m+0), args (m+1)) in MConstr (Mfix2, (types, ret, bod, vals)) | Mfix3 -> let n = 3 in let m = n+2 in let types = (args 0, args 1, args 2) in let ret = (args n) in let bod = (args (n+1)) in let vals = (args (m+0), args (m+1), args (m+2)) in MConstr (Mfix3, (types, ret, bod, vals)) | Mfix4 -> let n = 4 in let m = n+2 in let types = (args 0, args 1, args 2, args 3) in let ret = (args n) in let bod = (args (n+1)) in let vals = (args (m+0), args (m+1), args (m+2), args (m+3)) in MConstr (Mfix4, (types, ret, bod, vals)) | Mfix5 -> let n = 5 in let m = n+2 in let types = (args 0, args 1, args 2, args 3, args 4) in let ret = (args n) in let bod = (args (n+1)) in let vals = (args (m+0), args (m+1), args (m+2), args (m+3), args (m+4)) in MConstr (Mfix5, (types, ret, bod, vals)) | Mis_var -> MConstr (Mis_var, (args 0, args 1)) | Mnu -> MConstr (Mnu, (args 0, args 1, args 2, args 3, args 4)) | Mnu_let -> MConstr (Mnu_let, (args 0, args 1, args 2, args 3, args 4, args 5)) | Mabs_fun -> MConstr (Mabs_fun, (args 0, args 1, args 2, args 3)) | Mabs_let -> MConstr (Mabs_let, (args 0, args 1, args 2, args 3, args 4)) | Mabs_prod_type -> MConstr (Mabs_prod_type, (args 0, args 1, args 2)) | Mabs_prod_prop -> MConstr (Mabs_prod_prop, (args 0, args 1, args 2)) | Mabs_fix -> MConstr (Mabs_fix, (args 0, args 1, args 2, args 3)) | Mget_binder_name -> MConstr (Mget_binder_name, (args 0, args 1)) | Mremove -> MConstr (Mremove, (args 0, args 1, args 2, args 3)) | Mgen_evar -> MConstr (Mgen_evar, (args 0, args 1)) | Mis_evar -> MConstr (Mis_evar, (args 0, args 1)) | Mhash -> MConstr (Mhash, (args 0, args 1, args 2)) | Msolve_typeclasses -> MConstr (Msolve_typeclasses, ()) | Mprint -> MConstr (Mprint, (args 0)) | Mpretty_print -> MConstr (Mpretty_print, (args 0, args 1)) | Mhyps -> MConstr (Mhyps, ()) | Mdestcase -> MConstr (Mdestcase, (args 0, args 1)) | Mconstrs -> MConstr (Mconstrs, (args 0, args 1)) | Mmakecase -> MConstr (Mmakecase, (args 0)) | Munify -> MConstr (Munify, (args 0, args 1, args 2, args 3, args 4, args 5, args 6)) | Munify_cumul -> MConstr (Munify_cumul, (args 0, args 1, args 2, args 3, args 4, args 5)) | Mget_reference -> MConstr (Mget_reference, (args 0)) | Mget_var -> MConstr (Mget_var, (args 0)) | Mcall_ltac -> MConstr (Mcall_ltac, (args 0, args 1, args 2, args 3)) | Mlist_ltac -> MConstr (Mlist_ltac, ()) | Mread_line -> MConstr (Mread_line, ()) | Mdecompose -> MConstr (Mdecompose, (args 0, args 1)) | Msolve_typeclass -> MConstr (Msolve_typeclass, (args 0)) | Mdeclare -> MConstr (Mdeclare, (args 0, args 1, args 2, args 3, args 4)) | Mdeclare_implicits -> MConstr (Mdeclare_implicits, (args 0, args 1, args 2)) | Mos_cmd -> MConstr (Mos_cmd, (args 0)) | Mget_debug_exceptions -> MConstr (Mget_debug_exceptions, ()) | Mset_debug_exceptions -> MConstr (Mset_debug_exceptions, (args 0)) | Mget_trace -> MConstr (Mget_trace, ()) | Mset_trace -> MConstr (Mset_trace, (args 0)) | Mdecompose_app' -> MConstr (Mdecompose_app', (args 0, args 1, args 2, args 3, args 4, args 5, args 6, args 7)) | Mdecompose_forallT -> MConstr (Mdecompose_forallT, (args 0, args 1, args 2, args 3)) | Mdecompose_forallP -> MConstr (Mdecompose_forallP, (args 0, args 1, args 2, args 3)) | Mdecompose_app'' -> MConstr (Mdecompose_app'', (args 0, args 1, args 2, args 3)) | Mnew_timer -> MConstr (Mnew_timer, (args 0, args 1)) | Mstart_timer -> MConstr (Mstart_timer, (args 0, args 1, args 2)) | Mstop_timer -> MConstr (Mstop_timer, (args 0, args 1)) | Mreset_timer -> MConstr (Mreset_timer, (args 0, args 1)) | Mprint_timer -> MConstr (Mprint_timer, (args 0, args 1)) | Mkind_of_term -> MConstr (Mkind_of_term, (args 0, args 1)) | Mreplace -> MConstr (Mreplace, (args 0, args 1, args 2, args 3, args 4, args 5)) | Mdeclare_mind -> MConstr (Mdeclare_mind, (args 0, args 1, args 2)) | Mexisting_instance -> MConstr (Mexisting_instance, (args 0, args 1, args 2)) | Minstantiate_evar -> MConstr (Minstantiate_evar, (args 0, args 1, args 2, args 3, args 4, args 5)) Mtac2-1.4-coq8.20/src/mConstr.mli000066400000000000000000000107071472011217100163340ustar00rootroot00000000000000type arg = CClosure.fconstr type arg_any = arg type arg_type = arg type arg_fun = arg type arg_string = arg type arg_N = arg type arg_bool = arg type arg_mlist = arg type arg_case = arg type arg_fix1_ty = arg_type type arg_fix1_val = arg_any type arg_fix2_ty = arg_type * arg_type type arg_fix2_val = arg_any * arg_any type arg_fix3_ty = arg_type * arg_type * arg_type type arg_fix3_val = arg_any * arg_any * arg_any type arg_fix4_ty = arg_type * arg_type * arg_type * arg_type type arg_fix4_val = arg_any * arg_any * arg_any * arg_any type arg_fix5_ty = arg_type * arg_type * arg_type * arg_type * arg_type type arg_fix5_val = arg_any * arg_any * arg_any * arg_any * arg_any type 'a mconstr_head = | Mret : (arg_type * arg_any) mconstr_head | Mbind : (arg_type * arg_type * arg_any * arg_fun) mconstr_head | Mmtry' : (arg_type * arg_any * arg_fun) mconstr_head | Mraise' : (arg_type * arg_any) mconstr_head | Mfix1 : (arg_fix1_ty * arg_type * arg_fun * arg_fix1_val) mconstr_head | Mfix2 : (arg_fix2_ty * arg_type * arg_fun * arg_fix2_val) mconstr_head | Mfix3 : (arg_fix3_ty * arg_type * arg_fun * arg_fix3_val) mconstr_head | Mfix4 : (arg_fix4_ty * arg_type * arg_fun * arg_fix4_val) mconstr_head | Mfix5 : (arg_fix5_ty * arg_type * arg_fun * arg_fix5_val) mconstr_head | Mis_var : (arg_type * arg_any) mconstr_head | Mnu : (arg_type * arg_type * arg_string * arg_any * arg_fun) mconstr_head | Mnu_let : (arg_type * arg_type * arg_type * arg_string * arg_any * arg_fun) mconstr_head | Mabs_fun : (arg_type * arg_fun * arg_any * arg_any) mconstr_head | Mabs_let : (arg_type * arg_fun * arg_any * arg_any * arg_any) mconstr_head | Mabs_prod_prop : (arg_type * arg_any * arg_type) mconstr_head | Mabs_prod_type : (arg_type * arg_any * arg_type) mconstr_head | Mabs_fix : (arg_type * arg_any * arg_any * arg_N) mconstr_head | Mget_binder_name : (arg_type * arg_any) mconstr_head | Mremove : (arg_type * arg_type * arg_any * arg_any) mconstr_head | Mgen_evar : (arg_type * arg_any) mconstr_head | Mis_evar : (arg_type * arg_any) mconstr_head | Mhash : (arg_type * arg_any * arg_N) mconstr_head | Msolve_typeclasses | Mprint : (arg_string) mconstr_head | Mpretty_print : (arg_type * arg_any) mconstr_head | Mhyps | Mdestcase : (arg_type * arg_any) mconstr_head | Mconstrs : (arg_type * arg_any) mconstr_head | Mmakecase : (arg_case) mconstr_head | Munify : (arg_type * arg_type * arg_any * arg_any * arg_any * arg_fun * arg_fun) mconstr_head | Munify_cumul : (arg_type * arg_type * arg_type * arg_any * arg_fun * arg_fun) mconstr_head | Mget_reference : (arg_string) mconstr_head | Mget_var : (arg_string) mconstr_head | Mcall_ltac : (arg_any * arg_any * arg_string * arg_mlist) mconstr_head | Mlist_ltac | Mread_line | Mdecompose : (arg_type * arg_any) mconstr_head | Msolve_typeclass : (arg_type) mconstr_head | Mdeclare : (arg_any * arg_string * arg_bool * arg_type * arg_any) mconstr_head | Mdeclare_implicits : (arg_type * arg_any * arg_mlist) mconstr_head | Mos_cmd : (arg_string) mconstr_head | Mget_debug_exceptions | Mset_debug_exceptions : (arg_bool) mconstr_head | Mget_trace | Mset_trace : (arg_bool) mconstr_head | Mdecompose_app' : (arg_type * arg_fun * arg_any * arg_any * arg_any * arg_any * arg_any * arg_any) mconstr_head | Mdecompose_forallT : (arg_fun * arg_type * arg_any * arg_any) mconstr_head | Mdecompose_forallP : (arg_fun * arg_type * arg_any * arg_any) mconstr_head | Mdecompose_app'' : (arg_fun * arg_fun * arg_any * arg_any) mconstr_head | Mnew_timer : (arg_type * arg_any) mconstr_head | Mstart_timer : (arg_type * arg_any * arg_bool) mconstr_head | Mstop_timer : (arg_type * arg_any) mconstr_head | Mreset_timer : (arg_type * arg_any) mconstr_head | Mprint_timer : (arg_type * arg_any) mconstr_head | Mkind_of_term : (arg_type * arg_any) mconstr_head | Mreplace : (arg_type * arg_type * arg_type * arg_any * arg_any * arg_any) mconstr_head | Mdeclare_mind : (arg_any * arg_any * arg_any) mconstr_head | Mexisting_instance : (arg_any * arg_any * arg_bool) mconstr_head | Minstantiate_evar : (arg_type * arg_type * arg_any * arg_any * arg_fun * arg_fun) mconstr_head and mhead = | MHead : 'a mconstr_head -> mhead and mconstr = | MConstr : 'a mconstr_head * 'a -> mconstr val num_args_of_mconstr : 'a mconstr_head -> int val mconstr_head_of : Names.Constant.t -> mhead val mconstr_head_opt : Names.Constant.t -> mhead option val mconstr_of : (int -> CClosure.fconstr) -> 'a mconstr_head -> mconstr Mtac2-1.4-coq8.20/src/metaCoqInit.mlg000066400000000000000000000145631472011217100171260ustar00rootroot00000000000000{ (** This module initializes the plugin (parser extension, callbacks, …). *) (** Since Coq 8.5, the following directive must appear to declare plugins. See: http://lists.gforge.inria.fr/pipermail/coq-commits/2014-July/012704.html Remark: We should add a "How-to write your plugin" section in Coq manual. *) } DECLARE PLUGIN "coq-mtac2.plugin" { (** Defines the parser of the proof mode for MetaCoq. For the moment, this parser is trivial: an MProof command is simply a toplevel Gallina term. We will stay with a trivial parser as long as Coq's notations are meeting our needs. *) (** Introduce a new parsing rule identifier "vernac:mproof_command". This rule is expected to produce a vernac expression. *) let mproof_mode : Vernacexpr.vernac_expr Pcoq.Entry.t = Pcoq.Entry.make "vernac:mproof_command" (** In Coq's parser, the semantic values are typed using the module {Genarg} facilities (defined in package "lib"). We must declare a new type of arguments for MProof instructions to type the semantic values produced by our new grammar rule. Hence, at the [Genarg] level, we introduce a new type constant named "mproof_instr" using the [Genarg.create_arg] function. The type of the result [Genarg.genarg_type] is constrained to encode the following static property: - at the raw level (just after parsing), these semantic values are [MetaCoqInstr.mproof_instr] ; - after parsing, they should not appear anymore. (This is encoded by the usage of [Util.Empty.t] type which encode a type with no inhabitant.) *) let wit_mproof_instr : (MetaCoqInstr.mproof_instr, Util.Empty.t, Util.Empty.t) Genarg.genarg_type = Genarg.create_arg "mproof_instr" (* FIXME: (Yann) I am not 100% sure that using all this machinery is really needed. FIXME: Indeed, for the moment [with_mproof_instr] is not used except in the following FIXME: instruction. FIXME: Besides, is that true that no Mproof instruction will escape the FIXME: parsing phase? *) (* FIXME: (Beta) I have no idea what I'm doing *) (** We introduce a new grammar rule for MProof instructions. The type of the semantic values (with_mproof_instr) is specified. *) let mproof_instr : MetaCoqInstr.mproof_instr Pcoq.Entry.t = Pcoq.create_generic_entry2 "mproof_instr" (Genarg.rawwit wit_mproof_instr) (** We now declare the grammar rule named [mproof_mode] as the entry point for proof instructions (installed by [MetaCoqMode] in [ProofGlobal]). A grammar rule is defined in three parts (i) the producers ; (ii) the effect descriptor needed by STM (iii) the semantic value. Here, there is only one producer: the non terminal [mproof_instr] whose parsing rules are defined at the end of this file. The minus sign at the beginning of the rule means that there is no specific keyword starting the words derived from this non terminal. As far as I understand STM machinery: - [VtProofStep false] means that the interpretation of the proof step cannot be parallelized. - [VtLater] means that the command does not alter the parser and can therefore by executed after the parsing of the rest of the source file. Finally, we do not produce any semantic value for the moment. *) } VERNAC { mproof_mode } EXTEND MProofInstr | ![proof] [ mproof_instr(_instr) ] => { Vernacextend.classify_as_proofstep } -> { fun ~pstate -> MetaCoqInterp.interp_proof_constr ~pstate _instr } END { open G_vernac } (** The parsing rule for the non terminal [mproof_instr]. *) GRAMMAR EXTEND Gram GLOBAL: mproof_instr mproof_mode; mproof_instr : [[ c=Pcoq.Constr.term ; "." -> { MetaCoqInstr.MetaCoq_constr c } ]]; mproof_mode: [[ p = subprf -> { Vernacexpr.VernacSynPure p } | g = OPT toplevel_selector; p = subprf_with_selector -> { Vernacexpr.VernacSynPure (p g) } ]] ; END { (** Initialize the proof mode MProof for MetaCoq. *) (** The following identifiers must be globally unique. They are used in several global tables to register some callbacks (for instance for the parser and the interpreter). *) let proof_mode_identifier = "MProof" (** Register the proof mode. See proof_global.mli for a documentation on the role of each of the following fields. In our case, we have to set the command entry to "mproof_mode" defined in the MetaCoqParser when we enter in proof mode. This dynamically change the parser for the proof script instructions. See MetaCoqParser to know the syntax of our proof instructions. We also reset to the noedit_mode when we quit the MetaCoq proof mode. *) let _ = Pvernac.register_proof_mode proof_mode_identifier mproof_mode (** The following command extends both the parser and the interpreter of the Vernacular language so that a new keyword "MProof" is recognized and is interpreted as the entry point for a proof written in MetaCoq. In the following command: - On the first line, "MProofCommand" is a new constructor in the abstract syntax tree of VernacExpr. It will appear as an [extend_name] after the [VernacExtend]. Notice that [extend_name] is a pair of a string (which is "MProofCommand" here) and an integer which represents the index of the interpretation rule (here 0). - On the second line, [ "MProof" ] is the right hand side of the unique grammar rule for the non terminal MProofCommand. - On the third line, there are two classifiers that influence the interpretation of this command. "VtProofMode" classifies the command as a proof mode introducer. The "proof_mode_identifier" is used as a key in Vernac_classifier.classifiers. "VtNow" indicates that the interpretation of this command cannot be done in the background asynchronously. Indeed, changing the proof mode has an effect on the parsing and the interpretation of the subsequent commands. - On the fourth line, the interpretation function is given. This interpretation function is registered in Vernacinterp and called in Vernacentries.interp. *) } VERNAC COMMAND EXTEND MProofCommand | [ "MProof" ] => { (match Pvernac.lookup_proof_mode proof_mode_identifier with | None -> CErrors.user_err Pp.(str (Format.sprintf "No proof mode named \"%s\"." proof_mode_identifier)) | Some proof_mode -> Vernacextend.VtProofMode proof_mode) } -> { MetaCoqInterp.interp_mproof_command () } END Mtac2-1.4-coq8.20/src/metaCoqInstr.mli000066400000000000000000000003151472011217100173120ustar00rootroot00000000000000(** This module defines the abstract syntax tree for MetaCoq instructions. *) (** MetaCoq uses the syntax of Coq to represent programs. *) type mproof_instr = | MetaCoq_constr of Constrexpr.constr_expr Mtac2-1.4-coq8.20/src/metaCoqInterp.ml000066400000000000000000000237231472011217100173130ustar00rootroot00000000000000open Constrs open Ltac_pretype type mrun_arg_type = | PolyProgram of (UVars.AbstractContext.t * EConstr.types) | MonoProgram of (EConstr.types) | GTactic type mrun_arg = | StaticallyChecked of (mrun_arg_type * Names.GlobRef.t) | DynamicallyChecked of (Ltac_pretype.closed_glob_constr) let ifTactic env sigma ty c = let (sigma, gtactic) = MCTactics.mkGTactic env sigma in let unitType = CoqUnit.mkType in let gtactic = EConstr.mkApp(gtactic, [|Lazy.force unitType|]) in let open Evarsolve in let res = Unicoq.Munify.unify_evar_conv TransparentState.full env sigma Conversion.CONV gtactic ty in match res with | Success sigma -> (true, sigma) | _ -> (false, sigma) let glob_mtac_type ist r = let open Declarations in try let c = match (Smartlocate.locate_global_with_alias r) (* Maybe put loc back in for error reporting *) with | Names.GlobRef.ConstRef c -> c | _ -> CErrors.user_err (Pp.str "mrun_static only accepts constants. It does *not* accept variables, inductives, or constructors. ") in (* Typecheck here. Unification? probably *) let env = Global.env () in let sigma = Evd.from_env env in let body = Global.lookup_constant c in let ty = body.const_type in let sigma, ty, ret = match body.const_universes with | Declarations.Monomorphic -> sigma, ty, (fun ty -> MonoProgram ty) (* constraints already registered *) | Declarations.Polymorphic au -> (* need to instantiate and register the abstract universes a *) let inst, ctx = UnivGen.fresh_instance_from au None in (* TODO: find out why UnivFlexible needs a bool & select correct bool. *) let sigma = Evd.merge_sort_context_set ?sideff:(Some false) (Evd.UnivFlexible true) sigma ctx in sigma, Vars.subst_instance_constr inst ty, (fun ty -> PolyProgram (au, ty)) in let ty = EConstr.of_constr ty in let (h, args) = Reductionops.whd_all_stack env sigma ty in let sigma, metaCoqType = MtacNames.mkT_lazy sigma env in if EConstr.eq_constr_nounivs sigma metaCoqType h && List.length args = 1 then (ret (List.hd args), (Names.GlobRef.ConstRef c)) else let b, sigma = ifTactic env sigma ty (body.const_body) in if b then (GTactic, Names.GlobRef.ConstRef c) else CErrors.user_err (Pp.str "Not a Mtactic") with Not_found as exn -> let _, info = Exninfo.capture exn in Nametab.error_global_not_found ~info r module MetaCoqRun = struct (** This module run the interpretation of a constr *) let uncaught ?loc env sigma e tr = let open Pp in let err = str "Uncaught Mtac exception:\n" ++ str " " ++ hov 2 (Printer.pr_econstr_env env sigma e) ++ str "\n" ++ str "Mtac backtrace (last function first):\n" ++ Run.pr_backtrace tr ++ str "End of backtrace\n" ++ str "(Backtraces are only recorded with [Set_Debug_Exceptions].)\n" in CErrors.user_err ?loc err let ifM env sigma concl ty c = let sigma, metaCoqType = MtacNames.mkT_lazy sigma env in let (h, args) = Reductionops.whd_all_stack env sigma ty in if EConstr.eq_constr_nounivs sigma metaCoqType h && List.length args = 1 then try let sigma = Evarconv.unify_leq_delay env sigma (List.hd args) concl in (true, sigma) with Evarconv.UnableToUnify(_,_) -> CErrors.user_err (Pp.str "Different types") else (false, sigma) (** Given a type concl and a term c, it checks that c has type: - [M concl]: then it returns [c] - [tactic]: then it returns [c (Goal concl evar)] *) let pretypeT env sigma concl evar c = (* let sigma, ty = Typing.type_of ~refresh:true env sigma c in *) let ty = Retyping.get_type_of env sigma c in let b, sigma = ifM env sigma concl ty c in if b then (false, sigma, ty, c) else let b, sigma = ifTactic env sigma ty c in if b then (true, sigma, ty, c) else CErrors.user_err (Pp.str "Not a Mtactic") let run ?loc env sigma concl evar istactic (oty) t = (* [run] is also the entry point for code that doesn't go through [pretypeT] so we have to do the application to the current goal for tactics in here instead of [pretypeT]. *) let sigma, t = if istactic then let sigma, goal = Run.Goal.mkTheGoal concl evar sigma env in let t = EConstr.mkApp(t, [|goal|]) in let sigma, _ = Typing.type_of env sigma t in (sigma, t) else sigma, t in let sigma, ty = match oty with | Some ty -> sigma, ty | None -> Typing.type_of env sigma t in match Run.run (env, sigma) ty t with | Run.Val (sigma, v) -> let open Proofview in let open Proofview.Notations in Unsafe.tclEVARSADVANCE sigma >>= fun _-> if not istactic then Refine.refine ~typecheck:false begin fun evd -> evd, v end else begin try let goals = CoqList.from_coq sigma env v in let goals = List.map (fun x -> snd (CoqPair.from_coq (env, sigma) x)) goals in let goals = List.map (Run.Goal.evar_of_goal sigma env) goals in let goals = List.filter Option.has_some goals in let goals = List.map (fun e->Proofview_monad.with_empty_state (Option.get e)) goals in Unsafe.tclSETGOALS goals with CoqList.NotAList e -> let open Pp in CErrors.user_err (str "The list of goals is not normalized: " ++ (Printer.pr_econstr_env env sigma e)) end | Run.Err ((sigma, e), tr) -> uncaught ?loc env sigma e tr let evar_of_goal gl = let evk = Proofview.Goal.goal gl in let EvarInfo info = Evd.find (Proofview.Goal.sigma gl) evk in let ids = Evd.evar_identity_subst info in EConstr.Unsafe.to_constr @@ EConstr.mkEvar (evk, ids) (** Get back the context given a goal, interp the constr_expr to obtain a constr Then run the interpretation fo the constr, and returns the tactic value, according to the value of the data returned by [run]. *) let run_tac t = let open Proofview.Goal in enter begin fun gl -> let loc = Constrexpr_ops.constr_loc t in let env = env gl in let concl = concl gl in let sigma = sigma gl in let evar = EConstr.of_constr (evar_of_goal gl) in let (sigma, t) = Constrintern.interp_open_constr env sigma t in let (istactic, sigma, ty, t) = pretypeT env sigma concl evar t in (* We could be smarter here with the optional type argument to [run] but I cannot get it to work. *) run ?loc env sigma concl evar istactic (None) t end let understand env sigma {closure=closure;term=term} = let open Glob_ops in let open Pretyping in let flags = all_no_fail_flags in let lvar = { empty_lvar with ltac_constrs = closure.typed; ltac_uconstrs = closure.untyped; ltac_idents = closure.idents; } in understand_ltac flags env sigma lvar WithoutTypeConstraint term let run_tac_constr t = let open Proofview.Goal in enter begin fun gl -> let env = env gl in let concl = concl gl in let sigma = sigma gl in let evar = EConstr.of_constr (evar_of_goal gl) in let ((istactic, sigma, ty, t), loc) = match t with | StaticallyChecked (MonoProgram ty, Names.GlobRef.ConstRef c) -> begin try let sigma = Evarconv.unify_leq_delay env sigma concl ty in ((false, sigma, ty, EConstr.mkConst c), None) with Evarconv.UnableToUnify(_,_) -> CErrors.user_err (Pp.str "Different types") end | StaticallyChecked (PolyProgram (au, ty), Names.GlobRef.ConstRef c) -> begin try let inst, ctx = UnivGen.fresh_instance_from au None in (* TODO: find out why UnivFlexible needs a bool & select correct bool. *) let sigma = Evd.merge_sort_context_set ?sideff:(Some false) (Evd.UnivFlexible true) sigma ctx in let sigma = Evarconv.unify_leq_delay env sigma concl ty in ((false, sigma, ty, EConstr.mkConst c), None) with Evarconv.UnableToUnify(_,_) -> CErrors.user_err (Pp.str "Different types") end | StaticallyChecked (GTactic, gr) -> let sigma, t = EConstr.fresh_global env sigma gr in let ty = Retyping.get_type_of env sigma t in ((true, sigma, ty, t), None) | DynamicallyChecked t -> let {term=term} = t in let loc = Glob_ops.loc_of_glob_constr term in let sigma, t = understand env sigma t in pretypeT env sigma concl evar t, loc | _ -> assert false in run ?loc env sigma concl evar istactic None t end let run_mtac_do env sigma t = let loc = Constrexpr_ops.constr_loc t in let sigma, t = Constrintern.interp_open_constr env sigma t in let sigma, ty = Typing.type_of env sigma t in let sigma, (concl, sort) = Evarutil.new_type_evar env sigma Evd.univ_flexible in let isM, sigma = ifM env sigma concl ty t in if isM then match Run.run (env, sigma) ty t with | Run.Val _ -> () | Run.Err ((_, e), tr) -> uncaught ?loc env sigma e tr else CErrors.user_err (Pp.str "Mtac Do expects a term of type [M _].") end (** This module manages the interpretation of the MetaCoq tactics and the vernac MProof command. *) (** Interpreter of the MProof vernac command : - Get back and focus on the current proof - Set the proof mode to "MProof" mode. - Print subgoals *) let interp_mproof_command () = () (** Interpreter of a mtactic *) let interp_instr = function | MetaCoqInstr.MetaCoq_constr c -> MetaCoqRun.run_tac c let exec ~pstate f = fst @@ Declare.Proof.by (f ()) pstate (** Interpreter of a constr : - Interpretes the constr - Unfocus on the current proof *) let interp_proof_constr ~pstate instr = exec ~pstate (fun () -> interp_instr instr) Mtac2-1.4-coq8.20/src/metaCoqInterp.mli000066400000000000000000000014201472011217100174520ustar00rootroot00000000000000(* open Ltac_pretype module MetaCoqRun : sig val run_tac_constr : closed_glob_constr -> unit Proofview.tactic *) type mrun_arg_type = | PolyProgram of (UVars.AbstractContext.t * EConstr.types) | MonoProgram of (EConstr.types) | GTactic type mrun_arg = | StaticallyChecked of (mrun_arg_type * Names.GlobRef.t) | DynamicallyChecked of (Ltac_pretype.closed_glob_constr) module MetaCoqRun : sig val run_tac_constr : mrun_arg -> unit Proofview.tactic val run_mtac_do : Environ.env -> Evd.evar_map -> Constrexpr.constr_expr -> unit end val glob_mtac_type : 'a -> Libnames.qualid -> mrun_arg_type * Names.GlobRef.t val interp_proof_constr : pstate:Declare.Proof.t -> MetaCoqInstr.mproof_instr -> Declare.Proof.t val interp_mproof_command : unit -> unit Mtac2-1.4-coq8.20/src/metaCoqTactic.mlg000066400000000000000000000023061472011217100174220ustar00rootroot00000000000000{ open Ltac_plugin open MetaCoqInterp open Stdarg open Pcoq.Constr open Extraargs } DECLARE PLUGIN "coq-mtac2.plugin" { let print_mtac_type _ _ _ _ = Pp.mt () (* (reference, global_reference located or_var, global_reference) *) let interp_mtac_type ist _ _ r = r let subst_mtac_type subst r = let ty, r = r in (ty, fst (Globnames.subst_global subst r)) } ARGUMENT EXTEND mtac_type PRINTED BY { print_mtac_type } INTERPRETED BY { interp_mtac_type } GLOBALIZED BY { glob_mtac_type } SUBSTITUTED BY { subst_mtac_type } | [ global(l) ] -> { l } END TACTIC EXTEND mrun | [ "mrun_static" mtac_type(c) ] -> { MetaCoqRun.run_tac_constr (StaticallyChecked c) } | [ "mrun" uconstr(c) ] -> { MetaCoqRun.run_tac_constr (DynamicallyChecked c) } END (* NB this accesses proof state through proof_opt_query, but it can have non-proof side effects so it's not classifiable as query AFAICT*) VERNAC COMMAND EXTEND MtacDo CLASSIFIED AS SIDEFF | ![proof_opt_query] [ "Mtac" "Do" lconstr(c) ] -> { fun ~pstate -> let sigma, env = Option.cata Declare.Proof.get_current_context (let e = Global.env () in Evd.from_env e, e) pstate in MetaCoqRun.run_mtac_do env sigma c } END Mtac2-1.4-coq8.20/src/mtacNames.ml000066400000000000000000000033751472011217100164510ustar00rootroot00000000000000open Constr open EConstr open Termops open Constrs let metaCoq_module_name = "Mtac2.intf" let mkConstr e = Constrs.mkConstr (metaCoq_module_name ^ "." ^ e) let mkUGlobal e = Constrs.mkUGlobal (metaCoq_module_name ^ "." ^ e) let mkUConstr e = Constrs.mkUConstr (metaCoq_module_name ^ "." ^ e) let mkBuilder e = ConstrBuilder.from_string (metaCoq_module_name ^ "." ^ e) let mkUBuilder e = UConstrBuilder.from_string (metaCoq_module_name ^ "." ^ e) let mkT_lazy = mkUConstr "M.M.t" let mkUConstr e = Constrs.mkUConstr (metaCoq_module_name ^ "." ^ e) let isConstr sigma env e = let c = Lazy.force (mkConstr e) in eq_constr env sigma c let isUConstr sigma env e = let sigma, c = mkUConstr e sigma env in eq_constr_nounivs sigma c let constant_of_string e = let full_name = metaCoq_module_name ^ "." ^ e in let p = Libnames.path_of_string full_name in (* let q = Libnames.qualid_of_path p in *) match Nametab.global_of_path p with | Names.GlobRef.ConstRef (c) -> c | _ -> raise Not_found let isConstant sigma env const c = match EConstr.kind sigma c with | Const (n, _) -> Environ.QConstant.equal env n const | _ -> false let isFConstant env const fc = match CClosure.fterm_of fc with | CClosure.FFlex (Names.ConstKey (n, _)) -> Environ.QConstant.equal env n const | _ -> false let mkCase ind v ret branch sigma env = let sigma, c = mkUConstr "Case.mkCase" sigma env in sigma, mkApp(c, [|ind;v;ret;branch|]) let mkelem d sigma env = let sigma, c = mkUConstr "Dyn.elem" sigma env in sigma, mkApp(c, [|d|]) let mkdyn = mkUConstr "Dyn.dyn" let mkDyn ty el sigma env = let sigma, c = mkUConstr "Dyn.Dyn" sigma env in sigma, mkApp(c, [|ty;el|]) (* dyn is expected to be Dyn ty el *) let get_elem sigma dyn = (snd (destApp sigma dyn)).(1) Mtac2-1.4-coq8.20/src/mtacNames.mli000066400000000000000000000022261472011217100166140ustar00rootroot00000000000000val metaCoq_module_name : string val mkConstr : string -> EConstr.constr Lazy.t val mkUGlobal: string -> Names.GlobRef.t val mkUConstr: string -> Evd.evar_map -> Environ.env -> Evd.evar_map * EConstr.constr val mkBuilder: string -> Constrs.ConstrBuilder.t val mkUBuilder: string -> Constrs.UConstrBuilder.t val mkT_lazy : Evd.evar_map -> Environ.env -> Evd.evar_map * EConstr.constr val isConstr : Evd.evar_map -> Environ.env -> string -> EConstr.constr -> bool val isUConstr: Evd.evar_map -> Environ.env -> string -> EConstr.t -> bool val constant_of_string: string -> Names.Constant.t val isConstant : Evd.evar_map -> Environ.env -> Names.Constant.t -> EConstr.t -> bool val isFConstant : Environ.env -> Names.Constant.t -> CClosure.fconstr -> bool val mkCase: EConstr.t -> EConstr.t -> EConstr.t -> EConstr.t -> Evd.evar_map -> Environ.env -> Evd.evar_map * EConstr.t val mkelem: EConstr.t -> Evd.evar_map -> Environ.env -> Evd.evar_map * EConstr.t val mkdyn: Evd.evar_map -> Environ.env -> Evd.evar_map * EConstr.constr val mkDyn: EConstr.t -> EConstr.t -> Evd.evar_map -> Environ.env -> Evd.evar_map * EConstr.t val get_elem: Evd.evar_map -> EConstr.t -> EConstr.t Mtac2-1.4-coq8.20/src/run.ml000066400000000000000000003064171472011217100153500ustar00rootroot00000000000000(** This module defines the interpretation of MetaCoq constr *) open Ltac_plugin open Declarations open List open Pp open Environ open Evd open Context open Constr open EConstr open Termops open Reductionops open Names open Util open Evarconv open Constrs open CClosure let get_ts env = Conv_oracle.get_transp_state (Environ.oracle env) let ts_var_full = let open TransparentState in { tr_var = Id.Pred.full; tr_cst = Cpred.empty; tr_prj = PRpred.empty } let ts_cst_full = let open TransparentState in { tr_var = Id.Pred.empty; tr_cst = Cpred.full; tr_prj = PRpred.full } (** returns the i-th position of constructor c (starting from 0) *) let get_constructor_pos sigma c = let (_, pos), _ = destConstruct sigma c in pos-1 (** print informative exceptions *) let debug_ex = ref false (** traces execution *) let trace = ref false (** Some utilities for printing *) let print (sigma: Evd.evar_map) env s = Feedback.msg_notice (app (str "[DEBUG] ") (str (CoqString.from_coq (env, sigma) s))) let print_constr (sigma: Evd.evar_map) env t = Feedback.msg_notice (app (str "[DEBUG] ") (Printer.pr_econstr_env env sigma t)) let constr_to_string (sigma: Evd.evar_map) env t = Pp.string_of_ppcmds (Printer.pr_econstr_env env sigma t) (** Functions to convert between fconstr and econstr *) let of_econstr e = CClosure.inject (EConstr.Unsafe.to_constr e) let to_econstr f = EConstr.of_constr (CClosure.term_of_fconstr f) open MtacNames module RedList = GenericList (struct let nilname = metaCoq_module_name ^ ".Reduction.rlnil" let consname = metaCoq_module_name ^ ".Reduction.rlcons" let typename = metaCoq_module_name ^ ".Reduction.rllist" end) module Goal = struct let mkgs_base = mkUConstr "Goals.gs_open" let mkgs_any = mkUConstr "Goals.gs_any" let mkgoal ?base:(base=true) sigma env = let sigma, gs = if base then mkgs_base sigma env else mkgs_any sigma env in let sigma, t = mkUConstr "Goals.goal" sigma env in (sigma, mkApp (t, [|gs|])) let mkMetavar' gs sigma env = let sigma, gsopen = gs sigma env in let sigma, mvar = mkUConstr "Goals.Metavar'" sigma env in (sigma, mkApp (mvar, [|gsopen|])) let mkMetavar = mkMetavar' mkgs_base let mkAnyMetavar = mkMetavar' mkgs_any let mkAHyp = mkUConstr "Goals.AHyp" let mkHypLet = mkUConstr "Goals.HypLet" let mkHypRemove = mkUConstr "Goals.HypRem" let mkHypReplace = mkUConstr "Goals.HypReplace" let mkTheGoal ?base:(base=true) ty ev sigma env = let tt = Retyping.get_type_of env sigma ty in let tt = Reductionops.nf_all env sigma tt in if isSort sigma tt then let sort = ESorts.kind sigma (destSort sigma tt) in let sigma, ssort = if Sorts.is_prop sort then CoqSort.mkSProp env sigma else CoqSort.mkSType env sigma in let sigma, tg = (if base then mkMetavar else mkAnyMetavar) sigma env in sigma, mkApp (tg, [|ssort; ty;ev|]) else failwith ("WAT? Not a sort?" ^ (constr_to_string sigma env tt)) let mkAHypOrDef (name, odef, ty) body sigma env = (* we are going to wrap the body in a function, so we need to lift the indices. we also replace the name with index 1 *) let body = replace_term sigma (mkVar name.binder_name) (mkRel 1) (Vars.lift 1 body) in let name = map_annot Names.Name.mk_name name in match odef with | None -> let sigma, ahyp = mkAHyp sigma env in sigma, mkApp (ahyp, [|ty; mkLambda(name,ty,body)|]) | Some def -> let sigma, hyplet = mkHypLet sigma env in sigma, mkApp (hyplet, [|ty; mkLetIn(name,def,ty,body)|]) let make_replace env (sigma: evar_map) oldtype newtype id goal = let var = mkVar id in let sigma, sort = Evarutil.new_Type sigma in let sigma, eq = CoqEq.mkEqRefl sigma env sort oldtype in let sigma, rep = mkHypReplace sigma env in sigma, mkApp (rep, [|oldtype;newtype;var;eq;goal |]) let make_remove env sigma ty id goal = let var = mkVar id in let sigma, rem = mkHypRemove sigma env in sigma, mkApp (rem, [|ty;var;goal |]) (* it assumes goal is of type goal *) let evar_of_goal sigma env = let rec eog goal = let goal = Reductionops.whd_allnolet env sigma goal in let (c, args) = decompose_appvect sigma goal in if isConstruct sigma c then match get_constructor_pos sigma c with | 0 -> (* Metavar' *) let evar = whd_evar sigma args.(3) in if isEvar sigma evar then Some (fst (destEvar sigma evar)) else (* it is defined *) None | 1 -> (* AHyp *) let func = args.(1) in if isLambda sigma func then let (_, _, body) = destLambda sigma func in eog body else None | 2 -> (* HypLet *) let goal = args.(1) in if isLetIn sigma goal then let (_, _, _, body) = destLetIn sigma goal in eog body else None | 3 -> (* RemHyp *) eog args.(2) | 4 -> (* HypReplace *) eog args.(4) | _ -> failwith "Should not happen" else CErrors.user_err Pp.(app (str "Not a goal: ") (Printer.pr_econstr_env env sigma goal)) in eog let goal_of_evar ?base:(base=true) (env:env) sigma ev = let open Context.Named in let open Declaration in let evinfo = Evd.find_undefined sigma ev in let evenv = named_context_of_val (Evd.evar_filtered_hyps evinfo) in let env_list = named_context env in let rec compute sigma accu = function | nd :: evenv -> begin try let id = get_id nd in let nd' = lookup id env_list in let ty = get_type nd in let ty' = get_type nd' in if eq_constr env sigma ty ty' then compute sigma accu evenv (* same name and type, continue with the next *) else begin if Option.has_some (Reductionops.infer_conv env sigma ty ty') then (* not same, but convertible *) let sigma, accu = make_replace env sigma ty' ty id accu in compute sigma accu evenv else (* not same *) let sigma, accu = mkAHypOrDef (to_tuple nd) accu sigma env in let sigma, accu = make_remove env sigma ty' id accu in compute sigma accu evenv end with Not_found -> let sigma, accu = mkAHypOrDef (to_tuple nd) accu sigma env in compute sigma accu evenv end | [] -> (sigma, accu) in let ids = Evd.evar_identity_subst evinfo in let evar = (ev, ids) in let sigma, tg = mkTheGoal ~base:base (Evd.existential_type sigma evar) (EConstr.mkEvar evar) sigma env in compute sigma tg evenv (* we're missing the removal of the variables not ocurring in evenv *) end module Exceptions = struct let debug_exception sigma env e t = if !debug_ex then print_constr sigma env (mkApp (e, [|t|])) let mkCannotRemoveVar sigma env x = let varname = CoqString.to_coq (constr_to_string sigma env x) in let sigma, exc = mkUConstr "Exceptions.CannotRemoveVar" sigma env in debug_exception sigma env exc x; sigma, mkApp(exc, [|varname|]) let mkRefNotFound sigma env s = let msg = CoqString.to_coq s in let sigma, exc = (mkUConstr "Exceptions.RefNotFound" sigma env) in debug_exception sigma env exc msg; sigma, mkApp (exc, [|msg|]) let mkDebugEx s sigma env t = let sigma, exc = mkUConstr ("Exceptions." ^ s) sigma env in debug_exception sigma env exc t; sigma, exc let mkWrongTerm = mkDebugEx "WrongTerm" let mkHypMissesDependency = mkDebugEx "HypMissesDependency" let mkTypeMissesDependency = mkDebugEx "TypeMissesDependency" let mkDuplicatedVariable = mkDebugEx "DuplicatedVariable" let mkNotAVar = mkDebugEx "NotAVar" let _mkNotAForall = mkDebugEx "NotAForall" let mkNotAnApplication = mkDebugEx "NotAnApplication" let mkAbsDependencyError = mkDebugEx "AbsDependencyError" let mkAbsVariableIsADefinition = mkDebugEx "AbsVariableIsADefinition" let mkAbsLetNotConvertible = mkDebugEx "AbsLetNotConvertible" let mkNotALetIn = mkDebugEx "NotALetIn" let mkNotTheSameType = mkDebugEx "NotTheSameType" let mkExceptionNotGround = mkDebugEx "ExceptionNotGround" let mkStuckTerm = mkDebugEx "StuckTerm" let mkNotAList = mkDebugEx "NotAList" let mkHypsUniverseError = mkDebugEx "HypsUniverseError" let mkReductionFailure = mkDebugEx "ReductionFailure" let mkNotAUnifStrategy = mkDebugEx "NotAUnifStrategy" let mkNotAMatchExp = mkDebugEx "NotAMatchExp" let mkNotAnInductive = mkDebugEx "NotAnInductive" let mkVarAppearsInValue = mkDebugEx "VarAppearsInValue" let mkNotAnEvar sigma env ty t = let sigma, exc = mkUConstr "Exceptions.NotAnEvar" sigma env in let e = mkApp (exc, [|ty; t|]) in debug_exception sigma env exc t; sigma, e let mkNotAReference sigma env ty t = let sigma, exc = (mkUConstr "Exceptions.NotAReference" sigma env) in let e = mkApp (exc, [|ty; t|]) in debug_exception sigma env exc t; sigma, e let mkAlreadyDeclared sigma env name = let sigma, exc = (mkUConstr "Exceptions.AlreadyDeclared" sigma env) in let e = mkApp (exc, [|name|]) in debug_exception sigma env exc name; sigma, e let mkTypeErrorUnboundVar = mkDebugEx "UnboundVar" let mkLtacError sigma env msg = let sigma, exc = mkUConstr "Exceptions.LtacError" sigma env in let coqmsg = CoqString.to_coq msg in let e = mkApp(exc, [|coqmsg|]) in debug_exception sigma env exc coqmsg; sigma, e let mkNameExists sigma env s = let sigma, exc = (mkUConstr "Exceptions.NameExistsInContext" sigma env) in let e = mkApp (exc, [|s|]) in debug_exception sigma env exc s; sigma, e let mkInvalidName sigma env s = let sigma, exc = (mkUConstr "Exceptions.InvalidName" sigma env) in let e = mkApp (exc, [|s|]) in debug_exception sigma env exc s; sigma, e let block msg = CErrors.user_err Pp.(str msg) end module E = Exceptions module ReductionStrategy = struct open Reductionops open RedFlags open Context let reduce_constant = lazy (constant_of_string "Reduction.reduce") let isReduce sigma env c = isConstant sigma env (Lazy.force reduce_constant) c let isTReduce sigma env c = isReduce sigma env (EConstr.of_constr c) let isFReduce sigma env c = isFConstant env (Lazy.force reduce_constant) c let has_definition ts env sigma t = if isVar sigma t then let var = destVar sigma t in if not (TransparentState.is_transparent_variable ts var) then false else let n = Environ.lookup_named var env in Option.has_some (Named.Declaration.get_value n) else if isRel sigma t then let n = destRel sigma t in let n = Environ.lookup_rel n env in Option.has_some (Rel.Declaration.get_value n) else if isConst sigma t then let (c, _) = destConst sigma t in TransparentState.is_transparent_constant ts c && Environ.evaluable_constant c env else false let get_definition env sigma t : EConstr.t = if isVar sigma t then let var = destVar sigma t in let n = EConstr.lookup_named var env in match Named.Declaration.get_value n with | Some c -> c | _ -> CErrors.anomaly (Pp.str "get_definition for var didn't have definition!") else if isRel sigma t then let n = destRel sigma t in let d = Environ.lookup_rel n env in match Rel.Declaration.get_value d with | Some v -> (Vars.lift n) (of_constr v) | _ -> CErrors.anomaly (Pp.str "get_definition for rel didn't have definition!") else if isConst sigma t then let (c,ui) = destConst sigma t in let ui = EInstance.kind sigma ui in let d = Environ.constant_value_in env (c,ui) in of_constr d else CErrors.anomaly (Pp.str "get_definition didn't have definition!") let try_unfolding ts env sigma t = if has_definition ts env sigma t then get_definition env sigma t else t let one_step flags env sigma c = let ts = get_ts env in let h, args = decompose_app_list sigma c in let h = whd_evar sigma h in let r = match kind sigma h with | Lambda (_, _, trm) when args <> [] && red_set flags fBETA-> (Vars.subst1 (List.hd args) trm, List.tl args) | LetIn (_, trm, _, body) when red_set flags fZETA -> (Vars.subst1 trm body, args) | Var id when red_set flags (fVAR id) -> (try_unfolding ts env sigma h, args) | Rel _ when red_set flags fDELTA -> (try_unfolding ts env sigma h, args) | Const (c, u) when red_set flags (fCONST c) -> (try_unfolding ts env sigma h, args) | _ -> h, args in applist r let redflags = [|fBETA;fDELTA;fMATCH;fFIX;fZETA|] let posDeltaC = Array.length redflags let posDeltaX = posDeltaC + 1 let posDeltaOnly = posDeltaX + 1 (* let posDeltaBut = posDeltaOnly + 1 *) let get_flags (env, sigma) flags = (* we assume flags have the right type and are in nf *) let flags = RedList.from_coq sigma env flags in List.fold_right (fun f reds-> if isConstruct sigma f then let ci = get_constructor_pos sigma f in if ci = 1 (* special handling: RedDelta := fDELTA + full transparency *) then red_add_transparent (red_add reds fDELTA) TransparentState.full else if ci < Array.length redflags then red_add reds redflags.(ci) else if ci = posDeltaC then red_add_transparent (red_add reds fDELTA) ts_cst_full else if ci = posDeltaX then red_add_transparent (red_add reds fDELTA) ts_var_full else failwith "Unknown flag" else if isApp sigma f then let c, args = destApp sigma f in if isConstruct sigma c && Array.length args = 1 then let reds, func = if get_constructor_pos sigma c = posDeltaOnly then red_add_transparent (red_add reds fDELTA) TransparentState.empty, red_add else (* must be posDeltaBut *) red_add_transparent (red_add reds fDELTA) (Conv_oracle.get_transp_state (Environ.oracle env)), red_sub in let (sigma, ids) = RedList.from_coq_conv sigma env (fun sigma x -> sigma, get_elem sigma x) args.(0) in List.fold_right (fun e reds-> if isVar sigma e then func reds (fVAR (destVar sigma e)) else if isConst sigma e then func reds (fCONST (fst (destConst sigma e))) else failwith ("Unknown reference: " ^ constr_to_string sigma env e)) ids reds else failwith "Unknown flag" else failwith "Unknown flag" ) flags no_red let whdfun flags env sigma c = (* let open Machine in * let state = (c, Stack.empty) in * let (s, _) = whd_state_gen flags env sigma state in * Stack.zip sigma s *) let infos = Evarutil.create_clos_infos env sigma flags in let tabs = CClosure.create_tab () in (CClosure.whd_val infos tabs c) let redfuns = [| (fun _ _ sigma c -> sigma, c); (fun _ env sigma c -> sigma, Tacred.simpl env sigma (nf_evar sigma c)); (fun fs env sigma c -> sigma, one_step (get_flags (env, sigma) fs.(0)) env sigma c); (fun fs env sigma c -> sigma, EConstr.of_constr (whdfun (get_flags (env, sigma) fs.(0)) env sigma (of_econstr c))); (fun fs env sigma c-> sigma, clos_norm_flags (get_flags (env, sigma) fs.(0)) env sigma c); (fun _ env sigma c -> sigma, Redexpr.cbv_vm env sigma c); (* vm_compute *) (fun fs env sigma c -> let red, _ = Redexpr.reduction_of_red_expr env (Genredexpr.ExtraRedExpr (CoqString.from_coq (env,sigma) fs.(0))) in red env sigma c) |] type reduction_result = ReductionValue of evar_map * constr | ReductionStuck | ReductionFailure let reduce sigma env strategy c = try (* note that [args] can be an empty array, or an array with one element: the flags *) let strategy, args = decompose_appvect sigma strategy in let sigma, c = redfuns.(get_constructor_pos sigma strategy) args env sigma c in ReductionValue (sigma, c) with RedList.NotAList _ -> ReductionStuck | _ -> ReductionFailure (* let whd_betadeltaiota_nolet = whdfun RedFlags.allnolet *) let whd_all_novars = let flags = red_add_transparent betaiota ts_cst_full in whdfun flags let whd_betadeltaiota = whdfun RedFlags.all end module RE = ReductionStrategy module UnificationStrategy = struct open Evarsolve let evar_conv ts env sigma conv_pb t1 t2 = try match evar_conv_x (default_flags_of ts) env sigma conv_pb t1 t2 with | Success sigma -> Success (solve_unif_constraints_with_heuristics env sigma) | e -> e with _ -> UnifFailure (sigma, Pretype_errors.ProblemBeyondCapabilities) let funs = [| (fun _-> Unicoq.Munify.unify_evar_conv); Unicoq.Munify.unify_match; Unicoq.Munify.unify_match_nored; (fun _ -> evar_conv) |] let unicoq_pos = 0 let evarconv_pos = Array.length funs -1 (** unify oevars sigma env strategy conv_pb t1 t2 unifies t1 and t2 according to universe restrictions conv_pb (CUMUL or CONV) and strategy (UniCoq,UniMatch,UniMatchNoRed,UniEvarconv). In the UniMatch and UniMatchNoRed cases, it only instantiates evars in the evars set, assuming oevars = Some evars. If oevars = None, then the whole set of evars is assumed. The idea is to avoid pattern matching to instantiate external evars. It returns Success or UnifFailure and a bool stating if the strategy used was one of the Match. *) exception NotAUnifStrategy of EConstr.t let unify oevars sigma env strategy conv_pb t1 t2 = let pos = try let pos = get_constructor_pos sigma strategy in pos with Constr.DestKO -> raise (NotAUnifStrategy strategy) in let ts = get_ts env in let evars = match oevars with | Some e -> e | _ -> Evar.Map.domain (Evd.undefined_map sigma) in (funs.(pos) evars ts env sigma conv_pb t1 t2, pos > unicoq_pos && pos < evarconv_pos) end (** Everything about name generation *) module MNames = struct (* let mkTheName = Constr.mkConstr "Mtac2.M.TheName" *) (* let mkFreshFrom = Constr.mkConstr "Mtac2.M.FreshFrom" *) (* let mkGenerate = Constr.mkConstr "Mtac2.M.Generate" *) let get_name_base (env, sigma) (t: constr) = (* If t is a defined variable it is reducing it *) let t = EConstr.of_constr (RE.whd_all_novars env sigma (of_econstr t)) in if isVar sigma t then Some (nameR (destVar sigma t)) else if isLambda sigma t then let (n, _, _) = destLambda sigma t in Some n else if isProd sigma t then let (n, _, _) = destProd sigma t in Some n else if isLetIn sigma t then let (n, _, _, _) = destLetIn sigma t in Some n else None let get_name (env, sigma as ctx) (t: constr) : constr option = let name = get_name_base ctx t in match name with | Some {binder_name=Name i} -> Some (CoqString.to_coq (Names.Id.to_string i)) | Some _ -> (* it is Anonymous. We generate a fresh name. *) let n = Namegen.next_name_away (Name (Names.Id.of_string "x")) (vars_of_env env) in Some (CoqString.to_coq (Names.Id.to_string n)) | _ -> None let next_name_away s env = Namegen.next_name_away (Name s) (vars_of_env env) type name = AName of (bool * Id.t) | StuckName | InvalidName of string (* returns if the name generated is fresh or not *) let get_from_name (env, sigma as ctx) (t: constr) : name = let t = EConstr.of_constr (RE.whd_betadeltaiota env sigma (of_econstr t)) in let (h, args) = decompose_appvect sigma t in try match get_constructor_pos sigma h with | 0 -> (* TheName *) AName (false, Names.Id.of_string (CoqString.from_coq ctx args.(0))) | 1 -> (* FreshFrom *) let name = get_name_base ctx args.(1) in let name = match name with | Some {binder_name=Name i} -> Names.Id.to_string i | Some {binder_name=Anonymous} -> "ann" | None -> "x" in let name = next_name_away (Names.Id.of_string name) env in AName (true, name) | 2 -> (* FreshFromStr *) let name = CoqString.from_coq ctx args.(0) in let name = next_name_away (Names.Id.of_string name) env in AName (true, name) | 3 -> (* Generate *) let name = next_name_away (Names.Id.of_string "ann") env in AName (true, name) | _ -> StuckName with Constr.DestKO -> StuckName | CErrors.UserError pp -> InvalidName (Pp.string_of_ppcmds pp) end type backtrace_entry = | Constant of Names.Constant.t | MTry of Names.Constant.t option | InternalNu of Names.Id.t | InternalException of Pp.t (* | Anon of Loc.t option *) let pr_backtrace_entry t = let open Pp in match t with | Constant n -> Names.KerName.print (Names.Constant.canonical n) | MTry None -> str "" | MTry (Some n) -> str "" | InternalException p -> str "" | InternalNu name -> str "" (* | Anon (Some loc) -> * str "??? (" ++ Topfmt.pr_loc loc ++ str ")" * | Anon (None) -> Pp.str "???" *) type backtrace = backtrace_entry list module Backtrace = struct let push entry tr = if !debug_ex then entry () :: tr else tr let rec push_mtry mtry_tr = match mtry_tr with | [] -> push (fun () -> MTry None) | Constant n :: _ -> push (fun () -> MTry (Some n)) | _ :: mtry_tr -> push_mtry mtry_tr end let pr_backtrace (tr : backtrace) = let open Pp in prlist (fun t -> str " " ++ pr_backtrace_entry t ++ str "\n") tr type elem_stack = (evar_map * fconstr * stack * backtrace) type elem = (evar_map * constr) type data_stack = | Val of elem_stack | Err of elem_stack type data = | Val of elem | Err of elem * backtrace let return s t st tr : data_stack = Val (s, t, st, tr) let fail s t st tr : data_stack = Err (s, t, st, tr) let name_occurn_env env n = let open Context.Named.Declaration in let ids = Environ.fold_named_context_reverse (fun s n' -> Id.Set.add (get_id n') s) ~init:Id.Set.empty env in (* compute set of ids in env *) let ids = Id.Set.remove n ids in (* remove n *) let ids = Environ.really_needed env ids in (* and compute closure of ids *) Id.Set.mem n ids (* to finally check if n is in it *) let dest_Case (env, sigma) t = let sigma, dyn = mkdyn sigma env in try let (info, (return_type,r), iv, discriminant, branches) = EConstr.expand_case env sigma (destCase sigma t) in let sigma, branch_dyns = Array.fold_right ( fun t (sigma,l) -> let dyn_type = Retyping.get_type_of env sigma t in let sigma, cdyn = mkDyn dyn_type t sigma env in CoqList.mkCons sigma env dyn cdyn l ) branches (CoqList.mkNil sigma env dyn) in let ind_type = Retyping.get_type_of env sigma discriminant in let return_type_type = Retyping.get_type_of env sigma return_type in let sigma, ret_dyn = mkDyn return_type_type return_type sigma env in Some (mkCase ind_type discriminant ret_dyn branch_dyns sigma env) with | Not_found -> Exceptions.block "Something specific went wrong. TODO: find out what!" | Constr.DestKO -> None | _ -> Exceptions.block "Something not so specific went wrong." let contract_return_clause sigma (mib, mip) p = let open Context.Rel.Declaration in let (arity, p) = EConstr.decompose_lambda_n_decls sigma (mip.mind_nrealdecls + 1) p in match arity with | LocalAssum (_, ty) :: _ -> let (ind, args) = decompose_appvect sigma ty in let (_, u) = destInd sigma ind in let pms = Array.sub args 0 mib.mind_nparams in let dummy = List.make mip.mind_nrealdecls mkProp in let pms = Array.map (fun c -> Vars.substl dummy c) pms in let nas = Array.of_list (List.rev_map get_annot arity) in (u, pms, (nas, p)) | _ -> assert false let make_Case (env, sigma) case = let (_, args) = decompose_appvect sigma case in let repr_ind = args.(0) in let repr_ind = RE.whd_betadeltaiota env sigma (of_econstr repr_ind) in let repr_val = args.(1) in let repr_return = get_elem sigma args.(2) in let sigma, repr_branches = CoqList.from_coq_conv sigma env (fun sigma x -> sigma, get_elem sigma x) args.(3) in let t_type, l = decompose_appvect sigma (EConstr.of_constr repr_ind) in if isInd sigma t_type then match kind sigma t_type with | Ind ((mind, ind_i), _) -> let rci = ERelevance.relevant in let mib = Environ.lookup_mind mind env in let mip = mib.Declarations.mind_packets.(ind_i) in let case_info = Inductiveops.make_case_info env (mind, ind_i) LetPatternStyle in let (u, pms, repr_return) = contract_return_clause sigma (mib, mip) repr_return in let expand_branch i br = let open Context.Rel.Declaration in let ctx, _ = mip.mind_nf_lc.(i) in let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in let ctx = of_rel_context ctx in let nas = Array.of_list (List.rev_map get_annot ctx) in let args = Context.Rel.instance mkRel 0 ctx in nas, (mkApp (Vars.lift (Array.length nas) br, args)) in let repr_branches = List.mapi expand_branch repr_branches in let match_term = EConstr.mkCase (case_info, u, pms, (repr_return, rci), NoInvert (* TODO handle case inversion *), repr_val, (Array.of_list repr_branches)) in let match_type = Retyping.get_type_of env sigma match_term in mkDyn match_type match_term sigma env | _ -> assert false else Exceptions.block "case_type is not an inductive type" let get_Constrs (env, sigma) t = (* let t = to_constr sigma t in *) let t_type, args = decompose_app sigma (EConstr.of_constr (RE.whd_betadeltaiota env sigma (of_econstr t))) in if isInd sigma t_type then let (mind, ind_i), _ = destInd sigma t_type in let mbody = Environ.lookup_mind mind env in let ind = Array.get (mbody.mind_packets) ind_i in let sigma, dyn = mkdyn sigma env in (* let args = CList.firstn mbody.mind_nparams_rec args in *) let sigma, l = Array.fold_right (fun i (sigma, l) -> let constr = Names.ith_constructor_of_inductive (mind, ind_i) i in let coq_constr = mkConstruct constr in let ty = Retyping.get_type_of env sigma coq_constr in let sigma, dyn_constr = mkDyn ty coq_constr sigma env in CoqList.mkCons sigma env dyn dyn_constr l ) (* this is just a dirty hack to get the indices of constructors *) (Array.mapi (fun i t -> i+1) ind.mind_consnames) (CoqList.mkNil sigma env dyn) in let indty = t_type in let indtyty = Retyping.get_type_of env sigma indty in let nparams = CoqN.to_coq (mbody.mind_nparams) in let nindices = CoqN.to_coq (ind.mind_nrealargs) in let sigma, indtydyn = mkDyn indtyty indty sigma env in let sigma, ind_dyn = CoqInd_Dyn.to_coq sigma env [|indtydyn; nparams; nindices; l|] in (* let sigma, listty = CoqList.mkType sigma env dyn in * let sigma, pair = CoqPair.mkPair sigma env dyn listty indtydyn l in *) Some (sigma, ind_dyn) else None module Hypotheses = struct let hyp_builder = mkUBuilder "Goals.Hyp" let ahyp_constr = mkUBuilder "Goals.ahyp" exception NotAVariable exception NotAHyp let from_coq (env, sigma as ctx) c = let fvar = fun c -> if isVar sigma c then c else raise NotAVariable in let fdecl = CoqOption.from_coq sigma env in let oargs = UConstrBuilder.from_coq ahyp_constr ctx c in match oargs with | Some args -> (fvar args.(1), fdecl args.(2), args.(0)) | None -> raise NotAHyp let from_coq_list (env, sigma) t = (* safe to throw away sigma here as it doesn't change *) snd (CoqList.from_coq_conv sigma env (fun sigma x -> sigma, from_coq (env, sigma) x ) t) end (* It replaces each ii by ci in l = [(i1,c1) ... (in, cn)] in c. It throws Not_found if there is a variable not in l *) let multi_subst sigma l c = let rec substrec depth c = match kind sigma c with | Rel k -> if k<=depth then c else List.assoc (k - depth) l | _ -> map_with_binders sigma succ substrec depth c in substrec 0 c let name_depends_on sigma deps ty ot = let open Id.Set in let open Termops in let vars = collect_vars sigma ty in let vars = if Option.has_some ot then union (collect_vars sigma (Option.get ot)) vars else vars in not (is_empty (inter vars deps)) (* given a named_context env and a variable x it returns all the (named) variables that depends transitively on x *) let depends_on env sigma x = let open Id.Set in let open Context.Named in let deps = singleton x in fold_outside (fun v deps-> let (n, ot, ty) = Declaration.to_tuple v in if name_depends_on sigma deps ty ot then Id.Set.add n.binder_name deps else deps) env ~init:deps let name_deps env x = depends_on (named_context env) x let compute_deps env sigma x = if isVar sigma x then let name = destVar sigma x in name_deps env sigma name else failwith "check_dependencies should not be called with not a var" (* given a rel or var x and a term t and its type ty, it checks if t or ty does not depend on x *) let check_abs_deps env sigma x t ty = let ndeps = compute_deps env sigma x in let open Id.Set in (* The term might depend on x *) (subset (inter (collect_vars sigma t) ndeps) (singleton (destVar sigma x)) && is_empty (inter (collect_vars sigma ty) ndeps)) (* check if x \not\in FV(t) union FV(env) *) let check_dependencies env sigma x t = if isVar sigma x then let name = destVar sigma x in not (Termops.occur_var env sigma name t) && not (name_occurn_env env name) else failwith "check_dependencies should not be called with not a var or rel" (** Abstract *) type abs = AbsProd | AbsFun | AbsLet | AbsFix (** checks if (option) definition od and type ty has named vars included in vars *) let check_vars sigma od ty vars = Id.Set.subset (Termops.collect_vars sigma ty) vars && if Option.has_some od then Id.Set.subset (Termops.collect_vars sigma (Option.get od)) vars else true exception MissingDep (* returns a substitution and an environment such that applying the substitution to a term makes the term well typed in the environment *) let new_env (env, sigma) hyps = let _, _, subs, env = List.fold_right (fun (var, odef, ty) (idlist, idset, subs, env') -> (* the definition might refer to previously defined indices so we perform the substitution *) let odef = try Option.map (multi_subst sigma subs) odef with Not_found -> raise MissingDep in (* if the variable is named, its type can only refer to named variables. note that typing ensures the var has type ty, so its type must be defined in the named context *) if check_vars sigma odef ty idset then let id = destVar sigma var in (id::idlist, Id.Set.add id idset, subs, push_named (Context.Named.Declaration.of_tuple (annotR id, odef, ty)) env') else raise MissingDep ) hyps ([], Id.Set.empty, [], empty_env) in subs, env let make_evar sigma env ty = let sigma, evar = Evarutil.new_evar env sigma ty in sigma, evar (* return the reflected hash of a term *) let hash env sigma c size = let size = CoqN.from_coq (env, sigma) size in let h = Constr.hash (Unsafe.to_constr c) in CoqN.to_coq (Stdlib.abs (h mod size)) (* [build_hypotheses sigma env] reflects the hypotheses in [env] in a list of [ahyp]. It optionally takes the universes to use for the [mlist] and [Hyp] types. *) let build_hypotheses ?univ_list ?univ_hyp sigma env = let open Context.Named.Declaration in let renv = List.map (fun v->let (n, t, ty) = to_tuple v in (mkVar n.binder_name, t, ty)) (named_context env) in (* the list is reversed: [H : x > 0, x : nat] *) (* Pre-generate all constructors and types. We only need a total of two universes, one for hyps and one for the list constructors. For simplicity, we generate a total of 3 to not have to fiddle with the universes of nil, which we generate as before. *) let (sigma, hypty) = UConstrBuilder.build_app ?univs:univ_hyp Hypotheses.hyp_builder sigma env [||] in let (sigma, ahyp) = UConstrBuilder.build_app ?univs:univ_hyp Hypotheses.ahyp_constr sigma env [||] in let (sigma, cons) = UConstrBuilder.build_app ?univs:univ_list CoqList.consBuilder sigma env [||] in let rec build renv = match renv with | [] -> (UConstrBuilder.build_app ?univs:univ_list CoqList.nilBuilder sigma env [|hypty|]) | (n, t, ty) :: renv -> let (sigma, r) = build renv in let sigma, t = match t with | None -> UConstrBuilder.build_app ?univs:univ_hyp CoqOption.noneBuilder sigma env [|ty|] | Some t -> UConstrBuilder.build_app ?univs:univ_list CoqOption.someBuilder sigma env [|ty; t|] in let hyp = EConstr.mkApp (ahyp, [|ty; n; t|]) in sigma, EConstr.mkApp (cons, [|hypty; hyp; r|]) (* Hypotheses.cons_hyp ty n t r sigma env *) in build renv (* builds the context without x (which should be a variable) *) let env_without sigma env x = let open Context.Named.Declaration in let name_env = named_context env in let env = Environ.reset_context env in let nx = destVar sigma x in let name_env = List.filter (fun decl -> get_id decl <> nx) name_env in let env = push_named_context name_env env in env, sigma (* builds the context without x (which should be a variable) *) let env_replacing sigma env x ty = let open Context.Named.Declaration in let name_env = named_context env in let env = Environ.reset_context env in let nx = destVar sigma x in let name_env = List.map (fun decl -> if get_id decl <> nx then decl else map_type (fun _ -> ty) decl) name_env in let env = push_named_context name_env env in env, sigma let is_nu env sigma x nus = let open Context.Named.Declaration in let env = named_context env in let nx = destVar sigma x in let rec find env i = let decl = List.hd env in if get_id decl = nx then i else find (List.tl env) (i+1) in find env 0 < nus (** declare a definition *) exception UnsupportedDefinitionObjectKind exception CanonicalStructureMayNotBeOpaque let run_declare_def env sigma kind name opaque ty bod = let open Decls in let vernac_definition_hook poly = function | Coercion -> Some (ComCoercion.add_coercion_hook ~reversible:false) | CanonicalStructure -> if opaque then raise CanonicalStructureMayNotBeOpaque else Some (Declare.Hook.(make (fun { S.dref; _ } -> Canonical.declare_canonical_structure dref))) | SubClass -> Some (ComCoercion.add_subclass_hook ~poly ~reversible:false) (* | Instance -> Lemmas.mk_hook (fun local gr -> *) (* let local = match local with | Global -> false | Local -> true | _ -> raise DischargeLocality in *) (* let () = Typeclasses.declare_instance None local gr *) (* in () *) (* ) *) | Instance | IdentityCoercion | Scheme | StructureComponent | Fixpoint -> raise UnsupportedDefinitionObjectKind | _ -> None in (* copied from coq 8.6.1 Decl_kinds *) let kinds = [| Definition ; Coercion ; SubClass ; CanonicalStructure ; Example ; Fixpoint ; CoFixpoint ; Scheme ; StructureComponent ; IdentityCoercion ; Instance ; Method|] in let _, univs = EConstr.universes_of_constr sigma bod in let univs = Univ.Level.Set.union univs (snd (EConstr.universes_of_constr sigma ty)) in let ty = Unsafe.to_constr ty in let bod = Unsafe.to_constr bod in let sigma' = Evd.restrict_universe_context sigma univs in let uctx = Evd.evar_universe_context sigma' in let ctx = Evd.univ_entry ~poly:false sigma' in let kind_pos = get_constructor_pos sigma kind in let kind = kinds.(kind_pos) in let name = CoqString.from_coq (env, sigma) name in let id = Names.Id.of_string name in let ce = Declare.definition_entry ~opaque ~types:ty ~univs:ctx bod in let kn = Declare.declare_constant ~name:id ~kind:(Decls.IsDefinition kind) (Declare.DefinitionEntry ce) in let dref = GlobRef.ConstRef kn in let () = Declare.Hook.call ?hook:(vernac_definition_hook false kind) { Declare.Hook.S.uctx; obls=[]; scope=Locality.(Global ImportDefaultBehavior); dref } in let c = UnivGen.constr_of_monomorphic_global (Global.env ()) dref in let env = Global.env () in (* Feedback.msg_notice *) (* (Termops.print_constr_env env c); *) (sigma, env, c) (** declare implicits *) let run_declare_implicits env sigma gr impls = (* we expect each item in the list to correspond to an optional element of an inductive type roughly like this: | Explicit | Implicit | MaximallyImplicit But we do not care much for the actual type so right now we just take the constructor_pos *) let impliciteness = [| false (* Dummy value *) ; false (* Implicit *) ; true (* Maximal *) |] in let gr, _ = try Constr.destRef gr with DestKO -> raise Not_found in let impls = CoqList.from_coq sigma env impls in let idx = ref (List.length impls) in let impls = List.map (fun item -> let kind_pos = get_constructor_pos sigma item in let ret = CAst.make (if kind_pos > 0 then Some (Anonymous, impliciteness.(kind_pos)) else None) in (* let ret = match CoqOption.from_coq (env, sigma) item with *) (* | None -> None *) (* | Some item -> *) (* let kind_pos = get_constructor_pos item in *) (* Some (Constrexpr.ExplByPos(!idx, None), impliciteness.(kind_pos)) *) (* in *) idx := !idx - 1; ret ) impls in (* since there is no way to declare something explicit, we clear implicits first *) let () = Impargs.declare_manual_implicits false gr [] in let () = Impargs.maybe_declare_manual_implicits false gr impls in (sigma, CoqUnit.mkTT) let rec _below_lambdas sigma t f = function | 0 -> f t | k when k > 0 -> let n, typeT, t = destLambda sigma t in let t = _below_lambdas sigma t f (k - 1) in mkLambda (n, typeT, t) | _ -> raise (Failure "below_lambdas must not be called with negative values.") let rec _below_prods sigma t f = function | 0 -> f t | k when k > 0 -> let n, typeT, t = destProd sigma t in let t = _below_prods sigma t f (k-1) in mkProd (n, typeT, t) | _ -> raise (Failure "below_lambdas must not be called with negative values.") let rec strip_lambdas sigma t = function | 0 -> t | k when k > 0 -> let n, typeT, t = destLambda sigma t in let t = strip_lambdas sigma t (k - 1) in t | _ -> raise (Failure "strip_lambdas must not be called with negative values.") let rec fold_nat f t = function | 0 -> t | k when k > 0 -> fold_nat f (f k t) (k - 1) | _ -> raise (Failure "fold_nat must not be called with negative values.") let rec mTele_fold_left sigma env f acc t = match CoqMTele.from_coq sigma env t with | None -> acc | Some ((typeX,contF)) -> let (name,ty,t) = destLambda sigma contF in let acc = f acc (name, typeX) in mTele_fold_left sigma env f acc t let rec _mTele_fold_right sigma env f acc t = match CoqMTele.from_coq sigma env t with | None -> acc | Some ((typeX,contF)) -> let (_,_,t') = destLambda sigma contF in f t (_mTele_fold_right sigma env f acc t') (* turns [[tele x .. z]] and [fun x .. z => T] into [forall x .. z, b(T)] *) let mTele_to_foralls sigma env tele funs b = let n_args, funs, binders = mTele_fold_left sigma env (fun (n,funs,acc) (name, typeX) -> let (name, ty, funs) = destLambda sigma funs in (n+1, funs, (name, ty)::acc) ) (0, funs, []) tele in let sigma, funs = b sigma n_args funs in let arity = List.fold_left (fun t (name, ty) -> EConstr.mkProd (name, ty, t)) funs binders in sigma, n_args, arity let rec zip = function | ([], []) -> [] | (x::l1, y::l2) -> (x,y):: zip (l1, l2) | _ -> raise (Failure "zip called with lists of unequal length.") let rec unzip = function | [] -> [], [] | (x,y)::l -> let l1,l2 = unzip l in (x :: l1, y::l2) let declare_mind env sigma params sigs mut_constrs = let vars = vars_of_env env in (* Calculate length and LocalEntry list from parameter telescope. The LocalEntry list is reversed because we are using a left fold. *) let sigma = Evd.collapse_sort_variables sigma in let n_params, mind_entry_params, _, params = mTele_fold_left sigma env (fun (n, acc, vars, params) (name, typeX) -> let id = match name.binder_name with | Anonymous -> Namegen.next_name_away (Name (Id.of_string "")) vars | Name id -> id in let vars = Id.Set.add id vars in let params = (name, typeX):: params in (n+1, (Context.Rel.Declaration.LocalAssum (Context.nameR id, EConstr.to_constr sigma typeX))::acc, vars, params) ) (0, [], vars, []) params in let params_rev = params in let params = List.rev params in let _param_env = List.fold_left (fun param_env (name, typeX) -> Environ.push_rel (Context.Rel.Declaration.LocalAssum (EConstr.to_binder_annot sigma name, EConstr.to_constr sigma typeX)) param_env ) env params in (* let mind_entry_params = List.rev mind_entry_params in *) let sigma, inds = CoqList.from_coq_conv sigma env ( fun sigma t -> let (name, ind_sig) = CoqPair.from_coq (env, sigma) t in (* print_constr sigma env t; *) (* print_constr sigma env ind_sig; *) let (ind_tele, ind_ty) = CoqSigT.from_coq sigma env (strip_lambdas sigma ind_sig n_params) in let sigma, n_ind_args, ind_arity = mTele_to_foralls sigma env ind_tele ind_ty (fun sigma _ t -> let open CoqSort in match CoqSort.from_coq sigma env t with | Prop_sort -> sigma, mkProp | Type_sort -> let sigma, univ = Evd.new_univ_level_variable (Evd.UnivFlexible false) sigma in sigma, mkType (Univ.Universe.make univ) ) in let name = CoqString.from_coq (env, sigma) name in let name = Id.of_string name in let ind_arity_full = List.fold_left (fun arity (name, typeX) -> mkProd (name, typeX, arity)) ind_arity params_rev in (sigma, (name, n_ind_args, ind_ty, ind_arity, ind_arity_full)) ) sigs in let ind_env = List.fold_left (fun ind_env (name, _,_, _, ind_arity_full) -> Environ.push_rel (Context.Rel.Declaration.LocalAssum (Context.nameR name, EConstr.to_constr sigma ind_arity_full)) ind_env ) env inds in let _ind_env = List.fold_left (fun param_env (name, typeX) -> Environ.push_rel (Context.Rel.Declaration.LocalAssum (EConstr.to_binder_annot sigma name, EConstr.to_constr sigma typeX)) param_env ) ind_env params in (* Feedback.msg_debug (Pp.str "inductives:"); * Feedback.msg_debug (Printer.pr_context_of param_env sigma); * List.iter ((fun (name, _, _, ind_arity, ind_arity_full) -> * print_constr sigma param_env ind_arity; * print_constr sigma env ind_arity_full; * )) inds; *) let n_inds = List.length inds in (* is there no Nat.iter in ocaml?? *) (* print_constr sigma env mut_constrs; *) (* Strip off [n_params + n_inds] many lambdas. TODO: error handling, potentially delta-reduce. *) let mut_constrs = strip_lambdas sigma mut_constrs (n_params + n_inds) in (* prepare the list of parameters which we will append to the inductive type at the end of every constructor before we append indices. *) (* let param_args = fold_nat (fun k acc -> mkRel (n_params + n_inds - k + 1) :: acc) [] n_params in *) let param_args = List.mapi (fun i (name, typeX) -> mkRel (n_params - i)) params in (* Convert [constrs], now an [n_inds]-tuple of lists, into a list *) let sigma, _, constrs, unit_leftover = List.fold_left (fun (sigma, k_ind, acc, mut_constrs)(_, n_ind_args, _, _,_) -> (* print_constr sigma env mut_constrs; *) (* Feedback.msg_debug (Pp.int n_ind_args); *) let constrs, mut_constrs = CoqPair.from_coq (env, sigma) mut_constrs in let sigma, constrs = CoqList.from_coq_conv sigma env (fun sigma constr -> (* print_constr sigma env constr; *) let name, constr = CoqPair.from_coq (env, sigma) constr in let (constr_tele, constr_type) = CoqSigT.from_coq sigma env constr in let sigma, n_constr_args, constr_type = mTele_to_foralls sigma env constr_tele constr_type (fun sigma n_constr_args t -> let leftover_unit, args = fold_nat (fun _ (t, acc) -> (* print_constr sigma env t; *) let (arg, t) = CoqSigT.from_coq sigma env t in (t, arg::acc) ) (t, []) (n_ind_args) in sigma, EConstr.applist (EConstr.mkRel (n_params + n_inds - k_ind + n_constr_args), List.map (EConstr.Vars.lift n_constr_args) param_args @ rev args) ) in let name = CoqString.from_coq (env, sigma) name in let name = Id.of_string name in (sigma, (name, constr_type)) ) constrs in (sigma, k_ind+1, constrs::acc, mut_constrs) ) (sigma, 0, [], mut_constrs) inds in (* constrs now reversed because of a left fold. *) let constrs = List.rev constrs in assert (List.length constrs == List.length inds); (* Feedback.msg_debug (Pp.str "constructors:"); * Feedback.msg_debug (Printer.pr_context_of ind_env sigma); * Feedback.msg_debug ( * Pp.prlist_with_sep (fun () -> Pp.str "\n\n") ( * Pp.prlist_with_sep (fun () -> Pp.str "\n") (fun (name,t) -> * let open Pp in * Name.print (Names.Name name) ++ str ": " ++ * Printer.pr_econstr_env ind_env sigma t) * ) constrs * ); *) (* List.iter (List.iter (fun (name, constr) -> print_constr sigma ind_env constr)) constrs; *) let open Entries in let mind_entry_inds = List.fold_left (fun acc ((mind_entry_typename, n_ind_args, _, mind_entry_arity, _), constrs) -> let mind_entry_consnames, mind_entry_lc = unzip constrs in let mind_entry_lc = List.map (EConstr.to_constr sigma) mind_entry_lc in let mind_entry_arity = EConstr.to_constr sigma mind_entry_arity in {mind_entry_typename; mind_entry_arity; mind_entry_consnames; mind_entry_lc} :: acc ) [] (zip (inds, constrs)) in let mind_entry_inds = List.rev mind_entry_inds in let univs, ubinders = Evd.univ_entry ~poly:false sigma in let uctx = match univs with | UState.Monomorphic_entry ctx -> let () = Global.push_context_set ~strict:true ctx in Entries.Monomorphic_ind_entry | UState.Polymorphic_entry uctx -> Entries.Polymorphic_ind_entry uctx in let _ = DeclareInd.declare_mutual_inductive_with_eliminations {mind_entry_record=None; mind_entry_finite=Declarations.Finite; mind_entry_inds; mind_entry_params; mind_entry_universes=uctx; mind_entry_variance=None; mind_entry_private=None; } (univs, UnivNames.empty_binders) [] in (sigma, CoqUnit.mkTT) let koft sigma t = let lf n = Lazy.force (MtacNames.mkConstr ("Tm_kind." ^ n)) in let open Constr in match kind t with | Var _ -> lf "tmVar" | Evar _ -> lf "tmEvar" | Sort _ -> lf "tmSort" | Const _ -> lf "tmConst" | Construct _ -> lf "tmConstruct" | Lambda _ -> lf "tmLambda" | Prod _ -> lf "tmProd" | LetIn _ -> lf "tmLetIn" | App _ -> lf "tmApp" | Cast _ -> lf "tmCast" | Ind _ -> lf "tmInd" | Case _ -> lf "tmCase" | Fix _ -> lf "tmFix" | CoFix _ -> lf "tmCoFix" | _ -> failwith "unsupported" type ctxt = { env: Environ.env; sigma: Evd.evar_map; nus: int; stack: CClosure.stack; backtrace: backtrace; } type vm = Code of CClosure.fconstr | Ret of CClosure.fconstr | Fail of CClosure.fconstr | Bind of (CClosure.fconstr * backtrace) | Try of (Evd.evar_map * CClosure.stack * backtrace * CClosure.fconstr) | Nu of (Names.Id.t * Environ.env * backtrace) | Rem of (Environ.env * bool) | Rep of (Environ.env) (* Partition stack [st] into [careless ++ careful] such that if [careful] is [x :: careful'] then [x] is the lowest match or projection on the stack. This is useful to have because we know that a) matching on monadic terms is not part of monadic programs, thus [careless] only contains non-monadic terms b) only monadic programs contain let-reduce terms c) thus, we can freely reduce let bindings in the stack [careless] (i.e. above [x]) *) let cut_stack st = let rec f st careless_rev careful_rev = match st with | (( Zfix _ | Zproj _ | ZcaseT _ ) as z) :: st-> if List.is_empty careful_rev then f st careless_rev (z :: careful_rev) else f st (List.append careful_rev careless_rev) [z] | z :: st -> if List.is_empty careful_rev then f st (z :: careless_rev) careful_rev else f st careless_rev (z :: careful_rev) | r -> careless_rev, careful_rev in let careless_rev, careful_rev = f st [] [] in List.rev careless_rev, List.rev careful_rev type context = | Monadic | Pure let rec context_of_stack = function | [] -> Monadic | (( (* Zfix _ | *) Zproj _ | ZcaseT _)) :: st -> Pure | z :: st -> context_of_stack st let _zip_term m stk = let open CClosure in let open Constr in let rec zip_term zfun m stk = match stk with | [] -> m | Zapp args :: s -> zip_term zfun (mkApp(m, Array.map zfun args)) s | ZcaseT(ci,u,pms,p,br,e)::s -> (* FIXME let t = mkCase(ci, zfun (mk_clos e p), NoInvert, m, Array.map (fun b -> zfun (mk_clos e b)) br) in zip_term zfun t s *) assert false | Zproj (p,r)::s -> let t = mkProj (Projection.make p true, r, m) in zip_term zfun t s | Zfix(fx,par)::s -> let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in zip_term zfun h s | Zshift(n)::s -> zip_term zfun (lift n m) s | Zupdate(_rf)::s -> zip_term zfun m s | Zprimitive(_,c,rargs, kargs)::s -> let kargs = List.map (fun (_,a) -> zfun a) kargs in let args = List.fold_left (fun args a -> zfun a ::args) (m::kargs) rargs in let h = mkApp (mkConstU c, Array.of_list args) in zip_term zfun h s in zip_term (term_of_fconstr) m stk (* let vm_to_string env sigma = function *) (* | Code c -> "Code " ^ constr_to_string sigma env c *) (* | Bind c -> "Bind " ^ constr_to_string sigma env c *) (* | Try (_, c) -> "Try " ^ constr_to_string sigma env c *) (* | Ret c -> "Ret " ^ constr_to_string sigma env c *) (* | Fail c -> "Fail " ^ constr_to_string sigma env c *) (* | Nu _ -> "Nu" *) (* | Fix -> "Fix" *) (* | Rem _ -> "Rem" *) let check_exception exception_sigma mtry_sigma env c = let c = nf_evar exception_sigma c in (* avoids false dependencies *) try let (ev, _) = Typing.type_of env mtry_sigma c in (true, (ev, c)) with _ -> (false, E.mkExceptionNotGround mtry_sigma env c) let timers = Hashtbl.create 128 let create_clos_infos env sigma flgs = let env = set_typing_flags ({(Environ.typing_flags env) with share_reduction = false}) env in Evarutil.create_clos_infos env sigma flgs let reduce_noshare infos t stack = let r = CClosure.whd_stack infos t stack in r let pop_args num stack = let rec pop_args num stack = if num > 0 then match stack with | Zapp args :: stack -> let n = Array.length args in if n < num then let (argss, stack) = pop_args (num - n) stack in args :: argss, stack else if n = num then [args], stack else (* this can not happen. something of type [M T] can not be applied to more arguments *) assert false | _ -> failwith "no more arguments on stack" else ([], stack) in let argss, stack = pop_args num stack in if List.length argss == 0 then ([||], stack) else if List.length argss == 1 then (List.hd argss, stack) else (Array.concat argss, stack) let unfold_reference env (cst, u) = match Environ.lookup_constant cst env with | { const_body = Def b } -> Some (CClosure.mk_clos (Esubst.subs_id 0, u) b) | { const_body = (OpaqueDef _ | Undef _ | Primitive _ | Symbol _) } -> None | exception Not_found -> None let rec run' ctxt (vms : vm list) = (* let sigma, env, stack = ctxt.sigma, ctxt.env, ctxt.stack in *) (* if !trace then begin * print_string "<<< "; * List.iter (fun vm->Printf.printf "%s :: " (vm_to_string env sigma vm)) vms; * print_endline " >>>" * end; *) let vm = hd vms in let vms = tl vms in let ctxt_nu1_fail (_, env, _) = {ctxt with env; nus = ctxt.nus-1} in let ctxt_nu1 (_, env, backtrace) = {ctxt with backtrace; env; nus = ctxt.nus-1} in match vm, vms with | Ret c, [] -> return ctxt.sigma c ctxt.stack ctxt.backtrace | Ret c, (Bind (b, backtrace) :: vms) -> let stack = Zapp [|c|]::ctxt.stack in (run'[@tailcall]) {ctxt with backtrace; stack} (Code b :: vms) | Ret c, (Try (_, _, _, b) :: vms) -> (run'[@tailcall]) ctxt (Ret c :: vms) | Ret c, Nu (name, _, _ as p) :: vms -> (* why the sigma'? *) if occur_var ctxt.env ctxt.sigma name (to_econstr c) then let (sigma, e) = E.mkVarAppearsInValue ctxt.sigma ctxt.env (mkVar name) in let ctxt = ctxt_nu1_fail p in let backtrace = Backtrace.push ( fun () -> InternalException (Printer.pr_econstr_env ctxt.env sigma e) ) ctxt.backtrace in (run'[@tailcall]) {ctxt with backtrace; sigma} (Fail (of_econstr e) :: vms) else (run'[@tailcall]) (ctxt_nu1 p) (Ret c :: vms) | Ret c, Rem (env, was_nu) :: vms -> (run'[@tailcall]) {ctxt with env; nus = if was_nu then ctxt.nus+1 else ctxt.nus} (Ret c :: vms) | Ret c, Rep (env) :: vms -> (run'[@tailcall]) {ctxt with env} (Ret c :: vms) | Fail c, [] -> fail ctxt.sigma c ctxt.stack ctxt.backtrace | Fail c, (Bind (_, _) :: vms) -> (run'[@tailcall]) ctxt (Fail c :: vms) | Fail c, (Try (sigma, stack, backtrace_try, b) :: vms) -> let sigma = Evd.set_universe_context sigma (Evd.evar_universe_context ctxt.sigma) in let (ground, (sigma, c)) = check_exception ctxt.sigma sigma ctxt.env (to_econstr c) in let backtrace = ctxt.backtrace in let backtrace = if ground then Backtrace.push_mtry backtrace_try backtrace else Backtrace.push ( fun () -> InternalException (Printer.pr_econstr_env ctxt.env (ctxt.sigma) c) ) backtrace in (run'[@tailcall]) {ctxt with sigma; backtrace; stack=Zapp [|of_econstr c|] :: stack} (Code b::vms) | Fail c, (Nu p :: vms) -> (run'[@tailcall]) (ctxt_nu1_fail p) (Fail c :: vms) | Fail c, Rem (env, was_nu) :: vms -> (run'[@tailcall]) {ctxt with env; nus = if was_nu then ctxt.nus+1 else ctxt.nus} (Fail c :: vms) | Fail c, Rep (env) :: vms -> (run'[@tailcall]) {ctxt with env} (Fail c :: vms) | (Bind _ | Fail _ | Nu _ | Try _ | Rem _ | Rep _), _ -> failwith "ouch1" | Ret _, (Code _ :: _ | Ret _ :: _ | Fail _ :: _) -> failwith "ouch2" | Code t, _ -> (eval[@tailcall]) ctxt vms t and eval ctxt (vms : vm list) ?(reduced_to_let=false) t = let sigma, env, stack = ctxt.sigma, ctxt.env, ctxt.stack in let upd c = (Code c :: vms) in (* let cont ctxt h args = (run'[@tailcall]) {ctxt with stack=Zapp args::stack} (Code h :: vms) in *) (* let term = zip_term (CClosure.term_of_fconstr t) stack in * Feedback.msg_debug (Printer.pr_constr_env env sigma term); *) let reds = RedFlags.allnolet in let reds = RedFlags.red_add_transparent reds ts_var_full in let infos = create_clos_infos env sigma reds in let tab = CClosure.create_tab () in let reduced_term, stack = reduce_noshare infos tab t stack in (* Feedback.msg_debug (Pp.int (List.length stack)); *) let ctxt = {ctxt with stack} in let fail ?internal:(i=true) (sigma, c) = let backtrace = if i then let p () = InternalException (Printer.pr_econstr_env env sigma (to_econstr c)) in Backtrace.push (p) ctxt.backtrace else ctxt.backtrace in (run'[@tailcall]) {ctxt with sigma; backtrace} (Fail c :: vms) in let efail ?internal (sigma, fc) = fail ?internal (sigma, of_econstr fc) in let ctx_st = context_of_stack stack in (* (if !trace then ( * (let open Pp in match ctx_st with * | Monadic -> Feedback.msg_debug (str "monadic " ++ bool reduced_to_let) * | Pure -> Feedback.msg_debug (str "pure " ++ bool reduced_to_let) * ); * * let term = _zip_term (CClosure.term_of_fconstr reduced_term) stack in * Feedback.msg_debug (Printer.pr_constr_env env sigma term) * ) * else () * ); *) let is_blocked = function | FFlex (VarKey _) -> true | (FRel i | FFlex (RelKey i)) when not (Environ.evaluable_rel i env) -> true | _ -> false in match ctx_st, fterm_of reduced_term with | Monadic, FConstruct _ -> failwith ("Invariant invalidated: reduction reached the constructor of M.t.") | Monadic, FLetIn (_,v,_,bd,e) -> let open ReductionStrategy in let (is_reduce, num_args, args_clos) = ( match fterm_of v with | FApp (h, args) -> (isFReduce sigma env h, Array.length args, fun () -> args) | FCLOS (t, subst) when Constr.isApp t -> let (h, args) = Constr.destApp t in (isTReduce sigma env h, Array.length args, fun () -> Array.map (fun x -> mk_red (FCLOS (x, subst))) args ) | _ -> (false, -1, fun () -> [||]) ) in if is_reduce && num_args == 3 then let args' = args_clos () in let red = Array.get args' 0 in let term = Array.get args' 2 in (* print_constr sigma env term; *) let ob = reduce sigma env (to_econstr red) (to_econstr term) in match ob with | ReductionValue (sigma, b) -> let e = (CClosure.usubs_cons (of_econstr b) e) in let ctxt = {ctxt with sigma} in (run'[@tailcall]) ctxt (upd (mk_red (FCLOS (bd, e)))) | ReductionStuck -> let l = to_econstr (Array.get args' 0) in efail (E.mkNotAList sigma env l) | ReductionFailure -> let l = to_econstr (Array.get args' 0) in efail (E.mkReductionFailure sigma env l) else let e = (CClosure.usubs_cons v e) in (eval[@tailcall]) ctxt vms (mk_red (FCLOS (bd, e))) | Monadic, FFlex (ConstKey (hc, u)) -> begin match MConstr.mconstr_head_opt hc with | Some mh -> (* We have reached a primitive *) (primitive[@tailcall]) ctxt vms mh u reduced_term | None -> match unfold_reference env (hc, u) with | Some v -> let backtrace = Backtrace.push (fun () -> Constant hc) ctxt.backtrace in let ctxt = {ctxt with backtrace} in (run'[@taillcall]) ctxt (Code v :: vms) | None -> efail (E.mkStuckTerm sigma env (to_econstr t)) end (* [whd_stack] considers unfolded primitive projections fully reduced. That will not do. *) | Monadic, FProj (proj, r, t) -> let stack = Zproj (Projection.repr proj, r) :: stack in let ctxt = {ctxt with stack} in (eval[@tailcall]) ctxt vms t | Pure, (_ as t) when (is_blocked t) -> begin if !debug_ex then (let open Pp in Feedback.msg_debug ( Printer.pr_econstr_env env sigma (to_econstr reduced_term) ++ str " is not evaluable. Are you trying to reduce a \\nu variable?" ) ); efail (E.mkStuckTerm sigma env (to_econstr reduced_term)) end | Pure, (_ as t) when not reduced_to_let -> let careless, careful = cut_stack stack in let infos = CClosure.infos_with_reds infos RedFlags.all in (* let term_to_reduce = _zip_term (CClosure.term_of_fconstr reduced_term) careless in * Feedback.msg_debug (Printer.pr_constr_env env sigma term_to_reduce); *) let tab = CClosure.create_tab () in let t', stack = reduce_noshare infos tab (CClosure.mk_red t) careless in let stack = List.append stack careful in (* carefully reduce further without touching lets *) let infos = CClosure.infos_with_reds infos RedFlags.allnolet in let tab = CClosure.create_tab () in let t', stack = reduce_noshare infos tab t' stack in (* signal that we have advanced reduced everything down to lets *) (eval[@tailcall]) {ctxt with stack} vms ?reduced_to_let:(Some true) t' | _ -> if !debug_ex then (let open Pp in Feedback.msg_debug ( Printer.pr_econstr_env env sigma (to_econstr reduced_term) ++ str " is not evaluable. Context: " ++ (match ctx_st with | Pure -> str "Pure" | Monadic -> str "Monadic") ++ str ". " ++ if reduced_to_let then str "Reduced to let-in." else str "Not reduced to let-in." ) ); efail (E.mkStuckTerm sigma env (to_econstr reduced_term)) and primitive ctxt vms mh univs reduced_term = let sigma, env, stack = ctxt.sigma, ctxt.env, ctxt.stack in let open MConstr in let upd c = (Code c :: vms) in (* let (h, args) = decompose_appvect sigma reduced_term in *) (* print_constr sigma env (to_econstr reduced_term); *) let return ?new_env:(new_env=env) sigma c = (run'[@tailcall]) {ctxt with sigma; env=new_env; stack} (Ret c :: vms) in (* let fail (sigma, c) = (run'[@tailcall]) {ctxt with sigma} (Fail c :: vms) in *) (* wrappers for return and fail to conveniently return/fail with EConstrs *) let _ereturn ?new_env s fc = return ?new_env:new_env s (of_econstr fc) in (* let efail (sigma, fc) = fail (sigma, of_econstr fc) in *) (* print_constr sigma env h; *) let num_args = (let (MHead mh) = mh in MConstr.num_args_of_mconstr mh) in let args, stack = pop_args num_args stack in let mc = (let (MHead mh) = mh in MConstr.mconstr_of (Array.get args) mh) in let hf = reduced_term in if !trace then print_constr sigma env (EConstr.of_constr (CClosure.term_of_fconstr (mk_red (FApp (reduced_term,args))))); let ctxt = {ctxt with stack} in (* Re-do the wrappers so they use the new stack *) let return ?new_env:(new_env=env) sigma c = (run'[@tailcall]) {ctxt with sigma; env=new_env; stack} (Ret c :: vms) in let fail ?internal:(i=true) (sigma, c) = let backtrace = if i then let p () = InternalException (Printer.pr_econstr_env env sigma (to_econstr c)) in Backtrace.push (p) ctxt.backtrace else ctxt.backtrace in (run'[@tailcall]) {ctxt with sigma; backtrace} (Fail c :: vms) in (* wrappers for return and fail to conveniently return/fail with EConstrs *) let ereturn ?new_env s fc = return ?new_env:new_env s (of_econstr fc) in let efail ?internal (sigma, fc) = fail ?internal (sigma, of_econstr fc) in (* (* repetition :( *) *) (* let return sigma c = (run'[@tailcall]) {ctxt with sigma} (Ret c :: vms) in *) (* let fail (sigma, c) = (run'[@tailcall]) {ctxt with sigma} (Fail c :: vms) in *) (* (* wrappers for return and fail to conveniently return/fail with EConstrs *) *) (* let ereturn s fc = return s (of_econstr fc) in *) (* let efail (sigma, fc) = fail (sigma, of_econstr fc) in *) (* Array.iter (fun x -> print_constr sigma ctxt.env (to_econstr x)) args; *) match mc with | MConstr (Mret, (_, t)) -> return sigma t | MConstr (Mbind, (_, _, t, f)) -> (run'[@tailcall]) ctxt (Code t :: Bind (f, ctxt.backtrace) :: vms) | MConstr (Mmtry', (_, t, f)) -> (run'[@tailcall]) ctxt (Code t :: Try (sigma, stack, ctxt.backtrace, f) :: vms) | MConstr (Mraise', (_, t)) -> fail ~internal:false (sigma, t) | MConstr (Mfix1, ((a), b, f, (x))) -> (run_fix[@tailcall]) ctxt vms hf [|a|] b f [|x|] | MConstr (Mfix2, ((a1, a2), b, f, (x1, x2))) -> (run_fix[@tailcall]) ctxt vms hf [|a1; a2|] b f [|x1; x2|] | MConstr (Mfix3, ((a1, a2, a3), b, f, (x1, x2, x3))) -> (run_fix[@tailcall]) ctxt vms hf [|a1; a2; a3|] b f [|x1; x2; x3|] | MConstr (Mfix4, ((a1, a2, a3, a4), b, f, (x1, x2, x3, x4))) -> (run_fix[@tailcall]) ctxt vms hf [|a1; a2; a3; a4|] b f [|x1; x2; x3; x4|] | MConstr (Mfix5, ((a1, a2, a3, a4, a5), b, f, (x1, x2, x3, x4, x5))) -> (run_fix[@tailcall]) ctxt vms hf [|a1; a2; a3; a4; a5|] b f [|x1; x2; x3; x4; x5|] | MConstr (Mis_var, (_, e)) -> if isVar sigma (to_econstr e) then ereturn sigma (Lazy.force CoqBool.mkTrue) else ereturn sigma (Lazy.force CoqBool.mkFalse) | MConstr (Mnu, (a, _, s, ot, f)) -> let a = to_econstr a in let s = to_econstr s in (* print_constr sigma env s; *) begin let open MNames in match MNames.get_from_name (env, sigma) s with | AName (fresh, name) -> if (not fresh) && (Id.Set.mem name (vars_of_env env)) then efail (Exceptions.mkNameExists sigma env s) else begin match CoqOption.from_coq sigma env (to_econstr ot) with | exception CoqOption.NotAnOption -> efail (Exceptions.mkStuckTerm sigma env s) | ot -> let nu = Nu (name, ctxt.env, ctxt.backtrace) in let env = push_named (Context.Named.Declaration.of_tuple (annotR name, ot, a)) env in let backtrace = Backtrace.push (fun () -> InternalNu (name)) ctxt.backtrace in let nus = ctxt.nus + 1 in let stack = Zapp [|of_econstr (mkVar name)|] :: stack in (run'[@tailcall]) {backtrace; env; sigma; nus; stack} (Code f :: nu :: vms) end | StuckName -> efail (Exceptions.mkWrongTerm sigma env s) | InvalidName _ -> efail (Exceptions.mkInvalidName sigma env s) end | MConstr (Mnu_let, (ta, tb, tc, s, c, f)) -> let s = to_econstr s in begin let open MNames in match MNames.get_from_name (env, sigma) s with | AName (fresh, name) -> let c = to_econstr c in if (not fresh) && (Id.Set.mem name (vars_of_env env)) then efail (Exceptions.mkNameExists sigma env s) else if not (isLetIn sigma c) then efail (Exceptions.mkNotALetIn sigma env c) else begin let ta = to_econstr ta in let (_, d, dty, body) = destLetIn sigma c in let eqaty = Unicoq.Munify.unify_evar_conv TransparentState.full env sigma Conversion.CONV ta dty in let eqtypes = match eqaty with Evarsolve.Success _ -> true | _ -> false in if not eqtypes then efail (Exceptions.mkNotTheSameType sigma env ta) else let nu = Nu (name, ctxt.env, ctxt.backtrace) in let env = push_named (Context.Named.Declaration.of_tuple (annotR name, Some d, dty)) env in let var = mkVar name in let body = Vars.subst1 var body in let backtrace = Backtrace.push (fun () -> InternalNu (name)) ctxt.backtrace in let nus = ctxt.nus + 1 in let stack = Zapp [|of_econstr (mkVar name); of_econstr body|] :: stack in (run'[@tailcall]) {backtrace; env; sigma; nus; stack} (Code f :: nu :: vms) end | StuckName -> efail (Exceptions.mkWrongTerm sigma env s) | InvalidName _ -> efail (Exceptions.mkInvalidName sigma env s) end | MConstr (Mabs_fun, (a, p, x, y)) -> abs vms AbsFun ctxt a p x y 0 mkProp | MConstr (Mabs_let, (a, p, x, t, y)) -> abs vms AbsLet ctxt a p x y 0 (to_econstr t) | MConstr (Mabs_prod_type, (a, x, y)) -> (* HACK: put mkProp as returning type *) abs vms AbsProd ctxt a (of_econstr mkProp) x y 0 mkProp | MConstr (Mabs_prod_prop, (a, x, y)) -> (* HACK: put mkProp as returning type *) abs vms AbsProd ctxt a (of_econstr mkProp) x y 0 mkProp | MConstr (Mabs_fix, (a, f, t, n)) -> let n = CoqN.from_coq (env, sigma) (to_econstr n) in (* HACK: put mkProp as returning type *) abs vms AbsFix ctxt a (of_econstr mkProp) f t n mkProp | MConstr (Mget_binder_name, (_, t)) -> let t = to_econstr t in (* With the new reduction machine, there may still be casts left in t. For now, we assume there is at most one *) let t = try let (c, _, _) = destCast sigma t in c with Constr.DestKO -> t in let s = MNames.get_name (env, sigma) t in begin match s with | Some s -> return sigma (of_econstr s) | None -> efail (Exceptions.mkWrongTerm sigma env t) end | MConstr (Mremove, (_, _, x, t)) -> let x = to_econstr x in let t = to_econstr t in if isVar sigma x then if check_dependencies env sigma x t then let isnu = is_nu env sigma x ctxt.nus in let nus = if isnu then ctxt.nus-1 else ctxt.nus in let env', sigma = env_without sigma env x in (run'[@tailcall]) {ctxt with env=env'; sigma; nus} (Code (of_econstr t) :: Rem (env, isnu) :: vms) else efail (E.mkCannotRemoveVar sigma env x) else efail (E.mkNotAVar sigma env x) | MConstr (Mreplace, (_, tyB, _, x, _, t)) -> let tyB = to_econstr tyB in let x = to_econstr x in if isVar sigma x then let env', sigma = env_replacing sigma env x tyB in (run'[@tailcall]) {ctxt with env=env'; sigma} (Code t :: Rep (env) :: vms) else efail (E.mkNotAVar sigma env x) | MConstr (Mgen_evar, (ty, hyp)) -> let ty, hyp = to_econstr ty, to_econstr hyp in cvar vms ctxt ty hyp | MConstr (Mis_evar, (_, e)) -> let e = whd_evar sigma (to_econstr e) in if isEvar sigma e || (isApp sigma e && isEvar sigma (fst (destApp sigma e))) then ereturn sigma (Lazy.force CoqBool.mkTrue) else ereturn sigma (Lazy.force CoqBool.mkFalse) | MConstr (Mhash, (_, x1, x2)) -> ereturn sigma (hash env sigma (to_econstr x1) (to_econstr x2)) | MConstr (Msolve_typeclasses, _) -> let evd' = Typeclasses.resolve_typeclasses ~fail:false env sigma in ereturn evd' (Lazy.force CoqUnit.mkTT) | MConstr (Mprint, (s)) -> print sigma env (to_econstr s); ereturn sigma (Lazy.force CoqUnit.mkTT) | MConstr (Mpretty_print, (_, t)) -> let t = nf_evar sigma (to_econstr t) in let s = constr_to_string sigma env t in ereturn sigma (CoqString.to_coq s) | MConstr (Mhyps, _) -> let sigma, hyps, expected_type = let ulist, uhyp = let qs, univs = UVars.Instance.to_array univs in match qs, univs with | [||], [|ulist; uhyp|] -> ulist, uhyp | _ -> failwith ("Expected `M.hyps` to have zero qualities and two universes; found " ^ string_of_int (Array.length qs) ^ " and " ^ string_of_int (Array.length univs)) in let ulist = EInstance.make (UVars.Instance.of_array ([||], [|ulist|])) in let uhyp = EInstance.make (UVars.Instance.of_array ([||], [|uhyp|])) in let sigma, hyps = build_hypotheses ~univ_hyp:uhyp ~univ_list:ulist sigma env in let sigma, hyp_ty = UConstrBuilder.build_app ~univs:uhyp Hypotheses.hyp_builder sigma env [||] in let sigma, list_ty = UConstrBuilder.build_app ~univs:ulist CoqList.listBuilder sigma env [|hyp_ty|] in sigma, hyps, list_ty in (* Feedback.msg_debug (Printer.pr_econstr_env env sigma expected_ty); * Feedback.msg_debug (Printer.pr_econstr_env env sigma ty); * Feedback.msg_debug (Printer.pr_econstr_env env sigma hyps); *) begin match Typing.check env sigma hyps expected_type with | sigma -> (* Feedback.msg_debug (Printer.pr_econstr_env env sigma expected_ty); * Feedback.msg_debug (Printer.pr_econstr_env env sigma ty); * Feedback.msg_debug (Printer.pr_econstr_env env sigma hyps); *) return sigma (of_econstr hyps) | exception Pretype_errors.PretypeError (env, sigma, err) -> if !debug_ex then Feedback.msg_debug (Himsg.explain_pretype_error env sigma err); efail (E.mkHypsUniverseError sigma env hyps) end | MConstr (Mdestcase, (_, t)) -> let t = to_econstr t in begin match dest_Case (env, sigma) t with | Some (sigma', case) -> ereturn sigma' case | _ -> efail (E.mkNotAMatchExp sigma env t) end | MConstr (Mconstrs, (_, t)) -> let t = to_econstr t in let oval = get_Constrs (env, sigma) t in begin match oval with | Some (sigma', constrs) -> ereturn sigma' constrs | None -> efail (E.mkNotAnInductive sigma env t) end | MConstr (Mmakecase, (case)) -> begin match make_Case (env, sigma) (to_econstr case) with | (sigma', case) -> ereturn sigma' case | exception CoqList.NotAList l -> efail (E.mkNotAList sigma env l) end | MConstr (Munify, (_,_, uni, x, y, ts, tf)) -> let x, y, uni = to_econstr x, to_econstr y, to_econstr uni in begin let open UnificationStrategy in match unify None sigma env uni Conversion.CONV x y with | Evarsolve.Success sigma, _ -> (run'[@tailcall]) {ctxt with sigma = sigma} (Code ts :: vms) | _, _ -> (run'[@tailcall]) ctxt (Code tf :: vms) | exception NotAUnifStrategy u -> efail (E.mkNotAUnifStrategy sigma env u) end | MConstr (Munify_cumul, (_, uni, x, y, ts, tf)) -> let x, y, uni = to_econstr x, to_econstr y, to_econstr uni in begin let open UnificationStrategy in let r = unify None sigma env uni Conversion.CUMUL x y in match r with | Evarsolve.Success sigma, _ -> let id = EConstr.mkLambda(anonR,x,mkRel 1) in let ts = of_econstr (EConstr.mkApp (to_econstr ts, [|id|])) in (run'[@tailcall]) {ctxt with sigma = sigma} (Code ts :: vms) | _, _ -> (run'[@tailcall]) ctxt (Code tf :: vms) | exception NotAUnifStrategy u -> efail (E.mkNotAUnifStrategy sigma env u) end | MConstr (Mget_reference, s) -> let s = CoqString.from_coq (env, sigma) (to_econstr s) in let open Nametab in let open Libnames in begin match Evd.fresh_global env sigma (locate (qualid_of_string s)) with | (sigma, v) -> let ty = Retyping.get_type_of env sigma v in let sigma, dyn = mkDyn ty v sigma env in ereturn sigma dyn | exception _ -> efail (Exceptions.mkRefNotFound sigma env s) end | MConstr (Mget_var, s) -> let s = CoqString.from_coq (env, sigma) (to_econstr s) in let open Context.Named in begin match lookup (Id.of_string s) (named_context env) with | var -> let sigma, dyn = mkDyn (Declaration.get_type var) (mkVar (Declaration.get_id var)) sigma env in ereturn sigma dyn | exception _ -> efail (Exceptions.mkRefNotFound sigma env s) end | MConstr (Mcall_ltac, (sort, concl, name, args)) -> let open Tacinterp in let open Tacexpr in let open Loc in let open Names in let concl, name, args = to_econstr concl, to_econstr name, to_econstr args in let name, args = CoqString.from_coq (env, sigma) name, CoqList.from_coq sigma env args in let args = List.map (CoqSig.from_coq (env, sigma)) args in let tac_name = Tacenv.locate_tactic (Libnames.qualid_of_string name) in let arg_name = "lx_" in let args = List.mapi (fun i a->(Id.of_string (arg_name ^ string_of_int i), Value.of_constr a)) args in let args_var = List.map (fun (n, _) -> Reference (Locus.ArgVar (CAst.make n))) args in let to_call = CAst.make (TacArg (TacCall (CAst.make (Locus.ArgArg (tag tac_name), args_var)))) in begin let undef = Evar.Map.domain (Evd.undefined_map sigma) in let args_map = List.fold_left (fun m (k, v)-> Id.Map.add k v m) Id.Map.empty args in let ist = { (default_ist ()) with lfun = args_map } in let name, poly = Id.of_string "mtac2", false in match Proof.refine_by_tactic ~name ~poly env sigma concl (Tacinterp.eval_tactic_ist ist to_call) with | (c, sigma) -> let new_undef = Evar.Set.diff (Evar.Map.domain (Evd.undefined_map sigma)) undef in let new_undef = Evar.Set.elements new_undef in let sigma, goal = Goal.mkgoal ~base:false sigma env in let sigma, listg = CoqList.mkType sigma env goal in let sigma, goals = CoqList.pto_coq env goal (fun e sigma->Goal.goal_of_evar ~base:false env sigma e) new_undef sigma in let sigma, pair = CoqPair.mkPair sigma env concl listg c goals in (ereturn[@tailcall]) sigma pair | exception CErrors.UserError ppm -> let expl = string_of_ppcmds ppm in efail (Exceptions.mkLtacError sigma env expl) | exception e -> efail (Exceptions.mkLtacError sigma env (Printexc.to_string e)) end | MConstr (Mlist_ltac, _) -> let aux k _ = Feedback.msg_info (Pp.str (Names.KerName.to_string k)) in KNmap.iter aux (Tacenv.ltac_entries ()); ereturn sigma (Lazy.force CoqUnit.mkTT) | MConstr (Mread_line, _) -> ereturn sigma (CoqString.to_coq (read_line ())) | MConstr (Mdecompose, (_, t)) -> let (h, args) = decompose_app_list sigma (to_econstr t) in let sigma, dyn = mkdyn sigma env in let sigma, listdyn = CoqList.mkType sigma env dyn in let sigma, dh = mkDyn (Retyping.get_type_of env sigma h) h sigma env in let sigma, args = CoqList.pto_coq env dyn (fun t sigma->mkDyn (Retyping.get_type_of env sigma t) t sigma env) args sigma in let sigma, pair =CoqPair.mkPair sigma env dyn listdyn dh args in ereturn sigma pair | MConstr (Msolve_typeclass, (ty)) -> let ty = to_econstr ty in begin match Typeclasses.resolve_one_typeclass ~unique:false env sigma ty with | (sigma, v) -> let sigma, some = (CoqOption.mkSome sigma env ty v) in ereturn sigma some | exception Not_found -> let sigma, none = (CoqOption.mkNone sigma env ty) in ereturn sigma none end | MConstr (Mdeclare, (kind, name, opaque, ty, bod)) -> let kind, name, opaque, ty, bod = to_econstr kind, to_econstr name, to_econstr opaque, to_econstr ty, to_econstr bod in (match run_declare_def env sigma kind name (CoqBool.from_coq sigma opaque) ty bod with | (sigma, env, ret) -> ereturn ~new_env:env sigma (of_constr ret) | exception DeclareUniv.AlreadyDeclared _ -> efail (E.mkAlreadyDeclared sigma env name) | exception Type_errors.TypeError(env, Type_errors.UnboundVar v) -> efail (E.mkTypeErrorUnboundVar sigma env (mkVar v)) ) | MConstr (Mdeclare_implicits, (t, reference, impls)) -> let reference, impls = to_econstr reference, to_econstr impls in let reference_t = EConstr.Unsafe.to_constr reference in (match run_declare_implicits env sigma reference_t impls with | (sigma, ret) -> ereturn sigma (Lazy.force ret) | exception Not_found -> efail (E.mkNotAReference sigma env (to_econstr t) reference) ) | MConstr (Mos_cmd, (cmd)) -> let cmd = CoqString.from_coq (env, sigma) (to_econstr cmd) in let ret = Sys.command cmd in ereturn sigma (CoqZ.to_coq ret) | MConstr (Mget_debug_exceptions, _) -> ereturn sigma (CoqBool.to_coq !debug_ex) | MConstr (Mset_debug_exceptions, b) -> debug_ex := CoqBool.from_coq sigma (to_econstr b); ereturn sigma (Lazy.force CoqUnit.mkTT) | MConstr (Mget_trace, _) -> ereturn sigma (CoqBool.to_coq !trace) | MConstr (Mset_trace, b) -> trace := CoqBool.from_coq sigma (to_econstr b); ereturn sigma (Lazy.force CoqUnit.mkTT) | MConstr (Mdecompose_app', (_, _, _, uni, t, c, cont_success, cont_failure)) -> (* : A B m uni a C cont *) (* we eta-reduce both [c] and [t]. Since Coq will happily eta-expand things more or less randomly, it makes sense to undo this before we attempt a syntactic pattern matching. *) let t = Termops.eta_reduce_head sigma (to_econstr t) in let c = Termops.eta_reduce_head sigma (to_econstr c) in let (t_head, t_args) = decompose_app_list sigma t in let (c_head, c_args) = decompose_app_list sigma c in (* We need to be careful about primitive projections. In particular, we always need to unify parameters *if* the pattern contains them. There are several situations to consider that involve primitive projections: 1. [c_head] is a primitive projection but [t_head] isn't 2. [t_head] is a primitive projection but [c_head] isn't 3. Both are primitive projections *) let (c_head, c_args), (t_head, t_args) = match (isProj sigma c_head, isProj sigma t_head) with | (false, false) -> (* nothing to do *) (c_head, c_args), (t_head, t_args) | (true, false) -> (* In this case, the record value must be part of the left-hand side of the pattern * i.e. [pattern = proj r | ...]. (Otherwise the pattern could not be a primitive projection.) If we know that [t_head] is the folded version of [c_head] we can simply unify the record values. Otherwise it could be literally anything. In that case, we expand [c_head]. *) let c_proj, _, c_rval = destProj sigma c_head in let c_constant = (Projection.constant c_proj) in if isConstant sigma env c_constant t_head then let n_params = Structures.Structure.projection_nparams c_constant in let _t_params, t_args = List.chop n_params t_args in (t_head, c_rval :: c_args), (t_head, t_args) else let c = Retyping.expand_projection env sigma c_proj c_rval c_args in let c_head, c_args = decompose_app_list sigma c in (c_head, c_args), (t_head, t_args) | (false, true) -> (* Trying to be clever about this case, too. There is a clever version of this case: If [c_head] is the folded version of [t_head] and [c_args] contains the record value (i.e. [pattern = folded_proj ... r | ]) we can avoid expanding [t] by dropping [n_params] arguments from [c_args]. However, this breaks the requirement that if the pattern mentions the parameters we should unify them. Thus, we always expand in this case. *) let t_proj, _, t_rval = destProj sigma t_head in (* Code for clever version: * let t_constant = (Projection.constant t_proj) in * let n_params = Recordops.find_projection_nparams (GlobRef.ConstRef t_constant) in * if isConstant sigma t_constant c_head && List.length c_args > n_params then * let _c_params, c_args = List.chop n_params c_args in * (\* we use [c_head] on both sides to make sure they are considered equal *\) * (c_head, c_args), (c_head, t_args) * else *) let t = Retyping.expand_projection env sigma t_proj t_rval t_args in let t_head, t_args = decompose_app_list sigma t in (c_head, c_args), (t_head, t_args) | (true, true) -> let (c_proj, _, c_rval) = destProj sigma c_head in let (t_proj, _, t_rval) = destProj sigma t_head in if QProjection.equal env c_proj t_proj then (* we use [c_head] on both sides to make sure they are considered equal *) (c_head, c_rval :: c_args), (c_head, t_rval :: t_args) else (* no way to succeed anyway but we'll leave that to [eq_constr_nounivs] below *) (c_head, c_args), (t_head, t_args) in let fail () = (run'[@tailcall]) ctxt (upd cont_failure) in if eq_constr_nounivs sigma t_head c_head then let uni = to_econstr uni in let t_args_uni, t_args_rem = List.chop (List.length c_args) t_args in let to_unify = List.combine (c_head :: c_args) (t_head :: t_args_uni) in let rec uni_and_go = function | [] -> let t_args_rem = List.map of_econstr t_args_rem in (run'[@tailcall]) {ctxt with sigma = sigma; stack=Zapp (Array.of_list t_args_rem) :: stack} (upd cont_success) | ((c,t)::ls) -> let (unires, _) = UnificationStrategy.unify None sigma env uni (Conversion.CONV) c t in match unires with | Evarsolve.Success (sigma) -> (uni_and_go[@tailcall]) ls | Evarsolve.UnifFailure _ -> (* efail (E.mkWrongTerm sigma env c_head) *) (fail[@tailcall]) () in (uni_and_go[@tailcall]) to_unify else (fail[@tailcall]) () | MConstr (Mdecompose_forallT, (_, t, cont_success, cont_failure)) -> let t = to_econstr t in begin match EConstr.destProd sigma t with | (n, a, b) -> let b = EConstr.mkLambda (n, a, b) in let (a, b) = (of_econstr a, of_econstr b) in (run'[@tailcall]) {ctxt with stack=Zapp [|a; b|] :: stack} (upd cont_success) | exception Constr.DestKO -> (run'[@tailcall]) ctxt (upd cont_failure) end | MConstr (Mdecompose_forallP, (_, t, cont_success, cont_failure)) -> let t = to_econstr t in begin match EConstr.destProd sigma t with | (n, a, b) -> let b = EConstr.mkLambda (n, a, b) in let (a, b) = (of_econstr a, of_econstr b) in (* (run'[@tailcall]) {ctxt with sigma = sigma; stack=Zapp [|a; b|] :: stack} (upd cont) | exception Constr.DestKO -> efail (E.mkNotAForall sigma env t) *) (run'[@tailcall]) {ctxt with stack=Zapp [|a; b|] :: stack} (upd cont_success) | exception Constr.DestKO -> (run'[@tailcall]) ctxt (upd cont_failure) end | MConstr (Mdecompose_app'', (_, _, t, cont)) -> let t = to_econstr t in begin match EConstr.destApp sigma t with | (h, args) -> let args, arg = Array.chop (Array.length args - 1) args in let h = EConstr.mkApp (h, args) in let arg = arg.(0) in let h_type = Retyping.get_type_of env sigma h in (* let arg_type = Retyping.get_type_of env sigma arg in let (h_type, arg_type, h, arg) = (of_econstr h_type, of_econstr arg_type, of_econstr h, of_econstr arg) in (run'[@tailcall]) {ctxt with sigma = sigma; stack=Zapp [|h_type; arg_type; h; arg|] :: stack} (upd cont) | exception Constr.DestKO -> *) let h_type = ReductionStrategy.whdfun RedFlags.all env sigma (of_econstr (h_type)) in let h_typefun = to_lambda sigma 1 (EConstr.of_constr h_type) in let arg_type = (match EConstr.destLambda sigma h_typefun with | (_, ty, _) -> ty) in let (h_type, arg_type, h, arg) = (of_econstr h_typefun, of_econstr arg_type, of_econstr h, of_econstr arg) in (run'[@tailcall]) {ctxt with sigma = sigma; stack=Zapp [|arg_type; h_type; h; arg|] :: stack} (upd cont) | exception Constr.DestKO -> efail (E.mkNotAnApplication sigma env t) end | MConstr (Mnew_timer, (_, t_arg)) -> let t_arg = to_econstr t_arg in let name, _ = destConst sigma t_arg in let fname = Constant.canonical name in let last = None in let () = Hashtbl.add timers fname ((ref last, ref 0.0)) in ereturn sigma (Lazy.force CoqUnit.mkTT) | MConstr (Mstart_timer, (_, t_arg, reset)) -> let reset = CoqBool.from_coq sigma (to_econstr reset) in let t_arg = to_econstr t_arg in let name, _ = destConst sigma t_arg in let fname = Constant.canonical name in begin match Hashtbl.find timers fname with | t -> let () = fst t := Some (System.get_time ()) in if reset then snd t := 0.0; ereturn sigma (Lazy.force CoqUnit.mkTT) | exception Not_found -> ereturn sigma (Lazy.force CoqUnit.mkTT) end | MConstr (Mstop_timer, (_, t_arg)) -> let t_arg = to_econstr t_arg in let name, _ = destConst sigma t_arg in let fname = Constant.canonical name in begin match Hashtbl.find timers fname with | t -> let (last, total) = (! (fst t)), (! (snd t)) in begin match last with | Some last -> let time = System.get_time () in snd t := total +. (System.time_difference last time) | None -> snd t := -.infinity end; ereturn sigma (Lazy.force CoqUnit.mkTT) | exception Not_found -> ereturn sigma (Lazy.force CoqUnit.mkTT) end | MConstr (Mreset_timer, (_, t_arg)) -> let t_arg = to_econstr t_arg in let name, _ = destConst sigma t_arg in let fname = Constant.canonical name in let t = Hashtbl.find timers fname in let () = fst t := None in let () = snd t := 0.0 in ereturn sigma (Lazy.force CoqUnit.mkTT) | MConstr (Mprint_timer, (_, t_arg)) -> let t_arg = to_econstr t_arg in let name, _ = destConst sigma t_arg in let fname = Constant.canonical name in let t = Hashtbl.find timers fname in let total = !(snd t) in let () = Feedback.msg_info (Pp.str (Printf.sprintf "%f" total)) in ereturn sigma (Lazy.force CoqUnit.mkTT) | MConstr (Mkind_of_term, (_, t)) -> ereturn sigma (koft sigma (CClosure.term_of_fconstr t)) | MConstr (Mdeclare_mind, (params, inds, constrs)) -> let sigma, types = declare_mind env sigma (to_econstr params) (to_econstr inds) (to_econstr constrs) in ereturn sigma (Lazy.force types) | MConstr (Mexisting_instance, (name, prio, global)) -> let global = CoqBool.from_coq sigma (to_econstr global) in let name = CoqString.from_coq (env, sigma) (to_econstr name) in let path = Libnames.path_of_string name in let qualid = Libnames.qualid_of_path path in let prio = CoqOption.from_coq sigma env (to_econstr prio) in let open Typeclasses in let hint_priority = Option.map (CoqN.from_coq (env, sigma)) prio in let global = if global then Hints.SuperGlobal else Hints.Local in Classes.existing_instance global (Nametab.locate qualid) (Some {hint_priority; hint_pattern= None}); ereturn sigma ((Lazy.force CoqUnit.mkTT)) | MConstr (Minstantiate_evar, (ty, _, evar, solution, succ, fail)) -> let evar = to_econstr evar in begin match destEvar sigma evar with | exception DestKO -> let ty = to_econstr ty in efail (E.mkNotAnEvar sigma env ty evar) | (evar, x) -> let solution = to_econstr solution in let open Unicoq.Munify in let options = current_options () in let options = ref { options with inst_unify_types = false; inst_beta_reduce_type = false; } in match Unicoq.Munify.instantiate ~options env ((evar, x), []) solution sigma with | Evarsolve.Success sigma -> (* let sigma = Typing.check env sigma solution (to_econstr ty) in *) (run'[@tailcall]) {ctxt with sigma = sigma} (Code succ :: vms) | Evarsolve.UnifFailure _ -> (run'[@tailcall]) {ctxt with sigma = sigma} (Code fail :: vms) end (* h is the mfix operator, a is an array of types of the arguments, b is the return type of the fixpoint, f is the function and x its arguments. *) and run_fix ctxt (vms: vm list) (h: fconstr) (a: fconstr array) (b: fconstr) (f: fconstr) (x: fconstr array) = (* (run'[@tailcall]) {ctxt with stack=Zapp (Array.append [|mk_red (FApp (h, Array.append a [|f|]))|] x)::ctxt.stack} (Code f :: vms) *) (* Feedback.msg_notice(Pp.str "run_fix"); *) (run'[@tailcall]) {ctxt with stack=Zapp (Array.append [|mk_red (FApp (h, Array.append a [|b;f|]))|] x)::ctxt.stack} (Code f :: vms) (* abs case env a p x y n abstract variable x from term y according to the case. if variables depending on x appear in y or the type p, it fails. n is for fixpoint and t for a let-binder. *) and abs vms case ctxt a p x y n t : data_stack = let sigma, env = ctxt.sigma, ctxt.env in let a, p, x, y = to_econstr a, to_econstr p, to_econstr x, to_econstr y in let a = nf_evar sigma a in let p = nf_evar sigma p in let x = nf_evar sigma x in let y = nf_evar sigma y in (* check if the type p does not depend of x, and that no variable created after x depends on it. otherwise, we will have to substitute the context, which is impossible *) if isVar sigma x then let name = destVar sigma x in let odef = let n = Environ.lookup_named name env in Context.Named.Declaration.get_value n in if case <> AbsLet && odef <> None then let (sigma, e) = E.mkAbsVariableIsADefinition sigma env x in (run'[@tailcall]) {ctxt with sigma} (Fail (of_econstr e) :: vms) else if check_abs_deps env sigma x y p then let y' = Vars.subst_vars sigma [name] y in let run t = (run'[@tailcall]) ctxt (Ret (of_econstr t) :: vms) in match case with | AbsProd -> (run[@tailcall]) (mkProd (nameR name, a, y')) | AbsFun -> (run[@tailcall]) (mkLambda (nameR name, a, y')) | AbsLet -> begin let letin = mkLetIn (nameR name, t, a, y') in match odef with | None -> run letin | Some d -> if is_conv env sigma (of_constr d) t then (run[@tailcall]) letin else let (sigma, e) = E.mkAbsLetNotConvertible sigma env t in (run'[@tailcall]) {ctxt with sigma} (Fail (of_econstr e) :: vms) end | AbsFix -> (run[@tailcall]) (mkFix (([|n-1|], 0), ([|nameR name|], [|a|], [|y'|]))) else let (sigma, e) = E.mkAbsDependencyError sigma env (mkApp(x,[|y;p|])) in (run'[@tailcall]) {ctxt with sigma} (Fail (of_econstr e) :: vms) else let (sigma, e) = E.mkNotAVar sigma env x in (run'[@tailcall]) {ctxt with sigma} (Fail (of_econstr e) :: vms) and cvar vms ctxt ty ohyps = let env, sigma = ctxt.env, ctxt.sigma in let ohyps = CoqOption.from_coq sigma env ohyps in if Option.has_some ohyps then let chyps = Option.get ohyps in let ovars = try let hyps = Hypotheses.from_coq_list (env, sigma) chyps in Some (List.map (fun (v, _, _)->v) hyps, hyps) with Hypotheses.NotAVariable -> None in let fail (sigma, c) = (run'[@tailcall]) {ctxt with sigma} (Fail (of_econstr c) :: vms) in match ovars with | Some (vars, hyps) -> if List.distinct vars then let value = try let subs, env = new_env (env, sigma) hyps in let ty = multi_subst sigma subs ty in let sigma, evar = make_evar sigma env ty in let (e, _) = destEvar sigma evar in (* the evar created by make_evar has id in the substitution but we need to remap it to the actual variables in hyps *) `OK (sigma, mkLEvar sigma (e, vars)) with | MissingDep -> `MDep | Not_found -> `NFound in match value with | `OK (sigma, c) -> (run'[@tailcall]) {ctxt with sigma} (Ret (of_econstr c) :: vms) | `MDep -> fail (E.mkHypMissesDependency sigma env chyps) | `NFound -> fail (E.mkTypeMissesDependency sigma env chyps) else fail (E.mkDuplicatedVariable sigma env chyps) | None -> fail (E.mkNotAVar sigma env chyps) else let sigma, evar = make_evar sigma env ty in (run'[@tailcall]) {ctxt with sigma} (Ret (of_econstr evar) :: vms) (* returns the enviornment and substitution without db rels *) let db_to_named sigma env = let open Context in let env' = push_named_context (named_context env) (reset_context env) in let vars = Named.to_vars (named_context env) in let _, subs, env = CList.fold_right_i (fun n var (vars, subs, env') -> (* the definition might refer to previously defined indices so we perform the substitution *) let (name, odef, ty) = Rel.Declaration.to_tuple var in let odef = Option.map (multi_subst sigma subs) odef in let ty = multi_subst sigma subs ty in (* since the name can be Anonymous, we need to generate a name *) let id = map_annot (function | Anonymous -> Id.of_string ("_MC" ^ string_of_int n) | Name n -> Namegen.next_ident_away n vars) name in let nvar = Named.Declaration.of_tuple (id, odef, ty) in Id.Set.add id.binder_name vars, (n, mkVar id.binder_name) :: subs, push_named nvar env' ) 1 (rel_context env) (vars, [], env') in subs, env (* It replaces each ci by ii in l = [(i1,c1) ... (in, cn)] in c. *) let multi_subst_inv sigma l c = let l = List.map (fun (a, b) -> (b, a)) l in let rec substrec depth c = begin try let n = destVar sigma c in begin try mkRel (List.assoc (mkVar n) l + depth) with Not_found -> mkVar n end with Constr.DestKO -> map_with_binders sigma succ substrec depth c end in substrec 0 c let run (env0, sigma) ty t : data = let subs, env = db_to_named sigma env0 in let t = multi_subst sigma subs t in let t = CClosure.inject (EConstr.Unsafe.to_constr t) in (* ty is of the form [M X] or a term reducible to that. *) (* we only need [X]. *) (* Feedback.msg_info (Printer.pr_econstr_env env sigma ty); *) let ty = EConstr.of_constr (RE.whd_betadeltaiota env sigma (of_econstr ty)) in (* Feedback.msg_info (Printer.pr_econstr_env env sigma ty); *) let _, ty = decompose_app sigma ty in assert (Array.length ty == 1); match run' {env; sigma; nus=0; stack=CClosure.empty_stack; backtrace=[]} [Code t] with | Err (sigma', v, _, backtrace) -> (* let v = Vars.replace_vars vsubs v in *) let v = multi_subst_inv sigma' subs (to_econstr v) in let (ground, (sigma, v)) = check_exception sigma' sigma' env0 v in (* No need to log anything if the exception is ground. *) let backtrace = if ground then backtrace else Backtrace.push ( fun () -> InternalException (Printer.pr_econstr_env env (sigma) v) ) backtrace in Err ((sigma, v), backtrace) | Val (sigma', v, stack, tr) -> assert (List.is_empty stack); let v = multi_subst_inv sigma' subs (to_econstr v) in (* let sigma' = Typing.check env sigma' v ty in *) (* let sigma', _ = Typing.type_of env0 sigma' v in *) Val (sigma', v) (** set the run function in unicoq *) let _ = let lift_constr = ref None in Unicoq.Munify.set_lift_constr (fun env sigma -> match !lift_constr with | None -> let lc = snd (mkUConstr "Lift.lift" sigma env) in lift_constr := Some lc; sigma, lc | Some lc -> sigma, lc) let _ = Unicoq.Munify.set_run (fun env sigma t -> let ty = Retyping.get_type_of env sigma t in match run (env, sigma) ty t with | Err _ -> None | Val c -> Some c) Mtac2-1.4-coq8.20/src/run.mli000066400000000000000000000030421472011217100155050ustar00rootroot00000000000000open Environ open Evd open EConstr type backtrace val pr_backtrace : backtrace -> Pp.t type elem_stack = (Evd.evar_map * CClosure.fconstr * CClosure.stack * backtrace) type elem = (evar_map * constr) type data_stack = | Val of elem_stack | Err of elem_stack type data = | Val of elem | Err of elem * backtrace val make_evar : evar_map -> env -> constr -> evar_map * constr (* used in metaCoqInterp *) val run : (env * evar_map) -> constr -> etypes -> data module Goal : sig val mkTheGoal : ?base:bool -> types -> constr -> Evd.evar_map -> Environ.env -> (Evd.evar_map * constr) val evar_of_goal : Evd.evar_map -> Environ.env -> constr -> Evar.t option end (** DEBUG **) type ctxt = { env: Environ.env; sigma: Evd.evar_map; nus: int; stack: CClosure.stack; backtrace: backtrace; } type vm = Code of CClosure.fconstr | Ret of CClosure.fconstr | Fail of CClosure.fconstr | Bind of (CClosure.fconstr * backtrace) | Try of (Evd.evar_map * CClosure.stack * backtrace * CClosure.fconstr) | Nu of (Names.Id.t * Environ.env * backtrace) | Rem of (Environ.env * bool) | Rep of (Environ.env) (* val run_fix : ctxt -> vm list -> CClosure.fconstr -> CClosure.fconstr array -> CClosure.fconstr -> CClosure.fconstr -> CClosure.fconstr array *) val run' : ctxt -> vm list -> data_stack val multi_subst : evar_map -> (int * constr) list -> constr -> constr module Hypotheses : sig val from_coq_list : (Environ.env * Evd.evar_map) -> constr -> (constr * constr option * constr) list end Mtac2-1.4-coq8.20/tests/000077500000000000000000000000001472011217100145525ustar00rootroot00000000000000Mtac2-1.4-coq8.20/tests/ConstrSelector.v000066400000000000000000000125451472011217100177210ustar00rootroot00000000000000From Mtac2 Require Import Datatypes List Mtac2 ConstrSelector. Import T. Import Mtac2.lib.List.ListNotations. Eval compute in M.eval (index 0). Eval compute in M.eval (index S). Eval compute in M.eval (index eq_refl). Eval compute in M.eval (index nil). Eval compute in M.eval (index (@cons _)). Goal forall b, orb b (negb b) = true. MProof. destructn 0 &> case true do reflexivity. reflexivity. Qed. Definition elim0 : tactic := gT <- goal_type; A <- M.evar Type; intro_base (FreshFrom gT) (fun x:A=>elim x). Definition rrewrite {A} (x: A) := trewrite RightRewrite [m:Dyn x]%list. Definition lrewrite {A} (x: A) := trewrite LeftRewrite [m:Dyn x]%list. Goal forall n, n + 0 = n. MProof. elim0 &> case 0 do reflexivity. intros &> simpl. select (_ = _) >>= rrewrite ;; reflexivity. Qed. Goal forall n, n + 0 = n. MProof. elim0 &> simpl &> case 0, S do intros &> try reflexivity. select (_ = _) >>= rrewrite ;; reflexivity. Qed. Require Import Coq.Arith.Arith. Require Import Coq.Arith.EqNat. Inductive id : Type := | Id : nat -> id. Definition total_map (A:Type) := id -> A. Definition beq_id id1 id2 := match id1,id2 with | Id n1, Id n2 => Nat.eqb n1 n2 end. Definition t_update {A:Type} (m : total_map A) (x : id) (v : A) := fun x' => if beq_id x x' then v else m x'. Definition state := total_map nat. Inductive aexp : Type := | ANum : nat -> aexp | AId : id -> aexp (* <----- NEW *) | APlus : aexp -> aexp -> aexp | AMinus : aexp -> aexp -> aexp | AMult : aexp -> aexp -> aexp. Inductive bexp : Type := | BTrue : bexp | BFalse : bexp | BEq : aexp -> aexp -> bexp | BLe : aexp -> aexp -> bexp | BNot : bexp -> bexp | BAnd : bexp -> bexp -> bexp. Fixpoint aeval (st : state) (a : aexp) : nat := match a with | ANum n => n | AId x => st x (* <----- NEW *) | APlus a1 a2 => (aeval st a1) + (aeval st a2) | AMinus a1 a2 => (aeval st a1) - (aeval st a2) | AMult a1 a2 => (aeval st a1) * (aeval st a2) end. Fixpoint beval (st : state) (b : bexp) : bool := match b with | BTrue => true | BFalse => false | BEq a1 a2 => Nat.eqb (aeval st a1) (aeval st a2) | BLe a1 a2 => leb (aeval st a1) (aeval st a2) | BNot b1 => negb (beval st b1) | BAnd b1 b2 => andb (beval st b1) (beval st b2) end. Definition bequiv (b1 b2 : bexp) : Prop := forall (st:state), beval st b1 = beval st b2. Reserved Notation "c1 '/' st '\\' st'" (at level 40, st at level 39). Inductive com : Type := | CSkip : com | CBreak : com (* <-- new *) | CAss : id -> aexp -> com | CSeq : com -> com -> com | CIf : bexp -> com -> com -> com | CWhile : bexp -> com -> com. Notation "'SKIP'" := CSkip. Notation "x '::=' a" := (CAss x a) (at level 60). Notation "c1 ;;; c2" := (CSeq c1 c2) (at level 80, right associativity). Notation "'WHILE' b 'DO' c 'END'" := (CWhile b c) (at level 80, right associativity). Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" := (CIf c1 c2 c3) (at level 80, right associativity). Inductive ceval : com -> state -> state -> Prop := | E_Skip : forall st, SKIP / st \\ st | E_Ass : forall st a1 n x, aeval st a1 = n -> (x ::= a1) / st \\ (t_update st x n) | E_Seq : forall c1 c2 st st' st'', c1 / st \\ st' -> c2 / st' \\ st'' -> (c1 ;;; c2) / st \\ st'' | E_IfTrue : forall st st' b c1 c2, beval st b = true -> c1 / st \\ st' -> (IFB b THEN c1 ELSE c2 FI) / st \\ st' | E_IfFalse : forall st st' b c1 c2, beval st b = false -> c2 / st \\ st' -> (IFB b THEN c1 ELSE c2 FI) / st \\ st' | E_WhileEnd : forall b st c, beval st b = false -> (WHILE b DO c END) / st \\ st | E_WhileLoop : forall st st' st'' b c, beval st b = true -> c / st \\ st' -> (WHILE b DO c END) / st' \\ st'' -> (WHILE b DO c END) / st \\ st'' where "c1 '/' st '\\' st'" := (ceval c1 st st'). Require Import Strings.String. Definition remember {A} (x:A) (def eq : string) : tactic := cpose_base (TheName def) x (fun y:A=> cassert_base (TheName eq) (fun H: y = x =>lrewrite H) |1> reflexivity). Lemma WHILE_true_nonterm : forall b c st st', bequiv b BTrue -> ~( (WHILE b DO c END) / st \\ st' ). MProof. intros b c. remember (WHILE b DO c END) "cw" "Heqcw". intros st st' eqT H. induction H &> case E_Skip, E_Ass, E_IfTrue, E_IfFalse, E_Seq do discriminate. - (* E_WhileEnd *) (* contradictory -- b is always true! *) inversion Heqcw. subst. select (bequiv _ _) >>= unfold_in bequiv. move_back H. simpl. select (forall x:_, _) >>= rrewrite. simpl. discriminate. - (* E_WhileLoop *) (* immediate from the IH *) select (WHILE _ DO _ END = _ -> _) >>= apply. assumption. Qed. Lemma WHILE_true_nonterm' : forall b c st st', bequiv b BTrue -> ~( (WHILE b DO c END) / st \\ st' ). MProof. intros b c. remember (WHILE b DO c END) "cw" "Heqcw". intros st st' eqT H. induction H &> except E_WhileEnd, E_WhileLoop do discriminate. - (* E_WhileEnd *) (* contradictory -- b is always true! *) inversion Heqcw. subst. select (bequiv _ _) >>= unfold_in bequiv. move_back H. simpl. select (forall x:_, _) >>= rrewrite. simpl. discriminate. - (* E_WhileLoop *) (* immediate from the IH *) select (WHILE _ DO _ END = _ -> _) >>= apply. assumption. Qed. Mtac2-1.4-coq8.20/tests/DepDestruct.v000066400000000000000000000177541472011217100172050ustar00rootroot00000000000000From Mtac2 Require Import Datatypes List Mtac2 DepDestruct Sorts MTeleMatch. Import Sorts.S. Import T. Import Mtac2.lib.List.ListNotations. Unset Universe Minimization ToSet. Goal forall n, 0 <= n. MProof. intros n. new_destruct n. Abort. Section Bugs. (** BUG: It used to fail with one constructor types, but not with two *) Inductive one_constr : Prop := | the_one_constr : one_constr . Goal one_constr -> True. MProof. intros t. new_destruct t. Abort. Inductive two_constrs : Prop := | first_constr : two_constrs | second_constr : two_constrs . Goal two_constrs -> True. MProof. intros t. new_destruct t. - trivial. - trivial. Qed. Unset Unicoq Debug. End Bugs. (* The 2nd new_destruct used to fail. *) Goal forall n, n = S n -> False. MProof. intros n H. Fail new_destruct H. (* fine, all indices need to be var *) pose (j := S n). assert (eq : j = S n) |1> reflexivity. cmove_back H (rewrite <- eq). intro H. (* now H has only indices *) move_back eq. Fail new_destruct H. (* FIX: failing because it's trying to abstract the definition j *) Abort. Section ExampleReflect. Inductive reflect (P :Prop) : bool -> Set := | RTrue : P -> reflect P true | RFalse : ~P -> reflect P false. Goal forall P b, reflect P b -> P <-> b = true. MProof. intros P b r. new_destruct r. - intro xP &> split &> [m:reflexivity | intros &> assumption]. - intro nxP &> split &> [m:intros &> contradiction | intros &> discriminate]. Qed. Example reflect_reflect P : ITele (Typeₛ) := iTele (fun b=>@iBase Typeₛ (reflect P b)). Example reflect_RTrue P : CTele (reflect_reflect P) := (cProd (fun p : P=>@cBase _ (reflect_reflect _) (aTele true aBase) (RTrue P p))). Example reflect_RFalse P : CTele (reflect_reflect P) := (cProd (fun p=>@cBase _ (reflect_reflect _) (aTele _ (aBase)) (RFalse P p))). Example reflect_args P b : ATele (reflect_reflect P) := aTele b aBase. Example bla P : RTele Propₛ (reflect_reflect P) := Eval simpl in (fun b=>(fun _=>P <-> b = true)). Example bla_branch P := Eval simpl in branch_of_CTele (bla P) (reflect_RTrue P). Example bla_RTele P b (r : reflect P b) : RTele _ _ := Eval compute in M.eval (abstract_goal (rsort := Propₛ) ((P <-> b = true)) (reflect_args P b) r). Example bla_goals P b r : mlist dyn := Eval compute in mmap (fun cs => Dyn (branch_of_CTele (rsort := Propₛ) (bla_RTele P b r) cs)) [m: reflect_RTrue P | reflect_RFalse P]. Example reflectP_it : ITele _ := iTele (fun P => iTele (fun b => iBase (sort := Typeₛ) (reflect P b))). Program Example reflectP_RTrue : CTele reflectP_it := cProd (fun P => cProd (fun p => (cBase (aTele _ (aTele _ aBase)) (@RTrue P p)))). Program Example reflectP_RFalse : CTele reflectP_it := cProd (fun P => cProd (fun np => (cBase (aTele _ (aTele _ aBase)) (@RFalse P np)))). Example reflectP_args P b : ATele reflectP_it := aTele P (aTele b (aBase)). Example reflect_app P b := Eval compute in ITele_App (reflect_args P b). Example blaP_RTele P b r : RTele _ _ := Eval compute in M.eval (abstract_goal (rsort := Propₛ) ((P <-> b = true)) (reflectP_args P b) r). Example blaP_goals P b r : mlist dyn := Eval compute in mmap (fun cs => Dyn (branch_of_CTele (blaP_RTele P b r) cs)) [m: reflectP_RFalse | reflectP_RTrue ]. Goal True. MProof. (\tactic g => r <- M.destcase (match 3 with 0 => true | S _ => false end); M.print_term r;; cpose r (fun r=>idtac) g). (\tactic g=> let c := reduce RedHNF r in case <- M.makecase c; cpose case (fun y=>idtac) g) : tactic. Abort. Goal forall P b, reflect P b -> P <-> b = true. Proof. intros P b r. pose (rG := (M.eval (abstract_goal (rsort := Typeₛ) (P <-> b = true) (reflect_args P b) r)) : RTele _ _). cbn delta -[RTele] in rG. assert (T : branch_of_CTele rG (reflect_RTrue P)). { now firstorder. } assert (F : branch_of_CTele rG (reflect_RFalse P)). { compute. firstorder. now discriminate. } pose (mc := M.makecase {| case_val := r; case_return := Dyn (RTele_Fun rG); case_branches := [m: Dyn T | Dyn F] |}). compute in mc. pose (c := M.eval mc). unfold M.eval in c. mrun (let c := reduce (RedOneStep [rl: RedDelta]) c in dcase c as e in exact e). Qed. Notation "'mpose' ( x := t )" := (r <- t; cpose r (fun x=>idtac)) (at level 40, x at next level). Fixpoint unfold_funs {A} (t: A) (n: nat) {struct n} : M A := match n with | 0 => M.ret t | S n' => (mtmmatch A as A' return A =m= A' -> M A' with | [? B (fty : B -> Type)] forall x, fty x =m> fun H => let t' := reduce RedSimpl match H in meq _ P return P with meq_refl => t end in (* we need to reduce this *) M.nu (FreshFrom "A") mNone (fun x=> r <- unfold_funs (t' x) n'; abs x r) | [? A'] A' =m> fun H => match H in meq _ P return M P with meq_refl => M.ret t end end) meq_refl end%MC. (* MetaCoq version *) Goal forall P b, reflect P b -> P <-> b = true. MProof. intros P b r. mpose (rG := abstract_goal (rsort := Propₛ) (P <-> b = true) (reflect_args P b) r). simpl. assert (T : branch_of_CTele rG (reflect_RTrue P)). { simpl. cintros x {- split&> [m:cintros xP {- reflexivity -} | cintros notP {- assumption -}] -}. (* it doesn't work if intros is put outside *) } assert (F : branch_of_CTele rG (reflect_RFalse P)). { simpl. intros. split. intros. a <- select (~ _); x <- select P; exact (match a x with end). intros;; discriminate. } mpose (return_type := unfold_funs (RTele_Fun rG) 5). pose (mc := M.makecase {| case_val := r; case_return := Dyn (return_type); case_branches := [m: Dyn T | Dyn F] |}). let mc := reduce RedNF mc in r <- mc; pose (c := r). clear mc. unfold_in (@branch_of_CTele) T. simpl_in T. unfold_in (@branch_of_CTele) F. simpl_in F. clear return_type. (* TODO: figure out why `unfold` above doesn't work anymore. *) (* clear rG. *) let c := reduce (RedOneStep [rl: RedDelta]) c in dcase c as c in exact c. Abort. End ExampleReflect. Set Unicoq Try Solving Eqn. Require Vector. Module VectorExample. Import Vector. Goal forall n (v : t nat n), n = Coq.Lists.List.length (to_list v). Proof. pose (it := iTele (fun n => @iBase (Typeₛ) (t nat n))). pose (vnil := ((@cBase Typeₛ it (aTele 0 aBase) (nil nat))) : CTele it). pose (vcons := (cProd (fun a => cProd (fun n => cProd (fun (v : t nat n) => (@cBase Typeₛ it (aTele (S n) aBase) (cons _ a _ v)))))) : CTele it). fix f 2. intros n v. pose (a := (aTele n (aBase)) : ATele it). pose (rt := M.eval (abstract_goal (rsort := Propₛ) (n = Coq.Lists.List.length (to_list v)) a v)). simpl in vcons. cbn beta iota zeta delta -[RTele] in rt. assert (N : branch_of_CTele rt vnil). { now auto. } assert (C : branch_of_CTele rt vcons). { intros x k v'. hnf. simpl. f_equal. exact (f _ _). } pose (mc := M.makecase {| case_val := v; case_return := Dyn (RTele_Fun rt); case_branches := [m:Dyn N | Dyn C] |} ). unfold rt in mc. simpl RTele_Fun in mc. (* pose (ma := (match v as v' in t _ k return k = length (to_list v') with *) (* | nil _ => N *) (* | cons _ a k v => C a k v *) (* end)). *) (* pose (c' := eval (destcase ma)). *) (* unfold eval in c'. *) pose (c := M.eval mc). unfold M.eval in c. mrun (let c := reduce (RedOneStep [rl: RedDelta]) c in dcase c as c in exact c). Qed. End VectorExample. Example get_reflect_ITele := Eval compute in ltac:(mrun (get_ITele (reflect True)))%MC. Example reflect_nindx := Eval compute in let (n, _) := get_reflect_ITele in n. Example reflect_sort := Eval compute in let (sort, _) := msnd get_reflect_ITele in sort. Example reflect_itele : ITele reflect_sort := Eval compute in match msnd get_reflect_ITele as pair return let (sort, _) := pair in ITele sort with | existT _ s it => it end. Mtac2-1.4-coq8.20/tests/Exhaustive.v000066400000000000000000000034531472011217100170730ustar00rootroot00000000000000Require Import Strings.String. From Mtac2 Require Import Base List Exhaustive. Import M.notations. Check (mmatch 1 with exhaustively | [#] S | n =n> M.print "S" | [#] O | =n> M.print "O" | _ => M.print "not in constructor normal form" end). (* Test a different order *) Check (mmatch 1 with exhaustively | [#] O | =n> M.print "O" | [#] S | n =n> M.print "S" | _ => M.print "not in constructor normal form" end). (* Test another order. This one makes no sense but it is exhaustive in the sense of the checker. *) Check (mmatch 1 with exhaustively | _ => M.print "always triggered first" | [#] O | =n> M.print "O, never triggered" | [#] S | n =n> M.print "S, never triggered" end). (* Forget a constructor *) Fail Check (mmatch 1 with exhaustively | [#] S | n =n> M.print "S" | _ => M.print "not in constructor normal form" end). (* Forget another constructor *) Fail Check (mmatch 1 with exhaustively | [#] O | =n> M.print "O" | _ => M.print "not in constructor normal form" end). (* Forget constructor, swap order. *) Fail Check (mmatch 1 with exhaustively | _ => M.print "not in constructor normal form" | [#] O | =n> M.print "O" end). (* Check inductive type with parameters. *) Check (mmatch cons 1 nil with exhaustively | [#] @nil _ | =n> M.print "nil" | [#] @cons _ | (a : nat) l =n> M.print "cons" | _ => M.print "not in constructor normal form" end). (* Check inductive type with parameters which we instantiate with syntactically different but convertible values. *) Check (mmatch cons 1 nil with exhaustively | [#] @nil (id nat) | =n> M.print "nil" | [#] @cons nat | a l =n> M.print "cons" | _ => M.print "not in constructor normal form" end). Mtac2-1.4-coq8.20/tests/UnivSanityCheck.v000066400000000000000000000024151472011217100200120ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Import M. Import M.notations. Print Universes "universes-mtac2.txt". Import M. Require Import Coq.Numbers.BinNums. Require Import Strings.String. Definition file := "universes-mtac2.txt". Definition magic_number := "0". (* we look for whaterever universes from Coq is < or <= than one of Mtac's *) Definition find_cmd := "egrep ""Coq.*Mtac2"" " ++ file. (* we count the lines (we get one for each pair of universes found above). we also remove spaces since in Mac Os (apparently) wc returns spaces. *) Definition count_cmd := find_cmd ++ " | wc -l | tr -d ' '". (* we test the result of the previous command to be equal to the actual number of universes we expect to be in the list. currenlty, only those from ex *) Definition assert_cmd := "[ $(" ++ count_cmd ++ ") = """ ++ magic_number ++ """ ]". Definition cmd := Eval compute in eval (print assert_cmd;; ret assert_cmd). Eval compute in eval (os_cmd count_cmd). Definition is_linux := "[ $(uname) = ""Linux"" ] ". Goal eval (os_cmd is_linux >>= fun x=>match x with | Z0 => M.print "Running test";; os_cmd cmd | _ => M.print "Not running test";; M.ret Z0 end) = Z0. reflexivity. Qed. (* erase the file created *) Goal eval (os_cmd ("rm " ++ file)) = Z0. reflexivity. Qed. Mtac2-1.4-coq8.20/tests/abs.v000066400000000000000000000061661472011217100155170ustar00rootroot00000000000000From Mtac2 Require Export Mtac2. Require Import Strings.String. Require Import Lists.List. Import ListNotations. Definition assert_eq {A} (a b : A) : M True := mmatch b with a => M.ret I | _ => M.raise exception end. (* Abstracting an index works *) Goal True. pose (code := (\nu x:nat, r <- M.abs_fun (P:=fun _ :nat=>nat) x x; assert_eq r (@id nat))%MC). mrun code. Qed. (* Abstracting the second index works too *) Goal True. mrun (\nu y:nat, \nu x:nat, r <- M.abs_fun x x; assert_eq r (@id nat))%MC. Qed. (* Abstracting the second index works too having names *) Goal forall n m:nat, True. intros. mrun (\nu y:nat, \nu x:nat, r <- M.abs_fun x x; assert_eq r (@id nat))%MC. Qed. (* Abstracting the first index works too having names *) Goal forall n m:nat, True. intros. mrun (\nu x:nat, \nu y:nat, r <- M.abs_fun x x; assert_eq r (@id nat))%MC. Qed. (* Abstracting a name works *) Goal forall n m:nat, True. intros n m. mrun (r <- M.abs_fun n n; assert_eq r (@id nat))%MC. Qed. (* Abstracting a name works with indices too *) Goal forall n m:nat, True. intros n m. mrun (\nu x:nat, \nu y :nat, r <- M.abs_fun n n; assert_eq r (@id nat))%MC. Qed. (* Abstracting an index depending on names works *) Goal forall n m:nat, True. intros n m. mrun (\nu H: n=m, r <- M.abs_fun H H; assert_eq r (@id _))%MC. Qed. (* Abstracting a name with an index depending on it works if the return value does not *) Goal forall n m:nat, True. intros n m. mrun (\nu H: n=m, r <- M.abs_fun n n; assert_eq r (@id _))%MC. Qed. (* Abstracting a name with an index depending on it does not work if the (type of the) return value depends on it *) Goal forall n m:nat, True. intros n m. mrun (mtry \nu H: n=m, r <- M.abs_fun (P:=fun n'=>n'=m) n H; M.ret I with AbsDependencyError => M.ret I end)%MC. Qed. (* No dependency in the term should raise no problem *) Goal True. mrun (\nu x:nat, r <- M.abs_fun (P:=fun _ :nat=>nat) x 0; assert_eq r (fun _=>0))%MC. Qed. (* Abstracting a term depending on the return element is fine (the other way around is the problem) *) Goal forall x, x>0 -> True. intros x H. mrun (r <- M.abs_fun (P:=fun _:x >0=>nat) H x; assert_eq r (fun _=>x))%MC. Qed. (* Evars prevent abstracting of a var *) Goal forall A (x : A), True. intros A x. mrun (mtry e <- M.evar True; r <- M.abs_fun A e; M.ret e with AbsDependencyError => M.ret I end)%MC. Qed. (* Test soundness *) Goal forall A (x y : A), x = y. intros A x y. Fail mrun (M.abs_fun (P:=fun x => x = y) y (@eq_refl _ _) >>= M.print_term;; M.evar _)%MC. Abort. Fixpoint n_ary n := match n with | 0 => True | S n' => True -> n_ary n' end. Goal let x := 1 in eq_refl = (eq_refl : n_ary x = (True -> True)). intros x. pose (t := (M.abs_fun (P:=fun y =>eq_refl = (eq_refl : n_ary y = n_ary y)) x eq_refl >>= fun f =>M.ret (f x : eq_refl = (eq_refl : n_ary x = (True -> True))))%MC). Fail (mrun t). (* it must fail, because x is a definition. otherwise, we could end up with an ill-typed term (fun y => eq_refl = (eq_refl : n_ary y = (True -> True))) *) Fail Check (fun y => eq_refl = (eq_refl : n_ary y = (True -> True))). Abort. Mtac2-1.4-coq8.20/tests/abs_prod.v000066400000000000000000000020551472011217100165340ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Goal forall x:nat, True. MProof. intro x. (aP <- M.abs_prod_type x (x <= 0:Type); mmatch aP with (forall y, y <= 0:Type) =c> M.ret _ | _ => M.failwith "Didn't work" end)%MC. Abort. Import M. Import M.notations. Goal forall x:nat, True. MProof. intro x. aP <- M.abs_prod_type x (x <= 0:Type); unify_or_fail UniCoq (forall y, y <= 0:Type) aP;; ret I. Qed. (* TODO: it fails with Unicoq, why?? *) Goal forall x:nat, True. MProof. intro x. pose (K := aP <- M.abs_prod_type x (x <= 0:Type); mmatch aP with (forall y, y <= 0):Type => M.ret I end). K. Qed. Fixpoint n_ary n := match n with | 0 => True | S n' => True -> n_ary n' end. Goal let x := 1 in Prop. intros x. pose (t := M.abs_prod_prop x (eq_refl = (eq_refl : n_ary x = (True -> True)))). Fail mrun (t >>= T.exact)%tactic. (* It should fail because otherwise it will create an ill-typed prop *) Abort. Mtac Do ( let t := forall x : nat, (fun T => T) Type in let t := reduce (RedOneStep [rl: RedBeta]) t in print_term t). Mtac2-1.4-coq8.20/tests/binders.v000066400000000000000000000032501472011217100163670ustar00rootroot00000000000000Require Import Mtac2.lib.Datatypes Mtac2.Mtac2. Example nu_new_name_works : forall x:nat, 0 <= x. MProof. M.nu (TheName "x") mNone (fun y=> M.abs_fun y (le_0_n y)). Qed. Example nu_existing_name_fails (x: nat) : forall y:nat, 0 <= y. MProof. Mtac Do Set_Debug_Exceptions. (mtry M.nu (TheName "x") mNone (fun y=>M.abs_fun y (le_0_n y)) with NameExistsInContext (TheName "x")=>M.ret _ end)%MC. Abort. Example nu_returning_x_fails (x: nat) : forall y:nat, 0 <= y. MProof. (mtry M.nu (TheName "z") mNone (fun y=>M.ret y) with VarAppearsInValue => M.ret _ end)%MC. Abort. Example fresh_nu : True. MProof. (\nu_f for (fun hopefully_unused : True => True) as (x : nat), n <- M.get_binder_name x; M.coerce (B:=n = "hopefully_unused") (@eq_refl _ n);; M.ret I )%MC. Qed. Example mirror_nu : True. MProof. (* The type of [x] and [y] is determined by the function given to [\nu_m] *) (\nu_m for (fun (hopefully_unused0 : True) (hopefully_unused1 : hopefully_unused0 = I) => True) as x y, n0 <- M.get_binder_name x; M.coerce (B:=n0 = "hopefully_unused0") (@eq_refl _ n0);; n1 <- M.get_binder_name y; M.coerce (B:=n1 = "hopefully_unused1") (@eq_refl _ n1);; M.ret I )%MC. Qed. Example mirror_nu_with_func : True. MProof. (* The type of [x] and [y] is determined by the function given to [\nu_m] *) (\nu_M for (fun (hopefully_unused0 : True) (hopefully_unused1 : hopefully_unused0 = I) => True) as x y ; f, M.unify_or_fail UniMatchNoRed f True;; n0 <- M.get_binder_name x; M.coerce (B:=n0 = "hopefully_unused0") (@eq_refl _ n0);; n1 <- M.get_binder_name y; M.coerce (B:=n1 = "hopefully_unused1") (@eq_refl _ n1);; M.ret I )%MC. Qed.Mtac2-1.4-coq8.20/tests/bug_universes.v000066400000000000000000000032161472011217100176230ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Set Universe Polymorphism. Set Printing Universes. (* Demonstrate that id indeed has the right type *) Definition test@{i j} : Type@{i} -> Type@{max(i,j)} := id. (* Demonstrate that ltac gets it right *) Lemma testL@{i j} : Type@{i} -> Type@{max(i,j)}. Proof. exact id. Qed. (* M.ret somehow works in 8.8 *) Lemma testM@{i j} : Type@{i} -> Type@{max(i,j)}. MProof. M.ret id. Qed. (* runTac works too *) Lemma testMTac@{i j} : Type@{i} -> Type@{max(i,j)}. MProof. T.exact id. Qed. (* apply doesn't generate a new universe index (it used to be the case) *) Lemma testMTacApply@{i j} : Type@{i} -> Type@{max(i,j)}. MProof. T.apply (@id). Qed. (* and ltac's 8.8 doesn't do that either *) Lemma testLApply@{i j} : Type@{i} -> Type@{max(i,j)}. Proof. apply @id. Qed. Notation "p '=e>' b" := (pbase p%core (b%core) UniEvarconv) (no associativity, at level 201) : pattern_scope. Notation "p '=e>' [ H ] b" := (pbase p%core (b%core) UniEvarconv) (no associativity, at level 201, H at next level) : pattern_scope. Definition test_match@{k m+} {A:Type@{k}} (x:A) : tactic := mmatch A with | [? B:Type@{m}] B =c> T.exact x end. Lemma testMmatch@{i j} : Type@{i} -> Type@{max(i,j)}. MProof. test_match (fun x=>x). Qed. Lemma testMmatch'@{i j} : Type@{i} -> Type@{j}. MProof. test_match (fun x=>x). Qed. Print testMmatch. Print testMmatch'. Definition testdef : Type -> Type := fun x=>x. Lemma testret : Type -> Type. MProof. M.ret (fun x=>x). Qed. (* If this fails we likely swapped LHS & RHS of the cumulative unification in [ifM] *) Print testret. Lemma testexact : Type -> Type. MProof. T.exact (fun x=>x). Qed. About testexact. Mtac2-1.4-coq8.20/tests/bugs.v000066400000000000000000000046711472011217100157110ustar00rootroot00000000000000From Mtac2 Require Import Logic Datatypes Mtac2. Require Import Bool.Bool. Import T. (** A bug with destruct *) Goal forall n:nat, 0 <= n. MProof. intros. (* destruct n. *) (* the type of the match seems to be wrong *) Abort. (** It was throwing an exception, but now it works *) Theorem exists_example_2 : forall n, (exists m, n = 4 + m) -> (exists o, n = 2 + o). MProof. intros n. cintros m {- destruct m -}. Abort. (** A bug with the call to UniCoq (solved) *) Example fubar (T : Type) (A : T) : M Prop:= oeq <- M.unify Prop T UniCoq; match oeq with | mSome eq => M.ret (meq_rect Prop (fun T=>T -> Prop) id T eq A) | _ => M.raise exception end. Definition fubarType := Eval compute in ltac:(mrun (mtry fubar Type (True <-> True) with _ => M.ret True end)%MC). (* TODO: this test no longer works unless we want to import MTeleMatch here *) (** With mmatch should be the same *) (* Example fubar_mmatch (T : Type) (A : T) : M Prop:= *) (* mmatch T with *) (* | Prop => [H] M.ret (meq_rect Prop (fun T=>T -> Prop) id T (meq_sym H) A) *) (* | _ => M.raise exception *) (* end. *) (* Definition fubarType_mmatch := *) (* Eval compute in *) (* ltac:(mrun (mtry fubar_mmatch Type (True <-> True) with _ => M.ret True end)%MC). *) (** the bind overloaded notation was reducing terms using typeclasses. destcase expects a match, but it finds false *) Definition destcase_fail := ltac:(mrun (r <- M.ret (match 3 with 0 => true | _ => false end); _ <- M.destcase r; M.ret I)%MC). (** with the bind construct it works. this proves that the <- ; notation is reducing *) Definition destcase_work := ltac:(mrun (M.bind (M.destcase (match 3 with 0 => true | _ => false end)) (fun _=> M.ret I))). (* Regression test for a bug in `T.bind` where goals were filtered after both tactics were executed instead of filtering after the first tactic. *) (* Force a solved goal to be returned. *) Definition faulty_exact {A} (x : A) : tactic := fun g => (match g with | Metavar _ _ g' => M.cumul UniCoq x g';; M.ret [m: (m: tt, AnyMetavar _ _ g')] end)%MC. Goal True /\ 1=1. MProof. (* Work around previous bad behavior to force the left-hand side of the outermost bind operator to produce unsolved goals. *) (fun g => r<- M.map (fun '(m: x,g') => open_and_apply ((faulty_exact) I) g') =<< apply conj g; M.ret (mconcat r) )%MC &> (fun g : goal gs_open => (is_open g >>= M.print_term);; M.print_term g;; reflexivity g)%MC. Qed. Mtac2-1.4-coq8.20/tests/bugs/000077500000000000000000000000001472011217100155125ustar00rootroot00000000000000Mtac2-1.4-coq8.20/tests/bugs/abs_prod_unsoundness.v000066400000000000000000000004451472011217100221410ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Set Universe Polymorphism. Goal nat -> Set. MProof. intros n. (* We cannot build something bigger than Set! This must fail. *) Fail M.abs_prod_type n Set. (* But building the right type works fine: *) M.abs_prod_type n nat. (* nat -> nat *) Qed. Mtac2-1.4-coq8.20/tests/bugs/bug117.v000066400000000000000000000007271472011217100167150ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Definition to_any (g: goal gs_open) : goal gs_any := match g with | Metavar _ s e => Metavar' _ _ s e end. (* besides duplicating the same goal (which is not incorrect, just stupid) this tactic is not normalizing the list. *) Definition wrong_tactic : tactic := \tactic g => M.ret ([m: (m: tt, to_any g)]+m+[m: (m: tt, to_any g)]). Goal True. MProof. Fail wrong_tactic. (* it should fail nicely (without anomaly) *) Abort.Mtac2-1.4-coq8.20/tests/bugs/bug225.v000066400000000000000000000005631472011217100167130ustar00rootroot00000000000000From Mtac2 Require Import Base Datatypes. Import M.notations. From Coq Require Import String. Definition reduce_nu := ltac:( mrun ( M.nu Generate (mNone) (fun k => mtry k with | StuckTerm => M.ret tt | _ => M.failwith "expected StuckTerm" end ) ) ). Mtac2-1.4-coq8.20/tests/bugs/bug288.v000066400000000000000000000013251472011217100167210ustar00rootroot00000000000000From Mtac2 Require Import Datatypes Mtac2. Require Import Lists.List. Import ListNotations. (** assert x y e asserts that y is syntactically equal to x. Since we need to make sure the convertibility check is not triggered, we assume the terms x and/or y contains an evar e that is instantiated with tt. *) Definition assert_eq {A} (x y: A) : M unit := o1 <- M.unify x y UniMatchNoRed; match o1 with | mSome _ => M.ret tt | _ => M.raise (NotUnifiable x y) end. (* Lets in matches used to break let-reduce. *) Mtac Do ( match (let x := 1 in [x]) with | nil => M.raise exception | cons _ _ => let n := reduce (RedStrong RedAll) (1 + 1) in assert_eq 2 n end ). Mtac2-1.4-coq8.20/tests/bugs/bug295.v000066400000000000000000000025101472011217100167140ustar00rootroot00000000000000From Mtac2 Require Import Mtac2 Ttactics. Set Printing Universes. Import Ttactics.TT. Import TT.notations. Module Test. Polymorphic Section With. Monomorphic Parameter MyGoal : Prop. Polymorphic Parameter MyAssum1@{U1}: forall T1:Type@{U1}, Prop. Polymorphic Parameter MyAssum2@{U2}: forall T2:Type@{U2}, Prop. Polymorphic Parameter MyProof@{U1 U2+|U1 < U2+} : forall (T1 : Type) (T2 : Type), MyAssum1@{U1} T1 -> MyAssum2@{U2} T2 -> MyGoal. Set Printing Depth 1000. Polymorphic Definition my_tactic@{U1 U2 U1' U2'+} : tactic := Eval cbv beta fix match delta [ MatchGoalTT.match_goal_base MatchGoalTT.match_goal_pattern MatchGoalTT.match_goal_pattern' M.mmatch'' M.open_branch M.open_pattern ] in (match_goal with | [[? (T1: Type@{U1'}) (T2:Type@{U2'}) | (H1 : MyAssum1@{U1} T1) (H2 : MyAssum2@{U2} T2) |- MyGoal ]] => TT.apply (MyProof@{U1 U2 U1' U2'} T1 T2 H1 H2) end )%TT%MC. Polymorphic Universe poly U1 U2. Parameter T1 : Type@{U1}. Parameter T2 : Type@{U2}. Polymorphic Example test1 (H1 : MyAssum1@{U1} T1) (H2 : MyAssum2@{U2} T2) : MyGoal. Proof. mrun (my_tactic). Qed. (* <-- there used to be a Fail here :-) *) End With. End Test. Mtac2-1.4-coq8.20/tests/bugs/bug297.v000066400000000000000000000002621472011217100167200ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Parameter x : moption nat. Definition test : M nat := mtry (M.nu Generate x (fun x=>M.ret 0)) with StuckTerm => M.ret 0 end. Mtac Do test. Mtac2-1.4-coq8.20/tests/bugs/bug299.v000066400000000000000000000013271472011217100167250ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Import M.notations. Import M. Inductive tFalse : Type. Definition omg_false (f:tFalse) : Exception. constructor. Qed. Polymorphic Definition test : M unit := a <- evar Type; \nu b : a, mtry' ( eqp <- unify_or_fail UniCoq a tFalse; (* replace b eqp ( *) (* here b : nat *) let b' := rcbv (internal_meq_rew _ a (fun a => a) b tFalse eqp) in raise (omg_false b') (* ) *) ) (fun e => mif is_evar a then unify_or_fail UniCoq a nat;; dbg_term "a: " a;; print_term e;; failwith "a was not instantiated, although b has its type" else print "All good, a was instantiated with b's type (tFalse)";; ret tt). Mtac Do test. Mtac2-1.4-coq8.20/tests/bugs/bug302.v000066400000000000000000000017731472011217100167130ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Import M.notations. Import M. Inductive tFalse : Set. Definition omg_false (f:tFalse) : Exception. constructor. Qed. Polymorphic Definition test : M unit := a <- evar Type; \nu b : a, mtry' ( eqp <- unify_or_fail UniCoq a tFalse; replace b eqp ( (* here b : nat *) let b' := rcbv (internal_meq_rew _ a (fun a => a) b tFalse eqp) in raise (omg_false b') ) ) (fun e => hs <- hyps; match hs with | [m: h] => mmatch h with | [#] @ahyp | a' b' o =n> mmatch a' with | [#] tFalse | =n> mif is_evar a then failwith "a is still an evar, but b has its type" else print "all good" | _ => mif is_evar a then failwith "a is still an evar, but b has its type" else dbg_term "a' is " a';; failwith "No idea of what happened!" end end | _ => failwith "more than one hypothesis?" end). Mtac Do test. Mtac2-1.4-coq8.20/tests/bugs/bug304.v000066400000000000000000000006621472011217100167110ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Import M.notations. Import M. (** we construct an equality of 4 =m= 2 from an equality of 2 =m= 2 *) Polymorphic Definition test : M unit := mtry (\nu n := 2, eq <- unify_or_fail UniCoq n 2; abs_let (P:=fun n=> n =m= 2) n 4 (eq : n =m= 2) : M (4 =m= 2));; print "This shouldn't run";; ret tt with AbsLetNotConvertible => print "All good";; ret tt end. Mtac Do test. Mtac2-1.4-coq8.20/tests/cevar.v000066400000000000000000000025201472011217100160400ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Import Mtac2.lib.List.ListNotations. Example ex1 (x y: nat) (H: x>y) (z: nat) : True. MProof. M.Cevar _ [m:ahyp H mNone | ahyp y mNone | ahyp x mNone]. (* wrong order of variables *) Unshelve. Fail M.Cevar _ [m:ahyp x mNone| ahyp H mNone| ahyp y mNone]. (* dup variable *) Fail M.Cevar _ [m:ahyp x mNone| ahyp x mNone| ahyp y mNone]. M.Cevar _ [m:ahyp H mNone| ahyp y (mSome 0)| ahyp x mNone]. Unshelve. T.exact I. Qed. Example ex2 : forall (x y: nat) (H: x>y) (z:nat), True. MProof. cintros (x y: nat) (H: x>y) (z: nat) {- e <- M.Cevar _ [m:ahyp H mNone| ahyp y mNone| ahyp x mNone]; T.exact e -}. (* misses z in the evar, but it still works, why? *) Unshelve. T.exact I. Qed. Example ex3 : forall (x y: nat) (H: x>y), True. MProof. (* wrong order of variables *) Fail cintros (x y: nat) (H: x>y) {- e <- M.Cevar True [m:ahyp x mNone| ahyp H mNone| ahyp y mNone]; T.exact e -}. (* dup variable *) Fail cintros (x y: nat) (H: x>y) {- e <- M.Cevar True [m:ahyp x mNone| ahyp x mNone| ahyp y mNone]; T.exact e -}. cintros (x y: nat) (H: x>y) {- e <- M.Cevar _ [m:ahyp H mNone| ahyp y (mSome x)| ahyp x mNone]; T.exact e -}. Unshelve. (* not a variable *) Fail M.Cevar _ [m:ahyp (x > y) mNone| ahyp y (mSome x)| ahyp x mNone]. T.exact I. Qed. Mtac2-1.4-coq8.20/tests/comptactics.v000066400000000000000000000031251472011217100172530ustar00rootroot00000000000000From Mtac2 Require Import Mtac2 CompoundTactics. Import T. Import T.notations. Import CT. Import CT.notations. Example exabs (x : nat) : x = 1 -> 1 = x. MProof. intro H. simple_rewrite H. reflexivity. Qed. Example exabs2 (x : nat) : S x = 1 -> 1 = S x. MProof. intro H. simple_rewrite H. reflexivity. Qed. Require Import Strings.String. Example exabs2' (x : nat) : S x = 1 -> 1 = S x. MProof. intro H. variabilize (S x) as t. assert (B:t = S x). reflexivity. Abort. Require Import Arith. Example exif (x : nat) : if Nat.eqb (S x) 1 then x = 0 : Type else True. MProof. variabilize (Nat.eqb (S x) (S 0)) as t. assert (B:t = Nat.eqb (S x) 1). reflexivity. Abort. Definition sillyfun (n : nat) : bool := if Nat.eqb n 3 then false else if Nat.eqb n 5 then false else false. Theorem sillyfun_false : forall (n : nat), (sillyfun n = false) : Type. MProof. intros n. unfold sillyfun. variabilize (Nat.eqb n 3) as t3. destruct t3. simpl. reflexivity. simpl. variabilize (Nat.eqb _ _) as t5. destruct t5 &> reflexivity. Qed. Definition sillyfun1 (n : nat) : bool := if Nat.eqb n 3 then true else if Nat.eqb n 5 then true else false. Fixpoint evenb (n:nat) : bool := match n with | O => true | S O => false | S (S n') => evenb n' end. Definition oddb (n:nat) : bool := negb (evenb n). Theorem sillyfun1_odd : forall (n : nat), (sillyfun1 n = true -> oddb n = true) : Type . MProof. intros n. unfold sillyfun1. variabilize (Nat.eqb n 3) as t. assert (Heqe3 : t = (n =? 3)%nat) |1> reflexivity. move_back Heqe3. destruct t &> intro Heqe3. Abort. Mtac2-1.4-coq8.20/tests/debug_ex.v000066400000000000000000000006601472011217100165250ustar00rootroot00000000000000From Mtac2 Require Import Base Datatypes. Import M. Import M.notations. Goal True. MProof. Fail raise _. (* should say "ExceptionNotGround" *) Mtac Do Set_Debug_Exceptions. Fail raise _. (* should print ?e *) Fail nu "P" mNone (fun P:True=>M.ret P). (* should print P *) Fail (_:M True). (* should print "StuckTerm ?t" *) Mtac Do Unset_Debug_Exceptions. Fail (_:M True). (* shoudn't print anything *) M.ret I. Qed. Mtac2-1.4-coq8.20/tests/decapp.v000066400000000000000000000012331472011217100161740ustar00rootroot00000000000000From Mtac2 Require Import Base DecomposeApp. Import M.notations. Mtac Do Check ltac:(mrun (MTele_of (nat) _ (@plus))). Definition pairs := <[decapp (3 + 5) with @plus ]> UniMatchNoRed (fun x y => M.ret (x,y)). Definition pairs_eq : M.eval pairs = (3, 5) := eq_refl. Fail Definition should_fail := <[decapp (String.append "a" "b") with @plus ]> (fun x y => M.ret (x,y)). Definition dyns := <[decapp (Dyn 5) with @Dyn@{Set} ]> UniMatchNoRed (fun ty el => M.ret ty). Definition dyns_eq : M.eval dyns = nat := eq_refl. Definition dyns_ty := <[decapp (Dyn 5) with @Dyn nat ]> UniMatchNoRed (fun el => M.ret el). Definition dyns_ty_eq : M.eval dyns_ty = 5 := eq_refl.Mtac2-1.4-coq8.20/tests/declare.v000066400000000000000000000206161472011217100163450ustar00rootroot00000000000000From Mtac2 Require Import Mtac2 Sorts MTele Specif. Import M.notations. Definition test := c <- M.declare dok_Definition "bla" false 1; M.print_term c. Goal unit. MProof. (* TODO: inlining test here used to *not* work because of universes. *) c <- M.declare dok_Definition "bla" false 1; M.print_term c. Qed. Goal unit. MProof. test. Qed. Typeclasses eauto := debug. Structure ST := mkS { s : nat }. Require Mtac2.lib.List. Import Mtac2.lib.List.ListNotations. Definition cs := c1 <- M.declare dok_CanonicalStructure "bla" false (fun (x : nat) => (fun x => mkS x) x); c2 <- M.declare dok_Definition "bli" true c1; M.declare_implicits c2 [m: ia_MaximallyImplicit];; M.ret tt. Compute ltac:(mrun cs). Print bla. Print Coercions. Print Canonical Projections. Print bli. Fail Compute (bli 1). Compute (@bli 1). Module DeclareTest. Fail Compute ltac:(mrun (M.declare_implicits (1+1) [m:])). Local Arguments Nat.add {_ _}. Fail Compute ltac:(mrun (M.declare_implicits (Nat.add) [m:])). Fail Compute ltac:(mrun (M.declare_implicits (Nat.add (n:=1)) [m:])). Compute ltac:(mrun (M.declare_implicits (@Nat.add) [m:])). Compute ltac:(mrun (M.declare_implicits (@Nat.add) [m: ia_MaximallyImplicit | ia_MaximallyImplicit])). Definition should_work0 := Nat.add (n:=3) (m :=2). Compute ltac:(mrun (M.declare_implicits (@Nat.add) [m: ia_Implicit | ia_Explicit])). Definition should_work2 := Nat.add (n:=3) 2. Compute ltac:(mrun (M.declare_implicits (@Nat.add) [m: ia_Explicit | ia_MaximallyImplicit])). Definition should_work1 := Nat.add (m :=3) 2. Compute ltac:(mrun (M.declare_implicits (@Nat.add) [m: ia_Explicit | ia_Explicit])). Definition should_work := Nat.add 3 2. End DeclareTest. Require Import Strings.String. Import M.notations. Fixpoint defineN (n : nat) : M unit := match n with | 0 => M.ret tt | S n => s <- M.pretty_print n; M.declare dok_Definition ("NAT"++s)%string false n;; defineN n end. Fail Print NAT0. Compute ltac:(mrun (defineN 4)). Print NAT0. Print NAT1. Print NAT2. Print NAT3. Fail Print NAT4. Set Printing All. (* nasty *) Fail Compute ltac:(mrun (defineN 4)). Search "NAT". (* Now there are no definitions like "NATS (S O)" *) Fail Compute ltac:(mrun (M.get_reference "NATS O")). Definition ev := c <- M.declare dok_Definition "_" true (S O); M.print_term c. Compute (M.eval ev). (* it was failing *) Unset Printing All. (* ouch, there should be a catchable error. but what about previously declared objects? *) Definition alrdecl := mtry defineN 5 with [?s] AlreadyDeclared s => M.print s;; M.ret tt end. Compute ltac:(mrun alrdecl). Print NAT4. (* definitions before the failing one are declared. *) (* NOTE: We give a unidirectional version of Nat.succ_le_mono for compatibility. *) Lemma succ_le_mono_lr (n m : nat) : n <= m -> S n <= S m. Proof. now apply ->PeanoNat.Nat.succ_le_mono. Qed. (* we should check that the terms are closed w.r.t. section variables *) (* JANNO: for now we just raise an catchable exception. *) Fail Compute fun x y => ltac:(mrun ( mtry M.declare dok_Definition "lenS" true (succ_le_mono_lr x y);; M.ret tt with | UnboundVar => M.failwith "This must fail" | _ => M.ret tt end )). (* This used to fail because of weird universe issues. *) Compute ltac:(mrun (c <- M.declare dok_Definition "blu" true (succ_le_mono_lr); M.print_term c)). Definition decl_blu := (c <- M.declare dok_Definition "blu" true (succ_le_mono_lr); M.print_term c). (* This now fails because the previous failure no longer exists and [blu] is declared. *) Fail Compute ltac:(mrun decl_blu). Print blu. Definition backtracking_test := mtry M.declare dok_Definition "newone" false tt;; M.declare dok_Definition "blu" false tt;; M.ret tt with [?s] AlreadyDeclared s => M.ret tt end. Compute ltac:(mrun backtracking_test). Print newone. (* is this expected? or should the "state" of definitions be also backtracked? *) Print blu. Module Inductives. Set Polymorphic Inductive Cumulativity. Unset Universe Minimization ToSet. Import ListNotations. Definition typ_of {A : Type} (a : A) := A. Import TeleNotation. Notation P := [tele (T : Type) (k : nat)]. Module M1. Notation I2 := (m: "blubb__"%string; fun T k => mexistT (MTele_ConstT _) ([tele _ : k = k]) (fun _ => Propₛ)). Definition mind_test := (M.declare_mind P ([m: I2])). Eval cbv beta iota fix delta [mfold_right typ_of] in typ_of mind_test. (* Eval cbv beta iota fix delta [mfold_right typ_of] in *) Definition testprog := mind_test (fun I2 T k => (m: mnil; tt) ). Eval cbv in testprog. Eval cbn in ltac:(mrun( let t := dreduce ((@S.Fun), testprog) testprog in t )). End M1. Module M2. Notation I2 := (m: "blubb__"%string; fun T k => mexistT (MTele_ConstT _) ([tele _ : k = k]) (fun _ => Propₛ)). Definition mind_test := (M.declare_mind P ([m: I2])). Eval cbv beta iota fix delta [mfold_right typ_of] in typ_of mind_test. (* Eval cbv beta iota fix delta [mfold_right typ_of] in *) Definition testprog := mind_test (fun I2 T k => (m: [m: (m: "c1"%string, mexistT _ (mTele (fun t : T => mBase)) (S.Fun (sort:=Typeₛ) (fun t => ((mexistT _ eq_refl tt)))) ) ]; tt) ). Eval cbv in testprog. Eval cbn in ltac:(mrun( let t := dreduce ((@S.Fun), testprog) testprog in t )). End M2. Module M3. Notation I1 := (m: "bla__"%string; fun T k => mexistT (MTele_ConstT _) ([tele]) (Typeₛ)). Notation I2 := (m: "blubb__"%string; fun T k => mexistT (MTele_ConstT _ ) ([tele]) (Propₛ)). Definition mind_test := (M.declare_mind P ([m: I1 | I2])). Eval cbv beta iota fix delta [mfold_right typ_of] in typ_of mind_test. (* Eval cbv beta iota fix delta [mfold_right typ_of] in *) Definition testprog := mind_test (fun I1 I2 T k => (m: [m: (m: "c1"%string, mexistT _ (mTele (fun t : I2 T k => mBase)) (S.Fun (sort:=Typeₛ) (fun t => tt)) ) ]; [m: (m: "c2"%string, mexistT _ (mTele (fun t : I1 T k => mBase)) (S.Fun (sort:=Typeₛ) (fun t => tt)) ) ]; tt) ). Eval cbn in ltac:(mrun( let t := dreduce ((@S.Fun), testprog) testprog in t )). End M3. Module M4. Notation I1 := (m: "bla__"%string; fun T k => mexistT (MTele_ConstT _) ([tele x y : nat]) (fun x y => Typeₛ)). Notation I2 := (m: "blubb__"%string; fun T k => mexistT (MTele_ConstT _) ([tele _ : k = k]) (fun _ => Propₛ)). Definition mind_test := (M.declare_mind P ([m: I1 | I2])). Eval cbv beta iota fix delta [mfold_right typ_of] in typ_of mind_test. (* Eval cbv beta iota fix delta [mfold_right typ_of] in *) Definition testprog := mind_test (fun I1 I2 T k => (m: [m: (m: "c1"%string, mexistT _ (mTele (fun t : I2 T k eq_refl => mBase)) (S.Fun (sort:=Typeₛ) (fun t => (mexistT _ 1 (mexistT _ 2 tt)))) ) ]; mnil; tt) ). Eval cbn in ltac:(mrun( let t := dreduce ((@S.Fun), testprog) testprog in t )). End M4. End Inductives. Module ExistingInstance. Module Inner. Class dummy := Dummy { dummy_nat : nat; dummy_extra : string }. Definition test_global5 : dummy := Dummy 5 "5". Definition test_global55 : dummy := Dummy 55 "55". Definition test_local1 : dummy := Dummy 1 "1". Mtac Do (M.existing_instance "test_global5" (mSome 5%N) true ). Mtac Do (M.existing_instance "test_global55" (mSome 55%N) true ). Mtac Do (M.existing_instance "test_local1" (mSome 1%N) false). Mtac Do (M.ret (meq_refl : dummy_nat =m= 1)). End Inner. Fail Mtac Do (M.ret (meq_refl : Inner.dummy_nat =m= 1)). Mtac Do (M.ret (meq_refl : Inner.dummy_nat =m= 5)). Fail Mtac Do (M.ret (meq_refl : Inner.dummy_nat =m= 55)). End ExistingInstance. Mtac2-1.4-coq8.20/tests/decompose.v000066400000000000000000000016531472011217100167240ustar00rootroot00000000000000From Mtac2 Require Import List Mtac2. Import ListNotations. Import M. Import M.notations. Definition decompose {T} (x : T) := (mfix2 f (d : dyn) (args: mlist dyn) : M (dyn *m mlist dyn) := M.print_term d;; mmatch d with | [? A B (t1: A -> B) t2] Dyn (t1 t2) => f (Dyn t1) (Dyn t2 :m: args) | [? A B (t1: forall (x:A), B x) t2] Dyn (t1 t2) => f (Dyn t1) (Dyn t2 :m: args) | _ => M.ret (m: d, args) end) (Dyn x) [m:]. (* If I'm not mistaken, the problem comes from the unification of ?t1 ?t2 =?= M.ret True Which first tries to unify ?t1 with M.ret, without the knoweldge of it being restricted by the second argument. I think it should first unify ?t2 and then ?t1 (or delay the unification. *) Goal True. MProof. Fail mmatch Dyn (@M.ret True) with | [? (P : Type -> Prop) (t1 : forall X:Type, P X) (t2 : Prop) ] @Dyn (P t2) (t1 t2) => M.ret I | _ => M.raise exception end. Abort. Mtac2-1.4-coq8.20/tests/dependent_let_goals.v000066400000000000000000000004121472011217100207350ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Lemma dep_test1 x y: let m := max x y in @eq (eq (max x y) m) eq_refl eq_refl. Proof. intros m. reflexivity. Qed. Lemma dep_test1_M x y: let m := max x y in @eq (eq (max x y) m) eq_refl eq_refl. MProof. intros m. T.reflexivity. Qed. Mtac2-1.4-coq8.20/tests/destruct_eq.v000066400000000000000000000006671472011217100172740ustar00rootroot00000000000000From Mtac2 Require Import Mtac2 CompoundTactics. From Coq.Arith Require Import Arith. Example beq_nat_ex : forall n, if (Nat.eqb n 3) then True else True. MProof. intros n. CT.destruct_eq (Nat.eqb _ _). - simpl. intro H. T.exact I. - simpl. intro H. T.exact I. Qed. Example beq_nat_ex_comp : forall n, if (Nat.eqb n 3) then True else True. MProof. intros n. CT.destruct_eq (Nat.eqb _ _) &> simpl &> intros &> T.exact I. Qed. Mtac2-1.4-coq8.20/tests/do.v000066400000000000000000000005421472011217100153440ustar00rootroot00000000000000Require Import Mtac2.Base. Import M. Import M.notations. (* dumb test *) Mtac Do (ret tt). (* Test without parentheses. *) Mtac Do ret tt. Mtac Do (print_term tt). (* open terms are OK *) Mtac Do (ret _). Fail Mtac Do _. (* Stuck term *) Set Printing Universes. Mtac Do New Exception Pum. Check Pum. Fail Mtac Do (raise Pum). Mtac Do Check (_ + _).Mtac2-1.4-coq8.20/tests/dummylang.v000066400000000000000000000077701472011217100167510ustar00rootroot00000000000000(** A simple example showcasing Mtac2 for PL proofs *) (** The language are if-then-elses with conditional (bool) expressions and a nil value (to make it sligthly more interesting). *) Inductive binop := band | bor. Inductive unop := bnot. Inductive exp := ttrue | ffalse | nil | B : binop -> exp -> exp -> exp | U : unop -> exp -> exp. Inductive st := | ife : exp -> st -> st -> st | sc. Notation ";;" := sc. Notation "'If' e 'then' s1 'else' s2 'end'" := (ife e s1 s2) (at level 10). Notation "a 'or' b" := (B bor a b) (at level 10). Notation "a 'and' b" := (B band a b) (at level 10). Check (If ffalse or nil then ;; else If ttrue then ;; else ;; end end). Definition delta : exp -> exp := fun e=> match e with | B band ffalse e' => ffalse | B band nil e' => ffalse | B band _ e' => e' | B bor ffalse e' => e' | B bor nil e' => e' | B bor v e' => v | U not ffalse => ttrue | U not nil => ttrue | U not _ => ffalse | _ => e end. Inductive is_val : exp -> Prop := | vnil : is_val nil | vtrue : is_val ttrue | vfalse : is_val ffalse. Inductive step : st -> st -> Prop := | IfT : forall s1 s2 v, is_val v -> v <> nil -> v <> ffalse -> step (If v then s1 else s2 end) s1 | IfF : forall s1 s2, step (If ffalse then s1 else s2 end) s2 | IfN : forall s1 s2, step (If nil then s1 else s2 end) s2 | Ife : forall s1 s2 e1 e2, estep e1 e2 -> step (If e1 then s1 else s2 end) (If e2 then s1 else s2 end) with estep : exp -> exp -> Prop := | BinV : forall op v e, estep (B op v e) (delta (B op v e)) | BinS : forall op e e1 e2, estep e1 e2 -> estep (B op e1 e) (B op e2 e) | UnV : forall op v, estep (U op v) (delta (U op v)) | UnS : forall op e1 e2, estep e1 e2 -> estep (U op e1) (U op e2). Inductive steps : st -> st -> Prop := | steps0: forall m, steps m m | stepsn: forall p p' p'', step p p' -> steps p' p'' -> steps p p''. Example test : steps (If nil or ffalse then ;; else ;; end) ;;. Proof. eapply stepsn. eapply Ife. econstructor. simpl. eapply stepsn. eapply IfF. econstructor. Qed. #[global] Hint Constructors is_val st exp step estep steps unop binop. (** We prove that every program terminates in a ;;. We do it first in plain Ltac. *) Lemma always_sc : forall p, steps p ;;. Proof. induction 0; eauto. induction e; eauto. - eapply stepsn; repeat (assumption || econstructor || discriminate). - case b; induction e1; eauto. - case u; induction e; eauto. + eapply stepsn. eapply Ife. econstructor. simpl. eapply stepsn. eapply IfT. econstructor. discriminate. discriminate. assumption. + eapply stepsn. eapply Ife. econstructor. simpl. eapply stepsn. eapply IfT. econstructor. discriminate. discriminate. assumption. Qed. (** Now we do it in Mtac2. *) From Mtac2 Require Import Mtac2 ConstrSelector. Import T. Import T.notations. Polymorphic Definition stepNdo {A} (l : A) := (apply stepsn |1> apply l |1> constructor) &> simpl. Polymorphic Definition stepInIf := stepNdo Ife. Polymorphic Definition stepIfTrue := (stepNdo IfT) &> try (discriminate || T.assumption). Definition UnsoledGoals : Exception. constructor. Qed. Notation "t '[x]'" := (t &> T.raise UnsoledGoals) (at level 0). Lemma alwas_sc_mtac2 : forall p, steps p ;;. MProof. intros p. (select st >>= induction) &> case steps0 do eauto [x]. (select exp >>= induction) &> case false, nil do eauto [x]. + stepIfTrue. + (select binop >>= destruct) &> (select exp >>= induction) &> eauto [x]. + (select unop >>= destruct) &> (select exp >>= induction) &> case true, B, U do eauto [x] &> (stepInIf &> stepIfTrue). Qed.Mtac2-1.4-coq8.20/tests/exceptions.v000066400000000000000000000036261472011217100171310ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Axiom block : M nat. Fail Definition block_fails := ltac:(mrun block). Fail Definition block_fails2 := ltac:(mrun (id block)). Fail Definition block_fails3 := ltac:((mrun (match 0+0 with 0 => block | _ => M.ret 0 end))). Fail Definition block_fails4 := ltac:(mrun ( mtry id (M.raise exception;; M.ret 0) with | exception => id id block end )%MC). Definition block_raises_failure := ltac:(mrun (mtry block with StuckTerm => M.ret 0 end)%MC). Example simple_ex := ltac:(mrun (mtry M.raise exception with exception => M.ret 0 end)%MC). Definition AnException (n : nat) : Exception. exact exception. Qed. Example closed_ex := ltac:(mrun (mtry M.raise (AnException 0) with [? n] AnException n => M.ret n end)%MC). Example not_closed_but_closed (m : nat) := ltac:(mrun (mtry M.raise (AnException m) with [? n] AnException n => M.ret n end)%MC). Example nu_not_closed_raise_not_closed := ltac:(mrun (mtry \nu x:nat, M.raise (AnException x) with ExceptionNotGround => M.ret 0 end)%MC). Example nu_not_closed_but_ok := ltac:(mrun (\nu x:nat, mtry M.raise (AnException x) with [? y] AnException y => M.ret 0 end)%MC). Example evar_not_closed_raise_not_closed := ltac:(mrun (mtry e <- M.evar nat; M.raise (AnException e) with ExceptionNotGround => M.ret 0 end)%MC). Example evar_closed_is_fine := ltac:(mrun (mtry e <- M.evar nat; M.unify e 0 UniCoq;; M.raise (AnException e) with [? n] AnException n => M.ret n end)%MC). Example evar_not_closed_but_ok := ltac:(mrun ( e <- M.evar nat; mtry M.raise (AnException e) with [? d] AnException d => M.unify d 0 UniCoq;; M.ret d end)%MC). Fail Example nu_not_closed_raise_not_groud_uncaught := ltac:(mrun (\nu e : nat, M.raise (AnException e)%MC)). Example escapes_a_nu_but_ok := ltac:(mrun ( \nu f:nat, mtry \nu e : nat, M.raise (AnException f) with AnException f => M.ret 0 end)%MC). Mtac2-1.4-coq8.20/tests/goal_reordering.v000066400000000000000000000017451472011217100201120ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Goal True. MProof. (M.evar nat;; M.evar bool;; M.ret _)%MC. (* FIXME: why are all evars shelved when we do this in the tactic monad? *) Unshelve. M.ret _. Unshelve. M.ret _. Unshelve. M.ret true. Unshelve. M.ret I. M.ret 0. Qed. Definition ThrowANat (n : nat) : Exception. exact exception. Qed. Definition test n : M nat := mmatch n with | [? n'] S n' => M.raise (ThrowANat n') | _ => M.ret 0 end. Goal True. MProof. M.mtry' (test 1;; M.ret I) (fun _=> M.ret I). Qed. Goal {n:nat| n = n}. MProof. (mtry test 1;; M.raise exception with [? n'] ThrowANat n' => M.ret (exist _ n' _) end)%MC. Abort. Goal {n:nat| n = n}. MProof. (mmatch 2 + 4 with | [? n] n + n => M.ret (exist _ (n + n) eq_refl) | [? n] n + n => M.ret (exist _ (n + n) eq_refl) | [? n] n + n => M.ret (exist _ (n + n) eq_refl) | [? n] n + n => M.ret (exist _ (n + n) eq_refl) | [? n m] n + m => M.ret (exist (fun n=>n=n) (n + m) eq_refl) end)%MC. Qed. Mtac2-1.4-coq8.20/tests/hugo.v000066400000000000000000000020731472011217100157050ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Inductive my_enum_type := one | two | three. Require Import Vector. Import Fin. Require Import Lia. Lemma lt_0_S n : 0 < S n. Proof. lia. Qed. (* NOTE: unidirectional version of Nat.succ_lt_mono for compatibility. *) Lemma succ_lt_mono_lr (n m : nat) : n < m -> S n < S m. Proof. now intros H; apply ->PeanoNat.Nat.succ_lt_mono. Qed. Fixpoint prove_leq n m : M (n < m) := match n, m with | 0, S _ => M.ret (lt_0_S _) | S n', S m' => H <- prove_leq n' m'; M.ret (succ_lt_mono_lr _ _ H) | _, _ => M.failwith "n not < m" end. Definition to_fin_MP : T.selector unit := (fun l=> let n := mlength l in M.mapi (fun i '(m: _, g) => H <- prove_leq i n; let v := rcbv (of_nat_lt H) in T.open_and_apply (T.exact v) g) l;; M.ret [m:])%MC. Goal my_enum_type -> Fin.t 3. MProof. intro H. T.destruct H &> to_fin_MP : gtactic unit. (* HACK: why do we need to specify the return type? *) Qed. Goal my_enum_type. MProof. pose (H := FS (FS F1) : Fin.t 3). let p := proj1_sig (to_nat H) in T.nconstructor (S p). Qed. Mtac2-1.4-coq8.20/tests/hyps.v000066400000000000000000000010321472011217100157200ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Import Sorts.S. Open Scope M_scope. Unset Universe Minimization ToSet. Lemma test_OK@{u1 u2 u3} : Type@{u1} -> mlist@{u3} Hyp@{u2}. intros. mrun (M.hyps). Qed. Lemma test_KO@{u1 u2 u3|u2 < u1} : Type@{u1} -> mlist@{u3} Hyp@{u2}. intros. (* With [u1] bigger than [u2] we can no longer fit [Type@{u1}] into [Hyp@{u2}]. *) Fail mrun M.hyps@{u3 u2}. (* Make sure we get the expected exception *) mrun (mtry M.hyps@{u3 u2};; M.raise exception with | HypsUniverseError => M.ret mnil end). Qed. Mtac2-1.4-coq8.20/tests/initialization.v000066400000000000000000000000341472011217100177650ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Mtac2-1.4-coq8.20/tests/intropatt.v000066400000000000000000000012171472011217100167660ustar00rootroot00000000000000From Mtac2 Require Import Mtac2 IntroPatt. Goal True -> True -> True. MProof. pintros \x y //. Qed. Goal nat -> True -> True. MProof. pintros [| ~~ | \x ] \t //. Qed. Goal forall x y z : nat, x = y -> x + z = y + z. MProof. pintros \x y z r> //. Qed. Goal forall x y z : nat, x = y -> x + z = y + z. MProof. pintros \x y z x + z = z + x. MProof. (* is there a way to avoid the parens here? *) (pintros [| ~~ | \x'] [| ~~ | \z'] /=) &> [i: // | r> // | r> // | \IH]. Abort. Mtac2-1.4-coq8.20/tests/kind_of_term.v000066400000000000000000000007301472011217100174010ustar00rootroot00000000000000Require Import Mtac2.Base. Import M. (* just testing it works *) Definition test := ltac:(mrun (isLambda (fun x:nat=>x))). Goal eval (isLambda (fun x:nat=>x)) = true. reflexivity. Qed. Goal eval (isProd (forall x:nat, True)) = true. reflexivity. Qed. Goal eval (isCast (True : Prop)) = true. reflexivity. Qed. Goal eval (isApp (id 0)) = true. reflexivity. Qed. Goal eval (isConst (@id)) = true. reflexivity. Qed. Goal eval (isConstruct S) = true. reflexivity. Qed. Mtac2-1.4-coq8.20/tests/lift.v000066400000000000000000000045021472011217100157000ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Import M. Require Import Lists.List. Import ListNotations. Set Use Unicoq. Structure execV {A} (f : M A) B := ExecV { value : B } . Canonical Structure the_value {A} (f : M A) v := ExecV _ f (lift f v) v. Arguments value {A} f {B} {e}. Definition exec {A} (f : M A) {v:A} : lift f v := v. Goal True. refine (let H := _ in let _ : value (ret I) = H := eq_refl in H). Qed. Goal True. refine (exec (print "hola";; ret I)). Qed. Goal True. refine (exec (raise exception)). Abort. (* note that it doesn't fail, it just silently leaves the goal open (in fact, the proof will contain exec) *) Notation "'[ex' t ']'" := (exec t) (at level 0). Goal [ex ret True] = True. unfold exec. reflexivity. Qed. Import M.notations. Definition silly := fix f (n: nat) : M Prop := match n with | 0 => ret True | S n' => f n' >>= fun r=>ret (True -> r) end. Goal [ex silly 3] : _. (* we need the : to make sure it triggers the rule for lift *) unfold exec. Abort. (* Module Second. Import First. Section Inlist. Parameter A : Type. Structure inlist x := Inlist { list_of :> list A; proof : In x list_of }. Arguments list_of {x} i. Arguments proof {x} i. Program Definition unify {A} (x y : A) (P : A -> Type) (f : P y) : M (P x) := mmatch x with | y => [H] ret (meq_rect_r P f H) | _ => raise exception end. Import M.notations. Program Canonical Structure cons_inst x y s (f : execV ( mtry unify y x (fun z=>In x (z :: s)) (in_eq x s) with exception => e <- evar (inlist x); unify s (list_of e) (fun l=>In x (y :: l)) (in_cons y x (list_of e) (proof e)) end)) := Inlist x (y :: value _ f) (result f). Program Canonical app_inst x s1 (f : execV (fun s2=> e <- evar (inlist x); mtry unify s1 (list_of e) (fun s1 => In x (s1 ++ s2)) (in_or_app (list_of e) s2 x (or_introl (proof e))) with NotUnifiableException => unify s2 (list_of e) (fun s2 => In x (s1 ++ s2)) (in_or_app s1 (list_of e) x (or_intror (proof e))) end)) := Inlist x (s1 ++ value _ f) (result f). Definition test (x y z : A) : In x (x :: y :: z :: nil) := proof _. Definition test1 (x y z : A) : In y (x :: y :: z :: nil) := proof _. Definition test3 (x y z : A) : In y ([z;y] ++ [x;z]) := proof _. Definition test4 (x y z : A) s : In z (s ++ [x;z]) := proof _. End Inlist. *)Mtac2-1.4-coq8.20/tests/ltac.v000066400000000000000000000033411472011217100156650ustar00rootroot00000000000000From Mtac2 Require Import Datatypes List Mtac2. Import Mtac2.lib.List.ListNotations. Import T. Require Import Bool.Bool. Ltac induction n := induction n. Definition qualify s := String.append "" s. Definition induction {A} (n:A) : tactic := ltac (qualify "induction") [m:Dyn n]. Goal forall n:nat, 0 <= n. MProof. intros n. induction n &> [m:apply le_n| apply le_S;; assumption]. Qed. Goal forall m n:nat, 0 <= n. MProof. intros m n. (* m shouldn't be in the list of hypotheses, as it is shared *) (\tactic g => r <- induction n g; match r with | (m:_,AnyMetavar _ _ _) :m: _ => M.ret r | _ => M.raise exception end) &> [m:apply le_n| apply le_S;; assumption]. Qed. Ltac myapply H := apply H. Definition apply' := qualify "myapply". Ltac remove H := clear H. Definition remove := qualify "remove". Goal forall P Q, (P -> Q) -> P -> Q. MProof. intros P Q f x. apply f. ltac remove [m:Dyn f]. exact x. Qed. Goal forall P Q, (P -> Q) -> P -> Q. MProof. intros P Q f x. g <- select (_->_); ltac apply' [m:Dyn g] ;; assumption. Qed. Goal forall P Q, (P -> Q) -> P -> Q. MProof. intros P Q. cintros f x {- ltac apply' [m:Dyn f] ;; ltac apply' [m:Dyn x] -}. Qed. Ltac injection x := injection x. Goal forall n m, S n = S m -> n = m. MProof. intros n m H. ltac (qualify "injection") [m:Dyn H]. trivial. Qed. (** Testing that we can chain ltac tactics that modify the context *) Goal forall n m, S n = S m -> n = m. MProof. intros n m H. induction n &> induction m &> T.try trivial. Abort. Goal forall n m, 1 + n = S m -> n = m. MProof. intros n m H. Ltac unf H := unfold Nat.add in H. ltac "unf" [m: Dyn H] &> (select (_ = _) >>= fun H' => ltac "injection" [m: Dyn H']). trivial. Qed. Mtac2-1.4-coq8.20/tests/ltac_rewrite.v000066400000000000000000000010201472011217100174160ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Goal 4 = 3 -> 3 = 2 -> 2 = 1 -> 1 = 4. MProof. intros H1 H2 H3. rewrite H1. rewrite -> H2. rewrite <- H3. rewrite H3, H3. T.reflexivity. Qed. Goal 4 = 3 -> 3 = 2 -> 2 = 1 -> 1 = 4. MProof. intros H1 H2 H3. rewrite H1, H2, H3. rewrite <- H3, H2, H1. rewrite -> H1, H2, H3. T.reflexivity. Qed. Goal 4 = 3 -> 3 = 2 -> 2 = 1 -> 1 = 4. MProof. intros H1 H2 H3. rewrite_in -> H3; H1. rewrite_in <- H1; H3, H2. rewrite_in H3; H1, H2. rewrite H3, H2. T.reflexivity. Qed. Mtac2-1.4-coq8.20/tests/match_goal_context.v000066400000000000000000000016161472011217100206070ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Goal forall x, True /\ x = 0. MProof. intros x. match_goal with | [[? y |- context C [y = 0] ]] => T.change (C (y = 0 + 0)) end. Abort. Goal forall x, x = 0. MProof. intros x. match_goal with | [[? y |- context C [y = 0] ]] => T.change (C (y = 0 + 0)) end. Abort. Goal forall x y, True /\ (x = x + (y + 0)) /\ True. MProof. intros x y. match_goal with | [[ y |- context C [y + 0] ]] => T.change (C (y + (0 * 0 * 0 * 0))) end. Abort. Goal True /\ True. MProof. match_goal with | [[ |- context C [ True ] ]] => T.change (C (id True)) end. (* works on Prop goals *) Abort. Goal nat * nat. MProof. Fail match_goal with | [[ |- context C [ nat : Set ] ]] => idtac end. (* It fails on non Prop goals... *) Abort. Goal nat * nat. MProof. match_goal with | [[ |- context C [ nat : Type ] ]] => T.idtac end. (* It works on Type *) Abort. Mtac2-1.4-coq8.20/tests/mctacticstests.v000066400000000000000000000175431472011217100200100ustar00rootroot00000000000000Require Import Bool.Bool. Require Import Mtac2.Mtac2. Import T. Import Mtac2.lib.List.ListNotations. Goal True. MProof. exact I. Qed. Goal False. MProof. Fail exact I. Abort. (* The example below is broken but [Fail] cannot catch the error so for now we disable it. TODO: fix this. *) (* Example not_fail_not_var (H : forall x, 0 = S x) : 0 = 0. *) (* MProof. *) (* Fail destruct 0. *) (* Show Proof. *) (* - reflexivity. *) (* - simpl. apply H. *) (* Qed. *) Example ex_destr (n:nat) : n = n. MProof. destruct n. - reflexivity. - intro n'. reflexivity. Qed. Goal forall b : bool, b = b. MProof. intro b. - destruct b &> [m:reflexivity| reflexivity]%list. Qed. Goal forall b1 : bool, b1 = b1. MProof. intro b1 &> [m:reflexivity]%list. Qed. Goal forall b1 b2 b3 : bool, b1 && b2 && b3 = b3 && b2 && b1. MProof. intro b1 ;; (intro b2;; intro b3). destruct b1;; (destruct b2;; (destruct b3;; reflexivity)). Qed. Goal forall b1 b2 b3 : bool, b1 && b2 && b3 = b3 && b2 && b1. MProof. intro b1;; intro b2;; intro b3. destruct b1;; destruct b2;; destruct b3;; reflexivity. Qed. Goal forall b1 b2 b3 : bool, b1 && b2 && b3 = b3 && b2 && b1. MProof. intros b1;; intros b2 b3. destruct b1;; destruct b2;; destruct b3;; reflexivity. Qed. Goal forall b1 b2 : bool, b1 && b2 = b2 && b1. MProof. cintros b1 b2 {- destruct b1;; destruct b2;; reflexivity -}. Qed. Goal forall b1 b2 b3 : bool, b1 && b2 && b3 = b3 && b2 && b1. MProof. cintros b1 b2 {- destruct b1;; destruct b2;; cintro b3 {- destruct b3;; reflexivity -} -}. Qed. Goal (forall x, x > 0) -> 3 > 0. MProof. intro H. apply H. Qed. Goal (forall x, x > 0) -> 3 > 0. MProof. cintro H {- apply H -}. Qed. Goal {x:nat & x > 0}. MProof. apply (existT _ 1 _). Unshelve. hnf. apply le_n. Qed. Require Import Lia. Definition lia := ltac "Coq.micromega.Lia.lia" [m:]. Goal (forall x y, x > y \/ y < x -> x <> y) -> 3 <> 0. MProof. cintro H {- apply H;; left;; lia -}. Qed. Lemma test1 : forall P, P -> P. MProof. exact (fun P x => x). Qed. Lemma test2 : True. MProof. apply (fun (x : True) => x). exact I. Qed. Lemma test3 : O = O. MProof. reflexivity. Qed. Lemma test4 : forall (p : Prop), p = p. MProof. intro x. reflexivity. Qed. Goal forall (x y z : Prop), x = y -> y = z -> x = z. Proof. intros x y z H G. transitivity y. exact H. exact G. Qed. Lemma assumption_test (n m : nat) (H : n = m) : m = n. MProof. symmetry. assumption. Qed. Goal forall (x y z : Prop), x = y -> y = z -> x = z. MProof. intros x y z H G. transitivity y. - exact H. - exact G. Qed. Definition transitivity := "Coq.Init.Ltac.transitivity". Lemma test6 : forall (x y z : Prop), x = y -> y = z -> x = z. MProof. intros x y z H G. ltac transitivity [m:Dyn y]. ltac "Coq.Init.Ltac.revgoals" [m:]. exact H. exact G. Qed. Goal forall (p : Prop), p \/ ~p -> ~p \/ p. Proof. intros p H. destruct H. - right. assumption. - left. assumption. Qed. (* *) Lemma destruct1 : forall (p : Prop), p \/ ~p -> ~p \/ p. MProof. intros p H. destruct H;; intro H0. - right;; assumption. - left;; assumption. Qed. Goal forall b, andb b b = b. MProof. intro b. destruct b. - reflexivity. - reflexivity. Qed. Definition testmg := match_goal with [[ (b : nat) |- S b > 0 ]] => M.print_term b;; destruct b end. Goal forall b : nat, S b > 0. MProof. intros b. Fail testmg. (* FIX why? *) destruct b. - simpl. lia. - intros n';; simpl;; lia. Qed. Goal forall a b : nat, S b > 0. MProof. intros a b. Fail testmg. (* FIX why? *) destruct b. - simpl;; lia. - intros n';; simpl;; lia. Qed. Goal forall a b c : nat, S b > 0. MProof. intros a b c. Fail testmg. destruct b. - simpl;; lia. - intros n';; simpl;; lia. Qed. Goal forall P Q : Prop, P -> P. MProof. intros P Q x. assumption. Qed. Goal forall P Q : Prop, Q -> P -> P. MProof. intros P Q xQ xP. assumption. Qed. Goal forall P Q : Prop, Q -> P -> Q -> P /\ Q. MProof. intros P Q xQ xP xP'. split. - assumption. - assumption. Qed. Goal forall x : bool, orb x true = true. MProof. intro x. match_goal with [[ z:bool |- _ ]] => destruct z end. - reflexivity. - reflexivity. Qed. Goal forall (a b : nat) (Hb : b = 0) (Ha : a = 0), b = 0. MProof. intros a b Hb Ha. match_goal with [[ (x:nat) (Hx : x = 0) |- x = 0 ]] => exact Hx end. Qed. Goal forall (a b : nat) (Hb : b = 0) (Ha : a = 0), a = 0. MProof. intros a b Hb Ha. match_goal with [[ (x:nat) (Hx : x = 0) |- x = 0 ]] => exact Hx end. Qed. Goal forall (a b : nat) (Ha : a = 0) (Hb : b = 0), a = a. MProof. intros a b Ha Hb. match_goal with [[ (x:nat) (Hx : x = 0) |- x = x ]] => reflexivity end. Qed. Goal forall (a b : nat) (Ha : a = 0) (Hb : b = 0), b = b. MProof. intros a b Ha Hb. match_goal with [[ (x:nat) (Hx : x = 0) |- x = x ]] => reflexivity end. Qed. Example apply_tactic (a b : nat) : a > b -> S a > S b. MProof. intro H. apply (proj1 (PeanoNat.Nat.succ_lt_mono b a)). assumption. Qed. Example apply_tactic_fail (a b : nat) : a > b -> S a > b. MProof. intro H. Fail apply (proj1 (PeanoNat.Nat.succ_lt_mono b a)). Abort. Goal forall b1 b2 b3 : bool, andb b1 (andb b2 b3) = andb b1 (andb b2 b3). MProof. introsn 1. introsn 2. Fail introsn 1. introsn 0. reflexivity. Qed. Goal forall b1 b2 b3 : bool, andb b1 (andb b2 b3) = andb b1 (andb b2 b3). MProof. destructn 0. - destructn 1. + Fail destructn 0. select bool >>= destruct;; reflexivity. + select bool >>= destruct;; reflexivity. - introsn 2;; reflexivity. Qed. (* clear *) Goal forall (x : nat) (z : bool) (y : nat), x > y. MProof. intros x z y. clear z. Fail clear y. Abort. (* generalize *) Goal forall (x : nat) (z : bool) (y : nat), x > y. MProof. intros x z y. generalize x;; generalize y;; generalize z. Show Proof. Abort. (* move_back *) Goal forall (x : nat) (z : bool) (y : nat), x > y. MProof. intros x z y. cmove_back x (cmove_back y (clear z)). Abort. Goal forall x : Prop, x = x. MProof. auto. Qed. (** intros_all test *) Goal forall (x y z : nat) (H: x = y), y = x. MProof. intros. x <- select (_ = _); rewrite x. reflexivity. Qed. (** destruct_all *) Goal forall x y : bool, x && y = y && x. MProof. intros. destruct_all bool;; reflexivity. Qed. Goal forall x : bool, true = x. MProof. try (intros;; reflexivity). Abort. Goal forall x y : bool, x = y -> y = x. MProof. intros x y H. destruct x || idtac. (* should execute idtac because H depends on x *) cmove_back H ( destruct x;; destruct y;; intros;; (reflexivity || (symmetry;; assumption)) ). Qed. Goal True. MProof. cpose I (fun x=>idtac). exact I. Qed. Goal forall x:nat, x = x. MProof. trivial. Qed. Goal forall x:nat, forall y:nat, False -> x = 0. MProof. (** trivial is just testing that if it does not solve the goal, the goal is still there *) trivial;; intros;; contradiction. Qed. Import T. Import T.notations. Example ex_destr_not_var (b c: bool) : (if b && c then c else c) = c. MProof. pose (H := b && c). assert (Heq : H = b && c). - reflexivity. (* Set Printing All. *) (* - pose (T := tactic). *) (* pose (r := rewrite <- Heq : T). *) (* pose (d := destruct H : tactic). *) (* Set Printing Universes. *) (* pose (K := seq_one r d). *) (* pose (K:=(rewrite <- Heq);; destruct H). *) (* let K' := dreduce (K, (@seq)) K in *) (* pose (K'':= K'). *) (* K. ;; destruct H. ;; reflexivity. *) (* - (rewrite <- Heq);; destruct H;; reflexivity. *) (* Qed. *) Abort. Example fix_tac_ex: forall x:nat, 0 <= x. MProof. fix_tac (TheName "f") 1;; apply le_0_n. Qed. Example intros_def: let x := 0 in forall y, x <= y. MProof. intros. apply le_0_n. Qed. Example intros_def': let x := 0 in forall y, x <= y. MProof. intros x y. Ltac ind x :=induction x. ltac "mctacticstests.ind" [m:Dyn y];; apply le_0_n. Qed. Example test_unfold : id 0 = 0. MProof. unfold (@id). reflexivity. Qed. Mtac2-1.4-coq8.20/tests/min_bug_univpoly.v000066400000000000000000000350211472011217100203270ustar00rootroot00000000000000(* -*- mode: coq; coq-prog-args: ("-emacs" "-top" "min_bug_univpoly") -*- *) (* File reduced by coq-bug-finder from original input, then from 2673 lines to 1040 lines, then from 1056 lines to 1040 lines, then from 1055 lines to 696 lines, then from 704 lines to 696 lines *) (* coqc version 8.6.1 (August 2017) compiled on Aug 8 2017 15:55:58 with OCaml 4.02.3 coqtop version blackbox:/home/janno/.opam/ra-gps/build/coq.8.6.dev,master (6dbffe1db990966321ce47fede1840252dc67688) *) (* commenting this makes it work *) Set Universe Polymorphism. Unset Universe Minimization ToSet. Module Export AdmitTactic. Module Import LocalFalse. Inductive False := . End LocalFalse. Axiom proof_admitted : False. Tactic Notation "admit" := abstract case proof_admitted. End AdmitTactic. Require Coq.Strings.String. Module Import LocalFalse. Inductive False := . End LocalFalse. Inductive False := . Set Implicit Arguments. Inductive eq (A:Type) (x:A) : A -> Prop := eq_refl : x = x :>A where "x = y :> A" := (@eq A x y) : type_scope. Notation "x = y" := (x = y :>_) : type_scope. Notation "x <> y :> T" := (~ x = y :>T) : type_scope. Notation "x <> y" := (x <> y :>_) : type_scope. Arguments eq_refl {A x} , [A] x. Arguments eq_rect [A] x P _ y _ : rename. Section Logic_lemmas. Section equality. Variables A B : Type. Variable f : A -> B. Variables x y z : A. Theorem eq_sym : x = y -> y = x. admit. Defined. Theorem eq_trans : x = y -> y = z -> x = z. admit. Defined. Theorem f_equal : x = y -> f x = f y. admit. Defined. Theorem not_eq_sym : x <> y -> y <> x. admit. Defined. End equality. Definition eq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y. admit. Defined. Definition eq_rec_r : forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y = x -> P y. admit. Defined. Definition eq_rect_r : forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y = x -> P y. admit. Defined. End Logic_lemmas. Notation "'rew' H 'in' H'" := (eq_rect _ _ H' _ H) (at level 10, H' at level 10, format "'[' 'rew' H in '/' H' ']'"). Notation "'rew' [ P ] H 'in' H'" := (eq_rect _ P H' _ H) (at level 10, H' at level 10, format "'[' 'rew' [ P ] '/ ' H in '/' H' ']'"). Notation "'rew' <- H 'in' H'" := (eq_rect_r _ H' H) (at level 10, H' at level 10, format "'[' 'rew' <- H in '/' H' ']'"). Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a. admit. Defined. Lemma rew_opp_l : forall A (P:A->Type) (x y:A) (H:x=y) (a:P x), rew <- H in rew H in a = a. admit. Defined. Theorem f_equal2 : forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1) (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2. admit. Defined. Theorem f_equal3 : forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1) (x2 y2:A2) (x3 y3:A3), x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3. admit. Defined. Theorem f_equal4 : forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B) (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4), x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> f x1 x2 x3 x4 = f y1 y2 y3 y4. admit. Defined. Theorem f_equal5 : forall (A1 A2 A3 A4 A5 B:Type) (f:A1 -> A2 -> A3 -> A4 -> A5 -> B) (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4) (x5 y5:A5), x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> x5 = y5 -> f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5. admit. Defined. Theorem f_equal_compose : forall A B C (a b:A) (f:A->B) (g:B->C) (e:a=b), f_equal g (f_equal f e) = f_equal (fun a => g (f a)) e. admit. Defined. Theorem eq_trans_refl_l : forall A (x y:A) (e:x=y), eq_trans eq_refl e = e. admit. Defined. Theorem eq_trans_refl_r : forall A (x y:A) (e:x=y), eq_trans e eq_refl = e. admit. Defined. Theorem eq_sym_involutive : forall A (x y:A) (e:x=y), eq_sym (eq_sym e) = e. admit. Defined. Theorem eq_trans_sym_inv_l : forall A (x y:A) (e:x=y), eq_trans (eq_sym e) e = eq_refl. admit. Defined. Theorem eq_trans_sym_inv_r : forall A (x y:A) (e:x=y), eq_trans e (eq_sym e) = eq_refl. admit. Defined. Theorem eq_trans_assoc : forall A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t), eq_trans e (eq_trans e' e'') = eq_trans (eq_trans e e') e''. admit. Defined. Theorem eq_id_comm_l : forall A (f:A->A) (Hf:forall a, a = f a), forall a, f_equal f (Hf a) = Hf (f a). admit. Defined. Theorem eq_id_comm_r : forall A (f:A->A) (Hf:forall a, f a = a), forall a, f_equal f (Hf a) = Hf (f a). admit. Defined. Lemma eq_refl_map_distr : forall A B x (f:A->B), f_equal f (eq_refl x) = eq_refl (f x). admit. Defined. Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e'). admit. Defined. Lemma eq_sym_map_distr : forall A B (x y:A) (f:A->B) (e:x=y), eq_sym (f_equal f e) = f_equal f (eq_sym e). admit. Defined. Lemma eq_trans_sym_distr : forall A (x y z:A) (e:x=y) (e':y=z), eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e). admit. Defined. Lemma eq_trans_rew_distr : forall A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x), rew (eq_trans e e') in k = rew e' in rew e in k. admit. Defined. Lemma rew_const : forall A P (x y:A) (e:x=y) (k:P), rew [fun _ => P] e in k = k. admit. Defined. Inductive option (A:Type) : Type := | Some : A -> option A | None : option A. Arguments None {A}. Definition option_map (A B:Type) (f:A->B) (o : option A) : option B := match o with | Some a => @Some B (f a) | None => @None B end. Inductive sum (A B:Type) : Type := | inl : A -> sum A B | inr : B -> sum A B. Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. Notation "x * y" := (prod x y) : type_scope. Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. Inductive list (A : Type) : Type := | nil : list A | cons : A -> list A -> list A. Arguments nil {A}. Infix "::" := cons (at level 60, right associativity) : list_scope. Local Open Scope list_scope. Definition length (A : Type) : list A -> nat := fix length l := match l with | nil => O | _ :: l' => S (length l') end. Definition app (A : Type) : list A -> list A -> list A := fix app l m := match l with | nil => m | a :: l1 => a :: app l1 m end. Infix "++" := app (right associativity, at level 60) : list_scope. Notation "[m: ]" := nil (format "[m: ]") : list_scope. Notation "[m: x ]" := (cons x nil) : list_scope. Import Strings.String. Import NArith.BinNat. Unset Implicit Arguments. Inductive Exception : Type := exception : Exception. Definition NotUnifiable {A} (x y : A) : Exception. admit. Defined. Definition Failure (s : string) : Exception. admit. Defined. Definition NotAGoal : Exception. admit. Defined. Definition DoesNotMatch : Exception. admit. Defined. Definition NoPatternMatches : Exception. admit. Defined. Definition EmptyList : Exception. admit. Defined. Definition NotCumul {A B} (x: A) (y: B) : Exception. admit. Defined. Polymorphic Record dyn := Dyn { type : Type; elem :> type }. Inductive redlist A := rlnil | rlcons : A -> redlist A -> redlist A. Arguments rlnil {_}. Arguments rlcons {_} _ _. Notation "[rl: x ; .. ; y ]" := (rlcons x (.. (rlcons y rlnil) ..)). Inductive RedFlags := | RedBeta | RedDelta | RedMatch | RedFix | RedZeta | RedDeltaC | RedDeltaX | RedDeltaOnly : redlist dyn -> RedFlags | RedDeltaBut : redlist dyn -> RedFlags. Inductive Reduction := | RedNone | RedSimpl | RedOneStep | RedWhd : redlist RedFlags -> Reduction | RedStrong : redlist RedFlags -> Reduction | RedVmCompute. Inductive Unification : Set := | UniCoq : Unification | UniMatch : Unification | UniMatchNoRed : Unification | UniEvarconv : Unification. Inductive Hyp : Type := | ahyp : forall {A}, A -> option A -> Hyp. Record Case := mkCase { case_ind : Type; case_val : case_ind; case_return : dyn; case_branches : list dyn }. Definition reduce (r : Reduction) {A} (x : A) := x. Notation rone_step := (reduce RedOneStep). Inductive goal := | Goal : forall {A}, A -> goal | AHyp : forall {A}, option A -> (A -> goal) -> goal | HypRem : forall {A}, A -> goal -> goal. Inductive pattern (M : Type -> Type) (A : Type) (B : A -> Type) (y : A) : Prop := | pbase : forall x : A, (y = x -> M (B x)) -> Unification -> pattern M A B y | ptele : forall {C}, (forall x : C, pattern M A B y) -> pattern M A B y. Arguments pbase {M A B y} _ _ _. Arguments ptele {M A B y C} _. Declare Scope pattern_scope. Notation "[? x .. y ] ps" := (ptele (fun x => .. (ptele (fun y => ps)).. )) (at level 202, x binder, y binder, ps at next level) : pattern_scope. Notation "p => [ H ] b" := (pbase p%core (fun H => b%core) UniMatch) (no associativity, at level 201, H at next level) : pattern_scope. Notation "'_' => b " := (ptele (fun x=> pbase x (fun _ => b%core) UniMatch)) (at level 201, b at next level) : pattern_scope. Notation "p '=n>' b" := (pbase p%core (fun _ => b%core) UniMatchNoRed) (no associativity, at level 201) : pattern_scope. Notation "p '=n>' [ H ] b" := (pbase p%core (fun H => b%core) UniMatchNoRed) (no associativity, at level 201, H at next level) : pattern_scope. Notation "p '=u>' b" := (pbase p%core (fun _ => b%core) UniCoq) (no associativity, at level 201) : pattern_scope. Notation "p '=u>' [ H ] b" := (pbase p%core (fun H => b%core) UniCoq) (no associativity, at level 201, H at next level) : pattern_scope. Delimit Scope pattern_scope with pattern. Declare Scope with_pattern_scope. Notation "'with' | p1 | .. | pn 'end'" := ((@cons (pattern _ _ _ _) p1%pattern (.. (@cons (pattern _ _ _ _) pn%pattern nil) ..))) (at level 91, p1 at level 210, pn at level 210) : with_pattern_scope. Notation "'with' p1 | .. | pn 'end'" := ((@cons (pattern _ _ _ _) p1%pattern (.. (@cons (pattern _ _ _ _) pn%pattern nil) ..))) (at level 91, p1 at level 210, pn at level 210) : with_pattern_scope. Delimit Scope with_pattern_scope with with_pattern. Inductive t@{U1 U2 E1 L1 H1 O1} : Type@{U1} -> Prop := | ret : forall {A : Type@{U1}}, A -> t A | bind : forall {A : Type@{U1}} {B : Type@{U1}}, t A -> (A -> t B) -> t B | mtry' : forall {A : Type@{U1}}, t A -> (Exception@{E1} -> t A) -> t A | raise : forall {A : Type@{U1}}, Exception@{E1} -> t A | nu : forall {A : Type@{U1}} {B : Type@{U1}}, string -> option A -> (A -> t B) -> t B | gen_evar : forall (A : Type@{U1}), option (list@{L1} Hyp@{H1}) -> t A | unify {A : Type@{U2}} (x y : A) : Unification -> t (option@{O1} (x = y)) | unify_univ (A B : Type@{U1}) : Unification -> t (option (A -> B)) . (* Inductive t : Type -> Prop := *) (* | ret : forall {A : Type}, A -> t A *) (* | bind : forall {A : Type} {B : Type}, *) (* t A -> (A -> t B) -> t B *) (* | mtry' : forall {A : Type}, t A -> (Exception -> t A) -> t A *) (* | raise : forall {A : Type}, Exception -> t A *) (* | nu : forall {A : Type} {B : Type}, string -> option A -> (A -> t B) -> t B *) (* | gen_evar : forall (A : Type), option (list Hyp) -> t A *) (* | unify {A : Type} (x y : A) : Unification -> t (option (x = y)) *) (* | unify_univ (A B : Type) : Unification -> t (option (A -> B)) *) (* . *) Definition evar (A : Type) : t A := gen_evar A None. Definition failwith {A} (s : string) : t A := raise (Failure s). (* Definition print_term {A} (x : A) : t unit := *) (* bind (pretty_print x) (fun s=> print s). *) Module Export monad_notations. Declare Scope M_scope. Delimit Scope M_scope with MC. Open Scope M_scope. Notation "r '<-' t1 ';' t2" := (@bind _ _ t1 (fun r=> t2%MC)) (at level 81, right associativity, format "'[' r '<-' '[' t1 ; ']' ']' '/' t2 ") : M_scope. Notation "t1 ';;' t2" := (bind t1 (fun _ => t2%MC)) (at level 81, right associativity, format "'[' '[' t1 ;; ']' ']' '/' t2 ") : M_scope. Notation "t >>= f" := (bind t f) (at level 70) : M_scope. Notation "'mif' b 'then' t 'else' u" := (cond <- b; if cond then t else u) (at level 200) : M_scope. End monad_notations. Fixpoint open_pattern {A P y} (p : pattern t A P y) : t (P y) := match p with | pbase x f u => oeq <- unify x y u; match oeq return t (P y) with | Some eq => let h := reduce (RedStrong [rl:RedBeta;RedDelta;RedMatch]) (eq_sym eq) in let 'eq_refl := eq in let b := reduce (RedStrong [rl:RedBeta]) (f h) in b | None => raise DoesNotMatch end | @ptele _ _ _ _ C f => e <- evar C; open_pattern (f e) end. Fixpoint mmatch' {A P} (y : A) (ps : list (pattern t A P y)) : t (P y) := match ps with | [m:] => raise NoPatternMatches | p :: ps' => mtry' (open_pattern p) (fun e => mif unify e DoesNotMatch UniMatchNoRed then mmatch' y ps' else raise e) end. Module Export notations. Export monad_notations. (* Notation "'mfix1' f ( x : A ) : 'M' T := b" := *) (* (fix1 (fun x=>T%type) (fun f (x : A)=>b%MC)) *) (* (at level 85, f at level 0, x at next level, format *) (* "'[v ' 'mfix1' f '(' x ':' A ')' ':' 'M' T ':=' '/ ' b ']'") : M_scope. *) Notation "'mmatch' x ls" := (@mmatch' _ (fun _ => _) x ls%with_pattern) (at level 90, ls at level 91) : M_scope. End notations. Definition unify_cumul {A B} (x: A) (y: B) (u : Unification) : t bool := of <- unify_univ A B u; match of with | Some f => let fx := reduce RedOneStep (f x) in oeq <- unify fx y u; match oeq with Some _ => ret true | None => ret false end | None => ret false end. (* UNCOMMENT THE NEXT TWO COMMENTS TO MAKE IT COMPILE *) (* Unset Universe Polymorphism. *) Definition cumul_or_fail {A B} (x: A) (y: B) : t unit := b <- unify_cumul x y UniCoq; if b then ret tt else raise (NotCumul x y). (* Set Universe Polymorphism. *) Notation M := t. Import notations. Definition NotAProduct : Exception. admit. Defined. Definition gtactic (A : Type) := goal -> M (list (A * goal)). Notation tactic := (gtactic unit). Definition exact {A} (x:A) : tactic := fun g => match g with | Goal g => cumul_or_fail x g;; ret [m:] | _ => raise NotAGoal end. Fail Definition intro_base {A B} (var : string) (t : A -> gtactic B) : gtactic B := fun g => mmatch g with | [? P e] @Goal (forall x:A, P x) e =u> @nu nat _ var None (fun x=> exact nat g;; raise exception) | _ => raise NotAProduct end. Mtac2-1.4-coq8.20/tests/min_bug_univpoly2.v000066400000000000000000000042201472011217100204060ustar00rootroot00000000000000(* -*- mode: coq; coq-prog-args: ("-emacs" "-R" "." "Top" "-top" "min_bug_poly2") -*- *) (* File reduced by coq-bug-finder from original input, then from 469 lines to 112 lines, then from 128 lines to 112 lines *) (* coqc version 8.6.1 (August 2017) compiled on Aug 22 2017 10:37:48 with OCaml 4.02.3 coqtop version 8.6.1 (August 2017) *) Axiom proof_admitted : False. Tactic Notation "admit" := abstract case proof_admitted. (* commenting this makes it work *) Set Universe Polymorphism. Inductive list (A : Type) : Type := | nil : list A | cons : A -> list A -> list A. Arguments nil {A}. Local Open Scope list_scope. Notation "[m: ]" := nil (format "[m: ]") : list_scope. Inductive option A := Some : A -> option A | None. Arguments Some {A} _. Arguments None {A}. Inductive eq {A : Type} (x : A) : A -> Prop := eq_refl : eq x x. Arguments eq_refl {A} _. Inductive goal := | Goal : forall {A}, A -> goal. Inductive t : Type -> Prop := | ret : forall {A : Type}, A -> t A | bind : forall {A : Type} {B : Type}, t A -> (A -> t B) -> t B | unify {A : Type} (x y : A) : t (option (x = y)) | unify_univ (A B : Type) : t (option (A -> B)) . Declare Scope M_scope. Delimit Scope M_scope with MC. Open Scope M_scope. Notation "r '<-' t1 ';' t2" := (@bind _ _ t1 (fun r=> t2%MC)) (at level 81, right associativity, format "'[' r '<-' '[' t1 ; ']' ']' '/' t2 ") : M_scope. Notation "t1 ';;' t2" := (bind t1 (fun _ => t2%MC)) (at level 81, right associativity, format "'[' '[' t1 ;; ']' ']' '/' t2 ") : M_scope. Notation "t >>= f" := (bind t f) (at level 70) : M_scope. Definition unify_cumul {A B} (x: A) (y: B) : t bool := of <- unify_univ A B; match of with | Some f => let fx := f x in oeq <- unify fx y; match oeq with Some _ => ret true | None => ret false end | None => ret false end. Definition cumul_or_fail {A B} (x: A) (y: B) : t unit := b <- unify_cumul x y; ret tt. Notation M := t. Definition gtactic (A : Type) := goal -> M (list (A * goal)). Notation tactic := (gtactic unit). Fail Definition exact {A} (x:A) : tactic := fun g => match g with | Goal g => cumul_or_fail x g;; ret [m:] end. Mtac2-1.4-coq8.20/tests/mode.v000066400000000000000000000001221472011217100156600ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Goal True. MProof. Abort. Goal True. MProof. Abort. Mtac2-1.4-coq8.20/tests/mono_list_issue.v000066400000000000000000000030661472011217100201610ustar00rootroot00000000000000Module MonoList. From Coq Require Import List. Import ListNotations. Class MBind (M : Type -> Type) := mbind : forall {A B}, (A -> M B) -> M A -> M B. #[global] Instance list_bind : MBind list := fun A B f => fix go (l : list A) := match l with nil => nil | cons x l => f x ++ go l end%list. Set Printing Universes. Polymorphic Record dyn := Dyn { type : Type; elem : type }. Fail Definition fails : list dyn := [Dyn _ (@List.app)]. End MonoList. Module PolyList. Polymorphic Inductive list (A : Type) : Type := nil : list A | cons : A -> list A -> list A. Arguments nil {A}. Arguments cons {A} a l. Infix "::" := cons (at level 60, right associativity) : list_scope. Delimit Scope list_scope with list. Bind Scope list_scope with list. Local Open Scope list_scope. Definition app (A : Type) : list A -> list A -> list A := fix app l m := match l with | nil => m | a :: l1 => a :: app l1 m end. Arguments app {_}. Infix "++" := app (right associativity, at level 60) : list_scope. Notation "[ ]" := nil (format "[ ]") : list_scope. Notation "[ x ]" := (cons x nil) : list_scope. Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)) : list_scope. Class MBind (M : Type -> Type) := mbind : forall {A B}, (A -> M B) -> M A -> M B. #[global] Instance list_bind : MBind list := fun A B f => fix go (l : list A) := match l with nil => nil | cons x l => f x ++ go l end%list. Set Printing Universes. Polymorphic Record dyn := Dyn { type : Type; elem : type }. Definition doesnotfail : list dyn := [Dyn _ (@List.app)]. End PolyList.Mtac2-1.4-coq8.20/tests/mrun.v000066400000000000000000000015421472011217100157240ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Example trivial : True. Proof. mrun (M.ret I). Qed. Example exact : True. Proof. mrun (T.exact I). Qed. Example destruct : nat -> True. Proof. mrun (T.destructn 0). - mrun (T.exact I). - mrun (T.introsn 1;; T.exact I). Qed. Example destruct2 : nat -> True. Proof. mrun (T.destructn 0); [mrun (T.exact I) | mrun (T.introsn 1;; T.exact I)]. Qed. Definition MTrue := M.ret I. Ltac mrun_static_tac1 := mrun_static MTrue. Example mrun_static_ex1 : True. Proof. mrun_static_tac1. Qed. Definition TTrue := T.exact I. Ltac mrun_static_tac2 := mrun_static TTrue. Example mrun_static_ex2 : True. Proof. mrun_static_tac2. Qed. Fail Ltac mrun_static_tac3 := mrun_static I. Definition Munit := M.ret tt. Ltac mrun_static_tac4 := mrun_static Munit. Example mrun_static_ex4 : True. Proof. Fail mrun_static_tac4. Abort.Mtac2-1.4-coq8.20/tests/names.v000066400000000000000000000004051472011217100160430ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Goal True -> True. MProof. mtry (T.intro_base (TheName "x x") (fun _=>T.idtac)) with [? x] InvalidName x => T.idtac end. mtry (T.intro_base (FreshFromStr "x x") (fun _=>T.idtac)) with [? x] InvalidName x => T.idtac end. Abort. Mtac2-1.4-coq8.20/tests/nu_let.v000066400000000000000000000011131472011217100162230ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Require Import Bool.Bool. Example hyp_well_formed : True. MProof. (\nu x := I, l <- M.hyps; oeq <- M.unify l [m: ahyp x (mSome I)] UniCoq; match oeq with | mNone => M.raise exception | _ => M.ret I end)%MC. Qed. Example env_well_formed : True. MProof. (\nu x := I, oeq <- M.unify x I UniCoq; match oeq with | mNone => M.raise exception | _ => M.ret I end)%MC. Qed. Example fail_returning_var : True. MProof. (mtry (\nu x := I, M.ret x);; M.raise exception with VarAppearsInValue => M.ret I end)%MC. Qed. Mtac2-1.4-coq8.20/tests/pretype.v000066400000000000000000000014211472011217100164270ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Definition ex1 := fun x:nat=>ltac:(mrun (M.ret x)). Definition ex2 := fun x y:nat=>ltac:(mrun (M.ret (x + y))). Definition ex3 := fun (x y:nat) (H : x < y) =>ltac:(mrun (M.ret H)). Section test. Variable x : nat. Definition ex4 := fun x y:nat=>ltac:(mrun (M.ret (x + y))). Definition ex4l := fun x y:nat=>ltac:(exact (x + y)). Definition ex4plain := fun x y:nat=>x + y. (* It is interpreting that the x comes from the Variable. That is a bug in Coq. For the moment we take it as if that is the expected behavior. *) Definition testex4 : ex4 = ex4l := eq_refl. (* We do what must be done: rewrite x to be x0 *) Definition ex5_eval := fun x y:nat=>M.eval (M.ret (x + y)). Definition testex5 : ex5_eval = ex4plain := eq_refl. End test. Mtac2-1.4-coq8.20/tests/reduction.v000066400000000000000000000113171472011217100167400ustar00rootroot00000000000000From Mtac2 Require Import Datatypes Mtac2. Require Import Lists.List. Import ListNotations. (** assert x y e asserts that y is syntactically equal to x. Since we need to make sure the convertibility check is not triggered, we assume the terms x and/or y contains an evar e that is instantiated with tt. *) Definition assert_eq {A} (x y: A) : M unit := o1 <- M.unify x y UniMatchNoRed; match o1 with | mSome _ => M.ret tt | _ => M.raise (NotUnifiable x y) end. Example reduce_no_reduction : unit. MProof. (* testing the eq check: it should fail *) Fail let x := reduce RedNone ((fun x=>x) tt) in assert_eq x tt. Fail let x := reduce RedNone ((fun x=>x) tt) in assert_eq tt x. let x := reduce RedNone ((fun x=>x) tt) in assert_eq ((fun x=>x) tt) x. Qed. Example reduce_simpl : unit. MProof. let x := reduce RedSimpl ((fun x=>x) tt) in assert_eq x tt. Qed. Example reduce_one_step : unit. MProof. let x := reduce (RedOneStep [rl:RedBeta]) ((fun x y=>x) tt tt) in assert_eq x ((fun y=>tt) tt). Qed. Example reduce_one_wrong_step_does_nothing : unit. MProof. let x := reduce (RedOneStep [rl:RedDelta]) ((fun x y=>x) tt tt) in assert_eq x ((fun x y=>x) tt tt). Qed. Example reduce_whd : unit. MProof. let x := reduce RedHNF (id ((fun x=>x) tt)) in assert_eq x tt. Qed. Example is_not_breaking_letins : True. MProof. let x := M.ret _ in x. Unshelve. let x := id I in M.ret x. Qed. Print is_not_breaking_letins. Example reduce_beta : unit. MProof. let x := reduce (RedWhd [rl:RedBeta]) (id ((fun x=>x) tt)) in assert_eq x (id ((fun x=>x) tt)). Qed. Example reduce_beta2 : unit. MProof. let x := reduce (RedWhd [rl:RedBeta]) ((fun x=>x) (fun x=>x) tt) in assert_eq x tt. Qed. Example reduce_BetaDeltaIota : unit. MProof. let x := reduce (RedWhd [rl:RedBeta;RedDelta;RedMatch]) (elemr (Dynr (let t := tt in t))) in assert_eq x (let t := tt in t). Qed. Section ASection. Let p := 0. Example reduce_BetaDeltaIotaP : unit. MProof. let x := reduce (RedWhd [rl:RedBeta;RedDelta;RedMatch]) (elemr (Dynr (fst (p, tt)))) in assert_eq x 0. Qed. Example reduce_OneStepDyn : nat. MProof. let x := reduce (RedOneStep [rl:RedDelta]) (elemr (Dynr p)) in let x := reduce (RedWhd [rl:RedBeta;RedMatch]) x in M.ret x. Qed. Example reduce_deltac : unit. MProof. let x := reduce (RedWhd [rl:RedBeta;RedMatch;RedDeltaC]) (elemr (Dynr (fst (p, tt)))) in assert_eq x p. Qed. Example reduce_deltax : unit. MProof. let x := reduce (RedStrong [rl:RedBeta;RedMatch;RedDeltaX]) (elemr (Dynr (fst (p, tt)))) in assert_eq x (elemr (Dynr (fst (0, tt)))). Qed. Definition test_opaque : nat. exact 0. Qed. Example reduce_deltac_opaque : unit. MProof. let x := reduce (RedWhd [rl:RedBeta;RedMatch;RedDeltaC]) (elemr (Dynr (fst (test_opaque, tt)))) in assert_eq x test_opaque. Qed. End ASection. Example reduction_only : unit. MProof. (e <- M.evar unit; n <- M.evar nat; let x := reduce (RedStrong [rl:RedDeltaOnly [rl:Dyn (@id)]]) (id ((fun x:nat=>x) n)) in assert_eq x ((fun A (x:A)=>x) nat ((fun x:nat=>x) n)))%MC. Unshelve. M.ret tt. M.ret 0. Qed. Example reduction_only2 : unit. MProof. Fail (e <- M.evar unit; n <- M.evar nat; let x := reduce (RedStrong [RedBeta; RedDeltaOnly [Dyn (@id)]]) (id ((fun x=>x)) (n+0)) in assert_eq x ((fun A (x:A)=>x) nat ((fun x=>x) (n + 0))))%MC. (n <- M.evar nat; let x := reduce (RedStrong [rl:RedBeta; RedDeltaOnly [rl:Dyn (@id)]]) (id ((fun x=>x)) (n+0)) in M.unify n 0 UniMatchNoRed;; M.ret tt)%MC. Qed. Set Nested Proofs Allowed. Example reduction_but : unit. MProof. (e <- M.evar unit; n <- M.evar nat; let x := reduce (RedStrong [rl:RedBeta;RedMatch;RedFix;RedDeltaBut [rl:Dyn (@id)]]) (id (fun x=>x) ((fun x=>x) (0 + n))) in assert_eq x (id (fun x=>x) n))%MC. Unshelve. M.ret tt. M.ret 0. Qed. Fixpoint fib (n : nat) := match n with | 0 => 1 | S n' => match n' with | 0 => 1 | S n'' => fib n' + fib n'' end end. Example reducion_cbv : nat. MProof. Time let res := reduce RedNF (fib 20) in M.ret res. Qed. Example reducion_vm : nat. MProof. Time let res := reduce RedVmCompute (fib 20) in M.ret res. Qed. Example shouldn_t_fail_horribly_with_bad_ref : unit. MProof. (mtry let x := reduce (RedStrong [rl: RedDeltaOnly [rl: Dyn "x"]]) 0 in M.failwith "Shouldn't be here" with ReductionFailure => M.ret tt end)%MC. Qed. Example shouldn_t_fail_horribly_with_bad_reduction (r: Reduction) : unit. MProof. (mtry let x := reduce r 0 in M.failwith "Shouldn't be here" with ReductionFailure => M.ret tt end)%MC. Qed. Local Declare Reduction mtac2_test_reduction := lazy beta delta [id]. Example declare_reduction_test : unit. MProof. let t := reduce (RedReduction "mtac2_test_reduction") (id (1+1)) in mmatch t with | 1+1 =n> M.ret tt end. Qed. Mtac2-1.4-coq8.20/tests/reif_jason.v000066400000000000000000000546451472011217100170760ustar00rootroot00000000000000Require Import Coq.ZArith.ZArith. Require Import Coq.Lists.List. Set Implicit Arguments. Reserved Notation "'dlet' x .. y := v 'in' f" (at level 200, x binder, y binder, f at level 200, format "'dlet' x .. y := v 'in' '//' f"). Reserved Notation "'nllet' x .. y := v 'in' f" (at level 200, x binder, y binder, f at level 200, format "'nllet' x .. y := v 'in' '//' f"). Reserved Notation "'elet' x := v 'in' f" (at level 200, f at level 200, format "'elet' x := v 'in' '//' f"). Definition Let_In {A P} (v : A) (f : forall x : A, P x) : P v := let x := v in f x. Notation "'dlet' x .. y := v 'in' f" := (Let_In v (fun x => .. (fun y => f) .. )). Definition Let_In_nat : nat -> (nat -> nat) -> nat := (@Let_In nat (fun _ => nat)). Definition key : unit. exact tt. Qed. Definition lock {A} (v : A) : A := match key with tt => v end. Lemma unlock {A} (v : A) : lock v = v. Proof. unfold lock; destruct key; reflexivity. Qed. Definition LockedLet_In_nat : nat -> (nat -> nat) -> nat := lock Let_In_nat. Definition locked_nat_mul := lock Nat.mul. Notation "'nllet' x .. y := v 'in' f" := (LockedLet_In_nat v (fun x => .. (fun y => f) .. )). Definition lock_Let_In_nat : @Let_In nat (fun _ => nat) = LockedLet_In_nat := eq_sym (unlock _). Definition lock_Nat_mul : Nat.mul = locked_nat_mul := eq_sym (unlock _). Module Import PHOAS. Inductive expr {var : Type} : Type := | NatO : expr | NatS : expr -> expr | LetIn (v : expr) (f : var -> expr) | Var (v : var) | NatMul (x y : expr). Declare Scope expr_scope. Bind Scope expr_scope with expr. Delimit Scope expr_scope with expr. Infix "*" := NatMul : expr_scope. Notation "'elet' x := v 'in' f" := (LetIn v (fun x => f%expr)) : expr_scope. Notation "$$ x" := (Var x) (at level 9, format "$$ x") : expr_scope. Fixpoint denote (e : @expr nat) : nat := match e with | NatO => O | NatS x => S (denote x) | LetIn v f => dlet x := denote v in denote (f x) | Var v => v | NatMul x y => denote x * denote y end. Definition Expr := forall var, @expr var. Definition Denote (e : Expr) := denote (e _). End PHOAS. (* cf COQBUG(https://github.com/coq/coq/issues/5448), COQBUG(https://github.com/coq/coq/issues/6315) *) Ltac refresh n := let n' := fresh n in let n' := fresh n in n'. Ltac Reify_of reify x := constr:(fun var : Type => ltac:(let v := reify var x in exact v)). Ltac error_cant_elim_deps f := let __ := match goal with | _ => idtac "Failed to eliminate functional dependencies in" f end in constr:(I : I). Ltac error_bad_function f := let __ := match goal with | _ => idtac "Bad let-in function" f end in constr:(I : I). Ltac error_bad_term term := let __ := match goal with | _ => idtac "Unrecognized term:" term end in let ret := constr:(term : I) in constr:(I : I). (** Take care of initial locking of mul, letin, etc. *) Ltac make_pre_Reify_rhs nat_of untag do_lock_letin do_lock_natmul := let RHS := lazymatch goal with |- _ = ?RHS => RHS end in let e := fresh "e" in let T := fresh in evar (T : Type); evar (e : T); subst T; cut (untag (nat_of e) = RHS); [ subst e | lazymatch do_lock_letin with | true => rewrite ?lock_Let_In_nat | false => idtac end; lazymatch do_lock_natmul with | true => rewrite ?lock_Nat_mul | false => idtac end; cbv [e]; clear e ]. Fixpoint big (a : nat) (sz : nat) : nat := match sz with | O => a | S sz' => dlet a' := a * a in big a' sz' end. Definition big_flat_op {T} (op : T -> T -> T) (a : T) (sz : nat) : T := Eval cbv [Z_of_nat Pos.of_succ_nat Pos.iter_op Pos.succ] in match Z_of_nat sz with | Z0 => a | Zpos p => Pos.iter_op op p a | Zneg p => a end. Definition big_flat (a : nat) (sz : nat) : nat := big_flat_op Nat.mul a sz. Module CanonicalStructuresPHOAS. (** * Canonical-structure based reification to [@expr nat], with let-binders *) Local Notation context := (list nat). Structure tagged_nat (ctx : context) := tag { untag :> nat }. Structure reified_of (ctx : context) := reify { nat_of : tagged_nat ctx ; reified_nat_of :> forall var, list var -> (forall T, T) -> @expr var }. Definition var_tl_tag := tag. Definition var_hd_tag := var_tl_tag. Definition S_tag := var_hd_tag. Definition O_tag := S_tag. Definition mul_tag := O_tag. (** N.B. [Canonical] structures follow [Import], so they must be imported for reification to work. *) Module Export Exports. Canonical Structure letin_tag ctx n := mul_tag ctx n. Canonical Structure reify_O ctx := reify (O_tag ctx 0) (fun var _ _ => @NatO var). Canonical Structure reify_S ctx x := reify (@S_tag ctx (S (@nat_of ctx x))) (fun var vs phantom => @NatS var (x var vs phantom)). Canonical Structure reify_mul ctx x y := reify (@mul_tag ctx (@nat_of ctx x * @nat_of ctx y)) (fun var vs phantom => @NatMul var (x var vs phantom) (y var vs phantom)). Canonical Structure reify_var_hd n ctx := reify (var_hd_tag (n :: ctx) n) (fun var vs phantom => @Var var (List.hd (phantom _) vs)). Canonical Structure reify_var_tl n ctx x := reify (var_tl_tag (n :: ctx) (@nat_of ctx x)) (fun var vs phantom => reified_nat_of x (List.tl vs) phantom). Canonical Structure reify_letin ctx v f := reify (letin_tag ctx (nllet x := @nat_of ctx v in @nat_of (x :: ctx) (f x))) (fun var vs phantom => elet x := reified_nat_of v vs phantom in reified_nat_of (f (phantom _)) (x :: vs) phantom)%expr. End Exports. Definition ReifiedNatOf (e : reified_of nil) : (forall T, T) -> Expr := fun phantom var => reified_nat_of e nil phantom. Ltac pre_Reify_rhs _ := make_pre_Reify_rhs (@nat_of nil) (@untag nil) true false. End CanonicalStructuresPHOAS. Export CanonicalStructuresPHOAS.Exports. Module LtacTacInTermExplicitCtx. Module var_context. Inductive var_context {var : Type} := nil | cons (n : nat) (v : var) (xs : var_context). End var_context. Ltac reify_helper var term ctx := let reify_rec term := reify_helper var term ctx in lazymatch ctx with | context[var_context.cons term ?v _] => constr:(@Var var v) | _ => lazymatch term with | O => constr:(@NatO var) | S ?x => let rx := reify_rec x in constr:(@NatS var rx) | ?x * ?y => let rx := reify_rec x in let ry := reify_rec y in constr:(@NatMul var rx ry) | (dlet x := ?v in ?f) => let rv := reify_rec v in let not_x := refresh x in let not_x2 := refresh not_x in let not_x3 := refresh not_x2 in let rf := lazymatch constr:( fun (x : nat) (not_x : var) => match f, @var_context.cons var x not_x ctx return @expr var with (* c.f. COQBUG(https://github.com/coq/coq/issues/6252#issuecomment-347041995) for [return] *) | not_x2, not_x3 => ltac:(let fx := (eval cbv delta [not_x2] in not_x2) in let ctx := (eval cbv delta [not_x3] in not_x3) in clear not_x2 not_x3; let rf := reify_helper var fx ctx in exact rf) end) with | fun _ => ?f => f | ?f => error_cant_elim_deps f end in constr:(@LetIn var rv rf) | ?v => error_bad_term v end end. Ltac reify var x := reify_helper var x (@var_context.nil var). Ltac Reify x := Reify_of reify x. End LtacTacInTermExplicitCtx. (* Require Ltac2.Ltac2. Module Import Ltac2Common. Import Ltac2.Init. Import Ltac2.Notations. Module List. Ltac2 rec map f ls := match ls with | [] => [] | l :: ls => f l :: map f ls end. End List. Module Ident. Ltac2 rec find_error id xs := match xs with | [] => None | x :: xs => let ((id', val)) := x in match Ident.equal id id' with | true => Some val | false => find_error id xs end end. Ltac2 find id xs := match find_error id xs with | None => Control.zero Not_found | Some val => val end. End Ident. Module Array. Ltac2 rec to_list_aux (ls : 'a array) (start : int) := match Int.equal (Int.compare start (Array.length ls)) -1 with | true => Array.get ls start :: to_list_aux ls (Int.mul start 1) | false => [] end. Ltac2 to_list (ls : 'a array) := to_list_aux ls 0. End Array. Module Constr. Ltac2 rec strip_casts term := match Constr.Unsafe.kind term with | Constr.Unsafe.Cast term' _ _ => strip_casts term' | _ => term end. Module Unsafe. Ltac2 beta1 (c : constr) := match Constr.Unsafe.kind c with | Constr.Unsafe.App f args => match Constr.Unsafe.kind f with | Constr.Unsafe.Lambda id ty f => Constr.Unsafe.substnl (Array.to_list args) 0 f | _ => c end | _ => c end. Ltac2 zeta1 (c : constr) := match Constr.Unsafe.kind c with | Constr.Unsafe.LetIn id v ty f => Constr.Unsafe.substnl [v] 0 f | _ => c end. End Unsafe. End Constr. Module Ltac1. Class Ltac1Result {T} (v : T) := {}. Class Ltac1Results {T} (v : list T) := {}. Class Ltac2Result {T} (v : T) := {}. Ltac save_ltac1_result v := match goal with | _ => assert (Ltac1Result v) by constructor end. Ltac clear_ltac1_results _ := match goal with | _ => repeat match goal with | [ H : Ltac1Result _ |- _ ] => clear H end end. Ltac2 get_ltac1_result () := (lazy_match! goal with | [ id : Ltac1Result ?v |- _ ] => Std.clear [id]; v end). Ltac save_ltac1_results v := match goal with | _ => assert (Ltac1Result v) by constructor end. Ltac2 save_ltac2_result v := Std.cut '(Ltac2Result $v); Control.dispatch [(fun () => Std.intros false [Std.IntroNaming (Std.IntroFresh @res)]) ; (fun () => Notations.constructor)]. Ltac get_ltac2_result _ := lazymatch goal with | [ res : Ltac2Result ?v |- _ ] => let __ := match goal with | _ => clear res end in v end. Ltac2 from_ltac1 (save_args : constr) (tac : unit -> unit) := let beta_flag := { Std.rBeta := true; Std.rMatch := false; Std.rFix := false; Std.rCofix := false; Std.rZeta := false; Std.rDelta := false; Std.rConst := []; } in let c := '(ltac2:(save_ltac2_result save_args; tac (); let v := get_ltac1_result () in Control.refine (fun () => v))) in Constr.Unsafe.zeta1 (Constr.Unsafe.zeta1 (Std.eval_cbv beta_flag c)). End Ltac1. End Ltac2Common. Module Ltac2LowLevel. Import Ltac2.Init. Import Ltac2.Notations. Ltac2 rec unsafe_reify_helper (mkVar : constr -> 'a) (mkO : 'a) (mkS : 'a -> 'a) (mkNatMul : 'a -> 'a -> 'a) (mkLetIn : 'a -> ident option -> constr -> 'a -> 'a) (gO : constr) (gS : constr) (gNatMul : constr) (gLetIn : constr) (unrecognized : constr -> 'a) (term : constr) := let reify_rec term := unsafe_reify_helper mkVar mkO mkS mkNatMul mkLetIn gO gS gNatMul gLetIn unrecognized term in let kterm := Constr.Unsafe.kind term in match Constr.equal term gO with | true => mkO | false => match kterm with | Constr.Unsafe.Rel _ => mkVar term | Constr.Unsafe.Var _ => mkVar term | Constr.Unsafe.Cast term _ _ => reify_rec term | Constr.Unsafe.App f args => match Constr.equal f gS with | true => let x := Array.get args 0 in let rx := reify_rec x in mkS rx | false => match Constr.equal f gNatMul with | true => let x := Array.get args 0 in let y := Array.get args 1 in let rx := reify_rec x in let ry := reify_rec y in mkNatMul rx ry | false => match Constr.equal f gLetIn with | true => let x := Array.get args 2 (* assume the first two args are type params *) in let f := Array.get args 3 in match Constr.Unsafe.kind f with | Constr.Unsafe.Lambda idx ty body => let rx := reify_rec x in let rf := reify_rec body in mkLetIn rx idx ty rf | _ => unrecognized term end | false => unrecognized term end end end | _ => unrecognized term end end. Ltac2 unsafe_reify (var : constr) (term : constr) := let cVar := '@Var in let cO := '@NatO in let cS := '@NatS in let cNatMul := '@NatMul in let cLetIn := '@LetIn in let gO := 'O in let gS := 'S in let gNatMul := '@Nat.mul in let gLetIn := '@Let_In in let mk0VarArgs := let args := Array.make 1 var in args in let mk1VarArgs (x : constr) := let args := Array.make 2 var in let () := Array.set args 1 x in args in let mk2VarArgs (x : constr) (y : constr) := let args := Array.make 3 var in let () := Array.set args 1 x in let () := Array.set args 2 y in args in let mkApp0 (f : constr) := Constr.Unsafe.make (Constr.Unsafe.App f mk0VarArgs) in let mkApp1 (f : constr) (x : constr) := Constr.Unsafe.make (Constr.Unsafe.App f (mk1VarArgs x)) in let mkApp2 (f : constr) (x : constr) (y : constr) := Constr.Unsafe.make (Constr.Unsafe.App f (mk2VarArgs x y)) in let mkVar (v : constr) := mkApp1 cVar v in let mkO := mkApp0 cO in let mkS (v : constr) := mkApp1 cS v in let mkNatMul (x : constr) (y : constr) := mkApp2 cNatMul x y in let mkcLetIn (x : constr) (y : constr) := mkApp2 cLetIn x y in let mkLetIn (x : constr) (idx : ident option) (ty : constr) (fbody : constr) := mkcLetIn x (Constr.Unsafe.make (Constr.Unsafe.Lambda idx var fbody)) in let ret := unsafe_reify_helper mkVar mkO mkS mkNatMul mkLetIn gO gS gNatMul gLetIn (fun term => term) term in ret. Ltac2 check_result (ret : constr) := match Constr.Unsafe.check ret with | Val rterm => rterm | Err exn => Control.zero exn end. Ltac2 reify (var : constr) (term : constr) := check_result (unsafe_reify var term). Ltac2 unsafe_Reify (term : constr) := let fresh_set := Fresh.Free.of_constr term in let idvar := Fresh.fresh fresh_set @var in let var := Constr.Unsafe.make (Constr.Unsafe.Var idvar) in let rterm := unsafe_reify var term in let rterm := Constr.Unsafe.closenl [idvar] 1 rterm in Constr.Unsafe.make (Constr.Unsafe.Lambda (Some idvar) 'Type rterm). Ltac2 do_Reify (term : constr) := check_result (unsafe_Reify term). Ltac2 unsafe_mkApp1 (f : constr) (x : constr) := let args := Array.make 1 x in Constr.Unsafe.make (Constr.Unsafe.App f args). Ltac2 mkApp1 (f : constr) (x : constr) := check_result (unsafe_mkApp1 f x). Ltac2 all_flags := { Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true; Std.rZeta := true; Std.rDelta := true; Std.rConst := []; }. Ltac2 betaiota_flags := { Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true; Std.rZeta := false; Std.rDelta := false; Std.rConst := []; }. Ltac2 in_goal := { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences }. Ltac2 do_Reify_rhs_fast () := let g := Control.goal () in match Constr.Unsafe.kind g with | Constr.Unsafe.App f args (* App eq [ty; lhs; rhs] *) => let v := Array.get args 2 in let rv := Control.time (Some "actual reif") (fun _ => unsafe_Reify v) in let rv := Control.time (Some "eval lazy") (fun _ => Std.eval_lazy all_flags rv) in Control.time (Some "lazy beta iota") (fun _ => Std.lazy betaiota_flags in_goal); Control.time (Some "transitivity (Denote rv)") (fun _ => Std.transitivity (unsafe_mkApp1 'Denote rv)) | _ => Control.zero (Tactic_failure (Some (Message.concat (Message.of_string "Invalid goal in Ltac2Unsafe.do_Reify_rhs_fast: ") (Message.of_constr g)))) end. Ltac2 do_Reify_rhs () := lazy_match! goal with | [ |- _ = ?v ] => let rv := do_Reify v in let rv := Std.eval_lazy all_flags rv in Std.transitivity (mkApp1 'Denote rv) | [ |- ?g ] => Control.zero (Tactic_failure (Some (Message.concat (Message.of_string "Invalid goal in Ltac2Unsafe.do_Reify_rhs: ") (Message.of_constr g)))) end. Ltac reify var term := let __ := Ltac1.save_ltac1_result (var, term) in let ret := constr:(ltac2:(let args := Ltac1.get_ltac1_result () in (lazy_match! args with | (?var, ?term) => let rv := reify var term in Control.refine (fun () => rv) | _ => Control.throw Not_found end))) in let __ := Ltac1.clear_ltac1_results () in ret. Ltac Reify x := Reify_of reify x. (*Ltac do_Reify_rhs _ := do_Reify_rhs_of Reify ().*) Ltac do_Reify_rhs _ := ltac2:(do_Reify_rhs_fast ()). End Ltac2LowLevel. *) Require Mtac2.Mtac2. Module Mtac2Mmatch. Import Mtac2.Mtac2. Import M.notations. Module var_context. Inductive var_context {var : Type} := nil | cons (n : nat) (v : var) (xs : var_context). End var_context. Definition find_in_ctx {var : Type} (term : nat) (ctx : @var_context.var_context var) : M (option var) := (mfix1 find_in_ctx (ctx : @var_context.var_context var) : M (option var) := (mmatch ctx with | [? v xs] (var_context.cons term v xs) =n> M.ret (Some v) | [? x v xs] (var_context.cons x v xs) =n> find_in_ctx xs | _ => M.ret None end)) ctx. Definition reify_helper {var : Type} (term : nat) (ctx : @var_context.var_context var) : M (@expr var) := ((mfix2 reify_helper (term : nat) (ctx : @var_context.var_context var) : M (@expr var) := lvar <- find_in_ctx term ctx; match lvar with | Some v => M.ret (@Var var v) | None => mmatch term with | O =n> M.ret (@NatO var) | [? x] (S x) =n> (rx <- reify_helper x ctx; M.ret (@NatS var rx)) | [? x y] (x * y) =n> (rx <- reify_helper x ctx; ry <- reify_helper y ctx; M.ret (@NatMul var rx ry)) | [? v f] (@Let_In nat (fun _ => nat) v f) =n> (rv <- reify_helper v ctx; rf <- (M.nu (FreshFrom f) mNone (fun x : nat => M.nu (FreshFrom "vx") mNone (fun vx : var => let fx := reduce (RedWhd [rl:RedBeta]) (f x) in rf <- reify_helper fx (var_context.cons x vx ctx); M.abs_fun vx rf))); M.ret (@LetIn var rv rf)) end end) term ctx). Definition reify (var : Type) (term : nat) : M (@expr var) := reify_helper term var_context.nil. Definition Reify (term : nat) : M Expr := \nu var:Type, r <- reify var term; M.abs_fun var r. Ltac Reify' x := constr:(ltac:(mrun (@Reify x))). Ltac Reify x := Reify' x. End Mtac2Mmatch. Require Mtac2.DecomposeApp. Module MTac2. Import Mtac2.Mtac2 Mtac2.DecomposeApp. Import M.notations. Definition mor {A} (t1 t2 : M A) : M A := M.mtry' t1 (fun _ => t2). Notation "a '_or_' b" := (mor a b) (at level 50). Module var_context. Inductive var_context {var : Type} := nil | cons (n : nat) (v : var) (xs : var_context). End var_context. Fixpoint find_in_ctx {var : Type} (term : nat) (ctx : @var_context.var_context var) {struct ctx} : M (option var) := match ctx with | var_context.cons term' v xs => mmatch term' with | [#] term | =n> M.ret (Some v) | _ => M.ret None end | _ => M.ret None end. Definition reify_helper {var : Type} (term : nat) (ctx : @var_context.var_context var) : M (@expr var) := ((mfix2 reify_helper (term : nat) (ctx : @var_context.var_context var) : M (@expr var) := lvar <- find_in_ctx term ctx; match lvar with | Some v => M.ret (@Var var v) | None => mmatch term with | [#] O | =n> M.ret (@NatO var) | [#] S | x =n> rx <- reify_helper x ctx; M.ret (@NatS var rx) | [#] Nat.mul | x y =n> rx <- reify_helper x ctx; ry <- reify_helper y ctx; M.ret (@NatMul var rx ry) | [#] @Let_In nat (fun _=>nat) | v f =n> rv <- reify_helper v ctx; rf <- (M.nu (FreshFrom f) mNone (fun x : nat => M.nu Generate mNone (fun vx : var => let fx := reduce (RedWhd [rl:RedBeta]) (f x) in rf <- reify_helper fx (var_context.cons x vx ctx); M.abs_fun vx rf))); M.ret (@LetIn var rv rf) end end) term ctx). Definition reify (var : Type) (term : nat) : M (@expr var) := reify_helper term var_context.nil. Definition Reify (term : nat) : M Expr := \nu var:Type, r <- reify var term; M.abs_fun var r. Ltac Reify' x := constr:(ltac:(mrun (@Reify x))). Ltac Reify x := Reify' x. End MTac2. Mtac2-1.4-coq8.20/tests/removetest.v000066400000000000000000000036621472011217100171450ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Example test_remove1 (x y z : nat) : x > y -> x > y. MProof. Fail M.remove x (M.ret id). (* the meta-variable depends on it *) Fail M.remove (id z) (M.ret id). (* must be a variable *) M.remove z (M.ret id). (* z is not required for the proof *) Qed. Example test_remove2 (z y x : nat) : x > y -> x > y. MProof. M.remove z (M.ret id). (* z is not required for the proof *) Qed. Example test_remove3 : forall x y z : nat, x > y -> x > y. MProof. (* z is not required for the proof *) (\nu x, \nu y, \nu z : nat, r1 <- M.remove z (M.ret id); r2 <- M.abs_fun z r1; r3 <- M.abs_fun (P:=fun y=>forall z, x > y -> x > y) y r2; M.abs_fun (P:=fun x=>forall y, nat -> x > y -> x > y) x r3)%MC. Qed. Example test_remove4 : forall z x y : nat, x > y -> x > y. MProof. (* z is not required for the proof *) (\nu z, \nu x, \nu y : nat, r1 <- M.remove z (M.ret id); r2 <- M.abs_fun y r1; r3 <- M.abs_fun (P:= fun x =>forall y : nat, x > y -> x > y) x r2; M.abs_fun z r3)%MC. Qed. Lemma negb_involutive : forall b b2:bool, negb (negb b) = b. MProof. cintros b {- T.destruct b -};; T.select bool >>= T.clear ;; intros b2. - T.reflexivity. - T.reflexivity. Qed. Lemma negb_involutive' (n:nat) : forall b b2:bool, negb (negb b) = b. MProof. cintros b {- T.destruct b -};; T.select bool >>= T.clear ;; intros b2. - T.reflexivity. - T.reflexivity. Qed. Lemma negb_involutive'' (n1 n2 n3:nat) : forall b b2:bool, negb (negb b) = b. MProof. cintros b {- T.destruct b -};; T.select bool >>= T.clear ;; intros b2. - T.reflexivity. - T.reflexivity. Qed. (* Bug #103 *) Goal True -> True. MProof. intro x. T.try (T.clear x &> T.raise NotAGoal). T.assumption. Qed. Goal True -> True -> True. MProof. cintros x y {- T.try (T.clear x &> T.raise NotAGoal) -}. T.assumption. Qed. Goal True -> True -> True. MProof. cintros x y {- T.try (T.clear y &> T.raise NotAGoal) -}. T.assumption. Qed.Mtac2-1.4-coq8.20/tests/replace.v000066400000000000000000000002231472011217100163510ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Goal (if true then True else False) -> True. MProof. intros H. M.replace H meq_refl (M.ret H). Show Proof. Qed. Mtac2-1.4-coq8.20/tests/rew_hd_error.v000066400000000000000000000006201472011217100174200ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Import M. Import M.notations. Require Import Lists.List. Import ListNotations. Definition rew_hd_error : tactic := match_goal with | [[? A (l: list A) |- context C[hd_error l] ]] => match l with | [] => rewrite hd_error_nil | (_ :: _) => rewrite hd_error_cons end end. Goal hd_error [1] = Some 1. MProof. rew_hd_error. T.reflexivity. Qed.Mtac2-1.4-coq8.20/tests/selectors.v000066400000000000000000000014021472011217100167410ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Import T. Example test_selector1 : forall n, n >= 0. MProof. destructn 0 &> S.first (apply le_0_n). Abort. Example test_selector2 : forall n, n >= 0. MProof. destructn 0 &> S.rev &> S.last (apply le_0_n). Abort. Example test_selector3 : forall n, n >= 0. MProof. destructn 0 |1> apply le_0_n. Abort. Example test_selector4 : forall n, n >= 0. MProof. destructn 0 &> S.rev l> apply le_0_n. Abort. Example test_selector5 : forall n, n >= 0. MProof. destructn 0 &> S.rev |2> apply le_0_n. Abort. Example test_selector6 : forall n, n >= 0. MProof. (destructn 0 &> S.rev |2> apply le_0_n) |1> idtac. Abort. Example test_selector7 : forall n, n >= 0. MProof. Fail (destructn 0 &> S.rev |2> apply le_0_n) |2> print_goal. Abort. Mtac2-1.4-coq8.20/tests/sf-5/000077500000000000000000000000001472011217100153245ustar00rootroot00000000000000Mtac2-1.4-coq8.20/tests/sf-5/_CoqProject000066400000000000000000000002031472011217100174520ustar00rootroot00000000000000-R lf lf -R ../../theories Mtac2 -I ../../src lf/Preface.v lf/Basics.v lf/Induction.v lf/Lists.v lf/Poly.v lf/Tactics.v lf/Logic.v Mtac2-1.4-coq8.20/tests/sf-5/configure.sh000077500000000000000000000001211472011217100176360ustar00rootroot00000000000000#!/usr/bin/env sh # Makefile generation coq_makefile -f _CoqProject -o Makefile Mtac2-1.4-coq8.20/tests/sf-5/lf/000077500000000000000000000000001472011217100157255ustar00rootroot00000000000000Mtac2-1.4-coq8.20/tests/sf-5/lf/.depend000066400000000000000000000035571472011217100171770ustar00rootroot00000000000000Preface.vo Preface.glob Preface.v.beautified: Preface.v Preface.vio: Preface.v Basics.vo Basics.glob Basics.v.beautified: Basics.v Basics.vio: Basics.v Induction.vo Induction.glob Induction.v.beautified: Induction.v Basics.vo Induction.vio: Induction.v Basics.vio Lists.vo Lists.glob Lists.v.beautified: Lists.v Induction.vo Lists.vio: Lists.v Induction.vio Poly.vo Poly.glob Poly.v.beautified: Poly.v Lists.vo Poly.vio: Poly.v Lists.vio Tactics.vo Tactics.glob Tactics.v.beautified: Tactics.v Poly.vo Tactics.vio: Tactics.v Poly.vio Logic.vo Logic.glob Logic.v.beautified: Logic.v Tactics.vo Logic.vio: Logic.v Tactics.vio IndProp.vo IndProp.glob IndProp.v.beautified: IndProp.v Logic.vo IndProp.vio: IndProp.v Logic.vio Maps.vo Maps.glob Maps.v.beautified: Maps.v Maps.vio: Maps.v ProofObjects.vo ProofObjects.glob ProofObjects.v.beautified: ProofObjects.v IndProp.vo ProofObjects.vio: ProofObjects.v IndProp.vio IndPrinciples.vo IndPrinciples.glob IndPrinciples.v.beautified: IndPrinciples.v ProofObjects.vo IndPrinciples.vio: IndPrinciples.v ProofObjects.vio Rel.vo Rel.glob Rel.v.beautified: Rel.v IndProp.vo Rel.vio: Rel.v IndProp.vio Imp.vo Imp.glob Imp.v.beautified: Imp.v Maps.vo Imp.vio: Imp.v Maps.vio ImpParser.vo ImpParser.glob ImpParser.v.beautified: ImpParser.v Maps.vo Imp.vo ImpParser.vio: ImpParser.v Maps.vio Imp.vio ImpCEvalFun.vo ImpCEvalFun.glob ImpCEvalFun.v.beautified: ImpCEvalFun.v Imp.vo Maps.vo ImpCEvalFun.vio: ImpCEvalFun.v Imp.vio Maps.vio Extraction.vo Extraction.glob Extraction.v.beautified: Extraction.v ImpCEvalFun.vo Imp.vo ImpParser.vo Maps.vo Extraction.vio: Extraction.v ImpCEvalFun.vio Imp.vio ImpParser.vio Maps.vio Auto.vo Auto.glob Auto.v.beautified: Auto.v Maps.vo Imp.vo Auto.vio: Auto.v Maps.vio Imp.vio Postscript.vo Postscript.glob Postscript.v.beautified: Postscript.v Postscript.vio: Postscript.v Bib.vo Bib.glob Bib.v.beautified: Bib.v Bib.vio: Bib.v Mtac2-1.4-coq8.20/tests/sf-5/lf/Basics.v000066400000000000000000001375061472011217100173340ustar00rootroot00000000000000(** * Basics: Functional Programming in Coq *) (* REMINDER: ##################################################### ### PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY ### ##################################################### (See the [Preface] for why.) *) From Mtac2 Require Export Mtac2 IntroPatt CompoundTactics. Export T. Export CT. Export CT.notations. Set Global Default Proof Using "Type". (* ################################################################# *) (** * Introduction *) (** The functional programming style is founded on simple, everyday mathematical intuition: If a procedure or method has no side effects, then (ignoring efficiency) all we need to understand about it is how it maps inputs to outputs -- that is, we can think of it as just a concrete method for computing a mathematical function. This is one sense of the word "functional" in "functional programming." The direct connection between programs and simple mathematical objects supports both formal correctness proofs and sound informal reasoning about program behavior. The other sense in which functional programming is "functional" is that it emphasizes the use of functions (or methods) as _first-class_ values -- i.e., values that can be passed as arguments to other functions, returned as results, included in data structures, etc. The recognition that functions can be treated as data gives rise to a host of useful and powerful programming idioms. Other common features of functional languages include _algebraic data types_ and _pattern matching_, which make it easy to construct and manipulate rich data structures, and sophisticated _polymorphic type systems_ supporting abstraction and code reuse. Coq offers all of these features. The first half of this chapter introduces the most essential elements of Coq's functional programming language, called _Gallina_. The second half introduces some basic _tactics_ that can be used to prove properties of Coq programs. *) (* ################################################################# *) (** * Data and Functions *) (* ================================================================= *) (** ** Enumerated Types *) (** One notable aspect of Coq is that its set of built-in features is _extremely_ small. For example, instead of providing the usual palette of atomic data types (booleans, integers, strings, etc.), Coq offers a powerful mechanism for defining new data types from scratch, with all these familiar types as instances. Naturally, the Coq distribution comes preloaded with an extensive standard library providing definitions of booleans, numbers, and many common data structures like lists and hash tables. But there is nothing magic or primitive about these library definitions. To illustrate this, we will explicitly recapitulate all the definitions we need in this course, rather than just getting them implicitly from the library. *) (* ================================================================= *) (** ** Days of the Week *) (** To see how this definition mechanism works, let's start with a very simple example. The following declaration tells Coq that we are defining a new set of data values -- a _type_. *) Inductive day : Type := | monday : day | tuesday : day | wednesday : day | thursday : day | friday : day | saturday : day | sunday : day. (** The type is called [day], and its members are [monday], [tuesday], etc. The second and following lines of the definition can be read "[monday] is a [day], [tuesday] is a [day], etc." Having defined [day], we can write functions that operate on days. *) Definition next_weekday (d:day) : day := match d with | monday => tuesday | tuesday => wednesday | wednesday => thursday | thursday => friday | friday => monday | saturday => monday | sunday => monday end. (** One thing to note is that the argument and return types of this function are explicitly declared. Like most functional programming languages, Coq can often figure out these types for itself when they are not given explicitly -- i.e., it can do _type inference_ -- but we'll generally include them to make reading easier. *) (** Having defined a function, we should check that it works on some examples. There are actually three different ways to do this in Coq. First, we can use the command [Compute] to evaluate a compound expression involving [next_weekday]. *) Compute (next_weekday friday). (* ==> monday : day *) Compute (next_weekday (next_weekday saturday)). (* ==> tuesday : day *) (** (We show Coq's responses in comments, but, if you have a computer handy, this would be an excellent moment to fire up the Coq interpreter under your favorite IDE -- either CoqIde or Proof General -- and try this for yourself. Load this file, [Basics.v], from the book's Coq sources, find the above example, submit it to Coq, and observe the result.) Second, we can record what we _expect_ the result to be in the form of a Coq example: *) Example test_next_weekday: (next_weekday (next_weekday saturday)) = tuesday. (** This declaration does two things: it makes an assertion (that the second weekday after [saturday] is [tuesday]), and it gives the assertion a name that can be used to refer to it later. Having made the assertion, we can also ask Coq to verify it, like this: *) MProof. simpl. reflexivity. Qed. (** The details are not important for now (we'll come back to them in a bit), but essentially this can be read as "The assertion we've just made can be proved by observing that both sides of the equality evaluate to the same thing, after some simplification." Third, we can ask Coq to _extract_, from our [Definition], a program in some other, more conventional, programming language (OCaml, Scheme, or Haskell) with a high-performance compiler. This facility is very interesting, since it gives us a way to go from proved-correct algorithms written in Gallina to efficient machine code. (Of course, we are trusting the correctness of the OCaml/Haskell/Scheme compiler, and of Coq's extraction facility itself, but this is still a big step forward from the way most software is developed today.) Indeed, this is one of the main uses for which Coq was developed. We'll come back to this topic in later chapters. *) (* ================================================================= *) (** ** Homework Submission Guidelines *) (** If you are using Software Foundations in a course, your instructor may use automatic scripts to help grade your homework assignments. In order for these scripts to work correctly (so that you get full credit for your work!), please be careful to follow these rules: - The grading scripts work by extracting marked regions of the .v files that you submit. It is therefore important that you do not alter the "markup" that delimits exercises: the Exercise header, the name of the exercise, the "empty square bracket" marker at the end, etc. Please leave this markup exactly as you find it. - Do not delete exercises. If you skip an exercise (e.g., because it is marked Optional, or because you can't solve it), it is OK to leave a partial proof in your .v file, but in this case please make sure it ends with [Admitted] (not, for example [Abort]). *) (* ================================================================= *) (** ** Booleans *) (** In a similar way, we can define the standard type [bool] of booleans, with members [true] and [false]. *) Inductive bool : Type := | true : bool | false : bool. (** Although we are rolling our own booleans here for the sake of building up everything from scratch, Coq does, of course, provide a default implementation of the booleans, together with a multitude of useful functions and lemmas. (Take a look at [Coq.Init.Datatypes] in the Coq library documentation if you're interested.) Whenever possible, we'll name our own definitions and theorems so that they exactly coincide with the ones in the standard library. Functions over booleans can be defined in the same way as above: *) Definition negb (b:bool) : bool := match b with | true => false | false => true end. Definition andb (b1:bool) (b2:bool) : bool := match b1 with | true => b2 | false => false end. Definition orb (b1:bool) (b2:bool) : bool := match b1 with | true => true | false => b2 end. (** The last two of these illustrate Coq's syntax for multi-argument function definitions. The corresponding multi-argument application syntax is illustrated by the following "unit tests," which constitute a complete specification -- a truth table -- for the [orb] function: *) Example test_orb1: (orb true false) = true. MProof. simpl. reflexivity. Qed. Example test_orb2: (orb false false) = false. MProof. simpl. reflexivity. Qed. Example test_orb3: (orb false true) = true. MProof. simpl. reflexivity. Qed. Example test_orb4: (orb true true) = true. MProof. simpl. reflexivity. Qed. (** We can also introduce some familiar syntax for the boolean operations we have just defined. The [Infix] command defines a new symbolic notation for an existing definition. *) Notation "x && y" := (andb x y). Notation "x || y" := (orb x y). Example test_orb5: false || false || true = true. MProof. simpl. reflexivity. Qed. (** _A note on notation_: In [.v] files, we use square brackets to delimit fragments of Coq code within comments; this convention, also used by the [coqdoc] documentation tool, keeps them visually separate from the surrounding text. In the html version of the files, these pieces of text appear in a [different font]. The command [Admitted] can be used as a placeholder for an incomplete proof. We'll use it in exercises, to indicate the parts that we're leaving for you -- i.e., your job is to replace [Admitted]s with real proofs. *) (** **** Exercise: 1 star (nandb) *) (** Remove "[Admitted.]" and complete the definition of the following function; then make sure that the [Example] assertions below can each be verified by Coq. (Remove "[Admitted.]" and fill in each proof, following the model of the [orb] tests above.) The function should return [true] if either or both of its inputs are [false]. *) Definition nandb (b1:bool) (b2:bool) : bool (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_nandb1: (nandb true false) = true. (* FILL IN HERE *) Admitted. Example test_nandb2: (nandb false false) = true. (* FILL IN HERE *) Admitted. Example test_nandb3: (nandb false true) = true. (* FILL IN HERE *) Admitted. Example test_nandb4: (nandb true true) = false. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star (andb3) *) (** Do the same for the [andb3] function below. This function should return [true] when all of its inputs are [true], and [false] otherwise. *) Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_andb31: (andb3 true true true) = true. (* FILL IN HERE *) Admitted. Example test_andb32: (andb3 false true true) = false. (* FILL IN HERE *) Admitted. Example test_andb33: (andb3 true false true) = false. (* FILL IN HERE *) Admitted. Example test_andb34: (andb3 true true false) = false. (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** Function Types *) (** Every expression in Coq has a type, describing what sort of thing it computes. The [Check] command asks Coq to print the type of an expression. *) Check true. (* ===> true : bool *) Check (negb true). (* ===> negb true : bool *) (** Functions like [negb] itself are also data values, just like [true] and [false]. Their types are called _function types_, and they are written with arrows. *) Check negb. (* ===> negb : bool -> bool *) (** The type of [negb], written [bool -> bool] and pronounced "[bool] arrow [bool]," can be read, "Given an input of type [bool], this function produces an output of type [bool]." Similarly, the type of [andb], written [bool -> bool -> bool], can be read, "Given two inputs, both of type [bool], this function produces an output of type [bool]." *) (* ================================================================= *) (** ** Compound Types *) (** The types we have defined so far are examples of "enumerated types": their definitions explicitly enumerate a finite set of elements, each of which is just a bare constructor. Here is a more interesting type definition, where one of the constructors takes an argument: *) Inductive rgb : Type := | red : rgb | green : rgb | blue : rgb. Inductive color : Type := | black : color | white : color | primary : rgb -> color. (** Let's look at this in a little more detail. Every inductively defined type ([day], [bool], [rgb], [color], etc.) contains a set of _constructor expressions_ built from _constructors_ like [red], [primary], [true], [false], [monday], etc. The definitions of [rgb] and [color] say how expressions in the sets [rgb] and [color] can be built: - [reg], [green], and [blue] are the constructors of [rgb]; - [black], [white], and [primary] are the constructors of [color]; - the expression [red] belongs to the set [rgb], as do the expressions [green] and [blue]; - the expressions [black] and [white] belong to the set [color]; - if [p] is an expression belonging to the set [rgb], then [primary p] (pronounced "the constructor [primary] applied to the argument [p]") is an expression belonging to the set [color]; and - expressions formed in these ways are the _only_ ones belonging to the sets [rgb] and [color]. *) (** We can define functions on colors using pattern matching just as we have done for [day] and [bool]. *) Definition monochrome (c : color) : bool := match c with | black => true | white => true | primary p => false end. (** Since the [primary] constructor takes an argument, a pattern matching [primary] should include either a variable (as above) or a constant of appropriate type (as below). *) Definition isred (c : color) : bool := match c with | black => false | white => false | primary red => true | primary _ => false end. (** The pattern [primary _] here is shorthand for "[primary] applied to any [rgb] constructor except [red]." (The wildcard pattern [_] has the same effect as the dummy pattern variable [p] in the definition of [monochrome].) *) (* ================================================================= *) (** ** Modules *) (** Coq provides a _module system_, to aid in organizing large developments. In this course we won't need most of its features, but one is useful: If we enclose a collection of declarations between [Module X] and [End X] markers, then, in the remainder of the file after the [End], these definitions are referred to by names like [X.foo] instead of just [foo]. We will use this feature to introduce the definition of the type [nat] in an inner module so that it does not interfere with the one from the standard library (which we want to use in the rest because it comes with a tiny bit of convenient special notation). *) Module NatPlayground. (* ================================================================= *) (** ** Numbers *) (** An even more interesting way of defining a type is to allow its constrctors to take arguments from the very same type -- that is, to allow the rules describing its elements to be _inductive_. For example, we can define (a unary representation of) natural numbers as follows: *) Inductive nat : Type := | O : nat | S : nat -> nat. (** The clauses of this definition can be read: - [O] is a natural number (note that this is the letter "[O]," not the numeral "[0]"). - [S] can be put in front of a natural number to yield another one -- if [n] is a natural number, then [S n] is too. *) (** Again, let's look at this in a little more detail. The definition of [nat] says how expressions in the set [nat] can be built: - [O] and [S] are constructors; - the expression [O] belongs to the set [nat]; - if [n] is an expression belonging to the set [nat], then [S n] is also an expression belonging to the set [nat]; and - expressions formed in these two ways are the only ones belonging to the set [nat]. *) (** The same rules apply for our definitions of [day], [bool], [color], etc. The above conditions are the precise force of the [Inductive] declaration. They imply that the expression [O], the expression [S O], the expression [S (S O)], the expression [S (S (S O))], and so on all belong to the set [nat], while other expressions built from data constructors, like [true], [andb true false], [S (S false)], and [O (O (O S))] do not. A critical point here is that what we've done so far is just to define a _representation_ of numbers: a way of writing them down. The names [O] and [S] are arbitrary, and at this point they have no special meaning -- they are just two different marks that we can use to write down numbers (together with a rule that says any [nat] will be written as some string of [S] marks followed by an [O]). If we like, we can write essentially the same definition this way: *) Inductive nat' : Type := | stop : nat' | tick : nat' -> nat'. (** The _interpretation_ of these marks comes from how we use them to compute. *) (** We can do this by writing functions that pattern match on representations of natural numbers just as we did above with booleans and days -- for example, here is the predecessor function: *) Definition pred (n : nat) : nat := match n with | O => O | S n' => n' end. (** The second branch can be read: "if [n] has the form [S n'] for some [n'], then return [n']." *) End NatPlayground. (** Because natural numbers are such a pervasive form of data, Coq provides a tiny bit of built-in magic for parsing and printing them: ordinary arabic numerals can be used as an alternative to the "unary" notation defined by the constructors [S] and [O]. Coq prints numbers in arabic form by default: *) Check (S (S (S (S O)))). (* ===> 4 : nat *) Definition minustwo (n : nat) : nat := match n with | O => O | S O => O | S (S n') => n' end. Compute (minustwo 4). (* ===> 2 : nat *) (** The constructor [S] has the type [nat -> nat], just like [pred] and functions like [minustwo]: *) Check S. Check pred. Check minustwo. (** These are all things that can be applied to a number to yield a number. However, there is a fundamental difference between the first one and the other two: functions like [pred] and [minustwo] come with _computation rules_ -- e.g., the definition of [pred] says that [pred 2] can be simplified to [1] -- while the definition of [S] has no such behavior attached. Although it is like a function in the sense that it can be applied to an argument, it does not _do_ anything at all! It is just a way of writing down numbers. (Think about standard arabic numerals: the numeral [1] is not a computation; it's a piece of data. When we write [111] to mean the number one hundred and eleven, we are using [1], three times, to write down a concrete representation of a number.) For most function definitions over numbers, just pattern matching is not enough: we also need recursion. For example, to check that a number [n] is even, we may need to recursively check whether [n-2] is even. To write such functions, we use the keyword [Fixpoint]. *) Fixpoint evenb (n:nat) : bool := match n with | O => true | S O => false | S (S n') => evenb n' end. (** We can define [oddb] by a similar [Fixpoint] declaration, but here is a simpler definition: *) Definition oddb (n:nat) : bool := negb (evenb n). Example test_oddb1: oddb 1 = true. MProof. simpl. reflexivity. Qed. Example test_oddb2: oddb 4 = false. MProof. simpl. reflexivity. Qed. (** (You will notice if you step through these proofs that [simpl] actually has no effect on the goal -- all of the work is done by [reflexivity]. We'll see more about why that is shortly.) Naturally, we can also define multi-argument functions by recursion. *) Module NatPlayground2. Fixpoint plus (n : nat) (m : nat) : nat := match n with | O => m | S n' => S (plus n' m) end. (** Adding three to two now gives us five, as we'd expect. *) Compute (plus 3 2). (** The simplification that Coq performs to reach this conclusion can be visualized as follows: *) (* [plus (S (S (S O))) (S (S O))] ==> [S (plus (S (S O)) (S (S O)))] by the second clause of the [match] ==> [S (S (plus (S O) (S (S O))))] by the second clause of the [match] ==> [S (S (S (plus O (S (S O)))))] by the second clause of the [match] ==> [S (S (S (S (S O))))] by the first clause of the [match] *) (** As a notational convenience, if two or more arguments have the same type, they can be written together. In the following definition, [(n m : nat)] means just the same as if we had written [(n : nat) (m : nat)]. *) Fixpoint mult (n m : nat) : nat := match n with | O => O | S n' => plus m (mult n' m) end. Example test_mult1: (mult 3 3) = 9. MProof. simpl. reflexivity. Qed. (** You can match two expressions at once by putting a comma between them: *) Fixpoint minus (n m:nat) : nat := match (n, m) with | (O , _) => O | (S _ , O) => n | (S n', S m') => minus n' m' end. (** Again, the _ in the first line is a _wildcard pattern_. Writing [_] in a pattern is the same as writing some variable that doesn't get used on the right-hand side. This avoids the need to invent a variable name. *) End NatPlayground2. Fixpoint exp (base power : nat) : nat := match power with | O => S O | S p => mult base (exp base p) end. (** **** Exercise: 1 star (factorial) *) (** Recall the standard mathematical factorial function: factorial(0) = 1 factorial(n) = n * factorial(n-1) (if n>0) Translate this into Coq. *) Fixpoint factorial (n:nat) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_factorial1: (factorial 3) = 6. (* FILL IN HERE *) Admitted. Example test_factorial2: (factorial 5) = (mult 10 12). (* FILL IN HERE *) Admitted. (** [] *) (** We can make numerical expressions a little easier to read and write by introducing _notations_ for addition, multiplication, and subtraction. *) Notation "x + y" := (plus x y) (at level 50, left associativity) : nat_scope. Notation "x - y" := (minus x y) (at level 50, left associativity) : nat_scope. Notation "x * y" := (mult x y) (at level 40, left associativity) : nat_scope. Check ((0 + 1) + 1). (** (The [level], [associativity], and [nat_scope] annotations control how these notations are treated by Coq's parser. The details are not important for our purposes, but interested readers can refer to the optional "More on Notation" section at the end of this chapter.) Note that these do not change the definitions we've already made: they are simply instructions to the Coq parser to accept [x + y] in place of [plus x y] and, conversely, to the Coq pretty-printer to display [plus x y] as [x + y]. *) (** When we say that Coq comes with almost nothing built-in, we really mean it: even equality testing for numbers is a user-defined operation! We now define a function [beq_nat], which tests [nat]ural numbers for [eq]uality, yielding a [b]oolean. Note the use of nested [match]es (we could also have used a simultaneous match, as we did in [minus].) *) Fixpoint beq_nat (n m : nat) : bool := match n with | O => match m with | O => true | S m' => false end | S n' => match m with | O => false | S m' => beq_nat n' m' end end. (** The [leb] function tests whether its first argument is less than or equal to its second argument, yielding a boolean. *) Fixpoint leb (n m : nat) : bool := match n with | O => true | S n' => match m with | O => false | S m' => leb n' m' end end. Example test_leb1: (leb 2 2) = true. MProof. simpl. reflexivity. Qed. Example test_leb2: (leb 2 4) = true. MProof. simpl. reflexivity. Qed. Example test_leb3: (leb 4 2) = false. MProof. simpl. reflexivity. Qed. (** **** Exercise: 1 star (blt_nat) *) (** The [blt_nat] function tests [nat]ural numbers for [l]ess-[t]han, yielding a [b]oolean. Instead of making up a new [Fixpoint] for this one, define it in terms of a previously defined function. *) Definition blt_nat (n m : nat) : bool (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_blt_nat1: (blt_nat 2 2) = false. (* FILL IN HERE *) Admitted. Example test_blt_nat2: (blt_nat 2 4) = true. (* FILL IN HERE *) Admitted. Example test_blt_nat3: (blt_nat 4 2) = false. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Proof by Simplification *) (** Now that we've defined a few datatypes and functions, let's turn to stating and proving properties of their behavior. Actually, we've already started doing this: each [Example] in the previous sections makes a precise claim about the behavior of some function on some particular inputs. The proofs of these claims were always the same: use [simpl] to simplify both sides of the equation, then use [reflexivity] to check that both sides contain identical values. The same sort of "proof by simplification" can be used to prove more interesting properties as well. For example, the fact that [0] is a "neutral element" for [+] on the left can be proved just by observing that [0 + n] reduces to [n] no matter what [n] is, a fact that can be read directly off the definition of [plus].*) Theorem plus_O_n : forall n : nat, 0 + n = n. MProof. intros n. simpl. reflexivity. Qed. (** (You may notice that the above statement looks different in the [.v] file in your IDE than it does in the HTML rendition in your browser, if you are viewing both. In [.v] files, we write the [forall] universal quantifier using the reserved identifier "forall." When the [.v] files are converted to HTML, this gets transformed into an upside-down-A symbol.) This is a good place to mention that [reflexivity] is a bit more powerful than we have admitted. In the examples we have seen, the calls to [simpl] were actually not needed, because [reflexivity] can perform some simplification automatically when checking that two sides are equal; [simpl] was just added so that we could see the intermediate state -- after simplification but before finishing the proof. Here is a shorter proof of the theorem: *) Theorem plus_O_n' : forall n : nat, 0 + n = n. MProof. intros n. reflexivity. Qed. (** Moreover, it will be useful later to know that [reflexivity] does somewhat _more_ simplification than [simpl] does -- for example, it tries "unfolding" defined terms, replacing them with their right-hand sides. The reason for this difference is that, if reflexivity succeeds, the whole goal is finished and we don't need to look at whatever expanded expressions [reflexivity] has created by all this simplification and unfolding; by contrast, [simpl] is used in situations where we may have to read and understand the new goal that it creates, so we would not want it blindly expanding definitions and leaving the goal in a messy state. The form of the theorem we just stated and its proof are almost exactly the same as the simpler examples we saw earlier; there are just a few differences. First, we've used the keyword [Theorem] instead of [Example]. This difference is mostly a matter of style; the keywords [Example] and [Theorem] (and a few others, including [Lemma], [Fact], and [Remark]) mean pretty much the same thing to Coq. Second, we've added the quantifier [forall n:nat], so that our theorem talks about _all_ natural numbers [n]. Informally, to prove theorems of this form, we generally start by saying "Suppose [n] is some number..." Formally, this is achieved in the proof by [intros n], which moves [n] from the quantifier in the goal to a _context_ of current assumptions. The keywords [intros], [simpl], and [reflexivity] are examples of _tactics_. A tactic is a command that is used between [Proof] and [Qed] to guide the process of checking some claim we are making. We will see several more tactics in the rest of this chapter and yet more in future chapters. *) (** Other similar theorems can be proved with the same pattern. *) Theorem plus_1_l : forall n:nat, 1 + n = S n. MProof. intros n. reflexivity. Qed. Theorem mult_0_l : forall n:nat, 0 * n = 0. MProof. intros n. reflexivity. Qed. (** The [_l] suffix in the names of these theorems is pronounced "on the left." *) (** It is worth stepping through these proofs to observe how the context and the goal change. You may want to add calls to [simpl] before [reflexivity] to see the simplifications that Coq performs on the terms before checking that they are equal. *) (* ################################################################# *) (** * Proof by Rewriting *) (** This theorem is a bit more interesting than the others we've seen: *) Theorem plus_id_example : forall n m:nat, n = m -> n + n = m + m. (** Instead of making a universal claim about all numbers [n] and [m], it talks about a more specialized property that only holds when [n = m]. The arrow symbol is pronounced "implies." As before, we need to be able to reason by assuming we are given such numbers [n] and [m]. We also need to assume the hypothesis [n = m]. The [intros] tactic will serve to move all three of these from the goal into assumptions in the current context. Since [n] and [m] are arbitrary numbers, we can't just use simplification to prove this theorem. Instead, we prove it by observing that, if we are assuming [n = m], then we can replace [n] with [m] in the goal statement and obtain an equality with the same expression on both sides. The tactic that tells Coq to perform this replacement is called [rewrite]. *) MProof. (* move both quantifiers into the context: *) intros n m. (* move the hypothesis into the context: *) intros H. (* rewrite the goal using the hypothesis: *) rewrite -> H. reflexivity. Qed. (** The first line of the proof moves the universally quantified variables [n] and [m] into the context. The second moves the hypothesis [n = m] into the context and gives it the name [H]. The third tells Coq to rewrite the current goal ([n + n = m + m]) by replacing the left side of the equality hypothesis [H] with the right side. (The arrow symbol in the [rewrite] has nothing to do with implication: it tells Coq to apply the rewrite from left to right. To rewrite from right to left, you can use [rewrite <-]. Try making this change in the above proof and see what difference it makes.) *) (** **** Exercise: 1 star (plus_id_exercise) *) (** Remove "[Admitted.]" and fill in the proof. *) Theorem plus_id_exercise : forall n m o : nat, n = m -> m = o -> n + m = m + o. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** The [Admitted] command tells Coq that we want to skip trying to prove this theorem and just accept it as a given. This can be useful for developing longer proofs, since we can state subsidiary lemmas that we believe will be useful for making some larger argument, use [Admitted] to accept them on faith for the moment, and continue working on the main argument until we are sure it makes sense; then we can go back and fill in the proofs we skipped. Be careful, though: every time you say [Admitted] you are leaving a door open for total nonsense to enter Coq's nice, rigorous, formally checked world! *) (** We can also use the [rewrite] tactic with a previously proved theorem instead of a hypothesis from the context. If the statement of the previously proved theorem involves quantified variables, as in the example below, Coq tries to instantiate them by matching with the current goal. *) Theorem mult_0_plus : forall n m : nat, (0 + n) * m = n * m. MProof. intros n m. rewrite -> plus_O_n. reflexivity. Qed. (** **** Exercise: 2 stars (mult_S_1) *) Theorem mult_S_1 : forall n m : nat, m = S n -> m * (1 + n) = m * m. MProof. (* FILL IN HERE *) Admitted. (* (N.b. This proof can actually be completed without using [rewrite], but please do use [rewrite] for the sake of the exercise.) *) (** [] *) (* ################################################################# *) (** * Proof by Case Analysis *) (** Of course, not everything can be proved by simple calculation and rewriting: In general, unknown, hypothetical values (arbitrary numbers, booleans, lists, etc.) can block simplification. For example, if we try to prove the following fact using the [simpl] tactic as above, we get stuck. (We then use the [Abort] command to give up on it for the moment.)*) Theorem plus_1_neq_0_firsttry : forall n : nat, beq_nat (n + 1) 0 = false. MProof. intros n. simpl. (* does nothing! *) Abort. (** The reason for this is that the definitions of both [beq_nat] and [+] begin by performing a [match] on their first argument. But here, the first argument to [+] is the unknown number [n] and the argument to [beq_nat] is the compound expression [n + 1]; neither can be simplified. To make progress, we need to consider the possible forms of [n] separately. If [n] is [O], then we can calculate the final result of [beq_nat (n + 1) 0] and check that it is, indeed, [false]. And if [n = S n'] for some [n'], then, although we don't know exactly what number [n + 1] yields, we can calculate that, at least, it will begin with one [S], and this is enough to calculate that, again, [beq_nat (n + 1) 0] will yield [false]. The tactic that tells Coq to consider, separately, the cases where [n = O] and where [n = S n'] is called [destruct]. *) Theorem plus_1_neq_0 : forall n : nat, beq_nat (n + 1) 0 = false. MProof. intros n. destruct n &> [i: ~~ | \n']. - reflexivity. - reflexivity. Qed. (** The [destruct] generates _two_ subgoals, which we must then prove, separately, in order to get Coq to accept the theorem. The annotation "[as [| n']]" is called an _intro pattern_. It tells Coq what variable names to introduce in each subgoal. In general, what goes between the square brackets is a _list of lists_ of names, separated by [|]. In this case, the first component is empty, since the [O] constructor is nullary (it doesn't have any arguments). The second component gives a single name, [n'], since [S] is a unary constructor. The [-] signs on the second and third lines are called _bullets_, and they mark the parts of the proof that correspond to each generated subgoal. The proof script that comes after a bullet is the entire proof for a subgoal. In this example, each of the subgoals is easily proved by a single use of [reflexivity], which itself performs some simplification -- e.g., the first one simplifies [beq_nat (S n' + 1) 0] to [false] by first rewriting [(S n' + 1)] to [S (n' + 1)], then unfolding [beq_nat], and then simplifying the [match]. Marking cases with bullets is entirely optional: if bullets are not present, Coq simply asks you to prove each subgoal in sequence, one at a time. But it is a good idea to use bullets. For one thing, they make the structure of a proof apparent, making it more readable. Also, bullets instruct Coq to ensure that a subgoal is complete before trying to verify the next one, preventing proofs for different subgoals from getting mixed up. These issues become especially important in large developments, where fragile proofs lead to long debugging sessions. There are no hard and fast rules for how proofs should be formatted in Coq -- in particular, where lines should be broken and how sections of the proof should be indented to indicate their nested structure. However, if the places where multiple subgoals are generated are marked with explicit bullets at the beginning of lines, then the proof will be readable almost no matter what choices are made about other aspects of layout. This is also a good place to mention one other piece of somewhat obvious advice about line lengths. Beginning Coq users sometimes tend to the extremes, either writing each tactic on its own line or writing entire proofs on one line. Good style lies somewhere in the middle. One reasonable convention is to limit yourself to 80-character lines. The [destruct] tactic can be used with any inductively defined datatype. For example, we use it next to prove that boolean negation is involutive -- i.e., that negation is its own inverse. *) Theorem negb_involutive : forall b : bool, negb (negb b) = b. MProof. intros b. destruct b. - reflexivity. - reflexivity. Qed. (** Note that the [destruct] here has no [as] clause because none of the subcases of the [destruct] need to bind any variables, so there is no need to specify any names. (We could also have written [as [|]], or [as []].) In fact, we can omit the [as] clause from _any_ [destruct] and Coq will fill in variable names automatically. This is generally considered bad style, since Coq often makes confusing choices of names when left to its own devices. It is sometimes useful to invoke [destruct] inside a subgoal, generating yet more proof obligations. In this case, we use different kinds of bullets to mark goals on different "levels." For example: *) Theorem andb_commutative : forall b c, andb b c = andb c b. MProof. intros b c. destruct b. - destruct c. + reflexivity. + reflexivity. - destruct c. + reflexivity. + reflexivity. Qed. (** Each pair of calls to [reflexivity] corresponds to the subgoals that were generated after the execution of the [destruct c] line right above it. *) (** Besides [-] and [+], we can use [*] (asterisk) as a third kind of bullet. We can also enclose sub-proofs in curly braces, which is useful in case we ever encounter a proof that generates more than three levels of subgoals: *) Theorem andb_commutative' : forall b c, andb b c = andb c b. MProof. intros b c. destruct b. { destruct c. { reflexivity. } { reflexivity. } } { destruct c. { reflexivity. } { reflexivity. } } Qed. (** Since curly braces mark both the beginning and the end of a proof, they can be used for multiple subgoal levels, as this example shows. Furthermore, curly braces allow us to reuse the same bullet shapes at multiple levels in a proof: *) Theorem andb3_exchange : forall b c d, andb (andb b c) d = andb (andb b d) c. MProof. intros b c d. destruct b. - destruct c. { destruct d. - reflexivity. - reflexivity. } { destruct d. - reflexivity. - reflexivity. } - destruct c. { destruct d. - reflexivity. - reflexivity. } { destruct d. - reflexivity. - reflexivity. } Qed. (** Before closing the chapter, let's mention one final convenience. As you may have noticed, many proofs perform case analysis on a variable right after introducing it: intros x y. destruct y as [|y]. This pattern is so common that Coq provides a shorthand for it: we can perform case analysis on a variable when introducing it by using an intro pattern instead of a variable name. For instance, here is a shorter proof of the [plus_1_neq_0] theorem above. *) Theorem plus_1_neq_0' : forall n : nat, beq_nat (n + 1) 0 = false. MProof. pintros [|~~| \n]. - reflexivity. - reflexivity. Qed. (** If there are no arguments to name, we can just write [[]]. *) Theorem andb_commutative'' : forall b c, andb b c = andb c b. MProof. pintros [| ] [| ]. - reflexivity. - reflexivity. - reflexivity. - reflexivity. Qed. (** **** Exercise: 2 stars (andb_true_elim2) *) (** Prove the following claim, marking cases (and subcases) with bullets when you use [destruct]. *) Theorem andb_true_elim2 : forall b c : bool, andb b c = true -> c = true. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star (zero_nbeq_plus_1) *) Theorem zero_nbeq_plus_1 : forall n : nat, beq_nat 0 (n + 1) = false. MProof. (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** More on Notation (Optional) *) (** (In general, sections marked Optional are not needed to follow the rest of the book, except possibly other Optional sections. On a first reading, you might want to skim these sections so that you know what's there for future reference.) Recall the notation definitions for infix plus and times: *) Notation "x + y" := (plus x y) (at level 50, left associativity) : nat_scope. Notation "x * y" := (mult x y) (at level 40, left associativity) : nat_scope. (** For each notation symbol in Coq, we can specify its _precedence level_ and its _associativity_. The precedence level [n] is specified by writing [at level n]; this helps Coq parse compound expressions. The associativity setting helps to disambiguate expressions containing multiple occurrences of the same symbol. For example, the parameters specified above for [+] and [*] say that the expression [1+2*3*4] is shorthand for [(1+((2*3)*4))]. Coq uses precedence levels from 0 to 100, and _left_, _right_, or _no_ associativity. We will see more examples of this later, e.g., in the [Lists] chapter. Each notation symbol is also associated with a _notation scope_. Coq tries to guess what scope is meant from context, so when it sees [S(O*O)] it guesses [nat_scope], but when it sees the cartesian product (tuple) type [bool*bool] (which we'll see in later chapters) it guesses [type_scope]. Occasionally, it is necessary to help it out with percent-notation by writing [(x*y)%nat], and sometimes in what Coq prints it will use [%nat] to indicate what scope a notation is in. Notation scopes also apply to numeral notation ([3], [4], [5], etc.), so you may sometimes see [0%nat], which means [O] (the natural number [0] that we're using in this chapter), or [0%Z], which means the Integer zero (which comes from a different part of the standard library). Pro tip: Coq's notation mechanism is not especially powerful. Don't expect too much from it! *) (* ================================================================= *) (** ** Fixpoints and Structural Recursion (Optional) *) (** Here is a copy of the definition of addition: *) Fixpoint plus' (n : nat) (m : nat) : nat := match n with | O => m | S n' => S (plus' n' m) end. (** When Coq checks this definition, it notes that [plus'] is "decreasing on 1st argument." What this means is that we are performing a _structural recursion_ over the argument [n] -- i.e., that we make recursive calls only on strictly smaller values of [n]. This implies that all calls to [plus'] will eventually terminate. Coq demands that some argument of _every_ [Fixpoint] definition is "decreasing." This requirement is a fundamental feature of Coq's design: In particular, it guarantees that every function that can be defined in Coq will terminate on all inputs. However, because Coq's "decreasing analysis" is not very sophisticated, it is sometimes necessary to write functions in slightly unnatural ways. *) (** **** Exercise: 2 stars, optional (decreasing) *) (** To get a concrete sense of this, find a way to write a sensible [Fixpoint] definition (of a simple function on numbers, say) that _does_ terminate on all inputs, but that Coq will reject because of this restriction. *) (* FILL IN HERE *) (** [] *) (* ################################################################# *) (** * More Exercises *) (** **** Exercise: 2 stars (boolean_functions) *) (** Use the tactics you have learned so far to prove the following theorem about boolean functions. *) Theorem identity_fn_applied_twice : forall (f : bool -> bool), (forall (x : bool), f x = x) -> forall (b : bool), f (f b) = b. MProof. (* FILL IN HERE *) Admitted. (** Now state and prove a theorem [negation_fn_applied_twice] similar to the previous one but where the second hypothesis says that the function [f] has the property that [f x = negb x].*) (* FILL IN HERE *) (** [] *) (** **** Exercise: 3 stars, optional (andb_eq_orb) *) (** Prove the following theorem. (Hint: This one can be a bit tricky, depending on how you approach it. You will probably need both [destruct] and [rewrite], but destructing everything in sight is not the best way.) *) Theorem andb_eq_orb : forall (b c : bool), (andb b c = orb b c) -> b = c. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars (binary) *) (** Consider a different, more efficient representation of natural numbers using a binary rather than unary system. That is, instead of saying that each natural number is either zero or the successor of a natural number, we can say that each binary number is either - zero, - twice a binary number, or - one more than twice a binary number. (a) First, write an inductive definition of the type [bin] corresponding to this description of binary numbers. (Hint: Recall that the definition of [nat] above, Inductive nat : Type := | O : nat | S : nat -> nat. says nothing about what [O] and [S] "mean." It just says "[O] is in the set called [nat], and if [n] is in the set then so is [S n]." The interpretation of [O] as zero and [S] as successor/plus one comes from the way that we _use_ [nat] values, by writing functions to do things with them, proving things about them, and so on. Your definition of [bin] should be correspondingly simple; it is the functions you will write next that will give it mathematical meaning.) (b) Next, write an increment function [incr] for binary numbers, and a function [bin_to_nat] to convert binary numbers to unary numbers. (c) Write five unit tests [test_bin_incr1], [test_bin_incr2], etc. for your increment and binary-to-unary functions. (A "unit test" in Coq is a specific [Example] that can be proved with just [reflexivity], as we've done for several of our definitions.) Notice that incrementing a binary number and then converting it to unary should yield the same result as first converting it to unary and then incrementing. *) (* FILL IN HERE *) (** [] *) (** $Date: 2017-09-05 11:51:58 -0400 (Tue, 05 Sep 2017) $ *) Mtac2-1.4-coq8.20/tests/sf-5/lf/Induction.v000066400000000000000000000514171472011217100200600ustar00rootroot00000000000000(** * Induction: Proof by Induction *) (** Before getting started, we need to import all of our definitions from the previous chapter: *) From lf Require Export Basics. (** For the [Require Export] to work, you first need to use [coqc] to compile [Basics.v] into [Basics.vo]. This is like making a .class file from a .java file, or a .o file from a .c file. There are two ways to do it: - In CoqIDE: Open [Basics.v]. In the "Compile" menu, click on "Compile Buffer". - From the command line: Either [make Basics.vo] (assuming you've downloaded the whole LF directory and have a working 'make' command) or [coqc Basics.v] (which should work from any terminal window). If you have trouble (e.g., if you get complaints about missing identifiers later in the file), it may be because the "load path" for Coq is not set up correctly. The [Print LoadPath.] command may be helpful in sorting out such issues. *) (* ################################################################# *) (** * Proof by Induction *) (** We proved in the last chapter that [0] is a neutral element for [+] on the left, using an easy argument based on simplification. We also observed that proving the fact that it is also a neutral element on the _right_... *) Theorem plus_n_O_firsttry : forall n:nat, n = n + 0. (** ... can't be done in the same simple way. Just applying [reflexivity] doesn't work, since the [n] in [n + 0] is an arbitrary unknown number, so the [match] in the definition of [+] can't be simplified. *) MProof. intros n. simpl. (* Does nothing! *) Abort. (** And reasoning by cases using [destruct n] doesn't get us much further: the branch of the case analysis where we assume [n = 0] goes through fine, but in the branch where [n = S n'] for some [n'] we get stuck in exactly the same way. *) Theorem plus_n_O_secondtry : forall n:nat, n = n + 0. MProof. intros n. destruct n &> [i: ~~ | \n']. - (* n = 0 *) reflexivity. (* so far so good... *) - (* n = S n' *) simpl. (* ...but here we are stuck again *) Abort. (** We could use [destruct n'] to get one step further, but, since [n] can be arbitrarily large, if we just go on like this we'll never finish. *) (** To prove interesting facts about numbers, lists, and other inductively defined sets, we usually need a more powerful reasoning principle: _induction_. Recall (from high school, a discrete math course, etc.) the _principle of induction over natural numbers_: If [P(n)] is some proposition involving a natural number [n] and we want to show that [P] holds for all numbers [n], we can reason like this: - show that [P(O)] holds; - show that, for any [n'], if [P(n')] holds, then so does [P(S n')]; - conclude that [P(n)] holds for all [n]. In Coq, the steps are the same: we begin with the goal of proving [P(n)] for all [n] and break it down (by applying the [induction] tactic) into two separate subgoals: one where we must show [P(O)] and another where we must show [P(n') -> P(S n')]. Here's how this works for the theorem at hand: *) Theorem plus_n_O : forall n:nat, n = n + 0. MProof. intros n. elim n &> [i: ~~ | \n' IHn']. - (* n = 0 *) reflexivity. - (* n = S n' *) simpl. rewrite <- IHn'. reflexivity. Qed. (** Like [destruct], the [induction] tactic takes an [as...] clause that specifies the names of the variables to be introduced in the subgoals. Since there are two subgoals, the [as...] clause has two parts, separated by [|]. (Strictly speaking, we can omit the [as...] clause and Coq will choose names for us. In practice, this is a bad idea, as Coq's automatic choices tend to be confusing.) In the first subgoal, [n] is replaced by [0]. No new variables are introduced (so the first part of the [as...] is empty), and the goal becomes [0 = 0 + 0], which follows by simplification. In the second subgoal, [n] is replaced by [S n'], and the assumption [n' + 0 = n'] is added to the context with the name [IHn'] (i.e., the Induction Hypothesis for [n']). These two names are specified in the second part of the [as...] clause. The goal in this case becomes [S n' = (S n') + 0], which simplifies to [S n' = S (n' + 0)], which in turn follows from [IHn']. *) Theorem minus_diag : forall n, minus n n = 0. MProof. (* WORKED IN CLASS *) intros n. elim n &> [i:~~| \n' IHn']. - (* n = 0 *) simpl. reflexivity. - (* n = S n' *) simpl. rewrite -> IHn'. reflexivity. Qed. (** (The use of the [intros] tactic in these proofs is actually redundant. When applied to a goal that contains quantified variables, the [induction] tactic will automatically move them into the context as needed.) *) (** **** Exercise: 2 stars, recommended (basic_induction) *) (** Prove the following using induction. You might need previously proven results. *) Theorem mult_0_r : forall n:nat, n * 0 = 0. MProof. (* FILL IN HERE *) Admitted. Theorem plus_n_Sm : forall n m : nat, S (n + m) = n + (S m). MProof. (* FILL IN HERE *) Admitted. Theorem plus_comm : forall n m : nat, n + m = m + n. MProof. (* FILL IN HERE *) Admitted. Theorem plus_assoc : forall n m p : nat, n + (m + p) = (n + m) + p. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars (double_plus) *) (** Consider the following function, which doubles its argument: *) Fixpoint double (n:nat) := match n with | O => O | S n' => S (S (double n')) end. (** Use induction to prove this simple fact about [double]: *) Lemma double_plus : forall n, double n = n + n . MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, optional (evenb_S) *) (** One inconvenient aspect of our definition of [evenb n] is the recursive call on [n - 2]. This makes proofs about [evenb n] harder when done by induction on [n], since we may need an induction hypothesis about [n - 2]. The following lemma gives an alternative characterization of [evenb (S n)] that works better with induction: *) Theorem evenb_S : forall n : nat, evenb (S n) = negb (evenb n). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star (destruct_induction) *) (** Briefly explain the difference between the tactics [destruct] and [induction]. (* FILL IN HERE *) *) (** [] *) (* ################################################################# *) (** * Proofs Within Proofs *) (** In Coq, as in informal mathematics, large proofs are often broken into a sequence of theorems, with later proofs referring to earlier theorems. But sometimes a proof will require some miscellaneous fact that is too trivial and of too little general interest to bother giving it its own top-level name. In such cases, it is convenient to be able to simply state and prove the needed "sub-theorem" right at the point where it is used. The [assert] tactic allows us to do this. For example, our earlier proof of the [mult_0_plus] theorem referred to a previous theorem named [plus_O_n]. We could instead use [assert] to state and prove [plus_O_n] in-line: *) Theorem mult_0_plus' : forall n m : nat, (0 + n) * m = n * m. MProof. intros n m. assert (H: 0 + n = n). { reflexivity. } rewrite -> H. reflexivity. Qed. (** The [assert] tactic introduces two sub-goals. The first is the assertion itself; by prefixing it with [H:] we name the assertion [H]. (We can also name the assertion with [as] just as we did above with [destruct] and [induction], i.e., [assert (0 + n = n) as H].) Note that we surround the proof of this assertion with curly braces [{ ... }], both for readability and so that, when using Coq interactively, we can see more easily when we have finished this sub-proof. The second goal is the same as the one at the point where we invoke [assert] except that, in the context, we now have the assumption [H] that [0 + n = n]. That is, [assert] generates one subgoal where we must prove the asserted fact and a second subgoal where we can use the asserted fact to make progress on whatever we were trying to prove in the first place. *) (** Another example of [assert]... *) (** For example, suppose we want to prove that [(n + m) + (p + q) = (m + n) + (p + q)]. The only difference between the two sides of the [=] is that the arguments [m] and [n] to the first inner [+] are swapped, so it seems we should be able to use the commutativity of addition ([plus_comm]) to rewrite one into the other. However, the [rewrite] tactic is not very smart about _where_ it applies the rewrite. There are three uses of [+] here, and it turns out that doing [rewrite -> plus_comm] will affect only the _outer_ one... *) Theorem plus_rearrange_firsttry : forall n m p q : nat, (n + m) + (p + q) = (m + n) + (p + q). MProof. intros n m p q. (* We just need to swap (n + m) for (m + n)... seems like plus_comm should do the trick! *) rewrite -> plus_comm. (* Doesn't work...Coq rewrote the wrong plus! *) Abort. (** To use [plus_comm] at the point where we need it, we can introduce a local lemma stating that [n + m = m + n] (for the particular [m] and [n] that we are talking about here), prove this lemma using [plus_comm], and then use it to do the desired rewrite. *) Theorem plus_rearrange : forall n m p q : nat, (n + m) + (p + q) = (m + n) + (p + q). MProof. intros n m p q. assert (H: n + m = m + n). { rewrite -> plus_comm. reflexivity. } rewrite -> H. reflexivity. Qed. (* ################################################################# *) (** * Formal vs. Informal Proof *) (** "_Informal proofs are algorithms; formal proofs are code_." *) (** What constitutes a successful proof of a mathematical claim? The question has challenged philosophers for millennia, but a rough and ready definition could be this: A proof of a mathematical proposition [P] is a written (or spoken) text that instills in the reader or hearer the certainty that [P] is true -- an unassailable argument for the truth of [P]. That is, a proof is an act of communication. Acts of communication may involve different sorts of readers. On one hand, the "reader" can be a program like Coq, in which case the "belief" that is instilled is that [P] can be mechanically derived from a certain set of formal logical rules, and the proof is a recipe that guides the program in checking this fact. Such recipes are _formal_ proofs. Alternatively, the reader can be a human being, in which case the proof will be written in English or some other natural language, and will thus necessarily be _informal_. Here, the criteria for success are less clearly specified. A "valid" proof is one that makes the reader believe [P]. But the same proof may be read by many different readers, some of whom may be convinced by a particular way of phrasing the argument, while others may not be. Some readers may be particularly pedantic, inexperienced, or just plain thick-headed; the only way to convince them will be to make the argument in painstaking detail. But other readers, more familiar in the area, may find all this detail so overwhelming that they lose the overall thread; all they want is to be told the main ideas, since it is easier for them to fill in the details for themselves than to wade through a written presentation of them. Ultimately, there is no universal standard, because there is no single way of writing an informal proof that is guaranteed to convince every conceivable reader. In practice, however, mathematicians have developed a rich set of conventions and idioms for writing about complex mathematical objects that -- at least within a certain community -- make communication fairly reliable. The conventions of this stylized form of communication give a fairly clear standard for judging proofs good or bad. Because we are using Coq in this course, we will be working heavily with formal proofs. But this doesn't mean we can completely forget about informal ones! Formal proofs are useful in many ways, but they are _not_ very efficient ways of communicating ideas between human beings. *) (** For example, here is a proof that addition is associative: *) Theorem plus_assoc' : forall n m p : nat, n + (m + p) = (n + m) + p. MProof. intros n m p. elim n &> [i: ~~ | \n' IHn']. reflexivity. simpl. rewrite -> IHn'. reflexivity. Qed. (** Coq is perfectly happy with this. For a human, however, it is difficult to make much sense of it. We can use comments and bullets to show the structure a little more clearly... *) Theorem plus_assoc'' : forall n m p : nat, n + (m + p) = (n + m) + p. MProof. intros n m p. elim n &> [i:~~ | \n' IHn']. - (* n = 0 *) reflexivity. - (* n = S n' *) simpl. rewrite -> IHn'. reflexivity. Qed. (** ... and if you're used to Coq you may be able to step through the tactics one after the other in your mind and imagine the state of the context and goal stack at each point, but if the proof were even a little bit more complicated this would be next to impossible. A (pedantic) mathematician might write the proof something like this: *) (** - _Theorem_: For any [n], [m] and [p], n + (m + p) = (n + m) + p. _Proof_: By induction on [n]. - First, suppose [n = 0]. We must show 0 + (m + p) = (0 + m) + p. This follows directly from the definition of [+]. - Next, suppose [n = S n'], where n' + (m + p) = (n' + m) + p. We must show (S n') + (m + p) = ((S n') + m) + p. By the definition of [+], this follows from S (n' + (m + p)) = S ((n' + m) + p), which is immediate from the induction hypothesis. _Qed_. *) (** The overall form of the proof is basically similar, and of course this is no accident: Coq has been designed so that its [induction] tactic generates the same sub-goals, in the same order, as the bullet points that a mathematician would write. But there are significant differences of detail: the formal proof is much more explicit in some ways (e.g., the use of [reflexivity]) but much less explicit in others (in particular, the "proof state" at any given point in the Coq proof is completely implicit, whereas the informal proof reminds the reader several times where things stand). *) (** **** Exercise: 2 stars, advanced, recommended (plus_comm_informal) *) (** Translate your solution for [plus_comm] into an informal proof: Theorem: Addition is commutative. Proof: (* FILL IN HERE *) *) (** [] *) (** **** Exercise: 2 stars, optional (beq_nat_refl_informal) *) (** Write an informal proof of the following theorem, using the informal proof of [plus_assoc] as a model. Don't just paraphrase the Coq tactics into English! Theorem: [true = beq_nat n n] for any [n]. Proof: (* FILL IN HERE *) [] *) (* ################################################################# *) (** * More Exercises *) (** **** Exercise: 3 stars, recommended (mult_comm) *) (** Use [assert] to help prove this theorem. You shouldn't need to use induction on [plus_swap]. *) Theorem plus_swap : forall n m p : nat, n + (m + p) = m + (n + p). MProof. (* FILL IN HERE *) Admitted. (** Now prove commutativity of multiplication. (You will probably need to define and prove a separate subsidiary theorem to be used in the proof of this one. You may find that [plus_swap] comes in handy.) *) Theorem mult_comm : forall m n : nat, m * n = n * m. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, optional (more_exercises) *) (** Take a piece of paper. For each of the following theorems, first _think_ about whether (a) it can be proved using only simplification and rewriting, (b) it also requires case analysis ([destruct]), or (c) it also requires induction. Write down your prediction. Then fill in the proof. (There is no need to turn in your piece of paper; this is just to encourage you to reflect before you hack!) *) Check leb. Theorem leb_refl : forall n:nat, true = leb n n. MProof. (* FILL IN HERE *) Admitted. Theorem zero_nbeq_S : forall n:nat, beq_nat 0 (S n) = false. MProof. (* FILL IN HERE *) Admitted. Theorem andb_false_r : forall b : bool, andb b false = false. MProof. (* FILL IN HERE *) Admitted. Theorem plus_ble_compat_l : forall n m p : nat, leb n m = true -> leb (p + n) (p + m) = true. MProof. (* FILL IN HERE *) Admitted. Theorem S_nbeq_0 : forall n:nat, beq_nat (S n) 0 = false. MProof. (* FILL IN HERE *) Admitted. Theorem mult_1_l : forall n:nat, 1 * n = n. MProof. (* FILL IN HERE *) Admitted. Theorem all3_spec : forall b c : bool, orb (andb b c) (orb (negb b) (negb c)) = true. MProof. (* FILL IN HERE *) Admitted. Theorem mult_plus_distr_r : forall n m p : nat, (n + m) * p = (n * p) + (m * p). MProof. (* FILL IN HERE *) Admitted. Theorem mult_assoc : forall n m p : nat, n * (m * p) = (n * m) * p. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, optional (beq_nat_refl) *) (** Prove the following theorem. (Putting the [true] on the left-hand side of the equality may look odd, but this is how the theorem is stated in the Coq standard library, so we follow suit. Rewriting works equally well in either direction, so we will have no problem using the theorem no matter which way we state it.) *) Theorem beq_nat_refl : forall n : nat, true = beq_nat n n. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, optional (plus_swap') *) (** The [replace] tactic allows you to specify a particular subterm to rewrite and what you want it rewritten to: [replace (t) with (u)] replaces (all copies of) expression [t] in the goal by expression [u], and generates [t = u] as an additional subgoal. This is often useful when a plain [rewrite] acts on the wrong part of the goal. Use the [replace] tactic to do a proof of [plus_swap'], just like [plus_swap] but without needing [assert (n + m = m + n)]. *) Theorem plus_swap' : forall n m p : nat, n + (m + p) = m + (n + p). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, recommended (binary_commute) *) (** Recall the [incr] and [bin_to_nat] functions that you wrote for the [binary] exercise in the [Basics] chapter. Prove that the following diagram commutes: incr bin ----------------------> bin | | bin_to_nat | | bin_to_nat | | v v nat ----------------------> nat S That is, incrementing a binary number and then converting it to a (unary) natural number yields the same result as first converting it to a natural number and then incrementing. Name your theorem [bin_to_nat_pres_incr] ("pres" for "preserves"). Before you start working on this exercise, copy the definitions from your solution to the [binary] exercise here so that this file can be graded on its own. If you want to change your original definitions to make the property easier to prove, feel free to do so! *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 5 stars, advanced (binary_inverse) *) (** This exercise is a continuation of the previous exercise about binary numbers. You will need your definitions and theorems from there to complete this one; please copy them to this file to make it self contained for grading. (a) First, write a function to convert natural numbers to binary numbers. Then prove that starting with any natural number, converting to binary, then converting back yields the same natural number you started with. (b) You might naturally think that we should also prove the opposite direction: that starting with a binary number, converting to a natural, and then back to binary yields the same number we started with. However, this is not true! Explain what the problem is. (c) Define a "direct" normalization function -- i.e., a function [normalize] from binary numbers to binary numbers such that, for any binary number b, converting to a natural and then back to binary yields [(normalize b)]. Prove it. (Warning: This part is tricky!) Again, feel free to change your earlier definitions if this helps here. *) (* FILL IN HERE *) (** [] *) (** $Date: 2017-09-06 10:45:52 -0400 (Wed, 06 Sep 2017) $ *) Mtac2-1.4-coq8.20/tests/sf-5/lf/Lists.v000066400000000000000000001061301472011217100172130ustar00rootroot00000000000000(** * Lists: Working with Structured Data *) From lf Require Export Induction. Module NatList. (* ################################################################# *) (** * Pairs of Numbers *) (** In an [Inductive] type definition, each constructor can take any number of arguments -- none (as with [true] and [O]), one (as with [S]), or more than one, as here: *) Inductive natprod : Type := | pair : nat -> nat -> natprod. (** This declaration can be read: "There is just one way to construct a pair of numbers: by applying the constructor [pair] to two arguments of type [nat]." *) Check (pair 3 5). (** Here are two simple functions for extracting the first and second components of a pair. The definitions also illustrate how to do pattern matching on two-argument constructors. *) Definition fst (p : natprod) : nat := match p with | pair x y => x end. Definition snd (p : natprod) : nat := match p with | pair x y => y end. Compute (fst (pair 3 5)). (* ===> 3 *) (** Since pairs are used quite a bit, it is nice to be able to write them with the standard mathematical notation [(x,y)] instead of [pair x y]. We can tell Coq to allow this with a [Notation] declaration. *) Notation "( x , y )" := (pair x y). (** The new pair notation can be used both in expressions and in pattern matches (indeed, we've actually seen this already in the [Basics] chapter, in the definition of the [minus] function -- this works because the pair notation is also provided as part of the standard library): *) Compute (fst (3,5)). Definition fst' (p : natprod) : nat := match p with | (x,y) => x end. Definition snd' (p : natprod) : nat := match p with | (x,y) => y end. Definition swap_pair (p : natprod) : natprod := match p with | (x,y) => (y,x) end. (** Let's try to prove a few simple facts about pairs. If we state things in a particular (and slightly peculiar) way, we can complete proofs with just reflexivity (and its built-in simplification): *) Theorem surjective_pairing' : forall (n m : nat), (n,m) = (fst (n,m), snd (n,m)). MProof. reflexivity. Qed. (** But [reflexivity] is not enough if we state the lemma in a more natural way: *) Theorem surjective_pairing_stuck : forall (p : natprod), p = (fst p, snd p). MProof. simpl. (* Doesn't reduce anything! *) Abort. (** We have to expose the structure of [p] so that [simpl] can perform the pattern match in [fst] and [snd]. We can do this with [destruct]. *) Theorem surjective_pairing : forall (p : natprod), p = (fst p, snd p). MProof. intros p. destruct p &> [i:\n m]. simpl. reflexivity. Qed. (** Notice that, unlike its behavior with [nat]s, [destruct] generates just one subgoal here. That's because [natprod]s can only be constructed in one way. *) (** **** Exercise: 1 star (snd_fst_is_swap) *) Theorem snd_fst_is_swap : forall (p : natprod), (snd p, fst p) = swap_pair p. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star, optional (fst_swap_is_snd) *) Theorem fst_swap_is_snd : forall (p : natprod), fst (swap_pair p) = snd p. MProof. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Lists of Numbers *) (** Generalizing the definition of pairs, we can describe the type of _lists_ of numbers like this: "A list is either the empty list or else a pair of a number and another list." *) Inductive natlist : Type := | nil : natlist | cons : nat -> natlist -> natlist. (** For example, here is a three-element list: *) Definition mylist := cons 1 (cons 2 (cons 3 nil)). (** As with pairs, it is more convenient to write lists in familiar programming notation. The following declarations allow us to use [::] as an infix [cons] operator and square brackets as an "outfix" notation for constructing lists. *) Notation "x :: l" := (cons x l) (at level 60, right associativity). Notation "[ ]" := nil. Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..). (** It is not necessary to understand the details of these declarations, but in case you are interested, here is roughly what's going on. The [right associativity] annotation tells Coq how to parenthesize expressions involving several uses of [::] so that, for example, the next three declarations mean exactly the same thing: *) Definition mylist1 := 1 :: (2 :: (3 :: nil)). Definition mylist2 := 1 :: 2 :: 3 :: nil. Definition mylist3 := [1;2;3]. (** The [at level 60] part tells Coq how to parenthesize expressions that involve both [::] and some other infix operator. For example, since we defined [+] as infix notation for the [plus] function at level 50, Notation "x + y" := (plus x y) (at level 50, left associativity). the [+] operator will bind tighter than [::], so [1 + 2 :: [3]] will be parsed, as we'd expect, as [(1 + 2) :: [3]] rather than [1 + (2 :: [3])]. (Expressions like "[1 + 2 :: [3]]" can be a little confusing when you read them in a .v file. The inner brackets, around 3, indicate a list, but the outer brackets, which are invisible in the HTML rendering, are there to instruct the "coqdoc" tool that the bracketed part should be displayed as Coq code rather than running text.) The second and third [Notation] declarations above introduce the standard square-bracket notation for lists; the right-hand side of the third one illustrates Coq's syntax for declaring n-ary notations and translating them to nested sequences of binary constructors. *) (* ----------------------------------------------------------------- *) (** *** Repeat *) (** A number of functions are useful for manipulating lists. For example, the [repeat] function takes a number [n] and a [count] and returns a list of length [count] where every element is [n]. *) Fixpoint repeat (n count : nat) : natlist := match count with | O => nil | S count' => n :: (repeat n count') end. (* ----------------------------------------------------------------- *) (** *** Length *) (** The [length] function calculates the length of a list. *) Fixpoint length (l:natlist) : nat := match l with | nil => O | h :: t => S (length t) end. (* ----------------------------------------------------------------- *) (** *** Append *) (** The [app] function concatenates (appends) two lists. *) Fixpoint app (l1 l2 : natlist) : natlist := match l1 with | nil => l2 | h :: t => h :: (app t l2) end. (** Actually, [app] will be used a lot in some parts of what follows, so it is convenient to have an infix operator for it. *) Notation "x ++ y" := (app x y) (right associativity, at level 60). Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5]. MProof. reflexivity. Qed. Example test_app2: nil ++ [4;5] = [4;5]. MProof. reflexivity. Qed. Example test_app3: [1;2;3] ++ nil = [1;2;3]. MProof. reflexivity. Qed. (* ----------------------------------------------------------------- *) (** *** Head (with default) and Tail *) (** Here are two smaller examples of programming with lists. The [hd] function returns the first element (the "head") of the list, while [tl] returns everything but the first element (the "tail"). Of course, the empty list has no first element, so we must pass a default value to be returned in that case. *) Definition hd (default:nat) (l:natlist) : nat := match l with | nil => default | h :: t => h end. Definition tl (l:natlist) : natlist := match l with | nil => nil | h :: t => t end. Example test_hd1: hd 0 [1;2;3] = 1. MProof. reflexivity. Qed. Example test_hd2: hd 0 [] = 0. MProof. reflexivity. Qed. Example test_tl: tl [1;2;3] = [2;3]. MProof. reflexivity. Qed. (* ----------------------------------------------------------------- *) (** *** Exercises *) (** **** Exercise: 2 stars, recommended (list_funs) *) (** Complete the definitions of [nonzeros], [oddmembers] and [countoddmembers] below. Have a look at the tests to understand what these functions should do. *) Fixpoint nonzeros (l:natlist) : natlist (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_nonzeros: nonzeros [0;1;0;2;3;0;0] = [1;2;3]. (* FILL IN HERE *) Admitted. Fixpoint oddmembers (l:natlist) : natlist (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_oddmembers: oddmembers [0;1;0;2;3;0;0] = [1;3]. (* FILL IN HERE *) Admitted. Definition countoddmembers (l:natlist) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_countoddmembers1: countoddmembers [1;0;3;1;4;5] = 4. (* FILL IN HERE *) Admitted. Example test_countoddmembers2: countoddmembers [0;2;4] = 0. (* FILL IN HERE *) Admitted. Example test_countoddmembers3: countoddmembers nil = 0. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, advanced (alternate) *) (** Complete the definition of [alternate], which "zips up" two lists into one, alternating between elements taken from the first list and elements from the second. See the tests below for more specific examples. Note: one natural and elegant way of writing [alternate] will fail to satisfy Coq's requirement that all [Fixpoint] definitions be "obviously terminating." If you find yourself in this rut, look for a slightly more verbose solution that considers elements of both lists at the same time. (One possible solution requires defining a new kind of pairs, but this is not the only way.) *) Fixpoint alternate (l1 l2 : natlist) : natlist (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_alternate1: alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6]. (* FILL IN HERE *) Admitted. Example test_alternate2: alternate [1] [4;5;6] = [1;4;5;6]. (* FILL IN HERE *) Admitted. Example test_alternate3: alternate [1;2;3] [4] = [1;4;2;3]. (* FILL IN HERE *) Admitted. Example test_alternate4: alternate [] [20;30] = [20;30]. (* FILL IN HERE *) Admitted. (** [] *) (* ----------------------------------------------------------------- *) (** *** Bags via Lists *) (** A [bag] (or [multiset]) is like a set, except that each element can appear multiple times rather than just once. One possible implementation is to represent a bag of numbers as a list. *) Definition bag := natlist. (** **** Exercise: 3 stars, recommended (bag_functions) *) (** Complete the following definitions for the functions [count], [sum], [add], and [member] for bags. *) Fixpoint count (v:nat) (s:bag) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** All these proofs can be done just by [reflexivity]. *) Example test_count1: count 1 [1;2;3;1;4;1] = 3. (* FILL IN HERE *) Admitted. Example test_count2: count 6 [1;2;3;1;4;1] = 0. (* FILL IN HERE *) Admitted. (** Multiset [sum] is similar to set [union]: [sum a b] contains all the elements of [a] and of [b]. (Mathematicians usually define [union] on multisets a little bit differently -- using max instead of sum -- which is why we don't use that name for this operation.) For [sum] we're giving you a header that does not give explicit names to the arguments. Moreover, it uses the keyword [Definition] instead of [Fixpoint], so even if you had names for the arguments, you wouldn't be able to process them recursively. The point of stating the question this way is to encourage you to think about whether [sum] can be implemented in another way -- perhaps by using functions that have already been defined. *) Definition sum : bag -> bag -> bag (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3. (* FILL IN HERE *) Admitted. Definition add (v:nat) (s:bag) : bag (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_add1: count 1 (add 1 [1;4;1]) = 3. (* FILL IN HERE *) Admitted. Example test_add2: count 5 (add 1 [1;4;1]) = 0. (* FILL IN HERE *) Admitted. Definition member (v:nat) (s:bag) : bool (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_member1: member 1 [1;4;1] = true. (* FILL IN HERE *) Admitted. Example test_member2: member 2 [1;4;1] = false. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, optional (bag_more_functions) *) (** Here are some more bag functions for you to practice with. *) (** When remove_one is applied to a bag without the number to remove, it should return the same bag unchanged. *) Fixpoint remove_one (v:nat) (s:bag) : bag (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_remove_one1: count 5 (remove_one 5 [2;1;5;4;1]) = 0. (* FILL IN HERE *) Admitted. Example test_remove_one2: count 5 (remove_one 5 [2;1;4;1]) = 0. (* FILL IN HERE *) Admitted. Example test_remove_one3: count 4 (remove_one 5 [2;1;4;5;1;4]) = 2. (* FILL IN HERE *) Admitted. Example test_remove_one4: count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1. (* FILL IN HERE *) Admitted. Fixpoint remove_all (v:nat) (s:bag) : bag (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0. (* FILL IN HERE *) Admitted. Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0. (* FILL IN HERE *) Admitted. Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2. (* FILL IN HERE *) Admitted. Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0. (* FILL IN HERE *) Admitted. Fixpoint subset (s1:bag) (s2:bag) : bool (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_subset1: subset [1;2] [2;1;4;1] = true. (* FILL IN HERE *) Admitted. Example test_subset2: subset [1;2;2] [2;1;4;1] = false. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, recommended (bag_theorem) *) (** Write down an interesting theorem [bag_theorem] about bags involving the functions [count] and [add], and prove it. Note that, since this problem is somewhat open-ended, it's possible that you may come up with a theorem which is true, but whose proof requires techniques you haven't learned yet. Feel free to ask for help if you get stuck! *) (* Theorem bag_theorem : ... Proof. ... Qed. *) (** [] *) (* ################################################################# *) (** * Reasoning About Lists *) (** As with numbers, simple facts about list-processing functions can sometimes be proved entirely by simplification. For example, the simplification performed by [reflexivity] is enough for this theorem... *) Theorem nil_app : forall l:natlist, [] ++ l = l. MProof. reflexivity. Qed. (** ... because the [[]] is substituted into the "scrutinee" (the expression whose value is being "scrutinized" by the match) in the definition of [app], allowing the match itself to be simplified. *) (** Also, as with numbers, it is sometimes helpful to perform case analysis on the possible shapes (empty or non-empty) of an unknown list. *) Theorem tl_length_pred : forall l:natlist, pred (length l) = length (tl l). MProof. intros l. destruct l &> [i: ~~ | \n l']. - (* l = nil *) reflexivity. - (* l = cons n l' *) reflexivity. Qed. (** Here, the [nil] case works because we've chosen to define [tl nil = nil]. Notice that the [as] annotation on the [destruct] tactic here introduces two names, [n] and [l'], corresponding to the fact that the [cons] constructor for lists takes two arguments (the head and tail of the list it is constructing). *) (** Usually, though, interesting theorems about lists require induction for their proofs. *) (* ----------------------------------------------------------------- *) (** *** Micro-Sermon *) (** Simply reading example proof scripts will not get you very far! It is important to work through the details of each one, using Coq and thinking about what each step achieves. Otherwise it is more or less guaranteed that the exercises will make no sense when you get to them. 'Nuff said. *) (* ================================================================= *) (** ** Induction on Lists *) (** Proofs by induction over datatypes like [natlist] are a little less familiar than standard natural number induction, but the idea is equally simple. Each [Inductive] declaration defines a set of data values that can be built up using the declared constructors: a boolean can be either [true] or [false]; a number can be either [O] or [S] applied to another number; a list can be either [nil] or [cons] applied to a number and a list. Moreover, applications of the declared constructors to one another are the _only_ possible shapes that elements of an inductively defined set can have, and this fact directly gives rise to a way of reasoning about inductively defined sets: a number is either [O] or else it is [S] applied to some _smaller_ number; a list is either [nil] or else it is [cons] applied to some number and some _smaller_ list; etc. So, if we have in mind some proposition [P] that mentions a list [l] and we want to argue that [P] holds for _all_ lists, we can reason as follows: - First, show that [P] is true of [l] when [l] is [nil]. - Then show that [P] is true of [l] when [l] is [cons n l'] for some number [n] and some smaller list [l'], assuming that [P] is true for [l']. Since larger lists can only be built up from smaller ones, eventually reaching [nil], these two arguments together establish the truth of [P] for all lists [l]. Here's a concrete example: *) Theorem app_assoc : forall l1 l2 l3 : natlist, (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3). MProof. intros l1 l2 l3. elim l1 &> [i:~~| \n l1' IHl1']. - (* l1 = nil *) reflexivity. - (* l1 = cons n l1' *) simpl. rewrite -> IHl1'. reflexivity. Qed. (** Notice that, as when doing induction on natural numbers, the [as...] clause provided to the [induction] tactic gives a name to the induction hypothesis corresponding to the smaller list [l1'] in the [cons] case. Once again, this Coq proof is not especially illuminating as a static written document -- it is easy to see what's going on if you are reading the proof in an interactive Coq session and you can see the current goal and context at each point, but this state is not visible in the written-down parts of the Coq proof. So a natural-language proof -- one written for human readers -- will need to include more explicit signposts; in particular, it will help the reader stay oriented if we remind them exactly what the induction hypothesis is in the second case. *) (** For comparison, here is an informal proof of the same theorem. *) (** _Theorem_: For all lists [l1], [l2], and [l3], [(l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3)]. _Proof_: By induction on [l1]. - First, suppose [l1 = []]. We must show ([] ++ l2) ++ l3 = [] ++ (l2 ++ l3), which follows directly from the definition of [++]. - Next, suppose [l1 = n::l1'], with (l1' ++ l2) ++ l3 = l1' ++ (l2 ++ l3) (the induction hypothesis). We must show ((n :: l1') ++ l2) ++ l3 = (n :: l1') ++ (l2 ++ l3). By the definition of [++], this follows from n :: ((l1' ++ l2) ++ l3) = n :: (l1' ++ (l2 ++ l3)), which is immediate from the induction hypothesis. [] *) (* ----------------------------------------------------------------- *) (** *** Reversing a List *) (** For a slightly more involved example of inductive proof over lists, suppose we use [app] to define a list-reversing function [rev]: *) Fixpoint rev (l:natlist) : natlist := match l with | nil => nil | h :: t => rev t ++ [h] end. Example test_rev1: rev [1;2;3] = [3;2;1]. MProof. reflexivity. Qed. Example test_rev2: rev nil = nil. MProof. reflexivity. Qed. (* ----------------------------------------------------------------- *) (** *** Properties of [rev] *) (** Now let's prove some theorems about our newly defined [rev]. For something a bit more challenging than what we've seen, let's prove that reversing a list does not change its length. Our first attempt gets stuck in the successor case... *) Theorem rev_length_firsttry : forall l : natlist, length (rev l) = length l. MProof. intros l. elim l &> [i: ~~ | \n l' IHl']. - (* l = [] *) reflexivity. - (* l = n :: l' *) (* This is the tricky case. Let's begin as usual by simplifying. *) simpl. (* Now we seem to be stuck: the goal is an equality involving [++], but we don't have any useful equations in either the immediate context or in the global environment! We can make a little progress by using the IH to rewrite the goal... *) rewrite <- IHl'. (* ... but now we can't go any further. *) Abort. (** So let's take the equation relating [++] and [length] that would have enabled us to make progress and prove it as a separate lemma. *) Theorem app_length : forall l1 l2 : natlist, length (l1 ++ l2) = (length l1) + (length l2). MProof. (* WORKED IN CLASS *) intros l1 l2. elim l1 &> [i:~~| \n l1' IHl1']. - (* l1 = nil *) reflexivity. - (* l1 = cons *) simpl. rewrite -> IHl1'. reflexivity. Qed. (** Note that, to make the lemma as general as possible, we quantify over _all_ [natlist]s, not just those that result from an application of [rev]. This should seem natural, because the truth of the goal clearly doesn't depend on the list having been reversed. Moreover, it is easier to prove the more general property. *) (** Now we can complete the original proof. *) Theorem rev_length : forall l : natlist, length (rev l) = length l. MProof. intros l. elim l &> [i: ~~| \n l' IHl']. - (* l = nil *) reflexivity. - (* l = cons *) simpl. rewrite -> app_length, plus_comm. simpl. rewrite -> IHl'. reflexivity. Qed. (** For comparison, here are informal proofs of these two theorems: _Theorem_: For all lists [l1] and [l2], [length (l1 ++ l2) = length l1 + length l2]. _Proof_: By induction on [l1]. - First, suppose [l1 = []]. We must show length ([] ++ l2) = length [] + length l2, which follows directly from the definitions of [length] and [++]. - Next, suppose [l1 = n::l1'], with length (l1' ++ l2) = length l1' + length l2. We must show length ((n::l1') ++ l2) = length (n::l1') + length l2). This follows directly from the definitions of [length] and [++] together with the induction hypothesis. [] *) (** _Theorem_: For all lists [l], [length (rev l) = length l]. _Proof_: By induction on [l]. - First, suppose [l = []]. We must show length (rev []) = length [], which follows directly from the definitions of [length] and [rev]. - Next, suppose [l = n::l'], with length (rev l') = length l'. We must show length (rev (n :: l')) = length (n :: l'). By the definition of [rev], this follows from length ((rev l') ++ [n]) = S (length l') which, by the previous lemma, is the same as length (rev l') + length [n] = S (length l'). This follows directly from the induction hypothesis and the definition of [length]. [] *) (** The style of these proofs is rather longwinded and pedantic. After the first few, we might find it easier to follow proofs that give fewer details (which can easily work out in our own minds or on scratch paper if necessary) and just highlight the non-obvious steps. In this more compressed style, the above proof might look like this: *) (** _Theorem_: For all lists [l], [length (rev l) = length l]. _Proof_: First, observe that [length (l ++ [n]) = S (length l)] for any [l] (this follows by a straightforward induction on [l]). The main property again follows by induction on [l], using the observation together with the induction hypothesis in the case where [l = n'::l']. [] *) (** Which style is preferable in a given situation depends on the sophistication of the expected audience and how similar the proof at hand is to ones that the audience will already be familiar with. The more pedantic style is a good default for our present purposes. *) (* ================================================================= *) (** ** [Search] *) (** We've seen that proofs can make use of other theorems we've already proved, e.g., using [rewrite]. But in order to refer to a theorem, we need to know its name! Indeed, it is often hard even to remember what theorems have been proven, much less what they are called. Coq's [Search] command is quite helpful with this. Typing [Search foo] will cause Coq to display a list of all theorems involving [foo]. For example, try uncommenting the following line to see a list of theorems that we have proved about [rev]: *) (* Search rev. *) (** Keep [Search] in mind as you do the following exercises and throughout the rest of the book; it can save you a lot of time! If you are using ProofGeneral, you can run [Search] with [C-c C-a C-a]. Pasting its response into your buffer can be accomplished with [C-c C-;]. *) (* ================================================================= *) (** ** List Exercises, Part 1 *) (** **** Exercise: 3 stars (list_exercises) *) (** More practice with lists: *) Theorem app_nil_r : forall l : natlist, l ++ [] = l. MProof. (* FILL IN HERE *) Admitted. Theorem rev_app_distr: forall l1 l2 : natlist, rev (l1 ++ l2) = rev l2 ++ rev l1. MProof. (* FILL IN HERE *) Admitted. Theorem rev_involutive : forall l : natlist, rev (rev l) = l. MProof. (* FILL IN HERE *) Admitted. (** There is a short solution to the next one. If you find yourself getting tangled up, step back and try to look for a simpler way. *) Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist, l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4. MProof. (* FILL IN HERE *) Admitted. (** An exercise about your implementation of [nonzeros]: *) Lemma nonzeros_app : forall l1 l2 : natlist, nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars (beq_natlist) *) (** Fill in the definition of [beq_natlist], which compares lists of numbers for equality. Prove that [beq_natlist l l] yields [true] for every list [l]. *) Fixpoint beq_natlist (l1 l2 : natlist) : bool (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_beq_natlist1 : (beq_natlist nil nil = true). (* FILL IN HERE *) Admitted. Example test_beq_natlist2 : beq_natlist [1;2;3] [1;2;3] = true. (* FILL IN HERE *) Admitted. Example test_beq_natlist3 : beq_natlist [1;2;3] [1;2;4] = false. (* FILL IN HERE *) Admitted. Theorem beq_natlist_refl : forall l:natlist, true = beq_natlist l l. MProof. (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** List Exercises, Part 2 *) (** **** Exercise: 3 stars, advanced (bag_proofs) *) (** Here are a couple of little theorems to prove about your definitions about bags above. *) Theorem count_member_nonzero : forall (s : bag), leb 1 (count 1 (1 :: s)) = true. MProof. (* FILL IN HERE *) Admitted. (** The following lemma about [leb] might help you in the next proof. *) Theorem ble_n_Sn : forall n, leb n (S n) = true. MProof. intros n. elim n &> [i:~~| \n' IHn']. - (* 0 *) simpl. reflexivity. - (* S n' *) simpl. rewrite IHn'. reflexivity. Qed. Theorem remove_decreases_count: forall (s : bag), leb (count 0 (remove_one 0 s)) (count 0 s) = true. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, optional (bag_count_sum) *) (** Write down an interesting theorem [bag_count_sum] about bags involving the functions [count] and [sum], and prove it. (You may find that the difficulty of the proof depends on how you defined [count]!) *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 4 stars, advanced (rev_injective) *) (** Prove that the [rev] function is injective -- that is, forall (l1 l2 : natlist), rev l1 = rev l2 -> l1 = l2. (There is a hard way and an easy way to do this.) *) (* FILL IN HERE *) (** [] *) (* ################################################################# *) (** * Options *) (** Suppose we want to write a function that returns the [n]th element of some list. If we give it type [nat -> natlist -> nat], then we'll have to choose some number to return when the list is too short... *) Fixpoint nth_bad (l:natlist) (n:nat) : nat := match l with | nil => 42 (* arbitrary! *) | a :: l' => match beq_nat n O with | true => a | false => nth_bad l' (pred n) end end. (** This solution is not so good: If [nth_bad] returns [42], we can't tell whether that value actually appears on the input without further processing. A better alternative is to change the return type of [nth_bad] to include an error value as a possible outcome. We call this type [natoption]. *) Inductive natoption : Type := | Some : nat -> natoption | None : natoption. (** We can then change the above definition of [nth_bad] to return [None] when the list is too short and [Some a] when the list has enough members and [a] appears at position [n]. We call this new function [nth_error] to indicate that it may result in an error. *) Fixpoint nth_error (l:natlist) (n:nat) : natoption := match l with | nil => None | a :: l' => match beq_nat n O with | true => Some a | false => nth_error l' (pred n) end end. Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4. MProof. reflexivity. Qed. Example test_nth_error2 : nth_error [4;5;6;7] 3 = Some 7. MProof. reflexivity. Qed. Example test_nth_error3 : nth_error [4;5;6;7] 9 = None. MProof. reflexivity. Qed. (** (In the HTML version, the boilerplate proofs of these examples are elided. Click on a box if you want to see one.) This example is also an opportunity to introduce one more small feature of Coq's programming language: conditional expressions... *) Fixpoint nth_error' (l:natlist) (n:nat) : natoption := match l with | nil => None | a :: l' => if beq_nat n O then Some a else nth_error' l' (pred n) end. (** Coq's conditionals are exactly like those found in any other language, with one small generalization. Since the boolean type is not built in, Coq actually supports conditional expressions over _any_ inductively defined type with exactly two constructors. The guard is considered true if it evaluates to the first constructor in the [Inductive] definition and false if it evaluates to the second. *) (** The function below pulls the [nat] out of a [natoption], returning a supplied default in the [None] case. *) Definition option_elim (d : nat) (o : natoption) : nat := match o with | Some n' => n' | None => d end. (** **** Exercise: 2 stars (hd_error) *) (** Using the same idea, fix the [hd] function from earlier so we don't have to pass a default element for the [nil] case. *) Definition hd_error (l : natlist) : natoption (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_hd_error1 : hd_error [] = None. (* FILL IN HERE *) Admitted. Example test_hd_error2 : hd_error [1] = Some 1. (* FILL IN HERE *) Admitted. Example test_hd_error3 : hd_error [5;6] = Some 5. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star, optional (option_elim_hd) *) (** This exercise relates your new [hd_error] to the old [hd]. *) Theorem option_elim_hd : forall (l:natlist) (default:nat), hd default l = option_elim default (hd_error l). MProof. (* FILL IN HERE *) Admitted. (** [] *) End NatList. (* ################################################################# *) (** * Partial Maps *) (** As a final illustration of how data structures can be defined in Coq, here is a simple _partial map_ data type, analogous to the map or dictionary data structures found in most programming languages. *) (** First, we define a new inductive datatype [id] to serve as the "keys" of our partial maps. *) Inductive id : Type := | Id : nat -> id. (** Internally, an [id] is just a number. Introducing a separate type by wrapping each nat with the tag [Id] makes definitions more readable and gives us the flexibility to change representations later if we wish. *) (** We'll also need an equality test for [id]s: *) Definition beq_id (x1 x2 : id) := match x1, x2 with | Id n1, Id n2 => beq_nat n1 n2 end. (** **** Exercise: 1 star (beq_id_refl) *) Theorem beq_id_refl : forall x, true = beq_id x x. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** Now we define the type of partial maps: *) Module PartialMap. Export NatList. Inductive partial_map : Type := | empty : partial_map | record : id -> nat -> partial_map -> partial_map. (** This declaration can be read: "There are two ways to construct a [partial_map]: either using the constructor [empty] to represent an empty partial map, or by applying the constructor [record] to a key, a value, and an existing [partial_map] to construct a [partial_map] with an additional key-to-value mapping." *) (** The [update] function overrides the entry for a given key in a partial map (or adds a new entry if the given key is not already present). *) Definition update (d : partial_map) (x : id) (value : nat) : partial_map := record x value d. (** Last, the [find] function searches a [partial_map] for a given key. It returns [None] if the key was not found and [Some val] if the key was associated with [val]. If the same key is mapped to multiple values, [find] will return the first one it encounters. *) Fixpoint find (x : id) (d : partial_map) : natoption := match d with | empty => None | record y v d' => if beq_id x y then Some v else find x d' end. (** **** Exercise: 1 star (update_eq) *) Theorem update_eq : forall (d : partial_map) (x : id) (v: nat), find x (update d x v) = Some v. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star (update_neq) *) Theorem update_neq : forall (d : partial_map) (x y : id) (o: nat), beq_id x y = false -> find x (update d y o) = find x d. MProof. (* FILL IN HERE *) Admitted. (** [] *) End PartialMap. (** **** Exercise: 2 stars (baz_num_elts) *) (** Consider the following inductive definition: *) Inductive baz : Type := | Baz1 : baz -> baz | Baz2 : baz -> bool -> baz. (** How _many_ elements does the type [baz] have? (Answer in English or the natural language of your choice.) (* FILL IN HERE *) *) (** [] *) (** $Date: 2017-09-06 10:45:52 -0400 (Wed, 06 Sep 2017) $ *) Mtac2-1.4-coq8.20/tests/sf-5/lf/Logic.v000066400000000000000000001433511472011217100171600ustar00rootroot00000000000000(** * Logic: Logic in Coq *) Set Warnings "-notation-overridden,-parsing". From lf Require Export Tactics. (** In previous chapters, we have seen many examples of factual claims (_propositions_) and ways of presenting evidence of their truth (_proofs_). In particular, we have worked extensively with _equality propositions_ of the form [e1 = e2], with implications ([P -> Q]), and with quantified propositions ([forall x, P]). In this chapter, we will see how Coq can be used to carry out other familiar forms of logical reasoning. Before diving into details, let's talk a bit about the status of mathematical statements in Coq. Recall that Coq is a _typed_ language, which means that every sensible expression in its world has an associated type. Logical claims are no exception: any statement we might try to prove in Coq has a type, namely [Prop], the type of _propositions_. We can see this with the [Check] command: *) Check 3 = 3. (* ===> Prop *) Check forall n m : nat, n + m = m + n. (* ===> Prop *) (** Note that _all_ syntactically well-formed propositions have type [Prop] in Coq, regardless of whether they are true or not. *) (** Simply _being_ a proposition is one thing; being _provable_ is something else! *) Check 2 = 2. (* ===> Prop *) Check forall n : nat, n = 2. (* ===> Prop *) Check 3 = 4. (* ===> Prop *) (** Indeed, propositions don't just have types: they are _first-class objects_ that can be manipulated in the same ways as the other entities in Coq's world. *) (** So far, we've seen one primary place that propositions can appear: in [Theorem] (and [Lemma] and [Example]) declarations. *) Theorem plus_2_2_is_4 : 2 + 2 = 4. MProof. reflexivity. Qed. (** But propositions can be used in many other ways. For example, we can give a name to a proposition using a [Definition], just as we have given names to expressions of other sorts. *) Definition plus_fact : Prop := 2 + 2 = 4. Check plus_fact. (* ===> plus_fact : Prop *) (** We can later use this name in any situation where a proposition is expected -- for example, as the claim in a [Theorem] declaration. *) Theorem plus_fact_is_true : plus_fact. MProof. reflexivity. Qed. (** We can also write _parameterized_ propositions -- that is, functions that take arguments of some type and return a proposition. *) (** For instance, the following function takes a number and returns a proposition asserting that this number is equal to three: *) Definition is_three (n : nat) : Prop := n = 3. Check is_three. (* ===> nat -> Prop *) (** In Coq, functions that return propositions are said to define _properties_ of their arguments. For instance, here's a (polymorphic) property defining the familiar notion of an _injective function_. *) Definition injective {A B} (f : A -> B) := forall x y : A, f x = f y -> x = y. Lemma succ_inj : injective S. MProof. intros n m H. inversion H. reflexivity. Qed. (** The equality operator [=] is also a function that returns a [Prop]. The expression [n = m] is syntactic sugar for [eq n m], defined using Coq's [Notation] mechanism. Because [eq] can be used with elements of any type, it is also polymorphic: *) Check @eq. (* ===> forall A : Type, A -> A -> Prop *) (** (Notice that we wrote [@eq] instead of [eq]: The type argument [A] to [eq] is declared as implicit, so we need to turn off implicit arguments to see the full type of [eq].) *) (* ################################################################# *) (** * Logical Connectives *) (* ================================================================= *) (** ** Conjunction *) (** The _conjunction_ (or _logical and_) of propositions [A] and [B] is written [A /\ B], representing the claim that both [A] and [B] are true. *) Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4. (** To prove a conjunction, use the [split] tactic. It will generate two subgoals, one for each part of the statement: *) MProof. (* WORKED IN CLASS *) T.split. - (* 3 + 4 = 7 *) reflexivity. - (* 2 + 2 = 4 *) reflexivity. Qed. (** For any propositions [A] and [B], if we assume that [A] is true and we assume that [B] is true, we can conclude that [A /\ B] is also true. *) Lemma and_intro : forall A B : Prop, A -> B -> A /\ B. MProof. intros A B HA HB. T.split. - apply HA. - apply HB. Qed. (** Since applying a theorem with hypotheses to some goal has the effect of generating as many subgoals as there are hypotheses for that theorem, we can apply [and_intro] to achieve the same effect as [split]. *) Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4. MProof. apply and_intro. - (* 3 + 4 = 7 *) reflexivity. - (* 2 + 2 = 4 *) reflexivity. Qed. (** **** Exercise: 2 stars (and_exercise) *) Example and_exercise : forall n m : nat, n + m = 0 -> n = 0 /\ m = 0. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** So much for proving conjunctive statements. To go in the other direction -- i.e., to _use_ a conjunctive hypothesis to help prove something else -- we employ the [destruct] tactic. If the proof context contains a hypothesis [H] of the form [A /\ B], writing [destruct H as [HA HB]] will remove [H] from the context and add two new hypotheses: [HA], stating that [A] is true, and [HB], stating that [B] is true. *) Lemma and_example2 : forall n m : nat, n = 0 /\ m = 0 -> n + m = 0. MProof. (* WORKED IN CLASS *) intros n m H. destruct H &> [i: \Hn Hm]. rewrite Hn. rewrite Hm. reflexivity. Qed. (** As usual, we can also destruct [H] right when we introduce it, instead of introducing and then destructing it: *) Lemma and_example2' : forall n m : nat, n = 0 /\ m = 0 -> n + m = 0. MProof. pintros \n m [| \Hn Hm]. rewrite Hn. rewrite Hm. reflexivity. Qed. (** You may wonder why we bothered packing the two hypotheses [n = 0] and [m = 0] into a single conjunction, since we could have also stated the theorem with two separate premises: *) Lemma and_example2'' : forall n m : nat, n = 0 -> m = 0 -> n + m = 0. MProof. intros n m Hn Hm. rewrite Hn. rewrite Hm. reflexivity. Qed. (** For this theorem, both formulations are fine. But it's important to understand how to work with conjunctive hypotheses because conjunctions often arise from intermediate steps in proofs, especially in bigger developments. Here's a simple example: *) Lemma and_example3 : forall n m : nat, n + m = 0 -> n * m = 0. MProof. intros n m H. assert (H' : n = 0 /\ m = 0). { apply and_exercise. apply H. } destruct H' &> [i: \Hn Hm]. rewrite Hn. reflexivity. Qed. (** Another common situation with conjunctions is that we know [A /\ B] but in some context we need just [A] (or just [B]). The following lemmas are useful in such cases: *) Lemma proj1 : forall P Q : Prop, P /\ Q -> P. MProof. pintros \P Q [| \HP HQ]. apply HP. Qed. (** **** Exercise: 1 star, optional (proj2) *) Lemma proj2 : forall P Q : Prop, P /\ Q -> Q. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** Finally, we sometimes need to rearrange the order of conjunctions and/or the grouping of multi-way conjunctions. The following commutativity and associativity theorems are handy in such cases. *) Theorem and_commut : forall P Q : Prop, P /\ Q -> Q /\ P. MProof. (* WORKED IN CLASS *) pintros \P Q [| \HP HQ]. T.split. - (* left *) apply HQ. - (* right *) apply HP. Qed. (** **** Exercise: 2 stars (and_assoc) *) (** (In the following proof of associativity, notice how the _nested_ intro pattern breaks the hypothesis [H : P /\ (Q /\ R)] down into [HP : P], [HQ : Q], and [HR : R]. Finish the proof from there.) *) Theorem and_assoc : forall P Q R : Prop, P /\ (Q /\ R) -> (P /\ Q) /\ R. MProof. pintros \P Q R [| \HP [| \HQ HR]]. (* FILL IN HERE *) Admitted. (** [] *) (** By the way, the infix notation [/\] is actually just syntactic sugar for [and A B]. That is, [and] is a Coq operator that takes two propositions as arguments and yields a proposition. *) Check and. (* ===> and : Prop -> Prop -> Prop *) (* ================================================================= *) (** ** Disjunction *) (** Another important connective is the _disjunction_, or _logical or_ of two propositions: [A \/ B] is true when either [A] or [B] is. (Alternatively, we can write [or A B], where [or : Prop -> Prop -> Prop].) *) (** To use a disjunctive hypothesis in a proof, we proceed by case analysis, which, as for [nat] or other data types, can be done with [destruct] or [intros]. Here is an example: *) Lemma or_example : forall n m : nat, n = 0 \/ m = 0 -> n * m = 0. MProof. (* This pattern implicitly does case analysis on [n = 0 \/ m = 0] *) pintros \n m [| \Hn | \Hm]. - (* Here, [n = 0] *) rewrite Hn. reflexivity. - (* Here, [m = 0] *) rewrite Hm. rewrite <- mult_n_O. reflexivity. Qed. (** Conversely, to show that a disjunction holds, we need to show that one of its sides does. This is done via two tactics, [left] and [right]. As their names imply, the first one requires proving the left side of the disjunction, while the second requires proving its right side. Here is a trivial use... *) Lemma or_intro : forall A B : Prop, A -> A \/ B. MProof. intros A B HA. left. apply HA. Qed. (** ... and a slightly more interesting example requiring both [left] and [right]: *) Lemma zero_or_succ : forall n : nat, n = 0 \/ n = S (pred n). MProof. pintros [| ~~ | \n ]. - left. reflexivity. - right. reflexivity. Qed. (** **** Exercise: 1 star (mult_eq_0) *) Lemma mult_eq_0 : forall n m, n * m = 0 -> n = 0 \/ m = 0. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star (or_commut) *) Theorem or_commut : forall P Q : Prop, P \/ Q -> Q \/ P. MProof. (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** Falsehood and Negation *) (** So far, we have mostly been concerned with proving that certain things are _true_ -- addition is commutative, appending lists is associative, etc. Of course, we may also be interested in _negative_ results, showing that certain propositions are _not_ true. In Coq, such negative statements are expressed with the negation operator [~]. *) (** To see how negation works, recall the discussion of the _principle of explosion_ from the [Tactics] chapter; it asserts that, if we assume a contradiction, then any other proposition can be derived. Following this intuition, we could define [~ P] ("not [P]") as [forall Q, P -> Q]. Coq actually makes a slightly different choice, defining [~ P] as [P -> False], where [False] is a particular contradictory proposition defined in the standard library. *) Module MyNot. Definition not (P:Prop) := P -> False. Notation "~ x" := (not x) : type_scope. Check not. (* ===> Prop -> Prop *) End MyNot. (** Since [False] is a contradictory proposition, the principle of explosion also applies to it. If we get [False] into the proof context, we can use [destruct] (or [inversion]) on it to complete any goal: *) Theorem ex_falso_quodlibet : forall (P:Prop), False -> P. MProof. (* WORKED IN CLASS *) intros P contra. destruct contra. Qed. (** The Latin _ex falso quodlibet_ means, literally, "from falsehood follows whatever you like"; this is another common name for the principle of explosion. *) (** **** Exercise: 2 stars, optional (not_implies_our_not) *) (** Show that Coq's definition of negation implies the intuitive one mentioned above: *) Fact not_implies_our_not : forall (P:Prop), ~ P -> (forall (Q:Prop), P -> Q). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** This is how we use [not] to state that [0] and [1] are different elements of [nat]: *) Theorem zero_not_one : ~(0 = 1). MProof. intros contra. inversion contra. Qed. (** Such inequality statements are frequent enough to warrant a special notation, [x <> y]: *) Check (0 <> 1). (* ===> Prop *) Theorem zero_not_one' : 0 <> 1. MProof. intros H. inversion H. Qed. (** It takes a little practice to get used to working with negation in Coq. Even though you can see perfectly well why a statement involving negation is true, it can be a little tricky at first to get things into the right configuration so that Coq can understand it! Here are proofs of a few familiar facts to get you warmed up. *) Theorem not_False : ~ False. MProof. unfold not. intros H. destruct H. Qed. Theorem contradiction_implies_anything : forall P Q : Prop, (P /\ ~P) -> Q. MProof. (* WORKED IN CLASS *) pintros \P Q [| \HP HNA]. unfold_in not HNA. apply_in HNA HP. destruct HP. Qed. Theorem double_neg : forall P : Prop, P -> ~ ~P. MProof. (* WORKED IN CLASS *) intros P H. unfold not. intros G. apply G. apply H. Qed. (** **** Exercise: 2 stars, advanced, recommended (double_neg_inf) *) (** Write an informal proof of [double_neg]: _Theorem_: [P] implies [~~P], for any proposition [P]. *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 2 stars, recommended (contrapositive) *) Theorem contrapositive : forall (P Q : Prop), (P -> Q) -> (~Q -> ~P). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star (not_both_true_and_false) *) Theorem not_both_true_and_false : forall P : Prop, ~ (P /\ ~P). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star, advanced (informal_not_PNP) *) (** Write an informal proof (in English) of the proposition [forall P : Prop, ~(P /\ ~P)]. *) (* FILL IN HERE *) (** [] *) (** Similarly, since inequality involves a negation, it requires a little practice to be able to work with it fluently. Here is one useful trick. If you are trying to prove a goal that is nonsensical (e.g., the goal state is [false = true]), apply [ex_falso_quodlibet] to change the goal to [False]. This makes it easier to use assumptions of the form [~P] that may be available in the context -- in particular, assumptions of the form [x<>y]. *) Theorem not_true_is_false : forall b : bool, b <> true -> b = false. MProof. Set Printing All. pintros [| ] \H. - (* b = true *) unfold_in not H. apply ex_falso_quodlibet. apply H. reflexivity. - (* b = false *) reflexivity. Qed. (** Since reasoning with [ex_falso_quodlibet] is quite common, Coq provides a built-in tactic, [exfalso], for applying it. *) Theorem not_true_is_false' : forall b : bool, b <> true -> b = false. MProof. pintros [| ] \H. - (* b = false *) unfold_in not H. exfalso. (* <=== *) apply H. reflexivity. - (* b = true *) reflexivity. Qed. (* ================================================================= *) (** ** Truth *) (** Besides [False], Coq's standard library also defines [True], a proposition that is trivially true. To prove it, we use the predefined constant [I : True]: *) Lemma True_is_true : True. MProof. apply I. Qed. (** Unlike [False], which is used extensively, [True] is used quite rarely, since it is trivial (and therefore uninteresting) to prove as a goal, and it carries no useful information as a hypothesis. But it can be quite useful when defining complex [Prop]s using conditionals or as a parameter to higher-order [Prop]s. We will see examples of such uses of [True] later on. *) (* ================================================================= *) (** ** Logical Equivalence *) (** The handy "if and only if" connective, which asserts that two propositions have the same truth value, is just the conjunction of two implications. *) Module MyIff. Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P). Notation "P <-> Q" := (iff P Q) (at level 95, no associativity) : type_scope. End MyIff. Theorem iff_sym : forall P Q : Prop, (P <-> Q) -> (Q <-> P). MProof. (* WORKED IN CLASS *) pintros \P Q [| \HAB HBA]. T.split. - (* -> *) apply HBA. - (* <- *) apply HAB. Qed. Lemma not_true_iff_false : forall b, b <> true <-> b = false. MProof. (* WORKED IN CLASS *) intros b. T.split. - (* -> *) apply not_true_is_false. - (* <- *) intros H. rewrite H. intros H'. inversion H'. Qed. (** **** Exercise: 1 star, optional (iff_properties) *) (** Using the above proof that [<->] is symmetric ([iff_sym]) as a guide, prove that it is also reflexive and transitive. *) Theorem iff_refl : forall P : Prop, P <-> P. MProof. (* FILL IN HERE *) Admitted. Theorem iff_trans : forall P Q R : Prop, (P <-> Q) -> (Q <-> R) -> (P <-> R). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars (or_distributes_over_and) *) Theorem or_distributes_over_and : forall P Q R : Prop, P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** Some of Coq's tactics treat [iff] statements specially, avoiding the need for some low-level proof-state manipulation. In particular, [rewrite] and [reflexivity] can be used with [iff] statements, not just equalities. To enable this behavior, we need to import a special Coq library that allows rewriting with other formulas besides equality: *) Require Import Coq.Setoids.Setoid. (** Here is a simple example demonstrating how these tactics work with [iff]. First, let's prove a couple of basic iff equivalences... *) Lemma mult_0 : forall n m, n * m = 0 <-> n = 0 \/ m = 0. MProof. intros. T.split. (* FIXME in Coq, split does intros *) - apply mult_eq_0. - apply or_example. Qed. Lemma or_assoc : forall P Q R : Prop, P \/ (Q \/ R) <-> (P \/ Q) \/ R. MProof. intros P Q R. T.split. - pintros [| \H | [| \H | \H]]. + left. left. apply H. + left. right. apply H. + right. apply H. - pintros [| [| \H | \H] | \H]. + left. apply H. + right. left. apply H. + right. right. apply H. Qed. (** We can now use these facts with [rewrite] and [reflexivity] to give smooth proofs of statements involving equivalences. Here is a ternary version of the previous [mult_0] result: *) Lemma mult_0_3 : forall n m p, n * m * p = 0 <-> n = 0 \/ m = 0 \/ p = 0. MProof. intros n m p. rewrite mult_0. rewrite mult_0. rewrite or_assoc. Fail T.reflexivity. (* FIXME doesn't understand <-> *) tauto. Qed. (** The [apply] tactic can also be used with [<->]. When given an equivalence as its argument, [apply] tries to guess which side of the equivalence to use. *) Lemma apply_iff_example : forall n m : nat, n * m = 0 -> n = 0 \/ m = 0. MProof. intros n m H. Fail apply mult_0. Fail apply H. (* FIXME apply doesn't understand <-> *) ltac_apply mult_0. ltac_apply H. Qed. (* ================================================================= *) (** ** Existential Quantification *) (** Another important logical connective is _existential quantification_. To say that there is some [x] of type [T] such that some property [P] holds of [x], we write [exists x : T, P]. As with [forall], the type annotation [: T] can be omitted if Coq is able to infer from the context what the type of [x] should be. *) (** To prove a statement of the form [exists x, P], we must show that [P] holds for some specific choice of value for [x], known as the _witness_ of the existential. This is done in two steps: First, we explicitly tell Coq which witness [t] we have in mind by invoking the tactic [exists t]. Then we prove that [P] holds after all occurrences of [x] are replaced by [t]. *) Lemma four_is_even : exists n : nat, 4 = n + n. MProof. mexists 2. T.reflexivity. Qed. (** Conversely, if we have an existential hypothesis [exists x, P] in the context, we can destruct it to obtain a witness [x] and a hypothesis stating that [P] holds of [x]. *) Theorem exists_example_2 : forall n, (exists m, n = 4 + m) -> (exists o, n = 2 + o). MProof. (* WORKED IN CLASS *) pintros \n [| \m Hm]. (* note implicit [destruct] here *) (* FIXME goal has selem_of stuff and requires this: *) simpl. mexists (2 + m). (* FIXME goal is beta-expanded *) apply Hm. Qed. (** **** Exercise: 1 star (dist_not_exists) *) (** Prove that "[P] holds for all [x]" implies "there is no [x] for which [P] does not hold." *) Theorem dist_not_exists : forall (X:Type) (P : X -> Prop), (forall x, P x) -> ~ (exists x, ~ P x). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars (dist_exists_or) *) (** Prove that existential quantification distributes over disjunction. *) Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop), (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x). MProof. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Programming with Propositions *) (** The logical connectives that we have seen provide a rich vocabulary for defining complex propositions from simpler ones. To illustrate, let's look at how to express the claim that an element [x] occurs in a list [l]. Notice that this property has a simple recursive structure: *) (** - If [l] is the empty list, then [x] cannot occur on it, so the property "[x] appears in [l]" is simply false. *) (** - Otherwise, [l] has the form [x' :: l']. In this case, [x] occurs in [l] if either it is equal to [x'] or it occurs in [l']. *) (** We can translate this directly into a straightforward recursive function from taking an element and a list and returning a proposition: *) Fixpoint In {A : Type} (x : A) (l : list A) : Prop := match l with | [] => False | x' :: l' => x' = x \/ In x l' end. (** When [In] is applied to a concrete list, it expands into a concrete sequence of nested disjunctions. *) Example In_example_1 : In 4 [1; 2; 3; 4; 5]. MProof. (* WORKED IN CLASS *) simpl. right. right. right. left. T.reflexivity. Qed. Example In_example_2 : forall n, In n [2; 4] -> exists n', n = 2 * n'. MProof. (* WORKED IN CLASS *) simpl. pintros \n [| \H | [| \H | [| ]]] /=. - mexists 1. rewrite <- H. T.reflexivity. - mexists 2. rewrite <- H. T.reflexivity. Qed. (** (Notice the use of the empty pattern to discharge the last case _en passant_.) *) (** We can also prove more generic, higher-level lemmas about [In]. Note, in the next, how [In] starts out applied to a variable and only gets expanded when we do case analysis on this variable: *) Lemma In_map : forall (A B : Type) (f : A -> B) (l : list A) (x : A), In x l -> In (f x) (map f l). MProof. intros A B f l x. elim l &> [i: ~~ | \x' l' IHl']. - (* l = nil, contradiction *) simpl. pintros [|]. - (* l = x' :: l' *) simpl. pintros [| \H | \H]. + rewrite H. left. T.reflexivity. + right. apply IHl'. apply H. Qed. (** This way of defining propositions recursively, though convenient in some cases, also has some drawbacks. In particular, it is subject to Coq's usual restrictions regarding the definition of recursive functions, e.g., the requirement that they be "obviously terminating." In the next chapter, we will see how to define propositions _inductively_, a different technique with its own set of strengths and limitations. *) (** **** Exercise: 2 stars (In_map_iff) *) Lemma In_map_iff : forall (A B : Type) (f : A -> B) (l : list A) (y : B), In y (map f l) <-> exists x, f x = y /\ In x l. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars (in_app_iff) *) Lemma in_app_iff : forall A l l' (a:A), In a (l++l') <-> In a l \/ In a l'. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, recommended (All) *) (** Recall that functions returning propositions can be seen as _properties_ of their arguments. For instance, if [P] has type [nat -> Prop], then [P n] states that property [P] holds of [n]. Drawing inspiration from [In], write a recursive function [All] stating that some property [P] holds of all elements of a list [l]. To make sure your definition is correct, prove the [All_In] lemma below. (Of course, your definition should _not_ just restate the left-hand side of [All_In].) *) Fixpoint All {T : Type} (P : T -> Prop) (l : list T) : Prop (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Lemma All_In : forall T (P : T -> Prop) (l : list T), (forall x, In x l -> P x) <-> All P l. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars (combine_odd_even) *) (** Complete the definition of the [combine_odd_even] function below. It takes as arguments two properties of numbers, [Podd] and [Peven], and it should return a property [P] such that [P n] is equivalent to [Podd n] when [n] is odd and equivalent to [Peven n] otherwise. *) Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** To test your definition, prove the following facts: *) Theorem combine_odd_even_intro : forall (Podd Peven : nat -> Prop) (n : nat), (oddb n = true -> Podd n) -> (oddb n = false -> Peven n) -> combine_odd_even Podd Peven n. MProof. (* FILL IN HERE *) Admitted. Theorem combine_odd_even_elim_odd : forall (Podd Peven : nat -> Prop) (n : nat), combine_odd_even Podd Peven n -> oddb n = true -> Podd n. MProof. (* FILL IN HERE *) Admitted. Theorem combine_odd_even_elim_even : forall (Podd Peven : nat -> Prop) (n : nat), combine_odd_even Podd Peven n -> oddb n = false -> Peven n. MProof. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Applying Theorems to Arguments *) (** One feature of Coq that distinguishes it from many other proof assistants is that it treats _proofs_ as first-class objects. There is a great deal to be said about this, but it is not necessary to understand it in detail in order to use Coq. This section gives just a taste, while a deeper exploration can be found in the optional chapters [ProofObjects] and [IndPrinciples]. *) (** We have seen that we can use the [Check] command to ask Coq to print the type of an expression. We can also use [Check] to ask what theorem a particular identifier refers to. *) Check plus_comm. (* ===> forall n m : nat, n + m = m + n *) (** Coq prints the _statement_ of the [plus_comm] theorem in the same way that it prints the _type_ of any term that we ask it to [Check]. Why? *) (** The reason is that the identifier [plus_comm] actually refers to a _proof object_ -- a data structure that represents a logical derivation establishing of the truth of the statement [forall n m : nat, n + m = m + n]. The type of this object _is_ the statement of the theorem that it is a proof of. *) (** Intuitively, this makes sense because the statement of a theorem tells us what we can use that theorem for, just as the type of a computational object tells us what we can do with that object -- e.g., if we have a term of type [nat -> nat -> nat], we can give it two [nat]s as arguments and get a [nat] back. Similarly, if we have an object of type [n = m -> n + n = m + m] and we provide it an "argument" of type [n = m], we can derive [n + n = m + m]. *) (** Operationally, this analogy goes even further: by applying a theorem, as if it were a function, to hypotheses with matching types, we can specialize its result without having to resort to intermediate assertions. For example, suppose we wanted to prove the following result: *) Lemma plus_comm3 : forall n m p, n + (m + p) = (p + m) + n. (** It appears at first sight that we ought to be able to prove this by rewriting with [plus_comm] twice to make the two sides match. The problem, however, is that the second [rewrite] will undo the effect of the first. *) MProof. intros n m p. rewrite plus_comm. rewrite plus_comm. (* We are back where we started... *) Abort. (** One simple way of fixing this problem, using only tools that we already know, is to use [assert] to derive a specialized version of [plus_comm] that can be used to rewrite exactly where we want. *) Lemma plus_comm3_take2 : forall n m p, n + (m + p) = (p + m) + n. MProof. intros n m p. rewrite plus_comm. assert (H : m + p = p + m). { rewrite plus_comm. T.reflexivity. } rewrite H. T.reflexivity. Qed. (** A more elegant alternative is to apply [plus_comm] directly to the arguments we want to instantiate it with, in much the same way as we apply a polymorphic function to a type argument. *) Lemma plus_comm3_take3 : forall n m p, n + (m + p) = (p + m) + n. MProof. intros n m p. rewrite plus_comm. rewrite (plus_comm m). T.reflexivity. Qed. (** You can "use theorems as functions" in this way with almost all tactics that take a theorem name as an argument. Note also that theorem application uses the same inference mechanisms as function application; thus, it is possible, for example, to supply wildcards as arguments to be inferred, or to declare some hypotheses to a theorem as implicit by default. These features are illustrated in the proof below. *) Example lemma_application_ex : forall {n : nat} {ns : list nat}, In n (map (fun m => m * 0) ns) -> n = 0. MProof. intros n ns H. elim (proj1 _ _ (In_map_iff _ _ _ _ _) H). intros m. rewrite mult_0_r. pintros [| Prop] is a property describing even numbers. However, there are some cases where translating standard mathematical reasoning into Coq can be either cumbersome or sometimes even impossible, unless we enrich the core logic with additional axioms. We conclude this chapter with a brief discussion of some of the most significant differences between the two worlds. *) (* ================================================================= *) (** ** Functional Extensionality *) (** The equality assertions that we have seen so far mostly have concerned elements of inductive types ([nat], [bool], etc.). But since Coq's equality operator is polymorphic, these are not the only possibilities -- in particular, we can write propositions claiming that two _functions_ are equal to each other: *) Example function_equality_ex1 : plus 3 = plus (pred 4). MProof. T.reflexivity. Qed. (** In common mathematical practice, two functions [f] and [g] are considered equal if they produce the same outputs: (forall x, f x = g x) -> f = g This is known as the principle of _functional extensionality_. Informally speaking, an "extensional property" is one that pertains to an object's observable behavior. Thus, functional extensionality simply means that a function's identity is completely determined by what we can observe from it -- i.e., in Coq terms, the results we obtain after applying it. Functional extensionality is not part of Coq's basic axioms. This means that some "reasonable" propositions are not provable. *) Example function_equality_ex2 : (fun x => plus x 1) = (fun x => plus 1 x). MProof. (* Stuck *) Abort. (** However, we can add functional extensionality to Coq's core logic using the [Axiom] command. *) Axiom functional_extensionality : forall {X Y: Type} {f g : X -> Y}, (forall (x:X), f x = g x) -> f = g. (** Using [Axiom] has the same effect as stating a theorem and skipping its proof using [Admitted], but it alerts the reader that this isn't just something we're going to come back and fill in later! *) (** We can now invoke functional extensionality in proofs: *) Example function_equality_ex2 : (fun x => plus x 1) = (fun x => plus 1 x). MProof. apply functional_extensionality. intros x. apply plus_comm. Qed. (** Naturally, we must be careful when adding new axioms into Coq's logic, as they may render it _inconsistent_ -- that is, they may make it possible to prove every proposition, including [False]! Unfortunately, there is no simple way of telling whether an axiom is safe to add: hard work is generally required to establish the consistency of any particular combination of axioms. However, it is known that adding functional extensionality, in particular, _is_ consistent. *) (** To check whether a particular proof relies on any additional axioms, use the [Print Assumptions] command. *) Print Assumptions function_equality_ex2. (* ===> Axioms: functional_extensionality : forall (X Y : Type) (f g : X -> Y), (forall x : X, f x = g x) -> f = g *) (** **** Exercise: 4 stars (tr_rev) *) (** One problem with the definition of the list-reversing function [rev] that we have is that it performs a call to [app] on each step; running [app] takes time asymptotically linear in the size of the list, which means that [rev] has quadratic running time. We can improve this with the following definition: *) Fixpoint rev_append {X} (l1 l2 : list X) : list X := match l1 with | [] => l2 | x :: l1' => rev_append l1' (x :: l2) end. Definition tr_rev {X} (l : list X) : list X := rev_append l []. (** This version is said to be _tail-recursive_, because the recursive call to the function is the last operation that needs to be performed (i.e., we don't have to execute [++] after the recursive call); a decent compiler will generate very efficient code in this case. Prove that the two definitions are indeed equivalent. *) Lemma tr_rev_correct : forall X, @tr_rev X = @rev X. (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** Propositions and Booleans *) (** We've seen two different ways of encoding logical facts in Coq: with _booleans_ (of type [bool]), and with _propositions_ (of type [Prop]). For instance, to claim that a number [n] is even, we can say either - (1) that [evenb n] returns [true], or - (2) that there exists some [k] such that [n = double k]. Indeed, these two notions of evenness are equivalent, as can easily be shown with a couple of auxiliary lemmas. We often say that the boolean [evenb n] _reflects_ the proposition [exists k, n = double k]. *) Theorem evenb_double : forall k, evenb (double k) = true. MProof. intros k. elim k &> [i: ~~| \k' IHk']. - T.reflexivity. - simpl. apply IHk'. Qed. (** **** Exercise: 3 stars (evenb_double_conv) *) Theorem evenb_double_conv : forall n, exists k, n = if evenb n then double k else S (double k). MProof. (* Hint: Use the [evenb_S] lemma from [Induction.v]. *) (* FILL IN HERE *) Admitted. (** [] *) Theorem even_bool_prop : forall n, evenb n = true <-> exists k, n = double k. MProof. intros n. T.split. - intros H. elim (evenb_double_conv n) &> [i: \k Hk]. rewrite Hk. rewrite H. mexists k. T.reflexivity. - pintros [| \k Hk]. rewrite Hk. apply evenb_double. Qed. (** Similarly, to state that two numbers [n] and [m] are equal, we can say either (1) that [beq_nat n m] returns [true] or (2) that [n = m]. These two notions are equivalent. *) Theorem beq_nat_true_iff : forall n1 n2 : nat, beq_nat n1 n2 = true <-> n1 = n2. MProof. intros n1 n2. T.split. - apply beq_nat_true. - intros H. rewrite H. rewrite <- beq_nat_refl. T.reflexivity. Qed. (** However, even when the boolean and propositional formulations of a claim are equivalent from a purely logical perspective, they need not be equivalent _operationally_. Equality provides an extreme example: knowing that [beq_nat n m = true] is generally of little direct help in the middle of a proof involving [n] and [m]; however, if we convert the statement to the equivalent form [n = m], we can rewrite with it. The case of even numbers is also interesting. Recall that, when proving the backwards direction of [even_bool_prop] (i.e., [evenb_double], going from the propositional to the boolean claim), we used a simple induction on [k]. On the other hand, the converse (the [evenb_double_conv] exercise) required a clever generalization, since we can't directly prove [(exists k, n = double k) -> evenb n = true]. For these examples, the propositional claims are more useful than their boolean counterparts, but this is not always the case. For instance, we cannot test whether a general proposition is true or not in a function definition; as a consequence, the following code fragment is rejected: *) Fail Definition is_even_prime n := if n = 2 then true else false. (** Coq complains that [n = 2] has type [Prop], while it expects an elements of [bool] (or some other inductive type with two elements). The reason for this error message has to do with the _computational_ nature of Coq's core language, which is designed so that every function that it can express is computable and total. One reason for this is to allow the extraction of executable programs from Coq developments. As a consequence, [Prop] in Coq does _not_ have a universal case analysis operation telling whether any given proposition is true or false, since such an operation would allow us to write non-computable functions. Although general non-computable properties cannot be phrased as boolean computations, it is worth noting that even many _computable_ properties are easier to express using [Prop] than [bool], since recursive function definitions are subject to significant restrictions in Coq. For instance, the next chapter shows how to define the property that a regular expression matches a given string using [Prop]. Doing the same with [bool] would amount to writing a regular expression matcher, which would be more complicated, harder to understand, and harder to reason about. Conversely, an important side benefit of stating facts using booleans is enabling some proof automation through computation with Coq terms, a technique known as _proof by reflection_. Consider the following statement: *) Example even_1000 : exists k, 1000 = double k. (** The most direct proof of this fact is to give the value of [k] explicitly. *) MProof. mexists 500. T.reflexivity. Qed. (** On the other hand, the proof of the corresponding boolean statement is even simpler: *) Example even_1000' : evenb 1000 = true. MProof. T.reflexivity. Qed. (** What is interesting is that, since the two notions are equivalent, we can use the boolean formulation to prove the other one without mentioning the value 500 explicitly: *) Example even_1000'' : exists k, 1000 = double k. MProof. ltac_apply even_bool_prop. T.reflexivity. Qed. (* FIXME apply doesn't understand <-> *) (** Although we haven't gained much in terms of proof size in this case, larger proofs can often be made considerably simpler by the use of reflection. As an extreme example, the Coq proof of the famous _4-color theorem_ uses reflection to reduce the analysis of hundreds of different cases to a boolean computation. We won't cover reflection in great detail, but it serves as a good example showing the complementary strengths of booleans and general propositions. *) (** **** Exercise: 2 stars (logical_connectives) *) (** The following lemmas relate the propositional connectives studied in this chapter to the corresponding boolean operations. *) Lemma andb_true_iff : forall b1 b2:bool, b1 && b2 = true <-> b1 = true /\ b2 = true. MProof. (* FILL IN HERE *) Admitted. Lemma orb_true_iff : forall b1 b2, b1 || b2 = true <-> b1 = true \/ b2 = true. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star (beq_nat_false_iff) *) (** The following theorem is an alternate "negative" formulation of [beq_nat_true_iff] that is more convenient in certain situations (we'll see examples in later chapters). *) Theorem beq_nat_false_iff : forall x y : nat, beq_nat x y = false <-> x <> y. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars (beq_list) *) (** Given a boolean operator [beq] for testing equality of elements of some type [A], we can define a function [beq_list beq] for testing equality of lists with elements in [A]. Complete the definition of the [beq_list] function below. To make sure that your definition is correct, prove the lemma [beq_list_true_iff]. *) Fixpoint beq_list {A : Type} (beq : A -> A -> bool) (l1 l2 : list A) : bool (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Lemma beq_list_true_iff : forall A (beq : A -> A -> bool), (forall a1 a2, beq a1 a2 = true <-> a1 = a2) -> forall l1 l2, beq_list beq l1 l2 = true <-> l1 = l2. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, recommended (All_forallb) *) (** Recall the function [forallb], from the exercise [forall_exists_challenge] in chapter [Tactics]: *) Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool := match l with | [] => true | x :: l' => andb (test x) (forallb test l') end. (** Prove the theorem below, which relates [forallb] to the [All] property of the above exercise. *) Theorem forallb_true_iff : forall X test (l : list X), forallb test l = true <-> All (fun x => test x = true) l. MProof. (* FILL IN HERE *) Admitted. (** Are there any important properties of the function [forallb] which are not captured by this specification? *) (* FILL IN HERE *) (** [] *) (* ================================================================= *) (** ** Classical vs. Constructive Logic *) (** We have seen that it is not possible to test whether or not a proposition [P] holds while defining a Coq function. You may be surprised to learn that a similar restriction applies to _proofs_! In other words, the following intuitive reasoning principle is not derivable in Coq: *) Definition excluded_middle := forall P : Prop, P \/ ~ P. (** To understand operationally why this is the case, recall that, to prove a statement of the form [P \/ Q], we use the [left] and [right] tactics, which effectively require knowing which side of the disjunction holds. But the universally quantified [P] in [excluded_middle] is an _arbitrary_ proposition, which we know nothing about. We don't have enough information to choose which of [left] or [right] to apply, just as Coq doesn't have enough information to mechanically decide whether [P] holds or not inside a function. *) (** However, if we happen to know that [P] is reflected in some boolean term [b], then knowing whether it holds or not is trivial: we just have to check the value of [b]. *) Theorem restricted_excluded_middle : forall P b, (P <-> b = true) -> P \/ ~ P. MProof. pintros \P [|] \H. - left. rewrite H. T.reflexivity. - right. rewrite H. intros contra. inversion contra. Qed. (** In particular, the excluded middle is valid for equations [n = m], between natural numbers [n] and [m]. *) Theorem restricted_excluded_middle_eq : forall (n m : nat), n = m \/ n <> m. MProof. intros n m. apply (restricted_excluded_middle (n = m) (beq_nat n m)). Fail T.symmetry. (* FIXME symmetry doesn't understand <-> *) Fail apply beq_nat_true_iff. Fail Qed. Abort. (** It may seem strange that the general excluded middle is not available by default in Coq; after all, any given claim must be either true or false. Nonetheless, there is an advantage in not assuming the excluded middle: statements in Coq can make stronger claims than the analogous statements in standard mathematics. Notably, if there is a Coq proof of [exists x, P x], it is possible to explicitly exhibit a value of [x] for which we can prove [P x] -- in other words, every proof of existence is necessarily _constructive_. *) (** Logics like Coq's, which do not assume the excluded middle, are referred to as _constructive logics_. More conventional logical systems such as ZFC, in which the excluded middle does hold for arbitrary propositions, are referred to as _classical_. *) (** The following example illustrates why assuming the excluded middle may lead to non-constructive proofs: _Claim_: There exist irrational numbers [a] and [b] such that [a ^ b] is rational. _Proof_: It is not difficult to show that [sqrt 2] is irrational. If [sqrt 2 ^ sqrt 2] is rational, it suffices to take [a = b = sqrt 2] and we are done. Otherwise, [sqrt 2 ^ sqrt 2] is irrational. In this case, we can take [a = sqrt 2 ^ sqrt 2] and [b = sqrt 2], since [a ^ b = sqrt 2 ^ (sqrt 2 * sqrt 2) = sqrt 2 ^ 2 = 2]. [] Do you see what happened here? We used the excluded middle to consider separately the cases where [sqrt 2 ^ sqrt 2] is rational and where it is not, without knowing which one actually holds! Because of that, we wind up knowing that such [a] and [b] exist but we cannot determine what their actual values are (at least, using this line of argument). As useful as constructive logic is, it does have its limitations: There are many statements that can easily be proven in classical logic but that have much more complicated constructive proofs, and there are some that are known to have no constructive proof at all! Fortunately, like functional extensionality, the excluded middle is known to be compatible with Coq's logic, allowing us to add it safely as an axiom. However, we will not need to do so in this book: the results that we cover can be developed entirely within constructive logic at negligible extra cost. It takes some practice to understand which proof techniques must be avoided in constructive reasoning, but arguments by contradiction, in particular, are infamous for leading to non-constructive proofs. Here's a typical example: suppose that we want to show that there exists [x] with some property [P], i.e., such that [P x]. We start by assuming that our conclusion is false; that is, [~ exists x, P x]. From this premise, it is not hard to derive [forall x, ~ P x]. If we manage to show that this intermediate fact results in a contradiction, we arrive at an existence proof without ever exhibiting a value of [x] for which [P x] holds! The technical flaw here, from a constructive standpoint, is that we claimed to prove [exists x, P x] using a proof of [~ ~ (exists x, P x)]. Allowing ourselves to remove double negations from arbitrary statements is equivalent to assuming the excluded middle, as shown in one of the exercises below. Thus, this line of reasoning cannot be encoded in Coq without assuming additional axioms. *) (** **** Exercise: 3 stars (excluded_middle_irrefutable) *) (** The consistency of Coq with the general excluded middle axiom requires complicated reasoning that cannot be carried out within Coq itself. However, the following theorem implies that it is always safe to assume a decidability axiom (i.e., an instance of excluded middle) for any _particular_ Prop [P]. Why? Because we cannot prove the negation of such an axiom; if we could, we would have both [~ (P \/ ~P)] and [~ ~ (P \/ ~P)], a contradiction. *) Theorem excluded_middle_irrefutable: forall (P:Prop), ~ ~ (P \/ ~ P). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, advanced (not_exists_dist) *) (** It is a theorem of classical logic that the following two assertions are equivalent: ~ (exists x, ~ P x) forall x, P x The [dist_not_exists] theorem above proves one side of this equivalence. Interestingly, the other direction cannot be proved in constructive logic. Your job is to show that it is implied by the excluded middle. *) Theorem not_exists_dist : excluded_middle -> forall (X:Type) (P : X -> Prop), ~ (exists x, ~ P x) -> (forall x, P x). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 5 stars, optional (classical_axioms) *) (** For those who like a challenge, here is an exercise taken from the Coq'Art book by Bertot and Casteran (p. 123). Each of the following four statements, together with [excluded_middle], can be considered as characterizing classical logic. We can't prove any of them in Coq, but we can consistently add any one of them as an axiom if we wish to work in classical logic. Prove that all five propositions (these four plus [excluded_middle]) are equivalent. *) Definition peirce := forall P Q: Prop, ((P->Q)->P)->P. Definition double_negation_elimination := forall P:Prop, ~ ~P -> P. Definition de_morgan_not_and_not := forall P Q:Prop, ~(~P /\ ~Q) -> P\/Q. Definition implies_to_or := forall P Q:Prop, (P->Q) -> (~P\/Q). (* FILL IN HERE *) (** [] *) (** $Date: 2017-09-06 10:45:52 -0400 (Wed, 06 Sep 2017) $ *) Mtac2-1.4-coq8.20/tests/sf-5/lf/Poly.v000066400000000000000000001136601472011217100170460ustar00rootroot00000000000000(** * Poly: Polymorphism and Higher-Order Functions *) (* Final reminder: Please do not put solutions to the exercises in publicly accessible places. Thank you!! *) (* Suppress some annoying warnings from Coq: *) Set Warnings "-notation-overridden,-parsing". From lf Require Export Lists. (*** Polymorphism *) (** In this chapter we continue our development of basic concepts of functional programming. The critical new ideas are _polymorphism_ (abstracting functions over the types of the data they manipulate) and _higher-order functions_ (treating functions as data). We begin with polymorphism. *) (* ================================================================= *) (** ** Polymorphic Lists *) (** For the last couple of chapters, we've been working just with lists of numbers. Obviously, interesting programs also need to be able to manipulate lists with elements from other types -- lists of strings, lists of booleans, lists of lists, etc. We _could_ just define a new inductive datatype for each of these, for example... *) Inductive boollist : Type := | bool_nil : boollist | bool_cons : bool -> boollist -> boollist. (** ... but this would quickly become tedious, partly because we have to make up different constructor names for each datatype, but mostly because we would also need to define new versions of all our list manipulating functions ([length], [rev], etc.) for each new datatype definition. *) (** To avoid all this repetition, Coq supports _polymorphic_ inductive type definitions. For example, here is a _polymorphic list_ datatype. *) Inductive list (X:Type) : Type := | nil : list X | cons : X -> list X -> list X. (** This is exactly like the definition of [natlist] from the previous chapter, except that the [nat] argument to the [cons] constructor has been replaced by an arbitrary type [X], a binding for [X] has been added to the header, and the occurrences of [natlist] in the types of the constructors have been replaced by [list X]. (We can re-use the constructor names [nil] and [cons] because the earlier definition of [natlist] was inside of a [Module] definition that is now out of scope.) What sort of thing is [list] itself? One good way to think about it is that [list] is a _function_ from [Type]s to [Inductive] definitions; or, to put it another way, [list] is a function from [Type]s to [Type]s. For any particular type [X], the type [list X] is an [Inductive]ly defined set of lists whose elements are of type [X]. *) Check list. (* ===> list : Type -> Type *) (** The parameter [X] in the definition of [list] becomes a parameter to the constructors [nil] and [cons] -- that is, [nil] and [cons] are now polymorphic constructors, that need to be supplied with the type of the list they are building. As an example, [nil nat] constructs the empty list of type [nat]. *) Check (nil nat). (* ===> nil nat : list nat *) (** Similarly, [cons nat] adds an element of type [nat] to a list of type [list nat]. Here is an example of forming a list containing just the natural number 3.*) Check (cons nat 3 (nil nat)). (* ===> cons nat 3 (nil nat) : list nat *) (** What might the type of [nil] be? We can read off the type [list X] from the definition, but this omits the binding for [X] which is the parameter to [list]. [Type -> list X] does not explain the meaning of [X]. [(X : Type) -> list X] comes closer. Coq's notation for this situation is [forall X : Type, list X]. *) Check nil. (* ===> nil : forall X : Type, list X *) (** Similarly, the type of [cons] as read off from the definition is [X -> list X -> list X], but using this convention to explain the meaning of [X] results in the type [forall X, X -> list X -> list X]. *) Check cons. (* ===> cons : forall X : Type, X -> list X -> list X *) (** (Side note on notation: In .v files, the "forall" quantifier is spelled out in letters. In the generated HTML files and in the way various IDEs show .v files (with certain settings of their display controls), [forall] is usually typeset as the usual mathematical "upside down A," but you'll still see the spelled-out "forall" in a few places. This is just a quirk of typesetting: there is no difference in meaning.) *) (** Having to supply a type argument for each use of a list constructor may seem an awkward burden, but we will soon see ways of reducing that burden. *) Check (cons nat 2 (cons nat 1 (nil nat))). (** (We've written [nil] and [cons] explicitly here because we haven't yet defined the [ [] ] and [::] notations for the new version of lists. We'll do that in a bit.) *) (** We can now go back and make polymorphic versions of all the list-processing functions that we wrote before. Here is [repeat], for example: *) Fixpoint repeat (X : Type) (x : X) (count : nat) : list X := match count with | 0 => nil X | S count' => cons X x (repeat X x count') end. (** As with [nil] and [cons], we can use [repeat] by applying it first to a type and then to an element of this type (and a number): *) Example test_repeat1 : repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)). MProof. reflexivity. Qed. (** To use [repeat] to build other kinds of lists, we simply instantiate it with an appropriate type parameter: *) Example test_repeat2 : repeat bool false 1 = cons bool false (nil bool). MProof. reflexivity. Qed. Module MumbleGrumble. (** **** Exercise: 2 stars (mumble_grumble) *) (** Consider the following two inductively defined types. *) Inductive mumble : Type := | a : mumble | b : mumble -> nat -> mumble | c : mumble. Inductive grumble (X:Type) : Type := | d : mumble -> grumble X | e : X -> grumble X. (** Which of the following are well-typed elements of [grumble X] for some type [X]? - [d (b a 5)] - [d mumble (b a 5)] - [d bool (b a 5)] - [e bool true] - [e mumble (b c 0)] - [e bool (b c 0)] - [c] (* FILL IN HERE *) *) (** [] *) End MumbleGrumble. (* ----------------------------------------------------------------- *) (** *** Type Annotation Inference *) (** Let's write the definition of [repeat] again, but this time we won't specify the types of any of the arguments. Will Coq still accept it? *) Fixpoint repeat' X x count : list X := match count with | 0 => nil X | S count' => cons X x (repeat' X x count') end. (** Indeed it will. Let's see what type Coq has assigned to [repeat']: *) Check repeat'. (* ===> forall X : Type, X -> nat -> list X *) Check repeat. (* ===> forall X : Type, X -> nat -> list X *) (** It has exactly the same type type as [repeat]. Coq was able to use _type inference_ to deduce what the types of [X], [x], and [count] must be, based on how they are used. For example, since [X] is used as an argument to [cons], it must be a [Type], since [cons] expects a [Type] as its first argument; matching [count] with [0] and [S] means it must be a [nat]; and so on. This powerful facility means we don't always have to write explicit type annotations everywhere, although explicit type annotations are still quite useful as documentation and sanity checks, so we will continue to use them most of the time. You should try to find a balance in your own code between too many type annotations (which can clutter and distract) and too few (which forces readers to perform type inference in their heads in order to understand your code). *) (* ----------------------------------------------------------------- *) (** *** Type Argument Synthesis *) (** To use a polymorphic function, we need to pass it one or more types in addition to its other arguments. For example, the recursive call in the body of the [repeat] function above must pass along the type [X]. But since the second argument to [repeat] is an element of [X], it seems entirely obvious that the first argument can only be [X] -- why should we have to write it explicitly? Fortunately, Coq permits us to avoid this kind of redundancy. In place of any type argument we can write the "implicit argument" [_], which can be read as "Please try to figure out for yourself what belongs here." More precisely, when Coq encounters a [_], it will attempt to _unify_ all locally available information -- the type of the function being applied, the types of the other arguments, and the type expected by the context in which the application appears -- to determine what concrete type should replace the [_]. This may sound similar to type annotation inference -- indeed, the two procedures rely on the same underlying mechanisms. Instead of simply omitting the types of some arguments to a function, like repeat' X x count : list X := we can also replace the types with [_] repeat' (X : _) (x : _) (count : _) : list X := to tell Coq to attempt to infer the missing information. Using implicit arguments, the [repeat] function can be written like this: *) Fixpoint repeat'' X x count : list X := match count with | 0 => nil _ | S count' => cons _ x (repeat'' _ x count') end. (** In this instance, we don't save much by writing [_] instead of [X]. But in many cases the difference in both keystrokes and readability is nontrivial. For example, suppose we want to write down a list containing the numbers [1], [2], and [3]. Instead of writing this... *) Definition list123 := cons nat 1 (cons nat 2 (cons nat 3 (nil nat))). (** ...we can use argument synthesis to write this: *) Definition list123' := cons _ 1 (cons _ 2 (cons _ 3 (nil _))). (* ----------------------------------------------------------------- *) (** *** Implicit Arguments *) (** We can go further and even avoid writing [_]'s in most cases by telling Coq _always_ to infer the type argument(s) of a given function. The [Arguments] directive specifies the name of the function (or constructor) and then lists its argument names, with curly braces around any arguments to be treated as implicit. (If some arguments of a definition don't have a name, as is often the case for constructors, they can be marked with a wildcard pattern [_].) *) Arguments nil {X}. Arguments cons {X} _ _. Arguments repeat {X} x count. (** Now, we don't have to supply type arguments at all: *) Definition list123'' := cons 1 (cons 2 (cons 3 nil)). (** Alternatively, we can declare an argument to be implicit when defining the function itself, by surrounding it in curly braces instead of parens. For example: *) Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X := match count with | 0 => nil | S count' => cons x (repeat''' x count') end. (** (Note that we didn't even have to provide a type argument to the recursive call to [repeat''']; indeed, it would be invalid to provide one!) We will use the latter style whenever possible, but we will continue to use explicit [Argument] declarations for [Inductive] constructors. The reason for this is that marking the parameter of an inductive type as implicit causes it to become implicit for the type itself, not just for its constructors. For instance, consider the following alternative definition of the [list] type: *) Inductive list' {X:Type} : Type := | nil' : list' | cons' : X -> list' -> list'. (** Because [X] is declared as implicit for the _entire_ inductive definition including [list'] itself, we now have to write just [list'] whether we are talking about lists of numbers or booleans or anything else, rather than [list' nat] or [list' bool] or whatever; this is a step too far. *) (** Let's finish by re-implementing a few other standard list functions on our new polymorphic lists... *) Fixpoint app {X : Type} (l1 l2 : list X) : (list X) := match l1 with | nil => l2 | cons h t => cons h (app t l2) end. Fixpoint rev {X:Type} (l:list X) : list X := match l with | nil => nil | cons h t => app (rev t) (cons h nil) end. Fixpoint length {X : Type} (l : list X) : nat := match l with | nil => 0 | cons _ l' => S (length l') end. Example test_rev1 : rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)). MProof. reflexivity. Qed. Example test_rev2: rev (cons true nil) = cons true nil. MProof. reflexivity. Qed. Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3. MProof. reflexivity. Qed. (* ----------------------------------------------------------------- *) (** *** Supplying Type Arguments Explicitly *) (** One small problem with declaring arguments [Implicit] is that, occasionally, Coq does not have enough local information to determine a type argument; in such cases, we need to tell Coq that we want to give the argument explicitly just this time. For example, suppose we write this: *) Fail Definition mynil := nil. (** (The [Fail] qualifier that appears before [Definition] can be used with _any_ command, and is used to ensure that that command indeed fails when executed. If the command does fail, Coq prints the corresponding error message, but continues processing the rest of the file.) Here, Coq gives us an error because it doesn't know what type argument to supply to [nil]. We can help it by providing an explicit type declaration (so that Coq has more information available when it gets to the "application" of [nil]): *) Definition mynil : list nat := nil. (** Alternatively, we can force the implicit arguments to be explicit by prefixing the function name with [@]. *) Check @nil. Definition mynil' := @nil nat. (** Using argument synthesis and implicit arguments, we can define convenient notation for lists, as before. Since we have made the constructor type arguments implicit, Coq will know to automatically infer these when we use the notations. *) Notation "x :: y" := (cons x y) (at level 60, right associativity). Notation "[ ]" := nil. Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..). Notation "x ++ y" := (app x y) (at level 60, right associativity). (** Now lists can be written just the way we'd hope: *) Definition list123''' := [1; 2; 3]. (* ----------------------------------------------------------------- *) (** *** Exercises *) (** **** Exercise: 2 stars, optional (poly_exercises) *) (** Here are a few simple exercises, just like ones in the [Lists] chapter, for practice with polymorphism. Complete the proofs below. *) Theorem app_nil_r : forall (X:Type), forall l:list X, l ++ [] = l. MProof. (* FILL IN HERE *) Admitted. Theorem app_assoc : forall A (l m n:list A), l ++ m ++ n = (l ++ m) ++ n. MProof. (* FILL IN HERE *) Admitted. Lemma app_length : forall (X:Type) (l1 l2 : list X), length (l1 ++ l2) = length l1 + length l2. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, optional (more_poly_exercises) *) (** Here are some slightly more interesting ones... *) Theorem rev_app_distr: forall X (l1 l2 : list X), rev (l1 ++ l2) = rev l2 ++ rev l1. MProof. (* FILL IN HERE *) Admitted. Theorem rev_involutive : forall X : Type, forall l : list X, rev (rev l) = l. MProof. (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** Polymorphic Pairs *) (** Following the same pattern, the type definition we gave in the last chapter for pairs of numbers can be generalized to _polymorphic pairs_, often called _products_: *) Inductive prod (X Y : Type) : Type := | pair : X -> Y -> prod X Y. Arguments pair {X} {Y} _ _. (** As with lists, we make the type arguments implicit and define the familiar concrete notation. *) Notation "( x , y )" := (pair x y). (** We can also use the [Notation] mechanism to define the standard notation for product _types_: *) Notation "X * Y" := (prod X Y) : type_scope. (** (The annotation [: type_scope] tells Coq that this abbreviation should only be used when parsing types. This avoids a clash with the multiplication symbol.) *) (** It is easy at first to get [(x,y)] and [X*Y] confused. Remember that [(x,y)] is a _value_ built from two other values, while [X*Y] is a _type_ built from two other types. If [x] has type [X] and [y] has type [Y], then [(x,y)] has type [X*Y]. *) (** The first and second projection functions now look pretty much as they would in any functional programming language. *) Definition fst {X Y : Type} (p : X * Y) : X := match p with | (x, y) => x end. Definition snd {X Y : Type} (p : X * Y) : Y := match p with | (x, y) => y end. (** The following function takes two lists and combines them into a list of pairs. In other functional languages, it is often called [zip]; we call it [combine] for consistency with Coq's standard library. *) Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y) : list (X*Y) := match lx, ly with | [], _ => [] | _, [] => [] | x :: tx, y :: ty => (x, y) :: (combine tx ty) end. (** **** Exercise: 1 star, optional (combine_checks) *) (** Try answering the following questions on paper and checking your answers in coq: - What is the type of [combine] (i.e., what does [Check @combine] print?) - What does Compute (combine [1;2] [false;false;true;true]). print? *) (** [] *) (** **** Exercise: 2 stars, recommended (split) *) (** The function [split] is the right inverse of [combine]: it takes a list of pairs and returns a pair of lists. In many functional languages, it is called [unzip]. Fill in the definition of [split] below. Make sure it passes the given unit test. *) Fixpoint split {X Y : Type} (l : list (X*Y)) : (list X) * (list Y) (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_split: split [(1,false);(2,false)] = ([1;2],[false;false]). MProof. (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** Polymorphic Options *) (** One last polymorphic type for now: _polymorphic options_, which generalize [natoption] from the previous chapter: *) Inductive option (X:Type) : Type := | Some : X -> option X | None : option X. Arguments Some {X} _. Arguments None {X}. (** We can now rewrite the [nth_error] function so that it works with any type of lists. *) Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X := match l with | [] => None | a :: l' => if beq_nat n O then Some a else nth_error l' (pred n) end. Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4. MProof. reflexivity. Qed. Example test_nth_error2 : nth_error [ [1];[2]] 1 = Some [2]. MProof. reflexivity. Qed. Example test_nth_error3 : nth_error [true] 2 = None. MProof. reflexivity. Qed. (** **** Exercise: 1 star, optional (hd_error_poly) *) (** Complete the definition of a polymorphic version of the [hd_error] function from the last chapter. Be sure that it passes the unit tests below. *) Definition hd_error {X : Type} (l : list X) : option X (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** Once again, to force the implicit arguments to be explicit, we can use [@] before the name of the function. *) Check @hd_error. Example test_hd_error1 : hd_error [1;2] = Some 1. (* FILL IN HERE *) Admitted. Example test_hd_error2 : hd_error [ [1];[2]] = Some [1]. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Functions as Data *) (** Like many other modern programming languages -- including all functional languages (ML, Haskell, Scheme, Scala, Clojure, etc.) -- Coq treats functions as first-class citizens, allowing them to be passed as arguments to other functions, returned as results, stored in data structures, etc.*) (* ================================================================= *) (** ** Higher-Order Functions *) (** Functions that manipulate other functions are often called _higher-order_ functions. Here's a simple one: *) Definition doit3times {X:Type} (f:X->X) (n:X) : X := f (f (f n)). (** The argument [f] here is itself a function (from [X] to [X]); the body of [doit3times] applies [f] three times to some value [n]. *) Check @doit3times. (* ===> doit3times : forall X : Type, (X -> X) -> X -> X *) Example test_doit3times: doit3times minustwo 9 = 3. MProof. reflexivity. Qed. Example test_doit3times': doit3times negb true = false. MProof. reflexivity. Qed. (* ================================================================= *) (** ** Filter *) (** Here is a more useful higher-order function, taking a list of [X]s and a _predicate_ on [X] (a function from [X] to [bool]) and "filtering" the list, returning a new list containing just those elements for which the predicate returns [true]. *) Fixpoint filter {X:Type} (test: X->bool) (l:list X) : (list X) := match l with | [] => [] | h :: t => if test h then h :: (filter test t) else filter test t end. (** For example, if we apply [filter] to the predicate [evenb] and a list of numbers [l], it returns a list containing just the even members of [l]. *) Example test_filter1: filter evenb [1;2;3;4] = [2;4]. MProof. reflexivity. Qed. Definition length_is_1 {X : Type} (l : list X) : bool := beq_nat (length l) 1. Example test_filter2: filter length_is_1 [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ] = [ [3]; [4]; [8] ]. MProof. reflexivity. Qed. (** We can use [filter] to give a concise version of the [countoddmembers] function from the [Lists] chapter. *) Definition countoddmembers' (l:list nat) : nat := length (filter oddb l). Example test_countoddmembers'1: countoddmembers' [1;0;3;1;4;5] = 4. MProof. reflexivity. Qed. Example test_countoddmembers'2: countoddmembers' [0;2;4] = 0. MProof. reflexivity. Qed. Example test_countoddmembers'3: countoddmembers' nil = 0. MProof. reflexivity. Qed. (* ================================================================= *) (** ** Anonymous Functions *) (** It is arguably a little sad, in the example just above, to be forced to define the function [length_is_1] and give it a name just to be able to pass it as an argument to [filter], since we will probably never use it again. Moreover, this is not an isolated example: when using higher-order functions, we often want to pass as arguments "one-off" functions that we will never use again; having to give each of these functions a name would be tedious. Fortunately, there is a better way. We can construct a function "on the fly" without declaring it at the top level or giving it a name. *) Example test_anon_fun': doit3times (fun n => n * n) 2 = 256. MProof. reflexivity. Qed. (** The expression [(fun n => n * n)] can be read as "the function that, given a number [n], yields [n * n]." *) (** Here is the [filter] example, rewritten to use an anonymous function. *) Example test_filter2': filter (fun l => beq_nat (length l) 1) [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ] = [ [3]; [4]; [8] ]. MProof. reflexivity. Qed. (** **** Exercise: 2 stars (filter_even_gt7) *) (** Use [filter] (instead of [Fixpoint]) to write a Coq function [filter_even_gt7] that takes a list of natural numbers as input and returns a list of just those that are even and greater than 7. *) Definition filter_even_gt7 (l : list nat) : list nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_filter_even_gt7_1 : filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8]. (* FILL IN HERE *) Admitted. Example test_filter_even_gt7_2 : filter_even_gt7 [5;2;6;19;129] = []. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars (partition) *) (** Use [filter] to write a Coq function [partition]: partition : forall X : Type, (X -> bool) -> list X -> list X * list X Given a set [X], a test function of type [X -> bool] and a [list X], [partition] should return a pair of lists. The first member of the pair is the sublist of the original list containing the elements that satisfy the test, and the second is the sublist containing those that fail the test. The order of elements in the two sublists should be the same as their order in the original list. *) Definition partition {X : Type} (test : X -> bool) (l : list X) : list X * list X (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]). (* FILL IN HERE *) Admitted. Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]). (* FILL IN HERE *) Admitted. (** [] *) (* ================================================================= *) (** ** Map *) (** Another handy higher-order function is called [map]. *) Fixpoint map {X Y:Type} (f:X->Y) (l:list X) : (list Y) := match l with | [] => [] | h :: t => (f h) :: (map f t) end. (** It takes a function [f] and a list [ l = [n1, n2, n3, ...] ] and returns the list [ [f n1, f n2, f n3,...] ], where [f] has been applied to each element of [l] in turn. For example: *) Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5]. MProof. reflexivity. Qed. (** The element types of the input and output lists need not be the same, since [map] takes _two_ type arguments, [X] and [Y]; it can thus be applied to a list of numbers and a function from numbers to booleans to yield a list of booleans: *) Example test_map2: map oddb [2;1;2;5] = [false;true;false;true]. MProof. reflexivity. Qed. (** It can even be applied to a list of numbers and a function from numbers to _lists_ of booleans to yield a _list of lists_ of booleans: *) Example test_map3: map (fun n => [evenb n;oddb n]) [2;1;2;5] = [ [true;false];[false;true];[true;false];[false;true]]. MProof. reflexivity. Qed. (* ----------------------------------------------------------------- *) (** *** Exercises *) (** **** Exercise: 3 stars (map_rev) *) (** Show that [map] and [rev] commute. You may need to define an auxiliary lemma. *) Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X), map f (rev l) = rev (map f l). MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, recommended (flat_map) *) (** The function [map] maps a [list X] to a [list Y] using a function of type [X -> Y]. We can define a similar function, [flat_map], which maps a [list X] to a [list Y] using a function [f] of type [X -> list Y]. Your definition should work by 'flattening' the results of [f], like so: flat_map (fun n => [n;n+1;n+2]) [1;5;10] = [1; 2; 3; 5; 6; 7; 10; 11; 12]. *) Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X) : (list Y) (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example test_flat_map1: flat_map (fun n => [n;n;n]) [1;5;4] = [1; 1; 1; 5; 5; 5; 4; 4; 4]. (* FILL IN HERE *) Admitted. (** [] *) (** Lists are not the only inductive type that we can write a [map] function for. Here is the definition of [map] for the [option] type: *) Definition option_map {X Y : Type} (f : X -> Y) (xo : option X) : option Y := match xo with | None => None | Some x => Some (f x) end. (** **** Exercise: 2 stars, optional (implicit_args) *) (** The definitions and uses of [filter] and [map] use implicit arguments in many places. Replace the curly braces around the implicit arguments with parentheses, and then fill in explicit type parameters where necessary and use Coq to check that you've done so correctly. (This exercise is not to be turned in; it is probably easiest to do it on a _copy_ of this file that you can throw away afterwards.) *) (** [] *) (* ================================================================= *) (** ** Fold *) (** An even more powerful higher-order function is called [fold]. This function is the inspiration for the "[reduce]" operation that lies at the heart of Google's map/reduce distributed programming framework. *) Fixpoint fold {X Y:Type} (f: X->Y->Y) (l:list X) (b:Y) : Y := match l with | nil => b | h :: t => f h (fold f t b) end. (** Intuitively, the behavior of the [fold] operation is to insert a given binary operator [f] between every pair of elements in a given list. For example, [ fold plus [1;2;3;4] ] intuitively means [1+2+3+4]. To make this precise, we also need a "starting element" that serves as the initial second input to [f]. So, for example, fold plus [1;2;3;4] 0 yields 1 + (2 + (3 + (4 + 0))). Some more examples: *) Check (fold andb). (* ===> fold andb : list bool -> bool -> bool *) Example fold_example1 : fold mult [1;2;3;4] 1 = 24. MProof. reflexivity. Qed. Example fold_example2 : fold andb [true;true;false;true] true = false. MProof. reflexivity. Qed. Example fold_example3 : fold app [ [1];[];[2;3];[4]] [] = [1;2;3;4]. MProof. reflexivity. Qed. (** **** Exercise: 1 star, advanced (fold_types_different) *) (** Observe that the type of [fold] is parameterized by _two_ type variables, [X] and [Y], and the parameter [f] is a binary operator that takes an [X] and a [Y] and returns a [Y]. Can you think of a situation where it would be useful for [X] and [Y] to be different? *) (* FILL IN HERE *) (** [] *) (* ================================================================= *) (** ** Functions That Construct Functions *) (** Most of the higher-order functions we have talked about so far take functions as arguments. Let's look at some examples that involve _returning_ functions as the results of other functions. To begin, here is a function that takes a value [x] (drawn from some type [X]) and returns a function from [nat] to [X] that yields [x] whenever it is called, ignoring its [nat] argument. *) Definition constfun {X: Type} (x: X) : nat->X := fun (k:nat) => x. Definition ftrue := constfun true. Example constfun_example1 : ftrue 0 = true. MProof. reflexivity. Qed. Example constfun_example2 : (constfun 5) 99 = 5. MProof. reflexivity. Qed. (** In fact, the multiple-argument functions we have already seen are also examples of passing functions as data. To see why, recall the type of [plus]. *) Check plus. (* ==> nat -> nat -> nat *) (** Each [->] in this expression is actually a _binary_ operator on types. This operator is _right-associative_, so the type of [plus] is really a shorthand for [nat -> (nat -> nat)] -- i.e., it can be read as saying that "[plus] is a one-argument function that takes a [nat] and returns a one-argument function that takes another [nat] and returns a [nat]." In the examples above, we have always applied [plus] to both of its arguments at once, but if we like we can supply just the first. This is called _partial application_. *) Definition plus3 := plus 3. Check plus3. Example test_plus3 : plus3 4 = 7. MProof. reflexivity. Qed. Example test_plus3' : doit3times plus3 0 = 9. MProof. reflexivity. Qed. Example test_plus3'' : doit3times (plus 3) 0 = 9. MProof. reflexivity. Qed. (* ################################################################# *) (** * Additional Exercises *) Module Exercises. (** **** Exercise: 2 stars (fold_length) *) (** Many common functions on lists can be implemented in terms of [fold]. For example, here is an alternative definition of [length]: *) Definition fold_length {X : Type} (l : list X) : nat := fold (fun _ n => S n) l 0. Example test_fold_length1 : fold_length [4;7;0] = 3. MProof. reflexivity. Qed. (** Prove the correctness of [fold_length]. *) Theorem fold_length_correct : forall X (l : list X), fold_length l = length l. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars (fold_map) *) (** We can also define [map] in terms of [fold]. Finish [fold_map] below. *) Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** Write down a theorem [fold_map_correct] in Coq stating that [fold_map] is correct, and prove it. *) (* FILL IN HERE *) (** [] *) (** **** Exercise: 2 stars, advanced (currying) *) (** In Coq, a function [f : A -> B -> C] really has the type [A -> (B -> C)]. That is, if you give [f] a value of type [A], it will give you function [f' : B -> C]. If you then give [f'] a value of type [B], it will return a value of type [C]. This allows for partial application, as in [plus3]. Processing a list of arguments with functions that return functions is called _currying_, in honor of the logician Haskell Curry. Conversely, we can reinterpret the type [A -> B -> C] as [(A * B) -> C]. This is called _uncurrying_. With an uncurried binary function, both arguments must be given at once as a pair; there is no partial application. *) (** We can define currying as follows: *) Definition prod_curry {X Y Z : Type} (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y). (** As an exercise, define its inverse, [prod_uncurry]. Then prove the theorems below to show that the two are inverses. *) Definition prod_uncurry {X Y Z : Type} (f : X -> Y -> Z) (p : X * Y) : Z (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. (** As a (trivial) example of the usefulness of currying, we can use it to shorten one of the examples that we saw above: *) Example test_map1': map (plus 3) [2;0;2] = [5;3;5]. MProof. reflexivity. Qed. (** Thought exercise: before running the following commands, can you calculate the types of [prod_curry] and [prod_uncurry]? *) Check @prod_curry. Check @prod_uncurry. Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y, prod_curry (prod_uncurry f) x y = f x y. MProof. (* FILL IN HERE *) Admitted. Theorem curry_uncurry : forall (X Y Z : Type) (f : (X * Y) -> Z) (p : X * Y), prod_uncurry (prod_curry f) p = f p. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, advanced (nth_error_informal) *) (** Recall the definition of the [nth_error] function: Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X := match l with | [] => None | a :: l' => if beq_nat n O then Some a else nth_error l' (pred n) end. Write an informal proof of the following theorem: forall X n l, length l = n -> @nth_error X l n = None (* FILL IN HERE *) *) (** [] *) (** **** Exercise: 4 stars, advanced (church_numerals) *) (** This exercise explores an alternative way of defining natural numbers, using the so-called _Church numerals_, named after mathematician Alonzo Church. We can represent a natural number [n] as a function that takes a function [f] as a parameter and returns [f] iterated [n] times. *) Module Church. Definition nat := forall X : Type, (X -> X) -> X -> X. (** Let's see how to write some numbers with this notation. Iterating a function once should be the same as just applying it. Thus: *) Definition one : nat := fun (X : Type) (f : X -> X) (x : X) => f x. (** Similarly, [two] should apply [f] twice to its argument: *) Definition two : nat := fun (X : Type) (f : X -> X) (x : X) => f (f x). (** Defining [zero] is somewhat trickier: how can we "apply a function zero times"? The answer is actually simple: just return the argument untouched. *) Definition zero : nat := fun (X : Type) (f : X -> X) (x : X) => x. (** More generally, a number [n] can be written as [fun X f x => f (f ... (f x) ...)], with [n] occurrences of [f]. Notice in particular how the [doit3times] function we've defined previously is actually just the Church representation of [3]. *) Definition three : nat := @doit3times. (** Complete the definitions of the following functions. Make sure that the corresponding unit tests pass by proving them with [reflexivity]. *) (** Successor of a natural number: *) Definition succ (n : nat) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example succ_1 : succ zero = one. MProof. (* FILL IN HERE *) Admitted. Example succ_2 : succ one = two. MProof. (* FILL IN HERE *) Admitted. Example succ_3 : succ two = three. MProof. (* FILL IN HERE *) Admitted. (** Addition of two natural numbers: *) Definition plus (n m : nat) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example plus_1 : plus zero one = one. MProof. (* FILL IN HERE *) Admitted. Example plus_2 : plus two three = plus three two. MProof. (* FILL IN HERE *) Admitted. Example plus_3 : plus (plus two two) three = plus one (plus three three). MProof. (* FILL IN HERE *) Admitted. (** Multiplication: *) Definition mult (n m : nat) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example mult_1 : mult one one = one. MProof. (* FILL IN HERE *) Admitted. Example mult_2 : mult zero (plus three three) = zero. MProof. (* FILL IN HERE *) Admitted. Example mult_3 : mult two three = plus three three. MProof. (* FILL IN HERE *) Admitted. (** Exponentiation: *) (** (_Hint_: Polymorphism plays a crucial role here. However, choosing the right type to iterate over can be tricky. If you hit a "Universe inconsistency" error, try iterating over a different type: [nat] itself is usually problematic.) *) Definition exp (n m : nat) : nat (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Example exp_1 : exp two two = plus two two. MProof. (* FILL IN HERE *) Admitted. Example exp_2 : exp three two = plus (mult two (mult two two)) one. MProof. (* FILL IN HERE *) Admitted. Example exp_3 : exp three zero = one. MProof. (* FILL IN HERE *) Admitted. End Church. (** [] *) End Exercises. (** $Date: 2017-09-06 11:44:36 -0400 (Wed, 06 Sep 2017) $ *) Mtac2-1.4-coq8.20/tests/sf-5/lf/Preface.v000066400000000000000000000467201472011217100174720ustar00rootroot00000000000000(** * Preface *) (* ################################################################# *) (** * Welcome *) (** This is the entry point in a series of electronic textbooks on various aspects of _Software Foundations_ -- the mathematical underpinnings of reliable software. Topics in the series include basic concepts of logic, computer-assisted theorem proving, the Coq proof assistant, functional programming, operational semantics, logics for reasoning about programs, and static type systems. The exposition is intended for a broad range of readers, from advanced undergraduates to PhD students and researchers. No specific background in logic or programming languages is assumed, though a degree of mathematical maturity will be helpful. The principal novelty of the series is that it is one hundred percent formalized and machine-checked: each text is literally a script for Coq. The books are intended to be read alongside (or inside) an interactive session with Coq. All the details in the text are fully formalized in Coq, and most of the exercises are designed to be worked using Coq. The files in each book are organized into a sequence of core chapters, covering about one semester's worth of material and organized into a coherent linear narrative, plus a number of "offshoot" chapters covering additional topics. All the core chapters are suitable for both upper-level undergraduate and graduate students. This book, _Logical Foundations_, lays groundwork for the others, introducing the reader to the basic ideas of functional programming, constructive logic, and the Coq proof assistant. *) (* ################################################################# *) (** * Overview *) (** Building reliable software is really hard. The scale and complexity of modern systems, the number of people involved, and the range of demands placed on them make it extremely difficult to build software that is even more-or-less correct, much less 100%% correct. At the same time, the increasing degree to which information processing is woven into every aspect of society greatly amplifies the cost of bugs and insecurities. Computer scientists and software engineers have responded to these challenges by developing a whole host of techniques for improving software reliability, ranging from recommendations about managing software projects teams (e.g., extreme programming) to design philosophies for libraries (e.g., model-view-controller, publish-subscribe, etc.) and programming languages (e.g., object-oriented programming, aspect-oriented programming, functional programming, ...) to mathematical techniques for specifying and reasoning about properties of software and tools for helping validate these properties. The _Software Foundations_ series is focused on this last set of techniques. The text is constructed around three conceptual threads: (1) basic tools from _logic_ for making and justifying precise claims about programs; (2) the use of _proof assistants_ to construct rigorous logical arguments; (3) _functional programming_, both as a method of programming that simplifies reasoning about programs and as a bridge between programming and logic. Some suggestions for further reading can be found in the [Postscript] chapter. Bibliographic information for all cited works can be found in the file [Bib]. *) (* ================================================================= *) (** ** Logic *) (** Logic is the field of study whose subject matter is _proofs_ -- unassailable arguments for the truth of particular propositions. Volumes have been written about the central role of logic in computer science. Manna and Waldinger called it "the calculus of computer science," while Halpern et al.'s paper _On the Unusual Effectiveness of Logic in Computer Science_ catalogs scores of ways in which logic offers critical tools and insights. Indeed, they observe that, "As a matter of fact, logic has turned out to be significiantly more effective in computer science than it has been in mathematics. This is quite remarkable, especially since much of the impetus for the development of logic during the past one hundred years came from mathematics." In particular, the fundamental tools of _inductive proof_ are ubiquitous in all of computer science. You have surely seen them before, perhaps in a course on discrete math or analysis of algorithms, but in this course we will examine them more deeply than you have probably done so far. *) (* ================================================================= *) (** ** Proof Assistants *) (** The flow of ideas between logic and computer science has not been unidirectional: CS has also made important contributions to logic. One of these has been the development of software tools for helping construct proofs of logical propositions. These tools fall into two broad categories: - _Automated theorem provers_ provide "push-button" operation: you give them a proposition and they return either _true_ or _false_ (or, sometimes, _don't know: ran out of time_). Although their capabilities are still limited to specific domains, they have matured tremendously in recent years and are used now in a multitude of settings. Examples of such tools include SAT solvers, SMT solvers, and model checkers. - _Proof assistants_ are hybrid tools that automate the more routine aspects of building proofs while depending on human guidance for more difficult aspects. Widely used proof assistants include Isabelle, Agda, Twelf, ACL2, PVS, and Coq, among many others. This course is based around Coq, a proof assistant that has been under development since 1983 and that in recent years has attracted a large community of users in both research and industry. Coq provides a rich environment for interactive development of machine-checked formal reasoning. The kernel of the Coq system is a simple proof-checker, which guarantees that only correct deduction steps are ever performed. On top of this kernel, the Coq environment provides high-level facilities for proof development, including a large library of common definitions and lemmas, powerful tactics for constructing complex proofs semi-automatically, and a special-purpose programming language for defining new proof-automation tactics for specific situations. Coq has been a critical enabler for a huge variety of work across computer science and mathematics: - As a _platform for modeling programming languages_, it has become a standard tool for researchers who need to describe and reason about complex language definitions. It has been used, for example, to check the security of the JavaCard platform, obtaining the highest level of common criteria certification, and for formal specifications of the x86 and LLVM instruction sets and programming languages such as C. - As an _environment for developing formally certified software and hardware_, Coq has been used, for example, to build CompCert, a fully-verified optimizing compiler for C, and CertiKos, a fully verified hypervisor, for proving the correctness of subtle algorithms involving floating point numbers, and as the basis for CertiCrypt, an environment for reasoning about the security of cryptographic algorithms. It is also being used to build verified implementations of the open-source RISC-V processor. - As a _realistic environment for functional programming with dependent types_, it has inspired numerous innovations. For example, the Ynot system embeds "relational Hoare reasoning" (an extension of the _Hoare Logic_ we will see later in this course) in Coq. - As a _proof assistant for higher-order logic_, it has been used to validate a number of important results in mathematics. For example, its ability to include complex computations inside proofs made it possible to develop the first formally verified proof of the 4-color theorem. This proof had previously been controversial among mathematicians because part of it included checking a large number of configurations using a program. In the Coq formalization, everything is checked, including the correctness of the computational part. More recently, an even more massive effort led to a Coq formalization of the Feit-Thompson Theorem -- the first major step in the classification of finite simple groups. By the way, in case you're wondering about the name, here's what the official Coq web site at INRIA (the French national research lab where Coq has mostly been developed) says about it: "Some French computer scientists have a tradition of naming their software as animal species: Caml, Elan, Foc or Phox are examples of this tacit convention. In French, 'coq' means rooster, and it sounds like the initials of the Calculus of Constructions (CoC) on which it is based." The rooster is also the national symbol of France, and C-o-q are the first three letters of the name of Thierry Coquand, one of Coq's early developers. *) (* ================================================================= *) (** ** Functional Programming *) (** The term _functional programming_ refers both to a collection of programming idioms that can be used in almost any programming language and to a family of programming languages designed to emphasize these idioms, including Haskell, OCaml, Standard ML, F##, Scala, Scheme, Racket, Common Lisp, Clojure, Erlang, and Coq. Functional programming has been developed over many decades -- indeed, its roots go back to Church's lambda-calculus, which was invented in the 1930s, well before the first computers (at least the first electronic ones)! But since the early '90s it has enjoyed a surge of interest among industrial engineers and language designers, playing a key role in high-value systems at companies like Jane St. Capital, Microsoft, Facebook, and Ericsson. The most basic tenet of functional programming is that, as much as possible, computation should be _pure_, in the sense that the only effect of execution should be to produce a result: it should be free from _side effects_ such as I/O, assignments to mutable variables, redirecting pointers, etc. For example, whereas an _imperative_ sorting function might take a list of numbers and rearrange its pointers to put the list in order, a pure sorting function would take the original list and return a _new_ list containing the same numbers in sorted order. A significant benefit of this style of programming is that it makes programs easier to understand and reason about. If every operation on a data structure yields a new data structure, leaving the old one intact, then there is no need to worry about how that structure is being shared and whether a change by one part of the program might break an invariant that another part of the program relies on. These considerations are particularly critical in concurrent systems, where every piece of mutable state that is shared between threads is a potential source of pernicious bugs. Indeed, a large part of the recent interest in functional programming in industry is due to its simpler behavior in the presence of concurrency. Another reason for the current excitement about functional programming is related to the first: functional programs are often much easier to parallelize than their imperative counterparts. If running a computation has no effect other than producing a result, then it does not matter _where_ it is run. Similarly, if a data structure is never modified destructively, then it can be copied freely, across cores or across the network. Indeed, the "Map-Reduce" idiom, which lies at the heart of massively distributed query processors like Hadoop and is used by Google to index the entire web is a classic example of functional programming. For purposes of this course, functional programming has yet another significant attraction: it serves as a bridge between logic and computer science. Indeed, Coq itself can be viewed as a combination of a small but extremely expressive functional programming language plus a set of tools for stating and proving logical assertions. Moreover, when we come to look more closely, we find that these two sides of Coq are actually aspects of the very same underlying machinery -- i.e., _proofs are programs_. *) (* ================================================================= *) (** ** Further Reading *) (** This text is intended to be self contained, but readers looking for a deeper treatment of particular topics will find some suggestions for further reading in the [Postscript] chapter. *) (* ################################################################# *) (** * Practicalities *) (* ================================================================= *) (** ** Chapter Dependencies *) (** A diagram of the dependencies between chapters and some suggested paths through the material can be found in the file [deps.html]. *) (* ================================================================= *) (** ** System Requirements *) (** Coq runs on Windows, Linux, and macOS. You will need: - A current installation of Coq, available from the Coq home page. These files have been tested with Coq 8.7.1. - An IDE for interacting with Coq. Currently, there are two choices: - Proof General is an Emacs-based IDE. It tends to be preferred by users who are already comfortable with Emacs. It requires a separate installation (google "Proof General"). Adventurous users of Coq within Emacs may also want to check out extensions such as [company-coq] and [control-lock]. - CoqIDE is a simpler stand-alone IDE. It is distributed with Coq, so it should be available once you have Coq installed. It can also be compiled from scratch, but on some platforms this may involve installing additional packages for GUI libraries and such. *) (* ================================================================= *) (** ** Exercises *) (** Each chapter includes numerous exercises. Each is marked with a "star rating," which can be interpreted as follows: - One star: easy exercises that underscore points in the text and that, for most readers, should take only a minute or two. Get in the habit of working these as you reach them. - Two stars: straightforward exercises (five or ten minutes). - Three stars: exercises requiring a bit of thought (ten minutes to half an hour). - Four and five stars: more difficult exercises (half an hour and up). Also, some exercises are marked "advanced," and some are marked "optional." Doing just the non-optional, non-advanced exercises should provide good coverage of the core material. Optional exercises provide a bit of extra practice with key concepts and introduce secondary themes that may be of interest to some readers. Advanced exercises are for readers who want an extra challenge and a deeper cut at the material. _Please do not post solutions to the exercises in a public place_. Software Foundations is widely used both for self-study and for university courses. Having solutions easily available makes it much less useful for courses, which typically have graded homework assignments. We especially request that readers not post solutions to the exercises anyplace where they can be found by search engines. *) (* ================================================================= *) (** ** Downloading the Coq Files *) (** A tar file containing the full sources for the "release version" of this book (as a collection of Coq scripts and HTML files) is available at http://www.cis.upenn.edu/~bcpierce/sf. (If you are using the book as part of a class, your professor may give you access to a locally modified version of the files, which you should use instead of the release version.) *) (* ================================================================= *) (** ** Lecture Videos *) (** Lectures for an intensive summer course based on _Logical Foundations_ (part of the DeepSpec summer school in 2017) can be found at https://deepspec.org/event/dsss17/coq_intensive.html. The video quality is poor at the beginning but gets better in the later lectures. *) (* ################################################################# *) (** * Note for Instructors *) (** If you plan to use these materials in your own course, you will undoubtedly find things you'd like to change, improve, or add. Your contributions are welcome! In order to keep the legalities simple and to have a single point of responsibility in case the need should ever arise to adjust the license terms, sublicense, etc., we ask all contributors (i.e., everyone with access to the developers' repository) to assign copyright in their contributions to the appropriate "author of record," as follows: - I hereby assign copyright in my past and future contributions to the Software Foundations project to the Author of Record of each volume or component, to be licensed under the same terms as the rest of Software Foundations. I understand that, at present, the Authors of Record are as follows: For Volumes 1 and 2, known until 2016 as "Software Foundations" and from 2016 as (respectively) "Logical Foundations" and "Programming Foundations," the Author of Record is Benjamin Pierce. For Volume 3, "Verified Functional Algorithms", the Author of Record is Andrew W. Appel. For components outside of designated Volumes (e.g., typesetting and grading tools and other software infrastructure), the Author of Record is Benjamin Pierce. To get started, please send an email to Benjamin Pierce, describing yourself and how you plan to use the materials and including (1) the above copyright transfer text and (2) the result of doing "htpasswd -s -n NAME" where NAME is your preferred user name. We'll set you up with access to the subversion repository and developers' mailing lists. In the repository you'll find a file [INSTRUCTORS] with further instructions. *) (* ################################################################# *) (** * Translations *) (** Thanks to the efforts of a team of volunteer translators, _Software Foundations_ can be enjoyed in Japanese at http://proofcafe.org/sf. A Chinese translation is also underway; you can preview it at https://coq-zh.github.io/SF-zh/. *) (* ################################################################# *) (** * Thanks *) (** Development of the _Software Foundations_ series has been supported, in part, by the National Science Foundation under the NSF Expeditions grant 1521523, _The Science of Deep Specification_. *) Mtac2-1.4-coq8.20/tests/sf-5/lf/Tactics.v000066400000000000000000001134521472011217100175140ustar00rootroot00000000000000(** * Tactics: More Basic Tactics *) (** This chapter introduces several additional proof strategies and tactics that allow us to begin proving more interesting properties of functional programs. We will see: - how to use auxiliary lemmas in both "forward-style" and "backward-style" proofs; - how to reason about data constructors (in particular, how to use the fact that they are injective and disjoint); - how to strengthen an induction hypothesis (and when such strengthening is required); and - more details on how to reason by case analysis. *) Set Warnings "-notation-overridden,-parsing". From lf Require Export Poly. (* ################################################################# *) (** * The [apply] Tactic *) (** We often encounter situations where the goal to be proved is _exactly_ the same as some hypothesis in the context or some previously proved lemma. *) Theorem silly1 : forall (n m o p : nat), n = m -> [n;o] = [n;p] -> [n;o] = [m;p]. MProof. intros n m o p eq1 eq2. rewrite <- eq1. (** Here, we could finish with "[rewrite -> eq2. reflexivity.]" as we have done several times before. We can achieve the same effect in a single step by using the [apply] tactic instead: *) apply eq2. Qed. (** The [apply] tactic also works with _conditional_ hypotheses and lemmas: if the statement being applied is an implication, then the premises of this implication will be added to the list of subgoals needing to be proved. *) Theorem silly2 : forall (n m o p : nat), n = m -> (forall (q r : nat), q = r -> [q;o] = [r;p]) -> [n;o] = [m;p]. MProof. intros n m o p eq1 eq2. apply eq2. apply eq1. Qed. (** You may find it instructive to experiment with this proof and see if there is a way to complete it using just [rewrite] instead of [apply]. *) (** Typically, when we use [apply H], the statement [H] will begin with a [forall] that binds some _universal variables_. When Coq matches the current goal against the conclusion of [H], it will try to find appropriate values for these variables. For example, when we do [apply eq2] in the following proof, the universal variable [q] in [eq2] gets instantiated with [n] and [r] gets instantiated with [m]. *) Theorem silly2a : forall (n m : nat), (n,n) = (m,m) -> (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) -> [n] = [m]. MProof. intros n m eq1 eq2. apply eq2. apply eq1. Qed. (** **** Exercise: 2 stars, optional (silly_ex) *) (** Complete the following proof without using [simpl]. *) Theorem silly_ex : (forall n, evenb n = true -> oddb (S n) = true) -> evenb 3 = true -> oddb 4 = true. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** To use the [apply] tactic, the (conclusion of the) fact being applied must match the goal exactly -- for example, [apply] will not work if the left and right sides of the equality are swapped. *) Theorem silly3_firsttry : forall (n : nat), true = beq_nat n 5 -> beq_nat (S (S n)) 7 = true. MProof. intros n H. simpl. (** Here we cannot use [apply] directly, but we can use the [symmetry] tactic, which switches the left and right sides of an equality in the goal. *) symmetry. simpl. (* (This [simpl] is optional, since [apply] will perform simplification first, if needed.) *) apply H. Qed. (** **** Exercise: 3 stars (apply_exercise1) *) (** (_Hint_: You can use [apply] with previously defined lemmas, not just hypotheses in the context. Remember that [Search] is your friend.) *) Theorem rev_exercise1 : forall (l l' : list nat), l = rev l' -> l' = rev l. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 1 star, optional (apply_rewrite) *) (** Briefly explain the difference between the tactics [apply] and [rewrite]. What are the situations where both can usefully be applied? (* FILL IN HERE *) *) (** [] *) (* ################################################################# *) (** * The [apply ... with ...] Tactic *) (** The following silly example uses two rewrites in a row to get from [[a,b]] to [[e,f]]. *) Example trans_eq_example : forall (a b c d e f : nat), [a;b] = [c;d] -> [c;d] = [e;f] -> [a;b] = [e;f]. MProof. intros a b c d e f eq1 eq2. rewrite -> eq1. rewrite -> eq2. reflexivity. Qed. (** Since this is a common pattern, we might like to pull it out as a lemma recording, once and for all, the fact that equality is transitive. *) Theorem trans_eq : forall (X:Type) (n m o : X), n = m -> m = o -> n = o. MProof. intros X n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2. reflexivity. Qed. (** Now, we should be able to use [trans_eq] to prove the above example. However, to do this we need a slight refinement of the [apply] tactic. *) Example trans_eq_example' : forall (a b c d e f : nat), [a;b] = [c;d] -> [c;d] = [e;f] -> [a;b] = [e;f]. MProof. intros a b c d e f eq1 eq2. (** If we simply tell Coq [apply trans_eq] at this point, it can tell (by matching the goal against the conclusion of the lemma) that it should instantiate [X] with [[nat]], [n] with [[a,b]], and [o] with [[e,f]]. However, the matching process doesn't determine an instantiation for [m]: we have to supply one explicitly by adding [with (m:=[c,d])] to the invocation of [apply]. *) apply trans_eq mwith ("m":=[c;d]). apply eq1. apply eq2. Qed. (** Actually, we usually don't have to include the name [m] in the [with] clause; Coq is often smart enough to figure out which instantiation we're giving. We could instead write: [apply trans_eq with [c;d]]. *) (** **** Exercise: 3 stars, optional (apply_with_exercise) *) Example trans_eq_exercise : forall (n m o p : nat), m = (minustwo o) -> (n + p) = m -> (n + p) = (minustwo o). MProof. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * The [inversion] Tactic *) (** Recall the definition of natural numbers: Inductive nat : Type := | O : nat | S : nat -> nat. It is obvious from this definition that every number has one of two forms: either it is the constructor [O] or it is built by applying the constructor [S] to another number. But there is more here than meets the eye: implicit in the definition (and in our informal understanding of how datatype declarations work in other programming languages) are two more facts: - The constructor [S] is _injective_. That is, if [S n = S m], it must be the case that [n = m]. - The constructors [O] and [S] are _disjoint_. That is, [O] is not equal to [S n] for any [n]. Similar principles apply to all inductively defined types: all constructors are injective, and the values built from distinct constructors are never equal. For lists, the [cons] constructor is injective and [nil] is different from every non-empty list. For booleans, [true] and [false] are different. (Since neither [true] nor [false] take any arguments, their injectivity is not interesting.) And so on. *) (** Coq provides a tactic called [inversion] that allows us to exploit these principles in proofs. To see how to use it, let's show explicitly that the [S] constructor is injective: *) Theorem S_injective : forall (n m : nat), S n = S m -> n = m. MProof. intros n m H. (** By writing [inversion H] at this point, we are asking Coq to generate all equations that it can infer from [H] as additional hypotheses, replacing variables in the goal as it goes. In the present example, this amounts to adding a new hypothesis [H1 : n = m] and replacing [n] by [m] in the goal. *) inversion H. reflexivity. Qed. (** Here's a more interesting example that shows how multiple equations can be derived at once. *) Theorem inversion_ex1 : forall (n m o : nat), [n; m] = [o; o] -> [n] = [m]. MProof. intros n m o H. inversion H. reflexivity. Qed. (** We can name the equations that [inversion] generates with an [as ...] clause: *) Theorem inversion_ex2 : forall (n m : nat), [n] = [m] -> n = m. MProof. intros n m H. inversion H. reflexivity. Qed. (** **** Exercise: 1 star (inversion_ex3) *) Example inversion_ex3 : forall (X : Type) (x y z : X) (l j : list X), x :: y :: l = z :: j -> y :: l = x :: j -> x = y. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** When used on a hypothesis involving an equality between _different_ constructors (e.g., [S n = O]), [inversion] solves the goal immediately. Consider the following proof: *) Theorem beq_nat_0_l : forall n, beq_nat 0 n = true -> n = 0. MProof. intros n. (** We can proceed by case analysis on [n]. The first case is trivial. *) destruct n &> [i:~~ | \n']. - (* n = 0 *) intros H. reflexivity. (** However, the second one doesn't look so simple: assuming [beq_nat 0 (S n') = true], we must show [S n' = 0], but the latter clearly contradictory! The way forward lies in the assumption. After simplifying the goal state, we see that [beq_nat 0 (S n') = true] has become [false = true]: *) - (* n = S n' *) simpl. (** If we use [inversion] on this hypothesis, Coq notices that the subgoal we are working on is impossible, and therefore removes it from further consideration. *) intros H. inversion H. Qed. (** This is an instance of a logical principle known as the _principle of explosion_, which asserts that a contradictory hypothesis entails anything, even false things! *) Theorem inversion_ex4 : forall (n : nat), S n = O -> 2 + 2 = 5. MProof. intros n contra. inversion contra. Qed. Theorem inversion_ex5 : forall (n m : nat), false = true -> [n] = [m]. MProof. intros n m contra. inversion contra. Qed. (** If you find the principle of explosion confusing, remember that these proofs are not actually showing that the conclusion of the statement holds. Rather, they are arguing that, if the nonsensical situation described by the premise did somehow arise, then the nonsensical conclusion would follow. We'll explore the principle of explosion of more detail in the next chapter. *) (** **** Exercise: 1 star (inversion_ex6) *) Example inversion_ex6 : forall (X : Type) (x y z : X) (l j : list X), x :: y :: l = [] -> y :: l = z :: j -> x = z. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** To summarize this discussion, suppose [H] is a hypothesis in the context or a previously proven lemma of the form c a1 a2 ... an = d b1 b2 ... bm for some constructors [c] and [d] and arguments [a1 ... an] and [b1 ... bm]. Then [inversion H] has the following effect: - If [c] and [d] are the same constructor, then, by the injectivity of this constructor, we know that [a1 = b1], [a2 = b2], etc. The [inversion H] adds these facts to the context and tries to use them to rewrite the goal. - If [c] and [d] are different constructors, then the hypothesis [H] is contradictory, and the current goal doesn't have to be considered at all. In this case, [inversion H] marks the current goal as completed and pops it off the goal stack. *) (** The injectivity of constructors allows us to reason that [forall (n m : nat), S n = S m -> n = m]. The converse of this implication is an instance of a more general fact about both constructors and functions, which we will find useful in a few places below: *) Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A), x = y -> f x = f y. MProof. intros A B f x y eq. rewrite eq. reflexivity. Qed. (* ################################################################# *) (** * Using Tactics on Hypotheses *) (** By default, most tactics work on the goal formula and leave the context unchanged. However, most tactics also have a variant that performs a similar operation on a statement in the context. For example, the tactic [simpl in H] performs simplification in the hypothesis named [H] in the context. *) Theorem S_inj : forall (n m : nat) (b : bool), beq_nat (S n) (S m) = b -> beq_nat n m = b. MProof. intros n m b H. simpl_in H. apply H. Qed. (** Similarly, [apply L in H] matches some conditional statement [L] (of the form [L1 -> L2], say) against a hypothesis [H] in the context. However, unlike ordinary [apply] (which rewrites a goal matching [L2] into a subgoal [L1]), [apply L in H] matches [H] against [L1] and, if successful, replaces it with [L2]. In other words, [apply L in H] gives us a form of "forward reasoning": from [L1 -> L2] and a hypothesis matching [L1], it produces a hypothesis matching [L2]. By contrast, [apply L] is "backward reasoning": it says that if we know [L1->L2] and we are trying to prove [L2], it suffices to prove [L1]. Here is a variant of a proof from above, using forward reasoning throughout instead of backward reasoning. *) Theorem silly3' : forall (n : nat), (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) -> true = beq_nat n 5 -> true = beq_nat (S (S n)) 7. MProof. intros n eq H. symmetry_in H. apply_in eq H. symmetry_in H. apply H. Qed. (** Forward reasoning starts from what is _given_ (premises, previously proven theorems) and iteratively draws conclusions from them until the goal is reached. Backward reasoning starts from the _goal_, and iteratively reasons about what would imply the goal, until premises or previously proven theorems are reached. If you've seen informal proofs before (for example, in a math or computer science class), they probably used forward reasoning. In general, idiomatic use of Coq tends to favor backward reasoning, but in some situations the forward style can be easier to think about. *) (** **** Exercise: 3 stars, recommended (plus_n_n_injective) *) (** Practice using "in" variants in this exercise. (Hint: use [plus_n_Sm].) *) Theorem plus_n_n_injective : forall n m, n + n = m + m -> n = m. MProof. intros n. elim n &> [i:~~| \n']. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Varying the Induction Hypothesis *) (** Sometimes it is important to control the exact form of the induction hypothesis when carrying out inductive proofs in Coq. In particular, we need to be careful about which of the assumptions we move (using [intros]) from the goal to the context before invoking the [induction] tactic. For example, suppose we want to show that the [double] function is injective -- i.e., that it maps different arguments to different results: Theorem double_injective: forall n m, double n = double m -> n = m. The way we _start_ this proof is a bit delicate: if we begin with intros n. induction n. all is well. But if we begin it with intros n m. induction n. we get stuck in the middle of the inductive case... *) Theorem double_injective_FAILED : forall n m, double n = double m -> n = m. MProof. intros n m. elim n &> [i:~~ | \n']. - (* n = O *) simpl. destruct m &> [i: ~~ | \m'] &> intro eq. + (* m = O *) reflexivity. + (* m = S m' *) inversion eq. - (* n = S n' *) destruct m &> [i:~~ | \m'] &> intro IH &> intro eq. + (* m = O *) inversion eq. + (* m = S m' *) apply f_equal. (** At this point, the induction hypothesis, [IHn'], does _not_ give us [n' = m'] -- there is an extra [S] in the way -- so the goal is not provable. *) Abort. (** What went wrong? *) (** The problem is that, at the point we invoke the induction hypothesis, we have already introduced [m] into the context -- intuitively, we have told Coq, "Let's consider some particular [n] and [m]..." and we now have to prove that, if [double n = double m] for _these particular_ [n] and [m], then [n = m]. The next tactic, [induction n] says to Coq: We are going to show the goal by induction on [n]. That is, we are going to prove, for _all_ [n], that the proposition - [P n] = "if [double n = double m], then [n = m]" holds, by showing - [P O] (i.e., "if [double O = double m] then [O = m]") and - [P n -> P (S n)] (i.e., "if [double n = double m] then [n = m]" implies "if [double (S n) = double m] then [S n = m]"). If we look closely at the second statement, it is saying something rather strange: it says that, for a _particular_ [m], if we know - "if [double n = double m] then [n = m]" then we can prove - "if [double (S n) = double m] then [S n = m]". To see why this is strange, let's think of a particular [m] -- say, [5]. The statement is then saying that, if we know - [Q] = "if [double n = 10] then [n = 5]" then we can prove - [R] = "if [double (S n) = 10] then [S n = 5]". But knowing [Q] doesn't give us any help at all with proving [R]! (If we tried to prove [R] from [Q], we would start with something like "Suppose [double (S n) = 10]..." but then we'd be stuck: knowing that [double (S n)] is [10] tells us nothing about whether [double n] is [10], so [Q] is useless.) *) (** Trying to carry out this proof by induction on [n] when [m] is already in the context doesn't work because we are then trying to prove a relation involving _every_ [n] but just a _single_ [m]. *) (** The successful proof of [double_injective] leaves [m] in the goal statement at the point where the [induction] tactic is invoked on [n]: *) Theorem double_injective : forall n m, double n = double m -> n = m. MProof. intros n. elim n &> [i: ~~| \n' IH]. - (* n = O *) simpl. destructn 0 &> [i:~~| \m'] &> intro eq. + (* m = O *) reflexivity. + (* m = S m' *) inversion eq. - (* n = S n' *) simpl. (** Notice that both the goal and the induction hypothesis are different this time: the goal asks us to prove something more general (i.e., to prove the statement for _every_ [m]), but the IH is correspondingly more flexible, allowing us to choose any [m] we like when we apply the IH. *) (** Now we've chosen a particular [m] and introduced the assumption that [double n = double m]. Since we are doing a case analysis on [n], we also need a case analysis on [m] to keep the two "in sync." *) destructn 0 &> [i:~~ | \m'] &> intro eq. + (* m = O *) simpl. (** The 0 case is trivial: *) inversion eq. + (* m = S m' *) apply f_equal. (** At this point, since we are in the second branch of the [destruct m], the [m'] mentioned in the context is the predecessor of the [m] we started out talking about. Since we are also in the [S] branch of the induction, this is perfect: if we instantiate the generic [m] in the IH with the current [m'] (this instantiation is performed automatically by the [apply] in the next step), then [IHn'] gives us exactly what we need to finish the proof. *) apply IH. inversion eq. reflexivity. Qed. (** What you should take away from all this is that we need to be careful about using induction to try to prove something too specific: To prove a property of [n] and [m] by induction on [n], it is sometimes important to leave [m] generic. *) (** The following exercise requires the same pattern. *) (** **** Exercise: 2 stars (beq_nat_true) *) Theorem beq_nat_true : forall n m, beq_nat n m = true -> n = m. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 2 stars, advanced (beq_nat_true_informal) *) (** Give a careful informal proof of [beq_nat_true], being as explicit as possible about quantifiers. *) (* FILL IN HERE *) (** [] *) (** The strategy of doing fewer [intros] before an [induction] to obtain a more general IH doesn't always work by itself; sometimes some _rearrangement_ of quantified variables is needed. Suppose, for example, that we wanted to prove [double_injective] by induction on [m] instead of [n]. *) Theorem double_injective_take2_FAILED : forall n m, double n = double m -> n = m. MProof. intros n m. elim m &> [i:~~ | \m']. - (* m = O *) simpl. destruct n &> [i:~~ | \n'] &> intro eq. + (* n = O *) reflexivity. + (* n = S n' *) inversion eq. - (* m = S m' *) destruct n &> [i:~~| \n'] &> intro IH &> intro eq. + (* n = O *) inversion eq. + (* n = S n' *) apply f_equal. (* Stuck again here, just like before. *) Abort. (** The problem is that, to do induction on [m], we must first introduce [n]. (If we simply say [induction m] without introducing anything first, Coq will automatically introduce [n] for us!) *) (** What can we do about this? One possibility is to rewrite the statement of the lemma so that [m] is quantified before [n]. This works, but it's not nice: We don't want to have to twist the statements of lemmas to fit the needs of a particular strategy for proving them! Rather we want to state them in the clearest and most natural way. *) (** What we can do instead is to first introduce all the quantified variables and then _re-generalize_ one or more of them, selectively taking variables out of the context and putting them back at the beginning of the goal. The [generalize dependent] tactic does this. *) (* We will use this tactic twice, so we abstract it *) Local Definition tac := destructn 0 &> [i:~~| \n'] &> intro eq. Theorem double_injective_take2 : forall n m, double n = double m -> n = m. MProof. intros n m. (* [n] and [m] are both in the context *) move_back n. (* Now [n] is back in the goal and we can do induction on [m] and get a sufficiently general IH. *) elim m &> [i:~~| \m' IHm']. - (* m = O *) simpl. tac. + (* n = O *) reflexivity. + (* n = S n' *) inversion eq. - (* m = S m' *) tac. + (* n = O *) inversion eq. + (* n = S n' *) apply f_equal. apply IHm'. inversion eq. reflexivity. Qed. (** Let's look at an informal proof of this theorem. Note that the proposition we prove by induction leaves [n] quantified, corresponding to the use of generalize dependent in our formal proof. _Theorem_: For any nats [n] and [m], if [double n = double m], then [n = m]. _Proof_: Let [m] be a [nat]. We prove by induction on [m] that, for any [n], if [double n = double m] then [n = m]. - First, suppose [m = 0], and suppose [n] is a number such that [double n = double m]. We must show that [n = 0]. Since [m = 0], by the definition of [double] we have [double n = 0]. There are two cases to consider for [n]. If [n = 0] we are done, since [m = 0 = n], as required. Otherwise, if [n = S n'] for some [n'], we derive a contradiction: by the definition of [double], we can calculate [double n = S (S (double n'))], but this contradicts the assumption that [double n = 0]. - Second, suppose [m = S m'] and that [n] is again a number such that [double n = double m]. We must show that [n = S m'], with the induction hypothesis that for every number [s], if [double s = double m'] then [s = m']. By the fact that [m = S m'] and the definition of [double], we have [double n = S (S (double m'))]. There are two cases to consider for [n]. If [n = 0], then by definition [double n = 0], a contradiction. Thus, we may assume that [n = S n'] for some [n'], and again by the definition of [double] we have [S (S (double n')) = S (S (double m'))], which implies by inversion that [double n' = double m']. Instantiating the induction hypothesis with [n'] thus allows us to conclude that [n' = m'], and it follows immediately that [S n' = S m']. Since [S n' = n] and [S m' = m], this is just what we wanted to show. [] *) (** Before we close this section and move on to some exercises, let's digress briefly and use [beq_nat_true] to prove a similar property of identifiers that we'll need in later chapters: *) Theorem beq_id_true : forall x y, beq_id x y = true -> x = y. MProof. pintros [|\m] [|\n]. simpl. intros H. assert (H' : m = n). { apply beq_nat_true. apply H. } rewrite H'. reflexivity. Qed. (** **** Exercise: 3 stars, recommended (gen_dep_practice) *) (** Prove this by induction on [l]. *) Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X), length l = n -> nth_error l n = None. MProof. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Unfolding Definitions *) (** It sometimes happens that we need to manually unfold a Definition so that we can manipulate its right-hand side. For example, if we define... *) Definition square n := n * n. (** ... and try to prove a simple fact about [square]... *) Lemma square_mult : forall n m, square (n * m) = square n * square m. MProof. intros n m. simpl. (** ... we get stuck: [simpl] doesn't simplify anything at this point, and since we haven't proved any other facts about [square], there is nothing we can [apply] or [rewrite] with. To make progress, we can manually [unfold] the definition of [square]: *) unfold square. (** Now we have plenty to work with: both sides of the equality are expressions involving multiplication, and we have lots of facts about multiplication at our disposal. In particular, we know that it is commutative and associative, and from these facts it is not hard to finish the proof. *) rewrite mult_assoc. assert (H : n * m * n = n * n * m). { rewrite mult_comm. apply mult_assoc. } rewrite H. rewrite mult_assoc. reflexivity. Qed. (** At this point, a deeper discussion of unfolding and simplification is in order. You may already have observed that tactics like [simpl], [reflexivity], and [apply] will often unfold the definitions of functions automatically when this allows them to make progress. For example, if we define [foo m] to be the constant [5]... *) Definition foo (x: nat) := 5. (** then the [simpl] in the following proof (or the [reflexivity], if we omit the [simpl]) will unfold [foo m] to [(fun x => 5) m] and then further simplify this expression to just [5]. *) Fact silly_fact_1 : forall m, foo m + 1 = foo (m + 1) + 1. MProof. intros m. simpl. reflexivity. Qed. (** However, this automatic unfolding is rather conservative. For example, if we define a slightly more complicated function involving a pattern match... *) Definition bar x := match x with | O => 5 | S _ => 5 end. (** ...then the analogous proof will get stuck: *) Fact silly_fact_2_FAILED : forall m, bar m + 1 = bar (m + 1) + 1. MProof. intros m. simpl. (* Does nothing! *) Abort. (** The reason that [simpl] doesn't make progress here is that it notices that, after tentatively unfolding [bar m], it is left with a match whose scrutinee, [m], is a variable, so the [match] cannot be simplified further. (It is not smart enough to notice that the two branches of the [match] are identical.) So it gives up on unfolding [bar m] and leaves it alone. Similarly, tentatively unfolding [bar (m+1)] leaves a [match] whose scrutinee is a function application (that, itself, cannot be simplified, even after unfolding the definition of [+]), so [simpl] leaves it alone. *) (** At this point, there are two ways to make progress. One is to use [destruct m] to break the proof into two cases, each focusing on a more concrete choice of [m] ([O] vs [S _]). In each case, the [match] inside of [bar] can now make progress, and the proof is easy to complete. *) Fact silly_fact_2 : forall m, bar m + 1 = bar (m + 1) + 1. MProof. intros m. destruct m. - simpl. reflexivity. - simpl. reflexivity. Qed. (** This approach works, but it depends on our recognizing that the [match] hidden inside [bar] is what was preventing us from making progress. *) (** A more straightforward way to make progress is to explicitly tell Coq to unfold [bar]. *) Fact silly_fact_2' : forall m, bar m + 1 = bar (m + 1) + 1. MProof. intros m. unfold bar. (** Now it is apparent that we are stuck on the [match] expressions on both sides of the [=], and we can use [destruct] to finish the proof without thinking too hard. *) destruct m. - reflexivity. - reflexivity. Qed. (* ################################################################# *) (** * Using [destruct] on Compound Expressions *) (** We have seen many examples where [destruct] is used to perform case analysis of the value of some variable. But sometimes we need to reason by cases on the result of some _expression_. We can also do this with [destruct]. Here are some examples: *) Definition sillyfun (n : nat) : bool := if beq_nat n 3 then false else if beq_nat n 5 then false else false. Theorem sillyfun_false : forall (n : nat), (sillyfun n = false) : Type. MProof. intros n. unfold sillyfun. destruct (beq_nat n 3). - (* beq_nat n 3 = true *) simpl. reflexivity. - (* beq_nat n 3 = false *) simpl. destruct (beq_nat _ _). + (* beq_nat n 5 = true *) reflexivity. + (* beq_nat n 5 = false *) reflexivity. Qed. (** After unfolding [sillyfun] in the above proof, we find that we are stuck on [if (beq_nat n 3) then ... else ...]. But either [n] is equal to [3] or it isn't, so we can use [destruct (beq_nat n 3)] to let us reason about the two cases. In general, the [destruct] tactic can be used to perform case analysis of the results of arbitrary computations. If [e] is an expression whose type is some inductively defined type [T], then, for each constructor [c] of [T], [destruct e] generates a subgoal in which all occurrences of [e] (in the goal and in the context) are replaced by [c]. *) (** **** Exercise: 3 stars, optional (combine_split) *) Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2, split l = (l1, l2) -> combine l1 l2 = l. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** However, [destruct]ing compound expressions requires a bit of care, as such [destruct]s can sometimes erase information we need to complete a proof. *) (** For example, suppose we define a function [sillyfun1] like this: *) Definition sillyfun1 (n : nat) : bool := if beq_nat n 3 then true else if beq_nat n 5 then true else false. (** Now suppose that we want to convince Coq of the (rather obvious) fact that [sillyfun1 n] yields [true] only when [n] is odd. By analogy with the proofs we did with [sillyfun] above, it is natural to start the proof like this: *) Theorem sillyfun1_odd_FAILED : forall (n : nat), sillyfun1 n = true -> oddb n = true. MProof. intros n eq. unfold_in sillyfun1 eq. destruct (beq_nat n 3). (* stuck... *) Abort. (** We get stuck at this point because the context does not contain enough information to prove the goal! The problem is that the substitution performed by [destruct] is too brutal -- it threw away every occurrence of [beq_nat n 3], but we need to keep some memory of this expression and how it was destructed, because we need to be able to reason that, since [beq_nat n 3 = true] in this branch of the case analysis, it must be that [n = 3], from which it follows that [n] is odd. What we would really like is to substitute away all existing occurences of [beq_nat n 3], but at the same time add an equation to the context that records which case we are in. The [eqn:] qualifier allows us to introduce such an equation, giving it a name that we choose. *) Theorem sillyfun1_odd : forall (n : nat), sillyfun1 n = true -> oddb n = true. MProof. intros n. unfold sillyfun1. destruct_eq (beq_nat _ 3) &> intro Heqe3. (* Now we have the same state as at the point where we got stuck above, except that the context contains an extra equality assumption, which is exactly what we need to make progress. *) - (* e3 = true *) simpl. T.apply_in (beq_nat_true _ _) Heqe3. (* FIX: not very useful apply_in tactic... *) rewrite -> Heqe3. reflexivity. - (* e3 = false *) (* When we come to the second equality test in the body of the function we are reasoning about, we can use [eqn:] again in the same way, allow us to finish the proof. *) destruct_eq (beq_nat _ _) &> intro Heqe5. + (* e5 = true *) T.apply_in (beq_nat_true _ _) Heqe5. rewrite -> Heqe5. reflexivity. + (* e5 = false *) intro eq. inversion eq. Qed. (** **** Exercise: 2 stars (destruct_eqn_practice) *) Theorem bool_fn_applied_thrice : forall (f : bool -> bool) (b : bool), f (f (f b)) = f b. MProof. (* FILL IN HERE *) Admitted. (** [] *) (* ################################################################# *) (** * Review *) (** We've now seen many of Coq's most fundamental tactics. We'll introduce a few more in the coming chapters, and later on we'll see some more powerful _automation_ tactics that make Coq help us with low-level details. But basically we've got what we need to get work done. Here are the ones we've seen: - [intros]: move hypotheses/variables from goal to context - [reflexivity]: finish the proof (when the goal looks like [e = e]) - [apply]: prove goal using a hypothesis, lemma, or constructor - [apply... in H]: apply a hypothesis, lemma, or constructor to a hypothesis in the context (forward reasoning) - [apply... with...]: explicitly specify values for variables that cannot be determined by pattern matching - [simpl]: simplify computations in the goal - [simpl in H]: ... or a hypothesis - [rewrite]: use an equality hypothesis (or lemma) to rewrite the goal - [rewrite ... in H]: ... or a hypothesis - [symmetry]: changes a goal of the form [t=u] into [u=t] - [symmetry in H]: changes a hypothesis of the form [t=u] into [u=t] - [unfold]: replace a defined constant by its right-hand side in the goal - [unfold... in H]: ... or a hypothesis - [destruct... as...]: case analysis on values of inductively defined types - [destruct... eqn:...]: specify the name of an equation to be added to the context, recording the result of the case analysis - [induction... as...]: induction on values of inductively defined types - [inversion]: reason by injectivity and distinctness of constructors - [assert (H: e)] (or [assert (e) as H]): introduce a "local lemma" [e] and call it [H] - [generalize dependent x]: move the variable [x] (and anything else that depends on it) from the context back to an explicit hypothesis in the goal formula *) (* ################################################################# *) (** * Additional Exercises *) (** **** Exercise: 3 stars (beq_nat_sym) *) Theorem beq_nat_sym : forall (n m : nat), beq_nat n m = beq_nat m n. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, advanced? (beq_nat_sym_informal) *) (** Give an informal proof of this lemma that corresponds to your formal proof above: Theorem: For any [nat]s [n] [m], [beq_nat n m = beq_nat m n]. Proof: (* FILL IN HERE *) [] *) (** **** Exercise: 3 stars, optional (beq_nat_trans) *) Theorem beq_nat_trans : forall n m p, beq_nat n m = true -> beq_nat m p = true -> beq_nat n p = true. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, advanced (split_combine) *) (** We proved, in an exercise above, that for all lists of pairs, [combine] is the inverse of [split]. How would you formalize the statement that [split] is the inverse of [combine]? When is this property true? Complete the definition of [split_combine_statement] below with a property that states that [split] is the inverse of [combine]. Then, prove that the property holds. (Be sure to leave your induction hypothesis general by not doing [intros] on more things than necessary. Hint: what property do you need of [l1] and [l2] for [split] [combine l1 l2 = (l1,l2)] to be true?) *) Definition split_combine_statement : Prop (* ("[: Prop]" means that we are giving a name to a logical proposition here.) *) (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted. Theorem split_combine : split_combine_statement. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 3 stars, advanced (filter_exercise) *) (** This one is a bit challenging. Pay attention to the form of your induction hypothesis. *) Theorem filter_exercise : forall (X : Type) (test : X -> bool) (x : X) (l lf : list X), filter test l = x :: lf -> test x = true. MProof. (* FILL IN HERE *) Admitted. (** [] *) (** **** Exercise: 4 stars, advanced, recommended (forall_exists_challenge) *) (** Define two recursive [Fixpoints], [forallb] and [existsb]. The first checks whether every element in a list satisfies a given predicate: forallb oddb [1;3;5;7;9] = true forallb negb [false;false] = true forallb evenb [0;2;4;5] = false forallb (beq_nat 5) [] = true The second checks whether there exists an element in the list that satisfies a given predicate: existsb (beq_nat 5) [0;2;3;6] = false existsb (andb true) [true;true;false] = true existsb oddb [1;0;0;0;0;3] = true existsb evenb [] = false Next, define a _nonrecursive_ version of [existsb] -- call it [existsb'] -- using [forallb] and [negb]. Finally, prove a theorem [existsb_existsb'] stating that [existsb'] and [existsb] have the same behavior. *) (* FILL IN HERE *) (** [] *) (** $Date: 2017-09-06 10:45:52 -0400 (Wed, 06 Sep 2017) $ *) Mtac2-1.4-coq8.20/tests/ssrpattern.v000066400000000000000000000013641472011217100171520ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Goal (3+5, 0) = (10, 0). MProof. (* works with _ *) ssrpattern (_+_). T.treduce (RedOneStep [rl:RedZeta]). (* works with evars, but won't instantiate them *) e <- M.evar nat; f <- M.evar nat; ssrpattern (e+f);; (mif M.is_evar e then T.ret tt else M.failwith "evar instantiated"): tactic. Abort. Import M.notations. (* abstract _from_sort and _from_term *) Goal True->True. MProof. opf <- T.abstract_from_sort Propₛ 3 (3+3 = 6); match opf with | mSome f=> M.print_term f | mNone => M.failwith "abstract failed!" end;; M.ret _. Unshelve. opf <- T.abstract_from_term 3 (_+3 = 6); match opf with | mSome f=> M.print_term f | mNone => M.failwith "abstract failed!" end;; M.ret _. Abort.Mtac2-1.4-coq8.20/tests/tactics.v000066400000000000000000000025131472011217100163740ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Goal 2+3 = 4 -> 2+2 = 3 -> 5 = 3. MProof. intros H1 H2. T.simpl_in_all. rewrite H1, H2. T.reflexivity. Qed. Goal 2+3 = 4 -> 2+2 = 3 -> 5 = 3. MProof. intros H1 H2. T.simpl_in H1 &> T.simpl_in H2. (* #101 concatenation of simpl_in doesn't work *) rewrite H1, H2. T.reflexivity. Qed. Goal True. MProof. T.cut True. - T.apply id. - T.exact I. Qed. Inductive test_i := | Zero : nat -> test_i | One : test_i -> test_i | Two : test_i -> test_i -> test_i. Goal forall g:test_i, g = g. MProof. (* #97 intros wasn't creating evars for each type *) T.destructn 0 &> intros n &> T.reflexivity. Qed. Require Import Mtac2.tactics.IntroPatt. Example ex_act_on (x y z : nat) (H: x = y) : y = x. MProof. act_on x T.destruct [i: ~~ | \x'] &> (`A B <- M.evar nat; T.select (A = B) >>= fun x=>rewrite x) &> T.reflexivity. Qed. Example ex_act_on2 (x y z : test_i) (H: x = y) : y = x. MProof. act_on x T.destruct [i: ?? | ?? | \a ??] &> (`A B <- M.evar test_i; T.select (A = B) >>= fun x=>rewrite x) &> T.reflexivity. Qed. Example ex_specialize: (forall x, x >= 0) -> forall y, y >= 0. MProof. intros f x. T.specialize f x. T.assumption. Qed. Example repeat_it: True /\ True /\ True /\ (False -> False) /\ True. MProof. T.repeat (T.split || T.exact I || T.assumption || intros). Qed.Mtac2-1.4-coq8.20/tests/test_bind.v000066400000000000000000000002231472011217100167110ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Goal True. MProof. M.bind (M.ret I) (fun r => M.ret r). Qed. Goal True. MProof. (r <- M.ret I; M.ret r)%MC. Qed. Mtac2-1.4-coq8.20/tests/test_brackets.v000066400000000000000000000012341472011217100175760ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Import T. Theorem andb3_exchange : forall b c d, andb (andb b c) d = andb (andb b d) c. MProof. intros b c d. destruct b. - destruct c. { destruct d. - reflexivity. - reflexivity. } { destruct d. - reflexivity. - reflexivity. } - destruct c. { destruct d. - reflexivity. - reflexivity. } { destruct d. * reflexivity. * reflexivity. } Qed. Import Lists.List.ListNotations. Theorem plus_n_O : forall n:nat, n = n + 0. MProof. intros n. elim n asp [ [] ; [ "n'" ; "IHn'"]]. - (* n = 0 *) reflexivity. - (* n = S n' *) simpl. rewrite <- IHn'. reflexivity. Qed. Mtac2-1.4-coq8.20/tests/test_get_name.v000066400000000000000000000014661472011217100175660ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Goal True. MProof. (s <- M.get_binder_name (fun name:nat=>name); match String.string_dec s "name" with | left _ => M.ret I | _ => M.raise exception end)%MC. Qed. Goal forall x:nat, True. MProof. M.ret (fun name=>_). Unshelve. (s <- M.get_binder_name name; match String.string_dec s "name" with | left _ => M.ret I | _ => M.raise exception end)%MC. Qed. Goal True. MProof. M.nu (TheName "name") mNone (fun x:nat=> s <- M.get_binder_name x; match String.string_dec s "name" with | left _ => M.ret I | _ => M.raise exception end)%MC. Qed. Goal True. MProof. (r <- M.nu (TheName "name") mNone (fun x:nat => M.abs_fun x x); s <- M.get_binder_name r; match String.string_dec s "name" with | left _ => M.ret I | _ => M.raise exception end)%MC. Qed. Mtac2-1.4-coq8.20/tests/test_get_reference.v000066400000000000000000000017601472011217100206010ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Goal forall x, 0 <= x. MProof. H <- M.get_reference "le_0_n"; dcase H as e in T.apply e. Qed. Goal forall x, 0 <= x. MProof. H <- M.get_reference "Peano.le_0_n"; dcase H as e in T.exact e. Qed. Goal forall x, 0 <= x. MProof. H <- M.get_reference "Coq.Init.Peano.le_0_n"; dcase H as e in T.apply e. Qed. Definition myle0n := le_0_n. Goal forall x, 0 <= x. MProof. H <- M.get_reference "myle0n"; dcase H as e in T.apply e. Qed. Goal forall x, 0 <= x -> 0 <= x. MProof. intros x H. mtry H <- M.get_reference "H"; dcase H as e in T.apply e with RefNotFound "H" => T.apply myle0n end. Qed. (* We don't have this issue anymore *) (* Goal forall x, 0 <= x. *) (* MProof. *) (* H <- M.get_reference "Peano.le_0_n"; *) (* T.exact H.(elem). *) (* Fail Qed. *) (* (* it rightfully complains that the universe in elem is not compatible with the one from H. *) (* This is why it should be destroyed as done previously. *) *) (* Abort. *) Mtac2-1.4-coq8.20/tests/test_goal_match.v000066400000000000000000000037661472011217100201120ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Import T. Goal forall x : nat, forall y : bool, True. MProof. intros x y. (* works *) match_goal with [[ (x : nat) (y : bool) |- _ ]] => idtac end. match_goal with [[ (y : bool) (y : nat) |- _ ]] => idtac end. (* it should fail *) Fail match_goal with [[ (x : nat) (y : nat) |- _ ]] => idtac end. exact I. Qed. Goal forall (x : nat) (H : x > 0) (y : bool), True. MProof. intros x H y. (* works *) match_goal with [[ (x : nat) (y : bool) |- _ ]] => idtac end. match_goal with [[ (y : bool) (y : nat) |- _ ]] => idtac end. match_goal with [[ (z : nat) (Q : z > 0) |- _ ]] => idtac end. match_goal with [[ (z : nat) (w : bool) (Q : z > 0) |- _ ]] => idtac end. match_goal with [[ (w : bool) (z : nat) (Q : z > 0) |- _ ]] => idtac end. match_goal with [[ (Q : x > 0) (z : nat) |- _ ]] => idtac end. (* it should fail *) Fail match_goal ([[ (x : nat) (y : nat) |- _ ]] => idtac). exact I. Qed. Goal forall (x : nat) (H : x > 0) (y : bool), x = x. MProof. intros x H y. match_goal with [[ (Q : x > 0) (z : nat) |- x = z ]] => reflexivity end. Qed. Goal forall (x : nat) (H : x > 0) (y : bool), x = x. MProof. intros x H y. match_goal with [[? a | (Q : a > 0) (z : nat) |- a = z ]] => reflexivity end. Qed. Goal forall (x : nat) (H : x > 0) (y : bool), 0 + x = x. MProof. intros x H y. match_goal with [[? a | (Q : a > 0) (z : nat) |- a = z ]] => apply (eq_refl a) end. Qed. Goal forall (x : nat) (H : x > 0) (y : bool), 0 + x = x. MProof. intros x H y. match_goal with | [[? a |- a = a + a ]] => idtac | [[? a | (Q : a > 0) (z : nat) |- a = z ]] => apply (eq_refl a) | [[? a : nat |- a = a ]] => raise (Failure "should not happen") end. Qed. Goal forall (x : nat) (H : x > 0) (y : bool), 0 + x = x. MProof. intros x H y. (* a is instantiated with x, and then when matching x with 0 + x it fails (as it should) *) Fail match_goal_nored with [[? a | (Q : a > 0) (z : nat) |- a = z ]] => apply (eq_refl a) end. match_goal_nored with [[? a | (Q : a > 0) (z : nat) |- 0 + a = z ]] => apply (eq_refl a) end. Qed. Mtac2-1.4-coq8.20/tests/test_mmatch.v000066400000000000000000000234451472011217100172610ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Import T. Goal True. MProof. (mmatch I with [? i] i => M.ret i : M True end)%MC. Qed. Goal True. MProof. (mmatch _ with [? i] i => M.ret i : M True end)%MC. Unshelve. (mmatch (fun x=>x) I with [? i] (fun x=>x) i => M.ret i : M True end)%MC. Qed. Goal True. MProof. (* uninstantiated i *) (mmatch (fun x=>x) I with [? i] I => M.ret i : M True end)%MC. (* do not reduce pattern *) Fail (mmatch I with [? i] (fun x=>x) i => M.ret i : M True end)%MC. Unshelve. (mmatch I with | [? i] (fun x=>x) i => M.ret i : M True | [? i] i => M.ret i : M True end)%MC. Qed. Require Import List. Import ListNotations. (** Testing the construction of mmatch *) Definition NotFound : Exception. exact exception. Qed. Require Import Init.Datatypes. Require Import Lists.List. Import Base.M. Import M.notations. Definition inlist A (x : A) : forall (l : list A), M (In x l) := mfix1 f (l : list A) : M (In x l) := mmatch l as l return M (In x l ) with | [? l r] l ++ r => M.mtry' ( il <- f l; M.ret (in_or_app l r x (or_introl il)) ) (fun e=>mmatch e with NotFound => ir <- f r; M.ret (in_or_app l r x (or_intror ir)) end) | [? s] (x :: s) => M.ret (in_eq _ _) | [? y s] (y :: s) => r <- f s; M.ret (in_cons y _ _ r) | _ => M.raise NotFound end. Import ListNotations. (** Testing the execution of mmatch *) Example testM ( x01 x11 x21 x31 x41 x51 x61 x71 x81 x91 x02 x12 x22 x32 x42 x52 x62 x72 x82 x92 x03 x13 x23 x33 x43 x53 x63 x73 x83 x93 x04 x14 x24 x34 x44 x54 x64 x74 x84 x94 x05 x15 x25 x35 x45 x55 x65 x75 x85 x95 x06 x16 x26 x36 x46 x56 x66 x76 x86 x96 x07 x17 x27 x37 x47 x57 x67 x77 x87 x97 x08 x18 x28 x38 x48 x58 x68 x78 x88 x98 x09 x19 x29 x39 x49 x59 x69 x79 x89 x99 : nat) : In x99 [ x01;x11;x21;x31;x41;x51;x61;x71;x81;x91; x02;x12;x22;x32;x42;x52;x62;x72;x82;x92; x03;x13;x23;x33;x43;x53;x63;x73;x83;x93; x04;x14;x24;x34;x44;x54;x64;x74;x84;x94; x05;x15;x25;x35;x45;x55;x65;x75;x85;x95; x06;x16;x26;x36;x46;x56;x66;x76;x86;x96; x07;x17;x27;x37;x47;x57;x67;x77;x87;x97; x08;x18;x28;x38;x48;x58;x68;x78;x88;x98; x09;x19;x29;x39;x49;x59;x69;x79;x89;x99 ]. MProof. Time inlist _ _ _. Qed. (* This definition fails because Coq is unable to find the returning type*) Definition test (t : nat) := mmatch t with | 0 => ret (eq_refl 0) end. (* We need the [return] clause *) Definition test_return (t : nat) : M (t = t) := mmatch t as x return M (x = x) with | 0 => M.ret (eq_refl 0) end. (* testing with a different name *) Definition test_return_in (t : nat) : M (t = t) := mmatch 0+t as x return M (x = x) with | 0 => M.ret (eq_refl 0) end. (* testing no reducing patterns *) (* note that in this case we change the order (it doesn't matter) *) Definition inlist_nored A (x : A) : forall (l : list A), M (In x l) := mfix1 f (l : list A) : M (In x l) := mmatch l as l return M (In x l) with | [? s] (x :: s) =n> M.ret (in_eq _ _) | [? y s] (y :: s) =n> r <- f s; M.ret (in_cons y _ _ r) | [? l r] l ++ r =n> mtry il <- f l; M.ret (in_or_app l r x (or_introl il)) with NotFound => ir <- f r; M.ret (in_or_app l r x (or_intror ir)) end | _ => M.raise NotFound end. Example with_red : In 0 ([1;2]++[0;4]). MProof. inlist _ _ _. Defined. Example with_nored : In 0 ([1;2]++[0;4]). MProof. inlist_nored _ _ _. Defined. (* we prove that we get the same proof: the list wasn't reduce to cons in the second case *) Lemma are_equal : with_nored = with_red. Proof. reflexivity. Qed. (* if instead we use reduction (in the first two patterns), the proof is not the same: *) Definition inlist_redcons A (x : A) : forall (l : list A), M (In x l) := mfix1 f (l : list A) : M (In x l) := mmatch l as l return M (In x l) with | [? s] (x :: s) => M.ret (in_eq _ _) | [? y s] (y :: s) => r <- f s; M.ret (in_cons y _ _ r) | [? l r] l ++ r =n> mtry il <- f l; M.ret (in_or_app l r x (or_introl il)) with NotFound => ir <- f r; M.ret (in_or_app l r x (or_intror ir)) end | _ => M.raise NotFound end. Example with_redcons : In 0 ([1;2]++[0;4]). MProof. inlist_redcons _ _ _. Defined. (* we can't prove we get the same proof: the list was reduce to cons in the second case *) Lemma are_not_equal : with_nored = with_redcons. Proof. Fail reflexivity. Abort. (* Test new `Sort` patterns *) From Mtac2 Require Import Sorts. Mtac Do ((fun (T : Type) => mmatch T with [¿ s] [? (T : s)] (T : Type) =u> M.unify_or_fail UniMatchNoRed s Propₛ;; M.ret I end) (True -> True)). Mtac Do ((fun (T : Type) => mmatch T with [¿ s] [? (T : s)] (T : Type) =u> M.unify_or_fail UniMatchNoRed s Typeₛ;; M.ret I end) (True -> nat)). (* Test new `Exception` parameter of `mmatch'` which is instantiated with an exception different from `DoesNotMatch` for our encoding of `mtry`. The test asserts that a `DoesNotMatch` exception can escape `mtry`. This is crucial for certain backtracking metaprograms and tactics. *) Mtac Do ( M.mtry' ( mtry M.raise DoesNotMatch with | DoesNotMatch => mtry M.raise DoesNotMatch with | DoesNotMatch => M.raise DoesNotMatch end end) (fun e => M.unify_or_fail UniMatchNoRed e DoesNotMatch;; M.ret tt) ). (** Test new branch types of `mmatch` *) (* [is_head] *) Mtac Do ( mmatch (3 + 5) with | [#] plus | x y =n> M.unify_or_fail UniMatchNoRed (x,y) (3,5);; M.ret I end ). (* Checking notation levels *) Mtac Do ( mmatch (3 + 5) with | [#] plus | x y =n> _ <- M.ret tt; M.unify_or_fail UniMatchNoRed (x,y) (3,5);; M.ret I | [#] plus | x y =n> M.ret tt;; M.unify_or_fail UniMatchNoRed (x,y) (3,5);; M.ret I end ). (* This example will fail because it does perform any reduction on the initial arguments *) Fail Mtac Do ( mmatch (3 + 3) with | [#] plus (2+1) | y =n> M.unify_or_fail UniMatchNoRed (y) (5);; M.ret I end ). (* But this one succeeds, as it uses conversion by calling Unicoq's unification. *) Mtac Do ( mmatch (3 + 5) with | [#] plus (2+1) | y =u> M.unify_or_fail UniMatchNoRed (y) (5);; M.ret I end ). (* Non-primitive projections *) Record R1 := { f1 : nat }. Mtac Do ( mmatch f1 {| f1 := 1 |} with | [#] f1 | r =u> M.unify_or_fail UniMatchNoRed (r) ({|f1 := 1|});; M.ret I end ). Set Primitive Projections. Record R2 := { f2 : nat }. Mtac Do ( mmatch f2 {| f2 := 1 |} with | [#] f2 | r =u> M.unify_or_fail UniMatchNoRed (r) ({|f2 := 1|});; M.ret I end ). Mtac Do ( mmatch f2 {| f2 := 1 |} with | [#] f2 {| f2 := 2 |} | =u> mfail "primitive projection error: record values were not unified at all" | [#] f2 {| f2 := (0+1) |} | =n> mfail "primitive projection error: record values were unified but shouldn't have been" | [#] f2 {| f2 := (0+1) |} | =u> M.ret I end ). Mtac Do ( mmatch {| f2 := 1 |}.(f2) with | [#] @f2 {| f2 := 2 |} | =u> mfail "primitive projection error: record values were not unified at all" | [#] @f2 {| f2 := (0+1) |} | =n> mfail "primitive projection error: record values were unified but shouldn't have been" | [#] @f2 {| f2 := (0+1) |} | =u> M.ret I end ). (* Primitive records with parameters *) Record R3 {p : nat} := { f3 : bool }. (* Primitive target, non-primitive branches *) Definition R3_test1 := mmatch f3 (Build_R3 1 true) return M True with | [#] @f3 2 | r =u> mfail "primitive projection error: record parameters should not match" | [#] @f3 (0+1) | r =n> mfail "primitive projection error: record parameters were unified but shouldn't have been" | [#] @f3 (0+1) | r =u> M.unify_or_fail UniMatchNoRed (r) (Build_R3 1 true);; M.ret I end. Mtac Do (R3_test1). Definition R3_test2 := mmatch f3 (Build_R3 1 true) return M True with | [#] f3 (Build_R3 1 true) | =n> M.ret I end. Mtac Do (R3_test2). Definition R3_test3 := (* Only way to enter non-primitive projections for primitive records *) ltac:(let p := constr:(@f3 (0+1)) in exact( (* Unfortunately, once the match is executed the projection is unfolded already. *) mmatch p (Build_R3 1 true) return M True with | [#] f3 (Build_R3 1 true) | =n> mfail "primitive projection error: record parameters were unified but shouldn't have been" | [#] f3 (Build_R3 2 true) | =n> mfail "primitive projection error: record values were unified but shouldn't have been" | [#] f3 (Build_R3 (0+1) true) | =n> M.ret I end ) ). (* There is nothing we can do about this with the way the compatability constants are unfolded automatically. *) Fail Mtac Do (R3_test3). (* [decompose_forall[P|T]] *) Mtac Do ( mmatch (forall x : nat, x = x) with | [!Prop] forall _ : X, P =n> M.unify_or_fail UniMatchNoRed P (fun x => x = x);; M.ret I end ). Mtac Do ( mmatch (nat -> Type) with | [!Type] forall _ : X, P =n> M.unify_or_fail UniMatchNoRed P (fun x => Type);; M.ret I end ). (* [#] patterns with eta expanded terms *) Mtac Do ( mmatch (3 + 5) with | [#] fun x y => plus x y | x y =n> M.unify_or_fail UniMatchNoRed (x,y) (3,5);; M.ret I end ). Mtac Do ( mmatch Nat.add 3 with | [#] fun x => plus x | x =n> M.unify_or_fail UniMatchNoRed (x) (3);; M.ret I end ). Mtac Do ( mmatch fun y => Nat.add 3 y with | [#] fun x => plus x | x =n> M.unify_or_fail UniMatchNoRed (x) (3);; M.ret I end ). Mtac Do ( mmatch fun y => Nat.add 3 y with | [#] plus | x =n> M.unify_or_fail UniMatchNoRed (x) (3);; M.ret I end ). Mtac2-1.4-coq8.20/tests/test_mtry.v000066400000000000000000000010301472011217100167650ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Import M. Import notations. Goal True. MProof. mtry' (raise exception) (fun _=>ret I). Qed. Goal True. MProof. mtry raise exception with _ => ret I end. Qed. Definition one : Exception. exact exception. Qed. Goal True. MProof. mtry @raise True exception with exception => ret I end. Qed. Goal True. MProof. mtry' (raise one) (fun e => mtry' (unify e exception UniCoq;; raise e) (fun _=>ret I)). Qed. Goal True. MProof. Fail mtry @raise True one with exception => ret I end. ret I. Qed. Mtac2-1.4-coq8.20/tests/test_munify.v000066400000000000000000000011241472011217100173050ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Definition test {A} (o : M (moption A)) : M _ := o <- o; match o with mSome x => M.ret x | _ => M.raise exception end. Goal True =m= True. MProof. test (M.unify True True UniCoq). Qed. Goal True =m= False. MProof. Fail test (M.unify True False UniCoq). Abort. Import M. Import M.notations. Definition test_unfold := 1 + 1. Set Unicoq Debug. Fail Eval hnf in ltac:(mrun ( A <- evar Type; t1 <- evar (A -> nat); t2 <- evar A; unify_or_fail UniMatchNoRed (t1 t2) test_unfold;; M.ret 0)). (* Should fail: it shouldn't unfold test *) Mtac2-1.4-coq8.20/tests/test_ret.v000066400000000000000000000000761472011217100165750ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Goal True. MProof. M.ret I. Qed. Mtac2-1.4-coq8.20/tests/test_unfold_in.v000066400000000000000000000001651472011217100177570ustar00rootroot00000000000000Require Import Mtac2.Mtac2. Goal forall x, 0 + x = S x -> False. MProof. intros x H. T.unfold_in plus H. Abort. Mtac2-1.4-coq8.20/tests/timers.v000066400000000000000000000014231472011217100162440ustar00rootroot00000000000000From Mtac2 Require Import Base. Import M.notations. Definition timer : Prop. exact True. Qed. Mtac Do (M.new_timer timer). Definition unused_timer : Prop. exact True. Qed. Mtac Do (M.new_timer unused_timer). Definition slow := (mfix1 f (n : nat) : M unit := match n with | S n => M.unify 1 1 UniCoq;; f n | O => M.ret tt end) 1000. Mtac Do ( M.start_timer timer true;; slow;; M.stop_timer timer;; M.print_timer timer ). Mtac Do (M.print_timer timer). Mtac Do ( M.start_timer timer false;; slow;; M.stop_timer timer;; M.print_timer timer ). Mtac Do (M.print_timer unused_timer). (* Should print 0.0 *)Mtac2-1.4-coq8.20/tests/trace.v000066400000000000000000000005341472011217100160410ustar00rootroot00000000000000From Mtac2 Require Import Base Datatypes. Goal True. MProof. M.ret I. Qed. Import M.notations. Goal forall P:Type, forall x: P, P. MProof. Mtac Do Set_Trace. M.nu Generate mNone (fun P:Type=>M.nu Generate mNone (fun x:P=> M.abs_fun x x >>= M.abs_fun P)). Mtac Do Unset_Trace. Qed. Goal True. MProof. M.ret I. (* no more tracing *) Qed. Mtac2-1.4-coq8.20/tests/ttactics.v000066400000000000000000000064231472011217100165640ustar00rootroot00000000000000From Mtac2 Require Import Mtac2 Ttactics. From Coq Require Import String. (* Mtac Do (do_def "tt_lt_trans" (@PeanoNat.Nat.lt_trans)). *) (* Check tt_lt_trans. *) (* Arguments tt_lt_trans {_ _ _}. *) (* (** Example: transitivity *) *) (* Definition trans {x y z: nat} : M ((x < z) * (z < y) =m> x < y) := *) (* tg1 <- evar _; *) (* tg2 <- evar _; *) (* ret ((tg1, tg2), PeanoNat.Nat.lt_trans _ _ _ tg1 tg2). *) (* Import TT. *) (* Import TT.notations. *) (* Goal 1 < 3 -> 3 < 4 -> 1 < 4. *) (* MProof. *) (* intros. *) (* compl tt_lt_trans [t: tassumption | tassumption ]. *) (* Qed. *) (* Goal 1 < 3 -> 3 < 4 -> 1 < 4. *) (* MProof. *) (* intros. *) (* compl tt_lt_trans [t: Muse T.assumption | assumption]. *) (* Qed. *) (* Goal 1 < 3 -> 3 < 4 -> 1 < 4. *) (* MProof. *) (* intros. *) (* to_tactic tt_lt_trans &> T.try T.assumption. *) (* Qed. *) Import TT.notations. (* The following test case tries to establish that the proof term of [test_vm_compute] matches [id (_ <: _)]. It could really benefit from a [constr_eq] primitive. The reason we test this is that we need to be careful about [CClosure] operations accidentally removing the cast. It also serves as a test case for typed tactics where it is often necessary to have [vm_compute] calls. *) Definition test_vm_compute : True. mrun (TT.apply id <**> TT.vm_compute <**> TT.apply I >>= TT.to_T)%tactic. Defined. Mtac Do ( let t := reduce (RedOneStep [rl: RedDelta]) (test_vm_compute) in M.decompose_app'' t (fun A B f a => M.decompose_app'' f (fun C D g b => mmatch existT id C b return M unit with | [? X (Q : X -> Prop) b] existT id (forall x, Q x) b =u> \nu x : X, let bx := reduce (RedOneStep [rl: RedBeta]) (b x) in k <- M.kind_of_term bx; match k with | tmCast => M.ret tt | _ => M.failwith "Cast disappeared." end end ) : M (unit) ) (* M.unify_or_fail UniMatchNoRed t (id (fun a : True => a <: True) I) *) )%MC. (* Testing the *type* of the goal in [match_goal] for the absence of [S.selem_of] and other unwanted wrappers. *) Module SelemOf. Import TT. Definition test_Type := ( match_goal with | [[?P |- P]] => mmatch P return M (P *m _) with | unit =n> TT.idtac : M _ | _ => mfail "[P] not forwarded as exactly [P] to [match_goal] branch" end end)%MC%TT. Definition test_Prop := ( match_goal with | [[?P : Prop |- P]] => mmatch P return M (P *m _) with | True =n> TT.idtac : M _ | _ => mfail "[P] not forwarded as exactly [P] to [match_goal] branch" end end)%MC%TT. Goal unit. mrun test_Type. Abort. Goal True. mrun test_Prop. Abort. End SelemOf. Mtac2-1.4-coq8.20/tests/typeclass.v000066400000000000000000000012531472011217100167510ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Class Test := { val : nat }. #[global] Instance Zero : Test := {| val := 0 |}. Import M.notations. Definition CouldntFindTC : Exception. exact exception. Qed. Definition fail_solve_tc A := M.solve_typeclass A >>= fun x=> match x with | mSome v => M.ret v | mNone => M.raise CouldntFindTC end. Definition zero := ltac:(mrun (fail_solve_tc Test >>= fun x=>M.ret (@val x))). Goal zero = 0. MProof. T.reflexivity. Qed. Class TestFail := { valF : nat }. Definition fail_but_caught := ltac: (mrun ( mtry fail_solve_tc TestFail;; M.ret 1 with CouldntFindTC => M.ret 0 end)). Goal fail_but_caught = 0. MProof. T.reflexivity. Qed. Mtac2-1.4-coq8.20/tests/typed_term_decomposition.v000066400000000000000000000061001472011217100220460ustar00rootroot00000000000000From Mtac2 Require Import Base MTele DecomposeApp Tactics List. Import M.notations. Import ProdNotations. Import Mtac2.lib.List.ListNotations. Import TeleNotation. Definition test_tele : MTele := [tele (x y : nat)]. Check ltac:(mrun ( M.decompose_app' (B := fun _ => (nat*nat)%type) (m := test_tele) UniMatchNoRed (3+5) (@plus) (fun x y => M.ret (x,y))) ). (* This test will fail because [3] and [2+1] not be unified as requested by specifying `UniMatchNoRed`. *) Fail Check ltac:(mrun ( M.decompose_app' (B := fun _ => nat) (m := [tele _]) UniMatchNoRed (3+5) (@plus (2+1)) (fun y => M.ret (y))) ). (* Once we allow unification of evars the test succeeds *) Check ltac:(mrun ( M.decompose_app' (B := fun _ => nat) (m := [tele _]) UniCoq (3+5) (@plus _) (fun y => M.ret (y))) ). Definition prop_tele : MTele := mTele (fun _ : Prop => mTele (fun _ : Prop => mBase)). Check ltac:(mrun ( M.decompose_app' (B := fun _ => (_*_)%type) (m := prop_tele) UniMatchNoRed (True \/ False) (@or) (fun x y => M.ret (x,y))) ). Import T.notations. Goal True. MProof. (<[decapp (3+5) with @plus]> UniMatchNoRed (fun x y => M.print_term (x,y);; T.idtac)). Abort. Example dep_type (n1 n2: nat) : match n1 with | O => bool | S _ => unit end -> n2 = n2 := fun _ => eq_refl n2. Local Close Scope tactic_scope. Local Open Scope M_scope. Import M.notations. Mtac Do ( mtry <[decapp dep_type O 2 true with dep_type 1 2]> UniCoq (fun u => M.print_term u) with | WrongTerm => M.ret tt end ). Notation app := (3 + 4). Definition test1 : M unit := M.decompose_app'' (S:=fun _ _ => _) app (fun A B f h => M.ret tt). Mtac Do (test1). Definition decompose_app {A} (a : A) : M (dyn *m mlist dyn) := let rec := mfix3 f (A : _) (a : A) (args : mlist dyn) : M (dyn *m mlist dyn) := mtry M.decompose_app'' (S:=fun _ _ => _) a (fun X Y h x => f _ h (Dyn x :m: args) ) with NotAnApplication =n> M.ret (m: Dyn a, args) end in rec _ a mnil . Mtac Do (M.decompose app >>= M.print_term). Mtac Do (decompose_app app >>= M.print_term). (* To see if the resulting term is actually well-typed, we return it. Printing is not concerned by ill-typedness. *) Mtac Do (decompose_app app). Notation FA := (forall n : nat, n = n). Definition test3 := M.decompose_forallT (B:=fun _ => _) FA (fun A B => M.ret tt) (M.raise NotAForall). Mtac Do (test3). Notation FA_Prop := (forall n : nat, n = n). Definition test3_Prop := M.decompose_forallP (B:=fun _ => _) FA_Prop (fun A B => M.ret tt) (M.raise NotAForall). Mtac Do (test3_Prop).Mtac2-1.4-coq8.20/tests/unification.v000066400000000000000000000010031472011217100172430ustar00rootroot00000000000000From Mtac2 Require Import Mtac2. Import M. Import M.notations. Goal True. MProof. (* unequal *) unify_cnt (B:=fun x=>x) UniCoq True False (failwith "equal?") (ret I). Qed. Goal True. MProof. (* equal *) unify_cnt (B:=fun x=>x) UniCoq True True (ret I) (failwith "not equal?"). Qed. Goal True. MProof. (* unreduced Reduction: it shouldn't work *) pose (r := UniCoq). mtry unify_cnt (B:=fun _=>_) r True True (failwith "equal?") (failwith "not equal?") with NotAUnifStrategy => ret I end. Qed. Mtac2-1.4-coq8.20/theories/000077500000000000000000000000001472011217100152325ustar00rootroot00000000000000Mtac2-1.4-coq8.20/theories/Base.v000066400000000000000000000034411472011217100162750ustar00rootroot00000000000000Declare ML Module "coq-unicoq.plugin". Declare ML Module "MetaCoqPlugin:coq-mtac2.plugin". (* Declare ML Module must work without the Requires to be compatible with async proofs. Running it before them serves as a test (although it doesn't test that it still works without the prelude Requires). *) From Mtac2 Require Import Logic Datatypes Logic List Utils Sorts MTele. Import Sorts. From Mtac2 Require Export Pattern. From Mtac2.intf Require Export Dyn Reduction Unification DeclarationDefs M Lift . Require Import Strings.String. Require Import NArith.BinNat. Require Import NArith.BinNatDef. Import Mtac2.lib.List.ListNotations. Set Universe Polymorphism. Unset Universe Minimization ToSet. Module M. Export M.M. (** Defines [eval f] to execute after elaboration the Mtactic [f]. It allows e.g. [rewrite (eval f)]. *) Class runner A (f : t A) := { eval : A }. Arguments runner {A} _. Arguments Build_runner {A} _ _. Arguments eval {A} _ {_}. End M. #[global] Hint Extern 20 (M.runner ?f) => (mrun (M.bind f (fun eres=> M.ret (M.Build_runner f eres)))) : typeclass_instances. Import M.notations. Notation "t 'mwith' ( k := u )" := (ltac:(mrun (r <- M.mwith t k u; dcase r with _ as x in M.ret x)%MC)) (at level 0). (** creation of exceptions *) Definition new_exception name := M.declare dok_Definition name true exception;; M.ret tt. Definition binder_exception (f: unit->unit) := M.get_binder_name f >>= new_exception. Notation "'New' 'Exception' n" := (binder_exception (fun n=>n)) (at level 0, n at next level). Definition Check {A} (x:A) := M.print_term A. Definition Set_Debug_Exceptions := M.set_debug_exceptions true. Definition Unset_Debug_Exceptions := M.set_debug_exceptions false. Definition Set_Trace := M.set_trace true. Definition Unset_Trace := M.set_trace false. Mtac2-1.4-coq8.20/theories/DecomposeApp.v000066400000000000000000000077321472011217100200110ustar00rootroot00000000000000From Mtac2 Require Import Base Datatypes List Sorts Specif MTele Tactics MFixDef MTeleMatchDef. Import Sorts.S. Import M.notations. Import ListNotations. Set Universe Polymorphism. Unset Universe Minimization ToSet. (** Given `(A T : Type) (t : T)`, derive - `m : MTele` - `MTele_Const A m` such that - `T = MTele_Const A m` - `t : MTele_Const A m` *) (* FIX: proper error messaging *) Definition MTele_of (A : Type) : forall T, T -> M (msigT (MTele_Const (s:=Typeₛ) A)) := let matchtele := fun T => mTele (fun _ : T => mBase) in let fixtele := mTele (matchtele) in mfix' (m:=fixtele) (fun T (_ : T) => msigT (MTele_Const (s:=Typeₛ) A)) ( fun f T => mtmmatch' _ matchtele _ T [m: branch_pattern (@pbase _ (fun T => T -> M (msigT (MTele_Const (s:=Typeₛ) A))) A (fun t : A => M.ret (mexistT (MTele_Const (s:=Typeₛ) A) mBase t)) UniCoq ) | branch_pattern (ptele (fun (X : Type) => ptele (fun (F : forall x : X, Type) => @pbase _ (fun T => T -> M (msigT (MTele_Const (s:=Typeₛ) A))) (forall x : X, F x) (fun t : _ => M.nu (FreshFrom T) mNone (fun x => let Fx := reduce (RedOneStep [rl:RedBeta]) (F x) in let tx := (* rone_step *) (t x) in '(mexistT _ n T) <- f Fx tx; n' <- M.abs_fun (P:=fun _ => MTele) x n; T' <- M.coerce T; T' <- M.abs_fun (P:=fun x => MTele_Const (s:=Typeₛ) A (n' x)) x T'; M.ret (mexistT (MTele_Const (s:=Typeₛ) A) (mTele n') T') ) ) UniCoq ))) ] ). Definition decompose_app {m : MTele} {A : Type} {B : A -> Type} {C : MTele_ConstT A m} {T: Type} (a : A) (t : T) : M (Unification -> MTele_sort (MTele_ConstMap (si:=Typeₛ) Propₛ (fun a : A => M (B a)) C) -> M (B a)) := ( '(mexistT _ m' T') <- MTele_of A T t; M.unify m m' UniCoq;; M.cumul UniCoq C t;; let x := fun u => @M.decompose_app' A B m u a C in M.ret x ). Notation "'<[decapp' a 'return' T 'with' b ]>" := ( ltac:(mrun (decompose_app (B:=T) a b)) ) (at level 0, a at next level, b at next level) : M_scope. Notation "'<[decapp' a 'with' b ]>" := ( ltac:(mrun (decompose_app (A:=?[A]) (B:=fun _ : ?A => _) a b)) ) (at level 0, a at next level, b at next level) : M_scope. Local Definition mtele_convert' {A : Type} {B : A -> Prop} {G : Type} {mt:MTele} {C : MTele_ConstT A mt} : MTele_sort (MTele_ConstMap (si:=Typeₛ) Propₛ (fun a => G -> B a) C) -> (G -> MTele_sort (MTele_ConstMap (si:=Typeₛ) Propₛ B C)). induction mt as [|X F IHmt]. - cbn. refine (fun x => x). - cbn. intros ? ? ?. refine (IHmt _ _ _ _); [|auto]. apply X0. Defined. Definition decompose_app_tactic {m : MTele} {A : Type} {B : A -> Type} {C : MTele_ConstT A m} {T: Type} (a : A) (t : T) : M (Unification -> MTele_sort (MTele_ConstMap (si:=Typeₛ) Propₛ (fun a : A => gtactic (B a)) C) -> gtactic (B a)) := ( '(mexistT _ m' T') <- MTele_of A T t; M.unify m m' UniCoq;; M.cumul UniCoq C t;; let x := fun uni f (g : goal gs_open) => @M.decompose_app' A (fun a => mlist (mprod (B a) (goal gs_any))) m uni a C (f g) in let y := fun uni f => x uni (mtele_convert' f) in M.ret y ). Notation "'<[decapp' a 'return' T 'with' b ]>" := ( ltac:(mrun (decompose_app_tactic (B:=T) a b)) ) (at level 0, a at next level, b at next level) : tactic_scope. Notation "'<[decapp' a 'with' b ]>" := ( ltac:(mrun (decompose_app_tactic (A:=?[A]) (B:=fun _ : ?A => _) a b)) ) (at level 0, a at next level, b at next level) : tactic_scope.Mtac2-1.4-coq8.20/theories/Mtac2.v000066400000000000000000000005761472011217100163770ustar00rootroot00000000000000Require Export Strings.String. Require Export Numbers.BinNums. Export Coq.Strings.String. Export Coq.NArith.BinNatDef. From Mtac2 Require Export Base List Logic Datatypes. From Mtac2.tactics Require Export Tactics ImportedTactics. Export M.notations. Export TacticsBase.T.notations. Export Tactics.T.notations. Export ListNotations. Export ProdNotations. Open Scope string_scope. Mtac2-1.4-coq8.20/theories/Pattern.v000066400000000000000000000226761472011217100170530ustar00rootroot00000000000000From Mtac2 Require Import Logic List intf.Unification Sorts MTele Exceptions. Import Sorts.S. Import ListNotations. Set Universe Polymorphism. Unset Universe Minimization ToSet. Set Polymorphic Inductive Cumulativity. (** Pattern matching without pain *) (* The M will be instantiated with the M monad or the gtactic monad. In principle, we could make it part of the B, but then higher order unification will fail. *) Inductive pattern@{a} (A : Type@{a}) (B : A -> Prop) : Prop := | pany : (forall x : A, B x) -> pattern A B | pbase : forall x : A, B x -> Unification -> pattern A B | ptele : forall {C:Type@{a}}, (forall x : C, pattern A B) -> pattern A B | psort : (Sort -> pattern A B) -> pattern A B. Arguments pany {A B} & _. Arguments pbase {A B} & _ _ _. Arguments ptele {A B C} & _. Arguments psort {A B} & _. (* Set Printing Universes. *) (* Set Printing Implicit. *) Inductive branch@{a elem_a x+} : forall {A : Type@{a}} {B : A -> Prop}, Prop := | branch_pattern {A : Type@{a}} {B : A -> Prop} : pattern A B -> @branch A B | branch_app_static {A : Type@{a}} {B : A -> Prop} : forall {m:MTele@{elem_a}} (uni : Unification) (C : selem_of (MTele_Const@{_ _} (s:=Typeₛ) A m)), MTele_sort@{elem_a _ _ a elem_a} (MTele_ConstMap (si := Typeₛ) Propₛ (fun a : A => B a) C) -> @branch A B | branch_forallP {B : Prop -> Prop}: (forall (X : Type@{x}) (Y : X -> Prop), B (forall x : X, Y x)) -> @branch Prop B | branch_forallT {B : Type@{elem_a} -> Prop}: (forall (X : Type@{elem_a}) (Y : X -> Type@{elem_a}), B (forall x : X, Y x)) -> @branch Type@{elem_a} B. Arguments branch _ _ : clear implicits. Arguments branch_pattern _ _ &. (* | branch_app_dynamic {A} {B : forall A, A -> Type} {y}: *) (* (forall X (Y : X -> Type) (f : forall x, Y x) (x : X), M (B _ (f x))) -> *) (* @branch M _ B A y *) Declare Custom Entry Mtac2_pattern. Notation "[¿ s .. t ] ps" := (psort (fun s => .. (psort (fun t => ps)) ..)) (in custom Mtac2_pattern at level 202, s binder, t binder, ps custom Mtac2_pattern, only parsing). Notation "'[S?' s .. t ] ps" := (psort (fun s => .. (psort (fun t => ps)) ..)) (in custom Mtac2_pattern at level 202, s binder, t binder, ps custom Mtac2_pattern). Notation "[? x .. y ] ps" := (ptele (fun x => .. (ptele (fun y => ps)).. )) (in custom Mtac2_pattern at level 202, x binder, y binder, ps custom Mtac2_pattern at next level, only parsing ). Declare Custom Entry Mtac2_unification. Notation "=m>" := (UniMatch) (in custom Mtac2_unification, only parsing). Notation "=>" := (UniMatch) (in custom Mtac2_unification). Notation "=n>" := (UniMatchNoRed) (in custom Mtac2_unification). Notation "=c>" := (UniEvarconv) (in custom Mtac2_unification). Notation "=u>" := (UniCoq) (in custom Mtac2_unification). Notation "p u b" := (pbase p%core b%core u) (no associativity, in custom Mtac2_pattern at level 201, p constr, b constr, u custom Mtac2_unification). (* To get perfect indentation we declare a printing only rule that incorporates both evars and base of the pattern *) Notation "[? x .. y ] p u b" := (ptele (fun x => .. (ptele (fun y => pbase p%core b%core u)).. )) (in custom Mtac2_pattern at level 202, x binder, y binder, p constr, b constr, u custom Mtac2_unification, only printing, format "'[' [? x .. y ] p u '/' '[' b ']' ']'" ). Notation "'_' => b " := (pany (fun _ => b%core)) (in custom Mtac2_pattern at level 201, b constr). Notation "'_' 'as' catchall => b " := (pany (fun catchall => b%core)) (in custom Mtac2_pattern at level 201, b constr, catchall binder). Notation "'[debug_Mtac2_pattern' p ]" := (p) (p custom Mtac2_pattern at level 1000, only parsing). Check [debug_Mtac2_pattern [? x : nat] true =u> _]. Declare Custom Entry Mtac2_branch. Notation "x" := (branch_pattern x) (in custom Mtac2_branch at level 201, x custom Mtac2_pattern). (* Syntax for decomposition of applications with a known head symbol. The [=>] arrows are annotated with the reduction strategy used for the initial arguments that are part of the head symbol term [f]. The delimiter [|] separates the head symbol term from the arguments, which are binders that can be refered to in [b] *) Notation "'[#' ] f '|' x .. z '=n>' b" := (branch_app_static (m := mTele (fun x => .. (mTele (fun z => mBase)) ..)) UniMatchNoRed f (fun x => .. (fun z => b) ..) ) (in custom Mtac2_branch at level 201, f constr, x binder, z binder, b constr). Notation "'[#' ] f '|' '=n>' b" := (branch_app_static (m := mBase) UniMatchNoRed f b) (in custom Mtac2_branch at level 201, f constr, b constr). Notation "'[#' ] f '|' x .. z '=m>' b" := (branch_app_static (m := mTele (fun x => .. (mTele (fun z => mBase)) ..)) UniMatch f (fun x => .. (fun z => b) ..) ) (in custom Mtac2_branch at level 201, f constr, x binder, z binder, b constr). Notation "'[#' ] f '|' '=m>' b" := (branch_app_static (m := mBase) UniMatch f b) (in custom Mtac2_branch at level 201, f constr, b constr). Notation "'[#' ] f '|' x .. z '=u>' b" := (branch_app_static (m := mTele (fun x => .. (mTele (fun z => mBase)) ..)) UniCoq f (fun x => .. (fun z => b) ..) ) (in custom Mtac2_branch at level 201, f constr, x binder, z binder, b constr). Notation "'[#' ] f '|' '=u>' b" := (branch_app_static (m := mBase) UniCoq f b) (in custom Mtac2_branch at level 201, f constr, b constr). Notation "'[#' ] f '|' x .. z '=c>' b" := (branch_app_static (m := mTele (fun x => .. (mTele (fun z => mBase)) ..)) UniEvarconv f (fun x => .. (fun z => b) ..) ) (in custom Mtac2_branch at level 201, f constr, x binder, z binder, b constr). Notation "'[#' ] f '|' '=c>' b" := (branch_app_static (m := mBase) UniEvarconv f b) (in custom Mtac2_branch at level 201, f constr, b constr). (* Syntax for decomposition of [forall x : X, P x]. We define two variants, one for [Prop] and for [Type]. The initial tokens are [[!Prop]] and [[!Type]] and the remaining syntax tries to mirror an actual [forall]. *) Notation "'[!Prop' ] 'forall' '_' : X , P =n> b" := (branch_forallP (fun X P => b)) (in custom Mtac2_branch at level 201, X constr, P constr, b constr). Notation "'[!Type' ] 'forall' '_' : X , P =n> b" := (branch_forallT (fun X P => b)) (in custom Mtac2_branch at level 201, X constr, P constr, b constr). Structure Predicate := PREDICATE { predicate_pred : Prop }. Structure Matcher {A} := MATCHER { matcher_pred: forall y, Predicate; matcher_ret: Prop; _ : forall (E: Exception) (ps : mlist (branch A (fun y => predicate_pred (matcher_pred y)))), matcher_ret }. Arguments Matcher {_}. Arguments MATCHER {_}. Definition matcher_match {A} (m : Matcher) : forall (E: Exception) (ps : mlist (branch A (fun y => predicate_pred (matcher_pred m y)))), matcher_ret m := ltac:(destruct m as [ ? ? x]; refine x). Structure InDepMatcher := INDEPMATCHER { idmatcher_return : Prop; _ : forall A (y : A) (E: Exception) (ps : mlist (branch A (fun _ => idmatcher_return))), idmatcher_return; }. Definition idmatcher_match (m : InDepMatcher) : forall A y (E: Exception) (ps : mlist (branch A (fun _ => idmatcher_return m))), idmatcher_return m := ltac:(destruct m as [ ? x]; refine x). Definition idmatcher_match_invert (m : InDepMatcher) (A : Type) (y : A) (R : Prop) : R =m= idmatcher_return m -> forall (_ : Exception) (_ : mlist (branch A (fun _ => R))), (* R y =m= matcher_return y m -> *) R. intros ->. eauto using idmatcher_match. Defined. Arguments idmatcher_match _ _ _ & _. Definition matcher_match_invert (A : Type) (y : A) (m : Matcher) (R : A -> Prop) : (matcher_ret m =m= R y) -> (fun y => predicate_pred (matcher_pred m y)) =m= R -> forall (_ : Exception) (_ : mlist (branch A R)), (* R y =m= matcher_return y m -> *) R y. intros <- <-. eauto using matcher_match. Defined. Arguments matcher_match_invert _ _ _ _ & _ _ _ _ . Declare Custom Entry Mtac2_with_branch. Notation "| p1 | .. | pn" := ((@mcons (branch _ _) p1 (.. (@mcons (branch _ _) pn [m:]) ..))) (in custom Mtac2_with_branch at level 91, p1 custom Mtac2_branch at level 210, pn custom Mtac2_branch at level 210, format "| p1 '//' | .. '//' | pn" ). Notation "p1 | .. | pn" := ((@mcons (branch _ _) p1 (.. (@mcons (branch _ _) pn [m:]) ..))) (in custom Mtac2_with_branch at level 91, p1 custom Mtac2_branch at level 210, pn custom Mtac2_branch at level 210, only parsing ). Notation "'mmatch' x 'with' ls 'end'" := (idmatcher_match _ _ x DoesNotMatch ls) (at level 200, ls custom Mtac2_with_branch at level 91, format "'[hv' 'mmatch' x 'with' '/' ls '/' 'end' ']'"). Notation "'mmatch' x 'return' p 'with' ls 'end'" := (idmatcher_match_invert _ _ x p meq_refl DoesNotMatch ls) (at level 200, ls custom Mtac2_with_branch at level 91, format "'[hv' 'mmatch' x 'return' p 'with' '/' ls '/' 'end' ']'"). Notation "'mmatch' x 'as' y 'return' p 'with' ls 'end'" := (matcher_match_invert _ x _ (fun y => p%type) meq_refl meq_refl DoesNotMatch ls) (at level 200, ls custom Mtac2_with_branch at level 91, y binder, format "'[hv' 'mmatch' x 'as' y 'return' p 'with' '/' ls '/' 'end' ']'"). Notation "'mmatch' x 'in' T 'as' y 'return' p 'with' ls 'end'" := (matcher_match_invert T%type x _ (fun y => p%type) meq_refl meq_refl DoesNotMatch ls) (at level 200, ls custom Mtac2_with_branch at level 91, y binder, format "'[hv' 'mmatch' x 'in' T 'as' y 'return' p 'with' '/' ls '/' 'end' ']'"). Mtac2-1.4-coq8.20/theories/dune000066400000000000000000000003101472011217100161020ustar00rootroot00000000000000(coq.theory (name Mtac2) (package coq-mtac2) (modules :standard \ ideas.SumRun ideas.Pre-typedtactics ideas.non_refl_refl) (libraries unicoq.plugin coq-mtac2.plugin)) (include_subdirs qualified) Mtac2-1.4-coq8.20/theories/ideas/000077500000000000000000000000001472011217100163175ustar00rootroot00000000000000Mtac2-1.4-coq8.20/theories/ideas/Abstract.v000066400000000000000000000133711472011217100202560ustar00rootroot00000000000000From Mtac2 Require Import Base Logic Datatypes List. Import M. Import M.notations. Set Implicit Arguments. Unset Strict Implicit. Set Universe Polymorphism. Unset Universe Minimization ToSet. Structure result A B x t := R { fu : A -> B; pf : t =m= fu x }. Arguments R [A B x t]. Notation reduce_dyns := (reduce (RedStrong [rl:RedBeta; RedMatch; RedZeta; RedDeltaOnly [rl: Dyn elemr; Dyn typer; Dyn case_return; Dyn case_val; Dyn case_branches; Dyn case_ind]])). Lemma abs_app (A : Type) (x : A) (A' : Type) r (t1 : A' -> typer r) (t2 : A') (r1 : result x t1) (r2 : result x t2): result x (t1 t2). Proof. elim r1. intros f1 p1. elim r2. intros f2 p2. rewrite p1, p2. exact (R (fun y=>f1 y (f2 y)) (meq_refl _)). Defined. Lemma match_eq : forall A B : Type, forall x : A, forall (r : dynr) (b : bool) (P Q : typer r), result x b -> result x P -> result x Q -> result x (if b then P else Q). Proof. intros A B x r b P Q r1 r2 r3. elim r1; intros f1 b1. elim r2; intros f2 b2. elim r3; intros f3 b3. rewrite b1, b2, b3. exact (R (fun y=>if (f1 y) then (f2 y) else f3 y) (meq_refl _)). Defined. Arguments match_eq [A B x r b P Q]. Definition non_dep_eq {A P Q} (x:A) (P' : result x P) (Q' : result x Q) : result x (P -> Q). Proof. case P' as [fuP eqP]. case Q' as [fuQ eqQ]. rewrite eqP, eqQ. refine (R (fun y=>fuP y -> fuQ y) meq_refl). Defined. Definition to_dynr (d: dyn) : M dynr := dcase d as e in ret (Dynr e). Import ProdNotations. Import Mtac2.lib.List.ListNotations. Require Import Strings.String. Definition construct_case A (x: A) (loop: forall r: dynr, M (moption (result x (elemr r)))) C := let 'mkCase _ val retrn branches := C in nu (FreshFromStr "v") mNone (fun v=> new_val_opt <- loop (Dynr val); '(m: some_branch_depends, new_branches) <- M.fold_right ( fun branch '(m: some_branch_depends, new_branches) => b <- to_dynr branch; r <- loop b; match r with | mSome r => let (fub, _) := r in let fub := reduce (RedWhd [rl:RedBeta]) (fub v) in ret (m: true, Dyn fub :m: new_branches) | mNone => ret (m: some_branch_depends, branch :m: new_branches) end ) (m: false, [m:]) branches; let new_val := match new_val_opt with mSome new_val => new_val | mNone => R (fun _ => val) meq_refl end in match new_val_opt, some_branch_depends with | mSome _, _ | _, true => let (fuv, _) := new_val in let fuv := reduce (RedWhd [rl:RedBeta]) (fuv v) in let new_case := reduce_dyns {| case_val := fuv; case_return := retrn; case_branches := new_branches |} in d <- makecase new_case; dcase d as A0, cas in func <- abs_fun v cas; ret (mSome (@Dyn (A -> A0) func)) | _,_ => ret mNone end ). Notation reduce_all := (reduce (RedStrong [rl:RedBeta; RedMatch; RedZeta; RedDeltaOnly [rl: Dyn elemr; Dyn typer; Dyn (@fu); Dyn (@abs_app); Dyn (@meq_rect_r); Dyn (@meq_rect); Dyn (@meq_sym); Dyn (@internal_meq_rew_r); Dyn (@match_eq); Dyn (@non_dep_eq)]])). Definition abstract A B (x : A) (t : B) : M (moption _) := mif is_evar x then M.ret mNone else r <- (mfix1 loop (r : dynr) : M (moption (result x (elemr r))) := let r := reduce_dyns r in let '(Dynr r') := r in mif is_evar (r') then M.ret mNone else mmatch r as r' return M (moption (result x (elemr r'))) with | Dynr x =c> ret (mSome (R (fun x=>x) (meq_refl _))) (* | [? b (P:type r) (Q:type r)] Dyn (match b with *) (* | true => P *) (* | false => Q *) (* end) *) (* =u> *) (* b' <- loop (Dyn b); *) (* P' <- loop (Dyn P); *) (* Q' <- loop (Dyn Q); *) (* ret (match_eq B b' P' Q') *) | [? P Q] Dynr (P -> Q) =n> P' <- loop (Dynr P); Q' <- loop (Dynr Q); match P', Q' with | mSome P', mSome Q' => ret (mSome (non_dep_eq P' Q')) | mSome P', mNone => ret (mSome (non_dep_eq P' (R (fun _ => Q) meq_refl))) | mNone, mSome Q' => ret (mSome (non_dep_eq (R (fun _ => P) meq_refl) Q')) | mNone, mNone => ret mNone end | _ as r => let r' := dreduce (typer) (typer r) in mmatch r as r' return M (moption (result x (elemr r'))) with | [? A' (t1 : A' -> r') t2] Dynr (t1 t2) =n> r1 <- loop (Dynr t1); r2 <- loop (Dynr t2); match r1, r2 with | mSome r1, mSome r2 => ret (mSome (abs_app r1 r2)) | mSome r1, mNone => ret (mSome (abs_app r1 (R (fun _ => t2) meq_refl))) | mNone, mSome r2 => ret (mSome (abs_app (R (fun _ => t1) meq_refl) r2)) | mNone, mNone => ret mNone end | [? z] z =n> let def := R (fun _=>elemr z) (meq_refl) : (result x (elemr z)) in mtry let '@Dynr T e := z in C <- destcase e; cas <- construct_case loop C; match cas with | mSome cas => mmatch cas with | [? el: A -> (typer z)] Dyn el =c> eq <- coerce (meq_refl (elemr z)); ret (mSome (R (t:=elemr z) el eq)) | [? e] e => print "nope:";; print_term e;; ret (mNone) end | mNone => ret mNone end with NotAMatchExp => ret mNone end end end) (Dynr t); let reduced := reduce_all r in ret reduced. Lemma eq_fu (A : Type) (x y : A) (P : Type) (r : result x P) : x = y -> fu r y -> P. Proof. elim r. intros f H1 H2. simpl. rewrite H1, H2. auto. Qed. Mtac2-1.4-coq8.20/theories/ideas/DepDestruct.v000066400000000000000000000465611472011217100207500ustar00rootroot00000000000000From Mtac2 Require Import Logic Datatypes List Sorts Base MTeleMatch MFix. From Mtac2.tactics Require Import Tactics ImportedTactics. Import Sorts.S. Import M.notations. Import ProdNotations. Require Import Strings.String. Import Mtac2.lib.List.ListNotations. Set Universe Polymorphism. Unset Universe Minimization ToSet. (** This is the [abs] from [MetaCoq] but first reducing the variable [x] (in case it is [id x] or some convertible term to a variable) *) Definition abs {A} {P} (x:A) (t:P x) := (* let y := reduce RedHNF x in *) (* abs_fun y t. *) M.abs_fun x t. Notation redMatch := (reduce (RedWhd [rl:RedMatch])). (** A polymorphic function that returns the type of an element. *) Definition type_of {A : Type} (x : A) : Type := A. (** [ITele s] described a sorted type [forall x, ..., y, P] with [P] a [stype_of s]. *) Inductive ITele (sort : Sort) : Type := | iBase : sort -> ITele sort | iTele : forall {T : Type}, (T -> ITele sort) -> ITele sort. Declare Scope ITele_scope. Delimit Scope ITele_scope with IT. Bind Scope ITele_scope with ITele. Arguments iBase {_} _. Arguments iTele {_ _%type} _. (** [ATele it] describes a applied version of the type described in [it]. For instance, if [it] represents the type [T] equals to [forall x, ..., y, P], [ATele it] represents [T c1 ... cn]. *) (* Inductive ATele {sort} : ITele sort -> Type := *) (* | aBase : forall {T: stype_of sort}, ATele (iBase T) *) (* | aTele : forall {T : Type} {f : T -> ITele sort} (a:T), ATele (f a) -> ATele (iTele f). *) (* Delimit Scope ATele_scope with AT. *) (* Bind Scope ATele_scope with ATele. *) (* Arguments aBase {_ _}. *) (* Arguments aTele {_ _%type _} _%AT _. *) Fixpoint ATele {sort} (it : ITele sort) : Type := match it with | iBase T => unit | @iTele _ T f => { t : T & ATele (f t) } end. Arguments ATele {_} !_%IT : simpl nomatch. Declare Scope ATele_scope. Delimit Scope ATele_scope with AT. Bind Scope ATele_scope with ATele. Definition aBase {isort} {T} : ATele (@iBase isort T) := tt. Definition aTele {isort} {T} {f} t (a : ATele (f t)) : ATele (@iTele isort T f) := existT _ t a. (** Returns the type resulting from the [ATele] [args] *) Fixpoint ITele_App {isort} {it : ITele isort} : forall (args : ATele it), isort := match it with | iBase T => fun _ => T | iTele f => fun '(existT _ t a) => ITele_App a end. Arguments ITele_App {_ !_%IT} !_%AT : simpl nomatch. (** Represents a constructor of an inductive type. *) Inductive CTele {sort} (it : ITele sort) : Type := | cBase : forall {a : ATele it} (c : ITele_App a), CTele it | cProd : forall {T : Type}, (T -> CTele it) -> CTele it. Declare Scope CTele_scope. Delimit Scope CTele_scope with CT. Bind Scope CTele_scope with CTele. Arguments CTele {_} _%IT. Arguments cBase {_ _%IT} _%AT _. Arguments cProd {_ _%IT _%type} _. (** Represents a constructor of an inductive type where all arguments are non-dependent *) Notation NDCfold it := (fun l => mfold_right (fun T b => T *m b)%type unit l -> {a : ATele it & ITele_App a}). Definition NDCTele {sort} (it : ITele sort) : Type := { l : mlist Type & NDCfold it l }. Definition ndcBase {sort} {T : stype_of sort} (a : ATele (iBase T)) (t : selem_of T) : NDCTele (iBase T) := existT _ [m:] (fun _ => existT _ a t). (** Represents the result type of a branch. *) (* Inductive RTele {isort} rsort : ITele isort -> Type := *) (* | rBase : forall {T : stype_of isort}, (selem_of T -> stype_of rsort) -> RTele rsort (iBase T) *) (* | rTele : forall {T:Type} {f}, (forall (t : T), RTele rsort (f t)) -> RTele rsort (iTele f). *) (* Delimit Scope RTele_scope with RT. *) (* Bind Scope RTele_scope with RTele. *) (* Represent it as a function as its shape is completely determined by the given ITele *) Fixpoint RTele {isort : Sort} (rsort : Sort) (it : ITele isort) : Type := match it with | iBase T => T -> rsort | iTele f => forall t, RTele rsort (f t) end. Arguments RTele {_} _ _%IT. Fixpoint RTele_App {isort rsort} {it : ITele isort} : forall (a : ATele it), RTele rsort it -> selem_of (ITele_App a) -> stype_of rsort := match it as it' with | iBase _ => fun _ rt => rt | iTele f => fun '(existT _ t a) rt => RTele_App a (rt t) end. (* Fixpoint RTele_App {isort rsort} {it : ITele isort} (rt : RTele rsort it) : forall (a : ATele it), selem_of (ITele_App a) -> stype_of rsort := *) (* match rt in RTele _ it' return forall a' : ATele it', selem_of (ITele_App a') -> stype_of rsort *) (* with *) (* | @rBase _ _ T t => *) (* fun (a : ATele (iBase T)) => *) (* match a as a' in ATele it' return *) (* match it' with *) (* | iBase T' => (selem_of T' -> stype_of rsort) -> selem_of (ITele_App a') -> stype_of rsort *) (* | iTele f => True *) (* end *) (* with *) (* | aBase => fun f => f *) (* | aTele _ _ => I *) (* end t *) (* | rTele r => *) (* let rec t := RTele_App (r t) in *) (* fun (a : ATele (iTele _)) => *) (* match a as a' in ATele it' return *) (* match it' with *) (* | iBase _ => True *) (* | @iTele _ T' f => (forall (t:T') (a:ATele (f t)), selem_of (ITele_App a) -> _) -> selem_of (ITele_App a') -> stype_of rsort *) (* end *) (* with *) (* | aBase => I *) (* | aTele v a => fun rec => rec v a *) (* end rec *) (* end. *) (* rt_T_weird1 and rt_T_weird2 will be equal to rt_T_type1 and rt_T_type2. Again, Coq does not realize that. So we leave them in for now. *) Fixpoint RTele_Type {isort rsort} {it : ITele isort} : RTele rsort it -> Type := match it with | iBase s => fun _ => (forall (t : s), rsort) | iTele _ => fun rt => forall t, RTele_Type (rt t) end. (* No idea why we still need rt_F_max_weird. *) Fixpoint RTele_Fun {isort rsort} {it : ITele isort} : forall (rt : RTele rsort it), RTele_Type rt := match it with | iBase _ => fun r => r | iTele _ => fun rt t => (RTele_Fun (rt t)) end. Notation reduce_novars := (reduce (RedStrong [rl:RedBeta;RedMatch;RedFix;RedDeltaC;RedZeta])). (* We need to handle Prop (maybe) *) Program Fixpoint abstract_goal {isort} {rsort} {it : ITele isort} (G : stype_of rsort) : forall (args : ATele it) , selem_of (ITele_App args) -> M (RTele rsort it) := match it as it' return forall (a' : ATele it'), selem_of (ITele_App a') -> M (RTele rsort it') with | iBase T => fun _ => fun t : T => let t := reduce_novars t in b <- M.is_var t; if b then let Gty := reduce RedHNF (type_of G) in let T' := reduce RedHNF (type_of t) in r <- (@abs T' (fun _=>Gty) t G) : M (RTele _ (iBase _)); let r := reduce RedHNF (r) in M.ret r else M.failwith "Argument t should be a variable" | iTele f => fun '(existT _ v args) => fun t : ITele_App _ => r <- abstract_goal G args t; let v := reduce_novars v in b <- M.is_var v; if b then let Gty := reduce RedHNF (fun v'=>RTele rsort (f v')) in let T' := reduce RedHNF (type_of v) in r <- @abs T' Gty v r : M (RTele _ (iTele _)); let r := reduce RedHNF (r) in (* M.ret r *) _ else M.failwith "All indices need to be variables" end%MC. Next Obligation. exact (M.ret r1). Defined. Fixpoint branch_of_CTele {isort} {rsort} {it : ITele isort} (rt : RTele rsort it) (ct : CTele it) : stype_of rsort := match ct with | cBase a t => RTele_App a rt t | cProd f => ForAll (fun t => branch_of_CTele rt (f t)) end. Definition branch_of_NDCTele {isort} {rsort} {it : ITele isort} (rt : RTele rsort it) (ct : NDCTele it) : stype_of rsort := (fix rec l := match l as l' return NDCfold it l' -> rsort with | [m:] => fun f => RTele_App (projT1 (f tt)) rt (projT2 (f tt)) | T :m: l => fun f => ForAll (fun t : T => rec l (fun y => f(m: t,y))) end) (projT1 ct) (projT2 ct). (* Get exactly `max` many arguments *) Definition NotEnoughArguments : Exception. exact exception. Qed. Program Fixpoint args_of_max (max : nat) : dyn -> M (mlist dyn) := match max with | 0 => fun _ => M.ret [m:] | S max => fun d=> mmatch d with | [? T Q (t : T) (f : T -> Q)] Dyn (f t) => r <- args_of_max max (Dyn f); M.ret (Dyn t :m: r) | _ => T <- M.evar Type; P <- M.evar (T -> Type); f <- M.evar (forall x:T, P x); t <- M.evar T; dcase d as el in b <- M.cumul UniCoq el (f t); if b then r <- args_of_max max (Dyn f); M.ret (Dyn t :m: r) else M.raise NotEnoughArguments end end%MC. (** Given a inductive described in [it] and a list of elements [al], it returns the [ATele] describing the applied version of [it] with [al]. *) Fixpoint get_ATele {isort} (it : ITele isort) (al : mlist dyn) {struct al} : M (ATele it) := match it as it', al return M (ATele it') with | iBase T, [m:] => M.ret tt | iTele f, t_dyn :m: al => (* We coerce the type of the element in [t_dyn] to match that expected by f *) dcase t_dyn as el in t <- M.coerce el; r <- get_ATele (f t) al; M.ret (existT _ t r) | _, _ => M.raise NoPatternMatches end. Definition get_CTele_raw : forall {isort} (it : ITele isort) (nparams nindx : nat) {A : stype_of isort}, A -> M (CTele it) := fun isort it nparams nindx => mfix rec (A : stype_of isort) : selem_of A -> M (CTele it) := mtmmatch A as A return selem_of A -> M (CTele it) with | [? B (F : B -> isort)] ForAll F =u> fun f => M.nu (FreshFrom F) mNone (fun b : B => let t := reduce (RedWhd RedAll) (App f b) in r <- rec (F b) t; f' <- abs b r; M.ret (cProd f')) | A =n> fun a => let A_red := reduce RedHNF A in (* why the reduction here? *) args <- args_of_max (nparams+nindx) (Dyn A_red); atele <- get_ATele it (mrev args); a' <- @M.coerce _ (ITele_App atele) a ; M.ret (cBase atele a') end. Definition get_CTele := fun {isort} => match isort as sort return forall {it : ITele sort} nparams nindx {A : sort}, A -> M (CTele it) with | Propₛ => get_CTele_raw (isort := Propₛ) | Typeₛ => get_CTele_raw (isort := Typeₛ) end. Definition get_NDCTele_raw : forall {isort} (it : ITele isort) (nindx : nat) {A : stype_of isort}, selem_of A -> M (NDCTele it) := fun isort it nindx => mfix rec (A : isort) : A -> M (NDCTele it) := mtmmatch A as A return selem_of A -> M (NDCTele it) with | [? B (F : B -> isort)] ForAll F =u> fun f => M.nu (FreshFrom F) mNone (fun b : B => r <- rec (F b) (App f b); let '(existT _ l F) := r in r' <- (M.abs_fun b F) : M (B -> _); M.ret (existT (NDCfold _) (B:m:l) (fun '(m: b,y) => r' b y)) ) | A =n> fun a => let A_red := reduce RedHNF A in (* why the reduction here? *) args <- args_of_max nindx (Dyn A_red); atele <- get_ATele it args; a' <- @M.coerce _ (ITele_App atele) a ; M.ret (existT _ [m:] (fun _ => existT _ atele a')) end. Definition get_NDCTele := fun {isort} => match isort as sort return forall {it : ITele sort} nindx {A : sort}, A -> M (NDCTele it) with | Propₛ => get_NDCTele_raw (isort := Propₛ) | Typeₛ => get_NDCTele_raw (isort := Typeₛ) end. (** Given a goal, it returns its sorted version *) Program Definition sort_goal {T : Type} : T -> M (sigT stype_of) := mtmmatch T as T return T -> M (sigT stype_of) with | Prop =u> fun A_Prop => M.ret (existT stype_of Propₛ A_Prop) | Type =u> fun A_Type => M.ret (existT stype_of Typeₛ A_Type) end. (* Definition sget_ITele (sort : Sort) : forall {T : sort} (ind : T), M (nat * ITele sort) := *) (* mfix f (T : stype_of sort) : forall (ind : T), M (nat * ITele sort)%type := *) (* mtmmatch T as T return selem_of T -> M (nat * ITele sort) with *) (* | [? (A : Type) (F : A -> stype_of sort)] forall a, F a =u> *) (* fun indFun => *) (* name <- M.fresh_binder_name F; *) (* M.nu name mNone (fun a : A => *) (* r <- f (F a) (indFun a); *) (* let (n, it) := r in *) (* f <- abs a it; *) (* M.ret (S n, iTele f)) *) (* | stype_of sort =n> *) (* fun indProp => *) (* M.ret (0, iBase (sort := sort) indProp) *) (* end. *) Definition get_ITele : forall {T : Type} (ind : T), M (nat *m (sigT ITele)) := mfix f (T : _) : T -> M (nat *m sigT ITele)%type := mtmmatch T as T return T -> M (nat *m sigT ITele)%type with | [? (A : Type) (F : A -> Type)] forall a, F a =m> fun indFun => M.nu (FreshFrom T) mNone (fun a : A => r <- f (F a) (indFun a); let (n, sit) := r in let (sort, it) := sit in f <- abs a it; M.ret (m: S n, existT _ sort (iTele f))) | Prop =m> fun indProp => M.ret (m: 0, existT _ Propₛ (iBase (sort := Propₛ) indProp)) | Type =m> fun indType => M.ret (m: 0, existT _ (Typeₛ) (iBase (sort := Typeₛ) indType)) | Set =m> fun indType => M.ret (m: 0, existT _ (Typeₛ) (iBase (sort := Typeₛ) indType)) | T =n> fun _=> M.failwith "Impossible ITele" end. Fixpoint compute_params (ind : dyn) {s} (i : ITele s) : M (mlist dyn) := match i with | iBase _ => M.ret mnil | iTele f => dcase ind as _, ind in '(m: ind, arg) <- M.decompose ind; arg <- M.coerce arg; rec <- compute_params (Dyn ind) (f arg); M.ret (Dyn arg :m: rec) end. Fixpoint compute_ATele_from_rev_params {s} (i : ITele s) (l : mlist dyn) {struct l} : M (ATele i) := match i as i, l return M (ATele i) with | iBase _, mnil => M.ret tt | iTele f, arg :m: l => arg <- M.coerce arg; rec <- compute_ATele_from_rev_params (f arg) l; M.ret (existT _ arg rec) | _, _ => M.failwith "bug" end. Require Import Mtac2.lib.Specif. Definition apply_arg {s} (i : ITele s) : forall (a : ATele i), msigT (ATele) := match i with | iBase s => fun args => mexistT ATele (iBase s) args | iTele f => fun '(existT _ a args) => mexistT ATele (f a) args end. Fixpoint apply_args {s} (i : ITele s) (a : ATele i) (n : nat) : msigT ATele := match n with | 0 => mexistT ATele i a | S n => let '(mexistT _ it args) := apply_arg i a in apply_args it args n end. Definition ITele_App_eq {s} {i : ITele s} : forall (a : ATele i), ITele_App a = ITele_App (mprojT2 (apply_arg i a)) := match i with | iBase _ => fun _ => eq_refl | iTele f => fun '(existT _ _ _) => eq_refl end. Definition apply_param_constr {s} {i : ITele s} : forall (a : ATele i) (c : CTele i), M (CTele (mprojT1 (apply_arg i a))) := match i as i return forall (a : ATele i) (c : CTele i), M (CTele (mprojT1 (apply_arg i a))) with | iBase _ => fun _ c => M.ret c | iTele f => fun '(existT _ arg args as at1) => (fix go first (c : CTele (iTele f)) : M (CTele (f arg)) := match c , first with | cBase (existT _ arg' args' as at2) app, false => mmatch arg as arg return M (CTele (f arg)) with | arg' =u> let app := match eq_sym (ITele_App_eq (i:=iTele f) at2) in _ = x return x with | eq_refl => app end in M.ret (cBase args' app) end | cBase _ _, true => M.failwith "constructor takes no more arguments." | cProd F, true => let A := _ in let B := _ in arg <- @M.coerce A B arg; c <- go false (F arg); M.ret c | cProd F, false => \nu x, c <- go false (F x); c <- M.abs_fun x c; M.ret (cProd c) end) true end. Fixpoint apply_params_constrs {s} {i : ITele s} (n : nat) : forall (args : ATele i) (cs : mlist (CTele i)), M (mlist (CTele (mprojT1 (apply_args i args n)))) := let P := (fun i : ITele s => ATele i *m mlist (CTele i)) in match n, i as i return forall (args : ATele i) (cs : mlist (CTele i)), M (mlist (CTele (mprojT1 (apply_args i args n)))) with | 0, _ => fun a cs => M.ret cs | S m, iTele f => fun '(existT _ a args as args') cs => cs <- M.map (apply_param_constr (i:=iTele f) args') cs; apply_params_constrs m _ cs | S m, iBase _ => fun _ _ => M.failwith "Reached iBase but am supposed to apply more parameters" end . Obligation Tactic := idtac. Program Definition get_ind (A : Type) : M (nat *m nat *m sigT (fun s => (ITele s)) *m mlist dyn) := '(mkInd_dyn indP nparams nindx constrs) <- M.constrs A; dcase indP as el in sortit <- get_ITele el : M (nat *m sigT ITele); let (isort, it) := msnd sortit in M.ret (m: BinNat.N.to_nat nparams, BinNat.N.to_nat nindx, existT _ _ it, constrs). (* Compute ind type ATele *) Definition get_ind_atele {isort} (it : ITele isort) (nparams nindx : nat) (A : Type) : M (ATele it) := arglist <- args_of_max (nparams + nindx) (Dyn A) : M (mlist dyn); atele <- get_ATele it (mrev arglist) : M (ATele it); M.ret atele. Import TacticsBase.T.notations. Definition new_destruct {A : Type} (n : A) : tactic := \tactic g => '(m: nparams, nindx, (existT _ isort it), constrs) <- get_ind A; (* let (nsortit, constrs) := ind in *) (* let (nindx, sortit) := nsortit in *) (* let (isort, it) := sortit in *) atele <- get_ind_atele it nparams nindx A; (* Compute CTeles *) cts <- M.map (fun c_dyn : dyn => dcase c_dyn as dtype, delem in ty <- M.evar (stype_of isort); b <- M.cumul UniCoq ty dtype; if b then el <- M.evar ty; M.cumul_or_fail UniCoq el delem;; get_CTele it nparams nindx ty el else M.failwith "Couldn't unify the type of the inductive with the type of the constructor" ) constrs; (* Compute return type RTele *) cts <- apply_params_constrs nparams atele cts; let it := mprojT1 (apply_args it atele nparams) in let atele := mprojT2 (apply_args _ atele nparams) in gt <- M.goal_type g; rsG <- sort_goal gt; let (rsort, sG) := rsG in n' <- M.coerce n; rt <- abstract_goal sG atele n'; let sg := reduce RedSimpl (mmap ( fun ct => (selem_of (branch_of_CTele rt ct)) ) cts) in goals <- M.map (fun ty=> r <- M.evar ty; M.ret (Metavar Typeₛ _ r)) sg; (*FIX: Typeₛ is not right *) branches <- M.map M.goal_to_dyn goals; let tsg := reduce RedHNF (type_of sg) in (*FIX: these reductions should be smarter *) let rrf := reduce RedSimpl (RTele_Fun rt) in let rrt := reduce RedSimpl (RTele_Type rt) in let type := reduce RedHNF (type_of n') in caseterm <- M.makecase {| case_ind := type; case_val := n'; case_return := Dyn rrf; case_branches := branches |}; (let '(Metavar s _ ge) := g in M.unify_or_fail UniCoq caseterm (Dyn ge);; M.ret tt );; M.map (fun (g : goal gs_open) => match g with | (Metavar _ _ g) => M.ret (m: tt, (AnyMetavar _ _ g)) end ) goals. Mtac2-1.4-coq8.20/theories/ideas/Pre-typedtactics.v000066400000000000000000000205211472011217100217320ustar00rootroot00000000000000From Mtac2 Require Import Base Datatypes List MTele MTeleMatch MTeleMatchDef MFixDef Sorts tactics.Tactics. Require Import Strings.String. Import Sorts. Import Mtac2.lib.List.ListNotations. Import ProdNotations. Import Tactics.T. Import M. Import M.notations. Set Universe Polymorphism. Unset Universe Minimization ToSet. Local Inductive msigT {A} (P : A -> Type) : Type := | mexistT x : P x -> msigT P. Local Notation "'{$' x .. y & P }" := (msigT (fun x => .. (msigT (fun y => P)) .. )) (x binder, y binder). Local Definition mprojT1 {A} {P} : @msigT A P -> A := fun '(mexistT _ x _) => x. Local Definition mprojT2 {A} {P} : forall s : @msigT A P, P (mprojT1 s) := fun '(mexistT _ _ p) => p. Local Inductive TTele : Type := | ttbase (X : Type) : TTele | tttele {X} : (X -> TTele) -> TTele. Fixpoint TTele_ty (M : Type -> Type) t := match t with | ttbase X => M X | tttele F => forall x, TTele_ty M (F x) end. Local Fixpoint TTele_bind {X} {t} : (X -> TTele_ty M t) -> (TTele_ty M.t t) := match t with | ttbase X => M.bind (M.evar _) | tttele F => fun f (t : _) => @TTele_bind X (F t) (fun x : X => f x t) end . Local Fixpoint func_of (l : mlist Prop) := match l with | mnil => True | mcons T l => prod T (func_of l) end. Local Notation "x -*> y" := (prod (func_of x) y) (only parsing, at level 91). Local Notation tty := (TTele_ty (fun T => msigT (fun l => M (l -*> T)))). Local Fixpoint TTele_bind' {X : Prop} (x : X) {t} : (TTele_ty (fun T => msigT (fun l => X -> M (l -*> T))) t) -> (tty t) := match t with | ttbase B => fun '(mexistT _ l f) => mexistT _ (X :m: l) ( H <- M.evar X; '(goals, R) <- f H; M.ret ((H,goals), R)) | tttele F => fun f t => TTele_bind' x (f t) end . Definition lift_lemma : forall (A : Prop), A -> M (msigT tty) := let m := (mTele (fun (A : Prop) => (mTele (fun (a:A) => mBase)))) in @mfix' m (fun A (a:A) => msigT tty) (fun rec (A : Prop) => let m (A : Prop) := mTele (fun a:A => mBase) in mtmmatch' _ m (fun A a => msigT tty) A [m: (mtptele (fun B:Prop => mtptele (fun (C:Prop) => (mtpbase ( m:=fun A:Prop => A -> M _)) _ ( fun (f : B -> C) => M.nu (FreshFrom A) mNone (fun b : B => '(mexistT _ t X) <- rec C (f b); match t as t return tty t -> M (_) with | tttele _ => fun _ => M.failwith "Lemma to be lifted has dependent quantifiers after non-dependent ones. This is not supported." | ttbase P => fun f => let '(mexistT _ l f) := f in f' <- M.abs_fun b f; f' <- M.coerce f'; let T' := reduce (RedWhd RedAll) (TTele_bind' b (t0:=ttbase _) (mexistT _ l f')) in M.ret (mexistT tty (ttbase P) T') end X ) ) UniMatchNoRed)))%mtpattern | (mtptele (fun B:Type => mtptele (fun (C:B -> Prop) => (mtpbase ( m:=fun A:Prop => A -> M _)) _ ( fun (f : forall b:B, C b) => M.nu (FreshFrom A) mNone (fun b : B => '(mexistT _ t X) <- rec _ (f b); t' <- M.abs_fun b t; X <- M.coerce X; X' <- M.abs_fun (P:=fun b => tty (t' b)) b X; M.ret (mexistT tty (tttele t') (fun x => X' x)) ) ) UniMatchNoRed)))%mtpattern | (mtpbase ( m:=fun A:Prop => A -> M _) A (fun a:A => M.ret (mexistT tty (ttbase A) (mexistT _ mnil (M.ret (I,a)))) ) UniCoq )%mtpattern ]%with_mtpattern ) . Local Fixpoint TTele_App {P1} {t} (P2 : forall T (H : P1 T), Type) : TTele_ty P1 t -> Type := match t with | ttbase P => fun x => P2 _ x | tttele F => fun g => forall x, TTele_App P2 (g x) end. Local Fixpoint TTele_app {P1} {t} P2 (f : forall T PT, P2 T PT) : forall tt, TTele_App (P1:=P1) (t:=t) P2 tt := match t with | ttbase T => fun tt : P1 T => f _ _ | tttele F => fun (tt : forall t, TTele_ty P1 (F t)) t => @TTele_app _ (F t) _ f (tt t) end. Definition do_def n {A:Prop} (a:A) := '(mexistT _ t f) <- lift_lemma A (a); (* let f := reduce (RedStrong [rl: RedBeta; RedZeta; RedFix; RedMatch; RedDeltaOnly [rl: Dyn (@M.type_of); Dyn (@TTele_ty)] ]) (f) in *) let x := reduce (RedStrong [rl: RedFix; RedMatch; RedBeta; RedDeltaOnly [rl: Dyn (@TTele_app)]]) (TTele_app (fun T PT => let '(mexistT _ l _) := PT in M (l -*> T)) (fun T PT => let '(mexistT _ l X) := PT in X ) f) in let T := reduce (RedStrong [rl: RedBeta; RedZeta; RedFix; RedMatch; RedDeltaOnly [rl: Dyn (@M.type_of); Dyn (@TTele_ty); Dyn (@TTele_App); Dyn (@TTele_app); Dyn (@func_of)] ]) (M.type_of x) in @M.declare dok_Definition n false T x;; M.ret tt. (** We use a synonim to prod to emulate typed goals. The idea *) (* is that at the left we have the hypotheses, and at the right *) (* the goal type. A goal H1, ..., Hn |- G is then written *) (* (H1 * ... * Hn) =m> G *) (* A lemma lifted to this type will produce an element of type G given *) (* promises (evars) for H1, ..., Hn. *) (* *) Definition myprod := prod. Arguments myprod _%type _%type. Notation "T1 '|m-' G" := (myprod T1 G) (at level 98, no associativity, format "T1 |m- G") : type_scope. (** composes on the left of the arrow *) Definition compl {A} {B} (f: M (A |m- B)) (g : M A) : M B := '(a, b) <- f; a' <- g; mif unify a a' UniCoq then ret b else failwith "nope". (** composes a product *) Definition compi {A} {B} (g : M A) (h : M B) : M (A * B) := g >>= fun xg=> h >>= fun xh => ret (xg, xh). (** Solves goal A provided tactic t *) Definition Mby' {A} (t: tactic) : M A := e <- evar A; l <- t (Goal Typeₛ e); l' <- T.filter_goals l; match l' with mnil => ret e | _ => failwith "couldn't solve" end. Mtac Do New Exception NotAProp. Definition Muse {A} (t: tactic) : M A := mtry P <- evar Prop; of <- unify_univ P A UniMatchNoRed; match of with | mSome f => e <- M.evar P; t (Goal Propₛ e);; let e := reduce (RedOneStep [rl: RedBeta]) (f e) in ret e | mNone => raise NotAProp end with | NotAProp => e <- evar A; t (Goal Typeₛ e);; ret e end. Definition is_prod T := mmatch T with | [? A B] (A * B)%type => ret true | _ => ret false end. Definition dest_pair {T} (x:T) : M (dyn * dyn) := mmatch Dyn x with | [? A B a b] @Dyn (A*B) (a, b) => ret (Dyn a, Dyn b) end. (** Given an element with type of the form (A1 * ... * An), *) (* it generates a goal for each unsolved variable in the pair. *) Program Definition to_goals : forall {A}, A -> M (mlist (unit *m goal)) := mfix2 to_goals (A: Type) (a: A) : M _ := mif is_evar a then ret [m: (m: tt, Goal Typeₛ a)] else mif is_prod A then '(d1, d2) <- dest_pair a; dcase d1 as x in dcase d2 as y in t1s <- to_goals _ x; t2s <- to_goals _ y; ret (t1s +m+ t2s) else ret [m:]. (** From a typed tactic with type A |m- B, it generates an untyped one *) Definition to_tactic {A B} (f: M (A |m- B)) : tactic := fun g=> gT <- goal_type g; mif unify gT B UniCoq then '(a, b) <- f; al <- to_goals a; ls <- T.filter_goals al; T.exact b g;; ret ls else failwith "nope". Definition pass := evar. Arguments pass {_}. Import Strings.Ascii. Local Open Scope string. Definition doTT {A:Prop} (x:A) := s <- pretty_print x; let s := match String.get 0 s with | Some "@"%char => String.substring 1 (String.length s -1) s | _ => s end ++ "T" in print s;; do_def s x. Mtac2-1.4-coq8.20/theories/ideas/README.md000066400000000000000000000002031472011217100175710ustar00rootroot00000000000000This directory contains pieces of code not ready for production, but that are worth keeping to show how to write certain patterns. Mtac2-1.4-coq8.20/theories/ideas/StaticApply.v000066400000000000000000000127101472011217100207440ustar00rootroot00000000000000Require Import Coq.Strings.String. From Mtac2 Require Import Base Logic Datatypes List MFix MTeleMatch. Import M.notations. Import Mtac2.lib.List.ListNotations. Definition funs_of (T : Prop) : mlist Prop -> Prop := fix f l := match l with | [m: ] => T | X :m: l => X -> f l end. (* fun T l => fold_right (fun B X => B -> X) T l. *) Definition args_of : mlist Prop -> Prop := fix f l := match l with | [m: ] => True | X :m: l => (X * f l)%type end. Definition apply_args_of {T} : forall {l}, funs_of T l -> args_of l -> T := fix f l := match l as l return funs_of T l -> args_of l -> T with | [m: ] => fun t _ => t | X :m: l => fun F '(x, a) => f l (F x) a end. (* Compute funs_of (M nat) [m: True | False]. *) Definition funs_bind {T X : Type} : forall {l}, (X -> funs_of (M T) l) -> (M X -> funs_of (M T) l) := fix f l := match l return (X -> funs_of _ l) -> (M X -> funs_of _ l) with | [m:] => fun g mx => M.bind mx g | Y :m: l => fun g mx y => f _ (fun x => g x y) mx end. (* Definition unify_within {T} {X:Prop} (x : X) : *) (* forall l, funs_of (M T) [m: X & l] -> funs_of (M T) [m: X & l] := *) (* fix f l := *) (* match l as l return funs_of _ [m: X & l] -> funs_of _ [m: X & l] with *) (* | nil => fun F x' => M.unify x x' UniEvarconv;; F x' *) (* | [m: Y & l] => fun F x' y => f l (fun x'' => F x'' y) x' *) (* end. *) (* Eval cbn in unify_within (M.ret 2) [m: ] (fun x => M.ret x). *) (* Eval cbn in ltac:(mrun ( *) (* x <- M.evar nat; *) (* unify_within (M.ret x) [m: ] (fun _ => M.ret x) (M.ret 2) *) (* )). *) Record Apply_Args (P T : Type) (t : T) := APPLY_ARGS { apply_type: Type; apply_func: apply_type; }. Definition remove_ret {V} {B} {Q : B -> Type} {A} : forall (v : V) b (m : Q b), (Q b -> M A) -> M A := fun v b m cont => m' <- M.remove v (M.ret m); oe <- M.unify m m' UniMatchNoRed; match oe with | mNone => M.failwith "Impossible branch." | mSome e => match meq_sym e in _ =m= m'' return _ -> M A with | meq_refl => fun cont => cont m' end cont end . Definition apply_type_of (P : Type) : forall {T} (t : T), M (sigT (funs_of (M P))) := mfix f (T : _) : T -> M (sigT (funs_of (M P))) := mtmmatch T as T' return T' -> M (sigT (funs_of (M P))) with | (M P : Type) =c> fun t => M.ret (existT (funs_of (M P)) [m:] t) | [? X F] (forall x : X, F x) =c> fun ft => M.nu (FreshFrom ft) mNone (fun x_nu : X => x <- M.evar X; let F' := reduce (RedOneStep [rl:RedBeta]) (F x) in let f' := reduce (RedOneStep [rl:RedBeta]) (ft x) in r <- f F' f'; mif M.is_evar x then o <- M.unify x_nu x UniEvarconv; let '(existT _ rl rp) := r in rp' <- M.abs_fun x_nu rp; mtry (M.remove x_nu ( let r' : sigT (funs_of (M P)) := existT _ (M X :m: rl) (funs_bind rp') in M.ret r' )) with | [?s] CannotRemoveVar s => let err := (String.append "A hypothesis depends on " s) in M.failwith err end else M.remove x_nu (M.ret r) ) | _ as _catchall => fun _ => M.failwith "The lemma's conclusion does not unify with the goal." end . (* Notation "'[apply_args_mtac' t 'in' P ]" := *) (* ( *) (* (* M.print "bla";; *) *) (* let t' := t in *) (* let P' := P in *) (* r <- apply_type_of P' t'; *) (* (* M.print_term r;; *) *) (* let '(existT _ rl rp) := r in *) (* M.ret (APPLY_ARGS P' _ t' _ rp) *) (* ). *) (* Hint Extern 0 (Apply_Args ?P ?T ?t) => *) (* mrun [apply_args_mtac t in P] : typeclass_instances. *) (* Goal forall x y : nat, Apply_Args (x =m= x) _ (fun x => test_lemma True x y). *) (* intros. *) (* mrun [apply_args_mtac (fun x => test_lemma True x y) in x = x]. *) (* Defined. *) (* Eval vm_compute in Unnamed_thm. *) (* Definition bla x y := Eval vm_compute in @apply_func _ _ _ (Unnamed_thm x y). *) (* (* Notation "'[test' t ]" := (let f := ltac:(mrun t) in ltac:(let e := uconstr:(id f) in exact e)) (at level 0, t at level 11). *) *) (* Notation "'[static_apply' t 'in' P ]" := *) (* ( *) (* let t' := t in (* WHY IS THIS NECESSARY? *) *) (* let F := M.eval [apply_args_mtac t' in P] in *) (* @apply_func _ _ _ F *) (* ) (at level 0, P, t at level 11). *) (* (* Notation "'[bla' t ]" := (let F := ltac:(mrun (M.unify t 1 UniCoq)) in 0 ). *) *) (* Notation "'[bla' t ]" := (let F := ltac:(let t := open_constr:(t) in unify t 1) in True). *) (* Fail Goal [bla _]. *) (* Goal 1=1. *) (* mrun ([static_apply (test_lemma _ _ _) in _=_] (M.ret I) (M.evar (1>0))). *) (* Abort. *) Notation "t '&s>' '[s' t1 ; .. ; tn ]" := ( let t' := t in let r := M.eval (apply_type_of _ t') in let args := M.eval ((* debug true [m:] *) (M.coerce (pair t1 .. (pair tn I) ..))) in apply_args_of (projT2 r) args ) (at level 41, left associativity, format "t &s> [s t1 ; .. ; tn ]" ). (* Definition test_lemma (T : Type) (x y : nat) : T -> y > 0 -> M (x =m= x) := *) (* fun t H => M.print_term (T, x, y, t, H);; M.ret meq_refl. *) (* Goal 1=m=1. *) (* mrun ((test_lemma _ _ _) &s> [s M.ret I ; M.evar (1>0) ]). *) (* auto. *) (* Qed. *) (* Goal 1=m=1. *) (* mrun ( *) (* let f : M(1=1) := *) (* (test_lemma _ _ _) &s> [s M.ret I ; M.evar (1>0) ] in *) (* M.ret eq_refl). *) (* Qed. *) Mtac2-1.4-coq8.20/theories/ideas/SubgoalsStrict.v000066400000000000000000000072671472011217100214720ustar00rootroot00000000000000From Mtac2 Require Import Base Tactics Datatypes List Sorts. Import Sorts.S. Import ListNotations. Set Implicit Arguments. Import ProdNotations. Require Import Strings.String. Set Universe Polymorphism. (** This is a simple example tighting up a bit the types of tactics in order to ensure a property. In this case, we make sure that a variation of `apply` is composed with as many tactics as the number required by the number of hypotheses of the type. *) (** We won't statically check that the tactic isn't cheating. If the tactic produce a different number of subgoals, that is not our problem here. *) (** For that reason, we use the following record instead of a Vector.t: we want to easily embed tactics into ntactics and back. *) Record PackedVec (A: Type) (count: nat) := mkPackedVec { goals : mlist (A *m goal gs_any) }. Definition ntactic A n := goal gs_open -> M (PackedVec A n). Import M. Import M.notations. Coercion n_to_g A n (nt : ntactic A n) : gtactic A := fun g=>pv <- nt g; M.ret pv.(goals). (** For the composition, we can't be generic here: we produce a gtactic out of the composition of an ntactic with nth gtactics. *) Class NSeq (A B : Type) n (nt: ntactic A n) (l: mlist (gtactic B)) (pf: mlength l = n) := nseq : gtactic B. Arguments nseq {A B _} _%tactic _%tactic _ {_}. Import Mtac2.lib.List. #[global] Instance nseq_list {A B} n (nt: ntactic A n) (l: mlist (gtactic B)) pf: NSeq nt l pf := fun g => gs <- nt g; ls <- T.gmap l gs.(goals); let res := dreduce (@mconcat, @mapp) (mconcat ls) in T.filter_goals res. Notation "t1 '&n>' ts" := (nseq t1 ts eq_refl) (at level 41, left associativity) : tactic_scope. Import Datatypes. (** [max_apply t] applies theorem t to the current goal. It generates a subgoal for each non-dependent hypothesis in the theorem. *) Definition max_apply {T} (c : T) : tactic := fun g=> match g with Metavar Typeₛ gT eg => (mfix1 go (d : dyn) : M (mlist (unit *m goal _)) := (* let (_, el) := d in *) (* mif M.unify_cumul el eg UniCoq then M.ret [m:] else *) mmatch d return M (mlist (unit *m goal _)) with | [? T1 T2 f] @Dyn (T1 -> T2) f => e <- M.evar T1; r <- go (Dyn (f e)); M.ret ((m: tt, AnyMetavar Typeₛ _ e) :m: r) | [? T1 T2 f] @Dyn (forall x:T1, T2 x) f => e <- M.evar T1; r <- go (Dyn (f e)); M.ret r | Dyn eg =u> M.ret [m:] | _ => dcase d as ty, el in M.raise (T.CantApply ty gT) end) (Dyn c) | Metavar Propₛ _ _ => M.failwith "It's a prop!" end. Definition count_nondep_binders (T: Type) : M nat := (mfix1 go (T : Type) : M nat := mmatch T return M nat with | [? T1 T2] (T1 -> T2) => r <- go T2; M.ret (S r) | [? T1 T2] (forall x:T1, T2 x) => nu (FreshFromStr "name") mNone (fun e:T1=>go (T2 e)) | _ => M.ret 0 end) T. Definition napply {T} {e: runner (count_nondep_binders T)} (c : T) : ntactic unit (@eval _ _ e) := fun g=> ls <- max_apply c g; M.ret (mkPackedVec (@eval _ _ e) ls). Import TacticsBase.T. Import TacticsBase.T.notations. (* Goal forall P Q, (P -> Q -> P) -> P -> Q -> P. *) (* MProof. *) (* intros P Q H x y. *) (* Fail napply H &n> [m: assumption]. *) (* Fail napply H &n> [m: ]. *) (* pose (T := napply H &n> [m: assumption | assumption]). *) (* T. *) (* Qed. *) (* Goal forall P Q, (P -> Q -> P) -> P -> Q -> P. *) (* MProof. *) (* intros P Q H x. *) (* Fail napply H &n> [m: assumption]. *) (* Fail napply H &n> [m: ]. *) (* pose (tac := napply H &n> [m: assumption | assumption]). *) (* Fail tac. (* ok, we can define the tactic, but it now fails to apply *) *) (* intro y. *) (* tac. *) (* Qed. *) Mtac2-1.4-coq8.20/theories/ideas/SumRun.v000066400000000000000000000035301472011217100177400ustar00rootroot00000000000000From Mtac2 Require Import Mtac2 lib.Datatypes. Module SumRunner. Inductive runner_sum A := | success (a : A) | failure (e : Exception). Arguments success [_] _. Arguments failure [_] _. Set Primitive Projections. Class sum_runner A (f : M.t A) := SR { sum_eval : runner_sum A }. Arguments sum_runner {A} _. Arguments SR {A} _ _. Arguments sum_eval {A} _ {_}. Unset Primitive Projections. End SumRunner. Import SumRunner. #[global] Hint Extern 0 (sum_runner ?f) => (mrun ( mtry (eres <- f; M.ret (SR f (success eres))) with | [?e : Exception] e => M.ret (SR f (failure e)) end )%MC) : typeclass_instances. Notation "'[̇type' T 'OR' Exception ]" := (match _ with | success _ => T | failure _ => Exception end) : type_scope. Notation "'[run' t ]" := ( match sum_eval t as t' return (match t' with | success _ => _ | failure _ => Exception end) with | success a => a | failure e => e end). (* Eval compute in sum_eval (@M.failwith unit ""). *) (* Fail Eval compute in 1 + [run M.failwith (A:=nat) ""]. *) (* Fail Eval compute in 1 + [run M.ret I]. *) (* Eval compute in 1 + [run M.ret 1]. *) Polymorphic Cumulative Structure execV {A} (f : M A) B := ExecV { value : B } . Canonical Structure the_value {A} (f : M A) v := ExecV _ f (lift f v) v. Arguments value {A} f {B} {e}. Global Set Use Unicoq. Notation "'Σ' x .. y , t" := (sigT (fun x => .. (sigT (fun y => t)) ..)) (at level 200, x binder, y binder). (* Definition test {T} (t : T) : M (Σ X (x : X) f, f x = t) := *) (* mmatch T return M (Σ X x f, f x = t) with *) (* | [? X] (X -> T) => _ *) (* end. *) (* Goal True. *) (* refine (let H := _ in let _ : value (M.ret I) =m= H := meq_refl in H). *) (* Qed. *) Notation "'[run' t ]" := (let H := _ in let _ : value t = H := eq_refl in H).Mtac2-1.4-coq8.20/theories/ideas/Transport.v000066400000000000000000000163031472011217100205050ustar00rootroot00000000000000Require Import Coq.Strings.String. From Mtac2 Require Import Base Logic Datatypes List Sorts DepDestruct MTeleMatch. Import Sorts.S. Import M. Import M.notations. Import Mtac2.lib.List.ListNotations. Import Mtac2.lib.Datatypes.ProdNotations. Set Universe Polymorphism. Unset Universe Minimization ToSet. Fixpoint combine {A B} (l : mlist A) (l' : mlist B) {struct l} : mlist (A *m B) := match l with | mnil => mnil | (x :m: tl)%list => match l' with | mnil => mnil | (y :m: tl')%list => ((m: x, y) :m: combine tl tl')%list end end. Definition get_ind_cts (A : Type) (offset : nat) : M (nat * {s : Sort & { it : ITele s & mlist (NDCTele it)}}) := '(m: nparams, nindx, (existT _ isort it), constrs) <- get_ind A; let constrs := mskipn offset constrs in atele <- get_ind_atele it nparams nindx A; (* Compute CTeles *) cts <- M.map (fun c_dyn : dyn => dcase c_dyn as dtype, delem in let ty_c := reduce (RedWhd RedAll) (S.stype_of isort) in ty <- M.evar ty_c; b <- M.cumul UniMatchNoRed ty dtype; if b then let el_c := reduce (RedWhd RedAll) (S.selem_of ty) in el <- M.evar el_c; M.cumul UniMatchNoRed el delem;; get_NDCTele it nindx ty el else M.failwith "Couldn't unify the type of the inductive with the type of the constructor" ) constrs; M.ret (nindx, existT _ _ (existT _ _ cts)). Local Notation lprod l := (mfold_right (fun T b => T *m b)%type unit l). Definition Mnu {A B} (f : A -> M B) (n : name) : M B := (M.nu n mNone f). Local Notation "\fnu x .. z , t" := (M.nu Generate mNone (fun x => .. (M.nu Generate mNone (fun z => t)) ..)) (at level 101, x binder, z binder, right associativity) : M_scope. Local Notation "'\sfnu' s 'for' x .. z , t" := (M.nu (FreshFromStr s) mNone (fun x => .. (M.nu (FreshFromStr s) mNone (fun z => t)) ..)) (at level 101, x binder, z binder). Local Notation "\fnuf x .. z 'for' F , t" := (M.nu (FreshFrom F) mNone (fun x => (* let F := reduce (RedWhd RedAll) F in *) ..( M.nu (FreshFrom F) mNone (fun z => (* let F := reduce (RedWhd RedAll) F in *) t ) ).. ) ) (at level 101, x binder, z binder). Definition stype_type (sort : Sort) (t : stype_of sort) : Type := (selem_of t) : Type. Definition gen_match_branch {T1 T2 X} (recursor : T1 -> M T2) (base : T2 -> M X) := fix f (C1_types C2_types : mlist Type) : forall ndc : (NDCfold (@iBase Typeₛ T1) C1_types), (lprod C2_types -> M X) -> M (branch_of_NDCTele (rsort := Propₛ) (it := @iBase Typeₛ T1) (fun _ => M X) (existT _ C1_types ndc)) := match C1_types as C1_types, C2_types as C2_types return forall ndc : (NDCfold (@iBase Typeₛ T1) C1_types), (lprod C2_types -> M X) -> M (branch_of_NDCTele (rsort := Propₛ) (it := @iBase Typeₛ T1) (fun _ => M X) (existT _ C1_types ndc)) with | mnil, mnil => fun (F1 : unit -> _) (F2 : unit -> _) => let c2 := reduce RedVmCompute (F2 tt) in M.ret c2 | X1:m:C1_types, X2:m:C2_types => mtmmatch (m: X1, X2) as Xs return forall ndc : (NDCfold (@iBase Typeₛ T1) (mfst Xs:m:C1_types)), (lprod (msnd Xs:m:C2_types) -> M X) -> M (branch_of_NDCTele (rsort := Propₛ) (it := @iBase Typeₛ T1) (fun _ => M X) (existT _ (mfst Xs:m:C1_types) ndc)) with | [? A : Type] (m: A, A) =u> fun (F1 : lprod (mfst (m: A,A):m:_) -> _) (F2 : lprod (msnd (m: A,A):m:_) -> M X)=> \fnuf a for F1, pat <- f C1_types C2_types (fun y=> F1 (m: a,y)) (fun lp => F2 (m: a,lp)); M.abs_fun (P:=fun _ => _) a pat | (m: T1, T2) =u> fun (F1 : lprod (mfst (m:T1,T2):m:_) -> _) (F2 : lprod (msnd (m:T1,T2):m:_) -> M X) => \fnuf a for F1, pat <- f C1_types C2_types (fun x=> F1 (m: a,x)) (fun lp => b <- recursor a; F2(m: b,lp)); M.abs_fun (P:=fun _ => _) a pat end | _, _ => fun _ _ => M.failwith "Constructors have different arity." end. Definition gen_match_from_to (T1 T2 : Type) X (offset : nat) : M (forall recursor : T1 -> M T2, forall base : T2 -> M X, T1 -> M X) := i1 <- get_ind_cts T1 O; i2 <- get_ind_cts T2 offset; mmatch (m: i1, i2) with | [?(n1 : nat) (Cs1 : mlist (NDCTele (@iBase Typeₛ T1))) (n2 : nat) (Cs2 : mlist (NDCTele (@iBase Typeₛ T2)))] (m: ((n1, existT _ Typeₛ (existT _ (@iBase Typeₛ T1) Cs1))), ((n2, existT _ Typeₛ (existT _ (@iBase Typeₛ T2) Cs2))) ) => let it1 := @iBase Typeₛ T1 in let it2 := @iBase Typeₛ T2 in (if Nat.eqb (mlength Cs1) (mlength Cs2) then M.ret unit else M.failwith "Number of remaining constructors of T2 does not match that of T1");; (* let Cs1 := reduce RedVmCompute Cs1 in *) (* let Cs2 := reduce RedVmCompute Cs2 in *) let zipped := combine Cs1 Cs2 in \sfnu "recursor" for recursor : T1 -> M T2, \sfnu "base" for base : T2 -> M X, (* Construct MTele *) pats <- M.map (fun Csi => let (Cs1_i, Cs2_i) := Csi : (NDCTele it1) *m NDCTele (it2) in (* M.print_term (Cs1_i, Cs2_i);; *) let c11 := reduce (RedVmCompute) (projT1 Cs1_i) in let c1 := reduce (RedVmCompute) (projT2 Cs1_i) in let c21 := reduce (RedVmCompute) (projT1 Cs2_i) in let c2 := reduce (RedVmCompute) (projT2 Cs2_i) in (* M.print_term c21;; *) t <- gen_match_branch recursor base c11 c21 c1 (fun x => let '(existT _ _ y) := c2 x in base y); M.ret (Dyn t) ) (zipped); (* M.print_term pats;; *) \sfnu "t1" for t1 : T1, c <- M.makecase (mkCase T1 t1 (Dyn (fun _ : T1 => M X)) (pats)); dcase c as T, b in oeq <- M.unify (T) (M X) UniCoq; match oeq return (T) -> M ((T1 -> M T2) -> (T2 -> M X) -> T1 -> M X) with | mSome eq => match eq in _ =m= R return T -> M ((T1 -> M T2) -> (T2 -> M X) -> T1 -> R) with | meq_refl => fun f => (* let f := reduce (RedWhd ([rl:RedMatch;RedBeta;RedDeltaOnly [rl:Dyn (@elem)]])) f in *) (* let ty := reduce (RedWhd ([rl:RedMatch;RedBeta;RedDeltaOnly [rl:Dyn (@type)]])) T in *) let ty := T in (* M.print_term ty;; *) f <- M.abs_fun (P:=fun _ => ty) t1 f; f <- M.abs_fun base f; f <- M.abs_fun recursor f; M.ret (f) end | mNone => fun _ => M.failwith "Impossible branch." end b end . Section Test. Inductive Rnat : Set := | Rmult : Rnat -> Rnat -> Rnat | RO : Rnat | RS : Rnat -> Rnat. Set Printing Universes. Time Definition hl_expr_to_expr_coq {X : Type} : (nat -> M Rnat) -> (Rnat -> M X) -> nat -> M X := fun f b => ltac:(mrun( (gen_match_from_to nat Rnat X 1)) ) f b. End Test. Mtac2-1.4-coq8.20/theories/ideas/non_refl_refl.v000066400000000000000000000204371472011217100213260ustar00rootroot00000000000000From Mtac2 Require Import Base MTele Logic. Import M.notations. Set Universe Polymorphism. Unset Universe Minimization ToSet. From Coq Require Import JMeq. Notation "x =j= y" := (JMeq x y) (at level 70, y at next level, no associativity). Lemma JMeq_types : forall {A B} {x: A} {y: B} (H: x =j= y), A =m= B. Proof. intros. destruct H. reflexivity. Qed. Lemma JMeq_meq : forall {A} (x: A) (y: A) (H: x =j= y), x =m= y. Proof. intros. rewrite H. reflexivity. Qed. (** Given a term [t] of type [T], assumed to be of the form [let x : A := y in t'], with [T] being [let x : A := y in P] (or its let-expanded version), it gets a function [f] and executes [f A x y P meq_refl t' JMeq_refl] under the context extended with [x : A := y]. Assuming it returns value [b], it returns it after checking no harm is done: [x] is not free in [b]. Note that one might tink that it's wrong to return [y] or [P]. However, these terms where well-typed in the original context, so there is no problem. [x] is the only one being added to the context, and the one to care about. *) Definition full_nu_let {T} (n: name) (t: T) {B : Type} (f : forall A (x y: A) P (eqxy: x =m= y) (t': P) (eqP: t =j= t'), M B) : M B. intros. exact M.mkt. Qed. (** Given a variable [x] of type [A], a definition (supposed to be equal) [y], and a term [t] of type [P], it returns a [t'] equals to [t]: [let z : A := y in t{z/x}]. It won't check if [y] is the actual definition, as long it is equal to [x] (that's what [eqxy] says), and assuming [x] is a variable, it should be sound to return the let-binding. The reason why the returned term has the same type as [P] is because [let z:A := y in t{z/x}] has type [P{y/x}] and, since [x =m= y], we get [P{x/x}] which is [P]. *) Definition full_abs_let : forall {A : Type} {P : Type} (x y : A) (eqxy: x=m=y) (t: P), M {t' : P & t =m= t'}. intros. exact M.mkt. Qed. Definition old_nu_let {A B C : Type} (n: name) (blet: C) (f: A -> C -> M B) : M B := full_nu_let n blet (fun A' x y P eqxy t' eqt' => eqAA' <- M.unify_or_fail UniCoq A' A; let x := reduce (RedWhd [rl:RedMatch]) (match eqAA' with meq_refl => x end) in let eqCP := dreduce (@JMeq_types, @meq_sym) (meq_sym (JMeq_types eqt')) in let t' := reduce (RedWhd [rl:RedMatch]) (match eqCP with meq_refl => t' end) in f x t'). Obligation Tactic := simpl; intros. Program Definition let_completeness {B} (term: B) : M {blet : B & blet =m= term} := full_nu_let (TheName "m") term (fun A m d P eqmd body eqP=> body_let <- full_abs_let (P:=P) m d eqmd body; let (blet, jeq) := body_let in M.ret (existT _ _ _ : { blet : _ & blet =m= term})). Next Obligation. apply JMeq_types in eqP. rewrite eqP. exact blet. Defined. Next Obligation. cbv. simpl in jeq. destruct eqmd. destruct (JMeq_types eqP). rewrite eqP. rewrite jeq. reflexivity. Defined. Program Definition let_soundness {A} {P} (x d: A) (term: P) (eqxd : x =m= d) : M {t : P & t =m= term} := letb <- full_abs_let x d eqxd term; let (blet, eq) := letb in full_nu_let (TheName "m") blet (fun B a b T eqab t' eqblet => _). Next Obligation. refine (M.ret (existT _ _ _)). simpl in eq. generalize (JMeq_types eqblet). intro eqPT. generalize t' eqblet. clear t' eqblet. rewrite <- eqPT. intros t' eqblet. rewrite eq. rewrite eqblet. reflexivity. Qed. Print Module M.M. (** Let [T] equals to [forall x:A, B x] and [t] equals to [fun x:A => b], it introduces [x:A] in the context, and executes [f A x B b meq_refl meq_refl], the first [meq_refl] being the equality of types [T =m= forall x:A, B x] and the second of the body, morally [t x =m= b]. The value returned by [f] must not contain [x]. *) Definition dest_fun_type (T C: Type) (t: T): Type. refine ((forall A (x: A) (B: A->Type) (b: B x) (eqTB : T =m= (forall z:A, B z)) (eqt: (_ : (forall z, B z)) x =m= b), M C) -> M C). rewrite eqTB in t. exact t. Defined. Definition dest_fun {T C} t : dest_fun_type T C t. intros; constructor. Qed. Definition abs_fun: forall{A: Type} {P: A->Type} (x: A) (t: P x), M {t': forall x, P x & t' x =m= t}. constructor. Qed. Require Import ssreflect. Lemma equal_f_dep : forall {A B} {f g : forall (x : A), B x}, f =m= g -> forall x, f x =m= g x. Proof. by move=>? ? ? ? ->. Qed. Axiom functional_extensionality_dep : forall {A} {B : A -> Type}, forall (f g : forall x : A, B x), (forall x, f x =m= g x) -> f =m= g. Program Definition fun_completeness {T: Type} (t: T) : M {A:Type & {P:A->Type & {funp : forall x:A, P x & funp =j= t}}} := dest_fun t (fun A x B b eqTB eqt => absf <- abs_fun x b; let (t', eqtb') := absf in M.ret (existT _ A (existT _ B (existT _ t' _)))). Next Obligation. cbv in eqt. rewrite -eqt in eqtb'. move: eqtb'. (* We know that [t' x =m= t' x] but we can't conclude that [t' =m= t]. Informally, this holds because [x] can be substituted by any [y], and then conclude with functional_extensionality_dep. *) Admitted. Axiom forall_extensionality : forall (A : Type) (B C : A -> Type), (forall x : A, B x =m= C x) -> (forall x : A, B x) =m= (forall x : A, C x). Axiom forall_extensionality_domain : forall (A B: Type) (C: A -> Type) (D: B -> Type), (forall x : A, C x) =m= (forall x : B, D x) -> A =m= B. (* this is not true I think *) Axiom forall_extensionality_codomain : forall (A: Type) (C: A -> Type) (D: A -> Type), (forall x, C x) =m= (forall x, D x) -> C =m= D. (* does it make sense? *) Program Definition fun_soundness {A: Type} {P: A->Type} (x: A) (b: P x) : M {b':P x & b' =m= b} := absf <- abs_fun x b; let (funp, feq) := absf in dest_fun funp (fun A' x' B' b' eqPP' eqbb' => M.ret (existT _ _ _ : {b':P x & b' =m= b})). Next Obligation. move/forall_extensionality_domain: (eqPP')=>eqAA'. move: B' x' b' eqPP' eqbb'. rewrite -eqAA'. intros. move/forall_extensionality_codomain: (eqPP')=>eqPB'. move: b' eqPP' eqbb'. rewrite -eqPB'. move=>b' eqPP'. cbv. Admitted. Require Import BinNat. Inductive level := aLevel : N -> level | aVar : N -> level. Inductive sort := sProp | sSet | sType : level -> sort. Definition dest_sort : Type -> M sort. intros. exact M.mkt. Qed. Definition make_sort : sort -> M Type. intros. exact M.mkt. Qed. (* There's nothing we can prove about this *) (** Let's see what we can do with decompose_forallT *) Require Import Mtac2.lib.Datatypes. (* So far it doesn't provide any equality, so we can't prove anything *) Axiom admit : forall P, P. Program Definition forall_complete (T:Type) : M {T':Type & T' =m= T} := M.decompose_forallT (B:=fun _=>{T':Type & T' =m= T}) T (fun A b => M.nu Generate mNone (fun x=> r <- M.abs_prod_type x (b x); M.ret (existT _ r (admit _)) : M {T':Type & T' =m= T})) (M.failwith "error"). Require Import Mtac2. (* but it works *) Goal (forall x, x > 0 : Type) =m= (forall x, x > 0 : Type). MProof. r <- forall_complete (forall x, x > 0); let (x, _) := r in T.exact (meq_refl x). Qed. Import M.notations. (** An [abs_fun] function without generating terms of equalities on the OCaml side *) Definition abs_fun' {A : Type} {P : A -> Type} (x : A) {B : _} (c : P x) : (forall (f : forall x, P x), M (B (f x))) -> M (B c). constructor. Qed. (** The abs_fun from above can be defined in term of this last one: *) Definition abs_fun'' : forall{A: Type} {P: A->Type} (x: A) (c : P x), M {t': forall x, P x & t' x =m= c}. intros. refine (abs_fun' x (B:=fun c => {t' : forall x, P x & t' x =m= c}) _ _). intros. refine (M.ret _). econstructor. reflexivity. Defined. (** Given a function [F : A->Type], it returns [forall x, F x] (and a proof of this equality)*) Definition abs_prod' {A} (F: A->Type) : M {T:Type& T =m= forall x, F x}. constructor. Qed. (** Just for the record, this is how you get the original abs_prod *) Definition abs_prod {A} (x:A) (t: Type) : M Type := f <- M.abs_fun x t; '(existT _ T _) <- abs_prod' f; M.ret T. (** A version of [abs_prod] returning proofs: given [x] and [t], it returns a term [T] and a function [F] such that [T = forall y, F y], and [F x = t]. *) Definition abs_prod_pf {A} (x:A) (t: Type) : M {T & {F & F x =m= t /\ T =m= forall x, F x}}. refine ( '(existT _ f pf) <- abs_fun'' x t; '(existT _ T pfT) <- abs_prod' f; M.ret _). exists T. exists f. split; assumption. Defined. Mtac2-1.4-coq8.20/theories/intf/000077500000000000000000000000001472011217100161725ustar00rootroot00000000000000Mtac2-1.4-coq8.20/theories/intf/Case.v000066400000000000000000000010001472011217100172230ustar00rootroot00000000000000From Coq Require Import BinNums. From Mtac2 Require Import List. From Mtac2.intf Require Import Dyn. Set Universe Polymorphism. Unset Universe Minimization ToSet. Set Polymorphic Inductive Cumulativity. Record Ind_dyn := mkInd_dyn { ind_dyn_ind : dyn; ind_dyn_nparams : N; ind_dyn_nindices : N; ind_dyn_constrs : mlist dyn }. Record Case := mkCase { case_ind : Type; case_val : case_ind; case_return : dyn; case_branches : mlist dyn }.Mtac2-1.4-coq8.20/theories/intf/DeclarationDefs.v000066400000000000000000000007711472011217100214150ustar00rootroot00000000000000Set Universe Polymorphism. Unset Universe Minimization ToSet. (** Lifted from coq 8.6.1 Decl_kinds TODO: auto generate this file to avoid inconsistencies. *) Inductive definition_object_kind : Set := | dok_Definition | dok_Coercion | dok_SubClass | dok_CanonicalStructure | dok_Example | dok_Fixpoint | dok_CoFixpoint | dok_Scheme | dok_StructureComponent | dok_IdentityCoercion | dok_Instance | dok_Method. Inductive implicit_arguments : Set := | ia_Explicit | ia_Implicit | ia_MaximallyImplicit. Mtac2-1.4-coq8.20/theories/intf/Dyn.v000066400000000000000000000015531472011217100171170ustar00rootroot00000000000000Set Universe Polymorphism. Unset Universe Minimization ToSet. (** This module offers two types to encode an element with its type. *) (** The type [dyn] is trivially constructed with [mkdyn], although it's not expected to be used by the user. Instead, the "constructor function" [Dyn] should be used. The reason for this seemingly weird construction is that we want [dyn] to not introduce new universes. In order to inspect an element of type [dyn], we need to resort to the [decompose_app] primitive (which has specific notation for this case, see the [M] module). *) Variant dyn : Prop := mkdyn. Definition Dyn : forall {type : Type} (elem : type), dyn. refine (fun _ _=> mkdyn). Qed. (** [dynr] is a traditional record, and it generates a universe and its restriction. *) Record dynr := Dynr { typer: Type; elemr:> typer }. Arguments Dynr {_} _. Mtac2-1.4-coq8.20/theories/intf/Exceptions.v000066400000000000000000000064071472011217100205110ustar00rootroot00000000000000Require Import Strings.String. From Mtac2.intf Require Import Name. Set Universe Polymorphism. Unset Universe Minimization ToSet. Inductive Exception : Prop := exception : Exception. Definition StuckTerm : Exception. exact exception. Qed. Definition NotAList : Exception. exact exception. Qed. Definition HypsUniverseError : Exception. exact exception. Qed. Definition NotAUnifStrategy : Exception. exact exception. Qed. Definition ReductionFailure : Exception. exact exception. Qed. Definition TermNotGround : Exception. exact exception. Qed. Definition WrongTerm : Exception. exact exception. Qed. Definition HypMissesDependency : Exception. exact exception. Qed. Definition TypeMissesDependency : Exception. exact exception. Qed. Definition DuplicatedVariable : Exception. exact exception. Qed. Definition NotAVar : Exception. exact exception. Qed. Definition NotAForall : Exception. exact exception. Qed. Definition NotAnApplication : Exception. exact exception. Qed. Definition LtacError (s:string) : Exception. exact exception. Qed. Definition NotUnifiable {A} (x y : A) : Exception. exact exception. Qed. Definition Failure (s : string) : Exception. exact exception. Qed. Definition NameExistsInContext (n : Name.name) : Exception. exact exception. Qed. Definition InvalidName (n : Name.name) : Exception. exact exception. Qed. Definition ExceptionNotGround : Exception. exact exception. Qed. Definition CannotRemoveVar (x : string) : Exception. exact exception. Qed. Definition RefNotFound (x : string) : Exception. exact exception. Qed. Definition AbsDependencyError : Exception. exact exception. Qed. Definition AbsVariableIsADefinition : Exception. exact exception. Qed. Definition AbsLetNotConvertible : Exception. exact exception. Qed. Definition VarAppearsInValue : Exception. exact exception. Qed. Definition NotALetIn : Exception. exact exception. Qed. Definition NotTheSameType : Exception. exact exception. Qed. Definition DoesNotMatch : Exception. exact exception. Qed. Definition NoPatternMatches : Exception. exact exception. Qed. Definition Anomaly : Exception. exact exception. Qed. Definition Continue : Exception. exact exception. Qed. Definition NameNotFound (n: string) : Exception. exact exception. Qed. Definition WrongType (T: Type) : Exception. exact exception. Qed. Definition EmptyList : Exception. exact exception. Qed. Definition NotThatManyElements : Exception. exact exception. Qed. Definition CantCoerce : Exception. exact exception. Qed. Definition NotCumul {A B} (x: A) (y: B) : Exception. exact exception. Qed. Definition NotAnEvar {A} (x: A) : Exception. exact exception. Qed. Definition CantInstantiate {A} (x t: A) : Exception. exact exception. Qed. Definition NotAReference {A} (x : A) : Exception. exact exception. Qed. Definition AlreadyDeclared (name : string) : Exception. exact exception. Qed. Definition UnboundVar : Exception. exact exception. Qed. Definition NotAMatchExp : Exception. exact exception. Qed. Definition NotAnInductive : Exception. exact exception. Qed. Definition NoClassInstance (A : Type) : Exception. exact exception. Qed. Definition NotFound : Exception. exact exception. Qed. (* We don't want the user to catch this error: it's someone messing up the invariant that goals are opened. *) Notation NotAGoal := (Failure "Not a Goal"). Mtac2-1.4-coq8.20/theories/intf/Goals.v000066400000000000000000000014771472011217100174370ustar00rootroot00000000000000From Mtac2 Require Import Datatypes Logic intf.Sorts. Import Sorts.S. Set Universe Polymorphism. Unset Universe Minimization ToSet. Set Polymorphic Inductive Cumulativity. Inductive Hyp : Prop := | ahyp : forall {A}, A -> moption A -> Hyp. Inductive goal_state : Set := | gs_open | gs_any. Inductive goal@{U131 U132} : goal_state -> Prop := | Metavar' : forall gs (s : Sort) (A : stype_of@{U131 U132} s), selem_of@{U131 U132} A -> goal gs | AHyp : forall {A : Type@{U132}}, (A -> goal gs_any) -> goal gs_any | HypLet : Type@{U132} -> goal gs_any -> goal gs_any | HypRem : forall {A : Type@{U132}}, A -> goal gs_any -> goal gs_any | HypReplace : forall {A B : Type@{U132}}, A -> meq@{U131} A B -> goal gs_any -> goal gs_any. Notation "'Metavar'" := (Metavar' gs_open). Notation "'AnyMetavar'" := (Metavar' gs_any). Mtac2-1.4-coq8.20/theories/intf/Lift.v000066400000000000000000000003041472011217100172540ustar00rootroot00000000000000From Mtac2.intf Require Import M. Set Universe Polymorphism. Unset Universe Minimization ToSet. (** Execution of tactics at unification *) Polymorphic Definition lift {A} (f: M A) (v : A) := A. Mtac2-1.4-coq8.20/theories/intf/M.v000066400000000000000000001146551472011217100165710ustar00rootroot00000000000000Require Import Strings.String. Require Import NArith.BinNat. From Mtac2 Require Import Logic Datatypes Logic List Utils MTele Pattern Specif. Import ListNotations. Import ProdNotations. From Mtac2.intf Require Export Sorts Exceptions Dyn Reduction Unification DeclarationDefs Goals Case Tm_kind Name. Import Sorts.S. Set Universe Polymorphism. Set Polymorphic Inductive Cumulativity. Unset Universe Minimization ToSet. (** THE definition of the monad *) Unset Printing Notations. Module M. CoInductive t (a : Type) : Prop := mkt : t a. Arguments mkt {_}. Local Ltac make := refine (mkt) || (intro; make). Definition ret : forall {A : Type}, A -> t A. make. Qed. Definition bind : forall {A : Type} {B : Type}, t A -> (A -> t B) -> t B. make. Qed. Definition mtry' : forall {A : Type}, t A -> (Exception -> t A) -> t A. make. Qed. Definition raise' : forall {A : Type}, Exception -> t A. make. Qed. Definition fix1 : forall{A: Type} (B: A->Type), ((forall x: A, t (B x))->(forall x: A, t (B x))) -> forall x: A, t (B x). make. Qed. Definition fix2 : forall {A1: Type} {A2: A1->Type} (B: forall (a1 : A1), A2 a1->Type), ((forall (x1: A1) (x2: A2 x1), t (B x1 x2)) -> (forall (x1: A1) (x2: A2 x1), t (B x1 x2))) -> forall (x1: A1) (x2: A2 x1), t (B x1 x2). make. Qed. Definition fix3 : forall {A1: Type} {A2: A1->Type} {A3 : forall (a1: A1), A2 a1->Type} (B: forall (a1: A1) (a2: A2 a1), A3 a1 a2->Type), ((forall (x1: A1) (x2: A2 x1) (x3: A3 x1 x2), t (B x1 x2 x3)) -> (forall (x1: A1) (x2: A2 x1) (x3: A3 x1 x2), t (B x1 x2 x3))) -> forall (x1: A1) (x2: A2 x1) (x3: A3 x1 x2), t (B x1 x2 x3). make. Qed. Definition fix4 : forall {A1: Type} {A2: A1->Type} {A3: forall (a1: A1), A2 a1->Type} {A4: forall (a1: A1) (a2: A2 a1), A3 a1 a2->Type} (B: forall (a1: A1) (a2: A2 a1) (a3: A3 a1 a2), A4 a1 a2 a3->Type), ((forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2) (x4 : A4 x1 x2 x3), t (B x1 x2 x3 x4)) -> (forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2) (x4 : A4 x1 x2 x3), t (B x1 x2 x3 x4))) -> forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2) (x4 : A4 x1 x2 x3), t (B x1 x2 x3 x4). make. Qed. Definition fix5: forall{A1: Type} {A2: A1->Type} {A3: forall(a1: A1), A2 a1->Type} {A4: forall(a1: A1)(a2: A2 a1), A3 a1 a2->Type} {A5: forall(a1: A1)(a2: A2 a1)(a3: A3 a1 a2), A4 a1 a2 a3->Type} (B: forall(a1: A1)(a2: A2 a1)(a3: A3 a1 a2)(a4: A4 a1 a2 a3), A5 a1 a2 a3 a4->Type), ((forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2) (x4 : A4 x1 x2 x3) (x5 : A5 x1 x2 x3 x4), t (B x1 x2 x3 x4 x5)) -> (forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2) (x4 : A4 x1 x2 x3) (x5 : A5 x1 x2 x3 x4), t (B x1 x2 x3 x4 x5))) -> forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2) (x4 : A4 x1 x2 x3) (x5 : A5 x1 x2 x3 x4), t (B x1 x2 x3 x4 x5). make. Qed. (** [is_var e] returns if [e] is a variable. *) Definition is_var: forall{A : Type}, A->t bool. make. Qed. (* [nu x od f] executes [f x] where variable [x] is added to the local context, optionally with definition [d] with [od = Some d]. It raises [NameExistsInContext] if the name "x" is in the context, or [VarAppearsInValue] if executing [f x] results in a term containing variable [x]. *) Definition nu: forall{A: Type}{B: Type}, name -> moption A -> (A -> t B) -> t B. make. Qed. (* [@nu_let A B C n t f] expects [t] to be [let y : A' := t1 in t2] and executes [f x t2{x/y}], with variable [x := t1] added to the local context. It raises [NotALetIn] if [t] is not a let-in, [NotTheSameType] if [A] is not unifiable with [A'], [NameExistsInContext] if the name "x" is in the context, or [VarAppearsInValue] if executing [f] with the given arguments results in a term containing variable [x]. *) Definition nu_let: forall{A: Type}{B: Type}{C: Type}, name -> C -> (A -> C -> t B) -> t B. make. Qed. (** [abs_fun x e] abstracts variable [x] from [e]. It raises [NotAVar] if [x] is not a variable, or [AbsDependencyError] if [e] or its type [P] depends on a variable also depending on [x]. *) Definition abs_fun: forall{A: Type} {P: A->Type} (x: A), P x -> t (forall x, P x). make. Qed. (** [abs_let x d e] returns [let x := d in e]. It raises [NotAVar] if [x] is not a variable, or [AbsDependencyError] if [e] or its type [P] depends on a variable also depending on [x]. *) Definition abs_let: forall{A: Type} {P: A->Type} (x: A) (y: A), P x -> t (let x := y in P x). make. Qed. (** [abs_prod x e] returns [forall x, e]. It raises [NotAVar] if [x] is not a variable, or [AbsDependencyError] if [e] or its type [P] depends on a variable also depending on [x]. *) Definition abs_prod_type@{a y r + | a <= r, y <= r +} : forall{A: Type@{a}} (x : A), Type@{y} -> t Type@{r}. make. Qed. (** [abs_prod x e] returns [forall x, e]. It raises [NotAVar] if [x] is not a variable, or [AbsDependencyError] if [e] or its type [P] depends on a variable also depending on [x]. *) Definition abs_prod_prop: forall{A: Type} (x : A), Prop -> t Prop. make. Qed. (** [abs_fix f t n] returns [fix f {struct n} := t]. [f]'s type must have n products, that is, be [forall x1, ..., xn, T] *) Definition abs_fix: forall{A: Type}, A -> A -> N -> t A. make. Qed. (** [get_binder_name t] returns the name of variable [x] if: - [t = x], - [t = forall x, P x], - [t = fun x=>b], - [t = let x := d in b]. It raises [WrongTerm] in any other case. *) Definition get_binder_name: forall{A: Type}, A -> t@{Set} string. make. Qed. (** [remove x t] executes [t] in a context without variable [x]. Raises [NotAVar] if [x] is not a variable, and [CannotRemoveVar "x"] if [t] or the environment depends on [x]. *) Definition remove : forall{A: Type} {B: Type}, A -> t B -> t B. make. Qed. (** [gen_evar A ohyps] creates a meta-variable with type [A] and, optionally, in the context resulting from [ohyp]. It might raise [HypMissesDependency] if some variable in [ohyp] is referring to a variable not in the rest of the list (the order matters, and is from new-to-old). For instance, if [H : x > 0], then the context containing [H] and [x] should be given as: [ [ahyp H None; ahyp x None] ] If the type [A] is referring to variables not in the list of hypotheses, it raise [TypeMissesDependency]. If the list contains something that is not a variable, it raises [NotAVar]. If it contains duplicated occurrences of a variable, it raises a [DuplicatedVariable]. *) Definition gen_evar@{a H}: forall(A: Type@{a}), moption@{a} (mlist@{a} Hyp@{H}) -> t A. make. Qed. (** [is_evar e] returns if [e] is a meta-variable. *) Definition is_evar: forall{A: Type}, A -> t bool. make. Qed. (** [hash e n] returns a number smaller than [n] representing a hash of term [e] *) Definition hash: forall{A: Type}, A -> N -> t N. make. Qed. (** [solve_typeclasses] calls type classes resolution. *) Definition solve_typeclasses : t@{Set} unit. make. Qed. (** [print s] prints string [s] to stdout. *) Definition print : string -> t@{Set} unit. make. Qed. (** [pretty_print e] converts term [e] to string. *) Definition pretty_print : forall{A: Type}, A -> t@{Set} string. make. Qed. (** [hyps@{u h}] returns the list of hypotheses if the type of all hypotheses fits within universe [h]. Otherwise, it throws the [HypsUniverseError] exception *) Definition hyps@{u h}: t@{u} (mlist@{u} Hyp@{h}). make. Qed. Definition destcase: forall{A: Type} (a: A), t (Case). make. Qed. (** Given an inductive type A, applied to all its parameters (but not necessarily indices), [constrs] returns a [Ind_dyn] value representing the inductive type: - [ind_dyn_ind]: The unapplied inductive type itself as a [dyn] - [ind_dyn_nparams]: The number of parameters - [ind_dyn_nindices]: The number of indices - [ind_dyn_constrs]: the inductie type's constructors as [dyn]s . *) Definition constrs: forall{A: Type} (a: A), t Ind_dyn. make. Qed. Definition makecase: forall(C: Case), t dyn. make. Qed. (** [unify_cnt u x y ts tf] uses unification strategy [r] to equate [x] and [y]. If unification succeeds, it will run [ts]. Otherwise, if unification fails, [tf] is executed instead. It uses convertibility of universes, meaning that it fails if [x] is [Prop] and [y] is [Type]. If they are both types, it will try to equate its leveles. *) Definition unify_cnt {A: Type} {B: A -> Type} (u:Unification) (x y : A) : t (B y) -> t (B x) -> t (B x). make. Qed. (** [unify_cumul_cnt u A B ts tf] uses unification strategy [u] to cumulatively unify type [A] with type [B]. If successful, it runs [ts (fun a:A=>a)], where the function argument is of type [A->B] and is thus a witness that [A] can be embedded into [B]. Otherwise, if unification fails, [unify_cumul_cnt] runs [tf]. Note that unlike [unfiy_cnt], [unify_cumul_cnt] does not establish convertibility. This means that in general [A] and [B] cannot be used interchangeably when unification succeeds *) Definition unify_cumul_cnt {C : Type} (u:Unification) (A: Type) (B: Type) : ((A->B) -> t C) -> t C -> t C. make. Qed. (** [get_reference s] returns the constant that is reference by s. *) Definition get_reference: string -> t dyn. make. Qed. (** [get_var s] returns the var named after s. *) Definition get_var: string -> t dyn. make. Qed. Definition call_ltac : forall(sort: Sort) {A: sort}, string->mlist dyn -> t (mprod A (mlist (goal gs_any))). make. Qed. Definition list_ltac: t unit. make. Qed. (** [read_line] returns the string from stdin. *) Definition read_line: t@{Set} string. make. Qed. (** [decompose x] decomposes value [x] into a head and a spine of arguments. For instance, [decompose (3 + 3)] returns [(Dyn add, [Dyn 3; Dyn 3])] *) Definition decompose : forall {A: Type}, A -> t (mprod dyn (mlist dyn)). make. Qed. (** [solve_typeclass A] calls type classes resolution for [A] and returns the result or fail. *) Definition solve_typeclass : forall (A:Type), t (moption A). make. Qed. (** [declare dok name opaque t] defines [name] as definition kind [dok] with content [t] and opacity [opaque] *) Definition declare: forall (dok: definition_object_kind) (name: string) (opaque: bool), forall{A : Type}, A -> t A. make. Qed. (** [declare_implicits r l] declares implicit arguments for global reference [r] according to [l] *) Definition declare_implicits: forall {A: Type} (a : A), mlist implicit_arguments -> t unit. make. Qed. (** [os_cmd cmd] executes the command and returns its error number. *) Definition os_cmd: string -> t Z. make. Qed. Definition get_debug_exceptions: t bool. make. Qed. Definition set_debug_exceptions: bool -> t unit. make. Qed. Definition get_trace: t bool. make. Qed. Definition set_trace: bool -> t unit. make. Qed. (** [is_head uni a (h u .. w) (fun x .. z => t)] executes 1. [t[i..k/x..z]] if [a] is [H u' .. w' i .. k] where [u' .. w'] unify with [u .. w] according to the unification stragety [uni] 2. [f] if [a] is any other term or any of [u' .. w'] do not unify with the respective given candidate in [u .. w]. *) Definition is_head : forall {A : Type} {B : A -> Type} {m:MTele} (uni : Unification) (a : A) (C : MTele_ConstT A m) (success : MTele_sort (MTele_ConstMap (si := Typeₛ) Propₛ (T:=A) (fun a => t (B a)) C)) (failure: t (B a)), t (B a). make. Qed. (** [decompose_forallT T (fun A B => t)] executes [t[A'/A, B'/B]] iff T is [forall a : A, B']. *) Definition decompose_forallT : forall {B : Type -> Type} (T : Type) (success : forall (A : Type) (b : A -> Type), t (B (forall a : A, b a))) (failure : t (B T)), t (B T). make. Qed. (** [decompose_forallP T (fun A B => t)] executes [t[A'/A, B'/B]] iff T is [forall a : A, B'] and [B']. This is a specialized version of [decompose_forallT] that makes sure to not insert any casts from [Prop] to [Type]. *) Definition decompose_forallP : forall {B : Prop -> Type} (P : Prop) (success : forall (A : Type) (b : A -> Prop), t (B (forall a : A, b a))) (failure : t (B P)), t (B P). make. Qed. (** [decompose_app'' m (fun A B f x => t)] executes [A' .. x'/A .. x] iff m is [f x] with [f : forall a : A, B a] and [x : A]. *) Definition decompose_app'' : forall {S : forall T, T -> Type} {T : Type} (m : T), (forall A (B : A -> Type) (f : forall a, B a) (a : A), t (S _ (f a))) -> t (S T m). make. Qed. Definition new_timer : forall {A} (a : A), t unit. make. Qed. Definition start_timer : forall {A} (a : A) (reset : bool), t unit. make. Qed. Definition stop_timer : forall {A} (a : A), t unit. make. Qed. Definition reset_timer : forall {A} (a : A), t unit. make. Qed. Definition print_timer : forall {A} (a : A), t unit. make. Qed. (** [kind_of_term t] returns the term kind of t *) Definition kind_of_term: forall{A: Type}, A -> t tm_kind. make. Qed. (** [@replace A B _ x eq t] excecutes [t] in the context resulting from replacing the type [A] of hypothesis [x] with [B], using the [eq] witness of their equality. *) Definition replace {A B C} (x:A) : A =m= B -> t C -> t C. make. Qed. Definition declare_mind (params : MTele) (sigs : mlist (string *m (MTele_ConstT m:{ mt_ind &(MTele_ConstT S.Sort mt_ind)} params))) (constrs : mfold_right (fun '(m: _; ind) acc => MTele_val (curry_sort Typeₛ (fun a' => MTele_Ty (mprojT1 (apply_constT ind a')))) -> acc (* MTele_val (MTele_In Typeₛ (fun a => MTele_Ty (mprojT1 (a.(acc_const) ind)))) -> acc *) )%type ( ( MTele_val (curry_sort Typeₛ (fun a => mfold_right (fun '(m: _; ind) acc => mlist (string *m m:{mt_constr & MTele_ConstT (ArgsOf (mprojT1 (apply_constT ind a))) mt_constr}) *m acc )%type unit sigs ) ) ) ) sigs ) : (* t (mfold_right (fun '(m: _; _; mexistT _ mt_ind T) acc => MTele_val T *m acc)%type unit sigs). *) t unit. make. Qed. Definition existing_instance (name : string) (priority : moption N) (global : bool) : t unit. make. Qed. (* [instantiate_evar e x succ fail] is a specialized variant of [unify] which assumes that [e] is an evar and attempts to instantiate it with [x]. If successful, it runs [succ]. Otherwise it runs [fail]. *) Definition instantiate_evar {A : Type} {P : A -> Type} (e x : A) (succ : t (P x)) (fail : t (P e)) : t (P e). make. Qed. Arguments t _%type. Definition fmap {A:Type} {B:Type} (f : A -> B) (x : t A) : t B := bind x (fun a => ret (f a)). Definition fapp {A:Type} {B:Type} (f : t (A -> B)) (x : t A) : t B := bind f (fun g => fmap g x). Definition Cevar (A : Type) (ctx : mlist Hyp) : t A := gen_evar A (mSome ctx). Definition evar@{a H} (A : Type@{a}) : t A := gen_evar@{a H} A mNone. Set Universe Minimization ToSet. Definition sorted_evar (s: Sort) : forall T : s, t T := match s with | Propₛ => fun T:Prop => M.evar T | Typeₛ => fun T:Type => M.evar T end. Set Printing Universes. Definition unify@{a} {A : Type@{a}} (x y : A) (U : Unification) : t@{a} (moption@{a} (meq@{a} x y)) := unify_cnt@{a a} (A:=A) (B:=fun x => moption@{a} (meq x y)) U x y (ret@{a} (mSome@{a} (@meq_refl _ y))) (ret@{a} mNone@{a}). Definition unify_cumul@{a b+} (A : Type@{a}) (B : Type@{b}) (U : Unification) : t (moption (A->B)) := unify_cumul_cnt U A B (fun f => M.ret (mSome f)) (M.ret mNone). Definition raise {A:Type} (e: Exception): t A := bind get_debug_exceptions (fun b=> if b then bind (pretty_print@{Set} e) (fun s=> bind (print ("raise " ++ s)) (fun _ => raise' e)) else raise' e). Definition failwith {A} (s : string) : t A := raise (Failure s). (* TODO: figure out why this is incompatible with [Minimization ToSet]. (It breaks tests/declare.v.) *) Unset Universe Minimization ToSet. Definition print_term {A} (x : A) : t unit := bind (pretty_print x) (fun s=> print s). Set Universe Minimization ToSet. Definition dbg_term {A} (s: string) (x : A) : t unit := bind (pretty_print x) (fun t=> print (s++t)). Definition decompose_app' {A : Type} {B : A -> Type} {m:MTele} (uni : Unification) (a : A) (C : MTele_ConstT A m) (success : MTele_sort (MTele_ConstMap (si := Typeₛ) Propₛ (T:=A) (fun a => t (B a)) C)) : t (B a) := is_head uni a C success (raise WrongTerm). Declare Scope M_scope. Module monad_notations. Bind Scope M_scope with t. Delimit Scope M_scope with MC. Open Scope M_scope. Notation "r '<-' t1 ';' t2" := (bind t1 (fun r=> t2)) (at level 20, t1 at level 100, t2 at level 200, right associativity, format "'[' r '<-' '[' t1 ; ']' ']' '/' t2 ") : M_scope. Notation "' r '<-' t1 ';' t2" := (bind t1 (fun r=> t2)) (at level 20, r pattern, t1 at level 100, t2 at level 200, right associativity, format "'[' ''' r '<-' '[' t1 ; ']' ']' '/' t2 ") : M_scope. (* Notation "' r1 .. rn '<-' t1 ';' t2" := (bind t1 (fun r1 => .. (fun rn => t2) ..)) *) (* (at level 20, r1 binder, rn binder, t1 at level 100, t2 at level 200, *) (* right associativity, format "'[' ''' r1 .. rn '<-' '[' t1 ; ']' ']' '/' t2 ") : M_scope. *) Notation "` r1 .. rn '<-' t1 ';' t2" := (bind t1 (fun r1 => .. (bind t1 (fun rn => t2)) ..)) (at level 20, r1 binder, rn binder, t1 at level 100, t2 at level 200, right associativity, format "'[' '`' r1 .. rn '<-' '[' t1 ; ']' ']' '/' t2 ") : M_scope. Notation "t1 ';;' t2" := (bind t1 (fun _ => t2)) (at level 100, t2 at level 200, format "'[' '[' t1 ;; ']' ']' '/' t2 ") : M_scope. Notation "f =<< t" := (bind t f) (at level 70, only parsing) : M_scope. Notation "t >>= f" := (bind t f) (at level 70) : M_scope. Infix "<$>" := fmap (at level 61, left associativity) : M_scope. Infix "<*>" := fapp (at level 61, left associativity) : M_scope. Notation "'mif' b 'then' t 'else' u" := (cond <- b; if cond then t else u) (at level 200, format "'[hv' 'mif' '/ ' '[' b ']' '/' 'then' '/ ' '[' t ']' '/' 'else' '/ ' '[' u ']' ']'" ) : M_scope. End monad_notations. Import monad_notations. Local Notation Mpattern A P := (pattern A (fun y => t (P y))). Local Notation Mbranch A P := (branch A (fun y => t (P y))). Definition open_pattern@{a p+} {A : Type@{a}} {P : A -> Type@{p}} {y} (E : Exception) := Eval lazy beta iota match zeta delta [meq_sym] in fix open_pattern (p : Mpattern A P) : t (P y) := match p with | pany f => f y | pbase x f u => bind@{a _} (unify x y u) (fun oeq => match oeq return t (P y) with | mSome eq => (* eq has type x =m= t, but for the pattern we need t = x. *) (* we still want to provide eq_refl though, so we reduce it *) let 'meq_refl := eq in (* For some reason, we need to return the beta-reduction of the pattern, or some tactic fails *) let b := (* reduce (RedWhd [rl:RedBeta]) *) (f) in b | mNone => raise E end) | ptele f => e <- evar@{_ a} _; open_pattern (f e) | psort f => mtry' (open_pattern (f Propₛ)) (fun e => M.unify_cnt (B:=fun _ => (P y)) UniMatchNoRed e E (open_pattern (f Typeₛ)) (raise e) (* oeq <- M.unify e E UniMatchNoRed; *) (* match oeq with *) (* | mSome _ => open_pattern E (f Typeₛ) *) (* | mNone => raise e *) (* end *) ) end. (* We need to be extra careful here to use the provided [y] instead of that provided by the dependent pattern matching (which may be more reduced or otherwise mangled). *) Definition open_branch {A P} (E : Exception) (b : branch A (fun a => t (P a))) : forall y, t (P y) := Eval lazy beta zeta iota delta [internal_meq_rew open_pattern] in match b in branch A' P' return forall (P_old : A' -> Type), P' =m= (fun a => t (P_old a)) -> forall y, t (P_old y) with | @branch_pattern A P p => fun P_old Peq z => let op := @open_pattern _ P_old z E in ltac:(rewrite Peq in p; refine (op p)) | @branch_app_static A B m U _ cont => fun P_old Peq z => let op := is_head (B:=P_old) U z _ in ltac:(rewrite Peq in cont; refine (op cont (raise E))) | branch_forallT cont => fun P_old Peq z => let op := decompose_forallT z in ltac:(rewrite Peq in cont; refine (op cont (raise E))) | branch_forallP cont => fun P_old Peq z => let op := decompose_forallP z in ltac:(rewrite Peq in cont; refine (op cont (raise E))) (* | _ => fun _ _ => M.failwith "not implemented" *) end P meq_refl. (* The first universe of the [branch] could be shared with [A] but somehow that makes our iris case study slower in a reproducible way. *) Definition mmatch''@{a p+} {A:Type@{a}} {P: A -> Type@{p}} (E : Exception) (y : A) (failure : t (P y)) := Eval lazy beta zeta iota delta [open_branch] in fix mmatch'' (ps : mlist@{Set} (Mbranch A P)) : t (P y) := match ps with | [m:] => failure | p :m: ps' => mtry' (open_branch E p y) (fun e => is_head (B:=fun e => P y) (m := mBase) UniMatchNoRed E e (mmatch'' ps') (raise e)) (* TODO: don't abuse is_head for this. *) end. Definition mmatch' {A:Type} {P: A -> Type} (E : Exception) (ps : mlist (Mbranch A P)) (y : A) : t (P y) := Eval lazy beta zeta iota delta [mmatch''] in mmatch'' E y (raise NoPatternMatches) ps. Definition NotCaught : Exception. constructor. Qed. Module Matcher. Canonical Structure M_Predicate {A} {P : A -> Type} {y : A} : Predicate := PREDICATE (t (P y)). Canonical Structure M_Matcher {A} {y} {P} := @MATCHER A (@M_Predicate _ _) (t (P y)) (fun E ps => @mmatch' A P E ps y). Canonical Structure M_InDepMatcher {B} := INDEPMATCHER (t B) (fun A y E ps => @mmatch' A (fun _ => B) E ps y). End Matcher. Export Matcher. Module notations_pre. Export monad_notations. (* We cannot make this notation recursive, so we loose notation in favor of naming. *) Notation "'\nu' x , a" := ( let f := fun x => a in nu (FreshFrom f) mNone f) (at level 200, x ident, a at level 200, right associativity) : M_scope. Notation "'\nu' x : A , a" := ( let f := fun x:A=>a in nu (FreshFrom f) mNone f) (at level 200, x ident, a at level 200, right associativity) : M_scope. Notation "'\nu' x := t , a" := ( let f := fun x => a in nu (FreshFrom f) (mSome t) f) (at level 200, x ident, a at level 200, right associativity) : M_scope. Notation "'mfix1' f x .. y : 'M' T := b" := (fix1 (fun x => .. (fun y => T%type) ..) (fun f x => .. (fun y => b) ..)) (at level 200, f ident, x binder, y binder, b at level 200, format "'[v ' 'mfix1' f x .. y ':' 'M' T ':=' '/' '[' b ']' ']'") : M_scope. Notation "'mfix2' f x .. y : 'M' T := b" := (fix2 (fun x => .. (fun y => T%type) ..) (fun f x => .. (fun y => b) ..)) (at level 200, f ident, x binder, y binder, format "'[v ' 'mfix2' f x .. y ':' 'M' T ':=' '/' '[' b ']' ']'") : M_scope. Notation "'mfix3' f x .. y : 'M' T := b" := (fix3 (fun x => .. (fun y => T%type) ..) (fun f x => .. (fun y => b) ..)) (at level 200, f ident, x binder, y binder, format "'[v ' 'mfix3' f x .. y ':' 'M' T ':=' '/' '[' b ']' ']'") : M_scope. Notation "'mfix4' f x .. y : 'M' T := b" := (fix4 (fun x => .. (fun y => T%type) ..) (fun f x => .. (fun y => b) ..)) (at level 200, f ident, x binder, y binder, format "'[v ' 'mfix4' f x .. y ':' 'M' T ':=' '/' '[' b ']' ']'") : M_scope. Notation "'mfix5' f x .. y : 'M' T := b" := (fix5 (fun x => .. (fun y => T%type) ..) (fun f x => .. (fun y => b) ..)) (at level 200, f ident, x binder, y binder, format "'[v ' 'mfix5' f x .. y ':' 'M' T ':=' '/' '[' b ']' ']'") : M_scope. Notation "'mtry' a 'with' ls 'end'" := (mtry' a (fun e => (@mmatch'' _ (fun _ => _) NotCaught e (raise e) ls))) (at level 200, a at level 100, ls custom Mtac2_with_branch at level 91, format "'[hv' 'mtry' '/ ' '[' a ']' '/' 'with' '/' ls '/' 'end' ']'" ) : M_scope. Import TeleNotation. Notation "'dcase' v 'with' A 'as' x 'in' t" := (@M.decompose_app' _ (fun _ => _) [tele (_:A)] UniCoq v (@Dyn A) (fun x => t)) (at level 91, t at level 200) : M_scope. Notation "'dcase' v 'as' A ',' x 'in' t" := (@M.decompose_app' _ (fun _ => _) [tele A (_:A)] UniMatchNoRed v (@Dyn) (fun A x => t)) (at level 91, t at level 200) : M_scope. Notation "'dcase' v 'as' x 'in' t" := (dcase v as _ , x in t) (at level 91, t at level 200) : M_scope. End notations_pre. Import notations_pre. (* Utilities for lists *) Definition map {A B} (f : A -> t B) := mfix1 rec (l : mlist A) : M (mlist B) := match l with | [m:] => ret [m:] | x :m: xs => mcons <$> f x <*> rec xs end. Fixpoint mapi' (n : nat) {A B} (f : nat -> A -> t B) (l: mlist A) : t (mlist B) := match l with | [m:] => ret [m:] | x :m: xs => mcons <$> f n x <*> mapi' (S n) f xs end. Definition mapi := @mapi' 0. Arguments mapi {_ _} _ _. Definition find {A} (b : A -> t bool) : mlist A -> t (moption A) := fix f l := match l with | [m:] => ret mNone | x :m: xs => mif b x then ret (mSome x) else f xs end. Definition filter {A} (b : A -> t bool) : mlist A -> t (mlist A) := fix f l := match l with | [m:] => ret [m:] | x :m: xs => mif b x then mcons x <$> f xs else f xs end. Definition hd {A} (l : mlist A) : t A := match l with | a :m: _ => ret a | _ => raise EmptyList end. Fixpoint last {A} (l : mlist A) : t A := match l with | [m:a] => ret a | _ :m: s => last s | _ => raise EmptyList end. Definition fold_right {A B} (f : B -> A -> t A) (x : A) : mlist B -> t A := fix loop l := match l with | [m:] => ret x | x :m: xs => f x =<< loop xs end. Definition fold_left {A B} (f : A -> B -> t A) : mlist B -> A -> t A := fix loop l (a : A) := match l with | [m:] => ret a | b :m: bs => loop bs =<< f a b end. Definition index_of {A} (f : A -> t bool) (l : mlist A) : t (moption nat) := '(m: _, r) <- fold_left (fun '(m: i, r) x => match r with | mSome _ => ret (m: i,r) | _ => mif f x then ret (m: i, mSome i) else ret (m: S i, mNone) end ) l (m: 0, mNone); ret r. Fixpoint nth {A} (n : nat) (l : mlist A) : t A := match n, l with | 0, a :m: _ => ret a | S n, _ :m: s => nth n s | _, _ => raise NotThatManyElements end. Definition iterate {A} (f : A -> t unit) : mlist A -> t unit := fix loop l := match l with | [m:] => ret tt | b :m: bs => f b;; loop bs end. (** More utilitie *) Unset Printing Universes. Definition mwith {A B} (c : A) (n : string) (v : B) : t dyn := (mfix1 app (d : dyn) : M _ := dcase d as ty, el in mmatch d return t dyn with | [? T1 T2 f] @Dyn (forall x:T1, T2 x) f => let ty := reduce (RedWhd [rl:RedBeta]) ty in binder <- get_binder_name ty; mif unify binder n UniMatchNoRed then oeq' <- unify B T1 UniCoq; match oeq' with | mSome eq' => let v' := reduce (RedWhd [rl:RedMatch]) match eq' as x in _ =m= x with meq_refl=> v end in ret (Dyn (f v')) | _ => raise (WrongType T1) end else e <- evar T1; app (Dyn (f e)) | _ => raise (NameNotFound n) end ) (Dyn c). Definition type_of {A} (x : A) : Type := A. Definition type_inside {A} (x : t A) : Type := A. (** Unifies [x] with [y] and raises [NotUnifiable] if it they are not unifiable. *) Definition unify_or_fail {A} (u : Unification) (x y : A) : t (x =m= y) := oeq <- unify x y u; match oeq with | mNone => raise (NotUnifiable x y) | mSome eq => ret eq end. (** Cumulatively unifies [x] with [y] and raises [NotUnifiable] if it they are not unifiable. *) Definition unify_cumul_or_fail {A} (u : Unification) (x y : A) : t (x =m= y) := oeq <- unify x y u; match oeq with | mNone => raise (NotUnifiable x y) | mSome eq => ret eq end. Definition cumul {A B} (u : Unification) (x: A) (y: B) : t bool := of <- unify_cumul A B u; match of with | mSome f => let fx := reduce (RedOneStep [rl:RedBeta]) (f x) in oeq <- unify fx y u; match oeq with mSome _ => ret true | mNone => ret false end | mNone => ret false end. (* [y] is the evar *) Definition inst_cumul {A B} (u : Unification) (x: A) (y: B) : t bool := of <- unify_cumul A B u; match of with | mSome f => let fx := reduce (RedOneStep [rl:RedBeta]) (f x) in instantiate_evar y fx (M.ret true) (M.ret false) | mNone => ret false end. (** Unifies [x] with [y] using cumulativity and raises [NotCumul] if it they are not unifiable. *) Definition cumul_or_fail {A B} (u : Unification) (x: A) (y: B) : t unit := mif cumul u x y then ret tt else raise (NotCumul x y). Definition inst_cumul_or_fail {A B} (u : Unification) (x: A) (y: B) : t unit := mif inst_cumul u x y then ret tt else raise (NotCumul x y). Definition names_of_hyp : t (mlist string) := env <- hyps; mfold_left (fun (ns : t (mlist string)) '(ahyp var _) => fmap mcons (get_binder_name var) <*> ns) env (ret [m:]). Definition hyps_except {A} (x : A) : t (mlist Hyp) := filter (fun y => mmatch y with | [? b] ahyp x b => M.ret false | _ => ret true end) =<< M.hyps. Definition find_hyp_index {A} (x : A) : t (moption nat) := index_of (fun y => mmatch y with | [? b] ahyp x b => M.ret true | _ => ret false end) =<< M.hyps. Definition find_hyp {A:Type} : mlist Hyp -> t A := mfix1 f (l : mlist Hyp) : M A := match l with | (@ahyp A' x d) :m: l' => ou <- unify A' A UniEvarconv; match ou return t A with | mSome e => match e in _ =m= x return t x with meq_refl => M.ret x end | mNone => f l' end | _ => M.raise NotFound end. Definition select (T: Type) : t T := hyps >>= find_hyp. (** given a string s it appends a marker to avoid collition with user provided names *) Definition anonymize (s : string) : t string := let s' := rcbv ("__" ++ s)%string in ret s'. Definition def_binder_name {A:Type} (x : A) : t string := mtry' (get_binder_name x) (fun _ => ret "x"%string). Fixpoint string_rev_app (s1 s2 : string) := match s1 with | EmptyString => s2 | String c s1 => string_rev_app s1 (String c s2) end. Definition string_rev s := string_rev_app s EmptyString. (* string_rev_flatten: takes a list of reversed strings and computes the string that consists of the unreversed strings. *) Fixpoint string_rev_flatten (ss : mlist string) := match ss with | [m:] => EmptyString | s :m: ss => string_rev_app s (string_rev_flatten ss) end. Definition fail_strs (l : mlist dyn) : M.t string := fix2 (fun _ _ => string) (fun go l (acc : mlist string) => match l with | [m: ] => let r := reduce (RedVmCompute) (string_rev (string_rev_flatten acc)) in M.ret r | D :m: l => mmatch D with | [? s] @Dyn string s => (* let r := reduce (RedVmCompute) (string_rev s) in *) go l (s :m: acc) | _ => dcase D as t in s <- M.pretty_print t; (* let r := reduce (RedVmCompute) (string_rev s) in *) go l (s :m: acc) end end) l [m:]. Module notations. Export notations_pre. Local Definition bind_nu {A B C} (F : A) (a : B -> t C) := M.nu (FreshFrom F) mNone a. (* Fresh names. This notation is declared recursive to allow optional type annotations but it only works for a single binder *) Notation "'\nu_f' 'for' F 'as' x .. z , a " := ( bind_nu F (fun x => .. (bind_nu F (fun z => a)) .. ) ) (at level 200, a at level 200, x binder, z binder). Local Definition bind_nu_rec {A} {B : A -> Type} {C} (a : forall x : A, B x -> t C) (F : forall x : A, B x) := M.nu (FreshFrom F) mNone (fun x : A => let F := reduce (RedOneStep [rl: RedBeta]) (F x) in a x F). (* Fresh names _m_irroring the shape of the [F]'s type. The names will only be related to [F]'s binder names if [F] is syntactically equal to [fun x .. z => ..]. Otherwise, the reduction strategy will not reduce the term far enough for the next call to [fresh_binder_name] to find the correct name. This notation is let-expanded because Coq's notation mechanism is unable to recognize it as [() F]. *) Notation "'\nu_m' 'for' F 'as' x .. z , a " := ( let t := (bind_nu_rec (fun x => .. (bind_nu_rec (fun z => fun _ => a)) .. )) in t F ) (at level 200, a at level 200, x binder, z binder). Notation "'\nu_M' 'for' F 'as' x .. z ; f , a " := ( let t := (bind_nu_rec (fun x => .. (bind_nu_rec (fun z => fun f => a)) .. )) in t F ) (at level 200, a at level 200, x binder, z binder). (* This `fail` notation mirrors Ltac's `fail` notation, with one exception: no automagic spaces are inserted between the arguments. *) Notation "'mfail' s1 .. sn" := ((fail_strs (mcons (Dyn s1) .. (mcons (Dyn sn) mnil) ..)) >>= M.failwith) (at level 0, s1 at next level, sn at next level) : M_scope. End notations. Definition unfold_projection {A} (y : A) : t A := let x := reduce (RedOneStep [rl:RedDelta]) y in let x := reduce (RedWhd [rl:RedBeta;RedMatch]) x in ret x. (** [coerce x] coreces element [x] of type [A] into an element of type [B], assuming [A] and [B] are unifiable. It raises [CantCoerce] if it fails. *) Definition coerce {A B : Type} (x : A) : t B := oH <- unify A B UniCoq; match oH with | mSome H => match H with meq_refl => ret x end | _ => raise CantCoerce end. Definition is_prop_or_type (d : dyn) : t bool := mmatch d with | Dyn Prop => ret true | Dyn Type => ret true | _ => ret false end. (** [goal_type g] extracts the type of the goal. *) Definition goal_type (g : goal gs_open) : t Type := match g with | Metavar s A x => match s as s return stype_of s -> t Type with | Propₛ => fun A => ret (A:Type) | Typeₛ => fun A => ret A end A end. (** [goal_prop g] extracts the prop of the goal or raises [CantCoerce] its type can't be cast to a Prop. *) Definition goal_prop (g : goal gs_open) : t Prop := match g with | Metavar s A _ => match s as s return forall A:stype_of s, t Prop with | Propₛ => fun A:Prop => ret A | Typeₛ => fun A:Type => gP <- evar Prop; mtry cumul_or_fail UniMatch gP A;; ret gP with _ => raise CantCoerce end (* its better to raise CantCoerce than NotCumul *) end A end. (** Convertion functions from [dyn] to [goal]. *) Definition dyn_to_goal (d : dyn) : t (goal gs_open) := mmatch d with | [? (A:Prop) x] @Dyn A x => ret (Metavar Propₛ A x) | [? (A:Type) x] @Dyn A x => ret (Metavar Typeₛ A x) end. Definition goal_to_dyn (g : goal gs_open) : t dyn := match g with | Metavar _ _ d => ret (Dyn d) end. Definition cprint {A} (s : string) (c : A) : t unit := x <- pretty_print c; let s := reduce RedNF (s ++ x)%string in print s. (** Printing of a goal *) Definition print_hyp (a : Hyp) : t unit := let (A, x, ot) := a in sA <- pretty_print A; sx <- pretty_print x; match ot with | mSome t => st <- pretty_print t; M.print (sx ++ " := " ++ st ++ " : " ++ sA) | mNone => print (sx ++ " : " ++ sA) end. Definition print_hyps : t unit := l <- hyps; let l := mrev' l in iterate print_hyp l. Definition print_goal (g : goal gs_open) : t unit := let repeat c := (fix repeat s n := match n with | 0 => s | S n => repeat (c++s)%string n end) ""%string in sg <- match g with | Metavar _ G _ => pretty_print G end; let sep := repeat "="%string 20 in print_hyps;; print sep;; print sg;; ret tt. Definition inst_evar {A} (x y : A) : t (moption (x =m= y)) := instantiate_evar (P:=fun t => moption (t =m= y)) x y (M.ret (mSome meq_refl)) (M.ret mNone). (** [instantiate x t] tries to instantiate meta-variable [x] with [t]. It fails with [NotAnEvar] if [x] is not a meta-variable (applied to a spine), or [CantInstantiate] if it fails to find a suitable instantiation. [t] is beta-reduced to avoid false dependencies. *) Definition instantiate {A} (x y : A) : t unit := '(m: h, _) <- decompose x; dcase h as e in mif is_evar e then let t := reduce (RedWhd [rl:RedBeta]) t in r <- inst_evar x y; match r with | mSome _ => M.ret tt | _ => raise (CantInstantiate x y) end else raise (NotAnEvar h) . Definition solve_typeclass_or_fail (A : Type) : t A := x <- solve_typeclass A; match x with mSome a => M.ret a | mNone => raise (NoClassInstance A) end. (** Collects obviously visible evars *) Definition collect_evars {A} (x: A) := res <- (mfix1 f (d: dyn) : M (mlist dyn) := dcase d as e in mif M.is_evar e then M.ret [m: d] else let e := reduce (RedWhd [rl: RedBeta; RedMatch; RedZeta]) e in '(m: h, l) <- M.decompose e; if is_empty l then M.ret [m:] else f h >>= fun d => M.map f l >>= fun ds => M.ret (mapp d (mconcat ds)) ) (Dyn x); let red := dreduce (@mapp, @mconcat) res in ret red. (** Query functions *) Definition isVar {A} (x: A) := kind_of_term x >>= fun k=> match k with | tmVar => ret true | _ => ret false end. Definition isEvar {A} (x: A) := kind_of_term x >>= fun k=> match k with | tmEvar => ret true | _ => ret false end. Definition isConst {A} (x: A) := kind_of_term x >>= fun k=> match k with | tmConst => ret true | _ => ret false end. Definition isConstruct {A} (x: A) := kind_of_term x >>= fun k=> match k with | tmConstruct => ret true | _ => ret false end. Definition isApp {A} (x: A) := kind_of_term x >>= fun k=> match k with | tmApp => ret true | _ => ret false end. Definition isLambda {A} (x: A) := kind_of_term x >>= fun k=> match k with | tmLambda => ret true | _ => ret false end. Definition isProd {A} (x: A) := kind_of_term x >>= fun k=> match k with | tmProd => ret true | _ => ret false end. Definition isCast {A} (x: A) := kind_of_term x >>= fun k=> match k with | tmCast => ret true | _ => ret false end. Definition isSort {A} (x: A) := kind_of_term x >>= fun k=> match k with | tmSort => ret true | _ => ret false end. Definition isCase {A} (x: A) := kind_of_term x >>= fun k=> match k with | tmCase => ret true | _ => ret false end. Definition bunify {A} (x y: A) (u: Unification) : t bool := mif unify x y u then ret true else ret false. End M. Export M.Matcher. Notation M := M.t. Mtac2-1.4-coq8.20/theories/intf/MTele.v000066400000000000000000000215511472011217100173730ustar00rootroot00000000000000From Mtac2 Require Import Sorts Specif. Import Sorts.S. Set Universe Polymorphism. Unset Universe Minimization ToSet. Set Polymorphic Inductive Cumulativity. Set Printing Coercions. (* Set Printing Universes. *) (** MTele: a telescope which represent nested binder This will be used to represent legal types of patterns and fixpoints. *) Inductive MTele : Type := | mBase : MTele | mTele {X : Type} (F : X -> MTele) : MTele . (** MTele_Const : A constant (i.e. binder independent) type-level interpretation of MTele. It constructs `∀ x .. z, T`. *) Fixpoint MTele_Const {s : Sort} (T : s) (n : MTele) : s := match n with | mBase => T | mTele F => ForAll (fun x => MTele_Const T (F x)) end. Definition MTele_ConstP (T : Prop) (n : MTele) : Prop := @MTele_Const Propₛ T n. Definition MTele_ConstT (T : Type) (n : MTele) : Type := @MTele_Const Typeₛ T n. Fixpoint MTele_const {s : Sort} {T : s} {n : MTele} : @MTele_Const s T n -> stype_of s := match n return MTele_Const T n -> _ with | mBase => fun _ => T | mTele F => fun C => ForAll (fun x => MTele_const (App C x)) end. Definition MTele_constP {T : Prop} {n} : MTele_ConstP T n -> Prop := @MTele_const Propₛ T n. Definition MTele_constT {T : Type} {n} : MTele_ConstT T n -> Type := @MTele_const Typeₛ T n. (** MTele_Sort: compute `∀ x .. z, Type` from a given MTele *) Definition MTele_Sort (s : Sort) (n : MTele) : Type := MTele_ConstT (stype_of s) n. Fixpoint MTele_Sort' (s : Sort) (n : MTele) : Type := match n with | mBase => stype_of s | mTele F => forall x, MTele_Sort' s (F x) end. (* Lemma MTele_Sort_eq s n : MTele_Sort s n -> MTele_Sort' s n. *) (* Proof. induction n. intros H. exact H. intros H x. apply X0. apply H. Qed. *) (* Lemma MTele_Sort_eq' s n : MTele_Sort' s n -> MTele_Sort s n. *) (* Proof. induction n. intros H. exact H. cbn. intros H x. apply X0. apply H. Qed. *) Definition MTele_Ty := (MTele_Sort Typeₛ). Definition MTele_Pr := (MTele_Sort Propₛ). (* Definition MTele_sort {s : Sort} {n : MTele} : MTele_Sort s n -> Type := @MTele_constT _ n. *) Fixpoint MTele_sort {s : Sort} {n : MTele} : forall S : MTele_Sort s n, Type := match n return MTele_Sort s n -> _ with | mBase => fun S => selem_of S | mTele F => fun S => forall x, MTele_sort (S x) end. (** Register MTele_ty as a coercion so that we can pretend any `MTele` is a type. *) (* Coercion MTele_Ty : MTele >-> Sortclass. *) (** MTele_val: compute `λ x .. z, T x .. z` from `T : MTele_ty n` *) Fixpoint MTele_val {s} {n : MTele} : MTele_Sort s n -> s := match n as n return MTele_Sort s n -> s with | mBase => fun f => f | mTele F => fun f => ForAll (fun x => MTele_val (f x)) end. Definition MTele_valT {n} : MTele_Ty n -> Type := MTele_val (s := Typeₛ) (n:=n). (* ltac:( *) (* let e := constr:(MTele_val (s := Typeₛ) (n:=n)) in *) (* let e := (eval red in e) in *) (* let e := (eval cbv match beta delta [ForAll stype_of] in e) in *) (* let e := (eval fold MTele_Ty in e) in *) (* exact e). *) Definition MTele_valP {n} : MTele_Pr n -> Prop := MTele_val (s := Propₛ) (n:=n). (* Coercion MTele_valT : MTele_Ty >-> Sortclass. *) (** Currying and Uncurrying for Telescope Types and Functions *) Fixpoint ArgsOf (m : MTele) : Type := match m with | mBase => unit | mTele f => msigT (fun x => ArgsOf (f x)) end. Fixpoint apply_const {s : Sort} {m : MTele} {T : s} : MTele_Const T m -> ArgsOf m -> T := match m with | mBase => fun t _ => t | mTele f => fun t '(mexistT _ x U) => apply_const (App t x) U end. Definition apply_constT {m : MTele} {T : Typeₛ} := @apply_const Typeₛ m T. Definition apply_constP {m : MTele} {T : Prop} := @apply_const Propₛ m T. Definition apply_sort {s : Sort} {m : MTele} : MTele_Sort s m -> ArgsOf m -> stype_of s := @apply_const Typeₛ m (stype_of s). Fixpoint apply_val {s : Sort} {m : MTele} : forall {T : MTele_Sort s m} (v : MTele_val T) (a : ArgsOf m), apply_sort T a := match m with | mBase => fun _ v _ => v | mTele f => fun _ v '(mexistT _ x U) => apply_val (App v x) U end. Fixpoint curry_const {s : Sort} {m : MTele} {T : s} : (ArgsOf m -> T) -> MTele_Const T m := match m with | mBase => fun f => f tt | mTele F => fun f => Fun (fun x => curry_const (fun a => f (mexistT (fun x => ArgsOf _) x a))) end. Definition curry_sort (s : Sort) {m : MTele} : _ -> MTele_Sort s m := @curry_const Typeₛ m (stype_of s). Fixpoint curry_val {s : Sort} {m : MTele} : forall {T : MTele_Sort s m}, (forall a: ArgsOf m, apply_sort T a) -> MTele_val T := match m with | mBase => fun T f => f tt | mTele F => fun T f => Fun (fun x => curry_val (fun a => f (mexistT _ _ _))) end. (** Convert a MTele_Const `C : ∀ x .. z, T` into a dependently-typed telescope type `∀ x .. z, C x .. z` *) Fixpoint MTele_ConstSort {s : Sort} {n : MTele} : forall {T : s} (C : MTele_Const T n), MTele_Sort s n := match n with | mBase => fun T _ => T | mTele F => fun _ C t => MTele_ConstSort (App C t) end. (** MTele_To: recursively apply the given functor G to binders and return B at the base. MTele_Sort and MTele_val could be instances of this if we were to wrap ∀ and λ in definitions. *) Fixpoint MTele_To {s : Sort} (B : s) (G: forall X, (X -> s) -> s) (n : MTele) : s := match n as n return s with | mBase => B | mTele F => G _ (fun x => MTele_To B G (F x)) end. Fixpoint MTele_to {s : Sort} {B : s} {G: forall X, (X -> s) -> s} {n : MTele} (b : B) (g : forall X F, G X F) : MTele_To B G n := match n as n return MTele_To B G n with | mBase => b | mTele F => g _ _ end. (* Fixpoint MTele_ConstMap {si : Sort} (so : Sort) {n : MTele} {T : si} (G : T -> so) : forall (C : MTele_Const T n), MTele_Sort so n := *) (* match n with *) (* | mBase => fun C => G C *) (* | mTele F => fun C t => MTele_ConstMap so G (App C t) *) (* end. *) Definition MTele_ConstMap {si : Sort} (so : Sort) {n : MTele} {T : si} (G : T -> so) : forall (C : MTele_Const T n), MTele_Sort so n := fun C => curry_sort so (fun a => G (apply_const C a)). Fixpoint MTele_constmap_app {si : Sort} (so : Sort) {n : MTele} {T : si} {A : Type} (G : T -> A -> so) {struct n} : forall (C : MTele_Const T n), MTele_sort (@MTele_ConstMap si so n T ((fun x => ForAll (fun a => G x a))) C) -> forall a : A, MTele_sort (@MTele_ConstMap si so n T (fun x => G x a) C) := match n with | mBase => fun C f a => App f a | mTele F => fun C f a t => MTele_constmap_app _ _ _ (f _) a end. Fixpoint apply_ConstMap {si so : Sort} {n : MTele} {T : si} {G : T -> so} : forall {C : MTele_Const T n} (v : MTele_val (MTele_ConstMap so G C)), forall a : ArgsOf n, G (apply_const C a) := match n with | mBase => fun T v a => v | mTele F => fun T v '(mexistT _ x a) => apply_ConstMap (App v x) a end. Fixpoint curry_ConstMap {si so : Sort} {n : MTele} {T : si} {G : T -> so} : forall {C : MTele_Const T n}, (forall a, G (apply_const C a)) -> MTele_val (MTele_ConstMap so G C) := match n with | mBase => fun T f => f tt | mTele F => fun T f => Fun (fun x => curry_ConstMap (fun a => f (mexistT _ _ _))) end. (** MTele_C: MTele_map with a constant function *) Definition MTele_C (s so : Sort) {n : MTele} : (s -> so) -> MTele_Sort s n -> MTele_Sort so n := fun G T => MTele_ConstMap (si:=Typeₛ) (T:=stype_of s) so G T. Fixpoint MTele_c (s so : Sort) {n : MTele} : forall (G : s -> so) (g : ForAll G) (T : MTele_Sort s n), MTele_val T -> MTele_val (MTele_C _ _ G T) := match n with | mBase => fun G g T v => App g _ | mTele F => fun G g T v => Fun (fun x => MTele_c s so G g (T x) (App v x)) end. Definition apply_C {s : Sort} (so : Sort) {n : MTele} {G : s -> so} {T : MTele_Sort s n} : MTele_val (MTele_C _ so G T) -> forall a : ArgsOf n, G (apply_sort T a) := apply_ConstMap. Definition curry_C {s : Sort} (so : Sort) {n : MTele} {G : s -> so} {T : MTele_Sort s n} : (forall a, G (apply_sort T a)) -> MTele_val (MTele_C s so G T) := curry_ConstMap. (* Old MTele functions redefined on top of the more general newer ones above *) Definition MTele_ty (M : Type -> Prop) {n : MTele} : forall A : MTele_Ty n, Prop := fun A => MTele_val (MTele_C Typeₛ Propₛ M A). Notation MT_Acc R T := (forall (M' : Type -> Prop), MTele_ty M' T -> M' R). (* MTele_open: old telescope accessor *) Fixpoint MTele_open (M : Type -> Prop) {X : Type -> Prop} {m}: forall (T : MTele_Ty m), (forall R, MT_Acc R T -> X R) -> MTele_ty X T := match m as m' return forall T : MTele_Ty m', (forall R, MT_Acc R T -> X R) -> MTele_ty X T with | mBase => fun T b => b _ (fun X x => x) | mTele F => fun T b x => MTele_open M (T x) (fun R f => b R (fun M' mR => f M' (mR x))) end. Module TeleNotation. Notation "'[tele' x .. z ]" := (mTele (fun x => .. (mTele (fun z => mBase)) ..)) (x binder, z binder, format "[tele '[hv' x .. z ']' ]"). Notation "'[tele' ]" := (mBase). End TeleNotation. Mtac2-1.4-coq8.20/theories/intf/Name.v000066400000000000000000000011101472011217100172320ustar00rootroot00000000000000Require Import Strings.String. Set Universe Polymorphism. Unset Universe Minimization ToSet. (** [TheName s] introduces a name strictly (there can't be another one with the same name in the context). [FreshFrom x] uses [get_binder_name x] to generate a name, and then ensures it's fresh. If [get_binder_name] fails, it generates a new name (Never fails). [FreshFromStr s] takes string s and generates a fresh name. [Generate] Generates a fresh name. *) Inductive name := TheName (n: string) | FreshFrom {A} (b: A) | FreshFromStr (n: string) | Generate.Mtac2-1.4-coq8.20/theories/intf/Reduction.v000066400000000000000000000025461472011217100203240ustar00rootroot00000000000000From Coq Require Import String. From Mtac2.intf Require Import Dyn. Set Universe Polymorphism. Unset Universe Minimization ToSet. Monomorphic Inductive redlist A := rlnil | rlcons : A -> redlist A -> redlist A. Arguments rlnil {_}. Arguments rlcons {_} _ _. Notation "[rl: ]" := rlnil. Notation "[rl: x ; .. ; y ]" := (rlcons x (.. (rlcons y rlnil) ..)). Monomorphic Inductive RedFlags : Set := | RedBeta | RedDelta | RedMatch | RedFix | RedZeta | RedDeltaC | RedDeltaX | RedDeltaOnly : redlist dyn -> RedFlags | RedDeltaBut : redlist dyn -> RedFlags. Monomorphic Inductive Reduction : Set := | RedNone | RedSimpl | RedOneStep : redlist RedFlags -> Reduction | RedWhd : redlist RedFlags -> Reduction | RedStrong : redlist RedFlags -> Reduction | RedVmCompute | RedReduction : string -> Reduction. (* Reduction primitive. It throws [NotAList] if the list of flags is not a list. *) Definition reduce (r : Reduction) {A:Type} (x : A) := x. Notation RedAll := ([rl:RedBeta;RedDelta;RedZeta;RedMatch;RedFix]). Notation RedNF := (RedStrong RedAll). Notation RedHNF := (RedWhd RedAll). Notation rsimpl := (reduce RedSimpl). Notation rhnf := (reduce RedHNF). Notation rcbv := (reduce RedNF). Notation "'dreduce' ( l1 , .. , ln )" := (reduce (RedStrong [rl:RedBeta; RedFix; RedMatch; RedDeltaOnly (rlcons (Dyn l1) ( .. (rlcons (Dyn ln) rlnil) ..))])) (at level 0). Mtac2-1.4-coq8.20/theories/intf/Sorts.v000066400000000000000000000067071472011217100175050ustar00rootroot00000000000000Set Universe Polymorphism. Unset Universe Minimization ToSet. (** Types that can hold either a [Prop] or a [Type] *) Set Universe Polymorphism. Unset Universe Minimization ToSet. Reserved Notation "'Typeₛ'". Reserved Notation "'Propₛ'". Module S. Monomorphic Inductive Sort : Set := Prop_sort | Type_sort. Notation "'Typeₛ'" := Type_sort. Notation "'Propₛ'" := Prop_sort. (** Creates a fresh type according to [s] *) Definition stype_of (s : Sort) : Type := match s with Typeₛ => Type | Propₛ => Prop end. Arguments stype_of !_ : simpl nomatch. (** When working with a sort [s], we cannot simply say "we have an element of [stype_of s]". For that, we make [selem_of T], where [T] is a [stype_of s]. *) Definition selem_of@{i j+} {s : Sort} : stype_of@{i j} s -> Type@{j} := match s return stype_of s -> Type@{j} with | Typeₛ => fun x => x | Propₛ => fun x => x end. Arguments selem_of {!_} _ : simpl nomatch. Fail Local Example CannotMakeAnElementOfaSort s (P : stype_of s) (x : P) := x. Local Example WeCanWithElemOf s (P : stype_of s) (x : selem_of P) := x. Definition selem_lift {s : Sort} : @selem_of Typeₛ (stype_of s) -> Type := match s as s' return @selem_of Typeₛ (stype_of s') -> Type with | Typeₛ => fun x => x | Propₛ => fun y => y end. Definition ForAll {sort : Sort} {A : Type} : (A -> stype_of sort) -> stype_of sort := match sort as sort' return ((A -> stype_of sort') -> stype_of sort') with | Propₛ => fun F => forall a : A, F a | Typeₛ => fun F => forall a : A, F a end. Definition Impl {sort : Sort} A (B : stype_of sort) : stype_of sort := ForAll (sort := sort) (fun _ : A => B). Definition Fun {sort} {A : Type} : forall {F : A -> stype_of sort}, (forall a, selem_of (F a)) -> selem_of (ForAll F) := match sort as sort' return forall {F : A -> stype_of sort'}, (forall a, selem_of (F a)) -> selem_of (ForAll F) with | Propₛ => fun _ f => f | Typeₛ => fun _ f => f end. Definition App {sort} {A : Type} : forall {F : A -> _}, selem_of (ForAll (sort := sort) F) -> forall a, selem_of (F a) := match sort as sort' return forall F, selem_of (ForAll (sort := sort') F) -> forall a, selem_of (F a) with | Propₛ => fun F f a => f a | Typeₛ => fun F f a => f a end. Definition Impl_lift {sort} {A : Type} : forall {B : stype_of sort}, (A -> selem_of B) -> selem_of (Impl A B) := match sort with | Propₛ => fun B f => f | Typeₛ => fun B f => f end. Definition lift_Impl {sort} {A : Type} : forall {B : stype_of sort}, selem_of (Impl A B) -> (A -> selem_of B) := match sort with | Propₛ => fun B f => f | Typeₛ => fun B f => f end. End S. Import S. Declare Scope Sort_scope. Delimit Scope Sort_scope with sort. Notation "'Typeₛ'" := Type_sort. Notation "'Propₛ'" := Prop_sort. Notation "'forallₛ' x .. y , T" := (ForAll (fun x => .. (fun y => T) ..)) (at level 200, x binder, y binder) : Sort_scope. Notation "∀ₛ x .. y , T" := (ForAll (fun x => .. (fun y => T) ..)) (at level 200, x binder, y binder). Notation "S ->ₛ T" := (∀ₛ _ : S, T)%sort (at level 200) : Sort_scope. Notation "'funₛ' x .. y => t" := (Fun (fun x => .. (fun y => t) ..)) (at level 200, x binder, y binder) : Sort_scope. Notation "'λₛ' x .. y , t" := (Fun (fun x => .. (fun y => t) ..)) (at level 200, x binder, y binder) : Sort_scope. Coercion stype_of : Sort >-> Sortclass. Coercion selem_of : stype_of >-> Sortclass. Mtac2-1.4-coq8.20/theories/intf/Tm_kind.v000066400000000000000000000002661472011217100177520ustar00rootroot00000000000000Inductive tm_kind := | tmVar | tmEvar | tmSort | tmConst | tmConstruct | tmProd | tmLambda | tmLetIn | tmApp | tmCast | tmInd | tmCase | tmFix | tmCoFix. Mtac2-1.4-coq8.20/theories/intf/Unification.v000066400000000000000000000003101472011217100206230ustar00rootroot00000000000000Set Universe Polymorphism. Unset Universe Minimization ToSet. Inductive Unification : Set := | UniCoq : Unification | UniMatch : Unification | UniMatchNoRed : Unification | UniEvarconv : Unification.Mtac2-1.4-coq8.20/theories/lib/000077500000000000000000000000001472011217100160005ustar00rootroot00000000000000Mtac2-1.4-coq8.20/theories/lib/Datatypes.v000066400000000000000000000076701472011217100201370ustar00rootroot00000000000000(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* moption A | mNone : moption A. Arguments mSome {A} a. Arguments mNone {A}. Definition moption_map (A B:Type) (f:A->B) (o : moption A) : moption B := match o with | mSome a => @mSome B (f a) | mNone => @mNone B end. (* (** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *) *) (* Inductive sum (A B:Type) : Type := *) (* | inl : A -> sum A B *) (* | inr : B -> sum A B. *) (* Notation "x + y" := (sum x y) : type_scope. *) (* Arguments inl {A B} _ , [A] B _. *) (* Arguments inr {A B} _ , A [B] _. *) (* (** [prod A B], written [A * B], is the product of [A] and [B]; *) (* the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *) *) Inductive mprod (A B:Type) : Type := mpair : A -> B -> mprod A B. (* Add Printing Let prod. *) Module ProdNotations. Infix "*m" := (mprod) (at level 40) : type_scope. Notation "(m: x , y , .. , z )" := (mpair .. (mpair x y) .. z) : core_scope. Notation "(m: x ; .. ; y ; z )" := (mpair x .. (mpair y z) ..) : core_scope. End ProdNotations. Arguments mpair {A B} _ _. Section projections. Import ProdNotations. Context {A : Type} {B : Type}. Definition mfst (p:A *m B) := match p with | (m: x, y) => x end. Definition msnd (p:A *m B) := match p with | (m: x, y) => y end. End projections. (* Hint Resolve pair inl inr: core. *) (* Lemma surjective_pairing : *) (* forall (A B:Type) (p:A * B), p = pair (fst p) (snd p). *) (* Proof. *) (* destruct p; reflexivity. *) (* Qed. *) (* Lemma injective_projections : *) (* forall (A B:Type) (p1 p2:A * B), *) (* fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2. *) (* Proof. *) (* destruct p1; destruct p2; simpl; intros Hfst Hsnd. *) (* rewrite Hfst; rewrite Hsnd; reflexivity. *) (* Qed. *) (* Definition prod_uncurry (A B C:Type) (f:prod A B -> C) *) (* (x:A) (y:B) : C := f (pair x y). *) (* Definition prod_curry (A B C:Type) (f:A -> B -> C) *) (* (p:prod A B) : C := match p with *) (* | pair x y => f x y *) (* end. *) (** Polymorphic lists and some operations *) Cumulative Inductive mlist (A : Type) : Type := | mnil : mlist A | mcons : A -> mlist A -> mlist A. Arguments mnil {A}. Arguments mcons & {A} a l. Declare Scope mlist_scope. Infix ":m:" := mcons (at level 60, right associativity) : mlist_scope. Delimit Scope mlist_scope with mlist. Bind Scope mlist_scope with mlist. Local Open Scope mlist_scope. Definition mlength (A : Type) : mlist A -> nat := fix length l := match l with | mnil => O | _ :m: l' => S (length l') end. (** Concatenation of two lists *) Definition mapp (A : Type) : mlist A -> mlist A -> mlist A := fix mapp l m := match l with | mnil => m | a :m: l1 => a :m: mapp l1 m end. Infix "+m+" := mapp (right associativity, at level 60) : mlist_scope. Mtac2-1.4-coq8.20/theories/lib/List.v000066400000000000000000000126361472011217100171120ustar00rootroot00000000000000(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* default | x :m: _ => x end. Definition mhd_error {A} (l:mlist A) : moption A := match l with | [m:] => mNone | x :m: _ => mSome x end. Definition mtl {A} (l:mlist A) := match l with | [m:] => mnil | a :m: m => m end. Fixpoint mnth {A} (n:nat) (l:mlist A) (default:A) {struct l} : A := match n, l with | O, x :m: l' => x | O, other => default | S m, [m:] => default | S m, x :m: t => mnth m t default end. Fixpoint mnth_ok {A} (n:nat) (l:mlist A) (default:A) {struct l} : bool := match n, l with | O, x :m: l' => true | O, other => false | S m, [m:] => false | S m, x :m: t => mnth_ok m t default end. Fixpoint mnth_error {A} (l:mlist A) (n:nat) {struct n} : moption A := match n, l with | O, x :m: _ => mSome x | S n, _ :m: l => mnth_error l n | _, _ => mNone end. Definition mnth_default {A}(default:A) (l:mlist A) (n:nat) : A := match mnth_error l n with | mSome x => x | mNone => default end. Fixpoint mlast {A} (l:mlist A) (d:A) : A := match l with | [m:] => d | [m:a] => a | a :m: l => mlast l d end. Fixpoint mremovemlast {A} (l:mlist A) : mlist A := match l with | [m:] => [m:] | [m:a] => [m:] | a :m: l => a :m: mremovemlast l end. Fixpoint mrev {A} (l:mlist A) : mlist A := match l with | [m:] => [m:] | x :m: l' => mrev l' +m+ [m:x] end. Fixpoint mrev_append {A} (l l': mlist A) : mlist A := match l with | [m:] => l' | a:m:l => mrev_append l (a:m:l') end. Definition mrev' {A} l : mlist A := mrev_append l [m:]. Fixpoint mconcat {A} (l : mlist (mlist A)) : mlist A := match l with | mnil => mnil | mcons x l => x +m+ mconcat l end. Definition mmap {A B} (f : A -> B) := fix mmap (l:mlist A) : mlist B := match l with | [m:] => [m:] | a :m: t => (f a) :m: (mmap t) end. Definition mflat_mmap {A B} (f:A -> mlist B) := fix mflat_mmap (l:mlist A) : mlist B := match l with | mnil => mnil | mcons x t => (f x)+m+(mflat_mmap t) end. Section Fold_Left_Recursor. Variables (A : Type) (B : Type). Variable f : A -> B -> A. Fixpoint mfold_left (l:mlist B) (a0:A) : A := match l with | mnil => a0 | mcons b t => mfold_left t (f a0 b) end. End Fold_Left_Recursor. Section Fold_Right_Recursor. Variables (A : Type) (B : Type). Variable f : B -> A -> A. Variable a0 : A. Fixpoint mfold_right (l:mlist B) : A := match l with | mnil => a0 | mcons b t => f b (mfold_right t) end. End Fold_Right_Recursor. Section Bool. Variable A : Type. Variable f : A -> bool. Fixpoint mexistsb (l:mlist A) : bool := match l with | mnil => false | a:m:l => f a || mexistsb l end. Fixpoint mforallb (l:mlist A) : bool := match l with | mnil => true | a:m:l => f a && mforallb l end. Fixpoint mfilter (l:mlist A) : mlist A := match l with | mnil => mnil | x :m: l => if f x then x:m:(mfilter l) else mfilter l end. Fixpoint mfind (l:mlist A) : moption A := match l with | mnil => mNone | x :m: mtl => if f x then mSome x else mfind mtl end. Fixpoint mpartition (l:mlist A) : mlist A * mlist A := match l with | mnil => (mnil, mnil) | x :m: mtl => let (g,d) := mpartition mtl in if f x then (x:m:g,d) else (g,x:m:d) end. End Bool. Fixpoint msplit {A B} (l:mlist (A*B)) : mlist A * mlist B := match l with | [m:] => ([m:], [m:]) | (x,y) :m: mtl => let (left,right) := msplit mtl in (x:m:left, y:m:right) end. Fixpoint mcombine {A B} (l : mlist A) (l' : mlist B) : mlist (A*B) := match l,l' with | x:m:mtl, y:m:mtl' => (x,y):m:(mcombine mtl mtl') | _, _ => mnil end. Fixpoint mlist_prod {A B} (l:mlist A) (l':mlist B) : mlist (A * B) := match l with | mnil => mnil | mcons x t => (mmap (fun y:B => (x, y)) l')+m+(mlist_prod t l') end. Fixpoint mfirstn {A} (n:nat)(l:mlist A) : mlist A := match n with | 0 => mnil | S n => match l with | mnil => mnil | a:m:l => a:m:(mfirstn n l) end end. Fixpoint mskipn {A} (n:nat)(l:mlist A) : mlist A := match n with | 0 => l | S n => match l with | mnil => mnil | a:m:l => mskipn n l end end. Fixpoint mseq (start len:nat) : mlist nat := match len with | 0 => mnil | S len => start :m: mseq (S start) len end. Fixpoint mrepeat {A} (x : A) (n: nat ) := match n with | O => [m:] | S k => x:m:(mrepeat x k) end. Mtac2-1.4-coq8.20/theories/lib/Logic.v000066400000000000000000000217321472011217100172310ustar00rootroot00000000000000(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* T" (at level 70, y at next level, no associativity). Reserved Notation "x =m= y" (at level 70, no associativity). (** * First-order quantifiers *) (** [ex P], or simply [exists x, P x], or also [exists x:A, P x], expresses the existence of an [x] of some type [A] in [Set] which satisfies the predicate [P]. This is existential quantification. [ex2 P Q], or simply [exists2 x, P x & Q x], or also [exists2 x:A, P x & Q x], expresses the existence of an [x] of type [A] which satisfies both predicates [P] and [Q]. Universal quantification is primitively written [forall x:A, Q]. By symmetry with existential quantification, the construction [all P] is provided too. *) Inductive mex (A:Type) (P:A -> Prop) : Prop := mex_intro : forall x:A, P x -> mex (A:=A) P. (** * Equality *) (** [eq x y], or simply [x=y] expresses the equality of [x] and [y]. Both [x] and [y] must belong to the same type [A]. The definition is inductive and states the reflexivity of the equality. The others properties (symmetry, transitivity, replacement of equals by equals) are proved below. The type of [x] and [y] can be made explicit using the notation [x = y :> A]. This is Leibniz equality as it expresses that [x] and [y] are equal iff every property on [A] which is true of [x] is also true of [y] *) Inductive meq (A:Type) (x:A) : A -> Prop := meq_refl : x =m= x :>A where "x =m= y :> A" := (@meq A x y) : type_scope. Notation "x =m= y" := (x =m= y :>_) : type_scope. Arguments meq {A} x _. Arguments meq_refl {A x} , [A] x. Arguments meq_ind [A] x P _ y _ : rename. Arguments meq_rec [A] x P _ y _ : rename. Arguments meq_rect [A] x P _ y _ : rename. (* Section Logic_lemmas. *) Section equality. Variables A : Type. Variables x y z : A. Theorem meq_sym : x =m= y -> y =m= x. Proof. destruct 1; reflexivity. Defined. Theorem meq_trans : x =m= y -> y =m= z -> x =m= z. Proof. destruct 2; trivial. Defined. Variable B : Type. Variable f : A -> B. Theorem mf_equal : x =m= y -> f x =m= f y. Proof. destruct 1; reflexivity. Defined. End equality. Definition meq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y =m= x -> P y. intros A x P H y H0. elim meq_sym with (1 := H0); assumption. Defined. Definition meq_rec_r : forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y =m= x -> P y. intros A x P H y H0; elim meq_sym with (1 := H0); assumption. Defined. Definition meq_rect_r : forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y =m= x -> P y. intros A x P H y H0; elim meq_sym with (1 := H0); assumption. Defined. (* End Logic_lemmas. *) (* Module EqNotations. *) (* Notation "'rew' H 'in' H'" := (eq_rect _ _ H' _ H) *) (* (at level 10, H' at level 10, *) (* format "'[' 'rew' H in '/' H' ']'"). *) (* Notation "'rew' [ P ] H 'in' H'" := (eq_rect _ P H' _ H) *) (* (at level 10, H' at level 10, *) (* format "'[' 'rew' [ P ] '/ ' H in '/' H' ']'"). *) (* Notation "'rew' <- H 'in' H'" := (eq_rect_r _ H' H) *) (* (at level 10, H' at level 10, *) (* format "'[' 'rew' <- H in '/' H' ']'"). *) (* Notation "'rew' <- [ P ] H 'in' H'" := (eq_rect_r P H' H) *) (* (at level 10, H' at level 10, *) (* format "'[' 'rew' <- [ P ] '/ ' H in '/' H' ']'"). *) (* Notation "'rew' -> H 'in' H'" := (eq_rect _ _ H' _ H) *) (* (at level 10, H' at level 10, only parsing). *) (* Notation "'rew' -> [ P ] H 'in' H'" := (eq_rect _ P H' _ H) *) (* (at level 10, H' at level 10, only parsing). *) (* End EqNotations. *) (* Import EqNotations. *) (* Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a. *) (* Proof. *) (* intros. *) (* destruct H. *) (* reflexivity. *) (* Defined. *) (* Lemma rew_opp_l : forall A (P:A->Type) (x y:A) (H:x=y) (a:P x), rew <- H in rew H in a = a. *) (* Proof. *) (* intros. *) (* destruct H. *) (* reflexivity. *) (* Defined. *) (* Theorem f_equal2 : *) (* forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1) *) (* (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2. *) (* Proof. *) (* destruct 1; destruct 1; reflexivity. *) (* Qed. *) (* Theorem f_equal3 : *) (* forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1) *) (* (x2 y2:A2) (x3 y3:A3), *) (* x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3. *) (* Proof. *) (* destruct 1; destruct 1; destruct 1; reflexivity. *) (* Qed. *) (* Theorem f_equal4 : *) (* forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B) *) (* (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4), *) (* x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> f x1 x2 x3 x4 = f y1 y2 y3 y4. *) (* Proof. *) (* destruct 1; destruct 1; destruct 1; destruct 1; reflexivity. *) (* Qed. *) (* Theorem f_equal5 : *) (* forall (A1 A2 A3 A4 A5 B:Type) (f:A1 -> A2 -> A3 -> A4 -> A5 -> B) *) (* (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4) (x5 y5:A5), *) (* x1 = y1 -> *) (* x2 = y2 -> *) (* x3 = y3 -> x4 = y4 -> x5 = y5 -> f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5. *) (* Proof. *) (* destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity. *) (* Qed. *) (* Theorem f_equal_compose : forall A B C (a b:A) (f:A->B) (g:B->C) (e:a=b), *) (* f_equal g (f_equal f e) = f_equal (fun a => g (f a)) e. *) (* Proof. *) (* destruct e. reflexivity. *) (* Defined. *) (* (** The goupoid structure of equality *) *) (* Theorem eq_trans_refl_l : forall A (x y:A) (e:x=y), eq_trans eq_refl e = e. *) (* Proof. *) (* destruct e. reflexivity. *) (* Defined. *) (* Theorem eq_trans_refl_r : forall A (x y:A) (e:x=y), eq_trans e eq_refl = e. *) (* Proof. *) (* destruct e. reflexivity. *) (* Defined. *) (* Theorem eq_sym_involutive : forall A (x y:A) (e:x=y), eq_sym (eq_sym e) = e. *) (* Proof. *) (* destruct e; reflexivity. *) (* Defined. *) (* Theorem eq_trans_sym_inv_l : forall A (x y:A) (e:x=y), eq_trans (eq_sym e) e = eq_refl. *) (* Proof. *) (* destruct e; reflexivity. *) (* Defined. *) (* Theorem eq_trans_sym_inv_r : forall A (x y:A) (e:x=y), eq_trans e (eq_sym e) = eq_refl. *) (* Proof. *) (* destruct e; reflexivity. *) (* Defined. *) (* Theorem eq_trans_assoc : forall A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t), *) (* eq_trans e (eq_trans e' e'') = eq_trans (eq_trans e e') e''. *) (* Proof. *) (* destruct e''; reflexivity. *) (* Defined. *) (* (** Extra properties of equality *) *) (* Theorem eq_id_comm_l : forall A (f:A->A) (Hf:forall a, a = f a), forall a, f_equal f (Hf a) = Hf (f a). *) (* Proof. *) (* intros. *) (* unfold f_equal. *) (* rewrite <- (eq_trans_sym_inv_l (Hf a)). *) (* destruct (Hf a) at 1 2. *) (* destruct (Hf a). *) (* reflexivity. *) (* Defined. *) (* Theorem eq_id_comm_r : forall A (f:A->A) (Hf:forall a, f a = a), forall a, f_equal f (Hf a) = Hf (f a). *) (* Proof. *) (* intros. *) (* unfold f_equal. *) (* rewrite <- (eq_trans_sym_inv_l (Hf (f (f a)))). *) (* set (Hfsymf := fun a => eq_sym (Hf a)). *) (* change (eq_sym (Hf (f (f a)))) with (Hfsymf (f (f a))). *) (* pattern (Hfsymf (f (f a))). *) (* destruct (eq_id_comm_l f Hfsymf (f a)). *) (* destruct (eq_id_comm_l f Hfsymf a). *) (* unfold Hfsymf. *) (* destruct (Hf a). simpl. *) (* rewrite eq_trans_refl_l. *) (* reflexivity. *) (* Defined. *) (* Lemma eq_refl_map_distr : forall A B x (f:A->B), f_equal f (eq_refl x) = eq_refl (f x). *) (* Proof. *) (* reflexivity. *) (* Qed. *) (* Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e'). *) (* Proof. *) (* destruct e'. *) (* reflexivity. *) (* Defined. *) (* Lemma eq_sym_map_distr : forall A B (x y:A) (f:A->B) (e:x=y), eq_sym (f_equal f e) = f_equal f (eq_sym e). *) (* Proof. *) (* destruct e. *) (* reflexivity. *) (* Defined. *) (* Lemma eq_trans_sym_distr : forall A (x y z:A) (e:x=y) (e':y=z), eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e). *) (* Proof. *) (* destruct e, e'. *) (* reflexivity. *) (* Defined. *) (* Lemma eq_trans_rew_distr : forall A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x), *) (* rew (eq_trans e e') in k = rew e' in rew e in k. *) (* Proof. *) (* destruct e, e'; reflexivity. *) (* Qed. *) (* Lemma rew_const : forall A P (x y:A) (e:x=y) (k:P), *) (* rew [fun _ => P] e in k = k. *) (* Proof. *) (* destruct e; reflexivity. *) (* Qed. *) Mtac2-1.4-coq8.20/theories/lib/Specif.v000066400000000000000000000246231472011217100174070ustar00rootroot00000000000000(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Prop) : Type := mexist : forall x:A, P x -> msig P. Inductive msig2 (A:Type) (P Q:A -> Prop) : Type := mexist2 : forall x:A, P x -> Q x -> msig2 P Q. (** [(msigT A P)], or more suggestively [{x:A & (P x)}] is a Msigma-type. Similarly for [(msigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *) Inductive msigT (A:Type) (P:A -> Type) : Type := mexistT : forall x:A, P x -> msigT P. Inductive msigT2 (A:Type) (P Q:A -> Type) : Type := mexistT2 : forall x:A, P x -> Q x -> msigT2 P Q. (* Notations *) Arguments msig (A P)%type. Arguments msig2 (A P Q)%type. Arguments msigT (A P)%type. Arguments msigT2 (A P Q)%type. (* Notation "{ x | P }" := (msig (fun x => P)) : type_scope. *) (* Notation "{ x | P & Q }" := (msig2 (fun x => P) (fun x => Q)) : type_scope. *) (* Notation "{ x : A | P }" := (msig (A:=A) (fun x => P)) : type_scope. *) (* Notation "{ x : A | P & Q }" := (msig2 (A:=A) (fun x => P) (fun x => Q)) : *) (* type_scope. *) (* Notation "{ x : A & P }" := (msigT (A:=A) (fun x => P)) : type_scope. *) Notation "'m:{' x .. y & P }" := (msigT (fun x => .. (msigT (fun y => P)) ..)) (x binder, y binder) : type_scope. (* Notation "{ x : A & P & Q }" := (msigT2 (A:=A) (fun x => P) (fun x => Q)) : *) (* type_scope. *) Add Printing Let msig. Add Printing Let msig2. Add Printing Let msigT. Add Printing Let msigT2. (** Mprojections of [msig] An element [y] of a subset [{x:A | (P x)}] is the pair of an [a] of type [A] and of a proof [h] that [a] satisfies [P]. Then [(mproj1_msig y)] is the witness [a] and [(mproj2_msig y)] is the proof of [(P a)] *) (* Set Universe Polymorphism. Set Polymorphic Inductive Cumulativity. *) Section Subset_mprojections. Variable A : Type. Variable P : A -> Prop. Definition mproj1_msig (e:msig P) := match e with | mexist _ a b => a end. Definition mproj2_msig (e:msig P) := match e return P (mproj1_msig e) with | mexist _ a b => b end. End Subset_mprojections. (** [msig2] of a predicate can be mprojected to a [msig]. This allows [mproj1_msig] and [mproj2_msig] to be usable with [msig2]. The [let] statements occur in the body of the [exist] so that [mproj1_msig] of a coerced [X : msig2 P Q] will unify with [let (a, _, _) := X in a] *) Definition msig_of_msig2 (A : Type) (P Q : A -> Prop) (X : msig2 P Q) : msig P := mexist P (let (a, _, _) := X in a) (let (x, p, _) as s return (P (let (a, _, _) := s in a)) := X in p). (** Mprojections of [msig2] An element [y] of a subset [{x:A | (P x) & (Q x)}] is the triple of an [a] of type [A], a of a proof [h] that [a] satisfies [P], and a proof [h'] that [a] satisfies [Q]. Then [(mproj1_msig (msig_of_msig2 y))] is the witness [a], [(mproj2_msig (msig_of_msig2 y))] is the proof of [(P a)], and [(mproj3_msig y)] is the proof of [(Q a)]. *) Section Subset_mprojections2. Variable A : Type. Variables P Q : A -> Prop. Definition mproj3_msig (e : msig2 P Q) := let (a, b, c) return Q (mproj1_msig (msig_of_msig2 e)) := e in c. End Subset_mprojections2. (** Mprojections of [msigT] An element [x] of a msigma-type [{y:A & P y}] is a dependent pair made of an [a] of type [A] and an [h] of type [P a]. Then, [(mprojT1 x)] is the first mprojection and [(mprojT2 x)] is the second mprojection, the type of which depends on the [mprojT1]. *) Section Mprojections. Variable A : Type. Variable P : A -> Type. Definition mprojT1 (x:msigT P) : A := match x with | mexistT _ a _ => a end. Definition mprojT2 (x:msigT P) : P (mprojT1 x) := match x return P (mprojT1 x) with | mexistT _ _ h => h end. End Mprojections. (** [msigT2] of a predicate can be mprojected to a [msigT]. This allows [mprojT1] and [mprojT2] to be usable with [msigT2]. The [let] statements occur in the body of the [existT] so that [mprojT1] of a coerced [X : msigT2 P Q] will unify with [let (a, _, _) := X in a] *) Definition msigT_of_msigT2 (A : Type) (P Q : A -> Type) (X : msigT2 P Q) : msigT P := mexistT P (let (a, _, _) := X in a) (let (x, p, _) as s return (P (let (a, _, _) := s in a)) := X in p). (** Mprojections of [msigT2] An element [x] of a msigma-type [{y:A & P y & Q y}] is a dependent pair made of an [a] of type [A], an [h] of type [P a], and an [h'] of type [Q a]. Then, [(mprojT1 (msigT_of_msigT2 x))] is the first mprojection, [(mprojT2 (msigT_of_msigT2 x))] is the second mprojection, and [(mprojT3 x)] is the third mprojection, the types of which depends on the [mprojT1]. *) Section Mprojections2. Variable A : Type. Variables P Q : A -> Type. Definition mprojT3 (e : msigT2 P Q) := let (a, b, c) return Q (mprojT1 (msigT_of_msigT2 e)) := e in c. End Mprojections2. (** [msigT] of a predicate is equivalent to [msig] *) Definition msig_of_msigT (A : Type) (P : A -> Prop) (X : msigT P) : msig P := mexist P (mprojT1 X) (mprojT2 X). Definition msigT_of_msig (A : Type) (P : A -> Prop) (X : msig P) : msigT P := mexistT P (mproj1_msig X) (mproj2_msig X). (** [msigT2] of a predicate is equivalent to [msig2] *) Definition msig2_of_msigT2 (A : Type) (P Q : A -> Prop) (X : msigT2 P Q) : msig2 P Q := mexist2 P Q (mprojT1 (msigT_of_msigT2 X)) (mprojT2 (msigT_of_msigT2 X)) (mprojT3 X). Definition msigT2_of_msig2 (A : Type) (P Q : A -> Prop) (X : msig2 P Q) : msigT2 P Q := mexistT2 P Q (mproj1_msig (msig_of_msig2 X)) (mproj2_msig (msig_of_msig2 X)) (mproj3_msig X). (** [sumbool] is a boolean type equipped with the justification of their value *) Inductive sumbool (A B:Prop) : Set := | left : A -> {A} + {B} | right : B -> {A} + {B} where "{ A } + { B }" := (sumbool A B) : type_scope. Add Printing If sumbool. Arguments left {A B} _, [A] B _. Arguments right {A B} _ , A [B] _. (** [sumor] is an option type equipped with the justification of why it may not be a regular value *) Inductive sumor (A:Type) (B:Prop) : Type := | inleft : A -> A + {B} | inright : B -> A + {B} where "A + { B }" := (sumor A B) : type_scope. Add Printing If sumor. Arguments inleft {A B} _ , [A] B _. Arguments inright {A B} _ , A [B] _. (* Unset Universe Polymorphism. *) (** Various forms of the axiom of choice for specifications *) (* Section Choice_lemmas. *) (* Variables S S' : Set. *) (* Variable R : S -> S' -> Prop. *) (* Variable R' : S -> S' -> Set. *) (* Variables R1 R2 : S -> Prop. *) (* Lemma Choice : *) (* (forall x:S, {y:S' | R x y}) -> {f:S -> S' | forall z:S, R z (f z)}. *) (* Proof. *) (* intro H. *) (* exists (fun z => mproj1_msig (H z)). *) (* intro z; destruct (H z); assumption. *) (* Defined. *) (* Lemma Choice2 : *) (* (forall x:S, {y:S' & R' x y}) -> {f:S -> S' & forall z:S, R' z (f z)}. *) (* Proof. *) (* intro H. *) (* exists (fun z => mprojT1 (H z)). *) (* intro z; destruct (H z); assumption. *) (* Defined. *) (* Lemma bool_choice : *) (* (forall x:S, {R1 x} + {R2 x}) -> *) (* {f:S -> bool | forall x:S, f x = true /\ R1 x \/ f x = false /\ R2 x}. *) (* Proof. *) (* intro H. *) (* exists (fun z:S => if H z then true else false). *) (* intro z; destruct (H z); auto. *) (* Defined. *) (* End Choice_lemmas. *) (* Section Dependent_choice_lemmas. *) (* Variables X : Set. *) (* Variable R : X -> X -> Prop. *) (* Lemma dependent_choice : *) (* (forall x:X, {y | R x y}) -> *) (* forall x0, {f : nat -> X | f O = x0 /\ forall n, R (f n) (f (S n))}. *) (* Proof. *) (* intros H x0. *) (* set (f:=fix f n := match n with O => x0 | S n' => mproj1_msig (H (f n')) end). *) (* exists f. *) (* split. reflexivity. *) (* induction n; simpl; apply mproj2_msig. *) (* Defined. *) (* End Dependent_choice_lemmas. *) (** A result of type [(Exc A)] is either a normal value of type [A] or an [error] : [Inductive Exc [A:Type] : Type := value : A->(Exc A) | error : (Exc A)]. It is implemented using the option type. *) (* Section Exc. *) (* Variable A : Type. *) (* Definition Exc := option A. *) (* Definition value := @Some A. *) (* Definition error := @None A. *) (* End Exc. *) (* Arguments error {A}. *) (* Definition except := False_rec. (* for compatibility with previous versions *) *) (* Arguments except [P] _. *) (* Theorem absurd_set : forall (A:Prop) (C:Set), A -> ~ A -> C. *) (* Proof. *) (* intros A C h1 h2. *) (* apply False_rec. *) (* apply (h2 h1). *) (* Defined. *) (* Hint Resolve left right inleft inright: core v62. *) (* Hint Resolve exist exist2 existT existT2: core. *) (* Compatibility *) (* Notation msigS := msigT (compat "8.2"). *) (* Notation existS := existT (compat "8.2"). *) (* Notation msigS_rect := msigT_rect (compat "8.2"). *) (* Notation msigS_rec := msigT_rec (compat "8.2"). *) (* Notation msigS_ind := msigT_ind (compat "8.2"). *) (* Notation mprojS1 := mprojT1 (compat "8.2"). *) (* Notation mprojS2 := mprojT2 (compat "8.2"). *) (* Notation msigS2 := msigT2 (compat "8.2"). *) (* Notation existS2 := existT2 (compat "8.2"). *) (* Notation msigS2_rect := msigT2_rect (compat "8.2"). *) (* Notation msigS2_rec := msigT2_rec (compat "8.2"). *) (* Notation msigS2_ind := msigT2_ind (compat "8.2"). *) Mtac2-1.4-coq8.20/theories/lib/Utils.v000066400000000000000000000014711472011217100172720ustar00rootroot00000000000000From Mtac2 Require Import Datatypes List. Import ListNotations. Set Universe Polymorphism. Set Polymorphic Inductive Cumulativity. Unset Universe Minimization ToSet. Definition dec_bool {P} (x : {P}+{~P}) : bool := match x with | left _ => true | _ => false end. Definition option_to_bool {A} (ox : moption A) : bool := match ox with mSome _ => true | _ => false end. Definition is_empty {A} (l: mlist A) : bool := match l with [m:] => true | _ => false end. Fixpoint but_last {A} (l : mlist A) : mlist A := match l with | [m:] => [m:] | [m:a] => [m:] | a :m: ls => a :m: but_last ls end. Fixpoint nsplit {A} (n : nat) (l : mlist A) : mlist A * mlist A := match n, l with | 0, l => ([m:], l) | S n', x :m: l' => let (l1, l2) := nsplit n' l' in (x :m: l1, l2) | _, _ => ([m:], [m:]) end. Mtac2-1.4-coq8.20/theories/meta/000077500000000000000000000000001472011217100161605ustar00rootroot00000000000000Mtac2-1.4-coq8.20/theories/meta/Exhaustive.v000066400000000000000000000035471472011217100205050ustar00rootroot00000000000000From Mtac2 Require Import Base List Datatypes. Import M.notations. Import Datatypes.ProdNotations. Set Universe Polymorphism. Unset Universe Minimization ToSet. Set Polymorphic Inductive Cumulativity. (** This file implements exhaustive [mmatch]es by introducing the [mmatch t exhaustively_with ... end] syntax. We currently consider only [[# ] c | x .. y ] nodes, and only those that have an unapplied constructor [c] on the left-hand side of [|]. *) Definition ConstrNotFound : Exception. constructor. Qed. Definition ConstrsUnmentioned (m : mlist dyn) : Exception. constructor. Qed. Definition find_in_constrs {C} (c : C) : mlist dyn -> M (mlist dyn) := mfix1 f (cs : _) : M _ := match cs with | mnil => M.ret mnil | mcons c' cs => '(m: c, _) <- M.decompose c; dcase c as C, c in let C := reduce (RedVmCompute) C in mmatch c' with | @Dyn C c =n> M.ret cs | _ => l <- f cs; M.ret (c' :m: l) end end. Definition check_exhaustiveness {A B} (ps_in : mlist (branch A B)) (ops : moption (mlist (branch A B))) : M (mlist (branch A B)) := '(mkInd_dyn _ _ _ constrs) <- M.constrs A; ( mfix2 f (ps : _) (constrs : _) : M _ := match ps, constrs with | mnil, mnil => match ops with | mNone => M.ret ps_in | mSome ps' => let ps := dreduce (@mapp) (mapp ps_in ps') in M.ret ps end | mcons p ps, _ => match p with | branch_app_static U C _ => constrs <- find_in_constrs C constrs; f ps constrs | _ => f ps constrs end | _, _ => M.raise (ConstrsUnmentioned constrs) end ) ps_in constrs . Notation "'exhaustively' ls" := ( ltac:(mrun (check_exhaustiveness ls (mNone))) ) (in custom Mtac2_with_branch at level 91, ls custom Mtac2_with_branch). Mtac2-1.4-coq8.20/theories/meta/MFix.v000066400000000000000000000074641472011217100172250ustar00rootroot00000000000000From Mtac2 Require Import Base Logic Datatypes MFixDef MTele MTeleMatch. Import M.notations. Import Sorts.S. Set Universe Polymorphism. Unset Universe Minimization ToSet. Local Definition MFA {n} (T : MTele_Ty n) := (MTele_val (MTele_C Typeₛ Propₛ M T)). (* Less specific version of MTele_of in MTeleMatch.v *) Definition MTele_of' := (mfix1 f (T : Prop) : M { m : MTele & { mT : MTele_Ty m & T =m= MFA mT } } := (mtmmatch T as T0 return T =m= T0 -> M { m : MTele & { mT : MTele_Ty m & T =m= MFA mT } } with | [?X : Type] M X =u> fun H => M.ret (existT (fun m => {mT : MTele_Ty m & T =m= MFA mT}) (mBase) (existT (fun mT : MTele_Ty mBase => T =m= MFA mT) _ H) ) | [?(X : Type) (F : forall x:X, Prop)] (forall x:X, F x) =c> fun H => M.nu (FreshFrom F) mNone (fun x => '(existT _ m (existT _ mT E)) <- f (F x); m' <- M.abs_fun x m; mT' <- (M.coerce mT >>= M.abs_fun (P:=fun x => MTele_Ty (m' x)) x); (* E' <- (M.abs_fun x E >>= M.coerce (B:=_ =m= MFA mT')); *) E' <- M.coerce (@meq_refl _ (MFA (n:=mTele m') mT')); M.ret (existT _ (mTele m') (existT _ mT' E')) (* mf <- M.abs_fun (P:=fun x => {m : _ & F x =m= MFA m}) x mf; *) (* let g := (fun x => projT1 (mf x)) in *) (* let h := (fun x => projT2 (mf x)) in *) (* e <- M.evar ((forall x, F x) =m= MFA (mTele g)); *) (* er <- M.coerce (meq_refl (forall x, F x)); *) (* M.unify e er UniEvarconv;; *) (* M.ret (existT (fun m => (forall x:X, F x) =m= MFA m) (mTele g) e) *) ) end) meq_refl ). Definition MTele_of : Prop -> M (sigT MTele_Ty) := mfix1 f (T : Prop) : M (sigT MTele_Ty) := mmatch T return M (sigT MTele_Ty) with | [?X : Type] M X =u> M.ret (existT _ mBase X) | [?(X : Type) (F : forall x:X, Prop)] (forall x:X, F x) =c> M.nu (FreshFrom F) mNone (fun x => '(existT _ n T) <- f (F x); n' <- M.abs_fun (P:=fun _ => MTele) x n; T' <- M.abs_fun x T; T' <- M.coerce T'; M.ret (existT _ (mTele n') T') ) end . Class MT_OF (T : Prop) := { mt_of_tele : MTele; mt_of_type: MTele_Ty mt_of_tele; mt_of_eq : T =m= MFA mt_of_type }. (* Arguments mt_of _ {_}. *) Definition tc_helper (t : Prop) := '(existT _ m (existT _ mT eq)) <- MTele_of' t; M.ret (Build_MT_OF _ m mT eq). #[global] Hint Extern 0 (MT_OF ?t) => mrun (tc_helper t ) : typeclass_instances. Definition mfix_tc' {A : Prop} {mt : MT_OF A} : forall (F : (A -> A)), A := match meq_sym (@mt_of_eq _ mt) in _ =m= R return (R -> R ) -> (R) with | meq_refl => MFixDef.mfix' _ end. Arguments mfix_tc' {_} {_} _. Notation "'mfix' f x .. y : T := b" := ( @mfix_tc' (forall x, .. (forall y, T) ..) _ (fun f => fun x => .. (fun y => b)..) ) (only parsing, no associativity, at level 85, f ident, x binder, y binder, format "mfix f x .. y : T := b" ). (* The above notation does not work for printing since [T] cannot be derived from an application of `mfix_tc'`. Thus, we define a printing notation that omits [T]. *) Notation "'mfix' f x .. y := b" := ( mfix_tc' (fun f => fun x => .. (fun y => b)..) ) (only printing, no associativity, at level 85, f ident, x binder, y binder, format "mfix f x .. y := b" ). Mtac2-1.4-coq8.20/theories/meta/MFixDef.v000066400000000000000000000020251472011217100176300ustar00rootroot00000000000000From Mtac2 Require Import Base Specif MTele. Import Sorts.S. Import M.notations. Set Universe Polymorphism. Unset Universe Minimization ToSet. Local Notation MFA T := (MTele_val (MTele_C Typeₛ Propₛ M T)). Fixpoint uncurry {m : MTele} : forall {T : MTele_Ty m}, MFA T -> forall U : ArgsOf m, M (apply_sort T U) := match m as m return forall T : MTele_Ty m, MFA T -> forall U : ArgsOf m, M (apply_sort T U) with | mBase => fun T F _ => F | mTele f => fun T F '(mexistT _ x U) => uncurry (F x) U end. Fixpoint curry {m : MTele} : forall {T : MTele_Ty m}, (forall U : ArgsOf m, M (apply_sort T U)) -> MFA T := match m with | mBase => fun T F => F tt | mTele f => fun T F x => curry (fun U => F (mexistT _ x U)) end. Definition mfix' {m : MTele} (T : MTele_Ty m) (F : MFA T -> MFA T) : MFA T := curry (mfix1 rec (U : _) : M _ := uncurry (F (curry rec)) U). (* Definition mfix' (m : MTele) (F : MFA m -> MFA m) : MFA m := *) (* curry m (M.fix1 _ (fun rec => uncurry m (F (curry m rec)))). *) Mtac2-1.4-coq8.20/theories/meta/MTeleMatch.v000066400000000000000000000100271472011217100203320ustar00rootroot00000000000000Require Import Coq.Strings.String. From Mtac2 Require Import Base Specif Logic Datatypes MTele MTeleMatchDef. Import M.notations. Set Universe Polymorphism. Unset Universe Minimization ToSet. Definition MTele_of {A:Type} (T : A -> Prop) : M (A -> msigT MTele_Ty) := M.nu (FreshFrom T) mNone (fun a => let T' := reduce (RedOneStep [rl:RedBeta]) (T a) in (mfix1 f (T : Prop) : M (msigT MTele_Ty) := mmatch T return M (msigT MTele_Ty) with | [?X : Type] M X =u> M.ret (mexistT _ mBase X) | [?(X : Type) (F : forall x:X, Prop)] (forall x:X, F x) =u> M.nu (FreshFrom T) mNone (fun x => let T' := reduce (RedOneStep [rl:RedBeta]) (F x) in '(mexistT _ n T) <- f T'; n' <- M.abs_fun x n; T' <- (M.coerce (B:=MTele_Ty (n' x)) T >>= M.abs_fun x); M.ret (mexistT _ (mTele n') T') ) end ) (T') >>= (fun t => (* M.print_term t;; *) t' <- M.abs_fun a t; (* M.print_term t';; *) M.ret t')). Local Example test := fun x => mexistT MTele_Ty (mTele (fun _ : nat => mBase)) (fun y : nat => x = y). Eval hnf in ltac:(mrun (MTele_of (fun x : nat => forall y:nat, M (x = y)))). Local Example MTele_of_Test : nat -> msigT MTele_Ty := Eval hnf in ltac:(mrun (MTele_of (fun x : nat => forall y:nat, M (x = y)))). Class TC_UNIFY {T : Type} (A B : T) : Prop := tc_unify : (A =m= B). Arguments tc_unify {_} _ _ {_}. Definition tc_unify_mtac T (A B : T) := (* M.print "tc_unify 1";; *) o <- @M.unify T A B UniCoq; (* M.print "tc_unify 2";; *) match o with | mSome eq => M.ret eq | mNone => let A := reduce (RedStrong RedAll) A in let B := reduce (RedStrong RedAll) B in (* M.print_term (A,B);; *) M.failwith "cannot (tc_)unify." end. #[global] Hint Extern 0 (@TC_UNIFY ?T ?A ?B) => mrun (tc_unify_mtac T A B) : typeclass_instances. Class MT_OF {A} (T : A -> Prop) := mt_of : A -> msigT MTele_Ty. Arguments mt_of {_} _ {_}. #[global] Hint Extern 0 (@MT_OF ?A ?t) => mrun (@MTele_of A t) : typeclass_instances. Notation "'mtmmatch' x 'as' y 'return' T 'with' p 'end'" := ( let mt1 := mt_of (fun y => T) in match tc_unify (fun _z => MTele_ty M (mprojT2 (mt1 _z))) ((fun y => T)) in _ =m= R return mlist (branch _ R) -> R x with | meq_refl => mtmmatch' _ (fun _z => mprojT1 (mt1 _z)) (fun _z => mprojT2 (mt1 _z)) x end (p) ) (at level 200, p custom Mtac2_with_branch). Local Example mt_of_test : MT_OF (fun x:nat => forall y:nat, M nat). Proof. apply _. Qed. (* Set Printing All. *) Set Printing Universes. Definition bluf := (fun x:(nat:Type) => forall y:(nat:Type), M (nat:Type)). Eval hnf in ltac:(mrun (MTele_of (bluf))). Local Example test1 := let mt1 := ltac:(mrun (MTele_of bluf)) in let _ := ltac:(mrun (let mt1 := reduce (RedOneStep [rl:RedDelta]) mt1 in M.print_term mt1)) in ltac:(mrun(tc_unify_mtac _ (fun _z : (nat:Type) => MTele_ty M (mprojT2 (mt1 _z))) ((fun x:(nat:Type) => forall y:(nat:Type), M (nat:Type))))). Local Program Example mtmmatch_prog_test (x : (nat : Type)) := mtmmatch x as x return forall y, M (x = y) with | [?i] i =n> fun y => M.failwith "" end. (* Alternative version, currently broken because of bidir. annotations. *) Polymorphic Class MTY_OF {A} := MTt_Of { mty_of : A -> Prop }. Arguments MTt_Of [_] _. Polymorphic Class RET_TY (A : Type) := Ret_Ty { ret_ty : A }. Arguments Ret_Ty [_] _. Arguments ret_ty {_ _}. Notation "'mtmmatch_alt' x 'as' y 'return' T 'with' p 'end'" := ( let mt1 := M.eval (MTele_of (fun y => T)) in let F : RET_TY _ := Ret_Ty (fun y => T) in let mt : MTY_OF := MTt_Of (fun _z => MTele_ty M (n:=mprojT1 (mt1 _z)) (mprojT2 (mt1 _z))) in mtmmatch' _ (fun y => mprojT1 (mt1 y)) (fun y => mprojT2 (mt1 y)) x p ) (at level 90, p custom Mtac2_with_branch). Local Example test_mtmmatch (n : nat) := mtmmatch_alt n as n' return n = n' -> M (n = 1) with | 1 =n> fun H => M.ret H | _ as _catchall => fun H : n = _catchall => M.failwith "test" end. Mtac2-1.4-coq8.20/theories/meta/MTeleMatchDef.v000066400000000000000000000057641472011217100207650ustar00rootroot00000000000000From Mtac2 Require Import Base Logic Datatypes List MTele. Import M.notations. Import Sorts.S. Import ListNotations. Set Universe Polymorphism. Set Polymorphic Inductive Cumulativity. Unset Universe Minimization ToSet. Local Notation MFA T := (MTele_val (MTele_C Typeₛ Propₛ M T)). Definition open_pattern {A} {m} {T : forall x, MTele_Ty (m x)} {y : A} {a : ArgsOf (m y)} : forall(p : pattern A (fun x => MFA (T x))), M (apply_sort (T y) a) := Eval lazy beta iota match zeta delta [meq_sym] in fix go p := match p return M _ with | pany f => apply_C Propₛ (f y) a | pbase x f u => oeq <- M.unify x y u; match oeq return M (apply_sort (T y) a) with | mSome eq => match eq in meq _ z return forall a : ArgsOf (m z), M (apply_sort (T z) a) with | meq_refl => apply_C Propₛ f end a | mNone => M.raise DoesNotMatch end | ptele f => c <- M.evar _; go (f c) | psort f => M.mtry' (go (f Propₛ)) (fun e => oeq <- M.unify e DoesNotMatch UniMatchNoRed; match oeq with | mSome _ => go (f Typeₛ) | mNone => M.raise e end ) end . Import String. Open Scope string_scope. Definition open_branch {A} {m} {T : forall x, MTele_Ty (m x)} {y : A} {a : ArgsOf (m y)} (b : branch A (fun x => MFA (T x))) : M (apply_sort (T y) a) := let open_pattern' := @open_pattern A m T y a in match b in branch A P return (pattern A P -> _) -> M _ with | branch_pattern p => fun open_pattern' => open_pattern' p | _ => fun _ => mfail "Unsupported branch type in mtmmatch: " b end open_pattern'. Definition mtmmatch' A m (T : forall x, MTele_Ty (m x)) (y : A) (ps : mlist (branch A (fun x => MFA (T x)))) : selem_of (MFA (T y)) := curry_C Propₛ (fun a : ArgsOf (m y) => (fix mmatch' (ps : mlist (branch A (fun x => MFA (T x)))) := match ps with | [m:] => M.raise NoPatternMatches | p :m: ps' => M.mtry' (open_branch p) (fun e => mif M.unify e DoesNotMatch UniMatchNoRed then mmatch' ps' else M.raise e) end) ps ). Module TestFin. Require Fin. Polymorphic Definition mt : nat -> MTele := fun n => mTele (fun _ : Fin.t n => mBase). Definition T : forall n, MTele_Ty (mt n) := fun n _ => True. Definition pO u : pattern nat _ := @pbase _ (fun x => MTele_ty M (n:=mt x) (T x)) 0 ((* ex_intro _ 0 *) (fun x => Fin.case0 (fun _ => M True) x)) u. Definition p1 u : pattern nat _ := @pbase _ (fun x => MTele_ty M (n:=mt x) (T x)) 1 ((* ex_intro _ 1 *) (fun n => M.ret I)) u. Definition pi u : pattern nat (fun x => MTele_ty M (n:=mt x) (T x)) := ptele (fun i : nat => @pbase _ _ i ((* ex_intro _ i *) (fun n => M.ret I)) u ). Program Example pbeta : pattern nat (fun x => MTele_ty M (n:=mt x) (T x)) := ptele (fun i : nat => @pbase _ (* (fun x => MTele_ty M (mt x)) *) _ (i+1) ((* ex_intro _ (i + 1) *) (fun n : Fin.t (i + 1) => M.ret I)) UniCoq ). End TestFin. Mtac2-1.4-coq8.20/theories/tactics/000077500000000000000000000000001472011217100166645ustar00rootroot00000000000000Mtac2-1.4-coq8.20/theories/tactics/CompoundTactics.v000066400000000000000000000035121472011217100221530ustar00rootroot00000000000000From Mtac2 Require Import Base Tactics ImportedTactics Datatypes List Logic Abstract Sorts. Import Sorts.S. Import M. Import M.notations. Import ListNotations. Import ProdNotations. Require Import Strings.String. Set Implicit Arguments. Unset Strict Implicit. Module CT. Definition SimpleRewriteNoOccurrence : Exception. constructor. Qed. Definition simple_rewrite A {x y : A} (p : x = y) : tactic := fun g=> gT <- goal_type g; r <- T.abstract_from_term x gT; match r with | mSome r => newG <- evar (r y); T.exact (eq_rect y _ newG x (eq_sym p)) g;; ret [m: (m: tt, AnyMetavar Typeₛ _ newG)] | mNone => M.raise SimpleRewriteNoOccurrence end. Import TacticsBase.T.notations. Definition CVariablizeNoOccurrence : Exception. constructor. Qed. Definition cvariabilize_base {A} (fail: bool) (t: A) (name:name) (cont: A -> tactic) : tactic := gT <- T.goal_type; r <- T.abstract_from_term t gT; match r with | mSome r => T.cpose_base name t (fun x => T.change (r x);; cont x ) | mNone => if fail then M.raise CVariablizeNoOccurrence else T.cpose_base name t (fun x => T.change ((fun _=>gT) x);; cont x ) end. Definition destruct {A : Type} (n : A) : tactic := mif M.is_var n then T.destruct n else cvariabilize_base false n (FreshFromStr "dn") (fun x=>T.destruct x). Program Definition destruct_eq {A} (t: A) : tactic := cvariabilize_base false t (FreshFromStr "v") (fun var=> T.cassert_base (FreshFromStr "eqn") (fun (eqnv : t = var)=> T.cmove_back eqnv (T.destruct var)) |1> T.reflexivity ). Module notations. Notation "'uid' v" := (fun v:unit=>unit) (at level 0). Notation "'variabilize' t 'as' v" := ( cvariabilize_base false t (FreshFrom (uid v)) (fun _=>T.idtac) ) (at level 0, t at next level, v at next level). End notations. End CT.Mtac2-1.4-coq8.20/theories/tactics/ConstrSelector.v000066400000000000000000000061031472011217100220240ustar00rootroot00000000000000Require Import Coq.Strings.String. From Mtac2 Require Import Datatypes List Mtac2. Import TacticsBase.T. Import Mtac2.lib.List.ListNotations. Import ProdNotations. Set Universe Polymorphism. Unset Universe Minimization ToSet. (** This files defines a useful tactic to kill subgoals on groups based on the (position) of the constructors. For instance, for a variable x of some inductive type I with constructors c1, ..., cn, the following code applies tactic t to only constructors c1, c3, c5: [induction x &> case c5, c1, c3 do t] Note that there is no check on the type of x and the constructors, nor any check that the first tactic (induction above) will produce exactly n subgoals. *) (** Obtains the list of constructors of a type I from a type of the form A1 -> ... -> An -> I *) Definition get_constrs := mfix1 fill (T : Type) : M (mlist dyn) := mmatch T return M (mlist dyn) with | [? A B] A -> B => fill B | [? A (P:A->Type)] forall x, P x => M.nu (FreshFrom T) mNone (fun x=> fill (P x) ) | _ => '(mkInd_dyn _ _ _ l) <- M.constrs T; M.ret l end%MC. (** Given a constructor c, it returns its index. *) Definition index {A} (c: A) : M _ := l <- get_constrs A; (mfix2 f (i : nat) (l : mlist dyn) : M nat := mmatch l with | [? l'] (Dyn c :m: l') => M.ret i | [? d' l'] (d' :m: l') => f (S i) l' end)%MC 0 l. Definition snth_index {A:Type} (c:A) (t:tactic) : T.selector unit := fun l => (i <- index c; S.nth i (fun _=>t) l)%MC. Notation "'case' c 'do' t" := (snth_index c t) (at level 40). Import M.notations. Local Close Scope tactic_scope. Definition snth_indices (l : mlist dyn) (t : tactic) : selector unit := fun goals=> M.fold_left (fun (accu : mlist (unit *m goal gs_any)) (d : dyn)=> dcase d as c in i <- index c; let ogoal := mnth_error goals i in match ogoal with | mSome (m: _, g) => newgoals <- open_and_apply t g; let res := dreduce (@mapp, @mmap) (accu +m+ newgoals) in T.filter_goals res | mNone => M.failwith "snth_indices" end) l goals. Definition apply_except (l : mlist dyn) (t : tactic) : selector unit := fun goals=> a_constr <- match mhd_error l with mSome d=> M.ret d | _ => M.failwith "apply_except: empty list" end; dcase a_constr as T, c in constrs <- get_constrs T; M.fold_left (fun (accu : mlist (unit *m goal gs_any)) (d : dyn)=> dcase d as c in i <- index c; let ogoal := mnth_error goals i in match ogoal with | mSome (m: _, g) => mif M.find (fun d'=>M.bunify d d' UniCoq) l then M.ret ((m:tt, g) :m: accu) else newgoals <- open_and_apply t g; let res := dreduce (@mapp, @mmap) (accu +m+ newgoals) in T.filter_goals res | mNone => M.failwith "snth_indices" end) constrs goals. Open Scope tactic_scope. Notation "'case' c , .. , d 'do' t" := (snth_indices (Dyn c :m: .. (Dyn d :m: [m:]) ..) t) (at level 40). Notation "'except' c , .. , d 'do' t" := (apply_except (Dyn c :m: .. (Dyn d :m: [m:]) ..) t) (at level 40). Mtac2-1.4-coq8.20/theories/tactics/ImportedTactics.v000066400000000000000000000131221472011217100221500ustar00rootroot00000000000000From Mtac2 Require Import Base Tactics. Require Import ssrmatching.ssrmatching. Import M.notations. Import T.notations. Require Import Strings.String. Require Import Mtac2.lib.List. Import Mtac2.lib.List.ListNotations. Set Universe Polymorphism. Unset Universe Minimization ToSet. Definition qualify s := String.append "Mtac2.tactics.ImportedTactics." s. Ltac Mtrivial := trivial. Definition trivial : tactic := T.ltac (qualify "Mtrivial") [m:]. Ltac Mdiscriminate := discriminate. Definition discriminate : tactic := T.ltac (qualify "Mdiscriminate") [m:]. Ltac Mintuition := intuition. Definition intuition : tactic := T.ltac (qualify "Mintuition") [m:]. Ltac Mauto := auto. Definition auto : tactic := T.ltac (qualify "Mauto") [m:]. Ltac Meauto := eauto. Definition eauto : tactic := T.ltac (qualify "Meauto") [m:]. Ltac Msubst := subst. Definition subst : tactic := T.ltac (qualify "Msubst") [m:]. Ltac Mcontradiction := contradiction. Definition contradiction : tactic := T.ltac (qualify "Mcontradiction") [m:]. Ltac Mtauto := tauto. Definition tauto : tactic := T.ltac (qualify "Mtauto") [m:]. Ltac Munfold x := unfold x. Definition unfold {A} (x: A) := T.ltac (qualify "Munfold") [m:Dyn x]. Ltac rrewrite1 a := rewrite a. Ltac rrewrite2 a b := rewrite a, b. Ltac rrewrite3 a b c := rewrite a, b, c. Ltac rrewrite4 a b c d := rewrite a, b, c, d. Ltac rrewrite5 a b c d e := rewrite a, b, c, d, e. Definition compute_terminator {A} (l: mlist A) : M string := match l with | [m:] => M.ret "_all" (* for rewrite_in *) | [m: _] => M.ret "1" | _ :m: [m:_] => M.ret "2" | _ :m: _ :m: [m:_] => M.ret "3" | _ :m: _ :m: _ :m: [m:_] => M.ret "4" | _ :m: _ :m: _ :m: _ :m: [m:_] => M.ret "5" | _ => M.failwith "Unsupported" end%string. Ltac lrewrite1 a := rewrite <- a. Ltac lrewrite2 a b := rewrite <- a, <- b. Ltac lrewrite3 a b c := rewrite <- a, <- b, <- c. Ltac lrewrite4 a b c d := rewrite <- a, <- b, <- c, <- d. Ltac lrewrite5 a b c d e := rewrite <- a, <- b, <- c, <- d, <- e. Inductive RewriteDirection : Set := LeftRewrite | RightRewrite. Definition trewrite (d : RewriteDirection) (args : mlist dyn) : tactic := fun g => (ter <- compute_terminator args; let prefix := match d with LeftRewrite => "l"%string | RightRewrite => "r"%string end in let name := reduce RedNF (qualify (prefix++"rewrite"++ter)) in T.ltac name args g)%MC. Notation "'rewrite' '->' x , .. , z" := (trewrite RightRewrite (mcons (Dyn x) .. (mcons (Dyn z) [m:]) ..)) (at level 0, x at next level, z at next level). Notation "'rewrite' '<-' x , .. , z" := (trewrite LeftRewrite (mcons (Dyn x) .. (mcons (Dyn z) [m:]) ..)) (at level 0, x at next level, z at next level). Notation "'rewrite' x , .. , z" := (trewrite RightRewrite (mcons (Dyn x) .. (mcons (Dyn z) [m:]) ..)) (at level 0, x at next level, z at next level). Ltac in_rrewrite_all x := rewrite x in *. Ltac in_rrewrite1 x a := rewrite x in a. Ltac in_rrewrite2 x a b := rewrite x in a, b. Ltac in_rrewrite3 x a b c := rewrite x in a, b, c. Ltac in_rrewrite4 x a b c d := rewrite x in a, b, c, d. Ltac in_rrewrite5 x a b c d e := rewrite x in a, b, c, d, e. Ltac in_lrewrite_all x := rewrite <- x in *. Ltac in_lrewrite1 x a := rewrite <- x in a. Ltac in_lrewrite2 x a b := rewrite <- x in a, b. Ltac in_lrewrite3 x a b c := rewrite <- x in a, b, c. Ltac in_lrewrite4 x a b c d := rewrite <- x in a, b, c, d. Ltac in_lrewrite5 x a b c d e := rewrite <- x in a, b, c, d, e. Definition trewrite_in {T} (d: RewriteDirection) (x: T) (args: mlist dyn) : tactic := \tactic g => ter <- compute_terminator args; let prefix := match d with LeftRewrite => "l"%string | RightRewrite => "r"%string end in let name := reduce RedNF (qualify ("in_"++prefix++"rewrite"++ter)) in T.ltac name (Dyn x :m: args) g. Notation "'rewrite_in' '->' a ; x , .. , z" := (trewrite_in RightRewrite a (mcons (Dyn x) .. (mcons (Dyn z) [m:]) ..)) (at level 0, x at next level, z at next level). Notation "'rewrite_in' '<-' a ; x , .. , z" := (trewrite_in LeftRewrite a (mcons (Dyn x) .. (mcons (Dyn z) [m:]) ..)) (at level 0, x at next level, z at next level). Notation "'rewrite_in' a ; x , .. , z" := (trewrite_in RightRewrite a (mcons (Dyn x) .. (mcons (Dyn z) [m:]) ..)) (at level 0, x at next level, z at next level). Notation "'rewrite_*' '->' a" := (trewrite_in RightRewrite a [m:]) (at level 0). Notation "'rewrite_*' '<-' a" := (trewrite_in LeftRewrite a [m:]) (at level 0). Notation "'rewrite_*' a" := (trewrite_in a [m:]) (at level 0). Ltac Melim h := elim h. Definition elim {A} (x:A) : tactic := T.ltac (qualify "Melim") [m: Dyn x]. Ltac Minduction v := induction v. Definition induction {A} (x:A) : tactic := T.ltac (qualify "Minduction") [m: Dyn x]. Definition injection {A} (x: A) : tactic := T.ltac ("Coq.Init.Notations.injection") [m:Dyn x]. Ltac Minversion H := inversion H. Definition inversion {A} (x: A) : tactic := T.ltac (qualify "Minversion") [m:Dyn x]. Ltac Mtypeclasses_eauto := typeclasses eauto. Definition typeclasses_eauto : tactic := T.ltac (qualify "Mtypeclasses_eauto") [m:]. Ltac Mapply x := apply x. Definition ltac_apply {A} (x:A) := T.ltac (qualify "Mapply") [m:Dyn x]. Ltac Mdestruct x := destruct x. Definition ltac_destruct {A} (x:A) := T.ltac (qualify "Mdestruct") [m:Dyn x]. Ltac Mssrpattern p := ssrpattern p. Definition ssrpattern {A} (x:A) := T.ltac (qualify "Mssrpattern") [m: Dyn x]. Ltac Madmit := admit. Definition admit := T.ltac (qualify "Madmit") [m:]. Ltac Mcase n := case n. Definition case {A} (x:A) := T.ltac (qualify "Mcase") [m: Dyn x]. Ltac Mcase_eq n := case_eq n. Definition case_eq {A} (x:A) := T.ltac (qualify "Mcase_eq") [m: Dyn x]. Mtac2-1.4-coq8.20/theories/tactics/IntroPatt.v000066400000000000000000000074551472011217100210120ustar00rootroot00000000000000Require Import Coq.Strings.String. From Mtac2 Require Import List Base. From Mtac2.tactics Require Import TacticsBase Tactics ImportedTactics. Import Mtac2.lib.List.ListNotations. Import M.notations. Import TacticsBase.T.notations. Import Tactics.T.notations. Set Universe Polymorphism. Unset Universe Minimization ToSet. Inductive IPB := . Inductive IP := | IntroNoOp : IP | IntroAnon : IP | IntroB (binder : IPB -> unit) : IP | IntroC (cases : mlist LIP) | IntroR : RewriteDirection -> IP | IntroDone | IntroSimpl : IP with LIP := | lnil : LIP | lcons : IP -> LIP -> LIP. Definition LIP_app : LIP -> LIP -> LIP := fix f l1 := match l1 with | lnil => fun l2 => l2 | lcons ip l1 => fun l2 => lcons ip (f l1 l2) end. Declare Scope IP_scope. Bind Scope IP_scope with IP. Delimit Scope IP_scope with IP. Definition LIP_rcons := fix f l1 := match l1 with | lnil => fun ip => ip | lcons ip1 l1 => fun ip => lcons ip1 (f l1 ip) end. Coercion LIP_rcons : LIP >-> Funclass. Coercion LIP_app : LIP >-> Funclass. Notation "\ x .. z " := (lcons (IntroB (fun x => tt)) .. (lcons (IntroB (fun z => tt)) lnil) ..) (at level 20, x binder, z binder) : IP_scope. Notation "\ x .. z C" := (lcons (IntroB (fun x => tt)) .. (lcons (IntroB (fun z => tt)) C) ..) (at level 20, x binder, z binder) : IP_scope. Notation "'//'" := (lcons IntroDone lnil) : IP_scope. Notation "'/='" := (lcons IntroSimpl lnil) : IP_scope. Notation "~~" := (lcons IntroNoOp lnil) : IP_scope. Notation "r>" := (lcons (IntroR RightRewrite) lnil) : IP_scope. Notation " M.ret a | lcons b bs => f a b >>= loop bs end%MC. Definition NotDone : Exception. exact exception. Qed. Definition done : tactic := intros ;; (tauto || T.assumption || T.reflexivity) || (T.raise NotDone). Fixpoint mmap_plist (f: LIP -> tactic) (l: mlist LIP) : mlist tactic := match l with | [m:] => [m:] | a :m: l' => f a :m: mmap_plist f l' end. Definition case0 := A <- M.evar _; T.intro_base Generate (fun x:A=>case x;; T.clear x). Definition to_tactic (ip : IP) (do_intro : LIP -> tactic) : tactic := match ip return tactic with | IntroNoOp => T.idtac | IntroAnon => T.introsn 1 | IntroB binder => T.intro_simpl (FreshFrom binder) | IntroC [m:] => case0 | IntroC ips => case0 &> mmap_plist do_intro ips | IntroR d => T.introsn 1;; l <- M.hyps; h <- M.hd l; let (_, var, _) := h : Hyp in trewrite d [m:Dyn var];; T.clear var | IntroDone => done | IntroSimpl => simpl end. Import ProdNotations. Definition do_intro : LIP -> tactic := mfix2 do_intro (lip : LIP) (g : goal gs_open) : M (mlist (unit *m goal gs_any)) := (match lip return tactic with | lnil => T.idtac | lcons ip lnil => to_tactic ip do_intro | lcons ip lip => to_tactic ip do_intro ;; do_intro lip end%tactic) g. Notation "'pintro' s" := (do_intro s%IP) (at level 100). Notation "'pintros' l1 .. ln" := (do_intro (LIP_app l1%IP .. (LIP_app ln%IP lnil) ..)) (at level 0). Notation "[i: l1 | .. | ln ]" := (mcons (pintros l1) ( .. (mcons (pintros ln) mnil) ..)) (at level 0). (** [act_on x f] pulls all hypotheses until [x] back to the goal, calls [f x], and then pushes back every hypotheses again. *) Definition act_on {A} (x: A) (f: A->tactic) (i: mlist tactic) : tactic := \tactic g=> names <- T.move_until_aux x g; match names with | [m: (m: names, g)] => T.open_and_apply (f x &> i &> T.intros_names names)%tactic g | _ => M.failwith "act_on: impossible" end. Close Scope IP. Mtac2-1.4-coq8.20/theories/tactics/Tactics.v000066400000000000000000000647701472011217100204630ustar00rootroot00000000000000Require Import Strings.String. Require Import ssrmatching.ssrmatching. From Mtac2 Require Export Base. From Mtac2 Require Import Logic Datatypes List Utils Logic Sorts MTeleMatch. From Mtac2.tactics Require Export TacticsBase. Import Sorts.S. Import M.notations. Import Mtac2.lib.List.ListNotations. Import T. Require Import Strings.String. Require Import NArith.BinNat. Require Import NArith.BinNatDef. Set Universe Polymorphism. Unset Universe Minimization ToSet. Module T. Export TacticsBase.T. (** Exceptions *) Mtac Do New Exception IntroDifferentType. Mtac Do New Exception NotAProduct. Mtac Do New Exception CantFindConstructor. Mtac Do New Exception ConstructorsStartsFrom1. Mtac Do New Exception Not1Constructor. Mtac Do New Exception Not2Constructor. Mtac Do New Exception NotThatType. Mtac Do New Exception NoProgress. Mtac Do New Exception GoalNotExistential. Definition SomethingNotRight {A} (t : A) : Exception. exact exception. Qed. Definition CantApply {T1 T2} (x:T1) (y:T2) : Exception. exact exception. Qed. Import ProdNotations. Definition exact {A} (x:A) : tactic := fun g => match g with | Metavar _ _ g => M.inst_cumul_or_fail UniCoq x g;; M.ret [m:] end. Definition eexact {A} (x:A) : tactic := fun g => match g with | Metavar _ _ g => M.cumul_or_fail UniCoq x g;; l <- M.collect_evars g; M.map (fun d => '(Metavar _ _ g) <- M.dyn_to_goal d; M.ret (m: tt, AnyMetavar _ _ g)) l end. (** [intro_base n t] introduces variable or definition named [n] in the context and executes [t n]. Raises [NotAProduct] if the goal is not a product or a let-binding. *) Definition intro_base {A B} (var : name) (t : A -> gtactic B) : gtactic B := fun g => mmatch g return M (mlist (B *m goal gs_any)) with | [? s B (def: B) P e] Metavar s (let x := def in P x) e =n> (* normal match will not instantiate meta-variables from the scrutinee, so we do the inification here*) eqBA <- M.unify_or_fail UniCoq B A; M.nu var (mSome def) (fun x=> let Px := reduce (RedWhd [rl:RedBeta]) (P x) in e' <- M.sorted_evar _ Px; nG <- M.abs_let (P:=P) x def e'; exact nG g;; let x := reduce (RedWhd [rl:RedMatch]) (match eqBA with meq_refl => x end) in t x (Metavar s _ e') >>= let_close_goals x) | [? (s:Sort) (P:_->s) e] Metavar s (ForAll (fun x:A => P x)) e =u> M.nu var mNone (fun x=> let Px := reduce (RedWhd [rl:RedBeta]) (P x) in e' <- M.sorted_evar _ Px; nG <- M.abs_fun (P:=P) x e'; exact nG g;; t x (Metavar s Px e') >>= close_goals x) | [? (s:Sort) B (P:_->s) e] Metavar s (ForAll (fun x:A => P x)) e =u> mtry M.unify_or_fail UniCoq A B;; M.failwith "intros: impossible" with _ => M.raise IntroDifferentType end | _ => M.raise NotAProduct end. Definition intro_cont {A B} (t : A -> gtactic B) : gtactic B := fun g=> n <- M.get_binder_name t; intro_base (TheName n) t g. (** Given a name of a variable, it introduces it in the context *) Definition intro_simpl (var : name) : tactic := fun g => A <- M.evar Type; intro_base var (fun _ : A => idtac) g. (** Introduces an anonymous name based on a binder *) Definition intro_anonymous {A} (T : A) (g : goal gs_open) : M (goal gs_any) := res <- intro_simpl (FreshFrom T) g >>= M.hd; M.ret (msnd res). (** Introduces all hypotheses. Does not fail if there are 0. *) Definition intros_all : tactic := fun '(Metavar _ _ g) => (mfix1 f (g : goal gs_any) : M (mlist (unit *m goal gs_any)) := open_and_apply (fun g : goal gs_open => match g in goal gs return match gs with gs_any => True | gs_open => M (mlist (unit *m goal gs_any)) end with | Metavar s T g' => mtry intro_anonymous T g >>= f with | NotAProduct => M.ret [m:(m: tt,AnyMetavar _ _ g')] end | _ => I (* Should not be necessary! *) end) g) (AnyMetavar _ _ g). (** Introduces up to n binders. Throws [NotAProduct] if there aren't enough products in the goal. *) Definition introsn_cont (cont: tactic) : nat -> tactic := fun n '(Metavar _ _ g) => (mfix2 f (n : nat) (g : goal gs_any) : M (mlist (unit *m goal gs_any)) := open_and_apply (fun g => match n, g with | 0, g => cont g | S n', Metavar s T _ => intro_anonymous T g >>= f n' end) g) n (AnyMetavar _ _ g). Definition introsn := introsn_cont idtac. (** Overloaded binding *) Definition copy_ctx {A} (B : A -> Type) : dyn -> M Type := mfix1 rec (d : dyn) : M Type := mmatch d with | [? c : A] Dyn c => let Bc := reduce (RedWhd [rl:RedBeta]) (B c) in M.ret Bc | [? C (D : C -> Type) (c : forall y:C, D y)] Dyn c => M.nu (FreshFrom c) mNone (fun y=> r <- rec (Dyn (c y)); M.abs_prod_type y r) | [? C D (c : C->D)] Dyn c => M.nu (FreshFrom c) mNone (fun y=> r <- rec (Dyn (c y)); M.abs_prod_type y r) | _ => M.print_term A;; M.raise (SomethingNotRight d) end. (** Generalizes a goal given a certain hypothesis [x]. It does not remove [x] from the goal. *) Definition generalize {A} (x : A) : tactic := fun g => match g with | Metavar Typeₛ P _ => aP <- M.abs_prod_type x P; (* aP = (forall x:A, P) *) e <- M.remove x (M.evar aP); (mtmmatch aP as aP' return aP =m= aP' -> M _ with | [? Q : A -> Type] (forall z:A, Q z) =n> fun H => let e' := reduce (RedWhd [rl:RedMatch]) match H in _ =m= Q return Q with meq_refl _ => e end in exact (e' x) g;; M.ret [m:(m: tt, AnyMetavar Typeₛ _ e)] | _ as _catchall => fun _ => M.failwith "generalize" end) meq_refl | Metavar Propₛ P _ => aP <- M.abs_prod_prop x P; (* aP = (forall x:A, P) *) e <- M.remove x (M.evar aP); (mtmmatch aP as aP' return @meq Prop aP aP' -> M _ with | [? Q : A -> Prop] (forall z:A, Q z) =n> fun H : @meq Prop _ (forall z:A, Q z) => let e' := reduce (RedWhd [rl:RedMatch]) match H in _ =m= Q return Q with meq_refl _ => e end in exact (e' x) g;; M.ret [m:(m: tt, AnyMetavar Propₛ _ e)] | _ as _catchall => fun (H : aP =m= _catchall) => M.failwith "generalize" end) meq_refl end. (** Clear hypothesis [x] and continues the execution on [cont] *) Definition cclear {A B} (x:A) (cont : gtactic B) : gtactic B := fun g=> match g with | Metavar Propₛ gT _ => '(e,l) <- M.remove x ( e <- M.evar gT; l <- cont (Metavar Propₛ _ e); M.ret (e, l)); exact e g;; rem_hyp x l | Metavar Typeₛ gT _ => '(e,l) <- M.remove x ( e <- M.evar gT; l <- cont (Metavar Typeₛ _ e); M.ret (e, l)); exact e g;; rem_hyp x l end. Definition clear {A} (x : A) : tactic := cclear x idtac. Definition apply_params_to_constructors (ind_applied : dyn) (i : Ind_dyn) : M (mlist dyn) := let '(mkInd_dyn _ nparams _ l) := i in rev_params <- (mfix3 go (ind_dyn : _) (acc : _) (n : nat) : M (mlist dyn) := match n with | 0 => M.ret acc | S n => dcase ind_dyn as ind in M.decompose_app'' (S:=fun _ _ => mlist dyn) ind (fun A B f a => go (Dyn f) (Dyn a :m: acc) n ) end ) ind_applied mnil (N.to_nat nparams); let apply_rev_params := ( mfix2 go (params : mlist dyn) (c : _) : M (dyn) := match params with | [m:] => M.ret c | p :m: params => dcase p as P, p in mmatch c with | [? C c] @Dyn (forall p:P, C p) c =u> go params (Dyn (c p)) end end ) in M.map (apply_rev_params rev_params) l. Definition destruct {A : Type} (n : A) : tactic := fun g => let A := reduce (RedWhd [rl:RedBeta]) A in b <- M.is_var n; ctx <- if b then M.hyps_except n else M.hyps; match g in goal gs return match gs with gs_any => True | gs_open => M (mlist (unit *m goal gs_any)) end with | Metavar s gT _ => P <- M.Cevar (A->s) ctx; let Pn := P n in M.unify_or_fail UniCoq Pn gT;; '(mkInd_dyn _ _ _ l as i) <- M.constrs A; l <- apply_params_to_constructors (Dyn A) i; l <- M.map (fun d : dyn => (* a constructor c has type (forall x, ... y, A) and we return (forall x, ... y, P (c x .. y)) *) t' <- copy_ctx P d; e <- M.Cevar t' ctx; M.ret (Dyn e)) l; let c := {| case_ind := A; case_val := n; case_return := Dyn P; case_branches := l |} in case <- M.makecase c; dcase case as e in exact e g;; M.map (fun d => '(Metavar _ _ g) <- M.dyn_to_goal d; M.ret (m: tt, AnyMetavar _ _ g)) l | _ => I (* This makes no sense. It should not be necessary. *) end. (** Destructs the n-th hypotheses in the goal (counting from 0) *) Definition destructn (n : nat) : tactic := bind (introsn n) (fun _ g => A <- M.evar Type; @intro_base A _ (FreshFromStr "tmp") destruct g). (** [apply t] applies theorem t to the current goal. It generates a subgoal for each hypothesis in the theorem. If the hypothesis is introduced by a dependent product (a forall), then no subgoal is generated. If it isn't dependent (a ->), then it is included in the list of next subgoals. *) Definition apply {T} (c : T) : tactic := fun g=> match g with Metavar s t eg => (mfix1 go (d : dyn) : M (mlist (unit *m goal gs_any)) := dcase d as el in (* we don't want to see the S.selem_of term in the user's term, so we reduce it *) let ty := dreduce (@S.selem_of) (S.selem_of t) in mif @M.cumul _ ty UniCoq el eg then M.ret [m:] else mmatch d return M (mlist (unit *m goal gs_any)) with | [? (T1 T2 : Prop) f] @Dyn (T1 -> T2) f => e <- M.evar T1; r <- go (Dyn (f e)); M.ret ((m: tt, AnyMetavar Propₛ _ e) :m: r) | [? (T1 : Prop) (T2 : Type) f] @Dyn (T1 -> T2) f => e <- M.evar T1; r <- go (Dyn (f e)); M.ret ((m: tt, AnyMetavar Propₛ _ e) :m: r) | [? (T1 T2 : Type) f] @Dyn (T1 -> T2) f => e <- M.evar T1; r <- go (Dyn (f e)); M.ret ((m: tt, AnyMetavar Typeₛ _ e) :m: r) | [? (T1 : Type) (T2: T1 -> Prop) f] @Dyn (forall x:T1, T2 x) f => e <- M.evar T1; r <- go (Dyn (f e)); M.ret r | [? (T1 : Type) (T2: T1 -> Type) f] @Dyn (forall x:T1, T2 x) f => e <- M.evar T1; r <- go (Dyn (f e)); M.ret r | _ => gT <- M.goal_type g; M.raise (CantApply T gT) end) (Dyn c) end. Definition apply_ : tactic := fun g => match g with | Metavar _ _ gevar => G <- M.goal_type g; x <- M.solve_typeclass_or_fail G; M.cumul_or_fail UniCoq x gevar;; M.ret [m:] end. Definition change (P : Type) : tactic := fun g => gT <- M.goal_type g; e <- M.evar P; exact e g;; M.ret [m:(m: tt, AnyMetavar Typeₛ _ e)]. Definition destruct_all (T : Type) : tactic := fun g=> l <- M.filter (fun '(@ahyp Th _ _) => r <- M.unify Th T UniCoq; M.ret (option_to_bool r)) =<< M.hyps; (fix f (l : mlist Hyp) : tactic := match l with | [m:] => idtac | ahyp x _ :m: l => bind (destruct x) (fun _ => f l) end) l g. Definition typed_intro (T : Type) : tactic := fun g => U <- M.goal_type g; mmatch U with | [? P:T->Type] forall x:T, P x => intro_simpl (FreshFrom U) g | _ => M.raise NotThatType end. Definition typed_intros (T : Type) : tactic := fun g => (mfix1 f (g : goal gs_open) : M _ := mtry bind (typed_intro T) (fun _ => f) g with | NotThatType => idtac g end) g. (** changes a hypothesis H with one of type Q and the same name *) Definition change_hyp {P Q} (H : P) (newH: Q) : tactic := fun g=> match g with | Metavar sort gT _ => name <- M.get_binder_name H; '(m: gabs, abs) <- M.remove H (M.nu (TheName name) mNone (fun nH: Q=> r <- M.evar gT; abs <- M.abs_fun nH r; gabs <- M.abs_fun nH (AnyMetavar sort _ r); M.ret (m: AHyp gabs, abs))); exact (abs newH) g;; M.ret [m:(m: tt, gabs)] end. Definition cassert_with_base {A B} (name : name) (t : A) (cont : A -> gtactic B) : gtactic B := fun g => M.nu name (mSome t) (fun x=> match g with | Metavar sort gT _ => r <- M.evar gT; value <- M.abs_fun x r; exact (value t) g;; close_goals x =<< cont x (Metavar sort _ r) end). Definition cpose_base {A B} (name : name) (t : A) (cont : A -> gtactic B) : gtactic B := fun g => M.nu name (mSome t) (fun x=> match g with | Metavar sort gT _ => r <- M.evar gT; value <- M.abs_let x t r; exact value g;; let_close_goals x =<< cont x (Metavar sort _ r) end). Definition cpose {A} (t: A) (cont : A -> tactic) : tactic := fun g => cpose_base(FreshFrom cont) t cont g. (* FIX: seriously need to abstract these set of functions! Too much duplication! *) Definition cassert_base {A} (name : name) (cont : A -> tactic) : tactic := fun g => a <- M.evar A; (* [a] will be the goal to solve [A] *) M.nu name mNone (fun x => match g with | Metavar sort gT _ => gT <- M.goal_type g; r <- M.evar gT; (* The new goal now referring to n *) value <- M.abs_fun x r; exact (value a) g;; (* instantiate the old goal with the new one *) v <- cont x (Metavar Typeₛ _ r) >>= close_goals x; M.ret ((m: tt,AnyMetavar Typeₛ _ a) :m: v) end ). (* append the goal for a to the top of the goals *) Definition cassert {A} (cont : A -> tactic) : tactic := fun g=> cassert_base (FreshFrom cont) cont g. (** [cut U] creates two goals with types [U -> T] and [U], where [T] is the type of the current goal. *) Definition cut (U : Type) : tactic := fun g => match g with | Metavar Propₛ T _ => ut <- M.evar (U -> T); u <- M.evar U; exact (ut u) g;; M.ret [m:(m: tt,AnyMetavar Propₛ _ ut)| (m: tt,AnyMetavar Typeₛ _ u)] | Metavar Typeₛ T _ => ut <- M.evar (U -> T); u <- M.evar U; exact (ut u) g;; M.ret [m:(m: tt,AnyMetavar Typeₛ _ ut)| (m: tt,AnyMetavar Typeₛ _ u)] end. (* performs simpl in each hypothesis and in the goal *) Definition simpl_in_all : tactic := fun g => l <- M.fold_right (fun (hyp : Hyp) hyps => let (A, x, ot) := hyp in let A := rsimpl A in M.ret (@ahyp A x ot :m: hyps) ) [m:] =<< M.hyps; match g with | Metavar Propₛ T e' => let T := rsimpl T in e <- M.Cevar T l; (* create the new goal in the new context *) (* we need normal unification since g might be a compound value *) mif M.unify e' e UniMatchNoRed then M.ret [m:(m: tt,AnyMetavar Propₛ _ e)] else M.failwith "simpl_in_all: Prop" | Metavar Typeₛ T e' => let T := rsimpl T in e <- M.Cevar T l; (* create the new goal in the new context *) (* we need normal unification since g might be a compound value *) mif M.unify e' e UniMatchNoRed then M.ret [m:(m: tt,AnyMetavar Typeₛ _ e)] else M.failwith "simpl_in_all: Type" end. Definition reduce_in (r : Reduction) {P} (H : P) : tactic := fun g => let P' := reduce r P in M.replace (A:=P) (B:=P') H meq_refl ( match g with | Metavar Typeₛ gT _ => e <- M.evar gT; oeq <- M.unify (Metavar Typeₛ _ e) g UniCoq; match oeq with | mSome _ => M.ret [m:(m: tt, HypReplace (A:=P) (B:=P') H meq_refl (AnyMetavar Typeₛ _ e))] | _ => M.failwith "reduce_in: impossible" end | Metavar Propₛ gT _ => e <- M.evar gT; oeq <- M.unify (Metavar Propₛ _ e) g UniCoq; match oeq with | mSome _ => M.ret [m:(m: tt, HypReplace (A:=P) (B:=P') H meq_refl (AnyMetavar Propₛ _ e))] | _ => M.failwith "reduce_in: impossible" end end). Definition simpl_in {P} (H : P) : tactic := reduce_in RedSimpl H. (** exists tactic *) Definition mexists {A} (x: A) : tactic := fun g => match g with | Metavar Typeₛ _ _ => P <- M.evar (A -> Type); e <- M.evar _; oeq <- M.unify g (Metavar Typeₛ _ (@existT _ P x e)) UniCoq; match oeq with | mSome _ => M.ret [m:(m: tt,AnyMetavar Typeₛ _ e)] | _ => M.raise GoalNotExistential end | Metavar Propₛ _ _ => P <- M.evar (A -> Prop); e <- M.evar _; oeq <- M.unify g (Metavar Propₛ _ (@ex_intro _ P x e)) UniCoq; match oeq with | mSome _ => M.ret [m:(m: tt,AnyMetavar Propₛ _ e)] | _ => M.raise GoalNotExistential end end. Definition eexists: tactic := fun g=> T <- M.evar Type; x <- M.evar T; l <- mexists x g; let res := dreduce (@mapp) (l +m+ [m:(m: tt, AnyMetavar Typeₛ _ x)]) in M.ret res. (** [n_etas n f] takes a function f with type [forall x1, ..., xn, T] and returns its eta-expansion: [fun x1, ..., xn=>f x1 .. xn]. Raises [NotAProduct] if there aren't that many absractions. *) Definition n_etas (n : nat) {A} (f : A) : M A := (fix loop (n : nat) (d : dynr) : M (typer d) := match n with | 0 => (* we remove the wrapper of the element in [d] *) M.unfold_projection (elemr d) | S n' => mmatch d as d return M (typer d) with | [? B (T:B->Type) f] @Dynr (forall x:B, T x) f => ty <- M.unfold_projection (typer d); M.nu (FreshFrom ty) mNone (fun x:B => loop n' (Dynr (f x)) >>= M.abs_fun x ) | _ => M.raise NotAProduct end end) n (Dynr f). (** [fix_tac f n] is like Coq's [fix] tactic: it generates a fixpoint with a new goal as body, containing a variable named [f] with the current goal as type. The goal is expected to have at least [n] products. *) Definition fix_tac (f : name) (n : N) : tactic := fun g => gT <- M.goal_type g; '(f, new_goal) <- M.nu f mNone (fun f : gT => (* We introduce the recursive definition f and create the new goal having it. *) new_goal <- M.evar gT; (* We need to enclose the body with n-abstractions as required by the fix operator. *) fixp <- n_etas (N.to_nat n) new_goal; fixp <- M.abs_fix f fixp n; (* fixp is now the fixpoint with the evar as body *) (* The new goal is enclosed with the definition of f *) new_goal <- M.abs_fun f (AnyMetavar Typeₛ _ new_goal); M.ret (fixp, AHyp new_goal) ); exact f g;; M.ret [m:(m: tt,new_goal)]. Definition progress {A} (t : gtactic A) : gtactic A := fun '(Metavar _ _ g) => r <- t (Metavar _ _ g); match r with | [m:(m: x,g')] => mmatch AnyMetavar _ _ g with | g' => M.raise NoProgress | _ => M.ret [m:(m: x,g')] end | _ => M.ret r end. (** [repeat t] applies tactic [t] to the goal several times (it should only generate at most 1 subgoal), until no changes or no goal is left. *) Definition repeat (t : tactic) : tactic := fix0 _ (fun rec '(Metavar _ _ g) => r <- filter_goals =<< try t (Metavar _ _ g); (* if it fails, the execution will stop below *) match r with | [m:(m: _,g')] => mmatch AnyMetavar _ _ g with | g' => M.ret [m:(m: tt,AnyMetavar _ _ g)] (* the goal is the exact same, return *) | _ => open_and_apply rec g' end | [m:] => M.ret r | l => (* got several goals, recurse on each *) gs <- M.map (fun '(m: _ , g) =>open_and_apply rec g) l; let res := dreduce (@mconcat, mapp) (mconcat gs) in M.ret res end). Definition map_term (f : forall d:dynr, M d.(typer)) : forall d : dynr, M d.(typer) := mfix1 rec (d : dynr) : M d.(typer) := let (ty, el) := d in mmatch d as d return M d.(typer) with | [? B A (b: B) (a: B -> A)] Dynr (a b) =n> d1 <- rec (Dynr a); d2 <- rec (Dynr b); M.ret (d1 d2) | [? B (A: B -> Type) (a: forall x, A x)] Dynr (fun x:B=>a x) =n> M.nu (FreshFrom el) mNone (fun x : B => d1 <- rec (Dynr (a x)); M.abs_fun x d1) | [? B (A: B -> Type) a] Dynr (forall x:B, a x) =n> M.nu (FreshFrom el) mNone (fun x : B => d1 <- rec (Dynr (a x)); M.abs_prod_type x d1) | [? d'] d' =n> f d' end. Definition unfold_slow {A} (x : A) : tactic := fun g => let def := reduce (RedOneStep [rl:RedDelta]) x in match g with | Metavar Typeₛ gT _ => gT' <- map_term (fun d => let (ty, el) := d in mmatch d as d return M d.(typer) with | Dynr x =n> M.ret def | [? A (d': A)] Dynr d' =n> M.ret d' end) (Dynr gT); e <- M.evar gT'; exact e g;; M.ret [m:(m: tt,AnyMetavar Typeₛ _ e)] | Metavar Propₛ gT _ => gT' <- map_term (fun d => let (ty, el) := d in mmatch d as d return M d.(typer) with | Dynr x =n> M.ret def | [? A (d': A)] Dynr d' =n> M.ret d' end) (Dynr gT); e <- M.evar gT'; exact e g;; M.ret [m:(m: tt,AnyMetavar Propₛ _ e)] end. Definition unfold {A} (x : A) : tactic := fun g => match g with | Metavar Typeₛ gT _ => let gT' := dreduce (x) gT in ng <- M.evar gT'; exact ng g;; M.ret [m:(m: tt, AnyMetavar Typeₛ _ ng)] | Metavar Propₛ gT _ => let gT' := dreduce (x) gT in ng <- M.evar gT'; exact ng g;; M.ret [m:(m: tt, AnyMetavar Propₛ _ ng)] end. Definition unfold_in {A B} (x : A) (h : B) : tactic := reduce_in (RedStrong [rl:RedBeta; RedMatch; RedFix; RedDeltaOnly [rl:Dyn x]]) h. Fixpoint intros_simpl (l : list string) : tactic := match l with | nil => idtac | n :: l => bind (intro_simpl (TheName n)) (fun _ => intros_simpl l) end%list. Fixpoint name_pattern (l : list (list string)) : mlist tactic := match l with | nil => [m:] | ns :: l => intros_simpl ns :m: name_pattern l end%list. Module notations. Export TacticsBase.T.notations. Open Scope tactic_scope. (* We need a fresh evar to be able to use intro with ;; *) Notation "'intro' x" := (T <- M.evar Type; @intro_cont T _ (fun x=>idtac)) (at level 40) : tactic_scope. Notation "'evar_intro_cont' t" := (T <- M.evar Type; @intro_cont T _ t) (at level 40) : tactic_scope. Notation "'intros' x .. y" := (evar_intro_cont (fun x=>.. (evar_intro_cont (fun y=>idtac)) ..)) (at level 0, x binder, y binder, right associativity) : tactic_scope. Notation "'intros'" := intros_all : tactic_scope. Notation "'cintro' x '{-' t '-}'" := (intro_cont (fun x=>t)) (at level 0, right associativity) : tactic_scope. Notation "'cintros' x .. y '{-' t '-}'" := (intro_cont (fun x=>.. (intro_cont (fun y=>t)) ..)) (at level 0, x binder, y binder, t at next level, right associativity) : tactic_scope. Notation "'simpl'" := (treduce RedSimpl) : tactic_scope. Notation "'hnf'" := (treduce RedHNF) : tactic_scope. Notation "'cbv'" := (treduce RedNF) : tactic_scope. Notation "'pose' ( x := t )" := (cpose t (fun x=>idtac)) (at level 40, x at next level) : tactic_scope. Notation "'assert' ( x : T )" := (cassert (fun x:T=>idtac)) (at level 40, x at next level) : tactic_scope. Notation "t 'asp' n" := (seq_list t (name_pattern n%list)) (at level 40) : tactic_scope. End notations. Import notations. Import TacticsBase.T.notations. (* Some derived tactics *) (** Applies reflexivity *) Definition prim_reflexivity : tactic := apply (@Coq.Init.Logic.eq_refl). (** Fist introduces the hypotheses and then applies reflexivity *) Definition reflexivity : tactic := intros_all;; prim_reflexivity. (** Given a list of dyn's, it applies each of them until one succeeds. Throws NoProgress if none apply *) Definition apply_one_of (l : mlist dyn) : tactic := mfold_left (fun a d => dcase d as e in (or a (apply e))) l (T.raise NoProgress). (** Tries to apply each constructor of the goal type *) Definition constructor : tactic := '(mkInd_dyn _ _ _ l) <- M.constrs =<< goal_type; apply_one_of l. Definition apply_in {P Q} (c : P -> Q) (H : P) : tactic := change_hyp H (c H). Definition transitivity {B} (y : B) : tactic := apply (fun x => @Coq.Init.Logic.eq_trans B x y). Definition symmetry : tactic := apply Coq.Init.Logic.eq_sym. Definition symmetry_in {T} {x y: T} (H: x = y) : tactic := apply_in (@Coq.Init.Logic.eq_sym _ _ _) H. Definition exfalso : tactic := apply Coq.Init.Logic.False_ind. Definition nconstructor (n : nat) : tactic := A <- goal_type; match n with | 0 => M.raise ConstructorsStartsFrom1 | S n => '(mkInd_dyn _ _ _ l) <- M.constrs A; match mnth_error l n with | mSome d => dcase d as x in apply x | mNone => raise CantFindConstructor end end. Definition split : tactic := A <- goal_type; '(mkInd_dyn _ _ _ l) <- M.constrs A; match l with | [m:_] => nconstructor 1 | _ => raise Not1Constructor end. Definition left : tactic := A <- goal_type; '(mkInd_dyn _ _ _ l) <- M.constrs A; match l with | d :m: [m: _ ] => dcase d as x in apply x | _ => raise Not2Constructor end. Definition right : tactic := A <- goal_type; '(mkInd_dyn _ _ _ l) <- M.constrs A; match l with | _ :m: [m: d] => dcase d as x in apply x | _ => raise Not2Constructor end. Definition assumption : tactic := A <- goal_type; match_goal with [[ x : A |- A ]] => exact x end. (** Given a type [T] it searches for a hypothesis with that type and executes the [cont]inuation on it. *) Definition select (T : Type) : gtactic T := A <- goal_type; match_goal with [[ x : T |- A ]] => T.ret x end. (** generalize with clear *) Definition cmove_back {A B} (x : A) (cont : gtactic B) : gtactic B := generalize x ;; cclear x cont. Definition move_back {A} (x: A) := cmove_back x idtac. Definition first {B} : mlist (gtactic B) -> gtactic B := fix go l : gtactic B := match l with | [m:] => T.raise NoProgress | x :m: xs => x || go xs end. (** Auxiliar function of [act_on]. It pulls hypotheses until it reaches [x], and returns the names of the once used. *) Definition move_until_aux {A} (x: A) : gtactic (mlist name) := (fix move_until_aux (accu: mlist name) (hyps: mlist Hyp) := \tactic g=> match hyps with | [m: ] => M.raise NotAVar | (ahyp y _ :m: hyps) => mif M.cumul UniMatchNoRed x y then ret accu g else name <- M.pretty_print y; cmove_back y (move_until_aux (TheName name :m: accu) hyps) g end) [m:] =<< M.hyps. (** [move_until x] moves back to the goal as many variables as there are below [x] *) Definition move_until {A} (x: A) : tactic := move_until_aux x;; idtac. (** [intros_names names] introduces as many variables as names in [names] *) Fixpoint intros_names (names : mlist name) : tactic := match names with | [m:] => idtac | name :m: names => T <- M.evar Type; intro_base name (fun x:T=>intros_names names) end. Definition specialize {A B} (f: forall x: A, B x) (x: A) : tactic := mif M.is_var f then let Bx := reduce (RedWhd [rl: RedBeta]) (B x) in change_hyp (Q:=Bx) f (f x) else M.raise NotAVar. End T. Mtac2-1.4-coq8.20/theories/tactics/TacticsBase.v000066400000000000000000000571061472011217100212510ustar00rootroot00000000000000Require Import Strings.String. Require Import ssrmatching.ssrmatching. From Mtac2 Require Export Base. From Mtac2 Require Import Logic Datatypes List Utils Logic intf.Sorts. Import Sorts.S. Import M.notations. Import Mtac2.lib.List.ListNotations. Require Import Strings.String. Require Import NArith.BinNat. Require Import NArith.BinNatDef. Set Universe Polymorphism. Set Polymorphic Inductive Cumulativity. Unset Universe Minimization ToSet. (** Exceptions *) Mtac Do New Exception NoGoalsLeft. Mtac Do New Exception NotSameSize. Mtac Do New Exception DoesNotMatchGoal. Mtac Do New Exception NoPatternMatchesGoal. Import ProdNotations. (** The type for tactics *) Definition gtactic@{a g1 g2} (A: Type@{a}) := goal@{g1 g2} gs_open -> M.t@{a} (mlist@{a} (mprod@{a Set} A (goal@{g1 g2} gs_any))). Definition tactic := gtactic unit. Declare Scope tactic_scope. Delimit Scope tactic_scope with tactic. Bind Scope tactic_scope with gtactic. Module T. Definition with_goal {A} (f : goal gs_open -> M A) (g : goal gs_open) : M.t _ := match g with | Metavar _ _ g' => y <- f g; M.ret [m: (m: y, AnyMetavar _ _ g')] end. Coercion of_M {A} (x : M A) : gtactic A := with_goal (fun _ => x). Definition mtry' {A} (t : gtactic A) (f : Exception -> gtactic A) : gtactic A := fun g => M.mtry' (t g) (fun e => f e g). Definition raise {A} (e : Exception) : gtactic A := M.raise e. Definition fix0 (B : Type) : (gtactic B -> gtactic B) -> gtactic B := @M.fix1 (goal _) (fun _ => mlist (B *m (goal _))). Definition fix1 {A} (B : A -> Type) : ((forall x : A, gtactic (B x)) -> (forall x : A, gtactic (B x))) -> forall x : A, gtactic (B x) := @M.fix2 A (fun _ => (goal _)) (fun x _ => mlist (B x *m (goal _))). Definition fix2 {A1} {A2 : A1 -> Type} (B : forall a1 : A1, A2 a1 -> Type) : ((forall (x1 : A1) (x2 : A2 x1), gtactic (B x1 x2)) -> forall (x1 : A1) (x2 : A2 x1), gtactic (B x1 x2)) -> forall (x1 : A1) (x2 : A2 x1), gtactic (B x1 x2) := @M.fix3 A1 A2 (fun _ _ => (goal _)) (fun x y _ => mlist (B x y *m (goal _))). Definition fix3 {A1} {A2 : A1 -> Type} {A3 : forall a1 : A1, A2 a1 -> Type} (B : forall (a1 : A1) (a2 : A2 a1), A3 a1 a2 -> Type) : ((forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2), gtactic (B x1 x2 x3)) -> forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2), gtactic (B x1 x2 x3)) -> forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2), gtactic (B x1 x2 x3) := @M.fix4 A1 A2 A3 (fun _ _ _ => (goal _)) (fun x y z _ => mlist (B x y z *m (goal _))). Definition fix4 {A1} {A2 : A1 -> Type} {A3 : forall a1 : A1, A2 a1 -> Type} {A4 : forall (a1 : A1) (a2 : A2 a1), A3 a1 a2 -> Type} (B : forall (a1 : A1) (a2 : A2 a1) (a3 : A3 a1 a2), A4 a1 a2 a3 -> Type) : ((forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2) (x4 : A4 x1 x2 x3), gtactic (B x1 x2 x3 x4)) -> forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2) (x4 : A4 x1 x2 x3), gtactic (B x1 x2 x3 x4)) -> forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x1 x2) (x4 : A4 x1 x2 x3), gtactic (B x1 x2 x3 x4) := @M.fix5 A1 A2 A3 A4 (fun _ _ _ _ => (goal _)) (fun x y z z' _ => mlist (B x y z z' *m (goal _))). Local Notation Tpattern A P := (pattern A (fun y => gtactic (P y))). Local Notation Tbranch A P := (branch A (fun y => gtactic (P y))). Fixpoint pattern_map {A} {B : A -> Type} (g : (goal _)) (p : Tpattern A B) : pattern A (fun y => M (mlist (B y *m (goal _)))) := match p with | pany f => pany (fun x => f x g) | pbase x f r => pbase x (f g) r | ptele f => ptele (fun x => pattern_map g (f x)) | psort f => psort (fun s => pattern_map g (f s)) end. Definition branch_map {A} {B} (y : A) (g : (goal _)) (b : branch A (fun a => gtactic (B a))) : branch A (fun y => M (mlist (B y *m (goal _)))) := match b in branch A' P' return forall B : A' -> Type, forall P_eq : P' =m= fun a => gtactic (B a), branch A' (fun y => M (mlist (B y *m (goal _)))) with | @branch_pattern _ _ p => fun B P_eq => let op p := branch_pattern (pattern_map g p) in ltac:(rewrite P_eq in p; refine (op p)) | branch_app_static U ct cont => fun _ P_eq => let cont := ltac:(rewrite P_eq in cont; refine cont) in let cont := MTele.MTele_constmap_app (si:=Typeₛ) Propₛ (fun _ _ => _) ct cont g in @branch_app_static _ _ _ U _ cont | branch_forallP cont => fun _ P_eq => let cont := ltac:(rewrite P_eq in cont; refine cont) in branch_forallP (fun x y => cont x y g) | branch_forallT cont => fun _ P_eq => let cont := ltac:(rewrite P_eq in cont; refine cont) in branch_forallT (fun x y => cont x y g) end B meq_refl. Definition mmatch' {A P} (E : Exception) (y : A) (ps : mlist (Tbranch A P)) : gtactic (P y) := fun g => M.mmatch' E (mmap (branch_map y g) ps) y. Definition mmatch'' {A:Type} {P: A -> Type} (E : Exception) (y : A) (failure : gtactic (P y)) (ps : mlist (Tbranch A P)) : gtactic (P y) := fun g => M.mmatch'' E y (failure g) (mmap (branch_map y g) ps). Module Matcher. Canonical Structure T_Predicate {A} {P : A -> Type} {y : A} : Predicate := PREDICATE (gtactic (P y)). Canonical Structure T_Matcher {A} {y} {P} := MATCHER (@T_Predicate _ _) (gtactic (P y)) (fun E ps => @mmatch' A P E y ps). Canonical Structure T_InDepMatcher {B} := INDEPMATCHER (gtactic B) (fun A y E ps => @mmatch' A (fun _ => B) E y ps). End Matcher. Export Matcher. Definition ret {A} (x : A) : gtactic A := fun '(Metavar _ _ g) => M.ret [m:(m: x, AnyMetavar _ _ g)]. Definition idtac : tactic := ret tt. Definition try (t : tactic) : tactic := fun '(Metavar _ _ g' as g)=> mtry t g with _ => M.ret [m:(m: tt, AnyMetavar _ _ g')] end. Definition or {A} (t u : gtactic A) : gtactic A := fun g=> mtry t g with _ => u g end. Definition get_binder_name {A} (x : A) : gtactic string := fun '(Metavar _ _ g) => s <- M.get_binder_name x; M.ret [m:(m: s,AnyMetavar _ _ g)]. Definition goal_type : gtactic Type := with_goal M.goal_type. Definition goal_prop : gtactic Prop := with_goal M.goal_prop. Definition ltac (t : string) (args : mlist dyn) : tactic := fun g => match g with | Metavar s ty el => '(m: v, l) <- @M.call_ltac s ty t args; M.unify_or_fail UniCoq v el;; let l' := dreduce (@mmap) (mmap (mpair tt) l) in M.ret l' end. Definition treduce (r : Reduction) : tactic := fun g=> match g with | Metavar Typeₛ T e=> let T' := reduce r T in e <- M.evar T'; mif M.cumul UniEvarconv g (Metavar Typeₛ T e) then M.ret [m:(m: tt, AnyMetavar Typeₛ _ e)] else M.failwith "treduce" | Metavar Propₛ T e=> let T' := reduce r T in e <- M.evar T'; mif M.cumul UniEvarconv g (Metavar Propₛ T e) then M.ret [m:(m: tt, AnyMetavar Propₛ _ e)] else M.failwith "treduce" end. (** We wrap "pattern" in two functions: one that abstracts a term from a type (the usual use of pattern), and another one which abstracts a term from another term. For the latter, we need to wrap the term in a type to make it work. *) Ltac Mssrpattern p := ssrpattern p. Definition wrapper {A} (t: A) : Prop. exact False. Qed. Definition Backtrack {A} {B} (x:A) (C : A -> B) : Exception. exact exception. Qed. Definition abstract_from_term_dep {A} {B} (x:A) (y:B) (D : B -> Type) (ok : forall C : A -> B, M (D (C x))) (fail : M (D y)) : M (D y) := mtry '(m: _, gs) <- M.call_ltac Propₛ (A:=wrapper y) "Mssrpattern" [m:Dyn x]; mmatch gs with | [? y (f:A->B) t] [m: AnyMetavar Propₛ (let z := y in wrapper (f z)) t] =u> M.raise (@Backtrack A B y f) (* nasty HACK: we backtract so as not to get evars floating: we only care about the term! (which should be well typed in the right sigma) *) | _ => M.print_term gs;; M.failwith "abstract_from_sort: mmatch goal not ground" end with | [#] @Backtrack A B x | f =u> o <- M.unify (f x) (y) UniCoq; match o with | mSome eq => match eq in _ =m= B return M (D B) with | meq_refl => ok f end | mNone => M.failwith "abstract_from_sort: terms not unifiable" end | ExceptionNotGround => M.failwith "abstract_from_sort: backtrack" | [?s] Failure s => M.raise (Failure s) | [?s] LtacError s => fail (* we suppose it's not matched *) end. Definition abstract_from_sort_dep (s:Sort) {A} (x:A) (B:s) (D : s -> Type) (ok : forall C : A -> s, M (D (C x))) (fail : M (D B)) : M (D B) := abstract_from_term_dep x B D ok fail. Definition abstract_from_sort (s:Sort) {A} (x:A) (B:s) : M (moption (A -> s)) := abstract_from_sort_dep s x B (fun _ => moption (A -> s)) (fun C => M.ret (mSome C)) (M.ret mNone). Definition abstract_from_type {A} := @abstract_from_sort Typeₛ A. Definition abstract_from_term {A} {B} (x:A) (t : B) : M (moption (A -> B)) := abstract_from_term_dep x t (fun _ => _) (fun C => M.ret (mSome C)) (M.ret mNone). (** [close_goals x l] takes the list of goals [l] and appends hypothesis [x] to each of them. *) Definition close_goals {A B} (y : B) : mlist (A *m _) -> M (mlist (A *m _)) := M.map (fun '(m: x,g') => r <- M.abs_fun y g'; M.ret (m: x, @AHyp B r)). (** [let_close_goals x l] takes the list of goals [l] and appends hypothesis [x] with its definition to each of them (it assumes it is defined). *) Definition let_close_goals {A: Type} {B:Type} (y : B) : mlist (A *m goal gs_any) -> M (mlist (mprod A _)) := let t := reduce (RedOneStep [rl:RedDelta]) y in (* to obtain x's definition *) M.map (fun '(m: x,g') => r <- M.abs_let y t g'; M.ret (m: x, HypLet B r)). (** [rem_hyp x l] "removes" hypothesis [x] from the list of goals [l]. *) Definition rem_hyp {A B} (x : B) (l: mlist (A *m goal gs_any)) : M (mlist (A *m goal gs_any)) := let v := dreduce (@mmap) (mmap (fun '(m: y,g) => (m: y, HypRem x g)) l) in M.ret v. (** [rep_hyp x l] "replaces" hypothesis [x] from the list of goals [l]. *) Definition rep_hyp {A B C} (x : A) (e : A =m= B) (l: mlist (C *m goal gs_any)) : M (mlist (C *m goal gs_any)) := let v := dreduce (@mmap) (mmap (fun '(m: y,g) => (m: y, HypReplace x e g)) l) in M.ret v. (** Returns if a goal is open, i.e., a meta-variable. *) Definition is_open : forall {gs}, goal gs -> M bool := mfix2 is_open (gs : _) (g : goal gs) : M _ := match g with | Metavar _ _ e | AnyMetavar _ _ e => M.is_evar e | @AHyp C f => (* we get the name in order to avoid inserting existing names (nu will raise an exception otherwise) *) M.nu Generate mNone (fun x : C => is_open _ (f x)) | HypLet A f => (* we get the name in order to avoid inserting existing names (nu will raise an exception otherwise) *) M.nu_let Generate f (fun _ : A =>is_open _) | HypRem _ g => is_open _ g (* we don't care about the variable *) | HypReplace _ _ g => is_open _ g (* we don't care about the variable *) end. (** removes the goals that were solved *) Definition filter_goals {A} : mlist (A *m goal gs_any) -> M (mlist (A *m goal gs_any)) := M.filter (fun '(m: x,g) => is_open g). (** [open_and_apply t] is a tactic that "opens" the current goal (pushes all the hypotheses in the context) and applies tactic [t] to the so-opened goal. The result is "closed" back. *) Definition open_and_apply@{a+} {A:Type@{a}} (t : gtactic A) : goal gs_any -> M (mlist (A *m goal gs_any)) := mfix1 open (g: goal gs_any) : M _ := match g return M _ with | Metavar _ _ g | AnyMetavar _ _ g => t (Metavar _ _ g) | @AHyp C f => M.nu (FreshFrom f) mNone (fun x : C => open (f x) >>= close_goals x) | HypLet B f => M.nu_let (FreshFrom f) f (fun (x : B) (g : goal gs_any) => open g >>= let_close_goals x) | HypRem x f => M.remove x (open f) >>= rem_hyp x | HypReplace x e f => M.replace x e (open f) >>= rep_hyp x e end. (** Sequencing *) Definition bind@{a b+} {A:Type@{a}} {B:Type@{b}} (t : gtactic A) (f : A -> gtactic B) : gtactic B := fun g => gs <- t g >>= filter_goals; r <- M.map (fun '(m: x,g') => open_and_apply (f x) g') gs; let res := dreduce (@mconcat, mapp) (mconcat r) in M.ret res. Definition fmap {A B} (f : A -> B) (x : gtactic A) : gtactic B := bind x (fun a => ret (f a)). Definition fapp {A B} (f : gtactic (A -> B)) (x : gtactic A) : gtactic B := bind f (fun g => fmap g x). Fixpoint gmap@{a b+} {A:Type@{a}} {B:Type@{b}} (tacs : mlist (gtactic A)) (gs : mlist (B *m goal gs_any)) : M (mlist (mlist (A *m goal gs_any))) := match tacs, gs with | [m:], [m:] => M.ret [m:] | tac :m: tacs', (m: _, g) :m: gs' => mcons <$> open_and_apply tac g <*> gmap tacs' gs' | _, _ => M.raise NotSameSize end. Class Seq (A B C : Type) : Prop := seq : gtactic A -> C -> gtactic B. Arguments seq {A B C _} _%tactic _%tactic. #[global] Instance seq_one@{a b+} {A:Type@{a}} {B:Type@{b}} : Seq A B (gtactic B) := fun t1 t2 => bind t1 (fun _ => t2). #[global] Instance seq_list@{a b+} {A:Type@{a}} {B:Type@{b}} : Seq A B (mlist (gtactic B)) := fun t f g => gs <- t g >>= filter_goals; ls <- gmap f gs; let res := dreduce (@mconcat, mapp) (mconcat ls) in M.ret res. (** match_goal *) Inductive goal_pattern (B : Type) : Prop := | gbase : forall {A}, A -> gtactic B -> goal_pattern B | gbase_context : forall {A}, A -> ((A -> Type) -> gtactic B) -> goal_pattern B | gtele : forall {C}, (C -> goal_pattern B) -> goal_pattern B | gtele_evar : forall {C}, (C -> goal_pattern B) -> goal_pattern B. Arguments gbase {B A} _ _. Arguments gbase_context {B} {A} _ _. Arguments gtele {B C} _. Arguments gtele_evar {B C} _. Definition match_goal_context@{c a+} (s2:Sort) {C:Type@{c}}{A:Type@{a}} (x: A) (y: s2) (cont: (A -> s2) -> gtactic C) : gtactic C := fun g=> r <- abstract_from_sort s2 x y; match r with | mSome r => cont r g | mNone => M.raise DoesNotMatchGoal end. Fixpoint match_goal_pattern'@{b+} {B:Type@{b}} (u : Unification) (p : goal_pattern B) : mlist Hyp -> mlist Hyp -> gtactic B := fix go l1 l2 g := match p, l2 with | gbase P t, _ => gT <- M.goal_type g; mif M.cumul u P gT then t g else M.raise DoesNotMatchGoal | gbase_context x t, _ => match g with | Metavar Propₛ gT _ => (fun (A : Prop) => match_goal_context Propₛ x A t g) gT | Metavar Typeₛ gT _ => (fun (A : Type) => match_goal_context Typeₛ x A t g) gT end | @gtele _ C f, @ahyp A a d :m: l2' => oeqCA <- M.unify C A u; match oeqCA with | mSome eqCA => let a' := rcbv match meq_sym eqCA with meq_refl => a end in mtry match_goal_pattern' u (f a') [m:] (mrev_append l1 l2') g with DoesNotMatchGoal => go (ahyp a d :m: l1) l2' g end | mNone => go (ahyp a d :m: l1) l2' g end | @gtele_evar _ C f, _ => e <- M.evar C; match_goal_pattern' u (f e) l1 l2 g | _, _ => M.raise DoesNotMatchGoal end. Definition match_goal_pattern {B} (u : Unification) (p : goal_pattern B) : gtactic B := fun g=> r <- M.hyps; match_goal_pattern' u p [m:] (mrev' r) g. Fixpoint match_goal_base {B} (u : Unification) (ps : mlist (goal_pattern B)) : gtactic B := fun g => match ps with | [m:] => M.raise NoPatternMatchesGoal | p :m: ps' => mtry match_goal_pattern u p g with DoesNotMatchGoal => match_goal_base u ps' g end end. Definition print_goal : tactic := with_goal M.print_goal. (** Type for goal manipulation primitives *) Definition selector A := mlist (A *m goal gs_any) -> M (mlist (A *m goal gs_any)). #[global] Instance tactic_selector@{a+} {A : Type@{a}} : Seq A A (selector A) := fun t s g => t g >>= filter_goals >>= s. Module S. Definition nth {A} (n : nat) (f : A -> gtactic A) : selector A := fun l => let (l1, l2) := dreduce (@nsplit) (nsplit n l) in match mhd_error l2 with | mNone => M.raise NoGoalsLeft | mSome (m: x, g) => goals <- open_and_apply (f x) g; let res := dreduce (@mapp, @mtl) (l1 +m+ goals +m+ mtl l2) in filter_goals res end. Definition last {A} (t : gtactic A) : selector A := fun l => let n := dreduce (pred, mlength) (pred (mlength l)) in nth n (fun _=>t) l. Definition first {A} (t : gtactic A) : selector A := nth 0 (fun _=>t). Definition rev {A} : selector A := fun l => let res := dreduce (@mrev', @mrev_append, @mapp) (mrev' l) in M.ret res. End S. Module notations. Open Scope tactic_scope. (* This notation makes sure that [t] is in [MC] scope ands casts the resulting lambda into a [tactic] to make sure that it can be ran. *) Notation "\tactic g => t" := ((fun g => t%MC) : gtactic _) (at level 200, g at level 0, right associativity). Notation "r '<-' t1 ';' t2" := (bind t1 (fun r => t2%tactic)) (at level 20, t1 at level 100, t2 at level 200, format "'[' r '<-' '[' t1 ; ']' ']' '/' t2 ") : tactic_scope. (* Notation "' r1 .. rn '<-' t1 ';' t2" := (bind t1 (fun r1 => .. (fun rn => t2%tactic) ..)) *) (* (at level 20, r1 binder, rn binder, t1 at level 100, t2 at level 200, *) (* format "'[' ''' r1 .. rn '<-' '[' t1 ; ']' ']' '/' t2 ") : tactic_scope. *) Notation "' r '<-' t1 ';' t2" := (bind t1 (fun r=> t2%tactic)) (at level 20, r pattern, t1 at level 100, t2 at level 200, right associativity, format "'[' ''' r '<-' '[' t1 ; ']' ']' '/' t2 ") : tactic_scope. Notation "` r1 .. rn '<-' t1 ';' t2" := (bind t1 (fun r1 => .. (bind t1 (fun rn => t2%tactic)) ..)) (at level 20, r1 binder, rn binder, t1 at level 100, t2 at level 200, right associativity, format "'[' '`' r1 .. rn '<-' '[' t1 ; ']' ']' '/' t2 ") : tactic_scope. Notation "f =<< t" := (bind t f) (at level 70, only parsing) : tactic_scope. Notation "t >>= f" := (bind t f) (at level 70) : tactic_scope. Infix "<$>" := fmap (at level 61, left associativity) : tactic_scope. Infix "<*>" := fapp (at level 61, left associativity) : tactic_scope. Notation "t1 ';;' t2" := (seq t1 t2) (at level 100, t2 at level 200, right associativity, format "'[' '[' t1 ;; ']' ']' '/' t2 ") : tactic_scope. Notation "'mif' b 'then' t 'else' u" := (cond <- b; if cond then t else u) (at level 200) : tactic_scope. Notation "'mfix0' f : 'gtactic' T := b" := (fix0 T%type (fun f => b%tactic)) (at level 200, f ident, format "'[v ' 'mfix0' f ':' 'gtactic' T ':=' '/ ' b ']'") : tactic_scope. Notation "'mfix1' f x .. y : 'gtactic' T := b" := (fix1 (fun x => .. (fun y => T%type) ..) (fun f x => .. (fun y => b%tactic) ..)) (at level 200, f ident, x binder, y binder, format "'[v ' 'mfix1' f x .. y ':' 'gtactic' T ':=' '/ ' b ']'") : tactic_scope. Notation "'mfix2' f x .. y : 'gtactic' T := b" := (fix2 (fun x => .. (fun y => T%type) ..) (fun f x => .. (fun y => b%tactic) ..)) (at level 200, f ident, x binder, y binder, format "'[v ' 'mfix2' f x .. y ':' 'gtactic' T ':=' '/ ' b ']'") : tactic_scope. Notation "'mfix3' f x .. y : 'gtactic' T := b" := (fix3 (fun x => .. (fun y => T%type) ..) (fun f x => .. (fun y => b%tactic) ..)) (at level 200, f ident, x binder, y binder, format "'[v ' 'mfix3' f x .. y ':' 'gtactic' T ':=' '/ ' b ']'") : tactic_scope. Notation "'mfix4' f x .. y : 'gtactic' T := b" := (fix4 (fun x => .. (fun y => T%type) ..) (fun f x => .. (fun y => b%tactic) ..)) (at level 200, f ident, x binder, y binder, format "'[v ' 'mfix4' f x .. y ':' 'gtactic' T ':=' '/ ' b ']'") : tactic_scope. Notation "'mtry' a 'with' ls 'end'" := (mtry' a (fun e => (@mmatch'' _ (fun _ => _) M.NotCaught e (T.raise e) ls))) (at level 200, a at level 100, ls custom Mtac2_with_branch at level 91, only parsing) : tactic_scope. Notation "t || u" := (or t u) : tactic_scope. Declare Scope match_goal_pattern_scope. Notation "[[ |- ps ] ] => t" := (gbase ps t) (at level 202, ps at next level) : match_goal_pattern_scope. Notation "[[? a .. b | x .. y |- ps ] ] => t" := (gtele_evar (fun a => .. (gtele_evar (fun b => gtele (fun x => .. (gtele (fun y => gbase ps t)).. ))).. )) (at level 202, a binder, b binder, x binder, y binder, ps at next level) : match_goal_pattern_scope. Notation "[[? a .. b |- ps ] ] => t" := (gtele_evar (fun a => .. (gtele_evar (fun b => gbase ps t)).. )) (at level 202, a binder, b binder, ps at next level) : match_goal_pattern_scope. Notation "[[ x .. y |- ps ] ] => t" := (gtele (fun x => .. (gtele (fun y => gbase ps t)).. )) (at level 202, x binder, y binder, ps at next level) : match_goal_pattern_scope. Notation "[[ |- 'context' C [ ps ] ] ] => t" := (gbase_context ps (fun C => t)) (at level 202, C at level 0, ps at next level) : match_goal_pattern_scope. Notation "[[? a .. b | x .. y |- 'context' C [ ps ] ] ] => t" := (gtele_evar (fun a => .. (gtele_evar (fun b => gtele (fun x=> .. (gtele (fun y => gbase_context ps (fun C => t))).. ))).. )) (at level 202, a binder, b binder, x binder, y binder, C at level 0, ps at next level) : match_goal_pattern_scope. Notation "[[? a .. b |- 'context' C [ ps ] ] ] => t" := (gtele_evar (fun a => .. (gtele_evar (fun b => gbase_context ps (fun C => t))).. )) (at level 202, a binder, b binder, C at level 0, ps at next level) : match_goal_pattern_scope. Notation "[[ x .. y |- 'context' C [ ps ] ] ] => t" := (gtele (fun x=> .. (gtele (fun y => gbase_context ps (fun C => t))).. )) (at level 202, x binder, y binder, C at level 0, ps at next level) : match_goal_pattern_scope. Delimit Scope match_goal_pattern_scope with match_goal_pattern. Declare Scope match_goal_with_scope. Notation "'with' | p1 | .. | pn 'end'" := ((@mcons (goal_pattern _) p1%match_goal_pattern (.. (@mcons (goal_pattern _) pn%match_goal_pattern [m:]) ..))) (at level 91, p1 at level 210, pn at level 210) : match_goal_with_scope. Notation "'with' p1 | .. | pn 'end'" := ((@mcons (goal_pattern _) p1%match_goal_pattern (.. (@mcons (goal_pattern _) pn%match_goal_pattern [m:]) ..))) (at level 91, p1 at level 210, pn at level 210) : match_goal_with_scope. Delimit Scope match_goal_with_scope with match_goal_with. Notation "'match_goal' ls" := (match_goal_base UniCoq ls%match_goal_with) (at level 200, ls at level 91) : tactic_scope. Notation "'match_goal_nored' ls" := (match_goal_base UniMatchNoRed ls%match_goal_with) (at level 200, ls at level 91) : tactic_scope. (* Note that unlike the monadic ;; notation, this one is left associative. This is needed so that we can nest tactics accordingly, for example: split &> idtac &> [idtac; idtac] &> [idtac; idtac] *) Notation "t1 '&>' ts" := (seq t1 ts) (at level 41, left associativity) : tactic_scope. Notation "t1 '|1>' t2" := (t1 &> S.nth 0 (fun _=>t2)) (at level 41, left associativity, t2 at level 100) : tactic_scope. Notation "t1 '|2>' t2" := (t1 &> S.nth 1 (fun _=>t2)) (at level 41, left associativity, t2 at level 100) : tactic_scope. Notation "t1 '|3>' t2" := (t1 &> S.nth 2 (fun _=>t2)) (at level 41, left associativity, t2 at level 100) : tactic_scope. Notation "t1 '|4>' t2" := (t1 &> S.nth 3 (fun _=>t2)) (at level 41, left associativity, t2 at level 100) : tactic_scope. Notation "t1 '|5>' t2" := (t1 &> S.nth 4 (fun _=>t2)) (at level 41, left associativity, t2 at level 100) : tactic_scope. Notation "t1 '|6>' t2" := (t1 &> S.nth 5 (fun _=>t2)) (at level 41, left associativity, t2 at level 100) : tactic_scope. Notation "t1 'l>' t2" := (t1 &> S.last t2) (at level 41, left associativity, t2 at level 100) : tactic_scope. Import MTele.TeleNotation. Notation "'dcase' v 'as' A ',' x 'in' t" := (fun g => @M.decompose_app' _ (fun _ => _) [tele A (_:A)] UniMatchNoRed v (@Dyn) (fun A x => t g)) (at level 91, t at level 200) : tactic_scope. Notation "'dcase' v 'as' x 'in' t" := (dcase v as _, x in t) (at level 91, t at level 200) : tactic_scope. End notations. End T. Export T.Matcher. Coercion T.of_M : M >-> gtactic. Mtac2-1.4-coq8.20/theories/tactics/Ttactics.v000066400000000000000000000336041472011217100206370ustar00rootroot00000000000000From Mtac2 Require Import Base Datatypes List Sorts tactics.Tactics. Require Import Strings.String. Import Sorts.S. Import Mtac2.lib.List.ListNotations. Import ProdNotations. Import Tactics.T. Import M. Import M.notations. Set Universe Polymorphism. Unset Universe Minimization ToSet. Module TT. (** A typed tactic is a program that promises in its type the goal it solves, pehaps creating (dynamically-typed) goals. *) Definition ttac A := M (A *m mlist (goal gs_any)). Declare Scope typed_tactic_scope. Bind Scope typed_tactic_scope with ttac. Delimit Scope typed_tactic_scope with TT. (** [to_goal A] returns an evar with type A, and a the [goal] based on it. It tries to coerce [A] into a [Prop] first, in order to provide the most precise goal possible. For that, we need to backtrack in case it is not a [Prop] (and treat it as a [Type]). *) Mtac Do New Exception NotAProp. Definition to_goal (A : Type) : M (A *m goal gs_open) := mtry P <- evar Prop; of <- unify_cumul P A UniMatchNoRed; match of with | mSome f => a <- M.evar P; let a' := reduce (RedOneStep [rl: RedBeta]) (f a) in ret (m: a', Metavar Propₛ _ a) | mNone => raise NotAProp (* we backtrack to erase P *) end with [#] NotAProp | =n> a <- evar A; M.ret (m: a, Metavar Typeₛ _ a) end. (** [demote] is a [ttac] that proves anything by simply postponing it as a goal. *) Definition demote {A: Type} : ttac A := '(m: a, g) <- to_goal A; let '(Metavar _ _ g) := g in M.ret (m: a, [m: AnyMetavar _ _ g]). (** [use t] tries to solve the goal with tactic [t] *) Definition use {A} (t : tactic) : ttac A := '(m: a, g) <- to_goal A; gs <- t g; let gs := dreduce (@mmap) (mmap (fun '(m: _, g) => g) gs) in M.ret (m: a, gs). Arguments use [_] _%tactic. Definition idtac {A} : ttac A := '(m: a, g) <- to_goal A; let '(Metavar _ _ g) := g in M.ret (m: a, [m: AnyMetavar _ _ g]). (** [by'] is like [use] but it ensures there are no goals left. *) Definition by' {A} (t : tactic) : ttac A := '(m: a, g) <- to_goal A; gs <- t g; gs' <- T.filter_goals gs; match gs' with | [m:] => ret (m: a, [m:]) | _ => failwith "couldn't solve" end. Arguments by' [_] _%tactic. (** Coercion between an [M] program and a [ttac] *) Definition lift {A} (t : M A) : ttac A := t >>= (fun a => M.ret (m: a, [m:])). Coercion lift : M.t >-> ttac. (** The composition operator. It combines the subgoals according to function [comb]. *) Definition fappgl {A B C} (comb : C -> C -> M C) (f : M ((A -> B) *m C)) (x : M (A *m C)) : M (B *m C) := (f >>= (fun '(m: b, cb) => '(m: a, ca) <- x; c <- comb cb ca; M.ret (m: b a, c) ) )%MC. Definition Mappend {A} (xs ys : mlist A) := let zs := dreduce (@mapp) (mapp xs ys) in M.ret zs. (** [to_T t] uses the result of a [ttac] as a [tactic]. *) Definition to_T {A} : (A *m mlist (goal _)) -> tactic := (fun '(m: a, gs) g => exact a g;; let gs := dreduce (@mmap) (mmap (mpair tt) gs) in M.ret gs )%MC. Definition apply {A} (a : A) : ttac A := M.ret (m: a, [m:]). Definition apply_ {A} : ttac A := by' apply_. Definition try {A} (t : ttac A) : ttac A := mtry t with _ => demote : M _ end. Mtac Do New Exception TTchange_Exception. Definition change A {B} (f : ttac A) : ttac B := (oeq <- M.unify A B UniCoq; match oeq with | mSome eq => match eq in Logic.meq _ X return ttac X with | Logic.meq_refl => f end | mNone => M.raise TTchange_Exception end )%MC. Definition change_dep {X} (B : X -> Type) x {y} (f : ttac (B x)) : ttac (B y) := ( e <- M.unify x y UniCoq; match e with | mSome e => match e in Logic.meq _ z return ttac (B z) with | Logic.meq_refl => f end | mNone => M.raise TTchange_Exception end )%MC. Definition vm_compute {A} : ttac (A -> A) := ( M.ret (m: (fun a : A => a <: A), [m:]) )%MC. Definition vm_change_dep {X} (B : X -> Type) x {y} (f : ttac (B x)) : ttac (B y) := ( let x' := reduce RedVmCompute x in let y' := reduce RedVmCompute y in e <- M.unify x' y' UniMatchNoRed; match e with | mSome e => match e in Logic.meq _ z return ttac (B z) with | Logic.meq_refl => f end | mNone => M.raise TTchange_Exception end )%MC. Definition tintro {A P} (f: forall (x:A), ttac (P x)) : ttac (forall (x:A), P x) := M.nu (FreshFrom f) mNone (fun x=> '(m: v, gs) <- f x; a <- M.abs_fun x v; b <- T.close_goals x (mmap (fun g=>(m: tt, g)) gs); let b := mmap msnd b in M.ret (m: a, b)). Definition tpass {A} := lift (M.evar A). Definition texists {A} {Q:A->Prop} : ttac (exists (x:A), Q x) := e <- M.evar A; pf <- M.evar (Q e); M.ret (m: ex_intro _ e pf, [m: AnyMetavar Propₛ _ pf]). Definition tassumption {A:Type} : ttac A := lift (M.select _). Definition tor {A:Type} (t u : ttac A) : ttac A := mtry r <- t; M.ret r with _ => r <- u; M.ret r end. Definition reflexivity {P} {A B : P} : TT.ttac (A = B) := r <- M.coerce (eq_refl A); M.ret (m: r, [m:]). Require Import Strings.String. Definition ucomp1 {A B} (t: ttac A) (u: ttac B) : ttac A := '(m: v1, gls1) <- t; match gls1 with | [m: gl] => '(m: v2, gls) <- u; open_and_apply (exact v2) gl;; M.ret (m: v1, gls) | _ => mfail "more than a goal"%string end. Definition lower {A} (t: ttac A) : M A := '(m: r, _) <- t; ret r. (** [rewrite] allows to rewrite with an equation in a specific part of the goal. *) Definition rewrite {X : Type} (C : X -> Type) {a b : X} (H : a = b) : ttac (C b) -> ttac (C a) := fun t => '(m: x, gs) <- t; M.ret (m: match H in _ = z return (C z) -> (C a) with | eq_refl => fun x => x end x, gs). (** with_goal_prop is an easy way of focusing on the current goal to go from [tactic] to [ttac]. It is cheap when the goal is correctly annotated as a Prop and no more expensive than focusing via `match_goal` when it isn't. *) Definition with_goal_prop (F : forall (P : Prop), ttac P) : tactic := fun g => match g with | Metavar Propₛ G g => '(m: x, gs) <- F G; M.inst_cumul_or_fail UniCoq x g;; M.map (fun g => M.ret (m:tt,g)) gs | Metavar Typeₛ G g => gP <- evar Prop; mtry inst_cumul_or_fail UniMatch gP G;; '(m: x, gs) <- F gP; M.inst_cumul_or_fail UniCoq x g;; M.map (fun g => M.ret (m:tt,g)) gs with _ => raise CantCoerce end (* its better to raise CantCoerce than NotCumul *) end. (** with_goal_type is an easy way of focusing on the current goal to go from [tactic] to [ttac]. It is always cheap and will upcast props. *) Definition with_goal_type (F : forall (T : Type), ttac T) : tactic := fun g => match g with | Metavar Propₛ G g => '(m: x, gs) <- F G; M.inst_cumul_or_fail UniCoq x g;; M.map (fun g => M.ret (m:tt,g)) gs | Metavar Typeₛ G g => gP <- evar Prop; mtry inst_cumul_or_fail UniMatch gP G;; '(m: x, gs) <- F G; M.inst_cumul_or_fail UniCoq x g;; M.map (fun g => M.ret (m:tt,g)) gs with _ => raise CantCoerce end (* its better to raise CantCoerce than NotCumul *) end. Definition with_goal_sort (F : forall {s : Sort} (T : s), ttac T) (e : Exception) : tactic := fun g => match g with | Metavar s T g => '(m: t, gs) <- F T; o <- M.inst_evar g t; match o with | mSome _ => gs <- M.map (fun x => M.ret (mpair tt x)) gs; M.ret gs | mNone => raise e end end. Definition with_goal_type' (F : forall T, ttac T) (e : Exception) : tactic := fun g => match g with | Metavar Propₛ T g => '(m: t, gs) <- F T; o <- M.inst_evar g t; match o with | mSome _ => gs <- M.map (fun x => M.ret (mpair tt x)) gs; M.ret gs | mNone => raise e end | Metavar Typeₛ T g => '(m: t, gs) <- F T; o <- M.inst_evar g t; match o with | mSome _ => gs <- M.map (fun x => M.ret (mpair tt x)) gs; M.ret gs | mNone => raise e end end. Module MatchGoalTT. Import TacticsBase.T.notations. Import Mtac2.lib.Logic. Inductive goal_pattern : Prop := | gbase : forall (A : _), ttac A -> goal_pattern | gbase_context : forall {A} (a : A), (forall (C : A -> Type), ttac (C a)) -> goal_pattern | gtele : forall {C}, (C -> goal_pattern) -> goal_pattern | gtele_evar : forall {C}, (C -> goal_pattern) -> goal_pattern. Arguments gbase _ _. Arguments gbase_context {A} _ _. Arguments gtele {C} _. Arguments gtele_evar {C} _. Set Printing Implicit. (* [with_upcast] is necessary to call the continuation in [gbase_context] on a sorted goal after abstracting from the goal. It avoids a [selem_of] coercion that would otherwise be introduced. *) Definition with_upcast {s : Sort} {A} {a : A} : (forall (C : A -> Type), ttac (C a)) -> forall C : (A -> s), ttac (C a) := match s with | Propₛ => fun t (f : A -> Prop) => t f | Typeₛ => fun t (f : A -> Type) => t f end. Fixpoint match_goal_pattern' (u : Unification) (p : goal_pattern) : mlist Hyp -> mlist Hyp -> tactic := fix go l1 l2 g := match p, l2 with | gbase P t, _ => with_goal_type' ( fun G => o <- M.unify_cumul P G u; match o with | mSome f => '(m: p, gs) <- t; let fp := reduce (RedOneStep [rl:RedBeta]) (f p) in M.ret (m: fp, gs) | mNone => raise DoesNotMatchGoal end ) (DoesNotMatchGoal) g | gbase_context x t, _ => with_goal_sort ( fun s G => T.abstract_from_sort_dep s x G (fun C => C *m mlist (goal gs_any)) (* avoid [selem_of] coercions *) (with_upcast t) (raise DoesNotMatchGoal) ) (DoesNotMatchGoal) g | @gtele C f, @ahyp A a d :m: l2' => oeqCA <- M.unify C A u; match oeqCA with | mSome eqCA => let a' := rcbv match Logic.meq_sym eqCA in _ =m= X return X with meq_refl => a end in mtry match_goal_pattern' u (f a') [m:] (mrev_append l1 l2') g with [#] DoesNotMatchGoal | =n> go (ahyp a d :m: l1) l2' g end | mNone => go (ahyp a d :m: l1) l2' g end | @gtele_evar C f, _ => e <- M.evar C; match_goal_pattern' u (f e) l1 l2 g | _, _ => M.raise DoesNotMatchGoal end%MC. Definition match_goal_pattern (u : Unification) (p : goal_pattern) : tactic := fun g=> (r <- M.hyps; match_goal_pattern' u p [m:] (mrev' r) g)%MC. Fixpoint match_goal_base (u : Unification) (ps : mlist (goal_pattern)) : tactic := fun g => match ps with | [m:] => M.raise NoPatternMatchesGoal | p :m: ps' => mtry match_goal_pattern u p g with [#] DoesNotMatchGoal | =n> match_goal_base u ps' g end end%MC. End MatchGoalTT. Import MatchGoalTT. Arguments match_goal_base _ _%TT. Module notations. (* Notation "[t: x | .. | y ]" := (TT.compi x (.. (TT.compi y (M.ret I)) ..)). *) (* Set Warnings "(-[non-reversible-notation,parsing])". *) (* Notation "'doTT' t" := (ltac:(mrun (doTT t))) (at level 0). *) Infix "<**>" := (fappgl Mappend) (at level 61, left associativity) : M_scope. Infix "&**" := ucomp1 (at level 60) : M_scope. Infix "||t" := tor (at level 59) : M_scope. Declare Scope typed_match_goal_pattern_scope. Notation "[[ |- ps ] ] => t" := (gbase ps t) (at level 202, ps at next level) : typed_match_goal_pattern_scope. Notation "[[? a .. b | x .. y |- ps ] ] => t" := (gtele_evar (fun a => .. (gtele_evar (fun b => gtele (fun x => .. (gtele (fun y => gbase ps t)).. ))).. )) (at level 202, a binder, b binder, x binder, y binder, ps at next level) : typed_match_goal_pattern_scope. Notation "[[? a .. b |- ps ] ] => t" := (gtele_evar (fun a => .. (gtele_evar (fun b => gbase ps t)).. )) (at level 202, a binder, b binder, ps at next level) : typed_match_goal_pattern_scope. Notation "[[ x .. y |- ps ] ] => t" := (gtele (fun x => .. (gtele (fun y => gbase ps t)).. )) (at level 202, x binder, y binder, ps at next level) : typed_match_goal_pattern_scope. Notation "[[ |- 'context' C [ ps ] ] ] => t" := (gbase_context ps (fun C => t)) (at level 202, C at level 0, ps at next level) : typed_match_goal_pattern_scope. Notation "[[? a .. b | x .. y |- 'context' C [ ps ] ] ] => t" := (gtele_evar (fun a => .. (gtele_evar (fun b => gtele (fun x=> .. (gtele (fun y => gbase_context ps (fun C => t))).. ))).. )) (at level 202, a binder, b binder, x binder, y binder, C at level 0, ps at next level) : typed_match_goal_pattern_scope. Notation "[[? a .. b |- 'context' C [ ps ] ] ] => t" := (gtele_evar (fun a => .. (gtele_evar (fun b => gbase_context ps (fun C => t))).. )) (at level 202, a binder, b binder, C at level 0, ps at next level) : typed_match_goal_pattern_scope. Notation "[[ x .. y |- 'context' C [ ps ] ] ] => t" := (gtele (fun x=> .. (gtele (fun y => gbase_context ps (fun C => t))).. )) (at level 202, x binder, y binder, C at level 0, ps at next level) : typed_match_goal_pattern_scope. Delimit Scope typed_match_goal_pattern_scope with typed_match_goal_pattern. Declare Scope typed_match_goal_with_scope. Notation "'with' | p1 | .. | pn 'end'" := ((@mcons (goal_pattern) p1%typed_match_goal_pattern (.. (@mcons (goal_pattern) pn%typed_match_goal_pattern [m:]) ..))) (at level 91, p1 at level 210, pn at level 210) : typed_match_goal_with_scope. Notation "'with' p1 | .. | pn 'end'" := ((@mcons (goal_pattern) p1%typed_match_goal_pattern (.. (@mcons (goal_pattern) pn%typed_match_goal_pattern [m:]) ..))) (at level 91, p1 at level 210, pn at level 210) : typed_match_goal_with_scope. Delimit Scope typed_match_goal_with_scope with typed_match_goal_with. Notation "'match_goal' ls" := (match_goal_base UniCoq ls%typed_match_goal_with) (at level 200, ls at level 91) : typed_tactic_scope. Notation "'match_goal_nored' ls" := (match_goal_base UniMatchNoRed ls%typed_match_goal_with) (at level 200, ls at level 91) : typed_tactic_scope. End notations. End TT. Mtac2-1.4-coq8.20/timings/000077500000000000000000000000001472011217100150625ustar00rootroot00000000000000Mtac2-1.4-coq8.20/timings/decapp_vs_mmatch.v000066400000000000000000000045331472011217100205530ustar00rootroot00000000000000From Mtac2 Require Import Mtac2 DecomposeApp. Fixpoint goal n := match n with | 0 => True | S n' => goal n' /\ goal n' end. Import M.notations. Definition with_mmatch: forall {P:Prop}, M P := mfix1 f (P: Prop) : M P := mmatch P as P' return M (P':Prop) with | True => M.ret I | [? Q R] Q /\ R => r1 <- f Q; r2 <- f R; M.ret (conj r1 r2) end. Definition with_decapp: forall {P:Prop}, M P := mfix1 f (P: Prop) : M P := mtry <[decapp P return (fun P':Prop=>P') with True]>%MC UniMatchNoRed (M.ret I) with WrongTerm => <[decapp P return (fun P':Prop=>P') with and]>%MC UniMatchNoRed (fun Q R => r1 <- f Q; r2 <- f R; M.ret (conj r1 r2) ) end. (* Section Mmatch. Example test1_mmatch : goal 10. MProof. cbv. Time with_mmatch. Qed. Example test11_mmatch : goal 11. MProof. cbv. Time with_mmatch. Qed. Example test12_mmatch : goal 12. MProof. cbv. Time with_mmatch. Qed. Example test13_mmatch : goal 13. MProof. cbv. Time with_mmatch. Qed. Example test14_mmatch : goal 14. MProof. cbv. Time with_mmatch. Qed. Example test15_mmatch : goal 15. MProof. cbv. Time with_mmatch. Qed. End Mmatch. Section Decapp. Example test1_decapp : goal 10. MProof. cbv. Time with_decapp. Qed. Example test11_decapp : goal 11. MProof. cbv. Time with_decapp. Qed. Example test12_decapp : goal 12. MProof. cbv. Time with_decapp. Qed. Example test13_decapp : goal 13. MProof. cbv. Time with_decapp. Qed. Example test14_decapp : goal 14. MProof. cbv. Time with_decapp. Qed. Example test15_decapp : goal 15. MProof. cbv. Time with_decapp. Qed. End Decapp. *) Require Import Strings.String. Fixpoint pollute n := match n with | 0 => goal 10 | S n' => nat -> pollute n' end. Module MmatchM. Example test1_mmatch : pollute 10. Proof. cbv. intros. Time mrun with_mmatch. Qed. Example test11_mmatch : pollute 100. Proof. cbv. intros. Time mrun with_mmatch. Qed. Example test12_mmatch : pollute 1000. Proof. cbv. intros. Time mrun with_mmatch. Qed. End MmatchM. Module DecappM. Example test1_decapp : pollute 10. Proof. cbv. intros. Time mrun with_decapp. Qed. Example test11_decapp : pollute 100. Proof. cbv. intros. Time mrun with_decapp. Qed. Example test12_decapp : pollute 1000. Proof. cbv. intros. Time mrun with_decapp. Qed. End DecappM. Mtac2-1.4-coq8.20/timings/mfix.v000066400000000000000000000023761472011217100162240ustar00rootroot00000000000000From Mtac2 Require Import Mtac2 MTele MTeleMatch MFixDef MTeleMatchDef. Definition Mtest : nat -> nat -> nat -> nat -> M nat := Eval cbn [mfix' curry uncurry ArgsOf apply_sort] in mfix' (m :=mTele (fun a1 => mTele (fun a2 => mTele (fun a3 => mTele (fun a4 => mBase))))) (fun a1 a2 a3 a4 => nat) (fun (rec : nat -> nat -> nat -> nat -> M nat) a b c d => match (a, b, c, d) with | (0, 0, 0, 0) => M.ret 0 | (0, 0, 0, o) => rec a b c (pred o) | (0, 0, m, o) => rec a b (pred m) o | (0, n, m, o) => rec a (pred n) m o | (l, n, m, o) => rec (pred l) n m o end). Definition Mtest2 : nat -> nat -> nat -> nat -> M nat := mfix4 rec (a : nat) (b : nat) (c : nat) (d : nat) : M nat := match (a, b, c, d) with | (0, 0, 0, 0) => M.ret 0 | (0, 0, 0, o) => rec a b c (pred o) | (0, 0, m, o) => rec a b (pred m) o | (0, n, m, o) => rec a (pred n) m o | (l, n, m, o) => rec (pred l) n m o end. Time Compute ltac:(mrun ( Mtest 300 300 300 300 ) ). Time Compute ltac:(mrun ( Mtest2 300 300 300 300 ) ).Mtac2-1.4-coq8.20/timings/reif_jason.v000066400000000000000000000041661472011217100173770ustar00rootroot00000000000000From Mtac2Tests Require Import reif_jason. Import PHOAS. Local Notation n_small := 50%nat. Local Notation n := 500%nat. Goal True. assert (H : exists e, Denote e = big 1 n). { cbv [big]. eexists. (* Time let v := lazymatch goal with |- _ = ?x => x end in *) (* let k := Ltac2LowLevel.Reify v in *) (* idtac. (* 0.096 s *) *) Time let v := lazymatch goal with |- _ = ?x => x end in let k := LtacTacInTermExplicitCtx.Reify v in idtac. (* 2.439 s *) Time let v := lazymatch goal with |- _ = ?x => x end in let k := MTac2.Reify v in idtac. (* 20.59 s *) admit. } clear H. assert (H : exists e, Denote e = big 1 n_small). { cbv [big]. eexists. (* Time let v := lazymatch goal with |- _ = ?x => x end in *) (* let k := Ltac2LowLevel.Reify v in *) (* idtac. (* 0.005 s *) *) Time let v := lazymatch goal with |- _ = ?x => x end in let k := LtacTacInTermExplicitCtx.Reify v in idtac. (* 0.044 s *) Time let v := lazymatch goal with |- _ = ?x => x end in let k := Mtac2Mmatch.Reify v in idtac. (* 2.276 s *) Time let v := lazymatch goal with |- _ = ?x => x end in let k := MTac2.Reify v in idtac. (* 0.228 s *) CanonicalStructuresPHOAS.pre_Reify_rhs (). Focus 2. Time refine eq_refl. (* 1.893 s *) admit. } clear H. assert (H : exists e, Denote e = big_flat 1 n). { cbv [big_flat big_flat_op]. eexists. (* Time let v := lazymatch goal with |- _ = ?x => x end in *) (* let k := Ltac2LowLevel.Reify v in *) (* idtac. (* 0.065 s *) *) Time let v := lazymatch goal with |- _ = ?x => x end in let k := LtacTacInTermExplicitCtx.Reify v in idtac. (* 0.223 s *) Time let v := lazymatch goal with |- _ = ?x => x end in let k := Mtac2Mmatch.Reify v in idtac. (* 2.46 s *) Time let v := lazymatch goal with |- _ = ?x => x end in let k := MTac2.Reify v in idtac. (* 0.092 s *) CanonicalStructuresPHOAS.pre_Reify_rhs (). Focus 2. Time refine eq_refl. (* 0.599 s *) admit. } Abort.Mtac2-1.4-coq8.20/timings/typed_term_decomposition.v000066400000000000000000000027021472011217100223620ustar00rootroot00000000000000From Mtac2 Require Import Base MTele DecomposeApp Tactics List. Import M.notations. Import ProdNotations. Import Mtac2.lib.List.ListNotations. From Mtac2Tests Require Import typed_term_decomposition. From Coq Require Import String. Definition test1_iter := Nat.iter 5000 (fun r => test1;; r) (M.ret tt). Time Mtac Do (test1_iter). Definition test1_vm := Eval vm_compute in test1_iter. Time Mtac Do (test1_vm). Definition test2_builtin : M _ := Nat.iter 5000 (fun r => M.decompose app;; r) (M.ret tt). Definition test2_derived : M _ := Nat.iter 5000 (fun r => decompose_app app;; r) (M.ret tt). Mtac Do (M.print "Timings for built-in [M.decompose]:"). Time Mtac Do (test2_builtin). Mtac Do (M.print "Timings for [decompose_app] derived from [decompose_app'']:"). Time Mtac Do (test2_derived). Mtac Do (M.print "[decompose_ForallT/ForallP]"). Definition test3_iter := Nat.iter 5000 (fun r => test3;; r) (M.ret tt). Definition test3_Prop_iter := Nat.iter 5000 (fun r => test3_Prop;; r) (M.ret tt). Mtac Do (M.print "[decompose_forallT]"). Time Mtac Do (test3_iter). Mtac Do (M.print "[decompose_forallP]"). Time Mtac Do (test3_Prop_iter). Mtac Do (M.print "[decompose_forallT], pre-reduced with [vm_compute]"). Definition test3_vm := Eval vm_compute in test3_iter. Time Mtac Do (test3_vm). Mtac Do (M.print "[decompose_forallP], pre-reduced with [vm_compute]"). Definition test3_Prop_vm := Eval vm_compute in test3_Prop_iter. Time Mtac Do (test3_Prop_vm).