diff options
264 files changed, 12077 insertions, 12374 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 6c6e4bdfcb..a7c0846e35 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -6,126 +6,101 @@ /.github/ @coq/contributing-process-maintainers /CONTRIBUTING.md @coq/contributing-process-maintainers +/dev/doc/shield-icon.png @coq/contributing-process-maintainers /dev/doc/release-process.md @coq/contributing-process-maintainers -/dev/doc/MERGING.md @coq/pushers -# This ensures that all members of the @coq/pushers -# team are notified when the merging doc changes. - ########## Build system ########## -/Makefile* @gares -/dev/tools/make_git_revision.sh @gares +/Makefile* @coq/legacy-build-maintainers +/dev/tools/make_git_revision.sh @coq/legacy-build-maintainers -/configure* @ejgallego +/configure* @coq/legacy-build-maintainers @coq/build-maintainers -/META.coq.in @ejgallego +/META.coq.in @coq/legacy-build-maintainers -/dev/build/windows @MSoegtropIMC -# Secondary maintainer @maximedenes +/dev/build/windows @coq/windows-build-maintainers ########## CI infrastructure ########## -/dev/ci/ @coq/ci-maintainers -/.travis.yml @coq/ci-maintainers -/.gitlab-ci.yml @coq/ci-maintainers -/Makefile.ci @coq/ci-maintainers -/dev/ci/nix @coq/nix-maintainers +/dev/ci/ @coq/ci-maintainers +/.travis.yml @coq/ci-maintainers +/.gitlab-ci.yml @coq/ci-maintainers +/azure-pipelines.yml @coq/ci-maintainers +/Makefile.ci @coq/ci-maintainers + +/dev/ci/nix @coq/nix-maintainers +*.nix @coq/nix-maintainers /dev/ci/user-overlays/*.sh @ghost # Trick to avoid getting review requests # each time someone adds an overlay -/dev/ci/*.bat @coq/ci-maintainers - -*.nix @coq/nix-maintainers - -azure-pipelines.yml @coq/ci-maintainers -/dev/ci/azure* @coq/ci-maintainers - ########## Documentation ########## -/README.md @Zimmi48 -# Secondary maintainer @maximedenes +/README.md @coq/doc-maintainers +/INSTALL.md @coq/doc-maintainers -/INSTALL* @Zimmi48 -# Secondary maintainer @maximedenes +/CODE_OF_CONDUCT.md @coq/code-of-conduct-team -/CODE_OF_CONDUCT.md @Zimmi48 -# Secondary maintainer @mattam82 +/doc/ @coq/doc-maintainers +/Makefile.doc @coq/doc-maintainers -/dev/doc/ @Zimmi48 -# Secondary maintainer @maximedenes +/dev/doc/ @coq/doc-maintainers +/doc/changelog/*/*.rst @ghost /dev/doc/changes.md @ghost # Trick to avoid getting review requests -# each time someone modifies the dev changelog - -/doc/ @coq/doc-maintainers -/Makefile.doc @coq/doc-maintainers +# each time someone modifies the changelog -/man/ @silene -# Secondary maintainer @maximedenes +/man/ @coq/doc-maintainers -/doc/plugin_tutorial/ @coq/plugin-tutorial-maintainers +/doc/plugin_tutorial/ @coq/plugin-tutorial-maintainers ########## Coqchk ########## -/checker/ @ppedrot -/test-suite/coqchk/ @ppedrot -# Secondary maintainers @maximedenes +/checker/ @coq/kernel-maintainers +/test-suite/coqchk/ @coq/kernel-maintainers ########## Coq lib ########## -/clib/ @ppedrot -/test-suite/unit-tests/clib/ @ppedrot -# Secondary maintainer @ejgallego - -/lib/ @ejgallego -# Secondary maintainer @ppedrot - -/lib/cWarnings.* @maximedenes -# Secondary maintainer @ejgallego +/clib/ @coq/lib-maintainers +/test-suite/unit-tests/clib/ @coq/lib-maintainers +/lib/ @coq/lib-maintainers ########## Proof engine ########## -/engine/ @ppedrot -# Secondary maintainer @aspiwack +/engine/ @coq/engine-maintainers -/engine/universes.* @SkySkimmer -/engine/univops.* @SkySkimmer -/engine/uState.* @SkySkimmer -# Secondary maintainer @mattam82 +/engine/univ* @coq/universes-maintainers +/engine/uState.* @coq/universes-maintainers ########## CoqIDE ########## -/ide/ @ppedrot -/test-suite/ide/ @ppedrot -# Secondary maintainers @gares @herbelin +/ide/ @coq/coqide-maintainers +/ide/protocol/ @coq/stm-maintainers +/test-suite/ide/ @coq/stm-maintainers -########## Interpretation ########## +########## Desugaring ########## -/interp/ @herbelin -# Secondary maintainer @ejgallego +/interp/ @coq/extensible-syntax-maintainers ########## Kernel ########## -/kernel/ @maximedenes -# Secondary maintainers @barras @ppedrot +/kernel/ @coq/kernel-maintainers -/kernel/byterun/ @maximedenes -# Secondary maintainer @silene +/kernel/byterun/ @coq/vm-native-maintainers +/kernel/native* @coq/vm-native-maintainers +/kernel/vm* @coq/vm-native-maintainers +/kernel/vconv.* @coq/vm-native-maintainers -/kernel/sorts.* @SkySkimmer -/kernel/uGraph.* @SkySkimmer -/kernel/univ.* @SkySkimmer -# Secondary maintainer @mattam82 +/kernel/sorts.* @coq/universes-maintainers +/kernel/uGraph.* @coq/universes-maintainers +/kernel/univ.* @coq/universes-maintainers ########## Library ########## -/library/ @silene -# Secondary maintainer @gares +/library/ @coq/library-maintainers ########## Parser ########## @@ -135,33 +110,26 @@ azure-pipelines.yml @coq/ci-maintainers ########## Plugins ########## -/plugins/btauto/ @ppedrot -# Secondary maintainer @herbelin +/plugins/btauto/ @coq/btauto-maintainers -/plugins/cc/ @PierreCorbineau -# Secondary maintainer @herbelin +/plugins/cc/ @coq/cc-maintainers -/plugins/derive/ @aspiwack -# Secondary maintainer @ppedrot +/plugins/derive/ @coq/derive-maintainers -/plugins/extraction/ @maximedenes +/plugins/extraction/ @coq/extraction-maintainers -/plugins/firstorder/ @PierreCorbineau -# Secondary maintainer @herbelin +/plugins/firstorder/ @coq/firstorder-maintainers -/plugins/funind/ @forestjulien -# Secondary maintainer @Matafou +/plugins/funind/ @coq/funind-maintainers -/plugins/ltac/ @ppedrot -# Secondary maintainer @herbelin +/plugins/ltac/ @coq/ltac-maintainers /plugins/micromega/ @coq/micromega-maintainers /test-suite/micromega/ @coq/micromega-maintainers -/plugins/nsatz/ @thery -# Secondary maintainer @ppedrot +/plugins/nsatz/ @coq/nsatz-maintainers -/plugins/setoid_ring/ @coq/ring-maintainers +/plugins/setoid_ring/ @coq/ring-maintainers /plugins/ssrmatching/ @coq/ssreflect-maintainers /plugins/ssr/ @coq/ssreflect-maintainers @@ -169,190 +137,101 @@ azure-pipelines.yml @coq/ci-maintainers /plugins/syntax/ @coq/parsing-maintainers -/plugins/rtauto/ @PierreCorbineau -# Secondary maintainer @herbelin +/plugins/rtauto/ @coq/rtauto-maintainers -/user-contrib/Ltac2 @ppedrot +/user-contrib/Ltac2 @coq/ltac2-maintainers ########## Pretyper ########## -/pretyping/ @mattam82 -# Secondary maintainer @gares +/pretyping/ @coq/pretyper-maintainers -/pretyping/vnorm.* @maximedenes -/pretyping/nativenorm.* @maximedenes -# Secondary maintainer @ppedrot +/pretyping/vnorm.* @coq/vm-native-maintainers +/pretyping/nativenorm.* @coq/vm-native-maintainers ########## Pretty printer ########## -/printing/ @herbelin -# Secondary maintainer @mattam82 +/printing/ @coq/extensible-syntax-maintainers ########## Proof infrastructure ########## -/proofs/ @ppedrot -# Secondary maintainer @Zimmi48 +/proofs/ @coq/engine-maintainers ########## STM ########## -/stm/ @gares -/test-suite/interactive/ @gares -/test-suite/stm/ @gares -/test-suite/vio/ @gares -# Secondary maintainer @ejgallego +/stm/ @coq/stm-maintainers +/test-suite/interactive/ @coq/stm-maintainers +/test-suite/stm/ @coq/stm-maintainers +/test-suite/vio/ @coq/stm-maintainers ########## Tactics ########## -/tactics/ @ppedrot -# Secondary maintainer @mattam82 +/tactics/ @coq/tactics-maintainers -/tactics/class_tactics.* @mattam82 -/test-suite/typeclasses/ @mattam82 -# Secondary maintainer @ppedrot +/tactics/class_tactics.* @coq/typeclasses-maintainers +/test-suite/typeclasses/ @coq/typeclasses-maintainers ########## Standard library ########## -/theories/Arith/ @herbelin - -/theories/Bool/ @herbelin - -/theories/Classes/ @mattam82 -# Secondary maintainer @herbelin - -/theories/FSets/ @herbelin - -/theories/Init/ @ppedrot - -/theories/Lists/ @ppedrot - -/theories/Logic/ @herbelin -# Secondary maintainer @ppedrot - -/theories/MSets/ @herbelin - -/theories/NArith/ @herbelin - -/theories/Numbers/ @herbelin - -/theories/PArith/ @herbelin - -/theories/Program/ @mattam82 -# Secondary maintainer @herbelin - -/theories/QArith/ @herbelin - -/theories/Reals/ @coq/reals-library-maintainers +/theories/ @coq/stdlib-maintainers -/theories/Relations/ @mattam82 -# Secondary maintainer @ppedrot +/theories/Classes/ @coq/typeclasses-maintainers -/theories/Setoids/ @mattam82 -# Secondary maintainer @ppedrot +/theories/Reals/ @coq/reals-library-maintainers -/theories/Sets/ @herbelin - -/theories/Sorting/ @herbelin - -/theories/Strings/ @herbelin - -/theories/Structures/ @herbelin - -/theories/Unicode/ @herbelin - -/theories/Wellfounded/ @mattam82 - -/theories/ZArith/ @herbelin - -/theories/Compat/ @JasonGross -# Secondary maintainer @Zimmi48 - -/theories/Vectors/ @herbelin +/theories/Compat/ @coq/compat-maintainers ########## Tools ########## -/tools/coqdoc/ @silene -/test-suite/coqdoc/ @silene -# Secondary maintainer @mattam82 +/tools/coqdoc/ @coq/coqdoc-maintainers +/test-suite/coqdoc/ @coq/coqdoc-maintainers +/tools/coqwc* @coq/coqdoc-maintainers +/test-suite/coqwc/ @coq/coqdoc-maintainers -/tools/coq_makefile* @gares -/tools/CoqMakefile* @gares -/test-suite/coq-makefile/ @gares -# Secondary maintainer @silene +/tools/coq_makefile* @coq/coq-makefile-maintainers +/tools/CoqMakefile* @coq/coq-makefile-maintainers +/test-suite/coq-makefile/ @coq/coq-makefile-maintainers -/tools/coqdep* @ppedrot -# Secondary maintainer @maximedenes +/tools/TimeFileMaker.py @coq/coq-makefile-maintainers +/tools/make-*-tim*.py @coq/coq-makefile-maintainers -/tools/coq_tex* @silene -# Secondary maintainer @gares +/tools/coqdep* @coq/legacy-build-maintainers @coq/build-maintainers -/tools/coqwc* @silene -/test-suite/coqwc/ @silene +/tools/coq_tex* @silene # Secondary maintainer @gares -/tools/TimeFileMaker.py @JasonGross -/tools/make-both-single-timing-files.py @JasonGross -/tools/make-both-time-files.py @JasonGross -/tools/make-one-time-file.py @JasonGross - ########## Toplevel ########## -/toplevel/ @ejgallego -# Secondary maintainer @gares +/toplevel/ @coq/toplevel-maintainers +/topbin/ @coq/toplevel-maintainers ########## Vernacular ########## -/vernac/ @mattam82 -# Secondary maintainer @maximedenes +/vernac/ @coq/vernac-maintainers -/vernac/metasyntax.* @coq/parsing-maintainers +/vernac/metasyntax.* @coq/parsing-maintainers -########## Test suite ########## +/vernac/classes.* @coq/typeclasses-maintainers -/test-suite/Makefile @gares -/test-suite/_CoqProject @gares -/test-suite/README.md @gares -# Secondary maintainer @SkySkimmer +########## Test suite ########## -/test-suite/report.sh @SkySkimmer +/test-suite/Makefile @coq/test-suite-maintainers +/test-suite/README.md @coq/test-suite-maintainers +/test-suite/report.sh @coq/test-suite-maintainers +/test-suite/unit-tests/src/ @coq/test-suite-maintainers /test-suite/complexity/ @herbelin -/test-suite/unit-tests/src/ @jfehrle -# Secondary maintainer @SkySkimmer - -/test-suite/success/Compat*.v @JasonGross +/test-suite/success/Compat*.v @coq/compat-maintainers ########## Developer tools ########## -/dev/tools/backport-pr.sh @Zimmi48 -# Secondary maintainer @maximedenes - -/dev/tools/change-header @herbelin - -/dev/tools/check-eof-newline.sh @SkySkimmer - -/dev/tools/coqdev.el @SkySkimmer - -/dev/tools/github-check-prs.py @SkySkimmer - -/dev/tools/make-changelog.sh @SkySkimmer -# Secondary maintainer @Zimmi48 - -/dev/tools/merge-pr.sh @maximedenes -# Secondary maintainer @gares - -/dev/tools/pre-commit @SkySkimmer - -/dev/tools/check-owners*.sh @SkySkimmer -# Secondary maintainer @maximedenes +/dev/tools/ @coq/dev-tools-maintainers -/dev/tools/update-compat.py @JasonGross -/test-suite/tools/update-compat/ @JasonGross -# Secondary maintainer @Zimmi48 +/dev/tools/update-compat.py @coq/compat-maintainers +/test-suite/tools/update-compat/ @coq/compat-maintainers ########## Dune ########## -/.ocamlinit @ejgallego -*dune* @ejgallego -*.opam @ejgallego -# Secondary maintainer @Zimmi48 +/.ocamlinit @coq/build-maintainers +*dune* @coq/build-maintainers +*.opam @coq/build-maintainers 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 6344b51702..3a626796a6 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-12-03-V81" + 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 @@ -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" @@ -567,6 +578,8 @@ library:ci-bedrock2: name: "$CI_JOB_NAME" paths: - _build_ci + variables: + NJOBS: "1" library:ci-color: extends: .ci-template-flambda 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 e26103cedd..a0139e422d 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -42,6 +42,7 @@ well. - [Becoming a maintainer](#becoming-a-maintainer) - [Reviewing pull requests](#reviewing-pull-requests) - [Merging pull requests](#merging-pull-requests) + - [Additional notes for pull request reviewers and assignees](#additional-notes-for-pull-request-reviewers-and-assignees) - [Core development team](#core-development-team) - [Release management](#release-management) - [Packaging Coq](#packaging-coq) @@ -56,6 +57,7 @@ well. - [Git documentation, tips and tricks](#git-documentation-tips-and-tricks) - [GitHub documentation, tips and tricks](#github-documentation-tips-and-tricks) - [GitLab documentation, tips and tricks](#gitlab-documentation-tips-and-tricks) + - [Merge script dependencies](#merge-script-dependencies) - [Coqbot](#coqbot) - [Online forum and chat to talk to developers](#online-forum-and-chat-to-talk-to-developers) - [Coq remote working groups](#coq-remote-working-groups) @@ -430,7 +432,7 @@ and merge when it is the case (you can ping them if the PR is ready from your side but nothing happens for a few days). After your PR is accepted and merged, it may get backported to a -stable branch if appropriate, and will eventually make it to a +release branch if appropriate, and will eventually make it to a release. You do not have to worry about this, it is the role of the assignee and the release manager to do so (see Section [Release management](#release-management)). The milestone should give you an @@ -497,6 +499,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`. @@ -731,28 +738,65 @@ spending time in vain. ### Merging pull requests ### -Our [CODEOWNERS][] file associates a team of maintainers, or a -principal and secondary maintainers, to each component. They will be -responsible for self-assigning and merging PRs (they didn't co-author) -that change this component. When several components are changed in -significant ways, at least a maintainer (other than the PR author) -must approve the PR for each affected component before it can be -merged, and one of them has to assign the PR, and merge it when it is -time. Before merging, the assignee must also select a milestone for -the PR (see also Section [Release management](#release-management)). - -If you feel knowledgeable enough to maintain a component, and have a -good track record of contributing to it, we would be happy to have you -join one of the maintainer teams. - -The merging process is described in more details in [this -document][MERGING]. - -The people with merging powers (either because listed as a principal -or secondary maintainer in [CODEOWNERS][], or because member of a -maintainer team), are the members of the **@coq/pushers** team -([member list][coq-pushers] only visible to the Coq organization -members because of a limitation of GitHub). +Our [CODEOWNERS][] file associates a team of maintainers to each +component. When a PR is opened (or a draft PR is marked as ready for +review), GitHub will automatically request reviews to maintainer teams +of affected components. As soon as it is the case, one available +member of a team that was requested a review should self-assign the +PR, and will act as its shepherd from then on. + +The PR assignee is responsible for making sure that all the proposed +changes have been reviewed by relevant maintainers, that change +requests have been implemented, that CI is passing, and eventually +will be the one who merges the PR. + +*If you have already frequently contributed to a component, we would +be happy to have you join one of the maintainer teams.* + +The complete list of maintainer teams is available [here][coq-pushers] +(link only accessible to people who are already members of the Coq +organization, because of a limitation of GitHub). + +#### Additional notes for pull request reviewers and assignees #### + +- NEVER USE GITHUB'S MERGE BUTTON. Instead, we provide a script + [`dev/tools/merge-pr.sh`][merge-pr] which you should use to merge a + PR (requires having configured gpg with git). In the future, we + will also support merging through a command to **@coqbot**. + +- PR authors or co-authors cannot review, self-assign, or merge the PR + they contributed to. However, reviewers may push small fixes to the + PR branch to facilitate the PR integration. + +- Only PRs targetting the `master` branch can be merged by a + maintainer. For PRs targetting a release branch, the assignee + should always be the RM. + +- Before merging, the assignee must also select a milestone for the PR + (see also Section [Release management](#release-management)). + +- To know which files you are a maintainer of, you can look for black + shields icons in the "Files changed" tab. Alternatively, you may + use the [`dev/tools/check-owners-pr.sh`][check-owners] script for + the same purpose. + +  + +- Sometimes, it is a good practice to announce the intent to merge one + or several days in advance when unsure that everyone had a chance to + voice their opinion, or to finish reviewing the PR. + +- When a PR has [overlays][user-overlays], then: + + - the overlays that are backward-compatible (normally the case for + overlays fixing Coq code) should have been merged *before* the PR + can be merged; + + - the overlays that are not backward-compatible (normally only the + case for overlays fixing OCaml code) should be merged *just after* + the PR has been merged (and thus the assignee should ping the + maintainers of the affected projects to ask them to merge the + overlays). ### Core development team ### @@ -778,23 +822,23 @@ on the wiki. Development of new features, refactorings, deprecations and clean-ups always happens on `master`. Stabilization starts by branching -(creating a new stable `v...` branch from the current `master`), which +(creating a new `v...` release branch from the current `master`), which marks the beginning of a feature freeze (new features will continue to be merged into `master` but won't make it for the upcoming major release, but only for the next one). -After branching, most changes are introduced in the stable branch by a +After branching, most changes are introduced in the release branch by a backporting process. PR authors and assignee can signal a desire to have a PR backported by selecting an appropriate milestone. Most of the time, the choice of milestone is between two options: the next major version that has yet to branch from `master`, or the next -version (beta, final, or patch-level release) of the active stable +version (beta, final, or patch-level release) of the active release branch. In the end, it is the RM who decides whether to follow or not the recommendation of the PR assignee, and who backports PRs to the -stable branch. +release branch. -Very specific changes that are only relevant for the stable branch and -not for the `master` branch can result in a PR targetting the stable +Very specific changes that are only relevant for the release branch and +not for the `master` branch can result in a PR targetting the release branch instead of `master`. In this case, the RM is the only one who can merge the PR, and they may even do so if they are the author of the PR. Examples of such PRs include bug fixes to a feature that has @@ -803,13 +847,13 @@ number in preparation for the next release. Some automation is in place to help the RM in their task: a GitHub project is created at branching time to manage PRs to backport; when a -PR is merged in a milestone corresponding to the stable branch, our +PR is merged in a milestone corresponding to the release branch, our bot will add this PR in a "Request inclusion" column in this project; the RM can browse through the list of PRs waiting to be backported in this column, possibly reject some of them by simply removing the PR from the column (in which case, the bot will update the PR milestone), and proceed to backport others; when a backported PR is pushed to the -stable branch, the bot moves the PR from the "Request inclusion" +release branch, the bot moves the PR from the "Request inclusion" column to a "Shipped" column. More information about the RM tasks can be found in the [release @@ -865,7 +909,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, @@ -909,6 +953,16 @@ procedure. We also have a benchmarking infrastructure, which is documented [on the wiki][jenkins-doc]. +##### Restarting failed jobs ##### + +When CI has a few failures which look spurious, restarting the +corresponding jobs is a good way to ensure this was indeed the case. +You can restart jobs on Azure from the "Checks" tab on GitHub. To +restart a job on GitLab CI, you should sign into GitLab (this can be +done using a GitHub account); if you are part of the [Coq organization +on GitLab](https://gitlab.com/coq), you should see a "Retry" button; +otherwise, send a request to join the organization. + #### Code owners, issue and pull request templates #### These files can be found in the [`.github`](.github) directory. The @@ -1024,6 +1078,22 @@ restart failing CI jobs. GitLab too has [extensive documentation][GitLab-doc], in particular on configuring CI. +#### Merge script dependencies #### + +The merge script passes option `-S` to `git merge` to ensure merge +commits are signed. Consequently, it depends on the GnuPG command +utility being installed and a GPG key being available. Here is a +short documentation on how to use GPG, git & GitHub: +https://help.github.com/articles/signing-commits-with-gpg/. + +The script depends on a few other utilities. If you are a Nix user, +the simplest way of getting them is to run `nix-shell` first. + +**Note for homebrew (MacOS) users:** it has been reported that +installing GnuPG is not out of the box. Installing explicitly +`pinentry-mac` seems important for typing of passphrase to work +correctly (see also this [Stack Overflow Q-and-A][pinentry-mac]). + #### Coqbot #### Our bot sources can be found at <https://github.com/coq/bot>. Its @@ -1064,6 +1134,7 @@ can be found [on the wiki][wiki-CUDW]. [add-contributor]: https://github.com/orgs/coq/teams/contributors/members?add=true [api-doc]: https://coq.github.io/doc/master/api/ [CEP]: https://github.com/coq/ceps +[check-owners]: dev/tools/check-owners-pr.sh [CI-README-developers]: dev/ci/README-developers.md [CI-README-users]: dev/ci/README-users.md [Code-of-Conduct]: CODE_OF_CONDUCT.md @@ -1079,7 +1150,7 @@ can be found [on the wiki][wiki-CUDW]. [Coq-documentation]: https://coq.inria.fr/documentation [Coq-issue-tracker]: https://github.com/coq/coq/issues [Coq-package-index]: https://coq.inria.fr/packages -[coq-pushers]: https://github.com/orgs/coq/teams/pushers/members +[coq-pushers]: https://github.com/orgs/coq/teams/pushers/teams [coq-repository]: https://github.com/coq/coq [Coq-website-repository]: https://github.com/coq/www [debugging-doc]: dev/doc/debugging.md @@ -1113,7 +1184,7 @@ can be found [on the wiki][wiki-CUDW]. [jenkins-doc]: https://github.com/coq/coq/wiki/Jenkins-(automated-benchmarking) [kind-documentation]: https://github.com/coq/coq/issues?q=is%3Aopen+is%3Aissue+label%3A%22kind%3A+documentation%22 [master-doc]: https://coq.github.io/doc/master/refman/ -[MERGING]: dev/doc/MERGING.md +[merge-pr]: dev/tools/merge-pr.sh [needs-benchmarking]: https://github.com/coq/coq/labels/needs%3A%20benchmarking [needs-changelog]: https://github.com/coq/coq/labels/needs%3A%20changelog%20entry [needs-documentation]: https://github.com/coq/coq/labels/needs%3A%20documentation @@ -1128,6 +1199,7 @@ can be found [on the wiki][wiki-CUDW]. [Octobox]: http://octobox.io/ [old-style-guide]: dev/doc/style.txt [other-standard-libraries]: https://github.com/coq/stdlib2/wiki/Other-%22standard%22-libraries +[pinentry-mac]: https://stackoverflow.com/questions/39494631/gpg-failed-to-sign-the-data-fatal-failed-to-write-commit-object-git-2-10-0 [plugin-tutorial]: doc/plugin_tutorial [ProofGeneral-issues]: https://github.com/ProofGeneral/PG/issues [Reddit]: https://www.reddit.com/r/Coq/ diff --git a/INSTALL b/INSTALL deleted file mode 100644 index 31758203fe..0000000000 --- a/INSTALL +++ /dev/null @@ -1,323 +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 - - 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 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 49bdea6d9c..377dbd9b7e 100644 --- a/META.coq.in +++ b/META.coq.in @@ -561,4 +561,19 @@ package "plugins" ( plugin(byte) = "ssreflect_plugin.cmo" plugin(native) = "ssreflect_plugin.cmxs" ) + + package "ltac2" ( + + description = "Coq Ltac2 Plugin" + version = "8.12" + + requires = "coq.plugins.ltac" + directory = "../user-contrib/Ltac2" + + archive(byte) = "ltac2_plugin.cmo" + archive(native) = "ltac2_plugin.cmx" + + plugin(byte) = "ltac2_plugin.cmo" + plugin(native) = "ltac2_plugin.cmxs" + ) ) @@ -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 '*.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.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.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..fe7ca7c36f 100644 --- a/Makefile.vofiles +++ b/Makefile.vofiles @@ -31,9 +31,9 @@ ALLMODS:=$(call vo_to_mod,$(ALLVO:.$(VO)=.vo)) # Converting a stdlib filename into native compiler filenames # Used for install targets -vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%, N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.cm*)))))) +vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%,N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.cm*)))))) -vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%, N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.o)))))) +vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%,N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.o)))))) ifdef QUICK GLOBFILES:= @@ -49,7 +49,6 @@ endif else NATIVEFILES := endif -LIBFILES:=$(ALLVO:.$(VO)=.vo) $(ALLVO:.$(VO)=.vos) $(NATIVEFILES) $(VFILES) $(GLOBFILES) # For emacs: # Local Variables: @@ -31,6 +31,9 @@ environment for semi-interactive development of machine-checked proofs. [![Homebrew package][homebrew-badge]][homebrew-link] [![nixpkgs unstable package][nixpkgs-badge]][nixpkgs-link] +[![Docker Hub package][dockerhub-badge]][dockerhub-link] +[![latest dockerized version][coqorg-badge]][coqorg-link] + [repology-badge]: https://repology.org/badge/latest-versions/coq.svg [repology-link]: https://repology.org/metapackage/coq/versions @@ -52,9 +55,15 @@ environment for semi-interactive development of machine-checked proofs. [nixpkgs-badge]: https://repology.org/badge/version-for-repo/nix_unstable/coq.svg [nixpkgs-link]: https://nixos.org/nixos/packages.html#coq +[dockerhub-badge]: https://img.shields.io/docker/automated/coqorg/coq.svg +[dockerhub-link]: https://hub.docker.com/r/coqorg/coq "Automated build on Docker Hub" + +[coqorg-badge]: https://images.microbadger.com/badges/version/coqorg/coq.svg +[coqorg-link]: https://github.com/coq-community/docker-coq/wiki#docker-coq-images "Docker images of Coq" + 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 +79,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 diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 31dcae0f82..aba2b05037 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -19,7 +19,7 @@ jobs: powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" SET CYGROOT=C:\cygwin64 SET CYGCACHE=%CYGROOT%\var\cache\setup - setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python2 -P python3 + setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python3 SET TARGET_ARCH=x86_64-w64-mingw32 SET CD_MFMT=%cd:\=/% 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/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/default.nix b/default.nix index 6a7a98aa5e..cfadca54d2 100644 --- a/default.nix +++ b/default.nix @@ -41,7 +41,6 @@ stdenv.mkDerivation rec { buildInputs = [ hostname - python2 # update-compat.py python3 time # coq-makefile timing tools dune ] @@ -66,7 +65,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/base_include b/dev/base_include index 4841db8953..96a867475d 100644 --- a/dev/base_include +++ b/dev/base_include @@ -60,11 +60,11 @@ open Cases open Pattern open Patternops open Cbv -open Classops +open Coercionops open Arguments_renaming open Pretyping open Cbv -open Classops +open Coercionops open Clenv open Clenvtac open Constr_matching @@ -134,7 +134,7 @@ open Tacticals open Tactics open Eqschemes -open Class +open ComCoercion open ComDefinition open Indschemes open Ind_tables diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 82cc7a7117..859b3e3166 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -921,69 +921,6 @@ function make_gtk_sourceview3 { build_conf_make_inst https://download.gnome.org/sources/gtksourceview/3.24 gtksourceview-3.24.11 tar.xz make_arch_pkg_config } -##### FLEXDLL FLEXLINK ##### - -# Note: there is a circular dependency between flexlink and ocaml (resolved in Ocaml 4.03.) -# For MinGW it is not even possible to first build an Ocaml without flexlink support, -# Because Makefile.nt doesn't support this. So we have to use a binary flexlink. -# One could of cause do a bootstrap run ... - -# Install flexdll objects - -function install_flexdll { - cp flexdll.h "$PREFIXMINGW/include" - if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then - cp flexdll*_mingw.o "/usr/$TARGET_ARCH/bin" - cp flexdll*_mingw.o "$PREFIXOCAML/bin" - elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then - cp flexdll*_mingw64.o "/usr/$TARGET_ARCH/bin" - cp flexdll*_mingw64.o "$PREFIXOCAML/bin" - else - echo "Unknown target architecture" - return 1 - fi -} - -# Install flexlink - -function install_flexlink { - cp flexlink.exe "/usr/$TARGET_ARCH/bin" - - cp flexlink.exe "$PREFIXOCAML/bin" -} - -# Get binary flexdll flexlink for building OCaml -# An alternative is to first build an OCaml without shared library support and build flexlink with it - -function get_flex_dll_link_bin { - if build_prep https://github.com/alainfrisch/flexdll/releases/download/0.37/ flexdll-bin-0.37 zip 1 ; then - install_flexdll - install_flexlink - build_post - fi -} - -# Build flexdll and flexlink from sources after building OCaml - -function make_flex_dll_link { - if build_prep https://github.com/alainfrisch/flexdll/archive 0.37 tar.gz 1 flexdll-0.37 ; then - if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then - # shellcheck disable=SC2086 - log1 make $MAKE_OPT build_mingw flexlink.exe - elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then - # shellcheck disable=SC2086 - log1 make $MAKE_OPT build_mingw64 flexlink.exe - else - echo "Unknown target architecture" - return 1 - fi - install_flexdll - install_flexlink - log2 make clean - build_post - fi -} - ##### LN replacement ##### # Note: this does support symlinks, but symlinks require special user rights on Windows. @@ -1016,39 +953,22 @@ function make_arch_pkg_config { ##### OCAML ##### function make_ocaml { - get_flex_dll_link_bin - if build_prep https://github.com/ocaml/ocaml/archive 4.07.1 tar.gz 1 ocaml-4.07.1 ; then - # See README.win32.adoc - cp config/m-nt.h byterun/caml/m.h - cp config/s-nt.h byterun/caml/s.h - if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then - cp config/Makefile.mingw config/Makefile - elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then - cp config/Makefile.mingw64 config/Makefile - else - echo "Unknown target architecture" - return 1 - fi + if build_prep https://github.com/ocaml/ocaml/archive 4.08.1 tar.gz 1 ocaml-4.08.1 ; then + # see https://github.com/ocaml/ocaml/blob/4.08/README.win32.adoc - # Prefix is fixed in make file - replace it with the real one - # TODO: this might not work if PREFIX contains spaces - sed -i "s|^PREFIX=.*|PREFIX=$PREFIXOCAML|" config/Makefile + # get flexdll sources into folder ./flexdll + get_expand_source_tar https://github.com/alainfrisch/flexdll/archive 0.37 tar.gz 1 flexdll-0.37 flexdll # We don't want to mess up Coq's directory structure so put the OCaml library in a separate folder - # If we refer to the make variable ${PREFIX} below, camlp5 ends up having the wrong path: - # D:\bin\coq64_buildtest_abs_ocaml4\bin>ocamlc -where => D:/bin/coq64_buildtest_abs_ocaml4/libocaml - # D:\bin\coq64_buildtest_abs_ocaml4\bin>camlp4 -where => ${PREFIX}/libocaml\camlp4 - # So we put an explicit path in there - sed -i "s|^LIBDIR=.*|LIBDIR=$PREFIXOCAML/libocaml|" config/Makefile - - # Note: ocaml doesn't support -j 8, so don't pass MAKE_OPT - # I verified that 4.02.3 still doesn't support parallel build - log2 make world -f Makefile.nt - log2 make bootstrap -f Makefile.nt - log2 make opt -f Makefile.nt - log2 make opt.opt -f Makefile.nt - log2 make install -f Makefile.nt - # TODO log2 make clean -f Makefile.nt Temporarily disabled for ocamlbuild development + logn configure ./configure --build=i686-pc-cygwin --host="$TARGET_ARCH" --prefix="$PREFIXOCAML" --libdir="$PREFIXOCAML/libocaml" + + log2 make flexdll $MAKE_OPT + # Note the next command might change after 4.09.x to just make + # see https://github.com/ocaml/ocaml/blob/4.09/README.win32.adoc + # compare to https://github.com/ocaml/ocaml/blob/4.10/README.win32.adoc + log2 make world.opt $MAKE_OPT + log2 make flexlink.opt $MAKE_OPT + log2 make install $MAKE_OPT # Move license files and other into into special folder if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then @@ -1065,7 +985,6 @@ function make_ocaml { build_post fi - make_flex_dll_link } ##### OCAML EXTRA TOOLS ##### @@ -1099,7 +1018,7 @@ function make_num { function make_ocamlbuild { make_ocaml - if build_prep https://github.com/ocaml/ocamlbuild/archive 0.12.0 tar.gz 1 ocamlbuild-0.12.0; then + if build_prep https://github.com/ocaml/ocamlbuild/archive 0.14.0 tar.gz 1 ocamlbuild-0.14.0; then log2 make configure OCAML_NATIVE=true OCAMLBUILD_PREFIX=$PREFIXOCAML OCAMLBUILD_BINDIR=$PREFIXOCAML/bin OCAMLBUILD_LIBDIR=$PREFIXOCAML/lib log1 make $MAKE_OPT log2 make install @@ -1112,6 +1031,7 @@ function make_ocamlbuild { function make_findlib { make_ocaml make_ocamlbuild + # Note: latest is 1.8.1 but http://projects.camlcity.org/projects/dl/findlib-1.8.1/doc/README says this is for OCaml 4.09 if build_prep https://opam.ocaml.org/1.2.2/archives ocamlfind.1.8.0+opam tar.gz 1 ; then logn configure ./configure -bindir "$PREFIXOCAML\\bin" -sitelib "$PREFIXOCAML\\libocaml\\site-lib" -config "$PREFIXOCAML\\etc\\findlib.conf" # Note: findlib doesn't support -j 8, so don't pass MAKE_OPT @@ -1385,7 +1305,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 87122e0fb5..f04de0ce6c 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -209,7 +209,7 @@ ######################################################################## # bedrock2 ######################################################################## -: "${bedrock2_CI_REF:=master}" +: "${bedrock2_CI_REF:=tested}" : "${bedrock2_CI_GITURL:=https://github.com/mit-plv/bedrock2}" : "${bedrock2_CI_ARCHIVEURL:=${bedrock2_CI_GITURL}/archive}" 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/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 8907843b12..b8f9d99702 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-12-03-V81" +# CACHEKEY: "bionic_coq-V2019-12-08-V82" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -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" \ @@ -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.3" + 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/11293-ppedrot-rename-class-files.sh b/dev/ci/user-overlays/11293-ppedrot-rename-class-files.sh new file mode 100644 index 0000000000..a95170a455 --- /dev/null +++ b/dev/ci/user-overlays/11293-ppedrot-rename-class-files.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "11293" ] || [ "$CI_BRANCH" = "rename-class-files" ]; then + + elpi_CI_REF=rename-class-files + elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi + + mtac2_CI_REF=rename-class-files + mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 + +fi diff --git a/dev/ci/user-overlays/11338-ppedrot-rm-global-uses-evd.sh b/dev/ci/user-overlays/11338-ppedrot-rm-global-uses-evd.sh new file mode 100644 index 0000000000..f41271804a --- /dev/null +++ b/dev/ci/user-overlays/11338-ppedrot-rm-global-uses-evd.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "11338" ] || [ "$CI_BRANCH" = "rm-global-uses-evd" ]; then + + unicoq_CI_REF=rm-global-uses-evd + unicoq_CI_GITURL=https://github.com/ppedrot/unicoq + + equations_CI_REF=rm-global-uses-evd + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + +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/MERGING.md b/dev/doc/MERGING.md deleted file mode 100644 index 66f5a96802..0000000000 --- a/dev/doc/MERGING.md +++ /dev/null @@ -1,177 +0,0 @@ -# Merging changes in Coq - -This document describes how patches, submitted as pull requests (PRs) on the -`master` branch, should be merged into the main repository -(https://github.com/coq/coq). - -## Code owners - -The [CODEOWNERS](../../.github/CODEOWNERS) file defines owners for each part of -the code. Sometime there is one principal maintainer and one or several -secondary maintainer(s). Sometimes, it is a team of code owners and all of its -members act as principal maintainers for the component. - -When a PR is submitted, GitHub will automatically ask the principal -maintainer (or the code owner team) for a review. If the PR touches several -parts, all the corresponding owners will be asked for a review. - -Maintainers are never assigned as reviewer on their own PRs. - -If a principal maintainer submits a PR or is a co-author of a PR that is -submitted and this PR changes the component they own, they must request a -review from a secondary maintainer. They can also delegate the review if they -know they are not available to do it. - -## Reviewing - -When maintainers receive a review request, they are expected to: - -* Put their name in the assignee field, if they are in charge of the component - that is the main target of the patch (or if they are the only maintainer asked - to review the PR). -* Review the PR, approve it or request changes. -* If they are the assignee, check if all reviewers approved the PR. If not, - regularly ping the author (if changes should be implemented) or the reviewers - (if reviews are missing). The assignee ensures that any requests for more - discussion have been granted. When the discussion has converged and ALL - REVIEWERS(*) have approved the PR, the assignee is expected to follow the merging - process described below. - -To know what files you are a code owner of in a large PR, you can run -`dev/tools/check-owners-pr.sh xxxx`. Results are unfortunately imperfect. - -When a PR received lots of comments or if the PR has not been opened for long -and the assignee thinks that some other developers might want to comment, -it is recommended that they announce their intention to merge and wait a full -working day (or more if deemed useful) before the actual merge, as a sort of -last call for comments. - -In all cases, maintainers can delegate reviews to the other maintainers, -except if it would lead to a maintainer reviewing their own patch. - -A maintainer is expected to be reasonably reactive, but no specific timeframe is -given for reviewing. - -When none of the maintainers have commented nor self-assigned a PR in a delay -of five working days, any maintainer of another component who feels comfortable -reviewing the PR can assign it to themselves. To prevent misunderstandings, -maintainers should not hesitate to announce in advance when they shall be -unavailable for more than five working days. - -(*) In case a component is touched in a trivial way (adding/removing one file in -a `Makefile`, etc), or by applying a systematic refactoring process (global -renaming for instance) that has been reviewed globally, the assignee can -say in a comment they think a review is not required from every code owner and -proceed with the merge. - -### Breaking changes - -If the PR breaks compatibility of some external projects in CI, then fixes to -those external projects should have been prepared (cf. the relevant sub-section -in the [CI README](../ci/README.md#Breaking-changes) and the PR can be tested -with these fixes thanks to ["overlays"](../ci/user-overlays/README.md). - -Moreover the PR author *must* add an entry to the [unreleased -changelog](../../doc/changelog/README.md) or to the -[`dev/doc/changes.md`](changes.md) file. - -If overlays are missing, ask the author to prepare them and label the PR with -the [needs: overlay](https://github.com/coq/coq/labels/needs%3A%20overlay) label. - -When fixes are ready, there are two cases to consider: - -- For patches that are backward compatible (best scenario), you should get the - external project maintainers to integrate them before merging the PR. -- For patches that are not backward compatible (which is often the case when - patching plugins after an update to the Coq API), you can proceed to merge - the PR and then notify the external project maintainers they can merge the - patch. - -## Merging - -Once all reviewers approved the PR, the assignee is expected to check that CI -completed without relevant failures, and that the PR comes with appropriate -documentation and test cases. If not, they should leave a comment on the PR and -put the appropriate label. Otherwise, they are expected to merge the PR using the -[merge script](../tools/merge-pr.sh). - -When CI has a few failures which look spurious, restarting the corresponding -jobs is a good way of ensuring this was indeed the case. -To restart a job on AppVeyor, you should connect using your GitHub -account; being part of the Coq organization on GitHub should give you the -permission to do so. -To restart a job on GitLab CI, you should sign into GitLab (this can be done -using a GitHub account); if you are part of the -[Coq organization on GitLab](https://gitlab.com/coq), you should see a "Retry" -button; otherwise, send a request to join the organization. - -When the PR has conflicts, the assignee can either: -- ask the author to rebase the branch, fixing the conflicts -- warn the author that they are going to rebase the branch, and push to the - branch directly - -In both cases, CI should be run again. - -In some rare cases (e.g. the conflicts are in the `CHANGES.md` file and the PR -is not a candidate for backporting), it is ok to fix -the conflicts in the merge commit (following the same steps as below), and push -to `master` directly. DON'T USE the GitHub interface to fix these conflicts. - -To merge the PR proceed in the following way -``` -$ git checkout master -$ git pull -$ dev/tools/merge-pr.sh XXXX -$ git push upstream -``` -where `XXXX` is the number of the PR to be merged and `upstream` is the name -of your remote pointing to `git@github.com:coq/coq.git`. -Note that you are only supposed to merge PRs into `master`. PRs should rarely -target the stable branch, but when it is the case they are the responsibility -of the release manager. - -This script conducts various checks before proceeding to merge. Don't bypass them -without a good reason to, and in that case, write a comment in the PR thread to -explain the reason. - -Maintainers MUST NOT merge their own patches. - -DON'T USE the GitHub interface for merging, since it will prevent the automated -backport script from operating properly, generates bad commit messages, and a -messy history when there are conflicts. - -### Merge script dependencies - -The merge script passes option `-S` to `git merge` to ensure merge commits -are signed. Consequently, it depends on the GnuPG command utility being -installed and a GPG key being available. Here is a short documentation on -how to use GPG, git & GitHub: https://help.github.com/articles/signing-commits-with-gpg/. - -The script depends on a few other utilities. If you are a Nix user, the -simplest way of getting them is to run `nix-shell` first. - -**Note for homebrew (MacOS) users:** it has been reported that installing GnuPG -is not out of the box. Installing explicitly "pinentry-mac" seems important for -typing of passphrase to work correctly (see also this -[Stack Overflow Q-and-A](https://stackoverflow.com/questions/39494631/gpg-failed-to-sign-the-data-fatal-failed-to-write-commit-object-git-2-10-0)). - -## Addendum for organization admins - -### Adding a new code owner individual - -If someone is added to the [`CODEOWNERS`](../../.github/CODEOWNERS) file and -they did not have merging rights before, they should also be added to the -**@coq/pushers** team. You may do so using -[this link](https://github.com/orgs/coq/teams/pushers/members?add=true). - -Before adding someone to the **@coq/pushers** team, you should ensure that they -have read the present merging documentation, and explicitly tell them not to -use the merging button on the GitHub web interface. - -### Adding a new code owner team - -Go to [that page](https://github.com/orgs/coq/teams/pushers/teams) and click on -the green "Add a team" button. Use a "-maintainer" suffix for the name of your -team. You may then add new members to this team (you don't need to add them to -the **@coq/pushers** team first as this will be done automatically because the -team you created is a sub-team of **@coq/pushers**). 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/critical-bugs b/dev/doc/critical-bugs index 67becb251a..2d187f7bae 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -255,6 +255,18 @@ Conversion machines GH issue number: #9925 risk: + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: broken long multiplication primitive integer emulation layer on 32 bits + introduced: e43b176 + impacted released versions: 8.10.0, 8.10.1, 8.10.2 + impacted development branches: 8.11 + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: 4e176a7 + found by: Soegtrop, Melquiond + exploit: test-suite/bugs/closed/bug_11321.v + GH issue number: #11321 + risk: critical, as any BigN computation on 32-bit architectures is wrong + component: "native" conversion machine (translation to OCaml which compiles to native code) summary: translation of identifier from Coq to OCaml was not bijective, leading to identify True and False introduced: V8.5 diff --git a/dev/doc/shield-icon.png b/dev/doc/shield-icon.png Binary files differnew file mode 100644 index 0000000000..629e51a819 --- /dev/null +++ b/dev/doc/shield-icon.png 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/merge-pr.sh b/dev/tools/merge-pr.sh index c0a3eeb11c..a888998ebf 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -137,7 +137,8 @@ if [ "$LOCAL_BRANCH_COMMIT" != "$UPSTREAM_COMMIT" ]; then else error "Local branch is not up-to-date with ${REMOTE}." error "Pull before merging." - ask_confirmation + # This check should never be bypassed. + exit 1 fi fi diff --git a/dev/top_printers.ml b/dev/top_printers.ml index f7f2bcdcff..835c20a4f7 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -47,7 +47,7 @@ let ppmind kn = pp(MutInd.debug_print kn) let ppind (kn,i) = pp(MutInd.debug_print kn ++ str"," ++int i) let ppsp sp = pp(pr_path sp) let ppqualid qid = pp(pr_qualid qid) -let ppclindex cl = pp(Classops.pr_cl_index cl) +let ppclindex cl = pp(Coercionops.pr_cl_index cl) let ppscheme k = pp (Ind_tables.pr_scheme_kind k) let prrecarg = function diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 5a2144f996..133326523b 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -29,7 +29,7 @@ val ppind : Names.inductive -> unit val ppsp : Libnames.full_path -> unit val ppqualid : Libnames.qualid -> unit -val ppclindex : Classops.cl_index -> unit +val ppclindex : Coercionops.cl_index -> unit val ppscheme : 'a Ind_tables.scheme_kind -> unit 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/11361-fix-11360-discharge-template-param-var.rst b/doc/changelog/01-kernel/11361-fix-11360-discharge-template-param-var.rst new file mode 100644 index 0000000000..8c84648aa7 --- /dev/null +++ b/doc/changelog/01-kernel/11361-fix-11360-discharge-template-param-var.rst @@ -0,0 +1,4 @@ +- **Fixed:** `#11360 <https://github.com/issues/11360>`_ + Broken section closing when a template polymorphic inductive type depends on + a section variable through its parameters (`#11361 + <https://github.com/coq/coq/pull/11361>`_, by Gaëtan Gilbert). 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/11233-master+fix11231-missing-variable-pattern-matching-decompilation.rst b/doc/changelog/02-specification-language/11233-master+fix11231-missing-variable-pattern-matching-decompilation.rst new file mode 100644 index 0000000000..941469d698 --- /dev/null +++ b/doc/changelog/02-specification-language/11233-master+fix11231-missing-variable-pattern-matching-decompilation.rst @@ -0,0 +1,6 @@ +- **Fixed:** + A dependency was missing when looking for default clauses in the + algorithm for printing pattern matching clauses (`#11233 + <https://github.com/coq/coq/pull/11233>`_, by Hugo Herbelin, fixing + `#11231 <https://github.com/coq/coq/pull/11231>`_, reported by Barry + Jay). 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/10760-more-rapply.rst b/doc/changelog/04-tactics/10760-more-rapply.rst new file mode 100644 index 0000000000..2815f8af8a --- /dev/null +++ b/doc/changelog/04-tactics/10760-more-rapply.rst @@ -0,0 +1,7 @@ +- The tactic :tacn:`rapply` in :g:`Coq.Program.Tactics` now handles + arbitrary numbers of underscores and takes in a :g:`uconstr`. In + rare cases where users were relying on :tacn:`rapply` inserting + exactly 15 underscores and no more, due to the lemma having a + completely unspecified codomain (and thus allowing for any number of + underscores), the tactic will now instead loop. (`#10760 + <https://github.com/coq/coq/pull/10760>`_, by Jason Gross) 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/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/04-tactics/11288-omega+depr.rst b/doc/changelog/04-tactics/11288-omega+depr.rst new file mode 100644 index 0000000000..2832e6db61 --- /dev/null +++ b/doc/changelog/04-tactics/11288-omega+depr.rst @@ -0,0 +1,6 @@ +- **Removed:** + The undocumented ``omega with`` tactic variant has been removed, + using ``lia`` is the recommended replacement, tho the old semantics + of ``omega with *`` can be recovered with ``zify; omega`` + (`#11288 <https://github.com/coq/coq/pull/11288>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/04-tactics/11337-omega-with-depr.rst b/doc/changelog/04-tactics/11337-omega-with-depr.rst new file mode 100644 index 0000000000..25e929e030 --- /dev/null +++ b/doc/changelog/04-tactics/11337-omega-with-depr.rst @@ -0,0 +1,6 @@ +- **Deprecated:** + The undocumented ``omega with`` tactic variant has been deprecated, + using ``lia`` is the recommended replacement, tho the old semantics + of ``omega with *`` can be recovered with ``zify; omega`` + (`#11337 <https://github.com/coq/coq/pull/11337>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/07-commands-and-options/10747-canonical-better-message.rst b/doc/changelog/07-commands-and-options/10747-canonical-better-message.rst new file mode 100644 index 0000000000..e73be9c642 --- /dev/null +++ b/doc/changelog/07-commands-and-options/10747-canonical-better-message.rst @@ -0,0 +1,5 @@ +- **Changed:** + The :cmd:`Print Canonical Projections` command now can take constants and + prints only the unification rules that involve or are synthesized from given + constants (`#10747 <https://github.com/coq/coq/pull/10747>`_, + by Kazuhiko Sakaguchi). diff --git a/doc/changelog/07-commands-and-options/11164-let-cs.rst b/doc/changelog/07-commands-and-options/11164-let-cs.rst new file mode 100644 index 0000000000..b9ecd140e7 --- /dev/null +++ b/doc/changelog/07-commands-and-options/11164-let-cs.rst @@ -0,0 +1 @@ +- A section variable introduces with :g:`Let` can be declared as a :g:`Canonical Structure` (`#11164 <https://github.com/coq/coq/pull/11164>`_, by Enrico Tassi). 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/11357-master.rst b/doc/changelog/08-tools/11357-master.rst new file mode 100644 index 0000000000..599db5b1da --- /dev/null +++ b/doc/changelog/08-tools/11357-master.rst @@ -0,0 +1,4 @@ +- **Fixed:** + ``coq_makefile`` does not break when using the ``CAMLPKGS`` variable + together with an unpacked (``mllib``) plugin. (`#11357 + <https://github.com/coq/coq/pull/11357>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/11-infrastructure-and-dependencies/11245-bye+py2.rst b/doc/changelog/11-infrastructure-and-dependencies/11245-bye+py2.rst new file mode 100644 index 0000000000..03c2ccc1d2 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/11245-bye+py2.rst @@ -0,0 +1,4 @@ +- **Removed:** + Python 2 is not longer required in any part of the codebase. + (`#11245 <https://github.com/coq/coq/pull/11245>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index 549598b187..a34b2d5195 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -143,22 +143,24 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica application of a tactic. ``.. prodn::`` A grammar production. - This is useful if you intend to document individual grammar productions. - Otherwise, use Sphinx's `production lists + Use ``.. prodn`` to document grammar productions instead of Sphinx + `production lists <http://www.sphinx-doc.org/en/stable/markup/para.html#directive-productionlist>`_. - Unlike ``.. productionlist``\ s, this directive accepts notation syntax. - - - Usage:: - - .. prodn:: token += production - .. prodn:: token ::= production + prodn displays multiple productions together with alignment similar to ``.. productionlist``, + however unlike ``.. productionlist``\ s, this directive accepts notation syntax. Example:: - .. prodn:: term += let: @pattern := @term in @term .. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } + term += let: @pattern := @term in @term + | second_production + + The first line defines "occ_switch", which must be unique in the document. The second + references and expands the definition of "term", whose main definition is elsewhere + in the document. The third form is for continuing the + definition of a nonterminal when it has multiple productions. It leaves the first + column in the output blank. ``.. table::`` :black_nib: A Coq table, i.e. a setting that is a set of values. Example:: diff --git a/doc/sphinx/_static/coqnotations.sty b/doc/sphinx/_static/coqnotations.sty index 3548b8754c..3dfe4db439 100644 --- a/doc/sphinx/_static/coqnotations.sty +++ b/doc/sphinx/_static/coqnotations.sty @@ -67,11 +67,26 @@ \newcssclass{notation-sup}{\nsup{#1}} \newcssclass{notation-sub}{\nsub{#1}} -\newcssclass{notation}{\nnotation{#1}} +\newcssclass{notation}{\nnotation{\textbf{#1}}} \newcssclass{repeat}{\nrepeat{#1}} \newcssclass{repeat-wrapper}{\nwrapper{#1}} +\newcssclass{repeat-wrapper-with-sub}{\nwrapper{#1}} \newcssclass{hole}{\nhole{#1}} \newcssclass{alternative}{\nalternative{\nbox{#1}}{0pt}} \newcssclass{alternative-block}{#1} \newcssclass{repeated-alternative}{\nalternative{#1}{\nboxsep}} \newcssclass{alternative-separator}{\quad\naltsep{}\quad} +\newcssclass{prodn-table}{% + \begin{savenotes} + \sphinxattablestart + \begin{tabulary}{\linewidth}[t]{lLL} + #1 + \end{tabulary} + \par + \sphinxattableend + \end{savenotes}} +% latex puts targets 1 line below where they should be; prodn-target corrects for this +\newcssclass{prodn-target}{\raisebox{\dimexpr \nscriptsize \relax}{#1}} +\newcssclass{prodn-cell-nonterminal}{#1 &} +\newcssclass{prodn-cell-op}{#1 &} +\newcssclass{prodn-cell-production}{#1\\} diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index 4a5fa0b328..3806ba6ee6 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -10,6 +10,7 @@ .notation { /* font-family: "Ubuntu Mono", "Consolas", monospace; */ white-space: pre-wrap; + font-weight: bold; } .notation .notation-sup { @@ -85,7 +86,8 @@ padding-right: 0.6em; /* Space for the left half of the sub- and sup-scripts */ } -.notation .repeat-wrapper { +.notation .repeat-wrapper, +.notation .repeat-wrapper-with-sub { display: inline-block; position: relative; margin-right: 0.4em; /* Space for the right half of the sub- and sup-scripts */ @@ -165,10 +167,52 @@ /* Overrides */ /*************/ -.rst-content table.docutils td, .rst-content table.docutils th { - padding: 8px; /* Reduce horizontal padding */ - border-left: none; - border-right: none; +.prodn-table { + display: table; + margin: 1.5em 0px; + vertical-align: baseline; + font-weight: bold; +} + +.prodn-column-group { + display: table-column-group; +} + +.prodn-column { + display: table-column; +} + +.prodn-row-group { + display: table-row-group; +} + +.prodn-row { + display: table-row; +} + +.prodn-cell-nonterminal, +.prodn-cell-op, +.prodn-cell-production +{ + display: table-cell; +} + +.prodn-cell-nonterminal { + padding-right: 0.49em; +} + +.prodn-cell-op { + padding-right: 0.90em; + font-weight: normal; +} + +.prodn-table .notation > .repeat-wrapper { + margin-top: 0.28em; +} + +.prodn-table .notation > .repeat-wrapper-with-sub { + margin-top: 0.28em; + margin-bottom: 0.28em; } /* We can't display nested blocks otherwise */ diff --git a/doc/sphinx/addendum/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index 45b3f6f161..15f42591ce 100644 --- a/doc/sphinx/addendum/extended-pattern-matching.rst +++ b/doc/sphinx/addendum/extended-pattern-matching.rst @@ -192,7 +192,7 @@ Disjunctive patterns -------------------- Multiple patterns that share the same right-hand-side can be -factorized using the notation :n:`{+| @patterns_comma}`. For +factorized using the notation :n:`{+| {+, @pattern } }`. For instance, :g:`max` can be rewritten as follows: .. coqtop:: in reset 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/omega.rst b/doc/sphinx/addendum/omega.rst index 650a444a16..daca43e65e 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -5,6 +5,27 @@ Omega: a solver for quantifier-free problems in Presburger Arithmetic :Author: Pierre Crégut +.. warning:: + + The :tacn:`omega` tactic is about to be deprecated in favor of the + :tacn:`lia` tactic. The goal is to consolidate the arithmetic + solving capabilities of Coq into a single engine; moreover, + :tacn:`lia` is in general more powerful than :tacn:`omega` (it is a + complete Presburger arithmetic solver while :tacn:`omega` was known + to be incomplete). + + Work is in progress to make sure that there are no regressions + (including no performance regression) when switching from + :tacn:`omega` to :tacn:`lia` in existing projects. However, we + already recommend using :tacn:`lia` in new or refactored proof + scripts. We also ask that you report (in our `bug tracker + <https://github.com/coq/coq/issues>`_) any issue you encounter, + especially if the issue was not present in :tacn:`omega`. + + Note that replacing :tacn:`omega` with :tacn:`lia` can break + non-robust proof scripts which rely on incompleteness bugs of + :tacn:`omega` (e.g. using the pattern :g:`; try omega`). + Description of ``omega`` ------------------------ diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 1d0c937792..21000889d3 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -50,6 +50,11 @@ __ 811RefineInstance_ __ 811SSRUnderOver_ __ 811Reals_ +Additionally, while the :tacn:`omega` tactic is not yet deprecated in +this version of Coq, it should soon be the case and we already +recommend users to switch to :tacn:`lia` in new proof scripts (see +also the warning message in the :ref:`corresponding chapter <omega>`). + 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 @@ -350,11 +355,8 @@ Changes in 8.11+beta1 `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 + goal by instantiating the hidden evar.) + This feature 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 diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst index bcdf3277ad..1424b4f3e1 100644 --- a/doc/sphinx/introduction.rst +++ b/doc/sphinx/introduction.rst @@ -60,7 +60,7 @@ Nonetheless, the manual has some structure that is explained below. of the formalism. Chapter :ref:`themodulesystem` describes the module system. -- The second part describes the proof engine. It is divided in six +- The second part describes the proof engine. It is divided into several chapters. Chapter :ref:`vernacularcommands` presents all commands (we call them *vernacular commands*) that are not directly related to interactive proving: requests to the environment, complete or partial @@ -68,8 +68,10 @@ Nonetheless, the manual has some structure that is explained below. proofs, do multiple proofs in parallel is explained in Chapter :ref:`proofhandling`. In Chapter :ref:`tactics`, all commands that realize one or more steps of the proof are presented: we call them - *tactics*. The language to combine these tactics into complex proof - strategies is given in Chapter :ref:`ltac`. Examples of tactics + *tactics*. The legacy language to combine these tactics into complex proof + strategies is given in Chapter :ref:`ltac`. The currently experimental + language that will eventually replace Ltac is presented in + Chapter :ref:`ltac2`. Examples of tactics are described in Chapter :ref:`detailedexamplesoftactics`. Finally, the |SSR| proof language is presented in Chapter :ref:`thessreflectprooflanguage`. diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index cad5e4e67e..80f209fcf1 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -95,25 +95,23 @@ Logic The basic library of |Coq| comes with the definitions of standard (intuitionistic) logical connectives (they are defined as inductive constructions). They are equipped with an appealing syntax enriching the -subclass :token:`form` of the syntactic class :token:`term`. The syntax of -:token:`form` is shown below: - -.. /!\ Please keep the blanks in the lines below, experimentally they produce - a nice last column. Or even better, find a proper way to do this! - -.. productionlist:: - form : True (True) - : False (False) - : ~ `form` (not) - : `form` /\ `form` (and) - : `form` \/ `form` (or) - : `form` -> `form` (primitive implication) - : `form` <-> `form` (iff) - : forall `ident` : `type`, `form` (primitive for all) - : exists `ident` [: `specif`], `form` (ex) - : exists2 `ident` [: `specif`], `form` & `form` (ex2) - : `term` = `term` (eq) - : `term` = `term` :> `specif` (eq) +subclass :token:`form` of the syntactic class :token:`term`. The constructs +for :production:`form` are: + +============================================== ======= +True True +False False +:n:`~ @form` not +:n:`@form /\ @form` and +:n:`@form \/ @form` or +:n:`@form -> @form` primitive implication +:n:`@form <-> @form` iff +:n:`forall @ident : @type, @form` primitive for all +:n:`exists @ident {? @specif}, @form` ex +:n:`exists2 @ident {? @specif}, @form & @form` ex2 +:n:`@term = @term` eq +:n:`@term = @term :> @specif` eq +============================================== ======= .. note:: @@ -281,19 +279,20 @@ In the basic library, we find in ``Datatypes.v`` the definition of the basic data-types of programming, defined as inductive constructions over the sort ``Set``. Some of them come with a special syntax shown below (this syntax table is common with -the next section :ref:`specification`): - -.. productionlist:: - specif : `specif` * `specif` (prod) - : `specif` + `specif` (sum) - : `specif` + { `specif` } (sumor) - : { `specif` } + { `specif` } (sumbool) - : { `ident` : `specif` | `form` } (sig) - : { `ident` : `specif` | `form` & `form` } (sig2) - : { `ident` : `specif` & `specif` } (sigT) - : { `ident` : `specif` & `specif` & `specif` } (sigT2) - term : (`term`, `term`) (pair) - +the next section :ref:`specification`). The constructs for :production:`specif` are: + +============================================= ======= +:n:`@specif * @specif` prod +:n:`@specif + @specif` sum +:n:`@specif + { @specif }` sumor +:n:`{ @specif } + { @specif }` sumbool +:n:`{ @ident : @specif | @form }` sig +:n:`{ @ident : @specif | @form & @form }` sig2 +:n:`{ @ident : @specif & @specif }` sigT +:n:`{ @ident : @specif & @specif & @specif }` sigT2 +============================================= ======= + +The notation for pairs (elements of type prod) is: :n:`(@term, @term)` Programming +++++++++++ diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 8caa289a47..bdfdffeaad 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -155,19 +155,19 @@ available: .. _record_projections_grammar: - .. insertgram term_projection term_projection + .. insertprodn term_projection term_projection - .. productionlist:: coq - term_projection : `term0` .( `qualid` `args_opt` ) - : `term0` .( @ `qualid` `term1_list_opt` ) + .. prodn:: + term_projection ::= @term0 .( @qualid {* @arg } ) + | @term0 .( @ @qualid {* @term1 } ) Syntax of Record projections The corresponding grammar rules are given in the preceding grammar. When :token:`qualid` -denotes a projection, the syntax :n:`@term.(@qualid)` is equivalent to :n:`@qualid @term`, -the syntax :n:`@term.(@qualid {+ @arg })` to :n:`@qualid {+ @arg } @term`. -and the syntax :n:`@term.(@@qualid {+ @term })` to :n:`@@qualid {+ @term } @term`. -In each case, :token:`term` is the object projected and the +denotes a projection, the syntax :n:`@term0.(@qualid)` is equivalent to :n:`@qualid @term0`, +the syntax :n:`@term0.(@qualid {+ @arg })` to :n:`@qualid {+ @arg } @term0`. +and the syntax :n:`@term0.(@@qualid {+ @term0 })` to :n:`@@qualid {+ @term0 } @term0`. +In each case, :token:`term0` is the object projected and the other arguments are the parameters of the inductive type. @@ -1629,8 +1629,8 @@ The syntax is supported in all top-level definitions: :cmd:`Definition`, :cmd:`Fixpoint`, :cmd:`Lemma` and so on. For (co-)inductive datatype declarations, the semantics are the following: an inductive parameter declared as an implicit argument need not be repeated in the inductive -definition but will become implicit for the constructors of the -inductive only, not the inductive type itself. For example: +definition and will become implicit for the inductive type and the constructors. +For example: .. coqtop:: all @@ -1878,27 +1878,16 @@ Controlling the insertion of implicit arguments not followed by explicit argumen Explicit applications ~~~~~~~~~~~~~~~~~~~~~ -In presence of non-strict or contextual argument, or in presence of +In presence of non-strict or contextual arguments, or in presence of partial applications, the synthesis of implicit arguments may fail, so -one may have to give explicitly certain implicit arguments of an -application. The syntax for this is :n:`(@ident := @term)` where :token:`ident` is the -name of the implicit argument and term is its corresponding explicit -term. Alternatively, one can locally deactivate the hiding of implicit -arguments of a function by using the notation :n:`@qualid {+ @term }`. -This syntax extension is given in the following grammar: +one may have to explicitly give certain implicit arguments of an +application. Use the :n:`(@ident := @term)` form of :token:`arg` to do so, +where :token:`ident` is the name of the implicit argument and :token:`term` +is its corresponding explicit term. Alternatively, one can deactivate +the hiding of implicit arguments for a single function application using the +:n:`@ @qualid {? @univ_annot } {* @term1 }` form of :token:`term10`. -.. _explicit_app_grammar: - - .. productionlist:: explicit_apps - term : @ `qualid` `term` … `term` - : @ `qualid` - : `qualid` `argument` … `argument` - argument : `term` - : (`ident` := `term`) - - Syntax for explicitly giving implicit arguments - -.. example:: (continued) +.. example:: Syntax for explicitly giving implicit arguments (continued) .. coqtop:: all @@ -1994,6 +1983,8 @@ Deactivation of implicit arguments for parsing to be given as if no arguments were implicit. By symmetry, this also affects printing. +.. _canonical-structure-declaration: + Canonical structures ~~~~~~~~~~~~~~~~~~~~ @@ -2004,6 +1995,7 @@ value. The complete documentation of canonical structures can be found in :ref:`canonicalstructures`; here only a simple example is given. .. cmd:: {? Local | #[local] } Canonical {? Structure } @qualid + :name: Canonical Structure This command declares :token:`qualid` as a canonical instance of a structure (a record). When the :g:`#[local]` attribute is given the effect @@ -2075,11 +2067,13 @@ in :ref:`canonicalstructures`; here only a simple example is given. This is equivalent to a regular definition of :token:`ident` followed by the declaration :n:`Canonical @ident`. -.. cmd:: Print Canonical Projections +.. cmd:: Print Canonical Projections {* @ident} This displays the list of global names that are components of some canonical structure. For each of them, the canonical structure of - which it is a projection is indicated. + which it is a projection is indicated. If constants are given as + its arguments, only the unification rules that involve or are + synthesized from simultaneously all given constants will be shown. .. example:: @@ -2089,10 +2083,15 @@ in :ref:`canonicalstructures`; here only a simple example is given. Print Canonical Projections. + .. coqtop:: all + + Print Canonical Projections nat. + .. note:: - The last line would not show up if the corresponding projection (namely - :g:`Prf_equiv`) were annotated as not canonical, as described above. + The last line in the first example would not show up if the + corresponding projection (namely :g:`Prf_equiv`) were annotated as not + canonical, as described above. Implicit types of variables ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2312,17 +2311,13 @@ Printing universes Existential variables --------------------- -.. insertgram term_evar evar_binding +.. insertprodn term_evar evar_binding -.. productionlist:: coq - term_evar : ?[ `ident` ] - : ?[ ?`ident` ] - : ?`ident` `evar_bindings_opt` - evar_bindings_opt : @{ `evar_bindings_semi` } - : `empty` - evar_bindings_semi : `evar_bindings_semi` ; `evar_binding` - : `evar_binding` - evar_binding : `ident` := `term` +.. prodn:: + term_evar ::= ?[ @ident ] + | ?[ ?@ident ] + | ?@ident {? @%{ {+; @evar_binding } %} } + evar_binding ::= @ident := @term |Coq| terms can include existential variables which represents unknown subterms to eventually be replaced by actual subterms. @@ -2555,3 +2550,8 @@ the context to help inferring the types of the remaining arguments. Arguments ex_intro _ _ & _ _. Check (ex_intro _ true _ : exists n : nat, n > 0). + +Coq will attempt to produce a term which uses the arguments you +provided, but in some cases involving Program mode the arguments after +the bidirectionality starts may be replaced by convertible but +syntactically different terms. diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 3cc101d06b..d591718b17 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -16,27 +16,27 @@ In Coq, logical objects are typed to ensure their logical correctness. The rules implemented by the typing algorithm are described in Chapter :ref:`calculusofinductiveconstructions`. -About the grammars in the manual -================================ +.. About the grammars in the manual + ================================ -Grammars are presented in Backus-Naur form (BNF). Terminal symbols are -set in black ``typewriter font``. In addition, there are special notations for -regular expressions. + Grammars are presented in Backus-Naur form (BNF). Terminal symbols are + set in black ``typewriter font``. In addition, there are special notations for + regular expressions. -An expression enclosed in square brackets ``[…]`` means at most one -occurrence of this expression (this corresponds to an optional -component). + An expression enclosed in square brackets ``[…]`` means at most one + occurrence of this expression (this corresponds to an optional + component). -The notation “``entry sep … sep entry``” stands for a non empty sequence -of expressions parsed by entry and separated by the literal “``sep``” [1]_. + The notation “``entry sep … sep entry``” stands for a non empty sequence + of expressions parsed by entry and separated by the literal “``sep``” [1]_. -Similarly, the notation “``entry … entry``” stands for a non empty -sequence of expressions parsed by the “``entry``” entry, without any -separator between. + Similarly, the notation “``entry … entry``” stands for a non empty + sequence of expressions parsed by the “``entry``” entry, without any + separator between. -At the end, the notation “``[entry sep … sep entry]``” stands for a -possibly empty sequence of expressions parsed by the “``entry``” entry, -separated by the literal “``sep``”. + At the end, the notation “``[entry sep … sep entry]``” stands for a + possibly empty sequence of expressions parsed by the “``entry``” entry, + separated by the literal “``sep``”. .. _lexical-conventions: @@ -58,10 +58,12 @@ Identifiers recognized by the following grammar (except that the string ``_`` is reserved; it is not a valid identifier): - .. productionlist:: coq - ident : `first_letter`[`subsequent_letter`…`subsequent_letter`] - first_letter : a..z ∣ A..Z ∣ _ ∣ `unicode_letter` - subsequent_letter : `first_letter` ∣ 0..9 ∣ ' ∣ `unicode_id_part` + .. insertprodn ident subsequent_letter + + .. prodn:: + ident ::= @first_letter {* @subsequent_letter } + first_letter ::= {| a .. z | A .. Z | _ | @unicode_letter } + subsequent_letter ::= {| @first_letter | @digit | ' | @unicode_id_part } All characters are meaningful. In particular, identifiers are case-sensitive. :production:`unicode_letter` non-exhaustively includes Latin, @@ -77,13 +79,13 @@ Numerals integer. Underscores embedded in the digits are ignored, for example ``1_000_000`` is the same as ``1000000``. - .. productionlist:: coq - numeral : `num`[. `num`][`exp`[`sign`]`num`] - int : [-]`num` - num : `digit`…`digit` - digit : 0..9 - exp : e | E - sign : + | - + .. insertprodn numeral digit + + .. prodn:: + numeral ::= {+ @digit } {? . {+ @digit } } {? {| e | E } {? {| + | - } } {+ @digit } } + int ::= {? - } {+ @digit } + num ::= {+ @digit } + digit ::= 0 .. 9 Strings Strings begin and end with ``"`` (double quote). Use ``""`` to represent @@ -139,50 +141,39 @@ presentation of Cic is given in Chapter :ref:`calculusofinductiveconstructions`. are given in Chapter :ref:`extensionsofgallina`. How to customize the syntax is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. -.. insertgram term binders_opt - -.. productionlist:: coq - term : forall `open_binders` , `term` - : fun `open_binders` => `term` - : `term_let` - : if `term` `as_return_type_opt` then `term` else `term` - : `term_fix` - : `term100` - term100 : `term_cast` - : `term10` - term10 : `term1` `args` - : @ `qualid` `universe_annot_opt` `term1_list_opt` - : `term1` - args : `args` `arg` - : `arg` - arg : ( `ident` := `term` ) - : `term1` - term1_list_opt : `term1_list_opt` `term1` - : `empty` - empty : - term1 : `term_projection` - : `term0` % `ident` - : `term0` - args_opt : `args` - : `empty` - term0 : `qualid` `universe_annot_opt` - : `sort` - : `numeral` - : `string` - : _ - : `term_evar` - : `term_match` - : ( `term` ) - : {| `fields_def` |} - : `{ `term` } - : `( `term` ) - : ltac : ( `ltac_expr` ) - fields_def : `field_def` ; `fields_def` - : `field_def` - : `empty` - field_def : `qualid` `binders_opt` := `term` - binders_opt : `binders` - : `empty` +.. insertprodn term field_def + +.. prodn:: + term ::= forall @open_binders , @term + | fun @open_binders => @term + | @term_let + | if @term {? {? as @name } return @term100 } then @term else @term + | @term_fix + | @term_cofix + | @term100 + term100 ::= @term_cast + | @term10 + term10 ::= @term1 {+ @arg } + | @ @qualid {? @univ_annot } {* @term1 } + | @term1 + arg ::= ( @ident := @term ) + | @term1 + term1 ::= @term_projection + | @term0 % @ident + | @term0 + term0 ::= @qualid {? @univ_annot } + | @sort + | @numeral + | @string + | _ + | @term_evar + | @term_match + | ( @term ) + | %{%| {* @field_def } %|%} + | `%{ @term %} + | `( @term ) + | ltac : ( @ltac_expr ) + field_def ::= @qualid {* @binder } := @term Types ----- @@ -196,12 +187,11 @@ of types inside the syntactic class :token:`term`. Qualified identifiers and simple identifiers -------------------------------------------- -.. insertgram qualid field +.. insertprodn qualid field_ident -.. productionlist:: coq - qualid : `qualid` `field` - : `ident` - field : .`ident` +.. prodn:: + qualid ::= @ident {* @field_ident } + field_ident ::= .@ident *Qualified identifiers* (:token:`qualid`) denote *global constants* (definitions, lemmas, theorems, remarks or facts), *global variables* @@ -210,7 +200,7 @@ types*. *Simple identifiers* (or shortly :token:`ident`) are a syntactic subset of qualified identifiers. Identifiers may also denote *local variables*, while qualified identifiers do not. -Field identifiers, written :token:`field`, are identifiers prefixed by +Field identifiers, written :token:`field_ident`, are identifiers prefixed by `.` (dot) with no blank between the dot and the identifier. @@ -237,34 +227,27 @@ numbers (see :ref:`datatypes`). Sorts ----- -.. insertgram sort universe_level - -.. productionlist:: coq - sort : Set - : Prop - : SProp - : Type - : Type @{ _ } - : Type @{ `universe` } - universe : max ( `universe_exprs_comma` ) - : `universe_expr` - universe_exprs_comma : `universe_exprs_comma` , `universe_expr` - : `universe_expr` - universe_expr : `universe_name` `universe_increment_opt` - universe_name : `qualid` - : Set - : Prop - universe_increment_opt : + `num` - : `empty` - universe_annot_opt : @{ `universe_levels_opt` } - : `empty` - universe_levels_opt : `universe_levels_opt` `universe_level` - : `empty` - universe_level : Set - : Prop - : Type - : _ - : `qualid` +.. insertprodn sort univ_annot + +.. prodn:: + sort ::= Set + | Prop + | SProp + | Type + | Type @%{ _ %} + | Type @%{ @universe %} + universe ::= max ( {+, @universe_expr } ) + | @universe_expr + universe_expr ::= @universe_name {? + @num } + universe_name ::= @qualid + | Set + | Prop + universe_level ::= Set + | Prop + | Type + | _ + | @qualid + univ_annot ::= @%{ {* @universe_level } %} There are four sorts :g:`SProp`, :g:`Prop`, :g:`Set` and :g:`Type`. @@ -272,12 +255,12 @@ There are four sorts :g:`SProp`, :g:`Prop`, :g:`Set` and :g:`Type`. propositions* (also called *strict propositions*). - :g:`Prop` is the universe of *logical propositions*. The logical propositions - themselves are typing the proofs. We denote propositions by :production:`form`. + themselves are typing the proofs. We denote propositions by :token:`form`. This constitutes a semantic subclass of the syntactic class :token:`term`. - :g:`Set` is the universe of *program types* or *specifications*. The specifications themselves are typing the programs. We denote - specifications by :production:`specif`. This constitutes a semantic subclass of + specifications by :token:`specif`. This constitutes a semantic subclass of the syntactic class :token:`term`. - :g:`Type` is the type of sorts. @@ -289,34 +272,24 @@ More on sorts can be found in Section :ref:`sorts`. Binders ------- -.. insertgram open_binders exclam_opt - -.. productionlist:: coq - open_binders : `names` : `term` - : `binders` - names : `names` `name` - : `name` - name : _ - : `ident` - binders : `binders` `binder` - : `binder` - binder : `name` - : ( `names` : `term` ) - : ( `name` `colon_term_opt` := `term` ) - : { `name` } - : { `names` `colon_term_opt` } - : `( `typeclass_constraints_comma` ) - : `{ `typeclass_constraints_comma` } - : ' `pattern0` - : ( `name` : `term` | `term` ) - typeclass_constraints_comma : `typeclass_constraints_comma` , `typeclass_constraint` - : `typeclass_constraint` - typeclass_constraint : `exclam_opt` `term` - : { `name` } : `exclam_opt` `term` - : `name` : `exclam_opt` `term` - exclam_opt : ! - : `empty` - +.. insertprodn open_binders typeclass_constraint + +.. prodn:: + open_binders ::= {+ @name } : @term + | {+ @binder } + name ::= _ + | @ident + binder ::= @name + | ( {+ @name } : @term ) + | ( @name {? : @term } := @term ) + | %{ {+ @name } {? : @term } %} + | `( {+, @typeclass_constraint } ) + | `%{ {+, @typeclass_constraint } %} + | ' @pattern0 + | ( @name : @term %| @term ) + typeclass_constraint ::= {? ! } @term + | %{ @name %} : {? ! } @term + | @name : {? ! } @term Various constructions such as :g:`fun`, :g:`forall`, :g:`fix` and :g:`cofix` *bind* variables. A binding is represented by an identifier. If the binding @@ -335,7 +308,7 @@ variable can be introduced at the same time. It is also possible to give the type of the variable as follows: :n:`(@ident : @type := @term)`. -Lists of :token:`binder` are allowed. In the case of :g:`fun` and :g:`forall`, +Lists of :token:`binder`\s are allowed. In the case of :g:`fun` and :g:`forall`, it is intended that at least one binder of the list is an assumption otherwise fun and forall gets identical. Moreover, parentheses can be omitted in the case of a single sequence of bindings sharing the same type (e.g.: @@ -354,11 +327,8 @@ function on type :g:`A`). The keyword :g:`fun` can be followed by several binders as given in Section :ref:`binders`. Functions over several variables are equivalent to an iteration of one-variable functions. For instance the expression -“fun :token:`ident`\ :math:`_{1}` … :token:`ident`\ :math:`_{n}` -: :token:`type` => :token:`term`” -denotes the same function as “ fun :token:`ident`\ -:math:`_{1}` : :token:`type` => … -fun :token:`ident`\ :math:`_{n}` : :token:`type` => :token:`term`”. If +:n:`fun {+ @ident__i } : @type => @term` +denotes the same function as :n:`{+ fun @ident__i : @type => } @term`. If a let-binder occurs in the list of binders, it is expanded to a let-in definition (see Section :ref:`let-in`). @@ -389,15 +359,14 @@ the propositional implication and function types. Applications ------------ -The expression :token:`term`\ :math:`_0` :token:`term`\ :math:`_1` denotes the -application of :token:`term`\ :math:`_0` to :token:`term`\ :math:`_1`. +The expression :n:`@term__fun @term` denotes the application of +:n:`@term__fun` (which is expected to have a function type) to +:token:`term`. -The expression :token:`term`\ :math:`_0` :token:`term`\ :math:`_1` ... -:token:`term`\ :math:`_n` denotes the application of the term -:token:`term`\ :math:`_0` to the arguments :token:`term`\ :math:`_1` ... then -:token:`term`\ :math:`_n`. It is equivalent to ( … ( :token:`term`\ :math:`_0` -:token:`term`\ :math:`_1` ) … ) :token:`term`\ :math:`_n` : associativity is to the -left. +The expression :n:`@term__fun {+ @term__i }` denotes the application +of the term :n:`@term__fun` to the arguments :n:`@term__i`. It is +equivalent to :n:`( … ( @term__fun @term__1 ) … ) @term__n`: +associativity is to the left. The notation :n:`(@ident := @term)` for arguments is used for making explicit the value of implicit arguments (see @@ -411,13 +380,13 @@ Section :ref:`explicit-applications`). Type cast --------- -.. insertgram term_cast term_cast +.. insertprodn term_cast term_cast -.. productionlist:: coq - term_cast : `term10` <: `term` - : `term10` <<: `term` - : `term10` : `term` - : `term10` :> +.. prodn:: + term_cast ::= @term10 <: @term + | @term10 <<: @term + | @term10 : @term + | @term10 :> The expression :n:`@term : @type` is a type cast expression. It enforces the type of :token:`term` to be :token:`type`. @@ -444,21 +413,14 @@ guess the missing piece of information. Let-in definitions ------------------ -.. insertgram term_let names_comma +.. insertprodn term_let term_let -.. productionlist:: coq - term_let : let `name` `colon_term_opt` := `term` in `term` - : let `name` `binders` `colon_term_opt` := `term` in `term` - : let `single_fix` in `term` - : let `names_tuple` `as_return_type_opt` := `term` in `term` - : let ' `pattern` := `term` `return_type_opt` in `term` - : let ' `pattern` in `pattern` := `term` `return_type` in `term` - colon_term_opt : : `term` - : `empty` - names_tuple : ( `names_comma` ) - : () - names_comma : `names_comma` , `name` - : `name` +.. prodn:: + term_let ::= let @name {? : @term } := @term in @term + | let @name {+ @binder } {? : @term } := @term in @term + | let ( {*, @name } ) {? {? as @name } return @term100 } := @term in @term + | let ' @pattern := @term {? return @term100 } in @term + | let ' @pattern in @pattern := @term return @term100 in @term :n:`let @ident := @term in @term’` denotes the local binding of :token:`term` to the variable @@ -471,57 +433,25 @@ stands for :n:`let @ident := fun {+ @binder} => @term in @term’`. Definition by cases: match -------------------------- -.. insertgram term_match record_pattern - -.. productionlist:: coq - term_match : match `case_items_comma` `return_type_opt` with `or_opt` `eqns_or_opt` end - case_items_comma : `case_items_comma` , `case_item` - : `case_item` - return_type_opt : `return_type` - : `empty` - as_return_type_opt : `as_name_opt` `return_type` - : `empty` - return_type : return `term100` - case_item : `term100` `as_name_opt` `in_opt` - as_name_opt : as `name` - : `empty` - in_opt : in `pattern` - : `empty` - or_opt : | - : `empty` - eqns_or_opt : `eqns_or` - : `empty` - eqns_or : `eqns_or` | `eqn` - : `eqn` - eqn : `patterns_comma_list_or` => `term` - patterns_comma_list_or : `patterns_comma_list_or` | `patterns_comma` - : `patterns_comma` - patterns_comma : `patterns_comma` , `pattern` - : `pattern` - pattern : `pattern10` : `term` - : `pattern10` - pattern10 : `pattern1` as `name` - : `pattern1_list` - : @ `qualid` `pattern1_list_opt` - : `pattern1` - pattern1_list : `pattern1_list` `pattern1` - : `pattern1` - pattern1_list_opt : `pattern1_list` - : `empty` - pattern1 : `pattern0` % `ident` - : `pattern0` - pattern0 : `qualid` - : {| `record_patterns_opt` |} - : _ - : ( `patterns_or` ) - : `numeral` - : `string` - patterns_or : `patterns_or` | `pattern` - : `pattern` - record_patterns_opt : `record_patterns_opt` ; `record_pattern` - : `record_pattern` - : `empty` - record_pattern : `qualid` := `pattern` +.. insertprodn term_match pattern0 + +.. prodn:: + term_match ::= match {+, @case_item } {? return @term100 } with {? %| } {*| @eqn } end + case_item ::= @term100 {? as @name } {? in @pattern } + eqn ::= {+| {+, @pattern } } => @term + pattern ::= @pattern10 : @term + | @pattern10 + pattern10 ::= @pattern1 as @name + | @pattern1 {* @pattern1 } + | @ @qualid {* @pattern1 } + pattern1 ::= @pattern0 % @ident + | @pattern0 + pattern0 ::= @qualid + | %{%| {* @qualid := @pattern } %|%} + | _ + | ( {+| @pattern } ) + | @numeral + | @string Objects of inductive types can be destructured by a case-analysis construction called *pattern matching* expression. A pattern matching @@ -531,31 +461,30 @@ to apply specific treatments accordingly. This paragraph describes the basic form of pattern matching. See Section :ref:`Mult-match` and Chapter :ref:`extendedpatternmatching` for the description of the general form. The basic form of pattern matching is characterized -by a single :token:`case_item` expression, a :token:`patterns_comma` restricted to a +by a single :token:`case_item` expression, an :token:`eqn` restricted to a single :token:`pattern` and :token:`pattern` restricted to the form :n:`@qualid {* @ident}`. -The expression match ":token:`term`:math:`_0` :token:`return_type_opt` with -:token:`pattern`:math:`_1` => :token:`term`:math:`_1` :math:`|` … :math:`|` -:token:`pattern`:math:`_n` => :token:`term`:math:`_n` end" denotes a -*pattern matching* over the term :token:`term`:math:`_0` (expected to be -of an inductive type :math:`I`). The terms :token:`term`:math:`_1`\ …\ -:token:`term`:math:`_n` are the *branches* of the pattern matching -expression. Each of :token:`pattern`:math:`_i` has a form :token:`qualid` -:token:`ident` where :token:`qualid` must denote a constructor. There should be +The expression +:n:`match @term {? return @term100 } with {+| @pattern__i => @term__i } end` denotes a +*pattern matching* over the term :n:`@term` (expected to be +of an inductive type :math:`I`). The :n:`@term__i` +are the *branches* of the pattern matching +expression. Each :n:`@pattern__i` has the form :n:`@qualid @ident` +where :n:`@qualid` must denote a constructor. There should be exactly one branch for every constructor of :math:`I`. -The :token:`return_type_opt` expresses the type returned by the whole match +The :n:`return @term100` clause gives the type returned by the whole match expression. There are several cases. In the *non dependent* case, all -branches have the same type, and the :token:`return_type_opt` is the common type of -branches. In this case, :token:`return_type_opt` can usually be omitted as it can be -inferred from the type of the branches [2]_. +branches have the same type, and the :n:`return @term100` specifies that type. +In this case, :n:`return @term100` can usually be omitted as it can be +inferred from the type of the branches [1]_. In the *dependent* case, there are three subcases. In the first subcase, the type in each branch may depend on the exact value being matched in the branch. In this case, the whole pattern matching itself depends on the term being matched. This dependency of the term being matched in the -return type is expressed with an “as :token:`ident`” clause where :token:`ident` +return type is expressed with an :n:`@ident` clause where :token:`ident` is dependent in the return type. For instance, in the following example: .. coqtop:: in @@ -604,19 +533,19 @@ type of each branch can depend on the type dependencies specific to the branch and the whole pattern matching expression has a type determined by the specific dependencies in the type of the term being matched. This dependency of the return type in the annotations of the inductive type -is expressed using a “:g:`in` :math:`I` :g:`_ … _` :token:`pattern`:math:`_1` … -:token:`pattern`:math:`_n`” clause, where +is expressed with a clause in the form +:n:`in @qualid {+ _ } {+ @pattern }`, where -- :math:`I` is the inductive type of the term being matched; +- :token:`qualid` is the inductive type of the term being matched; -- the :g:`_` are matching the parameters of the inductive type: the +- the holes :n:`_` match the parameters of the inductive type: the return type is not dependent on them. -- the :token:`pattern`:math:`_i` are matching the annotations of the +- each :n:`@pattern` matches the annotations of the inductive type: the return type is dependent on them -- in the basic case which we describe below, each :token:`pattern`:math:`_i` - is a name :token:`ident`:math:`_i`; see :ref:`match-in-patterns` for the +- in the basic case which we describe below, each :n:`@pattern` + is a name :n:`@ident`; see :ref:`match-in-patterns` for the general case For instance, in the following example: @@ -651,27 +580,18 @@ Sections :ref:`if-then-else` and :ref:`irrefutable-patterns`). Recursive and co-recursive functions: fix and cofix --------------------------------------------------- -.. insertgram term_fix term1_extended_opt +.. insertprodn term_fix term1_extended + +.. prodn:: + term_fix ::= let fix @fix_body in @term + | fix @fix_body {? {+ with @fix_body } for @ident } + fix_body ::= @ident {* @binder } {? @fixannot } {? : @term } := @term + fixannot ::= %{ struct @ident %} + | %{ wf @term1_extended @ident %} + | %{ measure @term1_extended {? @ident } {? @term1_extended } %} + term1_extended ::= @term1 + | @ @qualid {? @univ_annot } -.. productionlist:: coq - term_fix : `single_fix` - : `single_fix` with `fix_bodies` for `ident` - single_fix : fix `fix_body` - : cofix `fix_body` - fix_bodies : `fix_bodies` with `fix_body` - : `fix_body` - fix_body : `ident` `binders_opt` `fixannot_opt` `colon_term_opt` := `term` - fixannot_opt : `fixannot` - : `empty` - fixannot : { struct `ident` } - : { wf `term1_extended` `ident` } - : { measure `term1_extended` `ident_opt` `term1_extended_opt` } - term1_extended : `term1` - : @ `qualid` `universe_annot_opt` - ident_opt : `ident` - : `empty` - term1_extended_opt : `term1_extended` - : `empty` The expression “``fix`` :token:`ident`:math:`_1` :token:`binder`:math:`_1` ``:`` :token:`type`:math:`_1` ``:=`` :token:`term`:math:`_1` ``with … with`` @@ -681,6 +601,17 @@ The expression “``fix`` :token:`ident`:math:`_1` :token:`binder`:math:`_1` ``: recursion. It is the local counterpart of the :cmd:`Fixpoint` command. When :math:`n=1`, the “``for`` :token:`ident`:math:`_i`” clause is omitted. +The association of a single fixpoint and a local definition have a special +syntax: :n:`let fix @ident @binders := @term in` stands for +:n:`let @ident := fix @ident @binders := @term in`. The same applies for co-fixpoints. + +.. insertprodn term_cofix cofix_body + +.. prodn:: + term_cofix ::= let cofix @cofix_body in @term + | cofix @cofix_body {? {+ with @cofix_body } for @ident } + cofix_body ::= @ident {* @binder } {? : @term } := @term + The expression “``cofix`` :token:`ident`:math:`_1` :token:`binder`:math:`_1` ``:`` :token:`type`:math:`_1` ``with … with`` :token:`ident`:math:`_n` :token:`binder`:math:`_n` : :token:`type`:math:`_n` ``for`` :token:`ident`:math:`_i`” denotes the @@ -688,10 +619,6 @@ The expression “``cofix`` :token:`ident`:math:`_1` :token:`binder`:math:`_1` ` co-recursion. It is the local counterpart of the :cmd:`CoFixpoint` command. When :math:`n=1`, the “``for`` :token:`ident`:math:`_i`” clause is omitted. -The association of a single fixpoint and a local definition have a special -syntax: :n:`let fix @ident @binders := @term in` stands for -:n:`let @ident := fix @ident @binders := @term in`. The same applies for co-fixpoints. - .. _vernacular: The Vernacular @@ -715,6 +642,8 @@ The Vernacular : ( `ident` … `ident` : `term` ) … ( `ident` … `ident` : `term` ) definition : [Local] Definition `ident` [`binders`] [: `term`] := `term` . : Let `ident` [`binders`] [: `term`] := `term` . + binders : binders binder + : binder inductive : Inductive `ind_body` with … with `ind_body` . : CoInductive `ind_body` with … with `ind_body` . ind_body : `ident` [`binders`] : `term` := @@ -1545,7 +1474,7 @@ Chapter :ref:`Tactics`. The basic assertion command is: The name you provided is already defined. You have then to choose another name. - .. exn:: Nested proofs are not allowed unless you turn the :flag:`Nested Proofs Allowed` flag on. + .. exn:: Nested proofs are not allowed unless you turn the Nested Proofs Allowed flag on. You are asserting a new statement while already being in proof editing mode. This feature, called nested proofs, is disabled by default. @@ -1691,6 +1620,17 @@ variety of commands: :n:`@string__1` is the actual notation, :n:`@string__2` is the version number, :n:`@string__3` is the note. +``canonical`` + This attribute can decorate a :cmd:`Definition` or :cmd:`Let` command. + It is equivalent to having a :cmd:`Canonical Structure` declaration just + after the command. + + This attirbute can take the value ``false`` when decorating a record field + declaration with the effect of preventing the field from being involved in + the inference of canonical instances. + + See also :ref:`canonical-structure-declaration`. + .. example:: .. coqtop:: all reset warn @@ -1715,10 +1655,5 @@ variety of commands: command with some attribute it does not understand. .. [1] - This is similar to the expression “*entry* :math:`\{` sep *entry* - :math:`\}`” in standard BNF, or “*entry* :math:`(` sep *entry* - :math:`)`\ \*” in the syntax of regular expressions. - -.. [2] Except if the inductive type is empty in which case there is no equation that can be used to infer the return type. diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index cfdc70d50e..dd80b29bda 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -1,12 +1,12 @@ .. _ltac2: +Ltac2 +===== + .. coqtop:: none From Ltac2 Require Import Ltac2. -Ltac2 -===== - The Ltac tactic language is probably one of the ingredients of the success of Coq, yet it is at the same time its Achilles' heel. Indeed, Ltac: diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 6884b6e998..0527e26353 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -490,6 +490,13 @@ The following example script illustrates all these features: You just finished a goal focused by ``{``, you must unfocus it with ``}``. +Mandatory Bullets +````````````````` + +Using :opt:`Default Goal Selector` with the ``!`` selector forces +tactic scripts to keep focus to exactly one goal (e.g. using bullets) +or use explicit goal selectors. + Set Bullet Behavior ``````````````````` .. opt:: Bullet Behavior {| "None" | "Strict Subproofs" } diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 81e50c0834..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 @@ -685,6 +688,28 @@ Applying theorems instantiate (see :ref:`Existential-Variables`). The instantiation is intended to be found later in the proof. + .. tacv:: rapply @term + :name: rapply + + The tactic :tacn:`rapply` behaves like :tacn:`eapply` but it + uses the proof engine of :tacn:`refine` for dealing with + existential variables, holes, and conversion problems. This may + result in slightly different behavior regarding which conversion + problems are solvable. However, like :tacn:`apply` but unlike + :tacn:`eapply`, :tacn:`rapply` will fail if there are any holes + which remain in :n:`@term` itself after typechecking and + typeclass resolution but before unification with the goal. More + technically, :n:`@term` is first parsed as a + :production:`constr` rather than as a :production:`uconstr` or + :production:`open_constr` before being applied to the goal. Note + that :tacn:`rapply` prefers to instantiate as many hypotheses of + :n:`@term` as possible. As a result, if it is possible to apply + :n:`@term` to arbitrarily many arguments without getting a type + error, :tacn:`rapply` will loop. + + Note that you need to :n:`Require Import Coq.Program.Tactics` to + make use of :tacn:`rapply`. + .. tacv:: simple apply @term. This behaves like :tacn:`apply` but it reasons modulo conversion only on subterms diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 89b24ea8a3..a38c26c2b3 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1200,7 +1200,7 @@ Controlling the locality of commands + Commands whose default behavior is to extend their effect outside sections but not outside modules when they occur in a section and to extend their effect outside the module or library file they occur in - when no section contains them.For these commands, the Local modifier + when no section contains them. For these commands, the Local modifier limits the effect to the current section or module while the Global modifier extends the effect outside the module even when the command occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this 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/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index eff70bdac5..1f9178f4b6 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -403,55 +403,60 @@ class TableObject(NotationObject): class ProductionObject(CoqObject): r"""A grammar production. - This is useful if you intend to document individual grammar productions. - Otherwise, use Sphinx's `production lists + Use ``.. prodn`` to document grammar productions instead of Sphinx + `production lists <http://www.sphinx-doc.org/en/stable/markup/para.html#directive-productionlist>`_. - Unlike ``.. productionlist``\ s, this directive accepts notation syntax. - - - Usage:: - - .. prodn:: token += production - .. prodn:: token ::= production + prodn displays multiple productions together with alignment similar to ``.. productionlist``, + however unlike ``.. productionlist``\ s, this directive accepts notation syntax. Example:: - .. prodn:: term += let: @pattern := @term in @term .. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } + term += let: @pattern := @term in @term + | second_production + + The first line defines "occ_switch", which must be unique in the document. The second + references and expands the definition of "term", whose main definition is elsewhere + in the document. The third form is for continuing the + definition of a nonterminal when it has multiple productions. It leaves the first + column in the output blank. """ subdomain = "prodn" #annotation = "Grammar production" + # handle_signature is called for each line of input in the prodn:: + # 'signatures' accumulates them in order to combine the lines into a single table: + signatures = None + def _render_signature(self, signature, signode): raise NotImplementedError(self) SIG_ERROR = ("{}: Invalid syntax in ``.. prodn::`` directive" + "\nExpected ``name ::= ...`` or ``name += ...``" - + " (e.g. ``pattern += constr:(@ident)``)") + + " (e.g. ``pattern += constr:(@ident)``)\n" + + " in `{}`") def handle_signature(self, signature, signode): - nsplits = 2 - parts = signature.split(maxsplit=nsplits) - if len(parts) != 3: - loc = os.path.basename(get_node_location(signode)) - raise ExtensionError(ProductionObject.SIG_ERROR.format(loc)) - - lhs, op, rhs = (part.strip() for part in parts) - if op not in ["::=", "+="]: - loc = os.path.basename(get_node_location(signode)) - raise ExtensionError(ProductionObject.SIG_ERROR.format(loc)) - - self._render_annotation(signode) - - lhs_op = '{} {} '.format(lhs, op) - lhs_node = nodes.literal(lhs_op, lhs_op) - - position = self.state_machine.get_source_and_line(self.lineno) - rhs_node = notation_to_sphinx(rhs, *position) - signode += addnodes.desc_name(signature, '', lhs_node, rhs_node) + parts = signature.split(maxsplit=1) + if parts[0].strip() == "|" and len(parts) == 2: + lhs = "" + op = "|" + rhs = parts[1].strip() + else: + nsplits = 2 + parts = signature.split(maxsplit=nsplits) + if len(parts) != 3: + loc = os.path.basename(get_node_location(signode)) + raise ExtensionError(ProductionObject.SIG_ERROR.format(loc, signature)) + else: + lhs, op, rhs = (part.strip() for part in parts) + if op not in ["::=", "+="]: + loc = os.path.basename(get_node_location(signode)) + raise ExtensionError(ProductionObject.SIG_ERROR.format(loc, signature)) + self.signatures.append((lhs, op, rhs)) return ('token', lhs) if op == '::=' else None def _add_index_entry(self, name, target): @@ -468,6 +473,49 @@ class ProductionObject(CoqObject): self._warn_if_duplicate_name(objects, name) objects[name] = env.docname, targetid + def run(self): + self.signatures = [] + indexnode = super().run()[0] # makes calls to handle_signature + + table = nodes.inline(classes=['prodn-table']) + tgroup = nodes.inline(classes=['prodn-column-group']) + for i in range(3): + tgroup += nodes.inline(classes=['prodn-column']) + table += tgroup + tbody = nodes.inline(classes=['prodn-row-group']) + table += tbody + + # create rows + for signature in self.signatures: + lhs, op, rhs = signature + position = self.state_machine.get_source_and_line(self.lineno) + + row = nodes.inline(classes=['prodn-row']) + entry = nodes.inline(classes=['prodn-cell-nonterminal']) + if lhs != "": + target_name = 'grammar-token-' + lhs + target = nodes.target('', '', ids=[target_name], names=[target_name]) + # putting prodn-target on the target node won't appear in the tex file + inline = nodes.inline(classes=['prodn-target']) + inline += target + entry += inline + entry += notation_to_sphinx('@'+lhs, *position) + else: + entry += nodes.literal('', '') + row += entry + + entry = nodes.inline(classes=['prodn-cell-op']) + entry += nodes.literal(op, op) + row += entry + + entry = nodes.inline(classes=['prodn-cell-production']) + entry += notation_to_sphinx(rhs, *position) + row += entry + + tbody += row + + return [indexnode, table] # only this node goes into the doc + class ExceptionObject(NotationObject): """An error raised by a Coq command or tactic. diff --git a/doc/tools/coqrst/notations/TacticNotations.g b/doc/tools/coqrst/notations/TacticNotations.g index 905b52525a..f9cf26a21e 100644 --- a/doc/tools/coqrst/notations/TacticNotations.g +++ b/doc/tools/coqrst/notations/TacticNotations.g @@ -42,7 +42,8 @@ LALT: '{|'; LGROUP: '{+' | '{*' | '{?'; LBRACE: '{'; RBRACE: '}'; -ESCAPED: '%{' | '%}' | '%|'; +// todo: need a cleaner way to escape the 3-character strings here +ESCAPED: '%{' | '%}' | '%|' | '`%{' | '@%{'; PIPE: '|'; ATOM: '@' | '_' | ~[@_{}| ]+; ID: '@' ('_'? [a-zA-Z0-9])+; diff --git a/doc/tools/coqrst/notations/TacticNotationsLexer.py b/doc/tools/coqrst/notations/TacticNotationsLexer.py index e3a115e32a..7bda849010 100644 --- a/doc/tools/coqrst/notations/TacticNotationsLexer.py +++ b/doc/tools/coqrst/notations/TacticNotationsLexer.py @@ -8,33 +8,35 @@ import sys def serializedATN(): with StringIO() as buf: buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\f") - buf.write("M\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") + buf.write("S\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") buf.write("\4\b\t\b\4\t\t\t\4\n\t\n\4\13\t\13\3\2\3\2\3\2\3\3\3\3") buf.write("\3\3\3\3\3\3\3\3\5\3!\n\3\3\4\3\4\3\5\3\5\3\6\3\6\3\6") - buf.write("\3\6\3\6\3\6\5\6-\n\6\3\7\3\7\3\b\3\b\6\b\63\n\b\r\b\16") - buf.write("\b\64\5\b\67\n\b\3\t\3\t\5\t;\n\t\3\t\6\t>\n\t\r\t\16") - buf.write("\t?\3\n\3\n\3\n\6\nE\n\n\r\n\16\nF\3\13\6\13J\n\13\r\13") - buf.write("\16\13K\2\2\f\3\3\5\4\7\5\t\6\13\7\r\b\17\t\21\n\23\13") - buf.write("\25\f\3\2\5\4\2BBaa\6\2\"\"BBaa}\177\5\2\62;C\\c|\2V\2") - buf.write("\3\3\2\2\2\2\5\3\2\2\2\2\7\3\2\2\2\2\t\3\2\2\2\2\13\3") - buf.write("\2\2\2\2\r\3\2\2\2\2\17\3\2\2\2\2\21\3\2\2\2\2\23\3\2") - buf.write("\2\2\2\25\3\2\2\2\3\27\3\2\2\2\5 \3\2\2\2\7\"\3\2\2\2") - buf.write("\t$\3\2\2\2\13,\3\2\2\2\r.\3\2\2\2\17\66\3\2\2\2\218\3") - buf.write("\2\2\2\23A\3\2\2\2\25I\3\2\2\2\27\30\7}\2\2\30\31\7~\2") - buf.write("\2\31\4\3\2\2\2\32\33\7}\2\2\33!\7-\2\2\34\35\7}\2\2\35") - buf.write("!\7,\2\2\36\37\7}\2\2\37!\7A\2\2 \32\3\2\2\2 \34\3\2\2") - buf.write("\2 \36\3\2\2\2!\6\3\2\2\2\"#\7}\2\2#\b\3\2\2\2$%\7\177") - buf.write("\2\2%\n\3\2\2\2&\'\7\'\2\2\'-\7}\2\2()\7\'\2\2)-\7\177") - buf.write("\2\2*+\7\'\2\2+-\7~\2\2,&\3\2\2\2,(\3\2\2\2,*\3\2\2\2") - buf.write("-\f\3\2\2\2./\7~\2\2/\16\3\2\2\2\60\67\t\2\2\2\61\63\n") - buf.write("\3\2\2\62\61\3\2\2\2\63\64\3\2\2\2\64\62\3\2\2\2\64\65") - buf.write("\3\2\2\2\65\67\3\2\2\2\66\60\3\2\2\2\66\62\3\2\2\2\67") - buf.write("\20\3\2\2\28=\7B\2\29;\7a\2\2:9\3\2\2\2:;\3\2\2\2;<\3") - buf.write("\2\2\2<>\t\4\2\2=:\3\2\2\2>?\3\2\2\2?=\3\2\2\2?@\3\2\2") - buf.write("\2@\22\3\2\2\2AB\7a\2\2BD\7a\2\2CE\t\4\2\2DC\3\2\2\2E") - buf.write("F\3\2\2\2FD\3\2\2\2FG\3\2\2\2G\24\3\2\2\2HJ\7\"\2\2IH") - buf.write("\3\2\2\2JK\3\2\2\2KI\3\2\2\2KL\3\2\2\2L\26\3\2\2\2\13") - buf.write("\2 ,\64\66:?FK\2") + buf.write("\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\5\6\63\n\6\3\7\3") + buf.write("\7\3\b\3\b\6\b9\n\b\r\b\16\b:\5\b=\n\b\3\t\3\t\5\tA\n") + buf.write("\t\3\t\6\tD\n\t\r\t\16\tE\3\n\3\n\3\n\6\nK\n\n\r\n\16") + buf.write("\nL\3\13\6\13P\n\13\r\13\16\13Q\2\2\f\3\3\5\4\7\5\t\6") + buf.write("\13\7\r\b\17\t\21\n\23\13\25\f\3\2\5\4\2BBaa\6\2\"\"B") + buf.write("Baa}\177\5\2\62;C\\c|\2^\2\3\3\2\2\2\2\5\3\2\2\2\2\7\3") + buf.write("\2\2\2\2\t\3\2\2\2\2\13\3\2\2\2\2\r\3\2\2\2\2\17\3\2\2") + buf.write("\2\2\21\3\2\2\2\2\23\3\2\2\2\2\25\3\2\2\2\3\27\3\2\2\2") + buf.write("\5 \3\2\2\2\7\"\3\2\2\2\t$\3\2\2\2\13\62\3\2\2\2\r\64") + buf.write("\3\2\2\2\17<\3\2\2\2\21>\3\2\2\2\23G\3\2\2\2\25O\3\2\2") + buf.write("\2\27\30\7}\2\2\30\31\7~\2\2\31\4\3\2\2\2\32\33\7}\2\2") + buf.write("\33!\7-\2\2\34\35\7}\2\2\35!\7,\2\2\36\37\7}\2\2\37!\7") + buf.write("A\2\2 \32\3\2\2\2 \34\3\2\2\2 \36\3\2\2\2!\6\3\2\2\2\"") + buf.write("#\7}\2\2#\b\3\2\2\2$%\7\177\2\2%\n\3\2\2\2&\'\7\'\2\2") + buf.write("\'\63\7}\2\2()\7\'\2\2)\63\7\177\2\2*+\7\'\2\2+\63\7~") + buf.write("\2\2,-\7b\2\2-.\7\'\2\2.\63\7}\2\2/\60\7B\2\2\60\61\7") + buf.write("\'\2\2\61\63\7}\2\2\62&\3\2\2\2\62(\3\2\2\2\62*\3\2\2") + buf.write("\2\62,\3\2\2\2\62/\3\2\2\2\63\f\3\2\2\2\64\65\7~\2\2\65") + buf.write("\16\3\2\2\2\66=\t\2\2\2\679\n\3\2\28\67\3\2\2\29:\3\2") + buf.write("\2\2:8\3\2\2\2:;\3\2\2\2;=\3\2\2\2<\66\3\2\2\2<8\3\2\2") + buf.write("\2=\20\3\2\2\2>C\7B\2\2?A\7a\2\2@?\3\2\2\2@A\3\2\2\2A") + buf.write("B\3\2\2\2BD\t\4\2\2C@\3\2\2\2DE\3\2\2\2EC\3\2\2\2EF\3") + buf.write("\2\2\2F\22\3\2\2\2GH\7a\2\2HJ\7a\2\2IK\t\4\2\2JI\3\2\2") + buf.write("\2KL\3\2\2\2LJ\3\2\2\2LM\3\2\2\2M\24\3\2\2\2NP\7\"\2\2") + buf.write("ON\3\2\2\2PQ\3\2\2\2QO\3\2\2\2QR\3\2\2\2R\26\3\2\2\2\13") + buf.write("\2 \62:<@ELQ\2") return buf.getvalue() diff --git a/doc/tools/coqrst/notations/fontsupport.py b/doc/tools/coqrst/notations/fontsupport.py index f0df7f1c01..c3ba2c1301 100755 --- a/doc/tools/coqrst/notations/fontsupport.py +++ b/doc/tools/coqrst/notations/fontsupport.py @@ -1,4 +1,5 @@ #!/usr/bin/env python2 +# -*- coding: utf-8 -*- ########################################################################## ## # The Coq Proof Assistant / The Coq Development Team ## ## v # INRIA, CNRS and contributors - Copyright 1999-2019 ## diff --git a/doc/tools/coqrst/notations/html.py b/doc/tools/coqrst/notations/html.py index d9c5383774..1136ee4997 100644 --- a/doc/tools/coqrst/notations/html.py +++ b/doc/tools/coqrst/notations/html.py @@ -61,7 +61,7 @@ class TacticNotationsToHTMLVisitor(TacticNotationsVisitor): tags.sub(sub.getText()[1:]) def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): - tags.span(ctx.ESCAPED().getText()[1:]) + tags.span(ctx.ESCAPED().getText().replace("%", "")) def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): text(" ") diff --git a/doc/tools/coqrst/notations/plain.py b/doc/tools/coqrst/notations/plain.py index 93a7ec4683..23996b0d63 100644 --- a/doc/tools/coqrst/notations/plain.py +++ b/doc/tools/coqrst/notations/plain.py @@ -53,7 +53,7 @@ class TacticNotationsToDotsVisitor(TacticNotationsVisitor): self.buffer.write("‘{}’".format(ctx.ID().getText()[1:])) def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): - self.buffer.write(ctx.ESCAPED().getText()[1:]) + self.buffer.write(ctx.ESCAPED().getText().replace("%", "")) def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): self.buffer.write(" ") diff --git a/doc/tools/coqrst/notations/sphinx.py b/doc/tools/coqrst/notations/sphinx.py index 4ca0a2ef83..ab18d136b8 100644 --- a/doc/tools/coqrst/notations/sphinx.py +++ b/doc/tools/coqrst/notations/sphinx.py @@ -45,7 +45,11 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): def visitRepeat(self, ctx:TacticNotationsParser.RepeatContext): # Uses inline nodes instead of subscript and superscript to ensure that # we get the right customization hooks at the LaTeX level - wrapper = nodes.inline('', '', classes=['repeat-wrapper']) + separator = ctx.ATOM() or ctx.PIPE() + # I wanted to have 2 independent classes "repeat-wrapper" and "with-sub" here, + # but that breaks the latex build (invalid .tex file) + classes = 'repeat-wrapper-with-sub' if separator else 'repeat-wrapper' + wrapper = nodes.inline('', '', classes=[classes]) children = self.visitChildren(ctx) if len(children) == 1 and self.is_alternative(children[0]): @@ -58,7 +62,6 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): repeat_marker = ctx.LGROUP().getText()[1] wrapper += nodes.inline(repeat_marker, repeat_marker, classes=['notation-sup']) - separator = ctx.ATOM() or ctx.PIPE() if separator: sep = separator.getText() wrapper += nodes.inline(sep, sep, classes=['notation-sub']) @@ -72,10 +75,33 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): sp += nodes.Text("}") return [sp] + def escape(self, atom): + node = nodes.inline("","") + while atom != "": + if atom[0] == "'": + node += nodes.raw("\\textquotesingle{}", "\\textquotesingle{}", format="latex") + atom = atom[1:] + elif atom[0] == "`": + node += nodes.raw("\\`{}", "\\`{}", format="latex") + atom = atom[1:] + else: + index_ap = atom.find("'") + index_bt = atom.find("`") + if index_ap == -1: + index = index_bt + elif index_bt == -1: + index = index_ap + else: + index = min(index_ap, index_bt) + lit = atom if index == -1 else atom[:index] + node += nodes.inline(lit, lit) + atom = atom[len(lit):] + return node + def visitAtomic(self, ctx:TacticNotationsParser.AtomicContext): atom = ctx.ATOM().getText() sub = ctx.SUB() - node = nodes.inline(atom, atom) + node = self.escape(atom) if sub: sub_index = sub.getText()[2:] @@ -101,7 +127,7 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): escaped = ctx.ESCAPED().getText() - return [nodes.inline(escaped, escaped[1:])] + return [self.escape(escaped.replace("%", ""))] def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): return [nodes.Text(" ")] diff --git a/doc/tools/docgram/README.md b/doc/tools/docgram/README.md index a0a1809133..182532e413 100644 --- a/doc/tools/docgram/README.md +++ b/doc/tools/docgram/README.md @@ -194,14 +194,15 @@ to the grammar. ### `.rst` file updates -`doc_grammar` updates `.rst` files when it sees the following 3 lines +`doc_grammar` updates `.rst` files where it sees the following 3 lines ``` -.. insertgram <start> <end> -.. productionlist:: XXX +.. insertprodn <start> <end> + +.. prodn:: ``` -The end of the existing `productionlist` is recognized by a blank line. +The end of the existing `prodn` is recognized by a blank line. ### Other details diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 06b49a0a18..9c1827f5b7 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -65,6 +65,7 @@ DELETE: [ | test_lpar_idnum_coloneq | test_nospace_pipe_closedcurly | test_show_goal +| ensure_fixannot (* SSR *) (* | ssr_null_entry *) @@ -101,18 +102,8 @@ hyp: [ | var ] -empty: [ -| -] - -or_opt: [ -| "|" -| empty -] - ltac_expr_opt: [ -| tactic_expr5 -| empty +| OPT tactic_expr5 ] ltac_expr_opt_list_or: [ @@ -124,7 +115,7 @@ tactic_then_gen: [ | EDIT ADD_OPT tactic_expr5 "|" tactic_then_gen | EDIT ADD_OPT tactic_expr5 ".." tactic_then_last | REPLACE OPT tactic_expr5 ".." tactic_then_last -| WITH ltac_expr_opt ".." or_opt ltac_expr_opt_list_or +| WITH ltac_expr_opt ".." OPT "|" ltac_expr_opt_list_or ] ltac_expr_opt_list_or: [ @@ -144,24 +135,23 @@ fullyqualid: [ | qualid ] - -field: [ | DELETENT ] - -field: [ +field_ident: [ | "." ident ] basequalid: [ | REPLACE ident fields -| WITH qualid field +| WITH ident LIST0 field_ident +| DELETE ident ] +field: [ | DELETENT ] fields: [ | DELETENT ] dirpath: [ | REPLACE ident LIST0 field | WITH ident -| dirpath field +| dirpath field_ident ] binders: [ @@ -172,45 +162,37 @@ lconstr: [ | DELETE l_constr ] -let_type_cstr: [ -| DELETE OPT [ ":" lconstr ] -| rec_type_cstr +type_cstr: [ +| REPLACE ":" lconstr +| WITH OPT ( ":" lconstr ) +| DELETE (* empty *) ] -as_name_opt: [ -| "as" name -| empty +let_type_cstr: [ +| DELETE OPT [ ":" lconstr ] +| type_cstr ] (* rename here because we want to use "return_type" for something else *) RENAME: [ -| return_type as_return_type_opt -] - -as_return_type_opt: [ -| REPLACE OPT [ OPT [ "as" name ] case_type ] -| WITH as_name_opt case_type -| empty +| return_type as_return_type ] case_item: [ | REPLACE operconstr100 OPT [ "as" name ] OPT [ "in" pattern200 ] -| WITH operconstr100 as_name_opt OPT [ "in" pattern200 ] -] - -as_dirpath: [ -| DELETE OPT [ "as" dirpath ] -| "as" dirpath -| empty +| WITH operconstr100 OPT ("as" name) OPT [ "in" pattern200 ] ] binder_constr: [ | MOVETO term_let "let" name binders let_type_cstr ":=" operconstr200 "in" operconstr200 -| MOVETO term_let "let" single_fix "in" operconstr200 -| MOVETO term_let "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type_opt ":=" operconstr200 "in" operconstr200 +| MOVETO term_fix "let" "fix" fix_decl "in" operconstr200 +| MOVETO term_cofix "let" "cofix" cofix_decl "in" operconstr200 +| MOVETO term_let "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" operconstr200 "in" operconstr200 | MOVETO term_let "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 | MOVETO term_let "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 | MOVETO term_let "let" "'" pattern200 "in" pattern200 ":=" operconstr200 case_type "in" operconstr200 +| MOVETO term_fix "fix" fix_decls +| MOVETO term_cofix "cofix" cofix_decls ] term_let: [ @@ -218,8 +200,8 @@ term_let: [ | WITH "let" name let_type_cstr ":=" operconstr200 "in" operconstr200 | "let" name LIST1 binder let_type_cstr ":=" operconstr200 "in" operconstr200 (* Don't need to document that "( )" is equivalent to "()" *) -| REPLACE "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type_opt ":=" operconstr200 "in" operconstr200 -| WITH "let" [ "(" LIST1 name SEP "," ")" | "()" ] as_return_type_opt ":=" operconstr200 "in" operconstr200 +| REPLACE "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" operconstr200 "in" operconstr200 +| WITH "let" "(" LIST0 name SEP "," ")" as_return_type ":=" operconstr200 "in" operconstr200 | REPLACE "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 | WITH "let" "'" pattern200 ":=" operconstr200 OPT case_type "in" operconstr200 | DELETE "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 @@ -228,6 +210,8 @@ term_let: [ atomic_constr: [ (* @Zimmi48: "string" used only for notations, but keep to be consistent with patterns *) (* | DELETE string *) +| REPLACE global univ_instance +| WITH global OPT univ_instance | REPLACE "?" "[" ident "]" | WITH "?[" ident "]" | MOVETO term_evar "?[" ident "]" @@ -253,6 +237,8 @@ operconstr10: [ (* fixme: add in as a prodn somewhere *) | MOVETO dangling_pattern_extension_rule "@" pattern_identref LIST1 identref | DELETE dangling_pattern_extension_rule +| REPLACE "@" global univ_instance LIST0 operconstr9 +| WITH "@" global OPT univ_instance LIST0 operconstr9 ] operconstr9: [ @@ -260,64 +246,45 @@ operconstr9: [ | DELETE ".." operconstr0 ".." ] -arg_list: [ -| arg_list appl_arg -| appl_arg -] - -arg_list_opt: [ -| arg_list -| empty -] - operconstr1: [ | REPLACE operconstr0 ".(" global LIST0 appl_arg ")" -| WITH operconstr0 ".(" global arg_list_opt ")" -| MOVETO term_projection operconstr0 ".(" global arg_list_opt ")" +| WITH operconstr0 ".(" global LIST0 appl_arg ")" +| MOVETO term_projection operconstr0 ".(" global LIST0 appl_arg ")" | MOVETO term_projection operconstr0 ".(" "@" global LIST0 ( operconstr9 ) ")" ] operconstr0: [ (* @Zimmi48: This rule is a hack, according to Hugo, and should not be shown in the manual. *) | DELETE "{" binder_constr "}" +| REPLACE "{|" record_declaration bar_cbrace +| WITH "{|" LIST0 field_def bar_cbrace ] -single_fix: [ -| DELETE fix_kw fix_decl -| "fix" fix_decl -| "cofix" fix_decl +fix_decls: [ +| DELETE fix_decl +| REPLACE fix_decl "with" LIST1 fix_decl SEP "with" "for" identref +| WITH fix_decl OPT ( LIST1 ("with" fix_decl) "for" identref ) ] -fix_kw: [ | DELETENT ] +cofix_decls: [ +| DELETE cofix_decl +| REPLACE cofix_decl "with" LIST1 cofix_decl SEP "with" "for" identref +| WITH cofix_decl OPT ( LIST1 ( "with" cofix_decl ) "for" identref ) +] -binders_fixannot: [ -(* -| REPLACE impl_name_head impl_ident_tail binders_fixannot -| WITH impl_name_head impl_ident_tail "}" binders_fixannot -*) -(* Omit this complex detail. See https://github.com/coq/coq/pull/10614#discussion_r344118146 *) -| DELETE impl_name_head impl_ident_tail binders_fixannot +fields_def: [ +| REPLACE field_def ";" fields_def +| WITH LIST1 field_def SEP ";" +| DELETE field_def +] -| DELETE fixannot +binders_fixannot: [ | DELETE binder binders_fixannot +| DELETE fixannot | DELETE (* empty *) - | LIST0 binder OPT fixannot ] -impl_ident_tail: [ -| DELETENT -(* -| REPLACE "}" -| WITH empty -| REPLACE LIST1 name ":" lconstr "}" -| WITH LIST1 name ":" lconstr -| REPLACE LIST1 name "}" -| WITH LIST1 name -| REPLACE ":" lconstr "}" -| WITH ":" lconstr -*) -] of_type_with_opt_coercion: [ | DELETE ":>" ">" @@ -347,18 +314,28 @@ closed_binder: [ | DELETE "(" name ":" lconstr ")" | DELETE "(" name ":=" lconstr ")" + | REPLACE "(" name ":" lconstr ":=" lconstr ")" -| WITH "(" name rec_type_cstr ":=" lconstr ")" +| WITH "(" name type_cstr ":=" lconstr ")" +| DELETE "{" name "}" | DELETE "{" name LIST1 name "}" | REPLACE "{" name LIST1 name ":" lconstr "}" -| WITH "{" LIST1 name rec_type_cstr "}" +| WITH "{" LIST1 name type_cstr "}" | DELETE "{" name ":" lconstr "}" ] +name_colon: [ +| name ":" +] + typeclass_constraint: [ | EDIT ADD_OPT "!" operconstr200 +| REPLACE "{" name "}" ":" [ "!" | ] operconstr200 +| WITH "{" name "}" ":" OPT "!" operconstr200 +| REPLACE name_colon [ "!" | ] operconstr200 +| WITH name_colon OPT "!" operconstr200 ] (* ?? From the grammar, Prim.name seems to be only "_" but ident is also accepted "*) @@ -376,62 +353,54 @@ DELETE: [ | orient_rw ] -pattern1_list: [ -| pattern1_list pattern1 -| pattern1 -] - -pattern1_list_opt: [ -| pattern1_list -| empty -] - pattern10: [ | REPLACE pattern1 LIST1 pattern1 -| WITH LIST1 pattern1 -| REPLACE "@" reference LIST0 pattern1 -| WITH "@" reference pattern1_list_opt +| WITH pattern1 LIST0 pattern1 +| DELETE pattern1 ] pattern0: [ | REPLACE "(" pattern200 ")" | WITH "(" LIST1 pattern200 SEP "|" ")" | DELETE "(" pattern200 "|" LIST1 pattern200 SEP "|" ")" +| REPLACE "{|" record_patterns bar_cbrace +| WITH "{|" LIST0 record_pattern bar_cbrace ] -patterns_comma: [ -| patterns_comma "," pattern100 -| pattern100 -] - -patterns_comma_list_or: [ -| patterns_comma_list_or "|" patterns_comma -| patterns_comma +DELETE: [ +| record_patterns ] eqn: [ | REPLACE LIST1 mult_pattern SEP "|" "=>" lconstr -| WITH patterns_comma_list_or "=>" lconstr +| WITH LIST1 [ LIST1 pattern100 SEP "," ] SEP "|" "=>" lconstr ] -record_patterns: [ -| REPLACE record_pattern ";" record_patterns -| WITH record_patterns ";" record_pattern +universe_increment: [ +| REPLACE "+" natural +| WITH OPT ( "+" natural ) +| DELETE (* empty *) ] -(* todo: binders should be binders_opt *) - +evar_instance: [ +| REPLACE "@{" LIST1 inst SEP ";" "}" +| WITH OPT ( "@{" LIST1 inst SEP ";" "}" ) +| DELETE (* empty *) +] -(* lexer stuff *) -bigint: [ -| DELETE NUMERAL -| num +univ_instance: [ +| DELETE (* empty *) ] -ident: [ -| DELETENT +constr: [ +| REPLACE "@" global univ_instance +| WITH "@" global OPT univ_instance ] +(* todo: binders should be binders_opt *) + + +(* lexer stuff *) IDENT: [ | ident ] @@ -445,11 +414,45 @@ LEFTQMARK: [ | "?" ] +digit: [ +| "0" ".." "9" +] + +num: [ +| LIST1 digit +] + natural: [ | DELETENT ] natural: [ | num (* todo: or should it be "nat"? *) ] +numeral: [ +| LIST1 digit OPT ("." LIST1 digit) OPT [ [ "e" | "E" ] OPT [ "+" | "-" ] LIST1 digit ] +] + +int: [ +| OPT "-" LIST1 digit +] + +bigint: [ +| DELETE NUMERAL +| num +] + +first_letter: [ +| [ "a" ".." "z" | "A" ".." "Z" | "_" | unicode_letter ] +] + +subsequent_letter: [ +| [ first_letter | digit | "'" | unicode_id_part ] +] + +ident: [ +| DELETE IDENT +| first_letter LIST0 subsequent_letter +] + NUMERAL: [ | numeral ] @@ -467,10 +470,6 @@ STRING: [ (* added productions *) -name_colon: [ -| name ":" -] - command_entry: [ | noedit_mode ] @@ -528,12 +527,6 @@ simple_tactic: [ | WITH "eintros" intropatterns ] -intropatterns: [ -| DELETE LIST0 intropattern -| intropatterns intropattern -| empty -] - (* todo: don't use DELETENT for this *) ne_intropatterns: [ | DELETENT ] @@ -594,7 +587,6 @@ SPLICE: [ | reference | bar_cbrace | lconstr -| impl_name_head (* | ast_closure_term @@ -665,6 +657,15 @@ SPLICE: [ | name_colon | closed_binder | binders_fixannot +| as_return_type +| case_type +| fields_def +| universe_increment +| type_cstr +| record_pattern +| evar_instance +| fix_decls +| cofix_decls ] RENAME: [ @@ -703,20 +704,13 @@ RENAME: [ | BULLET bullet | nat_or_var num_or_var | fix_decl fix_body -| instance universe_annot_opt -| rec_type_cstr colon_term_opt -| fix_constr term_fix +| cofix_decl cofix_body | constr term1_extended -| case_type return_type | appl_arg arg -| record_patterns record_patterns_opt -| universe_increment universe_increment_opt | rec_definition fix_definition | corec_definition cofix_definition -| record_field_instance field_def -| record_fields_instance fields_def -| evar_instance evar_bindings_opt | inst evar_binding +| univ_instance univ_annot ] diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 70976e705e..b50c427742 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -49,7 +49,7 @@ let default_args = { } let start_symbols = ["vernac_toplevel"] -let tokens = [ "bullet"; "ident"; "int"; "num"; "numeral"; "string" ] +let tokens = [ "bullet"; "string"; "unicode_id_part"; "unicode_letter" ] (* translated symbols *) @@ -148,8 +148,10 @@ module DocGram = struct let g_add_prod_after g ins_after nt prod = let prods = try NTMap.find nt !g.map with Not_found -> [] in - (* todo: add check for duplicates *) - g_add_after g ~update:true ins_after nt (prods @ [prod]) + if prods <> [] then + g_update_prods g nt (prods @ [prod]) + else + g_add_after g ~update:true ins_after nt [prod] (* replace the map and order *) let g_reorder g map order = @@ -237,7 +239,17 @@ and prod_to_str ?(plist=false) prod = let rec output_prodn = function - | Sterm s -> let s = if List.mem s ["{"; "{|"; "|"; "}"] then "%" ^ s else s in + | Sterm s -> + let s = match s with + | "|}" -> "%|%}" + | "{|" -> "%{%|" + | "`{" -> "`%{" + | "@{" -> "@%{" + | "{" + | "}" + | "|" -> "%" ^ s + | _ -> s + in sprintf "%s" s | Snterm s -> sprintf "@%s" s | Slist1 sym -> sprintf "{+ %s }" (output_prodn sym) @@ -266,7 +278,14 @@ and output_sep sep = | Sterm s -> sprintf "%s" s (* avoid escaping separator *) | _ -> output_prodn sep -and prod_to_prodn prod = String.concat " " (List.map output_prodn prod) +and prod_to_prodn_r prod = + match prod with + | Sterm s :: Snterm "ident" :: tl when List.mem s ["?"; "."] -> + (sprintf "%s@ident" s) :: (prod_to_prodn_r tl) + | p :: tl -> (output_prodn p) :: (prod_to_prodn_r tl) + | [] -> [] + +and prod_to_prodn prod = String.concat " " (prod_to_prodn_r prod) let pr_prods nt prods = (* duplicative *) Printf.printf "%s: [\n" nt; @@ -304,11 +323,11 @@ let print_in_order out g fmt nt_order hide = fprintf out "%s%s\n" pfx str) prods; | `PRODN -> - fprintf out "\n%s:\n" nt; - List.iter (fun prod -> + fprintf out "\n%s:\n%s " nt nt; + List.iteri (fun i prod -> let str = prod_to_prodn prod in - let pfx = if str = "" then "" else " " in - fprintf out "%s%s\n" pfx str) + let op = if i = 0 then "::=" else "+=" in + fprintf out "%s %s\n" op str) prods; with Not_found -> error "Missing nt '%s' in print_in_order\n" nt) nt_order @@ -458,8 +477,10 @@ let ematch prod edit = -> ematchr [psym] [sym] && ematchr [psep] [sep] | (Sparen psyml, Sparen syml) -> ematchr psyml syml - | (Sprod psymll, Sprod symll) - -> List.fold_left (&&) true (List.map2 ematchr psymll symll) + | (Sprod psymll, Sprod symll) -> + if List.compare_lengths psymll symll != 0 then false + else + List.fold_left (&&) true (List.map2 ematchr psymll symll) | _, _ -> phd = hd in m && ematchr ptl tl @@ -691,17 +712,22 @@ let rec edit_prod g top edit_map prod = | _ -> [Snterm binding] with Not_found -> [sym0] in + let maybe_wrap syms = + match syms with + | s :: [] -> List.hd syms + | s -> Sparen (List.rev syms) + in let rec edit_symbol sym0 = match sym0 with | Sterm s -> [sym0] | Snterm s -> edit_nt edit_map sym0 s - | Slist1 sym -> [Slist1 (List.hd (edit_symbol sym))] + | Slist1 sym -> [Slist1 (maybe_wrap (edit_symbol sym))] (* you'll get a run-time failure deleting a SEP symbol *) - | Slist1sep (sym, sep) -> [Slist1sep (List.hd (edit_symbol sym), (List.hd (edit_symbol sep)))] - | Slist0 sym -> [Slist0 (List.hd (edit_symbol sym))] - | Slist0sep (sym, sep) -> [Slist0sep (List.hd (edit_symbol sym), (List.hd (edit_symbol sep)))] - | Sopt sym -> [Sopt (List.hd (edit_symbol sym))] + | Slist1sep (sym, sep) -> [Slist1sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] + | Slist0 sym -> [Slist0 (maybe_wrap (edit_symbol sym))] + | Slist0sep (sym, sep) -> [Slist0sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] + | Sopt sym -> [Sopt (maybe_wrap (edit_symbol sym))] | Sparen slist -> [Sparen (List.hd (edit_prod g false edit_map slist))] | Sprod slistlist -> let (_, prods) = edit_rule g edit_map "" slistlist in [Sprod prods] @@ -1079,7 +1105,9 @@ let apply_edit_file g edits = g_add_prod_after g (Some nt) nt2 oprod; let prods' = (try let posn = find_first oprod prods nt in - let prods = insert_after posn [[Snterm nt2]] prods in (* insert new prod *) + let prods = if List.mem [Snterm nt2] prods then prods + else insert_after posn [[Snterm nt2]] prods (* insert new prod *) + in remove_prod oprod prods nt (* remove orig prod *) with Not_found -> prods) in @@ -1091,6 +1119,7 @@ let apply_edit_file g edits = aux tl (edit_single_prod g oprod prods nt) add_nt | (Snterm "REPLACE" :: oprod) :: (Snterm "WITH" :: rprod) :: tl -> report_undef_nts g rprod ""; + (* todo: check result not already present *) let prods' = (try let posn = find_first oprod prods nt in let prods = insert_after posn [rprod] prods in (* insert new prod *) @@ -1580,7 +1609,7 @@ let process_rst g file args seen tac_prods cmd_prods = line in (* todo: maybe pass end_index? *) - let output_insertgram start_index end_ indent is_coq_group = + let output_insertprodn start_index end_ indent = let rec copy_prods list = match list with | [] -> () @@ -1590,21 +1619,21 @@ let process_rst g file args seen tac_prods cmd_prods = warn "%s line %d: '%s' already included at %s line %d\n" file !linenum nt prev_file prev_linenum; with Not_found -> - if is_coq_group then - seen := { !seen with nts = (NTMap.add nt (file, !linenum) !seen.nts)} ); + seen := { !seen with nts = (NTMap.add nt (file, !linenum) !seen.nts)} ); let prods = NTMap.find nt !g.map in List.iteri (fun i prod -> - let rhs = String.trim (sprintf ": %s" (prod_to_str ~plist:true prod)) in - fprintf new_rst "%s %s %s\n" indent (if i = 0 then nt else String.make (String.length nt) ' ') rhs) + let rhs = String.trim (prod_to_prodn prod) in + let sep = if i = 0 then " ::=" else "|" in + fprintf new_rst "%s %s%s %s\n" indent (if i = 0 then nt else "") sep rhs) prods; if nt <> end_ then copy_prods tl in copy_prods (nthcdr start_index !g.order) in - let process_insertgram line rhs = + let process_insertprodn line rhs = if not (Str.string_match ig_args_regex rhs 0) then - error "%s line %d: bad arguments '%s' for 'insertgram'\n" file !linenum rhs + error "%s line %d: bad arguments '%s' for 'insertprodn'\n" file !linenum rhs else begin let start = Str.matched_group 1 rhs in let end_ = Str.matched_group 2 rhs in @@ -1624,19 +1653,18 @@ let process_rst g file args seen tac_prods cmd_prods = try let line2 = getline() in if not (Str.string_match blank_regex line2 0) then - error "%s line %d: expecting a blank line after 'insertgram'\n" file !linenum + error "%s line %d: expecting a blank line after 'insertprodn'\n" file !linenum else begin let line3 = getline() in - if not (Str.string_match dir_regex line3 0) || (Str.matched_group 2 line3) <> "productionlist::" then - error "%s line %d: expecting 'productionlist' after 'insertgram'\n" file !linenum + if not (Str.string_match dir_regex line3 0) || (Str.matched_group 2 line3) <> "prodn::" then + error "%s line %d: expecting 'prodn' after 'insertprodn'\n" file !linenum else begin let indent = Str.matched_group 1 line3 in - let is_coq_group = ("coq" = String.trim (Str.matched_group 3 line3)) in let rec skip_to_end () = let endline = getline() in if Str.string_match end_prodlist_regex endline 0 then begin fprintf new_rst "%s\n\n%s\n" line line3; - output_insertgram start_index end_ indent is_coq_group; + output_insertprodn start_index end_ indent; fprintf new_rst "%s\n" endline end else skip_to_end () @@ -1657,9 +1685,9 @@ let process_rst g file args seen tac_prods cmd_prods = let dir = Str.matched_group 2 line in let rhs = String.trim (Str.matched_group 3 line) in match dir with - | "productionlist::" -> + | "prodn::" -> if rhs = "coq" then - warn "%s line %d: Missing 'insertgram' before 'productionlist:: coq'\n" file !linenum; + warn "%s line %d: Missing 'insertprodn' before 'prodn:: coq'\n" file !linenum; fprintf new_rst "%s\n" line; | "tacn::" when args.check_tacs -> if not (StringSet.mem rhs tac_prods) then @@ -1675,8 +1703,8 @@ let process_rst g file args seen tac_prods cmd_prods = warn "%s line %d: Repeated command: '%s'\n" file !linenum rhs; seen := { !seen with cmds = (NTMap.add rhs (file, !linenum) !seen.cmds)}; fprintf new_rst "%s\n" line - | "insertgram" -> - process_insertgram line rhs + | "insertprodn" -> + process_insertprodn line rhs | _ -> fprintf new_rst "%s\n" line end else fprintf new_rst "%s\n" line; diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index ebaeb392a5..e12589bb89 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -64,7 +64,7 @@ lconstr: [ constr: [ | operconstr8 -| "@" global instance +| "@" global univ_instance ] operconstr200: [ @@ -90,7 +90,7 @@ operconstr90: [ operconstr10: [ | operconstr9 LIST1 appl_arg -| "@" global instance LIST0 operconstr9 +| "@" global univ_instance LIST0 operconstr9 | "@" pattern_identref LIST1 identref | operconstr9 ] @@ -123,16 +123,16 @@ operconstr0: [ ] record_declaration: [ -| record_fields_instance +| fields_def ] -record_fields_instance: [ -| record_field_instance ";" record_fields_instance -| record_field_instance +fields_def: [ +| field_def ";" fields_def +| field_def | ] -record_field_instance: [ +field_def: [ | global binders ":=" lconstr ] @@ -140,13 +140,15 @@ binder_constr: [ | "forall" open_binders "," operconstr200 | "fun" open_binders "=>" operconstr200 | "let" name binders let_type_cstr ":=" operconstr200 "in" operconstr200 -| "let" single_fix "in" operconstr200 +| "let" "fix" fix_decl "in" operconstr200 +| "let" "cofix" cofix_decl "in" operconstr200 | "let" [ "(" LIST0 name SEP "," ")" | "()" ] return_type ":=" operconstr200 "in" operconstr200 | "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 | "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 | "let" "'" pattern200 "in" pattern200 ":=" operconstr200 case_type "in" operconstr200 | "if" operconstr200 return_type "then" operconstr200 "else" operconstr200 -| fix_constr +| "fix" fix_decls +| "cofix" cofix_decls ] appl_arg: [ @@ -155,7 +157,7 @@ appl_arg: [ ] atomic_constr: [ -| global instance +| global univ_instance | sort | NUMERAL | string @@ -174,7 +176,7 @@ evar_instance: [ | ] -instance: [ +univ_instance: [ | "@{" LIST0 universe_level "}" | ] @@ -187,22 +189,22 @@ universe_level: [ | global ] -fix_constr: [ -| single_fix -| single_fix "with" LIST1 fix_decl SEP "with" "for" identref +fix_decls: [ +| fix_decl +| fix_decl "with" LIST1 fix_decl SEP "with" "for" identref ] -single_fix: [ -| fix_kw fix_decl +cofix_decls: [ +| cofix_decl +| cofix_decl "with" LIST1 cofix_decl SEP "with" "for" identref ] -fix_kw: [ -| "fix" -| "cofix" +fix_decl: [ +| identref binders_fixannot type_cstr ":=" operconstr200 ] -fix_decl: [ -| identref binders_fixannot let_type_cstr ":=" operconstr200 +cofix_decl: [ +| identref binders type_cstr ":=" operconstr200 ] match_constr: [ @@ -282,26 +284,14 @@ pattern0: [ | string ] -impl_ident_tail: [ -| "}" -| LIST1 name ":" lconstr "}" -| LIST1 name "}" -| ":" lconstr "}" -] - fixannot: [ | "{" "struct" identref "}" | "{" "wf" constr identref "}" | "{" "measure" constr OPT identref OPT constr "}" ] -impl_name_head: [ -| impl_ident_head -] - binders_fixannot: [ -| impl_name_head impl_ident_tail binders_fixannot -| fixannot +| ensure_fixannot fixannot | binder binders_fixannot | ] @@ -344,6 +334,11 @@ typeclass_constraint: [ | operconstr200 ] +type_cstr: [ +| ":" lconstr +| +] + let_type_cstr: [ | OPT [ ":" lconstr ] ] @@ -514,9 +509,6 @@ command: [ | "Add" "LoadPath" ne_string as_dirpath | "Add" "Rec" "LoadPath" ne_string as_dirpath | "Remove" "LoadPath" ne_string -| "AddPath" ne_string "as" as_dirpath -| "AddRecPath" ne_string "as" as_dirpath -| "DelPath" ne_string | "Type" lconstr | "Print" printable | "Print" smart_global OPT univ_name_list @@ -963,16 +955,11 @@ opt_coercion: [ ] rec_definition: [ -| ident_decl binders_fixannot rec_type_cstr OPT [ ":=" lconstr ] decl_notation +| ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notation ] corec_definition: [ -| ident_decl binders rec_type_cstr OPT [ ":=" lconstr ] decl_notation -] - -rec_type_cstr: [ -| ":" lconstr -| +| ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notation ] scheme: [ @@ -994,7 +981,6 @@ record_field: [ record_fields: [ | record_field ";" record_fields -| record_field ";" | record_field | ] @@ -1395,7 +1381,6 @@ syntax: [ only_parsing: [ | "(" "only" "parsing" ")" -| "(" "compat" STRING ")" | ] @@ -1413,7 +1398,6 @@ syntax_modifier: [ | "no" "associativity" | "only" "printing" | "only" "parsing" -| "compat" STRING | "format" STRING OPT STRING | IDENT; "," LIST1 IDENT SEP "," "at" level | IDENT; "at" level diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 545ccde03a..63e0ca129c 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -8,30 +8,15 @@ vernac_toplevel: [ | "Quit" "." | "BackTo" num "." | "Show" "Goal" num "at" num "." -| "Show" "Proof" "Diffs" removed_opt "." +| "Show" "Proof" "Diffs" OPT "removed" "." | vernac_control ] -removed_opt: [ -| "removed" -| empty -] - tactic_mode: [ -| toplevel_selector_opt query_command -| toplevel_selector_opt "{" -| toplevel_selector_opt ltac_info_opt ltac_expr ltac_use_default -| "par" ":" ltac_info_opt ltac_expr ltac_use_default -] - -toplevel_selector_opt: [ -| toplevel_selector -| empty -] - -ltac_info_opt: [ -| "Info" num -| empty +| OPT toplevel_selector query_command +| OPT toplevel_selector "{" +| OPT toplevel_selector OPT ( "Info" num ) ltac_expr ltac_use_default +| "par" ":" OPT ( "Info" num ) ltac_expr ltac_use_default ] ltac_use_default: [ @@ -44,15 +29,16 @@ vernac_control: [ | "Redirect" string vernac_control | "Timeout" num vernac_control | "Fail" vernac_control -| quoted_attributes_list_opt vernac +| LIST0 ( "#[" LIST0 attribute SEP "," "]" ) vernac ] term: [ | "forall" open_binders "," term | "fun" open_binders "=>" term | term_let -| "if" term as_return_type_opt "then" term "else" term +| "if" term OPT [ OPT [ "as" name ] "return" term100 ] "then" term "else" term | term_fix +| term_cofix | term100 ] @@ -62,43 +48,24 @@ term100: [ ] term10: [ -| term1 args -| "@" qualid universe_annot_opt term1_list_opt +| term1 LIST1 arg +| "@" qualid OPT univ_annot LIST0 term1 | term1 ] -args: [ -| args arg -| arg -] - arg: [ | "(" ident ":=" term ")" | term1 ] -term1_list_opt: [ -| term1_list_opt term1 -| empty -] - -empty: [ -| -] - term1: [ | term_projection | term0 "%" ident | term0 ] -args_opt: [ -| args -| empty -] - term0: [ -| qualid universe_annot_opt +| qualid OPT univ_annot | sort | numeral | string @@ -106,46 +73,25 @@ term0: [ | term_evar | term_match | "(" term ")" -| "{|" fields_def "|}" +| "{|" LIST0 field_def "|}" | "`{" term "}" | "`(" term ")" | "ltac" ":" "(" ltac_expr ")" ] -fields_def: [ -| field_def ";" fields_def -| field_def -| empty -] - field_def: [ -| qualid binders_opt ":=" term -] - -binders_opt: [ -| binders -| empty +| qualid LIST0 binder ":=" term ] term_projection: [ -| term0 ".(" qualid args_opt ")" -| term0 ".(" "@" qualid term1_list_opt ")" +| term0 ".(" qualid LIST0 arg ")" +| term0 ".(" "@" qualid LIST0 ( term1 ) ")" ] term_evar: [ | "?[" ident "]" | "?[" "?" ident "]" -| "?" ident evar_bindings_opt -] - -evar_bindings_opt: [ -| "@{" evar_bindings_semi "}" -| empty -] - -evar_bindings_semi: [ -| evar_bindings_semi ";" evar_binding -| evar_binding +| "?" ident OPT ( "@{" LIST1 evar_binding SEP ";" "}" ) ] evar_binding: [ @@ -153,42 +99,26 @@ evar_binding: [ ] dangling_pattern_extension_rule: [ -| "@" "?" ident ident_list -] - -ident_list: [ -| ident_list ident -| ident +| "@" "?" ident LIST1 ident ] record_fields: [ | record_field ";" record_fields -| record_field ";" | record_field -| empty +| ] record_field: [ -| quoted_attributes_list_opt record_binder num_opt2 decl_notation +| LIST0 ( "#[" LIST0 attribute SEP "," "]" ) record_binder OPT [ "|" num ] decl_notation ] decl_notation: [ -| "where" one_decl_notation_list -| empty -] - -one_decl_notation_list: [ -| one_decl_notation_list "and" one_decl_notation -| one_decl_notation +| "where" LIST1 one_decl_notation SEP "and" +| ] one_decl_notation: [ -| string ":=" term1_extended ident_opt3 -] - -ident_opt3: [ -| ":" ident -| empty +| string ":=" term1_extended OPT [ ":" ident ] ] record_binder: [ @@ -197,9 +127,9 @@ record_binder: [ ] record_binder_body: [ -| binders_opt of_type_with_opt_coercion term -| binders_opt of_type_with_opt_coercion term ":=" term -| binders_opt ":=" term +| LIST0 binder of_type_with_opt_coercion term +| LIST0 binder of_type_with_opt_coercion term ":=" term +| LIST0 binder ":=" term ] of_type_with_opt_coercion: [ @@ -208,43 +138,50 @@ of_type_with_opt_coercion: [ | ":" ] -num_opt2: [ -| "|" num -| empty +attribute: [ +| ident attribute_value ] -quoted_attributes_list_opt: [ -| quoted_attributes_list_opt "#[" attribute_list_comma_opt "]" -| empty +attribute_value: [ +| "=" string +| "(" LIST0 attribute SEP "," ")" +| ] -attribute_list_comma_opt: [ -| attribute_list_comma -| empty +qualid: [ +| ident LIST0 field_ident ] -attribute_list_comma: [ -| attribute_list_comma "," attribute -| attribute +field_ident: [ +| "." ident ] -attribute: [ -| ident attribute_value +numeral: [ +| LIST1 digit OPT ( "." LIST1 digit ) OPT [ [ "e" | "E" ] OPT [ "+" | "-" ] LIST1 digit ] ] -attribute_value: [ -| "=" string -| "(" attribute_list_comma_opt ")" -| empty +int: [ +| OPT "-" LIST1 digit ] -qualid: [ -| qualid field -| ident +num: [ +| LIST1 digit ] -field: [ -| "." ident +digit: [ +| "0" ".." "9" +] + +ident: [ +| first_letter LIST0 subsequent_letter +] + +first_letter: [ +| [ "a" ".." "z" | "A" ".." "Z" | "_" | unicode_letter ] +] + +subsequent_letter: [ +| [ first_letter | digit | "'" | unicode_id_part ] ] sort: [ @@ -257,17 +194,12 @@ sort: [ ] universe: [ -| "max" "(" universe_exprs_comma ")" -| universe_expr -] - -universe_exprs_comma: [ -| universe_exprs_comma "," universe_expr +| "max" "(" LIST1 universe_expr SEP "," ")" | universe_expr ] universe_expr: [ -| universe_name universe_increment_opt +| universe_name OPT ( "+" num ) ] universe_name: [ @@ -276,21 +208,6 @@ universe_name: [ | "Prop" ] -universe_increment_opt: [ -| "+" num -| empty -] - -universe_annot_opt: [ -| "@{" universe_levels_opt "}" -| empty -] - -universe_levels_opt: [ -| universe_levels_opt universe_level -| empty -] - universe_level: [ | "Set" | "Prop" @@ -299,83 +216,50 @@ universe_level: [ | qualid ] -term_fix: [ -| single_fix -| single_fix "with" fix_bodies "for" ident -] - -single_fix: [ -| "fix" fix_body -| "cofix" fix_body +univ_annot: [ +| "@{" LIST0 universe_level "}" ] -fix_bodies: [ -| fix_bodies "with" fix_body -| fix_body +term_fix: [ +| "let" "fix" fix_body "in" term +| "fix" fix_body OPT ( LIST1 ( "with" fix_body ) "for" ident ) ] fix_body: [ -| ident binders_opt fixannot_opt colon_term_opt ":=" term -] - -fixannot_opt: [ -| fixannot -| empty +| ident LIST0 binder OPT fixannot OPT ( ":" term ) ":=" term ] fixannot: [ | "{" "struct" ident "}" | "{" "wf" term1_extended ident "}" -| "{" "measure" term1_extended ident_opt term1_extended_opt "}" +| "{" "measure" term1_extended OPT ident OPT term1_extended "}" ] term1_extended: [ | term1 -| "@" qualid universe_annot_opt +| "@" qualid OPT univ_annot ] -ident_opt: [ -| ident -| empty +term_cofix: [ +| "let" "cofix" cofix_body "in" term +| "cofix" cofix_body OPT ( LIST1 ( "with" cofix_body ) "for" ident ) ] -term1_extended_opt: [ -| term1_extended -| empty +cofix_body: [ +| ident LIST0 binder OPT ( ":" term ) ":=" term ] term_let: [ -| "let" name colon_term_opt ":=" term "in" term -| "let" name binders colon_term_opt ":=" term "in" term -| "let" single_fix "in" term -| "let" names_tuple as_return_type_opt ":=" term "in" term -| "let" "'" pattern ":=" term return_type_opt "in" term -| "let" "'" pattern "in" pattern ":=" term return_type "in" term -] - -colon_term_opt: [ -| ":" term -| empty -] - -names_tuple: [ -| "(" names_comma ")" -| "()" -] - -names_comma: [ -| names_comma "," name -| name +| "let" name OPT ( ":" term ) ":=" term "in" term +| "let" name LIST1 binder OPT ( ":" term ) ":=" term "in" term +| "let" "(" LIST0 name SEP "," ")" OPT [ OPT [ "as" name ] "return" term100 ] ":=" term "in" term +| "let" "'" pattern ":=" term OPT ( "return" term100 ) "in" term +| "let" "'" pattern "in" pattern ":=" term "return" term100 "in" term ] open_binders: [ -| names ":" term -| binders -] - -names: [ -| names name -| name +| LIST1 name ":" term +| LIST1 binder ] name: [ @@ -383,37 +267,21 @@ name: [ | ident ] -binders: [ -| binders binder -| binder -] - binder: [ | name -| "(" names ":" term ")" -| "(" name colon_term_opt ":=" term ")" -| "{" name "}" -| "{" names colon_term_opt "}" -| "`(" typeclass_constraints_comma ")" -| "`{" typeclass_constraints_comma "}" +| "(" LIST1 name ":" term ")" +| "(" name OPT ( ":" term ) ":=" term ")" +| "{" LIST1 name OPT ( ":" term ) "}" +| "`(" LIST1 typeclass_constraint SEP "," ")" +| "`{" LIST1 typeclass_constraint SEP "," "}" | "'" pattern0 | "(" name ":" term "|" term ")" ] -typeclass_constraints_comma: [ -| typeclass_constraints_comma "," typeclass_constraint -| typeclass_constraint -] - typeclass_constraint: [ -| exclam_opt term -| "{" name "}" ":" exclam_opt term -| name ":" exclam_opt term -] - -exclam_opt: [ -| "!" -| empty +| OPT "!" term +| "{" name "}" ":" OPT "!" term +| name ":" OPT "!" term ] term_cast: [ @@ -424,69 +292,15 @@ term_cast: [ ] term_match: [ -| "match" case_items_comma return_type_opt "with" or_opt eqns_or_opt "end" -] - -case_items_comma: [ -| case_items_comma "," case_item -| case_item -] - -return_type_opt: [ -| return_type -| empty -] - -as_return_type_opt: [ -| as_name_opt return_type -| empty -] - -return_type: [ -| "return" term100 +| "match" LIST1 case_item SEP "," OPT ( "return" term100 ) "with" OPT "|" LIST0 eqn SEP "|" "end" ] case_item: [ -| term100 as_name_opt in_opt -] - -as_name_opt: [ -| "as" name -| empty -] - -in_opt: [ -| "in" pattern -| empty -] - -or_opt: [ -| "|" -| empty -] - -eqns_or_opt: [ -| eqns_or -| empty -] - -eqns_or: [ -| eqns_or "|" eqn -| eqn +| term100 OPT ( "as" name ) OPT [ "in" pattern ] ] eqn: [ -| patterns_comma_list_or "=>" term -] - -patterns_comma_list_or: [ -| patterns_comma_list_or "|" patterns_comma -| patterns_comma -] - -patterns_comma: [ -| patterns_comma "," pattern -| pattern +| LIST1 [ LIST1 pattern SEP "," ] SEP "|" "=>" term ] pattern: [ @@ -496,19 +310,8 @@ pattern: [ pattern10: [ | pattern1 "as" name -| pattern1_list -| "@" qualid pattern1_list_opt -| pattern1 -] - -pattern1_list: [ -| pattern1_list pattern1 -| pattern1 -] - -pattern1_list_opt: [ -| pattern1_list -| empty +| pattern1 LIST0 pattern1 +| "@" qualid LIST0 pattern1 ] pattern1: [ @@ -518,28 +321,13 @@ pattern1: [ pattern0: [ | qualid -| "{|" record_patterns_opt "|}" +| "{|" LIST0 ( qualid ":=" pattern ) "|}" | "_" -| "(" patterns_or ")" +| "(" LIST1 pattern SEP "|" ")" | numeral | string ] -patterns_or: [ -| patterns_or "|" pattern -| pattern -] - -record_patterns_opt: [ -| record_patterns_opt ";" record_pattern -| record_pattern -| empty -] - -record_pattern: [ -| qualid ":=" pattern -] - vernac: [ | "Local" vernac_poly | "Global" vernac_poly @@ -571,78 +359,28 @@ subprf: [ ] gallina: [ -| thm_token ident_decl binders_opt ":" term with_list_opt +| thm_token ident_decl LIST0 binder ":" term LIST0 [ "with" ident_decl LIST0 binder ":" term ] | assumption_token inline assum_list | assumptions_token inline assum_list | def_token ident_decl def_body | "Let" ident def_body -| cumulativity_token_opt private_token finite_token inductive_definition_list -| "Fixpoint" fix_definition_list -| "Let" "Fixpoint" fix_definition_list -| "CoFixpoint" cofix_definition_list -| "Let" "CoFixpoint" cofix_definition_list -| "Scheme" scheme_list -| "Combined" "Scheme" ident "from" ident_list_comma +| OPT cumulativity_token private_token finite_token LIST1 inductive_definition SEP "with" +| "Fixpoint" LIST1 fix_definition SEP "with" +| "Let" "Fixpoint" LIST1 fix_definition SEP "with" +| "CoFixpoint" LIST1 cofix_definition SEP "with" +| "Let" "CoFixpoint" LIST1 cofix_definition SEP "with" +| "Scheme" LIST1 scheme SEP "with" +| "Combined" "Scheme" ident "from" LIST1 ident SEP "," | "Register" qualid "as" qualid | "Register" "Inline" qualid -| "Primitive" ident term_opt ":=" register_token -| "Universe" ident_list -| "Universes" ident_list -| "Constraint" univ_constraint_list_comma -] - -term_opt: [ -| ":" term -| empty -] - -univ_constraint_list_comma: [ -| univ_constraint_list_comma "," univ_constraint -| univ_constraint -] - -with_list_opt: [ -| with_list_opt "with" ident_decl binders_opt ":" term -| empty -] - -cumulativity_token_opt: [ -| cumulativity_token -| empty -] - -inductive_definition_list: [ -| inductive_definition_list "with" inductive_definition -| inductive_definition -] - -fix_definition_list: [ -| fix_definition_list "with" fix_definition -| fix_definition +| "Primitive" ident OPT [ ":" term ] ":=" register_token +| "Universe" LIST1 ident +| "Universes" LIST1 ident +| "Constraint" LIST1 univ_constraint SEP "," ] fix_definition: [ -| ident_decl binders_opt fixannot_opt colon_term_opt term_opt2 decl_notation -] - -term_opt2: [ -| ":=" term -| empty -] - -cofix_definition_list: [ -| cofix_definition_list "with" cofix_definition -| cofix_definition -] - -scheme_list: [ -| scheme_list "with" scheme -| scheme -] - -ident_list_comma: [ -| ident_list_comma "," ident -| ident +| ident_decl LIST0 binder OPT fixannot OPT ( ":" term ) OPT [ ":=" term ] decl_notation ] register_token: [ @@ -731,21 +469,15 @@ assumptions_token: [ inline: [ | "Inline" "(" num ")" | "Inline" -| empty +| ] univ_constraint: [ -| universe_name lt_alt universe_name -] - -lt_alt: [ -| "<" -| "=" -| "<=" +| universe_name [ "<" | "=" | "<=" ] universe_name ] ident_decl: [ -| ident univ_decl_opt +| ident OPT ( "@{" LIST0 ident [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | "|}" ] ] ) ] finite_token: [ @@ -764,46 +496,41 @@ cumulativity_token: [ private_token: [ | "Private" -| empty +| ] def_body: [ -| binders_opt ":=" reduce term -| binders_opt ":" term ":=" reduce term -| binders_opt ":" term +| LIST0 binder ":=" reduce term +| LIST0 binder ":" term ":=" reduce term +| LIST0 binder ":" term ] reduce: [ | "Eval" red_expr "in" -| empty +| ] red_expr: [ | "red" | "hnf" -| "simpl" delta_flag ref_or_pattern_occ_opt +| "simpl" delta_flag OPT ref_or_pattern_occ | "cbv" strategy_flag | "cbn" strategy_flag | "lazy" strategy_flag | "compute" delta_flag -| "vm_compute" ref_or_pattern_occ_opt -| "native_compute" ref_or_pattern_occ_opt -| "unfold" unfold_occ_list_comma -| "fold" term1_extended_list -| "pattern" pattern_occ_list_comma +| "vm_compute" OPT ref_or_pattern_occ +| "native_compute" OPT ref_or_pattern_occ +| "unfold" LIST1 unfold_occ SEP "," +| "fold" LIST1 term1_extended +| "pattern" LIST1 pattern_occ SEP "," | ident ] strategy_flag: [ -| red_flags_list +| LIST1 red_flags | delta_flag ] -red_flags_list: [ -| red_flags_list red_flags -| red_flags -] - red_flags: [ | "beta" | "iota" @@ -815,14 +542,9 @@ red_flags: [ ] delta_flag: [ -| "-" "[" smart_global_list "]" -| "[" smart_global_list "]" -| empty -] - -ref_or_pattern_occ_opt: [ -| ref_or_pattern_occ -| empty +| "-" "[" LIST1 smart_global "]" +| "[" LIST1 smart_global "]" +| ] ref_or_pattern_occ: [ @@ -830,83 +552,48 @@ ref_or_pattern_occ: [ | term1_extended occs ] -unfold_occ_list_comma: [ -| unfold_occ_list_comma "," unfold_occ -| unfold_occ -] - unfold_occ: [ | smart_global occs ] -pattern_occ_list_comma: [ -| pattern_occ_list_comma "," pattern_occ -| pattern_occ -] - opt_constructors_or_fields: [ | ":=" constructor_list_or_record_decl -| empty +| ] inductive_definition: [ -| opt_coercion ident_decl binders_opt term_opt opt_constructors_or_fields decl_notation +| opt_coercion ident_decl LIST0 binder OPT [ ":" term ] opt_constructors_or_fields decl_notation ] opt_coercion: [ | ">" -| empty +| ] constructor_list_or_record_decl: [ -| "|" constructor_list_or -| ident constructor_type "|" constructor_list_or_opt +| "|" LIST1 constructor SEP "|" +| ident constructor_type "|" LIST0 constructor SEP "|" | ident constructor_type | ident "{" record_fields "}" | "{" record_fields "}" -| empty -] - -constructor_list_or: [ -| constructor_list_or "|" constructor -| constructor -] - -constructor_list_or_opt: [ -| constructor_list_or -| empty +| ] assum_list: [ -| assum_coe_list +| LIST1 assum_coe | simple_assum_coe ] -assum_coe_list: [ -| assum_coe_list assum_coe -| assum_coe -] - assum_coe: [ | "(" simple_assum_coe ")" ] simple_assum_coe: [ -| ident_decl_list of_type_with_opt_coercion term -] - -ident_decl_list: [ -| ident_decl_list ident_decl -| ident_decl +| LIST1 ident_decl of_type_with_opt_coercion term ] constructor_type: [ -| binders_opt of_type_with_opt_coercion_opt -] - -of_type_with_opt_coercion_opt: [ -| of_type_with_opt_coercion term -| empty +| LIST0 binder [ of_type_with_opt_coercion term | ] ] constructor: [ @@ -914,7 +601,7 @@ constructor: [ ] cofix_definition: [ -| ident_decl binders_opt colon_term_opt term_opt2 decl_notation +| ident_decl LIST0 binder OPT ( ":" term ) OPT [ ":=" term ] decl_notation ] scheme: [ @@ -943,67 +630,47 @@ smart_global: [ ] by_notation: [ -| string ident_opt2 -] - -ident_opt2: [ -| "%" ident -| empty +| string OPT [ "%" ident ] ] gallina_ext: [ -| "Module" export_token ident module_binder_list_opt of_module_type is_module_expr -| "Module" "Type" ident module_binder_list_opt module_type_inl_list_opt is_module_type -| "Declare" "Module" export_token ident module_binder_list_opt ":" module_type_inl +| "Module" export_token ident LIST0 ( "(" export_token LIST1 ident ":" module_type_inl ")" ) of_module_type is_module_expr +| "Module" "Type" ident LIST0 ( "(" export_token LIST1 ident ":" module_type_inl ")" ) LIST0 ( "<:" module_type_inl ) is_module_type +| "Declare" "Module" export_token ident LIST0 ( "(" export_token LIST1 ident ":" module_type_inl ")" ) ":" module_type_inl | "Section" ident | "Chapter" ident | "End" ident | "Collection" ident ":=" section_subset_expr -| "Require" export_token qualid_list -| "From" qualid "Require" export_token qualid_list -| "Import" qualid_list -| "Export" qualid_list -| "Include" module_type_inl module_expr_inl_list_opt -| "Include" "Type" module_type_inl module_type_inl_list_opt -| "Transparent" smart_global_list -| "Opaque" smart_global_list -| "Strategy" strategy_level_list -| "Canonical" Structure_opt qualid univ_decl_opt2 -| "Canonical" Structure_opt by_notation -| "Coercion" qualid univ_decl_opt def_body +| "Require" export_token LIST1 qualid +| "From" qualid "Require" export_token LIST1 qualid +| "Import" LIST1 qualid +| "Export" LIST1 qualid +| "Include" module_type_inl LIST0 ( "<+" module_expr_inl ) +| "Include" "Type" module_type_inl LIST0 ( "<+" module_type_inl ) +| "Transparent" LIST1 smart_global +| "Opaque" LIST1 smart_global +| "Strategy" LIST1 [ strategy_level "[" LIST1 smart_global "]" ] +| "Canonical" OPT "Structure" qualid OPT [ OPT ( "@{" LIST0 ident [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | "|}" ] ] ) def_body ] +| "Canonical" OPT "Structure" by_notation +| "Coercion" qualid OPT ( "@{" LIST0 ident [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | "|}" ] ] ) def_body | "Identity" "Coercion" ident ":" class_rawexpr ">->" class_rawexpr | "Coercion" qualid ":" class_rawexpr ">->" class_rawexpr | "Coercion" by_notation ":" class_rawexpr ">->" class_rawexpr -| "Context" binders -| "Instance" instance_name ":" term hint_info fields_def_opt +| "Context" LIST1 binder +| "Instance" instance_name ":" term hint_info [ ":=" "{" [ LIST1 field_def SEP ";" | ] "}" | ":=" term | ] | "Existing" "Instance" qualid hint_info -| "Existing" "Instances" qualid_list num_opt2 +| "Existing" "Instances" LIST1 qualid OPT [ "|" num ] | "Existing" "Class" qualid -| "Arguments" smart_global argument_spec_block_list_opt more_implicits_block_opt arguments_modifier_opt +| "Arguments" smart_global LIST0 argument_spec_block OPT [ "," LIST1 [ LIST0 more_implicits_block ] SEP "," ] OPT [ ":" LIST1 arguments_modifier SEP "," ] | "Implicit" "Type" reserv_list | "Implicit" "Types" reserv_list -| "Generalizable" All_alt -| "Export" "Set" ident_list option_setting -| "Export" "Unset" ident_list -] - -smart_global_list: [ -| smart_global_list smart_global -| smart_global -] - -num_opt: [ -| num -| empty -] - -qualid_list: [ -| qualid_list qualid -| qualid +| "Generalizable" [ "All" "Variables" | "No" "Variables" | [ "Variable" | "Variables" ] LIST1 ident ] +| "Export" "Set" LIST1 ident option_setting +| "Export" "Unset" LIST1 ident ] option_setting: [ -| empty +| | int | string ] @@ -1015,132 +682,35 @@ class_rawexpr: [ ] hint_info: [ -| "|" num_opt term1_extended_opt -| empty -] - -module_binder_list_opt: [ -| module_binder_list_opt "(" export_token ident_list ":" module_type_inl ")" -| empty -] - -module_type_inl_list_opt: [ -| module_type_inl_list_opt module_type_inl -| empty -] - -module_expr_inl_list_opt: [ -| module_expr_inl_list_opt module_expr_inl -| empty -] - -strategy_level_list: [ -| strategy_level_list strategy_level "[" smart_global_list "]" -| strategy_level "[" smart_global_list "]" -] - -fields_def_opt: [ -| ":=" "{" fields_def "}" -| ":=" term -| empty -] - -argument_spec_block_list_opt: [ -| argument_spec_block_list_opt argument_spec_block -| empty -] - -more_implicits_block_opt: [ -| "," more_implicits_block_list_comma -| empty -] - -more_implicits_block_list_comma: [ -| more_implicits_block_list_comma "," more_implicits_block_list_opt -| more_implicits_block_list_opt -] - -arguments_modifier_opt: [ -| ":" arguments_modifier_list_comma -| empty -] - -arguments_modifier_list_comma: [ -| arguments_modifier_list_comma "," arguments_modifier -| arguments_modifier -] - -All_alt: [ -| "All" "Variables" -| "No" "Variables" -| Variable_alt ident_list -] - -Variable_alt: [ -| "Variable" -| "Variables" -] - -more_implicits_block_list_opt: [ -| more_implicits_block_list_opt more_implicits_block -| empty -] - -univ_decl_opt2: [ -| univ_decl_opt def_body -| empty -] - -univ_decl_opt: [ -| "@{" ident_list_opt plus_opt univ_constraint_alt -| empty -] - -plus_opt: [ -| "+" -| empty -] - -univ_constraint_alt: [ -| "|" univ_constraint_list_comma_opt plus_opt "}" -| rbrace_alt -] - -univ_constraint_list_comma_opt: [ -| univ_constraint_list_comma -| empty -] - -rbrace_alt: [ -| "}" -| "|}" +| "|" OPT num OPT term1_extended +| ] export_token: [ | "Import" | "Export" -| empty +| ] of_module_type: [ | ":" module_type_inl -| module_type_inl_list_opt +| LIST0 ( "<:" module_type_inl ) ] is_module_type: [ -| ":=" module_type_inl module_type_inl_list_opt -| empty +| ":=" module_type_inl LIST0 ( "<+" module_type_inl ) +| ] is_module_expr: [ -| ":=" module_expr_inl module_expr_inl_list_opt -| empty +| ":=" module_expr_inl LIST0 ( "<+" module_expr_inl ) +| ] functor_app_annot: [ | "[" "inline" "at" "level" num "]" | "[" "no" "inline" "]" -| empty +| ] module_expr_inl: [ @@ -1171,33 +741,23 @@ module_type: [ ] with_declaration: [ -| "Definition" qualid univ_decl_opt ":=" term +| "Definition" qualid OPT ( "@{" LIST0 ident [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | "|}" ] ] ) ":=" term | "Module" qualid ":=" qualid ] argument_spec_block: [ -| exclam_opt name scope_delimiter_opt +| OPT "!" name OPT ( "%" ident ) | "/" | "&" -| "(" scope_delimiter_list ")" scope_delimiter_opt -| "[" scope_delimiter_list "]" scope_delimiter_opt -| "{" scope_delimiter_list "}" scope_delimiter_opt -] - -scope_delimiter_opt: [ -| "%" ident -| empty -] - -scope_delimiter_list: [ -| scope_delimiter_list scope_delimiter_opt -| scope_delimiter_opt +| "(" LIST1 ( OPT "!" name OPT ( "%" ident ) ) ")" OPT ( "%" ident ) +| "[" LIST1 ( OPT "!" name OPT ( "%" ident ) ) "]" OPT ( "%" ident ) +| "{" LIST1 ( OPT "!" name OPT ( "%" ident ) ) "}" OPT ( "%" ident ) ] more_implicits_block: [ | name -| "[" names "]" -| "{" names "}" +| "[" LIST1 name "]" +| "{" LIST1 name "}" ] strategy_level: [ @@ -1208,26 +768,21 @@ strategy_level: [ ] instance_name: [ -| ident_decl binders_opt -| empty +| ident_decl LIST0 binder +| ] reserv_list: [ -| reserv_tuple_list +| LIST1 reserv_tuple | simple_reserv ] -reserv_tuple_list: [ -| reserv_tuple_list reserv_tuple -| reserv_tuple -] - reserv_tuple: [ | "(" simple_reserv ")" ] simple_reserv: [ -| ident_list ":" term +| LIST1 ident ":" term ] arguments_modifier: [ @@ -1244,46 +799,36 @@ arguments_modifier: [ | "clear" "implicits" "and" "scopes" ] -Structure_opt: [ -| "Structure" -| empty -] - command: [ | "Goal" term -| "Comments" comment_list_opt -| "Declare" "Instance" ident_decl binders_opt ":" term hint_info | "Declare" "Scope" ident | "Pwd" | "Cd" | "Cd" string -| "Load" Verbose_opt string_alt -| "Declare" "ML" "Module" string_list +| "Load" [ "Verbose" | ] [ string | ident ] +| "Declare" "ML" "Module" LIST1 string | "Locate" locatable | "Add" "LoadPath" string as_dirpath | "Add" "Rec" "LoadPath" string as_dirpath | "Remove" "LoadPath" string -| "AddPath" string "as" as_dirpath -| "AddRecPath" string "as" as_dirpath -| "DelPath" string | "Type" term | "Print" printable -| "Print" smart_global univ_name_list_opt +| "Print" smart_global OPT ( "@{" LIST0 name "}" ) | "Print" "Module" "Type" qualid | "Print" "Module" qualid | "Print" "Namespace" dirpath | "Inspect" num | "Add" "ML" "Path" string | "Add" "Rec" "ML" "Path" string -| "Set" ident_list option_setting -| "Unset" ident_list -| "Print" "Table" ident_list -| "Add" ident ident option_ref_value_list -| "Add" ident option_ref_value_list -| "Test" ident_list "for" option_ref_value_list -| "Test" ident_list -| "Remove" ident ident option_ref_value_list -| "Remove" ident option_ref_value_list +| "Set" LIST1 ident option_setting +| "Unset" LIST1 ident +| "Print" "Table" LIST1 ident +| "Add" ident ident LIST1 option_ref_value +| "Add" ident LIST1 option_ref_value +| "Test" LIST1 ident "for" LIST1 option_ref_value +| "Test" LIST1 ident +| "Remove" ident ident LIST1 option_ref_value +| "Remove" ident LIST1 option_ref_value | "Write" "State" ident | "Write" "State" string | "Restore" "State" ident @@ -1328,9 +873,11 @@ command: [ | "Show" "Intros" | "Show" "Match" qualid | "Guarded" -| "Create" "HintDb" ident discriminated_opt -| "Remove" "Hints" qualid_list opt_hintbases +| "Create" "HintDb" ident [ "discriminated" | ] +| "Remove" "Hints" LIST1 qualid opt_hintbases | "Hint" hint opt_hintbases +| "Comments" LIST0 comment +| "Declare" "Instance" ident_decl LIST0 binder ":" term hint_info | "Obligation" int "of" ident ":" term withtac | "Obligation" int "of" ident withtac | "Obligation" int ":" term withtac @@ -1360,20 +907,20 @@ command: [ | "Add" "Relation" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident | "Add" "Relation" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident | "Add" "Relation" term1_extended term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "transitivity" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "transitivity" "proved" "by" term1_extended "as" ident | "Add" "Setoid" term1_extended term1_extended term1_extended "as" ident -| "Add" "Parametric" "Setoid" binders_opt ":" term1_extended term1_extended term1_extended "as" ident +| "Add" "Parametric" "Setoid" LIST0 binder ":" term1_extended term1_extended term1_extended "as" ident | "Add" "Morphism" term1_extended ":" ident | "Declare" "Morphism" term1_extended ":" ident | "Add" "Morphism" term1_extended "with" "signature" term "as" ident -| "Add" "Parametric" "Morphism" binders_opt ":" term1_extended "with" "signature" term "as" ident +| "Add" "Parametric" "Morphism" LIST0 binder ":" term1_extended "with" "signature" term "as" ident | "Grab" "Existential" "Variables" | "Unshelve" | "Declare" "Equivalent" "Keys" term1_extended term1_extended @@ -1401,49 +948,49 @@ command: [ | "Show" "Zify" "CstOp" (* micromega plugin *) | "Show" "Zify" "BinRel" (* micromega plugin *) | "Show" "Zify" "Spec" (* micromega plugin *) -| "Add" "Ring" ident ":" term1_extended ring_mods_opt (* setoid_ring plugin *) +| "Add" "Ring" ident ":" term1_extended OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* setoid_ring plugin *) | "Hint" "Cut" "[" hints_path "]" opthints -| "Typeclasses" "Transparent" qualid_list_opt -| "Typeclasses" "Opaque" qualid_list_opt -| "Typeclasses" "eauto" ":=" debug eauto_search_strategy int_opt +| "Typeclasses" "Transparent" LIST0 qualid +| "Typeclasses" "Opaque" LIST0 qualid +| "Typeclasses" "eauto" ":=" debug eauto_search_strategy OPT int +| "Proof" "with" ltac_expr OPT [ "using" section_subset_expr ] +| "Proof" "using" section_subset_expr OPT [ "with" ltac_expr ] +| "Tactic" "Notation" OPT ( "(" "at" "level" num ")" ) LIST1 ltac_production_item ":=" ltac_expr | "Print" "Rewrite" "HintDb" ident -| "Proof" "with" ltac_expr using_opt -| "Proof" "using" section_subset_expr with_opt -| "Tactic" "Notation" ltac_tactic_level_opt ltac_production_item_list ":=" ltac_expr | "Print" "Ltac" qualid | "Locate" "Ltac" qualid -| "Ltac" tacdef_body_list +| "Ltac" LIST1 tacdef_body SEP "with" | "Print" "Ltac" "Signatures" | "Set" "Firstorder" "Solver" ltac_expr | "Print" "Firstorder" "Solver" +| "Function" LIST1 fix_definition SEP "with" (* funind plugin *) +| "Functional" "Scheme" LIST1 fun_scheme_arg SEP "with" (* funind plugin *) | "Extraction" qualid (* extraction plugin *) -| "Recursive" "Extraction" qualid_list (* extraction plugin *) -| "Extraction" string qualid_list (* extraction plugin *) -| "Extraction" "TestCompile" qualid_list (* extraction plugin *) -| "Separate" "Extraction" qualid_list (* extraction plugin *) +| "Recursive" "Extraction" LIST1 qualid (* extraction plugin *) +| "Extraction" string LIST1 qualid (* extraction plugin *) +| "Extraction" "TestCompile" LIST1 qualid (* extraction plugin *) +| "Separate" "Extraction" LIST1 qualid (* extraction plugin *) | "Extraction" "Library" ident (* extraction plugin *) | "Recursive" "Extraction" "Library" ident (* extraction plugin *) | "Extraction" "Language" language (* extraction plugin *) -| "Extraction" "Inline" qualid_list (* extraction plugin *) -| "Extraction" "NoInline" qualid_list (* extraction plugin *) +| "Extraction" "Inline" LIST1 qualid (* extraction plugin *) +| "Extraction" "NoInline" LIST1 qualid (* extraction plugin *) | "Print" "Extraction" "Inline" (* extraction plugin *) | "Reset" "Extraction" "Inline" (* extraction plugin *) -| "Extraction" "Implicit" qualid "[" int_or_id_list_opt "]" (* extraction plugin *) -| "Extraction" "Blacklist" ident_list (* extraction plugin *) +| "Extraction" "Implicit" qualid "[" LIST0 int_or_id "]" (* extraction plugin *) +| "Extraction" "Blacklist" LIST1 ident (* extraction plugin *) | "Print" "Extraction" "Blacklist" (* extraction plugin *) | "Reset" "Extraction" "Blacklist" (* extraction plugin *) -| "Extract" "Constant" qualid string_list_opt "=>" mlname (* extraction plugin *) +| "Extract" "Constant" qualid LIST0 string "=>" mlname (* extraction plugin *) | "Extract" "Inlined" "Constant" qualid "=>" mlname (* extraction plugin *) -| "Extract" "Inductive" qualid "=>" mlname "[" mlname_list_opt "]" string_opt (* extraction plugin *) +| "Extract" "Inductive" qualid "=>" mlname "[" LIST0 mlname "]" OPT string (* extraction plugin *) | "Show" "Extraction" (* extraction plugin *) -| "Function" fix_definition_list (* funind plugin *) -| "Functional" "Scheme" fun_scheme_arg_list (* funind plugin *) | "Functional" "Case" fun_scheme_arg (* funind plugin *) | "Generate" "graph" "for" qualid (* funind plugin *) -| "Hint" "Rewrite" orient term1_extended_list ":" ident_list_opt -| "Hint" "Rewrite" orient term1_extended_list "using" ltac_expr ":" ident_list_opt -| "Hint" "Rewrite" orient term1_extended_list -| "Hint" "Rewrite" orient term1_extended_list "using" ltac_expr +| "Hint" "Rewrite" orient LIST1 term1_extended ":" LIST0 ident +| "Hint" "Rewrite" orient LIST1 term1_extended "using" ltac_expr ":" LIST0 ident +| "Hint" "Rewrite" orient LIST1 term1_extended +| "Hint" "Rewrite" orient LIST1 term1_extended "using" ltac_expr | "Derive" "Inversion_clear" ident "with" term1_extended "Sort" sort_family | "Derive" "Inversion_clear" ident "with" term1_extended | "Derive" "Inversion" ident "with" term1_extended "Sort" sort_family @@ -1453,7 +1000,7 @@ command: [ | "Declare" "Left" "Step" term1_extended | "Declare" "Right" "Step" term1_extended | "Print" "Rings" (* setoid_ring plugin *) -| "Add" "Field" ident ":" term1_extended field_mods_opt (* setoid_ring plugin *) +| "Add" "Field" ident ":" term1_extended OPT ( "(" LIST1 field_mod SEP "," ")" ) (* setoid_ring plugin *) | "Print" "Fields" (* setoid_ring plugin *) | "Numeral" "Notation" qualid qualid qualid ":" ident numnotoption | "String" "Notation" qualid qualid qualid ":" ident @@ -1462,31 +1009,11 @@ command: [ orient: [ | "->" | "<-" -| empty -] - -string_opt: [ -| string -| empty -] - -qualid_list_opt: [ -| qualid_list_opt qualid -| empty -] - -univ_name_list_opt: [ -| "@{" name_list_opt "}" -| empty -] - -name_list_opt: [ -| name_list_opt name -| empty +| ] section_subset_expr: [ -| starredidentref_list_opt +| LIST0 starredidentref | ssexpr ] @@ -1503,17 +1030,12 @@ ssexpr50: [ ssexpr0: [ | starredidentref -| "(" starredidentref_list_opt ")" -| "(" starredidentref_list_opt ")" "*" +| "(" LIST0 starredidentref ")" +| "(" LIST0 starredidentref ")" "*" | "(" ssexpr ")" | "(" ssexpr ")" "*" ] -starredidentref_list_opt: [ -| starredidentref_list_opt starredidentref -| empty -] - starredidentref: [ | ident | ident "*" @@ -1521,43 +1043,13 @@ starredidentref: [ | "Type" "*" ] -int_opt: [ -| int -| empty -] - -using_opt: [ -| "using" section_subset_expr -| empty -] - -with_opt: [ -| "with" ltac_expr -| empty -] - -ltac_tactic_level_opt: [ -| "(" "at" "level" num ")" -| empty -] - -ltac_production_item_list: [ -| ltac_production_item_list ltac_production_item -| ltac_production_item -] - -tacdef_body_list: [ -| tacdef_body_list "with" tacdef_body -| tacdef_body -] - printable: [ -| "Term" smart_global univ_name_list_opt +| "Term" smart_global OPT ( "@{" LIST0 name "}" ) | "All" | "Section" qualid | "Grammar" ident | "Custom" "Grammar" ident -| "LoadPath" dirpath_opt +| "LoadPath" OPT dirpath | "Modules" | "Libraries" | "ML" "Path" @@ -1579,9 +1071,9 @@ printable: [ | "HintDb" ident | "Scopes" | "Scope" ident -| "Visibility" ident_opt +| "Visibility" OPT ident | "Implicit" smart_global -| Sorted_opt "Universes" printunivs_subgraph_opt string_opt +| [ "Sorted" | ] "Universes" OPT ( "Subgraph" "(" LIST0 qualid ")" ) OPT string | "Assumptions" smart_global | "Opaque" "Dependencies" smart_global | "Transparent" "Dependencies" smart_global @@ -1591,84 +1083,9 @@ printable: [ | "Registered" ] -dirpath_opt: [ -| dirpath -| empty -] - dirpath: [ | ident -| dirpath field -] - -Sorted_opt: [ -| "Sorted" -| empty -] - -printunivs_subgraph_opt: [ -| "Subgraph" "(" qualid_list_opt ")" -| empty -] - -comment_list_opt: [ -| comment_list_opt comment -| empty -] - -Verbose_opt: [ -| "Verbose" -| empty -] - -string_alt: [ -| string -| ident -] - -string_list: [ -| string_list string -| string -] - -option_ref_value_list: [ -| option_ref_value_list option_ref_value -| option_ref_value -] - -discriminated_opt: [ -| "discriminated" -| empty -] - -string_list_opt: [ -| string_list_opt string -| empty -] - -mlname_list_opt: [ -| mlname_list_opt mlname -| empty -] - -fun_scheme_arg_list: [ -| fun_scheme_arg_list "with" fun_scheme_arg -| fun_scheme_arg -] - -term1_extended_list: [ -| term1_extended_list term1_extended -| term1_extended -] - -ring_mods_opt: [ -| "(" ring_mod_list_comma ")" (* setoid_ring plugin *) -| empty -] - -field_mods_opt: [ -| "(" field_mod_list_comma ")" (* setoid_ring plugin *) -| empty +| dirpath field_ident ] locatable: [ @@ -1685,8 +1102,7 @@ option_ref_value: [ ] as_dirpath: [ -| "as" dirpath -| empty +| OPT [ "as" dirpath ] ] comment: [ @@ -1701,25 +1117,20 @@ reference_or_constr: [ ] hint: [ -| "Resolve" reference_or_constr_list hint_info -| "Resolve" "->" qualid_list num_opt -| "Resolve" "<-" qualid_list num_opt -| "Immediate" reference_or_constr_list +| "Resolve" LIST1 reference_or_constr hint_info +| "Resolve" "->" LIST1 qualid OPT num +| "Resolve" "<-" LIST1 qualid OPT num +| "Immediate" LIST1 reference_or_constr | "Variables" "Transparent" | "Variables" "Opaque" | "Constants" "Transparent" | "Constants" "Opaque" -| "Transparent" qualid_list -| "Opaque" qualid_list -| "Mode" qualid plus_list -| "Unfold" qualid_list -| "Constructors" qualid_list -| "Extern" num term1_extended_opt "=>" ltac_expr -] - -reference_or_constr_list: [ -| reference_or_constr_list reference_or_constr -| reference_or_constr +| "Transparent" LIST1 qualid +| "Opaque" LIST1 qualid +| "Mode" qualid LIST1 [ "+" | "!" | "-" ] +| "Unfold" LIST1 qualid +| "Constructors" LIST1 qualid +| "Extern" num OPT term1_extended "=>" ltac_expr ] constr_body: [ @@ -1727,20 +1138,9 @@ constr_body: [ | ":" term ":=" term ] -plus_list: [ -| plus_list plus_alt -| plus_alt -] - -plus_alt: [ -| "+" -| "!" -| "-" -] - withtac: [ | "with" ltac_expr -| empty +| ] ltac_def_kind: [ @@ -1749,23 +1149,18 @@ ltac_def_kind: [ ] tacdef_body: [ -| qualid fun_var_list ltac_def_kind ltac_expr +| qualid LIST1 fun_var ltac_def_kind ltac_expr | qualid ltac_def_kind ltac_expr ] ltac_production_item: [ | string -| ident "(" ident ltac_production_sep_opt ")" +| ident "(" ident OPT ( "," string ) ")" | ident ] -ltac_production_sep_opt: [ -| "," string -| empty -] - numnotoption: [ -| empty +| | "(" "warning" "after" num ")" | "(" "abstract" "after" num ")" ] @@ -1797,44 +1192,34 @@ ring_mod: [ | "abstract" (* setoid_ring plugin *) | "morphism" term1_extended (* setoid_ring plugin *) | "constants" "[" ltac_expr "]" (* setoid_ring plugin *) -| "closed" "[" qualid_list "]" (* setoid_ring plugin *) +| "closed" "[" LIST1 qualid "]" (* setoid_ring plugin *) | "preprocess" "[" ltac_expr "]" (* setoid_ring plugin *) | "postprocess" "[" ltac_expr "]" (* setoid_ring plugin *) | "setoid" term1_extended term1_extended (* setoid_ring plugin *) | "sign" term1_extended (* setoid_ring plugin *) -| "power" term1_extended "[" qualid_list "]" (* setoid_ring plugin *) +| "power" term1_extended "[" LIST1 qualid "]" (* setoid_ring plugin *) | "power_tac" term1_extended "[" ltac_expr "]" (* setoid_ring plugin *) | "div" term1_extended (* setoid_ring plugin *) ] -ring_mod_list_comma: [ -| ring_mod_list_comma "," ring_mod -| ring_mod -] - field_mod: [ | ring_mod (* setoid_ring plugin *) | "completeness" term1_extended (* setoid_ring plugin *) ] -field_mod_list_comma: [ -| field_mod_list_comma "," field_mod -| field_mod -] - debug: [ | "debug" -| empty +| ] eauto_search_strategy: [ | "(bfs)" | "(dfs)" -| empty +| ] hints_path_atom: [ -| qualid_list +| LIST1 qualid | "_" ] @@ -1849,62 +1234,52 @@ hints_path: [ ] opthints: [ -| ":" ident_list -| empty +| ":" LIST1 ident +| ] opt_hintbases: [ -| empty -| ":" ident_list -] - -int_or_id_list_opt: [ -| int_or_id_list_opt int_or_id -| empty +| +| ":" LIST1 ident ] query_command: [ | "Eval" red_expr "in" term "." | "Compute" term "." | "Check" term "." -| "About" smart_global univ_name_list_opt "." +| "About" smart_global OPT ( "@{" LIST0 name "}" ) "." | "SearchHead" term1_extended in_or_out_modules "." | "SearchPattern" term1_extended in_or_out_modules "." | "SearchRewrite" term1_extended in_or_out_modules "." | "Search" searchabout_query searchabout_queries "." | "SearchAbout" searchabout_query searchabout_queries "." -| "SearchAbout" "[" searchabout_query_list "]" in_or_out_modules "." +| "SearchAbout" "[" LIST1 searchabout_query "]" in_or_out_modules "." ] ne_in_or_out_modules: [ -| "inside" qualid_list -| "outside" qualid_list +| "inside" LIST1 qualid +| "outside" LIST1 qualid ] in_or_out_modules: [ | ne_in_or_out_modules -| empty +| ] positive_search_mark: [ | "-" -| empty +| ] searchabout_query: [ -| positive_search_mark string scope_delimiter_opt +| positive_search_mark string OPT ( "%" ident ) | positive_search_mark term1_extended ] searchabout_queries: [ | ne_in_or_out_modules | searchabout_query searchabout_queries -| empty -] - -searchabout_query_list: [ -| searchabout_query_list searchabout_query -| searchabout_query +| ] syntax: [ @@ -1912,34 +1287,18 @@ syntax: [ | "Close" "Scope" ident | "Delimit" "Scope" ident "with" ident | "Undelimit" "Scope" ident -| "Bind" "Scope" ident "with" class_rawexpr_list -| "Infix" string ":=" term1_extended syntax_modifier_opt ident_opt3 -| "Notation" ident ident_list_opt ":=" term1_extended only_parsing -| "Notation" string ":=" term1_extended syntax_modifier_opt ident_opt3 +| "Bind" "Scope" ident "with" LIST1 class_rawexpr +| "Infix" string ":=" term1_extended [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" ident ] +| "Notation" ident LIST0 ident ":=" term1_extended only_parsing +| "Notation" string ":=" term1_extended [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" ident ] | "Format" "Notation" string string string -| "Reserved" "Infix" string syntax_modifier_opt -| "Reserved" "Notation" string syntax_modifier_opt -] - -class_rawexpr_list: [ -| class_rawexpr_list class_rawexpr -| class_rawexpr -] - -syntax_modifier_opt: [ -| "(" syntax_modifier_list_comma ")" -| empty -] - -syntax_modifier_list_comma: [ -| syntax_modifier_list_comma "," syntax_modifier -| syntax_modifier +| "Reserved" "Infix" string [ "(" LIST1 syntax_modifier SEP "," ")" | ] +| "Reserved" "Notation" string [ "(" LIST1 syntax_modifier SEP "," ")" | ] ] only_parsing: [ | "(" "only" "parsing" ")" -| "(" "compat" string ")" -| empty +| ] level: [ @@ -1956,9 +1315,8 @@ syntax_modifier: [ | "no" "associativity" | "only" "printing" | "only" "parsing" -| "compat" string -| "format" string string_opt -| ident "," ident_list_comma "at" level +| "format" string OPT string +| ident "," LIST1 ident SEP "," "at" level | ident "at" level | ident "at" level constr_as_binder_kind | ident constr_as_binder_kind @@ -1971,23 +1329,13 @@ syntax_extension_type: [ | "bigint" | "binder" | "constr" -| "constr" level_opt constr_as_binder_kind_opt +| "constr" OPT ( "at" level ) OPT constr_as_binder_kind | "pattern" | "pattern" "at" "level" num | "strict" "pattern" | "strict" "pattern" "at" "level" num | "closed" "binder" -| "custom" ident level_opt constr_as_binder_kind_opt -] - -level_opt: [ -| level -| empty -] - -constr_as_binder_kind_opt: [ -| constr_as_binder_kind -| empty +| "custom" ident OPT ( "at" level ) OPT constr_as_binder_kind ] constr_as_binder_kind: [ @@ -2032,9 +1380,9 @@ simple_tactic: [ | "split" "with" bindings | "esplit" "with" bindings | "exists" -| "exists" bindings_list_comma +| "exists" LIST1 bindings SEP "," | "eexists" -| "eexists" bindings_list_comma +| "eexists" LIST1 bindings SEP "," | "intros" "until" quantified_hypothesis | "intro" | "intro" ident @@ -2050,17 +1398,17 @@ simple_tactic: [ | "move" ident "at" "bottom" | "move" ident "after" ident | "move" ident "before" ident -| "rename" rename_list_comma -| "revert" ident_list +| "rename" LIST1 rename SEP "," +| "revert" LIST1 ident | "simple" "induction" quantified_hypothesis | "simple" "destruct" quantified_hypothesis | "double" "induction" quantified_hypothesis quantified_hypothesis | "admit" | "fix" ident num | "cofix" ident -| "clear" ident_list_opt -| "clear" "-" ident_list -| "clearbody" ident_list +| "clear" LIST0 ident +| "clear" "-" LIST1 ident +| "clearbody" LIST1 ident | "generalize" "dependent" term1_extended | "replace" term1_extended "with" term1_extended clause_dft_concl by_arg_tac | "replace" "->" term1_extended clause_dft_concl @@ -2078,10 +1426,10 @@ simple_tactic: [ | "injection" destruction_arg | "einjection" | "einjection" destruction_arg -| "injection" "as" simple_intropattern_list_opt -| "injection" destruction_arg "as" simple_intropattern_list_opt -| "einjection" "as" simple_intropattern_list_opt -| "einjection" destruction_arg "as" simple_intropattern_list_opt +| "injection" "as" LIST0 simple_intropattern +| "injection" destruction_arg "as" LIST0 simple_intropattern +| "einjection" "as" LIST0 simple_intropattern +| "einjection" destruction_arg "as" LIST0 simple_intropattern | "simple" "injection" | "simple" "injection" destruction_arg | "dependent" "rewrite" orient term1_extended @@ -2091,11 +1439,11 @@ simple_tactic: [ | "decompose" "sum" term1_extended | "decompose" "record" term1_extended | "absurd" term1_extended -| "contradiction" constr_with_bindings_opt -| "autorewrite" "with" ident_list clause_dft_concl -| "autorewrite" "with" ident_list clause_dft_concl "using" ltac_expr -| "autorewrite" "*" "with" ident_list clause_dft_concl -| "autorewrite" "*" "with" ident_list clause_dft_concl "using" ltac_expr +| "contradiction" OPT constr_with_bindings +| "autorewrite" "with" LIST1 ident clause_dft_concl +| "autorewrite" "with" LIST1 ident clause_dft_concl "using" ltac_expr +| "autorewrite" "*" "with" LIST1 ident clause_dft_concl +| "autorewrite" "*" "with" LIST1 ident clause_dft_concl "using" ltac_expr | "rewrite" "*" orient term1_extended "in" ident "at" occurrences by_arg_tac | "rewrite" "*" orient term1_extended "at" occurrences "in" ident by_arg_tac | "rewrite" "*" orient term1_extended "in" ident by_arg_tac @@ -2106,7 +1454,7 @@ simple_tactic: [ | "notypeclasses" "refine" term1_extended | "simple" "notypeclasses" "refine" term1_extended | "solve_constraints" -| "subst" ident_list +| "subst" LIST1 ident | "subst" | "simple" "subst" | "evar" "(" ident ":" term ")" @@ -2150,7 +1498,7 @@ simple_tactic: [ | "swap" int_or_var int_or_var | "revgoals" | "guard" int_or_var comparison int_or_var -| "decompose" "[" term1_extended_list "]" term1_extended +| "decompose" "[" LIST1 term1_extended "]" term1_extended | "optimize_heap" | "start" "ltac" "profiling" | "stop" "ltac" "profiling" @@ -2158,32 +1506,32 @@ simple_tactic: [ | "show" "ltac" "profile" | "show" "ltac" "profile" "cutoff" int | "show" "ltac" "profile" string -| "restart_timer" string_opt -| "finish_timing" string_opt -| "finish_timing" "(" string ")" string_opt +| "restart_timer" OPT string +| "finish_timing" OPT string +| "finish_timing" "(" string ")" OPT string | "eassumption" | "eexact" term1_extended | "trivial" auto_using hintbases | "info_trivial" auto_using hintbases | "debug" "trivial" auto_using hintbases -| "auto" int_or_var_opt auto_using hintbases -| "info_auto" int_or_var_opt auto_using hintbases -| "debug" "auto" int_or_var_opt auto_using hintbases -| "prolog" "[" term1_extended_list_opt "]" int_or_var -| "eauto" int_or_var_opt int_or_var_opt auto_using hintbases -| "new" "auto" int_or_var_opt auto_using hintbases -| "debug" "eauto" int_or_var_opt int_or_var_opt auto_using hintbases -| "info_eauto" int_or_var_opt int_or_var_opt auto_using hintbases -| "dfs" "eauto" int_or_var_opt auto_using hintbases +| "auto" OPT int_or_var auto_using hintbases +| "info_auto" OPT int_or_var auto_using hintbases +| "debug" "auto" OPT int_or_var auto_using hintbases +| "prolog" "[" LIST0 term1_extended "]" int_or_var +| "eauto" OPT int_or_var OPT int_or_var auto_using hintbases +| "new" "auto" OPT int_or_var auto_using hintbases +| "debug" "eauto" OPT int_or_var OPT int_or_var auto_using hintbases +| "info_eauto" OPT int_or_var OPT int_or_var auto_using hintbases +| "dfs" "eauto" OPT int_or_var auto_using hintbases | "autounfold" hintbases clause_dft_concl | "autounfold_one" hintbases "in" ident | "autounfold_one" hintbases | "unify" term1_extended term1_extended | "unify" term1_extended term1_extended "with" ident | "convert_concl_no_check" term1_extended -| "typeclasses" "eauto" "bfs" int_or_var_opt "with" ident_list -| "typeclasses" "eauto" int_or_var_opt "with" ident_list -| "typeclasses" "eauto" int_or_var_opt +| "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 ident +| "typeclasses" "eauto" OPT int_or_var "with" LIST1 ident +| "typeclasses" "eauto" OPT int_or_var | "head_of_constr" ident term1_extended | "not_evar" term1_extended | "is_ground" term1_extended @@ -2209,16 +1557,16 @@ simple_tactic: [ | "rewrite_strat" rewstrategy "in" ident | "intros" intropattern_list_opt | "eintros" intropattern_list_opt -| "apply" constr_with_bindings_arg_list_comma in_hyp_as -| "eapply" constr_with_bindings_arg_list_comma in_hyp_as -| "simple" "apply" constr_with_bindings_arg_list_comma in_hyp_as -| "simple" "eapply" constr_with_bindings_arg_list_comma in_hyp_as -| "elim" constr_with_bindings_arg eliminator_opt -| "eelim" constr_with_bindings_arg eliminator_opt +| "apply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as +| "eapply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as +| "simple" "apply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as +| "simple" "eapply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as +| "elim" constr_with_bindings_arg OPT ( "using" constr_with_bindings ) +| "eelim" constr_with_bindings_arg OPT ( "using" constr_with_bindings ) | "case" induction_clause_list | "ecase" induction_clause_list -| "fix" ident num "with" fixdecl_list -| "cofix" ident "with" cofixdecl_list +| "fix" ident num "with" LIST1 fixdecl +| "cofix" ident "with" LIST1 cofixdecl | "pose" bindings_with_parameters | "pose" term1_extended as_name | "epose" bindings_with_parameters @@ -2242,47 +1590,47 @@ simple_tactic: [ | "enough" term1_extended as_ipat by_tactic | "eenough" term1_extended as_ipat by_tactic | "generalize" term1_extended -| "generalize" term1_extended term1_extended_list -| "generalize" term1_extended occs as_name pattern_occ_list_opt +| "generalize" term1_extended LIST1 term1_extended +| "generalize" term1_extended occs as_name LIST0 [ "," pattern_occ as_name ] | "induction" induction_clause_list | "einduction" induction_clause_list | "destruct" induction_clause_list | "edestruct" induction_clause_list -| "rewrite" oriented_rewriter_list_comma clause_dft_concl by_tactic -| "erewrite" oriented_rewriter_list_comma clause_dft_concl by_tactic -| "dependent" simple_alt quantified_hypothesis as_or_and_ipat with_opt2 +| "rewrite" LIST1 oriented_rewriter SEP "," clause_dft_concl by_tactic +| "erewrite" LIST1 oriented_rewriter SEP "," clause_dft_concl by_tactic +| "dependent" [ "simple" "inversion" | "inversion" | "inversion_clear" ] quantified_hypothesis as_or_and_ipat OPT [ "with" term1_extended ] | "simple" "inversion" quantified_hypothesis as_or_and_ipat in_hyp_list | "inversion" quantified_hypothesis as_or_and_ipat in_hyp_list | "inversion_clear" quantified_hypothesis as_or_and_ipat in_hyp_list | "inversion" quantified_hypothesis "using" term1_extended in_hyp_list | "red" clause_dft_concl | "hnf" clause_dft_concl -| "simpl" delta_flag ref_or_pattern_occ_opt clause_dft_concl +| "simpl" delta_flag OPT ref_or_pattern_occ clause_dft_concl | "cbv" strategy_flag clause_dft_concl | "cbn" strategy_flag clause_dft_concl | "lazy" strategy_flag clause_dft_concl | "compute" delta_flag clause_dft_concl -| "vm_compute" ref_or_pattern_occ_opt clause_dft_concl -| "native_compute" ref_or_pattern_occ_opt clause_dft_concl -| "unfold" unfold_occ_list_comma clause_dft_concl -| "fold" term1_extended_list clause_dft_concl -| "pattern" pattern_occ_list_comma clause_dft_concl +| "vm_compute" OPT ref_or_pattern_occ clause_dft_concl +| "native_compute" OPT ref_or_pattern_occ clause_dft_concl +| "unfold" LIST1 unfold_occ SEP "," clause_dft_concl +| "fold" LIST1 term1_extended clause_dft_concl +| "pattern" LIST1 pattern_occ SEP "," clause_dft_concl | "change" conversion clause_dft_concl | "change_no_check" conversion clause_dft_concl | "btauto" | "rtauto" | "congruence" | "congruence" int -| "congruence" "with" term1_extended_list -| "congruence" int "with" term1_extended_list +| "congruence" "with" LIST1 term1_extended +| "congruence" int "with" LIST1 term1_extended | "f_equal" -| "firstorder" ltac_expr_opt firstorder_using -| "firstorder" ltac_expr_opt "with" ident_list -| "firstorder" ltac_expr_opt firstorder_using "with" ident_list -| "gintuition" ltac_expr_opt -| "functional" "inversion" quantified_hypothesis qualid_opt (* funind plugin *) -| "functional" "induction" term1_extended_list fun_ind_using with_names (* funind plugin *) -| "soft" "functional" "induction" term1_extended_list fun_ind_using with_names (* funind plugin *) +| "firstorder" OPT ltac_expr firstorder_using +| "firstorder" OPT ltac_expr "with" LIST1 ident +| "firstorder" OPT ltac_expr firstorder_using "with" LIST1 ident +| "gintuition" OPT ltac_expr +| "functional" "inversion" quantified_hypothesis OPT qualid (* funind plugin *) +| "functional" "induction" LIST1 term1_extended fun_ind_using with_names (* funind plugin *) +| "soft" "functional" "induction" LIST1 term1_extended fun_ind_using with_names (* funind plugin *) | "myred" (* micromega plugin *) | "psatz_Z" int_or_var ltac_expr (* micromega plugin *) | "psatz_Z" ltac_expr (* micromega plugin *) @@ -2304,12 +1652,12 @@ simple_tactic: [ | "saturate" (* micromega plugin *) | "nsatz_compute" term1_extended (* nsatz plugin *) | "omega" (* omega plugin *) -| "omega" "with" ident_list (* omega plugin *) +| "omega" "with" LIST1 ident (* omega plugin *) | "omega" "with" "*" (* omega plugin *) | "protect_fv" string "in" ident (* setoid_ring plugin *) | "protect_fv" string (* setoid_ring plugin *) -| "ring_lookup" ltac_expr0 "[" term1_extended_list_opt "]" term1_extended_list (* setoid_ring plugin *) -| "field_lookup" ltac_expr "[" term1_extended_list_opt "]" term1_extended_list (* setoid_ring plugin *) +| "ring_lookup" ltac_expr0 "[" LIST0 term1_extended "]" LIST1 term1_extended (* setoid_ring plugin *) +| "field_lookup" ltac_expr "[" LIST0 term1_extended "]" LIST1 term1_extended (* setoid_ring plugin *) ] int_or_var: [ @@ -2317,13 +1665,8 @@ int_or_var: [ | ident ] -constr_with_bindings_opt: [ -| constr_with_bindings -| empty -] - hloc: [ -| empty +| | "in" "|-" "*" | "in" ident | "in" "(" "Type" "of" ident ")" @@ -2338,30 +1681,25 @@ rename: [ by_arg_tac: [ | "by" ltac_expr3 -| empty +| ] in_clause: [ | in_clause | "*" occs | "*" "|-" concl_occ -| hypident_occ_list_comma_opt "|-" concl_occ -| hypident_occ_list_comma_opt +| LIST0 hypident_occ SEP "," "|-" concl_occ +| LIST0 hypident_occ SEP "," ] occs: [ | "at" occs_nums -| empty -] - -hypident_occ_list_comma_opt: [ -| hypident_occ_list_comma -| empty +| ] as_ipat: [ | "as" simple_intropattern -| empty +| ] or_and_intropattern_loc: [ @@ -2371,40 +1709,35 @@ or_and_intropattern_loc: [ as_or_and_ipat: [ | "as" or_and_intropattern_loc -| empty +| ] eqn_ipat: [ | "eqn" ":" naming_intropattern | "_eqn" ":" naming_intropattern | "_eqn" -| empty +| ] as_name: [ | "as" ident -| empty +| ] by_tactic: [ | "by" ltac_expr3 -| empty +| ] rewriter: [ | "!" constr_with_bindings_arg -| qmark_alt constr_with_bindings_arg +| [ "?" | "?" ] constr_with_bindings_arg | num "!" constr_with_bindings_arg -| num qmark_alt constr_with_bindings_arg +| num [ "?" | "?" ] constr_with_bindings_arg | num constr_with_bindings_arg | constr_with_bindings_arg ] -qmark_alt: [ -| "?" -| "?" -] - oriented_rewriter: [ | orient rewriter ] @@ -2414,53 +1747,22 @@ induction_clause: [ ] induction_clause_list: [ -| induction_clause_list_comma eliminator_opt opt_clause -] - -induction_clause_list_comma: [ -| induction_clause_list_comma "," induction_clause -| induction_clause -] - -eliminator_opt: [ -| "using" constr_with_bindings -| empty +| LIST1 induction_clause SEP "," OPT ( "using" constr_with_bindings ) opt_clause ] auto_using: [ -| "using" term1_extended_list_comma -| empty -] - -term1_extended_list_comma: [ -| term1_extended_list_comma "," term1_extended -| term1_extended +| "using" LIST1 term1_extended SEP "," +| ] intropattern_list_opt: [ -| intropattern_list_opt intropattern -| empty +| LIST0 intropattern ] or_and_intropattern: [ | "[" intropattern_or_list_or "]" -| "(" simple_intropattern_list_comma_opt ")" -| "(" simple_intropattern "&" simple_intropattern_list_ ")" -] - -simple_intropattern_list_comma_opt: [ -| simple_intropattern_list_comma -| empty -] - -simple_intropattern_list_comma: [ -| simple_intropattern_list_comma "," simple_intropattern -| simple_intropattern -] - -simple_intropattern_list_: [ -| simple_intropattern_list_ "&" simple_intropattern -| simple_intropattern +| "(" LIST0 simple_intropattern SEP "," ")" +| "(" simple_intropattern "&" LIST1 simple_intropattern SEP "&" ")" ] intropattern_or_list_or: [ @@ -2468,11 +1770,6 @@ intropattern_or_list_or: [ | intropattern_list_opt ] -simple_intropattern_list_opt: [ -| simple_intropattern_list_opt simple_intropattern -| empty -] - equality_intropattern: [ | "->" | "<-" @@ -2492,12 +1789,7 @@ intropattern: [ ] simple_intropattern: [ -| simple_intropattern_closed term0_list_opt -] - -term0_list_opt: [ -| term0_list_opt "%" term0 -| empty +| simple_intropattern_closed LIST0 [ "%" term0 ] ] simple_intropattern_closed: [ @@ -2513,65 +1805,14 @@ simple_binding: [ ] bindings: [ -| simple_binding_list -| term1_extended_list -] - -simple_binding_list: [ -| simple_binding_list simple_binding -| simple_binding -] - -constr_with_bindings_arg_list_comma: [ -| constr_with_bindings_arg_list_comma "," constr_with_bindings_arg -| constr_with_bindings_arg -] - -fixdecl_list: [ -| fixdecl_list fixdecl -| fixdecl -] - -cofixdecl_list: [ -| cofixdecl_list cofixdecl -| cofixdecl -] - -pattern_occ_list_opt: [ -| pattern_occ_list_opt "," pattern_occ as_name -| empty +| LIST1 simple_binding +| LIST1 term1_extended ] pattern_occ: [ | term1_extended occs ] -oriented_rewriter_list_comma: [ -| oriented_rewriter_list_comma "," oriented_rewriter -| oriented_rewriter -] - -simple_alt: [ -| "simple" "inversion" -| "inversion" -| "inversion_clear" -] - -with_opt2: [ -| "with" term1_extended -| empty -] - -bindings_list_comma: [ -| bindings_list_comma "," bindings -| bindings -] - -rename_list_comma: [ -| rename_list_comma "," rename -| rename -] - comparison: [ | "=" | "<" @@ -2582,22 +1823,12 @@ comparison: [ hintbases: [ | "with" "*" -| "with" ident_list -| empty -] - -qualid_opt: [ -| qualid -| empty +| "with" LIST1 ident +| ] bindings_with_parameters: [ -| "(" ident simple_binder_list_opt ":=" term ")" -] - -simple_binder_list_opt: [ -| simple_binder_list_opt simple_binder -| empty +| "(" ident LIST0 simple_binder ":=" term ")" ] hypident: [ @@ -2613,23 +1844,23 @@ hypident_occ: [ clause_dft_concl: [ | "in" in_clause | occs -| empty +| ] clause_dft_all: [ | "in" in_clause -| empty +| ] opt_clause: [ | "in" in_clause | "at" occs_nums -| empty +| ] occs_nums: [ -| num_or_var_list -| "-" num_or_var int_or_var_list_opt +| LIST1 num_or_var +| "-" num_or_var LIST0 int_or_var ] num_or_var: [ @@ -2637,47 +1868,37 @@ num_or_var: [ | ident ] -int_or_var_list_opt: [ -| int_or_var_list_opt int_or_var -| empty -] - -num_or_var_list: [ -| num_or_var_list num_or_var -| num_or_var -] - concl_occ: [ | "*" occs -| empty +| ] in_hyp_list: [ -| "in" ident_list -| empty +| "in" LIST1 ident +| ] in_hyp_as: [ | "in" ident as_ipat -| empty +| ] simple_binder: [ | name -| "(" names ":" term ")" +| "(" LIST1 name ":" term ")" ] fixdecl: [ -| "(" ident simple_binder_list_opt struct_annot ":" term ")" +| "(" ident LIST0 simple_binder struct_annot ":" term ")" ] struct_annot: [ | "{" "struct" name "}" -| empty +| ] cofixdecl: [ -| "(" ident simple_binder_list_opt ":" term ")" +| "(" ident LIST0 simple_binder ":" term ")" ] constr_with_bindings: [ @@ -2686,7 +1907,7 @@ constr_with_bindings: [ with_bindings: [ | "with" bindings -| empty +| ] destruction_arg: [ @@ -2713,36 +1934,26 @@ conversion: [ firstorder_using: [ | "using" qualid -| "using" qualid "," qualid_list_comma -| "using" qualid qualid qualid_list_opt -| empty -] - -qualid_list_comma: [ -| qualid_list_comma "," qualid -| qualid +| "using" qualid "," LIST1 qualid SEP "," +| "using" qualid qualid LIST0 qualid +| ] fun_ind_using: [ | "using" constr_with_bindings (* funind plugin *) -| empty (* funind plugin *) +| (* funind plugin *) ] with_names: [ | "as" simple_intropattern (* funind plugin *) -| empty (* funind plugin *) +| (* funind plugin *) ] occurrences: [ -| int_list +| LIST1 int | ident ] -int_list: [ -| int_list int -| int -] - rewstrategy: [ | term1_extended | "<-" term1_extended @@ -2764,51 +1975,31 @@ rewstrategy: [ | "choice" rewstrategy rewstrategy | "old_hints" ident | "hints" ident -| "terms" term1_extended_list_opt +| "terms" LIST0 term1_extended | "eval" red_expr | "fold" term1_extended ] -hypident_occ_list_comma: [ -| hypident_occ_list_comma "," hypident_occ -| hypident_occ -] - ltac_expr: [ | binder_tactic | ltac_expr4 ] binder_tactic: [ -| "fun" fun_var_list "=>" ltac_expr -| "let" rec_opt let_clause_list "in" ltac_expr +| "fun" LIST1 fun_var "=>" ltac_expr +| "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" ltac_expr | "info" ltac_expr ] -fun_var_list: [ -| fun_var_list fun_var -| fun_var -] - fun_var: [ | ident | "_" ] -rec_opt: [ -| "rec" -| empty -] - -let_clause_list: [ -| let_clause_list "with" let_clause -| let_clause -] - let_clause: [ | ident ":=" ltac_expr | "_" ":=" ltac_expr -| ident fun_var_list ":=" ltac_expr +| ident LIST1 fun_var ":=" ltac_expr ] ltac_expr4: [ @@ -2820,27 +2011,28 @@ ltac_expr4: [ ] multi_goal_tactics: [ -| ltac_expr_opt "|" multi_goal_tactics -| ltac_expr_opt ".." or_opt ltac_expr_opt_list_or +| OPT ltac_expr "|" multi_goal_tactics +| ltac_expr_opt ".." OPT "|" ltac_expr_opt_list_or | ltac_expr -| empty +| ] ltac_expr_opt: [ -| ltac_expr -| empty +| OPT ltac_expr ] ltac_expr_opt_list_or: [ | ltac_expr_opt_list_or "|" ltac_expr_opt | ltac_expr_opt +| ltac_expr_opt_list_or "|" OPT ltac_expr +| OPT ltac_expr ] ltac_expr3: [ | "try" ltac_expr3 | "do" int_or_var ltac_expr3 | "timeout" int_or_var ltac_expr3 -| "time" string_opt ltac_expr3 +| "time" OPT string ltac_expr3 | "repeat" ltac_expr3 | "progress" ltac_expr3 | "once" ltac_expr3 @@ -2863,48 +2055,23 @@ ltac_expr2: [ ltac_expr1: [ | ltac_match_term +| "first" "[" LIST0 ltac_expr SEP "|" "]" +| "solve" "[" LIST0 ltac_expr SEP "|" "]" +| "idtac" LIST0 message_token +| failkw [ int_or_var | ] LIST0 message_token | ltac_match_goal -| "first" "[" ltac_expr_list_or_opt "]" -| "solve" "[" ltac_expr_list_or_opt "]" -| "idtac" message_token_list_opt -| failkw int_or_var_opt message_token_list_opt | simple_tactic | tactic_arg -| qualid tactic_arg_compat_list_opt +| qualid LIST0 tactic_arg_compat | ltac_expr0 ] -ltac_expr_list_or_opt: [ -| ltac_expr_list_or -| empty -] - -ltac_expr_list_or: [ -| ltac_expr_list_or "|" ltac_expr -| ltac_expr -] - -message_token_list_opt: [ -| message_token_list_opt message_token -| empty -] - message_token: [ | ident | string | int ] -int_or_var_opt: [ -| int_or_var -| empty -] - -term1_extended_list_opt: [ -| term1_extended_list_opt term1_extended -| empty -] - failkw: [ | "fail" | "gfail" @@ -2914,26 +2081,16 @@ tactic_arg: [ | "eval" red_expr "in" term | "context" ident "[" term "]" | "type" "of" term -| "fresh" fresh_id_list_opt +| "fresh" LIST0 fresh_id | "type_term" term1_extended | "numgoals" ] -fresh_id_list_opt: [ -| fresh_id_list_opt fresh_id -| empty -] - fresh_id: [ | string | qualid ] -tactic_arg_compat_list_opt: [ -| tactic_arg_compat_list_opt tactic_arg_compat -| empty -] - tactic_arg_compat: [ | tactic_arg | term @@ -2963,22 +2120,17 @@ only_selector: [ ] selector: [ -| range_selector_list_comma +| LIST1 range_selector SEP "," | "[" ident "]" ] -range_selector_list_comma: [ -| range_selector_list_comma "," range_selector -| range_selector -] - range_selector: [ | num "-" num | num ] ltac_match_term: [ -| match_key ltac_expr "with" or_opt match_rule_list_or "end" +| match_key ltac_expr "with" OPT "|" LIST1 match_rule SEP "|" "end" ] match_key: [ @@ -2987,67 +2139,27 @@ match_key: [ | "lazymatch" ] -match_rule_list_or: [ -| match_rule_list_or "|" match_rule -| match_rule -] - match_rule: [ -| match_pattern_alt "=>" ltac_expr -] - -match_pattern_alt: [ -| match_pattern -| "_" +| [ match_pattern | "_" ] "=>" ltac_expr ] match_pattern: [ -| "context" ident_opt "[" term "]" +| "context" OPT ident "[" term "]" | term ] ltac_match_goal: [ -| match_key reverse_opt "goal" "with" or_opt match_context_rule_list_or "end" -] - -reverse_opt: [ -| "reverse" -| empty -] - -match_context_rule_list_or: [ -| match_context_rule_list_or "|" match_context_rule -| match_context_rule +| match_key OPT "reverse" "goal" "with" OPT "|" LIST1 match_context_rule SEP "|" "end" ] match_context_rule: [ -| match_hyp_list_comma_opt "|-" match_pattern "=>" ltac_expr -| "[" match_hyp_list_comma_opt "|-" match_pattern "]" "=>" ltac_expr +| LIST0 match_hyp SEP "," "|-" match_pattern "=>" ltac_expr +| "[" LIST0 match_hyp SEP "," "|-" match_pattern "]" "=>" ltac_expr | "_" "=>" ltac_expr ] -match_hyp_list_comma_opt: [ -| match_hyp_list_comma -| empty -] - -match_hyp_list_comma: [ -| match_hyp_list_comma "," match_hyp -| match_hyp -] - match_hyp: [ | name ":" match_pattern -| name ":=" match_pattern_opt match_pattern -] - -match_pattern_opt: [ -| "[" match_pattern "]" ":" -| empty -] - -ident_list_opt: [ -| ident_list_opt ident -| empty +| name ":=" OPT ( "[" match_pattern "]" ":" ) match_pattern ] diff --git a/doc/tools/docgram/productionlist.edit_mlg b/doc/tools/docgram/productionlist.edit_mlg index 42d94e76bb..8170b71e7a 100644 --- a/doc/tools/docgram/productionlist.edit_mlg +++ b/doc/tools/docgram/productionlist.edit_mlg @@ -13,32 +13,6 @@ DOC_GRAMMAR -EXPAND: [ | ] - -RENAME: [ -| name_alt names_tuple -| binder_list binders -| binder_list_opt binders_opt -| typeclass_constraint_list_comma typeclass_constraints_comma -| universe_expr_list_comma universe_exprs_comma -| universe_level_list_opt universe_levels_opt -| name_list names -| name_list_comma names_comma -| case_item_list_comma case_items_comma -| eqn_list_or_opt eqns_or_opt -| eqn_list_or eqns_or -| pattern_list_or patterns_or -| fix_body_list fix_bodies -| arg_list args -| arg_list_opt args_opt -| evar_binding_list_semi evar_bindings_semi -] - -binders_opt: [ -| REPLACE binders_opt binder -| WITH binders -] - (* this is here because they're inside _opt generated by EXPAND *) SPLICE: [ | ltac_info diff --git a/dune-project b/dune-project index 1249c4af9f..fa05f5fb41 100644 --- a/dune-project +++ b/dune-project @@ -2,6 +2,9 @@ (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/evd.ml b/engine/evd.ml index 94868d9bdd..8e7d942c37 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -200,13 +200,14 @@ let evar_filtered_hyps evi = match Filter.repr (evar_filter evi) with in make_hyps filter (evar_context evi) -let evar_env evi = Global.env_of_context evi.evar_hyps +let evar_env env evi = + Environ.reset_with_named_context evi.evar_hyps env -let evar_filtered_env evi = match Filter.repr (evar_filter evi) with -| None -> evar_env evi +let evar_filtered_env env evi = match Filter.repr (evar_filter evi) with +| None -> evar_env env evi | Some filter -> let rec make_env filter ctxt = match filter, ctxt with - | [], [] -> reset_context (Global.env ()) + | [], [] -> reset_context env | false :: filter, _ :: ctxt -> make_env filter ctxt | true :: filter, decl :: ctxt -> let env = make_env filter ctxt in diff --git a/engine/evd.mli b/engine/evd.mli index 7876e9a48f..8843adc853 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -125,8 +125,8 @@ val evar_filtered_hyps : evar_info -> named_context_val val evar_body : evar_info -> evar_body val evar_candidates : evar_info -> constr list option val evar_filter : evar_info -> Filter.t -val evar_env : evar_info -> env -val evar_filtered_env : evar_info -> env +val evar_env : env -> evar_info -> env +val evar_filtered_env : env -> evar_info -> env val map_evar_body : (econstr -> econstr) -> evar_body -> evar_body val map_evar_info : (econstr -> econstr) -> evar_info -> evar_info diff --git a/engine/proofview.ml b/engine/proofview.ml index ed44372045..16be96454e 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 @@ -1036,9 +1039,9 @@ let (>>=) = tclBIND (** {6 Goal-dependent tactics} *) -let goal_env evars gl = +let goal_env env evars gl = let evi = Evd.find evars gl in - Evd.evar_filtered_env evi + Evd.evar_filtered_env env evi let goal_nf_evar sigma gl = let evi = Evd.find sigma gl in @@ -1253,9 +1256,10 @@ module V82 = struct let of_tactic t gls = try + let env = Global.env () in let init = { shelf = []; solution = gls.Evd.sigma ; comb = [with_empty_state gls.Evd.it] } in let name, poly = Names.Id.of_string "legacy_pe", false in - let (_,final,_,_) = apply ~name ~poly (goal_env gls.Evd.sigma gls.Evd.it) t init in + let (_,final,_,_) = apply ~name ~poly (goal_env env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = CList.map drop_state final.comb } with Logic_monad.TacticFailure e as src -> let (_, info) = CErrors.push src in 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 = diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 28f4f5aed6..cc0c1e4602 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -678,7 +678,7 @@ 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 - (match Classops.hide_coercion r with + (match Coercionops.hide_coercion r with | Some n when (n - pars) < nargs && (inctx || (n - pars)+1 < nargs) -> (* We skip the coercion *) let l = List.skipn (n - pars) args in diff --git a/interp/notation.ml b/interp/notation.ml index efb826a76e..93969f3718 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1430,7 +1430,7 @@ let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false (**********************************************************************) (* Mapping classes to scopes *) -open Classops +open Coercionops type scope_class = cl_typ @@ -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.mli b/interp/notation.mli index 864e500d56..ea5125f7ec 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -271,7 +271,7 @@ val compute_type_scope : Evd.evar_map -> EConstr.types -> scope_name option (** Get the current scope bound to Sortclass, if it exists *) val current_type_scope_name : unit -> scope_name option -val scope_class_of_class : Classops.cl_typ -> scope_class +val scope_class_of_class : Coercionops.cl_typ -> scope_class (** Building notation key *) 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/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 c91cb39fe2..b19472dc99 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 *******************************) (************************************************************************) @@ -255,16 +197,14 @@ let unbounded_from_below u cstrs = is u_k and is contributing. *) 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) && - not (Univ.LSet.mem l ctor_levels) then - Some l - else None + Univ.LSet.mem l (Univ.ContextSet.levels uctx) && + unbounded_from_below l (Univ.ContextSet.constraints uctx) && + not (Univ.LSet.mem l ctor_levels) in let univs = Univ.Universe.levels concl in let univs = if template_check then - Univ.LSet.filter (fun l -> Option.has_some (check_level l) || Univ.Level.is_prop l) univs + Univ.LSet.filter (fun l -> check_level l || Univ.Level.is_prop l) univs else univs (* Doesn't check the universes can be generalized *) in let fold acc = function @@ -351,8 +291,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 @@ -389,11 +335,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 @@ -408,4 +351,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/indtypes.ml b/kernel/indtypes.ml index 750ac86908..0d900c2ec9 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -379,17 +379,25 @@ let check_positivity ~chkpos kn names env_ar_par paramsctxt finite inds = (************************************************************************) (* Build the inductive packet *) -let repair_arity indices = function - | RegularArity ar -> ar.mind_user_arity - | TemplateArity ar -> mkArity (indices,Sorts.sort_of_univ ar.template_level) +let fold_arity f acc params arity indices = match arity with + | RegularArity ar -> f acc ar.mind_user_arity + | TemplateArity _ -> + let fold_ctx acc ctx = + List.fold_left (fun acc d -> + Context.Rel.Declaration.fold_constr (fun c acc -> f acc c) d acc) + acc + ctx + in + fold_ctx (fold_ctx acc params) indices -let fold_inductive_blocks f = +let fold_inductive_blocks f acc params inds = Array.fold_left (fun acc ((arity,lc),(indices,_),_) -> - f (Array.fold_left f acc lc) (repair_arity indices arity)) + fold_arity f (Array.fold_left f acc lc) params arity indices) + acc inds -let used_section_variables env inds = +let used_section_variables env params inds = let fold l c = Id.Set.union (Environ.global_vars_set env c) l in - let ids = fold_inductive_blocks fold Id.Set.empty inds in + let ids = fold_inductive_blocks fold Id.Set.empty params inds in keep_hyps env ids let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) @@ -461,7 +469,7 @@ let compute_projections (kn, i as ind) mib = let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) - let hyps = used_section_variables env inds in + let hyps = used_section_variables env paramsctxt inds in let nparamargs = Context.Rel.nhyps paramsctxt in (* Check one inductive *) let build_one_packet (id,cnames) ((arity,lc),(indices,splayed_lc),kelim) recarg = @@ -479,18 +487,17 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in - let transf num = - let arity = List.length (dest_subterms recarg).(num) in - if Int.equal arity 0 then - let p = (!nconst, 0) in - incr nconst; p - else - let p = (!nblock + 1, arity) in - incr nblock; p - (* les tag des constructeur constant commence a 0, - les tag des constructeur non constant a 1 (0 => accumulator) *) + let transf arity = + if Int.equal arity 0 then + let p = (!nconst, 0) in + incr nconst; p + else + let p = (!nblock + 1, arity) in + incr nblock; p + (* les tag des constructeur constant commence a 0, + les tag des constructeur non constant a 1 (0 => accumulator) *) in - let rtbl = Array.init (List.length cnames) transf in + let rtbl = Array.map transf consnrealargs in (* Build the inductive packet *) { mind_typename = id; mind_arity = arity; 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 759feda9ab..ee101400d6 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -331,13 +331,13 @@ 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 = 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 } @@ -346,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 @@ -547,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 @@ -998,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 = push_context_set false 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 @@ -1015,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 0b7ca26e09..92bbd264fa 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -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/uint63_31.ml b/kernel/uint63_31.ml index e38389ca13..445166f6af 100644 --- a/kernel/uint63_31.ml +++ b/kernel/uint63_31.ml @@ -15,8 +15,8 @@ let _ = assert (Sys.word_size = 32) let uint_size = 63 -let maxuint63 = Int64.of_string "0x7FFFFFFFFFFFFFFF" -let maxuint31 = Int64.of_string "0x7FFFFFFF" +let maxuint63 = 0x7FFF_FFFF_FFFF_FFFFL +let maxuint31 = 0x7FFF_FFFFL let zero = Int64.zero let one = Int64.one @@ -118,27 +118,30 @@ let div21 xh xl y = let div21 xh xl y = if Int64.compare y xh <= 0 then zero, zero else div21 xh xl y - (* exact multiplication *) +(* exact multiplication *) let mulc x y = - let lx = ref (Int64.logand x maxuint31) in - let ly = ref (Int64.logand y maxuint31) in + let lx = Int64.logand x maxuint31 in + let ly = Int64.logand y maxuint31 in let hx = Int64.shift_right x 31 in let hy = Int64.shift_right y 31 in - let hr = ref (Int64.mul hx hy) in - let lr = ref (Int64.logor (Int64.mul !lx !ly) (Int64.shift_left !hr 62)) in - hr := (Int64.shift_right_logical !hr 1); - lx := Int64.mul !lx hy; - ly := Int64.mul hx !ly; - hr := Int64.logor !hr (Int64.add (Int64.shift_right !lx 32) (Int64.shift_right !ly 32)); - lr := Int64.add !lr (Int64.shift_left !lx 31); - hr := Int64.add !hr (Int64.shift_right_logical !lr 63); - lr := Int64.add (Int64.shift_left !ly 31) (mask63 !lr); - hr := Int64.add !hr (Int64.shift_right_logical !lr 63); - if Int64.logand !lr Int64.min_int <> 0L - then Int64.(sub !hr one, mask63 !lr) - else (!hr, !lr) - -let equal x y = mask63 x = mask63 y + (* compute the median products *) + let s = Int64.add (Int64.mul lx hy) (Int64.mul hx ly) in + (* s fits on 64 bits, split it into a 33-bit high part and a 31-bit low part *) + let lr = Int64.shift_left (Int64.logand s maxuint31) 31 in + let hr = Int64.shift_right_logical s 31 in + (* add the outer products *) + let lr = Int64.add (Int64.mul lx ly) lr in + let hr = Int64.add (Int64.mul hx hy) hr in + (* hr fits on 64 bits, since the final result fits on 126 bits *) + (* now x * y = hr * 2^62 + lr and lr < 2^63 *) + let lr = Int64.add lr (Int64.shift_left (Int64.logand hr 1L) 62) in + let hr = Int64.shift_right_logical hr 1 in + (* now x * y = hr * 2^63 + lr, but lr might be too large *) + if Int64.logand lr Int64.min_int <> 0L + then Int64.add hr 1L, mask63 lr + else hr, lr + +let equal (x : t) y = x = y let compare x y = Int64.compare x y 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 6c47d6c6ae..9cce9b92ad 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -243,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 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/parsing/pcoq.ml b/parsing/pcoq.ml index 734dd8ee8a..26afdcb9d5 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -533,6 +533,7 @@ let extend_entry_command (type a) (type b) (tag : (a, b) entry_command) (g : a) try EntryDataMap.find tag !camlp5_entries with Not_found -> EntryData.Ex String.Map.empty in + let () = assert (not @@ String.Map.mem name old) in let entries = String.Map.add name e old in camlp5_entries := EntryDataMap.add tag (EntryData.Ex entries) !camlp5_entries in diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 2f26226f4e..4e7482d4af 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -18,11 +18,11 @@ open Tacticals.New let update_flags ()= let open TransparentState in - let f accu coe = match coe.Classops.coe_value with + let f accu coe = match coe.Coercionops.coe_value with | Names.GlobRef.ConstRef kn -> { accu with tr_cst = Names.Cpred.remove kn accu.tr_cst } | _ -> accu in - let flags = List.fold_left f TransparentState.full (Classops.coercions ()) in + let flags = List.fold_left f TransparentState.full (Coercionops.coercions ()) in red_flags:= CClosure.RedFlags.red_add_transparent CClosure.betaiotazeta diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index c87eb7c3c9..3ea4974a87 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -26,9 +26,9 @@ module NamedDecl = Context.Named.Declaration (* The instantiate tactic *) -let instantiate_evar evk (ist,rawc) sigma = +let instantiate_evar evk (ist,rawc) env sigma = let evi = Evd.find sigma evk in - let filtered = Evd.evar_filtered_env evi in + let filtered = Evd.evar_filtered_env env evi in let constrvars = Tacinterp.extract_ltac_constr_values ist filtered in let lvar = { ltac_constrs = constrvars; @@ -36,7 +36,7 @@ let instantiate_evar evk (ist,rawc) sigma = ltac_idents = Names.Id.Map.empty; ltac_genargs = ist.Geninterp.lfun; } in - let sigma' = w_refine (evk,evi) (lvar ,rawc) sigma in + let sigma' = w_refine (evk,evi) (lvar ,rawc) env sigma in tclEVARS sigma' let evar_list sigma c = @@ -48,6 +48,7 @@ let evar_list sigma c = let instantiate_tac n c ido = Proofview.V82.tactic begin fun gl -> + let env = Global.env () in let sigma = gl.sigma in let evl = match ido with @@ -69,16 +70,17 @@ let instantiate_tac n c ido = user_err Pp.(str "Not enough uninstantiated existential variables."); if n <= 0 then user_err Pp.(str "Incorrect existential variable index."); let evk,_ = List.nth evl (n-1) in - instantiate_evar evk c sigma gl + instantiate_evar evk c env sigma gl end let instantiate_tac_by_name id c = Proofview.V82.tactic begin fun gl -> + let env = Global.env () in let sigma = gl.sigma in let evk = try Evd.evar_key id sigma with Not_found -> user_err Pp.(str "Unknown existential variable.") in - instantiate_evar evk c sigma gl + instantiate_evar evk c env sigma gl end let let_evar name typ = diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 0e8c225a8f..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 -> diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index ca5c8b30c2..98d14f3d33 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -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 = 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/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/omega/g_omega.mlg b/plugins/omega/g_omega.mlg index 84964a7bd2..7c653b223e 100644 --- a/plugins/omega/g_omega.mlg +++ b/plugins/omega/g_omega.mlg @@ -21,40 +21,9 @@ DECLARE PLUGIN "omega_plugin" { open Ltac_plugin -open Names -open Coq_omega -open Stdarg - -let eval_tactic name = - let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in - let kn = KerName.make (ModPath.MPfile dp) (Label.make name) in - let tac = Tacenv.interp_ltac kn in - Tacinterp.eval_tactic tac - -let omega_tactic l = - let tacs = List.map - (function - | "nat" -> eval_tactic "zify_nat" - | "positive" -> eval_tactic "zify_positive" - | "N" -> eval_tactic "zify_N" - | "Z" -> eval_tactic "zify_op" - | s -> CErrors.user_err Pp.(str ("No Omega knowledge base for type "^s))) - (Util.List.sort_uniquize String.compare l) - in - Tacticals.New.tclTHEN - (Tacticals.New.tclREPEAT (Tacticals.New.tclTHENLIST tacs)) - (omega_solver) } TACTIC EXTEND omega -| [ "omega" ] -> { omega_tactic [] } +| [ "omega" ] -> { Coq_omega.omega_solver } END - -TACTIC EXTEND omega' -| [ "omega" "with" ne_ident_list(l) ] -> - { omega_tactic (List.map Names.Id.to_string l) } -| [ "omega" "with" "*" ] -> - { Tacticals.New.tclTHEN (eval_tactic "zify") (omega_tactic []) } -END - 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/ssrsetoid.v b/plugins/ssr/ssrsetoid.v index 609c9d5ab8..7c5cd135fe 100644 --- a/plugins/ssr/ssrsetoid.v +++ b/plugins/ssr/ssrsetoid.v @@ -18,9 +18,7 @@ than [eq] or [iff], e.g. a [RewriteRelation], by doing: [Require Import ssreflect. Require Setoid.] - This file's instances have priority 12 > other stdlib instances - and each [Under_rel] instance comes with a [Hint Cut] directive - (otherwise Ring_polynom.v won't compile because of unbounded search). + This file's instances have priority 12 > other stdlib instances. (Note: this file could be skipped when porting [under] to stdlib2.) *) @@ -38,85 +36,3 @@ Instance compat_Reflexive : RelationClasses.Reflexive R -> ssrclasses.Reflexive R | 12. Proof. now trivial. Qed. - -(** Add instances so that ['Under[ F i ]] terms, - that is, [Under_rel T R (F i) (?G i)] terms, - can be manipulated with rewrite/setoid_rewrite with lemmas on [R]. - Note that this requires that [R] is a [Prop] relation, otherwise - a [bool] relation may need to be "lifted": see the [TestPreOrder] - section in test-suite/ssr/under.v *) - -Instance Under_subrelation {A} (R : relation A) : subrelation R (Under_rel _ R) | 12. -Proof. now rewrite Under_relE. Qed. - -(* see also Morphisms.trans_co_eq_inv_impl_morphism *) - -Instance Under_Reflexive {A} (R : relation A) : - RelationClasses.Reflexive R -> - RelationClasses.Reflexive (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Reflexive Under_Reflexive] : typeclass_instances. - -(* These instances are a bit off-topic given that (Under_rel A R) will - typically be reflexive, to be able to trigger the [over] terminator - -Instance under_Irreflexive {A} (R : relation A) : - RelationClasses.Irreflexive R -> - RelationClasses.Irreflexive (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Irreflexive Under_Irreflexive] : typeclass_instances. - -Instance under_Asymmetric {A} (R : relation A) : - RelationClasses.Asymmetric R -> - RelationClasses.Asymmetric (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Asymmetric Under_Asymmetric] : typeclass_instances. - -Instance under_StrictOrder {A} (R : relation A) : - RelationClasses.StrictOrder R -> - RelationClasses.StrictOrder (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Strictorder Under_Strictorder] : typeclass_instances. - *) - -Instance Under_Symmetric {A} (R : relation A) : - RelationClasses.Symmetric R -> - RelationClasses.Symmetric (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Symmetric Under_Symmetric] : typeclass_instances. - -Instance Under_Transitive {A} (R : relation A) : - RelationClasses.Transitive R -> - RelationClasses.Transitive (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Transitive Under_Transitive] : typeclass_instances. - -Instance Under_PreOrder {A} (R : relation A) : - RelationClasses.PreOrder R -> - RelationClasses.PreOrder (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_PreOrder Under_PreOrder] : typeclass_instances. - -Instance Under_PER {A} (R : relation A) : - RelationClasses.PER R -> - RelationClasses.PER (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_PER Under_PER] : typeclass_instances. - -Instance Under_Equivalence {A} (R : relation A) : - RelationClasses.Equivalence R -> - RelationClasses.Equivalence (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Equivalence Under_Equivalence] : typeclass_instances. - -(* Don't handle Antisymmetric and PartialOrder classes for now, - as these classes depend on two relation symbols... *) diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 9f6fe0e651..d8dbf2f3dc 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -370,14 +370,14 @@ let coerce_search_pattern_to_sort hpat = let filter_head, coe_path = try let _, cp = - Classops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in + Coercionops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in warn (); true, cp with _ -> false, [] in let coerce hp coe_index = - let coe_ref = coe_index.Classops.coe_value in + let coe_ref = coe_index.Coercionops.coe_value in try - let n_imps = Option.get (Classops.hide_coercion coe_ref) in + let n_imps = Option.get (Coercionops.hide_coercion coe_ref) in mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] with Not_found | Option.IsNone -> errorstrm (str "need explicit coercion " ++ pr_global coe_ref ++ spc () diff --git a/pretyping/cases.ml b/pretyping/cases.ml index aa6ec1c941..cbd04a76ad 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -436,7 +436,7 @@ let adjust_tomatch_to_pattern ~program_mode sigma pb ((current,typ),deps,dep) = | exception Evarconv.UnableToUnify _ -> sigma, current | sigma -> sigma, current else - let sigma, j = Coercion.inh_conv_coerce_to ?loc ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in + let sigma, j, _trace = Coercion.inh_conv_coerce_to ?loc ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in sigma, j.uj_val in sigma, (current, try_find_ind !!(pb.env) sigma indt names)) @@ -1955,8 +1955,12 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let inh_conv_coerce_to_tycon ?loc ~program_mode env sigma j tycon = match tycon with - | Some p -> Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma - ~flags:(default_flags_of TransparentState.full) j p + | Some p -> + let (evd,v,_trace) = + Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma + ~flags:(default_flags_of TransparentState.full) j p + in + (evd,v) | None -> sigma, j (* We put the tycon inside the arity signature, possibly discovering dependencies. *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index f0e73bdb29..3c7f9a8f00 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -27,7 +27,7 @@ open EConstr open Vars open Reductionops open Pretype_errors -open Classops +open Coercionops open Evarutil open Evarconv open Evd @@ -136,20 +136,6 @@ let lift_args n sign = in liftrec (List.length sign) sign -let mu env evdref t = - let rec aux v = - let v' = hnf env !evdref v in - match disc_subset !evdref v' with - | Some (u, p) -> - let f, ct = aux u in - let p = hnf_nodelta env !evdref p in - (Some (fun x -> - app_opt env evdref - f (papp evdref sig_proj1 [| u; p; x |])), - ct) - | None -> (None, v) - in aux t - let coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) : (EConstr.constr -> EConstr.constr) option = @@ -367,36 +353,97 @@ let saturate_evd env evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd +type coercion_trace = + | IdCoe + | PrimProjCoe of { + proj : Projection.Repr.t; + args : econstr list; + previous : coercion_trace; + } + | Coe of { + head : econstr; + args : econstr list; + previous : coercion_trace; + } + | ProdCoe of { na : Name.t binder_annot; ty : econstr; dom : coercion_trace; body : coercion_trace } + +let empty_coercion_trace = IdCoe + +(* similar to iterated apply_coercion_args *) +let rec reapply_coercions sigma trace c = match trace with + | IdCoe -> c + | PrimProjCoe { proj; args; previous } -> + let c = reapply_coercions sigma previous c in + let args = args@[c] in + let head, args = match args with [] -> assert false | hd :: tl -> hd, tl in + applist (mkProj (Projection.make proj false, head), args) + | Coe {head; args; previous} -> + let c = reapply_coercions sigma previous c in + let args = args@[c] in + applist (head, args) + | ProdCoe { na; ty; dom; body } -> + let x = reapply_coercions sigma dom (mkRel 1) in + let c = beta_applist sigma (lift 1 c, [x]) in + let c = reapply_coercions sigma body c in + mkLambda (na, ty, c) + (* Apply coercion path from p to hj; raise NoCoercion if not applicable *) let apply_coercion env sigma p hj typ_cl = - let j,t,evd = + let j,t,trace,evd = List.fold_left - (fun (ja,typ_cl,sigma) i -> + (fun (ja,typ_cl,trace,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 + let argl = class_args_of env sigma typ_cl in + let trace = + if isid then trace + else match isproj with + | None -> Coe {head=fv.uj_val;args=argl;previous=trace} + | Some proj -> + let args = List.skipn (Projection.Repr.npars proj) argl in + PrimProjCoe {proj; args; previous=trace } in - (if isid then + let argl = argl@[ja.uj_val] in + let sigma, jres = apply_coercion_args env sigma true isproj argl fv in + let jres = + 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 + jres + in + jres, jres.uj_type, trace, sigma) + (hj,typ_cl,IdCoe,sigma) p + in evd, j, trace + +let mu env evdref t = + let rec aux v = + let v' = hnf env !evdref v in + match disc_subset !evdref v' with + | Some (u, p) -> + let f, ct, trace = aux u in + let p = hnf_nodelta env !evdref p in + let p1 = delayed_force sig_proj1 in + let evd, p1 = Evarutil.new_global !evdref p1 in + evdref := evd; + (Some (fun x -> + app_opt env evdref + f (mkApp (p1, [| u; p; x |]))), + ct, + Coe {head=p1; args=[u;p]; previous=trace}) + | None -> (None, v, IdCoe) + in aux t (* Try to coerce to a funclass; raise NoCoercion if not possible *) let inh_app_fun_core ~program_mode env evd j = let t = whd_all env evd j.uj_type in match EConstr.kind evd t with - | Prod _ -> (evd,j) + | Prod _ -> (evd,j,IdCoe) | Evar ev -> let (evd',t) = Evardefine.define_evar_as_product env evd ev in - (evd',{ uj_val = j.uj_val; uj_type = t }) + (evd',{ uj_val = j.uj_val; uj_type = t },IdCoe) | _ -> try let t,p = lookup_path_to_fun_from env evd j.uj_type in @@ -405,11 +452,11 @@ let inh_app_fun_core ~program_mode env evd j = if program_mode then try let evdref = ref evd in - let coercef, t = mu env evdref t in + let coercef, t, trace = mu env evdref t in let res = { uj_val = app_opt env evdref coercef j.uj_val; uj_type = t } in - (!evdref, res) + (!evdref, res, trace) with NoSubtacCoercion | NoCoercion -> - (evd,j) + (evd,j,IdCoe) else raise NoCoercion (* Try to coerce to a funclass; returns [j] if no coercion is applicable *) @@ -417,10 +464,10 @@ let inh_app_fun ~program_mode resolve_tc env evd j = try inh_app_fun_core ~program_mode env evd j with | NoCoercion when not resolve_tc - || not (get_use_typeclasses_for_conversion ()) -> (evd, j) + || not (get_use_typeclasses_for_conversion ()) -> (evd, j, IdCoe) | NoCoercion -> try inh_app_fun_core ~program_mode env (saturate_evd env evd) j - with NoCoercion -> (evd, j) + with NoCoercion -> (evd, j, IdCoe) let type_judgment env sigma j = match EConstr.kind sigma (whd_all env sigma j.uj_type) with @@ -430,7 +477,7 @@ let type_judgment env sigma j = let inh_tosort_force ?loc env evd j = try let t,p = lookup_path_to_sort_from env evd j.uj_type in - let evd,j1 = apply_coercion env evd p j t in + let evd,j1,_trace = apply_coercion env evd p j t in let j2 = Environ.on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env evd j2) with Not_found | NoCoercion -> @@ -449,7 +496,7 @@ let inh_coerce_to_sort ?loc env evd j = let inh_coerce_to_base ?loc ~program_mode env evd j = if program_mode then let evdref = ref evd in - let ct, typ' = mu env evdref j.uj_type in + let ct, typ', trace = mu env evdref j.uj_type in let res = { uj_val = (app_coercion env evdref ct j.uj_val); uj_type = typ' } @@ -459,7 +506,7 @@ let inh_coerce_to_base ?loc ~program_mode env evd j = let inh_coerce_to_prod ?loc ~program_mode env evd t = if program_mode then let evdref = ref evd in - let _, typ' = mu env evdref t in + let _, typ', _trace = mu env evdref t in !evdref, typ' else (evd, t) @@ -468,24 +515,24 @@ let inh_coerce_to_fail flags env evd rigidonly v t c1 = then raise NoCoercion else - let evd, v', t' = + let evd, v', t', trace = try let t2,t1,p = lookup_path_between env evd (t,c1) in - let evd,j = + let evd,j,trace = apply_coercion env evd p {uj_val = v; uj_type = t} t2 in - evd, j.uj_val, j.uj_type + evd, j.uj_val, j.uj_type, trace with Not_found -> raise NoCoercion in - try (unify_leq_delay ~flags env evd t' c1, v') + try (unify_leq_delay ~flags env evd t' c1, v', trace) with UnableToUnify _ -> raise NoCoercion let default_flags_of env = default_flags_of TransparentState.full let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigidonly v t c1 = - try (unify_leq_delay ~flags env evd t c1, v) + try (unify_leq_delay ~flags env evd t c1, v, IdCoe) with UnableToUnify (best_failed_evd,e) -> try inh_coerce_to_fail flags env evd rigidonly v t c1 with NoCoercion -> @@ -505,24 +552,27 @@ let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigid | na -> na) name in let open Context.Rel.Declaration in let env1 = push_rel (LocalAssum (name,u1)) env in - let (evd', v1) = + let (evd', v1, trace1) = inh_conv_coerce_to_fail ?loc env1 evd rigidonly (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'', mkLambda (name, u1, v2')) + let (evd'',v2',trace2) = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in + let trace = ProdCoe { na=name; ty=u1; dom=trace1; body=trace2 } in + (evd'', mkLambda (name, u1, v2'), trace) | _ -> 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') = + let (evd', val', otrace) = try - inh_conv_coerce_to_fail ?loc env evd ~flags rigidonly cj.uj_val cj.uj_type t + let (evd', val', trace) = inh_conv_coerce_to_fail ?loc env evd ~flags rigidonly cj.uj_val cj.uj_type t in + (evd', val', Some trace) with NoCoercionNoUnifier (best_failed_evd,e) -> try if program_mode then - coerce_itf ?loc env evd cj.uj_val cj.uj_type t + let (evd', val') = coerce_itf ?loc env evd cj.uj_val cj.uj_type t in + (evd', val', None) else raise NoSubtacCoercion with | NoSubtacCoercion when not resolve_tc || not (get_use_typeclasses_for_conversion ()) -> @@ -533,11 +583,12 @@ 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 cj.uj_val cj.uj_type t + let (evd', val', trace) = inh_conv_coerce_to_fail ?loc env evd' rigidonly cj.uj_val cj.uj_type t in + (evd', val', Some trace) with NoCoercionNoUnifier (_evd,_error) -> error_actual_type ?loc env best_failed_evd cj t e in - (evd',{ uj_val = val'; uj_type = t }) + (evd',{ uj_val = val'; uj_type = t },otrace) 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 diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index fe93a26f4f..b92f3709cc 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -16,13 +16,19 @@ open Glob_term (** {6 Coercions. } *) +type coercion_trace + +val empty_coercion_trace : coercion_trace + +val reapply_coercions : evar_map -> coercion_trace -> EConstr.t -> EConstr.t + (** [inh_app_fun resolve_tc env isevars j] coerces [j] to a function; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type a product; it returns [j] if no coercion is applicable. resolve_tc=false disables resolving type classes (as the last resort before failing) *) val inh_app_fun : program_mode:bool -> bool -> - env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment + env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment * coercion_trace (** [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it inserts a coercion into [j], if needed, in such a way it gets as @@ -48,11 +54,11 @@ val inh_coerce_to_prod : ?loc:Loc.t -> program_mode:bool -> val inh_conv_coerce_to : ?loc:Loc.t -> program_mode:bool -> bool -> env -> evar_map -> ?flags:Evarconv.unify_flags -> - unsafe_judgment -> types -> evar_map * unsafe_judgment + unsafe_judgment -> types -> evar_map * unsafe_judgment * coercion_trace option 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 + unsafe_judgment -> types -> evar_map * unsafe_judgment * coercion_trace option (** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases pattern [pat] typed in [ind1] into a pattern typed in [ind2]; diff --git a/pretyping/classops.ml b/pretyping/coercionops.ml index c12a236d8e..16021b66f8 100644 --- a/pretyping/classops.ml +++ b/pretyping/coercionops.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/coercionops.mli index 9c5274286e..9f633843eb 100644 --- a/pretyping/classops.mli +++ b/pretyping/coercionops.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/detyping.ml b/pretyping/detyping.ml index 862865bd90..037006bc47 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -455,7 +455,9 @@ let rec decomp_branch tags nal flags (avoid,env as e) sigma c = (avoid', add_name_opt na' body t env) sigma c let rec build_tree na isgoal e sigma ci cl = - let mkpat n rhs pl = DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in + let mkpat n rhs pl = + let na = update_name sigma na rhs in + na, DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,na) in let cnl = ci.ci_pp_info.cstr_tags in List.flatten (List.init (Array.length cl) @@ -485,7 +487,9 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with and contract_branch isgoal e sigma (cdn,mkpat,rhs) = let nal,rhs = decomp_branch cdn [] isgoal e sigma rhs in let mat = align_tree nal isgoal rhs sigma in - List.map (fun (ids,hd,rhs) -> ids,mkpat rhs hd,rhs) mat + List.map (fun (ids,hd,rhs) -> + let na, pat = mkpat rhs hd in + (Nameops.Name.fold_right Id.Set.add na ids, pat, rhs)) mat (**********************************************************************) (* Transform internal representation of pattern-matching into list of *) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 2130d4ce90..3bd52088c7 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1337,8 +1337,8 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = try let evi = Evd.find_undefined evd evk in let evi = nf_evar_info evd evi in - let env_evar_unf = evar_env evi in - let env_evar = evar_filtered_env evi in + let env_evar_unf = evar_env env_rhs evi in + let env_evar = evar_filtered_env env_rhs evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in if !debug_ho_unification then @@ -1473,16 +1473,16 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = | Some [t] -> if not (noccur_evar env_rhs evd ev (EConstr.of_constr t)) then raise (TypingFailed evd); - instantiate_evar evar_unify flags evd ev (EConstr.of_constr t) + instantiate_evar evar_unify flags env_rhs evd ev (EConstr.of_constr t) | Some l when abstract = Abstraction.Abstract && List.exists (fun c -> isVarId evd id (EConstr.of_constr c)) l -> - instantiate_evar evar_unify flags evd ev vid + instantiate_evar evar_unify flags env_rhs evd ev vid | _ -> evd) with e -> user_err (Pp.str "Cannot find an instance") else ((if !debug_ho_unification then let evi = Evd.find evd evk in - let env = Evd.evar_env evi in + let env = Evd.evar_env env_rhs evi in Feedback.msg_debug Pp.(str"evar is defined: " ++ int (Evar.repr evk) ++ spc () ++ prc env evd (match evar_body evi with Evar_defined c -> c @@ -1498,7 +1498,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = (if !debug_ho_unification then begin let evi = Evd.find evd evk in - let evenv = evar_env evi in + let evenv = evar_env env_rhs evi in let body = match evar_body evi with Evar_empty -> assert false | Evar_defined c -> c in Feedback.msg_debug Pp.(str"evar was defined already as: " ++ prc evenv evd body) end; @@ -1506,7 +1506,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = else try let evi = Evd.find_undefined evd evk in - let evenv = evar_env evi in + let evenv = evar_env env_rhs evi in let rhs' = nf_evar evd rhs' in if !debug_ho_unification then Feedback.msg_debug Pp.(str"abstracted type before second solve_evars: " ++ @@ -1517,7 +1517,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = if !debug_ho_unification then Feedback.msg_debug Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs')); let flags = default_flags_of TransparentState.full in - Evarsolve.instantiate_evar evar_unify flags evd evk rhs' + Evarsolve.instantiate_evar evar_unify flags env_rhs evd evk rhs' with IllTypedInstance _ -> raise (TypingFailed evd) in let evd = abstract_free_holes evd subst in @@ -1664,7 +1664,7 @@ let max_undefined_with_candidates evd = with MaxUndefined ans -> Some ans -let rec solve_unconstrained_evars_with_candidates flags evd = +let rec solve_unconstrained_evars_with_candidates flags env evd = (* max_undefined is supposed to return the most recent, hence possibly most dependent evar *) match max_undefined_with_candidates evd with @@ -1675,9 +1675,9 @@ let rec solve_unconstrained_evars_with_candidates flags evd = | a::l -> (* In case of variables, most recent ones come first *) try - let evd = instantiate_evar evar_unify flags evd evk a in + let evd = instantiate_evar evar_unify flags env evd evk a in match reconsider_unif_constraints evar_unify flags evd with - | Success evd -> solve_unconstrained_evars_with_candidates flags evd + | Success evd -> solve_unconstrained_evars_with_candidates flags env evd | UnifFailure _ -> aux l with | IllTypedInstance _ -> aux l @@ -1685,7 +1685,7 @@ let rec solve_unconstrained_evars_with_candidates flags evd = (* Expected invariant: most dependent solutions come first *) (* so as to favor progress when used with the refine tactics *) let evd = aux l in - solve_unconstrained_evars_with_candidates flags evd + solve_unconstrained_evars_with_candidates flags env evd let solve_unconstrained_impossible_cases env evd = Evd.fold_undefined (fun evk ev_info evd' -> @@ -1695,18 +1695,18 @@ let solve_unconstrained_impossible_cases env evd = let evd' = Evd.merge_context_set Evd.univ_flexible_alg ?loc evd' ctx in let ty = j_type j in let flags = default_flags env in - instantiate_evar evar_unify flags evd' evk ty + instantiate_evar evar_unify flags env evd' evk ty | _ -> evd') evd evd let solve_unif_constraints_with_heuristics env ?(flags=default_flags env) ?(with_ho=false) evd = - let evd = solve_unconstrained_evars_with_candidates flags evd in + let evd = solve_unconstrained_evars_with_candidates flags env evd in let rec aux evd pbs progress stuck = match pbs with | (pbty,env,t1,t2 as pb) :: pbs -> (match apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 with | Success evd' -> - let evd' = solve_unconstrained_evars_with_candidates flags evd' in + let evd' = solve_unconstrained_evars_with_candidates flags env evd' in let (evd', rest) = extract_all_conv_pbs evd' in begin match rest with | [] -> aux evd' pbs true stuck diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index aebdd14396..c580d44237 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -76,7 +76,7 @@ let idx = Namegen.default_dependent_ident let define_pure_evar_as_product env evd evk = let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in - let evenv = evar_env evi in + let evenv = evar_env env evi in let id = next_ident_away idx (Environ.ids_of_named_context_val evi.evar_hyps) in let concl = Reductionops.whd_all evenv evd evi.evar_concl in let s = destSort evd concl in @@ -129,7 +129,7 @@ let define_evar_as_product env evd (evk,args) = let define_pure_evar_as_lambda env evd evk = let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in - let evenv = evar_env evi in + let evenv = evar_env env evi in let typ = Reductionops.whd_all evenv evd (evar_concl evi) in let evd1,(na,dom,rng) = match EConstr.kind evd typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) @@ -170,7 +170,7 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function let define_evar_as_sort env evd (ev,args) = let evd, s = new_sort_variable univ_rigid evd in let evi = Evd.find_undefined evd ev in - let concl = Reductionops.whd_all (evar_env evi) evd evi.evar_concl in + let concl = Reductionops.whd_all (evar_env env evi) evd evi.evar_concl in let sort = destSort evd concl in let evd' = Evd.define ev (mkSort s) evd in Evd.set_leq_sort env evd' (Sorts.super s) (ESorts.kind evd' sort), s diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 5a23525fb0..b54a713a16 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -764,9 +764,9 @@ let restrict_upon_filter evd evk p args = let len = Array.length args in Filter.restrict_upon oldfullfilter len (fun i -> p (Array.unsafe_get args i)) -let check_evar_instance unify flags evd evk1 body = +let check_evar_instance unify flags env evd evk1 body = let evi = Evd.find evd evk1 in - let evenv = evar_env evi in + let evenv = evar_env env evi in (* FIXME: The body might be ill-typed when this is called from w_merge *) (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) let ty = @@ -915,7 +915,7 @@ let rec find_solution_type evarenv = function let rec do_projection_effects unify flags define_fun env ty evd = function | ProjectVar -> evd | ProjectEvar ((evk,argsv),evi,id,p) -> - let evd = check_evar_instance unify flags evd evk (mkVar id) in + let evd = check_evar_instance unify flags env evd evk (mkVar id) in let evd = Evd.define evk (EConstr.mkVar id) evd in (* TODO: simplify constraints involving evk *) let evd = do_projection_effects unify flags define_fun env ty evd p in @@ -1284,7 +1284,7 @@ let solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 (evk2,_ as update_evar_info evk2 (fst (destEvar evd' body)) evd' else evd' in - check_evar_instance unify flags evd' evk2 body + check_evar_instance unify flags env evd' evk2 body with EvarSolvedOnTheFly (evd,c) -> f env evd pbty ev2 c @@ -1329,12 +1329,12 @@ let solve_evar_evar ?(force=false) f unify flags env evd pbty (evk1,args1 as ev1 try (* ?X : Π Δ. Type i = ?Y : Π Δ'. Type j. The body of ?X and ?Y just has to be of type Π Δ. Type k for some k <= i, j. *) - let evienv = Evd.evar_env evi in + let evienv = Evd.evar_env env evi in let concl1 = EConstr.Unsafe.to_constr evi.evar_concl in let ctx1, i = Reduction.dest_arity evienv concl1 in let ctx1 = List.map (fun c -> map_rel_decl EConstr.of_constr c) ctx1 in let evi2 = Evd.find evd evk2 in - let evi2env = Evd.evar_env evi2 in + let evi2env = Evd.evar_env env evi2 in let concl2 = EConstr.Unsafe.to_constr evi2.evar_concl in let ctx2, j = Reduction.dest_arity evi2env concl2 in let ctx2 = List.map (fun c -> map_rel_decl EConstr.of_constr c) ctx2 in @@ -1418,7 +1418,7 @@ let solve_candidates unify flags env evd (evk,argsv) rhs = (* time and the evar been solved by the filtering process *) if Evd.is_undefined evd evk then let evd' = Evd.define evk c evd in - check_evar_instance unify flags evd' evk c + check_evar_instance unify flags env evd' evk c else evd | l when List.length l < List.length l' -> let candidates = List.map fst l in @@ -1442,11 +1442,11 @@ let occur_evar_upto_types sigma n c = in try occur_rec c; false with Occur -> true -let instantiate_evar unify flags evd evk body = +let instantiate_evar unify flags env evd evk body = (* Check instance freezing the evar to be defined, as checking could involve the same evar definition problem again otherwise *) let flags = { flags with frozen_evars = Evar.Set.add evk flags.frozen_evars } in - let evd' = check_evar_instance unify flags evd evk body in + let evd' = check_evar_instance unify flags env evd evk body in Evd.define evk body evd' (* We try to instantiate the evar assuming the body won't depend @@ -1508,7 +1508,7 @@ let rec invert_definition unify flags choose imitate_defs raise (NotEnoughInformationToProgress sols); (* No unique projection but still restrict to where it is possible *) (* materializing is necessary, but is restricting useful? *) - let ty = find_solution_type (evar_filtered_env evi) sols in + let ty = find_solution_type (evar_filtered_env env evi) sols in let ty' = instantiate_evar_array evi ty argsv in let (evd,evar,(evk',argsv' as ev')) = materialize_evar (evar_define unify flags ~choose) env !evdref 0 ev ty' in @@ -1571,7 +1571,7 @@ let rec invert_definition unify flags choose imitate_defs try let evd,body = project_evar_on_evar false unify flags env' evd aliases 0 None ev'' ev' in let evd = Evd.define evk' body evd in - check_evar_instance unify flags evd evk' body + check_evar_instance unify flags env' evd evk' body with | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) | CannotProject (evd,ev'') -> @@ -1638,7 +1638,7 @@ let rec invert_definition unify flags choose imitate_defs else let t' = imitate (env,0) rhs in if !progress then - (recheck_applications unify flags (evar_env evi) evdref t'; t') + (recheck_applications unify flags (evar_env env evi) evdref t'; t') else t' in (!evdref,body) @@ -1670,7 +1670,7 @@ and evar_define unify flags ?(choose=false) ?(imitate_defs=true) env evd pbty (e if occur_evar_upto_types evd' evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) let evd', body = refresh_universes pbty env evd' body in - instantiate_evar unify flags evd' evk body + instantiate_evar unify flags env evd' evk body with | NotEnoughInformationToProgress sols -> postpone_non_unique_projection env evd pbty ev sols rhs diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 908adac7e4..74aee9da59 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -77,7 +77,7 @@ type conversion_check = unify_flags -> unification_kind -> - [c] does not contain any Meta(_) *) -val instantiate_evar : unifier -> unify_flags -> evar_map -> +val instantiate_evar : unifier -> unify_flags -> env -> evar_map -> Evar.t -> constr -> evar_map (** [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]), @@ -125,7 +125,7 @@ exception IllTypedInstance of env * types * types (* May raise IllTypedInstance if types are not convertible *) val check_evar_instance : unifier -> unify_flags -> - evar_map -> Evar.t -> constr -> evar_map + env -> evar_map -> Evar.t -> constr -> evar_map val remove_instance_local_defs : evar_map -> Evar.t -> 'a array -> 'a list diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 4925f3e5fa..bf61d44a10 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 @@ -359,7 +361,7 @@ let adjust_evar_source sigma na c = (* coerce to tycon if any *) let inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j = function - | None -> sigma, j + | None -> sigma, j, Some Coercion.empty_coercion_trace | Some t -> Coercion.inh_conv_coerce_to ?loc ~program_mode resolve_tc !!env sigma j t @@ -478,26 +480,144 @@ 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 discard_trace (sigma,t,otrace) = sigma, t + + 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 + discard_trace @@ 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 + discard_trace @@ 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 +625,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 + discard_trace @@ 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 +639,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 +656,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 +664,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,23 +759,29 @@ 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 + discard_trace @@ 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 + discard_trace @@ 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 let nargs_before_bidi = + if Option.is_empty tycon then length + (* We apply bidirectionality hints only if an expected type is specified *) + else (* if `f` is a global, we retrieve bidirectionality hints *) - try - let (gr,_) = destRef sigma fj.uj_val in - Option.default length @@ GlobRef.Map.find_opt gr !bidi_hints - with DestKO -> - length + try + let (gr,_) = destRef sigma fj.uj_val in + Option.default length @@ GlobRef.Map.find_opt gr !bidi_hints + with DestKO -> + length in let candargs = (* Bidirectional typechecking hint: @@ -685,24 +818,38 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : else fun f v -> applist (f, [v]) | _ -> fun _ f v -> applist (f, [v]) in - let rec apply_rec env sigma n resj candargs bidiargs = function - | [] -> sigma, resj, List.rev bidiargs + let refresh_template env sigma resj = + (* Special case for inductive type applications that must be + refreshed right away. *) + match EConstr.kind sigma resj.uj_val with + | App (f,args) -> + if Termops.is_template_polymorphic_ind !!env sigma f then + let c = mkApp (f, args) in + let sigma, c = Evarsolve.refresh_universes (Some true) !!env sigma c in + let t = Retyping.get_type_of !!env sigma c in + sigma, make_judge c (* use this for keeping evars: resj.uj_val *) t + else sigma, resj + | _ -> sigma, resj + in + let rec apply_rec env sigma n resj resj_before_bidi candargs bidiargs = function + | [] -> sigma, resj, resj_before_bidi, List.rev bidiargs | c::rest -> let bidi = n >= nargs_before_bidi in let argloc = loc_of_glob_constr c in - let sigma, resj = Coercion.inh_app_fun ~program_mode resolve_tc !!env sigma resj in + let sigma, resj, trace = Coercion.inh_app_fun ~program_mode resolve_tc !!env sigma resj in let resty = whd_all !!env sigma resj.uj_type in match EConstr.kind sigma resty with | Prod (na,c1,c2) -> - let tycon = Some c1 in let (sigma, hj), bidiargs = - if bidi && Option.has_some tycon then + if bidi then (* We want to get some typing information from the context before typing the argument, so we replace it by an existential variable *) let sigma, c_hole = new_evar env sigma ~src:(loc,Evar_kinds.InternalHole) c1 in - (sigma, make_judge c_hole c1), (c_hole, c) :: bidiargs - else pretype tycon env sigma c, bidiargs + (sigma, make_judge c_hole c1), (c_hole, c, trace) :: bidiargs + else + let tycon = Some c1 in + pretype tycon env sigma c, bidiargs in let sigma, candargs, ujval = match candargs with @@ -717,29 +864,18 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : in let sigma, ujval = adjust_evar_source sigma na.binder_name ujval in let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in - let j = { uj_val = value; uj_type = typ } in - apply_rec env sigma (n+1) j candargs bidiargs rest + let resj = { uj_val = value; uj_type = typ } in + let resj_before_bidi = if bidi then resj_before_bidi else resj in + apply_rec env sigma (n+1) resj resj_before_bidi candargs bidiargs rest | _ -> let sigma, hj = pretype empty_tycon env sigma c in error_cant_apply_not_functional ?loc:(Loc.merge_opt floc argloc) !!env sigma resj [|hj|] in - let sigma, resj, bidiargs = apply_rec env sigma 0 fj candargs [] args in - let sigma, resj = - match EConstr.kind sigma resj.uj_val with - | App (f,args) -> - if Termops.is_template_polymorphic_ind !!env sigma f then - (* Special case for inductive type applications that must be - refreshed right away. *) - let c = mkApp (f, args) in - let sigma, c = Evarsolve.refresh_universes (Some true) !!env sigma c in - let t = Retyping.get_type_of !!env sigma c in - sigma, make_judge c (* use this for keeping evars: resj.uj_val *) t - else sigma, resj - | _ -> sigma, resj - in - let sigma, t = inh_conv_coerce_to_tycon ?loc env sigma resj tycon in - let refine_arg sigma (newarg,origarg) = + let sigma, resj, resj_before_bidi, bidiargs = apply_rec env sigma 0 fj fj candargs [] args in + let sigma, resj = refresh_template env sigma resj in + let sigma, resj, otrace = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon in + let refine_arg n (sigma,t) (newarg,origarg,trace) = (* Refine an argument (originally `origarg`) represented by an evar (`newarg`) to use typing information from the context *) (* Recover the expected type of the argument *) @@ -748,14 +884,29 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let sigma, j = pretype (Some ty) env sigma origarg in (* Unify the (possibly refined) existential variable with the (typechecked) original value *) - Evarconv.unify_delay !!env sigma newarg (j_val j) + let sigma = Evarconv.unify_delay !!env sigma newarg (j_val j) in + sigma, app_f n (Coercion.reapply_coercions sigma trace t) (j_val j) in (* We now refine any arguments whose typing was delayed for bidirectionality *) - let sigma = List.fold_left refine_arg sigma bidiargs in - (sigma, t) + let t = resj_before_bidi.uj_val in + let sigma, t = List.fold_left_i refine_arg nargs_before_bidi (sigma,t) bidiargs in + (* If we did not get a coercion trace (e.g. with `Program` coercions, we + replaced user-provided arguments with inferred ones. Otherwise, we apply + the coercion trace to the user-provided arguments. *) + let resj = + match otrace with + | None -> resj + | Some trace -> + let resj = { resj with uj_val = t } in + let sigma, resj = refresh_template env sigma resj in + { resj with uj_val = Coercion.reapply_coercions sigma trace t } + in + (sigma, resj) - | 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 +916,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 + discard_trace @@ 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 +950,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 + discard_trace @@ 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 +977,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 +1074,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 +1108,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 +1143,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 - - | GCases (sty,po,tml,eqns) -> - Cases.compile_cases ?loc ~program_mode sty (pretype, sigma) tycon env (po,tml,eqns) + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon - | 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 +1155,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 +1186,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 discard_trace @@ 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 -> + discard_trace @@ 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 + discard_trace @@ 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 +1234,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 +1247,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 +1346,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 open Classops in +let path_convertible env sigma i p q = + let open Coercionops 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 +1367,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 @@ -1228,4 +1400,4 @@ let path_convertible env sigma p q = let _ = Evarconv.unify_delay env sigma tp tq in true with Evarconv.UnableToUnify _ | PretypeError _ -> false -let _ = Classops.install_path_comparator path_convertible +let _ = Coercionops.install_path_comparator path_convertible 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/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 7e140f4399..07154d4e03 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -26,7 +26,7 @@ Constr_matching Tacred Typeclasses_errors Typeclasses -Classops +Coercionops Program Coercion Detyping diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 5b416a99f9..3b918b5396 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -19,7 +19,6 @@ open CErrors open Util open Pp open Names -open Globnames open Constr open Mod_subst open Reductionops @@ -80,7 +79,7 @@ let subst_structure subst (id, kl, projs as obj) = (Option.Smart.map (subst_constant subst)) projs in - let id' = subst_constructor subst id in + let id' = Globnames.subst_constructor subst id in if projs' == projs && id' == id then obj else (id',kl,projs') @@ -114,7 +113,7 @@ let find_primitive_projection c = (* the effective components of a structure and the projections of the *) (* structure *) -(* Table des definitions "object" : pour chaque object c, +(* Table of "object" definitions: for each object c, c := [x1:B1]...[xk:Bk](Build_R a1...am t1...t_n) @@ -127,16 +126,19 @@ let find_primitive_projection c = that maps the pair (Li,ci) to the following data + o_ORIGIN = c (the constant name which this conversion rule is + synthesized from) o_DEF = c o_TABS = B1...Bk o_INJ = Some n (when ci is a reference to the parameter xi) - o_PARAMS = a1...am - o_NARAMS = m + o_TPARAMS = a1...am + o_NPARAMS = m o_TCOMP = ui1...uir *) type obj_typ = { + o_ORIGIN : GlobRef.t; o_DEF : constr; o_CTX : Univ.AUContext.t; o_INJ : int option; (* position of trivial argument if any *) @@ -187,13 +189,13 @@ let rec cs_pattern_of_constr env t = let _, params = Inductive.find_rectype env ty in Const_cs (GlobRef.ConstRef (Projection.constant p)), None, params @ [c] | Sort s -> Sort_cs (Sorts.family s), None, [] - | _ -> Const_cs (global_of_constr t) , None, [] + | _ -> Const_cs (Globnames.global_of_constr t) , None, [] let warn_projection_no_head_constant = CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker" - (fun (sign,env,t,con,proji_sp) -> + (fun (sign,env,t,ref,proji_sp) -> let env = Termops.push_rels_assum sign env in - let con_pp = Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef con) in + let con_pp = Nametab.pr_global_env Id.Set.empty ref in let proji_sp_pp = Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef proji_sp) in let term_pp = Termops.Internal.print_constr_env env (Evd.from_env env) (EConstr.of_constr t) in strbrk "Projection value has no head constant: " @@ -201,11 +203,17 @@ let warn_projection_no_head_constant = ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.") (* Intended to always succeed *) -let compute_canonical_projections env ~warn (con,ind) = - let o_CTX = Environ.constant_context env con in - let u = Univ.make_abstract_instance o_CTX in - let o_DEF = mkConstU (con, u) in - let c = Environ.constant_value_in env (con,u) in +let compute_canonical_projections env ~warn (gref,ind) = + let o_CTX = Environ.universes_of_global env gref in + let o_DEF, c = + match gref with + | GlobRef.ConstRef con -> + let u = Univ.make_abstract_instance o_CTX in + mkConstU (con, u), Environ.constant_value_in env (con,u) + | GlobRef.VarRef id -> + mkVar id, Option.get (Environ.named_body id env) + | GlobRef.ConstructRef _ | GlobRef.IndRef _ -> assert false + in let sign,t = Reductionops.splay_lam env (Evd.from_env env) (EConstr.of_constr c) in let sign = List.map (on_snd EConstr.Unsafe.to_constr) sign in let t = EConstr.Unsafe.to_constr t in @@ -224,10 +232,10 @@ let compute_canonical_projections env ~warn (con,ind) = match cs_pattern_of_constr nenv t with | patt, o_INJ, o_TCOMPS -> ((GlobRef.ConstRef proji_sp, (patt, t)), - { o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) + { o_ORIGIN = gref ; o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) :: acc | exception Not_found -> - if warn then warn_projection_no_head_constant (sign, env, t, con, proji_sp); + if warn then warn_projection_no_head_constant (sign, env, t, gref, proji_sp); acc ) acc spopt else acc @@ -263,12 +271,17 @@ let register_canonical_structure ~warn env sigma o = warn_redundant_canonical_projection (hd_val, prj, new_can_s, old_can_s) ) -let subst_canonical_structure subst (cst,ind as obj) = +type cs = GlobRef.t * inductive + +let subst_canonical_structure subst (gref,ind as obj) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) - let cst' = subst_constant subst cst in - let ind' = subst_ind subst ind in - if cst' == cst && ind' == ind then obj else (cst',ind') + match gref with + | GlobRef.ConstRef cst -> + let cst' = subst_constant subst cst in + let ind' = subst_ind subst ind in + if cst' == cst && ind' == ind then obj else (GlobRef.ConstRef cst',ind') + | _ -> assert false (*s High-level declaration of a canonical structure *) @@ -279,15 +292,20 @@ let error_not_structure ref description = description)) let check_and_decompose_canonical_structure env sigma ref = - let sp = + let vc = match ref with - GlobRef.ConstRef sp -> sp - | _ -> error_not_structure ref (str "Expected an instance of a record or structure.") + | GlobRef.ConstRef sp -> + let u = Univ.make_abstract_instance (Environ.constant_context env sp) in + begin match Environ.constant_opt_value_in env (sp, u) with + | Some vc -> vc + | None -> error_not_structure ref (str "Could not find its value in the global environment.") end + | GlobRef.VarRef id -> + begin match Environ.named_body id env with + | Some b -> b + | None -> error_not_structure ref (str "Could not find its value in the global environment.") end + | GlobRef.IndRef _ | GlobRef.ConstructRef _ -> + error_not_structure ref (str "Expected an instance of a record or structure.") in - let u = Univ.make_abstract_instance (Environ.constant_context env sp) in - let vc = match Environ.constant_opt_value_in env (sp, u) with - | Some vc -> vc - | None -> error_not_structure ref (str "Could not find its value in the global environment.") in let body = snd (splay_lam env sigma (EConstr.of_constr vc)) in let body = EConstr.Unsafe.to_constr body in let f,args = match kind body with @@ -305,7 +323,7 @@ let check_and_decompose_canonical_structure env sigma ref = let ntrue_projs = List.count (fun { pk_true_proj } -> pk_true_proj) s.s_PROJKIND in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref (str "Got too few arguments to the record or structure constructor."); - (sp,indsp) + (ref,indsp) let lookup_canonical_conversion (proj,pat) = assoc_pat pat (GlobRef.Map.find proj !object_table) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index e8b0d771aa..fd156adc2c 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -73,6 +73,7 @@ type cs_pattern = | Default_cs type obj_typ = { + o_ORIGIN : GlobRef.t; o_DEF : constr; o_CTX : Univ.AUContext.t; o_INJ : int option; (** position of trivial argument *) @@ -86,13 +87,15 @@ val cs_pattern_of_constr : Environ.env -> constr -> cs_pattern * int option * co val pr_cs_pattern : cs_pattern -> Pp.t +type cs = GlobRef.t * inductive + val lookup_canonical_conversion : (GlobRef.t * cs_pattern) -> constr * obj_typ val register_canonical_structure : warn:bool -> Environ.env -> Evd.evar_map -> - Constant.t * inductive -> unit -val subst_canonical_structure : Mod_subst.substitution -> Constant.t * inductive -> Constant.t * inductive + cs -> unit +val subst_canonical_structure : Mod_subst.substitution -> cs -> cs val is_open_canonical_projection : Environ.env -> Evd.evar_map -> Reductionops.state -> bool val canonical_projections : unit -> ((GlobRef.t * cs_pattern) * obj_typ) list -val check_and_decompose_canonical_structure : Environ.env -> Evd.evar_map -> GlobRef.t -> Constant.t * inductive +val check_and_decompose_canonical_structure : Environ.env -> Evd.evar_map -> GlobRef.t -> cs diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 48d5fac321..6486435ca2 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1290,7 +1290,7 @@ let is_mimick_head sigma ts f = let try_to_coerce env evd c cty tycon = let j = make_judge c cty in - let (evd',j') = inh_conv_coerce_rigid_to ~program_mode:false true env evd j tycon in + let (evd',j',_trace) = inh_conv_coerce_rigid_to ~program_mode:false true env evd j tycon in let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in let evd' = Evd.map_metas_fvalue (fun c -> nf_evar evd' c) evd' in (evd',j'.uj_val) diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 2da163b8ee..b55a41471a 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -275,7 +275,7 @@ let tag_var = tag Tag.variable pr_reference r, latom | CPatOr pl -> - let pp = pr_patt mt (lpator,Any) in + let pp p = hov 0 (pr_patt mt (lpator,Any) p) in surround (hov 0 (prlist_with_sep pr_spcbar pp pl)), lpator | CPatNotation ((_,"( _ )"),([p],[]),[]) -> @@ -304,7 +304,8 @@ let tag_var = tag Tag.variable spc() ++ hov 4 (pr_with_comments ?loc (str "| " ++ - hov 0 (prlist_with_sep pr_spcbar (prlist_with_sep sep_v (pr_patt ltop)) pl + hov 0 (prlist_with_sep pr_spcbar + (fun p -> hov 0 (prlist_with_sep sep_v (pr_patt ltop) p)) pl ++ str " =>") ++ pr_sep_com spc (pr ltop) rhs)) diff --git a/printing/printer.ml b/printing/printer.ml index bb54f587fd..97e0528939 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -490,8 +490,8 @@ let pr_concl n ?(diffs=false) ?og_s sigma g = header ++ str " is:" ++ cut () ++ str" " ++ pc (* display evar type: a context and a type *) -let pr_evgl_sign sigma evi = - let env = evar_env evi in +let pr_evgl_sign env sigma evi = + let env = evar_env env evi in let ps = pr_named_context_of env sigma in let _, l = match Filter.repr (evar_filter evi) with | None -> [], [] @@ -517,7 +517,8 @@ let pr_evgl_sign sigma evi = (* Print an existential variable *) let pr_evar sigma (evk, evi) = - let pegl = pr_evgl_sign sigma evi in + let env = Global.env () in + let pegl = pr_evgl_sign env sigma evi in hov 0 (pr_existential_key sigma evk ++ str " : " ++ pegl) (* Print an enumerated list of existential variables *) diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 58c0f7db53..e466992721 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -678,7 +678,7 @@ let define_with_type sigma env ev c = let t = Retyping.get_type_of env sigma ev in let ty = Retyping.get_type_of env sigma c in let j = Environ.make_judge c ty in - let (sigma, j) = Coercion.inh_conv_coerce_to ~program_mode:false true env sigma j t in + let (sigma, j, _trace) = Coercion.inh_conv_coerce_to ~program_mode:false true env sigma j t in let (ev, _) = destEvar sigma ev in let sigma = Evd.define ev j.Environ.uj_val sigma in sigma 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/evar_refiner.ml b/proofs/evar_refiner.ml index 59918ab2f9..8297b11585 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -44,10 +44,10 @@ let define_and_solve_constraints evk c env evd = | Success evd -> evd | UnifFailure _ -> user_err Pp.(str "Instance does not satisfy the constraints.") -let w_refine (evk,evi) (ltac_var,rawc) sigma = +let w_refine (evk,evi) (ltac_var,rawc) env sigma = if Evd.is_defined sigma evk then user_err Pp.(str "Instantiate called on already-defined evar"); - let env = Evd.evar_filtered_env evi in + let env = Evd.evar_filtered_env env evi in let sigma',typed_c = let flags = { Pretyping.use_typeclasses = true; diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index 8f3ac7ed25..a618bf1c94 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -17,4 +17,4 @@ open Ltac_pretype type glob_constr_ltac_closure = ltac_var_map * glob_constr val w_refine : Evar.t * evar_info -> - glob_constr_ltac_closure -> evar_map -> evar_map + glob_constr_ltac_closure -> Environ.env -> evar_map -> evar_map diff --git a/proofs/goal.ml b/proofs/goal.ml index 426fba7f63..4759c0860f 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -31,8 +31,9 @@ module V82 = struct (* Old style env primitive *) let env evars gl = + let env = Global.env () in let evi = Evd.find evars gl in - Evd.evar_filtered_env evi + Evd.evar_filtered_env env evi (* Old style hyps primitive *) let hyps evars gl = diff --git a/proofs/proof.ml b/proofs/proof.ml index 2ee006631a..5ab4409f8b 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 @@ -439,10 +434,10 @@ module V82 = struct else CList.nth evl (n-1) in - let env = Evd.evar_filtered_env evi in + let env = Evd.evar_filtered_env env evi in let rawc = intern env sigma in let ltac_vars = Glob_ops.empty_lvar in - let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in + let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) env sigma in Proofview.Unsafe.tclEVARS sigma end in let { name; poly } = pr in 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/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/test-suite/Makefile b/test-suite/Makefile index bfdf34b1cf..265c2eafa7 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -530,29 +530,37 @@ $(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); \ echo " $<...Error! (should be accepted)" ; \ + $(FAIL); \ elif [ "$$res" = "" ]; then \ echo $(log_failure); \ echo " $<...Error! (couldn't find a time measure)"; \ + $(FAIL); \ 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" "$<"`; \ - 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 \ + if [ "$$res" = "" ]; then \ echo $(log_failure); \ - echo " $<...Error! (should run faster ($$rescorrected >= $$exp))"; \ - $(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_11140.v b/test-suite/bugs/bug_11140.v new file mode 100644 index 0000000000..ca806ea324 --- /dev/null +++ b/test-suite/bugs/bug_11140.v @@ -0,0 +1,11 @@ +Axiom T : nat -> Prop. +Axiom f : forall x, T x. +Arguments f & x. + +Lemma test : (f (1 + _) : T 2) = f 2. +match goal with +| |- (f (1 + 1) = f 2) => idtac +| |- (f 2 = f 2) => fail (* Issue 11140 *) +| |- _ => fail +end. +Abort. 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_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_11321.v b/test-suite/bugs/closed/bug_11321.v new file mode 100644 index 0000000000..ce95280fb1 --- /dev/null +++ b/test-suite/bugs/closed/bug_11321.v @@ -0,0 +1,10 @@ +Require Import Cyclic63. + +Goal False. +Proof. +assert (4294967296 *c 2147483648 = WW 2 0)%int63 as H. + vm_cast_no_check (@eq_refl (zn2z int) (WW 2 0)%int63). +generalize (f_equal (zn2z_to_Z wB to_Z) H). +now rewrite mulc_WW_spec. +Fail Qed. +Abort. diff --git a/test-suite/bugs/closed/bug_11360.v b/test-suite/bugs/closed/bug_11360.v new file mode 100644 index 0000000000..d8bc4a9f02 --- /dev/null +++ b/test-suite/bugs/closed/bug_11360.v @@ -0,0 +1,6 @@ +Section S. + Variable (A:Type). + #[universes(template)] + Inductive bar (d:A) := . +End S. +Check bar nat 0. diff --git a/test-suite/coq-makefile/findlib-package-unpacked/Makefile.local b/test-suite/coq-makefile/findlib-package-unpacked/Makefile.local new file mode 100644 index 0000000000..0f4a7d9954 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/Makefile.local @@ -0,0 +1 @@ +CAMLPKGS += -package foo diff --git a/test-suite/coq-makefile/findlib-package-unpacked/_CoqProject b/test-suite/coq-makefile/findlib-package-unpacked/_CoqProject new file mode 100644 index 0000000000..cbdb43f842 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/_CoqProject @@ -0,0 +1,10 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mllib +src/test.mlg +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/META b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/META new file mode 100644 index 0000000000..ff5f1c7c96 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/META @@ -0,0 +1,4 @@ +archive(byte)="foo.cma" +archive(native)="foo.cmxa" +linkopts="-linkall" +requires="str" diff --git a/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/Makefile b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/Makefile new file mode 100644 index 0000000000..1615bfd067 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/Makefile @@ -0,0 +1,14 @@ +-include ../../Makefile.conf + +CO="$(COQMF_OCAMLFIND)" opt +CB="$(COQMF_OCAMLFIND)" ocamlc + +all: + $(CO) -c foolib.ml + $(CO) -a foolib.cmx -o foo.cmxa + $(CB) -c foolib.ml + $(CB) -a foolib.cmo -o foo.cma + $(CB) -c foo.mli # empty .mli file, to be understood + +clean: + rm -f *.cmo *.cma *.cmx *.cmxa *.cmi *.o *.a diff --git a/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foo.mli b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foo.mli new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foo.mli diff --git a/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foolib.ml b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foolib.ml new file mode 100644 index 0000000000..81306fb89b --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foolib.ml @@ -0,0 +1,2 @@ +let foo () = + assert(Str.search_forward (Str.regexp "foo") "barfoobar" 0 = 3) diff --git a/test-suite/coq-makefile/findlib-package-unpacked/run.sh b/test-suite/coq-makefile/findlib-package-unpacked/run.sh new file mode 100755 index 0000000000..e53a7ed0f7 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/run.sh @@ -0,0 +1,20 @@ +#!/usr/bin/env bash + +. ../template/init.sh +mv src/test_plugin.mlpack src/test_plugin.mllib + +echo "let () = Foolib.foo ();;" >> src/test_aux.ml +export OCAMLPATH=$OCAMLPATH:$PWD/findlib +if which cygpath 2>/dev/null; then + # the only way I found to pass OCAMLPATH on win is to have it contain + # only one entry + OCAMLPATH=$(cygpath -w "$PWD"/findlib) + export OCAMLPATH +fi +make -C findlib/foo clean +coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf +cat Makefile.local +make -C findlib/foo +make +make byte diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh index e1f17725dc..13e484b852 100755 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh @@ -5,20 +5,14 @@ set -e cd "$(dirname "${BASH_SOURCE[0]}")" -python2 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build-pretty.log2 || exit $? -python3 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build-pretty.log3 || exit $? +"$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build-pretty.log || exit $? -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log || exit $? -cat time-of-build.log.in | python2 "$COQLIB"/tools/make-one-time-file.py - time-of-build-pretty.log2 || exit $? -cat time-of-build.log.in | python3 "$COQLIB"/tools/make-one-time-file.py - time-of-build-pretty.log3 || exit $? +cat time-of-build.log.in | "$COQLIB"/tools/make-one-time-file.py - time-of-build-pretty.log || exit $? -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log || exit $? -(python2 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in - || exit $?) > time-of-build-pretty.log2 -(python3 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in - || exit $?) > time-of-build-pretty.log3 +("$COQLIB"/tools/make-one-time-file.py time-of-build.log.in - || exit $?) > time-of-build-pretty.log -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log || exit $? diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh index 9f3b648aa3..cfacf738a3 100755 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh @@ -9,3 +9,4 @@ export COQLIB ./001-correct-diff-sorting-order/run.sh ./002-single-file-sorting/run.sh +./003-non-utf8/run.sh 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/output/Cases.out b/test-suite/output/Cases.out index e84ac85aa8..6976610b22 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -166,3 +166,15 @@ fun x : K => match x with : K -> nat The command has indeed failed with message: Pattern "S _, _" is redundant in this clause. +stray = +fun N : Tree => +match N with +| App (App Node (Node as strayvariable)) _ | + App (App Node (App Node _ as strayvariable)) _ | + App (App Node (App (App Node Node) (App _ _) as strayvariable)) _ | + App (App Node (App (App Node (App _ _)) _ as strayvariable)) _ | + App (App Node (App (App (App _ _) _) _ as strayvariable)) _ => + strayvariable +| _ => Node +end + : Tree -> Tree diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index a040b69b44..262ec2b677 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -222,3 +222,23 @@ Check fun x => match x with a3 | a4 | a1 => 3 | _ => 2 end. (* Test redundant clause within a disjunctive pattern *) Fail Check fun n m => match n, m with 0, 0 | _, S _ | S 0, _ | S (S _ | _), _ => false end. + +Module Bug11231. + +(* Missing dependency in computing if a clause is a default clause *) + +Inductive Tree: Set := +| Node : Tree +| App : Tree -> Tree -> Tree +. + +Definition stray N := +match N with +| App (App Node (App (App Node Node) Node)) _ => Node +| App (App Node strayvariable) _ => strayvariable +| _ => Node +end. + +Print stray. + +End Bug11231. 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/PrintCanonicalProjections.out b/test-suite/output/PrintCanonicalProjections.out new file mode 100644 index 0000000000..a4e2251440 --- /dev/null +++ b/test-suite/output/PrintCanonicalProjections.out @@ -0,0 +1,18 @@ +bool <- sort_eq ( bool_eqType ) +bool <- sort_TYPE ( bool_TYPE ) +nat <- sort_eq ( nat_eqType ) +nat <- sort_TYPE ( nat_TYPE ) +prod <- sort_eq ( prod_eqType ) +prod <- sort_TYPE ( prod_TYPE ) +sum <- sort_eq ( sum_eqType ) +sum <- sort_TYPE ( sum_TYPE ) +sum <- sort_TYPE ( sum_TYPE ) +prod <- sort_TYPE ( prod_TYPE ) +nat <- sort_TYPE ( nat_TYPE ) +bool <- sort_TYPE ( bool_TYPE ) +sum <- sort_eq ( sum_eqType ) +prod <- sort_eq ( prod_eqType ) +nat <- sort_eq ( nat_eqType ) +bool <- sort_eq ( bool_eqType ) +bool <- sort_TYPE ( bool_TYPE ) +bool <- sort_eq ( bool_eqType ) diff --git a/test-suite/output/PrintCanonicalProjections.v b/test-suite/output/PrintCanonicalProjections.v new file mode 100644 index 0000000000..808cdffe39 --- /dev/null +++ b/test-suite/output/PrintCanonicalProjections.v @@ -0,0 +1,46 @@ +Record TYPE := Pack_TYPE { sort_TYPE :> Type }. +Record eqType := Pack_eq { sort_eq :> Type; _ : sort_eq -> sort_eq -> bool }. + +Definition eq_op (T : eqType) : T -> T -> bool := + match T with Pack_eq _ op => op end. + +Definition bool_eqb b1 b2 := + match b1, b2 with + | false, false => true + | true, true => true + | _, _ => false + end. + +Canonical bool_TYPE := Pack_TYPE bool. +Canonical bool_eqType := Pack_eq bool bool_eqb. + +Canonical nat_TYPE := Pack_TYPE nat. +Canonical nat_eqType := Pack_eq nat Nat.eqb. + +Definition prod_eqb (T U : eqType) (x y : T * U) := + match x, y with + | (x1, x2), (y1, y2) => + andb (eq_op _ x1 y1) (eq_op _ x2 y2) + end. + +Canonical prod_TYPE (T U : TYPE) := Pack_TYPE (T * U). +Canonical prod_eqType (T U : eqType) := Pack_eq (T * U) (prod_eqb T U). + +Definition sum_eqb (T U : eqType) (x y : T + U) := + match x, y with + | inl x, inl y => eq_op _ x y + | inr x, inr y => eq_op _ x y + | _, _ => false + end. + +Canonical sum_TYPE (T U : TYPE) := Pack_TYPE (T + U). +Canonical sum_eqType (T U : eqType) := Pack_eq (T + U) (sum_eqb T U). + +Print Canonical Projections bool. +Print Canonical Projections nat. +Print Canonical Projections prod. +Print Canonical Projections sum. +Print Canonical Projections sort_TYPE. +Print Canonical Projections sort_eq. +Print Canonical Projections sort_TYPE bool. +Print Canonical Projections bool_eqType. 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/output/unification.out b/test-suite/output/unification.out new file mode 100644 index 0000000000..dfd755da61 --- /dev/null +++ b/test-suite/output/unification.out @@ -0,0 +1,11 @@ +The command has indeed failed with message: +In environment +x : T +T : Type +a : T +Unable to unify "T" with "?X@{x0:=x; x:=C a}" (cannot instantiate +"?X" because "T" is not in its scope: available arguments are +"x" "C a"). +The command has indeed failed with message: +The term "id" has type "ID" while it is expected to have type +"Type -> ?T" (cannot instantiate "?T" because "A" is not in its scope). diff --git a/test-suite/output/unification.v b/test-suite/output/unification.v new file mode 100644 index 0000000000..ff99f2e23c --- /dev/null +++ b/test-suite/output/unification.v @@ -0,0 +1,12 @@ +(* Unification error tests *) + +Module A. + +(* Check regression of an UNBOUND_REL bug *) +Inductive T := C : forall {A}, A -> T. +Fail Check fun x => match x return ?[X] with C a => a end. + +(* Bug #3634 *) +Fail Check (id:Type -> _). + +End A. diff --git a/test-suite/ssr/under.v b/test-suite/ssr/under.v index c12491138a..0312b9c733 100644 --- a/test-suite/ssr/under.v +++ b/test-suite/ssr/under.v @@ -313,8 +313,7 @@ Qed. End TestGeneric2. Section TestPreOrder. -(* inspired by https://github.com/coq/coq/pull/10022#issuecomment-530101950 - but without needing to do [rewrite UnderE] manually. *) +(* inspired by https://github.com/coq/coq/pull/10022#issuecomment-530101950 *) Require Import Morphisms. @@ -330,7 +329,7 @@ Parameter leq_mul : Local Notation "+%N" := addn (at level 0, only parsing). -(** Context lemma (could *) +(** Context lemma *) Lemma leq'_big : forall I (F G : I -> nat) (r : seq I), (forall i : I, leq' (F i) (G i)) -> (leq' (\big[+%N/0%N]_(i <- r) F i) (\big[+%N/0%N]_(i <- r) G i)). @@ -370,8 +369,10 @@ have lem : forall (i : nat), i < n -> leq' (3 + i) (3 + n). under leq'_big => i. { - (* The "magic" is here: instantiate the evar with the bound "3 + n" *) - rewrite lem ?ltn_ord //. over. + rewrite UnderE. + + (* instantiate the evar with the bound "3 + n" *) + apply: lem; exact: ltn_ord. } cbv beta. diff --git a/test-suite/success/CanonicalStructure.v b/test-suite/success/CanonicalStructure.v index e6d674c1e6..88702a6e80 100644 --- a/test-suite/success/CanonicalStructure.v +++ b/test-suite/success/CanonicalStructure.v @@ -51,3 +51,22 @@ Fail Check (refl_equal _ : l _ = x2). Check s0. Check s1. Check s2. + +Section Y. + Let s3 := MKL x3. + Canonical Structure s3. + Check (refl_equal _ : l _ = x3). +End Y. +Fail Check (refl_equal _ : l _ = x3). +Fail Check s3. + +Section V. + #[canonical] Let s3 := MKL x3. + Check (refl_equal _ : l _ = x3). +End V. + +Section W. + #[canonical, local] Definition s2' := MKL x2. + Check (refl_equal _ : l _ = x2). +End W. +Fail Check (refl_equal _ : l _ = x2). 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/Omega.v b/test-suite/success/Omega.v index 470e4f0580..5e0f90d59b 100644 --- a/test-suite/success/Omega.v +++ b/test-suite/success/Omega.v @@ -90,5 +90,5 @@ Qed. (* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) Lemma lem10 : forall n m:nat, le n (plus n (mult n m)). Proof. -intros; omega with *. +intros; zify; omega. Qed. diff --git a/test-suite/success/OmegaPre.v b/test-suite/success/OmegaPre.v index 17531064cc..0223255067 100644 --- a/test-suite/success/OmegaPre.v +++ b/test-suite/success/OmegaPre.v @@ -16,112 +16,112 @@ Open Scope Z_scope. Goal forall a:Z, Z.max a a = a. intros. -omega with *. +zify; omega. Qed. Goal forall a b:Z, Z.max a b = Z.max b a. intros. -omega with *. +zify; omega. Qed. Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c. intros. -omega with *. +zify; omega. Qed. Goal forall a b:Z, Z.max a b + Z.min a b = a + b. intros. -omega with *. +zify; omega. Qed. Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. intros. zify. -intuition; subst; omega. (* pure multiplication: omega alone can't do it *) +intuition; subst; zify; omega. (* pure multiplication: zify; omega alone can't do it *) Qed. Goal forall a:Z, Z.abs a = a -> a >= 0. intros. -omega with *. +zify; omega. Qed. Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1. intros. -omega with *. +zify; omega. Qed. (* zify_nat *) Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat. intros. -omega with *. +zify; omega. Qed. Goal forall m:nat, (m<1)%nat -> (m=0)%nat. intros. -omega with *. +zify; omega. Qed. Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat. intros. -omega with *. +zify; omega. Qed. (* 2000 instead of 200: works, but quite slow *) Goal forall m: nat, (m*m>=0)%nat. intros. -omega with *. +zify; omega. Qed. (* zify_positive *) Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive. intros. -omega with *. +zify; omega. Qed. Goal forall m:positive, (m<2)%positive -> (m=1)%positive. intros. -omega with *. +zify; omega. Qed. Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive. intros. -omega with *. +zify; omega. Qed. Goal forall m: positive, (m*m>=1)%positive. intros. -omega with *. +zify; omega. Qed. (* zify_N *) Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N. intros. -omega with *. +zify; omega. Qed. Goal forall m:N, (m<1)%N -> (m=0)%N. intros. -omega with *. +zify; omega. Qed. Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N. intros. -omega with *. +zify; omega. Qed. Goal forall m:N, (m*m>=0)%N. intros. -omega with *. +zify; omega. Qed. (* mix of datatypes *) Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p. intros. -omega with *. +zify; omega. Qed. diff --git a/test-suite/success/custom_entry.v b/test-suite/success/custom_entry.v new file mode 100644 index 0000000000..e88ae65e18 --- /dev/null +++ b/test-suite/success/custom_entry.v @@ -0,0 +1,13 @@ +Declare Custom Entry foo. + +Print Custom Grammar foo. + +Notation "[ e ]" := e (e custom foo at level 0). + +Print Custom Grammar foo. + +Notation "1" := O (in custom foo at level 0). + +Print Custom Grammar foo. + +Fail Declare Custom Entry foo. diff --git a/test-suite/success/rapply.v b/test-suite/success/rapply.v new file mode 100644 index 0000000000..13efd986f0 --- /dev/null +++ b/test-suite/success/rapply.v @@ -0,0 +1,27 @@ +Require Import Coq.Program.Tactics. + +(** We make a version of [rapply] that takes [uconstr]; we do not +currently test what scope [rapply] interprets terms in. *) + +Tactic Notation "urapply" uconstr(p) := rapply p. + +Ltac test n := + (*let __ := match goal with _ => idtac n end in*) + lazymatch n with + | O => let __ := match goal with _ => assert True by urapply I; clear end in + uconstr:(fun _ => I) + | S ?n' + => let lem := test n' in + let __ := match goal with _ => assert True by (unshelve urapply lem; try exact I); clear end in + uconstr:(fun _ : True => lem) + end. + +Goal True. + assert True by urapply I. + assert True by (unshelve urapply (fun _ => I); try exact I). + assert True by (unshelve urapply (fun _ _ => I); try exact I). + assert True by (unshelve urapply (fun _ _ _ => I); try exact I). + clear. + Time let __ := test 50 in idtac. + urapply I. +Qed. diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 9822b270ba..1c183930f9 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -62,7 +62,7 @@ the ML-like program for [induction_ltof2] is : *) Theorem induction_ltof1 : - forall P:A -> Set, + forall P:A -> Type, (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a. Proof. intros P F. @@ -75,21 +75,21 @@ Proof. Defined. Theorem induction_gtof1 : - forall P:A -> Set, + forall P:A -> Type, (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a. Proof. exact induction_ltof1. Defined. Theorem induction_ltof2 : - forall P:A -> Set, + forall P:A -> Type, (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a. Proof. - exact (well_founded_induction well_founded_ltof). + exact (well_founded_induction_type well_founded_ltof). Defined. Theorem induction_gtof2 : - forall P:A -> Set, + forall P:A -> Type, (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a. Proof. exact induction_ltof2. @@ -119,6 +119,18 @@ Proof. exact (well_founded_ltof nat (fun m => m)). Defined. +Lemma lt_wf_rect1 : + forall n (P:nat -> Type), (forall n, (forall m, m < n -> P m) -> P n) -> P n. +Proof. + exact (fun p P F => induction_ltof1 nat (fun m => m) P F p). +Defined. + +Lemma lt_wf_rect : + forall n (P:nat -> Type), (forall n, (forall m, m < n -> P m) -> P n) -> P n. +Proof. + exact (fun p P F => induction_ltof2 nat (fun m => m) P F p). +Defined. + Lemma lt_wf_rec1 : forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n. Proof. @@ -137,6 +149,12 @@ Proof. intro p; intros; elim (lt_wf p); auto with arith. Qed. +Lemma gt_wf_rect : + forall n (P:nat -> Type), (forall n, (forall m, n > m -> P m) -> P n) -> P n. +Proof. + exact lt_wf_rect. +Defined. + Lemma gt_wf_rec : forall n (P:nat -> Set), (forall n, (forall m, n > m -> P m) -> P n) -> P n. Proof. @@ -147,6 +165,16 @@ Lemma gt_wf_ind : forall n (P:nat -> Prop), (forall n, (forall m, n > m -> P m) -> P n) -> P n. Proof lt_wf_ind. +Lemma lt_wf_double_rect : + forall P:nat -> nat -> Type, + (forall n m, + (forall p q, p < n -> P p q) -> + (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m. +Proof. + intros P Hrec p; pattern p; apply lt_wf_rect. + intros n H q; pattern q; apply lt_wf_rect; auto with arith. +Defined. + Lemma lt_wf_double_rec : forall P:nat -> nat -> Set, (forall n m, 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 303acf7ae2..e3ff4979a9 100644 --- a/theories/MSets/MSetEqProperties.v +++ b/theories/MSets/MSetEqProperties.v @@ -18,6 +18,8 @@ [equal s s'=true] instead of [Equal s s'], etc. *) Require Import MSetProperties Zerob Sumbool Lia DecidableTypeEx. +Require FSetEqProperties. + Module WEqPropertiesOn (Import E:DecidableType)(M:WSetsOn E). Module Import MP := WPropertiesOn E M. @@ -857,7 +859,7 @@ 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 fset). lia. +intros. do 3 (rewrite fold_add by auto with fset). lia. do 3 rewrite fold_empty;auto. Qed. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index ba8e4dff6d..c8a100b0e7 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -61,12 +61,12 @@ Ltac destruct_pairs := repeat (destruct_one_pair). Ltac destruct_one_ex := let tac H := let ph := fresh "H" in (destruct H as [H ph]) in - let tac2 H := let ph := fresh "H" in let ph' := fresh "H" in - (destruct H as [H ph ph']) + let tac2 H := let ph := fresh "H" in let ph' := fresh "H" in + (destruct H as [H ph ph']) in let tacT H := let ph := fresh "X" in (destruct H as [H ph]) in - let tacT2 H := let ph := fresh "X" in let ph' := fresh "X" in - (destruct H as [H ph ph']) + let tacT2 H := let ph := fresh "X" in let ph' := fresh "X" in + (destruct H as [H ph ph']) in match goal with | [H : (ex _) |- _] => tac H @@ -140,7 +140,7 @@ Ltac clear_dups := repeat clear_dup. (** Try to clear everything except some hyp *) -Ltac clear_except hyp := +Ltac clear_except hyp := repeat match goal with [ H : _ |- _ ] => match H with | hyp => fail 1 @@ -173,22 +173,10 @@ Ltac on_application f tac T := (** A variant of [apply] using [refine], doing as much conversion as necessary. *) Ltac rapply p := - refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _) || - refine (p _ _ _ _ _) || - refine (p _ _ _ _) || - refine (p _ _ _) || - refine (p _ _) || - refine (p _) || - refine p. + (** before we try to add more underscores, first ensure that adding such underscores is valid *) + (assert_succeeds (idtac; let __ := open_constr:(p _) in idtac); + rapply uconstr:(p _)) + || refine p. (** Tactical [on_call f tac] applies [tac] on any application of [f] in the hypothesis or goal. *) 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/tools/CoqMakefile.in b/tools/CoqMakefile.in index 600494625b..d3ed5e78b4 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -637,7 +637,7 @@ $(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib $(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib $(SHOW)'CAMLOPT -a -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ $(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa diff --git a/vernac/attributes.ml b/vernac/attributes.ml index b7a3b002bd..68d2c3a00d 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -234,5 +234,7 @@ let only_polymorphism atts = parse polymorphic atts let vernac_polymorphic_flag = ukey, VernacFlagList ["polymorphic", VernacFlagEmpty] let vernac_monomorphic_flag = ukey, VernacFlagList ["monomorphic", VernacFlagEmpty] -let canonical = +let canonical_field = enable_attribute ~key:"canonical" ~default:(fun () -> true) +let canonical_instance = + enable_attribute ~key:"canonical" ~default:(fun () -> false) diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 34ff15ca7d..0074db66d3 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -48,7 +48,8 @@ val program : bool attribute val template : bool option attribute val locality : bool option attribute val deprecation : Deprecation.t option attribute -val canonical : bool attribute +val canonical_field : bool attribute +val canonical_instance : bool attribute val program_mode_option_name : string list (** For internal use when messing with the global option. *) diff --git a/vernac/canonical.ml b/vernac/canonical.ml index 141b02ef63..e41610b532 100644 --- a/vernac/canonical.ml +++ b/vernac/canonical.ml @@ -21,10 +21,12 @@ let cache_canonical_structure (_, (o,_)) = let sigma = Evd.from_env env in register_canonical_structure ~warn:true env sigma o -let discharge_canonical_structure (_,(x, local)) = - if local then None else Some (x, local) +let discharge_canonical_structure (_,((gref, _ as x), local)) = + if local || (Globnames.isVarRef gref && Lib.is_in_section gref) then None + else Some (x, local) -let inCanonStruc : (Constant.t * inductive) * bool -> obj = + +let inCanonStruc : (GlobRef.t * inductive) * bool -> obj = declare_object {(default_object "CANONICAL-STRUCTURE") with open_function = open_canonical_structure; cache_function = cache_canonical_structure; 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 a001420f74..625ffb5a06 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -32,7 +32,7 @@ let declare_variable is_coe ~kind typ imps impl {CAst.v=name} = let env = Global.env () in let sigma = Evd.from_env env in let () = Classes.declare_instance env sigma None true r in - let () = if is_coe then Class.try_add_new_coercion r ~local:true ~poly:false in + let () = if is_coe then ComCoercion.try_add_new_coercion r ~local:true ~poly:false in () let instance_of_univ_entry = function @@ -65,7 +65,7 @@ let declare_axiom is_coe ~poly ~local ~kind typ (univs, pl) imps nl {CAst.v=name | Declare.ImportNeedQualified -> true | Declare.ImportDefaultBehavior -> false in - let () = if is_coe then Class.try_add_new_coercion gr ~local ~poly in + let () = if is_coe then ComCoercion.try_add_new_coercion gr ~local ~poly in let inst = instance_of_univ_entry univs in (gr,inst) @@ -255,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/class.ml b/vernac/comCoercion.ml index 3c43b125d1..56ab6f289d 100644 --- a/vernac/class.ml +++ b/vernac/comCoercion.ml @@ -18,7 +18,7 @@ open Context open Vars open Termops open Environ -open Classops +open Coercionops open Declare open Libobject @@ -231,7 +231,7 @@ let check_source = function let cache_coercion (_,c) = let env = Global.env () in let sigma = Evd.from_env env in - Classops.declare_coercion env sigma c + Coercionops.declare_coercion env sigma c let open_coercion i o = if Int.equal i 1 then diff --git a/vernac/class.mli b/vernac/comCoercion.mli index 3254d5d981..f98ef4fdd6 100644 --- a/vernac/class.mli +++ b/vernac/comCoercion.mli @@ -9,7 +9,7 @@ (************************************************************************) open Names -open Classops +open Coercionops (** Classes and coercions. *) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 2aee9bd47f..8de1c69424 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,18 +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 ~ctor_levels 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 ~ctor_levels uctx params conclu in - not (template_check && Univ.LSet.is_empty conclunivs) + not (Univ.LSet.is_empty conclunivs) | Entries.Polymorphic_entry _ -> false let check_param = function @@ -350,33 +350,28 @@ 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 || let ctor_levels = @@ -390,7 +385,7 @@ let interp_mutual_inductive_constr ~env0 ~sigma ~template ~udecl ~env_ar ~env_pa List.fold_left (fun levels c -> add_levels c levels) param_levels ctypes in - template_polymorphism_candidate env0 ~ctor_levels uctx ctx_params concl + 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 -> @@ -408,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; @@ -417,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 @@ -492,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 @@ -505,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) @@ -559,7 +553,7 @@ let do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind ~uni (* Declare the possible notations of inductive types *) List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns; (* Declare the coercions *) - List.iter (fun qid -> Class.try_add_new_coercion (Nametab.locate qid) ~local:false ~poly) coes + List.iter (fun qid -> ComCoercion.try_add_new_coercion (Nametab.locate qid) ~local:false ~poly) coes (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index ef05b213d8..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 *) @@ -78,17 +76,17 @@ val should_auto_template : Id.t -> bool -> bool inductive under consideration. *) val template_polymorphism_candidate - : Environ.env + : template_check:bool -> ctor_levels:Univ.LSet.t -> Entries.universes_entry -> Constr.rel_context -> Sorts.t option -> bool -(** [template_polymorphism_candidate env ~ctor_levels uctx params +(** [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 + 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/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..07656f9715 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 @@ -278,6 +278,10 @@ let find_custom_entry s = try (find_custom_entry constr_custom_entry sc, find_custom_entry pattern_custom_entry sp) with Not_found -> user_err Pp.(str "Undeclared custom entry: " ++ str s ++ str ".") +let exists_custom_entry s = match find_custom_entry s with +| _ -> true +| exception _ -> false + let locality_of_custom_entry s = String.Set.mem s !custom_entry_locality (* This computes the name of the level where to add a new rule *) @@ -347,12 +351,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 +373,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/egramcoq.mli b/vernac/egramcoq.mli index f879d51660..6768d24d5c 100644 --- a/vernac/egramcoq.mli +++ b/vernac/egramcoq.mli @@ -19,4 +19,7 @@ val extend_constr_grammar : Notation_gram.one_notation_grammar -> unit (** Add a term notation rule to the parsing system. *) val create_custom_entry : local:bool -> string -> unit + +val exists_custom_entry : string -> bool + val locality_of_custom_entry : string -> bool diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 436648c163..3302231fd1 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -471,7 +471,7 @@ GRAMMAR EXTEND Gram [ [ attr = LIST0 quoted_attributes ; bd = record_binder; rf_priority = OPT [ "|"; n = natural -> { n } ]; rf_notation = decl_notation -> { - let rf_canonical = attr |> List.flatten |> parse canonical in + let rf_canonical = attr |> List.flatten |> parse canonical_field in let rf_subclass, rf_decl = bd in rf_decl, { rf_subclass ; rf_priority ; rf_notation ; rf_canonical } } ] ] ; @@ -1026,7 +1026,8 @@ GRAMMAR EXTEND Gram | IDENT "Coercions" -> { PrintCoercions } | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr -> { PrintCoercionPaths (s,t) } - | IDENT "Canonical"; IDENT "Projections" -> { PrintCanonicalConversions } + | IDENT "Canonical"; IDENT "Projections"; qids = LIST0 smart_global + -> { PrintCanonicalConversions qids } | IDENT "Typing"; IDENT "Flags" -> { PrintTypingFlags } | IDENT "Tables" -> { PrintTables } | IDENT "Options" -> { PrintTables (* A Synonymous to Tables *) } diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 19ec0a3642..ba7ae5069b 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -297,6 +297,7 @@ let explain_unification_error env sigma p1 p2 = function strbrk " with term " ++ pr_leconstr_env env sigma rhs ++ strbrk " that would depend on itself"] | NotClean ((evk,args),env,c) -> + let env = make_all_name_different env sigma in [str "cannot instantiate " ++ quote (pr_existential_key sigma evk) ++ strbrk " because " ++ pr_leconstr_env env sigma c ++ strbrk " is not in its scope" ++ @@ -605,7 +606,7 @@ let rec explain_evar_kind env sigma evk ty = let explain_typeclass_resolution env sigma evi k = match Typeclasses.class_of_constr env sigma evi.evar_concl with | Some _ -> - let env = Evd.evar_filtered_env evi in + let env = Evd.evar_filtered_env env evi in fnl () ++ str "Could not find an instance for " ++ pr_leconstr_env env sigma evi.evar_concl ++ pr_trailing_ne_context_of env sigma @@ -622,7 +623,7 @@ let explain_placeholder_kind env sigma c e = let explain_unsolvable_implicit env sigma evk explain = let evi = Evarutil.nf_evar_info sigma (Evd.find_undefined sigma evk) in - let env = Evd.evar_filtered_env evi in + let env = Evd.evar_filtered_env env evi in let type_of_hole = pr_leconstr_env env sigma evi.evar_concl in let pe = pr_trailing_ne_context_of env sigma in strbrk "Cannot infer " ++ diff --git a/vernac/library.ml b/vernac/library.ml index 244424de6b..0f7e7d2aa0 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -430,6 +430,22 @@ let error_recursively_dependent_library dir = (* Security weakness: file might have been changed on disk between writing the content and computing the checksum... *) +let save_library_base f sum lib univs tasks proofs = + let ch = raw_extern_library f in + try + System.marshal_out_segment f ch (sum : seg_sum); + System.marshal_out_segment f ch (lib : seg_lib); + System.marshal_out_segment f ch (univs : seg_univ option); + System.marshal_out_segment f ch (tasks : 'tasks option); + System.marshal_out_segment f ch (proofs : seg_proofs); + close_out ch + with reraise -> + let reraise = CErrors.push reraise in + close_out ch; + Feedback.msg_warning (str "Removed file " ++ str f); + Sys.remove f; + iraise reraise + type ('document,'counters) todo_proofs = | ProofsTodoNone (* for .vo *) | ProofsTodoSomeEmpty of Future.UUIDSet.t (* for .vos *) @@ -454,18 +470,17 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = match todo_proofs with | ProofsTodoNone -> None, None | ProofsTodoSomeEmpty _except -> - None, - Some (Univ.ContextSet.empty,false) + None, Some (Univ.ContextSet.empty,false) | ProofsTodoSome (_except, tasks, rcbackup) -> - let tasks = - List.map Stateid.(fun (r,b) -> + let tasks = + List.map Stateid.(fun (r,b) -> try { r with uuid = Future.UUIDMap.find r.uuid f2t_map }, b with Not_found -> assert b; { r with uuid = -1 }, b) tasks in - Some (tasks,rcbackup), - Some (Univ.ContextSet.empty,false) - in - let sd = { + Some (tasks,rcbackup), + Some (Univ.ContextSet.empty,false) + in + let sd = { md_name = dir; md_deps = Array.of_list (current_deps ()); } in @@ -475,36 +490,15 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = } in if Array.exists (fun (d,_) -> DirPath.equal d dir) sd.md_deps then error_recursively_dependent_library dir; - (* Open the vo file and write the magic number *) - let f' = f in - let ch = raw_extern_library f' in - try - (* Writing vo payload *) - System.marshal_out_segment f' ch (sd : seg_sum); - System.marshal_out_segment f' ch (md : seg_lib); - System.marshal_out_segment f' ch (utab : seg_univ option); - System.marshal_out_segment f' ch (tasks : 'tasks option); - System.marshal_out_segment f' ch (opaque_table : seg_proofs); - close_out ch; - (* Writing native code files *) - if output_native_objects then - let fn = Filename.dirname f'^"/"^Nativecode.mod_uid_of_dirpath dir in - Nativelib.compile_library dir ast fn - with reraise -> - let reraise = CErrors.push reraise in - let () = Feedback.msg_warning (str "Removed file " ++ str f') in - let () = close_out ch in - let () = Sys.remove f' in - iraise reraise + (* Writing vo payload *) + save_library_base f sd md utab tasks opaque_table; + (* Writing native code files *) + if output_native_objects then + let fn = Filename.dirname f ^"/"^ Nativecode.mod_uid_of_dirpath dir in + Nativelib.compile_library dir ast fn let save_library_raw f sum lib univs proofs = - let ch = raw_extern_library f in - System.marshal_out_segment f ch (sum : seg_sum); - System.marshal_out_segment f ch (lib : seg_lib); - System.marshal_out_segment f ch (Some univs : seg_univ option); - System.marshal_out_segment f ch (None : 'tasks option); - System.marshal_out_segment f ch (proofs : seg_proofs); - close_out ch + save_library_base f sum lib (Some univs) None proofs module StringOrd = struct type t = string let compare = String.compare end module StringSet = Set.Make(StringOrd) diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index e23522da9e..222e9eb825 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 @ @@ -1654,10 +1654,16 @@ let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing (**********************************************************************) (* Declaration of custom entry *) +let warn_custom_entry = + CWarnings.create ~name:"custom-entry-overriden" ~category:"parsing" + (fun s -> + strbrk "Custom entry " ++ str s ++ strbrk " has been overriden.") + let load_custom_entry _ _ = () let open_custom_entry _ (_,(local,s)) = - Egramcoq.create_custom_entry ~local s + if Egramcoq.exists_custom_entry s then warn_custom_entry s + else Egramcoq.create_custom_entry ~local s let cache_custom_entry o = load_custom_entry 1 o; @@ -1677,4 +1683,7 @@ let inCustomEntry : locality_flag * string -> obj = classify_function = classify_custom_entry} let declare_custom_entry local s = - Lib.add_anonymous_leaf (inCustomEntry (local,s)) + if Egramcoq.exists_custom_entry s then + user_err Pp.(str "Custom entry " ++ str s ++ str " already exists") + else + Lib.add_anonymous_leaf (inCustomEntry (local,s)) diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 1742027076..a1bd99c237 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -513,8 +513,8 @@ let string_of_theorem_kind = let open Decls in function keyword "Print Coercion Paths" ++ spc() ++ pr_class_rawexpr s ++ spc() ++ pr_class_rawexpr t - | PrintCanonicalConversions -> - keyword "Print Canonical Structures" + | PrintCanonicalConversions qids -> + keyword "Print Canonical Structures" ++ prlist pr_smart_global qids | PrintTypingFlags -> keyword "Print Typing Flags" | PrintTables -> diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index eb7b28f15b..b999ce9f3f 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -199,7 +199,7 @@ let print_opacity ref = (*******************) let print_if_is_coercion ref = - if Classops.coercion_exists ref then [pr_global ref ++ str " is a coercion"] else [] + if Coercionops.coercion_exists ref then [pr_global ref ++ str " is a coercion"] else [] (*******************) (* *) @@ -951,7 +951,7 @@ let inspect env sigma depth = (*************************************************************************) (* Pretty-printing functions coming from classops.ml *) -open Classops +open Coercionops let print_coercion_value v = Printer.pr_global v.coe_value @@ -965,7 +965,7 @@ let print_path ((i,j),p) = str"] : ") ++ print_class i ++ str" >-> " ++ print_class j -let _ = Classops.install_path_printer print_path +let _ = Coercionops.install_path_printer print_path let print_graph () = prlist_with_sep fnl print_path (inheritance_graph()) @@ -996,12 +996,24 @@ let print_path_between cls clt = in print_path ((i,j),p) -let print_canonical_projections env sigma = +let print_canonical_projections env sigma grefs = + let match_proj_gref ((x,y),c) gr = + GlobRef.equal x gr || + begin match y with + | Const_cs y -> GlobRef.equal y gr + | _ -> false + end || + GlobRef.equal c.o_ORIGIN gr + in + let projs = + List.filter (fun p -> List.for_all (match_proj_gref p) grefs) + (canonical_projections ()) + in prlist_with_sep fnl (fun ((r1,r2),o) -> pr_cs_pattern r2 ++ str " <- " ++ pr_global r1 ++ str " ( " ++ pr_lconstr_env env sigma o.o_DEF ++ str " )") - (canonical_projections ()) + projs (*************************************************************************) diff --git a/vernac/prettyp.mli b/vernac/prettyp.mli index dc4280f286..ac41f30c5d 100644 --- a/vernac/prettyp.mli +++ b/vernac/prettyp.mli @@ -52,8 +52,8 @@ val print_impargs : qualid Constrexpr.or_by_notation -> Pp.t val print_graph : unit -> Pp.t val print_classes : unit -> Pp.t val print_coercions : unit -> Pp.t -val print_path_between : Classops.cl_typ -> Classops.cl_typ -> Pp.t -val print_canonical_projections : env -> Evd.evar_map -> Pp.t +val print_path_between : Coercionops.cl_typ -> Coercionops.cl_typ -> Pp.t +val print_canonical_projections : env -> Evd.evar_map -> GlobRef.t list -> Pp.t (** Pretty-printing functions for type classes and instances *) val print_typeclasses : unit -> Pp.t diff --git a/vernac/record.ml b/vernac/record.ml index d85b71df44..df9b4a0914 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 @@ -366,8 +366,8 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f let refi = GlobRef.ConstRef kn in Impargs.maybe_declare_manual_implicits false refi impls; if flags.pf_subclass then begin - let cl = Class.class_of_global (GlobRef.IndRef indsp) in - Class.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl + let cl = ComCoercion.class_of_global (GlobRef.IndRef indsp) in + ComCoercion.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl end; let i = if is_local_assum decl then i+1 else i in (Some kn::sp_projs, i, Projection term::subst) @@ -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 -> @@ -447,7 +446,8 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa univs) param_levels fields in - ComInductive.template_polymorphism_candidate (Global.env ()) ~ctor_levels univs params + 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 @@ -477,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 @@ -490,7 +489,7 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa let cstr = (rsp, 1) in let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers fieldimpls fields in let build = GlobRef.ConstructRef cstr in - let () = if is_coe then Class.try_add_new_coercion build ~local:false ~poly in + let () = if is_coe then ComCoercion.try_add_new_coercion build ~local:false ~poly in let () = declare_structure_entry (cstr, List.rev kinds, List.rev sp_projs) in rsp in diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 5226c2ba65..7b4924eaed 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -21,7 +21,7 @@ RecLemmas Library Prettyp Lemmas -Class +ComCoercion Auto_ind_decl Search Indschemes diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index e4965614d8..e98820bc98 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -49,9 +49,9 @@ let get_goal_or_global_context ~pstate glnum = | Some p -> Pfedit.get_goal_context p glnum let cl_of_qualid = function - | FunClass -> Classops.CL_FUN - | SortClass -> Classops.CL_SORT - | RefClass r -> Class.class_of_global (Smartlocate.smart_global ~head:true r) + | FunClass -> Coercionops.CL_FUN + | SortClass -> Coercionops.CL_SORT + | RefClass r -> ComCoercion.class_of_global (Smartlocate.smart_global ~head:true r) let scope_class_of_qualid qid = Notation.scope_class_of_class (cl_of_qualid qid) @@ -63,14 +63,15 @@ module DefAttributes = struct polymorphic : bool; program : bool; deprecated : Deprecation.t option; + canonical_instance : bool; } let parse f = let open Attributes in - let ((locality, deprecated), polymorphic), program = - parse Notations.(locality ++ deprecation ++ polymorphic ++ program) f + let (((locality, deprecated), polymorphic), program), canonical_instance = + parse Notations.(locality ++ deprecation ++ polymorphic ++ program ++ canonical_instance) f in - { polymorphic; program; locality; deprecated } + { polymorphic; program; locality; deprecated; canonical_instance } end let module_locality = Attributes.Notations.(locality >>= fun l -> return (make_module_locality l)) @@ -474,7 +475,7 @@ let program_inference_hook env sigma ev = let tac = !Obligations.default_tactic in let evi = Evd.find sigma ev in let evi = Evarutil.nf_evar_info sigma evi in - let env = Evd.evar_filtered_env evi in + let env = Evd.evar_filtered_env env evi in try let concl = evi.Evd.evar_concl in if not (Evarutil.is_ground_env sigma env && @@ -522,13 +523,17 @@ 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 ~local ~poly = let open Decls in function +let vernac_definition_hook ~canonical_instance ~local ~poly = let open Decls in function | Coercion -> - Some (Class.add_coercion_hook ~poly) + Some (ComCoercion.add_coercion_hook ~poly) | CanonicalStructure -> Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure ?local dref))) | SubClass -> - Some (Class.add_subclass_hook ~poly) + Some (ComCoercion.add_subclass_hook ~poly) +| Definition when canonical_instance -> + Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure ?local dref))) +| Let when canonical_instance -> + Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure dref))) | _ -> None let fresh_name_for_anonymous_theorem () = @@ -551,7 +556,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 ~local:atts.locality ~poly:atts.polymorphic kind in + let hook = vernac_definition_hook ~canonical_instance:atts.canonical_instance ~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 +565,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 ~local:atts.locality ~poly:atts.polymorphic kind in + let hook = vernac_definition_hook ~canonical_instance:atts.canonical_instance ~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 @@ -1034,7 +1039,7 @@ let vernac_coercion ~atts ref qids qidt = let target = cl_of_qualid qidt in let source = cl_of_qualid qids in let ref' = smart_global ref in - Class.try_add_new_coercion_with_target ref' ~local ~poly ~source ~target; + ComCoercion.try_add_new_coercion_with_target ref' ~local ~poly ~source ~target; Flags.if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") let vernac_identity_coercion ~atts id qids qidt = @@ -1042,7 +1047,7 @@ let vernac_identity_coercion ~atts id qids qidt = let local = enforce_locality local in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in - Class.try_add_new_identity_coercion id ~local ~poly ~source ~target + ComCoercion.try_add_new_identity_coercion id ~local ~poly ~source ~target (* Type classes *) @@ -1621,7 +1626,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 @@ -1701,7 +1706,9 @@ let vernac_print ~pstate ~atts = | PrintCoercions -> Prettyp.print_coercions () | PrintCoercionPaths (cls,clt) -> Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt) - | PrintCanonicalConversions -> Prettyp.print_canonical_projections env sigma + | PrintCanonicalConversions qids -> + let grefs = List.map Smartlocate.smart_global qids in + Prettyp.print_canonical_projections env sigma grefs | PrintUniverses (sort, subgraph, dst) -> print_universes ~sort ~subgraph dst | PrintHint r -> Hints.pr_hint_ref env sigma (smart_global r) | PrintHintGoal -> diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 32ff8b8fb2..1daa244986 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -46,7 +46,7 @@ type printable = | PrintInstances of qualid or_by_notation | PrintCoercions | PrintCoercionPaths of class_rawexpr * class_rawexpr - | PrintCanonicalConversions + | PrintCanonicalConversions of qualid or_by_notation list | PrintUniverses of bool * qualid list option * string option | PrintHint of qualid or_by_notation | PrintHintGoal |
