diff options
224 files changed, 5299 insertions, 3603 deletions
diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md index c9cb516cd3..aec6cd0a21 100644 --- a/.github/ISSUE_TEMPLATE.md +++ b/.github/ISSUE_TEMPLATE.md @@ -1,18 +1,11 @@ -<!-- Thank you for your contribution. - Please complete the following information when reporting a bug. --> +<!-- Thank you for reporting a bug to Coq! --> -#### Version - -<!-- You can get this information by running `coqtop -v`. --> - - -#### Operating system +#### Description of the problem +<!-- If you can, it's helpful to provide self-contained example of some code +that reproduces the bug. If not, a link to a larger example is also helpful. --> -#### Description of the problem +#### Coq Version -<!-- It is helpful to provide enough information so that we can reproduce the bug. - In particular, please include a code example which produces it. - If the example is small, you can include it here between ``` ```. - Otherwise, please provide a link to a repository, a gist (https://gist.github.com) - or drag-and-drop a `.zip` archive. --> +<!-- You can get this information by running `coqtop -v`. If relevant, please +also include your operating system. --> diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e981c592a2..a6858c6802 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -288,16 +288,15 @@ pkg:opam: variables: OPAM_SWITCH: edge -pkg:nix: +.nix-template: &nix-template image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git stage: test variables: # By default we use coq.cachix.org as an extra substituter but this can be overridden EXTRA_SUBSTITUTERS: https://coq.cachix.org - EXTRA_PUBLIC_KEYS: coq.cachix.org-1:Jgt0DwGAUo+wpxCM52k2V+E0hLoOzFPzvg94F65agtI= + EXTRA_PUBLIC_KEYS: coq.cachix.org-1:5QW/wwEnD+l2jvN6QRbRRsa4hBHG3QiQQ26cxu1F5tI= # The following variables should not be overridden GIT_STRATEGY: none - CACHIX_PUBLIC_KEY: cachix.cachix.org-1:eWNHQldwUO7G2VkjpnjDbWwy4KQ/HNxht7H4SSoMckM= NIXOS_PUBLIC_KEY: cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= dependencies: [] # We don't need to download build artifacts @@ -305,8 +304,6 @@ pkg:nix: script: # Use current worktree as tmpdir to allow exporting artifacts in case of failure - export TMPDIR=$PWD - # Install Cachix as documented at https://github.com/cachix/cachix - - nix-env -if https://github.com/cachix/cachix/tarball/master --substituters https://cachix.cachix.org --trusted-public-keys "$CACHIX_PUBLIC_KEY" # We build an expression rather than a direct URL to not be dependent on # the URL location; we are forced to put the public key of cache.nixos.org # because there is no --extra-trusted-public-key option. @@ -317,6 +314,24 @@ pkg:nix: paths: - nix-build-coq.drv-0/*/test-suite/logs +pkg:nix:deploy: + <<: *nix-template + environment: + name: cachix + url: https://coq.cachix.org + before_script: + # Install Cachix as documented at https://github.com/cachix/cachix + - nix-env -iA cachix -f https://cachix.org/api/v1/install + only: + - master + - /^v.*\..*$/ + +pkg:nix: + <<: *nix-template + except: + - master + - /^v.*\..*$/ + doc:refman: <<: *doc-template dependencies: @@ -386,11 +401,11 @@ test-suite:edge+trunk+make: stage: test dependencies: [] script: - - opam switch create 4.08.0 --empty + - opam switch create 4.09.0 --empty - eval $(opam env) - - opam repo add ocaml-pr https://github.com/ocaml/ocaml-pr-repository.git + - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git - opam update - - opam install ocaml-variants=4.08.0 num + - opam install ocaml-variants=4.09.0+trunk num - eval $(opam env) # We avoid problems with warnings: - ./configure -profile devel -warn-error no @@ -410,18 +425,18 @@ test-suite:edge+trunk+dune: stage: test dependencies: [] script: - - opam switch create 4.08.0 --empty + - opam switch create 4.09.0 --empty - eval $(opam env) - - opam repo add ocaml-pr https://github.com/ocaml/ocaml-pr-repository.git + - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git - opam update - - opam install ocaml-variants=4.08.0 num + - opam install ocaml-variants=4.09.0+trunk num - opam pin add dune --dev # ounit lablgtk conf-gtksourceview - opam install dune - eval $(opam env) # We use the release profile to avoid problems with warnings - make -f Makefile.dune trunk - export COQ_UNIT_TEST=noop - - dune runtest --profile=ocaml408 + - dune runtest --profile=ocaml409 variables: OPAM_SWITCH: edge artifacts: diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 855d36048d..0000000000 --- a/.travis.yml +++ /dev/null @@ -1,116 +0,0 @@ -dist: trusty - -# Travis builds are slower using sudo: false (the container-based -# infrastructure) as of March 2017; see -# https://github.com/coq/coq/pull/467 for some discussion. -sudo: required - -# Until Ocaml becomes a language, we set a known one. -language: c - -cache: - directories: - - $HOME/.opam - -before_cache: - - rm -rf ~/.opam/log/ - -env: - global: - - NJOBS=2 - - COMPILER="4.07.0" - - DUNE_VER=".1.2.1" - - FINDLIB_VER=".1.8.0" - - LABLGTK="lablgtk.2.18.6 conf-gtksourceview.2" - - NATIVE_COMP="yes" - - COQ_DEST="-local" - - MAIN_TARGET="world" - -matrix: - include: - - os: osx - env: - - TEST_TARGET="test-suite" - - NATIVE_COMP="no" - - COQ_DEST="-local" - - EXTRA_OPAM="ounit" - before_install: - - brew update - - brew unlink python - - brew install gnu-time - # only way to continue using OPAM 1.2 - - brew install https://raw.githubusercontent.com/Homebrew/homebrew-core/d156edeeed7291f4bc1e08620b331bbd05d52b78/Formula/opam.rb - - opam init -j "$NJOBS" --compiler="$COMPILER" -n -y - - opam switch "$COMPILER" && opam update - - eval $(opam config env) - - opam config list - - opam install -j "$NJOBS" -y num ocamlfind${FINDLIB_VER} dune${DUNE_VER} ${EXTRA_OPAM} - - opam list - - - if: NOT (type = pull_request) - os: osx - osx_image: xcode7.3 - env: - - TEST_TARGET="" - - NATIVE_COMP="no" - - COQ_DEST="-prefix $PWD/_install_ci" - - EXTRA_CONF="-coqide opt -warn-error yes" - - EXTRA_OPAM="$LABLGTK" - before_install: - - brew update - - brew unlink python - - brew install gnu-time gtk+ expat gtksourceview gdk-pixbuf - # only way to continue using OPAM 1.2 - - brew install https://raw.githubusercontent.com/Homebrew/homebrew-core/d156edeeed7291f4bc1e08620b331bbd05d52b78/Formula/opam.rb - - brew unlink python@2 - - brew install python3 - - pip3 install macpack - - opam init -j "$NJOBS" --compiler="$COMPILER" -n -y - - opam switch "$COMPILER" && opam update - - eval $(opam config env) - - opam config list - - opam install -j "$NJOBS" -y num ocamlfind${FINDLIB_VER} dune${DUNE_VER} ${EXTRA_OPAM} - - opam list - before_deploy: - - dev/build/osx/make-macos-dmg.sh - deploy: - - provider: bintray - user: maximedenes - file: .bintray.json - key: - secure: "gUvXWwWR0gicDqsKOnBfe45taToSFied6gN8tCa5IOtl6E6gFoHoPZ83ZWXQsZP50oMDFS5eji0VQAFGEbOsGrTZaD9Y9Jnu34NND78SWL1tsJ6nHO3aCAoMpB0N3+oRuF6S+9HStU6KXWqgj+GeU4vZ4TOlG01RGctJa6U3vII=" - skip_cleanup: true - on: - all_branches: true - -before_install: -- if [ "$TRAVIS_PULL_REQUEST" != "false" ]; then echo "Tested commit (followed by parent commits):"; git log -1; for commit in `git log -1 --format="%P"`; do echo; git log -1 $commit; done; fi - -script: - -- set -e -- echo 'Testing make clean...' && echo -en 'travis_fold:start:coq.clean\\r' -- make clean # ensure that `make clean` works on a fresh clone -- echo -en 'travis_fold:end:coq.clean\\r' - -- echo 'Configuring Coq...' && echo -en 'travis_fold:start:coq.config\\r' -- ./configure $COQ_DEST -warn-error yes -native-compiler $NATIVE_COMP $EXTRA_CONF -- echo -en 'travis_fold:end:coq.config\\r' - -- echo 'Building Coq...' && echo -en 'travis_fold:start:coq.build\\r' -- make -j $NJOBS $MAIN_TARGET -- echo -en 'travis_fold:end:coq.build\\r' - -- echo 'Running tests...' && echo -en 'travis_fold:start:coq.test\\r' -- if [ -n "$TEST_TARGET" ]; then $TW make -j $NJOBS $TEST_TARGET; fi -- echo -en 'travis_fold:end:coq.test\\r' -- set +e - -# Testing Gitter webhook -notifications: - webhooks: - urls: - - https://webhooks.gitter.im/e/3cdabdec318214c7cd63 - on_success: change # options: [always|never|change] default: always - on_failure: always # options: [always|never|change] default: always - on_start: never # options: [always|never|change] default: always diff --git a/CHANGES.md b/CHANGES.md index bcdb951a94..9d912a63b1 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -22,6 +22,11 @@ Coqide Coqtop +- the use of `coqtop` as a compiler has been deprecated, in favor of + `coqc`. Consequently option `-compile` will stop to be accepted in + the next release. `coqtop` is now reserved to interactive + use. (@ejgallego #9095) + - new option -topfile filename, which will set the current module name (à la -top) based on the filename passed, taking into account the proper -R/-Q options. For example, given -R Foo foolib using @@ -49,6 +54,9 @@ Notations - New command `String Notation` to register string syntax for custom inductive types. +- Various bugs have been fixed (e.g. PR #9214 on removing spurious + parentheses on abbreviations shortening a strict prefix of an application). + Plugins - The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) @@ -75,6 +83,14 @@ Tactics foo : database`). When the database name is omitted, the hint is added to the core database (as previously), but a deprecation warning is emitted. +- There are now tactics in `PreOmega.v` called + `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and + `Z.to_euclidean_division_equations` (which combines the `div_mod` + and `quot_rem` variants) which allow `lia`, `nia`, `romega`, etc to + support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), + by posing the specifying equation for `Z.div` and `Z.modulo` before + replacing them with atoms. + Vernacular commands - `Combined Scheme` can now work when inductive schemes are generated in sort @@ -101,6 +117,11 @@ Vernacular commands - Option `Refine Instance Mode` has been turned off by default, meaning that `Instance` no longer opens a proof when a body is provided. +- `Instance`, when no body is provided, now always opens a proof. This is a + breaking change, as instance of `Instance foo : C.` where `C` is a trivial + class will have to be changed into `Instance foo : C := {}.` or + `Instance foo : C. Proof. Qed.`. + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: @@ -161,12 +182,24 @@ Misc SSReflect - New intro patterns: - - temporary introduction: => + - - block introduction: => [^ prefix ] [^~ suffix ] - - fast introduction: => > - - tactics as views: => /ltac:mytac + - temporary introduction: `=> +` + - block introduction: `=> [^ prefix ] [^~ suffix ]` + - fast introduction: `=> >` + - tactics as views: `=> /ltac:mytac` + - replace hypothesis: `=> {}H` See the reference manual for the actual documentation. +- Clear discipline made consistent across the entire proof language. + Whenever a clear switch `{x..}` comes immediately before an existing proof + context entry (used as a view, as a rewrite rule or as name for a new + context entry) then such entry is cleared too. + + E.g. The following sentences are elaborated as follows (when H is an existing + proof context entry): + - `=> {x..} H` -> `=> {x..H} H` + - `=> {x..} /H` -> `=> /v {x..H}` + - `rewrite {x..} H` -> `rewrite E {x..H}` + Changes from 8.8.2 to 8.9+beta1 =============================== diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index de7fb9183c..bb0e388cdd 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -55,7 +55,7 @@ please add an entry to [`dev/doc/critical-bugs`](/dev/doc/critical-bugs). Don't be alarmed if the pull request process takes some time. It can take a few days to get feedback, approval on the final changes, and then a merge. Coq doesn't release new versions very frequently so it can take a few months for your change to land in a released version. That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. -Whitespace discipline (do not indent using tabs, no trailing spaces, text files end with newlines) is checked by Travis (using `git diff --check`). We ship a [`dev/tools/pre-commit`](/dev/tools/pre-commit) git hook which fixes these errors at commit time. `configure` automatically sets you up to use it, unless you already have a hook at `.git/hooks/pre-commit`. +Whitespace discipline (do not indent using tabs, no trailing spaces, text files end with newlines) is checked by the `lint` job on GitLab CI (using `git diff --check`). We ship a [`dev/tools/pre-commit`](/dev/tools/pre-commit) git hook which fixes these errors at commit time. `configure` automatically sets you up to use it, unless you already have a hook at `.git/hooks/pre-commit`. Here are a few tags Coq developers may add to your PR and what they mean. In general feedback and requests for you as the pull request author will be in the comments and tags are only used to organize pull requests. @@ -113,9 +113,8 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). "./configure -help". The main options accepted are: -prefix <dir> - Binaries, library, man pages and Emacs mode will be respectively - installed in <dir>/bin, <dir>/lib/coq, <dir>/man and - <dir>/lib/emacs/site-lisp + 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 @@ -126,9 +125,6 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). -mandir <dir> (default: /usr/local/share/man) Directory where the Coq manual pages will be installed --emacslib <dir> (default: /usr/local/lib/emacs/site-lisp) - Directory where the Coq Emacs mode 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 @@ -175,9 +171,9 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). 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, manual pages - and emacs mode are copied in some standard places of your system, defined at - configuration time (step 3). Just do +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 @@ -82,7 +82,8 @@ export MLPACKFILES := $(call find, '*.mlpack') export MLGFILES := $(call find, '*.mlg') export CFILES := $(call findindir, 'kernel/byterun', '*.c') -MERLININFILES := $(call find, '.merlin.in') +# NB our find wrapper ignores the test suite +MERLININFILES := $(call find, '.merlin.in') test-suite/unit-tests/.merlin.in export MERLINFILES := $(MERLININFILES:.in=) # NB: The lists of currently existing .ml and .mli files will change diff --git a/Makefile.build b/Makefile.build index e683a6bda8..5775569712 100644 --- a/Makefile.build +++ b/Makefile.build @@ -198,7 +198,7 @@ TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) # TIME="%C (%U user, %S sys, %e total, %M maxres)" COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) -BOOTCOQC=$(TIMER) $(COQTOPBEST) -boot $(COQOPTS) -compile +BOOTCOQC=$(TIMER) $(COQC) -boot $(COQOPTS) LOCALINCLUDES=$(addprefix -I ,$(SRCDIRS)) MLINCLUDES=$(LOCALINCLUDES) @@ -281,7 +281,7 @@ ifndef ORDER_ONLY_SEP $(error This Makefile needs GNU Make 3.81 or later (that is a version that supports the order-only dependency feature without major bugs.)) endif -VO_TOOLS_DEP := $(COQTOPBEST) +VO_TOOLS_DEP := $(COQC) ifdef VALIDATE VO_TOOLS_DEP += $(CHICKEN) endif @@ -351,6 +351,9 @@ coqbyte: $(TOPBYTE) $(CHICKENBYTE) $(COQTOPEXE): $(TOPBINOPT:.opt=.$(BEST)) rm -f $@ && cp $< $@ +$(COQC): $(COQCOPT:.opt=.$(BEST)) + rm -f $@ && cp $< $@ + bin/%.opt$(EXE): topbin/%_bin.ml $(LINKCMX) $(LIBCOQRUN) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(OCAMLOPT) -linkall -linkpkg $(MLINCLUDES) \ @@ -377,17 +380,6 @@ $(COQTOPBYTE): $(LINKCMO) $(LIBCOQRUN) $(COQTOP_BYTE) $(SYSMOD) -package compiler-libs.toplevel \ $(LINKCMO) $(BYTEFLAGS) $(COQTOP_BYTE) -o $@ -# For coqc -COQCCMO:=config/config.cma clib/clib.cma lib/lib.cma toplevel/usage.cmo tools/coqc.cmo - -$(COQC): $(call bestobj, $(COQCCMO)) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, $(SYSMOD)) - -$(COQCBYTE): $(COQCCMO) - $(SHOW)'OCAMLC -o $@' - $(HIDE)$(call ocamlbyte, $(SYSMOD)) - ########################################################################### # other tools ########################################################################### @@ -784,8 +776,7 @@ $(PLUGMLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter plugins/%, $(MLLIBFILES) $( coqlib: theories plugins ifdef QUICK $(SHOW)'COQC -schedule-vio2vo $(NJOBS) theories/**.vio plugins/**.vio' - $(HIDE)$(BOOTCOQC:-compile=-schedule-vio2vo) $(NJOBS) \ - $(THEORIESVO) $(PLUGINSVO) + $(HIDE)$(BOOTCOQC) -schedule-vio2vo $(NJOBS) $(THEORIESVO) $(PLUGINSVO) endif coqlib.timing.diff: theories.timing.diff plugins.timing.diff diff --git a/Makefile.common b/Makefile.common index 2dced04967..f998ea867b 100644 --- a/Makefile.common +++ b/Makefile.common @@ -32,6 +32,7 @@ COQWCBYTE:=bin/coqwc.byte$(EXE) COQDOC:=bin/coqdoc$(EXE) COQDOCBYTE:=bin/coqdoc.byte$(EXE) COQC:=bin/coqc$(EXE) +COQCOPT:=bin/coqc.opt$(EXE) COQCBYTE:=bin/coqc.byte$(EXE) COQWORKMGR:=bin/coqworkmgr$(EXE) COQWORKMGRBYTE:=bin/coqworkmgr.byte$(EXE) @@ -2,7 +2,6 @@ [![GitLab][gitlab-badge]][gitlab-link] [![Azure Pipelines][azure-badge]][azure-link] -[![Travis][travis-badge]][travis-link] [![Appveyor][appveyor-badge]][appveyor-link] [![Gitter][gitter-badge]][gitter-link] [![DOI][doi-badge]][doi-link] @@ -13,9 +12,6 @@ [azure-badge]: https://dev.azure.com/coq/coq/_apis/build/status/coq.coq?branchName=master [azure-link]: https://dev.azure.com/coq/coq/_build/latest?definitionId=1?branchName=master -[travis-badge]: https://travis-ci.org/coq/coq.svg?branch=master -[travis-link]: https://travis-ci.org/coq/coq/builds - [appveyor-badge]: https://ci.appveyor.com/api/projects/status/eln43k05pa2vm908/branch/master?svg=true [appveyor-link]: https://ci.appveyor.com/project/coq/coq/branch/master diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index c823db956d..d2d1efcb2c 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -77,6 +77,9 @@ let check_arity env ar1 ar2 = match ar1, ar2 with (* template_level is inferred by indtypes, so functor application can produce a smaller one *) | (RegularArity _ | TemplateArity _), _ -> false +let check_kelim k1 k2 = + List.for_all (fun x -> List.mem_f Sorts.family_equal x k2) k1 + (* Use [eq_ind_chk] because when we rebuild the recargs we have lost the knowledge of who is the canonical version. Try with to see test-suite/coqchk/include.v *) @@ -102,7 +105,7 @@ let check_packet env mind ind check "mind_user_lc" (Array.equal Constr.equal ind.mind_user_lc mind_user_lc); check "mind_nrealargs" Int.(equal ind.mind_nrealargs mind_nrealargs); check "mind_nrealdecls" Int.(equal ind.mind_nrealdecls mind_nrealdecls); - check "mind_kelim" (List.equal Sorts.family_equal ind.mind_kelim mind_kelim); + check "mind_kelim" (check_kelim ind.mind_kelim mind_kelim); check "mind_nf_lc" (Array.equal Constr.equal ind.mind_nf_lc mind_nf_lc); (* NB: here syntactic equality is not just an optimisation, we also diff --git a/configure.ml b/configure.ml index 6f5ade3b9a..ef38651a4d 100644 --- a/configure.ml +++ b/configure.ml @@ -19,7 +19,7 @@ let vo_magic = 8991 let state_magic = 58991 let distributed_exec = ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; - "coqc";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep"] + "coqc.opt";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep"] let verbose = ref false (* for debugging this script *) diff --git a/default.nix b/default.nix index 89d69cc40f..b65d736d79 100644 --- a/default.nix +++ b/default.nix @@ -23,10 +23,10 @@ { pkgs ? (import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/958a6c6dd39b0d6628e1408e798a8f1308f2f3e1.tar.gz"; - sha256 = "0vs6k4jn0rbdfzaxmh3xh64q213326680i9g3cjgr7l9y6h6m5sy"; + url = "https://github.com/NixOS/nixpkgs/archive/11cf7d6e1ffd5fbc09a51b76d668ad0858a772ed.tar.gz"; + sha256 = "0zcg4mgfdk3ryiqj1j5iv5bljjvsgi6q6j9z1vkq383c4g4clc72"; }) {}) -, ocamlPackages ? pkgs.ocaml-ng.ocamlPackages_4_06 +, ocamlPackages ? pkgs.ocamlPackages , buildIde ? true , buildDoc ? true , doInstallCheck ? true diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 07a13b8204..2e934ff0c0 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -444,9 +444,6 @@ function load_overlay_data { else export CI_BRANCH="" export CI_PULL_REQUEST="" - # Used when building 8.8.0 with the latest scripts - export TRAVIS_BRANCH="" - export TRAVIS_PULL_REQUEST="" fi for overlay in /build/user-overlays/*.sh; do diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index 6663fbecf8..10b4f9b044 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -16,14 +16,12 @@ We are currently running tests on the following platforms: `./configure`. It should allow complying with this discipline without pain. -- Travis CI is used to test the compilation of Coq and run the test-suite on - macOS. - - AppVeyor is used to test the compilation of Coq and run the test-suite on Windows. - Azure Pipelines is used to test the compilation of Coq and run the - test-suite on Windows. It is expected to replace appveyor eventually. + test-suite on Windows and on macOS. It is expected to replace + appveyor eventually. You can anticipate the results of most of these tests prior to submitting your PR by running GitLab CI on your private branches. To do so follow these steps: diff --git a/dev/ci/ci-wrapper.sh b/dev/ci/ci-wrapper.sh index 12a70176c2..9ca8f76054 100755 --- a/dev/ci/ci-wrapper.sh +++ b/dev/ci/ci-wrapper.sh @@ -6,13 +6,6 @@ set -eo pipefail -function travis_fold { - if [ -n "${TRAVIS}" ]; - then - echo "travis_fold:$1:$2" - fi -} - CI_NAME="$1" CI_SCRIPT="ci-${CI_NAME}.sh" @@ -22,6 +15,5 @@ cd "${DIR}/../.." export TIMED=1 "${DIR}/${CI_SCRIPT}" 2>&1 | tee time-of-build.log -travis_fold 'start' 'coq.test.timing' && echo 'Aggregating timing log...' +echo 'Aggregating timing log...' python ./tools/make-one-time-file.py time-of-build.log -travis_fold 'end' 'coq.test.timing' diff --git a/dev/ci/user-overlays/09263-maximedenes-parsing-state.sh b/dev/ci/user-overlays/09263-maximedenes-parsing-state.sh new file mode 100644 index 0000000000..ebd1b524da --- /dev/null +++ b/dev/ci/user-overlays/09263-maximedenes-parsing-state.sh @@ -0,0 +1,12 @@ +if [ "$CI_PULL_REQUEST" = "9263" ] || [ "$CI_BRANCH" = "parsing-state" ]; then + + mtac2_CI_REF=proof-mode + mtac2_CI_GITURL=https://github.com/maximedenes/Mtac2 + + ltac2_CI_REF=proof-mode + ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 + + equations_CI_REF=proof-mode + equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations + +fi diff --git a/dev/doc/MERGING.md b/dev/doc/MERGING.md index 56fdab0c26..5705857d76 100644 --- a/dev/doc/MERGING.md +++ b/dev/doc/MERGING.md @@ -93,7 +93,7 @@ put the approriate label. Otherwise, they are expected to merge the PR using the 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 Travis or on AppVeyor, you should connect using your GitHub +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 diff --git a/dev/doc/profiling.txt b/dev/doc/profiling.txt index 29e87df6b8..8455d13377 100644 --- a/dev/doc/profiling.txt +++ b/dev/doc/profiling.txt @@ -10,7 +10,7 @@ In Coq source folder: opam switch 4.05.0+trunk+fp ./configure -local -debug make -perf record -g bin/coqtop -compile file.v +perf record -g bin/coqc file.v perf report -g fractal,callee --no-children To profile only part of a file, first load it using @@ -96,7 +96,7 @@ https://github.com/mshinwell/opam-repo-dev ### For memory dump: -CAMLRUNPARAM=T,mj bin/coqtop -compile file.v +CAMLRUNPARAM=T,mj bin/coqc file.v In another terminal: @@ -112,7 +112,7 @@ number of objects and third is the place where the objects where allocated. ### For complete memory graph: -CAMLRUNPARAM=T,gr bin/coqtop -compile file.v +CAMLRUNPARAM=T,gr bin/coqc file.v In another terminal: diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index b1c111685b..d05b6c8eef 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -4,37 +4,20 @@ - [ ] Create a new issue to track the release process where you can copy-paste the present checklist. -- [ ] Change the version name to the next major version and the magic numbers - (see [#7008](https://github.com/coq/coq/pull/7008/files)). -- [ ] Update the compatibility infrastructure, which consists of doing - the following steps. Note that all but the final step can be - performed automatically by - [`dev/tools/update-compat.py`](/dev/tools/update-compat.py) so - long as you have already updated `coq_version` in - [`configure.ml`](/configure.ml). - + [ ] Add a file `theories/Compat/CoqXX.v` which contains just the header - from [`dev/header.ml`](/dev/header.ml) - + [ ] Add the line `Require Export Coq.Compat.CoqXX.` at the top of - `theories/Compat/CoqYY.v`, where Y.Y is the version prior to X.X. - + [ ] Delete the file `theories/Compat/CoqWW.v`, where W.W is three versions - prior to X.X. - + [ ] Update - [`doc/stdlib/index-list.html.template`](/doc/stdlib/index-list.html.template) - with the deleted/added files. - + [ ] Remove any notations in the standard library which have `compat "W.W"`. - + [ ] Update the type `compat_version` in [`lib/flags.ml`](/lib/flags.ml) by - bumping all the version numbers by one, and update the interpretations - of those flags in [`toplevel/coqargs.ml`](/toplevel/coqargs.ml) and - [`vernac/g_vernac.mlg`](/vernac/g_vernac.mlg). - + [ ] Update the files - [`test-suite/success/CompatCurrentFlag.v`](/test-suite/success/CompatCurrentFlag.v), - [`test-suite/success/CompatPreviousFlag.v`](/test-suite/success/CompatPreviousFlag.v), - and - [`test-suite/success/CompatOldFlag.v`](/test-suite/success/CompatOldFlag.v) - by bumping all version numbers by 1. - + [ ] Decide what to do about all test-suite files which mention `-compat - W.W` or `Coq.Comapt.CoqWW` (which is no longer valid, since we only - keep compatibility against the two previous versions) +- [ ] Change the version name to the next major version and the magic + numbers (see [#7008](https://github.com/coq/coq/pull/7008/files)). + + Additionally, in the same commit, update the compatibility + infrastructure, which consists of invoking + [`dev/tools/update-compat.py`](../tools/update-compat.py) with the + `--master` flag. + + Note that the `update-compat.py` script must be run twice: once + *immediately after* branching with the `--master` flag (which sets + up Coq to support four `-compat` flag arguments), *in the same + commit* as the one that updates `coq_version` in + [`configure.ml`](../../configure.ml), and once again later on before + the next branch point with the `--release` flag (see next section). - [ ] Put the corresponding alpha tag using `git tag -s`. The `VX.X+alpha` tag marks the first commit to be in `master` and not in the branch of the previous version. @@ -43,6 +26,19 @@ release date) and put this information in the milestone (using the description and due date fields). +## Anytime after the previous version is branched off master ## + +- [ ] Update the compatibility infrastructure to the next release, + which consists of invoking + [`dev/tools/update-compat.py`](../tools/update-compat.py) with the + `--release` flag; this sets up Coq to support three `-compat` flag + arguments. To ensure that CI passes, you will have to decide what + to do about all test-suite files which mention `-compat U.U` or + `Coq.Comapt.CoqUU` (which is no longer valid, since we only keep + compatibility against the two previous versions on releases), and + you may have to prepare overlays for projects using the + compatibility flags. + ## About one month before the beta ## - [ ] Create the `X.X.0` milestone and set its due date. diff --git a/dev/doc/versions-history.tex b/dev/doc/versions-history.tex index 8f9c3171da..1c4913d201 100644 --- a/dev/doc/versions-history.tex +++ b/dev/doc/versions-history.tex @@ -271,7 +271,7 @@ Coq ``V7'' archive & August 1999 & new cvs archive based on J.-C. Filliâtre's \ & & \feature{kernel-centric} architecture \\ & & more care for outside readers\\ & & (indentation, ocaml warning protection)\\ -Coq V7.0beta& released 27 December 2000 & \feature{${\cal L}_{\mathit{tac}}$} \\ +Coq V7.0beta& released 27 December 2000 & \feature{${\mathcal{L}}_{\mathit{tac}}$} \\ Coq V7.0beta2& released 2 February 2001\\ Coq V7.0& released 25 April 2001 & \feature{extraction} (version 2) [6-2-2001] \\ diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh index a27dacc5a7..72e2930386 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -143,7 +143,7 @@ fi # Sanity check: PR has an outdated version of CI BASE_COMMIT=$(echo "$PRDATA" | jq -r '.base.sha') -CI_FILES=(".travis.yml" ".gitlab-ci.yml" "appveyor.yml") +CI_FILES=(".gitlab-ci.yml" "appveyor.yml") if ! git diff --quiet "$BASE_COMMIT" "$LOCAL_BRANCH_COMMIT" -- "${CI_FILES[@]}" then diff --git a/dev/tools/update-compat.py b/dev/tools/update-compat.py index 14094553a2..ff9b32fe78 100755 --- a/dev/tools/update-compat.py +++ b/dev/tools/update-compat.py @@ -1,6 +1,60 @@ #!/usr/bin/env python from __future__ import with_statement -import os, re, sys +import os, re, sys, subprocess + +# When passed `--release`, this script sets up Coq to support three +# `-compat` flag arguments. If executed manually, this would consist +# of doing the following steps: +# +# - Delete the file `theories/Compat/CoqUU.v`, where U.U is four +# versions prior to the new version X.X. After this, there +# should be exactly three `theories/Compat/CoqNN.v` files. +# - Update +# [`doc/stdlib/index-list.html.template`](/doc/stdlib/index-list.html.template) +# with the deleted file. +# - Remove any notations in the standard library which have `compat "U.U"`. +# - Update the type `compat_version` in [`lib/flags.ml`](/lib/flags.ml) by +# bumping all the version numbers by one, and update the interpretations +# of those flags in [`toplevel/coqargs.ml`](/toplevel/coqargs.ml) and +# [`vernac/g_vernac.mlg`](/vernac/g_vernac.mlg). +# +# - Remove the file +# [`test-suite/success/CompatOldOldFlag.v`](/test-suite/success/CompatOldOldFlag.v). +# - Update +# [`test-suite/tools/update-compat/run.sh`](/test-suite/tools/update-compat/run.sh) +# to ensure that it passes `--release` to the `update-compat.py` +# script. + +# When passed the `--master` flag, this script sets up Coq to support +# four `-compat` flag arguments. If executed manually, this would +# consist of doing the following steps: +# +# - Add a file `theories/Compat/CoqXX.v` which contains just the header +# from [`dev/header.ml`](/dev/header.ml) +# - Add the line `Require Export Coq.Compat.CoqXX.` at the top of +# `theories/Compat/CoqYY.v`, where Y.Y is the version prior to X.X. +# - Update +# [`doc/stdlib/index-list.html.template`](/doc/stdlib/index-list.html.template) +# with the added file. +# - Update the type `compat_version` in [`lib/flags.ml`](/lib/flags.ml) by +# bumping all the version numbers by one, and update the interpretations +# of those flags in [`toplevel/coqargs.ml`](/toplevel/coqargs.ml) and +# [`vernac/g_vernac.mlg`](/vernac/g_vernac.mlg). +# - Update the files +# [`test-suite/success/CompatCurrentFlag.v`](/test-suite/success/CompatCurrentFlag.v), +# [`test-suite/success/CompatPreviousFlag.v`](/test-suite/success/CompatPreviousFlag.v), +# and +# [`test-suite/success/CompatOldFlag.v`](/test-suite/success/CompatOldFlag.v) +# by bumping all version numbers by 1. Re-create the file +# [`test-suite/success/CompatOldOldFlag.v`](/test-suite/success/CompatOldOldFlag.v) +# with its version numbers also bumped by 1 (file should have +# been removed before branching; see above). +# - Update +# [`test-suite/tools/update-compat/run.sh`](/test-suite/tools/update-compat/run.sh) +# to ensure that it passes `--master` to the `update-compat.py` +# script. + + # Obtain the absolute path of the script being run. By assuming that # the script lives in dev/tools/, and basing all calls on the path of @@ -11,6 +65,8 @@ ROOT_PATH = os.path.realpath(os.path.join(SCRIPT_PATH, '..', '..')) CONFIGURE_PATH = os.path.join(ROOT_PATH, 'configure.ml') HEADER_PATH = os.path.join(ROOT_PATH, 'dev', 'header.ml') DEFAULT_NUMBER_OF_OLD_VERSIONS = 2 +RELEASE_NUMBER_OF_OLD_VERSIONS = 2 +MASTER_NUMBER_OF_OLD_VERSIONS = 3 EXTRA_HEADER = '\n(** Compatibility file for making Coq act similar to Coq v%s *)\n' FLAGS_MLI_PATH = os.path.join(ROOT_PATH, 'lib', 'flags.mli') FLAGS_ML_PATH = os.path.join(ROOT_PATH, 'lib', 'flags.ml') @@ -18,18 +74,46 @@ COQARGS_ML_PATH = os.path.join(ROOT_PATH, 'toplevel', 'coqargs.ml') G_VERNAC_PATH = os.path.join(ROOT_PATH, 'vernac', 'g_vernac.mlg') DOC_INDEX_PATH = os.path.join(ROOT_PATH, 'doc', 'stdlib', 'index-list.html.template') BUG_4798_PATH = os.path.join(ROOT_PATH, 'test-suite', 'bugs', 'closed', 'bug_4798.v') +BUG_9166_PATH = os.path.join(ROOT_PATH, 'test-suite', 'bugs', 'closed', 'bug_9166.v') +TEST_SUITE_RUN_PATH = os.path.join(ROOT_PATH, 'test-suite', 'tools', 'update-compat', 'run.sh') TEST_SUITE_PATHS = tuple(os.path.join(ROOT_PATH, 'test-suite', 'success', i) for i in ('CompatOldOldFlag.v', 'CompatOldFlag.v', 'CompatPreviousFlag.v', 'CompatCurrentFlag.v')) TEST_SUITE_DESCRIPTIONS = ('current-minus-three', 'current-minus-two', 'current-minus-one', 'current') # sanity check that we are where we think we are assert(os.path.normpath(os.path.realpath(SCRIPT_PATH)) == os.path.normpath(os.path.realpath(os.path.join(ROOT_PATH, 'dev', 'tools')))) assert(os.path.exists(CONFIGURE_PATH)) +BUG_HEADER = r"""(* DO NOT MODIFY THIS FILE DIRECTLY *) +(* It is autogenerated by %s. *) +""" % os.path.relpath(os.path.realpath(__file__), ROOT_PATH) def get_header(): with open(HEADER_PATH, 'r') as f: return f.read() HEADER = get_header() +def break_or_continue(): + msg = 'Press ENTER to continue, or Ctrl+C to break...' + try: + raw_input(msg) + except NameError: # we must be running python3 + input(msg) + +def maybe_git_add(local_path, suggest_add=True, **args): + if args['git_add']: + print("Running 'git add %s'..." % local_path) + retc = subprocess.call(['git', 'add', local_path], cwd=ROOT_PATH) + if retc is not None and retc != 0: + print('!!! Process returned code %d' % retc) + elif suggest_add: + print(r"!!! Don't forget to 'git add %s'!" % local_path) + +def maybe_git_rm(local_path, **args): + if args['git_add']: + print("Running 'git rm %s'..." % local_path) + retc = subprocess.call(['git', 'rm', local_path], cwd=ROOT_PATH) + if retc is not None and retc != 0: + print('!!! Process returned code %d' % retc) + def get_version(cur_version=None): if cur_version is not None: return cur_version with open(CONFIGURE_PATH, 'r') as f: @@ -72,11 +156,56 @@ def get_known_versions(): def get_new_versions(known_versions, **args): if args['cur_version'] in known_versions: assert(known_versions[-1] == args['cur_version']) - assert(len(known_versions) == args['number_of_compat_versions']) - return known_versions + known_versions = known_versions[:-1] assert(len(known_versions) >= args['number_of_old_versions']) return tuple(list(known_versions[-args['number_of_old_versions']:]) + [args['cur_version']]) +def print_diff(olds, news, numch=30): + for ch in range(min(len(olds), len(news))): + if olds[ch] != news[ch]: + print('Character %d differs:\nOld: %s\nNew: %s' % (ch, repr(olds[ch:][:numch]), repr(news[ch:][numch]))) + return + ch = min(len(olds), len(news)) + assert(len(olds) != len(news)) + print('Strings are different lengths:\nOld tail: %s\nNew tail: %s' % (repr(olds[ch:]), repr(news[ch:]))) + +def update_shebang_to_match(contents, new_contents, path): + contents_lines = contents.split('\n') + new_contents_lines = new_contents.split('\n') + if not (contents_lines[0].startswith('#!/') and contents_lines[0].endswith('bash')): + raise Exception('Unrecognized #! line in existing %s: %s' % (os.path.relpath(path, ROOT_PATH), repr(contents_lines[0]))) + if not (new_contents_lines[0].startswith('#!/') and new_contents_lines[0].endswith('bash')): + raise Exception('Unrecognized #! line in new %s: %s' % (os.path.relpath(path, ROOT_PATH), repr(new_contents_lines[0]))) + new_contents_lines[0] = contents_lines[0] + return '\n'.join(new_contents_lines) + +def update_if_changed(contents, new_contents, path, exn_string='%s changed!', suggest_add=False, pass_through_shebang=False, assert_unchanged=False, **args): + if contents is not None and pass_through_shebang: + new_contents = update_shebang_to_match(contents, new_contents, path) + if contents is None or contents != new_contents: + if not assert_unchanged: + print('Updating %s...' % os.path.relpath(path, ROOT_PATH)) + with open(path, 'w') as f: + f.write(new_contents) + maybe_git_add(os.path.relpath(path, ROOT_PATH), suggest_add=suggest_add, **args) + else: + if contents is not None: + print('Unexpected change:\nOld contents:\n%s\n\nNew contents:\n%s\n' % (contents, new_contents)) + print_diff(contents, new_contents) + raise Exception(exn_string % os.path.relpath(path, ROOT_PATH)) + +def remove_if_exists(path, exn_string='%s exists when it should not!', assert_unchanged=False, **args): + if os.path.exists(path): + if not assert_unchanged: + print('Removing %s...' % os.path.relpath(path, ROOT_PATH)) + os.remove(path) + maybe_git_rm(os.path.relpath(path, ROOT_PATH), **args) + else: + raise Exception(exn_string % os.path.relpath(path, ROOT_PATH)) + +def update_file(new_contents, path, **args): + update_if_changed(None, new_contents, path, **args) + def update_compat_files(old_versions, new_versions, assert_unchanged=False, **args): for v in old_versions: if v not in new_versions: @@ -85,6 +214,7 @@ def update_compat_files(old_versions, new_versions, assert_unchanged=False, **ar print('Removing %s...' % compat_file) compat_path = os.path.join(ROOT_PATH, compat_file) os.rename(compat_path, compat_path + '.bak') + maybe_git_rm(compat_file, **args) else: raise Exception('%s exists!' % compat_file) for v, next_v in zip(new_versions, list(new_versions[1:]) + [None]): @@ -95,12 +225,7 @@ def update_compat_files(old_versions, new_versions, assert_unchanged=False, **ar contents = HEADER + (EXTRA_HEADER % v) if next_v is not None: contents += '\nRequire Export Coq.Compat.%s.\n' % version_name_to_compat_name(next_v, ext='') - if not assert_unchanged: - with open(compat_path, 'w') as f: - f.write(contents) - print(r"Don't forget to 'git add %s'!" % compat_file) - else: - raise Exception('%s does not exist!' % compat_file) + update_file(contents, compat_path, exn_string='%s does not exist!', assert_unchanged=assert_unchanged, **args) else: # print('Checking %s...' % compat_file) with open(compat_path, 'r') as f: @@ -116,12 +241,7 @@ def update_compat_files(old_versions, new_versions, assert_unchanged=False, **ar if not contents.startswith(header + '\n'): contents = contents.replace(header, header + '\n') contents = contents.replace(header, '%s\n%s' % (header, line)) - if not assert_unchanged: - print('Updating %s...' % compat_file) - with open(compat_path, 'w') as f: - f.write(contents) - else: - raise Exception('Compat file %s is missing line %s' % (compat_file, line)) + update_file(contents, compat_path, exn_string=('Compat file %%s is missing line %s' % line), assert_unchanged=assert_unchanged, **args) def update_compat_versions_type_line(new_versions, contents, relpath): compat_version_string = ' | '.join(['V%s_%s' % tuple(v.split('.')) for v in new_versions[:-1]] + ['Current']) @@ -173,11 +293,18 @@ def update_add_compat_require(new_versions, contents, relpath): return new_contents def update_parse_compat_version(new_versions, contents, relpath, **args): - line_count = args['number_of_compat_versions']+2 # 1 for the first line, 1 for the invalid flags + line_count = 3 # 1 for the first line, 1 for the invalid flags, and 1 for Current first_line = 'let parse_compat_version = let open Flags in function' - old_function_lines = contents[contents.index(first_line):].split('\n')[:line_count] - if re.match(r'^ \| \([0-9 "\.\|]*\) as s ->$', old_function_lines[-1]) is None: - raise Exception('Could not recognize line %d of parse_compat_version in %s as a list of invalid versions' % (line_count, relpath)) + split_contents = contents[contents.index(first_line):].split('\n') + while True: + cur_line = split_contents[:line_count][-1] + if re.match(r'^ \| \([0-9 "\.\|]*\) as s ->$', cur_line) is not None: + break + elif re.match(r'^ \| "[0-9\.]*" -> V[0-9_]*$', cur_line) is not None: + line_count += 1 + else: + raise Exception('Could not recognize line %d of parse_compat_version in %s as a list of invalid versions (line was %s)' % (line_count, relpath, repr(cur_line))) + old_function_lines = split_contents[:line_count] all_versions = re.findall(r'"([0-9\.]+)"', ''.join(old_function_lines)) invalid_versions = tuple(i for i in all_versions if i not in new_versions) new_function_lines = [first_line] @@ -197,15 +324,6 @@ def check_no_old_versions(old_versions, new_versions, contents, relpath): if V in contents: raise Exception('Unreplaced usage of %s remaining in %s' % (V, relpath)) -def update_if_changed(contents, new_contents, path, assert_unchanged=False, **args): - if contents != new_contents: - if not assert_unchanged: - print('Updating %s...' % os.path.relpath(path, ROOT_PATH)) - with open(path, 'w') as f: - f.write(new_contents) - else: - raise Exception('%s changed!' % os.path.relpath(path, ROOT_PATH)) - def update_flags_mli(old_versions, new_versions, **args): with open(FLAGS_MLI_PATH, 'r') as f: contents = f.read() new_contents = update_compat_versions_type_line(new_versions, contents, os.path.relpath(FLAGS_MLI_PATH, ROOT_PATH)) @@ -238,21 +356,26 @@ def update_flags(old_versions, new_versions, **args): update_coqargs_ml(old_versions, new_versions, **args) update_g_vernac(old_versions, new_versions, **args) -def update_test_suite(new_versions, assert_unchanged=False, test_suite_paths=TEST_SUITE_PATHS, test_suite_descriptions=TEST_SUITE_DESCRIPTIONS, **args): +def update_test_suite(new_versions, assert_unchanged=False, test_suite_paths=TEST_SUITE_PATHS, test_suite_descriptions=TEST_SUITE_DESCRIPTIONS, test_suite_outdated_paths=tuple(), **args): assert(len(new_versions) == len(test_suite_paths)) assert(len(new_versions) == len(test_suite_descriptions)) for i, (v, path, descr) in enumerate(zip(new_versions, test_suite_paths, test_suite_descriptions)): - if not os.path.exists(path): - raise Exception('Could not find existing file %s' % os.path.relpath(path, ROOT_PATH)) + contents = None + suggest_add = False + if os.path.exists(path): + with open(path, 'r') as f: contents = f.read() + else: + suggest_add = True if '%s' in descr: descr = descr % v - with open(path, 'r') as f: contents = f.read() lines = ['(* -*- coq-prog-args: ("-compat" "%s") -*- *)' % v, '(** Check that the %s compatibility flag actually requires the relevant modules. *)' % descr] for imp_v in reversed(new_versions[i:]): lines.append('Import Coq.Compat.%s.' % version_name_to_compat_name(imp_v, ext='')) lines.append('') new_contents = '\n'.join(lines) - update_if_changed(contents, new_contents, path, **args) + update_if_changed(contents, new_contents, path, suggest_add=suggest_add, **args) + for path in test_suite_outdated_paths: + remove_if_exists(path, assert_unchanged=assert_unchanged, **args) def update_doc_index(new_versions, **args): with open(DOC_INDEX_PATH, 'r') as f: contents = f.read() @@ -264,17 +387,48 @@ def update_doc_index(new_versions, **args): new_contents = new_contents.replace(firstline, '\n'.join([firstline] + extra_lines)) update_if_changed(contents, new_contents, DOC_INDEX_PATH, **args) +def update_test_suite_run(**args): + with open(TEST_SUITE_RUN_PATH, 'r') as f: contents = f.read() + new_contents = r'''#!/usr/bin/env bash + +# allow running this script from any directory by basing things on where the script lives +SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" + +# we assume that the script lives in test-suite/tools/update-compat/, +# and that update-compat.py lives in dev/tools/ +cd "${SCRIPT_DIR}/../../.." +dev/tools/update-compat.py --assert-unchanged %s || exit $? +''' % ' '.join([('--master' if args['master'] else ''), ('--release' if args['release'] else '')]).strip() + update_if_changed(contents, new_contents, TEST_SUITE_RUN_PATH, pass_through_shebang=True, **args) + def update_bug_4789(new_versions, **args): # we always update this compat notation to oldest # currently-supported compat version, which should never be the # current version with open(BUG_4798_PATH, 'r') as f: contents = f.read() - new_contents = r"""Check match 2 with 0 => 0 | S n => n end. + new_contents = BUG_HEADER + r"""Check match 2 with 0 => 0 | S n => n end. Notation "|" := 1 (compat "%s"). Check match 2 with 0 => 0 | S n => n end. (* fails *) """ % new_versions[0] update_if_changed(contents, new_contents, BUG_4798_PATH, **args) +def update_bug_9166(new_versions, **args): + # we always update this compat notation to oldest + # currently-supported compat version, which should never be the + # current version + with open(BUG_9166_PATH, 'r') as f: contents = f.read() + new_contents = BUG_HEADER + r"""Set Warnings "+deprecated". + +Notation bar := option (compat "%s"). + +Definition foo (x: nat) : nat := + match x with + | 0 => 0 + | S bar => bar + end. +""" % new_versions[0] + update_if_changed(contents, new_contents, BUG_9166_PATH, **args) + def update_compat_notations_in(old_versions, new_versions, contents): for v in old_versions: if v not in new_versions: @@ -305,11 +459,26 @@ def parse_args(argv): args = { 'assert_unchanged': False, 'cur_version': None, - 'number_of_old_versions': DEFAULT_NUMBER_OF_OLD_VERSIONS + 'number_of_old_versions': None, + 'master': False, + 'release': False, + 'git_add': False, } + if '--master' not in argv and '--release' not in argv: + print(r'''WARNING: You should pass either --release (sometime before branching) + or --master (right after branching and updating the version number in version.ml)''') + if '--assert-unchanged' not in args: break_or_continue() for arg in argv[1:]: if arg == '--assert-unchanged': args['assert_unchanged'] = True + elif arg == '--git-add': + args['git_add'] = True + elif arg == '--master': + args['master'] = True + if args['number_of_old_versions'] is None: args['number_of_old_versions'] = MASTER_NUMBER_OF_OLD_VERSIONS + elif arg == '--release': + args['release'] = True + if args['number_of_old_versions'] is None: args['number_of_old_versions'] = RELEASE_NUMBER_OF_OLD_VERSIONS elif arg.startswith('--cur-version='): args['cur_version'] = arg[len('--cur-version='):] assert(len(args['cur_version'].split('.')) == 2) @@ -317,10 +486,11 @@ def parse_args(argv): elif arg.startswith('--number-of-old-versions='): args['number_of_old_versions'] = int(arg[len('--number-of-old-versions='):]) else: - print('USAGE: %s [--assert-unchanged] [--cur-version=NN.NN] [--number-of-old-versions=NN]' % argv[0]) + print('USAGE: %s [--assert-unchanged] [--cur-version=NN.NN] [--number-of-old-versions=NN] [--git-add]' % argv[0]) print('') print('ERROR: Unrecognized argument: %s' % arg) sys.exit(1) + if args['number_of_old_versions'] is None: args['number_of_old_versions'] = DEFAULT_NUMBER_OF_OLD_VERSIONS return args if __name__ == '__main__': @@ -331,11 +501,14 @@ if __name__ == '__main__': new_versions = get_new_versions(known_versions, **args) assert(len(TEST_SUITE_PATHS) >= args['number_of_compat_versions']) args['test_suite_paths'] = tuple(TEST_SUITE_PATHS[-args['number_of_compat_versions']:]) + args['test_suite_outdated_paths'] = tuple(TEST_SUITE_PATHS[:-args['number_of_compat_versions']]) args['test_suite_descriptions'] = tuple(TEST_SUITE_DESCRIPTIONS[-args['number_of_compat_versions']:]) update_compat_files(known_versions, new_versions, **args) update_flags(known_versions, new_versions, **args) update_test_suite(new_versions, **args) + update_test_suite_run(**args) update_doc_index(new_versions, **args) update_bug_4789(new_versions, **args) + update_bug_9166(new_versions, **args) update_compat_notations(known_versions, new_versions, **args) display_git_grep(known_versions, new_versions) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 6a28c5b3d1..927a912fbf 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -242,7 +242,7 @@ \newcommand{\vref}{\nterm{ref}} \newcommand{\zarithformula}{\nterm{zarith\_formula}} \newcommand{\zarith}{\nterm{zarith}} -\newcommand{\ltac}{\mbox{${\cal L}_{tac}$}} +\newcommand{\ltac}{\mbox{${\mathcal{L}}_{tac}$}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % \mbox{\sf } series for roman text in maths formulas % @@ -373,15 +373,15 @@ \newcommand{\sumbool}[2]{\{#1\}+\{#2\}} \newcommand{\myifthenelse}[3]{\kw{if} ~ #1 ~\kw{then} ~ #2 ~ \kw{else} ~ #3} \newcommand{\fun}[2]{\item[]{\tt {#1}}. \quad\\ #2} -\newcommand{\WF}[2]{\ensuremath{{\cal W\!F}(#1)[#2]}} -\newcommand{\WFTWOLINES}[2]{\ensuremath{{\cal W\!F}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}}} +\newcommand{\WF}[2]{\ensuremath{{\mathcal{W\!F}}(#1)[#2]}} +\newcommand{\WFTWOLINES}[2]{\ensuremath{{\mathcal{W\!F}}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}}} \newcommand{\WFE}[1]{\WF{E}{#1}} \newcommand{\WT}[4]{\ensuremath{#1[#2] \vdash #3 : #4}} \newcommand{\WTE}[3]{\WT{E}{#1}{#2}{#3}} \newcommand{\WTEG}[2]{\WTE{\Gamma}{#1}{#2}} \newcommand{\WTM}[3]{\WT{#1}{}{#2}{#3}} -\newcommand{\WFT}[2]{\ensuremath{#1[] \vdash {\cal W\!F}(#2)}} +\newcommand{\WFT}[2]{\ensuremath{#1[] \vdash {\mathcal{W\!F}}(#2)}} \newcommand{\WS}[3]{\ensuremath{#1[] \vdash #2 <: #3}} \newcommand{\WSE}[2]{\WS{E}{#1}{#2}} \newcommand{\WEV}[3]{\mbox{$#1[] \vdash #2 \lra #3$}} @@ -427,7 +427,7 @@ \newcommand{\letin}[3]{\kw{let}~#1:=#2~\kw{in}~#3} \newcommand{\subst}[3]{#1\{#2/#3\}} \newcommand{\substs}[4]{#1\{(#2/#3)_{#4}\}} -\newcommand{\Sort}{\mbox{$\cal S$}} +\newcommand{\Sort}{\mbox{$\mathcal{S}$}} \newcommand{\convert}{=_{\beta\delta\iota\zeta\eta}} \newcommand{\leconvert}{\leq_{\beta\delta\iota\zeta\eta}} \newcommand{\NN}{\mathbb{N}} diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index e799677c59..b076aac1ed 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -145,7 +145,7 @@ weakness, the :tacn:`lia` tactic is using recursively a combination of: + linear *positivstellensatz* refutations; + cutting plane proofs; + case split. - + Cutting plane proofs ~~~~~~~~~~~~~~~~~~~~~~ @@ -250,6 +250,16 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. .. [#] Support for :g:`nat` and :g:`N` is obtained by pre-processing the goal with the ``zify`` tactic. +.. [#] Support for :g:`Z.div` and :g:`Z.modulo` may be obtained by + pre-processing the goal with the ``Z.div_mod_to_equations`` tactic (you may + need to manually run ``zify`` first). +.. [#] Support for :g:`Z.quot` and :g:`Z.rem` may be obtained by pre-processing + the goal with the ``Z.quot_rem_to_equations`` tactic (you may need to manually + run ``zify`` first). +.. [#] Note that support for :g:`Z.div`, :g:`Z.modulo`, :g:`Z.quot`, and + :g:`Z.rem` may be simultaneously obtained by pre-processing the goal with the + ``Z.to_euclidean_division_equations`` tactic (you may need to manually run + ``zify`` first). .. [#] Sources and binaries can be found at https://projects.coin-or.org/Csdp .. [#] Variants deal with equalities and strict inequalities. .. [#] In practice, the oracle might fail to produce such a refutation. diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index 8b7214e2ab..903ee115c9 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -52,7 +52,7 @@ in interactive mode. It is not strictly mandatory in batch mode if it is not the first time the file is compiled and if the file itself did not change. When the proof does not begin with Proof using, the system records in an -auxiliary file, produced along with the `.vo` file, the list of section +auxiliary file, produced along with the ``.vo`` file, the list of section variables used. Automatic suggestion of proof annotations @@ -154,22 +154,22 @@ to a worker process. The threshold can be configured with Batch mode --------------- -When |Coq| is used as a batch compiler by running `coqc` or `coqtop` --compile, it produces a `.vo` file for each `.v` file. A `.vo` file contains, -among other things, theorem statements and proofs. Hence to produce a -.vo |Coq| need to process all the proofs of the `.v` file. +When |Coq| is used as a batch compiler by running ``coqc``, it produces +a ``.vo`` file for each ``.v`` file. A ``.vo`` file contains, among other +things, theorem statements and proofs. Hence to produce a .vo |Coq| +need to process all the proofs of the ``.v`` file. The asynchronous processing of proofs can decouple the generation of a -compiled file (like the `.vo` one) that can be loaded by ``Require`` from the +compiled file (like the ``.vo`` one) that can be loaded by ``Require`` from the generation and checking of the proof objects. The ``-quick`` flag can be -passed to `coqc` or `coqtop` to produce, quickly, `.vio` files. -Alternatively, when using a Makefile produced by `coq_makefile`, +passed to ``coqc`` or ``coqtop`` to produce, quickly, ``.vio`` files. +Alternatively, when using a Makefile produced by ``coq_makefile``, the ``quick`` target can be used to compile all files using the ``-quick`` flag. -A `.vio` file can be loaded using ``Require`` exactly as a `.vo` file but +A ``.vio`` file can be loaded using ``Require`` exactly as a ``.vo`` file but proofs will not be available (the Print command produces an error). Moreover, some universe constraints might be missing, so universes -inconsistencies might go unnoticed. A `.vio` file does not contain proof +inconsistencies might go unnoticed. A ``.vio`` file does not contain proof objects, but proof tasks, i.e. what a worker process can transform into a proof object. @@ -177,52 +177,52 @@ Compiling a set of files with the ``-quick`` flag allows one to work, interactively, on any file without waiting for all the proofs to be checked. -When working interactively, one can fully check all the `.v` files by -running `coqc` as usual. +When working interactively, one can fully check all the ``.v`` files by +running ``coqc`` as usual. -Alternatively one can turn each `.vio` into the corresponding `.vo`. All +Alternatively one can turn each ``.vio`` into the corresponding ``.vo``. All .vio files can be processed in parallel, hence this alternative might be faster. The command ``coqtop -schedule-vio2vo 2 a b c`` can be used to -obtain a good scheduling for two workers to produce `a.vo`, `b.vo`, and -`c.vo`. When using a Makefile produced by `coq_makefile`, the ``vio2vo`` target -can be used for that purpose. Variable `J` should be set to the number +obtain a good scheduling for two workers to produce ``a.vo``, ``b.vo``, and +``c.vo``. When using a Makefile produced by ``coq_makefile``, the ``vio2vo`` target +can be used for that purpose. Variable ``J`` should be set to the number of workers, e.g. ``make vio2vo J=2``. The only caveat is that, while the -.vo files obtained from `.vio` files are complete (they contain all proof +.vo files obtained from ``.vio`` files are complete (they contain all proof terms and universe constraints), the satisfiability of all universe constraints has not been checked globally (they are checked to be consistent for every single proof). Constraints will be checked when -these `.vo` files are (recursively) loaded with ``Require``. +these ``.vo`` files are (recursively) loaded with ``Require``. There is an extra, possibly even faster, alternative: just check the -proof tasks stored in `.vio` files without producing the `.vo` files. This +proof tasks stored in ``.vio`` files without producing the ``.vo`` files. This is possibly faster because all the proof tasks are independent, hence one can further partition the job to be done between workers. The ``coqtop -schedule-vio-checking 6 a b c`` command can be used to obtain a -good scheduling for 6 workers to check all the proof tasks of `a.vio`, -`b.vio`, and `c.vio`. Auxiliary files are used to predict how long a proof +good scheduling for 6 workers to check all the proof tasks of ``a.vio``, +``b.vio``, and ``c.vio``. Auxiliary files are used to predict how long a proof task will take, assuming it will take the same amount of time it took last time. When using a Makefile produced by coq_makefile, the -``checkproofs`` target can be used to check all `.vio` files. Variable `J` +``checkproofs`` target can be used to check all ``.vio`` files. Variable ``J`` should be set to the number of workers, e.g. ``make checkproofs J=6``. As -when converting `.vio` files to `.vo` files, universe constraints are not +when converting ``.vio`` files to ``.vo`` files, universe constraints are not checked to be globally consistent. Hence this compilation mode is only useful for quick regression testing and on developments not making -heavy use of the `Type` hierarchy. +heavy use of the ``Type`` hierarchy. Limiting the number of parallel workers -------------------------------------------- Many |Coq| processes may run on the same computer, and each of them may -start many additional worker processes. The `coqworkmgr` utility lets +start many additional worker processes. The ``coqworkmgr`` utility lets one limit the number of workers, globally. The utility accepts the ``-j`` argument to specify the maximum number of -workers (defaults to 2). `coqworkmgr` automatically starts in the +workers (defaults to 2). ``coqworkmgr`` automatically starts in the background and prints an environment variable assignment like ``COQWORKMGR_SOCKET=localhost:45634``. The user must set this variable in all the shells from which |Coq| processes will be started. If one uses just one terminal running the bash shell, then ``export ‘coqworkmgr -j 4‘`` will do the job. -After that, all |Coq| processes, e.g. `coqide` and `coqc`, will respect the +After that, all |Coq| processes, e.g. ``coqide`` and ``coqc``, will respect the limit, globally. diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 91504089a8..67683902cd 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -84,7 +84,7 @@ implemented using *algebraic universes*. An algebraic universe :math:`u` is either a variable (a qualified identifier with a number) or a successor of an algebraic universe (an expression :math:`u+1`), or an upper bound of algebraic universes (an -expression :math:`\max(u 1 ,...,u n )`), or the base universe (the expression +expression :math:`\max(u_1 ,...,u_n )`), or the base universe (the expression :math:`0`) which corresponds, in the arity of template polymorphic inductive types (see Section :ref:`well-formed-inductive-definitions`), @@ -117,18 +117,18 @@ the following rules. #. variables, hereafter ranged over by letters :math:`x`, :math:`y`, etc., are terms #. constants, hereafter ranged over by letters :math:`c`, :math:`d`, etc., are terms. #. if :math:`x` is a variable and :math:`T`, :math:`U` are terms then - :math:`∀ x:T,U` (:g:`forall x:T, U` in |Coq| concrete syntax) is a term. - If :math:`x` occurs in :math:`U`, :math:`∀ x:T,U` reads as + :math:`∀ x:T,~U` (:g:`forall x:T, U` in |Coq| concrete syntax) is a term. + If :math:`x` occurs in :math:`U`, :math:`∀ x:T,~U` reads as “for all :math:`x` of type :math:`T`, :math:`U`”. - As :math:`U` depends on :math:`x`, one says that :math:`∀ x:T,U` is + As :math:`U` depends on :math:`x`, one says that :math:`∀ x:T,~U` is a *dependent product*. If :math:`x` does not occur in :math:`U` then - :math:`∀ x:T,U` reads as + :math:`∀ x:T,~U` reads as “if :math:`T` then :math:`U`”. A *non dependent product* can be written: :math:`T \rightarrow U`. #. if :math:`x` is a variable and :math:`T`, :math:`u` are terms then - :math:`λ x:T . u` (:g:`fun x:T => u` + :math:`λ x:T .~u` (:g:`fun x:T => u` in |Coq| concrete syntax) is a term. This is a notation for the - λ-abstraction of λ-calculus :cite:`Bar81`. The term :math:`λ x:T . u` is a function + λ-abstraction of λ-calculus :cite:`Bar81`. The term :math:`λ x:T .~u` is a function which maps elements of :math:`T` to the expression :math:`u`. #. if :math:`t` and :math:`u` are terms then :math:`(t~u)` is a term (:g:`t u` in |Coq| concrete @@ -172,11 +172,11 @@ implicative proposition, to denote :math:`\nat →\Prop` which is the type of unary predicates over the natural numbers, etc. Let us assume that ``mult`` is a function of type :math:`\nat→\nat→\nat` and ``eqnat`` a -predicate of type \nat→\nat→ \Prop. The λ-abstraction can serve to build -“ordinary” functions as in :math:`λ x:\nat.(\kw{mult}~x~x)` (i.e. +predicate of type :math:`\nat→\nat→ \Prop`. The λ-abstraction can serve to build +“ordinary” functions as in :math:`λ x:\nat.~(\kw{mult}~x~x)` (i.e. :g:`fun x:nat => mult x x` in |Coq| notation) but may build also predicates over the natural -numbers. For instance :math:`λ x:\nat.(\kw{eqnat}~x~0)` +numbers. For instance :math:`λ x:\nat.~(\kw{eqnat}~x~0)` (i.e. :g:`fun x:nat => eqnat x 0` in |Coq| notation) will represent the predicate of one variable :math:`x` which asserts the equality of :math:`x` with :math:`0`. This predicate has type @@ -186,7 +186,7 @@ object :math:`P~t` of type :math:`\Prop`, namely a proposition. Furthermore :g:`forall x:nat, P x` will represent the type of functions which associate to each natural number :math:`n` an object of type :math:`(P~n)` and -consequently represent the type of proofs of the formula “:math:`∀ x. P(x`)”. +consequently represent the type of proofs of the formula “:math:`∀ x.~P(x)`”. .. _Typing-rules: @@ -206,7 +206,7 @@ A *local context* is an ordered list of *local declarations* of names which we call *variables*. The declaration of some variable :math:`x` is either a *local assumption*, written :math:`x:T` (:math:`T` is a type) or a *local definition*, written :math:`x:=t:T`. We use brackets to write local contexts. -A typical example is :math:`[x:T;y:=u:U;z:V]`. Notice that the variables +A typical example is :math:`[x:T;~y:=u:U;~z:V]`. Notice that the variables declared in a local context must be distinct. If :math:`Γ` is a local context that declares some :math:`x`, we write :math:`x ∈ Γ`. By writing :math:`(x:T) ∈ Γ` we mean that either :math:`x:T` is an @@ -232,9 +232,9 @@ A *global assumption* will be represented in the global environment as :math:`(c:T)` which assumes the name :math:`c` to be of some type :math:`T`. A *global definition* will be represented in the global environment as :math:`c:=t:T` which defines the name :math:`c` to have value :math:`t` and type :math:`T`. We shall call -such names *constants*. For the rest of the chapter, the :math:`E;c:T` denotes +such names *constants*. For the rest of the chapter, the :math:`E;~c:T` denotes the global environment :math:`E` enriched with the global assumption :math:`c:T`. -Similarly, :math:`E;c:=t:T` denotes the global environment :math:`E` enriched with the +Similarly, :math:`E;~c:=t:T` denotes the global environment :math:`E` enriched with the global definition :math:`(c:=t:T)`. The rules for inductive definitions (see Section @@ -284,14 +284,14 @@ following rules. s \in \Sort c \notin E ------------ - \WF{E;c:T}{} + \WF{E;~c:T}{} .. inference:: W-Global-Def \WTE{}{t}{T} c \notin E --------------- - \WF{E;c:=t:T}{} + \WF{E;~c:=t:T}{} .. inference:: Ax-Prop @@ -328,10 +328,10 @@ following rules. .. inference:: Prod-Prop \WTEG{T}{s} - s \in {\Sort} + s \in \Sort \WTE{\Gamma::(x:T)}{U}{\Prop} ----------------------------- - \WTEG{\forall~x:T,U}{\Prop} + \WTEG{∀ x:T,~U}{\Prop} .. inference:: Prod-Set @@ -339,25 +339,25 @@ following rules. s \in \{\Prop, \Set\} \WTE{\Gamma::(x:T)}{U}{\Set} ---------------------------- - \WTEG{\forall~x:T,U}{\Set} + \WTEG{∀ x:T,~U}{\Set} .. inference:: Prod-Type \WTEG{T}{\Type(i)} \WTE{\Gamma::(x:T)}{U}{\Type(i)} -------------------------------- - \WTEG{\forall~x:T,U}{\Type(i)} + \WTEG{∀ x:T,~U}{\Type(i)} .. inference:: Lam - \WTEG{\forall~x:T,U}{s} + \WTEG{∀ x:T,~U}{s} \WTE{\Gamma::(x:T)}{t}{U} ------------------------------------ - \WTEG{\lb x:T\mto t}{\forall x:T, U} + \WTEG{λ x:T\mto t}{∀ x:T,~U} .. inference:: App - \WTEG{t}{\forall~x:U,T} + \WTEG{t}{∀ x:U,~T} \WTEG{u}{U} ------------------------------ \WTEG{(t\ u)}{\subst{T}{x}{u}} @@ -406,7 +406,7 @@ can decide if two programs are *intentionally* equal (one says We want to be able to identify some terms as we can identify the application of a function to a given argument with its result. For -instance the identity function over a given type T can be written +instance the identity function over a given type :math:`T` can be written :math:`λx:T.~x`. In any global environment :math:`E` and local context :math:`Γ`, we want to identify any object :math:`a` (of type :math:`T`) with the application :math:`((λ x:T.~x)~a)`. We define for @@ -490,10 +490,10 @@ destroyed, this reduction differs from δ-reduction. It is called ~~~~~~~~~~~ Another important concept is η-expansion. It is legal to identify any -term :math:`t` of functional type :math:`∀ x:T, U` with its so-called η-expansion +term :math:`t` of functional type :math:`∀ x:T,~U` with its so-called η-expansion .. math:: - λx:T. (t~x) + λx:T.~(t~x) for :math:`x` an arbitrary variable name fresh in :math:`t`. @@ -503,26 +503,26 @@ for :math:`x` an arbitrary variable name fresh in :math:`t`. We deliberately do not define η-reduction: .. math:: - λ x:T. (t~x) \not\triangleright_η t + λ x:T.~(t~x)~\not\triangleright_η~t This is because, in general, the type of :math:`t` need not to be convertible - to the type of :math:`λ x:T. (t~x)`. E.g., if we take :math:`f` such that: + to the type of :math:`λ x:T.~(t~x)`. E.g., if we take :math:`f` such that: .. math:: - f : ∀ x:\Type(2),\Type(1) + f ~:~ ∀ x:\Type(2),~\Type(1) then .. math:: - λ x:\Type(1),(f~x) : ∀ x:\Type(1),\Type(1) + λ x:\Type(1).~(f~x) ~:~ ∀ x:\Type(1),~\Type(1) We could not allow .. math:: - λ x:Type(1),(f~x) \triangleright_η f + λ x:\Type(1).~(f~x) ~\triangleright_η~ f - because the type of the reduced term :math:`∀ x:\Type(2),\Type(1)` would not be - convertible to the type of the original term :math:`∀ x:\Type(1),\Type(1).` + because the type of the reduced term :math:`∀ x:\Type(2),~\Type(1)` would not be + convertible to the type of the original term :math:`∀ x:\Type(1),~\Type(1)`. .. _convertibility: @@ -541,9 +541,9 @@ global environment :math:`E` and local context :math:`Γ` iff there exist terms :math:`u_1` and :math:`u_2` such that :math:`E[Γ] ⊢ t_1 \triangleright … \triangleright u_1` and :math:`E[Γ] ⊢ t_2 \triangleright … \triangleright u_2` and either :math:`u_1` and :math:`u_2` are identical, or they are convertible up to η-expansion, -i.e. :math:`u_1` is :math:`λ x:T. u_1'` and :math:`u_2 x` is +i.e. :math:`u_1` is :math:`λ x:T.~u_1'` and :math:`u_2 x` is recursively convertible to :math:`u_1'` , or, symmetrically, -:math:`u_2` is :math:`λx:T. u_2'` +:math:`u_2` is :math:`λx:T.~u_2'` and :math:`u_1 x` is recursively convertible to :math:`u_2'`. We then write :math:`E[Γ] ⊢ t_1 =_{βδιζη} t_2` . @@ -601,8 +601,8 @@ Subtyping rules ------------------- At the moment, we did not take into account one rule between universes -which says that any term in a universe of index i is also a term in -the universe of index i+1 (this is the *cumulativity* rule of |Cic|). +which says that any term in a universe of index :math:`i` is also a term in +the universe of index :math:`i+1` (this is the *cumulativity* rule of |Cic|). This property extends the equivalence relation of convertibility into a *subtyping* relation inductively defined by: @@ -614,25 +614,25 @@ a *subtyping* relation inductively defined by: :math:`E[Γ] ⊢ \Prop ≤_{βδιζη} \Type(i)`, for any :math:`i` #. if :math:`E[Γ] ⊢ T =_{βδιζη} U` and :math:`E[Γ::(x:T)] ⊢ T' ≤_{βδιζη} U'` then - :math:`E[Γ] ⊢ ∀x:T, T′ ≤_{βδιζη} ∀ x:U, U′`. + :math:`E[Γ] ⊢ ∀x:T,~T′ ≤_{βδιζη} ∀ x:U,~U′`. #. if :math:`\ind{p}{Γ_I}{Γ_C}` is a universe polymorphic and cumulative (see Chapter :ref:`polymorphicuniverses`) inductive type (see below) and - :math:`(t : ∀Γ_P ,∀Γ_{\mathit{Arr}(t)}, \Sort)∈Γ_I` + :math:`(t : ∀Γ_P ,∀Γ_{\mathit{Arr}(t)}, S)∈Γ_I` and - :math:`(t' : ∀Γ_P' ,∀Γ_{\mathit{Arr}(t)}', \Sort')∈Γ_I` + :math:`(t' : ∀Γ_P' ,∀Γ_{\mathit{Arr}(t)}', S')∈Γ_I` are two different instances of *the same* inductive type (differing only in universe levels) with constructors .. math:: - [c_1 : ∀Γ_P ,∀ T_{1,1} … T_{1,n_1} ,~t~v_{1,1} … v_{1,m} ;…; - c_k : ∀Γ_P ,∀ T_{k,1} … T_{k,n_k} ,~t~v_{k,1} … v_{k,m} ] + [c_1 : ∀Γ_P ,∀ T_{1,1} … T_{1,n_1} ,~t~v_{1,1} … v_{1,m} ;~…;~ + c_k : ∀Γ_P ,∀ T_{k,1} … T_{k,n_k} ,~t~v_{k,1} … v_{k,m} ] and .. math:: - [c_1 : ∀Γ_P' ,∀ T_{1,1}' … T_{1,n_1}' ,~t'~v_{1,1}' … v_{1,m}' ;…; - c_k : ∀Γ_P' ,∀ T_{k,1}' … T_{k,n_k}' ,~t'~v_{k,1}' … v_{k,m}' ] + [c_1 : ∀Γ_P' ,∀ T_{1,1}' … T_{1,n_1}' ,~t'~v_{1,1}' … v_{1,m}' ;~…;~ + c_k : ∀Γ_P' ,∀ T_{k,1}' … T_{k,n_k}' ,~t'~v_{k,1}' … v_{k,m}' ] respectively then @@ -656,8 +656,8 @@ a *subtyping* relation inductively defined by: .. math:: E[Γ] ⊢ A_i ≤_{βδιζη} A_i' - where :math:`Γ_{\mathit{Arr}(t)} = [a_1 : A_1 ; … ; a_l : A_l ]` and - :math:`Γ_{\mathit{Arr}(t)}' = [a_1 : A_1'; … ; a_l : A_l']`. + where :math:`Γ_{\mathit{Arr}(t)} = [a_1 : A_1 ;~ … ;~a_l : A_l ]` and + :math:`Γ_{\mathit{Arr}(t)}' = [a_1 : A_1';~ … ;~a_l : A_l']`. The conversion rule up to subtyping is now exactly: @@ -677,19 +677,19 @@ The conversion rule up to subtyping is now exactly: form*. There are several ways (or strategies) to apply the reduction rules. Among them, we have to mention the *head reduction* which will play an important role (see Chapter :ref:`tactics`). Any term :math:`t` can be written as -:math:`λ x_1 :T_1 . … λ x_k :T_k . (t_0~t_1 … t_n )` where :math:`t_0` is not an +:math:`λ x_1 :T_1 .~… λ x_k :T_k .~(t_0~t_1 … t_n )` where :math:`t_0` is not an application. We say then that :math:`t_0` is the *head of* :math:`t`. If we assume -that :math:`t_0` is :math:`λ x:T. u_0` then one step of β-head reduction of :math:`t` is: +that :math:`t_0` is :math:`λ x:T.~u_0` then one step of β-head reduction of :math:`t` is: .. math:: - λ x_1 :T_1 . … λ x_k :T_k . (λ x:T. u_0~t_1 … t_n ) \triangleright - λ (x_1 :T_1 )…(x_k :T_k ). (\subst{u_0}{x}{t_1}~t_2 … t_n ) + λ x_1 :T_1 .~… λ x_k :T_k .~(λ x:T.~u_0~t_1 … t_n ) ~\triangleright~ + λ (x_1 :T_1 )…(x_k :T_k ).~(\subst{u_0}{x}{t_1}~t_2 … t_n ) Iterating the process of head reduction until the head of the reduced term is no more an abstraction leads to the *β-head normal form* of :math:`t`: .. math:: - t \triangleright … \triangleright λ x_1 :T_1 . …λ x_k :T_k . (v~u_1 … u_m ) + t \triangleright … \triangleright λ x_1 :T_1 .~…λ x_k :T_k .~(v~u_1 … u_m ) where :math:`v` is not an abstraction (nor an application). Note that the head normal form must not be confused with the normal form since some :math:`u_i` @@ -713,12 +713,12 @@ Formally, we can represent any *inductive definition* as These inductive definitions, together with global assumptions and global definitions, then form the global environment. Additionally, -for any :math:`p` there always exists :math:`Γ_P =[a_1 :A_1 ;…;a_p :A_p ]` such that +for any :math:`p` there always exists :math:`Γ_P =[a_1 :A_1 ;~…;~a_p :A_p ]` such that each :math:`T` in :math:`(t:T)∈Γ_I \cup Γ_C` can be written as: :math:`∀Γ_P , T'` where :math:`Γ_P` is called the *context of parameters*. Furthermore, we must have that each :math:`T` in :math:`(t:T)∈Γ_I` can be written as: :math:`∀Γ_P,∀Γ_{\mathit{Arr}(t)}, S` where -:math:`Γ_{\mathit{Arr}(t)}` is called the *Arity* of the inductive type t and :math:`S` is called -the sort of the inductive type t (not to be confused with :math:`\Sort` which is the set of sorts). +:math:`Γ_{\mathit{Arr}(t)}` is called the *Arity* of the inductive type :math:`t` and :math:`S` is called +the sort of the inductive type :math:`t` (not to be confused with :math:`\Sort` which is the set of sorts). .. example:: @@ -726,8 +726,8 @@ the sort of the inductive type t (not to be confused with :math:`\Sort` which is .. math:: \ind{1}{[\List:\Set→\Set]}{\left[\begin{array}{rcl} - \Nil & : & \forall A:\Set,\List~A \\ - \cons & : & \forall A:\Set, A→ \List~A→ \List~A + \Nil & : & ∀ A:\Set,~\List~A \\ + \cons & : & ∀ A:\Set,~A→ \List~A→ \List~A \end{array} \right]} @@ -771,8 +771,8 @@ the sort of the inductive type t (not to be confused with :math:`\Sort` which is \odd&:&\nat → \Prop \end{array}\right]} {\left[\begin{array}{rcl} \evenO &:& \even~0\\ - \evenS &:& \forall n, \odd~n → \even~(\nS~n)\\ - \oddS &:& \forall n, \even~n → \odd~(\nS~n) + \evenS &:& ∀ n,~\odd~n → \even~(\nS~n)\\ + \oddS &:& ∀ n,~\even~n → \odd~(\nS~n) \end{array}\right]} which corresponds to the result of the |Coq| declaration: @@ -792,7 +792,7 @@ the sort of the inductive type t (not to be confused with :math:`\Sort` which is Types of inductive objects ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have to give the type of constants in a global environment E which +We have to give the type of constants in a global environment :math:`E` which contains an inductive declaration. .. inference:: Ind @@ -821,8 +821,8 @@ contains an inductive declaration. E[Γ] ⊢ \even : \nat→\Prop\\ E[Γ] ⊢ \odd : \nat→\Prop\\ E[Γ] ⊢ \evenO : \even~\nO\\ - E[Γ] ⊢ \evenS : \forall~n:\nat,~\odd~n → \even~(\nS~n)\\ - E[Γ] ⊢ \oddS : \forall~n:\nat,~\even~n → \odd~(\nS~n) + E[Γ] ⊢ \evenS : ∀ n:\nat,~\odd~n → \even~(\nS~n)\\ + E[Γ] ⊢ \oddS : ∀ n:\nat,~\even~n → \odd~(\nS~n) \end{array} @@ -842,11 +842,11 @@ Arity of a given sort +++++++++++++++++++++ A type :math:`T` is an *arity of sort* :math:`s` if it converts to the sort :math:`s` or to a -product :math:`∀ x:T,U` with :math:`U` an arity of sort :math:`s`. +product :math:`∀ x:T,~U` with :math:`U` an arity of sort :math:`s`. .. example:: - :math:`A→\Set` is an arity of sort :math:`\Set`. :math:`∀ A:\Prop,A→ \Prop` is an arity of sort + :math:`A→\Set` is an arity of sort :math:`\Set`. :math:`∀ A:\Prop,~A→ \Prop` is an arity of sort :math:`\Prop`. @@ -858,21 +858,21 @@ sort :math:`s`. .. example:: - :math:`A→ Set` and :math:`∀ A:\Prop,A→ \Prop` are arities. + :math:`A→ \Set` and :math:`∀ A:\Prop,~A→ \Prop` are arities. Type of constructor +++++++++++++++++++ -We say that T is a *type of constructor of I* in one of the following +We say that :math:`T` is a *type of constructor of* :math:`I` in one of the following two cases: + :math:`T` is :math:`(I~t_1 … t_n )` -+ :math:`T` is :math:`∀ x:U,T'` where :math:`T'` is also a type of constructor of :math:`I` ++ :math:`T` is :math:`∀ x:U,~T'` where :math:`T'` is also a type of constructor of :math:`I` .. example:: :math:`\nat` and :math:`\nat→\nat` are types of constructor of :math:`\nat`. - :math:`∀ A:Type,\List~A` and :math:`∀ A:Type,A→\List~A→\List~A` are types of constructor of :math:`\List`. + :math:`∀ A:\Type,~\List~A` and :math:`∀ A:\Type,~A→\List~A→\List~A` are types of constructor of :math:`\List`. .. _positivity: @@ -883,7 +883,7 @@ The type of constructor :math:`T` will be said to *satisfy the positivity condition* for a constant :math:`X` in the following cases: + :math:`T=(X~t_1 … t_n )` and :math:`X` does not occur free in any :math:`t_i` -+ :math:`T=∀ x:U,V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` ++ :math:`T=∀ x:U,~V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` satisfies the positivity condition for :math:`X`. Strict positivity @@ -895,13 +895,13 @@ cases: + :math:`X` does not occur in :math:`T` + :math:`T` converts to :math:`(X~t_1 … t_n )` and :math:`X` does not occur in any of :math:`t_i` -+ :math:`T` converts to :math:`∀ x:U,V` and :math:`X` does not occur in type :math:`U` but occurs ++ :math:`T` converts to :math:`∀ x:U,~V` and :math:`X` does not occur in type :math:`U` but occurs strictly positively in type :math:`V` + :math:`T` converts to :math:`(I~a_1 … a_m~t_1 … t_p )` where :math:`I` is the name of an inductive declaration of the form .. math:: - \ind{m}{I:A}{c_1 :∀ p_1 :P_1 ,… ∀p_m :P_m ,C_1 ;…;c_n :∀ p_1 :P_1 ,… ∀p_m :P_m ,C_n} + \ind{m}{I:A}{c_1 :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_1 ;~…;~c_n :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_n} (in particular, it is not mutually defined and it has :math:`m` parameters) and :math:`X` does not occur in @@ -916,7 +916,7 @@ condition* for a constant :math:`X` in the following cases: + :math:`T=(I~b_1 … b_m~u_1 … u_p)`, :math:`I` is an inductive definition with :math:`m` parameters and :math:`X` does not occur in any :math:`u_i` -+ :math:`T=∀ x:U,V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` ++ :math:`T=∀ x:U,~V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` satisfies the nested positivity condition for :math:`X` @@ -930,7 +930,6 @@ condition* for a constant :math:`X` in the following cases: Inductive nattree (A:Type) : Type := | leaf : nattree A | node : A -> (nat -> nattree A) -> nattree A. - End TreeExample. Then every instantiated constructor of ``nattree A`` satisfies the nested positivity condition for ``nattree``: @@ -958,8 +957,8 @@ We shall now describe the rules allowing the introduction of a new inductive definition. Let :math:`E` be a global environment and :math:`Γ_P`, :math:`Γ_I`, :math:`Γ_C` be contexts -such that :math:`Γ_I` is :math:`[I_1 :∀ Γ_P ,A_1 ;…;I_k :∀ Γ_P ,A_k]`, and -:math:`Γ_C` is :math:`[c_1:∀ Γ_P ,C_1 ;…;c_n :∀ Γ_P ,C_n ]`. Then +such that :math:`Γ_I` is :math:`[I_1 :∀ Γ_P ,A_1 ;~…;~I_k :∀ Γ_P ,A_k]`, and +:math:`Γ_C` is :math:`[c_1:∀ Γ_P ,C_1 ;~…;~c_n :∀ Γ_P ,C_n ]`. Then .. inference:: W-Ind @@ -967,7 +966,7 @@ such that :math:`Γ_I` is :math:`[I_1 :∀ Γ_P ,A_1 ;…;I_k :∀ Γ_P ,A_k]`, (E[Γ_P ] ⊢ A_j : s_j )_{j=1… k} (E[Γ_I ;Γ_P ] ⊢ C_i : s_{q_i} )_{i=1… n} ------------------------------------------ - \WF{E;\ind{p}{Γ_I}{Γ_C}}{Γ} + \WF{E;~\ind{p}{Γ_I}{Γ_C}}{Γ} provided that the following side conditions hold: @@ -990,8 +989,8 @@ the Type hierarchy. .. example:: It is well known that the existential quantifier can be encoded as an - inductive definition. The following declaration introduces the second- - order existential quantifier :math:`∃ X.P(X)`. + inductive definition. The following declaration introduces the + second-order existential quantifier :math:`∃ X.P(X)`. .. coqtop:: in @@ -1028,7 +1027,7 @@ in :math:`\Type`. .. flag:: Auto Template Polymorphism This option, enabled by default, makes every inductive type declared - at level :math:`Type` (without annotations or hiding it behind a + at level :math:`\Type` (without annotations or hiding it behind a definition) template polymorphic. This can be prevented using the ``notemplate`` attribute. @@ -1055,9 +1054,9 @@ Calculus of Inductive Constructions. The following typing rule is added to the theory. Let :math:`\ind{p}{Γ_I}{Γ_C}` be an inductive definition. Let -:math:`Γ_P = [p_1 :P_1 ;…;p_p :P_p ]` be its context of parameters, -:math:`Γ_I = [I_1:∀ Γ_P ,A_1 ;…;I_k :∀ Γ_P ,A_k ]` its context of definitions and -:math:`Γ_C = [c_1 :∀ Γ_P ,C_1 ;…;c_n :∀ Γ_P ,C_n]` its context of constructors, +:math:`Γ_P = [p_1 :P_1 ;~…;~p_p :P_p ]` be its context of parameters, +:math:`Γ_I = [I_1:∀ Γ_P ,A_1 ;~…;~I_k :∀ Γ_P ,A_k ]` its context of definitions and +:math:`Γ_C = [c_1 :∀ Γ_P ,C_1 ;~…;~c_n :∀ Γ_P ,C_n]` its context of constructors, with :math:`c_i` a constructor of :math:`I_{q_i}`. Let :math:`m ≤ p` be the length of the longest prefix of parameters such that the :math:`m` first arguments of all occurrences of all :math:`I_j` in all :math:`C_k` (even the occurrences in the @@ -1077,15 +1076,15 @@ uniform parameters of :math:`Γ_P` . We have: \end{array} \right. ----------------------------- - E[] ⊢ I_j~q_1 … q_r :∀ [p_{r+1} :P_{r+1} ;…;p_p :P_p], (A_j)_{/s_j} + E[] ⊢ I_j~q_1 … q_r :∀ [p_{r+1} :P_{r+1} ;~…;~p_p :P_p], (A_j)_{/s_j} provided that the following side conditions hold: + :math:`Γ_{P′}` is the context obtained from :math:`Γ_P` by replacing each :math:`P_l` that is an arity with :math:`P_l'` for :math:`1≤ l ≤ r` (notice that :math:`P_l` arity implies :math:`P_l'` - arity since :math:`(E[] ⊢ P_l' ≤_{βδιζη} \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1} )`; + arity since :math:`E[] ⊢ P_l' ≤_{βδιζη} \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}`); + there are sorts :math:`s_i` , for :math:`1 ≤ i ≤ k` such that, for - :math:`Γ_{I'} = [I_1 :∀ Γ_{P'} ,(A_1)_{/s_1} ;…;I_k :∀ Γ_{P'} ,(A_k)_{/s_k}]` + :math:`Γ_{I'} = [I_1 :∀ Γ_{P'} ,(A_1)_{/s_1} ;~…;~I_k :∀ Γ_{P'} ,(A_k)_{/s_k}]` we have :math:`(E[Γ_{I′} ;Γ_{P′}] ⊢ C_i : s_{q_i})_{i=1… n}` ; + the sorts :math:`s_i` are such that all eliminations, to :math:`\Prop`, :math:`\Set` and :math:`\Type(j)`, are allowed @@ -1103,7 +1102,7 @@ replacements of sorts, needed for this derivation, in the parameters that are arities (this is possible because :math:`\ind{p}{Γ_I}{Γ_C}` well-formed implies that :math:`\ind{p}{Γ_{I'}}{Γ_{C'}}` is well-formed and has the same allowed eliminations, where :math:`Γ_{I′}` is defined as above and -:math:`Γ_{C′} = [c_1 :∀ Γ_{P′} ,C_1 ;…;c_n :∀ Γ_{P′} ,C_n ]`). That is, the changes in the +:math:`Γ_{C′} = [c_1 :∀ Γ_{P′} ,C_1 ;~…;~c_n :∀ Γ_{P′} ,C_n ]`). That is, the changes in the types of each partial instance :math:`q_1 … q_r` can be characterized by the ordered sets of arity sorts among the types of parameters, and to each signature is associated a new inductive definition with fresh names. @@ -1206,7 +1205,7 @@ recursion (even terminating). So the basic idea is to restrict ourselves to primitive recursive functions and functionals. For instance, assuming a parameter :math:`A:\Set` exists in the local context, -we want to build a function length of type :math:`\List~A → \nat` which computes +we want to build a function :math:`\length` of type :math:`\List~A → \nat` which computes the length of the list, such that :math:`(\length~(\Nil~A)) = \nO` and :math:`(\length~(\cons~A~a~l)) = (\nS~(\length~l))`. We want these equalities to be @@ -1232,7 +1231,7 @@ principles. For instance, in order to prove :math:`(\kw{has}\_\kw{length}~A~(\cons~A~a~l)~(\length~(\cons~A~a~l)))` -which given the conversion equalities satisfied by length is the same +which given the conversion equalities satisfied by :math:`\length` is the same as proving: @@ -1268,7 +1267,7 @@ The |Coq| term for this proof will be written: .. math:: - \Match~m~\with~(c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n \kwend + \Match~m~\with~(c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n~\kwend In this expression, if :math:`m` eventually happens to evaluate to :math:`(c_i~u_1 … u_{p_i})` then the expression will behave as specified in its :math:`i`-th branch @@ -1276,7 +1275,7 @@ and it will reduce to :math:`f_i` where the :math:`x_{i1} …x_{ip_i}` are repla :math:`u_1 … u_{p_i}` according to the ι-reduction. Actually, for type checking a :math:`\Match…\with…\kwend` expression we also need -to know the predicate P to be proved by case analysis. In the general +to know the predicate :math:`P` to be proved by case analysis. In the general case where :math:`I` is an inductively defined :math:`n`-ary relation, :math:`P` is a predicate over :math:`n+1` arguments: the :math:`n` first ones correspond to the arguments of :math:`I` (parameters excluded), and the last one corresponds to object :math:`m`. |Coq| @@ -1310,7 +1309,7 @@ inference rules, we use a more compact notation: .. _Allowed-elimination-sorts: -**Allowed elimination sorts.** An important question for building the typing rule for match is what +**Allowed elimination sorts.** An important question for building the typing rule for :math:`\Match` is what can be the type of :math:`λ a x . P` with respect to the type of :math:`m`. If :math:`m:I` and :math:`I:A` and :math:`λ a x . P : B` then by :math:`[I:A|B]` we mean that one can use :math:`λ a x . P` with :math:`m` in the above match-construct. @@ -1328,7 +1327,7 @@ There is no restriction on the sort of the predicate to be eliminated. [(I~x):A′|B′] ----------------------- - [I:∀ x:A, A′|∀ x:A, B′] + [I:∀ x:A,~A′|∀ x:A,~B′] .. inference:: Set & Type @@ -1348,7 +1347,7 @@ sort :math:`\Prop`. ~ --------------- - [I:Prop|I→Prop] + [I:\Prop|I→\Prop] :math:`\Prop` is the type of logical propositions, the proofs of properties :math:`P` in @@ -1377,7 +1376,7 @@ the proof of :g:`or A B` is not accepted: From the computational point of view, the structure of the proof of :g:`(or A B)` in this term is needed for computing the boolean value. -In general, if :math:`I` has type :math:`\Prop` then :math:`P` cannot have type :math:`I→Set,` because +In general, if :math:`I` has type :math:`\Prop` then :math:`P` cannot have type :math:`I→\Set`, because it will mean to build an informative proof of type :math:`(P~m)` doing a case analysis over a non-computational object that will disappear in the extracted program. But the other way is safe with respect to our @@ -1385,11 +1384,11 @@ interpretation we can have :math:`I` a computational object and :math:`P` a non-computational one, it just corresponds to proving a logical property of a computational object. -In the same spirit, elimination on :math:`P` of type :math:`I→Type` cannot be allowed -because it trivially implies the elimination on :math:`P` of type :math:`I→ Set` by +In the same spirit, elimination on :math:`P` of type :math:`I→\Type` cannot be allowed +because it trivially implies the elimination on :math:`P` of type :math:`I→ \Set` by cumulativity. It also implies that there are two proofs of the same -property which are provably different, contradicting the proof- -irrelevance property which is sometimes a useful axiom: +property which are provably different, contradicting the +proof-irrelevance property which is sometimes a useful axiom: .. example:: @@ -1398,7 +1397,7 @@ irrelevance property which is sometimes a useful axiom: Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. The elimination of an inductive definition of type :math:`\Prop` on a predicate -:math:`P` of type :math:`I→ Type` leads to a paradox when applied to impredicative +:math:`P` of type :math:`I→ \Type` leads to a paradox when applied to impredicative inductive definition like the second-order existential quantifier :g:`exProp` defined above, because it gives access to the two projections on this type. @@ -1414,7 +1413,7 @@ this type. I~\kw{is an empty or singleton definition} s ∈ \Sort ------------------------------------- - [I:Prop|I→ s] + [I:\Prop|I→ s] A *singleton definition* has only one constructor and all the arguments of this constructor have type :math:`\Prop`. In that case, there is a @@ -1451,7 +1450,7 @@ corresponding to the :math:`c:C` constructor. .. math:: \begin{array}{ll} \{c:(I~p_1\ldots p_r\ t_1 \ldots t_p)\}^P &\equiv (P~t_1\ldots ~t_p~c) \\ - \{c:\forall~x:T,C\}^P &\equiv \forall~x:T,\{(c~x):C\}^P + \{c:∀ x:T,~C\}^P &\equiv ∀ x:T,~\{(c~x):C\}^P \end{array} We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math:`c`. @@ -1470,7 +1469,7 @@ We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math: can be represented in abstract syntax as .. math:: - \case(t,P,f 1 | f 2 ) + \case(t,P,f_1 | f_2 ) where @@ -1478,9 +1477,9 @@ We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math: :nowrap: \begin{eqnarray*} - P & = & \lambda~l~.~P^\prime\\ + P & = & λ l.~P^\prime\\ f_1 & = & t_1\\ - f_2 & = & \lambda~(hd:\nat)~.~\lambda~(tl:\List~\nat)~.~t_2 + f_2 & = & λ (hd:\nat).~λ (tl:\List~\nat).~t_2 \end{eqnarray*} According to the definition: @@ -1492,9 +1491,9 @@ We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math: \begin{array}{rl} \{(\cons~\nat)\}^P & ≡\{(\cons~\nat) : (\nat→\List~\nat→\List~\nat)\}^P \\ - & ≡∀ n:\nat, \{(\cons~\nat~n) : \List~\nat→\List~\nat)\}^P \\ - & ≡∀ n:\nat, ∀ l:\List~\nat, \{(\cons~\nat~n~l) : \List~\nat)\}^P \\ - & ≡∀ n:\nat, ∀ l:\List~\nat,(P~(\cons~\nat~n~l)). + & ≡∀ n:\nat,~\{(\cons~\nat~n) : (\List~\nat→\List~\nat)\}^P \\ + & ≡∀ n:\nat,~∀ l:\List~\nat,~\{(\cons~\nat~n~l) : (\List~\nat)\}^P \\ + & ≡∀ n:\nat,~∀ l:\List~\nat,~(P~(\cons~\nat~n~l)). \end{array} Given some :math:`P` then :math:`\{(\Nil~\nat)\}^P` represents the expected type of :math:`f_1` , @@ -1519,7 +1518,7 @@ following typing rule E[Γ] ⊢ \case(c,P,f_1 |… |f_l ) : (P~t_1 … t_s~c) provided :math:`I` is an inductive type in a -definition :math:`\ind{r}{Γ_I}{Γ_C}` with :math:`Γ_C = [c_1 :C_1 ;…;c_n :C_n ]` and +definition :math:`\ind{r}{Γ_I}{Γ_C}` with :math:`Γ_C = [c_1 :C_1 ;~…;~c_n :C_n ]` and :math:`c_{p_1} … c_{p_l}` are the only constructors of :math:`I`. @@ -1558,7 +1557,7 @@ The ι-contraction of this term is :math:`(f_i~a_1 … a_m )` leading to the general reduction rule: .. math:: - \case((c_{p_i}~q_1 … q_r~a_1 … a_m ),P,f_1 |… |f_n ) \triangleright_ι (f_i~a_1 … a_m ) + \case((c_{p_i}~q_1 … q_r~a_1 … a_m ),P,f_1 |… |f_l ) \triangleright_ι (f_i~a_1 … a_m ) .. _Fixpoint-definitions: @@ -1599,7 +1598,7 @@ The typing rule is the expected one for a fixpoint. .. inference:: Fix (E[Γ] ⊢ A_i : s_i )_{i=1… n} - (E[Γ,f_1 :A_1 ,…,f_n :A_n ] ⊢ t_i : A_i )_{i=1… n} + (E[Γ;~f_1 :A_1 ;~…;~f_n :A_n ] ⊢ t_i : A_i )_{i=1… n} ------------------------------------------------------- E[Γ] ⊢ \Fix~f_i\{f_1 :A_1 :=t_1 … f_n :A_n :=t_n \} : A_i @@ -1639,7 +1638,7 @@ fixpoints is extended and becomes where :math:`k_i` are positive integers. Each :math:`k_i` represents the index of parameter of :math:`f_i` , on which :math:`f_i` is decreasing. Each :math:`A_i` should be a type (reducible to a term) starting with at least :math:`k_i` products -:math:`∀ y_1 :B_1 ,… ∀ y_{k_i} :B_{k_i} , A_i'` and :math:`B_{k_i}` an inductive type. +:math:`∀ y_1 :B_1 ,~… ∀ y_{k_i} :B_{k_i} ,~A_i'` and :math:`B_{k_i}` an inductive type. Now in the definition :math:`t_i`, if :math:`f_j` occurs then it should be applied to at least :math:`k_j` arguments and the :math:`k_j`-th argument should be @@ -1649,23 +1648,23 @@ The definition of being structurally smaller is a bit technical. One needs first to define the notion of *recursive arguments of a constructor*. For an inductive definition :math:`\ind{r}{Γ_I}{Γ_C}`, if the type of a constructor :math:`c` has the form -:math:`∀ p_1 :P_1 ,… ∀ p_r :P_r, ∀ x_1:T_1, … ∀ x_r :T_r, (I_j~p_1 … p_r~t_1 … t_s )`, +:math:`∀ p_1 :P_1 ,~… ∀ p_r :P_r,~∀ x_1:T_1,~… ∀ x_r :T_r,~(I_j~p_1 … p_r~t_1 … t_s )`, then the recursive arguments will correspond to :math:`T_i` in which one of the :math:`I_l` occurs. The main rules for being structurally smaller are the following. Given a variable :math:`y` of an inductively defined type in a declaration -:math:`\ind{r}{Γ_I}{Γ_C}` where :math:`Γ_I` is :math:`[I_1 :A_1 ;…;I_k :A_k]`, and :math:`Γ_C` is -:math:`[c_1 :C_1 ;…;c_n :C_n ]`, the terms structurally smaller than :math:`y` are: +:math:`\ind{r}{Γ_I}{Γ_C}` where :math:`Γ_I` is :math:`[I_1 :A_1 ;~…;~I_k :A_k]`, and :math:`Γ_C` is +:math:`[c_1 :C_1 ;~…;~c_n :C_n ]`, the terms structurally smaller than :math:`y` are: -+ :math:`(t~u)` and :math:`λ x:u . t` when :math:`t` is structurally smaller than :math:`y`. ++ :math:`(t~u)` and :math:`λ x:U .~t` when :math:`t` is structurally smaller than :math:`y`. + :math:`\case(c,P,f_1 … f_n)` when each :math:`f_i` is structurally smaller than :math:`y`. If :math:`c` is :math:`y` or is structurally smaller than :math:`y`, its type is an inductive definition :math:`I_p` part of the inductive declaration corresponding to :math:`y`. Each :math:`f_i` corresponds to a type of constructor - :math:`C_q ≡ ∀ p_1 :P_1 ,…,∀ p_r :P_r , ∀ y_1 :B_1 , … ∀ y_k :B_k , (I~a_1 … a_k )` - and can consequently be written :math:`λ y_1 :B_1' . … λ y_k :B_k'. g_i`. (:math:`B_i'` is + :math:`C_q ≡ ∀ p_1 :P_1 ,~…,∀ p_r :P_r ,~∀ y_1 :B_1 ,~… ∀ y_k :B_k ,~(I~a_1 … a_k )` + and can consequently be written :math:`λ y_1 :B_1' .~… λ y_k :B_k'.~g_i`. (:math:`B_i'` is obtained from :math:`B_i` by substituting parameters for variables) the variables :math:`y_j` occurring in :math:`g_i` corresponding to recursive arguments :math:`B_i` (the ones in which one of the :math:`I_l` occurs) are structurally smaller than y. @@ -1709,7 +1708,7 @@ Let :math:`F` be the set of declarations: The reduction for fixpoints is: .. math:: - (\Fix~f_i \{F\}~a_1 …a_{k_i}) \triangleright_ι \subst{t_i}{f_k}{\Fix~f_k \{F\}}_{k=1… n} ~a_1 … a_{k_i} + (\Fix~f_i \{F\}~a_1 …a_{k_i}) ~\triangleright_ι~ \subst{t_i}{f_k}{\Fix~f_k \{F\}}_{k=1… n} ~a_1 … a_{k_i} when :math:`a_{k_i}` starts with a constructor. This last restriction is needed in order to keep strong normalization and corresponds to the reduction @@ -1719,13 +1718,11 @@ possible: .. math:: :nowrap: - {\def\plus{\mathsf{plus}} - \def\tri{\triangleright_\iota} - \begin{eqnarray*} - \plus~(\nS~(\nS~\nO))~(\nS~\nO) & \tri & \nS~(\plus~(\nS~\nO)~(\nS~\nO))\\ - & \tri & \nS~(\nS~(\plus~\nO~(\nS~\nO)))\\ - & \tri & \nS~(\nS~(\nS~\nO))\\ - \end{eqnarray*}} + \begin{eqnarray*} + \plus~(\nS~(\nS~\nO))~(\nS~\nO)~& \trii & \nS~(\plus~(\nS~\nO)~(\nS~\nO))\\ + & \trii & \nS~(\nS~(\plus~\nO~(\nS~\nO)))\\ + & \trii & \nS~(\nS~(\nS~\nO))\\ + \end{eqnarray*} .. _Mutual-induction: @@ -1755,9 +1752,9 @@ reference to the global declaration in the subsequent global environment and local context by explicitly applying this constant to the constant :math:`c'`. -Below, if :math:`Γ` is a context of the form :math:`[y_1 :A_1 ;…;y_n :A_n]`, we write -:math:`∀x:U,\subst{Γ}{c}{x}` to mean -:math:`[y_1 :∀ x:U,\subst{A_1}{c}{x};…;y_n :∀ x:U,\subst{A_n}{c}{x}]` +Below, if :math:`Γ` is a context of the form :math:`[y_1 :A_1 ;~…;~y_n :A_n]`, we write +:math:`∀x:U,~\subst{Γ}{c}{x}` to mean +:math:`[y_1 :∀ x:U,~\subst{A_1}{c}{x};~…;~y_n :∀ x:U,~\subst{A_n}{c}{x}]` and :math:`\subst{E}{|Γ|}{|Γ|c}` to mean the parallel substitution :math:`E\{y_1 /(y_1~c)\}…\{y_n/(y_n~c)\}`. @@ -1767,25 +1764,25 @@ and :math:`\subst{E}{|Γ|}{|Γ|c}` to mean the parallel substitution **First abstracting property:** .. math:: - \frac{\WF{E;c:U;E′;c′:=t:T;E″}{Γ}} - {\WF{E;c:U;E′;c′:=λ x:U.~\subst{t}{c}{x}:∀x:U,~\subst{T}{c}{x};\subst{E″}{c′}{(c′~c)}} - {\subst{Γ}{c}{(c~c′)}}} + \frac{\WF{E;~c:U;~E′;~c′:=t:T;~E″}{Γ}} + {\WF{E;~c:U;~E′;~c′:=λ x:U.~\subst{t}{c}{x}:∀x:U,~\subst{T}{c}{x};~\subst{E″}{c′}{(c′~c)}} + {\subst{Γ}{c′}{(c′~c)}}} .. math:: - \frac{\WF{E;c:U;E′;c′:T;E″}{Γ}} - {\WF{E;c:U;E′;c′:∀ x:U,~\subst{T}{c}{x};\subst{E″}{c′}{(c′~c)}}{\subst{Γ}{c}{(c~c′)}}} + \frac{\WF{E;~c:U;~E′;~c′:T;~E″}{Γ}} + {\WF{E;~c:U;~E′;~c′:∀ x:U,~\subst{T}{c}{x};~\subst{E″}{c′}{(c′~c)}}{\subst{Γ}{c′}{(c′~c)}}} .. math:: - \frac{\WF{E;c:U;E′;\ind{p}{Γ_I}{Γ_C};E″}{Γ}} - {\WFTWOLINES{E;c:U;E′;\ind{p+1}{∀ x:U,~\subst{Γ_I}{c}{x}}{∀ x:U,~\subst{Γ_C}{c}{x}}; - \subst{E″}{|Γ_I ,Γ_C |}{|Γ_I ,Γ_C | c}} - {\subst{Γ}{|Γ_I ,Γ_C|}{|Γ_I ,Γ_C | c}}} + \frac{\WF{E;~c:U;~E′;~\ind{p}{Γ_I}{Γ_C};~E″}{Γ}} + {\WFTWOLINES{E;~c:U;~E′;~\ind{p+1}{∀ x:U,~\subst{Γ_I}{c}{x}}{∀ x:U,~\subst{Γ_C}{c}{x}};~ + \subst{E″}{|Γ_I ;Γ_C |}{|Γ_I ;Γ_C | c}} + {\subst{Γ}{|Γ_I ;Γ_C|}{|Γ_I ;Γ_C | c}}} One can similarly modify a global declaration by generalizing it over a previously defined constant :math:`c′`. Below, if :math:`Γ` is a context of the form -:math:`[y_1 :A_1 ;…;y_n :A_n]`, we write :math:`\subst{Γ}{c}{u}` to mean -:math:`[y_1 :\subst{A_1} {c}{u};…;y_n:\subst{A_n} {c}{u}]`. +:math:`[y_1 :A_1 ;~…;~y_n :A_n]`, we write :math:`\subst{Γ}{c}{u}` to mean +:math:`[y_1 :\subst{A_1} {c}{u};~…;~y_n:\subst{A_n} {c}{u}]`. .. _Second-abstracting-property: @@ -1793,16 +1790,16 @@ a previously defined constant :math:`c′`. Below, if :math:`Γ` is a context of **Second abstracting property:** .. math:: - \frac{\WF{E;c:=u:U;E′;c′:=t:T;E″}{Γ}} - {\WF{E;c:=u:U;E′;c′:=(\letin{x}{u:U}{\subst{t}{c}{x}}):\subst{T}{c}{u};E″}{Γ}} + \frac{\WF{E;~c:=u:U;~E′;~c′:=t:T;~E″}{Γ}} + {\WF{E;~c:=u:U;~E′;~c′:=(\letin{x}{u:U}{\subst{t}{c}{x}}):\subst{T}{c}{u};~E″}{Γ}} .. math:: - \frac{\WF{E;c:=u:U;E′;c′:T;E″}{Γ}} - {\WF{E;c:=u:U;E′;c′:\subst{T}{c}{u};E″}{Γ}} + \frac{\WF{E;~c:=u:U;~E′;~c′:T;~E″}{Γ}} + {\WF{E;~c:=u:U;~E′;~c′:\subst{T}{c}{u};~E″}{Γ}} .. math:: - \frac{\WF{E;c:=u:U;E′;\ind{p}{Γ_I}{Γ_C};E″}{Γ}} - {\WF{E;c:=u:U;E′;\ind{p}{\subst{Γ_I}{c}{u}}{\subst{Γ_C}{c}{u}};E″}{Γ}} + \frac{\WF{E;~c:=u:U;~E′;~\ind{p}{Γ_I}{Γ_C};~E″}{Γ}} + {\WF{E;~c:=u:U;~E′;~\ind{p}{\subst{Γ_I}{c}{u}}{\subst{Γ_C}{c}{u}};~E″}{Γ}} .. _Pruning-the-local-context: @@ -1817,7 +1814,7 @@ One can consequently derive the following property. .. inference:: First pruning property: - \WF{E;c:U;E′}{Γ} + \WF{E;~c:U;~E′}{Γ} c~\kw{does not occur in}~E′~\kw{and}~Γ -------------------------------------- \WF{E;E′}{Γ} @@ -1827,7 +1824,7 @@ One can consequently derive the following property. .. inference:: Second pruning property: - \WF{E;c:=u:U;E′}{Γ} + \WF{E;~c:=u:U;~E′}{Γ} c~\kw{does not occur in}~E′~\kw{and}~Γ -------------------------------------- \WF{E;E′}{Γ} @@ -1868,10 +1865,10 @@ in the sort :math:`\Set`, which is extended to a domain in any sort: .. inference:: ProdImp E[Γ] ⊢ T : s - s ∈ {\Sort} - E[Γ::(x:T)] ⊢ U : Set + s ∈ \Sort + E[Γ::(x:T)] ⊢ U : \Set --------------------- - E[Γ] ⊢ ∀ x:T,U : Set + E[Γ] ⊢ ∀ x:T,~U : \Set This extension has consequences on the inductive definitions which are allowed. In the impredicative system, one can build so-called *large @@ -1886,15 +1883,15 @@ impredicative system for sort :math:`\Set` become: .. inference:: Set1 - s ∈ \{Prop, Set\} + s ∈ \{\Prop, \Set\} ----------------- - [I:Set|I→ s] + [I:\Set|I→ s] .. inference:: Set2 I~\kw{is a small inductive definition} s ∈ \{\Type(i)\} ---------------- - [I:Set|I→ s] + [I:\Set|I→ s] diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index d0e44cd212..50a56f1d51 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -234,7 +234,8 @@ Primitive Projections extended the Calculus of Inductive Constructions with a new binary term constructor `r.(p)` representing a primitive projection `p` applied to a record object `r` (i.e., primitive projections are always applied). - Even if the record type has parameters, these do not appear at + Even if the record type has parameters, these do not appear + in the internal representation of applications of the projection, considerably reducing the sizes of terms when manipulating parameterized records and type checking time. On the user level, primitive projections can be used as a replacement diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index 9bc67147f7..1b4d2315aa 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -163,14 +163,14 @@ and ``coqtop``, unless stated otherwise: is equivalent to runningRequire dirpath. :-require dirpath: Load |Coq| compiled library dirpath and import it. This is equivalent to running Require Import dirpath. -:-batch: Exit just after argument parsing. Available for `coqtop` only. -:-compile *file.v*: Compile file *file.v* into *file.vo*. This option +:-batch: Exit just after argument parsing. Available for ``coqtop`` only. +:-compile *file.v*: Deprecated; use ``coqc`` instead. Compile file *file.v* into *file.vo*. This option implies -batch (exit just after argument parsing). It is available only - for `coqtop`, as this behavior is the purpose of `coqc`. -:-compile-verbose *file.v*: Same as -compile but also output the + for `coqtop`, as this behavior is the purpose of ``coqc``. +:-compile-verbose *file.v*: Deprecated. Use ``coqc -verbose``. Same as -compile but also output the content of *file.v* as it is compiled. :-verbose: Output the content of the input file as it is compiled. - This option is available for `coqc` only; it is the counterpart of + This option is available for ``coqc`` only; it is the counterpart of -compile-verbose. :-w (all|none|w₁,…,wₙ): Configure the display of warnings. This option expects all, none or a comma-separated list of warning names or @@ -211,11 +211,11 @@ and ``coqtop``, unless stated otherwise: (to be used by coqdoc, see :ref:`coqdoc`). By default, if *file.v* is being compiled, *file.glob* is used. :-no-glob: Disable the dumping of references for global names. -:-image *file*: Set the binary image to be used by `coqc` to be *file* +:-image *file*: Set the binary image to be used by ``coqc`` to be *file* instead of the standard one. Not of general use. :-bindir *directory*: Set the directory containing |Coq| binaries to be - used by `coqc`. It is equivalent to doing export COQBIN= *directory* - before launching `coqc`. + used by ``coqc``. It is equivalent to doing export COQBIN= *directory* + before launching ``coqc``. :-where: Print the location of |Coq|’s standard library and exit. :-config: Print the locations of |Coq|’s binaries, dependencies, and libraries, then exit. diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 92bd4dbd1d..483dbd311d 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -1445,6 +1445,16 @@ section constant. If tactic is ``move`` or ``case`` and an equation :token:`ident` is given, then clear (step 3) for :token:`d_item` is suppressed (see section :ref:`generation_of_equations_ssr`). +Intro patterns (see section :ref:`introduction_ssr`) +and the ``rewrite`` tactic (see section :ref:`rewriting_ssr`) +let one place a :token:`clear_switch` in the middle of other items +(namely identifiers, views and rewrite rules). This can trigger the +addition of proof context items to the ones being explicitly +cleared, and in turn this can result in clear errors (e.g. if the +context item automatically added occurs in the goal). The +relevant sections describe ways to avoid the unintended clear of +context items. + Matching for apply and exact ```````````````````````````` @@ -1572,6 +1582,9 @@ The :token:`i_pattern`\s can be seen as a variant of *intro patterns* (see :tacn:`intros`:) each performs an introduction operation, i.e., pops some variables or assumptions from the goal. +Simplification items +````````````````````` + An :token:`s_item` can simplify the set of subgoals or the subgoals themselves: + ``//`` removes all the “trivial” subgoals that can be resolved by the @@ -1583,18 +1596,32 @@ An :token:`s_item` can simplify the set of subgoals or the subgoals themselves: ``/= //``, i.e., ``simpl; try done``. -When an :token:`s_item` bears a :token:`clear_switch`, then the +When an :token:`s_item` immediately precedes a :token:`clear_switch`, then the :token:`clear_switch` is executed *after* the :token:`s_item`, e.g., ``{IHn}//`` will solve some subgoals, possibly using the fact ``IHn``, and will erase ``IHn`` from the context of the remaining subgoals. +Views +````` + The first entry in the :token:`i_view` grammar rule, :n:`/@term`, represents a view (see section :ref:`views_and_reflection_ssr`). It interprets the top of the stack with the view :token:`term`. -It is equivalent to ``move/term``. The optional flag ``{}`` can -be used to signal that the :token:`term`, when it is a context entry, -has to be cleared. +It is equivalent to :n:`move/@term`. + +A :token:`clear_switch` that immediately precedes an :token:`i_view` +is complemented with the name of the view if an only if the :token:`i_view` +is a simple proof context entry [#10]_. +E.g. ``{}/v`` is equivalent to ``/v{v}``. +This behavior can be avoided by separating the :token:`clear_switch` +from the :token:`i_view` with the ``-`` intro pattern or by putting +parentheses around the view. + +A :token:`clear_switch` that immediately precedes an :token:`i_view` +is executed after the view application. + + If the next :token:`i_item` is a view, then the view is applied to the assumption in top position once all the previous :token:`i_item` have been performed. @@ -1608,6 +1635,9 @@ Notations can be used to name tactics, for example:: lets one write just ``/myop`` in the intro pattern. Note the scope annotation: views are interpreted opening the ``ssripat`` scope. +Intro patterns +`````````````` + |SSR| supports the following :token:`i_pattern`\s: :token:`ident` @@ -1615,6 +1645,13 @@ annotation: views are interpreted opening the ``ssripat`` scope. a new constant, fact, or defined constant :token:`ident`, respectively. Note that defined constants cannot be introduced when δ-expansion is required to expose the top variable or assumption. + A :token:`clear_switch` (even an empty one) immediately preceding an + :token:`ident` is complemented with that :token:`ident` if and only if + the identifier is a simple proof context entry [#10]_. + As a consequence by prefixing the + :token:`ident` with ``{}`` one can *replace* a context entry. + This behavior can be avoided by separating the :token:`clear_switch` + from the :token:`ident` with the ``-`` intro pattern. ``>`` pops every variable occurring in the rest of the stack. Type class instances are popped even if they don't occur @@ -1708,6 +1745,9 @@ annotation: views are interpreted opening the ``ssripat`` scope. Note that |SSR| does not support the syntax ``(ipat, …, ipat)`` for destructing intro-patterns. +Clear switch +```````````` + Clears are deferred until the end of the intro pattern. .. example:: @@ -1730,6 +1770,9 @@ is performed behind the scenes. Facts mentioned in a clear switch must be valid names in the proof context (excluding the section context). +Branching and destructuring +``````````````````````````` + The rules for interpreting branching and destructing :token:`i_pattern` are motivated by the fact that it would be pointless to have a branching pattern if tactic is a ``move``, and in most of the remaining cases @@ -1754,6 +1797,9 @@ interpretation, e.g.: are all equivalent. +Block introduction +`````````````````` + |SSR| supports the following :token:`i_block`\s: :n:`[^ @ident ]` @@ -3030,13 +3076,22 @@ operation should be performed: pattern. In its simplest form, it is a regular term. If no explicit redex switch is present the rewrite pattern to be matched is inferred from the :token:`r_item`. -+ This optional term, or the :token:`r_item`, may be preceded by an occurrence - switch (see section :ref:`selectors_ssr`) or a clear item - (see section :ref:`discharge_ssr`), - these two possibilities being exclusive. An occurrence switch selects ++ This optional term, or the :token:`r_item`, may be preceded by an + :token:`occ_switch` (see section :ref:`selectors_ssr`) or a + :token:`clear_switch` (see section :ref:`discharge_ssr`), + these two possibilities being exclusive. + + An occurrence switch selects the occurrences of the rewrite pattern which should be affected by the rewrite operation. + A clear switch, even an empty one, is performed *after* the + :token:`r_item` is actually processed and is complemented with the name of + the rewrite rule if an only if it is a simple proof context entry [#10]_. + As a consequence one can + write ``rewrite {}H`` to rewrite with ``H`` and dispose ``H`` immediately + afterwards. + This behavior can be avoided by putting parentheses around the rewrite rule. An :token:`r_item` can be: @@ -3291,10 +3346,6 @@ the rewrite tactic. The effect of the tactic on the initial goal is to rewrite this lemma at the second occurrence of the first matching ``x + y + 0`` of the explicit rewrite redex ``_ + y + 0``. -An empty occurrence switch ``{}`` is not interpreted as a valid occurrence -switch. It has the effect of clearing the :token:`r_item` (when it is the name -of a context entry). - Occurrence selection and repetition ``````````````````````````````````` @@ -5520,3 +5571,5 @@ Settings in the metatheory .. [#9] The current state of the proof shall be displayed by the Show Proof command of |Coq| proof mode. +.. [#10] A simple proof context entry is a naked identifier (i.e. not between + parentheses) designating a context entry that is not a section variable. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 250d9c3a8a..7eef504ea9 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3388,7 +3388,7 @@ Automation :name: auto This tactic implements a Prolog-like resolution procedure to solve the - current goal. It first tries to solve the goal using the assumption + current goal. It first tries to solve the goal using the :tacn:`assumption` tactic, then it reduces the goal to an atomic one using intros and introduces the newly generated hypotheses as hints. Then it looks at the list of tactics associated to the head symbol of the goal and diff --git a/doc/sphinx/refman-preamble.sty b/doc/sphinx/refman-preamble.sty index b4fc608e47..8f7b1bb1e8 100644 --- a/doc/sphinx/refman-preamble.sty +++ b/doc/sphinx/refman-preamble.sty @@ -56,27 +56,29 @@ \newcommand{\oddS}{\textsf{odd}_\textsf{S}} \newcommand{\ovl}[1]{\overline{#1}} \newcommand{\Pair}{\textsf{pair}} +\newcommand{\plus}{\mathsf{plus}} \newcommand{\Prod}{\textsf{prod}} \newcommand{\Prop}{\textsf{Prop}} \newcommand{\return}{\kw{return}} \newcommand{\Set}{\textsf{Set}} \newcommand{\si}{\textsf{if}} \newcommand{\sinon}{\textsf{else}} -\newcommand{\Sort}{\cal S} +\newcommand{\Sort}{\mathcal{S}} \newcommand{\Str}{\textsf{Stream}} \newcommand{\Struct}{\kw{Struct}} \newcommand{\subst}[3]{#1\{#2/#3\}} \newcommand{\tl}{\textsf{tl}} \newcommand{\tree}{\textsf{tree}} +\newcommand{\trii}{\triangleright_\iota} \newcommand{\true}{\textsf{true}} \newcommand{\Type}{\textsf{Type}} \newcommand{\unfold}{\textsf{unfold}} \newcommand{\WEV}[3]{\mbox{$#1[] \vdash #2 \lra #3$}} \newcommand{\WEVT}[3]{\mbox{$#1[] \vdash #2 \lra$}\\ \mbox{$ #3$}} -\newcommand{\WF}[2]{{\cal W\!F}(#1)[#2]} +\newcommand{\WF}[2]{{\mathcal{W\!F}}(#1)[#2]} \newcommand{\WFE}[1]{\WF{E}{#1}} -\newcommand{\WFT}[2]{#1[] \vdash {\cal W\!F}(#2)} -\newcommand{\WFTWOLINES}[2]{{\cal W\!F}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}} +\newcommand{\WFT}[2]{#1[] \vdash {\mathcal{W\!F}}(#2)} +\newcommand{\WFTWOLINES}[2]{{\mathcal{W\!F}}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}} \newcommand{\with}{\kw{with}} \newcommand{\WS}[3]{#1[] \vdash #2 <: #3} \newcommand{\WSE}[2]{\WS{E}{#1}{#2}} diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index c707da1353..ae66791b0c 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1496,12 +1496,13 @@ Numeral notations function returns :g:`None`, or if the interpretation is registered for only non-negative integers, and the given numeral is negative. - .. exn:: @ident should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z could be used{? (require BinNums first)}. + + .. exn:: @ident should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first). The parsing function given to the :cmd:`Numeral Notation` vernacular is not of the right type. - .. exn:: @ident should go from @type to Decimal.int or (option Decimal.int). Instead of Decimal.int, the types Decimal.uint or Z could be used{? (require BinNums first)}. + .. exn:: @ident should go from @type to Decimal.int or (option Decimal.int). Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first). The printing function given to the :cmd:`Numeral Notation` vernacular is not of the right type. diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 51f94d7e5a..c33df52038 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -618,5 +618,6 @@ through the <tt>Require Import</tt> command.</p> theories/Compat/Coq87.v theories/Compat/Coq88.v theories/Compat/Coq89.v + theories/Compat/Coq810.v </dd> </dl> @@ -5,7 +5,7 @@ (ocamlopt_flags -O3 -unbox-closures)) (ireport (flags :standard -rectypes -w -9-27-40+60) (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report)) - (ocaml408 + (ocaml409 (flags :standard -strict-sequence -strict-formats -short-paths -keep-locs -rectypes -w -9-27+40+60 -warn-error -5 -alert --deprecated))) ; The _ profile could help factoring the above, however it doesn't diff --git a/engine/proofview.ml b/engine/proofview.ml index cf4224bbdb..d4ad53ff5f 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -39,7 +39,7 @@ let proofview p = let compact el ({ solution } as pv) = let nf c = Evarutil.nf_evar solution c in - let nf0 c = EConstr.(to_constr solution (of_constr c)) in + let nf0 c = EConstr.(to_constr ~abort_on_undefined_evars:false solution (of_constr c)) in let size = Evd.fold (fun _ _ i -> i+1) solution 0 in let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in let pruned_solution = Evd.drop_all_defined solution in diff --git a/engine/uState.ml b/engine/uState.ml index 6969d2ba44..430a3a2fd9 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -12,6 +12,7 @@ open Pp open CErrors open Util open Names +open Univ module UNameMap = Names.Id.Map @@ -24,12 +25,12 @@ module UPairSet = UnivMinim.UPairSet (* 2nd part used to check consistency on the fly. *) type t = - { uctx_names : UnivNames.universe_binders * uinfo Univ.LMap.t; - uctx_local : Univ.ContextSet.t; (** The local context of variables *) - uctx_seff_univs : Univ.LSet.t; (** Local universes used through private constants *) + { uctx_names : UnivNames.universe_binders * uinfo LMap.t; + uctx_local : ContextSet.t; (** The local context of variables *) + uctx_seff_univs : LSet.t; (** Local universes used through private constants *) uctx_univ_variables : UnivSubst.universe_opt_subst; (** The local universes that are unification variables *) - uctx_univ_algebraic : Univ.LSet.t; + uctx_univ_algebraic : LSet.t; (** The subset of unification variables that can be instantiated with algebraic universes as they appear in inferred types only. *) uctx_universes : UGraph.t; (** The current graph extended with the local constraints *) @@ -38,11 +39,11 @@ type t = } let empty = - { uctx_names = UNameMap.empty, Univ.LMap.empty; - uctx_local = Univ.ContextSet.empty; - uctx_seff_univs = Univ.LSet.empty; - uctx_univ_variables = Univ.LMap.empty; - uctx_univ_algebraic = Univ.LSet.empty; + { uctx_names = UNameMap.empty, LMap.empty; + uctx_local = ContextSet.empty; + uctx_seff_univs = LSet.empty; + uctx_univ_variables = LMap.empty; + uctx_univ_algebraic = LSet.empty; uctx_universes = UGraph.initial_universes; uctx_initial_universes = UGraph.initial_universes; uctx_weak_constraints = UPairSet.empty; } @@ -52,8 +53,8 @@ let make u = uctx_universes = u; uctx_initial_universes = u} let is_empty ctx = - Univ.ContextSet.is_empty ctx.uctx_local && - Univ.LMap.is_empty ctx.uctx_univ_variables + ContextSet.is_empty ctx.uctx_local && + LMap.is_empty ctx.uctx_univ_variables let uname_union s t = if s == t then s @@ -67,29 +68,29 @@ let union ctx ctx' = if ctx == ctx' then ctx else if is_empty ctx' then ctx else - let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in - let seff = Univ.LSet.union ctx.uctx_seff_univs ctx'.uctx_seff_univs in + let local = ContextSet.union ctx.uctx_local ctx'.uctx_local in + let seff = LSet.union ctx.uctx_seff_univs ctx'.uctx_seff_univs in let names = uname_union (fst ctx.uctx_names) (fst ctx'.uctx_names) in - let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local) - (Univ.ContextSet.levels ctx.uctx_local) in - let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in + let newus = LSet.diff (ContextSet.levels ctx'.uctx_local) + (ContextSet.levels ctx.uctx_local) in + let newus = LSet.diff newus (LMap.domain ctx.uctx_univ_variables) in let weak = UPairSet.union ctx.uctx_weak_constraints ctx'.uctx_weak_constraints in let declarenew g = - Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) newus g + LSet.fold (fun u g -> UGraph.add_universe u false g) newus g in - let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in + let names_rev = LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; uctx_seff_univs = seff; uctx_univ_variables = - Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; + LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; uctx_univ_algebraic = - Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; + LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; uctx_initial_universes = declarenew ctx.uctx_initial_universes; uctx_universes = (if local == ctx.uctx_local then ctx.uctx_universes else - let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in + let cstrsr = ContextSet.constraints ctx'.uctx_local in UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes)); uctx_weak_constraints = weak} @@ -97,14 +98,14 @@ let context_set ctx = ctx.uctx_local let constraints ctx = snd ctx.uctx_local -let context ctx = Univ.ContextSet.to_context ctx.uctx_local +let context ctx = ContextSet.to_context ctx.uctx_local let const_univ_entry ~poly uctx = let open Entries in if poly then let (binders, _) = uctx.uctx_names in let uctx = context uctx in - let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in + let nas = UnivNames.compute_instance_binders (UContext.instance uctx) binders in Polymorphic_const_entry (nas, uctx) else Monomorphic_const_entry (context_set uctx) @@ -114,7 +115,7 @@ let ind_univ_entry ~poly uctx = if poly then let (binders, _) = uctx.uctx_names in let uctx = context uctx in - let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in + let nas = UnivNames.compute_instance_binders (UContext.instance uctx) binders in Polymorphic_ind_entry (nas, uctx) else Monomorphic_ind_entry (context_set uctx) @@ -132,19 +133,19 @@ let add_uctx_names ?loc s l (names, names_rev) = if UNameMap.mem s names then user_err ?loc ~hdr:"add_uctx_names" Pp.(str "Universe " ++ Names.Id.print s ++ str" already bound."); - (UNameMap.add s l names, Univ.LMap.add l { uname = Some s; uloc = loc } names_rev) + (UNameMap.add s l names, LMap.add l { uname = Some s; uloc = loc } names_rev) let add_uctx_loc l loc (names, names_rev) = match loc with | None -> (names, names_rev) - | Some _ -> (names, Univ.LMap.add l { uname = None; uloc = loc } names_rev) + | Some _ -> (names, LMap.add l { uname = None; uloc = loc } names_rev) let of_binders b = let ctx = empty in let rmap = UNameMap.fold (fun id l rmap -> - Univ.LMap.add l { uname = Some id; uloc = None } rmap) - b Univ.LMap.empty + LMap.add l { uname = Some id; uloc = None } rmap) + b LMap.empty in { ctx with uctx_names = b, rmap } @@ -157,7 +158,6 @@ let invent_name (named,cnt) u = aux cnt let universe_binders ctx = - let open Univ in let named, rev = ctx.uctx_names in let named, _ = LSet.fold (fun u named -> match LMap.find u rev with @@ -169,7 +169,7 @@ let universe_binders ctx = named let instantiate_variable l b v = - try v := Univ.LMap.set l (Some b) !v + try v := LMap.set l (Some b) !v with Not_found -> assert false exception UniversesDiffer @@ -177,7 +177,6 @@ exception UniversesDiffer let drop_weak_constraints = ref false let process_universe_constraints ctx cstrs = - let open Univ in let open UnivSubst in let open UnivProblem in let univs = ctx.uctx_universes in @@ -190,9 +189,9 @@ let process_universe_constraints ctx cstrs = | UEq (u, v) -> UEq (subst_univs_universe normalize u, subst_univs_universe normalize v) | ULe (u, v) -> ULe (subst_univs_universe normalize u, subst_univs_universe normalize v) in - let is_local l = Univ.LMap.mem l !vars in + let is_local l = LMap.mem l !vars in let varinfo x = - match Univ.Universe.level x with + match Universe.level x with | None -> Inl x | Some l -> Inr l in @@ -206,27 +205,27 @@ let process_universe_constraints ctx cstrs = else if not (UGraph.check_eq_level univs l' r') then (* Two rigid/global levels, none of them being local, one of them being Prop/Set, disallow *) - if Univ.Level.is_small l' || Univ.Level.is_small r' then - raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) + if Level.is_small l' || Level.is_small r' then + raise (UniverseInconsistency (Eq, l, r, None)) else if fo then raise UniversesDiffer in - Univ.enforce_eq_level l' r' local + enforce_eq_level l' r' local in let equalize_universes l r local = match varinfo l, varinfo r with | Inr l', Inr r' -> equalize_variables false l l' r r' local | Inr l, Inl r | Inl r, Inr l -> - let alg = Univ.LSet.mem l ctx.uctx_univ_algebraic in - let inst = Univ.univ_level_rem l r r in + let alg = LSet.mem l ctx.uctx_univ_algebraic in + let inst = univ_level_rem l r r in if alg then (instantiate_variable l inst vars; local) else - let lu = Univ.Universe.make l in - if Univ.univ_level_mem l r then - Univ.enforce_leq inst lu local - else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None)) + let lu = Universe.make l in + if univ_level_mem l r then + enforce_leq inst lu local + else raise (UniverseInconsistency (Eq, lu, r, None)) | Inl _, Inl _ (* both are algebraic *) -> if UGraph.check_eq univs l r then local - else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) + else raise (UniverseInconsistency (Eq, l, r, None)) in let unify_universes cst local = let cst = nf_constraint cst in @@ -237,29 +236,29 @@ let process_universe_constraints ctx cstrs = if UGraph.check_leq univs l r then (* Keep Prop/Set <= var around if var might be instantiated by prop or set later. *) - match Univ.Universe.level l, Univ.Universe.level r with + match Universe.level l, Universe.level r with | Some l, Some r -> - Univ.Constraint.add (l, Univ.Le, r) local + Constraint.add (l, Le, r) local | _ -> local else - begin match Univ.Universe.level r with + begin match Universe.level r with | None -> user_err Pp.(str "Algebraic universe on the right") | Some r' -> - if Univ.Level.is_small r' then - if not (Univ.Universe.is_levels l) + if Level.is_small r' then + if not (Universe.is_levels l) then - raise (Univ.UniverseInconsistency (Univ.Le, l, r, None)) + raise (UniverseInconsistency (Le, l, r, None)) else - let levels = Univ.Universe.levels l in + let levels = Universe.levels l in let fold l' local = - let l = Univ.Universe.make l' in - if Univ.Level.is_small l' || is_local l' then + let l = Universe.make l' in + if Level.is_small l' || is_local l' then equalize_variables false l l' r r' local - else raise (Univ.UniverseInconsistency (Univ.Le, l, r, None)) + else raise (UniverseInconsistency (Le, l, r, None)) in - Univ.LSet.fold fold levels local + LSet.fold fold levels local else - Univ.enforce_leq l r local + enforce_leq l r local end | ULub (l, r) -> equalize_variables true (Universe.make l) l (Universe.make r) r local @@ -268,26 +267,26 @@ let process_universe_constraints ctx cstrs = | UEq (l, r) -> equalize_universes l r local in let local = - UnivProblem.Set.fold unify_universes cstrs Univ.Constraint.empty + UnivProblem.Set.fold unify_universes cstrs Constraint.empty in !vars, !weak, local let add_constraints ctx cstrs = let univs, local = ctx.uctx_local in - let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> - let l = Univ.Universe.make l and r = Univ.Universe.make r in + let cstrs' = Constraint.fold (fun (l,d,r) acc -> + let l = Universe.make l and r = Universe.make r in let cstr' = let open UnivProblem in match d with - | Univ.Lt -> - ULe (Univ.Universe.super l, r) - | Univ.Le -> ULe (l, r) - | Univ.Eq -> UEq (l, r) + | Lt -> + ULe (Universe.super l, r) + | Le -> ULe (l, r) + | Eq -> UEq (l, r) in UnivProblem.Set.add cstr' acc) cstrs UnivProblem.Set.empty in let vars, weak, local' = process_universe_constraints ctx cstrs' in { ctx with - uctx_local = (univs, Univ.Constraint.union local local'); + uctx_local = (univs, Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes; uctx_weak_constraints = weak; } @@ -299,7 +298,7 @@ let add_universe_constraints ctx cstrs = let univs, local = ctx.uctx_local in let vars, weak, local' = process_universe_constraints ctx cstrs in { ctx with - uctx_local = (univs, Univ.Constraint.union local local'); + uctx_local = (univs, Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes; uctx_weak_constraints = weak; } @@ -307,14 +306,14 @@ let add_universe_constraints ctx cstrs = let constrain_variables diff ctx = let univs, local = ctx.uctx_local in let univs, vars, local = - Univ.LSet.fold + LSet.fold (fun l (univs, vars, cstrs) -> try - match Univ.LMap.find l vars with + match LMap.find l vars with | Some u -> - (Univ.LSet.add l univs, - Univ.LMap.remove l vars, - Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs) + (LSet.add l univs, + LMap.remove l vars, + Constraint.add (l, Eq, Option.get (Universe.level u)) cstrs) | None -> (univs, vars, cstrs) with Not_found | Option.IsNone -> (univs, vars, cstrs)) diff (univs, ctx.uctx_univ_variables, local) @@ -324,14 +323,14 @@ let constrain_variables diff ctx = let qualid_of_level uctx = let map, map_rev = uctx.uctx_names in fun l -> - try Some (Libnames.qualid_of_ident (Option.get (Univ.LMap.find l map_rev).uname)) + try Some (Libnames.qualid_of_ident (Option.get (LMap.find l map_rev).uname)) with Not_found | Option.IsNone -> UnivNames.qualid_of_level l let pr_uctx_level uctx l = match qualid_of_level uctx l with | Some qid -> Libnames.pr_qualid qid - | None -> Univ.Level.pr l + | None -> Level.pr l type ('a, 'b) gen_universe_decl = { univdecl_instance : 'a; (* Declared universes *) @@ -340,16 +339,15 @@ type ('a, 'b) gen_universe_decl = { univdecl_extensible_constraints : bool (* Can new constraints be added *) } type universe_decl = - (lident list, Univ.Constraint.t) gen_universe_decl + (lident list, Constraint.t) gen_universe_decl let default_univ_decl = { univdecl_instance = []; univdecl_extensible_instance = true; - univdecl_constraints = Univ.Constraint.empty; + univdecl_constraints = Constraint.empty; univdecl_extensible_constraints = true } let error_unbound_universes left uctx = - let open Univ in let n = LSet.cardinal left in let loc = try @@ -365,7 +363,6 @@ let error_unbound_universes left uctx = str" unbound.")) let universe_context ~names ~extensible uctx = - let open Univ in let levels = ContextSet.levels uctx.uctx_local in let newinst, left = List.fold_right @@ -388,7 +385,6 @@ let universe_context ~names ~extensible uctx = let check_universe_context_set ~names ~extensible uctx = if extensible then () else - let open Univ in let left = List.fold_left (fun left { CAst.loc; v = id } -> let l = try UNameMap.find id (fst uctx.uctx_names) @@ -415,7 +411,7 @@ let check_mono_univ_decl uctx decl = if not decl.univdecl_extensible_constraints then check_implication uctx decl.univdecl_constraints - (Univ.ContextSet.constraints uctx.uctx_local); + (ContextSet.constraints uctx.uctx_local); uctx.uctx_local let check_univ_decl ~poly uctx decl = @@ -425,7 +421,7 @@ let check_univ_decl ~poly uctx decl = if poly then let (binders, _) = uctx.uctx_names in let uctx = universe_context ~names ~extensible uctx in - let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in + let nas = UnivNames.compute_instance_binders (UContext.instance uctx) binders in Entries.Polymorphic_const_entry (nas, uctx) else let () = check_universe_context_set ~names ~extensible uctx in @@ -434,11 +430,10 @@ let check_univ_decl ~poly uctx decl = if not decl.univdecl_extensible_constraints then check_implication uctx decl.univdecl_constraints - (Univ.ContextSet.constraints uctx.uctx_local); + (ContextSet.constraints uctx.uctx_local); ctx let restrict_universe_context (univs, csts) keep = - let open Univ in let removed = LSet.diff univs keep in if LSet.is_empty removed then univs, csts else @@ -453,8 +448,8 @@ let restrict_universe_context (univs, csts) keep = (LSet.inter univs keep, csts) let restrict ctx vars = - let vars = Univ.LSet.union vars ctx.uctx_seff_univs in - let vars = Names.Id.Map.fold (fun na l vars -> Univ.LSet.add l vars) + let vars = LSet.union vars ctx.uctx_seff_univs in + let vars = Names.Id.Map.fold (fun na l vars -> LSet.add l vars) (fst ctx.uctx_names) vars in let uctx' = restrict_universe_context ctx.uctx_local vars in @@ -465,7 +460,7 @@ let demote_seff_univs entry uctx = match entry.const_entry_universes with | Polymorphic_const_entry _ -> uctx | Monomorphic_const_entry (univs, _) -> - let seff = Univ.LSet.union uctx.uctx_seff_univs univs in + let seff = LSet.union uctx.uctx_seff_univs univs in { uctx with uctx_seff_univs = seff } type rigid = @@ -483,7 +478,6 @@ let univ_flexible_alg = UnivFlexible true or defined separately. In the later case, there is no extension, see [emit_side_effects] for example. *) let merge ?loc ~sideff ~extend rigid uctx ctx' = - let open Univ in let levels = ContextSet.levels ctx' in let uctx = if not extend then uctx else @@ -527,7 +521,7 @@ let merge ?loc ~sideff ~extend rigid uctx ctx' = uctx_initial_universes = initial } let merge_subst uctx s = - { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s } + { uctx with uctx_univ_variables = LMap.subst_union uctx.uctx_univ_variables s } let emit_side_effects eff u = let uctxs = Safe_typing.universes_of_private eff in @@ -536,14 +530,14 @@ let emit_side_effects eff u = let new_univ_variable ?loc rigid name ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = let u = UnivGen.fresh_level () in - let ctx' = Univ.ContextSet.add_universe u ctx in + let ctx' = ContextSet.add_universe u ctx in let uctx', pred = match rigid with | UnivRigid -> uctx, true | UnivFlexible b -> - let uvars' = Univ.LMap.add u None uvars in + let uvars' = LMap.add u None uvars in if b then {uctx with uctx_univ_variables = uvars'; - uctx_univ_algebraic = Univ.LSet.add u avars}, false + uctx_univ_algebraic = LSet.add u avars}, false else {uctx with uctx_univ_variables = uvars'}, false in let names = @@ -574,12 +568,11 @@ let add_global_univ uctx u = let univs = UGraph.add_universe u true uctx.uctx_universes in - { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local; + { uctx with uctx_local = ContextSet.add_universe u uctx.uctx_local; uctx_initial_universes = initial; uctx_universes = univs } let make_flexible_variable ctx ~algebraic u = - let open Univ in let {uctx_local = cstrs; uctx_univ_variables = uvars; uctx_univ_algebraic = avars; uctx_universes=g; } = ctx in assert (try LMap.find u uvars == None with Not_found -> true); @@ -608,48 +601,47 @@ let make_flexible_variable ctx ~algebraic u = uctx_univ_algebraic = avars'} let make_nonalgebraic_variable ctx u = - { ctx with uctx_univ_algebraic = Univ.LSet.remove u ctx.uctx_univ_algebraic } + { ctx with uctx_univ_algebraic = LSet.remove u ctx.uctx_univ_algebraic } let make_flexible_nonalgebraic ctx = - {ctx with uctx_univ_algebraic = Univ.LSet.empty} + {ctx with uctx_univ_algebraic = LSet.empty} let is_sort_variable uctx s = match s with | Sorts.Type u -> - (match Univ.universe_level u with + (match universe_level u with | Some l as x -> - if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x + if LSet.mem l (ContextSet.levels uctx.uctx_local) then x else None | None -> None) | _ -> None let subst_univs_context_with_def def usubst (ctx, cst) = - (Univ.LSet.diff ctx def, UnivSubst.subst_univs_constraints usubst cst) + (LSet.diff ctx def, UnivSubst.subst_univs_constraints usubst cst) let is_trivial_leq (l,d,r) = - Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r)) + Level.is_prop l && (d == Le || (d == Lt && Level.is_set r)) (* Prop < i <-> Set+1 <= i <-> Set < i *) let translate_cstr (l,d,r as cstr) = - let open Univ in - if Level.equal Level.prop l && d == Univ.Lt && not (Level.equal Level.set r) then + if Level.equal Level.prop l && d == Lt && not (Level.equal Level.set r) then (Level.set, d, r) else cstr let refresh_constraints univs (ctx, cstrs) = let cstrs', univs' = - Univ.Constraint.fold (fun c (cstrs', univs as acc) -> + Constraint.fold (fun c (cstrs', univs as acc) -> let c = translate_cstr c in if is_trivial_leq c then acc - else (Univ.Constraint.add c cstrs', UGraph.enforce_constraint c univs)) - cstrs (Univ.Constraint.empty, univs) + else (Constraint.add c cstrs', UGraph.enforce_constraint c univs)) + cstrs (Constraint.empty, univs) in ((ctx, cstrs'), univs') let normalize_variables uctx = let normalized_variables, def, subst = UnivSubst.normalize_univ_variables uctx.uctx_univ_variables in - let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in + let ctx_local = subst_univs_context_with_def def (make_subst subst) uctx.uctx_local in let ctx_local', univs = refresh_constraints uctx.uctx_initial_universes ctx_local in subst, { uctx with uctx_local = ctx_local'; uctx_univ_variables = normalized_variables; @@ -657,17 +649,17 @@ let normalize_variables uctx = let abstract_undefined_variables uctx = let vars' = - Univ.LMap.fold (fun u v acc -> - if v == None then Univ.LSet.remove u acc + LMap.fold (fun u v acc -> + if v == None then LSet.remove u acc else acc) uctx.uctx_univ_variables uctx.uctx_univ_algebraic - in { uctx with uctx_local = Univ.ContextSet.empty; + in { uctx with uctx_local = ContextSet.empty; uctx_univ_algebraic = vars' } let fix_undefined_variables uctx = let algs', vars' = - Univ.LMap.fold (fun u v (algs, vars as acc) -> - if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars) + LMap.fold (fun u v (algs, vars as acc) -> + if v == None then (LSet.remove u algs, LMap.remove u vars) else acc) uctx.uctx_univ_variables (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables) @@ -677,20 +669,20 @@ let fix_undefined_variables uctx = let refresh_undefined_univ_variables uctx = let subst, ctx' = UnivGen.fresh_universe_context_set_instance uctx.uctx_local in - let subst_fn u = Univ.subst_univs_level_level subst u in - let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (subst_fn u) acc) - uctx.uctx_univ_algebraic Univ.LSet.empty + let subst_fn u = subst_univs_level_level subst u in + let alg = LSet.fold (fun u acc -> LSet.add (subst_fn u) acc) + uctx.uctx_univ_algebraic LSet.empty in let vars = - Univ.LMap.fold + LMap.fold (fun u v acc -> - Univ.LMap.add (subst_fn u) - (Option.map (Univ.subst_univs_level_universe subst) v) acc) - uctx.uctx_univ_variables Univ.LMap.empty + LMap.add (subst_fn u) + (Option.map (subst_univs_level_universe subst) v) acc) + uctx.uctx_univ_variables LMap.empty in let weak = UPairSet.fold (fun (u,v) acc -> UPairSet.add (subst_fn u, subst_fn v) acc) uctx.uctx_weak_constraints UPairSet.empty in - let declare g = Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) - (Univ.ContextSet.levels ctx') g in + let declare g = LSet.fold (fun u g -> UGraph.add_universe u false g) + (ContextSet.levels ctx') g in let initial = declare uctx.uctx_initial_universes in let univs = declare UGraph.initial_universes in let uctx' = {uctx_names = uctx.uctx_names; @@ -708,7 +700,7 @@ let minimize uctx = normalize_context_set uctx.uctx_universes uctx.uctx_local uctx.uctx_univ_variables uctx.uctx_univ_algebraic uctx.uctx_weak_constraints in - if Univ.ContextSet.equal us' uctx.uctx_local then uctx + if ContextSet.equal us' uctx.uctx_local then uctx else let us', universes = refresh_constraints uctx.uctx_initial_universes us' diff --git a/ide/fake_ide.ml b/ide/fake_ide.ml index 8b0c736f50..4e26cb6095 100644 --- a/ide/fake_ide.ml +++ b/ide/fake_ide.ml @@ -241,6 +241,9 @@ let eval_print l coq = | [ Tok(_,"ADD"); Top [Tok(_,name)]; Tok(_,phrase) ] -> let eid, tip = add_sentence ~name phrase in after_add (base_eval_call (add ((phrase,eid),(tip,true))) coq) + | [ Tok(_,"FAILADD"); Tok(_,phrase) ] -> + let eid, tip = add_sentence phrase in + after_fail coq (base_eval_call ~fail:false (add ((phrase,eid),(tip,true))) coq) | [ Tok(_,"GOALS"); ] -> eval_call (goals ()) coq | [ Tok(_,"FAILGOALS"); ] -> @@ -267,7 +270,8 @@ let eval_print l coq = prerr_endline "Quitting fake_ide"; exit 0 | Tok("#[^\n]*",_) :: _ -> () - | _ -> error "syntax error" + | Tok(s,_) :: _ -> error ("syntax error at " ^ s) + | _ -> error ("syntax error") let grammar = let open Parser in @@ -275,6 +279,7 @@ let grammar = let eat_phrase = eat_balanced '{' in Alt [ Seq [Item (eat_rex "ADD"); Opt (Item eat_id); Item eat_phrase] + ; Seq [Item (eat_rex "FAILADD"); Item eat_phrase] ; Seq [Item (eat_rex "EDIT_AT"); Item eat_id] ; Seq [Item (eat_rex "QUERY"); Opt (Item eat_id); Item eat_phrase] ; Seq [Item (eat_rex "WAIT")] diff --git a/ide/idetop.ml b/ide/idetop.ml index 716a942d5c..e157696294 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -64,11 +64,19 @@ let is_known_option cmd = match Vernacprop.under_control cmd with (** Check whether a command is forbidden in the IDE *) -let ide_cmd_checks ~id {CAst.loc;v=ast} = - let user_error s = CErrors.user_err ?loc ~hdr:"IDE" (str s) in - let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in +let ide_cmd_checks ~last_valid {CAst.loc;v=ast} = + let user_error s = + try CErrors.user_err ?loc ~hdr:"IDE" (str s) + with e -> + let (e, info) = CErrors.push e in + let info = Stateid.add info ~valid:last_valid Stateid.dummy in + Exninfo.raise ~info e + in if is_debug ast then - user_error "Debug mode not available in the IDE"; + user_error "Debug mode not available in the IDE" + +let ide_cmd_warns ~id {CAst.loc;v=ast} = + let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in if is_known_option ast then warn "Set this option from the IDE menu instead"; if is_navigation_vernac ast || is_undo ast then @@ -83,11 +91,15 @@ let set_doc doc = ide_doc := Some doc let add ((s,eid),(sid,verbose)) = let doc = get_doc () in let pa = Pcoq.Parsable.make (Stream.of_string s) in - let loc_ast = Stm.parse_sentence ~doc sid pa in + match Stm.parse_sentence ~doc sid ~entry:Pvernac.main_entry pa with + | None -> assert false (* s is not an empty string *) + | Some (loc, ast) -> + let loc_ast = CAst.make ~loc ast in + ide_cmd_checks ~last_valid:sid loc_ast; let doc, newid, rc = Stm.add ~doc ~ontop:sid verbose loc_ast in set_doc doc; let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in - ide_cmd_checks ~id:newid loc_ast; + ide_cmd_warns ~id:newid loc_ast; (* TODO: the "" parameter is a leftover of the times the protocol * used to include stderr/stdout output. * @@ -121,10 +133,10 @@ let query (route, (s,id)) = let annotate phrase = let doc = get_doc () in - let {CAst.loc;v=ast} = - let pa = Pcoq.Parsable.make (Stream.of_string phrase) in - Stm.parse_sentence ~doc (Stm.get_current_state ~doc) pa - in + let pa = Pcoq.Parsable.make (Stream.of_string phrase) in + match Stm.parse_sentence ~doc (Stm.get_current_state ~doc) ~entry:Pvernac.main_entry pa with + | None -> Richpp.richpp_of_pp 78 (Pp.mt ()) + | Some (_, ast) -> (* XXX: Width should be a parameter of annotate... *) Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast) @@ -534,5 +546,5 @@ let islave_init ~opts extra_args = let () = let open Coqtop in - let custom = { init = islave_init; run = loop; opts = Coqargs.default_opts } in + let custom = { init = islave_init; run = loop; opts = Coqargs.default } in start_coq custom diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 444ac5ab6d..13078840ef 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -625,8 +625,13 @@ let explicitize inctx impl (cf,f) args = CApp ((ip,f),args1@args2) | None -> let args = exprec 1 (args,impl) in - if List.is_empty args then f.CAst.v else CApp ((None, f), args) - in + if List.is_empty args then f.CAst.v else + match f.CAst.v with + | CApp (g,args') -> + (* may happen with notations for a prefix of an n-ary + application *) + CApp (g,args'@args) + | _ -> CApp ((None, f), args) in try expl () with Expl -> let f',us = match f with { CAst.v = CRef (f,us) } -> f,us | _ -> assert false in diff --git a/lib/flags.ml b/lib/flags.ml index ae4d337ded..55bfa3cbde 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -66,7 +66,7 @@ let we_are_parsing = ref false (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = V8_7 | V8_8 | Current +type compat_version = V8_7 | V8_8 | V8_9 | Current let compat_version = ref Current @@ -77,6 +77,9 @@ let version_compare v1 v2 = match v1, v2 with | V8_8, V8_8 -> 0 | V8_8, _ -> -1 | _, V8_8 -> 1 + | V8_9, V8_9 -> 0 + | V8_9, _ -> -1 + | _, V8_9 -> 1 | Current, Current -> 0 let version_strictly_greater v = version_compare !compat_version v > 0 @@ -85,6 +88,7 @@ let version_less_or_equal v = not (version_strictly_greater v) let pr_version = function | V8_7 -> "8.7" | V8_8 -> "8.8" + | V8_9 -> "8.9" | Current -> "current" (* Translate *) diff --git a/lib/flags.mli b/lib/flags.mli index d883cf1e30..7336b9beaf 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -58,7 +58,7 @@ val we_are_parsing : bool ref (* Set Printing All flag. For some reason it is a global flag *) val raw_print : bool ref -type compat_version = V8_7 | V8_8 | Current +type compat_version = V8_7 | V8_8 | V8_9 | Current val compat_version : compat_version ref val version_compare : compat_version -> compat_version -> int val version_strictly_greater : compat_version -> bool diff --git a/lib/stateid.ml b/lib/stateid.ml index 5485c4bf19..8f45f3605d 100644 --- a/lib/stateid.ml +++ b/lib/stateid.ml @@ -27,6 +27,8 @@ let get exn = Exninfo.get exn state_id_info let equal = Int.equal let compare = Int.compare +let print id = Pp.int id + module Self = struct type t = int let compare = compare diff --git a/lib/stateid.mli b/lib/stateid.mli index 5d4b71a354..f6ce7ddc40 100644 --- a/lib/stateid.mli +++ b/lib/stateid.mli @@ -20,6 +20,7 @@ val initial : t val dummy : t val fresh : unit -> t val to_string : t -> string +val print : t -> Pp.t val of_int : int -> t val to_int : t -> int diff --git a/man/coqtop.1 b/man/coqtop.1 index 084adfe453..addfb54672 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -85,22 +85,6 @@ load Coq library and import it (Require Import path.) .TP -.BI \-compile \ filename.v -compile Coq file -.I filename.v -(implies -.B \-batch -) - -.TP -.BI \-compile\-verbose \ filename.v -verbosely compile Coq file -.I filename.v -(implies -.B \-batch -) - -.TP .B \-where print Coq's standard library location and exit @@ -125,8 +109,6 @@ batch mode (exits just after arguments parsing) .B \-boot boot mode (implies .B \-q -and -.B \-batch ) .TP diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 19ae97da77..759e60fbca 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -439,7 +439,6 @@ module Module = let module_expr = Entry.create "module_expr" let module_type = Entry.create "module_type" end - let epsilon_value f e = let r = G.production (G.r_next G.r_stop (symbol_of_prod_entry_key e), (fun x _ -> f x)) in let ext = [None, None, [r]] in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 352857d4cd..3203a25b46 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -41,6 +41,16 @@ end - static rules explicitly defined in files g_*.ml4 - static rules macro-generated by ARGUMENT EXTEND, TACTIC EXTEND and VERNAC EXTEND (see e.g. file extratactics.ml4) + + Note that parsing a Coq document is in essence stateful: the parser + needs to recognize commands that start proofs and use a different + parsing entry point for them. + + We thus provide two different interfaces: the "raw" parsing + interface, in the style of camlp5, which provides more flexibility, + and a more specialize "parse_vernac" one, which will indeed adjust + the state as needed. + *) (** Dynamic extension of rules @@ -269,3 +279,7 @@ type any_entry = AnyEntry : 'a Entry.t -> any_entry val register_grammars_by_name : string -> any_entry list -> unit val find_grammars_by_name : string -> any_entry list + +(** Parsing state handling *) +val freeze : marshallable:bool -> frozen_t +val unfreeze : frozen_t -> unit diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index df4b647642..0cdf8fb5d8 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -18,7 +18,7 @@ DECLARE PLUGIN "derive_plugin" { -let classify_derive_command _ = Vernacextend.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) +let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]),VtLater) } diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 8f0440a2a4..c4f8843e51 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -186,7 +186,7 @@ VERNAC COMMAND EXTEND Function (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) with | Vernacextend.VtSideff ids, _ when hard -> - Vernacextend.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) + Vernacextend.(VtStartProof (GuaranteesOpacity, ids), VtLater) | x -> x } -> { do_generate_principle false (List.map snd recsl) } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index d9b19c1ae6..4c24f51b1e 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -58,15 +58,8 @@ let new_entry name = let toplevel_selector = new_entry "vernac:toplevel_selector" let tacdef_body = new_entry "tactic:tacdef_body" -(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for - proof editing and changes nothing else). Then sets it as the default proof mode. *) -let _ = - let mode = { - Proof_global.name = "Classic"; - set = (fun () -> Pvernac.set_command_entry tactic_mode); - reset = (fun () -> Pvernac.(set_command_entry noedit_mode)); - } in - Proof_global.register_proof_mode mode +(* Registers [tactic_mode] as a parser for proof editing *) +let classic_proof_mode = Pvernac.register_proof_mode "Classic" tactic_mode (* Hack to parse "[ id" without dropping [ *) let test_bracket_ident = diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index 1ea6ff84d4..cdee012a82 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -83,7 +83,7 @@ open Obligations let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac -let classify_obbl _ = Vernacextend.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) +let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]), VtLater) } diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 31fb1c9abf..db8d1b20d8 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -285,13 +285,13 @@ VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF add_morphism_infer atts m n; } | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => { VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater } + => { VtStartProof(GuaranteesOpacity,[n]), VtLater } -> { add_morphism atts [] m s n; } | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => { VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater } + => { VtStartProof(GuaranteesOpacity,[n]), VtLater } -> { add_morphism atts binders m s n; } diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index d4bafe773f..7adae148bd 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -846,7 +846,7 @@ struct match env with | [] -> ([v],n) | e::l -> - if EConstr.eq_constr sigma e v + if EConstr.eq_constr_nounivs sigma e v then (env,n) else let (env,n) = _add l ( n+1) v in diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v index c5a09d677e..a964febf9c 100644 --- a/plugins/nsatz/Nsatz.v +++ b/plugins/nsatz/Nsatz.v @@ -452,6 +452,7 @@ constructor;red;intros;subst;trivial. Qed. Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). +Defined. Instance Rri : (Ring (Ro:=Rops)). constructor; @@ -468,6 +469,7 @@ Class can_compute_Z (z : Z) := dummy_can_compute_Z : True. Hint Extern 0 (can_compute_Z ?v) => match isZcst v with true => exact I end : typeclass_instances. Instance reify_IZR z lvar {_ : can_compute_Z z} : reify (PEc z) lvar (IZR z). +Defined. Lemma R_one_zero: 1%R <> 0%R. discrR. @@ -484,6 +486,7 @@ exact Rmult_integral. exact R_one_zero. Defined. Require Import QArith. Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). +Defined. Instance Qri : (Ring (Ro:=Qops)). constructor. diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 94a3d40441..695f000cb1 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -12,6 +12,120 @@ Require Import Arith Max Min BinInt BinNat Znat Nnat. Local Open Scope Z_scope. +(** * [Z.div_mod_to_equations], [Z.quot_rem_to_equations], [Z.to_euclidean_division_equations]: the tactics for preprocessing [Z.div] and [Z.modulo], [Z.quot] and [Z.rem] *) + +(** These tactic use the complete specification of [Z.div] and + [Z.modulo] ([Z.quot] and [Z.rem], respectively) to remove these + functions from the goal without losing information. The + [Z.euclidean_division_equations_cleanup] tactic removes needless + hypotheses, which makes tactics like [nia] run faster. The tactic + [Z.to_euclidean_division_equations] combines the handling of both variants + of division/quotient and modulo/remainder. *) + +Module Z. + Lemma mod_0_r_ext x y : y = 0 -> x mod y = 0. + Proof. intro; subst; destruct x; reflexivity. Qed. + Lemma div_0_r_ext x y : y = 0 -> x / y = 0. + Proof. intro; subst; destruct x; reflexivity. Qed. + + Lemma rem_0_r_ext x y : y = 0 -> Z.rem x y = x. + Proof. intro; subst; destruct x; reflexivity. Qed. + Lemma quot_0_r_ext x y : y = 0 -> Z.quot x y = 0. + Proof. intro; subst; destruct x; reflexivity. Qed. + + Lemma rem_bound_pos_pos x y : 0 < y -> 0 <= x -> 0 <= Z.rem x y < y. + Proof. intros; apply Z.rem_bound_pos; assumption. Qed. + Lemma rem_bound_neg_pos x y : y < 0 -> 0 <= x -> 0 <= Z.rem x y < -y. + Proof. rewrite <- Z.rem_opp_r'; intros; apply Z.rem_bound_pos; rewrite ?Z.opp_pos_neg; assumption. Qed. + Lemma rem_bound_pos_neg x y : 0 < y -> x <= 0 -> -y < Z.rem x y <= 0. + Proof. rewrite <- (Z.opp_involutive x), Z.rem_opp_l', <- Z.opp_lt_mono, and_comm, !Z.opp_nonpos_nonneg; apply rem_bound_pos_pos. Qed. + Lemma rem_bound_neg_neg x y : y < 0 -> x <= 0 -> y < Z.rem x y <= 0. + Proof. rewrite <- (Z.opp_involutive x), <- (Z.opp_involutive y), Z.rem_opp_l', <- Z.opp_lt_mono, and_comm, !Z.opp_nonpos_nonneg, Z.opp_involutive; apply rem_bound_neg_pos. Qed. + + Ltac div_mod_to_equations_generalize x y := + pose proof (Z.div_mod x y); + pose proof (Z.mod_pos_bound x y); + pose proof (Z.mod_neg_bound x y); + pose proof (div_0_r_ext x y); + pose proof (mod_0_r_ext x y); + let q := fresh "q" in + let r := fresh "r" in + set (q := x / y) in *; + set (r := x mod y) in *; + clearbody q r. + Ltac quot_rem_to_equations_generalize x y := + pose proof (Z.quot_rem' x y); + pose proof (rem_bound_pos_pos x y); + pose proof (rem_bound_pos_neg x y); + pose proof (rem_bound_neg_pos x y); + pose proof (rem_bound_neg_neg x y); + pose proof (quot_0_r_ext x y); + pose proof (rem_0_r_ext x y); + let q := fresh "q" in + let r := fresh "r" in + set (q := Z.quot x y) in *; + set (r := Z.rem x y) in *; + clearbody q r. + + Ltac div_mod_to_equations_step := + match goal with + | [ |- context[?x / ?y] ] => div_mod_to_equations_generalize x y + | [ |- context[?x mod ?y] ] => div_mod_to_equations_generalize x y + | [ H : context[?x / ?y] |- _ ] => div_mod_to_equations_generalize x y + | [ H : context[?x mod ?y] |- _ ] => div_mod_to_equations_generalize x y + end. + Ltac quot_rem_to_equations_step := + match goal with + | [ |- context[Z.quot ?x ?y] ] => quot_rem_to_equations_generalize x y + | [ |- context[Z.rem ?x ?y] ] => quot_rem_to_equations_generalize x y + | [ H : context[Z.quot ?x ?y] |- _ ] => quot_rem_to_equations_generalize x y + | [ H : context[Z.rem ?x ?y] |- _ ] => quot_rem_to_equations_generalize x y + end. + Ltac div_mod_to_equations' := repeat div_mod_to_equations_step. + Ltac quot_rem_to_equations' := repeat quot_rem_to_equations_step. + Ltac euclidean_division_equations_cleanup := + repeat match goal with + | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl) + | [ H : ?x <> ?x -> _ |- _ ] => clear H + | [ H : ?x < ?x -> _ |- _ ] => clear H + | [ H : ?T -> _, H' : ?T |- _ ] => specialize (H H') + | [ H : ?T -> _, H' : ~?T |- _ ] => clear H + | [ H : ~?T -> _, H' : ?T |- _ ] => clear H + | [ H : ?A -> ?x = ?x -> _ |- _ ] => specialize (fun a => H a eq_refl) + | [ H : ?A -> ?x <> ?x -> _ |- _ ] => clear H + | [ H : ?A -> ?x < ?x -> _ |- _ ] => clear H + | [ H : ?A -> ?B -> _, H' : ?B |- _ ] => specialize (fun a => H a H') + | [ H : ?A -> ?B -> _, H' : ~?B |- _ ] => clear H + | [ H : ?A -> ~?B -> _, H' : ?B |- _ ] => clear H + | [ H : 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : ?A -> 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?A -> ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : ?A -> 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?A -> ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H + | [ H : ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H + | [ H : ?A -> 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H + | [ H : ?A -> ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H + | [ H : 0 <= ?x -> _, H' : ?x <= 0 |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x (eq_sym pf))) + | [ H : ?A -> 0 <= ?x -> _, H' : ?x <= 0 |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl 0 x (eq_sym pf))) + | [ H : ?x <= 0 -> _, H' : 0 <= ?x |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x pf)) + | [ H : ?A -> ?x <= 0 -> _, H' : 0 <= ?x |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl x 0 pf)) + | [ H : ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H + | [ H : ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H + | [ H : ?A -> ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H + | [ H : ?A -> ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H + | [ H : ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H + | [ H : ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H + | [ H : ?A -> ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H + | [ H : ?A -> ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H + end. + Ltac div_mod_to_equations := div_mod_to_equations'; euclidean_division_equations_cleanup. + Ltac quot_rem_to_equations := quot_rem_to_equations'; euclidean_division_equations_cleanup. + Ltac to_euclidean_division_equations := div_mod_to_equations'; quot_rem_to_equations'; euclidean_division_equations_cleanup. +End Z. (** * zify: the Z-ification tactic *) @@ -411,6 +525,24 @@ Ltac zify_N_op := | |- context [ Z.of_N (N.mul ?a ?b) ] => pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * + (* N.div -> Z.div and a positivity hypothesis *) + | H : context [ Z.of_N (N.div ?a ?b) ] |- _ => + pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * + | |- context [ Z.of_N (N.div ?a ?b) ] => + pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * + + (* N.modulo -> Z.rem / Z.modulo and a positivity hypothesis (N.modulo agrees with Z.modulo on everything except 0; so we pose both the non-zero proof for this agreement, but also replace things with [Z.rem]) *) + | H : context [ Z.of_N (N.modulo ?a ?b) ] |- _ => + pose proof (N2Z.is_nonneg (N.modulo a b)); + pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + rewrite (N2Z.inj_rem a b) in * + | |- context [ Z.of_N (N.div ?a ?b) ] => + pose proof (N2Z.is_nonneg (N.modulo a b)); + pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + rewrite (N2Z.inj_rem a b) in * + (* atoms of type N : we add a positivity condition (if not already there) *) | _ : 0 <= Z.of_N ?a |- _ => hide_Z_of_N a | _ : context [ Z.of_N ?a ] |- _ => pose proof (N2Z.is_nonneg a); hide_Z_of_N a diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v index 1ca6227f25..aa0370b2ac 100644 --- a/plugins/setoid_ring/Ncring_initial.v +++ b/plugins/setoid_ring/Ncring_initial.v @@ -32,6 +32,7 @@ Lemma Zsth : Equivalence (@eq Z). Proof. exact Z.eq_equiv. Qed. Instance Zops:@Ring_ops Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z). +Defined. Instance Zr: (@Ring _ _ _ _ _ _ _ _ Zops). Proof. diff --git a/plugins/setoid_ring/Ncring_tac.v b/plugins/setoid_ring/Ncring_tac.v index 7958507819..c8d560cfe9 100644 --- a/plugins/setoid_ring/Ncring_tac.v +++ b/plugins/setoid_ring/Ncring_tac.v @@ -27,41 +27,50 @@ Class nth (R:Type) (t:R) (l:list R) (i:nat). Instance Ifind0 (R:Type) (t:R) l : nth t(t::l) 0. +Defined. Instance IfindS (R:Type) (t2 t1:R) l i {_:nth t1 l i} : nth t1 (t2::l) (S i) | 1. +Defined. Class closed (T:Type) (l:list T). Instance Iclosed_nil T : closed (T:=T) nil. +Defined. Instance Iclosed_cons T t (l:list T) {_:closed l} : closed (t::l). +Defined. Class reify (R:Type)`{Rr:Ring (T:=R)} (e:PExpr Z) (lvar:list R) (t:R). Instance reify_zero (R:Type) lvar op `{Ring (T:=R)(ring0:=op)} : reify (ring0:=op)(PEc 0%Z) lvar op. +Defined. Instance reify_one (R:Type) lvar op `{Ring (T:=R)(ring1:=op)} : reify (ring1:=op) (PEc 1%Z) lvar op. +Defined. Instance reifyZ0 (R:Type) lvar `{Ring (T:=R)} : reify (PEc Z0) lvar Z0|11. +Defined. Instance reifyZpos (R:Type) lvar (p:positive) `{Ring (T:=R)} : reify (PEc (Zpos p)) lvar (Zpos p)|11. +Defined. Instance reifyZneg (R:Type) lvar (p:positive) `{Ring (T:=R)} : reify (PEc (Zneg p)) lvar (Zneg p)|11. +Defined. Instance reify_add (R:Type) e1 lvar t1 e2 t2 op @@ -69,6 +78,7 @@ Instance reify_add (R:Type) {_:reify (add:=op) e1 lvar t1} {_:reify (add:=op) e2 lvar t2} : reify (add:=op) (PEadd e1 e2) lvar (op t1 t2). +Defined. Instance reify_mul (R:Type) e1 lvar t1 e2 t2 op @@ -76,6 +86,7 @@ Instance reify_mul (R:Type) {_:reify (mul:=op) e1 lvar t1} {_:reify (mul:=op) e2 lvar t2} : reify (mul:=op) (PEmul e1 e2) lvar (op t1 t2)|10. +Defined. Instance reify_mul_ext (R:Type) `{Ring R} lvar (z:Z) e2 t2 @@ -83,6 +94,7 @@ Instance reify_mul_ext (R:Type) `{Ring R} {_:reify e2 lvar t2} : reify (PEmul (PEc z) e2) lvar (@multiplication Z _ _ z t2)|9. +Defined. Instance reify_sub (R:Type) e1 lvar t1 e2 t2 op @@ -90,24 +102,28 @@ Instance reify_sub (R:Type) {_:reify (sub:=op) e1 lvar t1} {_:reify (sub:=op) e2 lvar t2} : reify (sub:=op) (PEsub e1 e2) lvar (op t1 t2). +Defined. Instance reify_opp (R:Type) e1 lvar t1 op `{Ring (T:=R)(opp:=op)} {_:reify (opp:=op) e1 lvar t1} : reify (opp:=op) (PEopp e1) lvar (op t1). +Defined. Instance reify_pow (R:Type) `{Ring R} e1 lvar t1 n `{Ring (T:=R)} {_:reify e1 lvar t1} : reify (PEpow e1 n) lvar (pow_N t1 n)|1. +Defined. Instance reify_var (R:Type) t lvar i `{nth R t lvar i} `{Rr: Ring (T:=R)} : reify (Rr:= Rr) (PEX Z (Pos.of_succ_nat i))lvar t | 100. +Defined. Class reifylist (R:Type)`{Rr:Ring (T:=R)} (lexpr:list (PExpr Z)) (lvar:list R) (lterm:list R). @@ -115,12 +131,14 @@ Class reifylist (R:Type)`{Rr:Ring (T:=R)} (lexpr:list (PExpr Z)) (lvar:list R) Instance reify_nil (R:Type) lvar `{Rr: Ring (T:=R)} : reifylist (Rr:= Rr) nil lvar (@nil R). +Defined. Instance reify_cons (R:Type) e1 lvar t1 lexpr2 lterm2 `{Rr: Ring (T:=R)} {_:reify (Rr:= Rr) e1 lvar t1} {_:reifylist (Rr:= Rr) lexpr2 lvar lterm2} : reifylist (Rr:= Rr) (e1::lexpr2) lvar (t1::lterm2). +Defined. Definition list_reifyl (R:Type) lexpr lvar lterm `{Rr: Ring (T:=R)} diff --git a/plugins/setoid_ring/Rings_Q.v b/plugins/setoid_ring/Rings_Q.v index ae91ee1664..df3677e1c3 100644 --- a/plugins/setoid_ring/Rings_Q.v +++ b/plugins/setoid_ring/Rings_Q.v @@ -15,6 +15,7 @@ Require Export Integral_domain. Require Import QArith. Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). +Defined. Instance Qri : (Ring (Ro:=Qops)). constructor. diff --git a/plugins/setoid_ring/Rings_R.v b/plugins/setoid_ring/Rings_R.v index 901b36ed3b..fe7558845d 100644 --- a/plugins/setoid_ring/Rings_R.v +++ b/plugins/setoid_ring/Rings_R.v @@ -20,6 +20,7 @@ constructor;red;intros;subst;trivial. Qed. Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). +Defined. Instance Rri : (Ring (Ro:=Rops)). constructor; diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index dd2c2d0ba4..9ce9250a43 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -67,7 +67,7 @@ type ssrview = ast_closure_term list type id_block = Prefix of Id.t | SuffixId of Id.t | SuffixNum of int (* Only [One] forces an introduction, possibly reducing the goal. *) -type anon_iter = +type anon_kind = | One of string option (* name hint *) | Drop | All @@ -76,25 +76,23 @@ type anon_iter = type ssripat = | IPatNoop | IPatId of Id.t - | IPatAnon of anon_iter (* inaccessible name *) -(* TODO | IPatClearMark *) - | IPatDispatch of bool (* ssr exception: accept a dispatch on the empty list even when there are subgoals *) * ssripatss_or_block (* (..|..) *) - | IPatCase of (* ipats_mod option * *) ssripatss_or_block (* this is not equivalent to /case /[..|..] if there are already multiple goals *) + | IPatAnon of anon_kind (* inaccessible name *) + | IPatDispatch of ssripatss_or_block (* (..|..) *) + | IPatCase of ssripatss_or_block (* [..|..] *) | IPatInj of ssripatss | IPatRewrite of (*occurrence option * rewrite_pattern **) ssrocc * ssrdir - | IPatView of bool * ssrview (* {}/view (true if the clear is present) *) + | IPatView of ssrview (* /view *) | IPatClear of ssrclear (* {H1 H2} *) | IPatSimpl of ssrsimpl | IPatAbstractVars of Id.t list | IPatFastNondep - | IPatEqGen of unit Proofview.tactic (* internal use: generation of eqn *) and ssripats = ssripat list and ssripatss = ssripats list and ssripatss_or_block = | Block of id_block | Regular of ssripats list -type ssrhpats = ((ssrclear * ssripats) * ssripats) * ssripats +type ssrhpats = ((ssrclear option * ssripats) * ssripats) * ssripats type ssrhpats_wtransp = bool * ssrhpats (* tac => inpats *) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 311d912efd..c3b9bde9b8 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -66,7 +66,7 @@ let check_hyp_exists hyps (SsrHyp(_, id)) = try ignore(Context.Named.lookup id hyps) with Not_found -> errorstrm Pp.(str"No assumption is named " ++ Id.print id) -let test_hypname_exists hyps id = +let test_hyp_exists hyps (SsrHyp(_, id)) = try ignore(Context.Named.lookup id hyps); true with Not_found -> false diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 51116ccd75..e642b5e788 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -29,7 +29,7 @@ val allocc : ssrocc val hyp_id : ssrhyp -> Id.t val hyps_ids : ssrhyps -> Id.t list val check_hyp_exists : ('a, 'b) Context.Named.pt -> ssrhyp -> unit -val test_hypname_exists : ('a, 'b) Context.Named.pt -> Id.t -> bool +val test_hyp_exists : ('a, 'b) Context.Named.pt -> ssrhyp -> bool val check_hyps_uniq : Id.t list -> ssrhyps -> unit val not_section_id : Id.t -> bool val hyp_err : ?loc:Loc.t -> string -> Id.t -> 'a diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 257ecd2a85..8c1363020a 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -94,17 +94,23 @@ let basecuttac name c gl = let introstac ipats = Proofview.V82.of_tactic (tclIPAT ipats) let havetac ist - (transp,((((clr, pats), binders), simpl), (((fk, _), t), hint))) + (transp,((((clr, orig_pats), binders), simpl), (((fk, _), t), hint))) suff namefst gl = let concl = pf_concl gl in + let pats = tclCompileIPats orig_pats in + let binders = tclCompileIPats binders in + let simpl = tclCompileIPats simpl in let skols, pats = - List.partition (function IPatAbstractVars _ -> true | _ -> false) pats in + List.partition (function IOpAbstractVars _ -> true | _ -> false) pats in let itac_mkabs = introstac skols in - let itac_c = introstac (IPatClear clr :: pats) in + let itac_c, clr = + match clr with + | None -> introstac pats, [] + | Some clr -> introstac (tclCompileIPats (IPatClear clr :: orig_pats)), clr in let itac, id, clr = introstac pats, Tacticals.tclIDTAC, old_cleartac clr in let binderstac n = - let rec aux = function 0 -> [] | n -> IPatAnon (One None) :: aux (n-1) in + let rec aux = function 0 -> [] | n -> IOpInaccessible None :: aux (n-1) in Tacticals.tclTHEN (if binders <> [] then introstac (aux n) else Tacticals.tclIDTAC) (introstac binders) in let simpltac = introstac simpl in @@ -160,7 +166,7 @@ let havetac ist gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c | FwdHave, false, false -> let skols = List.flatten (List.map (function - | IPatAbstractVars ids -> ids + | IOpAbstractVars ids -> ids | _ -> assert false) skols) in let skols_args = List.map (fun id -> Ssripats.Internal.examine_abstract (EConstr.mkVar id) gl) skols in @@ -203,10 +209,12 @@ let destProd_or_LetIn sigma c = | _ -> raise DestKO let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = + let clr0 = Option.default [] clr0 in + let pats = tclCompileIPats pats in let mkabs gen = abs_wgen false (fun x -> x) gen in let mkclr gen clrs = clr_of_wgen gen clrs in let mkpats = function - | _, Some ((x, _), _) -> fun pats -> IPatId (hoi_id x) :: pats + | _, Some ((x, _), _) -> fun pats -> IOpId (hoi_id x) :: pats | _ -> fun x -> x in let ct = match Ssrcommon.ssrterm_of_ast_closure_term ct with | (a, (b, Some ct)) -> @@ -265,7 +273,7 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = if gens = [] then errorstrm(str"gen have requires some generalizations"); let clear0 = old_cleartac clr0 in let id, name_general_hyp, cleanup, pats = match id, pats with - | None, (IPatId id as ip)::pats -> Some id, tacipat [ip], clear0, pats + | None, (IOpId id as ip)::pats -> Some id, tacipat [ip], clear0, pats | None, _ -> None, Tacticals.tclIDTAC, clear0, pats | Some (Some id),_ -> Some id, introid id, clear0, pats | Some _,_ -> @@ -289,6 +297,10 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = (** The "suffice" tactic *) let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = + let clr = Option.default [] clr in + let pats = tclCompileIPats pats in + let binders = tclCompileIPats binders in + let simpl = tclCompileIPats simpl in let htac = Tacticals.tclTHEN (introstac pats) (hinttac ist true hint) in let c = match Ssrcommon.ssrterm_of_ast_closure_term c with | (a, (b, Some ct)) -> diff --git a/plugins/ssr/ssrfwd.mli b/plugins/ssr/ssrfwd.mli index 8a05e25504..35e89dbcea 100644 --- a/plugins/ssr/ssrfwd.mli +++ b/plugins/ssr/ssrfwd.mli @@ -22,7 +22,7 @@ val ssrposetac : Id.t * (ssrfwdfmt * ast_closure_term) -> v82tac val havetac : ist -> bool * - ((((Ssrast.ssrclear * Ssrast.ssripat list) * Ssrast.ssripats) * + ((((Ssrast.ssrclear option * Ssrast.ssripat list) * Ssrast.ssripats) * Ssrast.ssripats) * (((Ssrast.ssrfwdkind * 'a) * ast_closure_term) * (bool * Tacinterp.Value.t option list))) -> @@ -35,7 +35,7 @@ val basecuttac : val wlogtac : Ltac_plugin.Tacinterp.interp_sign -> - ((Ssrast.ssrhyps * Ssrast.ssripats) * 'a) * 'b -> + ((Ssrast.ssrclear option * Ssrast.ssripats) * 'a) * 'b -> (Ssrast.ssrhyps * ((Ssrast.ssrhyp_or_id * string) * Ssrmatching_plugin.Ssrmatching.cpattern option) @@ -50,7 +50,7 @@ val wlogtac : val sufftac : Ssrast.ist -> - (((Ssrast.ssrhyps * Ssrast.ssripats) * Ssrast.ssripat list) * + (((Ssrast.ssrclear option * Ssrast.ssripats) * Ssrast.ssripat list) * Ssrast.ssripat list) * (('a * ast_closure_term) * diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index ce81d83661..a8dfd69240 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -19,14 +19,78 @@ open Proofview.Notations open Ssrast +type ssriop = + | IOpId of Names.Id.t + | IOpDrop + | IOpTemporay + | IOpInaccessible of string option + | IOpInaccessibleAll + | IOpAbstractVars of Names.Id.t list + | IOpFastNondep + + | IOpInj of ssriops list + + | IOpDispatchBlock of id_block + | IOpDispatchBranches of ssriops list + + | IOpCaseBlock of id_block + | IOpCaseBranches of ssriops list + + | IOpRewrite of ssrocc * ssrdir + | IOpView of ssrclear option * ssrview (* extra clears to be performed *) + + | IOpClear of ssrclear * ssrhyp option (* must clear, may clear *) + | IOpSimpl of ssrsimpl + + | IOpEqGen of unit Proofview.tactic (* generation of eqn *) + + | IOpNoop + +and ssriops = ssriop list + +let rec pr_ipatop = function + | IOpId id -> Names.Id.print id + | IOpDrop -> Pp.str "_" + | IOpTemporay -> Pp.str "+" + | IOpInaccessible None -> Pp.str "?" + | IOpInaccessible (Some s) -> Pp.str ("?«"^s^"»") + | IOpInaccessibleAll -> Pp.str "*" + | IOpAbstractVars l -> Pp.str ("[:"^String.concat " " (List.map Names.Id.to_string l)^"]") + | IOpFastNondep -> Pp.str ">" + + | IOpInj l -> Pp.(str "[=" ++ ppl l ++ str "]") + + | IOpDispatchBlock b -> Pp.(str"(" ++ Ssrprinters.pr_block b ++ str")") + | IOpDispatchBranches l -> Pp.(str "(" ++ ppl l ++ str ")") + + | IOpCaseBlock b -> Pp.(str"[" ++ Ssrprinters.pr_block b ++ str"]") + | IOpCaseBranches l -> Pp.(str "[" ++ ppl l ++ str "]") + + | IOpRewrite (occ,dir) -> Pp.(Ssrprinters.(pr_occ occ ++ pr_dir dir)) + | IOpView (None,vs) -> Pp.(prlist_with_sep mt (fun c -> str "/" ++ Ssrprinters.pr_ast_closure_term c) vs) + | IOpView (Some cl,vs) -> Pp.(Ssrprinters.pr_clear Pp.spc cl ++ prlist_with_sep mt (fun c -> str "/" ++ Ssrprinters.pr_ast_closure_term c) vs) + + | IOpClear (clmust,clmay) -> + Pp.(Ssrprinters.pr_clear spc clmust ++ + match clmay with + | Some cl -> str "(try " ++ Ssrprinters.pr_clear spc [cl] ++ str")" + | None -> mt ()) + | IOpSimpl s -> Ssrprinters.pr_simpl s + + | IOpEqGen _ -> Pp.str "E:" + | IOpNoop -> Pp.str"-" +and ppl x = Pp.(prlist_with_sep (fun () -> str"|") (prlist_with_sep spc pr_ipatop)) x + + module IpatMachine : sig (* the => tactical. ?eqtac is a tactic to be eventually run * after the first [..] block. first_case_is_dispatch is the * ssr exception to elim: and case: *) val main : ?eqtac:unit tactic -> first_case_is_dispatch:bool -> - ssripats -> unit tactic + ssriops -> unit tactic + val tclCompileIPats : ssripats -> ssriops val tclSEED_SUBGOALS : Names.Name.t list array -> unit tactic -> unit tactic @@ -53,7 +117,7 @@ module State : sig val isNSEED_CONSUME : (Names.Name.t list option -> unit tactic) -> unit tactic (* Some data may expire *) - val isTICK : ssripat -> unit tactic + val isTICK : ssriop -> unit tactic val isPRINT : Proofview.Goal.t -> Pp.t @@ -149,7 +213,7 @@ let isNSEED_CONSUME k = k x) let isTICK = function - | IPatSimpl _ | IPatClear _ -> tclUNIT () + | IOpSimpl _ | IOpClear _ -> tclUNIT () | _ -> tclGET (fun s -> tclSET { s with name_seed = None }) end (* }}} *************************************************************** *) @@ -238,6 +302,13 @@ let tacCHECK_HYPS_EXIST hyps = Goal.enter begin fun gl -> tclUNIT () end +let tacFILTER_HYP_EXIST hyps k = Goal.enter begin fun gl -> + let ctx = Goal.hyps gl in + k (Option.bind hyps (fun h -> + if Ssrcommon.test_hyp_exists ctx h && + Ssrcommon.(not_section_id (hyp_id h)) then Some h else None)) +end + (** [=> []] *****************************************************************) (* calls t1 then t2 on each subgoal passing to t2 the index of the current @@ -286,13 +357,13 @@ let tac_intro_seed interp_ipats fix = Goal.enter begin fun gl -> | Prefix id -> Id.to_string id ^ "?" | SuffixNum n -> "?" ^ string_of_int n | SuffixId id -> "?" ^ Id.to_string id in - IPatAnon (One (Some s)) + IOpInaccessible (Some s) | Name id -> let s = match fix with | Prefix fix -> Id.to_string fix ^ Id.to_string id | SuffixNum n -> Id.to_string id ^ string_of_int n | SuffixId fix -> Id.to_string id ^ Id.to_string fix in - IPatId (Id.of_string s)) seeds in + IOpId (Id.of_string s)) seeds in interp_ipats ipats end end @@ -342,7 +413,7 @@ let tclMK_ABSTRACT_VARS ids = (* Debugging *) let tclLOG p t = tclUNIT () >>= begin fun () -> - Ssrprinters.ppdebug (lazy Pp.(str "exec: " ++ Ssrprinters.pr_ipat p)); + Ssrprinters.ppdebug (lazy Pp.(str "exec: " ++ pr_ipatop p)); tclUNIT () end <*> Goal.enter begin fun g -> @@ -362,58 +433,74 @@ let tclLOG p t = let notTAC = tclUNIT false +let duplicate_clear = + CWarnings.create ~name:"duplicate-clear" ~category:"ssr" + (fun id -> Pp.(str "Duplicate clear of " ++ Id.print id)) + (* returns true if it was a tactic (eg /ltac:tactic) *) let rec ipat_tac1 ipat : bool tactic = match ipat with - | IPatView (clear_if_id,l) -> + | IOpView (glued_clear,l) -> + let clear_if_id, extra_clear = + match glued_clear with + | None -> false, [] + | Some x -> true, List.map Ssrcommon.hyp_id x in Ssrview.tclIPAT_VIEWS ~views:l ~clear_if_id - ~conclusion:(fun ~to_clear:clr -> intro_clear clr) + ~conclusion:(fun ~to_clear:clr -> + let inter = CList.intersect Id.equal clr extra_clear in + List.iter duplicate_clear inter; + let cl = CList.union Id.equal clr extra_clear in + intro_clear cl) - | IPatDispatch(true, Regular [[]]) -> - notTAC - | IPatDispatch(_, Regular ipatss) -> + | IOpDispatchBranches ipatss -> tclDISPATCH (List.map ipat_tac ipatss) <*> notTAC - | IPatDispatch(_,Block id_block) -> + | IOpDispatchBlock id_block -> tac_intro_seed ipat_tac id_block <*> notTAC - - | IPatId id -> Ssrcommon.tclINTRO_ID id <*> notTAC - | IPatFastNondep -> intro_anon_deps <*> notTAC - - | IPatCase (Block id_block) -> + | IOpCaseBlock id_block -> Ssrcommon.tclWITHTOP tac_case <*> tac_intro_seed ipat_tac id_block <*> notTAC - | IPatCase (Regular ipatss) -> + | IOpCaseBranches ipatss -> tclIORPAT (Ssrcommon.tclWITHTOP tac_case) ipatss <*> notTAC - | IPatInj ipatss -> + + | IOpId id -> Ssrcommon.tclINTRO_ID id <*> notTAC + | IOpFastNondep -> intro_anon_deps <*> notTAC + | IOpDrop -> intro_drop <*> notTAC + | IOpInaccessible seed -> Ssrcommon.tclINTRO_ANON ?seed () <*> notTAC + | IOpInaccessibleAll -> intro_anon_all <*> notTAC + | IOpTemporay -> intro_anon_temp <*> notTAC + + | IOpSimpl Nop -> assert false + + | IOpInj ipatss -> tclIORPAT (Ssrcommon.tclWITHTOP (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) ipatss <*> notTAC - | IPatAnon Drop -> intro_drop <*> notTAC - | IPatAnon (One seed) -> Ssrcommon.tclINTRO_ANON ?seed () <*> notTAC - | IPatAnon All -> intro_anon_all <*> notTAC - | IPatAnon Temporary -> intro_anon_temp <*> notTAC - - | IPatNoop -> notTAC - | IPatSimpl Nop -> notTAC - - | IPatClear ids -> - tacCHECK_HYPS_EXIST ids <*> - intro_clear (List.map Ssrcommon.hyp_id ids) <*> + | IOpClear (must,may) -> + tacCHECK_HYPS_EXIST must <*> + tacFILTER_HYP_EXIST may (fun may -> + let must = List.map Ssrcommon.hyp_id must in + let cl = Option.fold_left (fun cls (SsrHyp(_,id)) -> + if CList.mem_f Id.equal id cls then begin + duplicate_clear id; + cls + end else id :: cls) must may in + intro_clear cl) <*> notTAC - | IPatSimpl x -> + | IOpSimpl x -> V82.tactic ~nf_evars:false (Ssrequality.simpltac x) <*> notTAC - | IPatRewrite (occ,dir) -> + | IOpRewrite (occ,dir) -> Ssrcommon.tclWITHTOP (fun x -> V82.tactic ~nf_evars:false (Ssrequality.ipat_rewrite occ dir x)) <*> notTAC - | IPatAbstractVars ids -> tclMK_ABSTRACT_VARS ids <*> notTAC + | IOpAbstractVars ids -> tclMK_ABSTRACT_VARS ids <*> notTAC - | IPatEqGen t -> t <*> notTAC + | IOpEqGen t -> t <*> notTAC + | IOpNoop -> notTAC and ipat_tac pl : unit tactic = match pl with @@ -433,51 +520,88 @@ and tclIORPAT tac = function | p -> Tacticals.New.tclTHENS tac (List.map ipat_tac p) and ssr_exception is_on = function - | Some (IPatCase l) when is_on -> Some (IPatDispatch(true, l)) + | Some (IOpCaseBranches [[]]) when is_on -> Some IOpNoop + | Some (IOpCaseBranches l) when is_on -> + Some (IOpDispatchBranches l) + | Some (IOpCaseBlock s) when is_on -> + Some (IOpDispatchBlock s) | x -> x and option_to_list = function None -> [] | Some x -> [x] and split_at_first_case ipats = let rec loop acc = function - | (IPatSimpl _ | IPatClear _) as x :: rest -> loop (x :: acc) rest - | (IPatCase _ | IPatDispatch _) as x :: xs -> CList.rev acc, Some x, xs + | (IOpSimpl _ | IOpClear _) as x :: rest -> loop (x :: acc) rest + | (IOpCaseBlock _ | IOpCaseBranches _ + | IOpDispatchBlock _ | IOpDispatchBranches _) as x :: xs -> + CList.rev acc, Some x, xs | pats -> CList.rev acc, None, pats in loop [] ipats ;; (* Simple pass doing {x}/v -> /v{x} *) -let elaborate_ipats l = +let tclCompileIPats l = let rec elab = function + + | (IPatClear cl) :: (IPatView v) :: rest -> + (IOpView(Some cl,v)) :: elab rest + | (IPatClear cl) :: (IPatId id) :: rest -> + (IOpClear (cl,Some (SsrHyp(None,id)))) :: IOpId id :: elab rest + + (* boring code *) | [] -> [] - | (IPatClear _ as p1) :: (IPatView _ as p2) :: rest -> p2 :: p1 :: elab rest - | IPatDispatch(s, Regular p) :: rest -> IPatDispatch (s, Regular (List.map elab p)) :: elab rest - | IPatCase (Regular p) :: rest -> IPatCase (Regular (List.map elab p)) :: elab rest - | IPatInj p :: rest -> IPatInj (List.map elab p) :: elab rest - | (IPatEqGen _ | IPatId _ | IPatSimpl _ | IPatClear _ | IPatFastNondep | - IPatAnon _ | IPatView _ | IPatNoop | IPatRewrite _ | - IPatAbstractVars _ | IPatDispatch(_, Block _) | IPatCase(Block _)) as x :: rest -> x :: elab rest - in - elab l -let main ?eqtac ~first_case_is_dispatch ipats = - let ipats = elaborate_ipats ipats in - let ip_before, case, ip_after = split_at_first_case ipats in + | IPatId id :: rest -> IOpId id :: elab rest + | IPatAnon (One hint) ::rest -> IOpInaccessible hint :: elab rest + | IPatAnon Drop :: rest -> IOpDrop :: elab rest + | IPatAnon All :: rest -> IOpInaccessibleAll :: elab rest + | IPatAnon Temporary :: rest -> IOpTemporay :: elab rest + | IPatAbstractVars vs :: rest -> IOpAbstractVars vs :: elab rest + | IPatFastNondep :: rest -> IOpFastNondep :: elab rest + + | IPatInj pats :: rest -> IOpInj (List.map elab pats) :: elab rest + | IPatRewrite(occ,dir) :: rest -> IOpRewrite(occ,dir) :: elab rest + | IPatView vs :: rest -> IOpView (None,vs) :: elab rest + | IPatSimpl s :: rest -> IOpSimpl s :: elab rest + | IPatClear cl :: rest -> IOpClear (cl,None) :: elab rest + + | IPatCase (Block seed) :: rest -> IOpCaseBlock seed :: elab rest + | IPatCase (Regular bs) :: rest -> IOpCaseBranches (List.map elab bs) :: elab rest + | IPatDispatch (Block seed) :: rest -> IOpDispatchBlock seed :: elab rest + | IPatDispatch (Regular bs) :: rest -> IOpDispatchBranches (List.map elab bs) :: elab rest + | IPatNoop :: rest -> IOpNoop :: elab rest + + in + elab l +;; +let tclCompileIPats l = + Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats input: " ++ + prlist_with_sep spc Ssrprinters.pr_ipat l)); + let ops = tclCompileIPats l in + Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats output: " ++ + prlist_with_sep spc pr_ipatop ops)); + ops + +let main ?eqtac ~first_case_is_dispatch iops = + let ip_before, case, ip_after = split_at_first_case iops in let case = ssr_exception first_case_is_dispatch case in let case = option_to_list case in - let eqtac = option_to_list (Option.map (fun x -> IPatEqGen x) eqtac) in - Ssrcommon.tcl0G ~default:() (ipat_tac (ip_before @ case @ eqtac @ ip_after) <*> intro_end) + let eqtac = option_to_list (Option.map (fun x -> IOpEqGen x) eqtac) in + let ipats = ip_before @ case @ eqtac @ ip_after in + Ssrcommon.tcl0G ~default:() (ipat_tac ipats <*> intro_end) end (* }}} *) let tclIPAT_EQ eqtac ip = Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); - IpatMachine.main ~eqtac ~first_case_is_dispatch:true ip + IpatMachine.(main ~eqtac ~first_case_is_dispatch:true (tclCompileIPats ip)) let tclIPATssr ip = Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); - IpatMachine.main ~first_case_is_dispatch:true ip + IpatMachine.(main ~first_case_is_dispatch:true (tclCompileIPats ip)) + +let tclCompileIPats = IpatMachine.tclCompileIPats (* Common code to handle generalization lists along with the defective case *) let with_defective maintac deps clr = Goal.enter begin fun g -> @@ -721,12 +845,12 @@ let eqmovetac _ gen = ;; let rec eqmoveipats eqpat = function - | (IPatSimpl _ | IPatClear _ as ipat) :: ipats -> + | (IOpSimpl _ | IOpClear _ as ipat) :: ipats -> ipat :: eqmoveipats eqpat ipats - | (IPatAnon All :: _ | []) as ipats -> - IPatAnon (One None) :: eqpat :: ipats + | (IOpInaccessibleAll :: _ | []) as ipats -> + IOpInaccessible None :: eqpat @ ipats | ipat :: ipats -> - ipat :: eqpat :: ipats + ipat :: eqpat @ ipats let ssrsmovetac = Goal.enter begin fun g -> let sigma, concl = Goal.(sigma g, concl g) in @@ -736,7 +860,6 @@ let ssrsmovetac = Goal.enter begin fun g -> end let tclIPAT ip = - Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); IpatMachine.main ~first_case_is_dispatch:false ip let ssrmovetac = function @@ -748,17 +871,17 @@ let ssrmovetac = function gentac <*> tclLAST_GEN ~to_ind:false lastgen (tacVIEW_THEN_GRAB view ~conclusion) <*> - tclIPAT (IPatClear clr :: ipats) + tclIPAT (IOpClear (clr,None) :: IpatMachine.tclCompileIPats ipats) | _::_ as view, (_, ({ gens = []; clr }, ipats)) -> - tclIPAT (IPatView (false,view) :: IPatClear clr :: ipats) + tclIPAT (IOpView (None,view) :: IOpClear (clr,None) :: IpatMachine.tclCompileIPats ipats) | _, (Some pat, (dgens, ipats)) -> let dgentac = with_dgens dgens eqmovetac in - dgentac <*> tclIPAT (eqmoveipats pat ipats) + dgentac <*> tclIPAT (eqmoveipats (IpatMachine.tclCompileIPats [pat]) (IpatMachine.tclCompileIPats ipats)) | _, (_, ({ gens = (_ :: _ as gens); dgens = []; clr}, ipats)) -> let gentac = V82.tactic ~nf_evars:false (Ssrcommon.genstac (gens, clr)) in - gentac <*> tclIPAT ipats + gentac <*> tclIPAT (IpatMachine.tclCompileIPats ipats) | _, (_, ({ clr }, ipats)) -> - Tacticals.New.tclTHENLIST [ssrsmovetac; Tactics.clear (List.map Ssrcommon.hyp_id clr); tclIPAT ipats] + Tacticals.New.tclTHENLIST [ssrsmovetac; Tactics.clear (List.map Ssrcommon.hyp_id clr); tclIPAT (IpatMachine.tclCompileIPats ipats)] (** [abstract: absvar gens] **************************************************) let rec is_Evar_or_CastedMeta sigma x = diff --git a/plugins/ssr/ssripats.mli b/plugins/ssr/ssripats.mli index 89cba4be71..893061b154 100644 --- a/plugins/ssr/ssripats.mli +++ b/plugins/ssr/ssripats.mli @@ -19,8 +19,44 @@ open Ssrast +(* Atomic operations for the IPat machine. Use this if you are "patching" an + * ipat written by the user, since patching it at he AST level and then + * compiling it may have tricky effects, eg adding a clear in front of a view + * also has the effect of disposing the view (the compilation phase takes care + * of this, by using the compiled ipats you can be more precise *) +type ssriop = + | IOpId of Names.Id.t + | IOpDrop + | IOpTemporay + | IOpInaccessible of string option + | IOpInaccessibleAll + | IOpAbstractVars of Names.Id.t list + | IOpFastNondep + + | IOpInj of ssriops list + + | IOpDispatchBlock of id_block + | IOpDispatchBranches of ssriops list + + | IOpCaseBlock of id_block + | IOpCaseBranches of ssriops list + + | IOpRewrite of ssrocc * ssrdir + | IOpView of ssrclear option * ssrview (* extra clears to be performed *) + + | IOpClear of ssrclear * ssrhyp option + | IOpSimpl of ssrsimpl + + | IOpEqGen of unit Proofview.tactic (* generation of eqn *) + + | IOpNoop + +and ssriops = ssriop list + +val tclCompileIPats : ssripats -> ssriops + (* The => tactical *) -val tclIPAT : ssripats -> unit Proofview.tactic +val tclIPAT : ssriops -> unit Proofview.tactic (* As above but with the SSR exception: first case is dispatch *) val tclIPATssr : ssripats -> unit Proofview.tactic diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 76726009ac..3fb21e5ef6 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -635,11 +635,10 @@ let rec map_ipat map_id map_ssrhyp map_ast_closure_term = function | IPatClear clr -> IPatClear (List.map map_ssrhyp clr) | IPatCase (Regular iorpat) -> IPatCase (Regular (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat)) | IPatCase (Block(hat)) -> IPatCase (Block(map_block map_id hat)) - | IPatDispatch (s, Regular iorpat) -> IPatDispatch (s, Regular (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat)) - | IPatDispatch (s, Block (hat)) -> IPatDispatch (s, Block(map_block map_id hat)) + | IPatDispatch (Regular iorpat) -> IPatDispatch (Regular (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat)) + | IPatDispatch (Block (hat)) -> IPatDispatch (Block(map_block map_id hat)) | IPatInj iorpat -> IPatInj (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) - | IPatView (clr,v) -> IPatView (clr,List.map map_ast_closure_term v) - | IPatEqGen _ -> assert false (*internal usage only *) + | IPatView v -> IPatView (List.map map_ast_closure_term v) and map_block map_id = function | Prefix id -> Prefix (map_id id) | SuffixId id -> SuffixId (map_id id) @@ -715,22 +714,22 @@ let interp_ipat ist gl = if not (ltacvar id) then hyp :: hyps else add_intro_pattern_hyps CAst.(make ?loc (interp_introid ist gl id)) hyps in let clr' = List.fold_right add_hyps clr [] in - check_hyps_uniq [] clr'; IPatClear clr' + check_hyps_uniq [] clr'; + IPatClear clr' | IPatCase(Regular iorpat) -> IPatCase(Regular(List.map (List.map interp) iorpat)) | IPatCase(Block(hat)) -> IPatCase(Block(interp_block hat)) - | IPatDispatch(s,Regular iorpat) -> - IPatDispatch(s,Regular (List.map (List.map interp) iorpat)) - | IPatDispatch(s,Block(hat)) -> IPatDispatch(s,Block(interp_block hat)) + | IPatDispatch(Regular iorpat) -> + IPatDispatch(Regular (List.map (List.map interp) iorpat)) + | IPatDispatch(Block(hat)) -> IPatDispatch(Block(interp_block hat)) | IPatInj iorpat -> IPatInj (List.map (List.map interp) iorpat) | IPatAbstractVars l -> IPatAbstractVars (List.map get_intro_id (List.map (interp_introid ist gl) l)) - | IPatView (clr,l) -> IPatView (clr,List.map (fun x -> snd(interp_ast_closure_term ist + | IPatView l -> IPatView (List.map (fun x -> snd(interp_ast_closure_term ist gl x)) l) | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop | IPatFastNondep) as x -> x - | IPatEqGen _ -> assert false (*internal usage only *) in interp @@ -765,10 +764,6 @@ ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY { pr_ssripats } | Some [], _ -> CErrors.user_err ~loc (str"occ_switch expected") | None, occ -> [IPatRewrite (occ, R2L)] | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, R2L)] } - | [ ssrdocc(occ) ssrfwdview(v) ] -> { match occ with - | Some [], _ -> [IPatView (true,v)] - | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl;IPatView (false,v)] - | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here") } | [ ssrdocc(occ) ] -> { match occ with | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl] | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here") } @@ -786,7 +781,7 @@ ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY { pr_ssripats } | [ "-/" integer(n) "/=" ] -> { [IPatNoop;IPatSimpl(SimplCut (n,~-1))] } | [ "-/" integer(n) "/" integer (m) "=" ] -> { [IPatNoop;IPatSimpl(SimplCut(n,m))] } - | [ ssrfwdview(v) ] -> { [IPatView (false,v)] } + | [ ssrfwdview(v) ] -> { [IPatView v] } | [ "[" ":" ident_list(idl) "]" ] -> { [IPatAbstractVars idl] } | [ "[:" ident_list(idl) "]" ] -> { [IPatAbstractVars idl] } END @@ -875,11 +870,12 @@ ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY { pr_ssripats } let check_ssrhpats loc w_binders ipats = let err_loc s = CErrors.user_err ~loc ~hdr:"ssreflect" s in let clr, ipats = + let opt_app = function None -> fun l -> Some l + | Some l1 -> fun l2 -> Some (l1 @ l2) in let rec aux clr = function - | IPatClear cl :: tl -> aux (clr @ cl) tl -(* | IPatSimpl (cl, sim) :: tl -> clr @ cl, IPatSimpl ([], sim) :: tl *) + | IPatClear cl :: tl -> aux (opt_app clr cl) tl | tl -> clr, tl - in aux [] ipats in + in aux None ipats in let simpl, ipats = match List.rev ipats with | IPatSimpl _ as s :: tl -> [s], List.rev tl @@ -903,27 +899,29 @@ let check_ssrhpats loc w_binders ipats = in loop [] ipats in ((clr, ipat), binders), simpl +let pr_clear_opt sep = function None -> mt () | Some x -> pr_clear sep x + let pr_hpats (((clr, ipat), binders), simpl) = - pr_clear mt clr ++ pr_ipats ipat ++ pr_ipats binders ++ pr_ipats simpl + pr_clear_opt mt clr ++ pr_ipats ipat ++ pr_ipats binders ++ pr_ipats simpl let pr_ssrhpats _ _ _ = pr_hpats let pr_ssrhpats_wtransp _ _ _ (_, x) = pr_hpats x } -ARGUMENT EXTEND ssrhpats TYPED AS (((ssrclear * ssripat) * ssripat) * ssripat) +ARGUMENT EXTEND ssrhpats TYPED AS (((ssrclear option * ssripat) * ssripat) * ssripat) PRINTED BY { pr_ssrhpats } | [ ssripats(i) ] -> { check_ssrhpats loc true i } END ARGUMENT EXTEND ssrhpats_wtransp - TYPED AS (bool * (((ssrclear * ssripats) * ssripats) * ssripats)) + TYPED AS (bool * (((ssrclear option * ssripats) * ssripats) * ssripats)) PRINTED BY { pr_ssrhpats_wtransp } | [ ssripats(i) ] -> { false,check_ssrhpats loc true i } | [ ssripats(i) "@" ssripats(j) ] -> { true,check_ssrhpats loc true (i @ j) } END ARGUMENT EXTEND ssrhpats_nobs -TYPED AS (((ssrclear * ssripats) * ssripats) * ssripats) PRINTED BY { pr_ssrhpats } +TYPED AS (((ssrclear option * ssripats) * ssripats) * ssripats) PRINTED BY { pr_ssrhpats } | [ ssripats(i) ] -> { check_ssrhpats loc false i } END @@ -2051,7 +2049,7 @@ END (* We just add a numeric version that clears the n top assumptions. *) TACTIC EXTEND ssrclear - | [ "clear" natural(n) ] -> { tclIPAT (List.init n (fun _ -> IPatAnon Drop)) } + | [ "clear" natural(n) ] -> { tclIPAT (List.init n (fun _ -> IOpDrop)) } END (** The "move" tactic *) @@ -2090,10 +2088,10 @@ let movearg_of_parsed_movearg (v,(eq,(dg,ip))) = TACTIC EXTEND ssrmove | [ "move" ssrmovearg(arg) ssrrpat(pat) ] -> - { ssrmovetac (movearg_of_parsed_movearg arg) <*> tclIPAT [pat] } + { ssrmovetac (movearg_of_parsed_movearg arg) <*> tclIPAT (tclCompileIPats [pat]) } | [ "move" ssrmovearg(arg) ssrclauses(clauses) ] -> { tclCLAUSES (ssrmovetac (movearg_of_parsed_movearg arg)) clauses } -| [ "move" ssrrpat(pat) ] -> { tclIPAT [pat] } +| [ "move" ssrrpat(pat) ] -> { tclIPAT (tclCompileIPats [pat]) } | [ "move" ] -> { ssrsmovetac } END @@ -2632,7 +2630,11 @@ END { -let augment_preclr clr1 (((clr0, x),y),z) = (((clr1 @ clr0, x),y),z) +let augment_preclr clr1 (((clr0, x),y),z) = + let cl = match clr0 with + | None -> if clr1 = [] then None else Some clr1 + | Some clr0 -> Some (clr1 @ clr0) in + (((cl, x),y),z) } diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 898e03b00e..38f5b7d107 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -74,7 +74,7 @@ let pr_occ = function | None -> str "{}" let pr_clear_ne clr = str "{" ++ pr_hyps clr ++ str "}" -let pr_clear sep clr = if clr = [] then mt () else sep () ++ pr_clear_ne clr +let pr_clear sep clr = sep () ++ pr_clear_ne clr let pr_dir = function L2R -> str "->" | R2L -> str "<-" @@ -102,20 +102,18 @@ let rec pr_ipat p = | IPatClear clr -> pr_clear mt clr | IPatCase (Regular iorpat) -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") | IPatCase (Block m) -> hov 1 (str"[" ++ pr_block m ++ str"]") - | IPatDispatch(_,Regular iorpat) -> hov 1 (str "(" ++ pr_iorpat iorpat ++ str ")") - | IPatDispatch (_,Block m) -> hov 1 (str"(" ++ pr_block m ++ str")") + | IPatDispatch(Regular iorpat) -> hov 1 (str "(" ++ pr_iorpat iorpat ++ str ")") + | IPatDispatch (Block m) -> hov 1 (str"(" ++ pr_block m ++ str")") | IPatInj iorpat -> hov 1 (str "[=" ++ pr_iorpat iorpat ++ str "]") | IPatRewrite (occ, dir) -> pr_occ occ ++ pr_dir dir | IPatAnon All -> str "*" | IPatAnon Drop -> str "_" | IPatAnon (One _) -> str "?" - | IPatView (false,v) -> pr_view2 v - | IPatView (true,v) -> str"{}" ++ pr_view2 v + | IPatView v -> pr_view2 v | IPatAnon Temporary -> str "+" | IPatNoop -> str "-" | IPatAbstractVars l -> str "[:" ++ pr_list spc Id.print l ++ str "]" | IPatFastNondep -> str">" - | IPatEqGen _ -> str "<tac>" and pr_ipats ipats = pr_list spc pr_ipat ipats and pr_iorpat iorpat = pr_list pr_bar pr_ipats iorpat and pr_block = function (Prefix id) -> str"^" ++ Id.print id diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli index 31c360ad6d..5f20ac2705 100644 --- a/plugins/ssr/ssrprinters.mli +++ b/plugins/ssr/ssrprinters.mli @@ -43,6 +43,7 @@ val pr_view2 : ast_closure_term list -> Pp.t val pr_ipat : ssripat -> Pp.t val pr_ipats : ssripats -> Pp.t val pr_iorpat : ssripatss -> Pp.t +val pr_block : id_block -> Pp.t val pr_hyp : ssrhyp -> Pp.t val pr_hyps : ssrhyps -> Pp.t diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 4816027296..2794696017 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -142,7 +142,7 @@ let intern_constr_expr { Genintern.genv; ltacvars = vars } sigma ce = To allow for t being a notation, like "Notation foo x := ltac:(foo x)", we need to internalize t. *) -let is_tac_in_term ?extra_scope { body; glob_env; interp_env } = +let is_tac_in_term ?extra_scope { annotation; body; glob_env; interp_env } = Goal.(enter_one ~__LOC__ begin fun goal -> let genv = env goal in let sigma = sigma goal in @@ -161,7 +161,7 @@ let is_tac_in_term ?extra_scope { body; glob_env; interp_env } = | Glob_term.GHole (_,_, Some x) when Genarg.has_type x (Genarg.glbwit Tacarg.wit_tactic) -> tclUNIT (`Tac (Genarg.out_gen (Genarg.glbwit Tacarg.wit_tactic) x)) - | _ -> tclUNIT (`Term (interp_env, g)) + | _ -> tclUNIT (`Term (annotation, interp_env, g)) end) (* To inject a constr into a glob_constr we use an Ltac variable *) @@ -207,7 +207,7 @@ let tclKeepOpenConstr (_env, sigma, t) = Unsafe.tclEVARS sigma <*> tclUNIT t let tclADD_CLEAR_IF_ID (env, ist, t) x = Ssrprinters.ppdebug (lazy Pp.(str"tclADD_CLEAR_IF_ID: " ++ Printer.pr_econstr_env env ist t)); - let hd, _ = EConstr.decompose_app ist t in + let hd, args = EConstr.decompose_app ist t in match EConstr.kind ist hd with | Constr.Var id when Ssrcommon.not_section_id id -> tclUNIT (x, [id]) | _ -> tclUNIT (x,[]) @@ -280,8 +280,9 @@ let interp_view ~clear_if_id ist v p = else tclKeepOpenConstr ot >>= tclPAIR [] (* we store in the state (v top), then (v1 (v2 top))... *) -let pile_up_view ~clear_if_id (ist, v) = +let pile_up_view ~clear_if_id (annotation, ist, v) = let ist = Ssrcommon.option_assert_get ist (Pp.str"not a term") in + let clear_if_id = clear_if_id && annotation <> `Parens in State.vsPUSH (fun p -> interp_view ~clear_if_id ist v p) let finalize_view s0 ?(simple_types=true) p = diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 470deb4a60..ea564ae2ba 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -33,30 +33,41 @@ let get_constructors ind = Array.to_list (Array.mapi (fun j c -> ConstructRef (ind, j + 1)) mc) -let q_z = qualid_of_string "Coq.Numbers.BinNums.Z" -let q_positive = qualid_of_string "Coq.Numbers.BinNums.positive" -let q_int = qualid_of_string "Coq.Init.Decimal.int" -let q_uint = qualid_of_string "Coq.Init.Decimal.uint" -let q_option = qualid_of_string "Coq.Init.Datatypes.option" +let qualid_of_ref n = + n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty + +let q_option () = qualid_of_ref "core.option.type" let unsafe_locate_ind q = match Nametab.locate q with | IndRef i -> i | _ -> raise Not_found -let locate_ind q = - try unsafe_locate_ind q - with Not_found -> Nametab.error_global_not_found q - let locate_z () = - try - Some { z_ty = unsafe_locate_ind q_z; - pos_ty = unsafe_locate_ind q_positive } - with Not_found -> None + let zn = "num.Z.type" in + let pn = "num.pos.type" in + if Coqlib.has_ref zn && Coqlib.has_ref pn + then + let q_z = qualid_of_ref zn in + let q_pos = qualid_of_ref pn in + Some ({ + z_ty = unsafe_locate_ind q_z; + pos_ty = unsafe_locate_ind q_pos; + }, mkRefC q_z) + else None let locate_int () = - { uint = locate_ind q_uint; - int = locate_ind q_int } + let int = "num.int.type" in + let uint = "num.uint.type" in + if Coqlib.has_ref int && Coqlib.has_ref uint + then + let q_int = qualid_of_ref int in + let q_uint = qualid_of_ref uint in + Some ({ + int = unsafe_locate_ind q_int; + uint = unsafe_locate_ind q_uint; + }, mkRefC q_int, mkRefC q_uint) + else None let has_type f ty = let (sigma, env) = Pfedit.get_current_context () in @@ -64,19 +75,17 @@ let has_type f ty = try let _ = Constrintern.interp_constr env sigma c in true with Pretype_errors.PretypeError _ -> false -let type_error_to f ty loadZ = +let type_error_to f ty = CErrors.user_err (pr_qualid f ++ str " should go from Decimal.int to " ++ pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ - fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z could be used" ++ - (if loadZ then str " (require BinNums first)." else str ".")) + fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first).") -let type_error_of g ty loadZ = +let type_error_of g ty = CErrors.user_err (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Decimal.int or (option Decimal.int)." ++ fnl () ++ - str "Instead of Decimal.int, the types Decimal.uint or Z could be used" ++ - (if loadZ then str " (require BinNums first)." else str ".")) + str "Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first).") let vernac_numeral_notation local ty f g scope opts = let int_ty = locate_int () in @@ -86,43 +95,36 @@ let vernac_numeral_notation local ty f g scope opts = let of_ty = Smartlocate.global_with_alias g in let cty = mkRefC ty in let app x y = mkAppC (x,[y]) in - let cref q = mkRefC q in let arrow x y = mkProdC ([CAst.make Anonymous],Default Decl_kinds.Explicit, x, y) in - let cZ = cref q_z in - let cint = cref q_int in - let cuint = cref q_uint in - let coption = cref q_option in - let opt r = app coption r in + let opt r = app (mkRefC (q_option ())) r in let constructors = get_constructors tyc in (* Check the type of f *) let to_kind = - if has_type f (arrow cint cty) then Int int_ty, Direct - else if has_type f (arrow cint (opt cty)) then Int int_ty, Option - else if has_type f (arrow cuint cty) then UInt int_ty.uint, Direct - else if has_type f (arrow cuint (opt cty)) then UInt int_ty.uint, Option - else - match z_pos_ty with - | Some z_pos_ty -> - if has_type f (arrow cZ cty) then Z z_pos_ty, Direct - else if has_type f (arrow cZ (opt cty)) then Z z_pos_ty, Option - else type_error_to f ty false - | None -> type_error_to f ty true + match int_ty with + | Some (int_ty, cint, _) when has_type f (arrow cint cty) -> Int int_ty, Direct + | Some (int_ty, cint, _) when has_type f (arrow cint (opt cty)) -> Int int_ty, Option + | Some (int_ty, _, cuint) when has_type f (arrow cuint cty) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint) when has_type f (arrow cuint (opt cty)) -> UInt int_ty.uint, Option + | _ -> + match z_pos_ty with + | Some (z_pos_ty, cZ) when has_type f (arrow cZ cty) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type f (arrow cZ (opt cty)) -> Z z_pos_ty, Option + | _ -> type_error_to f ty in (* Check the type of g *) let of_kind = - if has_type g (arrow cty cint) then Int int_ty, Direct - else if has_type g (arrow cty (opt cint)) then Int int_ty, Option - else if has_type g (arrow cty cuint) then UInt int_ty.uint, Direct - else if has_type g (arrow cty (opt cuint)) then UInt int_ty.uint, Option - else - match z_pos_ty with - | Some z_pos_ty -> - if has_type g (arrow cty cZ) then Z z_pos_ty, Direct - else if has_type g (arrow cty (opt cZ)) then Z z_pos_ty, Option - else type_error_of g ty false - | None -> type_error_of g ty true + match int_ty with + | Some (int_ty, cint, _) when has_type g (arrow cty cint) -> Int int_ty, Direct + | Some (int_ty, cint, _) when has_type g (arrow cty (opt cint)) -> Int int_ty, Option + | Some (int_ty, _, cuint) when has_type g (arrow cty cuint) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint) when has_type g (arrow cty (opt cuint)) -> UInt int_ty.uint, Option + | _ -> + match z_pos_ty with + | Some (z_pos_ty, cZ) when has_type g (arrow cty cZ) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type g (arrow cty (opt cZ)) -> Z z_pos_ty, Option + | _ -> type_error_of g ty in let o = { to_kind; to_ty; of_kind; of_ty; ty_name = ty; diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 0ace11839e..08df9a2460 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -43,7 +43,7 @@ let subst_rename_args (subst, (_, (r, names as orig))) = if r==r' then orig else (r', names) let discharge_rename_args = function - | _, (ReqGlobal (c, names), _ as req) -> + | _, (ReqGlobal (c, names), _ as req) when not (isVarRef c && Lib.is_in_section c) -> (try let vars = Lib.variable_section_segment_of_reference c in let var_names = List.map (fst %> NamedDecl.get_id %> Name.mk_name) vars in diff --git a/proofs/goal_select.ml b/proofs/goal_select.ml index cef3fd3f5e..955d797227 100644 --- a/proofs/goal_select.ml +++ b/proofs/goal_select.ml @@ -45,7 +45,7 @@ let parse_goal_selector = function | "!" -> SelectAlreadyFocused | "all" -> SelectAll | i -> - let err_msg = "The default selector must be \"all\" or a natural number." in + let err_msg = "The default selector must be \"all\", \"!\" or a natural number." in begin try let i = int_of_string i in if i < 0 then CErrors.user_err Pp.(str err_msg); diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 4cc73f419e..9ee9e7ae2c 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -22,51 +22,6 @@ open Names module NamedDecl = Context.Named.Declaration -(*** Proof Modes ***) - -(* Type of proof modes : - - A function [set] to set it *from standard mode* - - A function [reset] to reset the *standard mode* from it *) -type proof_mode_name = string -type proof_mode = { - name : proof_mode_name ; - set : unit -> unit ; - reset : unit -> unit -} - -let proof_modes = Hashtbl.create 6 -let find_proof_mode n = - try Hashtbl.find proof_modes n - with Not_found -> - CErrors.user_err Pp.(str (Format.sprintf "No proof mode named \"%s\"." n)) - -let register_proof_mode ({name = n} as m) = - Hashtbl.add proof_modes n (CEphemeron.create m) - -(* initial mode: standard mode *) -let standard = { name = "No" ; set = (fun ()->()) ; reset = (fun () -> ()) } -let _ = register_proof_mode standard - -(* Default proof mode, to be set at the beginning of proofs. *) -let default_proof_mode = ref (find_proof_mode "No") - -let get_default_proof_mode_name () = - (CEphemeron.default !default_proof_mode standard).name - -let proof_mode_opt_name = ["Default";"Proof";"Mode"] -let () = - Goptions.(declare_string_option { - optdepr = false; - optname = "default proof mode" ; - optkey = proof_mode_opt_name ; - optread = begin fun () -> - (CEphemeron.default !default_proof_mode standard).name - end; - optwrite = begin fun n -> - default_proof_mode := find_proof_mode n - end - }) - (*** Proof Global Environment ***) (* Extra info on proofs. *) @@ -95,7 +50,6 @@ type pstate = { endline_tactic : Genarg.glob_generic_argument option; section_vars : Constr.named_context option; proof : Proof.t; - mode : proof_mode CEphemeron.key; universe_decl: UState.universe_decl; strength : Decl_kinds.goal_kind; } @@ -109,23 +63,8 @@ let apply_terminator f = f to be resumed when the current proof is closed or aborted. *) let pstates = ref ([] : pstate list) -(* Current proof_mode, for bookkeeping *) -let current_proof_mode = ref !default_proof_mode - -(* combinators for proof modes *) -let update_proof_mode () = - match !pstates with - | { mode = m } :: _ -> - CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); - current_proof_mode := m; - CEphemeron.iter_opt !current_proof_mode (fun x -> x.set ()) - | _ -> - CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); - current_proof_mode := find_proof_mode "No" - (* combinators for the current_proof lists *) -let push a l = l := a::!l; - update_proof_mode () +let push a l = l := a::!l exception NoSuchProof let () = CErrors.register_handler begin function @@ -221,25 +160,8 @@ let discard {CAst.loc;v=id} = let discard_current () = if List.is_empty !pstates then raise NoCurrentProof else pstates := List.tl !pstates - let discard_all () = pstates := [] -(* [set_proof_mode] sets the proof mode to be used after it's called. It is - typically called by the Proof Mode command. *) -let set_proof_mode m id = - pstates := List.map - (fun ps -> if pf_name_eq id ps then { ps with mode = m } else ps) - !pstates; - update_proof_mode () - -let set_proof_mode mn = - set_proof_mode (find_proof_mode mn) (get_current_proof_name ()) - -let activate_proof_mode mode = - CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ()) -let disactivate_current_proof_mode () = - CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()) - (** [start_proof sigma id pl str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this @@ -254,9 +176,8 @@ let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals terminator proof = Proof.start ~name ~poly:(pi2 kind) sigma goals; endline_tactic = None; section_vars = None; - mode = find_proof_mode "No"; - universe_decl = pl; - strength = kind } in + strength = kind; + universe_decl = pl } in push initial_state pstates let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals terminator = @@ -265,9 +186,8 @@ let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals termina proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals; endline_tactic = None; section_vars = None; - mode = find_proof_mode "No"; - universe_decl = pl; - strength = kind } in + strength = kind; + universe_decl = pl } in push initial_state pstates let get_used_variables () = (cur_pstate ()).section_vars @@ -478,7 +398,7 @@ end let freeze ~marshallable = if marshallable then CErrors.anomaly (Pp.str"full marshalling of proof state not supported.") else !pstates -let unfreeze s = pstates := s; update_proof_mode () +let unfreeze s = pstates := s let proof_of_state = function { proof }::_ -> proof | _ -> raise NoCurrentProof let copy_terminators ~src ~tgt = assert(List.length src = List.length tgt); diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index e762f3b7dc..40920f51a3 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -13,7 +13,6 @@ environment. *) type t - val there_are_pending_proofs : unit -> bool val check_no_pending_proof : unit -> unit @@ -139,47 +138,3 @@ val freeze : marshallable:bool -> t val unfreeze : t -> unit val proof_of_state : t -> Proof.t val copy_terminators : src:t -> tgt:t -> t - - -(**********************************************************) -(* Proof Mode API *) -(* The current Proof Mode API is deprecated and a new one *) -(* will be (hopefully) defined in 8.8 *) -(**********************************************************) - -(** Type of proof modes : - - A name - - A function [set] to set it *from standard mode* - - A function [reset] to reset the *standard mode* from it - -*) -type proof_mode_name = string -type proof_mode = { - name : proof_mode_name ; - set : unit -> unit ; - reset : unit -> unit -} - -(** Registers a new proof mode which can then be adressed by name - in [set_default_proof_mode]. - One mode is already registered - the standard mode - named "No", - It corresponds to Coq default setting are they are set when coqtop starts. *) -val register_proof_mode : proof_mode -> unit -(* Can't make this deprecated due to limitations of camlp5 *) -(* [@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] *) - -val proof_mode_opt_name : string list - -val get_default_proof_mode_name : unit -> proof_mode_name -[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] - -(** [set_proof_mode] sets the proof mode to be used after it's called. It is - typically called by the Proof Mode command. *) -val set_proof_mode : proof_mode_name -> unit -[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] - -val activate_proof_mode : proof_mode_name -> unit -[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] - -val disactivate_current_proof_mode : unit -> unit -[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 2f8129bbfd..be8ef24a09 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -118,18 +118,38 @@ module Make(T : Task) () = struct let spawn id = let name = Printf.sprintf "%s:%d" !T.name id in let proc, ic, oc = + (* Filter arguments for slaves. *) let rec set_slave_opt = function | [] -> !async_proofs_flags_for_workers @ ["-worker-id"; name; "-async-proofs-worker-priority"; - CoqworkmgrApi.(string_of_priority !async_proofs_worker_priority)] - | ("-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl - | ("-async-proofs" |"-vio2vo" + CoqworkmgrApi.(string_of_priority !async_proofs_worker_priority)] + (* Options to discard: 0 arguments *) + | ("-emacs"|"-emacs-U"|"-batch")::tl -> + set_slave_opt tl + (* Options to discard: 1 argument *) + | ("-async-proofs" |"-vio2vo" | "-o" |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv" |"-compile" |"-compile-verbose" + |"-async-proofs-cache" |"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl -> set_slave_opt tl - | x::tl -> x :: set_slave_opt tl in + (* We need to pass some options with one argument *) + | ( "-I" | "-include" | "-top" | "-topfile" | "-coqlib" | "-exclude-dir" | "-compat" + | "-load-ml-object" | "-load-ml-source" | "-require" | "-w" | "-color" | "-init-file" + | "-profile-ltac-cutoff" | "-main-channel" | "-control-channel" | "-mangle-names" + | "-diffs" | "-mangle-name" | "-dump-glob" | "-bytecode-compiler" | "-native-compiler" as x) :: a :: tl -> + x :: a :: set_slave_opt tl + (* We need to pass some options with two arguments *) + | ( "-R" | "-Q" as x) :: a1 :: a2 :: tl -> + x :: a1 :: a2 :: set_slave_opt tl + (* Finally we pass all options starting in '-'; check this is safe w.r.t the weird vio* option set *) + | x :: tl when x.[0] = '-' -> + x :: set_slave_opt tl + (* We assume this is a file, filter out *) + | _ :: tl -> + set_slave_opt tl + in let args = Array.of_list (set_slave_opt (List.tl (Array.to_list Sys.argv))) in let env = Array.append (T.extra_env ()) (Unix.environment ()) in diff --git a/stm/stm.ml b/stm/stm.ml index 8ed7f2c866..0165b3c029 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -126,8 +126,6 @@ type aast = { } let pr_ast { expr; indentation } = Pp.(int indentation ++ str " " ++ Ppvernac.pr_vernac expr) -let default_proof_mode () = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] - (* Commands piercing opaque *) let may_pierce_opaque = function | VernacPrint _ @@ -146,13 +144,13 @@ let update_global_env () = module Vcs_ = Vcs.Make(Stateid.Self) type future_proof = Proof_global.closed_proof_output Future.computation -type proof_mode = string + type depth = int type branch_type = [ `Master - | `Proof of proof_mode * depth + | `Proof of depth | `Edit of - proof_mode * Stateid.t * Stateid.t * Vernacextend.vernac_qed_type * Vcs_.Branch.t ] + Stateid.t * Stateid.t * Vernacextend.vernac_qed_type * Vcs_.Branch.t ] (* TODO 8.7 : split commands and tactics, since this type is too messy now *) type cmd_t = { ctac : bool; (* is a tactic *) @@ -203,10 +201,10 @@ let summary_pstate = Evarutil.meta_counter_summary_tag, Obligations.program_tcc_summary_tag type cached_state = - | Empty - | Error of Exninfo.iexn - | Valid of Vernacstate.t - + | EmptyState + | ParsingState of Vernacstate.Parser.state + | FullState of Vernacstate.t + | ErrorState of Vernacstate.Parser.state option * Exninfo.iexn type branch = Vcs_.Branch.t * branch_type Vcs_.branch_info type backup = { mine : branch; others : branch list } @@ -214,10 +212,16 @@ type 'vcs state_info = { (* TODO: Make this record private to VCS *) mutable n_reached : int; (* debug cache: how many times was computed *) mutable n_goals : int; (* open goals: indentation *) mutable state : cached_state; (* state value *) + mutable proof_mode : Pvernac.proof_mode option; mutable vcs_backup : 'vcs option * backup option; } -let default_info () = - { n_reached = 0; n_goals = 0; state = Empty; vcs_backup = None,None } +let default_info proof_mode = + { + n_reached = 0; n_goals = 0; + state = EmptyState; + proof_mode; + vcs_backup = (None,None); + } module DynBlockData : Dyn.S = Dyn.Make () @@ -256,15 +260,15 @@ end = struct (* {{{ *) List.fold_left max 0 (CList.map_filter (function - | { Vcs_.kind = `Proof (_,n) } -> Some n + | { Vcs_.kind = `Proof n } -> Some n | { Vcs_.kind = `Edit _ } -> Some 1 | _ -> None) (List.map (Vcs_.get_branch vcs) (Vcs_.branches vcs))) let find_proof_at_depth vcs pl = try List.find (function - | _, { Vcs_.kind = `Proof(m, n) } -> Int.equal n pl - | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.str "find_proof_at_depth.") + | _, { Vcs_.kind = `Proof n } -> Int.equal n pl + | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.str "find_proof_at_depth") | _ -> false) (List.map (fun h -> h, Vcs_.get_branch vcs h) (Vcs_.branches vcs)) with Not_found -> failwith "find_proof_at_depth" @@ -326,7 +330,7 @@ module VCS : sig type vcs = (branch_type, transaction, vcs state_info, box) Vcs_.t - val init : stm_doc_type -> id -> doc + val init : stm_doc_type -> id -> Vernacstate.Parser.state -> doc (* val get_type : unit -> stm_doc_type *) val set_ldir : Names.DirPath.t -> unit val get_ldir : unit -> Names.DirPath.t @@ -339,7 +343,7 @@ module VCS : sig val branches : unit -> Branch.t list val get_branch : Branch.t -> branch_type branch_info val get_branch_pos : Branch.t -> id - val new_node : ?id:Stateid.t -> unit -> id + val new_node : ?id:Stateid.t -> Pvernac.proof_mode option -> unit -> id val merge : id -> ours:transaction -> ?into:Branch.t -> Branch.t -> unit val rewrite_merge : id -> ours:transaction -> at:id -> Branch.t -> unit val delete_branch : Branch.t -> unit @@ -356,6 +360,10 @@ module VCS : sig val goals : id -> int -> unit val set_state : id -> cached_state -> unit val get_state : id -> cached_state + val set_parsing_state : id -> Vernacstate.Parser.state -> unit + val get_parsing_state : id -> Vernacstate.Parser.state option + val get_proof_mode : id -> Pvernac.proof_mode option + val set_proof_mode : id -> Pvernac.proof_mode option -> unit (* cuts from start -> stop, raising Expired if some nodes are not there *) val slice : block_start:id -> block_stop:id -> vcs @@ -369,7 +377,8 @@ module VCS : sig val proof_nesting : unit -> int val checkout_shallowest_proof_branch : unit -> unit - val propagate_sideff : action:seff_t -> unit + val propagate_sideff : action:seff_t -> Stateid.t list + val propagate_qed : unit -> unit val gc : unit -> unit @@ -411,11 +420,11 @@ end = struct (* {{{ *) | Qed { qast } -> Pp.string_of_ppcmds (pr_ast qast) in let is_green id = match get_info vcs id with - | Some { state = Valid _ } -> true + | Some { state = FullState _ } -> true | _ -> false in let is_red id = match get_info vcs id with - | Some { state = Error _ } -> true + | Some { state = ErrorState _ } -> true | _ -> false in let head = current_branch vcs in let heads = @@ -517,10 +526,11 @@ end = struct (* {{{ *) let doc_type = ref (Interactive (TopLogical (Names.DirPath.make []))) let ldir = ref Names.DirPath.empty - let init dt id = + let init dt id ps = doc_type := dt; vcs := empty id; - vcs := set_info !vcs id (default_info ()); + let info = { (default_info None) with state = ParsingState ps } in + vcs := set_info !vcs id info; dummy_doc let set_ldir ld = @@ -545,9 +555,9 @@ end = struct (* {{{ *) let branches () = branches !vcs let get_branch head = get_branch !vcs head let get_branch_pos head = (get_branch head).pos - let new_node ?(id=Stateid.fresh ()) () = + let new_node ?(id=Stateid.fresh ()) proof_mode () = assert(Vcs_.get_info !vcs id = None); - vcs := set_info !vcs id (default_info ()); + vcs := set_info !vcs id (default_info proof_mode); id let merge id ~ours ?into branch = vcs := merge !vcs id ~ours ~theirs:Noop ?into branch @@ -569,9 +579,39 @@ end = struct (* {{{ *) | Some x -> x | None -> raise Vcs_aux.Expired let set_state id s = - (get_info id).state <- s; - if async_proofs_is_master !cur_opt then Hooks.(call state_ready ~doc:dummy_doc (* XXX should be taken in input *) id) + let info = get_info id in + info.state <- s; + let is_full_state_valid = match s with + | FullState _ -> true + | EmptyState | ErrorState _ | ParsingState _ -> false + in + if async_proofs_is_master !cur_opt && is_full_state_valid then + Hooks.(call state_ready ~doc:dummy_doc (* XXX should be taken in input *) id) + let get_state id = (get_info id).state + + let get_parsing_state id = + stm_pperr_endline (fun () -> str "retrieve parsing state state " ++ str (Stateid.to_string id) ++ str " }}}"); + match (get_info id).state with + | FullState s -> Some s.Vernacstate.parsing + | ParsingState s -> Some s + | ErrorState (s,_) -> s + | EmptyState -> None + + let set_parsing_state id ps = + let info = get_info id in + let new_state = + match info.state with + | FullState s -> assert false + | ParsingState s -> assert false + | ErrorState _ -> assert false + | EmptyState -> ParsingState ps + in + info.state <- new_state + + let get_proof_mode id = (get_info id).proof_mode + let set_proof_mode id pm = (get_info id).proof_mode <- pm + let reached id = let info = get_info id in info.n_reached <- info.n_reached + 1 @@ -582,28 +622,33 @@ end = struct (* {{{ *) let checkout_shallowest_proof_branch () = if List.mem edit_branch (Vcs_.branches !vcs) then begin - checkout edit_branch; - match get_branch edit_branch with - | { kind = `Edit (mode, _,_,_,_) } -> Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] - | _ -> assert false + checkout edit_branch end else let pl = proof_nesting () in try - let branch, mode = match Vcs_aux.find_proof_at_depth !vcs pl with - | h, { Vcs_.kind = `Proof (m, _) } -> h, m | _ -> assert false in - checkout branch; - stm_prerr_endline (fun () -> "mode:" ^ mode); - Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] + let branch = fst @@ Vcs_aux.find_proof_at_depth !vcs pl in + checkout branch with Failure _ -> - checkout Branch.master; - Proof_global.disactivate_current_proof_mode () [@ocaml.warning "-3"] + checkout Branch.master (* copies the transaction on every open branch *) let propagate_sideff ~action = + List.map (fun b -> + checkout b; + let proof_mode = get_proof_mode @@ get_branch_pos b in + let id = new_node proof_mode () in + merge id ~ours:(Sideff action) ~into:b Branch.master; + id) + (List.filter (fun b -> not (Branch.equal b Branch.master)) (branches ())) + + let propagate_qed () = List.iter (fun b -> checkout b; - let id = new_node () in - merge id ~ours:(Sideff action) ~into:b Branch.master) + let proof_mode = get_proof_mode @@ get_branch_pos b in + let id = new_node proof_mode () in + let parsing = Option.get @@ get_parsing_state (get_branch_pos b) in + merge id ~ours:(Sideff CherryPickEnv) ~into:b Branch.master; + set_parsing_state id parsing) (List.filter (fun b -> not (Branch.equal b Branch.master)) (branches ())) let visit id = Vcs_aux.visit !vcs id @@ -625,10 +670,12 @@ end = struct (* {{{ *) let slice ~block_start ~block_stop = let l = nodes_in_slice ~block_start ~block_stop in let copy_info v id = + let info = get_info id in Vcs_.set_info v id - { (get_info id) with state = Empty; vcs_backup = None,None } in + { info with state = EmptyState; + vcs_backup = None,None } in let make_shallow = function - | Valid st -> Valid (Vernacstate.make_shallow st) + | FullState st -> FullState (Vernacstate.make_shallow st) | x -> x in let copy_info_w_state v id = @@ -651,12 +698,14 @@ end = struct (* {{{ *) let v = copy_info v id in v) l v in (* Stm should have reached the beginning of proof *) - assert (match (get_info block_start).state with Valid _ -> true | _ -> false); + assert (match get_state block_start + with FullState _ -> true | _ -> false); (* We put in the new dag the most recent state known to master *) let rec fill id = - match (get_info id).state with - | Empty | Error _ -> fill (Vcs_aux.visit v id).next - | Valid _ -> copy_info_w_state v id in + match get_state id with + | EmptyState | ErrorState _ | ParsingState _ -> fill (Vcs_aux.visit v id).next + | FullState _ -> copy_info_w_state v id + in let v = fill block_stop in (* We put in the new dag the first state (since Qed shall run on it, * see check_task_aux) *) @@ -753,13 +802,12 @@ end = struct (* {{{ *) end (* }}} *) let state_of_id ~doc id = - try match (VCS.get_info id).state with - | Valid s -> `Valid (Some s) - | Error (e,_) -> `Error e - | Empty -> `Valid None + try match VCS.get_state id with + | FullState s -> `Valid (Some s) + | ErrorState (_,(e,_)) -> `Error e + | EmptyState | ParsingState _ -> `Valid None with VCS.Expired -> `Expired - (****** A cache: fills in the nodes of the VCS document with their value ******) module State : sig @@ -782,6 +830,7 @@ module State : sig val fix_exn_ref : (Exninfo.iexn -> Exninfo.iexn) ref val install_cached : Stateid.t -> unit + (* val install_parsing_state : Stateid.t -> unit *) val is_cached : ?cache:bool -> Stateid.t -> bool val is_cached_and_valid : ?cache:bool -> Stateid.t -> bool @@ -804,10 +853,6 @@ module State : sig val register_root_state : unit -> unit val restore_root_state : unit -> unit - (* Only for internal use to catch problems in parse_sentence, should - be removed in the state handling refactoring. *) - val cur_id : Stateid.t ref - val purify : ('a -> 'b) -> 'a -> 'b end = struct (* {{{ *) @@ -824,6 +869,8 @@ end = struct (* {{{ *) Vernacstate.unfreeze_interp_state st.vernac_state; cur_id := st.id + let invalidate_cur_state () = cur_id := Stateid.dummy + type proof_part = Proof_global.t * int * (* Evarutil.meta_counter_summary_tag *) @@ -842,49 +889,58 @@ end = struct (* {{{ *) Summary.project_from_summary st Util.(pi3 summary_pstate) let cache_state ~marshallable id = - VCS.set_state id (Valid (Vernacstate.freeze_interp_state ~marshallable)) + VCS.set_state id (FullState (Vernacstate.freeze_interp_state ~marshallable)) - let freeze_invalid id iexn = VCS.set_state id (Error iexn) + let freeze_invalid id iexn = + let ps = VCS.get_parsing_state id in + VCS.set_state id (ErrorState (ps,iexn)) let is_cached ?(cache=false) id only_valid = if Stateid.equal id !cur_id then try match VCS.get_info id with - | { state = Empty } when cache -> cache_state ~marshallable:false id; true + | ({ state = EmptyState } | { state = ParsingState _ }) when cache -> cache_state ~marshallable:false id; true | _ -> true with VCS.Expired -> false else - try match VCS.get_info id with - | { state = Empty } -> false - | { state = Valid _ } -> true - | { state = Error _ } -> not only_valid + try match VCS.get_state id with + | EmptyState | ParsingState _ -> false + | FullState _ -> true + | ErrorState _ -> not only_valid with VCS.Expired -> false let is_cached_and_valid ?cache id = is_cached ?cache id true let is_cached ?cache id = is_cached ?cache id false let install_cached id = - match VCS.get_info id with - | { state = Valid s } -> + match VCS.get_state id with + | FullState s -> Vernacstate.unfreeze_interp_state s; cur_id := id - | { state = Error ie } -> + | ErrorState (_,ie) -> Exninfo.iraise ie - | _ -> - (* coqc has a 1 slot cache and only for valid states *) - if not (VCS.is_interactive ()) && Stateid.equal id !cur_id then () - else anomaly Pp.(str "installing a non cached state.") + | EmptyState | ParsingState _ -> + (* coqc has a 1 slot cache and only for valid states *) + if (VCS.is_interactive ()) || not (Stateid.equal id !cur_id) then + anomaly Pp.(str "installing a non cached state.") + + (* + let install_parsing_state id = + if not (Stateid.equal id !cur_id) then begin + Vernacstate.Parser.install @@ VCS.get_parsing_state id + end + *) let get_cached id = - try match VCS.get_info id with - | { state = Valid s } -> s + try match VCS.get_state id with + | FullState s -> s | _ -> anomaly Pp.(str "not a cached state.") with VCS.Expired -> anomaly Pp.(str "not a cached state (expired).") let assign id what = let open Vernacstate in - if VCS.get_state id <> Empty then () else + if VCS.get_state id <> EmptyState then () else try match what with | `Full s -> let s = @@ -896,7 +952,7 @@ end = struct (* {{{ *) ~src:(get_cached prev).proof ~tgt:s.proof } else s with VCS.Expired -> s in - VCS.set_state id (Valid s) + VCS.set_state id (FullState s) | `ProofOnly(ontop,(pstate,c1,c2,c3)) -> if is_cached_and_valid ontop then let s = get_cached ontop in @@ -912,7 +968,7 @@ end = struct (* {{{ *) st end } in - VCS.set_state id (Valid s) + VCS.set_state id (FullState s) with VCS.Expired -> () let exn_on id ~valid (e, info) = @@ -958,7 +1014,7 @@ end = struct (* {{{ *) with e -> let (e, info) = CErrors.push e in let good_id = !cur_id in - cur_id := Stateid.dummy; + invalidate_cur_state (); VCS.reached id; let ie = match Stateid.get info, safe_id with @@ -1130,7 +1186,7 @@ module Backtrack : sig val branches_of : Stateid.t -> backup (* Returns the state that the command should backtract to *) - val undo_vernac_classifier : vernac_control -> doc:doc -> Stateid.t * vernac_when + val undo_vernac_classifier : vernac_control -> doc:doc -> Stateid.t val get_prev_proof : doc:doc -> Stateid.t -> Proof.t option end = struct (* {{{ *) @@ -1205,30 +1261,30 @@ end = struct (* {{{ *) try match Vernacprop.under_control v with | VernacResetInitial -> - Stateid.initial, VtNow + Stateid.initial | VernacResetName {CAst.v=name} -> - let id = VCS.get_branch_pos (VCS.current_branch ()) in + let id = VCS.cur_tip () in (try let oid = fold_until (fun b (id,_,label,_,_) -> if b then `Stop id else `Cont (List.mem name label)) false id in - oid, VtNow + oid with Not_found -> - id, VtNow) + id) | VernacBack n -> - let id = VCS.get_branch_pos (VCS.current_branch ()) in + let id = VCS.cur_tip () in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) n id in - oid, VtNow + oid | VernacUndo n -> - let id = VCS.get_branch_pos (VCS.current_branch ()) in + let id = VCS.cur_tip () in let oid = fold_until back_tactic n id in - oid, VtLater + oid | VernacUndoTo _ | VernacRestart as e -> let m = match e with VernacUndoTo m -> m | _ -> 0 in - let id = VCS.get_branch_pos (VCS.current_branch ()) in + let id = VCS.cur_tip () in let vcs = match (VCS.get_info id).vcs_backup with | None, _ -> anomaly Pp.(str"Backtrack: tip with no vcs_backup.") @@ -1241,15 +1297,15 @@ end = struct (* {{{ *) 0 id in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) (n-m-1) id in - oid, VtLater + oid | VernacAbortAll -> - let id = VCS.get_branch_pos (VCS.current_branch ()) in + let id = VCS.cur_tip () in let oid = fold_until (fun () (id,vcs,_,_,_) -> match Vcs_.branches vcs with [_] -> `Stop id | _ -> `Cont ()) () id in - oid, VtLater + oid | VernacBackTo id -> - Stateid.of_int id, VtNow + Stateid.of_int id | _ -> anomaly Pp.(str "incorrect VtMeta classification") with | Not_found -> @@ -1615,7 +1671,7 @@ end = struct (* {{{ *) when is_tac expr && State.same_env o n -> (* A pure tactic *) Some (id, `ProofOnly (prev, State.proof_part_of_frozen n)) | Some _, Some s -> - msg_debug (Pp.str "STM: sending back a fat state"); + if !Flags.debug then msg_debug (Pp.str "STM: sending back a fat state"); Some (id, `Full s) | _, Some s -> Some (id, `Full s) in let rec aux seen = function @@ -2331,8 +2387,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (Proofview.Goal.goal gl) goals_to_admit then Proofview.give_up else Proofview.tclUNIT () end in - match (VCS.get_info base_state).state with - | Valid { Vernacstate.proof } -> + match VCS.get_state base_state with + | FullState { Vernacstate.proof } -> Proof_global.unfreeze proof; Proof_global.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; @@ -2469,7 +2525,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = VCS.create_proof_task_box nodes ~qed:id ~block_start; begin match brinfo, qed.fproof with | { VCS.kind = `Edit _ }, None -> assert false - | { VCS.kind = `Edit (_,_,_, okeep, _) }, Some (ofp, cancel) -> + | { VCS.kind = `Edit (_,_, okeep, _) }, Some (ofp, cancel) -> assert(redefine_qed = true); if okeep <> keep then msg_warning(strbrk("The command closing the proof changed. " @@ -2655,7 +2711,7 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = (* We must reset the whole state before creating a document! *) State.restore_root_state (); - let doc = VCS.init doc_type Stateid.initial in + let doc = VCS.init doc_type Stateid.initial (Vernacstate.Parser.init ()) in (* Set load path; important, this has to happen before we declare the library below as [Declaremods/Library] will infer the module @@ -2723,16 +2779,8 @@ let observe ~doc id = let finish ~doc = let head = VCS.current_branch () in - let doc =observe ~doc (VCS.get_branch_pos head) in - VCS.print (); - (* EJGA: Setting here the proof state looks really wrong, and it - hides true bugs cf bug #5363. Also, what happens with observe? *) - (* Some commands may by side effect change the proof mode *) - (match VCS.get_branch head with - | { VCS.kind = `Edit (mode,_,_,_,_) } -> Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] - | { VCS.kind = `Proof (mode, _) } -> Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] - | _ -> () - ); doc + let doc = observe ~doc (VCS.get_branch_pos head) in + VCS.print (); doc let wait ~doc = let doc = observe ~doc (VCS.get_branch_pos VCS.Branch.master) in @@ -2809,12 +2857,14 @@ let merge_proof_branch ~valid ?id qast keep brname = match brinfo with | { VCS.kind = `Proof _ } -> VCS.checkout VCS.Branch.master; - let id = VCS.new_node ?id () in + let id = VCS.new_node ?id None () in + let parsing = Option.get @@ VCS.get_parsing_state (VCS.cur_tip ()) in VCS.merge id ~ours:(Qed (qed None)) brname; + VCS.set_parsing_state id parsing; VCS.delete_branch brname; - VCS.propagate_sideff ~action:CherryPickEnv; + VCS.propagate_qed (); `Ok - | { VCS.kind = `Edit (mode, qed_id, master_id, _,_) } -> + | { VCS.kind = `Edit (qed_id, master_id, _,_) } -> let ofp = match VCS.visit qed_id with | { step = `Qed ({ fproof }, _) } -> fproof @@ -2846,25 +2896,32 @@ let snapshot_vio ~doc ldir long_f_dot_vo = let reset_task_queue = Slaves.reset_task_queue (* Document building *) -let process_back_meta_command ~newtip ~head oid aast w = - let id = VCS.new_node ~id:newtip () in - let { mine; others } = Backtrack.branches_of oid in + +(* We process a meta command found in the document *) +let process_back_meta_command ~newtip ~head oid aast = let valid = VCS.get_branch_pos head in + let old_parsing = Option.get @@ VCS.get_parsing_state oid in + + (* Merge in and discard all the branches currently open that were not open in `oid` *) + let { mine; others } = Backtrack.branches_of oid in List.iter (fun branch -> if not (List.mem_assoc branch (mine::others)) then ignore(merge_proof_branch ~valid aast VtDrop branch)) (VCS.branches ()); + + (* We add a node on top of every branch, to represent state aliasing *) VCS.checkout_shallowest_proof_branch (); let head = VCS.current_branch () in List.iter (fun b -> - if not(VCS.Branch.equal b head) then begin - VCS.checkout b; - VCS.commit (VCS.new_node ()) (Alias (oid,aast)); - end) + VCS.checkout b; + let id = if (VCS.Branch.equal b head) then Some newtip else None in + let proof_mode = VCS.get_proof_mode @@ VCS.cur_tip () in + let id = VCS.new_node ?id proof_mode () in + VCS.commit id (Alias (oid,aast)); + VCS.set_parsing_state id old_parsing) (VCS.branches ()); VCS.checkout_shallowest_proof_branch (); - VCS.commit id (Alias (oid,aast)); - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok + Backtrack.record (); `Ok let get_allow_nested_proofs = Goptions.declare_bool_option_and_ref @@ -2873,6 +2930,7 @@ let get_allow_nested_proofs = ~key:Vernac_classifier.stm_allow_nested_proofs_option_name ~value:false +(** [process_transaction] adds a node in the document *) let process_transaction ~doc ?(newtip=Stateid.fresh ()) ({ verbose; loc; expr } as x) c = stm_pperr_endline (fun () -> str "{{{ processing: " ++ pr_ast x); @@ -2880,18 +2938,21 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) try let head = VCS.current_branch () in VCS.checkout head; + let head_parsing = + Option.get @@ VCS.(get_parsing_state (get_branch_pos head)) in + let proof_mode = VCS.(get_proof_mode (get_branch_pos head)) in let rc = begin stm_prerr_endline (fun () -> " classified as: " ^ Vernac_classifier.string_of_vernac_classification c); match c with (* Meta *) | VtMeta, _ -> - let id, w = Backtrack.undo_vernac_classifier expr ~doc in - process_back_meta_command ~newtip ~head id x w + let id = Backtrack.undo_vernac_classifier expr ~doc in + process_back_meta_command ~newtip ~head id x (* Query *) | VtQuery, w -> - let id = VCS.new_node ~id:newtip () in + let id = VCS.new_node ~id:newtip proof_mode () in let queue = if VCS.is_vio_doc () && VCS.((get_branch head).kind = `Master) && @@ -2899,10 +2960,11 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) then `SkipQueue else `MainQueue in VCS.commit id (mkTransCmd x [] false queue); - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok + VCS.set_parsing_state id head_parsing; + Backtrack.record (); assert (w == VtLater); `Ok (* Proof *) - | VtStartProof (mode, guarantee, names), w -> + | VtStartProof (guarantee, names), w -> if not (get_allow_nested_proofs ()) && VCS.proof_nesting () > 0 then "Nested proofs are not allowed unless you turn option Nested Proofs Allowed on." @@ -2912,39 +2974,22 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) |> Exninfo.iraise else - let id = VCS.new_node ~id:newtip () in + let proof_mode = Some (Vernacentries.get_default_proof_mode ()) in + let id = VCS.new_node ~id:newtip proof_mode () in let bname = VCS.mk_branch_name x in VCS.checkout VCS.Branch.master; if VCS.Branch.equal head VCS.Branch.master then begin VCS.commit id (Fork (x, bname, guarantee, names)); - VCS.branch bname (`Proof (mode, VCS.proof_nesting () + 1)) + VCS.branch bname (`Proof (VCS.proof_nesting () + 1)) end else begin - VCS.branch bname (`Proof (mode, VCS.proof_nesting () + 1)); + VCS.branch bname (`Proof (VCS.proof_nesting () + 1)); VCS.merge id ~ours:(Fork (x, bname, guarantee, names)) head end; - Proof_global.activate_proof_mode mode [@ocaml.warning "-3"]; - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok - | VtProofMode _, VtLater -> - anomaly(str"VtProofMode must be executed VtNow.") - | VtProofMode mode, VtNow -> - let id = VCS.new_node ~id:newtip () in - VCS.commit id (mkTransCmd x [] false `MainQueue); - List.iter - (fun bn -> match VCS.get_branch bn with - | { VCS.root; kind = `Master; pos } -> () - | { VCS.root; kind = `Proof(_,d); pos } -> - VCS.delete_branch bn; - VCS.branch ~root ~pos bn (`Proof(mode,d)) - | { VCS.root; kind = `Edit(_,f,q,k,ob); pos } -> - VCS.delete_branch bn; - VCS.branch ~root ~pos bn (`Edit(mode,f,q,k,ob))) - (VCS.branches ()); - VCS.checkout_shallowest_proof_branch (); - Backtrack.record (); - ignore(finish ~doc:dummy_doc); - `Ok + VCS.set_parsing_state id head_parsing; + Backtrack.record (); assert (w == VtLater); `Ok + | VtProofStep { parallel; proof_block_detection = cblock }, w -> - let id = VCS.new_node ~id:newtip () in + let id = VCS.new_node ~id:newtip proof_mode () in let queue = match parallel with | `Yes(solve,abstract) -> `TacQueue (solve, abstract, ref false) @@ -2954,21 +2999,25 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) If/when and UI will make something useful with this piece of info, detection should occur here. detect_proof_block id cblock; *) - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok + VCS.set_parsing_state id head_parsing; + Backtrack.record (); assert (w == VtLater); `Ok + | VtQed keep, w -> let valid = VCS.get_branch_pos head in - let rc = merge_proof_branch ~valid ~id:newtip x keep head in + let rc = + merge_proof_branch ~valid ~id:newtip x keep head in VCS.checkout_shallowest_proof_branch (); - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); + Backtrack.record (); assert (w == VtLater); rc (* Side effect in a (still open) proof is replayed on all branches*) | VtSideff l, w -> - let id = VCS.new_node ~id:newtip () in - begin match (VCS.get_branch head).VCS.kind with - | `Edit _ -> VCS.commit id (mkTransCmd x l true `MainQueue); - | `Master -> VCS.commit id (mkTransCmd x l false `MainQueue); - | `Proof _ -> + let id = VCS.new_node ~id:newtip proof_mode () in + let new_ids = + match (VCS.get_branch head).VCS.kind with + | `Edit _ -> VCS.commit id (mkTransCmd x l true `MainQueue); [] + | `Master -> VCS.commit id (mkTransCmd x l false `MainQueue); [] + | `Proof _ -> VCS.checkout VCS.Branch.master; VCS.commit id (mkTransCmd x l true `MainQueue); (* We can't replay a Definition since universes may be differently @@ -2976,10 +3025,27 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let action = match Vernacprop.under_control x.expr with | VernacDefinition(_, _, DefineBody _) -> CherryPickEnv | _ -> ReplayCommand x in - VCS.propagate_sideff ~action; - end; + VCS.propagate_sideff ~action + in VCS.checkout_shallowest_proof_branch (); - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok + Backtrack.record (); + let parsing_state = + begin match w with + | VtNow -> + (* We need to execute to get the new parsing state *) + ignore(finish ~doc:dummy_doc); + let parsing = Vernacstate.Parser.cur_state () in + (* If execution has not been put in cache, we need to save the parsing state *) + if (VCS.get_info id).state == EmptyState then VCS.set_parsing_state id parsing; + parsing + | VtLater -> VCS.set_parsing_state id head_parsing; head_parsing + end + in + (* We save the parsing state on non-master branches *) + List.iter (fun id -> + if (VCS.get_info id).state == EmptyState then + VCS.set_parsing_state id parsing_state) new_ids; + `Ok (* Unknown: we execute it, check for open goals and propagate sideeff *) | VtUnknown, VtNow -> @@ -2991,7 +3057,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) |> State.exn_on ~valid:Stateid.dummy Stateid.dummy |> Exninfo.iraise else - let id = VCS.new_node ~id:newtip () in + let id = VCS.new_node ~id:newtip proof_mode () in let head_id = VCS.get_branch_pos head in let _st : unit = Reach.known_state ~doc ~cache:true head_id in (* ensure it is ok *) let step () = @@ -3009,9 +3075,8 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) | VernacInstance (_,_ , None, _) -> GuaranteesOpacity | _ -> Doesn'tGuaranteeOpacity in VCS.commit id (Fork (x,bname,opacity_of_produced_term (Vernacprop.under_control x.expr),[])); - let proof_mode = default_proof_mode () in - VCS.branch bname (`Proof (proof_mode, VCS.proof_nesting () + 1)); - Proof_global.activate_proof_mode proof_mode [@ocaml.warning "-3"]; + VCS.set_proof_mode id (Some (Vernacentries.get_default_proof_mode ())); + VCS.branch bname (`Proof (VCS.proof_nesting () + 1)); end else begin begin match (VCS.get_branch head).VCS.kind with | `Edit _ -> VCS.commit id (mkTransCmd x [] in_proof `MainQueue); @@ -3019,7 +3084,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) | `Proof _ -> VCS.commit id (mkTransCmd x [] in_proof `MainQueue); (* We hope it can be replayed, but we can't really know *) - VCS.propagate_sideff ~action:(ReplayCommand x); + ignore(VCS.propagate_sideff ~action:(ReplayCommand x)); end; VCS.checkout_shallowest_proof_branch (); end in @@ -3028,6 +3093,17 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) | VtUnknown, VtLater -> anomaly(str"classifier: VtUnknown must imply VtNow.") + + | VtProofMode pm, VtNow -> + let proof_mode = Pvernac.lookup_proof_mode pm in + let id = VCS.new_node ~id:newtip proof_mode () in + VCS.commit id (mkTransCmd x [] false `MainQueue); + VCS.set_parsing_state id head_parsing; + Backtrack.record (); `Ok + + | VtProofMode _, VtLater -> + anomaly(str"classifier: VtProofMode must imply VtNow.") + end in let pr_rc rc = match rc with | `Ok -> Pp.(seq [str "newtip ("; str (Stateid.to_string (VCS.cur_tip ())); str ")"]) @@ -3051,45 +3127,10 @@ let get_ast ~doc id = let stop_worker n = Slaves.cancel_worker n -(* We must parse on top of a state id, it should be something like: - - - get parsing information for that state. - - feed the parsable / parser with the right parsing information. - - call the parser - - Now, the invariant in ensured by the callers, but this is a bit - problematic. -*) -exception End_of_input - -let parse_sentence ~doc sid pa = - (* XXX: Should this restore the previous state? - Using reach here to try to really get to the - proper state makes the error resilience code fail *) - (* Reach.known_state ~cache:`Yes sid; *) - let cur_tip = VCS.cur_tip () in - let real_tip = !State.cur_id in - if not (Stateid.equal sid cur_tip) then - user_err ~hdr:"Stm.parse_sentence" - (str "Currently, the parsing api only supports parsing at the tip of the document." ++ fnl () ++ - str "You wanted to parse at: " ++ str (Stateid.to_string sid) ++ - str " but the current tip is: " ++ str (Stateid.to_string cur_tip)) ; - if not (Stateid.equal sid real_tip) && !Flags.debug && !stm_debug then - Feedback.msg_debug - (str "Warning, the real tip doesn't match the current tip." ++ - str "You wanted to parse at: " ++ str (Stateid.to_string sid) ++ - str " but the real tip is: " ++ str (Stateid.to_string real_tip) ++ fnl () ++ - str "This is usually due to use of Stm.observe to evaluate a state different than the tip. " ++ - str "All is good if not parsing changes occur between the two states, however if they do, a problem might occur."); - Flags.with_option Flags.we_are_parsing (fun () -> - try - match Pcoq.Entry.parse Pvernac.main_entry pa with - | None -> raise End_of_input - | Some (loc, cmd) -> CAst.make ~loc cmd - with e when CErrors.noncritical e -> - let (e, info) = CErrors.push e in - Exninfo.iraise (e, info)) - () +let parse_sentence ~doc sid ~entry pa = + let ps = Option.get @@ VCS.get_parsing_state sid in + let proof_mode = VCS.get_proof_mode sid in + Vernacstate.Parser.parse ps (entry proof_mode) pa (* You may need to know the len + indentation of previous command to compute * the indentation of the current one. @@ -3153,20 +3194,20 @@ let query ~doc ~at ~route s = State.purify (fun s -> if Stateid.equal at Stateid.dummy then ignore(finish ~doc:dummy_doc) else Reach.known_state ~doc ~cache:true at; - try - while true do - let { CAst.loc; v=ast } = parse_sentence ~doc at s in - let indentation, strlen = compute_indentation ?loc at in - let st = State.get_cached at in - let aast = { verbose = true; indentation; strlen; loc; expr = ast } in - ignore(stm_vernac_interp ~route at st aast) - done; - with - | End_of_input -> () - | exn -> - let iexn = CErrors.push exn in - Exninfo.iraise iexn - ) + let rec loop () = + match parse_sentence ~doc at ~entry:Pvernac.main_entry s with + | None -> () + | Some (loc, ast) -> + let indentation, strlen = compute_indentation ~loc at in + let st = State.get_cached at in + let aast = { + verbose = true; indentation; strlen; + loc = Some loc; expr = ast } in + ignore(stm_vernac_interp ~route at st aast); + loop () + in + loop () + ) s let edit_at ~doc id = @@ -3204,21 +3245,21 @@ let edit_at ~doc id = | { step = `Sideff (ReplayCommand _,id) } -> id | { step = `Sideff _ } -> tip | { next } -> master_for_br root next in - let reopen_branch start at_id mode qed_id tip old_branch = + let reopen_branch start at_id qed_id tip old_branch = let master_id, cancel_switch, keep = (* Hum, this should be the real start_id in the cluster and not next *) match VCS.visit qed_id with | { step = `Qed ({ fproof = Some (_,cs); keep },_) } -> start, cs, keep | _ -> anomaly (str "ProofTask not ending with Qed.") in VCS.branch ~root:master_id ~pos:id - VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch)); + VCS.edit_branch (`Edit (qed_id, master_id, keep, old_branch)); VCS.delete_boxes_of id; cancel_switch := true; Reach.known_state ~doc ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `Focus { stop = qed_id; start = master_id; tip } in let no_edit = function - | `Edit (pm, _,_,_,_) -> `Proof(pm,1) + | `Edit (_,_,_,_) -> `Proof 1 | x -> x in let backto id bn = List.iter VCS.delete_branch (VCS.branches ()); @@ -3244,17 +3285,17 @@ let edit_at ~doc id = let focused = List.exists ((=) VCS.edit_branch) (VCS.branches ()) in let branch_info = match snd (VCS.get_info id).vcs_backup with - | Some{ mine = bn, { VCS.kind = `Proof(m,_) }} -> Some(m,bn) - | Some{ mine = _, { VCS.kind = `Edit(m,_,_,_,bn) }} -> Some (m,bn) + | Some{ mine = bn, { VCS.kind = `Proof _ }} -> Some bn + | Some{ mine = _, { VCS.kind = `Edit(_,_,_,bn) }} -> Some bn | _ -> None in match focused, VCS.proof_task_box_of id, branch_info with | _, Some _, None -> assert false - | false, Some { qed = qed_id ; lemma = start }, Some(mode,bn) -> + | false, Some { qed = qed_id ; lemma = start }, Some bn -> let tip = VCS.cur_tip () in if has_failed qed_id && is_pure qed_id && not !cur_opt.async_proofs_never_reopen_branch - then reopen_branch start id mode qed_id tip bn + then reopen_branch start id qed_id tip bn else backto id (Some bn) - | true, Some { qed = qed_id }, Some(mode,bn) -> + | true, Some { qed = qed_id }, Some bn -> if on_cur_branch id then begin assert false end else if is_ancestor_of_cur_branch id then begin @@ -3273,7 +3314,7 @@ let edit_at ~doc id = end else begin anomaly(str"Cannot leave an `Edit branch open.") end - | false, None, Some(_,bn) -> backto id (Some bn) + | false, None, Some bn -> backto id (Some bn) | false, None, None -> backto id None in VCS.print (); diff --git a/stm/stm.mli b/stm/stm.mli index b6071fa56b..821ab59a43 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -93,16 +93,17 @@ val init_core : unit -> unit (** [new_doc opt] Creates a new document with options [opt] *) val new_doc : stm_init_options -> doc * Stateid.t -(** [parse_sentence sid pa] Reads a sentence from [pa] with parsing - state [sid] Returns [End_of_input] if the stream ends *) -val parse_sentence : doc:doc -> Stateid.t -> Pcoq.Parsable.t -> - Vernacexpr.vernac_control CAst.t +(** [parse_sentence sid entry pa] Reads a sentence from [pa] with parsing state + [sid] and non terminal [entry]. [entry] receives in input the current proof + mode. [sid] should be associated with a valid parsing state (which may not + be the case if an error was raised at parsing time). *) +val parse_sentence : + doc:doc -> Stateid.t -> + entry:(Pvernac.proof_mode option -> 'a Pcoq.Entry.t) -> Pcoq.Parsable.t -> 'a (* Reminder: A parsable [pa] is constructed using [Pcoq.Parsable.t stream], where [stream : char Stream.t]. *) -exception End_of_input - (* [add ~ontop ?newtip verbose cmd] adds a new command [cmd] ontop of the state [ontop]. The [ontop] parameter just asserts that the GUI is on diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 09f531ce13..292e3966a1 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -15,8 +15,6 @@ open CAst open Vernacextend open Vernacexpr -let default_proof_mode () = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] - let string_of_parallel = function | `Yes (solve,abs) -> "par" ^ if solve then "solve" else "" ^ if abs then "abs" else "" @@ -32,9 +30,9 @@ let string_of_vernac_type = function | VtProofStep { parallel; proof_block_detection } -> "ProofStep " ^ string_of_parallel parallel ^ Option.default "" proof_block_detection - | VtProofMode s -> "ProofMode " ^ s | VtQuery -> "Query" | VtMeta -> "Meta " + | VtProofMode _ -> "Proof Mode" let string_of_vernac_when = function | VtLater -> "Later" @@ -57,7 +55,7 @@ let stm_allow_nested_proofs_option_name = ["Nested";"Proofs";"Allowed"] let options_affecting_stm_scheduling = [ Attributes.universe_polymorphism_option_name; stm_allow_nested_proofs_option_name; - Proof_global.proof_mode_opt_name; + Vernacentries.proof_mode_opt_name; ] let classify_vernac e = @@ -97,15 +95,15 @@ let classify_vernac e = | VernacSetOption (_, ["Default";"Proof";"Using"],_) -> VtSideff [], VtNow (* StartProof *) | VernacDefinition ((Decl_kinds.DoDischarge,_),({v=i},_),ProveBody _) -> - VtStartProof(default_proof_mode (),Doesn'tGuaranteeOpacity, idents_of_name i), VtLater + VtStartProof(Doesn'tGuaranteeOpacity, idents_of_name i), VtLater | VernacDefinition (_,({v=i},_),ProveBody _) -> let guarantee = if poly then Doesn'tGuaranteeOpacity else GuaranteesOpacity in - VtStartProof(default_proof_mode (),guarantee, idents_of_name i), VtLater + VtStartProof(guarantee, idents_of_name i), VtLater | VernacStartTheoremProof (_,l) -> let ids = List.map (fun (({v=i}, _), _) -> i) l in let guarantee = if poly then Doesn'tGuaranteeOpacity else GuaranteesOpacity in - VtStartProof (default_proof_mode (),guarantee,ids), VtLater + VtStartProof (guarantee,ids), VtLater | VernacFixpoint (discharge,l) -> let guarantee = if discharge = Decl_kinds.DoDischarge || poly then Doesn'tGuaranteeOpacity @@ -115,7 +113,7 @@ let classify_vernac e = List.fold_left (fun (l,b) ((({v=id},_),_,_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (default_proof_mode (),guarantee,ids), VtLater + then VtStartProof (guarantee,ids), VtLater else VtSideff ids, VtLater | VernacCoFixpoint (discharge,l) -> let guarantee = @@ -126,7 +124,7 @@ let classify_vernac e = List.fold_left (fun (l,b) ((({v=id},_),_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (default_proof_mode (),guarantee,ids), VtLater + then VtStartProof (guarantee,ids), VtLater else VtSideff ids, VtLater (* Sideff: apply to all open branches. usually run on master only *) | VernacAssumption (_,_,l) -> @@ -163,7 +161,6 @@ let classify_vernac e = | VernacExistingClass _ | VernacExistingInstance _ | VernacRegister _ | VernacNameSectionHypSet _ - | VernacDeclareCustomEntry _ | VernacComments _ | VernacDeclareInstance _ -> VtSideff [], VtLater (* Who knows *) @@ -177,6 +174,7 @@ let classify_vernac e = | VernacDeclareModuleType ({v=id},bl,_,_) -> VtSideff [id], if bl = [] then VtLater else VtNow (* These commands alter the parser *) + | VernacDeclareCustomEntry _ | VernacOpenCloseScope _ | VernacDeclareScope _ | VernacDelimiters _ | VernacBindScope _ | VernacInfix _ | VernacNotation _ | VernacNotationAddFormat _ @@ -184,8 +182,8 @@ let classify_vernac e = | VernacSyntacticDefinition _ | VernacRequire _ | VernacImport _ | VernacInclude _ | VernacDeclareMLModule _ - | VernacContext _ (* TASSI: unsure *) - | VernacProofMode _ -> VtSideff [], VtNow + | VernacContext _ (* TASSI: unsure *) -> VtSideff [], VtNow + | VernacProofMode pm -> VtProofMode pm, VtNow (* These are ambiguous *) | VernacInstance _ -> VtUnknown, VtNow (* Stm will install a new classifier to handle these *) @@ -211,10 +209,10 @@ let classify_vernac e = | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match static_control_classifier e with | ( VtQuery | VtProofStep _ | VtSideff _ - | VtProofMode _ | VtMeta), _ as x -> x + | VtMeta), _ as x -> x | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, - VtNow - | (VtStartProof _ | VtUnknown), _ -> VtQuery, VtLater) + VtLater + | (VtStartProof _ | VtUnknown | VtProofMode _), _ -> VtQuery, VtLater) in static_control_classifier e diff --git a/test-suite/Makefile b/test-suite/Makefile index 37091a49e5..cafc9a744c 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -38,14 +38,15 @@ LIB := .. BIN := $(shell cd ..; pwd)/bin/ COQFLAGS?= -coqtop := $(BIN)coqtop -coqlib $(LIB) -boot -q -batch -test-mode -R prerequisite TestSuite $(COQFLAGS) +coqc_boot := $(BIN)coqc -coqlib $(LIB) -boot -q -test-mode -R prerequisite TestSuite $(COQFLAGS) coqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite $(COQFLAGS) coqchk := $(BIN)coqchk -coqlib $(LIB) -R prerequisite TestSuite coqdoc := $(BIN)coqdoc +coqtop := $(BIN)coqtop -coqlib $(LIB) -boot -q -test-mode -R prerequisite TestSuite coqtopbyte := $(BIN)coqtop.byte -coqtopload := $(coqtop) -async-proofs-cache force -load-vernac-source -coqtopcompile := $(coqtop) -async-proofs-cache force -compile +coqc_interactive := $(coqc) -async-proofs-cache force +coqc_boot_interactive := $(coqc_boot) -async-proofs-cache force coqdep := $(BIN)coqdep -coqlib $(LIB) VERBOSE?= @@ -60,12 +61,8 @@ SINGLE_QUOTE=" #" # double up on the quotes, in a comment, to appease the emacs syntax highlighter # wrap the arguments in parens, but only if they exist get_coq_prog_args_in_parens = $(subst $(SINGLE_QUOTE),,$(if $(call get_coq_prog_args,$(1)), ($(call get_coq_prog_args,$(1))))) -# get the command to use with this set of arguments; if there's -compile, use coqc, else use coqtop -has_profile_ltac_or_compile_flag = $(filter "-profile-ltac-cutoff" "-profile-ltac" "-compile",$(call get_coq_prog_args,$(1))) -get_command_based_on_flags = $(if $(call has_profile_ltac_or_compile_flag,$(1)),$(coqtopcompile),$(coqtopload)) get_set_impredicativity= $(filter "-impredicative-set",$(call get_coq_prog_args,$(1))) - bogomips:= ifneq (,$(wildcard /proc/cpuinfo)) sedbogo := -e "s/bogomips.*: \([0-9]*\).*/\1/p" # i386, ppc @@ -209,7 +206,7 @@ $(addsuffix .log,$(wildcard bugs/opened/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...still active"; \ @@ -231,7 +228,7 @@ $(addsuffix .log,$(wildcard bugs/closed/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -297,7 +294,7 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be prepared" ; \ @@ -307,7 +304,7 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v echo " $<...correctly prepared" ; \ fi; \ } > "$@" - @echo "CHK $(shell basename $< .v)" + @echo "CHECK $<" $(HIDE)$(coqchk) -norec TestSuite.$(shell basename $< .v) > $(shell dirname $<)/$(shell basename $< .v).chk.log 2>&1 ssr: $(wildcard ssr/*.v:%.v=%.v.log) @@ -316,7 +313,7 @@ $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v)): %.v $(HIDE){ \ opts="$(if $(findstring modules/,$<),-R modules Mods)"; \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -326,7 +323,7 @@ $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v)): %.v $(FAIL); \ fi; \ } > "$@" - @echo "CHK $(shell basename $< .v)" + @echo "CHECK $<" $(HIDE){ \ opts="$(if $(findstring modules/,$<),-R modules Mods -norec Mods.$(shell basename $< .v),-I $(shell dirname $<) -norec $(shell basename $< .v))"; \ $(coqchk) -silent $(call get_set_impredicativity,$<) $$opts 2>&1; R=$$?; \ @@ -342,7 +339,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") -async-proofs on \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") -async-proofs on \ $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ @@ -353,7 +350,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v $(FAIL); \ fi; \ } > "$@" - @echo "CHK $(shell basename $< .v)" + @echo "CHECK $<" $(HIDE){ \ $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ @@ -367,7 +364,7 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -377,7 +374,7 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) $(FAIL); \ fi; \ } > "$@" - @echo "CHK $(shell basename $< .v)" + @echo "CHECK $<" $(HIDE){ \ $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ @@ -392,7 +389,7 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) $(HIDE){ \ echo $(call log_intro,$<); \ output=$*.out.real; \ - $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1 \ + $(coqc_boot_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 \ | grep -v "Welcome to Coq" \ | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ @@ -431,7 +428,7 @@ $(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out echo $(call log_intro,$<); \ tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \ tmpexpected=`mktemp /tmp/coqcheck.XXXXXX`; \ - $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1 \ + $(coqc_boot_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 \ | grep -v "Welcome to Coq" \ | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ @@ -486,7 +483,7 @@ $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v $(PREREQUISITELOG) $(HIDE){ \ echo $(call log_intro,$<); \ true "extract effective user time"; \ - res=`$(call get_command_based_on_flags,"$<") "$<" $(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_boot_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \ R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ @@ -517,7 +514,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v $(PREREQUISITELOG @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_success); \ echo " $<...still wished"; \ @@ -531,7 +528,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v $(PREREQUISITELOG # Additional dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo modules/%.vo: modules/%.v - $(HIDE)$(coqtop) -R modules Mods -compile $< + $(HIDE)$(coqc) -R modules Mods $< ####################################################################### # Miscellaneous tests @@ -550,7 +547,7 @@ $(patsubst %.sh,%.log,$(wildcard misc/*.sh)): %.log: %.sh $(PREREQUISITELOG) echo $(call log_intro,$<); \ export BIN="$(BIN)"; \ export coqc="$(coqc)"; \ - export coqtop="$(coqtop)"; \ + export coqtop="$(coqc_boot)"; \ export coqdep="$(coqdep)"; \ export coqtopbyte="$(coqtopbyte)"; \ "$<" 2>&1; R=$$?; times; \ @@ -591,7 +588,7 @@ vio: $(patsubst %.v,%.vio.log,$(wildcard vio/*.v)) @echo "TEST $<" $(HIDE){ \ $(coqc) -quick -R vio vio $* 2>&1 && \ - $(coqtop) -R vio vio -vio2vo $*.vio 2>&1 && \ + $(coqc) -R vio vio -vio2vo $*.vio 2>&1 && \ $(coqchk) -R vio vio -norec $(subst /,.,$*) 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ diff --git a/test-suite/bugs/closed/HoTT_coq_056.v b/test-suite/bugs/closed/HoTT_coq_056.v index 3e3a987a7c..b80e0bb0e4 100644 --- a/test-suite/bugs/closed/HoTT_coq_056.v +++ b/test-suite/bugs/closed/HoTT_coq_056.v @@ -94,9 +94,9 @@ Definition FunctorApplicationOf {C D} F {argsT} args {T} {rtn} Global Arguments FunctorApplicationOf / {C} {D} F {argsT} args {T} {rtn} {_}. Global Instance FunctorApplicationDash C D (F : Functor C D) -: FunctorApplicationInterpretable F (IdentityFunctor C) F | 0. +: FunctorApplicationInterpretable F (IdentityFunctor C) F | 0 := {}. Global Instance FunctorApplicationFunctorFunctor' A B C C' D (F : Functor (A * B) D) (G : Functor C A) (H : Functor C' B) -: FunctorApplicationInterpretable F (G, H) (F ∘ (FunctorProduct' G H))%functor | 100. +: FunctorApplicationInterpretable F (G, H) (F ∘ (FunctorProduct' G H))%functor | 100 := {}. Notation "F ⟨ x ⟩" := (FunctorApplicationOf F%functor x%functor) : functor_scope. diff --git a/test-suite/bugs/closed/bug_3324.v b/test-suite/bugs/closed/bug_3324.v index 45dbb57aa2..dae0d4c024 100644 --- a/test-suite/bugs/closed/bug_3324.v +++ b/test-suite/bugs/closed/bug_3324.v @@ -6,7 +6,7 @@ Module ETassi. Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). - Global Instance isset_hProp : IsHSet hProp | 0. + Global Instance isset_hProp : IsHSet hProp | 0 := {}. Check (eq_refl _ : setT (default_HSet _ _) = hProp). Check (eq_refl _ : setT _ = hProp). @@ -22,7 +22,7 @@ Module JGross. Definition Unit_hp:hProp:=(hp Unit admit). Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). - Global Instance isset_hProp : IsHSet hProp | 0. + Global Instance isset_hProp : IsHSet hProp | 0 := {}. Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h. Lemma isepi_issurj {X Y} (f:X->Y): isepi f -> True. diff --git a/test-suite/bugs/closed/bug_3454.v b/test-suite/bugs/closed/bug_3454.v index e4cd60cb24..0a01adec33 100644 --- a/test-suite/bugs/closed/bug_3454.v +++ b/test-suite/bugs/closed/bug_3454.v @@ -32,14 +32,14 @@ Local Instance isequiv_tgt_compose A B : @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) (A -> B) (@compose A {xy : B * B & fst xy = snd xy} B - (@compose {xy : B * B & fst xy = snd xy} _ B (@snd B B) pr1)). + (@compose {xy : B * B & fst xy = snd xy} _ B (@snd B B) pr1)) := {}. (* Toplevel input, characters 220-223: *) (* Error: Cannot infer this placeholder. *) Local Instance isequiv_tgt_compose' A B : @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) (A -> B) - (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) pr1)). + (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) pr1)) := {}. (* Toplevel input, characters 221-232: *) (* Error: *) (* In environment *) @@ -52,7 +52,7 @@ Local Instance isequiv_tgt_compose'' A B : @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) (A -> B) (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) - (fun s => s.(projT1)))). + (fun s => s.(projT1)))) := {}. (* Toplevel input, characters 15-241: Error: Cannot infer an internal placeholder of type "Type" in environment: diff --git a/test-suite/bugs/closed/bug_3682.v b/test-suite/bugs/closed/bug_3682.v index 9d37d1a2d0..07b759afb5 100644 --- a/test-suite/bugs/closed/bug_3682.v +++ b/test-suite/bugs/closed/bug_3682.v @@ -1,6 +1,6 @@ Require Import TestSuite.admit. Class Foo. Definition bar `{Foo} (x : Set) := Set. -Instance: Foo. +Instance: Foo := {}. Definition bar1 := bar nat. Definition bar2 := bar ltac:(admit). diff --git a/test-suite/bugs/closed/bug_4782.v b/test-suite/bugs/closed/bug_4782.v index be17a96f15..c08195d502 100644 --- a/test-suite/bugs/closed/bug_4782.v +++ b/test-suite/bugs/closed/bug_4782.v @@ -15,8 +15,8 @@ Record T := { dom : Type }. Definition pairT A B := {| dom := (dom A * dom B)%type |}. Class C (A:Type). Parameter B:T. -Instance c (A:T) : C (dom A). -Instance cn : C (dom B). +Instance c (A:T) : C (dom A) := {}. +Instance cn : C (dom B) := {}. Parameter F : forall A:T, C (dom A) -> forall x:dom A, x=x -> A = A. Set Typeclasses Debug. Goal forall (A:T) (x:dom A), pairT A A = pairT A A. diff --git a/test-suite/bugs/closed/bug_4798.v b/test-suite/bugs/closed/bug_4798.v index 41a1251ca5..696812dee1 100644 --- a/test-suite/bugs/closed/bug_4798.v +++ b/test-suite/bugs/closed/bug_4798.v @@ -1,3 +1,5 @@ +(* DO NOT MODIFY THIS FILE DIRECTLY *) +(* It is autogenerated by dev/tools/update-compat.py. *) Check match 2 with 0 => 0 | S n => n end. Notation "|" := 1 (compat "8.7"). Check match 2 with 0 => 0 | S n => n end. (* fails *) diff --git a/test-suite/bugs/closed/bug_4836.v b/test-suite/bugs/closed/bug_4836.v index 5838dcd8a7..9aefb10172 100644 --- a/test-suite/bugs/closed/bug_4836.v +++ b/test-suite/bugs/closed/bug_4836.v @@ -1 +1 @@ -(* -*- coq-prog-args: ("-compile" "bugs/closed/PLACEHOLDER.v") -*- *) +(* -*- coq-prog-args: ("bugs/closed/PLACEHOLDER.v") -*- *) diff --git a/test-suite/bugs/closed/bug_5401.v b/test-suite/bugs/closed/bug_5401.v index 95193b993b..466e669d00 100644 --- a/test-suite/bugs/closed/bug_5401.v +++ b/test-suite/bugs/closed/bug_5401.v @@ -5,7 +5,7 @@ Parameter P : nat -> Type. Parameter v : forall m, P m. Parameter f : forall (P : nat -> Type), (forall a, P a) -> P 0. Class U (R : P 0) (m : forall x, P x) : Prop. -Instance w : U (f _ (fun _ => v _)) v. +Instance w : U (f _ (fun _ => v _)) v := {}. Print HintDb typeclass_instances. End A. diff --git a/test-suite/bugs/closed/bug_7811.v b/test-suite/bugs/closed/bug_7811.v index fee330f22d..155f3285b7 100644 --- a/test-suite/bugs/closed/bug_7811.v +++ b/test-suite/bugs/closed/bug_7811.v @@ -1,4 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-top" "atomic" "-Q" "." "iris" "-R" "." "stdpp") -*- *) +(* -*- mode: coq; coq-prog-args: ("-top" "atomic" "-Q" "." "iris" "-R" "." "stdpp") -*- *) (* File reduced by coq-bug-finder from original input, then from 140 lines to 26 lines, then from 141 lines to 27 lines, then from 142 lines to 27 lines, then from 272 lines to 61 lines, then from 291 lines to 94 lines, then from 678 lines to 142 lines, then from 418 lines to 161 lines, then from 538 lines to 189 lines, then from 840 lines to 493 lines, then from 751 lines to 567 lines, then from 913 lines to 649 lines, then from 875 lines to 666 lines, then from 784 lines to 568 lines, then from 655 lines to 173 lines, then from 317 lines to 94 lines, then from 172 lines to 86 lines, then from 102 lines to 86 lines, then from 130 lines to 86 lines, then from 332 lines to 112 lines, then from 279 lines to 111 lines, then from 3996 lines to 5697 lines, then from 153 lines to 117 lines, then from 146 lines to 108 lines, then from 124 lines to 108 lines *) (* coqc version 8.8.0 (May 2018) compiled on May 2 2018 16:49:46 with OCaml 4.02.3 coqtop version 8.8.0 (May 2018) *) diff --git a/test-suite/bugs/closed/bug_9166.v b/test-suite/bugs/closed/bug_9166.v index 8a7e9c37b0..a89837dd12 100644 --- a/test-suite/bugs/closed/bug_9166.v +++ b/test-suite/bugs/closed/bug_9166.v @@ -1,3 +1,5 @@ +(* DO NOT MODIFY THIS FILE DIRECTLY *) +(* It is autogenerated by dev/tools/update-compat.py. *) Set Warnings "+deprecated". Notation bar := option (compat "8.7"). diff --git a/test-suite/bugs/closed/bug_9268.v b/test-suite/bugs/closed/bug_9268.v new file mode 100644 index 0000000000..02dd46f6d2 --- /dev/null +++ b/test-suite/bugs/closed/bug_9268.v @@ -0,0 +1,46 @@ +Require Import Coq.ZArith.ZArith. +Require Import Coq.micromega.Lia. + +Local Open Scope Z_scope. + +Definition Register := Z%type. + +Definition Opcode := Z%type. + +Inductive InstructionI : Type + := Lb : Register -> Register -> Z -> InstructionI + | InvalidI : InstructionI. + +Inductive Instruction : Type + := IInstruction : InstructionI -> Instruction. + +Definition funct3_LB : Z := 0. + +Definition opcode_LOAD : Opcode := 3. + +Set Universe Polymorphism. + +Definition MachineInt := Z. + +Definition funct3_JALR := 0. + +Axiom InstructionMapper: Type -> Type. + +Definition apply_InstructionMapper(mapper: InstructionMapper Z)(inst: Instruction): Z := + match inst with + | IInstruction InvalidI => 2 + | IInstruction (Lb rd rs1 oimm12) => 3 + end. + +Axiom Encoder: InstructionMapper MachineInt. + +Definition encode: Instruction -> MachineInt := apply_InstructionMapper Encoder. + +Lemma foo: forall (ins: InstructionI), + 0 <= encode (IInstruction ins) -> + 0 <= encode (IInstruction ins) . +Proof. + Set Printing Universes. + intros. + lia. +Qed. diff --git a/test-suite/bugs/closed/bug_9367.v b/test-suite/bugs/closed/bug_9367.v new file mode 100644 index 0000000000..885f6bc391 --- /dev/null +++ b/test-suite/bugs/closed/bug_9367.v @@ -0,0 +1,12 @@ +Section foo. +Variable f : forall n : nat, nat. +Arguments f {_}. +Check f (n := 3). +Global Arguments f {bar} : rename. +End foo. + +Section foo. +Variable f : forall n : nat, nat. +Arguments f {_}. +Fail Check f (bar := 3). +End foo. diff --git a/test-suite/bugs/closed/bug_9451.v b/test-suite/bugs/closed/bug_9451.v new file mode 100644 index 0000000000..03bb0433f1 --- /dev/null +++ b/test-suite/bugs/closed/bug_9451.v @@ -0,0 +1,8 @@ +Goal False. +cut True. +assert False. +evar (x : True). +let v := open_constr:(_) in idtac. all: exfalso; clear. +Optimize Proof. +(* Error: Anomaly "grounding a non evar-free term" *) +Abort All. diff --git a/test-suite/bugs/closed/bug_9453.v b/test-suite/bugs/closed/bug_9453.v new file mode 100644 index 0000000000..18745533b2 --- /dev/null +++ b/test-suite/bugs/closed/bug_9453.v @@ -0,0 +1,7 @@ +(* check compatibility with 8.8 and earlier for lack of warnings on the nat 5000 *) +Set Warnings Append "+large-nat,+abstract-large-number". +Fail Check 5001. +Check 5000. +(* Error: +To avoid stack overflow, large numbers in nat are interpreted as applications of +Nat.of_uint. *) diff --git a/test-suite/complexity/constructor.v b/test-suite/complexity/constructor.v index c5e1953829..31217ca75e 100644 --- a/test-suite/complexity/constructor.v +++ b/test-suite/complexity/constructor.v @@ -214,3 +214,4 @@ Fixpoint expand (n : nat) : Prop := Example Expand : expand 2500. Time constructor. (* ~0.45 secs *) +Qed. diff --git a/test-suite/complexity/f_equal.v b/test-suite/complexity/f_equal.v index 86698fa872..c2c566930b 100644 --- a/test-suite/complexity/f_equal.v +++ b/test-suite/complexity/f_equal.v @@ -12,3 +12,4 @@ end. Goal stupid 23 = stupid 23. Timeout 5 Time f_equal. +Abort. diff --git a/test-suite/complexity/injection.v b/test-suite/complexity/injection.v index a76fa19d3c..298a07c1c4 100644 --- a/test-suite/complexity/injection.v +++ b/test-suite/complexity/injection.v @@ -111,3 +111,4 @@ Lemma test: forall n1 w1 n2 w2, mk_world n1 w1 = mk_world n2 w2 -> Proof. intros. Timeout 10 Time injection H. +Abort. diff --git a/test-suite/complexity/ring.v b/test-suite/complexity/ring.v index 51f7c4dabc..2d585ce5c5 100644 --- a/test-suite/complexity/ring.v +++ b/test-suite/complexity/ring.v @@ -5,3 +5,4 @@ Require Import ZArith. Open Scope Z_scope. Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13. Timeout 5 Time intro; ring. +Abort. diff --git a/test-suite/complexity/ring2.v b/test-suite/complexity/ring2.v index 04fa59075b..1c119b8e42 100644 --- a/test-suite/complexity/ring2.v +++ b/test-suite/complexity/ring2.v @@ -50,3 +50,4 @@ Infix "+" := Zadd : Z_scope. Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13. Timeout 5 Time intro; ring. +Abort. diff --git a/test-suite/complexity/setoid_rewrite.v b/test-suite/complexity/setoid_rewrite.v index 2e3b006ef0..10b270ccad 100644 --- a/test-suite/complexity/setoid_rewrite.v +++ b/test-suite/complexity/setoid_rewrite.v @@ -8,3 +8,4 @@ Variable f : nat -> Prop. Goal forall U:Prop, f 100 <-> U. intros U. Timeout 5 Time setoid_replace U with False. +Abort. diff --git a/test-suite/complexity/unification.v b/test-suite/complexity/unification.v index d2ea527516..0c9915c84e 100644 --- a/test-suite/complexity/unification.v +++ b/test-suite/complexity/unification.v @@ -49,3 +49,4 @@ Goal )))) . Timeout 2 Time try refine (refl_equal _). +Abort. diff --git a/test-suite/coqchk/inductive_functor_squash.v b/test-suite/coqchk/inductive_functor_squash.v new file mode 100644 index 0000000000..9d33fafc4c --- /dev/null +++ b/test-suite/coqchk/inductive_functor_squash.v @@ -0,0 +1,15 @@ + + +Module Type T. + Parameter f : nat -> Type. +End T. + +Module F(A:T). + Inductive ind : Prop := + C : A.f 0 -> ind. +End F. + +Module A. Definition f (x:nat) := True. End A. + +Module M := F A. +(* M.ind could eliminate into Set/Type even though F.ind can't *) diff --git a/test-suite/ide/debug_ltac.fake b/test-suite/ide/debug_ltac.fake new file mode 100644 index 0000000000..aa68fad39e --- /dev/null +++ b/test-suite/ide/debug_ltac.fake @@ -0,0 +1,2 @@ +FAILADD { Debug On. } +ADD { Set Debug On. } diff --git a/test-suite/misc/4722.sh b/test-suite/misc/4722.sh index 86bc50b5cd..70071b9d60 100755 --- a/test-suite/misc/4722.sh +++ b/test-suite/misc/4722.sh @@ -4,12 +4,12 @@ set -e # create test files mkdir -p misc/4722 ln -sf toto misc/4722/tata -touch misc/4722.v +touch misc/bug_4722.v # run test -$coqtop "-R" "misc/4722" "Foo" -top Top -load-vernac-source misc/4722.v +$coqc "-R" "misc/4722" "Foo" -top Top misc/bug_4722.v # clean up test files rm misc/4722/tata rmdir misc/4722 -rm misc/4722.v +rm misc/bug_4722.v diff --git a/test-suite/misc/7704.sh b/test-suite/misc/7704.sh index 0ca2c97d24..5fc171649e 100755 --- a/test-suite/misc/7704.sh +++ b/test-suite/misc/7704.sh @@ -4,4 +4,4 @@ set -e export PATH=$BIN:$PATH -${coqtop#"$BIN"} -compile misc/aux7704.v +${coqc#"$BIN"} misc/aux7704.v diff --git a/test-suite/misc/aux7704.v b/test-suite/misc/aux7704.v index 6fdcf67684..1c95211a71 100644 --- a/test-suite/misc/aux7704.v +++ b/test-suite/misc/aux7704.v @@ -1,4 +1,3 @@ - Goal True /\ True. Proof. split. diff --git a/test-suite/misc/deps-checksum.sh b/test-suite/misc/deps-checksum.sh index a15a8fbee9..8523358303 100755 --- a/test-suite/misc/deps-checksum.sh +++ b/test-suite/misc/deps-checksum.sh @@ -3,4 +3,4 @@ rm -f misc/deps/A/*.vo misc/deps/B/*.vo $coqc -R misc/deps/A A misc/deps/A/A.v $coqc -R misc/deps/B A misc/deps/B/A.v $coqc -R misc/deps/B A misc/deps/B/B.v -$coqtop -R misc/deps/B A -R misc/deps/A A -load-vernac-source misc/deps/checksum.v +$coqc -R misc/deps/B A -R misc/deps/A A misc/deps/checksum.v diff --git a/test-suite/misc/deps-order.sh b/test-suite/misc/deps-order.sh index 6bb2ba2da0..551515b0d6 100755 --- a/test-suite/misc/deps-order.sh +++ b/test-suite/misc/deps-order.sh @@ -10,12 +10,12 @@ R=$? times $coqc -R misc/deps/lib lib misc/deps/lib/foo.v 2>&1 $coqc -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/foo.v 2>&1 -$coqtop -R misc/deps/lib lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1 +$coqc -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 S=$? if [ $R = 0 ] && [ $S = 0 ]; then - printf "coqdep and coqtop agree\n" + printf "coqdep and coqc agree\n" exit 0 else - printf "coqdep and coqtop disagree\n" + printf "coqdep and coqc disagree\n" exit 1 fi diff --git a/test-suite/misc/deps-utf8.sh b/test-suite/misc/deps-utf8.sh index acb45b2292..af69370ce4 100755 --- a/test-suite/misc/deps-utf8.sh +++ b/test-suite/misc/deps-utf8.sh @@ -8,7 +8,7 @@ rm -f misc/deps/théorèmes/*.v tmpoutput=$(mktemp /tmp/coqcheck.XXXXXX) $coqc -R misc/deps AlphaBêta misc/deps/αβ/γδ.v R=$? -$coqtop -R misc/deps AlphaBêta -load-vernac-source misc/deps/αβ/εζ.v +$coqc -R misc/deps AlphaBêta misc/deps/αβ/εζ.v S=$? if [ $R = 0 ] && [ $S = 0 ]; then exit 0 diff --git a/test-suite/misc/exitstatus.sh b/test-suite/misc/exitstatus.sh index a327f4248b..afc415b2da 100755 --- a/test-suite/misc/exitstatus.sh +++ b/test-suite/misc/exitstatus.sh @@ -1,8 +1,5 @@ #!/bin/sh -$coqtop -load-vernac-source misc/exitstatus/illtyped.v -N=$? $coqc misc/exitstatus/illtyped.v P=$? -printf "On ill-typed input, coqtop returned %s.\n" "$N" printf "On ill-typed input, coqc returned %s.\n" "$P" -if [ $N = 1 ] && [ $P = 1 ]; then exit 0; else exit 1; fi +if [ $P = 1 ]; then exit 0; else exit 1; fi diff --git a/test-suite/output/FunExt.v b/test-suite/output/FunExt.v index 7658ce718e..440fe46003 100644 --- a/test-suite/output/FunExt.v +++ b/test-suite/output/FunExt.v @@ -1,3 +1,4 @@ +(* -*- coq-prog-args: ("-async-proofs" "no") -*- *) Require Import FunctionalExtensionality. (* Basic example *) diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 94016e170b..7a64b7eb45 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -45,5 +45,9 @@ fun x : nat => (x.-1)%pred : Prop ## : Prop +myAnd1 True True + : Prop +r 2 3 + : Prop Notation Cn := Foo.FooCn -Expands to: Notation Top.J.Mfoo.Foo.Bar.Cn +Expands to: Notation Notations4.J.Mfoo.Foo.Bar.Cn diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 309115848f..90babf9c55 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -165,6 +165,22 @@ Check ##. End H. +(* Fixing bugs reported by G. Gonthier in #9207 *) + +Module I. + +Definition myAnd A B := A /\ B. +Notation myAnd1 A := (myAnd A). +Check myAnd1 True True. + +Set Warnings "-auto-template". + +Record Pnat := {inPnat :> nat -> Prop}. +Axiom r : nat -> Pnat. +Check r 2 3. + +End I. + (* Fixing a bug reported by G. Gonthier in #9207 *) Module J. diff --git a/test-suite/output/RecognizePluginWarning.v b/test-suite/output/RecognizePluginWarning.v index cd667bbd00..a53b52396f 100644 --- a/test-suite/output/RecognizePluginWarning.v +++ b/test-suite/output/RecognizePluginWarning.v @@ -1,4 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-w" "extraction-logical-axiom") -*- *) +(* -*- mode: coq; coq-prog-args: ("-w" "extraction-logical-axiom") -*- *) (* Test that mentioning a warning defined in plugins works. The failure mode here is that these result in a warning about unknown warnings, since the diff --git a/test-suite/output/Show.v b/test-suite/output/Show.v index 60faac8dd9..c875051bdc 100644 --- a/test-suite/output/Show.v +++ b/test-suite/output/Show.v @@ -5,7 +5,7 @@ Theorem nums : forall (n m : nat), n = m -> (S n) = (S m). Proof. intros. - induction n as [| n']. + induction n as [| n']. induction m as [| m']. Show. Admitted. diff --git a/test-suite/output/UnclosedBlocks.v b/test-suite/output/UnclosedBlocks.v index 854bd6a6d5..b9ba579246 100644 --- a/test-suite/output/UnclosedBlocks.v +++ b/test-suite/output/UnclosedBlocks.v @@ -1,4 +1,3 @@ -(* -*- mode: coq; coq-prog-args: ("-compile" "UnclosedBlocks.v") *) Module Foo. Module Closed. End Closed. diff --git a/test-suite/output/UsePluginWarning.v b/test-suite/output/UsePluginWarning.v index c6e0054641..618b8fd42f 100644 --- a/test-suite/output/UsePluginWarning.v +++ b/test-suite/output/UsePluginWarning.v @@ -1,5 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-w" "-extraction-logical-axiom") -*- *) - +(* -*- mode: coq; coq-prog-args: ("-w" "-extraction-logical-axiom") -*- *) Require Extraction. Axiom foo : Prop. diff --git a/test-suite/output/simpl.v b/test-suite/output/simpl.v index 5f1926f142..5f7e3ab9dd 100644 --- a/test-suite/output/simpl.v +++ b/test-suite/output/simpl.v @@ -11,3 +11,4 @@ Undo. simpl (0 + _). Show. Undo. +Abort. diff --git a/test-suite/output/unifconstraints.v b/test-suite/output/unifconstraints.v index 179dec3fb0..c987d66c5f 100644 --- a/test-suite/output/unifconstraints.v +++ b/test-suite/output/unifconstraints.v @@ -1,3 +1,4 @@ +(* -*- coq-prog-args: ("-async-proofs" "no") -*- *) (* Set Printing Existential Instances. *) Unset Solve Unification Constraints. Axiom veeryyyyyyyyyyyyloooooooooooooonggidentifier : nat. diff --git a/test-suite/report.sh b/test-suite/report.sh index cef615266b..71aac029ea 100755 --- a/test-suite/report.sh +++ b/test-suite/report.sh @@ -24,21 +24,11 @@ cp summary.log "$SAVEDIR"/ rm "$FAILED" # print info -if [ -n "$TRAVIS" ] || [ -n "$APPVEYOR" ] || [ -n "$PRINT_LOGS" ]; then +if [ -n "$APPVEYOR" ] || [ -n "$PRINT_LOGS" ]; then find logs/ -name '*.log' -not -name 'summary.log' -print0 | while IFS= read -r -d '' file; do - if [ -n "$TRAVIS" ]; then - # ${foo////.} replaces every / by . in $foo - printf 'travis_fold:start:coq.logs.%s\n' "${file////.}"; - else printf '%s\n' "$file" - fi - + printf '%s\n' "$file" cat "$file" - - if [ -n "$TRAVIS" ]; then - # ${foo////.} replaces every / by . in $foo - printf 'travis_fold:end:coq.logs.%s\n' "${file////.}"; - else printf '\n' - fi + printf '\n' done printed_logs=1 fi diff --git a/test-suite/ssr/ipat_replace.v b/test-suite/ssr/ipat_replace.v new file mode 100644 index 0000000000..528f33f30d --- /dev/null +++ b/test-suite/ssr/ipat_replace.v @@ -0,0 +1,17 @@ +Require Import ssreflect. + +Lemma test : True. +Proof. +have H : True. + by []. +have {}H : True. + by apply: H. +by apply: H. +Qed. + +Lemma test2 (H : True) : False -> False -> False. +Proof. +move=> {}W. +move=> {}H. +by apply: H. +Qed. diff --git a/test-suite/success/CompatCurrentFlag.v b/test-suite/success/CompatCurrentFlag.v index 5650dba236..81469d79c3 100644 --- a/test-suite/success/CompatCurrentFlag.v +++ b/test-suite/success/CompatCurrentFlag.v @@ -1,3 +1,3 @@ -(* -*- coq-prog-args: ("-compat" "8.9") -*- *) +(* -*- coq-prog-args: ("-compat" "8.10") -*- *) (** Check that the current compatibility flag actually requires the relevant modules. *) -Import Coq.Compat.Coq89. +Import Coq.Compat.Coq810. diff --git a/test-suite/success/CompatOldFlag.v b/test-suite/success/CompatOldFlag.v index 37d50ee67d..afeb57f9f2 100644 --- a/test-suite/success/CompatOldFlag.v +++ b/test-suite/success/CompatOldFlag.v @@ -1,5 +1,5 @@ -(* -*- coq-prog-args: ("-compat" "8.7") -*- *) +(* -*- coq-prog-args: ("-compat" "8.8") -*- *) (** Check that the current-minus-two compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq810. Import Coq.Compat.Coq89. Import Coq.Compat.Coq88. -Import Coq.Compat.Coq87. diff --git a/test-suite/success/CompatOldOldFlag.v b/test-suite/success/CompatOldOldFlag.v new file mode 100644 index 0000000000..1f62635f50 --- /dev/null +++ b/test-suite/success/CompatOldOldFlag.v @@ -0,0 +1,6 @@ +(* -*- coq-prog-args: ("-compat" "8.7") -*- *) +(** Check that the current-minus-three compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq810. +Import Coq.Compat.Coq89. +Import Coq.Compat.Coq88. +Import Coq.Compat.Coq87. diff --git a/test-suite/success/CompatPreviousFlag.v b/test-suite/success/CompatPreviousFlag.v index 9981388381..c8f75915c8 100644 --- a/test-suite/success/CompatPreviousFlag.v +++ b/test-suite/success/CompatPreviousFlag.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-compat" "8.8") -*- *) +(* -*- coq-prog-args: ("-compat" "8.9") -*- *) (** Check that the current-minus-one compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq810. Import Coq.Compat.Coq89. -Import Coq.Compat.Coq88. diff --git a/test-suite/success/Nia.v b/test-suite/success/Nia.v new file mode 100644 index 0000000000..62ecece792 --- /dev/null +++ b/test-suite/success/Nia.v @@ -0,0 +1,918 @@ +Require Import Coq.ZArith.ZArith. +Require Import Coq.micromega.Lia. +Open Scope Z_scope. + +(** Add [Z.to_euclidean_division_equations] to the end of [zify], just for this + file. *) +Ltac zify ::= repeat (zify_nat; zify_positive; zify_N); zify_op; Z.to_euclidean_division_equations. + +Lemma Z_zerop_or x : x = 0 \/ x <> 0. Proof. nia. Qed. +Lemma Z_eq_dec_or (x y : Z) : x = y \/ x <> y. Proof. nia. Qed. + +Ltac unique_pose_proof pf := + let T := type of pf in + lazymatch goal with + | [ H : T |- _ ] => fail + | _ => pose proof pf + end. + +Ltac saturate_mod_div := + repeat match goal with + | [ |- context[?x mod ?y] ] => unique_pose_proof (Z_zerop_or (x / y)) + | [ H : context[?x mod ?y] |- _ ] => unique_pose_proof (Z_zerop_or (x / y)) + | [ |- context[?x / ?y] ] => unique_pose_proof (Z_zerop_or y) + | [ H : context[?x / ?y] |- _ ] => unique_pose_proof (Z_zerop_or y) + | [ |- context[Z.rem ?x ?y] ] => unique_pose_proof (Z_zerop_or (Z.quot x y)) + | [ H : context[Z.rem ?x ?y] |- _ ] => unique_pose_proof (Z_zerop_or (Z.quot x y)) + | [ |- context[Z.quot ?x ?y] ] => unique_pose_proof (Z_zerop_or y) + | [ H : context[Z.quot ?x ?y] |- _ ] => unique_pose_proof (Z_zerop_or y) + end. + +Ltac t := intros; saturate_mod_div; try nia. + +Ltac destr_step := + match goal with + | [ H : and _ _ |- _ ] => destruct H + | [ H : or _ _ |- _ ] => destruct H + end. + +Example mod_0_l: forall x : Z, 0 mod x = 0. Proof. t. Qed. +Example mod_0_r: forall x : Z, x mod 0 = 0. Proof. intros; nia. Qed. +Example Z_mod_same_full: forall a : Z, a mod a = 0. Proof. t. Qed. +Example Zmod_0_l: forall a : Z, 0 mod a = 0. Proof. t. Qed. +Example Zmod_0_r: forall a : Z, a mod 0 = 0. Proof. intros; nia. Qed. +Example mod_mod_same: forall x y : Z, (x mod y) mod y = x mod y. Proof. t. Qed. +Example Zmod_mod: forall a n : Z, (a mod n) mod n = a mod n. Proof. t. Qed. +Example Zmod_1_r: forall a : Z, a mod 1 = 0. Proof. intros; nia. Qed. +Example Zmod_div: forall a b : Z, a mod b / b = 0. Proof. intros; nia. Qed. +Example Z_mod_1_r: forall a : Z, a mod 1 = 0. Proof. intros; nia. Qed. +Example Z_mod_same: forall a : Z, a > 0 -> a mod a = 0. Proof. t. Qed. +Example Z_mod_mult: forall a b : Z, (a * b) mod b = 0. +Proof. + intros a b. + assert (b = 0 \/ (a * b) / b = a) by nia. + nia. +Qed. +Example Z_mod_same': forall a : Z, a <> 0 -> a mod a = 0. Proof. t. Qed. +Example Z_mod_0_l: forall a : Z, a <> 0 -> 0 mod a = 0. Proof. t. Qed. +Example Zmod_opp_opp: forall a b : Z, - a mod - b = - (a mod b). +Proof. + intros a b. + pose proof (Z_eq_dec_or ((-a)/(-b)) (a/b)). + nia. +Qed. +Example Z_mod_le: forall a b : Z, 0 <= a -> 0 < b -> a mod b <= a. Proof. t. Qed. +Example Zmod_le: forall a b : Z, 0 < b -> 0 <= a -> a mod b <= a. Proof. t. Qed. +Example Zplus_mod_idemp_r: forall a b n : Z, (b + a mod n) mod n = (b + a) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((b + a mod n) / n = (b / n) + (b mod n + a mod n) / n) + by nia. + assert ((b + a) / n = (b / n) + (a / n) + (b mod n + a mod n) / n) + by nia. + nia. +Qed. +Example Zplus_mod_idemp_l: forall a b n : Z, (a mod n + b) mod n = (a + b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a mod n + b) / n = (b / n) + (b mod n + a mod n) / n) by nia. + assert ((a + b) / n = (b / n) + (a / n) + (b mod n + a mod n) / n) by nia. + nia. +Qed. +Example Zmult_mod_distr_r: forall a b c : Z, (a * c) mod (b * c) = a mod b * c. +Proof. + intros a b c. + destruct (Z_zerop c); try nia. + pose proof (Z_eq_dec_or ((a * c) / (b * c)) (a / b)). + nia. +Qed. +Example Z_mod_zero_opp_full: forall a b : Z, a mod b = 0 -> - a mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(-a/b))). + nia. +Qed. +Example Zmult_mod_idemp_r: forall a b n : Z, (b * (a mod n)) mod n = (b * a) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((b * (a mod n)) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) + by nia. + assert ((b * a) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) + by nia. + nia. +Qed. +Example Zmult_mod_idemp_l: forall a b n : Z, (a mod n * b) mod n = (a * b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert (((a mod n) * b) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) + by nia. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) + by nia. + nia. +Qed. +Example Zminus_mod_idemp_r: forall a b n : Z, (a - b mod n) mod n = (a - b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a - b mod n) / n = a / n + ((a mod n) - (b mod n)) / n) by nia. + assert ((a - b) / n = a / n - b / n + ((a mod n) - (b mod n)) / n) by nia. + nia. +Qed. +Example Zminus_mod_idemp_l: forall a b n : Z, (a mod n - b) mod n = (a - b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a mod n - b) / n = - (b / n) + ((a mod n) - (b mod n)) / n) by nia. + assert ((a - b) / n = a / n - b / n + ((a mod n) - (b mod n)) / n) by nia. + nia. +Qed. +Example Z_mod_plus_full: forall a b c : Z, (a + b * c) mod c = a mod c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c + b)). + nia. +Qed. +Example Zmult_mod_distr_l: forall a b c : Z, (c * a) mod (c * b) = c * (a mod b). +Proof. + intros a b c. + destruct (Z_zerop c); try nia. + pose proof (Z_eq_dec_or ((c * a) / (c * b)) (a / b)). + nia. +Qed. +Example Z_mod_zero_opp_r: forall a b : Z, a mod b = 0 -> a mod - b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(a/-b))). + nia. +Qed. +Example Zmod_1_l: forall a : Z, 1 < a -> 1 mod a = 1. Proof. t. Qed. +Example Z_mod_1_l: forall a : Z, 1 < a -> 1 mod a = 1. Proof. t. Qed. +Example Z_mod_mul: forall a b : Z, b <> 0 -> (a * b) mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or ((a*b)/b) a). + nia. +Qed. +Example Zminus_mod: forall a b n : Z, (a - b) mod n = (a mod n - b mod n) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a - b) / n = (a / n) - (b / n) + ((a mod n) - (b mod n)) / n) by nia. + nia. +Qed. +Example Zplus_mod: forall a b n : Z, (a + b) mod n = (a mod n + b mod n) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a + b) / n = (a / n) + (b / n) + ((a mod n) + (b mod n)) / n) by nia. + nia. +Qed. +Example Zmult_mod: forall a b n : Z, (a * b) mod n = (a mod n * (b mod n)) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a * b) / n = n * (a / n) * (b / n) + (a mod n) * (b / n) + (a / n) * (b mod n) + ((a mod n) * (b mod n)) / n) + by nia. + nia. +Qed. +Example Z_mod_mod: forall a n : Z, n <> 0 -> (a mod n) mod n = a mod n. Proof. t. Qed. +Example Z_mod_div: forall a b : Z, b <> 0 -> a mod b / b = 0. Proof. intros; nia. Qed. +Example Z_div_exact_full_1: forall a b : Z, a = b * (a / b) -> a mod b = 0. Proof. intros; nia. Qed. +Example Z_mod_pos_bound: forall a b : Z, 0 < b -> 0 <= a mod b < b. Proof. intros; nia. Qed. +Example Z_mod_sign_mul: forall a b : Z, b <> 0 -> 0 <= a mod b * b. Proof. intros; nia. Qed. +Example Z_mod_neg_bound: forall a b : Z, b < 0 -> b < a mod b <= 0. Proof. intros; nia. Qed. +Example Z_mod_neg: forall a b : Z, b < 0 -> b < a mod b <= 0. Proof. intros; nia. Qed. +Example div_mod_small: forall x y : Z, 0 <= x < y -> x mod y = x. Proof. t. Qed. +Example Zmod_small: forall a n : Z, 0 <= a < n -> a mod n = a. Proof. t. Qed. +Example Z_mod_small: forall a b : Z, 0 <= a < b -> a mod b = a. Proof. t. Qed. +Example Z_div_zero_opp_full: forall a b : Z, a mod b = 0 -> - a / b = - (a / b). Proof. intros; nia. Qed. +Example Z_mod_zero_opp: forall a b : Z, b > 0 -> a mod b = 0 -> - a mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(-a/b))). + nia. +Qed. +Example Z_div_zero_opp_r: forall a b : Z, a mod b = 0 -> a / - b = - (a / b). Proof. intros; nia. Qed. +Example Z_mod_lt: forall a b : Z, b > 0 -> 0 <= a mod b < b. Proof. intros; nia. Qed. +Example Z_mod_opp_opp: forall a b : Z, b <> 0 -> - a mod - b = - (a mod b). +Proof. + intros a b. + pose proof (Z_eq_dec_or ((-a)/(-b)) ((a/b))). + nia. +Qed. +Example Z_mod_bound_pos: forall a b : Z, 0 <= a -> 0 < b -> 0 <= a mod b < b. Proof. intros; nia. Qed. +Example Z_mod_opp_l_z: forall a b : Z, b <> 0 -> a mod b = 0 -> - a mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(-a/b))). + nia. +Qed. +Example Z_mod_plus: forall a b c : Z, c > 0 -> (a + b * c) mod c = a mod c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c+b)). + nia. +Qed. +Example Z_mod_opp_r_z: forall a b : Z, b <> 0 -> a mod b = 0 -> a mod - b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(a/-b))). + nia. +Qed. +Example Zmod_eq: forall a b : Z, b > 0 -> a mod b = a - a / b * b. Proof. intros; nia. Qed. +Example Z_div_exact_2: forall a b : Z, b > 0 -> a mod b = 0 -> a = b * (a / b). Proof. intros; nia. Qed. +Example Z_div_mod_eq: forall a b : Z, b > 0 -> a = b * (a / b) + a mod b. Proof. intros; nia. Qed. +Example Z_div_exact_1: forall a b : Z, b > 0 -> a = b * (a / b) -> a mod b = 0. Proof. intros; nia. Qed. +Example Z_mod_add: forall a b c : Z, c <> 0 -> (a + b * c) mod c = a mod c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c+b)). + nia. +Qed. +Example Z_mod_nz_opp_r: forall a b : Z, a mod b <> 0 -> a mod - b = a mod b - b. +Proof. + intros a b. + assert (a mod b <> 0 -> a / -b = -(a/b)-1) by t. + nia. +Qed. +Example Z_mul_mod_idemp_l: forall a b n : Z, n <> 0 -> (a mod n * b) mod n = (a * b) mod n. +Proof. + intros a b n ?. + assert (((a mod n) * b) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) + by nia. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) + by nia. + nia. +Qed. +Example Z_mod_nz_opp_full: forall a b : Z, a mod b <> 0 -> - a mod b = b - a mod b. +Proof. + intros a b. + assert (a mod b <> 0 -> -a/b = -1-a/b) by nia. + nia. +Qed. +Example Z_add_mod_idemp_r: forall a b n : Z, n <> 0 -> (a + b mod n) mod n = (a + b) mod n. +Proof. + intros a b n ?. + assert ((a + b mod n) / n = (a / n) + (a mod n + b mod n) / n) by nia. + assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. + nia. +Qed. +Example Z_add_mod_idemp_l: forall a b n : Z, n <> 0 -> (a mod n + b) mod n = (a + b) mod n. +Proof. + intros a b n ?. + assert ((a mod n + b) / n = (b / n) + (a mod n + b mod n) / n) by nia. + assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. + nia. +Qed. +Example Z_mul_mod_idemp_r: forall a b n : Z, n <> 0 -> (a * (b mod n)) mod n = (a * b) mod n. +Proof. + intros a b n ?. + assert ((a * (b mod n)) / n = (a / n) * (b mod n) + ((a mod n) * (b mod n)) / n) + by nia. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((a mod n) * (b mod n)) / n) + by nia. + nia. +Qed. +Example Zmod_eq_full: forall a b : Z, b <> 0 -> a mod b = a - a / b * b. Proof. intros; nia. Qed. +Example div_eq: forall x y : Z, y <> 0 -> x mod y = 0 -> x / y * y = x. Proof. intros; nia. Qed. +Example Z_mod_eq: forall a b : Z, b <> 0 -> a mod b = a - b * (a / b). Proof. intros; nia. Qed. +Example Z_mod_sign_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> Z.sgn (a mod b) = Z.sgn b. Proof. intros; nia. Qed. +Example Z_div_exact_full_2: forall a b : Z, b <> 0 -> a mod b = 0 -> a = b * (a / b). Proof. intros; nia. Qed. +Example Z_div_mod: forall a b : Z, b <> 0 -> a = b * (a / b) + a mod b. Proof. intros; nia. Qed. +Example Z_add_mod: forall a b n : Z, n <> 0 -> (a + b) mod n = (a mod n + b mod n) mod n. +Proof. + intros a b n ?. + assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. + nia. +Qed. +Example Z_mul_mod: forall a b n : Z, n <> 0 -> (a * b) mod n = (a mod n * (b mod n)) mod n. +Proof. + intros a b n ?. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((a mod n) * (b mod n)) / n) + by nia. + nia. +Qed. +Example Z_div_exact: forall a b : Z, b <> 0 -> a = b * (a / b) <-> a mod b = 0. Proof. intros; nia. Qed. +Example Z_div_opp_l_z: forall a b : Z, b <> 0 -> a mod b = 0 -> - a / b = - (a / b). Proof. intros; nia. Qed. +Example Z_div_opp_r_z: forall a b : Z, b <> 0 -> a mod b = 0 -> a / - b = - (a / b). Proof. intros; nia. Qed. +Example Z_mod_opp_r_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> a mod - b = a mod b - b. +Proof. + intros a b. + assert (a mod b <> 0 -> a/(-b) = -1-a/b) by nia. + nia. +Qed. +Example Z_mul_mod_distr_r: forall a b c : Z, b <> 0 -> c <> 0 -> (a * c) mod (b * c) = a mod b * c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a*c)/(b*c)) (a/b)). + nia. +Qed. +Example Z_mul_mod_distr_l: forall a b c : Z, b <> 0 -> c <> 0 -> (c * a) mod (c * b) = c * (a mod b). +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((c*a)/(c*b)) (a/b)). + nia. +Qed. +Example Z_mod_opp_l_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> - a mod b = b - a mod b. +Proof. + intros a b. + assert (a mod b <> 0 -> -a/b = -1-a/b) by nia. + nia. +Qed. +Example mod_eq: forall x x' y : Z, x / y = x' / y -> x mod y = x' mod y -> y <> 0 -> x = x'. Proof. intros; nia. Qed. +Example Z_div_nz_opp_r: forall a b : Z, a mod b <> 0 -> a / - b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Z_div_nz_opp_full: forall a b : Z, a mod b <> 0 -> - a / b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Zmod_unique: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a / b) by nia. + nia. +Qed. +Example Z_mod_unique_neg: forall a b q r : Z, b < r <= 0 -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a / b) by nia. + nia. +Qed. +Example Z_mod_unique_pos: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a / b) by nia. + nia. +Qed. +Example Z_rem_mul_r: forall a b c : Z, b <> 0 -> 0 < c -> a mod (b * c) = a mod b + b * ((a / b) mod c). +Proof. + intros a b c ??. + assert (a / (b * c) = ((a / b) / c)) by nia. + nia. +Qed. +Example Z_mod_bound_or: forall a b : Z, b <> 0 -> 0 <= a mod b < b \/ b < a mod b <= 0. Proof. intros; nia. Qed. +Example Z_div_opp_l_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> - a / b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Z_div_opp_r_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> a / - b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Z_mod_small_iff: forall a b : Z, b <> 0 -> a mod b = a <-> 0 <= a < b \/ b < a <= 0. Proof. t. Qed. +Example Z_mod_unique: forall a b q r : Z, 0 <= r < b \/ b < r <= 0 -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a/b) by nia. + nia. +Qed. +Example Z_opp_mod_bound_or: forall a b : Z, b <> 0 -> 0 <= - (a mod b) < - b \/ - b < - (a mod b) <= 0. Proof. intros; nia. Qed. + +Example Zdiv_0_r: forall a : Z, a / 0 = 0. Proof. intros; nia. Qed. +Example Zdiv_0_l: forall a : Z, 0 / a = 0. Proof. intros; nia. Qed. +Example Z_div_1_r: forall a : Z, a / 1 = a. Proof. intros; nia. Qed. +Example Zdiv_1_r: forall a : Z, a / 1 = a. Proof. intros; nia. Qed. +Example Zdiv_opp_opp: forall a b : Z, - a / - b = a / b. Proof. intros; nia. Qed. +Example Z_div_0_l: forall a : Z, a <> 0 -> 0 / a = 0. Proof. intros; nia. Qed. +Example Z_div_pos: forall a b : Z, b > 0 -> 0 <= a -> 0 <= a / b. Proof. intros; nia. Qed. +Example Z_div_ge0: forall a b : Z, b > 0 -> a >= 0 -> a / b >= 0. Proof. intros; nia. Qed. +Example Z_div_pos': forall a b : Z, 0 <= a -> 0 < b -> 0 <= a / b. Proof. intros; nia. Qed. +Example Z_mult_div_ge: forall a b : Z, b > 0 -> b * (a / b) <= a. Proof. intros; nia. Qed. +Example Z_mult_div_ge_neg: forall a b : Z, b < 0 -> b * (a / b) >= a. Proof. intros; nia. Qed. +Example Z_mul_div_le: forall a b : Z, 0 < b -> b * (a / b) <= a. Proof. intros; nia. Qed. +Example Z_mul_div_ge: forall a b : Z, b < 0 -> a <= b * (a / b). Proof. intros; nia. Qed. +Example Z_div_same: forall a : Z, a > 0 -> a / a = 1. Proof. intros; nia. Qed. +Example Z_div_mult: forall a b : Z, b > 0 -> a * b / b = a. Proof. intros; nia. Qed. +Example Z_mul_succ_div_gt: forall a b : Z, 0 < b -> a < b * Z.succ (a / b). Proof. intros; nia. Qed. +Example Z_mul_succ_div_lt: forall a b : Z, b < 0 -> b * Z.succ (a / b) < a. Proof. intros; nia. Qed. +Example Zdiv_1_l: forall a : Z, 1 < a -> 1 / a = 0. Proof. intros; nia. Qed. +Example Z_div_1_l: forall a : Z, 1 < a -> 1 / a = 0. Proof. intros; nia. Qed. +Example Z_div_str_pos: forall a b : Z, 0 < b <= a -> 0 < a / b. Proof. intros; nia. Qed. +Example Z_div_ge: forall a b c : Z, c > 0 -> a >= b -> a / c >= b / c. Proof. intros; nia. Qed. +Example Z_div_mult_full: forall a b : Z, b <> 0 -> a * b / b = a. Proof. intros; nia. Qed. +Example Z_div_same': forall a : Z, a <> 0 -> a / a = 1. Proof. intros; nia. Qed. +Example Zdiv_lt_upper_bound: forall a b q : Z, 0 < b -> a < q * b -> a / b < q. Proof. intros; nia. Qed. +Example Z_div_mul: forall a b : Z, b <> 0 -> a * b / b = a. Proof. intros; nia. Qed. +Example Z_div_lt: forall a b : Z, 0 < a -> 1 < b -> a / b < a. Proof. intros; nia. Qed. +Example Z_div_le_mono: forall a b c : Z, 0 < c -> a <= b -> a / c <= b / c. Proof. intros; nia. Qed. +Example Zdiv_sgn: forall a b : Z, 0 <= Z.sgn (a / b) * Z.sgn a * Z.sgn b. Proof. intros; nia. Qed. +Example Z_div_same_full: forall a : Z, a <> 0 -> a / a = 1. Proof. intros; nia. Qed. +Example Z_div_lt_upper_bound: forall a b q : Z, 0 < b -> a < b * q -> a / b < q. Proof. intros; nia. Qed. +Example Z_div_le: forall a b c : Z, c > 0 -> a <= b -> a / c <= b / c. Proof. intros; nia. Qed. +Example Z_div_le_lower_bound: forall a b q : Z, 0 < b -> b * q <= a -> q <= a / b. Proof. intros; nia. Qed. +Example Zdiv_le_lower_bound: forall a b q : Z, 0 < b -> q * b <= a -> q <= a / b. Proof. intros; nia. Qed. +Example Zdiv_le_upper_bound: forall a b q : Z, 0 < b -> a <= q * b -> a / b <= q. Proof. intros; nia. Qed. +Example Z_div_le_upper_bound: forall a b q : Z, 0 < b -> a <= b * q -> a / b <= q. Proof. intros; nia. Qed. +Example Z_div_small: forall a b : Z, 0 <= a < b -> a / b = 0. Proof. intros; nia. Qed. +Example Zdiv_small: forall a b : Z, 0 <= a < b -> a / b = 0. Proof. intros; nia. Qed. +Example Z_div_opp_opp: forall a b : Z, b <> 0 -> - a / - b = a / b. Proof. intros; nia. Qed. +Example Zdiv_mult_cancel_r: forall a b c : Z, c <> 0 -> a * c / (b * c) = a / b. Proof. intros; nia. Qed. +Example Z_div_unique_exact: forall a b q : Z, b <> 0 -> a = b * q -> q = a / b. Proof. intros; nia. Qed. +Example Zdiv_mult_cancel_l: forall a b c : Z, c <> 0 -> c * a / (c * b) = a / b. Proof. intros; nia. Qed. +Example Zdiv_le_compat_l: forall p q r : Z, 0 <= p -> 0 < q < r -> p / r <= p / q. +Proof. + intros p q r ??. + assert (p mod r <= p mod q \/ p mod q <= p mod r) by nia. + assert (0 <= p / r) by nia. + assert (0 <= p / q) by nia. + nia. +Qed. +Example Z_div_le_compat_l: forall p q r : Z, 0 <= p -> 0 < q <= r -> p / r <= p / q. +Proof. + intros p q r ??. + assert (p mod r <= p mod q \/ p mod q <= p mod r) by nia. + assert (0 <= p / r) by nia. + assert (0 <= p / q) by nia. + nia. +Qed. +Example Zdiv_Zdiv: forall a b c : Z, 0 <= b -> 0 <= c -> a / b / c = a / (b * c). Proof. intros; nia. Qed. +Example Z_div_plus: forall a b c : Z, c > 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. +Example Z_div_lt': forall a b : Z, b >= 2 -> a > 0 -> a / b < a. Proof. intros; nia. Qed. +Example Zdiv_mult_le: forall a b c : Z, 0 <= a -> 0 <= b -> 0 <= c -> c * (a / b) <= c * a / b. Proof. intros; nia. Qed. +Example Z_div_add_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. Proof. intros; nia. Qed. +Example Z_div_plus_full_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. Proof. intros; nia. Qed. +Example Z_div_add: forall a b c : Z, c <> 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. +Example Z_div_plus_full: forall a b c : Z, c <> 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. +Example Z_div_mul_le: forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a / b) <= c * a / b. Proof. intros; nia. Qed. +Example Z_div_mul_cancel_r: forall a b c : Z, b <> 0 -> c <> 0 -> a * c / (b * c) = a / b. Proof. intros; nia. Qed. +Example Z_div_div: forall a b c : Z, b <> 0 -> 0 < c -> a / b / c = a / (b * c). Proof. intros; nia. Qed. +Example Z_div_mul_cancel_l: forall a b c : Z, b <> 0 -> c <> 0 -> c * a / (c * b) = a / b. Proof. intros; nia. Qed. +Example Z_div_unique_neg: forall a b q r : Z, b < r <= 0 -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. +Example Zdiv_unique: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. +Example Z_div_unique_pos: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. +Example Z_div_small_iff: forall a b : Z, b <> 0 -> a / b = 0 <-> 0 <= a < b \/ b < a <= 0. Proof. intros; nia. Qed. +Example Z_div_unique: forall a b q r : Z, 0 <= r < b \/ b < r <= 0 -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. + +(** Now we do the same, but with [Z.quot] and [Z.rem] instead. *) +Lemma N2Z_inj_quot : forall n m : N, Z.of_N (n / m) = Z.of_N n ÷ Z.of_N m. Proof. intros; nia. Qed. +Lemma N2Z_inj_rem : forall n m : N, Z.of_N (n mod m) = Z.rem (Z.of_N n) (Z.of_N m). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. +Proof. intros; destruct (Z_zerop (a ÷ b)); nia. Qed. +Lemma OrdersEx_Z_as_DT_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros; destruct (Z_zerop (a ÷ b)); nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). +Proof. intros; assert (0 < b * c) by nia; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. +Proof. + intros. + destruct (Z_zerop p), (Z_zerop (p ÷ r)), (Z_zerop (p ÷ q)); subst; [ nia.. | ]. + assert (0 < q) by nia; assert (0 < r) by nia; assert (0 < p) by nia. + nia. +Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. +Proof. + intros. + destruct (Z_zerop p), (Z_zerop (p ÷ r)), (Z_zerop (p ÷ q)); [ subst; nia.. | ]. + assert (0 < p) by nia; assert (0 < r) by nia. + nia. +Qed. +Lemma OrdersEx_Z_as_DT_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. +Proof. + intros. + destruct (Z_zerop a), (Z_zerop b), (Z_zerop (a ÷ c)), (Z_zerop (b ÷ c)); [ subst; nia.. | ]. + nia. +Qed. +Lemma OrdersEx_Z_as_DT_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. +Proof. + intros. + assert (c * b <> 0) by nia. + destruct (Z_zerop a), (Z_zerop (c * a)); subst; [ nia | exfalso; nia.. | ]. +Abort. +Lemma OrdersEx_Z_as_DT_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. Abort. +Lemma OrdersEx_Z_as_DT_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; assert (b * c <> 0) by nia. Abort. +Lemma OrdersEx_Z_as_DT_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z2N_inj_quot : forall n m : Z, 0 <= n -> 0 <= m -> Z.to_N (n ÷ m) = (Z.to_N n / Z.to_N m)%N. +Proof. intros; destruct (Z_zerop n), (Z_zerop m), (Z_zerop (n ÷ m)); [ subst; try nia.. | ]. Abort. +Lemma Z2N_inj_rem : forall n m : Z, 0 <= n -> 0 <= m -> Z.to_N (Z.rem n m) = (Z.to_N n mod Z.to_N m)%N. Proof. intros. Abort. +Lemma Zabs2N_inj_quot : forall n m : Z, Z.abs_N (n ÷ m) = (Z.abs_N n / Z.abs_N m)%N. Proof. intros. Abort. +Lemma Zabs2N_inj_rem : forall n m : Z, Z.abs_N (Z.rem n m) = (Z.abs_N n mod Z.abs_N m)%N. Proof. intros. Abort. +(* Some of these don't work, and I haven't gone through and figured out which ones yet, so they're all commented out for now *) +(* +Lemma Z_add_rem : forall a b n : Z, n <> 0 -> 0 <= a * b -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_add_rem_idemp_l : forall a b n : Z, n <> 0 -> 0 <= a * b -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Z_add_rem_idemp_r : forall a b n : Z, n <> 0 -> 0 <= a * b -> Z.rem (a + Z.rem b n) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_add_rem : forall a b n : Z, n <> 0 -> 0 <= a * b -> ZBinary.Z.rem (a + b) n = ZBinary.Z.rem (ZBinary.Z.rem a n + ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_add_rem_idemp_l : forall a b n : Z, n <> 0 -> 0 <= a * b -> ZBinary.Z.rem (ZBinary.Z.rem a n + b) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_add_rem_idemp_r : forall a b n : Z, n <> 0 -> 0 <= a * b -> ZBinary.Z.rem (a + ZBinary.Z.rem b n) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_gcd_quot_gcd : forall a b g : Z, g <> 0 -> g = ZBinary.Z.gcd a b -> ZBinary.Z.gcd (a ÷ g) (b ÷ g) = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_gcd_rem : forall a b : Z, b <> 0 -> ZBinary.Z.gcd (ZBinary.Z.rem a b) b = ZBinary.Z.gcd b a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mod_mul_r : forall a b c : Z, b <> 0 -> c <> 0 -> ZBinary.Z.rem a (b * c) = ZBinary.Z.rem a b + b * ZBinary.Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_pred_quot_gt : forall a b : Z, 0 <= a -> b < 0 -> a < b * ZBinary.Z.pred (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_pred_quot_lt : forall a b : Z, a <= 0 -> 0 < b -> b * ZBinary.Z.pred (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_distr_l : forall a b c : Z, b <> 0 -> c <> 0 -> ZBinary.Z.rem (c * a) (c * b) = c * ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_distr_r : forall a b c : Z, b <> 0 -> c <> 0 -> ZBinary.Z.rem (a * c) (b * c) = ZBinary.Z.rem a b * c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem : forall a b n : Z, n <> 0 -> ZBinary.Z.rem (a * b) n = ZBinary.Z.rem (ZBinary.Z.rem a n * ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_idemp_l : forall a b n : Z, n <> 0 -> ZBinary.Z.rem (ZBinary.Z.rem a n * b) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_idemp_r : forall a b n : Z, n <> 0 -> ZBinary.Z.rem (a * ZBinary.Z.rem b n) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_succ_quot_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * ZBinary.Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_succ_quot_lt : forall a b : Z, a <= 0 -> b < 0 -> b * ZBinary.Z.succ (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_add_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a + b) n = ZBinary.Z.rem (ZBinary.Z.rem a n + ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_add_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (ZBinary.Z.rem a n + b) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_add_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a + ZBinary.Z.rem b n) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_exact : forall a b : Z, 0 <= a -> 0 < b -> a = b * (a ÷ b) <-> ZBinary.Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_0_l : forall a : Z, 0 < a -> ZBinary.Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_1_l : forall a : Z, 1 < a -> ZBinary.Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_1_r : forall a : Z, 0 <= a -> ZBinary.Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> ZBinary.Z.rem (a + b * c) c = ZBinary.Z.rem a c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_divides : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_le : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_mod : forall a n : Z, 0 <= a -> 0 < n -> ZBinary.Z.rem (ZBinary.Z.rem a n) n = ZBinary.Z.rem a n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_mul : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_mul_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> ZBinary.Z.rem a (b * c) = ZBinary.Z.rem a b + b * ZBinary.Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_same : forall a : Z, 0 < a -> ZBinary.Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_small : forall a b : Z, 0 <= a < b -> ZBinary.Z.rem a b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_small_iff : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b = a <-> a < b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_distr_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> ZBinary.Z.rem (c * a) (c * b) = c * ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_distr_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> ZBinary.Z.rem (a * c) (b * c) = ZBinary.Z.rem a b * c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a * b) n = ZBinary.Z.rem (ZBinary.Z.rem a n * ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (ZBinary.Z.rem a n * b) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a * ZBinary.Z.rem b n) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_succ_div_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * ZBinary.Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_Quot2Div_div_mod : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + ZBinary.Z.rem a b. Proof. intros; nia. Qed. +ZBinary_Z_Private_Div_Quot2Div_div_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) ZBinary.Z.quot +Lemma ZBinary_Z_Private_Div_Quot2Div_mod_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= ZBinary.Z.rem a b < b. Proof. intros; nia. Qed. +ZBinary_Z_Private_Div_Quot2Div_mod_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) ZBinary.Z.rem +Lemma ZBinary_Z_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_abs : forall a b : Z, b <> 0 -> ZBinary.Z.abs a ÷ ZBinary.Z.abs b = ZBinary.Z.abs (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_abs_l : forall a b : Z, b <> 0 -> ZBinary.Z.abs a ÷ b = ZBinary.Z.sgn a * (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_abs_r : forall a b : Z, b <> 0 -> a ÷ ZBinary.Z.abs b = ZBinary.Z.sgn b * (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_div : forall a b : Z, b <> 0 -> a ÷ b = ZBinary.Z.sgn a * ZBinary.Z.sgn b * (ZBinary.Z.abs a / ZBinary.Z.abs b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_exact : forall a b : Z, b <> 0 -> a = b * (a ÷ b) <-> ZBinary.Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_rem' : forall a b : Z, a = b * (a ÷ b) + ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_rem : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_small_iff : forall a b : Z, b <> 0 -> a ÷ b = 0 <-> ZBinary.Z.abs a < ZBinary.Z.abs b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +ZBinary_Z_quot_wd Morphisms.Proper (Morphisms.respectful ZBinary.Z.eq (Morphisms.respectful ZBinary.Z.eq ZBinary.Z.eq)) ZBinary.Z.quot +Lemma ZBinary_Z_rem_0_l : forall a : Z, a <> 0 -> ZBinary.Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_1_l : forall a : Z, 1 < a -> ZBinary.Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_1_r : forall a : Z, ZBinary.Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_abs : forall a b : Z, b <> 0 -> ZBinary.Z.rem (ZBinary.Z.abs a) (ZBinary.Z.abs b) = ZBinary.Z.abs (ZBinary.Z.rem a b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_abs_l : forall a b : Z, b <> 0 -> ZBinary.Z.rem (ZBinary.Z.abs a) b = ZBinary.Z.abs (ZBinary.Z.rem a b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_abs_r : forall a b : Z, b <> 0 -> ZBinary.Z.rem a (ZBinary.Z.abs b) = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> ZBinary.Z.rem (a + b * c) c = ZBinary.Z.rem a c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_bound_abs : forall a b : Z, b <> 0 -> ZBinary.Z.abs (ZBinary.Z.rem a b) < ZBinary.Z.abs b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= ZBinary.Z.rem a b < b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_eq : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = a - b * (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_le : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mod_eq_0 : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = 0 <-> a mod b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mod : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = ZBinary.Z.sgn a * (ZBinary.Z.abs a mod ZBinary.Z.abs b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mod_nonneg : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mul : forall a b : Z, b <> 0 -> ZBinary.Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_nonneg : forall a b : Z, b <> 0 -> 0 <= a -> 0 <= ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_nonpos : forall a b : Z, b <> 0 -> a <= 0 -> ZBinary.Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_l : forall a b : Z, b <> 0 -> ZBinary.Z.rem (- a) b = - ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_l' : forall a b : Z, ZBinary.Z.rem (- a) b = - ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_opp : forall a b : Z, b <> 0 -> ZBinary.Z.rem (- a) (- b) = - ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_r : forall a b : Z, b <> 0 -> ZBinary.Z.rem a (- b) = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_r' : forall a b : Z, ZBinary.Z.rem a (- b) = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_quot : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b ÷ b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_rem : forall a n : Z, n <> 0 -> ZBinary.Z.rem (ZBinary.Z.rem a n) n = ZBinary.Z.rem a n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_same : forall a : Z, a <> 0 -> ZBinary.Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_sign : forall a b : Z, a <> 0 -> b <> 0 -> ZBinary.Z.sgn (ZBinary.Z.rem a b) <> - ZBinary.Z.sgn a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_sign_mul : forall a b : Z, b <> 0 -> 0 <= ZBinary.Z.rem a b * a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_sign_nz : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b <> 0 -> ZBinary.Z.sgn (ZBinary.Z.rem a b) = ZBinary.Z.sgn a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_small : forall a b : Z, 0 <= a < b -> ZBinary.Z.rem a b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_small_iff : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = a <-> ZBinary.Z.abs a < ZBinary.Z.abs b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +ZBinary_Z_rem_wd Morphisms.Proper (Morphisms.respectful ZBinary.Z.eq (Morphisms.respectful ZBinary.Z.eq ZBinary.Z.eq)) ZBinary.Z.rem +Lemma Z_gcd_quot_gcd : forall a b g : Z, g <> 0 -> g = Z.gcd a b -> Z.gcd (a ÷ g) (b ÷ g) = 1. Proof. intros; nia. Qed. +Lemma Z_gcd_rem : forall a b : Z, b <> 0 -> Z.gcd (Z.rem a b) b = Z.gcd b a. Proof. intros; nia. Qed. +Lemma Z_mod_mul_r : forall a b c : Z, b <> 0 -> c <> 0 -> Z.rem a (b * c) = Z.rem a b + b * Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma Z_mul_pred_quot_gt : forall a b : Z, 0 <= a -> b < 0 -> a < b * Z.pred (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_mul_pred_quot_lt : forall a b : Z, a <= 0 -> 0 < b -> b * Z.pred (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma Z_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. Proof. intros; nia. Qed. +Lemma Z_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma Z_mul_rem_distr_l : forall a b c : Z, b <> 0 -> c <> 0 -> Z.rem (c * a) (c * b) = c * Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_mul_rem_distr_r : forall a b c : Z, b <> 0 -> c <> 0 -> Z.rem (a * c) (b * c) = Z.rem a b * c. Proof. intros; nia. Qed. +Lemma Z_mul_rem : forall a b n : Z, n <> 0 -> Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_mul_rem_idemp_l : forall a b n : Z, n <> 0 -> Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_mul_rem_idemp_r : forall a b n : Z, n <> 0 -> Z.rem (a * Z.rem b n) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_mul_succ_quot_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_mul_succ_quot_lt : forall a b : Z, a <= 0 -> b < 0 -> b * Z.succ (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_add_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_add_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_add_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a + Z.rem b n) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_exact : forall a b : Z, 0 <= a -> 0 < b -> a = b * (a ÷ b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_0_l : forall a : Z, 0 < a -> Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_1_l : forall a : Z, 1 < a -> Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_1_r : forall a : Z, 0 <= a -> Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_divides : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_le : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_mod : forall a n : Z, 0 <= a -> 0 < n -> Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_mul : forall a b : Z, 0 <= a -> 0 < b -> Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_mul_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem a (b * c) = Z.rem a b + b * Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_same : forall a : Z, 0 < a -> Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_small : forall a b : Z, 0 <= a < b -> Z.rem a b = a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_small_iff : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a <-> a < b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_distr_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem (c * a) (c * b) = c * Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_distr_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem (a * c) (b * c) = Z.rem a b * c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a * Z.rem b n) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_succ_div_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_Private_Div_Quot2Div_div_mod : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + Z.rem a b. Proof. intros; nia. Qed. +Z_Private_Div_Quot2Div_div_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) Z.quot +Lemma Z_Private_Div_Quot2Div_mod_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. +Z_Private_Div_Quot2Div_mod_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) Z.rem +Lemma Z_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_quot_0_r_ext : forall x y : Z, y = 0 -> x ÷ y = 0. Proof. intros; nia. Qed. +Lemma Z_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma Zquot2_quot : forall n : Z, Z.quot2 n = n ÷ 2. Proof. intros; nia. Qed. +Lemma Z_quot_abs : forall a b : Z, b <> 0 -> Z.abs a ÷ Z.abs b = Z.abs (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_abs_l : forall a b : Z, b <> 0 -> Z.abs a ÷ b = Z.sgn a * (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_abs_r : forall a b : Z, b <> 0 -> a ÷ Z.abs b = Z.sgn b * (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma Z_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_div : forall a b : Z, b <> 0 -> a ÷ b = Z.sgn a * Z.sgn b * (Z.abs a / Z.abs b). Proof. intros; nia. Qed. +Lemma Z_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma Z_quot_exact : forall a b : Z, b <> 0 -> a = b * (a ÷ b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma Z_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma Z_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma Z_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma Z_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma Z_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma Z_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma Z_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma Z_quot_rem' : forall a b : Z, a = b * (a ÷ b) + Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_quot_rem : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma Z_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma Z_quot_small_iff : forall a b : Z, b <> 0 -> a ÷ b = 0 <-> Z.abs a < Z.abs b. Proof. intros; nia. Qed. +Lemma Z_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Z_quot_wd Morphisms.Proper (Morphisms.respectful Z.eq (Morphisms.respectful Z.eq Z.eq)) Z.quot +Lemma Zquot_Zeven_rem : forall a : Z, Z.even a = (Z.rem a 2 =? 0). Proof. intros; nia. Qed. +Lemma Zquot_Z_mult_quot_ge : forall a b : Z, a <= 0 -> a <= b * (a ÷ b) <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Z_mult_quot_le : forall a b : Z, 0 <= a -> 0 <= b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_distr_l : forall a b c : Z, Z.rem (c * a) (c * b) = c * Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_distr_r : forall a b c : Z, Z.rem (a * c) (b * c) = Z.rem a b * c. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem : forall a b n : Z, Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_idemp_l : forall a b n : Z, Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_idemp_r : forall a b n : Z, Z.rem (b * Z.rem a n) n = Z.rem (b * a) n. Proof. intros; nia. Qed. +Lemma Zquot_Zodd_rem : forall a : Z, Z.odd a = negb (Z.rem a 2 =? 0). Proof. intros; nia. Qed. +Lemma Zquot_Zplus_rem : forall a b n : Z, 0 <= a * b -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Zquot_Zplus_rem_idemp_l : forall a b n : Z, 0 <= a * b -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Zquot_Zplus_rem_idemp_r : forall a b n : Z, 0 <= a * b -> Z.rem (b + Z.rem a n) n = Z.rem (b + a) n. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_0_l : forall a : Z, 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_0_r : forall a : Z, a ÷ 0 = 0. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_exact_full : forall a b : Z, a = b * (a ÷ b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_le_lower_bound : forall a b q : Z, 0 < b -> q * b <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_le_upper_bound : forall a b q : Z, 0 < b -> a <= q * b -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_lt : forall a b : Z, 0 < a -> 2 <= b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < q * b -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mod_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> q = a ÷ b /\ r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_monotone : forall a b c : Z, 0 <= c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mult_cancel_l : forall a b c : Z, c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mult_cancel_r : forall a b c : Z, c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mult_le : forall a b c : Z, 0 <= a -> 0 <= b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_opp_l : forall a b : Z, - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Zquot_Zquot_opp_opp : forall a b : Z, - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_opp_r : forall a b : Z, a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_plus : forall a b c : Z, 0 <= (a + b * c) * a -> c <> 0 -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_plus_l : forall a b c : Z, 0 <= (a * b + c) * c -> b <> 0 -> b <> 0 -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_pos : forall a b : Z, 0 <= a -> 0 <= b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquotrem_Zdiv_eucl_pos : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b /\ Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_sgn : forall a b : Z, 0 <= Z.sgn (a ÷ b) * Z.sgn a * Z.sgn b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_Zdiv_pos : forall a b : Z, 0 <= a -> 0 <= b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_Zquot : forall a b c : Z, a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_0_l : forall a : Z, Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_0_r : forall a : Z, Z.rem a 0 = a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_divides : forall a b : Z, Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_even : forall a : Z, Z.rem a 2 = (if Z.even a then 0 else Z.sgn a). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_le : forall a b : Z, 0 <= a -> 0 <= b -> Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_neg : forall a b : Z, a <= 0 -> b <> 0 -> - Z.abs b < Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_neg_neg : forall a b : Z, a <= 0 -> b < 0 -> b < Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_neg_pos : forall a b : Z, a <= 0 -> 0 < b -> - b < Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_pos : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= Z.rem a b < Z.abs b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_pos_neg : forall a b : Z, 0 <= a -> b < 0 -> 0 <= Z.rem a b < - b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_pos_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. +Lemma Zquot_Z_rem_mult : forall a b : Z, Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_odd : forall a : Z, Z.rem a 2 = (if Z.odd a then Z.sgn a else 0). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_opp_l : forall a b : Z, Z.rem (- a) b = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_opp_opp : forall a b : Z, Z.rem (- a) (- b) = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_opp_r : forall a b : Z, Z.rem a (- b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Z_rem_plus : forall a b c : Z, 0 <= (a + b * c) * a -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_rem : forall a n : Z, Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros; nia. Qed. +Lemma Zquot_Z_rem_same : forall a : Z, Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_sgn2 : forall a b : Z, 0 <= Z.rem a b * a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_sgn : forall a b : Z, 0 <= Z.sgn (Z.rem a b) * Z.sgn a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_Zmod_pos : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_Zmod_zero : forall a b : Z, b <> 0 -> Z.rem a b = 0 <-> a mod b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_0_l : forall a : Z, a <> 0 -> Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma Z_rem_0_r_ext : forall x y : Z, y = 0 -> Z.rem x y = x. Proof. intros; nia. Qed. +Lemma Z_rem_1_l : forall a : Z, 1 < a -> Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma Z_rem_1_r : forall a : Z, Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma Z_rem_abs : forall a b : Z, b <> 0 -> Z.rem (Z.abs a) (Z.abs b) = Z.abs (Z.rem a b). Proof. intros; nia. Qed. +Lemma Z_rem_abs_l : forall a b : Z, b <> 0 -> Z.rem (Z.abs a) b = Z.abs (Z.rem a b). Proof. intros; nia. Qed. +Lemma Z_rem_abs_r : forall a b : Z, b <> 0 -> Z.rem a (Z.abs b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros; nia. Qed. +Lemma Z_rem_bound_abs : forall a b : Z, b <> 0 -> Z.abs (Z.rem a b) < Z.abs b. Proof. intros; nia. Qed. +Lemma Z_rem_bound_neg_neg : forall x y : Z, y < 0 -> x <= 0 -> y < Z.rem x y <= 0. Proof. intros; nia. Qed. +Lemma Z_rem_bound_neg_pos : forall x y : Z, y < 0 -> 0 <= x -> 0 <= Z.rem x y < - y. Proof. intros; nia. Qed. +Lemma Z_rem_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. +Lemma Z_rem_bound_pos_neg : forall x y : Z, 0 < y -> x <= 0 -> - y < Z.rem x y <= 0. Proof. intros; nia. Qed. +Lemma Z_rem_bound_pos_pos : forall x y : Z, 0 < y -> 0 <= x -> 0 <= Z.rem x y < y. Proof. intros; nia. Qed. +Lemma Z_rem_eq : forall a b : Z, b <> 0 -> Z.rem a b = a - b * (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_rem_le : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma Z_rem_mod_eq_0 : forall a b : Z, b <> 0 -> Z.rem a b = 0 <-> a mod b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_mod : forall a b : Z, b <> 0 -> Z.rem a b = Z.sgn a * (Z.abs a mod Z.abs b). Proof. intros; nia. Qed. +Lemma Z_rem_mod_nonneg : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma Z_rem_mul : forall a b : Z, b <> 0 -> Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_nonneg : forall a b : Z, b <> 0 -> 0 <= a -> 0 <= Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_nonpos : forall a b : Z, b <> 0 -> a <= 0 -> Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Z_rem_opp_l : forall a b : Z, b <> 0 -> Z.rem (- a) b = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_l' : forall a b : Z, Z.rem (- a) b = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_opp : forall a b : Z, b <> 0 -> Z.rem (- a) (- b) = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_r : forall a b : Z, b <> 0 -> Z.rem a (- b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_r' : forall a b : Z, Z.rem a (- b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_quot : forall a b : Z, b <> 0 -> Z.rem a b ÷ b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_rem : forall a n : Z, n <> 0 -> Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros; nia. Qed. +Lemma Z_rem_same : forall a : Z, a <> 0 -> Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma Z_rem_sign : forall a b : Z, a <> 0 -> b <> 0 -> Z.sgn (Z.rem a b) <> - Z.sgn a. Proof. intros; nia. Qed. +Lemma Z_rem_sign_mul : forall a b : Z, b <> 0 -> 0 <= Z.rem a b * a. Proof. intros; nia. Qed. +Lemma Z_rem_sign_nz : forall a b : Z, b <> 0 -> Z.rem a b <> 0 -> Z.sgn (Z.rem a b) = Z.sgn a. Proof. intros; nia. Qed. +Lemma Z_rem_small : forall a b : Z, 0 <= a < b -> Z.rem a b = a. Proof. intros; nia. Qed. +Lemma Z_rem_small_iff : forall a b : Z, b <> 0 -> Z.rem a b = a <-> Z.abs a < Z.abs b. Proof. intros; nia. Qed. +Lemma Z_rem_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_wd : Morphisms.Proper (Morphisms.respectful Z.eq (Morphisms.respectful Z.eq Z.eq)) Z.rem. Proof. intros; nia. Qed. +*) diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 9086621344..3888cafed3 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -14,7 +14,7 @@ Module onlyclasses. Module RJung. Class Foo (x : nat). - Instance foo x : x = 2 -> Foo x. + Instance foo x : x = 2 -> Foo x := {}. Hint Extern 0 (_ = _) => reflexivity : typeclass_instances. Typeclasses eauto := debug. Check (_ : Foo 2). @@ -63,7 +63,7 @@ End RefineVsNoTceauto. Module Leivantex2PR339. (** Was a bug preventing to find hints associated with no pattern *) Class Bar := {}. - Instance bar1 (t:Type) : Bar. + Instance bar1 (t:Type) : Bar := {}. Hint Extern 0 => exact True : typeclass_instances. Typeclasses eauto := debug. Goal Bar. @@ -222,10 +222,10 @@ Module IterativeDeepening. Class B. Class C. - Instance: B -> A | 0. - Instance: C -> A | 0. - Instance: C -> B -> A | 0. - Instance: A -> A | 0. + Instance: B -> A | 0 := {}. + Instance: C -> A | 0 := {}. + Instance: C -> B -> A | 0 := {}. + Instance: A -> A | 0 := {}. Goal C -> A. intros. diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v index 5477c83316..62a66daf7d 100644 --- a/test-suite/success/auto.v +++ b/test-suite/success/auto.v @@ -51,7 +51,7 @@ Qed. Class B (A : Type). Class I. -Instance i : I. +Instance i : I := {}. Definition flip {A B C : Type} (f : A -> B -> C) := fun y x => f x y. Class D (f : nat -> nat -> nat). @@ -59,7 +59,7 @@ Definition ftest (x y : nat) := x + y. Definition flipD (f : nat -> nat -> nat) : D f -> D (flip f). Admitted. Module Instnopat. - Local Instance: B nat. + Local Instance: B nat := {}. (* pattern_of_constr -> B nat *) (* exact hint *) Check (_ : B nat). @@ -72,7 +72,7 @@ Module Instnopat. eauto with typeclass_instances. Qed. - Local Instance: D ftest. + Local Instance: D ftest := {}. Local Hint Resolve flipD | 0 : typeclass_instances. (* pattern: D (flip _) *) Fail Timeout 1 Check (_ : D _). (* loops applying flipD *) @@ -80,7 +80,7 @@ Module Instnopat. End Instnopat. Module InstnopatApply. - Local Instance: I -> B nat. + Local Instance: I -> B nat := {}. (* pattern_of_constr -> B nat *) (* apply hint *) Check (_ : B nat). @@ -116,7 +116,7 @@ Module InstPat. Hint Extern 0 (D (flip _)) => apply flipD : typeclass_instances. Module withftest. - Local Instance: D ftest. + Local Instance: D ftest := {}. Check (_ : D _). (* D_instance_0 : D ftest *) diff --git a/test-suite/success/bteauto.v b/test-suite/success/bteauto.v index 730b367d60..cea7d92c0b 100644 --- a/test-suite/success/bteauto.v +++ b/test-suite/success/bteauto.v @@ -149,10 +149,10 @@ Module IterativeDeepening. Class B. Class C. - Instance: B -> A | 0. - Instance: C -> A | 0. - Instance: C -> B -> A | 0. - Instance: A -> A | 0. + Instance: B -> A | 0 := {}. + Instance: C -> A | 0 := {}. + Instance: C -> B -> A | 0 := {}. + Instance: A -> A | 0 := {}. Goal C -> A. intros. diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index d1d384659b..573912c7cd 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -263,7 +263,7 @@ Abort. (* This one was working in 8.4 (because of full conv on closed arguments) *) Class E. -Instance a:E. +Instance a:E := {}. Goal forall h : E -> nat -> nat, h (id a) 0 = h a 0. intros. destruct (h _). diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v index c44747379f..5b616ccc33 100644 --- a/test-suite/success/eauto.v +++ b/test-suite/success/eauto.v @@ -9,11 +9,11 @@ (************************************************************************) Class A (A : Type). - Instance an: A nat. + Instance an: A nat := {}. Class B (A : Type) (a : A). -Instance bn0: B nat 0. -Instance bn1: B nat 1. +Instance bn0: B nat 0 := {}. +Instance bn1: B nat 1 := {}. Goal A nat. Proof. @@ -39,7 +39,7 @@ Proof. eexists. eexists. typeclasses eauto. Defined. -Instance ab: A bool. (* Backtrack on A instance *) +Instance ab: A bool := {}. (* Backtrack on A instance *) Goal exists (T : Type) (t : T), A T /\ B T t. Proof. eexists. eexists. typeclasses eauto. @@ -51,7 +51,7 @@ Hint Extern 0 { x : ?A & _ } => unshelve class_apply @existT : typeclass_instances. Existing Class sigT. Set Typeclasses Debug. -Instance can: C an 0. +Instance can: C an 0 := {}. (* Backtrack on instance implementation *) Goal exists (T : Type) (t : T), { x : A T & C x t }. Proof. @@ -59,7 +59,7 @@ Proof. Defined. Class D T `(a: A T). - Instance: D _ an. + Instance: D _ an := {}. Goal exists (T : Type), { x : A T & D T x }. Proof. eexists. typeclasses eauto. diff --git a/test-suite/success/setoid_test2.v b/test-suite/success/setoid_test2.v index 79467e549c..351481b0b6 100644 --- a/test-suite/success/setoid_test2.v +++ b/test-suite/success/setoid_test2.v @@ -120,7 +120,7 @@ Axiom eqS1: S1 -> S1 -> Prop. Axiom SetoidS1 : Setoid_Theory S1 eqS1. Add Setoid S1 eqS1 SetoidS1 as S1setoid. -Instance eqS1_default : DefaultRelation eqS1. +Instance eqS1_default : DefaultRelation eqS1 := {}. Axiom eqS1': S1 -> S1 -> Prop. Axiom SetoidS1' : Setoid_Theory S1 eqS1'. @@ -220,7 +220,7 @@ Axiom eqS1_test8: S1_test8 -> S1_test8 -> Prop. Axiom SetoidS1_test8 : Setoid_Theory S1_test8 eqS1_test8. Add Setoid S1_test8 eqS1_test8 SetoidS1_test8 as S1_test8setoid. -Instance eqS1_test8_default : DefaultRelation eqS1_test8. +Instance eqS1_test8_default : DefaultRelation eqS1_test8 := {}. Axiom f_test8 : S2 -> S1_test8. Add Morphism f_test8 with signature (eqS2 ==> eqS1_test8) as f_compat_test8. Admitted. diff --git a/test-suite/tools/update-compat/run.sh b/test-suite/tools/update-compat/run.sh index 02a2348450..61273c4f37 100755 --- a/test-suite/tools/update-compat/run.sh +++ b/test-suite/tools/update-compat/run.sh @@ -6,4 +6,4 @@ SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" # we assume that the script lives in test-suite/tools/update-compat/, # and that update-compat.py lives in dev/tools/ cd "${SCRIPT_DIR}/../../.." -dev/tools/update-compat.py --assert-unchanged --cur-version=8.9 || exit $? +dev/tools/update-compat.py --assert-unchanged --master || exit $? diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v index 106a79e8c9..59a1b8da43 100644 --- a/theories/Bool/BoolEq.v +++ b/theories/Bool/BoolEq.v @@ -67,8 +67,8 @@ Section Bool_eq_dec. Proof. intros x y; case (exists_beq_eq x y). intros b; case b; intro H. - left; apply beq_eq; assumption. - right; apply beq_false_not_eq; assumption. + - left; apply beq_eq; assumption. + - right; apply beq_false_not_eq; assumption. Defined. End Bool_eq_dec. diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index 6f99ea1da7..32ed7fe78d 100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -45,6 +45,6 @@ Qed. Lemma IfProp_sum : forall (A B:Prop) (b:bool), IfProp A B b -> {A} + {B}. destruct b; intro H. -left; inversion H; auto with bool. -right; inversion H; auto with bool. +- left; inversion H; auto with bool. +- right; inversion H; auto with bool. Qed. diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index 97510578ae..f9ca1bed29 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -164,7 +164,11 @@ Section Relations. Lemma pointwise_pointwise {B} (R : crelation B) : relation_equivalence (pointwise_relation R) (@eq A ==> R). - Proof. intros. split. simpl_crelation. firstorder. Qed. + Proof. + intros. split. + - simpl_crelation. + - firstorder. + Qed. (** Subcrelations induce a morphism on the identity. *) @@ -265,8 +269,8 @@ Section GenericInstances. Next Obligation. Proof with auto. assert(R x0 x0). - transitivity y0... symmetry... - transitivity (y x0)... + - transitivity y0... symmetry... + - transitivity (y x0)... Qed. Unset Strict Universe Declaration. @@ -339,10 +343,11 @@ Section GenericInstances. Next Obligation. Proof with auto. - split. intros ; transitivity x0... - intros. - transitivity y... - symmetry... + split. + - intros ; transitivity x0... + - intros. + transitivity y... + symmetry... Qed. (** Every Transitive crelation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *) @@ -364,9 +369,9 @@ Section GenericInstances. Next Obligation. Proof with auto. split ; intros. - transitivity x0... transitivity x... symmetry... + - transitivity x0... transitivity x... symmetry... - transitivity y... transitivity y0... symmetry... + - transitivity y... transitivity y0... symmetry... Qed. Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R). @@ -397,8 +402,8 @@ Section GenericInstances. intros A B R R' HRR' S S' HSS' f g. unfold respectful , relation_equivalence in *; simpl in *. split ; intros H x y Hxy. - apply (fst (HSS' _ _)). apply H. now apply (snd (HRR' _ _)). - apply (snd (HSS' _ _)). apply H. now apply (fst (HRR' _ _)). + - apply (fst (HSS' _ _)). apply H. now apply (snd (HRR' _ _)). + - apply (snd (HSS' _ _)). apply H. now apply (fst (HRR' _ _)). Qed. (** [R] is Reflexive, hence we can build the needed proof. *) @@ -500,8 +505,8 @@ Instance proper_proper : Proper (relation_equivalence ==> eq ==> iffT) (@Proper Proof. intros A R R' HRR' x y <-. red in HRR'. split ; red ; intros. - now apply (fst (HRR' _ _)). - now apply (snd (HRR' _ _)). + - now apply (fst (HRR' _ _)). + - now apply (snd (HRR' _ _)). Qed. Ltac proper_reflexive := @@ -636,9 +641,9 @@ intros. apply proper_sym_arrow_iffT_2; auto with *. intros x x' Hx y y' Hy Hr. transitivity x. -generalize (partial_order_equivalence x x'); compute; intuition. -transitivity y; auto. -generalize (partial_order_equivalence y y'); compute; intuition. +- generalize (partial_order_equivalence x x'); compute; intuition. +- transitivity y; auto. + generalize (partial_order_equivalence y y'); compute; intuition. Qed. (** From a [PartialOrder] to the corresponding [StrictOrder]: @@ -649,13 +654,13 @@ Lemma PartialOrder_StrictOrder `(PartialOrder A eqA R) : StrictOrder (relation_conjunction R (complement eqA)). Proof. split; compute. -intros x (_,Hx). apply Hx, Equivalence_Reflexive. -intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. -apply PreOrder_Transitive with y; assumption. -intro Hxz. -apply Hxy'. -apply partial_order_antisym; auto. -rewrite Hxz. auto. +- intros x (_,Hx). apply Hx, Equivalence_Reflexive. +- intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. + + apply PreOrder_Transitive with y; assumption. + + intro Hxz. + apply Hxy'. + apply partial_order_antisym; auto. + rewrite Hxz. auto. Qed. (** From a [StrictOrder] to the corresponding [PartialOrder]: @@ -667,12 +672,12 @@ Lemma StrictOrder_PreOrder PreOrder (relation_disjunction R eqA). Proof. split. -intros x. right. reflexivity. -intros x y z [Hxy|Hxy] [Hyz|Hyz]. -left. transitivity y; auto. -left. rewrite <- Hyz; auto. -left. rewrite Hxy; auto. -right. transitivity y; auto. +- intros x. right. reflexivity. +- intros x y z [Hxy|Hxy] [Hyz|Hyz]. + + left. transitivity y; auto. + + left. rewrite <- Hyz; auto. + + left. rewrite Hxy; auto. + + right. transitivity y; auto. Qed. Hint Extern 4 (PreOrder (relation_disjunction _ _)) => diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index bc821532fe..c014ecc7ab 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -177,6 +177,7 @@ Section Defs. a rewrite crelation. *) Global Instance equivalence_rewrite_crelation `(Equivalence eqA) : RewriteRelation eqA. + Defined. (** Leibniz equality. *) Section Leibniz. @@ -195,7 +196,10 @@ End Defs. (** Default rewrite crelations handled by [setoid_rewrite]. *) Instance: RewriteRelation impl. +Defined. + Instance: RewriteRelation iff. +Defined. (** Hints to drive the typeclass resolution avoiding loops due to the use of full unification. *) @@ -299,7 +303,8 @@ Section Binary. fun R R' => forall x y, iffT (R x y) (R' x y). Global Instance: RewriteRelation relation_equivalence. - + Defined. + Definition relation_conjunction (R : crelation A) (R' : crelation A) : crelation A := fun x y => prod (R x y) (R' x y). @@ -310,9 +315,11 @@ Section Binary. Global Instance relation_equivalence_equivalence : Equivalence relation_equivalence. - Proof. split; red; unfold relation_equivalence, iffT. firstorder. - firstorder. - intros. specialize (X x0 y0). specialize (X0 x0 y0). firstorder. + Proof. + split; red; unfold relation_equivalence, iffT. + - firstorder. + - firstorder. + - intros. specialize (X x0 y0). specialize (X0 x0 y0). firstorder. Qed. Global Instance relation_implication_preorder : PreOrder (@subrelation A). @@ -337,8 +344,11 @@ Section Binary. Qed. Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R). - Proof. unfold flip; constructor; unfold flip. intros. apply H. apply symmetry. apply X. - unfold relation_conjunction. intros [H1 H2]. apply H. constructor; assumption. Qed. + Proof. + unfold flip; constructor; unfold flip. + - intros. apply H. apply symmetry. apply X. + - unfold relation_conjunction. intros [H1 H2]. apply H. constructor; assumption. + Qed. End Binary. Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 001b7dfdfd..a4fa537128 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -260,8 +260,8 @@ Section GenericInstances. Next Obligation. Proof with auto. assert(R x0 x0). - transitivity y0... symmetry... - transitivity (y x0)... + - transitivity y0... symmetry... + - transitivity (y x0)... Qed. (** The complement of a relation conserves its proper elements. *) @@ -344,10 +344,11 @@ Section GenericInstances. Next Obligation. Proof with auto. - split. intros ; transitivity x0... - intros. - transitivity y... - symmetry... + split. + - intros ; transitivity x0... + - intros. + transitivity y... + symmetry... Qed. (** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *) @@ -369,9 +370,9 @@ Section GenericInstances. Next Obligation. Proof with auto. split ; intros. - transitivity x0... transitivity x... symmetry... + - transitivity x0... transitivity x... symmetry... - transitivity y... transitivity y0... symmetry... + - transitivity y... transitivity y0... symmetry... Qed. Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R). @@ -403,15 +404,15 @@ Section GenericInstances. unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. split ; intros. - rewrite <- H0. - apply H1. - rewrite H. - assumption. - - rewrite H0. - apply H1. - rewrite <- H. - assumption. + - rewrite <- H0. + apply H1. + rewrite H. + assumption. + + - rewrite H0. + apply H1. + rewrite <- H. + assumption. Qed. (** [R] is Reflexive, hence we can build the needed proof. *) @@ -514,10 +515,10 @@ Proof. simpl_relation. reduce in H. split ; red ; intros. - setoid_rewrite <- H. - apply H0. - setoid_rewrite H. - apply H0. + - setoid_rewrite <- H. + apply H0. + - setoid_rewrite H. + apply H0. Qed. Ltac proper_reflexive := @@ -574,8 +575,8 @@ Proof. unfold relation_equivalence in *. unfold predicate_equivalence in *. simpl in *. unfold respectful. unfold flip in *. firstorder. - apply NB. apply H. apply NA. apply H0. - apply NB. apply H. apply NA. apply H0. + - apply NB. apply H. apply NA. apply H0. + - apply NB. apply H. apply NA. apply H0. Qed. Ltac normalizes := @@ -642,9 +643,9 @@ intros. apply proper_sym_impl_iff_2; auto with *. intros x x' Hx y y' Hy Hr. transitivity x. -generalize (partial_order_equivalence x x'); compute; intuition. -transitivity y; auto. -generalize (partial_order_equivalence y y'); compute; intuition. +- generalize (partial_order_equivalence x x'); compute; intuition. +- transitivity y; auto. + generalize (partial_order_equivalence y y'); compute; intuition. Qed. (** From a [PartialOrder] to the corresponding [StrictOrder]: @@ -655,13 +656,13 @@ Lemma PartialOrder_StrictOrder `(PartialOrder A eqA R) : StrictOrder (relation_conjunction R (complement eqA)). Proof. split; compute. -intros x (_,Hx). apply Hx, Equivalence_Reflexive. -intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. -apply PreOrder_Transitive with y; assumption. -intro Hxz. -apply Hxy'. -apply partial_order_antisym; auto. -rewrite Hxz; auto. +- intros x (_,Hx). apply Hx, Equivalence_Reflexive. +- intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. + + apply PreOrder_Transitive with y; assumption. + + intro Hxz. + apply Hxy'. + apply partial_order_antisym; auto. + rewrite Hxz; auto. Qed. @@ -674,12 +675,12 @@ Lemma StrictOrder_PreOrder PreOrder (relation_disjunction R eqA). Proof. split. -intros x. right. reflexivity. -intros x y z [Hxy|Hxy] [Hyz|Hyz]. -left. transitivity y; auto. -left. rewrite <- Hyz; auto. -left. rewrite Hxy; auto. -right. transitivity y; auto. +- intros x. right. reflexivity. +- intros x y z [Hxy|Hxy] [Hyz|Hyz]. + + left. transitivity y; auto. + + left. rewrite <- Hyz; auto. + + left. rewrite Hxy; auto. + + right. transitivity y; auto. Qed. Hint Extern 4 (PreOrder (relation_disjunction _ _)) => diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index 8881fda577..efb85aa341 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -85,10 +85,12 @@ Qed. Instance Acc_rel_morphism {A:Type} : Proper (relation_equivalence ==> Logic.eq ==> iff) (@Acc A). Proof. - apply proper_sym_impl_iff_2. red; now symmetry. red; now symmetry. - intros R R' EQ a a' Ha WF. subst a'. - induction WF as [x _ WF']. constructor. - intros y Ryx. now apply WF', EQ. + apply proper_sym_impl_iff_2. + - red; now symmetry. + - red; now symmetry. + - intros R R' EQ a a' Ha WF. subst a'. + induction WF as [x _ WF']. constructor. + intros y Ryx. now apply WF', EQ. Qed. (** Equivalent relations are simultaneously well-founded or not *) diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 4b97d75cea..440b317573 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -171,6 +171,7 @@ Section Defs. a rewrite relation. *) Global Instance equivalence_rewrite_relation `(Equivalence eqA) : RewriteRelation eqA. + Defined. (** Leibniz equality. *) Section Leibniz. @@ -189,7 +190,9 @@ End Defs. (** Default rewrite relations handled by [setoid_rewrite]. *) Instance: RewriteRelation impl. +Defined. Instance: RewriteRelation iff. +Defined. (** Hints to drive the typeclass resolution avoiding loops due to the use of full unification. *) @@ -404,9 +407,10 @@ Program Instance predicate_equivalence_equivalence : Qed. Next Obligation. fold pointwise_lifting. - induction l. firstorder. - intros. simpl in *. pose (IHl (x x0) (y x0) (z x0)). - firstorder. + induction l. + - firstorder. + - intros. simpl in *. pose (IHl (x x0) (y x0) (z x0)). + firstorder. Qed. Program Instance predicate_implication_preorder : @@ -415,9 +419,10 @@ Program Instance predicate_implication_preorder : induction l ; firstorder. Qed. Next Obligation. - induction l. firstorder. - unfold predicate_implication in *. simpl in *. - intro. pose (IHl (x x0) (y x0) (z x0)). firstorder. + induction l. + - firstorder. + - unfold predicate_implication in *. simpl in *. + intro. pose (IHl (x x0) (y x0) (z x0)). firstorder. Qed. (** We define the various operations which define the algebra on binary relations, @@ -430,6 +435,7 @@ Section Binary. @predicate_equivalence (_::_::Tnil). Global Instance: RewriteRelation relation_equivalence. + Defined. Definition relation_conjunction (R : relation A) (R' : relation A) : relation A := @predicate_intersection (A::A::Tnil) R R'. diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v index 3e6358c8f3..341dacd4b2 100644 --- a/theories/Classes/RelationPairs.v +++ b/theories/Classes/RelationPairs.v @@ -62,7 +62,10 @@ Class Measure {A B} (f : A -> B). (** Standard measures. *) Instance fst_measure : @Measure (A * B) A Fst. +Defined. + Instance snd_measure : @Measure (A * B) B Snd. +Defined. (** We define a product relation over [A*B]: each components should satisfy the corresponding initial relation. *) diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v index 3fab3c5a07..94920f74ec 100644 --- a/theories/Classes/SetoidTactics.v +++ b/theories/Classes/SetoidTactics.v @@ -41,6 +41,7 @@ Definition default_relation `{DefaultRelation A R} := R. (lowest priority). *) Instance equivalence_default `(Equivalence A R) : DefaultRelation R | 4. +Defined. (** The setoid_replace tactics in Ltac, defined in terms of default relations and the setoid_rewrite tactic. *) diff --git a/theories/Compat/Coq810.v b/theories/Compat/Coq810.v new file mode 100644 index 0000000000..f10201661e --- /dev/null +++ b/theories/Compat/Coq810.v @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Compatibility file for making Coq act similar to Coq v8.10 *) diff --git a/theories/Compat/Coq89.v b/theories/Compat/Coq89.v index decb5c7519..05d63d9a47 100644 --- a/theories/Compat/Coq89.v +++ b/theories/Compat/Coq89.v @@ -11,5 +11,7 @@ (** Compatibility file for making Coq act similar to Coq v8.9 *) Local Set Warnings "-deprecated". +Require Export Coq.Compat.Coq810. + Unset Private Polymorphic Universes. Set Refine Instance Mode. diff --git a/theories/Init/Decimal.v b/theories/Init/Decimal.v index 537400fb05..3d4b3d0568 100644 --- a/theories/Init/Decimal.v +++ b/theories/Init/Decimal.v @@ -40,7 +40,7 @@ Notation zero := (D0 Nil). (** For signed integers, we use two constructors [Pos] and [Neg]. *) -Inductive int := Pos (d:uint) | Neg (d:uint). +Variant int := Pos (d:uint) | Neg (d:uint). Declare Scope dec_uint_scope. Delimit Scope dec_uint_scope with uint. @@ -50,6 +50,9 @@ Declare Scope dec_int_scope. Delimit Scope dec_int_scope with int. Bind Scope dec_int_scope with int. +Register uint as num.uint.type. +Register int as num.int.type. + (** This representation favors simplicity over canonicity. For normalizing numbers, we need to remove head zero digits, and choose our canonical representation of 0 (here [D0 Nil] diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 1db0a8e1b5..b607be4f94 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -383,6 +383,11 @@ Section Logic_lemmas. Register eq_trans as core.eq.trans. + Theorem eq_trans_r : x = y -> z = y -> x = z. + Proof. + destruct 2; trivial. + Defined. + Theorem f_equal : x = y -> f x = f y. Proof. destruct 1; trivial. @@ -695,8 +700,8 @@ Proof. - intros (x,(Hx,Huni)); split. + exists x; assumption. + intros x' x'' Hx' Hx''; transitivity x. - symmetry; auto. - auto. + * symmetry; auto. + * auto. Qed. Lemma forall_exists_unique_domain_coincide : diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 5e29f854e8..81268a87ad 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -38,7 +38,7 @@ Numeral Notation Decimal.int Decimal.int_of_int Decimal.int_of_int : dec_int_scope. (* Parsing / printing of [nat] numbers *) -Numeral Notation nat Nat.of_uint Nat.to_uint : nat_scope (abstract after 5000). +Numeral Notation nat Nat.of_uint Nat.to_uint : nat_scope (abstract after 5001). (* Printing/Parsing of bytes *) Export Byte.ByteSyntaxNotations. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index cfba2bae69..e5d63c547d 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -765,8 +765,9 @@ Section Dependent_choice_lemmas. intros H x0. set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end). exists f. - split. reflexivity. - induction n; simpl; apply proj2_sig. + split. + - reflexivity. + - induction n; simpl; apply proj2_sig. Defined. End Dependent_choice_lemmas. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 8df533e743..af4632161e 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -202,13 +202,17 @@ Set Implicit Arguments. Lemma decide_left : forall (C:Prop) (decide:{C}+{~C}), C -> forall P:{C}+{~C}->Prop, (forall H:C, P (left _ H)) -> P decide. Proof. -intros; destruct decide. apply H0. contradiction. + intros; destruct decide. + - apply H0. + - contradiction. Qed. Lemma decide_right : forall (C:Prop) (decide:{C}+{~C}), ~C -> forall P:{C}+{~C}->Prop, (forall H:~C, P (right _ H)) -> P decide. Proof. -intros; destruct decide. contradiction. apply H0. + intros; destruct decide. + - contradiction. + - apply H0. Qed. Tactic Notation "decide" constr(lemma) "with" constr(H) := diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index d93816e9ff..419a0be49c 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -118,16 +118,16 @@ intros n; unfold dmemo_get, dmemo_list. rewrite (memo_get_correct memo_val mf n); simpl. case (is_eq n n); simpl; auto; intros e. assert (e = eq_refl n). - apply eq_proofs_unicity. - induction x as [| x Hx]; destruct y as [| y]. - left; auto. - right; intros HH; discriminate HH. - right; intros HH; discriminate HH. - case (Hx y). - intros HH; left; case HH; auto. - intros HH; right; intros HH1; case HH. - injection HH1; auto. -rewrite H; auto. +- apply eq_proofs_unicity. + induction x as [| x Hx]; destruct y as [| y]. + + left; auto. + + right; intros HH; discriminate HH. + + right; intros HH; discriminate HH. + + case (Hx y). + * intros HH; left; case HH; auto. + * intros HH; right; intros HH1; case HH. + injection HH1; auto. +- rewrite H; auto. Qed. (** Finally, a version with both dependency and iterator *) @@ -145,19 +145,19 @@ Theorem dimemo_get_correct: forall n, dmemo_get n dimemo_list = f n. Proof. intros n; unfold dmemo_get, dimemo_list. rewrite (imemo_get_correct memo_val mf mg); simpl. -case (is_eq n n); simpl; auto; intros e. -assert (e = eq_refl n). - apply eq_proofs_unicity. - induction x as [| x Hx]; destruct y as [| y]. - left; auto. - right; intros HH; discriminate HH. - right; intros HH; discriminate HH. - case (Hx y). - intros HH; left; case HH; auto. - intros HH; right; intros HH1; case HH. - injection HH1; auto. -rewrite H; auto. -intros n1; unfold mf; rewrite Hg_correct; auto. +- case (is_eq n n); simpl; auto; intros e. + assert (e = eq_refl n). + + apply eq_proofs_unicity. + induction x as [| x Hx]; destruct y as [| y]. + * left; auto. + * right; intros HH; discriminate HH. + * right; intros HH; discriminate HH. + * case (Hx y). + -- intros HH; left; case HH; auto. + -- intros HH; right; intros HH1; case HH. + injection HH1; auto. + + rewrite H; auto. +- intros n1; unfold mf; rewrite Hg_correct; auto. Qed. End DependentMemoFunction. diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index a03799959e..4503b3b643 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -92,20 +92,20 @@ Qed. Theorem sym_EqSt : forall s1 s2:Stream, EqSt s1 s2 -> EqSt s2 s1. coinduction Eq_sym. -case H; intros; symmetry ; assumption. -case H; intros; assumption. ++ case H; intros; symmetry ; assumption. ++ case H; intros; assumption. Qed. Theorem trans_EqSt : forall s1 s2 s3:Stream, EqSt s1 s2 -> EqSt s2 s3 -> EqSt s1 s3. coinduction Eq_trans. -transitivity (hd s2). -case H; intros; assumption. -case H0; intros; assumption. -apply (Eq_trans (tl s1) (tl s2) (tl s3)). -case H; trivial with datatypes. -case H0; trivial with datatypes. +- transitivity (hd s2). + + case H; intros; assumption. + + case H0; intros; assumption. +- apply (Eq_trans (tl s1) (tl s2) (tl s3)). + + case H; trivial with datatypes. + + case H0; trivial with datatypes. Qed. (** The definition given is equivalent to require the elements at each @@ -114,20 +114,20 @@ Qed. Theorem eqst_ntheq : forall (n:nat) (s1 s2:Stream), EqSt s1 s2 -> Str_nth n s1 = Str_nth n s2. unfold Str_nth; simple induction n. -intros s1 s2 H; case H; trivial with datatypes. -intros m hypind. -simpl. -intros s1 s2 H. -apply hypind. -case H; trivial with datatypes. +- intros s1 s2 H; case H; trivial with datatypes. +- intros m hypind. + simpl. + intros s1 s2 H. + apply hypind. + case H; trivial with datatypes. Qed. Theorem ntheq_eqst : forall s1 s2:Stream, (forall n:nat, Str_nth n s1 = Str_nth n s2) -> EqSt s1 s2. coinduction Equiv2. -apply (H 0). -intros n; apply (H (S n)). +- apply (H 0). +- intros n; apply (H (S n)). Qed. Section Stream_Properties. @@ -150,11 +150,11 @@ CoInductive ForAll (x: Stream) : Prop := Lemma ForAll_Str_nth_tl : forall m x, ForAll x -> ForAll (Str_nth_tl m x). Proof. induction m. - tauto. -intros x [_ H]. -simpl. -apply IHm. -assumption. +- tauto. +- intros x [_ H]. + simpl. + apply IHm. + assumption. Qed. Section Co_Induction_ForAll. @@ -179,10 +179,10 @@ CoFixpoint map (s:Stream A) : Stream B := Cons (f (hd s)) (map (tl s)). Lemma Str_nth_tl_map : forall n s, Str_nth_tl n (map s)= map (Str_nth_tl n s). Proof. induction n. -reflexivity. -simpl. -intros s. -apply IHn. +- reflexivity. +- simpl. + intros s. + apply IHn. Qed. Lemma Str_nth_map : forall n s, Str_nth n (map s)= f (Str_nth n s). @@ -228,11 +228,11 @@ Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B), Str_nth_tl n (zipWith a b)= zipWith (Str_nth_tl n a) (Str_nth_tl n b). Proof. induction n. -reflexivity. -intros [x xs] [y ys]. -unfold Str_nth in *. -simpl in *. -apply IHn. +- reflexivity. +- intros [x xs] [y ys]. + unfold Str_nth in *. + simpl in *. + apply IHn. Qed. Lemma Str_nth_zipWith : forall n (a:Stream A) (b:Stream B), Str_nth n (zipWith a diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index ed4d69ab02..86894cd1f2 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -88,8 +88,8 @@ Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B). Proof. intros A B. destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf]. - exists f0 g0; trivial. - exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; +- exists f0 g0; trivial. +- exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; destruct hf; auto. Qed. @@ -130,9 +130,9 @@ Proof. unfold R at 1. unfold g. rewrite AC. -trivial. -exists (fun x:pow U => x) (fun x:pow U => x). -trivial. +- trivial. +- exists (fun x:pow U => x) (fun x:pow U => x). + trivial. Qed. @@ -141,11 +141,11 @@ Proof. generalize not_has_fixpoint. unfold Not_b. apply AC_IF. -intros is_true is_false. -elim is_true; elim is_false; trivial. +- intros is_true is_false. + elim is_true; elim is_false; trivial. -intros not_true is_true. -elim not_true; trivial. +- intros not_true is_true. + elim not_true; trivial. Qed. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 8e59941f37..b930388d13 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -372,8 +372,7 @@ Proof. rewrite (UIP_refl y). intros z. assert (UIP:forall y' y'' : x = x, y' = y''). - { intros. apply eq_trans with (eq_refl x). apply UIP_refl. - symmetry. apply UIP_refl. } + { intros. apply eq_trans_r with (eq_refl x); apply UIP_refl. } transitivity (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z) (eq_sym (UIP (eq_refl x) (eq_refl x)))). - destruct z. destruct (UIP _ _). reflexivity. diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 4e8b48af9f..3babc9437b 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -66,9 +66,9 @@ Section EqdepDec. intros. unfold nu. destruct (eq_dec y) as [Heq|Hneq]. - reflexivity. + - reflexivity. - case Hneq; trivial. + - case Hneq; trivial. Qed. @@ -118,15 +118,15 @@ Section EqdepDec. Proof. intros. cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y). - simpl. - destruct (eq_dec x) as [Heq|Hneq]. - elim Heq using K_dec_on; trivial. + - simpl. + destruct (eq_dec x) as [Heq|Hneq]. + + elim Heq using K_dec_on; trivial. - intros. - case Hneq; trivial. + + intros. + case Hneq; trivial. - case H. - reflexivity. + - case H. + reflexivity. Qed. End EqdepDec. @@ -163,8 +163,8 @@ Theorem K_dec_type : Proof. intros A eq_dec x P H p. elim p using K_dec; intros. - case (eq_dec x0 y); [left|right]; assumption. - trivial. + - case (eq_dec x0 y); [left|right]; assumption. + - trivial. Qed. Theorem K_dec_set : @@ -260,8 +260,8 @@ Module DecidableEqDep (M:DecidableType). Proof. intros. apply inj_right_pair with (A:=U). - intros x0 y0; case (eq_dec x0 y0); [left|right]; assumption. - assumption. + - intros x0 y0; case (eq_dec x0 y0); [left|right]; assumption. + - assumption. Qed. End DecidableEqDep. diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 3914f44a2c..11897b6cb1 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -135,10 +135,10 @@ Proof. exists bool. exists (fun _ => True). exists true. exists false. exists I. exists I. split. -trivial. -intro H. -assert (true=false) by (destruct H; reflexivity). -discriminate. +- trivial. +- intro H. + assert (true=false) by (destruct H; reflexivity). + discriminate. Qed. (** However, when the dependencies are equal, [JMeq (P p) x (P q) y] diff --git a/theories/Numbers/BinNums.v b/theories/Numbers/BinNums.v index ef2c688759..247827597a 100644 --- a/theories/Numbers/BinNums.v +++ b/theories/Numbers/BinNums.v @@ -29,6 +29,7 @@ Bind Scope positive_scope with positive. Arguments xO _%positive. Arguments xI _%positive. +Register positive as num.pos.type. Register xI as num.pos.xI. Register xO as num.pos.xO. Register xH as num.pos.xH. diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v index bc366c508d..9fcb029b3c 100644 --- a/theories/Numbers/NatInt/NZAdd.v +++ b/theories/Numbers/NatInt/NZAdd.v @@ -22,14 +22,16 @@ Ltac nzsimpl' := autorewrite with nz nz'. Theorem add_0_r : forall n, n + 0 == n. Proof. -nzinduct n. now nzsimpl. -intro. nzsimpl. now rewrite succ_inj_wd. + nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. Qed. Theorem add_succ_r : forall n m, n + S m == S (n + m). Proof. -intros n m; nzinduct n. now nzsimpl. -intro. nzsimpl. now rewrite succ_inj_wd. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. Qed. Theorem add_succ_comm : forall n m, S n + m == n + S m. @@ -41,8 +43,9 @@ Hint Rewrite add_0_r add_succ_r : nz. Theorem add_comm : forall n m, n + m == m + n. Proof. -intros n m; nzinduct n. now nzsimpl. -intro. nzsimpl. now rewrite succ_inj_wd. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. Qed. Theorem add_1_l : forall n, 1 + n == S n. @@ -59,14 +62,16 @@ Hint Rewrite add_1_l add_1_r : nz. Theorem add_assoc : forall n m p, n + (m + p) == (n + m) + p. Proof. -intros n m p; nzinduct n. now nzsimpl. -intro. nzsimpl. now rewrite succ_inj_wd. + intros n m p; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. Qed. Theorem add_cancel_l : forall n m p, p + n == p + m <-> n == m. Proof. -intros n m p; nzinduct p. now nzsimpl. -intro p. nzsimpl. now rewrite succ_inj_wd. +intros n m p; nzinduct p. +- now nzsimpl. +- intro p. nzsimpl. now rewrite succ_inj_wd. Qed. Theorem add_cancel_r : forall n m p, n + p == m + p <-> n == m. diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v index 99812ee3fe..5f102e853b 100644 --- a/theories/Numbers/NatInt/NZAddOrder.v +++ b/theories/Numbers/NatInt/NZAddOrder.v @@ -17,8 +17,8 @@ Include NZBaseProp NZ <+ NZMulProp NZ <+ NZOrderProp NZ. Theorem add_lt_mono_l : forall n m p, n < m <-> p + n < p + m. Proof. -intros n m p; nzinduct p. now nzsimpl. -intro p. nzsimpl. now rewrite <- succ_lt_mono. + intros n m p; nzinduct p. - now nzsimpl. + - intro p. nzsimpl. now rewrite <- succ_lt_mono. Qed. Theorem add_lt_mono_r : forall n m p, n < m <-> n + p < m + p. @@ -35,8 +35,8 @@ Qed. Theorem add_le_mono_l : forall n m p, n <= m <-> p + n <= p + m. Proof. -intros n m p; nzinduct p. now nzsimpl. -intro p. nzsimpl. now rewrite <- succ_le_mono. + intros n m p; nzinduct p. - now nzsimpl. + - intro p. nzsimpl. now rewrite <- succ_le_mono. Qed. Theorem add_le_mono_r : forall n m p, n <= m <-> n + p <= m + p. @@ -124,9 +124,9 @@ Qed. Theorem add_le_cases : forall n m p q, n + m <= p + q -> n <= p \/ m <= q. Proof. intros n m p q H. -destruct (le_gt_cases n p) as [H1 | H1]. now left. -destruct (le_gt_cases m q) as [H2 | H2]. now right. -contradict H; rewrite nle_gt. now apply add_lt_mono. +destruct (le_gt_cases n p) as [H1 | H1]. - now left. +- destruct (le_gt_cases m q) as [H2 | H2]. + now right. + + contradict H; rewrite nle_gt. now apply add_lt_mono. Qed. Theorem add_neg_cases : forall n m, n + m < 0 -> n < 0 \/ m < 0. @@ -156,10 +156,10 @@ Qed. Lemma le_exists_sub : forall n m, n<=m -> exists p, m == p+n /\ 0<=p. Proof. - intros n m H. apply le_ind with (4:=H). solve_proper. - exists 0; nzsimpl; split; order. - clear m H. intros m H (p & EQ & LE). exists (S p). - split. nzsimpl. now f_equiv. now apply le_le_succ_r. + intros n m H. apply le_ind with (4:=H). - solve_proper. + - exists 0; nzsimpl; split; order. + - clear m H. intros m H (p & EQ & LE). exists (S p). + split. + nzsimpl. now f_equiv. + now apply le_le_succ_r. Qed. (** For the moment, it doesn't seem possible to relate diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v index 595b2182ab..840a798d9b 100644 --- a/theories/Numbers/NatInt/NZBase.v +++ b/theories/Numbers/NatInt/NZBase.v @@ -49,8 +49,8 @@ bidirectional induction steps *) Theorem succ_inj_wd : forall n1 n2, S n1 == S n2 <-> n1 == n2. Proof. intros; split. -apply succ_inj. -intros. now f_equiv. +- apply succ_inj. +- intros. now f_equiv. Qed. Theorem succ_inj_wd_neg : forall n m, S n ~= S m <-> n ~= m. @@ -72,9 +72,9 @@ Theorem central_induction : forall n, A n. Proof. intros z Base Step; revert Base; pattern z; apply bi_induction. -solve_proper. -intro; now apply bi_induction. -intro; pose proof (Step n); tauto. +- solve_proper. +- intro; now apply bi_induction. +- intro; pose proof (Step n); tauto. Qed. End CentralInduction. diff --git a/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v index 550aa226ac..b94cef7cee 100644 --- a/theories/Numbers/NatInt/NZDiv.v +++ b/theories/Numbers/NatInt/NZDiv.v @@ -54,22 +54,22 @@ Proof. intros b. assert (U : forall q1 q2 r1 r2, b*q1+r1 == b*q2+r2 -> 0<=r1<b -> 0<=r2 -> q1<q2 -> False). - intros q1 q2 r1 r2 EQ LT Hr1 Hr2. - contradict EQ. - apply lt_neq. - apply lt_le_trans with (b*q1+b). - rewrite <- add_lt_mono_l. tauto. - apply le_trans with (b*q2). - rewrite mul_comm, <- mul_succ_l, mul_comm. - apply mul_le_mono_nonneg_l; intuition; try order. - rewrite le_succ_l; auto. - rewrite <- (add_0_r (b*q2)) at 1. - rewrite <- add_le_mono_l. tauto. - -intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]]. -elim (U q1 q2 r1 r2); intuition. -split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto. -elim (U q2 q1 r2 r1); intuition. +- intros q1 q2 r1 r2 EQ LT Hr1 Hr2. + contradict EQ. + apply lt_neq. + apply lt_le_trans with (b*q1+b). + + rewrite <- add_lt_mono_l. tauto. + + apply le_trans with (b*q2). + * rewrite mul_comm, <- mul_succ_l, mul_comm. + apply mul_le_mono_nonneg_l; intuition; try order. + rewrite le_succ_l; auto. + * rewrite <- (add_0_r (b*q2)) at 1. + rewrite <- add_le_mono_l. tauto. + +- intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]]. + + elim (U q1 q2 r1 r2); intuition. + + split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto. + + elim (U q2 q1 r2 r1); intuition. Qed. Theorem div_unique: @@ -78,8 +78,8 @@ Theorem div_unique: Proof. intros a b q r Ha (Hb,Hr) EQ. destruct (div_mod_unique b q (a/b) r (a mod b)); auto. -apply mod_bound_pos; order. -rewrite <- div_mod; order. +- apply mod_bound_pos; order. +- rewrite <- div_mod; order. Qed. Theorem mod_unique: @@ -88,8 +88,8 @@ Theorem mod_unique: Proof. intros a b q r Ha (Hb,Hr) EQ. destruct (div_mod_unique b q (a/b) r (a mod b)); auto. -apply mod_bound_pos; order. -rewrite <- div_mod; order. +- apply mod_bound_pos; order. +- rewrite <- div_mod; order. Qed. Theorem div_unique_exact a b q: @@ -167,16 +167,16 @@ Qed. Lemma div_mul : forall a b, 0<=a -> 0<b -> (a*b)/b == a. Proof. intros; symmetry. apply div_unique_exact; trivial. -apply mul_nonneg_nonneg; order. -apply mul_comm. +- apply mul_nonneg_nonneg; order. +- apply mul_comm. Qed. Lemma mod_mul : forall a b, 0<=a -> 0<b -> (a*b) mod b == 0. Proof. intros; symmetry. apply mod_unique with a; try split; try order. -apply mul_nonneg_nonneg; order. -nzsimpl; apply mul_comm. +- apply mul_nonneg_nonneg; order. +- nzsimpl; apply mul_comm. Qed. @@ -187,10 +187,10 @@ Qed. Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a. Proof. intros. destruct (le_gt_cases b a). -apply le_trans with b; auto. -apply lt_le_incl. destruct (mod_bound_pos a b); auto. -rewrite lt_eq_cases; right. -apply mod_small; auto. +- apply le_trans with b; auto. + apply lt_le_incl. destruct (mod_bound_pos a b); auto. +- rewrite lt_eq_cases; right. + apply mod_small; auto. Qed. @@ -219,9 +219,9 @@ Qed. Lemma div_small_iff : forall a b, 0<=a -> 0<b -> (a/b==0 <-> a<b). Proof. intros a b Ha Hb; split; intros Hab. -destruct (lt_ge_cases a b); auto. -symmetry in Hab. contradict Hab. apply lt_neq, div_str_pos; auto. -apply div_small; auto. +- destruct (lt_ge_cases a b); auto. + symmetry in Hab. contradict Hab. apply lt_neq, div_str_pos; auto. +- apply div_small; auto. Qed. Lemma mod_small_iff : forall a b, 0<=a -> 0<b -> (a mod b == a <-> a<b). @@ -236,9 +236,9 @@ Qed. Lemma div_str_pos_iff : forall a b, 0<=a -> 0<b -> (0<a/b <-> b<=a). Proof. intros a b Ha Hb; split; intros Hab. -destruct (lt_ge_cases a b) as [LT|LE]; auto. -rewrite <- div_small_iff in LT; order. -apply div_str_pos; auto. +- destruct (lt_ge_cases a b) as [LT|LE]; auto. + rewrite <- div_small_iff in LT; order. +- apply div_str_pos; auto. Qed. @@ -250,14 +250,14 @@ Proof. intros. assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1). destruct (lt_ge_cases a b). -rewrite div_small; try split; order. -rewrite (div_mod a b) at 2 by order. -apply lt_le_trans with (b*(a/b)). -rewrite <- (mul_1_l (a/b)) at 1. -rewrite <- mul_lt_mono_pos_r; auto. -apply div_str_pos; auto. -rewrite <- (add_0_r (b*(a/b))) at 1. -rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. +- rewrite div_small; try split; order. +- rewrite (div_mod a b) at 2 by order. + apply lt_le_trans with (b*(a/b)). + + rewrite <- (mul_1_l (a/b)) at 1. + rewrite <- mul_lt_mono_pos_r; auto. + apply div_str_pos; auto. + + rewrite <- (add_0_r (b*(a/b))) at 1. + rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. Qed. (** [le] is compatible with a positive division. *) @@ -276,8 +276,8 @@ apply lt_le_trans with b; auto. rewrite (div_mod b c) at 1 by order. rewrite <- add_assoc, <- add_le_mono_l. apply le_trans with (c+0). -nzsimpl; destruct (mod_bound_pos b c); order. -rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order. +- nzsimpl; destruct (mod_bound_pos b c); order. +- rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order. Qed. (** The following two properties could be used as specification of div *) @@ -334,11 +334,11 @@ Theorem div_le_lower_bound: Proof. intros a b q Ha Hb H. destruct (lt_ge_cases 0 q). -rewrite <- (div_mul q b); try order. -apply div_le_mono; auto. -rewrite mul_comm; split; auto. -apply lt_le_incl, mul_pos_pos; auto. -apply le_trans with 0; auto; apply div_pos; auto. +- rewrite <- (div_mul q b); try order. + apply div_le_mono; auto. + rewrite mul_comm; split; auto. + apply lt_le_incl, mul_pos_pos; auto. +- apply le_trans with 0; auto; apply div_pos; auto. Qed. (** A division respects opposite monotonicity for the divisor *) @@ -350,10 +350,10 @@ Proof. apply div_le_lower_bound; auto. rewrite (div_mod p r) at 2 by order. apply le_trans with (r*(p/r)). - apply mul_le_mono_nonneg_r; try order. - apply div_pos; order. - rewrite <- (add_0_r (r*(p/r))) at 1. - rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order. + - apply mul_le_mono_nonneg_r; try order. + apply div_pos; order. + - rewrite <- (add_0_r (r*(p/r))) at 1. + rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order. Qed. @@ -365,9 +365,9 @@ Proof. intros. symmetry. apply mod_unique with (a/c+b); auto. - apply mod_bound_pos; auto. - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. - now rewrite mul_comm. + - apply mod_bound_pos; auto. + - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. Qed. Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c -> @@ -396,14 +396,14 @@ Proof. intros. symmetry. apply div_unique with ((a mod b)*c). - apply mul_nonneg_nonneg; order. - split. - apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order. - rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto. - rewrite (div_mod a b) at 1 by order. - rewrite mul_add_distr_r. - rewrite add_cancel_r. - rewrite <- 2 mul_assoc. now rewrite (mul_comm c). + - apply mul_nonneg_nonneg; order. + - split. + + apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order. + + rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto. + - rewrite (div_mod a b) at 1 by order. + rewrite mul_add_distr_r. + rewrite add_cancel_r. + rewrite <- 2 mul_assoc. now rewrite (mul_comm c). Qed. Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0<b -> 0<c -> @@ -418,10 +418,10 @@ Proof. intros. rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). rewrite <- div_mod. - rewrite div_mul_cancel_l; auto. - rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. - apply div_mod; order. - rewrite <- neq_mul_0; intuition; order. + - rewrite div_mul_cancel_l; auto. + rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. + apply div_mod; order. + - rewrite <- neq_mul_0; intuition; order. Qed. Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0<b -> 0<c -> @@ -447,8 +447,8 @@ Proof. rewrite add_comm, (mul_comm n), (mul_comm _ b). rewrite mul_add_distr_l, mul_assoc. intros. rewrite mod_add; auto. - now rewrite mul_comm. - apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto. + - now rewrite mul_comm. + - apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto. Qed. Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n -> @@ -460,8 +460,8 @@ Qed. Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0<n -> (a * b) mod n == ((a mod n) * (b mod n)) mod n. Proof. - intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. reflexivity. - now destruct (mod_bound_pos b n). + intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. - reflexivity. + - now destruct (mod_bound_pos b n). Qed. Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n -> @@ -471,8 +471,8 @@ Proof. generalize (add_nonneg_nonneg _ _ Ha Hb). rewrite (div_mod a n) at 1 2 by order. rewrite <- add_assoc, add_comm, mul_comm. - intros. rewrite mod_add; trivial. reflexivity. - apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto. + intros. rewrite mod_add; trivial. - reflexivity. + - apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto. Qed. Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n -> @@ -484,8 +484,8 @@ Qed. Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0<n -> (a+b) mod n == (a mod n + b mod n) mod n. Proof. - intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. reflexivity. - now destruct (mod_bound_pos b n). + intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. - reflexivity. + - now destruct (mod_bound_pos b n). Qed. Lemma div_div : forall a b c, 0<=a -> 0<b -> 0<c -> @@ -494,18 +494,18 @@ Proof. intros a b c Ha Hb Hc. apply div_unique with (b*((a/b) mod c) + a mod b); trivial. (* begin 0<= ... <b*c *) - destruct (mod_bound_pos (a/b) c), (mod_bound_pos a b); auto using div_pos. - split. - apply add_nonneg_nonneg; auto. - apply mul_nonneg_nonneg; order. - apply lt_le_trans with (b*((a/b) mod c) + b). - rewrite <- add_lt_mono_l; auto. - rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l; auto. - (* end 0<= ... < b*c *) - rewrite (div_mod a b) at 1 by order. - rewrite add_assoc, add_cancel_r. - rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. - apply div_mod; order. + - destruct (mod_bound_pos (a/b) c), (mod_bound_pos a b); auto using div_pos. + split. + + apply add_nonneg_nonneg; auto. + apply mul_nonneg_nonneg; order. + + apply lt_le_trans with (b*((a/b) mod c) + b). + * rewrite <- add_lt_mono_l; auto. + * rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l; auto. + (* end 0<= ... < b*c *) + - rewrite (div_mod a b) at 1 by order. + rewrite add_assoc, add_cancel_r. + rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. + apply div_mod; order. Qed. Lemma mod_mul_r : forall a b c, 0<=a -> 0<b -> 0<c -> @@ -527,10 +527,10 @@ Theorem div_mul_le: Proof. intros. apply div_le_lower_bound; auto. - apply mul_nonneg_nonneg; auto. - rewrite mul_assoc, (mul_comm b c), <- mul_assoc. - apply mul_le_mono_nonneg_l; auto. - apply mul_div_le; auto. + - apply mul_nonneg_nonneg; auto. + - rewrite mul_assoc, (mul_comm b c), <- mul_assoc. + apply mul_le_mono_nonneg_l; auto. + apply mul_div_le; auto. Qed. (** mod is related to divisibility *) @@ -539,9 +539,9 @@ Lemma mod_divides : forall a b, 0<=a -> 0<b -> (a mod b == 0 <-> exists c, a == b*c). Proof. split. - intros. exists (a/b). rewrite div_exact; auto. - intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto. - rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order. + - intros. exists (a/b). rewrite div_exact; auto. + - intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto. + rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order. Qed. End NZDivProp. diff --git a/theories/Numbers/NatInt/NZGcd.v b/theories/Numbers/NatInt/NZGcd.v index c38d1aac31..1ac89ce942 100644 --- a/theories/Numbers/NatInt/NZGcd.v +++ b/theories/Numbers/NatInt/NZGcd.v @@ -72,15 +72,15 @@ Lemma eq_mul_1_nonneg : forall n m, Proof. intros n m Hn H. le_elim Hn. - destruct (lt_ge_cases m 0) as [Hm|Hm]. - generalize (mul_pos_neg n m Hn Hm). order'. - le_elim Hm. - apply le_succ_l in Hn. rewrite <- one_succ in Hn. - le_elim Hn. - generalize (lt_1_mul_pos n m Hn Hm). order. - rewrite <- Hn, mul_1_l in H. now split. - rewrite <- Hm, mul_0_r in H. order'. - rewrite <- Hn, mul_0_l in H. order'. + - destruct (lt_ge_cases m 0) as [Hm|Hm]. + + generalize (mul_pos_neg n m Hn Hm). order'. + + le_elim Hm. + * apply le_succ_l in Hn. rewrite <- one_succ in Hn. + le_elim Hn. + -- generalize (lt_1_mul_pos n m Hn Hm). order. + -- rewrite <- Hn, mul_1_l in H. now split. + * rewrite <- Hm, mul_0_r in H. order'. + - rewrite <- Hn, mul_0_l in H. order'. Qed. Lemma eq_mul_1_nonneg' : forall n m, @@ -117,13 +117,13 @@ Lemma divide_antisym_nonneg : forall n m, Proof. intros n m Hn Hm (q,Hq) (r,Hr). le_elim Hn. - destruct (lt_ge_cases q 0) as [Hq'|Hq']. - generalize (mul_neg_pos q n Hq' Hn). order. - rewrite Hq, mul_assoc in Hr. symmetry in Hr. - apply mul_id_l in Hr; [|order]. - destruct (eq_mul_1_nonneg' r q) as [_ H]; trivial. - now rewrite H, mul_1_l in Hq. - rewrite <- Hn, mul_0_r in Hq. now rewrite <- Hn. + - destruct (lt_ge_cases q 0) as [Hq'|Hq']. + + generalize (mul_neg_pos q n Hq' Hn). order. + + rewrite Hq, mul_assoc in Hr. symmetry in Hr. + apply mul_id_l in Hr; [|order]. + destruct (eq_mul_1_nonneg' r q) as [_ H]; trivial. + now rewrite H, mul_1_l in Hq. + - rewrite <- Hn, mul_0_r in Hq. now rewrite <- Hn. Qed. Lemma mul_divide_mono_l : forall n m p, (n | m) -> (p * n | p * m). @@ -140,8 +140,8 @@ Lemma mul_divide_cancel_l : forall n m p, p ~= 0 -> ((p * n | p * m) <-> (n | m)). Proof. intros n m p Hp. split. - intros (q,Hq). exists q. now rewrite mul_shuffle3, mul_cancel_l in Hq. - apply mul_divide_mono_l. + - intros (q,Hq). exists q. now rewrite mul_shuffle3, mul_cancel_l in Hq. + - apply mul_divide_mono_l. Qed. Lemma mul_divide_cancel_r : forall n m p, p ~= 0 -> @@ -179,14 +179,14 @@ Qed. Lemma divide_pos_le : forall n m, 0 < m -> (n | m) -> n <= m. Proof. intros n m Hm (q,Hq). - destruct (le_gt_cases n 0) as [Hn|Hn]. order. - rewrite Hq. - destruct (lt_ge_cases q 0) as [Hq'|Hq']. - generalize (mul_neg_pos q n Hq' Hn). order. - le_elim Hq'. - rewrite <- (mul_1_l n) at 1. apply mul_le_mono_pos_r; trivial. - now rewrite one_succ, le_succ_l. - rewrite <- Hq', mul_0_l in Hq. order. + destruct (le_gt_cases n 0) as [Hn|Hn]. - order. + - rewrite Hq. + destruct (lt_ge_cases q 0) as [Hq'|Hq']. + + generalize (mul_neg_pos q n Hq' Hn). order. + + le_elim Hq'. + * rewrite <- (mul_1_l n) at 1. apply mul_le_mono_pos_r; trivial. + now rewrite one_succ, le_succ_l. + * rewrite <- Hq', mul_0_l in Hq. order. Qed. (** Basic properties of gcd *) @@ -197,28 +197,28 @@ Lemma gcd_unique : forall n m p, gcd n m == p. Proof. intros n m p Hp Hn Hm H. - apply divide_antisym_nonneg; trivial. apply gcd_nonneg. - apply H. apply gcd_divide_l. apply gcd_divide_r. - now apply gcd_greatest. + apply divide_antisym_nonneg; trivial. - apply gcd_nonneg. + - apply H. + apply gcd_divide_l. + apply gcd_divide_r. + - now apply gcd_greatest. Qed. Instance gcd_wd : Proper (eq==>eq==>eq) gcd. Proof. intros x x' Hx y y' Hy. apply gcd_unique. - apply gcd_nonneg. - rewrite Hx. apply gcd_divide_l. - rewrite Hy. apply gcd_divide_r. - intro. rewrite Hx, Hy. apply gcd_greatest. + - apply gcd_nonneg. + - rewrite Hx. apply gcd_divide_l. + - rewrite Hy. apply gcd_divide_r. + - intro. rewrite Hx, Hy. apply gcd_greatest. Qed. Lemma gcd_divide_iff : forall n m p, (p | gcd n m) <-> (p | n) /\ (p | m). Proof. - intros. split. split. - transitivity (gcd n m); trivial using gcd_divide_l. - transitivity (gcd n m); trivial using gcd_divide_r. - intros (H,H'). now apply gcd_greatest. + intros. split. - split. + + transitivity (gcd n m); trivial using gcd_divide_l. + + transitivity (gcd n m); trivial using gcd_divide_r. + - intros (H,H'). now apply gcd_greatest. Qed. Lemma gcd_unique_alt : forall n m p, 0<=p -> @@ -227,9 +227,9 @@ Lemma gcd_unique_alt : forall n m p, 0<=p -> Proof. intros n m p Hp H. apply gcd_unique; trivial. - apply H. apply divide_refl. - apply H. apply divide_refl. - intros. apply H. now split. + - apply H. apply divide_refl. + - apply H. apply divide_refl. + - intros. apply H. now split. Qed. Lemma gcd_comm : forall n m, gcd n m == gcd m n. @@ -247,8 +247,8 @@ Qed. Lemma gcd_0_l_nonneg : forall n, 0<=n -> gcd 0 n == n. Proof. intros. apply gcd_unique; trivial. - apply divide_0_r. - apply divide_refl. + - apply divide_0_r. + - apply divide_refl. Qed. Lemma gcd_0_r_nonneg : forall n, 0<=n -> gcd n 0 == n. @@ -284,24 +284,26 @@ Qed. Lemma gcd_eq_0 : forall n m, gcd n m == 0 <-> n == 0 /\ m == 0. Proof. - intros. split. split. - now apply gcd_eq_0_l with m. - now apply gcd_eq_0_r with n. - intros (EQ,EQ'). rewrite EQ, EQ'. now apply gcd_0_r_nonneg. + intros. split. + - split. + + now apply gcd_eq_0_l with m. + + now apply gcd_eq_0_r with n. + - intros (EQ,EQ'). rewrite EQ, EQ'. now apply gcd_0_r_nonneg. Qed. Lemma gcd_mul_diag_l : forall n m, 0<=n -> gcd n (n*m) == n. Proof. intros n m Hn. apply gcd_unique_alt; trivial. - intros q. split. split; trivial. now apply divide_mul_l. - now destruct 1. + intros q. split. - split; trivial. now apply divide_mul_l. + - now destruct 1. Qed. Lemma divide_gcd_iff : forall n m, 0<=n -> ((n|m) <-> gcd n m == n). Proof. - intros n m Hn. split. intros (q,Hq). rewrite Hq. - rewrite mul_comm. now apply gcd_mul_diag_l. - intros EQ. rewrite <- EQ. apply gcd_divide_r. + intros n m Hn. split. + - intros (q,Hq). rewrite Hq. + rewrite mul_comm. now apply gcd_mul_diag_l. + - intros EQ. rewrite <- EQ. apply gcd_divide_r. Qed. End NZGcdProp. diff --git a/theories/Numbers/NatInt/NZLog.v b/theories/Numbers/NatInt/NZLog.v index 794851a9dd..1951cfc3ef 100644 --- a/theories/Numbers/NatInt/NZLog.v +++ b/theories/Numbers/NatInt/NZLog.v @@ -40,10 +40,10 @@ Module Type NZLog2Prop Lemma log2_nonneg : forall a, 0 <= log2 a. Proof. intros a. destruct (le_gt_cases a 0) as [Ha|Ha]. - now rewrite log2_nonpos. - destruct (log2_spec a Ha) as (_,LT). - apply lt_succ_r, (pow_gt_1 2). order'. - rewrite <- le_succ_l, <- one_succ in Ha. order. + - now rewrite log2_nonpos. + - destruct (log2_spec a Ha) as (_,LT). + apply lt_succ_r, (pow_gt_1 2). + order'. + + rewrite <- le_succ_l, <- one_succ in Ha. order. Qed. (** A tactic for proving positivity and non-negativity *) @@ -62,17 +62,17 @@ Lemma log2_unique : forall a b, 0<=b -> 2^b<=a<2^(S b) -> log2 a == b. Proof. intros a b Hb (LEb,LTb). assert (Ha : 0 < a). - apply lt_le_trans with (2^b); trivial. - apply pow_pos_nonneg; order'. - assert (Hc := log2_nonneg a). - destruct (log2_spec a Ha) as (LEc,LTc). - assert (log2 a <= b). - apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. - now apply le_le_succ_r. - assert (b <= log2 a). - apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. - now apply le_le_succ_r. - order. + - apply lt_le_trans with (2^b); trivial. + apply pow_pos_nonneg; order'. + - assert (Hc := log2_nonneg a). + destruct (log2_spec a Ha) as (LEc,LTc). + assert (log2 a <= b). + + apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. + now apply le_le_succ_r. + + assert (b <= log2 a). + * apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. + now apply le_le_succ_r. + * order. Qed. (** Hence log2 is a morphism. *) @@ -81,9 +81,9 @@ Instance log2_wd : Proper (eq==>eq) log2. Proof. intros x x' Hx. destruct (le_gt_cases x 0). - rewrite 2 log2_nonpos; trivial. reflexivity. now rewrite <- Hx. - apply log2_unique. apply log2_nonneg. - rewrite Hx in *. now apply log2_spec. + - rewrite 2 log2_nonpos; trivial. + reflexivity. + now rewrite <- Hx. + - apply log2_unique. + apply log2_nonneg. + + rewrite Hx in *. now apply log2_spec. Qed. (** An alternate specification *) @@ -95,24 +95,24 @@ Proof. destruct (log2_spec _ Ha) as (LE,LT). destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). exists r. - split. now rewrite add_comm. - split. trivial. - apply (add_lt_mono_r _ _ (2^log2 a)). - rewrite <- Hr. generalize LT. - rewrite pow_succ_r by order_pos. - rewrite two_succ at 1. now nzsimpl. + split. - now rewrite add_comm. + - split. + trivial. + + apply (add_lt_mono_r _ _ (2^log2 a)). + rewrite <- Hr. generalize LT. + rewrite pow_succ_r by order_pos. + rewrite two_succ at 1. now nzsimpl. Qed. Lemma log2_unique' : forall a b c, 0<=b -> 0<=c<2^b -> a == 2^b + c -> log2 a == b. Proof. intros a b c Hb (Hc,H) EQ. - apply log2_unique. trivial. - rewrite EQ. - split. - rewrite <- add_0_r at 1. now apply add_le_mono_l. - rewrite pow_succ_r by order. - rewrite two_succ at 2. nzsimpl. now apply add_lt_mono_l. + apply log2_unique. - trivial. + - rewrite EQ. + split. + + rewrite <- add_0_r at 1. now apply add_le_mono_l. + + rewrite pow_succ_r by order. + rewrite two_succ at 2. nzsimpl. now apply add_lt_mono_l. Qed. (** log2 is exact on powers of 2 *) @@ -121,7 +121,7 @@ Lemma log2_pow2 : forall a, 0<=a -> log2 (2^a) == a. Proof. intros a Ha. apply log2_unique' with 0; trivial. - split; order_pos. now nzsimpl. + - split; order_pos. - now nzsimpl. Qed. (** log2 and predecessors of powers of 2 *) @@ -131,12 +131,12 @@ Proof. intros a Ha. assert (Ha' : S (P a) == a) by (now rewrite lt_succ_pred with 0). apply log2_unique. - apply lt_succ_r; order. - rewrite <-le_succ_l, <-lt_succ_r, Ha'. - rewrite lt_succ_pred with 0. - split; try easy. apply pow_lt_mono_r_iff; try order'. - rewrite succ_lt_mono, Ha'. apply lt_succ_diag_r. - apply pow_pos_nonneg; order'. + - apply lt_succ_r; order. + - rewrite <-le_succ_l, <-lt_succ_r, Ha'. + rewrite lt_succ_pred with 0. + + split; try easy. apply pow_lt_mono_r_iff; try order'. + rewrite succ_lt_mono, Ha'. apply lt_succ_diag_r. + + apply pow_pos_nonneg; order'. Qed. (** log2 and basic constants *) @@ -167,11 +167,11 @@ Qed. Lemma log2_null : forall a, log2 a == 0 <-> a <= 1. Proof. intros a. split; intros H. - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. - generalize (log2_pos a Ha); order. - le_elim H. - apply log2_nonpos. apply lt_succ_r. now rewrite <- one_succ. - rewrite H. apply log2_1. + - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. + generalize (log2_pos a Ha); order. + - le_elim H. + + apply log2_nonpos. apply lt_succ_r. now rewrite <- one_succ. + + rewrite H. apply log2_1. Qed. (** log2 is a monotone function (but not a strict one) *) @@ -180,11 +180,11 @@ Lemma log2_le_mono : forall a b, a<=b -> log2 a <= log2 b. Proof. intros a b H. destruct (le_gt_cases a 0) as [Ha|Ha]. - rewrite log2_nonpos; order_pos. - assert (Hb : 0 < b) by order. - destruct (log2_spec a Ha) as (LEa,_). - destruct (log2_spec b Hb) as (_,LTb). - apply lt_succ_r, (pow_lt_mono_r_iff 2); order_pos. + - rewrite log2_nonpos; order_pos. + - assert (Hb : 0 < b) by order. + destruct (log2_spec a Ha) as (LEa,_). + destruct (log2_spec b Hb) as (_,LTb). + apply lt_succ_r, (pow_lt_mono_r_iff 2); order_pos. Qed. (** No reverse result for <=, consider for instance log2 3 <= log2 2 *) @@ -193,13 +193,13 @@ Lemma log2_lt_cancel : forall a b, log2 a < log2 b -> a < b. Proof. intros a b H. destruct (le_gt_cases b 0) as [Hb|Hb]. - rewrite (log2_nonpos b) in H; trivial. - generalize (log2_nonneg a); order. - destruct (le_gt_cases a 0) as [Ha|Ha]. order. - destruct (log2_spec a Ha) as (_,LTa). - destruct (log2_spec b Hb) as (LEb,_). - apply le_succ_l in H. - apply (pow_le_mono_r_iff 2) in H; order_pos. + - rewrite (log2_nonpos b) in H; trivial. + generalize (log2_nonneg a); order. + - destruct (le_gt_cases a 0) as [Ha|Ha]. + order. + + destruct (log2_spec a Ha) as (_,LTa). + destruct (log2_spec b Hb) as (LEb,_). + apply le_succ_l in H. + apply (pow_le_mono_r_iff 2) in H; order_pos. Qed. (** When left side is a power of 2, we have an equivalence for <= *) @@ -208,12 +208,12 @@ Lemma log2_le_pow2 : forall a b, 0<a -> (2^b<=a <-> b <= log2 a). Proof. intros a b Ha. split; intros H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - generalize (log2_nonneg a); order. - rewrite <- (log2_pow2 b); trivial. now apply log2_le_mono. - transitivity (2^(log2 a)). - apply pow_le_mono_r; order'. - now destruct (log2_spec a Ha). + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_nonneg a); order. + + rewrite <- (log2_pow2 b); trivial. now apply log2_le_mono. + - transitivity (2^(log2 a)). + + apply pow_le_mono_r; order'. + + now destruct (log2_spec a Ha). Qed. (** When right side is a square, we have an equivalence for < *) @@ -222,15 +222,15 @@ Lemma log2_lt_pow2 : forall a b, 0<a -> (a<2^b <-> log2 a < b). Proof. intros a b Ha. split; intros H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite pow_neg_r in H; order. - apply (pow_lt_mono_r_iff 2); try order_pos. - apply le_lt_trans with a; trivial. - now destruct (log2_spec a Ha). - destruct (lt_ge_cases b 0) as [Hb|Hb]. - generalize (log2_nonneg a); order. - apply log2_lt_cancel; try order. - now rewrite log2_pow2. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite pow_neg_r in H; order. + + apply (pow_lt_mono_r_iff 2); try order_pos. + apply le_lt_trans with a; trivial. + now destruct (log2_spec a Ha). + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_nonneg a); order. + + apply log2_lt_cancel; try order. + now rewrite log2_pow2. Qed. (** Comparing log2 and identity *) @@ -240,16 +240,16 @@ Proof. intros a Ha. apply (pow_lt_mono_r_iff 2); try order_pos. apply le_lt_trans with a. - now destruct (log2_spec a Ha). - apply pow_gt_lin_r; order'. + - now destruct (log2_spec a Ha). + - apply pow_gt_lin_r; order'. Qed. Lemma log2_le_lin : forall a, 0<=a -> log2 a <= a. Proof. intros a Ha. le_elim Ha. - now apply lt_le_incl, log2_lt_lin. - rewrite <- Ha, log2_nonpos; order. + - now apply lt_le_incl, log2_lt_lin. + - rewrite <- Ha, log2_nonpos; order. Qed. (** Log2 and multiplication. *) @@ -271,14 +271,14 @@ Lemma log2_mul_above : forall a b, 0<=a -> 0<=b -> Proof. intros a b Ha Hb. le_elim Ha. - le_elim Hb. - apply lt_succ_r. - rewrite add_1_r, <- add_succ_r, <- add_succ_l. - apply log2_lt_pow2; try order_pos. - rewrite pow_add_r by order_pos. - apply mul_lt_mono_nonneg; try order; now apply log2_spec. - rewrite <- Hb. nzsimpl. rewrite log2_nonpos; order_pos. - rewrite <- Ha. nzsimpl. rewrite log2_nonpos; order_pos. + - le_elim Hb. + + apply lt_succ_r. + rewrite add_1_r, <- add_succ_r, <- add_succ_l. + apply log2_lt_pow2; try order_pos. + rewrite pow_add_r by order_pos. + apply mul_lt_mono_nonneg; try order; now apply log2_spec. + + rewrite <- Hb. nzsimpl. rewrite log2_nonpos; order_pos. + - rewrite <- Ha. nzsimpl. rewrite log2_nonpos; order_pos. Qed. (** And we can't find better approximations in general. @@ -293,10 +293,10 @@ Lemma log2_mul_pow2 : forall a b, 0<a -> 0<=b -> log2 (a*2^b) == b + log2 a. Proof. intros a b Ha Hb. apply log2_unique; try order_pos. split. - rewrite pow_add_r, mul_comm; try order_pos. - apply mul_le_mono_nonneg_r. order_pos. now apply log2_spec. - rewrite <-add_succ_r, pow_add_r, mul_comm; try order_pos. - apply mul_lt_mono_pos_l. order_pos. now apply log2_spec. + - rewrite pow_add_r, mul_comm; try order_pos. + apply mul_le_mono_nonneg_r. + order_pos. + now apply log2_spec. + - rewrite <-add_succ_r, pow_add_r, mul_comm; try order_pos. + apply mul_lt_mono_pos_l. + order_pos. + now apply log2_spec. Qed. Lemma log2_double : forall a, 0<a -> log2 (2*a) == S (log2 a). @@ -323,13 +323,13 @@ Lemma log2_succ_le : forall a, log2 (S a) <= S (log2 a). Proof. intros a. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. - apply (pow_le_mono_r_iff 2); try order_pos. - transitivity (S a). - apply log2_spec. - apply lt_succ_r; order. - now apply le_succ_l, log2_spec. - rewrite <- EQ, <- one_succ, log2_1; order_pos. - rewrite 2 log2_nonpos. order_pos. order'. now rewrite le_succ_l. + - apply (pow_le_mono_r_iff 2); try order_pos. + transitivity (S a). + + apply log2_spec. + apply lt_succ_r; order. + + now apply le_succ_l, log2_spec. + - rewrite <- EQ, <- one_succ, log2_1; order_pos. + - rewrite 2 log2_nonpos. + order_pos. + order'. + now rewrite le_succ_l. Qed. Lemma log2_succ_or : forall a, @@ -337,8 +337,8 @@ Lemma log2_succ_or : forall a, Proof. intros. destruct (le_gt_cases (log2 (S a)) (log2 a)) as [H|H]. - right. generalize (log2_le_mono _ _ (le_succ_diag_r a)); order. - left. apply le_succ_l in H. generalize (log2_succ_le a); order. + - right. generalize (log2_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (log2_succ_le a); order. Qed. Lemma log2_eq_succ_is_pow2 : forall a, @@ -346,27 +346,27 @@ Lemma log2_eq_succ_is_pow2 : forall a, Proof. intros a H. destruct (le_gt_cases a 0) as [Ha|Ha]. - rewrite 2 (proj2 (log2_null _)) in H. generalize (lt_succ_diag_r 0); order. - order'. apply le_succ_l. order'. - assert (Ha' : 0 < S a) by (apply lt_succ_r; order). - exists (log2 (S a)). - generalize (proj1 (log2_spec (S a) Ha')) (proj2 (log2_spec a Ha)). - rewrite <- le_succ_l, <- H. order. + - rewrite 2 (proj2 (log2_null _)) in H. + generalize (lt_succ_diag_r 0); order. + + order'. + apply le_succ_l. order'. + - assert (Ha' : 0 < S a) by (apply lt_succ_r; order). + exists (log2 (S a)). + generalize (proj1 (log2_spec (S a) Ha')) (proj2 (log2_spec a Ha)). + rewrite <- le_succ_l, <- H. order. Qed. Lemma log2_eq_succ_iff_pow2 : forall a, 0<a -> (log2 (S a) == S (log2 a) <-> exists b, S a == 2^b). Proof. intros a Ha. - split. apply log2_eq_succ_is_pow2. - intros (b,Hb). - assert (Hb' : 0 < b). - apply (pow_gt_1 2); try order'; now rewrite <- Hb, one_succ, <- succ_lt_mono. - rewrite Hb, log2_pow2; try order'. - setoid_replace a with (P (2^b)). rewrite log2_pred_pow2; trivial. - symmetry; now apply lt_succ_pred with 0. - apply succ_inj. rewrite Hb. symmetry. apply lt_succ_pred with 0. - rewrite <- Hb, lt_succ_r; order. + split. - apply log2_eq_succ_is_pow2. + - intros (b,Hb). + assert (Hb' : 0 < b). + + apply (pow_gt_1 2); try order'; now rewrite <- Hb, one_succ, <- succ_lt_mono. + + rewrite Hb, log2_pow2; try order'. + setoid_replace a with (P (2^b)). * rewrite log2_pred_pow2; trivial. + symmetry; now apply lt_succ_pred with 0. + * apply succ_inj. rewrite Hb. symmetry. apply lt_succ_pred with 0. + rewrite <- Hb, lt_succ_r; order. Qed. Lemma log2_succ_double : forall a, 0<a -> log2 (2*a+1) == S (log2 a). @@ -376,18 +376,18 @@ Proof. destruct (log2_succ_or (2*a)) as [H|H]; [exfalso|now rewrite H, log2_double]. apply log2_eq_succ_is_pow2 in H. destruct H as (b,H). destruct (lt_trichotomy b 0) as [LT|[EQ|LT]]. - rewrite pow_neg_r in H; trivial. - apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. - rewrite <- one_succ in Ha. order'. - rewrite EQ, pow_0_r in H. - apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. - rewrite <- one_succ in Ha. order'. - assert (EQ:=lt_succ_pred 0 b LT). - rewrite <- EQ, pow_succ_r in H; [|now rewrite <- lt_succ_r, EQ]. - destruct (lt_ge_cases a (2^(P b))) as [LT'|LE']. - generalize (mul_2_mono_l _ _ LT'). rewrite add_1_l. order. - rewrite (mul_le_mono_pos_l _ _ 2) in LE'; try order'. - rewrite <- H in LE'. apply le_succ_l in LE'. order. + - rewrite pow_neg_r in H; trivial. + apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. + rewrite <- one_succ in Ha. order'. + - rewrite EQ, pow_0_r in H. + apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. + rewrite <- one_succ in Ha. order'. + - assert (EQ:=lt_succ_pred 0 b LT). + rewrite <- EQ, pow_succ_r in H; [|now rewrite <- lt_succ_r, EQ]. + destruct (lt_ge_cases a (2^(P b))) as [LT'|LE']. + + generalize (mul_2_mono_l _ _ LT'). rewrite add_1_l. order. + + rewrite (mul_le_mono_pos_l _ _ 2) in LE'; try order'. + rewrite <- H in LE'. apply le_succ_l in LE'. order. Qed. (** Log2 and addition *) @@ -396,25 +396,28 @@ Lemma log2_add_le : forall a b, a~=1 -> b~=1 -> log2 (a+b) <= log2 a + log2 b. Proof. intros a b Ha Hb. destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. - rewrite one_succ, lt_succ_r in Ha'. - rewrite (log2_nonpos a); trivial. nzsimpl. apply log2_le_mono. - rewrite <- (add_0_l b) at 2. now apply add_le_mono. - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. - rewrite one_succ, lt_succ_r in Hb'. - rewrite (log2_nonpos b); trivial. nzsimpl. apply log2_le_mono. - rewrite <- (add_0_r a) at 2. now apply add_le_mono. - clear Ha Hb. - apply lt_succ_r. - apply log2_lt_pow2; try order_pos. - rewrite pow_succ_r by order_pos. - rewrite two_succ, one_succ at 1. nzsimpl. - apply add_lt_mono. - apply lt_le_trans with (2^(S (log2 a))). apply log2_spec; order'. - apply pow_le_mono_r. order'. rewrite <- add_1_r. apply add_le_mono_l. - rewrite one_succ; now apply le_succ_l, log2_pos. - apply lt_le_trans with (2^(S (log2 b))). apply log2_spec; order'. - apply pow_le_mono_r. order'. rewrite <- add_1_l. apply add_le_mono_r. - rewrite one_succ; now apply le_succ_l, log2_pos. + - rewrite one_succ, lt_succ_r in Ha'. + rewrite (log2_nonpos a); trivial. nzsimpl. apply log2_le_mono. + rewrite <- (add_0_l b) at 2. now apply add_le_mono. + - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. + + rewrite one_succ, lt_succ_r in Hb'. + rewrite (log2_nonpos b); trivial. nzsimpl. apply log2_le_mono. + rewrite <- (add_0_r a) at 2. now apply add_le_mono. + + clear Ha Hb. + apply lt_succ_r. + apply log2_lt_pow2; try order_pos. + rewrite pow_succ_r by order_pos. + rewrite two_succ, one_succ at 1. nzsimpl. + apply add_lt_mono. + * apply lt_le_trans with (2^(S (log2 a))). -- apply log2_spec; order'. + -- apply pow_le_mono_r. ++ order'. + ++ rewrite <- add_1_r. apply add_le_mono_l. + rewrite one_succ; now apply le_succ_l, log2_pos. + * apply lt_le_trans with (2^(S (log2 b))). + -- apply log2_spec; order'. + -- apply pow_le_mono_r. ++ order'. + ++ rewrite <- add_1_l. apply add_le_mono_r. + rewrite one_succ; now apply le_succ_l, log2_pos. Qed. (** The sum of two log2 is less than twice the log2 of the sum. @@ -430,17 +433,17 @@ Lemma add_log2_lt : forall a b, 0<a -> 0<b -> Proof. intros a b Ha Hb. nzsimpl'. assert (H : log2 a <= log2 (a+b)). - apply log2_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. - assert (H' : log2 b <= log2 (a+b)). - apply log2_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - le_elim H. - apply lt_le_trans with (log2 (a+b) + log2 b). - now apply add_lt_mono_r. now apply add_le_mono_l. - rewrite <- H at 1. apply add_lt_mono_l. - le_elim H'; trivial. - symmetry in H. apply log2_same in H; try order_pos. - symmetry in H'. apply log2_same in H'; try order_pos. - revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. + - apply log2_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. + - assert (H' : log2 b <= log2 (a+b)). + + apply log2_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + le_elim H. + * apply lt_le_trans with (log2 (a+b) + log2 b). + -- now apply add_lt_mono_r. -- now apply add_le_mono_l. + * rewrite <- H at 1. apply add_lt_mono_l. + le_elim H'; trivial. + symmetry in H. apply log2_same in H; try order_pos. + symmetry in H'. apply log2_same in H'; try order_pos. + revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. Qed. End NZLog2Prop. @@ -493,9 +496,9 @@ Qed. Instance log2_up_wd : Proper (eq==>eq) log2_up. Proof. assert (Proper (eq==>eq==>Logic.eq) compare). - repeat red; intros; do 2 case compare_spec; trivial; order. - intros a a' Ha. unfold log2_up. rewrite Ha at 1. - case compare; now rewrite ?Ha. + - repeat red; intros; do 2 case compare_spec; trivial; order. + - intros a a' Ha. unfold log2_up. rewrite Ha at 1. + case compare; now rewrite ?Ha. Qed. (** [log2_up] is always non-negative *) @@ -512,22 +515,23 @@ Lemma log2_up_unique : forall a b, 0<b -> 2^(P b)<a<=2^b -> log2_up a == b. Proof. intros a b Hb (LEb,LTb). assert (Ha : 1 < a). - apply le_lt_trans with (2^(P b)); trivial. - rewrite one_succ. apply le_succ_l. - apply pow_pos_nonneg. order'. apply lt_succ_r. - now rewrite (lt_succ_pred 0 b Hb). - assert (Hc := log2_up_nonneg a). - destruct (log2_up_spec a Ha) as (LTc,LEc). - assert (b <= log2_up a). - apply lt_succ_r. rewrite <- (lt_succ_pred 0 b Hb). - rewrite <- succ_lt_mono. - apply (pow_lt_mono_r_iff 2); try order'. - assert (Hc' : 0 < log2_up a) by order. - assert (log2_up a <= b). - apply lt_succ_r. rewrite <- (lt_succ_pred 0 _ Hc'). - rewrite <- succ_lt_mono. - apply (pow_lt_mono_r_iff 2); try order'. - order. + - apply le_lt_trans with (2^(P b)); trivial. + rewrite one_succ. apply le_succ_l. + apply pow_pos_nonneg. + order'. + + apply lt_succ_r. + now rewrite (lt_succ_pred 0 b Hb). + - assert (Hc := log2_up_nonneg a). + destruct (log2_up_spec a Ha) as (LTc,LEc). + assert (b <= log2_up a). + + apply lt_succ_r. rewrite <- (lt_succ_pred 0 b Hb). + rewrite <- succ_lt_mono. + apply (pow_lt_mono_r_iff 2); try order'. + + assert (Hc' : 0 < log2_up a) by order. + assert (log2_up a <= b). + * apply lt_succ_r. rewrite <- (lt_succ_pred 0 _ Hc'). + rewrite <- succ_lt_mono. + apply (pow_lt_mono_r_iff 2); try order'. + * order. Qed. (** [log2_up] is exact on powers of 2 *) @@ -536,12 +540,12 @@ Lemma log2_up_pow2 : forall a, 0<=a -> log2_up (2^a) == a. Proof. intros a Ha. le_elim Ha. - apply log2_up_unique; trivial. - split; try order. - apply pow_lt_mono_r; try order'. - rewrite <- (lt_succ_pred 0 a Ha) at 2. - now apply lt_succ_r. - now rewrite <- Ha, pow_0_r, log2_up_eqn0. + - apply log2_up_unique; trivial. + split; try order. + apply pow_lt_mono_r; try order'. + rewrite <- (lt_succ_pred 0 a Ha) at 2. + now apply lt_succ_r. + - now rewrite <- Ha, pow_0_r, log2_up_eqn0. Qed. (** [log2_up] and successors of powers of 2 *) @@ -570,9 +574,9 @@ Qed. Lemma le_log2_log2_up : forall a, log2 a <= log2_up a. Proof. intros a. unfold log2_up. case compare_spec; intros H. - rewrite <- H, log2_1. order. - rewrite <- (lt_succ_pred 1 a H) at 1. apply log2_succ_le. - rewrite log2_nonpos. order. now rewrite <-lt_succ_r, <-one_succ. + - rewrite <- H, log2_1. order. + - rewrite <- (lt_succ_pred 1 a H) at 1. apply log2_succ_le. + - rewrite log2_nonpos. + order. + now rewrite <-lt_succ_r, <-one_succ. Qed. Lemma le_log2_up_succ_log2 : forall a, log2_up a <= S (log2 a). @@ -586,23 +590,24 @@ Lemma log2_log2_up_spec : forall a, 0<a -> 2^log2 a <= a <= 2^log2_up a. Proof. intros a H. split. - now apply log2_spec. - rewrite <-le_succ_l, <-one_succ in H. le_elim H. - now apply log2_up_spec. - now rewrite <-H, log2_up_1, pow_0_r. + - now apply log2_spec. + - rewrite <-le_succ_l, <-one_succ in H. le_elim H. + + now apply log2_up_spec. + + now rewrite <-H, log2_up_1, pow_0_r. Qed. Lemma log2_log2_up_exact : forall a, 0<a -> (log2 a == log2_up a <-> exists b, a == 2^b). Proof. intros a Ha. - split. intros. exists (log2 a). - generalize (log2_log2_up_spec a Ha). rewrite <-H. - destruct 1; order. - intros (b,Hb). rewrite Hb. - destruct (le_gt_cases 0 b). - now rewrite log2_pow2, log2_up_pow2. - rewrite pow_neg_r; trivial. now rewrite log2_nonpos, log2_up_nonpos. + split. + - intros. exists (log2 a). + generalize (log2_log2_up_spec a Ha). rewrite <-H. + destruct 1; order. + - intros (b,Hb). rewrite Hb. + destruct (le_gt_cases 0 b). + + now rewrite log2_pow2, log2_up_pow2. + + rewrite pow_neg_r; trivial. now rewrite log2_nonpos, log2_up_nonpos. Qed. (** [log2_up] n is strictly positive for 1<n *) @@ -617,9 +622,9 @@ Qed. Lemma log2_up_null : forall a, log2_up a == 0 <-> a <= 1. Proof. intros a. split; intros H. - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. - generalize (log2_up_pos a Ha); order. - now apply log2_up_eqn0. + - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. + generalize (log2_up_pos a Ha); order. + - now apply log2_up_eqn0. Qed. (** [log2_up] is a monotone function (but not a strict one) *) @@ -628,10 +633,10 @@ Lemma log2_up_le_mono : forall a b, a<=b -> log2_up a <= log2_up b. Proof. intros a b H. destruct (le_gt_cases a 1) as [Ha|Ha]. - rewrite log2_up_eqn0; trivial. apply log2_up_nonneg. - rewrite 2 log2_up_eqn; try order. - rewrite <- succ_le_mono. apply log2_le_mono, succ_le_mono. - rewrite 2 lt_succ_pred with 1; order. + - rewrite log2_up_eqn0; trivial. apply log2_up_nonneg. + - rewrite 2 log2_up_eqn; try order. + rewrite <- succ_le_mono. apply log2_le_mono, succ_le_mono. + rewrite 2 lt_succ_pred with 1; order. Qed. (** No reverse result for <=, consider for instance log2_up 4 <= log2_up 3 *) @@ -640,12 +645,12 @@ Lemma log2_up_lt_cancel : forall a b, log2_up a < log2_up b -> a < b. Proof. intros a b H. destruct (le_gt_cases b 1) as [Hb|Hb]. - rewrite (log2_up_eqn0 b) in H; trivial. - generalize (log2_up_nonneg a); order. - destruct (le_gt_cases a 1) as [Ha|Ha]. order. - rewrite 2 log2_up_eqn in H; try order. - rewrite <- succ_lt_mono in H. apply log2_lt_cancel, succ_lt_mono in H. - rewrite 2 lt_succ_pred with 1 in H; order. + - rewrite (log2_up_eqn0 b) in H; trivial. + generalize (log2_up_nonneg a); order. + - destruct (le_gt_cases a 1) as [Ha|Ha]. + order. + + rewrite 2 log2_up_eqn in H; try order. + rewrite <- succ_lt_mono in H. apply log2_lt_cancel, succ_lt_mono in H. + rewrite 2 lt_succ_pred with 1 in H; order. Qed. (** When left side is a power of 2, we have an equivalence for < *) @@ -654,16 +659,16 @@ Lemma log2_up_lt_pow2 : forall a b, 0<a -> (2^b<a <-> b < log2_up a). Proof. intros a b Ha. split; intros H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - generalize (log2_up_nonneg a); order. - apply (pow_lt_mono_r_iff 2). order'. apply log2_up_nonneg. - apply lt_le_trans with a; trivial. - apply (log2_up_spec a). - apply le_lt_trans with (2^b); trivial. - rewrite one_succ, le_succ_l. apply pow_pos_nonneg; order'. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - now rewrite pow_neg_r. - rewrite <- (log2_up_pow2 b) in H; trivial. now apply log2_up_lt_cancel. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_up_nonneg a); order. + + apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. + * apply lt_le_trans with a; trivial. + apply (log2_up_spec a). + apply le_lt_trans with (2^b); trivial. + rewrite one_succ, le_succ_l. apply pow_pos_nonneg; order'. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + now rewrite pow_neg_r. + + rewrite <- (log2_up_pow2 b) in H; trivial. now apply log2_up_lt_cancel. Qed. (** When right side is a square, we have an equivalence for <= *) @@ -672,12 +677,12 @@ Lemma log2_up_le_pow2 : forall a b, 0<a -> (a<=2^b <-> log2_up a <= b). Proof. intros a b Ha. split; intros H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite pow_neg_r in H; order. - rewrite <- (log2_up_pow2 b); trivial. now apply log2_up_le_mono. - transitivity (2^(log2_up a)). - now apply log2_log2_up_spec. - apply pow_le_mono_r; order'. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite pow_neg_r in H; order. + + rewrite <- (log2_up_pow2 b); trivial. now apply log2_up_le_mono. + - transitivity (2^(log2_up a)). + + now apply log2_log2_up_spec. + + apply pow_le_mono_r; order'. Qed. (** Comparing [log2_up] and identity *) @@ -688,15 +693,15 @@ Proof. assert (H : S (P a) == a) by (now apply lt_succ_pred with 0). rewrite <- H at 2. apply lt_succ_r. apply log2_up_le_pow2; trivial. rewrite <- H at 1. apply le_succ_l. - apply pow_gt_lin_r. order'. apply lt_succ_r; order. + apply pow_gt_lin_r. - order'. - apply lt_succ_r; order. Qed. Lemma log2_up_le_lin : forall a, 0<=a -> log2_up a <= a. Proof. intros a Ha. le_elim Ha. - now apply lt_le_incl, log2_up_lt_lin. - rewrite <- Ha, log2_up_nonpos; order. + - now apply lt_le_incl, log2_up_lt_lin. + - rewrite <- Ha, log2_up_nonpos; order. Qed. (** [log2_up] and multiplication. *) @@ -711,12 +716,12 @@ Proof. assert (Ha':=log2_up_nonneg a). assert (Hb':=log2_up_nonneg b). le_elim Ha. - le_elim Hb. - apply log2_up_le_pow2; try order_pos. - rewrite pow_add_r; trivial. - apply mul_le_mono_nonneg; try apply log2_log2_up_spec; order'. - rewrite <- Hb. nzsimpl. rewrite log2_up_nonpos; order_pos. - rewrite <- Ha. nzsimpl. rewrite log2_up_nonpos; order_pos. + - le_elim Hb. + + apply log2_up_le_pow2; try order_pos. + rewrite pow_add_r; trivial. + apply mul_le_mono_nonneg; try apply log2_log2_up_spec; order'. + + rewrite <- Hb. nzsimpl. rewrite log2_up_nonpos; order_pos. + - rewrite <- Ha. nzsimpl. rewrite log2_up_nonpos; order_pos. Qed. Lemma log2_up_mul_below : forall a b, 0<a -> 0<b -> @@ -724,21 +729,21 @@ Lemma log2_up_mul_below : forall a b, 0<a -> 0<b -> Proof. intros a b Ha Hb. rewrite <-le_succ_l, <-one_succ in Ha. le_elim Ha. - rewrite <-le_succ_l, <-one_succ in Hb. le_elim Hb. - assert (Ha' : 0 < log2_up a) by (apply log2_up_pos; trivial). - assert (Hb' : 0 < log2_up b) by (apply log2_up_pos; trivial). - rewrite <- (lt_succ_pred 0 (log2_up a)); trivial. - rewrite <- (lt_succ_pred 0 (log2_up b)); trivial. - nzsimpl. rewrite <- succ_le_mono, le_succ_l. - apply (pow_lt_mono_r_iff 2). order'. apply log2_up_nonneg. - rewrite pow_add_r; try (apply lt_succ_r; rewrite (lt_succ_pred 0); trivial). - apply lt_le_trans with (a*b). - apply mul_lt_mono_nonneg; try order_pos; try now apply log2_up_spec. - apply log2_up_spec. - setoid_replace 1 with (1*1) by now nzsimpl. - apply mul_lt_mono_nonneg; order'. - rewrite <- Hb, log2_up_1; nzsimpl. apply le_succ_diag_r. - rewrite <- Ha, log2_up_1; nzsimpl. apply le_succ_diag_r. + - rewrite <-le_succ_l, <-one_succ in Hb. le_elim Hb. + + assert (Ha' : 0 < log2_up a) by (apply log2_up_pos; trivial). + assert (Hb' : 0 < log2_up b) by (apply log2_up_pos; trivial). + rewrite <- (lt_succ_pred 0 (log2_up a)); trivial. + rewrite <- (lt_succ_pred 0 (log2_up b)); trivial. + nzsimpl. rewrite <- succ_le_mono, le_succ_l. + apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. + * rewrite pow_add_r; try (apply lt_succ_r; rewrite (lt_succ_pred 0); trivial). + apply lt_le_trans with (a*b). + -- apply mul_lt_mono_nonneg; try order_pos; try now apply log2_up_spec. + -- apply log2_up_spec. + setoid_replace 1 with (1*1) by now nzsimpl. + apply mul_lt_mono_nonneg; order'. + + rewrite <- Hb, log2_up_1; nzsimpl. apply le_succ_diag_r. + - rewrite <- Ha, log2_up_1; nzsimpl. apply le_succ_diag_r. Qed. (** And we can't find better approximations in general. @@ -754,16 +759,16 @@ Lemma log2_up_mul_pow2 : forall a b, 0<a -> 0<=b -> Proof. intros a b Ha Hb. rewrite <- le_succ_l, <- one_succ in Ha; le_elim Ha. - apply log2_up_unique. apply add_nonneg_pos; trivial. now apply log2_up_pos. - split. - assert (EQ := lt_succ_pred 0 _ (log2_up_pos _ Ha)). - rewrite <- EQ. nzsimpl. rewrite pow_add_r, mul_comm; trivial. - apply mul_lt_mono_pos_r. order_pos. now apply log2_up_spec. - rewrite <- lt_succ_r, EQ. now apply log2_up_pos. - rewrite pow_add_r, mul_comm; trivial. - apply mul_le_mono_nonneg_l. order_pos. now apply log2_up_spec. - apply log2_up_nonneg. - now rewrite <- Ha, mul_1_l, log2_up_1, add_0_r, log2_up_pow2. + - apply log2_up_unique. + apply add_nonneg_pos; trivial. now apply log2_up_pos. + + split. + * assert (EQ := lt_succ_pred 0 _ (log2_up_pos _ Ha)). + rewrite <- EQ. nzsimpl. rewrite pow_add_r, mul_comm; trivial. + -- apply mul_lt_mono_pos_r. ++ order_pos. ++ now apply log2_up_spec. + -- rewrite <- lt_succ_r, EQ. now apply log2_up_pos. + * rewrite pow_add_r, mul_comm; trivial. + -- apply mul_le_mono_nonneg_l. ++ order_pos. ++ now apply log2_up_spec. + -- apply log2_up_nonneg. + - now rewrite <- Ha, mul_1_l, log2_up_1, add_0_r, log2_up_pow2. Qed. Lemma log2_up_double : forall a, 0<a -> log2_up (2*a) == S (log2_up a). @@ -790,12 +795,12 @@ Lemma log2_up_succ_le : forall a, log2_up (S a) <= S (log2_up a). Proof. intros a. destruct (lt_trichotomy 1 a) as [LT|[EQ|LT]]. - rewrite 2 log2_up_eqn; trivial. - rewrite pred_succ, <- succ_le_mono. rewrite <-(lt_succ_pred 1 a LT) at 1. - apply log2_succ_le. - apply lt_succ_r; order. - rewrite <- EQ, <- two_succ, log2_up_1, log2_up_2. now nzsimpl'. - rewrite 2 log2_up_eqn0. order_pos. order'. now rewrite le_succ_l. + - rewrite 2 log2_up_eqn; trivial. + + rewrite pred_succ, <- succ_le_mono. rewrite <-(lt_succ_pred 1 a LT) at 1. + apply log2_succ_le. + + apply lt_succ_r; order. + - rewrite <- EQ, <- two_succ, log2_up_1, log2_up_2. now nzsimpl'. + - rewrite 2 log2_up_eqn0. + order_pos. + order'. + now rewrite le_succ_l. Qed. Lemma log2_up_succ_or : forall a, @@ -803,8 +808,8 @@ Lemma log2_up_succ_or : forall a, Proof. intros. destruct (le_gt_cases (log2_up (S a)) (log2_up a)). - right. generalize (log2_up_le_mono _ _ (le_succ_diag_r a)); order. - left. apply le_succ_l in H. generalize (log2_up_succ_le a); order. + - right. generalize (log2_up_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (log2_up_succ_le a); order. Qed. Lemma log2_up_eq_succ_is_pow2 : forall a, @@ -812,33 +817,33 @@ Lemma log2_up_eq_succ_is_pow2 : forall a, Proof. intros a H. destruct (le_gt_cases a 0) as [Ha|Ha]. - rewrite 2 (proj2 (log2_up_null _)) in H. generalize (lt_succ_diag_r 0); order. - order'. apply le_succ_l. order'. - assert (Ha' : 1 < S a) by (now rewrite one_succ, <- succ_lt_mono). - exists (log2_up a). - generalize (proj1 (log2_up_spec (S a) Ha')) (proj2 (log2_log2_up_spec a Ha)). - rewrite H, pred_succ, lt_succ_r. order. + - rewrite 2 (proj2 (log2_up_null _)) in H. + generalize (lt_succ_diag_r 0); order. + + order'. + apply le_succ_l. order'. + - assert (Ha' : 1 < S a) by (now rewrite one_succ, <- succ_lt_mono). + exists (log2_up a). + generalize (proj1 (log2_up_spec (S a) Ha')) (proj2 (log2_log2_up_spec a Ha)). + rewrite H, pred_succ, lt_succ_r. order. Qed. Lemma log2_up_eq_succ_iff_pow2 : forall a, 0<a -> (log2_up (S a) == S (log2_up a) <-> exists b, a == 2^b). Proof. intros a Ha. - split. apply log2_up_eq_succ_is_pow2. - intros (b,Hb). - destruct (lt_ge_cases b 0) as [Hb'|Hb']. - rewrite pow_neg_r in Hb; order. - rewrite Hb, log2_up_pow2; try order'. - now rewrite log2_up_succ_pow2. + split. - apply log2_up_eq_succ_is_pow2. + - intros (b,Hb). + destruct (lt_ge_cases b 0) as [Hb'|Hb']. + + rewrite pow_neg_r in Hb; order. + + rewrite Hb, log2_up_pow2; try order'. + now rewrite log2_up_succ_pow2. Qed. Lemma log2_up_succ_double : forall a, 0<a -> log2_up (2*a+1) == 2 + log2 a. Proof. intros a Ha. - rewrite log2_up_eqn. rewrite add_1_r, pred_succ, log2_double; now nzsimpl'. - apply le_lt_trans with (0+1). now nzsimpl'. - apply add_lt_mono_r. order_pos. + rewrite log2_up_eqn. - rewrite add_1_r, pred_succ, log2_double; now nzsimpl'. + - apply le_lt_trans with (0+1). + now nzsimpl'. + + apply add_lt_mono_r. order_pos. Qed. (** [log2_up] and addition *) @@ -848,17 +853,17 @@ Lemma log2_up_add_le : forall a b, a~=1 -> b~=1 -> Proof. intros a b Ha Hb. destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. - rewrite (log2_up_eqn0 a) by order. nzsimpl. apply log2_up_le_mono. - rewrite one_succ, lt_succ_r in Ha'. - rewrite <- (add_0_l b) at 2. now apply add_le_mono. - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. - rewrite (log2_up_eqn0 b) by order. nzsimpl. apply log2_up_le_mono. - rewrite one_succ, lt_succ_r in Hb'. - rewrite <- (add_0_r a) at 2. now apply add_le_mono. - clear Ha Hb. - transitivity (log2_up (a*b)). - now apply log2_up_le_mono, add_le_mul. - apply log2_up_mul_above; order'. + - rewrite (log2_up_eqn0 a) by order. nzsimpl. apply log2_up_le_mono. + rewrite one_succ, lt_succ_r in Ha'. + rewrite <- (add_0_l b) at 2. now apply add_le_mono. + - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. + + rewrite (log2_up_eqn0 b) by order. nzsimpl. apply log2_up_le_mono. + rewrite one_succ, lt_succ_r in Hb'. + rewrite <- (add_0_r a) at 2. now apply add_le_mono. + + clear Ha Hb. + transitivity (log2_up (a*b)). + * now apply log2_up_le_mono, add_le_mul. + * apply log2_up_mul_above; order'. Qed. (** The sum of two [log2_up] is less than twice the [log2_up] of the sum. @@ -874,17 +879,17 @@ Lemma add_log2_up_lt : forall a b, 0<a -> 0<b -> Proof. intros a b Ha Hb. nzsimpl'. assert (H : log2_up a <= log2_up (a+b)). - apply log2_up_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. - assert (H' : log2_up b <= log2_up (a+b)). - apply log2_up_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - le_elim H. - apply lt_le_trans with (log2_up (a+b) + log2_up b). - now apply add_lt_mono_r. now apply add_le_mono_l. - rewrite <- H at 1. apply add_lt_mono_l. - le_elim H'. trivial. - symmetry in H. apply log2_up_same in H; try order_pos. - symmetry in H'. apply log2_up_same in H'; try order_pos. - revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. + - apply log2_up_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. + - assert (H' : log2_up b <= log2_up (a+b)). + + apply log2_up_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + le_elim H. + * apply lt_le_trans with (log2_up (a+b) + log2_up b). + -- now apply add_lt_mono_r. -- now apply add_le_mono_l. + * rewrite <- H at 1. apply add_lt_mono_l. + le_elim H'. -- trivial. + -- symmetry in H. apply log2_up_same in H; try order_pos. + symmetry in H'. apply log2_up_same in H'; try order_pos. + revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. Qed. End NZLog2UpProp. diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v index 44cbc51712..1492188452 100644 --- a/theories/Numbers/NatInt/NZMul.v +++ b/theories/Numbers/NatInt/NZMul.v @@ -22,24 +22,27 @@ Qed. Theorem mul_succ_r : forall n m, n * (S m) == n * m + n. Proof. -intros n m; nzinduct n. now nzsimpl. -intro n. nzsimpl. rewrite succ_inj_wd, <- add_assoc, (add_comm m n), add_assoc. -now rewrite add_cancel_r. + intros n m; nzinduct n. + - now nzsimpl. + - intro n. nzsimpl. rewrite succ_inj_wd, <- add_assoc, (add_comm m n), add_assoc. + now rewrite add_cancel_r. Qed. Hint Rewrite mul_0_r mul_succ_r : nz. Theorem mul_comm : forall n m, n * m == m * n. Proof. -intros n m; nzinduct n. now nzsimpl. -intro. nzsimpl. now rewrite add_cancel_r. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite add_cancel_r. Qed. Theorem mul_add_distr_r : forall n m p, (n + m) * p == n * p + m * p. Proof. -intros n m p; nzinduct n. now nzsimpl. -intro n. nzsimpl. rewrite <- add_assoc, (add_comm p (m*p)), add_assoc. -now rewrite add_cancel_r. + intros n m p; nzinduct n. + - now nzsimpl. + - intro n. nzsimpl. rewrite <- add_assoc, (add_comm p (m*p)), add_assoc. + now rewrite add_cancel_r. Qed. Theorem mul_add_distr_l : forall n m p, n * (m + p) == n * m + n * p. @@ -51,9 +54,9 @@ Qed. Theorem mul_assoc : forall n m p, n * (m * p) == (n * m) * p. Proof. -intros n m p; nzinduct n. now nzsimpl. -intro n. nzsimpl. rewrite mul_add_distr_r. -now rewrite add_cancel_r. + intros n m p; nzinduct n. - now nzsimpl. + - intro n. nzsimpl. rewrite mul_add_distr_r. + now rewrite add_cancel_r. Qed. Theorem mul_1_l : forall n, 1 * n == n. diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v index 292f0837c0..dc4167e96f 100644 --- a/theories/Numbers/NatInt/NZMulOrder.v +++ b/theories/Numbers/NatInt/NZMulOrder.v @@ -26,16 +26,16 @@ Qed. Theorem mul_lt_mono_pos_l : forall p n m, 0 < p -> (n < m <-> p * n < p * m). Proof. -intros p n m Hp. revert n m. apply lt_ind with (4:=Hp). solve_proper. -intros. now nzsimpl. -clear p Hp. intros p Hp IH n m. nzsimpl. -assert (LR : forall n m, n < m -> p * n + n < p * m + m) - by (intros n1 m1 H; apply add_lt_mono; trivial; now rewrite <- IH). -split; intros H. -now apply LR. -destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. -rewrite EQ in H. order. -apply LR in GT. order. + intros p n m Hp. revert n m. apply lt_ind with (4:=Hp). - solve_proper. + - intros. now nzsimpl. + - clear p Hp. intros p Hp IH n m. nzsimpl. + assert (LR : forall n m, n < m -> p * n + n < p * m + m) + by (intros n1 m1 H; apply add_lt_mono; trivial; now rewrite <- IH). + split; intros H. + + now apply LR. + + destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. + * rewrite EQ in H. order. + * apply LR in GT. order. Qed. Theorem mul_lt_mono_pos_r : forall p n m, 0 < p -> (n < m <-> n * p < m * p). @@ -47,19 +47,20 @@ Qed. Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n). Proof. nzord_induct p. -order. -intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order. -intros p Hp IH n m _. apply le_succ_l in Hp. -le_elim Hp. -assert (LR : forall n m, n < m -> p * m < p * n). - intros n1 m1 H. apply (le_lt_add_lt n1 m1). - now apply lt_le_incl. rewrite <- 2 mul_succ_l. now rewrite <- IH. -split; intros H. -now apply LR. -destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. -rewrite EQ in H. order. -apply LR in GT. order. -rewrite (mul_lt_pred p (S p)), Hp; now nzsimpl. +- order. +- intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order. +- intros p Hp IH n m _. apply le_succ_l in Hp. + le_elim Hp. + + assert (LR : forall n m, n < m -> p * m < p * n). + * intros n1 m1 H. apply (le_lt_add_lt n1 m1). + -- now apply lt_le_incl. + -- rewrite <- 2 mul_succ_l. now rewrite <- IH. + * split; intros H. + -- now apply LR. + -- destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. + ++ rewrite EQ in H. order. + ++ apply LR in GT. order. + + rewrite (mul_lt_pred p (S p)), Hp; now nzsimpl. Qed. Theorem mul_lt_mono_neg_r : forall p n m, p < 0 -> (n < m <-> m * p < n * p). @@ -71,17 +72,17 @@ Qed. Theorem mul_le_mono_nonneg_l : forall n m p, 0 <= p -> n <= m -> p * n <= p * m. Proof. intros n m p H1 H2. le_elim H1. -le_elim H2. apply lt_le_incl. now apply mul_lt_mono_pos_l. -apply eq_le_incl; now rewrite H2. -apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l. +- le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_pos_l. + + apply eq_le_incl; now rewrite H2. +- apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l. Qed. Theorem mul_le_mono_nonpos_l : forall n m p, p <= 0 -> n <= m -> p * m <= p * n. Proof. intros n m p H1 H2. le_elim H1. -le_elim H2. apply lt_le_incl. now apply mul_lt_mono_neg_l. -apply eq_le_incl; now rewrite H2. -apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l. +- le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_neg_l. + + apply eq_le_incl; now rewrite H2. +- apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l. Qed. Theorem mul_le_mono_nonneg_r : forall n m p, 0 <= p -> n <= m -> n * p <= m * p. @@ -101,10 +102,10 @@ Proof. intros n m p Hp; split; intro H; [|now f_equiv]. apply lt_gt_cases in Hp; destruct Hp as [Hp|Hp]; destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. -apply (mul_lt_mono_neg_l p) in LT; order. -apply (mul_lt_mono_neg_l p) in GT; order. -apply (mul_lt_mono_pos_l p) in LT; order. -apply (mul_lt_mono_pos_l p) in GT; order. +- apply (mul_lt_mono_neg_l p) in LT; order. +- apply (mul_lt_mono_neg_l p) in GT; order. +- apply (mul_lt_mono_pos_l p) in LT; order. +- apply (mul_lt_mono_pos_l p) in GT; order. Qed. Theorem mul_cancel_r : forall n m p, p ~= 0 -> (n * p == m * p <-> n == m). @@ -155,8 +156,8 @@ Theorem mul_lt_mono_nonneg : Proof. intros n m p q H1 H2 H3 H4. apply le_lt_trans with (m * p). -apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. -apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n]. +- apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. +- apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n]. Qed. (* There are still many variants of the theorem above. One can assume 0 < n @@ -167,10 +168,10 @@ Theorem mul_le_mono_nonneg : Proof. intros n m p q H1 H2 H3 H4. le_elim H2; le_elim H4. -apply lt_le_incl; now apply mul_lt_mono_nonneg. -rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. -rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl]. -rewrite H2; rewrite H4; now apply eq_le_incl. +- apply lt_le_incl; now apply mul_lt_mono_nonneg. +- rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. +- rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl]. +- rewrite H2; rewrite H4; now apply eq_le_incl. Qed. Theorem mul_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n * m. @@ -225,29 +226,29 @@ Qed. Theorem lt_1_mul_pos : forall n m, 1 < n -> 0 < m -> 1 < n * m. Proof. intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1. -rewrite mul_1_l in H1. now apply lt_1_l with m. -assumption. +- rewrite mul_1_l in H1. now apply lt_1_l with m. +- assumption. Qed. Theorem eq_mul_0 : forall n m, n * m == 0 <-> n == 0 \/ m == 0. Proof. intros n m; split. -intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; -destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; -try (now right); try (now left). -exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |]. -exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |]. -exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |]. -exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |]. -intros [H | H]. now rewrite H, mul_0_l. now rewrite H, mul_0_r. +- intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; + destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; + try (now right); try (now left). + + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |]. + + exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |]. + + exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |]. + + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |]. +- intros [H | H]. + now rewrite H, mul_0_l. + now rewrite H, mul_0_r. Qed. Theorem neq_mul_0 : forall n m, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. Proof. intros n m; split; intro H. -intro H1; apply eq_mul_0 in H1. tauto. -split; intro H1; rewrite H1 in H; -(rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H. +- intro H1; apply eq_mul_0 in H1. tauto. +- split; intro H1; rewrite H1 in H; + (rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H. Qed. Theorem eq_square_0 : forall n, n * n == 0 <-> n == 0. @@ -258,13 +259,13 @@ Qed. Theorem eq_mul_0_l : forall n m, n * m == 0 -> m ~= 0 -> n == 0. Proof. intros n m H1 H2. apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. -assumption. false_hyp H1 H2. +- assumption. - false_hyp H1 H2. Qed. Theorem eq_mul_0_r : forall n m, n * m == 0 -> n ~= 0 -> m == 0. Proof. intros n m H1 H2; apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. -false_hyp H1 H2. assumption. +- false_hyp H1 H2. - assumption. Qed. (** Some alternative names: *) @@ -276,16 +277,16 @@ Definition mul_eq_0_r := eq_mul_0_r. Theorem lt_0_mul n m : 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0). Proof. split; [intro H | intros [[H1 H2] | [H1 H2]]]. -destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; -[| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; -(destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; -[| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); -try (left; now split); try (right; now split). -assert (H3 : n * m < 0) by now apply mul_neg_pos. -exfalso; now apply (lt_asymm (n * m) 0). -assert (H3 : n * m < 0) by now apply mul_pos_neg. -exfalso; now apply (lt_asymm (n * m) 0). -now apply mul_pos_pos. now apply mul_neg_neg. +- destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; + [| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; + (destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; + [| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); + try (left; now split); try (right; now split). + + assert (H3 : n * m < 0) by now apply mul_neg_pos. + exfalso; now apply (lt_asymm (n * m) 0). + + assert (H3 : n * m < 0) by now apply mul_pos_neg. + exfalso; now apply (lt_asymm (n * m) 0). +- now apply mul_pos_pos. - now apply mul_neg_neg. Qed. Theorem square_lt_mono_nonneg : forall n m, 0 <= n -> n < m -> n * n < m * m. @@ -304,38 +305,38 @@ other variable *) Theorem square_lt_simpl_nonneg : forall n m, 0 <= m -> n * n < m * m -> n < m. Proof. intros n m H1 H2. destruct (lt_ge_cases n 0). -now apply lt_le_trans with 0. -destruct (lt_ge_cases n m) as [LT|LE]; trivial. -apply square_le_mono_nonneg in LE; order. +- now apply lt_le_trans with 0. +- destruct (lt_ge_cases n m) as [LT|LE]; trivial. + apply square_le_mono_nonneg in LE; order. Qed. Theorem square_le_simpl_nonneg : forall n m, 0 <= m -> n * n <= m * m -> n <= m. Proof. intros n m H1 H2. destruct (lt_ge_cases n 0). -apply lt_le_incl; now apply lt_le_trans with 0. -destruct (le_gt_cases n m) as [LE|LT]; trivial. -apply square_lt_mono_nonneg in LT; order. +- apply lt_le_incl; now apply lt_le_trans with 0. +- destruct (le_gt_cases n m) as [LE|LT]; trivial. + apply square_lt_mono_nonneg in LT; order. Qed. Theorem mul_2_mono_l : forall n m, n < m -> 1 + 2 * n < 2 * m. Proof. intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m two). -rewrite two_succ. nzsimpl. now rewrite le_succ_l. -order'. +- rewrite two_succ. nzsimpl. now rewrite le_succ_l. +- order'. Qed. Lemma add_le_mul : forall a b, 1<a -> 1<b -> a+b <= a*b. Proof. assert (AUX : forall a b, 0<a -> 0<b -> (S a)+(S b) <= (S a)*(S b)). - intros a b Ha Hb. - nzsimpl. rewrite <- succ_le_mono. apply le_succ_l. - rewrite <- add_assoc, <- (add_0_l (a+b)), (add_comm b). - apply add_lt_mono_r. - now apply mul_pos_pos. - intros a b Ha Hb. - assert (Ha' := lt_succ_pred 1 a Ha). - assert (Hb' := lt_succ_pred 1 b Hb). - rewrite <- Ha', <- Hb'. apply AUX; rewrite succ_lt_mono, <- one_succ; order. + - intros a b Ha Hb. + nzsimpl. rewrite <- succ_le_mono. apply le_succ_l. + rewrite <- add_assoc, <- (add_0_l (a+b)), (add_comm b). + apply add_lt_mono_r. + now apply mul_pos_pos. + - intros a b Ha Hb. + assert (Ha' := lt_succ_pred 1 a Ha). + assert (Hb' := lt_succ_pred 1 b Hb). + rewrite <- Ha', <- Hb'. apply AUX; rewrite succ_lt_mono, <- one_succ; order. Qed. (** A few results about squares *) @@ -343,25 +344,25 @@ Qed. Lemma square_nonneg : forall a, 0 <= a * a. Proof. intros. rewrite <- (mul_0_r a). destruct (le_gt_cases a 0). - now apply mul_le_mono_nonpos_l. - apply mul_le_mono_nonneg_l; order. + - now apply mul_le_mono_nonpos_l. + - apply mul_le_mono_nonneg_l; order. Qed. Lemma crossmul_le_addsquare : forall a b, 0<=a -> 0<=b -> b*a+a*b <= a*a+b*b. Proof. assert (AUX : forall a b, 0<=a<=b -> b*a+a*b <= a*a+b*b). - intros a b (Ha,H). - destruct (le_exists_sub _ _ H) as (d & EQ & Hd). - rewrite EQ. - rewrite 2 mul_add_distr_r. - rewrite !add_assoc. apply add_le_mono_r. - rewrite add_comm. apply add_le_mono_l. - apply mul_le_mono_nonneg_l; trivial. order. - intros a b Ha Hb. - destruct (le_gt_cases a b). - apply AUX; split; order. - rewrite (add_comm (b*a)), (add_comm (a*a)). - apply AUX; split; order. + - intros a b (Ha,H). + destruct (le_exists_sub _ _ H) as (d & EQ & Hd). + rewrite EQ. + rewrite 2 mul_add_distr_r. + rewrite !add_assoc. apply add_le_mono_r. + rewrite add_comm. apply add_le_mono_l. + apply mul_le_mono_nonneg_l; trivial. order. + - intros a b Ha Hb. + destruct (le_gt_cases a b). + + apply AUX; split; order. + + rewrite (add_comm (b*a)), (add_comm (a*a)). + apply AUX; split; order. Qed. Lemma add_square_le : forall a b, 0<=a -> 0<=b -> diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index 60e1123b35..89bc5cfecb 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -60,19 +60,19 @@ Qed. Theorem nle_succ_diag_l : forall n, ~ S n <= n. Proof. intros n H; le_elim H. -false_hyp H nlt_succ_diag_l. false_hyp H neq_succ_diag_l. ++ false_hyp H nlt_succ_diag_l. + false_hyp H neq_succ_diag_l. Qed. Theorem le_succ_l : forall n m, S n <= m <-> n < m. Proof. intro n; nzinduct m n. -split; intro H. false_hyp H nle_succ_diag_l. false_hyp H lt_irrefl. -intro m. -rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd. -rewrite or_cancel_r. -reflexivity. -intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l. -intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl. +- split; intro H. + false_hyp H nle_succ_diag_l. + false_hyp H lt_irrefl. +- intro m. + rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd. + rewrite or_cancel_r. + + reflexivity. + + intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l. + + intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl. Qed. (** Trichotomy *) @@ -80,8 +80,8 @@ Qed. Theorem le_gt_cases : forall n m, n <= m \/ n > m. Proof. intros n m; nzinduct n m. -left; apply le_refl. -intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition. +- left; apply le_refl. +- intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition. Qed. Theorem lt_trichotomy : forall n m, n < m \/ n == m \/ m < n. @@ -96,14 +96,14 @@ Notation lt_eq_gt_cases := lt_trichotomy (only parsing). Theorem lt_asymm : forall n m, n < m -> ~ m < n. Proof. intros n m; nzinduct n m. -intros H; false_hyp H lt_irrefl. -intro n; split; intros H H1 H2. -apply lt_succ_r in H2. le_elim H2. -apply H; auto. apply le_succ_l. now apply lt_le_incl. -rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l. -apply le_succ_l in H1. le_elim H1. -apply H; auto. rewrite lt_succ_r. now apply lt_le_incl. -rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l. +- intros H; false_hyp H lt_irrefl. +- intro n; split; intros H H1 H2. + + apply lt_succ_r in H2. le_elim H2. + * apply H; auto. apply le_succ_l. now apply lt_le_incl. + * rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l. + + apply le_succ_l in H1. le_elim H1. + * apply H; auto. rewrite lt_succ_r. now apply lt_le_incl. + * rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l. Qed. Notation lt_ngt := lt_asymm (only parsing). @@ -111,13 +111,15 @@ Notation lt_ngt := lt_asymm (only parsing). Theorem lt_trans : forall n m p, n < m -> m < p -> n < p. Proof. intros n m p; nzinduct p m. -intros _ H; false_hyp H lt_irrefl. -intro p. rewrite 2 lt_succ_r. -split; intros H H1 H2. -apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1]. -assert (n <= p) as H3 by (auto using lt_le_incl). -le_elim H3. assumption. rewrite <- H3 in H2. -elim (lt_asymm n m); auto. +- intros _ H; false_hyp H lt_irrefl. +- intro p. rewrite 2 lt_succ_r. + split; intros H H1 H2. + + apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1]. + + assert (n <= p) as H3 by (auto using lt_le_incl). + le_elim H3. + * assumption. + * rewrite <- H3 in H2. + elim (lt_asymm n m); auto. Qed. Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p. @@ -130,16 +132,16 @@ Qed. (** Some type classes about order *) Instance lt_strorder : StrictOrder lt. -Proof. split. exact lt_irrefl. exact lt_trans. Qed. +Proof. split. - exact lt_irrefl. - exact lt_trans. Qed. Instance le_preorder : PreOrder le. -Proof. split. exact le_refl. exact le_trans. Qed. +Proof. split. - exact le_refl. - exact le_trans. Qed. Instance le_partialorder : PartialOrder _ le. Proof. intros x y. compute. split. -intro EQ; now rewrite EQ. -rewrite 2 lt_eq_cases. intuition. elim (lt_irrefl x). now transitivity y. +- intro EQ; now rewrite EQ. +- rewrite 2 lt_eq_cases. intuition. elim (lt_irrefl x). now transitivity y. Qed. (** We know enough now to benefit from the generic [order] tactic. *) @@ -246,7 +248,7 @@ Qed. Theorem lt_0_2 : 0 < 2. Proof. -transitivity 1. apply lt_0_1. apply lt_1_2. + transitivity 1. - apply lt_0_1. - apply lt_1_2. Qed. Theorem le_0_2 : 0 <= 2. @@ -300,9 +302,9 @@ Qed. Theorem eq_dne : forall n m, ~ ~ n == m <-> n == m. Proof. intros n m; split; intro H. -destruct (eq_decidable n m) as [H1 | H1]. -assumption. false_hyp H1 H. -intro H1; now apply H1. +- destruct (eq_decidable n m) as [H1 | H1]. + + assumption. + false_hyp H1 H. +- intro H1; now apply H1. Qed. Theorem le_ngt : forall n m, n <= m <-> ~ n > m. @@ -321,8 +323,8 @@ Qed. Theorem lt_dne : forall n m, ~ ~ n < m <-> n < m. Proof. intros n m; split; intro H. -destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. -intro H1; false_hyp H H1. +- destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. +- intro H1; false_hyp H H1. Qed. Theorem nle_gt : forall n m, ~ n <= m <-> n > m. @@ -341,8 +343,8 @@ Qed. Theorem le_dne : forall n m, ~ ~ n <= m <-> n <= m. Proof. intros n m; split; intro H. -destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. -intro H1; false_hyp H H1. +- destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. +- intro H1; false_hyp H H1. Qed. Theorem nlt_succ_r : forall n m, ~ m < S n <-> n < m. @@ -361,18 +363,18 @@ Lemma lt_exists_pred_strong : forall z n m, z < m -> m <= n -> exists k, m == S k /\ z <= k. Proof. intro z; nzinduct n z. -order. -intro n; split; intros IH m H1 H2. -apply le_succ_r in H2. destruct H2 as [H2 | H2]. -now apply IH. exists n. now split; [| rewrite <- lt_succ_r; rewrite <- H2]. -apply IH. assumption. now apply le_le_succ_r. +- order. +- intro n; split; intros IH m H1 H2. + + apply le_succ_r in H2. destruct H2 as [H2 | H2]. + * now apply IH. * exists n. now split; [| rewrite <- lt_succ_r; rewrite <- H2]. + + apply IH. * assumption. * now apply le_le_succ_r. Qed. Theorem lt_exists_pred : forall z n, z < n -> exists k, n == S k /\ z <= k. Proof. intros z n H; apply lt_exists_pred_strong with (z := z) (n := n). -assumption. apply le_refl. +- assumption. - apply le_refl. Qed. Lemma lt_succ_pred : forall z n, z < n -> S (P n) == n. @@ -404,18 +406,19 @@ Let right_step'' := forall n, A' n <-> A' (S n). Lemma rs_rs' : A z -> right_step -> right_step'. Proof. intros Az RS n H1 H2. -le_elim H1. apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]]. -rewrite H3. apply RS; trivial. apply H2; trivial. -rewrite H3; apply lt_succ_diag_r. -rewrite <- H1; apply Az. +le_elim H1. +- apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]]. + rewrite H3. apply RS; trivial. apply H2; trivial. + rewrite H3; apply lt_succ_diag_r. +- rewrite <- H1; apply Az. Qed. Lemma rs'_rs'' : right_step' -> right_step''. Proof. intros RS' n; split; intros H1 m H2 H3. -apply lt_succ_r in H3; le_elim H3; -[now apply H1 | rewrite H3 in *; now apply RS']. -apply H1; [assumption | now apply lt_lt_succ_r]. +- apply lt_succ_r in H3; le_elim H3; + [now apply H1 | rewrite H3 in *; now apply RS']. +- apply H1; [assumption | now apply lt_lt_succ_r]. Qed. Lemma rbase : A' z. @@ -444,10 +447,12 @@ Theorem right_induction' : Proof. intros L R n. destruct (lt_trichotomy n z) as [H | [H | H]]. -apply L; now apply lt_le_incl. -apply L; now apply eq_le_incl. -apply right_induction. apply L; now apply eq_le_incl. assumption. -now apply lt_le_incl. +- apply L; now apply lt_le_incl. +- apply L; now apply eq_le_incl. +- apply right_induction. + + apply L; now apply eq_le_incl. + + assumption. + + now apply lt_le_incl. Qed. Theorem strong_right_induction' : @@ -455,9 +460,10 @@ Theorem strong_right_induction' : Proof. intros L R n. destruct (lt_trichotomy n z) as [H | [H | H]]. -apply L; now apply lt_le_incl. -apply L; now apply eq_le_incl. -apply strong_right_induction. assumption. now apply lt_le_incl. +- apply L; now apply lt_le_incl. +- apply L; now apply eq_le_incl. +- apply strong_right_induction. + + assumption. + now apply lt_le_incl. Qed. End RightInduction. @@ -472,17 +478,17 @@ Let left_step'' := forall n, A' n <-> A' (S n). Lemma ls_ls' : A z -> left_step -> left_step'. Proof. intros Az LS n H1 H2. le_elim H1. -apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl]. -rewrite H1; apply Az. +- apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl]. +- rewrite H1; apply Az. Qed. Lemma ls'_ls'' : left_step' -> left_step''. Proof. intros LS' n; split; intros H1 m H2 H3. -apply le_succ_l in H3. apply lt_le_incl in H3. now apply H1. -le_elim H3. -apply le_succ_l in H3. now apply H1. -rewrite <- H3 in *; now apply LS'. +- apply le_succ_l in H3. apply lt_le_incl in H3. now apply H1. +- le_elim H3. + + apply le_succ_l in H3. now apply H1. + + rewrite <- H3 in *; now apply LS'. Qed. Lemma lbase : A' (S z). @@ -512,10 +518,12 @@ Theorem left_induction' : Proof. intros R L n. destruct (lt_trichotomy n z) as [H | [H | H]]. -apply left_induction. apply R. now apply eq_le_incl. assumption. -now apply lt_le_incl. -rewrite H; apply R; now apply eq_le_incl. -apply R; now apply lt_le_incl. +- apply left_induction. + + apply R. now apply eq_le_incl. + + assumption. + + now apply lt_le_incl. +- rewrite H; apply R; now apply eq_le_incl. +- apply R; now apply lt_le_incl. Qed. Theorem strong_left_induction' : @@ -523,9 +531,9 @@ Theorem strong_left_induction' : Proof. intros R L n. destruct (lt_trichotomy n z) as [H | [H | H]]. -apply strong_left_induction; auto. now apply lt_le_incl. -rewrite H; apply R; now apply eq_le_incl. -apply R; now apply lt_le_incl. +- apply strong_left_induction; auto. now apply lt_le_incl. +- rewrite H; apply R; now apply eq_le_incl. +- apply R; now apply lt_le_incl. Qed. End LeftInduction. @@ -538,9 +546,9 @@ Theorem order_induction : Proof. intros Az RS LS n. destruct (lt_trichotomy n z) as [H | [H | H]]. -now apply left_induction; [| | apply lt_le_incl]. -now rewrite H. -now apply right_induction; [| | apply lt_le_incl]. +- now apply left_induction; [| | apply lt_le_incl]. +- now rewrite H. +- now apply right_induction; [| | apply lt_le_incl]. Qed. Theorem order_induction' : @@ -622,21 +630,24 @@ Theorem lt_wf : well_founded Rlt. Proof. unfold well_founded. apply strong_right_induction' with (z := z). -auto with typeclass_instances. -intros n H; constructor; intros y [H1 H2]. -apply nle_gt in H2. elim H2. now apply le_trans with z. -intros n H1 H2; constructor; intros m [H3 H4]. now apply H2. +- auto with typeclass_instances. +- intros n H; constructor; intros y [H1 H2]. + apply nle_gt in H2. elim H2. now apply le_trans with z. +- intros n H1 H2; constructor; intros m [H3 H4]. now apply H2. Qed. Theorem gt_wf : well_founded Rgt. Proof. unfold well_founded. apply strong_left_induction' with (z := z). -auto with typeclass_instances. -intros n H; constructor; intros y [H1 H2]. -apply nle_gt in H2. elim H2. now apply le_lt_trans with n. -intros n H1 H2; constructor; intros m [H3 H4]. -apply H2. assumption. now apply le_succ_l. +- auto with typeclass_instances. +- intros n H; constructor; intros y [H1 H2]. + apply nle_gt in H2. + + elim H2. + + now apply le_lt_trans with n. +- intros n H1 H2; constructor; intros m [H3 H4]. + apply H2. + + assumption. + now apply le_succ_l. Qed. End WF. diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v index 93d99f08f5..84b8a96e64 100644 --- a/theories/Numbers/NatInt/NZParity.v +++ b/theories/Numbers/NatInt/NZParity.v @@ -48,20 +48,20 @@ Qed. Lemma Even_or_Odd : forall x, Even x \/ Odd x. Proof. nzinduct x. - left. exists 0. now nzsimpl. - intros x. - split; intros [(y,H)|(y,H)]. - right. exists y. rewrite H. now nzsimpl. - left. exists (S y). rewrite H. now nzsimpl'. - right. - assert (LT : exists z, z<y). - destruct (lt_ge_cases 0 y) as [LT|GT]; [now exists 0 | exists x]. - rewrite <- le_succ_l, H. nzsimpl'. - rewrite <- (add_0_r y) at 3. now apply add_le_mono_l. - destruct LT as (z,LT). - destruct (lt_exists_pred z y LT) as (y' & Hy' & _). - exists y'. rewrite <- succ_inj_wd, H, Hy'. now nzsimpl'. - left. exists y. rewrite <- succ_inj_wd. rewrite H. now nzsimpl. + - left. exists 0. now nzsimpl. + - intros x. + split; intros [(y,H)|(y,H)]. + + right. exists y. rewrite H. now nzsimpl. + + left. exists (S y). rewrite H. now nzsimpl'. + + right. + assert (LT : exists z, z<y). + * destruct (lt_ge_cases 0 y) as [LT|GT]; [now exists 0 | exists x]. + rewrite <- le_succ_l, H. nzsimpl'. + rewrite <- (add_0_r y) at 3. now apply add_le_mono_l. + * destruct LT as (z,LT). + destruct (lt_exists_pred z y LT) as (y' & Hy' & _). + exists y'. rewrite <- succ_inj_wd, H, Hy'. now nzsimpl'. + + left. exists y. rewrite <- succ_inj_wd. rewrite H. now nzsimpl. Qed. Lemma double_below : forall n m, n<=m -> 2*n < 2*m+1. @@ -80,16 +80,16 @@ Lemma Even_Odd_False : forall x, Even x -> Odd x -> False. Proof. intros x (y,E) (z,O). rewrite O in E; clear O. destruct (le_gt_cases y z) as [LE|GT]. -generalize (double_below _ _ LE); order. -generalize (double_above _ _ GT); order. +- generalize (double_below _ _ LE); order. +- generalize (double_above _ _ GT); order. Qed. Lemma orb_even_odd : forall n, orb (even n) (odd n) = true. Proof. intros. destruct (Even_or_Odd n) as [H|H]. - rewrite <- even_spec in H. now rewrite H. - rewrite <- odd_spec in H. now rewrite H, orb_true_r. + - rewrite <- even_spec in H. now rewrite H. + - rewrite <- odd_spec in H. now rewrite H, orb_true_r. Qed. Lemma negb_odd : forall n, negb (odd n) = even n. @@ -142,8 +142,8 @@ Qed. Lemma Odd_succ : forall n, Odd (S n) <-> Even n. Proof. split; intros (m,H). - exists m. apply succ_inj. now rewrite add_1_r in H. - exists m. rewrite add_1_r. now f_equiv. + - exists m. apply succ_inj. now rewrite add_1_r in H. + - exists m. rewrite add_1_r. now f_equiv. Qed. Lemma odd_succ : forall n, odd (S n) = even n. @@ -192,10 +192,10 @@ Proof. case_eq (even n); case_eq (even m); rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec; intros (m',Hm) (n',Hn). - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm. - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_assoc. - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_shuffle0. - exists (n'+m'+1). rewrite Hm,Hn. nzsimpl'. now rewrite add_shuffle1. + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm. + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_assoc. + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_shuffle0. + - exists (n'+m'+1). rewrite Hm,Hn. nzsimpl'. now rewrite add_shuffle1. Qed. Lemma odd_add : forall n m, odd (n+m) = xorb (odd n) (odd m). @@ -210,14 +210,14 @@ Lemma even_mul : forall n m, even (mul n m) = even n || even m. Proof. intros. case_eq (even n); simpl; rewrite ?even_spec. - intros (n',Hn). exists (n'*m). now rewrite Hn, mul_assoc. - case_eq (even m); simpl; rewrite ?even_spec. - intros (m',Hm). exists (n*m'). now rewrite Hm, !mul_assoc, (mul_comm 2). - (* odd / odd *) - rewrite <- !negb_true_iff, !negb_even, !odd_spec. - intros (m',Hm) (n',Hn). exists (n'*2*m' +n'+m'). - rewrite Hn,Hm, !mul_add_distr_l, !mul_add_distr_r, !mul_1_l, !mul_1_r. - now rewrite add_shuffle1, add_assoc, !mul_assoc. + - intros (n',Hn). exists (n'*m). now rewrite Hn, mul_assoc. + - case_eq (even m); simpl; rewrite ?even_spec. + + intros (m',Hm). exists (n*m'). now rewrite Hm, !mul_assoc, (mul_comm 2). + (* odd / odd *) + + rewrite <- !negb_true_iff, !negb_even, !odd_spec. + intros (m',Hm) (n',Hn). exists (n'*2*m' +n'+m'). + rewrite Hn,Hm, !mul_add_distr_l, !mul_add_distr_r, !mul_1_l, !mul_1_r. + now rewrite add_shuffle1, add_assoc, !mul_assoc. Qed. Lemma odd_mul : forall n m, odd (mul n m) = odd n && odd m. diff --git a/theories/Numbers/NatInt/NZPow.v b/theories/Numbers/NatInt/NZPow.v index a1310667e1..830540bc66 100644 --- a/theories/Numbers/NatInt/NZPow.v +++ b/theories/Numbers/NatInt/NZPow.v @@ -60,8 +60,8 @@ Lemma pow_0_l' : forall a, a~=0 -> 0^a == 0. Proof. intros a Ha. destruct (lt_trichotomy a 0) as [LT|[EQ|GT]]; try order. - now rewrite pow_neg_r. - now apply pow_0_l. + - now rewrite pow_neg_r. + - now apply pow_0_l. Qed. Lemma pow_1_r : forall a, a^1 == a. @@ -71,9 +71,9 @@ Qed. Lemma pow_1_l : forall a, 0<=a -> 1^a == 1. Proof. - apply le_ind; intros. solve_proper. - now nzsimpl. - now nzsimpl. + apply le_ind; intros. - solve_proper. + - now nzsimpl. + - now nzsimpl. Qed. Hint Rewrite pow_1_r pow_1_l : nz. @@ -90,12 +90,12 @@ Hint Rewrite pow_2_r : nz. Lemma pow_eq_0 : forall a b, 0<=b -> a^b == 0 -> a == 0. Proof. intros a b Hb. apply le_ind with (4:=Hb). - solve_proper. - rewrite pow_0_r. order'. - clear b Hb. intros b Hb IH. - rewrite pow_succ_r by trivial. - intros H. apply eq_mul_0 in H. destruct H; trivial. - now apply IH. + - solve_proper. + - rewrite pow_0_r. order'. + - clear b Hb. intros b Hb IH. + rewrite pow_succ_r by trivial. + intros H. apply eq_mul_0 in H. destruct H; trivial. + now apply IH. Qed. Lemma pow_nonzero : forall a b, a~=0 -> 0<=b -> a^b ~= 0. @@ -106,13 +106,13 @@ Qed. Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b<0 \/ (0<b /\ a==0). Proof. intros a b. split. - intros H. - destruct (lt_trichotomy b 0) as [Hb|[Hb|Hb]]. - now left. - rewrite Hb, pow_0_r in H; order'. - right. split; trivial. apply pow_eq_0 with b; order. - intros [Hb|[Hb Ha]]. now rewrite pow_neg_r. - rewrite Ha. apply pow_0_l'. order. + - intros H. + destruct (lt_trichotomy b 0) as [Hb|[Hb|Hb]]. + + now left. + + rewrite Hb, pow_0_r in H; order'. + + right. split; trivial. apply pow_eq_0 with b; order. + - intros [Hb|[Hb Ha]]. + now rewrite pow_neg_r. + + rewrite Ha. apply pow_0_l'. order. Qed. (** Power and addition, multiplication *) @@ -120,12 +120,12 @@ Qed. Lemma pow_add_r : forall a b c, 0<=b -> 0<=c -> a^(b+c) == a^b * a^c. Proof. - intros a b c Hb. apply le_ind with (4:=Hb). solve_proper. - now nzsimpl. - clear b Hb. intros b Hb IH Hc. - nzsimpl; trivial. - rewrite IH; trivial. apply mul_assoc. - now apply add_nonneg_nonneg. + intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. + - now nzsimpl. + - clear b Hb. intros b Hb IH Hc. + nzsimpl; trivial. + + rewrite IH; trivial. apply mul_assoc. + + now apply add_nonneg_nonneg. Qed. Lemma pow_mul_l : forall a b c, @@ -133,23 +133,23 @@ Lemma pow_mul_l : forall a b c, Proof. intros a b c. destruct (lt_ge_cases c 0) as [Hc|Hc]. - rewrite !(pow_neg_r _ _ Hc). now nzsimpl. - apply le_ind with (4:=Hc). solve_proper. - now nzsimpl. - clear c Hc. intros c Hc IH. - nzsimpl; trivial. - rewrite IH; trivial. apply mul_shuffle1. + - rewrite !(pow_neg_r _ _ Hc). now nzsimpl. + - apply le_ind with (4:=Hc). + solve_proper. + + now nzsimpl. + + clear c Hc. intros c Hc IH. + nzsimpl; trivial. + rewrite IH; trivial. apply mul_shuffle1. Qed. Lemma pow_mul_r : forall a b c, 0<=b -> 0<=c -> a^(b*c) == (a^b)^c. Proof. - intros a b c Hb. apply le_ind with (4:=Hb). solve_proper. - intros. now nzsimpl. - clear b Hb. intros b Hb IH Hc. - nzsimpl; trivial. - rewrite pow_add_r, IH, pow_mul_l; trivial. apply mul_comm. - now apply mul_nonneg_nonneg. + intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. + - intros. now nzsimpl. + - clear b Hb. intros b Hb IH Hc. + nzsimpl; trivial. + rewrite pow_add_r, IH, pow_mul_l; trivial. + apply mul_comm. + + now apply mul_nonneg_nonneg. Qed. (** Positivity *) @@ -158,67 +158,67 @@ Lemma pow_nonneg : forall a b, 0<=a -> 0<=a^b. Proof. intros a b Ha. destruct (lt_ge_cases b 0) as [Hb|Hb]. - now rewrite !(pow_neg_r _ _ Hb). - apply le_ind with (4:=Hb). solve_proper. - nzsimpl; order'. - clear b Hb. intros b Hb IH. - nzsimpl; trivial. now apply mul_nonneg_nonneg. + - now rewrite !(pow_neg_r _ _ Hb). + - apply le_ind with (4:=Hb). + solve_proper. + + nzsimpl; order'. + + clear b Hb. intros b Hb IH. + nzsimpl; trivial. now apply mul_nonneg_nonneg. Qed. Lemma pow_pos_nonneg : forall a b, 0<a -> 0<=b -> 0<a^b. Proof. - intros a b Ha Hb. apply le_ind with (4:=Hb). solve_proper. - nzsimpl; order'. - clear b Hb. intros b Hb IH. - nzsimpl; trivial. now apply mul_pos_pos. + intros a b Ha Hb. apply le_ind with (4:=Hb). - solve_proper. + - nzsimpl; order'. + - clear b Hb. intros b Hb IH. + nzsimpl; trivial. now apply mul_pos_pos. Qed. (** Monotonicity *) Lemma pow_lt_mono_l : forall a b c, 0<c -> 0<=a<b -> a^c < b^c. Proof. - intros a b c Hc. apply lt_ind with (4:=Hc). solve_proper. - intros (Ha,H). nzsimpl; trivial; order. - clear c Hc. intros c Hc IH (Ha,H). - nzsimpl; try order. - apply mul_lt_mono_nonneg; trivial. - apply pow_nonneg; try order. - apply IH. now split. + intros a b c Hc. apply lt_ind with (4:=Hc). - solve_proper. + - intros (Ha,H). nzsimpl; trivial; order. + - clear c Hc. intros c Hc IH (Ha,H). + nzsimpl; try order. + apply mul_lt_mono_nonneg; trivial. + + apply pow_nonneg; try order. + + apply IH. now split. Qed. Lemma pow_le_mono_l : forall a b c, 0<=a<=b -> a^c <= b^c. Proof. intros a b c (Ha,H). destruct (lt_trichotomy c 0) as [Hc|[Hc|Hc]]. - rewrite !(pow_neg_r _ _ Hc); now nzsimpl. - rewrite Hc; now nzsimpl. - apply lt_eq_cases in H. destruct H as [H|H]; [|now rewrite <- H]. - apply lt_le_incl, pow_lt_mono_l; now try split. + - rewrite !(pow_neg_r _ _ Hc); now nzsimpl. + - rewrite Hc; now nzsimpl. + - apply lt_eq_cases in H. destruct H as [H|H]; [|now rewrite <- H]. + apply lt_le_incl, pow_lt_mono_l; now try split. Qed. Lemma pow_gt_1 : forall a b, 1<a -> (0<b <-> 1<a^b). Proof. intros a b Ha. split; intros Hb. - rewrite <- (pow_1_l b) by order. - apply pow_lt_mono_l; try split; order'. - destruct (lt_trichotomy b 0) as [H|[H|H]]; trivial. - rewrite pow_neg_r in Hb; order'. - rewrite H, pow_0_r in Hb. order. + - rewrite <- (pow_1_l b) by order. + apply pow_lt_mono_l; try split; order'. + - destruct (lt_trichotomy b 0) as [H|[H|H]]; trivial. + + rewrite pow_neg_r in Hb; order'. + + rewrite H, pow_0_r in Hb. order. Qed. Lemma pow_lt_mono_r : forall a b c, 1<a -> 0<=c -> b<c -> a^b < a^c. Proof. intros a b c Ha Hc H. destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite pow_neg_r by trivial. apply pow_pos_nonneg; order'. - assert (H' : b<=c) by order. - destruct (le_exists_sub _ _ H') as (d & EQ & Hd). - rewrite EQ, pow_add_r; trivial. rewrite <- (mul_1_l (a^b)) at 1. - apply mul_lt_mono_pos_r. - apply pow_pos_nonneg; order'. - apply pow_gt_1; trivial. - apply lt_eq_cases in Hd; destruct Hd as [LT|EQ']; trivial. - rewrite <- EQ' in *. rewrite add_0_l in EQ. order. + - rewrite pow_neg_r by trivial. apply pow_pos_nonneg; order'. + - assert (H' : b<=c) by order. + destruct (le_exists_sub _ _ H') as (d & EQ & Hd). + rewrite EQ, pow_add_r; trivial. rewrite <- (mul_1_l (a^b)) at 1. + apply mul_lt_mono_pos_r. + + apply pow_pos_nonneg; order'. + + apply pow_gt_1; trivial. + apply lt_eq_cases in Hd; destruct Hd as [LT|EQ']; trivial. + rewrite <- EQ' in *. rewrite add_0_l in EQ. order. Qed. (** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *) @@ -227,20 +227,20 @@ Lemma pow_le_mono_r : forall a b c, 0<a -> b<=c -> a^b <= a^c. Proof. intros a b c Ha H. destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite (pow_neg_r _ _ Hb). apply pow_nonneg; order. - apply le_succ_l in Ha; rewrite <- one_succ in Ha. - apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. - apply lt_eq_cases in H; destruct H as [H|H]; [|now rewrite <- H]. - apply lt_le_incl, pow_lt_mono_r; order. - nzsimpl; order. + - rewrite (pow_neg_r _ _ Hb). apply pow_nonneg; order. + - apply le_succ_l in Ha; rewrite <- one_succ in Ha. + apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. + + apply lt_eq_cases in H; destruct H as [H|H]; [|now rewrite <- H]. + apply lt_le_incl, pow_lt_mono_r; order. + + nzsimpl; order. Qed. Lemma pow_le_mono : forall a b c d, 0<a<=c -> b<=d -> a^b <= c^d. Proof. intros. transitivity (a^d). - apply pow_le_mono_r; intuition order. - apply pow_le_mono_l; intuition order. + - apply pow_le_mono_r; intuition order. + - apply pow_le_mono_l; intuition order. Qed. Lemma pow_lt_mono : forall a b c d, 0<a<c -> 0<b<d -> @@ -249,10 +249,10 @@ Proof. intros a b c d (Ha,Hac) (Hb,Hbd). apply le_succ_l in Ha; rewrite <- one_succ in Ha. apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. - transitivity (a^d). - apply pow_lt_mono_r; intuition order. - apply pow_lt_mono_l; try split; order'. - nzsimpl; try order. apply pow_gt_1; order. + - transitivity (a^d). + + apply pow_lt_mono_r; intuition order. + + apply pow_lt_mono_l; try split; order'. + - nzsimpl; try order. apply pow_gt_1; order. Qed. (** Injectivity *) @@ -262,10 +262,10 @@ Lemma pow_inj_l : forall a b c, 0<=a -> 0<=b -> 0<c -> Proof. intros a b c Ha Hb Hc EQ. destruct (lt_trichotomy a b) as [LT|[EQ'|GT]]; trivial. - assert (a^c < b^c) by (apply pow_lt_mono_l; try split; trivial). - order. - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). - order. + - assert (a^c < b^c) by (apply pow_lt_mono_l; try split; trivial). + order. + - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). + order. Qed. Lemma pow_inj_r : forall a b c, 1<a -> 0<=b -> 0<=c -> @@ -273,10 +273,10 @@ Lemma pow_inj_r : forall a b c, 1<a -> 0<=b -> 0<=c -> Proof. intros a b c Ha Hb Hc EQ. destruct (lt_trichotomy b c) as [LT|[EQ'|GT]]; trivial. - assert (a^b < a^c) by (apply pow_lt_mono_r; try split; trivial). - order. - assert (a^c < a^b) by (apply pow_lt_mono_r; try split; trivial). - order. + - assert (a^b < a^c) by (apply pow_lt_mono_r; try split; trivial). + order. + - assert (a^c < a^b) by (apply pow_lt_mono_r; try split; trivial). + order. Qed. (** Monotonicity results, both ways *) @@ -286,10 +286,10 @@ Lemma pow_lt_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c -> Proof. intros a b c Ha Hb Hc. split; intro LT. - apply pow_lt_mono_l; try split; trivial. - destruct (le_gt_cases b a) as [LE|GT]; trivial. - assert (b^c <= a^c) by (apply pow_le_mono_l; try split; order). - order. + - apply pow_lt_mono_l; try split; trivial. + - destruct (le_gt_cases b a) as [LE|GT]; trivial. + assert (b^c <= a^c) by (apply pow_le_mono_l; try split; order). + order. Qed. Lemma pow_le_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c -> @@ -297,10 +297,10 @@ Lemma pow_le_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c -> Proof. intros a b c Ha Hb Hc. split; intro LE. - apply pow_le_mono_l; try split; trivial. - destruct (le_gt_cases a b) as [LE'|GT]; trivial. - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). - order. + - apply pow_le_mono_l; try split; trivial. + - destruct (le_gt_cases a b) as [LE'|GT]; trivial. + assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). + order. Qed. Lemma pow_lt_mono_r_iff : forall a b c, 1<a -> 0<=c -> @@ -308,10 +308,10 @@ Lemma pow_lt_mono_r_iff : forall a b c, 1<a -> 0<=c -> Proof. intros a b c Ha Hc. split; intro LT. - now apply pow_lt_mono_r. - destruct (le_gt_cases c b) as [LE|GT]; trivial. - assert (a^c <= a^b) by (apply pow_le_mono_r; order'). - order. + - now apply pow_lt_mono_r. + - destruct (le_gt_cases c b) as [LE|GT]; trivial. + assert (a^c <= a^b) by (apply pow_le_mono_r; order'). + order. Qed. Lemma pow_le_mono_r_iff : forall a b c, 1<a -> 0<=c -> @@ -319,26 +319,26 @@ Lemma pow_le_mono_r_iff : forall a b c, 1<a -> 0<=c -> Proof. intros a b c Ha Hc. split; intro LE. - apply pow_le_mono_r; order'. - destruct (le_gt_cases b c) as [LE'|GT]; trivial. - assert (a^c < a^b) by (apply pow_lt_mono_r; order'). - order. + - apply pow_le_mono_r; order'. + - destruct (le_gt_cases b c) as [LE'|GT]; trivial. + assert (a^c < a^b) by (apply pow_lt_mono_r; order'). + order. Qed. (** For any a>1, the a^x function is above the identity function *) Lemma pow_gt_lin_r : forall a b, 1<a -> 0<=b -> b < a^b. Proof. - intros a b Ha Hb. apply le_ind with (4:=Hb). solve_proper. - nzsimpl. order'. - clear b Hb. intros b Hb IH. nzsimpl; trivial. - rewrite <- !le_succ_l in *. rewrite <- two_succ in Ha. - transitivity (2*(S b)). - nzsimpl'. rewrite <- 2 succ_le_mono. - rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - apply mul_le_mono_nonneg; trivial. - order'. - now apply lt_le_incl, lt_succ_r. + intros a b Ha Hb. apply le_ind with (4:=Hb). - solve_proper. + - nzsimpl. order'. + - clear b Hb. intros b Hb IH. nzsimpl; trivial. + rewrite <- !le_succ_l in *. rewrite <- two_succ in Ha. + transitivity (2*(S b)). + + nzsimpl'. rewrite <- 2 succ_le_mono. + rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + apply mul_le_mono_nonneg; trivial. + * order'. + * now apply lt_le_incl, lt_succ_r. Qed. (** Someday, we should say something about the full Newton formula. @@ -349,22 +349,22 @@ Qed. Lemma pow_add_lower : forall a b c, 0<=a -> 0<=b -> 0<c -> a^c + b^c <= (a+b)^c. Proof. - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). solve_proper. - nzsimpl; order. - clear c Hc. intros c Hc IH. - assert (0<=c) by order'. - nzsimpl; trivial. - transitivity ((a+b)*(a^c + b^c)). - rewrite mul_add_distr_r, !mul_add_distr_l. - apply add_le_mono. - rewrite <- add_0_r at 1. apply add_le_mono_l. - apply mul_nonneg_nonneg; trivial. - apply pow_nonneg; trivial. - rewrite <- add_0_l at 1. apply add_le_mono_r. - apply mul_nonneg_nonneg; trivial. - apply pow_nonneg; trivial. - apply mul_le_mono_nonneg_l; trivial. - now apply add_nonneg_nonneg. + intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). - solve_proper. + - nzsimpl; order. + - clear c Hc. intros c Hc IH. + assert (0<=c) by order'. + nzsimpl; trivial. + transitivity ((a+b)*(a^c + b^c)). + + rewrite mul_add_distr_r, !mul_add_distr_l. + apply add_le_mono. + * rewrite <- add_0_r at 1. apply add_le_mono_l. + apply mul_nonneg_nonneg; trivial. + apply pow_nonneg; trivial. + * rewrite <- add_0_l at 1. apply add_le_mono_r. + apply mul_nonneg_nonneg; trivial. + apply pow_nonneg; trivial. + + apply mul_le_mono_nonneg_l; trivial. + now apply add_nonneg_nonneg. Qed. (** This upper bound can also be seen as a convexity proof for x^c : @@ -377,37 +377,37 @@ Proof. assert (aux : forall a b c, 0<=a<=b -> 0<c -> (a + b) * (a ^ c + b ^ c) <= 2 * (a * a ^ c + b * b ^ c)). (* begin *) - intros a b c (Ha,H) Hc. - rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. - rewrite <- !add_assoc. apply add_le_mono_l. - rewrite !add_assoc. apply add_le_mono_r. - destruct (le_exists_sub _ _ H) as (d & EQ & Hd). - rewrite EQ. - rewrite 2 mul_add_distr_r. - rewrite !add_assoc. apply add_le_mono_r. - rewrite add_comm. apply add_le_mono_l. - apply mul_le_mono_nonneg_l; trivial. - apply pow_le_mono_l; try split; order. - (* end *) - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). solve_proper. - nzsimpl; order. - clear c Hc. intros c Hc IH. - assert (0<=c) by order. - nzsimpl; trivial. - transitivity ((a+b)*(2^(pred c) * (a^c + b^c))). - apply mul_le_mono_nonneg_l; trivial. - now apply add_nonneg_nonneg. - rewrite mul_assoc. rewrite (mul_comm (a+b)). - assert (EQ : S (P c) == c) by (apply lt_succ_pred with 0; order'). - assert (LE : 0 <= P c) by (now rewrite succ_le_mono, EQ, le_succ_l). - assert (EQ' : 2^c == 2^(P c) * 2) by (rewrite <- EQ at 1; nzsimpl'; order). - rewrite EQ', <- !mul_assoc. - apply mul_le_mono_nonneg_l. - apply pow_nonneg; order'. - destruct (le_gt_cases a b). - apply aux; try split; order'. - rewrite (add_comm a), (add_comm (a^c)), (add_comm (a*a^c)). - apply aux; try split; order'. + - intros a b c (Ha,H) Hc. + rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. + rewrite <- !add_assoc. apply add_le_mono_l. + rewrite !add_assoc. apply add_le_mono_r. + destruct (le_exists_sub _ _ H) as (d & EQ & Hd). + rewrite EQ. + rewrite 2 mul_add_distr_r. + rewrite !add_assoc. apply add_le_mono_r. + rewrite add_comm. apply add_le_mono_l. + apply mul_le_mono_nonneg_l; trivial. + apply pow_le_mono_l; try split; order. + (* end *) + - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). + solve_proper. + + nzsimpl; order. + + clear c Hc. intros c Hc IH. + assert (0<=c) by order. + nzsimpl; trivial. + transitivity ((a+b)*(2^(pred c) * (a^c + b^c))). + * apply mul_le_mono_nonneg_l; trivial. + now apply add_nonneg_nonneg. + * rewrite mul_assoc. rewrite (mul_comm (a+b)). + assert (EQ : S (P c) == c) by (apply lt_succ_pred with 0; order'). + assert (LE : 0 <= P c) by (now rewrite succ_le_mono, EQ, le_succ_l). + assert (EQ' : 2^c == 2^(P c) * 2) by (rewrite <- EQ at 1; nzsimpl'; order). + rewrite EQ', <- !mul_assoc. + apply mul_le_mono_nonneg_l. + -- apply pow_nonneg; order'. + -- destruct (le_gt_cases a b). + ++ apply aux; try split; order'. + ++ rewrite (add_comm a), (add_comm (a^c)), (add_comm (a*a^c)). + apply aux; try split; order'. Qed. End NZPowProp. diff --git a/theories/Numbers/NatInt/NZSqrt.v b/theories/Numbers/NatInt/NZSqrt.v index c2d2c4ae19..85ed71b8a4 100644 --- a/theories/Numbers/NatInt/NZSqrt.v +++ b/theories/Numbers/NatInt/NZSqrt.v @@ -49,18 +49,18 @@ Proof. intros b LT. destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. exfalso. assert ((S b)² < b²). - rewrite mul_succ_l, <- (add_0_r b²). - apply add_lt_le_mono. - apply mul_lt_mono_neg_l; trivial. apply lt_succ_diag_r. - now apply le_succ_l. - order. + - rewrite mul_succ_l, <- (add_0_r b²). + apply add_lt_le_mono. + + apply mul_lt_mono_neg_l; trivial. apply lt_succ_diag_r. + + now apply le_succ_l. + - order. Qed. Lemma sqrt_nonneg : forall a, 0<=√a. Proof. intros. destruct (lt_ge_cases a 0) as [Ha|Ha]. - now rewrite (sqrt_neg _ Ha). - apply sqrt_spec_nonneg. destruct (sqrt_spec a Ha). order. + - now rewrite (sqrt_neg _ Ha). + - apply sqrt_spec_nonneg. destruct (sqrt_spec a Ha). order. Qed. (** The spec of sqrt indeed determines it *) @@ -73,12 +73,12 @@ Proof. assert (Ha': 0<=√a) by now apply sqrt_nonneg. destruct (sqrt_spec a Ha) as (LEa,LTa). assert (b <= √a). - apply lt_succ_r, square_lt_simpl_nonneg; [|order]. - now apply lt_le_incl, lt_succ_r. - assert (√a <= b). - apply lt_succ_r, square_lt_simpl_nonneg; [|order]. - now apply lt_le_incl, lt_succ_r. - order. + - apply lt_succ_r, square_lt_simpl_nonneg; [|order]. + now apply lt_le_incl, lt_succ_r. + - assert (√a <= b). + + apply lt_succ_r, square_lt_simpl_nonneg; [|order]. + now apply lt_le_incl, lt_succ_r. + + order. Qed. (** Hence sqrt is a morphism *) @@ -87,9 +87,9 @@ Instance sqrt_wd : Proper (eq==>eq) sqrt. Proof. intros x x' Hx. destruct (lt_ge_cases x 0) as [H|H]. - rewrite 2 sqrt_neg; trivial. reflexivity. - now rewrite <- Hx. - apply sqrt_unique. rewrite Hx in *. now apply sqrt_spec. + - rewrite 2 sqrt_neg; trivial. + reflexivity. + + now rewrite <- Hx. + - apply sqrt_unique. rewrite Hx in *. now apply sqrt_spec. Qed. (** An alternate specification *) @@ -101,11 +101,11 @@ Proof. destruct (sqrt_spec _ Ha) as (LE,LT). destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). exists r. - split. now rewrite add_comm. - split. trivial. - apply (add_le_mono_r _ _ (√a)²). - rewrite <- Hr, add_comm. - generalize LT. nzsimpl'. now rewrite lt_succ_r, add_assoc. + split. - now rewrite add_comm. + - split. + trivial. + + apply (add_le_mono_r _ _ (√a)²). + rewrite <- Hr, add_comm. + generalize LT. nzsimpl'. now rewrite lt_succ_r, add_assoc. Qed. Lemma sqrt_unique' : forall a b c, 0<=c<=2*b -> @@ -115,10 +115,10 @@ Proof. apply sqrt_unique. rewrite EQ. split. - rewrite <- add_0_r at 1. now apply add_le_mono_l. - nzsimpl. apply lt_succ_r. - rewrite <- add_assoc. apply add_le_mono_l. - generalize H; now nzsimpl'. + - rewrite <- add_0_r at 1. now apply add_le_mono_l. + - nzsimpl. apply lt_succ_r. + rewrite <- add_assoc. apply add_le_mono_l. + generalize H; now nzsimpl'. Qed. (** Sqrt is exact on squares *) @@ -127,7 +127,7 @@ Lemma sqrt_square : forall a, 0<=a -> √(a²) == a. Proof. intros a Ha. apply sqrt_unique' with 0. - split. order. apply mul_nonneg_nonneg; order'. now nzsimpl. + - split. + order. + apply mul_nonneg_nonneg; order'. - now nzsimpl. Qed. (** Sqrt and predecessors of squares *) @@ -138,14 +138,14 @@ Proof. apply sqrt_unique. assert (EQ := lt_succ_pred 0 a Ha). rewrite EQ. split. - apply lt_succ_r. - rewrite (lt_succ_pred 0). - assert (0 <= P a) by (now rewrite <- lt_succ_r, EQ). - assert (P a < a) by (now rewrite <- le_succ_l, EQ). - apply mul_lt_mono_nonneg; trivial. - now apply mul_pos_pos. - apply le_succ_l. - rewrite (lt_succ_pred 0). reflexivity. now apply mul_pos_pos. + - apply lt_succ_r. + rewrite (lt_succ_pred 0). + + assert (0 <= P a) by (now rewrite <- lt_succ_r, EQ). + assert (P a < a) by (now rewrite <- le_succ_l, EQ). + apply mul_lt_mono_nonneg; trivial. + + now apply mul_pos_pos. + - apply le_succ_l. + rewrite (lt_succ_pred 0). + reflexivity. + now apply mul_pos_pos. Qed. (** Sqrt is a monotone function (but not a strict one) *) @@ -154,13 +154,13 @@ Lemma sqrt_le_mono : forall a b, a <= b -> √a <= √b. Proof. intros a b Hab. destruct (lt_ge_cases a 0) as [Ha|Ha]. - rewrite (sqrt_neg _ Ha). apply sqrt_nonneg. - assert (Hb : 0 <= b) by order. - destruct (sqrt_spec a Ha) as (LE,_). - destruct (sqrt_spec b Hb) as (_,LT). - apply lt_succ_r. - apply square_lt_simpl_nonneg; try order. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + - rewrite (sqrt_neg _ Ha). apply sqrt_nonneg. + - assert (Hb : 0 <= b) by order. + destruct (sqrt_spec a Ha) as (LE,_). + destruct (sqrt_spec b Hb) as (_,LT). + apply lt_succ_r. + apply square_lt_simpl_nonneg; try order. + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. Qed. (** No reverse result for <=, consider for instance √2 <= √1 *) @@ -169,16 +169,16 @@ Lemma sqrt_lt_cancel : forall a b, √a < √b -> a < b. Proof. intros a b H. destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite (sqrt_neg b Hb) in H; generalize (sqrt_nonneg a); order. - destruct (lt_ge_cases a 0) as [Ha|Ha]; [order|]. - destruct (sqrt_spec a Ha) as (_,LT). - destruct (sqrt_spec b Hb) as (LE,_). - apply le_succ_l in H. - assert ((S (√a))² <= (√b)²). - apply mul_le_mono_nonneg; trivial. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - order. + - rewrite (sqrt_neg b Hb) in H; generalize (sqrt_nonneg a); order. + - destruct (lt_ge_cases a 0) as [Ha|Ha]; [order|]. + destruct (sqrt_spec a Ha) as (_,LT). + destruct (sqrt_spec b Hb) as (LE,_). + apply le_succ_l in H. + assert ((S (√a))² <= (√b)²). + + apply mul_le_mono_nonneg; trivial. + * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + + order. Qed. (** When left side is a square, we have an equivalence for <= *) @@ -186,11 +186,11 @@ Qed. Lemma sqrt_le_square : forall a b, 0<=a -> 0<=b -> (b²<=a <-> b <= √a). Proof. intros a b Ha Hb. split; intros H. - rewrite <- (sqrt_square b); trivial. - now apply sqrt_le_mono. - destruct (sqrt_spec a Ha) as (LE,LT). - transitivity (√a)²; trivial. - now apply mul_le_mono_nonneg. + - rewrite <- (sqrt_square b); trivial. + now apply sqrt_le_mono. + - destruct (sqrt_spec a Ha) as (LE,LT). + transitivity (√a)²; trivial. + now apply mul_le_mono_nonneg. Qed. (** When right side is a square, we have an equivalence for < *) @@ -198,10 +198,10 @@ Qed. Lemma sqrt_lt_square : forall a b, 0<=a -> 0<=b -> (a<b² <-> √a < b). Proof. intros a b Ha Hb. split; intros H. - destruct (sqrt_spec a Ha) as (LE,_). - apply square_lt_simpl_nonneg; try order. - rewrite <- (sqrt_square b Hb) in H. - now apply sqrt_lt_cancel. + - destruct (sqrt_spec a Ha) as (LE,_). + apply square_lt_simpl_nonneg; try order. + - rewrite <- (sqrt_square b Hb) in H. + now apply sqrt_lt_cancel. Qed. (** Sqrt and basic constants *) @@ -218,14 +218,14 @@ Qed. Lemma sqrt_2 : √2 == 1. Proof. - apply sqrt_unique' with 1. nzsimpl; split; order'. now nzsimpl'. + apply sqrt_unique' with 1. - nzsimpl; split; order'. - now nzsimpl'. Qed. Lemma sqrt_pos : forall a, 0 < √a <-> 0 < a. Proof. - intros a. split; intros Ha. apply sqrt_lt_cancel. now rewrite sqrt_0. - rewrite <- le_succ_l, <- one_succ, <- sqrt_1. apply sqrt_le_mono. - now rewrite one_succ, le_succ_l. + intros a. split; intros Ha. - apply sqrt_lt_cancel. now rewrite sqrt_0. + - rewrite <- le_succ_l, <- one_succ, <- sqrt_1. apply sqrt_le_mono. + now rewrite one_succ, le_succ_l. Qed. Lemma sqrt_lt_lin : forall a, 1<a -> √a<a. @@ -239,11 +239,11 @@ Lemma sqrt_le_lin : forall a, 0<=a -> √a<=a. Proof. intros a Ha. destruct (le_gt_cases a 0) as [H|H]. - setoid_replace a with 0 by order. now rewrite sqrt_0. - destruct (le_gt_cases a 1) as [H'|H']. - rewrite <- le_succ_l, <- one_succ in H. - setoid_replace a with 1 by order. now rewrite sqrt_1. - now apply lt_le_incl, sqrt_lt_lin. + - setoid_replace a with 0 by order. now rewrite sqrt_0. + - destruct (le_gt_cases a 1) as [H'|H']. + + rewrite <- le_succ_l, <- one_succ in H. + setoid_replace a with 1 by order. now rewrite sqrt_1. + + now apply lt_le_incl, sqrt_lt_lin. Qed. (** Sqrt and multiplication. *) @@ -255,28 +255,28 @@ Lemma sqrt_mul_below : forall a b, √a * √b <= √(a*b). Proof. intros a b. destruct (lt_ge_cases a 0) as [Ha|Ha]. - rewrite (sqrt_neg a Ha). nzsimpl. apply sqrt_nonneg. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite (sqrt_neg b Hb). nzsimpl. apply sqrt_nonneg. - assert (Ha':=sqrt_nonneg a). - assert (Hb':=sqrt_nonneg b). - apply sqrt_le_square; try now apply mul_nonneg_nonneg. - rewrite mul_shuffle1. - apply mul_le_mono_nonneg; try now apply mul_nonneg_nonneg. - now apply sqrt_spec. - now apply sqrt_spec. + - rewrite (sqrt_neg a Ha). nzsimpl. apply sqrt_nonneg. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite (sqrt_neg b Hb). nzsimpl. apply sqrt_nonneg. + + assert (Ha':=sqrt_nonneg a). + assert (Hb':=sqrt_nonneg b). + apply sqrt_le_square; try now apply mul_nonneg_nonneg. + rewrite mul_shuffle1. + apply mul_le_mono_nonneg; try now apply mul_nonneg_nonneg. + * now apply sqrt_spec. + * now apply sqrt_spec. Qed. Lemma sqrt_mul_above : forall a b, 0<=a -> 0<=b -> √(a*b) < S (√a) * S (√b). Proof. intros a b Ha Hb. apply sqrt_lt_square. - now apply mul_nonneg_nonneg. - apply mul_nonneg_nonneg. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - rewrite mul_shuffle1. - apply mul_lt_mono_nonneg; trivial; now apply sqrt_spec. + - now apply mul_nonneg_nonneg. + - apply mul_nonneg_nonneg. + + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + - rewrite mul_shuffle1. + apply mul_lt_mono_nonneg; trivial; now apply sqrt_spec. Qed. (** And we can't find better approximations in general. @@ -296,73 +296,73 @@ Proof. intros a Ha. apply lt_succ_r. apply sqrt_lt_square. - now apply le_le_succ_r. - apply le_le_succ_r, le_le_succ_r, sqrt_nonneg. - rewrite <- (add_1_l (S (√a))). - apply lt_le_trans with (1²+(S (√a))²). - rewrite mul_1_l, add_1_l, <- succ_lt_mono. - now apply sqrt_spec. - apply add_square_le. order'. apply le_le_succ_r, sqrt_nonneg. + - now apply le_le_succ_r. + - apply le_le_succ_r, le_le_succ_r, sqrt_nonneg. + - rewrite <- (add_1_l (S (√a))). + apply lt_le_trans with (1²+(S (√a))²). + + rewrite mul_1_l, add_1_l, <- succ_lt_mono. + now apply sqrt_spec. + + apply add_square_le. * order'. * apply le_le_succ_r, sqrt_nonneg. Qed. Lemma sqrt_succ_or : forall a, 0<=a -> √(S a) == S (√a) \/ √(S a) == √a. Proof. intros a Ha. destruct (le_gt_cases (√(S a)) (√a)) as [H|H]. - right. generalize (sqrt_le_mono _ _ (le_succ_diag_r a)); order. - left. apply le_succ_l in H. generalize (sqrt_succ_le a Ha); order. + - right. generalize (sqrt_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (sqrt_succ_le a Ha); order. Qed. Lemma sqrt_eq_succ_iff_square : forall a, 0<=a -> (√(S a) == S (√a) <-> exists b, 0<b /\ S a == b²). Proof. intros a Ha. split. - intros EQ. exists (S (√a)). - split. apply lt_succ_r, sqrt_nonneg. - generalize (proj2 (sqrt_spec a Ha)). rewrite <- le_succ_l. - assert (Ha' : 0 <= S a) by now apply le_le_succ_r. - generalize (proj1 (sqrt_spec (S a) Ha')). rewrite EQ; order. - intros (b & Hb & H). - rewrite H. rewrite sqrt_square; try order. - symmetry. - rewrite <- (lt_succ_pred 0 b Hb). f_equiv. - rewrite <- (lt_succ_pred 0 b²) in H. apply succ_inj in H. - now rewrite H, sqrt_pred_square. - now apply mul_pos_pos. + - intros EQ. exists (S (√a)). + split. + apply lt_succ_r, sqrt_nonneg. + + generalize (proj2 (sqrt_spec a Ha)). rewrite <- le_succ_l. + assert (Ha' : 0 <= S a) by now apply le_le_succ_r. + generalize (proj1 (sqrt_spec (S a) Ha')). rewrite EQ; order. + - intros (b & Hb & H). + rewrite H. rewrite sqrt_square; try order. + symmetry. + rewrite <- (lt_succ_pred 0 b Hb). f_equiv. + rewrite <- (lt_succ_pred 0 b²) in H. + apply succ_inj in H. + now rewrite H, sqrt_pred_square. + + now apply mul_pos_pos. Qed. (** Sqrt and addition *) Lemma sqrt_add_le : forall a b, √(a+b) <= √a + √b. Proof. - assert (AUX : forall a b, a<0 -> √(a+b) <= √a + √b). - intros a b Ha. rewrite (sqrt_neg a Ha). nzsimpl. - apply sqrt_le_mono. - rewrite <- (add_0_l b) at 2. - apply add_le_mono_r; order. - intros a b. - destruct (lt_ge_cases a 0) as [Ha|Ha]. now apply AUX. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite (add_comm a), (add_comm (√a)); now apply AUX. - assert (Ha':=sqrt_nonneg a). - assert (Hb':=sqrt_nonneg b). - rewrite <- lt_succ_r. - apply sqrt_lt_square. - now apply add_nonneg_nonneg. - now apply lt_le_incl, lt_succ_r, add_nonneg_nonneg. - destruct (sqrt_spec a Ha) as (_,LTa). - destruct (sqrt_spec b Hb) as (_,LTb). - revert LTa LTb. nzsimpl. rewrite 3 lt_succ_r. - intros LTa LTb. - assert (H:=add_le_mono _ _ _ _ LTa LTb). - etransitivity; [eexact H|]. clear LTa LTb H. - rewrite <- (add_assoc _ (√a) (√a)). - rewrite <- (add_assoc _ (√b) (√b)). - rewrite add_shuffle1. - rewrite <- (add_assoc _ (√a + √b)). - rewrite (add_shuffle1 (√a) (√b)). - apply add_le_mono_r. - now apply add_square_le. + assert (AUX : forall a b, a<0 -> √(a+b) <= √a + √b). + - intros a b Ha. rewrite (sqrt_neg a Ha). nzsimpl. + apply sqrt_le_mono. + rewrite <- (add_0_l b) at 2. + apply add_le_mono_r; order. + - intros a b. + destruct (lt_ge_cases a 0) as [Ha|Ha]. + now apply AUX. + + destruct (lt_ge_cases b 0) as [Hb|Hb]. + * rewrite (add_comm a), (add_comm (√a)); now apply AUX. + * assert (Ha':=sqrt_nonneg a). + assert (Hb':=sqrt_nonneg b). + rewrite <- lt_succ_r. + apply sqrt_lt_square. + -- now apply add_nonneg_nonneg. + -- now apply lt_le_incl, lt_succ_r, add_nonneg_nonneg. + -- destruct (sqrt_spec a Ha) as (_,LTa). + destruct (sqrt_spec b Hb) as (_,LTb). + revert LTa LTb. nzsimpl. rewrite 3 lt_succ_r. + intros LTa LTb. + assert (H:=add_le_mono _ _ _ _ LTa LTb). + etransitivity; [eexact H|]. clear LTa LTb H. + rewrite <- (add_assoc _ (√a) (√a)). + rewrite <- (add_assoc _ (√b) (√b)). + rewrite add_shuffle1. + rewrite <- (add_assoc _ (√a + √b)). + rewrite (add_shuffle1 (√a) (√b)). + apply add_le_mono_r. + now apply add_square_le. Qed. (** convexity inequality for sqrt: sqrt of middle is above middle @@ -374,12 +374,12 @@ Proof. assert (Ha':=sqrt_nonneg a). assert (Hb':=sqrt_nonneg b). apply sqrt_le_square. - apply mul_nonneg_nonneg. order'. now apply add_nonneg_nonneg. - now apply add_nonneg_nonneg. - transitivity (2*((√a)² + (√b)²)). - now apply square_add_le. - apply mul_le_mono_nonneg_l. order'. - apply add_le_mono; now apply sqrt_spec. + - apply mul_nonneg_nonneg. + order'. + now apply add_nonneg_nonneg. + - now apply add_nonneg_nonneg. + - transitivity (2*((√a)² + (√b)²)). + + now apply square_add_le. + + apply mul_le_mono_nonneg_l. * order'. + * apply add_le_mono; now apply sqrt_spec. Qed. End NZSqrtProp. @@ -430,8 +430,8 @@ Qed. Lemma sqrt_up_nonneg : forall a, 0<=√°a. Proof. intros. destruct (le_gt_cases a 0) as [Ha|Ha]. - now rewrite sqrt_up_eqn0. - rewrite sqrt_up_eqn; trivial. apply le_le_succ_r, sqrt_nonneg. + - now rewrite sqrt_up_eqn0. + - rewrite sqrt_up_eqn; trivial. apply le_le_succ_r, sqrt_nonneg. Qed. (** [sqrt_up] is a morphism *) @@ -439,8 +439,8 @@ Qed. Instance sqrt_up_wd : Proper (eq==>eq) sqrt_up. Proof. assert (Proper (eq==>eq==>Logic.eq) compare). - intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order. - intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx. + - intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order. + - intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx. Qed. (** The spec of [sqrt_up] indeed determines it *) @@ -463,9 +463,9 @@ Lemma sqrt_up_square : forall a, 0<=a -> √°(a²) == a. Proof. intros a Ha. le_elim Ha. - rewrite sqrt_up_eqn by (now apply mul_pos_pos). - rewrite sqrt_pred_square; trivial. apply (lt_succ_pred 0); trivial. - rewrite sqrt_up_eqn0; trivial. rewrite <- Ha. now nzsimpl. + - rewrite sqrt_up_eqn by (now apply mul_pos_pos). + rewrite sqrt_pred_square; trivial. apply (lt_succ_pred 0); trivial. + - rewrite sqrt_up_eqn0; trivial. rewrite <- Ha. now nzsimpl. Qed. (** [sqrt_up] and successors of squares *) @@ -500,10 +500,10 @@ Qed. Lemma le_sqrt_sqrt_up : forall a, √a <= √°a. Proof. intros a. unfold sqrt_up. case compare_spec; intros H. - rewrite <- H, sqrt_0. order. - rewrite <- (lt_succ_pred 0 a H) at 1. apply sqrt_succ_le. - apply lt_succ_r. now rewrite (lt_succ_pred 0 a H). - now rewrite sqrt_neg. + - rewrite <- H, sqrt_0. order. + - rewrite <- (lt_succ_pred 0 a H) at 1. apply sqrt_succ_le. + apply lt_succ_r. now rewrite (lt_succ_pred 0 a H). + - now rewrite sqrt_neg. Qed. Lemma le_sqrt_up_succ_sqrt : forall a, √°a <= S (√a). @@ -517,21 +517,21 @@ Qed. Lemma sqrt_sqrt_up_spec : forall a, 0<=a -> (√a)² <= a <= (√°a)². Proof. intros a H. split. - now apply sqrt_spec. - le_elim H. - now apply sqrt_up_spec. - now rewrite <-H, sqrt_up_0, mul_0_l. + - now apply sqrt_spec. + - le_elim H. + + now apply sqrt_up_spec. + + now rewrite <-H, sqrt_up_0, mul_0_l. Qed. Lemma sqrt_sqrt_up_exact : forall a, 0<=a -> (√a == √°a <-> exists b, 0<=b /\ a == b²). Proof. intros a Ha. - split. intros. exists √a. - split. apply sqrt_nonneg. - generalize (sqrt_sqrt_up_spec a Ha). rewrite <-H. destruct 1; order. - intros (b & Hb & Hb'). rewrite Hb'. - now rewrite sqrt_square, sqrt_up_square. + split. - intros. exists √a. + split. + apply sqrt_nonneg. + + generalize (sqrt_sqrt_up_spec a Ha). rewrite <-H. destruct 1; order. + - intros (b & Hb & Hb'). rewrite Hb'. + now rewrite sqrt_square, sqrt_up_square. Qed. (** [sqrt_up] is a monotone function (but not a strict one) *) @@ -540,9 +540,9 @@ Lemma sqrt_up_le_mono : forall a b, a <= b -> √°a <= √°b. Proof. intros a b H. destruct (le_gt_cases a 0) as [Ha|Ha]. - rewrite (sqrt_up_eqn0 _ Ha). apply sqrt_up_nonneg. - rewrite 2 sqrt_up_eqn by order. rewrite <- succ_le_mono. - apply sqrt_le_mono, succ_le_mono. rewrite 2 (lt_succ_pred 0); order. + - rewrite (sqrt_up_eqn0 _ Ha). apply sqrt_up_nonneg. + - rewrite 2 sqrt_up_eqn by order. rewrite <- succ_le_mono. + apply sqrt_le_mono, succ_le_mono. rewrite 2 (lt_succ_pred 0); order. Qed. (** No reverse result for <=, consider for instance √°3 <= √°2 *) @@ -551,10 +551,10 @@ Lemma sqrt_up_lt_cancel : forall a b, √°a < √°b -> a < b. Proof. intros a b H. destruct (le_gt_cases b 0) as [Hb|Hb]. - rewrite (sqrt_up_eqn0 _ Hb) in H; generalize (sqrt_up_nonneg a); order. - destruct (le_gt_cases a 0) as [Ha|Ha]; [order|]. - rewrite <- (lt_succ_pred 0 a Ha), <- (lt_succ_pred 0 b Hb), <- succ_lt_mono. - apply sqrt_lt_cancel, succ_lt_mono. now rewrite <- 2 sqrt_up_eqn. + - rewrite (sqrt_up_eqn0 _ Hb) in H; generalize (sqrt_up_nonneg a); order. + - destruct (le_gt_cases a 0) as [Ha|Ha]; [order|]. + rewrite <- (lt_succ_pred 0 a Ha), <- (lt_succ_pred 0 b Hb), <- succ_lt_mono. + apply sqrt_lt_cancel, succ_lt_mono. now rewrite <- 2 sqrt_up_eqn. Qed. (** When left side is a square, we have an equivalence for < *) @@ -562,10 +562,10 @@ Qed. Lemma sqrt_up_lt_square : forall a b, 0<=a -> 0<=b -> (b² < a <-> b < √°a). Proof. intros a b Ha Hb. split; intros H. - destruct (sqrt_up_spec a) as (LE,LT). - apply le_lt_trans with b²; trivial using square_nonneg. - apply square_lt_simpl_nonneg; try order. apply sqrt_up_nonneg. - apply sqrt_up_lt_cancel. now rewrite sqrt_up_square. + - destruct (sqrt_up_spec a) as (LE,LT). + + apply le_lt_trans with b²; trivial using square_nonneg. + + apply square_lt_simpl_nonneg; try order. apply sqrt_up_nonneg. + - apply sqrt_up_lt_cancel. now rewrite sqrt_up_square. Qed. (** When right side is a square, we have an equivalence for <= *) @@ -573,17 +573,17 @@ Qed. Lemma sqrt_up_le_square : forall a b, 0<=a -> 0<=b -> (a <= b² <-> √°a <= b). Proof. intros a b Ha Hb. split; intros H. - rewrite <- (sqrt_up_square b Hb). - now apply sqrt_up_le_mono. - apply square_le_mono_nonneg in H; [|now apply sqrt_up_nonneg]. - transitivity (√°a)²; trivial. now apply sqrt_sqrt_up_spec. + - rewrite <- (sqrt_up_square b Hb). + now apply sqrt_up_le_mono. + - apply square_le_mono_nonneg in H; [|now apply sqrt_up_nonneg]. + transitivity (√°a)²; trivial. now apply sqrt_sqrt_up_spec. Qed. Lemma sqrt_up_pos : forall a, 0 < √°a <-> 0 < a. Proof. - intros a. split; intros Ha. apply sqrt_up_lt_cancel. now rewrite sqrt_up_0. - rewrite <- le_succ_l, <- one_succ, <- sqrt_up_1. apply sqrt_up_le_mono. - now rewrite one_succ, le_succ_l. + intros a. split; intros Ha. - apply sqrt_up_lt_cancel. now rewrite sqrt_up_0. + - rewrite <- le_succ_l, <- one_succ, <- sqrt_up_1. apply sqrt_up_le_mono. + now rewrite one_succ, le_succ_l. Qed. Lemma sqrt_up_lt_lin : forall a, 2<a -> √°a < a. @@ -599,11 +599,11 @@ Lemma sqrt_up_le_lin : forall a, 0<=a -> √°a<=a. Proof. intros a Ha. le_elim Ha. - rewrite sqrt_up_eqn; trivial. apply le_succ_l. - apply le_lt_trans with (P a). apply sqrt_le_lin. - now rewrite <- lt_succ_r, (lt_succ_pred 0). - rewrite <- (lt_succ_pred 0 a) at 2; trivial. apply lt_succ_diag_r. - now rewrite <- Ha, sqrt_up_0. + - rewrite sqrt_up_eqn; trivial. apply le_succ_l. + apply le_lt_trans with (P a). + apply sqrt_le_lin. + now rewrite <- lt_succ_r, (lt_succ_pred 0). + + rewrite <- (lt_succ_pred 0 a) at 2; trivial. apply lt_succ_diag_r. + - now rewrite <- Ha, sqrt_up_0. Qed. (** [sqrt_up] and multiplication. *) @@ -615,23 +615,23 @@ Lemma sqrt_up_mul_above : forall a b, 0<=a -> 0<=b -> √°(a*b) <= √°a * √ Proof. intros a b Ha Hb. apply sqrt_up_le_square. - now apply mul_nonneg_nonneg. - apply mul_nonneg_nonneg; apply sqrt_up_nonneg. - rewrite mul_shuffle1. - apply mul_le_mono_nonneg; trivial; now apply sqrt_sqrt_up_spec. + - now apply mul_nonneg_nonneg. + - apply mul_nonneg_nonneg; apply sqrt_up_nonneg. + - rewrite mul_shuffle1. + apply mul_le_mono_nonneg; trivial; now apply sqrt_sqrt_up_spec. Qed. Lemma sqrt_up_mul_below : forall a b, 0<a -> 0<b -> (P √°a)*(P √°b) < √°(a*b). Proof. intros a b Ha Hb. apply sqrt_up_lt_square. - apply mul_nonneg_nonneg; order. - apply mul_nonneg_nonneg; apply lt_succ_r. - rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. - rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. - rewrite mul_shuffle1. - apply mul_lt_mono_nonneg; trivial using square_nonneg; - now apply sqrt_up_spec. + - apply mul_nonneg_nonneg; order. + - apply mul_nonneg_nonneg; apply lt_succ_r. + + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. + + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. + - rewrite mul_shuffle1. + apply mul_lt_mono_nonneg; trivial using square_nonneg; + now apply sqrt_up_spec. Qed. (** And we can't find better approximations in general. @@ -650,37 +650,37 @@ Lemma sqrt_up_succ_le : forall a, 0<=a -> √°(S a) <= S (√°a). Proof. intros a Ha. apply sqrt_up_le_square. - now apply le_le_succ_r. - apply le_le_succ_r, sqrt_up_nonneg. - rewrite <- (add_1_l (√°a)). - apply le_trans with (1²+(√°a)²). - rewrite mul_1_l, add_1_l, <- succ_le_mono. - now apply sqrt_sqrt_up_spec. - apply add_square_le. order'. apply sqrt_up_nonneg. + - now apply le_le_succ_r. + - apply le_le_succ_r, sqrt_up_nonneg. + - rewrite <- (add_1_l (√°a)). + apply le_trans with (1²+(√°a)²). + + rewrite mul_1_l, add_1_l, <- succ_le_mono. + now apply sqrt_sqrt_up_spec. + + apply add_square_le. * order'. * apply sqrt_up_nonneg. Qed. Lemma sqrt_up_succ_or : forall a, 0<=a -> √°(S a) == S (√°a) \/ √°(S a) == √°a. Proof. intros a Ha. destruct (le_gt_cases (√°(S a)) (√°a)) as [H|H]. - right. generalize (sqrt_up_le_mono _ _ (le_succ_diag_r a)); order. - left. apply le_succ_l in H. generalize (sqrt_up_succ_le a Ha); order. + - right. generalize (sqrt_up_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (sqrt_up_succ_le a Ha); order. Qed. Lemma sqrt_up_eq_succ_iff_square : forall a, 0<=a -> (√°(S a) == S (√°a) <-> exists b, 0<=b /\ a == b²). Proof. intros a Ha. split. - intros EQ. - le_elim Ha. - exists (√°a). split. apply sqrt_up_nonneg. - generalize (proj2 (sqrt_up_spec a Ha)). - assert (Ha' : 0 < S a) by (apply lt_succ_r; order'). - generalize (proj1 (sqrt_up_spec (S a) Ha')). - rewrite EQ, pred_succ, lt_succ_r. order. - exists 0. nzsimpl. now split. - intros (b & Hb & H). - now rewrite H, sqrt_up_succ_square, sqrt_up_square. + - intros EQ. + le_elim Ha. + + exists (√°a). split. * apply sqrt_up_nonneg. + * generalize (proj2 (sqrt_up_spec a Ha)). + assert (Ha' : 0 < S a) by (apply lt_succ_r; order'). + generalize (proj1 (sqrt_up_spec (S a) Ha')). + rewrite EQ, pred_succ, lt_succ_r. order. + + exists 0. nzsimpl. now split. + - intros (b & Hb & H). + now rewrite H, sqrt_up_succ_square, sqrt_up_square. Qed. (** [sqrt_up] and addition *) @@ -688,21 +688,21 @@ Qed. Lemma sqrt_up_add_le : forall a b, √°(a+b) <= √°a + √°b. Proof. assert (AUX : forall a b, a<=0 -> √°(a+b) <= √°a + √°b). - intros a b Ha. rewrite (sqrt_up_eqn0 a Ha). nzsimpl. - apply sqrt_up_le_mono. - rewrite <- (add_0_l b) at 2. - apply add_le_mono_r; order. - intros a b. - destruct (le_gt_cases a 0) as [Ha|Ha]. now apply AUX. - destruct (le_gt_cases b 0) as [Hb|Hb]. - rewrite (add_comm a), (add_comm (√°a)); now apply AUX. - rewrite 2 sqrt_up_eqn; trivial. - nzsimpl. rewrite <- succ_le_mono. - transitivity (√(P a) + √b). - rewrite <- (lt_succ_pred 0 a Ha) at 1. nzsimpl. apply sqrt_add_le. - apply add_le_mono_l. - apply le_sqrt_sqrt_up. - now apply add_pos_pos. + - intros a b Ha. rewrite (sqrt_up_eqn0 a Ha). nzsimpl. + apply sqrt_up_le_mono. + rewrite <- (add_0_l b) at 2. + apply add_le_mono_r; order. + - intros a b. + destruct (le_gt_cases a 0) as [Ha|Ha]. + now apply AUX. + + destruct (le_gt_cases b 0) as [Hb|Hb]. + * rewrite (add_comm a), (add_comm (√°a)); now apply AUX. + * rewrite 2 sqrt_up_eqn; trivial. + -- nzsimpl. rewrite <- succ_le_mono. + transitivity (√(P a) + √b). + ++ rewrite <- (lt_succ_pred 0 a Ha) at 1. nzsimpl. apply sqrt_add_le. + ++ apply add_le_mono_l. + apply le_sqrt_sqrt_up. + -- now apply add_pos_pos. Qed. (** Convexity-like inequality for [sqrt_up]: [sqrt_up] of middle is above middle @@ -712,25 +712,24 @@ Qed. Lemma add_sqrt_up_le : forall a b, 0<=a -> 0<=b -> √°a + √°b <= S √°(2*(a+b)). Proof. intros a b Ha Hb. - le_elim Ha. - le_elim Hb. - rewrite 3 sqrt_up_eqn; trivial. - nzsimpl. rewrite <- 2 succ_le_mono. - etransitivity; [eapply add_sqrt_le|]. - apply lt_succ_r. now rewrite (lt_succ_pred 0 a Ha). - apply lt_succ_r. now rewrite (lt_succ_pred 0 b Hb). - apply sqrt_le_mono. - apply lt_succ_r. rewrite (lt_succ_pred 0). - apply mul_lt_mono_pos_l. order'. - apply add_lt_mono. - apply le_succ_l. now rewrite (lt_succ_pred 0). - apply le_succ_l. now rewrite (lt_succ_pred 0). - apply mul_pos_pos. order'. now apply add_pos_pos. - apply mul_pos_pos. order'. now apply add_pos_pos. - rewrite <- Hb, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. - rewrite <- (mul_1_l a) at 1. apply mul_le_mono_nonneg_r; order'. - rewrite <- Ha, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. - rewrite <- (mul_1_l b) at 1. apply mul_le_mono_nonneg_r; order'. + le_elim Ha;[le_elim Hb|]. + - rewrite 3 sqrt_up_eqn; trivial. + + nzsimpl. rewrite <- 2 succ_le_mono. + etransitivity; [eapply add_sqrt_le|]. + * apply lt_succ_r. now rewrite (lt_succ_pred 0 a Ha). + * apply lt_succ_r. now rewrite (lt_succ_pred 0 b Hb). + * apply sqrt_le_mono. + apply lt_succ_r. rewrite (lt_succ_pred 0). + -- apply mul_lt_mono_pos_l. ++ order'. + ++ apply add_lt_mono. + ** apply le_succ_l. now rewrite (lt_succ_pred 0). + ** apply le_succ_l. now rewrite (lt_succ_pred 0). + -- apply mul_pos_pos. ++ order'. ++ now apply add_pos_pos. + + apply mul_pos_pos. * order'. * now apply add_pos_pos. + - rewrite <- Hb, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. + rewrite <- (mul_1_l a) at 1. apply mul_le_mono_nonneg_r; order'. + - rewrite <- Ha, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. + rewrite <- (mul_1_l b) at 1. apply mul_le_mono_nonneg_r; order'. Qed. End NZSqrtUpProp. diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index 1c89b6c3b1..ae366204ac 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -73,10 +73,10 @@ Proof. simpl. split ; intros ; subst. - inversion H. - reflexivity. + - inversion H. + reflexivity. - pi. + - pi. Qed. (* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f] diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index f9d23e3cf6..092c1d6f48 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -97,15 +97,15 @@ Section Measure_well_founded. Proof with auto. unfold well_founded. cut (forall (a: M) (a0: T), m a0 = a -> Acc MR a0). - intros. + + intros. apply (H (m a))... - apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)). - intros. - apply Acc_intro. - intros. - unfold MR in H1. - rewrite H0 in H1. - apply (H (m y))... + + apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)). + intros. + apply Acc_intro. + intros. + unfold MR in H1. + rewrite H0 in H1. + apply (H (m y))... Defined. End Measure_well_founded. @@ -245,8 +245,8 @@ Module WfExtensionality. intros ; apply Fix_eq ; auto. intros. assert(f = g). - extensionality y ; apply H. - rewrite H0 ; auto. + - extensionality y ; apply H. + - rewrite H0 ; auto. Qed. (** Tactic to unfold once a definition based on [Fix_sub]. *) diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index e82a673445..0a60d96afc 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -45,9 +45,8 @@ Section Properties. Lemma clos_rt_is_preorder : preorder R*. Proof. apply Build_preorder. - exact (rt_refl A R). - - exact (rt_trans A R). + - exact (rt_refl A R). + - exact (rt_trans A R). Qed. (** Idempotency of the reflexive-transitive closure operator *) @@ -82,8 +81,8 @@ Section Properties. inclusion (clos_refl R) (clos_refl_trans R). Proof. induction 1 as [? ?| ]. - constructor; auto. - constructor 2. + - constructor; auto. + - constructor 2. Qed. Lemma clos_rt_t : forall x y z, @@ -100,9 +99,9 @@ Section Properties. Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans R). Proof. apply Build_equivalence. - exact (rst_refl A R). - exact (rst_trans A R). - exact (rst_sym A R). + - exact (rst_refl A R). + - exact (rst_trans A R). + - exact (rst_sym A R). Qed. (** Idempotency of the reflexive-symmetric-transitive closure operator *) @@ -130,18 +129,18 @@ Section Properties. Lemma clos_t1n_trans : forall x y, clos_trans_1n R x y -> clos_trans R x y. Proof. induction 1. - left; assumption. - right with y; auto. - left; auto. + - left; assumption. + - right with y; auto. + left; auto. Qed. Lemma clos_trans_t1n : forall x y, clos_trans R x y -> clos_trans_1n R x y. Proof. induction 1. - left; assumption. - generalize IHclos_trans2; clear IHclos_trans2; induction IHclos_trans1. - right with y; auto. - right with y; auto. + - left; assumption. + - generalize IHclos_trans2; clear IHclos_trans2; induction IHclos_trans1. + + right with y; auto. + + right with y; auto. eapply IHIHclos_trans1; auto. apply clos_t1n_trans; auto. Qed. @@ -150,8 +149,8 @@ Section Properties. clos_trans R x y <-> clos_trans_1n R x y. Proof. split. - apply clos_trans_t1n. - apply clos_t1n_trans. + - apply clos_trans_t1n. + - apply clos_t1n_trans. Qed. (** Direct transitive closure vs right-step extension *) @@ -159,29 +158,29 @@ Section Properties. Lemma clos_tn1_trans : forall x y, clos_trans_n1 R x y -> clos_trans R x y. Proof. induction 1. - left; assumption. - right with y; auto. - left; assumption. + - left; assumption. + - right with y; auto. + left; assumption. Qed. Lemma clos_trans_tn1 : forall x y, clos_trans R x y -> clos_trans_n1 R x y. Proof. induction 1. - left; assumption. - elim IHclos_trans2. - intro y0; right with y. - auto. - auto. - intros. - right with y0; auto. + - left; assumption. + - elim IHclos_trans2. + + intro y0; right with y. + * auto. + * auto. + + intros. + right with y0; auto. Qed. Lemma clos_trans_tn1_iff : forall x y, clos_trans R x y <-> clos_trans_n1 R x y. Proof. split. - apply clos_trans_tn1. - apply clos_tn1_trans. + - apply clos_trans_tn1. + - apply clos_tn1_trans. Qed. (** Direct reflexive-transitive closure is equivalent to @@ -203,31 +202,31 @@ Section Properties. clos_refl_trans_1n R x y -> clos_refl_trans R x y. Proof. induction 1. - constructor 2. - constructor 3 with y; auto. - constructor 1; auto. + - constructor 2. + - constructor 3 with y; auto. + constructor 1; auto. Qed. Lemma clos_rt_rt1n : forall x y, clos_refl_trans R x y -> clos_refl_trans_1n R x y. Proof. induction 1. - apply clos_rt1n_step; assumption. - left. - generalize IHclos_refl_trans2; clear IHclos_refl_trans2; - induction IHclos_refl_trans1; auto. + - apply clos_rt1n_step; assumption. + - left. + - generalize IHclos_refl_trans2; clear IHclos_refl_trans2; + induction IHclos_refl_trans1; auto. - right with y; auto. - eapply IHIHclos_refl_trans1; auto. - apply clos_rt1n_rt; auto. + right with y; auto. + eapply IHIHclos_refl_trans1; auto. + apply clos_rt1n_rt; auto. Qed. Lemma clos_rt_rt1n_iff : forall x y, clos_refl_trans R x y <-> clos_refl_trans_1n R x y. Proof. split. - apply clos_rt_rt1n. - apply clos_rt1n_rt. + - apply clos_rt_rt1n. + - apply clos_rt1n_rt. Qed. (** Direct reflexive-transitive closure is equivalent to @@ -237,28 +236,28 @@ Section Properties. clos_refl_trans_n1 R x y -> clos_refl_trans R x y. Proof. induction 1. - constructor 2. - constructor 3 with y; auto. - constructor 1; assumption. + - constructor 2. + - constructor 3 with y; auto. + constructor 1; assumption. Qed. Lemma clos_rt_rtn1 : forall x y, clos_refl_trans R x y -> clos_refl_trans_n1 R x y. Proof. induction 1. - apply clos_rtn1_step; auto. - left. - elim IHclos_refl_trans2; auto. - intros. - right with y0; auto. + - apply clos_rtn1_step; auto. + - left. + - elim IHclos_refl_trans2; auto. + intros. + right with y0; auto. Qed. Lemma clos_rt_rtn1_iff : forall x y, clos_refl_trans R x y <-> clos_refl_trans_n1 R x y. Proof. split. - apply clos_rt_rtn1. - apply clos_rtn1_rt. + - apply clos_rt_rtn1. + - apply clos_rtn1_rt. Qed. (** Induction on the left transitive step *) @@ -271,14 +270,14 @@ Section Properties. intros. revert H H0. induction H1; intros; auto with sets. - apply H1 with x; auto with sets. + - apply H1 with x; auto with sets. - apply IHclos_refl_trans2. - apply IHclos_refl_trans1; auto with sets. + - apply IHclos_refl_trans2. + + apply IHclos_refl_trans1; auto with sets. - intros. - apply H0 with y0; auto with sets. - apply rt_trans with y; auto with sets. + + intros. + apply H0 with y0; auto with sets. + apply rt_trans with y; auto with sets. Qed. (** Induction on the right transitive step *) @@ -311,45 +310,45 @@ Section Properties. clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans R x y. Proof. induction 1. - constructor 2. - constructor 4 with y; auto. - case H;[constructor 1|constructor 3; constructor 1]; auto. + - constructor 2. + - constructor 4 with y; auto. + case H;[constructor 1|constructor 3; constructor 1]; auto. Qed. Lemma clos_rst1n_trans : forall x y z, clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans_1n R y z -> clos_refl_sym_trans_1n R x z. induction 1. - auto. - intros; right with y; eauto. + - auto. + - intros; right with y; eauto. Qed. Lemma clos_rst1n_sym : forall x y, clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans_1n R y x. Proof. intros x y H; elim H. - constructor 1. - intros x0 y0 z D H0 H1; apply clos_rst1n_trans with y0; auto. - right with x0. - tauto. - left. + - constructor 1. + - intros x0 y0 z D H0 H1; apply clos_rst1n_trans with y0; auto. + right with x0. + + tauto. + + left. Qed. Lemma clos_rst_rst1n : forall x y, clos_refl_sym_trans R x y -> clos_refl_sym_trans_1n R x y. induction 1. - constructor 2 with y; auto. - constructor 1. - constructor 1. - apply clos_rst1n_sym; auto. - eapply clos_rst1n_trans; eauto. + - constructor 2 with y; auto. + constructor 1. + - constructor 1. + - apply clos_rst1n_sym; auto. + - eapply clos_rst1n_trans; eauto. Qed. Lemma clos_rst_rst1n_iff : forall x y, clos_refl_sym_trans R x y <-> clos_refl_sym_trans_1n R x y. Proof. split. - apply clos_rst_rst1n. - apply clos_rst1n_rst. + - apply clos_rst_rst1n. + - apply clos_rst1n_rst. Qed. (** Direct reflexive-symmetric-transitive closure is equivalent to @@ -359,9 +358,9 @@ Section Properties. clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans R x y. Proof. induction 1. - constructor 2. - constructor 4 with y; auto. - case H;[constructor 1|constructor 3; constructor 1]; auto. + - constructor 2. + - constructor 4 with y; auto. + case H;[constructor 1|constructor 3; constructor 1]; auto. Qed. Lemma clos_rstn1_trans : forall x y z, clos_refl_sym_trans_n1 R x y -> @@ -369,39 +368,39 @@ Section Properties. Proof. intros x y z H1 H2. induction H2. - auto. - intros. - right with y0; eauto. + - auto. + - intros. + right with y0; eauto. Qed. Lemma clos_rstn1_sym : forall x y, clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans_n1 R y x. Proof. intros x y H; elim H. - constructor 1. - intros y0 z D H0 H1. apply clos_rstn1_trans with y0; auto. - right with z. - tauto. - left. + - constructor 1. + - intros y0 z D H0 H1. apply clos_rstn1_trans with y0; auto. + right with z. + + tauto. + + left. Qed. Lemma clos_rst_rstn1 : forall x y, clos_refl_sym_trans R x y -> clos_refl_sym_trans_n1 R x y. Proof. induction 1. - constructor 2 with x; auto. - constructor 1. - constructor 1. - apply clos_rstn1_sym; auto. - eapply clos_rstn1_trans; eauto. + - constructor 2 with x; auto. + constructor 1. + - constructor 1. + - apply clos_rstn1_sym; auto. + - eapply clos_rstn1_trans; eauto. Qed. Lemma clos_rst_rstn1_iff : forall x y, clos_refl_sym_trans R x y <-> clos_refl_sym_trans_n1 R x y. Proof. split. - apply clos_rst_rstn1. - apply clos_rstn1_rst. + - apply clos_rst_rstn1. + - apply clos_rstn1_rst. Qed. End Equivalences. diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v index f2475af124..862c3238e7 100644 --- a/theories/Sets/Constructive_sets.v +++ b/theories/Sets/Constructive_sets.v @@ -103,8 +103,8 @@ Section Ensembles_facts. forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y. Proof. intros A x y H'; induction H'. - left; assumption. - right; apply Singleton_inv; assumption. + - left; assumption. + - right; apply Singleton_inv; assumption. Qed. Lemma Intersection_inv : diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 5b51c7b953..811e42f091 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -71,11 +71,11 @@ Section Partial_order_facts. elim D; simpl. intros C R H' H'0; elim H'0. intros H'1 H'2 H'3 x y z H'4 H'5; split. - apply H'2 with (y := y); tauto. - red; intro H'6. - elim H'4; intros H'7 H'8; apply H'8; clear H'4. - apply H'3; auto. - rewrite H'6; tauto. + - apply H'2 with (y := y); tauto. + - red; intro H'6. + elim H'4; intros H'7 H'8; apply H'8; clear H'4. + apply H'3; auto. + rewrite H'6; tauto. Qed. Lemma Strict_Rel_Transitive_with_Rel_left : @@ -87,11 +87,11 @@ Section Partial_order_facts. elim D; simpl. intros C R H' H'0; elim H'0. intros H'1 H'2 H'3 x y z H'4 H'5; split. - apply H'2 with (y := y); tauto. - red; intro H'6. - elim H'5; intros H'7 H'8; apply H'8; clear H'5. - apply H'3; auto. - rewrite <- H'6; auto. + - apply H'2 with (y := y); tauto. + - red; intro H'6. + elim H'5; intros H'7 H'8; apply H'8; clear H'5. + apply H'3; auto. + rewrite <- H'6; auto. Qed. Lemma Strict_Rel_Transitive : Transitive U (Strict_Rel_of U D). diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v index 86a500dfdd..5cd9f52c6b 100644 --- a/theories/Sets/Permut.v +++ b/theories/Sets/Permut.v @@ -33,8 +33,8 @@ Section Axiomatisation. forall x y z t:U, cong x y -> cong z t -> cong (op x z) (op y t). Proof. intros; apply cong_trans with (op y z). - apply cong_left; trivial. - apply cong_right; trivial. + - apply cong_left; trivial. + - apply cong_right; trivial. Qed. Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)). @@ -51,27 +51,27 @@ Section Axiomatisation. Proof. intros. apply cong_trans with (op x (op y z)). - apply op_ass. - apply cong_trans with (op x (op z y)). - apply cong_right; apply op_comm. - apply cong_sym; apply op_ass. + - apply op_ass. + - apply cong_trans with (op x (op z y)). + + apply cong_right; apply op_comm. + + apply cong_sym; apply op_ass. Qed. Lemma perm_left : forall x y z:U, cong (op x (op y z)) (op y (op x z)). Proof. intros. apply cong_trans with (op (op x y) z). - apply cong_sym; apply op_ass. - apply cong_trans with (op (op y x) z). - apply cong_left; apply op_comm. - apply op_ass. + - apply cong_sym; apply op_ass. + - apply cong_trans with (op (op y x) z). + + apply cong_left; apply op_comm. + + apply op_ass. Qed. Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)). Proof. intros; apply cong_trans with (op (op x y) z). - apply cong_sym; apply op_ass. - apply op_comm. + - apply cong_sym; apply op_ass. + - apply op_comm. Qed. (** Needed for treesort ... *) @@ -80,10 +80,10 @@ Section Axiomatisation. Proof. intros. apply cong_trans with (op x (op (op y t) z)). - apply cong_right; apply perm_right. - apply cong_trans with (op (op x (op y t)) z). - apply cong_sym; apply op_ass. - apply cong_left; apply perm_left. + - apply cong_right; apply perm_right. + - apply cong_trans with (op (op x (op y t)) z). + + apply cong_sym; apply op_ass. + + apply cong_left; apply perm_left. Qed. End Axiomatisation. diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index 50a7e401f8..5b352f05fa 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -154,9 +154,9 @@ Theorem Union_is_Lub : Lub (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Union U a b). intros A a b H' H'0. apply Lub_definition; simpl. -apply Upper_Bound_definition; simpl; auto with sets. -intros y H'1; elim H'1; auto with sets. -intros y H'1; elim H'1; simpl; auto with sets. +- apply Upper_Bound_definition; simpl; auto with sets. + intros y H'1; elim H'1; auto with sets. +- intros y H'1; elim H'1; simpl; auto with sets. Qed. Theorem Intersection_is_Glb : @@ -167,12 +167,12 @@ Theorem Intersection_is_Glb : (Intersection U a b). intros A a b H' H'0. apply Glb_definition; simpl. -apply Lower_Bound_definition; simpl; auto with sets. -apply Definition_of_Power_set. -generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a; - auto with sets. -intros y H'1; elim H'1; auto with sets. -intros y H'1; elim H'1; simpl; auto with sets. +- apply Lower_Bound_definition; simpl; auto with sets. + + apply Definition_of_Power_set. + generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a; + auto with sets. + + intros y H'1; elim H'1; auto with sets. +- intros y H'1; elim H'1; simpl; auto with sets. Qed. End The_power_set_partial_order. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index 81b475ac6e..784f2ce0ff 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -84,8 +84,8 @@ Section Sets_as_an_algebra. forall x y:U, Union U (Singleton U x) (Singleton U y) = Couple U x y. Proof. intros x y; apply Extensionality_Ensembles; split; red. - intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets). - intros x0 H'; elim H'; auto with sets. + - intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets). + - intros x0 H'; elim H'; auto with sets. Qed. Theorem Triple_as_union : @@ -94,10 +94,10 @@ Section Sets_as_an_algebra. Triple U x y z. Proof. intros x y z; apply Extensionality_Ensembles; split; red. - intros x0 H'; elim H'. - intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets). - intros x1 H'0; elim H'0; auto with sets. - intros x0 H'; elim H'; auto with sets. + - intros x0 H'; elim H'. + + intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets). + + intros x1 H'0; elim H'0; auto with sets. + - intros x0 H'; elim H'; auto with sets. Qed. Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y. @@ -132,10 +132,10 @@ Section Sets_as_an_algebra. intros A B C. apply Extensionality_Ensembles. split; red; intros x H'. - elim H'. - intros x0 H'0 H'1; generalize H'0. - elim H'1; auto with sets. - elim H'; intros x0 H'0; elim H'0; auto with sets. + - elim H'. + intros x0 H'0 H'1; generalize H'0. + elim H'1; auto with sets. + - elim H'; intros x0 H'0; elim H'0; auto with sets. Qed. Lemma Distributivity_l @@ -157,13 +157,13 @@ Section Sets_as_an_algebra. intros A B C. apply Extensionality_Ensembles. split; red; intros x H'. - elim H'; auto with sets. - intros x0 H'0; elim H'0; auto with sets. - elim H'. - intros x0 H'0; elim H'0; auto with sets. - intros x1 H'1 H'2; try exact H'2. - generalize H'1. - elim H'2; auto with sets. + - elim H'; auto with sets. + intros x0 H'0; elim H'0; auto with sets. + - elim H'. + intros x0 H'0; elim H'0; auto with sets. + intros x1 H'1 H'2; try exact H'2. + generalize H'1. + elim H'2; auto with sets. Qed. Theorem Union_add : @@ -188,11 +188,11 @@ Section Sets_as_an_algebra. intros X x H'; unfold Subtract. apply Extensionality_Ensembles. split; red; auto with sets. - intros x0 H'0; elim H'0; auto with sets. - intros x0 H'0; apply Setminus_intro; auto with sets. - red; intro H'1; elim H'1. - lapply (Singleton_inv U x x0); auto with sets. - intro H'4; apply H'; rewrite H'4; auto with sets. + - intros x0 H'0; elim H'0; auto with sets. + - intros x0 H'0; apply Setminus_intro; auto with sets. + red; intro H'1; elim H'1. + lapply (Singleton_inv U x x0); auto with sets. + intro H'4; apply H'; rewrite H'4; auto with sets. Qed. Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y. @@ -320,7 +320,9 @@ Section Sets_as_an_algebra. Setminus A s1 (Union A s2 s3) = Setminus A (Setminus A s1 s2) s3. Proof. intros. apply Extensionality_Ensembles. split. - * intros x H. inversion H. constructor. intuition. contradict H1. intuition. + * intros x H. inversion H. constructor. + -- intuition. + -- contradict H1. intuition. * intros x H. inversion H. inversion H0. constructor; intuition. inversion H4; intuition. Qed. diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index d275487e15..17bdefcdbf 100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -45,12 +45,12 @@ Theorem Equiv_from_preorder : Proof. intros U R H'; elim H'; intros H'0 H'1. apply Definition_of_equivalence. -red in H'0; auto 10 with sets. -2: red; intros x y h; elim h; intros H'3 H'4; auto 10 with sets. -red in H'1; red; auto 10 with sets. -intros x y z h; elim h; intros H'3 H'4; clear h. -intro h; elim h; intros H'5 H'6; clear h. -split; apply H'1 with y; auto 10 with sets. +- red in H'0; auto 10 with sets. +- red in H'1; red; auto 10 with sets. + intros x y z h; elim h; intros H'3 H'4; clear h. + intro h; elim h; intros H'5 H'6; clear h. + split; apply H'1 with y; auto 10 with sets. +- red; intros x y h; elim h; intros H'3 H'4; auto 10 with sets. Qed. Hint Resolve Equiv_from_preorder : core. diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v index 36da368447..48d0ea55c9 100644 --- a/theories/Sets/Relations_2_facts.v +++ b/theories/Sets/Relations_2_facts.v @@ -53,8 +53,8 @@ Theorem Rstar_contains_Rplus : Proof. intros U R; red. intros x y H'; elim H'. -generalize Rstar_contains_R; intro T; red in T; auto with sets. -intros x0 y0 z H'0 H'1 H'2; apply Rstar_n with y0; auto with sets. +- generalize Rstar_contains_R; intro T; red in T; auto with sets. +- intros x0 y0 z H'0 H'1 H'2; apply Rstar_n with y0; auto with sets. Qed. Theorem Rstar_transitive : @@ -79,9 +79,9 @@ Proof. generalize Rstar_contains_R; intro T; red in T. intros U R; unfold same_relation, contains. split; intros x y H'; elim H'; auto with sets. -generalize Rstar_transitive; intro T1; red in T1. -intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets. -intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets. +- generalize Rstar_transitive; intro T1; red in T1. + intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets. +- intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets. Qed. Theorem Rsym_imp_Rstarsym : @@ -121,12 +121,12 @@ Proof. generalize Rstar_contains_Rplus; intro T; red in T. generalize Rstar_transitive; intro T1; red in T1. intros U R x y z H'; elim H'. -intros x0 H'0; elim H'0. -intros x1 y0 H'1; exists y0; auto with sets. -intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets. -intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0. -split; [ try assumption | idtac ]. -apply T1 with z0; auto with sets. +- intros x0 H'0; elim H'0. + + intros x1 y0 H'1; exists y0; auto with sets. + + intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets. +- intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0. + split; [ try assumption | idtac ]. + apply T1 with z0; auto with sets. Qed. Theorem Lemma1 : @@ -137,17 +137,17 @@ Theorem Lemma1 : forall a:U, R x a -> exists z : _, Rstar U R a z /\ R b z. Proof. intros U R H' x b H'0; elim H'0. -intros x0 a H'1; exists a; auto with sets. -intros x0 y z H'1 H'2 H'3 a H'4. -red in H'. -specialize H' with (x := x0) (a := a) (b := y); lapply H'; - [ intro H'8; lapply H'8; - [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ] - | clear H' ]; auto with sets. -elim H'9. -intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5. -elim (H'3 t); auto with sets. -intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5. -exists z1; split; [ idtac | assumption ]. -apply Rstar_n with t; auto with sets. +- intros x0 a H'1; exists a; auto with sets. +- intros x0 y z H'1 H'2 H'3 a H'4. + red in H'. + specialize H' with (x := x0) (a := a) (b := y); lapply H'; + [ intro H'8; lapply H'8; + [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ] + | clear H' ]; auto with sets. + elim H'9. + intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5. + elim (H'3 t); auto with sets. + intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5. + exists z1; split; [ idtac | assumption ]. + apply Rstar_n with t; auto with sets. Qed. diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index 18ea019526..a4806ea0a6 100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -57,21 +57,21 @@ intro x; red; intros a b H'0. unfold coherent at 1. generalize b; clear b. elim H'0; clear H'0. -intros x0 b H'1; exists b; auto with sets. -intros x0 y z H'1 H'2 H'3 b H'4. -generalize (Lemma1 U R); intro h; lapply h; - [ intro H'0; generalize (H'0 x0 b); intro h0; lapply h0; - [ intro H'5; generalize (H'5 y); intro h1; lapply h1; - [ intro h2; elim h2; intros z0 h3; elim h3; intros H'6 H'7; +- intros x0 b H'1; exists b; auto with sets. +- intros x0 y z H'1 H'2 H'3 b H'4. + generalize (Lemma1 U R); intro h; lapply h; + [ intro H'0; generalize (H'0 x0 b); intro h0; lapply h0; + [ intro H'5; generalize (H'5 y); intro h1; lapply h1; + [ intro h2; elim h2; intros z0 h3; elim h3; intros H'6 H'7; clear h h0 h1 h2 h3 - | clear h h0 h1 ] - | clear h h0 ] - | clear h ]; auto with sets. -generalize (H'3 z0); intro h; lapply h; - [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h h0 h1 - | clear h ]; auto with sets. -exists z1; split; auto with sets. -apply Rstar_n with z0; auto with sets. + | clear h h0 h1 ] + | clear h h0 ] + | clear h ]; auto with sets. + generalize (H'3 z0); intro h; lapply h; + [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h h0 h1 + | clear h ]; auto with sets. + exists z1; split; auto with sets. + apply Rstar_n with z0; auto with sets. Qed. Theorem Strong_confluence_direct : @@ -82,31 +82,31 @@ intro x; red; intros a b H'0. unfold coherent at 1. generalize b; clear b. elim H'0; clear H'0. -intros x0 b H'1; exists b; auto with sets. -intros x0 y z H'1 H'2 H'3 b H'4. -cut (ex (fun t:U => Rstar U R y t /\ R b t)). -intro h; elim h; intros t h0; elim h0; intros H'0 H'5; clear h h0. -generalize (H'3 t); intro h; lapply h; - [ intro h0; elim h0; intros z0 h1; elim h1; intros H'6 H'7; clear h h0 h1 - | clear h ]; auto with sets. -exists z0; split; [ assumption | idtac ]. -apply Rstar_n with t; auto with sets. -generalize H'1; generalize y; clear H'1. -elim H'4. -intros x1 y0 H'0; exists y0; auto with sets. -intros x1 y0 z0 H'0 H'1 H'5 y1 H'6. -red in H'. -generalize (H' x1 y0 y1); intro h; lapply h; - [ intro H'7; lapply H'7; - [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; - clear h H'7 h0 h1 - | clear h ] - | clear h ]; auto with sets. -generalize (H'5 z1); intro h; lapply h; - [ intro h0; elim h0; intros t h1; elim h1; intros H'7 H'10; clear h h0 h1 - | clear h ]; auto with sets. -exists t; split; auto with sets. -apply Rstar_n with z1; auto with sets. +- intros x0 b H'1; exists b; auto with sets. +- intros x0 y z H'1 H'2 H'3 b H'4. + cut (ex (fun t:U => Rstar U R y t /\ R b t)). + + intro h; elim h; intros t h0; elim h0; intros H'0 H'5; clear h h0. + generalize (H'3 t); intro h; lapply h; + [ intro h0; elim h0; intros z0 h1; elim h1; intros H'6 H'7; clear h h0 h1 + | clear h ]; auto with sets. + exists z0; split; [ assumption | idtac ]. + apply Rstar_n with t; auto with sets. + + generalize H'1; generalize y; clear H'1. + elim H'4. + * intros x1 y0 H'0; exists y0; auto with sets. + * intros x1 y0 z0 H'0 H'1 H'5 y1 H'6. + red in H'. + generalize (H' x1 y0 y1); intro h; lapply h; + [ intro H'7; lapply H'7; + [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; + clear h H'7 h0 h1 + | clear h ] + | clear h ]; auto with sets. + generalize (H'5 z1); intro h; lapply h; + [ intro h0; elim h0; intros t h1; elim h1; intros H'7 H'10; clear h h0 h1 + | clear h ]; auto with sets. + exists t; split; auto with sets. + apply Rstar_n with z1; auto with sets. Qed. Theorem Noetherian_contains_Noetherian : @@ -131,41 +131,41 @@ generalize (Rstar_cases U R x0 y); intro h; lapply h; | intro h1; elim h1; intros u h2; elim h2; intros H'5 H'6; clear h h0 h1 h2 ] | clear h ]; auto with sets. -elim h1; auto with sets. -generalize (Rstar_cases U R x0 z); intro h; lapply h; - [ intro h0; elim h0; - [ clear h h0; intro h1 - | intro h1; elim h1; intros v h2; elim h2; intros H'7 H'8; - clear h h0 h1 h2 ] - | clear h ]; auto with sets. -elim h1; generalize coherent_symmetric; intro t; red in t; auto with sets. -unfold Locally_confluent, locally_confluent, coherent in H'0. -generalize (H'0 x0 u v); intro h; lapply h; - [ intro H'9; lapply H'9; - [ intro h0; elim h0; intros t h1; elim h1; intros H'10 H'11; - clear h H'9 h0 h1 - | clear h ] - | clear h ]; auto with sets. -clear H'0. -unfold coherent at 1 in H'2. -generalize (H'2 u); intro h; lapply h; - [ intro H'0; generalize (H'0 y t); intro h0; lapply h0; - [ intro H'9; lapply H'9; - [ intro h1; elim h1; intros y1 h2; elim h2; intros H'12 H'13; - clear h h0 H'9 h1 h2 - | clear h h0 ] - | clear h h0 ] - | clear h ]; auto with sets. -generalize Rstar_transitive; intro T; red in T. -generalize (H'2 v); intro h; lapply h; - [ intro H'9; generalize (H'9 y1 z); intro h0; lapply h0; - [ intro H'14; lapply H'14; - [ intro h1; elim h1; intros z1 h2; elim h2; intros H'15 H'16; - clear h h0 H'14 h1 h2 - | clear h h0 ] - | clear h h0 ] - | clear h ]; auto with sets. -red; (exists z1; split); auto with sets. -apply T with y1; auto with sets. -apply T with t; auto with sets. +- elim h1; auto with sets. +- generalize (Rstar_cases U R x0 z); intro h; lapply h; + [ intro h0; elim h0; + [ clear h h0; intro h1 + | intro h1; elim h1; intros v h2; elim h2; intros H'7 H'8; + clear h h0 h1 h2 ] + | clear h ]; auto with sets. + + elim h1; generalize coherent_symmetric; intro t; red in t; auto with sets. + + unfold Locally_confluent, locally_confluent, coherent in H'0. + generalize (H'0 x0 u v); intro h; lapply h; + [ intro H'9; lapply H'9; + [ intro h0; elim h0; intros t h1; elim h1; intros H'10 H'11; + clear h H'9 h0 h1 + | clear h ] + | clear h ]; auto with sets. + clear H'0. + unfold coherent at 1 in H'2. + generalize (H'2 u); intro h; lapply h; + [ intro H'0; generalize (H'0 y t); intro h0; lapply h0; + [ intro H'9; lapply H'9; + [ intro h1; elim h1; intros y1 h2; elim h2; intros H'12 H'13; + clear h h0 H'9 h1 h2 + | clear h h0 ] + | clear h h0 ] + | clear h ]; auto with sets. + generalize Rstar_transitive; intro T; red in T. + generalize (H'2 v); intro h; lapply h; + [ intro H'9; generalize (H'9 y1 z); intro h0; lapply h0; + [ intro H'14; lapply H'14; + [ intro h1; elim h1; intros z1 h2; elim h2; intros H'15 H'16; + clear h h0 H'14 h1 h2 + | clear h h0 ] + | clear h h0 ] + | clear h ]; auto with sets. + * red; (exists z1; split); auto with sets. + apply T with y1; auto with sets. + * apply T with t; auto with sets. Qed. diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 0ff304ed6b..edfffe6ce9 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -174,8 +174,8 @@ Lemma uniset_twist2 : seq (union x (union (union y z) t)) (union (union y (union x z)) t). Proof. intros; apply seq_trans with (union (union x (union y z)) t). -apply seq_sym; apply union_ass. -apply seq_left; apply union_perm_left. +- apply seq_sym; apply union_ass. +- apply seq_left; apply union_perm_left. Qed. (** specific for treesort *) @@ -186,8 +186,8 @@ Lemma treesort_twist1 : seq (union x (union u t)) (union (union y (union x t)) z). Proof. intros; apply seq_trans with (union x (union (union y z) t)). -apply seq_right; apply seq_left; trivial. -apply uniset_twist1. +- apply seq_right; apply seq_left; trivial. +- apply uniset_twist1. Qed. Lemma treesort_twist2 : @@ -196,8 +196,8 @@ Lemma treesort_twist2 : seq (union x (union u t)) (union (union y (union x z)) t). Proof. intros; apply seq_trans with (union x (union (union y z) t)). -apply seq_right; apply seq_left; trivial. -apply uniset_twist2. +- apply seq_right; apply seq_left; trivial. +- apply uniset_twist2. Qed. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index 4143dba547..346c300ee5 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -158,8 +158,10 @@ Module HasEqDec2Bool (E:Eq)(F:HasEqDec E) <: HasEqBool E. Lemma eqb_eq : forall x y, eqb x y = true <-> E.eq x y. Proof. intros x y. unfold eqb. destruct F.eq_dec as [EQ|NEQ]. - auto with *. - split. discriminate. intro EQ; elim NEQ; auto. + - auto with *. + - split. + + discriminate. + + intro EQ; elim NEQ; auto. Qed. End HasEqDec2Bool. @@ -168,8 +170,8 @@ Module HasEqBool2Dec (E:Eq)(F:HasEqBool E) <: HasEqDec E. Proof. intros x y. assert (H:=F.eqb_eq x y). destruct (F.eqb x y); [left|right]. - apply -> H; auto. - intro EQ. apply H in EQ. discriminate. + - apply -> H; auto. + - intro EQ. apply H in EQ. discriminate. Defined. End HasEqBool2Dec. diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v index 4d04667c01..c314f3f982 100644 --- a/theories/Structures/GenericMinMax.v +++ b/theories/Structures/GenericMinMax.v @@ -47,8 +47,8 @@ Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O. intros H H'. apply (StrictOrder_Irreflexive x). rewrite le_lteq in *; destruct H as [H|H]. - transitivity y; auto. - rewrite H in H'; auto. + - transitivity y; auto. + - rewrite H in H'; auto. Qed. Lemma max_l x y : y<=x -> max x y == x. @@ -142,8 +142,8 @@ Proof. intros Eqf Lef x y. destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - assert (f x <= f y) by (apply Lef; order). order. - assert (f y <= f x) by (apply Lef; order). order. + - assert (f x <= f y) by (apply Lef; order). order. + - assert (f y <= f x) by (apply Lef; order). order. Qed. (** *** Semi-lattice algebraic properties of [max] *) @@ -194,7 +194,11 @@ Proof. Qed. Lemma max_le_iff n m p : p <= max n m <-> p <= n \/ p <= m. -Proof. split. apply max_le. solve_max. Qed. +Proof. + split. + - apply max_le. + - solve_max. +Qed. Lemma max_lt_iff n m p : p < max n m <-> p < n \/ p < m. Proof. @@ -282,8 +286,8 @@ Proof. intros Eqf Lef x y. destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - assert (f x <= f y) by (apply Lef; order). order. - assert (f y <= f x) by (apply Lef; order). order. + - assert (f x <= f y) by (apply Lef; order). order. + - assert (f y <= f x) by (apply Lef; order). order. Qed. Lemma min_id n : min n n == n. @@ -330,7 +334,11 @@ Proof. Qed. Lemma min_le_iff n m p : min n m <= p <-> n <= p \/ m <= p. -Proof. split. apply min_le. solve_min. Qed. +Proof. + split. + - apply min_le. + - solve_min. +Qed. Lemma min_lt_iff n m p : min n m < p <-> n < p \/ m < p. Proof. @@ -377,16 +385,16 @@ Lemma min_max_absorption n m : max n (min n m) == n. Proof. intros. destruct (min_spec n m) as [(C,E)|(C,E)]; rewrite E. - apply max_l. order. - destruct (max_spec n m); intuition; order. + - apply max_l. order. + - destruct (max_spec n m); intuition; order. Qed. Lemma max_min_absorption n m : min n (max n m) == n. Proof. intros. destruct (max_spec n m) as [(C,E)|(C,E)]; rewrite E. - destruct (min_spec n m) as [(C',E')|(C',E')]; auto. order. - apply min_l; auto. order. + - destruct (min_spec n m) as [(C',E')|(C',E')]; auto. order. + - apply min_l; auto. order. Qed. (** Distributivity *) @@ -395,16 +403,16 @@ Lemma max_min_distr n m p : max n (min m p) == min (max n m) (max n p). Proof. symmetry. apply min_mono. - eauto with *. - repeat red; intros. apply max_le_compat_l; auto. + - eauto with *. + - repeat red; intros. apply max_le_compat_l; auto. Qed. Lemma min_max_distr n m p : min n (max m p) == max (min n m) (min n p). Proof. symmetry. apply max_mono. - eauto with *. - repeat red; intros. apply min_le_compat_l; auto. + - eauto with *. + - repeat red; intros. apply min_le_compat_l; auto. Qed. (** Modularity *) @@ -415,8 +423,8 @@ Proof. rewrite <- max_min_distr. destruct (max_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. destruct (min_spec m n) as [(C',E')|(C',E')]; rewrite E'. - rewrite 2 max_l; try order. rewrite min_le_iff; auto. - rewrite 2 max_l; try order. rewrite min_le_iff; auto. + - rewrite 2 max_l; try order. rewrite min_le_iff; auto. + - rewrite 2 max_l; try order. rewrite min_le_iff; auto. Qed. Lemma min_max_modular n m p : @@ -425,8 +433,8 @@ Proof. intros. rewrite <- min_max_distr. destruct (min_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. destruct (max_spec m n) as [(C',E')|(C',E')]; rewrite E'. - rewrite 2 min_l; try order. rewrite max_le_iff; right; order. - rewrite 2 min_l; try order. rewrite max_le_iff; auto. + - rewrite 2 min_l; try order. rewrite max_le_iff; right; order. + - rewrite 2 min_l; try order. rewrite max_le_iff; auto. Qed. (** Disassociativity *) @@ -448,8 +456,8 @@ Proof. intros Eqf Lef x y. destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - assert (f y <= f x) by (apply Lef; order). order. - assert (f x <= f y) by (apply Lef; order). order. + - assert (f y <= f x) by (apply Lef; order). order. + - assert (f x <= f y) by (apply Lef; order). order. Qed. Lemma min_max_antimono f : @@ -460,8 +468,8 @@ Proof. intros Eqf Lef x y. destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - assert (f y <= f x) by (apply Lef; order). order. - assert (f x <= f y) by (apply Lef; order). order. + - assert (f y <= f x) by (apply Lef; order). order. + - assert (f x <= f y) by (apply Lef; order). order. Qed. End MinMaxLogicalProperties. @@ -479,12 +487,12 @@ Lemma max_case_strong n m (P:t -> Type) : Proof. intros Compat Hl Hr. destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. -assert (n<=m) by (rewrite le_lteq; auto). -apply (Compat m), Hr; auto. symmetry; apply max_r; auto. -assert (n<=m) by (rewrite le_lteq; auto). -apply (Compat m), Hr; auto. symmetry; apply max_r; auto. -assert (m<=n) by (rewrite le_lteq; auto). -apply (Compat n), Hl; auto. symmetry; apply max_l; auto. +- assert (n<=m) by (rewrite le_lteq; auto). + apply (Compat m), Hr; auto. symmetry; apply max_r; auto. +- assert (n<=m) by (rewrite le_lteq; auto). + apply (Compat m), Hr; auto. symmetry; apply max_r; auto. +- assert (m<=n) by (rewrite le_lteq; auto). + apply (Compat n), Hl; auto. symmetry; apply max_l; auto. Defined. Lemma max_case n m (P:t -> Type) : @@ -508,12 +516,12 @@ Lemma min_case_strong n m (P:O.t -> Type) : Proof. intros Compat Hl Hr. destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. -assert (n<=m) by (rewrite le_lteq; auto). -apply (Compat n), Hl; auto. symmetry; apply min_l; auto. -assert (n<=m) by (rewrite le_lteq; auto). -apply (Compat n), Hl; auto. symmetry; apply min_l; auto. -assert (m<=n) by (rewrite le_lteq; auto). -apply (Compat m), Hr; auto. symmetry; apply min_r; auto. +- assert (n<=m) by (rewrite le_lteq; auto). + apply (Compat n), Hl; auto. symmetry; apply min_l; auto. +- assert (n<=m) by (rewrite le_lteq; auto). + apply (Compat n), Hl; auto. symmetry; apply min_l; auto. +- assert (m<=n) by (rewrite le_lteq; auto). + apply (Compat m), Hr; auto. symmetry; apply min_r; auto. Defined. Lemma min_case n m (P:O.t -> Type) : @@ -624,11 +632,11 @@ Module TOMaxEqDec_to_Compare Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). Proof. intros; unfold compare; repeat destruct eq_dec; auto; constructor. - destruct (lt_total x y); auto. - absurd (x==y); auto. transitivity (max x y); auto. - symmetry. apply max_l. rewrite le_lteq; intuition. - destruct (lt_total y x); auto. - absurd (max x y == y); auto. apply max_r; rewrite le_lteq; intuition. + - destruct (lt_total x y); auto. + absurd (x==y); auto. transitivity (max x y); auto. + symmetry. apply max_l. rewrite le_lteq; intuition. + - destruct (lt_total y x); auto. + absurd (max x y == y); auto. apply max_r; rewrite le_lteq; intuition. Qed. End TOMaxEqDec_to_Compare. diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v index 310a22a0a4..7fcf517457 100644 --- a/theories/Structures/Orders.v +++ b/theories/Structures/Orders.v @@ -143,8 +143,8 @@ Module Compare2EqBool (Import O:DecStrOrder') <: HasEqBool O. Proof. unfold eqb. intros x y. destruct (compare_spec x y) as [H|H|H]; split; auto; try discriminate. - intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). - intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). + - intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). + - intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). Qed. End Compare2EqBool. @@ -252,9 +252,11 @@ Module OTF_to_TTLB (Import O : OrderedTypeFull') <: TotalTransitiveLeBool. Proof. intros. unfold leb. rewrite le_lteq. destruct (compare_spec x y) as [EQ|LT|GT]; split; auto. - discriminate. - intros LE. elim (StrictOrder_Irreflexive x). - destruct LE as [LT|EQ]. now transitivity y. now rewrite <- EQ in GT. + - discriminate. + - intros LE. elim (StrictOrder_Irreflexive x). + destruct LE as [LT|EQ]. + + now transitivity y. + + now rewrite <- EQ in GT. Qed. Lemma leb_total : forall x y, leb x y \/ leb y x. @@ -267,10 +269,10 @@ Module OTF_to_TTLB (Import O : OrderedTypeFull') <: TotalTransitiveLeBool. Proof. intros x y z. rewrite !leb_le, !le_lteq. intros [Hxy|Hxy] [Hyz|Hyz]. - left; transitivity y; auto. - left; rewrite <- Hyz; auto. - left; rewrite Hxy; auto. - right; transitivity y; auto. + - left; transitivity y; auto. + - left; rewrite <- Hyz; auto. + - left; rewrite Hxy; auto. + - right; transitivity y; auto. Qed. Definition t := t. @@ -302,10 +304,10 @@ Module TTLB_to_OTF (Import O : TotalTransitiveLeBool') <: OrderedTypeFull. Proof. intros. unfold compare. case_eq (x <=? y). - case_eq (y <=? x). - constructor. split; auto. - constructor. split; congruence. - constructor. destruct (leb_total x y); split; congruence. + - case_eq (y <=? x). + + constructor. split; auto. + + constructor. split; congruence. + - constructor. destruct (leb_total x y); split; congruence. Qed. Definition eqb x y := (x <=? y) && (y <=? x). @@ -321,19 +323,19 @@ Module TTLB_to_OTF (Import O : TotalTransitiveLeBool') <: OrderedTypeFull. Instance eq_equiv : Equivalence eq. Proof. split. - intros x; unfold eq, le. destruct (leb_total x x); auto. - intros x y; unfold eq, le. intuition. - intros x y z; unfold eq, le. intuition; apply leb_trans with y; auto. + - intros x; unfold eq, le. destruct (leb_total x x); auto. + - intros x y; unfold eq, le. intuition. + - intros x y z; unfold eq, le. intuition; apply leb_trans with y; auto. Qed. Instance lt_strorder : StrictOrder lt. Proof. split. - intros x. unfold lt; red; intuition. - intros x y z; unfold lt, le. intuition. - apply leb_trans with y; auto. - absurd (z <=? y); auto. - apply leb_trans with x; auto. + - intros x. unfold lt; red; intuition. + - intros x y z; unfold lt, le. intuition. + + apply leb_trans with y; auto. + + absurd (z <=? y); auto. + apply leb_trans with x; auto. Qed. Instance lt_compat : Proper (eq ==> eq ==> iff) lt. @@ -341,11 +343,11 @@ Module TTLB_to_OTF (Import O : TotalTransitiveLeBool') <: OrderedTypeFull. apply proper_sym_impl_iff_2; auto with *. intros x x' Hx y y' Hy' H. unfold eq, lt, le in *. intuition. - apply leb_trans with x; auto. - apply leb_trans with y; auto. - absurd (y <=? x); auto. - apply leb_trans with x'; auto. - apply leb_trans with y'; auto. + - apply leb_trans with x; auto. + apply leb_trans with y; auto. + - absurd (y <=? x); auto. + apply leb_trans with x'; auto. + apply leb_trans with y'; auto. Qed. Definition le_lteq : forall x y, le x y <-> lt x y \/ eq x y. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 1fb0a37e16..182b781fe1 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -290,9 +290,9 @@ Module Type CompareBasedOrderFacts Lemma compare_spec x y : CompareSpec (x==y) (x<y) (y<x) (x?=y). Proof. case_eq (compare x y); intros H; constructor. - now apply compare_eq_iff. - now apply compare_lt_iff. - rewrite compare_antisym, CompOpp_iff in H. now apply compare_lt_iff. + - now apply compare_eq_iff. + - now apply compare_lt_iff. + - rewrite compare_antisym, CompOpp_iff in H. now apply compare_lt_iff. Qed. Lemma compare_eq x y : (x ?= y) = Eq -> x==y. diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v index 10d9027435..ea7769a994 100644 --- a/theories/Wellfounded/Disjoint_Union.v +++ b/theories/Wellfounded/Disjoint_Union.v @@ -45,11 +45,11 @@ Section Wf_Disjoint_Union. intros. unfold well_founded. destruct a as [a| b]. - apply (acc_A_sum a). - apply (H a). + - apply (acc_A_sum a). + apply (H a). - apply (acc_B_sum H b). - apply (H0 b). + - apply (acc_B_sum H b). + apply (H0 b). Qed. End Wf_Disjoint_Union. diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v index 37fd2fb23f..b2d08186ea 100644 --- a/theories/Wellfounded/Lexicographic_Product.v +++ b/theories/Wellfounded/Lexicographic_Product.v @@ -36,23 +36,23 @@ Section WfLexicographic_Product. apply Acc_intro. destruct y as [x2 y1]; intro H6. simple inversion H6; intro. - cut (leA x2 x); intros. - apply IHAcc; auto with sets. - intros. - apply H2. - apply t_trans with x2; auto with sets. - - red in H2. - apply H2. - auto with sets. - - injection H1 as <- _. - injection H3 as <- _; auto with sets. - - rewrite <- H1. - injection H3 as -> H3. - apply IHAcc0. - elim inj_pair2 with A B x y' x0; assumption. + - cut (leA x2 x); intros. + + apply IHAcc; auto with sets. + * intros. + apply H2. + apply t_trans with x2; auto with sets. + + * red in H2. + apply H2. + auto with sets. + + + injection H1 as <- _. + injection H3 as <- _; auto with sets. + + - rewrite <- H1. + injection H3 as -> H3. + apply IHAcc0. + elim inj_pair2 with A B x y' x0; assumption. Defined. Theorem wf_lexprod : @@ -116,17 +116,17 @@ Section Swap. apply Acc_intro. destruct y0; intros. inversion_clear H; inversion_clear H1; apply H0. - apply sp_swap. - apply right_sym; auto with sets. + - apply sp_swap. + apply right_sym; auto with sets. - apply sp_swap. - apply left_sym; auto with sets. + - apply sp_swap. + apply left_sym; auto with sets. - apply sp_noswap. - apply right_sym; auto with sets. + - apply sp_noswap. + apply right_sym; auto with sets. - apply sp_noswap. - apply left_sym; auto with sets. + - apply sp_noswap. + apply left_sym; auto with sets. Defined. @@ -135,26 +135,26 @@ Section Swap. Proof. induction 1 as [x0 _ IHAcc0]; intros H2. cut (forall y0:A, R y0 x0 -> Acc SwapProd (y0, y)). - clear IHAcc0. - induction H2 as [x1 _ IHAcc1]; intros H4. - cut (forall y:A, R y x1 -> Acc SwapProd (x0, y)). - clear IHAcc1. - intro. - apply Acc_intro. - destruct y; intro H5. - inversion_clear H5. - inversion_clear H0; auto with sets. - - apply swap_Acc. - inversion_clear H0; auto with sets. - - intros. - apply IHAcc1; auto with sets; intros. - apply Acc_inv with (y0, x1); auto with sets. - apply sp_noswap. - apply right_sym; auto with sets. - - auto with sets. + - clear IHAcc0. + induction H2 as [x1 _ IHAcc1]; intros H4. + cut (forall y:A, R y x1 -> Acc SwapProd (x0, y)). + + clear IHAcc1. + intro. + apply Acc_intro. + destruct y; intro H5. + inversion_clear H5. + * inversion_clear H0; auto with sets. + + * apply swap_Acc. + inversion_clear H0; auto with sets. + + + intros. + apply IHAcc1; auto with sets; intros. + apply Acc_inv with (y0, x1); auto with sets. + apply sp_noswap. + apply right_sym; auto with sets. + + - auto with sets. Defined. diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v index 9e671651fa..14d425b811 100644 --- a/theories/Wellfounded/Union.v +++ b/theories/Wellfounded/Union.v @@ -27,13 +27,13 @@ Section WfUnion. forall z:A, R2 z y -> exists2 y' : A, R2 y' x & clos_trans A R1 z y'. Proof. induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros. - elim H with y x z; auto with sets; intros x0 H2 H3. - exists x0; auto with sets. + - elim H with y x z; auto with sets; intros x0 H2 H3. + exists x0; auto with sets. - elim IH1 with z0; auto with sets; intros. - elim IH2 with x0; auto with sets; intros. - exists x1; auto with sets. - apply t_trans with x0; auto with sets. + - elim IH1 with z0; auto with sets; intros. + elim IH2 with x0; auto with sets; intros. + exists x1; auto with sets. + apply t_trans with x0; auto with sets. Qed. @@ -46,21 +46,21 @@ Section WfUnion. elim H3; intros; auto with sets. cut (clos_trans A R1 y x); auto with sets. elimtype (Acc (clos_trans A R1) y); intros. - apply Acc_intro; intros. - elim H8; intros. - apply H6; auto with sets. - apply t_trans with x0; auto with sets. + - apply Acc_intro; intros. + elim H8; intros. + + apply H6; auto with sets. + apply t_trans with x0; auto with sets. - elim strip_commut with x x0 y0; auto with sets; intros. - apply Acc_inv_trans with x1; auto with sets. - unfold union. - elim H11; auto with sets; intros. - apply t_trans with y1; auto with sets. + + elim strip_commut with x x0 y0; auto with sets; intros. + apply Acc_inv_trans with x1; auto with sets. + unfold union. + elim H11; auto with sets; intros. + apply t_trans with y1; auto with sets. - apply (Acc_clos_trans A). - apply Acc_inv with x; auto with sets. - apply H0. - apply Acc_intro; auto with sets. + - apply (Acc_clos_trans A). + apply Acc_inv with x; auto with sets. + apply H0. + apply Acc_intro; auto with sets. Qed. diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index cf46657d36..eb98fb2aba 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -39,9 +39,9 @@ Section WellOrdering. intros. apply (H v0 y0). cut (f = f1). - intros E; rewrite E; auto. - symmetry . - apply (inj_pair2 A (fun a0:A => B a0 -> WO) a0 f1 f H5). + - intros E; rewrite E; auto. + - symmetry . + apply (inj_pair2 A (fun a0:A => B a0 -> WO) a0 f1 f H5). Qed. End WellOrdering. diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 9ecd8f19ce..6681b79e38 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -186,7 +186,7 @@ let pp_vo_dep dir fmt vo = (* We explicitly include the location of coqlib to avoid tricky issues with coqlib location *) let libflag = "-coqlib %{project_root}" in (* The final build rule *) - let action = sprintf "(chdir %%{project_root} (run coqtop -boot %s %s %s -compile %s))" libflag eflag cflag source in + let action = sprintf "(chdir %%{project_root} (run coqc -boot %s %s %s %s))" libflag eflag cflag source in let all_targets = gen_coqc_targets vo in pp_rule fmt all_targets deps action diff --git a/tools/coqc.ml b/tools/coqc.ml deleted file mode 100644 index ae841212a7..0000000000 --- a/tools/coqc.ml +++ /dev/null @@ -1,163 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <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) *) -(************************************************************************) - -(** Coq compiler : coqc *) - -(** For improving portability, coqc is now an OCaml program instead - of a shell script. We use as much as possible the Sys and Filename - module for better portability, but the Unix module is still used - here and there (with explicitly qualified function names Unix.foo). - - We process here the commmand line to extract names of files to compile, - then we compile them one by one while passing by the rest of the command - line to a process running "coqtop -batch -compile <file>". -*) - -(* Environment *) - -let environment = Unix.environment () - -let use_bytecode = ref false -let image = ref "" - -let verbose = ref false - -let rec make_compilation_args = function - | [] -> [] - | file :: fl -> - (if !verbose then "-compile-verbose" else "-compile") - :: file :: (make_compilation_args fl) - -(* compilation of files [files] with command [command] and args [args] *) - -let compile command args files = - let args' = command :: args @ (make_compilation_args files) in - match Sys.os_type with - | "Win32" -> - let pid = - Unix.create_process_env command (Array.of_list args') environment - Unix.stdin Unix.stdout Unix.stderr - in - let status = snd (Unix.waitpid [] pid) in - let errcode = - match status with Unix.WEXITED c|Unix.WSTOPPED c|Unix.WSIGNALED c -> c - in - exit errcode - | _ -> - Unix.execvpe command (Array.of_list args') environment - -let usage () = - Usage.print_usage_coqc () ; - flush stderr ; - exit 1 - -(* parsing of the command line *) -let extra_arg_needed = ref true - -let parse_args () = - let rec parse (cfiles,args) = function - | [] -> - List.rev cfiles, List.rev args - | ("-verbose" | "--verbose") :: rem -> - verbose := true ; parse (cfiles,args) rem - | "-image" :: f :: rem -> image := f; parse (cfiles,args) rem - | "-image" :: [] -> usage () - | "-byte" :: rem -> use_bytecode := true; parse (cfiles,args) rem - | "-opt" :: rem -> use_bytecode := false; parse (cfiles,args) rem - -(* Informative options *) - - | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () - - | ("-v"|"--version") :: _ -> Usage.version 0 - - | ("-where") :: _ -> - Envars.set_coqlib ~fail:(fun x -> x); - print_endline (Envars.coqlib ()); - exit 0 - - | ("-config" | "--config") :: _ -> - Envars.set_coqlib ~fail:(fun x -> x); - Envars.print_config stdout Coq_config.all_src_dirs; - exit 0 - - | ("-print-version" | "--print-version") :: _ -> - Usage.machine_readable_version 0 - -(* Options for coqtop : a) options with 0 argument *) - - | ("-bt"|"-debug"|"-nolib"|"-boot"|"-time"|"-profile-ltac" - |"-batch"|"-noinit"|"-nois"|"-noglob"|"-no-glob" - |"-q"|"-profile"|"-echo" |"-quiet" - |"-silent"|"-m"|"-beautify"|"-strict-implicit" - |"-impredicative-set"|"-vm" - |"-indices-matter"|"-quick"|"-type-in-type" - |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch" - |"-stm-debug" - as o) :: rem -> - parse (cfiles,o::args) rem - -(* Options for coqtop : b) options with 1 argument *) - - | ("-outputstate"|"-inputstate"|"-is"|"-exclude-dir"|"-color" - |"-load-vernac-source"|"-l"|"-load-vernac-object" - |"-load-ml-source"|"-require"|"-load-ml-object" - |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top"|"-topfile" - |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w" - |"-o"|"-profile-ltac-cutoff"|"-mangle-names"|"-bytecode-compiler"|"-native-compiler" - as o) :: rem -> - begin - match rem with - | s :: rem' -> parse (cfiles,s::o::args) rem' - | [] -> usage () - end - | ("-I"|"-include" as o) :: s :: rem -> parse (cfiles,s::o::args) rem - -(* Options for coqtop : c) options with 1 argument and possibly more *) - - | ("-R"|"-Q" as o) :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem - | ("-schedule-vio-checking" - |"-check-vio-tasks" | "-schedule-vio2vo" as o) :: s :: rem -> - let nodash, rem = - CList.split_when (fun x -> String.length x > 1 && x.[0] = '-') rem in - extra_arg_needed := false; - parse (cfiles, List.rev nodash @ s :: o :: args) rem - - | f :: rem -> - if Sys.file_exists f then - parse (f::cfiles,args) rem - else - let fv = f ^ ".v" in - if Sys.file_exists fv then - parse (fv::cfiles,args) rem - else begin - prerr_endline ("coqc: "^f^": no such file or directory") ; - exit 1 - end - in - parse ([],[]) (List.tl (Array.to_list Sys.argv)) - -(* main: we parse the command line, define the command to compile files - * and then call the compilation on each file *) - -let main () = - let cfiles, args = parse_args () in - if cfiles = [] && !extra_arg_needed then begin - prerr_endline "coqc: too few arguments" ; - usage () - end; - let coqtopname = - if !image <> "" then !image - else System.get_toplevel_path ~byte:!use_bytecode "coqtop" - in - (* List.iter (compile coqtopname args) cfiles*) - Unix.handle_unix_error (compile coqtopname args) cfiles - -let _ = Printexc.print main () diff --git a/tools/dune b/tools/dune index 31b70fb06c..204bd09535 100644 --- a/tools/dune +++ b/tools/dune @@ -16,13 +16,6 @@ (libraries coq.lib)) (executable - (name coqc) - (public_name coqc) - (package coq) - (modules coqc) - (libraries coq.toplevel)) - -(executable (name coqworkmgr) (public_name coqworkmgr) (package coq) diff --git a/topbin/coqc_bin.ml b/topbin/coqc_bin.ml new file mode 100644 index 0000000000..d711c81124 --- /dev/null +++ b/topbin/coqc_bin.ml @@ -0,0 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <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) *) +(************************************************************************) + +(* Main coqc initialization *) +let _ = + Coqc.main () diff --git a/topbin/dune b/topbin/dune index 52f472d149..f42e4d6fc2 100644 --- a/topbin/dune +++ b/topbin/dune @@ -20,11 +20,19 @@ (modes byte) (link_flags -linkall)) +(executable + (name coqc_bin) + (public_name coqc) + (package coq) + (modules coqc_bin) + (libraries coq.toplevel) + (link_flags -linkall)) + ; Workers (executables (names coqqueryworker_bin coqtacticworker_bin coqproofworker_bin) (public_names coqqueryworker.opt coqtacticworker.opt coqproofworker.opt) (package coq) - (modules :standard \ coqtop_byte_bin coqtop_bin) + (modules :standard \ coqtop_byte_bin coqtop_bin coqc_bin) (libraries coq.toplevel) (link_flags -linkall)) diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index b248b87880..df2b983029 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -10,6 +10,7 @@ open Pp open Coqargs +open Coqcargs let fatal_error msg = Topfmt.std_logger Feedback.Error msg; @@ -81,7 +82,7 @@ let ensure_exists f = fatal_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) (* Compile a vernac file *) -let compile opts ~echo ~f_in ~f_out = +let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = let pfs = Proof_global.get_all_proof_names () in @@ -95,7 +96,7 @@ let compile opts ~echo ~f_in ~f_out = let iload_path = build_load_path opts in let require_libs = require_libs opts in let stm_options = opts.stm_flags in - match opts.compilation_mode with + match copts.compilation_mode with | BuildVo -> Flags.record_aux_file := true; let long_f_dot_v = ensure_v f_in in @@ -179,47 +180,47 @@ let compile opts ~echo ~f_in ~f_out = let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in Library.save_library_raw lfdv sum lib univs proofs -let compile opts ~echo ~f_in ~f_out = +let compile opts copts ~echo ~f_in ~f_out = ignore(CoqworkmgrApi.get 1); - compile opts ~echo ~f_in ~f_out; + compile opts copts ~echo ~f_in ~f_out; CoqworkmgrApi.giveback 1 -let compile_file opts (f_in, echo) = - let f_out = opts.compilation_output_name in +let compile_file opts copts (f_in, echo) = + let f_out = copts.compilation_output_name in if !Flags.beautify then Flags.with_option Flags.beautify_file - (fun f_in -> compile opts ~echo ~f_in ~f_out) f_in + (fun f_in -> compile opts copts ~echo ~f_in ~f_out) f_in else - compile opts ~echo ~f_in ~f_out + compile opts copts ~echo ~f_in ~f_out -let compile_files opts = - let compile_list = List.rev opts.compile_list in - List.iter (compile_file opts) compile_list +let compile_files opts copts = + let compile_list = List.rev copts.compile_list in + List.iter (compile_file opts copts) compile_list (******************************************************************************) (* VIO Dispatching *) (******************************************************************************) -let check_vio_tasks opts = +let check_vio_tasks copts = let rc = List.fold_left (fun acc t -> Vio_checking.check_vio t && acc) - true (List.rev opts.vio_tasks) in + true (List.rev copts.vio_tasks) in if not rc then fatal_error Pp.(str "VIO Task Check failed") (* vio files *) -let schedule_vio opts = - if opts.vio_checking then - Vio_checking.schedule_vio_checking opts.vio_files_j opts.vio_files +let schedule_vio copts = + if copts.vio_checking then + Vio_checking.schedule_vio_checking copts.vio_files_j copts.vio_files else - Vio_checking.schedule_vio_compilation opts.vio_files_j opts.vio_files + Vio_checking.schedule_vio_compilation copts.vio_files_j copts.vio_files -let do_vio opts = +let do_vio opts copts = (* We must initialize the loadpath here as the vio scheduling process happens outside of the STM *) - if opts.vio_files <> [] || opts.vio_tasks <> [] then + if copts.vio_files <> [] || copts.vio_tasks <> [] then let iload_path = build_load_path opts in List.iter Mltop.add_coq_path iload_path; (* Vio compile pass *) - if opts.vio_files <> [] then schedule_vio opts; + if copts.vio_files <> [] then schedule_vio copts; (* Vio task pass *) - if opts.vio_tasks <> [] then check_vio_tasks opts + if copts.vio_tasks <> [] then check_vio_tasks copts diff --git a/toplevel/ccompile.mli b/toplevel/ccompile.mli index 757c91c408..29a76eb966 100644 --- a/toplevel/ccompile.mli +++ b/toplevel/ccompile.mli @@ -10,10 +10,10 @@ (** [load_init_vernaculars opts ~state] Load vernaculars from the init (rc) file *) -val load_init_vernaculars : Coqargs.coq_cmdopts -> state:Vernac.State.t-> Vernac.State.t +val load_init_vernaculars : Coqargs.t -> state:Vernac.State.t-> Vernac.State.t (** [compile_files opts] compile files specified in [opts] *) -val compile_files : Coqargs.coq_cmdopts -> unit +val compile_files : Coqargs.t -> Coqcargs.t -> unit (** [do_vio opts] process [.vio] files in [opts] *) -val do_vio : Coqargs.coq_cmdopts -> unit +val do_vio : Coqargs.t -> Coqcargs.t -> unit diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 0a32879764..74c016101a 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -31,10 +31,9 @@ let set_type_in_type () = (******************************************************************************) -type compilation_mode = BuildVo | BuildVio | Vio2Vo type color = [`ON | `AUTO | `OFF] -type coq_cmdopts = { +type t = { load_init : bool; load_rcfile : bool; @@ -45,21 +44,10 @@ type coq_cmdopts = { vo_requires : (string * string option * bool option) list; (* None = No Import; Some false = Import; Some true = Export *) - (* XXX: Fusion? *) - batch_mode : bool; - compilation_mode : compilation_mode; - toplevel_name : Stm.interactive_top; - compile_list: (string * bool) list; (* bool is verbosity *) - compilation_output_name : string option; - load_vernacular_list : (string * bool) list; - - vio_checking: bool; - vio_tasks : (int list * string) list; - vio_files : string list; - vio_files_j : int; + batch : bool; color : color; @@ -67,6 +55,7 @@ type coq_cmdopts = { indices_matter : bool; enable_VM : bool; enable_native_compiler : bool; + stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; diffs_set : bool; @@ -85,13 +74,12 @@ type coq_cmdopts = { print_emacs : bool; inputstate : string option; - outputstate : string option; } let default_toplevel = Names.(DirPath.make [Id.of_string "Top"]) -let default_opts = { +let default = { load_init = true; load_rcfile = true; @@ -101,20 +89,10 @@ let default_opts = { vo_includes = []; vo_requires = []; - batch_mode = false; - compilation_mode = BuildVo; - toplevel_name = Stm.TopLogical default_toplevel; - compile_list = []; - compilation_output_name = None; - load_vernacular_list = []; - - vio_checking = false; - vio_tasks = []; - vio_files = []; - vio_files_j = 0; + batch = false; color = `AUTO; @@ -142,7 +120,6 @@ let default_opts = { (* Quiet / verbosity options should be here *) inputstate = None; - outputstate = None; } (******************************************************************************) @@ -165,46 +142,12 @@ let add_compat_require opts v = match v with | Flags.V8_7 -> add_vo_require opts "Coq.Compat.Coq87" None (Some false) | Flags.V8_8 -> add_vo_require opts "Coq.Compat.Coq88" None (Some false) - | Flags.Current -> add_vo_require opts "Coq.Compat.Coq89" None (Some false) - -let set_batch_mode opts = - (* XXX: This should be in the argument record *) - Flags.quiet := true; - System.trust_file_cache := true; - { opts with batch_mode = true } - -let add_compile opts verbose s = - let opts = set_batch_mode opts in - if not opts.glob_opt then Dumpglob.dump_to_dotglob (); - (* make the file name explicit; needed not to break up Coq loadpath stuff. *) - let s = - let open Filename in - if is_implicit s - then concat current_dir_name s - else s - in - { opts with compile_list = (s,verbose) :: opts.compile_list } + | Flags.V8_9 -> add_vo_require opts "Coq.Compat.Coq89" None (Some false) + | Flags.Current -> add_vo_require opts "Coq.Compat.Coq810" None (Some false) let add_load_vernacular opts verb s = { opts with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.load_vernacular_list } -let add_vio_task opts f = - let opts = set_batch_mode opts in - { opts with vio_tasks = f :: opts.vio_tasks } - -let add_vio_file opts f = - let opts = set_batch_mode opts in - { opts with vio_files = f :: opts.vio_files } - -let set_vio_checking_j opts opt j = - try { opts with vio_files_j = int_of_string j } - with Failure _ -> - prerr_endline ("The first argument of " ^ opt ^ " must the number"); - prerr_endline "of concurrent workers to be used (a positive integer)."; - prerr_endline "Makefiles generated by coq_makefile should be called"; - prerr_endline "setting the J variable like in 'make vio2vo J=3'"; - exit 1 - (** Options for proof general *) let set_emacs opts = Printer.enable_goal_tags_printing := true; @@ -224,22 +167,11 @@ let set_inputstate opts s = warn_deprecated_inputstate (); { opts with inputstate = Some s } -let warn_deprecated_outputstate = - CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated" - (fun () -> - Pp.strbrk "The outputstate option is deprecated and discouraged.") - -let set_outputstate opts s = - warn_deprecated_outputstate (); - { opts with outputstate = Some s } - let exitcode opts = if opts.filter_opts then 2 else 0 (******************************************************************************) (* Parsing helpers *) (******************************************************************************) -let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s) - let get_bool opt = function | "yes" | "on" -> true | "no" | "off" -> false @@ -284,16 +216,6 @@ let get_cache opt = function | "force" -> Some Stm.AsyncOpts.Force | _ -> prerr_endline ("Error: force expected after "^opt); exit 1 -let is_not_dash_option = function - | Some f when String.length f > 0 && f.[0] <> '-' -> true - | _ -> false - -let rec add_vio_args peek next oval = - if is_not_dash_option (peek ()) then - let oval = add_vio_file oval (next ()) in - add_vio_args peek next oval - else oval - let get_native_name s = (* We ignore even critical errors because this mode has to be super silent *) try @@ -310,7 +232,7 @@ let usage_no_coqlib = CWarnings.create ~name:"usage-no-coqlib" ~category:"filesy exception NoCoqLib -let usage batch = +let usage help = begin try Envars.set_coqlib ~fail:(fun x -> raise NoCoqLib) with NoCoqLib -> usage_no_coqlib () @@ -318,12 +240,10 @@ let usage batch = let lp = Coqinit.toplevel_init_load_path () in (* Necessary for finding the toplevels below *) List.iter Mltop.add_coq_path lp; - if batch - then Usage.print_usage_coqc () - else Usage.print_usage_coqtop () + help () (* Main parsing routine *) -let parse_args init_opts arglist : coq_cmdopts * string list = +let parse_args ~help ~init arglist : t * string list = let args = ref arglist in let extras = ref [] in let rec parse oval = match !args with @@ -335,10 +255,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = | x::rem -> args := rem; x | [] -> error_missing_arg opt in - let peek_next () = match !args with - | x::_ -> Some x - | [] -> None - in let noval = begin match opt with (* Complex options with many args *) @@ -364,23 +280,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = | _ -> error_missing_arg opt end - (* Options with two arg *) - |"-check-vio-tasks" -> - let tno = get_task_list (next ()) in - let tfile = next () in - add_vio_task oval (tno,tfile) - - |"-schedule-vio-checking" -> - let oval = { oval with vio_checking = true } in - let oval = set_vio_checking_j oval opt (next ()) in - let oval = add_vio_file oval (next ()) in - add_vio_args peek_next next oval - - |"-schedule-vio2vo" -> - let oval = set_vio_checking_j oval opt (next ()) in - let oval = add_vio_file oval (next ()) in - add_vio_args peek_next next oval - (* Options with one arg *) |"-coqlib" -> Envars.set_user_coqlib (next ()); @@ -435,12 +334,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = Flags.compat_version := v; add_compat_require oval v - |"-compile" -> - add_compile oval false (next ()) - - |"-compile-verbose" -> - add_compile oval true (next ()) - |"-dump-glob" -> Dumpglob.dump_into_file (next ()); { oval with glob_opt = true } @@ -457,9 +350,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = |"-inputstate"|"-is" -> set_inputstate oval (next ()) - |"-outputstate" -> - set_outputstate oval (next ()) - |"-load-ml-object" -> Mltop.dir_ml_load (next ()); oval @@ -505,10 +395,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = |"-control-channel" -> Spawned.control_channel := get_host_port opt (next()); oval - |"-vio2vo" -> - let oval = add_compile oval false (next ()) in - { oval with compilation_mode = Vio2Vo } - |"-w" | "-W" -> let w = next () in if w = "none" then @@ -518,8 +404,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = CWarnings.set_flags (CWarnings.normalize_flags_string w); oval - |"-o" -> { oval with compilation_output_name = Some (next()) } - |"-bytecode-compiler" -> { oval with enable_VM = get_bool opt (next ()) } @@ -547,7 +431,9 @@ let parse_args init_opts arglist : coq_cmdopts * string list = { oval with stm_flags = { oval.stm_flags with Stm.AsyncOpts.async_proofs_never_reopen_branch = true }} - |"-batch" -> set_batch_mode oval + |"-batch" -> + Flags.quiet := true; + { oval with batch = true } |"-test-mode" -> Flags.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval |"-boot" -> Flags.boot := true; { oval with load_rcfile = false; } @@ -577,13 +463,12 @@ let parse_args init_opts arglist : coq_cmdopts * string list = Flags.quiet := true; Flags.make_warn false; oval - |"-quick" -> { oval with compilation_mode = BuildVio } |"-list-tags" -> { oval with print_tags = true } |"-time" -> { oval with time = true } |"-type-in-type" -> set_type_in_type (); oval |"-unicode" -> add_vo_require oval "Utf8_core" None (Some false) |"-where" -> { oval with print_where = true } - |"-h"|"-H"|"-?"|"-help"|"--help" -> usage oval.batch_mode; oval + |"-h"|"-H"|"-?"|"-help"|"--help" -> usage help; oval |"-v"|"--version" -> Usage.version (exitcode oval) |"-print-version"|"--print-version" -> Usage.machine_readable_version (exitcode oval) @@ -596,13 +481,13 @@ let parse_args init_opts arglist : coq_cmdopts * string list = parse noval in try - parse init_opts + parse init with any -> fatal_error any (******************************************************************************) (* Startup LoadPath and Modules *) (******************************************************************************) -(* prelude_data == From Coq Require Export Prelude. *) +(* prelude_data == From Coq Require Import Prelude. *) let prelude_data = "Prelude", Some "Coq", Some false let require_libs opts = diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index e645b0c126..c9a7a0fd56 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -8,12 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type compilation_mode = BuildVo | BuildVio | Vio2Vo type color = [`ON | `AUTO | `OFF] val default_toplevel : Names.DirPath.t -type coq_cmdopts = { +type t = { load_init : bool; load_rcfile : bool; @@ -23,22 +22,10 @@ type coq_cmdopts = { vo_includes : Mltop.coq_path list; vo_requires : (string * string option * bool option) list; - (* Fuse these two? Currently, [batch_mode] is only used to - distinguish coqc / coqtop in help display. *) - batch_mode : bool; - compilation_mode : compilation_mode; - toplevel_name : Stm.interactive_top; - compile_list: (string * bool) list; (* bool is verbosity *) - compilation_output_name : string option; - load_vernacular_list : (string * bool) list; - - vio_checking: bool; - vio_tasks : (int list * string) list; - vio_files : string list; - vio_files_j : int; + batch : bool; color : color; @@ -63,18 +50,14 @@ type coq_cmdopts = { print_emacs : bool; - (* Quiet / verbosity options should be here *) - inputstate : string option; - outputstate : string option; - } (* Default options *) -val default_opts : coq_cmdopts +val default : t -val parse_args : coq_cmdopts -> string list -> coq_cmdopts * string list -val exitcode : coq_cmdopts -> int +val parse_args : help:(unit -> unit) -> init:t -> string list -> t * string list +val exitcode : t -> int -val require_libs : coq_cmdopts -> (string * string option * bool option) list -val build_load_path : coq_cmdopts -> Mltop.coq_path list +val require_libs : t -> (string * string option * bool option) list +val build_load_path : t -> Mltop.coq_path list diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml new file mode 100644 index 0000000000..d4107177a7 --- /dev/null +++ b/toplevel/coqc.ml @@ -0,0 +1,67 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <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) *) +(************************************************************************) + +let set_noninteractive_mode () = + Flags.quiet := true; + System.trust_file_cache := true + +let outputstate opts = + Option.iter (fun ostate_file -> + let fname = CUnix.make_suffix ostate_file ".coq" in + States.extern_state fname) opts.Coqcargs.outputstate + +let coqc_main () = + (* Careful because init_toplevel will call Summary.init_summaries, + thus options such as `quiet` have to be set after the main + initialisation is run. *) + let coqc_init ~opts args = + set_noninteractive_mode (); + let opts, args = Coqtop.(coqtop_toplevel.init) ~opts args in + opts, args + in + let opts, extras = + Topfmt.(in_phase ~phase:Initialization) + Coqtop.(init_toplevel ~help:Usage.print_usage_coqc ~init:Coqargs.default coqc_init) List.(tl (Array.to_list Sys.argv)) in + + let copts = Coqcargs.parse extras in + + if not opts.Coqargs.glob_opt then Dumpglob.dump_to_dotglob (); + + Topfmt.(in_phase ~phase:CompilationPhase) + Ccompile.compile_files opts copts; + + (* Careful this will modify the load-path and state so after this + point some stuff may not be safe anymore. *) + Topfmt.(in_phase ~phase:CompilationPhase) + Ccompile.do_vio opts copts; + + (* Allow the user to output an arbitrary state *) + outputstate copts; + + flush_all(); + if opts.Coqargs.output_context then begin + let sigma, env = Pfedit.get_current_context () in + Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) + end; + CProfile.print_profile () + +let main () = + let _feeder = Feedback.add_feeder Coqloop.coqloop_feed in + try + coqc_main (); + exit 0 + with exn -> + flush_all(); + Topfmt.print_err_exn exn; + flush_all(); + let exit_code = + if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 + in + exit exit_code diff --git a/toplevel/coqc.mli b/toplevel/coqc.mli new file mode 100644 index 0000000000..6049c5e188 --- /dev/null +++ b/toplevel/coqc.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <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) *) +(************************************************************************) + +val main : unit -> unit diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml new file mode 100644 index 0000000000..7445619d26 --- /dev/null +++ b/toplevel/coqcargs.ml @@ -0,0 +1,174 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <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) *) +(************************************************************************) + +type compilation_mode = BuildVo | BuildVio | Vio2Vo + +type t = + { compilation_mode : compilation_mode + + ; compile_list: (string * bool) list (* bool is verbosity *) + ; compilation_output_name : string option + + ; vio_checking : bool + ; vio_tasks : (int list * string) list + ; vio_files : string list + ; vio_files_j : int + + ; echo : bool + + ; outputstate : string option; + } + +let default = + { compilation_mode = BuildVo + + ; compile_list = [] + ; compilation_output_name = None + + ; vio_checking = false + ; vio_tasks = [] + ; vio_files = [] + ; vio_files_j = 0 + + ; echo = false + + ; outputstate = None + } + +let depr opt = + Feedback.msg_warning Pp.(seq[str "Option "; str opt; str " is a noop and deprecated"]) + +(* XXX Remove this duplication with Coqargs *) +let fatal_error exn = + Topfmt.(in_phase ~phase:ParsingCommandLine print_err_exn exn); + let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in + exit exit_code + +let error_missing_arg s = + prerr_endline ("Error: extra argument expected after option "^s); + prerr_endline "See -help for the syntax of supported options"; + exit 1 + +let add_compile ?echo copts s = + (* make the file name explicit; needed not to break up Coq loadpath stuff. *) + let echo = Option.default copts.echo echo in + let s = + let open Filename in + if is_implicit s + then concat current_dir_name s + else s + in + { copts with compile_list = (s,echo) :: copts.compile_list } + +let add_vio_task opts f = + { opts with vio_tasks = f :: opts.vio_tasks } + +let add_vio_file opts f = + { opts with vio_files = f :: opts.vio_files } + +let set_vio_checking_j opts opt j = + try { opts with vio_files_j = int_of_string j } + with Failure _ -> + prerr_endline ("The first argument of " ^ opt ^ " must the number"); + prerr_endline "of concurrent workers to be used (a positive integer)."; + prerr_endline "Makefiles generated by coq_makefile should be called"; + prerr_endline "setting the J variable like in 'make vio2vo J=3'"; + exit 1 + +let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s) + +let is_not_dash_option = function + | Some f when String.length f > 0 && f.[0] <> '-' -> true + | _ -> false + +let rec add_vio_args peek next oval = + if is_not_dash_option (peek ()) then + let oval = add_vio_file oval (next ()) in + add_vio_args peek next oval + else oval + +let warn_deprecated_outputstate = + CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated" + (fun () -> + Pp.strbrk "The outputstate option is deprecated and discouraged.") + +let set_outputstate opts s = + warn_deprecated_outputstate (); + { opts with outputstate = Some s } + +let parse arglist : t = + let echo = ref false in + let args = ref arglist in + let extras = ref [] in + let rec parse (oval : t) = match !args with + | [] -> + (oval, List.rev !extras) + | opt :: rem -> + args := rem; + let next () = match !args with + | x::rem -> args := rem; x + | [] -> error_missing_arg opt + in + let peek_next () = match !args with + | x::_ -> Some x + | [] -> None + in + let noval : t = begin match opt with + (* Deprecated options *) + | "-opt" + | "-byte" as opt -> + depr opt; + oval + | "-image" as opt -> + depr opt; + let _ = next () in + oval + (* Verbose == echo mode *) + | "-verbose" -> + echo := true; + oval + (* Output filename *) + | "-o" -> + { oval with compilation_output_name = Some (next ()) } + | "-quick" -> + { oval with compilation_mode = BuildVio } + | "-check-vio-tasks" -> + let tno = get_task_list (next ()) in + let tfile = next () in + add_vio_task oval (tno,tfile) + + | "-schedule-vio-checking" -> + let oval = { oval with vio_checking = true } in + let oval = set_vio_checking_j oval opt (next ()) in + let oval = add_vio_file oval (next ()) in + add_vio_args peek_next next oval + + | "-schedule-vio2vo" -> + let oval = set_vio_checking_j oval opt (next ()) in + let oval = add_vio_file oval (next ()) in + add_vio_args peek_next next oval + + | "-vio2vo" -> + let oval = add_compile ~echo:false oval (next ()) in + { oval with compilation_mode = Vio2Vo } + + | "-outputstate" -> + set_outputstate oval (next ()) + + | s -> + extras := s :: !extras; + oval + end in + parse noval + in + try + let opts, extra = parse default in + List.fold_left add_compile opts extra + with any -> fatal_error any diff --git a/toplevel/coqcargs.mli b/toplevel/coqcargs.mli new file mode 100644 index 0000000000..7792056b24 --- /dev/null +++ b/toplevel/coqcargs.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <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) *) +(************************************************************************) + +type compilation_mode = BuildVo | BuildVio | Vio2Vo + +type t = + { compilation_mode : compilation_mode + + ; compile_list: (string * bool) list (* bool is verbosity *) + ; compilation_output_name : string option + + ; vio_checking : bool + ; vio_tasks : (int list * string) list + ; vio_files : string list + ; vio_files_j : int + + ; echo : bool + + ; outputstate : string option + } + +val default : t +val parse : string list -> t diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index e58b9ccac7..cdbe444e5b 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -243,7 +243,7 @@ let set_prompt prompt = let parse_to_dot = let rec dot st = match Stream.next st with | Tok.KEYWORD ("."|"...") -> () - | Tok.EOI -> raise Stm.End_of_input + | Tok.EOI -> () | _ -> dot st in Pcoq.Entry.of_parser "Coqtoplevel.dot" dot @@ -257,12 +257,12 @@ let rec discard_to_dot () = Pcoq.Entry.parse parse_to_dot top_buffer.tokens with | Gramlib.Plexing.Error _ | CLexer.Error.E _ -> discard_to_dot () - | Stm.End_of_input -> raise Stm.End_of_input | e when CErrors.noncritical e -> () let read_sentence ~state input = (* XXX: careful with ignoring the state Eugene!*) - try G_toplevel.parse_toplevel input + let open Vernac.State in + try Stm.parse_sentence ~doc:state.doc state.sid ~entry:G_toplevel.vernac_toplevel input with reraise -> let reraise = CErrors.push reraise in discard_to_dot (); @@ -366,7 +366,6 @@ let top_goal_print ~doc c oldp newp = let msg = CErrors.iprint (e, info) in TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer -(* Careful to keep this loop tail-rec *) let rec vernac_loop ~state = let open CAst in let open Vernac.State in @@ -379,26 +378,30 @@ let rec vernac_loop ~state = try let input = top_buffer.tokens in match read_sentence ~state input with - | {v=VernacBacktrack(bid,_,_)} -> + | Some { v = VernacBacktrack(bid,_,_) } -> let bid = Stateid.of_int bid in let doc, res = Stm.edit_at ~doc:state.doc bid in assert (res = `NewTip); let state = { state with doc; sid = bid } in vernac_loop ~state - | {v=VernacQuit} -> + | Some { v = VernacQuit } -> exit 0 - | {v=VernacDrop} -> + + | Some { v = VernacDrop } -> if Mltop.is_ocaml_top() then (drop_last_doc := Some state; state) else (Feedback.msg_warning (str "There is no ML toplevel."); vernac_loop ~state) - | {v=VernacControl c; loc} -> + + | Some { v = VernacControl c; loc } -> let nstate = Vernac.process_expr ~state (make ?loc c) in top_goal_print ~doc:state.doc c state.proof nstate.proof; vernac_loop ~state:nstate + + | None -> + top_stderr (fnl ()); exit 0 + with - | Stm.End_of_input -> - top_stderr (fnl ()); exit 0 (* Exception printing should be done by the feedback listener, however this is not yet ready so we rely on the exception for now. *) diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index 7d03484412..0cc22ba31d 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -31,7 +31,7 @@ val coqloop_feed : Feedback.feedback -> unit (** Last document seen after `Drop` *) val drop_last_doc : Vernac.State.t option ref -val drop_args : Coqargs.coq_cmdopts option ref +val drop_args : Coqargs.t option ref (** Main entry point of Coq: read and execute vernac commands. *) -val loop : opts:Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit +val loop : opts:Coqargs.t -> state:Vernac.State.t -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 56622abc92..6ef0aa390d 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -58,11 +58,6 @@ let inputstate opts = let fname = Loadpath.locate_file (CUnix.make_suffix istate_file ".coq") in States.intern_state fname) opts.inputstate -let outputstate opts = - Option.iter (fun ostate_file -> - let fname = CUnix.make_suffix ostate_file ".coq" in - States.extern_state fname) opts.outputstate - (******************************************************************************) (* Fatal Errors *) (******************************************************************************) @@ -102,7 +97,7 @@ let init_color opts = else false in - if Proof_diffs.show_diffs () && not term_color && not opts.batch_mode then + if Proof_diffs.show_diffs () && not term_color then (prerr_endline "Error: -diffs requires enabling -color"; exit 1); Topfmt.init_terminal_output ~color:term_color @@ -148,116 +143,114 @@ let init_gc () = Gc.space_overhead = 120} (** Main init routine *) -let init_toplevel init_opts custom_init arglist = +let init_toplevel ~help ~init custom_init arglist = (* Coq's init process, phase 1: OCaml parameters, basic structures, and IO *) CProfile.init_profile (); init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) - let init_feeder = Feedback.add_feeder Coqloop.coqloop_feed in Lib.init(); (* Coq's init process, phase 2: Basic Coq environment, load-path, plugins. *) - let res = begin - try - let opts,extras = parse_args init_opts arglist in - memory_stat := opts.memory_stat; - - (* If we have been spawned by the Spawn module, this has to be done - * early since the master waits us to connect back *) - Spawned.init_channels (); - Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); - if opts.print_where then begin - print_endline (Envars.coqlib ()); - exit (exitcode opts) - end; - if opts.print_config then begin - Envars.print_config stdout Coq_config.all_src_dirs; - exit (exitcode opts) - end; - if opts.print_tags then begin - print_style_tags opts; - exit (exitcode opts) - end; - if opts.filter_opts then begin - print_string (String.concat "\n" extras); - exit 0; - end; - let top_lp = Coqinit.toplevel_init_load_path () in - List.iter Mltop.add_coq_path top_lp; - let opts, extras = custom_init ~opts extras in - if not (CList.is_empty extras) then begin - prerr_endline ("Don't know what to do with "^String.concat " " extras); - prerr_endline "See -help for the list of supported options"; - exit 1 - end; - Flags.if_verbose print_header (); - Mltop.init_known_plugins (); - Global.set_engagement opts.impredicative_set; - Global.set_indices_matter opts.indices_matter; - Global.set_VM opts.enable_VM; - Global.set_native_compiler opts.enable_native_compiler; - - (* Allow the user to load an arbitrary state here *) - inputstate opts; - - (* This state will be shared by all the documents *) - Stm.init_core (); - - (* Coq init process, phase 3: Stm initialization, backtracking state. - - It is essential that the module system is in a consistent - state before we take the first snapshot. This was not - guaranteed in the past, but now is thanks to the STM API. - - We split the codepath here depending whether coqtop is called - in interactive mode or not. *) - - (* The condition for starting the interactive mode is a bit - convoluted, we should really refactor batch/compilation_mode - more. *) - if (not opts.batch_mode - || CList.(is_empty opts.compile_list && is_empty opts.vio_files && is_empty opts.vio_tasks)) - (* Interactive *) - then begin - let iload_path = build_load_path opts in - let require_libs = require_libs opts in - let stm_options = opts.stm_flags in - let open Vernac.State in - let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) - Stm.new_doc - Stm.{ doc_type = Interactive opts.toplevel_name; - iload_path; require_libs; stm_options; - } in - let state = { doc; sid; proof = None; time = opts.time } in - Some (Ccompile.load_init_vernaculars opts ~state), opts - (* Non interactive: we perform a sequence of compilation steps *) - end else begin - Ccompile.compile_files opts; - (* Careful this will modify the load-path and state so after - this point some stuff may not be safe anymore. *) - Ccompile.do_vio opts; - (* Allow the user to output an arbitrary state *) - outputstate opts; - None, opts - end; - with any -> - flush_all(); - fatal_error_exn any - end in - Feedback.del_feeder init_feeder; - res + let opts, extras = parse_args ~help ~init arglist in + memory_stat := opts.memory_stat; + + (* If we have been spawned by the Spawn module, this has to be done + * early since the master waits us to connect back *) + Spawned.init_channels (); + Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); + if opts.print_where then begin + print_endline (Envars.coqlib ()); + exit (exitcode opts) + end; + if opts.print_config then begin + Envars.print_config stdout Coq_config.all_src_dirs; + exit (exitcode opts) + end; + if opts.print_tags then begin + print_style_tags opts; + exit (exitcode opts) + end; + if opts.filter_opts then begin + print_string (String.concat "\n" extras); + exit 0; + end; + let top_lp = Coqinit.toplevel_init_load_path () in + List.iter Mltop.add_coq_path top_lp; + let opts, extras = custom_init ~opts extras in + Flags.if_verbose print_header (); + Mltop.init_known_plugins (); + + Global.set_engagement opts.impredicative_set; + Global.set_indices_matter opts.indices_matter; + Global.set_VM opts.enable_VM; + Global.set_native_compiler opts.enable_native_compiler; + + (* Allow the user to load an arbitrary state here *) + inputstate opts; + + (* This state will be shared by all the documents *) + Stm.init_core (); + + (* Coq init process, phase 3: Stm initialization, backtracking state. + + It is essential that the module system is in a consistent + state before we take the first snapshot. This was not + guaranteed in the past, but now is thanks to the STM API. + *) + opts, extras + +type init_fn = opts:Coqargs.t -> string list -> Coqargs.t * string list type custom_toplevel = - { init : opts:coq_cmdopts -> string list -> coq_cmdopts * string list - ; run : opts:coq_cmdopts -> state:Vernac.State.t -> unit - ; opts : Coqargs.coq_cmdopts + { init : init_fn + ; run : opts:Coqargs.t -> state:Vernac.State.t -> unit + ; opts : Coqargs.t } + +let init_toploop opts = + let iload_path = build_load_path opts in + let require_libs = require_libs opts in + let stm_options = opts.stm_flags in + let open Vernac.State in + let doc, sid = + Stm.(new_doc + { doc_type = Interactive opts.toplevel_name; + iload_path; require_libs; stm_options; + }) in + let state = { doc; sid; proof = None; time = opts.time } in + Ccompile.load_init_vernaculars opts ~state, opts + +(* To remove in 8.11 *) +let call_coqc args = + let remove str arr = Array.(of_list List.(filter (fun l -> not String.(equal l str)) (to_list arr))) in + let coqc_name = Filename.remove_extension (System.get_toplevel_path "coqc") in + let args = remove "-compile" args in + Unix.execv coqc_name args + +let deprecated_coqc_warning = CWarnings.(create + ~name:"deprecate-compile-arg" + ~category:"toplevel" + ~default:Enabled + (fun opt_name -> Pp.(seq [str "The option "; str opt_name; str" is deprecated, please use coqc."]))) + +let rec coqc_deprecated_check args acc extras = + match extras with + | [] -> acc + | "-o" :: _ :: rem -> + deprecated_coqc_warning "-o"; + coqc_deprecated_check args acc rem + | ("-compile"|"-compile-verbose") :: file :: rem -> + deprecated_coqc_warning "-compile"; + call_coqc args + | x :: rem -> + coqc_deprecated_check args (x::acc) rem + let coqtop_init ~opts extra = init_color opts; CoqworkmgrApi.(init !async_proofs_worker_priority); @@ -266,20 +259,28 @@ let coqtop_init ~opts extra = let coqtop_toplevel = { init = coqtop_init ; run = Coqloop.loop - ; opts = Coqargs.default_opts + ; opts = Coqargs.default } let start_coq custom = - match init_toplevel custom.opts custom.init (List.tl (Array.to_list Sys.argv)) with - (* Batch mode *) - | Some state, opts when not opts.batch_mode -> - custom.run ~opts ~state; - exit 1 - | _ , opts -> - flush_all(); - if opts.output_context then begin - let sigma, env = Pfedit.get_current_context () in - Feedback.msg_notice (Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) - end; - CProfile.print_profile (); - exit 0 + let init_feeder = Feedback.add_feeder Coqloop.coqloop_feed in + (* Init phase *) + let state, opts = + try + let opts, extras = + init_toplevel + ~help:Usage.print_usage_coqtop ~init:default custom.init + (List.tl (Array.to_list Sys.argv)) in + let extras = coqc_deprecated_check Sys.argv [] extras in + if not (CList.is_empty extras) then begin + prerr_endline ("Don't know what to do with "^String.concat " " extras); + prerr_endline "See -help for the list of supported options"; + exit 1 + end; + init_toploop opts + with any -> + flush_all(); + fatal_error_exn any in + Feedback.del_feeder init_feeder; + if not opts.batch then custom.run ~opts ~state; + exit 0 diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index c95d0aca55..300a7a039b 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -12,14 +12,24 @@ [init] is used to do custom command line argument parsing. [run] launches a custom toplevel. *) -open Coqargs + +type init_fn = opts:Coqargs.t -> string list -> Coqargs.t * string list type custom_toplevel = - { init : opts:coq_cmdopts -> string list -> coq_cmdopts * string list - ; run : opts:coq_cmdopts -> state:Vernac.State.t -> unit - ; opts : Coqargs.coq_cmdopts + { init : init_fn + ; run : opts:Coqargs.t -> state:Vernac.State.t -> unit + ; opts : Coqargs.t } +(** [init_toplevel ~help ~init custom_init arg_list] + Common Coq initialization and argument parsing *) +val init_toplevel + : help:(unit -> unit) + -> init:Coqargs.t + -> init_fn + -> string list + -> Coqargs.t * string list + val coqtop_toplevel : custom_toplevel (** The Coq main module. [start custom] will parse the command line, diff --git a/toplevel/g_toplevel.mlg b/toplevel/g_toplevel.mlg index 5aba3d6b0b..7f1cca277e 100644 --- a/toplevel/g_toplevel.mlg +++ b/toplevel/g_toplevel.mlg @@ -21,7 +21,7 @@ type vernac_toplevel = | VernacControl of vernac_control module Toplevel_ : sig - val vernac_toplevel : vernac_toplevel CAst.t Entry.t + val vernac_toplevel : vernac_toplevel CAst.t option Entry.t end = struct let gec_vernac s = Entry.create ("toplevel:" ^ s) let vernac_toplevel = gec_vernac "vernac_toplevel" @@ -34,14 +34,14 @@ open Toplevel_ GRAMMAR EXTEND Gram GLOBAL: vernac_toplevel; vernac_toplevel: FIRST - [ [ IDENT "Drop"; "." -> { CAst.make VernacDrop } - | IDENT "Quit"; "." -> { CAst.make VernacQuit } + [ [ IDENT "Drop"; "." -> { Some (CAst.make VernacDrop) } + | IDENT "Quit"; "." -> { Some (CAst.make VernacQuit) } | IDENT "Backtrack"; n = natural ; m = natural ; p = natural; "." -> - { CAst.make (VernacBacktrack (n,m,p)) } - | cmd = Pvernac.main_entry -> + { Some (CAst.make (VernacBacktrack (n,m,p))) } + | cmd = Pvernac.Vernac_.main_entry -> { match cmd with - | None -> raise Stm.End_of_input - | Some (loc,c) -> CAst.make ~loc (VernacControl c) } + | None -> None + | Some (loc,c) -> Some (CAst.make ~loc (VernacControl c)) } ] ] ; @@ -49,6 +49,8 @@ END { -let parse_toplevel pa = Pcoq.Entry.parse vernac_toplevel pa +let vernac_toplevel pm = + Pvernac.Unsafe.set_tactic_entry pm; + vernac_toplevel } diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index 732744eb42..ddd11fd160 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -2,8 +2,10 @@ Vernac Usage Coqinit Coqargs +Coqcargs G_toplevel Coqloop Ccompile Coqtop WorkerLoop +Coqc diff --git a/toplevel/usage.ml b/toplevel/usage.ml index c43538017c..277f8b7367 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -23,7 +23,7 @@ let machine_readable_version ret = let extra_usage = ref [] let add_to_usage name text = extra_usage := (name,text) :: !extra_usage -let print_usage_channel co command = +let print_usage_common co command = output_string co command; output_string co "Coq options are:\n"; output_string co @@ -48,14 +48,6 @@ let print_usage_channel co command = \n -lv f (idem)\ \n -load-vernac-object f load Coq object file f.vo\ \n -require path load Coq library path and import it (Require Import path.)\ -\n -compile f.v compile Coq file f.v (implies -batch)\ -\n -compile-verbose f.v verbosely compile Coq file f.v (implies -batch)\ -\n -o f.vo use f.vo as the output file name\ -\n -quick quickly compile .v files to .vio files (skip proofs)\ -\n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ -\n into fi.vo\ -\n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ -\n proofs in each fi.vio\ \n\ \n -where print Coq's standard library location and exit\ \n -config, --config print Coq's configuration information and exit\ @@ -66,16 +58,15 @@ let print_usage_channel co command = \n -quiet unset display of extra information (implies -w \"-all\")\ \n -w (w1,..,wn) configure display of warnings\ \n -color (yes|no|auto) configure color output\ +\n -emacs tells Coq it is executed under Emacs\ \n\ \n -q skip loading of rcfile\ \n -init-file f set the rcfile to f\ -\n -batch batch mode (exits just after arguments parsing)\ -\n -boot boot mode (implies -q and -batch)\ +\n -boot boot mode (allows to overload the `Coq` library prefix)\ \n -bt print backtraces (requires configure debug flag)\ \n -debug debug mode (implies -bt)\ \n -diffs (on|off|removed) highlight differences between proof steps\ \n -stm-debug STM debug mode (will trace every transaction)\ -\n -emacs tells Coq it is executed under Emacs\ \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -impredicative-set set sort Set impredicative\ @@ -88,8 +79,8 @@ let print_usage_channel co command = \n (use environment variable\ \n OCAML_GC_STATS=\"/tmp/gclog.txt\"\ \n for full Gc stats dump)\ -\n -bytecode-compiler (yes|no) controls the vm_compute machinery\ -\n -native-compiler (yes|no|ondemand) controls the native_compute machinery\ +\n -bytecode-compiler (yes|no) enable the vm_compute reduction machine\ +\n -native-compiler (yes|no|ondemand) enable the native_compute reduction machine\ \n -h, -help, --help print this list of options\ \n"; List.iter (fun (name, text) -> @@ -101,21 +92,46 @@ let print_usage_channel co command = (* print the usage on standard error *) -let print_usage = print_usage_channel stderr - let print_usage_coqtop () = - print_usage "Usage: coqtop <options>\n\n"; + print_usage_common stderr "Usage: coqtop <options>\n\n"; + output_string stderr "\n\ +coqtop specific options:\ +\n\ +\n -batch batch mode (exits just after argument parsing)\ +\n\ +\nDeprecated options [use coqc instead]:\ +\n\ +\n -compile f.v compile Coq file f.v (implies -batch)\ +\n -compile-verbose f.v verbosely compile Coq file f.v (implies -batch)\ +\n -o f.vo use f.vo as the output file name\ +\n"; flush stderr ; exit 1 let print_usage_coqc () = - print_usage "Usage: coqc <options> <Coq options> file...\n\ -\noptions are:\ -\n -verbose compile verbosely\ -\n -image f specify an alternative executable for Coq\ -\n -opt run the native-code version of Coq\ -\n -byte run the bytecode version of Coq\ -\n -t keep temporary files\n\n"; + print_usage_common stderr "Usage: coqc <options> <Coq options> file..."; + output_string stderr "\n\ +coqc specific options:\ +\n\ +\n -o f.vo use f.vo as the output file name\ +\n -verbose compile and output the input file\ +\n -quick quickly compile .v files to .vio files (skip proofs)\ +\n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ +\n into fi.vo\ +\n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ +\n proofs in each fi.vio\ +\n\ +\nUndocumented:\ +\n -vio2vo [see manual]\ +\n -check-vio-tasks [see manual]\ +\n\ +\nDeprecated options:\ +\n\ +\n -image f specify an alternative executable for Coq\ +\n -opt run the native-code version of Coq\ +\n -byte run the bytecode version of Coq\ +\n -t keep temporary files\ +\n -outputstate file save summary state in file \ +\n"; flush stderr ; exit 1 - diff --git a/toplevel/usage.mli b/toplevel/usage.mli index fbb0117d45..64170adaa4 100644 --- a/toplevel/usage.mli +++ b/toplevel/usage.mli @@ -13,9 +13,6 @@ val version : int -> 'a val machine_readable_version : int -> 'a -(** {6 Prints the usage on the error output, preceeded by a user-provided message. } *) -val print_usage : string -> unit - (** {6 Enable toploop plugins to insert some text in the usage message. } *) val add_to_usage : string -> string -> unit diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index d8465aac27..45ca658857 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -68,10 +68,8 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = if ntip <> `NewTip then anomaly (str "vernac.ml: We got an unfocus operation on the toplevel!"); - (* Due to bug #5363 we cannot use observe here as we should, - it otherwise reveals bugs *) - (* Stm.observe nsid; *) - let ndoc = if check then Stm.finish ~doc else doc in + (* Force the command *) + let ndoc = if check then Stm.observe ~doc nsid else doc in let new_proof = Proof_global.give_me_the_proof_opt () in { state with doc = ndoc; sid = nsid; proof = new_proof; } with reraise -> @@ -92,51 +90,37 @@ let load_vernac_core ~echo ~check ~interactive ~state file = let in_echo = if echo then Some (open_utf8_file_in file) else None in let input_cleanup () = close_in in_chan; Option.iter close_in in_echo in - let in_pa = Pcoq.Parsable.make ~file:(Loc.InFile file) (Stream.of_channel in_chan) in - let rstate = ref state in - (* For beautify, list of parsed sids *) - let rids = ref [] in + let in_pa = + Pcoq.Parsable.make ~file:(Loc.InFile file) (Stream.of_channel in_chan) in let open State in - try - (* we go out of the following infinite loop when a End_of_input is - * raised, which means that we raised the end of the file being loaded *) - while true do - let { CAst.loc; _ } as ast = - Stm.parse_sentence ~doc:!rstate.doc !rstate.sid in_pa - (* If an error in parsing occurs, we propagate the exception - so the caller of load_vernac will take care of it. However, - in the future it could be possible that we want to handle - all the errors as feedback events, thus in this case we - should relay the exception here for convenience. A - possibility is shown below, however we may want to refactor - this code: - - try Stm.parse_sentence !rsid in_pa - with - | any when not is_end_of_input any -> - let (e, info) = CErrors.push any in - let loc = Loc.get_loc info in - let msg = CErrors.iprint (e, info) in - Feedback.msg_error ?loc msg; - iraise (e, info) - *) - in - (* Printing of vernacs *) - Option.iter (vernac_echo ?loc) in_echo; - - checknav_simple ast; - let state = Flags.silently (interp_vernac ~check ~interactive ~state:!rstate) ast in - rids := state.sid :: !rids; - rstate := state; - done; - input_cleanup (); - !rstate, !rids, Pcoq.Parsable.comment_state in_pa + + (* ids = For beautify, list of parsed sids *) + let rec loop state ids = + match + Stm.parse_sentence + ~doc:state.doc ~entry:Pvernac.main_entry state.sid in_pa + with + | None -> + input_cleanup (); + state, ids, Pcoq.Parsable.comment_state in_pa + | Some (loc, ast) -> + let ast = CAst.make ~loc ast in + + (* Printing of AST for -compile-verbose *) + Option.iter (vernac_echo ~loc) in_echo; + + checknav_simple ast; + + let state = + Flags.silently (interp_vernac ~check ~interactive ~state) ast in + + loop state (state.sid :: ids) + in + try loop state [] with any -> (* whatever the exception *) let (e, info) = CErrors.push any in input_cleanup (); - match e with - | Stm.End_of_input -> !rstate, !rids, Pcoq.Parsable.comment_state in_pa - | reraise -> iraise (e, info) + iraise (e, info) let process_expr ~state loc_ast = checknav_deep loc_ast; diff --git a/toplevel/workerLoop.ml b/toplevel/workerLoop.ml index e4e9a87365..f922ad8fee 100644 --- a/toplevel/workerLoop.ml +++ b/toplevel/workerLoop.ml @@ -23,7 +23,7 @@ let arg_init init ~opts extra_args = let start ~init ~loop = let open Coqtop in let custom = { - opts = Coqargs.default_opts; + opts = Coqargs.default; init = arg_init init; run = (fun ~opts:_ ~state:_ -> loop ()); } in diff --git a/vernac/classes.ml b/vernac/classes.ml index 748a2628c5..dd49f09d35 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -269,9 +269,9 @@ let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode ct Pretyping.check_evars env (Evd.from_env env) sigma termtype; let termtype = to_constr sigma termtype in let term = Option.map (to_constr ~abort_on_undefined_evars:false sigma) term in - if not (Evd.has_undefined sigma) && not (Option.is_empty term) then + if not (Evd.has_undefined sigma) && not (Option.is_empty props) then declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype - else if program_mode || refine || Option.is_empty term then + else if program_mode || refine || Option.is_empty props then declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype else CErrors.user_err Pp.(str "Unsolved obligations remaining."); id @@ -376,9 +376,11 @@ let context poly l = | [] -> assert false | [_] -> Evd.const_univ_entry ~poly sigma | _::_::_ -> - (* TODO: explain this little belly dance *) if Lib.sections_are_opened () then + (* More than 1 variable in a section: we can't associate + universes to any specific variable so we declare them + separately. *) begin let uctx = Evd.universe_context_set sigma in Declare.declare_universe_context poly uctx; @@ -386,8 +388,11 @@ let context poly l = else Monomorphic_const_entry Univ.ContextSet.empty end else if poly then + (* Multiple polymorphic axioms: they are all polymorphic the same way. *) Evd.const_univ_entry ~poly sigma else + (* Multiple monomorphic axioms: declare universes separately + to avoid redeclaring them. *) begin let uctx = Evd.universe_context_set sigma in Declare.declare_universe_context poly uctx; diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 3bc4aecdb1..79adefdcf7 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -61,7 +61,8 @@ let make_bullet s = | _ -> assert false let parse_compat_version = let open Flags in function - | "8.9" -> Current + | "8.10" -> Current + | "8.9" -> V8_9 | "8.8" -> V8_8 | "8.7" -> V8_7 | ("8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 8f155adb8a..0dfbba0e83 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -340,7 +340,7 @@ let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c | None -> standard_proof_terminator ?hook compute_guard | Some terminator -> terminator ?hook compute_guard in - let sign = + let sign = match sign with | Some sign -> sign | None -> initialize_named_context_for_proof () diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index a647b2ef73..0e46df2320 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -12,6 +12,27 @@ open Pcoq let uvernac = create_universe "vernac" +type proof_mode = string + +(* Tactic parsing modes *) +let register_proof_mode, find_proof_mode, lookup_proof_mode = + let proof_mode : (string, Vernacexpr.vernac_expr Entry.t) Hashtbl.t = + Hashtbl.create 19 in + let register_proof_mode ename e = Hashtbl.add proof_mode ename e; ename in + let find_proof_mode ename = + try Hashtbl.find proof_mode ename + with Not_found -> + CErrors.anomaly Pp.(str "proof mode not found: " ++ str ename) in + let lookup_proof_mode name = + if Hashtbl.mem proof_mode name then Some name + else None + in + register_proof_mode, find_proof_mode, lookup_proof_mode + +let proof_mode_to_string name = name + +let command_entry_ref = ref None + module Vernac_ = struct let gec_vernac s = Entry.create ("vernac:" ^ s) @@ -39,17 +60,24 @@ module Vernac_ = ] in Pcoq.grammar_extend main_entry None (None, [None, None, rule]) - let command_entry_ref = ref noedit_mode + let select_tactic_entry spec = + match spec with + | None -> noedit_mode + | Some ename -> find_proof_mode ename + let command_entry = Pcoq.Entry.of_parser "command_entry" - (fun strm -> Pcoq.Entry.parse_token_stream !command_entry_ref strm) + (fun strm -> Pcoq.Entry.parse_token_stream (select_tactic_entry !command_entry_ref) strm) end -let main_entry = Vernac_.main_entry +module Unsafe = struct + let set_tactic_entry oname = command_entry_ref := oname +end -let set_command_entry e = Vernac_.command_entry_ref := e -let get_command_entry () = !Vernac_.command_entry_ref +let main_entry proof_mode = + Unsafe.set_tactic_entry proof_mode; + Vernac_.main_entry let () = register_grammar Genredexpr.wit_red_expr (Vernac_.red_expr); diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index b2f8f71462..fa251281dc 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -14,6 +14,8 @@ open Vernacexpr val uvernac : gram_universe +type proof_mode + module Vernac_ : sig val gallina : vernac_expr Entry.t @@ -24,13 +26,31 @@ module Vernac_ : val rec_definition : (fixpoint_expr * decl_notation list) Entry.t val noedit_mode : vernac_expr Entry.t val command_entry : vernac_expr Entry.t + val main_entry : (Loc.t * vernac_control) option Entry.t val red_expr : raw_red_expr Entry.t val hint_info : Hints.hint_info_expr Entry.t end +(* To be removed when the parser is made functional wrt the tactic + * non terminal *) +module Unsafe : sig + (* To let third party grammar entries reuse Vernac_ and + * do something with the proof mode *) + val set_tactic_entry : proof_mode option -> unit +end + (** The main entry: reads an optional vernac command *) -val main_entry : (Loc.t * vernac_control) option Entry.t +val main_entry : proof_mode option -> (Loc.t * vernac_control) option Entry.t + +(** Grammar entry for tactics: proof mode(s). + By default Coq's grammar has an empty entry (non-terminal) for + tactics. A plugin can register its non-terminal by providing a name + and a grammar entry. + + For example the Ltac plugin register the "Classic" grammar + entry for parsing its tactics. + *) -(** Handling of the proof mode entry *) -val get_command_entry : unit -> vernac_expr Entry.t -val set_command_entry : vernac_expr Entry.t -> unit +val register_proof_mode : string -> Vernacexpr.vernac_expr Entry.t -> proof_mode +val lookup_proof_mode : string -> proof_mode option +val proof_mode_to_string : proof_mode -> string diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index b4b893a3fd..ed93267665 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -335,6 +335,7 @@ type execution_phase = | LoadingPrelude | LoadingRcFile | InteractiveLoop + | CompilationPhase let default_phase = ref InteractiveLoop @@ -373,7 +374,9 @@ let pr_phase ?loc () = Some (str "While loading initial state:" ++ Option.cata (fun loc -> fnl () ++ pr_loc loc) (mt ()) loc) | _, Some loc -> Some (pr_loc loc) | ParsingCommandLine, _ - | Initialization, _ -> None + | Initialization, _ + | CompilationPhase, _ -> + None | InteractiveLoop, _ -> (* Note: interactive messages such as "foo is defined" are not located *) None diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index 5f84c5edee..b0e3b3772c 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -60,6 +60,7 @@ type execution_phase = | LoadingPrelude | LoadingRcFile | InteractiveLoop + | CompilationPhase val in_phase : phase:execution_phase -> ('a -> 'b) -> 'a -> 'b diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 26859cd2cf..996fe320f9 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -489,6 +489,28 @@ let vernac_notation ~module_local = let vernac_custom_entry ~module_local s = Metasyntax.declare_custom_entry module_local s +(* Default proof mode, to be set at the beginning of proofs for + programs that cannot be statically classified. *) +let default_proof_mode = ref (Pvernac.register_proof_mode "Noedit" Pvernac.Vernac_.noedit_mode) +let get_default_proof_mode () = !default_proof_mode + +let get_default_proof_mode_opt () = Pvernac.proof_mode_to_string !default_proof_mode +let set_default_proof_mode_opt name = + default_proof_mode := + match Pvernac.lookup_proof_mode name with + | Some pm -> pm + | None -> CErrors.user_err Pp.(str (Format.sprintf "No proof mode named \"%s\"." name)) + +let proof_mode_opt_name = ["Default";"Proof";"Mode"] +let () = + Goptions.declare_string_option Goptions.{ + optdepr = false; + optname = "default proof mode" ; + optkey = proof_mode_opt_name; + optread = get_default_proof_mode_opt; + optwrite = set_default_proof_mode_opt; + } + (***********) (* Gallina *) @@ -2115,13 +2137,9 @@ exception End_of_input let vernac_load interp fname = if Proof_global.there_are_pending_proofs () then CErrors.user_err Pp.(str "Load is not supported inside proofs."); - let interp x = - let proof_mode = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] in - Proof_global.activate_proof_mode proof_mode [@ocaml.warning "-3"]; - interp x in - let parse_sentence = Flags.with_option Flags.we_are_parsing + let parse_sentence proof_mode = Flags.with_option Flags.we_are_parsing (fun po -> - match Pcoq.Entry.parse Pvernac.main_entry po with + match Pcoq.Entry.parse (Pvernac.main_entry proof_mode) po with | Some x -> x | None -> raise End_of_input) in let fname = @@ -2132,7 +2150,15 @@ let vernac_load interp fname = let in_chan = open_utf8_file_in longfname in Pcoq.Parsable.make ~file:(Loc.InFile longfname) (Stream.of_channel in_chan) in begin - try while true do interp (snd (parse_sentence input)) done + try while true do + let proof_mode = + if Proof_global.there_are_pending_proofs () then + Some (get_default_proof_mode ()) + else + None + in + interp (snd (parse_sentence proof_mode input)); + done with End_of_input -> () end; (* If Load left a proof open, we fail too. *) @@ -2312,8 +2338,7 @@ let interp ?proof ~atts ~st c = Aux_file.record_in_aux_at "VernacProof" (tacs^" "^usings); Option.iter vernac_set_end_tac tac; Option.iter vernac_set_used_variables using - | VernacProofMode mn -> unsupported_attributes atts; - Proof_global.set_proof_mode mn [@ocaml.warning "-3"] + | VernacProofMode mn -> unsupported_attributes atts; () (* Extensions *) | VernacExtend (opn,args) -> diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 8d8d7cfcf0..4fbd3849b0 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -10,6 +10,11 @@ val dump_global : Libnames.qualid Constrexpr.or_by_notation -> unit +(** Default proof mode set by `start_proof` *) +val get_default_proof_mode : unit -> Pvernac.proof_mode + +val proof_mode_opt_name : string list + (** Vernacular entries *) val vernac_require : Libnames.qualid option -> bool option -> Libnames.qualid list -> unit diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 05687afd8b..f5cf3401d0 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -29,15 +29,15 @@ type vernac_type = parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; proof_block_detection : proof_block_name option } - (* To be removed *) - | VtProofMode of string (* Queries are commands assumed to be "pure", that is to say, they don't modify the interpretation state. *) | VtQuery + (* Commands that change the current proof mode *) + | VtProofMode of string (* To be removed *) | VtMeta | VtUnknown -and vernac_start = string * opacity_guarantee * Names.Id.t list +and vernac_start = opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 0d43eb1ee8..118907c31b 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -45,15 +45,15 @@ type vernac_type = parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; proof_block_detection : proof_block_name option } - (* To be removed *) - | VtProofMode of string (* Queries are commands assumed to be "pure", that is to say, they don't modify the interpretation state. *) | VtQuery + (* Commands that change the current proof mode *) + | VtProofMode of string (* To be removed *) | VtMeta | VtUnknown -and vernac_start = string * opacity_guarantee * Names.Id.t list +and vernac_start = opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 61540024ef..c691dc8559 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -8,10 +8,30 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +module Parser = struct + + type state = Pcoq.frozen_t + + let init () = Pcoq.freeze ~marshallable:false + + let cur_state () = Pcoq.freeze ~marshallable:false + + let parse ps entry pa = + Pcoq.unfreeze ps; + Flags.with_option Flags.we_are_parsing (fun () -> + try Pcoq.Entry.parse entry pa + with e when CErrors.noncritical e -> + let (e, info) = CErrors.push e in + Exninfo.iraise (e, info)) + () + +end + type t = { - system : States.state; (* summary + libstack *) - proof : Proof_global.t; (* proof state *) - shallow : bool (* is the state trimmed down (libstack) *) + parsing: Parser.state; + system : States.state; (* summary + libstack *) + proof : Proof_global.t; (* proof state *) + shallow : bool; (* is the state trimmed down (libstack) *) } let s_cache = ref None @@ -37,11 +57,13 @@ let freeze_interp_state ~marshallable = { system = update_cache s_cache (States.freeze ~marshallable); proof = update_cache s_proof (Proof_global.freeze ~marshallable); shallow = false; + parsing = Parser.cur_state (); } -let unfreeze_interp_state { system; proof } = +let unfreeze_interp_state { system; proof; parsing } = do_if_not_cached s_cache States.unfreeze system; - do_if_not_cached s_proof Proof_global.unfreeze proof + do_if_not_cached s_proof Proof_global.unfreeze proof; + Pcoq.unfreeze parsing let make_shallow st = let lib = States.lib_of_state st.system in diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index ed20cb935a..581c23386a 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -8,10 +8,21 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +module Parser : sig + type state + + val init : unit -> state + val cur_state : unit -> state + + val parse : state -> 'a Pcoq.Entry.t -> Pcoq.Parsable.t -> 'a + +end + type t = { - system : States.state; (* summary + libstack *) - proof : Proof_global.t; (* proof state *) - shallow : bool (* is the state trimmed down (libstack) *) + parsing: Parser.state; + system : States.state; (* summary + libstack *) + proof : Proof_global.t; (* proof state *) + shallow : bool; (* is the state trimmed down (libstack) *) } val freeze_interp_state : marshallable:bool -> t |