diff options
324 files changed, 11703 insertions, 10733 deletions
diff --git a/.gitignore b/.gitignore index 6c117028a9..b99d2a0d45 100644 --- a/.gitignore +++ b/.gitignore @@ -52,6 +52,7 @@ TAGS bin/ _build_ci _build +_build_boot config/Makefile config/coq_config.ml config/coq_config.py @@ -92,6 +93,7 @@ test-suite/coqdoc/Coqdoc.* test-suite/coqdoc/index.html test-suite/coqdoc/coqdoc.css test-suite/output/MExtraction.out +test-suite/output/*.out.real test-suite/oUnit-anon.cache test-suite/unit-tests/**/*.test diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index d566d56331..956d74c8c1 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,7 +18,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-11-05-V01" + CACHEKEY: "bionic_coq-V2019-12-08-V82" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -103,13 +103,16 @@ before_script: - set -e - make -f Makefile.dune world - set +e + - tar cfj _build.tar.bz2 _build variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" artifacts: name: "$CI_JOB_NAME" + when: always paths: - - _build/ + - _build/log + - _build.tar.bz2 expire_in: 1 week .dune-ci-template: @@ -119,6 +122,7 @@ before_script: dependencies: - build:edge+flambda:dune:dev script: + - tar xfj _build.tar.bz2 - set -e - echo 'start:coq.test' - make -f Makefile.dune "$DUNE_TARGET" @@ -128,6 +132,7 @@ before_script: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" artifacts: + when: always name: "$CI_JOB_NAME" expire_in: 2 months @@ -310,7 +315,8 @@ lint: dependencies: [] variables: GIT_DEPTH: "" # we need an unknown amount of history for per-commit linting - OPAM_SWITCH: base + OPAM_SWITCH: "edge" + OPAM_VARIANT: "+flambda" pkg:opam: stage: stage-1 @@ -323,7 +329,7 @@ pkg:opam: - opam pin add --kind=path coqide.$COQ_VERSION . - set +e variables: - COQ_VERSION: "8.11" + COQ_VERSION: "8.12" OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" only: *full-ci @@ -408,6 +414,7 @@ doc:refman:dune: DUNE_TARGET: refman-html artifacts: paths: + - _build/log - _build/default/doc/sphinx_build/html doc:stdlib:dune: @@ -416,6 +423,7 @@ doc:stdlib:dune: DUNE_TARGET: stdlib-html artifacts: paths: + - _build/log - _build/default/doc/stdlib/html doc:refman:deploy: @@ -455,6 +463,7 @@ doc:ml-api:odoc: DUNE_TARGET: apidoc artifacts: paths: + - _build/log - _build/default/_doc/ test-suite:base: @@ -485,13 +494,15 @@ test-suite:edge+flambda: OPAM_VARIANT: "+flambda" only: *full-ci -test-suite:egde:dune:dev: +test-suite:edge:dune:dev: stage: stage-2 dependencies: - build:edge+flambda:dune:dev needs: - build:edge+flambda:dune:dev - script: make -f Makefile.dune test-suite + script: + - tar xfj _build.tar.bz2 + - make -f Makefile.dune test-suite variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" @@ -562,7 +573,11 @@ library:ci-argosy: extends: .ci-template library:ci-bedrock2: - extends: .ci-template + extends: .ci-template-flambda + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci library:ci-color: extends: .ci-template-flambda @@ -577,6 +592,20 @@ library:ci-color: library:ci-compcert: extends: .ci-template-flambda +library:ci-coqprime: + stage: stage-3 + extends: .ci-template-flambda + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci + needs: + - build:edge+flambda + - plugin:ci-bignums + dependencies: + - build:edge+flambda + - plugin:ci-bignums + library:ci-coquelicot: extends: .ci-template @@ -588,6 +617,18 @@ library:ci-fcsl-pcm: library:ci-fiat-crypto: extends: .ci-template-flambda + stage: stage-4 + needs: + - build:edge+flambda + - library:ci-bedrock2 + - library:ci-coqprime + - plugin:ci-bignums + - plugin:ci-rewriter + dependencies: + - build:edge+flambda + - library:ci-bedrock2 + - library:ci-coqprime + - plugin:ci-rewriter library:ci-fiat-crypto-legacy: extends: .ci-template-flambda @@ -634,7 +675,6 @@ library:ci-math-comp: library:ci-sf: extends: .ci-template - allow_failure: true # Waiting for integration of the fix for #10476 library:ci-stdlib2: extends: .ci-template-flambda @@ -699,3 +739,10 @@ plugin:ci-quickchick: plugin:ci-relation_algebra: extends: .ci-template + +plugin:ci-rewriter: + extends: .ci-template-flambda + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000000..59883180e5 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,7 @@ +profile=ocamlformat +module-item-spacing=compact +sequence-style=terminator +cases-exp-indent=2 +field-space=loose +exp-grouping=preserve +break-cases=fit diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore new file mode 100644 index 0000000000..b1f6597140 --- /dev/null +++ b/.ocamlformat-ignore @@ -0,0 +1,53 @@ +configure.ml +dev/* +coqpp/* +lib/* +clib/* +config/* +checker/* +kernel/* +library/* +engine/* +gramlib/* +parsing/* +interp/* +pretyping/* +printing/* +proofs/* +stm/* +tactics/* +theories/* +user-contrib/*/* +vernac/* +toplevel/* +topbin/* +ide/* +ide/*/* +doc/plugin_tutorial/*/*/* +doc/tools/docgram/* +test-suite/* +test-suite/*/*/* +test-suite/*/*/*/* +test-suite/*/*/*/*/* +tools/* +tools/*/* +plugins/btauto/* +plugins/cc/* +plugins/derive/* +plugins/extraction/* +plugins/firstorder/* +plugins/fourier/* +plugins/funind/* +plugins/ltac/* +plugins/nsatz/* +plugins/omega/* +plugins/rtauto/* +plugins/setoid/* +plugins/ing/* +plugins/setoid_ring/* +plugins/ssr/* +plugins/ssrmatching/* +plugins/syntax/* +# Enabled: micromega +# plugins/micromega/* +plugins/micromega/micromega.ml diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 07008f42d6..f7661743a2 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -483,7 +483,7 @@ We have a linter that checks a few different things: to build every commit, and in principle even the test-suite should pass on every commit (but this isn't tested in CI because it would take too long). A good way to test this is to use `git rebase - master --exec "make -f Makefile.dune check`. + master --exec "make -f Makefile.dune check"`. - **No tabs or end-of-line spaces on updated lines**. We are trying to get rid of all tabs and all end-of-line spaces from the code base (except in some very special files that need them). This checks not @@ -497,6 +497,11 @@ We have a linter that checks a few different things: your branch with `git rebase --whitespace=fix`. - **All files should end with a single newline**. See the section [Style guide](#style-guide) for additional style recommendations. +- **Code is properly formatted**: for some parts of the codebase, + formatting will be enforced using the + [`ocamlformat`](https://github.com/ocaml-ppx/ocamlformat) tool. You + can integrate the formatter in your editor of choice (see docs) or + use `dune build @fmt --auto-promote` to fix this kind of errors. You may run the linter yourself with `dev/lint-repository.sh`. @@ -865,7 +870,7 @@ team. #### Building Coq #### The list of dependencies can be found in the first section of the -[`INSTALL`](INSTALL) file. +[`INSTALL.md`](INSTALL.md) file. Today, the recommended method for building Coq is to use `dune`. Run `make -f Makefile.dune` to get help on the various available targets, diff --git a/INSTALL b/INSTALL deleted file mode 100644 index d9efd55b95..0000000000 --- a/INSTALL +++ /dev/null @@ -1,319 +0,0 @@ - INSTALLING FROM SOURCES - ----------------------- - - -WHAT DO YOU NEED ? -================== - - To compile Coq yourself, you need: - - - OCaml (version >= 4.05.0) - (available at https://ocaml.org/) - (This version of Coq has been tested up to OCaml 4.09.0) - - - The Num package, which used to be part of the OCaml standard library, - if you are using an OCaml version >= 4.06.0 - - - Findlib (version >= 1.4.1) - (available at http://projects.camlcity.org/projects/findlib.html) - - - GNU Make version 3.81 or later - - - a C compiler - - - an IEEE-754 compliant architecture with rounding to nearest - ties to even as default rounding mode (most architectures - should work nowadays) - - - for CoqIDE, the lablgtk development files (version >= 3.0.0), - and the GTK 3.x libraries including gtksourceview3. - - The IEEE-754 compliance is required by primitive floating-point - numbers (Require Import Floats). Common sources of incompatibility - are checked at configure time, preventing compilation. In the, - unlikely, event an incompatibility remains undetected, using Floats - would enable to prove False on this architecture. - - Note that num and lablgtk should be properly registered with - findlib/ocamlfind as Coq's makefile will use it to locate the - libraries during the build. - - Debian / Ubuntu users can get the necessary system packages for - CoqIDE with: - - $ sudo apt-get install libgtksourceview-3.0-dev - - Opam (https://opam.ocaml.org/) is recommended to install OCaml and - the corresponding packages. - - $ opam install num ocamlfind lablgtk3-sourceview3 - - should get you a reasonable OCaml environment to compile Coq. - - Nix users can also get all the required dependencies by running: - - $ nix-shell - - Advanced users may want to experiment with the OCaml Flambda - compiler as way to improve the performance of Coq. In order to - profit from Flambda, a special build of the OCaml compiler that has - the Flambda optimizer enabled must be installed. For OPAM users, - this amounts to installing a compiler switch ending in `+flambda`, - such as `4.07.0+flambda`. For other users, YMMV. Once `ocamlopt - -config` reports that Flambda is available, some further - optimization options can be used; see the entry about -flambda-opts - below for more details. - -QUICK INSTALLATION PROCEDURE. -============================= - -1. ./configure -2. make -3. make install (you may need superuser rights) - -INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). -================================================= - -1- Check that you have the OCaml compiler installed on your - computer and that "ocamlc" (or, better, its native code version - "ocamlc.opt") lies in a directory which is present in your $PATH - environment variable. At the time of writing this sentence, all - versions of Objective Caml later or equal to 4.05.0 are - supported. - - To get Coq in native-code, (it runs 4 to 10 times faster than - bytecode, but it takes more time to get compiled and the binary is - bigger), you will also need the "ocamlopt" (or its native code version - "ocamlopt.opt") command. - -2- The uncompression and un-tarring of the distribution file gave birth - to a directory named "coq-8.xx". You can rename this directory and put - it wherever you want. Just keep in mind that you will need some spare - space during the compilation (reckon on about 300 Mb of disk space - for the whole system in native-code compilation). Once installed, the - binaries take about 30 Mb, and the library about 200 Mb. - -3- First you need to configure the system. It is done automatically with - the command: - - ./configure <options> - - The "configure" script will ask you for directories where to put - the Coq binaries, standard library, man pages, etc. It will propose - you some default values. - - For a list of options accepted by the "configure" script, run - "./configure -help". The main options accepted are: - --prefix <dir> - Binaries, library, and man pages will be respectively - installed in <dir>/bin, <dir>/lib/coq, and <dir>/man - --bindir <dir> (default: /usr/local/bin) - Directory where the binaries will be installed - --libdir <dir> (default: /usr/local/lib/coq) - Directory where the Coq standard library will be installed - --mandir <dir> (default: /usr/local/share/man) - Directory where the Coq manual pages will be installed - --arch <value> (default is the result of the command "arch") - An arbitrary architecture name for your machine (useful when - compiling Coq on two different architectures for which the - result of "arch" is the same, e.g. Sun OS and Solaris) - --local - Compile Coq to run in its source directory. The installation (step 6) - is not necessary in that case. - --browser <command> - Use <command> to open an URL in a browser. %s must appear in <command>, - and will be replaced by the URL. - --flambda-opts <flags> - This experimental option will pass specific user flags to the - OCaml optimizing compiler. In most cases, this option is used - to tweak the flambda backend; for maximum performance we - recommend using - - -flambda-opts `-O3 -unbox-closures` - - but of course you are free to try with a different combination - of flags. You can read more at - https://caml.inria.fr/pub/docs/manual-ocaml/flambda.html - - There is a known problem with certain OCaml versions and - `native_compute`, that will make compilation to require - a large amount of RAM (>= 10GiB) in some particular files. - - We recommend disabling native compilation (`-native-compiler no`) - with flambda unless you use OCaml >= 4.07.0. - - c.f. https://caml.inria.fr/mantis/view.php?id=7630 - -4- Still in the root directory, do - - make - - to compile Coq in the best OCaml mode available (native-code if supported, - bytecode otherwise). - - This will compile the entire system. This phase can take more or less time, - depending on your architecture and is fairly verbose. On a multi-core machine, - it is recommended to compile in parallel, via make -jN where N is your number - of cores. - -5- You can now install the Coq system. Executables, libraries, and - manual pages are copied in some standard places of your system, - defined at configuration time (step 3). Just do - - umask 022 - make install - - Of course, you may need superuser rights to do that. - -6- Optionally, you could build the bytecode version of Coq via: - - make byte - - and install it via - - make install-byte - - This version is quite slower than the native code version of Coq, but could - be helpful for debugging purposes. In particular, coqtop.byte embeds an OCaml - toplevel accessible via the Drop command. - -7- You can now clean all the sources. (You can even erase them.) - - make clean - - -INSTALLATION PROCEDURE FOR ADVANCED USERS. -========================================== - - If you wish to write plugins you *must* keep the Coq sources, without - cleaning them. Therefore, to avoid a duplication of binaries and library, - it is not necessary to do the installation step (6- above). You just have - to tell it at configuration step (4- above) with the option -local : - - ./configure -local <other options> - - Then compile the sources as described in step 5 above. The resulting - binaries will reside in the subdirectory bin/. - - Unless you pass the -nodebug option to ./configure, the -g option of the - OCaml compiler will be used during compilation to allow debugging. - See the debugging file in dev/doc and the chapter 15 of the Coq Reference - Manual for details about how to use the OCaml debugger with Coq. - - -THE AVAILABLE COMMANDS. -======================= - - There are two Coq commands: - - coqtop The Coq toplevel - coqc The Coq compiler - - Under architecture where ocamlopt is available, coqtop is the native code - version of Coq. On such architecture, you could additionally request - the build of the bytecode version of Coq via 'make byte' and install it via - 'make install-byte'. This will create an extra binary named coqtop.byte, - that could be used for debugging purpose. If native code isn't available, - coqtop.byte is directly built by 'make', and coqtop is a link to coqtop.byte. - coqc also invokes the fastest version of Coq. Options -opt and -byte to coqtop - and coqc selects a particular binary. - - * `coqtop' launches Coq in the interactive mode. By default it loads - basic logical definitions and tactics from the Init directory. - - * `coqc' allows compilation of Coq files directly from the command line. - To compile a file foo.v, do: - - coqc foo.v - - It will produce a file foo.vo, that you can now load through the Coq - command "Require". - - A detailed description of these commands and of their options is given - in the Reference Manual (which you can get in the doc/ - directory, or read online on http://coq.inria.fr/doc/) - and in the corresponding manual pages. - - -COMPILING FOR DIFFERENT ARCHITECTURES. -====================================== - - This section explains how to compile Coq for several architecture, sharing - the same sources. The important fact is that some files are architecture - dependent (.cmx, .o and executable files for instance) but others are not - (.cmo and .vo). Consequently, you can : - - o save some time during compilation by not cleaning the architecture - independent files; - - o save some space during installation by sharing the Coq standard - library (which is fully architecture independent). - - So, in order to compile Coq for a new architecture, proceed as follows: - - * Omit step 7 above and clean only the architecture dependent files: - it is done automatically with the command - - make archclean - - * Configure the system for the new architecture: - - ./configure <options> - - You can specify the same directory for the standard library but you - MUST specify a different directory for the binaries (of course). - - * Compile and install the system as described in steps 5 and 6 above. - - -MOVING BINARIES OR LIBRARY. -=========================== - - If you move both the binaries and the library in a consistent way, - Coq should be able to still run. Otherwise, Coq may be "lost", - running "coqtop" would then return an error message of the kind: - - Error during initialization : - Error: cannot guess a path for Coq libraries; please use -coqlib option - - You can then indicate the new places to Coq, using the options -coqlib : - - coqtop -coqlib <new directory> - - See also next section. - - -DYNAMICALLY LOADED LIBRARIES FOR BYTECODE EXECUTABLES. -====================================================== - - Some bytecode executables of Coq use the OCaml runtime, which dynamically - loads a shared library (.so or .dll). When it is not installed properly, you - can get an error message of this kind: - - Fatal error: cannot load shared library dllcoqrun - Reason: dllcoqrun.so: cannot open shared object file: No such file or directory - - In this case, you need either: - - to set the CAML_LD_LIBRARY_PATH environment variable to point to the - directory where dllcoqrun.so is; this is suitable when you want to run - the command a limited number of times in a controlled environment (e.g. - during compilation of binary packages); - - install dllcoqrun.so in a location listed in the file ld.conf that is in - the directory of the standard library of OCaml; - - recompile your bytecode executables after reconfiguring the location - of the shared library: - ./configure -vmbyteflags "-dllib,-lcoqrun,-dllpath,<path>" ... - where <path> is the directory where the dllcoqrun.so is installed; - - (not recommended) compile bytecode executables with a custom OCaml - runtime by using: - ./configure -custom ... - be aware that stripping executables generated this way, or performing - other executable-specific operations, will make them useless. diff --git a/INSTALL.md b/INSTALL.md new file mode 100644 index 0000000000..a55e1e9ac2 --- /dev/null +++ b/INSTALL.md @@ -0,0 +1,79 @@ +Installing From Sources +======================= + +Build Requirements +------------------ + +To compile Coq yourself, you need: + +- [OCaml](https://ocaml.org/) (version >= 4.05.0) + (This version of Coq has been tested up to OCaml 4.09.0) + +- The [num](https://github.com/ocaml/num) library; note that it is + included in the OCaml distribution for OCaml versions < 4.06.0 + +- The [findlib](http://projects.camlcity.org/projects/findlib.html) library (version >= 1.8.0) + +- GNU Make (version >= 3.81) + +- a C compiler + +- an IEEE-754 compliant architecture with rounding to nearest + ties to even as default rounding mode (most architectures + should work nowadays) + +- for CoqIDE, the + [lablgtk3-sourceview3](https://github.com/garrigue/lablgtk) library + (version >= 3.0.beta8), and the corresponding GTK 3.x libraries, as + of today (gtk+3 >= 3.18 and gtksourceview3 >= 3.18) + +The IEEE-754 compliance is required by primitive floating-point +numbers (`Require Import Floats`). Common sources of incompatibility +are checked at configure time, preventing compilation. In the, +unlikely, event an incompatibility remains undetected, using Floats +would enable to prove False on this architecture. + +Note that `num` and `lablgtk3-sourceview3` should be properly +registered with `findlib/ocamlfind` as Coq's makefile will use it to +locate the libraries during the build. + +Debian / Ubuntu users can get the necessary system packages for +CoqIDE with: + + $ sudo apt-get install libgtksourceview-3.0-dev + +Opam (https://opam.ocaml.org/) is recommended to install OCaml and +the corresponding packages. + + $ opam switch create coq 4.09.0+flambda + $ eval $(opam env) + $ opam install num ocamlfind lablgtk3-sourceview3 + +should get you a reasonable OCaml environment to compile Coq. See the +OPAM documentation for more help. + +Nix users can also get all the required dependencies by running: + + $ nix-shell + +Advanced users may want to experiment with the OCaml Flambda +compiler as way to improve the performance of Coq. In order to +profit from Flambda, a special build of the OCaml compiler that has +the Flambda optimizer enabled must be installed. For OPAM users, +this amounts to installing a compiler switch ending in `+flambda`, +such as `4.07.1+flambda`. For other users, YMMV. Once `ocamlopt -config` +reports that Flambda is available, some further optimization options +can be used; see the entry about `-flambda-opts` in the build guide +for more details. + +Build and Installation Procedure +-------------------------------- + +Coq offers the choice of two build systems, an experimental one based +on [Dune](https://github.com/ocaml/dune), and the standard +makefile-based one. + +Please see [INSTALL.make.md](dev/doc/INSTALL.make.md) for build and +installation instructions using `make`. If you wish to experiment with +the Dune-based system see the [dune guide for +developers](dev/doc/build-system.dune.md). diff --git a/META.coq.in b/META.coq.in index 9869e7f575..49bdea6d9c 100644 --- a/META.coq.in +++ b/META.coq.in @@ -1,7 +1,7 @@ # TODO: Generate automatically with Dune description = "The Coq Proof Assistant Plugin API" -version = "8.11" +version = "8.12" directory = "" requires = "" @@ -9,7 +9,7 @@ requires = "" package "config" ( description = "Coq Configuration Variables" - version = "8.11" + version = "8.12" directory = "config" @@ -19,7 +19,7 @@ package "config" ( package "clib" ( description = "Base General Coq Library" - version = "8.11" + version = "8.12" directory = "clib" requires = "str, unix, threads" @@ -31,7 +31,7 @@ package "clib" ( package "lib" ( description = "Base Coq-Specific Library" - version = "8.11" + version = "8.12" directory = "lib" @@ -45,7 +45,7 @@ package "lib" ( package "vm" ( description = "Coq VM" - version = "8.11" + version = "8.12" directory = "kernel/byterun" @@ -64,7 +64,7 @@ package "vm" ( package "kernel" ( description = "Coq's Kernel" - version = "8.11" + version = "8.12" directory = "kernel" @@ -78,7 +78,7 @@ package "kernel" ( package "library" ( description = "Coq Libraries (vo) support" - version = "8.11" + version = "8.12" requires = "coq.kernel" @@ -92,7 +92,7 @@ package "library" ( package "engine" ( description = "Coq Tactic Engine" - version = "8.11" + version = "8.12" requires = "coq.library" directory = "engine" @@ -105,7 +105,7 @@ package "engine" ( package "pretyping" ( description = "Coq Pretyper" - version = "8.11" + version = "8.12" requires = "coq.engine" directory = "pretyping" @@ -118,7 +118,7 @@ package "pretyping" ( package "interp" ( description = "Coq Term Interpretation" - version = "8.11" + version = "8.12" requires = "coq.pretyping" directory = "interp" @@ -131,7 +131,7 @@ package "interp" ( package "proofs" ( description = "Coq Proof Engine" - version = "8.11" + version = "8.12" requires = "coq.interp" directory = "proofs" @@ -144,7 +144,7 @@ package "proofs" ( package "gramlib" ( description = "Coq Grammar Engine" - version = "8.11" + version = "8.12" requires = "coq.lib" directory = "gramlib/.pack" @@ -156,7 +156,7 @@ package "gramlib" ( package "parsing" ( description = "Coq Parsing Engine" - version = "8.11" + version = "8.12" requires = "coq.gramlib, coq.proofs" directory = "parsing" @@ -169,7 +169,7 @@ package "parsing" ( package "printing" ( description = "Coq Printing Engine" - version = "8.11" + version = "8.12" requires = "coq.parsing" directory = "printing" @@ -182,7 +182,7 @@ package "printing" ( package "tactics" ( description = "Coq Basic Tactics" - version = "8.11" + version = "8.12" requires = "coq.printing" directory = "tactics" @@ -195,7 +195,7 @@ package "tactics" ( package "vernac" ( description = "Coq Vernacular Interpreter" - version = "8.11" + version = "8.12" requires = "coq.tactics" directory = "vernac" @@ -208,7 +208,7 @@ package "vernac" ( package "stm" ( description = "Coq State Transactional Machine" - version = "8.11" + version = "8.12" requires = "coq.vernac" directory = "stm" @@ -221,7 +221,7 @@ package "stm" ( package "toplevel" ( description = "Coq Toplevel" - version = "8.11" + version = "8.12" requires = "num, coq.stm" directory = "toplevel" @@ -234,7 +234,7 @@ package "toplevel" ( package "idetop" ( description = "Coq IDE Libraries" - version = "8.11" + version = "8.12" requires = "coq.toplevel" directory = "ide" @@ -247,7 +247,7 @@ package "idetop" ( package "ide" ( description = "Coq IDE Libraries" - version = "8.11" + version = "8.12" requires = "coq.lib, coq.ideprotocol, lablgtk3, lablgtk3-sourceview3" directory = "ide" @@ -260,7 +260,7 @@ package "ide" ( package "ideprotocol" ( description = "Coq IDE protocol" - version = "8.11" + version = "8.12" requires = "coq.toplevel" directory = "ide/protocol" @@ -273,14 +273,14 @@ package "ideprotocol" ( package "plugins" ( description = "Coq built-in plugins" - version = "8.11" + version = "8.12" directory = "plugins" package "ltac" ( description = "Coq LTAC Plugin" - version = "8.11" + version = "8.12" requires = "coq.stm" directory = "ltac" @@ -295,7 +295,7 @@ package "plugins" ( package "tauto" ( description = "Coq tauto plugin" - version = "8.11" + version = "8.12" requires = "coq.plugins.ltac" directory = "ltac" @@ -310,7 +310,7 @@ package "plugins" ( package "omega" ( description = "Coq omega plugin" - version = "8.11" + version = "8.12" requires = "coq.plugins.ltac" directory = "omega" @@ -325,7 +325,7 @@ package "plugins" ( package "micromega" ( description = "Coq micromega plugin" - version = "8.11" + version = "8.12" requires = "num,coq.plugins.ltac" directory = "micromega" @@ -340,7 +340,7 @@ package "plugins" ( package "zify" ( description = "Coq Zify plugin" - version = "8.11" + version = "8.12" requires = "coq.plugins.ltac" directory = "micromega" @@ -355,7 +355,7 @@ package "plugins" ( package "setoid_ring" ( description = "Coq newring plugin" - version = "8.11" + version = "8.12" requires = "" directory = "setoid_ring" @@ -370,7 +370,7 @@ package "plugins" ( package "extraction" ( description = "Coq extraction plugin" - version = "8.11" + version = "8.12" requires = "coq.plugins.ltac" directory = "extraction" @@ -385,7 +385,7 @@ package "plugins" ( package "cc" ( description = "Coq cc plugin" - version = "8.11" + version = "8.12" requires = "coq.plugins.ltac" directory = "cc" @@ -400,7 +400,7 @@ package "plugins" ( package "firstorder" ( description = "Coq ground plugin" - version = "8.11" + version = "8.12" requires = "coq.plugins.ltac" directory = "firstorder" @@ -415,7 +415,7 @@ package "plugins" ( package "rtauto" ( description = "Coq rtauto plugin" - version = "8.11" + version = "8.12" requires = "coq.plugins.ltac" directory = "rtauto" @@ -430,7 +430,7 @@ package "plugins" ( package "btauto" ( description = "Coq btauto plugin" - version = "8.11" + version = "8.12" requires = "coq.plugins.ltac" directory = "btauto" @@ -445,7 +445,7 @@ package "plugins" ( package "funind" ( description = "Coq recdef plugin" - version = "8.11" + version = "8.12" requires = "coq.plugins.extraction" directory = "funind" @@ -460,7 +460,7 @@ package "plugins" ( package "nsatz" ( description = "Coq nsatz plugin" - version = "8.11" + version = "8.12" requires = "num,coq.plugins.ltac" directory = "nsatz" @@ -475,7 +475,7 @@ package "plugins" ( package "rsyntax" ( description = "Coq rsyntax plugin" - version = "8.11" + version = "8.12" requires = "" directory = "syntax" @@ -490,7 +490,7 @@ package "plugins" ( package "int63syntax" ( description = "Coq int63syntax plugin" - version = "8.11" + version = "8.12" requires = "" directory = "syntax" @@ -505,7 +505,7 @@ package "plugins" ( package "string_notation" ( description = "Coq string_notation plugin" - version = "8.11" + version = "8.12" requires = "" directory = "syntax" @@ -520,7 +520,7 @@ package "plugins" ( package "derive" ( description = "Coq derive plugin" - version = "8.11" + version = "8.12" requires = "" directory = "derive" @@ -535,7 +535,7 @@ package "plugins" ( package "ssrmatching" ( description = "Coq ssrmatching plugin" - version = "8.11" + version = "8.12" requires = "coq.plugins.ltac" directory = "ssrmatching" @@ -550,7 +550,7 @@ package "plugins" ( package "ssreflect" ( description = "Coq ssreflect plugin" - version = "8.11" + version = "8.12" requires = "coq.plugins.ssrmatching" directory = "ssr" @@ -8,359 +8,9 @@ ## # (see LICENSE file for the text of the license) ## ########################################################################## - -# Makefile for Coq -# -# To be used with GNU Make >= 3.81. -# -# This Makefile is now separated into Makefile.{common,build,doc}. -# You won't find Makefiles in sub-directories and this is done on purpose. -# If you are not yet convinced of the advantages of a single Makefile, please -# read -# http://aegis.sourceforge.net/auug97.pdf -# before complaining. -# -# When you are working in a subdir, you can compile without moving to the -# upper directory using "make -C ..", and the output is still understood -# by Emacs' next-error. -# -# Specific command-line options to this Makefile: -# -# make VERBOSE=1 # restore the raw echoing of commands -# make NO_RECALC_DEPS=1 # avoid recomputing dependencies -# -# Nota: the 1 above can be replaced by any non-empty value -# -# ---------------------------------------------------------------------- -# See dev/doc/build-system*.txt for more details/FAQ about this Makefile -# ---------------------------------------------------------------------- - - -########################################################################### -# File lists -########################################################################### - -# NB: due to limitations in Win32, please refrain using 'export' too much -# to communicate between make sub-calls (in Win32, 8kb max per env variable, -# 32kb total) - -# !! Before using FIND_SKIP_DIRS, please read how you should in the !! -# !! FIND_SKIP_DIRS section of dev/doc/build-system.dev.txt !! -FIND_SKIP_DIRS:='(' \ - -name '{arch}' -o \ - -name '.svn' -o \ - -name '_darcs' -o \ - -name '.git' -o \ - -name '.bzr' -o \ - -name 'debian' -o \ - -name "$${GIT_DIR}" -o \ - -name '_build' -o \ - -name '_build_ci' -o \ - -name '_install_ci' -o \ - -name 'gramlib' -o \ - -name 'user-contrib' -o \ - -name 'test-suite' -o \ - -name '.opamcache' -o \ - -name '.coq-native' -o \ - -name 'plugin_tutorial' \ -')' -prune -o - -define find - $(shell find . user-contrib/Ltac2 $(FIND_SKIP_DIRS) '(' -name $(1) ')' -print | sed 's|^\./||') -endef - -define findindir - $(shell find $(1) $(FIND_SKIP_DIRS) '(' -name $(2) ')' -print | sed 's|^\./||') -endef - -## Files in the source tree - -# instead of using "export FOO" do "COQ_EXPORTED += FOO" -# this makes it possible to clean up the environment in the subcall -COQ_EXPORTED := COQ_EXPORTED - -LEXFILES := $(call find, '*.mll') -YACCFILES := $(call find, '*.mly') -MLLIBFILES := $(call find, '*.mllib') -MLPACKFILES := $(call find, '*.mlpack') -MLGFILES := $(call find, '*.mlg') -CFILES := $(call findindir, 'kernel/byterun', '*.c') -COQ_EXPORTED +=MLLIBFILES MLPACKFILES MLGFILES CFILES - -# NB our find wrapper ignores the test suite -MERLININFILES := $(call find, '.merlin.in') test-suite/unit-tests/.merlin.in -MERLINFILES := $(MERLININFILES:.in=) -COQ_EXPORTED += MERLINFILES - -# NB: The lists of currently existing .ml and .mli files will change -# before and after a build or a make clean. Hence we do not export -# these variables, but cleaned-up versions (see below MLFILES and co) - -EXISTINGML := $(call find, '*.ml') -EXISTINGMLI := $(call find, '*.mli') - -## Files that will be generated - -# GRAMFILES must be in linking order -GRAMFILES=$(addprefix gramlib/.pack/gramlib__,Ploc Plexing Gramext Grammar) -GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) -GRAMMLIFILES := $(addsuffix .mli, $(GRAMFILES)) -GENGRAMMLFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml # why is gramlib.ml not in GRAMMLFILES? - -GENMLGFILES:= $(MLGFILES:.mlg=.ml) -GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) $(GENGRAMMLFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml -GENMLIFILES:=$(GRAMMLIFILES) -GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h -GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) kernel/genOpcodeFiles.exe -COQ_EXPORTED += GRAMFILES GRAMMLFILES GRAMMLIFILES GENMLFILES GENHFILES GENFILES - -## More complex file lists - -MLSTATICFILES := $(filter-out $(GENMLFILES), $(EXISTINGML)) -MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI)) -COQ_EXPORTED += MLSTATICFILES MLIFILES - -export $(COQ_EXPORTED) - -include Makefile.common - -########################################################################### -# Starting rules -########################################################################### - -NOARG: world - -.PHONY: NOARG help noconfig submake camldevfiles - -help: - @echo "Please use either:" - @echo " ./configure" - @echo " make world" - @echo " make install" - @echo " make clean" - @echo "or make archclean" - @echo "For make to be verbose, add VERBOSE=1" - @echo - @echo "Bytecode compilation is now a separate target:" - @echo " make byte" - @echo " make install-byte" - @echo "Please do not mix bytecode and native targets in the same make -j" - -UNSAVED_FILES:=$(shell find . -name '.\#*v' -o -name '.\#*.ml' -o -name '.\#*.ml?') -ifdef UNSAVED_FILES -$(error You have unsaved changes in your editor (emacs?) [$(UNSAVED_FILES)]; \ -cancel them or save before proceeding. Or your editor crashed. \ -Then, you may want to consider whether you want to restore the autosaves) -#If you try to simply remove this explicit test, the compilation may -#fail later. In particular, if a .#*.v file exists, coqdep fails to -#run. -endif - -# Apart from clean and a few misc files, everything will be done in a -# sub-call to make on Makefile.build. This way, we avoid doing here -# the -include of .d : since they trigger some compilations, we do not -# want them for a mere clean. Moreover, we regroup this sub-call in a -# common target named 'submake'. This way, multiple user-given goals -# (cf the MAKECMDGOALS variable) won't trigger multiple (possibly -# parallel) make sub-calls - -ifdef COQ_CONFIGURED -%:: submake ; +# The default build system is make-based one. +ifndef COQ_USE_DUNE +include Makefile.make else -%:: noconfig ; +include Makefile.dune endif - -MAKE_OPTS := --warn-undefined-variable --no-builtin-rules - -bin: - mkdir bin - -submake: alienclean camldevfiles | bin - $(MAKE) $(MAKE_OPTS) -f Makefile.build $(MAKECMDGOALS) - -noconfig: - @echo "Please run ./configure first" >&2; exit 1 - -# To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles - -Makefile $(wildcard Makefile.*) config/Makefile : ; - -########################################################################### -# OCaml dev files -########################################################################### -camldevfiles: $(MERLINFILES) META.coq - -# prevent submake dependency -META.coq.in $(MERLININFILES): ; - -.merlin: .merlin.in - cp -a "$<" "$@" - -%/.merlin: %/.merlin.in - cp -a "$<" "$@" - -META.coq: META.coq.in - cp -a "$<" "$@" - -########################################################################### -# Cleaning -########################################################################### - -.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean plugin-tutorialclean clean-ide mlgclean depclean cleanconfig distclean voclean timingclean alienclean - -clean: objclean cruftclean depclean docclean camldevfilesclean gramlibclean - -cleankeepvo: indepclean clean-ide optclean cruftclean depclean docclean - -objclean: archclean indepclean - -.PHONY: gramlibclean -gramlibclean: - rm -rf gramlib/.pack/ - -cruftclean: mlgclean - find . \( -name '*~' -o -name '*.annot' \) -exec rm -f {} + - rm -f gmon.out core - -camldevfilesclean: - rm -f $(MERLINFILES) META.coq - -indepclean: - rm -f $(GENFILES) - rm -f $(COQTOPBYTE) $(CHICKENBYTE) $(TOPBYTE) - find . \( -name '*~' -o -name '*.cm[ioat]' -o -name '*.cmti' \) -exec rm -f {} + - rm -f */*.pp[iox] plugins/*/*.pp[iox] - rm -rf $(SOURCEDOCDIR) - rm -f toplevel/mltop.byteml toplevel/mltop.optml - rm -f glob.dump - rm -f config/revision.ml revision - rm -f plugins/micromega/.micromega.ml.generated - $(MAKE) -C test-suite clean - -docclean: - rm -f doc/*/*.dvi doc/*/*.aux doc/*/*.log doc/*/*.bbl doc/*/*.blg doc/*/*.toc \ - doc/*/*.idx doc/*/*~ doc/*/*.ilg doc/*/*.ind doc/*/*.dvi.gz doc/*/*.ps.gz doc/*/*.pdf.gz\ - doc/*/*.???idx doc/*/*.???ind doc/*/*.v.tex doc/*/*.atoc doc/*/*.lof\ - doc/*/*.hatoc doc/*/*.haux doc/*/*.hcomind doc/*/*.herrind doc/*/*.hidx doc/*/*.hind \ - doc/*/*.htacind doc/*/*.htoc doc/*/*.v.html - rm -f doc/stdlib/index-list.html doc/stdlib/index-body.html \ - doc/stdlib/*Library.coqdoc.tex doc/stdlib/library.files \ - doc/stdlib/library.files.ls doc/stdlib/FullLibrary.tex - rm -f doc/*/*.ps doc/*/*.pdf doc/*/*.eps doc/*/*.pdf_t doc/*/*.eps_t - rm -rf doc/stdlib/html doc/tutorial/tutorial.v.html - rm -f doc/common/version.tex - rm -f doc/coq.tex - rm -rf doc/sphinx/_build - -archclean: clean-ide optclean voclean plugin-tutorialclean - rm -rf _build - rm -f $(ALLSTDLIB).* - -optclean: - rm -f $(COQTOPEXE) $(CHICKEN) $(TOPBINOPT) - rm -f $(TOOLS) $(PRIVATEBINARIES) $(CSDPCERT) - find . \( -name '*.cmx' -o -name '*.cmx[as]' -o -name '*.[soa]' -o -name '*.so' \) -exec rm -f {} + - -clean-ide: - rm -f $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi) $(COQIDEBYTE) $(COQIDE) - rm -f ide/input_method_lexer.ml - rm -f ide/highlight.ml ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml - rm -f ide/utf8_convert.ml - rm -f ide/default.bindings ide/default_bindings_src.exe - rm -rf $(COQIDEAPP) - -mlgclean: - rm -f $(GENMLGFILES) - -depclean: - find . $(FIND_SKIP_DIRS) '(' -name '*.d' ')' -exec rm -f {} + - -cacheclean: - find theories plugins test-suite -name '.*.aux' -exec rm -f {} + - -cleanconfig: - rm -f config/Makefile config/coq_config.ml dev/ocamldebug-coq config/Info-*.plist - -distclean: clean cleanconfig cacheclean timingclean - -voclean: - find theories plugins test-suite \( -name '*.vo' -o -name '*.vio' -o -name '*.glob' -o -name "*.cmxs" \ - -o -name "*.native" -o -name "*.cmx" -o -name "*.cmi" -o -name "*.o" \) -exec rm -f {} + - find theories plugins test-suite -name .coq-native -empty -exec rm -rf {} + - -timingclean: - find theories plugins test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' \ - -o -name "*.v.after-timing" -o -name "*.v.timing.diff" -o -name "time-of-build.log" \ - -o -name "time-of-build-before.log" -o -name "time-of-build-after.log" \ - -o -name "time-of-build-pretty.log" -o -name "time-of-build-both.log" \) -exec rm -f {} + - -plugin-tutorialclean: - +$(MAKE) -C $(PLUGINTUTO) clean - -# Ensure that every compiled file around has a known source file. -# This should help preventing weird compilation failures caused by leftover -# compiled files after deleting or moving some source files. - -EXISTINGVO:=$(call find, '*.vo') -KNOWNVO:=$(patsubst %.v,%.vo,$(call find, '*.v')) -ALIENVO:=$(filter-out $(KNOWNVO),$(EXISTINGVO)) - -EXISTINGOBJS:=$(call find, '*.cm[oxia]' -o -name '*.cmxa') -KNOWNML:=$(EXISTINGML) $(GENMLFILES) $(MLPACKFILES:.mlpack=.ml) \ - $(patsubst %.mlp,%.ml,$(wildcard grammar/*.mlp)) -KNOWNOBJS:=$(KNOWNML:.ml=.cmo) $(KNOWNML:.ml=.cmx) $(KNOWNML:.ml=.cmi) \ - $(MLIFILES:.mli=.cmi) \ - gramlib/.pack/gramlib.cma gramlib/.pack/gramlib.cmxa $(MLLIBFILES:.mllib=.cma) $(MLLIBFILES:.mllib=.cmxa) grammar/grammar.cma -ALIENOBJS:=$(filter-out $(KNOWNOBJS),$(EXISTINGOBJS)) - -alienclean: - rm -f $(ALIENOBJS) $(ALIENVO) - -########################################################################### -# Continuous Intregration Tests -########################################################################### -include Makefile.ci - -########################################################################### -# Emacs tags -########################################################################### - -.PHONY: tags printenv - -tags: - echo $(filter-out checker/%, $(MLIFILES)) $(filter-out checker/%, $(MLSTATICFILES)) $(MLGFILES) | sort -r | xargs \ - etags --language=none\ - "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/module[ \t]+\([^ \t]+\)/\1/" - echo $(MLGFILES) | sort -r | xargs \ - etags --append --language=none\ - "--regex=/[ \t]*\([^: \t]+\)[ \t]*:/\1/" - -checker-tags: - echo $(filter-out kernel/%, $(MLIFILES)) $(filter-out kernel/%, $(MLSTATICFILES)) $(MLGFILES) | sort -r | xargs \ - etags --language=none\ - "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/module[ \t]+\([^ \t]+\)/\1/" - echo $(MLGFILES) | sort -r | xargs \ - etags --append --language=none\ - "--regex=/[ \t]*\([^: \t]+\)[ \t]*:/\1/" - -# Useful to check that the exported variables are within the win32 limits - -printenv: - @env - @echo - @echo -n "Maxsize (win32 limit is 8k) : " - @env | wc -L - @echo -n "Total (win32 limit is 32k) : " - @env | wc -m diff --git a/Makefile.ci b/Makefile.ci index e9f7fa2db5..8315c16c64 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -19,6 +19,7 @@ CI_TARGETS= \ ci-coquelicot \ ci-corn \ ci-cross-crypto \ + ci-coqprime \ ci-elpi \ ci-ext-lib \ ci-equations \ @@ -38,6 +39,7 @@ CI_TARGETS= \ ci-perennial \ ci-quickchick \ ci-relation_algebra \ + ci-rewriter \ ci-sf \ ci-simple-io \ ci-stdlib2 \ @@ -56,10 +58,14 @@ ci-all: $(CI_TARGETS) ci-color: ci-bignums +ci-coqprime: ci-bignums + ci-math-classes: ci-bignums ci-corn: ci-math-classes +ci-fiat-crypto: ci-bedrock2 ci-coqprime ci-rewriter + ci-simple-io: ci-ext-lib ci-quickchick: ci-ext-lib ci-simple-io diff --git a/Makefile.doc b/Makefile.doc index 8e958532f0..125a4b33d5 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -71,7 +71,10 @@ refman-%: $(SPHINX_DEPS) doc/unreleased.rst $(HIDE)$(SPHINXENV) $(SPHINXBUILD) -b $* \ $(ALLSPHINXOPTS) doc/sphinx $(SPHINXBUILDDIR)/$* +COQREFMAN_FILES := $(wildcard $(SPHINXBUILDDIR)/latex/CoqRefMan*) +LATEX_REMOVE_FILES := $(filter-out $(SPHINXBUILDDIR)/latex/CoqRefMan.tex, $(COQREFMAN_FILES)) refman-pdf: refman-latex + rm -f $(LATEX_REMOVE_FILES) +$(MAKE) -C $(SPHINXBUILDDIR)/latex refman: $(SPHINX_DEPS) diff --git a/Makefile.dune b/Makefile.dune index 19e8a770bd..bafb40d55f 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -11,7 +11,8 @@ # use DUNEOPT=--display=short for a more verbose build # DUNEOPT=--display=short -BUILD_CONTEXT=_build/default +BOOT_DIR=_build_boot +BOOT_CONTEXT=$(BOOT_DIR)/default help: @echo "Welcome to Coq's Dune-based build system. Targets are:" @@ -45,8 +46,8 @@ plugins/ltac/dune: @echo "(library (name ltac_plugin) (public_name coq.plugins.ltac) (modules_without_implementation extraargs extratactics))" > plugins/ltac/dune voboot: plugins/ltac/dune - dune build $(DUNEOPT) @vodeps - dune exec ./tools/coq_dune.exe $(BUILD_CONTEXT)/.vfiles.d + dune build --build-dir=$(BOOT_DIR) $(DUNEOPT) @vodeps + dune exec --build-dir=$(BOOT_DIR) -- ./tools/coq_dune.exe $(BOOT_CONTEXT)/.vfiles.d states: voboot dune build --display=short $(DUNEOPT) dev/shim/coqtop-prelude @@ -104,8 +105,8 @@ ocheck: voboot ireport: dune clean - dune build $(DUNEOPT) @vodeps --profile=ireport - dune exec coq_dune $(BUILD_CONTEXT)/.vfiles.d --profile=ireport + dune build --build-dir=$(BOOT_DIR) $(DUNEOPT) @vodeps + dune exec --build-dir=$(BOOT_DIR) -- ./tools/coq_dune.exe $(BOOT_CONTEXT)/.vfiles.d dune build $(DUNEOPT) @install --profile=ireport clean: diff --git a/Makefile.ide b/Makefile.ide index bd72494289..b8a144f2ec 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -106,7 +106,7 @@ ifeq ($(HASCOQIDE),opt) $(COQIDE): $(LINKIDEOPT) $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 -linkall $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,threads,lablgtk3-sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ else $(COQIDE): $(COQIDEBYTE) @@ -116,7 +116,7 @@ endif $(COQIDEBYTE): $(LINKIDE) $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ + -linkpkg -package str,unix,threads,lablgtk3-sourceview3 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ ide/coqide_os_specific.ml: ide/coqide_$(IDEINT).ml.in config/Makefile rm -f $@ && cp $< $@ && chmod a-w $@ @@ -241,7 +241,7 @@ $(COQIDEAPP)/Contents: $(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,threads,lablgtk3-sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ $(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents diff --git a/Makefile.install b/Makefile.install index 456c391fd9..dc92062b47 100644 --- a/Makefile.install +++ b/Makefile.install @@ -115,9 +115,18 @@ endif install-merlin: $(INSTALLSH) $(FULLCOQLIB) $(wildcard $(INSTALLCMX:.cmx=.cmt) $(INSTALLCMI:.cmi=.cmti) $(MLIFILES) $(MLFILES) $(MERLINFILES)) +#NB: some files don't produce native files (eg Ltac2 files) as they +#don't have any Coq definitions. Makefile can't predict that so we use || true +#vos build is bugged in -quick mode, see #11195 install-library: $(MKDIR) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) + $(INSTALLSH) $(FULLCOQLIB) $(ALLVO:.$(VO)=.vo) + $(INSTALLSH) $(FULLCOQLIB) $(ALLVO:.$(VO)=.vos) || true +ifneq ($(NATIVECOMPUTE),) + $(INSTALLSH) $(FULLCOQLIB) $(NATIVEFILES) || true +endif + $(INSTALLSH) $(FULLCOQLIB) $(VFILES) + $(INSTALLSH) $(FULLCOQLIB) $(GLOBFILES) $(MKDIR) $(FULLCOQLIB)/user-contrib $(MKDIR) $(FULLCOQLIB)/kernel/byterun ifndef CUSTOM diff --git a/Makefile.make b/Makefile.make new file mode 100644 index 0000000000..e19053462d --- /dev/null +++ b/Makefile.make @@ -0,0 +1,364 @@ +########################################################################## +## # The Coq Proof Assistant / The Coq Development Team ## +## v # INRIA, CNRS and contributors - Copyright 1999-2019 ## +## <O___,, # (see CREDITS file for the list of authors) ## +## \VV/ ############################################################### +## // # This file is distributed under the terms of the ## +## # GNU Lesser General Public License Version 2.1 ## +## # (see LICENSE file for the text of the license) ## +########################################################################## + + +# Makefile for Coq +# +# To be used with GNU Make >= 3.81. +# +# This Makefile is now separated into Makefile.{common,build,doc}. +# You won't find Makefiles in sub-directories and this is done on purpose. +# If you are not yet convinced of the advantages of a single Makefile, please +# read +# http://aegis.sourceforge.net/auug97.pdf +# before complaining. +# +# When you are working in a subdir, you can compile without moving to the +# upper directory using "make -C ..", and the output is still understood +# by Emacs' next-error. +# +# Specific command-line options to this Makefile: +# +# make VERBOSE=1 # restore the raw echoing of commands +# make NO_RECALC_DEPS=1 # avoid recomputing dependencies +# +# Nota: the 1 above can be replaced by any non-empty value +# +# ---------------------------------------------------------------------- +# See dev/doc/build-system*.txt for more details/FAQ about this Makefile +# ---------------------------------------------------------------------- + + +########################################################################### +# File lists +########################################################################### + +# NB: due to limitations in Win32, please refrain using 'export' too much +# to communicate between make sub-calls (in Win32, 8kb max per env variable, +# 32kb total) + +# !! Before using FIND_SKIP_DIRS, please read how you should in the !! +# !! FIND_SKIP_DIRS section of dev/doc/build-system.dev.txt !! +# "-not -name ." to avoid skipping everything since we "find ." +# "-type d" to be able to find .merlin.in files +FIND_SKIP_DIRS:=-not -name . '(' \ + -name '{arch}' -o \ + -name '.*' -type d -o \ + -name '_darcs' -o \ + -name 'debian' -o \ + -name "$${GIT_DIR}" -o \ + -name '_build' -o \ + -name '_build_ci' -o \ + -name '_install_ci' -o \ + -name 'gramlib' -o \ + -name 'user-contrib' -o \ + -name 'test-suite' -o \ + -name 'plugin_tutorial' \ +')' -prune -o + +define find + $(shell find . user-contrib/Ltac2 $(FIND_SKIP_DIRS) '(' -name $(1) ')' -print | sed 's|^\./||') +endef + +define findindir + $(shell find $(1) $(FIND_SKIP_DIRS) '(' -name $(2) ')' -print | sed 's|^\./||') +endef + +## Files in the source tree + +# instead of using "export FOO" do "COQ_EXPORTED += FOO" +# this makes it possible to clean up the environment in the subcall +COQ_EXPORTED := COQ_EXPORTED + +LEXFILES := $(call find, '*.mll') +YACCFILES := $(call find, '*.mly') +MLLIBFILES := $(call find, '*.mllib') +MLPACKFILES := $(call find, '*.mlpack') +MLGFILES := $(call find, '*.mlg') +CFILES := $(call findindir, 'kernel/byterun', '*.c') +COQ_EXPORTED +=MLLIBFILES MLPACKFILES MLGFILES CFILES + +# NB our find wrapper ignores the test suite +MERLININFILES := $(call find, '.merlin.in') test-suite/unit-tests/.merlin.in +MERLINFILES := $(MERLININFILES:.in=) +COQ_EXPORTED += MERLINFILES + +# NB: The lists of currently existing .ml and .mli files will change +# before and after a build or a make clean. Hence we do not export +# these variables, but cleaned-up versions (see below MLFILES and co) + +EXISTINGML := $(call find, '*.ml') +EXISTINGMLI := $(call find, '*.mli') + +## Files that will be generated + +# GRAMFILES must be in linking order +GRAMFILES=$(addprefix gramlib/.pack/gramlib__,Ploc Plexing Gramext Grammar) +GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) +GRAMMLIFILES := $(addsuffix .mli, $(GRAMFILES)) +GENGRAMMLFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml # why is gramlib.ml not in GRAMMLFILES? + +GENMLGFILES:= $(MLGFILES:.mlg=.ml) +GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) $(GENGRAMMLFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml +GENMLIFILES:=$(GRAMMLIFILES) +GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h +GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) kernel/genOpcodeFiles.exe +COQ_EXPORTED += GRAMFILES GRAMMLFILES GRAMMLIFILES GENMLFILES GENHFILES GENFILES + +## More complex file lists + +MLSTATICFILES := $(filter-out $(GENMLFILES), $(EXISTINGML)) +MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI)) +COQ_EXPORTED += MLSTATICFILES MLIFILES + +export $(COQ_EXPORTED) + +include Makefile.common + +########################################################################### +# Starting rules +########################################################################### + +NOARG: world + +.PHONY: NOARG help noconfig submake camldevfiles + +help: + @echo "Please use either:" + @echo " ./configure" + @echo " make world" + @echo " make install" + @echo " make clean" + @echo "or make archclean" + @echo "For make to be verbose, add VERBOSE=1" + @echo + @echo "Bytecode compilation is now a separate target:" + @echo " make byte" + @echo " make install-byte" + @echo "Please do not mix bytecode and native targets in the same make -j" + +UNSAVED_FILES:=$(shell find . -name '.\#*v' -o -name '.\#*.ml' -o -name '.\#*.ml?') +ifdef UNSAVED_FILES +$(error You have unsaved changes in your editor (emacs?) [$(UNSAVED_FILES)]; \ +cancel them or save before proceeding. Or your editor crashed. \ +Then, you may want to consider whether you want to restore the autosaves) +#If you try to simply remove this explicit test, the compilation may +#fail later. In particular, if a .#*.v file exists, coqdep fails to +#run. +endif + +# Apart from clean and a few misc files, everything will be done in a +# sub-call to make on Makefile.build. This way, we avoid doing here +# the -include of .d : since they trigger some compilations, we do not +# want them for a mere clean. Moreover, we regroup this sub-call in a +# common target named 'submake'. This way, multiple user-given goals +# (cf the MAKECMDGOALS variable) won't trigger multiple (possibly +# parallel) make sub-calls + +ifdef COQ_CONFIGURED +%:: submake ; +else +%:: noconfig ; +endif + +MAKE_OPTS := --warn-undefined-variable --no-builtin-rules + +bin: + mkdir bin + +submake: alienclean camldevfiles | bin + $(MAKE) $(MAKE_OPTS) -f Makefile.build $(MAKECMDGOALS) + +noconfig: + @echo "Please run ./configure first" >&2; exit 1 + +# To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles + +Makefile $(wildcard Makefile.*) config/Makefile : ; + +########################################################################### +# OCaml dev files +########################################################################### +camldevfiles: $(MERLINFILES) META.coq + +# prevent submake dependency +META.coq.in $(MERLININFILES): ; + +.merlin: .merlin.in + cp -a "$<" "$@" + +%/.merlin: %/.merlin.in + cp -a "$<" "$@" + +META.coq: META.coq.in + cp -a "$<" "$@" + +########################################################################### +# Cleaning +########################################################################### + +.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean plugin-tutorialclean clean-ide mlgclean depclean cleanconfig distclean voclean timingclean alienclean + +clean: objclean cruftclean depclean docclean camldevfilesclean gramlibclean + +cleankeepvo: indepclean clean-ide optclean cruftclean depclean docclean + +objclean: archclean indepclean + +.PHONY: gramlibclean +gramlibclean: + rm -rf gramlib/.pack/ + +cruftclean: mlgclean + find . \( -name '*~' -o -name '*.annot' \) -exec rm -f {} + + rm -f gmon.out core + +camldevfilesclean: + rm -f $(MERLINFILES) META.coq + +indepclean: + rm -f $(GENFILES) + rm -f $(COQTOPBYTE) $(CHICKENBYTE) $(TOPBYTE) + find . \( -name '*~' -o -name '*.cm[ioat]' -o -name '*.cmti' \) -exec rm -f {} + + rm -f */*.pp[iox] plugins/*/*.pp[iox] + rm -rf $(SOURCEDOCDIR) + rm -f toplevel/mltop.byteml toplevel/mltop.optml + rm -f glob.dump + rm -f config/revision.ml revision + rm -f plugins/micromega/.micromega.ml.generated + $(MAKE) -C test-suite clean + +docclean: + rm -f doc/*/*.dvi doc/*/*.aux doc/*/*.log doc/*/*.bbl doc/*/*.blg doc/*/*.toc \ + doc/*/*.idx doc/*/*~ doc/*/*.ilg doc/*/*.ind doc/*/*.dvi.gz doc/*/*.ps.gz doc/*/*.pdf.gz\ + doc/*/*.???idx doc/*/*.???ind doc/*/*.v.tex doc/*/*.atoc doc/*/*.lof\ + doc/*/*.hatoc doc/*/*.haux doc/*/*.hcomind doc/*/*.herrind doc/*/*.hidx doc/*/*.hind \ + doc/*/*.htacind doc/*/*.htoc doc/*/*.v.html + rm -f doc/stdlib/index-list.html doc/stdlib/index-body.html \ + doc/stdlib/*Library.coqdoc.tex doc/stdlib/library.files \ + doc/stdlib/library.files.ls doc/stdlib/FullLibrary.tex + rm -f doc/*/*.ps doc/*/*.pdf doc/*/*.eps doc/*/*.pdf_t doc/*/*.eps_t + rm -rf doc/stdlib/html doc/tutorial/tutorial.v.html + rm -f doc/common/version.tex + rm -f doc/coq.tex + rm -rf doc/sphinx/_build + +archclean: clean-ide optclean voclean plugin-tutorialclean + rm -rf _build + rm -f $(ALLSTDLIB).* + +optclean: + rm -f $(COQTOPEXE) $(CHICKEN) $(TOPBINOPT) + rm -f $(TOOLS) $(PRIVATEBINARIES) $(CSDPCERT) + find . \( -name '*.cmx' -o -name '*.cmx[as]' -o -name '*.[soa]' -o -name '*.so' \) -exec rm -f {} + + +clean-ide: + rm -f $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi) $(COQIDEBYTE) $(COQIDE) + rm -f ide/input_method_lexer.ml + rm -f ide/highlight.ml ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml + rm -f ide/utf8_convert.ml + rm -f ide/default.bindings ide/default_bindings_src.exe + rm -rf $(COQIDEAPP) + +mlgclean: + rm -f $(GENMLGFILES) + +depclean: + find . $(FIND_SKIP_DIRS) '(' -name '*.d' ')' -exec rm -f {} + + +cacheclean: + find theories plugins test-suite -name '.*.aux' -exec rm -f {} + + +cleanconfig: + rm -f config/Makefile config/coq_config.ml dev/ocamldebug-coq config/Info-*.plist + +distclean: clean cleanconfig cacheclean timingclean + +voclean: + find theories plugins test-suite \( -name '*.vo' -o -name '*.vio' -o -name '*.vos' -o -name '*.vok' -o -name '*.glob' -o -name "*.cmxs" \ + -o -name "*.native" -o -name "*.cmx" -o -name "*.cmi" -o -name "*.o" \) -exec rm -f {} + + find theories plugins test-suite -name .coq-native -empty -exec rm -rf {} + + +timingclean: + find theories plugins test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' \ + -o -name "*.v.after-timing" -o -name "*.v.timing.diff" -o -name "time-of-build.log" \ + -o -name "time-of-build-before.log" -o -name "time-of-build-after.log" \ + -o -name "time-of-build-pretty.log" -o -name "time-of-build-both.log" \) -exec rm -f {} + + +plugin-tutorialclean: + +$(MAKE) -C $(PLUGINTUTO) clean + +# Ensure that every compiled file around has a known source file. +# This should help preventing weird compilation failures caused by leftover +# compiled files after deleting or moving some source files. + +EXISTINGVO:=$(call find, '*.vo') +KNOWNVO:=$(patsubst %.v,%.vo,$(call find, '*.v')) +ALIENVO:=$(filter-out $(KNOWNVO),$(EXISTINGVO)) + +EXISTINGOBJS:=$(call find, '*.cm[oxia]' -o -name '*.cmxa') +KNOWNML:=$(EXISTINGML) $(GENMLFILES) $(MLPACKFILES:.mlpack=.ml) \ + $(patsubst %.mlp,%.ml,$(wildcard grammar/*.mlp)) +KNOWNOBJS:=$(KNOWNML:.ml=.cmo) $(KNOWNML:.ml=.cmx) $(KNOWNML:.ml=.cmi) \ + $(MLIFILES:.mli=.cmi) \ + gramlib/.pack/gramlib.cma gramlib/.pack/gramlib.cmxa $(MLLIBFILES:.mllib=.cma) $(MLLIBFILES:.mllib=.cmxa) grammar/grammar.cma +ALIENOBJS:=$(filter-out $(KNOWNOBJS),$(EXISTINGOBJS)) + +alienclean: + rm -f $(ALIENOBJS) $(ALIENVO) + +########################################################################### +# Continuous Intregration Tests +########################################################################### +include Makefile.ci + +########################################################################### +# Emacs tags +########################################################################### + +.PHONY: tags printenv + +tags: + echo $(filter-out checker/%, $(MLIFILES)) $(filter-out checker/%, $(MLSTATICFILES)) $(MLGFILES) | sort -r | xargs \ + etags --language=none\ + "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/module[ \t]+\([^ \t]+\)/\1/" + echo $(MLGFILES) | sort -r | xargs \ + etags --append --language=none\ + "--regex=/[ \t]*\([^: \t]+\)[ \t]*:/\1/" + +checker-tags: + echo $(filter-out kernel/%, $(MLIFILES)) $(filter-out kernel/%, $(MLSTATICFILES)) $(MLGFILES) | sort -r | xargs \ + etags --language=none\ + "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/module[ \t]+\([^ \t]+\)/\1/" + echo $(MLGFILES) | sort -r | xargs \ + etags --append --language=none\ + "--regex=/[ \t]*\([^: \t]+\)[ \t]*:/\1/" + +# Useful to check that the exported variables are within the win32 limits + +printenv: + @env + @echo + @echo -n "Maxsize (win32 limit is 8k) : " + @env | wc -L + @echo -n "Total (win32 limit is 32k) : " + @env | wc -m diff --git a/Makefile.vofiles b/Makefile.vofiles index 97263ed9ea..b6e0cd0a08 100644 --- a/Makefile.vofiles +++ b/Makefile.vofiles @@ -49,7 +49,6 @@ endif else NATIVEFILES := endif -LIBFILES:=$(ALLVO:.$(VO)=.vo) $(ALLVO:.$(VO)=.vos) $(NATIVEFILES) $(VFILES) $(GLOBFILES) # For emacs: # Local Variables: @@ -54,7 +54,7 @@ environment for semi-interactive development of machine-checked proofs. Download the pre-built packages of the [latest release][] for Windows and macOS; read the [help page][opam-using] on how to install Coq with OPAM; -or refer to the [`INSTALL`](INSTALL) file for the procedure to install from source. +or refer to the [`INSTALL.md`](INSTALL.md) file for the procedure to install from source. [latest release]: https://github.com/coq/coq/releases/latest [opam-using]: https://coq.inria.fr/opam/www/using.html @@ -70,6 +70,15 @@ See also [Cocorico](https://github.com/coq/coq/wiki) (the Coq wiki), and the [Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ), for additional user-contributed documentation. +The documentation of the master branch is continuously deployed. See: +- [Reference Manual (master)][refman-master] +- [Documentation of the standard library (master)][stdlib-master] +- [Documentation of the ML API (master)][api-master] + +[api-master]: https://coq.github.io/doc/master/api/ +[refman-master]: https://coq.github.io/doc/master/refman/ +[stdlib-master]: https://coq.github.io/doc/master/stdlib/ + ## Changes The [Recent @@ -103,7 +112,7 @@ used, and include a complete source example leading to the bug. Guidelines for contributing to Coq in various ways are listed in the [contributor's guide](CONTRIBUTING.md). -Information about the next release is at https://github.com/coq/coq/wiki/Release-Plan +Information about release plans is at https://github.com/coq/coq/wiki/Release-Plan ## Supporting Coq diff --git a/checker/analyze.ml b/checker/analyze.ml index 4c06f1e250..91137a0ce2 100644 --- a/checker/analyze.ml +++ b/checker/analyze.ml @@ -106,8 +106,8 @@ end type repr = | RInt of int -| RInt63 of Uint63.t -| RFloat64 of Float64.t +| Rint64 of Int64.t +| RFloat64 of float | RBlock of (int * int) (* tag × len *) | RString of string | RPointer of int @@ -121,8 +121,8 @@ type data = type obj = | Struct of int * data array (* tag × data *) -| Int63 of Uint63.t (* Primitive integer *) -| Float64 of Float64.t (* Primitive float *) +| Int64 of Int64.t (* Primitive integer *) +| Float64 of float (* Primitive float *) | String of string module type Input = @@ -344,13 +344,13 @@ let parse_object chan = RCode addr | CODE_CUSTOM -> begin match input_cstring chan with - | "_j" -> RInt63 (Uint63.of_int64 (input_intL chan)) + | "_j" -> Rint64 (input_intL chan) | s -> Printf.eprintf "Unhandled custom code: %s" s; assert false end | CODE_DOUBLE_BIG -> - RFloat64 (Float64.of_float (input_double_big chan)) + RFloat64 (input_double_big chan) | CODE_DOUBLE_LITTLE -> - RFloat64 (Float64.of_float (input_double_little chan)) + RFloat64 (input_double_little chan) | CODE_DOUBLE_ARRAY32_LITTLE | CODE_DOUBLE_ARRAY8_BIG | CODE_DOUBLE_ARRAY8_LITTLE @@ -388,9 +388,9 @@ let parse chan = | RCode addr -> let data = Fun addr in data, None - | RInt63 i -> + | Rint64 i -> let data = Ptr !current_object in - let () = LargeArray.set memory !current_object (Int63 i) in + let () = LargeArray.set memory !current_object (Int64 i) in let () = incr current_object in data, None | RFloat64 f -> @@ -461,7 +461,7 @@ let instantiate (p, mem) = for i = 0 to len - 1 do let obj = match LargeArray.get mem i with | Struct (tag, blk) -> Obj.new_block tag (Array.length blk) - | Int63 i -> Obj.repr i + | Int64 i -> Obj.repr i | Float64 f -> Obj.repr f | String str -> Obj.repr str in @@ -481,7 +481,7 @@ let instantiate (p, mem) = for k = 0 to Array.length blk - 1 do Obj.set_field obj k (get_data blk.(k)) done - | Int63 _ + | Int64 _ | Float64 _ | String _ -> () done; diff --git a/checker/analyze.mli b/checker/analyze.mli index e579f4896d..6626d1dff7 100644 --- a/checker/analyze.mli +++ b/checker/analyze.mli @@ -7,8 +7,8 @@ type data = type obj = | Struct of int * data array (* tag × data *) -| Int63 of Uint63.t (* Primitive integer *) -| Float64 of Float64.t (* Primitive float *) +| Int64 of Int64.t (* Primitive integer *) +| Float64 of float (* Primitive float *) | String of string module LargeArray : diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index d20eea7874..06ee4fcc7a 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -61,7 +61,7 @@ let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = mind_entry_params = mb.mind_params_ctxt; mind_entry_inds; mind_entry_universes; - mind_entry_variance = mb.mind_variance; + mind_entry_cumulative= Option.has_some mb.mind_variance; mind_entry_private = mb.mind_private; } diff --git a/checker/dune b/checker/dune index 73cbbc8d19..af7d4f2923 100644 --- a/checker/dune +++ b/checker/dune @@ -12,6 +12,7 @@ (executable (name coqchk) (public_name coqchk) + (modes exe byte) (package coq) (modules coqchk) (flags :standard -open Coq_checklib) diff --git a/checker/votour.ml b/checker/votour.ml index fe6c487496..9adcc874ac 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -100,7 +100,7 @@ struct init_size seen (fun n -> fold (succ i) (accu + 1 + n) k) os.(i) in fold 0 1 (fun size -> let () = LargeArray.set !sizes p size in k size) - | Int63 _ -> k 0 + | Int64 _ -> k 0 | Float64 _ -> k 0 | String s -> let size = 2 + (String.length s / ws) in @@ -118,7 +118,7 @@ struct | Ptr p -> match LargeArray.get !memory p with | Struct (tag, os) -> BLOCK (tag, os) - | Int63 _ -> OTHER (* TODO: pretty-print int63 values *) + | Int64 _ -> OTHER (* TODO: pretty-print int63 values *) | Float64 _ -> OTHER (* TODO: pretty-print float64 values *) | String s -> STRING s diff --git a/clib/hashset.ml b/clib/hashset.ml index b7a245aed1..3477b615ef 100644 --- a/clib/hashset.ml +++ b/clib/hashset.ml @@ -118,8 +118,10 @@ module Make (E : EqType) = t.table.(t.rover) <- emptybucket; t.hashes.(t.rover) <- [| |]; end else begin - Obj.truncate (Obj.repr bucket) (prev_len + 1) [@ocaml.alert "--deprecated"]; - Obj.truncate (Obj.repr hbucket) prev_len [@ocaml.alert "--deprecated"]; + let newbucket = Weak.create prev_len in + Weak.blit bucket 0 newbucket 0 prev_len; + t.table.(t.rover) <- newbucket; + t.hashes.(t.rover) <- Array.sub hbucket 0 prev_len end; if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1; end; diff --git a/config/dune b/config/dune index a303774e17..5f2f7b1222 100644 --- a/config/dune +++ b/config/dune @@ -9,5 +9,9 @@ (rule (targets coq_config.ml coq_config.py Makefile dune.c_flags) (mode fallback) - (deps %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run (env_var COQ_CONFIGURE_PREFIX)) + (deps + %{project_root}/configure.ml + %{project_root}/dev/ocamldebug-coq.run + %{project_root}/dev/header.c + (env_var COQ_CONFIGURE_PREFIX)) (action (chdir %{project_root} (run %{ocaml} configure.ml -no-ask -native-compiler no)))) diff --git a/configure.ml b/configure.ml index d4521a7872..89d9ed9d2a 100644 --- a/configure.ml +++ b/configure.ml @@ -12,11 +12,11 @@ #load "str.cma" open Printf -let coq_version = "8.11+alpha" -let coq_macos_version = "8.10.90" (** "[...] should be a string comprised of +let coq_version = "8.12+alpha" +let coq_macos_version = "8.11.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) -let vo_magic = 81091 -let state_magic = 581091 +let vo_magic = 81191 +let state_magic = 581191 let is_a_released_version = false let distributed_exec = ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; @@ -194,6 +194,12 @@ let which prog = let program_in_path prog = try let _ = which prog in true with Not_found -> false +let build_date = + try + float_of_string (Sys.getenv "SOURCE_DATE_EPOCH") + with + Not_found -> Unix.time () + (** * Date *) (** The short one is displayed when starting coqtop, @@ -204,7 +210,7 @@ let months = "July";"August";"September";"October";"November";"December" |] let get_date () = - let now = Unix.localtime (Unix.time ()) in + let now = Unix.gmtime build_date in let year = 1900+now.Unix.tm_year in let month = months.(now.Unix.tm_mon) in sprintf "%s %d" month year, @@ -21,8 +21,8 @@ license: "LGPL-2.1" version: "dev" depends: [ - "ocaml" { >= "4.05.0" } - "dune" { build & >= "1.10.0" } + "ocaml" { >= "4.05.0" } + "dune" { >= "2.0.0" } "ocamlfind" { build } "num" ] diff --git a/coqide-server.opam b/coqide-server.opam index 5da533ea6b..4cec409f78 100644 --- a/coqide-server.opam +++ b/coqide-server.opam @@ -21,8 +21,8 @@ license: "LGPL-2.1" version: "dev" depends: [ - "dune" { build & >= "1.10.0" } - "coq" { = version } + "dune" { >= "2.0.0" } + "coq" { = version } ] build: [ [ "dune" "build" "-p" name "-j" jobs ] ] diff --git a/coqide.opam b/coqide.opam index 3e588ed0cf..54b8dca98b 100644 --- a/coqide.opam +++ b/coqide.opam @@ -19,10 +19,10 @@ license: "LGPL-2.1" version: "dev" depends: [ - "dune" { build & >= "1.10.0" } - "coqide-server" { = version } - "lablgtk3" { >= "3.0.beta5" } - "lablgtk3-sourceview3" { >= "3.0.beta5" } + "dune" { >= "2.0.0" } + "coqide-server" { = version } + "lablgtk3" { >= "3.0.beta5" } + "lablgtk3-sourceview3" { >= "3.0.beta5" } ] build-env: [ diff --git a/default.nix b/default.nix index 19afc2bd1b..ee4a6046ea 100644 --- a/default.nix +++ b/default.nix @@ -29,7 +29,7 @@ , shell ? false # We don't use lib.inNixShell because that would also apply # when in a nix-shell of some package depending on this one. -, coq-version ? "8.11-git" +, coq-version ? "8.12-git" }: with pkgs; @@ -66,7 +66,7 @@ stdenv.mkDerivation rec { ) ++ optionals shell ( [ jq curl gitFull gnupg ] # Dependencies of the merging script - ++ (with ocamlPackages; [ merlin ocp-indent ocp-index utop ]) # Dev tools + ++ (with ocamlPackages; [ merlin ocp-indent ocp-index utop ocamlformat ]) # Dev tools ++ [ graphviz ] # Useful for STM debugging ); diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 78c0b4b2c7..b1c752ba60 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1132,11 +1132,22 @@ function make_findlib { function make_dune { make_ocaml - if build_prep https://github.com/ocaml/dune/archive/ 1.10.0 tar.gz 1 dune-1.10.0 ; then + if build_prep https://github.com/ocaml/dune/archive/ 2.0.0 tar.gz 1 dune-2.0.0 ; then log2 make release log2 make install + # Dune support libs, we don't install glob and action-plugin as + # they are not needed by Coq + logn dune-private-build dune build -p dune-private-libs @install + logn dune-private-install dune install dune-private-libs + + logn dune-configurator-build dune build -p dune-configurator @install + logn dune-configurator-install dune install dune-configurator + + logn dune-build-info dune build -p dune-build-info @install + logn dune-build-info dune install dune-build-info + build_post fi } @@ -1191,7 +1202,8 @@ function make_ocaml_cairo2 { log2 dune build cairo2.install log2 dune install cairo2 - log2 dune clean + # See https://github.com/ocaml/dune/issues/2921 + # log2 dune clean build_post fi @@ -1216,7 +1228,8 @@ function make_lablgtk { log2 dune build -p lablgtk3-sourceview3 log2 dune install lablgtk3-sourceview3 - log2 dune clean + # See https://github.com/ocaml/dune/issues/2921 + # log2 dune clean build_post fi } @@ -1372,7 +1385,7 @@ function copy_coq_license { # FIXME: this is not the micromega license # It only applies to code that was copied into one single file! install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" - install -D INSTALL "$PREFIXCOQ/license_readme/coq/Install.txt" + install -D INSTALL.md "$PREFIXCOQ/license_readme/coq/Install.txt" install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" || true fi } diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 5139113083..87122e0fb5 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -144,6 +144,13 @@ : "${cross_crypto_CI_ARCHIVEURL:=${cross_crypto_CI_GITURL}/archive}" ######################################################################## +# rewriter +######################################################################## +: "${rewriter_CI_REF:=master}" +: "${rewriter_CI_GITURL:=https://github.com/mit-plv/rewriter}" +: "${rewriter_CI_ARCHIVEURL:=${rewriter_CI_GITURL}/archive}" + +######################################################################## # fiat_parsers ######################################################################## : "${fiat_parsers_CI_REF:=master}" @@ -179,13 +186,6 @@ : "${color_CI_ARCHIVEURL:=${color_CI_GITURL}/archive}" ######################################################################## -# SF -######################################################################## -: "${sf_lf_CI_TARURL:=https://softwarefoundations.cis.upenn.edu/lf-current/lf.tgz}" -: "${sf_plf_CI_TARURL:=https://softwarefoundations.cis.upenn.edu/plf-current/plf.tgz}" -: "${sf_vfa_CI_TARURL:=https://softwarefoundations.cis.upenn.edu/vfa-current/vfa.tgz}" - -######################################################################## # TLC ######################################################################## : "${tlc_CI_REF:=master-for-coq-ci}" @@ -200,6 +200,13 @@ : "${bignums_CI_ARCHIVEURL:=${bignums_CI_GITURL}/archive}" ######################################################################## +# coqprime +######################################################################## +: "${coqprime_CI_REF:=master}" +: "${coqprime_CI_GITURL:=https://github.com/thery/coqprime}" +: "${coqprime_CI_ARCHIVEURL:=${coqprime_CI_GITURL}/archive}" + +######################################################################## # bedrock2 ######################################################################## : "${bedrock2_CI_REF:=master}" diff --git a/dev/ci/ci-bedrock2.sh b/dev/ci/ci-bedrock2.sh index 2ac78d3c2b..8570c34194 100755 --- a/dev/ci/ci-bedrock2.sh +++ b/dev/ci/ci-bedrock2.sh @@ -6,4 +6,4 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download bedrock2 -( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make ) +( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make && make install ) diff --git a/dev/ci/ci-coqprime.sh b/dev/ci/ci-coqprime.sh new file mode 100755 index 0000000000..a4fd296896 --- /dev/null +++ b/dev/ci/ci-coqprime.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download coqprime + +( cd "${CI_BUILD_DIR}/coqprime" && make && make install) diff --git a/dev/ci/ci-equations.sh b/dev/ci/ci-equations.sh index b58a794da2..871d033f5b 100755 --- a/dev/ci/ci-equations.sh +++ b/dev/ci/ci-equations.sh @@ -5,5 +5,4 @@ ci_dir="$(dirname "$0")" git_download equations -( cd "${CI_BUILD_DIR}/equations" && coq_makefile -f _CoqProject -o Makefile && \ - make && make test-suite && make examples && make install) +( cd "${CI_BUILD_DIR}/equations" && ./configure.sh coq && make ci) diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh index e8c8d22678..000c418137 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat-crypto.sh @@ -10,8 +10,9 @@ git_download fiat_crypto # building the executables. # c.f. https://github.com/coq/coq/pull/8313#issuecomment-416650241 -fiat_crypto_CI_TARGETS1="c-files printlite lite" -fiat_crypto_CI_TARGETS2="coq" +fiat_crypto_CI_MAKE_ARGS="EXTERNAL_DEPENDENCIES=1" +fiat_crypto_CI_TARGETS1="${fiat_crypto_CI_MAKE_ARGS} standalone-ocaml c-files rust-files printlite lite" +fiat_crypto_CI_TARGETS2="${fiat_crypto_CI_MAKE_ARGS} all" ( cd "${CI_BUILD_DIR}/fiat_crypto" && git submodule update --init --recursive && \ ulimit -s 32768 && \ diff --git a/dev/ci/ci-rewriter.sh b/dev/ci/ci-rewriter.sh new file mode 100755 index 0000000000..235482ffeb --- /dev/null +++ b/dev/ci/ci-rewriter.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download rewriter + +( cd "${CI_BUILD_DIR}/rewriter" && make && make install) diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index 60436e672c..2b1d2298f2 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -3,10 +3,18 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -mkdir -p "${CI_BUILD_DIR}" && cd "${CI_BUILD_DIR}" || exit 1 -wget -qO- "${sf_lf_CI_TARURL}" | tar xvz -wget -qO- "${sf_plf_CI_TARURL}" | tar xvz -wget -qO- "${sf_vfa_CI_TARURL}" | tar xvz +CIRCLE_SF_TOKEN=00127070c10f5f09574b050e4f08e924764680d2 +data=$(wget https://circleci.com/api/v1.1/project/gh/DeepSpec/sfdev/latest/artifacts?circle-token=${CIRCLE_SF_TOKEN} -O -) + +mkdir -p "${CI_BUILD_DIR}" && cd "${CI_BUILD_DIR}" + +sf_lf_CI_TARURL=$(echo "$data" | jq -rc '.[] | select (.path == "lf.tgz") | .url') +sf_plf_CI_TARURL=$(echo "$data" | jq -rc '.[] | select (.path == "plf.tgz") | .url') +sf_vfa_CI_TARURL=$(echo "$data" | jq -rc '.[] | select (.path == "vfa.tgz") | .url') + +wget -O - "${sf_lf_CI_TARURL}?circle-token=${CIRCLE_SF_TOKEN}" | tar xvz +wget -O - "${sf_plf_CI_TARURL}?circle-token=${CIRCLE_SF_TOKEN}" | tar xvz +wget -O - "${sf_vfa_CI_TARURL}?circle-token=${CIRCLE_SF_TOKEN}" | tar xvz ( cd lf && make clean && make ) ( cd plf && make clean && make ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 1cad46cd89..b8f9d99702 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-11-05-V01" +# CACHEKEY: "bionic_coq-V2019-12-08-V82" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -8,7 +8,7 @@ ENV DEBIAN_FRONTEND="noninteractive" RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ # Dependencies of the image, the test-suite and external projects - m4 automake autoconf time wget rsync git gcc-multilib build-essential unzip \ + m4 automake autoconf time wget rsync git gcc-multilib build-essential unzip jq \ # Dependencies of lablgtk (for CoqIDE) libgtksourceview-3.0-dev \ # Dependencies of stdlib and sphinx doc @@ -22,7 +22,7 @@ RUN pip3 install sphinx==1.7.8 sphinx_rtd_theme==0.2.5b2 \ antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.0 # We need to install OPAM 2.0 manually for now. -RUN wget https://github.com/ocaml/opam/releases/download/2.0.4/opam-2.0.4-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam +RUN wget https://github.com/ocaml/opam/releases/download/2.0.5/opam-2.0.5-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam # Basic OPAM setup ENV NJOBS="2" \ @@ -37,7 +37,7 @@ ENV COMPILER="4.05.0" # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.1 dune.1.11.3 ounit.2.0.8 odoc.1.4.2" \ +ENV BASE_OPAM="num ocamlfind.1.8.1 dune.2.0.0 ounit.2.0.8 odoc.1.4.2" \ CI_OPAM="menhir.20190626 ocamlgraph.1.8.8" \ BASE_ONLY_OPAM="elpi.1.8.0" @@ -58,7 +58,7 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ # EDGE switch ENV COMPILER_EDGE="4.09.0" \ COQIDE_OPAM_EDGE="cairo2.0.6.1 lablgtk3-sourceview3.3.0.beta6" \ - BASE_OPAM_EDGE="dune-release.1.3.2" + BASE_OPAM_EDGE="dune-release.1.3.3 ocamlformat.0.12" # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. diff --git a/dev/ci/user-overlays/11027-SkySkimmer-expose-comind-univ.sh b/dev/ci/user-overlays/11027-SkySkimmer-expose-comind-univ.sh new file mode 100644 index 0000000000..bb65beb043 --- /dev/null +++ b/dev/ci/user-overlays/11027-SkySkimmer-expose-comind-univ.sh @@ -0,0 +1,19 @@ +if [ "$CI_PULL_REQUEST" = "11027" ] || [ "$CI_BRANCH" = "cleanup-comind-univ" ]; then + + elpi_CI_REF=expose-comind-univ + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + + equations_CI_REF=expose-comind-univ + equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + + paramcoq_CI_REF=expose-comind-univ + paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq + + mtac2_CI_REF=expose-comind-univ + mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 + + rewriter_CI_REF=cleanup-comind-univ + rewriter_CI_GITURL=https://github.com/SkySkimmer/rewriter + + +fi diff --git a/dev/ci/user-overlays/11141-herbelin-master+labelled-pr_lconstr-and-co.sh b/dev/ci/user-overlays/11141-herbelin-master+labelled-pr_lconstr-and-co.sh new file mode 100644 index 0000000000..fb66217487 --- /dev/null +++ b/dev/ci/user-overlays/11141-herbelin-master+labelled-pr_lconstr-and-co.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "11141" ] || [ "$CI_BRANCH" = "master+labelled-pr_lconstr-and-co" ]; then + + quickchick_CI_REF=master+adapt-coq-pr11141 + quickchick_CI_GITURL=https://github.com/herbelin/QuickChick + +fi diff --git a/dev/ci/user-overlays/11172-herbelin-master+coercion-notation-interleaved-printing.sh b/dev/ci/user-overlays/11172-herbelin-master+coercion-notation-interleaved-printing.sh new file mode 100644 index 0000000000..e0d9dc6469 --- /dev/null +++ b/dev/ci/user-overlays/11172-herbelin-master+coercion-notation-interleaved-printing.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "11172" ] || [ "$CI_BRANCH" = "master+coercion-notation-interleaved-printing" ]; then + + elpi_CI_REF=coq-master+mini-fix-mkGApp + elpi_CI_GITURL=https://github.com/herbelin/coq-elpi + +fi diff --git a/dev/doc/INSTALL.make.md b/dev/doc/INSTALL.make.md new file mode 100644 index 0000000000..3db5d0b14f --- /dev/null +++ b/dev/doc/INSTALL.make.md @@ -0,0 +1,258 @@ +Quick Installation Procedure using Make. +---------------------------------------- + + $ ./configure + $ make + $ make install (you may need superuser rights) + +Detailed Installation Procedure. +-------------------------------- + +1. Check that you have the OCaml compiler installed on your + computer and that `ocamlc` (or, better, its native code version + `ocamlc.opt`) is in a directory which is present in your $PATH + environment variable. At the time of writing this document, all + versions of Objective Caml later or equal to 4.05.0 are + supported. + + To get Coq in native-code, (which runs 4 to 10 times faster than + bytecode, but it takes more time to get compiled and the binary is + bigger), you will also need the `ocamlopt` (or its native code version + `ocamlopt.opt`) command. + +2. The uncompression and un-tarring of the distribution file gave birth + to a directory named "coq-8.xx". You can rename this directory and put + it wherever you want. Just keep in mind that you will need some spare + space during the compilation (reckon on about 300 Mb of disk space + for the whole system in native-code compilation). Once installed, the + binaries take about 30 Mb, and the library about 200 Mb. + +3. First you need to configure the system. It is done automatically with + the command: + + ./configure <options> + + The `configure` script will ask you for directories where to put + the Coq binaries, standard library, man pages, etc. It will propose + default values. + + For a list of options accepted by the `configure` script, run + `./configure -help`. The main options accepted are: + + * `-prefix <dir>` + Binaries, library, and man pages will be respectively + installed in `<dir>/bin`, `<dir>/lib/coq`, and `<dir>/man` + + * `-bindir <dir>` (default: `/usr/local/bin`) + Directory where the binaries will be installed + + * `-libdir <dir>` (default: `/usr/local/lib/coq`) + Directory where the Coq standard library will be installed + + * `-mandir <dir>` (default: `/usr/local/share/man`) + Directory where the Coq manual pages will be installed + + * `-arch <value>` (default is the result of the command `arch`) + An arbitrary architecture name for your machine (useful when + compiling Coq on two different architectures for which the + result of "arch" is the same, e.g. Sun OS and Solaris) + + * `-local` + Compile Coq to run in its source directory. The installation (step 6) + is not necessary in that case. + + * `-browser <command>` + Use <command> to open an URL in a browser. %s must appear in <command>, + and will be replaced by the URL. + + * `-flambda-opts <flags>` + This experimental option will pass specific user flags to the + OCaml optimizing compiler. In most cases, this option is used + to tweak the flambda backend; for maximum performance we + recommend using: + + -flambda-opts `-O3 -unbox-closures` + + but of course you are free to try with a different combination + of flags. You can read more at + https://caml.inria.fr/pub/docs/manual-ocaml/flambda.html + + There is a known problem with certain OCaml versions and + `native_compute`, that will make compilation to require + a large amount of RAM (>= 10GiB) in some particular files. + + We recommend disabling native compilation (`-native-compiler no`) + with flambda unless you use OCaml >= 4.07.0. + + c.f. https://caml.inria.fr/mantis/view.php?id=7630 + + If you want your build to be reproducible, ensure that the + SOURCE_DATE_EPOCH environment variable is set as documented in + https://reproducible-builds.org/specs/source-date-epoch/ + +4. Still in the root directory, do + + make + + to compile Coq in the best OCaml mode available (native-code if supported, + bytecode otherwise). + + This will compile the entire system. This phase can take more or less time, + depending on your architecture and is fairly verbose. On a multi-core machine, + it is recommended to compile in parallel, via make -jN where N is your number + of cores. + +5. You can now install the Coq system. Executables, libraries, and + manual pages are copied in some standard places of your system, + defined at configuration time (step 3). Just do + + umask 022 + make install + + Of course, you may need superuser rights to do that. + +6. Optionally, you could build the bytecode version of Coq via: + + make byte + + and install it via + + make install-byte + + This version is much slower than the native code version of Coq, but could + be helpful for debugging purposes. In particular, coqtop.byte embeds an OCaml + toplevel accessible via the Drop command. + +7. You can now clean all the sources. (You can even erase them.) + + make clean + +Installation Procedure For Plugin Developers. +--------------------------------------------- + +If you wish to write plugins you *must* keep the Coq sources, without +cleaning them. Therefore, to avoid a duplication of binaries and library, +it is not necessary to do the installation step (6- above). You just have +to tell it at configuration step (4- above) with the option -local : + + ./configure -local <other options> + +Then compile the sources as described in step 5 above. The resulting +binaries will reside in the subdirectory bin/. + +Unless you pass the -nodebug option to ./configure, the -g option of the +OCaml compiler will be used during compilation to allow debugging. +See the debugging file in dev/doc and the chapter 15 of the Coq Reference +Manual for details about how to use the OCaml debugger with Coq. + + +The Available Commands. +----------------------- + +There are two Coq commands: + + coqtop The Coq toplevel + coqc The Coq compiler + +Under architecture where ocamlopt is available, coqtop is the native code +version of Coq. On such architecture, you could additionally request +the build of the bytecode version of Coq via 'make byte' and install it via +'make install-byte'. This will create an extra binary named coqtop.byte, +that could be used for debugging purpose. If native code isn't available, +coqtop.byte is directly built by 'make', and coqtop is a link to coqtop.byte. +coqc also invokes the fastest version of Coq. Options -opt and -byte to coqtop +and coqc selects a particular binary. + +* `coqtop` launches Coq in the interactive mode. By default it loads + basic logical definitions and tactics from the Init directory. + +* `coqc` allows compilation of Coq files directly from the command line. + To compile a file foo.v, do: + + coqc foo.v + + It will produce a file `foo.vo`, that you can now load through the Coq + command `Require`. + + A detailed description of these commands and of their options is given + in the Reference Manual (which you can get in the doc/ + directory, or read online on http://coq.inria.fr/doc/) + and in the corresponding manual pages. + +Compiling For Different Architectures. +-------------------------------------- + +This section explains how to compile Coq for several architecture, sharing +the same sources. The important fact is that some files are architecture +dependent (`.cmx`, `.o` and executable files for instance) but others are not +(`.cmo` and `.vo`). Consequently, you can : + +- save some time during compilation by not cleaning the architecture + independent files; + +- save some space during installation by sharing the Coq standard + library (which is fully architecture independent). + +So, in order to compile Coq for a new architecture, proceed as follows: + +* Omit step 7 above and clean only the architecture dependent files: + it is done automatically with the command + + make archclean + +* Configure the system for the new architecture: + + ./configure <options> + + You can specify the same directory for the standard library but you + MUST specify a different directory for the binaries (of course). + +* Compile and install the system as described in steps 5 and 6 above. + +Moving Binaries Or Library. +--------------------------- + +If you move both the binaries and the library in a consistent way, +Coq should be able to still run. Otherwise, Coq may be "lost", +running "coqtop" would then return an error message of the kind: + + Error during initialization : + Error: cannot guess a path for Coq libraries; please use -coqlib option + +You can then indicate the new places to Coq, using the options -coqlib : + + coqtop -coqlib <new directory> + +See also next section. + +Dynamically Loaded Libraries For Bytecode Executables. +------------------------------------------------------ + +Some bytecode executables of Coq use the OCaml runtime, which dynamically +loads a shared library (.so or .dll). When it is not installed properly, you +can get an error message of this kind: + + Fatal error: cannot load shared library dllcoqrun + Reason: dllcoqrun.so: cannot open shared object file: No such file or directory + +In this case, you need either: + +- to set the `CAML_LD_LIBRARY_PATH` environment variable to point to the + directory where dllcoqrun.so is; this is suitable when you want to run + the command a limited number of times in a controlled environment (e.g. + during compilation of binary packages); +- install dllcoqrun.so in a location listed in the file ld.conf that is in + the directory of the standard library of OCaml; +- recompile your bytecode executables after reconfiguring the location + of the shared library: + + ./configure -vmbyteflags "-dllib,-lcoqrun,-dllpath,<path>" ... + + where `<path>` is the directory where the dllcoqrun.so is installed; +- (not recommended) compile bytecode executables with a custom OCaml + runtime by using: + + ./configure -custom ... + + be aware that stripping executables generated this way, or performing + other executable-specific operations, will make them useless. diff --git a/dev/doc/README.md b/dev/doc/README.md index bc281e0d94..ba53605b0e 100644 --- a/dev/doc/README.md +++ b/dev/doc/README.md @@ -43,8 +43,12 @@ To learn how to run the test suite, you can read ## Development environment + tooling + - [`Merlin`](https://github.com/ocaml/merlin) for autocomplete. - [Wiki pages on tooling containing `emacs`, `vim`, and `git` information](https://github.com/coq/coq/wiki/DevelSetup) +- [`ocamlformat`](https://github.com/ocaml-ppx/ocamlformat) provides + support for automatic formatting of OCaml code. To use it please run + `dune build @fmt`, see `ocamlformat`'s documentation for more help. ## A note about rlwrap diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 8ab00c6fd8..04b20c6889 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1,3 +1,15 @@ +## Changes between Coq 8.11 and Coq 8.12 + +### ML API + +Printers: + +- Functions such as Printer.pr_lconstr_goal_style_env have been + removed, use instead functions such as pr_lconstr with label + `goal_concl_style:true`. Functions such as + Constrextern.extern_constr which were taking a boolean argument for + the goal style now take instead a label. + ## Changes between Coq 8.10 and Coq 8.11 ### ML API diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 0631b3ad59..67becb251a 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -120,7 +120,17 @@ Universes risk: unlikely to be activated by chance (requires a plugin) component: template polymorphism - summary: template polymorphism not collecting side constrains on the universe level of a parameter; this is a general form of the previous issue about template polymorphism exploiting other ways to generate untracked constraints introduced: morally at the introduction of template polymorphism, 23 May 2006, 9c2d70b, r8845, Herbelin impacted released versions: at least V8.4-V8.4pl6, V8.5-V8.5pl3, V8.6-V8.6pl2, V8.7.0-V8.7.1, V8.8.0-V8.8.1, V8.9.0-V8.9.1, in theory also V8.1-V8.1pl4, V8.2-V8.2pl2, V8.3-V8.3pl2 but not exploit found there yet (an exploit using a plugin to force sharing of universe level is in principle possible though) + summary: template polymorphism not collecting side constrains on the + universe level of a parameter; this is a general form of the + previous issue about template polymorphism exploiting other ways to + generate untracked constraints + introduced: morally at the introduction of template polymorphism, 23 + May 2006, 9c2d70b, r8845, Herbelin + impacted released versions: at least V8.4-V8.4pl6, V8.5-V8.5pl3, + V8.6-V8.6pl2, V8.7.0-V8.7.1, V8.8.0-V8.8.1, V8.9.0-V8.9.1, in theory + also V8.1-V8.1pl4, V8.2-V8.2pl2, V8.3-V8.3pl2 but not exploit found + there yet (an exploit using a plugin to force sharing of universe + level is in principle possible though) impacted development branches: all from 8.4 to 8.9 at the time of writing and suspectingly also all from 8.1 to 8.4 if a way to create untracked constraints can be found impacted coqchk versions: a priori all (tested with V8.4 and V8.9 which accept the exploit) fixed in: soon in master and V8.10.0 (PR #9918, Aug 2019, Dénès and Sozeau) @@ -129,6 +139,22 @@ Universes GH issue number: #9294 risk: moderate risk to be activated by chance + component: template polymorphism + summary: using the same universe in the parameters and the + constructor arguments of a template polymorphic inductive (using + named universes in modern Coq, or unification tricks in older Coq) + produces implicit equality constraints not caught by the previous + template polymorphism fix. + introduced: same as the previous template polymorphism bug, morally + from V8.1, first verified impacted version V8.5 (the universe + unification is sufficiently different in V8.4 to prevent our trick + from working) + fixed in: expected in 8.10.2, 8.11+beta, master (#11128, Nov 2019, Gilbert) + found by: Gilbert + exploit: test-suite/bugs/closed/bug_11039.v + GH issue number: #11039 + risk: moderate risk (found by investigating #10504) + component: universe polymorphism, asynchronous proofs summary: universe constraints erroneously discarded when forcing an asynchronous proof containing delayed monomorphic constraints inside a universe polymorphic section introduced: between 8.4 and 8.5 by merging the asynchronous proofs feature branch and universe polymorphism one diff --git a/dev/dune-workspace.all b/dev/dune-workspace.all index 28e8773e25..49e338d0a5 100644 --- a/dev/dune-workspace.all +++ b/dev/dune-workspace.all @@ -1,4 +1,4 @@ -(lang dune 1.10) +(lang dune 2.0) ; Add custom flags here. Default developer profile is `dev` (context (opam (switch 4.05.0))) diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index 2e8a7455de..224601bbce 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -32,4 +32,7 @@ find . "(" -path ./.git -prune ")" -o -type f -print0 | echo Checking overlays dev/tools/check-overlays.sh || CODE=1 +echo Checking ocamlformat +dune build @fmt || CODE=1 + exit $CODE diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index e7a0ba4f6c..677377f868 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/4cd2cb43fb3a87f48c1e10bb65aee99d8f24cb9d.tar.gz"; - sha256 = "1d6rmq67kdg5gmk94wx2774qw89nvbhy6g1f2lms3c9ph37hways"; + url = "https://github.com/NixOS/nixpkgs/archive/f4ad230f90ef312695adc26f256036203e9c70af.tar.gz"; + sha256 = "0cdd275dz3q51sknn7s087js81zvaj5riz8f29id6j6chnyikzjq"; }) diff --git a/dev/tools/make-changelog.sh b/dev/tools/make-changelog.sh index dbb60359cb..e1aed4560d 100755 --- a/dev/tools/make-changelog.sh +++ b/dev/tools/make-changelog.sh @@ -3,7 +3,7 @@ printf "PR number? " read -r PR -printf "Where? (type a prefix)\n" +printf "Category? (type a prefix)\n" (cd doc/changelog && ls -d */) read -r where @@ -11,11 +11,25 @@ where="doc/changelog/$where" if ! [ -d "$where" ]; then where=$(echo "$where"*); fi where="$where/$PR-$(git rev-parse --abbrev-ref HEAD).rst" +printf "Type? (type first letter)\n" +printf "[A]dded \t[C]hanged \t[D]eprecated \t[F]ixed \t[R]emoved\n" +read -r type_first_letter + +case "$type_first_letter" in + [Aa]) type_full="Added";; + [Cc]) type_full="Changed";; + [Dd]) type_full="Deprecated";; + [Ff]) type_full="Fixed";; + [Rr]) type_full="Removed";; + *) printf "Invalid input!\n" + exit 1;; +esac + # shellcheck disable=SC2016 # the ` are regular strings, this is intended # use %s for the leading - to avoid looking like an option (not sure # if necessary but doesn't hurt) -printf '%s bla bla (`#%s <https://github.com/coq/coq/pull/%s>`_, by %s).' - "$PR" "$PR" "$(git config user.name)" > "$where" +printf '%s **%s:**\n Bla bla\n (`#%s <https://github.com/coq/coq/pull/%s>`_,\n by %s).' - "$type_full" "$PR" "$PR" "$(git config user.name)" > "$where" printf "Name of created changelog file:\n" printf "$where\n" diff --git a/dev/tools/update-compat.py b/dev/tools/update-compat.py index 7312c2a5af..ddb0362186 100755 --- a/dev/tools/update-compat.py +++ b/dev/tools/update-compat.py @@ -15,10 +15,8 @@ from io import open # [`doc/stdlib/index-list.html.template`](/doc/stdlib/index-list.html.template) # with the deleted file. # - Remove any notations in the standard library which have `compat "U.U"`. -# - Update the type `compat_version` in [`lib/flags.ml`](/lib/flags.ml) by -# bumping all the version numbers by one, and update the interpretations -# of those flags in [`toplevel/coqargs.ml`](/toplevel/coqargs.ml) and -# [`vernac/g_vernac.mlg`](/vernac/g_vernac.mlg). +# - Update the function `get_compat_file` in [`toplevel/coqargs.ml`](/toplevel/coqargs.ml) +# by bumping all the version numbers by one. # # - Remove the file # [`test-suite/success/CompatOldOldFlag.v`](/test-suite/success/CompatOldOldFlag.v). @@ -38,10 +36,8 @@ from io import open # - Update # [`doc/stdlib/index-list.html.template`](/doc/stdlib/index-list.html.template) # with the added file. -# - Update the type `compat_version` in [`lib/flags.ml`](/lib/flags.ml) by -# bumping all the version numbers by one, and update the interpretations -# of those flags in [`toplevel/coqargs.ml`](/toplevel/coqargs.ml) and -# [`vernac/g_vernac.mlg`](/vernac/g_vernac.mlg). +# - Update the function `get_compat_file` in [`toplevel/coqargs.ml`](/toplevel/coqargs.ml) +# by bumping all the version numbers by one. # - Update the files # [`test-suite/success/CompatCurrentFlag.v`](/test-suite/success/CompatCurrentFlag.v), # [`test-suite/success/CompatPreviousFlag.v`](/test-suite/success/CompatPreviousFlag.v), @@ -70,10 +66,7 @@ DEFAULT_NUMBER_OF_OLD_VERSIONS = 2 RELEASE_NUMBER_OF_OLD_VERSIONS = 2 MASTER_NUMBER_OF_OLD_VERSIONS = 3 EXTRA_HEADER = '\n(** Compatibility file for making Coq act similar to Coq v%s *)\n' -FLAGS_MLI_PATH = os.path.join(ROOT_PATH, 'lib', 'flags.mli') -FLAGS_ML_PATH = os.path.join(ROOT_PATH, 'lib', 'flags.ml') COQARGS_ML_PATH = os.path.join(ROOT_PATH, 'toplevel', 'coqargs.ml') -G_VERNAC_PATH = os.path.join(ROOT_PATH, 'vernac', 'g_vernac.mlg') DOC_INDEX_PATH = os.path.join(ROOT_PATH, 'doc', 'stdlib', 'index-list.html.template') TEST_SUITE_RUN_PATH = os.path.join(ROOT_PATH, 'test-suite', 'tools', 'update-compat', 'run.sh') TEST_SUITE_PATHS = tuple(os.path.join(ROOT_PATH, 'test-suite', 'success', i) @@ -248,118 +241,38 @@ def update_compat_files(old_versions, new_versions, assert_unchanged=False, **ar contents = contents.replace(header, '%s\n%s' % (header, line)) update_file(contents, compat_path, exn_string=('Compat file %%s is missing line %s' % line), assert_unchanged=assert_unchanged, **args) -def update_compat_versions_type_line(new_versions, contents, relpath): - compat_version_string = ' | '.join(['V%s_%s' % tuple(v.split('.')) for v in new_versions[:-1]] + ['Current']) - new_compat_line = 'type compat_version = %s' % compat_version_string - new_contents = re.sub(r'^type compat_version = .*$', new_compat_line, contents, flags=re.MULTILINE) - if new_compat_line not in new_contents: - raise Exception("Could not find 'type compat_version =' in %s" % relpath) - return new_contents - -def update_version_compare(new_versions, contents, relpath): - first_line = 'let version_compare v1 v2 = match v1, v2 with' - new_lines = [first_line] - for v in new_versions[:-1]: - V = 'V%s_%s' % tuple(v.split('.')) - new_lines.append(' | %s, %s -> 0' % (V, V)) - new_lines.append(' | %s, _ -> -1' % V) - new_lines.append(' | _, %s -> 1' % V) - new_lines.append(' | Current, Current -> 0') - new_lines = '\n'.join(new_lines) - new_contents = re.sub(first_line + '.*' + 'Current, Current -> 0', new_lines, contents, flags=re.DOTALL|re.MULTILINE) - if new_lines not in new_contents: - raise Exception('Could not find version_compare in %s' % relpath) - return new_contents - -def update_pr_version(new_versions, contents, relpath): - first_line = 'let pr_version = function' - new_lines = [first_line] - for v in new_versions[:-1]: - V = 'V%s_%s' % tuple(v.split('.')) - new_lines.append(' | %s -> "%s"' % (V, v)) - new_lines.append(' | Current -> "current"') - new_lines = '\n'.join(new_lines) - new_contents = re.sub(first_line + '.*' + 'Current -> "current"', new_lines, contents, flags=re.DOTALL|re.MULTILINE) - if new_lines not in new_contents: - raise Exception('Could not find pr_version in %s' % relpath) - return new_contents - -def update_add_compat_require(new_versions, contents, relpath): - first_line = 'let add_compat_require opts v =' - new_lines = [first_line, ' match v with'] - for v in new_versions[:-1]: - V = 'V%s_%s' % tuple(v.split('.')) - new_lines.append(' | Flags.%s -> add_vo_require opts "Coq.Compat.%s" None (Some false)' % (V, version_name_to_compat_name(v, ext=''))) - new_lines.append(' | Flags.Current -> add_vo_require opts "Coq.Compat.%s" None (Some false)' % version_name_to_compat_name(new_versions[-1], ext='')) - new_lines = '\n'.join(new_lines) - new_contents = re.sub(first_line + '.*' + 'Flags.Current -> add_vo_require opts "Coq.Compat.[^"]+" None .Some false.', new_lines, contents, flags=re.DOTALL|re.MULTILINE) - if new_lines not in new_contents: - raise Exception('Could not find add_compat_require in %s' % relpath) - return new_contents - -def update_parse_compat_version(new_versions, contents, relpath, **args): +def update_get_compat_file(new_versions, contents, relpath): line_count = 3 # 1 for the first line, 1 for the invalid flags, and 1 for Current - first_line = 'let parse_compat_version = let open Flags in function' + first_line = 'let get_compat_file = function' split_contents = contents[contents.index(first_line):].split('\n') while True: cur_line = split_contents[:line_count][-1] if re.match(r'^ \| \([0-9 "\.\|]*\) as s ->$', cur_line) is not None: break - elif re.match(r'^ \| "[0-9\.]*" -> V[0-9_]*$', cur_line) is not None: + elif re.match(r'^ \| "[0-9\.]*" -> "Coq.Compat.Coq[0-9]*"$', cur_line) is not None: line_count += 1 else: - raise Exception('Could not recognize line %d of parse_compat_version in %s as a list of invalid versions (line was %s)' % (line_count, relpath, repr(cur_line))) + raise Exception('Could not recognize line %d of get_compat_file in %s as a list of invalid versions (line was %s)' % (line_count, relpath, repr(cur_line))) old_function_lines = split_contents[:line_count] all_versions = re.findall(r'"([0-9\.]+)"', ''.join(old_function_lines)) invalid_versions = tuple(i for i in all_versions if i not in new_versions) new_function_lines = [first_line] - for v, V in reversed(list(zip(new_versions, ['V%s_%s' % tuple(v.split('.')) for v in new_versions[:-1]] + ['Current']))): + for v, V in reversed(list(zip(new_versions, ['"Coq.Compat.Coq%s%s"' % tuple(v.split('.')) for v in new_versions]))): new_function_lines.append(' | "%s" -> %s' % (v, V)) new_function_lines.append(' | (%s) as s ->' % ' | '.join('"%s"' % v for v in invalid_versions)) new_lines = '\n'.join(new_function_lines) new_contents = contents.replace('\n'.join(old_function_lines), new_lines) if new_lines not in new_contents: - raise Exception('Could not find parse_compat_version in %s' % relpath) + raise Exception('Could not find get_compat_file in %s' % relpath) return new_contents -def check_no_old_versions(old_versions, new_versions, contents, relpath): - for v in old_versions: - if v not in new_versions: - V = 'V%s_%s' % tuple(v.split('.')) - if V in contents: - raise Exception('Unreplaced usage of %s remaining in %s' % (V, relpath)) - -def update_flags_mli(old_versions, new_versions, **args): - contents = get_file(FLAGS_MLI_PATH) - new_contents = update_compat_versions_type_line(new_versions, contents, os.path.relpath(FLAGS_MLI_PATH, ROOT_PATH)) - check_no_old_versions(old_versions, new_versions, new_contents, os.path.relpath(FLAGS_MLI_PATH, ROOT_PATH)) - update_if_changed(contents, new_contents, FLAGS_MLI_PATH, **args) - -def update_flags_ml(old_versions, new_versions, **args): - contents = get_file(FLAGS_ML_PATH) - new_contents = update_compat_versions_type_line(new_versions, contents, os.path.relpath(FLAGS_ML_PATH, ROOT_PATH)) - new_contents = update_version_compare(new_versions, new_contents, os.path.relpath(FLAGS_ML_PATH, ROOT_PATH)) - new_contents = update_pr_version(new_versions, new_contents, os.path.relpath(FLAGS_ML_PATH, ROOT_PATH)) - check_no_old_versions(old_versions, new_versions, new_contents, os.path.relpath(FLAGS_ML_PATH, ROOT_PATH)) - update_if_changed(contents, new_contents, FLAGS_ML_PATH, **args) - def update_coqargs_ml(old_versions, new_versions, **args): contents = get_file(COQARGS_ML_PATH) - new_contents = update_add_compat_require(new_versions, contents, os.path.relpath(COQARGS_ML_PATH, ROOT_PATH)) - check_no_old_versions(old_versions, new_versions, new_contents, os.path.relpath(COQARGS_ML_PATH, ROOT_PATH)) + new_contents = update_get_compat_file(new_versions, contents, os.path.relpath(COQARGS_ML_PATH, ROOT_PATH)) update_if_changed(contents, new_contents, COQARGS_ML_PATH, **args) -def update_g_vernac(old_versions, new_versions, **args): - contents = get_file(G_VERNAC_PATH) - new_contents = update_parse_compat_version(new_versions, contents, os.path.relpath(G_VERNAC_PATH, ROOT_PATH), **args) - check_no_old_versions(old_versions, new_versions, new_contents, os.path.relpath(G_VERNAC_PATH, ROOT_PATH)) - update_if_changed(contents, new_contents, G_VERNAC_PATH, **args) - def update_flags(old_versions, new_versions, **args): - update_flags_mli(old_versions, new_versions, **args) - update_flags_ml(old_versions, new_versions, **args) update_coqargs_ml(old_versions, new_versions, **args) - update_g_vernac(old_versions, new_versions, **args) def update_test_suite(new_versions, assert_unchanged=False, test_suite_paths=TEST_SUITE_PATHS, test_suite_descriptions=TEST_SUITE_DESCRIPTIONS, test_suite_outdated_paths=tuple(), **args): assert(len(new_versions) == len(test_suite_paths)) diff --git a/doc/README.md b/doc/README.md index b784fe92f6..ef3ccc2105 100644 --- a/doc/README.md +++ b/doc/README.md @@ -27,7 +27,7 @@ Dependencies ### HTML documentation To produce the complete documentation in HTML, you will need Coq dependencies -listed in [`INSTALL`](../INSTALL). Additionally, the Sphinx-based +listed in [`INSTALL.md`](../INSTALL.md). Additionally, the Sphinx-based reference manual requires Python 3, and the following Python packages: - sphinx >= 1.7.8 diff --git a/doc/changelog/01-kernel/09867-floats.rst b/doc/changelog/01-kernel/09867-floats.rst deleted file mode 100644 index 56b5fc747a..0000000000 --- a/doc/changelog/01-kernel/09867-floats.rst +++ /dev/null @@ -1,13 +0,0 @@ -- A built-in support of floating-point arithmetic was added, allowing - one to devise efficient reflection tactics involving numerical - computation. Primitive floats are added in the language of terms, - following the binary64 format of the IEEE 754 standard, and the - related operations are implemented for the different reduction - engines of Coq by using the corresponding processor operators in - rounding-to-nearest-even. The properties of these operators are - axiomatized in the theory :g:`Coq.Floats.FloatAxioms` which is part - of the library :g:`Coq.Floats.Floats`. - See Section :ref:`primitive-floats` - (`#9867 <https://github.com/coq/coq/pull/9867>`_, - closes `#8276 <https://github.com/coq/coq/issues/8276>`_, - by Guillaume Bertholon, Erik Martin-Dorel, Pierre Roux). diff --git a/doc/changelog/01-kernel/10439-uniform-opaque-seff-handling.md b/doc/changelog/01-kernel/10439-uniform-opaque-seff-handling.md deleted file mode 100644 index e0573a2c74..0000000000 --- a/doc/changelog/01-kernel/10439-uniform-opaque-seff-handling.md +++ /dev/null @@ -1,4 +0,0 @@ -- Internal definitions generated by abstract-like tactics are now inlined - inside universe Qed-terminated polymorphic definitions, similarly to what - happens for their monomorphic counterparts, - (`#10439 <https://github.com/coq/coq/pull/10439>`_, by Pierre-Marie Pédrot). diff --git a/doc/changelog/01-kernel/10664-sections-stack-in-kernel.rst b/doc/changelog/01-kernel/10664-sections-stack-in-kernel.rst deleted file mode 100644 index bac08d12ea..0000000000 --- a/doc/changelog/01-kernel/10664-sections-stack-in-kernel.rst +++ /dev/null @@ -1,6 +0,0 @@ -- Section data is now part of the kernel. Solves a soundness issue - in interactive mode where global monomorphic universe constraints would be - dropped when forcing a delayed opaque proof inside a polymorphic section. Also - relaxes the nesting criterion for sections, as polymorphic sections can now - appear inside a monomorphic one - (#10664, <https://github.com/coq/coq/pull/10664> by Pierre-Marie Pédrot). diff --git a/doc/changelog/01-kernel/10811-sprop-default-on.rst b/doc/changelog/01-kernel/10811-sprop-default-on.rst deleted file mode 100644 index 349c44c205..0000000000 --- a/doc/changelog/01-kernel/10811-sprop-default-on.rst +++ /dev/null @@ -1,3 +0,0 @@ -- Using ``SProp`` is now allowed by default, without needing to pass - ``-allow-sprop`` or use :flag:`Allow StrictProp` (`#10811 - <https://github.com/coq/coq/pull/10811>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/10049-bidi-app.rst b/doc/changelog/02-specification-language/10049-bidi-app.rst deleted file mode 100644 index 279bb9272a..0000000000 --- a/doc/changelog/02-specification-language/10049-bidi-app.rst +++ /dev/null @@ -1,6 +0,0 @@ -- New annotation in `Arguments` for bidirectionality hints: it is now possible - to tell type inference to use type information from the context once the `n` - first arguments of an application are known. The syntax is: - `Arguments foo x y & z`. See :cmd:`Arguments (bidirectionality hints)` - (`#10049 <https://github.com/coq/coq/pull/10049>`_, by Maxime Dénès with - help from Enrico Tassi). diff --git a/doc/changelog/02-specification-language/10076-not-canonical-projection.rst b/doc/changelog/02-specification-language/10076-not-canonical-projection.rst deleted file mode 100644 index 0a902079b9..0000000000 --- a/doc/changelog/02-specification-language/10076-not-canonical-projection.rst +++ /dev/null @@ -1,4 +0,0 @@ -- Record fields can be annotated to prevent them from being used as canonical projections; - see :ref:`canonicalstructures` for details - (`#10076 <https://github.com/coq/coq/pull/10076>`_, - by Vincent Laporte). diff --git a/doc/changelog/02-specification-language/10167-orpat-mixfix.rst b/doc/changelog/02-specification-language/10167-orpat-mixfix.rst deleted file mode 100644 index 2d17e569d3..0000000000 --- a/doc/changelog/02-specification-language/10167-orpat-mixfix.rst +++ /dev/null @@ -1,12 +0,0 @@ -- Require parentheses around nested disjunctive patterns, so that pattern and - term syntax are consistent; match branch patterns no longer require - parentheses for notation at level 100 or more. Incompatibilities: - - + in :g:`match p with (_, (0|1)) => ...` parentheses may no longer be - omitted around :n:`0|1`. - + notation :g:`(p | q)` now potentially clashes with core pattern syntax, - and should be avoided. ``-w disj-pattern-notation`` flags such :cmd:`Notation`. - - See :ref:`extendedpatternmatching` for details - (`#10167 <https://github.com/coq/coq/pull/10167>`_, - by Georges Gonthier). diff --git a/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst b/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst deleted file mode 100644 index 71b10aaaf4..0000000000 --- a/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst +++ /dev/null @@ -1,11 +0,0 @@ -- :cmd:`Function` always opens a proof when used with a ``measure`` or ``wf`` - annotation, see :ref:`advanced-recursive-functions` for the updated - documentation (`#10215 <https://github.com/coq/coq/pull/10215>`_, - by Enrico Tassi). - -- The legacy command :cmd:`Add Morphism` always opens a proof and cannot be used - inside a module type. In order to declare a module type parameter that - happens to be a morphism, use :cmd:`Declare Morphism`. See - :ref:`deprecated_syntax_for_generalized_rewriting` for the updated - documentation (`#10215 <https://github.com/coq/coq/pull/10215>`_, - by Enrico Tassi). diff --git a/doc/changelog/02-specification-language/10441-static-poly-section.rst b/doc/changelog/02-specification-language/10441-static-poly-section.rst deleted file mode 100644 index 7f0345d946..0000000000 --- a/doc/changelog/02-specification-language/10441-static-poly-section.rst +++ /dev/null @@ -1,11 +0,0 @@ -- The universe polymorphism setting now applies from the opening of a section. - In particular, it is not possible anymore to mix polymorphic and monomorphic - definitions in a section when there are no variables nor universe constraints - defined in this section. This makes the behaviour consistent with the - documentation. (`#10441 <https://github.com/coq/coq/pull/10441>`_, - by Pierre-Marie Pédrot) - -- The :cmd:`Section` vernacular command now accepts the "universes" attribute. In - addition to setting the section universe polymorphism, it also locally sets - the universe polymorphic option inside the section. - (`#10441 <https://github.com/coq/coq/pull/10441>`_, by Pierre-Marie Pédrot) diff --git a/doc/changelog/02-specification-language/10657-minim-toset-flex.rst b/doc/changelog/02-specification-language/10657-minim-toset-flex.rst new file mode 100644 index 0000000000..8983e162fb --- /dev/null +++ b/doc/changelog/02-specification-language/10657-minim-toset-flex.rst @@ -0,0 +1,3 @@ +- Changed heuristics for universe minimization to :g:`Set`: only + minimize flexible universes (`#10657 <https://github.com/coq/coq/pull/10657>`_, + by Gaëtan Gilbert with help from Maxime Dénès and Matthieu Sozeau). diff --git a/doc/changelog/02-specification-language/10758-fix-10757.rst b/doc/changelog/02-specification-language/10758-fix-10757.rst deleted file mode 100644 index 4cce26aedc..0000000000 --- a/doc/changelog/02-specification-language/10758-fix-10757.rst +++ /dev/null @@ -1,5 +0,0 @@ -- ``Program Fixpoint`` now uses ``ex`` and ``sig`` to make telescopes - involving ``Prop`` types (`#10758 - <https://github.com/coq/coq/pull/10758>`_, by Gaëtan Gilbert, fixing - `#10757 <https://github.com/coq/coq/issues/10757>`_ reported by - Xavier Leroy). diff --git a/doc/changelog/02-specification-language/10985-about-arguments.rst b/doc/changelog/02-specification-language/10985-about-arguments.rst deleted file mode 100644 index 1e05b0b0fe..0000000000 --- a/doc/changelog/02-specification-language/10985-about-arguments.rst +++ /dev/null @@ -1,5 +0,0 @@ -- The output of the :cmd:`Print` and :cmd:`About` commands has - changed. Arguments meta-data is now displayed as the corresponding - :cmd:`Arguments <Arguments (implicits)>` command instead of the - human-targeted prose used in previous Coq versions. (`#10985 - <https://github.com/coq/coq/pull/10985>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/10996-refine-instance-returns.rst b/doc/changelog/02-specification-language/10996-refine-instance-returns.rst deleted file mode 100644 index cd1a692f54..0000000000 --- a/doc/changelog/02-specification-language/10996-refine-instance-returns.rst +++ /dev/null @@ -1,4 +0,0 @@ -- Added ``#[refine]`` attribute for :cmd:`Instance`, a more - predictable version of the old ``Refine Instance Mode`` which - unconditionally opens a proof (`#10996 - <https://github.com/coq/coq/pull/10996>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/10997-unsupport-atts-warn.rst b/doc/changelog/02-specification-language/10997-unsupport-atts-warn.rst deleted file mode 100644 index 43a748b365..0000000000 --- a/doc/changelog/02-specification-language/10997-unsupport-atts-warn.rst +++ /dev/null @@ -1,3 +0,0 @@ -- The unsupported attribute error is now an error-by-default warning, - meaning it can be disabled (`#10997 - <https://github.com/coq/coq/pull/10997>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/11132-master+fix-implicit-let-fixpoint-bug3282.rst b/doc/changelog/02-specification-language/11132-master+fix-implicit-let-fixpoint-bug3282.rst deleted file mode 100644 index f8298cdbdd..0000000000 --- a/doc/changelog/02-specification-language/11132-master+fix-implicit-let-fixpoint-bug3282.rst +++ /dev/null @@ -1,13 +0,0 @@ -- Fixed bugs sometimes preventing to define valid (co)fixpoints with implicit arguments - in the presence of local definitions, see `#3282 <https://github.com/coq/coq/issues/3282>`_ - (`#11132 <https://github.com/coq/coq/pull/11132>`_, by Hugo Herbelin). - - .. example:: - - The following features an implicit argument after a local - definition. It was wrongly rejected. - - .. coqtop:: in - - Definition f := fix f (o := true) {n : nat} m {struct m} := - match m with 0 => 0 | S m' => f (n:=n+1) m' end. diff --git a/doc/changelog/03-notations/09883-numeral-notations-sorts.rst b/doc/changelog/03-notations/09883-numeral-notations-sorts.rst deleted file mode 100644 index abc5a516ae..0000000000 --- a/doc/changelog/03-notations/09883-numeral-notations-sorts.rst +++ /dev/null @@ -1,4 +0,0 @@ -- Numeral Notations now support sorts in the input to printing - functions (e.g., numeral notations can be defined for terms - containing things like `@cons Set nat nil`). (`#9883 - <https://github.com/coq/coq/pull/9883>`_, by Jason Gross). diff --git a/doc/changelog/03-notations/10180-deprecate-notations.rst b/doc/changelog/03-notations/10180-deprecate-notations.rst deleted file mode 100644 index bce5db5865..0000000000 --- a/doc/changelog/03-notations/10180-deprecate-notations.rst +++ /dev/null @@ -1,6 +0,0 @@ -- The :cmd:`Notation` and :cmd:`Infix` commands now support the `deprecated` - attribute. The former `compat` annotation for notations is - deprecated, and its semantics changed. It is now made equivalent to using - a `deprecated` attribute, and is no longer connected with the `-compat` - command-line flag - (`#10180 <https://github.com/coq/coq/pull/10180>`_, by Maxime Dénès). diff --git a/doc/changelog/03-notations/10963-simplify-parser.rst b/doc/changelog/03-notations/10963-simplify-parser.rst deleted file mode 100644 index 327a39bdb6..0000000000 --- a/doc/changelog/03-notations/10963-simplify-parser.rst +++ /dev/null @@ -1,6 +0,0 @@ -- A simplification of parsing rules could cause a slight change of - parsing precedences for the very rare users who defined notations - with `constr` at level strictly between 100 and 200 and used these - notations on the right-hand side of a cast operator (`:`, `:>`, - `:>>`) (`#10963 <https://github.com/coq/coq/pull/10963>`_, by Théo - Zimmermann, simplification initially noticed by Jim Fehrle). diff --git a/doc/changelog/03-notations/11090-master+refactoring-application-printing.rst b/doc/changelog/03-notations/11090-master+refactoring-application-printing.rst deleted file mode 100644 index 5c3936073a..0000000000 --- a/doc/changelog/03-notations/11090-master+refactoring-application-printing.rst +++ /dev/null @@ -1 +0,0 @@ -- Fixed #11033: regression in not printing coercions to which is also associated a notation (`#11090 <https://github.com/coq/coq/pull/11090>`_, by Hugo Herbelin). diff --git a/doc/changelog/03-notations/11113-remove-compat.rst b/doc/changelog/03-notations/11113-remove-compat.rst new file mode 100644 index 0000000000..8c71d70cda --- /dev/null +++ b/doc/changelog/03-notations/11113-remove-compat.rst @@ -0,0 +1,4 @@ +- Removed deprecated ``compat`` modifier of :cmd:`Notation` + and :cmd:`Infix` commands + (`#11113 <https://github.com/coq/coq/pull/11113>`_, + by Théo Zimmermann, with help from Jason Gross). diff --git a/doc/changelog/03-notations/11172-master+coercion-notation-interleaved-printing.rst b/doc/changelog/03-notations/11172-master+coercion-notation-interleaved-printing.rst new file mode 100644 index 0000000000..8551cf3aac --- /dev/null +++ b/doc/changelog/03-notations/11172-master+coercion-notation-interleaved-printing.rst @@ -0,0 +1,2 @@ +- The printing algorithm now interleave search for notations and removal of coercions + (`#11172 <https://github.com/coq/coq/pull/11172>`_, by Hugo Herbelin). diff --git a/doc/changelog/03-notations/11276-master+fix10750.rst b/doc/changelog/03-notations/11276-master+fix10750.rst new file mode 100644 index 0000000000..a1b8594f5f --- /dev/null +++ b/doc/changelog/03-notations/11276-master+fix10750.rst @@ -0,0 +1,4 @@ +- **Fixed:** + :cmd:`Print Visibility` was failing in the presence of only-printing notations + (`#11276 <https://github.com/coq/coq/pull/11276>`_, + by Hugo Herbelin, fixing `#10750 <https://github.com/coq/coq/pull/10750>`_). diff --git a/doc/changelog/03-notations/11311-custom-entries-recursive.rst b/doc/changelog/03-notations/11311-custom-entries-recursive.rst new file mode 100644 index 0000000000..ae9888512d --- /dev/null +++ b/doc/changelog/03-notations/11311-custom-entries-recursive.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Recursive notations with custom entries were incorrectly parsing `constr` + instead of custom grammars (`#11311 <https://github.com/coq/coq/pull/11311>`_ + by Maxime Dénès, fixes `#9532 <https://github.com/coq/coq/pull/9532>`_, + `#9490 <https://github.com/coq/coq/pull/9490>`_). diff --git a/doc/changelog/04-tactics/09288-injection-as.rst b/doc/changelog/04-tactics/09288-injection-as.rst deleted file mode 100644 index 0cb669778c..0000000000 --- a/doc/changelog/04-tactics/09288-injection-as.rst +++ /dev/null @@ -1,4 +0,0 @@ -- Documented syntax :n:`injection @term as [= {+ @intropattern} ]` as - an alternative to :n:`injection @term as {+ @simple_intropattern}` using - the standard :n:`@injection_intropattern` syntax (`#9288 - <https://github.com/coq/coq/pull/9288>`_, by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/09856-zify.rst b/doc/changelog/04-tactics/09856-zify.rst deleted file mode 100644 index 6b9143c77b..0000000000 --- a/doc/changelog/04-tactics/09856-zify.rst +++ /dev/null @@ -1,7 +0,0 @@ -- Reimplementation of the :tacn:`zify` tactic. The tactic is more efficient and copes with dependent hypotheses. - It can also be extended by redefining the tactic ``zify_post_hook``. - (`#9856 <https://github.com/coq/coq/pull/9856>`_ fixes - `#8898 <https://github.com/coq/coq/issues/8898>`_, - `#7886 <https://github.com/coq/coq/issues/7886>`_, - `#9848 <https://github.com/coq/coq/issues/9848>`_ and - `#5155 <https://github.com/coq/coq/issues/5155>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/10318-select-only-error.rst b/doc/changelog/04-tactics/10318-select-only-error.rst deleted file mode 100644 index b4f991316e..0000000000 --- a/doc/changelog/04-tactics/10318-select-only-error.rst +++ /dev/null @@ -1,4 +0,0 @@ -- The goal selector tactical ``only`` now checks that the goal range - it is given is valid instead of ignoring goals out of the focus - range (`#10318 <https://github.com/coq/coq/pull/10318>`_, by Gaëtan - Gilbert). diff --git a/doc/changelog/04-tactics/10762-notypeclasses-refine.rst b/doc/changelog/04-tactics/10762-notypeclasses-refine.rst new file mode 100644 index 0000000000..2fef75dc7f --- /dev/null +++ b/doc/changelog/04-tactics/10762-notypeclasses-refine.rst @@ -0,0 +1,4 @@ +- **Changed:** + The tactics :tacn:`eapply`, :tacn:`refine` and its variants no + longer allows shelved goals to be solved by typeclass resolution. + (`#10762 <https://github.com/coq/coq/pull/10762>`_, by Matthieu Sozeau). diff --git a/doc/changelog/04-tactics/10765-micromega-caches.rst b/doc/changelog/04-tactics/10765-micromega-caches.rst deleted file mode 100644 index 12d8f68e63..0000000000 --- a/doc/changelog/04-tactics/10765-micromega-caches.rst +++ /dev/null @@ -1,3 +0,0 @@ -- Introduction of flags :flag:`Lia Cache`, :flag:`Nia Cache` and :flag:`Nra Cache`. - (see `#10772 <https://github.com/coq/coq/issues/10772>`_ for use case) - (`#10765 <https://github.com/coq/coq/pull/10765>`_ fixes `#10772 <https://github.com/coq/coq/issues/10772>`_ , by Frédéric Besson). diff --git a/doc/changelog/04-tactics/10774-zify-Z_to_N.rst b/doc/changelog/04-tactics/10774-zify-Z_to_N.rst deleted file mode 100644 index ed46cb101e..0000000000 --- a/doc/changelog/04-tactics/10774-zify-Z_to_N.rst +++ /dev/null @@ -1,3 +0,0 @@ -- The :tacn:`zify` tactic is now aware of `Z.to_N`. - (`#10774 <https://github.com/coq/coq/pull/10774>`_ fixes - `#9162 <https://github.com/coq/coq/issues/9162>`_, by Kazuhiko Sakaguchi). diff --git a/doc/changelog/04-tactics/10966-assert-succeeds-once.rst b/doc/changelog/04-tactics/10966-assert-succeeds-once.rst deleted file mode 100644 index 09bef82c80..0000000000 --- a/doc/changelog/04-tactics/10966-assert-succeeds-once.rst +++ /dev/null @@ -1,11 +0,0 @@ -- The :tacn:`assert_succeeds` and :tacn:`assert_fails` tactics now - only run their tactic argument once, even if it has multiple - successes. This prevents blow-up and looping from using - multisuccess tactics with :tacn:`assert_succeeds`. (`#10966 - <https://github.com/coq/coq/pull/10966>`_ fixes `#10965 - <https://github.com/coq/coq/issues/10965>`_, by Jason Gross). - -- The :tacn:`assert_succeeds` and :tacn:`assert_fails` tactics now - behave correctly when their tactic fully solves the goal. (`#10966 - <https://github.com/coq/coq/pull/10966>`_ fixes `#9114 - <https://github.com/coq/coq/issues/9114>`_, by Jason Gross). diff --git a/doc/changelog/04-tactics/10998-zify-complements.rst b/doc/changelog/04-tactics/10998-zify-complements.rst index 3ec526f0a9..c72d085687 100644 --- a/doc/changelog/04-tactics/10998-zify-complements.rst +++ b/doc/changelog/04-tactics/10998-zify-complements.rst @@ -1,4 +1,5 @@ -- The :tacn:`zify` tactic is now aware of `Pos.pred_double`, `Pos.pred_N`, +- **Added:** + The :tacn:`zify` tactic is now aware of `Pos.pred_double`, `Pos.pred_N`, `Pos.of_nat`, `Pos.add_carry`, `Pos.pow`, `Pos.square`, `Z.pow`, `Z.double`, `Z.pred_double`, `Z.succ_double`, `Z.square`, `Z.div2`, and `Z.quot2`. Injections for internal definitions in module `ZifyBool` (`isZero` and `isLeZero`) diff --git a/doc/changelog/04-tactics/11203-fix-time-printing.rst b/doc/changelog/04-tactics/11203-fix-time-printing.rst new file mode 100644 index 0000000000..cdfd2b228e --- /dev/null +++ b/doc/changelog/04-tactics/11203-fix-time-printing.rst @@ -0,0 +1,4 @@ +- The optional string argument to :tacn:`time` is now properly quoted + under :cmd:`Print Ltac` (`#11203 + <https://github.com/coq/coq/pull/11203>`_, fixes `#10971 + <https://github.com/coq/coq/issues/10971>`_, by Jason Gross) diff --git a/doc/changelog/04-tactics/11263-micromega-fix.rst b/doc/changelog/04-tactics/11263-micromega-fix.rst new file mode 100644 index 0000000000..ebfb6c19b1 --- /dev/null +++ b/doc/changelog/04-tactics/11263-micromega-fix.rst @@ -0,0 +1,6 @@ +- **Fixed** + Efficiency regression introduced by PR `#9725 <https://github.com/coq/coq/pull/9725>`_. + (`#11263 <https://github.com/coq/coq/pull/11263>`_, + fixes `#11063 <https://github.com/coq/coq/issues/11063>`_, + and `#11242 <https://github.com/coq/coq/issues/11242>`_, + and `#11270 <https://github.com/coq/coq/issues/11270>`_, by Frédéric Besson). diff --git a/doc/changelog/05-tactic-language/10002-ltac2.rst b/doc/changelog/05-tactic-language/10002-ltac2.rst deleted file mode 100644 index 6d62f11eff..0000000000 --- a/doc/changelog/05-tactic-language/10002-ltac2.rst +++ /dev/null @@ -1,9 +0,0 @@ -- Ltac2, a new version of the tactic language Ltac, that doesn't - preserve backward compatibility, has been integrated in the main Coq - distribution. It is still experimental, but we already recommend - users of advanced Ltac to start using it and report bugs or request - enhancements. See its documentation in the :ref:`dedicated chapter - <ltac2>` (`#10002 <https://github.com/coq/coq/pull/10002>`_, plugin - authored by Pierre-Marie Pédrot, with contributions by various - users, integration by Maxime Dénès, help on integrating / improving - the documentation by Théo Zimmermann and Jim Fehrle). diff --git a/doc/changelog/05-tactic-language/10289-ltac2+delimited-constr-in-notations.rst b/doc/changelog/05-tactic-language/10289-ltac2+delimited-constr-in-notations.rst deleted file mode 100644 index bd1c0c42e8..0000000000 --- a/doc/changelog/05-tactic-language/10289-ltac2+delimited-constr-in-notations.rst +++ /dev/null @@ -1,5 +0,0 @@ -- Ltac2 tactic notations with “constr” arguments can specify the - interpretation scope for these arguments; - see :ref:`ltac2_notations` for details - (`#10289 <https://github.com/coq/coq/pull/10289>`_, - by Vincent Laporte). diff --git a/doc/changelog/05-tactic-language/10324-ltac2-ssr-ampersand.rst b/doc/changelog/05-tactic-language/10324-ltac2-ssr-ampersand.rst deleted file mode 100644 index fba09f5e87..0000000000 --- a/doc/changelog/05-tactic-language/10324-ltac2-ssr-ampersand.rst +++ /dev/null @@ -1,5 +0,0 @@ -- White spaces are forbidden in the “&ident” syntax for ltac2 references - that are described in :ref:`ltac2_built-in-quotations` - (`#10324 <https://github.com/coq/coq/pull/10324>`_, - fixes `#10088 <https://github.com/coq/coq/issues/10088>`_, - authored by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/11241-master+bug-cofix-with-8.10.rst b/doc/changelog/05-tactic-language/11241-master+bug-cofix-with-8.10.rst new file mode 100644 index 0000000000..462ba4a7b1 --- /dev/null +++ b/doc/changelog/05-tactic-language/11241-master+bug-cofix-with-8.10.rst @@ -0,0 +1,4 @@ +- **Fixed:** + Syntax of tactic `cofix ... with ...` was broken from Coq 8.10. + (`#11241 <https://github.com/coq/coq/pull/11241>`_, + by Hugo Herbelin). diff --git a/doc/changelog/06-ssreflect/10022-ssr-under-setoid.rst b/doc/changelog/06-ssreflect/10022-ssr-under-setoid.rst deleted file mode 100644 index 5e005742fd..0000000000 --- a/doc/changelog/06-ssreflect/10022-ssr-under-setoid.rst +++ /dev/null @@ -1,28 +0,0 @@ -- Generalize tactics :tacn:`under` and :tacn:`over` for any registered - relation. More precisely, assume the given context lemma has type - `forall f1 f2, .. -> (forall i, R1 (f1 i) (f2 i)) -> R2 f1 f2`. The - first step performed by :tacn:`under` (since Coq 8.10) amounts to - calling the tactic :tacn:`rewrite <rewrite (ssreflect)>`, which - itself relies on :tacn:`setoid_rewrite` if need be. So this step was - already compatible with a double implication or setoid equality for - the conclusion head symbol `R2`. But a further step consists in - tagging the generated subgoal `R1 (f1 i) (?f2 i)` to protect it from - unwanted evar instantiation, and get `Under_rel _ R1 (f1 i) (?f2 i)` - that is displayed as ``'Under[ f1 i ]``. In Coq 8.10, this second - (convenience) step was only performed when `R1` was Leibniz' `eq` or - `iff`. Now, it is also performed for any relation `R1` which has a - ``RewriteRelation`` instance (a `RelationClasses.Reflexive` instance - being also needed so :tacn:`over` can discharge the ``'Under[ _ ]`` - goal by instantiating the hidden evar.) Also, it is now possible to - manipulate `Under_rel _ R1 (f1 i) (?f2 i)` subgoals directly if `R1` - is a `PreOrder` relation or so, thanks to extra instances proving - that `Under_rel` preserves the properties of the `R1` relation. - These two features generalizing support for setoid-like relations is - enabled as soon as we do both ``Require Import ssreflect.`` and - ``Require Setoid.`` Finally, a rewrite rule ``UnderE`` has been - added if one wants to "unprotect" the evar, and instantiate it - manually with another rule than reflexivity (i.e., without using the - :tacn:`over` tactic nor the ``over`` rewrite rule). See also Section - :ref:`under_ssr` (`#10022 <https://github.com/coq/coq/pull/10022>`_, - by Erik Martin-Dorel, with suggestions and review by Enrico Tassi - and Cyril Cohen). diff --git a/doc/changelog/06-ssreflect/10932-void-type-ssr.rst b/doc/changelog/06-ssreflect/10932-void-type-ssr.rst deleted file mode 100644 index 7366ef1190..0000000000 --- a/doc/changelog/06-ssreflect/10932-void-type-ssr.rst +++ /dev/null @@ -1,3 +0,0 @@ -- Add a :g:`void` notation for the standard library empty type (:g:`Empty_set`) - (`#10932 <https://github.com/coq/coq/pull/10932>`_, by Arthur Azevedo de - Amorim). diff --git a/doc/changelog/06-ssreflect/11136-inj_compr.rst b/doc/changelog/06-ssreflect/11136-inj_compr.rst deleted file mode 100644 index b546fcde6b..0000000000 --- a/doc/changelog/06-ssreflect/11136-inj_compr.rst +++ /dev/null @@ -1,2 +0,0 @@ -- Added lemma :g:`inj_compr` to :g:`ssr.ssrfun` - (`#11136 <https://github.com/coq/coq/pull/11136>`_, by Cyril Cohen). diff --git a/doc/changelog/07-commands-and-options/09530-rm-unknown.rst b/doc/changelog/07-commands-and-options/09530-rm-unknown.rst deleted file mode 100644 index 1c91800c65..0000000000 --- a/doc/changelog/07-commands-and-options/09530-rm-unknown.rst +++ /dev/null @@ -1,6 +0,0 @@ -- Deprecated flag `Refine Instance Mode` has been removed. - (`#9530 <https://github.com/coq/coq/pull/9530>`_, fixes - `#3632 <https://github.com/coq/coq/issues/3632>`_, `#3890 - <https://github.com/coq/coq/issues/3890>`_ and `#4638 - <https://github.com/coq/coq/issues/4638>`_ - by Maxime Dénès, review by Gaëtan Gilbert). diff --git a/doc/changelog/07-commands-and-options/10185-instance-no-bang.rst b/doc/changelog/07-commands-and-options/10185-instance-no-bang.rst deleted file mode 100644 index c69cda9656..0000000000 --- a/doc/changelog/07-commands-and-options/10185-instance-no-bang.rst +++ /dev/null @@ -1,2 +0,0 @@ -- Remove undocumented :n:`Instance : !@type` syntax - (`#10185 <https://github.com/coq/coq/pull/10185>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/07-commands-and-options/10277-no-show-script.rst b/doc/changelog/07-commands-and-options/10277-no-show-script.rst deleted file mode 100644 index 7fdeb632b4..0000000000 --- a/doc/changelog/07-commands-and-options/10277-no-show-script.rst +++ /dev/null @@ -1,2 +0,0 @@ -- Remove ``Show Script`` command (deprecated since 8.10) - (`#10277 <https://github.com/coq/coq/pull/10277>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/07-commands-and-options/10291-typing-flags.rst b/doc/changelog/07-commands-and-options/10291-typing-flags.rst deleted file mode 100644 index ef7adde801..0000000000 --- a/doc/changelog/07-commands-and-options/10291-typing-flags.rst +++ /dev/null @@ -1,4 +0,0 @@ -- Adding unsafe commands to enable/disable guard checking, positivity checking - and universes checking (providing a local `-type-in-type`). - See :ref:`controlling-typing-flags`. - (`#10291 <https://github.com/coq/coq/pull/10291>`_ by Simon Boulier). diff --git a/doc/changelog/07-commands-and-options/10476-fix-export.rst b/doc/changelog/07-commands-and-options/10476-fix-export.rst deleted file mode 100644 index ba71e1c337..0000000000 --- a/doc/changelog/07-commands-and-options/10476-fix-export.rst +++ /dev/null @@ -1,5 +0,0 @@ -- Fix two bugs in `Export`. This can have an impact on the behavior of the - `Import` command on libraries. `Import A` when `A` imports `B` which exports - `C` was importing `C`, whereas `Import` is not transitive. Also, after - `Import A B`, the import of `B` was sometimes incomplete. - (`#10476 <https://github.com/coq/coq/pull/10476>`_, by Maxime Dénès). diff --git a/doc/changelog/07-commands-and-options/10489-print_dependent_evars.rst b/doc/changelog/07-commands-and-options/10489-print_dependent_evars.rst deleted file mode 100644 index 580e808baa..0000000000 --- a/doc/changelog/07-commands-and-options/10489-print_dependent_evars.rst +++ /dev/null @@ -1,7 +0,0 @@ -- Update output generated by :flag:`Printing Dependent Evars Line` flag - used by the Prooftree tool in Proof General. - (`#10489 <https://github.com/coq/coq/pull/10489>`_, - closes `#4504 <https://github.com/coq/coq/issues/4504>`_, - `#10399 <https://github.com/coq/coq/issues/10399>`_ and - `#10400 <https://github.com/coq/coq/issues/10400>`_, - by Jim Fehrle). diff --git a/doc/changelog/07-commands-and-options/10494-diffs-in-show-proof.rst b/doc/changelog/07-commands-and-options/10494-diffs-in-show-proof.rst deleted file mode 100644 index c1df728c5c..0000000000 --- a/doc/changelog/07-commands-and-options/10494-diffs-in-show-proof.rst +++ /dev/null @@ -1,6 +0,0 @@ -- Optionally highlight the differences between successive proof steps in the - :cmd:`Show Proof` command. Experimental; only available in coqtop - and Proof General for now, may be supported in other IDEs - in the future. - (`#10494 <https://github.com/coq/coq/pull/10494>`_, - by Jim Fehrle). diff --git a/doc/changelog/07-commands-and-options/11162-local-cs.rst b/doc/changelog/07-commands-and-options/11162-local-cs.rst new file mode 100644 index 0000000000..5a69a107cd --- /dev/null +++ b/doc/changelog/07-commands-and-options/11162-local-cs.rst @@ -0,0 +1 @@ +- Handle the ``#[local]`` attribute in :g:`Canonical Structure` declarations (`#11162 <https://github.com/coq/coq/pull/11162>`_, by Enrico Tassi). diff --git a/doc/changelog/07-commands-and-options/11185-remove-typeclasses-axioms-instances.rst b/doc/changelog/07-commands-and-options/11185-remove-typeclasses-axioms-instances.rst new file mode 100644 index 0000000000..9fc09c4189 --- /dev/null +++ b/doc/changelog/07-commands-and-options/11185-remove-typeclasses-axioms-instances.rst @@ -0,0 +1,3 @@ +- **Removed:** ``Typeclasses Axioms Are Instances`` flag, deprecated since 8.10. + Use :cmd:`Declare Instance` for axioms which should be instances + (`#11185 <https://github.com/coq/coq/pull/11185>`_, by Théo Zimmermann). diff --git a/doc/changelog/07-commands-and-options/11258-coherence.rst b/doc/changelog/07-commands-and-options/11258-coherence.rst new file mode 100644 index 0000000000..f04a120417 --- /dev/null +++ b/doc/changelog/07-commands-and-options/11258-coherence.rst @@ -0,0 +1,10 @@ +- **Changed:** + The :cmd:`Coercion` command has been improved to check the coherence of the + inheritance graph. It checks whether a circular inheritance path of `C >-> C` + is convertible with the identity function or not, then report it as an + ambiguous path if it is not. The new mechanism does not report ambiguous + paths that are redundant with others. For example, checking the ambiguity of + `[f; g]` and `[f'; g]` is redundant with that of `[f]` and `[f']` thus will + not be reported + (`#11258 <https://github.com/coq/coq/pull/11258>`_, + by Kazuhiko Sakaguchi). diff --git a/doc/changelog/08-tools/08642-vos-files.rst b/doc/changelog/08-tools/08642-vos-files.rst deleted file mode 100644 index f612096880..0000000000 --- a/doc/changelog/08-tools/08642-vos-files.rst +++ /dev/null @@ -1,7 +0,0 @@ -- `coqc` now provides the ability to generate compiled interfaces. - Use `coqc -vos foo.v` to skip all opaque proofs during the - compilation of `foo.v`, and output a file called `foo.vos`. - This feature is experimental. It enables working on a Coq file without the need to - first compile the proofs contained in its dependencies - (`#8642 <https://github.com/coq/coq/pull/8642>`_ by Arthur Charguéraud, review by - Maxime Dénès and Emilio Gallego). diff --git a/doc/changelog/08-tools/10245-require-command-line.rst b/doc/changelog/08-tools/10245-require-command-line.rst deleted file mode 100644 index 54417077f5..0000000000 --- a/doc/changelog/08-tools/10245-require-command-line.rst +++ /dev/null @@ -1,6 +0,0 @@ -- Add command line options `-require-import`, `-require-export`, - `-require-import-from` and `-require-export-from`, as well as their - shorthand, `-ri`, `-re`, `-refrom` and -`rifrom`. Deprecate - confusing command line option `-require` - (`#10245 <https://github.com/coq/coq/pull/10245>`_ - by Hugo Herbelin, review by Emilio Gallego). diff --git a/doc/changelog/08-tools/10947-coq-makefile-dep.rst b/doc/changelog/08-tools/10947-coq-makefile-dep.rst deleted file mode 100644 index f620b32cb8..0000000000 --- a/doc/changelog/08-tools/10947-coq-makefile-dep.rst +++ /dev/null @@ -1,5 +0,0 @@ -- Renamed `VDFILE` from `.coqdeps.d` to `.<CoqMakefile>.d` in the `coq_makefile` - utility, where `<CoqMakefile>` is the name of the output file given by the - `-o` option. In this way two generated makefiles can coexist in the same - directory. - (`#10947 <https://github.com/coq/coq/pull/10947>`_, by Kazuhiko Sakaguchi). diff --git a/doc/changelog/08-tools/11068-coqbin-noslash.rst b/doc/changelog/08-tools/11068-coqbin-noslash.rst deleted file mode 100644 index c2c8f4df31..0000000000 --- a/doc/changelog/08-tools/11068-coqbin-noslash.rst +++ /dev/null @@ -1,3 +0,0 @@ -- ``coq_makefile`` now supports environment variable ``COQBIN`` with - no ending ``/`` character (`#11068 - <https://github.com/coq/coq/pull/11068>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/08-tools/11255-master+fix11254-coqtop-version.rst b/doc/changelog/08-tools/11255-master+fix11254-coqtop-version.rst new file mode 100644 index 0000000000..ecc134748d --- /dev/null +++ b/doc/changelog/08-tools/11255-master+fix11254-coqtop-version.rst @@ -0,0 +1,4 @@ +- **Fixed:** + ``coqtop --version`` was broken when called in the middle of an installation process + (`#11255 <https://github.com/coq/coq/pull/11255>`_, by Hugo Herbelin, fixing + `#11254 <https://github.com/coq/coq/pull/11254>`_). diff --git a/doc/changelog/10-standard-library/09772-ordered_type-hint-db.rst b/doc/changelog/10-standard-library/09772-ordered_type-hint-db.rst deleted file mode 100644 index 7babcdb6f1..0000000000 --- a/doc/changelog/10-standard-library/09772-ordered_type-hint-db.rst +++ /dev/null @@ -1,4 +0,0 @@ -- Moved the `auto` hints of the `OrderedType` module into a new `ordered_type` - database - (`#9772 <https://github.com/coq/coq/pull/9772>`_, - by Vincent Laporte). diff --git a/doc/changelog/10-standard-library/09811-remove-zlogarithm.rst b/doc/changelog/10-standard-library/09811-remove-zlogarithm.rst deleted file mode 100644 index ab625b9e03..0000000000 --- a/doc/changelog/10-standard-library/09811-remove-zlogarithm.rst +++ /dev/null @@ -1,4 +0,0 @@ -- Removes deprecated modules `Coq.ZArith.Zlogarithm` - and `Coq.ZArith.Zsqrt_compat` - (#9881 <https://github.com/coq/coq/pull/9811> - by Vincent Laporte). diff --git a/doc/changelog/10-standard-library/10445-constructive-reals.rst b/doc/changelog/10-standard-library/10445-constructive-reals.rst deleted file mode 100644 index d69056fc2f..0000000000 --- a/doc/changelog/10-standard-library/10445-constructive-reals.rst +++ /dev/null @@ -1,12 +0,0 @@ -- New module `Reals.ConstructiveCauchyReals` defines constructive real numbers - by Cauchy sequences of rational numbers. Classical real numbers are now defined - as a quotient of these constructive real numbers, which significantly reduces - the number of axioms needed (see `Reals.Rdefinitions` and `Reals.Raxioms`), - while preserving backward compatibility. - - Futhermore, the new axioms for classical real numbers include the limited - principle of omniscience (`sig_forall_dec`), which is a logical principle - instead of an ad hoc property of the real numbers. - - See `#10445 <https://github.com/coq/coq/pull/10445>`_, by Vincent Semeria, - with the help and review of Guillaume Melquiond and Bas Spitters. diff --git a/doc/changelog/10-standard-library/10651-new-lemmas-for-lists.rst b/doc/changelog/10-standard-library/10651-new-lemmas-for-lists.rst deleted file mode 100644 index 864c4e6a7e..0000000000 --- a/doc/changelog/10-standard-library/10651-new-lemmas-for-lists.rst +++ /dev/null @@ -1,6 +0,0 @@ -- New lemmas on :g:`combine`, :g:`filter`, :g:`nodup`, :g:`nth`, and - :g:`nth_error` functions on lists. The lemma :g:`filter_app` was moved to the - :g:`List` module. - - See `#10651 <https://github.com/coq/coq/pull/10651>`_, and - `#10731 <https://github.com/coq/coq/pull/10731>`_, by Oliver Nash. diff --git a/doc/changelog/10-standard-library/10827-dedekind-reals.rst b/doc/changelog/10-standard-library/10827-dedekind-reals.rst deleted file mode 100644 index 5d8467025b..0000000000 --- a/doc/changelog/10-standard-library/10827-dedekind-reals.rst +++ /dev/null @@ -1,11 +0,0 @@ -- New module `Reals.ClassicalDedekindReals` defines Dedekind real numbers - as boolean-values functions along with 3 logical axioms: limited principle - of omniscience, excluded middle of negations and functional extensionality. - The exposed type :g:`R` in module :g:`Reals.Rdefinitions` is those - Dedekind reals, hidden behind an opaque module. - Classical Dedekind reals are a quotient of constructive reals, which allows - to transport many constructive proofs to the classical case. - - See `#10827 <https://github.com/coq/coq/pull/10827>`_, by Vincent Semeria, - based on discussions with Guillaume Melquiond, Bas Spitters and Hugo Herbelin, - code review by Hugo Herbelin. diff --git a/doc/changelog/10-standard-library/10895-master+weak-excluded-middle-de-morgan.rst b/doc/changelog/10-standard-library/10895-master+weak-excluded-middle-de-morgan.rst deleted file mode 100644 index 6e87ff93c7..0000000000 --- a/doc/changelog/10-standard-library/10895-master+weak-excluded-middle-de-morgan.rst +++ /dev/null @@ -1 +0,0 @@ -- ClassicalFacts: Adding the standard equivalence between weak excluded-middle and the classical instance of De Morgan's law (`#10895 <https://github.com/coq/coq/pull/10895>`_, by Hugo Herbelin). diff --git a/doc/changelog/10-standard-library/11127-trunk.rst b/doc/changelog/10-standard-library/11127-trunk.rst new file mode 100644 index 0000000000..ef1d41d17f --- /dev/null +++ b/doc/changelog/10-standard-library/11127-trunk.rst @@ -0,0 +1,2 @@ +- **Added:** theorem :g:`bezout_comm` for natural numbers + (`#11127 <https://github.com/coq/coq/pull/11127>`_, by Daniel de Rauglaudre). diff --git a/doc/changelog/11-infrastructure-and-dependencies/10471-ocaml-408.rst b/doc/changelog/11-infrastructure-and-dependencies/10471-ocaml-408.rst deleted file mode 100644 index 8bfd01d7a0..0000000000 --- a/doc/changelog/11-infrastructure-and-dependencies/10471-ocaml-408.rst +++ /dev/null @@ -1,5 +0,0 @@ -- Coq now officially supports OCaml 4.08. - - see INSTALL files for details - (`#10471 <https://github.com/coq/coq/pull/10471>`_, - by Emilio Jesús Gallego Arias). diff --git a/doc/changelog/11-infrastructure-and-dependencies/11227-date.rst b/doc/changelog/11-infrastructure-and-dependencies/11227-date.rst new file mode 100644 index 0000000000..5c08e2b0ea --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/11227-date.rst @@ -0,0 +1,5 @@ +- **Added:** + Build date can now be overriden by setting the `SOURCE_DATE_EPOCH` + environment variable + (`#11227 <https://github.com/coq/coq/pull/11227>`_, + by Bernhard M. Wiedemann). diff --git a/doc/changelog/README.md b/doc/changelog/README.md index 3e0970a656..05bf710f89 100644 --- a/doc/changelog/README.md +++ b/doc/changelog/README.md @@ -15,12 +15,12 @@ entry in [`dev/doc/changes.md`](../../dev/doc/changes.md). ## How to add an entry? ## Run `./dev/tools/make-changelog.sh`: it will ask you for your PR -number, and to choose among the predefined categories. Afterward, -fill in the automatically generated entry with a short description of -your change (which should describe any compatibility issues in -particular). You may also add a reference to the relevant fixed -issue, and credit reviewers, co-authors, and anyone who helped advance -the PR. +number, and to choose among the predefined categories, and the +predefined types of changes. Afterward, fill in the automatically +generated entry with a short description of your change (which should +describe any compatibility issues in particular). You may also add a +reference to the relevant fixed issue, and credit reviewers, +co-authors, and anyone who helped advance the PR. The format for changelog entries is the same as in the reference manual. In particular, you may reference the documentation you just @@ -31,10 +31,18 @@ manual for details. Here is a summary of the structure of a changelog entry: ``` rst -- Description of the changes, with possible link to +- **Added / Changed / Deprecated / Fixed / Removed:** + Description of the changes, with possible link to :ref:`relevant-section` of the updated documentation (`#PRNUM <https://github.com/coq/coq/pull/PRNUM>`_, [fixes `#ISSUE1 <https://github.com/coq/coq/issues/ISSUE1>`_ [ and `#ISSUE2 <https://github.com/coq/coq/issues/ISSUE2>`_],] by Full Name[, with help / review of Full Name]). ``` + +The first line indicates the type of change. Available types come +from the [Keep a Changelog +1.0.0](https://keepachangelog.com/en/1.0.0/) specification. We +exclude the "Security" type for now because of the absence of a +process for handling critical bugs (proof of False) as security +vulnerabilities. diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index ca5b5e54a7..9f5741f72a 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -9,7 +9,7 @@ This chapter presents the extension of several equality related tactics to work over user-defined structures (called setoids) that are equipped with ad-hoc equivalence relations meant to behave as equalities. Actually, the tactics have also been generalized to -relations weaker then equivalences (e.g. rewriting systems). The +relations weaker than equivalences (e.g. rewriting systems). The toolbox also extends the automatic rewriting capabilities of the system, allowing the specification of custom strategies for rewriting. diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index c3b197288f..19b33f0d90 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -165,6 +165,12 @@ Declaring Coercions convertible with existing ones when they have coercions that don't satisfy the uniform inheritance condition. + .. warn:: ... is not definitionally an identity function. + + If a coercion path has the same source and target class, that is said to be + circular. When a new circular coercion path is not convertible with the + identity function, it will be reported as ambiguous. + .. cmdv:: Local Coercion @qualid : @class >-> @class Declares the construction denoted by :token:`qualid` as a coercion local to diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 661aa88082..57a2254100 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -576,14 +576,6 @@ Settings of goals. Setting this option to 1 or 2 turns on the :flag:`Typeclasses Debug` flag; setting this option to 0 turns that flag off. -.. flag:: Typeclasses Axioms Are Instances - - .. deprecated:: 8.10 - - This flag (off by default since 8.8) automatically declares axioms - whose type is a typeclass at declaration time as instances of that - class. - Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 80a24b997c..1d0c937792 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -6,6 +6,512 @@ Recent changes .. include:: ../unreleased.rst +Version 8.11 +------------ + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +The main changes brought by |Coq| version 8.11 are: + +- `Ltac2`__, a new tactic language for writing more robust larger scale + tactics, with built-in support for datatypes and the multi-goal tactic monad. +- `Primitive floats`__ are integrated in terms and follow the binary64 format + of the IEEE 754 standard, as specified in the `Coq.Float.Floats` library. +- `Cleanups`__ of the section mechanism, delayed proofs and further + restrictions of template polymorphism to fix soundness issues related to + universes. +- New `unsafe flags`__ to disable locally guard, positivity and universe + checking. Reliance on these flags is always printed by + :g:`Print Assumptions`. +- `Fixed bugs`__ of :g:`Export` and :g:`Import` that can have a + significant impact on user developments (**common source of + incompatibility!**). +- New interactive development method based on `vos` `interface files`__, + allowing to work on a file without recompiling the proof parts of their + dependencies. +- New :g:`Arguments` annotation for `bidirectional type inference`__ + configuration for reference (e.g. constants, inductive) applications. +- New `refine attribute`__ for :cmd:`Instance` can be used instead of + the removed ``Refine Instance Mode``. +- Generalization of the :g:`under` and :g:`over` tactics__ of SSReflect to + arbitrary relations. +- `Revision`__ of the :g:`Coq.Reals` library, its axiomatisation and + instances of the constructive and classical real numbers. + +__ 811Ltac2_ +__ 811PrimitiveFloats_ +__ 811Sections_ +__ 811UnsafeFlags_ +__ 811ExportBug_ +__ 811vos_ +__ 811BidirArguments_ +__ 811RefineInstance_ +__ 811SSRUnderOver_ +__ 811Reals_ + +The ``dev/doc/critical-bugs`` file documents the known critical bugs of |Coq| +and affected releases. See the `Changes in 8.11+beta1`_ section for the +detailed list of changes, including potentially breaking changes marked with +**Changed**. + +Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael +Soegtrop, Théo Zimmermann worked on maintaining and improving the +continuous integration system and package building infrastructure. + +Coq's documentation is available at https://coq.github.io/doc/V8.11+beta1/api (documentation of +the ML API), https://coq.github.io/doc/V8.11+beta1/refman (reference +manual), and https://coq.github.io/doc/V8.11+beta1/stdlib (documentation of +the standard library). + +The OPAM repository for |Coq| packages has been maintained by +Karl Palmskog, Matthieu Sozeau, Enrico Tassi with contributions +from many users. A list of packages is available at +https://coq.inria.fr/opam/www/. + +The 61 contributors to this version are Michael D. Adams, Guillaume +Allais, Helge Bahmann, Langston Barrett, Guillaume Bertholon, Frédéric +Besson, Simon Boulier, Michele Caci, Tej Chajed, Arthur Charguéraud, +Cyril Cohen, Frédéric Dabrowski, Arthur Azevedo de Amorim, Maxime +Dénès, Nikita Eshkeev, Jim Fehrle, Emilio Jesús Gallego Arias, +Paolo G. Giarrusso, Gaëtan Gilbert, Georges Gonthier, Jason Gross, +Samuel Gruetter, Armaël Guéneau, Hugo Herbelin, Florent Hivert, Jasper +Hugunin, Shachar Itzhaky, Jan-Oliver Kaiser, Robbert Krebbers, Vincent +Laporte, Olivier Laurent, Samuel Lelièvre, Nicholas Lewycky, Yishuai +Li, Jose Fernando Lopez Fernandez, Andreas Lynge, Kenji Maillard, Erik +Martin-Dorel, Guillaume Melquiond, Alexandre Moine, Oliver Nash, +Wojciech Nawrocki, Antonio Nikishaev, Pierre-Marie Pédrot, Clément +Pit-Claudel, Lars Rasmusson, Robert Rand, Talia Ringer, JP Rodi, +Pierre Roux, Kazuhiko Sakaguchi, Vincent Semeria, Michael Soegtrop, +Matthieu Sozeau, spanjel, Claude Stolze, Enrico Tassi, Laurent Théry, +James R. Wilcox, Xia Li-yao, Théo Zimmermann + +Many power users helped to improve the design of the new features via +the issue and pull request system, the |Coq| development mailing list, +the coq-club@inria.fr mailing list or the `Discourse forum +<https://coq.discourse.group/>`_. It would be impossible to mention +exhaustively the names of everybody who to some extent influenced the +development. + +Version 8.11 is the sixth release of |Coq| developed on a time-based +development cycle. Its development spanned 3 months from the release of +|Coq| 8.10. Pierre-Marie Pédrot is the release manager and maintainer of this +release, assisted by Matthieu Sozeau. This release is the result of 2000+ +commits and 300+ PRs merged, closing 75+ issues. + +| Paris, November 2019, +| Matthieu Sozeau for the |Coq| development team +| + + +Changes in 8.11+beta1 +~~~~~~~~~~~~~~~~~~~~~ + +**Kernel** + + .. _811PrimitiveFloats: + +- **Added:** + A built-in support of floating-point arithmetic, allowing + one to devise efficient reflection tactics involving numerical + computation. Primitive floats are added in the language of terms, + following the binary64 format of the IEEE 754 standard, and the + related operations are implemented for the different reduction + engines of Coq by using the corresponding processor operators in + rounding-to-nearest-even. The properties of these operators are + axiomatized in the theory :g:`Coq.Floats.FloatAxioms` which is part + of the library :g:`Coq.Floats.Floats`. + See Section :ref:`primitive-floats` + (`#9867 <https://github.com/coq/coq/pull/9867>`_, + closes `#8276 <https://github.com/coq/coq/issues/8276>`_, + by Guillaume Bertholon, Erik Martin-Dorel, Pierre Roux). +- **Changed:** + Internal definitions generated by :tacn:`abstract`\-like tactics are now inlined + inside universe :cmd:`Qed`\-terminated polymorphic definitions, similarly to what + happens for their monomorphic counterparts, + (`#10439 <https://github.com/coq/coq/pull/10439>`_, by Pierre-Marie Pédrot). + + .. _811Sections: + +- **Fixed:** + Section data is now part of the kernel. Solves a soundness issue + in interactive mode where global monomorphic universe constraints would be + dropped when forcing a delayed opaque proof inside a polymorphic section. Also + relaxes the nesting criterion for sections, as polymorphic sections can now + appear inside a monomorphic one + (`#10664, <https://github.com/coq/coq/pull/10664>`_ by Pierre-Marie Pédrot). +- **Changed:** + Using ``SProp`` is now allowed by default, without needing to pass + ``-allow-sprop`` or use :flag:`Allow StrictProp` (`#10811 + <https://github.com/coq/coq/pull/10811>`_, by Gaëtan Gilbert). + +**Specification language, type inference** + + .. _811BidirArguments: + +- **Added:** + Annotation in `Arguments` for bidirectionality hints: it is now possible + to tell type inference to use type information from the context once the `n` + first arguments of an application are known. The syntax is: + `Arguments foo x y & z`. See :cmd:`Arguments (bidirectionality hints)` + (`#10049 <https://github.com/coq/coq/pull/10049>`_, by Maxime Dénès with + help from Enrico Tassi). +- **Added:** + Record fields can be annotated to prevent them from being used as canonical projections; + see :ref:`canonicalstructures` for details + (`#10076 <https://github.com/coq/coq/pull/10076>`_, + by Vincent Laporte). +- **Changed:** + Require parentheses around nested disjunctive patterns, so that pattern and + term syntax are consistent; match branch patterns no longer require + parentheses for notation at level 100 or more. + + .. warning:: Incompatibilities + + + In :g:`match p with (_, (0|1)) => ...` parentheses may no longer be + omitted around :n:`0|1`. + + Notation :g:`(p | q)` now potentially clashes with core pattern syntax, + and should be avoided. ``-w disj-pattern-notation`` flags such :cmd:`Notation`. + + See :ref:`extendedpatternmatching` for details + (`#10167 <https://github.com/coq/coq/pull/10167>`_, + by Georges Gonthier). +- **Changed:** + :cmd:`Function` always opens a proof when used with a ``measure`` or ``wf`` + annotation, see :ref:`advanced-recursive-functions` for the updated + documentation (`#10215 <https://github.com/coq/coq/pull/10215>`_, + by Enrico Tassi). +- **Changed:** + The legacy command :cmd:`Add Morphism` always opens a proof and cannot be used + inside a module type. In order to declare a module type parameter that + happens to be a morphism, use :cmd:`Declare Morphism`. See + :ref:`deprecated_syntax_for_generalized_rewriting` for the updated + documentation (`#10215 <https://github.com/coq/coq/pull/10215>`_, + by Enrico Tassi). +- **Changed:** + The universe polymorphism setting now applies from the opening of a section. + In particular, it is not possible anymore to mix polymorphic and monomorphic + definitions in a section when there are no variables nor universe constraints + defined in this section. This makes the behaviour consistent with the + documentation. (`#10441 <https://github.com/coq/coq/pull/10441>`_, + by Pierre-Marie Pédrot) +- **Added:** + The :cmd:`Section` vernacular command now accepts the "universes" attribute. In + addition to setting the section universe polymorphism, it also locally sets + the universe polymorphic option inside the section. + (`#10441 <https://github.com/coq/coq/pull/10441>`_, by Pierre-Marie Pédrot) +- **Fixed:** + ``Program Fixpoint`` now uses ``ex`` and ``sig`` to make telescopes + involving ``Prop`` types (`#10758 + <https://github.com/coq/coq/pull/10758>`_, by Gaëtan Gilbert, fixing + `#10757 <https://github.com/coq/coq/issues/10757>`_ reported by + Xavier Leroy). +- **Changed:** + Output of the :cmd:`Print` and :cmd:`About` commands. + Arguments meta-data is now displayed as the corresponding + :cmd:`Arguments <Arguments (implicits)>` command instead of the + human-targeted prose used in previous Coq versions. (`#10985 + <https://github.com/coq/coq/pull/10985>`_, by Gaëtan Gilbert). + + .. _811RefineInstance: + +- **Added:** ``#[refine]`` attribute for :cmd:`Instance`, a more + predictable version of the old ``Refine Instance Mode`` which + unconditionally opens a proof (`#10996 + <https://github.com/coq/coq/pull/10996>`_, by Gaëtan Gilbert). +- **Changed:** + The unsupported attribute error is now an error-by-default warning, + meaning it can be disabled (`#10997 + <https://github.com/coq/coq/pull/10997>`_, by Gaëtan Gilbert). +- **Fixed:** Bugs sometimes preventing to define valid (co)fixpoints with implicit arguments + in the presence of local definitions, see `#3282 <https://github.com/coq/coq/issues/3282>`_ + (`#11132 <https://github.com/coq/coq/pull/11132>`_, by Hugo Herbelin). + + .. example:: + + The following features an implicit argument after a local + definition. It was wrongly rejected. + + .. coqtop:: in + + Definition f := fix f (o := true) {n : nat} m {struct m} := + match m with 0 => 0 | S m' => f (n:=n+1) m' end. + +**Notations** + +- **Added:** + Numeral Notations now support sorts in the input to printing + functions (e.g., numeral notations can be defined for terms + containing things like `@cons Set nat nil`). (`#9883 + <https://github.com/coq/coq/pull/9883>`_, by Jason Gross). +- **Added:** + The :cmd:`Notation` and :cmd:`Infix` commands now support the `deprecated` + attribute + (`#10180 <https://github.com/coq/coq/pull/10180>`_, by Maxime Dénès). +- **Deprecated:** + The former `compat` annotation for notations is + deprecated, and its semantics changed. It is now made equivalent to using + a `deprecated` attribute, and is no longer connected with the `-compat` + command-line flag + (`#10180 <https://github.com/coq/coq/pull/10180>`_, by Maxime Dénès). +- **Changed:** + A simplification of parsing rules could cause a slight change of + parsing precedences for the very rare users who defined notations + with `constr` at level strictly between 100 and 200 and used these + notations on the right-hand side of a cast operator (`:`, `:>`, + `:>>`) (`#10963 <https://github.com/coq/coq/pull/10963>`_, by Théo + Zimmermann, simplification initially noticed by Jim Fehrle). + +**Tactics** + +- **Added:** + Syntax :n:`injection @term as [= {+ @intropattern} ]` as + an alternative to :n:`injection @term as {+ @simple_intropattern}` using + the standard :n:`@injection_intropattern` syntax (`#9288 + <https://github.com/coq/coq/pull/9288>`_, by Hugo Herbelin). +- **Changed:** + Reimplementation of the :tacn:`zify` tactic. The tactic is more efficient and copes with dependent hypotheses. + It can also be extended by redefining the tactic ``zify_post_hook``. + (`#9856 <https://github.com/coq/coq/pull/9856>`_, fixes + `#8898 <https://github.com/coq/coq/issues/8898>`_, + `#7886 <https://github.com/coq/coq/issues/7886>`_, + `#9848 <https://github.com/coq/coq/issues/9848>`_ and + `#5155 <https://github.com/coq/coq/issues/5155>`_, by Frédéric Besson). +- **Changed:** + The goal selector tactical ``only`` now checks that the goal range + it is given is valid instead of ignoring goals out of the focus + range (`#10318 <https://github.com/coq/coq/pull/10318>`_, by Gaëtan + Gilbert). +- **Added:** + Flags :flag:`Lia Cache`, :flag:`Nia Cache` and :flag:`Nra Cache`. + (`#10765 <https://github.com/coq/coq/pull/10765>`_, by Frédéric Besson, + see `#10772 <https://github.com/coq/coq/issues/10772>`_ for use case). +- **Added:** + The :tacn:`zify` tactic is now aware of `Z.to_N`. + (`#10774 <https://github.com/coq/coq/pull/10774>`_, grants + `#9162 <https://github.com/coq/coq/issues/9162>`_, by Kazuhiko Sakaguchi). +- **Changed:** + The :tacn:`assert_succeeds` and :tacn:`assert_fails` tactics now + only run their tactic argument once, even if it has multiple + successes. This prevents blow-up and looping from using + multisuccess tactics with :tacn:`assert_succeeds`. (`#10966 + <https://github.com/coq/coq/pull/10966>`_ fixes `#10965 + <https://github.com/coq/coq/issues/10965>`_, by Jason Gross). +- **Fixed:** + The :tacn:`assert_succeeds` and :tacn:`assert_fails` tactics now + behave correctly when their tactic fully solves the goal. (`#10966 + <https://github.com/coq/coq/pull/10966>`_ fixes `#9114 + <https://github.com/coq/coq/issues/9114>`_, by Jason Gross). + +**Tactic language** + + .. _811Ltac2: + +- **Added:** + Ltac2, a new version of the tactic language Ltac, that doesn't + preserve backward compatibility, has been integrated in the main Coq + distribution. It is still experimental, but we already recommend + users of advanced Ltac to start using it and report bugs or request + enhancements. See its documentation in the :ref:`dedicated chapter + <ltac2>` (`#10002 <https://github.com/coq/coq/pull/10002>`_, plugin + authored by Pierre-Marie Pédrot, with contributions by various + users, integration by Maxime Dénès, help on integrating / improving + the documentation by Théo Zimmermann and Jim Fehrle). +- **Added:** + Ltac2 tactic notations with “constr” arguments can specify the + interpretation scope for these arguments; + see :ref:`ltac2_notations` for details + (`#10289 <https://github.com/coq/coq/pull/10289>`_, + by Vincent Laporte). +- **Changed:** + White spaces are forbidden in the :n:`&@ident` syntax for ltac2 references + that are described in :ref:`ltac2_built-in-quotations` + (`#10324 <https://github.com/coq/coq/pull/10324>`_, + fixes `#10088 <https://github.com/coq/coq/issues/10088>`_, + authored by Pierre-Marie Pédrot). + +**SSReflect** + + .. _811SSRUnderOver: + +- **Added:** + Generalize tactics :tacn:`under` and :tacn:`over` for any registered + relation. More precisely, assume the given context lemma has type + `forall f1 f2, .. -> (forall i, R1 (f1 i) (f2 i)) -> R2 f1 f2`. The + first step performed by :tacn:`under` (since Coq 8.10) amounts to + calling the tactic :tacn:`rewrite <rewrite (ssreflect)>`, which + itself relies on :tacn:`setoid_rewrite` if need be. So this step was + already compatible with a double implication or setoid equality for + the conclusion head symbol `R2`. But a further step consists in + tagging the generated subgoal `R1 (f1 i) (?f2 i)` to protect it from + unwanted evar instantiation, and get `Under_rel _ R1 (f1 i) (?f2 i)` + that is displayed as ``'Under[ f1 i ]``. In Coq 8.10, this second + (convenience) step was only performed when `R1` was Leibniz' `eq` or + `iff`. Now, it is also performed for any relation `R1` which has a + ``RewriteRelation`` instance (a `RelationClasses.Reflexive` instance + being also needed so :tacn:`over` can discharge the ``'Under[ _ ]`` + goal by instantiating the hidden evar.) Also, it is now possible to + manipulate `Under_rel _ R1 (f1 i) (?f2 i)` subgoals directly if `R1` + is a `PreOrder` relation or so, thanks to extra instances proving + that `Under_rel` preserves the properties of the `R1` relation. + These two features generalizing support for setoid-like relations is + enabled as soon as we do both ``Require Import ssreflect.`` and + ``Require Setoid.`` Finally, a rewrite rule ``UnderE`` has been + added if one wants to "unprotect" the evar, and instantiate it + manually with another rule than reflexivity (i.e., without using the + :tacn:`over` tactic nor the ``over`` rewrite rule). See also Section + :ref:`under_ssr` (`#10022 <https://github.com/coq/coq/pull/10022>`_, + by Erik Martin-Dorel, with suggestions and review by Enrico Tassi + and Cyril Cohen). +- **Added:** + A :g:`void` notation for the standard library empty type (:g:`Empty_set`) + (`#10932 <https://github.com/coq/coq/pull/10932>`_, by Arthur Azevedo de + Amorim). +- **Added:** Lemma :g:`inj_compr` to :g:`ssr.ssrfun` + (`#11136 <https://github.com/coq/coq/pull/11136>`_, by Cyril Cohen). + +**Commands and options** + +- **Removed:** + Deprecated flag `Refine Instance Mode` + (`#9530 <https://github.com/coq/coq/pull/9530>`_, fixes + `#3632 <https://github.com/coq/coq/issues/3632>`_, `#3890 + <https://github.com/coq/coq/issues/3890>`_ and `#4638 + <https://github.com/coq/coq/issues/4638>`_ + by Maxime Dénès, review by Gaëtan Gilbert). +- **Removed:** + Undocumented :n:`Instance : !@type` syntax + (`#10185 <https://github.com/coq/coq/pull/10185>`_, by Gaëtan Gilbert). +- **Removed:** + Deprecated ``Show Script`` command + (`#10277 <https://github.com/coq/coq/pull/10277>`_, by Gaëtan Gilbert). + + .. _811UnsafeFlags: + +- **Added:** + Unsafe commands to enable/disable guard checking, positivity checking + and universes checking (providing a local `-type-in-type`). + See :ref:`controlling-typing-flags` + (`#10291 <https://github.com/coq/coq/pull/10291>`_ by Simon Boulier). + + .. _811ExportBug: + +- **Fixed:** + Two bugs in :cmd:`Export`. This can have an impact on the behavior of the + :cmd:`Import` command on libraries. `Import A` when `A` imports `B` which exports + `C` was importing `C`, whereas :cmd:`Import` is not transitive. Also, after + `Import A B`, the import of `B` was sometimes incomplete + (`#10476 <https://github.com/coq/coq/pull/10476>`_, by Maxime Dénès). + + .. warning:: + + This is a common source of incompatibilities in projects + migrating to Coq 8.11. + +- **Changed:** + Output generated by :flag:`Printing Dependent Evars Line` flag + used by the Prooftree tool in Proof General. + (`#10489 <https://github.com/coq/coq/pull/10489>`_, + closes `#4504 <https://github.com/coq/coq/issues/4504>`_, + `#10399 <https://github.com/coq/coq/issues/10399>`_ and + `#10400 <https://github.com/coq/coq/issues/10400>`_, + by Jim Fehrle). +- **Added:** + Optionally highlight the differences between successive proof steps in the + :cmd:`Show Proof` command. Experimental; only available in coqtop + and Proof General for now, may be supported in other IDEs + in the future. + (`#10494 <https://github.com/coq/coq/pull/10494>`_, + by Jim Fehrle). +- **Removed:** Legacy commands ``AddPath``, ``AddRecPath``, and ``DelPath`` + which were undocumented, broken variants of :cmd:`Add LoadPath`, + :cmd:`Add Rec LoadPath`, and :cmd:`Remove LoadPath` + (`#11187 <https://github.com/coq/coq/pull/11187>`_, + by Maxime Dénès and Théo Zimmermann). + +**Tools** + + .. _811vos: + +- **Added:** + `coqc` now provides the ability to generate compiled interfaces. + Use `coqc -vos foo.v` to skip all opaque proofs during the + compilation of `foo.v`, and output a file called `foo.vos`. + This feature is experimental. It enables working on a Coq file without the need to + first compile the proofs contained in its dependencies + (`#8642 <https://github.com/coq/coq/pull/8642>`_ by Arthur Charguéraud, review by + Maxime Dénès and Emilio Gallego). +- **Added:** + Command-line options `-require-import`, `-require-export`, + `-require-import-from` and `-require-export-from`, as well as their + shorthand, `-ri`, `-re`, `-refrom` and -`rifrom`. Deprecate + confusing command line option `-require` + (`#10245 <https://github.com/coq/coq/pull/10245>`_ + by Hugo Herbelin, review by Emilio Gallego). +- **Changed:** + Renamed `VDFILE` from `.coqdeps.d` to `.<CoqMakefile>.d` in the `coq_makefile` + utility, where `<CoqMakefile>` is the name of the output file given by the + `-o` option. In this way two generated makefiles can coexist in the same + directory. + (`#10947 <https://github.com/coq/coq/pull/10947>`_, by Kazuhiko Sakaguchi). +- **Fixed:** ``coq_makefile`` now supports environment variable ``COQBIN`` with + no ending ``/`` character (`#11068 + <https://github.com/coq/coq/pull/11068>`_, by Gaëtan Gilbert). + +**Standard library** + +- **Changed:** + Moved the :tacn:`auto` hints of the `OrderedType` module into a new `ordered_type` + database + (`#9772 <https://github.com/coq/coq/pull/9772>`_, + by Vincent Laporte). +- **Removed:** + Deprecated modules `Coq.ZArith.Zlogarithm` and `Coq.ZArith.Zsqrt_compat` + (`#9881 <https://github.com/coq/coq/pull/9811>`_, + by Vincent Laporte). + + .. _811Reals: + +- **Added:** + Module `Reals.ConstructiveCauchyReals` defines constructive real numbers + by Cauchy sequences of rational numbers + (`#10445 <https://github.com/coq/coq/pull/10445>`_, by Vincent Semeria, + with the help and review of Guillaume Melquiond and Bas Spitters). +- **Added:** + New module `Reals.ClassicalDedekindReals` defines Dedekind real + numbers as boolean-valued functions along with 3 logical axioms: + limited principle of omniscience, excluded middle of negations, and + functional extensionality. The exposed type :g:`R` in module + :g:`Reals.Rdefinitions` now corresponds to these Dedekind reals, + hidden behind an opaque module, which significantly reduces the + number of axioms needed (see `Reals.Rdefinitions` and + `Reals.Raxioms`), while preserving backward compatibility. + Classical Dedekind reals are a quotient of constructive reals, which + allows to transport many constructive proofs to the classical case + (`#10827 <https://github.com/coq/coq/pull/10827>`_, by Vincent Semeria, + based on discussions with Guillaume Melquiond, Bas Spitters and Hugo Herbelin, + code review by Hugo Herbelin). +- **Added:** + New lemmas on :g:`combine`, :g:`filter`, :g:`nodup`, :g:`nth`, and + :g:`nth_error` functions on lists + (`#10651 <https://github.com/coq/coq/pull/10651>`_, and + `#10731 <https://github.com/coq/coq/pull/10731>`_, by Oliver Nash). +- **Changed:** + The lemma :g:`filter_app` was moved to the :g:`List` module + (`#10651 <https://github.com/coq/coq/pull/10651>`_, by Oliver Nash). +- **Added:** + Standard equivalence between weak excluded-middle and the + classical instance of De Morgan's law, in module :g:`ClassicalFacts` + (`#10895 <https://github.com/coq/coq/pull/10895>`_, by Hugo Herbelin). + +**Infrastructure and dependencies** + +- **Changed:** + Coq now officially supports OCaml 4.08. + See `INSTALL` file for details + (`#10471 <https://github.com/coq/coq/pull/10471>`_, + by Emilio Jesús Gallego Arias). + Version 8.10 ------------ @@ -568,7 +1074,7 @@ Other changes in 8.10+beta1 - The prelude used to be automatically Exported and is now only Imported. This should be relevant only when importing files which don't use `-noinit` into files which do - (`#9013 <https://github.com/coq/coq/pull/9013>`_, by Gaëtan Gilert). + (`#9013 <https://github.com/coq/coq/pull/9013>`_, by Gaëtan Gilbert). - Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an ordered type, using lexical order @@ -765,6 +1271,51 @@ A few bug fixes and documentation improvements, in particular: fixes `#4741 <https://github.com/coq/coq/issues/4741>`_, by Helge Bahmann). +Changes in 8.10.2 +~~~~~~~~~~~~~~~~~ + +**Kernel** + +- Fixed a critical bug of template polymorphism and nonlinear universes + (`#11128 <https://github.com/coq/coq/pull/11128>`_, + fixes `#11039 <https://github.com/coq/coq/issues/11039>`_, + by Gaëtan Gilbert). + +- Fixed an anomaly “Uncaught exception Constr.DestKO” on :g:`Inductive` + (`#11052 <https://github.com/coq/coq/pull/11052>`_, + fixes `#11048 <https://github.com/coq/coq/issues/11048>`_, + by Gaëtan Gilbert). + +- Fixed an anomaly “not enough abstractions in fix body” + (`#11014 <https://github.com/coq/coq/pull/11014>`_, + fixes `#8459 <https://github.com/coq/coq/issues/8459>`_, + by Gaëtan Gilbert). + +**Notations** + +- Fixed an 8.10 regression related to the printing of coercions associated to notations + (`#11090 <https://github.com/coq/coq/pull/11090>`_, + fixes `#11033 <https://github.com/coq/coq/issues/11033>`_, by Hugo Herbelin). + +**CoqIDE** + +- Fixed uneven dimensions of CoqIDE panels when window has been resized + (`#11070 <https://github.com/coq/coq/pull/11070>`_, + fixes 8.10-regression `#10956 <https://github.com/coq/coq/issues/10956>`_, + by Guillaume Melquiond). + +- Do not include final stops in queries + (`#11069 <https://github.com/coq/coq/pull/11069>`_, + fixes 8.10-regression `#11058 <https://github.com/coq/coq/issues/11058>`_, + by Guillaume Melquiond). + +**Infrastructure and dependencies** + +- Enable building of executables when they are running + (`#11000 <https://github.com/coq/coq/pull/11000>`_, + fixes 8.9-regression `#10728 <https://github.com/coq/coq/issues/10728>`_, + by Gaëtan Gilbert). + Version 8.9 ----------- diff --git a/doc/sphinx/dune b/doc/sphinx/dune index 353d58c676..b788fbbeed 100644 --- a/doc/sphinx/dune +++ b/doc/sphinx/dune @@ -1,8 +1,10 @@ (dirs :standard _static) -(rule (targets README.gen.rst) +(rule + (targets README.gen.rst) (deps (source_tree ../tools/coqrst) README.template.rst) (action (run ../tools/coqrst/regen_readme.py %{targets}))) -(alias (name refman-html) - (action (diff README.rst README.gen.rst))) +(rule + (alias refman-html) + (action (diff README.rst README.gen.rst))) diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index ae0afc7819..8caa289a47 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -2003,10 +2003,11 @@ applied to an unknown structure instance (an implicit argument) and a value. The complete documentation of canonical structures can be found in :ref:`canonicalstructures`; here only a simple example is given. -.. cmd:: Canonical {? Structure } @qualid +.. cmd:: {? Local | #[local] } Canonical {? Structure } @qualid This command declares :token:`qualid` as a canonical instance of a - structure (a record). + structure (a record). When the :g:`#[local]` attribute is given the effect + stops at the end of the :g:`Section` containig it. Assume that :token:`qualid` denotes an object ``(Build_struct`` |c_1| … |c_n| ``)`` in the structure :g:`struct` of which the fields are |x_1|, …, |x_n|. @@ -2069,7 +2070,7 @@ in :ref:`canonicalstructures`; here only a simple example is given. See :ref:`canonicalstructures` for a more realistic example. - .. cmdv:: Canonical {? Structure } @ident {? : @type } := @term + .. cmdv:: {? Local | #[local] } Canonical {? Structure } @ident {? : @type } := @term This is equivalent to a regular definition of :token:`ident` followed by the declaration :n:`Canonical @ident`. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 3994ff411c..53cfb973d4 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -555,12 +555,14 @@ Applying theorems This tactic applies to any goal. It behaves like :tacn:`exact` with a big difference: the user can leave some holes (denoted by ``_`` or :n:`(_ : @type)`) in the term. :tacn:`refine` will generate as many - subgoals as there are holes in the term. The type of holes must be either - synthesized by the system or declared by an explicit cast + subgoals as there are remaining holes in the elaborated term. The type + of holes must be either synthesized by the system or declared by an explicit cast like ``(_ : nat -> Prop)``. Any subgoal that occurs in other subgoals is automatically shelved, as if calling - :tacn:`shelve_unifiable`. This low-level tactic can be - useful to advanced users. + :tacn:`shelve_unifiable`. The produced subgoals (shelved or not) + are *not* candidates for typeclass resolution, even if they have a type-class + type as conclusion, letting the user control when and how typeclass resolution + is launched on them. This low-level tactic can be useful to advanced users. .. example:: @@ -611,8 +613,9 @@ Applying theorems .. tacv:: simple notypeclasses refine @term :name: simple notypeclasses refine - This tactic behaves like :tacn:`simple refine` except it performs type checking - without resolution of typeclasses. + This tactic behaves like the combination of :tacn:`simple refine` and + :tacn:`notypeclasses refine`: it performs type checking without resolution of + typeclasses, does not perform beta reductions or shelve the subgoals. .. flag:: Debug Unification @@ -2846,11 +2849,15 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. .. tacv:: cutrewrite <- (@term = @term’) :name: cutrewrite - This tactic is deprecated. It can be replaced by :n:`enough (@term = @term’) as <-`. + .. deprecated:: 8.5 + + This tactic can be replaced by :n:`enough (@term = @term’) as <-`. .. tacv:: cutrewrite -> (@term = @term’) - This tactic is deprecated. It can be replaced by :n:`enough (@term = @term’) as ->`. + .. deprecated:: 8.5 + + This tactic can be replaced by :n:`enough (@term = @term’) as ->`. .. tacn:: subst @ident @@ -4917,6 +4924,8 @@ Performance-oriented tactic variants .. tacv:: convert_concl_no_check @term :name: convert_concl_no_check + .. deprecated:: 8.11 + Deprecated old name for :tacn:`change_no_check`. Does not support any of its variants. diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index a2bc90ffc0..b816ef6210 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -24,6 +24,7 @@ plugins/extraction/Extraction.v plugins/funind/FunInd.v plugins/funind/Recdef.v plugins/ltac/Ltac.v +plugins/micromega/Ztac.v plugins/micromega/DeclConstant.v plugins/micromega/Env.v plugins/micromega/EnvRing.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 21b5678a85..ac611926b3 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -642,5 +642,6 @@ through the <tt>Require Import</tt> command.</p> theories/Compat/Coq89.v theories/Compat/Coq810.v theories/Compat/Coq811.v + theories/Compat/Coq812.v </dd> </dl> diff --git a/dune-project b/dune-project index 45d9d06314..fa05f5fb41 100644 --- a/dune-project +++ b/dune-project @@ -1,7 +1,10 @@ -(lang dune 1.10) +(lang dune 2.0) (name coq) (using coq 0.1) +(formatting + (enabled_for ocaml)) + ; We cannot set this to true until as long as the build is not ; properly bootstrapped [that is, we remove the voboot target] ; diff --git a/engine/proofview.ml b/engine/proofview.ml index ed44372045..6f8e668e4e 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -1025,8 +1025,11 @@ module Unsafe = struct let undefined = undefined - let mark_as_unresolvable p gl = - { p with solution = mark_in_evm ~goal:false p.solution [gl] } + let mark_unresolvables evm evs = + mark_in_evm ~goal:false evm evs + + let mark_as_unresolvables p evs = + { p with solution = mark_in_evm ~goal:false p.solution evs } end diff --git a/engine/proofview.mli b/engine/proofview.mli index 8ec53ac78c..a92179ab5b 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -481,8 +481,13 @@ module Unsafe : sig and makes them unresolvable for type classes. *) val mark_as_goals : Evd.evar_map -> Evar.t list -> Evd.evar_map - (** Make an evar unresolvable for type classes. *) - val mark_as_unresolvable : proofview -> Evar.t -> proofview + (** Make some evars unresolvable for type classes. + We need two functions as some functions use the proofview and others + directly manipulate the undelying evar_map. + *) + val mark_unresolvables : Evd.evar_map -> Evar.t list -> Evd.evar_map + + val mark_as_unresolvables : proofview -> Evar.t list -> proofview (** [advance sigma g] returns [Some g'] if [g'] is undefined and is the current avatar of [g] (for instance [g] was changed by [clear] diff --git a/engine/univMinim.ml b/engine/univMinim.ml index 30fdd28997..fc0770cf75 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -276,7 +276,7 @@ let normalize_context_set ~lbound g ctx us algs weak = Constraint.partition (fun (l,d,r) -> d == Le && (Level.equal l lbound || Level.is_sprop l)) csts in let smallles = if get_set_minimization () - then Constraint.filter (fun (l,d,r) -> LSet.mem r ctx && not (Level.is_sprop l)) smallles + then Constraint.filter (fun (l,d,r) -> LMap.mem r us && not (Level.is_sprop l)) smallles else Constraint.empty in let csts, partition = @@ -21,6 +21,7 @@ (package coqide-server) (modules idetop) (libraries coq.toplevel coqide-server.protocol) + (modes native byte) (link_flags -linkall)) (install @@ -45,7 +46,9 @@ (name coqide_main) (public_name coqide) (package coqide) + (optional) (modules coqide_main) + (modes exe byte) (libraries coqide_gui)) ; Input-method bindings diff --git a/ide/idetop.ml b/ide/idetop.ml index 7e55eb4d13..7d92cff365 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -196,7 +196,7 @@ let process_goal sigma g = let min_env = Environ.reset_context env in let id = Goal.uid g in let ccl = - pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g) + pr_letype_env ~goal_concl_style:true env sigma (Goal.V82.concl sigma g) in let process_hyp d (env,l) = let d' = CompactedDecl.to_named_context d in diff --git a/interp/constrextern.ml b/interp/constrextern.ml index c85f4f2cf7..28f4f5aed6 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -674,17 +674,15 @@ let match_coercion_app c = match DAst.get c with end | _ -> None -let rec remove_coercions inctx c = - match match_coercion_app c with +let remove_one_coercion inctx c = + try match match_coercion_app c with | Some (loc,r,pars,args) when not (!Flags.raw_print || !print_coercions) -> let nargs = List.length args in - (try match Classops.hide_coercion r with + (match Classops.hide_coercion r with | Some n when (n - pars) < nargs && (inctx || (n - pars)+1 < nargs) -> - (* We skip a coercion *) + (* We skip the coercion *) let l = List.skipn (n - pars) args in let (a,l) = match l with a::l -> (a,l) | [] -> assert false in - (* Recursively remove the head coercions *) - let a' = remove_coercions true a in (* Don't flatten App's in case of funclass so that (atomic) notations on [a] work; should be compatible since printer does not care whether App's are @@ -693,10 +691,13 @@ let rec remove_coercions inctx c = been confused with ordinary application or would have need a surrounding context and the coercion to funclass would have been made explicit to match *) - if List.is_empty l then a' else DAst.make ?loc @@ GApp (a',l) - | _ -> c - with Not_found -> c) - | _ -> c + let a' = if List.is_empty l then a else DAst.make ?loc @@ GApp (a,l) in + let inctx = inctx || not (List.is_empty l) in + Some (n-pars+1, inctx, a') + | _ -> None) + | _ -> None + with Not_found -> + None let rec flatten_application c = match DAst.get c with | GApp (f, l) -> @@ -721,27 +722,11 @@ let extern_possible_prim_token (custom,scopes) r = | None -> raise No_match | Some key -> insert_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) -let filter_fully_applied r l = - let nargs = match DAst.get r with - | GApp (f,args) -> List.length args - | _ -> assert false in - List.filter (fun (keyrule,pat,n as _rule) -> n = Some nargs) l - -let extern_optimal extern extern_fully_applied r r' = - if r==r' then - (* No coercion: we look for a notation for r or a partial application of it *) - extern r - else - (* A coercion is removed: we prefer in order: - - a notation w/o a delimiter for the expression w/o coercions (or a partial application of it), if any - - a notation for the fully-applied expression with coercions, if any - - a notation with a delimiter for the expression w/o coercions (or a partial applied of it), if any *) - try - let c' = extern r' in - match c' with - | { CAst.v = CDelimiters _} -> (try extern_fully_applied r with No_match -> c') - | _ -> c' - with No_match -> extern_fully_applied r +let filter_enough_applied nargs l = + match nargs with + | None -> l + | Some nargs -> + List.filter (fun (keyrule,pat,n as _rule) -> match n with Some n -> n > nargs | None -> false) l (* Helper function for safe and optimal printing of primitive tokens *) (* such as those for Int63 *) @@ -807,22 +792,17 @@ let extern_ref vars ref us = let extern_var ?loc id = CRef (qualid_of_ident ?loc id,None) let rec extern inctx scopes vars r = - let r' = remove_coercions inctx r in - try - if !Flags.raw_print || !print_no_symbol then raise No_match; - let extern_fun = extern_possible_prim_token scopes in - extern_optimal extern_fun extern_fun r r' - with No_match -> - try - let r'' = flatten_application r' in - if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_optimal - (fun r -> extern_notation scopes vars r (uninterp_notations r)) - (fun r -> extern_notation scopes vars r (filter_fully_applied r (uninterp_notations r))) - r r'' + match remove_one_coercion inctx (flatten_application r) with + | Some (nargs,inctx,r') -> + (try extern_notations scopes vars (Some nargs) r + with No_match -> extern inctx scopes vars r') + | None -> + + try extern_notations scopes vars None r with No_match -> - let loc = r'.CAst.loc in - match DAst.get r' with + + let loc = r.CAst.loc in + match DAst.get r with | GRef (ref,us) when entry_has_global (fst scopes) -> CAst.make ?loc (extern_ref vars ref us) | GVar id when entry_has_ident (fst scopes) -> CAst.make ?loc (extern_var ?loc id) @@ -1110,7 +1090,15 @@ and extern_eqn inctx scopes vars {CAst.loc;v=(ids,pll,c)} = let pll = List.map (List.map (extern_cases_pattern_in_scope scopes vars)) pll in make ?loc (pll,extern inctx scopes vars c) -and extern_notation (custom,scopes as allscopes) vars t = function +and extern_notations scopes vars nargs t = + if !Flags.raw_print || !print_no_symbol then raise No_match; + try extern_possible_prim_token scopes t + with No_match -> + let t = flatten_application t in + extern_notation scopes vars t (filter_enough_applied nargs (uninterp_notations t)) + +and extern_notation (custom,scopes as allscopes) vars t rules = + match rules with | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> let loc = Glob_ops.loc_of_glob_constr t in @@ -1211,7 +1199,15 @@ let extern_glob_type vars c = (******************************************************************) (* Main translation function from constr -> constr_expr *) -let extern_constr_gen lax goal_concl_style scopt env sigma t = +let extern_constr ?lax ?(inctx=false) ?scope env sigma t = + let r = Detyping.detype Detyping.Later ?lax false Id.Set.empty env sigma t in + let vars = vars_of_env env in + extern inctx (InConstrEntrySomeLevel,(scope,[])) vars r + +let extern_constr_in_scope ?lax ?inctx scope env sigma t = + extern_constr ?lax ?inctx ~scope env sigma t + +let extern_type ?lax ?(goal_concl_style=false) env sigma t = (* "goal_concl_style" means do alpha-conversion using the "goal" convention *) (* i.e.: avoid using the names of goal/section/rel variables and the short *) (* names of global definitions of current module when computing names for *) @@ -1220,30 +1216,18 @@ let extern_constr_gen lax goal_concl_style scopt env sigma t = (* those goal/section/rel variables that occurs in the subterm under *) (* consideration; see namegen.ml for further details *) let avoid = if goal_concl_style then vars_of_env env else Id.Set.empty in - let r = Detyping.detype Detyping.Later ~lax:lax goal_concl_style avoid env sigma t in - let vars = vars_of_env env in - extern false (InConstrEntrySomeLevel,(scopt,[])) vars r - -let extern_constr_in_scope goal_concl_style scope env sigma t = - extern_constr_gen false goal_concl_style (Some scope) env sigma t - -let extern_constr ?(lax=false) goal_concl_style env sigma t = - extern_constr_gen lax goal_concl_style None env sigma t - -let extern_type goal_concl_style env sigma t = - let avoid = if goal_concl_style then vars_of_env env else Id.Set.empty in - let r = Detyping.detype Detyping.Later goal_concl_style avoid env sigma t in + let r = Detyping.detype Detyping.Later ?lax goal_concl_style avoid env sigma t in extern_glob_type (vars_of_env env) r let extern_sort sigma s = extern_glob_sort (detype_sort sigma s) -let extern_closed_glob ?lax goal_concl_style env sigma t = +let extern_closed_glob ?lax ?(goal_concl_style=false) ?(inctx=false) ?scope env sigma t = let avoid = if goal_concl_style then vars_of_env env else Id.Set.empty in let r = Detyping.detype_closed_glob ?lax goal_concl_style avoid env sigma t in let vars = vars_of_env env in - extern false (InConstrEntrySomeLevel,(None,[])) vars r + extern inctx (InConstrEntrySomeLevel,(scope,[])) vars r (******************************************************************) (* Main translation function from pattern -> constr_expr *) diff --git a/interp/constrextern.mli b/interp/constrextern.mli index e22dd2be86..fa263cbeb7 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -28,7 +28,8 @@ val extern_glob_constr : Id.Set.t -> 'a glob_constr_g -> constr_expr val extern_glob_type : Id.Set.t -> 'a glob_constr_g -> constr_expr val extern_constr_pattern : names_context -> Evd.evar_map -> constr_pattern -> constr_expr -val extern_closed_glob : ?lax:bool -> bool -> env -> Evd.evar_map -> closed_glob_constr -> constr_expr +val extern_closed_glob : ?lax:bool -> ?goal_concl_style:bool -> ?inctx:bool -> ?scope:scope_name -> + env -> Evd.evar_map -> closed_glob_constr -> constr_expr (** If [b=true] in [extern_constr b env c] then the variables in the first level of quantification clashing with the variables in [env] are renamed. @@ -36,10 +37,12 @@ val extern_closed_glob : ?lax:bool -> bool -> env -> Evd.evar_map -> closed_glob env, sigma *) -val extern_constr : ?lax:bool -> bool -> env -> Evd.evar_map -> constr -> constr_expr -val extern_constr_in_scope : bool -> scope_name -> env -> Evd.evar_map -> constr -> constr_expr +val extern_constr : ?lax:bool -> ?inctx:bool -> ?scope:scope_name -> + env -> Evd.evar_map -> constr -> constr_expr +val extern_constr_in_scope : ?lax:bool -> ?inctx:bool -> scope_name -> + env -> Evd.evar_map -> constr -> constr_expr val extern_reference : ?loc:Loc.t -> Id.Set.t -> GlobRef.t -> qualid -val extern_type : bool -> env -> Evd.evar_map -> types -> constr_expr +val extern_type : ?lax:bool -> ?goal_concl_style:bool -> env -> Evd.evar_map -> types -> constr_expr val extern_sort : Evd.evar_map -> Sorts.t -> glob_sort val extern_rel_context : constr option -> env -> Evd.evar_map -> rel_context -> local_binder_expr list @@ -92,5 +95,3 @@ val toggle_scope_printing : val toggle_notation_printing : ?scope:Notation_term.scope_name -> notation:Constrexpr.notation -> activate:bool -> unit - - diff --git a/interp/constrintern.ml b/interp/constrintern.ml index ff115a3e48..c699f79351 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -256,7 +256,9 @@ type intern_env = { unb: bool; tmp_scope: Notation_term.tmp_scope_name option; scopes: Notation_term.scope_name list; - impls: internalization_env } + impls: internalization_env; + impl_binder_index: int option; +} (**********************************************************************) (* Remembering the parsing scope of variables in notations *) @@ -317,27 +319,50 @@ let mkGLambda ?loc (na,bk,t) body = DAst.make ?loc @@ GLambda (na, bk, t, body) (**********************************************************************) (* Utilities for binders *) -let build_impls = function - |Implicit -> (function - |Name id -> Some (id, Impargs.Manual, (true,true)) - |Anonymous -> Some (Id.of_string "_", Impargs.Manual, (true,true))) - |Explicit -> fun _ -> None - -let impls_type_list ?(args = []) = - let rec aux acc c = match DAst.get c with - | GProd (na,bk,_,c) -> aux ((build_impls bk na)::acc) c - | _ -> (Variable,[],List.append args (List.rev acc),[]) + +let warn_shadowed_implicit_name = + CWarnings.create ~name:"shadowed-implicit-name" ~category:"syntax" + Pp.(fun na -> str "Making shadowed name of implicit argument accessible by position.") + +let exists_name na l = + match na with + | Name id -> List.exists (function Some (ExplByName id',_,_) -> Id.equal id id' | _ -> false) l + | _ -> false + +let build_impls ?loc n bk na acc = + match bk with + | Implicit -> + let na = + if exists_name na acc then begin warn_shadowed_implicit_name ?loc na; Anonymous end + else na in + let impl = match na with + | Name id -> Some (ExplByName id,Manual,(true,true)) + | Anonymous -> Some (ExplByPos (n,None),Manual,(true,true)) in + impl :: acc + | Explicit -> None :: acc + +let impls_binder_list = + let rec aux acc n = function + | (na,bk,None,_) :: binders -> aux (build_impls n bk na acc) (n+1) binders + | (na,bk,Some _,_) :: binders -> aux acc n binders + | [] -> (n,acc) in aux [] -let impls_term_list ?(args = []) = - let rec aux acc c = match DAst.get c with - | GLambda (na,bk,_,c) -> aux ((build_impls bk na)::acc) c +let impls_type_list n ?(args = []) = + let rec aux acc n c = match DAst.get c with + | GProd (na,bk,_,c) -> aux (build_impls n bk na acc) (n+1) c + | _ -> (Variable,[],List.rev acc,[]) + in aux args n + +let impls_term_list n ?(args = []) = + let rec aux acc n c = match DAst.get c with + | GLambda (na,bk,_,c) -> aux (build_impls n bk na acc) (n+1) c | GRec (fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in - let acc' = List.fold_left (fun a (na, bk, _, _) -> (build_impls bk na)::a) acc args.(nb) in - aux acc' bds.(nb) - |_ -> (Variable,[],List.append args (List.rev acc),[]) - in aux [] + let n,acc' = List.fold_left (fun (n,acc) (na, bk, _, _) -> (n+1,build_impls n bk na acc)) (n,acc) args.(nb) in + aux acc' n bds.(nb) + |_ -> (Variable,[],List.rev acc,[]) + in aux args n (* Check if in binder "(x1 x2 .. xn : t)", none of x1 .. xn-1 occurs in t *) let rec check_capture ty = let open CAst in function @@ -396,6 +421,14 @@ let remember_binders_impargs env bl = let restore_binders_impargs env l = List.fold_right pure_push_name_env l env +let warn_unexpected_implicit_binder_declaration = + CWarnings.create ~name:"unexpected-implicit-declaration" ~category:"syntax" + Pp.(fun () -> str "Unexpected implicit binder declaration.") + +let check_implicit_meaningful ?loc k env = + if k = Implicit && env.impl_binder_index = None then + warn_unexpected_implicit_binder_declaration ?loc () + let intern_generalized_binder intern_type ntnvars env {loc;v=na} b' t ty = let ids = (match na with Anonymous -> fun x -> x | Name na -> Id.Set.add na) env.ids in @@ -408,6 +441,7 @@ let intern_generalized_binder intern_type ntnvars let env' = List.fold_left (fun env {loc;v=x} -> push_name_env ntnvars (Variable,[],[],[])(*?*) env (make ?loc @@ Name x)) env fvs in + check_implicit_meaningful ?loc b' env; let bl = List.map CAst.(map (fun id -> (Name id, Implicit, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None)))) @@ -423,8 +457,10 @@ let intern_generalized_binder intern_type ntnvars | _ -> default_non_dependent_ident in Implicit_quantifiers.make_fresh ids' (Global.env ()) id in Name name - | _ -> na - in (push_name_env ntnvars (impls_type_list ty')(*?*) env' (make ?loc na)), (make ?loc (na,b',ty')) :: List.rev bl + | _ -> na in + let impls = impls_type_list 1 ty' in + (push_name_env ntnvars impls env' (make ?loc na), + (make ?loc (na,b',ty')) :: List.rev bl) let intern_assumption intern ntnvars env nal bk ty = let intern_type env = intern (set_type_scope env) in @@ -432,9 +468,10 @@ let intern_assumption intern ntnvars env nal bk ty = | Default k -> let ty = intern_type env ty in check_capture ty nal; - let impls = impls_type_list ty in + let impls = impls_type_list 1 ty in List.fold_left (fun (env, bl) ({loc;v=na} as locna) -> + check_implicit_meaningful ?loc k env; (push_name_env ntnvars impls env locna, (make ?loc (na,k,locate_if_hole ?loc na ty))::bl)) (env, []) nal @@ -457,7 +494,8 @@ let intern_cases_pattern_fwd = ref (fun _ -> failwith "intern_cases_pattern_fwd" let intern_letin_binder intern ntnvars env (({loc;v=na} as locna),def,ty) = let term = intern env def in let ty = Option.map (intern env) ty in - (push_name_env ntnvars (impls_term_list term) env locna, + let impls = impls_term_list 1 term in + (push_name_env ntnvars impls env locna, (na,Explicit,term,ty)) let intern_cases_pattern_as_binder ?loc ntnvars env p = @@ -1105,7 +1143,8 @@ let interp_reference vars r = let (r,_,_,_),_ = intern_applied_reference ~isproj:None (fun _ -> error_not_enough_arguments ?loc:None) {ids = Id.Set.empty; unb = false ; - tmp_scope = None; scopes = []; impls = empty_internalization_env} + tmp_scope = None; scopes = []; impls = empty_internalization_env; + impl_binder_index = None} Environ.empty_named_context_val (vars, Id.Map.empty) None [] r in r @@ -1872,10 +1911,9 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* We add the recursive functions to the environment *) let env_rec = List.fold_left_i (fun i en name -> let (_,bli,tyi,_) = idl_temp.(i) in - let bli = List.filter (fun (_, _, t, _) -> t = None) bli in - let fix_args = List.map (fun (na, bk, t, _) -> build_impls bk na) bli in - push_name_env ntnvars (impls_type_list ~args:fix_args tyi) - en (CAst.make @@ Name name)) 0 env lf in + let binder_index,fix_args = impls_binder_list 1 bli in + let impls = impls_type_list ~args:fix_args binder_index tyi in + push_name_env ntnvars impls en (CAst.make @@ Name name)) 0 env lf in let idl = Array.map2 (fun (_,_,_,_,bd) (n,bl,ty,before_impls) -> (* We add the binders common to body and type to the environment *) let env_body = restore_binders_impargs env_rec before_impls in @@ -1904,9 +1942,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (bl,intern_type env' ty,bl_impls)) dl in let env_rec = List.fold_left_i (fun i en name -> let (bli,tyi,_) = idl_tmp.(i) in - let bli = List.filter (fun (_, _, t, _) -> t = None) bli in - let cofix_args = List.map (fun (na, bk, _, _) -> build_impls bk na) bli in - push_name_env ntnvars (impls_type_list ~args:cofix_args tyi) + let binder_index,cofix_args = impls_binder_list 1 bli in + push_name_env ntnvars (impls_type_list ~args:cofix_args binder_index tyi) en (CAst.make @@ Name name)) 0 env lf in let idl = Array.map2 (fun (_,_,_,bd) (b,c,bl_impls) -> (* We add the binders common to body and type to the environment *) @@ -1927,11 +1964,11 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let (env',bl) = List.fold_left intern_local_binder (reset_tmp_scope env,[]) bl in expand_binders ?loc mkGLambda bl (intern env' c2) | CLetIn (na,c1,t,c2) -> - let inc1 = intern (reset_tmp_scope env) c1 in - let int = Option.map (intern_type env) t in + let inc1 = intern_restart_implicit (reset_tmp_scope env) c1 in + let int = Option.map (intern_type_restart_implicit env) t in DAst.make ?loc @@ GLetIn (na.CAst.v, inc1, int, - intern (push_name_env ntnvars (impls_term_list inc1) env na) c2) + intern_restart_implicit (push_name_env ntnvars (impls_term_list 1 inc1) env na) c2) | CNotation ((InConstrEntrySomeLevel,"- _"), ([a],[],[],[])) when is_non_zero a -> let p = match a.CAst.v with CPrim (Numeral (_, p)) -> p | _ -> assert false in intern env (CAst.make ?loc @@ CPrim (Numeral (SMinus,p))) @@ -2114,7 +2151,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* Parsing existential variables *) | CEvar (n, l) -> DAst.make ?loc @@ - GEvar (n, List.map (on_snd (intern env)) l) + GEvar (n, List.map (on_snd (intern_no_implicit env)) l) | CPatVar _ -> raise (InternalizationError (loc,IllegalMetavariable)) (* end *) @@ -2127,8 +2164,14 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = ) and intern_type env = intern (set_type_scope env) + and intern_no_implicit env = intern {env with impl_binder_index = None} + + and intern_restart_implicit env = intern {env with impl_binder_index = Some 0} + + and intern_type_restart_implicit env = intern {(set_type_scope env) with impl_binder_index = Some 0} + and intern_local_binder env bind : intern_env * Glob_term.extended_glob_local_binder list = - intern_local_binder_aux intern ntnvars env bind + intern_local_binder_aux intern_restart_implicit ntnvars env bind (* Expands a multiple pattern into a disjunction of multiple patterns *) and intern_multiple_pattern env n pl = @@ -2160,7 +2203,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = and intern_case_item env forbidden_names_for_gen (tm,na,t) = (* the "match" part *) - let tm' = intern env tm in + let tm' = intern_no_implicit env tm in (* the "as" part *) let extra_id,na = let loc = tm'.CAst.loc in @@ -2229,7 +2272,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let id = name_of_implicit imp in let (_,a) = Id.Map.find id eargs in let eargs' = Id.Map.remove id eargs in - intern enva a :: aux (n+1) impl' subscopes' eargs' rargs + intern_no_implicit enva a :: aux (n+1) impl' subscopes' eargs' rargs with Not_found -> if List.is_empty rargs && Id.Map.is_empty eargs && not (maximal_insertion_of imp) then (* Less regular arguments than expected: complete *) @@ -2241,7 +2284,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = ) :: aux (n+1) impl' subscopes' eargs rargs end | (imp::impl', a::rargs') -> - intern enva a :: aux (n+1) impl' subscopes' eargs rargs' + intern_no_implicit enva a :: aux (n+1) impl' subscopes' eargs rargs' | (imp::impl', []) -> if not (Id.Map.is_empty eargs) then (let (id,(loc,_)) = Id.Map.choose eargs in @@ -2271,7 +2314,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | [] -> [] | a::args -> let (enva,subscopes) = apply_scope_env env subscopes in - (intern enva a) :: (intern_args env subscopes args) + (intern_no_implicit enva a) :: (intern_args env subscopes args) in try @@ -2307,7 +2350,7 @@ let intern_gen kind env sigma let tmp_scope = scope_of_type_kind sigma kind in internalize env {ids = extract_ids env; unb = false; tmp_scope = tmp_scope; scopes = []; - impls = impls} + impls; impl_binder_index = Some 0} pattern_mode (ltacvars, Id.Map.empty) c let intern_constr env sigma c = intern_gen WithoutTypeConstraint env sigma c @@ -2389,7 +2432,8 @@ let intern_core kind env sigma ?(pattern_mode=false) ?(ltacvars=empty_ltac_sign) { Genintern.intern_ids = ids; Genintern.notation_variable_status = vl } c = let tmp_scope = scope_of_type_kind sigma kind in let impls = empty_internalization_env in - internalize env {ids; unb = false; tmp_scope; scopes = []; impls} + internalize env + {ids; unb = false; tmp_scope; scopes = []; impls; impl_binder_index = Some 0} pattern_mode (ltacvars, vl) c let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = @@ -2397,7 +2441,8 @@ let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = (* [vl] is intended to remember the scope of the free variables of [a] *) let vl = Id.Map.map (fun typ -> (ref false, ref None, typ)) nenv.ninterp_var_type in let impls = Id.Map.fold (fun id _ impls -> Id.Map.remove id impls) nenv.ninterp_var_type impls in - let c = internalize env {ids; unb = false; tmp_scope = None; scopes = []; impls} + let c = internalize env + {ids; unb = false; tmp_scope = None; scopes = []; impls; impl_binder_index = None} false (empty_ltac_sign, vl) a in (* Splits variables into those that are binding, bound, or both *) (* Translate and check that [c] has all its free variables bound in [vars] *) @@ -2433,7 +2478,8 @@ let intern_context env impl_env binders = let (env, bl) = intern_local_binder_aux (my_intern_constr env lvar) Id.Map.empty (lenv, bl) b in (env, bl)) ({ids = extract_ids env; unb = false; - tmp_scope = None; scopes = []; impls = impl_env}, []) binders in + tmp_scope = None; scopes = []; impls = impl_env; + impl_binder_index = Some 0}, []) binders in (lenv.impls, List.map glob_local_binder_of_extended bl) with InternalizationError (loc,e) -> user_err ?loc ~hdr:"internalize" (explain_internalization_error e) diff --git a/interp/impargs.ml b/interp/impargs.ml index 2aa002ead1..df28b32f81 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -20,6 +20,7 @@ open Libobject open EConstr open Reductionops open Namegen +open Constrexpr module NamedDecl = Context.Named.Declaration @@ -289,7 +290,7 @@ type force_inference = bool (* true = always infer, never turn into evar/subgoal type implicit_status = (* None = Not implicit *) - (Id.t * implicit_explanation * (maximal_insertion * force_inference)) option + (explicitation * implicit_explanation * (maximal_insertion * force_inference)) option type implicit_side_condition = DefaultImpArgs | LessArgsThan of int @@ -299,9 +300,12 @@ let is_status_implicit = function | None -> false | _ -> true +let name_of_pos k = Id.of_string ("arg_" ^ string_of_int k) + let name_of_implicit = function | None -> anomaly (Pp.str "Not an implicit argument.") - | Some (id,_,_) -> id + | Some (ExplByName id,_,_) -> id + | Some (ExplByPos (k,_),_,_) -> name_of_pos k let maximal_insertion_of = function | Some (_,_,(b,_)) -> b @@ -336,7 +340,7 @@ let rec prepare_implicits f = function | (Anonymous, Some _)::_ -> anomaly (Pp.str "Unnamed implicit.") | (Name id, Some imp)::imps -> let imps' = prepare_implicits f imps in - Some (id,imp,(set_maximality imps' f.maximal,true)) :: imps' + Some (ExplByName id,imp,(set_maximality imps' f.maximal,true)) :: imps' | _::imps -> None :: prepare_implicits f imps let set_manual_implicits flags enriching autoimps l = @@ -346,15 +350,14 @@ let set_manual_implicits flags enriching autoimps l = let imps' = merge (k+1) autoimps explimps in begin match autoimp, explimp.CAst.v with | (Name id,_), Some (_,max) -> - Some (id, Manual, (set_maximality imps' max, true)) + Some (ExplByName id, Manual, (set_maximality imps' max, true)) | (Name id,Some exp), None when enriching -> - Some (id, exp, (set_maximality imps' flags.maximal, true)) + Some (ExplByName id, exp, (set_maximality imps' flags.maximal, true)) | (Name _,_), None -> None | (Anonymous,_), Some (Name id,max) -> - Some (id,Manual,(max,true)) + Some (ExplByName id,Manual,(max,true)) | (Anonymous,_), Some (Anonymous,max) -> - let id = Id.of_string ("arg_" ^ string_of_int k) in - Some (id,Manual,(max,true)) + Some (ExplByPos (k,None),Manual,(max,true)) | (Anonymous,_), None -> None end :: imps' | [], [] -> [] @@ -464,7 +467,7 @@ let implicits_of_global ref = | [], _ -> [] | _, [] -> implicits | Some (_, x,y) :: implicits, Name id :: names -> - Some (id, x,y) :: rename implicits names + Some (ExplByName id, x,y) :: rename implicits names | imp :: implicits, _ :: names -> imp :: rename implicits names in List.map (fun (t, il) -> t, rename il rename_l) l @@ -494,7 +497,7 @@ let impls_of_context ctx = let map decl = let id = NamedDecl.get_id decl in match Id.Map.get id !sec_implicits with - | Glob_term.Implicit -> Some (id, Manual, (true, true)) + | Glob_term.Implicit -> Some (ExplByName id, Manual, (true, true)) | Glob_term.Explicit -> None in List.rev_map map (List.filter (NamedDecl.is_local_assum) ctx) @@ -655,12 +658,12 @@ let compute_implicit_statuses autoimps l = let rec aux i = function | _ :: autoimps, NotImplicit :: manualimps -> None :: aux (i+1) (autoimps, manualimps) | Name id :: autoimps, MaximallyImplicit :: manualimps -> - Some (id, Manual, (true, true)) :: aux (i+1) (autoimps, manualimps) + Some (ExplByName id, Manual, (true, true)) :: aux (i+1) (autoimps, manualimps) | Name id :: autoimps, Implicit :: manualimps -> let imps' = aux (i+1) (autoimps, manualimps) in let max = set_maximality imps' false in if max then warn_set_maximal_deprecated i; - Some (id, Manual, (max, true)) :: imps' + Some (ExplByName id, Manual, (max, true)) :: imps' | Anonymous :: _, (Implicit | MaximallyImplicit) :: _ -> user_err ~hdr:"set_implicits" (strbrk ("Argument number " ^ string_of_int i ^ " (anonymous in original definition) cannot be declared implicit.")) diff --git a/interp/impargs.mli b/interp/impargs.mli index 8fa69e818a..ef3c2496f4 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -68,7 +68,7 @@ type maximal_insertion = bool (** true = maximal contextual insertion *) type force_inference = bool (** true = always infer, never turn into evar/subgoal *) -type implicit_status = (Id.t * implicit_explanation * +type implicit_status = (Constrexpr.explicitation * implicit_explanation * (maximal_insertion * force_inference)) option (** [None] = Not implicit *) diff --git a/interp/notation.ml b/interp/notation.ml index efb826a76e..5dc1658824 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1872,6 +1872,7 @@ let collect_notations stack = | SingleNotation ntn -> if List.mem_f notation_eq ntn knownntn then (all,knownntn) else + try let { not_interp = (_, r); not_location = (_, df) } = NotationMap.find ntn (find_scope default_scope).notations in let all' = match all with @@ -1879,7 +1880,8 @@ let collect_notations stack = (s,(df,r)::lonelyntn)::rest | _ -> (default_scope,[df,r])::all in - (all',ntn::knownntn)) + (all',ntn::knownntn) + with Not_found -> (* e.g. if only printing *) (all,knownntn)) ([],[]) stack) let pr_visible_in_scope prglob (scope,ntns) = diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index ff2498386d..265ca58ed9 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -1225,7 +1225,7 @@ let rec match_ inner u alp metas sigma a1 a2 = bind_bindinglist_env alp sigma id [DAst.make @@ GLocalAssum (Name id',Explicit,t1)] else match_names metas (alp,sigma) (Name id') na in - match_in u alp metas sigma (mkGApp a1 (DAst.make @@ GVar id')) b2 + match_in u alp metas sigma (mkGApp a1 [DAst.make @@ GVar id']) b2 | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 931b509f48..306643f758 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -12,7 +12,7 @@ for fast computation of bounded (31bits) integers */ #include <stdio.h> -#include <stdlib.h> +#include <stdlib.h> #include <stdint.h> #include <caml/config.h> #include <caml/misc.h> @@ -42,7 +42,7 @@ void init_arity () { arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]= arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= - arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= + arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= arity[ADDINT63]=arity[SUBINT63]=arity[LTINT63]=arity[LEINT63]= arity[LTFLOAT]=arity[LEFLOAT]= arity[ISINT]=arity[AREINT2]=0; @@ -76,7 +76,7 @@ void init_arity () { /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= arity[PROJ]=2; - /* instruction with four operands */ + /* instruction with four operands */ arity[MAKESWITCHBLOCK]=4; /* instruction with arbitrary operands */ arity[CLOSUREREC]=arity[CLOSURECOFIX]=arity[SWITCH]=0; @@ -134,7 +134,7 @@ value coq_is_accumulate_code(value code){ #ifdef ARCH_BIG_ENDIAN #define Reverse_32(dst,src) { \ - char * _p, * _q; \ + char * _p, * _q; \ char _a, _b; \ _p = (char *) (src); \ _q = (char *) (dst); \ @@ -159,9 +159,9 @@ value coq_tcode_of_code (value code) { q = coq_stat_alloc(len); Code_val(res) = q; len /= sizeof(opcode_t); - for (p = (code_t)code; p < (code_t)code + len; /*nothing*/) { + for (p = (code_t)code; p < (code_t)code + len; /*nothing*/) { opcode_t instr; - COPY32(&instr,p); + COPY32(&instr,p); p++; if (instr < 0 || instr > STOP){ instr = STOP; @@ -183,7 +183,7 @@ value coq_tcode_of_code (value code) { for(i=1; i<n; i++) { COPY32(q,p); p++; q++; }; } else { uint32_t i, ar; - ar = arity[instr]; + ar = arity[instr]; for(i=0; i<ar; i++) { COPY32(q,p); p++; q++; }; } } diff --git a/kernel/byterun/coq_gc.h b/kernel/byterun/coq_gc.h index f06275862c..38eda4d11f 100644 --- a/kernel/byterun/coq_gc.h +++ b/kernel/byterun/coq_gc.h @@ -37,8 +37,8 @@ CAMLextern void minor_collection (void); #define Make_header(wosize, tag, color) \ (((header_t) (((header_t) (wosize) << 10) \ - + (color) \ - + (tag_t) (tag))) \ + + (color) \ + + (tag_t) (tag))) \ ) #endif @@ -53,7 +53,7 @@ CAMLextern void minor_collection (void); } \ Hd_hp (young_ptr) = Make_header ((wosize), (tag), Caml_black); \ (result) = Val_hp (young_ptr); \ - }while(0) + }while(0) #endif /*_COQ_CAML_GC_ */ diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index ca1308696c..606cce0127 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -17,12 +17,14 @@ #include <signal.h> #include <stdint.h> #include <caml/memory.h> +#include <caml/signals.h> +#include <caml/version.h> #include <math.h> #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" -#include "coq_memory.h" -#include "coq_values.h" +#include "coq_memory.h" +#include "coq_values.h" #include "coq_float64.h" #ifdef ARCH_SIXTYFOUR @@ -49,7 +51,7 @@ sp is a local copy of the global variable extern_sp. */ #ifdef THREADED_CODE -# define Instruct(name) coq_lbl_##name: +# define Instruct(name) coq_lbl_##name: # if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) # define coq_Jumptbl_base ((char *) &&coq_lbl_ACC0) # else @@ -59,22 +61,22 @@ sp is a local copy of the global variable extern_sp. */ # ifdef DEBUG # define Next goto next_instr # else -# define Next goto *(void *)(coq_jumptbl_base + *pc++) +# define Next goto *(void *)(coq_jumptbl_base + *pc++) # endif -#else +#else # define Instruct(name) case name: # define Next break -#endif +#endif /* #define _COQ_DEBUG_ */ -#ifdef _COQ_DEBUG_ +#ifdef _COQ_DEBUG_ # define print_instr(s) /*if (drawinstr)*/ printf("%s\n",s) # define print_int(i) /*if (drawinstr)*/ printf("%d\n",i) # define print_lint(i) /*if (drawinstr)*/ printf("%ld\n",i) -# else -# define print_instr(s) -# define print_int(i) +# else +# define print_instr(s) +# define print_int(i) # define print_lint(i) #endif @@ -95,7 +97,7 @@ if (sp - num_args < coq_stack_threshold) { \ Some compilers underestimate the use of the local variables representing the abstract machine registers, and don't put them in hardware registers, which slows down the interpreter considerably. - For GCC, Xavier Leroy have hand-assigned hardware registers for + For GCC, Xavier Leroy have hand-assigned hardware registers for several architectures. */ @@ -171,11 +173,11 @@ if (sp - num_args < coq_stack_threshold) { \ #define CheckPrimArgs(cond, apply_lbl) do{ \ if (cond) pc++; \ - else{ \ - *--sp=accu; \ - accu = Field(coq_global_data, *pc++); \ + else{ \ + *--sp=accu; \ + accu = Field(coq_global_data, *pc++); \ goto apply_lbl; \ - } \ + } \ }while(0) #define CheckInt1() CheckPrimArgs(Is_uint63(accu), apply1) @@ -203,11 +205,13 @@ if (sp - num_args < coq_stack_threshold) { \ *sp = swap_accu_sp_tmp__; \ }while(0) +#if OCAML_VERSION < 41000 /* For signal handling, we hijack some code from the caml runtime */ -extern intnat caml_signals_are_pending; -extern intnat caml_pending_signals[]; +extern intnat volatile caml_signals_are_pending; +extern intnat volatile caml_pending_signals[]; extern void caml_process_pending_signals(void); +#endif /* The interpreter itself */ @@ -238,7 +242,7 @@ value coq_interprete static void * coq_jumptable[] = { # include "coq_jumptbl.h" }; -#else +#else opcode_t curr_instr; #endif print_instr("Enter Interpreter"); @@ -269,193 +273,193 @@ value coq_interprete switch(curr_instr) { #endif /* Basic stack operations */ - + Instruct(ACC0){ - print_instr("ACC0"); - accu = sp[0]; Next; + print_instr("ACC0"); + accu = sp[0]; Next; } Instruct(ACC1){ - print_instr("ACC1"); - accu = sp[1]; Next; + print_instr("ACC1"); + accu = sp[1]; Next; } Instruct(ACC2){ - print_instr("ACC2"); - accu = sp[2]; Next; + print_instr("ACC2"); + accu = sp[2]; Next; } Instruct(ACC3){ - print_instr("ACC3"); - accu = sp[3]; Next; + print_instr("ACC3"); + accu = sp[3]; Next; } Instruct(ACC4){ - print_instr("ACC4"); - accu = sp[4]; Next; + print_instr("ACC4"); + accu = sp[4]; Next; } Instruct(ACC5){ - print_instr("ACC5"); - accu = sp[5]; Next; + print_instr("ACC5"); + accu = sp[5]; Next; } Instruct(ACC6){ - print_instr("ACC6"); - accu = sp[6]; Next; + print_instr("ACC6"); + accu = sp[6]; Next; } Instruct(ACC7){ - print_instr("ACC7"); + print_instr("ACC7"); accu = sp[7]; Next; - } + } Instruct(PUSH){ - print_instr("PUSH"); - *--sp = accu; Next; + print_instr("PUSH"); + *--sp = accu; Next; } Instruct(PUSHACC0) { - print_instr("PUSHACC0"); + print_instr("PUSHACC0"); *--sp = accu; Next; } Instruct(PUSHACC1){ - print_instr("PUSHACC1"); + print_instr("PUSHACC1"); *--sp = accu; accu = sp[1]; Next; } Instruct(PUSHACC2){ - print_instr("PUSHACC2"); + print_instr("PUSHACC2"); *--sp = accu; accu = sp[2]; Next; } Instruct(PUSHACC3){ - print_instr("PUSHACC3"); - *--sp = accu; accu = sp[3]; Next; + print_instr("PUSHACC3"); + *--sp = accu; accu = sp[3]; Next; } Instruct(PUSHACC4){ - print_instr("PUSHACC4"); - *--sp = accu; accu = sp[4]; Next; + print_instr("PUSHACC4"); + *--sp = accu; accu = sp[4]; Next; } Instruct(PUSHACC5){ - print_instr("PUSHACC5"); - *--sp = accu; accu = sp[5]; Next; + print_instr("PUSHACC5"); + *--sp = accu; accu = sp[5]; Next; } Instruct(PUSHACC6){ - print_instr("PUSHACC5"); - *--sp = accu; accu = sp[6]; Next; + print_instr("PUSHACC5"); + *--sp = accu; accu = sp[6]; Next; } Instruct(PUSHACC7){ - print_instr("PUSHACC7"); - *--sp = accu; accu = sp[7]; Next; + print_instr("PUSHACC7"); + *--sp = accu; accu = sp[7]; Next; } Instruct(PUSHACC){ - print_instr("PUSHACC"); - *--sp = accu; + print_instr("PUSHACC"); + *--sp = accu; } /* Fallthrough */ - + Instruct(ACC){ - print_instr("ACC"); - accu = sp[*pc++]; + print_instr("ACC"); + accu = sp[*pc++]; Next; } - + Instruct(POP){ - print_instr("POP"); - sp += *pc++; - Next; + print_instr("POP"); + sp += *pc++; + Next; } /* Access in heap-allocated environment */ - + Instruct(ENVACC1){ - print_instr("ENVACC1"); - accu = Field(coq_env, 1); Next; + print_instr("ENVACC1"); + accu = Field(coq_env, 1); Next; } Instruct(ENVACC2){ - print_instr("ENVACC2"); - accu = Field(coq_env, 2); Next; + print_instr("ENVACC2"); + accu = Field(coq_env, 2); Next; } Instruct(ENVACC3){ - print_instr("ENVACC3"); - accu = Field(coq_env, 3); Next; + print_instr("ENVACC3"); + accu = Field(coq_env, 3); Next; } Instruct(ENVACC4){ - print_instr("ENVACC4"); - accu = Field(coq_env, 4); Next; + print_instr("ENVACC4"); + accu = Field(coq_env, 4); Next; } Instruct(PUSHENVACC1){ - print_instr("PUSHENVACC1"); - *--sp = accu; accu = Field(coq_env, 1); Next; + print_instr("PUSHENVACC1"); + *--sp = accu; accu = Field(coq_env, 1); Next; } Instruct(PUSHENVACC2){ - print_instr("PUSHENVACC2"); - *--sp = accu; accu = Field(coq_env, 2); Next; + print_instr("PUSHENVACC2"); + *--sp = accu; accu = Field(coq_env, 2); Next; } Instruct(PUSHENVACC3){ - print_instr("PUSHENVACC3"); - *--sp = accu; accu = Field(coq_env, 3); Next; + print_instr("PUSHENVACC3"); + *--sp = accu; accu = Field(coq_env, 3); Next; } Instruct(PUSHENVACC4){ - print_instr("PUSHENVACC4"); - *--sp = accu; accu = Field(coq_env, 4); Next; + print_instr("PUSHENVACC4"); + *--sp = accu; accu = Field(coq_env, 4); Next; } Instruct(PUSHENVACC){ - print_instr("PUSHENVACC"); - *--sp = accu; + print_instr("PUSHENVACC"); + *--sp = accu; } /* Fallthrough */ Instruct(ENVACC){ - print_instr("ENVACC"); - print_int(*pc); - accu = Field(coq_env, *pc++); + print_instr("ENVACC"); + print_int(*pc); + accu = Field(coq_env, *pc++); Next; } /* Function application */ - + Instruct(PUSH_RETADDR) { - print_instr("PUSH_RETADDR"); - sp -= 3; - sp[0] = (value) (pc + *pc); - sp[1] = coq_env; - sp[2] = Val_long(coq_extra_args); - coq_extra_args = 0; - pc++; - Next; + print_instr("PUSH_RETADDR"); + sp -= 3; + sp[0] = (value) (pc + *pc); + sp[1] = coq_env; + sp[2] = Val_long(coq_extra_args); + coq_extra_args = 0; + pc++; + Next; } Instruct(APPLY) { - print_instr("APPLY"); - coq_extra_args = *pc - 1; - pc = Code_val(accu); - coq_env = accu; - goto check_stack; + print_instr("APPLY"); + coq_extra_args = *pc - 1; + pc = Code_val(accu); + coq_env = accu; + goto check_stack; } Instruct(APPLY1) { value arg1; apply1: - print_instr("APPLY1"); + print_instr("APPLY1"); arg1 = sp[0]; - sp -= 3; - sp[0] = arg1; - sp[1] = (value)pc; - sp[2] = coq_env; - sp[3] = Val_long(coq_extra_args); - print_instr("call stack="); - print_lint(sp[1]); - print_lint(sp[2]); - print_lint(sp[3]); - pc = Code_val(accu); - coq_env = accu; - coq_extra_args = 0; - goto check_stack; + sp -= 3; + sp[0] = arg1; + sp[1] = (value)pc; + sp[2] = coq_env; + sp[3] = Val_long(coq_extra_args); + print_instr("call stack="); + print_lint(sp[1]); + print_lint(sp[2]); + print_lint(sp[3]); + pc = Code_val(accu); + coq_env = accu; + coq_extra_args = 0; + goto check_stack; } Instruct(APPLY2) { value arg1; value arg2; apply2: - print_instr("APPLY2"); + print_instr("APPLY2"); arg1 = sp[0]; arg2 = sp[1]; - sp -= 3; - sp[0] = arg1; - sp[1] = arg2; - sp[2] = (value)pc; - sp[3] = coq_env; - sp[4] = Val_long(coq_extra_args); - pc = Code_val(accu); - coq_env = accu; - coq_extra_args = 1; - goto check_stack; + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = (value)pc; + sp[3] = coq_env; + sp[4] = Val_long(coq_extra_args); + pc = Code_val(accu); + coq_env = accu; + coq_extra_args = 1; + goto check_stack; } Instruct(APPLY3) { @@ -463,21 +467,21 @@ value coq_interprete value arg2; value arg3; apply3: - print_instr("APPLY3"); + print_instr("APPLY3"); arg1 = sp[0]; arg2 = sp[1]; arg3 = sp[2]; - sp -= 3; - sp[0] = arg1; - sp[1] = arg2; - sp[2] = arg3; - sp[3] = (value)pc; - sp[4] = coq_env; - sp[5] = Val_long(coq_extra_args); - pc = Code_val(accu); - coq_env = accu; - coq_extra_args = 2; - goto check_stack; + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + sp[3] = (value)pc; + sp[4] = coq_env; + sp[5] = Val_long(coq_extra_args); + pc = Code_val(accu); + coq_env = accu; + coq_extra_args = 2; + goto check_stack; } Instruct(APPLY4) { @@ -501,16 +505,32 @@ value coq_interprete } /* Stack checks */ - + check_stack: print_instr("check_stack"); CHECK_STACK(0); /* We also check for signals */ +#if OCAML_VERSION >= 41000 + { + value res = caml_process_pending_actions_exn(); + if (Is_exception_result(res)) { + /* If there is an asynchronous exception, we reset the vm */ + coq_sp = coq_stack_high; + caml_raise(Extract_exception(res)); + } + } +#else if (caml_signals_are_pending) { - /* If there's a Ctrl-C, we reset the vm */ - if (caml_pending_signals[SIGINT]) { coq_sp = coq_stack_high; } - caml_process_pending_signals(); + /* If there's a Ctrl-C, we reset the vm */ + intnat sigint = caml_pending_signals[SIGINT]; + if (sigint) { coq_sp = coq_stack_high; } + caml_process_pending_signals(); + if (sigint) { + caml_failwith("Coq VM: Fatal error: SIGINT signal detected " + "but no exception was raised"); + } } +#endif Next; Instruct(ENSURESTACKCAPACITY) { @@ -524,460 +544,460 @@ value coq_interprete } Instruct(APPTERM) { - int nargs = *pc++; - int slotsize = *pc; - value * newsp; - int i; - print_instr("APPTERM"); - /* Slide the nargs bottom words of the current frame to the top - of the frame, and discard the remainder of the frame */ - newsp = sp + slotsize - nargs; - for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i]; - sp = newsp; - pc = Code_val(accu); - coq_env = accu; - coq_extra_args += nargs - 1; - goto check_stack; + int nargs = *pc++; + int slotsize = *pc; + value * newsp; + int i; + print_instr("APPTERM"); + /* Slide the nargs bottom words of the current frame to the top + of the frame, and discard the remainder of the frame */ + newsp = sp + slotsize - nargs; + for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i]; + sp = newsp; + pc = Code_val(accu); + coq_env = accu; + coq_extra_args += nargs - 1; + goto check_stack; } Instruct(APPTERM1) { - value arg1 = sp[0]; - print_instr("APPTERM1"); - sp = sp + *pc - 1; - sp[0] = arg1; - pc = Code_val(accu); - coq_env = accu; - goto check_stack; + value arg1 = sp[0]; + print_instr("APPTERM1"); + sp = sp + *pc - 1; + sp[0] = arg1; + pc = Code_val(accu); + coq_env = accu; + goto check_stack; } Instruct(APPTERM2) { - value arg1 = sp[0]; - value arg2 = sp[1]; - print_instr("APPTERM2"); - sp = sp + *pc - 2; - sp[0] = arg1; - sp[1] = arg2; - pc = Code_val(accu); - print_lint(accu); - coq_env = accu; - coq_extra_args += 1; - goto check_stack; + value arg1 = sp[0]; + value arg2 = sp[1]; + print_instr("APPTERM2"); + sp = sp + *pc - 2; + sp[0] = arg1; + sp[1] = arg2; + pc = Code_val(accu); + print_lint(accu); + coq_env = accu; + coq_extra_args += 1; + goto check_stack; } Instruct(APPTERM3) { - value arg1 = sp[0]; - value arg2 = sp[1]; - value arg3 = sp[2]; - print_instr("APPTERM3"); - sp = sp + *pc - 3; - sp[0] = arg1; - sp[1] = arg2; - sp[2] = arg3; - pc = Code_val(accu); - coq_env = accu; - coq_extra_args += 2; - goto check_stack; - } - + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + print_instr("APPTERM3"); + sp = sp + *pc - 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + pc = Code_val(accu); + coq_env = accu; + coq_extra_args += 2; + goto check_stack; + } + Instruct(RETURN) { - print_instr("RETURN"); - print_int(*pc); - sp += *pc++; - print_instr("stack="); - print_lint(sp[0]); - print_lint(sp[1]); - print_lint(sp[2]); - if (coq_extra_args > 0) { - print_instr("extra args > 0"); - print_lint(coq_extra_args); - coq_extra_args--; - pc = Code_val(accu); - coq_env = accu; - } else { - print_instr("extra args = 0"); - pc = (code_t)(sp[0]); - coq_env = sp[1]; - coq_extra_args = Long_val(sp[2]); - sp += 3; - } - Next; - } - + print_instr("RETURN"); + print_int(*pc); + sp += *pc++; + print_instr("stack="); + print_lint(sp[0]); + print_lint(sp[1]); + print_lint(sp[2]); + if (coq_extra_args > 0) { + print_instr("extra args > 0"); + print_lint(coq_extra_args); + coq_extra_args--; + pc = Code_val(accu); + coq_env = accu; + } else { + print_instr("extra args = 0"); + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + Instruct(RESTART) { - int num_args = Wosize_val(coq_env) - 2; - int i; - print_instr("RESTART"); + int num_args = Wosize_val(coq_env) - 2; + int i; + print_instr("RESTART"); CHECK_STACK(num_args); - sp -= num_args; - for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2); - coq_env = Field(coq_env, 1); - coq_extra_args += num_args; - Next; + sp -= num_args; + for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2); + coq_env = Field(coq_env, 1); + coq_extra_args += num_args; + Next; } - + Instruct(GRAB) { - int required = *pc++; - print_instr("GRAB"); - /* printf("GRAB %d\n",required); */ - if (coq_extra_args >= required) { - coq_extra_args -= required; - } else { - mlsize_t num_args, i; - num_args = 1 + coq_extra_args; /* arg1 + extra args */ - Alloc_small(accu, num_args + 2, Closure_tag); - Field(accu, 1) = coq_env; - for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; - Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ - sp += num_args; - pc = (code_t)(sp[0]); - coq_env = sp[1]; - coq_extra_args = Long_val(sp[2]); - sp += 3; - } - Next; - } - - Instruct(GRABREC) { - int rec_pos = *pc++; /* commence a zero */ - print_instr("GRABREC"); - if (rec_pos <= coq_extra_args && !Is_accu(sp[rec_pos])) { - pc++;/* On saute le Restart */ - } else { - if (coq_extra_args < rec_pos) { + int required = *pc++; + print_instr("GRAB"); + /* printf("GRAB %d\n",required); */ + if (coq_extra_args >= required) { + coq_extra_args -= required; + } else { + mlsize_t num_args, i; + num_args = 1 + coq_extra_args; /* arg1 + extra args */ + Alloc_small(accu, num_args + 2, Closure_tag); + Field(accu, 1) = coq_env; + for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ + sp += num_args; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + + Instruct(GRABREC) { + int rec_pos = *pc++; /* commence a zero */ + print_instr("GRABREC"); + if (rec_pos <= coq_extra_args && !Is_accu(sp[rec_pos])) { + pc++;/* On saute le Restart */ + } else { + if (coq_extra_args < rec_pos) { /* Partial application */ - mlsize_t num_args, i; - num_args = 1 + coq_extra_args; /* arg1 + extra args */ - Alloc_small(accu, num_args + 2, Closure_tag); - Field(accu, 1) = coq_env; - for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; - Code_val(accu) = pc - 3; - sp += num_args; - pc = (code_t)(sp[0]); - coq_env = sp[1]; - coq_extra_args = Long_val(sp[2]); - sp += 3; - } else { - /* The recursif argument is an accumulator */ - mlsize_t num_args, i; - /* Construction of fixpoint applied to its [rec_pos-1] first arguments */ - Alloc_small(accu, rec_pos + 2, Closure_tag); - Field(accu, 1) = coq_env; // We store the fixpoint in the first field - for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i]; // Storing args - Code_val(accu) = pc; - sp += rec_pos; - *--sp = accu; - /* Construction of the atom */ - Alloc_small(accu, 2, ATOM_FIX_TAG); - Field(accu,1) = sp[0]; - Field(accu,0) = sp[1]; - sp++; sp[0] = accu; - /* Construction of the accumulator */ - num_args = coq_extra_args - rec_pos; - Alloc_small(accu, 2+num_args, Accu_tag); - Code_val(accu) = accumulate; - Field(accu,1) = sp[0]; sp++; - for (i = 0; i < num_args;i++)Field(accu, i + 2) = sp[i]; - sp += num_args; - pc = (code_t)(sp[0]); - coq_env = sp[1]; - coq_extra_args = Long_val(sp[2]); - sp += 3; - } - } - Next; - } - + mlsize_t num_args, i; + num_args = 1 + coq_extra_args; /* arg1 + extra args */ + Alloc_small(accu, num_args + 2, Closure_tag); + Field(accu, 1) = coq_env; + for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc - 3; + sp += num_args; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } else { + /* The recursif argument is an accumulator */ + mlsize_t num_args, i; + /* Construction of fixpoint applied to its [rec_pos-1] first arguments */ + Alloc_small(accu, rec_pos + 2, Closure_tag); + Field(accu, 1) = coq_env; // We store the fixpoint in the first field + for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i]; // Storing args + Code_val(accu) = pc; + sp += rec_pos; + *--sp = accu; + /* Construction of the atom */ + Alloc_small(accu, 2, ATOM_FIX_TAG); + Field(accu,1) = sp[0]; + Field(accu,0) = sp[1]; + sp++; sp[0] = accu; + /* Construction of the accumulator */ + num_args = coq_extra_args - rec_pos; + Alloc_small(accu, 2+num_args, Accu_tag); + Code_val(accu) = accumulate; + Field(accu,1) = sp[0]; sp++; + for (i = 0; i < num_args;i++)Field(accu, i + 2) = sp[i]; + sp += num_args; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } + } + Next; + } + Instruct(CLOSURE) { - int nvars = *pc++; - int i; - print_instr("CLOSURE"); - print_int(nvars); - if (nvars > 0) *--sp = accu; - Alloc_small(accu, 1 + nvars, Closure_tag); - Code_val(accu) = pc + *pc; - pc++; - for (i = 0; i < nvars; i++) { - print_lint(sp[i]); - Field(accu, i + 1) = sp[i]; - } - sp += nvars; - Next; + int nvars = *pc++; + int i; + print_instr("CLOSURE"); + print_int(nvars); + if (nvars > 0) *--sp = accu; + Alloc_small(accu, 1 + nvars, Closure_tag); + Code_val(accu) = pc + *pc; + pc++; + for (i = 0; i < nvars; i++) { + print_lint(sp[i]); + Field(accu, i + 1) = sp[i]; + } + sp += nvars; + Next; } Instruct(CLOSUREREC) { - int nfuncs = *pc++; - int nvars = *pc++; - int start = *pc++; - int i; - value * p; - print_instr("CLOSUREREC"); - if (nvars > 0) *--sp = accu; - /* construction du vecteur de type */ + int nfuncs = *pc++; + int nvars = *pc++; + int start = *pc++; + int i; + value * p; + print_instr("CLOSUREREC"); + if (nvars > 0) *--sp = accu; + /* construction du vecteur de type */ Alloc_small(accu, nfuncs, Abstract_tag); - for(i = 0; i < nfuncs; i++) { - Field(accu,i) = (value)(pc+pc[i]); - } - pc += nfuncs; - *--sp=accu; - Alloc_small(accu, nfuncs * 2 + nvars, Closure_tag); - Field(accu, nfuncs * 2 + nvars - 1) = *sp++; - /* On remplie la partie pour les variables libres */ - p = &Field(accu, nfuncs * 2 - 1); - for (i = 0; i < nvars; i++) { - *p++ = *sp++; - } - p = &Field(accu, 0); - *p = (value) (pc + pc[0]); - p++; - for (i = 1; i < nfuncs; i++) { - *p = Make_header(i * 2, Infix_tag, Caml_white); - p++; /* color irrelevant. */ - *p = (value) (pc + pc[i]); - p++; - } - pc += nfuncs; - accu = accu + 2 * start * sizeof(value); - Next; - } - - Instruct(CLOSURECOFIX){ - int nfunc = *pc++; - int nvars = *pc++; - int start = *pc++; - int i, j , size; - value * p; - print_instr("CLOSURECOFIX"); - if (nvars > 0) *--sp = accu; - /* construction du vecteur de type */ + for(i = 0; i < nfuncs; i++) { + Field(accu,i) = (value)(pc+pc[i]); + } + pc += nfuncs; + *--sp=accu; + Alloc_small(accu, nfuncs * 2 + nvars, Closure_tag); + Field(accu, nfuncs * 2 + nvars - 1) = *sp++; + /* On remplie la partie pour les variables libres */ + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++) { + *p++ = *sp++; + } + p = &Field(accu, 0); + *p = (value) (pc + pc[0]); + p++; + for (i = 1; i < nfuncs; i++) { + *p = Make_header(i * 2, Infix_tag, Caml_white); + p++; /* color irrelevant. */ + *p = (value) (pc + pc[i]); + p++; + } + pc += nfuncs; + accu = accu + 2 * start * sizeof(value); + Next; + } + + Instruct(CLOSURECOFIX){ + int nfunc = *pc++; + int nvars = *pc++; + int start = *pc++; + int i, j , size; + value * p; + print_instr("CLOSURECOFIX"); + if (nvars > 0) *--sp = accu; + /* construction du vecteur de type */ Alloc_small(accu, nfunc, Abstract_tag); - for(i = 0; i < nfunc; i++) { - Field(accu,i) = (value)(pc+pc[i]); - } - pc += nfunc; - *--sp=accu; + for(i = 0; i < nfunc; i++) { + Field(accu,i) = (value)(pc+pc[i]); + } + pc += nfunc; + *--sp=accu; /* Creation des blocks accumulate */ for(i=0; i < nfunc; i++) { - Alloc_small(accu, 2, Accu_tag); - Code_val(accu) = accumulate; - Field(accu,1) = Val_int(1); - *--sp=accu; - } - /* creation des fonction cofix */ + Alloc_small(accu, 2, Accu_tag); + Code_val(accu) = accumulate; + Field(accu,1) = Val_int(1); + *--sp=accu; + } + /* creation des fonction cofix */ p = sp; - size = nfunc + nvars + 2; - for (i=0; i < nfunc; i++) { - - Alloc_small(accu, size, Closure_tag); - Code_val(accu) = pc+pc[i]; - for (j = 0; j < nfunc; j++) Field(accu, j+1) = p[j]; - Field(accu, size - 1) = p[nfunc]; - for (j = nfunc+1; j <= nfunc+nvars; j++) Field(accu, j) = p[j]; - *--sp = accu; + size = nfunc + nvars + 2; + for (i=0; i < nfunc; i++) { + + Alloc_small(accu, size, Closure_tag); + Code_val(accu) = pc+pc[i]; + for (j = 0; j < nfunc; j++) Field(accu, j+1) = p[j]; + Field(accu, size - 1) = p[nfunc]; + for (j = nfunc+1; j <= nfunc+nvars; j++) Field(accu, j) = p[j]; + *--sp = accu; /* creation du block contenant le cofix */ - Alloc_small(accu,1, ATOM_COFIX_TAG); - Field(accu, 0) = sp[0]; - *sp = accu; - /* mise a jour du block accumulate */ - caml_modify(&Field(p[i], 1),*sp); - sp++; - } - pc += nfunc; - accu = p[start]; + Alloc_small(accu,1, ATOM_COFIX_TAG); + Field(accu, 0) = sp[0]; + *sp = accu; + /* mise a jour du block accumulate */ + caml_modify(&Field(p[i], 1),*sp); + sp++; + } + pc += nfunc; + accu = p[start]; sp = p + nfunc + 1 + nvars; - print_instr("ici4"); - Next; + print_instr("ici4"); + Next; } - + Instruct(PUSHOFFSETCLOSURE) { - print_instr("PUSHOFFSETCLOSURE"); - *--sp = accu; + print_instr("PUSHOFFSETCLOSURE"); + *--sp = accu; } /* fallthrough */ Instruct(OFFSETCLOSURE) { - print_instr("OFFSETCLOSURE"); - accu = coq_env + *pc++ * sizeof(value); Next; + print_instr("OFFSETCLOSURE"); + accu = coq_env + *pc++ * sizeof(value); Next; } Instruct(PUSHOFFSETCLOSUREM2) { - print_instr("PUSHOFFSETCLOSUREM2"); - *--sp = accu; + print_instr("PUSHOFFSETCLOSUREM2"); + *--sp = accu; } /* fallthrough */ Instruct(OFFSETCLOSUREM2) { - print_instr("OFFSETCLOSUREM2"); - accu = coq_env - 2 * sizeof(value); Next; + print_instr("OFFSETCLOSUREM2"); + accu = coq_env - 2 * sizeof(value); Next; } Instruct(PUSHOFFSETCLOSURE0) { - print_instr("PUSHOFFSETCLOSURE0"); - *--sp = accu; + print_instr("PUSHOFFSETCLOSURE0"); + *--sp = accu; }/* fallthrough */ Instruct(OFFSETCLOSURE0) { - print_instr("OFFSETCLOSURE0"); - accu = coq_env; Next; + print_instr("OFFSETCLOSURE0"); + accu = coq_env; Next; } Instruct(PUSHOFFSETCLOSURE2){ - print_instr("PUSHOFFSETCLOSURE2"); - *--sp = accu; /* fallthrough */ + print_instr("PUSHOFFSETCLOSURE2"); + *--sp = accu; /* fallthrough */ } Instruct(OFFSETCLOSURE2) { - print_instr("OFFSETCLOSURE2"); - accu = coq_env + 2 * sizeof(value); Next; + print_instr("OFFSETCLOSURE2"); + accu = coq_env + 2 * sizeof(value); Next; } /* Access to global variables */ Instruct(PUSHGETGLOBAL) { - print_instr("PUSH"); - *--sp = accu; + print_instr("PUSH"); + *--sp = accu; } /* Fallthrough */ Instruct(GETGLOBAL){ - print_instr("GETGLOBAL"); - print_int(*pc); - accu = Field(coq_global_data, *pc); + print_instr("GETGLOBAL"); + print_int(*pc); + accu = Field(coq_global_data, *pc); pc++; Next; - } + } /* Allocation of blocks */ Instruct(MAKEBLOCK) { - mlsize_t wosize = *pc++; - tag_t tag = *pc++; - mlsize_t i; - value block; - print_instr("MAKEBLOCK, tag="); - Alloc_small(block, wosize, tag); - Field(block, 0) = accu; - for (i = 1; i < wosize; i++) Field(block, i) = *sp++; - accu = block; - Next; + mlsize_t wosize = *pc++; + tag_t tag = *pc++; + mlsize_t i; + value block; + print_instr("MAKEBLOCK, tag="); + Alloc_small(block, wosize, tag); + Field(block, 0) = accu; + for (i = 1; i < wosize; i++) Field(block, i) = *sp++; + accu = block; + Next; } Instruct(MAKEBLOCK1) { - - tag_t tag = *pc++; - value block; - print_instr("MAKEBLOCK1, tag="); - print_int(tag); - Alloc_small(block, 1, tag); - Field(block, 0) = accu; - accu = block; - Next; + + tag_t tag = *pc++; + value block; + print_instr("MAKEBLOCK1, tag="); + print_int(tag); + Alloc_small(block, 1, tag); + Field(block, 0) = accu; + accu = block; + Next; } Instruct(MAKEBLOCK2) { - - tag_t tag = *pc++; - value block; - print_instr("MAKEBLOCK2, tag="); - print_int(tag); - Alloc_small(block, 2, tag); - Field(block, 0) = accu; - Field(block, 1) = sp[0]; - sp += 1; - accu = block; - Next; + + tag_t tag = *pc++; + value block; + print_instr("MAKEBLOCK2, tag="); + print_int(tag); + Alloc_small(block, 2, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + sp += 1; + accu = block; + Next; } Instruct(MAKEBLOCK3) { - tag_t tag = *pc++; - value block; - print_instr("MAKEBLOCK3, tag="); - print_int(tag); - Alloc_small(block, 3, tag); - Field(block, 0) = accu; - Field(block, 1) = sp[0]; - Field(block, 2) = sp[1]; - sp += 2; - accu = block; - Next; + tag_t tag = *pc++; + value block; + print_instr("MAKEBLOCK3, tag="); + print_int(tag); + Alloc_small(block, 3, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + Field(block, 2) = sp[1]; + sp += 2; + accu = block; + Next; } Instruct(MAKEBLOCK4) { - tag_t tag = *pc++; - value block; - print_instr("MAKEBLOCK4, tag="); - print_int(tag); - Alloc_small(block, 4, tag); - Field(block, 0) = accu; - Field(block, 1) = sp[0]; - Field(block, 2) = sp[1]; - Field(block, 3) = sp[2]; - sp += 3; - accu = block; - Next; - } - - + tag_t tag = *pc++; + value block; + print_instr("MAKEBLOCK4, tag="); + print_int(tag); + Alloc_small(block, 4, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + Field(block, 2) = sp[1]; + Field(block, 3) = sp[2]; + sp += 3; + accu = block; + Next; + } + + /* Access to components of blocks */ - + Instruct(SWITCH) { - uint32_t sizes = *pc++; - print_instr("SWITCH"); - print_int(sizes & 0xFFFFFF); - if (Is_block(accu)) { - long index = Tag_val(accu); - print_instr("block"); - print_lint(index); - pc += pc[(sizes & 0xFFFFFF) + index]; - } else { - long index = Long_val(accu); - print_instr("constant"); - print_lint(index); - pc += pc[index]; - } - Next; + uint32_t sizes = *pc++; + print_instr("SWITCH"); + print_int(sizes & 0xFFFFFF); + if (Is_block(accu)) { + long index = Tag_val(accu); + print_instr("block"); + print_lint(index); + pc += pc[(sizes & 0xFFFFFF) + index]; + } else { + long index = Long_val(accu); + print_instr("constant"); + print_lint(index); + pc += pc[index]; + } + Next; } Instruct(PUSHFIELDS){ - int i; - int size = *pc++; - print_instr("PUSHFIELDS"); - sp -= size; - for(i=0;i<size;i++)sp[i] = Field(accu,i); - Next; - } - + int i; + int size = *pc++; + print_instr("PUSHFIELDS"); + sp -= size; + for(i=0;i<size;i++)sp[i] = Field(accu,i); + Next; + } + Instruct(GETFIELD0){ - print_instr("GETFIELD0"); - accu = Field(accu, 0); - Next; + print_instr("GETFIELD0"); + accu = Field(accu, 0); + Next; } Instruct(GETFIELD1){ - print_instr("GETFIELD1"); - accu = Field(accu, 1); - Next; + print_instr("GETFIELD1"); + accu = Field(accu, 1); + Next; } Instruct(GETFIELD){ - print_instr("GETFIELD"); - accu = Field(accu, *pc); - pc++; - Next; + print_instr("GETFIELD"); + accu = Field(accu, *pc); + pc++; + Next; } - + Instruct(SETFIELD0){ - print_instr("SETFIELD0"); - caml_modify(&Field(accu, 0),*sp); - sp++; - Next; + print_instr("SETFIELD0"); + caml_modify(&Field(accu, 0),*sp); + sp++; + Next; } - + Instruct(SETFIELD1){ - print_instr("SETFIELD1"); - caml_modify(&Field(accu, 1),*sp); - sp++; - Next; + print_instr("SETFIELD1"); + caml_modify(&Field(accu, 1),*sp); + sp++; + Next; } - + Instruct(SETFIELD){ - print_instr("SETFIELD"); - caml_modify(&Field(accu, *pc),*sp); - sp++; pc++; - Next; + print_instr("SETFIELD"); + caml_modify(&Field(accu, *pc),*sp); + sp++; pc++; + Next; } Instruct(PROJ){ do_proj: - print_instr("PROJ"); - if (Is_accu (accu)) { + print_instr("PROJ"); + if (Is_accu (accu)) { *--sp = accu; // Save matched block on stack accu = Field(accu, 1); // Save atom to accu register switch (Tag_val(accu)) { @@ -1023,135 +1043,135 @@ value coq_interprete accu = block; } } - } else { + } else { accu = Field(accu, *pc); pc += 2; - } - Next; + } + Next; } /* Integer constants */ Instruct(CONST0){ - print_instr("CONST0"); - accu = Val_int(0); Next;} + print_instr("CONST0"); + accu = Val_int(0); Next;} Instruct(CONST1){ - print_instr("CONST1"); - accu = Val_int(1); Next;} + print_instr("CONST1"); + accu = Val_int(1); Next;} Instruct(CONST2){ - print_instr("CONST2"); - accu = Val_int(2); Next;} + print_instr("CONST2"); + accu = Val_int(2); Next;} Instruct(CONST3){ - print_instr("CONST3"); - accu = Val_int(3); Next;} - + print_instr("CONST3"); + accu = Val_int(3); Next;} + Instruct(PUSHCONST0){ - print_instr("PUSHCONST0"); - *--sp = accu; accu = Val_int(0); Next; + print_instr("PUSHCONST0"); + *--sp = accu; accu = Val_int(0); Next; } Instruct(PUSHCONST1){ - print_instr("PUSHCONST1"); - *--sp = accu; accu = Val_int(1); Next; + print_instr("PUSHCONST1"); + *--sp = accu; accu = Val_int(1); Next; } Instruct(PUSHCONST2){ - print_instr("PUSHCONST2"); - *--sp = accu; accu = Val_int(2); Next; + print_instr("PUSHCONST2"); + *--sp = accu; accu = Val_int(2); Next; } Instruct(PUSHCONST3){ - print_instr("PUSHCONST3"); - *--sp = accu; accu = Val_int(3); Next; + print_instr("PUSHCONST3"); + *--sp = accu; accu = Val_int(3); Next; } Instruct(PUSHCONSTINT){ - print_instr("PUSHCONSTINT"); - *--sp = accu; + print_instr("PUSHCONSTINT"); + *--sp = accu; } /* Fallthrough */ Instruct(CONSTINT) { - print_instr("CONSTINT"); - print_int(*pc); - accu = Val_int(*pc); - pc++; - Next; + print_instr("CONSTINT"); + print_int(*pc); + accu = Val_int(*pc); + pc++; + Next; } /* Special operations for reduction of open term */ Instruct(ACCUMULATE) { - mlsize_t i, size; - print_instr("ACCUMULATE"); - size = Wosize_val(coq_env); - Alloc_small(accu, size + coq_extra_args + 1, Accu_tag); - for(i = 0; i < size; i++) Field(accu, i) = Field(coq_env, i); - for(i = size; i <= coq_extra_args + size; i++) - Field(accu, i) = *sp++; - pc = (code_t)(sp[0]); - coq_env = sp[1]; - coq_extra_args = Long_val(sp[2]); - sp += 3; - Next; - } + mlsize_t i, size; + print_instr("ACCUMULATE"); + size = Wosize_val(coq_env); + Alloc_small(accu, size + coq_extra_args + 1, Accu_tag); + for(i = 0; i < size; i++) Field(accu, i) = Field(coq_env, i); + for(i = size; i <= coq_extra_args + size; i++) + Field(accu, i) = *sp++; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + Next; + } Instruct(MAKESWITCHBLOCK) { - print_instr("MAKESWITCHBLOCK"); - *--sp = accu; // Save matched block on stack - accu = Field(accu,1); // Save atom to accu register - switch (Tag_val(accu)) { - case ATOM_COFIX_TAG: // We are forcing a cofix - { - mlsize_t i, nargs; - print_instr("COFIX_TAG"); - sp-=2; - pc++; + print_instr("MAKESWITCHBLOCK"); + *--sp = accu; // Save matched block on stack + accu = Field(accu,1); // Save atom to accu register + switch (Tag_val(accu)) { + case ATOM_COFIX_TAG: // We are forcing a cofix + { + mlsize_t i, nargs; + print_instr("COFIX_TAG"); + sp-=2; + pc++; // Push the return address - sp[0] = (value) (pc + *pc); - sp[1] = coq_env; - coq_env = Field(accu,0); // Pointer to suspension - accu = sp[2]; // Save accumulator to accu register - sp[2] = Val_long(coq_extra_args); // Push number of args for return - nargs = Wosize_val(accu) - 2; // Number of args = size of accumulator - 1 (accumulator code) - 1 (atom) + sp[0] = (value) (pc + *pc); + sp[1] = coq_env; + coq_env = Field(accu,0); // Pointer to suspension + accu = sp[2]; // Save accumulator to accu register + sp[2] = Val_long(coq_extra_args); // Push number of args for return + nargs = Wosize_val(accu) - 2; // Number of args = size of accumulator - 1 (accumulator code) - 1 (atom) // Push arguments to stack CHECK_STACK(nargs+1); - sp -= nargs; - for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); + sp -= nargs; + for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); *--sp = accu; // Leftmost argument is the pointer to the suspension - print_lint(nargs); - coq_extra_args = nargs; - pc = Code_val(coq_env); // Trigger evaluation - goto check_stack; - } - case ATOM_COFIXEVALUATED_TAG: - { - print_instr("COFIX_EVAL_TAG"); - accu = Field(accu,1); - pc++; - pc = pc + *pc; - sp++; - Next; - } - default: - { - mlsize_t sz; - int i, annot; - code_t typlbl,swlbl; - print_instr("MAKESWITCHBLOCK"); - - typlbl = (code_t)pc + *pc; - pc++; - swlbl = (code_t)pc + *pc; - pc++; - annot = *pc++; - sz = *pc++; - *--sp=Field(coq_global_data, annot); - /* We save the stack */ - if (sz == 0) accu = Atom(0); - else { - Alloc_small(accu, sz, Default_tag); - if (Field(*sp, 2) == Val_true) { - for (i = 0; i < sz; i++) Field(accu, i) = sp[i+2]; - }else{ - for (i = 0; i < sz; i++) Field(accu, i) = sp[i+5]; - } - } - *--sp = accu; + print_lint(nargs); + coq_extra_args = nargs; + pc = Code_val(coq_env); // Trigger evaluation + goto check_stack; + } + case ATOM_COFIXEVALUATED_TAG: + { + print_instr("COFIX_EVAL_TAG"); + accu = Field(accu,1); + pc++; + pc = pc + *pc; + sp++; + Next; + } + default: + { + mlsize_t sz; + int i, annot; + code_t typlbl,swlbl; + print_instr("MAKESWITCHBLOCK"); + + typlbl = (code_t)pc + *pc; + pc++; + swlbl = (code_t)pc + *pc; + pc++; + annot = *pc++; + sz = *pc++; + *--sp=Field(coq_global_data, annot); + /* We save the stack */ + if (sz == 0) accu = Atom(0); + else { + Alloc_small(accu, sz, Default_tag); + if (Field(*sp, 2) == Val_true) { + for (i = 0; i < sz; i++) Field(accu, i) = sp[i+2]; + }else{ + for (i = 0; i < sz; i++) Field(accu, i) = sp[i+5]; + } + } + *--sp = accu; /* Create bytecode wrappers */ Alloc_small(accu, 1, Abstract_tag); Code_val(accu) = typlbl; @@ -1168,47 +1188,47 @@ value coq_interprete Field(accu, 4) = coq_env; sp += 3; sp[0] = accu; - /* We create the atom */ - Alloc_small(accu, 2, ATOM_SWITCH_TAG); - Field(accu, 0) = sp[1]; Field(accu, 1) = sp[0]; - sp++;sp[0] = accu; - /* We create the accumulator */ - Alloc_small(accu, 2, Accu_tag); - Code_val(accu) = accumulate; - Field(accu,1) = *sp++; - } - } - Next; - } - - - + /* We create the atom */ + Alloc_small(accu, 2, ATOM_SWITCH_TAG); + Field(accu, 0) = sp[1]; Field(accu, 1) = sp[0]; + sp++;sp[0] = accu; + /* We create the accumulator */ + Alloc_small(accu, 2, Accu_tag); + Code_val(accu) = accumulate; + Field(accu,1) = *sp++; + } + } + Next; + } + + + Instruct(MAKEACCU) { - int i; - print_instr("MAKEACCU"); - Alloc_small(accu, coq_extra_args + 3, Accu_tag); - Code_val(accu) = accumulate; - Field(accu,1) = Field(coq_atom_tbl, *pc); - for(i = 2; i < coq_extra_args + 3; i++) Field(accu, i) = *sp++; - pc = (code_t)(sp[0]); - coq_env = sp[1]; - coq_extra_args = Long_val(sp[2]); - sp += 3; - Next; - } - + int i; + print_instr("MAKEACCU"); + Alloc_small(accu, coq_extra_args + 3, Accu_tag); + Code_val(accu) = accumulate; + Field(accu,1) = Field(coq_atom_tbl, *pc); + for(i = 2; i < coq_extra_args + 3; i++) Field(accu, i) = *sp++; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + Next; + } + Instruct(MAKEPROD) { - print_instr("MAKEPROD"); - *--sp=accu; - Alloc_small(accu,2,0); - Field(accu, 0) = sp[0]; - Field(accu, 1) = sp[1]; - sp += 2; - Next; + print_instr("MAKEPROD"); + *--sp=accu; + Alloc_small(accu,2,0); + Field(accu, 0) = sp[0]; + Field(accu, 1) = sp[1]; + sp += 2; + Next; } Instruct(BRANCH) { - /* unconditional branching */ + /* unconditional branching */ print_instr("BRANCH"); pc += *pc; /* pc = (code_t)(pc+*pc); */ @@ -1220,7 +1240,7 @@ value coq_interprete CheckInt2(); } Instruct(ADDINT63) { - /* Adds the integer in the accumulator with + /* Adds the integer in the accumulator with the one ontop of the stack (which is poped)*/ print_instr("ADDINT63"); Uint63_add(accu, *sp++); @@ -1230,27 +1250,27 @@ value coq_interprete Instruct (CHECKADDCINT63) { print_instr("CHECKADDCINT63"); CheckInt2(); - /* returns the sum with a carry */ + /* returns the sum with a carry */ int c; Uint63_add(accu, *sp); Uint63_lt(c, accu, *sp); Swap_accu_sp; AllocCarry(c); Field(accu, 0) = *sp++; - Next; + Next; } Instruct (CHECKADDCARRYCINT63) { print_instr("ADDCARRYCINT63"); CheckInt2(); - /* returns the sum plus one with a carry */ + /* returns the sum plus one with a carry */ int c; Uint63_addcarry(accu, *sp); Uint63_leq(c, accu, *sp); Swap_accu_sp; AllocCarry(c); Field(accu, 0) = *sp++; - Next; + Next; } Instruct (CHECKSUBINT63) { @@ -1259,7 +1279,7 @@ value coq_interprete } Instruct (SUBINT63) { print_instr("SUBINT63"); - /* returns the subtraction */ + /* returns the subtraction */ Uint63_sub(accu, *sp++); Next; } @@ -1267,35 +1287,35 @@ value coq_interprete Instruct (CHECKSUBCINT63) { print_instr("SUBCINT63"); CheckInt2(); - /* returns the subtraction with a carry */ + /* returns the subtraction with a carry */ int c; Uint63_lt(c, accu, *sp); Uint63_sub(accu, *sp); Swap_accu_sp; AllocCarry(c); Field(accu, 0) = *sp++; - Next; + Next; } Instruct (CHECKSUBCARRYCINT63) { print_instr("SUBCARRYCINT63"); CheckInt2(); - /* returns the subtraction minus one with a carry */ + /* returns the subtraction minus one with a carry */ int c; Uint63_leq(c,accu,*sp); Uint63_subcarry(accu,*sp); Swap_accu_sp; AllocCarry(c); Field(accu, 0) = *sp++; - Next; + Next; } Instruct (CHECKMULINT63) { print_instr("MULINT63"); CheckInt2(); - /* returns the multiplication */ + /* returns the multiplication */ Uint63_mul(accu,*sp++); - Next; + Next; } Instruct (CHECKMULCINT63) { @@ -1320,11 +1340,11 @@ value coq_interprete Uint63_eq0(b, *sp); if (b) { accu = *sp++; - } - else { + } + else { Uint63_div(accu, *sp++); } - Next; + Next; } Instruct(CHECKMODINT63) { @@ -1334,11 +1354,11 @@ value coq_interprete Uint63_eq0(b, *sp); if (b) { accu = *sp++; - } + } else { Uint63_mod(accu,*sp++); - } - Next; + } + Next; } Instruct (CHECKDIVEUCLINT63) { @@ -1366,7 +1386,7 @@ value coq_interprete Field(accu, 1) = sp[0]; sp += 2; } - Next; + Next; } Instruct (CHECKDIV21INT63) { @@ -1520,14 +1540,14 @@ value coq_interprete Instruct (ISINT){ print_instr("ISINT"); accu = (Is_uint63(accu)) ? coq_true : coq_false; - Next; + Next; } Instruct (AREINT2){ print_instr("AREINT2"); accu = (Is_uint63(accu) && Is_uint63(sp[0])) ? coq_true : coq_false; sp++; - Next; + Next; } @@ -1734,16 +1754,16 @@ value coq_interprete /* Debugging and machine control */ Instruct(STOP){ - print_instr("STOP"); - coq_sp = sp; + print_instr("STOP"); + coq_sp = sp; CAMLreturn(accu); } - - + + #ifndef THREADED_CODE default: /*fprintf(stderr, "%d\n", *pc);*/ - failwith("Coq VM: Fatal error: bad opcode"); + caml_failwith("Coq VM: Fatal error: bad opcode"); } } #endif diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index a1c49bee95..91d6773b1f 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -9,7 +9,7 @@ /***********************************************************************/ #include <stdio.h> -#include <string.h> +#include <string.h> #include <caml/alloc.h> #include <caml/address_class.h> #include "coq_gc.h" @@ -31,7 +31,7 @@ int drawinstr; long coq_saved_sp_offset; value * coq_sp; -/* Some predefined pointer code */ +/* Some predefined pointer code */ code_t accumulate; /* functions over global environment */ @@ -80,7 +80,7 @@ void init_coq_stack() coq_stack_high = coq_stack_low + Coq_stack_size / sizeof (value); coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value); coq_max_stack_size = Coq_max_stack_size; -} +} void init_coq_interpreter() { @@ -96,14 +96,14 @@ value init_coq_vm(value unit) /* ML */ fprintf(stderr,"already open \n");fflush(stderr);} else { drawinstr=0; -#ifdef THREADED_CODE +#ifdef THREADED_CODE init_arity(); #endif /* THREADED_CODE */ /* Allocate the table of global and the stack */ init_coq_stack(); /* Initialing the interpreter */ init_coq_interpreter(); - + /* Some predefined pointer code. * It is typically contained in accumulator blocks whose tag is 0 and thus * scanned by the GC, so make it look like an OCaml block. */ @@ -117,7 +117,7 @@ value init_coq_vm(value unit) /* ML */ coq_prev_scan_roots_hook = scan_roots_hook; scan_roots_hook = coq_scan_roots; coq_vm_initialized = 1; - } + } return Val_unit;; } diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h index 1ea461c5e5..7f982d0477 100644 --- a/kernel/byterun/coq_memory.h +++ b/kernel/byterun/coq_memory.h @@ -39,7 +39,7 @@ extern int drawinstr; /* interp state */ extern value * coq_sp; -/* Some predefined pointer code */ +/* Some predefined pointer code */ extern code_t accumulate; /* functions over global environment */ @@ -49,7 +49,7 @@ value coq_static_alloc(value size); /* ML */ value init_coq_vm(value unit); /* ML */ value re_init_coq_vm(value unit); /* ML */ -void realloc_coq_stack(asize_t required_space); +void realloc_coq_stack(asize_t required_space); value coq_set_transp_value(value transp); /* ML */ value get_coq_transp_value(value unit); /* ML */ #endif /* _COQ_MEMORY_ */ diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c index e05f3fb82e..bbe91da628 100644 --- a/kernel/byterun/coq_values.c +++ b/kernel/byterun/coq_values.c @@ -39,8 +39,8 @@ value coq_closure_arity(value clos) { if (Is_instruction(c,RESTART)) { c++; if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos)); - else { - if (Wosize_val(clos) != 2) failwith("Coq Values : coq_closure_arity"); + else { + if (Wosize_val(clos) != 2) caml_failwith("Coq Values : coq_closure_arity"); return Val_int(1); } } diff --git a/kernel/byterun/dune b/kernel/byterun/dune index 8d8374a603..2998178be2 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -2,8 +2,10 @@ (name byterun) (synopsis "Coq's Kernel Abstract Reduction Machine [C implementation]") (public_name coq.vm) - (c_flags (:include %{project_root}/config/dune.c_flags)) - (c_names coq_fix_code coq_memory coq_values coq_interp)) + (foreign_stubs + (language c) + (names coq_fix_code coq_memory coq_values coq_interp) + (flags (:include %{project_root}/config/dune.c_flags)))) (rule (targets coq_instruct.h) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 9d7387c7ad..261a3510d6 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -315,10 +315,6 @@ let refresh_polymorphic_type_of_inductive (_,mip) = let ctx = List.rev mip.mind_arity_ctxt in mkArity (List.rev ctx, Sorts.sort_of_univ ar.template_level), true -let dummy_variance = let open Entries in function - | Monomorphic_entry _ -> assert false - | Polymorphic_entry (_,uctx) -> Array.make (Univ.UContext.size uctx) Univ.Variance.Irrelevant - let cook_inductive { Opaqueproof.modlist; abstract } mib = let open Entries in let (section_decls, subst, abs_uctx) = abstract in @@ -333,10 +329,6 @@ let cook_inductive { Opaqueproof.modlist; abstract } mib = let auctx = Univ.AUContext.repr auctx in subst, Polymorphic_entry (nas, auctx) in - let variance = match mib.mind_variance with - | None -> None - | Some _ -> Some (dummy_variance ind_univs) - in let cache = RefTable.create 13 in let discharge c = Vars.subst_univs_level_constr subst (expmod_constr cache modlist c) in let inds = @@ -363,7 +355,7 @@ let cook_inductive { Opaqueproof.modlist; abstract } mib = mind_entry_params = params'; mind_entry_inds = inds'; mind_entry_private = mib.mind_private; - mind_entry_variance = variance; + mind_entry_cumulative = Option.has_some mib.mind_variance; mind_entry_universes = ind_univs } diff --git a/kernel/entries.ml b/kernel/entries.ml index b50c3ebbc3..8d930b521c 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -50,7 +50,7 @@ type mutual_inductive_entry = { mind_entry_params : Constr.rel_context; mind_entry_inds : one_inductive_entry list; mind_entry_universes : universes_entry; - mind_entry_variance : Univ.Variance.t array option; + mind_entry_cumulative : bool; (* universe constraints and the constraints for subtyping of inductive types in the block. *) mind_entry_private : bool option; diff --git a/kernel/environ.mli b/kernel/environ.mli index 257bd43083..bd5a000c2b 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -296,7 +296,13 @@ val add_constraints : Univ.Constraint.t -> env -> env (** Check constraints are satifiable in the environment. *) val check_constraints : Univ.Constraint.t -> env -> bool val push_context : ?strict:bool -> Univ.UContext.t -> env -> env +(* [push_context ?(strict=false) ctx env] pushes the universe context to the environment. + @raise UGraph.AlreadyDeclared if one of the universes is already declared. +*) val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env +(* [push_context_set ?(strict=false) ctx env] pushes the universe context set + to the environment. It does not fail if one of the universes is already declared. *) + val push_constraints_to_env : 'a Univ.constrained -> env -> env val push_subgraph : Univ.ContextSet.t -> env -> env diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index 06d2e1bb21..d9ccf81619 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -61,64 +61,6 @@ let mind_check_names mie = (************************************************************************) -(************************** Cumulativity checking************************) -(************************************************************************) - -(* Check arities and constructors *) -let check_subtyping_arity_constructor env subst arcn numparams is_arity = - let numchecked = ref 0 in - let basic_check ev tp = - if !numchecked < numparams then () else Reduction.conv_leq ev tp (subst tp); - numchecked := !numchecked + 1 - in - let check_typ typ typ_env = - match typ with - | LocalAssum (_, typ') -> - begin - try - basic_check typ_env typ'; Environ.push_rel typ typ_env - with Reduction.NotConvertible -> - CErrors.anomaly ~label:"bad inductive subtyping relation" - Pp.(str "Invalid subtyping relation") - end - | _ -> CErrors.anomaly Pp.(str "") - in - let typs, codom = Reduction.dest_prod env arcn in - let last_env = Context.Rel.fold_outside check_typ typs ~init:env in - if not is_arity then basic_check last_env codom else () - -let check_cumulativity univs variances env_ar params data = - let uctx = match univs with - | Monomorphic_entry _ -> raise (InductiveError BadUnivs) - | Polymorphic_entry (_,uctx) -> uctx - in - let instance = UContext.instance uctx in - if Instance.length instance != Array.length variances then raise (InductiveError BadUnivs); - let numparams = Context.Rel.nhyps params in - let new_levels = Array.init (Instance.length instance) - (fun i -> Level.(make (UGlobal.make DirPath.empty i))) - in - let lmap = Array.fold_left2 (fun lmap u u' -> LMap.add u u' lmap) - LMap.empty (Instance.to_array instance) new_levels - in - let dosubst = Vars.subst_univs_level_constr lmap in - let instance_other = Instance.of_array new_levels in - let constraints_other = Univ.subst_univs_level_constraints lmap (UContext.constraints uctx) in - let uctx_other = Univ.UContext.make (instance_other, constraints_other) in - let env = Environ.push_context uctx_other env_ar in - let subtyp_constraints = - Univ.enforce_leq_variance_instances variances - instance instance_other - Constraint.empty - in - let env = Environ.add_constraints subtyp_constraints env in - (* process individual inductive types: *) - List.iter (fun (arity,lc) -> - check_subtyping_arity_constructor env dosubst arity numparams true; - Array.iter (fun cnt -> check_subtyping_arity_constructor env dosubst cnt numparams false) lc) - data - -(************************************************************************) (************************** Type checking *******************************) (************************************************************************) @@ -253,10 +195,11 @@ let unbounded_from_below u cstrs = (starting from the most recent and ignoring let-definitions) is not contributing to the inductive type's sort or is Some u_k if its level is u_k and is contributing. *) -let template_polymorphic_univs ~template_check uctx paramsctxt concl = +let template_polymorphic_univs ~template_check ~ctor_levels uctx paramsctxt concl = let check_level l = if Univ.LSet.mem l (Univ.ContextSet.levels uctx) && - unbounded_from_below l (Univ.ContextSet.constraints uctx) then + unbounded_from_below l (Univ.ContextSet.constraints uctx) && + not (Univ.LSet.mem l ctor_levels) then Some l else None in @@ -302,10 +245,31 @@ let abstract_packets ~template_check univs usubst params ((arity,lc),(indices,sp | Polymorphic _ -> CErrors.anomaly ~label:"polymorphic_template_ind" Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.") in - let param_levels, concl_levels = template_polymorphic_univs ~template_check ctx params min_univ in + let ctor_levels = + let add_levels c levels = Univ.LSet.union levels (Vars.universes_of_constr c) in + let param_levels = + List.fold_left (fun levels d -> match d with + | LocalAssum _ -> levels + | LocalDef (_,b,t) -> add_levels b (add_levels t levels)) + Univ.LSet.empty params + in + Array.fold_left + (fun levels (d,c) -> + let levels = + List.fold_left (fun levels d -> + Context.Rel.Declaration.fold_constr add_levels d levels) + levels d + in + add_levels c levels) + param_levels + splayed_lc + in + let param_levels, concl_levels = + template_polymorphic_univs ~template_check ~ctor_levels ctx params min_univ + in if template_check && List.for_all (fun x -> Option.is_empty x) param_levels && Univ.LSet.is_empty concl_levels then - CErrors.anomaly ~label:"polymorphic_template_ind" + CErrors.user_err Pp.(strbrk "Ill-formed template inductive declaration: not polymorphic on any universe.") else TemplateArity {template_param_levels = param_levels; template_level = min_univ} @@ -329,8 +293,14 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = let env_univs = match mie.mind_entry_universes with | Monomorphic_entry ctx -> - let env = if has_template_poly then set_universes_lbound env Univ.Level.prop else env in - push_context_set ctx env + if has_template_poly then + (* For that particular case, we typecheck the inductive in an environment + where the universes introduced by the definition are only [>= Prop] *) + let env = set_universes_lbound env Univ.Level.prop in + push_context_set ~strict:false ctx env + else + (* In the regular case, all universes are [> Set] *) + push_context_set ~strict:true ctx env | Polymorphic_entry (_, ctx) -> push_context ctx env in @@ -367,11 +337,8 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = data, Some None in - let () = match mie.mind_entry_variance with - | None -> () - | Some variances -> - check_cumulativity mie.mind_entry_universes variances env_ar params (List.map pi1 data) - in + (* TODO pass only the needed bits *) + let variance = InferCumulativity.infer_inductive env mie in (* Abstract universes *) let usubst, univs = Declareops.abstract_universes mie.mind_entry_universes in @@ -386,4 +353,4 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = Environ.push_rel_context ctx env in - env_ar_par, univs, mie.mind_entry_variance, record, params, Array.of_list data + env_ar_par, univs, variance, record, params, Array.of_list data diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli index 8da4e2885c..5c04e860a2 100644 --- a/kernel/indTyping.mli +++ b/kernel/indTyping.mli @@ -38,6 +38,7 @@ val typecheck_inductive : env -> mutual_inductive_entry -> of a template polymorphic inductive *) val template_polymorphic_univs : template_check:bool -> + ctor_levels:Univ.LSet.t -> Univ.ContextSet.t -> Constr.rel_context -> Univ.Universe.t -> diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index 550c81ed82..77abe6b410 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -216,19 +216,11 @@ let infer_inductive env mie = let open Entries in let params = mie.mind_entry_params in let entries = mie.mind_entry_inds in - let variances = - match mie.mind_entry_variance with - | None -> None - | Some _ -> - let uctx = match mie.mind_entry_universes with - | Monomorphic_entry _ -> assert false - | Polymorphic_entry (_,uctx) -> uctx - in - try Some (infer_inductive_core env params entries uctx) - with TrivialVariance -> Some (Array.make (UContext.size uctx) Invariant) - in - { mie with mind_entry_variance = variances } - -let dummy_variance = let open Entries in function - | Monomorphic_entry _ -> assert false - | Polymorphic_entry (_,uctx) -> Array.make (UContext.size uctx) Irrelevant + if not mie.mind_entry_cumulative then None + else + let uctx = match mie.mind_entry_universes with + | Monomorphic_entry _ -> assert false + | Polymorphic_entry (_,uctx) -> uctx + in + try Some (infer_inductive_core env params entries uctx) + with TrivialVariance -> Some (Array.make (UContext.size uctx) Invariant) diff --git a/kernel/inferCumulativity.mli b/kernel/inferCumulativity.mli index a234e334d1..2bddfe21e2 100644 --- a/kernel/inferCumulativity.mli +++ b/kernel/inferCumulativity.mli @@ -9,6 +9,4 @@ (************************************************************************) val infer_inductive : Environ.env -> Entries.mutual_inductive_entry -> - Entries.mutual_inductive_entry - -val dummy_variance : Entries.universes_entry -> Univ.Variance.t array + Univ.Variance.t array option diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 2b83c2d868..f1e994b337 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -42,9 +42,9 @@ Type_errors Modops Inductive Typeops +InferCumulativity IndTyping Indtypes -InferCumulativity Cooking Term_typing Subtyping diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 06f5aae047..ee101400d6 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -122,7 +122,7 @@ type section_data = { type safe_environment = { env : Environ.env; - sections : section_data Section.t; + sections : section_data Section.t option; modpath : ModPath.t; modvariant : modvariant; modresolver : Mod_subst.delta_resolver; @@ -159,7 +159,7 @@ let empty_environment = revstruct = []; modlabels = Label.Set.empty; objlabels = Label.Set.empty; - sections = Section.empty; + sections = None; future_cst = []; univ = Univ.ContextSet.empty; engagement = None; @@ -173,7 +173,7 @@ let is_initial senv = | [], NONE -> ModPath.equal senv.modpath ModPath.initial | _ -> false -let sections_are_opened senv = not (Section.is_empty senv.sections) +let sections_are_opened senv = not (Option.is_empty senv.sections) let delta_of_senv senv = senv.modresolver,senv.paramresolver @@ -323,19 +323,21 @@ let env_of_senv = env_of_safe_env let sections_of_safe_env senv = senv.sections +let get_section = function + | None -> CErrors.user_err Pp.(str "No open section.") + | Some s -> s + type constraints_addition = | Now of Univ.ContextSet.t | Later of Univ.ContextSet.t Future.computation -let push_context_set poly cst senv = +let push_context_set ~strict cst senv = if Univ.ContextSet.is_empty cst then senv else - let sections = - if Section.is_empty senv.sections then senv.sections - else Section.push_constraints cst senv.sections + let sections = Option.map (Section.push_constraints cst) senv.sections in { senv with - env = Environ.push_context_set ~strict:(not poly) cst senv.env; + env = Environ.push_context_set ~strict cst senv.env; univ = Univ.ContextSet.union cst senv.univ; sections } @@ -344,7 +346,7 @@ let add_constraints cst senv = | Later fc -> {senv with future_cst = fc :: senv.future_cst} | Now cst -> - push_context_set false cst senv + push_context_set ~strict:true cst senv let add_constraints_list cst senv = List.fold_left (fun acc c -> add_constraints c acc) senv cst @@ -399,7 +401,7 @@ let check_current_library dir senv = match senv.modvariant with (** When operating on modules, we're normally outside sections *) let check_empty_context senv = - assert (Environ.empty_context senv.env && Section.is_empty senv.sections) + assert (Environ.empty_context senv.env && Option.is_empty senv.sections) (** When adding a parameter to the current module/modtype, it must have been freshly started *) @@ -447,22 +449,25 @@ let safe_push_named d env = Environ.push_named d env let push_named_def (id,de) senv = - let sections = Section.push_local senv.sections in + let sections = get_section senv.sections in + let sections = Section.push_local sections in let c, r, typ = Term_typing.translate_local_def senv.env id de in let x = Context.make_annot id r in let env'' = safe_push_named (LocalDef (x, c, typ)) senv.env in - { senv with sections; env = env'' } + { senv with sections=Some sections; env = env'' } let push_named_assum (x,t) senv = - let sections = Section.push_local senv.sections in + let sections = get_section senv.sections in + let sections = Section.push_local sections in let t, r = Term_typing.translate_local_assum senv.env t in let x = Context.make_annot x r in let env'' = safe_push_named (LocalAssum (x,t)) senv.env in - { senv with sections; env = env'' } + { senv with sections=Some sections; env = env'' } let push_section_context (nas, ctx) senv = - let sections = Section.push_context (nas, ctx) senv.sections in - let senv = { senv with sections } in + let sections = get_section senv.sections in + let sections = Section.push_context (nas, ctx) sections in + let senv = { senv with sections=Some sections } in let ctx = Univ.ContextSet.of_context ctx in (* We check that the universes are fresh. FIXME: This should be done implicitly, but we have to work around the API. *) @@ -542,7 +547,7 @@ let add_field ?(is_include=false) ((l,sfb) as field) gn senv = else (* Delayed constraints from opaque body are added by [add_constant_aux] *) let cst = constraints_of_sfb sfb in - List.fold_left (fun senv cst -> push_context_set false cst senv) senv cst + List.fold_left (fun senv cst -> push_context_set ~strict:true cst senv) senv cst in let env' = match sfb, gn with | SFBconst cb, C con -> Environ.add_constant con cb senv.env @@ -551,15 +556,18 @@ let add_field ?(is_include=false) ((l,sfb) as field) gn senv = | SFBmodule mb, M -> Modops.add_module mb senv.env | _ -> assert false in - let sections = match sfb, gn with - | SFBconst cb, C con -> - let poly = Declareops.constant_is_polymorphic cb in - Section.push_constant ~poly con senv.sections - | SFBmind mib, I mind -> - let poly = Declareops.inductive_is_polymorphic mib in - Section.push_inductive ~poly mind senv.sections - | _, (M | MT) -> senv.sections - | _ -> assert false + let sections = match senv.sections with + | None -> None + | Some sections -> + match sfb, gn with + | SFBconst cb, C con -> + let poly = Declareops.constant_is_polymorphic cb in + Some (Section.push_constant ~poly con sections) + | SFBmind mib, I mind -> + let poly = Declareops.inductive_is_polymorphic mib in + Some (Section.push_inductive ~poly mind sections) + | _, (M | MT) -> Some sections + | _ -> assert false in { senv with env = env'; @@ -952,11 +960,11 @@ let open_section senv = rev_objlabels = senv.objlabels; } in let sections = Section.open_section ~custom senv.sections in - { senv with sections } + { senv with sections=Some sections } let close_section senv = let open Section in - let sections0 = senv.sections in + let sections0 = get_section senv.sections in let env0 = senv.env in (* First phase: revert the declarations added in the section *) let sections, entries, cstrs, revert = Section.close_section sections0 in @@ -990,7 +998,7 @@ let close_section senv = let env = Environ.set_opaque_tables env (Environ.opaque_tables senv.env) in let senv = { senv with env; revstruct; sections; univ; objlabels; } in (* Second phase: replay the discharged section contents *) - let senv = add_constraints (Now cstrs) senv in + let senv = push_context_set ~strict:true cstrs senv in let modlist = Section.replacement_context env0 sections0 in let cooking_info seg = let { abstr_ctx; abstr_subst; abstr_uctx } = seg in @@ -1007,7 +1015,6 @@ let close_section senv = | `Inductive (ind, mib) -> let info = cooking_info (Section.segment_of_inductive env0 ind sections0) in let mie = Cooking.cook_inductive info mib in - let mie = InferCumulativity.infer_inductive senv.env mie in let _, senv = add_mind (MutInd.label ind) mie senv in senv in diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index ae6993b0e2..92bbd264fa 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -35,7 +35,7 @@ val is_initial : safe_environment -> bool val env_of_safe_env : safe_environment -> Environ.env -val sections_of_safe_env : safe_environment -> section_data Section.t +val sections_of_safe_env : safe_environment -> section_data Section.t option (** The safe_environment state monad *) @@ -113,7 +113,7 @@ val add_modtype : (** Adding universe constraints *) val push_context_set : - bool -> Univ.ContextSet.t -> safe_transformer0 + strict:bool -> Univ.ContextSet.t -> safe_transformer0 val add_constraints : Univ.Constraint.t -> safe_transformer0 diff --git a/kernel/section.ml b/kernel/section.ml index a1242f0faf..603ef5d006 100644 --- a/kernel/section.ml +++ b/kernel/section.ml @@ -20,7 +20,9 @@ type section_entry = type 'a entry_map = 'a Cmap.t * 'a Mindmap.t -type 'a section = { +type 'a t = { + sec_prev : 'a t option; + (** Section surrounding the current one *) sec_context : int; (** Length of the named context suffix that has been introduced locally *) sec_mono_universes : ContextSet.t; @@ -35,19 +37,9 @@ type 'a section = { sec_custom : 'a; } -(** Sections can be nested with the proviso that no monomorphic section can be - opened inside a polymorphic one. The reverse is allowed. *) -type 'a t = 'a section list +let rec depth sec = 1 + match sec.sec_prev with None -> 0 | Some prev -> depth prev -let empty = [] - -let is_empty = List.is_empty - -let depth = List.length - -let has_poly_univs = function - | [] -> false - | sec :: _ -> sec.has_poly_univs +let has_poly_univs sec = sec.has_poly_univs let find_emap e (cmap, imap) = match e with | SecDefinition con -> Cmap.find con cmap @@ -57,80 +49,59 @@ let add_emap e v (cmap, imap) = match e with | SecDefinition con -> (Cmap.add con v cmap, imap) | SecInductive ind -> (cmap, Mindmap.add ind v imap) -let on_last_section f sections = match sections with -| [] -> CErrors.user_err (Pp.str "No opened section") -| sec :: rem -> f sec :: rem - -let with_last_section f sections = match sections with -| [] -> f None -| sec :: _ -> f (Some sec) - -let push_local s = - let on_sec sec = { sec with sec_context = sec.sec_context + 1 } in - on_last_section on_sec s - -let push_context (nas, ctx) s = - let on_sec sec = - if UContext.is_empty ctx then sec - else - let (snas, sctx) = sec.sec_poly_universes in - let sec_poly_universes = (Array.append snas nas, UContext.union sctx ctx) in - { sec with sec_poly_universes; has_poly_univs = true } - in - on_last_section on_sec s - -let is_polymorphic_univ u s = - let check sec = - let (_, uctx) = sec.sec_poly_universes in - Array.exists (fun u' -> Level.equal u u') (Instance.to_array (UContext.instance uctx)) - in - List.exists check s - -let push_constraints uctx s = - let on_sec sec = - if sec.has_poly_univs && Constraint.exists (fun (l,_,r) -> is_polymorphic_univ l s || is_polymorphic_univ r s) (snd uctx) - then CErrors.user_err Pp.(str "Cannot add monomorphic constraints which refer to section polymorphic universes."); - let uctx' = sec.sec_mono_universes in - let sec_mono_universes = (ContextSet.union uctx uctx') in - { sec with sec_mono_universes } - in - on_last_section on_sec s - -let open_section ~custom sections = - let sec = { +let push_local sec = + { sec with sec_context = sec.sec_context + 1 } + +let push_context (nas, ctx) sec = + if UContext.is_empty ctx then sec + else + let (snas, sctx) = sec.sec_poly_universes in + let sec_poly_universes = (Array.append snas nas, UContext.union sctx ctx) in + { sec with sec_poly_universes; has_poly_univs = true } + +let rec is_polymorphic_univ u sec = + let (_, uctx) = sec.sec_poly_universes in + let here = Array.exists (fun u' -> Level.equal u u') (Instance.to_array (UContext.instance uctx)) in + here || Option.cata (is_polymorphic_univ u) false sec.sec_prev + +let push_constraints uctx sec = + if sec.has_poly_univs && + Constraint.exists + (fun (l,_,r) -> is_polymorphic_univ l sec || is_polymorphic_univ r sec) + (snd uctx) + then CErrors.user_err + Pp.(str "Cannot add monomorphic constraints which refer to section polymorphic universes."); + let uctx' = sec.sec_mono_universes in + let sec_mono_universes = (ContextSet.union uctx uctx') in + { sec with sec_mono_universes } + +let open_section ~custom sec_prev = + { + sec_prev; sec_context = 0; sec_mono_universes = ContextSet.empty; sec_poly_universes = ([||], UContext.empty); - has_poly_univs = has_poly_univs sections; + has_poly_univs = Option.cata has_poly_univs false sec_prev; sec_entries = []; sec_data = (Cmap.empty, Mindmap.empty); sec_custom = custom; - } in - sec :: sections + } -let close_section sections = - match sections with - | sec :: sections -> - sections, sec.sec_entries, sec.sec_mono_universes, sec.sec_custom - | [] -> - CErrors.user_err (Pp.str "No opened section.") +let close_section sec = + sec.sec_prev, sec.sec_entries, sec.sec_mono_universes, sec.sec_custom let make_decl_univs (nas,uctx) = abstract_universes nas uctx -let push_global ~poly e s = - if is_empty s then s - else if has_poly_univs s && not poly +let push_global ~poly e sec = + if has_poly_univs sec && not poly then CErrors.user_err Pp.(str "Cannot add a universe monomorphic declaration when \ section polymorphic universes are present.") else - let on_sec sec = - { sec with - sec_entries = e :: sec.sec_entries; - sec_data = add_emap e (make_decl_univs sec.sec_poly_universes) sec.sec_data; - } - in - on_last_section on_sec s + { sec with + sec_entries = e :: sec.sec_entries; + sec_data = add_emap e (make_decl_univs sec.sec_poly_universes) sec.sec_data; + } let push_constant ~poly con s = push_global ~poly (SecDefinition con) s @@ -154,22 +125,16 @@ let extract_hyps sec vars used = (* Only keep the part that is used by the declaration *) List.filter (fun d -> Id.Set.mem (NamedDecl.get_id d) used) vars -let section_segment_of_entry vars e hyps sections = +let section_segment_of_entry vars e hyps sec = (* [vars] are the named hypotheses, [hyps] the subset that is declared by the - global *) - let with_sec s = match s with - | None -> - CErrors.user_err (Pp.str "No opened section.") - | Some sec -> - let hyps = extract_hyps sec vars hyps in - let inst, auctx = find_emap e sec.sec_data in - { - abstr_ctx = hyps; - abstr_subst = inst; - abstr_uctx = auctx; - } - in - with_last_section with_sec sections + global *) + let hyps = extract_hyps sec vars hyps in + let inst, auctx = find_emap e sec.sec_data in + { + abstr_ctx = hyps; + abstr_subst = inst; + abstr_uctx = auctx; + } let segment_of_constant env con s = let body = Environ.lookup_constant con env in @@ -190,29 +155,19 @@ let extract_worklist info = let args = instance_from_variable_context info.abstr_ctx in info.abstr_subst, args -let replacement_context env s = - let with_sec sec = match sec with - | None -> CErrors.user_err (Pp.str "No opened section.") - | Some sec -> - let cmap, imap = sec.sec_data in - let cmap = Cmap.mapi (fun con _ -> extract_worklist @@ segment_of_constant env con s) cmap in - let imap = Mindmap.mapi (fun ind _ -> extract_worklist @@ segment_of_inductive env ind s) imap in - (cmap, imap) - in - with_last_section with_sec s - -let is_in_section env gr s = - let with_sec sec = match sec with - | None -> false - | Some sec -> - let open GlobRef in - match gr with - | VarRef id -> - let vars = List.firstn sec.sec_context (Environ.named_context env) in - List.exists (fun decl -> Id.equal id (NamedDecl.get_id decl)) vars - | ConstRef con -> - Cmap.mem con (fst sec.sec_data) - | IndRef (ind, _) | ConstructRef ((ind, _), _) -> - Mindmap.mem ind (snd sec.sec_data) - in - with_last_section with_sec s +let replacement_context env sec = + let cmap, imap = sec.sec_data in + let cmap = Cmap.mapi (fun con _ -> extract_worklist @@ segment_of_constant env con sec) cmap in + let imap = Mindmap.mapi (fun ind _ -> extract_worklist @@ segment_of_inductive env ind sec) imap in + (cmap, imap) + +let is_in_section env gr sec = + let open GlobRef in + match gr with + | VarRef id -> + let vars = List.firstn sec.sec_context (Environ.named_context env) in + List.exists (fun decl -> Id.equal id (NamedDecl.get_id decl)) vars + | ConstRef con -> + Cmap.mem con (fst sec.sec_data) + | IndRef (ind, _) | ConstructRef ((ind, _), _) -> + Mindmap.mem ind (snd sec.sec_data) diff --git a/kernel/section.mli b/kernel/section.mli index ec863b3b90..fbd3d8254e 100644 --- a/kernel/section.mli +++ b/kernel/section.mli @@ -16,13 +16,8 @@ open Univ type 'a t (** Type of sections with additional data ['a] *) -val empty : 'a t - -val is_empty : 'a t -> bool -(** Checks whether there is no opened section *) - val depth : 'a t -> int -(** Number of nested sections (0 if no sections are open) *) +(** Number of nested sections. *) (** {6 Manipulating sections} *) @@ -30,13 +25,13 @@ type section_entry = | SecDefinition of Constant.t | SecInductive of MutInd.t -val open_section : custom:'a -> 'a t -> 'a t +val open_section : custom:'a -> 'a t option -> 'a t (** Open a new section with the provided universe polymorphic status. Sections can be nested, with the proviso that polymorphic sections cannot appear inside a monomorphic one. A custom data can be attached to this section, that will be returned by {!close_section}. *) -val close_section : 'a t -> 'a t * section_entry list * ContextSet.t * 'a +val close_section : 'a t -> 'a t option * section_entry list * ContextSet.t * 'a (** Close the current section and returns the entries defined inside, the set of global monomorphic constraints added in this section, and the custom data provided at the opening of the section. *) diff --git a/lib/flags.ml b/lib/flags.ml index 83588779e5..b87ba46634 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -57,32 +57,6 @@ let raw_print = ref false let we_are_parsing = ref false -(* Compatibility mode *) - -(* Current means no particular compatibility consideration. - For correct comparisons, this constructor should remain the last one. *) - -type compat_version = V8_9 | V8_10 | Current - -let compat_version = ref Current - -let version_compare v1 v2 = match v1, v2 with - | V8_9, V8_9 -> 0 - | V8_9, _ -> -1 - | _, V8_9 -> 1 - | V8_10, V8_10 -> 0 - | V8_10, _ -> -1 - | _, V8_10 -> 1 - | Current, Current -> 0 - -let version_strictly_greater v = version_compare !compat_version v > 0 -let version_less_or_equal v = not (version_strictly_greater v) - -let pr_version = function - | V8_9 -> "8.9" - | V8_10 -> "8.10" - | Current -> "current" - (* Translate *) let beautify = ref false let beautify_file = ref false diff --git a/lib/flags.mli b/lib/flags.mli index 5df07399c5..86a922847f 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -14,7 +14,7 @@ This file is own its way to deprecation in favor of a purely functional state, but meanwhile it will contain options that are - truly global to the system such as [compat] or [debug] + truly global to the system such as [debug] If you are thinking about adding a global flag, well, just don't. First of all, options make testins exponentially more @@ -52,13 +52,6 @@ val we_are_parsing : bool ref (* Set Printing All flag. For some reason it is a global flag *) val raw_print : bool ref -type compat_version = V8_9 | V8_10 | Current -val compat_version : compat_version ref -val version_compare : compat_version -> compat_version -> int -val version_strictly_greater : compat_version -> bool -val version_less_or_equal : compat_version -> bool -val pr_version : compat_version -> string - (* Beautify command line flags, should move to printing? *) val beautify : bool ref val beautify_file : bool ref diff --git a/library/global.ml b/library/global.ml index d4262683bb..fbbe09301b 100644 --- a/library/global.ml +++ b/library/global.ml @@ -90,7 +90,7 @@ let push_named_assum a = globalize0 (Safe_typing.push_named_assum a) let push_named_def d = globalize0 (Safe_typing.push_named_def d) let push_section_context c = globalize0 (Safe_typing.push_section_context c) let add_constraints c = globalize0 (Safe_typing.add_constraints c) -let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) +let push_context_set ~strict c = globalize0 (Safe_typing.push_context_set ~strict c) let set_engagement c = globalize0 (Safe_typing.set_engagement c) let set_indices_matter b = globalize0 (Safe_typing.set_indices_matter b) @@ -206,7 +206,7 @@ let current_dirpath () = let with_global f = let (a, ctx) = f (env ()) (current_dirpath ()) in - push_context_set false ctx; a + push_context_set ~strict:true ctx; a let register_inline c = globalize0 (Safe_typing.register_inline c) let register_inductive c r = globalize0 (Safe_typing.register_inductive c r) diff --git a/library/global.mli b/library/global.mli index db0f87df7e..a38fde41a5 100644 --- a/library/global.mli +++ b/library/global.mli @@ -60,7 +60,7 @@ val add_mind : (** Extra universe constraints *) val add_constraints : Univ.Constraint.t -> unit -val push_context_set : bool -> Univ.ContextSet.t -> unit +val push_context_set : strict:bool -> Univ.ContextSet.t -> unit (** Non-interactive modules and module types *) diff --git a/library/lib.ml b/library/lib.ml index c3c480aee4..9cce9b92ad 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -133,7 +133,10 @@ let cwd () = !lib_state.path_prefix.Nametab.obj_dir let current_mp () = !lib_state.path_prefix.Nametab.obj_mp let current_sections () = Safe_typing.sections_of_safe_env (Global.safe_env()) -let sections_depth () = Section.depth (current_sections()) +let sections_depth () = match current_sections() with + | None -> 0 + | Some sec -> Section.depth sec + let sections_are_opened = Global.sections_are_opened let cwd_except_section () = @@ -240,15 +243,6 @@ let add_discharged_leaf id obj = cache_object (oname,newobj); add_entry oname (Leaf (AtomicObject newobj)) -let add_leaves id objs = - let oname = make_foname id in - let add_obj obj = - add_entry oname (Leaf (AtomicObject obj)); - load_object 1 (oname,obj) - in - List.iter add_obj objs; - oname - let add_anonymous_leaf ?(cache_first = true) obj = let id = anonymous_id () in let oname = make_foname id in @@ -417,14 +411,18 @@ let extract_worklist info = let sections () = Safe_typing.sections_of_safe_env @@ Global.safe_env () +let force_sections () = match Safe_typing.sections_of_safe_env (Global.safe_env()) with + | Some s -> s + | None -> CErrors.user_err Pp.(str "No open section.") + let replacement_context () = - Section.replacement_context (Global.env ()) (sections ()) + Section.replacement_context (Global.env ()) (force_sections ()) let section_segment_of_constant con = - Section.segment_of_constant (Global.env ()) con (sections ()) + Section.segment_of_constant (Global.env ()) con (force_sections ()) let section_segment_of_mutual_inductive kn = - Section.segment_of_inductive (Global.env ()) kn (sections ()) + Section.segment_of_inductive (Global.env ()) kn (force_sections ()) let empty_segment = Section.empty_segment @@ -437,8 +435,10 @@ let section_segment_of_reference = let open GlobRef in function let variable_section_segment_of_reference gr = (section_segment_of_reference gr).Section.abstr_ctx -let is_in_section ref = - Section.is_in_section (Global.env ()) ref (sections ()) +let is_in_section ref = match sections () with + | None -> false + | Some sec -> + Section.is_in_section (Global.env ()) ref sec let section_instance = let open GlobRef in function | VarRef id -> diff --git a/library/lib.mli b/library/lib.mli index a313a62c2e..0d03046dc2 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -65,10 +65,6 @@ val add_anonymous_entry : node -> unit val add_leaf : Id.t -> Libobject.obj -> Libobject.object_name val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit -(** this operation adds all objects with the same name and calls [load_object] - for each of them *) -val add_leaves : Id.t -> Libobject.obj list -> Libobject.object_name - (** {6 ... } *) (** The function [contents] gives access to the current entire segment *) diff --git a/library/libobject.ml b/library/libobject.ml index a632a426fd..c9ea6bcff8 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -82,79 +82,58 @@ and objects = (Names.Id.t * t) list and substitutive_objects = MBId.t list * algebraic_objects -type dynamic_object_declaration = { - dyn_cache_function : object_name * obj -> unit; - dyn_load_function : int -> object_name * obj -> unit; - dyn_open_function : int -> object_name * obj -> unit; - dyn_subst_function : Mod_subst.substitution * obj -> obj; - dyn_classify_function : obj -> obj substitutivity; - dyn_discharge_function : object_name * obj -> obj option; - dyn_rebuild_function : obj -> obj } - let object_tag (Dyn.Dyn (t, _)) = Dyn.repr t -let cache_tab = - (Hashtbl.create 223 : (string,dynamic_object_declaration) Hashtbl.t) +module DynMap = Dyn.Map (struct type 'a t = 'a object_declaration end) + +let cache_tab = ref DynMap.empty let declare_object_full odecl = let na = odecl.object_name in - let (infun, outfun) = Dyn.Easy.make_dyn na in - let cacher (oname,lobj) = odecl.cache_function (oname,outfun lobj) - and loader i (oname,lobj) = odecl.load_function i (oname,outfun lobj) - and opener i (oname,lobj) = odecl.open_function i (oname,outfun lobj) - and substituter (sub,lobj) = infun (odecl.subst_function (sub,outfun lobj)) - and classifier lobj = match odecl.classify_function (outfun lobj) with - | Dispose -> Dispose - | Substitute atomic_obj -> Substitute (infun atomic_obj) - | Keep atomic_obj -> Keep (infun atomic_obj) - | Anticipate (atomic_obj) -> Anticipate (infun atomic_obj) - and discharge (oname,lobj) = - Option.map infun (odecl.discharge_function (oname,outfun lobj)) - and rebuild lobj = infun (odecl.rebuild_function (outfun lobj)) + let tag = Dyn.create na in + let () = cache_tab := DynMap.add tag odecl !cache_tab in + let infun v = Dyn.Dyn (tag, v) in + let outfun v = match Dyn.Easy.prj v tag with + | None -> assert false + | Some v -> v in - Hashtbl.add cache_tab na { dyn_cache_function = cacher; - dyn_load_function = loader; - dyn_open_function = opener; - dyn_subst_function = substituter; - dyn_classify_function = classifier; - dyn_discharge_function = discharge; - dyn_rebuild_function = rebuild }; (infun,outfun) let declare_object odecl = fst (declare_object_full odecl) -let declare_object_full odecl = declare_object_full odecl -(* this function describes how the cache, load, open, and export functions - are triggered. *) - -let apply_dyn_fun f lobj = - let tag = object_tag lobj in - let dodecl = - try Hashtbl.find cache_tab tag - with Not_found -> assert false - in - f dodecl +let cache_object (sp, Dyn.Dyn (tag, v)) = + let decl = DynMap.find tag !cache_tab in + decl.cache_function (sp, v) -let cache_object ((_,lobj) as node) = - apply_dyn_fun (fun d -> d.dyn_cache_function node) lobj +let load_object i (sp, Dyn.Dyn (tag, v)) = + let decl = DynMap.find tag !cache_tab in + decl.load_function i (sp, v) -let load_object i ((_,lobj) as node) = - apply_dyn_fun (fun d -> d.dyn_load_function i node) lobj +let open_object i (sp, Dyn.Dyn (tag, v)) = + let decl = DynMap.find tag !cache_tab in + decl.open_function i (sp, v) -let open_object i ((_,lobj) as node) = - apply_dyn_fun (fun d -> d.dyn_open_function i node) lobj +let subst_object (subs, Dyn.Dyn (tag, v)) = + let decl = DynMap.find tag !cache_tab in + Dyn.Dyn (tag, decl.subst_function (subs, v)) -let subst_object ((_,lobj) as node) = - apply_dyn_fun (fun d -> d.dyn_subst_function node) lobj - -let classify_object lobj = - apply_dyn_fun (fun d -> d.dyn_classify_function lobj) lobj - -let discharge_object ((_,lobj) as node) = - apply_dyn_fun (fun d -> d.dyn_discharge_function node) lobj - -let rebuild_object lobj = - apply_dyn_fun (fun d -> d.dyn_rebuild_function lobj) lobj +let classify_object (Dyn.Dyn (tag, v)) = + let decl = DynMap.find tag !cache_tab in + match decl.classify_function v with + | Dispose -> Dispose + | Substitute v -> Substitute (Dyn.Dyn (tag, v)) + | Keep v -> Keep (Dyn.Dyn (tag, v)) + | Anticipate v -> Anticipate (Dyn.Dyn (tag, v)) + +let discharge_object (sp, Dyn.Dyn (tag, v)) = + let decl = DynMap.find tag !cache_tab in + match decl.discharge_function (sp, v) with + | None -> None + | Some v -> Some (Dyn.Dyn (tag, v)) + +let rebuild_object (Dyn.Dyn (tag, v)) = + let decl = DynMap.find tag !cache_tab in + Dyn.Dyn (tag, decl.rebuild_function v) let dump = Dyn.dump diff --git a/library/summary.ml b/library/summary.ml index d3ae42694a..2afccda847 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -19,57 +19,47 @@ type 'a summary_declaration = { unfreeze_function : 'a -> unit; init_function : unit -> unit } -let sum_mod = ref None -let sum_map = ref String.Map.empty +module DynMap = Dyn.Map(struct type 'a t = 'a summary_declaration end) + +type ml_modules = (string * string option) list + +let sum_mod : ml_modules summary_declaration option ref = ref None +let sum_map = ref DynMap.empty let mangle id = id ^ "-SUMMARY" -let unmangle id = String.(sub id 0 (length id - 8)) - -let ml_modules = "ML-MODULES" - -let internal_declare_summary fadd sumname sdecl = - let infun, outfun, tag = Dyn.Easy.make_dyn_tag (mangle sumname) in - let dyn_freeze ~marshallable = infun (sdecl.freeze_function ~marshallable) - and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum) - and dyn_init = sdecl.init_function in - let ddecl = { - freeze_function = dyn_freeze; - unfreeze_function = dyn_unfreeze; - init_function = dyn_init } - in - fadd sumname ddecl; - tag let declare_ml_modules_summary decl = - let ml_add _ ddecl = sum_mod := Some ddecl in - internal_declare_summary ml_add ml_modules decl + sum_mod := Some decl -let declare_ml_modules_summary decl = - ignore(declare_ml_modules_summary decl) +let check_name sumname = match Dyn.name sumname with +| None -> () +| Some (Dyn.Any tag) -> + anomaly ~label:"Summary.declare_summary" + (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str (Dyn.repr tag) ++ str ".") let declare_summary_tag sumname decl = - let fadd name ddecl = sum_map := String.Map.add name ddecl !sum_map in - let () = if String.Map.mem sumname !sum_map then - anomaly ~label:"Summary.declare_summary" - (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str sumname ++ str ".") - in - internal_declare_summary fadd sumname decl + let () = check_name (mangle sumname) in + let tag = Dyn.create (mangle sumname) in + let () = sum_map := DynMap.add tag decl !sum_map in + tag let declare_summary sumname decl = ignore(declare_summary_tag sumname decl) +module Frozen = Dyn.Map(struct type 'a t = 'a end) + type frozen = { - summaries : Dyn.t String.Map.t; + summaries : Frozen.t; (** Ordered list w.r.t. the first component. *) - ml_module : Dyn.t option; + ml_module : ml_modules option; (** Special handling of the ml_module summary. *) } -let empty_frozen = { summaries = String.Map.empty; ml_module = None } +let empty_frozen = { summaries = Frozen.empty; ml_module = None } let freeze_summaries ~marshallable : frozen = - let smap decl = decl.freeze_function ~marshallable in - { summaries = String.Map.map smap !sum_map; + let fold (DynMap.Any (tag, decl)) accu = Frozen.add tag (decl.freeze_function ~marshallable) accu in + { summaries = DynMap.fold fold !sum_map Frozen.empty; ml_module = Option.map (fun decl -> decl.freeze_function ~marshallable) !sum_mod; } @@ -87,23 +77,23 @@ let unfreeze_summaries ?(partial=false) { summaries; ml_module } = (* The unfreezing of [ml_modules_summary] has to be anticipated since it * may modify the content of [summaries] by loading new ML modules *) begin match !sum_mod with - | None -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".") - | Some decl -> Option.iter (fun state -> decl.unfreeze_function state) ml_module + | None -> anomaly (str "Undeclared ML-MODULES summary.") + | Some decl -> Option.iter decl.unfreeze_function ml_module end; (* We must be independent on the order of the map! *) - let ufz name decl = - try decl.unfreeze_function String.Map.(find name summaries) + let ufz (DynMap.Any (name, decl)) = + try decl.unfreeze_function Frozen.(find name summaries) with Not_found -> if not partial then begin - warn_summary_out_of_scope name; + warn_summary_out_of_scope (Dyn.repr name); decl.init_function () end; in (* String.Map.iter unfreeze_single !sum_map *) - String.Map.iter ufz !sum_map + DynMap.iter ufz !sum_map let init_summaries () = - String.Map.iter (fun _ decl -> decl.init_function ()) !sum_map + DynMap.iter (fun (DynMap.Any (_, decl)) -> decl.init_function ()) !sum_map (** For global tables registered statically before the end of coqtop launch, the following empty [init_function] could be used. *) @@ -112,18 +102,15 @@ let nop () = () (** Summary projection *) let project_from_summary { summaries } tag = - let id = unmangle (Dyn.repr tag) in - let state = String.Map.find id summaries in - Option.get (Dyn.Easy.prj state tag) + Frozen.find tag summaries let modify_summary st tag v = - let id = unmangle (Dyn.repr tag) in - let summaries = String.Map.set id (Dyn.Easy.inj v tag) st.summaries in + let () = assert (Frozen.mem tag st.summaries) in + let summaries = Frozen.add tag v st.summaries in {st with summaries} let remove_from_summary st tag = - let id = unmangle (Dyn.repr tag) in - let summaries = String.Map.remove id st.summaries in + let summaries = Frozen.remove tag st.summaries in {st with summaries} (** All-in-one reference declaration + registration *) @@ -140,26 +127,32 @@ let ref ?freeze ~name x = fst @@ ref_tag ?freeze ~name x module Local = struct -type 'a local_ref = ('a CEphemeron.key * string) ref +type 'a local_ref = ('a CEphemeron.key * 'a Dyn.tag) ref -let (:=) r v = r := (CEphemeron.create v, snd !r) +let set r v = r := (CEphemeron.create v, snd !r) -let (!) r = +let get r = let key, name = !r in try CEphemeron.get key with CEphemeron.InvalidKey -> - let { init_function } = String.Map.find name !sum_map in + let { init_function } = DynMap.find name !sum_map in init_function (); CEphemeron.get (fst !r) let ref ?(freeze=fun x -> x) ~name init = - let r = pervasives_ref (CEphemeron.create init, name) in - declare_summary name - { freeze_function = (fun ~marshallable -> freeze !r); - unfreeze_function = ((:=) r); - init_function = (fun () -> r := init) }; + let () = check_name (mangle name) in + let tag : 'a Dyn.tag = Dyn.create (mangle name) in + let r = pervasives_ref (CEphemeron.create init, tag) in + let () = sum_map := DynMap.add tag + { freeze_function = (fun ~marshallable -> freeze (get r)); + unfreeze_function = (set r); + init_function = (fun () -> set r init) } !sum_map + in r +let (!) = get +let (:=) = set + end let dump = Dyn.dump diff --git a/library/summary.mli b/library/summary.mli index 3a122edf3d..f4550b38f9 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -63,7 +63,7 @@ end because its unfreeze may load ML code and hence add summary entries. Thus is has to be recognizable, and handled properly. *) -val declare_ml_modules_summary : 'a summary_declaration -> unit +val declare_ml_modules_summary : (string * string option) list summary_declaration -> unit (** For global tables registered statically before the end of coqtop launch, the following empty [init_function] could be used. *) diff --git a/parsing/extend.ml b/parsing/extend.ml index ed6ebe5aed..dcdaa25c33 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -54,7 +54,7 @@ type constr_prod_entry_key = | ETProdBigint (* Parsed as an (unbounded) integer *) | ETProdConstr of Constrexpr.notation_entry * (production_level * production_position) (* Parsed as constr or pattern, or a subentry of those *) | ETProdPattern of int (* Parsed as pattern as a binder (as subpart of a constr) *) - | ETProdConstrList of (production_level * production_position) * string Tok.p list (* Parsed as non-empty list of constr *) + | ETProdConstrList of Constrexpr.notation_entry * (production_level * production_position) * string Tok.p list (* Parsed as non-empty list of constr, or subentries of those *) | ETProdBinderList of binder_entry_kind (* Parsed as non-empty list of local binders *) (** {5 AST for user-provided entries} *) diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v index 3ad5bc9f2d..4a603f2c52 100644 --- a/plugins/btauto/Algebra.v +++ b/plugins/btauto/Algebra.v @@ -1,4 +1,4 @@ -Require Import Bool PArith DecidableClass Ring Omega Lia. +Require Import Bool PArith DecidableClass Ring Lia. Ltac bool := repeat match goal with @@ -359,8 +359,8 @@ intros k p var1 var2 Hvar Hv; revert var1 var2 Hvar. induction Hv; intros var1 var2 Hvar; simpl; [now auto|]. rewrite Hvar; [|now auto]; erewrite (IHHv1 var1 var2). + erewrite (IHHv2 var1 var2); [ring|]. - intros; apply Hvar; zify; omega. - + intros; apply Hvar; zify; omega. + intros; apply Hvar; lia. + + intros; apply Hvar; lia. Qed. End Evaluation. @@ -424,7 +424,7 @@ match goal with apply Pos.max_case_strong; intros; lia | [ |- (?z < Pos.max ?x ?y)%positive ] => apply Pos.max_case_strong; intros; lia -| _ => zify; omega +| _ => lia end : core. Hint Resolve Pos.le_max_r Pos.le_max_l : core. @@ -472,8 +472,8 @@ intros k i p H; induction H; simpl poly_mul_mon; case_decide; intuition. - match goal with [ H : null ?p |- _ ] => solve[inversion H] end. + apply (valid_le_compat k); auto; constructor; intuition. - assert (X := poly_mul_mon_null_compat); intuition eauto. - - cutrewrite <- (Pos.max (Pos.succ i) i0 = i0); intuition. - - cutrewrite <- (Pos.max (Pos.succ i) (Pos.succ i0) = Pos.succ i0); intuition. + - enough (Pos.max (Pos.succ i) i0 = i0) as <-; intuition. + - enough (Pos.max (Pos.succ i) (Pos.succ i0) = Pos.succ i0) as <-; intuition. Qed. Lemma poly_mul_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr -> @@ -488,7 +488,7 @@ induction Hl; intros kr pr Hr; simpl. { apply (valid_le_compat (Pos.max i kr)); auto. } { apply poly_add_valid_compat; auto. now apply poly_mul_mon_valid_compat; intuition. } - - repeat apply Pos.max_case_strong; zify; omega. + - repeat apply Pos.max_case_strong; lia. Qed. (* Compatibility of linearity wrt to linear operations *) @@ -497,7 +497,7 @@ Lemma poly_add_linear_compat : forall kl kr pl pr, linear kl pl -> linear kr pr linear (Pos.max kl kr) (poly_add pl pr). Proof. intros kl kr pl pr Hl; revert kr pr; induction Hl; intros kr pr Hr; simpl. -+ apply (linear_le_compat kr); [|apply Pos.max_case_strong; zify; omega]. ++ apply (linear_le_compat kr); [|apply Pos.max_case_strong; lia]. now induction Hr; constructor; auto. + apply (linear_le_compat (Pos.max kr (Pos.succ i))); [|now auto]. induction Hr; simpl. @@ -527,17 +527,17 @@ inversion Hv; case_decide; subst. destruct (list_nth k var false); ring_simplify; [|now auto]. rewrite <- (andb_true_l (eval var p1)), <- (andb_true_l (eval var p3)). rewrite <- IHp2; auto; rewrite <- IHp1; [ring|]. - apply (valid_le_compat k); [now auto|zify; omega]. + apply (valid_le_compat k); [now auto|lia]. + remember (list_nth k var false) as b; destruct b; ring_simplify; [|now auto]. case_decide; simpl. - rewrite <- (IHp2 p2); [inversion H|now auto]; simpl. replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring); rewrite <- (IHp1 k). { rewrite <- Heqb; ring. } - { apply (valid_le_compat p2); [auto|zify; omega]. } + { apply (valid_le_compat p2); [auto|lia]. } - rewrite (IHp2 p2); [|now auto]. replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring). rewrite <- (IHp1 k); [rewrite <- Heqb; ring|]. - apply (valid_le_compat p2); [auto|zify; omega]. + apply (valid_le_compat p2); [auto|lia]. Qed. (* Reduction preserves evaluation by boolean assignations *) @@ -555,10 +555,10 @@ Lemma reduce_aux_le_compat : forall k l p, valid k p -> (k <= l)%positive -> reduce_aux l p = reduce_aux k p. Proof. intros k l p; revert k l; induction p; intros k l H Hle; simpl; auto. -inversion H; subst; repeat case_decide; subst; try (exfalso; zify; omega). -+ apply IHp1; [|now auto]; eapply valid_le_compat; [eauto|zify; omega]. +inversion H; subst; repeat case_decide; subst; try lia. ++ apply IHp1; [|now auto]; eapply valid_le_compat; [eauto|lia]. + f_equal; apply IHp1; auto. - now eapply valid_le_compat; [eauto|zify; omega]. + now eapply valid_le_compat; [eauto|lia]. Qed. (* Reduce projects valid polynomials into linear ones *) @@ -569,13 +569,13 @@ intros i p; revert i; induction p; intros i Hp; simpl. + constructor. + inversion Hp; subst; case_decide; subst. - rewrite <- (Pos.max_id i) at 1; apply poly_add_linear_compat. - { apply IHp1; eapply valid_le_compat; [eassumption|zify; omega]. } + { apply IHp1; eapply valid_le_compat; [eassumption|lia]. } { intuition. } - case_decide. - { apply IHp1; eapply valid_le_compat; [eauto|zify; omega]. } - { constructor; try (zify; omega); auto. - erewrite (reduce_aux_le_compat p2); [|assumption|zify; omega]. - apply IHp1; eapply valid_le_compat; [eauto|]; zify; omega. } + { apply IHp1; eapply valid_le_compat; [eauto|lia]. } + { constructor; try lia; auto. + erewrite (reduce_aux_le_compat p2); [|assumption|lia]. + apply IHp1; eapply valid_le_compat; [eauto|]; lia. } Qed. Lemma linear_reduce : forall k p, valid k p -> linear k (reduce p). @@ -583,7 +583,7 @@ Proof. intros k p H; induction H; simpl. + now constructor. + case_decide. - - eapply linear_le_compat; [eauto|zify; omega]. + - eapply linear_le_compat; [eauto|lia]. - constructor; auto. apply linear_reduce_aux; auto. Qed. diff --git a/plugins/btauto/Reflect.v b/plugins/btauto/Reflect.v index 98f5ab067a..867fe69550 100644 --- a/plugins/btauto/Reflect.v +++ b/plugins/btauto/Reflect.v @@ -1,4 +1,4 @@ -Require Import Bool DecidableClass Algebra Ring PArith Omega. +Require Import Bool DecidableClass Algebra Ring PArith Lia. Section Bool. @@ -80,7 +80,7 @@ Qed. Hint Extern 5 => change 0 with (min 0 0) : core. Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat : core. Local Hint Constructors valid : core. -Hint Extern 5 => zify; omega : core. +Hint Extern 5 => lia : core. (* Compatibility with validity *) @@ -203,7 +203,7 @@ intros A n; induction n using Pos.peano_rect; intros i x def Hd; + unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def). induction i using Pos.peano_case. - rewrite list_nth_base; reflexivity. - - rewrite list_nth_succ; apply IHn; zify; omega. + - rewrite list_nth_succ; apply IHn; lia. Qed. Lemma make_last_nth_2 : forall A n x def, list_nth n (@make_last A n x def) def = x. @@ -226,7 +226,7 @@ intros var; induction var; intros i j x Hd; simpl. - rewrite Pos.peano_rect_succ. induction i using Pos.peano_rect. { rewrite 2list_nth_base; reflexivity. } - { rewrite 2list_nth_succ; apply IHvar; zify; omega. } + { rewrite 2list_nth_succ; apply IHvar; lia. } Qed. Lemma list_replace_nth_2 : forall var i x, list_nth i (list_replace var i x) false = x. @@ -251,10 +251,10 @@ intros k p Hl Hp; induction Hl; simpl. assert (Hrw : b = true); [|rewrite Hrw; reflexivity] end. erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto]. - now intros j Hd; apply list_replace_nth_1; zify; omega. + now intros j Hd; apply list_replace_nth_1; lia. rewrite list_replace_nth_2, xorb_false_r. erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto]. - now intros j Hd; apply list_replace_nth_1; zify; omega. + now intros j Hd; apply list_replace_nth_1; lia. Qed. (* This should be better when using the [vm_compute] tactic instead of plain reflexivity. *) diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 2bc79d45d4..8946587a02 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -47,20 +47,6 @@ let ()= declare_int_option gdopt -let ()= - let congruence_depth=ref 100 in - let gdopt= - { optdepr=true; (* noop *) - optname="Congruence Depth"; - optkey=["Congruence";"Depth"]; - optread=(fun ()->Some !congruence_depth); - optwrite= - (function - None->congruence_depth:=0 - | Some i->congruence_depth:=(max i 0))} - in - declare_int_option gdopt - let default_intuition_tac = let tac _ _ = Auto.h_auto None [] None in let name = { Tacexpr.mltac_plugin = "ground_plugin"; mltac_tactic = "auto_with"; } in diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 9ff05c33e4..7d84ee6851 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -231,7 +231,7 @@ let print_cmap map= let print_entry c l s= let env = Global.env () in let sigma = Evd.from_env env in - let xc=Constrextern.extern_constr false env sigma (EConstr.of_constr c) in + let xc=Constrextern.extern_constr env sigma (EConstr.of_constr c) in str "| " ++ prlist Printer.pr_global l ++ str " : " ++ diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 6add56dd5b..58efee1518 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -142,7 +142,7 @@ let recompute_binder_list fixpoint_exprl = with rec_order = ComFixpoint.adjust_rec_order ~structonly:false fix.binders fix.rec_order }) fixpoint_exprl in let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl in let constr_expr_typel = - with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in + with_full_print (List.map (fun c -> Constrextern.extern_constr (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in let fixpoint_exprl_with_new_bl = List.map2 (fun ({ Vernacexpr.binders } as fp) fix_typ -> let binders, rtype = rebuild_bl [] binders fix_typ in @@ -1902,8 +1902,8 @@ let make_graph (f_ref : GlobRef.t) = let env = Global.env () in let extern_body,extern_type = with_full_print (fun () -> - (Constrextern.extern_constr false env sigma (EConstr.of_constr body), - Constrextern.extern_type false env sigma + (Constrextern.extern_constr env sigma (EConstr.of_constr body), + Constrextern.extern_type env sigma (EConstr.of_constr (*FIXME*) c_body.Declarations.const_type) ) ) diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index a9e5271e81..6c63a891e8 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -203,10 +203,6 @@ TACTIC EXTEND dependent_rewrite -> { rewriteInHyp b c id } END -(** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to - "replace u with t" or "enough (t=u) as <-" and - "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) - TACTIC EXTEND cut_rewrite | [ "cutrewrite" orient(b) constr(eqn) ] -> { cutRewriteInConcl b eqn } | [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index d82eadcfc7..f0d6258cd1 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -135,7 +135,7 @@ let mk_cofix_tac (loc,id,bl,ann,ty) = ~hdr:"Constr:mk_cofix_tac" (Pp.str"Annotation forbidden in cofix expression.")) ann in let bl = List.map (fun (nal,bk,t) -> CLocalAssum (nal,bk,t)) bl in - (id,CAst.make ~loc @@ CProdN(bl,ty)) + (id,if bl = [] then ty else CAst.make ~loc @@ CProdN(bl,ty)) (* Functions overloaded by quotifier *) let destruction_arg_of_constr (c,lbind as clbind) = match lbind with diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 6df068883c..7843faaef3 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -971,7 +971,7 @@ let pr_goal_selector ~toplevel s = | TacTime (s,t) -> hov 1 ( keyword "time" - ++ pr_opt str s ++ spc () + ++ pr_opt qstring s ++ spc () ++ pr_tac (ltactical,E) t), ltactical | TacRepeat t -> @@ -1273,7 +1273,7 @@ let pr_intro_pattern_env p = Genprint.TopPrinterNeedsContext (fun env sigma -> Miscprint.pr_intro_pattern print_constr p) let pr_red_expr_env r = Genprint.TopPrinterNeedsContext (fun env sigma -> - pr_red_expr env sigma (pr_econstr_env, pr_leconstr_env, + pr_red_expr env sigma ((fun e -> pr_econstr_env e), (fun e -> pr_leconstr_env e), pr_evaluable_reference_env env, pr_constr_pattern_env) r) let pr_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma -> diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 5618fd7bc3..98d14f3d33 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -924,10 +924,10 @@ let reset_env env = let env' = Global.env_of_context (Environ.named_context_val env) in Environ.push_rel_context (Environ.rel_context env) env' -let fold_match ?(force=false) env sigma c = +let fold_match env sigma c = let (ci, p, c, brs) = destCase sigma c in let cty = Retyping.get_type_of env sigma c in - let dep, pred, exists, (sk,eff) = + let dep, pred, exists, sk = let env', ctx, body = let ctx, pred = decompose_lam_assum sigma p in let env' = push_rel_context ctx env in @@ -954,8 +954,8 @@ let fold_match ?(force=false) env sigma c = else case_scheme_kind_from_type) in let exists = Ind_tables.check_scheme sk ci.ci_ind in - if exists || force then - dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind + if exists then + dep, pred, exists, Ind_tables.lookup_scheme sk ci.ci_ind else raise Not_found in let app = @@ -964,7 +964,7 @@ let fold_match ?(force=false) env sigma c = let meths = List.map (fun br -> br) (Array.to_list brs) in applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) in - sk, (if exists then env else reset_env env), app, eff + sk, (if exists then env else reset_env env), app let unfold_match env sigma sk app = match EConstr.kind sigma app with @@ -1222,7 +1222,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = else match try Some (fold_match env (goalevars evars) t) with Not_found -> None with | None -> state, c' - | Some (cst, _, t', eff (*FIXME*)) -> + | Some (cst, _, t') -> let state, res = aux { state ; env ; unfresh ; term1 = t' ; ty1 = ty ; cstr = (prop,cstr) ; evars } in @@ -1930,7 +1930,7 @@ let build_morphism_signature env sigma m = let evd = solve_constraints env !evd in let evd = Evd.minimize_universes evd in let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in - Pretyping.check_evars env (Evd.from_env env) evd (EConstr.of_constr m); + Pretyping.check_evars env evd (EConstr.of_constr m); Evd.evar_universe_context evd, m let default_morphism sign m = @@ -1944,12 +1944,7 @@ let default_morphism sign m = let evars, mor = resolve_one_typeclass env (goalevars evars) morph in mor, proper_projection env sigma mor morph -let warn_add_setoid_deprecated = - CWarnings.create ~name:"add-setoid" ~category:"deprecated" (fun () -> - Pp.(str "Add Setoid is deprecated, please use Add Parametric Relation.")) - let add_setoid atts binders a aeq t n = - warn_add_setoid_deprecated ?loc:a.CAst.loc (); init_setoid (); let () = declare_instance_refl atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in let () = declare_instance_sym atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in @@ -1966,10 +1961,6 @@ let make_tactic name = let tacqid = Libnames.qualid_of_string name in TacArg (CAst.make @@ (TacCall (CAst.make (tacqid, [])))) -let warn_add_morphism_deprecated = - CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> - Pp.(str "Add Morphism f : id is deprecated, please use Add Morphism f with signature (...) as id")) - let add_morphism_as_parameter atts m n : unit = init_setoid (); let instance_id = add_suffix n "_Proper" in @@ -1986,7 +1977,6 @@ let add_morphism_as_parameter atts m n : unit = declare_projection n instance_id (GlobRef.ConstRef cst) let add_morphism_interactive atts m n : Lemmas.t = - warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); let instance_id = add_suffix n "_Proper" in let env = Global.env () in diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 9633c9bd77..98aa649b62 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -212,12 +212,11 @@ let constr_of_id env id = (** Generic arguments : table of interpretation functions *) -(* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *) let push_trace call ist = if is_traced () then match TacStore.get ist.extra f_trace with - | None -> Proofview.tclUNIT [call] - | Some trace -> Proofview.tclUNIT (call :: trace) - else Proofview.tclUNIT [] + | None -> [call] + | Some trace -> (call :: trace) + else [] let propagate_trace ist loc id v = if has_type v (topwit wit_tacvalue) then @@ -225,7 +224,7 @@ let propagate_trace ist loc id v = match tacv with | VFun (appl,_,lfun,it,b) -> let t = if List.is_empty it then b else TacFun (it,b) in - push_trace(loc,LtacVarCall (id,t)) ist >>= fun trace -> + let trace = push_trace(loc,LtacVarCall (id,t)) ist in let ans = VFun (appl,trace,lfun,it,b) in Proofview.tclUNIT (of_tacvalue ans) | _ -> Proofview.tclUNIT v @@ -536,16 +535,7 @@ let interp_gen kind ist pattern_mode flags env sigma c = ltac_idents = constrvars.idents; ltac_genargs = ist.lfun; } in - (* Jason Gross: To avoid unnecessary modifications to tacinterp, as - suggested by Arnaud Spiwack, we run push_trace immediately. We do - this with the kludge of an empty proofview, and rely on the - invariant that running the tactic returned by push_trace does - not modify sigma. *) - let (_, dummy_proofview) = Proofview.init sigma [] in - - (* Again this is called at times with no open proof! *) - let name, poly = Id.of_string "tacinterp", ist.poly in - let (trace,_,_,_) = Proofview.apply ~name ~poly env (push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist) dummy_proofview in + let trace = push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist in let (evd,c) = catch_error trace (understand_ltac flags env sigma vars kind) term in @@ -1067,7 +1057,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti and eval_tactic ist tac : unit Proofview.tactic = match tac with | TacAtom {loc;v=t} -> let call = LtacAtomCall t in - push_trace(loc,call) ist >>= fun trace -> + let trace = push_trace(loc,call) ist in Profile_ltac.do_profile "eval_tactic:2" trace (catch_error_tac trace (interp_atomic ist t)) | TacFun _ | TacLetIn _ | TacMatchGoal _ | TacMatch _ -> interp_tactic ist tac @@ -1100,7 +1090,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with end | TacAbstract (t,ido) -> let call = LtacMLCall tac in - push_trace(None,call) ist >>= fun trace -> + let trace = push_trace(None,call) ist in Profile_ltac.do_profile "eval_tactic:TacAbstract" trace (catch_error_tac trace begin Proofview.Goal.enter begin fun gl -> Abstract.tclABSTRACT @@ -1153,7 +1143,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let tac l = let addvar x v accu = Id.Map.add x v accu in let lfun = List.fold_right2 addvar alias.Tacenv.alias_args l ist.lfun in - Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> + let trace = push_trace (loc,LtacNotationCall s) ist in let ist = { lfun ; poly @@ -1179,7 +1169,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Ftactic.run tac (fun () -> Proofview.tclUNIT ()) | TacML {loc; v=(opn,l)} -> - push_trace (Loc.tag ?loc @@ LtacMLCall tac) ist >>= fun trace -> + let trace = push_trace (Loc.tag ?loc @@ LtacMLCall tac) ist in let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in let tac = Tacenv.interp_ml_tactic opn in let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in @@ -1214,7 +1204,7 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = let ids = extract_ids [] ist.lfun Id.Set.empty in let loc_info = (Option.default loc loc',LtacNameCall r) in let extra = TacStore.set ist.extra f_avoid_ids ids in - push_trace loc_info ist >>= fun trace -> + let trace = push_trace loc_info ist in let extra = TacStore.set extra f_trace trace in let ist = { lfun = Id.Map.empty; poly; extra } in let appl = GlbAppl[r,[]] in diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index 55a93eade7..e53800d07d 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -23,28 +23,13 @@ Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". -Ltac zchange checker := +Ltac zchecker := intros __wit __varmap __ff ; - change (@Tauto.eval_bf _ (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (checker __ff __wit). - -Ltac zchecker_no_abstract checker := - zchange checker ; vm_compute ; reflexivity. - -Ltac zchecker_abstract checker := - abstract (zchange checker ; vm_cast_no_check (eq_refl true)). - -Ltac zchecker := zchecker_no_abstract ZTautoChecker_sound. - -(*Ltac zchecker_ext := zchecker_no_abstract ZTautoCheckerExt_sound.*) - -Ltac zchecker_ext := - intros __wit __varmap __ff ; - exact (ZTautoCheckerExt_sound __ff __wit - (@eq_refl bool true <: @eq bool (ZTautoCheckerExt __ff __wit) true) + exact (ZTautoChecker_sound __ff __wit + (@eq_refl bool true <: @eq bool (ZTautoChecker __ff __wit) true) (@find Z Z0 __varmap)). -Ltac lia := PreOmega.zify; xlia zchecker_ext. +Ltac lia := PreOmega.zify; xlia zchecker. Ltac nia := PreOmega.zify; xnlia zchecker. diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 80e0f3a536..0e8c09ef1b 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -56,7 +56,7 @@ Extract Constant Rinv => "fun x -> 1 / x". (*Extraction "micromega.ml" Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula Tauto.abst_form - ZMicromega.cnfZ ZMicromega.bound_problem_fr ZMicromega.Zeval_const QMicromega.cnfQ + ZMicromega.cnfZ ZMicromega.Zeval_const QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 6c1852acbf..0f7a02c2c9 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -17,12 +17,12 @@ Require Import OrderedRing. Require Import RingMicromega. Require Import Refl. -Require Import Raxioms Rfunctions RIneq Rpow_def DiscrR. +Require Import Raxioms Rfunctions RIneq Rpow_def. Require Import QArith. Require Import Qfield. Require Import Qreals. Require Import DeclConstant. -Require Import Lia. +Require Import Ztac. Require Setoid. (*Declare ML Module "micromega_plugin".*) @@ -334,15 +334,16 @@ Proof. apply Qeq_bool_eq in C2. rewrite C2. simpl. - rewrite Qpower0 by lia. + rewrite Qpower0. apply Q2R_0. + intro ; subst ; slia C1 C1. + rewrite Q2RpowerRZ. rewrite IHc. reflexivity. rewrite andb_false_iff in C. destruct C. simpl. apply Z.ltb_ge in H. - lia. + right ; normZ. slia H H0. left ; apply Qeq_bool_neq; auto. + simpl. rewrite <- IHc. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index c1edf579cf..aa8876357a 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -856,7 +856,7 @@ Proof. simpl. tauto. + - rewrite <- eval_cnf_cons_iff with (1:= fun env (term:Formula Z) => True) . + rewrite <- eval_cnf_cons_iff. simpl. unfold eval_tt. simpl. rewrite IHl. @@ -940,7 +940,7 @@ Proof. destruct (check_inconsistent f) eqn:U. - destruct f as [e op]. assert (US := check_inconsistent_sound _ _ U env). - rewrite eval_cnf_ff with (1:= eval_nformula). + rewrite eval_cnf_ff. tauto. - intros. rewrite cnf_of_list_correct. now apply xnormalise_correct. @@ -956,7 +956,7 @@ Proof. - destruct f as [e o]. assert (US := check_inconsistent_sound _ _ U env). - rewrite eval_cnf_tt with (1:= eval_nformula). + rewrite eval_cnf_tt. tauto. - rewrite cnf_of_list_correct. apply xnegate_correct. diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 02dd29ef14..a155207e2e 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -938,8 +938,6 @@ Section S. Qed. - Variable eval : Env -> Term -> Prop. - Variable eval' : Env -> Term' -> Prop. Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). @@ -1202,7 +1200,7 @@ Section S. Qed. - + Variable eval : Env -> Term -> Prop. Variable normalise_correct : forall env t tg, eval_cnf env (normalise t tg) -> eval env t. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index d709fdda14..9bedb47371 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -18,11 +18,11 @@ Require Import List. Require Import Bool. Require Import OrderedRing. Require Import RingMicromega. -Require FSetPositive FSetEqProperties. Require Import ZCoeff. Require Import Refl. Require Import ZArith_base. Require Import ZArithRing. +Require Import Ztac. Require PreOmega. (*Declare ML Module "micromega_plugin".*) Local Open Scope Z_scope. @@ -30,7 +30,7 @@ Local Open Scope Z_scope. Ltac flatten_bool := repeat match goal with [ id : (_ && _)%bool = true |- _ ] => destruct (andb_prop _ _ id); clear id - | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id + | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id end. Ltac inv H := inversion H ; try subst ; clear H. @@ -186,6 +186,7 @@ match o with | OpGt => Z.gt end. + Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= let (lhs, op, rhs) := f in (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs). @@ -193,10 +194,13 @@ Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= Definition Zeval_formula' := eval_formula Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt (fun x => x) (fun x => x) (pow_N 1 Z.mul). -Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f. +Lemma Zeval_formula_compat' : forall env f, Zeval_formula env f <-> Zeval_formula' env f. Proof. - destruct f ; simpl. - rewrite Zeval_expr_compat. rewrite Zeval_expr_compat. + intros. + unfold Zeval_formula. + destruct f. + repeat rewrite Zeval_expr_compat. + unfold Zeval_formula' ; simpl. unfold eval_expr. generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env Flhs). @@ -308,10 +312,10 @@ Definition xnnormalise (t : Formula Z) : NFormula Z := Lemma xnnormalise_correct : forall env f, - eval_nformula env (xnnormalise f) <-> Zeval_formula env f. + eval_nformula env (xnnormalise f) <-> Zeval_formula env f. Proof. intros. - rewrite Zeval_formula_compat. + rewrite Zeval_formula_compat'. unfold xnnormalise. destruct f as [lhs o rhs]. destruct o eqn:O ; cbn ; rewrite ?eval_pol_sub; @@ -418,7 +422,7 @@ Proof. specialize (Zunsat_sound _ EQ env). tauto. + - rewrite <- eval_cnf_cons_iff with (1:= fun env (term:Formula Z) => True) . + rewrite <- eval_cnf_cons_iff. rewrite IHf. simpl. unfold E at 2. @@ -439,7 +443,7 @@ Proof. generalize (xnnormalise t) as f;intro. destruct (Zunsat f) eqn:U. - assert (US := Zunsat_sound _ U env). - rewrite eval_cnf_ff with (1:= eval_nformula). + rewrite eval_cnf_ff. tauto. - rewrite cnf_of_list_correct. apply xnormalise_correct. @@ -474,7 +478,7 @@ Proof. - tauto. Qed. -Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t. +Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t. Proof. intros. rewrite <- xnnormalise_correct. @@ -482,13 +486,13 @@ Proof. generalize (xnnormalise t) as f;intro. destruct (Zunsat f) eqn:U. - assert (US := Zunsat_sound _ U env). - rewrite eval_cnf_tt with (1:= eval_nformula). + rewrite eval_cnf_tt. tauto. - rewrite cnf_of_list_correct. apply xnegate_correct. Qed. -Definition cnfZ (Annot TX AF : Type) (f : TFormula (Formula Z) Annot TX AF) := +Definition cnfZ (Annot: Type) (TX : Type) (AF : Type) (f : TFormula (Formula Z) Annot TX AF) := rxcnf Zunsat Zdeduce normalise negate true f. Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool := @@ -555,7 +559,8 @@ Inductive ZArithProof := | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof | EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof -(*| ExProof : positive -> positive -> positive -> ZArithProof ExProof z t x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) +| ExProof : positive -> ZArithProof -> ZArithProof +(*ExProof x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) . (*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof.*) @@ -826,187 +831,171 @@ Definition valid_cut_sign (op:Op1) := | _ => false end. -Module Vars. - Import FSetPositive. - Include PositiveSet. - Module Facts := FSetEqProperties.EqProperties(PositiveSet). +Definition bound_var (v : positive) : Formula Z := + Build_Formula (PEX v) OpGe (PEc 0). - Lemma mem_union_l : forall x s s', - mem x s = true -> - mem x (union s s') = true. - Proof. - intros. - rewrite Facts.union_mem. - rewrite H. reflexivity. - Qed. +Definition mk_eq_pos (x : positive) (y:positive) (t : positive) : Formula Z := + Build_Formula (PEX x) OpEq (PEsub (PEX y) (PEX t)). - Lemma mem_union_r : forall x s s', - mem x s' = true -> - mem x (union s s') = true. - Proof. - intros. - rewrite Facts.union_mem. - rewrite H. rewrite orb_comm. reflexivity. - Qed. - Lemma mem_singleton : forall p, - mem p (singleton p) = true. - Proof. - apply Facts.singleton_mem_1. - Qed. +Fixpoint vars (jmp : positive) (p : Pol Z) : list positive := + match p with + | Pc c => nil + | Pinj j p => vars (Pos.add j jmp) p + | PX p j q => jmp::(vars jmp p)++vars (Pos.succ jmp) q + end. - Lemma mem_elements : forall x v, - mem x v = true <-> List.In x (PositiveSet.elements v). - Proof. - intros. - rewrite Facts.MP.FM.elements_b. - rewrite existsb_exists. - unfold Facts.MP.FM.eqb. - split ; intros. - - destruct H as (x' & IN & EQ). - destruct (PositiveSet.E.eq_dec x x') ; try congruence. - subst ; auto. - - exists x. - split ; auto. - destruct (PositiveSet.E.eq_dec x x) ; congruence. - Qed. +Fixpoint max_var (jmp : positive) (p : Pol Z) : positive := + match p with + | Pc _ => jmp + | Pinj j p => max_var (Pos.add j jmp) p + | PX p j q => Pos.max (max_var jmp p) (max_var (Pos.succ jmp) q) + end. - Definition max_element (vars : t) := - fold Pos.max vars xH. +Lemma pos_le_add : forall y x, + (x <= y + x)%positive. +Proof. + intros. + assert ((Z.pos x) <= Z.pos (x + y))%Z. + rewrite <- (Z.add_0_r (Zpos x)). + rewrite <- Pos2Z.add_pos_pos. + apply Z.add_le_mono_l. + compute. congruence. + rewrite Pos.add_comm in H. + apply H. +Qed. - Lemma max_element_max : - forall x vars, mem x vars = true -> Pos.le x (max_element vars). - Proof. - unfold max_element. - intros. - rewrite mem_elements in H. - rewrite PositiveSet.fold_1. - set (F := (fun (a : positive) (e : PositiveSet.elt) => Pos.max e a)). - revert H. - assert (((x <= 1 -> x <= fold_left F (PositiveSet.elements vars) 1) - /\ - (List.In x (PositiveSet.elements vars) -> - x <= fold_left F (PositiveSet.elements vars) 1))%positive). - { - revert x. - generalize xH as acc. - induction (PositiveSet.elements vars). - - simpl. tauto. - - simpl. - intros. - destruct (IHl (F acc a) x). - split ; intros. - apply H. - unfold F. - rewrite Pos.max_le_iff. - tauto. - destruct H1 ; subst. - apply H. - unfold F. - rewrite Pos.max_le_iff. - simpl. - left. + +Lemma max_var_le : forall p v, + (v <= max_var v p)%positive. +Proof. + induction p; simpl. + - intros. + apply Pos.le_refl. + - intros. + specialize (IHp (p+v)%positive). + eapply Pos.le_trans ; eauto. + assert (xH + v <= p + v)%positive. + { apply Pos.add_le_mono. + apply Pos.le_1_l. apply Pos.le_refl. - tauto. } - tauto. - Qed. + eapply Pos.le_trans ; eauto. + apply pos_le_add. + - intros. + apply Pos.max_case_strong;intros ; auto. + specialize (IHp2 (Pos.succ v)%positive). + eapply Pos.le_trans ; eauto. +Qed. + +Lemma max_var_correct : forall p j v, + In v (vars j p) -> Pos.le v (max_var j p). +Proof. + induction p; simpl. + - tauto. + - auto. + - intros. + rewrite in_app_iff in H. + destruct H as [H |[ H | H]]. + + subst. + apply Pos.max_case_strong;intros ; auto. + apply max_var_le. + eapply Pos.le_trans ; eauto. + apply max_var_le. + + apply Pos.max_case_strong;intros ; auto. + eapply Pos.le_trans ; eauto. + + apply Pos.max_case_strong;intros ; auto. + eapply Pos.le_trans ; eauto. +Qed. + +Definition max_var_nformulae (l : list (NFormula Z)) := + List.fold_left (fun acc f => Pos.max acc (max_var xH (fst f))) l xH. - Definition is_subset (v1 v2 : t) := - forall x, mem x v1 = true -> mem x v2 = true. +Section MaxVar. - Lemma is_subset_union_l : forall v1 v2, - is_subset v1 (union v1 v2). + Definition F (acc : positive) (f : Pol Z * Op1) := Pos.max acc (max_var 1 (fst f)). + + Lemma max_var_nformulae_mono_aux : + forall l v acc, + (v <= acc -> + v <= fold_left F l acc)%positive. Proof. - unfold is_subset. + induction l ; simpl ; [easy|]. intros. - apply mem_union_l; auto. + apply IHl. + unfold F. + apply Pos.max_case_strong;intros ; auto. + eapply Pos.le_trans ; eauto. Qed. - Lemma is_subset_union_r : forall v1 v2, - is_subset v1 (union v2 v1). + Lemma max_var_nformulae_mono_aux' : + forall l acc acc', + (acc <= acc' -> + fold_left F l acc <= fold_left F l acc')%positive. Proof. - unfold is_subset. + induction l ; simpl ; [easy|]. intros. - apply mem_union_r; auto. + apply IHl. + unfold F. + apply Pos.max_le_compat_r; auto. Qed. - End Vars. - - -Fixpoint vars_of_pexpr (e : PExpr Z) : Vars.t := - match e with - | PEc _ => Vars.empty - | PEX x => Vars.singleton x - | PEadd e1 e2 | PEsub e1 e2 | PEmul e1 e2 => - let v1 := vars_of_pexpr e1 in - let v2 := vars_of_pexpr e2 in - Vars.union v1 v2 - | PEopp c => vars_of_pexpr c - | PEpow e n => vars_of_pexpr e - end. - -Definition vars_of_formula (f : Formula Z) := - match f with - | Build_Formula l o r => - let v1 := vars_of_pexpr l in - let v2 := vars_of_pexpr r in - Vars.union v1 v2 - end. - -Fixpoint vars_of_bformula {TX : Type} {TG : Type} {ID : Type} - (F : @GFormula (Formula Z) TX TG ID) : Vars.t := - match F with - | TT => Vars.empty - | FF => Vars.empty - | X p => Vars.empty - | A a t => vars_of_formula a - | Cj f1 f2 | D f1 f2 | I f1 _ f2 => - let v1 := vars_of_bformula f1 in - let v2 := vars_of_bformula f2 in - Vars.union v1 v2 - | Tauto.N f => vars_of_bformula f - end. - -Definition bound_var (v : positive) : Formula Z := - Build_Formula (PEX v) OpGe (PEc 0). - -Definition mk_eq_pos (x : positive) (y:positive) (t : positive) : Formula Z := - Build_Formula (PEX x) OpEq (PEsub (PEX y) (PEX t)). - -Section BOUND. - Context {TX TG ID : Type}. - Variable tag_of_var : positive -> positive -> option bool -> TG. - Definition bound_vars (fr : positive) - (v : Vars.t) : @GFormula (Formula Z) TX TG ID := - Vars.fold (fun k acc => - let y := (xO (fr + k)) in - let z := (xI (fr + k)) in - Cj - (Cj (A (mk_eq_pos k y z) (tag_of_var fr k None)) - (Cj (A (bound_var y) (tag_of_var fr k (Some false))) - (A (bound_var z) (tag_of_var fr k (Some true))))) - acc) v TT. + Lemma max_var_nformulae_correct_aux : forall l p o v, + In (p,o) l -> In v (vars xH p) -> Pos.le v (fold_left F l 1)%positive. + Proof. + intros. + generalize 1%positive as acc. + revert p o v H H0. + induction l. + - simpl. tauto. + - simpl. + intros. + destruct H ; subst. + + unfold F at 2. + simpl. + apply max_var_correct in H0. + apply max_var_nformulae_mono_aux. + apply Pos.max_case_strong;intros ; auto. + eapply Pos.le_trans ; eauto. + + eapply IHl ; eauto. + Qed. - Definition bound_problem (F : @GFormula (Formula Z) TX TG ID) : GFormula := - let v := vars_of_bformula F in - I (bound_vars (Pos.succ (Vars.max_element v)) v) None F. +End MaxVar. +Lemma max_var_nformalae_correct : forall l p o v, + In (p,o) l -> In v (vars xH p) -> Pos.le v (max_var_nformulae l)%positive. +Proof. + intros l p o v. + apply max_var_nformulae_correct_aux. +Qed. - Definition bound_problem_fr (fr : positive) (F : @GFormula (Formula Z) TX TG ID) : GFormula := - let v := vars_of_bformula F in - I (bound_vars fr v) None F. +Fixpoint max_var_psatz (w : Psatz Z) : positive := + match w with + | PsatzIn _ n => xH + | PsatzSquare p => max_var xH (Psquare 0 1 Z.add Z.mul Zeq_bool p) + | PsatzMulC p w => Pos.max (max_var xH p) (max_var_psatz w) + | PsatzMulE w1 w2 => Pos.max (max_var_psatz w1) (max_var_psatz w2) + | PsatzAdd w1 w2 => Pos.max (max_var_psatz w1) (max_var_psatz w2) + | _ => xH + end. -End BOUND. +Fixpoint max_var_prf (w : ZArithProof) : positive := + match w with + | DoneProof => xH + | RatProof w pf | CutProof w pf => Pos.max (max_var_psatz w) (max_var_prf pf) + | EnumProof w1 w2 l => List.fold_left (fun acc prf => Pos.max acc (max_var_prf prf)) l + (Pos.max (max_var_psatz w1) (max_var_psatz w2)) + | ExProof _ pf => max_var_prf pf + end. -Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := +Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := match pf with | DoneProof => false | RatProof w pf => @@ -1025,11 +1014,17 @@ Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool : | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf end end -(* | SplitProof e pf1 pf2 => - match ZChecker ((e,NonStrict)::l) pf1 , ZChecker (( -*) - - | EnumProof w1 w2 pf => + | ExProof x prf => + let fr := max_var_nformulae l in + if Pos.leb x fr then + let z := Pos.succ fr in + let t := Pos.succ z in + let nfx := xnnormalise (mk_eq_pos x z t) in + let posz := xnnormalise (bound_var z) in + let post := xnnormalise (bound_var t) in + ZChecker (nfx::posz::post::l) prf + else false + | EnumProof w1 w2 pf => match eval_Psatz l w1 , eval_Psatz l w2 with | Some f1 , Some f2 => match genCuttingPlane f1 , genCuttingPlane f2 with @@ -1040,7 +1035,7 @@ Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool : fun lb ub => match pfs with | nil => if Z.gtb lb ub then true else false - | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Z.add lb 1%Z) ub) + | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Z.add lb 1%Z) ub) end) pf (Z.opp z1) z2 else false | _ , _ => true @@ -1057,6 +1052,7 @@ Fixpoint bdepth (pf : ZArithProof) : nat := | RatProof _ p => S (bdepth p) | CutProof _ p => S (bdepth p) | EnumProof _ _ l => S (List.fold_right (fun pf x => Nat.max (bdepth pf) x) O l) + | ExProof _ p => S (bdepth p) end. Require Import Wf_nat. @@ -1246,16 +1242,190 @@ Proof. destruct (makeCuttingPlane p) ; discriminate. Qed. +Lemma eval_nformula_mk_eq_pos : forall env x z t, + env x = env z - env t -> + eval_nformula env (xnnormalise (mk_eq_pos x z t)). +Proof. + intros. + rewrite xnnormalise_correct. + simpl. auto. +Qed. + +Lemma eval_nformula_bound_var : forall env x, + env x >= 0 -> + eval_nformula env (xnnormalise (bound_var x)). +Proof. + intros. + rewrite xnnormalise_correct. + simpl. auto. +Qed. + + +Definition agree_env (fr : positive) (env env' : positive -> Z) : Prop := + forall x, Pos.le x fr -> env x = env' x. + +Lemma agree_env_subset : forall v1 v2 env env', + agree_env v1 env env' -> + Pos.le v2 v1 -> + agree_env v2 env env'. +Proof. + unfold agree_env. + intros. + apply H. + eapply Pos.le_trans ; eauto. +Qed. + + +Lemma agree_env_jump : forall fr j env env', + agree_env (fr + j) env env' -> + agree_env fr (Env.jump j env) (Env.jump j env'). +Proof. + intros. + unfold agree_env ; intro. + intros. + unfold Env.jump. + apply H. + apply Pos.add_le_mono_r; auto. +Qed. + + +Lemma agree_env_tail : forall fr env env', + agree_env (Pos.succ fr) env env' -> + agree_env fr (Env.tail env) (Env.tail env'). +Proof. + intros. + unfold Env.tail. + apply agree_env_jump. + rewrite <- Pos.add_1_r in H. + apply H. +Qed. + + +Lemma max_var_acc : forall p i j, + (max_var (i + j) p = max_var i p + j)%positive. +Proof. + induction p; simpl. + - reflexivity. + - intros. + rewrite ! IHp. + rewrite Pos.add_assoc. + reflexivity. + - intros. + rewrite !Pplus_one_succ_l. + rewrite ! IHp1. + rewrite ! IHp2. + rewrite ! Pos.add_assoc. + rewrite <- Pos.add_max_distr_r. + reflexivity. +Qed. + + + +Lemma agree_env_eval_nformula : + forall env env' e + (AGREE : agree_env (max_var xH (fst e)) env env'), + eval_nformula env e <-> eval_nformula env' e. +Proof. + destruct e. + simpl; intros. + assert ((RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env p) + = + (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env' p)). + { + revert env env' AGREE. + generalize xH. + induction p ; simpl. + - reflexivity. + - intros. + apply IHp with (p := p1%positive). + apply agree_env_jump. + eapply agree_env_subset; eauto. + rewrite (Pos.add_comm p). + rewrite max_var_acc. + apply Pos.le_refl. + - intros. + f_equal. + f_equal. + { apply IHp1 with (p:= p). + eapply agree_env_subset; eauto. + apply Pos.le_max_l. + } + f_equal. + { unfold Env.hd. + unfold Env.nth. + apply AGREE. + apply Pos.le_1_l. + } + { + apply IHp2 with (p := p). + apply agree_env_tail. + eapply agree_env_subset; eauto. + rewrite !Pplus_one_succ_r. + rewrite max_var_acc. + apply Pos.le_max_r. + } + } + rewrite H. tauto. +Qed. + +Lemma agree_env_eval_nformulae : + forall env env' l + (AGREE : agree_env (max_var_nformulae l) env env'), + make_conj (eval_nformula env) l <-> + make_conj (eval_nformula env') l. +Proof. + induction l. + - simpl. tauto. + - intros. + rewrite ! make_conj_cons. + assert (eval_nformula env a <-> eval_nformula env' a). + { + apply agree_env_eval_nformula. + eapply agree_env_subset ; eauto. + unfold max_var_nformulae. + simpl. + rewrite Pos.max_1_l. + apply max_var_nformulae_mono_aux. + apply Pos.le_refl. + } + rewrite H. + apply and_iff_compat_l. + apply IHl. + eapply agree_env_subset ; eauto. + unfold max_var_nformulae. + simpl. + apply max_var_nformulae_mono_aux'. + apply Pos.le_1_l. +Qed. -Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False. + +Lemma eq_true_iff_eq : + forall b1 b2 : bool, (b1 = true <-> b2 = true) <-> b1 = b2. +Proof. + destruct b1,b2 ; intuition congruence. +Qed. + +Ltac pos_tac := + repeat + match goal with + | |- false = _ => symmetry + | |- Pos.eqb ?X ?Y = false => rewrite Pos.eqb_neq ; intro + | H : @eq positive ?X ?Y |- _ => apply Zpos_eq in H + | H : context[Z.pos (Pos.succ ?X)] |- _ => rewrite (Pos2Z.inj_succ X) in H + | H : Pos.leb ?X ?Y = true |- _ => rewrite Pos.leb_le in H ; + apply (Pos2Z.pos_le_pos X Y) in H + end. + +Lemma ZChecker_sound : forall w l, + ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False. Proof. induction w using (well_founded_ind (well_founded_ltof _ bdepth)). - destruct w as [ | w pf | w pf | w1 w2 pf]. - (* DoneProof *) + destruct w as [ | w pf | w pf | w1 w2 pf | x pf]. + - (* DoneProof *) simpl. discriminate. - (* RatProof *) + - (* RatProof *) simpl. - intro l. case_eq (eval_Psatz l w) ; [| discriminate]. + intros l. case_eq (eval_Psatz l w) ; [| discriminate]. intros f Hf. case_eq (Zunsat f). intros. @@ -1276,15 +1446,15 @@ Proof. apply H2. split ; auto. apply eval_Psatz_sound with (2:= Hf) ; assumption. - (* CutProof *) + - (* CutProof *) simpl. - intro l. + intros l. case_eq (eval_Psatz l w) ; [ | discriminate]. intros f' Hlc. case_eq (genCuttingPlane f'). intros. assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False). - eapply (H pf) ; auto. + eapply (H pf) ; auto. unfold ltof. simpl. auto with arith. @@ -1303,8 +1473,8 @@ Proof. intros. apply eval_Psatz_sound with (2:= Hlc) in H2. apply genCuttingPlaneNone with (2:= H2) ; auto. - (* EnumProof *) - intro. + - (* EnumProof *) + intros l. simpl. case_eq (eval_Psatz l w1) ; [ | discriminate]. case_eq (eval_Psatz l w2) ; [ | discriminate]. @@ -1359,7 +1529,7 @@ Proof. intros. assert (HH :forall x, -z1 <= x <= z2 -> exists pr, (In pr pf /\ - ZChecker ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z). + ZChecker ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z). clear HZ0 Hop1 Hop2 HCutL HCutR H0 H1. revert Hfix. generalize (-z1). clear z1. intro z1. @@ -1386,7 +1556,7 @@ Proof. (*/asser *) destruct (HH _ H1) as [pr [Hin Hcheker]]. assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False). - apply (H pr);auto. + eapply (H pr) ;auto. apply in_bdepth ; auto. rewrite <- make_conj_impl in H2. apply H2. @@ -1410,6 +1580,92 @@ Proof. intros. apply eval_Psatz_sound with (2:= Hf2) in H2. apply genCuttingPlaneNone with (2:= H2) ; auto. +- intros l. + unfold ZChecker. + fold ZChecker. + set (fr := (max_var_nformulae l)%positive). + set (z1 := (Pos.succ fr)) in *. + set (t1 := (Pos.succ z1)) in *. + destruct (x <=? fr)%positive eqn:LE ; [|congruence]. + intros. + set (env':= fun v => if Pos.eqb v z1 + then if Z.leb (env x) 0 then 0 else env x + else if Pos.eqb v t1 + then if Z.leb (env x) 0 then -(env x) else 0 + else env v). + apply H with (env:=env') in H0. + + rewrite <- make_conj_impl in *. + intro. + rewrite !make_conj_cons in H0. + apply H0 ; repeat split. + * + apply eval_nformula_mk_eq_pos. + unfold env'. + rewrite! Pos.eqb_refl. + replace (x=?z1)%positive with false. + replace (x=?t1)%positive with false. + replace (t1=?z1)%positive with false. + destruct (env x <=? 0); ring. + { unfold t1. + pos_tac; normZ. + lia (Hyp H2). + } + { + unfold t1, z1. + pos_tac; normZ. + lia (Add (Hyp LE) (Hyp H3)). + } + { + unfold z1. + pos_tac; normZ. + lia (Add (Hyp LE) (Hyp H3)). + } + * + apply eval_nformula_bound_var. + unfold env'. + rewrite! Pos.eqb_refl. + destruct (env x <=? 0) eqn:EQ. + compute. congruence. + rewrite Z.leb_gt in EQ. + normZ. + lia (Add (Hyp EQ) (Hyp H2)). + * + apply eval_nformula_bound_var. + unfold env'. + rewrite! Pos.eqb_refl. + replace (t1 =? z1)%positive with false. + destruct (env x <=? 0) eqn:EQ. + rewrite Z.leb_le in EQ. + normZ. + lia (Add (Hyp EQ) (Hyp H2)). + compute; congruence. + unfold t1. + clear. + pos_tac; normZ. + lia (Hyp H). + * + rewrite agree_env_eval_nformulae with (env':= env') in H1;auto. + unfold agree_env; intros. + unfold env'. + replace (x0 =? z1)%positive with false. + replace (x0 =? t1)%positive with false. + reflexivity. + { + unfold t1, z1. + unfold fr in *. + apply Pos2Z.pos_le_pos in H2. + pos_tac; normZ. + lia (Add (Hyp H2) (Hyp H4)). + } + { + unfold z1, fr in *. + apply Pos2Z.pos_le_pos in H2. + pos_tac; normZ. + lia (Add (Hyp H2) (Hyp H4)). + } + + unfold ltof. + simpl. + apply Nat.lt_succ_diag_r. Qed. @@ -1417,7 +1673,7 @@ Qed. Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ZArithProof): bool := @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZArithProof (fun cl => ZChecker (List.map fst cl)) f w. -Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (fun x => x) (Zeval_formula env) f. +Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_bf (Zeval_formula env) f. Proof. intros f w. unfold ZTautoChecker. @@ -1430,11 +1686,12 @@ Proof. - unfold Zdeduce. intros. revert H. apply (nformula_plus_nformula_correct Zsor ZSORaddon); auto. - - intros env t tg. - rewrite normalise_correct ; auto. + intros. + rewrite normalise_correct in H. + auto. - - intros env t tg. - rewrite negate_correct ; auto. + intros. + rewrite negate_correct in H ; auto. - intros t w0. unfold eval_tt. intros. @@ -1443,270 +1700,6 @@ Proof. tauto. Qed. -Record is_diff_env_elt (fr : positive) (env env' : positive -> Z) (x:positive):= - { - eq_env : env x = env' x; - eq_diff : env x = env' (xO (fr+ x)) - env' (xI (fr + x)); - pos_xO : env' (xO (fr+x)) >= 0; - pos_xI : env' (xI (fr+x)) >= 0; - }. - - -Definition is_diff_env (s : Vars.t) (env env' : positive -> Z) := - let fr := Pos.succ (Vars.max_element s) in - forall x, Vars.mem x s = true -> - is_diff_env_elt fr env env' x. - -Definition mk_diff_env (s : Vars.t) (env : positive -> Z) := - let fr := Vars.max_element s in - fun x => - if Pos.leb x fr - then env x - else - let fr' := Pos.succ fr in - match x with - | xO x => if Z.leb (env (x - fr')%positive) 0 - then 0 else env (x -fr')%positive - | xI x => if Z.leb (env (x - fr')%positive) 0 - then - (env (x - fr')%positive) else 0 - | xH => 0 - end. - -Lemma le_xO : forall x, (x <= xO x)%positive. -Proof. - intros. - change x with (1 * x)%positive at 1. - change (xO x) with (2 * x)%positive. - apply Pos.mul_le_mono. - compute. congruence. - apply Pos.le_refl. -Qed. - -Lemma leb_xO_false : - (forall x y, x <=? y = false -> - xO x <=? y = false)%positive. -Proof. - intros. - rewrite Pos.leb_nle in *. - intro. apply H. - eapply Pos.le_trans ; eauto. - apply le_xO. -Qed. - -Lemma leb_xI_false : - (forall x y, x <=? y = false -> - xI x <=? y = false)%positive. -Proof. - intros. - rewrite Pos.leb_nle in *. - intro. apply H. - eapply Pos.le_trans ; eauto. - generalize (le_xO x). - intros. - eapply Pos.le_trans ; eauto. - change (xI x) with (Pos.succ (xO x))%positive. - apply Pos.lt_le_incl. - apply Pos.lt_succ_diag_r. -Qed. - -Lemma is_diff_env_ex : forall s env, - is_diff_env s env (mk_diff_env s env). -Proof. - intros. - unfold is_diff_env, mk_diff_env. - intros. - assert - ((Pos.succ (Vars.max_element s) + x <=? Vars.max_element s = false)%positive). - { - rewrite Pos.leb_nle. - intro. - eapply (Pos.lt_irrefl (Pos.succ (Vars.max_element s) + x)). - eapply Pos.le_lt_trans ; eauto. - generalize (Pos.lt_succ_diag_r (Vars.max_element s)). - intro. - eapply Pos.lt_trans ; eauto. - apply Pos.lt_add_r. - } - constructor. - - apply Vars.max_element_max in H. - rewrite <- Pos.leb_le in H. - rewrite H. auto. - - - rewrite leb_xO_false by auto. - rewrite leb_xI_false by auto. - rewrite Pos.add_comm. - rewrite Pos.add_sub. - destruct (env x <=? 0); ring. - - rewrite leb_xO_false by auto. - rewrite Pos.add_comm. - rewrite Pos.add_sub. - destruct (env x <=? 0) eqn:EQ. - apply Z.le_ge. - apply Z.le_refl. - rewrite Z.leb_gt in EQ. - apply Z.le_ge. - apply Z.lt_le_incl. - auto. - - rewrite leb_xI_false by auto. - rewrite Pos.add_comm. - rewrite Pos.add_sub. - destruct (env x <=? 0) eqn:EQ. - rewrite Z.leb_le in EQ. - apply Z.le_ge. - apply Z.opp_nonneg_nonpos; auto. - apply Z.le_ge. - apply Z.le_refl. -Qed. - -Lemma env_bounds : forall tg env s, - let fr := Pos.succ (Vars.max_element s) in - exists env', is_diff_env s env env' - /\ - eval_bf (Zeval_formula env') (bound_vars tg fr s). -Proof. - intros. - assert (DIFF:=is_diff_env_ex s env). - exists (mk_diff_env s env). split ; auto. - unfold bound_vars. - rewrite FSetPositive.PositiveSet.fold_1. - revert DIFF. - set (env' := mk_diff_env s env). - intro. - assert (ACC : eval_bf (Zeval_formula env') TT ). - { - simpl. auto. - } - revert ACC. - match goal with - | |- context[@TT ?A ?B ?C ?D] => generalize (@TT A B C D) as acc - end. - unfold is_diff_env in DIFF. - assert (DIFFL : forall x, In x (FSetPositive.PositiveSet.elements s) -> - (x < fr)%positive /\ - is_diff_env_elt fr env env' x). - { - intros. - rewrite <- Vars.mem_elements in H. - split. - apply Vars.max_element_max in H. - unfold fr in *. - eapply Pos.le_lt_trans ; eauto. - apply Pos.lt_succ_diag_r. - apply DIFF; auto. - } - clear DIFF. - match goal with - | |- context[fold_left ?F _ _] => - set (FUN := F) - end. - induction (FSetPositive.PositiveSet.elements s). - - simpl; auto. - - simpl. - intros. - eapply IHl ; eauto. - + intros. apply DIFFL. - simpl ; auto. - + unfold FUN. - simpl. - split ; auto. - assert (HYP : (a < fr /\ is_diff_env_elt fr env env' a)%positive). - { - apply DIFFL. - simpl. tauto. - } - destruct HYP as (LT & DIFF). - destruct DIFF. - rewrite <- eq_env0. - tauto. -Qed. - -Definition agree_env (v : Vars.t) (env env' : positive -> Z) : Prop := - forall x, Vars.mem x v = true -> env x = env' x. - -Lemma agree_env_subset : forall s1 s2 env env', - agree_env s1 env env' -> - Vars.is_subset s2 s1 -> - agree_env s2 env env'. -Proof. - unfold agree_env. - intros. - apply H. apply H0; auto. -Qed. - -Lemma agree_env_union : forall s1 s2 env env', - agree_env (Vars.union s1 s2) env env' -> - agree_env s1 env env' /\ agree_env s2 env env'. -Proof. - split; - eapply agree_env_subset; eauto. - apply Vars.is_subset_union_l. - apply Vars.is_subset_union_r. -Qed. - - - -Lemma agree_env_eval_expr : - forall env env' e - (AGREE : agree_env (vars_of_pexpr e) env env'), - Zeval_expr env e = Zeval_expr env' e. -Proof. - induction e; simpl;intros; - try (apply agree_env_union in AGREE; destruct AGREE); try f_equal ; auto. - - intros ; apply AGREE. - apply Vars.mem_singleton. -Qed. - -Lemma agree_env_eval_bf : - forall env env' f - (AGREE: agree_env (vars_of_bformula f) env env'), - eval_bf (Zeval_formula env') f <-> - eval_bf (Zeval_formula env) f. -Proof. - induction f; simpl; intros ; - try (apply agree_env_union in AGREE; destruct AGREE) ; try intuition fail. - - - unfold Zeval_formula. - destruct t. - simpl in * ; intros. - apply agree_env_union in AGREE ; destruct AGREE. - rewrite <- agree_env_eval_expr with (env:=env) by auto. - rewrite <- agree_env_eval_expr with (e:= Frhs) (env:=env) by auto. - tauto. -Qed. - -Lemma bound_problem_sound : forall tg f, - (forall env' : PolEnv Z, - eval_bf (Zeval_formula env') - (bound_problem tg f)) -> - forall env, - eval_bf (Zeval_formula env) f. -Proof. - intros. - unfold bound_problem in H. - destruct (env_bounds tg env (vars_of_bformula f)) - as (env' & DIFF & EVAL). - simpl in H. - apply H in EVAL. - eapply agree_env_eval_bf ; eauto. - unfold is_diff_env, agree_env in *. - intros. - apply DIFF in H0. - destruct H0. - intuition. -Qed. - - - -Definition ZTautoCheckerExt (f : BFormula (Formula Z)) (w : list ZArithProof) : bool := - ZTautoChecker (bound_problem (fun _ _ _ => tt) f) w. - -Lemma ZTautoCheckerExt_sound : forall f w, ZTautoCheckerExt f w = true -> forall env, eval_bf (Zeval_formula env) f. -Proof. - intros. - unfold ZTautoCheckerExt in H. - specialize (ZTautoChecker_sound _ _ H). - intros ; apply bound_problem_sound with (tg:= fun _ _ _ => tt); auto. -Qed. Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := match pt with @@ -1716,6 +1709,7 @@ Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := | EnumProof c1 c2 l => let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in List.fold_left (xhyps_of_pt (S base)) l acc + | ExProof _ pt => xhyps_of_pt (S (S (S base ))) acc pt end. Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. diff --git a/plugins/micromega/ZifyComparison.v b/plugins/micromega/ZifyComparison.v index 8a8b40ded8..df75cf2c05 100644 --- a/plugins/micromega/ZifyComparison.v +++ b/plugins/micromega/ZifyComparison.v @@ -9,7 +9,8 @@ (************************************************************************) Require Import Bool ZArith. -Require Import ZifyClasses. +Require Import Zify ZifyClasses. +Require Import Lia. Local Open Scope Z_scope. (** [Z_of_comparison] is the injection function for comparison *) @@ -64,11 +65,11 @@ Proof. intros. destruct (x ?= y) eqn:C; simpl. - rewrite Z.compare_eq_iff in C. - intuition. + lia. - rewrite Z.compare_lt_iff in C. - intuition. + lia. - rewrite Z.compare_gt_iff in C. - intuition. + lia. Qed. Instance ZcompareSpec : BinOpSpec ZcompareZ := diff --git a/plugins/micromega/Ztac.v b/plugins/micromega/Ztac.v new file mode 100644 index 0000000000..091f58a0ef --- /dev/null +++ b/plugins/micromega/Ztac.v @@ -0,0 +1,140 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Tactics for doing arithmetic proofs. + Useful to bootstrap lia. + *) + +Require Import ZArithRing. +Require Import ZArith_base. +Local Open Scope Z_scope. + +Lemma eq_incl : + forall (x y:Z), x = y -> x <= y /\ y <= x. +Proof. + intros; split; + apply Z.eq_le_incl; auto. +Qed. + +Lemma elim_concl_eq : + forall x y, (x < y \/ y < x -> False) -> x = y. +Proof. + intros. + destruct (Z_lt_le_dec x y). + exfalso. apply H ; auto. + destruct (Zle_lt_or_eq y x);auto. + exfalso. + apply H ; auto. +Qed. + +Lemma elim_concl_le : + forall x y, (y < x -> False) -> x <= y. +Proof. + intros. + destruct (Z_lt_le_dec y x). + exfalso ; auto. + auto. +Qed. + +Lemma elim_concl_lt : + forall x y, (y <= x -> False) -> x < y. +Proof. + intros. + destruct (Z_lt_le_dec x y). + auto. + exfalso ; auto. +Qed. + + + +Lemma Zlt_le_add_1 : forall n m : Z, n < m -> n + 1 <= m. +Proof. exact (Zlt_le_succ). Qed. + + +Ltac normZ := + repeat + match goal with + | H : _ < _ |- _ => apply Zlt_le_add_1 in H + | H : ?Y <= _ |- _ => + lazymatch Y with + | 0 => fail + | _ => apply Zle_minus_le_0 in H + end + | H : _ >= _ |- _ => apply Z.ge_le in H + | H : _ > _ |- _ => apply Z.gt_lt in H + | H : _ = _ |- _ => apply eq_incl in H ; destruct H + | |- @eq Z _ _ => apply elim_concl_eq ; let H := fresh "HZ" in intros [H|H] + | |- _ <= _ => apply elim_concl_le ; intros + | |- _ < _ => apply elim_concl_lt ; intros + | |- _ >= _ => apply Z.le_ge + end. + + +Inductive proof := +| Hyp (e : Z) (prf : 0 <= e) +| Add (p1 p2: proof) +| Mul (p1 p2: proof) +| Cst (c : Z) +. + +Lemma add_le : forall e1 e2, 0 <= e1 -> 0 <= e2 -> 0 <= e1+e2. +Proof. + intros. + change 0 with (0+ 0). + apply Z.add_le_mono; auto. +Qed. + +Lemma mul_le : forall e1 e2, 0 <= e1 -> 0 <= e2 -> 0 <= e1*e2. +Proof. + intros. + change 0 with (0* e2). + apply Zmult_le_compat_r; auto. +Qed. + +Fixpoint eval_proof (p : proof) : { e : Z | 0 <= e} := + match p with + | Hyp e prf => exist _ e prf + | Add p1 p2 => let (e1,p1) := eval_proof p1 in + let (e2,p2) := eval_proof p2 in + exist _ _ (add_le _ _ p1 p2) + | Mul p1 p2 => let (e1,p1) := eval_proof p1 in + let (e2,p2) := eval_proof p2 in + exist _ _ (mul_le _ _ p1 p2) + | Cst c => match Z_le_dec 0 c with + | left prf => exist _ _ prf + | _ => exist _ _ Z.le_0_1 + end + end. + +Ltac lia_step p := + let H := fresh in + let prf := (eval cbn - [Z.le Z.mul Z.opp Z.sub Z.add] in (eval_proof p)) in + match prf with + | @exist _ _ _ ?P => pose proof P as H + end ; ring_simplify in H. + +Ltac lia_contr := + match goal with + | H : 0 <= - (Zpos _) |- _ => + rewrite <- Z.leb_le in H; + compute in H ; discriminate + | H : 0 <= (Zneg _) |- _ => + rewrite <- Z.leb_le in H; + compute in H ; discriminate + end. + + +Ltac lia p := + lia_step p ; lia_contr. + +Ltac slia H1 H2 := + normZ ; lia (Add (Hyp _ H1) (Hyp _ H2)). + +Arguments Hyp {_} prf. diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 82c2be582b..cb15274736 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -22,97 +22,85 @@ let debug = false open Big_int open Num open Polynomial - module Mc = Micromega module Ml2C = Mutils.CamlToCoq module C2Ml = Mutils.CoqToCaml let use_simplex = ref true - -type ('prf,'model) res = - | Prf of 'prf - | Model of 'model - | Unknown - -type zres = (Mc.zArithProof , (int * Mc.z list)) res - -type qres = (Mc.q Mc.psatz , (int * Mc.q list)) res - +type ('prf, 'model) res = Prf of 'prf | Model of 'model | Unknown +type zres = (Mc.zArithProof, int * Mc.z list) res +type qres = (Mc.q Mc.psatz, int * Mc.q list) res open Mutils -type 'a number_spec = { - bigint_to_number : big_int -> 'a; - number_to_num : 'a -> num; - zero : 'a; - unit : 'a; - mult : 'a -> 'a -> 'a; - eqb : 'a -> 'a -> bool - } - -let z_spec = { - bigint_to_number = Ml2C.bigint ; - number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); - zero = Mc.Z0; - unit = Mc.Zpos Mc.XH; - mult = Mc.Z.mul; - eqb = Mc.zeq_bool - } - - -let q_spec = { - bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); - number_to_num = C2Ml.q_to_num; - zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; - unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; - mult = Mc.qmult; - eqb = Mc.qeq_bool - } - -let dev_form n_spec p = + +type 'a number_spec = + { bigint_to_number : big_int -> 'a + ; number_to_num : 'a -> num + ; zero : 'a + ; unit : 'a + ; mult : 'a -> 'a -> 'a + ; eqb : 'a -> 'a -> bool } + +let z_spec = + { bigint_to_number = Ml2C.bigint + ; number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)) + ; zero = Mc.Z0 + ; unit = Mc.Zpos Mc.XH + ; mult = Mc.Z.mul + ; eqb = Mc.zeq_bool } + +let q_spec = + { bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}) + ; number_to_num = C2Ml.q_to_num + ; zero = {Mc.qnum = Mc.Z0; Mc.qden = Mc.XH} + ; unit = {Mc.qnum = Mc.Zpos Mc.XH; Mc.qden = Mc.XH} + ; mult = Mc.qmult + ; eqb = Mc.qeq_bool } + +let dev_form n_spec p = let rec dev_form p = match p with - | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) - | Mc.PEX v -> Poly.variable (C2Ml.positive v) - | Mc.PEmul(p1,p2) -> - let p1 = dev_form p1 in - let p2 = dev_form p2 in - Poly.product p1 p2 - | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2) - | Mc.PEopp p -> Poly.uminus (dev_form p) - | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2)) - | Mc.PEpow(p,n) -> - let p = dev_form p in - let n = C2Ml.n n in - let rec pow n = - if Int.equal n 0 - then Poly.constant (n_spec.number_to_num n_spec.unit) - else Poly.product p (pow (n-1)) in - pow n in + | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) + | Mc.PEX v -> Poly.variable (C2Ml.positive v) + | Mc.PEmul (p1, p2) -> + let p1 = dev_form p1 in + let p2 = dev_form p2 in + Poly.product p1 p2 + | Mc.PEadd (p1, p2) -> Poly.addition (dev_form p1) (dev_form p2) + | Mc.PEopp p -> Poly.uminus (dev_form p) + | Mc.PEsub (p1, p2) -> + Poly.addition (dev_form p1) (Poly.uminus (dev_form p2)) + | Mc.PEpow (p, n) -> + let p = dev_form p in + let n = C2Ml.n n in + let rec pow n = + if Int.equal n 0 then Poly.constant (n_spec.number_to_num n_spec.unit) + else Poly.product p (pow (n - 1)) + in + pow n + in dev_form p let rec fixpoint f x = let y' = f x in - if (=) y' x then y' - else fixpoint f y' + if y' = x then y' else fixpoint f y' -let rec_simpl_cone n_spec e = +let rec_simpl_cone n_spec e = let simpl_cone = - Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in - - let rec rec_simpl_cone = function - | Mc.PsatzMulE(t1, t2) -> - simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) - | Mc.PsatzAdd(t1,t2) -> - simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) - | x -> simpl_cone x in + Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb + in + let rec rec_simpl_cone = function + | Mc.PsatzMulE (t1, t2) -> + simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) + | Mc.PsatzAdd (t1, t2) -> + simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) + | x -> simpl_cone x + in rec_simpl_cone e - let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c - - (* The binding with Fourier might be a bit obsolete -- how does it handle equalities ? *) @@ -133,174 +121,166 @@ let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c (* fold_left followed by a rev ! *) let constrain_variable v l = - let coeffs = List.fold_left (fun acc p -> (Vect.get v p.coeffs)::acc) [] l in - { coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int zero_big_int):: (List.rev coeffs)) ; - op = Eq ; - cst = Big_int zero_big_int } - - + let coeffs = List.fold_left (fun acc p -> Vect.get v p.coeffs :: acc) [] l in + { coeffs = + Vect.from_list + (Big_int zero_big_int :: Big_int zero_big_int :: List.rev coeffs) + ; op = Eq + ; cst = Big_int zero_big_int } let constrain_constant l = - let coeffs = List.fold_left (fun acc p -> minus_num p.cst ::acc) [] l in - { coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int unit_big_int):: (List.rev coeffs)) ; - op = Eq ; - cst = Big_int zero_big_int } + let coeffs = List.fold_left (fun acc p -> minus_num p.cst :: acc) [] l in + { coeffs = + Vect.from_list + (Big_int zero_big_int :: Big_int unit_big_int :: List.rev coeffs) + ; op = Eq + ; cst = Big_int zero_big_int } let positivity l = let rec xpositivity i l = match l with | [] -> [] - | c::l -> match c.op with - | Eq -> xpositivity (i+1) l - | _ -> - {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; - op = Ge ; - cst = Int 0 } :: (xpositivity (i+1) l) + | c :: l -> ( + match c.op with + | Eq -> xpositivity (i + 1) l + | _ -> + { coeffs = Vect.update (i + 1) (fun _ -> Int 1) Vect.null + ; op = Ge + ; cst = Int 0 } + :: xpositivity (i + 1) l ) in xpositivity 1 l - -let cstr_of_poly (p,o) = - let (c,l) = Vect.decomp_cst p in - {coeffs = l; op = o ; cst = minus_num c} - - +let cstr_of_poly (p, o) = + let c, l = Vect.decomp_cst p in + {coeffs = l; op = o; cst = minus_num c} let variables_of_cstr c = Vect.variables c.coeffs - (* If the certificate includes at least one strict inequality, the obtained polynomial can also be 0 *) let build_dual_linear_system l = - let variables = - List.fold_left (fun acc p -> ISet.union acc (variables_of_cstr p)) ISet.empty l in + List.fold_left + (fun acc p -> ISet.union acc (variables_of_cstr p)) + ISet.empty l + in (* For each monomial, compute a constraint *) let s0 = - ISet.fold (fun mn res -> (constrain_variable mn l)::res) variables [] in - let c = constrain_constant l in - + ISet.fold (fun mn res -> constrain_variable mn l :: res) variables [] + in + let c = constrain_constant l in (* I need at least something strictly positive *) - let strict = { - coeffs = Vect.from_list ((Big_int zero_big_int) :: (Big_int unit_big_int):: - (List.map (fun c -> if is_strict c then Big_int unit_big_int else Big_int zero_big_int) l)); - op = Ge ; cst = Big_int unit_big_int } in + let strict = + { coeffs = + Vect.from_list + ( Big_int zero_big_int :: Big_int unit_big_int + :: List.map + (fun c -> + if is_strict c then Big_int unit_big_int + else Big_int zero_big_int) + l ) + ; op = Ge + ; cst = Big_int unit_big_int } + in (* Add the positivity constraint *) - {coeffs = Vect.from_list ([Big_int zero_big_int ;Big_int unit_big_int]) ; - op = Ge ; - cst = Big_int zero_big_int}::(strict::(positivity l)@c::s0) + { coeffs = Vect.from_list [Big_int zero_big_int; Big_int unit_big_int] + ; op = Ge + ; cst = Big_int zero_big_int } + :: ((strict :: positivity l) @ (c :: s0)) + open Util (** [direct_linear_prover l] does not handle strict inegalities *) let fourier_linear_prover l = match Mfourier.Fourier.find_point l with | Inr prf -> - if debug then Printf.printf "AProof : %a\n" Mfourier.pp_proof prf ; - let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Mfourier.Proof.mk_proof l prf))) in - if debug then Printf.printf "CProof : %a" Vect.pp cert ; - (*Some (rats_to_ints (Vect.to_list cert))*) - Some (Vect.normalise cert) - | Inl _ -> None - + if debug then Printf.printf "AProof : %a\n" Mfourier.pp_proof prf; + let cert = + (*List.map (fun (x,n) -> x+1,n)*) + fst (List.hd (Mfourier.Proof.mk_proof l prf)) + in + if debug then Printf.printf "CProof : %a" Vect.pp cert; + (*Some (rats_to_ints (Vect.to_list cert))*) + Some (Vect.normalise cert) + | Inl _ -> None let direct_linear_prover l = - if !use_simplex - then Simplex.find_unsat_certificate l + if !use_simplex then Simplex.find_unsat_certificate l else fourier_linear_prover l let find_point l = - if !use_simplex - then Simplex.find_point l - else match Mfourier.Fourier.find_point l with - | Inr _ -> None - | Inl cert -> Some cert + if !use_simplex then Simplex.find_point l + else + match Mfourier.Fourier.find_point l with + | Inr _ -> None + | Inl cert -> Some cert let optimise v l = - if !use_simplex - then Simplex.optimise v l - else Mfourier.Fourier.optimise v l - - + if !use_simplex then Simplex.optimise v l else Mfourier.Fourier.optimise v l let dual_raw_certificate l = - if debug - then begin - Printf.printf "dual_raw_certificate\n"; - List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) l - end; - + if debug then begin + Printf.printf "dual_raw_certificate\n"; + List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) l + end; let sys = build_dual_linear_system l in - if debug then begin - Printf.printf "dual_system\n"; - List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) sys - end; - + Printf.printf "dual_system\n"; + List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) sys + end; try match find_point sys with | None -> None - | Some cert -> - match Vect.choose cert with - | None -> failwith "dual_raw_certificate: empty_certificate" - | Some _ -> - (*Some (rats_to_ints (Vect.to_list (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))))*) - Some (Vect.normalise (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))) - (* should not use rats_to_ints *) + | Some cert -> ( + match Vect.choose cert with + | None -> failwith "dual_raw_certificate: empty_certificate" + | Some _ -> + (*Some (rats_to_ints (Vect.to_list (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))))*) + Some (Vect.normalise (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))) ) + (* should not use rats_to_ints *) with x when CErrors.noncritical x -> - if debug - then (Printf.printf "dual raw certificate %s" (Printexc.to_string x); - flush stdout) ; - None - - + if debug then ( + Printf.printf "dual raw certificate %s" (Printexc.to_string x); + flush stdout ); + None let simple_linear_prover l = - try - direct_linear_prover l + try direct_linear_prover l with Strict -> (* Fourier elimination should handle > *) dual_raw_certificate l let env_of_list l = - snd (List.fold_left (fun (i,m) p -> (i+1,IMap.add i p m)) (0,IMap.empty) l) - - - + snd + (List.fold_left (fun (i, m) p -> (i + 1, IMap.add i p m)) (0, IMap.empty) l) let linear_prover_cstr sys = - let (sysi,prfi) = List.split sys in - - + let sysi, prfi = List.split sys in match simple_linear_prover sysi with | None -> None | Some cert -> Some (ProofFormat.proof_of_farkas (env_of_list prfi) cert) -let linear_prover_cstr = - if debug - then - fun sys -> - Printf.printf "<linear_prover"; flush stdout ; +let linear_prover_cstr = + if debug then ( fun sys -> + Printf.printf "<linear_prover"; + flush stdout; let res = linear_prover_cstr sys in - Printf.printf ">"; flush stdout ; - res + Printf.printf ">"; flush stdout; res ) else linear_prover_cstr - - let compute_max_nb_cstr l d = let len = List.length l in max len (max d (len * d)) - -let develop_constraint z_spec (e,k) = - (dev_form z_spec e, - match k with - | Mc.NonStrict -> Ge - | Mc.Equal -> Eq - | Mc.Strict -> Gt - | _ -> assert false - ) +let develop_constraint z_spec (e, k) = + ( dev_form z_spec e + , match k with + | Mc.NonStrict -> Ge + | Mc.Equal -> Eq + | Mc.Strict -> Gt + | _ -> assert false ) (** A single constraint can be unsat for the following reasons: - 0 >= c for c a negative constant @@ -312,125 +292,109 @@ type checksat = | Tauto (* Tautology *) | Unsat of ProofFormat.prf_rule (* Unsatisfiable *) | Cut of cstr * ProofFormat.prf_rule (* Cutting plane *) - | Normalise of cstr * ProofFormat.prf_rule (* Coefficients may be normalised i.e relatively prime *) + | Normalise of cstr * ProofFormat.prf_rule -exception FoundProof of ProofFormat.prf_rule +(* Coefficients may be normalised i.e relatively prime *) +exception FoundProof of ProofFormat.prf_rule (** [check_sat] - detects constraints that are not satisfiable; - normalises constraints and generate cuts. *) -let check_int_sat (cstr,prf) = - let {coeffs=coeffs ; op=op ; cst=cst} = cstr in +let check_int_sat (cstr, prf) = + let {coeffs; op; cst} = cstr in match Vect.choose coeffs with - | None -> - if eval_op op (Int 0) cst then Tauto else Unsat prf - | _ -> - let gcdi = Vect.gcd coeffs in - let gcd = Big_int gcdi in - if eq_num gcd (Int 1) - then Normalise(cstr,prf) - else - if Int.equal (sign_num (mod_num cst gcd)) 0 - then (* We can really normalise *) - begin - assert (sign_num gcd >=1 ) ; - let cstr = { - coeffs = Vect.div gcd coeffs; - op = op ; cst = cst // gcd - } in - Normalise(cstr,ProofFormat.Gcd(gcdi,prf)) - (* Normalise(cstr,CutPrf prf)*) - end - else - match op with - | Eq -> Unsat (ProofFormat.CutPrf prf) - | Ge -> - let cstr = { - coeffs = Vect.div gcd coeffs; - op = op ; cst = ceiling_num (cst // gcd) - } in Cut(cstr,ProofFormat.CutPrf prf) - | Gt -> failwith "check_sat : Unexpected operator" - + | None -> if eval_op op (Int 0) cst then Tauto else Unsat prf + | _ -> ( + let gcdi = Vect.gcd coeffs in + let gcd = Big_int gcdi in + if eq_num gcd (Int 1) then Normalise (cstr, prf) + else if Int.equal (sign_num (mod_num cst gcd)) 0 then begin + (* We can really normalise *) + assert (sign_num gcd >= 1); + let cstr = {coeffs = Vect.div gcd coeffs; op; cst = cst // gcd} in + Normalise (cstr, ProofFormat.Gcd (gcdi, prf)) + (* Normalise(cstr,CutPrf prf)*) + end + else + match op with + | Eq -> Unsat (ProofFormat.CutPrf prf) + | Ge -> + let cstr = + {coeffs = Vect.div gcd coeffs; op; cst = ceiling_num (cst // gcd)} + in + Cut (cstr, ProofFormat.CutPrf prf) + | Gt -> failwith "check_sat : Unexpected operator" ) let apply_and_normalise check f psys = - List.fold_left (fun acc pc' -> + List.fold_left + (fun acc pc' -> match f pc' with - | None -> pc'::acc - | Some pc' -> - match check pc' with - | Tauto -> acc - | Unsat prf -> raise (FoundProof prf) - | Cut(c,p) -> (c,p)::acc - | Normalise (c,p) -> (c,p)::acc - ) [] psys - - + | None -> pc' :: acc + | Some pc' -> ( + match check pc' with + | Tauto -> acc + | Unsat prf -> raise (FoundProof prf) + | Cut (c, p) -> (c, p) :: acc + | Normalise (c, p) -> (c, p) :: acc )) + [] psys let is_linear_for v pc = LinPoly.is_linear (fst (fst pc)) || LinPoly.is_linear_for v (fst (fst pc)) - - - (*let non_linear_pivot sys pc v pc' = if LinPoly.is_linear (fst (fst pc')) then None (* There are other ways to deal with those *) else WithProof.linear_pivot sys pc v pc' *) -let is_linear_substitution sys ((p,o),prf) = - let pred v = v =/ Int 1 || v =/ Int (-1) in +let is_linear_substitution sys ((p, o), prf) = + let pred v = v =/ Int 1 || v =/ Int (-1) in match o with - | Eq -> begin - match - List.filter (fun v -> List.for_all (is_linear_for v) sys) (LinPoly.search_all_linear pred p) - with - | [] -> None - | v::_ -> Some v (* make a choice *) - end - | _ -> None - + | Eq -> ( + match + List.filter + (fun v -> List.for_all (is_linear_for v) sys) + (LinPoly.search_all_linear pred p) + with + | [] -> None + | v :: _ -> Some v (* make a choice *) ) + | _ -> None let elim_simple_linear_equality sys0 = - let elim sys = - let (oeq,sys') = extract (is_linear_substitution sys) sys in + let oeq, sys' = extract (is_linear_substitution sys) sys in match oeq with | None -> None - | Some(v,pc) -> simplify (WithProof.linear_pivot sys0 pc v) sys' in - + | Some (v, pc) -> simplify (WithProof.linear_pivot sys0 pc v) sys' + in iterate_until_stable elim sys0 - - let output_sys o sys = List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys let subst sys = let sys' = WithProof.subst sys in - if debug then Printf.fprintf stdout "[subst:\n%a\n==>\n%a\n]" output_sys sys output_sys sys' ; + if debug then + Printf.fprintf stdout "[subst:\n%a\n==>\n%a\n]" output_sys sys output_sys + sys'; sys' - - (** [saturate_linear_equality sys] generate new constraints obtained by eliminating linear equalities by pivoting. For integers, the obtained constraints are sound but not complete. *) - let saturate_by_linear_equalities sys0 = - WithProof.saturate_subst false sys0 - +let saturate_by_linear_equalities sys0 = WithProof.saturate_subst false sys0 let saturate_by_linear_equalities sys = let sys' = saturate_by_linear_equalities sys in - if debug then Printf.fprintf stdout "[saturate_by_linear_equalities:\n%a\n==>\n%a\n]" output_sys sys output_sys sys' ; + if debug then + Printf.fprintf stdout "[saturate_by_linear_equalities:\n%a\n==>\n%a\n]" + output_sys sys output_sys sys'; sys' - - (* let saturate_linear_equality_non_linear sys0 = let (l,_) = extract_all (is_substitution false) sys0 in let rec elim l acc = @@ -442,108 +406,117 @@ let saturate_by_linear_equalities sys = elim l [] *) -let bounded_vars (sys: WithProof.t list) = - let l = (fst (extract_all (fun ((p,o),prf) -> - LinPoly.is_variable p - ) sys)) in - List.fold_left (fun acc (i,wp) -> IMap.add i wp acc) IMap.empty l +let bounded_vars (sys : WithProof.t list) = + let l = fst (extract_all (fun ((p, o), prf) -> LinPoly.is_variable p) sys) in + List.fold_left (fun acc (i, wp) -> IMap.add i wp acc) IMap.empty l -let rec power n p = - if n = 1 then p - else WithProof.product p (power (n-1) p) +let rec power n p = if n = 1 then p else WithProof.product p (power (n - 1) p) let bound_monomial mp m = - if Monomial.is_var m || Monomial.is_const m - then None + if Monomial.is_var m || Monomial.is_const m then None else - try - Some (Monomial.fold - (fun v i acc -> - let wp = IMap.find v mp in - WithProof.product (power i wp) acc) m (WithProof.const (Int 1)) - ) - with Not_found -> None - - -let bound_monomials (sys:WithProof.t list) = + try + Some + (Monomial.fold + (fun v i acc -> + let wp = IMap.find v mp in + WithProof.product (power i wp) acc) + m (WithProof.const (Int 1))) + with Not_found -> None + +let bound_monomials (sys : WithProof.t list) = let mp = bounded_vars sys in - let m = - List.fold_left (fun acc ((p,_),_) -> - Vect.fold (fun acc v _ -> let m = LinPoly.MonT.retrieve v in - match bound_monomial mp m with - | None -> acc - | Some r -> IMap.add v r acc) acc p) IMap.empty sys in - IMap.fold (fun _ e acc -> e::acc) m [] - + let m = + List.fold_left + (fun acc ((p, _), _) -> + Vect.fold + (fun acc v _ -> + let m = LinPoly.MonT.retrieve v in + match bound_monomial mp m with + | None -> acc + | Some r -> IMap.add v r acc) + acc p) + IMap.empty sys + in + IMap.fold (fun _ e acc -> e :: acc) m [] let develop_constraints prfdepth n_spec sys = LinPoly.MonT.clear (); - max_nb_cstr := compute_max_nb_cstr sys prfdepth ; + max_nb_cstr := compute_max_nb_cstr sys prfdepth; let sys = List.map (develop_constraint n_spec) sys in - List.mapi (fun i (p,o) -> ((LinPoly.linpol_of_pol p,o),ProofFormat.Hyp i)) sys + List.mapi + (fun i (p, o) -> ((LinPoly.linpol_of_pol p, o), ProofFormat.Hyp i)) + sys let square_of_var i = let x = LinPoly.var i in - ((LinPoly.product x x,Ge),(ProofFormat.Square x)) - + ((LinPoly.product x x, Ge), ProofFormat.Square x) (** [nlinear_preprocess sys] augments the system [sys] by performing some limited non-linear reasoning. For instance, it asserts that the x² ≥0 but also that if c₁ ≥ 0 ∈ sys and c₂ ≥ 0 ∈ sys then c₁ × c₂ ≥ 0. The resulting system is linearised. *) -let nlinear_preprocess (sys:WithProof.t list) = - - let is_linear = List.for_all (fun ((p,_),_) -> LinPoly.is_linear p) sys in - +let nlinear_preprocess (sys : WithProof.t list) = + let is_linear = List.for_all (fun ((p, _), _) -> LinPoly.is_linear p) sys in if is_linear then sys else let collect_square = - List.fold_left (fun acc ((p,_),_) -> MonMap.union (fun k e1 e2 -> Some e1) acc (LinPoly.collect_square p)) MonMap.empty sys in - let sys = MonMap.fold (fun s m acc -> - let s = LinPoly.of_monomial s in - let m = LinPoly.of_monomial m in - ((m, Ge), (ProofFormat.Square s))::acc) collect_square sys in - - let collect_vars = List.fold_left (fun acc p -> ISet.union acc (LinPoly.variables (fst (fst p)))) ISet.empty sys in - - let sys = ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys in - - let sys = sys @ (all_pairs WithProof.product sys) in - + List.fold_left + (fun acc ((p, _), _) -> + MonMap.union (fun k e1 e2 -> Some e1) acc (LinPoly.collect_square p)) + MonMap.empty sys + in + let sys = + MonMap.fold + (fun s m acc -> + let s = LinPoly.of_monomial s in + let m = LinPoly.of_monomial m in + ((m, Ge), ProofFormat.Square s) :: acc) + collect_square sys + in + let collect_vars = + List.fold_left + (fun acc p -> ISet.union acc (LinPoly.variables (fst (fst p)))) + ISet.empty sys + in + let sys = + ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys + in + let sys = sys @ all_pairs WithProof.product sys in if debug then begin - Printf.fprintf stdout "Preprocessed\n"; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; - end ; - + Printf.fprintf stdout "Preprocessed\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys + end; List.map (WithProof.annot "P") sys - - let nlinear_prover prfdepth sys = let sys = develop_constraints prfdepth q_spec sys in let sys1 = elim_simple_linear_equality sys in let sys2 = saturate_by_linear_equalities sys1 in - let sys = nlinear_preprocess sys1@sys2 in - let sys = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys in - let id = (List.fold_left - (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in + let sys = nlinear_preprocess sys1 @ sys2 in + let sys = List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys in + let id = + List.fold_left + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r)) + 0 sys + in let env = CList.interval 0 id in match linear_prover_cstr sys with | None -> Unknown - | Some cert -> - Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) - + | Some cert -> Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) let linear_prover_with_cert prfdepth sys = let sys = develop_constraints prfdepth q_spec sys in (* let sys = nlinear_preprocess sys in *) - let sys = List.map (fun (c,p) -> cstr_of_poly c,p) sys in - + let sys = List.map (fun (c, p) -> (cstr_of_poly c, p)) sys in match linear_prover_cstr sys with | None -> Unknown | Some cert -> - Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q (List.mapi (fun i e -> i) sys) cert) + Prf + (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q + (List.mapi (fun i e -> i) sys) + cert) (* The prover is (probably) incomplete -- only searching for naive cutting planes *) @@ -552,514 +525,525 @@ open Sos_types let rec scale_term t = match t with - | Zero -> unit_big_int , Zero - | Const n -> (denominator n) , Const (Big_int (numerator n)) - | Var n -> unit_big_int , Var n - | Opp t -> let s, t = scale_term t in s, Opp t - | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - let e = mult_big_int g (mult_big_int s1' s2') in - if Int.equal (compare_big_int e unit_big_int) 0 - then (unit_big_int, Add (y1,y2)) - else e, Add (Mul(Const (Big_int s2'), y1), - Mul (Const (Big_int s1'), y2)) + | Zero -> (unit_big_int, Zero) + | Const n -> (denominator n, Const (Big_int (numerator n))) + | Var n -> (unit_big_int, Var n) + | Opp t -> + let s, t = scale_term t in + (s, Opp t) + | Add (t1, t2) -> + let s1, y1 = scale_term t1 and s2, y2 = scale_term t2 in + let g = gcd_big_int s1 s2 in + let s1' = div_big_int s1 g in + let s2' = div_big_int s2 g in + let e = mult_big_int g (mult_big_int s1' s2') in + if Int.equal (compare_big_int e unit_big_int) 0 then + (unit_big_int, Add (y1, y2)) + else (e, Add (Mul (Const (Big_int s2'), y1), Mul (Const (Big_int s1'), y2))) | Sub _ -> failwith "scale term: not implemented" - | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in - mult_big_int s1 s2 , Mul (y1, y2) - | Pow(t,n) -> let s,t = scale_term t in - power_big_int_positive_int s n , Pow(t,n) + | Mul (y, z) -> + let s1, y1 = scale_term y and s2, y2 = scale_term z in + (mult_big_int s1 s2, Mul (y1, y2)) + | Pow (t, n) -> + let s, t = scale_term t in + (power_big_int_positive_int s n, Pow (t, n)) let scale_term t = - let (s,t') = scale_term t in - s,t' - -let rec scale_certificate pos = match pos with - | Axiom_eq i -> unit_big_int , Axiom_eq i - | Axiom_le i -> unit_big_int , Axiom_le i - | Axiom_lt i -> unit_big_int , Axiom_lt i - | Monoid l -> unit_big_int , Monoid l - | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) - | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) - | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) - | Square t -> let s,t' = scale_term t in - mult_big_int s s , Square t' - | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in - mult_big_int s1 s2 , Eqmul (y1,y2) - | Sum (y, z) -> let s1,y1 = scale_certificate y - and s2,y2 = scale_certificate z in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - mult_big_int g (mult_big_int s1' s2'), - Sum (Product(Rational_le (Big_int s2'), y1), - Product (Rational_le (Big_int s1'), y2)) + let s, t' = scale_term t in + (s, t') + +let rec scale_certificate pos = + match pos with + | Axiom_eq i -> (unit_big_int, Axiom_eq i) + | Axiom_le i -> (unit_big_int, Axiom_le i) + | Axiom_lt i -> (unit_big_int, Axiom_lt i) + | Monoid l -> (unit_big_int, Monoid l) + | Rational_eq n -> (denominator n, Rational_eq (Big_int (numerator n))) + | Rational_le n -> (denominator n, Rational_le (Big_int (numerator n))) + | Rational_lt n -> (denominator n, Rational_lt (Big_int (numerator n))) + | Square t -> + let s, t' = scale_term t in + (mult_big_int s s, Square t') + | Eqmul (t, y) -> + let s1, y1 = scale_term t and s2, y2 = scale_certificate y in + (mult_big_int s1 s2, Eqmul (y1, y2)) + | Sum (y, z) -> + let s1, y1 = scale_certificate y and s2, y2 = scale_certificate z in + let g = gcd_big_int s1 s2 in + let s1' = div_big_int s1 g in + let s2' = div_big_int s2 g in + ( mult_big_int g (mult_big_int s1' s2') + , Sum + ( Product (Rational_le (Big_int s2'), y1) + , Product (Rational_le (Big_int s1'), y2) ) ) | Product (y, z) -> - let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in - mult_big_int s1 s2 , Product (y1,y2) - + let s1, y1 = scale_certificate y and s2, y2 = scale_certificate z in + (mult_big_int s1 s2, Product (y1, y2)) open Micromega -let rec term_to_q_expr = function - | Const n -> PEc (Ml2C.q n) - | Zero -> PEc ( Ml2C.q (Int 0)) - | Var s -> PEX (Ml2C.index - (int_of_string (String.sub s 1 (String.length s - 1)))) - | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) - | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) - | Opp p -> PEopp (term_to_q_expr p) - | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n) - | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) - -let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e) +let rec term_to_q_expr = function + | Const n -> PEc (Ml2C.q n) + | Zero -> PEc (Ml2C.q (Int 0)) + | Var s -> + PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) + | Mul (p1, p2) -> PEmul (term_to_q_expr p1, term_to_q_expr p2) + | Add (p1, p2) -> PEadd (term_to_q_expr p1, term_to_q_expr p2) + | Opp p -> PEopp (term_to_q_expr p) + | Pow (t, n) -> PEpow (term_to_q_expr t, Ml2C.n n) + | Sub (t1, t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) + +let term_to_q_pol e = + Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus + Mc.qopp Mc.qeq_bool (term_to_q_expr e) let rec product l = match l with | [] -> Mc.PsatzZ | [i] -> Mc.PsatzIn (Ml2C.nat i) - | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) - + | i :: l -> Mc.PsatzMulE (Mc.PsatzIn (Ml2C.nat i), product l) -let q_cert_of_pos pos = +let q_cert_of_pos pos = let rec _cert_of_pos = function - Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) - | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) - | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) - | Monoid l -> product l + | Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) + | Monoid l -> product l | Rational_eq n | Rational_le n | Rational_lt n -> - if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else - Mc.PsatzC (Ml2C.q n) - | Square t -> Mc.PsatzSquare (term_to_q_pol t) - | Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y) - | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) - | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in + if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ + else Mc.PsatzC (Ml2C.q n) + | Square t -> Mc.PsatzSquare (term_to_q_pol t) + | Eqmul (t, y) -> Mc.PsatzMulC (term_to_q_pol t, _cert_of_pos y) + | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) + | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) + in simplify_cone q_spec (_cert_of_pos pos) - let rec term_to_z_expr = function - | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) - | Zero -> PEc ( Z0) - | Var s -> PEX (Ml2C.index - (int_of_string (String.sub s 1 (String.length s - 1)))) - | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2) - | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2) - | Opp p -> PEopp (term_to_z_expr p) - | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n) - | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2) - -let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e) - -let z_cert_of_pos pos = - let s,pos = (scale_certificate pos) in + | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) + | Zero -> PEc Z0 + | Var s -> + PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) + | Mul (p1, p2) -> PEmul (term_to_z_expr p1, term_to_z_expr p2) + | Add (p1, p2) -> PEadd (term_to_z_expr p1, term_to_z_expr p2) + | Opp p -> PEopp (term_to_z_expr p) + | Pow (t, n) -> PEpow (term_to_z_expr t, Ml2C.n n) + | Sub (t1, t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2) + +let term_to_z_pol e = + Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp + Mc.zeq_bool (term_to_z_expr e) + +let z_cert_of_pos pos = + let s, pos = scale_certificate pos in let rec _cert_of_pos = function - Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) - | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) - | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) - | Monoid l -> product l + | Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) + | Monoid l -> product l | Rational_eq n | Rational_le n | Rational_lt n -> - if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else - Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) - | Square t -> Mc.PsatzSquare (term_to_z_pol t) + if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ + else Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) + | Square t -> Mc.PsatzSquare (term_to_z_pol t) | Eqmul (t, y) -> - let is_unit = - match t with - | Const n -> n =/ Int 1 - | _ -> false in - if is_unit - then _cert_of_pos y - else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y) - | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) - | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in + let is_unit = match t with Const n -> n =/ Int 1 | _ -> false in + if is_unit then _cert_of_pos y + else Mc.PsatzMulC (term_to_z_pol t, _cert_of_pos y) + | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) + | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) + in simplify_cone z_spec (_cert_of_pos pos) +open Mutils (** All constraints (initial or derived) have an index and have a justification i.e., proof. Given a constraint, all the coefficients are always integers. *) -open Mutils + open Num open Big_int open Polynomial - - type prf_sys = (cstr * ProofFormat.prf_rule) list - - (** Proof generating pivoting over variable v *) -let pivot v (c1,p1) (c2,p2) = - let {coeffs = v1 ; op = op1 ; cst = n1} = c1 - and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in - - - +let pivot v (c1, p1) (c2, p2) = + let {coeffs = v1; op = op1; cst = n1} = c1 + and {coeffs = v2; op = op2; cst = n2} = c2 in (* Could factorise gcd... *) let xpivot cv1 cv2 = - ( - {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ; - op = opAdd op1 op2 ; - cst = n1 */ cv1 +/ n2 */ cv2 }, - - ProofFormat.add_proof (ProofFormat.mul_cst_proof cv1 p1) (ProofFormat.mul_cst_proof cv2 p2)) in - - match Vect.get v v1 , Vect.get v v2 with - | Int 0 , _ | _ , Int 0 -> None - | a , b -> - if Int.equal ((sign_num a) * (sign_num b)) (-1) - then - let cv1 = abs_num b - and cv2 = abs_num a in - Some (xpivot cv1 cv2) - else - if op1 == Eq - then - let cv1 = minus_num (b */ (Int (sign_num a))) - and cv2 = abs_num a in - Some (xpivot cv1 cv2) - else if op2 == Eq - then - let cv1 = abs_num b - and cv2 = minus_num (a */ (Int (sign_num b))) in - Some (xpivot cv1 cv2) - else None (* op2 could be Eq ... this might happen *) - + ( { coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) + ; op = opAdd op1 op2 + ; cst = (n1 */ cv1) +/ (n2 */ cv2) } + , ProofFormat.add_proof + (ProofFormat.mul_cst_proof cv1 p1) + (ProofFormat.mul_cst_proof cv2 p2) ) + in + match (Vect.get v v1, Vect.get v v2) with + | Int 0, _ | _, Int 0 -> None + | a, b -> + if Int.equal (sign_num a * sign_num b) (-1) then + let cv1 = abs_num b and cv2 = abs_num a in + Some (xpivot cv1 cv2) + else if op1 == Eq then + let cv1 = minus_num (b */ Int (sign_num a)) and cv2 = abs_num a in + Some (xpivot cv1 cv2) + else if op2 == Eq then + let cv1 = abs_num b and cv2 = minus_num (a */ Int (sign_num b)) in + Some (xpivot cv1 cv2) + else None + +(* op2 could be Eq ... this might happen *) let simpl_sys sys = - List.fold_left (fun acc (c,p) -> - match check_int_sat (c,p) with + List.fold_left + (fun acc (c, p) -> + match check_int_sat (c, p) with | Tauto -> acc | Unsat prf -> raise (FoundProof prf) - | Cut(c,p) -> (c,p)::acc - | Normalise (c,p) -> (c,p)::acc) [] sys - + | Cut (c, p) -> (c, p) :: acc + | Normalise (c, p) -> (c, p) :: acc) + [] sys (** [ext_gcd a b] is the extended Euclid algorithm. [ext_gcd a b = (x,y,g)] iff [ax+by=g] Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm *) let rec ext_gcd a b = - if Int.equal (sign_big_int b) 0 - then (unit_big_int,zero_big_int) + if Int.equal (sign_big_int b) 0 then (unit_big_int, zero_big_int) else - let (q,r) = quomod_big_int a b in - let (s,t) = ext_gcd b r in + let q, r = quomod_big_int a b in + let s, t = ext_gcd b r in (t, sub_big_int s (mult_big_int q t)) -let extract_coprime (c1,p1) (c2,p2) = - if c1.op == Eq && c2.op == Eq - then Vect.exists2 (fun n1 n2 -> - Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0) - c1.coeffs c2.coeffs +let extract_coprime (c1, p1) (c2, p2) = + if c1.op == Eq && c2.op == Eq then + Vect.exists2 + (fun n1 n2 -> + Int.equal + (compare_big_int + (gcd_big_int (numerator n1) (numerator n2)) + unit_big_int) + 0) + c1.coeffs c2.coeffs else None let extract2 pred l = let rec xextract2 rl l = match l with - | [] -> (None,rl) (* Did not find *) - | e::l -> - match extract (pred e) l with - | None,_ -> xextract2 (e::rl) l - | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in - + | [] -> (None, rl) (* Did not find *) + | e :: l -> ( + match extract (pred e) l with + | None, _ -> xextract2 (e :: rl) l + | Some (r, e'), l' -> (Some (r, e, e'), List.rev_append rl l') ) + in xextract2 [] l - -let extract_coprime_equation psys = - extract2 extract_coprime psys - - - - - - +let extract_coprime_equation psys = extract2 extract_coprime psys let pivot_sys v pc psys = apply_and_normalise check_int_sat (pivot v pc) psys let reduce_coprime psys = - let oeq,sys = extract_coprime_equation psys in + let oeq, sys = extract_coprime_equation psys in match oeq with | None -> None (* Nothing to do *) - | Some((v,n1,n2),(c1,p1),(c2,p2) ) -> - let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in - let l1' = Big_int l1 and l2' = Big_int l2 in - let cstr = - {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs); - op = Eq ; - cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) - } in - let prf = ProofFormat.add_proof (ProofFormat.mul_cst_proof l1' p1) (ProofFormat.mul_cst_proof l2' p2) in - - Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) + | Some ((v, n1, n2), (c1, p1), (c2, p2)) -> + let l1, l2 = ext_gcd (numerator n1) (numerator n2) in + let l1' = Big_int l1 and l2' = Big_int l2 in + let cstr = + { coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs) + ; op = Eq + ; cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) } + in + let prf = + ProofFormat.add_proof + (ProofFormat.mul_cst_proof l1' p1) + (ProofFormat.mul_cst_proof l2' p2) + in + Some (pivot_sys v (cstr, prf) ((c1, p1) :: sys)) (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) let reduce_unary psys = - let is_unary_equation (cstr,prf) = - if cstr.op == Eq - then - Vect.find (fun v n -> if n =/ (Int 1) || n=/ (Int (-1)) then Some v else None) cstr.coeffs - else None in - - let (oeq,sys) = extract is_unary_equation psys in + let is_unary_equation (cstr, prf) = + if cstr.op == Eq then + Vect.find + (fun v n -> if n =/ Int 1 || n =/ Int (-1) then Some v else None) + cstr.coeffs + else None + in + let oeq, sys = extract is_unary_equation psys in match oeq with | None -> None (* Nothing to do *) - | Some(v,pc) -> - Some(pivot_sys v pc sys) - + | Some (v, pc) -> Some (pivot_sys v pc sys) let reduce_var_change psys = - let rec rel_prime vect = match Vect.choose vect with | None -> None - | Some(x,v,vect) -> - let v = numerator v in - match Vect.find (fun x' v' -> - let v' = numerator v' in - if eq_big_int (gcd_big_int v v') unit_big_int - then Some(x',v') else None) vect with - | Some(x',v') -> Some ((x,v),(x', v')) - | None -> rel_prime vect in - - let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in - - let (oeq,sys) = extract rel_prime psys in - + | Some (x, v, vect) -> ( + let v = numerator v in + match + Vect.find + (fun x' v' -> + let v' = numerator v' in + if eq_big_int (gcd_big_int v v') unit_big_int then Some (x', v') + else None) + vect + with + | Some (x', v') -> Some ((x, v), (x', v')) + | None -> rel_prime vect ) + in + let rel_prime (cstr, prf) = + if cstr.op == Eq then rel_prime cstr.coeffs else None + in + let oeq, sys = extract rel_prime psys in match oeq with | None -> None - | Some(((x,v),(x',v')),(c,p)) -> - let (l1,l2) = ext_gcd v v' in - let l1,l2 = Big_int l1 , Big_int l2 in - - - let pivot_eq (c',p') = - let {coeffs = coeffs ; op = op ; cst = cst} = c' in - let vx = Vect.get x coeffs in - let vx' = Vect.get x' coeffs in - let m = minus_num (vx */ l1 +/ vx' */ l2) in - Some ({coeffs = - Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , - ProofFormat.add_proof (ProofFormat.mul_cst_proof m p) p') in - - Some (apply_and_normalise check_int_sat pivot_eq sys) - + | Some (((x, v), (x', v')), (c, p)) -> + let l1, l2 = ext_gcd v v' in + let l1, l2 = (Big_int l1, Big_int l2) in + let pivot_eq (c', p') = + let {coeffs; op; cst} = c' in + let vx = Vect.get x coeffs in + let vx' = Vect.get x' coeffs in + let m = minus_num ((vx */ l1) +/ (vx' */ l2)) in + Some + ( { coeffs = Vect.add (Vect.mul m c.coeffs) coeffs + ; op + ; cst = (m */ c.cst) +/ cst } + , ProofFormat.add_proof (ProofFormat.mul_cst_proof m p) p' ) + in + Some (apply_and_normalise check_int_sat pivot_eq sys) let reduction_equations psys = - iterate_until_stable (app_funs - [reduce_unary ; reduce_coprime ; - reduce_var_change (*; reduce_pivot*)]) psys - - - - + iterate_until_stable + (app_funs + [reduce_unary; reduce_coprime; reduce_var_change (*; reduce_pivot*)]) + psys (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) let get_bound sys = - let is_small (v,i) = - match Itv.range i with - | None -> false - | Some i -> i <=/ (Int 1) in - - let select_best (x1,i1) (x2,i2) = - if Itv.smaller_itv i1 i2 - then (x1,i1) else (x2,i2) in - + let is_small (v, i) = + match Itv.range i with None -> false | Some i -> i <=/ Int 1 + in + let select_best (x1, i1) (x2, i2) = + if Itv.smaller_itv i1 i2 then (x1, i1) else (x2, i2) + in (* For lia, there are no equations => these precautions are not needed *) (* For nlia, there are equations => do not enumerate over equations! *) let all_planes sys = - let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in + let eq, ineq = List.partition (fun c -> c.op == Eq) sys in match eq with | [] -> List.rev_map (fun c -> c.coeffs) ineq - | _ -> - List.fold_left (fun acc c -> - if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq - then acc else c.coeffs ::acc) [] ineq in - + | _ -> + List.fold_left + (fun acc c -> + if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq then acc + else c.coeffs :: acc) + [] ineq + in let smallest_interval = List.fold_left (fun acc vect -> - if is_small acc - then acc + if is_small acc then acc else match optimise vect sys with | None -> acc | Some i -> - if debug then Printf.printf "Found a new bound %a in %a" Vect.pp vect Itv.pp i; - select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in + if debug then + Printf.printf "Found a new bound %a in %a" Vect.pp vect Itv.pp i; + select_best (vect, i) acc) + (Vect.null, (None, None)) + (all_planes sys) + in let smallest_interval = - match smallest_interval - with - | (x,(Some i, Some j)) -> Some(i,x,j) - | x -> None (* This should not be possible *) + match smallest_interval with + | x, (Some i, Some j) -> Some (i, x, j) + | x -> None + (* This should not be possible *) in match smallest_interval with - | Some (lb,e,ub) -> - let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in - let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in - (match - (* x <= ub -> x > ub *) - direct_linear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys), - (* lb <= x -> lb > x *) + | Some (lb, e, ub) -> ( + let lbn, lbd = (sub_big_int (numerator lb) unit_big_int, denominator lb) in + let ubn, ubd = (add_big_int unit_big_int (numerator ub), denominator ub) in + (* x <= ub -> x > ub *) + match + ( direct_linear_prover + ( {coeffs = Vect.mul (Big_int ubd) e; op = Ge; cst = Big_int ubn} + :: sys ) + , (* lb <= x -> lb > x *) direct_linear_prover - ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys) - with - | Some cub , Some clb -> Some(List.tl (Vect.to_list clb),(lb,e,ub), List.tl (Vect.to_list cub)) - | _ -> failwith "Interval without proof" - ) + ( { coeffs = Vect.mul (minus_num (Big_int lbd)) e + ; op = Ge + ; cst = minus_num (Big_int lbn) } + :: sys ) ) + with + | Some cub, Some clb -> + Some (List.tl (Vect.to_list clb), (lb, e, ub), List.tl (Vect.to_list cub)) + | _ -> failwith "Interval without proof" ) | None -> None - let check_sys sys = - List.for_all (fun (c,p) -> Vect.for_all (fun _ n -> sign_num n <> 0) c.coeffs) sys + List.for_all + (fun (c, p) -> Vect.for_all (fun _ n -> sign_num n <> 0) c.coeffs) + sys open ProofFormat -let xlia (can_enum:bool) reduction_equations sys = - - - let rec enum_proof (id:int) (sys:prf_sys) = - if debug then (Printf.printf "enum_proof\n" ; flush stdout) ; - assert (check_sys sys) ; - - let nsys,prf = List.split sys in +let xlia (can_enum : bool) reduction_equations sys = + let rec enum_proof (id : int) (sys : prf_sys) = + if debug then ( + Printf.printf "enum_proof\n"; + flush stdout ); + assert (check_sys sys); + let nsys, prf = List.split sys in match get_bound nsys with | None -> Unknown (* Is the systeme really unbounded ? *) - | Some(prf1,(lb,e,ub),prf2) -> - if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp e (string_of_num lb) (string_of_num ub) ; - (match start_enum id e (ceiling_num lb) (floor_num ub) sys - with - | Prf prfl -> - Prf(ProofFormat.Enum(id,ProofFormat.proof_of_farkas (env_of_list prf) (Vect.from_list prf1),e, - ProofFormat.proof_of_farkas (env_of_list prf) (Vect.from_list prf2),prfl)) - | _ -> Unknown - ) - - and start_enum id e clb cub sys = - if clb >/ cub - then Prf [] + | Some (prf1, (lb, e, ub), prf2) -> ( + if debug then + Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp e + (string_of_num lb) (string_of_num ub); + match start_enum id e (ceiling_num lb) (floor_num ub) sys with + | Prf prfl -> + Prf + (ProofFormat.Enum + ( id + , ProofFormat.proof_of_farkas (env_of_list prf) + (Vect.from_list prf1) + , e + , ProofFormat.proof_of_farkas (env_of_list prf) + (Vect.from_list prf2) + , prfl )) + | _ -> Unknown ) + and start_enum id e clb cub sys = + if clb >/ cub then Prf [] else - let eq = {coeffs = e ; op = Eq ; cst = clb} in - match aux_lia (id+1) ((eq, ProofFormat.Def id) :: sys) with + let eq = {coeffs = e; op = Eq; cst = clb} in + match aux_lia (id + 1) ((eq, ProofFormat.Def id) :: sys) with | Unknown | Model _ -> Unknown - | Prf prf -> - match start_enum id e (clb +/ (Int 1)) cub sys with - | Prf l -> Prf (prf::l) - | _ -> Unknown - - - and aux_lia (id:int) (sys:prf_sys) = - assert (check_sys sys) ; - if debug then Printf.printf "xlia: %a \n" (pp_list ";" (fun o (c,_) -> output_cstr o c)) sys ; + | Prf prf -> ( + match start_enum id e (clb +/ Int 1) cub sys with + | Prf l -> Prf (prf :: l) + | _ -> Unknown ) + and aux_lia (id : int) (sys : prf_sys) = + assert (check_sys sys); + if debug then + Printf.printf "xlia: %a \n" + (pp_list ";" (fun o (c, _) -> output_cstr o c)) + sys; try let sys = reduction_equations sys in if debug then - Printf.printf "after reduction: %a \n" (pp_list ";" (fun o (c,_) -> output_cstr o c)) sys ; + Printf.printf "after reduction: %a \n" + (pp_list ";" (fun o (c, _) -> output_cstr o c)) + sys; match linear_prover_cstr sys with - | Some prf -> Prf (Step(id,prf,Done)) - | None -> if can_enum then enum_proof id sys else Unknown + | Some prf -> Prf (Step (id, prf, Done)) + | None -> if can_enum then enum_proof id sys else Unknown with FoundProof prf -> (* [reduction_equations] can find a proof *) - Prf(Step(id,prf,Done)) in - + Prf (Step (id, prf, Done)) + in (* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*) - let id = 1 + (List.fold_left - (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in + let id = + 1 + + List.fold_left + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r)) + 0 sys + in let orpf = try let sys = simpl_sys sys in aux_lia id sys - with FoundProof pr -> Prf(Step(id,pr,Done)) in + with FoundProof pr -> Prf (Step (id, pr, Done)) + in match orpf with | Unknown | Model _ -> Unknown | Prf prf -> - let env = CList.interval 0 (id - 1) in - if debug then begin - Printf.fprintf stdout "direct proof %a\n" output_proof prf; - flush stdout; - end; - let prf = compile_proof env prf in - (*try + let env = CList.interval 0 (id - 1) in + if debug then begin + Printf.fprintf stdout "direct proof %a\n" output_proof prf; + flush stdout + end; + let prf = compile_proof env prf in + (*try if Mc.zChecker sys' prf then Some prf else raise Certificate.BadCertificate with Failure s -> (Printf.printf "%s" s ; Some prf) - *) Prf prf + *) + Prf prf let xlia_simplex env red sys = let compile_prf sys prf = - let id = 1 + (List.fold_left - (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in + let id = + 1 + + List.fold_left + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r)) + 0 sys + in let env = CList.interval 0 (id - 1) in - Prf (compile_proof env prf) in - + Prf (compile_proof env prf) + in try let sys = red sys in - match Simplex.integer_solver sys with | None -> Unknown | Some prf -> compile_prf sys prf - with FoundProof prf -> compile_prf sys (Step(0,prf,Done)) + with FoundProof prf -> compile_prf sys (Step (0, prf, Done)) let xlia env0 en red sys = - if !use_simplex then xlia_simplex env0 red sys - else xlia en red sys - + if !use_simplex then xlia_simplex env0 red sys else xlia en red sys let dump_file = ref None let gen_bench (tac, prover) can_enum prfdepth sys = let res = prover can_enum prfdepth sys in - (match !dump_file with + ( match !dump_file with | None -> () | Some file -> - begin - let o = open_out (Filename.temp_file ~temp_dir:(Sys.getcwd ()) file ".v") in - let sys = develop_constraints prfdepth z_spec sys in - Printf.fprintf o "Require Import ZArith Lia. Open Scope Z_scope.\n"; - Printf.fprintf o "Goal %a.\n" (LinPoly.pp_goal "Z") (List.map fst sys) ; - begin - match res with - | Unknown | Model _ -> - Printf.fprintf o "Proof.\n intros. Fail %s.\nAbort.\n" tac - | Prf res -> - Printf.fprintf o "Proof.\n intros. %s.\nQed.\n" tac - end - ; - flush o ; - close_out o ; - end); + let o = open_out (Filename.temp_file ~temp_dir:(Sys.getcwd ()) file ".v") in + let sys = develop_constraints prfdepth z_spec sys in + Printf.fprintf o "Require Import ZArith Lia. Open Scope Z_scope.\n"; + Printf.fprintf o "Goal %a.\n" (LinPoly.pp_goal "Z") (List.map fst sys); + begin + match res with + | Unknown | Model _ -> + Printf.fprintf o "Proof.\n intros. Fail %s.\nAbort.\n" tac + | Prf res -> Printf.fprintf o "Proof.\n intros. %s.\nQed.\n" tac + end; + flush o; close_out o ); res -let lia (can_enum:bool) (prfdepth:int) sys = +let lia (can_enum : bool) (prfdepth : int) sys = let sys = develop_constraints prfdepth z_spec sys in if debug then begin - Printf.fprintf stdout "Input problem\n"; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; - Printf.fprintf stdout "Input problem\n"; - let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" in - List.iter (fun ((p,op),_) -> Printf.fprintf stdout "(assert (%s %a))\n" (string_of_op op) Vect.pp_smt p) sys; - end; + Printf.fprintf stdout "Input problem\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + Printf.fprintf stdout "Input problem\n"; + let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" in + List.iter + (fun ((p, op), _) -> + Printf.fprintf stdout "(assert (%s %a))\n" (string_of_op op) Vect.pp_smt + p) + sys + end; let sys = subst sys in - let bnd = bound_monomials sys in (* To deal with non-linear monomials *) - let sys = bnd@(saturate_by_linear_equalities sys)@sys in - - - let sys' = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys in + let bnd = bound_monomials sys in + (* To deal with non-linear monomials *) + let sys = bnd @ saturate_by_linear_equalities sys @ sys in + let sys' = List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys in xlia (List.map fst sys) can_enum reduction_equations sys' let make_cstr_system sys = - List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys + List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys let nlia enum prfdepth sys = let sys = develop_constraints prfdepth z_spec sys in - let is_linear = List.for_all (fun ((p,_),_) -> LinPoly.is_linear p) sys in - + let is_linear = List.for_all (fun ((p, _), _) -> LinPoly.is_linear p) sys in if debug then begin - Printf.fprintf stdout "Input problem\n"; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; - end; - - if is_linear - then xlia (List.map fst sys) enum reduction_equations (make_cstr_system sys) + Printf.fprintf stdout "Input problem\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys + end; + if is_linear then + xlia (List.map fst sys) enum reduction_equations (make_cstr_system sys) else (* let sys1 = elim_every_substitution sys in @@ -1068,23 +1052,15 @@ let nlia enum prfdepth sys = *) let sys1 = elim_simple_linear_equality sys in let sys2 = saturate_by_linear_equalities sys1 in - let sys3 = nlinear_preprocess (sys1@sys2) in - - let sys4 = make_cstr_system ((*sys2@*)sys3) in + let sys3 = nlinear_preprocess (sys1 @ sys2) in + let sys4 = make_cstr_system (*sys2@*) sys3 in (* [reduction_equations] is too brutal - there should be some non-linear reasoning *) - xlia (List.map fst sys) enum reduction_equations sys4 + xlia (List.map fst sys) enum reduction_equations sys4 (* For regression testing, if bench = true generate a Coq goal *) -let lia can_enum prfdepth sys = - gen_bench ("lia",lia) can_enum prfdepth sys - -let nlia enum prfdepth sys = - gen_bench ("nia",nlia) enum prfdepth sys - - - - +let lia can_enum prfdepth sys = gen_bench ("lia", lia) can_enum prfdepth sys +let nlia enum prfdepth sys = gen_bench ("nia", nlia) enum prfdepth sys (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/certificate.mli b/plugins/micromega/certificate.mli index cd26b72a27..a8cc595ddf 100644 --- a/plugins/micromega/certificate.mli +++ b/plugins/micromega/certificate.mli @@ -10,42 +10,36 @@ module Mc = Micromega - +val use_simplex : bool ref (** [use_simplex] is bound to the Coq option Simplex. If set, use the Simplex method, otherwise use Fourier *) -val use_simplex : bool ref - -type ('prf,'model) res = - | Prf of 'prf - | Model of 'model - | Unknown - -type zres = (Mc.zArithProof , (int * Mc.z list)) res -type qres = (Mc.q Mc.psatz , (int * Mc.q list)) res +type ('prf, 'model) res = Prf of 'prf | Model of 'model | Unknown +type zres = (Mc.zArithProof, int * Mc.z list) res +type qres = (Mc.q Mc.psatz, int * Mc.q list) res +val dump_file : string option ref (** [dump_file] is bound to the Coq option Dump Arith. If set to some [file], arithmetic goals are dumped in filexxx.v *) -val dump_file : string option ref -(** [q_cert_of_pos prf] converts a Sos proof into a rational Coq proof *) val q_cert_of_pos : Sos_types.positivstellensatz -> Mc.q Mc.psatz +(** [q_cert_of_pos prf] converts a Sos proof into a rational Coq proof *) -(** [z_cert_of_pos prf] converts a Sos proof into an integer Coq proof *) val z_cert_of_pos : Sos_types.positivstellensatz -> Mc.z Mc.psatz +(** [z_cert_of_pos prf] converts a Sos proof into an integer Coq proof *) +val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres (** [lia enum depth sys] generates an unsat proof for the linear constraints in [sys]. If the Simplex option is set, any failure to find a proof should be considered as a bug. *) -val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres +val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres (** [nlia enum depth sys] generates an unsat proof for the non-linear constraints in [sys]. The solver is incomplete -- the problem is undecidable *) -val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres +val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres (** [linear_prover_with_cert depth sys] generates an unsat proof for the linear constraints in [sys]. Over the rationals, the solver is complete. *) -val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres +val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres (** [nlinear depth sys] generates an unsat proof for the non-linear constraints in [sys]. The solver is incompete -- the problem is decidable. *) -val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 1772a3c333..92a2222cfa 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -39,16 +39,11 @@ let max_depth = max_int (* Search limit for provers over Q R *) let lra_proof_depth = ref max_depth - (* Search limit for provers over Z *) -let lia_enum = ref true +let lia_enum = ref true let lia_proof_depth = ref max_depth - -let get_lia_option () = - (!Certificate.use_simplex,!lia_enum,!lia_proof_depth) - -let get_lra_option () = - !lra_proof_depth +let get_lia_option () = (!Certificate.use_simplex, !lia_enum, !lia_proof_depth) +let get_lra_option () = !lra_proof_depth (* Enable/disable caches *) @@ -58,87 +53,72 @@ let use_nra_cache = ref true let use_csdp_cache = ref true let () = - - let int_opt l vref = - { - optdepr = false; - optname = List.fold_right (^) l ""; - optkey = l ; - optread = (fun () -> Some !vref); - optwrite = (fun x -> vref := (match x with None -> max_depth | Some v -> v)) - } in - - let lia_enum_opt = - { - optdepr = false; - optname = "Lia Enum"; - optkey = ["Lia";"Enum"]; - optread = (fun () -> !lia_enum); - optwrite = (fun x -> lia_enum := x) - } in - - let solver_opt = - { - optdepr = false; - optname = "Use the Simplex instead of Fourier elimination"; - optkey = ["Simplex"]; - optread = (fun () -> !Certificate.use_simplex); - optwrite = (fun x -> Certificate.use_simplex := x) - } in - - let dump_file_opt = - { - optdepr = false; - optname = "Generate Coq goals in file from calls to 'lia' 'nia'"; - optkey = ["Dump"; "Arith"]; - optread = (fun () -> !Certificate.dump_file); - optwrite = (fun x -> Certificate.dump_file := x) - } in - - let lia_cache_opt = - { - optdepr = false; - optname = "cache of lia (.lia.cache)"; - optkey = ["Lia" ; "Cache"]; - optread = (fun () -> !use_lia_cache); - optwrite = (fun x -> use_lia_cache := x) - } in - - let nia_cache_opt = - { - optdepr = false; - optname = "cache of nia (.nia.cache)"; - optkey = ["Nia" ; "Cache"]; - optread = (fun () -> !use_nia_cache); - optwrite = (fun x -> use_nia_cache := x) - } in - - let nra_cache_opt = - { - optdepr = false; - optname = "cache of nra (.nra.cache)"; - optkey = ["Nra" ; "Cache"]; - optread = (fun () -> !use_nra_cache); - optwrite = (fun x -> use_nra_cache := x) - } in - - - let () = declare_bool_option solver_opt in - let () = declare_bool_option lia_cache_opt in - let () = declare_bool_option nia_cache_opt in - let () = declare_bool_option nra_cache_opt in - let () = declare_stringopt_option dump_file_opt in - let () = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in - let () = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in - let () = declare_bool_option lia_enum_opt in - () - + let int_opt l vref = + { optdepr = false + ; optname = List.fold_right ( ^ ) l "" + ; optkey = l + ; optread = (fun () -> Some !vref) + ; optwrite = + (fun x -> vref := match x with None -> max_depth | Some v -> v) } + in + let lia_enum_opt = + { optdepr = false + ; optname = "Lia Enum" + ; optkey = ["Lia"; "Enum"] + ; optread = (fun () -> !lia_enum) + ; optwrite = (fun x -> lia_enum := x) } + in + let solver_opt = + { optdepr = false + ; optname = "Use the Simplex instead of Fourier elimination" + ; optkey = ["Simplex"] + ; optread = (fun () -> !Certificate.use_simplex) + ; optwrite = (fun x -> Certificate.use_simplex := x) } + in + let dump_file_opt = + { optdepr = false + ; optname = "Generate Coq goals in file from calls to 'lia' 'nia'" + ; optkey = ["Dump"; "Arith"] + ; optread = (fun () -> !Certificate.dump_file) + ; optwrite = (fun x -> Certificate.dump_file := x) } + in + let lia_cache_opt = + { optdepr = false + ; optname = "cache of lia (.lia.cache)" + ; optkey = ["Lia"; "Cache"] + ; optread = (fun () -> !use_lia_cache) + ; optwrite = (fun x -> use_lia_cache := x) } + in + let nia_cache_opt = + { optdepr = false + ; optname = "cache of nia (.nia.cache)" + ; optkey = ["Nia"; "Cache"] + ; optread = (fun () -> !use_nia_cache) + ; optwrite = (fun x -> use_nia_cache := x) } + in + let nra_cache_opt = + { optdepr = false + ; optname = "cache of nra (.nra.cache)" + ; optkey = ["Nra"; "Cache"] + ; optread = (fun () -> !use_nra_cache) + ; optwrite = (fun x -> use_nra_cache := x) } + in + let () = declare_bool_option solver_opt in + let () = declare_bool_option lia_cache_opt in + let () = declare_bool_option nia_cache_opt in + let () = declare_bool_option nra_cache_opt in + let () = declare_stringopt_option dump_file_opt in + let () = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in + let () = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in + let () = declare_bool_option lia_enum_opt in + () (** * Initialize a tag type to the Tag module declaration (see Mutils). *) type tag = Tag.t + module Mc = Micromega (** @@ -150,29 +130,26 @@ module Mc = Micromega type 'cst atom = 'cst Mc.formula -type 'cst formula = ('cst atom, EConstr.constr,tag * EConstr.constr,Names.Id.t) Mc.gFormula +type 'cst formula = + ('cst atom, EConstr.constr, tag * EConstr.constr, Names.Id.t) Mc.gFormula type 'cst clause = ('cst Mc.nFormula, tag * EConstr.constr) Mc.clause type 'cst cnf = ('cst Mc.nFormula, tag * EConstr.constr) Mc.cnf - -let rec pp_formula o (f:'cst formula) = +let rec pp_formula o (f : 'cst formula) = Mc.( - match f with - | TT -> output_string o "tt" - | FF -> output_string o "ff" + match f with + | TT -> output_string o "tt" + | FF -> output_string o "ff" | X c -> output_string o "X " - | A(_,(t,_)) -> Printf.fprintf o "A(%a)" Tag.pp t - | Cj(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 - | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 - | I(f1,n,f2) -> Printf.fprintf o "I(%a,%s,%a)" - pp_formula f1 - (match n with - | Some id -> Names.Id.to_string id - | None -> "") pp_formula f2 - | N(f) -> Printf.fprintf o "N(%a)" pp_formula f - ) - + | A (_, (t, _)) -> Printf.fprintf o "A(%a)" Tag.pp t + | Cj (f1, f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 + | D (f1, f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 + | I (f1, n, f2) -> + Printf.fprintf o "I(%a,%s,%a)" pp_formula f1 + (match n with Some id -> Names.Id.to_string id | None -> "") + pp_formula f2 + | N f -> Printf.fprintf o "N(%a)" pp_formula f) (** * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of @@ -182,9 +159,11 @@ let rec pp_formula o (f:'cst formula) = let selecti s m = let rec xselecti i m = match m with - | [] -> [] - | e::m -> if ISet.mem i s then e::(xselecti (i+1) m) else xselecti (i+1) m in - xselecti 0 m + | [] -> [] + | e :: m -> + if ISet.mem i s then e :: xselecti (i + 1) m else xselecti (i + 1) m + in + xselecti 0 m (** * MODULE: Mapping of the Coq data-strustures into Caml and Caml extracted @@ -194,57 +173,62 @@ let selecti s m = * Opened here and in csdpcert.ml. *) -module M = -struct - +(** + * MODULE END: M + *) +module M = struct (** * Location of the Coq libraries. *) - let logic_dir = ["Coq";"Logic";"Decidable"] + let logic_dir = ["Coq"; "Logic"; "Decidable"] let mic_modules = - [ - ["Coq";"Lists";"List"]; - ["Coq"; "micromega";"ZMicromega"]; - ["Coq"; "micromega";"Tauto"]; - ["Coq"; "micromega"; "DeclConstant"]; - ["Coq"; "micromega";"RingMicromega"]; - ["Coq"; "micromega";"EnvRing"]; - ["Coq"; "micromega"; "ZMicromega"]; - ["Coq"; "micromega"; "RMicromega"]; - ["Coq" ; "micromega" ; "Tauto"]; - ["Coq" ; "micromega" ; "RingMicromega"]; - ["Coq" ; "micromega" ; "EnvRing"]; - ["Coq";"QArith"; "QArith_base"]; - ["Coq";"Reals" ; "Rdefinitions"]; - ["Coq";"Reals" ; "Rpow_def"]; - ["LRing_normalise"]] - -[@@@ocaml.warning "-3"] + [ ["Coq"; "Lists"; "List"] + ; ["Coq"; "micromega"; "ZMicromega"] + ; ["Coq"; "micromega"; "Tauto"] + ; ["Coq"; "micromega"; "DeclConstant"] + ; ["Coq"; "micromega"; "RingMicromega"] + ; ["Coq"; "micromega"; "EnvRing"] + ; ["Coq"; "micromega"; "ZMicromega"] + ; ["Coq"; "micromega"; "RMicromega"] + ; ["Coq"; "micromega"; "Tauto"] + ; ["Coq"; "micromega"; "RingMicromega"] + ; ["Coq"; "micromega"; "EnvRing"] + ; ["Coq"; "QArith"; "QArith_base"] + ; ["Coq"; "Reals"; "Rdefinitions"] + ; ["Coq"; "Reals"; "Rpow_def"] + ; ["LRing_normalise"] ] + + [@@@ocaml.warning "-3"] let coq_modules = - Coqlib.(init_modules @ - [logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules) + Coqlib.( + init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules + @ mic_modules) - let bin_module = [["Coq";"Numbers";"BinNums"]] + let bin_module = [["Coq"; "Numbers"; "BinNums"]] let r_modules = - [["Coq";"Reals" ; "Rdefinitions"]; - ["Coq";"Reals" ; "Rpow_def"] ; - ["Coq";"Reals" ; "Raxioms"] ; - ["Coq";"QArith"; "Qreals"] ; - ] + [ ["Coq"; "Reals"; "Rdefinitions"] + ; ["Coq"; "Reals"; "Rpow_def"] + ; ["Coq"; "Reals"; "Raxioms"] + ; ["Coq"; "QArith"; "Qreals"] ] - let z_modules = [["Coq";"ZArith";"BinInt"]] + let z_modules = [["Coq"; "ZArith"; "BinInt"]] (** * Initialization : a large amount of Caml symbols are derived from * ZMicromega.v *) - let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.gen_reference_in_modules s m n) + let gen_constant_in_modules s m n = + EConstr.of_constr + ( UnivGen.constr_of_monomorphic_global + @@ Coqlib.gen_reference_in_modules s m n ) + let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules + [@@@ocaml.warning "+3"] let constant = gen_constant_in_modules "ZMicromega" coq_modules @@ -252,98 +236,78 @@ struct let r_constant = gen_constant_in_modules "ZMicromega" r_modules let z_constant = gen_constant_in_modules "ZMicromega" z_modules let m_constant = gen_constant_in_modules "ZMicromega" mic_modules - let coq_and = lazy (init_constant "and") let coq_or = lazy (init_constant "or") let coq_not = lazy (init_constant "not") - let coq_iff = lazy (init_constant "iff") let coq_True = lazy (init_constant "True") let coq_False = lazy (init_constant "False") - let coq_cons = lazy (constant "cons") let coq_nil = lazy (constant "nil") let coq_list = lazy (constant "list") - let coq_O = lazy (init_constant "O") let coq_S = lazy (init_constant "S") - let coq_nat = lazy (init_constant "nat") let coq_unit = lazy (init_constant "unit") + (* let coq_option = lazy (init_constant "option")*) let coq_None = lazy (init_constant "None") let coq_tt = lazy (init_constant "tt") let coq_Inl = lazy (init_constant "inl") let coq_Inr = lazy (init_constant "inr") - - let coq_N0 = lazy (bin_constant "N0") let coq_Npos = lazy (bin_constant "Npos") - let coq_xH = lazy (bin_constant "xH") let coq_xO = lazy (bin_constant "xO") let coq_xI = lazy (bin_constant "xI") - let coq_Z = lazy (bin_constant "Z") let coq_ZERO = lazy (bin_constant "Z0") let coq_POS = lazy (bin_constant "Zpos") let coq_NEG = lazy (bin_constant "Zneg") - let coq_Q = lazy (constant "Q") let coq_R = lazy (constant "R") - let coq_Qmake = lazy (constant "Qmake") - let coq_Rcst = lazy (constant "Rcst") - - let coq_C0 = lazy (m_constant "C0") - let coq_C1 = lazy (m_constant "C1") - let coq_CQ = lazy (m_constant "CQ") - let coq_CZ = lazy (m_constant "CZ") + let coq_C0 = lazy (m_constant "C0") + let coq_C1 = lazy (m_constant "C1") + let coq_CQ = lazy (m_constant "CQ") + let coq_CZ = lazy (m_constant "CZ") let coq_CPlus = lazy (m_constant "CPlus") let coq_CMinus = lazy (m_constant "CMinus") - let coq_CMult = lazy (m_constant "CMult") - let coq_CPow = lazy (m_constant "CPow") - let coq_CInv = lazy (m_constant "CInv") - let coq_COpp = lazy (m_constant "COpp") - - - let coq_R0 = lazy (constant "R0") - let coq_R1 = lazy (constant "R1") - + let coq_CMult = lazy (m_constant "CMult") + let coq_CPow = lazy (m_constant "CPow") + let coq_CInv = lazy (m_constant "CInv") + let coq_COpp = lazy (m_constant "COpp") + let coq_R0 = lazy (constant "R0") + let coq_R1 = lazy (constant "R1") let coq_proofTerm = lazy (constant "ZArithProof") let coq_doneProof = lazy (constant "DoneProof") let coq_ratProof = lazy (constant "RatProof") let coq_cutProof = lazy (constant "CutProof") let coq_enumProof = lazy (constant "EnumProof") - + let coq_ExProof = lazy (constant "ExProof") let coq_Zgt = lazy (z_constant "Z.gt") let coq_Zge = lazy (z_constant "Z.ge") let coq_Zle = lazy (z_constant "Z.le") let coq_Zlt = lazy (z_constant "Z.lt") - let coq_Eq = lazy (init_constant "eq") - + let coq_Eq = lazy (init_constant "eq") let coq_Zplus = lazy (z_constant "Z.add") let coq_Zminus = lazy (z_constant "Z.sub") let coq_Zopp = lazy (z_constant "Z.opp") let coq_Zmult = lazy (z_constant "Z.mul") let coq_Zpower = lazy (z_constant "Z.pow") - let coq_Qle = lazy (constant "Qle") let coq_Qlt = lazy (constant "Qlt") let coq_Qeq = lazy (constant "Qeq") - let coq_Qplus = lazy (constant "Qplus") let coq_Qminus = lazy (constant "Qminus") let coq_Qopp = lazy (constant "Qopp") let coq_Qmult = lazy (constant "Qmult") let coq_Qpower = lazy (constant "Qpower") - let coq_Rgt = lazy (r_constant "Rgt") let coq_Rge = lazy (r_constant "Rge") let coq_Rle = lazy (r_constant "Rle") let coq_Rlt = lazy (r_constant "Rlt") - let coq_Rplus = lazy (r_constant "Rplus") let coq_Rminus = lazy (r_constant "Rminus") let coq_Ropp = lazy (r_constant "Ropp") @@ -351,85 +315,112 @@ struct let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") let coq_powerZR = lazy (r_constant "powerRZ") - let coq_IZR = lazy (r_constant "IZR") - let coq_IQR = lazy (r_constant "Q2R") - - - let coq_PEX = lazy (constant "PEX" ) - let coq_PEc = lazy (constant"PEc") + let coq_IZR = lazy (r_constant "IZR") + let coq_IQR = lazy (r_constant "Q2R") + let coq_PEX = lazy (constant "PEX") + let coq_PEc = lazy (constant "PEc") let coq_PEadd = lazy (constant "PEadd") let coq_PEopp = lazy (constant "PEopp") let coq_PEmul = lazy (constant "PEmul") let coq_PEsub = lazy (constant "PEsub") let coq_PEpow = lazy (constant "PEpow") - - let coq_PX = lazy (constant "PX" ) - let coq_Pc = lazy (constant"Pc") + let coq_PX = lazy (constant "PX") + let coq_Pc = lazy (constant "Pc") let coq_Pinj = lazy (constant "Pinj") - let coq_OpEq = lazy (constant "OpEq") let coq_OpNEq = lazy (constant "OpNEq") let coq_OpLe = lazy (constant "OpLe") - let coq_OpLt = lazy (constant "OpLt") + let coq_OpLt = lazy (constant "OpLt") let coq_OpGe = lazy (constant "OpGe") - let coq_OpGt = lazy (constant "OpGt") - + let coq_OpGt = lazy (constant "OpGt") let coq_PsatzIn = lazy (constant "PsatzIn") let coq_PsatzSquare = lazy (constant "PsatzSquare") let coq_PsatzMulE = lazy (constant "PsatzMulE") let coq_PsatzMultC = lazy (constant "PsatzMulC") - let coq_PsatzAdd = lazy (constant "PsatzAdd") - let coq_PsatzC = lazy (constant "PsatzC") - let coq_PsatzZ = lazy (constant "PsatzZ") + let coq_PsatzAdd = lazy (constant "PsatzAdd") + let coq_PsatzC = lazy (constant "PsatzC") + let coq_PsatzZ = lazy (constant "PsatzZ") (* let coq_GT = lazy (m_constant "GT")*) let coq_DeclaredConstant = lazy (m_constant "DeclaredConstant") - let coq_TT = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") - let coq_FF = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF") - let coq_And = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj") - let coq_Or = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D") - let coq_Neg = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N") - let coq_Atom = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A") - let coq_X = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X") - let coq_Impl = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I") - let coq_Formula = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula") + let coq_TT = + lazy + (gen_constant_in_modules "ZMicromega" + [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] + "TT") + + let coq_FF = + lazy + (gen_constant_in_modules "ZMicromega" + [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] + "FF") + + let coq_And = + lazy + (gen_constant_in_modules "ZMicromega" + [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] + "Cj") + + let coq_Or = + lazy + (gen_constant_in_modules "ZMicromega" + [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] + "D") + + let coq_Neg = + lazy + (gen_constant_in_modules "ZMicromega" + [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] + "N") + + let coq_Atom = + lazy + (gen_constant_in_modules "ZMicromega" + [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] + "A") + + let coq_X = + lazy + (gen_constant_in_modules "ZMicromega" + [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] + "X") + + let coq_Impl = + lazy + (gen_constant_in_modules "ZMicromega" + [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] + "I") + + let coq_Formula = + lazy + (gen_constant_in_modules "ZMicromega" + [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] + "BFormula") (** * Initialization : a few Caml symbols are derived from other libraries; * QMicromega, ZArithRing, RingMicromega. *) - let coq_QWitness = lazy - (gen_constant_in_modules "QMicromega" - [["Coq"; "micromega"; "QMicromega"]] "QWitness") + let coq_QWitness = + lazy + (gen_constant_in_modules "QMicromega" + [["Coq"; "micromega"; "QMicromega"]] + "QWitness") + + let coq_Build = + lazy + (gen_constant_in_modules "RingMicromega" + [["Coq"; "micromega"; "RingMicromega"]; ["RingMicromega"]] + "Build_Formula") - let coq_Build = lazy - (gen_constant_in_modules "RingMicromega" - [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] - "Build_Formula") - let coq_Cstr = lazy - (gen_constant_in_modules "RingMicromega" - [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula") + let coq_Cstr = + lazy + (gen_constant_in_modules "RingMicromega" + [["Coq"; "micromega"; "RingMicromega"]; ["RingMicromega"]] + "Formula") (** * Parsing and dumping : transformation functions between Caml and Coq @@ -445,35 +436,34 @@ struct (* A simple but useful getter function *) let get_left_construct sigma term = - match EConstr.kind sigma term with - | Construct((_,i),_) -> (i,[| |]) - | App(l,rst) -> - (match EConstr.kind sigma l with - | Construct((_,i),_) -> (i,rst) - | _ -> raise ParseError - ) - | _ -> raise ParseError + match EConstr.kind sigma term with + | Construct ((_, i), _) -> (i, [||]) + | App (l, rst) -> ( + match EConstr.kind sigma l with + | Construct ((_, i), _) -> (i, rst) + | _ -> raise ParseError ) + | _ -> raise ParseError (* Access the Micromega module *) (* parse/dump/print from numbers up to expressions and formulas *) let rec parse_nat sigma term = - let (i,c) = get_left_construct sigma term in + let i, c = get_left_construct sigma term in match i with - | 1 -> Mc.O - | 2 -> Mc.S (parse_nat sigma (c.(0))) - | i -> raise ParseError + | 1 -> Mc.O + | 2 -> Mc.S (parse_nat sigma c.(0)) + | i -> raise ParseError let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) let rec dump_nat x = - match x with + match x with | Mc.O -> Lazy.force coq_O - | Mc.S p -> EConstr.mkApp(Lazy.force coq_S,[| dump_nat p |]) + | Mc.S p -> EConstr.mkApp (Lazy.force coq_S, [|dump_nat p|]) let rec parse_positive sigma term = - let (i,c) = get_left_construct sigma term in + let i, c = get_left_construct sigma term in match i with | 1 -> Mc.XI (parse_positive sigma c.(0)) | 2 -> Mc.XO (parse_positive sigma c.(0)) @@ -483,15 +473,15 @@ struct let rec dump_positive x = match x with | Mc.XH -> Lazy.force coq_xH - | Mc.XO p -> EConstr.mkApp(Lazy.force coq_xO,[| dump_positive p |]) - | Mc.XI p -> EConstr.mkApp(Lazy.force coq_xI,[| dump_positive p |]) + | Mc.XO p -> EConstr.mkApp (Lazy.force coq_xO, [|dump_positive p|]) + | Mc.XI p -> EConstr.mkApp (Lazy.force coq_xI, [|dump_positive p|]) let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) let dump_n x = match x with | Mc.N0 -> Lazy.force coq_N0 - | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) + | Mc.Npos p -> EConstr.mkApp (Lazy.force coq_Npos, [|dump_positive p|]) (** [is_ground_term env sigma term] holds if the term [term] is an instance of the typeclass [DeclConstant.GT term] @@ -502,26 +492,26 @@ struct let is_declared_term env evd t = match EConstr.kind evd t with - | Const _ | Construct _ -> (* Restrict typeclass resolution to trivial cases *) - begin - let typ = Retyping.get_type_of env evd t in - try - ignore (Typeclasses.resolve_one_typeclass env evd (EConstr.mkApp(Lazy.force coq_DeclaredConstant,[| typ;t|]))) ; true - with Not_found -> false - end - | _ -> false + | Const _ | Construct _ -> ( + (* Restrict typeclass resolution to trivial cases *) + let typ = Retyping.get_type_of env evd t in + try + ignore + (Typeclasses.resolve_one_typeclass env evd + (EConstr.mkApp (Lazy.force coq_DeclaredConstant, [|typ; t|]))); + true + with Not_found -> false ) + | _ -> false let rec is_ground_term env evd term = match EConstr.kind evd term with - | App(c,args) -> - is_declared_term env evd c && - Array.for_all (is_ground_term env evd) args + | App (c, args) -> + is_declared_term env evd c && Array.for_all (is_ground_term env evd) args | Const _ | Construct _ -> is_declared_term env evd term - | _ -> false - + | _ -> false let parse_z sigma term = - let (i,c) = get_left_construct sigma term in + let i, c = get_left_construct sigma term in match i with | 1 -> Mc.Z0 | 2 -> Mc.Zpos (parse_positive sigma c.(0)) @@ -529,221 +519,246 @@ struct | i -> raise ParseError let dump_z x = - match x with - | Mc.Z0 ->Lazy.force coq_ZERO - | Mc.Zpos p -> EConstr.mkApp(Lazy.force coq_POS,[| dump_positive p|]) - | Mc.Zneg p -> EConstr.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) + match x with + | Mc.Z0 -> Lazy.force coq_ZERO + | Mc.Zpos p -> EConstr.mkApp (Lazy.force coq_POS, [|dump_positive p|]) + | Mc.Zneg p -> EConstr.mkApp (Lazy.force coq_NEG, [|dump_positive p|]) - let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) + let pp_z o x = + Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) let dump_q q = - EConstr.mkApp(Lazy.force coq_Qmake, - [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) + EConstr.mkApp + ( Lazy.force coq_Qmake + , [|dump_z q.Micromega.qnum; dump_positive q.Micromega.qden|] ) let parse_q sigma term = - match EConstr.kind sigma term with - | App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then - {Mc.qnum = parse_z sigma args.(0) ; Mc.qden = parse_positive sigma args.(1) } - else raise ParseError - | _ -> raise ParseError - + match EConstr.kind sigma term with + | App (c, args) -> + if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then + { Mc.qnum = parse_z sigma args.(0) + ; Mc.qden = parse_positive sigma args.(1) } + else raise ParseError + | _ -> raise ParseError let rec pp_Rcst o cst = match cst with - | Mc.C0 -> output_string o "C0" - | Mc.C1 -> output_string o "C1" - | Mc.CQ q -> output_string o "CQ _" - | Mc.CZ z -> pp_z o z - | Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y - | Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y - | Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y - | Mc.CPow(x,y) -> Printf.fprintf o "(%a ^ _)" pp_Rcst x - | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t - | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t - + | Mc.C0 -> output_string o "C0" + | Mc.C1 -> output_string o "C1" + | Mc.CQ q -> output_string o "CQ _" + | Mc.CZ z -> pp_z o z + | Mc.CPlus (x, y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y + | Mc.CMinus (x, y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y + | Mc.CMult (x, y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y + | Mc.CPow (x, y) -> Printf.fprintf o "(%a ^ _)" pp_Rcst x + | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t + | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t let rec dump_Rcst cst = match cst with - | Mc.C0 -> Lazy.force coq_C0 - | Mc.C1 -> Lazy.force coq_C1 - | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_CQ, [| dump_q q |]) - | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_CZ, [| dump_z z |]) - | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_CPlus, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_CMinus, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_CMult, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CPow(x,y) -> EConstr.mkApp(Lazy.force coq_CPow, [| dump_Rcst x ; - match y with - | Mc.Inl z -> EConstr.mkApp(Lazy.force coq_Inl,[| Lazy.force coq_Z ; Lazy.force coq_nat; dump_z z|]) - | Mc.Inr n -> EConstr.mkApp(Lazy.force coq_Inr,[| Lazy.force coq_Z ; Lazy.force coq_nat; dump_nat n|]) - |]) - | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) - | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) + | Mc.C0 -> Lazy.force coq_C0 + | Mc.C1 -> Lazy.force coq_C1 + | Mc.CQ q -> EConstr.mkApp (Lazy.force coq_CQ, [|dump_q q|]) + | Mc.CZ z -> EConstr.mkApp (Lazy.force coq_CZ, [|dump_z z|]) + | Mc.CPlus (x, y) -> + EConstr.mkApp (Lazy.force coq_CPlus, [|dump_Rcst x; dump_Rcst y|]) + | Mc.CMinus (x, y) -> + EConstr.mkApp (Lazy.force coq_CMinus, [|dump_Rcst x; dump_Rcst y|]) + | Mc.CMult (x, y) -> + EConstr.mkApp (Lazy.force coq_CMult, [|dump_Rcst x; dump_Rcst y|]) + | Mc.CPow (x, y) -> + EConstr.mkApp + ( Lazy.force coq_CPow + , [| dump_Rcst x + ; ( match y with + | Mc.Inl z -> + EConstr.mkApp + ( Lazy.force coq_Inl + , [|Lazy.force coq_Z; Lazy.force coq_nat; dump_z z|] ) + | Mc.Inr n -> + EConstr.mkApp + ( Lazy.force coq_Inr + , [|Lazy.force coq_Z; Lazy.force coq_nat; dump_nat n|] ) ) |] + ) + | Mc.CInv t -> EConstr.mkApp (Lazy.force coq_CInv, [|dump_Rcst t|]) + | Mc.COpp t -> EConstr.mkApp (Lazy.force coq_COpp, [|dump_Rcst t|]) let rec dump_list typ dump_elt l = - match l with - | [] -> EConstr.mkApp(Lazy.force coq_nil,[| typ |]) - | e :: l -> EConstr.mkApp(Lazy.force coq_cons, - [| typ; dump_elt e;dump_list typ dump_elt l|]) + match l with + | [] -> EConstr.mkApp (Lazy.force coq_nil, [|typ|]) + | e :: l -> + EConstr.mkApp + (Lazy.force coq_cons, [|typ; dump_elt e; dump_list typ dump_elt l|]) let pp_list op cl elt o l = - let rec _pp o l = - match l with - | [] -> () - | [e] -> Printf.fprintf o "%a" elt e - | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in + let rec _pp o l = + match l with + | [] -> () + | [e] -> Printf.fprintf o "%a" elt e + | e :: l -> Printf.fprintf o "%a ,%a" elt e _pp l + in Printf.fprintf o "%s%a%s" op _pp l cl let dump_var = dump_positive let dump_expr typ dump_z e = - let rec dump_expr e = - match e with - | Mc.PEX n -> EConstr.mkApp(Lazy.force coq_PEX,[| typ; dump_var n |]) - | Mc.PEc z -> EConstr.mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |]) - | Mc.PEadd(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEadd, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEsub(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEsub, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEopp e -> EConstr.mkApp(Lazy.force coq_PEopp, - [| typ; dump_expr e|]) - | Mc.PEmul(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEmul, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEpow(e,n) -> EConstr.mkApp(Lazy.force coq_PEpow, - [| typ; dump_expr e; dump_n n|]) - in + let rec dump_expr e = + match e with + | Mc.PEX n -> EConstr.mkApp (Lazy.force coq_PEX, [|typ; dump_var n|]) + | Mc.PEc z -> EConstr.mkApp (Lazy.force coq_PEc, [|typ; dump_z z|]) + | Mc.PEadd (e1, e2) -> + EConstr.mkApp (Lazy.force coq_PEadd, [|typ; dump_expr e1; dump_expr e2|]) + | Mc.PEsub (e1, e2) -> + EConstr.mkApp (Lazy.force coq_PEsub, [|typ; dump_expr e1; dump_expr e2|]) + | Mc.PEopp e -> EConstr.mkApp (Lazy.force coq_PEopp, [|typ; dump_expr e|]) + | Mc.PEmul (e1, e2) -> + EConstr.mkApp (Lazy.force coq_PEmul, [|typ; dump_expr e1; dump_expr e2|]) + | Mc.PEpow (e, n) -> + EConstr.mkApp (Lazy.force coq_PEpow, [|typ; dump_expr e; dump_n n|]) + in dump_expr e let dump_pol typ dump_c e = let rec dump_pol e = match e with - | Mc.Pc n -> EConstr.mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|]) - | Mc.Pinj(p,pol) -> EConstr.mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|]) - | Mc.PX(pol1,p,pol2) -> EConstr.mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in - dump_pol e + | Mc.Pc n -> EConstr.mkApp (Lazy.force coq_Pc, [|typ; dump_c n|]) + | Mc.Pinj (p, pol) -> + EConstr.mkApp + (Lazy.force coq_Pinj, [|typ; dump_positive p; dump_pol pol|]) + | Mc.PX (pol1, p, pol2) -> + EConstr.mkApp + ( Lazy.force coq_PX + , [|typ; dump_pol pol1; dump_positive p; dump_pol pol2|] ) + in + dump_pol e let pp_pol pp_c o e = let rec pp_pol o e = match e with - | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n - | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol - | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in - pp_pol o e + | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n + | Mc.Pinj (p, pol) -> + Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol + | Mc.PX (pol1, p, pol2) -> + Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 + in + pp_pol o e -(* let pp_clause pp_c o (f: 'cst clause) = + (* let pp_clause pp_c o (f: 'cst clause) = List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) f *) - let pp_clause_tag o (f: 'cst clause) = - List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(_ @%a)" Tag.pp t) f + let pp_clause_tag o (f : 'cst clause) = + List.iter (fun ((p, _), (t, _)) -> Printf.fprintf o "(_ @%a)" Tag.pp t) f -(* let pp_cnf pp_c o (f:'cst cnf) = + (* let pp_cnf pp_c o (f:'cst cnf) = List.iter (fun l -> Printf.fprintf o "[%a]" (pp_clause pp_c) l) f *) - let pp_cnf_tag o (f:'cst cnf) = + let pp_cnf_tag o (f : 'cst cnf) = List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause_tag l) f - let dump_psatz typ dump_z e = - let z = Lazy.force typ in - let rec dump_cone e = - match e with - | Mc.PsatzIn n -> EConstr.mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |]) - | Mc.PsatzMulC(e,c) -> EConstr.mkApp(Lazy.force coq_PsatzMultC, - [| z; dump_pol z dump_z e ; dump_cone c |]) - | Mc.PsatzSquare e -> EConstr.mkApp(Lazy.force coq_PsatzSquare, - [| z;dump_pol z dump_z e|]) - | Mc.PsatzAdd(e1,e2) -> EConstr.mkApp(Lazy.force coq_PsatzAdd, - [| z; dump_cone e1; dump_cone e2|]) - | Mc.PsatzMulE(e1,e2) -> EConstr.mkApp(Lazy.force coq_PsatzMulE, - [| z; dump_cone e1; dump_cone e2|]) - | Mc.PsatzC p -> EConstr.mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|]) - | Mc.PsatzZ -> EConstr.mkApp(Lazy.force coq_PsatzZ,[| z|]) in - dump_cone e - - let pp_psatz pp_z o e = - let rec pp_cone o e = - match e with - | Mc.PsatzIn n -> - Printf.fprintf o "(In %a)%%nat" pp_nat n - | Mc.PsatzMulC(e,c) -> + let z = Lazy.force typ in + let rec dump_cone e = + match e with + | Mc.PsatzIn n -> EConstr.mkApp (Lazy.force coq_PsatzIn, [|z; dump_nat n|]) + | Mc.PsatzMulC (e, c) -> + EConstr.mkApp + (Lazy.force coq_PsatzMultC, [|z; dump_pol z dump_z e; dump_cone c|]) + | Mc.PsatzSquare e -> + EConstr.mkApp (Lazy.force coq_PsatzSquare, [|z; dump_pol z dump_z e|]) + | Mc.PsatzAdd (e1, e2) -> + EConstr.mkApp + (Lazy.force coq_PsatzAdd, [|z; dump_cone e1; dump_cone e2|]) + | Mc.PsatzMulE (e1, e2) -> + EConstr.mkApp + (Lazy.force coq_PsatzMulE, [|z; dump_cone e1; dump_cone e2|]) + | Mc.PsatzC p -> EConstr.mkApp (Lazy.force coq_PsatzC, [|z; dump_z p|]) + | Mc.PsatzZ -> EConstr.mkApp (Lazy.force coq_PsatzZ, [|z|]) + in + dump_cone e + + let pp_psatz pp_z o e = + let rec pp_cone o e = + match e with + | Mc.PsatzIn n -> Printf.fprintf o "(In %a)%%nat" pp_nat n + | Mc.PsatzMulC (e, c) -> Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c - | Mc.PsatzSquare e -> - Printf.fprintf o "(%a^2)" (pp_pol pp_z) e - | Mc.PsatzAdd(e1,e2) -> + | Mc.PsatzSquare e -> Printf.fprintf o "(%a^2)" (pp_pol pp_z) e + | Mc.PsatzAdd (e1, e2) -> Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzMulE(e1,e2) -> + | Mc.PsatzMulE (e1, e2) -> Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzC p -> - Printf.fprintf o "(%a)%%positive" pp_z p - | Mc.PsatzZ -> - Printf.fprintf o "0" in + | Mc.PsatzC p -> Printf.fprintf o "(%a)%%positive" pp_z p + | Mc.PsatzZ -> Printf.fprintf o "0" + in pp_cone o e let dump_op = function - | Mc.OpEq-> Lazy.force coq_OpEq - | Mc.OpNEq-> Lazy.force coq_OpNEq - | Mc.OpLe -> Lazy.force coq_OpLe - | Mc.OpGe -> Lazy.force coq_OpGe - | Mc.OpGt-> Lazy.force coq_OpGt - | Mc.OpLt-> Lazy.force coq_OpLt - - let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = - EConstr.mkApp(Lazy.force coq_Build, - [| typ; dump_expr typ dump_constant e1 ; - dump_op o ; - dump_expr typ dump_constant e2|]) + | Mc.OpEq -> Lazy.force coq_OpEq + | Mc.OpNEq -> Lazy.force coq_OpNEq + | Mc.OpLe -> Lazy.force coq_OpLe + | Mc.OpGe -> Lazy.force coq_OpGe + | Mc.OpGt -> Lazy.force coq_OpGt + | Mc.OpLt -> Lazy.force coq_OpLt + + let dump_cstr typ dump_constant {Mc.flhs = e1; Mc.fop = o; Mc.frhs = e2} = + EConstr.mkApp + ( Lazy.force coq_Build + , [| typ + ; dump_expr typ dump_constant e1 + ; dump_op o + ; dump_expr typ dump_constant e2 |] ) let assoc_const sigma x l = - try - snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) - with - Not_found -> raise ParseError - - let zop_table = [ - coq_Zgt, Mc.OpGt ; - coq_Zge, Mc.OpGe ; - coq_Zlt, Mc.OpLt ; - coq_Zle, Mc.OpLe ] - - let rop_table = [ - coq_Rgt, Mc.OpGt ; - coq_Rge, Mc.OpGe ; - coq_Rlt, Mc.OpLt ; - coq_Rle, Mc.OpLe ] - - let qop_table = [ - coq_Qlt, Mc.OpLt ; - coq_Qle, Mc.OpLe ; - coq_Qeq, Mc.OpEq - ] - - type gl = { env : Environ.env; sigma : Evd.evar_map } - - let is_convertible gl t1 t2 = - Reductionops.is_conv gl.env gl.sigma t1 t2 - - let parse_zop gl (op,args) = + try + snd + (List.find (fun (x', y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) + with Not_found -> raise ParseError + + let zop_table = + [ (coq_Zgt, Mc.OpGt) + ; (coq_Zge, Mc.OpGe) + ; (coq_Zlt, Mc.OpLt) + ; (coq_Zle, Mc.OpLe) ] + + let rop_table = + [ (coq_Rgt, Mc.OpGt) + ; (coq_Rge, Mc.OpGe) + ; (coq_Rlt, Mc.OpLt) + ; (coq_Rle, Mc.OpLe) ] + + let qop_table = [(coq_Qlt, Mc.OpLt); (coq_Qle, Mc.OpLe); (coq_Qeq, Mc.OpEq)] + + type gl = {env : Environ.env; sigma : Evd.evar_map} + + let is_convertible gl t1 t2 = Reductionops.is_conv gl.env gl.sigma t1 t2 + + let parse_zop gl (op, args) = let sigma = gl.sigma in match args with - | [| a1 ; a2|] -> assoc_const sigma op zop_table, a1, a2 - | [| ty ; a1 ; a2|] -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl ty (Lazy.force coq_Z) - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> raise ParseError - - let parse_rop gl (op,args) = + | [|a1; a2|] -> (assoc_const sigma op zop_table, a1, a2) + | [|ty; a1; a2|] -> + if + EConstr.eq_constr sigma op (Lazy.force coq_Eq) + && is_convertible gl ty (Lazy.force coq_Z) + then (Mc.OpEq, args.(1), args.(2)) + else raise ParseError + | _ -> raise ParseError + + let parse_rop gl (op, args) = let sigma = gl.sigma in match args with - | [| a1 ; a2|] -> assoc_const sigma op rop_table, a1 , a2 - | [| ty ; a1 ; a2|] -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl ty (Lazy.force coq_R) - then (Mc.OpEq, a1, a2) - else raise ParseError - | _ -> raise ParseError - - let parse_qop gl (op,args) = - if Array.length args = 2 - then (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) + | [|a1; a2|] -> (assoc_const sigma op rop_table, a1, a2) + | [|ty; a1; a2|] -> + if + EConstr.eq_constr sigma op (Lazy.force coq_Eq) + && is_convertible gl ty (Lazy.force coq_R) + then (Mc.OpEq, a1, a2) + else raise ParseError + | _ -> raise ParseError + + let parse_qop gl (op, args) = + if Array.length args = 2 then + (assoc_const gl.sigma op qop_table, args.(0), args.(1)) else raise ParseError type 'a op = @@ -753,74 +768,65 @@ struct | Ukn of string let assoc_ops sigma x l = - try - snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) - with - Not_found -> Ukn "Oups" + try + snd + (List.find (fun (x', y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) + with Not_found -> Ukn "Oups" (** * MODULE: Env is for environment. *) - module Env = - struct - - type t = { - vars : EConstr.t list ; - (* The list represents a mapping from EConstr.t to indexes. *) - gl : gl; - (* The evar_map may be updated due to unification of universes *) - } - - let empty gl = - { - vars = []; - gl = gl - } + module Env = struct + type t = + { vars : EConstr.t list + ; (* The list represents a mapping from EConstr.t to indexes. *) + gl : gl + (* The evar_map may be updated due to unification of universes *) } + let empty gl = {vars = []; gl} (** [eq_constr gl x y] returns an updated [gl] if x and y can be unified *) let eq_constr gl x y = let evd = gl.sigma in match EConstr.eq_constr_universes_proj gl.env evd x y with - | Some csts -> - let csts = UnivProblem.to_constraints ~force_weak:false (Evd.universes evd) csts in - begin - match Evd.add_constraints evd csts with - | evd -> Some {gl with sigma = evd} - | exception Univ.UniverseInconsistency _ -> None - end + | Some csts -> ( + let csts = + UnivProblem.to_constraints ~force_weak:false (Evd.universes evd) csts + in + match Evd.add_constraints evd csts with + | evd -> Some {gl with sigma = evd} + | exception Univ.UniverseInconsistency _ -> None ) | None -> None let compute_rank_add env v = let rec _add gl vars n v = match vars with - | [] -> (gl, [v] ,n) - | e::l -> - match eq_constr gl e v with - | Some gl' -> (gl', vars , n) - | None -> - let (gl,l',n) = _add gl l ( n+1) v in - (gl,e::l',n) in - let (gl',vars', n) = _add env.gl env.vars 1 v in - ({vars=vars';gl=gl'}, CamlToCoq.positive n) - - let get_rank env v = - let gl = env.gl in - - let rec _get_rank env n = - match env with - | [] -> raise (Invalid_argument "get_rank") - | e::l -> - match eq_constr gl e v with - | Some _ -> n - | None -> _get_rank l (n+1) - in - _get_rank env.vars 1 + | [] -> (gl, [v], n) + | e :: l -> ( + match eq_constr gl e v with + | Some gl' -> (gl', vars, n) + | None -> + let gl, l', n = _add gl l (n + 1) v in + (gl, e :: l', n) ) + in + let gl', vars', n = _add env.gl env.vars 1 v in + ({vars = vars'; gl = gl'}, CamlToCoq.positive n) + + let get_rank env v = + let gl = env.gl in + let rec _get_rank env n = + match env with + | [] -> raise (Invalid_argument "get_rank") + | e :: l -> ( + match eq_constr gl e v with Some _ -> n | None -> _get_rank l (n + 1) + ) + in + _get_rank env.vars 1 - let elements env = env.vars + let elements env = env.vars -(* let string_of_env gl env = + (* let string_of_env gl env = let rec string_of_env i env acc = match env with | [] -> acc @@ -830,101 +836,103 @@ struct (Printer.pr_econstr_env gl.env gl.sigma e)) acc) in string_of_env 1 env IMap.empty *) - let pp gl env = - let ppl = List.mapi (fun i e -> Pp.str "x" ++ Pp.int (i+1) ++ Pp.str ":" ++ Printer.pr_econstr_env gl.env gl.sigma e)env in - List.fold_right (fun e p -> e ++ Pp.str " ; " ++ p ) ppl (Pp.str "\n") + let pp gl env = + let ppl = + List.mapi + (fun i e -> + Pp.str "x" + ++ Pp.int (i + 1) + ++ Pp.str ":" + ++ Printer.pr_econstr_env gl.env gl.sigma e) + env + in + List.fold_right (fun e p -> e ++ Pp.str " ; " ++ p) ppl (Pp.str "\n") + end - end (* MODULE END: Env *) + (* MODULE END: Env *) (** * This is the big generic function for expression parsers. *) let parse_expr gl parse_constant parse_exp ops_spec env term = - if debug - then ( - Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env gl.env gl.sigma term)); - + if debug then + Feedback.msg_debug + (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env gl.env gl.sigma term); let parse_variable env term = - let (env,n) = Env.compute_rank_add env term in - (Mc.PEX n , env) in - + let env, n = Env.compute_rank_add env term in + (Mc.PEX n, env) + in let rec parse_expr env term = - let combine env op (t1,t2) = - let (expr1,env) = parse_expr env t1 in - let (expr2,env) = parse_expr env t2 in - (op expr1 expr2,env) in - - try (Mc.PEc (parse_constant gl term) , env) - with ParseError -> - match EConstr.kind gl.sigma term with - | App(t,args) -> - ( - match EConstr.kind gl.sigma t with - | Const c -> - ( match assoc_ops gl.sigma t ops_spec with - | Binop f -> combine env f (args.(0),args.(1)) - | Opp -> let (expr,env) = parse_expr env args.(0) in - (Mc.PEopp expr, env) - | Power -> - begin - try - let (expr,env) = parse_expr env args.(0) in - let power = (parse_exp expr args.(1)) in - (power , env) - with ParseError -> - (* if the exponent is a variable *) - let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) - end - | Ukn s -> - if debug - then (Printf.printf "unknown op: %s\n" s; flush stdout;); - let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) - ) - | _ -> parse_variable env term - ) - | _ -> parse_variable env term in - parse_expr env term + let combine env op (t1, t2) = + let expr1, env = parse_expr env t1 in + let expr2, env = parse_expr env t2 in + (op expr1 expr2, env) + in + try (Mc.PEc (parse_constant gl term), env) + with ParseError -> ( + match EConstr.kind gl.sigma term with + | App (t, args) -> ( + match EConstr.kind gl.sigma t with + | Const c -> ( + match assoc_ops gl.sigma t ops_spec with + | Binop f -> combine env f (args.(0), args.(1)) + | Opp -> + let expr, env = parse_expr env args.(0) in + (Mc.PEopp expr, env) + | Power -> ( + try + let expr, env = parse_expr env args.(0) in + let power = parse_exp expr args.(1) in + (power, env) + with ParseError -> + (* if the exponent is a variable *) + let env, n = Env.compute_rank_add env term in + (Mc.PEX n, env) ) + | Ukn s -> + if debug then ( + Printf.printf "unknown op: %s\n" s; + flush stdout ); + let env, n = Env.compute_rank_add env term in + (Mc.PEX n, env) ) + | _ -> parse_variable env term ) + | _ -> parse_variable env term ) + in + parse_expr env term let zop_spec = - [ - coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Zopp , Opp ; - coq_Zpower , Power] + [ (coq_Zplus, Binop (fun x y -> Mc.PEadd (x, y))) + ; (coq_Zminus, Binop (fun x y -> Mc.PEsub (x, y))) + ; (coq_Zmult, Binop (fun x y -> Mc.PEmul (x, y))) + ; (coq_Zopp, Opp) + ; (coq_Zpower, Power) ] let qop_spec = - [ - coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Qopp , Opp ; - coq_Qpower , Power] + [ (coq_Qplus, Binop (fun x y -> Mc.PEadd (x, y))) + ; (coq_Qminus, Binop (fun x y -> Mc.PEsub (x, y))) + ; (coq_Qmult, Binop (fun x y -> Mc.PEmul (x, y))) + ; (coq_Qopp, Opp) + ; (coq_Qpower, Power) ] let rop_spec = - [ - coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Ropp , Opp ; - coq_Rpower , Power] + [ (coq_Rplus, Binop (fun x y -> Mc.PEadd (x, y))) + ; (coq_Rminus, Binop (fun x y -> Mc.PEsub (x, y))) + ; (coq_Rmult, Binop (fun x y -> Mc.PEmul (x, y))) + ; (coq_Ropp, Opp) + ; (coq_Rpower, Power) ] - let parse_constant parse gl t = parse gl.sigma t + let parse_constant parse gl t = parse gl.sigma t (** [parse_more_constant parse gl t] returns the reification of term [t]. If [t] is a ground term, then it is first reduced to normal form before using a 'syntactic' parser *) let parse_more_constant parse gl t = - try - parse gl t - with ParseError -> - begin - if debug then Feedback.msg_debug Pp.(str "try harder"); - if is_ground_term gl.env gl.sigma t - then parse gl (Redexpr.cbv_vm gl.env gl.sigma t) - else raise ParseError - end + try parse gl t + with ParseError -> + if debug then Feedback.msg_debug Pp.(str "try harder"); + if is_ground_term gl.env gl.sigma t then + parse gl (Redexpr.cbv_vm gl.env gl.sigma t) + else raise ParseError let zconstant = parse_constant parse_z let qconstant = parse_constant parse_q @@ -935,22 +943,17 @@ struct [parse_constant_expr] returns a constant if the argument is an expression without variables. *) let rec parse_zexpr gl = - parse_expr gl - zconstant - (fun expr (x:EConstr.t) -> + parse_expr gl zconstant + (fun expr (x : EConstr.t) -> let z = parse_zconstant gl x in match z with | Mc.Zneg _ -> Mc.PEc Mc.Z0 - | _ -> Mc.PEpow(expr, Mc.Z.to_N z) - ) - zop_spec - and parse_zconstant gl e = - let (e,_) = parse_zexpr gl (Env.empty gl) e in - match Mc.zeval_const e with - | None -> raise ParseError - | Some z -> z - + | _ -> Mc.PEpow (expr, Mc.Z.to_N z)) + zop_spec + and parse_zconstant gl e = + let e, _ = parse_zexpr gl (Env.empty gl) e in + match Mc.zeval_const e with None -> raise ParseError | Some z -> z (* NB: R is a different story. Because it is axiomatised, reducing would not be effective. @@ -958,389 +961,387 @@ struct *) let rconst_assoc = - [ - coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ; - coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; - coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; - (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) - ] - - - - + [ (coq_Rplus, fun x y -> Mc.CPlus (x, y)) + ; (coq_Rminus, fun x y -> Mc.CMinus (x, y)) + ; (coq_Rmult, fun x y -> Mc.CMult (x, y)) + (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) ] let rconstant gl term = - let sigma = gl.sigma in - let rec rconstant term = match EConstr.kind sigma term with | Const x -> - if EConstr.eq_constr sigma term (Lazy.force coq_R0) - then Mc.C0 - else if EConstr.eq_constr sigma term (Lazy.force coq_R1) - then Mc.C1 - else raise ParseError - | App(op,args) -> - begin - try - (* the evaluation order is important in the following *) - let f = assoc_const sigma op rconst_assoc in - let a = rconstant args.(0) in - let b = rconstant args.(1) in - f a b - with - ParseError -> - match op with - | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> - let arg = rconstant args.(0) in - if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} - then raise ParseError (* This is a division by zero -- no semantics *) - else Mc.CInv(arg) - | op when EConstr.eq_constr sigma op (Lazy.force coq_Rpower) -> - Mc.CPow(rconstant args.(0) , Mc.Inr (parse_more_constant nconstant gl args.(1))) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> - Mc.CQ (qconstant gl args.(0)) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> - Mc.CZ (parse_more_constant zconstant gl args.(0)) - | _ -> raise ParseError - end - | _ -> raise ParseError in - + if EConstr.eq_constr sigma term (Lazy.force coq_R0) then Mc.C0 + else if EConstr.eq_constr sigma term (Lazy.force coq_R1) then Mc.C1 + else raise ParseError + | App (op, args) -> ( + try + (* the evaluation order is important in the following *) + let f = assoc_const sigma op rconst_assoc in + let a = rconstant args.(0) in + let b = rconstant args.(1) in + f a b + with ParseError -> ( + match op with + | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> + let arg = rconstant args.(0) in + if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0; Mc.qden = Mc.XH} + then raise ParseError + (* This is a division by zero -- no semantics *) + else Mc.CInv arg + | op when EConstr.eq_constr sigma op (Lazy.force coq_Rpower) -> + Mc.CPow + ( rconstant args.(0) + , Mc.Inr (parse_more_constant nconstant gl args.(1)) ) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> + Mc.CQ (qconstant gl args.(0)) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> + Mc.CZ (parse_more_constant zconstant gl args.(0)) + | _ -> raise ParseError ) ) + | _ -> raise ParseError + in rconstant term - - let rconstant gl term = - if debug - then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env gl.env gl.sigma term ++ fnl ()); + if debug then + Feedback.msg_debug + ( Pp.str "rconstant: " + ++ Printer.pr_leconstr_env gl.env gl.sigma term + ++ fnl () ); let res = rconstant gl term in - if debug then - (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; - res - - - - let parse_qexpr gl = parse_expr gl - qconstant - (fun expr x -> - let exp = zconstant gl x in + if debug then ( + Printf.printf "rconstant -> %a\n" pp_Rcst res; + flush stdout ); + res + + let parse_qexpr gl = + parse_expr gl qconstant + (fun expr x -> + let exp = zconstant gl x in match exp with - | Mc.Zneg _ -> - begin - match expr with - | Mc.PEc q -> Mc.PEc (Mc.qpower q exp) - | _ -> raise ParseError - end - | _ -> let exp = Mc.Z.to_N exp in - Mc.PEpow(expr,exp)) - qop_spec - - let parse_rexpr gl = parse_expr gl - rconstant - (fun expr x -> - let exp = Mc.N.of_nat (parse_nat gl.sigma x) in - Mc.PEpow(expr,exp)) - rop_spec - - let parse_arith parse_op parse_expr env cstr gl = + | Mc.Zneg _ -> ( + match expr with + | Mc.PEc q -> Mc.PEc (Mc.qpower q exp) + | _ -> raise ParseError ) + | _ -> + let exp = Mc.Z.to_N exp in + Mc.PEpow (expr, exp)) + qop_spec + + let parse_rexpr gl = + parse_expr gl rconstant + (fun expr x -> + let exp = Mc.N.of_nat (parse_nat gl.sigma x) in + Mc.PEpow (expr, exp)) + rop_spec + + let parse_arith parse_op parse_expr env cstr gl = let sigma = gl.sigma in - if debug - then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ()); + if debug then + Feedback.msg_debug + ( Pp.str "parse_arith: " + ++ Printer.pr_leconstr_env gl.env sigma cstr + ++ fnl () ); match EConstr.kind sigma cstr with - | App(op,args) -> - let (op,lhs,rhs) = parse_op gl (op,args) in - let (e1,env) = parse_expr gl env lhs in - let (e2,env) = parse_expr gl env rhs in - ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) - | _ -> failwith "error : parse_arith(2)" + | App (op, args) -> + let op, lhs, rhs = parse_op gl (op, args) in + let e1, env = parse_expr gl env lhs in + let e2, env = parse_expr gl env rhs in + ({Mc.flhs = e1; Mc.fop = op; Mc.frhs = e2}, env) + | _ -> failwith "error : parse_arith(2)" let parse_zarith = parse_arith parse_zop parse_zexpr - let parse_qarith = parse_arith parse_qop parse_qexpr - let parse_rarith = parse_arith parse_rop parse_rexpr (* generic parsing of arithmetic expressions *) - let mkC f1 f2 = Mc.Cj(f1,f2) - let mkD f1 f2 = Mc.D(f1,f2) - let mkIff f1 f2 = Mc.Cj(Mc.I(f1,None,f2),Mc.I(f2,None,f1)) - let mkI f1 f2 = Mc.I(f1,None,f2) + let mkC f1 f2 = Mc.Cj (f1, f2) + let mkD f1 f2 = Mc.D (f1, f2) + let mkIff f1 f2 = Mc.Cj (Mc.I (f1, None, f2), Mc.I (f2, None, f1)) + let mkI f1 f2 = Mc.I (f1, None, f2) let mkformula_binary g term f1 f2 = - match f1 , f2 with - | Mc.X _ , Mc.X _ -> Mc.X(term) - | _ -> g f1 f2 + match (f1, f2) with Mc.X _, Mc.X _ -> Mc.X term | _ -> g f1 f2 (** * This is the big generic function for formula parsers. *) let is_prop env sigma term = - let sort = Retyping.get_sort_of env sigma term in + let sort = Retyping.get_sort_of env sigma term in Sorts.is_prop sort let parse_formula gl parse_atom env tg term = let sigma = gl.sigma in - let is_prop term = is_prop gl.env gl.sigma term in - let parse_atom env tg t = try - let (at,env) = parse_atom env t gl in - (Mc.A(at,(tg,t)), env,Tag.next tg) + let at, env = parse_atom env t gl in + (Mc.A (at, (tg, t)), env, Tag.next tg) with ParseError -> - if is_prop t - then (Mc.X(t),env,tg) - else raise ParseError + if is_prop t then (Mc.X t, env, tg) else raise ParseError in - let rec xparse_formula env tg term = match EConstr.kind sigma term with - | App(l,rst) -> - (match rst with - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_and) -> - let f,env,tg = xparse_formula env tg a in - let g,env, tg = xparse_formula env tg b in - mkformula_binary mkC term f g,env,tg - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_or) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkD term f g,env,tg + | App (l, rst) -> ( + match rst with + | [|a; b|] when EConstr.eq_constr sigma l (Lazy.force coq_and) -> + let f, env, tg = xparse_formula env tg a in + let g, env, tg = xparse_formula env tg b in + (mkformula_binary mkC term f g, env, tg) + | [|a; b|] when EConstr.eq_constr sigma l (Lazy.force coq_or) -> + let f, env, tg = xparse_formula env tg a in + let g, env, tg = xparse_formula env tg b in + (mkformula_binary mkD term f g, env, tg) | [|a|] when EConstr.eq_constr sigma l (Lazy.force coq_not) -> - let (f,env,tg) = xparse_formula env tg a in (Mc.N(f), env,tg) - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_iff) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkIff term f g,env,tg - | _ -> parse_atom env tg term) - | Prod(typ,a,b) when typ.binder_name = Anonymous || EConstr.Vars.noccurn sigma 1 b -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkI term f g,env,tg - | _ -> if EConstr.eq_constr sigma term (Lazy.force coq_True) - then (Mc.TT,env,tg) - else if EConstr.eq_constr sigma term (Lazy.force coq_False) - then Mc.(FF,env,tg) - else if is_prop term then Mc.X(term),env,tg - else raise ParseError + let f, env, tg = xparse_formula env tg a in + (Mc.N f, env, tg) + | [|a; b|] when EConstr.eq_constr sigma l (Lazy.force coq_iff) -> + let f, env, tg = xparse_formula env tg a in + let g, env, tg = xparse_formula env tg b in + (mkformula_binary mkIff term f g, env, tg) + | _ -> parse_atom env tg term ) + | Prod (typ, a, b) + when typ.binder_name = Anonymous || EConstr.Vars.noccurn sigma 1 b -> + let f, env, tg = xparse_formula env tg a in + let g, env, tg = xparse_formula env tg b in + (mkformula_binary mkI term f g, env, tg) + | _ -> + if EConstr.eq_constr sigma term (Lazy.force coq_True) then + (Mc.TT, env, tg) + else if EConstr.eq_constr sigma term (Lazy.force coq_False) then + Mc.(FF, env, tg) + else if is_prop term then (Mc.X term, env, tg) + else raise ParseError in - xparse_formula env tg ((*Reductionops.whd_zeta*) term) + xparse_formula env tg (*Reductionops.whd_zeta*) term let dump_formula typ dump_atom f = let app_ctor c args = - EConstr.mkApp(Lazy.force c, Array.of_list (typ::EConstr.mkProp::Lazy.force coq_unit :: Lazy.force coq_unit :: args)) in - + EConstr.mkApp + ( Lazy.force c + , Array.of_list + ( typ :: EConstr.mkProp :: Lazy.force coq_unit + :: Lazy.force coq_unit :: args ) ) + in let rec xdump f = - match f with - | Mc.TT -> app_ctor coq_TT [] - | Mc.FF -> app_ctor coq_FF [] - | Mc.Cj(x,y) -> app_ctor coq_And [xdump x ; xdump y] - | Mc.D(x,y) -> app_ctor coq_Or [xdump x ; xdump y] - | Mc.I(x,_,y) -> app_ctor coq_Impl [xdump x ; EConstr.mkApp(Lazy.force coq_None,[|Lazy.force coq_unit|]); xdump y] - | Mc.N(x) -> app_ctor coq_Neg [xdump x] - | Mc.A(x,_) -> app_ctor coq_Atom [dump_atom x;Lazy.force coq_tt] - | Mc.X(t) -> app_ctor coq_X [t] in - xdump f - + match f with + | Mc.TT -> app_ctor coq_TT [] + | Mc.FF -> app_ctor coq_FF [] + | Mc.Cj (x, y) -> app_ctor coq_And [xdump x; xdump y] + | Mc.D (x, y) -> app_ctor coq_Or [xdump x; xdump y] + | Mc.I (x, _, y) -> + app_ctor coq_Impl + [ xdump x + ; EConstr.mkApp (Lazy.force coq_None, [|Lazy.force coq_unit|]) + ; xdump y ] + | Mc.N x -> app_ctor coq_Neg [xdump x] + | Mc.A (x, _) -> app_ctor coq_Atom [dump_atom x; Lazy.force coq_tt] + | Mc.X t -> app_ctor coq_X [t] + in + xdump f let prop_env_of_formula gl form = Mc.( - let rec doit env = function - | TT | FF | A(_,_) -> env - | X t -> fst (Env.compute_rank_add env t) - | Cj(f1,f2) | D(f1,f2) | I(f1,_,f2) -> - doit (doit env f1) f2 - | N f -> doit env f - in - - doit (Env.empty gl) form) + let rec doit env = function + | TT | FF | A (_, _) -> env + | X t -> fst (Env.compute_rank_add env t) + | Cj (f1, f2) | D (f1, f2) | I (f1, _, f2) -> doit (doit env f1) f2 + | N f -> doit env f + in + doit (Env.empty gl) form) let var_env_of_formula form = - - let rec vars_of_expr = function + let rec vars_of_expr = function | Mc.PEX n -> ISet.singleton (CoqToCaml.positive n) | Mc.PEc z -> ISet.empty - | Mc.PEadd(e1,e2) | Mc.PEmul(e1,e2) | Mc.PEsub(e1,e2) -> + | Mc.PEadd (e1, e2) | Mc.PEmul (e1, e2) | Mc.PEsub (e1, e2) -> ISet.union (vars_of_expr e1) (vars_of_expr e2) - | Mc.PEopp e | Mc.PEpow(e,_)-> vars_of_expr e + | Mc.PEopp e | Mc.PEpow (e, _) -> vars_of_expr e in + let vars_of_atom {Mc.flhs; Mc.fop; Mc.frhs} = + ISet.union (vars_of_expr flhs) (vars_of_expr frhs) + in + Mc.( + let rec doit = function + | TT | FF | X _ -> ISet.empty + | A (a, (t, c)) -> vars_of_atom a + | Cj (f1, f2) | D (f1, f2) | I (f1, _, f2) -> + ISet.union (doit f1) (doit f2) + | N f -> doit f + in + doit form) + + type 'cst dump_expr = + { (* 'cst is the type of the syntactic constants *) + interp_typ : EConstr.constr + ; dump_cst : 'cst -> EConstr.constr + ; dump_add : EConstr.constr + ; dump_sub : EConstr.constr + ; dump_opp : EConstr.constr + ; dump_mul : EConstr.constr + ; dump_pow : EConstr.constr + ; dump_pow_arg : Mc.n -> EConstr.constr + ; dump_op : (Mc.op2 * EConstr.constr) list } + + let dump_zexpr = + lazy + { interp_typ = Lazy.force coq_Z + ; dump_cst = dump_z + ; dump_add = Lazy.force coq_Zplus + ; dump_sub = Lazy.force coq_Zminus + ; dump_opp = Lazy.force coq_Zopp + ; dump_mul = Lazy.force coq_Zmult + ; dump_pow = Lazy.force coq_Zpower + ; dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))) + ; dump_op = List.map (fun (x, y) -> (y, Lazy.force x)) zop_table } + + let dump_qexpr = + lazy + { interp_typ = Lazy.force coq_Q + ; dump_cst = dump_q + ; dump_add = Lazy.force coq_Qplus + ; dump_sub = Lazy.force coq_Qminus + ; dump_opp = Lazy.force coq_Qopp + ; dump_mul = Lazy.force coq_Qmult + ; dump_pow = Lazy.force coq_Qpower + ; dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))) + ; dump_op = List.map (fun (x, y) -> (y, Lazy.force x)) qop_table } + + let rec dump_Rcst_as_R cst = + match cst with + | Mc.C0 -> Lazy.force coq_R0 + | Mc.C1 -> Lazy.force coq_R1 + | Mc.CQ q -> EConstr.mkApp (Lazy.force coq_IQR, [|dump_q q|]) + | Mc.CZ z -> EConstr.mkApp (Lazy.force coq_IZR, [|dump_z z|]) + | Mc.CPlus (x, y) -> + EConstr.mkApp + (Lazy.force coq_Rplus, [|dump_Rcst_as_R x; dump_Rcst_as_R y|]) + | Mc.CMinus (x, y) -> + EConstr.mkApp + (Lazy.force coq_Rminus, [|dump_Rcst_as_R x; dump_Rcst_as_R y|]) + | Mc.CMult (x, y) -> + EConstr.mkApp + (Lazy.force coq_Rmult, [|dump_Rcst_as_R x; dump_Rcst_as_R y|]) + | Mc.CPow (x, y) -> ( + match y with + | Mc.Inl z -> + EConstr.mkApp (Lazy.force coq_powerZR, [|dump_Rcst_as_R x; dump_z z|]) + | Mc.Inr n -> + EConstr.mkApp (Lazy.force coq_Rpower, [|dump_Rcst_as_R x; dump_nat n|]) + ) + | Mc.CInv t -> EConstr.mkApp (Lazy.force coq_Rinv, [|dump_Rcst_as_R t|]) + | Mc.COpp t -> EConstr.mkApp (Lazy.force coq_Ropp, [|dump_Rcst_as_R t|]) + + let dump_rexpr = + lazy + { interp_typ = Lazy.force coq_R + ; dump_cst = dump_Rcst_as_R + ; dump_add = Lazy.force coq_Rplus + ; dump_sub = Lazy.force coq_Rminus + ; dump_opp = Lazy.force coq_Ropp + ; dump_mul = Lazy.force coq_Rmult + ; dump_pow = Lazy.force coq_Rpower + ; dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n))) + ; dump_op = List.map (fun (x, y) -> (y, Lazy.force x)) rop_table } + + let prodn n env b = + let rec prodrec = function + | 0, env, b -> b + | n, (v, t) :: l, b -> + prodrec (n - 1, l, EConstr.mkProd (make_annot v Sorts.Relevant, t, b)) + | _ -> assert false + in + prodrec (n, env, b) - let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = - ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in - Mc.( - let rec doit = function - | TT | FF | X _ -> ISet.empty - | A (a,(t,c)) -> vars_of_atom a - | Cj(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) - | N f -> doit f in - - doit form) - - - - - type 'cst dump_expr = (* 'cst is the type of the syntactic constants *) - { - interp_typ : EConstr.constr; - dump_cst : 'cst -> EConstr.constr; - dump_add : EConstr.constr; - dump_sub : EConstr.constr; - dump_opp : EConstr.constr; - dump_mul : EConstr.constr; - dump_pow : EConstr.constr; - dump_pow_arg : Mc.n -> EConstr.constr; - dump_op : (Mc.op2 * EConstr.constr) list - } - -let dump_zexpr = lazy - { - interp_typ = Lazy.force coq_Z; - dump_cst = dump_z; - dump_add = Lazy.force coq_Zplus; - dump_sub = Lazy.force coq_Zminus; - dump_opp = Lazy.force coq_Zopp; - dump_mul = Lazy.force coq_Zmult; - dump_pow = Lazy.force coq_Zpower; - dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) zop_table - } - -let dump_qexpr = lazy - { - interp_typ = Lazy.force coq_Q; - dump_cst = dump_q; - dump_add = Lazy.force coq_Qplus; - dump_sub = Lazy.force coq_Qminus; - dump_opp = Lazy.force coq_Qopp; - dump_mul = Lazy.force coq_Qmult; - dump_pow = Lazy.force coq_Qpower; - dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table - } - -let rec dump_Rcst_as_R cst = - match cst with - | Mc.C0 -> Lazy.force coq_R0 - | Mc.C1 -> Lazy.force coq_R1 - | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_IQR, [| dump_q q |]) - | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_IZR, [| dump_z z |]) - | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CPow(x,y) -> - begin - match y with - | Mc.Inl z -> EConstr.mkApp(Lazy.force coq_powerZR,[| dump_Rcst_as_R x ; dump_z z|]) - | Mc.Inr n -> EConstr.mkApp(Lazy.force coq_Rpower,[| dump_Rcst_as_R x ; dump_nat n|]) - end - | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |]) - | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |]) - - -let dump_rexpr = lazy - { - interp_typ = Lazy.force coq_R; - dump_cst = dump_Rcst_as_R; - dump_add = Lazy.force coq_Rplus; - dump_sub = Lazy.force coq_Rminus; - dump_opp = Lazy.force coq_Ropp; - dump_mul = Lazy.force coq_Rmult; - dump_pow = Lazy.force coq_Rpower; - dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table - } - - - - -let prodn n env b = - let rec prodrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> prodrec (n-1, l, EConstr.mkProd (make_annot v Sorts.Relevant,t,b)) - | _ -> assert false - in - prodrec (n,env,b) - -(** [make_goal_of_formula depxr vars props form] where + (** [make_goal_of_formula depxr vars props form] where - vars is an environment for the arithmetic variables occurring in form - props is an environment for the propositions occurring in form @return a goal where all the variables and propositions of the formula are quantified *) -let make_goal_of_formula gl dexpr form = - - let vars_idx = - List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in - - (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) - - let props = prop_env_of_formula gl form in - - let fresh_var str i = Names.Id.of_string (str^(string_of_int i)) in - - let fresh_prop str i = - Names.Id.of_string (str^(string_of_int i)) in - - let vars_n = List.map (fun (_,i) -> fresh_var "__x" i, dexpr.interp_typ) vars_idx in - let props_n = List.mapi (fun i _ -> fresh_prop "__p" (i+1) , EConstr.mkProp) (Env.elements props) in - - let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in - - let dump_expr i e = - let rec dump_expr = function - | Mc.PEX n -> EConstr.mkRel (i+(List.assoc (CoqToCaml.positive n) vars_idx)) - | Mc.PEc z -> dexpr.dump_cst z - | Mc.PEadd(e1,e2) -> EConstr.mkApp(dexpr.dump_add, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEsub(e1,e2) -> EConstr.mkApp(dexpr.dump_sub, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEopp e -> EConstr.mkApp(dexpr.dump_opp, - [| dump_expr e|]) - | Mc.PEmul(e1,e2) -> EConstr.mkApp(dexpr.dump_mul, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEpow(e,n) -> EConstr.mkApp(dexpr.dump_pow, - [| dump_expr e; dexpr.dump_pow_arg n|]) - in dump_expr e in - - let mkop op e1 e2 = - try - EConstr.mkApp(List.assoc op dexpr.dump_op, [| e1; e2|]) + let make_goal_of_formula gl dexpr form = + let vars_idx = + List.mapi + (fun i v -> (v, i + 1)) + (ISet.elements (var_env_of_formula form)) + in + (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) + let props = prop_env_of_formula gl form in + let fresh_var str i = Names.Id.of_string (str ^ string_of_int i) in + let fresh_prop str i = Names.Id.of_string (str ^ string_of_int i) in + let vars_n = + List.map (fun (_, i) -> (fresh_var "__x" i, dexpr.interp_typ)) vars_idx + in + let props_n = + List.mapi + (fun i _ -> (fresh_prop "__p" (i + 1), EConstr.mkProp)) + (Env.elements props) + in + let var_name_pos = + List.map2 (fun (idx, _) (id, _) -> (id, idx)) vars_idx vars_n + in + let dump_expr i e = + let rec dump_expr = function + | Mc.PEX n -> + EConstr.mkRel (i + List.assoc (CoqToCaml.positive n) vars_idx) + | Mc.PEc z -> dexpr.dump_cst z + | Mc.PEadd (e1, e2) -> + EConstr.mkApp (dexpr.dump_add, [|dump_expr e1; dump_expr e2|]) + | Mc.PEsub (e1, e2) -> + EConstr.mkApp (dexpr.dump_sub, [|dump_expr e1; dump_expr e2|]) + | Mc.PEopp e -> EConstr.mkApp (dexpr.dump_opp, [|dump_expr e|]) + | Mc.PEmul (e1, e2) -> + EConstr.mkApp (dexpr.dump_mul, [|dump_expr e1; dump_expr e2|]) + | Mc.PEpow (e, n) -> + EConstr.mkApp (dexpr.dump_pow, [|dump_expr e; dexpr.dump_pow_arg n|]) + in + dump_expr e + in + let mkop op e1 e2 = + try EConstr.mkApp (List.assoc op dexpr.dump_op, [|e1; e2|]) with Not_found -> - EConstr.mkApp(Lazy.force coq_Eq,[|dexpr.interp_typ ; e1 ;e2|]) in - - let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } = - mkop fop (dump_expr i flhs) (dump_expr i frhs) in - - let rec xdump pi xi f = - match f with - | Mc.TT -> Lazy.force coq_True - | Mc.FF -> Lazy.force coq_False - | Mc.Cj(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) - | Mc.D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) - | Mc.I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (xdump (pi+1) (xi+1) y) - | Mc.N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) - | Mc.A(x,_) -> dump_cstr xi x - | Mc.X(t) -> let idx = Env.get_rank props t in - EConstr.mkRel (pi+idx) in - - let nb_vars = List.length vars_n in - let nb_props = List.length props_n in - - (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) - - let subst_prop p = - let idx = Env.get_rank props p in - EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in - - let form' = Mc.mapX subst_prop form in - - (prodn nb_props (List.map (fun (x,y) -> Name.Name x,y) props_n) - (prodn nb_vars (List.map (fun (x,y) -> Name.Name x,y) vars_n) - (xdump (List.length vars_n) 0 form)), - List.rev props_n, List.rev var_name_pos,form') + EConstr.mkApp (Lazy.force coq_Eq, [|dexpr.interp_typ; e1; e2|]) + in + let dump_cstr i {Mc.flhs; Mc.fop; Mc.frhs} = + mkop fop (dump_expr i flhs) (dump_expr i frhs) + in + let rec xdump pi xi f = + match f with + | Mc.TT -> Lazy.force coq_True + | Mc.FF -> Lazy.force coq_False + | Mc.Cj (x, y) -> + EConstr.mkApp (Lazy.force coq_and, [|xdump pi xi x; xdump pi xi y|]) + | Mc.D (x, y) -> + EConstr.mkApp (Lazy.force coq_or, [|xdump pi xi x; xdump pi xi y|]) + | Mc.I (x, _, y) -> + EConstr.mkArrow (xdump pi xi x) Sorts.Relevant + (xdump (pi + 1) (xi + 1) y) + | Mc.N x -> + EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) + | Mc.A (x, _) -> dump_cstr xi x + | Mc.X t -> + let idx = Env.get_rank props t in + EConstr.mkRel (pi + idx) + in + let nb_vars = List.length vars_n in + let nb_props = List.length props_n in + (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) + let subst_prop p = + let idx = Env.get_rank props p in + EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) + in + let form' = Mc.mapX subst_prop form in + ( prodn nb_props + (List.map (fun (x, y) -> (Name.Name x, y)) props_n) + (prodn nb_vars + (List.map (fun (x, y) -> (Name.Name x, y)) vars_n) + (xdump (List.length vars_n) 0 form)) + , List.rev props_n + , List.rev var_name_pos + , form' ) (** * Given a conclusion and a list of affectations, rebuild a term prefixed by @@ -1349,177 +1350,167 @@ let make_goal_of_formula gl dexpr form = *) let set l concl = - let rec xset acc = function - | [] -> acc - | (e::l) -> - let (name,expr,typ) = e in - xset (EConstr.mkNamedLetIn - (make_annot (Names.Id.of_string name) Sorts.Relevant) - expr typ acc) l in + let rec xset acc = function + | [] -> acc + | e :: l -> + let name, expr, typ = e in + xset + (EConstr.mkNamedLetIn + (make_annot (Names.Id.of_string name) Sorts.Relevant) + expr typ acc) + l + in xset concl l - -end (** - * MODULE END: M - *) +end open M let coq_Branch = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Branch") + lazy + (gen_constant_in_modules "VarMap" + [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] + "Branch") + let coq_Elt = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Elt") + lazy + (gen_constant_in_modules "VarMap" + [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] + "Elt") + let coq_Empty = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") + lazy + (gen_constant_in_modules "VarMap" + [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] + "Empty") let coq_VarMap = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") - + lazy + (gen_constant_in_modules "VarMap" + [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] + "t") let rec dump_varmap typ m = match m with - | Mc.Empty -> EConstr.mkApp(Lazy.force coq_Empty,[| typ |]) - | Mc.Elt v -> EConstr.mkApp(Lazy.force coq_Elt,[| typ; v|]) - | Mc.Branch(l,o,r) -> - EConstr.mkApp (Lazy.force coq_Branch, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) - + | Mc.Empty -> EConstr.mkApp (Lazy.force coq_Empty, [|typ|]) + | Mc.Elt v -> EConstr.mkApp (Lazy.force coq_Elt, [|typ; v|]) + | Mc.Branch (l, o, r) -> + EConstr.mkApp + (Lazy.force coq_Branch, [|typ; dump_varmap typ l; o; dump_varmap typ r|]) let vm_of_list env = match env with | [] -> Mc.Empty - | (d,_)::_ -> - List.fold_left (fun vm (c,i) -> - Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env + | (d, _) :: _ -> + List.fold_left + (fun vm (c, i) -> Mc.vm_add d (CamlToCoq.positive i) c vm) + Mc.Empty env let rec dump_proof_term = function | Micromega.DoneProof -> Lazy.force coq_doneProof - | Micromega.RatProof(cone,rst) -> - EConstr.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|]) - | Micromega.CutProof(cone,prf) -> - EConstr.mkApp(Lazy.force coq_cutProof, - [| dump_psatz coq_Z dump_z cone ; - dump_proof_term prf|]) - | Micromega.EnumProof(c1,c2,prfs) -> - EConstr.mkApp (Lazy.force coq_enumProof, - [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; - dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) - + | Micromega.RatProof (cone, rst) -> + EConstr.mkApp + ( Lazy.force coq_ratProof + , [|dump_psatz coq_Z dump_z cone; dump_proof_term rst|] ) + | Micromega.CutProof (cone, prf) -> + EConstr.mkApp + ( Lazy.force coq_cutProof + , [|dump_psatz coq_Z dump_z cone; dump_proof_term prf|] ) + | Micromega.EnumProof (c1, c2, prfs) -> + EConstr.mkApp + ( Lazy.force coq_enumProof + , [| dump_psatz coq_Z dump_z c1 + ; dump_psatz coq_Z dump_z c2 + ; dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |] ) + | Micromega.ExProof (p, prf) -> + EConstr.mkApp + (Lazy.force coq_ExProof, [|dump_positive p; dump_proof_term prf|]) let rec size_of_psatz = function | Micromega.PsatzIn _ -> 1 | Micromega.PsatzSquare _ -> 1 - | Micromega.PsatzMulC(_,p) -> 1 + (size_of_psatz p) - | Micromega.PsatzMulE(p1,p2) | Micromega.PsatzAdd(p1,p2) -> size_of_psatz p1 + size_of_psatz p2 + | Micromega.PsatzMulC (_, p) -> 1 + size_of_psatz p + | Micromega.PsatzMulE (p1, p2) | Micromega.PsatzAdd (p1, p2) -> + size_of_psatz p1 + size_of_psatz p2 | Micromega.PsatzC _ -> 1 - | Micromega.PsatzZ -> 1 + | Micromega.PsatzZ -> 1 let rec size_of_pf = function | Micromega.DoneProof -> 1 - | Micromega.RatProof(p,a) -> (size_of_pf a) + (size_of_psatz p) - | Micromega.CutProof(p,a) -> (size_of_pf a) + (size_of_psatz p) - | Micromega.EnumProof(p1,p2,l) -> (size_of_psatz p1) + (size_of_psatz p2) + (List.fold_left (fun acc p -> size_of_pf p + acc) 0 l) + | Micromega.RatProof (p, a) -> size_of_pf a + size_of_psatz p + | Micromega.CutProof (p, a) -> size_of_pf a + size_of_psatz p + | Micromega.EnumProof (p1, p2, l) -> + size_of_psatz p1 + size_of_psatz p2 + + List.fold_left (fun acc p -> size_of_pf p + acc) 0 l + | Micromega.ExProof (_, a) -> size_of_pf a + 1 let dump_proof_term t = - if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; + if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t); dump_proof_term t - - -let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden - +let pp_q o q = + Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden let rec pp_proof_term o = function | Micromega.DoneProof -> Printf.fprintf o "D" - | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst - | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst - | Micromega.EnumProof(c1,c2,rst) -> - Printf.fprintf o "EP[%a,%a,%a]" - (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 - (pp_list "[" "]" pp_proof_term) rst + | Micromega.RatProof (cone, rst) -> + Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst + | Micromega.CutProof (cone, rst) -> + Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst + | Micromega.EnumProof (c1, c2, rst) -> + Printf.fprintf o "EP[%a,%a,%a]" (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 + (pp_list "[" "]" pp_proof_term) + rst + | Micromega.ExProof (p, prf) -> + Printf.fprintf o "Ex[%a,%a]" pp_positive p pp_proof_term prf let rec parse_hyps gl parse_arith env tg hyps = - match hyps with - | [] -> ([],env,tg) - | (i,t)::l -> - let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in - if is_prop gl.env gl.sigma t - then - try - let (c,env,tg) = parse_formula gl parse_arith env tg t in - ((i,c)::lhyps, env,tg) - with ParseError -> (lhyps,env,tg) - else (lhyps,env,tg) - - -let parse_goal gl parse_arith (env:Env.t) hyps term = - let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in - let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in - (lhyps,f,env) - + match hyps with + | [] -> ([], env, tg) + | (i, t) :: l -> + let lhyps, env, tg = parse_hyps gl parse_arith env tg l in + if is_prop gl.env gl.sigma t then + try + let c, env, tg = parse_formula gl parse_arith env tg t in + ((i, c) :: lhyps, env, tg) + with ParseError -> (lhyps, env, tg) + else (lhyps, env, tg) + +let parse_goal gl parse_arith (env : Env.t) hyps term = + let f, env, tg = parse_formula gl parse_arith env (Tag.from 0) term in + let lhyps, env, tg = parse_hyps gl parse_arith env tg hyps in + (lhyps, f, env) + +type ('synt_c, 'prf) domain_spec = + { typ : EConstr.constr + ; (* is the type of the interpretation domain - Z, Q, R*) + coeff : EConstr.constr + ; (* is the type of the syntactic coeffs - Z , Q , Rcst *) + dump_coeff : 'synt_c -> EConstr.constr + ; proof_typ : EConstr.constr + ; dump_proof : 'prf -> EConstr.constr } (** * The datastructures that aggregate theory-dependent proof values. *) -type ('synt_c, 'prf) domain_spec = { - typ : EConstr.constr; (* is the type of the interpretation domain - Z, Q, R*) - coeff : EConstr.constr ; (* is the type of the syntactic coeffs - Z , Q , Rcst *) - dump_coeff : 'synt_c -> EConstr.constr ; - proof_typ : EConstr.constr ; - dump_proof : 'prf -> EConstr.constr -} - -let zz_domain_spec = lazy { - typ = Lazy.force coq_Z; - coeff = Lazy.force coq_Z; - dump_coeff = dump_z ; - proof_typ = Lazy.force coq_proofTerm ; - dump_proof = dump_proof_term -} - -let qq_domain_spec = lazy { - typ = Lazy.force coq_Q; - coeff = Lazy.force coq_Q; - dump_coeff = dump_q ; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_psatz coq_Q dump_q -} - -let max_tag f = 1 + (Tag.to_int (Mc.foldA (fun t1 (t2,_) -> Tag.max t1 t2) f (Tag.from 0))) - - -(** For completeness of the cutting-plane procedure, - each variable 'x' is replaced by 'y' - 'z' where - 'y' and 'z' are positive *) -let pre_processZ mt f = - - let x0 i = 2 * i in - let x1 i = 2 * i + 1 in - - let tag_of_var fr p b = - - let ip = CoqToCaml.positive fr + (CoqToCaml.positive p) in - - match b with - | None -> - let y = Mc.XO (Mc.Coq_Pos.add fr p) in - let z = Mc.XI (Mc.Coq_Pos.add fr p) in - let tag = Tag.from (- x0 (x0 ip)) in - let constr = Mc.mk_eq_pos p y z in - (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) - | Some false -> - let y = Mc.XO (Mc.Coq_Pos.add fr p) in - let tag = Tag.from (- x0 (x1 ip)) in - let constr = Mc.bound_var (Mc.XO y) in - (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) - | Some true -> - let z = Mc.XI (Mc.Coq_Pos.add fr p) in - let tag = Tag.from (- x1 (x1 ip)) in - let constr = Mc.bound_var (Mc.XI z) in - (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) in - - Mc.bound_problem_fr tag_of_var mt f + +let zz_domain_spec = + lazy + { typ = Lazy.force coq_Z + ; coeff = Lazy.force coq_Z + ; dump_coeff = dump_z + ; proof_typ = Lazy.force coq_proofTerm + ; dump_proof = dump_proof_term } + +let qq_domain_spec = + lazy + { typ = Lazy.force coq_Q + ; coeff = Lazy.force coq_Q + ; dump_coeff = dump_q + ; proof_typ = Lazy.force coq_QWitness + ; dump_proof = dump_psatz coq_Q dump_q } + +let max_tag f = + 1 + Tag.to_int (Mc.foldA (fun t1 (t2, _) -> Tag.max t1 t2) f (Tag.from 0)) + (** Naive topological sort of constr according to the subterm-ordering *) (* An element is minimal x is minimal w.r.t y if @@ -1530,26 +1521,25 @@ let pre_processZ mt f = * witness. *) -let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) = - (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) - let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in - let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in - let vm = dump_varmap (spec.typ) (vm_of_list env) in - (* todo : directly generate the proof term - or generalize before conversion? *) - Proofview.Goal.enter begin fun gl -> - Tacticals.New.tclTHENLIST - [ - Tactics.change_concl - (set - [ - ("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [|formula_typ |])); - ("__varmap", vm, EConstr.mkApp(Lazy.force coq_VarMap, [|spec.typ|])); - ("__wit", cert, cert_typ) - ] - (Tacmach.New.pf_concl gl)) - ] - end - +let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) + = + (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) + let formula_typ = EConstr.mkApp (Lazy.force coq_Cstr, [|spec.coeff|]) in + let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in + let vm = dump_varmap spec.typ (vm_of_list env) in + (* todo : directly generate the proof term - or generalize before conversion? *) + Proofview.Goal.enter (fun gl -> + Tacticals.New.tclTHENLIST + [ Tactics.change_concl + (set + [ ( "__ff" + , ff + , EConstr.mkApp (Lazy.force coq_Formula, [|formula_typ|]) ) + ; ( "__varmap" + , vm + , EConstr.mkApp (Lazy.force coq_VarMap, [|spec.typ|]) ) + ; ("__wit", cert, cert_typ) ] + (Tacmach.New.pf_concl gl)) ]) (** * The datastructures that aggregate prover attributes. @@ -1557,17 +1547,21 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* open Certificate -type ('option,'a,'prf,'model) prover = { - name : string ; (* name of the prover *) - get_option : unit ->'option ; (* find the options of the prover *) - prover : ('option * 'a list) -> ('prf, 'model) Certificate.res ; (* the prover itself *) - hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) - compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) - pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) - pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*) -} - - +type ('option, 'a, 'prf, 'model) prover = + { name : string + ; (* name of the prover *) + get_option : unit -> 'option + ; (* find the options of the prover *) + prover : 'option * 'a list -> ('prf, 'model) Certificate.res + ; (* the prover itself *) + hyps : 'prf -> ISet.t + ; (* extract the indexes of the hypotheses really used in the proof *) + compact : 'prf -> (int -> int) -> 'prf + ; (* remap the hyp indexes according to function *) + pp_prf : out_channel -> 'prf -> unit + ; (* pretting printing of proof *) + pp_f : out_channel -> 'a -> unit + (* pretty printing of the formulas (polynomials)*) } (** * Given a prover and a disjunction of atoms, find a proof of any of @@ -1575,34 +1569,36 @@ type ('option,'a,'prf,'model) prover = { * datastructure. *) -let find_witness p polys1 = +let find_witness p polys1 = let polys1 = List.map fst polys1 in match p.prover (p.get_option (), polys1) with | Model m -> Model m | Unknown -> Unknown - | Prf prf -> Prf(prf,p) + | Prf prf -> Prf (prf, p) (** * Given a prover and a CNF, find a proof for each of the clauses. * Return the proofs as a list. *) -let witness_list prover l = - let rec xwitness_list l = - match l with - | [] -> Prf [] - | e :: l -> +let witness_list prover l = + let rec xwitness_list l = + match l with + | [] -> Prf [] + | e :: l -> ( match xwitness_list l with - | Model (m,e) -> Model (m,e) - | Unknown -> Unknown - | Prf l -> - match find_witness prover e with - | Model m -> Model (m,e) - | Unknown -> Unknown - | Prf w -> Prf (w::l) in - xwitness_list l - -let witness_list_tags p g = witness_list p g + | Model (m, e) -> Model (m, e) + | Unknown -> Unknown + | Prf l -> ( + match find_witness prover e with + | Model m -> Model (m, e) + | Unknown -> Unknown + | Prf w -> Prf (w :: l) ) ) + in + xwitness_list l + +let witness_list_tags p g = witness_list p g + (* let t1 = System.get_time () in let res = witness_list p g in let t2 = System.get_time () in @@ -1614,15 +1610,17 @@ let witness_list_tags p g = witness_list p g * Prune the proof object, according to the 'diff' between two cnf formulas. *) - -let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = - - let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = - let new_cl = List.mapi (fun i (f,_) -> (f,i)) new_cl in +let compact_proofs (cnf_ff : 'cst cnf) res (cnf_ff' : 'cst cnf) = + let compact_proof (old_cl : 'cst clause) (prf, prover) (new_cl : 'cst clause) + = + let new_cl = List.mapi (fun i (f, _) -> (f, i)) new_cl in let remap i = - let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in - List.assoc formula new_cl in -(* if debug then + let formula = + try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" + in + List.assoc formula new_cl + in + (* if debug then begin Printf.printf "\ncompact_proof : %a %a %a" (pp_ml_list prover.pp_f) (List.map fst old_cl) @@ -1630,91 +1628,96 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = (pp_ml_list prover.pp_f) (List.map fst new_cl) ; flush stdout end ; *) - let res = try prover.compact prf remap with x when CErrors.noncritical x -> - if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; - (* This should not happen -- this is the recovery plan... *) - match prover.prover (prover.get_option (), List.map fst new_cl) with + let res = + try prover.compact prf remap + with x when CErrors.noncritical x -> ( + if debug then + Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x); + (* This should not happen -- this is the recovery plan... *) + match prover.prover (prover.get_option (), List.map fst new_cl) with | Unknown | Model _ -> failwith "proof compaction error" - | Prf p -> p + | Prf p -> p ) in - if debug then - begin - Printf.printf " -> %a\n" - prover.pp_prf res ; - flush stdout - end ; - res in - - let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = + if debug then begin + Printf.printf " -> %a\n" prover.pp_prf res; + flush stdout + end; + res + in + let is_proof_compatible (old_cl : 'cst clause) (prf, prover) + (new_cl : 'cst clause) = let hyps_idx = prover.hyps prf in let hyps = selecti hyps_idx old_cl in - is_sublist (=) hyps new_cl in - - - - let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) - if debug then - begin - Printf.printf "CNFRES\n"; flush stdout; - Printf.printf "CNFOLD %a\n" pp_cnf_tag cnf_ff; - List.iter (fun (cl,(prf,prover)) -> - let hyps_idx = prover.hyps prf in - let hyps = selecti hyps_idx cl in - Printf.printf "\nProver %a -> %a\n" - pp_clause_tag cl pp_clause_tag hyps;flush stdout) cnf_res; - Printf.printf "CNFNEW %a\n" pp_cnf_tag cnf_ff'; - - end; - - List.map (fun x -> - let (o,p) = - try - List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res + is_sublist ( = ) hyps new_cl + in + let cnf_res = List.combine cnf_ff res in + (* we get pairs clause * proof *) + if debug then begin + Printf.printf "CNFRES\n"; + flush stdout; + Printf.printf "CNFOLD %a\n" pp_cnf_tag cnf_ff; + List.iter + (fun (cl, (prf, prover)) -> + let hyps_idx = prover.hyps prf in + let hyps = selecti hyps_idx cl in + Printf.printf "\nProver %a -> %a\n" pp_clause_tag cl pp_clause_tag hyps; + flush stdout) + cnf_res; + Printf.printf "CNFNEW %a\n" pp_cnf_tag cnf_ff' + end; + List.map + (fun x -> + let o, p = + try List.find (fun (l, p) -> is_proof_compatible l p x) cnf_res with Not_found -> - begin - Printf.printf "ERROR: no compatible proof" ; flush stdout; - failwith "Cannot find compatible proof" end - in - compact_proof o p x) cnf_ff' - + Printf.printf "ERROR: no compatible proof"; + flush stdout; + failwith "Cannot find compatible proof" + in + compact_proof o p x) + cnf_ff' (** * "Hide out" tagged atoms of a formula by transforming them into generic * variables. See the Tag module in mutils.ml for more. *) - - let abstract_formula : TagSet.t -> 'a formula -> 'a formula = - fun hyps f -> - let to_constr = Mc.({ - mkTT = Lazy.force coq_True; - mkFF = Lazy.force coq_False; - mkA = (fun a (tg, t) -> t); - mkCj = (let coq_and = Lazy.force coq_and in - fun x y -> EConstr.mkApp(coq_and,[|x;y|])); - mkD = (let coq_or = Lazy.force coq_or in - fun x y -> EConstr.mkApp(coq_or,[|x;y|])); - mkI = (fun x y -> EConstr.mkArrow x Sorts.Relevant y); - mkN = (let coq_not = Lazy.force coq_not in - (fun x -> EConstr.mkApp(coq_not,[|x|]))) - }) in - Mc.abst_form to_constr (fun (t,_) -> TagSet.mem t hyps) true f - + fun hyps f -> + let to_constr = + Mc. + { mkTT = Lazy.force coq_True + ; mkFF = Lazy.force coq_False + ; mkA = (fun a (tg, t) -> t) + ; mkCj = + (let coq_and = Lazy.force coq_and in + fun x y -> EConstr.mkApp (coq_and, [|x; y|])) + ; mkD = + (let coq_or = Lazy.force coq_or in + fun x y -> EConstr.mkApp (coq_or, [|x; y|])) + ; mkI = (fun x y -> EConstr.mkArrow x Sorts.Relevant y) + ; mkN = + (let coq_not = Lazy.force coq_not in + fun x -> EConstr.mkApp (coq_not, [|x|])) } + in + Mc.abst_form to_constr (fun (t, _) -> TagSet.mem t hyps) true f (* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) let rec abstract_wrt_formula f1 f2 = Mc.( - match f1 , f2 with - | X c , _ -> X c - | A _ , A _ -> f2 - | Cj(a,b) , Cj(a',b') -> Cj(abstract_wrt_formula a a', abstract_wrt_formula b b') - | D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b') - | I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b') - | FF , FF -> FF - | TT , TT -> TT - | N x , N y -> N(abstract_wrt_formula x y) - | _ -> failwith "abstract_wrt_formula") + match (f1, f2) with + | X c, _ -> X c + | A _, A _ -> f2 + | Cj (a, b), Cj (a', b') -> + Cj (abstract_wrt_formula a a', abstract_wrt_formula b b') + | D (a, b), D (a', b') -> + D (abstract_wrt_formula a a', abstract_wrt_formula b b') + | I (a, _, b), I (a', x, b') -> + I (abstract_wrt_formula a a', x, abstract_wrt_formula b b') + | FF, FF -> FF + | TT, TT -> TT + | N x, N y -> N (abstract_wrt_formula x y) + | _ -> failwith "abstract_wrt_formula") (** * This exception is raised by really_call_csdpcert if Coq's configure didn't @@ -1723,7 +1726,6 @@ let rec abstract_wrt_formula f1 f2 = exception CsdpNotFound - (** * This is the core of Micromega: apply the prover, analyze the result and * prune unused fomulas, and finally modify the proof state. @@ -1731,12 +1733,11 @@ exception CsdpNotFound let formula_hyps_concl hyps concl = List.fold_right - (fun (id,f) (cc,ids) -> - match f with - Mc.X _ -> (cc,ids) - | _ -> (Mc.I(f,Some id,cc), id::ids)) - hyps (concl,[]) - + (fun (id, f) (cc, ids) -> + match f with + | Mc.X _ -> (cc, ids) + | _ -> (Mc.I (f, Some id, cc), id :: ids)) + hyps (concl, []) (* let time str f x = let t1 = System.get_time () in @@ -1746,70 +1747,76 @@ let formula_hyps_concl hyps concl = res *) -let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl = - - (* Express the goal as one big implication *) - let (ff,ids) = formula_hyps_concl polys1 polys2 in - let mt = CamlToCoq.positive (max_tag ff) in - - (* Construction of cnf *) - let pre_ff = pre_process mt (ff:'a formula) in - let (cnf_ff,cnf_ff_tags) = cnf pre_ff in - - match witness_list_tags prover cnf_ff with - | Model m -> Model m - | Unknown -> Unknown - | Prf res -> (*Printf.printf "\nList %i" (List.length `res); *) - let deps = List.fold_left - (fun s (cl,(prf,p)) -> - let tags = ISet.fold (fun i s -> - let t = fst (snd (List.nth cl i)) in - if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; - (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in - TagSet.union s tags) (List.fold_left (fun s (i,_) -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in - - let ff' = abstract_formula deps ff in - - let pre_ff' = pre_process mt ff' in - - let (cnf_ff',_) = cnf pre_ff' in - - if debug then - begin +let micromega_tauto pre_process cnf spec prover env + (polys1 : (Names.Id.t * 'cst formula) list) (polys2 : 'cst formula) gl = + (* Express the goal as one big implication *) + let ff, ids = formula_hyps_concl polys1 polys2 in + let mt = CamlToCoq.positive (max_tag ff) in + (* Construction of cnf *) + let pre_ff = pre_process mt (ff : 'a formula) in + let cnf_ff, cnf_ff_tags = cnf pre_ff in + match witness_list_tags prover cnf_ff with + | Model m -> Model m + | Unknown -> Unknown + | Prf res -> + (*Printf.printf "\nList %i" (List.length `res); *) + let deps = + List.fold_left + (fun s (cl, (prf, p)) -> + let tags = + ISet.fold + (fun i s -> + let t = fst (snd (List.nth cl i)) in + if debug then Printf.fprintf stdout "T : %i -> %a" i Tag.pp t; + (*try*) TagSet.add t s + (* with Invalid_argument _ -> s*)) + (p.hyps prf) TagSet.empty + in + TagSet.union s tags) + (List.fold_left + (fun s (i, _) -> TagSet.add i s) + TagSet.empty cnf_ff_tags) + (List.combine cnf_ff res) + in + let ff' = abstract_formula deps ff in + let pre_ff' = pre_process mt ff' in + let cnf_ff', _ = cnf pre_ff' in + if debug then begin output_string stdout "\n"; - Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; - Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff ; flush stdout; - Printf.printf "TFormAbs : %a\n" pp_formula ff' ; flush stdout; - Printf.printf "TFormPre : %a\n" pp_formula pre_ff ; flush stdout; - Printf.printf "TFormPreAbs : %a\n" pp_formula pre_ff' ; flush stdout; - Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff' ; flush stdout; + Printf.printf "TForm : %a\n" pp_formula ff; + flush stdout; + Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff; + flush stdout; + Printf.printf "TFormAbs : %a\n" pp_formula ff'; + flush stdout; + Printf.printf "TFormPre : %a\n" pp_formula pre_ff; + flush stdout; + Printf.printf "TFormPreAbs : %a\n" pp_formula pre_ff'; + flush stdout; + Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff'; + flush stdout end; - - (* Even if it does not work, this does not mean it is not provable + (* Even if it does not work, this does not mean it is not provable -- the prover is REALLY incomplete *) - (* if debug then + (* if debug then begin (* recompute the proofs *) match witness_list_tags prover cnf_ff' with | None -> failwith "abstraction is wrong" | Some res -> () end ; *) + let res' = compact_proofs cnf_ff res cnf_ff' in + let ff', res', ids = (ff', res', Mc.ids_of_formula ff') in + let res' = dump_list spec.proof_typ spec.dump_proof res' in + Prf (ids, ff', res') - let res' = compact_proofs cnf_ff res cnf_ff' in - - let (ff',res',ids) = (ff',res', Mc.ids_of_formula ff') in - - let res' = dump_list (spec.proof_typ) spec.dump_proof res' in - Prf (ids,ff',res') - -let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl = +let micromega_tauto pre_process cnf spec prover env + (polys1 : (Names.Id.t * 'cst formula) list) (polys2 : 'cst formula) gl = try micromega_tauto pre_process cnf spec prover env polys1 polys2 gl with Not_found -> - begin - Printexc.print_backtrace stdout; flush stdout; - Unknown - end - + Printexc.print_backtrace stdout; + flush stdout; + Unknown (** * Parse the proof environment, and call micromega_tauto @@ -1818,194 +1825,234 @@ let fresh_id avoid id gl = Tactics.fresh_id_in_env avoid id (Proofview.Goal.env gl) let clear_all_no_check = - Proofview.Goal.enter begin fun gl -> - let concl = Tacmach.New.pf_concl gl in - let env = Environ.reset_with_named_context Environ.empty_named_context_val (Tacmach.New.pf_env gl) in - (Refine.refine ~typecheck:false begin fun sigma -> - Evarutil.new_evar env sigma ~principal:true concl - end) - end - - - -let micromega_gen - parse_arith - pre_process - cnf - spec dumpexpr prover tac = - Proofview.Goal.enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_hyps_types gl in - try - let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in - let env = Env.elements env in - let spec = Lazy.force spec in - let dumpexpr = Lazy.force dumpexpr in - - - if debug then Feedback.msg_debug (Pp.str "Env " ++ (Env.pp gl0 env)) ; - - match micromega_tauto pre_process cnf spec prover env hyps concl gl0 with - | Unknown -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Model(m,e) -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Prf (ids,ff',res') -> - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 dumpexpr ff' in - let intro (id,_) = Tactics.introduction id in - - let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in - let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - (* let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in*) - let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - - let tac_arith = Tacticals.New.tclTHENLIST [ clear_all_no_check ;intro_props ; intro_vars ; - micromega_order_change spec res' - (EConstr.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in - - let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in - - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - - let arith_args = goal_props @ goal_vars in + Proofview.Goal.enter (fun gl -> + let concl = Tacmach.New.pf_concl gl in + let env = + Environ.reset_with_named_context Environ.empty_named_context_val + (Tacmach.New.pf_env gl) + in + Refine.refine ~typecheck:false (fun sigma -> + Evarutil.new_evar env sigma ~principal:true concl)) - let kill_arith = Tacticals.New.tclTHEN tac_arith tac in -(* +let micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac = + Proofview.Goal.enter (fun gl -> + let sigma = Tacmach.New.project gl in + let concl = Tacmach.New.pf_concl gl in + let hyps = Tacmach.New.pf_hyps_types gl in + try + let gl0 = {env = Tacmach.New.pf_env gl; sigma} in + let hyps, concl, env = + parse_goal gl0 parse_arith (Env.empty gl0) hyps concl + in + let env = Env.elements env in + let spec = Lazy.force spec in + let dumpexpr = Lazy.force dumpexpr in + if debug then Feedback.msg_debug (Pp.str "Env " ++ Env.pp gl0 env); + match + micromega_tauto pre_process cnf spec prover env hyps concl gl0 + with + | Unknown -> + flush stdout; + Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Model (m, e) -> + Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Prf (ids, ff', res') -> + let arith_goal, props, vars, ff_arith = + make_goal_of_formula gl0 dumpexpr ff' + in + let intro (id, _) = Tactics.introduction id in + let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in + let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in + (* let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in*) + let goal_name = + fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl + in + let env' = List.map (fun (id, i) -> (EConstr.mkVar id, i)) vars in + let tac_arith = + Tacticals.New.tclTHENLIST + [ clear_all_no_check + ; intro_props + ; intro_vars + ; micromega_order_change spec res' + (EConstr.mkApp (Lazy.force coq_list, [|spec.proof_typ|])) + env' ff_arith ] + in + let goal_props = + List.rev (Env.elements (prop_env_of_formula gl0 ff')) + in + let goal_vars = List.map (fun (_, i) -> List.nth env (i - 1)) vars in + let arith_args = goal_props @ goal_vars in + let kill_arith = Tacticals.New.tclTHEN tac_arith tac in + (* (*tclABSTRACT fails in certain corner cases.*) Tacticals.New.tclTHEN clear_all_no_check (Abstract.tclABSTRACT ~opaque:false None (Tacticals.New.tclTHEN tac_arith tac)) in *) - - Tacticals.New.tclTHEN - (Tactics.assert_by (Names.Name goal_name) arith_goal - ((*Proofview.tclTIME (Some "kill_arith")*) kill_arith)) - ((*Proofview.tclTIME (Some "apply_arith") *) - (Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args@(List.map EConstr.mkVar ids))))) - with - | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") - | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str - (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" - ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - | x -> begin if debug then Tacticals.New.tclFAIL 0 (Pp.str (Printexc.get_backtrace ())) - else raise x - end - end - -let micromega_order_changer cert env ff = + Tacticals.New.tclTHEN + (Tactics.assert_by (Names.Name goal_name) arith_goal + (*Proofview.tclTIME (Some "kill_arith")*) kill_arith) + ((*Proofview.tclTIME (Some "apply_arith") *) + Tactics.exact_check + (EConstr.applist + ( EConstr.mkVar goal_name + , arith_args @ List.map EConstr.mkVar ids ))) + with + | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") + | CsdpNotFound -> + flush stdout; + Tacticals.New.tclFAIL 0 + (Pp.str + ( " Skipping what remains of this tactic: the complexity of the \ + goal requires " + ^ "the use of a specialized external tool called csdp. \n\n" + ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" \ + executable in the path. \n\n" + ^ "Csdp packages are provided by some OS distributions; binaries \ + and source code can be downloaded from \ + https://projects.coin-or.org/Csdp" )) + | x -> + if debug then + Tacticals.New.tclFAIL 0 (Pp.str (Printexc.get_backtrace ())) + else raise x) + +let micromega_order_changer cert env ff = (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) let coeff = Lazy.force coq_Rcst in let dump_coeff = dump_Rcst in - let typ = Lazy.force coq_R in - let cert_typ = (EConstr.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in - - let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[| coeff|])) in + let typ = Lazy.force coq_R in + let cert_typ = + EConstr.mkApp (Lazy.force coq_list, [|Lazy.force coq_QWitness|]) + in + let formula_typ = EConstr.mkApp (Lazy.force coq_Cstr, [|coeff|]) in let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in - let vm = dump_varmap (typ) (vm_of_list env) in - Proofview.Goal.enter begin fun gl -> - Tacticals.New.tclTHENLIST - [ - (Tactics.change_concl - (set - [ - ("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [|formula_typ |])); - ("__varmap", vm, EConstr.mkApp - (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); - ("__wit", cert, cert_typ) - ] - (Tacmach.New.pf_concl gl))); - (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) - ] - end + let vm = dump_varmap typ (vm_of_list env) in + Proofview.Goal.enter (fun gl -> + Tacticals.New.tclTHENLIST + [ Tactics.change_concl + (set + [ ( "__ff" + , ff + , EConstr.mkApp (Lazy.force coq_Formula, [|formula_typ|]) ) + ; ( "__varmap" + , vm + , EConstr.mkApp + ( gen_constant_in_modules "VarMap" + [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] + "t" + , [|typ|] ) ) + ; ("__wit", cert, cert_typ) ] + (Tacmach.New.pf_concl gl)) + (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) + ]) let micromega_genr prover tac = let parse_arith = parse_rarith in - let spec = lazy { - typ = Lazy.force coq_R; - coeff = Lazy.force coq_Rcst; - dump_coeff = dump_q; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_psatz coq_Q dump_q - } in - Proofview.Goal.enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_hyps_types gl in - - try - let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in - let env = Env.elements env in - let spec = Lazy.force spec in - - let hyps' = List.map (fun (n,f) -> (n, Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in - let concl' = Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) concl in - - match micromega_tauto (fun _ x -> x) Mc.cnfQ spec prover env hyps' concl' gl0 with - | Unknown | Model _ -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Prf (ids,ff',res') -> - let (ff,ids) = formula_hyps_concl - (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in - - let ff' = abstract_wrt_formula ff' ff in - - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 (Lazy.force dump_rexpr) ff' in - let intro (id,_) = Tactics.introduction id in - - let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in - let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in - let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - - let tac_arith = Tacticals.New.tclTHENLIST [ clear_all_no_check ; intro_props ; intro_vars ; - micromega_order_changer res' env' ff_arith ] in - - let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in - - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - - let arith_args = goal_props @ goal_vars in - - let kill_arith = Tacticals.New.tclTHEN tac_arith tac in - (* Tacticals.New.tclTHEN + let spec = + lazy + { typ = Lazy.force coq_R + ; coeff = Lazy.force coq_Rcst + ; dump_coeff = dump_q + ; proof_typ = Lazy.force coq_QWitness + ; dump_proof = dump_psatz coq_Q dump_q } + in + Proofview.Goal.enter (fun gl -> + let sigma = Tacmach.New.project gl in + let concl = Tacmach.New.pf_concl gl in + let hyps = Tacmach.New.pf_hyps_types gl in + try + let gl0 = {env = Tacmach.New.pf_env gl; sigma} in + let hyps, concl, env = + parse_goal gl0 parse_arith (Env.empty gl0) hyps concl + in + let env = Env.elements env in + let spec = Lazy.force spec in + let hyps' = + List.map + (fun (n, f) -> + (n, Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) f)) + hyps + in + let concl' = + Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) concl + in + match + micromega_tauto + (fun _ x -> x) + Mc.cnfQ spec prover env hyps' concl' gl0 + with + | Unknown | Model _ -> + flush stdout; + Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Prf (ids, ff', res') -> + let ff, ids = + formula_hyps_concl + (List.filter (fun (n, _) -> List.mem n ids) hyps) + concl + in + let ff' = abstract_wrt_formula ff' ff in + let arith_goal, props, vars, ff_arith = + make_goal_of_formula gl0 (Lazy.force dump_rexpr) ff' + in + let intro (id, _) = Tactics.introduction id in + let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in + let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in + let ipat_of_name id = + Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) + in + let goal_name = + fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl + in + let env' = List.map (fun (id, i) -> (EConstr.mkVar id, i)) vars in + let tac_arith = + Tacticals.New.tclTHENLIST + [ clear_all_no_check + ; intro_props + ; intro_vars + ; micromega_order_changer res' env' ff_arith ] + in + let goal_props = + List.rev (Env.elements (prop_env_of_formula gl0 ff')) + in + let goal_vars = List.map (fun (_, i) -> List.nth env (i - 1)) vars in + let arith_args = goal_props @ goal_vars in + let kill_arith = Tacticals.New.tclTHEN tac_arith tac in + (* Tacticals.New.tclTHEN (Tactics.keep []) (Tactics.tclABSTRACT None*) - - Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) - [ - kill_arith; - (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - (Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args))) - ] ) - ] - - with - | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") - | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str - (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" - ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end - - -let lift_ratproof prover l = - match prover l with + Tacticals.New.tclTHENS + (Tactics.forward true (Some None) (ipat_of_name goal_name) + arith_goal) + [ kill_arith + ; Tacticals.New.tclTHENLIST + [ Tactics.generalize (List.map EConstr.mkVar ids) + ; Tactics.exact_check + (EConstr.applist (EConstr.mkVar goal_name, arith_args)) ] ] + with + | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") + | CsdpNotFound -> + flush stdout; + Tacticals.New.tclFAIL 0 + (Pp.str + ( " Skipping what remains of this tactic: the complexity of the \ + goal requires " + ^ "the use of a specialized external tool called csdp. \n\n" + ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" \ + executable in the path. \n\n" + ^ "Csdp packages are provided by some OS distributions; binaries \ + and source code can be downloaded from \ + https://projects.coin-or.org/Csdp" ))) + +let lift_ratproof prover l = + match prover l with | Unknown | Model _ -> Unknown - | Prf c -> Prf (Mc.RatProof( c,Mc.DoneProof)) + | Prf c -> Prf (Mc.RatProof (c, Mc.DoneProof)) type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list [@@@ocaml.warning "-37"] + type csdp_certificate = S of Sos_types.positivstellensatz option | F of string + (* Used to read the result of the execution of csdpcert *) type provername = string * int option @@ -2016,47 +2063,47 @@ type provername = string * int option open Persistent_cache +module MakeCache (T : sig + type prover_option + type coeff -module MakeCache(T : sig type prover_option - type coeff - val hash_prover_option : int -> prover_option -> int - val hash_coeff : int -> coeff -> int - val eq_prover_option : prover_option -> prover_option -> bool - val eq_coeff : coeff -> coeff -> bool - - end) = - struct - module E = - struct - type t = T.prover_option * (T.coeff Mc.pol * Mc.op1) list - - let equal = Hash.(eq_pair T.eq_prover_option (CList.equal (eq_pair (eq_pol T.eq_coeff) Hash.eq_op1))) + val hash_prover_option : int -> prover_option -> int + val hash_coeff : int -> coeff -> int + val eq_prover_option : prover_option -> prover_option -> bool + val eq_coeff : coeff -> coeff -> bool +end) = +struct + module E = struct + type t = T.prover_option * (T.coeff Mc.pol * Mc.op1) list - let hash = - let hash_cstr = Hash.(hash_pair (hash_pol T.hash_coeff) hash_op1) in - Hash.( (hash_pair T.hash_prover_option (List.fold_left hash_cstr)) 0) - end + let equal = + Hash.( + eq_pair T.eq_prover_option + (CList.equal (eq_pair (eq_pol T.eq_coeff) Hash.eq_op1))) - include PHashtable(E) + let hash = + let hash_cstr = Hash.(hash_pair (hash_pol T.hash_coeff) hash_op1) in + Hash.((hash_pair T.hash_prover_option (List.fold_left hash_cstr)) 0) + end - let memo_opt use_cache cache_file f = - let memof = memo cache_file f in - fun x -> if !use_cache then memof x else f x + include PHashtable (E) - end + let memo_opt use_cache cache_file f = + let memof = memo cache_file f in + fun x -> if !use_cache then memof x else f x +end +module CacheCsdp = MakeCache (struct + type prover_option = provername + type coeff = Mc.q + let hash_prover_option = + Hash.(hash_pair hash_string (hash_elt (Option.hash (fun x -> x)))) -module CacheCsdp = MakeCache(struct - type prover_option = provername - type coeff = Mc.q - let hash_prover_option = Hash.(hash_pair hash_string - (hash_elt (Option.hash (fun x -> x)))) - let eq_prover_option = Hash.(eq_pair String.equal - (Option.equal Int.equal)) - let hash_coeff = Hash.hash_q - let eq_coeff = Hash.eq_q - end) + let eq_prover_option = Hash.(eq_pair String.equal (Option.equal Int.equal)) + let hash_coeff = Hash.hash_q + let eq_coeff = Hash.eq_q +end) (** * Build the command to call csdpcert, and launch it. This in turn will call @@ -2065,233 +2112,237 @@ module CacheCsdp = MakeCache(struct *) let require_csdp = - if System.is_in_system_path "csdp" - then lazy () - else lazy (raise CsdpNotFound) - -let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option = - fun provername poly -> + if System.is_in_system_path "csdp" then lazy () else lazy (raise CsdpNotFound) +let really_call_csdpcert : + provername -> micromega_polys -> Sos_types.positivstellensatz option = + fun provername poly -> Lazy.force require_csdp; - let cmdname = List.fold_left Filename.concat (Envars.coqlib ()) - ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in - - match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with - | F str -> - if debug then Printf.fprintf stdout "really_call_csdpcert : %s\n" str; - raise (failwith str) - | S res -> res + ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] + in + match (command cmdname [|cmdname|] (provername, poly) : csdp_certificate) with + | F str -> + if debug then Printf.fprintf stdout "really_call_csdpcert : %s\n" str; + raise (failwith str) + | S res -> res (** * Check the cache before calling the prover. *) let xcall_csdpcert = - CacheCsdp.memo_opt use_csdp_cache ".csdp.cache" (fun (prover,pb) -> really_call_csdpcert prover pb) + CacheCsdp.memo_opt use_csdp_cache ".csdp.cache" (fun (prover, pb) -> + really_call_csdpcert prover pb) (** * Prover callback functions. *) -let call_csdpcert prover pb = xcall_csdpcert (prover,pb) +let call_csdpcert prover pb = xcall_csdpcert (prover, pb) let rec z_to_q_pol e = - match e with - | Mc.Pc z -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH} - | Mc.Pinj(p,pol) -> Mc.Pinj(p,z_to_q_pol pol) - | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2) + match e with + | Mc.Pc z -> Mc.Pc {Mc.qnum = z; Mc.qden = Mc.XH} + | Mc.Pinj (p, pol) -> Mc.Pinj (p, z_to_q_pol pol) + | Mc.PX (pol1, p, pol2) -> Mc.PX (z_to_q_pol pol1, p, z_to_q_pol pol2) let call_csdpcert_q provername poly = - match call_csdpcert provername poly with + match call_csdpcert provername poly with | None -> Unknown | Some cert -> - let cert = Certificate.q_cert_of_pos cert in - if Mc.qWeakChecker poly cert - then Prf cert - else ((print_string "buggy certificate") ;Unknown) + let cert = Certificate.q_cert_of_pos cert in + if Mc.qWeakChecker poly cert then Prf cert + else ( + print_string "buggy certificate"; + Unknown ) let call_csdpcert_z provername poly = - let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in + let l = List.map (fun (e, o) -> (z_to_q_pol e, o)) poly in match call_csdpcert provername l with - | None -> Unknown - | Some cert -> - let cert = Certificate.z_cert_of_pos cert in - if Mc.zWeakChecker poly cert - then Prf cert - else ((print_string "buggy certificate" ; flush stdout) ;Unknown) + | None -> Unknown + | Some cert -> + let cert = Certificate.z_cert_of_pos cert in + if Mc.zWeakChecker poly cert then Prf cert + else ( + print_string "buggy certificate"; + flush stdout; + Unknown ) let xhyps_of_cone base acc prf = let rec xtract e acc = match e with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc - | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in - if n >= base - then ISet.add (n-base) acc - else acc - | Mc.PsatzMulC(_,c) -> xtract c acc - | Mc.PsatzAdd(e1,e2) | Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in - - xtract prf acc + | Mc.PsatzIn n -> + let n = CoqToCaml.nat n in + if n >= base then ISet.add (n - base) acc else acc + | Mc.PsatzMulC (_, c) -> xtract c acc + | Mc.PsatzAdd (e1, e2) | Mc.PsatzMulE (e1, e2) -> xtract e1 (xtract e2 acc) + in + xtract prf acc let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf -let compact_cone prf f = +let compact_cone prf f = let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in - let rec xinterp prf = match prf with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf | Mc.PsatzIn n -> Mc.PsatzIn (np n) - | Mc.PsatzMulC(e,c) -> Mc.PsatzMulC(e,xinterp c) - | Mc.PsatzAdd(e1,e2) -> Mc.PsatzAdd(xinterp e1,xinterp e2) - | Mc.PsatzMulE(e1,e2) -> Mc.PsatzMulE(xinterp e1,xinterp e2) in - - xinterp prf + | Mc.PsatzMulC (e, c) -> Mc.PsatzMulC (e, xinterp c) + | Mc.PsatzAdd (e1, e2) -> Mc.PsatzAdd (xinterp e1, xinterp e2) + | Mc.PsatzMulE (e1, e2) -> Mc.PsatzMulE (xinterp e1, xinterp e2) + in + xinterp prf let hyps_of_pt pt = - let rec xhyps base pt acc = match pt with - | Mc.DoneProof -> acc - | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) - | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) - | Mc.EnumProof(c1,c2,l) -> - let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in - List.fold_left (fun s x -> xhyps (base + 1) x s) s l in - - xhyps 0 pt ISet.empty + | Mc.DoneProof -> acc + | Mc.RatProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c) + | Mc.CutProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c) + | Mc.EnumProof (c1, c2, l) -> + let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in + List.fold_left (fun s x -> xhyps (base + 1) x s) s l + | Mc.ExProof (_, pt) -> xhyps (base + 3) pt acc + in + xhyps 0 pt ISet.empty let compact_pt pt f = - let translate ofset x = - if x < ofset then x - else (f (x-ofset) + ofset) in - + let translate ofset x = if x < ofset then x else f (x - ofset) + ofset in let rec compact_pt ofset pt = match pt with - | Mc.DoneProof -> Mc.DoneProof - | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) - | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) - | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)), - Mc.map (fun x -> compact_pt (ofset+1) x) l) in - compact_pt 0 pt + | Mc.DoneProof -> Mc.DoneProof + | Mc.RatProof (c, pt) -> + Mc.RatProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt) + | Mc.CutProof (c, pt) -> + Mc.CutProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt) + | Mc.EnumProof (c1, c2, l) -> + Mc.EnumProof + ( compact_cone c1 (translate ofset) + , compact_cone c2 (translate ofset) + , Mc.map (fun x -> compact_pt (ofset + 1) x) l ) + | Mc.ExProof (x, pt) -> Mc.ExProof (x, compact_pt (ofset + 3) pt) + in + compact_pt 0 pt (** * Definition of provers. * Instantiates the type ('a,'prf) prover defined above. *) -let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) - - -module CacheZ = MakeCache(struct - type prover_option = bool * bool* int - type coeff = Mc.z - let hash_prover_option : int -> prover_option -> int = Hash.hash_elt Hashtbl.hash - let eq_prover_option : prover_option -> prover_option -> bool = (=) - let eq_coeff = Hash.eq_z - let hash_coeff = Hash.hash_z - end) - -module CacheQ = MakeCache(struct - type prover_option = int - type coeff = Mc.q - let hash_prover_option : int -> int -> int = Hash.hash_elt Hashtbl.hash - let eq_prover_option = Int.equal - let eq_coeff = Hash.eq_q - let hash_coeff = Hash.hash_q - end) - -let memo_lia = CacheZ.memo_opt use_lia_cache ".lia.cache" - (fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) -let memo_nlia = CacheZ.memo_opt use_nia_cache ".nia.cache" - (fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) -let memo_nra = CacheQ.memo_opt use_nra_cache ".nra.cache" - (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) - - - -let linear_prover_Q = { - name = "linear prover"; - get_option = get_lra_option ; - prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - - -let linear_prover_R = { - name = "linear prover"; - get_option = get_lra_option ; - prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let nlinear_prover_R = { - name = "nra"; - get_option = get_lra_option; - prover = memo_nra ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_Q str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> call_csdpcert_q o l); - hyps = hyps_of_cone; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_R str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> call_csdpcert_q o l); - hyps = hyps_of_cone; - compact = compact_cone; - pp_prf = pp_psatz pp_q; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_Z str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} - -let linear_Z = { - name = "lia"; - get_option = get_lia_option; - prover = memo_lia ; - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} - -let nlinear_Z = { - name = "nlia"; - get_option = get_lia_option; - prover = memo_nlia ; - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} +let lift_pexpr_prover p l = p (List.map (fun (e, o) -> (Mc.denorm e, o)) l) + +module CacheZ = MakeCache (struct + type prover_option = bool * bool * int + type coeff = Mc.z + + let hash_prover_option : int -> prover_option -> int = + Hash.hash_elt Hashtbl.hash + + let eq_prover_option : prover_option -> prover_option -> bool = ( = ) + let eq_coeff = Hash.eq_z + let hash_coeff = Hash.hash_z +end) + +module CacheQ = MakeCache (struct + type prover_option = int + type coeff = Mc.q + + let hash_prover_option : int -> int -> int = Hash.hash_elt Hashtbl.hash + let eq_prover_option = Int.equal + let eq_coeff = Hash.eq_q + let hash_coeff = Hash.hash_q +end) + +let memo_lia = + CacheZ.memo_opt use_lia_cache ".lia.cache" (fun ((_, ce, b), s) -> + lift_pexpr_prover (Certificate.lia ce b) s) + +let memo_nlia = + CacheZ.memo_opt use_nia_cache ".nia.cache" (fun ((_, ce, b), s) -> + lift_pexpr_prover (Certificate.nlia ce b) s) + +let memo_nra = + CacheQ.memo_opt use_nra_cache ".nra.cache" (fun (o, s) -> + lift_pexpr_prover (Certificate.nlinear_prover o) s) + +let linear_prover_Q = + { name = "linear prover" + ; get_option = get_lra_option + ; prover = + (fun (o, l) -> + lift_pexpr_prover (Certificate.linear_prover_with_cert o) l) + ; hyps = hyps_of_cone + ; compact = compact_cone + ; pp_prf = pp_psatz pp_q + ; pp_f = (fun o x -> pp_pol pp_q o (fst x)) } + +let linear_prover_R = + { name = "linear prover" + ; get_option = get_lra_option + ; prover = + (fun (o, l) -> + lift_pexpr_prover (Certificate.linear_prover_with_cert o) l) + ; hyps = hyps_of_cone + ; compact = compact_cone + ; pp_prf = pp_psatz pp_q + ; pp_f = (fun o x -> pp_pol pp_q o (fst x)) } + +let nlinear_prover_R = + { name = "nra" + ; get_option = get_lra_option + ; prover = memo_nra + ; hyps = hyps_of_cone + ; compact = compact_cone + ; pp_prf = pp_psatz pp_q + ; pp_f = (fun o x -> pp_pol pp_q o (fst x)) } + +let non_linear_prover_Q str o = + { name = "real nonlinear prover" + ; get_option = (fun () -> (str, o)) + ; prover = (fun (o, l) -> call_csdpcert_q o l) + ; hyps = hyps_of_cone + ; compact = compact_cone + ; pp_prf = pp_psatz pp_q + ; pp_f = (fun o x -> pp_pol pp_q o (fst x)) } + +let non_linear_prover_R str o = + { name = "real nonlinear prover" + ; get_option = (fun () -> (str, o)) + ; prover = (fun (o, l) -> call_csdpcert_q o l) + ; hyps = hyps_of_cone + ; compact = compact_cone + ; pp_prf = pp_psatz pp_q + ; pp_f = (fun o x -> pp_pol pp_q o (fst x)) } + +let non_linear_prover_Z str o = + { name = "real nonlinear prover" + ; get_option = (fun () -> (str, o)) + ; prover = (fun (o, l) -> lift_ratproof (call_csdpcert_z o) l) + ; hyps = hyps_of_pt + ; compact = compact_pt + ; pp_prf = pp_proof_term + ; pp_f = (fun o x -> pp_pol pp_z o (fst x)) } + +let linear_Z = + { name = "lia" + ; get_option = get_lia_option + ; prover = memo_lia + ; hyps = hyps_of_pt + ; compact = compact_pt + ; pp_prf = pp_proof_term + ; pp_f = (fun o x -> pp_pol pp_z o (fst x)) } + +let nlinear_Z = + { name = "nlia" + ; get_option = get_lia_option + ; prover = memo_nlia + ; hyps = hyps_of_pt + ; compact = compact_pt + ; pp_prf = pp_proof_term + ; pp_f = (fun o x -> pp_pol pp_z o (fst x)) } (** * Functions instantiating micromega_gen with the appropriate theories and @@ -2299,67 +2350,71 @@ let nlinear_Z = { *) let exfalso_if_concl_not_Prop = - Proofview.Goal.enter begin fun gl -> - Tacmach.New.( - if is_prop (pf_env gl) (project gl) (pf_concl gl) - then Tacticals.New.tclIDTAC - else Tactics.elim_type (Lazy.force coq_False) - ) - end + Proofview.Goal.enter (fun gl -> + Tacmach.New.( + if is_prop (pf_env gl) (project gl) (pf_concl gl) then + Tacticals.New.tclIDTAC + else Tactics.elim_type (Lazy.force coq_False))) let micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac = - Tacticals.New.tclTHEN exfalso_if_concl_not_Prop (micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac) + Tacticals.New.tclTHEN exfalso_if_concl_not_Prop + (micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac) let micromega_genr prover tac = Tacticals.New.tclTHEN exfalso_if_concl_not_Prop (micromega_genr prover tac) let lra_Q = - micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr - linear_prover_Q + micromega_gen parse_qarith + (fun _ x -> x) + Mc.cnfQ qq_domain_spec dump_qexpr linear_prover_Q -let psatz_Q i = - micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr - (non_linear_prover_Q "real_nonlinear_prover" (Some i) ) +let psatz_Q i = + micromega_gen parse_qarith + (fun _ x -> x) + Mc.cnfQ qq_domain_spec dump_qexpr + (non_linear_prover_Q "real_nonlinear_prover" (Some i)) -let lra_R = - micromega_genr linear_prover_R +let lra_R = micromega_genr linear_prover_R -let psatz_R i = - micromega_genr (non_linear_prover_R "real_nonlinear_prover" (Some i)) +let psatz_R i = + micromega_genr (non_linear_prover_R "real_nonlinear_prover" (Some i)) +let psatz_Z i = + micromega_gen parse_zarith + (fun _ x -> x) + Mc.cnfZ zz_domain_spec dump_zexpr + (non_linear_prover_Z "real_nonlinear_prover" (Some i)) -let psatz_Z i = - micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr - (non_linear_prover_Z "real_nonlinear_prover" (Some i) ) +let sos_Z = + micromega_gen parse_zarith + (fun _ x -> x) + Mc.cnfZ zz_domain_spec dump_zexpr + (non_linear_prover_Z "pure_sos" None) -let sos_Z = - micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr - (non_linear_prover_Z "pure_sos" None) - -let sos_Q = - micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr - (non_linear_prover_Q "pure_sos" None) - - -let sos_R = - micromega_genr (non_linear_prover_R "pure_sos" None) +let sos_Q = + micromega_gen parse_qarith + (fun _ x -> x) + Mc.cnfQ qq_domain_spec dump_qexpr + (non_linear_prover_Q "pure_sos" None) +let sos_R = micromega_genr (non_linear_prover_R "pure_sos" None) let xlia = - micromega_gen parse_zarith pre_processZ Mc.cnfZ zz_domain_spec dump_zexpr - linear_Z - + micromega_gen parse_zarith + (fun _ x -> x) + Mc.cnfZ zz_domain_spec dump_zexpr linear_Z -let xnlia = - micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr - nlinear_Z +let xnlia = + micromega_gen parse_zarith + (fun _ x -> x) + Mc.cnfZ zz_domain_spec dump_zexpr nlinear_Z -let nra = - micromega_genr nlinear_prover_R +let nra = micromega_genr nlinear_prover_R -let nqa = - micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr - nlinear_prover_R +let nqa = + micromega_gen parse_qarith + (fun _ x -> x) + Mc.cnfQ qq_domain_spec dump_qexpr nlinear_prover_R (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli index 844ff5b1a6..37ea560241 100644 --- a/plugins/micromega/coq_micromega.mli +++ b/plugins/micromega/coq_micromega.mli @@ -22,8 +22,7 @@ val sos_R : unit Proofview.tactic -> unit Proofview.tactic val lra_Q : unit Proofview.tactic -> unit Proofview.tactic val lra_R : unit Proofview.tactic -> unit Proofview.tactic - (** {5 Use Micromega independently from tactics. } *) -(** [dump_proof_term] generates the Coq representation of a Micromega proof witness *) val dump_proof_term : Micromega.zArithProof -> EConstr.t +(** [dump_proof_term] generates the Coq representation of a Micromega proof witness *) diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index 09e354957a..90dd81adf4 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -18,7 +18,6 @@ open Num open Sos open Sos_types open Sos_lib - module Mc = Micromega module C2Ml = Mutils.CoqToCaml @@ -26,157 +25,179 @@ type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list type csdp_certificate = S of Sos_types.positivstellensatz option | F of string type provername = string * int option - -let flags = [Open_append;Open_binary;Open_creat] - +let flags = [Open_append; Open_binary; Open_creat] let chan = open_out_gen flags 0o666 "trace" +module M = struct + open Mc -module M = -struct - open Mc - - let rec expr_to_term = function - | PEc z -> Const (C2Ml.q_to_num z) - | PEX v -> Var ("x"^(string_of_int (C2Ml.index v))) - | PEmul(p1,p2) -> + let rec expr_to_term = function + | PEc z -> Const (C2Ml.q_to_num z) + | PEX v -> Var ("x" ^ string_of_int (C2Ml.index v)) + | PEmul (p1, p2) -> let p1 = expr_to_term p1 in let p2 = expr_to_term p2 in - let res = Mul(p1,p2) in res - - | PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2) - | PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2) - | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n) - | PEopp p -> Opp (expr_to_term p) - - + let res = Mul (p1, p2) in + res + | PEadd (p1, p2) -> Add (expr_to_term p1, expr_to_term p2) + | PEsub (p1, p2) -> Sub (expr_to_term p1, expr_to_term p2) + | PEpow (p, n) -> Pow (expr_to_term p, C2Ml.n n) + | PEopp p -> Opp (expr_to_term p) end + open M let partition_expr l = - let rec f i = function - | [] -> ([],[],[]) - | (e,k)::l -> - let (eq,ge,neq) = f (i+1) l in + let rec f i = function + | [] -> ([], [], []) + | (e, k) :: l -> ( + let eq, ge, neq = f (i + 1) l in match k with - | Mc.Equal -> ((e,i)::eq,ge,neq) - | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq) - | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *) - (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq) - | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) - (* Not quite sure -- Coq interface has changed *) - in f 0 l - + | Mc.Equal -> ((e, i) :: eq, ge, neq) + | Mc.NonStrict -> (eq, (e, Axiom_le i) :: ge, neq) + | Mc.Strict -> + (* e > 0 == e >= 0 /\ e <> 0 *) + (eq, (e, Axiom_lt i) :: ge, (e, Axiom_lt i) :: neq) + | Mc.NonEqual -> (eq, ge, (e, Axiom_eq i) :: neq) ) + (* Not quite sure -- Coq interface has changed *) + in + f 0 l let rec sets_of_list l = - match l with + match l with | [] -> [[]] - | e::l -> let s = sets_of_list l in - s@(List.map (fun s0 -> e::s0) s) + | e :: l -> + let s = sets_of_list l in + s @ List.map (fun s0 -> e :: s0) s (* The exploration is probably not complete - for simple cases, it works... *) let real_nonlinear_prover d l = - let l = List.map (fun (e,op) -> (Mc.denorm e,op)) l in - try - let (eq,ge,neq) = partition_expr l in - - let rec elim_const = function - [] -> [] - | (x,y)::l -> let p = poly_of_term (expr_to_term x) in - if poly_isconst p - then elim_const l - else (p,y)::(elim_const l) in - - let eq = elim_const eq in - let peq = List.map fst eq in - - let pge = List.map - (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in - - let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y -> - let p = poly_of_term (expr_to_term p) in - match kd with - | Axiom_lt i -> poly_mul p y - | Axiom_eq i -> poly_mul (poly_pow p 2) y - | _ -> failwith "monoids") m (poly_const (Int 1)) , List.map snd m)) - (sets_of_list neq) in - - let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> - tryfind (fun m -> let (ci,cc) = - real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in - (ci,cc,snd m)) monoids) 0 in - - let proofs_ideal = List.map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i)) - cert_ideal (List.map snd eq) in - - let proofs_cone = List.map term_of_sos cert_cone in - - let proof_ne = - let (neq , lt) = List.partition - (function Axiom_eq _ -> true | _ -> false ) monoid in - let sq = match - (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq) - with - | [] -> Rational_lt (Int 1) - | l -> Monoid l in - List.fold_right (fun x y -> Product(x,y)) lt sq in - - let proof = end_itlist - (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in - S (Some proof) - with + let l = List.map (fun (e, op) -> (Mc.denorm e, op)) l in + try + let eq, ge, neq = partition_expr l in + let rec elim_const = function + | [] -> [] + | (x, y) :: l -> + let p = poly_of_term (expr_to_term x) in + if poly_isconst p then elim_const l else (p, y) :: elim_const l + in + let eq = elim_const eq in + let peq = List.map fst eq in + let pge = + List.map (fun (e, psatz) -> (poly_of_term (expr_to_term e), psatz)) ge + in + let monoids = + List.map + (fun m -> + ( List.fold_right + (fun (p, kd) y -> + let p = poly_of_term (expr_to_term p) in + match kd with + | Axiom_lt i -> poly_mul p y + | Axiom_eq i -> poly_mul (poly_pow p 2) y + | _ -> failwith "monoids") + m (poly_const (Int 1)) + , List.map snd m )) + (sets_of_list neq) + in + let cert_ideal, cert_cone, monoid = + deepen_until d + (fun d -> + tryfind + (fun m -> + let ci, cc = + real_positivnullstellensatz_general false d peq pge + (poly_neg (fst m)) + in + (ci, cc, snd m)) + monoids) + 0 + in + let proofs_ideal = + List.map2 + (fun q i -> Eqmul (term_of_poly q, Axiom_eq i)) + cert_ideal (List.map snd eq) + in + let proofs_cone = List.map term_of_sos cert_cone in + let proof_ne = + let neq, lt = + List.partition (function Axiom_eq _ -> true | _ -> false) monoid + in + let sq = + match + List.map (function Axiom_eq i -> i | _ -> failwith "error") neq + with + | [] -> Rational_lt (Int 1) + | l -> Monoid l + in + List.fold_right (fun x y -> Product (x, y)) lt sq + in + let proof = + end_itlist + (fun s t -> Sum (s, t)) + ((proof_ne :: proofs_ideal) @ proofs_cone) + in + S (Some proof) + with | Sos_lib.TooDeep -> S None | any -> F (Printexc.to_string any) (* This is somewhat buggy, over Z, strict inequality vanish... *) -let pure_sos l = - let l = List.map (fun (e,o) -> Mc.denorm e, o) l in - - (* If there is no strict inequality, +let pure_sos l = + let l = List.map (fun (e, o) -> (Mc.denorm e, o)) l in + (* If there is no strict inequality, I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) - try - let l = List.combine l (CList.interval 0 (List.length l -1)) in - let (lt,i) = try (List.find (fun (x,_) -> (=) (snd x) Mc.Strict) l) - with Not_found -> List.hd l in - let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in - let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *) - let pos = Product (Rational_lt n, - List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square - (term_of_poly p)), rst)) - polys (Rational_lt (Int 0))) in - let proof = Sum(Axiom_lt i, pos) in -(* let s,proof' = scale_certificate proof in + try + let l = List.combine l (CList.interval 0 (List.length l - 1)) in + let lt, i = + try List.find (fun (x, _) -> snd x = Mc.Strict) l + with Not_found -> List.hd l + in + let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in + let n, polys = sumofsquares plt in + (* n * (ci * pi^2) *) + let pos = + Product + ( Rational_lt n + , List.fold_right + (fun (c, p) rst -> + Sum (Product (Rational_lt c, Square (term_of_poly p)), rst)) + polys (Rational_lt (Int 0)) ) + in + let proof = Sum (Axiom_lt i, pos) in + (* let s,proof' = scale_certificate proof in let cert = snd (cert_of_pos proof') in *) S (Some proof) - with -(* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) - | any -> (* May be that could be refined *) S None - - + with (* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) + | any -> + (* May be that could be refined *) S None let run_prover prover pb = - match prover with - | "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb - | "pure_sos", None -> pure_sos pb - | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) + match prover with + | "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb + | "pure_sos", None -> pure_sos pb + | prover, _ -> + Printf.printf "unknown prover: %s\n" prover; + exit 1 let main () = try - let (prover,poly) = (input_value stdin : provername * micromega_polys) in + let (prover, poly) = (input_value stdin : provername * micromega_polys) in let cert = run_prover prover poly in -(* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ; + (* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ; close_out chan ; *) - - output_value stdout (cert:csdp_certificate); - flush stdout ; - Marshal.to_channel chan (cert:csdp_certificate) [] ; - flush chan ; - exit 0 - with any -> (Printf.fprintf chan "error %s" (Printexc.to_string any) ; exit 1) + output_value stdout (cert : csdp_certificate); + flush stdout; + Marshal.to_channel chan (cert : csdp_certificate) []; + flush chan; + exit 0 + with any -> + Printf.fprintf chan "error %s" (Printexc.to_string any); + exit 1 ;; - -let _ = main () in () +let _ = main () in +() (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/itv.ml b/plugins/micromega/itv.ml index 533b060dd3..214edb46ba 100644 --- a/plugins/micromega/itv.ml +++ b/plugins/micromega/itv.ml @@ -12,9 +12,9 @@ open Num - (** The type of intervals is *) - type interval = num option * num option - (** None models the absence of bound i.e. infinity +(** The type of intervals is *) +type interval = num option * num option +(** None models the absence of bound i.e. infinity As a result, - None , None -> \]-oo,+oo\[ - None , Some v -> \]-oo,v\] @@ -23,59 +23,51 @@ open Num Intervals needs to be explicitly normalised. *) - let pp o (n1,n2) = - (match n1 with - | None -> output_string o "]-oo" - | Some n -> Printf.fprintf o "[%s" (string_of_num n) - ); - output_string o ","; - (match n2 with - | None -> output_string o "+oo[" - | Some n -> Printf.fprintf o "%s]" (string_of_num n) - ) +let pp o (n1, n2) = + ( match n1 with + | None -> output_string o "]-oo" + | Some n -> Printf.fprintf o "[%s" (string_of_num n) ); + output_string o ","; + match n2 with + | None -> output_string o "+oo[" + | Some n -> Printf.fprintf o "%s]" (string_of_num n) - - - (** if then interval [itv] is empty, [norm_itv itv] returns [None] +(** if then interval [itv] is empty, [norm_itv itv] returns [None] otherwise, it returns [Some itv] *) - let norm_itv itv = - match itv with - | Some a , Some b -> if a <=/ b then Some itv else None - | _ -> Some itv +let norm_itv itv = + match itv with + | Some a, Some b -> if a <=/ b then Some itv else None + | _ -> Some itv (** [inter i1 i2 = None] if the intersection of intervals is empty [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) - let inter i1 i2 = - let (l1,r1) = i1 - and (l2,r2) = i2 in - - let inter f o1 o2 = - match o1 , o2 with - | None , None -> None - | Some _ , None -> o1 - | None , Some _ -> o2 - | Some n1 , Some n2 -> Some (f n1 n2) in - - norm_itv (inter max_num l1 l2 , inter min_num r1 r2) - - let range = function - | None,_ | _,None -> None - | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) - - - let smaller_itv i1 i2 = - match range i1 , range i2 with - | None , _ -> false - | _ , None -> true - | Some i , Some j -> i <=/ j - +let inter i1 i2 = + let l1, r1 = i1 and l2, r2 = i2 in + let inter f o1 o2 = + match (o1, o2) with + | None, None -> None + | Some _, None -> o1 + | None, Some _ -> o2 + | Some n1, Some n2 -> Some (f n1 n2) + in + norm_itv (inter max_num l1 l2, inter min_num r1 r2) + +let range = function + | None, _ | _, None -> None + | Some i, Some j -> Some (floor_num j -/ ceiling_num i +/ Int 1) + +let smaller_itv i1 i2 = + match (range i1, range i2) with + | None, _ -> false + | _, None -> true + | Some i, Some j -> i <=/ j (** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *) let in_bound bnd v = - let (l,r) = bnd in - match l , r with - | None , None -> true - | None , Some a -> v <=/ a - | Some a , None -> a <=/ v - | Some a , Some b -> a <=/ v && v <=/ b + let l, r = bnd in + match (l, r) with + | None, None -> true + | None, Some a -> v <=/ a + | Some a, None -> a <=/ v + | Some a, Some b -> a <=/ v && v <=/ b diff --git a/plugins/micromega/itv.mli b/plugins/micromega/itv.mli index 7b7edc64ea..c7164f2c98 100644 --- a/plugins/micromega/itv.mli +++ b/plugins/micromega/itv.mli @@ -10,6 +10,7 @@ open Num type interval = num option * num option + val pp : out_channel -> interval -> unit val inter : interval -> interval -> interval option val range : interval -> num option diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 75cdfa24f1..da75137185 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -14,37 +14,25 @@ open Polynomial open Vect let debug = false - let compare_float (p : float) q = pervasives_compare p q -(** Implementation of intervals *) open Itv +(** Implementation of intervals *) + type vector = Vect.t (** 'cstr' is the type of constraints. {coeffs = v ; bound = (l,r) } models the constraints l <= v <= r **) -module ISet = Set.Make(Int) +module ISet = Set.Make (Int) +module System = Hashtbl.Make (Vect) -module System = Hashtbl.Make(Vect) +type proof = Assum of int | Elim of var * proof * proof | And of proof * proof -type proof = -| Assum of int -| Elim of var * proof * proof -| And of proof * proof - -type system = { - sys : cstr_info ref System.t ; - vars : ISet.t -} -and cstr_info = { - bound : interval ; - prf : proof ; - pos : int ; - neg : int ; -} +type system = {sys : cstr_info ref System.t; vars : ISet.t} +and cstr_info = {bound : interval; prf : proof; pos : int; neg : int} (** A system of constraints has the form [\{sys = s ; vars = v\}]. [s] is a hashtable mapping a normalised vector to a [cstr_info] record where @@ -58,31 +46,29 @@ and cstr_info = { [v] is an upper-bound of the set of variables which appear in [s]. *) -(** To be thrown when a system has no solution *) exception SystemContradiction of proof +(** To be thrown when a system has no solution *) (** Pretty printing *) - let rec pp_proof o prf = - match prf with - | Assum i -> Printf.fprintf o "H%i" i - | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2 - | And(prf1,prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2 - -let pp_cstr o (vect,bnd) = - let (l,r) = bnd in - (match l with - | None -> () - | Some n -> Printf.fprintf o "%s <= " (string_of_num n)) - ; - Vect.pp o vect ; - (match r with - | None -> output_string o"\n" - | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)) - - -let pp_system o sys= - System.iter (fun vect ibnd -> - pp_cstr o (vect,(!ibnd).bound)) sys +let rec pp_proof o prf = + match prf with + | Assum i -> Printf.fprintf o "H%i" i + | Elim (v, prf1, prf2) -> + Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2 + | And (prf1, prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2 + +let pp_cstr o (vect, bnd) = + let l, r = bnd in + ( match l with + | None -> () + | Some n -> Printf.fprintf o "%s <= " (string_of_num n) ); + Vect.pp o vect; + match r with + | None -> output_string o "\n" + | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n) + +let pp_system o sys = + System.iter (fun vect ibnd -> pp_cstr o (vect, !ibnd.bound)) sys (** [merge_cstr_info] takes: - the intersection of bounds and @@ -90,13 +76,12 @@ let pp_system o sys= - [pos] and [neg] fields should be identical *) let merge_cstr_info i1 i2 = - let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1 - and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in - assert (Int.equal p1 p2 && Int.equal n1 n2) ; - match inter i1 i2 with - | None -> None (* Could directly raise a system contradiction exception *) - | Some bnd -> - Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) } + let {pos = p1; neg = n1; bound = i1; prf = prf1} = i1 + and {pos = p2; neg = n2; bound = i2; prf = prf2} = i2 in + assert (Int.equal p1 p2 && Int.equal n1 n2); + match inter i1 i2 with + | None -> None (* Could directly raise a system contradiction exception *) + | Some bnd -> Some {pos = p1; neg = n1; bound = bnd; prf = And (prf1, prf2)} (** [xadd_cstr vect cstr_info] loads an constraint into the system. The constraint is neither redundant nor contradictory. @@ -104,90 +89,96 @@ let merge_cstr_info i1 i2 = *) let xadd_cstr vect cstr_info sys = - try + try let info = System.find sys vect in - match merge_cstr_info cstr_info !info with - | None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf))) - | Some info' -> info := info' - with - | Not_found -> System.replace sys vect (ref cstr_info) + match merge_cstr_info cstr_info !info with + | None -> raise (SystemContradiction (And (cstr_info.prf, !info.prf))) + | Some info' -> info := info' + with Not_found -> System.replace sys vect (ref cstr_info) exception TimeOut let xadd_cstr vect cstr_info sys = - if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ; - if System.length sys < !max_nb_cstr - then xadd_cstr vect cstr_info sys - else raise TimeOut + if debug && Int.equal (System.length sys mod 1000) 0 then ( + print_string "*"; flush stdout ); + if System.length sys < !max_nb_cstr then xadd_cstr vect cstr_info sys + else raise TimeOut type cstr_ext = - | Contradiction (** The constraint is contradictory. + | Contradiction + (** The constraint is contradictory. Typically, a [SystemContradiction] exception will be raised. *) - | Redundant (** The constrain is redundant. + | Redundant + (** The constrain is redundant. Typically, the constraint will be dropped *) - | Cstr of vector * cstr_info (** Taken alone, the constraint is neither contradictory nor redundant. + | Cstr of vector * cstr_info + (** Taken alone, the constraint is neither contradictory nor redundant. Typically, it will be added to the constraint system. *) (** [normalise_cstr] : vector -> cstr_info -> cstr_ext *) let normalise_cstr vect cinfo = match norm_itv cinfo.bound with - | None -> Contradiction - | Some (l,r) -> - match Vect.choose vect with - | None -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction - | Some (_,n,_) -> Cstr(Vect.div n vect, - let divn x = x // n in - if Int.equal (sign_num n) 1 - then{cinfo with bound = (Option.map divn l , Option.map divn r) } - else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (Option.map divn r , Option.map divn l)}) - + | None -> Contradiction + | Some (l, r) -> ( + match Vect.choose vect with + | None -> if Itv.in_bound (l, r) (Int 0) then Redundant else Contradiction + | Some (_, n, _) -> + Cstr + ( Vect.div n vect + , let divn x = x // n in + if Int.equal (sign_num n) 1 then + {cinfo with bound = (Option.map divn l, Option.map divn r)} + else + { cinfo with + pos = cinfo.neg + ; neg = cinfo.pos + ; bound = (Option.map divn r, Option.map divn l) } ) ) (** For compatibility, there is an external representation of constraints *) - let count v = - Vect.fold (fun (n,p) _ vl -> + Vect.fold + (fun (n, p) _ vl -> let sg = sign_num vl in - assert (sg <> 0) ; - if Int.equal sg 1 then (n,p+1)else (n+1, p)) (0,0) v - - -let norm_cstr {coeffs = v ; op = o ; cst = c} idx = - let (n,p) = count v in - - normalise_cstr v {pos = p ; neg = n ; bound = - (match o with - | Eq -> Some c , Some c - | Ge -> Some c , None - | Gt -> raise Polynomial.Strict - ) ; - prf = Assum idx } - + assert (sg <> 0); + if Int.equal sg 1 then (n, p + 1) else (n + 1, p)) + (0, 0) v + +let norm_cstr {coeffs = v; op = o; cst = c} idx = + let n, p = count v in + normalise_cstr v + { pos = p + ; neg = n + ; bound = + ( match o with + | Eq -> (Some c, Some c) + | Ge -> (Some c, None) + | Gt -> raise Polynomial.Strict ) + ; prf = Assum idx } (** [load_system l] takes a list of constraints of type [cstr_compat] @return a system of constraints @raise SystemContradiction if a contradiction is found *) let load_system l = - let sys = System.create 1000 in - - let li = List.mapi (fun i e -> (e,i)) l in - - let vars = List.fold_left (fun vrs (cstr,i) -> - match norm_cstr cstr i with - | Contradiction -> raise (SystemContradiction (Assum i)) - | Redundant -> vrs - | Cstr(vect,info) -> - xadd_cstr vect info sys ; - Vect.fold (fun s v _ -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in - - {sys = sys ;vars = vars} + let li = List.mapi (fun i e -> (e, i)) l in + let vars = + List.fold_left + (fun vrs (cstr, i) -> + match norm_cstr cstr i with + | Contradiction -> raise (SystemContradiction (Assum i)) + | Redundant -> vrs + | Cstr (vect, info) -> + xadd_cstr vect info sys; + Vect.fold (fun s v _ -> ISet.add v s) vrs cstr.coeffs) + ISet.empty li + in + {sys; vars} let system_list sys = - let { sys = s ; vars = v } = sys in - System.fold (fun k bi l -> (k, !bi)::l) s [] - + let {sys = s; vars = v} = sys in + System.fold (fun k bi l -> (k, !bi) :: l) s [] (** [add (v1,c1) (v2,c2) ] precondition: (c1 <>/ Int 0 && c2 <>/ Int 0) @@ -196,15 +187,15 @@ let system_list sys = Note that the resulting vector is not normalised. *) -let add (v1,c1) (v2,c2) = - assert (c1 <>/ Int 0 && c2 <>/ Int 0) ; - let res = mul_add (Int 1 // c1) v1 (Int 1 // c2) v2 in - (res, count res) +let add (v1, c1) (v2, c2) = + assert (c1 <>/ Int 0 && c2 <>/ Int 0); + let res = mul_add (Int 1 // c1) v1 (Int 1 // c2) v2 in + (res, count res) -let add (v1,c1) (v2,c2) = - let res = add (v1,c1) (v2,c2) in - (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*) - res +let add (v1, c1) (v2, c2) = + let res = add (v1, c1) (v2, c2) in + (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*) + res (** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *) @@ -215,54 +206,59 @@ let add (v1,c1) (v2,c2) = @param m contains constraints which do not mention [x] *) -let split x (vect: vector) info (l,m,r) = - match get x vect with - | Int 0 -> (* The constraint does not mention [x], store it in m *) - (l,(vect,info)::m,r) - | vl -> (* otherwise *) - - let cons_bound lst bd = - match bd with - | None -> lst - | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in - - let lb,rb = info.bound in - if Int.equal (sign_num vl) 1 - then (cons_bound l lb,m,cons_bound r rb) - else (* sign_num vl = -1 *) - (cons_bound l rb,m,cons_bound r lb) - +let split x (vect : vector) info (l, m, r) = + match get x vect with + | Int 0 -> + (* The constraint does not mention [x], store it in m *) + (l, (vect, info) :: m, r) + | vl -> + (* otherwise *) + let cons_bound lst bd = + match bd with + | None -> lst + | Some bnd -> (vl, vect, {info with bound = (Some bnd, None)}) :: lst + in + let lb, rb = info.bound in + if Int.equal (sign_num vl) 1 then (cons_bound l lb, m, cons_bound r rb) + else (* sign_num vl = -1 *) + (cons_bound l rb, m, cons_bound r lb) (** [project vr sys] projects system [sys] over the set of variables [ISet.remove vr sys.vars ]. This is a one step Fourier elimination. *) let project vr sys = - - let (l,m,r) = System.fold (fun vect rf l_m_r -> split vr vect !rf l_m_r) sys.sys ([],[],[]) in - + let l, m, r = + System.fold + (fun vect rf l_m_r -> split vr vect !rf l_m_r) + sys.sys ([], [], []) + in let new_sys = System.create (System.length sys.sys) in - - (* Constraints in [m] belong to the projection - for those [vr] is already projected out *) - List.iter (fun (vect,info) -> System.replace new_sys vect (ref info) ) m ; - - let elim (v1,vect1,info1) (v2,vect2,info2) = - let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1 - and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in - - let bnd1 = Option.get (fst bound1) - and bnd2 = Option.get (fst bound2) in - let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in - let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2) in - (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in - - List.iter(fun l_elem -> List.iter (fun r_elem -> - let (vect,info) = elim l_elem r_elem in + (* Constraints in [m] belong to the projection - for those [vr] is already projected out *) + List.iter (fun (vect, info) -> System.replace new_sys vect (ref info)) m; + let elim (v1, vect1, info1) (v2, vect2, info2) = + let {neg = n1; pos = p1; bound = bound1; prf = prf1} = info1 + and {neg = n2; pos = p2; bound = bound2; prf = prf2} = info2 in + let bnd1 = Option.get (fst bound1) and bnd2 = Option.get (fst bound2) in + let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in + let vres, (n, p) = add (vect1, v1) (vect2, minus_num v2) in + ( vres + , { neg = n + ; pos = p + ; bound = (Some bound, None) + ; prf = Elim (vr, info1.prf, info2.prf) } ) + in + List.iter + (fun l_elem -> + List.iter + (fun r_elem -> + let vect, info = elim l_elem r_elem in match normalise_cstr vect info with - | Redundant -> () - | Contradiction -> raise (SystemContradiction info.prf) - | Cstr(vect,info) -> xadd_cstr vect info new_sys) r ) l; - {sys = new_sys ; vars = ISet.remove vr sys.vars} - + | Redundant -> () + | Contradiction -> raise (SystemContradiction info.prf) + | Cstr (vect, info) -> xadd_cstr vect info new_sys) + r) + l; + {sys = new_sys; vars = ISet.remove vr sys.vars} (** [project_using_eq] performs elimination by pivoting using an equation. This is the counter_part of the [elim] sub-function of [!project]. @@ -273,103 +269,92 @@ let project vr sys = @param prf is the proof of the equation *) -let project_using_eq vr c vect bound prf (vect',info') = - match get vr vect' with - | Int 0 -> (vect',info') - | c2 -> - let c1 = if c2 >=/ Int 0 then minus_num c else c in - - let c2 = abs_num c2 in - - let (vres,(n,p)) = add (vect,c1) (vect', c2) in - - let cst = bound // c1 in - - let bndres = - let f x = cst +/ x // c2 in - let (l,r) = info'.bound in - (Option.map f l , Option.map f r) in - - (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) - +let project_using_eq vr c vect bound prf (vect', info') = + match get vr vect' with + | Int 0 -> (vect', info') + | c2 -> + let c1 = if c2 >=/ Int 0 then minus_num c else c in + let c2 = abs_num c2 in + let vres, (n, p) = add (vect, c1) (vect', c2) in + let cst = bound // c1 in + let bndres = + let f x = cst +/ (x // c2) in + let l, r = info'.bound in + (Option.map f l, Option.map f r) + in + (vres, {neg = n; pos = p; bound = bndres; prf = Elim (vr, prf, info'.prf)}) -let elim_var_using_eq vr vect cst prf sys = +let elim_var_using_eq vr vect cst prf sys = let c = get vr vect in - - let elim_var = project_using_eq vr c vect cst prf in - - let new_sys = System.create (System.length sys.sys) in - - System.iter(fun vect iref -> - let (vect',info') = elim_var (vect,!iref) in - match normalise_cstr vect' info' with - | Redundant -> () - | Contradiction -> raise (SystemContradiction info'.prf) - | Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ; - - {sys = new_sys ; vars = ISet.remove vr sys.vars} - + let elim_var = project_using_eq vr c vect cst prf in + let new_sys = System.create (System.length sys.sys) in + System.iter + (fun vect iref -> + let vect', info' = elim_var (vect, !iref) in + match normalise_cstr vect' info' with + | Redundant -> () + | Contradiction -> raise (SystemContradiction info'.prf) + | Cstr (vect, info') -> xadd_cstr vect info' new_sys) + sys.sys; + {sys = new_sys; vars = ISet.remove vr sys.vars} (** [size sys] computes the number of entries in the system of constraints *) -let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0 +let size sys = System.fold (fun v iref s -> s + !iref.neg + !iref.pos) sys 0 -module IMap = CMap.Make(Int) +module IMap = CMap.Make (Int) (** [eval_vect map vect] evaluates vector [vect] using the values of [map]. If [map] binds all the variables of [vect], we get [eval_vect map [(x1,v1);...;(xn,vn)] = (IMap.find x1 map * v1) + ... + (IMap.find xn map) * vn , []] The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *) -let eval_vect map vect = - Vect.fold (fun (sum,rst) v vl -> +let eval_vect map vect = + Vect.fold + (fun (sum, rst) v vl -> try let val_v = IMap.find v map in (sum +/ (val_v */ vl), rst) - with - Not_found -> (sum, Vect.set v vl rst)) (Int 0,Vect.null) vect - - + with Not_found -> (sum, Vect.set v vl rst)) + (Int 0, Vect.null) vect (** [restrict_bound n sum itv] returns the interval of [x] given that (fst itv) <= x * n + sum <= (snd itv) *) -let restrict_bound n sum (itv:interval) = - let f x = (x -/ sum) // n in - let l,r = itv in - match sign_num n with - | 0 -> if in_bound itv sum - then (None,None) (* redundant *) - else failwith "SystemContradiction" - | 1 -> Option.map f l , Option.map f r - | _ -> Option.map f r , Option.map f l - +let restrict_bound n sum (itv : interval) = + let f x = (x -/ sum) // n in + let l, r = itv in + match sign_num n with + | 0 -> + if in_bound itv sum then (None, None) (* redundant *) + else failwith "SystemContradiction" + | 1 -> (Option.map f l, Option.map f r) + | _ -> (Option.map f r, Option.map f l) (** [bound_of_variable map v sys] computes the interval of [v] in [sys] given a mapping [map] binding all the other variables *) let bound_of_variable map v sys = - System.fold (fun vect iref bnd -> - let sum,rst = eval_vect map vect in - let vl = Vect.get v rst in - match inter bnd (restrict_bound vl sum (!iref).bound) with + System.fold + (fun vect iref bnd -> + let sum, rst = eval_vect map vect in + let vl = Vect.get v rst in + match inter bnd (restrict_bound vl sum !iref.bound) with | None -> - Printf.fprintf stdout "bound_of_variable: eval_vecr %a = %s,%a\n" - Vect.pp vect (Num.string_of_num sum) Vect.pp rst ; - Printf.fprintf stdout "current interval: %a\n" Itv.pp (!iref).bound; - failwith "bound_of_variable: impossible" - | Some itv -> itv) sys (None,None) - + Printf.fprintf stdout "bound_of_variable: eval_vecr %a = %s,%a\n" + Vect.pp vect (Num.string_of_num sum) Vect.pp rst; + Printf.fprintf stdout "current interval: %a\n" Itv.pp !iref.bound; + failwith "bound_of_variable: impossible" + | Some itv -> itv) + sys (None, None) (** [pick_small_value bnd] picks a value being closed to zero within the interval *) let pick_small_value bnd = match bnd with - | None , None -> Int 0 - | None , Some i -> if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i - | Some i,None -> if i <=/ (Int 0) then Int 0 else ceiling_num i - | Some i,Some j -> - if i <=/ Int 0 && Int 0 <=/ j - then Int 0 - else if ceiling_num i <=/ floor_num j - then ceiling_num i (* why not *) else i - + | None, None -> Int 0 + | None, Some i -> if Int 0 <=/ floor_num i then Int 0 else floor_num i + | Some i, None -> if i <=/ Int 0 then Int 0 else ceiling_num i + | Some i, Some j -> + if i <=/ Int 0 && Int 0 <=/ j then Int 0 + else if ceiling_num i <=/ floor_num j then ceiling_num i (* why not *) + else i (** [solution s1 sys_l = Some(sn,\[(vn-1,sn-1);...; (v1,s1)\]\@sys_l)] then [sn] is a system which contains only [black_v] -- if it existed in [s1] @@ -378,262 +363,242 @@ let pick_small_value bnd = *) let solve_sys black_v choose_eq choose_variable sys sys_l = - let rec solve_sys sys sys_l = - if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys); - if debug then Printf.printf "solve_sys :\n %a" pp_system sys.sys ; - + if debug then + Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys); + if debug then Printf.printf "solve_sys :\n %a" pp_system sys.sys; let eqs = choose_eq sys in + try + let v, vect, cst, ln = + fst (List.find (fun ((v, _, _, _), _) -> v <> black_v) eqs) + in + if debug then ( + Printf.printf "\nE %a = %s variable %i\n" Vect.pp vect + (string_of_num cst) v; + flush stdout ); + let sys' = elim_var_using_eq v vect cst ln sys in + solve_sys sys' ((v, sys) :: sys_l) + with Not_found -> ( + let vars = choose_variable sys in try - let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in - if debug then - (Printf.printf "\nE %a = %s variable %i\n" Vect.pp vect (string_of_num cst) v ; - flush stdout); - let sys' = elim_var_using_eq v vect cst ln sys in - solve_sys sys' ((v,sys)::sys_l) - with Not_found -> - let vars = choose_variable sys in - try - let (v,est) = (List.find (fun (v,_) -> v <> black_v) vars) in - if debug then (Printf.printf "\nV : %i estimate %f\n" v est ; flush stdout) ; - let sys' = project v sys in - solve_sys sys' ((v,sys)::sys_l) - with Not_found -> (* we are done *) Inl (sys,sys_l) in - solve_sys sys sys_l - - - - -let solve black_v choose_eq choose_variable cstrs = - + let v, est = List.find (fun (v, _) -> v <> black_v) vars in + if debug then ( + Printf.printf "\nV : %i estimate %f\n" v est; + flush stdout ); + let sys' = project v sys in + solve_sys sys' ((v, sys) :: sys_l) + with Not_found -> (* we are done *) Inl (sys, sys_l) ) + in + solve_sys sys sys_l + +let solve black_v choose_eq choose_variable cstrs = try let sys = load_system cstrs in - if debug then Printf.printf "solve :\n %a" pp_system sys.sys ; - solve_sys black_v choose_eq choose_variable sys [] + if debug then Printf.printf "solve :\n %a" pp_system sys.sys; + solve_sys black_v choose_eq choose_variable sys [] with SystemContradiction prf -> Inr prf - (** The purpose of module [EstimateElimVar] is to try to estimate the cost of eliminating a variable. The output is an ordered list of (variable,cost). *) -module EstimateElimVar = -struct +module EstimateElimVar = struct type sys_list = (vector * cstr_info) list - let abstract_partition (v:int) (l: sys_list) = - - let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) = + let abstract_partition (v : int) (l : sys_list) = + let rec xpart (l : sys_list) (ltl : sys_list) (n : int list) (z : int) + (p : int list) = match l with - | [] -> (ltl, n,z,p) - | (l1,info) ::rl -> - match Vect.choose l1 with - | None -> xpart rl ((Vect.null,info)::ltl) n (info.neg+info.pos+z) p - | Some(vr, vl, rl1) -> - if Int.equal v vr - then - let cons_bound lst bd = - match bd with - | None -> lst - | Some bnd -> info.neg+info.pos::lst in - - let lb,rb = info.bound in - if Int.equal (sign_num vl) 1 - then xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb) - else xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb) - else - (* the variable is greater *) - xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p - + | [] -> (ltl, n, z, p) + | (l1, info) :: rl -> ( + match Vect.choose l1 with + | None -> + xpart rl ((Vect.null, info) :: ltl) n (info.neg + info.pos + z) p + | Some (vr, vl, rl1) -> + if Int.equal v vr then + let cons_bound lst bd = + match bd with + | None -> lst + | Some bnd -> (info.neg + info.pos) :: lst + in + let lb, rb = info.bound in + if Int.equal (sign_num vl) 1 then + xpart rl ((rl1, info) :: ltl) (cons_bound n lb) z + (cons_bound p rb) + else + xpart rl ((rl1, info) :: ltl) (cons_bound n rb) z + (cons_bound p lb) + else + (* the variable is greater *) + xpart rl ((l1, info) :: ltl) n (info.neg + info.pos + z) p ) in - let (sys',n,z,p) = xpart l [] [] 0 [] in - + let sys', n, z, p = xpart l [] [] 0 [] in let ln = float_of_int (List.length n) in - let sn = float_of_int (List.fold_left (+) 0 n) in + let sn = float_of_int (List.fold_left ( + ) 0 n) in let lp = float_of_int (List.length p) in - let sp = float_of_int (List.fold_left (+) 0 p) in - (sys', float_of_int z +. lp *. sn +. ln *. sp -. lp*.ln) - - - let choose_variable sys = - let {sys = s ; vars = v} = sys in + let sp = float_of_int (List.fold_left ( + ) 0 p) in + (sys', float_of_int z +. (lp *. sn) +. (ln *. sp) -. (lp *. ln)) + let choose_variable sys = + let {sys = s; vars = v} = sys in let sl = system_list sys in - - let evals = fst - (ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s in - ((v,vl)::eval, ts)) v ([],sl)) in - - List.sort (fun x y -> compare_float (snd x) (snd y) ) evals - - + let evals = + fst + (ISet.fold + (fun v (eval, s) -> + let ts, vl = abstract_partition v s in + ((v, vl) :: eval, ts)) + v ([], sl)) + in + List.sort (fun x y -> compare_float (snd x) (snd y)) evals end + open EstimateElimVar (** The module [EstimateElimEq] is similar to [EstimateElimVar] but it orders equations. *) -module EstimateElimEq = -struct - - let itv_point bnd = - match bnd with - |(Some a, Some b) -> a =/ b - | _ -> false +module EstimateElimEq = struct + let itv_point bnd = match bnd with Some a, Some b -> a =/ b | _ -> false let rec unroll_until v l = match Vect.choose l with - | None -> (false,Vect.null) - | Some(i,_,rl) -> if Int.equal i v - then (true,rl) - else if i < v then unroll_until v rl else (false,l) - - + | None -> (false, Vect.null) + | Some (i, _, rl) -> + if Int.equal i v then (true, rl) + else if i < v then unroll_until v rl + else (false, l) let rec choose_simple_equation eqs = match eqs with - | [] -> None - | (vect,a,prf,ln)::eqs -> - match Vect.choose vect with - | Some(i,v,rst) -> if Vect.is_null rst - then Some (i,vect,a,prf,ln) - else choose_simple_equation eqs - | _ -> choose_simple_equation eqs - - - let choose_primal_equation eqs (sys_l: (Vect.t *cstr_info) list) = + | [] -> None + | (vect, a, prf, ln) :: eqs -> ( + match Vect.choose vect with + | Some (i, v, rst) -> + if Vect.is_null rst then Some (i, vect, a, prf, ln) + else choose_simple_equation eqs + | _ -> choose_simple_equation eqs ) + let choose_primal_equation eqs (sys_l : (Vect.t * cstr_info) list) = (* Counts the number of equations referring to variable [v] -- It looks like nb_cst is dead... *) let is_primal_equation_var v = - List.fold_left (fun nb_eq (vect,info) -> - if fst (unroll_until v vect) - then if itv_point info.bound then nb_eq + 1 else nb_eq - else nb_eq) 0 sys_l in - + List.fold_left + (fun nb_eq (vect, info) -> + if fst (unroll_until v vect) then + if itv_point info.bound then nb_eq + 1 else nb_eq + else nb_eq) + 0 sys_l + in let rec find_var vect = match Vect.choose vect with - | None -> None - | Some(i,_,vect) -> - let nb_eq = is_primal_equation_var i in - if Int.equal nb_eq 2 - then Some i else find_var vect in - + | None -> None + | Some (i, _, vect) -> + let nb_eq = is_primal_equation_var i in + if Int.equal nb_eq 2 then Some i else find_var vect + in let rec find_eq_var eqs = match eqs with - | [] -> None - | (vect,a,prf,ln)::l -> - match find_var vect with - | None -> find_eq_var l - | Some r -> Some (r,vect,a,prf,ln) + | [] -> None + | (vect, a, prf, ln) :: l -> ( + match find_var vect with + | None -> find_eq_var l + | Some r -> Some (r, vect, a, prf, ln) ) in - match choose_simple_equation eqs with - | None -> find_eq_var eqs - | Some res -> Some res - - - - let choose_equality_var sys = + match choose_simple_equation eqs with + | None -> find_eq_var eqs + | Some res -> Some res + let choose_equality_var sys = let sys_l = system_list sys in - - let equalities = List.fold_left - (fun l (vect,info) -> - match info.bound with - | Some a , Some b -> - if a =/ b then (* This an equation *) - (vect,a,info.prf,info.neg+info.pos)::l else l - | _ -> l - ) [] sys_l in - + let equalities = + List.fold_left + (fun l (vect, info) -> + match info.bound with + | Some a, Some b -> + if a =/ b then + (* This an equation *) + (vect, a, info.prf, info.neg + info.pos) :: l + else l + | _ -> l) + [] sys_l + in let rec estimate_cost v ct sysl acc tlsys = match sysl with - | [] -> (acc,tlsys) - | (l,info)::rsys -> - let ln = info.pos + info.neg in - let (b,l) = unroll_until v l in - match b with - | true -> - if itv_point info.bound - then estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *) - else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys) (* should be more ? *) - | false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in - - match choose_primal_equation equalities sys_l with - | None -> - let cost_eq eq const prf ln acc_costs = - - let rec cost_eq eqr sysl costs = - match Vect.choose eqr with - | None -> costs - | Some(v,_,eqr) -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in - cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in - cost_eq eq sys_l acc_costs in - - let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in - - (* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *) - - List.sort (fun x y -> Int.compare (snd x) (snd y) ) all_costs - | Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0] - - + | [] -> (acc, tlsys) + | (l, info) :: rsys -> ( + let ln = info.pos + info.neg in + let b, l = unroll_until v l in + match b with + | true -> + if itv_point info.bound then + estimate_cost v ct rsys (acc + ln) ((l, info) :: tlsys) + (* this is free *) + else estimate_cost v ct rsys (acc + ln + ct) ((l, info) :: tlsys) + (* should be more ? *) + | false -> estimate_cost v ct rsys (acc + ln) ((l, info) :: tlsys) ) + in + match choose_primal_equation equalities sys_l with + | None -> + let cost_eq eq const prf ln acc_costs = + let rec cost_eq eqr sysl costs = + match Vect.choose eqr with + | None -> costs + | Some (v, _, eqr) -> + let cst, tlsys = estimate_cost v (ln - 1) sysl 0 [] in + cost_eq eqr tlsys (((v, eq, const, prf), cst) :: costs) + in + cost_eq eq sys_l acc_costs + in + let all_costs = + List.fold_left + (fun all_costs (vect, const, prf, ln) -> + cost_eq vect const prf ln all_costs) + [] equalities + in + (* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *) + List.sort (fun x y -> Int.compare (snd x) (snd y)) all_costs + | Some (v, vect, const, prf, _) -> [((v, vect, const, prf), 0)] end -open EstimateElimEq -module Fourier = -struct +open EstimateElimEq +module Fourier = struct let optimise vect l = (* We add a dummy (fresh) variable for vector *) - let fresh = - List.fold_left (fun fr c -> max fr (Vect.fresh c.coeffs)) 0 l in - let cstr = { - coeffs = Vect.set fresh (Int (-1)) vect ; - op = Eq ; - cst = (Int 0)} in - match solve fresh choose_equality_var choose_variable (cstr::l) with - | Inr prf -> None (* This is an unsatisfiability proof *) - | Inl (s,_) -> - try - Some (bound_of_variable IMap.empty fresh s.sys) - with x when CErrors.noncritical x -> - Printf.printf "optimise Exception : %s" (Printexc.to_string x); - None - + let fresh = List.fold_left (fun fr c -> max fr (Vect.fresh c.coeffs)) 0 l in + let cstr = + {coeffs = Vect.set fresh (Int (-1)) vect; op = Eq; cst = Int 0} + in + match solve fresh choose_equality_var choose_variable (cstr :: l) with + | Inr prf -> None (* This is an unsatisfiability proof *) + | Inl (s, _) -> ( + try Some (bound_of_variable IMap.empty fresh s.sys) + with x when CErrors.noncritical x -> + Printf.printf "optimise Exception : %s" (Printexc.to_string x); + None ) let find_point cstrs = - match solve max_int choose_equality_var choose_variable cstrs with - | Inr prf -> Inr prf - | Inl (_,l) -> - - let rec rebuild_solution l map = - match l with - | [] -> map - | (v,e)::l -> - let itv = bound_of_variable map v e.sys in - let map = IMap.add v (pick_small_value itv) map in - rebuild_solution l map - in - - let map = rebuild_solution l IMap.empty in - let vect = IMap.fold (fun v i vect -> Vect.set v i vect) map Vect.null in - if debug then Printf.printf "SOLUTION %a" Vect.pp vect ; - let res = Inl vect in - res - - + | Inr prf -> Inr prf + | Inl (_, l) -> + let rec rebuild_solution l map = + match l with + | [] -> map + | (v, e) :: l -> + let itv = bound_of_variable map v e.sys in + let map = IMap.add v (pick_small_value itv) map in + rebuild_solution l map + in + let map = rebuild_solution l IMap.empty in + let vect = IMap.fold (fun v i vect -> Vect.set v i vect) map Vect.null in + if debug then Printf.printf "SOLUTION %a" Vect.pp vect; + let res = Inl vect in + res end - -module Proof = -struct - - - - -(** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction. +module Proof = struct + (** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction. The proofs constructed by Fourier elimination are more like execution traces: - certain facts are recorded but are useless - certain inferences are implicit. @@ -641,124 +606,123 @@ struct *) let add x y = fst (add x y) - let forall_pairs f l1 l2 = - List.fold_left (fun acc e1 -> - List.fold_left (fun acc e2 -> - match f e1 e2 with - | None -> acc - | Some v -> v::acc) acc l2) [] l1 - - - let add_op x y = - match x , y with - | Eq , Eq -> Eq - | _ -> Ge - - - let pivot v (p1,c1) (p2,c2) = - let {coeffs = v1 ; op = op1 ; cst = n1} = c1 - and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in - - match Vect.get v v1 , Vect.get v v2 with - | Int 0 , _ | _ , Int 0 -> None - | a , b -> - if Int.equal ((sign_num a) * (sign_num b)) (-1) - then - Some (add (p1,abs_num a) (p2,abs_num b) , - {coeffs = add (v1,abs_num a) (v2,abs_num b) ; - op = add_op op1 op2 ; - cst = n1 // (abs_num a) +/ n2 // (abs_num b) }) - else if op1 == Eq - then Some (add (p1,minus_num (a // b)) (p2,Int 1), - {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ; - op = add_op op1 op2; - cst = n1 // (minus_num (a// b)) +/ n2 // (Int 1)}) - else if op2 == Eq - then - Some (add (p2,minus_num (b // a)) (p1,Int 1), - {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ; - op = add_op op1 op2; - cst = n2 // (minus_num (b// a)) +/ n1 // (Int 1)}) - else None (* op2 could be Eq ... this might happen *) - + List.fold_left + (fun acc e1 -> + List.fold_left + (fun acc e2 -> match f e1 e2 with None -> acc | Some v -> v :: acc) + acc l2) + [] l1 + + let add_op x y = match (x, y) with Eq, Eq -> Eq | _ -> Ge + + let pivot v (p1, c1) (p2, c2) = + let {coeffs = v1; op = op1; cst = n1} = c1 + and {coeffs = v2; op = op2; cst = n2} = c2 in + match (Vect.get v v1, Vect.get v v2) with + | Int 0, _ | _, Int 0 -> None + | a, b -> + if Int.equal (sign_num a * sign_num b) (-1) then + Some + ( add (p1, abs_num a) (p2, abs_num b) + , { coeffs = add (v1, abs_num a) (v2, abs_num b) + ; op = add_op op1 op2 + ; cst = (n1 // abs_num a) +/ (n2 // abs_num b) } ) + else if op1 == Eq then + Some + ( add (p1, minus_num (a // b)) (p2, Int 1) + , { coeffs = add (v1, minus_num (a // b)) (v2, Int 1) + ; op = add_op op1 op2 + ; cst = (n1 // minus_num (a // b)) +/ (n2 // Int 1) } ) + else if op2 == Eq then + Some + ( add (p2, minus_num (b // a)) (p1, Int 1) + , { coeffs = add (v2, minus_num (b // a)) (v1, Int 1) + ; op = add_op op1 op2 + ; cst = (n2 // minus_num (b // a)) +/ (n1 // Int 1) } ) + else None + + (* op2 could be Eq ... this might happen *) let normalise_proofs l = - List.fold_left (fun acc (prf,cstr) -> - match acc with + List.fold_left + (fun acc (prf, cstr) -> + match acc with | Inr _ -> acc (* I already found a contradiction *) - | Inl acc -> - match norm_cstr cstr 0 with - | Redundant -> Inl acc - | Contradiction -> Inr (prf,cstr) - | Cstr(v,info) -> Inl ((prf,cstr,v,info)::acc)) (Inl []) l - + | Inl acc -> ( + match norm_cstr cstr 0 with + | Redundant -> Inl acc + | Contradiction -> Inr (prf, cstr) + | Cstr (v, info) -> Inl ((prf, cstr, v, info) :: acc) )) + (Inl []) l type oproof = (vector * cstr * num) option - let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) = - let (l,r) = info.bound in - + let merge_proof (oleft : oproof) (prf, cstr, v, info) (oright : oproof) = + let l, r = info.bound in let keep p ob bd = - match ob , bd with - | None , None -> None - | None , Some b -> Some(prf,cstr,b) - | Some _ , None -> ob - | Some(prfl,cstrl,bl) , Some b -> if p bl b then Some(prf,cstr, b) else ob in - - let oleft = keep (<=/) oleft l in - let oright = keep (>=/) oright r in - (* Now, there might be a contradiction *) - match oleft , oright with - | None , _ | _ , None -> Inl (oleft,oright) - | Some(prfl,cstrl,l) , Some(prfr,cstrr,r) -> - if l <=/ r - then Inl (oleft,oright) - else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*) - match Vect.choose cstrr.coeffs with - | None -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) - | Some(v,_,_) -> - match pivot v (prfl,cstrl) (prfr,cstrr) with - | None -> failwith "merge_proof : pivot is not possible" - | Some x -> Inr x - -let mk_proof hyps prf = - (* I am keeping list - I might have a proof for the left bound and a proof for the right bound. + match (ob, bd) with + | None, None -> None + | None, Some b -> Some (prf, cstr, b) + | Some _, None -> ob + | Some (prfl, cstrl, bl), Some b -> + if p bl b then Some (prf, cstr, b) else ob + in + let oleft = keep ( <=/ ) oleft l in + let oright = keep ( >=/ ) oright r in + (* Now, there might be a contradiction *) + match (oleft, oright) with + | None, _ | _, None -> Inl (oleft, oright) + | Some (prfl, cstrl, l), Some (prfr, cstrr, r) -> ( + if l <=/ r then Inl (oleft, oright) + else + (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*) + match Vect.choose cstrr.coeffs with + | None -> + Inr (add (prfl, Int 1) (prfr, Int 1), cstrr) (* this is wrong *) + | Some (v, _, _) -> ( + match pivot v (prfl, cstrl) (prfr, cstrr) with + | None -> failwith "merge_proof : pivot is not possible" + | Some x -> Inr x ) ) + + let mk_proof hyps prf = + (* I am keeping list - I might have a proof for the left bound and a proof for the right bound. If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2. For each proof list, all the vectors should be of the form a.v for different constants a. *) - - let rec mk_proof prf = - match prf with - | Assum i -> [ (Vect.set i (Int 1) Vect.null , List.nth hyps i) ] - - | Elim(v,prf1,prf2) -> - let prfsl = mk_proof prf1 - and prfsr = mk_proof prf2 in - (* I take only the pairs for which the elimination is meaningful *) - forall_pairs (pivot v) prfsl prfsr - | And(prf1,prf2) -> - let prfsl1 = mk_proof prf1 - and prfsl2 = mk_proof prf2 in - (* detect trivial redundancies and contradictions *) - match normalise_proofs (prfsl1@prfsl2) with - | Inr x -> [x] (* This is a contradiction - this should be the end of the proof *) - | Inl l -> (* All the vectors are the same *) - let prfs = - List.fold_left (fun acc e -> - match acc with - | Inr _ -> acc (* I have a contradiction *) - | Inl (oleft,oright) -> merge_proof oleft e oright) (Inl(None,None)) l in - match prfs with - | Inr x -> [x] - | Inl (oleft,oright) -> - match oleft , oright with - | None , None -> [] - | None , Some(prf,cstr,_) | Some(prf,cstr,_) , None -> [prf,cstr] - | Some(prf1,cstr1,_) , Some(prf2,cstr2,_) -> [prf1,cstr1;prf2,cstr2] in - + let rec mk_proof prf = + match prf with + | Assum i -> [(Vect.set i (Int 1) Vect.null, List.nth hyps i)] + | Elim (v, prf1, prf2) -> + let prfsl = mk_proof prf1 and prfsr = mk_proof prf2 in + (* I take only the pairs for which the elimination is meaningful *) + forall_pairs (pivot v) prfsl prfsr + | And (prf1, prf2) -> ( + let prfsl1 = mk_proof prf1 and prfsl2 = mk_proof prf2 in + (* detect trivial redundancies and contradictions *) + match normalise_proofs (prfsl1 @ prfsl2) with + | Inr x -> [x] + (* This is a contradiction - this should be the end of the proof *) + | Inl l -> ( + (* All the vectors are the same *) + let prfs = + List.fold_left + (fun acc e -> + match acc with + | Inr _ -> acc (* I have a contradiction *) + | Inl (oleft, oright) -> merge_proof oleft e oright) + (Inl (None, None)) + l + in + match prfs with + | Inr x -> [x] + | Inl (oleft, oright) -> ( + match (oleft, oright) with + | None, None -> [] + | None, Some (prf, cstr, _) | Some (prf, cstr, _), None -> + [(prf, cstr)] + | Some (prf1, cstr1, _), Some (prf2, cstr2, _) -> + [(prf1, cstr1); (prf2, cstr2)] ) ) ) + in mk_proof prf - - end - diff --git a/plugins/micromega/mfourier.mli b/plugins/micromega/mfourier.mli index 16cb49c85e..8743f0ccc4 100644 --- a/plugins/micromega/mfourier.mli +++ b/plugins/micromega/mfourier.mli @@ -13,26 +13,17 @@ module IMap : CSig.MapS with type key = int type proof module Fourier : sig - - - val find_point : Polynomial.cstr list -> - (Vect.t, proof) Util.union - - val optimise : Vect.t -> - Polynomial.cstr list -> - Itv.interval option - + val find_point : Polynomial.cstr list -> (Vect.t, proof) Util.union + val optimise : Vect.t -> Polynomial.cstr list -> Itv.interval option end val pp_proof : out_channel -> proof -> unit module Proof : sig - - val mk_proof : Polynomial.cstr list -> - proof -> (Vect.t * Polynomial.cstr) list + val mk_proof : + Polynomial.cstr list -> proof -> (Vect.t * Polynomial.cstr) list val add_op : Polynomial.op -> Polynomial.op -> Polynomial.op - end exception TimeOut diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index f508b3dc56..d17a0aabb7 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -281,6 +281,20 @@ module Coq_Pos = let compare = compare_cont Eq + (** val max : positive -> positive -> positive **) + + let max p p' = + match compare p p' with + | Gt -> p + | _ -> p' + + (** val leb : positive -> positive -> bool **) + + let leb x y = + match compare x y with + | Gt -> false + | _ -> true + (** val gcdn : nat -> positive -> positive -> positive **) let rec gcdn n0 a b = @@ -1760,13 +1774,6 @@ let simpl_cone cO cI ctimes ceqb e = match e with | _ -> PsatzAdd (t1, t2))) | _ -> e -module PositiveSet = - struct - type tree = - | Leaf - | Node of tree * bool * tree - end - type q = { qnum : z; qden : positive } (** val qeq_bool : q -> q -> bool **) @@ -1980,6 +1987,7 @@ type zArithProof = | RatProof of zWitness * zArithProof | CutProof of zWitness * zArithProof | EnumProof of zWitness * zWitness * zArithProof list +| ExProof of positive * zArithProof (** val zgcdM : z -> z -> z **) @@ -2051,116 +2059,6 @@ let valid_cut_sign = function | NonStrict -> true | _ -> false -module Vars = - struct - type elt = positive - - type tree = PositiveSet.tree = - | Leaf - | Node of tree * bool * tree - - type t = tree - - (** val empty : t **) - - let empty = - Leaf - - (** val add : elt -> t -> t **) - - let rec add i = function - | Leaf -> - (match i with - | XI i0 -> Node (Leaf, false, (add i0 Leaf)) - | XO i0 -> Node ((add i0 Leaf), false, Leaf) - | XH -> Node (Leaf, true, Leaf)) - | Node (l, o, r) -> - (match i with - | XI i0 -> Node (l, o, (add i0 r)) - | XO i0 -> Node ((add i0 l), o, r) - | XH -> Node (l, true, r)) - - (** val singleton : elt -> t **) - - let singleton i = - add i empty - - (** val union : t -> t -> t **) - - let rec union m m' = - match m with - | Leaf -> m' - | Node (l, o, r) -> - (match m' with - | Leaf -> m - | Node (l', o', r') -> - Node ((union l l'), (if o then true else o'), (union r r'))) - - (** val rev_append : elt -> elt -> elt **) - - let rec rev_append y x = - match y with - | XI y0 -> rev_append y0 (XI x) - | XO y0 -> rev_append y0 (XO x) - | XH -> x - - (** val rev : elt -> elt **) - - let rev x = - rev_append x XH - - (** val xfold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> elt -> 'a1 **) - - let rec xfold f m v i = - match m with - | Leaf -> v - | Node (l, b, r) -> - if b - then xfold f r (f (rev i) (xfold f l v (XO i))) (XI i) - else xfold f r (xfold f l v (XO i)) (XI i) - - (** val fold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> 'a1 **) - - let fold f m i = - xfold f m i XH - end - -(** val vars_of_pexpr : z pExpr -> Vars.t **) - -let rec vars_of_pexpr = function -| PEc _ -> Vars.empty -| PEX x -> Vars.singleton x -| PEadd (e1, e2) -> - let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 -| PEsub (e1, e2) -> - let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 -| PEmul (e1, e2) -> - let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 -| PEopp c -> vars_of_pexpr c -| PEpow (e0, _) -> vars_of_pexpr e0 - -(** val vars_of_formula : z formula -> Vars.t **) - -let vars_of_formula f = - let { flhs = l; fop = _; frhs = r } = f in - let v1 = vars_of_pexpr l in let v2 = vars_of_pexpr r in Vars.union v1 v2 - -(** val vars_of_bformula : (z formula, 'a1, 'a2, 'a3) gFormula -> Vars.t **) - -let rec vars_of_bformula = function -| A (a, _) -> vars_of_formula a -| Cj (f1, f2) -> - let v1 = vars_of_bformula f1 in - let v2 = vars_of_bformula f2 in Vars.union v1 v2 -| D (f1, f2) -> - let v1 = vars_of_bformula f1 in - let v2 = vars_of_bformula f2 in Vars.union v1 v2 -| N f0 -> vars_of_bformula f0 -| I (f1, _, f2) -> - let v1 = vars_of_bformula f1 in - let v2 = vars_of_bformula f2 in Vars.union v1 v2 -| _ -> Vars.empty - (** val bound_var : positive -> z formula **) let bound_var v = @@ -2171,24 +2069,18 @@ let bound_var v = let mk_eq_pos x y t0 = { flhs = (PEX x); fop = OpEq; frhs = (PEsub ((PEX y), (PEX t0))) } -(** val bound_vars : - (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z - formula, 'a1, 'a2, 'a3) gFormula **) +(** val max_var : positive -> z pol -> positive **) -let bound_vars tag_of_var fr v = - Vars.fold (fun k acc -> - let y = XO (Coq_Pos.add fr k) in - let z0 = XI (Coq_Pos.add fr k) in - Cj ((Cj ((A ((mk_eq_pos k y z0), (tag_of_var fr k None))), (Cj ((A - ((bound_var y), (tag_of_var fr k (Some false)))), (A ((bound_var z0), - (tag_of_var fr k (Some true)))))))), acc)) v TT +let rec max_var jmp = function +| Pc _ -> jmp +| Pinj (j, p2) -> max_var (Coq_Pos.add j jmp) p2 +| PX (p2, _, q0) -> + Coq_Pos.max (max_var jmp p2) (max_var (Coq_Pos.succ jmp) q0) -(** val bound_problem_fr : - (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, - 'a1, 'a2, 'a3) gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula **) +(** val max_var_nformulae : z nFormula list -> positive **) -let bound_problem_fr tag_of_var fr f = - let v = vars_of_bformula f in I ((bound_vars tag_of_var fr v), None, f) +let max_var_nformulae l = + fold_left (fun acc f -> Coq_Pos.max acc (max_var XH (fst f))) l XH (** val zChecker : z nFormula list -> zArithProof -> bool **) @@ -2232,6 +2124,16 @@ let rec zChecker l = function | None -> true) | None -> false) | None -> false) +| ExProof (x, prf) -> + let fr = max_var_nformulae l in + if Coq_Pos.leb x fr + then let z0 = Coq_Pos.succ fr in + let t0 = Coq_Pos.succ z0 in + let nfx = xnnormalise (mk_eq_pos x z0 t0) in + let posz = xnnormalise (bound_var z0) in + let post = xnnormalise (bound_var t0) in + zChecker (nfx::(posz::(post::l))) prf + else false (** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 822fde9ab0..4200c80574 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -1,275 +1,276 @@ - type __ = Obj.t - -type unit0 = -| Tt +type unit0 = Tt val negb : bool -> bool -type nat = -| O -| S of nat - -type ('a, 'b) sum = -| Inl of 'a -| Inr of 'b - -val fst : ('a1 * 'a2) -> 'a1 - -val snd : ('a1 * 'a2) -> 'a2 +type nat = O | S of nat +type ('a, 'b) sum = Inl of 'a | Inr of 'b +val fst : 'a1 * 'a2 -> 'a1 +val snd : 'a1 * 'a2 -> 'a2 val app : 'a1 list -> 'a1 list -> 'a1 list -type comparison = -| Eq -| Lt -| Gt +type comparison = Eq | Lt | Gt val compOpp : comparison -> comparison - val add : nat -> nat -> nat - val nth : nat -> 'a1 list -> 'a1 -> 'a1 - val rev_append : 'a1 list -> 'a1 list -> 'a1 list - val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list - val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 - val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 -type positive = -| XI of positive -| XO of positive -| XH - -type n = -| N0 -| Npos of positive - -type z = -| Z0 -| Zpos of positive -| Zneg of positive - -module Pos : - sig - type mask = - | IsNul - | IsPos of positive - | IsNeg - end - -module Coq_Pos : - sig - val succ : positive -> positive +type positive = XI of positive | XO of positive | XH +type n = N0 | Npos of positive +type z = Z0 | Zpos of positive | Zneg of positive - val add : positive -> positive -> positive +module Pos : sig + type mask = IsNul | IsPos of positive | IsNeg +end +module Coq_Pos : sig + val succ : positive -> positive + val add : positive -> positive -> positive val add_carry : positive -> positive -> positive - val pred_double : positive -> positive - type mask = Pos.mask = - | IsNul - | IsPos of positive - | IsNeg + type mask = Pos.mask = IsNul | IsPos of positive | IsNeg val succ_double_mask : mask -> mask - val double_mask : mask -> mask - val double_pred_mask : positive -> mask - val sub_mask : positive -> positive -> mask - val sub_mask_carry : positive -> positive -> mask - val sub : positive -> positive -> positive - val mul : positive -> positive -> positive - val iter : ('a1 -> 'a1) -> 'a1 -> positive -> 'a1 - val size_nat : positive -> nat - val compare_cont : comparison -> positive -> positive -> comparison - val compare : positive -> positive -> comparison - + val max : positive -> positive -> positive + val leb : positive -> positive -> bool val gcdn : nat -> positive -> positive -> positive - val gcd : positive -> positive -> positive - val of_succ_nat : nat -> positive - end +end -module N : - sig +module N : sig val of_nat : nat -> n - end +end val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 -module Z : - sig +module Z : sig val double : z -> z - val succ_double : z -> z - val pred_double : z -> z - val pos_sub : positive -> positive -> z - val add : z -> z -> z - val opp : z -> z - val sub : z -> z -> z - val mul : z -> z -> z - val pow_pos : z -> positive -> z - val pow : z -> z -> z - val compare : z -> z -> comparison - val leb : z -> z -> bool - val ltb : z -> z -> bool - val gtb : z -> z -> bool - val max : z -> z -> z - val abs : z -> z - val to_N : z -> n - val of_nat : nat -> z - val of_N : n -> z - val pos_div_eucl : positive -> z -> z * z - val div_eucl : z -> z -> z * z - val div : z -> z -> z - val gcd : z -> z -> z - end +end val zeq_bool : z -> z -> bool type 'c pol = -| Pc of 'c -| Pinj of positive * 'c pol -| PX of 'c pol * positive * 'c pol + | Pc of 'c + | Pinj of positive * 'c pol + | PX of 'c pol * positive * 'c pol val p0 : 'a1 -> 'a1 pol - val p1 : 'a1 -> 'a1 pol - val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool - val mkPinj : positive -> 'a1 pol -> 'a1 pol - val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol -val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val mkPX : + 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol - val mkX : 'a1 -> 'a1 -> 'a1 pol - val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol - val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol - val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> - 'a1 pol + ('a1 -> 'a1 -> 'a1) + -> ('a1 pol -> 'a1 pol -> 'a1 pol) + -> 'a1 pol + -> positive + -> 'a1 pol + -> 'a1 pol val psubI : - ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive - -> 'a1 pol -> 'a1 pol + ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1) + -> ('a1 pol -> 'a1 pol -> 'a1 pol) + -> 'a1 pol + -> positive + -> 'a1 pol + -> 'a1 pol val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 - pol -> 'a1 pol + 'a1 + -> ('a1 -> 'a1 -> bool) + -> ('a1 pol -> 'a1 pol -> 'a1 pol) + -> 'a1 pol + -> positive + -> 'a1 pol + -> 'a1 pol val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol + 'a1 + -> ('a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> ('a1 pol -> 'a1 pol -> 'a1 pol) + -> 'a1 pol + -> positive + -> 'a1 pol + -> 'a1 pol -val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val padd : + 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 pol + -> 'a1 pol + -> 'a1 pol val psub : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - 'a1 pol -> 'a1 pol -> 'a1 pol + 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 pol + -> 'a1 pol + -> 'a1 pol -val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol +val pmulC_aux : + 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 pol + -> 'a1 + -> 'a1 pol val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 pol + -> 'a1 + -> 'a1 pol val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> ('a1 pol -> 'a1 pol -> 'a1 pol) + -> 'a1 pol + -> positive + -> 'a1 pol + -> 'a1 pol val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol - -> 'a1 pol -> 'a1 pol + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 pol + -> 'a1 pol + -> 'a1 pol val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 pol -> 'a1 pol type 'c pExpr = -| PEc of 'c -| PEX of positive -| PEadd of 'c pExpr * 'c pExpr -| PEsub of 'c pExpr * 'c pExpr -| PEmul of 'c pExpr * 'c pExpr -| PEopp of 'c pExpr -| PEpow of 'c pExpr * n + | PEc of 'c + | PEX of positive + | PEadd of 'c pExpr * 'c pExpr + | PEsub of 'c pExpr * 'c pExpr + | PEmul of 'c pExpr * 'c pExpr + | PEopp of 'c pExpr + | PEpow of 'c pExpr * n val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol - -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> ('a1 pol -> 'a1 pol) + -> 'a1 pol + -> 'a1 pol + -> positive + -> 'a1 pol val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol - -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> ('a1 pol -> 'a1 pol) + -> 'a1 pol + -> n + -> 'a1 pol val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 pExpr + -> 'a1 pol type ('tA, 'tX, 'aA, 'aF) gFormula = -| TT -| FF -| X of 'tX -| A of 'tA * 'aA -| Cj of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula -| D of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula -| N of ('tA, 'tX, 'aA, 'aF) gFormula -| I of ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula - -val mapX : ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula + | TT + | FF + | X of 'tX + | A of 'tA * 'aA + | Cj of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula + | D of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula + | N of ('tA, 'tX, 'aA, 'aF) gFormula + | I of + ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula + +val mapX : + ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula val foldA : ('a5 -> 'a3 -> 'a5) -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 - val cons_id : 'a1 option -> 'a1 list -> 'a1 list - val ids_of_formula : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list - val collect_annot : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list type 'a bFormula = ('a, __, unit0, unit0) gFormula @@ -278,411 +279,449 @@ val map_bformula : ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, 'a5) gFormula type ('x, 'annot) clause = ('x * 'annot) list - type ('x, 'annot) cnf = ('x, 'annot) clause list val cnf_tt : ('a1, 'a2) cnf - val cnf_ff : ('a1, 'a2) cnf val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> ('a1, 'a2) - clause option + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> 'a1 * 'a2 + -> ('a1, 'a2) clause + -> ('a1, 'a2) clause option val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) clause -> - ('a1, 'a2) clause option + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> ('a1, 'a2) clause + -> ('a1, 'a2) clause + -> ('a1, 'a2) clause option val xor_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> ('a1, 'a2) clause + -> ('a1, 'a2) cnf + -> ('a1, 'a2) cnf val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> ('a1, 'a2) clause + -> ('a1, 'a2) cnf + -> ('a1, 'a2) cnf val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) - cnf + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> ('a1, 'a2) cnf + -> ('a1, 'a2) cnf + -> ('a1, 'a2) cnf val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula val is_cnf_tt : ('a1, 'a2) cnf -> bool - val is_cnf_ff : ('a1, 'a2) cnf -> bool - val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf val or_cnf_opt : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) - cnf + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> ('a1, 'a2) cnf + -> ('a1, 'a2) cnf + -> ('a1, 'a2) cnf val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 - -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf + ('a2 -> bool) + -> ('a2 -> 'a2 -> 'a2 option) + -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) + -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) + -> bool + -> ('a1, 'a3, 'a4, 'a5) tFormula + -> ('a2, 'a3) cnf val radd_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> (('a1, - 'a2) clause, 'a2 list) sum + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> 'a1 * 'a2 + -> ('a1, 'a2) clause + -> (('a1, 'a2) clause, 'a2 list) sum val ror_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause -> - (('a1, 'a2) clause, 'a2 list) sum + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> ('a1 * 'a2) list + -> ('a1, 'a2) clause + -> (('a1, 'a2) clause, 'a2 list) sum val xror_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> - ('a1, 'a2) clause list * 'a2 list + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> ('a1 * 'a2) list + -> ('a1, 'a2) clause list + -> ('a1, 'a2) clause list * 'a2 list val ror_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> - ('a1, 'a2) clause list * 'a2 list + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> ('a1 * 'a2) list + -> ('a1, 'a2) clause list + -> ('a1, 'a2) clause list * 'a2 list val ror_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> ('a1, 'a2) clause - list -> ('a1, 'a2) cnf * 'a2 list + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> ('a1, 'a2) clause list + -> ('a1, 'a2) clause list + -> ('a1, 'a2) cnf * 'a2 list val ror_cnf_opt : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) - cnf * 'a2 list + ('a1 -> bool) + -> ('a1 -> 'a1 -> 'a1 option) + -> ('a1, 'a2) cnf + -> ('a1, 'a2) cnf + -> ('a1, 'a2) cnf * 'a2 list val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 list val rxcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 - -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list - -type ('term, 'annot, 'tX) to_constrT = { mkTT : 'tX; mkFF : 'tX; - mkA : ('term -> 'annot -> 'tX); - mkCj : ('tX -> 'tX -> 'tX); mkD : ('tX -> 'tX -> 'tX); - mkI : ('tX -> 'tX -> 'tX); mkN : ('tX -> 'tX) } - -val aformula : ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 + ('a2 -> bool) + -> ('a2 -> 'a2 -> 'a2 option) + -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) + -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) + -> bool + -> ('a1, 'a3, 'a4, 'a5) tFormula + -> ('a2, 'a3) cnf * 'a3 list + +type ('term, 'annot, 'tX) to_constrT = + { mkTT : 'tX + ; mkFF : 'tX + ; mkA : 'term -> 'annot -> 'tX + ; mkCj : 'tX -> 'tX -> 'tX + ; mkD : 'tX -> 'tX -> 'tX + ; mkI : 'tX -> 'tX -> 'tX + ; mkN : 'tX -> 'tX } + +val aformula : + ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 val is_X : ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option val abs_and : - ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula - -> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) - tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT + -> ('a1, 'a2, 'a3, 'a4) tFormula + -> ('a1, 'a2, 'a3, 'a4) tFormula + -> ( ('a1, 'a2, 'a3, 'a4) tFormula + -> ('a1, 'a2, 'a3, 'a4) tFormula + -> ('a1, 'a2, 'a3, 'a4) tFormula) + -> ('a1, 'a3, 'a2, 'a4) gFormula val abs_or : - ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula - -> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) - tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT + -> ('a1, 'a2, 'a3, 'a4) tFormula + -> ('a1, 'a2, 'a3, 'a4) tFormula + -> ( ('a1, 'a2, 'a3, 'a4) tFormula + -> ('a1, 'a2, 'a3, 'a4) tFormula + -> ('a1, 'a2, 'a3, 'a4) tFormula) + -> ('a1, 'a3, 'a2, 'a4) gFormula val mk_arrow : - 'a4 option -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, - 'a3, 'a4) tFormula + 'a4 option + -> ('a1, 'a2, 'a3, 'a4) tFormula + -> ('a1, 'a2, 'a3, 'a4) tFormula + -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_form : - ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, - 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT + -> ('a2 -> bool) + -> bool + -> ('a1, 'a2, 'a3, 'a4) tFormula + -> ('a1, 'a3, 'a2, 'a4) gFormula -val cnf_checker : (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool +val cnf_checker : + (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 - -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, 'a3, unit0) gFormula -> - 'a4 list -> bool + ('a2 -> bool) + -> ('a2 -> 'a2 -> 'a2 option) + -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) + -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) + -> (('a2 * 'a3) list -> 'a4 -> bool) + -> ('a1, __, 'a3, unit0) gFormula + -> 'a4 list + -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool - val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool type 'c polC = 'c pol - -type op1 = -| Equal -| NonEqual -| Strict -| NonStrict - +type op1 = Equal | NonEqual | Strict | NonStrict type 'c nFormula = 'c polC * op1 val opMult : op1 -> op1 -> op1 option - val opAdd : op1 -> op1 -> op1 option type 'c psatz = -| PsatzIn of nat -| PsatzSquare of 'c polC -| PsatzMulC of 'c polC * 'c psatz -| PsatzMulE of 'c psatz * 'c psatz -| PsatzAdd of 'c psatz * 'c psatz -| PsatzC of 'c -| PsatzZ + | PsatzIn of nat + | PsatzSquare of 'c polC + | PsatzMulC of 'c polC * 'c psatz + | PsatzMulE of 'c psatz * 'c psatz + | PsatzAdd of 'c psatz * 'c psatz + | PsatzC of 'c + | PsatzZ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option -val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option +val map_option2 : + ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC - -> 'a1 nFormula -> 'a1 nFormula option + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 polC + -> 'a1 nFormula + -> 'a1 nFormula option val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 - nFormula -> 'a1 nFormula -> 'a1 nFormula option + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 nFormula + -> 'a1 nFormula + -> 'a1 nFormula option val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 - nFormula option + 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 nFormula + -> 'a1 nFormula + -> 'a1 nFormula option val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> - 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> ('a1 -> 'a1 -> bool) + -> 'a1 nFormula list + -> 'a1 psatz + -> 'a1 nFormula option val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> - 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool - -type op2 = -| OpEq -| OpNEq -| OpLe -| OpGe -| OpLt -| OpGt - -type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> ('a1 -> 'a1 -> bool) + -> 'a1 nFormula list + -> 'a1 psatz + -> bool + +type op2 = OpEq | OpNEq | OpLe | OpGe | OpLt | OpGt +type 't formula = {flhs : 't pExpr; fop : op2; frhs : 't pExpr} val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 pExpr + -> 'a1 pol val psub0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - 'a1 pol -> 'a1 pol -> 'a1 pol + 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 pol + -> 'a1 pol + -> 'a1 pol -val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val padd0 : + 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 pol + -> 'a1 pol + -> 'a1 pol val popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol val normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 formula + -> 'a1 nFormula val xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list - val xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list val cnf_of_list : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a2 -> ('a1 - nFormula, 'a2) cnf + 'a1 + -> ('a1 -> 'a1 -> bool) + -> ('a1 -> 'a1 -> bool) + -> 'a1 nFormula list + -> 'a2 + -> ('a1 nFormula, 'a2) cnf val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, - 'a2) cnf + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> ('a1 -> 'a1 -> bool) + -> 'a1 formula + -> 'a2 + -> ('a1 nFormula, 'a2) cnf val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> - 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, - 'a2) cnf + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> ('a1 -> 'a1 -> bool) + -> 'a1 formula + -> 'a2 + -> ('a1 nFormula, 'a2) cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr - val denorm : 'a1 pol -> 'a1 pExpr - val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr - val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula val simpl_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz + 'a1 + -> 'a1 + -> ('a1 -> 'a1 -> 'a1) + -> ('a1 -> 'a1 -> bool) + -> 'a1 psatz + -> 'a1 psatz -module PositiveSet : - sig - type tree = - | Leaf - | Node of tree * bool * tree - end - -type q = { qnum : z; qden : positive } +type q = {qnum : z; qden : positive} val qeq_bool : q -> q -> bool - val qle_bool : q -> q -> bool - val qplus : q -> q -> q - val qmult : q -> q -> q - val qopp : q -> q - val qminus : q -> q -> q - val qinv : q -> q - val qpower_positive : q -> positive -> q - val qpower : q -> z -> q -type 'a t = -| Empty -| Elt of 'a -| Branch of 'a t * 'a * 'a t +type 'a t = Empty | Elt of 'a | Branch of 'a t * 'a * 'a t val find : 'a1 -> 'a1 t -> positive -> 'a1 - val singleton : 'a1 -> positive -> 'a1 -> 'a1 t - val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t - val zeval_const : z pExpr -> z option type zWitness = z psatz val zWeakChecker : z nFormula list -> z psatz -> bool - val psub1 : z pol -> z pol -> z pol - val padd1 : z pol -> z pol -> z pol - val normZ : z pExpr -> z pol - val zunsat : z nFormula -> bool - val zdeduce : z nFormula -> z nFormula -> z nFormula option - val xnnormalise : z formula -> z nFormula - val xnormalise0 : z nFormula -> z nFormula list - val cnf_of_list0 : 'a1 -> z nFormula list -> (z nFormula * 'a1) list list - val normalise0 : z formula -> 'a1 -> (z nFormula, 'a1) cnf - val xnegate0 : z nFormula -> z nFormula list - val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf -val cnfZ : (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list +val cnfZ : + (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list val ceiling : z -> z -> z type zArithProof = -| DoneProof -| RatProof of zWitness * zArithProof -| CutProof of zWitness * zArithProof -| EnumProof of zWitness * zWitness * zArithProof list + | DoneProof + | RatProof of zWitness * zArithProof + | CutProof of zWitness * zArithProof + | EnumProof of zWitness * zWitness * zArithProof list + | ExProof of positive * zArithProof val zgcdM : z -> z -> z - val zgcd_pol : z polC -> z * z - val zdiv_pol : z polC -> z -> z polC - val makeCuttingPlane : z polC -> z polC * z - val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option - -val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula - +val nformula_of_cutting_plane : (z polC * z) * op1 -> z nFormula val is_pol_Z0 : z polC -> bool - val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option - val valid_cut_sign : op1 -> bool - -module Vars : - sig - type elt = positive - - type tree = PositiveSet.tree = - | Leaf - | Node of tree * bool * tree - - type t = tree - - val empty : t - - val add : elt -> t -> t - - val singleton : elt -> t - - val union : t -> t -> t - - val rev_append : elt -> elt -> elt - - val rev : elt -> elt - - val xfold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> elt -> 'a1 - - val fold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> 'a1 - end - -val vars_of_pexpr : z pExpr -> Vars.t - -val vars_of_formula : z formula -> Vars.t - -val vars_of_bformula : (z formula, 'a1, 'a2, 'a3) gFormula -> Vars.t - val bound_var : positive -> z formula - val mk_eq_pos : positive -> positive -> positive -> z formula - -val bound_vars : - (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, 'a1, 'a2, - 'a3) gFormula - -val bound_problem_fr : - (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, 'a1, 'a2, 'a3) - gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula - +val max_var : positive -> z pol -> positive +val max_var_nformulae : z nFormula list -> positive val zChecker : z nFormula list -> zArithProof -> bool - val zTautoChecker : z formula bFormula -> zArithProof list -> bool type qWitness = q psatz val qWeakChecker : q nFormula list -> q psatz -> bool - val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf - val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf - val qunsat : q nFormula -> bool - val qdeduce : q nFormula -> q nFormula -> q nFormula option - val normQ : q pExpr -> q pol -val cnfQ : (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list +val cnfQ : + (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = -| C0 -| C1 -| CQ of q -| CZ of z -| CPlus of rcst * rcst -| CMinus of rcst * rcst -| CMult of rcst * rcst -| CPow of rcst * (z, nat) sum -| CInv of rcst -| COpp of rcst + | C0 + | C1 + | CQ of q + | CZ of z + | CPlus of rcst * rcst + | CMinus of rcst * rcst + | CMult of rcst * rcst + | CPow of rcst * (z, nat) sum + | CInv of rcst + | COpp of rcst val z_of_exp : (z, nat) sum -> z - val q_of_Rcst : rcst -> q type rWitness = q psatz val rWeakChecker : q nFormula list -> q psatz -> bool - val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf - val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf - val runsat : q nFormula -> bool - val rdeduce : q nFormula -> q nFormula -> q nFormula option - val rTautoChecker : rcst formula bFormula -> rWitness list -> bool diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index a30e963f2a..03f042647c 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -21,294 +21,246 @@ module Int = struct type t = int + let compare : int -> int -> int = compare - let equal : int -> int -> bool = (=) + let equal : int -> int -> bool = ( = ) end -module ISet = - struct - include Set.Make(Int) +module ISet = struct + include Set.Make (Int) - let pp o s = iter (fun i -> Printf.fprintf o "%i " i) s - end + let pp o s = iter (fun i -> Printf.fprintf o "%i " i) s +end -module IMap = - struct - include Map.Make(Int) +module IMap = struct + include Map.Make (Int) - let from k m = - let (_,_,r) = split (k-1) m in - r - end + let from k m = + let _, _, r = split (k - 1) m in + r +end let rec pp_list s f o l = match l with - | [] -> () - | [e] -> f o e - | e::l -> f o e ; output_string o s ; pp_list s f o l + | [] -> () + | [e] -> f o e + | e :: l -> f o e; output_string o s; pp_list s f o l let finally f rst = try let res = f () in - rst () ; res + rst (); res with reraise -> - (try rst () - with any -> raise reraise - ); raise reraise + (try rst () with any -> raise reraise); + raise reraise let rec try_any l x = - match l with + match l with | [] -> None - | (f,s)::l -> match f x with - | None -> try_any l x - | x -> x + | (f, s) :: l -> ( match f x with None -> try_any l x | x -> x ) let all_pairs f l = - let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in - + let pair_with acc e l = List.fold_left (fun acc x -> f e x :: acc) acc l in let rec xpairs acc l = - match l with - | [] -> acc - | e::lx -> xpairs (pair_with acc e l) lx in - xpairs [] l + match l with [] -> acc | e :: lx -> xpairs (pair_with acc e l) lx + in + xpairs [] l let rec is_sublist f l1 l2 = - match l1 ,l2 with - | [] ,_ -> true - | e::l1', [] -> false - | e::l1' , e'::l2' -> - if f e e' then is_sublist f l1' l2' - else is_sublist f l1 l2' + match (l1, l2) with + | [], _ -> true + | e :: l1', [] -> false + | e :: l1', e' :: l2' -> + if f e e' then is_sublist f l1' l2' else is_sublist f l1 l2' let extract pred l = - List.fold_left (fun (fd,sys) e -> - match fd with - | None -> - begin - match pred e with - | None -> fd, e::sys - | Some v -> Some(v,e) , sys - end - | _ -> (fd, e::sys) - ) (None,[]) l + List.fold_left + (fun (fd, sys) e -> + match fd with + | None -> ( + match pred e with None -> (fd, e :: sys) | Some v -> (Some (v, e), sys) + ) + | _ -> (fd, e :: sys)) + (None, []) l let extract_best red lt l = let rec extractb c e rst l = match l with - [] -> Some (c,e) , rst - | e'::l' -> match red e' with - | None -> extractb c e (e'::rst) l' - | Some c' -> if lt c' c - then extractb c' e' (e::rst) l' - else extractb c e (e'::rst) l' in + | [] -> (Some (c, e), rst) + | e' :: l' -> ( + match red e' with + | None -> extractb c e (e' :: rst) l' + | Some c' -> + if lt c' c then extractb c' e' (e :: rst) l' + else extractb c e (e' :: rst) l' ) + in match extract red l with - | None , _ -> None,l - | Some(c,e), rst -> extractb c e [] rst - + | None, _ -> (None, l) + | Some (c, e), rst -> extractb c e [] rst let rec find_option pred l = match l with | [] -> raise Not_found - | e::l -> match pred e with - | Some r -> r - | None -> find_option pred l - -let find_some pred l = - try Some (find_option pred l) with Not_found -> None + | e :: l -> ( match pred e with Some r -> r | None -> find_option pred l ) +let find_some pred l = try Some (find_option pred l) with Not_found -> None -let extract_all pred l = - List.fold_left (fun (s1,s2) e -> - match pred e with - | None -> s1,e::s2 - | Some v -> (v,e)::s1 , s2) ([],[]) l +let extract_all pred l = + List.fold_left + (fun (s1, s2) e -> + match pred e with None -> (s1, e :: s2) | Some v -> ((v, e) :: s1, s2)) + ([], []) l let simplify f sys = - let (sys',b) = - List.fold_left (fun (sys',b) c -> - match f c with - | None -> (c::sys',b) - | Some c' -> - (c'::sys',true) - ) ([],false) sys in + let sys', b = + List.fold_left + (fun (sys', b) c -> + match f c with None -> (c :: sys', b) | Some c' -> (c' :: sys', true)) + ([], false) sys + in if b then Some sys' else None let generate_acc f acc sys = - List.fold_left (fun sys' c -> match f c with - | None -> sys' - | Some c' -> c'::sys' - ) acc sys - + List.fold_left + (fun sys' c -> match f c with None -> sys' | Some c' -> c' :: sys') + acc sys let generate f sys = generate_acc f [] sys - let saturate p f sys = - let rec sat acc l = + let rec sat acc l = match extract p l with - | None,_ -> acc - | Some r,l' -> - let n = generate (f r) (l'@acc) in - sat (n@acc) l' in - try sat [] sys with - x -> - begin - Printexc.print_backtrace stdout ; - raise x - end - + | None, _ -> acc + | Some r, l' -> + let n = generate (f r) (l' @ acc) in + sat (n @ acc) l' + in + try sat [] sys + with x -> + Printexc.print_backtrace stdout; + raise x open Num open Big_int let ppcm x y = - let g = gcd_big_int x y in - let x' = div_big_int x g in - let y' = div_big_int y g in + let g = gcd_big_int x y in + let x' = div_big_int x g in + let y' = div_big_int y g in mult_big_int g (mult_big_int x' y') let denominator = function - | Int _ | Big_int _ -> unit_big_int - | Ratio r -> Ratio.denominator_ratio r + | Int _ | Big_int _ -> unit_big_int + | Ratio r -> Ratio.denominator_ratio r let numerator = function - | Ratio r -> Ratio.numerator_ratio r - | Int i -> Big_int.big_int_of_int i - | Big_int i -> i + | Ratio r -> Ratio.numerator_ratio r + | Int i -> Big_int.big_int_of_int i + | Big_int i -> i let iterate_until_stable f x = - let rec iter x = - match f x with - | None -> x - | Some x' -> iter x' in - iter x + let rec iter x = match f x with None -> x | Some x' -> iter x' in + iter x let rec app_funs l x = - match l with - | [] -> None - | f::fl -> - match f x with - | None -> app_funs fl x - | Some x' -> Some x' - + match l with + | [] -> None + | f :: fl -> ( match f x with None -> app_funs fl x | Some x' -> Some x' ) (** * MODULE: Coq to Caml data-structure mappings *) -module CoqToCaml = -struct - open Micromega - - let rec nat = function - | O -> 0 - | S n -> (nat n) + 1 +module CoqToCaml = struct + open Micromega + let rec nat = function O -> 0 | S n -> nat n + 1 - let rec positive p = - match p with - | XH -> 1 - | XI p -> 1+ 2*(positive p) - | XO p -> 2*(positive p) + let rec positive p = + match p with + | XH -> 1 + | XI p -> 1 + (2 * positive p) + | XO p -> 2 * positive p - let n nt = - match nt with - | N0 -> 0 - | Npos p -> positive p + let n nt = match nt with N0 -> 0 | Npos p -> positive p - let rec index i = (* Swap left-right ? *) - match i with - | XH -> 1 - | XI i -> 1+(2*(index i)) - | XO i -> 2*(index i) + let rec index i = + (* Swap left-right ? *) + match i with XH -> 1 | XI i -> 1 + (2 * index i) | XO i -> 2 * index i - open Big_int + open Big_int - let rec positive_big_int p = - match p with - | XH -> unit_big_int - | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) - | XO p -> (mult_int_big_int 2 (positive_big_int p)) + let rec positive_big_int p = + match p with + | XH -> unit_big_int + | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) + | XO p -> mult_int_big_int 2 (positive_big_int p) - let z_big_int x = - match x with - | Z0 -> zero_big_int - | Zpos p -> (positive_big_int p) - | Zneg p -> minus_big_int (positive_big_int p) + let z_big_int x = + match x with + | Z0 -> zero_big_int + | Zpos p -> positive_big_int p + | Zneg p -> minus_big_int (positive_big_int p) - let z x = - match x with - | Z0 -> 0 - | Zpos p -> index p - | Zneg p -> - (index p) - - - let q_to_num {qnum = x ; qden = y} = - Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) + let z x = match x with Z0 -> 0 | Zpos p -> index p | Zneg p -> -index p + let q_to_num {qnum = x; qden = y} = + Big_int (z_big_int x) // Big_int (z_big_int (Zpos y)) end - (** * MODULE: Caml to Coq data-structure mappings *) -module CamlToCoq = -struct - open Micromega - - let rec nat = function - | 0 -> O - | n -> S (nat (n-1)) +module CamlToCoq = struct + open Micromega + let rec nat = function 0 -> O | n -> S (nat (n - 1)) - let rec positive n = - if Int.equal n 1 then XH - else if Int.equal (n land 1) 1 then XI (positive (n lsr 1)) - else XO (positive (n lsr 1)) + let rec positive n = + if Int.equal n 1 then XH + else if Int.equal (n land 1) 1 then XI (positive (n lsr 1)) + else XO (positive (n lsr 1)) - let n nt = - if nt < 0 - then assert false - else if Int.equal nt 0 then N0 - else Npos (positive nt) + let n nt = + if nt < 0 then assert false + else if Int.equal nt 0 then N0 + else Npos (positive nt) - let rec index n = - if Int.equal n 1 then XH - else if Int.equal (n land 1) 1 then XI (index (n lsr 1)) - else XO (index (n lsr 1)) + let rec index n = + if Int.equal n 1 then XH + else if Int.equal (n land 1) 1 then XI (index (n lsr 1)) + else XO (index (n lsr 1)) - - let z x = - match compare x 0 with - | 0 -> Z0 - | 1 -> Zpos (positive x) - | _ -> (* this should be -1 *) + let z x = + match compare x 0 with + | 0 -> Z0 + | 1 -> Zpos (positive x) + | _ -> + (* this should be -1 *) Zneg (positive (-x)) - open Big_int - - let positive_big_int n = - let two = big_int_of_int 2 in - let rec _pos n = - if eq_big_int n unit_big_int then XH - else - let (q,m) = quomod_big_int n two in - if eq_big_int unit_big_int m - then XI (_pos q) - else XO (_pos q) in - _pos n - - let bigint x = - match sign_big_int x with - | 0 -> Z0 - | 1 -> Zpos (positive_big_int x) - | _ -> Zneg (positive_big_int (minus_big_int x)) - - let q n = - {Micromega.qnum = bigint (numerator n) ; - Micromega.qden = positive_big_int (denominator n)} - + open Big_int + + let positive_big_int n = + let two = big_int_of_int 2 in + let rec _pos n = + if eq_big_int n unit_big_int then XH + else + let q, m = quomod_big_int n two in + if eq_big_int unit_big_int m then XI (_pos q) else XO (_pos q) + in + _pos n + + let bigint x = + match sign_big_int x with + | 0 -> Z0 + | 1 -> Zpos (positive_big_int x) + | _ -> Zneg (positive_big_int (minus_big_int x)) + + let q n = + { Micromega.qnum = bigint (numerator n) + ; Micromega.qden = positive_big_int (denominator n) } end (** @@ -316,25 +268,22 @@ end * between two lists given an ordering, and using a hash computation *) -module Cmp = -struct - - let rec compare_lexical l = - match l with - | [] -> 0 (* Equal *) - | f::l -> +module Cmp = struct + let rec compare_lexical l = + match l with + | [] -> 0 (* Equal *) + | f :: l -> let cmp = f () in - if Int.equal cmp 0 then compare_lexical l else cmp - - let rec compare_list cmp l1 l2 = - match l1 , l2 with - | [] , [] -> 0 - | [] , _ -> -1 - | _ , [] -> 1 - | e1::l1 , e2::l2 -> + if Int.equal cmp 0 then compare_lexical l else cmp + + let rec compare_list cmp l1 l2 = + match (l1, l2) with + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + | e1 :: l1, e2 :: l2 -> let c = cmp e1 e2 in - if Int.equal c 0 then compare_list cmp l1 l2 else c - + if Int.equal c 0 then compare_list cmp l1 l2 else c end (** @@ -344,22 +293,18 @@ end * superfluous items, which speeds the translation up a bit. *) -module type Tag = -sig - - type t +module type Tag = sig + type t = int val from : int -> t val next : t -> t val pp : out_channel -> t -> unit val compare : t -> t -> int val max : t -> t -> t - val to_int : t -> int + val to_int : t -> int end -module Tag : Tag = -struct - +module Tag : Tag = struct type t = int let from i = i @@ -368,14 +313,15 @@ struct let pp o i = output_string o (string_of_int i) let compare : int -> int -> int = Int.compare let to_int x = x - end (** * MODULE: Ordered sets of tags. *) -module TagSet = Set.Make(Tag) +module TagSet = struct + include Set.Make (Tag) +end (** As for Unix.close_process, our Unix.waipid will ignore all EINTR *) @@ -389,120 +335,100 @@ let rec waitpid_non_intr pid = let command exe_path args vl = (* creating pipes for stdin, stdout, stderr *) - let (stdin_read,stdin_write) = Unix.pipe () - and (stdout_read,stdout_write) = Unix.pipe () - and (stderr_read,stderr_write) = Unix.pipe () in - + let stdin_read, stdin_write = Unix.pipe () + and stdout_read, stdout_write = Unix.pipe () + and stderr_read, stderr_write = Unix.pipe () in (* Create the process *) - let pid = Unix.create_process exe_path args stdin_read stdout_write stderr_write in - + let pid = + Unix.create_process exe_path args stdin_read stdout_write stderr_write + in (* Write the data on the stdin of the created process *) let outch = Unix.out_channel_of_descr stdin_write in - output_value outch vl ; - flush outch ; - + output_value outch vl; + flush outch; (* Wait for its completion *) - let status = waitpid_non_intr pid in - - finally - (* Recover the result *) - (fun () -> - match status with - | Unix.WEXITED 0 -> - let inch = Unix.in_channel_of_descr stdout_read in - begin - try Marshal.from_channel inch - with any -> - failwith - (Printf.sprintf "command \"%s\" exited %s" exe_path - (Printexc.to_string any)) - end - | Unix.WEXITED i -> - failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) - | Unix.WSIGNALED i -> - failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) - | Unix.WSTOPPED i -> - failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) - (* Cleanup *) - (fun () -> - List.iter (fun x -> try Unix.close x with any -> ()) - [stdin_read; stdin_write; - stdout_read; stdout_write; - stderr_read; stderr_write]) + let status = waitpid_non_intr pid in + finally + (* Recover the result *) + (fun () -> + match status with + | Unix.WEXITED 0 -> ( + let inch = Unix.in_channel_of_descr stdout_read in + try Marshal.from_channel inch + with any -> + failwith + (Printf.sprintf "command \"%s\" exited %s" exe_path + (Printexc.to_string any)) ) + | Unix.WEXITED i -> + failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) + | Unix.WSIGNALED i -> + failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) + | Unix.WSTOPPED i -> + failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) + (* Cleanup *) + (fun () -> + List.iter + (fun x -> try Unix.close x with any -> ()) + [ stdin_read + ; stdin_write + ; stdout_read + ; stdout_write + ; stderr_read + ; stderr_write ]) (** Hashing utilities *) -module Hash = - struct - - module Mc = Micromega - - open Hashset.Combine - - let int_of_eq_op1 = Mc.(function - | Equal -> 0 - | NonEqual -> 1 - | Strict -> 2 - | NonStrict -> 3) - - let eq_op1 o1 o2 = int_of_eq_op1 o1 = int_of_eq_op1 o2 - - let hash_op1 h o = combine h (int_of_eq_op1 o) - - - let rec eq_positive p1 p2 = - match p1 , p2 with - | Mc.XH , Mc.XH -> true - | Mc.XI p1 , Mc.XI p2 -> eq_positive p1 p2 - | Mc.XO p1 , Mc.XO p2 -> eq_positive p1 p2 - | _ , _ -> false - - let eq_z z1 z2 = - match z1 , z2 with - | Mc.Z0 , Mc.Z0 -> true - | Mc.Zpos p1, Mc.Zpos p2 - | Mc.Zneg p1, Mc.Zneg p2 -> eq_positive p1 p2 - | _ , _ -> false - - let eq_q {Mc.qnum = qn1 ; Mc.qden = qd1} {Mc.qnum = qn2 ; Mc.qden = qd2} = - eq_z qn1 qn2 && eq_positive qd1 qd2 - - let rec eq_pol eq p1 p2 = - match p1 , p2 with - | Mc.Pc c1 , Mc.Pc c2 -> eq c1 c2 - | Mc.Pinj(i1,p1) , Mc.Pinj(i2,p2) -> eq_positive i1 i2 && eq_pol eq p1 p2 - | Mc.PX(p1,i1,p1') , Mc.PX(p2,i2,p2') -> - eq_pol eq p1 p2 && eq_positive i1 i2 && eq_pol eq p1' p2' - | _ , _ -> false - - - let eq_pair eq1 eq2 (x1,y1) (x2,y2) = - eq1 x1 x2 && eq2 y1 y2 - - - let hash_pol helt = - let rec hash acc = function - | Mc.Pc c -> helt (combine acc 1) c - | Mc.Pinj(p,c) -> hash (combine (combine acc 1) (CoqToCaml.index p)) c - | Mc.PX(p1,i,p2) -> hash (hash (combine (combine acc 2) (CoqToCaml.index i)) p1) p2 in - hash - - - let hash_pair h1 h2 h (e1,e2) = - h2 (h1 h e1) e2 - - let hash_elt f h e = combine h (f e) - - let hash_string h (e:string) = hash_elt Hashtbl.hash h e - - let hash_z = hash_elt CoqToCaml.z - - let hash_q = hash_elt (fun q -> Hashtbl.hash (CoqToCaml.q_to_num q)) - - end - - - +module Hash = struct + module Mc = Micromega + open Hashset.Combine + + let int_of_eq_op1 = + Mc.(function Equal -> 0 | NonEqual -> 1 | Strict -> 2 | NonStrict -> 3) + + let eq_op1 o1 o2 = int_of_eq_op1 o1 = int_of_eq_op1 o2 + let hash_op1 h o = combine h (int_of_eq_op1 o) + + let rec eq_positive p1 p2 = + match (p1, p2) with + | Mc.XH, Mc.XH -> true + | Mc.XI p1, Mc.XI p2 -> eq_positive p1 p2 + | Mc.XO p1, Mc.XO p2 -> eq_positive p1 p2 + | _, _ -> false + + let eq_z z1 z2 = + match (z1, z2) with + | Mc.Z0, Mc.Z0 -> true + | Mc.Zpos p1, Mc.Zpos p2 | Mc.Zneg p1, Mc.Zneg p2 -> eq_positive p1 p2 + | _, _ -> false + + let eq_q {Mc.qnum = qn1; Mc.qden = qd1} {Mc.qnum = qn2; Mc.qden = qd2} = + eq_z qn1 qn2 && eq_positive qd1 qd2 + + let rec eq_pol eq p1 p2 = + match (p1, p2) with + | Mc.Pc c1, Mc.Pc c2 -> eq c1 c2 + | Mc.Pinj (i1, p1), Mc.Pinj (i2, p2) -> eq_positive i1 i2 && eq_pol eq p1 p2 + | Mc.PX (p1, i1, p1'), Mc.PX (p2, i2, p2') -> + eq_pol eq p1 p2 && eq_positive i1 i2 && eq_pol eq p1' p2' + | _, _ -> false + + let eq_pair eq1 eq2 (x1, y1) (x2, y2) = eq1 x1 x2 && eq2 y1 y2 + + let hash_pol helt = + let rec hash acc = function + | Mc.Pc c -> helt (combine acc 1) c + | Mc.Pinj (p, c) -> hash (combine (combine acc 1) (CoqToCaml.index p)) c + | Mc.PX (p1, i, p2) -> + hash (hash (combine (combine acc 2) (CoqToCaml.index i)) p1) p2 + in + hash + + let hash_pair h1 h2 h (e1, e2) = h2 (h1 h e1) e2 + let hash_elt f h e = combine h (f e) + let hash_string h (e : string) = hash_elt Hashtbl.hash h e + let hash_z = hash_elt CoqToCaml.z + let hash_q = hash_elt (fun q -> Hashtbl.hash (CoqToCaml.q_to_num q)) +end (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index 9692bc631b..ef8d154b13 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -8,51 +8,50 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -module Int : sig type t = int val compare : int -> int -> int val equal : int -> int -> bool end +module Int : sig + type t = int + val compare : int -> int -> int + val equal : int -> int -> bool +end module ISet : sig include Set.S with type elt = int + val pp : out_channel -> t -> unit end -module IMap : -sig +module IMap : sig include Map.S with type key = int - (** [from k m] returns the submap of [m] with keys greater or equal k *) val from : key -> 'elt t -> 'elt t - + (** [from k m] returns the submap of [m] with keys greater or equal k *) end val numerator : Num.num -> Big_int.big_int val denominator : Num.num -> Big_int.big_int module Cmp : sig - val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int val compare_lexical : (unit -> int) list -> int - end module Tag : sig - type t val pp : out_channel -> t -> unit val next : t -> t - val max : t -> t -> t + val max : t -> t -> t val from : int -> t val to_int : t -> int - end module TagSet : CSig.SetS with type elt = Tag.t -val pp_list : string -> (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit +val pp_list : + string -> (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit module CamlToCoq : sig - val positive : int -> Micromega.positive val bigint : Big_int.big_int -> Micromega.z val n : int -> Micromega.n @@ -61,74 +60,62 @@ module CamlToCoq : sig val index : int -> Micromega.positive val z : int -> Micromega.z val positive_big_int : Big_int.big_int -> Micromega.positive - end module CoqToCaml : sig - val z_big_int : Micromega.z -> Big_int.big_int - val z : Micromega.z -> int - val q_to_num : Micromega.q -> Num.num - val positive : Micromega.positive -> int - val n : Micromega.n -> int - val nat : Micromega.nat -> int - val index : Micromega.positive -> int - + val z : Micromega.z -> int + val q_to_num : Micromega.q -> Num.num + val positive : Micromega.positive -> int + val n : Micromega.n -> int + val nat : Micromega.nat -> int + val index : Micromega.positive -> int end module Hash : sig - - val eq_op1 : Micromega.op1 -> Micromega.op1 -> bool - + val eq_op1 : Micromega.op1 -> Micromega.op1 -> bool val eq_positive : Micromega.positive -> Micromega.positive -> bool - val eq_z : Micromega.z -> Micromega.z -> bool - val eq_q : Micromega.q -> Micromega.q -> bool - val eq_pol : ('a -> 'a -> bool) -> 'a Micromega.pol -> 'a Micromega.pol -> bool + val eq_pol : + ('a -> 'a -> bool) -> 'a Micromega.pol -> 'a Micromega.pol -> bool - val eq_pair : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> 'a * 'b -> 'a * 'b -> bool + val eq_pair : + ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> 'a * 'b -> 'a * 'b -> bool val hash_op1 : int -> Micromega.op1 -> int + val hash_pol : (int -> 'a -> int) -> int -> 'a Micromega.pol -> int - val hash_pol : (int -> 'a -> int) -> int -> 'a Micromega.pol -> int - - val hash_pair : (int -> 'a -> int) -> (int -> 'b -> int) -> int -> 'a * 'b -> int - - val hash_z : int -> Micromega.z -> int - - val hash_q : int -> Micromega.q -> int + val hash_pair : + (int -> 'a -> int) -> (int -> 'b -> int) -> int -> 'a * 'b -> int + val hash_z : int -> Micromega.z -> int + val hash_q : int -> Micromega.q -> int val hash_string : int -> string -> int - val hash_elt : ('a -> int) -> int -> 'a -> int - end - val ppcm : Big_int.big_int -> Big_int.big_int -> Big_int.big_int - val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list val try_any : (('a -> 'b option) * 'c) list -> 'a -> 'b option val is_sublist : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val extract : ('a -> 'b option) -> 'a list -> ('b * 'a) option * 'a list - val extract_all : ('a -> 'b option) -> 'a list -> ('b * 'a) list * 'a list -val extract_best : ('a -> 'b option) -> ('b -> 'b -> bool) -> 'a list -> ('b *'a) option * 'a list - -val find_some : ('a -> 'b option) -> 'a list -> 'b option +val extract_best : + ('a -> 'b option) + -> ('b -> 'b -> bool) + -> 'a list + -> ('b * 'a) option * 'a list +val find_some : ('a -> 'b option) -> 'a list -> 'b option val iterate_until_stable : ('a -> 'a option) -> 'a -> 'a - val simplify : ('a -> 'a option) -> 'a list -> 'a list option -val saturate : ('a -> 'b option) -> ('b * 'a -> 'a -> 'a option) -> 'a list -> 'a list +val saturate : + ('a -> 'b option) -> ('b * 'a -> 'a -> 'a option) -> 'a list -> 'a list val generate : ('a -> 'b option) -> 'a list -> 'b list - val app_funs : ('a -> 'b option) list -> 'a -> 'b option - val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 28d8d5a020..d5b28cb03e 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -14,207 +14,158 @@ (* *) (************************************************************************) -module type PHashtable = - sig - (* see documentation in [persistent_cache.mli] *) - type 'a t - type key - - val open_in : string -> 'a t - - val find : 'a t -> key -> 'a - - val add : 'a t -> key -> 'a -> unit - - val memo : string -> (key -> 'a) -> (key -> 'a) - - val memo_cond : string -> (key -> bool) -> (key -> 'a) -> (key -> 'a) - - end +module type PHashtable = sig + (* see documentation in [persistent_cache.mli] *) + type 'a t + type key + + val open_in : string -> 'a t + val find : 'a t -> key -> 'a + val add : 'a t -> key -> 'a -> unit + val memo : string -> (key -> 'a) -> key -> 'a + val memo_cond : string -> (key -> bool) -> (key -> 'a) -> key -> 'a +end open Hashtbl -module PHashtable(Key:HashedType) : PHashtable with type key = Key.t = -struct +module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct open Unix type key = Key.t - module Table = Hashtbl.Make(Key) + module Table = Hashtbl.Make (Key) exception InvalidTableFormat exception UnboundTable type mode = Closed | Open + type 'a t = {outch : out_channel; mutable status : mode; htbl : 'a Table.t} - type 'a t = - { - outch : out_channel ; - mutable status : mode ; - htbl : 'a Table.t - } - - -let finally f rst = - try - let res = f () in - rst () ; res - with reraise -> - (try rst () - with any -> raise reraise - ); raise reraise - - -let read_key_elem inch = - try - Some (Marshal.from_channel inch) - with + let finally f rst = + try + let res = f () in + rst (); res + with reraise -> + (try rst () with any -> raise reraise); + raise reraise + + let read_key_elem inch = + try Some (Marshal.from_channel inch) with | End_of_file -> None | e when CErrors.noncritical e -> raise InvalidTableFormat -(** + (** We used to only lock/unlock regions. Is-it more robust/portable to lock/unlock a fixed region e.g. [0;1]? In case of locking failure, the cache is not used. **) -type lock_kind = Read | Write - -let lock kd fd = - let pos = lseek fd 0 SEEK_CUR in - let success = - try - ignore (lseek fd 0 SEEK_SET); - let lk = match kd with - | Read -> F_RLOCK - | Write -> F_LOCK in - lockf fd lk 1; true - with Unix.Unix_error(_,_,_) -> false in - ignore (lseek fd pos SEEK_SET) ; - success - -let unlock fd = - let pos = lseek fd 0 SEEK_CUR in - try - ignore (lseek fd 0 SEEK_SET) ; - lockf fd F_ULOCK 1 - with - Unix.Unix_error(_,_,_) -> () - (* Here, this is really bad news -- + type lock_kind = Read | Write + + let lock kd fd = + let pos = lseek fd 0 SEEK_CUR in + let success = + try + ignore (lseek fd 0 SEEK_SET); + let lk = match kd with Read -> F_RLOCK | Write -> F_LOCK in + lockf fd lk 1; true + with Unix.Unix_error (_, _, _) -> false + in + ignore (lseek fd pos SEEK_SET); + success + + let unlock fd = + let pos = lseek fd 0 SEEK_CUR in + try + ignore (lseek fd 0 SEEK_SET); + lockf fd F_ULOCK 1 + with Unix.Unix_error (_, _, _) -> + () + (* Here, this is really bad news -- there is a pending lock which could cause a deadlock. Should it be an anomaly or produce a warning ? *); - ignore (lseek fd pos SEEK_SET) - - -(* We make the assumption that an acquired lock can always be released *) + ignore (lseek fd pos SEEK_SET) -let do_under_lock kd fd f = - if lock kd fd - then - finally f (fun () -> unlock fd) - else f () + (* We make the assumption that an acquired lock can always be released *) + let do_under_lock kd fd f = + if lock kd fd then finally f (fun () -> unlock fd) else f () - -let open_in f = - let flags = [O_RDONLY ; O_CREAT] in - let finch = openfile f flags 0o666 in - let inch = in_channel_of_descr finch in - let htbl = Table.create 100 in - - let rec xload () = - match read_key_elem inch with + let open_in f = + let flags = [O_RDONLY; O_CREAT] in + let finch = openfile f flags 0o666 in + let inch = in_channel_of_descr finch in + let htbl = Table.create 100 in + let rec xload () = + match read_key_elem inch with | None -> () - | Some (key,elem) -> - Table.add htbl key elem ; - xload () in + | Some (key, elem) -> Table.add htbl key elem; xload () + in try (* Locking of the (whole) file while reading *) - do_under_lock Read finch xload ; - close_in_noerr inch ; - { - outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ; - status = Open ; - htbl = htbl - } + do_under_lock Read finch xload; + close_in_noerr inch; + { outch = + out_channel_of_descr (openfile f [O_WRONLY; O_APPEND; O_CREAT] 0o666) + ; status = Open + ; htbl } with InvalidTableFormat -> - (* The file is corrupted *) - begin - close_in_noerr inch ; - let flags = [O_WRONLY; O_TRUNC;O_CREAT] in - let out = (openfile f flags 0o666) in + (* The file is corrupted *) + close_in_noerr inch; + let flags = [O_WRONLY; O_TRUNC; O_CREAT] in + let out = openfile f flags 0o666 in let outch = out_channel_of_descr out in - do_under_lock Write out - (fun () -> - Table.iter - (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; - flush outch) ; - { outch = outch ; - status = Open ; - htbl = htbl - } - end - - -let add t k e = - let {outch = outch ; status = status ; htbl = tbl} = t in - if status == Closed - then raise UnboundTable + do_under_lock Write out (fun () -> + Table.iter + (fun k e -> Marshal.to_channel outch (k, e) [Marshal.No_sharing]) + htbl; + flush outch); + {outch; status = Open; htbl} + + let add t k e = + let {outch; status; htbl = tbl} = t in + if status == Closed then raise UnboundTable else let fd = descr_of_out_channel outch in - begin - Table.add tbl k e ; - do_under_lock Write fd - (fun _ -> - Marshal.to_channel outch (k,e) [Marshal.No_sharing] ; - flush outch - ) - end - -let find t k = - let {outch = outch ; status = status ; htbl = tbl} = t in - if status == Closed - then raise UnboundTable + Table.add tbl k e; + do_under_lock Write fd (fun _ -> + Marshal.to_channel outch (k, e) [Marshal.No_sharing]; + flush outch) + + let find t k = + let {outch; status; htbl = tbl} = t in + if status == Closed then raise UnboundTable else let res = Table.find tbl k in - res - -let memo cache f = - let tbl = lazy (try Some (open_in cache) with _ -> None) in - fun x -> - match Lazy.force tbl with - | None -> f x - | Some tbl -> - try - find tbl x - with - Not_found -> - let res = f x in - add tbl x res ; - res - -let memo_cond cache cond f = - let tbl = lazy (try Some (open_in cache) with _ -> None) in - fun x -> - match Lazy.force tbl with - | None -> f x - | Some tbl -> - if cond x - then - begin - try find tbl x - with Not_found -> - let res = f x in - add tbl x res ; - res - end - else f x - - + res + + let memo cache f = + let tbl = lazy (try Some (open_in cache) with _ -> None) in + fun x -> + match Lazy.force tbl with + | None -> f x + | Some tbl -> ( + try find tbl x + with Not_found -> + let res = f x in + add tbl x res; res ) + + let memo_cond cache cond f = + let tbl = lazy (try Some (open_in cache) with _ -> None) in + fun x -> + match Lazy.force tbl with + | None -> f x + | Some tbl -> + if cond x then begin + try find tbl x + with Not_found -> + let res = f x in + add tbl x res; res + end + else f x end - (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/persistent_cache.mli b/plugins/micromega/persistent_cache.mli index cb14d73972..7d459a66e7 100644 --- a/plugins/micromega/persistent_cache.mli +++ b/plugins/micromega/persistent_cache.mli @@ -10,32 +10,29 @@ open Hashtbl -module type PHashtable = - sig - type 'a t - type key +module type PHashtable = sig + type 'a t + type key - val open_in : string -> 'a t - (** [open_in f] rebuilds a table from the records stored in file [f]. + val open_in : string -> 'a t + (** [open_in f] rebuilds a table from the records stored in file [f]. As marshaling is not type-safe, it might segfault. *) - val find : 'a t -> key -> 'a - (** find has the specification of Hashtable.find *) + val find : 'a t -> key -> 'a + (** find has the specification of Hashtable.find *) - val add : 'a t -> key -> 'a -> unit - (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. + val add : 'a t -> key -> 'a -> unit + (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. (and writes the binding to the file associated with [tbl].) If [key] is already bound, raises KeyAlreadyBound *) - val memo : string -> (key -> 'a) -> (key -> 'a) - (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. + val memo : string -> (key -> 'a) -> key -> 'a + (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. Note that the cache will only be loaded when the function is used for the first time *) - val memo_cond : string -> (key -> bool) -> (key -> 'a) -> (key -> 'a) - (** [memo cache cond f] only use the cache if [cond k] holds for the key [k]. *) + val memo_cond : string -> (key -> bool) -> (key -> 'a) -> key -> 'a + (** [memo cache cond f] only use the cache if [cond k] holds for the key [k]. *) +end - - end - -module PHashtable(Key:HashedType) : PHashtable with type key = Key.t +module PHashtable (Key : HashedType) : PHashtable with type key = Key.t diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 1a31a36732..a4f9b60b14 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -15,9 +15,7 @@ (************************************************************************) open Num -module Utils = Mutils -open Utils - +open Mutils module Mc = Micromega let max_nb_cstr = ref max_int @@ -25,165 +23,153 @@ let max_nb_cstr = ref max_int type var = int let debug = false +let ( <+> ) = add_num +let ( <*> ) = mult_num -let (<+>) = add_num -let (<*>) = mult_num - -module Monomial : -sig +module Monomial : sig type t + val const : t val is_const : t -> bool val var : var -> t val is_var : t -> bool val get_var : t -> var option val prod : t -> t -> t - val exp : t -> int -> t - val div : t -> t -> t * int + val exp : t -> int -> t + val div : t -> t -> t * int val compare : t -> t -> int val pp : out_channel -> t -> unit val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a val sqrt : t -> t option val variables : t -> ISet.t -end - = struct + val degree : t -> int +end = struct (* A monomial is represented by a multiset of variables *) - module Map = Map.Make(Int) + module Map = Map.Make (Int) open Map type t = int Map.t + let degree m = Map.fold (fun _ i d -> i + d) m 0 + let is_singleton m = try - let (k,v) = choose m in - let (l,e,r) = split k m in - if is_empty l && is_empty r - then Some(k,v) else None + let k, v = choose m in + let l, e, r = split k m in + if is_empty l && is_empty r then Some (k, v) else None with Not_found -> None let pp o m = - let pp_elt o (k,v)= - if v = 1 then Printf.fprintf o "x%i" k - else Printf.fprintf o "x%i^%i" k v in - + let pp_elt o (k, v) = + if v = 1 then Printf.fprintf o "x%i" k else Printf.fprintf o "x%i^%i" k v + in let rec pp_list o l = match l with - [] -> () + | [] -> () | [e] -> pp_elt o e - | e::l -> Printf.fprintf o "%a*%a" pp_elt e pp_list l in - - pp_list o (Map.bindings m) - - + | e :: l -> Printf.fprintf o "%a*%a" pp_elt e pp_list l + in + pp_list o (Map.bindings m) (* The monomial that corresponds to a constant *) let const = Map.empty - let sum_degree m = Map.fold (fun _ n s -> s + n) m 0 (* Total ordering of monomials *) - let compare: t -> t -> int = - fun m1 m2 -> - let s1 = sum_degree m1 - and s2 = sum_degree m2 in - if Int.equal s1 s2 then Map.compare Int.compare m1 m2 - else Int.compare s1 s2 + let compare : t -> t -> int = + fun m1 m2 -> + let s1 = sum_degree m1 and s2 = sum_degree m2 in + if Int.equal s1 s2 then Map.compare Int.compare m1 m2 else Int.compare s1 s2 - let is_const m = (m = Map.empty) + let is_const m = m = Map.empty (* The monomial 'x' *) let var x = Map.add x 1 Map.empty let is_var m = - match is_singleton m with - | None -> false - | Some (_,i) -> i = 1 + match is_singleton m with None -> false | Some (_, i) -> i = 1 let get_var m = match is_singleton m with | None -> None - | Some (k,i) -> if i = 1 then Some k else None - + | Some (k, i) -> if i = 1 then Some k else None let sqrt m = if is_const m then None else try - Some (Map.fold (fun v i acc -> - let i' = i / 2 in - if i mod 2 = 0 - then add v i' acc - else raise Not_found) m const) + Some + (Map.fold + (fun v i acc -> + let i' = i / 2 in + if i mod 2 = 0 then add v i' acc else raise Not_found) + m const) with Not_found -> None - (* Get the degre of a variable in a monomial *) let find x m = try find x m with Not_found -> 0 (* Product of monomials *) - let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 + let prod m1 m2 = Map.fold (fun k d m -> add k (find k m + d) m) m1 m2 let exp m n = - let rec exp acc n = - if n = 0 then acc - else exp (prod acc m) (n - 1) in - + let rec exp acc n = if n = 0 then acc else exp (prod acc m) (n - 1) in exp const n (* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *) let div m1 m2 = - let n = fold (fun x i n -> let i' = find x m1 in - let nx = i' / i in - min n nx) m2 max_int in - - let mr = fold (fun x i' m -> - let i = find x m2 in - let ir = i' - i * n in - if ir = 0 then m - else add x ir m) m1 empty in - (mr,n) - + let n = + fold + (fun x i n -> + let i' = find x m1 in + let nx = i' / i in + min n nx) + m2 max_int + in + let mr = + fold + (fun x i' m -> + let i = find x m2 in + let ir = i' - (i * n) in + if ir = 0 then m else add x ir m) + m1 empty + in + (mr, n) let variables m = fold (fun v i acc -> ISet.add v acc) m ISet.empty - let fold = fold - end -module MonMap = - struct - include Map.Make(Monomial) +module MonMap = struct + include Map.Make (Monomial) - let union f = merge - (fun x v1 v2 -> - match v1 , v2 with - | None , None -> None - | Some v , None | None , Some v -> Some v - | Some v1 , Some v2 -> f x v1 v2) - end + let union f = + merge (fun x v1 v2 -> + match (v1, v2) with + | None, None -> None + | Some v, None | None, Some v -> Some v + | Some v1, Some v2 -> f x v1 v2) +end let pp_mon o (m, i) = - if Monomial.is_const m - then if eq_num (Int 0) i then () - else Printf.fprintf o "%s" (string_of_num i) + if Monomial.is_const m then + if eq_num (Int 0) i then () else Printf.fprintf o "%s" (string_of_num i) else match i with - | Int 1 -> Monomial.pp o m + | Int 1 -> Monomial.pp o m | Int -1 -> Printf.fprintf o "-%a" Monomial.pp m - | Int 0 -> () - | _ -> Printf.fprintf o "%s*%a" (string_of_num i) Monomial.pp m - + | Int 0 -> () + | _ -> Printf.fprintf o "%s*%a" (string_of_num i) Monomial.pp m - -module Poly : -(* A polynomial is a map of monomials *) -(* +module Poly : (* A polynomial is a map of monomials *) + (* This is probably a naive implementation (expected to be fast enough - Coq is probably the bottleneck) *The new ring contribution is using a sparse Horner representation. *) sig type t + val pp : out_channel -> t -> unit val get : Monomial.t -> t -> num val variable : var -> t @@ -193,42 +179,34 @@ sig val addition : t -> t -> t val uminus : t -> t val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a - val factorise : var -> t -> t * t -end = struct + val factorise : var -> t -> t * t +end = struct (*normalisation bug : 0*x ... *) - module P = Map.Make(Monomial) + module P = Map.Make (Monomial) open P type t = num P.t - - let pp o p = P.iter (fun mn i -> Printf.fprintf o "%a + " pp_mon (mn, i)) p - + let pp o p = P.iter (fun mn i -> Printf.fprintf o "%a + " pp_mon (mn, i)) p (* Get the coefficient of monomial mn *) let get : Monomial.t -> t -> num = - fun mn p -> try find mn p with Not_found -> (Int 0) - + fun mn p -> try find mn p with Not_found -> Int 0 (* The polynomial 1.x *) - let variable : var -> t = - fun x -> add (Monomial.var x) (Int 1) empty + let variable : var -> t = fun x -> add (Monomial.var x) (Int 1) empty (*The constant polynomial *) - let constant : num -> t = - fun c -> add (Monomial.const) c empty + let constant : num -> t = fun c -> add Monomial.const c empty (* The addition of a monomial *) let add : Monomial.t -> num -> t -> t = - fun mn v p -> + fun mn v p -> if sign_num v = 0 then p else - let vl = (get mn p) <+> v in - if sign_num vl = 0 then - remove mn p - else add mn vl p - + let vl = get mn p <+> v in + if sign_num vl = 0 then remove mn p else add mn vl p (** Design choice: empty is not a polynomial I do not remember why .... @@ -236,76 +214,56 @@ end = struct (* The product by a monomial *) let mult : Monomial.t -> num -> t -> t = - fun mn v p -> - if sign_num v = 0 - then constant (Int 0) + fun mn v p -> + if sign_num v = 0 then constant (Int 0) else - fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty - - - let addition : t -> t -> t = - fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 + fold + (fun mn' v' res -> P.add (Monomial.prod mn mn') (v <*> v') res) + p empty + let addition : t -> t -> t = + fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 let product : t -> t -> t = - fun p1 p2 -> - fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty - - - let uminus : t -> t = - fun p -> map (fun v -> minus_num v) p + fun p1 p2 -> fold (fun mn v res -> addition (mult mn v p2) res) p1 empty + let uminus : t -> t = fun p -> map (fun v -> minus_num v) p let fold = P.fold let factorise x p = let x = Monomial.var x in - P.fold (fun m v (px,cx) -> - let (m1,i) = Monomial.div m x in - if i = 0 - then (px, add m v cx) + P.fold + (fun m v (px, cx) -> + let m1, i = Monomial.div m x in + if i = 0 then (px, add m v cx) else - let mx = Monomial.prod m1 (Monomial.exp x (i-1)) in - (add mx v px,cx) ) p (constant (Int 0) , constant (Int 0)) - + let mx = Monomial.prod m1 (Monomial.exp x (i - 1)) in + (add mx v px, cx)) + p + (constant (Int 0), constant (Int 0)) end - - type vector = Vect.t -type cstr = {coeffs : vector ; op : op ; cst : num} -and op = |Eq | Ge | Gt - -exception Strict +type cstr = {coeffs : vector; op : op; cst : num} -let is_strict c = (=) c.op Gt - -let eval_op = function - | Eq -> (=/) - | Ge -> (>=/) - | Gt -> (>/) +and op = Eq | Ge | Gt +exception Strict +let is_strict c = c.op = Gt +let eval_op = function Eq -> ( =/ ) | Ge -> ( >=/ ) | Gt -> ( >/ ) let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" -let output_cstr o { coeffs ; op ; cst } = - Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op) (string_of_num cst) - +let output_cstr o {coeffs; op; cst} = + Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op) + (string_of_num cst) let opMult o1 o2 = - match o1, o2 with - | Eq , _ | _ , Eq -> Eq - | Ge , _ | _ , Ge -> Ge - | Gt , Gt -> Gt + match (o1, o2) with Eq, _ | _, Eq -> Eq | Ge, _ | _, Ge -> Ge | Gt, Gt -> Gt let opAdd o1 o2 = - match o1, o2 with - | Eq , x | x , Eq -> x - | Gt , x | x , Gt -> Gt - | Ge , Ge -> Ge - - - + match (o1, o2) with Eq, x | x, Eq -> x | Gt, x | x, Gt -> Gt | Ge, Ge -> Ge module LinPoly = struct (** A linear polynomial a0 + a1.x1 + ... + an.xn @@ -314,36 +272,40 @@ module LinPoly = struct type t = Vect.t - module MonT = struct - module MonoMap = Map.Make(Monomial) - module IntMap = Map.Make(Int) + module MonT = struct + module MonoMap = Map.Make (Monomial) + module IntMap = Map.Make (Int) (** A hash table might be preferable but requires a hash function. *) - let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty) - let (monomial_of_index : Monomial.t IntMap.t ref) = ref (IntMap.empty) + let (index_of_monomial : int MonoMap.t ref) = ref MonoMap.empty + + let (monomial_of_index : Monomial.t IntMap.t ref) = ref IntMap.empty let fresh = ref 0 - let clear () = - index_of_monomial := MonoMap.empty; - monomial_of_index := IntMap.empty ; - fresh := 0 + let reserve vr = + if !fresh > vr then failwith (Printf.sprintf "Cannot reserve %i" vr) + else fresh := vr + 1 + let get_fresh () = !fresh let register m = - try - MonoMap.find m !index_of_monomial + try MonoMap.find m !index_of_monomial with Not_found -> - begin - let res = !fresh in - index_of_monomial := MonoMap.add m res !index_of_monomial ; - monomial_of_index := IntMap.add res m !monomial_of_index ; - incr fresh ; res - end + let res = !fresh in + index_of_monomial := MonoMap.add m res !index_of_monomial; + monomial_of_index := IntMap.add res m !monomial_of_index; + incr fresh; + res let retrieve i = IntMap.find i !monomial_of_index - let _ = register Monomial.const + let clear () = + index_of_monomial := MonoMap.empty; + monomial_of_index := IntMap.empty; + fresh := 0; + ignore (register Monomial.const) + let _ = register Monomial.const end let var v = Vect.set (MonT.register (Monomial.var v)) (Int 1) Vect.null @@ -353,126 +315,127 @@ module LinPoly = struct Vect.set v (Int 1) Vect.null let linpol_of_pol p = - Poly.fold - (fun mon num vct -> - let vr = MonT.register mon in - Vect.set vr num vct) p Vect.null + Poly.fold + (fun mon num vct -> + let vr = MonT.register mon in + Vect.set vr num vct) + p Vect.null let pol_of_linpol v = - Vect.fold (fun p vr n -> Poly.add (MonT.retrieve vr) n p) (Poly.constant (Int 0)) v - - let coq_poly_of_linpol cst p = + Vect.fold + (fun p vr n -> Poly.add (MonT.retrieve vr) n p) + (Poly.constant (Int 0)) v + let coq_poly_of_linpol cst p = let pol_of_mon m = - Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(CamlToCoq.positive x),CamlToCoq.n v),p)) m (Mc.PEc (cst (Int 1))) in - - Vect.fold (fun acc x v -> + Monomial.fold + (fun x v p -> + Mc.PEmul (Mc.PEpow (Mc.PEX (CamlToCoq.positive x), CamlToCoq.n v), p)) + m + (Mc.PEc (cst (Int 1))) + in + Vect.fold + (fun acc x v -> let mn = MonT.retrieve x in - Mc.PEadd(Mc.PEmul(Mc.PEc (cst v), pol_of_mon mn),acc)) (Mc.PEc (cst (Int 0))) p + Mc.PEadd (Mc.PEmul (Mc.PEc (cst v), pol_of_mon mn), acc)) + (Mc.PEc (cst (Int 0))) + p let pp_var o vr = - try - Monomial.pp o (MonT.retrieve vr) (* this is a non-linear variable *) - with Not_found -> Printf.fprintf o "v%i" vr - - - let pp o p = Vect.pp_gen pp_var o p - - - let constant c = - if sign_num c = 0 - then Vect.null - else Vect.set 0 c Vect.null + try Monomial.pp o (MonT.retrieve vr) (* this is a non-linear variable *) + with Not_found -> Printf.fprintf o "v%i" vr + let pp o p = Vect.pp_gen pp_var o p + let constant c = if sign_num c = 0 then Vect.null else Vect.set 0 c Vect.null let is_linear p = - Vect.for_all (fun v _ -> - let mn = (MonT.retrieve v) in - Monomial.is_var mn || Monomial.is_const mn) p + Vect.for_all + (fun v _ -> + let mn = MonT.retrieve v in + Monomial.is_var mn || Monomial.is_const mn) + p let is_variable p = - let ((x,v),r) = Vect.decomp_fst p in - if Vect.is_null r && v >/ Int 0 - then Monomial.get_var (MonT.retrieve x) + let (x, v), r = Vect.decomp_fst p in + if Vect.is_null r && v >/ Int 0 then Monomial.get_var (MonT.retrieve x) else None - let factorise x p = - let (px,cx) = Poly.factorise x (pol_of_linpol p) in + let px, cx = Poly.factorise x (pol_of_linpol p) in (linpol_of_pol px, linpol_of_pol cx) - let is_linear_for x p = - let (a,b) = factorise x p in + let a, b = factorise x p in Vect.is_constant a let search_all_linear p l = - Vect.fold (fun acc x v -> - if p v - then + Vect.fold + (fun acc x v -> + if p v then let x' = MonT.retrieve x in match Monomial.get_var x' with | None -> acc - | Some x -> - if is_linear_for x l - then x::acc - else acc - else acc) [] l + | Some x -> if is_linear_for x l then x :: acc else acc + else acc) + [] l - let min_list (l:int list) = - match l with - | [] -> None - | e::l -> Some (List.fold_left min e l) - - let search_linear p l = - min_list (search_all_linear p l) + let min_list (l : int list) = + match l with [] -> None | e :: l -> Some (List.fold_left min e l) + let search_linear p l = min_list (search_all_linear p l) let product p1 p2 = linpol_of_pol (Poly.product (pol_of_linpol p1) (pol_of_linpol p2)) let addition p1 p2 = Vect.add p1 p2 - let of_vect v = - Vect.fold (fun acc v vl -> addition (product (var v) (constant vl)) acc) Vect.null v - - let variables p = Vect.fold - (fun acc v _ -> - ISet.union (Monomial.variables (MonT.retrieve v)) acc) ISet.empty p - - - let pp_goal typ o l = - let vars = List.fold_left (fun acc p -> ISet.union acc (variables (fst p))) ISet.empty l in - let pp_vars o i = ISet.iter (fun v -> Printf.fprintf o "(x%i : %s) " v typ) vars in - - Printf.fprintf o "forall %a\n" pp_vars vars ; - List.iteri (fun i (p,op) -> Printf.fprintf o "(H%i : %a %s 0)\n" i pp p (string_of_op op)) l; + Vect.fold + (fun acc v vl -> addition (product (var v) (constant vl)) acc) + Vect.null v + + let variables p = + Vect.fold + (fun acc v _ -> ISet.union (Monomial.variables (MonT.retrieve v)) acc) + ISet.empty p + + let monomials p = Vect.fold (fun acc v _ -> ISet.add v acc) ISet.empty p + + let degree v = + Vect.fold (fun acc v vl -> max acc (Monomial.degree (MonT.retrieve v))) 0 v + + let pp_goal typ o l = + let vars = + List.fold_left + (fun acc p -> ISet.union acc (variables (fst p))) + ISet.empty l + in + let pp_vars o i = + ISet.iter (fun v -> Printf.fprintf o "(x%i : %s) " v typ) vars + in + Printf.fprintf o "forall %a\n" pp_vars vars; + List.iteri + (fun i (p, op) -> + Printf.fprintf o "(H%i : %a %s 0)\n" i pp p (string_of_op op)) + l; Printf.fprintf o ", False\n" - - - - - let collect_square p = - Vect.fold (fun acc v _ -> - let m = (MonT.retrieve v) in - match Monomial.sqrt m with - | None -> acc - | Some s -> MonMap.add s m acc - ) MonMap.empty p - - + let collect_square p = + Vect.fold + (fun acc v _ -> + let m = MonT.retrieve v in + match Monomial.sqrt m with None -> acc | Some s -> MonMap.add s m acc) + MonMap.empty p end -module ProofFormat = struct +module ProofFormat = struct open Big_int type prf_rule = | Annot of string * prf_rule | Hyp of int | Def of int - | Cst of Num.num + | Cst of Num.num | Zero | Square of Vect.t | MulC of Vect.t * prf_rule @@ -485,265 +448,279 @@ module ProofFormat = struct | Done | Step of int * prf_rule * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list + | ExProof of int * int * int * var * var * var * proof + (* x = z - t, z >= 0, t >= 0 *) let rec output_prf_rule o = function - | Annot(s,p) -> Printf.fprintf o "(%a)@%s" output_prf_rule p s + | Annot (s, p) -> Printf.fprintf o "(%a)@%s" output_prf_rule p s | Hyp i -> Printf.fprintf o "Hyp %i" i | Def i -> Printf.fprintf o "Def %i" i | Cst c -> Printf.fprintf o "Cst %s" (string_of_num c) - | Zero -> Printf.fprintf o "Zero" + | Zero -> Printf.fprintf o "Zero" | Square s -> Printf.fprintf o "(%a)^2" Poly.pp (LinPoly.pol_of_linpol s) - | MulC(p,pr) -> Printf.fprintf o "(%a) * (%a)" Poly.pp (LinPoly.pol_of_linpol p) output_prf_rule pr - | MulPrf(p1,p2) -> Printf.fprintf o "(%a) * (%a)" output_prf_rule p1 output_prf_rule p2 - | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 - | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p - | Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) + | MulC (p, pr) -> + Printf.fprintf o "(%a) * (%a)" Poly.pp (LinPoly.pol_of_linpol p) + output_prf_rule pr + | MulPrf (p1, p2) -> + Printf.fprintf o "(%a) * (%a)" output_prf_rule p1 output_prf_rule p2 + | AddPrf (p1, p2) -> + Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 + | CutPrf p -> Printf.fprintf o "[%a]" output_prf_rule p + | Gcd (c, p) -> + Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) let rec output_proof o = function | Done -> Printf.fprintf o "." - | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf - | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i - output_prf_rule p1 Vect.pp v output_prf_rule p2 - (pp_list ";" output_proof) pl + | Step (i, p, pf) -> + Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + | Enum (i, p1, v, p2, pl) -> + Printf.fprintf o "%i{%a<=%a<=%a}%a" i output_prf_rule p1 Vect.pp v + output_prf_rule p2 (pp_list ";" output_proof) pl + | ExProof (i, j, k, x, z, t, pr) -> + Printf.fprintf o "%i := %i = %i - %i ; %i := %i >= 0 ; %i := %i >= 0 ; %a" + i x z t j z k t output_proof pr let rec pr_size = function - | Annot(_,p) -> pr_size p - | Zero| Square _ -> Int 0 - | Hyp _ -> Int 1 - | Def _ -> Int 1 - | Cst n -> n - | Gcd(i, p) -> pr_size p // (Big_int i) - | MulPrf(p1,p2) | AddPrf(p1,p2) -> pr_size p1 +/ pr_size p2 - | CutPrf p -> pr_size p - | MulC(v, p) -> pr_size p - + | Annot (_, p) -> pr_size p + | Zero | Square _ -> Int 0 + | Hyp _ -> Int 1 + | Def _ -> Int 1 + | Cst n -> n + | Gcd (i, p) -> pr_size p // Big_int i + | MulPrf (p1, p2) | AddPrf (p1, p2) -> pr_size p1 +/ pr_size p2 + | CutPrf p -> pr_size p + | MulC (v, p) -> pr_size p let rec pr_rule_max_id = function - | Annot(_,p) -> pr_rule_max_id p + | Annot (_, p) -> pr_rule_max_id p | Hyp i | Def i -> i | Cst _ | Zero | Square _ -> -1 - | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p - | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2) + | MulC (_, p) | CutPrf p | Gcd (_, p) -> pr_rule_max_id p + | MulPrf (p1, p2) | AddPrf (p1, p2) -> + max (pr_rule_max_id p1) (pr_rule_max_id p2) let rec proof_max_id = function | Done -> -1 - | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) - | Enum(i,p1,_,p2,l) -> - let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in - List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l - + | Step (i, pr, prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) + | Enum (i, p1, _, p2, l) -> + let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in + List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l + | ExProof (i, j, k, _, _, _, prf) -> + max (max (max i j) k) (proof_max_id prf) let rec pr_rule_def_cut id = function - | Annot(_,p) -> pr_rule_def_cut id p - | MulC(p,prf) -> - let (bds,id',prf') = pr_rule_def_cut id prf in - (bds, id', MulC(p,prf')) - | MulPrf(p1,p2) -> - let (bds1,id,p1) = pr_rule_def_cut id p1 in - let (bds2,id,p2) = pr_rule_def_cut id p2 in - (bds2@bds1,id,MulPrf(p1,p2)) - | AddPrf(p1,p2) -> - let (bds1,id,p1) = pr_rule_def_cut id p1 in - let (bds2,id,p2) = pr_rule_def_cut id p2 in - (bds2@bds1,id,AddPrf(p1,p2)) + | Annot (_, p) -> pr_rule_def_cut id p + | MulC (p, prf) -> + let bds, id', prf' = pr_rule_def_cut id prf in + (bds, id', MulC (p, prf')) + | MulPrf (p1, p2) -> + let bds1, id, p1 = pr_rule_def_cut id p1 in + let bds2, id, p2 = pr_rule_def_cut id p2 in + (bds2 @ bds1, id, MulPrf (p1, p2)) + | AddPrf (p1, p2) -> + let bds1, id, p1 = pr_rule_def_cut id p1 in + let bds2, id, p2 = pr_rule_def_cut id p2 in + (bds2 @ bds1, id, AddPrf (p1, p2)) | CutPrf p -> - let (bds,id,p) = pr_rule_def_cut id p in - ((id,p)::bds,id+1,Def id) - | Gcd(c,p) -> - let (bds,id,p) = pr_rule_def_cut id p in - ((id,p)::bds,id+1,Def id) - | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x) - + let bds, id, p = pr_rule_def_cut id p in + ((id, p) :: bds, id + 1, Def id) + | Gcd (c, p) -> + let bds, id, p = pr_rule_def_cut id p in + ((id, p) :: bds, id + 1, Def id) + | (Square _ | Cst _ | Def _ | Hyp _ | Zero) as x -> ([], id, x) (* Do not define top-level cuts *) let pr_rule_def_cut id = function | CutPrf p -> - let (bds,ids,p') = pr_rule_def_cut id p in - bds,ids, CutPrf p' - | p -> pr_rule_def_cut id p - - - let rec implicit_cut p = - match p with - | CutPrf p -> implicit_cut p - | _ -> p + let bds, ids, p' = pr_rule_def_cut id p in + (bds, ids, CutPrf p') + | p -> pr_rule_def_cut id p + let rec implicit_cut p = match p with CutPrf p -> implicit_cut p | _ -> p let rec pr_rule_collect_hyps pr = match pr with - | Annot(_,pr) -> pr_rule_collect_hyps pr + | Annot (_, pr) -> pr_rule_collect_hyps pr | Hyp i | Def i -> ISet.add i ISet.empty | Cst _ | Zero | Square _ -> ISet.empty - | MulC(_,pr) | Gcd(_,pr)| CutPrf pr -> pr_rule_collect_hyps pr - | MulPrf(p1,p2) | AddPrf(p1,p2) -> ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2) + | MulC (_, pr) | Gcd (_, pr) | CutPrf pr -> pr_rule_collect_hyps pr + | MulPrf (p1, p2) | AddPrf (p1, p2) -> + ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2) - let simplify_proof p = + let simplify_proof p = let rec simplify_proof p = match p with | Done -> (Done, ISet.empty) - | Step(i,pr,Done) -> (p, ISet.add i (pr_rule_collect_hyps pr)) - | Step(i,pr,prf) -> - let (prf',hyps) = simplify_proof prf in - if not (ISet.mem i hyps) - then (prf',hyps) - else - (Step(i,pr,prf'), ISet.add i (ISet.union (pr_rule_collect_hyps pr) hyps)) - | Enum(i,p1,v,p2,pl) -> - let (pl,hl) = List.split (List.map simplify_proof pl) in - let hyps = List.fold_left ISet.union ISet.empty hl in - (Enum(i,p1,v,p2,pl),ISet.add i (ISet.union (ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2)) hyps)) in + | Step (i, pr, Done) -> (p, ISet.add i (pr_rule_collect_hyps pr)) + | Step (i, pr, prf) -> + let prf', hyps = simplify_proof prf in + if not (ISet.mem i hyps) then (prf', hyps) + else + ( Step (i, pr, prf') + , ISet.add i (ISet.union (pr_rule_collect_hyps pr) hyps) ) + | Enum (i, p1, v, p2, pl) -> + let pl, hl = List.split (List.map simplify_proof pl) in + let hyps = List.fold_left ISet.union ISet.empty hl in + ( Enum (i, p1, v, p2, pl) + , ISet.add i + (ISet.union + (ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2)) + hyps) ) + | ExProof (i, j, k, x, z, t, prf) -> + let prf', hyps = simplify_proof prf in + if + (not (ISet.mem i hyps)) + && (not (ISet.mem j hyps)) + && not (ISet.mem k hyps) + then (prf', hyps) + else + ( ExProof (i, j, k, x, z, t, prf') + , ISet.add i (ISet.add j (ISet.add k hyps)) ) + in fst (simplify_proof p) - let rec normalise_proof id prf = match prf with - | Done -> (id,Done) - | Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done)) - | Step(i,p,prf) -> - let bds,id,p' = pr_rule_def_cut id p in - let (id,prf) = normalise_proof id prf in - let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) - (Step(i,p',prf)) bds in - - (id,prf) - | Enum(i,p1,v,p2,pl) -> - (* Why do I have top-level cuts ? *) - (* let p1 = implicit_cut p1 in + | Done -> (id, Done) + | Step (i, Gcd (c, p), Done) -> normalise_proof id (Step (i, p, Done)) + | Step (i, p, prf) -> + let bds, id, p' = pr_rule_def_cut id p in + let id, prf = normalise_proof id prf in + let prf = + List.fold_left + (fun acc (i, p) -> Step (i, CutPrf p, acc)) + (Step (i, p', prf)) + bds + in + (id, prf) + | ExProof (i, j, k, x, z, t, prf) -> + let id, prf = normalise_proof id prf in + (id, ExProof (i, j, k, x, z, t, prf)) + | Enum (i, p1, v, p2, pl) -> + (* Why do I have top-level cuts ? *) + (* let p1 = implicit_cut p1 in let p2 = implicit_cut p2 in let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in (List.fold_left max 0 ids , Enum(i,p1,v,p2,prfs)) *) - - let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in - let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in - let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in - (List.fold_left max 0 ids , - List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) - (Enum(i,p1',v,p2',prfs)) (bds2@bds1)) - + let bds1, id, p1' = pr_rule_def_cut id (implicit_cut p1) in + let bds2, id, p2' = pr_rule_def_cut id (implicit_cut p2) in + let ids, prfs = List.split (List.map (normalise_proof id) pl) in + ( List.fold_left max 0 ids + , List.fold_left + (fun acc (i, p) -> Step (i, CutPrf p, acc)) + (Enum (i, p1', v, p2', prfs)) + (bds2 @ bds1) ) let normalise_proof id prf = let prf = simplify_proof prf in let res = normalise_proof id prf in - if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; + if debug then + Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof + (snd res); res - module OrdPrfRule = - struct - type t = prf_rule - - let id_of_constr = function - | Annot _ -> 0 - | Hyp _ -> 1 - | Def _ -> 2 - | Cst _ -> 3 - | Zero -> 4 - | Square _ -> 5 - | MulC _ -> 6 - | Gcd _ -> 7 - | MulPrf _ -> 8 - | AddPrf _ -> 9 - | CutPrf _ -> 10 - - let cmp_pair c1 c2 (x1,x2) (y1,y2) = - match c1 x1 y1 with - | 0 -> c2 x2 y2 - | i -> i - - - let rec compare p1 p2 = - match p1, p2 with - | Annot(s1,p1) , Annot(s2,p2) -> if s1 = s2 then compare p1 p2 - else Util.pervasives_compare s1 s2 - | Hyp i , Hyp j -> Util.pervasives_compare i j - | Def i , Def j -> Util.pervasives_compare i j - | Cst n , Cst m -> Num.compare_num n m - | Zero , Zero -> 0 - | Square v1 , Square v2 -> Vect.compare v1 v2 - | MulC(v1,p1) , MulC(v2,p2) -> cmp_pair Vect.compare compare (v1,p1) (v2,p2) - | Gcd(b1,p1) , Gcd(b2,p2) -> cmp_pair Big_int.compare_big_int compare (b1,p1) (b2,p2) - | MulPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2) - | AddPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2) - | CutPrf p , CutPrf p' -> compare p p' - | _ , _ -> Util.pervasives_compare (id_of_constr p1) (id_of_constr p2) - - end - - - + module OrdPrfRule = struct + type t = prf_rule + + let id_of_constr = function + | Annot _ -> 0 + | Hyp _ -> 1 + | Def _ -> 2 + | Cst _ -> 3 + | Zero -> 4 + | Square _ -> 5 + | MulC _ -> 6 + | Gcd _ -> 7 + | MulPrf _ -> 8 + | AddPrf _ -> 9 + | CutPrf _ -> 10 + + let cmp_pair c1 c2 (x1, x2) (y1, y2) = + match c1 x1 y1 with 0 -> c2 x2 y2 | i -> i + + let rec compare p1 p2 = + match (p1, p2) with + | Annot (s1, p1), Annot (s2, p2) -> + if s1 = s2 then compare p1 p2 else String.compare s1 s2 + | Hyp i, Hyp j -> Int.compare i j + | Def i, Def j -> Int.compare i j + | Cst n, Cst m -> Num.compare_num n m + | Zero, Zero -> 0 + | Square v1, Square v2 -> Vect.compare v1 v2 + | MulC (v1, p1), MulC (v2, p2) -> + cmp_pair Vect.compare compare (v1, p1) (v2, p2) + | Gcd (b1, p1), Gcd (b2, p2) -> + cmp_pair Big_int.compare_big_int compare (b1, p1) (b2, p2) + | MulPrf (p1, q1), MulPrf (p2, q2) -> + cmp_pair compare compare (p1, q1) (p2, q2) + | AddPrf (p1, q1), MulPrf (p2, q2) -> + cmp_pair compare compare (p1, q1) (p2, q2) + | CutPrf p, CutPrf p' -> compare p p' + | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) + end let add_proof x y = - match x, y with - | Zero , p | p , Zero -> p - | _ -> AddPrf(x,y) - + match (x, y) with Zero, p | p, Zero -> p | _ -> AddPrf (x, y) let rec mul_cst_proof c p = match p with - | Annot(s,p) -> Annot(s,mul_cst_proof c p) - | MulC(v,p') -> MulC(Vect.mul c v,p') - | _ -> - match sign_num c with - | 0 -> Zero (* This is likely to be a bug *) - | -1 -> MulC(LinPoly.constant c, p) (* [p] should represent an equality *) - | 1 -> - if eq_num (Int 1) c - then p - else MulPrf(Cst c,p) - | _ -> assert false - + | Annot (s, p) -> Annot (s, mul_cst_proof c p) + | MulC (v, p') -> MulC (Vect.mul c v, p') + | _ -> ( + match sign_num c with + | 0 -> Zero (* This is likely to be a bug *) + | -1 -> + MulC (LinPoly.constant c, p) (* [p] should represent an equality *) + | 1 -> if eq_num (Int 1) c then p else MulPrf (Cst c, p) + | _ -> assert false ) let sMulC v p = - let (c,v') = Vect.decomp_cst v in - if Vect.is_null v' then mul_cst_proof c p - else MulC(v,p) - + let c, v' = Vect.decomp_cst v in + if Vect.is_null v' then mul_cst_proof c p else MulC (v, p) let mul_proof p1 p2 = - match p1 , p2 with - | Zero , _ | _ , Zero -> Zero - | Cst c , p | p , Cst c -> mul_cst_proof c p - | _ , _ -> - MulPrf(p1,p2) + match (p1, p2) with + | Zero, _ | _, Zero -> Zero + | Cst c, p | p, Cst c -> mul_cst_proof c p + | _, _ -> MulPrf (p1, p2) + module PrfRuleMap = Map.Make (OrdPrfRule) - module PrfRuleMap = Map.Make(OrdPrfRule) + let prf_rule_of_map m = + PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero - let prf_rule_of_map m = - PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero - - - let rec dev_prf_rule p = - match p with - | Annot(s,p) -> dev_prf_rule p - | Hyp _ | Def _ | Cst _ | Zero | Square _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1)) - | MulC(v,p) -> PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) - | AddPrf(p1,p2) -> PrfRuleMap.merge (fun k o1 o2 -> - match o1 , o2 with - | None , None -> None - | None , Some v | Some v, None -> Some v - | Some v1 , Some v2 -> Some (LinPoly.addition v1 v2)) (dev_prf_rule p1) (dev_prf_rule p2) - | MulPrf(p1, p2) -> - begin - let p1' = dev_prf_rule p1 in - let p2' = dev_prf_rule p2 in - - let p1'' = prf_rule_of_map p1' in - let p2'' = prf_rule_of_map p2' in - - match p1'' with - | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' - | _ -> PrfRuleMap.singleton (MulPrf(p1'',p2'')) (LinPoly.constant (Int 1)) - end - | _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1)) - - let simplify_prf_rule p = - prf_rule_of_map (dev_prf_rule p) - - - (* + let rec dev_prf_rule p = + match p with + | Annot (s, p) -> dev_prf_rule p + | Hyp _ | Def _ | Cst _ | Zero | Square _ -> + PrfRuleMap.singleton p (LinPoly.constant (Int 1)) + | MulC (v, p) -> + PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) + | AddPrf (p1, p2) -> + PrfRuleMap.merge + (fun k o1 o2 -> + match (o1, o2) with + | None, None -> None + | None, Some v | Some v, None -> Some v + | Some v1, Some v2 -> Some (LinPoly.addition v1 v2)) + (dev_prf_rule p1) (dev_prf_rule p2) + | MulPrf (p1, p2) -> ( + let p1' = dev_prf_rule p1 in + let p2' = dev_prf_rule p2 in + let p1'' = prf_rule_of_map p1' in + let p2'' = prf_rule_of_map p2' in + match p1'' with + | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' + | _ -> + PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant (Int 1)) ) + | _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1)) + + let simplify_prf_rule p = prf_rule_of_map (dev_prf_rule p) + + (* let mul_proof p1 p2 = let res = mul_proof p1 p2 in Printf.printf "mul_proof %a %a = %a\n" @@ -767,309 +744,291 @@ module ProofFormat = struct *) let proof_of_farkas env vect = - Vect.fold (fun prf x n -> - add_proof (mul_cst_proof n (IMap.find x env)) prf) Zero vect - - - - - module Env = struct + Vect.fold + (fun prf x n -> add_proof (mul_cst_proof n (IMap.find x env)) prf) + Zero vect + module Env = struct let rec string_of_int_list l = match l with | [] -> "" - | i::l -> Printf.sprintf "%i,%s" i (string_of_int_list l) - + | i :: l -> Printf.sprintf "%i,%s" i (string_of_int_list l) let id_of_hyp hyp l = let rec xid_of_hyp i l' = match l' with - | [] -> failwith (Printf.sprintf "id_of_hyp %i %s" hyp (string_of_int_list l)) - | hyp'::l' -> if (=) hyp hyp' then i else xid_of_hyp (i+1) l' in + | [] -> + failwith (Printf.sprintf "id_of_hyp %i %s" hyp (string_of_int_list l)) + | hyp' :: l' -> if hyp = hyp' then i else xid_of_hyp (i + 1) l' + in xid_of_hyp 0 l - end - let cmpl_prf_rule norm (cst:num-> 'a) env prf = - let rec cmpl = - function - | Annot(s,p) -> cmpl p + let cmpl_prf_rule norm (cst : num -> 'a) env prf = + let rec cmpl = function + | Annot (s, p) -> cmpl p | Hyp i | Def i -> Mc.PsatzIn (CamlToCoq.nat (Env.id_of_hyp i env)) - | Cst i -> Mc.PsatzC (cst i) - | Zero -> Mc.PsatzZ - | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl p1, cmpl p2) - | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl p1 , cmpl p2) - | MulC(lp,p) -> let lp = norm (LinPoly.coq_poly_of_linpol cst lp) in - Mc.PsatzMulC(lp,cmpl p) - | Square lp -> Mc.PsatzSquare (norm (LinPoly.coq_poly_of_linpol cst lp)) - | _ -> failwith "Cuts should already be compiled" in + | Cst i -> Mc.PsatzC (cst i) + | Zero -> Mc.PsatzZ + | MulPrf (p1, p2) -> Mc.PsatzMulE (cmpl p1, cmpl p2) + | AddPrf (p1, p2) -> Mc.PsatzAdd (cmpl p1, cmpl p2) + | MulC (lp, p) -> + let lp = norm (LinPoly.coq_poly_of_linpol cst lp) in + Mc.PsatzMulC (lp, cmpl p) + | Square lp -> Mc.PsatzSquare (norm (LinPoly.coq_poly_of_linpol cst lp)) + | _ -> failwith "Cuts should already be compiled" + in cmpl prf + let cmpl_prf_rule_z env r = + cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (numerator x)) env r - - - let cmpl_prf_rule_z env r = cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (numerator x)) env r - - let rec cmpl_proof env = function - | Done -> Mc.DoneProof - | Step(i,p,prf) -> - begin - match p with - | CutPrf p' -> - Mc.CutProof(cmpl_prf_rule_z env p', cmpl_proof (i::env) prf) - | _ -> Mc.RatProof(cmpl_prf_rule_z env p,cmpl_proof (i::env) prf) - end - | Enum(i,p1,_,p2,l) -> - Mc.EnumProof(cmpl_prf_rule_z env p1,cmpl_prf_rule_z env p2,List.map (cmpl_proof (i::env)) l) - + let rec cmpl_proof env = function + | Done -> Mc.DoneProof + | Step (i, p, prf) -> ( + match p with + | CutPrf p' -> + Mc.CutProof (cmpl_prf_rule_z env p', cmpl_proof (i :: env) prf) + | _ -> Mc.RatProof (cmpl_prf_rule_z env p, cmpl_proof (i :: env) prf) ) + | Enum (i, p1, _, p2, l) -> + Mc.EnumProof + ( cmpl_prf_rule_z env p1 + , cmpl_prf_rule_z env p2 + , List.map (cmpl_proof (i :: env)) l ) + | ExProof (i, j, k, x, _, _, prf) -> + Mc.ExProof (CamlToCoq.positive x, cmpl_proof (i :: j :: k :: env) prf) let compile_proof env prf = let id = 1 + proof_max_id prf in - let _,prf = normalise_proof id prf in + let _, prf = normalise_proof id prf in cmpl_proof env prf let rec eval_prf_rule env = function - | Annot(s,p) -> eval_prf_rule env p + | Annot (s, p) -> eval_prf_rule env p | Hyp i | Def i -> env i - | Cst n -> (Vect.set 0 n Vect.null, - match Num.compare_num n (Int 0) with - | 0 -> Ge - | 1 -> Gt - | _ -> failwith "eval_prf_rule : negative constant" - ) - | Zero -> (Vect.null, Ge) - | Square v -> (LinPoly.product v v,Ge) - | MulC(v, p) -> - let (p1,o) = eval_prf_rule env p in - begin match o with - | Eq -> (LinPoly.product v p1,Eq) - | _ -> - Printf.fprintf stdout "MulC(%a,%a) invalid 2d arg %a %s" Vect.pp v output_prf_rule p Vect.pp p1 (string_of_op o); - failwith "eval_prf_rule : not an equality" - end - | Gcd(g,p) -> let (v,op) = eval_prf_rule env p in - (Vect.div (Big_int g) v, op) - | MulPrf(p1,p2) -> - let (v1,o1) = eval_prf_rule env p1 in - let (v2,o2) = eval_prf_rule env p2 in - (LinPoly.product v1 v2, opMult o1 o2) - | AddPrf(p1,p2) -> - let (v1,o1) = eval_prf_rule env p1 in - let (v2,o2) = eval_prf_rule env p2 in - (LinPoly.addition v1 v2, opAdd o1 o2) - | CutPrf p -> eval_prf_rule env p - - - let is_unsat (p,o) = - let (c,r) = Vect.decomp_cst p in - if Vect.is_null r - then not (eval_op o c (Int 0)) - else false + | Cst n -> ( + ( Vect.set 0 n Vect.null + , match Num.compare_num n (Int 0) with + | 0 -> Ge + | 1 -> Gt + | _ -> failwith "eval_prf_rule : negative constant" ) ) + | Zero -> (Vect.null, Ge) + | Square v -> (LinPoly.product v v, Ge) + | MulC (v, p) -> ( + let p1, o = eval_prf_rule env p in + match o with + | Eq -> (LinPoly.product v p1, Eq) + | _ -> + Printf.fprintf stdout "MulC(%a,%a) invalid 2d arg %a %s" Vect.pp v + output_prf_rule p Vect.pp p1 (string_of_op o); + failwith "eval_prf_rule : not an equality" ) + | Gcd (g, p) -> + let v, op = eval_prf_rule env p in + (Vect.div (Big_int g) v, op) + | MulPrf (p1, p2) -> + let v1, o1 = eval_prf_rule env p1 in + let v2, o2 = eval_prf_rule env p2 in + (LinPoly.product v1 v2, opMult o1 o2) + | AddPrf (p1, p2) -> + let v1, o1 = eval_prf_rule env p1 in + let v2, o2 = eval_prf_rule env p2 in + (LinPoly.addition v1 v2, opAdd o1 o2) + | CutPrf p -> eval_prf_rule env p + + let is_unsat (p, o) = + let c, r = Vect.decomp_cst p in + if Vect.is_null r then not (eval_op o c (Int 0)) else false let rec eval_proof env p = match p with | Done -> failwith "Proof is not finished" - | Step(i, prf, rst) -> - let (p,o) = eval_prf_rule (fun i -> IMap.find i env) prf in - if is_unsat (p,o) then true - else - if (=) rst Done - then - begin - Printf.fprintf stdout "Last inference %a %s\n" LinPoly.pp p (string_of_op o); - false - end - else eval_proof (IMap.add i (p,o) env) rst - | Enum(i,r1,v,r2,l) -> let _ = eval_prf_rule (fun i -> IMap.find i env) r1 in - let _ = eval_prf_rule (fun i -> IMap.find i env) r2 in - (* Should check bounds *) - failwith "Not implemented" - + | Step (i, prf, rst) -> + let p, o = eval_prf_rule (fun i -> IMap.find i env) prf in + if is_unsat (p, o) then true + else if rst = Done then begin + Printf.fprintf stdout "Last inference %a %s\n" LinPoly.pp p + (string_of_op o); + false + end + else eval_proof (IMap.add i (p, o) env) rst + | Enum (i, r1, v, r2, l) -> + let _ = eval_prf_rule (fun i -> IMap.find i env) r1 in + let _ = eval_prf_rule (fun i -> IMap.find i env) r2 in + (* Should check bounds *) + failwith "Not implemented" + | ExProof _ -> failwith "Not implemented" end -module WithProof = struct +module WithProof = struct + type t = (LinPoly.t * op) * ProofFormat.prf_rule - type t = ((LinPoly.t * op) * ProofFormat.prf_rule) + let annot s (p, prf) = (p, ProofFormat.Annot (s, prf)) - let annot s (p,prf) = (p, ProofFormat.Annot(s,prf)) + let output o ((lp, op), prf) = + Printf.fprintf o "%a %s 0 by %a\n" LinPoly.pp lp (string_of_op op) + ProofFormat.output_prf_rule prf - let output o ((lp,op),prf) = - Printf.fprintf o "%a %s 0 by %a\n" LinPoly.pp lp (string_of_op op) ProofFormat.output_prf_rule prf - - let output_sys o l = - List.iter (Printf.fprintf o "%a\n" output) l + let output_sys o l = List.iter (Printf.fprintf o "%a\n" output) l exception InvalidProof - let zero = ((Vect.null,Eq), ProofFormat.Zero) - - let const n = ((LinPoly.constant n,Ge), ProofFormat.Cst n) + let zero = ((Vect.null, Eq), ProofFormat.Zero) + let const n = ((LinPoly.constant n, Ge), ProofFormat.Cst n) + let of_cstr (c, prf) = ((Vect.set 0 (Num.minus_num c.cst) c.coeffs, c.op), prf) - let of_cstr (c,prf) = - (Vect.set 0 (Num.minus_num (c.cst)) c.coeffs,c.op), prf - - let product : t -> t -> t = fun ((p1,o1),prf1) ((p2,o2),prf2) -> - ((LinPoly.product p1 p2 , opMult o1 o2), ProofFormat.mul_proof prf1 prf2) + let product : t -> t -> t = + fun ((p1, o1), prf1) ((p2, o2), prf2) -> + ((LinPoly.product p1 p2, opMult o1 o2), ProofFormat.mul_proof prf1 prf2) - let addition : t -> t -> t = fun ((p1,o1),prf1) ((p2,o2),prf2) -> + let addition : t -> t -> t = + fun ((p1, o1), prf1) ((p2, o2), prf2) -> ((Vect.add p1 p2, opAdd o1 o2), ProofFormat.add_proof prf1 prf2) - let mult p ((p1,o1),prf1) = + let mult p ((p1, o1), prf1) = match o1 with - | Eq -> ((LinPoly.product p p1,o1), ProofFormat.sMulC p prf1) - | Gt| Ge -> let (n,r) = Vect.decomp_cst p in - if Vect.is_null r && n >/ Int 0 - then ((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1) - else raise InvalidProof - - - let cutting_plane ((p,o),prf) = - let (c,p') = Vect.decomp_cst p in - let g = (Vect.gcd p') in - if (Big_int.eq_big_int Big_int.unit_big_int g) || c =/ Int 0 || - not (Big_int.eq_big_int (denominator c) Big_int.unit_big_int) + | Eq -> ((LinPoly.product p p1, o1), ProofFormat.sMulC p prf1) + | Gt | Ge -> + let n, r = Vect.decomp_cst p in + if Vect.is_null r && n >/ Int 0 then + ((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1) + else ( + Printf.printf "mult_error %a [*] %a\n" LinPoly.pp p output + ((p1, o1), prf1); + raise InvalidProof ) + + let cutting_plane ((p, o), prf) = + let c, p' = Vect.decomp_cst p in + let g = Vect.gcd p' in + if + Big_int.eq_big_int Big_int.unit_big_int g + || c =/ Int 0 + || not (Big_int.eq_big_int (denominator c) Big_int.unit_big_int) then None (* Nothing to do *) else - let c1 = c // (Big_int g) in + let c1 = c // Big_int g in let c1' = Num.floor_num c1 in - if c1 =/ c1' - then None + if c1 =/ c1' then None else match o with - | Eq -> Some ((Vect.set 0 (Int (-1)) Vect.null,Eq), ProofFormat.Gcd(g,prf)) + | Eq -> + Some ((Vect.set 0 (Int (-1)) Vect.null, Eq), ProofFormat.Gcd (g, prf)) | Gt -> failwith "cutting_plane ignore strict constraints" | Ge -> - (* This is a non-trivial common divisor *) - Some ((Vect.set 0 c1' (Vect.div (Big_int g) p),o),ProofFormat.Gcd(g, prf)) - + (* This is a non-trivial common divisor *) + Some + ( (Vect.set 0 c1' (Vect.div (Big_int g) p), o) + , ProofFormat.Gcd (g, prf) ) let construct_sign p = - let (c,p') = Vect.decomp_cst p in - if Vect.is_null p' - then - Some (begin match sign_num c with - | 0 -> (true, Eq, ProofFormat.Zero) - | 1 -> (true,Gt, ProofFormat.Cst c) - | _ (*-1*) -> (false,Gt, ProofFormat.Cst (minus_num c)) - end) + let c, p' = Vect.decomp_cst p in + if Vect.is_null p' then + Some + ( match sign_num c with + | 0 -> (true, Eq, ProofFormat.Zero) + | 1 -> (true, Gt, ProofFormat.Cst c) + | _ (*-1*) -> (false, Gt, ProofFormat.Cst (minus_num c)) ) else None - let get_sign l p = match construct_sign p with - | None -> begin + | None -> ( + try + let (p', o), prf = + List.find (fun ((p', o), prf) -> Vect.equal p p') l + in + Some (true, o, prf) + with Not_found -> ( + let p = Vect.uminus p in try - let ((p',o),prf) = - List.find (fun ((p',o),prf) -> Vect.equal p p') l in - Some (true,o,prf) - with Not_found -> - let p = Vect.uminus p in - try - let ((p',o),prf) = List.find (fun ((p',o),prf) -> Vect.equal p p') l in - Some (false,o,prf) - with Not_found -> None - end + let (p', o), prf = + List.find (fun ((p', o), prf) -> Vect.equal p p') l + in + Some (false, o, prf) + with Not_found -> None ) ) | Some s -> Some s + let mult_sign : bool -> t -> t = + fun b ((p, o), prf) -> if b then ((p, o), prf) else ((Vect.uminus p, o), prf) - let mult_sign : bool -> t -> t = fun b ((p,o),prf) -> - if b then ((p,o),prf) - else ((Vect.uminus p,o),prf) - - - let rec linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) = - + let rec linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2) = (* lp1 = a1.x + b1 *) - let (a1,b1) = LinPoly.factorise x lp1 in - + let a1, b1 = LinPoly.factorise x lp1 in (* lp2 = a2.x + b2 *) - let (a2,b2) = LinPoly.factorise x lp2 in - - if Vect.is_null a2 - then (* We are done *) - Some ((lp2,op2),prf2) + let a2, b2 = LinPoly.factorise x lp2 in + if Vect.is_null a2 then (* We are done *) + Some ((lp2, op2), prf2) else - match op1,op2 with - | Eq , (Ge|Gt) -> begin - match get_sign sys a1 with - | None -> None (* Impossible to pivot without sign information *) - | Some(b,o,prf) -> - let sa1 = mult_sign b ((a1,o),prf) in - let sa2 = if b then (Vect.uminus a2) else a2 in - - let ((lp2,op2),prf2) = - addition (product sa1 ((lp2,op2),prf2)) - (mult sa2 ((lp1,op1),prf1)) in - linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) - - end - | Eq , Eq -> - let ((lp2,op2),prf2) = addition (mult a1 ((lp2,op2),prf2)) - (mult (Vect.uminus a2) ((lp1,op1),prf1)) in - linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) - - | (Ge | Gt) , (Ge| Gt) -> begin - match get_sign sys a1 , get_sign sys a2 with - | Some(b1,o1,p1) , Some(b2,o2,p2) -> - if b1 <> b2 - then - let ((lp2,op2),prf2) = - addition (product (mult_sign b1 ((a1,o1), p1)) ((lp2,op2),prf2)) - (product (mult_sign b2 ((a2,o2), p2)) ((lp1,op1),prf1)) in - linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) - else None - | _ -> None - end - | (Ge|Gt) , Eq -> failwith "pivot: equality as second argument" - - let linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) = - match linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) with + match (op1, op2) with + | Eq, (Ge | Gt) -> ( + match get_sign sys a1 with + | None -> None (* Impossible to pivot without sign information *) + | Some (b, o, prf) -> + let sa1 = mult_sign b ((a1, o), prf) in + let sa2 = if b then Vect.uminus a2 else a2 in + let (lp2, op2), prf2 = + addition + (product sa1 ((lp2, op2), prf2)) + (mult sa2 ((lp1, op1), prf1)) + in + linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2) ) + | Eq, Eq -> + let (lp2, op2), prf2 = + addition + (mult a1 ((lp2, op2), prf2)) + (mult (Vect.uminus a2) ((lp1, op1), prf1)) + in + linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2) + | (Ge | Gt), (Ge | Gt) -> ( + match (get_sign sys a1, get_sign sys a2) with + | Some (b1, o1, p1), Some (b2, o2, p2) -> + if b1 <> b2 then + let (lp2, op2), prf2 = + addition + (product (mult_sign b1 ((a1, o1), p1)) ((lp2, op2), prf2)) + (product (mult_sign b2 ((a2, o2), p2)) ((lp1, op1), prf1)) + in + linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2) + else None + | _ -> None ) + | (Ge | Gt), Eq -> failwith "pivot: equality as second argument" + + let linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2) = + match linear_pivot sys ((lp1, op1), prf1) x ((lp2, op2), prf2) with | None -> None - | Some (c,p) -> Some(c, ProofFormat.simplify_prf_rule p) - - -let is_substitution strict ((p,o),prf) = - let pred v = if strict then v =/ Int 1 || v =/ Int (-1) else true in + | Some (c, p) -> Some (c, ProofFormat.simplify_prf_rule p) - match o with - | Eq -> LinPoly.search_linear pred p - | _ -> None + let is_substitution strict ((p, o), prf) = + let pred v = if strict then v =/ Int 1 || v =/ Int (-1) else true in + match o with Eq -> LinPoly.search_linear pred p | _ -> None - -let subst1 sys0 = - let (oeq,sys') = extract (is_substitution true) sys0 in - match oeq with - | None -> sys0 - | Some(v,pc) -> - match simplify (linear_pivot sys0 pc v) sys' with - | None -> sys0 - | Some sys' -> sys' - - - -let subst sys0 = - let elim sys = - let (oeq,sys') = extract (is_substitution true) sys in + let subst1 sys0 = + let oeq, sys' = extract (is_substitution true) sys0 in match oeq with - | None -> None - | Some(v,pc) -> simplify (linear_pivot sys0 pc v) sys' in - - iterate_until_stable elim sys0 - - -let saturate_subst b sys0 = - let select = is_substitution b in - let gen (v,pc) ((c,op),prf) = - if ISet.mem v (LinPoly.variables c) - then linear_pivot sys0 pc v ((c,op),prf) - else None - in - saturate select gen sys0 - - + | None -> sys0 + | Some (v, pc) -> ( + match simplify (linear_pivot sys0 pc v) sys' with + | None -> sys0 + | Some sys' -> sys' ) + + let subst sys0 = + let elim sys = + let oeq, sys' = extract (is_substitution true) sys in + match oeq with + | None -> None + | Some (v, pc) -> simplify (linear_pivot sys0 pc v) sys' + in + iterate_until_stable elim sys0 + + let saturate_subst b sys0 = + let select = is_substitution b in + let gen (v, pc) ((c, op), prf) = + if ISet.mem v (LinPoly.variables c) then + linear_pivot sys0 pc v ((c, op), prf) + else None + in + saturate select gen sys0 end - (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index cfb1bb914c..7e905ac69b 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -9,7 +9,6 @@ (************************************************************************) open Mutils - module Mc = Micromega val max_nb_cstr : int ref @@ -17,46 +16,52 @@ val max_nb_cstr : int ref type var = int module Monomial : sig - (** A monomial is represented by a multiset of variables *) type t + (** A monomial is represented by a multiset of variables *) - (** [fold f m acc] - folds over the variables with multiplicities *) val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a + (** [fold f m acc] + folds over the variables with multiplicities *) + val degree : t -> int + (** [degree m] is the sum of the degrees of each variable *) + + val const : t (** [const] @return the empty monomial i.e. without any variable *) - val const : t val is_const : t -> bool + val var : var -> t (** [var x] @return the monomial x^1 *) - val var : var -> t + val prod : t -> t -> t + (** [prod n m] + @return the monomial n*m *) + + val sqrt : t -> t option (** [sqrt m] @return [Some r] iff r^2 = m *) - val sqrt : t -> t option + val is_var : t -> bool (** [is_var m] @return [true] iff m = x^1 for some variable x *) - val is_var : t -> bool + val get_var : t -> var option (** [get_var m] @return [x] iff m = x^1 for variable x *) - val get_var : t -> var option - + val div : t -> t -> t * int (** [div m1 m2] @return a pair [mr,n] such that mr * (m2)^n = m1 where n is maximum *) - val div : t -> t -> t * int - (** [compare m1 m2] provides a total order over monomials*) val compare : t -> t -> int + (** [compare m1 m2] provides a total order over monomials*) + val variables : t -> ISet.t (** [variables m] @return the set of variables with (strictly) positive multiplicities *) - val variables : t -> ISet.t end module MonMap : sig @@ -76,52 +81,52 @@ module Poly : sig type t + val constant : Num.num -> t (** [constant c] @return the constant polynomial c *) - val constant : Num.num -> t + val variable : var -> t (** [variable x] @return the polynomial 1.x^1 *) - val variable : var -> t + val addition : t -> t -> t (** [addition p1 p2] @return the polynomial p1+p2 *) - val addition : t -> t -> t + val product : t -> t -> t (** [product p1 p2] @return the polynomial p1*p2 *) - val product : t -> t -> t + val uminus : t -> t (** [uminus p] @return the polynomial -p i.e product by -1 *) - val uminus : t -> t + val get : Monomial.t -> t -> Num.num (** [get mi p] @return the coefficient ai of the monomial mi. *) - val get : Monomial.t -> t -> Num.num - - (** [fold f p a] folds f over the monomials of p with non-zero coefficient *) val fold : (Monomial.t -> Num.num -> 'a -> 'a) -> t -> 'a -> 'a + (** [fold f p a] folds f over the monomials of p with non-zero coefficient *) + val add : Monomial.t -> Num.num -> t -> t (** [add m n p] @return the polynomial n*m + p *) - val add : Monomial.t -> Num.num -> t -> t - end -type cstr = {coeffs : Vect.t ; op : op ; cst : Num.num} (* Representation of linear constraints *) +type cstr = {coeffs : Vect.t; op : op; cst : Num.num} + +(* Representation of linear constraints *) and op = Eq | Ge | Gt val eval_op : op -> Num.num -> Num.num -> bool (*val opMult : op -> op -> op*) -val opAdd : op -> op -> op +val opAdd : op -> op -> op +val is_strict : cstr -> bool (** [is_strict c] @return whether the constraint is strict i.e. c.op = Gt *) -val is_strict : cstr -> bool exception Strict @@ -141,65 +146,70 @@ module LinPoly : sig This is done using the monomial tables of the module MonT. *) module MonT : sig - (** [clear ()] clears the mapping. *) val clear : unit -> unit + (** [clear ()] clears the mapping. *) + + val reserve : int -> unit + (** [reserve i] reserves the integer i *) + + val get_fresh : unit -> int + (** [get_fresh ()] return the first fresh variable *) + val retrieve : int -> Monomial.t (** [retrieve x] @return the monomial corresponding to the variable [x] *) - val retrieve : int -> Monomial.t + val register : Monomial.t -> int (** [register m] @return the variable index for the monomial m *) - val register : Monomial.t -> int - end - (** [linpol_of_pol p] linearise the polynomial p *) val linpol_of_pol : Poly.t -> t + (** [linpol_of_pol p] linearise the polynomial p *) + val var : var -> t (** [var x] @return 1.y where y is the variable index of the monomial x^1. *) - val var : var -> t + val coq_poly_of_linpol : (Num.num -> 'a) -> t -> 'a Mc.pExpr (** [coq_poly_of_linpol c p] @param p is a multi-variate polynomial. @param c maps a rational to a Coq polynomial coefficient. @return the coq expression corresponding to polynomial [p].*) - val coq_poly_of_linpol : (Num.num -> 'a) -> t -> 'a Mc.pExpr + val of_monomial : Monomial.t -> t (** [of_monomial m] @returns 1.x where x is the variable (index) for monomial m *) - val of_monomial : Monomial.t -> t - (** [of_vect v] + val of_vect : Vect.t -> t + (** [of_vect v] @returns a1.x1 + ... + an.xn This is not the identity because xi is the variable index of xi^1 *) - val of_vect : Vect.t -> t + val variables : t -> ISet.t (** [variables p] @return the set of variables of the polynomial p interpreted as a multi-variate polynomial *) - val variables : t -> ISet.t + val is_variable : t -> var option (** [is_variable p] @return Some x if p = a.x for a >= 0 *) - val is_variable : t -> var option + val is_linear : t -> bool (** [is_linear p] @return whether the multi-variate polynomial is linear. *) - val is_linear : t -> bool + val is_linear_for : var -> t -> bool (** [is_linear_for x p] @return true if the polynomial is linear in x i.e can be written c*x+r where c is a constant and r is independent from x *) - val is_linear_for : var -> t -> bool + val constant : Num.num -> t (** [constant c] @return the constant polynomial c *) - val constant : Num.num -> t (** [search_linear pred p] @return a variable x such p = a.x + b such that @@ -208,36 +218,42 @@ module LinPoly : sig val search_linear : (Num.num -> bool) -> t -> var option + val search_all_linear : (Num.num -> bool) -> t -> var list (** [search_all_linear pred p] @return all the variables x such p = a.x + b such that p is linear in x i.e x does not occur in b and a is a constant such that [pred a] *) - val search_all_linear : (Num.num -> bool) -> t -> var list - (** [product p q] - @return the product of the polynomial [p*q] *) val product : t -> t -> t + (** [product p q] + @return the product of the polynomial [p*q] *) + val factorise : var -> t -> t * t (** [factorise x p] @return [a,b] such that [p = a.x + b] and [x] does not occur in [b] *) - val factorise : var -> t -> t * t + val collect_square : t -> Monomial.t MonMap.t (** [collect_square p] @return a mapping m such that m[s] = s^2 for every s^2 that is a monomial of [p] *) - val collect_square : t -> Monomial.t MonMap.t + val monomials : t -> ISet.t + (** [monomials p] + @return the set of monomials. *) + + val degree : t -> int + (** [degree p] + @return return the maximum degree *) - (** [pp_var o v] pretty-prints a monomial indexed by v. *) val pp_var : out_channel -> var -> unit + (** [pp_var o v] pretty-prints a monomial indexed by v. *) - (** [pp o p] pretty-prints a polynomial. *) val pp : out_channel -> t -> unit + (** [pp o p] pretty-prints a polynomial. *) - (** [pp_goal typ o l] pretty-prints the list of constraints as a Coq goal. *) val pp_goal : string -> out_channel -> (t * op) list -> unit - + (** [pp_goal typ o l] pretty-prints the list of constraints as a Coq goal. *) end module ProofFormat : sig @@ -252,7 +268,7 @@ module ProofFormat : sig | Annot of string * prf_rule | Hyp of int | Def of int - | Cst of Num.num + | Cst of Num.num | Zero | Square of Vect.t | MulC of Vect.t * prf_rule @@ -265,92 +281,82 @@ module ProofFormat : sig | Done | Step of int * prf_rule * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list + | ExProof of int * int * int * var * var * var * proof - val pr_size : prf_rule -> Num.num + (* x = z - t, z >= 0, t >= 0 *) + val pr_size : prf_rule -> Num.num val pr_rule_max_id : prf_rule -> int - val proof_max_id : proof -> int - val normalise_proof : int -> proof -> int * proof - val output_prf_rule : out_channel -> prf_rule -> unit - val output_proof : out_channel -> proof -> unit - val add_proof : prf_rule -> prf_rule -> prf_rule - val mul_cst_proof : Num.num -> prf_rule -> prf_rule - val mul_proof : prf_rule -> prf_rule -> prf_rule - val compile_proof : int list -> proof -> Micromega.zArithProof - val cmpl_prf_rule : ('a Micromega.pExpr -> 'a Micromega.pol) -> - (Num.num -> 'a) -> (int list) -> prf_rule -> 'a Micromega.psatz + val cmpl_prf_rule : + ('a Micromega.pExpr -> 'a Micromega.pol) + -> (Num.num -> 'a) + -> int list + -> prf_rule + -> 'a Micromega.psatz val proof_of_farkas : prf_rule IMap.t -> Vect.t -> prf_rule - val eval_prf_rule : (int -> LinPoly.t * op) -> prf_rule -> LinPoly.t * op - val eval_proof : (LinPoly.t * op) IMap.t -> proof -> bool - end val output_cstr : out_channel -> cstr -> unit - val opMult : op -> op -> op (** [module WithProof] constructs polynomials packed with the proof that their sign is correct. *) -module WithProof : -sig - +module WithProof : sig type t = (LinPoly.t * op) * ProofFormat.prf_rule - (** [InvalidProof] is raised if the operation is invalid. *) exception InvalidProof + (** [InvalidProof] is raised if the operation is invalid. *) val annot : string -> t -> t - val of_cstr : cstr * ProofFormat.prf_rule -> t - (** [out_channel chan c] pretty-prints the constraint [c] over the channel [chan] *) val output : out_channel -> t -> unit + (** [out_channel chan c] pretty-prints the constraint [c] over the channel [chan] *) val output_sys : out_channel -> t list -> unit - (** [zero] represents the tautology (0=0) *) val zero : t + (** [zero] represents the tautology (0=0) *) - (** [const n] represents the tautology (n>=0) *) val const : Num.num -> t + (** [const n] represents the tautology (n>=0) *) + val product : t -> t -> t (** [product p q] @return the polynomial p*q with its sign and proof *) - val product : t -> t -> t + val addition : t -> t -> t (** [addition p q] @return the polynomial p+q with its sign and proof *) - val addition : t -> t -> t + val mult : LinPoly.t -> t -> t (** [mult p q] @return the polynomial p*q with its sign and proof. @raise InvalidProof if p is not a constant and p is not an equality *) - val mult : LinPoly.t -> t -> t - (** [cutting_plane p] does integer reasoning and adjust the constant to be integral *) val cutting_plane : t -> t option + (** [cutting_plane p] does integer reasoning and adjust the constant to be integral *) + val linear_pivot : t list -> t -> Vect.var -> t -> t option (** [linear_pivot sys p x q] @return the polynomial [q] where [x] is eliminated using the polynomial [p] The pivoting operation is only defined if - p is linear in x i.e p = a.x+b and x neither occurs in a and b - The pivoting also requires some sign conditions for [a] *) - val linear_pivot : t list -> t -> Vect.var -> t -> t option - -(** [subst sys] performs the equivalent of the 'subst' tactic of Coq. + (** [subst sys] performs the equivalent of the 'subst' tactic of Coq. For every p=0 \in sys such that p is linear in x with coefficient +/- 1 i.e. p = 0 <-> x = e and x \notin e. Replace x by e in sys @@ -361,12 +367,9 @@ sig val subst : t list -> t list - (** [subst1 sys] performs a single substitution *) val subst1 : t list -> t list + (** [subst1 sys] performs a single substitution *) val saturate_subst : bool -> t list -> t list - - val is_substitution : bool -> t -> var option - end diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index 4c95e6da75..ade8143f3c 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -8,73 +8,66 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** A naive simplex *) open Polynomial open Num + (*open Util*) open Mutils -type ('a,'b) sum = Inl of 'a | Inr of 'b +type ('a, 'b) sum = Inl of 'a | Inr of 'b let debug = false type iset = unit IMap.t -type tableau = Vect.t IMap.t (** Mapping basic variables to their equation. +type tableau = Vect.t IMap.t +(** Mapping basic variables to their equation. All variables >= than a threshold rst are restricted.*) -module Restricted = - struct - type t = - { - base : int; (** All variables above [base] are restricted *) - exc : int option (** Except [exc] which is currently optimised *) - } - - let pp o {base;exc} = - Printf.fprintf o ">= %a " LinPoly.pp_var base; - match exc with - | None ->Printf.fprintf o "-" - | Some x ->Printf.fprintf o "-%a" LinPoly.pp_var base - - let is_exception (x:var) (r:t) = - match r.exc with - | None -> false - | Some x' -> x = x' - - let restrict x rst = - if is_exception x rst - then - {base = rst.base;exc= None} - else failwith (Printf.sprintf "Cannot restrict %i" x) - - - let is_restricted x r0 = - x >= r0.base && not (is_exception x r0) - - let make x = {base = x ; exc = None} +module Restricted = struct + type t = + { base : int (** All variables above [base] are restricted *) + ; exc : int option (** Except [exc] which is currently optimised *) } - let set_exc x rst = {base = rst.base ; exc = Some x} + let pp o {base; exc} = + Printf.fprintf o ">= %a " LinPoly.pp_var base; + match exc with + | None -> Printf.fprintf o "-" + | Some x -> Printf.fprintf o "-%a" LinPoly.pp_var base - let fold rst f m acc = - IMap.fold (fun k v acc -> - if is_exception k rst then acc - else f k v acc) (IMap.from rst.base m) acc + let is_exception (x : var) (r : t) = + match r.exc with None -> false | Some x' -> x = x' - end + let restrict x rst = + if is_exception x rst then {base = rst.base; exc = None} + else failwith (Printf.sprintf "Cannot restrict %i" x) + let is_restricted x r0 = x >= r0.base && not (is_exception x r0) + let make x = {base = x; exc = None} + let set_exc x rst = {base = rst.base; exc = Some x} + let fold rst f m acc = + IMap.fold + (fun k v acc -> if is_exception k rst then acc else f k v acc) + (IMap.from rst.base m) acc +end let pp_row o v = LinPoly.pp o v -let output_tableau o t = - IMap.iter (fun k v -> - Printf.fprintf o "%a = %a\n" LinPoly.pp_var k pp_row v) t +let output_tableau o t = + IMap.iter + (fun k v -> Printf.fprintf o "%a = %a\n" LinPoly.pp_var k pp_row v) + t + +let output_env o t = + IMap.iter + (fun k v -> + Printf.fprintf o "%a : %a\n" LinPoly.pp_var k WithProof.output v) + t let output_vars o m = IMap.iter (fun k _ -> Printf.fprintf o "%a " LinPoly.pp_var k) m - (** A tableau is feasible iff for every basic restricted variable xi, we have ci>=0. @@ -83,12 +76,10 @@ let output_vars o m = if ci>=0. *) - -let unfeasible (rst:Restricted.t) tbl = - Restricted.fold rst (fun k v m -> - if Vect.get_cst v >=/ Int 0 then m - else IMap.add k () m) tbl IMap.empty - +let unfeasible (rst : Restricted.t) tbl = + Restricted.fold rst + (fun k v m -> if Vect.get_cst v >=/ Int 0 then m else IMap.add k () m) + tbl IMap.empty let is_feasible rst tb = IMap.is_empty (unfeasible rst tb) @@ -105,11 +96,10 @@ let is_feasible rst tb = IMap.is_empty (unfeasible rst tb) *) let is_maximised_vect rst v = - Vect.for_all (fun xi ai -> - if ai >/ Int 0 - then false - else Restricted.is_restricted xi rst) v - + Vect.for_all + (fun xi ai -> + if ai >/ Int 0 then false else Restricted.is_restricted xi rst) + v (** [is_maximised rst v] @return None if the variable is not maximised @@ -117,10 +107,8 @@ let is_maximised_vect rst v = *) let is_maximised rst v = try - let (vl,v) = Vect.decomp_cst v in - if is_maximised_vect rst v - then Some vl - else None + let vl, v = Vect.decomp_cst v in + if is_maximised_vect rst v then Some vl else None with Not_found -> None (** A variable xi is unbounded if for every @@ -132,21 +120,13 @@ let is_maximised rst v = violating a restriction. *) - type result = - | Max of num (** Maximum is reached *) + | Max of num (** Maximum is reached *) | Ubnd of var (** Problem is unbounded *) - | Feas (** Problem is feasible *) + | Feas (** Problem is feasible *) -type pivot = - | Done of result - | Pivot of int * int * num - - - - -type simplex = - | Opt of tableau * result +type pivot = Done of result | Pivot of int * int * num +type simplex = Opt of tableau * result (** For a row, x = ao.xo+...+ai.xi a valid pivot variable is such that it can improve the value of xi. @@ -156,15 +136,16 @@ type simplex = This is the entering variable. *) -let rec find_pivot_column (rst:Restricted.t) (r:Vect.t) = +let rec find_pivot_column (rst : Restricted.t) (r : Vect.t) = match Vect.choose r with | None -> failwith "find_pivot_column" - | Some(xi,ai,r') -> if ai </ Int 0 - then if Restricted.is_restricted xi rst - then find_pivot_column rst r' (* ai.xi cannot be improved *) - else (xi, -1) (* r is not restricted, sign of ai does not matter *) - else (* ai is positive, xi can be increased *) - (xi,1) + | Some (xi, ai, r') -> + if ai </ Int 0 then + if Restricted.is_restricted xi rst then find_pivot_column rst r' + (* ai.xi cannot be improved *) + else (xi, -1) (* r is not restricted, sign of ai does not matter *) + else (* ai is positive, xi can be increased *) + (xi, 1) (** Finding the variable leaving the basis is more subtle because we need to: - increase the objective function @@ -173,46 +154,46 @@ let rec find_pivot_column (rst:Restricted.t) (r:Vect.t) = This explains why we choose the pivot with the smallest score *) -let min_score s (i1,sc1) = +let min_score s (i1, sc1) = match s with - | None -> Some (i1,sc1) - | Some(i0,sc0) -> - if sc0 </ sc1 then s - else if sc1 </ sc0 then Some (i1,sc1) - else if i0 < i1 then s else Some(i1,sc1) + | None -> Some (i1, sc1) + | Some (i0, sc0) -> + if sc0 </ sc1 then s + else if sc1 </ sc0 then Some (i1, sc1) + else if i0 < i1 then s + else Some (i1, sc1) let find_pivot_row rst tbl j sgn = Restricted.fold rst (fun i' v res -> let aij = Vect.get j v in - if (Int sgn) */ aij </ Int 0 - then (* This would improve *) - let score' = Num.abs_num ((Vect.get_cst v) // aij) in - min_score res (i',score') - else res) tbl None + if Int sgn */ aij </ Int 0 then + (* This would improve *) + let score' = Num.abs_num (Vect.get_cst v // aij) in + min_score res (i', score') + else res) + tbl None let safe_find err x t = - try - IMap.find x t + try IMap.find x t with Not_found -> - if debug - then Printf.fprintf stdout "safe_find %s x%i %a\n" err x output_tableau t; - failwith err - + if debug then + Printf.fprintf stdout "safe_find %s x%i %a\n" err x output_tableau t; + failwith err (** [find_pivot vr t] aims at improving the objective function of the basic variable vr *) -let find_pivot vr (rst:Restricted.t) tbl = +let find_pivot vr (rst : Restricted.t) tbl = (* Get the objective of the basic variable vr *) - let v = safe_find "find_pivot" vr tbl in + let v = safe_find "find_pivot" vr tbl in match is_maximised rst v with | Some mx -> Done (Max mx) (* Maximum is reached; we are done *) - | None -> - (* Extract the vector *) - let (_,v) = Vect.decomp_cst v in - let (j',sgn) = find_pivot_column rst v in - match find_pivot_row rst (IMap.remove vr tbl) j' sgn with - | None -> Done (Ubnd j') - | Some (i',sc) -> Pivot(i', j', sc) + | None -> ( + (* Extract the vector *) + let _, v = Vect.decomp_cst v in + let j', sgn = find_pivot_column rst v in + match find_pivot_row rst (IMap.remove vr tbl) j' sgn with + | None -> Done (Ubnd j') + | Some (i', sc) -> Pivot (i', j', sc) ) (** [solve_column c r e] @param c is a non-basic variable @@ -223,12 +204,11 @@ let find_pivot vr (rst:Restricted.t) tbl = c = (r - e')/ai *) -let solve_column (c : var) (r : var) (e : Vect.t) : Vect.t = +let solve_column (c : var) (r : var) (e : Vect.t) : Vect.t = let a = Vect.get c e in - if a =/ Int 0 - then failwith "Cannot solve column" + if a =/ Int 0 then failwith "Cannot solve column" else - let a' = (Int (-1) // a) in + let a' = Int (-1) // a in Vect.mul a' (Vect.set r (Int (-1)) (Vect.set c (Int 0) e)) (** [pivot_row r c e] @@ -236,439 +216,477 @@ let solve_column (c : var) (r : var) (e : Vect.t) : Vect.t = @param r is a vector r = g.c + r' @return g.e+r' *) -let pivot_row (row: Vect.t) (c : var) (e : Vect.t) : Vect.t = +let pivot_row (row : Vect.t) (c : var) (e : Vect.t) : Vect.t = let g = Vect.get c row in - if g =/ Int 0 - then row - else Vect.mul_add g e (Int 1) (Vect.set c (Int 0) row) + if g =/ Int 0 then row else Vect.mul_add g e (Int 1) (Vect.set c (Int 0) row) -let pivot_with (m : tableau) (v: var) (p : Vect.t) = - IMap.map (fun (r:Vect.t) -> pivot_row r v p) m +let pivot_with (m : tableau) (v : var) (p : Vect.t) = + IMap.map (fun (r : Vect.t) -> pivot_row r v p) m let pivot (m : tableau) (r : var) (c : var) = - let row = safe_find "pivot" r m in + let row = safe_find "pivot" r m in let piv = solve_column c r row in IMap.add c piv (pivot_with (IMap.remove r m) c piv) - let adapt_unbounded vr x rst tbl = - if Vect.get_cst (IMap.find vr tbl) >=/ Int 0 - then tbl - else pivot tbl vr x + if Vect.get_cst (IMap.find vr tbl) >=/ Int 0 then tbl else pivot tbl vr x -module BaseSet = Set.Make(struct type t = iset let compare = IMap.compare (fun x y -> 0) end) +module BaseSet = Set.Make (struct + type t = iset + + let compare = IMap.compare (fun x y -> 0) +end) let get_base tbl = IMap.mapi (fun k _ -> ()) tbl let simplex opt vr rst tbl = let b = ref BaseSet.empty in - -let rec simplex opt vr rst tbl = - - if debug then begin + let rec simplex opt vr rst tbl = + ( if debug then let base = get_base tbl in - if BaseSet.mem base !b - then Printf.fprintf stdout "Cycling detected\n" - else b := BaseSet.add base !b - end; - - if debug && not (is_feasible rst tbl) - then - begin + if BaseSet.mem base !b then Printf.fprintf stdout "Cycling detected\n" + else b := BaseSet.add base !b ); + if debug && not (is_feasible rst tbl) then begin let m = unfeasible rst tbl in Printf.fprintf stdout "Simplex error\n"; Printf.fprintf stdout "The current tableau is not feasible\n"; - Printf.fprintf stdout "Restricted >= %a\n" Restricted.pp rst ; + Printf.fprintf stdout "Restricted >= %a\n" Restricted.pp rst; output_tableau stdout tbl; Printf.fprintf stdout "Error for variables %a\n" output_vars m end; - - if not opt && (Vect.get_cst (IMap.find vr tbl) >=/ Int 0) - then Opt(tbl,Feas) - else - match find_pivot vr rst tbl with - | Done r -> - begin match r with - | Max _ -> Opt(tbl, r) - | Ubnd x -> + if (not opt) && Vect.get_cst (IMap.find vr tbl) >=/ Int 0 then + Opt (tbl, Feas) + else + match find_pivot vr rst tbl with + | Done r -> ( + match r with + | Max _ -> Opt (tbl, r) + | Ubnd x -> let t' = adapt_unbounded vr x rst tbl in - Opt(t',r) - | Feas -> raise (Invalid_argument "find_pivot") - end - | Pivot(i,j,s) -> - if debug then begin - Printf.fprintf stdout "Find pivot for x%i(%s)\n" vr (string_of_num s); - Printf.fprintf stdout "Leaving variable x%i\n" i; - Printf.fprintf stdout "Entering variable x%i\n" j; - end; - let m' = pivot tbl i j in - simplex opt vr rst m' in - -simplex opt vr rst tbl - - + Opt (t', r) + | Feas -> raise (Invalid_argument "find_pivot") ) + | Pivot (i, j, s) -> + if debug then begin + Printf.fprintf stdout "Find pivot for x%i(%s)\n" vr (string_of_num s); + Printf.fprintf stdout "Leaving variable x%i\n" i; + Printf.fprintf stdout "Entering variable x%i\n" j + end; + let m' = pivot tbl i j in + simplex opt vr rst m' + in + simplex opt vr rst tbl -type certificate = - | Unsat of Vect.t - | Sat of tableau * var option +type certificate = Unsat of Vect.t | Sat of tableau * var option (** [normalise_row t v] @return a row obtained by pivoting the basic variables of the vector v *) -let normalise_row (t : tableau) (v: Vect.t) = - Vect.fold (fun acc vr ai -> try +let normalise_row (t : tableau) (v : Vect.t) = + Vect.fold + (fun acc vr ai -> + try let e = IMap.find vr t in Vect.add (Vect.mul ai e) acc with Not_found -> Vect.add (Vect.set vr ai Vect.null) acc) Vect.null v -let normalise_row (t : tableau) (v: Vect.t) = +let normalise_row (t : tableau) (v : Vect.t) = let v' = normalise_row t v in if debug then Printf.fprintf stdout "Normalised Optimising %a\n" LinPoly.pp v'; v' -let add_row (nw :var) (t : tableau) (v : Vect.t) : tableau = +let add_row (nw : var) (t : tableau) (v : Vect.t) : tableau = IMap.add nw (normalise_row t v) t - - (** [push_real] performs reasoning over the rationals *) -let push_real (opt : bool) (nw : var) (v : Vect.t) (rst: Restricted.t) (t : tableau) : certificate = - if debug - then begin Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau t; - Printf.fprintf stdout "Optimising %a=%a\n" LinPoly.pp_var nw LinPoly.pp v - end; +let push_real (opt : bool) (nw : var) (v : Vect.t) (rst : Restricted.t) + (t : tableau) : certificate = + if debug then begin + Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau t; + Printf.fprintf stdout "Optimising %a=%a\n" LinPoly.pp_var nw LinPoly.pp v + end; match simplex opt nw rst (add_row nw t v) with - | Opt(t',r) -> (* Look at the optimal *) - match r with - | Ubnd x-> - if debug then Printf.printf "The objective is unbounded (variable %a)\n" LinPoly.pp_var x; - Sat (t',Some x) (* This is sat and we can extract a value *) - | Feas -> Sat (t',None) - | Max n -> - if debug then begin - Printf.printf "The objective is maximised %s\n" (string_of_num n); - Printf.printf "%a = %a\n" LinPoly.pp_var nw pp_row (IMap.find nw t') - end; - - if n >=/ Int 0 - then Sat (t',None) - else - let v' = safe_find "push_real" nw t' in - Unsat (Vect.set nw (Int 1) (Vect.set 0 (Int 0) (Vect.mul (Int (-1)) v'))) - + | Opt (t', r) -> ( + (* Look at the optimal *) + match r with + | Ubnd x -> + if debug then + Printf.printf "The objective is unbounded (variable %a)\n" + LinPoly.pp_var x; + Sat (t', Some x) (* This is sat and we can extract a value *) + | Feas -> Sat (t', None) + | Max n -> + if debug then begin + Printf.printf "The objective is maximised %s\n" (string_of_num n); + Printf.printf "%a = %a\n" LinPoly.pp_var nw pp_row (IMap.find nw t') + end; + if n >=/ Int 0 then Sat (t', None) + else + let v' = safe_find "push_real" nw t' in + Unsat + (Vect.set nw (Int 1) (Vect.set 0 (Int 0) (Vect.mul (Int (-1)) v'))) ) +open Mutils (** One complication is that equalities needs some pre-processing. *) -open Mutils -open Polynomial - -let fresh_var l = - 1 + - try - (ISet.max_elt (List.fold_left (fun acc c -> ISet.union acc (Vect.variables c.coeffs)) ISet.empty l)) - with Not_found -> 0 +open Polynomial (*type varmap = (int * bool) IMap.t*) - let make_certificate vm l = - Vect.normalise (Vect.fold (fun acc x n -> - let (x',b) = IMap.find x vm in - Vect.set x' (if b then n else Num.minus_num n) acc) Vect.null l) - - - - + Vect.normalise + (Vect.fold + (fun acc x n -> + let x', b = IMap.find x vm in + Vect.set x' (if b then n else Num.minus_num n) acc) + Vect.null l) + +(** [eliminate_equalities vr0 l] + represents an equality e = 0 of index idx in the list l + by 2 constraints (vr:e >= 0) and (vr+1:-e >= 0) + The mapping vm maps vr to idx + *) -let eliminate_equalities (vr0:var) (l:Polynomial.cstr list) = +let eliminate_equalities (vr0 : var) (l : Polynomial.cstr list) = let rec elim idx vr vm l acc = match l with - | [] -> (vr,vm,acc) - | c::l -> match c.op with - | Ge -> let v = Vect.set 0 (minus_num c.cst) c.coeffs in - elim (idx+1) (vr+1) (IMap.add vr (idx,true) vm) l ((vr,v)::acc) - | Eq -> let v1 = Vect.set 0 (minus_num c.cst) c.coeffs in - let v2 = Vect.mul (Int (-1)) v1 in - let vm = IMap.add vr (idx,true) (IMap.add (vr+1) (idx,false) vm) in - elim (idx+1) (vr+2) vm l ((vr,v1)::(vr+1,v2)::acc) - | Gt -> raise Strict in + | [] -> (vr, vm, acc) + | c :: l -> ( + match c.op with + | Ge -> + let v = Vect.set 0 (minus_num c.cst) c.coeffs in + elim (idx + 1) (vr + 1) (IMap.add vr (idx, true) vm) l ((vr, v) :: acc) + | Eq -> + let v1 = Vect.set 0 (minus_num c.cst) c.coeffs in + let v2 = Vect.mul (Int (-1)) v1 in + let vm = IMap.add vr (idx, true) (IMap.add (vr + 1) (idx, false) vm) in + elim (idx + 1) (vr + 2) vm l ((vr, v1) :: (vr + 1, v2) :: acc) + | Gt -> raise Strict ) + in elim 0 vr0 IMap.empty l [] let find_solution rst tbl = - IMap.fold (fun vr v res -> if Restricted.is_restricted vr rst - then res - else Vect.set vr (Vect.get_cst v) res) tbl Vect.null + IMap.fold + (fun vr v res -> + if Restricted.is_restricted vr rst then res + else Vect.set vr (Vect.get_cst v) res) + tbl Vect.null -let choose_conflict (sol:Vect.t) (l: (var * Vect.t) list) = - let esol = Vect.set 0 (Int 1) sol in +let find_full_solution rst tbl = + IMap.fold (fun vr v res -> Vect.set vr (Vect.get_cst v) res) tbl Vect.null - let rec most_violating l e (x,v) rst = +let choose_conflict (sol : Vect.t) (l : (var * Vect.t) list) = + let esol = Vect.set 0 (Int 1) sol in + let rec most_violating l e (x, v) rst = match l with - | [] -> Some((x,v),rst) - | (x',v')::l -> - let e' = Vect.dotproduct esol v' in - if e' <=/ e - then most_violating l e' (x',v') ((x,v)::rst) - else most_violating l e (x,v) ((x',v')::rst) in - + | [] -> Some ((x, v), rst) + | (x', v') :: l -> + let e' = Vect.dotproduct esol v' in + if e' <=/ e then most_violating l e' (x', v') ((x, v) :: rst) + else most_violating l e (x, v) ((x', v') :: rst) + in match l with | [] -> None - | (x,v)::l -> let e = Vect.dotproduct esol v in - most_violating l e (x,v) [] - + | (x, v) :: l -> + let e = Vect.dotproduct esol v in + most_violating l e (x, v) [] - -let rec solve opt l (rst:Restricted.t) (t:tableau) = +let rec solve opt l (rst : Restricted.t) (t : tableau) = let sol = find_solution rst t in match choose_conflict sol l with - | None -> Inl (rst,t,None) - | Some((vr,v),l) -> - match push_real opt vr v (Restricted.set_exc vr rst) t with - | Sat (t',x) -> - (* let t' = remove_redundant rst t' in*) - begin - match l with - | [] -> Inl(rst,t', x) - | _ -> solve opt l rst t' - end - | Unsat c -> Inr c - -let find_unsat_certificate (l : Polynomial.cstr list ) = - let vr = fresh_var l in - let (_,vm,l') = eliminate_equalities vr l in - - match solve false l' (Restricted.make vr) IMap.empty with - | Inr c -> Some (make_certificate vm c) + | None -> Inl (rst, t, None) + | Some ((vr, v), l) -> ( + match push_real opt vr v (Restricted.set_exc vr rst) t with + | Sat (t', x) -> ( + (* let t' = remove_redundant rst t' in*) + match l with + | [] -> Inl (rst, t', x) + | _ -> solve opt l rst t' ) + | Unsat c -> Inr c ) + +let find_unsat_certificate (l : Polynomial.cstr list) = + let vr = LinPoly.MonT.get_fresh () in + let _, vm, l' = eliminate_equalities vr l in + match solve false l' (Restricted.make vr) IMap.empty with + | Inr c -> Some (make_certificate vm c) | Inl _ -> None - +let fresh_var l = + 1 + + + try + ISet.max_elt + (List.fold_left + (fun acc c -> ISet.union acc (Vect.variables c.coeffs)) + ISet.empty l) + with Not_found -> 0 let find_point (l : Polynomial.cstr list) = let vr = fresh_var l in - let (_,vm,l') = eliminate_equalities vr l in - + let _, vm, l' = eliminate_equalities vr l in match solve false l' (Restricted.make vr) IMap.empty with - | Inl (rst,t,_) -> Some (find_solution rst t) - | _ -> None - - + | Inl (rst, t, _) -> Some (find_solution rst t) + | _ -> None let optimise obj l = - let vr0 = fresh_var l in - let (_,vm,l') = eliminate_equalities (vr0+1) l in - + let vr0 = LinPoly.MonT.get_fresh () in + let _, vm, l' = eliminate_equalities (vr0 + 1) l in let bound pos res = match res with - | Opt(_,Max n) -> Some (if pos then n else minus_num n) - | Opt(_,Ubnd _) -> None - | Opt(_,Feas) -> None + | Opt (_, Max n) -> Some (if pos then n else minus_num n) + | Opt (_, Ubnd _) -> None + | Opt (_, Feas) -> None in - match solve false l' (Restricted.make vr0) IMap.empty with - | Inl (rst,t,_) -> - Some (bound false - (simplex true vr0 rst (add_row vr0 t (Vect.uminus obj))), - bound true - (simplex true vr0 rst (add_row vr0 t obj))) - | _ -> None - - + | Inl (rst, t, _) -> + Some + ( bound false (simplex true vr0 rst (add_row vr0 t (Vect.uminus obj))) + , bound true (simplex true vr0 rst (add_row vr0 t obj)) ) + | _ -> None open Polynomial let env_of_list l = - List.fold_left (fun (i,m) l -> (i+1, IMap.add i l m)) (0,IMap.empty) l - + List.fold_left (fun (i, m) l -> (i + 1, IMap.add i l m)) (0, IMap.empty) l open ProofFormat -let make_farkas_certificate (env: WithProof.t IMap.t) vm v = - Vect.fold (fun acc x n -> +let make_farkas_certificate (env : WithProof.t IMap.t) vm v = + Vect.fold + (fun acc x n -> add_proof acc begin try - let (x',b) = IMap.find x vm in - (mul_cst_proof - (if b then n else (Num.minus_num n)) - (snd (IMap.find x' env))) - with Not_found -> (* This is an introduced hypothesis *) - (mul_cst_proof n (snd (IMap.find x env))) - end) Zero v - -let make_farkas_proof (env: WithProof.t IMap.t) vm v = - Vect.fold (fun wp x n -> - WithProof.addition wp begin + let x', b = IMap.find x vm in + mul_cst_proof + (if b then n else Num.minus_num n) + (snd (IMap.find x' env)) + with Not_found -> + (* This is an introduced hypothesis *) + mul_cst_proof n (snd (IMap.find x env)) + end) + Zero v + +let make_farkas_proof (env : WithProof.t IMap.t) vm v = + Vect.fold + (fun wp x n -> + WithProof.addition wp + begin try - let (x', b) = IMap.find x vm in - let n = if b then n else Num.minus_num n in + let x', b = IMap.find x vm in + let n = if b then n else Num.minus_num n in WithProof.mult (Vect.cst n) (IMap.find x' env) - with Not_found -> - WithProof.mult (Vect.cst n) (IMap.find x env) - end) WithProof.zero v - + with Not_found -> WithProof.mult (Vect.cst n) (IMap.find x env) + end) + WithProof.zero v let frac_num n = n -/ Num.floor_num n +type ('a, 'b) hitkind = + | Forget + (* Not interesting *) + | Hit of 'a + (* Yes, we have a positive result *) + | Keep of 'b -(* [resolv_var v rst tbl] returns (if it exists) a restricted variable vr such that v = vr *) -exception FoundVar of int - -let resolve_var v rst tbl = - let v = Vect.set v (Int 1) Vect.null in - try - IMap.iter (fun k vect -> - if Restricted.is_restricted k rst - then if Vect.equal v vect then raise (FoundVar k) - else ()) tbl ; None - with FoundVar k -> Some k - -let prepare_cut env rst tbl x v = - (* extract the unrestricted part *) - let (unrst,rstv) = Vect.partition (fun x vl -> not (Restricted.is_restricted x rst) && frac_num vl <>/ Int 0) (Vect.set 0 (Int 0) v) in - if Vect.is_null unrst - then Some rstv - else Some (Vect.fold (fun acc k i -> - match resolve_var k rst tbl with - | None -> acc (* Should not happen *) - | Some v' -> Vect.set v' i acc) - rstv unrst) - -let cut env rmin sol vm (rst:Restricted.t) tbl (x,v) = - begin - (* Printf.printf "Trying to cut %i\n" x;*) - let (n,r) = Vect.decomp_cst v in - - +let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = + let n, r = Vect.decomp_cst v in let f = frac_num n in - - if f =/ Int 0 - then None (* The solution is integral *) + if f =/ Int 0 then Forget (* The solution is integral *) else (* This is potentially a cut *) - let t = - if f </ (Int 1) // (Int 2) - then - let t' = ((Int 1) // f) in - if Num.is_integer_num t' - then t' -/ Int 1 - else Num.floor_num t' - else Int 1 in - + let t = + if f </ Int 1 // Int 2 then + let t' = Int 1 // f in + if Num.is_integer_num t' then t' -/ Int 1 else Num.floor_num t' + else Int 1 + in let cut_coeff1 v = let fv = frac_num v in - if fv <=/ (Int 1 -/ f) - then fv // (Int 1 -/ f) - else (Int 1 -/ fv) // f in - + if fv <=/ Int 1 -/ f then fv // (Int 1 -/ f) else (Int 1 -/ fv) // f + in let cut_coeff2 v = frac_num (t */ v) in - let cut_vector ccoeff = - match prepare_cut env rst tbl x v with - | None -> Vect.null - | Some r -> - (*Printf.printf "Potential cut %a\n" LinPoly.pp r;*) - Vect.fold (fun acc x n -> Vect.set x (ccoeff n) acc) Vect.null r + Vect.fold + (fun acc x n -> + if Restricted.is_restricted x rst then Vect.set x (ccoeff n) acc + else acc) + Vect.null r in - - let lcut = List.map (fun cv -> Vect.normalise (cut_vector cv)) [cut_coeff1 ; cut_coeff2] in - - let lcut = List.map (make_farkas_proof env vm) lcut in - + let lcut = + List.map + (fun cv -> Vect.normalise (cut_vector cv)) + [cut_coeff1; cut_coeff2] + in + let lcut = List.map (make_farkas_proof env vm) lcut in let check_cutting_plane c = match WithProof.cutting_plane c with | None -> - if debug then Printf.printf "This is not cutting plane for %a\n%a:" LinPoly.pp_var x WithProof.output c; - None - | Some(v,prf) -> - if debug then begin - Printf.printf "This is a cutting plane for %a:" LinPoly.pp_var x; - Printf.printf " %a\n" WithProof.output (v,prf); - end; - if (=) (snd v) Eq - then (* Unsat *) Some (x,(v,prf)) - else - let vl = (Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol)) in - if eval_op Ge vl (Int 0) - then begin - (* Can this happen? *) - if debug then Printf.printf "The cut is feasible %s >= 0 ??\n" (Num.string_of_num vl); - None - end - else Some(x,(v,prf)) in - - find_some check_cutting_plane lcut - end + if debug then + Printf.printf "This is not a cutting plane for %a\n%a:" LinPoly.pp_var + x WithProof.output c; + None + | Some (v, prf) -> + if debug then ( + Printf.printf "This is a cutting plane for %a:" LinPoly.pp_var x; + Printf.printf " %a\n" WithProof.output (v, prf) ); + if snd v = Eq then (* Unsat *) Some (x, (v, prf)) + else + let vl = Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol) in + if eval_op Ge vl (Int 0) then ( + if debug then + Printf.printf "The cut is feasible %s >= 0 \n" + (Num.string_of_num vl); + None ) + else Some (x, (v, prf)) + in + match find_some check_cutting_plane lcut with + | Some r -> Hit r + | None -> Keep (x, v) + +let merge_result_old oldr f x = + match oldr with + | Hit v -> Hit v + | Forget -> ( + match f x with Forget -> Forget | Hit v -> Hit v | Keep v -> Keep v ) + | Keep v -> ( + match f x with Forget -> Keep v | Keep v' -> Keep v | Hit v -> Hit v ) + +let merge_best lt oldr newr = + match (oldr, newr) with + | x, Forget -> x + | Hit v, Hit v' -> if lt v v' then Hit v else Hit v' + | _, Hit v | Hit v, _ -> Hit v + | Forget, Keep v -> Keep v + | Keep v, Keep v' -> Keep v' let find_cut nb env u sol vm rst tbl = - if nb = 0 - then - IMap.fold (fun x v acc -> - match acc with - | None -> cut env u sol vm rst tbl (x,v) - | Some c -> Some c) tbl None + if nb = 0 then + IMap.fold + (fun x v acc -> merge_result_old acc (cut env u sol vm rst tbl) (x, v)) + tbl Forget else - IMap.fold (fun x v acc -> - match cut env u sol vm rst tbl (x,v) , acc with - | None , Some r | Some r , None -> Some r - | None , None -> None - | Some (v,((lp,o),p1)) , Some (v',((lp',o'),p2)) -> - Some (if ProofFormat.pr_size p1 </ ProofFormat.pr_size p2 - then (v,((lp,o),p1)) else (v',((lp',o'),p2))) - ) tbl None - - + let lt (_, (_, p1)) (_, (_, p2)) = + ProofFormat.pr_size p1 </ ProofFormat.pr_size p2 + in + IMap.fold + (fun x v acc -> merge_best lt acc (cut env u sol vm rst tbl (x, v))) + tbl Forget + +let var_of_vect v = fst (fst (Vect.decomp_fst v)) + +let eliminate_variable (bounded, vr, env, tbl) x = + if debug then + Printf.printf "Eliminating variable %a from tableau\n%a\n" LinPoly.pp_var x + output_tableau tbl; + (* We identify the new variables with the constraint. *) + LinPoly.MonT.reserve vr; + let z = LinPoly.var (vr + 1) in + let zv = var_of_vect z in + let t = LinPoly.var (vr + 2) in + let tv = var_of_vect t in + (* x = z - t *) + let xdef = Vect.add z (Vect.uminus t) in + let xp = ((Vect.set x (Int 1) (Vect.uminus xdef), Eq), Def vr) in + let zp = ((z, Ge), Def zv) in + let tp = ((t, Ge), Def tv) in + (* Pivot the current tableau using xdef *) + let tbl = IMap.map (fun v -> Vect.subst x xdef v) tbl in + (* Pivot the environment *) + let env = + IMap.map + (fun lp -> + let (v, o), p = lp in + let ai = Vect.get x v in + if ai =/ Int 0 then lp + else + WithProof.addition + (WithProof.mult (Vect.cst (Num.minus_num ai)) xp) + lp) + env + in + (* Add the variables to the environment *) + let env = IMap.add vr xp (IMap.add zv zp (IMap.add tv tp env)) in + (* Remember the mapping *) + let bounded = IMap.add x (vr, zv, tv) bounded in + if debug then ( + Printf.printf "Tableau without\n %a\n" output_tableau tbl; + Printf.printf "Environment\n %a\n" output_env env ); + (bounded, vr + 3, env, tbl) let integer_solver lp = - let (l,_) = List.split lp in - let vr0 = fresh_var l in - let (vr,vm,l') = eliminate_equalities vr0 l in - - let _,env = env_of_list (List.map WithProof.of_cstr lp) in - + let l, _ = List.split lp in + let vr0 = 3 * LinPoly.MonT.get_fresh () in + let vr, vm, l' = eliminate_equalities vr0 l in + let _, env = env_of_list (List.map WithProof.of_cstr lp) in let insert_row vr v rst tbl = match push_real true vr v rst tbl with - | Sat (t',x) -> Inl (Restricted.restrict vr rst,t',x) - | Unsat c -> Inr c in - + | Sat (t', x) -> Inl (Restricted.restrict vr rst, t', x) + | Unsat c -> Inr c + in let nb = ref 0 in - let rec isolve env cr vr res = incr nb; match res with - | Inr c -> Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c),Done)) - | Inl (rst,tbl,x) -> - if debug then begin - Printf.fprintf stdout "Looking for a cut\n"; - Printf.fprintf stdout "Restricted %a ...\n" Restricted.pp rst; - Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau tbl; - (* Printf.fprintf stdout "Bounding box\n%a\n" output_box (bounding_box (vr+1) rst tbl l')*) - end; - let sol = find_solution rst tbl in - - match find_cut (!nb mod 2) env cr (*x*) sol vm rst tbl with - | None -> None - | Some(cr,((v,op),cut)) -> - if (=) op Eq - then (* This is a contradiction *) - Some(Step(vr,CutPrf cut, Done)) - else - let res = insert_row vr v (Restricted.set_exc vr rst) tbl in - let prf = isolve (IMap.add vr ((v,op),Def vr) env) (Some cr) (vr+1) res in - match prf with - | None -> None - | Some p -> Some (Step(vr,CutPrf cut,p)) in - + | Inr c -> + Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c), Done)) + | Inl (rst, tbl, x) -> ( + if debug then begin + Printf.fprintf stdout "Looking for a cut\n"; + Printf.fprintf stdout "Restricted %a ...\n" Restricted.pp rst; + Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau tbl; + flush stdout + (* Printf.fprintf stdout "Bounding box\n%a\n" output_box (bounding_box (vr+1) rst tbl l')*) + end; + let sol = find_full_solution rst tbl in + match find_cut (!nb mod 2) env cr (*x*) sol vm rst tbl with + | Forget -> + None (* There is no hope, there should be an integer solution *) + | Hit (cr, ((v, op), cut)) -> + if op = Eq then + (* This is a contradiction *) + Some (Step (vr, CutPrf cut, Done)) + else ( + LinPoly.MonT.reserve vr; + let res = insert_row vr v (Restricted.set_exc vr rst) tbl in + let prf = + isolve (IMap.add vr ((v, op), Def vr) env) (Some cr) (vr + 1) res + in + match prf with + | None -> None + | Some p -> Some (Step (vr, CutPrf cut, p)) ) + | Keep (x, v) -> ( + if debug then + Printf.fprintf stdout "Remove %a from Tableau\n" LinPoly.pp_var x; + let bounded, vr, env, tbl = + Vect.fold + (fun acc x n -> + if x <> 0 && not (Restricted.is_restricted x rst) then + eliminate_variable acc x + else acc) + (IMap.empty, vr, env, tbl) v + in + let prf = isolve env cr vr (Inl (rst, tbl, None)) in + match prf with + | None -> None + | Some pf -> + Some + (IMap.fold + (fun x (vr, zv, tv) acc -> ExProof (vr, zv, tv, x, zv, tv, acc)) + bounded pf) ) ) + in let res = solve true l' (Restricted.make vr0) IMap.empty in isolve env None vr res let integer_solver lp = - if debug then Printf.printf "Input integer solver\n%a\n" WithProof.output_sys (List.map WithProof.of_cstr lp); - + if debug then + Printf.printf "Input integer solver\n%a\n" WithProof.output_sys + (List.map WithProof.of_cstr lp); match integer_solver lp with | None -> None - | Some prf -> if debug - then Printf.fprintf stdout "Proof %a\n" ProofFormat.output_proof prf ; - Some prf + | Some prf -> + if debug then + Printf.fprintf stdout "Proof %a\n" ProofFormat.output_proof prf; + Some prf diff --git a/plugins/micromega/simplex.mli b/plugins/micromega/simplex.mli index cba8e94ea7..19bcce3590 100644 --- a/plugins/micromega/simplex.mli +++ b/plugins/micromega/simplex.mli @@ -10,9 +10,8 @@ open Polynomial val optimise : Vect.t -> cstr list -> (Num.num option * Num.num option) option - val find_point : cstr list -> Vect.t option - val find_unsat_certificate : cstr list -> Vect.t option -val integer_solver : (cstr * ProofFormat.prf_rule) list -> ProofFormat.proof option +val integer_solver : + (cstr * ProofFormat.prf_rule) list -> ProofFormat.proof option diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index f2dfaa42a5..772ed7a8c5 100644 --- a/plugins/micromega/sos.ml +++ b/plugins/micromega/sos.ml @@ -9,17 +9,17 @@ (* ========================================================================= *) (* Nonlinear universal reals procedure using SOS decomposition. *) (* ========================================================================= *) -open Num;; -open Sos_types;; -open Sos_lib;; +open Num +open Sos_types +open Sos_lib (* prioritize_real();; *) -let debugging = ref false;; +let debugging = ref false -exception Sanity;; +exception Sanity (* ------------------------------------------------------------------------- *) (* Turn a rational into a decimal string with d sig digits. *) @@ -29,228 +29,224 @@ let decimalize = let rec normalize y = if abs_num y </ Int 1 // Int 10 then normalize (Int 10 */ y) - 1 else if abs_num y >=/ Int 1 then normalize (y // Int 10) + 1 - else 0 in + else 0 + in fun d x -> - if x =/ Int 0 then "0.0" else - let y = abs_num x in - let e = normalize y in - let z = pow10(-e) */ y +/ Int 1 in - let k = round_num(pow10 d */ z) in - (if x </ Int 0 then "-0." else "0.") ^ - implode(List.tl(explode(string_of_num k))) ^ - (if e = 0 then "" else "e"^string_of_int e);; + if x =/ Int 0 then "0.0" + else + let y = abs_num x in + let e = normalize y in + let z = (pow10 (-e) */ y) +/ Int 1 in + let k = round_num (pow10 d */ z) in + (if x </ Int 0 then "-0." else "0.") + ^ implode (List.tl (explode (string_of_num k))) + ^ if e = 0 then "" else "e" ^ string_of_int e (* ------------------------------------------------------------------------- *) (* Iterations over numbers, and lists indexed by numbers. *) (* ------------------------------------------------------------------------- *) let rec itern k l f a = - match l with - [] -> a - | h::t -> itern (k + 1) t f (f h k a);; + match l with [] -> a | h :: t -> itern (k + 1) t f (f h k a) -let rec iter (m,n) f a = - if n < m then a - else iter (m+1,n) f (f m a);; +let rec iter (m, n) f a = if n < m then a else iter (m + 1, n) f (f m a) (* ------------------------------------------------------------------------- *) (* The main types. *) (* ------------------------------------------------------------------------- *) -type vector = int*(int,num)func;; - -type matrix = (int*int)*(int*int,num)func;; - -type monomial = (vname,int)func;; - -type poly = (monomial,num)func;; +type vector = int * (int, num) func +type matrix = (int * int) * (int * int, num) func +type monomial = (vname, int) func +type poly = (monomial, num) func (* ------------------------------------------------------------------------- *) (* Assignment avoiding zeros. *) (* ------------------------------------------------------------------------- *) -let (|-->) x y a = if y =/ Int 0 then a else (x |-> y) a;; +let ( |--> ) x y a = if y =/ Int 0 then a else (x |-> y) a (* ------------------------------------------------------------------------- *) (* This can be generic. *) (* ------------------------------------------------------------------------- *) -let element (d,v) i = tryapplyd v i (Int 0);; - -let mapa f (d,v) = - d,foldl (fun a i c -> (i |--> f(c)) a) undefined v;; - -let is_zero (d,v) = - match v with - Empty -> true - | _ -> false;; +let element (d, v) i = tryapplyd v i (Int 0) +let mapa f (d, v) = (d, foldl (fun a i c -> (i |--> f c) a) undefined v) +let is_zero (d, v) = match v with Empty -> true | _ -> false (* ------------------------------------------------------------------------- *) (* Vectors. Conventionally indexed 1..n. *) (* ------------------------------------------------------------------------- *) -let vector_0 n = (n,undefined:vector);; - -let dim (v:vector) = fst v;; +let vector_0 n = ((n, undefined) : vector) +let dim (v : vector) = fst v let vector_const c n = if c =/ Int 0 then vector_0 n - else (n,List.fold_right (fun k -> k |-> c) (1--n) undefined :vector);; + else ((n, List.fold_right (fun k -> k |-> c) (1 -- n) undefined) : vector) -let vector_cmul c (v:vector) = +let vector_cmul c (v : vector) = let n = dim v in - if c =/ Int 0 then vector_0 n - else n,mapf (fun x -> c */ x) (snd v) + if c =/ Int 0 then vector_0 n else (n, mapf (fun x -> c */ x) (snd v)) let vector_of_list l = let n = List.length l in - (n,List.fold_right2 (|->) (1--n) l undefined :vector);; + ((n, List.fold_right2 ( |-> ) (1 -- n) l undefined) : vector) (* ------------------------------------------------------------------------- *) (* Matrices; again rows and columns indexed from 1. *) (* ------------------------------------------------------------------------- *) -let matrix_0 (m,n) = ((m,n),undefined:matrix);; - -let dimensions (m:matrix) = fst m;; +let matrix_0 (m, n) = (((m, n), undefined) : matrix) +let dimensions (m : matrix) = fst m -let matrix_cmul c (m:matrix) = - let (i,j) = dimensions m in - if c =/ Int 0 then matrix_0 (i,j) - else (i,j),mapf (fun x -> c */ x) (snd m);; +let matrix_cmul c (m : matrix) = + let i, j = dimensions m in + if c =/ Int 0 then matrix_0 (i, j) + else ((i, j), mapf (fun x -> c */ x) (snd m)) -let matrix_neg (m:matrix) = (dimensions m,mapf minus_num (snd m) :matrix);; +let matrix_neg (m : matrix) = ((dimensions m, mapf minus_num (snd m)) : matrix) -let matrix_add (m1:matrix) (m2:matrix) = +let matrix_add (m1 : matrix) (m2 : matrix) = let d1 = dimensions m1 and d2 = dimensions m2 in if d1 <> d2 then failwith "matrix_add: incompatible dimensions" - else (d1,combine (+/) (fun x -> x =/ Int 0) (snd m1) (snd m2) :matrix);; - -let row k (m:matrix) = - let i,j = dimensions m in - (j, - foldl (fun a (i,j) c -> if i = k then (j |-> c) a else a) undefined (snd m) - : vector);; - -let column k (m:matrix) = - let i,j = dimensions m in - (i, - foldl (fun a (i,j) c -> if j = k then (i |-> c) a else a) undefined (snd m) - : vector);; - -let diagonal (v:vector) = + else ((d1, combine ( +/ ) (fun x -> x =/ Int 0) (snd m1) (snd m2)) : matrix) + +let row k (m : matrix) = + let i, j = dimensions m in + ( ( j + , foldl + (fun a (i, j) c -> if i = k then (j |-> c) a else a) + undefined (snd m) ) + : vector ) + +let column k (m : matrix) = + let i, j = dimensions m in + ( ( i + , foldl + (fun a (i, j) c -> if j = k then (i |-> c) a else a) + undefined (snd m) ) + : vector ) + +let diagonal (v : vector) = let n = dim v in - ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);; + (((n, n), foldl (fun a i c -> ((i, i) |-> c) a) undefined (snd v)) : matrix) (* ------------------------------------------------------------------------- *) (* Monomials. *) (* ------------------------------------------------------------------------- *) -let monomial_1 = (undefined:monomial);; - -let monomial_var x = (x |=> 1 :monomial);; +let monomial_1 = (undefined : monomial) +let monomial_var x = (x |=> 1 : monomial) -let (monomial_mul:monomial->monomial->monomial) = - combine (+) (fun x -> false);; +let (monomial_mul : monomial -> monomial -> monomial) = + combine ( + ) (fun x -> false) -let monomial_degree x (m:monomial) = tryapplyd m x 0;; - -let monomial_multidegree (m:monomial) = foldl (fun a x k -> k + a) 0 m;; - -let monomial_variables m = dom m;; +let monomial_degree x (m : monomial) = tryapplyd m x 0 +let monomial_multidegree (m : monomial) = foldl (fun a x k -> k + a) 0 m +let monomial_variables m = dom m (* ------------------------------------------------------------------------- *) (* Polynomials. *) (* ------------------------------------------------------------------------- *) -let poly_0 = (undefined:poly);; - -let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 && a) true p;; - -let poly_var x = ((monomial_var x) |=> Int 1 :poly);; +let poly_0 = (undefined : poly) +let poly_isconst (p : poly) = foldl (fun a m c -> m = monomial_1 && a) true p +let poly_var x = (monomial_var x |=> Int 1 : poly) +let poly_const c = if c =/ Int 0 then poly_0 else monomial_1 |=> c -let poly_const c = - if c =/ Int 0 then poly_0 else (monomial_1 |=> c);; +let poly_cmul c (p : poly) = + if c =/ Int 0 then poly_0 else mapf (fun x -> c */ x) p -let poly_cmul c (p:poly) = - if c =/ Int 0 then poly_0 - else mapf (fun x -> c */ x) p;; - -let poly_neg (p:poly) = (mapf minus_num p :poly);; +let poly_neg (p : poly) = (mapf minus_num p : poly) -let poly_add (p1:poly) (p2:poly) = - (combine (+/) (fun x -> x =/ Int 0) p1 p2 :poly);; +let poly_add (p1 : poly) (p2 : poly) = + (combine ( +/ ) (fun x -> x =/ Int 0) p1 p2 : poly) -let poly_sub p1 p2 = poly_add p1 (poly_neg p2);; +let poly_sub p1 p2 = poly_add p1 (poly_neg p2) -let poly_cmmul (c,m) (p:poly) = +let poly_cmmul (c, m) (p : poly) = if c =/ Int 0 then poly_0 else if m = monomial_1 then mapf (fun d -> c */ d) p - else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p;; + else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p -let poly_mul (p1:poly) (p2:poly) = - foldl (fun a m c -> poly_add (poly_cmmul (c,m) p2) a) poly_0 p1;; +let poly_mul (p1 : poly) (p2 : poly) = + foldl (fun a m c -> poly_add (poly_cmmul (c, m) p2) a) poly_0 p1 -let poly_square p = poly_mul p p;; +let poly_square p = poly_mul p p let rec poly_pow p k = if k = 0 then poly_const (Int 1) else if k = 1 then p - else let q = poly_square(poly_pow p (k / 2)) in - if k mod 2 = 1 then poly_mul p q else q;; + else + let q = poly_square (poly_pow p (k / 2)) in + if k mod 2 = 1 then poly_mul p q else q -let degree x (p:poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p;; +let degree x (p : poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p -let multidegree (p:poly) = - foldl (fun a m c -> max (monomial_multidegree m) a) 0 p;; +let multidegree (p : poly) = + foldl (fun a m c -> max (monomial_multidegree m) a) 0 p -let poly_variables (p:poly) = - foldr (fun m c -> union (monomial_variables m)) p [];; +let poly_variables (p : poly) = + foldr (fun m c -> union (monomial_variables m)) p [] (* ------------------------------------------------------------------------- *) (* Order monomials for human presentation. *) (* ------------------------------------------------------------------------- *) -let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 || x1 = x2 && k1 > k2;; +let humanorder_varpow (x1, k1) (x2, k2) = x1 < x2 || (x1 = x2 && k1 > k2) let humanorder_monomial = - let rec ord l1 l2 = match (l1,l2) with - _,[] -> true - | [],_ -> false - | h1::t1,h2::t2 -> humanorder_varpow h1 h2 || h1 = h2 && ord t1 t2 in - fun m1 m2 -> m1 = m2 || - ord (sort humanorder_varpow (graph m1)) - (sort humanorder_varpow (graph m2));; + let rec ord l1 l2 = + match (l1, l2) with + | _, [] -> true + | [], _ -> false + | h1 :: t1, h2 :: t2 -> humanorder_varpow h1 h2 || (h1 = h2 && ord t1 t2) + in + fun m1 m2 -> + m1 = m2 + || ord + (sort humanorder_varpow (graph m1)) + (sort humanorder_varpow (graph m2)) (* ------------------------------------------------------------------------- *) (* Conversions to strings. *) (* ------------------------------------------------------------------------- *) -let string_of_vname (v:vname): string = (v: string);; +let string_of_vname (v : vname) : string = (v : string) let string_of_varpow x k = - if k = 1 then string_of_vname x else string_of_vname x^"^"^string_of_int k;; + if k = 1 then string_of_vname x else string_of_vname x ^ "^" ^ string_of_int k let string_of_monomial m = - if m = monomial_1 then "1" else - let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a) - (sort humanorder_varpow (graph m)) [] in - String.concat "*" vps;; - -let string_of_cmonomial (c,m) = + if m = monomial_1 then "1" + else + let vps = + List.fold_right + (fun (x, k) a -> string_of_varpow x k :: a) + (sort humanorder_varpow (graph m)) + [] + in + String.concat "*" vps + +let string_of_cmonomial (c, m) = if m = monomial_1 then string_of_num c else if c =/ Int 1 then string_of_monomial m - else string_of_num c ^ "*" ^ string_of_monomial m;; - -let string_of_poly (p:poly) = - if p = poly_0 then "<<0>>" else - let cms = sort (fun (m1,_) (m2,_) -> humanorder_monomial m1 m2) (graph p) in - let s = - List.fold_left (fun a (m,c) -> - if c </ Int 0 then a ^ " - " ^ string_of_cmonomial(minus_num c,m) - else a ^ " + " ^ string_of_cmonomial(c,m)) - "" cms in - let s1 = String.sub s 0 3 - and s2 = String.sub s 3 (String.length s - 3) in - "<<" ^(if s1 = " + " then s2 else "-"^s2)^">>";; + else string_of_num c ^ "*" ^ string_of_monomial m + +let string_of_poly (p : poly) = + if p = poly_0 then "<<0>>" + else + let cms = + sort (fun (m1, _) (m2, _) -> humanorder_monomial m1 m2) (graph p) + in + let s = + List.fold_left + (fun a (m, c) -> + if c </ Int 0 then a ^ " - " ^ string_of_cmonomial (minus_num c, m) + else a ^ " + " ^ string_of_cmonomial (c, m)) + "" cms + in + let s1 = String.sub s 0 3 and s2 = String.sub s 3 (String.length s - 3) in + "<<" ^ (if s1 = " + " then s2 else "-" ^ s2) ^ ">>" (* ------------------------------------------------------------------------- *) (* Printers. *) @@ -275,38 +271,41 @@ let print_poly m = Format.print_string(string_of_poly m);; (* Conversion from term. *) (* ------------------------------------------------------------------------- *) -let rec poly_of_term t = match t with - Zero -> poly_0 -| Const n -> poly_const n -| Var x -> poly_var x -| Opp t1 -> poly_neg (poly_of_term t1) -| Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r) -| Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r) -| Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r) -| Pow (t, n) -> - poly_pow (poly_of_term t) n;; +let rec poly_of_term t = + match t with + | Zero -> poly_0 + | Const n -> poly_const n + | Var x -> poly_var x + | Opp t1 -> poly_neg (poly_of_term t1) + | Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r) + | Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r) + | Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r) + | Pow (t, n) -> poly_pow (poly_of_term t) n (* ------------------------------------------------------------------------- *) (* String of vector (just a list of space-separated numbers). *) (* ------------------------------------------------------------------------- *) -let sdpa_of_vector (v:vector) = +let sdpa_of_vector (v : vector) = let n = dim v in - let strs = List.map (o (decimalize 20) (element v)) (1--n) in - String.concat " " strs ^ "\n";; + let strs = List.map (o (decimalize 20) (element v)) (1 -- n) in + String.concat " " strs ^ "\n" (* ------------------------------------------------------------------------- *) (* String for a matrix numbered k, in SDPA sparse format. *) (* ------------------------------------------------------------------------- *) -let sdpa_of_matrix k (m:matrix) = +let sdpa_of_matrix k (m : matrix) = let pfx = string_of_int k ^ " 1 " in - let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) - (snd m) [] in + let ms = + foldr (fun (i, j) c a -> if i > j then a else ((i, j), c) :: a) (snd m) [] + in let mss = sort (increasing fst) ms in - List.fold_right (fun ((i,j),c) a -> - pfx ^ string_of_int i ^ " " ^ string_of_int j ^ - " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; + List.fold_right + (fun ((i, j), c) a -> + pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c + ^ "\n" ^ a) + mss "" (* ------------------------------------------------------------------------- *) (* String in SDPA sparse format for standard SDP problem: *) @@ -316,85 +315,88 @@ let sdpa_of_matrix k (m:matrix) = (* ------------------------------------------------------------------------- *) let sdpa_of_problem comment obj mats = - let m = List.length mats - 1 - and n,_ = dimensions (List.hd mats) in - "\"" ^ comment ^ "\"\n" ^ - string_of_int m ^ "\n" ^ - "1\n" ^ - string_of_int n ^ "\n" ^ - sdpa_of_vector obj ^ - List.fold_right2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) - (1--List.length mats) mats "";; + let m = List.length mats - 1 and n, _ = dimensions (List.hd mats) in + "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ "1\n" ^ string_of_int n + ^ "\n" ^ sdpa_of_vector obj + ^ List.fold_right2 + (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) + (1 -- List.length mats) + mats "" (* ------------------------------------------------------------------------- *) (* More parser basics. *) (* ------------------------------------------------------------------------- *) let word s = - end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t)) - (List.map a (explode s));; + end_itlist + (fun p1 p2 -> p1 ++ p2 >> fun (s, t) -> s ^ t) + (List.map a (explode s)) + let token s = - many (some isspace) ++ word s ++ many (some isspace) - >> (fun ((_,t),_) -> t);; + many (some isspace) ++ word s ++ many (some isspace) >> fun ((_, t), _) -> t let decimal = - let (||) = parser_or in + let ( || ) = parser_or in let numeral = some isnum in - let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in - let decimalfrac = atleast 1 numeral - >> (fun s -> Num.num_of_string(implode s) // pow10 (List.length s)) in + let decimalint = atleast 1 numeral >> o Num.num_of_string implode in + let decimalfrac = + atleast 1 numeral + >> fun s -> Num.num_of_string (implode s) // pow10 (List.length s) + in let decimalsig = decimalint ++ possibly (a "." ++ decimalfrac >> snd) - >> (function (h,[x]) -> h +/ x | (h,_) -> h) in + >> function h, [x] -> h +/ x | h, _ -> h + in let signed prs = - a "-" ++ prs >> ((o) minus_num snd) - || a "+" ++ prs >> snd - || prs in + a "-" ++ prs >> o minus_num snd || a "+" ++ prs >> snd || prs + in let exponent = (a "e" || a "E") ++ signed decimalint >> snd in - signed decimalsig ++ possibly exponent - >> (function (h,[x]) -> h */ power_num (Int 10) x | (h,_) -> h);; + signed decimalsig ++ possibly exponent + >> function h, [x] -> h */ power_num (Int 10) x | h, _ -> h let mkparser p s = - let x,rst = p(explode s) in - if rst = [] then x else failwith "mkparser: unparsed input";; + let x, rst = p (explode s) in + if rst = [] then x else failwith "mkparser: unparsed input" (* ------------------------------------------------------------------------- *) (* Parse back a vector. *) (* ------------------------------------------------------------------------- *) let _parse_sdpaoutput, parse_csdpoutput = - let (||) = parser_or in + let ( || ) = parser_or in let vector = token "{" ++ listof decimal (token ",") "decimal" ++ token "}" - >> (fun ((_,v),_) -> vector_of_list v) in + >> fun ((_, v), _) -> vector_of_list v + in let rec skipupto dscr prs inp = - (dscr ++ prs >> snd - || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in - let ignore inp = (),[] in + (dscr ++ prs >> snd || some (fun c -> true) ++ skipupto dscr prs >> snd) inp + in + let ignore inp = ((), []) in let sdpaoutput = - skipupto (word "xVec" ++ token "=") - (vector ++ ignore >> fst) in + skipupto (word "xVec" ++ token "=") (vector ++ ignore >> fst) + in let csdpoutput = - (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++ - (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in - mkparser sdpaoutput,mkparser csdpoutput;; + (decimal ++ many (a " " ++ decimal >> snd) >> fun (h, t) -> h :: t) + ++ (a " " ++ a "\n" ++ ignore) + >> o vector_of_list fst + in + (mkparser sdpaoutput, mkparser csdpoutput) (* ------------------------------------------------------------------------- *) (* The default parameters. Unfortunately this goes to a fixed file. *) (* ------------------------------------------------------------------------- *) let _sdpa_default_parameters = -"100 unsigned int maxIteration;\ -\n1.0E-7 double 0.0 < epsilonStar;\ -\n1.0E2 double 0.0 < lambdaStar;\ -\n2.0 double 1.0 < omegaStar;\ -\n-1.0E5 double lowerBound;\ -\n1.0E5 double upperBound;\ -\n0.1 double 0.0 <= betaStar < 1.0;\ -\n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\ -\n0.9 double 0.0 < gammaStar < 1.0;\ -\n1.0E-7 double 0.0 < epsilonDash;\ -\n";; + "100 unsigned int maxIteration;\n\ + 1.0E-7 double 0.0 < epsilonStar;\n\ + 1.0E2 double 0.0 < lambdaStar;\n\ + 2.0 double 1.0 < omegaStar;\n\ + -1.0E5 double lowerBound;\n\ + 1.0E5 double upperBound;\n\ + 0.1 double 0.0 <= betaStar < 1.0;\n\ + 0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\n\ + 0.9 double 0.0 < gammaStar < 1.0;\n\ + 1.0E-7 double 0.0 < epsilonDash;\n" (* ------------------------------------------------------------------------- *) (* These were suggested by Makoto Yamashita for problems where we are *) @@ -402,42 +404,40 @@ let _sdpa_default_parameters = (* ------------------------------------------------------------------------- *) let sdpa_alt_parameters = -"1000 unsigned int maxIteration;\ -\n1.0E-7 double 0.0 < epsilonStar;\ -\n1.0E4 double 0.0 < lambdaStar;\ -\n2.0 double 1.0 < omegaStar;\ -\n-1.0E5 double lowerBound;\ -\n1.0E5 double upperBound;\ -\n0.1 double 0.0 <= betaStar < 1.0;\ -\n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\ -\n0.9 double 0.0 < gammaStar < 1.0;\ -\n1.0E-7 double 0.0 < epsilonDash;\ -\n";; + "1000 unsigned int maxIteration;\n\ + 1.0E-7 double 0.0 < epsilonStar;\n\ + 1.0E4 double 0.0 < lambdaStar;\n\ + 2.0 double 1.0 < omegaStar;\n\ + -1.0E5 double lowerBound;\n\ + 1.0E5 double upperBound;\n\ + 0.1 double 0.0 <= betaStar < 1.0;\n\ + 0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\n\ + 0.9 double 0.0 < gammaStar < 1.0;\n\ + 1.0E-7 double 0.0 < epsilonDash;\n" -let _sdpa_params = sdpa_alt_parameters;; +let _sdpa_params = sdpa_alt_parameters (* ------------------------------------------------------------------------- *) (* CSDP parameters; so far I'm sticking with the defaults. *) (* ------------------------------------------------------------------------- *) let csdp_default_parameters = -"axtol=1.0e-8\ -\natytol=1.0e-8\ -\nobjtol=1.0e-8\ -\npinftol=1.0e8\ -\ndinftol=1.0e8\ -\nmaxiter=100\ -\nminstepfrac=0.9\ -\nmaxstepfrac=0.97\ -\nminstepp=1.0e-8\ -\nminstepd=1.0e-8\ -\nusexzgap=1\ -\ntweakgap=0\ -\naffine=0\ -\nprintlevel=1\ -\n";; - -let csdp_params = csdp_default_parameters;; + "axtol=1.0e-8\n\ + atytol=1.0e-8\n\ + objtol=1.0e-8\n\ + pinftol=1.0e8\n\ + dinftol=1.0e8\n\ + maxiter=100\n\ + minstepfrac=0.9\n\ + maxstepfrac=0.97\n\ + minstepp=1.0e-8\n\ + minstepd=1.0e-8\n\ + usexzgap=1\n\ + tweakgap=0\n\ + affine=0\n\ + printlevel=1\n" + +let csdp_params = csdp_default_parameters (* ------------------------------------------------------------------------- *) (* Now call CSDP on a problem and parse back the output. *) @@ -450,14 +450,15 @@ let run_csdp dbg obj mats = and params_file = Filename.concat temp_path "param.csdp" in file_of_string input_file (sdpa_of_problem "" obj mats); file_of_string params_file csdp_params; - let rv = Sys.command("cd "^temp_path^"; csdp "^input_file ^ - " " ^ output_file ^ - (if dbg then "" else "> /dev/null")) in + let rv = + Sys.command + ( "cd " ^ temp_path ^ "; csdp " ^ input_file ^ " " ^ output_file + ^ if dbg then "" else "> /dev/null" ) + in let op = string_of_file output_file in let res = parse_csdpoutput op in - ((if dbg then () - else (Sys.remove input_file; Sys.remove output_file)); - rv,res);; + if dbg then () else (Sys.remove input_file; Sys.remove output_file); + (rv, res) (* ------------------------------------------------------------------------- *) (* Try some apparently sensible scaling first. Note that this is purely to *) @@ -470,27 +471,27 @@ let scale_then = let common_denominator amat acc = foldl (fun a m c -> lcm_num (denominator c) a) acc amat and maximal_element amat acc = - foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in + foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat + in fun solver obj mats -> let cd1 = List.fold_right common_denominator mats (Int 1) - and cd2 = common_denominator (snd obj) (Int 1) in + and cd2 = common_denominator (snd obj) (Int 1) in let mats' = List.map (mapf (fun x -> cd1 */ x)) mats and obj' = vector_cmul cd2 obj in let max1 = List.fold_right maximal_element mats' (Int 0) and max2 = maximal_element (snd obj') (Int 0) in - let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0)) - and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in + let scal1 = pow2 (20 - int_of_float (log (float_of_num max1) /. log 2.0)) + and scal2 = pow2 (20 - int_of_float (log (float_of_num max2) /. log 2.0)) in let mats'' = List.map (mapf (fun x -> x */ scal1)) mats' and obj'' = vector_cmul scal2 obj' in - solver obj'' mats'';; + solver obj'' mats'' (* ------------------------------------------------------------------------- *) (* Round a vector to "nice" rationals. *) (* ------------------------------------------------------------------------- *) -let nice_rational n x = round_num (n */ x) // n;; - -let nice_vector n = mapa (nice_rational n);; +let nice_rational n x = round_num (n */ x) // n +let nice_vector n = mapa (nice_rational n) (* ------------------------------------------------------------------------- *) (* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *) @@ -498,13 +499,13 @@ let nice_vector n = mapa (nice_rational n);; (* ------------------------------------------------------------------------- *) let linear_program_basic a = - let m,n = dimensions a in - let mats = List.map (fun j -> diagonal (column j a)) (1--n) + let m, n = dimensions a in + let mats = List.map (fun j -> diagonal (column j a)) (1 -- n) and obj = vector_const (Int 1) m in - let rv,res = run_csdp false obj mats in + let rv, res = run_csdp false obj mats in if rv = 1 || rv = 2 then false else if rv = 0 then true - else failwith "linear_program: An error occurred in the SDP solver";; + else failwith "linear_program: An error occurred in the SDP solver" (* ------------------------------------------------------------------------- *) (* Test whether a point is in the convex hull of others. Rather than use *) @@ -513,16 +514,17 @@ let linear_program_basic a = (* ------------------------------------------------------------------------- *) let in_convex_hull pts pt = - let pts1 = (1::pt) :: List.map (fun x -> 1::x) pts in + let pts1 = (1 :: pt) :: List.map (fun x -> 1 :: x) pts in let pts2 = List.map (fun p -> List.map (fun x -> -x) p @ p) pts1 in - let n = List.length pts + 1 - and v = 2 * (List.length pt + 1) in + let n = List.length pts + 1 and v = 2 * (List.length pt + 1) in let m = v + n - 1 in let mat = - (m,n), - itern 1 pts2 (fun pts j -> itern 1 pts (fun x i -> (i,j) |-> Int x)) - (iter (1,n) (fun i -> (v + i,i+1) |-> Int 1) undefined) in - linear_program_basic mat;; + ( (m, n) + , itern 1 pts2 + (fun pts j -> itern 1 pts (fun x i -> (i, j) |-> Int x)) + (iter (1, n) (fun i -> (v + i, i + 1) |-> Int 1) undefined) ) + in + linear_program_basic mat (* ------------------------------------------------------------------------- *) (* Filter down a set of points to a minimal set with the same convex hull. *) @@ -531,24 +533,23 @@ let in_convex_hull pts pt = let minimal_convex_hull = let augment1 = function | [] -> assert false - | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in - let augment m ms = funpow 3 augment1 (m::ms) in + | m :: ms -> if in_convex_hull ms m then ms else ms @ [m] + in + let augment m ms = funpow 3 augment1 (m :: ms) in fun mons -> let mons' = List.fold_right augment (List.tl mons) [List.hd mons] in - funpow (List.length mons') augment1 mons';; + funpow (List.length mons') augment1 mons' (* ------------------------------------------------------------------------- *) (* Stuff for "equations" (generic A->num functions). *) (* ------------------------------------------------------------------------- *) -let equation_cmul c eq = - if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq;; - -let equation_add eq1 eq2 = combine (+/) (fun x -> x =/ Int 0) eq1 eq2;; +let equation_cmul c eq = if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq +let equation_add eq1 eq2 = combine ( +/ ) (fun x -> x =/ Int 0) eq1 eq2 let equation_eval assig eq = let value v = apply assig v in - foldl (fun a v c -> a +/ value(v) */ c) (Int 0) eq;; + foldl (fun a v c -> a +/ (value v */ c)) (Int 0) eq (* ------------------------------------------------------------------------- *) (* Eliminate all variables, in an essentially arbitrary order. *) @@ -556,29 +557,35 @@ let equation_eval assig eq = let eliminate_all_equations one = let choose_variable eq = - let (v,_) = choose eq in + let v, _ = choose eq in if v = one then let eq' = undefine v eq in - if is_undefined eq' then failwith "choose_variable" else - let (w,_) = choose eq' in w - else v in + if is_undefined eq' then failwith "choose_variable" + else + let w, _ = choose eq' in + w + else v + in let rec eliminate dun eqs = match eqs with - [] -> dun - | eq::oeqs -> - if is_undefined eq then eliminate dun oeqs else + | [] -> dun + | eq :: oeqs -> + if is_undefined eq then eliminate dun oeqs + else let v = choose_variable eq in let a = apply eq v in - let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in + let eq' = equation_cmul (Int (-1) // a) (undefine v eq) in let elim e = let b = tryapplyd e v (Int 0) in - if b =/ Int 0 then e else - equation_add e (equation_cmul (minus_num b // a) eq) in - eliminate ((v |-> eq') (mapf elim dun)) (List.map elim oeqs) in + if b =/ Int 0 then e + else equation_add e (equation_cmul (minus_num b // a) eq) + in + eliminate ((v |-> eq') (mapf elim dun)) (List.map elim oeqs) + in fun eqs -> let assig = eliminate undefined eqs in let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in - setify vs,assig;; + (setify vs, assig) (* ------------------------------------------------------------------------- *) (* Hence produce the "relevant" monomials: those whose squares lie in the *) @@ -593,14 +600,23 @@ let eliminate_all_equations one = let newton_polytope pol = let vars = poly_variables pol in - let mons = List.map (fun m -> List.map (fun x -> monomial_degree x m) vars) (dom pol) + let mons = + List.map (fun m -> List.map (fun x -> monomial_degree x m) vars) (dom pol) and ds = List.map (fun x -> (degree x pol + 1) / 2) vars in - let all = List.fold_right (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] + let all = + List.fold_right (fun n -> allpairs (fun h t -> h :: t) (0 -- n)) ds [[]] and mons' = minimal_convex_hull mons in let all' = - List.filter (fun m -> in_convex_hull mons' (List.map (fun x -> 2 * x) m)) all in - List.map (fun m -> List.fold_right2 (fun v i a -> if i = 0 then a else (v |-> i) a) - vars m monomial_1) (List.rev all');; + List.filter + (fun m -> in_convex_hull mons' (List.map (fun x -> 2 * x) m)) + all + in + List.map + (fun m -> + List.fold_right2 + (fun v i a -> if i = 0 then a else (v |-> i) a) + vars m monomial_1) + (List.rev all') (* ------------------------------------------------------------------------- *) (* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *) @@ -609,40 +625,55 @@ let newton_polytope pol = let diag m = let nn = dimensions m in let n = fst nn in - if snd nn <> n then failwith "diagonalize: non-square matrix" else - let rec diagonalize i m = - if is_zero m then [] else - let a11 = element m (i,i) in - if a11 </ Int 0 then failwith "diagonalize: not PSD" - else if a11 =/ Int 0 then - if is_zero(row i m) then diagonalize (i + 1) m - else failwith "diagonalize: not PSD" - else - let v = row i m in - let v' = mapa (fun a1k -> a1k // a11) v in - let m' = - (n,n), - iter (i+1,n) (fun j -> - iter (i+1,n) (fun k -> - ((j,k) |--> (element m (j,k) -/ element v j */ element v' k)))) - undefined in - (a11,v')::diagonalize (i + 1) m' in - diagonalize 1 m;; + if snd nn <> n then failwith "diagonalize: non-square matrix" + else + let rec diagonalize i m = + if is_zero m then [] + else + let a11 = element m (i, i) in + if a11 </ Int 0 then failwith "diagonalize: not PSD" + else if a11 =/ Int 0 then + if is_zero (row i m) then diagonalize (i + 1) m + else failwith "diagonalize: not PSD" + else + let v = row i m in + let v' = mapa (fun a1k -> a1k // a11) v in + let m' = + ( (n, n) + , iter + (i + 1, n) + (fun j -> + iter + (i + 1, n) + (fun k -> + (j, k) + |--> element m (j, k) -/ (element v j */ element v' k))) + undefined ) + in + (a11, v') :: diagonalize (i + 1) m' + in + diagonalize 1 m (* ------------------------------------------------------------------------- *) (* Adjust a diagonalization to collect rationals at the start. *) (* ------------------------------------------------------------------------- *) let deration d = - if d = [] then Int 0,d else - let adj(c,l) = - let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) // - foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in - (c // (a */ a)),mapa (fun x -> a */ x) l in - let d' = List.map adj d in - let a = List.fold_right ((o) lcm_num ( (o) denominator fst)) d' (Int 1) // - List.fold_right ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in - (Int 1 // a),List.map (fun (c,l) -> (a */ c,l)) d';; + if d = [] then (Int 0, d) + else + let adj (c, l) = + let a = + foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) + // foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) + in + (c // (a */ a), mapa (fun x -> a */ x) l) + in + let d' = List.map adj d in + let a = + List.fold_right (o lcm_num (o denominator fst)) d' (Int 1) + // List.fold_right (o gcd_num (o numerator fst)) d' (Int 0) + in + (Int 1 // a, List.map (fun (c, l) -> (a */ c, l)) d') (* ------------------------------------------------------------------------- *) (* Enumeration of monomials with given multidegree bound. *) @@ -651,12 +682,18 @@ let deration d = let rec enumerate_monomials d vars = if d < 0 then [] else if d = 0 then [undefined] - else if vars = [] then [monomial_1] else - let alts = - List.map (fun k -> let oths = enumerate_monomials (d - k) (List.tl vars) in - List.map (fun ks -> if k = 0 then ks else (List.hd vars |-> k) ks) oths) - (0--d) in - end_itlist (@) alts;; + else if vars = [] then [monomial_1] + else + let alts = + List.map + (fun k -> + let oths = enumerate_monomials (d - k) (List.tl vars) in + List.map + (fun ks -> if k = 0 then ks else (List.hd vars |-> k) ks) + oths) + (0 -- d) + in + end_itlist ( @ ) alts (* ------------------------------------------------------------------------- *) (* Enumerate products of distinct input polys with degree <= d. *) @@ -665,46 +702,57 @@ let rec enumerate_monomials d vars = (* ------------------------------------------------------------------------- *) let rec enumerate_products d pols = - if d = 0 then [poly_const num_1,Rational_lt num_1] else if d < 0 then [] else - match pols with - [] -> [poly_const num_1,Rational_lt num_1] - | (p,b)::ps -> let e = multidegree p in - if e = 0 then enumerate_products d ps else - enumerate_products d ps @ - List.map (fun (q,c) -> poly_mul p q,Product(b,c)) - (enumerate_products (d - e) ps);; + if d = 0 then [(poly_const num_1, Rational_lt num_1)] + else if d < 0 then [] + else + match pols with + | [] -> [(poly_const num_1, Rational_lt num_1)] + | (p, b) :: ps -> + let e = multidegree p in + if e = 0 then enumerate_products d ps + else + enumerate_products d ps + @ List.map + (fun (q, c) -> (poly_mul p q, Product (b, c))) + (enumerate_products (d - e) ps) (* ------------------------------------------------------------------------- *) (* Multiply equation-parametrized poly by regular poly and add accumulator. *) (* ------------------------------------------------------------------------- *) let epoly_pmul p q acc = - foldl (fun a m1 c -> - foldl (fun b m2 e -> - let m = monomial_mul m1 m2 in - let es = tryapplyd b m undefined in - (m |-> equation_add (equation_cmul c e) es) b) - a q) acc p;; + foldl + (fun a m1 c -> + foldl + (fun b m2 e -> + let m = monomial_mul m1 m2 in + let es = tryapplyd b m undefined in + (m |-> equation_add (equation_cmul c e) es) b) + a q) + acc p (* ------------------------------------------------------------------------- *) (* Convert regular polynomial. Note that we treat (0,0,0) as -1. *) (* ------------------------------------------------------------------------- *) let epoly_of_poly p = - foldl (fun a m c -> (m |-> ((0,0,0) |=> minus_num c)) a) undefined p;; + foldl (fun a m c -> (m |-> ((0, 0, 0) |=> minus_num c)) a) undefined p (* ------------------------------------------------------------------------- *) (* String for block diagonal matrix numbered k. *) (* ------------------------------------------------------------------------- *) let sdpa_of_blockdiagonal k m = - let pfx = string_of_int k ^" " in + let pfx = string_of_int k ^ " " in let ents = - foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in + foldl (fun a (b, i, j) c -> if i > j then a else ((b, i, j), c) :: a) [] m + in let entss = sort (increasing fst) ents in - List.fold_right (fun ((b,i,j),c) a -> - pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ - " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; + List.fold_right + (fun ((b, i, j), c) a -> + pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j + ^ " " ^ decimalize 20 c ^ "\n" ^ a) + entss "" (* ------------------------------------------------------------------------- *) (* SDPA for problem using block diagonal (i.e. multiple SDPs) *) @@ -712,14 +760,14 @@ let sdpa_of_blockdiagonal k m = let sdpa_of_blockproblem comment nblocks blocksizes obj mats = let m = List.length mats - 1 in - "\"" ^ comment ^ "\"\n" ^ - string_of_int m ^ "\n" ^ - string_of_int nblocks ^ "\n" ^ - (String.concat " " (List.map string_of_int blocksizes)) ^ - "\n" ^ - sdpa_of_vector obj ^ - List.fold_right2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) - (1--List.length mats) mats "";; + "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ string_of_int nblocks + ^ "\n" + ^ String.concat " " (List.map string_of_int blocksizes) + ^ "\n" ^ sdpa_of_vector obj + ^ List.fold_right2 + (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) + (1 -- List.length mats) + mats "" (* ------------------------------------------------------------------------- *) (* Hence run CSDP on a problem in block diagonal form. *) @@ -731,254 +779,319 @@ let run_csdp dbg nblocks blocksizes obj mats = String.sub input_file 0 (String.length input_file - 6) ^ ".out" and params_file = Filename.concat temp_path "param.csdp" in file_of_string input_file - (sdpa_of_blockproblem "" nblocks blocksizes obj mats); + (sdpa_of_blockproblem "" nblocks blocksizes obj mats); file_of_string params_file csdp_params; - let rv = Sys.command("cd "^temp_path^"; csdp "^input_file ^ - " " ^ output_file ^ - (if dbg then "" else "> /dev/null")) in + let rv = + Sys.command + ( "cd " ^ temp_path ^ "; csdp " ^ input_file ^ " " ^ output_file + ^ if dbg then "" else "> /dev/null" ) + in let op = string_of_file output_file in let res = parse_csdpoutput op in - ((if dbg then () - else (Sys.remove input_file; Sys.remove output_file)); - rv,res);; + if dbg then () else (Sys.remove input_file; Sys.remove output_file); + (rv, res) let csdp nblocks blocksizes obj mats = - let rv,res = run_csdp (!debugging) nblocks blocksizes obj mats in - (if rv = 1 || rv = 2 then failwith "csdp: Problem is infeasible" - else if rv = 3 then () + let rv, res = run_csdp !debugging nblocks blocksizes obj mats in + if rv = 1 || rv = 2 then failwith "csdp: Problem is infeasible" + else if rv = 3 then () (*Format.print_string "csdp warning: Reduced accuracy"; Format.print_newline() *) - else if rv <> 0 then failwith("csdp: error "^string_of_int rv) - else ()); - res;; + else if rv <> 0 then failwith ("csdp: error " ^ string_of_int rv) + else (); + res (* ------------------------------------------------------------------------- *) (* 3D versions of matrix operations to consider blocks separately. *) (* ------------------------------------------------------------------------- *) -let bmatrix_add = combine (+/) (fun x -> x =/ Int 0);; +let bmatrix_add = combine ( +/ ) (fun x -> x =/ Int 0) let bmatrix_cmul c bm = - if c =/ Int 0 then undefined - else mapf (fun x -> c */ x) bm;; + if c =/ Int 0 then undefined else mapf (fun x -> c */ x) bm -let bmatrix_neg = bmatrix_cmul (Int(-1));; +let bmatrix_neg = bmatrix_cmul (Int (-1)) (* ------------------------------------------------------------------------- *) (* Smash a block matrix into components. *) (* ------------------------------------------------------------------------- *) let blocks blocksizes bm = - List.map (fun (bs,b0) -> - let m = foldl - (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a) - undefined bm in - (((bs,bs),m):matrix)) - (List.combine blocksizes (1--List.length blocksizes));; + List.map + (fun (bs, b0) -> + let m = + foldl + (fun a (b, i, j) c -> if b = b0 then ((i, j) |-> c) a else a) + undefined bm + in + (((bs, bs), m) : matrix)) + (List.combine blocksizes (1 -- List.length blocksizes)) (* ------------------------------------------------------------------------- *) (* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *) (* ------------------------------------------------------------------------- *) let real_positivnullstellensatz_general linf d eqs leqs pol = - let vars = List.fold_right ((o) union poly_variables) (pol::eqs @ List.map fst leqs) [] in + let vars = + List.fold_right (o union poly_variables) + ((pol :: eqs) @ List.map fst leqs) + [] + in let monoid = if linf then - (poly_const num_1,Rational_lt num_1):: - (List.filter (fun (p,c) -> multidegree p <= d) leqs) - else enumerate_products d leqs in + (poly_const num_1, Rational_lt num_1) + :: List.filter (fun (p, c) -> multidegree p <= d) leqs + else enumerate_products d leqs + in let nblocks = List.length monoid in let mk_idmultiplier k p = let e = d - multidegree p in let mons = enumerate_monomials e vars in - let nons = List.combine mons (1--List.length mons) in - mons, - List.fold_right (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in - let mk_sqmultiplier k (p,c) = + let nons = List.combine mons (1 -- List.length mons) in + ( mons + , List.fold_right + (fun (m, n) -> m |-> ((-k, -n, n) |=> Int 1)) + nons undefined ) + in + let mk_sqmultiplier k (p, c) = let e = (d - multidegree p) / 2 in let mons = enumerate_monomials e vars in - let nons = List.combine mons (1--List.length mons) in - mons, - List.fold_right (fun (m1,n1) -> - List.fold_right (fun (m2,n2) a -> - let m = monomial_mul m1 m2 in - if n1 > n2 then a else - let c = if n1 = n2 then Int 1 else Int 2 in - let e = tryapplyd a m undefined in - (m |-> equation_add ((k,n1,n2) |=> c) e) a) - nons) - nons undefined in - let sqmonlist,sqs = List.split(List.map2 mk_sqmultiplier (1--List.length monoid) monoid) - and idmonlist,ids = List.split(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in + let nons = List.combine mons (1 -- List.length mons) in + ( mons + , List.fold_right + (fun (m1, n1) -> + List.fold_right + (fun (m2, n2) a -> + let m = monomial_mul m1 m2 in + if n1 > n2 then a + else + let c = if n1 = n2 then Int 1 else Int 2 in + let e = tryapplyd a m undefined in + (m |-> equation_add ((k, n1, n2) |=> c) e) a) + nons) + nons undefined ) + in + let sqmonlist, sqs = + List.split (List.map2 mk_sqmultiplier (1 -- List.length monoid) monoid) + and idmonlist, ids = + List.split (List.map2 mk_idmultiplier (1 -- List.length eqs) eqs) + in let blocksizes = List.map List.length sqmonlist in let bigsum = - List.fold_right2 (fun p q a -> epoly_pmul p q a) eqs ids - (List.fold_right2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs - (epoly_of_poly(poly_neg pol))) in - let eqns = foldl (fun a m e -> e::a) [] bigsum in - let pvs,assig = eliminate_all_equations (0,0,0) eqns in - let qvars = (0,0,0)::pvs in - let allassig = List.fold_right (fun v -> (v |-> (v |=> Int 1))) pvs assig in + List.fold_right2 + (fun p q a -> epoly_pmul p q a) + eqs ids + (List.fold_right2 + (fun (p, c) s a -> epoly_pmul p s a) + monoid sqs + (epoly_of_poly (poly_neg pol))) + in + let eqns = foldl (fun a m e -> e :: a) [] bigsum in + let pvs, assig = eliminate_all_equations (0, 0, 0) eqns in + let qvars = (0, 0, 0) :: pvs in + let allassig = List.fold_right (fun v -> v |-> (v |=> Int 1)) pvs assig in let mk_matrix v = - foldl (fun m (b,i,j) ass -> if b < 0 then m else - let c = tryapplyd ass v (Int 0) in - if c =/ Int 0 then m else - ((b,j,i) |-> c) (((b,i,j) |-> c) m)) - undefined allassig in - let diagents = foldl - (fun a (b,i,j) e -> if b > 0 && i = j then equation_add e a else a) - undefined allassig in + foldl + (fun m (b, i, j) ass -> + if b < 0 then m + else + let c = tryapplyd ass v (Int 0) in + if c =/ Int 0 then m else ((b, j, i) |-> c) (((b, i, j) |-> c) m)) + undefined allassig + in + let diagents = + foldl + (fun a (b, i, j) e -> if b > 0 && i = j then equation_add e a else a) + undefined allassig + in let mats = List.map mk_matrix qvars - and obj = List.length pvs, - itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) - undefined in - let raw_vec = if pvs = [] then vector_0 0 - else scale_then (csdp nblocks blocksizes) obj mats in + and obj = + ( List.length pvs + , itern 1 pvs (fun v i -> i |--> tryapplyd diagents v (Int 0)) undefined ) + in + let raw_vec = + if pvs = [] then vector_0 0 + else scale_then (csdp nblocks blocksizes) obj mats + in let find_rounding d = - (if !debugging then - (Format.print_string("Trying rounding with limit "^string_of_num d); - Format.print_newline()) - else ()); + if !debugging then ( + Format.print_string ("Trying rounding with limit " ^ string_of_num d); + Format.print_newline () ) + else (); let vec = nice_vector d raw_vec in - let blockmat = iter (1,dim vec) - (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (List.nth mats i)) a) - (bmatrix_neg (List.nth mats 0)) in + let blockmat = + iter + (1, dim vec) + (fun i a -> + bmatrix_add (bmatrix_cmul (element vec i) (List.nth mats i)) a) + (bmatrix_neg (List.nth mats 0)) + in let allmats = blocks blocksizes blockmat in - vec,List.map diag allmats in - let vec,ratdias = + (vec, List.map diag allmats) + in + let vec, ratdias = if pvs = [] then find_rounding num_1 - else tryfind find_rounding (List.map Num.num_of_int (1--31) @ - List.map pow2 (5--66)) in + else + tryfind find_rounding + (List.map Num.num_of_int (1 -- 31) @ List.map pow2 (5 -- 66)) + in let newassigs = - List.fold_right (fun k -> List.nth pvs (k - 1) |-> element vec k) - (1--dim vec) ((0,0,0) |=> Int(-1)) in + List.fold_right + (fun k -> List.nth pvs (k - 1) |-> element vec k) + (1 -- dim vec) + ((0, 0, 0) |=> Int (-1)) + in let finalassigs = - foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs - allassig in + foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs allassig + in let poly_of_epoly p = - foldl (fun a v e -> (v |--> equation_eval finalassigs e) a) - undefined p in + foldl (fun a v e -> (v |--> equation_eval finalassigs e) a) undefined p + in let mk_sos mons = - let mk_sq (c,m) = - c,List.fold_right (fun k a -> (List.nth mons (k - 1) |--> element m k) a) - (1--List.length mons) undefined in - List.map mk_sq in + let mk_sq (c, m) = + ( c + , List.fold_right + (fun k a -> (List.nth mons (k - 1) |--> element m k) a) + (1 -- List.length mons) + undefined ) + in + List.map mk_sq + in let sqs = List.map2 mk_sos sqmonlist ratdias and cfs = List.map poly_of_epoly ids in - let msq = List.filter (fun (a,b) -> b <> []) (List.map2 (fun a b -> a,b) monoid sqs) in - let eval_sq sqs = List.fold_right - (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in + let msq = + List.filter + (fun (a, b) -> b <> []) + (List.map2 (fun a b -> (a, b)) monoid sqs) + in + let eval_sq sqs = + List.fold_right + (fun (c, q) -> poly_add (poly_cmul c (poly_mul q q))) + sqs poly_0 + in let sanity = - List.fold_right (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq - (List.fold_right2 (fun p q -> poly_add (poly_mul p q)) cfs eqs - (poly_neg pol)) in - if not(is_undefined sanity) then raise Sanity else - cfs,List.map (fun (a,b) -> snd a,b) msq;; + List.fold_right + (fun ((p, c), s) -> poly_add (poly_mul p (eval_sq s))) + msq + (List.fold_right2 + (fun p q -> poly_add (poly_mul p q)) + cfs eqs (poly_neg pol)) + in + if not (is_undefined sanity) then raise Sanity + else (cfs, List.map (fun (a, b) -> (snd a, b)) msq) (* ------------------------------------------------------------------------- *) (* The ordering so we can create canonical HOL polynomials. *) (* ------------------------------------------------------------------------- *) -let dest_monomial mon = sort (increasing fst) (graph mon);; +let dest_monomial mon = sort (increasing fst) (graph mon) let monomial_order = let rec lexorder l1 l2 = - match (l1,l2) with - [],[] -> true - | vps,[] -> false - | [],vps -> true - | ((x1,n1)::vs1),((x2,n2)::vs2) -> - if x1 < x2 then true - else if x2 < x1 then false - else if n1 < n2 then false - else if n2 < n1 then true - else lexorder vs1 vs2 in + match (l1, l2) with + | [], [] -> true + | vps, [] -> false + | [], vps -> true + | (x1, n1) :: vs1, (x2, n2) :: vs2 -> + if x1 < x2 then true + else if x2 < x1 then false + else if n1 < n2 then false + else if n2 < n1 then true + else lexorder vs1 vs2 + in fun m1 m2 -> - if m2 = monomial_1 then true else if m1 = monomial_1 then false else - let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in - let deg1 = List.fold_right ((o) (+) snd) mon1 0 - and deg2 = List.fold_right ((o) (+) snd) mon2 0 in - if deg1 < deg2 then false else if deg1 > deg2 then true - else lexorder mon1 mon2;; + if m2 = monomial_1 then true + else if m1 = monomial_1 then false + else + let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in + let deg1 = List.fold_right (o ( + ) snd) mon1 0 + and deg2 = List.fold_right (o ( + ) snd) mon2 0 in + if deg1 < deg2 then false + else if deg1 > deg2 then true + else lexorder mon1 mon2 (* ------------------------------------------------------------------------- *) (* Map back polynomials and their composites to HOL. *) (* ------------------------------------------------------------------------- *) -let term_of_varpow = - fun x k -> - if k = 1 then Var x else Pow (Var x, k);; +let term_of_varpow x k = if k = 1 then Var x else Pow (Var x, k) -let term_of_monomial = - fun m -> if m = monomial_1 then Const num_1 else - let m' = dest_monomial m in - let vps = List.fold_right (fun (x,k) a -> term_of_varpow x k :: a) m' [] in - end_itlist (fun s t -> Mul (s,t)) vps;; +let term_of_monomial m = + if m = monomial_1 then Const num_1 + else + let m' = dest_monomial m in + let vps = List.fold_right (fun (x, k) a -> term_of_varpow x k :: a) m' [] in + end_itlist (fun s t -> Mul (s, t)) vps -let term_of_cmonomial = - fun (m,c) -> - if m = monomial_1 then Const c - else if c =/ num_1 then term_of_monomial m - else Mul (Const c,term_of_monomial m);; +let term_of_cmonomial (m, c) = + if m = monomial_1 then Const c + else if c =/ num_1 then term_of_monomial m + else Mul (Const c, term_of_monomial m) -let term_of_poly = - fun p -> - if p = poly_0 then Zero else - let cms = List.map term_of_cmonomial - (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in - end_itlist (fun t1 t2 -> Add (t1,t2)) cms;; +let term_of_poly p = + if p = poly_0 then Zero + else + let cms = + List.map term_of_cmonomial + (sort (fun (m1, _) (m2, _) -> monomial_order m1 m2) (graph p)) + in + end_itlist (fun t1 t2 -> Add (t1, t2)) cms -let term_of_sqterm (c,p) = - Product(Rational_lt c,Square(term_of_poly p));; +let term_of_sqterm (c, p) = Product (Rational_lt c, Square (term_of_poly p)) -let term_of_sos (pr,sqs) = +let term_of_sos (pr, sqs) = if sqs = [] then pr - else Product(pr,end_itlist (fun a b -> Sum(a,b)) (List.map term_of_sqterm sqs));; + else + Product + (pr, end_itlist (fun a b -> Sum (a, b)) (List.map term_of_sqterm sqs)) (* ------------------------------------------------------------------------- *) (* Some combinatorial helper functions. *) (* ------------------------------------------------------------------------- *) let rec allpermutations l = - if l = [] then [[]] else - List.fold_right (fun h acc -> List.map (fun t -> h::t) - (allpermutations (subtract l [h])) @ acc) l [];; + if l = [] then [[]] + else + List.fold_right + (fun h acc -> + List.map (fun t -> h :: t) (allpermutations (subtract l [h])) @ acc) + l [] -let changevariables_monomial zoln (m:monomial) = - foldl (fun a x k -> (List.assoc x zoln |-> k) a) monomial_1 m;; +let changevariables_monomial zoln (m : monomial) = + foldl (fun a x k -> (List.assoc x zoln |-> k) a) monomial_1 m let changevariables zoln pol = - foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a) - poly_0 pol;; + foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a) poly_0 pol (* ------------------------------------------------------------------------- *) (* Return to original non-block matrices. *) (* ------------------------------------------------------------------------- *) -let sdpa_of_vector (v:vector) = +let sdpa_of_vector (v : vector) = let n = dim v in - let strs = List.map (o (decimalize 20) (element v)) (1--n) in - String.concat " " strs ^ "\n";; + let strs = List.map (o (decimalize 20) (element v)) (1 -- n) in + String.concat " " strs ^ "\n" -let sdpa_of_matrix k (m:matrix) = +let sdpa_of_matrix k (m : matrix) = let pfx = string_of_int k ^ " 1 " in - let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) - (snd m) [] in + let ms = + foldr (fun (i, j) c a -> if i > j then a else ((i, j), c) :: a) (snd m) [] + in let mss = sort (increasing fst) ms in - List.fold_right (fun ((i,j),c) a -> - pfx ^ string_of_int i ^ " " ^ string_of_int j ^ - " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; + List.fold_right + (fun ((i, j), c) a -> + pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c + ^ "\n" ^ a) + mss "" let sdpa_of_problem comment obj mats = - let m = List.length mats - 1 - and n,_ = dimensions (List.hd mats) in - "\"" ^ comment ^ "\"\n" ^ - string_of_int m ^ "\n" ^ - "1\n" ^ - string_of_int n ^ "\n" ^ - sdpa_of_vector obj ^ - List.fold_right2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) - (1--List.length mats) mats "";; + let m = List.length mats - 1 and n, _ = dimensions (List.hd mats) in + "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ "1\n" ^ string_of_int n + ^ "\n" ^ sdpa_of_vector obj + ^ List.fold_right2 + (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) + (1 -- List.length mats) + mats "" let run_csdp dbg obj mats = let input_file = Filename.temp_file "sos" ".dat-s" in @@ -987,109 +1100,139 @@ let run_csdp dbg obj mats = and params_file = Filename.concat temp_path "param.csdp" in file_of_string input_file (sdpa_of_problem "" obj mats); file_of_string params_file csdp_params; - let rv = Sys.command("cd "^temp_path^"; csdp "^input_file ^ - " " ^ output_file ^ - (if dbg then "" else "> /dev/null")) in + let rv = + Sys.command + ( "cd " ^ temp_path ^ "; csdp " ^ input_file ^ " " ^ output_file + ^ if dbg then "" else "> /dev/null" ) + in let op = string_of_file output_file in let res = parse_csdpoutput op in - ((if dbg then () - else (Sys.remove input_file; Sys.remove output_file)); - rv,res);; + if dbg then () else (Sys.remove input_file; Sys.remove output_file); + (rv, res) let csdp obj mats = - let rv,res = run_csdp (!debugging) obj mats in - (if rv = 1 || rv = 2 then failwith "csdp: Problem is infeasible" - else if rv = 3 then () -(* (Format.print_string "csdp warning: Reduced accuracy"; + let rv, res = run_csdp !debugging obj mats in + if rv = 1 || rv = 2 then failwith "csdp: Problem is infeasible" + else if rv = 3 then () + (* (Format.print_string "csdp warning: Reduced accuracy"; Format.print_newline()) *) - else if rv <> 0 then failwith("csdp: error "^string_of_int rv) - else ()); - res;; + else if rv <> 0 then failwith ("csdp: error " ^ string_of_int rv) + else (); + res (* ------------------------------------------------------------------------- *) (* Sum-of-squares function with some lowbrow symmetry reductions. *) (* ------------------------------------------------------------------------- *) let sumofsquares_general_symmetry tool pol = - let vars = poly_variables pol - and lpps = newton_polytope pol in + let vars = poly_variables pol and lpps = newton_polytope pol in let n = List.length lpps in let sym_eqs = - let invariants = List.filter - (fun vars' -> - is_undefined(poly_sub pol (changevariables (List.combine vars vars') pol))) - (allpermutations vars) in - let lpns = List.combine lpps (1--List.length lpps) in + let invariants = + List.filter + (fun vars' -> + is_undefined + (poly_sub pol (changevariables (List.combine vars vars') pol))) + (allpermutations vars) + in + let lpns = List.combine lpps (1 -- List.length lpps) in let lppcs = - List.filter (fun (m,(n1,n2)) -> n1 <= n2) - (allpairs - (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in - let clppcs = end_itlist (@) - (List.map (fun ((m1,m2),(n1,n2)) -> - List.map (fun vars' -> - (changevariables_monomial (List.combine vars vars') m1, - changevariables_monomial (List.combine vars vars') m2),(n1,n2)) - invariants) - lppcs) in - let clppcs_dom = setify(List.map fst clppcs) in - let clppcs_cls = List.map (fun d -> List.filter (fun (e,_) -> e = d) clppcs) - clppcs_dom in + List.filter + (fun (m, (n1, n2)) -> n1 <= n2) + (allpairs (fun (m1, n1) (m2, n2) -> ((m1, m2), (n1, n2))) lpns lpns) + in + let clppcs = + end_itlist ( @ ) + (List.map + (fun ((m1, m2), (n1, n2)) -> + List.map + (fun vars' -> + ( ( changevariables_monomial (List.combine vars vars') m1 + , changevariables_monomial (List.combine vars vars') m2 ) + , (n1, n2) )) + invariants) + lppcs) + in + let clppcs_dom = setify (List.map fst clppcs) in + let clppcs_cls = + List.map (fun d -> List.filter (fun (e, _) -> e = d) clppcs) clppcs_dom + in let eqvcls = List.map (o setify (List.map snd)) clppcs_cls in let mk_eq cls acc = match cls with - [] -> raise Sanity + | [] -> raise Sanity | [h] -> acc - | h::t -> List.map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in - List.fold_right mk_eq eqvcls [] in - let eqs = foldl (fun a x y -> y::a) [] - (itern 1 lpps (fun m1 n1 -> - itern 1 lpps (fun m2 n2 f -> - let m = monomial_mul m1 m2 in - if n1 > n2 then f else - let c = if n1 = n2 then Int 1 else Int 2 in - (m |-> ((n1,n2) |-> c) (tryapplyd f m undefined)) f)) - (foldl (fun a m c -> (m |-> ((0,0)|=>c)) a) - undefined pol)) @ - sym_eqs in - let pvs,assig = eliminate_all_equations (0,0) eqs in - let allassig = List.fold_right (fun v -> (v |-> (v |=> Int 1))) pvs assig in - let qvars = (0,0)::pvs in + | h :: t -> List.map (fun k -> (k |-> Int (-1)) (h |=> Int 1)) t @ acc + in + List.fold_right mk_eq eqvcls [] + in + let eqs = + foldl + (fun a x y -> y :: a) + [] + (itern 1 lpps + (fun m1 n1 -> + itern 1 lpps (fun m2 n2 f -> + let m = monomial_mul m1 m2 in + if n1 > n2 then f + else + let c = if n1 = n2 then Int 1 else Int 2 in + (m |-> ((n1, n2) |-> c) (tryapplyd f m undefined)) f)) + (foldl (fun a m c -> (m |-> ((0, 0) |=> c)) a) undefined pol)) + @ sym_eqs + in + let pvs, assig = eliminate_all_equations (0, 0) eqs in + let allassig = List.fold_right (fun v -> v |-> (v |=> Int 1)) pvs assig in + let qvars = (0, 0) :: pvs in let diagents = - end_itlist equation_add (List.map (fun i -> apply allassig (i,i)) (1--n)) in + end_itlist equation_add (List.map (fun i -> apply allassig (i, i)) (1 -- n)) + in let mk_matrix v = - ((n,n), - foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in - if c =/ Int 0 then m else - ((j,i) |-> c) (((i,j) |-> c) m)) - undefined allassig :matrix) in + ( ( (n, n) + , foldl + (fun m (i, j) ass -> + let c = tryapplyd ass v (Int 0) in + if c =/ Int 0 then m else ((j, i) |-> c) (((i, j) |-> c) m)) + undefined allassig ) + : matrix ) + in let mats = List.map mk_matrix qvars - and obj = List.length pvs, - itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) - undefined in + and obj = + ( List.length pvs + , itern 1 pvs (fun v i -> i |--> tryapplyd diagents v (Int 0)) undefined ) + in let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in let find_rounding d = - (if !debugging then - (Format.print_string("Trying rounding with limit "^string_of_num d); - Format.print_newline()) - else ()); + if !debugging then ( + Format.print_string ("Trying rounding with limit " ^ string_of_num d); + Format.print_newline () ) + else (); let vec = nice_vector d raw_vec in - let mat = iter (1,dim vec) - (fun i a -> matrix_add (matrix_cmul (element vec i) (List.nth mats i)) a) - (matrix_neg (List.nth mats 0)) in - deration(diag mat) in - let rat,dia = + let mat = + iter + (1, dim vec) + (fun i a -> + matrix_add (matrix_cmul (element vec i) (List.nth mats i)) a) + (matrix_neg (List.nth mats 0)) + in + deration (diag mat) + in + let rat, dia = if pvs = [] then - let mat = matrix_neg (List.nth mats 0) in - deration(diag mat) + let mat = matrix_neg (List.nth mats 0) in + deration (diag mat) else - tryfind find_rounding (List.map Num.num_of_int (1--31) @ - List.map pow2 (5--66)) in - let poly_of_lin(d,v) = - d,foldl(fun a i c -> (List.nth lpps (i - 1) |-> c) a) undefined (snd v) in + tryfind find_rounding + (List.map Num.num_of_int (1 -- 31) @ List.map pow2 (5 -- 66)) + in + let poly_of_lin (d, v) = + (d, foldl (fun a i c -> (List.nth lpps (i - 1) |-> c) a) undefined (snd v)) + in let lins = List.map poly_of_lin dia in - let sqs = List.map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in + let sqs = + List.map (fun (d, l) -> poly_mul (poly_const d) (poly_pow l 2)) lins + in let sos = poly_cmul rat (end_itlist poly_add sqs) in - if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;; - -let sumofsquares = sumofsquares_general_symmetry csdp;; + if is_undefined (poly_sub sos pol) then (rat, lins) else raise Sanity +let sumofsquares = sumofsquares_general_symmetry csdp diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli index c9181953c8..ac75bd37f0 100644 --- a/plugins/micromega/sos.mli +++ b/plugins/micromega/sos.mli @@ -13,26 +13,24 @@ open Sos_types type poly val poly_isconst : poly -> bool - val poly_neg : poly -> poly - val poly_mul : poly -> poly -> poly - val poly_pow : poly -> int -> poly - val poly_const : Num.num -> poly - val poly_of_term : term -> poly - val term_of_poly : poly -> term -val term_of_sos : positivstellensatz * (Num.num * poly) list -> - positivstellensatz +val term_of_sos : + positivstellensatz * (Num.num * poly) list -> positivstellensatz val string_of_poly : poly -> string -val real_positivnullstellensatz_general : bool -> int -> poly list -> - (poly * positivstellensatz) list -> - poly -> poly list * (positivstellensatz * (Num.num * poly) list) list +val real_positivnullstellensatz_general : + bool + -> int + -> poly list + -> (poly * positivstellensatz) list + -> poly + -> poly list * (positivstellensatz * (Num.num * poly) list) list -val sumofsquares : poly -> Num.num * ( Num.num * poly) list +val sumofsquares : poly -> Num.num * (Num.num * poly) list diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml index 0a0ffc7947..51221aa6b9 100644 --- a/plugins/micromega/sos_lib.ml +++ b/plugins/micromega/sos_lib.ml @@ -13,47 +13,45 @@ open Num (* Comparisons that are reflexive on NaN and also short-circuiting. *) (* ------------------------------------------------------------------------- *) -let cmp = compare (** FIXME *) +(** FIXME *) +let cmp = compare -let (=?) = fun x y -> cmp x y = 0;; -let (<?) = fun x y -> cmp x y < 0;; -let (<=?) = fun x y -> cmp x y <= 0;; -let (>?) = fun x y -> cmp x y > 0;; +let ( =? ) x y = cmp x y = 0 +let ( <? ) x y = cmp x y < 0 +let ( <=? ) x y = cmp x y <= 0 +let ( >? ) x y = cmp x y > 0 (* ------------------------------------------------------------------------- *) (* Combinators. *) (* ------------------------------------------------------------------------- *) -let (o) = fun f g x -> f(g x);; +let o f g x = f (g x) (* ------------------------------------------------------------------------- *) (* Some useful functions on "num" type. *) (* ------------------------------------------------------------------------- *) - let num_0 = Int 0 and num_1 = Int 1 and num_2 = Int 2 -and num_10 = Int 10;; +and num_10 = Int 10 -let pow2 n = power_num num_2 (Int n);; -let pow10 n = power_num num_10 (Int n);; +let pow2 n = power_num num_2 (Int n) +let pow10 n = power_num num_10 (Int n) let numdom r = let r' = Ratio.normalize_ratio (ratio_of_num r) in - num_of_big_int(Ratio.numerator_ratio r'), - num_of_big_int(Ratio.denominator_ratio r');; + ( num_of_big_int (Ratio.numerator_ratio r') + , num_of_big_int (Ratio.denominator_ratio r') ) -let numerator = (o) fst numdom -and denominator = (o) snd numdom;; +let numerator = o fst numdom +and denominator = o snd numdom let gcd_num n1 n2 = - num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));; + num_of_big_int (Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2)) let lcm_num x y = - if x =/ num_0 && y =/ num_0 then num_0 - else abs_num((x */ y) // gcd_num x y);; - + if x =/ num_0 && y =/ num_0 then num_0 else abs_num (x */ y // gcd_num x y) (* ------------------------------------------------------------------------- *) (* Various versions of list iteration. *) @@ -61,9 +59,9 @@ let lcm_num x y = let rec end_itlist f l = match l with - [] -> failwith "end_itlist" - | [x] -> x - | (h::t) -> f h (end_itlist f t);; + | [] -> failwith "end_itlist" + | [x] -> x + | h :: t -> f h (end_itlist f t) (* ------------------------------------------------------------------------- *) (* All pairs arising from applying a function over two lists. *) @@ -71,36 +69,32 @@ let rec end_itlist f l = let rec allpairs f l1 l2 = match l1 with - h1::t1 -> List.fold_right (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) - | [] -> [];; + | h1 :: t1 -> List.fold_right (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) + | [] -> [] (* ------------------------------------------------------------------------- *) (* String operations (surely there is a better way...) *) (* ------------------------------------------------------------------------- *) -let implode l = List.fold_right (^) l "";; +let implode l = List.fold_right ( ^ ) l "" let explode s = let rec exap n l = - if n < 0 then l else - exap (n - 1) ((String.sub s n 1)::l) in - exap (String.length s - 1) [];; - + if n < 0 then l else exap (n - 1) (String.sub s n 1 :: l) + in + exap (String.length s - 1) [] (* ------------------------------------------------------------------------- *) (* Repetition of a function. *) (* ------------------------------------------------------------------------- *) -let rec funpow n f x = - if n < 1 then x else funpow (n-1) f (f x);; - - +let rec funpow n f x = if n < 1 then x else funpow (n - 1) f (f x) (* ------------------------------------------------------------------------- *) (* Sequences. *) (* ------------------------------------------------------------------------- *) -let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; +let rec ( -- ) m n = if m > n then [] else m :: (m + 1 -- n) (* ------------------------------------------------------------------------- *) (* Various useful list operations. *) @@ -108,39 +102,29 @@ let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; let rec tryfind f l = match l with - [] -> failwith "tryfind" - | (h::t) -> try f h with Failure _ -> tryfind f t;; + | [] -> failwith "tryfind" + | h :: t -> ( try f h with Failure _ -> tryfind f t ) (* ------------------------------------------------------------------------- *) (* "Set" operations on lists. *) (* ------------------------------------------------------------------------- *) -let rec mem x lis = - match lis with - [] -> false - | (h::t) -> x =? h || mem x t;; - -let insert x l = - if mem x l then l else x::l;; - -let union l1 l2 = List.fold_right insert l1 l2;; - -let subtract l1 l2 = List.filter (fun x -> not (mem x l2)) l1;; +let rec mem x lis = match lis with [] -> false | h :: t -> x =? h || mem x t +let insert x l = if mem x l then l else x :: l +let union l1 l2 = List.fold_right insert l1 l2 +let subtract l1 l2 = List.filter (fun x -> not (mem x l2)) l1 (* ------------------------------------------------------------------------- *) (* Common measure predicates to use with "sort". *) (* ------------------------------------------------------------------------- *) -let increasing f x y = f x <? f y;; +let increasing f x y = f x <? f y (* ------------------------------------------------------------------------- *) (* Iterating functions over lists. *) (* ------------------------------------------------------------------------- *) -let rec do_list f l = - match l with - [] -> () - | (h::t) -> (f h; do_list f t);; +let rec do_list f l = match l with [] -> () | h :: t -> f h; do_list f t (* ------------------------------------------------------------------------- *) (* Sorting. *) @@ -148,10 +132,10 @@ let rec do_list f l = let rec sort cmp lis = match lis with - [] -> [] - | piv::rest -> - let r,l = List.partition (cmp piv) rest in - (sort cmp l) @ (piv::(sort cmp r));; + | [] -> [] + | piv :: rest -> + let r, l = List.partition (cmp piv) rest in + sort cmp l @ (piv :: sort cmp r) (* ------------------------------------------------------------------------- *) (* Removing adjacent (NB!) equal elements from list. *) @@ -159,16 +143,16 @@ let rec sort cmp lis = let rec uniq l = match l with - x::(y::_ as t) -> let t' = uniq t in - if x =? y then t' else - if t'==t then l else x::t' - | _ -> l;; + | x :: (y :: _ as t) -> + let t' = uniq t in + if x =? y then t' else if t' == t then l else x :: t' + | _ -> l (* ------------------------------------------------------------------------- *) (* Convert list into set by eliminating duplicates. *) (* ------------------------------------------------------------------------- *) -let setify s = uniq (sort (<=?) s);; +let setify s = uniq (sort ( <=? ) s) (* ------------------------------------------------------------------------- *) (* Polymorphic finite partial functions via Patricia trees. *) @@ -179,25 +163,22 @@ let setify s = uniq (sort (<=?) s);; (* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *) (* ------------------------------------------------------------------------- *) -type ('a,'b)func = - Empty - | Leaf of int * ('a*'b)list - | Branch of int * int * ('a,'b)func * ('a,'b)func;; +type ('a, 'b) func = + | Empty + | Leaf of int * ('a * 'b) list + | Branch of int * int * ('a, 'b) func * ('a, 'b) func (* ------------------------------------------------------------------------- *) (* Undefined function. *) (* ------------------------------------------------------------------------- *) -let undefined = Empty;; +let undefined = Empty (* ------------------------------------------------------------------------- *) (* In case of equality comparison worries, better use this. *) (* ------------------------------------------------------------------------- *) -let is_undefined f = - match f with - Empty -> true - | _ -> false;; +let is_undefined f = match f with Empty -> true | _ -> false (* ------------------------------------------------------------------------- *) (* Operation analogous to "map" for lists. *) @@ -205,15 +186,15 @@ let is_undefined f = let mapf = let rec map_list f l = - match l with - [] -> [] - | (x,y)::t -> (x,f(y))::(map_list f t) in + match l with [] -> [] | (x, y) :: t -> (x, f y) :: map_list f t + in let rec mapf f t = match t with - Empty -> Empty - | Leaf(h,l) -> Leaf(h,map_list f l) - | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in - mapf;; + | Empty -> Empty + | Leaf (h, l) -> Leaf (h, map_list f l) + | Branch (p, b, l, r) -> Branch (p, b, mapf f l, mapf f r) + in + mapf (* ------------------------------------------------------------------------- *) (* Operations analogous to "fold" for lists. *) @@ -221,119 +202,125 @@ let mapf = let foldl = let rec foldl_list f a l = - match l with - [] -> a - | (x,y)::t -> foldl_list f (f a x y) t in + match l with [] -> a | (x, y) :: t -> foldl_list f (f a x y) t + in let rec foldl f a t = match t with - Empty -> a - | Leaf(h,l) -> foldl_list f a l - | Branch(p,b,l,r) -> foldl f (foldl f a l) r in - foldl;; + | Empty -> a + | Leaf (h, l) -> foldl_list f a l + | Branch (p, b, l, r) -> foldl f (foldl f a l) r + in + foldl let foldr = let rec foldr_list f l a = - match l with - [] -> a - | (x,y)::t -> f x y (foldr_list f t a) in + match l with [] -> a | (x, y) :: t -> f x y (foldr_list f t a) + in let rec foldr f t a = match t with - Empty -> a - | Leaf(h,l) -> foldr_list f l a - | Branch(p,b,l,r) -> foldr f l (foldr f r a) in - foldr;; + | Empty -> a + | Leaf (h, l) -> foldr_list f l a + | Branch (p, b, l, r) -> foldr f l (foldr f r a) + in + foldr (* ------------------------------------------------------------------------- *) (* Redefinition and combination. *) (* ------------------------------------------------------------------------- *) -let (|->),combine = - let ldb x y = let z = x lxor y in z land (-z) in +let ( |-> ), combine = + let ldb x y = + let z = x lxor y in + z land -z + in let newbranch p1 t1 p2 t2 = let b = ldb p1 p2 in let p = p1 land (b - 1) in - if p1 land b = 0 then Branch(p,b,t1,t2) - else Branch(p,b,t2,t1) in - let rec define_list (x,y as xy) l = + if p1 land b = 0 then Branch (p, b, t1, t2) else Branch (p, b, t2, t1) + in + let rec define_list ((x, y) as xy) l = match l with - (a,b as ab)::t -> - if x =? a then xy::t - else if x <? a then xy::l - else ab::(define_list xy t) + | ((a, b) as ab) :: t -> + if x =? a then xy :: t + else if x <? a then xy :: l + else ab :: define_list xy t | [] -> [xy] and combine_list op z l1 l2 = - match (l1,l2) with - [],_ -> l2 - | _,[] -> l1 - | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) -> - if x1 <? x2 then xy1::(combine_list op z t1 l2) - else if x2 <? x1 then xy2::(combine_list op z l1 t2) else - let y = op y1 y2 and l = combine_list op z t1 t2 in - if z(y) then l else (x1,y)::l in - let (|->) x y = + match (l1, l2) with + | [], _ -> l2 + | _, [] -> l1 + | ((x1, y1) as xy1) :: t1, ((x2, y2) as xy2) :: t2 -> + if x1 <? x2 then xy1 :: combine_list op z t1 l2 + else if x2 <? x1 then xy2 :: combine_list op z l1 t2 + else + let y = op y1 y2 and l = combine_list op z t1 t2 in + if z y then l else (x1, y) :: l + in + let ( |-> ) x y = let k = Hashtbl.hash x in let rec upd t = match t with - Empty -> Leaf (k,[x,y]) - | Leaf(h,l) -> - if h = k then Leaf(h,define_list (x,y) l) - else newbranch h t k (Leaf(k,[x,y])) - | Branch(p,b,l,r) -> - if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y])) - else if k land b = 0 then Branch(p,b,upd l,r) - else Branch(p,b,l,upd r) in - upd in + | Empty -> Leaf (k, [(x, y)]) + | Leaf (h, l) -> + if h = k then Leaf (h, define_list (x, y) l) + else newbranch h t k (Leaf (k, [(x, y)])) + | Branch (p, b, l, r) -> + if k land (b - 1) <> p then newbranch p t k (Leaf (k, [(x, y)])) + else if k land b = 0 then Branch (p, b, upd l, r) + else Branch (p, b, l, upd r) + in + upd + in let rec combine op z t1 t2 = - match (t1,t2) with - Empty,_ -> t2 - | _,Empty -> t1 - | Leaf(h1,l1),Leaf(h2,l2) -> - if h1 = h2 then - let l = combine_list op z l1 l2 in - if l = [] then Empty else Leaf(h1,l) - else newbranch h1 t1 h2 t2 - | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) | - (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) -> - if k land (b - 1) = p then - if k land b = 0 then - let l' = combine op z lf l in - if is_undefined l' then r else Branch(p,b,l',r) - else - let r' = combine op z lf r in - if is_undefined r' then l else Branch(p,b,l,r') - else - newbranch k lf p br - | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) -> - if b1 < b2 then - if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2 - else if p2 land b1 = 0 then - let l = combine op z l1 t2 in - if is_undefined l then r1 else Branch(p1,b1,l,r1) - else - let r = combine op z r1 t2 in - if is_undefined r then l1 else Branch(p1,b1,l1,r) - else if b2 < b1 then - if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2 - else if p1 land b2 = 0 then - let l = combine op z t1 l2 in - if is_undefined l then r2 else Branch(p2,b2,l,r2) - else - let r = combine op z t1 r2 in - if is_undefined r then l2 else Branch(p2,b2,l2,r) - else if p1 = p2 then - let l = combine op z l1 l2 and r = combine op z r1 r2 in - if is_undefined l then r - else if is_undefined r then l else Branch(p1,b1,l,r) - else - newbranch p1 t1 p2 t2 in - (|->),combine;; + match (t1, t2) with + | Empty, _ -> t2 + | _, Empty -> t1 + | Leaf (h1, l1), Leaf (h2, l2) -> + if h1 = h2 then + let l = combine_list op z l1 l2 in + if l = [] then Empty else Leaf (h1, l) + else newbranch h1 t1 h2 t2 + | (Leaf (k, lis) as lf), (Branch (p, b, l, r) as br) + |(Branch (p, b, l, r) as br), (Leaf (k, lis) as lf) -> + if k land (b - 1) = p then + if k land b = 0 then + let l' = combine op z lf l in + if is_undefined l' then r else Branch (p, b, l', r) + else + let r' = combine op z lf r in + if is_undefined r' then l else Branch (p, b, l, r') + else newbranch k lf p br + | Branch (p1, b1, l1, r1), Branch (p2, b2, l2, r2) -> + if b1 < b2 then + if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2 + else if p2 land b1 = 0 then + let l = combine op z l1 t2 in + if is_undefined l then r1 else Branch (p1, b1, l, r1) + else + let r = combine op z r1 t2 in + if is_undefined r then l1 else Branch (p1, b1, l1, r) + else if b2 < b1 then + if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2 + else if p1 land b2 = 0 then + let l = combine op z t1 l2 in + if is_undefined l then r2 else Branch (p2, b2, l, r2) + else + let r = combine op z t1 r2 in + if is_undefined r then l2 else Branch (p2, b2, l2, r) + else if p1 = p2 then + let l = combine op z l1 l2 and r = combine op z r1 r2 in + if is_undefined l then r + else if is_undefined r then l + else Branch (p1, b1, l, r) + else newbranch p1 t1 p2 t2 + in + (( |-> ), combine) (* ------------------------------------------------------------------------- *) (* Special case of point function. *) (* ------------------------------------------------------------------------- *) -let (|=>) = fun x y -> (x |-> y) undefined;; - +let ( |=> ) x y = (x |-> y) undefined (* ------------------------------------------------------------------------- *) (* Grab an arbitrary element. *) @@ -341,9 +328,9 @@ let (|=>) = fun x y -> (x |-> y) undefined;; let rec choose t = match t with - Empty -> failwith "choose: completely undefined function" - | Leaf(h,l) -> List.hd l - | Branch(b,p,t1,t2) -> choose t1;; + | Empty -> failwith "choose: completely undefined function" + | Leaf (h, l) -> List.hd l + | Branch (b, p, t1, t2) -> choose t1 (* ------------------------------------------------------------------------- *) (* Application. *) @@ -352,21 +339,22 @@ let rec choose t = let applyd = let rec apply_listd l d x = match l with - (a,b)::t -> if x =? a then b - else if x >? a then apply_listd t d x else d x - | [] -> d x in + | (a, b) :: t -> + if x =? a then b else if x >? a then apply_listd t d x else d x + | [] -> d x + in fun f d x -> let k = Hashtbl.hash x in let rec look t = match t with - Leaf(h,l) when h = k -> apply_listd l d x - | Branch(p,b,l,r) -> look (if k land b = 0 then l else r) - | _ -> d x in - look f;; - -let apply f = applyd f (fun x -> failwith "apply");; + | Leaf (h, l) when h = k -> apply_listd l d x + | Branch (p, b, l, r) -> look (if k land b = 0 then l else r) + | _ -> d x + in + look f -let tryapplyd f a d = applyd f (fun x -> d) a;; +let apply f = applyd f (fun x -> failwith "apply") +let tryapplyd f a d = applyd f (fun x -> d) a (* ------------------------------------------------------------------------- *) (* Undefinition. *) @@ -375,161 +363,166 @@ let tryapplyd f a d = applyd f (fun x -> d) a;; let undefine = let rec undefine_list x l = match l with - (a,b as ab)::t -> - if x =? a then t - else if x <? a then l else - let t' = undefine_list x t in - if t' == t then l else ab::t' - | [] -> [] in + | ((a, b) as ab) :: t -> + if x =? a then t + else if x <? a then l + else + let t' = undefine_list x t in + if t' == t then l else ab :: t' + | [] -> [] + in fun x -> let k = Hashtbl.hash x in let rec und t = match t with - Leaf(h,l) when h = k -> - let l' = undefine_list x l in + | Leaf (h, l) when h = k -> + let l' = undefine_list x l in + if l' == l then t else if l' = [] then Empty else Leaf (h, l') + | Branch (p, b, l, r) when k land (b - 1) = p -> + if k land b = 0 then + let l' = und l in if l' == l then t - else if l' = [] then Empty - else Leaf(h,l') - | Branch(p,b,l,r) when k land (b - 1) = p -> - if k land b = 0 then - let l' = und l in - if l' == l then t - else if is_undefined l' then r - else Branch(p,b,l',r) - else - let r' = und r in - if r' == r then t - else if is_undefined r' then l - else Branch(p,b,l,r') - | _ -> t in - und;; - + else if is_undefined l' then r + else Branch (p, b, l', r) + else + let r' = und r in + if r' == r then t + else if is_undefined r' then l + else Branch (p, b, l, r') + | _ -> t + in + und (* ------------------------------------------------------------------------- *) (* Mapping to sorted-list representation of the graph, domain and range. *) (* ------------------------------------------------------------------------- *) -let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; - -let dom f = setify(foldl (fun a x y -> x::a) [] f);; +let graph f = setify (foldl (fun a x y -> (x, y) :: a) [] f) +let dom f = setify (foldl (fun a x y -> x :: a) [] f) (* ------------------------------------------------------------------------- *) (* More parser basics. *) (* ------------------------------------------------------------------------- *) -exception Noparse;; +exception Noparse - -let isspace,isnum = - let charcode s = Char.code(String.get s 0) in +let isspace, isnum = + let charcode s = Char.code s.[0] in let spaces = " \t\n\r" and separators = ",;" and brackets = "()[]{}" and symbs = "\\!@#$%^&*-+|\\<=>/?~.:" and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ" and nums = "0123456789" in - let allchars = spaces^separators^brackets^symbs^alphas^nums in - let csetsize = List.fold_right ((o) max charcode) (explode allchars) 256 in + let allchars = spaces ^ separators ^ brackets ^ symbs ^ alphas ^ nums in + let csetsize = List.fold_right (o max charcode) (explode allchars) 256 in let ctable = Array.make csetsize 0 in - do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces); - do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators); - do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets); - do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs); - do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas); - do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums); - let isspace c = Array.get ctable (charcode c) = 1 - and isnum c = Array.get ctable (charcode c) = 32 in - isspace,isnum;; + do_list (fun c -> ctable.(charcode c) <- 1) (explode spaces); + do_list (fun c -> ctable.(charcode c) <- 2) (explode separators); + do_list (fun c -> ctable.(charcode c) <- 4) (explode brackets); + do_list (fun c -> ctable.(charcode c) <- 8) (explode symbs); + do_list (fun c -> ctable.(charcode c) <- 16) (explode alphas); + do_list (fun c -> ctable.(charcode c) <- 32) (explode nums); + let isspace c = ctable.(charcode c) = 1 + and isnum c = ctable.(charcode c) = 32 in + (isspace, isnum) let parser_or parser1 parser2 input = - try parser1 input - with Noparse -> parser2 input;; + try parser1 input with Noparse -> parser2 input -let (++) parser1 parser2 input = - let result1,rest1 = parser1 input in - let result2,rest2 = parser2 rest1 in - (result1,result2),rest2;; +let ( ++ ) parser1 parser2 input = + let result1, rest1 = parser1 input in + let result2, rest2 = parser2 rest1 in + ((result1, result2), rest2) let rec many prs input = - try let result,next = prs input in - let results,rest = many prs next in - (result::results),rest - with Noparse -> [],input;; + try + let result, next = prs input in + let results, rest = many prs next in + (result :: results, rest) + with Noparse -> ([], input) -let (>>) prs treatment input = - let result,rest = prs input in - treatment(result),rest;; +let ( >> ) prs treatment input = + let result, rest = prs input in + (treatment result, rest) let fix err prs input = - try prs input - with Noparse -> failwith (err ^ " expected");; + try prs input with Noparse -> failwith (err ^ " expected") let listof prs sep err = - prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);; + prs ++ many (sep ++ fix err prs >> snd) >> fun (h, t) -> h :: t let possibly prs input = - try let x,rest = prs input in [x],rest - with Noparse -> [],input;; + try + let x, rest = prs input in + ([x], rest) + with Noparse -> ([], input) -let some p = - function - [] -> raise Noparse - | (h::t) -> if p h then (h,t) else raise Noparse;; +let some p = function + | [] -> raise Noparse + | h :: t -> if p h then (h, t) else raise Noparse -let a tok = some (fun item -> item = tok);; +let a tok = some (fun item -> item = tok) let rec atleast n prs i = - (if n <= 0 then many prs - else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;; + ( if n <= 0 then many prs + else prs ++ atleast (n - 1) prs >> fun (h, t) -> h :: t ) + i (* ------------------------------------------------------------------------- *) -let temp_path = Filename.get_temp_dir_name ();; +let temp_path = Filename.get_temp_dir_name () (* ------------------------------------------------------------------------- *) (* Convenient conversion between files and (lists of) strings. *) (* ------------------------------------------------------------------------- *) let strings_of_file filename = - let fd = try open_in filename - with Sys_error _ -> - failwith("strings_of_file: can't open "^filename) in + let fd = + try open_in filename + with Sys_error _ -> failwith ("strings_of_file: can't open " ^ filename) + in let rec suck_lines acc = - try let l = input_line fd in - suck_lines (l::acc) - with End_of_file -> List.rev acc in + try + let l = input_line fd in + suck_lines (l :: acc) + with End_of_file -> List.rev acc + in let data = suck_lines [] in - (close_in fd; data);; + close_in fd; data -let string_of_file filename = - String.concat "\n" (strings_of_file filename);; +let string_of_file filename = String.concat "\n" (strings_of_file filename) let file_of_string filename s = let fd = open_out filename in - output_string fd s; close_out fd;; - + output_string fd s; close_out fd (* ------------------------------------------------------------------------- *) (* Iterative deepening. *) (* ------------------------------------------------------------------------- *) let rec deepen f n = - try (*print_string "Searching with depth limit "; - print_int n; print_newline();*) f n - with Failure _ -> deepen f (n + 1);; + try + (*print_string "Searching with depth limit "; + print_int n; print_newline();*) + f n + with Failure _ -> deepen f (n + 1) exception TooDeep let deepen_until limit f n = match compare limit 0 with - | 0 -> raise TooDeep - | -1 -> deepen f n - | _ -> - let rec d_until f n = - try(* if !debugging + | 0 -> raise TooDeep + | -1 -> deepen f n + | _ -> + let rec d_until f n = + try + (* if !debugging then (print_string "Searching with depth limit "; - print_int n; print_newline()) ;*) f n - with Failure x -> - (*if !debugging then (Printf.printf "solver error : %s\n" x) ; *) - if n = limit then raise TooDeep else d_until f (n + 1) in - d_until f n + print_int n; print_newline()) ;*) + f n + with Failure x -> + (*if !debugging then (Printf.printf "solver error : %s\n" x) ; *) + if n = limit then raise TooDeep else d_until f (n + 1) + in + d_until f n diff --git a/plugins/micromega/sos_lib.mli b/plugins/micromega/sos_lib.mli index f01b632c67..2bbcbf336b 100644 --- a/plugins/micromega/sos_lib.mli +++ b/plugins/micromega/sos_lib.mli @@ -9,58 +9,54 @@ (************************************************************************) val o : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b - val num_1 : Num.num val pow10 : int -> Num.num val pow2 : int -> Num.num - val implode : string list -> string val explode : string -> string list - val funpow : int -> ('a -> 'a) -> 'a -> 'a val tryfind : ('a -> 'b) -> 'a list -> 'b -type ('a,'b) func = - | Empty - | Leaf of int * ('a*'b) list - | Branch of int * int * ('a,'b) func * ('a,'b) func +type ('a, 'b) func = + | Empty + | Leaf of int * ('a * 'b) list + | Branch of int * int * ('a, 'b) func * ('a, 'b) func val undefined : ('a, 'b) func val is_undefined : ('a, 'b) func -> bool -val (|->) : 'a -> 'b -> ('a, 'b) func -> ('a, 'b) func -val (|=>) : 'a -> 'b -> ('a, 'b) func +val ( |-> ) : 'a -> 'b -> ('a, 'b) func -> ('a, 'b) func +val ( |=> ) : 'a -> 'b -> ('a, 'b) func val choose : ('a, 'b) func -> 'a * 'b -val combine : ('a -> 'a -> 'a) -> ('a -> bool) -> ('b, 'a) func -> ('b, 'a) func -> ('b, 'a) func -val (--) : int -> int -> int list +val combine : + ('a -> 'a -> 'a) + -> ('a -> bool) + -> ('b, 'a) func + -> ('b, 'a) func + -> ('b, 'a) func + +val ( -- ) : int -> int -> int list val tryapplyd : ('a, 'b) func -> 'a -> 'b -> 'b val apply : ('a, 'b) func -> 'a -> 'b - val foldl : ('a -> 'b -> 'c -> 'a) -> 'a -> ('b, 'c) func -> 'a val foldr : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) func -> 'c -> 'c val mapf : ('a -> 'b) -> ('c, 'a) func -> ('c, 'b) func - val undefine : 'a -> ('a, 'b) func -> ('a, 'b) func - val dom : ('a, 'b) func -> 'a list val graph : ('a, 'b) func -> ('a * 'b) list - val union : 'a list -> 'a list -> 'a list val subtract : 'a list -> 'a list -> 'a list val sort : ('a -> 'a -> bool) -> 'a list -> 'a list val setify : 'a list -> 'a list val increasing : ('a -> 'b) -> 'a -> 'a -> bool val allpairs : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - val gcd_num : Num.num -> Num.num -> Num.num val lcm_num : Num.num -> Num.num -> Num.num val numerator : Num.num -> Num.num val denominator : Num.num -> Num.num val end_itlist : ('a -> 'a -> 'a) -> 'a list -> 'a - -val (>>) : ('a -> 'b * 'c) -> ('b -> 'd) -> 'a -> 'd * 'c -val (++) : ('a -> 'b * 'c) -> ('c -> 'd * 'e) -> 'a -> ('b * 'd) * 'e - +val ( >> ) : ('a -> 'b * 'c) -> ('b -> 'd) -> 'a -> 'd * 'c +val ( ++ ) : ('a -> 'b * 'c) -> ('c -> 'd * 'e) -> 'a -> ('b * 'd) * 'e val a : 'a -> 'a list -> 'a * 'a list val many : ('a -> 'b * 'a) -> 'a -> 'b list * 'a val some : ('a -> bool) -> 'a list -> 'a * 'a list @@ -70,10 +66,9 @@ val parser_or : ('a -> 'b) -> ('a -> 'b) -> 'a -> 'b val isnum : string -> bool val atleast : int -> ('a -> 'b * 'a) -> 'a -> 'b list * 'a val listof : ('a -> 'b * 'c) -> ('c -> 'd * 'a) -> string -> 'a -> 'b list * 'c - val temp_path : string val string_of_file : string -> string val file_of_string : string -> string -> unit - val deepen_until : int -> (int -> 'a) -> int -> 'a + exception TooDeep diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml index 0ba76fc0ea..988024968b 100644 --- a/plugins/micromega/sos_types.ml +++ b/plugins/micromega/sos_types.ml @@ -14,53 +14,53 @@ open Num type vname = string type term = -| Zero -| Const of Num.num -| Var of vname -| Opp of term -| Add of (term * term) -| Sub of (term * term) -| Mul of (term * term) -| Pow of (term * int) - + | Zero + | Const of Num.num + | Var of vname + | Opp of term + | Add of (term * term) + | Sub of (term * term) + | Mul of (term * term) + | Pow of (term * int) let rec output_term o t = match t with - | Zero -> output_string o "0" - | Const n -> output_string o (string_of_num n) - | Var n -> Printf.fprintf o "v%s" n - | Opp t -> Printf.fprintf o "- (%a)" output_term t - | Add(t1,t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2 - | Sub(t1,t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2 - | Mul(t1,t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2 - | Pow(t1,i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i + | Zero -> output_string o "0" + | Const n -> output_string o (string_of_num n) + | Var n -> Printf.fprintf o "v%s" n + | Opp t -> Printf.fprintf o "- (%a)" output_term t + | Add (t1, t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2 + | Sub (t1, t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2 + | Mul (t1, t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2 + | Pow (t1, i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i + (* ------------------------------------------------------------------------- *) (* Data structure for Positivstellensatz refutations. *) (* ------------------------------------------------------------------------- *) type positivstellensatz = - Axiom_eq of int - | Axiom_le of int - | Axiom_lt of int - | Rational_eq of num - | Rational_le of num - | Rational_lt of num - | Square of term - | Monoid of int list - | Eqmul of term * positivstellensatz - | Sum of positivstellensatz * positivstellensatz - | Product of positivstellensatz * positivstellensatz;; - + | Axiom_eq of int + | Axiom_le of int + | Axiom_lt of int + | Rational_eq of num + | Rational_le of num + | Rational_lt of num + | Square of term + | Monoid of int list + | Eqmul of term * positivstellensatz + | Sum of positivstellensatz * positivstellensatz + | Product of positivstellensatz * positivstellensatz let rec output_psatz o = function | Axiom_eq i -> Printf.fprintf o "Aeq(%i)" i | Axiom_le i -> Printf.fprintf o "Ale(%i)" i | Axiom_lt i -> Printf.fprintf o "Alt(%i)" i - | Rational_eq n -> Printf.fprintf o "eq(%s)" (string_of_num n) - | Rational_le n -> Printf.fprintf o "le(%s)" (string_of_num n) - | Rational_lt n -> Printf.fprintf o "lt(%s)" (string_of_num n) - | Square t -> Printf.fprintf o "(%a)^2" output_term t - | Monoid l -> Printf.fprintf o "monoid" - | Eqmul (t,ps) -> Printf.fprintf o "%a * %a" output_term t output_psatz ps - | Sum (t1,t2) -> Printf.fprintf o "%a + %a" output_psatz t1 output_psatz t2 - | Product (t1,t2) -> Printf.fprintf o "%a * %a" output_psatz t1 output_psatz t2 + | Rational_eq n -> Printf.fprintf o "eq(%s)" (string_of_num n) + | Rational_le n -> Printf.fprintf o "le(%s)" (string_of_num n) + | Rational_lt n -> Printf.fprintf o "lt(%s)" (string_of_num n) + | Square t -> Printf.fprintf o "(%a)^2" output_term t + | Monoid l -> Printf.fprintf o "monoid" + | Eqmul (t, ps) -> Printf.fprintf o "%a * %a" output_term t output_psatz ps + | Sum (t1, t2) -> Printf.fprintf o "%a + %a" output_psatz t1 output_psatz t2 + | Product (t1, t2) -> + Printf.fprintf o "%a * %a" output_psatz t1 output_psatz t2 diff --git a/plugins/micromega/sos_types.mli b/plugins/micromega/sos_types.mli index c55bb69e8a..ca9a43b1d0 100644 --- a/plugins/micromega/sos_types.mli +++ b/plugins/micromega/sos_types.mli @@ -13,28 +13,28 @@ type vname = string type term = -| Zero -| Const of Num.num -| Var of vname -| Opp of term -| Add of (term * term) -| Sub of (term * term) -| Mul of (term * term) -| Pow of (term * int) + | Zero + | Const of Num.num + | Var of vname + | Opp of term + | Add of (term * term) + | Sub of (term * term) + | Mul of (term * term) + | Pow of (term * int) val output_term : out_channel -> term -> unit type positivstellensatz = - Axiom_eq of int - | Axiom_le of int - | Axiom_lt of int - | Rational_eq of Num.num - | Rational_le of Num.num - | Rational_lt of Num.num - | Square of term - | Monoid of int list - | Eqmul of term * positivstellensatz - | Sum of positivstellensatz * positivstellensatz - | Product of positivstellensatz * positivstellensatz + | Axiom_eq of int + | Axiom_le of int + | Axiom_lt of int + | Rational_eq of Num.num + | Rational_le of Num.num + | Rational_lt of Num.num + | Square of term + | Monoid of int list + | Eqmul of term * positivstellensatz + | Sum of positivstellensatz * positivstellensatz + | Product of positivstellensatz * positivstellensatz val output_psatz : out_channel -> positivstellensatz -> unit diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml index a5f3b83c48..f53a7b42c9 100644 --- a/plugins/micromega/vect.ml +++ b/plugins/micromega/vect.ml @@ -11,177 +11,158 @@ open Num open Mutils +type var = int (** [t] is the type of vectors. A vector [(x1,v1) ; ... ; (xn,vn)] is such that: - variables indexes are ordered (x1 < ... < xn - values are all non-zero *) -type var = int + type t = (var * num) list +type vector = t (** [equal v1 v2 = true] if the vectors are syntactically equal. *) let rec equal v1 v2 = - match v1 , v2 with - | [] , [] -> true - | [] , _ -> false - | _::_ , [] -> false - | (i1,n1)::v1 , (i2,n2)::v2 -> - (Int.equal i1 i2) && n1 =/ n2 && equal v1 v2 + match (v1, v2) with + | [], [] -> true + | [], _ -> false + | _ :: _, [] -> false + | (i1, n1) :: v1, (i2, n2) :: v2 -> Int.equal i1 i2 && n1 =/ n2 && equal v1 v2 let hash v = let rec hash i = function | [] -> i - | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in - Hashtbl.hash (hash 0 v ) - + | (vr, vl) :: l -> hash (i + Hashtbl.hash (vr, float_of_num vl)) l + in + Hashtbl.hash (hash 0 v) let null = [] +let is_null v = match v with [] | [(0, Int 0)] -> true | _ -> false -let is_null v = - match v with - | [] | [0,Int 0] -> true - | _ -> false - -let pp_var_num pp_var o (v,n) = - if Int.equal v 0 - then if eq_num (Int 0) n then () - else Printf.fprintf o "%s" (string_of_num n) +let pp_var_num pp_var o (v, n) = + if Int.equal v 0 then + if eq_num (Int 0) n then () else Printf.fprintf o "%s" (string_of_num n) else match n with - | Int 1 -> pp_var o v + | Int 1 -> pp_var o v | Int -1 -> Printf.fprintf o "-%a" pp_var v - | Int 0 -> () - | _ -> Printf.fprintf o "%s*%a" (string_of_num n) pp_var v + | Int 0 -> () + | _ -> Printf.fprintf o "%s*%a" (string_of_num n) pp_var v -let pp_var_num_smt pp_var o (v,n) = - if Int.equal v 0 - then if eq_num (Int 0) n then () - else Printf.fprintf o "%s" (string_of_num n) +let pp_var_num_smt pp_var o (v, n) = + if Int.equal v 0 then + if eq_num (Int 0) n then () else Printf.fprintf o "%s" (string_of_num n) else match n with - | Int 1 -> pp_var o v + | Int 1 -> pp_var o v | Int -1 -> Printf.fprintf o "(- %a)" pp_var v - | Int 0 -> () - | _ -> Printf.fprintf o "(* %s %a)" (string_of_num n) pp_var v - + | Int 0 -> () + | _ -> Printf.fprintf o "(* %s %a)" (string_of_num n) pp_var v let rec pp_gen pp_var o v = match v with | [] -> output_string o "0" | [e] -> pp_var_num pp_var o e - | e::l -> Printf.fprintf o "%a + %a" (pp_var_num pp_var) e (pp_gen pp_var) l - + | e :: l -> Printf.fprintf o "%a + %a" (pp_var_num pp_var) e (pp_gen pp_var) l let pp_var o v = Printf.fprintf o "x%i" v - let pp o v = pp_gen pp_var o v -let pp_smt o v = - let list o v = List.iter (fun e -> Printf.fprintf o "%a " (pp_var_num_smt pp_var) e) v in +let pp_smt o v = + let list o v = + List.iter (fun e -> Printf.fprintf o "%a " (pp_var_num_smt pp_var) e) v + in Printf.fprintf o "(+ %a)" list v -let from_list (l: num list) = +let from_list (l : num list) = let rec xfrom_list i l = match l with | [] -> [] - | e::l -> - if e <>/ Int 0 - then (i,e)::(xfrom_list (i+1) l) - else xfrom_list (i+1) l in - + | e :: l -> + if e <>/ Int 0 then (i, e) :: xfrom_list (i + 1) l + else xfrom_list (i + 1) l + in xfrom_list 0 l let zero_num = Int 0 - let to_list m = let rec xto_list i l = match l with | [] -> [] - | (x,v)::l' -> - if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in + | (x, v) :: l' -> + if i = x then v :: xto_list (i + 1) l' else zero_num :: xto_list (i + 1) l + in xto_list 0 m - -let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst +let cons i v rst = if v =/ Int 0 then rst else (i, v) :: rst let rec update i f t = match t with | [] -> cons i (f zero_num) [] - | (k,v)::l -> - match Int.compare i k with - | 0 -> cons k (f v) l - | -1 -> cons i (f zero_num) t - | 1 -> (k,v) ::(update i f l) - | _ -> failwith "compare_num" + | (k, v) :: l -> ( + match Int.compare i k with + | 0 -> cons k (f v) l + | -1 -> cons i (f zero_num) t + | 1 -> (k, v) :: update i f l + | _ -> failwith "compare_num" ) let rec set i n t = match t with | [] -> cons i n [] - | (k,v)::l -> - match Int.compare i k with - | 0 -> cons k n l - | -1 -> cons i n t - | 1 -> (k,v) :: (set i n l) - | _ -> failwith "compare_num" - -let cst n = if n =/ Int 0 then [] else [0,n] + | (k, v) :: l -> ( + match Int.compare i k with + | 0 -> cons k n l + | -1 -> cons i n t + | 1 -> (k, v) :: set i n l + | _ -> failwith "compare_num" ) +let cst n = if n =/ Int 0 then [] else [(0, n)] let mul z t = match z with | Int 0 -> [] | Int 1 -> t - | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t + | _ -> List.map (fun (i, n) -> (i, mult_num z n)) t let div z t = - if z <>/ Int 1 - then List.map (fun (x,nx) -> (x,nx // z)) t - else t - - -let uminus t = List.map (fun (i,n) -> i, minus_num n) t - - -let rec add (ve1:t) (ve2:t) = - match ve1 , ve2 with - | [] , v | v , [] -> v - | (v1,c1)::l1 , (v2,c2)::l2 -> - let cmp = Util.pervasives_compare v1 v2 in - if cmp == 0 then - let s = add_num c1 c2 in - if eq_num (Int 0) s - then add l1 l2 - else (v1,s)::(add l1 l2) - else if cmp < 0 then (v1,c1) :: (add l1 ve2) - else (v2,c2) :: (add l2 ve1) - - -let rec xmul_add (n1:num) (ve1:t) (n2:num) (ve2:t) = - match ve1 , ve2 with - | [] , _ -> mul n2 ve2 - | _ , [] -> mul n1 ve1 - | (v1,c1)::l1 , (v2,c2)::l2 -> - let cmp = Util.pervasives_compare v1 v2 in - if cmp == 0 then - let s = ( n1 */ c1) +/ (n2 */ c2) in - if eq_num (Int 0) s - then xmul_add n1 l1 n2 l2 - else (v1,s)::(xmul_add n1 l1 n2 l2) - else if cmp < 0 then (v1,n1 */ c1) :: (xmul_add n1 l1 n2 ve2) - else (v2,n2 */c2) :: (xmul_add n1 ve1 n2 l2) + if z <>/ Int 1 then List.map (fun (x, nx) -> (x, nx // z)) t else t + +let uminus t = List.map (fun (i, n) -> (i, minus_num n)) t + +let rec add (ve1 : t) (ve2 : t) = + match (ve1, ve2) with + | [], v | v, [] -> v + | (v1, c1) :: l1, (v2, c2) :: l2 -> + let cmp = Int.compare v1 v2 in + if cmp == 0 then + let s = add_num c1 c2 in + if eq_num (Int 0) s then add l1 l2 else (v1, s) :: add l1 l2 + else if cmp < 0 then (v1, c1) :: add l1 ve2 + else (v2, c2) :: add l2 ve1 + +let rec xmul_add (n1 : num) (ve1 : t) (n2 : num) (ve2 : t) = + match (ve1, ve2) with + | [], _ -> mul n2 ve2 + | _, [] -> mul n1 ve1 + | (v1, c1) :: l1, (v2, c2) :: l2 -> + let cmp = Int.compare v1 v2 in + if cmp == 0 then + let s = (n1 */ c1) +/ (n2 */ c2) in + if eq_num (Int 0) s then xmul_add n1 l1 n2 l2 + else (v1, s) :: xmul_add n1 l1 n2 l2 + else if cmp < 0 then (v1, n1 */ c1) :: xmul_add n1 l1 n2 ve2 + else (v2, n2 */ c2) :: xmul_add n1 ve1 n2 l2 let mul_add n1 ve1 n2 ve2 = - if n1 =/ Int 1 && n2 =/ Int 1 - then add ve1 ve2 - else xmul_add n1 ve1 n2 ve2 + if n1 =/ Int 1 && n2 =/ Int 1 then add ve1 ve2 else xmul_add n1 ve1 n2 ve2 - -let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical - [ - (fun () -> Int.compare (fst x) (fst y)); - (fun () -> compare_num (snd x) (snd y))]) +let compare : t -> t -> int = + Mutils.Cmp.compare_list (fun x y -> + Mutils.Cmp.compare_lexical + [ (fun () -> Int.compare (fst x) (fst y)) + ; (fun () -> compare_num (snd x) (snd y)) ]) (** [tail v vect] returns - [None] if [v] is not a variable of the vector [vect] @@ -189,150 +170,124 @@ let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.com and [rst] is the remaining of the vector We exploit that vectors are ordered lists *) -let rec tail (v:var) (vect:t) = +let rec tail (v : var) (vect : t) = match vect with | [] -> None - | (v',vl)::vect' -> - match Int.compare v' v with - | 0 -> Some (vl,vect) (* Ok, found *) - | -1 -> tail v vect' (* Might be in the tail *) - | _ -> None (* Hopeless *) - -let get v vect = - match tail v vect with - | None -> Int 0 - | Some(vl,_) -> vl - -let is_constant v = - match v with - | [] | [0,_] -> true - | _ -> false - - - -let get_cst vect = - match vect with - | (0,v)::_ -> v - | _ -> Int 0 - -let choose v = - match v with - | [] -> None - | (vr,vl)::rst -> Some (vr,vl,rst) - - -let rec fresh v = - match v with - | [] -> 1 - | [v,_] -> v + 1 - | _::v -> fresh v - - -let variables v = - List.fold_left (fun acc (x,_) -> ISet.add x acc) ISet.empty v - -let decomp_cst v = - match v with - | (0,vl)::v -> vl,v - | _ -> Int 0,v + | (v', vl) :: vect' -> ( + match Int.compare v' v with + | 0 -> Some (vl, vect) (* Ok, found *) + | -1 -> tail v vect' (* Might be in the tail *) + | _ -> None ) + +(* Hopeless *) + +let get v vect = match tail v vect with None -> Int 0 | Some (vl, _) -> vl +let is_constant v = match v with [] | [(0, _)] -> true | _ -> false +let get_cst vect = match vect with (0, v) :: _ -> v | _ -> Int 0 +let choose v = match v with [] -> None | (vr, vl) :: rst -> Some (vr, vl, rst) +let rec fresh v = match v with [] -> 1 | [(v, _)] -> v + 1 | _ :: v -> fresh v +let variables v = List.fold_left (fun acc (x, _) -> ISet.add x acc) ISet.empty v +let decomp_cst v = match v with (0, vl) :: v -> (vl, v) | _ -> (Int 0, v) let rec decomp_at i v = match v with - | [] -> (Int 0 , null) - | (vr,vl)::r -> if i = vr then (vl,r) - else if i < vr then (Int 0,v) - else decomp_at i r + | [] -> (Int 0, null) + | (vr, vl) :: r -> + if i = vr then (vl, r) else if i < vr then (Int 0, v) else decomp_at i r -let decomp_fst v = - match v with - | [] -> ((0,Int 0),[]) - | x::v -> (x,v) +let decomp_fst v = match v with [] -> ((0, Int 0), []) | x :: v -> (x, v) +let rec subst (vr : int) (e : t) (v : t) = + match v with + | [] -> [] + | (x, n) :: v' -> ( + match Int.compare vr x with + | 0 -> mul_add n e (Int 1) v' + | -1 -> v + | 1 -> add [(x, n)] (subst vr e v') + | _ -> assert false ) -let fold f acc v = - List.fold_left (fun acc (v,i) -> f acc v i) acc v +let fold f acc v = List.fold_left (fun acc (v, i) -> f acc v i) acc v let fold_error f acc v = let rec fold acc v = match v with | [] -> Some acc - | (x,i)::v' -> match f acc x i with - | None -> None - | Some acc' -> fold acc' v' in + | (x, i) :: v' -> ( + match f acc x i with None -> None | Some acc' -> fold acc' v' ) + in fold acc v - - let rec find p v = match v with | [] -> None - | (v,n)::v' -> match p v n with - | None -> find p v' - | Some r -> Some r - - -let for_all p l = - List.for_all (fun (v,n) -> p v n) l - + | (v, n) :: v' -> ( match p v n with None -> find p v' | Some r -> Some r ) -let decr_var i v = List.map (fun (v,n) -> (v-i,n)) v -let incr_var i v = List.map (fun (v,n) -> (v+i,n)) v +let for_all p l = List.for_all (fun (v, n) -> p v n) l +let decr_var i v = List.map (fun (v, n) -> (v - i, n)) v +let incr_var i v = List.map (fun (v, n) -> (v + i, n)) v open Big_int let gcd v = - let res = fold (fun c _ n -> - assert (Int.equal (compare_big_int (denominator n) unit_big_int) 0); - gcd_big_int c (numerator n)) zero_big_int v in - if Int.equal (compare_big_int res zero_big_int) 0 - then unit_big_int else res + let res = + fold + (fun c _ n -> + assert (Int.equal (compare_big_int (denominator n) unit_big_int) 0); + gcd_big_int c (numerator n)) + zero_big_int v + in + if Int.equal (compare_big_int res zero_big_int) 0 then unit_big_int else res let normalise v = let ppcm = fold (fun c _ n -> ppcm c (denominator n)) unit_big_int v in - let gcd = + let gcd = let gcd = fold (fun c _ n -> gcd_big_int c (numerator n)) zero_big_int v in - if Int.equal (compare_big_int gcd zero_big_int) 0 then unit_big_int else gcd in - List.map (fun (x,v) -> (x, v */ (Big_int ppcm) // (Big_int gcd))) v + if Int.equal (compare_big_int gcd zero_big_int) 0 then unit_big_int else gcd + in + List.map (fun (x, v) -> (x, v */ Big_int ppcm // Big_int gcd)) v let rec exists2 p vect1 vect2 = - match vect1 , vect2 with - | _ , [] | [], _ -> None - | (v1,n1)::vect1' , (v2, n2) :: vect2' -> - if Int.equal v1 v2 - then - if p n1 n2 - then Some (v1,n1,n2) - else - exists2 p vect1' vect2' - else - if v1 < v2 - then exists2 p vect1' vect2 - else exists2 p vect1 vect2' + match (vect1, vect2) with + | _, [] | [], _ -> None + | (v1, n1) :: vect1', (v2, n2) :: vect2' -> + if Int.equal v1 v2 then + if p n1 n2 then Some (v1, n1, n2) else exists2 p vect1' vect2' + else if v1 < v2 then exists2 p vect1' vect2 + else exists2 p vect1 vect2' let dotproduct v1 v2 = let rec dot acc v1 v2 = - match v1, v2 with - | [] , _ | _ , [] -> acc - | (x1,n1)::v1', (x2,n2)::v2' -> - if x1 == x2 - then dot (acc +/ n1 */ n2) v1' v2' - else if x1 < x2 - then dot acc v1' v2 - else dot acc v1 v2' in + match (v1, v2) with + | [], _ | _, [] -> acc + | (x1, n1) :: v1', (x2, n2) :: v2' -> + if x1 == x2 then dot (acc +/ (n1 */ n2)) v1' v2' + else if x1 < x2 then dot acc v1' v2 + else dot acc v1 v2' + in dot (Int 0) v1 v2 - -let map f v = List.map (fun (x,v) -> f x v) v +let map f v = List.map (fun (x, v) -> f x v) v let abs_min_elt v = match v with | [] -> None - | (v,vl)::r -> - Some (List.fold_left (fun (v1,vl1) (v2,vl2) -> - if abs_num vl1 </ abs_num vl2 - then (v1,vl1) else (v2,vl2) ) (v,vl) r) - + | (v, vl) :: r -> + Some + (List.fold_left + (fun (v1, vl1) (v2, vl2) -> + if abs_num vl1 </ abs_num vl2 then (v1, vl1) else (v2, vl2)) + (v, vl) r) + +let partition p = List.partition (fun (vr, vl) -> p vr vl) +let mkvar x = set x (Int 1) null -let partition p = List.partition (fun (vr,vl) -> p vr vl) +module Bound = struct + type t = {cst : num; var : var; coeff : num} -let mkvar x = set x (Int 1) null + let of_vect (v : vector) = + match v with + | [(x, v)] -> if x = 0 then None else Some {cst = Int 0; var = x; coeff = v} + | [(0, v); (x, v')] -> Some {cst = v; var = x; coeff = v'} + | _ -> None +end diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli index 40ef8078e4..4b814cbb82 100644 --- a/plugins/micromega/vect.mli +++ b/plugins/micromega/vect.mli @@ -11,9 +11,11 @@ open Num open Mutils -type var = int (** Variables are simply (positive) integers. *) +type var = int +(** Variables are simply (positive) integers. *) -type t (** The type of vectors or equivalently linear expressions. +type t +(** The type of vectors or equivalently linear expressions. The current implementation is using association lists. A list [(0,c),(x1,ai),...,(xn,an)] represents the linear expression c + a1.xn + ... an.xn where ai are rational constants and xi are variables. @@ -23,6 +25,8 @@ type t (** The type of vectors or equivalently linear expressions. are not represented. *) +type vector = t + (** {1 Generic functions} *) (** [hash] [equal] and [compare] so that Vect.t can be used as @@ -34,140 +38,147 @@ val compare : t -> t -> int (** {1 Basic accessors and utility functions} *) +val pp_gen : (out_channel -> var -> unit) -> out_channel -> t -> unit (** [pp_gen pp_var o v] prints the representation of the vector [v] over the channel [o] *) -val pp_gen : (out_channel -> var -> unit) -> out_channel -> t -> unit -(** [pp o v] prints the representation of the vector [v] over the channel [o] *) val pp : out_channel -> t -> unit +(** [pp o v] prints the representation of the vector [v] over the channel [o] *) -(** [pp_smt o v] prints the representation of the vector [v] over the channel [o] using SMTLIB conventions *) val pp_smt : out_channel -> t -> unit +(** [pp_smt o v] prints the representation of the vector [v] over the channel [o] using SMTLIB conventions *) -(** [variables v] returns the set of variables with non-zero coefficients *) val variables : t -> ISet.t +(** [variables v] returns the set of variables with non-zero coefficients *) -(** [get_cst v] returns c i.e. the coefficient of the variable zero *) val get_cst : t -> num +(** [get_cst v] returns c i.e. the coefficient of the variable zero *) -(** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) val decomp_cst : t -> num * t +(** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) -(** [decomp_cst v] returns the pair (ai, ai+1.xi+...+an.xn) *) val decomp_at : int -> t -> num * t +(** [decomp_cst v] returns the pair (ai, ai+1.xi+...+an.xn) *) val decomp_fst : t -> (var * num) * t -(** [cst c] returns the vector v=c+0.x1+...+0.xn *) val cst : num -> t +(** [cst c] returns the vector v=c+0.x1+...+0.xn *) +val is_constant : t -> bool (** [is_constant v] holds if [v] is a constant vector i.e. v=c+0.x1+...+0.xn *) -val is_constant : t -> bool -(** [null] is the empty vector i.e. 0+0.x1+...+0.xn *) val null : t +(** [null] is the empty vector i.e. 0+0.x1+...+0.xn *) -(** [is_null v] returns whether [v] is the [null] vector i.e [equal v null] *) val is_null : t -> bool +(** [is_null v] returns whether [v] is the [null] vector i.e [equal v null] *) +val get : var -> t -> num (** [get xi v] returns the coefficient ai of the variable [xi]. [get] is also defined for the variable 0 *) -val get : var -> t -> num +val set : var -> num -> t -> t (** [set xi ai' v] returns the vector c+a1.x1+...ai'.xi+...+an.xn i.e. the coefficient of the variable xi is set to ai' *) -val set : var -> num -> t -> t -(** [mkvar xi] returns 1.xi *) val mkvar : var -> t +(** [mkvar xi] returns 1.xi *) +val update : var -> (num -> num) -> t -> t (** [update xi f v] returns c+a1.x1+...+f(ai).xi+...+an.xn *) -val update : var -> (num -> num) -> t -> t -(** [fresh v] return the fresh variable with index 1+ max (variables v) *) val fresh : t -> int +(** [fresh v] return the fresh variable with index 1+ max (variables v) *) +val choose : t -> (var * num * t) option (** [choose v] decomposes a vector [v] depending on whether it is [null] or not. @return None if v is [null] @return Some(x,n,r) where v = r + n.x x is the smallest variable with non-zero coefficient n <> 0. *) -val choose : t -> (var * num * t) option -(** [from_list l] returns the vector c+a1.x1...an.xn from the list of coefficient [l=c;a1;...;an] *) val from_list : num list -> t +(** [from_list l] returns the vector c+a1.x1...an.xn from the list of coefficient [l=c;a1;...;an] *) +val to_list : t -> num list (** [to_list v] returns the list of all coefficient of the vector v i.e. [c;a1;...;an] The list representation is (obviously) not sparsed and therefore certain ai may be 0 *) -val to_list : t -> num list +val decr_var : int -> t -> t (** [decr_var i v] decrements the variables of the vector [v] by the amount [i]. Beware, it is only defined if all the variables of v are greater than i *) -val decr_var : int -> t -> t +val incr_var : int -> t -> t (** [incr_var i v] increments the variables of the vector [v] by the amount [i]. *) -val incr_var : int -> t -> t +val gcd : t -> Big_int.big_int (** [gcd v] returns gcd(num(c),num(a1),...,num(an)) where num extracts the numerator of a rational value. *) -val gcd : t -> Big_int.big_int -(** [normalise v] returns a vector with only integer coefficients *) val normalise : t -> t - +(** [normalise v] returns a vector with only integer coefficients *) (** {1 Linear arithmetics} *) +val add : t -> t -> t (** [add v1 v2] is vector addition. @param v1 is of the form c +a1.x1 +...+an.xn @param v2 is of the form c'+a1'.x1 +...+an'.xn @return c1+c1'+ (a1+a1').x1 + ... + (an+an').xn *) -val add : t -> t -> t +val mul : num -> t -> t (** [mul a v] is vector multiplication of vector [v] by a scalar [a]. @return a.v = a.c+a.a1.x1+...+a.an.xn *) -val mul : num -> t -> t -(** [mul_add c1 v1 c2 v2] returns the linear combination c1.v1+c2.v2 *) val mul_add : num -> t -> num -> t -> t +(** [mul_add c1 v1 c2 v2] returns the linear combination c1.v1+c2.v2 *) + +val subst : int -> t -> t -> t +(** [subst x v v'] replaces x by v in vector v' *) -(** [div c1 v1] returns the mutiplication by the inverse of c1 i.e (1/c1).v1 *) val div : num -> t -> t +(** [div c1 v1] returns the mutiplication by the inverse of c1 i.e (1/c1).v1 *) -(** [uminus v] @return -v the opposite vector of v i.e. (-1).v *) val uminus : t -> t +(** [uminus v] @return -v the opposite vector of v i.e. (-1).v *) (** {1 Iterators} *) -(** [fold f acc v] returns f (f (f acc 0 c ) x1 a1 ) ... xn an *) val fold : ('acc -> var -> num -> 'acc) -> 'acc -> t -> 'acc +(** [fold f acc v] returns f (f (f acc 0 c ) x1 a1 ) ... xn an *) +val fold_error : ('acc -> var -> num -> 'acc option) -> 'acc -> t -> 'acc option (** [fold_error f acc v] is the same as [fold (fun acc x i -> match acc with None -> None | Some acc' -> f acc' x i) (Some acc) v] but with early exit... *) -val fold_error : ('acc -> var -> num -> 'acc option) -> 'acc -> t -> 'acc option +val find : (var -> num -> 'c option) -> t -> 'c option (** [find f v] returns the first [f xi ai] such that [f xi ai <> None]. If no such xi ai exists, it returns None *) -val find : (var -> num -> 'c option) -> t -> 'c option -(** [for_all p v] returns /\_{i>=0} (f xi ai) *) val for_all : (var -> num -> bool) -> t -> bool +(** [for_all p v] returns /\_{i>=0} (f xi ai) *) +val exists2 : (num -> num -> bool) -> t -> t -> (var * num * num) option (** [exists2 p v v'] returns Some(xi,ai,ai') if p(xi,ai,ai') holds and ai,ai' <> 0. It returns None if no such pair of coefficient exists. *) -val exists2 : (num -> num -> bool) -> t -> t -> (var * num * num) option -(** [dotproduct v1 v2] is the dot product of v1 and v2. *) val dotproduct : t -> t -> num +(** [dotproduct v1 v2] is the dot product of v1 and v2. *) val map : (var -> num -> 'a) -> t -> 'a list - val abs_min_elt : t -> (var * num) option - val partition : (var -> num -> bool) -> t -> t * t + +module Bound : sig + type t = {cst : num; var : var; coeff : num} + (** represents a0 + ai.xi *) + + val of_vect : vector -> t option +end diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index 0a57677220..5d8ae83853 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -27,10 +27,7 @@ let pr_constr env evd e = Printer.pr_econstr_env env evd e let rec find_option pred l = match l with | [] -> raise Not_found - | e::l -> match pred e with - | Some r -> r - | None -> find_option pred l - + | e :: l -> ( match pred e with Some r -> r | None -> find_option pred l ) (** [HConstr] is a map indexed by EConstr.t. It should only be used using closed terms. @@ -39,8 +36,7 @@ module HConstr = struct module M = Map.Make (struct type t = EConstr.t - let compare c c' = - Constr.compare (unsafe_to_constr c) (unsafe_to_constr c') + let compare c c' = Constr.compare (unsafe_to_constr c) (unsafe_to_constr c') end) type 'a t = 'a list M.t @@ -52,91 +48,89 @@ module HConstr = struct M.add h (e :: l) m let empty = M.empty - let find h m = match lfind h m with e :: _ -> e | [] -> raise Not_found - let find_all = lfind let fold f m acc = M.fold (fun k l acc -> List.fold_left (fun acc e -> f k e acc) acc l) m acc - end - (** [get_projections_from_constant (evd,c) ] returns an array of constr [| a1,.. an|] such that [c] is defined as Definition c := mk a1 .. an with mk a constructor. ai is therefore either a type parameter or a projection. *) - let get_projections_from_constant (evd, i) = - match EConstr.kind evd (Reductionops.clos_whd_flags CClosure.all (Global.env ()) evd i) with + match + EConstr.kind evd + (Reductionops.clos_whd_flags CClosure.all (Global.env ()) evd i) + with | App (c, a) -> Some a | _ -> - raise (CErrors.user_err Pp.(str "The hnf of term " ++ pr_constr (Global.env ()) evd i - ++ str " should be an application i.e. (c a1 ... an)")) + raise + (CErrors.user_err + Pp.( + str "The hnf of term " + ++ pr_constr (Global.env ()) evd i + ++ str " should be an application i.e. (c a1 ... an)")) (** An instance of type, say T, is registered into a hashtable, say TableT. *) type 'a decl = - { decl: EConstr.t + { decl : EConstr.t ; (* Registered type instance *) - deriv: 'a - (* Projections of insterest *) } - + deriv : 'a (* Projections of insterest *) } module EInjT = struct type t = - { isid: bool + { isid : bool ; (* S = T -> inj = fun x -> x*) - source: EConstr.t + source : EConstr.t ; (* S *) - target: EConstr.t + target : EConstr.t ; (* T *) (* projections *) - inj: EConstr.t + inj : EConstr.t ; (* S -> T *) - pred: EConstr.t + pred : EConstr.t ; (* T -> Prop *) - cstr: EConstr.t option - (* forall x, pred (inj x) *) } + cstr : EConstr.t option (* forall x, pred (inj x) *) } end module EBinOpT = struct type t = { (* Op : source1 -> source2 -> source3 *) - source1: EConstr.t - ; source2: EConstr.t - ; source3: EConstr.t - ; target: EConstr.t - ; inj1: EConstr.t + source1 : EConstr.t + ; source2 : EConstr.t + ; source3 : EConstr.t + ; target : EConstr.t + ; inj1 : EConstr.t ; (* InjTyp source1 target *) - inj2: EConstr.t + inj2 : EConstr.t ; (* InjTyp source2 target *) - inj3: EConstr.t + inj3 : EConstr.t ; (* InjTyp source3 target *) - tbop: EConstr.t - (* TBOpInj *) } + tbop : EConstr.t (* TBOpInj *) } end module ECstOpT = struct - type t = {source: EConstr.t; target: EConstr.t; inj: EConstr.t} + type t = {source : EConstr.t; target : EConstr.t; inj : EConstr.t} end module EUnOpT = struct type t = - { source1: EConstr.t - ; source2: EConstr.t - ; target: EConstr.t - ; inj1_t: EConstr.t - ; inj2_t: EConstr.t - ; unop: EConstr.t } + { source1 : EConstr.t + ; source2 : EConstr.t + ; target : EConstr.t + ; inj1_t : EConstr.t + ; inj2_t : EConstr.t + ; unop : EConstr.t } end module EBinRelT = struct type t = - {source: EConstr.t; target: EConstr.t; inj: EConstr.t; brel: EConstr.t} + {source : EConstr.t; target : EConstr.t; inj : EConstr.t; brel : EConstr.t} end module EPropBinOpT = struct @@ -147,37 +141,32 @@ module EPropUnOpT = struct type t = EConstr.t end - module ESatT = struct - type t = {parg1: EConstr.t; parg2: EConstr.t; satOK: EConstr.t} + type t = {parg1 : EConstr.t; parg2 : EConstr.t; satOK : EConstr.t} end (* Different type of declarations *) type decl_kind = | PropOp of EPropBinOpT.t decl - | PropUnOp of EPropUnOpT.t decl - | InjTyp of EInjT.t decl - | BinRel of EBinRelT.t decl - | BinOp of EBinOpT.t decl - | UnOp of EUnOpT.t decl - | CstOp of ECstOpT.t decl - | Saturate of ESatT.t decl - - -let get_decl = function + | PropUnOp of EPropUnOpT.t decl + | InjTyp of EInjT.t decl + | BinRel of EBinRelT.t decl + | BinOp of EBinOpT.t decl + | UnOp of EUnOpT.t decl + | CstOp of ECstOpT.t decl + | Saturate of ESatT.t decl + +let get_decl = function | PropOp d -> d.decl - | PropUnOp d -> d.decl - | InjTyp d -> d.decl - | BinRel d -> d.decl - | BinOp d -> d.decl - | UnOp d -> d.decl - | CstOp d -> d.decl - | Saturate d -> d.decl - -type term_kind = - | Application of EConstr.constr - | OtherTerm of EConstr.constr + | PropUnOp d -> d.decl + | InjTyp d -> d.decl + | BinRel d -> d.decl + | BinOp d -> d.decl + | UnOp d -> d.decl + | CstOp d -> d.decl + | Saturate d -> d.decl +type term_kind = Application of EConstr.constr | OtherTerm of EConstr.constr module type Elt = sig type elt @@ -185,11 +174,9 @@ module type Elt = sig val name : string (** name *) - val table : (term_kind * decl_kind) HConstr.t ref - + val table : (term_kind * decl_kind) HConstr.t ref val cast : elt decl -> decl_kind - - val dest : decl_kind -> (elt decl) option + val dest : decl_kind -> elt decl option val get_key : int (** [get_key] is the type-index used as key for the instance *) @@ -199,19 +186,14 @@ module type Elt = sig built from the type-instance i and the arguments (type indexes and projections) of the type-class constructor. *) - (* val arity : int*) - + (* val arity : int*) end - -let table = Summary.ref ~name:("zify_table") HConstr.empty - -let saturate = Summary.ref ~name:("zify_saturate") HConstr.empty - +let table = Summary.ref ~name:"zify_table" HConstr.empty +let saturate = Summary.ref ~name:"zify_saturate" HConstr.empty let table_cache = ref HConstr.empty let saturate_cache = ref HConstr.empty - (** Each type-class gives rise to a different table. They only differ on how projections are extracted. *) module EInj = struct @@ -220,186 +202,129 @@ module EInj = struct type elt = EInjT.t let name = "EInj" - let table = table - let cast x = InjTyp x - - let dest = function - | InjTyp x -> Some x - | _ -> None - + let dest = function InjTyp x -> Some x | _ -> None let mk_elt evd i (a : EConstr.t array) = let isid = EConstr.eq_constr evd a.(0) a.(1) in { isid - ; source= a.(0) - ; target= a.(1) - ; inj= a.(2) - ; pred= a.(3) - ; cstr= (if isid then None else Some a.(4)) } + ; source = a.(0) + ; target = a.(1) + ; inj = a.(2) + ; pred = a.(3) + ; cstr = (if isid then None else Some a.(4)) } let get_key = 0 - end module EBinOp = struct type elt = EBinOpT.t + open EBinOpT let name = "BinOp" - let table = table let mk_elt evd i a = - { source1= a.(0) - ; source2= a.(1) - ; source3= a.(2) - ; target= a.(3) - ; inj1= a.(5) - ; inj2= a.(6) - ; inj3= a.(7) - ; tbop= a.(9) } + { source1 = a.(0) + ; source2 = a.(1) + ; source3 = a.(2) + ; target = a.(3) + ; inj1 = a.(5) + ; inj2 = a.(6) + ; inj3 = a.(7) + ; tbop = a.(9) } let get_key = 4 - - let cast x = BinOp x - - let dest = function - | BinOp x -> Some x - | _ -> None - + let dest = function BinOp x -> Some x | _ -> None end module ECstOp = struct type elt = ECstOpT.t + open ECstOpT let name = "CstOp" - let table = table - let cast x = CstOp x - - let dest = function - | CstOp x -> Some x - | _ -> None - - - let mk_elt evd i a = {source= a.(0); target= a.(1); inj= a.(3)} - + let dest = function CstOp x -> Some x | _ -> None + let mk_elt evd i a = {source = a.(0); target = a.(1); inj = a.(3)} let get_key = 2 - end module EUnOp = struct type elt = EUnOpT.t + open EUnOpT let name = "UnOp" - let table = table - let cast x = UnOp x - - let dest = function - | UnOp x -> Some x - | _ -> None - + let dest = function UnOp x -> Some x | _ -> None let mk_elt evd i a = - { source1= a.(0) - ; source2= a.(1) - ; target= a.(2) - ; inj1_t= a.(4) - ; inj2_t= a.(5) - ; unop= a.(6) } + { source1 = a.(0) + ; source2 = a.(1) + ; target = a.(2) + ; inj1_t = a.(4) + ; inj2_t = a.(5) + ; unop = a.(6) } let get_key = 3 - end module EBinRel = struct type elt = EBinRelT.t + open EBinRelT let name = "BinRel" - let table = table - let cast x = BinRel x + let dest = function BinRel x -> Some x | _ -> None - let dest = function - | BinRel x -> Some x - | _ -> None - - let mk_elt evd i a = {source= a.(0); target= a.(1); inj= a.(3); brel= a.(4)} + let mk_elt evd i a = + {source = a.(0); target = a.(1); inj = a.(3); brel = a.(4)} let get_key = 2 - end module EPropOp = struct type elt = EConstr.t let name = "PropBinOp" - let table = table - let cast x = PropOp x - - let dest = function - | PropOp x -> Some x - | _ -> None - + let dest = function PropOp x -> Some x | _ -> None let mk_elt evd i a = i - let get_key = 0 - end module EPropUnOp = struct type elt = EConstr.t let name = "PropUnOp" - let table = table - let cast x = PropUnOp x - - let dest = function - | PropUnOp x -> Some x - | _ -> None - + let dest = function PropUnOp x -> Some x | _ -> None let mk_elt evd i a = i - let get_key = 0 - end - - -let constr_of_term_kind = function - | Application c -> c - | OtherTerm c -> c - - +let constr_of_term_kind = function Application c -> c | OtherTerm c -> c let fold_declared_const f evd acc = HConstr.fold - (fun _ (_,e) acc -> f (fst (EConstr.destConst evd (get_decl e))) acc) - (!table_cache) acc - - + (fun _ (_, e) acc -> f (fst (EConstr.destConst evd (get_decl e))) acc) + !table_cache acc module type S = sig val register : Constrexpr.constr_expr -> unit - val print : unit -> unit end - module MakeTable (E : Elt) = struct (** Given a term [c] and its arguments ai, we construct a HConstr.t table that is @@ -410,33 +335,34 @@ module MakeTable (E : Elt) = struct let make_elt (evd, i) = match get_projections_from_constant (evd, i) with | None -> - let env = Global.env () in - let t = string_of_ppcmds (pr_constr env evd i) in - failwith ("Cannot register term " ^ t) + let env = Global.env () in + let t = string_of_ppcmds (pr_constr env evd i) in + failwith ("Cannot register term " ^ t) | Some a -> E.mk_elt evd i a - let register_hint evd t elt = + let register_hint evd t elt = match EConstr.kind evd t with - | App(c,_) -> - E.table := HConstr.add c (Application t, E.cast elt) !E.table - | _ -> E.table := HConstr.add t (OtherTerm t, E.cast elt) !E.table - - - + | App (c, _) -> + E.table := HConstr.add c (Application t, E.cast elt) !E.table + | _ -> E.table := HConstr.add t (OtherTerm t, E.cast elt) !E.table let register_constr env evd c = let c = EConstr.of_constr c in let t = get_type_of env evd c in match EConstr.kind evd t with | App (intyp, args) -> - let styp = args.(E.get_key) in - let elt = {decl= c; deriv= (make_elt (evd, c))} in - register_hint evd styp elt + let styp = args.(E.get_key) in + let elt = {decl = c; deriv = make_elt (evd, c)} in + register_hint evd styp elt | _ -> - let env = Global.env () in - raise (CErrors.user_err Pp. - (str ": Cannot register term "++pr_constr env evd c++ - str ". It has type "++pr_constr env evd t++str " which should be of the form [F X1 .. Xn]")) + let env = Global.env () in + raise + (CErrors.user_err + Pp.( + str ": Cannot register term " + ++ pr_constr env evd c ++ str ". It has type " + ++ pr_constr env evd t + ++ str " which should be of the form [F X1 .. Xn]")) let register_obj : Constr.constr -> Libobject.obj = let cache_constr (_, c) = @@ -447,7 +373,7 @@ module MakeTable (E : Elt) = struct let subst_constr (subst, c) = Mod_subst.subst_mps subst c in Libobject.declare_object @@ Libobject.superglobal_object_nodischarge - ("register-zify-" ^ E.name) + ("register-zify-" ^ E.name) ~cache:cache_constr ~subst:(Some subst_constr) (** [register c] is called from the VERNACULAR ADD [name] constr(t). @@ -455,52 +381,40 @@ module MakeTable (E : Elt) = struct registered as a [superglobal_object_nodischarge]. TODO: pre-compute [get_type_of] - [cache_constr] is using another environment. *) - let register = fun c -> + let register c = let env = Global.env () in let evd = Evd.from_env env in let evd, c = Constrintern.interp_open_constr env evd c in let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in () - let pp_keys () = let env = Global.env () in let evd = Evd.from_env env in HConstr.fold - (fun _ (k,d) acc -> + (fun _ (k, d) acc -> match E.dest d with | None -> acc | Some _ -> - Pp.(pr_constr env evd (constr_of_term_kind k) ++ str " " ++ acc)) - (!E.table) (Pp.str "") - - - let print () = Feedback.msg_info (pp_keys ()) + Pp.(pr_constr env evd (constr_of_term_kind k) ++ str " " ++ acc)) + !E.table (Pp.str "") + let print () = Feedback.msg_info (pp_keys ()) end - module InjTable = MakeTable (EInj) - module ESat = struct type elt = ESatT.t + open ESatT let name = "Saturate" - let table = saturate - let cast x = Saturate x - - let dest = function - | Saturate x -> Some x - | _ -> None - - let mk_elt evd i a = {parg1= a.(2); parg2= a.(3); satOK= a.(5)} - + let dest = function Saturate x -> Some x | _ -> None + let mk_elt evd i a = {parg1 = a.(2); parg2 = a.(3); satOK = a.(5)} let get_key = 1 - end module BinOp = MakeTable (EBinOp) @@ -512,10 +426,9 @@ module PropUnOp = MakeTable (EPropUnOp) module Saturate = MakeTable (ESat) let init_cache () = - table_cache := !table; + table_cache := !table; saturate_cache := !saturate - (** The module [Spec] is used to register the instances of [BinOpSpec], [UnOpSpec]. They are not indexed and stored in a list. *) @@ -556,7 +469,6 @@ module Spec = struct Feedback.msg_notice l end - let unfold_decl evd = let f cst acc = cst :: acc in fold_declared_const f evd [] @@ -578,33 +490,19 @@ let locate_const str = (* The following [constr] are necessary for constructing the proof terms *) let mkapp2 = lazy (zify "mkapp2") - let mkapp = lazy (zify "mkapp") - let mkapp0 = lazy (zify "mkapp0") - let mkdp = lazy (zify "mkinjterm") - let eq_refl = lazy (zify "eq_refl") - let mkrel = lazy (zify "mkrel") - let mkprop_op = lazy (zify "mkprop_op") - let mkuprop_op = lazy (zify "mkuprop_op") - let mkdpP = lazy (zify "mkinjprop") - let iff_refl = lazy (zify "iff_refl") - let q = lazy (zify "target_prop") - let ieq = lazy (zify "injprop_ok") - let iff = lazy (zify "iff") - - (* A super-set of the previous are needed to unfold the generated proof terms. *) let to_unfold = @@ -631,7 +529,6 @@ let to_unfold = ; "mkapp0" ; "mkprop_op" ]) - (** Module [CstrTable] records terms [x] injected into [inj x] together with the corresponding type constraint. The terms are stored by side-effect during the traversal @@ -644,17 +541,15 @@ module CstrTable = struct type t = EConstr.t let hash c = Constr.hash (unsafe_to_constr c) - let equal c c' = Constr.equal (unsafe_to_constr c) (unsafe_to_constr c') end) let table : EConstr.t HConstr.t = HConstr.create 10 - let register evd t (i : EConstr.t) = HConstr.add table t i let get () = let l = HConstr.fold (fun k i acc -> (k, i) :: acc) table [] in - HConstr.clear table ; l + HConstr.clear table; l (** [gen_cstr table] asserts (cstr k) for each element of the table (k,cstr). NB: the constraint is only asserted if it does not already exist in the context. @@ -667,7 +562,7 @@ module CstrTable = struct let hyps_table = HConstr.create 20 in List.iter (fun (_, (t : EConstr.types)) -> HConstr.add hyps_table t ()) - (Tacmach.New.pf_hyps_types gl) ; + (Tacmach.New.pf_hyps_types gl); fun c -> HConstr.mem hyps_table c in (* Add the constraint (cstr k) if it is not already present *) @@ -683,17 +578,16 @@ module CstrTable = struct (Names.Id.of_string "cstr") env in - Tactics.pose_proof (Names.Name n) term ) + Tactics.pose_proof (Names.Name n) term) in List.fold_left (fun acc (k, i) -> Tacticals.New.tclTHEN (gen k i) acc) - Tacticals.New.tclIDTAC table ) + Tacticals.New.tclIDTAC table) end let mkvar red evd inj v = ( if not red then - match inj.cstr with None -> () | Some ctr -> CstrTable.register evd v ctr - ) ; + match inj.cstr with None -> () | Some ctr -> CstrTable.register evd v ctr ); let iv = EConstr.mkApp (inj.inj, [|v|]) in let iv = if red then Tacred.compute (Global.env ()) evd iv else iv in EConstr.mkApp @@ -724,11 +618,8 @@ let inj_term_of_texpr evd = function | Var (inj, e) -> mkvar false evd inj e | Constant (inj, e) -> mkvar true evd inj e -let mkapp2_id evd i (* InjTyp S3 T *) - inj (* deriv i *) - t (* S1 -> S2 -> S3 *) - b (* Binop S1 S2 S3 t ... *) - dbop (* deriv b *) e1 e2 = +let mkapp2_id evd i (* InjTyp S3 T *) inj (* deriv i *) t (* S1 -> S2 -> S3 *) b + (* Binop S1 S2 S3 t ... *) dbop (* deriv b *) e1 e2 = let default () = let e1' = inj_term_of_texpr evd e1 in let e2' = inj_term_of_texpr evd e2 in @@ -755,15 +646,16 @@ let mkapp2_id evd i (* InjTyp S3 T *) |Var (_, e1), Var (_, e2) |Constant (_, e1), Var (_, e2) |Var (_, e1), Constant (_, e2) -> - Var (inj, EConstr.mkApp (t, [|e1; e2|])) + Var (inj, EConstr.mkApp (t, [|e1; e2|])) | _, _ -> default () let mkapp_id evd i inj (unop, u) f e1 = - EUnOpT.(if EConstr.eq_constr evd u.unop f then - (* Injection does nothing *) - match e1 with - | Constant (_, e) | Var (_, e) -> Var (inj, EConstr.mkApp (f, [|e|])) - | Injterm e1 -> + EUnOpT.( + if EConstr.eq_constr evd u.unop f then + (* Injection does nothing *) + match e1 with + | Constant (_, e) | Var (_, e) -> Var (inj, EConstr.mkApp (f, [|e|])) + | Injterm e1 -> Injterm (EConstr.mkApp ( force mkapp @@ -775,124 +667,128 @@ let mkapp_id evd i inj (unop, u) f e1 = ; u.inj2_t ; unop ; e1 |] )) - else - let e1 = inj_term_of_texpr evd e1 in - Injterm - (EConstr.mkApp - ( force mkapp - , [|u.source1; u.source2; u.target; f; u.inj1_t; u.inj2_t; unop; e1|] - ))) - -type typed_constr = {constr: EConstr.t; typ: EConstr.t} - + else + let e1 = inj_term_of_texpr evd e1 in + Injterm + (EConstr.mkApp + ( force mkapp + , [|u.source1; u.source2; u.target; f; u.inj1_t; u.inj2_t; unop; e1|] + ))) +type typed_constr = {constr : EConstr.t; typ : EConstr.t} let get_injection env evd t = match snd (HConstr.find t !table_cache) with | InjTyp i -> i - | _ -> raise Not_found - - - (* [arrow] is the term (fun (x:Prop) (y : Prop) => x -> y) *) - let arrow = - let name x = - Context.make_annot (Name.mk_name (Names.Id.of_string x)) Sorts.Relevant in - EConstr.mkLambda - ( name "x" - , EConstr.mkProp - , EConstr.mkLambda - ( name "y" - , EConstr.mkProp - , EConstr.mkProd - ( Context.make_annot Names.Anonymous Sorts.Relevant - , EConstr.mkRel 2 - , EConstr.mkRel 2 ) ) ) - - - let is_prop env sigma term = - let sort = Retyping.get_sort_of env sigma term in + | _ -> raise Not_found + +(* [arrow] is the term (fun (x:Prop) (y : Prop) => x -> y) *) +let arrow = + let name x = + Context.make_annot (Name.mk_name (Names.Id.of_string x)) Sorts.Relevant + in + EConstr.mkLambda + ( name "x" + , EConstr.mkProp + , EConstr.mkLambda + ( name "y" + , EConstr.mkProp + , EConstr.mkProd + ( Context.make_annot Names.Anonymous Sorts.Relevant + , EConstr.mkRel 2 + , EConstr.mkRel 2 ) ) ) + +let is_prop env sigma term = + let sort = Retyping.get_sort_of env sigma term in Sorts.is_prop sort - (** [get_application env evd e] expresses [e] as an application (c a) +(** [get_application env evd e] expresses [e] as an application (c a) where c is the head symbol and [a] is the array of arguments. The function also transforms (x -> y) as (arrow x y) *) - let get_operator env evd e = - let is_arrow a p1 p2 = - is_prop env evd p1 && is_prop (EConstr.push_rel (Context.Rel.Declaration.LocalAssum(a,p1)) env) evd p2 - && (a.Context.binder_name = Names.Anonymous || EConstr.Vars.noccurn evd 1 p2) in - match EConstr.kind evd e with - | Prod (a, p1, p2) when is_arrow a p1 p2 -> - (arrow,[|p1 ;p2|]) - | App(c,a) -> (c,a) - | _ -> (e,[||]) - +let get_operator env evd e = + let is_arrow a p1 p2 = + is_prop env evd p1 + && is_prop + (EConstr.push_rel (Context.Rel.Declaration.LocalAssum (a, p1)) env) + evd p2 + && (a.Context.binder_name = Names.Anonymous || EConstr.Vars.noccurn evd 1 p2) + in + match EConstr.kind evd e with + | Prod (a, p1, p2) when is_arrow a p1 p2 -> (arrow, [|p1; p2|]) + | App (c, a) -> (c, a) + | _ -> (e, [||]) - let is_convertible env evd k t = - Reductionops.check_conv env evd k t +let is_convertible env evd k t = Reductionops.check_conv env evd k t - (** [match_operator env evd hd arg (t,d)] +(** [match_operator env evd hd arg (t,d)] - hd is head operator of t - If t = OtherTerm _, then t = hd - If t = Application _, then we extract the relevant number of arguments from arg and check for convertibility *) - let match_operator env evd hd args (t, d) = - let decomp t i = - let n = Array.length args in - let t' = EConstr.mkApp(hd,Array.sub args 0 (n-i)) in - if is_convertible env evd t' t - then Some (d,t) - else None in - - match t with - | OtherTerm t -> Some(d,t) - | Application t -> - match d with - | CstOp _ -> decomp t 0 - | UnOp _ -> decomp t 1 - | BinOp _ -> decomp t 2 - | BinRel _ -> decomp t 2 - | PropOp _ -> decomp t 2 - | PropUnOp _ -> decomp t 1 - | _ -> None - - - let rec trans_expr env evd e = +let match_operator env evd hd args (t, d) = + let decomp t i = + let n = Array.length args in + let t' = EConstr.mkApp (hd, Array.sub args 0 (n - i)) in + if is_convertible env evd t' t then Some (d, t) else None + in + match t with + | OtherTerm t -> Some (d, t) + | Application t -> ( + match d with + | CstOp _ -> decomp t 0 + | UnOp _ -> decomp t 1 + | BinOp _ -> decomp t 2 + | BinRel _ -> decomp t 2 + | PropOp _ -> decomp t 2 + | PropUnOp _ -> decomp t 1 + | _ -> None ) + +let rec trans_expr env evd e = (* Get the injection *) - let {decl= i; deriv= inj} = get_injection env evd e.typ in + let {decl = i; deriv = inj} = get_injection env evd e.typ in let e = e.constr in if EConstr.isConstruct evd e then Constant (inj, e) (* Evaluate later *) else - let (c,a) = get_operator env evd e in + let c, a = get_operator env evd e in try - let (k,t) = find_option (match_operator env evd c a) (HConstr.find_all c !table_cache) in + let k, t = + find_option + (match_operator env evd c a) + (HConstr.find_all c !table_cache) + in let n = Array.length a in - match k with - | CstOp {decl = c'} -> - Injterm (EConstr.mkApp (force mkapp0, [|inj.source; inj.target; e; i; c'|])) - | UnOp {decl = unop ; deriv = u} -> - let a' = trans_expr env evd {constr= a.(n-1); typ= u.EUnOpT.source1} in - if is_constant a' && EConstr.isConstruct evd t then - Constant (inj, e) - else mkapp_id evd i inj (unop, u) t a' - | BinOp {decl = binop ; deriv = b} -> - let a0 = trans_expr env evd {constr= a.(n-2); typ= b.EBinOpT.source1} in - let a1 = trans_expr env evd {constr= a.(n-1); typ= b.EBinOpT.source2} in - if is_constant a0 && is_constant a1 && EConstr.isConstruct evd t - then Constant (inj, e) - else mkapp2_id evd i inj t binop b a0 a1 - | d -> - Var (inj,e) - with Not_found -> Var (inj,e) + match k with + | CstOp {decl = c'} -> + Injterm + (EConstr.mkApp (force mkapp0, [|inj.source; inj.target; e; i; c'|])) + | UnOp {decl = unop; deriv = u} -> + let a' = + trans_expr env evd {constr = a.(n - 1); typ = u.EUnOpT.source1} + in + if is_constant a' && EConstr.isConstruct evd t then Constant (inj, e) + else mkapp_id evd i inj (unop, u) t a' + | BinOp {decl = binop; deriv = b} -> + let a0 = + trans_expr env evd {constr = a.(n - 2); typ = b.EBinOpT.source1} + in + let a1 = + trans_expr env evd {constr = a.(n - 1); typ = b.EBinOpT.source2} + in + if is_constant a0 && is_constant a1 && EConstr.isConstruct evd t then + Constant (inj, e) + else mkapp2_id evd i inj t binop b a0 a1 + | d -> Var (inj, e) + with Not_found -> Var (inj, e) let trans_expr env evd e = - try trans_expr env evd e with Not_found -> + try trans_expr env evd e + with Not_found -> raise (CErrors.user_err ( Pp.str "Missing injection for type " ++ Printer.pr_leconstr_env env evd e.typ )) - type tprop = | TProp of EConstr.t (** Transformed proposition *) | IProp of EConstr.t (** Identical proposition *) @@ -903,72 +799,72 @@ let mk_iprop e = let inj_prop_of_tprop = function TProp p -> p | IProp e -> mk_iprop e let rec trans_prop env evd e = - let (c,a) = get_operator env evd e in + let c, a = get_operator env evd e in try - let (k,t) = find_option (match_operator env evd c a) (HConstr.find_all c !table_cache) in + let k, t = + find_option (match_operator env evd c a) (HConstr.find_all c !table_cache) + in let n = Array.length a in match k with - | PropOp {decl= rop} -> - begin - try - let t1 = trans_prop env evd a.(n-2) in - let t2 = trans_prop env evd a.(n-1) in - match (t1, t2) with - | IProp _, IProp _ -> IProp e - | _, _ -> - let t1 = inj_prop_of_tprop t1 in - let t2 = inj_prop_of_tprop t2 in - TProp (EConstr.mkApp (force mkprop_op, [|t; rop; t1; t2|])) - with Not_found -> IProp e - end - | BinRel {decl = br ; deriv = rop} -> - begin - try - let a1 = trans_expr env evd {constr = a.(n-2) ; typ = rop.EBinRelT.source} in - let a2 = trans_expr env evd {constr = a.(n-1) ; typ = rop.EBinRelT.source} in - if EConstr.eq_constr evd t rop.EBinRelT.brel then - match (constr_of_texpr a1, constr_of_texpr a2) with - | Some e1, Some e2 -> IProp (EConstr.mkApp (t, [|e1; e2|])) - | _, _ -> - let a1 = inj_term_of_texpr evd a1 in - let a2 = inj_term_of_texpr evd a2 in - TProp - (EConstr.mkApp - ( force mkrel - , [| rop.EBinRelT.source - ; rop.EBinRelT.target - ; t - ; rop.EBinRelT.inj - ; br - ; a1 - ; a2 |] )) - else - let a1 = inj_term_of_texpr evd a1 in - let a2 = inj_term_of_texpr evd a2 in - TProp - (EConstr.mkApp - ( force mkrel - , [| rop.EBinRelT.source - ; rop.EBinRelT.target - ; t - ; rop.EBinRelT.inj - ; br - ; a1 - ; a2 |] )) - with Not_found -> IProp e - end - | PropUnOp {decl = rop} -> - begin - try - let t1 = trans_prop env evd a.(n-1) in - match t1 with - | IProp _ -> IProp e - | _ -> - let t1 = inj_prop_of_tprop t1 in - TProp (EConstr.mkApp (force mkuprop_op, [|t; rop; t1|])) - with Not_found -> IProp e - end - | _ -> IProp e + | PropOp {decl = rop} -> ( + try + let t1 = trans_prop env evd a.(n - 2) in + let t2 = trans_prop env evd a.(n - 1) in + match (t1, t2) with + | IProp _, IProp _ -> IProp e + | _, _ -> + let t1 = inj_prop_of_tprop t1 in + let t2 = inj_prop_of_tprop t2 in + TProp (EConstr.mkApp (force mkprop_op, [|t; rop; t1; t2|])) + with Not_found -> IProp e ) + | BinRel {decl = br; deriv = rop} -> ( + try + let a1 = + trans_expr env evd {constr = a.(n - 2); typ = rop.EBinRelT.source} + in + let a2 = + trans_expr env evd {constr = a.(n - 1); typ = rop.EBinRelT.source} + in + if EConstr.eq_constr evd t rop.EBinRelT.brel then + match (constr_of_texpr a1, constr_of_texpr a2) with + | Some e1, Some e2 -> IProp (EConstr.mkApp (t, [|e1; e2|])) + | _, _ -> + let a1 = inj_term_of_texpr evd a1 in + let a2 = inj_term_of_texpr evd a2 in + TProp + (EConstr.mkApp + ( force mkrel + , [| rop.EBinRelT.source + ; rop.EBinRelT.target + ; t + ; rop.EBinRelT.inj + ; br + ; a1 + ; a2 |] )) + else + let a1 = inj_term_of_texpr evd a1 in + let a2 = inj_term_of_texpr evd a2 in + TProp + (EConstr.mkApp + ( force mkrel + , [| rop.EBinRelT.source + ; rop.EBinRelT.target + ; t + ; rop.EBinRelT.inj + ; br + ; a1 + ; a2 |] )) + with Not_found -> IProp e ) + | PropUnOp {decl = rop} -> ( + try + let t1 = trans_prop env evd a.(n - 1) in + match t1 with + | IProp _ -> IProp e + | _ -> + let t1 = inj_prop_of_tprop t1 in + TProp (EConstr.mkApp (force mkuprop_op, [|t; rop; t1|])) + with Not_found -> IProp e ) + | _ -> IProp e with Not_found -> IProp e let unfold n env evd c = @@ -984,14 +880,14 @@ let unfold n env evd c = match n with | None -> c | Some n -> - Tacred.unfoldn [(Locus.AllOccurrences, Names.EvalVarRef n)] env evd c + Tacred.unfoldn [(Locus.AllOccurrences, Names.EvalVarRef n)] env evd c in (* Reduce the term *) - let c = cbv (List.rev_append (force to_unfold) unfold_decl) env evd c in + let c = cbv (List.rev_append (force to_unfold) unfold_decl) env evd c in c let trans_check_prop env evd t = - if is_prop env evd t then + if is_prop env evd t then (*let t = Tacred.unfoldn [Locus.AllOccurrences, Names.EvalConstRef coq_not] env evd t in*) match trans_prop env evd t with IProp e -> None | TProp e -> Some e else None @@ -1001,7 +897,7 @@ let trans_hyps env evd l = (fun acc (h, p) -> match trans_check_prop env evd p with | None -> acc - | Some p' -> (h, p, p') :: acc ) + | Some p' -> (h, p, p') :: acc) [] (List.rev l) (* Only used if a direct rewrite fails *) @@ -1016,7 +912,7 @@ let trans_hyp h t = let h' = fresh_id_in_env Id.Set.empty h env in tclTHENLIST [ letin_tac None (Names.Name n) t None - Locus.{onhyps= None; concl_occs= NoOccurrences} + Locus.{onhyps = None; concl_occs = NoOccurrences} ; assert_by (Name.Name h') (EConstr.mkApp (force q, [|EConstr.mkVar n|])) (tclTHEN @@ -1027,19 +923,19 @@ let trans_hyp h t = (h', Locus.InHyp) ; clear [n] ; (* [clear H] may fail if [h] has dependencies *) - tclTRY (clear [h]) ] ))) + tclTRY (clear [h]) ]))) let is_progress_rewrite evd t rew = match EConstr.kind evd rew with | App (c, [|lhs; rhs|]) -> - if EConstr.eq_constr evd (force iff) c then - (* This is a successful rewriting *) - not (EConstr.eq_constr evd lhs rhs) - else - CErrors.anomaly - Pp.( - str "is_progress_rewrite: not a rewrite" - ++ pr_constr (Global.env ()) evd rew) + if EConstr.eq_constr evd (force iff) c then + (* This is a successful rewriting *) + not (EConstr.eq_constr evd lhs rhs) + else + CErrors.anomaly + Pp.( + str "is_progress_rewrite: not a rewrite" + ++ pr_constr (Global.env ()) evd rew) | _ -> failwith "is_progress_rewrite: not even an application" let trans_hyp h t0 t = @@ -1050,10 +946,10 @@ let trans_hyp h t0 t = let t' = unfold None env evd (EConstr.mkApp (force ieq, [|t|])) in if is_progress_rewrite evd t0 (get_type_of env evd t') then tclFIRST - [ Equality.general_rewrite_in true Locus.AllOccurrences true false - h t' false + [ Equality.general_rewrite_in true Locus.AllOccurrences true false h + t' false ; trans_hyp h t ] - else tclIDTAC )) + else tclIDTAC)) let trans_concl t = Tacticals.New.( @@ -1064,15 +960,15 @@ let trans_concl t = let t' = unfold None env evd (EConstr.mkApp (force ieq, [|t|])) in if is_progress_rewrite evd concl (get_type_of env evd t') then Equality.general_rewrite true Locus.AllOccurrences true false t' - else tclIDTAC )) + else tclIDTAC)) let tclTHENOpt e tac tac' = match e with None -> tac' | Some e' -> Tacticals.New.tclTHEN (tac e') tac' let zify_tac = Proofview.Goal.enter (fun gl -> - Coqlib.check_required_library ["Coq"; "micromega"; "ZifyClasses"] ; - Coqlib.check_required_library ["Coq"; "micromega"; "ZifyInst"] ; + Coqlib.check_required_library ["Coq"; "micromega"; "ZifyClasses"]; + Coqlib.check_required_library ["Coq"; "micromega"; "ZifyInst"]; init_cache (); let evd = Tacmach.New.project gl in let env = Tacmach.New.pf_env gl in @@ -1083,15 +979,16 @@ let zify_tac = (Tacticals.New.tclTHEN (Tacticals.New.tclTHENLIST (List.rev_map (fun (h, p, t) -> trans_hyp h p t) hyps)) - (CstrTable.gen_cstr l)) ) + (CstrTable.gen_cstr l))) let iter_specs tac = Tacticals.New.tclTHENLIST - (List.fold_left (fun acc d -> tac d :: acc) [] (Spec.get ())) + (List.fold_left (fun acc d -> tac d :: acc) [] (Spec.get ())) - -let iter_specs (tac: Ltac_plugin.Tacinterp.Value.t) = - iter_specs (fun c -> Ltac_plugin.Tacinterp.Value.apply tac [Ltac_plugin.Tacinterp.Value.of_constr c]) +let iter_specs (tac : Ltac_plugin.Tacinterp.Value.t) = + iter_specs (fun c -> + Ltac_plugin.Tacinterp.Value.apply tac + [Ltac_plugin.Tacinterp.Value.of_constr c]) let find_hyp evd t l = try Some (fst (List.find (fun (h, t') -> EConstr.eq_constr evd t t') l)) @@ -1104,39 +1001,37 @@ let sat_constr c d = let hyps = Tacmach.New.pf_hyps_types gl in match EConstr.kind evd c with | App (c, args) -> - if Array.length args = 2 then ( - let h1 = - Tacred.cbv_beta env evd - (EConstr.mkApp (d.ESatT.parg1, [|args.(0)|])) + if Array.length args = 2 then + let h1 = + Tacred.cbv_beta env evd + (EConstr.mkApp (d.ESatT.parg1, [|args.(0)|])) + in + let h2 = + Tacred.cbv_beta env evd + (EConstr.mkApp (d.ESatT.parg2, [|args.(1)|])) + in + match (find_hyp evd h1 hyps, find_hyp evd h2 hyps) with + | Some h1, Some h2 -> + let n = + Tactics.fresh_id_in_env Id.Set.empty + (Names.Id.of_string "__sat") + env in - let h2 = - Tacred.cbv_beta env evd - (EConstr.mkApp (d.ESatT.parg2, [|args.(1)|])) + let trm = + EConstr.mkApp + ( d.ESatT.satOK + , [|args.(0); args.(1); EConstr.mkVar h1; EConstr.mkVar h2|] ) in - match (find_hyp evd h1 hyps, find_hyp evd h2 hyps) with - | Some h1, Some h2 -> - let n = - Tactics.fresh_id_in_env Id.Set.empty - (Names.Id.of_string "__sat") - env - in - let trm = - EConstr.mkApp - ( d.ESatT.satOK - , [|args.(0); args.(1); EConstr.mkVar h1; EConstr.mkVar h2|] - ) - in - Tactics.pose_proof (Names.Name n) trm - | _, _ -> Tacticals.New.tclIDTAC ) - else Tacticals.New.tclIDTAC - | _ -> Tacticals.New.tclIDTAC ) - + Tactics.pose_proof (Names.Name n) trm + | _, _ -> Tacticals.New.tclIDTAC + else Tacticals.New.tclIDTAC + | _ -> Tacticals.New.tclIDTAC) let get_all_sat env evd c = - List.fold_left (fun acc e -> - match e with - | (_,Saturate s) -> s::acc - | _ -> acc) [] (HConstr.find_all c !saturate_cache ) + List.fold_left + (fun acc e -> match e with _, Saturate s -> s :: acc | _ -> acc) + [] + (HConstr.find_all c !saturate_cache) let saturate = Proofview.Goal.enter (fun gl -> @@ -1149,21 +1044,19 @@ let saturate = let rec sat t = match EConstr.kind evd t with | App (c, args) -> - sat c ; - Array.iter sat args ; - if Array.length args = 2 then - let ds = get_all_sat env evd c in - if ds = [] then () - else ( - List.iter (fun x -> CstrTable.HConstr.add table t x.deriv) ds ) - else () + sat c; + Array.iter sat args; + if Array.length args = 2 then + let ds = get_all_sat env evd c in + if ds = [] then () + else List.iter (fun x -> CstrTable.HConstr.add table t x.deriv) ds + else () | Prod (a, t1, t2) when a.Context.binder_name = Names.Anonymous -> - sat t1 ; sat t2 + sat t1; sat t2 | _ -> () in (* Collect all the potential saturation lemma *) - sat concl ; - List.iter (fun (_, t) -> sat t) hyps ; + sat concl; + List.iter (fun (_, t) -> sat t) hyps; Tacticals.New.tclTHENLIST - (CstrTable.HConstr.fold (fun c d acc -> sat_constr c d :: acc) table []) - ) + (CstrTable.HConstr.fold (fun c d acc -> sat_constr c d :: acc) table [])) diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli index 54e8f07ddc..9e3cf5d24c 100644 --- a/plugins/micromega/zify.mli +++ b/plugins/micromega/zify.mli @@ -9,16 +9,19 @@ (************************************************************************) open Constrexpr -module type S = sig val register : constr_expr -> unit val print : unit -> unit end +module type S = sig + val register : constr_expr -> unit + val print : unit -> unit +end module InjTable : S -module UnOp : S -module BinOp : S -module CstOp : S -module BinRel : S -module PropOp : S +module UnOp : S +module BinOp : S +module CstOp : S +module BinRel : S +module PropOp : S module PropUnOp : S -module Spec : S +module Spec : S module Saturate : S val zify_tac : unit Proofview.tactic diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v index 58d01c125c..896ee303cc 100644 --- a/plugins/nsatz/Nsatz.v +++ b/plugins/nsatz/Nsatz.v @@ -31,6 +31,7 @@ Require Export Ncring_tac. Require Export Integral_domain. Require Import DiscrR. Require Import ZArith. +Require Import Lia. Declare ML Module "nsatz_plugin". @@ -413,7 +414,7 @@ Ltac nsatz_generic radicalmax info lparam lvar := try exact integral_domain_minus_one_zero || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation, one, one_notation, multiplication, mul_notation, zero, zero_notation; - discrR || omega]) + discrR || lia ]) || ((*simpl*) idtac) || idtac "could not prove discrimination result" ] ] @@ -502,7 +503,7 @@ reflexivity. exact Qplus_opp_r. Defined. Lemma Q_one_zero: not (Qeq 1%Q 0%Q). -unfold Qeq. simpl. auto with *. Qed. +Proof. unfold Qeq. simpl. lia. Qed. Instance Qcri: (Cring (Rr:=Qri)). red. exact Qmult_comm. Defined. @@ -513,8 +514,7 @@ exact Qmult_integral. exact Q_one_zero. Defined. (* Integers *) Lemma Z_one_zero: 1%Z <> 0%Z. -omega. -Qed. +Proof. lia. Qed. Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. diff --git a/plugins/setoid_ring/Rings_Z.v b/plugins/setoid_ring/Rings_Z.v index a0901202f7..8a51bcea02 100644 --- a/plugins/setoid_ring/Rings_Z.v +++ b/plugins/setoid_ring/Rings_Z.v @@ -17,8 +17,7 @@ Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. Lemma Z_one_zero: 1%Z <> 0%Z. -omega. -Qed. +Proof. discriminate. Qed. Instance Zdi : (Integral_domain (Rcr:=Zcri)). constructor. diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index f1dc63dd9e..f7e4a95a22 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -358,7 +358,7 @@ let find_ring_structure env sigma l = spc() ++ str"\"" ++ pr_econstr_env env sigma ty ++ str"\"")) | [] -> assert false -let add_entry (sp,_kn) e = +let add_entry e = from_carrier := Cmap.add e.ring_carrier e !from_carrier let subst_th (subst,th) = @@ -403,7 +403,7 @@ let subst_th (subst,th) = let theory_to_obj : ring_info -> obj = - let cache_th (name,th) = add_entry name th in + let cache_th (_, th) = add_entry th in declare_object @@ global_object_nodischarge "tactic-new-ring-theory" ~cache:cache_th ~subst:(Some subst_th) @@ -599,7 +599,7 @@ let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div let req = EConstr.to_constr sigma req in let sth = EConstr.to_constr sigma sth in let _ = - Lib.add_leaf name + Lib.add_anonymous_leaf (theory_to_obj { ring_name = name; ring_carrier = r; @@ -814,7 +814,7 @@ let find_field_structure env sigma l = spc()++str"\""++pr_econstr_env env sigma ty++str"\"")) | [] -> assert false -let add_field_entry (sp,_kn) e = +let add_field_entry e = field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier let subst_th (subst,th) = @@ -855,7 +855,7 @@ let subst_th (subst,th) = field_post_tac = posttac' } let ftheory_to_obj : field_info -> obj = - let cache_th (name,th) = add_field_entry name th in + let cache_th (_, th) = add_field_entry th in declare_object @@ global_object_nodischarge "tactic-new-field-theory" ~cache:cache_th ~subst:(Some subst_th) @@ -925,7 +925,7 @@ let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign od let r = EConstr.to_constr sigma r in let req = EConstr.to_constr sigma req in let _ = - Lib.add_leaf name + Lib.add_anonymous_leaf (ftheory_to_obj { field_name = name; field_carrier = r; diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index f6b192c226..475859fcc2 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -1184,7 +1184,6 @@ Notation xpreim := (fun f (p : pred _) x => p (f x)). (** The packed class interface for pred-like types. **) -#[universes(template)] Structure predType T := PredType {pred_sort :> Type; topred : pred_sort -> pred T}. diff --git a/pretyping/classops.ml b/pretyping/classops.ml index c12a236d8e..16021b66f8 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -297,15 +297,15 @@ let lookup_pattern_path_between env (s,t) = (* rajouter une coercion dans le graphe *) -let path_printer : ((Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) ref = +let path_printer : ((cl_index * cl_index) * inheritance_path -> Pp.t) ref = ref (fun _ -> str "<a class path>") let install_path_printer f = path_printer := f let print_path x = !path_printer x -let path_comparator : (Environ.env -> Evd.evar_map -> inheritance_path -> inheritance_path -> bool) ref = - ref (fun _ _ _ _ -> false) +let path_comparator : (Environ.env -> Evd.evar_map -> cl_index -> inheritance_path -> inheritance_path -> bool) ref = + ref (fun _ _ _ _ _ -> false) let install_path_comparator f = path_comparator := f @@ -315,7 +315,10 @@ let warn_ambiguous_path = CWarnings.create ~name:"ambiguous-paths" ~category:"typechecker" (fun l -> prlist_with_sep fnl (fun (c,p,q) -> str"New coercion path " ++ print_path (c,p) ++ - str" is ambiguous with existing " ++ print_path (c, q) ++ str".") l) + if List.is_empty q then + str" is not definitionally an identity function." + else + str" is ambiguous with existing " ++ print_path (c, q) ++ str".") l) (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) @@ -334,10 +337,23 @@ let add_coercion_in_graph env sigma (ic,source,target) = let ambig_paths = (ref [] : ((cl_index * cl_index) * inheritance_path * inheritance_path) list ref) in let try_add_new_path (i,j as ij) p = + (* If p is a cycle, we check whether p is definitionally an identity + function or not. If it is not, we report p as an ambiguous inheritance + path. *) + if Bijint.Index.equal i j && not (compare_path env sigma i p []) then + ambig_paths := (ij,p,[])::!ambig_paths; if not (Bijint.Index.equal i j) || different_class_params env i then match lookup_path_between_class ij with | q -> - if not (compare_path env sigma p q) then + (* p has the same source and target classes as an existing path q. We + report them as ambiguous inheritance paths if + 1. p and q have no common element, and + 2. p and q are not convertible. + If 1 does not hold, say p = p1 @ [c] @ p2 and q = q1 @ [c] @ q2, + convertibility of p1 and q1, also, p2 and q2 should be checked; thus, + checking the ambiguity of p and q is redundant with them. *) + if not (List.exists (fun c -> List.exists (coe_info_typ_equal c) q) p || + compare_path env sigma i p q) then ambig_paths := (ij,p,q)::!ambig_paths; false | exception Not_found -> (add_new_path ij p; true) @@ -355,7 +371,7 @@ let add_coercion_in_graph env sigma (ic,source,target) = try_add_new_path1 (s,target) (p@[ic]); ClPairMap.iter (fun (u,v) q -> - if not (Bijint.Index.equal u v) && Bijint.Index.equal u target && not (List.equal coe_info_typ_equal p q) then + if not (Bijint.Index.equal u v) && Bijint.Index.equal u target then try_add_new_path1 (s,v) (p@[ic]@q)) old_inheritance_graph end; diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 9c5274286e..9f633843eb 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -111,7 +111,7 @@ val lookup_pattern_path_between : val install_path_printer : ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit val install_path_comparator : - (env -> evar_map -> inheritance_path -> inheritance_path -> bool) -> unit + (env -> evar_map -> cl_index -> inheritance_path -> inheritance_path -> bool) -> unit (**/**) (** {6 This is for printing purpose } *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index e07fec6b43..f0e73bdb29 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -31,7 +31,6 @@ open Classops open Evarutil open Evarconv open Evd -open Termops open Globnames let get_use_typeclasses_for_conversion = @@ -151,7 +150,7 @@ let mu env evdref t = | None -> (None, v) in aux t -and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) +let coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) : (EConstr.constr -> EConstr.constr) option = let open Context.Rel.Declaration in @@ -361,8 +360,8 @@ let app_coercion env evdref coercion v = let coerce_itf ?loc env evd v t c1 = let evdref = ref evd in let coercion = coerce ?loc env evdref t c1 in - let t = Option.map (app_coercion env evdref coercion) v in - !evdref, t + let t = app_coercion env evdref coercion v in + !evdref, t let saturate_evd env evd = Typeclasses.resolve_typeclasses @@ -370,27 +369,25 @@ let saturate_evd env evd = (* Apply coercion path from p to hj; raise NoCoercion if not applicable *) let apply_coercion env sigma p hj typ_cl = - try - let j,t,evd = - List.fold_left - (fun (ja,typ_cl,sigma) i -> - let isid = i.coe_is_identity in - let isproj = i.coe_is_projection in - let sigma, c = new_global sigma i.coe_value in - let typ = Retyping.get_type_of env sigma c in - let fv = make_judge c typ in - let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in - let sigma, jres = - apply_coercion_args env sigma true isproj argl fv - in - (if isid then - { uj_val = ja.uj_val; uj_type = jres.uj_type } - else - jres), - jres.uj_type,sigma) + let j,t,evd = + List.fold_left + (fun (ja,typ_cl,sigma) i -> + let isid = i.coe_is_identity in + let isproj = i.coe_is_projection in + let sigma, c = new_global sigma i.coe_value in + let typ = Retyping.get_type_of env sigma c in + let fv = make_judge c typ in + let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in + let sigma, jres = + apply_coercion_args env sigma true isproj argl fv + in + (if isid then + { uj_val = ja.uj_val; uj_type = jres.uj_type } + else + jres), + jres.uj_type,sigma) (hj,typ_cl,sigma) p - in evd, j - with NoCoercion as e -> raise e + in evd, j (* Try to coerce to a funclass; raise NoCoercion if not possible *) let inh_app_fun_core ~program_mode env evd j = @@ -474,17 +471,15 @@ let inh_coerce_to_fail flags env evd rigidonly v t c1 = let evd, v', t' = try let t2,t1,p = lookup_path_between env evd (t,c1) in - match v with - | Some v -> - let evd,j = - apply_coercion env evd p - {uj_val = v; uj_type = t} t2 in - evd, Some j.uj_val, j.uj_type - | None -> evd, None, t + let evd,j = + apply_coercion env evd p + {uj_val = v; uj_type = t} t2 + in + evd, j.uj_val, j.uj_type with Not_found -> raise NoCoercion in - try (unify_leq_delay ~flags env evd t' c1, v') - with UnableToUnify _ -> raise NoCoercion + try (unify_leq_delay ~flags env evd t' c1, v') + with UnableToUnify _ -> raise NoCoercion let default_flags_of env = default_flags_of TransparentState.full @@ -512,25 +507,22 @@ let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigid let env1 = push_rel (LocalAssum (name,u1)) env in let (evd', v1) = inh_conv_coerce_to_fail ?loc env1 evd rigidonly - (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in - let v1 = Option.get v1 in - let v2 = Option.map (fun v -> beta_applist evd' (lift 1 v,[v1])) v in - let t2 = match v2 with - | None -> subst_term evd' v1 t2 - | Some v2 -> Retyping.get_type_of env1 evd' v2 in + (mkRel 1) (lift 1 u1) (lift 1 t1) in + let v2 = beta_applist evd' (lift 1 v,[v1]) in + let t2 = Retyping.get_type_of env1 evd' v2 in let (evd'',v2') = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in - (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') + (evd'', mkLambda (name, u1, v2')) | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly flags env evd cj t = let (evd', val') = try - inh_conv_coerce_to_fail ?loc env evd ~flags rigidonly (Some cj.uj_val) cj.uj_type t + inh_conv_coerce_to_fail ?loc env evd ~flags rigidonly cj.uj_val cj.uj_type t with NoCoercionNoUnifier (best_failed_evd,e) -> try if program_mode then - coerce_itf ?loc env evd (Some cj.uj_val) cj.uj_type t + coerce_itf ?loc env evd cj.uj_val cj.uj_type t else raise NoSubtacCoercion with | NoSubtacCoercion when not resolve_tc || not (get_use_typeclasses_for_conversion ()) -> @@ -541,21 +533,13 @@ let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly flags env evd if evd' == evd then error_actual_type ?loc env best_failed_evd cj t e else - inh_conv_coerce_to_fail ?loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t + inh_conv_coerce_to_fail ?loc env evd' rigidonly cj.uj_val cj.uj_type t with NoCoercionNoUnifier (_evd,_error) -> error_actual_type ?loc env best_failed_evd cj t e in - let val' = match val' with Some v -> v | None -> assert(false) in - (evd',{ uj_val = val'; uj_type = t }) + (evd',{ uj_val = val'; uj_type = t }) let inh_conv_coerce_to ?loc ~program_mode resolve_tc env evd ?(flags=default_flags_of env) = inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc false flags env evd let inh_conv_coerce_rigid_to ?loc ~program_mode resolve_tc env evd ?(flags=default_flags_of env) = inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc true flags env evd - -let inh_conv_coerces_to ?loc env evd ?(flags=default_flags_of env) t t' = - try - fst (inh_conv_coerce_to_fail ?loc env evd ~flags true None t t') - with NoCoercion -> - evd (* Maybe not enough information to unify *) - diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index 3b24bcec8b..fe93a26f4f 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -54,13 +54,6 @@ val inh_conv_coerce_rigid_to : ?loc:Loc.t -> program_mode:bool ->bool -> env -> evar_map -> ?flags:Evarconv.unify_flags -> unsafe_judgment -> types -> evar_map * unsafe_judgment -(** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t] - is coercible to an object of type [t'] adding evar constraints if needed; - it fails if no coercion exists *) -val inh_conv_coerces_to : ?loc:Loc.t -> - env -> evar_map -> ?flags:Evarconv.unify_flags -> - types -> types -> evar_map - (** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases pattern [pat] typed in [ind1] into a pattern typed in [ind2]; raises [Not_found] if no coercion found *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 1264b0b33c..02c2fc4a13 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -34,10 +34,10 @@ let cases_predicate_names tml = | (tm,(na,None)) -> [na] | (tm,(na,Some {v=(_,nal)})) -> na::nal) tml) -let mkGApp ?loc p t = DAst.make ?loc @@ +let mkGApp ?loc p l = DAst.make ?loc @@ match DAst.get p with - | GApp (f,l) -> GApp (f,l@[t]) - | _ -> GApp (p,[t]) + | GApp (f,l') -> GApp (f,l'@l) + | _ -> GApp (p,l) let map_glob_decl_left_to_right f (na,k,obd,ty) = let comp1 = Option.map f obd in diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 37aa31d094..20ac35888e 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -42,8 +42,8 @@ val cases_pattern_loc : 'a cases_pattern_g -> Loc.t option val cases_predicate_names : 'a tomatch_tuples_g -> Name.t list -(** Apply one argument to a glob_constr *) -val mkGApp : ?loc:Loc.t -> 'a glob_constr_g -> 'a glob_constr_g -> 'a glob_constr_g +(** Apply a list of arguments to a glob_constr *) +val mkGApp : ?loc:Loc.t -> 'a glob_constr_g -> 'a glob_constr_g list -> 'a glob_constr_g val map_glob_constr : (glob_constr -> glob_constr) -> glob_constr -> glob_constr diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 304e06818e..342891d65f 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -37,6 +37,7 @@ val head_pattern_bound : constr_pattern -> GlobRef.t returns its label; raises an anomaly otherwise *) val head_of_constr_reference : Evd.evar_map -> constr -> GlobRef.t +[@@ocaml.deprecated "use [EConstr.destRef]"] (** [pattern_of_constr c] translates a term [c] with metavariables into a pattern; currently, no destructor (Cases, Fix, Cofix) and no diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 4925f3e5fa..0364e1b61f 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -288,16 +288,18 @@ let check_extra_evars_are_solved env current_sigma frozen = match frozen with (* [check_evars] fails if some unresolved evar remains *) -let check_evars env initial_sigma sigma c = +let check_evars env ?initial sigma c = let rec proc_rec c = match EConstr.kind sigma c with | Evar (evk, _) -> - if not (Evd.mem initial_sigma evk) then - let (loc,k) = evar_source evk sigma in - begin match k with - | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () - | _ -> Pretype_errors.error_unsolvable_implicit ?loc env sigma evk None - end + (match initial with + | Some initial when Evd.mem initial evk -> () + | _ -> + let (loc,k) = evar_source evk sigma in + begin match k with + | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () + | _ -> Pretype_errors.error_unsolvable_implicit ?loc env sigma evk None + end) | _ -> EConstr.iter sigma proc_rec c in proc_rec c @@ -478,26 +480,142 @@ let mark_obligation_evar sigma k evc = Evd.set_obligation_evar sigma (fst (destEvar sigma evc)) | _ -> sigma -(* [pretype tycon env sigma lvar lmeta cstr] attempts to type [cstr] *) -(* in environment [env], with existential variables [sigma] and *) -(* the type constraint tycon *) +type 'a pretype_fun = ?loc:Loc.t -> program_mode:bool -> poly:bool -> bool -> type_constraint -> GlobEnv.t -> evar_map -> evar_map * 'a + +type pretyper = { + pretype_ref : pretyper -> GlobRef.t * glob_level list option -> unsafe_judgment pretype_fun; + pretype_var : pretyper -> Id.t -> unsafe_judgment pretype_fun; + pretype_evar : pretyper -> existential_name * (Id.t * glob_constr) list -> unsafe_judgment pretype_fun; + pretype_patvar : pretyper -> Evar_kinds.matching_var_kind -> unsafe_judgment pretype_fun; + pretype_app : pretyper -> glob_constr * glob_constr list -> unsafe_judgment pretype_fun; + pretype_lambda : pretyper -> Name.t * binding_kind * glob_constr * glob_constr -> unsafe_judgment pretype_fun; + pretype_prod : pretyper -> Name.t * binding_kind * glob_constr * glob_constr -> unsafe_judgment pretype_fun; + pretype_letin : pretyper -> Name.t * glob_constr * glob_constr option * glob_constr -> unsafe_judgment pretype_fun; + pretype_cases : pretyper -> Constr.case_style * glob_constr option * tomatch_tuples * cases_clauses -> unsafe_judgment pretype_fun; + pretype_lettuple : pretyper -> Name.t list * (Name.t * glob_constr option) * glob_constr * glob_constr -> unsafe_judgment pretype_fun; + pretype_if : pretyper -> glob_constr * (Name.t * glob_constr option) * glob_constr * glob_constr -> unsafe_judgment pretype_fun; + pretype_rec : pretyper -> glob_fix_kind * Id.t array * glob_decl list array * glob_constr array * glob_constr array -> unsafe_judgment pretype_fun; + pretype_sort : pretyper -> glob_sort -> unsafe_judgment pretype_fun; + pretype_hole : pretyper -> Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option -> unsafe_judgment pretype_fun; + pretype_cast : pretyper -> glob_constr * glob_constr cast_type -> unsafe_judgment pretype_fun; + pretype_int : pretyper -> Uint63.t -> unsafe_judgment pretype_fun; + pretype_float : pretyper -> Float64.t -> unsafe_judgment pretype_fun; + pretype_type : pretyper -> glob_constr -> unsafe_type_judgment pretype_fun; +} -let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = - let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in - let pretype_type = pretype_type ~program_mode ~poly resolve_tc in - let pretype = pretype ~program_mode ~poly resolve_tc in - let open Context.Rel.Declaration in +(** Tie the loop *) +let eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma t = let loc = t.CAst.loc in match DAst.get t with | GRef (ref,u) -> + self.pretype_ref self (ref, u) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GVar id -> + self.pretype_var self id ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GEvar (evk, args) -> + self.pretype_evar self (evk, args) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GPatVar knd -> + self.pretype_patvar self knd ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GApp (c, args) -> + self.pretype_app self (c, args) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GLambda (na, bk, t, c) -> + self.pretype_lambda self (na, bk, t, c) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GProd (na, bk, t, c) -> + self.pretype_prod self (na, bk, t, c) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GLetIn (na, b, t, c) -> + self.pretype_letin self (na, b, t, c) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GCases (st, c, tm, cl) -> + self.pretype_cases self (st, c, tm, cl) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GLetTuple (na, b, t, c) -> + self.pretype_lettuple self (na, b, t, c) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GIf (c, r, t1, t2) -> + self.pretype_if self (c, r, t1, t2) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GRec (knd, nas, decl, c, t) -> + self.pretype_rec self (knd, nas, decl, c, t) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GSort s -> + self.pretype_sort self s ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GHole (knd, nam, arg) -> + self.pretype_hole self (knd, nam, arg) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GCast (c, t) -> + self.pretype_cast self (c, t) ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GInt n -> + self.pretype_int self n ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GFloat f -> + self.pretype_float self f ?loc ~program_mode ~poly resolve_tc tycon env sigma + +let eval_type_pretyper self ~program_mode ~poly resolve_tc tycon env sigma t = + self.pretype_type self t ~program_mode ~poly resolve_tc tycon env sigma + +let pretype_instance self ~program_mode ~poly resolve_tc env sigma loc hyps evk update = + let f decl (subst,update,sigma) = + let id = NamedDecl.get_id decl in + let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in + let t = replace_vars subst (NamedDecl.get_type decl) in + let check_body sigma id c = + match b, c with + | Some b, Some c -> + if not (is_conv !!env sigma b c) then + user_err ?loc (str "Cannot interpret " ++ + pr_existential_key sigma evk ++ + strbrk " in current context: binding for " ++ Id.print id ++ + strbrk " is not convertible to its expected definition (cannot unify " ++ + quote (Termops.Internal.print_constr_env !!env sigma b) ++ + strbrk " and " ++ + quote (Termops.Internal.print_constr_env !!env sigma c) ++ + str ").") + | Some b, None -> + user_err ?loc (str "Cannot interpret " ++ + pr_existential_key sigma evk ++ + strbrk " in current context: " ++ Id.print id ++ + strbrk " should be bound to a local definition.") + | None, _ -> () in + let check_type sigma id t' = + if not (is_conv !!env sigma t t') then + user_err ?loc (str "Cannot interpret " ++ + pr_existential_key sigma evk ++ + strbrk " in current context: binding for " ++ Id.print id ++ + strbrk " is not well-typed.") in + let sigma, c, update = + try + let c = List.assoc id update in + let sigma, c = eval_pretyper self ~program_mode ~poly resolve_tc (mk_tycon t) env sigma c in + check_body sigma id (Some c.uj_val); + sigma, c.uj_val, List.remove_assoc id update + with Not_found -> + try + let (n,b',t') = lookup_rel_id id (rel_context !!env) in + check_type sigma id (lift n t'); + check_body sigma id (Option.map (lift n) b'); + sigma, mkRel n, update + with Not_found -> + try + let decl = lookup_named id !!env in + check_type sigma id (NamedDecl.get_type decl); + check_body sigma id (NamedDecl.get_value decl); + sigma, mkVar id, update + with Not_found -> + user_err ?loc (str "Cannot interpret " ++ + pr_existential_key sigma evk ++ + str " in current context: no binding for " ++ Id.print id ++ str ".") in + ((id,c)::subst, update, sigma) in + let subst,inst,sigma = List.fold_right f hyps ([],update,sigma) in + check_instance loc subst inst; + sigma, Array.map_of_list snd subst + +module Default = +struct + + let pretype_ref self (ref, u) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> let sigma, t_ref = pretype_ref ?loc sigma env ref u in - inh_conv_coerce_to_tycon ?loc env sigma t_ref tycon + inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma t_ref tycon - | GVar id -> + let pretype_var self id = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let pretype tycon env sigma t = eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma t in let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) loc env sigma id in - inh_conv_coerce_to_tycon ?loc env sigma t_id tycon + inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma t_id tycon - | GEvar (id, inst) -> + let pretype_evar self (id, inst) ?loc ~program_mode ~poly resolve_tc tycon env sigma = (* Ne faudrait-il pas s'assurer que hyps est bien un sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) let id = interp_ltac_id env id in @@ -505,12 +623,12 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : try Evd.evar_key id sigma with Not_found -> error_evar_not_found ?loc !!env sigma id in let hyps = evar_filtered_context (Evd.find sigma evk) in - let sigma, args = pretype_instance ~program_mode ~poly resolve_tc env sigma loc hyps evk inst in + let sigma, args = pretype_instance self ~program_mode ~poly resolve_tc env sigma loc hyps evk inst in let c = mkEvar (evk, args) in let j = Retyping.get_judgment_of !!env sigma c in - inh_conv_coerce_to_tycon ?loc env sigma j tycon + inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j tycon - | GPatVar kind -> + let pretype_patvar self kind ?loc ~program_mode ~poly resolve_tc tycon env sigma = let sigma, ty = match tycon with | Some ty -> sigma, ty @@ -519,7 +637,10 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let sigma, uj_val = new_evar env sigma ~src:(loc,k) ty in sigma, { uj_val; uj_type = ty } - | GHole (k, naming, None) -> + let pretype_hole self (k, naming, ext) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + match ext with + | None -> let open Namegen in let naming = match naming with | IntroIdentifier id -> IntroIdentifier (interp_ltac_id env id) @@ -533,7 +654,7 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let sigma = if program_mode then mark_obligation_evar sigma k uj_val else sigma in sigma, { uj_val; uj_type = ty } - | GHole (k, _naming, Some arg) -> + | Some arg -> let sigma, ty = match tycon with | Some ty -> sigma, ty @@ -541,7 +662,11 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let c, sigma = GlobEnv.interp_glob_genarg env poly sigma ty arg in sigma, { uj_val = c; uj_type = ty } - | GRec (fixkind,names,bl,lar,vdef) -> + let pretype_rec self (fixkind, names, bl, lar, vdef) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let open Context.Rel.Declaration in + let pretype tycon env sigma c = eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in + let pretype_type tycon env sigma c = eval_type_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let rec type_bl env sigma ctxt = function | [] -> sigma, ctxt @@ -632,13 +757,16 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : iraise (e, info)); make_judge (mkCoFix cofix) ftys.(i) in - inh_conv_coerce_to_tycon ?loc env sigma fixj tycon + inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma fixj tycon - | GSort s -> + let pretype_sort self s = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> let sigma, j = pretype_sort ?loc sigma s in - inh_conv_coerce_to_tycon ?loc env sigma j tycon + inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j tycon - | GApp (f,args) -> + let pretype_app self (f, args) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let pretype tycon env sigma c = eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in let sigma, fj = pretype empty_tycon env sigma f in let floc = loc_of_glob_constr f in let length = List.length args in @@ -738,7 +866,7 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : else sigma, resj | _ -> sigma, resj in - let sigma, t = inh_conv_coerce_to_tycon ?loc env sigma resj tycon in + let sigma, t = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon in let refine_arg sigma (newarg,origarg) = (* Refine an argument (originally `origarg`) represented by an evar (`newarg`) to use typing information from the context *) @@ -755,7 +883,9 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let sigma = List.fold_left refine_arg sigma bidiargs in (sigma, t) - | GLambda(name,bk,c1,c2) -> + let pretype_lambda self (name, bk, c1, c2) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let open Context.Rel.Declaration in let sigma, tycon' = match tycon with | None -> sigma, tycon @@ -765,17 +895,20 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : in let sigma, (name',dom,rng) = split_tycon ?loc !!env sigma tycon' in let dom_valcon = valcon_of_tycon dom in - let sigma, j = pretype_type dom_valcon env sigma c1 in + let sigma, j = eval_type_pretyper self ~program_mode ~poly resolve_tc dom_valcon env sigma c1 in let name = {binder_name=name; binder_relevance=Sorts.relevance_of_sort j.utj_type} in let var = LocalAssum (name, j.utj_val) in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let var',env' = push_rel ~hypnaming sigma var env in - let sigma, j' = pretype rng env' sigma c2 in + let sigma, j' = eval_pretyper self ~program_mode ~poly resolve_tc rng env' sigma c2 in let name = get_name var' in let resj = judge_of_abstraction !!env (orelse_name name name'.binder_name) j j' in - inh_conv_coerce_to_tycon ?loc env sigma resj tycon + inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon - | GProd(name,bk,c1,c2) -> + let pretype_prod self (name, bk, c1, c2) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let open Context.Rel.Declaration in + let pretype_type tycon env sigma c = eval_type_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in let sigma, j = pretype_type empty_valcon env sigma c1 in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let sigma, name, j' = match name with @@ -796,9 +929,13 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let (e, info) = CErrors.push e in let info = Option.cata (Loc.add_loc info) info loc in iraise (e, info) in - inh_conv_coerce_to_tycon ?loc env sigma resj tycon + inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon - | GLetIn(name,c1,t,c2) -> + let pretype_letin self (name, c1, t, c2) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let open Context.Rel.Declaration in + let pretype tycon env sigma c = eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in + let pretype_type tycon env sigma c = eval_type_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in let sigma, tycon1 = match t with | Some t -> @@ -819,7 +956,11 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : sigma, { uj_val = mkLetIn (make_annot name r, j.uj_val, t, j'.uj_val) ; uj_type = subst1 j.uj_val j'.uj_type } - | GLetTuple (nal,(na,po),c,d) -> + let pretype_lettuple self (nal, (na, po), c, d) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let open Context.Rel.Declaration in + let pretype tycon env sigma c = eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in + let pretype_type tycon env sigma c = eval_type_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in let sigma, cj = pretype empty_tycon env sigma c in let (IndType (indf,realargs)) = try find_rectype !!env sigma cj.uj_type @@ -912,7 +1053,15 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : obj ind rci p cj.uj_val fj.uj_val in sigma, { uj_val = v; uj_type = ccl }) - | GIf (c,(na,po),b1,b2) -> + let pretype_cases self (sty, po, tml, eqns) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let pretype tycon env sigma c = eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in + Cases.compile_cases ?loc ~program_mode sty (pretype, sigma) tycon env (po,tml,eqns) + + let pretype_if self (c, (na, po), b1, b2) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let open Context.Rel.Declaration in + let pretype tycon env sigma c = eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in let sigma, cj = pretype empty_tycon env sigma c in let (IndType (indf,realargs)) = try find_rectype !!env sigma cj.uj_type @@ -938,7 +1087,7 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let psign,env_p = push_rel_context ~hypnaming sigma psign predenv in let sigma, pred, p = match po with | Some p -> - let sigma, pj = pretype_type empty_valcon env_p sigma p in + let sigma, pj = eval_type_pretyper self ~program_mode ~poly resolve_tc empty_valcon env_p sigma p in let ccl = nf_evar sigma pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist sigma (pred,[cj.uj_val])) in @@ -973,12 +1122,11 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in let cj = { uj_val = v; uj_type = p } in - inh_conv_coerce_to_tycon ?loc env sigma cj tycon + inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon - | GCases (sty,po,tml,eqns) -> - Cases.compile_cases ?loc ~program_mode sty (pretype, sigma) tycon env (po,tml,eqns) - - | GCast (c,k) -> + let pretype_cast self (c, k) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let pretype tycon env sigma c = eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in let sigma, cj = match k with | CastCoerce -> @@ -986,7 +1134,7 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : Coercion.inh_coerce_to_base ?loc ~program_mode !!env sigma cj | CastConv t | CastVM t | CastNative t -> let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in - let sigma, tj = pretype_type empty_valcon env sigma t in + let sigma, tj = eval_type_pretyper self ~program_mode ~poly resolve_tc empty_valcon env sigma t in let sigma, tval = Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma tj.utj_val in let tval = nf_evar sigma tval in @@ -1017,81 +1165,28 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : in let v = mkCast (cj.uj_val, k, tval) in sigma, { uj_val = v; uj_type = tval } - in inh_conv_coerce_to_tycon ?loc env sigma cj tycon + in inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon - | GInt i -> + let pretype_int self i = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> let resj = try Typing.judge_of_int !!env i with Invalid_argument _ -> user_err ?loc ~hdr:"pretype" (str "Type of int63 should be registered first.") in - inh_conv_coerce_to_tycon ?loc env sigma resj tycon - | GFloat f -> + inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon + + let pretype_float self f = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> let resj = try Typing.judge_of_float !!env f with Invalid_argument _ -> user_err ?loc ~hdr:"pretype" (str "Type of float should be registered first.") in - inh_conv_coerce_to_tycon ?loc env sigma resj tycon - -and pretype_instance ~program_mode ~poly resolve_tc env sigma loc hyps evk update = - let f decl (subst,update,sigma) = - let id = NamedDecl.get_id decl in - let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in - let t = replace_vars subst (NamedDecl.get_type decl) in - let check_body sigma id c = - match b, c with - | Some b, Some c -> - if not (is_conv !!env sigma b c) then - user_err ?loc (str "Cannot interpret " ++ - pr_existential_key sigma evk ++ - strbrk " in current context: binding for " ++ Id.print id ++ - strbrk " is not convertible to its expected definition (cannot unify " ++ - quote (Termops.Internal.print_constr_env !!env sigma b) ++ - strbrk " and " ++ - quote (Termops.Internal.print_constr_env !!env sigma c) ++ - str ").") - | Some b, None -> - user_err ?loc (str "Cannot interpret " ++ - pr_existential_key sigma evk ++ - strbrk " in current context: " ++ Id.print id ++ - strbrk " should be bound to a local definition.") - | None, _ -> () in - let check_type sigma id t' = - if not (is_conv !!env sigma t t') then - user_err ?loc (str "Cannot interpret " ++ - pr_existential_key sigma evk ++ - strbrk " in current context: binding for " ++ Id.print id ++ - strbrk " is not well-typed.") in - let sigma, c, update = - try - let c = List.assoc id update in - let sigma, c = pretype ~program_mode ~poly resolve_tc (mk_tycon t) env sigma c in - check_body sigma id (Some c.uj_val); - sigma, c.uj_val, List.remove_assoc id update - with Not_found -> - try - let (n,b',t') = lookup_rel_id id (rel_context !!env) in - check_type sigma id (lift n t'); - check_body sigma id (Option.map (lift n) b'); - sigma, mkRel n, update - with Not_found -> - try - let decl = lookup_named id !!env in - check_type sigma id (NamedDecl.get_type decl); - check_body sigma id (NamedDecl.get_value decl); - sigma, mkVar id, update - with Not_found -> - user_err ?loc (str "Cannot interpret " ++ - pr_existential_key sigma evk ++ - str " in current context: no binding for " ++ Id.print id ++ str ".") in - ((id,c)::subst, update, sigma) in - let subst,inst,sigma = List.fold_right f hyps ([],update,sigma) in - check_instance loc subst inst; - sigma, Array.map_of_list snd subst + inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon (* [pretype_type valcon env sigma c] coerces [c] into a type *) -and pretype_type ~program_mode ~poly resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with +let pretype_type self c ?loc ~program_mode ~poly resolve_tc valcon (env : GlobEnv.t) sigma = match DAst.get c with | GHole (knd, naming, None) -> let loc = loc_of_glob_constr c in (match valcon with @@ -1118,7 +1213,7 @@ and pretype_type ~program_mode ~poly resolve_tc valcon (env : GlobEnv.t) sigma c let sigma = if program_mode then mark_obligation_evar sigma knd utj_val else sigma in sigma, { utj_val; utj_type = s}) | _ -> - let sigma, j = pretype ~program_mode ~poly resolve_tc empty_tycon env sigma c in + let sigma, j = eval_pretyper self ~program_mode ~poly resolve_tc empty_tycon env sigma c in let loc = loc_of_glob_constr c in let sigma, tj = Coercion.inh_coerce_to_sort ?loc !!env sigma j in match valcon with @@ -1131,6 +1226,41 @@ and pretype_type ~program_mode ~poly resolve_tc valcon (env : GlobEnv.t) sigma c ?loc:(loc_of_glob_constr c) !!env sigma tj.utj_val v end +end + +(* [pretype tycon env sigma lvar lmeta cstr] attempts to type [cstr] *) +(* in environment [env], with existential variables [sigma] and *) +(* the type constraint tycon *) + +let default_pretyper = + let open Default in + { + pretype_ref = pretype_ref; + pretype_var = pretype_var; + pretype_evar = pretype_evar; + pretype_patvar = pretype_patvar; + pretype_app = pretype_app; + pretype_lambda = pretype_lambda; + pretype_prod = pretype_prod; + pretype_letin = pretype_letin; + pretype_cases = pretype_cases; + pretype_lettuple = pretype_lettuple; + pretype_if = pretype_if; + pretype_rec = pretype_rec; + pretype_sort = pretype_sort; + pretype_hole = pretype_hole; + pretype_cast = pretype_cast; + pretype_int = pretype_int; + pretype_float = pretype_float; + pretype_type = pretype_type; + } + +let pretype ~program_mode ~poly resolve_tc tycon env sigma c = + eval_pretyper default_pretyper ~program_mode ~poly resolve_tc tycon env sigma c + +let pretype_type ~program_mode ~poly resolve_tc tycon env sigma c = + eval_type_pretyper default_pretyper ~program_mode ~poly resolve_tc tycon env sigma c + let ise_pretype_gen flags env sigma lvar kind c = let program_mode = flags.program_mode in let poly = flags.polymorphic in @@ -1195,19 +1325,20 @@ let understand_ltac flags env sigma lvar kind c = let (sigma, c, _) = ise_pretype_gen flags env sigma lvar kind c in (sigma, c) -let path_convertible env sigma p q = +let path_convertible env sigma i p q = let open Classops in let mkGRef ref = DAst.make @@ Glob_term.GRef(ref,None) in let mkGVar id = DAst.make @@ Glob_term.GVar(id) in let mkGApp(rt,rtl) = DAst.make @@ Glob_term.GApp(rt,rtl) in let mkGLambda(n,t,b) = DAst.make @@ Glob_term.GLambda(n,Explicit,t,b) in + let mkGSort u = DAst.make @@ Glob_term.GSort u in let mkGHole () = DAst.make @@ Glob_term.GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) in let path_to_gterm p = match p with | ic :: p' -> let names = - List.map (fun n -> Id.of_string ("x" ^ string_of_int n)) - (List.interval 0 ic.coe_param) + List.init (ic.coe_param + 1) + (fun n -> Id.of_string ("x" ^ string_of_int n)) in List.fold_right (fun id t -> mkGLambda (Name id, mkGHole (), t)) names @@ @@ -1215,9 +1346,29 @@ let path_convertible env sigma p q = (fun t ic -> mkGApp (mkGRef ic.coe_value, List.make ic.coe_param (mkGHole ()) @ [t])) - (mkGApp (mkGRef ic.coe_value, List.map (fun i -> mkGVar i) names)) + (mkGApp (mkGRef ic.coe_value, List.map mkGVar names)) p' - | [] -> anomaly (str "A coercion path shouldn't be empty.") + | [] -> + (* identity function for the class [i]. *) + let cl,params = class_info_from_index i in + let clty = + match cl with + | CL_SORT -> mkGSort (Glob_term.UAnonymous {rigid=false}) + | CL_FUN -> anomaly (str "A source class must not be Funclass.") + | CL_SECVAR v -> mkGRef (GlobRef.VarRef v) + | CL_CONST c -> mkGRef (GlobRef.ConstRef c) + | CL_IND i -> mkGRef (GlobRef.IndRef i) + | CL_PROJ p -> mkGRef (GlobRef.ConstRef (Projection.Repr.constant p)) + in + let names = + List.init params.cl_param + (fun n -> Id.of_string ("x" ^ string_of_int n)) + in + List.fold_right + (fun id t -> mkGLambda (Name id, mkGHole (), t)) names @@ + mkGLambda (Name (Id.of_string "x"), + mkGApp (clty, List.map mkGVar names), + mkGVar (Id.of_string "x")) in try let sigma,tp = understand_tcc env sigma (path_to_gterm p) in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index f9da568c75..18e416596e 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -115,12 +115,49 @@ val solve_remaining_evars : ?hook:inference_hook -> inference_flags -> val check_evars_are_solved : program_mode:bool -> env -> ?initial:evar_map -> (* current map: *) evar_map -> unit -(** [check_evars env initial_sigma extended_sigma c] fails if some - new unresolved evar remains in [c] *) -val check_evars : env -> evar_map -> evar_map -> constr -> unit +(** [check_evars env ?initial sigma c] fails if some unresolved evar + remains in [c] which isn't in [initial] (any unresolved evar if + [initial] not provided) *) +val check_evars : env -> ?initial:evar_map -> evar_map -> constr -> unit (**/**) (** Internal of Pretyping... *) val ise_pretype_gen : inference_flags -> env -> evar_map -> ltac_var_map -> typing_constraint -> glob_constr -> evar_map * constr * types + +(** {6 Open-recursion style pretyper} *) + +type 'a pretype_fun = ?loc:Loc.t -> program_mode:bool -> poly:bool -> bool -> Evardefine.type_constraint -> GlobEnv.t -> evar_map -> evar_map * 'a + +type pretyper = { + pretype_ref : pretyper -> GlobRef.t * glob_level list option -> unsafe_judgment pretype_fun; + pretype_var : pretyper -> Id.t -> unsafe_judgment pretype_fun; + pretype_evar : pretyper -> existential_name * (Id.t * glob_constr) list -> unsafe_judgment pretype_fun; + pretype_patvar : pretyper -> Evar_kinds.matching_var_kind -> unsafe_judgment pretype_fun; + pretype_app : pretyper -> glob_constr * glob_constr list -> unsafe_judgment pretype_fun; + pretype_lambda : pretyper -> Name.t * binding_kind * glob_constr * glob_constr -> unsafe_judgment pretype_fun; + pretype_prod : pretyper -> Name.t * binding_kind * glob_constr * glob_constr -> unsafe_judgment pretype_fun; + pretype_letin : pretyper -> Name.t * glob_constr * glob_constr option * glob_constr -> unsafe_judgment pretype_fun; + pretype_cases : pretyper -> Constr.case_style * glob_constr option * tomatch_tuples * cases_clauses -> unsafe_judgment pretype_fun; + pretype_lettuple : pretyper -> Name.t list * (Name.t * glob_constr option) * glob_constr * glob_constr -> unsafe_judgment pretype_fun; + pretype_if : pretyper -> glob_constr * (Name.t * glob_constr option) * glob_constr * glob_constr -> unsafe_judgment pretype_fun; + pretype_rec : pretyper -> glob_fix_kind * Id.t array * glob_decl list array * glob_constr array * glob_constr array -> unsafe_judgment pretype_fun; + pretype_sort : pretyper -> glob_sort -> unsafe_judgment pretype_fun; + pretype_hole : pretyper -> Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option -> unsafe_judgment pretype_fun; + pretype_cast : pretyper -> glob_constr * glob_constr cast_type -> unsafe_judgment pretype_fun; + pretype_int : pretyper -> Uint63.t -> unsafe_judgment pretype_fun; + pretype_float : pretyper -> Float64.t -> unsafe_judgment pretype_fun; + pretype_type : pretyper -> glob_constr -> unsafe_type_judgment pretype_fun; +} +(** Type of pretyping algorithms in open-recursion style. A typical way to + implement a pretyping variant is to inherit from some pretyper using + record inheritance and replacing particular fields with the [where] clause. + Recursive calls to the subterms should call the [pretyper] provided as the + first argument to the function. This object can be turned in an actual + pretyping function through the {!eval_pretyper} function below. *) + +val default_pretyper : pretyper +(** Coq vanilla pretyper. *) + +val eval_pretyper : pretyper -> program_mode:bool -> poly:bool -> bool -> Evardefine.type_constraint -> GlobEnv.t -> evar_map -> glob_constr -> evar_map * unsafe_judgment diff --git a/printing/printer.ml b/printing/printer.ml index a85e268306..bb54f587fd 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -76,25 +76,22 @@ let () = and only names of goal/section variables and rel names that do _not_ occur in the scope of the binder to be printed are avoided. *) -let pr_econstr_n_core goal_concl_style env sigma n t = - pr_constr_expr_n env sigma n (extern_constr goal_concl_style env sigma t) -let pr_econstr_core goal_concl_style env sigma t = - pr_constr_expr env sigma (extern_constr goal_concl_style env sigma t) -let pr_leconstr_core = Proof_diffs.pr_leconstr_core - -let pr_constr_n_env env sigma n c = pr_econstr_n_core false env sigma n (EConstr.of_constr c) +let pr_econstr_n_env ?lax ?inctx ?scope env sigma n t = + pr_constr_expr_n env sigma n (extern_constr ?lax ?inctx ?scope env sigma t) +let pr_econstr_env ?lax ?inctx ?scope env sigma t = + pr_constr_expr env sigma (extern_constr ?lax ?inctx ?scope env sigma t) +let pr_leconstr_env = Proof_diffs.pr_leconstr_env + +let pr_constr_n_env ?lax ?inctx ?scope env sigma n c = + pr_econstr_n_env ?lax ?inctx ?scope env sigma n (EConstr.of_constr c) +let pr_constr_env ?lax ?inctx ?scope env sigma c = + pr_econstr_env ?lax ?inctx ?scope env sigma (EConstr.of_constr c) let pr_lconstr_env = Proof_diffs.pr_lconstr_env -let pr_constr_env env sigma c = pr_econstr_core false env sigma (EConstr.of_constr c) - -let pr_lconstr_goal_style_env env sigma c = pr_leconstr_core true env sigma (EConstr.of_constr c) -let pr_constr_goal_style_env env sigma c = pr_econstr_core true env sigma (EConstr.of_constr c) -let pr_econstr_n_env env sigma c = pr_econstr_n_core false env sigma c -let pr_leconstr_env env sigma c = pr_leconstr_core false env sigma c -let pr_econstr_env env sigma c = pr_econstr_core false env sigma c - -let pr_open_lconstr_env env sigma (_,c) = pr_leconstr_env env sigma c -let pr_open_constr_env env sigma (_,c) = pr_econstr_env env sigma c +let pr_open_lconstr_env ?lax ?inctx ?scope env sigma (_,c) = + pr_leconstr_env ?lax ?inctx ?scope env sigma c +let pr_open_constr_env ?lax ?inctx ?scope env sigma (_,c) = + pr_econstr_env ?lax ?inctx ?scope env sigma c let pr_constr_under_binders_env_gen pr env sigma (ids,c) = (* Warning: clashes can occur with variables of same name in env but *) @@ -106,16 +103,14 @@ let pr_constr_under_binders_env_gen pr env sigma (ids,c) = let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_econstr_env let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_leconstr_env -let pr_etype_core goal_concl_style env sigma t = - pr_constr_expr env sigma (extern_type goal_concl_style env sigma t) -let pr_letype_core = Proof_diffs.pr_letype_core - -let pr_ltype_env env sigma c = pr_letype_core false env sigma (EConstr.of_constr c) -let pr_type_env env sigma c = pr_etype_core false env sigma (EConstr.of_constr c) +let pr_etype_env ?lax ?goal_concl_style env sigma t = + pr_constr_expr env sigma (extern_type ?lax ?goal_concl_style env sigma t) +let pr_letype_env = Proof_diffs.pr_letype_env -let pr_etype_env env sigma c = pr_etype_core false env sigma c -let pr_letype_env env sigma c = pr_letype_core false env sigma c -let pr_goal_concl_style_env env sigma c = pr_letype_core true env sigma c +let pr_type_env ?lax ?goal_concl_style env sigma c = + pr_etype_env ?lax ?goal_concl_style env sigma (EConstr.of_constr c) +let pr_ltype_env ?lax ?goal_concl_style env sigma c = + pr_letype_env ?lax ?goal_concl_style env sigma (EConstr.of_constr c) let pr_ljudge_env env sigma j = (pr_leconstr_env env sigma j.uj_val, pr_leconstr_env env sigma j.uj_type) @@ -125,10 +120,10 @@ let pr_lglob_constr_env env c = let pr_glob_constr_env env c = pr_constr_expr env (Evd.from_env env) (extern_glob_constr (Termops.vars_of_env env) c) -let pr_closed_glob_n_env env sigma n c = - pr_constr_expr_n env sigma n (extern_closed_glob false env sigma c) -let pr_closed_glob_env env sigma c = - pr_constr_expr env sigma (extern_closed_glob false env sigma c) +let pr_closed_glob_n_env ?lax ?goal_concl_style ?inctx ?scope env sigma n c = + pr_constr_expr_n env sigma n (extern_closed_glob ?lax ?goal_concl_style ?inctx ?scope env sigma c) +let pr_closed_glob_env ?lax ?goal_concl_style ?inctx ?scope env sigma c = + pr_constr_expr env sigma (extern_closed_glob ?lax ?goal_concl_style ?inctx ?scope env sigma c) let pr_lconstr_pattern_env env sigma c = pr_lconstr_pattern_expr env sigma (extern_constr_pattern (Termops.names_of_rel_context env) sigma c) @@ -141,7 +136,7 @@ let pr_cases_pattern t = let pr_sort sigma s = pr_glob_sort (extern_sort sigma s) let () = Termops.Internal.set_print_constr - (fun env sigma t -> pr_lconstr_expr env sigma (extern_constr ~lax:true false env sigma t)) + (fun env sigma t -> pr_lconstr_expr env sigma (extern_constr ~lax:true env sigma t)) let pr_in_comment x = str "(* " ++ x ++ str " *)" @@ -462,7 +457,7 @@ let pr_goal ?(diffs=false) ?og_s g_s = else pr_context_of env sigma ++ cut () ++ str "============================" ++ cut () ++ - pr_goal_concl_style_env env sigma concl + pr_letype_env ~goal_concl_style:true env sigma concl in str " " ++ v 0 goal @@ -489,7 +484,7 @@ let pr_concl n ?(diffs=false) ?og_s sigma g = if diffs then Proof_diffs.diff_concl ?og_s sigma g else - pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g) + pr_letype_env ~goal_concl_style:true env sigma (Goal.V82.concl sigma g) in let header = pr_goal_header (int n) sigma g in header ++ str " is:" ++ cut () ++ str" " ++ pc diff --git a/printing/printer.mli b/printing/printer.mli index 87b09ff755..1d7a25cbb6 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -15,55 +15,93 @@ open Pattern open Evd open Glob_term open Ltac_pretype +open Notation_term (** These are the entry points for printing terms, context, tac, ... *) - val enable_unfocused_goal_printing: bool ref val enable_goal_tags_printing : bool ref val enable_goal_names_printing : bool ref (** Terms *) -val pr_lconstr_env : env -> evar_map -> constr -> Pp.t -val pr_lconstr_goal_style_env : env -> evar_map -> constr -> Pp.t +(** Printers for terms. + + The "lconstr" variant does not require parentheses to isolate the + expression from the surrounding context (for instance [3 + 4] + will be written [3 + 4]). The "constr" variant (w/o "l") + enforces parentheses whenever the term is not an atom (for + instance, [3] will be written [3] but [3 + 4] will be + written [(3 + 4)]. + + [~inctx:true] indicates that the term is intended to be printed in + a context where its type is known so that a head coercion would be + skipped, or implicit arguments inferable from the context will not + be made explicit. For instance, if [foo] is declared as a + coercion, [foo bar] will be printed as [bar] if [inctx] is [true] + and as [foo bar] otherwise. + + [~scope:some_scope_name] indicates that the head of the term is + intended to be printed in scope [some_scope_name]. It defaults to + [None]. + + [~lax:true] is for debugging purpose. It defaults to [~lax:false]. *) -val pr_constr_env : env -> evar_map -> constr -> Pp.t -val pr_constr_goal_style_env : env -> evar_map -> constr -> Pp.t -val pr_constr_n_env : env -> evar_map -> Notation_gram.tolerability -> constr -> Pp.t +val pr_constr_env : ?lax:bool -> ?inctx:bool -> ?scope:scope_name -> env -> evar_map -> constr -> Pp.t +val pr_lconstr_env : ?lax:bool -> ?inctx:bool -> ?scope:scope_name -> env -> evar_map -> constr -> Pp.t + +val pr_constr_n_env : ?lax:bool -> ?inctx:bool -> ?scope:scope_name -> env -> evar_map -> Notation_gram.tolerability -> constr -> Pp.t (** Same, but resilient to [Nametab] errors. Prints fully-qualified names when [shortest_qualid_of_global] has failed. Prints "??" in case of remaining issues (such as reference not in env). *) -val safe_pr_lconstr_env : env -> evar_map -> constr -> Pp.t - -val safe_pr_constr_env : env -> evar_map -> constr -> Pp.t - -val pr_econstr_env : env -> evar_map -> EConstr.t -> Pp.t -val pr_leconstr_env : env -> evar_map -> EConstr.t -> Pp.t +val safe_pr_constr_env : env -> evar_map -> constr -> Pp.t +val safe_pr_lconstr_env : env -> evar_map -> constr -> Pp.t -val pr_econstr_n_env : env -> evar_map -> Notation_gram.tolerability -> EConstr.t -> Pp.t +val pr_econstr_env : ?lax:bool -> ?inctx:bool -> ?scope:scope_name -> env -> evar_map -> EConstr.t -> Pp.t +val pr_leconstr_env : ?lax:bool -> ?inctx:bool -> ?scope:scope_name -> env -> evar_map -> EConstr.t -> Pp.t -val pr_etype_env : env -> evar_map -> EConstr.types -> Pp.t -val pr_letype_env : env -> evar_map -> EConstr.types -> Pp.t +val pr_econstr_n_env : ?lax:bool -> ?inctx:bool -> ?scope:scope_name -> env -> evar_map -> Notation_gram.tolerability -> EConstr.t -> Pp.t -val pr_open_constr_env : env -> evar_map -> open_constr -> Pp.t +val pr_etype_env : ?lax:bool -> ?goal_concl_style:bool -> env -> evar_map -> EConstr.types -> Pp.t +val pr_letype_env : ?lax:bool -> ?goal_concl_style:bool -> env -> evar_map -> EConstr.types -> Pp.t -val pr_open_lconstr_env : env -> evar_map -> open_constr -> Pp.t +val pr_open_constr_env : ?lax:bool -> ?inctx:bool -> ?scope:scope_name -> env -> evar_map -> open_constr -> Pp.t +val pr_open_lconstr_env : ?lax:bool -> ?inctx:bool -> ?scope:scope_name -> env -> evar_map -> open_constr -> Pp.t val pr_constr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t val pr_lconstr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t -val pr_goal_concl_style_env : env -> evar_map -> EConstr.types -> Pp.t -val pr_ltype_env : env -> evar_map -> types -> Pp.t - -val pr_type_env : env -> evar_map -> types -> Pp.t - -val pr_closed_glob_n_env : env -> evar_map -> Notation_gram.tolerability -> closed_glob_constr -> Pp.t -val pr_closed_glob_env : env -> evar_map -> closed_glob_constr -> Pp.t +(** Printers for types. Types are printed in scope "type_scope" and + under the constraint of being of type a sort. + + The "ltype" variant does not require parentheses to isolate the + expression from the surrounding context (for instance [nat * bool] + will be written [nat * bool]). The "type" variant (w/o "l") + enforces parentheses whenever the term is not an atom (for + instance, [nat] will be written [nat] but [nat * bool] will be + written [(nat * bool)]. + + [~goal_concl_style:true] tells to print the type the same way as + command [Show] would print a goal. Concretely, it means that all + names of goal/section variables and all names of variables + referred by de Bruijn indices (if any) in the given environment + and all short names of global definitions of the current module + must be avoided while printing bound variables. Otherwise, short + names of global definitions are printed qualified and only names + of goal/section variables and rel names that do _not_ occur in the + scope of the binder to be printed are avoided. + + [~lax:true] is for debugging purpose. *) + +val pr_ltype_env : ?lax:bool -> ?goal_concl_style:bool -> env -> evar_map -> types -> Pp.t +val pr_type_env : ?lax:bool -> ?goal_concl_style:bool -> env -> evar_map -> types -> Pp.t + +val pr_closed_glob_n_env : ?lax:bool -> ?goal_concl_style:bool -> ?inctx:bool -> ?scope:scope_name -> env -> evar_map -> Notation_gram.tolerability -> closed_glob_constr -> Pp.t +val pr_closed_glob_env : ?lax:bool -> ?goal_concl_style:bool -> ?inctx:bool -> ?scope:scope_name -> env -> evar_map -> closed_glob_constr -> Pp.t val pr_ljudge_env : env -> evar_map -> EConstr.unsafe_judgment -> Pp.t * Pp.t diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index 233163d097..dec87f8071 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -245,18 +245,18 @@ let process_goal sigma g : EConstr.t reified_goal = let hyps = List.map to_tuple hyps in { name; ty; hyps; env; sigma };; -let pr_letype_core goal_concl_style env sigma t = - Ppconstr.pr_lconstr_expr env sigma (Constrextern.extern_type goal_concl_style env sigma t) +let pr_letype_env ?lax ?goal_concl_style env sigma t = + Ppconstr.pr_lconstr_expr env sigma + (Constrextern.extern_type ?lax ?goal_concl_style env sigma t) let pp_of_type env sigma ty = - pr_letype_core true env sigma ty + pr_letype_env ~goal_concl_style:true env sigma ty -let pr_leconstr_core goal_concl_style env sigma t = - Ppconstr.pr_lconstr_expr env sigma (Constrextern.extern_constr goal_concl_style env sigma t) +let pr_leconstr_env ?lax ?inctx ?scope env sigma t = + Ppconstr.pr_lconstr_expr env sigma (Constrextern.extern_constr ?lax ?inctx ?scope env sigma t) -let pr_lconstr_env env sigma c = pr_leconstr_core false env sigma (EConstr.of_constr c) - -let pr_lconstr_env_econstr env sigma c = pr_leconstr_core false env sigma c +let pr_lconstr_env ?lax ?inctx ?scope env sigma c = + pr_leconstr_env ?lax ?inctx ?scope env sigma (EConstr.of_constr c) let diff_concl ?og_s nsigma ng = let open Evd in @@ -301,7 +301,7 @@ let goal_info goal sigma = line_idents := idents :: !line_idents; let mid = match body with | Some c -> - let pb = pr_lconstr_env_econstr env sigma c in + let pb = pr_leconstr_env env sigma c in let pb = if EConstr.isCast sigma c then surround pb else pb in str " := " ++ pb | None -> mt() in @@ -556,7 +556,7 @@ let to_constr pf = (* pprf generally has only one element, but it may have more in the derive plugin *) let t = List.hd pprf in let sigma, env = get_proof_context pf in - let x = Constrextern.extern_constr false env sigma t in (* todo: right options?? *) + let x = Constrextern.extern_constr env sigma t in (* todo: right options?? *) x.v diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli index a806ab7123..eebdaccd32 100644 --- a/printing/proof_diffs.mli +++ b/printing/proof_diffs.mli @@ -57,9 +57,9 @@ val diff_goal : ?og_s:(Goal.goal sigma) -> Goal.goal -> Evd.evar_map -> Pp.t (** Convert a string to a list of token strings using the lexer *) val tokenize_string : string -> string list -val pr_letype_core : bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Pp.t -val pr_leconstr_core : bool -> Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t -val pr_lconstr_env : env -> evar_map -> constr -> Pp.t +val pr_letype_env : ?lax:bool -> ?goal_concl_style:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Pp.t +val pr_leconstr_env : ?lax:bool -> ?inctx:bool -> ?scope:Notation_term.scope_name -> Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t +val pr_lconstr_env : ?lax:bool -> ?inctx:bool -> ?scope:Notation_term.scope_name -> env -> evar_map -> constr -> Pp.t (** Computes diffs for a single conclusion *) val diff_concl : ?og_s:Goal.goal sigma -> Evd.evar_map -> Goal.goal -> Pp.t diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 611671255d..c6a0299cf3 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -72,7 +72,9 @@ let clenv_refine ?(with_evars=false) ?(with_classes=true) clenv = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:(not with_evars) clenv.env clenv.evd in - Typeclasses.make_unresolvables (fun x -> List.mem_f Evar.equal x evars) evd' + (* After an apply, all the subgoals including those dependent shelved ones are in + the hands of the user and resolution won't be called implicitely on them. *) + Typeclasses.make_unresolvables (fun x -> true) evd' else clenv.evd in let clenv = { clenv with evd = evd' } in diff --git a/proofs/proof.ml b/proofs/proof.ml index 2ee006631a..e9f93d0c8f 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -386,12 +386,7 @@ let run_tactic env tac pr = let sigma = Proofview.return proofview in let to_shelve = undef sigma to_shelve in let shelf = (undef sigma pr.shelf)@retrieved@to_shelve in - let proofview = - List.fold_left - Proofview.Unsafe.mark_as_unresolvable - proofview - to_shelve - in + let proofview = Proofview.Unsafe.mark_as_unresolvables proofview to_shelve in let given_up = pr.given_up@give_up in let proofview = Proofview.Unsafe.reset_future_goals proofview in { pr with proofview ; shelf ; given_up },(status,info_trace),result diff --git a/proofs/refine.ml b/proofs/refine.ml index dd8b52e56c..ea42218aaa 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -94,6 +94,7 @@ let generic_refine ~typecheck f gl = in (* Mark goals *) let sigma = Proofview.Unsafe.mark_as_goals sigma comb in + let sigma = Proofview.Unsafe.mark_unresolvables sigma shelf in let comb = CList.map (fun x -> Proofview.goal_with_state x state) comb in let trace env sigma = Pp.(hov 2 (str"simple refine"++spc()++ Termops.Internal.print_constr_env env sigma c)) in diff --git a/proofs/refine.mli b/proofs/refine.mli index bdcccae805..269382489d 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -25,7 +25,8 @@ val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> uni for the current goal (refine is a goal-dependent tactic), the new holes created by [t] become the new subgoals. Exceptions raised during the interpretation of [t] are caught and result in - tactic failures. If [typecheck] is [true] [t] is type-checked beforehand. *) + tactic failures. If [typecheck] is [true] [t] is type-checked beforehand. + Shelved evars and goals are all marked as unresolvable for typeclasses. *) val generic_refine : typecheck:bool -> ('a * EConstr.t) tactic -> Proofview.Goal.t -> 'a tactic diff --git a/tactics/declare.ml b/tactics/declare.ml index fb06bb8a4f..da4de3df77 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -56,7 +56,7 @@ let declare_universe_context ~poly ctx = let nas = name_instance (Univ.UContext.instance uctx) in Global.push_section_context (nas, uctx) else - Global.push_context_set false ctx + Global.push_context_set ~strict:true ctx (** Declaration of constants and parameters *) diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 51f01888aa..d6fda00ad8 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -24,14 +24,14 @@ open Ind_tables (* Induction/recursion schemes *) -let optimize_non_type_induction_scheme kind dep sort _ ind = +let optimize_non_type_induction_scheme kind dep sort ind = let env = Global.env () in let sigma = Evd.from_env env in if check_scheme kind ind then (* in case the inductive has a type elimination, generates only one induction scheme, the other ones share the same code with the appropriate type *) - let cte, eff = find_scheme kind ind in + let cte = lookup_scheme kind ind in let sigma, cte = Evd.fresh_constant_instance env sigma cte in let c = mkConstU cte in let t = type_of_constant_in (Global.env()) cte in @@ -47,11 +47,11 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = let sigma, sort = Evd.fresh_sort_in_family sigma sort in let sigma, t', c' = weaken_sort_scheme env sigma false sort npars c t in let sigma = Evd.minimize_universes sigma in - (Evarutil.nf_evars_universes sigma c', Evd.evar_universe_context sigma), eff + (Evarutil.nf_evars_universes sigma c', Evd.evar_universe_context sigma) else let sigma, pind = Evd.fresh_inductive_instance env sigma ind in let sigma, c = build_induction_scheme env sigma pind dep sort in - (c, Evd.evar_universe_context sigma), Evd.empty_side_effects + (c, Evd.evar_universe_context sigma) let build_induction_scheme_in_type dep sort ind = let env = Global.env () in @@ -60,17 +60,23 @@ let build_induction_scheme_in_type dep sort ind = let sigma, c = build_induction_scheme env sigma pind dep sort in c, Evd.evar_universe_context sigma +let declare_individual_scheme_object name ?aux f = + let f : individual_scheme_object_function = + fun _ ind -> f ind, Evd.empty_side_effects + in + declare_individual_scheme_object name ?aux f + let rect_scheme_kind_from_type = declare_individual_scheme_object "_rect_nodep" - (fun _ x -> build_induction_scheme_in_type false InType x, Evd.empty_side_effects) + (fun x -> build_induction_scheme_in_type false InType x) let rect_scheme_kind_from_prop = declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop" - (fun _ x -> build_induction_scheme_in_type false InType x, Evd.empty_side_effects) + (fun x -> build_induction_scheme_in_type false InType x) let rect_dep_scheme_kind_from_type = declare_individual_scheme_object "_rect" ~aux:"_rect_from_type" - (fun _ x -> build_induction_scheme_in_type true InType x, Evd.empty_side_effects) + (fun x -> build_induction_scheme_in_type true InType x) let rec_scheme_kind_from_type = declare_individual_scheme_object "_rec_nodep" ~aux:"_rec_nodep_from_type" @@ -90,7 +96,7 @@ let ind_scheme_kind_from_type = let sind_scheme_kind_from_type = declare_individual_scheme_object "_sind_nodep" - (fun _ x -> build_induction_scheme_in_type false InSProp x, Evd.empty_side_effects) + (fun x -> build_induction_scheme_in_type false InSProp x) let ind_dep_scheme_kind_from_type = declare_individual_scheme_object "_ind" ~aux:"_ind_from_type" @@ -98,7 +104,7 @@ let ind_dep_scheme_kind_from_type = let sind_dep_scheme_kind_from_type = declare_individual_scheme_object "_sind" ~aux:"_sind_from_type" - (fun _ x -> build_induction_scheme_in_type true InSProp x, Evd.empty_side_effects) + (fun x -> build_induction_scheme_in_type true InSProp x) let ind_scheme_kind_from_prop = declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop" @@ -106,7 +112,7 @@ let ind_scheme_kind_from_prop = let sind_scheme_kind_from_prop = declare_individual_scheme_object "_sind" ~aux:"_sind_from_prop" - (fun _ x -> build_induction_scheme_in_type false InSProp x, Evd.empty_side_effects) + (fun x -> build_induction_scheme_in_type false InSProp x) let nondep_elim_scheme from_kind to_kind = match from_kind, to_kind with @@ -130,24 +136,24 @@ let build_case_analysis_scheme_in_type dep sort ind = let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" - (fun _ x -> build_case_analysis_scheme_in_type false InType x, Evd.empty_side_effects) + (fun x -> build_case_analysis_scheme_in_type false InType x) let case_scheme_kind_from_prop = declare_individual_scheme_object "_case" ~aux:"_case_from_prop" - (fun _ x -> build_case_analysis_scheme_in_type false InType x, Evd.empty_side_effects) + (fun x -> build_case_analysis_scheme_in_type false InType x) let case_dep_scheme_kind_from_type = declare_individual_scheme_object "_case" ~aux:"_case_from_type" - (fun _ x -> build_case_analysis_scheme_in_type true InType x, Evd.empty_side_effects) + (fun x -> build_case_analysis_scheme_in_type true InType x) let case_dep_scheme_kind_from_type_in_prop = declare_individual_scheme_object "_casep_dep" - (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Evd.empty_side_effects) + (fun x -> build_case_analysis_scheme_in_type true InProp x) let case_dep_scheme_kind_from_prop = declare_individual_scheme_object "_case_dep" - (fun _ x -> build_case_analysis_scheme_in_type true InType x, Evd.empty_side_effects) + (fun x -> build_case_analysis_scheme_in_type true InType x) let case_dep_scheme_kind_from_prop_in_prop = declare_individual_scheme_object "_casep" - (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Evd.empty_side_effects) + (fun x -> build_case_analysis_scheme_in_type true InProp x) diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli index 093a4c456b..8e167b171c 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -12,14 +12,6 @@ open Ind_tables (** Induction/recursion schemes *) -val optimize_non_type_induction_scheme : - 'a Ind_tables.scheme_kind -> - Indrec.dep_flag -> - Sorts.family -> - 'b -> - Names.inductive -> - (Constr.constr * UState.t) * Evd.side_effects - val rect_scheme_kind_from_prop : individual scheme_kind val ind_scheme_kind_from_prop : individual scheme_kind val sind_scheme_kind_from_prop : individual scheme_kind diff --git a/tactics/equality.ml b/tactics/equality.ml index fc37d5a254..96b61b6994 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1648,7 +1648,14 @@ let cutSubstClause l2r eqn cls = | None -> cutSubstInConcl l2r eqn | Some id -> cutSubstInHyp l2r eqn id -let cutRewriteClause l2r eqn cls = try_rewrite (cutSubstClause l2r eqn cls) +let warn_deprecated_cutrewrite = + CWarnings.create ~name:"deprecated-cutrewrite" ~category:"deprecated" + (fun () -> strbrk"\"cutrewrite\" is deprecated. See documentation for proposed replacement.") + +let cutRewriteClause l2r eqn cls = + warn_deprecated_cutrewrite (); + try_rewrite (cutSubstClause l2r eqn cls) + let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None diff --git a/tactics/hints.ml b/tactics/hints.ml index eb50a2a67c..7b3797119a 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1289,8 +1289,7 @@ let prepare_hint check env init (sigma,c) = mkNamedLambda (make_annot id Sorts.Relevant) t (iter (replace_term sigma evar (mkVar id) c)) in let c' = iter c in let env = Global.env () in - let empty_sigma = Evd.from_env env in - if check then Pretyping.check_evars env empty_sigma sigma c'; + if check then Pretyping.check_evars env sigma c'; let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in (c', diff) diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index 9c94f3c319..517ccfaf53 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -82,10 +82,9 @@ let is_visible_name id = with Not_found -> false let compute_name internal id = - match internal with - | UserAutomaticRequest | UserIndividualRequest -> id - | InternalTacticRequest -> - Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name + if internal then + Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name + else id let define internal role id c poly univs = let id = compute_name internal id in @@ -94,10 +93,7 @@ let define internal role id c poly univs = let univs = UState.univ_entry ~poly ctx in let entry = Declare.pure_definition_entry ~univs c in let kn, eff = Declare.declare_private_constant ~role ~kind:Decls.(IsDefinition Scheme) ~name:id entry in - let () = match internal with - | InternalTacticRequest -> () - | _-> Declare.definition_message id - in + let () = if internal then () else Declare.definition_message id in kn, eff let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = @@ -107,7 +103,8 @@ let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in let role = Evd.Schema (ind, kind) in - let const, neff = define mode role id c (Declareops.inductive_is_polymorphic mib) ctx in + let internal = mode == InternalTacticRequest in + let const, neff = define internal role id c (Declareops.inductive_is_polymorphic mib) ctx in DeclareScheme.declare_scheme kind [|ind,const|]; const, Evd.concat_side_effects neff eff @@ -125,7 +122,8 @@ let define_mutual_scheme_base kind suff f mode names mind = with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in let fold i effs id cl = let role = Evd.Schema ((mind, i), kind)in - let cst, neff = define mode role id cl (Declareops.inductive_is_polymorphic mib) ctx in + let internal = mode == InternalTacticRequest in + let cst, neff = define internal role id cl (Declareops.inductive_is_polymorphic mib) ctx in (Evd.concat_side_effects neff effs, cst) in let (eff, consts) = Array.fold_left2_map_i fold eff ids cl in @@ -153,6 +151,14 @@ let find_scheme ?(mode=InternalTacticRequest) kind (mind,i as ind) = let ca, eff = define_mutual_scheme_base kind s f mode [] mind in ca.(i), eff +let define_individual_scheme kind mode names ind = + ignore (define_individual_scheme kind mode names ind) + +let define_mutual_scheme kind mode names mind = + ignore (define_mutual_scheme kind mode names mind) + let check_scheme kind ind = try let _ = find_scheme_on_env_too kind ind in true with Not_found -> false + +let lookup_scheme = DeclareScheme.lookup_scheme diff --git a/tactics/ind_tables.mli b/tactics/ind_tables.mli index 7e544b09dc..d886fb67d3 100644 --- a/tactics/ind_tables.mli +++ b/tactics/ind_tables.mli @@ -45,15 +45,17 @@ val declare_individual_scheme_object : string -> ?aux:string -> val define_individual_scheme : individual scheme_kind -> internal_flag (** internal *) -> - Id.t option -> inductive -> Constant.t * Evd.side_effects + Id.t option -> inductive -> unit val define_mutual_scheme : mutual scheme_kind -> internal_flag (** internal *) -> - (int * Id.t) list -> MutInd.t -> Constant.t array * Evd.side_effects + (int * Id.t) list -> MutInd.t -> unit (** Main function to retrieve a scheme in the cache or to generate it *) val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> Constant.t * Evd.side_effects val check_scheme : 'a scheme_kind -> inductive -> bool +(** Like [find_scheme] but fails when the scheme is not already in the cache *) +val lookup_scheme : 'a scheme_kind -> inductive -> Constant.t val pr_scheme_kind : 'a scheme_kind -> Pp.t diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 33c9c11350..9258a75461 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -934,7 +934,7 @@ let is_local_unfold env flags = let reduce redexp cl = let trace env sigma = let open Printer in - let pr = (pr_econstr_env, pr_leconstr_env, pr_evaluable_reference, pr_constr_pattern_env) in + let pr = ((fun e -> pr_econstr_env e), (fun e -> pr_leconstr_env e), pr_evaluable_reference, pr_constr_pattern_env) in Pp.(hov 2 (Ppred.pr_red_expr_env env sigma pr str redexp)) in Proofview.Trace.name_tactic trace begin @@ -2982,14 +2982,17 @@ let quantify lconstr = hypothesis of the goal, the new hypothesis replaces it. (c,lbind) are supposed to be of the form - ((t t1 t2 ... tm) , someBindings) + ((H t1 t2 ... tm) , someBindings) + whete t1..tn are user given args, to which someBinding must be combined. - in which case we pose a proof with body + The goal is to pose a proof with body - (fun y1...yp => H t1 t2 ... tm u1 ... uq) where yi are the - remaining arguments of H that lbind could not resolve, ui are a mix - of inferred args and yi. The overall effect is to remove from H as - much quantification as possible given lbind. *) + (fun y1...yp => H t1 t2 ... tm u1 ... uq) + + where yi are the remaining arguments of H that lbind could not + solve, ui are a mix of inferred args and yi. The overall effect + is to remove from H as much quantification as possible given + lbind. *) let specialize (c,lbind) ipat = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -2998,6 +3001,7 @@ let specialize (c,lbind) ipat = if lbind == NoBindings then sigma, c else + (* ***** SOLVING ARGS ******* *) let typ_of_c = Retyping.get_type_of env sigma c in (* If the term is lambda then we put a letin to put avoid interaction between the term and the bindings. *) @@ -3010,16 +3014,24 @@ let specialize (c,lbind) ipat = let clause = clenv_unify_meta_types ~flags clause in let sigma = clause.evd in let (thd,tstack) = whd_nored_stack sigma (clenv_value clause) in - let c_hd , c_args = decompose_app sigma c in + (* The completely applied term is (thd tstack), but tstack may + contain unsolved metas, so now we must reabstract them + args with there name to have + fun unsolv1 unsolv2 ... => (thd tstack_with _rels) + Note: letins have been reudced, they are not present in tstack *) + (* ****** REBUILDING UNSOLVED FORALLs ****** *) + (* thd is the thing to which we reapply everything, solved or + unsolved, unsolved things are requantified too *) let liftrel x = match kind sigma x with | Rel n -> mkRel (n+1) | _ -> x in (* We grab names used in product to remember them at re-abstracting phase *) - let typ_of_c_hd = pf_get_type_of gl c_hd in + let typ_of_c_hd = pf_get_type_of gl thd in let lprod, concl = decompose_prod_assum sigma typ_of_c_hd in - (* accumulator args: arguments to apply to c_hd: all inferred - args + re-abstracted rels *) + (* lprd = initial products (including letins). + l(tstack initially) = the same products after unification vs lbind (some metas remain) + args: accumulator : args to apply to hd: inferred args + metas reabstracted *) let rec rebuild_lambdas sigma lprd args hd l = match lprd , l with | _, [] -> sigma,applist (hd, (List.map (nf_evar sigma) args)) @@ -3038,8 +3050,13 @@ let specialize (c,lbind) ipat = | Context.Rel.Declaration.LocalAssum _::lp' , t::l' -> let sigma,hd' = rebuild_lambdas sigma lp' (args@[t]) hd l' in sigma,hd' + | Context.Rel.Declaration.LocalDef _::lp' , _ -> + (* letins have been reduced in l and should anyway not + correspond to an arg, we ignore them. *) + let sigma,hd' = rebuild_lambdas sigma lp' args hd l in + sigma,hd' | _ ,_ -> assert false in - let sigma,hd = rebuild_lambdas sigma (List.rev lprod) [] c_hd tstack in + let sigma,hd = rebuild_lambdas sigma (List.rev lprod) [] thd tstack in Evd.clear_metas sigma, hd in let typ = Retyping.get_type_of env sigma term in diff --git a/test-suite/Makefile b/test-suite/Makefile index 1744138d29..b3a633e528 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -530,7 +530,7 @@ $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v $(PREREQUISITELOG) $(HIDE){ \ echo $(call log_intro,$<); \ true "extract effective user time"; \ - res=`$(coqc_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \ + res=`$(coqc_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1 | sed "s/\r//g"`; \ R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ @@ -540,17 +540,25 @@ $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v $(PREREQUISITELOG) echo " $<...Error! (couldn't find a time measure)"; \ else \ true "express effective time in centiseconds"; \ + resorig="$$res"; \ res=`echo "$$res"00 | sed -n -e "s/\([0-9]*\)\.\([0-9][0-9]\).*/\1\2/p"`; \ - true "find expected time * 100"; \ - exp=`sed -n -e "s/(\*.*Expected time < \([0-9]\).\([0-9][0-9]\)s.*\*)/\1\2/p" "$<"`; \ - ok=`expr \( $$res \* $(bogomips) \) "<" \( $$exp \* 6120 \)`; \ - if [ "$$ok" = 1 ]; then \ - echo $(log_success); \ - echo " $<...Ok"; \ - else \ + if [ "$$res" = "" ]; then \ echo $(log_failure); \ - echo " $<...Error! (should run faster)"; \ - $(FAIL); \ + echo " $<...Error! (invalid time measure: $$resorig)"; \ + else \ + true "find expected time * 100"; \ + exp=`sed -n -e "s/(\*.*Expected time < \([0-9]\).\([0-9][0-9]\)s.*\*)/\1\2/p" "$<"`; \ + true "compute corrected effective time, rounded up"; \ + rescorrected=`expr \( $$res \* $(bogomips) + 6120 - 1 \) / 6120`; \ + ok=`expr \( $$res \* $(bogomips) \) "<" \( $$exp \* 6120 \)`; \ + if [ "$$ok" = 1 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error! (should run faster ($$rescorrected >= $$exp))"; \ + $(FAIL); \ + fi; \ fi; \ fi; \ } > "$@" diff --git a/test-suite/bugs/bug_9490.v b/test-suite/bugs/bug_9490.v new file mode 100644 index 0000000000..a5def40c49 --- /dev/null +++ b/test-suite/bugs/bug_9490.v @@ -0,0 +1,9 @@ +Declare Custom Entry with_pattern. +Declare Custom Entry M_branch. +Notation "'with' | p1 | .. | pn 'end'" := + (cons p1 (.. (cons pn nil) ..)) + (in custom with_pattern at level 91, p1 custom M_branch at level 202, pn custom M_branch at level 202). +Notation "'bla'" := I (in custom M_branch at level 202). +Notation "'[use_with' l ]" := (l) (at level 0, l custom with_pattern at level 91). +Check [use_with with | bla end]. +Check [use_with with | bla | bla end]. diff --git a/test-suite/bugs/bug_9532.v b/test-suite/bugs/bug_9532.v new file mode 100644 index 0000000000..d198d45f2f --- /dev/null +++ b/test-suite/bugs/bug_9532.v @@ -0,0 +1,12 @@ +Declare Custom Entry atom. +Notation "1" := tt (in custom atom). +Notation "atom:( s )" := s (s custom atom). + +Declare Custom Entry expr. +Notation "expr:( s )" := s (s custom expr). +Notation "( x , y , .. , z )" := (@cons unit x (@cons unit y .. (@cons unit z (@nil unit)) ..)) + (in custom expr at level 0, x custom atom, y custom atom, z custom atom). + +Check atom:(1). +Check expr:((1,1)). +Check expr:((1,1,1)). diff --git a/test-suite/bugs/closed/bug_10298.v b/test-suite/bugs/closed/bug_10298.v new file mode 100644 index 0000000000..ad4778cc36 --- /dev/null +++ b/test-suite/bugs/closed/bug_10298.v @@ -0,0 +1,35 @@ +Set Implicit Arguments. + +Generalizable Variables A. + +Parameter val : Type. + +Class Enc (A:Type) := + make_Enc { enc : A -> val }. + +Global Instance Enc_dummy : Enc unit. +Admitted. + +Definition FORM := forall A (EA:Enc A) (Q:A->Prop), Prop. + +Axiom FORM_intro : forall F : FORM, F unit Enc_dummy (fun _ : unit => True). + +Definition IDF (F:FORM) : FORM := F. + +Parameter ID : forall (G:Prop), G -> G. + +Parameter EID : forall A (EA:Enc A) (F:FORM) (Q:A->Prop), + F _ _ Q -> + F _ _ Q. + +Lemma bla : forall F, + (forall A (EA:Enc A), IDF F EA (fun (X:A) => True) -> True) -> + True. +Proof. + intros F M. + notypeclasses refine (M _ _ _). + notypeclasses refine (EID _ _ _ _). + eapply (ID _). + Unshelve. + + apply FORM_intro. +Qed. diff --git a/test-suite/bugs/closed/bug_10504.v b/test-suite/bugs/closed/bug_10504.v new file mode 100644 index 0000000000..6e66a6a90a --- /dev/null +++ b/test-suite/bugs/closed/bug_10504.v @@ -0,0 +1,14 @@ +Inductive any_list {A} := +| nil : @any_list A +| cons : forall X, A -> @any_list X -> @any_list A. + +Arguments nil {A}. +Arguments cons {A X}. + +Notation "[]" := (@nil Type). +Notation "hd :: tl" := (cons hd tl). + +Definition xs := true :: 2137 :: false :: 0 :: []. +Fail Definition ys := xs :: xs. + +(* Goal ys = ys. produced an anomaly "Unable to handle arbitrary u+k <= v constraints" *) diff --git a/test-suite/bugs/closed/bug_10762.v b/test-suite/bugs/closed/bug_10762.v new file mode 100644 index 0000000000..d3991d4d38 --- /dev/null +++ b/test-suite/bugs/closed/bug_10762.v @@ -0,0 +1,30 @@ + +Set Implicit Arguments. + +Generalizable Variables A B. +Parameter val: Type. + +Class Enc (A:Type) : Type := + make_Enc { enc : A -> val }. + +Hint Mode Enc + : typeclass_instances. + +Parameter bar : forall A (EA:Enc A), EA = EA. + +Parameter foo : forall (P:Prop), + P -> + P = P -> + True. + +Parameter id : forall (P:Prop), + P -> P. + + Check enc. + + Lemma test : True. + eapply foo; [ eapply bar | apply id]. apply id. + (* eapply bar introduces an unresolved typeclass evar that is no longer + a candidate after the application (eapply should leave typeclass goals shelved). + We ensure that this happens also _across_ goals in `[ | ]` and not only at `.`.. + *) + Abort. diff --git a/test-suite/bugs/closed/bug_11039.v b/test-suite/bugs/closed/bug_11039.v new file mode 100644 index 0000000000..f02a3ef177 --- /dev/null +++ b/test-suite/bugs/closed/bug_11039.v @@ -0,0 +1,26 @@ +(* this bug was a proof of False *) + +(* when we require template poly Coq recognizes that it's not allowed *) +Fail #[universes(template)] + Inductive foo@{i} (A:Type@{i}) : Type@{i+1} := bar (X:Type@{i}) : foo A. + +(* variants with letin *) +Fail #[universes(template)] + Inductive foo@{i} (T:=Type@{i}:Type@{i+1}) (A:Type@{i}) : Type@{i+1} := bar (X:T) : foo A. + +Fail #[universes(template)] + Record foo@{i} (T:=Type@{i}:Type@{i+1}) (A:Type@{i}) : Type@{i+1} := bar { X:T }. + + +(* no implicit template poly, no explicit universe annotations *) +Inductive foo (A:Type) := bar X : foo X -> foo A | nonempty. +Arguments nonempty {_}. + +Fail Check foo nat : Type@{foo.u0}. +(* template poly didn't activate *) + +Definition U := Type. +Definition A : U := foo nat. + +Fail Definition down : U -> A := fun u => bar nat u nonempty. +(* this is the one where it's important that it fails *) diff --git a/test-suite/bugs/closed/bug_2083.v b/test-suite/bugs/closed/bug_2083.v index f33e96cea6..40fda71e66 100644 --- a/test-suite/bugs/closed/bug_2083.v +++ b/test-suite/bugs/closed/bug_2083.v @@ -13,15 +13,15 @@ Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) error end. -Require Import Omega. +Require Import Lia. -Solve Obligations with program_simpl ; auto with *; try omega. +Solve Obligations with program_simpl ; auto with *; lia. Next Obligation. - apply H. simpl. omega. + apply H. simpl. lia. Defined. Next Obligation. - case (le_lt_dec p i) ; intros. assert(i = p) by omega. subst. + case (le_lt_dec p i) ; intros. assert(i = p) by lia. subst. revert H0. clear_subset_proofs. auto. apply H. simpl. assumption. Defined. diff --git a/test-suite/bugs/closed/bug_3652.v b/test-suite/bugs/closed/bug_3652.v index 915cfcac27..b21a4d939c 100644 --- a/test-suite/bugs/closed/bug_3652.v +++ b/test-suite/bugs/closed/bug_3652.v @@ -1,6 +1,7 @@ Require Setoid. Require ZArith. Import ZArith. +Require Import Lia. Inductive Erasable(A : Set) : Prop := erasable: A -> Erasable A. @@ -87,12 +88,12 @@ Proof. unfold zotval. unfold mp2a1s. ring_simplify'. - replace 2 with (2*1) at 2 7 by omega. + replace 2 with (2*1) at 2 7 by lia. rewrite <-?Z.mul_assoc. rewrite <-?Z.mul_add_distr_l. rewrite <-Z.mul_sub_distr_l. - rewrite Z.mul_cancel_l by omega. - replace 1 with (2-1) at 1 by omega. + rewrite Z.mul_cancel_l by lia. + replace 1 with (2-1) at 1 by lia. rewrite Z.add_sub_assoc. rewrite Z.sub_cancel_r. Unshelve. diff --git a/test-suite/bugs/closed/bug_4280.v b/test-suite/bugs/closed/bug_4280.v index fd7897509e..31524e5dcf 100644 --- a/test-suite/bugs/closed/bug_4280.v +++ b/test-suite/bugs/closed/bug_4280.v @@ -1,11 +1,11 @@ -Require Import ZArith. +Require Import ZArith Lia. Require Import Eqdep_dec. Local Open Scope Z_scope. Definition t := { n: Z | n > 1 }. Program Definition two : t := 2. -Next Obligation. omega. Qed. +Next Obligation. lia. Qed. Program Definition t_eq (x y: t) : {x=y} + {x<>y} := if Z.eq_dec (proj1_sig x) (proj1_sig y) then left _ else right _. diff --git a/test-suite/bugs/closed/bug_4306.v b/test-suite/bugs/closed/bug_4306.v index f1bce04451..1ad84f9bb5 100644 --- a/test-suite/bugs/closed/bug_4306.v +++ b/test-suite/bugs/closed/bug_4306.v @@ -1,7 +1,7 @@ Require Import List. Require Import Arith. Require Import Recdef. -Require Import Omega. +Require Import Lia. Function foo (xys : (list nat * list nat)) {measure (fun xys => length (fst xys) + length (snd xys))} : list nat := match xys with @@ -14,9 +14,7 @@ Function foo (xys : (list nat * list nat)) {measure (fun xys => length (fst xys) end end. Proof. - intros; simpl; omega. - intros; simpl; omega. - intros; simpl; omega. + all: simpl; lia. Qed. Function bar (xys : (list nat * list nat)) {measure (fun xys => length (fst xys) + length (snd xys))} : list nat := diff --git a/test-suite/bugs/closed/bug_4456.v b/test-suite/bugs/closed/bug_4456.v index 7685552725..0c26d4de32 100644 --- a/test-suite/bugs/closed/bug_4456.v +++ b/test-suite/bugs/closed/bug_4456.v @@ -10,7 +10,7 @@ Tactic Notation "admit" := case proof_admitted. Require Coq.Program.Program. Require Coq.Strings.String. -Require Coq.omega.Omega. +Require Coq.micromega.Lia. Module Export Fiat_DOT_Common. Module Export Fiat. Module Common. @@ -489,7 +489,8 @@ Defined. End app. Import Coq.Lists.List. -Import Coq.omega.Omega. +Import Coq.Arith.Arith. +Import Coq.micromega.Lia. Import Fiat_DOT_Common.Fiat.Common. Import Fiat.Parsers.ContextFreeGrammar.Valid. Local Open Scope string_like_scope. @@ -585,8 +586,8 @@ Defined. | _ => discriminate | [ H : forall x, (_ * _)%type -> _ |- _ ] => specialize (fun x y z => H x (y, z)) | _ => solve [ eauto with nocore ] - | _ => solve [ apply Min.min_case_strong; omega ] - | _ => omega + | _ => solve [ apply Min.min_case_strong; lia ] + | _ => lia | [ H : production_valid (_::_) |- _ ] => let H' := fresh in pose proof H as H'; diff --git a/test-suite/bugs/closed/bug_4852.v b/test-suite/bugs/closed/bug_4852.v index e2e00f05d3..cdc8cd8b20 100644 --- a/test-suite/bugs/closed/bug_4852.v +++ b/test-suite/bugs/closed/bug_4852.v @@ -2,7 +2,7 @@ Require Import Coq.Lists.List. Import ListNotations. -Require Import Omega. +Require Import Lia. Definition wfi_lt := well_founded_induction_type Wf_nat.lt_wf. @@ -16,7 +16,7 @@ Tactic Notation "wfinduction" constr(term) "on" ne_hyp_list(Hs) "as" ident(H) := Hint Rewrite @app_comm_cons @app_assoc @app_length : app_rws. -Ltac solve_nat := autorewrite with app_rws in *; cbn in *; omega. +Ltac solve_nat := autorewrite with app_rws in *; cbn in *; lia. Notation "| x |" := (length x) (at level 11, no associativity, format "'|' x '|'"). diff --git a/test-suite/bugs/opened/bug_1596.v b/test-suite/bugs/opened/bug_1596.v index 27cb731151..89410047b2 100644 --- a/test-suite/bugs/opened/bug_1596.v +++ b/test-suite/bugs/opened/bug_1596.v @@ -1,7 +1,7 @@ Require Import Relations. Require Import FSets. Require Import Arith. -Require Import Omega. +Require Import Lia. Set Keyed Unification. @@ -147,14 +147,14 @@ Module MessageSpi. Lemma lt_trans : forall (x y z:t),(lt x y)->(lt y z)->(lt x z). unfold lt. induction x;destruct y;simpl;try tauto;destruct z;try tauto;intros. - omega. + lia. Qed. Lemma lt_not_eq : forall (x y:t),(lt x y)->~(eq x y). unfold eq;unfold lt. induction x;destruct y;simpl;try tauto;intro;red;intro;try (discriminate H0);injection H0;intros. - elim (lt_irrefl n);try omega. + elim (lt_irrefl n); lia. Qed. Definition compare : forall (x y:t),(Compare lt eq x y). diff --git a/test-suite/bugs/opened/bug_3357.v b/test-suite/bugs/opened/bug_3357.v index c479158877..f0e5d71811 100644 --- a/test-suite/bugs/opened/bug_3357.v +++ b/test-suite/bugs/opened/bug_3357.v @@ -1,4 +1,9 @@ -Notation D1 := (forall {T : Type} ( x : T ) , Type). +(* See discussion in #668 for whether manual implicit arguments should + be allowed in notations or not *) + +Set Warnings "+syntax". + +Fail Notation D1 := (forall {T : Type} ( x : T ) , Type). Definition DD1 ( A : forall {T : Type} (x : T), Type ) := A 1. Fail Definition DD1' ( A : D1 ) := A 1. (* Toplevel input, characters 32-33: diff --git a/test-suite/complexity/pattern.v b/test-suite/complexity/pattern.v new file mode 100644 index 0000000000..2101535be7 --- /dev/null +++ b/test-suite/complexity/pattern.v @@ -0,0 +1,38 @@ +(** Testing the performance of [pattern]. For not regressing on COQBUG(https://github.com/coq/coq/issues/11150) and COQBUG(https://github.com/coq/coq/issues/6502) *) +(* Expected time < 1.65s *) +(* reference: 0.673s after adjustment *) +Definition Let_In {A P} (v : A) (f : forall x : A, P x) : P v +:= let x := v in f x. + +Fixpoint big (a : nat) (sz : nat) : nat + := match sz with + | O => a + | S sz' => Let_In (a * a) (fun a' => big a' sz') + end. + +Ltac do_time n := + try ( + once (assert (exists e, e = big 1 n); + [ lazy -[big]; (*match goal with |- ?G => idtac G end;*) lazy [big]; + time pattern Nat.mul, S, O, (@Let_In nat (fun _ => nat)) + | ]); + fail). + +Ltac do_time_to n := + lazymatch (eval vm_compute in n) with + | O => idtac + | ?n' => do_time_to (Nat.div2 n'); idtac n'; do_time n' + end. + +Local Set Warnings "-abstract-large-number". + +(* Don't spend lots of time printing *) +Notation hide := (_ = _). + +Goal True. +Proof. + (* do_time_to 16384. *) (* should be linear, not quadratic *) + assert (exists e, e = big 1 16384). + lazy -[big]; (*match goal with |- ?G => idtac G end;*) lazy [big]. + Timeout 15 Time pattern Nat.mul, S, O, (@Let_In nat (fun _ => nat)). +Abort. diff --git a/test-suite/micromega/bug_11270.v b/test-suite/micromega/bug_11270.v new file mode 100644 index 0000000000..80abc6d0e9 --- /dev/null +++ b/test-suite/micromega/bug_11270.v @@ -0,0 +1,6 @@ +Require Import Psatz. +Theorem foo : forall a b, 1 <= S (a + a * S b). +Proof. +intros. +lia. +Qed. diff --git a/test-suite/modules/PO.v b/test-suite/modules/PO.v index be33104918..4c0ee1b5bd 100644 --- a/test-suite/modules/PO.v +++ b/test-suite/modules/PO.v @@ -35,8 +35,8 @@ Module Pair (X: PO) (Y: PO) <: PO. destruct p2. unfold le. intuition. - cutrewrite (t = t1). - cutrewrite (t0 = t2). + enough (t = t1) as ->. + enough (t0 = t2) as ->. reflexivity. info auto. diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v index 61ae4edbd1..398528de72 100644 --- a/test-suite/output/Fixpoint.v +++ b/test-suite/output/Fixpoint.v @@ -16,7 +16,7 @@ Check end in f 0. -Require Import ZArith_base Omega. +Require Import ZArith_base Lia. Open Scope Z_scope. Inductive even: Z -> Prop := @@ -35,13 +35,13 @@ Proof. fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1). intros. destruct H. - omega. + lia. apply odd_pos_even_pos in H. - omega. + lia. intros. destruct H. apply even_pos_odd_pos in H. - omega. + lia. Qed. CoInductive Inf := S { projS : Inf }. diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v index 668be1fdbc..357afb51eb 100644 --- a/test-suite/output/MExtraction.v +++ b/test-suite/output/MExtraction.v @@ -1,6 +1,6 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) (* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) @@ -56,10 +56,11 @@ Extract Constant Rinv => "fun x -> 1 / x". Recursive Extraction Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula Tauto.abst_form - ZMicromega.cnfZ ZMicromega.bound_problem_fr ZMicromega.Zeval_const QMicromega.cnfQ + ZMicromega.cnfZ ZMicromega.Zeval_const QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. + (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 32120a9674..799d310fa7 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -31,6 +31,8 @@ Let "x" e1 e2 : expr Let "x" e1 e2 : expr +Let "x" e1 e2 : list string + : list string myAnd1 True True : Prop r 2 3 diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index d3433949d1..26c7840a16 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -94,6 +94,10 @@ Coercion App : expr >-> Funclass. Check (Let "x" e1 e2). +Axiom free_vars :> expr -> list string. + +Check (Let "x" e1 e2) : list string. + End D. (* Fixing bugs reported by G. Gonthier in #9207 *) diff --git a/test-suite/output/print_ltac.out b/test-suite/output/print_ltac.out new file mode 100644 index 0000000000..952761acca --- /dev/null +++ b/test-suite/output/print_ltac.out @@ -0,0 +1,8 @@ +Ltac t1 := time "my tactic" idtac +Ltac t2 := let x := string:("my tactic") in + idtac + x +Ltac t3 := idtacstr "my tactic" +Ltac t4 x := match x with + | ?A => (A, A) + end diff --git a/test-suite/output/print_ltac.v b/test-suite/output/print_ltac.v new file mode 100644 index 0000000000..a992846791 --- /dev/null +++ b/test-suite/output/print_ltac.v @@ -0,0 +1,12 @@ +(* Testing of various things about Print Ltac *) +(* https://github.com/coq/coq/issues/10971 *) +Ltac t1 := time "my tactic" idtac. +Print Ltac t1. +Ltac t2 := let x := string:("my tactic") in idtac x. +Print Ltac t2. +Tactic Notation "idtacstr" string(str) := idtac str. +Ltac t3 := idtacstr "my tactic". +Print Ltac t3. +(* https://github.com/coq/coq/issues/9716 *) +Ltac t4 x := match x with ?A => constr:((A, A)) end. +Print Ltac t4. diff --git a/test-suite/output/relaxed_ambiguous_paths.out b/test-suite/output/relaxed_ambiguous_paths.out index dc793598a9..ac5a09bad7 100644 --- a/test-suite/output/relaxed_ambiguous_paths.out +++ b/test-suite/output/relaxed_ambiguous_paths.out @@ -7,6 +7,16 @@ New coercion path [ac; cd] : A >-> D is ambiguous with existing [ac] : A >-> C [bd] : B >-> D [cd] : C >-> D +File "stdin", line 26, characters 0-28: +Warning: +New coercion path [ab; bc] : A >-> C is ambiguous with existing +[ac] : A >-> C. [ambiguous-paths,typechecker] +[ac] : A >-> C +[ac; cd] : A >-> D +[ab] : A >-> B +[cd] : C >-> D +[bc] : B >-> C +[bc; cd] : B >-> D [B_A] : B >-> A [C_A] : C >-> A [D_B] : D >-> B @@ -21,7 +31,7 @@ New coercion path [ac; cd] : A >-> D is ambiguous with existing [D_A] : D >-> A [D_B] : D >-> B [D_C] : D >-> C -File "stdin", line 103, characters 0-86: +File "stdin", line 121, characters 0-86: Warning: New coercion path [D_C; C_A'] : D >-> A' is ambiguous with existing [D_B; B_A'] : D >-> A'. [ambiguous-paths,typechecker] @@ -34,3 +44,15 @@ New coercion path [D_C; C_A'] : D >-> A' is ambiguous with existing [D_A] : D >-> A [D_B] : D >-> B [D_C] : D >-> C +File "stdin", line 130, characters 0-47: +Warning: +New coercion path [unwrap_nat; wrap_nat] : NAT >-> NAT is not definitionally an identity function. +[ambiguous-paths,typechecker] +File "stdin", line 131, characters 0-64: +Warning: +New coercion path [unwrap_list; wrap_list] : LIST >-> LIST is not definitionally an identity function. +[ambiguous-paths,typechecker] +File "stdin", line 132, characters 0-51: +Warning: +New coercion path [unwrap_Type; wrap_Type] : TYPE >-> TYPE is not definitionally an identity function. +[ambiguous-paths,typechecker] diff --git a/test-suite/output/relaxed_ambiguous_paths.v b/test-suite/output/relaxed_ambiguous_paths.v index a4af27539c..41322045f2 100644 --- a/test-suite/output/relaxed_ambiguous_paths.v +++ b/test-suite/output/relaxed_ambiguous_paths.v @@ -16,6 +16,24 @@ End test1. Module test2. Section test2. + +Variable (A B C D : Type). +Variable (ab : A -> B) (bc : B -> C) (ac : A -> C) (cd : C -> D). + +Local Coercion ac : A >-> C. +Local Coercion cd : C >-> D. +Local Coercion ab : A >-> B. +Local Coercion bc : B >-> C. +(* `[ab; bc; cd], [ac; cd] : A >-> D` should not be shown as ambiguous paths *) +(* here because they are redundant with `[ab; bc], [ac] : A >-> C`. *) + +Print Graph. + +End test2. +End test2. + +Module test3. +Section test3. Variable (A : Type) (P Q : A -> Prop). Record B := { @@ -39,11 +57,11 @@ Local Coercion D_C (d : D) : C := Build_C (D_A d) (D_Q d). Print Graph. -End test2. -End test2. +End test3. +End test3. -Module test3. -Section test3. +Module test4. +Section test4. Variable (A : Type) (P Q : A -> Prop). @@ -71,11 +89,11 @@ Local Coercion D_C (d : D) : C true := Build_C true (D_A d) (D_Q d). Print Graph. -End test3. -End test3. +End test4. +End test4. -Module test4. -Section test4. +Module test5. +Section test5. Variable (A : Type) (P Q : A -> Prop). @@ -105,5 +123,18 @@ Local Coercion D_C (d : D) : C true := Print Graph. -End test4. -End test4. +End test5. +End test5. + +Module test6. +Record > NAT := wrap_nat { unwrap_nat :> nat }. +Record > LIST (T : Type) := wrap_list { unwrap_list :> list T }. +Record > TYPE := wrap_Type { unwrap_Type :> Type }. +End test6. + +Module test7. +Set Primitive Projections. +Record > NAT_prim := wrap_nat { unwrap_nat :> nat }. +Record > LIST_prim (T : Type) := wrap_list { unwrap_list :> list T }. +Record > TYPE_prim := wrap_Type { unwrap_Type :> Type }. +End test7. diff --git a/test-suite/success/CanonicalStructure.v b/test-suite/success/CanonicalStructure.v index b8cae47196..e6d674c1e6 100644 --- a/test-suite/success/CanonicalStructure.v +++ b/test-suite/success/CanonicalStructure.v @@ -29,3 +29,25 @@ Canonical Structure bool_test := mk_test (fun x y => x || y). Definition b := bool. Check (fun x : b => x != x). + +Inductive four := x0 | x1 | x2 | x3. +Structure local := MKL { l : four }. + +Section X. + Definition s0 := MKL x0. + #[local] Canonical Structure s0. + Check (refl_equal _ : l _ = x0). + + #[local] Canonical Structure s1 := MKL x1. + Check (refl_equal _ : l _ = x1). + + Local Canonical Structure s2 := MKL x2. + Check (refl_equal _ : l _ = x2). + +End X. +Fail Check (refl_equal _ : l _ = x0). +Fail Check (refl_equal _ : l _ = x1). +Fail Check (refl_equal _ : l _ = x2). +Check s0. +Check s1. +Check s2. diff --git a/test-suite/success/CompatCurrentFlag.v b/test-suite/success/CompatCurrentFlag.v index fd6101bf89..c86548440b 100644 --- a/test-suite/success/CompatCurrentFlag.v +++ b/test-suite/success/CompatCurrentFlag.v @@ -1,3 +1,3 @@ -(* -*- coq-prog-args: ("-compat" "8.11") -*- *) +(* -*- coq-prog-args: ("-compat" "8.12") -*- *) (** Check that the current compatibility flag actually requires the relevant modules. *) -Import Coq.Compat.Coq811. +Import Coq.Compat.Coq812. diff --git a/test-suite/success/CompatOldFlag.v b/test-suite/success/CompatOldFlag.v index f774cef44f..a1c1209db6 100644 --- a/test-suite/success/CompatOldFlag.v +++ b/test-suite/success/CompatOldFlag.v @@ -1,5 +1,5 @@ -(* -*- coq-prog-args: ("-compat" "8.9") -*- *) +(* -*- coq-prog-args: ("-compat" "8.10") -*- *) (** Check that the current-minus-two compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq812. Import Coq.Compat.Coq811. Import Coq.Compat.Coq810. -Import Coq.Compat.Coq89. diff --git a/test-suite/success/CompatOldOldFlag.v b/test-suite/success/CompatOldOldFlag.v new file mode 100644 index 0000000000..dd259988ac --- /dev/null +++ b/test-suite/success/CompatOldOldFlag.v @@ -0,0 +1,6 @@ +(* -*- coq-prog-args: ("-compat" "8.9") -*- *) +(** Check that the current-minus-three compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq812. +Import Coq.Compat.Coq811. +Import Coq.Compat.Coq810. +Import Coq.Compat.Coq89. diff --git a/test-suite/success/CompatPreviousFlag.v b/test-suite/success/CompatPreviousFlag.v index 1c5ccc1a92..00f4747e3e 100644 --- a/test-suite/success/CompatPreviousFlag.v +++ b/test-suite/success/CompatPreviousFlag.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-compat" "8.10") -*- *) +(* -*- coq-prog-args: ("-compat" "8.11") -*- *) (** Check that the current-minus-one compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq812. Import Coq.Compat.Coq811. -Import Coq.Compat.Coq810. diff --git a/test-suite/success/LocalDefinition.v b/test-suite/success/LocalDefinition.v index 22fb09526d..d944036112 100644 --- a/test-suite/success/LocalDefinition.v +++ b/test-suite/success/LocalDefinition.v @@ -26,28 +26,12 @@ Module TestAdmittedVisibility. Fail Check d2. End TestAdmittedVisibility. -(* Test consistent behavior of Local Definition wrt automatic declaration of instances *) - Module TestVariableAsInstances. - Module Test1. - Set Typeclasses Axioms Are Instances. - Class U. - Local Parameter b : U. - Definition testU := _ : U. (* _ resolved *) - - Class T. - Variable a : T. (* warned to be the same as "Local Parameter" *) - Definition testT := _ : T. (* _ resolved *) - End Test1. - - Module Test2. - Unset Typeclasses Axioms Are Instances. - Class U. - Local Parameter b : U. - Fail Definition testU := _ : U. (* _ unresolved *) + Class U. + Local Parameter b : U. + Fail Definition testU := _ : U. (* _ unresolved *) - Class T. - Variable a : T. (* warned to be the same as "Local Parameter" thus should not be an instance *) - Fail Definition testT := _ : T. (* used to succeed *) - End Test2. + Class T. + Variable a : T. (* warned to be the same as "Local Parameter" thus should not be an instance *) + Fail Definition testT := _ : T. (* used to succeed *) End TestVariableAsInstances. diff --git a/test-suite/success/NotationDeprecation.v b/test-suite/success/NotationDeprecation.v index 96814a1b97..60d40d3d12 100644 --- a/test-suite/success/NotationDeprecation.v +++ b/test-suite/success/NotationDeprecation.v @@ -3,19 +3,11 @@ Module Syndefs. #[deprecated(since = "8.9", note = "Do not use.")] Notation foo := Prop. -Notation bar := Prop (compat "8.9"). - -Fail -#[deprecated(since = "8.9", note = "Do not use.")] -Notation zar := Prop (compat "8.9"). - Check foo. -Check bar. Set Warnings "+deprecated". Fail Check foo. -Fail Check bar. End Syndefs. @@ -24,19 +16,11 @@ Module Notations. #[deprecated(since = "8.9", note = "Do not use.")] Notation "!!" := Prop. -Notation "##" := Prop (compat "8.9"). - -Fail -#[deprecated(since = "8.9", note = "Do not use.")] -Notation "**" := Prop (compat "8.9"). - Check !!. -Check ##. Set Warnings "+deprecated". Fail Check !!. -Fail Check ##. End Notations. @@ -45,18 +29,10 @@ Module Infix. #[deprecated(since = "8.9", note = "Do not use.")] Infix "!!" := plus (at level 1). -Infix "##" := plus (at level 1, compat "8.9"). - -Fail -#[deprecated(since = "8.9", note = "Do not use.")] -Infix "**" := plus (at level 1, compat "8.9"). - Check (_ !! _). -Check (_ ## _). Set Warnings "+deprecated". Fail Check (_ !! _). -Fail Check (_ ## _). End Infix. diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v index d047f7560e..aa439fae12 100644 --- a/test-suite/success/Notations2.v +++ b/test-suite/success/Notations2.v @@ -165,3 +165,10 @@ Notation "# x ## t & u" := ((fun x => (x,t)),(fun x => (x,u))) (at level 0, x pa Check fun y : nat => # (x,z) ## y & y. End M17. + +Module Bug10750. + +Notation "#" := 0 (only printing). +Print Visibility. + +End Bug10750. diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v index 6370cab6b2..4fac798f76 100644 --- a/test-suite/success/RecTutorial.v +++ b/test-suite/success/RecTutorial.v @@ -1210,7 +1210,3 @@ Proof. constructor. trivial. Qed. - - - - diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 736d05fefc..3f96bf2c35 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -241,13 +241,8 @@ Module IterativeDeepening. End IterativeDeepening. -Module AxiomsAreInstances. - Set Typeclasses Axioms Are Instances. - Class TestClass1 := {}. - Axiom testax1 : TestClass1. - Definition testdef1 : TestClass1 := _. +Module AxiomsAreNotInstances. - Unset Typeclasses Axioms Are Instances. Class TestClass2 := {}. Axiom testax2 : TestClass2. Fail Definition testdef2 : TestClass2 := _. @@ -256,4 +251,4 @@ Module AxiomsAreInstances. Existing Instance testax2. Definition testdef2 : TestClass2 := _. -End AxiomsAreInstances. +End AxiomsAreNotInstances. diff --git a/test-suite/success/cofixtac.v b/test-suite/success/cofixtac.v new file mode 100644 index 0000000000..ae75ee770f --- /dev/null +++ b/test-suite/success/cofixtac.v @@ -0,0 +1,10 @@ +CoInductive stream := +| C : content -> stream +with content := +| D : nat -> stream -> content. + +Lemma one : stream. +cofix c with (d : content). +- constructor. apply d. +- constructor. exact 1. apply c. +Defined. diff --git a/test-suite/success/implicit.v b/test-suite/success/implicit.v index 23853890d8..ecaaedca53 100644 --- a/test-suite/success/implicit.v +++ b/test-suite/success/implicit.v @@ -124,3 +124,36 @@ Inductive I3 {A} (x:=0) (a:A) : forall {n:nat}, Prop := (* Check global implicit declaration over ref not in section *) Section D. Global Arguments eq [A] _ _. End D. + +(* Check local manual implicit arguments *) +(* Gives a warning and make the second x anonymous *) +(* Isn't the name "arg_1" a bit fragile though? *) + +Check fun f : forall {x:nat} {x:bool} (x:unit), unit => f (x:=1) (arg_2:=true) tt. + +(* Check the existence of a shadowing warning *) + +Set Warnings "+syntax". +Fail Check fun f : forall {x:nat} {x:bool} (x:unit), unit => f (x:=1) (arg_2:=true) tt. +Set Warnings "syntax". + +(* Test failure when implicit arguments are mentioned in subterms + which are not types of variables *) + +Set Warnings "+syntax". +Fail Check (id (forall {a}, a)). +Set Warnings "syntax". + +(* Miscellaneous tests *) + +Check let f := fun {x:nat} y => y=true in f false. + +(* Isn't the name "arg_1" a bit fragile, here? *) + +Check fun f : forall {_:nat}, nat => f (arg_1:=0). + +(* This test was wrongly warning/failing at some time *) + +Set Warnings "+syntax". +Check id (fun x => let f c {a} (b:a=a) := b in f true (eq_refl 0)). +Set Warnings "syntax". diff --git a/test-suite/success/specialize.v b/test-suite/success/specialize.v index f12db8b081..1b04594290 100644 --- a/test-suite/success/specialize.v +++ b/test-suite/success/specialize.v @@ -109,6 +109,28 @@ match goal with H:_ |- _ => clear H end. match goal with H:_ |- _ => exact H end. Qed. +(* let ins should be supported in the type of the specialized hypothesis *) +Axiom foo: forall (m1 m2: nat), let n := 2 * m1 in m1 = m2 -> False. +Goal False. + pose proof foo as P. + assert (2 = 2) as A by reflexivity. + specialize P with (1 := A). + assumption. +Qed. + +(* Another more subtle test on letins: they should not interfere with foralls. *) +Goal forall (P: forall y:nat, + forall A (zz:A), + let a := zz in + let x := 1 in + forall n : y = x, + n = n), + True. + intros P. + specialize P with (zz := @eq_refl _ 2). + constructor. +Qed. + (* Test specialize as *) Goal (forall x, x=0) -> 1=0. diff --git a/test-suite/tools/update-compat/run.sh b/test-suite/tools/update-compat/run.sh index 7ff5571ffb..61273c4f37 100755 --- a/test-suite/tools/update-compat/run.sh +++ b/test-suite/tools/update-compat/run.sh @@ -6,4 +6,4 @@ SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" # we assume that the script lives in test-suite/tools/update-compat/, # and that update-compat.py lives in dev/tools/ cd "${SCRIPT_DIR}/../../.." -dev/tools/update-compat.py --assert-unchanged --release || exit $? +dev/tools/update-compat.py --assert-unchanged --master || exit $? diff --git a/theories/Compat/Coq811.v b/theories/Compat/Coq811.v index 4a9a041d4e..4d28e4f708 100644 --- a/theories/Compat/Coq811.v +++ b/theories/Compat/Coq811.v @@ -9,3 +9,5 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.11 *) + +Require Export Coq.Compat.Coq812. diff --git a/theories/Compat/Coq812.v b/theories/Compat/Coq812.v new file mode 100644 index 0000000000..5d2fbc56d5 --- /dev/null +++ b/theories/Compat/Coq812.v @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Compatibility file for making Coq act similar to Coq v8.12 *) diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index 9aed952183..d9e89d6b91 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -72,7 +72,7 @@ - [[Geuvers01]] H. Geuvers, "Inconsistency of Classical Logic in Type Theory", 2001, revised 2007 - (see {{http://www.cs.ru.nl/~herman/PUBS/newnote.ps.gz}}). + (see external link {{http://www.cs.ru.nl/~herman/PUBS/newnote.ps.gz}}). *) diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v index e777f10411..e3ff4979a9 100644 --- a/theories/MSets/MSetEqProperties.v +++ b/theories/MSets/MSetEqProperties.v @@ -17,7 +17,9 @@ [mem x s=true] instead of [In x s], [equal s s'=true] instead of [Equal s s'], etc. *) -Require Import MSetProperties Zerob Sumbool Omega DecidableTypeEx. +Require Import MSetProperties Zerob Sumbool Lia DecidableTypeEx. +Require FSetEqProperties. + Module WEqPropertiesOn (Import E:DecidableType)(M:WSetsOn E). Module Import MP := WPropertiesOn E M. @@ -845,19 +847,19 @@ unfold sum. intros f g Hf Hg. assert (fc : compat_opL (fun x:elt =>plus (f x))) by (repeat red; intros; rewrite Hf; auto). -assert (ft : transposeL (fun x:elt =>plus (f x))) by (red; intros; omega). +assert (ft : transposeL (fun x:elt =>plus (f x))) by (red; intros; lia). assert (gc : compat_opL (fun x:elt => plus (g x))) by (repeat red; intros; rewrite Hg; auto). -assert (gt : transposeL (fun x:elt =>plus (g x))) by (red; intros; omega). +assert (gt : transposeL (fun x:elt =>plus (g x))) by (red; intros; lia). assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))) by (repeat red; intros; rewrite Hf,Hg; auto). -assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))) by (red; intros; omega). +assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))) by (red; intros; lia). intros s;pattern s; apply set_rec. intros. rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H). rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H). rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto. -intros. do 3 (rewrite fold_add; auto with *). +intros. do 3 (rewrite fold_add by auto with fset). lia. do 3 rewrite fold_empty;auto. Qed. @@ -869,7 +871,7 @@ assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))) by (repeat red; intros; rewrite Hf; auto). assert (ct : transposeL (fun x => plus (if f x then 1 else 0))) by - (red; intros; omega). + (red; intros; lia). intros s;pattern s; apply set_rec. intros. change elt with E.t. @@ -919,7 +921,7 @@ Lemma sum_compat : forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. intros. unfold sum; apply (@fold_compat _ (@Logic.eq nat)); - repeat red; auto with *. + repeat red; auto with *; lia. Qed. End Sum. diff --git a/theories/Numbers/Natural/Abstract/NGcd.v b/theories/Numbers/Natural/Abstract/NGcd.v index e159341af3..f05cd985cc 100644 --- a/theories/Numbers/Natural/Abstract/NGcd.v +++ b/theories/Numbers/Natural/Abstract/NGcd.v @@ -151,6 +151,94 @@ Proof. left. now apply gcd_bezout_pos. Qed. +(** Bezout on natural numbers commutes *) + +Theorem bezout_comm : forall a b g, + b ~= 0 -> Bezout a b g -> Bezout b a g. +Proof. + intros * Hbz (u & v & Huv). + destruct (eq_0_gt_0_cases a) as [Haz| Haz]. + -rewrite Haz in Huv |-*. + rewrite mul_0_r in Huv; symmetry in Huv. + apply eq_add_0 in Huv. + rewrite (proj1 Huv). + now exists 0, 0; nzsimpl. + -apply neq_0_lt_0 in Haz. + destruct (lt_trichotomy (u / b) (v / a)) as [Hm| Hm]. + +apply lt_le_incl in Hm. + remember (v / a + 1) as k eqn:Hk. + exists (k * a - v), (k * b - u). + do 2 rewrite mul_sub_distr_r. + rewrite Huv. + rewrite (add_comm _ (v * b)). + rewrite sub_add_distr. + rewrite add_sub_assoc. + *rewrite add_comm, add_sub. + now rewrite mul_shuffle0. + *apply (add_le_mono_r _ _ (v * b)). + rewrite <- Huv. + rewrite sub_add. + --apply mul_le_mono_r. + rewrite Hk. + specialize (div_mod u b Hbz) as H1. + rewrite mul_add_distr_r, mul_1_l, mul_comm. + rewrite H1 at 1. + apply add_le_mono. + ++now apply mul_le_mono_l. + ++apply lt_le_incl. + apply mod_bound_pos. + **apply le_0_l. + **now apply neq_0_lt_0. + --rewrite mul_shuffle0. + apply mul_le_mono_r. + rewrite Hk. + specialize (div_mod v a Haz) as H1. + rewrite mul_add_distr_r, mul_1_l, mul_comm. + rewrite H1 at 1. + apply add_le_mono_l. + apply lt_le_incl. + apply mod_bound_pos. + ++apply le_0_l. + ++now apply neq_0_lt_0. + +remember (u / b + 1) as k eqn:Hk. + exists (k * a - v), (k * b - u). + do 2 rewrite mul_sub_distr_r. + rewrite Huv. + rewrite (add_comm _ (v * b)). + rewrite sub_add_distr. + rewrite add_sub_assoc. + *rewrite add_comm, add_sub. + now rewrite mul_shuffle0. + *apply (add_le_mono_r _ _ (v * b)). + rewrite sub_add. + --rewrite <- Huv. + apply mul_le_mono_r. + rewrite Hk. + specialize (div_mod u b Hbz) as H1. + rewrite mul_add_distr_r, mul_1_l, mul_comm. + rewrite H1 at 1. + apply add_le_mono_l. + apply lt_le_incl. + apply mod_bound_pos. + ++apply le_0_l. + ++now apply neq_0_lt_0. + --rewrite mul_shuffle0. + apply mul_le_mono_r. + rewrite Hk. + specialize (div_mod v a Haz) as H1. + rewrite mul_add_distr_r, mul_1_l, mul_comm. + rewrite H1 at 1. + apply add_le_mono. + ++apply mul_le_mono_l. + destruct Hm as [Hm| Hm]. + **now rewrite Hm. + **now apply lt_le_incl. + ++apply lt_le_incl. + apply mod_bound_pos. + **apply le_0_l. + **now apply neq_0_lt_0. +Qed. + Lemma gcd_mul_mono_l : forall n m p, gcd (p * n) (p * m) == p * gcd n m. Proof. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index b09a7d3264..c5165662e5 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -257,7 +257,6 @@ Ltac blocked t := block_goal ; t ; unblock_goal. be used by the [equations] resolver. It is especially useful to register the dependent elimination principles for things in [Prop] which are not automatically generated. *) -#[universes(template)] Class DependentEliminationPackage (A : Type) := { elim_type : Type ; elim : elim_type }. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index 5b3d6ea30e..b1f0d9bc39 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Export Rbase. +Require Import Rdefinitions Raxioms RIneq. Require Export QArith_base. (** Injection of rational numbers into real numbers. *) @@ -48,7 +48,7 @@ set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); set (Y2 := IZR (Zpos y2)) in *. assert ((X1 * Y2)%R = (Y1 * X2)%R). unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. - apply IZR_eq; auto. +f_equal; auto. clear H. field_simplify_eq; auto. rewrite H0; ring. diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index cbf90c5adb..0cad621692 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Rbase. +Require Import Rdefinitions Raxioms RIneq. Require Import Rbasic_fun. Require Import Even. Require Import Div2. @@ -85,7 +85,7 @@ Proof. assert (H1 := le_INR _ _ H). do 2 rewrite mult_INR in H1. apply Rmult_le_reg_l with (INR 2). - replace (INR 2) with 2; [ prove_sup0 | reflexivity ]. + apply lt_0_INR. apply Nat.lt_0_2. assumption. Qed. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 229e6018ca..b0d7b26a86 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -19,7 +19,7 @@ Require Export Raxioms. Require Import Rpow_def. Require Import Zpower. Require Export ZArithRing. -Require Import Lia. +Require Import Ztac. Require Export RealField. Local Open Scope Z_scope. @@ -1875,7 +1875,7 @@ Lemma eq_IZR : forall n m:Z, IZR n = IZR m -> n = m. Proof. intros z1 z2 H; generalize (Rminus_diag_eq (IZR z1) (IZR z2) H); rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0); - intro; lia. + apply Zminus_eq. Qed. (**********) @@ -1913,21 +1913,24 @@ Qed. Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m. Proof. intros m n H; apply Rnot_lt_ge; red; intro. - generalize (lt_IZR m n H0); intro; lia. + generalize (lt_IZR m n H0); intro. + slia H H1. Qed. Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m. Proof. intros m n H; apply Rnot_gt_le; red; intro. - unfold Rgt in H0; generalize (lt_IZR n m H0); intro; lia. + unfold Rgt in H0; generalize (lt_IZR n m H0); intro. + slia H H1. Qed. Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m. Proof. intros m n H; cut (m <= n)%Z. intro H0; elim (IZR_le m n H0); intro; auto. - generalize (eq_IZR m n H1); intro; exfalso; lia. - lia. + generalize (eq_IZR m n H1); intro; exfalso. + slia H H3. + normZ. slia H H0. Qed. Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 <> IZR z2. @@ -1954,7 +1957,7 @@ Lemma one_IZR_r_R1 : forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m. Proof. intros r z x [H1 H2] [H3 H4]. - cut ((z - x)%Z = 0%Z). lia. + apply Zminus_eq. apply one_IZR_lt1. rewrite <- Z_R_minus; split. replace (-1) with (r - (r + 1)). diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index 5f0747d869..d9820f9444 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -13,8 +13,8 @@ (* *) (**********************************************************) -Require Import Rbase. -Require Import Lia. +Require Import Rdefinitions Raxioms RIneq. +Require Import Ztac. Local Open Scope R_scope. (*********************************************************) @@ -60,7 +60,7 @@ Proof. apply lt_IZR in H1. rewrite <- minus_IZR in H2. apply le_IZR in H2. - lia. + normZ. slia H2 HZ. slia H1 HZ. Qed. (**********) @@ -229,8 +229,8 @@ Proof. rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H. rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H; generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); - intros; clear H H0; unfold Int_part at 1; - lia. + intros; clear H H0; unfold Int_part at 1. + normZ. slia H HZ. slia H0 HZ. Qed. (**********) @@ -322,8 +322,8 @@ Proof. generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H); intro; clear H; generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0); - intros; clear H0 H1; unfold Int_part at 1; - lia. + intros; clear H0 H1; unfold Int_part at 1. + normZ. slia H HZ. slia H0 HZ. Qed. (**********) @@ -437,7 +437,8 @@ Proof. rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0; rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0; generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0); - intro; clear H H0; unfold Int_part at 1; lia. + intro; clear H H0; unfold Int_part at 1. + normZ. slia H HZ. slia H0 HZ. Qed. (**********) @@ -498,8 +499,8 @@ Proof. rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1; generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1); - intro; clear H0 H1; unfold Int_part at 1; - lia. + intro; clear H0 H1; unfold Int_part at 1. + normZ. slia H HZ. slia H0 HZ. Qed. (**********) diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index 1a74582b71..e6c6e8bf48 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Rbase. +Require Import Rdefinitions Raxioms RIneq. Require Import Rbasic_fun. Local Open Scope R_scope. diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index efca826077..7e59639dd4 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -13,7 +13,7 @@ (* *) (*********************************************************) -Require Import Rbase. +Require Import Rdefinitions Raxioms RIneq. Require Import R_Ifp. Local Open Scope R_scope. diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index 7f9e019c5b..a63df38808 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -17,7 +17,7 @@ (********************************************************) Require Export ArithRing. -Require Import Rbase. +Require Import Rdefinitions Raxioms RIneq. Require Export Rpow_def. Require Export R_Ifp. Require Export Rbasic_fun. @@ -25,8 +25,8 @@ Require Export R_sqr. Require Export SplitAbsolu. Require Export SplitRmult. Require Export ArithProp. -Require Import Lia. Require Import Zpower. +Require Import Ztac. Local Open Scope nat_scope. Local Open Scope R_scope. @@ -122,7 +122,7 @@ Hint Resolve pow_lt: real. Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n. Proof. intros x n; elim n; simpl; auto with real. - intros H' H'0; exfalso; lia. + intros H' H'0; exfalso. apply (Nat.lt_irrefl 0); assumption. intros n0; case n0. simpl; rewrite Rmult_1_r; auto. intros n1 H' H'0 H'1. @@ -262,14 +262,14 @@ Proof. elim (IZN (up (b * / (Rabs x - 1))) H2); intros; exists x0; apply (Rge_trans (INR x0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))). - rewrite INR_IZR_INZ; apply IZR_ge; lia. + rewrite INR_IZR_INZ; apply IZR_ge. normZ. slia H3 H5. unfold Rge; left; assumption. exists 0%nat; apply (Rge_trans (INR 0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))). - rewrite INR_IZR_INZ; apply IZR_ge; simpl; lia. + rewrite INR_IZR_INZ; apply IZR_ge; simpl. normZ. slia H2 H3. unfold Rge; left; assumption. - lia. + apply Z.le_ge_cases. Qed. Lemma pow_ne_zero : forall n:nat, n <> 0%nat -> 0 ^ n = 0. @@ -745,7 +745,8 @@ Proof. - now simpl; rewrite Rmult_1_l. - now rewrite <- !pow_powerRZ, Rpow_mult_distr. - destruct Hmxy as [H|H]. - + assert(m = 0) as -> by now lia. + + assert(m = 0) as -> by + (destruct n; [assumption| subst; simpl in H; lia_contr]). now rewrite <- Hm, Rmult_1_l. + assert(x0 <> 0)%R by now intros ->; apply H; rewrite Rmult_0_l. assert(y0 <> 0)%R by now intros ->; apply H; rewrite Rmult_0_r. @@ -808,7 +809,7 @@ Proof. ring. rewrite Rmult_plus_distr_r; rewrite Hrecn; cut ((n + 1)%nat = S n). intro H; rewrite H; simpl; ring. - lia. + apply Nat.add_1_r. Qed. Lemma sum_f_R0_triangle : diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v index be2b5a73f3..cad1525580 100644 --- a/theories/Reals/SplitRmult.v +++ b/theories/Reals/SplitRmult.v @@ -11,7 +11,7 @@ (*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*) -Require Import Rbase. +Require Import Rdefinitions Raxioms RIneq. Ltac split_Rmult := match goal with diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v index 8e8f05dabc..4feeb9bfff 100644 --- a/theories/Sorting/PermutEq.v +++ b/theories/Sorting/PermutEq.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Relations Setoid SetoidList List Multiset PermutSetoid Permutation Omega. +Require Import Relations Setoid SetoidList List Multiset PermutSetoid Permutation Lia. Set Implicit Arguments. @@ -85,7 +85,7 @@ Section Perm. rewrite multiplicity_NoDup in H, H0. generalize (H a) (H0 a) (H1 a); clear H H0 H1. do 2 rewrite multiplicity_In. - destruct 3; omega. + destruct 3; lia. Qed. (** Permutation is compatible with In. *) diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v index 90c82b677b..234063f14f 100644 --- a/theories/Sorting/PermutSetoid.v +++ b/theories/Sorting/PermutSetoid.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Omega Relations Multiset SetoidList. +Require Import Lia Relations Multiset SetoidList. (** This file is deprecated, use [Permutation.v] instead. @@ -189,7 +189,7 @@ Lemma permut_conv_inv : forall e l1 l2, permutation (e :: l1) (e :: l2) -> permutation l1 l2. Proof. intros e l1 l2; unfold permutation, meq; simpl; intros H a; - generalize (H a); apply plus_reg_l. + generalize (H a); lia. Qed. Lemma permut_app_inv1 : @@ -199,9 +199,7 @@ Proof. intros H a; generalize (H a); clear H. do 2 rewrite list_contents_app. simpl. - intros; apply plus_reg_l with (multiplicity (list_contents l) a). - rewrite plus_comm; rewrite H; rewrite plus_comm. - trivial. + lia. Qed. (** we can use [multiplicity] to define [InA] and [NoDupA]. *) @@ -220,8 +218,7 @@ Proof. intros H a; generalize (H a); clear H. do 2 rewrite list_contents_app. simpl. - intros; apply plus_reg_l with (multiplicity (list_contents l) a). - trivial. + lia. Qed. Lemma permut_remove_hd_eq : @@ -230,13 +227,9 @@ Lemma permut_remove_hd_eq : Proof. unfold permutation, meq; simpl; intros l l1 l2 a b Heq H a0. specialize H with a0. - rewrite list_contents_app in *; simpl in *. - apply plus_reg_l with (if eqA_dec a a0 then 1 else 0). - rewrite H; clear H. - symmetry; rewrite plus_comm, <- ! plus_assoc; f_equal. - rewrite plus_comm. - destruct (eqA_dec a a0) as [Ha|Ha]; rewrite Heq in Ha; - decide (eqA_dec b a0) with Ha; reflexivity. + rewrite list_contents_app in *. simpl in *. + destruct (eqA_dec a _) as [Ha|Ha]; rewrite Heq in Ha; revert H; + decide (eqA_dec b a0) with Ha; lia. Qed. Lemma permut_remove_hd : @@ -342,9 +335,9 @@ Proof. rewrite multiplicity_InA. specialize (H a). rewrite if_eqA_refl in H. - clear IHl; omega. + clear IHl; lia. rewrite IHl; intros. - specialize (H a0). omega. + specialize (H a0). lia. Qed. (** Permutation is compatible with InA. *) @@ -395,14 +388,14 @@ Proof. apply permut_length_1. red; red; intros. specialize (P a). simpl in *. - rewrite (@if_eqA_rewrite_l a1 a2 a) in P by auto. omega. + rewrite (@if_eqA_rewrite_l a1 a2 a) in P by auto. lia. right. inversion_clear H0; [|inversion H]. split; auto. apply permut_length_1. red; red; intros. specialize (P a); simpl in *. - rewrite (@if_eqA_rewrite_l a1 b2 a) in P by auto. omega. + rewrite (@if_eqA_rewrite_l a1 b2 a) in P by auto. lia. Qed. (** Permutation is compatible with length. *) @@ -434,7 +427,7 @@ Proof. rewrite multiplicity_NoDupA in H, H0. generalize (H a) (H0 a) (H1 a); clear H H0 H1. do 2 rewrite multiplicity_InA. - destruct 3; omega. + destruct 3; lia. Qed. End Permut. diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index f8f046ae75..3e8cafc417 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -34,7 +34,7 @@ let rec print_prefix_list sep = function let usage_coq_makefile () = output_string stderr "Usage summary:\ \n\ -\ncoq_makefile .... [file.v] ... [file.ml[i4]?] ... [file.ml{lib,pack}]\ +\ncoq_makefile .... [file.v] ... [file.ml[ig]?] ... [file.ml{lib,pack}]\ \n ... [any] ... [-extra[-phony] result dependencies command]\ \n ... [-I dir] ... [-R physicalpath logicalpath]\ \n ... [-Q physicalpath logicalpath] ... [VARIABLE = value]\ @@ -45,7 +45,7 @@ let usage_coq_makefile () = \nFull list of options:\ \n\ \n[file.v]: Coq file to be compiled\ -\n[file.ml[i4]?]: Objective Caml file to be compiled\ +\n[file.ml[ig]?]: Objective Caml file to be compiled\ \n[file.ml{lib,pack}]: ocamlbuild-style file that describes a Objective Caml\ \n library/module\ \n[any] : subdirectory that should be \"made\" and has a Makefile itself\ diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 717c06a868..ae1e1c6ed3 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -30,7 +30,7 @@ let build_table l = let is_keyword = build_table - [ "About"; "AddPath"; "Axiom"; "Abort"; "Chapter"; "Check"; "Coercion"; "Compute"; "CoFixpoint"; + [ "About"; "Axiom"; "Abort"; "Chapter"; "Check"; "Coercion"; "Compute"; "CoFixpoint"; "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example"; "Export"; "Fact"; "Fix"; "Fixpoint"; "From"; "Function"; "Generalizable"; "Global"; "Grammar"; "Guarded"; "Goal"; "Hint"; "Debug"; "On"; diff --git a/topbin/dune b/topbin/dune index 7b77826216..46052c81e5 100644 --- a/topbin/dune +++ b/topbin/dune @@ -26,6 +26,7 @@ (package coq) (modules coqc_bin) (libraries coq.toplevel) + (modes native byte) ; Adding -ccopt -flto to links options could be interesting, however, ; it doesn't work on Windows (link_flags -linkall)) diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 8dd1c45024..5326ce6114 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -174,12 +174,6 @@ let add_vo_include opts unix_path coq_path implicit = let add_vo_require opts d p export = { opts with pre = { opts.pre with vo_requires = (d, p, export) :: opts.pre.vo_requires }} -let add_compat_require opts v = - match v with - | Flags.V8_9 -> add_vo_require opts "Coq.Compat.Coq89" None (Some false) - | Flags.V8_10 -> add_vo_require opts "Coq.Compat.Coq810" None (Some false) - | Flags.Current -> add_vo_require opts "Coq.Compat.Coq811" None (Some false) - let add_load_vernacular opts verb s = { opts with pre = { opts.pre with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.pre.load_vernacular_list }} @@ -273,6 +267,18 @@ let get_native_name s = Nativelib.output_dir; Library.native_name_from_filename s] with _ -> "" +let get_compat_file = function + | "8.12" -> "Coq.Compat.Coq812" + | "8.11" -> "Coq.Compat.Coq811" + | "8.10" -> "Coq.Compat.Coq810" + | "8.9" -> "Coq.Compat.Coq89" + | ("8.8" | "8.7" | "8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> + CErrors.user_err ~hdr:"get_compat_file" + Pp.(str "Compatibility with version " ++ str s ++ str " not supported.") + | s -> + CErrors.user_err ~hdr:"get_compat_file" + Pp.(str "Unknown compatibility version \"" ++ str s ++ str "\".") + let to_opt_key = Str.(split (regexp " +")) let parse_option_set opt = @@ -378,9 +384,7 @@ let parse_args ~help ~init arglist : t * string list = |"-worker-id" -> set_worker_id opt (next ()); oval |"-compat" -> - let v = G_vernac.parse_compat_version (next ()) in - Flags.compat_version := v; - add_compat_require oval v + add_vo_require oval (get_compat_file (next ())) None (Some false) |"-exclude-dir" -> System.exclude_directory (next ()); oval diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 309f5b657a..46dd693155 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -155,12 +155,20 @@ let print_style_tags opts = let () = List.iter iter tags in flush_all () +let init_setup = function + | None -> Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); + | Some s -> Envars.set_user_coqlib s + let print_query opts = function | PrintVersion -> Usage.version () | PrintMachineReadableVersion -> Usage.machine_readable_version () - | PrintWhere -> print_endline (Envars.coqlib ()) + | PrintWhere -> + let () = init_setup opts.config.coqlib in + print_endline (Envars.coqlib ()) | PrintHelp h -> Usage.print_usage stderr h - | PrintConfig -> Envars.print_config stdout Coq_config.all_src_dirs + | PrintConfig -> + let () = init_setup opts.config.coqlib in + Envars.print_config stdout Coq_config.all_src_dirs | PrintTags -> print_style_tags opts.config (** GC tweaking *) @@ -188,10 +196,6 @@ let init_gc () = Gc.minor_heap_size = 33554432; (* 4M *) Gc.space_overhead = 120} -let init_setup = function - | None -> Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); - | Some s -> Envars.set_user_coqlib s - let init_process () = (* Coq's init process, phase 1: OCaml parameters, basic structures, and IO @@ -256,11 +260,11 @@ type ('a,'b) custom_toplevel = let init_toplevel custom = let () = init_process () in let opts, customopts = init_parse custom.parse_extra custom.help custom.opts in - let () = init_setup opts.config.coqlib in (* Querying or running? *) match opts.main with | Queries q -> List.iter (print_query opts) q; exit 0 | Run -> + let () = init_setup opts.config.coqlib in let customstate = init_execution opts (custom.init customopts) in opts, customopts, customstate diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 310ea62a1d..f954915cf8 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -430,7 +430,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = end (* used in the bool -> leb side *) -let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = +let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let open EConstr in let avoid = Array.of_list aavoid in let do_arg sigma hd v offset = @@ -658,7 +658,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). if GlobRef.equal (GlobRef.IndRef indeq) Coqlib.(lib_ref "core.eq.type") then Tacticals.New.tclTHEN - (do_replace_bl mode bl_scheme_key ind + (do_replace_bl bl_scheme_key ind (!avoid) nparrec (ca.(2)) (ca.(1))) diff --git a/vernac/canonical.ml b/vernac/canonical.ml index e9454bab8a..141b02ef63 100644 --- a/vernac/canonical.ml +++ b/vernac/canonical.ml @@ -11,29 +11,30 @@ open Names open Libobject open Recordops -let open_canonical_structure i (_, o) = +let open_canonical_structure i (_, (o,_)) = let env = Global.env () in let sigma = Evd.from_env env in if Int.equal i 1 then register_canonical_structure env sigma ~warn:false o -let cache_canonical_structure (_, o) = +let cache_canonical_structure (_, (o,_)) = let env = Global.env () in let sigma = Evd.from_env env in register_canonical_structure ~warn:true env sigma o -let discharge_canonical_structure (_,x) = Some x +let discharge_canonical_structure (_,(x, local)) = + if local then None else Some (x, local) -let inCanonStruc : Constant.t * inductive -> obj = +let inCanonStruc : (Constant.t * inductive) * bool -> obj = declare_object {(default_object "CANONICAL-STRUCTURE") with open_function = open_canonical_structure; cache_function = cache_canonical_structure; - subst_function = (fun (subst,c) -> subst_canonical_structure subst c); + subst_function = (fun (subst,(c,local)) -> subst_canonical_structure subst c, local); classify_function = (fun x -> Substitute x); discharge_function = discharge_canonical_structure } let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) -let declare_canonical_structure ref = +let declare_canonical_structure ?(local=false) ref = let env = Global.env () in let sigma = Evd.from_env env in - add_canonical_structure (check_and_decompose_canonical_structure env sigma ref) + add_canonical_structure (check_and_decompose_canonical_structure env sigma ref, local) diff --git a/vernac/canonical.mli b/vernac/canonical.mli index a3bbaf6d18..e4161b4f97 100644 --- a/vernac/canonical.mli +++ b/vernac/canonical.mli @@ -9,4 +9,4 @@ (************************************************************************) open Names -val declare_canonical_structure : GlobRef.t -> unit +val declare_canonical_structure : ?local:bool -> GlobRef.t -> unit diff --git a/vernac/classes.ml b/vernac/classes.ml index 0333b73ffe..c9b5144299 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -410,7 +410,7 @@ let do_instance_resolve_TC termtype sigma env = (* Beware of this step, it is required as to minimize universes. *) let sigma = Evd.minimize_universes sigma in (* Check that the type is free of evars now. *) - Pretyping.check_evars env (Evd.from_env env) sigma termtype; + Pretyping.check_evars env sigma termtype; termtype, sigma let do_instance_type_ctx_instance props k env' ctx' sigma ~program_mode subst = diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index e5db6146ca..8a403e5a03 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -22,24 +22,6 @@ open Entries module RelDecl = Context.Rel.Declaration (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) -let axiom_into_instance = ref false - -let () = - let open Goptions in - declare_bool_option - { optdepr = true; - optname = "automatically declare axioms whose type is a typeclass as instances"; - optkey = ["Typeclasses";"Axioms";"Are";"Instances"]; - optread = (fun _ -> !axiom_into_instance); - optwrite = (:=) axiom_into_instance; } - -let should_axiom_into_instance = let open Decls in function - | Context -> - (* The typeclass behaviour of Variable and Context doesn't depend - on section status *) - true - | Definitional | Logical | Conjectural -> !axiom_into_instance - let declare_variable is_coe ~kind typ imps impl {CAst.v=name} = let kind = Decls.IsAssumption kind in let decl = Declare.SectionLocalAssum {typ; impl} in @@ -58,7 +40,12 @@ let instance_of_univ_entry = function | Monomorphic_entry _ -> Univ.Instance.empty let declare_axiom is_coe ~poly ~local ~kind typ (univs, pl) imps nl {CAst.v=name} = - let do_instance = should_axiom_into_instance kind in + let do_instance = let open Decls in match kind with + | Context -> true + (* The typeclass behaviour of Variable and Context doesn't depend + on section status *) + | Definitional | Logical | Conjectural -> false + in let inl = let open Declaremods in match nl with | NoInline -> None | DefaultInline -> Some (Flags.get_inline_level()) @@ -268,7 +255,7 @@ let context ~poly l = let sigma, (_, ((_env, ctx), impls)) = interp_context_evars ~program_mode:false env sigma l in (* Note, we must use the normalized evar from now on! *) let sigma = Evd.minimize_universes sigma in - let ce t = Pretyping.check_evars env (Evd.from_env env) sigma t in + let ce t = Pretyping.check_evars env sigma t in let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) ctx in (* reorder, evar-normalize and add implicit status *) let ctx = List.rev_map (fun d -> diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 80fcb7bc45..b603c54026 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -255,7 +255,7 @@ let inductive_levels env evd arities inds = in let cstrs_levels, min_levels, sizes = CList.split3 - (List.map2 (fun (_,tys,_) (arity,(ctx,du)) -> + (List.map2 (fun (_,tys) (arity,(ctx,du)) -> let len = List.length tys in let minlev = Sorts.univ_of_sort du in let minlev = @@ -323,16 +323,18 @@ let check_named {CAst.loc;v=na} = match na with let msg = str "Parameters must be named." in user_err ?loc msg -let template_polymorphism_candidate env uctx params concl = +let template_polymorphism_candidate ~template_check ~ctor_levels uctx params concl = match uctx with | Entries.Monomorphic_entry uctx -> let concltemplate = Option.cata (fun s -> not (Sorts.is_small s)) false concl in if not concltemplate then false + else if not template_check then true else - let template_check = Environ.check_template env in let conclu = Option.cata Sorts.univ_of_sort Univ.type0m_univ concl in - let params, conclunivs = IndTyping.template_polymorphic_univs ~template_check uctx params conclu in - not (template_check && Univ.LSet.is_empty conclunivs) + let params, conclunivs = + IndTyping.template_polymorphic_univs ~template_check ~ctor_levels uctx params conclu + in + not (Univ.LSet.is_empty conclunivs) | Entries.Polymorphic_entry _ -> false let check_param = function @@ -348,42 +350,47 @@ let restrict_inductive_universes sigma ctx_params arities constructors = let uvars = Univ.LSet.empty in let uvars = Context.Rel.(fold_outside (Declaration.fold_constr merge_universes_of_constr) ctx_params ~init:uvars) in let uvars = List.fold_right merge_universes_of_constr arities uvars in - let uvars = List.fold_right (fun (_,ctypes,_) -> List.fold_right merge_universes_of_constr ctypes) constructors uvars in + let uvars = List.fold_right (fun (_,ctypes) -> List.fold_right merge_universes_of_constr ctypes) constructors uvars in Evd.restrict_universe_context sigma uvars -let interp_mutual_inductive_constr ~env0 ~sigma ~template ~udecl ~env_ar ~env_params ~ctx_params ~indnames ~arities ~arityconcl ~constructors ~env_ar_params ~cumulative ~poly ~private_ind ~finite = +let interp_mutual_inductive_constr ~sigma ~template ~udecl ~ctx_params ~indnames ~arities ~arityconcl ~constructors ~env_ar_params ~cumulative ~poly ~private_ind ~finite = (* Compute renewed arities *) let sigma = Evd.minimize_universes sigma in let nf = Evarutil.nf_evars_universes sigma in - let constructors = List.map (on_pi2 (List.map nf)) constructors in + let constructors = List.map (on_snd (List.map nf)) constructors in let arities = List.map EConstr.(to_constr sigma) arities in let sigma = List.fold_left make_anonymous_conclusion_flexible sigma arityconcl in let sigma, arities = inductive_levels env_ar_params sigma arities constructors in let sigma = Evd.minimize_universes sigma in let nf = Evarutil.nf_evars_universes sigma in let arities = List.map (on_snd nf) arities in - let constructors = List.map (on_pi2 (List.map nf)) constructors in + let constructors = List.map (on_snd (List.map nf)) constructors in let ctx_params = List.map Termops.(map_rel_decl (EConstr.to_constr sigma)) ctx_params in let arityconcl = List.map (Option.map (fun (_anon, s) -> EConstr.ESorts.kind sigma s)) arityconcl in let sigma = restrict_inductive_universes sigma ctx_params (List.map snd arities) constructors in let uctx = Evd.check_univ_decl ~poly sigma udecl in - List.iter (fun c -> check_evars env_params (Evd.from_env env_params) sigma (EConstr.of_constr (snd c))) arities; - Context.Rel.iter (fun c -> check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr c)) ctx_params; - List.iter (fun (_,ctyps,_) -> - List.iter (fun c -> check_evars env_ar_params (Evd.from_env env_ar_params) sigma (EConstr.of_constr c)) ctyps) - constructors; (* Build the inductive entries *) - let entries = List.map4 (fun indname (templatearity, arity) concl (cnames,ctypes,cimpls) -> + let entries = List.map4 (fun indname (templatearity, arity) concl (cnames,ctypes) -> let template_candidate () = - templatearity || template_polymorphism_candidate env0 uctx ctx_params concl in + templatearity || + let ctor_levels = + let add_levels c levels = Univ.LSet.union levels (Vars.universes_of_constr c) in + let param_levels = + List.fold_left (fun levels d -> match d with + | LocalAssum _ -> levels + | LocalDef (_,b,t) -> add_levels b (add_levels t levels)) + Univ.LSet.empty ctx_params + in + List.fold_left (fun levels c -> add_levels c levels) + param_levels ctypes + in + template_polymorphism_candidate ~template_check:(Environ.check_template env_ar_params) ~ctor_levels uctx ctx_params concl + in let template = match template with | Some template -> if poly && template then user_err Pp.(strbrk "Template-polymorphism and universe polymorphism are not compatible."); - if template && not (template_candidate ()) then - user_err Pp.(strbrk "Inductive " ++ Id.print indname ++ - str" cannot be made template polymorphic."); template | None -> should_auto_template indname (template_candidate ()) @@ -396,7 +403,6 @@ let interp_mutual_inductive_constr ~env0 ~sigma ~template ~udecl ~env_ar ~env_pa }) indnames arities arityconcl constructors in - let variance = if poly && cumulative then Some (InferCumulativity.dummy_variance uctx) else None in (* Build the mutual inductive entry *) let mind_ent = { mind_entry_params = ctx_params; @@ -405,12 +411,10 @@ let interp_mutual_inductive_constr ~env0 ~sigma ~template ~udecl ~env_ar ~env_pa mind_entry_inds = entries; mind_entry_private = if private_ind then Some false else None; mind_entry_universes = uctx; - mind_entry_variance = variance; + mind_entry_cumulative = poly && cumulative; } in - (if poly && cumulative then - InferCumulativity.infer_inductive env_ar mind_ent - else mind_ent), Evd.universe_binders sigma + mind_ent, Evd.universe_binders sigma let interp_params env udecl uparamsl paramsl = let sigma, udecl = interp_univ_decl_opt env udecl in @@ -480,9 +484,10 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not List.init (List.length indl) EConstr.(fun i -> mkApp (mkRel (i + 1 + nuparams), uargs)) @ List.init nuparams EConstr.(fun i -> mkRel (i + 1)) in let generalize_constructor c = EConstr.Unsafe.to_constr (EConstr.Vars.substnl uparam_subst nparams c) in + let cimpls = List.map pi3 constructors in let constructors = List.map (fun (cnames,ctypes,cimpls) -> - (cnames,List.map generalize_constructor ctypes,cimpls)) - constructors + (cnames,List.map generalize_constructor ctypes)) + constructors in let ctx_params = ctx_params @ ctx_uparams in let userimpls = useruimpls @ userimpls in @@ -493,11 +498,12 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not (* Try further to solve evars, and instantiate them *) let sigma = solve_remaining_evars all_and_fail_flags env_params sigma in let impls = - List.map2 (fun indimpls (_,_,cimpls) -> + List.map2 (fun indimpls cimpls -> indimpls, List.map (fun impls -> - userimpls @ impls) cimpls) indimpls constructors + userimpls @ impls) cimpls) + indimpls cimpls in - let mie, pl = interp_mutual_inductive_constr ~env0 ~template ~sigma ~env_params ~env_ar ~ctx_params ~udecl ~arities ~arityconcl ~constructors ~env_ar_params ~poly ~finite ~cumulative ~private_ind ~indnames in + let mie, pl = interp_mutual_inductive_constr ~template ~sigma ~ctx_params ~udecl ~arities ~arityconcl ~constructors ~env_ar_params ~poly ~finite ~cumulative ~private_ind ~indnames in (mie, pl, impls) diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 45e539b1e4..cc104b3762 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -49,24 +49,22 @@ val declare_mutual_inductive_with_eliminations -> Names.MutInd.t [@@ocaml.deprecated "Please use DeclareInd.declare_mutual_inductive_with_eliminations"] -val interp_mutual_inductive_constr : - env0:Environ.env -> - sigma:Evd.evar_map -> - template:bool option -> - udecl:UState.universe_decl -> - env_ar:Environ.env -> - env_params:Environ.env -> - ctx_params:(EConstr.t, EConstr.t) Context.Rel.Declaration.pt list -> - indnames:Names.Id.t list -> - arities:EConstr.t list -> - arityconcl:(bool * EConstr.ESorts.t) option list -> - constructors:(Names.Id.t list * Constr.constr list * 'a list list) list -> - env_ar_params:Environ.env -> - cumulative:bool -> - poly:bool -> - private_ind:bool -> - finite:Declarations.recursivity_kind -> - Entries.mutual_inductive_entry * UnivNames.universe_binders +val interp_mutual_inductive_constr + : sigma:Evd.evar_map + -> template:bool option + -> udecl:UState.universe_decl + -> ctx_params:(EConstr.t, EConstr.t) Context.Rel.Declaration.pt list + -> indnames:Names.Id.t list + -> arities:EConstr.t list + -> arityconcl:(bool * EConstr.ESorts.t) option list + -> constructors:(Names.Id.t list * Constr.constr list) list + -> env_ar_params:Environ.env + (** Environment with the inductives and parameters in the rel_context *) + -> cumulative:bool + -> poly:bool + -> private_ind:bool + -> finite:Declarations.recursivity_kind + -> Entries.mutual_inductive_entry * UnivNames.universe_binders (************************************************************************) (** Internal API, exported for Record *) @@ -77,12 +75,18 @@ val should_auto_template : Id.t -> bool -> bool automatically use template polymorphism. [x] is the name of the inductive under consideration. *) -val template_polymorphism_candidate : - Environ.env -> Entries.universes_entry -> Constr.rel_context -> Sorts.t option -> bool -(** [template_polymorphism_candidate env uctx params conclsort] is - [true] iff an inductive with params [params] and conclusion - [conclsort] would be definable as template polymorphic. It should - have at least one universe in its monomorphic universe context that - can be made parametric in its conclusion sort, if one is given. - If the [Template Check] flag is false we just check that the conclusion sort - is not small. *) +val template_polymorphism_candidate + : template_check:bool + -> ctor_levels:Univ.LSet.t + -> Entries.universes_entry + -> Constr.rel_context + -> Sorts.t option + -> bool +(** [template_polymorphism_candidate ~template_check ~ctor_levels uctx params + conclsort] is [true] iff an inductive with params [params], + conclusion [conclsort] and universe levels appearing in the + constructor arguments [ctor_levels] would be definable as template + polymorphic. It should have at least one universe in its + monomorphic universe context that can be made parametric in its + conclusion sort, if one is given. If the [template_check] flag is + false we just check that the conclusion sort is not small. *) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 0e17f2b274..d48e2139d1 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -200,7 +200,7 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = Constrintern.Recursive full_arity impls in let newimpls = Id.Map.singleton recname - (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))], + (r, l, impls @ [Some (ExplByName (Id.of_string "recproof"), Impargs.Manual, (true, false))], scopes @ [None]) in interp_casted_constr_evars ~program_mode:true (push_rel_context ctx env) sigma ~impls:newimpls body (lift 1 top_arity) diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index 54dda09e83..c816a4eb4f 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -550,7 +550,7 @@ let intern_arg (acc, cst) (idl,(typ,ann)) = let lib_dir = Lib.library_dp() in let env = Global.env() in let (mty, _, cst') = Modintern.interp_module_ast env Modintern.ModType typ in - let () = Global.push_context_set true cst' in + let () = Global.push_context_set ~strict:true cst' in let env = Global.env () in let sobjs = get_module_sobjs false env inl mty in let mp0 = get_module_path mty in @@ -674,7 +674,7 @@ module RawModOps = struct let start_module export id args res fs = let mp = Global.start_module id in let arg_entries_r, cst = intern_args args in - let () = Global.push_context_set true cst in + let () = Global.push_context_set ~strict:true cst in let env = Global.env () in let res_entry_o, subtyps, cst = match res with | Enforce (res,ann) -> @@ -689,7 +689,7 @@ let start_module export id args res fs = let typs, cst = build_subtypes env mp arg_entries_r resl in None, typs, cst in - let () = Global.push_context_set true cst in + let () = Global.push_context_set ~strict:true cst in openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps }; let prefix = Lib.start_module export id mp fs in Nametab.(push_dir (Until 1) (prefix.obj_dir) (GlobDirRef.DirOpenModule prefix)); @@ -782,7 +782,7 @@ let declare_module id args res mexpr_o fs = | None -> None | _ -> inl_res in - let () = Global.push_context_set true cst in + let () = Global.push_context_set ~strict:true cst in let mp_env,resolver = Global.add_module id entry inl in (* Name consistency check : kernel vs. library *) @@ -804,10 +804,10 @@ module RawModTypeOps = struct let start_modtype id args mtys fs = let mp = Global.start_modtype id in let arg_entries_r, cst = intern_args args in - let () = Global.push_context_set true cst in + let () = Global.push_context_set ~strict:true cst in let env = Global.env () in let sub_mty_l, cst = build_subtypes env mp arg_entries_r mtys in - let () = Global.push_context_set true cst in + let () = Global.push_context_set ~strict:true cst in openmodtype_info := sub_mty_l; let prefix = Lib.start_modtype id mp fs in Nametab.(push_dir (Until 1) (prefix.obj_dir) (GlobDirRef.DirOpenModtype prefix)); @@ -835,19 +835,19 @@ let declare_modtype id args mtys (mty,ann) fs = then we adds the module parameters to the global env. *) let mp = Global.start_modtype id in let arg_entries_r, cst = intern_args args in - let () = Global.push_context_set true cst in + let () = Global.push_context_set ~strict:true cst in let params = mk_params_entry arg_entries_r in let env = Global.env () in let mte, _, cst = Modintern.interp_module_ast env Modintern.ModType mty in - let () = Global.push_context_set true cst in + let () = Global.push_context_set ~strict:true cst in let env = Global.env () in (* We check immediately that mte is well-formed *) let _, _, _, cst = Mod_typing.translate_mse env None inl mte in - let () = Global.push_context_set true cst in + let () = Global.push_context_set ~strict:true cst in let env = Global.env () in let entry = params, mte in let sub_mty_l, cst = build_subtypes env mp arg_entries_r mtys in - let () = Global.push_context_set true cst in + let () = Global.push_context_set ~strict:true cst in let env = Global.env () in let sobjs = get_functor_sobjs false env inl entry in let subst = map_mp (get_module_path (snd entry)) mp empty_delta_resolver in @@ -903,7 +903,7 @@ let type_of_incl env is_mod = function let declare_one_include (me_ast,annot) = let env = Global.env() in let me, kind, cst = Modintern.interp_module_ast env Modintern.ModAny me_ast in - let () = Global.push_context_set true cst in + let () = Global.push_context_set ~strict:true cst in let env = Global.env () in let is_mod = (kind == Modintern.Module) in let cur_mp = Lib.current_mp () in diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index e02f94629c..b65a126f55 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -247,7 +247,7 @@ type (_, _) entry = | TTReference : ('self, qualid) entry | TTBigint : ('self, string) entry | TTConstr : notation_entry * prod_info * 'r target -> ('r, 'r) entry -| TTConstrList : prod_info * string Tok.p list * 'r target -> ('r, 'r list) entry +| TTConstrList : notation_entry * prod_info * string Tok.p list * 'r target -> ('r, 'r list) entry | TTPattern : int -> ('self, cases_pattern_expr) entry | TTOpenBinderList : ('self, local_binder_expr list) entry | TTClosedBinderList : string Tok.p list -> ('self, local_binder_expr list list) entry @@ -347,12 +347,12 @@ let symbol_of_target : type s. _ -> _ -> _ -> _ -> s target -> (s, s) mayrec_sym let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) mayrec_symbol = fun assoc from typ -> match typ with | TTConstr (s, p, forpat) -> symbol_of_target s p assoc from forpat -| TTConstrList (typ', [], forpat) -> - begin match symbol_of_target InConstrEntry typ' assoc from forpat with +| TTConstrList (s, typ', [], forpat) -> + begin match symbol_of_target s typ' assoc from forpat with | MayRecNo s -> MayRecNo (Alist1 s) | MayRecMay s -> MayRecMay (Alist1 s) end -| TTConstrList (typ', tkl, forpat) -> - begin match symbol_of_target InConstrEntry typ' assoc from forpat with +| TTConstrList (s, typ', tkl, forpat) -> + begin match symbol_of_target s typ' assoc from forpat with | MayRecNo s -> MayRecNo (Alist1sep (s, make_sep_rules tkl)) | MayRecMay s -> MayRecMay (Alist1sep (s, make_sep_rules tkl)) end | TTPattern p -> MayRecNo (Aentryl (Constr.pattern, string_of_int p)) @@ -369,7 +369,7 @@ let interp_entry forpat e = match e with | ETProdBigint -> TTAny TTBigint | ETProdConstr (s,p) -> TTAny (TTConstr (s, p, forpat)) | ETProdPattern p -> TTAny (TTPattern p) -| ETProdConstrList (p, tkl) -> TTAny (TTConstrList (p, tkl, forpat)) +| ETProdConstrList (s, p, tkl) -> TTAny (TTConstrList (s, p, tkl, forpat)) | ETProdBinderList ETBinderOpen -> TTAny TTOpenBinderList | ETProdBinderList (ETBinderClosed tkl) -> TTAny (TTClosedBinderList tkl) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 5b97e06b2b..436648c163 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -62,17 +62,6 @@ let make_bullet s = | '*' -> Star n | _ -> assert false -let parse_compat_version = let open Flags in function - | "8.11" -> Current - | "8.10" -> V8_10 - | "8.9" -> V8_9 - | ("8.8" | "8.7" | "8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> - CErrors.user_err ~hdr:"get_compat_version" - Pp.(str "Compatibility with version " ++ str s ++ str " not supported.") - | s -> - CErrors.user_err ~hdr:"get_compat_version" - Pp.(str "Unknown compatibility version \"" ++ str s ++ str "\".") - (* For now we just keep the top-level location of the whole vernacular, that is to say, including attributes and control flags; this is not very convenient for advanced clients tho, so in the @@ -938,15 +927,7 @@ GRAMMAR EXTEND Gram | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string -> { VernacRemoveLoadPath dir } - (* For compatibility *) - | IDENT "AddPath"; dir = ne_string; "as"; alias = as_dirpath -> - { VernacAddLoadPath (false, dir, alias) } - | IDENT "AddRecPath"; dir = ne_string; "as"; alias = as_dirpath -> - { VernacAddLoadPath (true, dir, alias) } - | IDENT "DelPath"; dir = ne_string -> - { VernacRemoveLoadPath dir } - - (* Type-Checking (pas dans le refman) *) + (* Type-Checking *) | "Type"; c = lconstr -> { VernacGlobalCheck c } (* Printing (careful factorization of entries) *) @@ -1010,7 +991,7 @@ GRAMMAR EXTEND Gram | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules; "." -> { fun g -> VernacSearch (SearchRewrite c,g, l) } | IDENT "Search"; s = searchabout_query; l = searchabout_queries; "." -> - { let (sl,m) = l in fun g -> VernacSearch (SearchAbout (s::sl),g, m) } + { let (sl,m) = l in fun g -> VernacSearch (Search (s::sl),g, m) } (* compatibility: SearchAbout *) | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries; "." -> { fun g -> let (sl,m) = l in VernacSearch (SearchAbout (s::sl),g, m) } @@ -1199,7 +1180,7 @@ GRAMMAR EXTEND Gram | IDENT "Notation"; id = identref; idl = LIST0 ident; ":="; c = constr; b = only_parsing -> { VernacSyntacticDefinition - (id,(idl,c),b) } + (id,(idl,c),{ onlyparsing = b }) } | IDENT "Notation"; s = lstring; ":="; c = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ]; @@ -1223,11 +1204,8 @@ GRAMMAR EXTEND Gram ] ] ; only_parsing: - [ [ "("; IDENT "only"; IDENT "parsing"; ")" -> - { Some Flags.Current } - | "("; IDENT "compat"; s = STRING; ")" -> - { Some (parse_compat_version s) } - | -> { None } ] ] + [ [ "("; IDENT "only"; IDENT "parsing"; ")" -> { true } + | -> { false } ] ] ; level: [ [ IDENT "level"; n = natural -> { NumLevel n } @@ -1243,8 +1221,6 @@ GRAMMAR EXTEND Gram | IDENT "no"; IDENT "associativity" -> { SetAssoc Gramlib.Gramext.NonA } | IDENT "only"; IDENT "printing" -> { SetOnlyPrinting } | IDENT "only"; IDENT "parsing" -> { SetOnlyParsing } - | IDENT "compat"; s = STRING -> - { SetCompatVersion (parse_compat_version s) } | IDENT "format"; s1 = [s = STRING -> { CAst.make ~loc s } ]; s2 = OPT [s = STRING -> { CAst.make ~loc s } ] -> { begin match s1, s2 with diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 2e58bf4a93..19ec0a3642 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -117,8 +117,8 @@ let display_eq ~flags env sigma t1 t2 = let open Constrextern in let t1 = canonize_constr sigma t1 in let t2 = canonize_constr sigma t2 in - let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) () in - let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () in + let ct1 = Flags.with_options flags (fun () -> extern_constr env sigma t1) () in + let ct2 = Flags.with_options flags (fun () -> extern_constr env sigma t2) () in Constrexpr_ops.constr_expr_eq ct1 ct2 (** This function adds some explicit printing flags if the two arguments are @@ -134,9 +134,9 @@ let rec pr_explicit_aux env sigma t1 t2 = function pr_explicit_aux env sigma t1 t2 rem else let open Constrextern in - let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) () + let ct1 = Flags.with_options flags (fun () -> extern_constr env sigma t1) () in - let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () + let ct2 = Flags.with_options flags (fun () -> extern_constr env sigma t2) () in Ppconstr.pr_lconstr_expr env sigma ct1, Ppconstr.pr_lconstr_expr env sigma ct2 @@ -697,7 +697,7 @@ let explain_cannot_find_well_typed_abstraction env sigma p l e = str "Abstracting over the " ++ str (String.plural (List.length l) "term") ++ spc () ++ hov 0 (pr_enum (fun c -> pr_lconstr_env env sigma (EConstr.to_constr sigma c)) l) ++ spc () ++ - str "leads to a term" ++ spc () ++ pr_lconstr_goal_style_env env sigma p ++ + str "leads to a term" ++ spc () ++ pr_ltype_env ~goal_concl_style:true env sigma p ++ spc () ++ str "which is ill-typed." ++ (match e with None -> mt () | Some e -> fnl () ++ str "Reason is: " ++ e) @@ -1183,7 +1183,7 @@ let error_ill_formed_constructor env id c v nparams nargs = let pr_ltype_using_barendregt_convention_env env c = (* Use goal_concl_style as an approximation of Barendregt's convention (?) *) - quote (pr_goal_concl_style_env env (Evd.from_env env) (EConstr.of_constr c)) + quote (pr_ltype_env ~goal_concl_style:true env (Evd.from_env env) c) let error_bad_ind_parameters env c n v1 v2 = let pc = pr_ltype_using_barendregt_convention_env env c in @@ -1338,7 +1338,7 @@ let explain_reduction_tactic_error = function | Tacred.InvalidAbstraction (env,sigma,c,(env',e)) -> let e = map_ptype_error EConstr.of_constr e in str "The abstracted term" ++ spc () ++ - quote (pr_goal_concl_style_env env sigma c) ++ + quote (pr_letype_env ~goal_concl_style:true env sigma c) ++ spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' (Evd.from_env env') e diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index b2e1a5e796..2f0b1062a7 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -210,7 +210,7 @@ let declare_one_case_analysis_scheme ind = induction scheme, the other ones share the same code with the appropriate type *) if Sorts.family_leq InType kelim then - ignore (define_individual_scheme dep UserAutomaticRequest None ind) + define_individual_scheme dep UserAutomaticRequest None ind (* Induction/recursion schemes *) @@ -248,7 +248,7 @@ let declare_one_induction_scheme ind = else if depelim then kinds_from_type else nondep_kinds_from_type) in - List.iter (fun kind -> ignore (define_individual_scheme kind UserAutomaticRequest None ind)) + List.iter (fun kind -> define_individual_scheme kind UserAutomaticRequest None ind) elims let declare_induction_schemes kn = @@ -264,7 +264,7 @@ let declare_induction_schemes kn = let declare_eq_decidability_gen internal names kn = let mib = Global.lookup_mind kn in if mib.mind_finite <> Declarations.CoFinite then - ignore (define_mutual_scheme eq_dec_scheme_kind internal names kn) + define_mutual_scheme eq_dec_scheme_kind internal names kn let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *) str "Decidable equality on " ++ quote (Printer.pr_inductive (Global.env()) ind) @@ -280,14 +280,14 @@ let try_declare_eq_decidability kn = let declare_eq_decidability = declare_eq_decidability_scheme_with [] let ignore_error f x = - try ignore (f x) with e when CErrors.noncritical e -> () + try f x with e when CErrors.noncritical e -> () let declare_rewriting_schemes ind = if Hipattern.is_inductive_equality ind then begin - ignore (define_individual_scheme rew_r2l_scheme_kind UserAutomaticRequest None ind); - ignore (define_individual_scheme rew_r2l_dep_scheme_kind UserAutomaticRequest None ind); - ignore (define_individual_scheme rew_r2l_forward_dep_scheme_kind - UserAutomaticRequest None ind); + define_individual_scheme rew_r2l_scheme_kind UserAutomaticRequest None ind; + define_individual_scheme rew_r2l_dep_scheme_kind UserAutomaticRequest None ind; + define_individual_scheme rew_r2l_forward_dep_scheme_kind + UserAutomaticRequest None ind; (* These ones expect the equality to be symmetric; the first one also *) (* needs eq *) ignore_error (define_individual_scheme rew_l2r_scheme_kind UserAutomaticRequest None) ind; @@ -310,7 +310,7 @@ let declare_congr_scheme ind = try Coqlib.check_required_library Coqlib.logic_module_name; true with e when CErrors.noncritical e -> false then - ignore (define_individual_scheme congr_scheme_kind UserAutomaticRequest None ind) + define_individual_scheme congr_scheme_kind UserAutomaticRequest None ind else warn_cannot_build_congruence () end diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index fd57901acd..35681aed13 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -611,7 +611,7 @@ let expand_list_rule s typ tkl x n p ll = else if Int.equal i (p+n) then let hds = GramConstrListMark (p+n,true,p) :: hds - @ [GramConstrNonTerminal (ETProdConstrList (typ,tkl), Some x)] in + @ [GramConstrNonTerminal (ETProdConstrList (s, typ,tkl), Some x)] in distribute hds ll else distribute (GramConstrListMark (i+1,false,p) :: hds @ [main]) ll @ @@ -805,7 +805,6 @@ type notation_modifier = { (* common to syn_data below *) only_parsing : bool; only_printing : bool; - compat : Flags.compat_version option; format : lstring option; extra : (string * string) list; } @@ -818,7 +817,6 @@ let default = { subtyps = []; only_parsing = false; only_printing = false; - compat = None; format = None; extra = []; } @@ -877,8 +875,6 @@ let interp_modifiers modl = let open NotationMods in interp subtyps { acc with only_parsing = true; } l | SetOnlyPrinting :: l -> interp subtyps { acc with only_printing = true; } l - | SetCompatVersion v :: l -> - interp subtyps { acc with compat = Some v; } l | SetFormat ("text",s) :: l -> if not (Option.is_empty acc.format) then user_err Pp.(str "A format is given more than once."); interp subtyps { acc with format = Some s; } l @@ -916,7 +912,6 @@ let check_binder_type recvars etyps = let not_a_syntax_modifier = function | SetOnlyParsing -> true | SetOnlyPrinting -> true -| SetCompatVersion _ -> true | _ -> false let no_syntax_modifiers mods = List.for_all not_a_syntax_modifier mods @@ -1213,32 +1208,12 @@ let check_locality_compatibility local custom i_typs = strbrk " which is local.")) (List.uniquize allcustoms) -let warn_deprecated_compat = - CWarnings.create ~name:"deprecated-compat" ~category:"deprecated" - (fun () -> Pp.(str"The \"compat\" modifier is deprecated." ++ spc () ++ - str"Please use the \"deprecated\" attributed instead.")) - -(* Returns the new deprecation and the onlyparsing status. This should be -removed together with the compat syntax modifier. *) -let merge_compat_deprecation compat deprecation = - match compat, deprecation with - | Some Flags.Current, _ -> deprecation, true - | Some _, Some _ -> - CErrors.user_err Pp.(str"The \"compat\" modifier cannot be used with the \"deprecated\" attribute." - ++ spc () ++ str"Please use only the latter.") - | Some v, None -> - warn_deprecated_compat (); - Some (Deprecation.make ~since:(Flags.pr_version v) ()), true - | None, Some _ -> deprecation, true - | None, None -> deprecation, false - let compute_syntax_data ~local deprecation df modifiers = let open SynData in let open NotationMods in let mods = interp_modifiers modifiers in let onlyprint = mods.only_printing in let onlyparse = mods.only_parsing in - let deprecation, _ = merge_compat_deprecation mods.compat deprecation in if onlyprint && onlyparse then user_err (str "A notation cannot be both 'only printing' and 'only parsing'."); let assoc = Option.append mods.assoc (Some Gramlib.Gramext.NonA) in let (recvars,mainvars,symbols) = analyze_notation_tokens ~onlyprint df in @@ -1659,7 +1634,7 @@ let try_interp_name_alias = function | [], { CAst.v = CRef (ref,_) } -> intern_reference ref | _ -> raise Not_found -let add_syntactic_definition ~local deprecation env ident (vars,c) compat = +let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing } = let vars,reversibility,pat = try [], APrioriReversible, NRef (try_interp_name_alias (vars,c)) with Not_found -> @@ -1673,7 +1648,6 @@ let add_syntactic_definition ~local deprecation env ident (vars,c) compat = let map id = let (_,sc) = Id.Map.find id nvars in (id, sc) in List.map map vars, reversibility, pat in - let deprecation, onlyparsing = merge_compat_deprecation compat deprecation in let onlyparsing = onlyparsing || fst (printability None false reversibility pat) in Syntax_def.declare_syntactic_definition ~local deprecation ident ~onlyparsing (vars,pat) diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index 44e08c4819..e3e733a4b7 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -52,7 +52,7 @@ val add_syntax_extension : (** Add a syntactic definition (as in "Notation f := ...") *) val add_syntactic_definition : local:bool -> Deprecation.t option -> env -> - Id.t -> Id.t list * constr_expr -> Flags.compat_version option -> unit + Id.t -> Id.t list * constr_expr -> onlyparsing_flag -> unit (** Print the Camlp5 state of a grammar *) diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 080629ede2..1742027076 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -161,6 +161,8 @@ open Pputils | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchAbout sl -> + keyword "SearchAbout" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b + | Search sl -> keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b let pr_option_ref_value = function @@ -410,7 +412,6 @@ let string_of_theorem_kind = let open Decls in function | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_simple_entry_type typ | SetOnlyPrinting -> keyword "only printing" | SetOnlyParsing -> keyword "only parsing" - | SetCompatVersion v -> keyword("compat \"" ^ Flags.pr_version v ^ "\"") | SetFormat("text",s) -> keyword "format " ++ pr_ast qs s | SetFormat(k,s) -> keyword "format " ++ qs k ++ spc() ++ pr_ast qs s @@ -1057,16 +1058,12 @@ let string_of_definition_object_kind = let open Decls in function ) | VernacHints (dbnames,h) -> return (pr_hints dbnames h (pr_constr env sigma) (pr_constr_pattern_expr env sigma)) - | VernacSyntacticDefinition (id,(ids,c),compat) -> + | VernacSyntacticDefinition (id,(ids,c),{onlyparsing}) -> return ( hov 2 (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++ prlist_with_sep spc pr_id ids ++ str":=" ++ pr_constrarg c ++ - pr_syntax_modifiers - (match compat with - | None -> [] - | Some Flags.Current -> [SetOnlyParsing] - | Some v -> [SetCompatVersion v])) + pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else [])) ) | VernacArguments (q, args, more_implicits, mods) -> return ( diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index ea49cae9db..eb7b28f15b 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -255,9 +255,13 @@ let needs_extra_scopes ref scopes = let ty, _ctx = Typeops.type_of_global_in_context env ref in aux env ty scopes +let implicit_name_of_pos = function + | Constrexpr.ExplByName id -> Name id + | Constrexpr.ExplByPos (n,k) -> Anonymous + let implicit_kind_of_status = function | None -> Anonymous, NotImplicit - | Some (id,_,(maximal,_)) -> Name id, if maximal then MaximallyImplicit else Implicit + | Some (pos,_,(maximal,_)) -> implicit_name_of_pos pos, if maximal then MaximallyImplicit else Implicit let dummy = { Vernacexpr.implicit_status = NotImplicit; diff --git a/vernac/record.ml b/vernac/record.ml index 49a73271f0..ea10e06d02 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -202,7 +202,7 @@ let typecheck_params_and_fields finite def poly pl ps records = in let univs = Evd.check_univ_decl ~poly sigma decl in let ubinders = Evd.universe_binders sigma in - let ce t = Pretyping.check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr t) in + let ce t = Pretyping.check_evars env0 sigma (EConstr.of_constr t) in let () = List.iter (iter_constr ce) (List.rev newps) in ubinders, univs, template, newps, imps, ans @@ -411,7 +411,6 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa | Polymorphic_entry (nas, ctx) -> true, Polymorphic_entry (nas, ctx) in - let variance = if poly && cumulative then Some (InferCumulativity.dummy_variance ctx) else None in let binder_name = match name with | None -> @@ -429,15 +428,32 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa let type_constructor = it_mkProd_or_LetIn ind fields in let template = let template_candidate () = - ComInductive.template_polymorphism_candidate (Global.env ()) univs params + (* we use some dummy values for the arities in the rel_context + as univs_of_constr doesn't care about localassums and + getting the real values is too annoying *) + let add_levels c levels = Univ.LSet.union levels (Vars.universes_of_constr c) in + let param_levels = + List.fold_left (fun levels d -> match d with + | LocalAssum _ -> levels + | LocalDef (_,b,t) -> add_levels b (add_levels t levels)) + Univ.LSet.empty params + in + let ctor_levels = List.fold_left + (fun univs d -> + let univs = + RelDecl.fold_constr (fun c univs -> add_levels c univs) d univs + in + univs) + param_levels fields + in + let template_check = Environ.check_template (Global.env ()) in + ComInductive.template_polymorphism_candidate ~template_check ~ctor_levels univs params (Some (Sorts.sort_of_univ min_univ)) in match template with | Some template, _ -> (* templateness explicitly requested *) if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); - if template && not (template_candidate ()) then - user_err Pp.(strbrk "record cannot be made template polymorphic on any universe"); template | None, template -> (* auto detect template *) @@ -461,10 +477,9 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa mind_entry_inds = blocks; mind_entry_private = None; mind_entry_universes = univs; - mind_entry_variance = variance; + mind_entry_cumulative = poly && cumulative; } in - let mie = InferCumulativity.infer_inductive (Global.env ()) mie in let impls = List.map (fun _ -> paramimpls, []) record_data in let kn = DeclareInd.declare_mutual_inductive_with_eliminations mie ubinders impls ~primitive_expected:!primitive_flag diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 535aceed15..439ec61d38 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -522,11 +522,11 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?hook thms = in start_lemma_with_initialization ?hook ~poly ~scope ~kind evd ~udecl recguard thms snl -let vernac_definition_hook ~poly = let open Decls in function +let vernac_definition_hook ~local ~poly = let open Decls in function | Coercion -> Some (Class.add_coercion_hook ~poly) | CanonicalStructure -> - Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure dref))) + Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure ?local dref))) | SubClass -> Some (Class.add_subclass_hook ~poly) | _ -> None @@ -551,7 +551,7 @@ let vernac_definition_name lid local = let vernac_definition_interactive ~atts (discharge, kind) (lid, pl) bl t = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in - let hook = vernac_definition_hook ~poly:atts.polymorphic kind in + let hook = vernac_definition_hook ~local:atts.locality ~poly:atts.polymorphic kind in let program_mode = atts.program in let poly = atts.polymorphic in let name = vernac_definition_name lid local in @@ -560,7 +560,7 @@ let vernac_definition_interactive ~atts (discharge, kind) (lid, pl) bl t = let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt = let open DefAttributes in let scope = enforce_locality_exp atts.locality discharge in - let hook = vernac_definition_hook ~poly:atts.polymorphic kind in + let hook = vernac_definition_hook ~local:atts.locality ~poly:atts.polymorphic kind in let program_mode = atts.program in let name = vernac_definition_name lid scope in let red_option = match red_option with @@ -1025,8 +1025,8 @@ let vernac_require from import qidl = (* Coercions and canonical structures *) -let vernac_canonical r = - Canonical.declare_canonical_structure (smart_global r) +let vernac_canonical ~local r = + Canonical.declare_canonical_structure ?local (smart_global r) let vernac_coercion ~atts ref qids qidt = let local, poly = Attributes.(parse Notations.(locality ++ polymorphic) atts) in @@ -1206,10 +1206,10 @@ let vernac_hints ~atts dbnames h = let local = enforce_module_locality local in Hints.add_hints ~local dbnames (Hints.interp_hints ~poly h) -let vernac_syntactic_definition ~atts lid x compat = +let vernac_syntactic_definition ~atts lid x only_parsing = let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in Dumpglob.dump_definition lid false "syndef"; - Metasyntax.add_syntactic_definition ~local:module_local deprecation (Global.env()) lid.v x compat + Metasyntax.add_syntactic_definition ~local:module_local deprecation (Global.env()) lid.v x only_parsing let default_env () = { Notation_term.ninterp_var_type = Id.Map.empty; @@ -1621,7 +1621,7 @@ let vernac_global_check c = let c,uctx = interp_constr env sigma c in let senv = Global.safe_env() in let uctx = UState.context_set uctx in - let senv = Safe_typing.push_context_set false uctx senv in + let senv = Safe_typing.push_context_set ~strict:false uctx senv in let c = EConstr.to_constr sigma c in let j = Safe_typing.typing senv c in let env = Safe_typing.env_of_safe_env senv in @@ -1785,6 +1785,10 @@ let () = optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } +let warn_deprecated_search_about = + CWarnings.create ~name:"deprecated-search-about" ~category:"deprecated" + (fun () -> strbrk "The SearchAbout command is deprecated. Please use Search instead.") + let vernac_search ~pstate ~atts s gopt r = let gopt = query_command_selector gopt in let r = interp_search_restriction r in @@ -1815,6 +1819,10 @@ let vernac_search ~pstate ~atts s gopt r = | SearchHead c -> (Search.search_by_head ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchAbout sl -> + warn_deprecated_search_about (); + (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> + Search.prioritize_search) pr_search + | Search sl -> (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> Search.prioritize_search) pr_search @@ -2085,8 +2093,7 @@ let translate_vernac ~atts v = let open Vernacextend in match v with vernac_import export qidl) | VernacCanonical qid -> VtDefault(fun () -> - unsupported_attributes atts; - vernac_canonical qid) + vernac_canonical ~local:(only_locality atts) qid) | VernacCoercion (r,s,t) -> VtDefault(fun () -> vernac_coercion ~atts r s t) | VernacIdentityCoercion ({v=id},s,t) -> diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index ce96d9265c..32ff8b8fb2 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -70,6 +70,7 @@ type searchable = | SearchRewrite of constr_pattern_expr | SearchHead of constr_pattern_expr | SearchAbout of (bool * search_about_item) list + | Search of (bool * search_about_item) list type locatable = | LocateAny of qualid or_by_notation @@ -104,7 +105,7 @@ type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) type export_flag = bool (* true = Export; false = Import *) type inductive_flag = Declarations.recursivity_kind -type onlyparsing_flag = Flags.compat_version option +type onlyparsing_flag = { onlyparsing : bool } (* Some v = Parse only; None = Print also. If v<>Current, it contains the name of the coq version which this notation is trying to be compatible with *) @@ -184,7 +185,6 @@ type syntax_modifier = | SetEntryType of string * Extend.simple_constr_prod_entry_key | SetOnlyParsing | SetOnlyPrinting - | SetCompatVersion of Flags.compat_version | SetFormat of string * lstring type proof_end = |