diff options
126 files changed, 9993 insertions, 3909 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index c644059af0..f0403a7318 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -8,14 +8,17 @@ stages: - stage-4 # Only dependencies in stage 1, 2 and 3 - deploy -# When a job has no dependencies, it goes to stage 1. -# Otherwise, we set "needs" and "dependencies" to the same value. +# When a job has no dependencies, it goes to stage 1. Otherwise, we +# set both "needs" and "dependencies". "needs" is a superset of +# "dependencies" that should include all the transitive dependencies. +# "dependencies" only list the previous jobs whose artifact we need to +# keep. # some default values variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-08-08-V01" + CACHEKEY: "bionic_coq-V2019-09-20-V01" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -376,6 +379,9 @@ pkg:nix:deploy:channel: name: cachix url: https://coq.cachix.org only: + refs: # Repeat conditions from pkg:nix:deploy + - master + - /^v.*\..*$/ variables: - $CACHIX_DEPLOYMENT_KEY dependencies: [] @@ -501,62 +507,6 @@ test-suite:egde:dune:dev: # Gitlab doesn't support yet "expire_in: never" so we use the instance default # expire_in: never -test-suite:edge+trunk+make: - stage: stage-1 - dependencies: [] - script: - - opam switch create 4.09.0 --empty - - eval $(opam env) - - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git - - opam update - - opam install ocaml-variants=4.09.0+trunk - - opam pin add -n ocamlfind --dev - - opam install num - - eval $(opam env) - # We avoid problems with warnings: - - ./configure -profile devel -warn-error no - - make -j "$NJOBS" world - - make -j "$NJOBS" test-suite UNIT_TESTS= - variables: - OPAM_SWITCH: base - artifacts: - name: "$CI_JOB_NAME.logs" - when: always - paths: - - test-suite/logs - expire_in: 1 week - allow_failure: true - only: *full-ci - -test-suite:edge+trunk+dune: - stage: stage-1 - dependencies: [] - script: - - opam switch create 4.09.0 --empty - - eval $(opam env) - - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git - - opam update - - opam install ocaml-variants=4.09.0+trunk - - opam pin add -n ocamlfind --dev - - opam pin add dune --dev # ounit lablgtk conf-gtksourceview - - opam install dune num - - 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=ocaml409 - variables: - OPAM_SWITCH: base - artifacts: - name: "$CI_JOB_NAME.logs" - when: always - paths: - - _build/log - - _build/default/test-suite/logs - expire_in: 1 week - allow_failure: true - only: *full-ci - test-suite:base+async: extends: .test-suite-template dependencies: @@ -654,6 +604,7 @@ library:ci-corn: stage: stage-4 needs: - build:edge+flambda + - plugin:ci-bignums - library:ci-math-classes dependencies: - build:edge+flambda @@ -687,6 +638,7 @@ library:ci-math-comp: library:ci-sf: extends: .ci-template + allow_failure: true # Waiting for integration of the fix for #10476 library:ci-stdlib2: extends: .ci-template-flambda @@ -9,7 +9,7 @@ WHAT DO YOU NEED ? - OCaml (version >= 4.05.0) (available at https://ocaml.org/) - (This version of Coq has been tested up to OCaml 4.08.1) + (This version of Coq has been tested up to OCaml 4.09.0) - The Num package, which used to be part of the OCaml standard library, if you are using an OCaml version >= 4.06.0 diff --git a/Makefile.build b/Makefile.build index 610af5fe40..f2e1ca4ea0 100644 --- a/Makefile.build +++ b/Makefile.build @@ -581,7 +581,7 @@ bin/votour.byte: $(VOTOURCMO) ########################################################################### CSDPCERTCMO:=clib/clib.cma $(addprefix plugins/micromega/, \ - mutils.cmo micromega.cmo \ + micromega.cmo mutils.cmo \ sos_types.cmo sos_lib.cmo sos.cmo csdpcert.cmo ) $(CSDPCERT): $(call bestobj, $(CSDPCERTCMO)) diff --git a/Makefile.common b/Makefile.common index dd23d7dd2f..2d1200c071 100644 --- a/Makefile.common +++ b/Makefile.common @@ -155,13 +155,14 @@ LTACCMO:=plugins/ltac/ltac_plugin.cmo plugins/ltac/tauto_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo SSRCMO:=plugins/ssr/ssreflect_plugin.cmo LTAC2CMO:=user-contrib/Ltac2/ltac2_plugin.cmo +ZIFYCMO:=plugins/micromega/zify_plugin.cmo PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(MICROMEGACMO) \ $(RINGCMO) \ $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(SYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) $(LTAC2CMO) + $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) $(LTAC2CMO) $(ZIFYCMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) diff --git a/Makefile.dune b/Makefile.dune index 88055d62dc..19e8a770bd 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -6,7 +6,7 @@ .PHONY: quickbyte quickopt quickide # Partial / quick developer targets .PHONY: refman-html stdlib-html apidoc # Documentation targets .PHONY: test-suite release # Accessory targets -.PHONY: ocheck trunk ireport clean # Maintenance targets +.PHONY: ocheck ireport clean # Maintenance targets # use DUNEOPT=--display=short for a more verbose build # DUNEOPT=--display=short @@ -36,7 +36,6 @@ help: @echo " - release: build Coq in release mode" @echo "" @echo " - ocheck: build for all supported OCaml versions [requires OPAM]" - @echo " - trunk: build with a configuration compatible with OCaml trunk" @echo " - ireport: build with optimized flambda settings and emit an inline report" @echo " - clean: remove build directory and autogenerated files" @echo " - help: show this message" @@ -103,11 +102,6 @@ release: voboot ocheck: voboot dune build $(DUNEOPT) @install --workspace=dev/dune-workspace.all -trunk: - dune build $(DUNEOPT) --profile=ocaml409 @vodeps - dune exec coq_dune $(BUILD_CONTEXT)/.vfiles.d - dune build $(DUNEOPT) --profile=ocaml409 coq.install coqide-server.install - ireport: dune clean dune build $(DUNEOPT) @vodeps --profile=ireport diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 84f080cc73..38ea915f3c 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -72,8 +72,8 @@ jobs: opam list displayName: 'Install OCaml dependencies' env: - COMPILER: "4.08.1" - FINDLIB_VER: ".1.8.0" + COMPILER: "4.09.0" + FINDLIB_VER: ".1.8.1" OPAMYES: "true" - script: | diff --git a/clib/hashset.ml b/clib/hashset.ml index debfc15c9a..b7a245aed1 100644 --- a/clib/hashset.ml +++ b/clib/hashset.ml @@ -118,8 +118,8 @@ module Make (E : EqType) = t.table.(t.rover) <- emptybucket; t.hashes.(t.rover) <- [| |]; end else begin - Obj.truncate (Obj.repr bucket) (prev_len + 1); - Obj.truncate (Obj.repr hbucket) prev_len; + Obj.truncate (Obj.repr bucket) (prev_len + 1) [@ocaml.alert "--deprecated"]; + Obj.truncate (Obj.repr hbucket) prev_len [@ocaml.alert "--deprecated"]; end; if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1; end; diff --git a/dev/ci/azure-opam.sh b/dev/ci/azure-opam.sh index 03ce5a6b5d..ee6c62673b 100755 --- a/dev/ci/azure-opam.sh +++ b/dev/ci/azure-opam.sh @@ -2,7 +2,7 @@ set -e -x -OPAM_VARIANT=ocaml-variants.4.08.1+mingw64c +OPAM_VARIANT=ocaml-variants.4.09.0+mingw64c wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz tar -xf opam64.tar.xz diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 7175b5ffd5..edca83c6ef 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-08-08-V01" +# CACHEKEY: "bionic_coq-V2019-09-20-V01" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -37,12 +37,12 @@ ENV COMPILER="4.05.0" # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.10.0 ounit.2.0.8 odoc.1.4.0" \ +ENV BASE_OPAM="num ocamlfind.1.8.1 dune.1.11.3 ounit.2.0.8 odoc.1.4.2" \ CI_OPAM="menhir.20190626 ocamlgraph.1.8.8" \ - BASE_ONLY_OPAM="elpi.1.4.0" + BASE_ONLY_OPAM="elpi.1.7.0" # BASE switch; CI_OPAM contains Coq's CI dependencies. -ENV COQIDE_OPAM="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" +ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.0.beta6" # Must add this to COQIDE_OPAM{,_EDGE} when we update the opam # packages "lablgtk3-gtksourceview3" @@ -56,9 +56,9 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ opam install $BASE_OPAM # EDGE switch -ENV COMPILER_EDGE="4.08.1" \ - COQIDE_OPAM_EDGE="cairo2.0.6 lablgtk3-sourceview3.3.0.beta6" \ - BASE_OPAM_EDGE="dune-release.1.3.1" +ENV COMPILER_EDGE="4.09.0" \ + COQIDE_OPAM_EDGE="cairo2.0.6.1 lablgtk3-sourceview3.3.0.beta6" \ + BASE_OPAM_EDGE="dune-release.1.3.2" # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. diff --git a/dev/ci/user-overlays/10416-gares-elpi-14.sh b/dev/ci/user-overlays/10416-gares-elpi-14.sh deleted file mode 100644 index 52d1005a7d..0000000000 --- a/dev/ci/user-overlays/10416-gares-elpi-14.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10416" ] || [ "$CI_BRANCH" = "elpi-14" ]; then - - elpi_CI_REF="coq-master-elpi-14" - elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10727-ejgallego-library+to_vernac_step2.sh b/dev/ci/user-overlays/10727-ejgallego-library+to_vernac_step2.sh new file mode 100644 index 0000000000..a5f6551474 --- /dev/null +++ b/dev/ci/user-overlays/10727-ejgallego-library+to_vernac_step2.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10727" ] || [ "$CI_BRANCH" = "library+to_vernac_step2" ]; then + + elpi_CI_REF=library+to_vernac_step2 + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + +fi diff --git a/dev/ci/user-overlays/10738-gares-elpi1.7.sh b/dev/ci/user-overlays/10738-gares-elpi1.7.sh new file mode 100644 index 0000000000..8922badf90 --- /dev/null +++ b/dev/ci/user-overlays/10738-gares-elpi1.7.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10738" ] || [ "$CI_BRANCH" = "elpi1.7" ]; then + + elpi_CI_REF="coq-master+elpi1.7" + elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi + +fi diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index d00c8cb11a..78d7061259 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -129,6 +129,18 @@ Universes GH issue number: #9294 risk: moderate risk to be activated by chance + component: universe polymorphism, asynchronous proofs + summary: universe constraints erroneously discarded when forcing an asynchronous proof containing delayed monomorphic constraints inside a universe polymorphic section + introduced: between 8.4 and 8.5 by merging the asynchronous proofs feature branch and universe polymorphism one + impacted released: V8.5-V8.10 + impacted development branches: none + impacted coqchk versions: immune + fixed in: PR#10664 + found by: Pédrot + exploit: no test + GH issue number: none + risk: unlikely to be triggered in interactive mode, not present in batch mode (i.e. coqc) + Primitive projections component: primitive projections, guard condition diff --git a/dev/dune-workspace.all b/dev/dune-workspace.all index 7e53f13e45..28e8773e25 100644 --- a/dev/dune-workspace.all +++ b/dev/dune-workspace.all @@ -1,7 +1,7 @@ -(lang dune 1.4) +(lang dune 1.10) ; Add custom flags here. Default developer profile is `dev` (context (opam (switch 4.05.0))) (context (opam (switch 4.05.0+32bit))) -(context (opam (switch 4.08.1))) -(context (opam (switch 4.08.1+flambda))) +(context (opam (switch 4.09.0))) +(context (opam (switch 4.09.0+flambda))) diff --git a/doc/changelog/01-kernel/10664-sections-stack-in-kernel.rst b/doc/changelog/01-kernel/10664-sections-stack-in-kernel.rst new file mode 100644 index 0000000000..bac08d12ea --- /dev/null +++ b/doc/changelog/01-kernel/10664-sections-stack-in-kernel.rst @@ -0,0 +1,6 @@ +- Section data is now part of the kernel. Solves a soundness issue + in interactive mode where global monomorphic universe constraints would be + dropped when forcing a delayed opaque proof inside a polymorphic section. Also + relaxes the nesting criterion for sections, as polymorphic sections can now + appear inside a monomorphic one + (#10664, <https://github.com/coq/coq/pull/10664> by Pierre-Marie Pédrot). diff --git a/doc/changelog/02-specification-language/10758-fix-10757.rst b/doc/changelog/02-specification-language/10758-fix-10757.rst new file mode 100644 index 0000000000..4cce26aedc --- /dev/null +++ b/doc/changelog/02-specification-language/10758-fix-10757.rst @@ -0,0 +1,5 @@ +- ``Program Fixpoint`` now uses ``ex`` and ``sig`` to make telescopes + involving ``Prop`` types (`#10758 + <https://github.com/coq/coq/pull/10758>`_, by Gaëtan Gilbert, fixing + `#10757 <https://github.com/coq/coq/issues/10757>`_ reported by + Xavier Leroy). diff --git a/doc/changelog/04-tactics/09856-zify.rst b/doc/changelog/04-tactics/09856-zify.rst new file mode 100644 index 0000000000..6b9143c77b --- /dev/null +++ b/doc/changelog/04-tactics/09856-zify.rst @@ -0,0 +1,7 @@ +- Reimplementation of the :tacn:`zify` tactic. The tactic is more efficient and copes with dependent hypotheses. + It can also be extended by redefining the tactic ``zify_post_hook``. + (`#9856 <https://github.com/coq/coq/pull/9856>`_ fixes + `#8898 <https://github.com/coq/coq/issues/8898>`_, + `#7886 <https://github.com/coq/coq/issues/7886>`_, + `#9848 <https://github.com/coq/coq/issues/9848>`_ and + `#5155 <https://github.com/coq/coq/issues/5155>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/10765-micromega-caches.rst b/doc/changelog/04-tactics/10765-micromega-caches.rst new file mode 100644 index 0000000000..12d8f68e63 --- /dev/null +++ b/doc/changelog/04-tactics/10765-micromega-caches.rst @@ -0,0 +1,3 @@ +- Introduction of flags :flag:`Lia Cache`, :flag:`Nia Cache` and :flag:`Nra Cache`. + (see `#10772 <https://github.com/coq/coq/issues/10772>`_ for use case) + (`#10765 <https://github.com/coq/coq/pull/10765>`_ fixes `#10772 <https://github.com/coq/coq/issues/10772>`_ , by Frédéric Besson). diff --git a/doc/changelog/04-tactics/10774-zify-Z_to_N.rst b/doc/changelog/04-tactics/10774-zify-Z_to_N.rst new file mode 100644 index 0000000000..ed46cb101e --- /dev/null +++ b/doc/changelog/04-tactics/10774-zify-Z_to_N.rst @@ -0,0 +1,3 @@ +- The :tacn:`zify` tactic is now aware of `Z.to_N`. + (`#10774 <https://github.com/coq/coq/pull/10774>`_ fixes + `#9162 <https://github.com/coq/coq/issues/9162>`_, by Kazuhiko Sakaguchi). diff --git a/doc/changelog/04-tactics/10806-fix-micromega-wrt-projections.rst b/doc/changelog/04-tactics/10806-fix-micromega-wrt-projections.rst new file mode 100644 index 0000000000..d6fc724415 --- /dev/null +++ b/doc/changelog/04-tactics/10806-fix-micromega-wrt-projections.rst @@ -0,0 +1,4 @@ +- Micromega tactics (:tacn:`lia`, :tacn:`nia`, etc) are no longer confused by + primitive projections (`#10806 <https://github.com/coq/coq/pull/10806>`_, + fixes `#9512 <https://github.com/coq/coq/issues/9512>`_ + by Vincent Laporte). diff --git a/doc/changelog/10-standard-library/09772-ordered_type-hint-db.rst b/doc/changelog/10-standard-library/09772-ordered_type-hint-db.rst new file mode 100644 index 0000000000..7babcdb6f1 --- /dev/null +++ b/doc/changelog/10-standard-library/09772-ordered_type-hint-db.rst @@ -0,0 +1,4 @@ +- Moved the `auto` hints of the `OrderedType` module into a new `ordered_type` + database + (`#9772 <https://github.com/coq/coq/pull/9772>`_, + by Vincent Laporte). diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index e56b36caad..4a691bde3a 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -9,9 +9,11 @@ Short description of the tactics -------------------------------- The Psatz module (``Require Import Psatz.``) gives access to several -tactics for solving arithmetic goals over :math:`\mathbb{Z}`, :math:`\mathbb{Q}`, and :math:`\mathbb{R}` [#]_. -It also possible to get the tactics for integers by a ``Require Import Lia``, -rationals ``Require Import Lqa`` and reals ``Require Import Lra``. +tactics for solving arithmetic goals over :math:`\mathbb{Q}`, +:math:`\mathbb{R}`, and :math:`\mathbb{Z}` but also :g:`nat` and +:g:`N`. It also possible to get the tactics for integers by a +``Require Import Lia``, rationals ``Require Import Lqa`` and reals +``Require Import Lra``. + :tacn:`lia` is a decision procedure for linear integer arithmetic; + :tacn:`nia` is an incomplete proof procedure for integer non-linear @@ -23,7 +25,7 @@ rationals ``Require Import Lqa`` and reals ``Require Import Lra``. ``n`` is an optional integer limiting the proof search depth, is an incomplete proof procedure for non-linear arithmetic. It is based on John Harrison’s HOL Light - driver to the external prover `csdp` [#]_. Note that the `csdp` driver is + driver to the external prover `csdp` [#csdp]_. Note that the `csdp` driver is generating a *proof cache* which makes it possible to rerun scripts even without `csdp`. @@ -33,6 +35,18 @@ rationals ``Require Import Lqa`` and reals ``Require Import Lra``. use the Simplex method for solving linear goals. If it is not set, the decision procedures are using Fourier elimination. +.. flag:: Lia Cache + + This option (set by default) instructs :tacn:`lia` to cache its results in the file `.lia.cache` + +.. flag:: Nia Cache + + This option (set by default) instructs :tacn:`nia` to cache its results in the file `.nia.cache` + +.. flag:: Nra Cache + + This option (set by default) instructs :tacn:`nra` to cache its results in the file `.nra.cache` + The tactics solve propositional formulas parameterized by atomic arithmetic expressions interpreted over a domain :math:`D \in \{\mathbb{Z},\mathbb{Q},\mathbb{R}\}`. @@ -78,7 +92,7 @@ closed under the following rules: \end{array}` The following theorem provides a proof principle for checking that a -set of polynomial inequalities does not have solutions [#]_. +set of polynomial inequalities does not have solutions [#fnpsatz]_. .. _psatz_thm: @@ -111,32 +125,21 @@ and checked to be :math:`-1`. The deductive power of :tacn:`lra` overlaps with the one of :tacn:`field` tactic *e.g.*, :math:`x = 10 * x / 10` is solved by :tacn:`lra`. - `lia`: a tactic for linear integer arithmetic --------------------------------------------- .. tacn:: lia :name: lia - This tactic offers an alternative to the :tacn:`omega` tactic. Roughly - speaking, the deductive power of lia is the combined deductive power of - :tacn:`ring_simplify` and :tacn:`omega`. However, it solves linear goals - that :tacn:`omega` does not solve, such as the following so-called *omega - nightmare* :cite:`TheOmegaPaper`. + This tactic solves linear goals over :g:`Z` by searching for *linear* refutations and cutting planes. + :tacn:`lia` provides support for :g:`Z`, :g:`nat`, :g:`positive` and :g:`N` by pre-processing via the :tacn:`zify` tactic. -.. coqdoc:: - - Goal forall x y, - 27 <= 11 * x + 13 * y <= 45 -> - -10 <= 7 * x - 9 * y <= 4 -> False. - -The estimation of the relative efficiency of :tacn:`lia` *vs* :tacn:`omega` is under evaluation. High level view of `lia` ~~~~~~~~~~~~~~~~~~~~~~~~ Over :math:`\mathbb{R}`, *positivstellensatz* refutations are a complete proof -principle [#]_. However, this is not the case over :math:`\mathbb{Z}`. Actually, +principle [#mayfail]_. However, this is not the case over :math:`\mathbb{Z}`. Actually, *positivstellensatz* refutations are not even sufficient to decide linear *integer* arithmetic. The canonical example is :math:`2 * x = 1 -> \mathtt{False}` which is a theorem of :math:`\mathbb{Z}` but not a theorem of :math:`{\mathbb{R}}`. To remedy this @@ -249,21 +252,55 @@ cone expression :math:`2 \times (x-1) + (\mathbf{x-1}) \times (\mathbf{x−1}) + belongs to :math:`\mathit{Cone}({−x^2,x -1})`. Moreover, by running :tacn:`ring` we 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. +`zify`: pre-processing of arithmetic goals +------------------------------------------ + +.. tacn:: zify + :name: zify + + This tactic is internally called by :tacn:`lia` to support additional types e.g., :g:`nat`, :g:`positive` and :g:`N`. + By requiring the module ``ZifyBool``, the boolean type :g:`bool` and some comparison operators are also supported. + :tacn:`zify` can also be extended by rebinding the tactic `Zify.zify_post_hook` that is run immediately after :tacn:`zify`. + + + To support :g:`Z.div` and :g:`Z.modulo`: ``Ltac Zify.zify_post_hook ::= Z.div_mod_to_equations``. + + To support :g:`Z.quot` and :g:`Z.rem`: ``Ltac Zify.zify_post_hook ::= Z.quot_rem_to_equations``. + + To support :g:`Z.div`, :g:`Z.modulo`, :g:`Z.quot`, and :g:`Z.rem`: ``Ltac Zify.zify_post_hook ::= Z.to_euclidean_division_equations``. + + +.. cmd:: Show Zify InjTyp + :name: Show Zify InjTyp + + This command shows the list of types that can be injected into :g:`Z`. + +.. cmd:: Show Zify BinOp + :name: Show Zify BinOp + + This command shows the list of binary operators processed by :tacn:`zify`. + +.. cmd:: Show Zify BinRel + :name: Show Zify BinRel + + This command shows the list of binary relations processed by :tacn:`zify`. + + +.. cmd:: Show Zify UnOp + :name: Show Zify UnOp + + This command shows the list of unary operators processed by :tacn:`zify`. + +.. cmd:: Show Zify CstOp + :name: Show Zify CstOp + + This command shows the list of constants processed by :tacn:`zify`. + +.. cmd:: Show Zify Spec + :name: Show Zify Spec + + This command shows the list of operators over :g:`Z` that are compiled using their specification e.g., :g:`Z.min`. + +.. [#csdp] Sources and binaries can be found at https://projects.coin-or.org/Csdp +.. [#fnpsatz] Variants deal with equalities and strict inequalities. +.. [#mayfail] In practice, the oracle might fail to produce such a refutation. .. comment in original TeX: .. %% \paragraph{The {\tt sos} tactic} -- where {\tt sos} stands for \emph{sum of squares} -- tries to prove that a diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 7e698bfb66..905068e316 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -147,14 +147,7 @@ Many other commands support the ``Polymorphic`` flag, including: - :cmd:`Section` will locally set the polymorphism flag inside the section. - ``Variables``, ``Context``, ``Universe`` and ``Constraint`` in a section support - polymorphism. This means that the universe variables (and associated - constraints) are discharged polymorphically over definitions that use - them. In other words, two definitions in the section sharing a common - variable will both get parameterized by the universes produced by the - variable declaration. This is in contrast to a “mononorphic” variable - which introduces global universes and constraints, making the two - definitions depend on the *same* global universes associated to the - variable. + polymorphism. See :ref:`universe-polymorphism-in-sections` for more details. - :cmd:`Hint Resolve` and :cmd:`Hint Rewrite` will use the auto/rewrite hint polymorphically, not at a single instance. @@ -375,9 +368,7 @@ to universes and explicitly instantiate polymorphic definitions. as well. Global universe names live in a separate namespace. The command supports the ``Polymorphic`` flag only in sections, meaning the universe quantification will be discharged on each section definition - independently. One cannot mix polymorphic and monomorphic - declarations in the same section. - + independently. .. cmd:: Constraint @universe_constraint Polymorphic Constraint @universe_constraint @@ -510,3 +501,51 @@ underscore or by omitting the annotation to a polymorphic definition. Lemma baz : Type@{outer}. Proof. exact Type@{inner}. Qed. About baz. + +.. _universe-polymorphism-in-sections: + +Universe polymorphism and sections +---------------------------------- + +:cmd:`Variables`, :cmd:`Context`, :cmd:`Universe` and +:cmd:`Constraint` in a section support polymorphism. This means that +the universe variables and their associated constraints are discharged +polymorphically over definitions that use them. In other words, two +definitions in the section sharing a common variable will both get +parameterized by the universes produced by the variable declaration. +This is in contrast to a “mononorphic” variable which introduces +global universes and constraints, making the two definitions depend on +the *same* global universes associated to the variable. + +It is possible to mix universe polymorphism and monomorphism in +sections, except in the following ways: + +- no monomorphic constraint may refer to a polymorphic universe: + + .. coqtop:: all reset + + Section Foo. + + Polymorphic Universe i. + Fail Constraint i = i. + + This includes constraints implictly declared by commands such as + :cmd:`Variable`, which may as a such need to be used with universe + polymorphism activated (locally by attribute or globally by option): + + .. coqtop:: all + + Fail Variable A : (Type@{i} : Type). + Polymorphic Variable A : (Type@{i} : Type). + + (in the above example the anonymous :g:`Type` constrains polymorphic + universe :g:`i` to be strictly smaller.) + +- no monomorphic constant or inductive may be declared if polymorphic + universes or universe constraints are present. + +These restrictions are required in order to produce a sensible result +when closing the section (the requirement on constants and inductives +is stricter than the one on constraints, because constants and +inductives are abstracted by *all* the section's polymorphic universes +and constraints). diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 46c349f3e7..c910136406 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3961,6 +3961,9 @@ At Coq startup, only the core database is nonempty and can be used. :fset: internal database for the implementation of the ``FSets`` library. +:ordered_type: lemmas about ordered types (as defined in the legacy ``OrderedType`` module), + mainly used in the ``FSets`` and ``FMaps`` libraries. + You are advised not to put your own hints in the core database, but use one or several databases specific to your development. diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index 46175e37ed..bc4d8b95ab 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -42,6 +42,10 @@ plugins/micromega/Tauto.v plugins/micromega/VarMap.v plugins/micromega/ZCoeff.v plugins/micromega/ZMicromega.v +plugins/micromega/ZifyInst.v +plugins/micromega/ZifyBool.v +plugins/micromega/ZifyClasses.v +plugins/micromega/Zify.v plugins/nsatz/Nsatz.v plugins/omega/Omega.v plugins/omega/OmegaLemmas.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index cc91776a4d..d1b98b94a3 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -515,7 +515,9 @@ through the <tt>Require Import</tt> command.</p> <dd> theories/Reals/Rdefinitions.v theories/Reals/ConstructiveReals.v + theories/Reals/ConstructiveRealsMorphisms.v theories/Reals/ConstructiveCauchyReals.v + theories/Reals/ConstructiveCauchyRealsMult.v theories/Reals/Raxioms.v theories/Reals/ConstructiveRIneq.v theories/Reals/ConstructiveRealsLUB.v @@ -4,9 +4,7 @@ (release (flags :standard -rectypes) (ocamlopt_flags -O3 -unbox-closures)) (ireport (flags :standard -rectypes -w -9-27-40+60) - (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report)) - (ocaml409 - (flags :standard -strict-sequence -strict-formats -keep-locs -rectypes -w -9-27+40+60 -warn-error -5 -alert --deprecated))) + (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report))) ; Information about flags for release mode: ; diff --git a/engine/uState.ml b/engine/uState.ml index cb40e6eadd..d93ccafcf0 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -178,6 +178,7 @@ exception UniversesDiffer let drop_weak_constraints = ref false + let process_universe_constraints ctx cstrs = let open UnivSubst in let open UnivProblem in @@ -236,22 +237,21 @@ let process_universe_constraints ctx cstrs = else match cst with | ULe (l, r) -> - if UGraph.check_leq univs l r then - (* Keep Prop/Set <= var around if var might be instantiated by prop or set - later. *) - match Universe.level l, Universe.level r with - | Some l, Some r -> - Constraint.add (l, Le, r) local - | _ -> local - else - begin match Universe.level r with - | None -> user_err Pp.(str "Algebraic universe on the right") - | Some r' -> - if Level.is_small r' then + begin match Univ.Universe.level r with + | None -> + if UGraph.check_leq univs l r then local + else user_err Pp.(str "Algebraic universe on the right") + | Some r' -> + if Level.is_small r' then if not (Universe.is_levels l) - then + then (* l contains a +1 and r=r' small so l <= r impossible *) raise (UniverseInconsistency (Le, l, r, None)) else + if UGraph.check_leq univs l r then match Univ.Universe.level l with + | Some l -> + Univ.Constraint.add (l, Le, r') local + | None -> local + else let levels = Universe.levels l in let fold l' local = let l = Universe.make l' in @@ -260,8 +260,12 @@ let process_universe_constraints ctx cstrs = else raise (UniverseInconsistency (Le, l, r, None)) in LSet.fold fold levels local - else - enforce_leq l r local + else + match Univ.Universe.level l with + | Some l -> + Univ.Constraint.add (l, Le, r') local + | None -> + if UGraph.check_leq univs l r then local else enforce_leq l r local end | ULub (l, r) -> equalize_variables true (Universe.make l) l (Universe.make r) r local diff --git a/interp/modintern.ml b/interp/modintern.ml index 955288244e..ddf5b2d7b1 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -12,7 +12,6 @@ open Declarations open Libnames open Constrexpr open Constrintern -open Declaremods type module_internalization_error = | NotAModuleNorModtype of string @@ -21,9 +20,11 @@ type module_internalization_error = exception ModuleInternalizationError of module_internalization_error +type module_kind = Module | ModType | ModAny + let error_not_a_module_loc kind loc qid = let s = string_of_qualid qid in - let e = let open Declaremods in match kind with + let e = match kind with | Module -> Modops.ModuleTypingError (Modops.NotAModule s) | ModType -> Modops.ModuleTypingError (Modops.NotAModuleType s) | ModAny -> ModuleInternalizationError (NotAModuleNorModtype s) @@ -46,7 +47,6 @@ let error_application_to_module_type loc = it is equal to the input kind when this one isn't ModAny. *) let lookup_module_or_modtype kind qid = - let open Declaremods in let loc = qid.CAst.loc in try if kind == ModType then raise Not_found; diff --git a/interp/modintern.mli b/interp/modintern.mli index 75ab38c64a..72695a680e 100644 --- a/interp/modintern.mli +++ b/interp/modintern.mli @@ -28,5 +28,7 @@ exception ModuleInternalizationError of module_internalization_error kind is never ModAny, and it is equal to the input kind when this one isn't ModAny. *) +type module_kind = Module | ModType | ModAny + val interp_module_ast : - env -> Declaremods.module_kind -> module_ast -> module_struct_entry * Declaremods.module_kind * Univ.ContextSet.t + env -> module_kind -> module_ast -> module_struct_entry * module_kind * Univ.ContextSet.t diff --git a/pretyping/inferCumulativity.ml b/kernel/inferCumulativity.ml index ed069eace0..3b8c2cd788 100644 --- a/pretyping/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -77,7 +77,7 @@ let infer_sort cv_pb variances s = | CUMUL -> LSet.fold infer_level_leq (Universe.levels (Sorts.univ_of_sort s)) variances -let infer_table_key infos variances c = +let infer_table_key variances c = let open Names in match c with | ConstKey (_, u) -> @@ -103,7 +103,7 @@ let rec infer_fterm cv_pb infos variances hd stk = | FRel _ -> infer_stack infos variances stk | FInt _ -> infer_stack infos variances stk | FFlex fl -> - let variances = infer_table_key infos variances fl in + let variances = infer_table_key variances fl in infer_stack infos variances stk | FProj (_,c) -> let variances = infer_fterm CONV infos variances c [] in @@ -152,7 +152,7 @@ and infer_stack infos variances (stk:CClosure.stack) = | Zfix (fx,a) -> let variances = infer_fterm CONV infos variances fx [] in infer_stack infos variances a - | ZcaseT (ci,p,br,e) -> + | ZcaseT (_, p, br, e) -> let variances = infer_fterm CONV infos variances (mk_clos e p) [] in infer_vect infos variances (Array.map (mk_clos e) br) | Zshift _ -> variances @@ -195,7 +195,7 @@ let infer_inductive_core env params entries uctx = Array.fold_left (fun variances u -> LMap.add u IrrelevantI variances) LMap.empty uarray in - let env, params = Typeops.check_context env params in + let env, _ = Typeops.check_context env params in let variances = List.fold_left (fun variances entry -> let variances = infer_arity_constructor true env variances entry.mind_entry_arity @@ -213,9 +213,8 @@ let infer_inductive_core env params entries uctx = let infer_inductive env mie = let open Entries in - let { mind_entry_params = params; - mind_entry_inds = entries; } = mie - in + let params = mie.mind_entry_params in + let entries = mie.mind_entry_inds in let variances = match mie.mind_entry_variance with | None -> None diff --git a/pretyping/inferCumulativity.mli b/kernel/inferCumulativity.mli index a234e334d1..a234e334d1 100644 --- a/pretyping/inferCumulativity.mli +++ b/kernel/inferCumulativity.mli diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 59c1d5890f..20e742d7f8 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -43,9 +43,11 @@ Inductive Typeops IndTyping Indtypes +InferCumulativity Cooking Term_typing Subtyping Mod_typing Nativelibrary +Section Safe_typing diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index e54118c775..f788832d5b 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -96,14 +96,14 @@ let mk_accu (a : atom) : t = else let data = { data with acc_arg = x :: data.acc_arg } in let ans = Obj.repr (accumulate data) in - let () = Obj.set_tag ans accumulate_tag in + let () = Obj.set_tag ans accumulate_tag [@ocaml.alert "--deprecated"] in ans in let acc = { acc_atm = a; acc_arg = [] } in let ans = Obj.repr (accumulate acc) in (** FIXME: use another representation for accumulators, this causes naked pointers. *) - let () = Obj.set_tag ans accumulate_tag in + let () = Obj.set_tag ans accumulate_tag [@ocaml.alert "--deprecated"] in (Obj.obj ans : t) let get_accu (k : accumulator) = diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index e256466112..f0ffd2e073 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -142,11 +142,6 @@ let force_constraints _access { opaque_val = prfs; opaque_dir = odp; _ } = funct get_mono (Future.force cu) else Univ.ContextSet.empty -let get_direct_constraints = function -| Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") -| Direct (_, cu) -> - Future.chain cu get_mono - module FMap = Future.UUIDMap let dump ?(except = Future.UUIDSet.empty) { opaque_val = otab; opaque_len = n; _ } = diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 7c53656c3c..758a9f5107 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -63,7 +63,6 @@ type indirect_accessor = { indirect opaque accessor given as an argument. *) val force_proof : indirect_accessor -> opaquetab -> opaque -> constr * unit delayed_universes val force_constraints : indirect_accessor -> opaquetab -> opaque -> Univ.ContextSet.t -val get_direct_constraints : opaque -> Univ.ContextSet.t Future.computation val subst_opaque : substitution -> opaque -> opaque diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 6970a11e72..4268f0a602 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -113,8 +113,16 @@ type library_info = DirPath.t * vodigest (** Functor and funsig parameters, most recent first *) type module_parameters = (MBId.t * module_type_body) list +(** Part of the safe_env at a section opening time to be backtracked *) +type section_data = { + rev_env : Environ.env; + rev_univ : Univ.ContextSet.t; + rev_objlabels : Label.Set.t; +} + type safe_environment = { env : Environ.env; + sections : section_data Section.t; modpath : ModPath.t; modvariant : modvariant; modresolver : Mod_subst.delta_resolver; @@ -151,6 +159,7 @@ let empty_environment = revstruct = []; modlabels = Label.Set.empty; objlabels = Label.Set.empty; + sections = Section.empty; future_cst = []; univ = Univ.ContextSet.empty; engagement = None; @@ -317,14 +326,23 @@ let universes_of_private eff = let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env +let sections_of_safe_env senv = senv.sections + type constraints_addition = | Now of Univ.ContextSet.t | Later of Univ.ContextSet.t Future.computation let push_context_set poly cst senv = - { senv with - env = Environ.push_context_set ~strict:(not poly) cst senv.env; - univ = Univ.ContextSet.union cst senv.univ } + if Univ.ContextSet.is_empty cst then senv + else + let sections = + if Section.is_empty senv.sections then senv.sections + else Section.push_constraints cst senv.sections + in + { senv with + env = Environ.push_context_set ~strict:(not poly) cst senv.env; + univ = Univ.ContextSet.union cst senv.univ; + sections } let add_constraints cst senv = match cst with @@ -386,7 +404,7 @@ let check_current_library dir senv = match senv.modvariant with (** When operating on modules, we're normally outside sections *) let check_empty_context senv = - assert (Environ.empty_context senv.env) + assert (Environ.empty_context senv.env && Section.is_empty senv.sections) (** When adding a parameter to the current module/modtype, it must have been freshly started *) @@ -433,19 +451,30 @@ let safe_push_named d env = with Not_found -> () in Environ.push_named d env - let push_named_def (id,de) senv = + let sections = Section.push_local senv.sections in let c, r, typ = Term_typing.translate_local_def senv.env id de in let x = Context.make_annot id r in let env'' = safe_push_named (LocalDef (x, c, typ)) senv.env in - { senv with env = env'' } + { senv with sections; env = env'' } let push_named_assum (x,t) senv = + let sections = Section.push_local senv.sections in let t, r = Term_typing.translate_local_assum senv.env t in let x = Context.make_annot x r in let env'' = safe_push_named (LocalAssum (x,t)) senv.env in - {senv with env=env''} - + { senv with sections; env = env'' } + +let push_section_context (nas, ctx) senv = + let sections = Section.push_context (nas, ctx) senv.sections in + let senv = { senv with sections } in + let ctx = Univ.ContextSet.of_context ctx in + (* We check that the universes are fresh. FIXME: This should be done + implicitly, but we have to work around the API. *) + let () = assert (Univ.LSet.for_all (fun u -> not (Univ.LSet.mem u (fst senv.univ))) (fst ctx)) in + { senv with + env = Environ.push_context_set ~strict:false ctx senv.env; + univ = Univ.ContextSet.union ctx senv.univ } (** {6 Insertion of new declarations to current environment } *) @@ -527,8 +556,19 @@ let add_field ?(is_include=false) ((l,sfb) as field) gn senv = | SFBmodule mb, M -> Modops.add_module mb senv.env | _ -> assert false in + let sections = match sfb, gn with + | SFBconst cb, C con -> + let poly = Declareops.constant_is_polymorphic cb in + Section.push_constant ~poly con senv.sections + | SFBmind mib, I mind -> + let poly = Declareops.inductive_is_polymorphic mib in + Section.push_inductive ~poly mind senv.sections + | _, (M | MT) -> senv.sections + | _ -> assert false + in { senv with env = env'; + sections; revstruct = field :: senv.revstruct; modlabels = Label.Set.union mlabs senv.modlabels; objlabels = Label.Set.union olabs senv.objlabels } @@ -549,15 +589,6 @@ type exported_private_constant = Constant.t let add_constant_aux ~in_section senv (kn, cb) = let l = Constant.label kn in - let delayed_cst = match cb.const_body with - | OpaqueDef o when not (Declareops.constant_is_polymorphic cb) -> - let fc = Opaqueproof.get_direct_constraints o in - begin match Future.peek_val fc with - | None -> [Later fc] - | Some c -> [Now c] - end - | Undef _ | Def _ | Primitive _ | OpaqueDef _ -> [] - in (* This is the only place where we hashcons the contents of a constant body *) let cb = if in_section then cb else Declareops.hcons_const_body cb in let cb, otab = match cb.const_body with @@ -572,7 +603,6 @@ let add_constant_aux ~in_section senv (kn, cb) = in let senv = { senv with env = Environ.set_opaque_tables senv.env otab } in let senv' = add_field (l,SFBconst cb) (C kn) senv in - let senv' = add_constraints_list delayed_cst senv' in let senv'' = match cb.const_body with | Undef (Some lev) -> update_resolver @@ -787,15 +817,10 @@ let export_private_constants ~in_section ce senv = let map (kn, cb) = (kn, map_constant (fun c -> map cb.const_universes c) cb) in let bodies = List.map map exported in let exported = List.map (fun (kn, _) -> kn) exported in + (* No delayed constants to declare *) let senv = List.fold_left (add_constant_aux ~in_section) senv bodies in (ce, exported), senv -let add_recipe ~in_section l r senv = - let kn = Constant.make2 senv.modpath l in - let cb = Term_typing.translate_recipe senv.env kn r in - let senv = add_constant_aux ~in_section senv (kn, cb) in - kn, senv - let add_constant (type a) ~(side_effect : a effect_entry) ~in_section l decl senv : (Constant.t * a) * safe_environment = let kn = Constant.make2 senv.modpath l in let cb = @@ -811,8 +836,24 @@ let add_constant (type a) ~(side_effect : a effect_entry) ~in_section l decl sen Term_typing.translate_constant Term_typing.Pure senv.env kn ce in let senv = + let delayed_cst = match cb.const_body with + | OpaqueDef fc when not (Declareops.constant_is_polymorphic cb) -> + let map (_, u) = match u with + | Opaqueproof.PrivateMonomorphic ctx -> ctx + | Opaqueproof.PrivatePolymorphic _ -> assert false + in + let fc = Future.chain fc map in + begin match Future.peek_val fc with + | None -> [Later fc] + | Some c -> [Now c] + end + | Undef _ | Def _ | Primitive _ | OpaqueDef _ -> [] + in let cb = map_constant (fun c -> Opaqueproof.create c) cb in - add_constant_aux ~in_section senv (kn, cb) in + let senv = add_constant_aux ~in_section senv (kn, cb) in + add_constraints_list delayed_cst senv + in + let senv = match decl with | ConstantEntry (_,(Entries.PrimitiveEntry { Entries.prim_entry_content = CPrimitives.OT_type t; _ })) -> @@ -902,6 +943,73 @@ let add_module l me inl senv = in (mp,mb.mod_delta),senv'' +(** {6 Interactive sections *) + +let open_section senv = + let custom = { + rev_env = senv.env; + rev_univ = senv.univ; + rev_objlabels = senv.objlabels; + } in + let sections = Section.open_section ~custom senv.sections in + { senv with sections } + +let close_section senv = + let open Section in + let sections0 = senv.sections in + let env0 = senv.env in + (* First phase: revert the declarations added in the section *) + let sections, entries, cstrs, revert = Section.close_section sections0 in + let rec pop_revstruct accu entries revstruct = match entries, revstruct with + | [], revstruct -> accu, revstruct + | _ :: _, [] -> + CErrors.anomaly (Pp.str "Unmatched section data") + | entry :: entries, (lbl, leaf) :: revstruct -> + let data = match entry, leaf with + | SecDefinition kn, SFBconst cb -> + let () = assert (Label.equal lbl (Constant.label kn)) in + `Definition (kn, cb) + | SecInductive ind, SFBmind mib -> + let () = assert (Label.equal lbl (MutInd.label ind)) in + `Inductive (ind, mib) + | (SecDefinition _ | SecInductive _), (SFBconst _ | SFBmind _) -> + CErrors.anomaly (Pp.str "Section content mismatch") + | (SecDefinition _ | SecInductive _), (SFBmodule _ | SFBmodtype _) -> + CErrors.anomaly (Pp.str "Module inside a section") + in + pop_revstruct (data :: accu) entries revstruct + in + let redo, revstruct = pop_revstruct [] entries senv.revstruct in + (* Don't revert the delayed constraints. If some delayed constraints were + forced inside the section, they have been turned into global monomorphic + that are going to be replayed. Those that are not forced are not readded + by {!add_constant_aux}. *) + let { rev_env = env; rev_univ = univ; rev_objlabels = objlabels } = revert in + let senv = { senv with env; revstruct; sections; univ; objlabels; } in + (* Second phase: replay the discharged section contents *) + let senv = add_constraints (Now cstrs) senv in + let modlist = Section.replacement_context env0 sections0 in + let cooking_info seg = + let { abstr_ctx; abstr_subst; abstr_uctx } = seg in + let abstract = (abstr_ctx, abstr_subst, abstr_uctx) in + { Opaqueproof.modlist; abstract } + in + let fold senv = function + | `Definition (kn, cb) -> + let in_section = not (Section.is_empty senv.sections) in + let info = cooking_info (Section.segment_of_constant env0 kn sections0) in + let r = { Cooking.from = cb; info } in + let cb = Term_typing.translate_recipe senv.env kn r in + (* Delayed constants are already in the global environment *) + add_constant_aux ~in_section senv (kn, cb) + | `Inductive (ind, mib) -> + let info = cooking_info (Section.segment_of_inductive env0 ind sections0) in + let mie = Cooking.cook_inductive info mib in + let mie = InferCumulativity.infer_inductive senv.env mie in + let _, senv = add_mind (MutInd.label ind) mie senv in + senv + in + List.fold_left fold senv redo (** {6 Starting / ending interactive modules and module types } *) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index fa53fa33fa..d97d61a72f 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -27,12 +27,16 @@ val digest_match : actual:vodigest -> required:vodigest -> bool type safe_environment +type section_data + val empty_environment : safe_environment val is_initial : safe_environment -> bool val env_of_safe_env : safe_environment -> Environ.env +val sections_of_safe_env : safe_environment -> section_data Section.t + (** The safe_environment state monad *) type safe_transformer0 = safe_environment -> safe_environment @@ -67,15 +71,6 @@ val join_safe_environment : val is_joined_environment : safe_environment -> bool (** {6 Enriching a safe environment } *) -(** Insertion of local declarations (Local or Variables) *) - -val push_named_assum : (Id.t * Constr.types) -> safe_transformer0 - -(** Returns the full universe context necessary to typecheck the definition - (futures are forced) *) -val push_named_def : - Id.t * Entries.section_def_entry -> safe_transformer0 - (** Insertion of global axioms or definitions *) type 'a effect_entry = @@ -96,9 +91,6 @@ val add_constant : side_effect:'a effect_entry -> in_section:bool -> Label.t -> global_declaration -> (Constant.t * 'a) safe_transformer -val add_recipe : - in_section:bool -> Label.t -> Cooking.recipe -> Constant.t safe_transformer - (** Adding an inductive type *) val add_mind : @@ -140,6 +132,22 @@ val set_allow_sprop : bool -> safe_transformer0 val check_engagement : Environ.env -> Declarations.set_predicativity -> unit +(** {6 Interactive section functions } *) + +val open_section : safe_transformer0 + +val close_section : safe_transformer0 + +(** Insertion of local declarations (Local or Variables) *) + +val push_named_assum : (Id.t * Constr.types) -> safe_transformer0 + +val push_named_def : + Id.t * Entries.section_def_entry -> safe_transformer0 + +(** Add local universes to a polymorphic section *) +val push_section_context : (Name.t array * Univ.UContext.t) -> safe_transformer0 + (** {6 Interactive module functions } *) val start_module : Label.t -> ModPath.t safe_transformer diff --git a/kernel/section.ml b/kernel/section.ml new file mode 100644 index 0000000000..4a9b222798 --- /dev/null +++ b/kernel/section.ml @@ -0,0 +1,222 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names +open Univ + +module NamedDecl = Context.Named.Declaration + +type section_entry = +| SecDefinition of Constant.t +| SecInductive of MutInd.t + +type 'a entry_map = 'a Cmap.t * 'a Mindmap.t + +type 'a section = { + sec_context : int; + (** Length of the named context suffix that has been introduced locally *) + sec_mono_universes : ContextSet.t; + sec_poly_universes : Name.t array * UContext.t; + (** Universes local to the section *) + has_poly_univs : bool; + (** Are there polymorphic universes or constraints, including in previous sections. *) + sec_entries : section_entry list; + (** Definitions introduced in the section *) + sec_data : (Instance.t * AUContext.t) entry_map; + (** Additional data synchronized with the section *) + sec_custom : 'a; +} + +(** Sections can be nested with the proviso that no monomorphic section can be + opened inside a polymorphic one. The reverse is allowed. *) +type 'a t = 'a section list + +let empty = [] + +let is_empty = List.is_empty + +let has_poly_univs = function + | [] -> false + | sec :: _ -> sec.has_poly_univs + +let find_emap e (cmap, imap) = match e with +| SecDefinition con -> Cmap.find con cmap +| SecInductive ind -> Mindmap.find ind imap + +let add_emap e v (cmap, imap) = match e with +| SecDefinition con -> (Cmap.add con v cmap, imap) +| SecInductive ind -> (cmap, Mindmap.add ind v imap) + +let on_last_section f sections = match sections with +| [] -> CErrors.user_err (Pp.str "No opened section") +| sec :: rem -> f sec :: rem + +let with_last_section f sections = match sections with +| [] -> f None +| sec :: _ -> f (Some sec) + +let push_local s = + let on_sec sec = { sec with sec_context = sec.sec_context + 1 } in + on_last_section on_sec s + +let push_context (nas, ctx) s = + let on_sec sec = + if UContext.is_empty ctx then sec + else + let (snas, sctx) = sec.sec_poly_universes in + let sec_poly_universes = (Array.append snas nas, UContext.union sctx ctx) in + { sec with sec_poly_universes; has_poly_univs = true } + in + on_last_section on_sec s + +let is_polymorphic_univ u s = + let check sec = + let (_, uctx) = sec.sec_poly_universes in + Array.exists (fun u' -> Level.equal u u') (Instance.to_array (UContext.instance uctx)) + in + List.exists check s + +let push_constraints uctx s = + let on_sec sec = + if sec.has_poly_univs && Constraint.exists (fun (l,_,r) -> is_polymorphic_univ l s || is_polymorphic_univ r s) (snd uctx) + then CErrors.user_err Pp.(str "Cannot add monomorphic constraints which refer to section polymorphic universes."); + let uctx' = sec.sec_mono_universes in + let sec_mono_universes = (ContextSet.union uctx uctx') in + { sec with sec_mono_universes } + in + on_last_section on_sec s + +let open_section ~custom sections = + let sec = { + sec_context = 0; + sec_mono_universes = ContextSet.empty; + sec_poly_universes = ([||], UContext.empty); + has_poly_univs = has_poly_univs sections; + sec_entries = []; + sec_data = (Cmap.empty, Mindmap.empty); + sec_custom = custom; + } in + sec :: sections + +let close_section sections = + match sections with + | sec :: sections -> + sections, sec.sec_entries, sec.sec_mono_universes, sec.sec_custom + | [] -> + CErrors.user_err (Pp.str "No opened section.") + +let make_decl_univs (nas,uctx) = abstract_universes nas uctx + +let push_global ~poly e s = + if is_empty s then s + else if has_poly_univs s && not poly + then CErrors.user_err + Pp.(str "Cannot add a universe monomorphic declaration when \ + section polymorphic universes are present.") + else + let on_sec sec = + { sec with + sec_entries = e :: sec.sec_entries; + sec_data = add_emap e (make_decl_univs sec.sec_poly_universes) sec.sec_data; + } + in + on_last_section on_sec s + +let push_constant ~poly con s = push_global ~poly (SecDefinition con) s + +let push_inductive ~poly ind s = push_global ~poly (SecInductive ind) s + +type abstr_info = { + abstr_ctx : Constr.named_context; + abstr_subst : Instance.t; + abstr_uctx : AUContext.t; +} + +let empty_segment = { + abstr_ctx = []; + abstr_subst = Instance.empty; + abstr_uctx = AUContext.empty; +} + +let extract_hyps sec vars hyps = + (* FIXME: this code is fishy. It is supposed to check that declared section + variables are an ordered subset of the ambient ones, but it doesn't check + e.g. uniqueness of naming nor convertibility of the section data. *) + let rec aux ids hyps = match ids, hyps with + | id :: ids, decl :: hyps when Names.Id.equal id (NamedDecl.get_id decl) -> + decl :: aux ids hyps + | _ :: ids, hyps -> + aux ids hyps + | [], _ -> [] + in + let ids = List.map NamedDecl.get_id @@ List.firstn sec.sec_context vars in + aux ids hyps + +let section_segment_of_entry vars e hyps sections = + (* [vars] are the named hypotheses, [hyps] the subset that is declared by the + global *) + let with_sec s = match s with + | None -> + CErrors.user_err (Pp.str "No opened section.") + | Some sec -> + let hyps = extract_hyps sec vars hyps in + let inst, auctx = find_emap e sec.sec_data in + { + abstr_ctx = hyps; + abstr_subst = inst; + abstr_uctx = auctx; + } + in + with_last_section with_sec sections + +let segment_of_constant env con s = + let body = Environ.lookup_constant con env in + let vars = Environ.named_context env in + section_segment_of_entry vars (SecDefinition con) body.Declarations.const_hyps s + +let segment_of_inductive env mind s = + let mib = Environ.lookup_mind mind env in + let vars = Environ.named_context env in + section_segment_of_entry vars (SecInductive mind) mib.Declarations.mind_hyps s + +let instance_from_variable_context = + List.rev %> List.filter NamedDecl.is_local_assum %> List.map NamedDecl.get_id %> Array.of_list + +let extract_worklist info = + let args = instance_from_variable_context info.abstr_ctx in + info.abstr_subst, args + +let replacement_context env s = + let with_sec sec = match sec with + | None -> CErrors.user_err (Pp.str "No opened section.") + | Some sec -> + let cmap, imap = sec.sec_data in + let cmap = Cmap.mapi (fun con _ -> extract_worklist @@ segment_of_constant env con s) cmap in + let imap = Mindmap.mapi (fun ind _ -> extract_worklist @@ segment_of_inductive env ind s) imap in + (cmap, imap) + in + with_last_section with_sec s + +let is_in_section env gr s = + let with_sec sec = match sec with + | None -> false + | Some sec -> + let open GlobRef in + match gr with + | VarRef id -> + let vars = List.firstn sec.sec_context (Environ.named_context env) in + List.exists (fun decl -> Id.equal id (NamedDecl.get_id decl)) vars + | ConstRef con -> + Cmap.mem con (fst sec.sec_data) + | IndRef (ind, _) | ConstructRef ((ind, _), _) -> + Mindmap.mem ind (snd sec.sec_data) + in + with_last_section with_sec s diff --git a/kernel/section.mli b/kernel/section.mli new file mode 100644 index 0000000000..fc3ac141e4 --- /dev/null +++ b/kernel/section.mli @@ -0,0 +1,87 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Univ + +(** Kernel implementation of sections. *) + +type 'a t +(** Type of sections with additional data ['a] *) + +val empty : 'a t + +val is_empty : 'a t -> bool +(** Checks whether there is no opened section *) + +(** {6 Manipulating sections} *) + +type section_entry = +| SecDefinition of Constant.t +| SecInductive of MutInd.t + +val open_section : custom:'a -> 'a t -> 'a t +(** Open a new section with the provided universe polymorphic status. Sections + can be nested, with the proviso that polymorphic sections cannot appear + inside a monomorphic one. A custom data can be attached to this section, + that will be returned by {!close_section}. *) + +val close_section : 'a t -> 'a t * section_entry list * ContextSet.t * 'a +(** Close the current section and returns the entries defined inside, the set + of global monomorphic constraints added in this section, and the custom data + provided at the opening of the section. *) + +(** {6 Extending sections} *) + +val push_local : 'a t -> 'a t +(** Extend the current section with a local definition (cf. push_named). *) + +val push_context : Name.t array * UContext.t -> 'a t -> 'a t +(** Extend the current section with a local universe context. Assumes that the + last opened section is polymorphic. *) + +val push_constraints : ContextSet.t -> 'a t -> 'a t +(** Extend the current section with a global universe context. + Assumes that the last opened section is monomorphic. *) + +val push_constant : poly:bool -> Constant.t -> 'a t -> 'a t +(** Make the constant as having been defined in this section. *) + +val push_inductive : poly:bool -> MutInd.t -> 'a t -> 'a t +(** Make the inductive block as having been defined in this section. *) + +(** {6 Retrieving section data} *) + +type abstr_info = private { + abstr_ctx : Constr.named_context; + (** Section variables of this prefix *) + abstr_subst : Univ.Instance.t; + (** Actual names of the abstracted variables *) + abstr_uctx : Univ.AUContext.t; + (** Universe quantification, same length as the substitution *) +} +(** Data needed to abstract over the section variable and universe hypotheses *) + + +val empty_segment : abstr_info +(** Nothing to abstract *) + +val segment_of_constant : Environ.env -> Constant.t -> 'a t -> abstr_info +(** Section segment at the time of the constant declaration *) + +val segment_of_inductive : Environ.env -> MutInd.t -> 'a t -> abstr_info +(** Section segment at the time of the inductive declaration *) + +val replacement_context : Environ.env -> 'a t -> Opaqueproof.work_list +(** Section segments of all declarations from this section. *) + +val is_in_section : Environ.env -> GlobRef.t -> 'a t -> bool + +val is_polymorphic_univ : Level.t -> 'a t -> bool diff --git a/library/global.ml b/library/global.ml index 6bb4614aa4..c4685370d1 100644 --- a/library/global.ml +++ b/library/global.ml @@ -71,6 +71,11 @@ let globalize0 f = GlobalSafeEnv.set_safe_env (f (safe_env ())) let globalize f = let res,env = f (safe_env ()) in GlobalSafeEnv.set_safe_env env; res +let globalize0_with_summary fs f = + let env = f (safe_env ()) in + Summary.unfreeze_summaries fs; + GlobalSafeEnv.set_safe_env env + let globalize_with_summary fs f = let res,env = f (safe_env ()) in Summary.unfreeze_summaries fs; @@ -83,6 +88,7 @@ let i2l = Label.of_id let push_named_assum a = globalize0 (Safe_typing.push_named_assum a) let push_named_def d = globalize0 (Safe_typing.push_named_def d) +let push_section_context c = globalize0 (Safe_typing.push_section_context c) let add_constraints c = globalize0 (Safe_typing.add_constraints c) let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) @@ -98,12 +104,14 @@ let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) let add_constant ~side_effect ~in_section id d = globalize (Safe_typing.add_constant ~side_effect ~in_section (i2l id) d) -let add_recipe ~in_section id d = globalize (Safe_typing.add_recipe ~in_section (i2l id) d) let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) let add_module id me inl = globalize (Safe_typing.add_module (i2l id) me inl) let add_include me ismod inl = globalize (Safe_typing.add_include me ismod inl) +let open_section () = globalize0 Safe_typing.open_section +let close_section fs = globalize0_with_summary fs Safe_typing.close_section + let start_module id = globalize (Safe_typing.start_module (i2l id)) let start_modtype id = globalize (Safe_typing.start_modtype (i2l id)) diff --git a/library/global.mli b/library/global.mli index d0bd556d70..c45bf65d84 100644 --- a/library/global.mli +++ b/library/global.mli @@ -44,6 +44,7 @@ val sprop_allowed : unit -> bool val push_named_assum : (Id.t * Constr.types) -> unit val push_named_def : (Id.t * Entries.section_def_entry) -> unit +val push_section_context : (Name.t array * Univ.UContext.t) -> unit val export_private_constants : in_section:bool -> Safe_typing.private_constants Entries.proof_output -> @@ -51,7 +52,6 @@ val export_private_constants : in_section:bool -> val add_constant : side_effect:'a Safe_typing.effect_entry -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * 'a -val add_recipe : in_section:bool -> Id.t -> Cooking.recipe -> Constant.t val add_mind : Id.t -> Entries.mutual_inductive_entry -> MutInd.t @@ -71,6 +71,15 @@ val add_include : Entries.module_struct_entry -> bool -> Declarations.inline -> Mod_subst.delta_resolver +(** Sections *) + +val open_section : unit -> unit +(** [poly] is true when the section should be universe polymorphic *) + +val close_section : Summary.frozen -> unit +(** Close the section and reset the global state to the one at the time when + the section what opened. *) + (** Interactive modules and module types *) val start_module : Id.t -> ModPath.t diff --git a/library/lib.ml b/library/lib.ml index 851f086961..991e23eb3a 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -410,87 +410,11 @@ let find_opening_node id = - the list of substitution to do at section closing *) -type abstr_info = { +type abstr_info = Section.abstr_info = private { abstr_ctx : Constr.named_context; abstr_subst : Univ.Instance.t; abstr_uctx : Univ.AUContext.t; } -type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t - -type secentry = - | Variable of { - id:Names.Id.t; - } - | Context of Univ.ContextSet.t - -type section_data = { - sec_entry : secentry list; - sec_abstr : abstr_list; - sec_poly : bool; -} - -let empty_section_data ~poly = { - sec_entry = []; - sec_abstr = (Names.Cmap.empty,Names.Mindmap.empty); - sec_poly = poly; -} - -let sectab = - Summary.ref ([] : section_data list) ~name:"section-context" - -let check_same_poly p sec = - if p != sec.sec_poly then - user_err Pp.(str "Cannot mix universe polymorphic and monomorphic declarations in sections.") - -let add_section ~poly () = - List.iter (fun tab -> check_same_poly poly tab) !sectab; - sectab := empty_section_data ~poly :: !sectab - -let add_section_variable ~name ~poly = - match !sectab with - | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) - | s :: sl -> - List.iter (fun tab -> check_same_poly poly tab) !sectab; - let s = { s with sec_entry = Variable {id=name} :: s.sec_entry } in - sectab := s :: sl - -let add_section_context ctx = - match !sectab with - | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) - | s :: sl -> - check_same_poly true s; - let s = { s with sec_entry = Context ctx :: s.sec_entry } in - sectab := s :: sl - -exception PolyFound (* make this a let exception once possible *) -let is_polymorphic_univ u = - try - let open Univ in - List.iter (fun s -> - let vars = s.sec_entry in - List.iter (function - | Variable _ -> () - | Context (univs,_) -> - if LSet.mem u univs then raise PolyFound - ) vars - ) !sectab; - false - with PolyFound -> true - -let extract_hyps poly (secs,ohyps) = - let rec aux = function - | (Variable {id}::idl, decl::hyps) when Names.Id.equal id (NamedDecl.get_id decl) -> - let l, r = aux (idl,hyps) in - decl :: l, r - | (Variable _::idl,hyps) -> - let l, r = aux (idl,hyps) in - l, r - | (Context ctx :: idl, hyps) -> - let () = assert poly in - let l, r = aux (idl, hyps) in - l, Univ.ContextSet.union r ctx - | [], _ -> [],Univ.ContextSet.empty - in aux (secs,ohyps) let instance_from_variable_context = List.rev %> List.filter is_local_assum %> List.map NamedDecl.get_id %> Array.of_list @@ -499,66 +423,21 @@ let extract_worklist info = let args = instance_from_variable_context info.abstr_ctx in info.abstr_subst, args -let make_worklist (cmap, mmap) = - Cmap.map extract_worklist cmap, Mindmap.map extract_worklist mmap - -let name_instance inst = - (* FIXME: this should probably be done at an upper level, by storing the - name information in the section data structure. *) - let map lvl = match Univ.Level.name lvl with - | None -> (* Having Prop/Set/Var as section universes makes no sense *) - assert false - | Some na -> - try - let qid = Nametab.shortest_qualid_of_universe na in - Name (Libnames.qualid_basename qid) - with Not_found -> - (* Best-effort naming from the string representation of the level. - See univNames.ml for a similar hack. *) - Name (Id.of_string_soft (Univ.Level.to_string lvl)) - in - Array.map map (Univ.Instance.to_array inst) - -let add_section_replacement g poly hyps = - match !sectab with - | [] -> () - | s :: sl -> - let () = check_same_poly poly s in - let sechyps,ctx = extract_hyps s.sec_poly (s.sec_entry, hyps) in - let ctx = Univ.ContextSet.to_context ctx in - let nas = name_instance (Univ.UContext.instance ctx) in - let subst, ctx = Univ.abstract_universes nas ctx in - let info = { - abstr_ctx = sechyps; - abstr_subst = subst; - abstr_uctx = ctx; - } in - let s = { s with - sec_abstr = g info s.sec_abstr; - } in - sectab := s :: sl - -let add_section_kn ~poly kn = - let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in - add_section_replacement f poly - -let add_section_constant ~poly kn = - let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in - add_section_replacement f poly - -let replacement_context () = make_worklist (List.hd !sectab).sec_abstr +let sections () = Safe_typing.sections_of_safe_env @@ Global.safe_env () + +let is_polymorphic_univ u = + Section.is_polymorphic_univ u (sections ()) + +let replacement_context () = + Section.replacement_context (Global.env ()) (sections ()) let section_segment_of_constant con = - Names.Cmap.find con (fst (List.hd !sectab).sec_abstr) + Section.segment_of_constant (Global.env ()) con (sections ()) let section_segment_of_mutual_inductive kn = - Names.Mindmap.find kn (snd (List.hd !sectab).sec_abstr) + Section.segment_of_inductive (Global.env ()) kn (sections ()) -let empty_segment = { - abstr_ctx = []; - abstr_subst = Univ.Instance.empty; - abstr_uctx = Univ.AUContext.empty; -} +let empty_segment = Section.empty_segment let section_segment_of_reference = let open GlobRef in function | ConstRef c -> section_segment_of_constant c @@ -569,28 +448,24 @@ let section_segment_of_reference = let open GlobRef in function let variable_section_segment_of_reference gr = (section_segment_of_reference gr).abstr_ctx +let is_in_section ref = + Section.is_in_section (Global.env ()) ref (sections ()) + let section_instance = let open GlobRef in function | VarRef id -> - let eq = function - | Variable {id=id'} -> Names.Id.equal id id' - | Context _ -> false - in - if List.exists eq (List.hd !sectab).sec_entry - then Univ.Instance.empty, [||] - else raise Not_found + if is_in_section (VarRef id) then (Univ.Instance.empty, [||]) + else raise Not_found | ConstRef con -> - let data = Names.Cmap.find con (fst (List.hd !sectab).sec_abstr) in + let data = section_segment_of_constant con in extract_worklist data | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - let data = Names.Mindmap.find kn (snd (List.hd !sectab).sec_abstr) in + let data = section_segment_of_mutual_inductive kn in extract_worklist data -let is_in_section ref = - try ignore (section_instance ref); true with Not_found -> false - (*************) (* Sections. *) -let open_section ~poly id = +let open_section id = + let () = Global.open_section () in let opp = !lib_state.path_prefix in let obj_dir = add_dirpath_suffix opp.Nametab.obj_dir id in let prefix = Nametab.{ obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in @@ -600,9 +475,7 @@ let open_section ~poly id = add_entry (make_foname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) Nametab.(push_dir (Until 1) obj_dir (GlobDirRef.DirOpenSection prefix)); - lib_state := { !lib_state with path_prefix = prefix }; - add_section ~poly () - + lib_state := { !lib_state with path_prefix = prefix } (* Restore lib_stk and summaries as before the section opening, and add a ClosedSection object. *) @@ -631,7 +504,7 @@ let close_section () = lib_state := { !lib_state with lib_stk = before }; pop_path_prefix (); let newdecls = List.map discharge_item secdecls in - Summary.unfreeze_summaries fs; + let () = Global.close_section fs in List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls (* State and initialization. *) diff --git a/library/lib.mli b/library/lib.mli index 9ffa69ef93..d3315b0f2e 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -147,7 +147,7 @@ val library_part : GlobRef.t -> DirPath.t (** {6 Sections } *) -val open_section : poly:bool -> Id.t -> unit +val open_section : Id.t -> unit val close_section : unit -> unit (** {6 We can get and set the state of the operations (used in [States]). } *) @@ -163,7 +163,7 @@ val drop_objects : frozen -> frozen val init : unit -> unit (** {6 Section management for discharge } *) -type abstr_info = private { +type abstr_info = Section.abstr_info = private { abstr_ctx : Constr.named_context; (** Section variables of this prefix *) abstr_subst : Univ.Instance.t; @@ -181,10 +181,6 @@ val variable_section_segment_of_reference : GlobRef.t -> Constr.named_context val section_instance : GlobRef.t -> Univ.Instance.t * Id.t array val is_in_section : GlobRef.t -> bool -val add_section_variable : name:Id.t -> poly:bool -> unit -val add_section_context : Univ.ContextSet.t -> unit -val add_section_constant : poly:bool -> Constant.t -> Constr.named_context -> unit -val add_section_kn : poly:bool -> MutInd.t -> Constr.named_context -> unit val replacement_context : unit -> Opaqueproof.work_list val is_polymorphic_univ : Univ.Level.t -> bool diff --git a/library/library.mllib b/library/library.mllib index c34d8911e8..a6188f7661 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -5,7 +5,6 @@ Summary Nametab Global Lib -Declaremods States Kindops Goptions diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index ca33e4e757..7be049269c 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -920,20 +920,10 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) - let info = Lemmas.Info.make - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:(Decls.(IsProof Theorem)) () in - - let lemma = Lemmas.start_lemma - (*i The next call to mk_equation_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - ~name:(mk_equation_id f_id) - ~poly:false - ~info - evd - lemma_type - in + + (*i The next call to mk_equation_id is valid since we are + constructing the lemma Ensures by: obvious i*) + let lemma = Lemmas.start_lemma ~name:(mk_equation_id f_id) ~poly:false evd lemma_type in let lemma,_ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in evd diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 570b72136c..6011af74e5 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -1387,15 +1387,7 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = i*) let lem_id = mk_correct_id f_id in let (typ,_) = lemmas_types_infos.(i) in - let info = Lemmas.Info.make - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:(Decls.(IsProof Theorem)) () in - let lemma = Lemmas.start_lemma - ~name:lem_id - ~poly:false - ~info - !evd - typ in + let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false !evd typ in let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (proving_tac i)) lemma in let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in @@ -1456,11 +1448,7 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = Ensures by: obvious i*) let lem_id = mk_complete_id f_id in - let info = Lemmas.Info.make - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsProof Theorem) () in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false ~info - sigma (fst lemmas_types_infos.(i)) in + let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false sigma (fst lemmas_types_infos.(i)) in let lemma = fst (Lemmas.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") (proving_tac i))) lemma) in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index c62aa0cf6b..4c5eab1a9b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1332,9 +1332,7 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let lemma = build_proof env (Evd.from_env env) start_tac end_tac in Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None in - let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~kind:(Decls.(IsProof Lemma)) - () in + let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) () in let lemma = Lemmas.start_lemma ~name:na ~poly:false (* FIXME *) ~info @@ -1376,7 +1374,7 @@ let com_terminate nb_args ctx hook = let start_proof env ctx tac_start tac_end = - let info = Lemmas.Info.make ~hook ~scope:(DeclareDef.Global ImportDefaultBehavior) ~kind:Decls.(IsProof Lemma) () in + let info = Lemmas.Info.make ~hook () in let lemma = Lemmas.start_lemma ~name:thm_name ~poly:false (*FIXME*) ~info diff --git a/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml index 9e8e86d4fc..252c15478d 100644 --- a/plugins/ltac/tacarg.ml +++ b/plugins/ltac/tacarg.ml @@ -20,7 +20,7 @@ let make0 ?dyn name = wit let wit_intropattern = make0 "intropattern" (* To keep after deprecation phase but it will get a different parsing semantics (Tactic Notation and TACTIC EXTEND) in pltac.ml *) -let wit_simple_intropattern = make0 "simple_intropattern" +let wit_simple_intropattern = make0 ~dyn:(val_tag (topwit wit_intropattern)) "simple_intropattern" let wit_quant_hyp = make0 "quant_hyp" let wit_constr_with_bindings = make0 "constr_with_bindings" let wit_open_constr_with_bindings = make0 "open_constr_with_bindings" diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index e64129d204..da89a027e2 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -145,11 +145,8 @@ let coerce_to_constr_context v = else raise (CannotCoerceTo "a term context") let is_intro_pattern v = - if has_type v (topwit wit_intropattern [@warning "-3"]) then - Some (out_gen (topwit wit_intropattern [@warning "-3"]) v).CAst.v - else - if has_type v (topwit wit_simple_intropattern) then - Some (out_gen (topwit wit_simple_intropattern) v).CAst.v + if has_type v (topwit wit_intro_pattern) then + Some (out_gen (topwit wit_intro_pattern) v).CAst.v else None diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index 8c7b601aba..7e04fe0220 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -23,9 +23,6 @@ Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". -Ltac preprocess := - zify ; unfold Z.succ in * ; unfold Z.pred in *. - Ltac zchange checker := intros __wit __varmap __ff ; change (@Tauto.eval_bf _ (Zeval_formula (@find Z Z0 __varmap)) __ff) ; @@ -39,11 +36,17 @@ Ltac zchecker_abstract checker := Ltac zchecker := zchecker_no_abstract ZTautoChecker_sound. -Ltac zchecker_ext := zchecker_no_abstract ZTautoCheckerExt_sound. +(*Ltac zchecker_ext := zchecker_no_abstract ZTautoCheckerExt_sound.*) + +Ltac zchecker_ext := + intros __wit __varmap __ff ; + exact (ZTautoCheckerExt_sound __ff __wit + (@eq_refl bool true <: @eq bool (ZTautoCheckerExt __ff __wit) true) + (@find Z Z0 __varmap)). -Ltac lia := preprocess; xlia zchecker_ext. +Ltac lia := zify; xlia zchecker_ext. -Ltac nia := preprocess; xnlia zchecker. +Ltac nia := zify; xnlia zchecker. (* Local Variables: *) diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 1050bae303..80e0f3a536 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -55,7 +55,8 @@ Extract Constant Rinv => "fun x -> 1 / x". extraction is only performed as a test in the test suite. *) (*Extraction "micromega.ml" Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula - ZMicromega.cnfZ ZMicromega.Zeval_const ZMicromega.bound_problem_fr QMicromega.cnfQ + Tauto.abst_form + ZMicromega.cnfZ ZMicromega.bound_problem_fr ZMicromega.Zeval_const QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index 3c72d3268f..4a02d1d01e 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -172,9 +172,9 @@ Qed. Require Import Coq.micromega.Tauto. -Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. +Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. -Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. +Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. @@ -204,7 +204,7 @@ Proof. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Qsor QSORaddon) ; auto. - - unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon). + - unfold qdeduce. intros. revert H. apply (nformula_plus_nformula_correct Qsor QSORaddon);auto. - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_normalise_correct Qsor QSORaddon);eauto. - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_negate_correct Qsor QSORaddon);eauto. - intros t w0. diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 30bbac44d0..d8282a1127 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -432,8 +432,8 @@ Qed. Require Import Coq.micromega.Tauto. -Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. -Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. +Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. +Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. Definition runsat := check_inconsistent 0%Q Qeq_bool Qle_bool. @@ -467,7 +467,9 @@ Proof. apply Reval_nformula_dec. - destruct t. apply (check_inconsistent_sound Rsor QSORaddon) ; auto. - - unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon). + - unfold rdeduce. + intros. revert H. + eapply (nformula_plus_nformula_correct Rsor QSORaddon); eauto. - now apply (cnf_normalise_correct Rsor QSORaddon). - intros. now eapply (cnf_negate_correct Rsor QSORaddon); eauto. - intros t w0. diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v index 63b4d5e8f8..cd759029fa 100644 --- a/plugins/micromega/Refl.v +++ b/plugins/micromega/Refl.v @@ -99,8 +99,6 @@ Proof. apply IHl; auto. Qed. - - Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2. Proof. induction l1. @@ -114,34 +112,41 @@ Proof. tauto. Qed. +Infix "+++" := rev_append (right associativity, at level 60) : list_scope. + +Lemma make_conj_rapp : forall A eval l1 l2, @make_conj A eval (l1 +++ l2) <-> @make_conj A eval (l1++l2). +Proof. + induction l1. + - simpl. tauto. + - intros. + simpl rev_append at 1. + rewrite IHl1. + rewrite make_conj_app. + rewrite make_conj_cons. + simpl app. + rewrite make_conj_cons. + rewrite make_conj_app. + tauto. +Qed. + Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)), - ~ make_conj eval (t ::a) -> ~ (eval t) \/ (~ make_conj eval a). + ~ make_conj eval (t ::a) <-> ~ (eval t) \/ (~ make_conj eval a). Proof. intros. - simpl in H. - destruct a. - tauto. + rewrite make_conj_cons. tauto. Qed. Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval (no_middle_eval : forall d, eval d \/ ~ eval d) , - ~ make_conj eval (t ++ a) -> (~ make_conj eval t) \/ (~ make_conj eval a). + ~ make_conj eval (t ++ a) <-> (~ make_conj eval t) \/ (~ make_conj eval a). Proof. induction t. - simpl. - tauto. - intros. - simpl ((a::t)++a0)in H. - destruct (@not_make_conj_cons _ _ _ _ (no_middle_eval a) H). - left ; red ; intros. - apply H0. - rewrite make_conj_cons in H1. - tauto. - destruct (IHt _ _ no_middle_eval H0). - left ; red ; intros. - apply H1. - rewrite make_conj_cons in H2. - tauto. - right ; auto. + - simpl. + tauto. + - intros. + simpl ((a::t)++a0). + rewrite !not_make_conj_cons by auto. + rewrite IHt by auto. + tauto. Qed. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index cddc140f51..c1edf579cf 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -707,6 +707,8 @@ Definition padd := Padd cO cplus ceqb. Definition pmul := Pmul cO cI cplus ctimes ceqb. +Definition popp := Popp copp. + Definition normalise (f : Formula C) : NFormula := let (lhs, op, rhs) := f in let lhs := norm lhs in @@ -733,7 +735,6 @@ let (lhs, op, rhs) := f in | OpLt => (psub lhs rhs, NonStrict) end. - Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. Proof. intros. @@ -755,6 +756,12 @@ Proof. (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. +Lemma eval_pol_opp : forall env e, eval_pol env (popp e) == - eval_pol env e. +Proof. + intros. + apply (Popp_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). +Qed. Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env (norm lhs). @@ -766,16 +773,18 @@ Qed. Theorem normalise_sound : forall (env : PolEnv) (f : Formula C), - eval_formula env f -> eval_nformula env (normalise f). + eval_formula env f <-> eval_nformula env (normalise f). Proof. -intros env f H; destruct f as [lhs op rhs]; simpl in *. +intros env f; destruct f as [lhs op rhs]; simpl in *. destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. -now apply <- (Rminus_eq_0 sor). -intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H. -now apply -> (Rle_le_minus sor). -now apply -> (Rle_le_minus sor). -now apply -> (Rlt_lt_minus sor). -now apply -> (Rlt_lt_minus sor). +- symmetry. + now apply (Rminus_eq_0 sor). +- rewrite (Rminus_eq_0 sor). + tauto. +- now apply (Rle_le_minus sor). +- now apply (Rle_le_minus sor). +- now apply (Rlt_lt_minus sor). +- now apply (Rlt_lt_minus sor). Qed. Theorem negate_correct : @@ -784,92 +793,173 @@ Theorem negate_correct : Proof. intros env f; destruct f as [lhs op rhs]; simpl. destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. -symmetry. rewrite (Rminus_eq_0 sor). +- symmetry. rewrite (Rminus_eq_0 sor). split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)]. -rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor). -rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). -rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). -rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). -rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). +- rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor). +- rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). +- rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). +- rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). +- rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). Qed. (** Another normalisation - this is used for cnf conversion **) -Definition xnormalise (t:Formula C) : list (NFormula) := - let (lhs,o,rhs) := t in - let lhs := norm lhs in - let rhs := norm rhs in +Definition xnormalise (f:NFormula) : list (NFormula) := + let (e,o) := f in + match o with + | Equal => (e , Strict) :: (popp e, Strict) :: nil + | NonEqual => (e , Equal) :: nil + | Strict => (popp e, NonStrict) :: nil + | NonStrict => (popp e, Strict) :: nil + end. + +Definition xnegate (t:NFormula) : list (NFormula) := + let (e,o) := t in match o with - | OpEq => - (psub lhs rhs, Strict)::(psub rhs lhs , Strict)::nil - | OpNEq => (psub lhs rhs,Equal) :: nil - | OpGt => (psub rhs lhs,NonStrict) :: nil - | OpLt => (psub lhs rhs,NonStrict) :: nil - | OpGe => (psub rhs lhs , Strict) :: nil - | OpLe => (psub lhs rhs ,Strict) :: nil + | Equal => (e,Equal) :: nil + | NonEqual => (e,Strict)::(popp e,Strict)::nil + | Strict => (e,Strict) :: nil + | NonStrict => (e,NonStrict) :: nil end. -Import Coq.micromega.Tauto. -Definition cnf_normalise {T : Type} (t:Formula C) (tg : T) : cnf NFormula T := - List.map (fun x => (x,tg)::nil) (xnormalise t). +Import Coq.micromega.Tauto. +Definition cnf_of_list {T : Type} (l:list NFormula) (tg : T) : cnf NFormula T := + List.fold_right (fun x acc => + if check_inconsistent x then acc else ((x,tg)::nil)::acc) + (cnf_tt _ _) l. Add Ring SORRing : (SORrt sor). -Lemma cnf_normalise_correct : forall (T : Type) env t tg, eval_cnf (Annot:=T) eval_nformula env (cnf_normalise t tg) -> eval_formula env t. +Lemma cnf_of_list_correct : + forall (T : Type) env l tg, + eval_cnf (Annot:=T) eval_nformula env (cnf_of_list l tg) <-> + make_conj (fun x : NFormula => eval_nformula env x -> False) l. Proof. - unfold cnf_normalise, xnormalise ; simpl ; intros T env t tg. - unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o ; unfold eval_tt; - simpl; - repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; - generalize (eval_pexpr env lhs); - generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. - - apply (SORle_antisymm sor). - + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - - now rewrite <- (Rminus_eq_0 sor). - - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. - - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. + unfold cnf_of_list. + intros T env l tg. + set (F := (fun (x : NFormula) (acc : list (list (NFormula * T))) => + if check_inconsistent x then acc else ((x, tg) :: nil) :: acc)). + set (G := ((fun x : NFormula => eval_nformula env x -> False))). + induction l. + - compute. + tauto. + - rewrite make_conj_cons. + simpl. + unfold F at 1. + destruct (check_inconsistent a) eqn:EQ. + + rewrite IHl. + unfold G. + destruct a. + specialize (check_inconsistent_sound _ _ EQ env). + simpl. + tauto. + + + rewrite <- eval_cnf_cons_iff with (1:= fun env (term:Formula Z) => True) . + simpl. + unfold eval_tt. simpl. + rewrite IHl. + unfold G at 2. + tauto. Qed. -Definition xnegate (t:Formula C) : list (NFormula) := - let (lhs,o,rhs) := t in - let lhs := norm lhs in - let rhs := norm rhs in - match o with - | OpEq => (psub lhs rhs,Equal) :: nil - | OpNEq => (psub lhs rhs ,Strict)::(psub rhs lhs,Strict)::nil - | OpGt => (psub lhs rhs,Strict) :: nil - | OpLt => (psub rhs lhs,Strict) :: nil - | OpGe => (psub lhs rhs,NonStrict) :: nil - | OpLe => (psub rhs lhs,NonStrict) :: nil - end. +Definition cnf_normalise {T: Type} (t: Formula C) (tg: T) : cnf NFormula T := + let f := normalise t in + if check_inconsistent f then cnf_ff _ _ + else cnf_of_list (xnormalise f) tg. -Definition cnf_negate {T : Type} (t:Formula C) (tg:T) : cnf NFormula T := - List.map (fun x => (x,tg)::nil) (xnegate t). +Definition cnf_negate {T: Type} (t: Formula C) (tg: T) : cnf NFormula T := + let f := normalise t in + if check_inconsistent f then cnf_tt _ _ + else cnf_of_list (xnegate f) tg. + +Lemma eq0_cnf : forall x, + (0 < x -> False) /\ (0 < - x -> False) <-> x == 0. +Proof. + split ; intros. + + apply (SORle_antisymm sor). + * now rewrite (Rle_ngt sor). + * rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). + setoid_replace (0 - x) with (-x) by ring. + tauto. + + split; intro. + * rewrite (SORlt_le_neq sor) in H0. + apply (proj2 H0). + now rewrite H. + * rewrite (SORlt_le_neq sor) in H0. + apply (proj2 H0). + rewrite H. ring. +Qed. + +Lemma xnormalise_correct : forall env f, + (make_conj (fun x => eval_nformula env x -> False) (xnormalise f)) <-> eval_nformula env f. +Proof. + intros env f. + destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; + repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; + repeat rewrite eval_pol_opp; + generalize (eval_pol env e) as x; intro. + - apply eq0_cnf. + - unfold not. tauto. + - symmetry. rewrite (Rlt_nge sor). + rewrite (Rle_le_minus sor). + setoid_replace (0 - x) with (-x) by ring. + tauto. + - rewrite (Rle_ngt sor). + symmetry. + rewrite (Rlt_lt_minus sor). + setoid_replace (0 - x) with (-x) by ring. + tauto. +Qed. + + +Lemma xnegate_correct : forall env f, + (make_conj (fun x => eval_nformula env x -> False) (xnegate f)) <-> ~ eval_nformula env f. +Proof. + intros env f. + destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; + repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; + repeat rewrite eval_pol_opp; + generalize (eval_pol env e) as x; intro. + - tauto. + - rewrite eq0_cnf. + rewrite (Req_dne sor). + tauto. + - tauto. + - tauto. +Qed. + + +Lemma cnf_normalise_correct : forall (T : Type) env t tg, eval_cnf (Annot:=T) eval_nformula env (cnf_normalise t tg) <-> eval_formula env t. +Proof. + intros T env t tg. + unfold cnf_normalise. + rewrite normalise_sound. + generalize (normalise t) as f;intro. + destruct (check_inconsistent f) eqn:U. + - destruct f as [e op]. + assert (US := check_inconsistent_sound _ _ U env). + rewrite eval_cnf_ff with (1:= eval_nformula). + tauto. + - intros. rewrite cnf_of_list_correct. + now apply xnormalise_correct. +Qed. -Lemma cnf_negate_correct : forall (T : Type) env t (tg:T), eval_cnf eval_nformula env (cnf_negate t tg) -> ~ eval_formula env t. +Lemma cnf_negate_correct : forall (T : Type) env t (tg:T), eval_cnf eval_nformula env (cnf_negate t tg) <-> ~ eval_formula env t. Proof. - unfold cnf_negate, xnegate ; simpl ; intros T env t tg. - unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o ; unfold eval_tt; simpl; - repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; - generalize (eval_pexpr env lhs); - generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; intuition. + intros T env t tg. + rewrite normalise_sound. + unfold cnf_negate. + generalize (normalise t) as f;intro. + destruct (check_inconsistent f) eqn:U. - - apply H0. - rewrite H1 ; ring. - - apply H1. apply (SORle_antisymm sor). - + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - - apply H0. now rewrite (Rle_le_minus sor) in H1. - - apply H0. now rewrite (Rle_le_minus sor) in H1. - - apply H0. now rewrite (Rlt_lt_minus sor) in H1. - - apply H0. now rewrite (Rlt_lt_minus sor) in H1. + destruct f as [e o]. + assert (US := check_inconsistent_sound _ _ U env). + rewrite eval_cnf_tt with (1:= eval_nformula). + tauto. + - rewrite cnf_of_list_correct. + apply xnegate_correct. Qed. Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index d6ccf582ae..02dd29ef14 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -223,32 +223,59 @@ Section S. end end. - (* Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.map (fun x => (t++x)) f. *) - - Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.fold_right (fun e acc => + Definition xor_clause_cnf (t:clause) (f:cnf) : cnf := + List.fold_left (fun acc e => match or_clause t e with | None => acc | Some cl => cl :: acc - end) nil f. + end) f nil . + + Definition or_clause_cnf (t: clause) (f:cnf) : cnf := + match t with + | nil => f + | _ => xor_clause_cnf t f + end. Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := match f with | nil => cnf_tt - | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') + | e :: rst => (or_cnf rst f') +++ (or_clause_cnf e f') end. Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := - f1 ++ f2. + f1 +++ f2. (** TX is Prop in Coq and EConstr.constr in Ocaml. AF i s unit in Coq and Names.Id.t in Ocaml *) Definition TFormula (TX: Type) (AF: Type) := @GFormula Term TX Annot AF. + + Definition is_cnf_tt (c : cnf) : bool := + match c with + | nil => true + | _ => false + end. + + Definition is_cnf_ff (c : cnf) : bool := + match c with + | nil::nil => true + | _ => false + end. + + Definition and_cnf_opt (f1 : cnf) (f2 : cnf) : cnf := + if is_cnf_ff f1 || is_cnf_ff f2 + then cnf_ff + else and_cnf f1 f2. + + Definition or_cnf_opt (f1 : cnf) (f2 : cnf) : cnf := + if is_cnf_tt f1 || is_cnf_tt f2 + then cnf_tt + else if is_cnf_ff f2 + then f1 else or_cnf f1 f2. + Fixpoint xcnf {TX AF: Type} (pol : bool) (f : TFormula TX AF) {struct f}: cnf := match f with | TT => if pol then cnf_tt else cnf_ff @@ -257,9 +284,10 @@ Section S. | A x t => if pol then normalise x t else negate x t | N e => xcnf (negb pol) e | Cj e1 e2 => - (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) - | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) - | I e1 _ e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) + (if pol then and_cnf_opt else or_cnf_opt) (xcnf pol e1) (xcnf pol e2) + | D e1 e2 => (if pol then or_cnf_opt else and_cnf_opt) (xcnf pol e1) (xcnf pol e2) + | I e1 _ e2 + => (if pol then or_cnf_opt else and_cnf_opt) (xcnf (negb pol) e1) (xcnf pol e2) end. Section CNFAnnot. @@ -269,8 +297,6 @@ Section S. For efficiency, this is a separate function. *) - - Fixpoint radd_term (t : Term' * Annot) (cl : clause) : clause + list Annot := match cl with | nil => (* if t is unsat, the clause is empty BUT t is needed. *) @@ -301,56 +327,616 @@ Section S. end end. - Definition ror_clause_cnf t f := - List.fold_right (fun e '(acc,tg) => + Definition xror_clause_cnf t f := + List.fold_left (fun '(acc,tg) e => match ror_clause t e with | inl cl => (cl :: acc,tg) - | inr l => (acc,tg++l) - end) (nil,nil) f . + | inr l => (acc,tg+++l) + end) f (nil,nil). + + Definition ror_clause_cnf t f := + match t with + | nil => (f,nil) + | _ => xror_clause_cnf t f + end. - Fixpoint ror_cnf f f' := + Fixpoint ror_cnf (f f':list clause) := match f with | nil => (cnf_tt,nil) | e :: rst => let (rst_f',t) := ror_cnf rst f' in let (e_f', t') := ror_clause_cnf e f' in - (rst_f' ++ e_f', t ++ t') + (rst_f' +++ e_f', t +++ t') + end. + + Definition annot_of_clause (l : clause) : list Annot := + List.map snd l. + + Definition annot_of_cnf (f : cnf) : list Annot := + List.fold_left (fun acc e => annot_of_clause e +++ acc ) f nil. + + + Definition ror_cnf_opt f1 f2 := + if is_cnf_tt f1 + then (cnf_tt , nil) + else if is_cnf_tt f2 + then (cnf_tt, nil) + else if is_cnf_ff f2 + then (f1,nil) + else ror_cnf f1 f2. + + + Definition ocons {A : Type} (o : option A) (l : list A) : list A := + match o with + | None => l + | Some e => e ::l end. - Fixpoint rxcnf {TX AF: Type}(polarity : bool) (f : TFormula TX AF) := + Definition ratom (c : cnf) (a : Annot) : cnf * list Annot := + if is_cnf_ff c || is_cnf_tt c + then (c,a::nil) + else (c,nil). (* t is embedded in c *) + + Fixpoint rxcnf {TX AF: Type}(polarity : bool) (f : TFormula TX AF) : cnf * list Annot := match f with | TT => if polarity then (cnf_tt,nil) else (cnf_ff,nil) | FF => if polarity then (cnf_ff,nil) else (cnf_tt,nil) | X p => if polarity then (cnf_ff,nil) else (cnf_ff,nil) - | A x t => ((if polarity then normalise x t else negate x t),nil) + | A x t => ratom (if polarity then normalise x t else negate x t) t | N e => rxcnf (negb polarity) e | Cj e1 e2 => - let (e1,t1) := rxcnf polarity e1 in - let (e2,t2) := rxcnf polarity e2 in + let '(e1,t1) := rxcnf polarity e1 in + let '(e2,t2) := rxcnf polarity e2 in if polarity - then (e1 ++ e2, t1 ++ t2) - else let (f',t') := ror_cnf e1 e2 in - (f', t1 ++ t2 ++ t') + then (and_cnf_opt e1 e2, t1 +++ t2) + else let (f',t') := ror_cnf_opt e1 e2 in + (f', t1 +++ t2 +++ t') | D e1 e2 => - let (e1,t1) := rxcnf polarity e1 in - let (e2,t2) := rxcnf polarity e2 in + let '(e1,t1) := rxcnf polarity e1 in + let '(e2,t2) := rxcnf polarity e2 in if polarity - then let (f',t') := ror_cnf e1 e2 in - (f', t1 ++ t2 ++ t') - else (e1 ++ e2, t1 ++ t2) - | I e1 _ e2 => - let (e1 , t1) := (rxcnf (negb polarity) e1) in - let (e2 , t2) := (rxcnf polarity e2) in + then let (f',t') := ror_cnf_opt e1 e2 in + (f', t1 +++ t2 +++ t') + else (and_cnf_opt e1 e2, t1 +++ t2) + | I e1 a e2 => + let '(e1 , t1) := (rxcnf (negb polarity) e1) in if polarity - then let (f',t') := ror_cnf e1 e2 in - (f', t1 ++ t2 ++ t') - else (and_cnf e1 e2, t1 ++ t2) + then + if is_cnf_ff e1 + then + rxcnf polarity e2 + else (* compute disjunction *) + let '(e2 , t2) := (rxcnf polarity e2) in + let (f',t') := ror_cnf_opt e1 e2 in + (f', t1 +++ t2 +++ t') (* record the hypothesis *) + else + let '(e2 , t2) := (rxcnf polarity e2) in + (and_cnf_opt e1 e2, t1 +++ t2) end. + + Section Abstraction. + Variable TX : Type. + Variable AF : Type. + + Class to_constrT : Type := + { + mkTT : TX; + mkFF : TX; + mkA : Term -> Annot -> TX; + mkCj : TX -> TX -> TX; + mkD : TX -> TX -> TX; + mkI : TX -> TX -> TX; + mkN : TX -> TX + }. + + Context {to_constr : to_constrT}. + + Fixpoint aformula (f : TFormula TX AF) : TX := + match f with + | TT => mkTT + | FF => mkFF + | X p => p + | A x t => mkA x t + | Cj f1 f2 => mkCj (aformula f1) (aformula f2) + | D f1 f2 => mkD (aformula f1) (aformula f2) + | I f1 o f2 => mkI (aformula f1) (aformula f2) + | N f => mkN (aformula f) + end. + + + Definition is_X (f : TFormula TX AF) : option TX := + match f with + | X p => Some p + | _ => None + end. + + Definition is_X_inv : forall f x, + is_X f = Some x -> f = X x. + Proof. + destruct f ; simpl ; congruence. + Qed. + + + Variable needA : Annot -> bool. + + Definition abs_and (f1 f2 : TFormula TX AF) + (c : TFormula TX AF -> TFormula TX AF -> TFormula TX AF) := + match is_X f1 , is_X f2 with + | Some _ , _ | _ , Some _ => X (aformula (c f1 f2)) + | _ , _ => c f1 f2 + end. + + Definition abs_or (f1 f2 : TFormula TX AF) + (c : TFormula TX AF -> TFormula TX AF -> TFormula TX AF) := + match is_X f1 , is_X f2 with + | Some _ , Some _ => X (aformula (c f1 f2)) + | _ , _ => c f1 f2 + end. + + Definition mk_arrow (o : option AF) (f1 f2: TFormula TX AF) := + match o with + | None => I f1 None f2 + | Some _ => if is_X f1 then f2 else I f1 o f2 + end. + + + Fixpoint abst_form (pol : bool) (f : TFormula TX AF) := + match f with + | TT => if pol then TT else X mkTT + | FF => if pol then X mkFF else FF + | X p => X p + | A x t => if needA t then A x t else X (mkA x t) + | Cj f1 f2 => + let f1 := abst_form pol f1 in + let f2 := abst_form pol f2 in + if pol then abs_and f1 f2 Cj + else abs_or f1 f2 Cj + | D f1 f2 => + let f1 := abst_form pol f1 in + let f2 := abst_form pol f2 in + if pol then abs_or f1 f2 D + else abs_and f1 f2 D + | I f1 o f2 => + let f1 := abst_form (negb pol) f1 in + let f2 := abst_form pol f2 in + if pol + then abs_or f1 f2 (mk_arrow o) + else abs_and f1 f2 (mk_arrow o) + | N f => let f := abst_form (negb pol) f in + match is_X f with + | Some a => X (mkN a) + | _ => N f + end + end. + + + + + Lemma if_same : forall {A: Type} (b:bool) (t:A), + (if b then t else t) = t. + Proof. + destruct b ; reflexivity. + Qed. + + Lemma is_cnf_tt_cnf_ff : + is_cnf_tt cnf_ff = false. + Proof. + reflexivity. + Qed. + + Lemma is_cnf_ff_cnf_ff : + is_cnf_ff cnf_ff = true. + Proof. + reflexivity. + Qed. + + + Lemma is_cnf_tt_inv : forall f1, + is_cnf_tt f1 = true -> f1 = cnf_tt. + Proof. + unfold cnf_tt. + destruct f1 ; simpl ; try congruence. + Qed. + + Lemma is_cnf_ff_inv : forall f1, + is_cnf_ff f1 = true -> f1 = cnf_ff. + Proof. + unfold cnf_ff. + destruct f1 ; simpl ; try congruence. + destruct c ; simpl ; try congruence. + destruct f1 ; try congruence. + reflexivity. + Qed. + + + Lemma if_cnf_tt : forall f, (if is_cnf_tt f then cnf_tt else f) = f. + Proof. + intros. + destruct (is_cnf_tt f) eqn:EQ. + apply is_cnf_tt_inv in EQ;auto. + reflexivity. + Qed. + + Lemma or_cnf_opt_cnf_ff : forall f, + or_cnf_opt cnf_ff f = f. + Proof. + intros. + unfold or_cnf_opt. + rewrite is_cnf_tt_cnf_ff. + simpl. + destruct (is_cnf_tt f) eqn:EQ. + apply is_cnf_tt_inv in EQ. + congruence. + destruct (is_cnf_ff f) eqn:EQ1. + apply is_cnf_ff_inv in EQ1. + congruence. + reflexivity. + Qed. + + Lemma abs_and_pol : forall f1 f2 pol, + and_cnf_opt (xcnf pol f1) (xcnf pol f2) = + xcnf pol (abs_and f1 f2 (if pol then Cj else D)). + Proof. + unfold abs_and; intros. + destruct (is_X f1) eqn:EQ1. + apply is_X_inv in EQ1. + subst. + simpl. + rewrite if_same. reflexivity. + destruct (is_X f2) eqn:EQ2. + apply is_X_inv in EQ2. + subst. + simpl. + rewrite if_same. + unfold and_cnf_opt. + rewrite orb_comm. reflexivity. + destruct pol ; simpl; auto. + Qed. + + Lemma abs_or_pol : forall f1 f2 pol, + or_cnf_opt (xcnf pol f1) (xcnf pol f2) = + xcnf pol (abs_or f1 f2 (if pol then D else Cj)). + Proof. + unfold abs_or; intros. + destruct (is_X f1) eqn:EQ1. + apply is_X_inv in EQ1. + subst. + destruct (is_X f2) eqn:EQ2. + apply is_X_inv in EQ2. + subst. + simpl. + rewrite if_same. + reflexivity. + simpl. + rewrite if_same. + destruct pol ; simpl; auto. + destruct pol ; simpl ; auto. + Qed. + + Variable needA_all : forall a, needA a = true. + + Lemma xcnf_true_mk_arrow_l : forall o t f, + xcnf true (mk_arrow o (X t) f) = xcnf true f. + Proof. + destruct o ; simpl; auto. + intros. rewrite or_cnf_opt_cnf_ff. reflexivity. + Qed. + + Lemma or_cnf_opt_cnf_ff_r : forall f, + or_cnf_opt f cnf_ff = f. + Proof. + unfold or_cnf_opt. + intros. + rewrite is_cnf_tt_cnf_ff. + rewrite orb_comm. + simpl. + apply if_cnf_tt. + Qed. + + Lemma xcnf_true_mk_arrow_r : forall o t f, + xcnf true (mk_arrow o f (X t)) = xcnf false f. + Proof. + destruct o ; simpl; auto. + - intros. + destruct (is_X f) eqn:EQ. + apply is_X_inv in EQ. subst. reflexivity. + simpl. + apply or_cnf_opt_cnf_ff_r. + - intros. + apply or_cnf_opt_cnf_ff_r. + Qed. + + + + Lemma abst_form_correct : forall f pol, + xcnf pol f = xcnf pol (abst_form pol f). + Proof. + induction f;intros. + - simpl. destruct pol ; reflexivity. + - simpl. destruct pol ; reflexivity. + - simpl. reflexivity. + - simpl. rewrite needA_all. + reflexivity. + - simpl. + specialize (IHf1 pol). + specialize (IHf2 pol). + rewrite IHf1. + rewrite IHf2. + destruct pol. + + + apply abs_and_pol; auto. + + + apply abs_or_pol; auto. + - simpl. + specialize (IHf1 pol). + specialize (IHf2 pol). + rewrite IHf1. + rewrite IHf2. + destruct pol. + + + apply abs_or_pol; auto. + + + apply abs_and_pol; auto. + - simpl. + specialize (IHf (negb pol)). + destruct (is_X (abst_form (negb pol) f)) eqn:EQ1. + + apply is_X_inv in EQ1. + rewrite EQ1 in *. + simpl in *. + destruct pol ; auto. + + simpl. congruence. + - simpl. + specialize (IHf1 (negb pol)). + specialize (IHf2 pol). + destruct pol. + + + simpl in *. + unfold abs_or. + destruct (is_X (abst_form false f1)) eqn:EQ1; + destruct (is_X (abst_form true f2)) eqn:EQ2 ; simpl. + * apply is_X_inv in EQ1. + apply is_X_inv in EQ2. + rewrite EQ1 in *. + rewrite EQ2 in *. + rewrite IHf1. rewrite IHf2. + simpl. reflexivity. + * apply is_X_inv in EQ1. + rewrite EQ1 in *. + rewrite IHf1. + simpl. + rewrite xcnf_true_mk_arrow_l. + rewrite or_cnf_opt_cnf_ff. + congruence. + * apply is_X_inv in EQ2. + rewrite EQ2 in *. + rewrite IHf2. + simpl. + rewrite xcnf_true_mk_arrow_r. + rewrite or_cnf_opt_cnf_ff_r. + congruence. + * destruct o ; simpl ; try congruence. + rewrite EQ1. + simpl. congruence. + + simpl in *. + unfold abs_and. + destruct (is_X (abst_form true f1)) eqn:EQ1; + destruct (is_X (abst_form false f2)) eqn:EQ2 ; simpl. + * apply is_X_inv in EQ1. + apply is_X_inv in EQ2. + rewrite EQ1 in *. + rewrite EQ2 in *. + rewrite IHf1. rewrite IHf2. + simpl. reflexivity. + * apply is_X_inv in EQ1. + rewrite EQ1 in *. + rewrite IHf1. + simpl. reflexivity. + * apply is_X_inv in EQ2. + rewrite EQ2 in *. + rewrite IHf2. + simpl. unfold and_cnf_opt. + rewrite orb_comm. reflexivity. + * destruct o; simpl. + rewrite EQ1. simpl. + congruence. + congruence. + Qed. + + End Abstraction. + + End CNFAnnot. + Lemma radd_term_term : forall a' a cl, radd_term a a' = inl cl -> add_term a a' = Some cl. + Proof. + induction a' ; simpl. + - intros. + destruct (deduce (fst a) (fst a)). + destruct (unsat t). congruence. + inversion H. reflexivity. + inversion H ;reflexivity. + - intros. + destruct (deduce (fst a0) (fst a)). + destruct (unsat t). congruence. + destruct (radd_term a0 a') eqn:RADD; try congruence. + inversion H. subst. + apply IHa' in RADD. + rewrite RADD. + reflexivity. + destruct (radd_term a0 a') eqn:RADD; try congruence. + inversion H. subst. + apply IHa' in RADD. + rewrite RADD. + reflexivity. + Qed. + + Lemma radd_term_term' : forall a' a cl, add_term a a' = Some cl -> radd_term a a' = inl cl. + Proof. + induction a' ; simpl. + - intros. + destruct (deduce (fst a) (fst a)). + destruct (unsat t). congruence. + inversion H. reflexivity. + inversion H ;reflexivity. + - intros. + destruct (deduce (fst a0) (fst a)). + destruct (unsat t). congruence. + destruct (add_term a0 a') eqn:RADD; try congruence. + inversion H. subst. + apply IHa' in RADD. + rewrite RADD. + reflexivity. + destruct (add_term a0 a') eqn:RADD; try congruence. + inversion H. subst. + apply IHa' in RADD. + rewrite RADD. + reflexivity. + Qed. + + Lemma xror_clause_clause : forall a f, + fst (xror_clause_cnf a f) = xor_clause_cnf a f. + Proof. + unfold xror_clause_cnf. + unfold xor_clause_cnf. + assert (ACC: fst (@nil clause,@nil Annot) = nil). + reflexivity. + intros. + set (F1:= (fun '(acc, tg) (e : clause) => + match ror_clause a e with + | inl cl => (cl :: acc, tg) + | inr l => (acc, tg +++ l) + end)). + set (F2:= (fun (acc : list clause) (e : clause) => + match or_clause a e with + | Some cl => cl :: acc + | None => acc + end)). + revert ACC. + generalize (@nil clause,@nil Annot). + generalize (@nil clause). + induction f ; simpl ; auto. + intros. + apply IHf. + unfold F1 , F2. + destruct p ; simpl in * ; subst. + clear. + revert a0. + induction a; simpl; auto. + intros. + destruct (radd_term a a1) eqn:RADD. + apply radd_term_term in RADD. + rewrite RADD. + auto. + destruct (add_term a a1) eqn:RADD'. + apply radd_term_term' in RADD'. + congruence. + reflexivity. + Qed. + + Lemma ror_clause_clause : forall a f, + fst (ror_clause_cnf a f) = or_clause_cnf a f. + Proof. + unfold ror_clause_cnf,or_clause_cnf. + destruct a ; auto. + apply xror_clause_clause. + Qed. + + Lemma ror_cnf_cnf : forall f1 f2, fst (ror_cnf f1 f2) = or_cnf f1 f2. + Proof. + induction f1 ; simpl ; auto. + intros. + specialize (IHf1 f2). + destruct(ror_cnf f1 f2). + rewrite <- ror_clause_clause. + destruct(ror_clause_cnf a f2). + simpl. + rewrite <- IHf1. + reflexivity. + Qed. + + Lemma ror_opt_cnf_cnf : forall f1 f2, fst (ror_cnf_opt f1 f2) = or_cnf_opt f1 f2. + Proof. + unfold ror_cnf_opt, or_cnf_opt. + intros. + destruct (is_cnf_tt f1). + - simpl ; auto. + - simpl. destruct (is_cnf_tt f2) ; simpl ; auto. + destruct (is_cnf_ff f2) eqn:EQ. + reflexivity. + apply ror_cnf_cnf. + Qed. + + Lemma ratom_cnf : forall f a, + fst (ratom f a) = f. + Proof. + unfold ratom. + intros. + destruct (is_cnf_ff f || is_cnf_tt f); auto. + Qed. + + + + Lemma rxcnf_xcnf : forall {TX AF:Type} (f:TFormula TX AF) b, + fst (rxcnf b f) = xcnf b f. + Proof. + induction f ; simpl ; auto. + - destruct b; simpl ; auto. + - destruct b; simpl ; auto. + - destruct b ; simpl ; auto. + - intros. rewrite ratom_cnf. reflexivity. + - intros. + specialize (IHf1 b). + specialize (IHf2 b). + destruct (rxcnf b f1). + destruct (rxcnf b f2). + simpl in *. + subst. destruct b ; auto. + rewrite <- ror_opt_cnf_cnf. + destruct (ror_cnf_opt (xcnf false f1) (xcnf false f2)). + reflexivity. + - intros. + specialize (IHf1 b). + specialize (IHf2 b). + rewrite <- IHf1. + rewrite <- IHf2. + destruct (rxcnf b f1). + destruct (rxcnf b f2). + simpl in *. + subst. destruct b ; auto. + rewrite <- ror_opt_cnf_cnf. + destruct (ror_cnf_opt (xcnf true f1) (xcnf true f2)). + reflexivity. + - intros. + specialize (IHf1 (negb b)). + specialize (IHf2 b). + rewrite <- IHf1. + rewrite <- IHf2. + destruct (rxcnf (negb b) f1). + destruct (rxcnf b f2). + simpl in *. + subst. + destruct b;auto. + generalize (is_cnf_ff_inv (xcnf (negb true) f1)). + destruct (is_cnf_ff (xcnf (negb true) f1)). + + intros. + rewrite H by auto. + unfold or_cnf_opt. + simpl. + destruct (is_cnf_tt (xcnf true f2)) eqn:EQ;auto. + apply is_cnf_tt_inv in EQ; auto. + destruct (is_cnf_ff (xcnf true f2)) eqn:EQ1. + apply is_cnf_ff_inv in EQ1. congruence. + reflexivity. + + + rewrite <- ror_opt_cnf_cnf. + destruct (ror_cnf_opt (xcnf (negb true) f1) (xcnf true f2)). + intros. + reflexivity. + Qed. + Variable eval : Env -> Term -> Prop. @@ -364,8 +950,9 @@ Section S. - Variable deduce_prop : forall env t t' u, - eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u. + Variable deduce_prop : forall t t' u, + deduce t t' = Some u -> forall env, + eval' env t -> eval' env t' -> eval' env u. @@ -377,14 +964,55 @@ Section S. Definition eval_cnf (env : Env) (f:cnf) := make_conj (eval_clause env) f. - Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y. + Lemma eval_cnf_app : forall env x y, eval_cnf env (x+++y) <-> eval_cnf env x /\ eval_cnf env y. Proof. unfold eval_cnf. intros. - rewrite make_conj_app in H ; auto. + rewrite make_conj_rapp. + rewrite make_conj_app ; auto. + tauto. Qed. + Lemma eval_cnf_ff : forall env, eval_cnf env cnf_ff <-> False. + Proof. + unfold cnf_ff, eval_cnf,eval_clause. + simpl. tauto. + Qed. + + Lemma eval_cnf_tt : forall env, eval_cnf env cnf_tt <-> True. + Proof. + unfold cnf_tt, eval_cnf,eval_clause. + simpl. tauto. + Qed. + + + Lemma eval_cnf_and_opt : forall env x y, eval_cnf env (and_cnf_opt x y) <-> eval_cnf env (and_cnf x y). + Proof. + unfold and_cnf_opt. + intros. + destruct (is_cnf_ff x) eqn:F1. + { apply is_cnf_ff_inv in F1. + simpl. subst. + unfold and_cnf. + rewrite eval_cnf_app. + rewrite eval_cnf_ff. + tauto. + } + simpl. + destruct (is_cnf_ff y) eqn:F2. + { apply is_cnf_ff_inv in F2. + simpl. subst. + unfold and_cnf. + rewrite eval_cnf_app. + rewrite eval_cnf_ff. + tauto. + } + tauto. + Qed. + + + Definition eval_opt_clause (env : Env) (cl: option clause) := match cl with | None => True @@ -392,57 +1020,50 @@ Section S. end. - Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl). + Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) <-> eval_clause env (t::cl). Proof. induction cl. - (* BC *) simpl. - case_eq (deduce (fst t) (fst t)) ; auto. - intros *. - case_eq (unsat t0) ; auto. - unfold eval_clause. - rewrite make_conj_cons. - intros. intro. - apply unsat_prop with (1:= H) (env := env). - apply deduce_prop with (3:= H0) ; tauto. + case_eq (deduce (fst t) (fst t)) ; try tauto. + intros. + generalize (@deduce_prop _ _ _ H env). + case_eq (unsat t0) ; try tauto. + { intros. + generalize (@unsat_prop _ H0 env). + unfold eval_clause. + rewrite make_conj_cons. + simpl; intros. + tauto. + } - (* IC *) simpl. - case_eq (deduce (fst t) (fst a)). - intro u. - case_eq (unsat u). - simpl. intros. - unfold eval_clause. - intro. - apply unsat_prop with (1:= H) (env:= env). - repeat rewrite make_conj_cons in H2. - apply deduce_prop with (3:= H0); tauto. - intro. - case_eq (add_term t cl) ; intros. - simpl in H2. - rewrite H0 in IHcl. - simpl in IHcl. - unfold eval_clause in *. - intros. - repeat rewrite make_conj_cons in *. - tauto. - rewrite H0 in IHcl ; simpl in *. - unfold eval_clause in *. + case_eq (deduce (fst t) (fst a)); intros. - repeat rewrite make_conj_cons in *. - tauto. - case_eq (add_term t cl) ; intros. - simpl in H1. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - rewrite H in IHcl. - simpl in IHcl. - tauto. - simpl in *. - rewrite H in IHcl. - simpl in IHcl. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - tauto. + generalize (@deduce_prop _ _ _ H env). + case_eq (unsat t0); intros. + { + generalize (@unsat_prop _ H0 env). + simpl. + unfold eval_clause. + repeat rewrite make_conj_cons. + tauto. + } + destruct (add_term t cl) ; simpl in * ; try tauto. + { + intros. + unfold eval_clause in *. + repeat rewrite make_conj_cons in *. + tauto. + } + { + unfold eval_clause in *. + repeat rewrite make_conj_cons in *. + tauto. + } + destruct (add_term t cl) ; simpl in *; + unfold eval_clause in * ; + repeat rewrite make_conj_cons in *; tauto. Qed. @@ -455,80 +1076,84 @@ Section S. Hint Resolve no_middle_eval_tt : tauto. - Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'. + Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') <-> eval_clause env cl \/ eval_clause env cl'. Proof. induction cl. - - simpl. tauto. + - simpl. unfold eval_clause at 2. simpl. tauto. - intros *. simpl. assert (HH := add_term_correct env a cl'). - case_eq (add_term a cl'). + assert (eval_tt env a \/ ~ eval_tt env a) by (apply no_middle_eval'). + destruct (add_term a cl'); simpl in *. + - intros. - apply IHcl in H0. - rewrite H in HH. - simpl in HH. + rewrite IHcl. unfold eval_clause in *. - destruct H0. - * - repeat rewrite make_conj_cons in *. + rewrite !make_conj_cons in *. tauto. - * apply HH in H0. - apply not_make_conj_cons in H0 ; auto with tauto. + + unfold eval_clause in *. repeat rewrite make_conj_cons in *. tauto. - + - intros. - rewrite H in HH. - simpl in HH. - unfold eval_clause in *. - assert (HH' := HH Coq.Init.Logic.I). - apply not_make_conj_cons in HH'; auto with tauto. - repeat rewrite make_conj_cons in *. - tauto. Qed. - Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f). + Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) <-> (eval_clause env t) \/ (eval_cnf env f). Proof. unfold eval_cnf. unfold or_clause_cnf. intros until t. - set (F := (fun (e : clause) (acc : list clause) => + set (F := (fun (acc : list clause) (e : clause) => match or_clause t e with | Some cl => cl :: acc | None => acc end)). - induction f;auto. - simpl. - intros. - destruct f. - - simpl in H. - simpl in IHf. - unfold F in H. - revert H. - intros. - apply or_clause_correct. - destruct (or_clause t a) ; simpl in * ; auto. - - - unfold F in H at 1. - revert H. - assert (HH := or_clause_correct t a env). - destruct (or_clause t a); simpl in HH ; - rewrite make_conj_cons in * ; intuition. - rewrite make_conj_cons in *. - tauto. + intro f. + assert ( make_conj (eval_clause env) (fold_left F f nil) <-> (eval_clause env t \/ make_conj (eval_clause env) f) /\ make_conj (eval_clause env) nil). + { + generalize (@nil clause) as acc. + induction f. + - simpl. + intros ; tauto. + - intros. + simpl fold_left. + rewrite IHf. + rewrite make_conj_cons. + unfold F in *; clear F. + generalize (or_clause_correct t a env). + destruct (or_clause t a). + + + rewrite make_conj_cons. + simpl. tauto. + + simpl. tauto. + } + destruct t ; auto. + - unfold eval_clause ; simpl. tauto. + - unfold xor_clause_cnf. + unfold F in H. + rewrite H. + unfold make_conj at 2. tauto. Qed. - Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval_tt env) a) -> eval_cnf env f -> eval_cnf env (a::f). + Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval_tt env) a /\ eval_cnf env f) <-> eval_cnf env (a::f). + Proof. + intros. + unfold eval_cnf in *. + rewrite make_conj_cons ; eauto. + unfold eval_clause at 2. + tauto. + Qed. + + Lemma eval_cnf_cons_iff : forall env a f, ((~ make_conj (eval_tt env) a) /\ eval_cnf env f) <-> eval_cnf env (a::f). Proof. intros. unfold eval_cnf in *. rewrite make_conj_cons ; eauto. + unfold eval_clause. + tauto. Qed. - Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env f) \/ (eval_cnf env f'). + + Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') <-> (eval_cnf env f) \/ (eval_cnf env f'). Proof. induction f. unfold eval_cnf. @@ -536,17 +1161,49 @@ Section S. tauto. (**) intros. - simpl in H. - destruct (eval_cnf_app _ _ _ H). - clear H. - destruct (IHf _ H0). - destruct (or_clause_cnf_correct _ _ _ H1). - left. - apply eval_cnf_cons ; auto. - right ; auto. - right ; auto. + simpl. + rewrite eval_cnf_app. + rewrite <- eval_cnf_cons_iff. + rewrite IHf. + rewrite or_clause_cnf_correct. + unfold eval_clause. + tauto. Qed. + Lemma or_cnf_opt_correct : forall env f f', eval_cnf env (or_cnf_opt f f') <-> eval_cnf env (or_cnf f f'). + Proof. + unfold or_cnf_opt. + intros. + destruct (is_cnf_tt f) eqn:TF. + { simpl. + apply is_cnf_tt_inv in TF. + subst. + rewrite or_cnf_correct. + rewrite eval_cnf_tt. + tauto. + } + destruct (is_cnf_tt f') eqn:TF'. + { simpl. + apply is_cnf_tt_inv in TF'. + subst. + rewrite or_cnf_correct. + rewrite eval_cnf_tt. + tauto. + } + { simpl. + destruct (is_cnf_ff f') eqn:EQ. + apply is_cnf_ff_inv in EQ. + subst. + rewrite or_cnf_correct. + rewrite eval_cnf_ff. + tauto. + tauto. + } + Qed. + + + + Variable normalise_correct : forall env t tg, eval_cnf env (normalise t tg) -> eval env t. Variable negate_correct : forall env t tg, eval_cnf env (negate t tg) -> ~ eval env t. @@ -554,16 +1211,16 @@ Section S. Lemma xcnf_correct : forall (f : @GFormula Term Prop Annot unit) pol env, eval_cnf env (xcnf pol f) -> eval_f (fun x => x) (eval env) (if pol then f else N f). Proof. induction f. - (* TT *) + - (* TT *) unfold eval_cnf. simpl. destruct pol ; simpl ; auto. - (* FF *) + - (* FF *) unfold eval_cnf. destruct pol; simpl ; auto. unfold eval_clause ; simpl. tauto. - (* P *) + - (* P *) simpl. destruct pol ; intros ;simpl. unfold eval_cnf in H. @@ -575,7 +1232,7 @@ Section S. unfold eval_cnf in H;simpl in H. unfold eval_clause in H ; simpl in H. tauto. - (* A *) + - (* A *) simpl. destruct pol ; simpl. intros. @@ -583,49 +1240,54 @@ Section S. (* A 2 *) intros. eapply negate_correct ; eauto. - auto. - (* Cj *) + - (* Cj *) destruct pol ; simpl. - (* pol = true *) + + (* pol = true *) intros. + rewrite eval_cnf_and_opt in H. unfold and_cnf in H. - destruct (eval_cnf_app _ _ _ H). - clear H. + rewrite eval_cnf_app in H. + destruct H. split. - apply (IHf1 _ _ H0). - apply (IHf2 _ _ H1). - (* pol = false *) + apply (IHf1 _ _ H). + apply (IHf2 _ _ H0). + + (* pol = false *) intros. - destruct (or_cnf_correct _ _ _ H). - generalize (IHf1 false env H0). + rewrite or_cnf_opt_correct in H. + rewrite or_cnf_correct in H. + destruct H as [H | H]. + generalize (IHf1 false env H). simpl. tauto. - generalize (IHf2 false env H0). + generalize (IHf2 false env H). simpl. tauto. - (* D *) + - (* D *) simpl. destruct pol. - (* pol = true *) + + (* pol = true *) intros. - destruct (or_cnf_correct _ _ _ H). - generalize (IHf1 _ env H0). + rewrite or_cnf_opt_correct in H. + rewrite or_cnf_correct in H. + destruct H as [H | H]. + generalize (IHf1 _ env H). simpl. tauto. - generalize (IHf2 _ env H0). + generalize (IHf2 _ env H). simpl. tauto. - (* pol = true *) - unfold and_cnf. + + (* pol = true *) intros. - destruct (eval_cnf_app _ _ _ H). - clear H. + rewrite eval_cnf_and_opt in H. + unfold and_cnf. + rewrite eval_cnf_app in H. + destruct H as [H0 H1]. simpl. generalize (IHf1 _ _ H0). generalize (IHf2 _ _ H1). simpl. tauto. - (**) + - (**) simpl. destruct pol ; simpl. intros. @@ -633,25 +1295,29 @@ Section S. intros. generalize (IHf _ _ H). tauto. - (* I *) + - (* I *) simpl; intros. destruct pol. - simpl. + + simpl. intro. - destruct (or_cnf_correct _ _ _ H). - generalize (IHf1 _ _ H1). + rewrite or_cnf_opt_correct in H. + rewrite or_cnf_correct in H. + destruct H as [H | H]. + generalize (IHf1 _ _ H). simpl in *. tauto. - generalize (IHf2 _ _ H1). + generalize (IHf2 _ _ H). auto. - (* pol = false *) - unfold and_cnf in H. - simpl in H. - destruct (eval_cnf_app _ _ _ H). - generalize (IHf1 _ _ H0). - generalize (IHf2 _ _ H1). - simpl. - tauto. + + (* pol = false *) + rewrite eval_cnf_and_opt in H. + unfold and_cnf in H. + simpl in H. + rewrite eval_cnf_app in H. + destruct H as [H0 H1]. + generalize (IHf1 _ _ H0). + generalize (IHf2 _ _ H1). + simpl. + tauto. Qed. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index c0d22486b5..47c77ea927 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -23,6 +23,7 @@ Require Import ZCoeff. Require Import Refl. Require Import ZArith. (*Declare ML Module "micromega_plugin".*) +Open Scope Z_scope. Ltac flatten_bool := repeat match goal with @@ -32,10 +33,70 @@ Ltac flatten_bool := Ltac inv H := inversion H ; try subst ; clear H. +Lemma eq_le_iff : forall x, 0 = x <-> (0 <= x /\ x <= 0). +Proof. + intros. + split ; intros. + - subst. + compute. intuition congruence. + - destruct H. + apply Z.le_antisymm; auto. +Qed. + +Lemma lt_le_iff : forall x, + 0 < x <-> 0 <= x - 1. +Proof. + split ; intros. + - apply Zlt_succ_le. + ring_simplify. + auto. + - apply Zle_lt_succ in H. + ring_simplify in H. + auto. +Qed. + +Lemma le_0_iff : forall x y, + x <= y <-> 0 <= y - x. +Proof. + split ; intros. + - apply Zle_minus_le_0; auto. + - apply Zle_0_minus_le; auto. +Qed. + +Lemma le_neg : forall x, + ((0 <= x) -> False) <-> 0 < -x. +Proof. + intro. + rewrite lt_le_iff. + split ; intros. + - apply Znot_le_gt in H. + apply Zgt_le_succ in H. + rewrite le_0_iff in H. + ring_simplify in H; auto. + - assert (C := (Z.add_le_mono _ _ _ _ H H0)). + ring_simplify in C. + compute in C. + apply C ; reflexivity. +Qed. + +Lemma eq_cnf : forall x, + (0 <= x - 1 -> False) /\ (0 <= -1 - x -> False) <-> x = 0. +Proof. + intros. + rewrite Z.eq_sym_iff. + rewrite eq_le_iff. + rewrite (le_0_iff x 0). + rewrite !le_neg. + rewrite !lt_le_iff. + replace (- (x - 1) -1) with (-x) by ring. + replace (- (-1 - x) -1) with x by ring. + split ; intros (H1 & H2); auto. +Qed. -Require Import EnvRing. -Open Scope Z_scope. + + +Require Import EnvRing. Lemma Zsor : SOR 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt. Proof. @@ -211,83 +272,213 @@ Proof. apply (eval_pol_norm Zsor ZSORaddon). Qed. -Definition xnormalise (t:Formula Z) : list (NFormula Z) := +Definition Zunsat := check_inconsistent 0 Zeq_bool Z.leb. + +Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool. + +Lemma Zunsat_sound : forall f, + Zunsat f = true -> forall env, eval_nformula env f -> False. +Proof. + unfold Zunsat. + intros. + destruct f. + eapply check_inconsistent_sound with (1 := Zsor) (2 := ZSORaddon) in H; eauto. +Qed. + +Definition xnnormalise (t : Formula Z) : NFormula Z := let (lhs,o,rhs) := t in - let lhs := normZ lhs in - let rhs := normZ rhs in - match o with - | OpEq => - ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil - | OpNEq => (psub lhs rhs,Equal) :: nil - | OpGt => (psub rhs lhs,NonStrict) :: nil - | OpLt => (psub lhs rhs,NonStrict) :: nil - | OpGe => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil - | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil - end. + let lhs := normZ lhs in + let rhs := normZ rhs in + match o with + | OpEq => (psub rhs lhs, Equal) + | OpNEq => (psub rhs lhs, NonEqual) + | OpGt => (psub lhs rhs, Strict) + | OpLt => (psub rhs lhs, Strict) + | OpGe => (psub lhs rhs, NonStrict) + | OpLe => (psub rhs lhs, NonStrict) + end. + +Lemma xnnormalise_correct : + forall env f, + eval_nformula env (xnnormalise f) <-> Zeval_formula env f. +Proof. + intros. + rewrite Zeval_formula_compat. + unfold xnnormalise. + destruct f as [lhs o rhs]. + destruct o eqn:O ; cbn ; rewrite ?eval_pol_sub; + rewrite <- !eval_pol_norm ; simpl in *; + unfold eval_expr; + generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) env lhs); + generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) env rhs); intros. + - split ; intros. + + assert (z0 + (z - z0) = z0 + 0) by congruence. + rewrite Z.add_0_r in H0. + rewrite <- H0. + ring. + + subst. + ring. + - split ; repeat intro. + subst. apply H. ring. + apply H. + assert (z0 + (z - z0) = z0 + 0) by congruence. + rewrite Z.add_0_r in H1. + rewrite <- H1. + ring. + - split ; intros. + + apply Zle_0_minus_le; auto. + + apply Zle_minus_le_0; auto. + - split ; intros. + + apply Zle_0_minus_le; auto. + + apply Zle_minus_le_0; auto. + - split ; intros. + + apply Zlt_0_minus_lt; auto. + + apply Zlt_left_lt in H. + apply H. + - split ; intros. + + apply Zlt_0_minus_lt ; auto. + + apply Zlt_left_lt in H. + apply H. +Qed. + +Definition xnormalise (f: NFormula Z) : list (NFormula Z) := + let (e,o) := f in + match o with + | Equal => (psub e (Pc 1),NonStrict) :: (psub (Pc (-1)) e, NonStrict) :: nil + | NonStrict => ((psub (Pc (-1)) e,NonStrict)::nil) + | Strict => ((psub (Pc 0)) e, NonStrict)::nil + | NonEqual => (e, Equal)::nil + end. + +Lemma eval_pol_Pc : forall env z, + eval_pol env (Pc z) = z. +Proof. + reflexivity. +Qed. + +Ltac iff_ring := + match goal with + | |- ?F 0 ?X <-> ?F 0 ?Y => replace X with Y by ring ; tauto + end. + + +Lemma xnormalise_correct : forall env f, + (make_conj (fun x => eval_nformula env x -> False) (xnormalise f)) <-> eval_nformula env f. +Proof. + intros. + destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; + repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; + generalize (eval_pol env e) as x; intro. + - apply eq_cnf. + - unfold not. tauto. + - rewrite le_neg. + iff_ring. + - rewrite le_neg. + rewrite lt_le_iff. + iff_ring. +Qed. + Require Import Coq.micromega.Tauto BinNums. -Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := - List.map (fun x => (x,tg)::nil) (xnormalise t). +Definition cnf_of_list {T: Type} (tg : T) (l : list (NFormula Z)) := + List.fold_right (fun x acc => + if Zunsat x then acc else ((x,tg)::nil)::acc) + (cnf_tt _ _) l. + +Lemma cnf_of_list_correct : + forall {T : Type} (tg:T) (f : list (NFormula Z)) env, + eval_cnf eval_nformula env (cnf_of_list tg f) <-> + make_conj (fun x : NFormula Z => eval_nformula env x -> False) f. +Proof. + unfold cnf_of_list. + intros. + set (F := (fun (x : NFormula Z) (acc : list (list (NFormula Z * T))) => + if Zunsat x then acc else ((x, tg) :: nil) :: acc)). + set (E := ((fun x : NFormula Z => eval_nformula env x -> False))). + induction f. + - compute. + tauto. + - rewrite make_conj_cons. + simpl. + unfold F at 1. + destruct (Zunsat a) eqn:EQ. + + rewrite IHf. + unfold E at 1. + specialize (Zunsat_sound _ EQ env). + tauto. + + + rewrite <- eval_cnf_cons_iff with (1:= fun env (term:Formula Z) => True) . + rewrite IHf. + simpl. + unfold E at 2. + unfold eval_tt. simpl. + tauto. +Qed. +Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := + let f := xnnormalise t in + if Zunsat f then cnf_ff _ _ + else cnf_of_list tg (xnormalise f). Lemma normalise_correct : forall (T: Type) env t (tg:T), eval_cnf eval_nformula env (normalise t tg) <-> Zeval_formula env t. Proof. - unfold normalise, xnormalise; cbn -[padd]; intros T env t tg. - rewrite Zeval_formula_compat. - unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o; cbn -[padd]; - repeat rewrite eval_pol_sub; - repeat rewrite eval_pol_add; - repeat rewrite <- eval_pol_norm ; simpl in *; - unfold eval_expr; - generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env lhs); - generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst; - intuition (auto with zarith). + intros. + rewrite <- xnnormalise_correct. + unfold normalise. + generalize (xnnormalise t) as f;intro. + destruct (Zunsat f) eqn:U. + - assert (US := Zunsat_sound _ U env). + rewrite eval_cnf_ff with (1:= eval_nformula). + tauto. + - rewrite cnf_of_list_correct. + apply xnormalise_correct. Qed. -Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := - let (lhs,o,rhs) := t in - let lhs := normZ lhs in - let rhs := normZ rhs in +Definition xnegate (f:NFormula Z) : list (NFormula Z) := + let (e,o) := f in match o with - | OpEq => (psub lhs rhs,Equal) :: nil - | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil - | OpGt => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil - | OpLt => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil - | OpGe => (psub lhs rhs,NonStrict) :: nil - | OpLe => (psub rhs lhs,NonStrict) :: nil + | Equal => (e,Equal) :: nil + | NonEqual => (psub e (Pc 1),NonStrict) :: (psub (Pc (-1)) e, NonStrict) :: nil + | NonStrict => (e,NonStrict)::nil + | Strict => (psub e (Pc 1),NonStrict)::nil end. Definition negate {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := - List.map (fun x => (x,tg)::nil) (xnegate t). + let f := xnnormalise t in + if Zunsat f then cnf_tt _ _ + else cnf_of_list tg (xnegate f). -Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t. -Proof. +Lemma xnegate_correct : forall env f, + (make_conj (fun x => eval_nformula env x -> False) (xnegate f)) <-> ~ eval_nformula env f. Proof. - Opaque padd. - intros T env t tg. - rewrite Zeval_formula_compat. - unfold negate, xnegate ; simpl. - unfold eval_cnf,eval_clause. - destruct t as [lhs o rhs]; case_eq o; unfold eval_tt ; simpl; - repeat rewrite eval_pol_sub; - repeat rewrite eval_pol_add; - repeat rewrite <- eval_pol_norm ; simpl in *; - unfold eval_expr; - generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env lhs); - generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst; - intuition (auto with zarith). - Transparent padd. + intros. + destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; + repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; + generalize (eval_pol env e) as x; intro. + - tauto. + - rewrite eq_cnf. + destruct (Z.eq_decidable x 0);tauto. + - rewrite lt_le_iff. + tauto. + - tauto. Qed. -Definition Zunsat := check_inconsistent 0 Zeq_bool Z.leb. - -Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool. +Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t. +Proof. + intros. + rewrite <- xnnormalise_correct. + unfold negate. + generalize (xnnormalise t) as f;intro. + destruct (Zunsat f) eqn:U. + - assert (US := Zunsat_sound _ U env). + rewrite eval_cnf_tt with (1:= eval_nformula). + tauto. + - rewrite cnf_of_list_correct. + apply xnegate_correct. +Qed. Definition cnfZ (Annot TX AF : Type) (f : TFormula (Formula Z) Annot TX AF) := rxcnf Zunsat Zdeduce normalise negate true f. @@ -1221,7 +1412,8 @@ Proof. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Zsor ZSORaddon) ; auto. - - unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon). + - unfold Zdeduce. intros. revert H. + apply (nformula_plus_nformula_correct Zsor ZSORaddon); auto. - intros env t tg. rewrite normalise_correct ; auto. @@ -1513,10 +1705,8 @@ Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. - Open Scope Z_scope. - (** To ease bindings from ml code **) Definition make_impl := Refl.make_impl. Definition make_conj := Refl.make_conj. diff --git a/plugins/micromega/Zify.v b/plugins/micromega/Zify.v new file mode 100644 index 0000000000..57d812b0fd --- /dev/null +++ b/plugins/micromega/Zify.v @@ -0,0 +1,90 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import ZifyClasses. +Require Export ZifyInst. +Require Import InitialRing. + +(** From PreOmega *) + +(** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *) + +Ltac zify_unop_core t thm a := + (* Let's introduce the specification theorem for t *) + pose proof (thm a); + (* Then we replace (t a) everywhere with a fresh variable *) + let z := fresh "z" in set (z:=t a) in *; clearbody z. + +Ltac zify_unop_var_or_term t thm a := + (* If a is a variable, no need for aliasing *) + let za := fresh "z" in + (rename a into za; rename za into a; zify_unop_core t thm a) || + (* Otherwise, a is a complex term: we alias it. *) + (remember a as za; zify_unop_core t thm za). + +Ltac zify_unop t thm a := + (* If a is a scalar, we can simply reduce the unop. *) + (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *) + let isz := isZcst a in + match isz with + | true => + let u := eval compute in (t a) in + change (t a) with u in * + | _ => zify_unop_var_or_term t thm a + end. + +Ltac zify_unop_nored t thm a := + (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) + let isz := isZcst a in + match isz with + | true => zify_unop_core t thm a + | _ => zify_unop_var_or_term t thm a + end. + +Ltac zify_binop t thm a b:= + (* works as zify_unop, except that we should be careful when + dealing with b, since it can be equal to a *) + let isza := isZcst a in + match isza with + | true => zify_unop (t a) (thm a) b + | _ => + let za := fresh "z" in + (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || + (remember a as za; match goal with + | H : za = b |- _ => zify_unop_nored (t za) (thm za) za + | _ => zify_unop_nored (t za) (thm za) b + end) + end. + +(* end from PreOmega *) + +Ltac applySpec S := + let t := type of S in + match t with + | @BinOpSpec _ _ ?Op _ => + let Spec := (eval unfold S, BSpec in (@BSpec _ _ Op _ S)) in + repeat + match goal with + | H : context[Op ?X ?Y] |- _ => zify_binop Op Spec X Y + | |- context[Op ?X ?Y] => zify_binop Op Spec X Y + end + | @UnOpSpec _ _ ?Op _ => + let Spec := (eval unfold S, USpec in (@USpec _ _ Op _ S)) in + repeat + match goal with + | H : context[Op ?X] |- _ => zify_unop Op Spec X + | |- context[Op ?X ] => zify_unop Op Spec X + end + end. + +(** [zify_post_hook] is there to be redefined. *) +Ltac zify_post_hook := idtac. + +Ltac zify := zify_tac ; (iter_specs applySpec) ; zify_post_hook. diff --git a/plugins/micromega/ZifyBool.v b/plugins/micromega/ZifyBool.v new file mode 100644 index 0000000000..ec37c2003f --- /dev/null +++ b/plugins/micromega/ZifyBool.v @@ -0,0 +1,255 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +Require Import Bool ZArith. +Require Import ZifyClasses. +Open Scope Z_scope. +(* Instances of [ZifyClasses] for dealing with boolean operators. + Various encodings of boolean are possible. One objective is to + have an encoding that is terse but also lia friendly. + *) + +(** [Z_of_bool] is the injection function for boolean *) +Definition Z_of_bool (b : bool) : Z := if b then 1 else 0. + +(** [bool_of_Z] is a compatible reverse operation *) +Definition bool_of_Z (z : Z) : bool := negb (Z.eqb z 0). + +Lemma Z_of_bool_bound : forall x, 0 <= Z_of_bool x <= 1. +Proof. + destruct x ; simpl; compute; intuition congruence. +Qed. + +Instance Inj_bool_Z : InjTyp bool Z := + { inj := Z_of_bool ; pred :=(fun x => 0 <= x <= 1) ; cstr := Z_of_bool_bound}. +Add InjTyp Inj_bool_Z. + +(** Boolean operators *) + +Instance Op_andb : BinOp andb := + { TBOp := Z.min ; + TBOpInj := ltac: (destruct n,m; reflexivity)}. +Add BinOp Op_andb. + +Instance Op_orb : BinOp orb := + { TBOp := Z.max ; + TBOpInj := ltac:(destruct n,m; reflexivity)}. +Add BinOp Op_orb. + +Instance Op_negb : UnOp negb := + { TUOp := fun x => 1 - x ; TUOpInj := ltac:(destruct x; reflexivity)}. +Add UnOp Op_negb. + +Instance Op_eq_bool : BinRel (@eq bool) := + {TR := @eq Z ; TRInj := ltac:(destruct n,m; simpl ; intuition congruence) }. +Add BinRel Op_eq_bool. + +Instance Op_true : CstOp true := + { TCst := 1 ; TCstInj := eq_refl }. + +Instance Op_false : CstOp false := + { TCst := 0 ; TCstInj := eq_refl }. + + +(** Comparisons are encoded using the predicates [isZero] and [isLeZero].*) + +Definition isZero (z : Z) := Z_of_bool (Z.eqb z 0). + +Definition isLeZero (x : Z) := Z_of_bool (Z.leb x 0). + +(* Some intermediate lemma *) + +Lemma Z_eqb_isZero : forall n m, + Z_of_bool (n =? m) = isZero (n - m). +Proof. + intros ; unfold isZero. + destruct ( n =? m) eqn:EQ. + - simpl. rewrite Z.eqb_eq in EQ. + rewrite EQ. rewrite Z.sub_diag. + reflexivity. + - + destruct (n - m =? 0) eqn:EQ'. + rewrite Z.eqb_neq in EQ. + rewrite Z.eqb_eq in EQ'. + apply Zminus_eq in EQ'. + congruence. + reflexivity. +Qed. + +Lemma Z_leb_sub : forall x y, x <=? y = ((x - y) <=? 0). +Proof. + intros. + destruct (x <=?y) eqn:B1 ; + destruct (x - y <=?0) eqn:B2 ; auto. + - rewrite Z.leb_le in B1. + rewrite Z.leb_nle in B2. + rewrite Z.le_sub_0 in B2. tauto. + - rewrite Z.leb_nle in B1. + rewrite Z.leb_le in B2. + rewrite Z.le_sub_0 in B2. tauto. +Qed. + +Lemma Z_ltb_leb : forall x y, x <? y = (x +1 <=? y). +Proof. + intros. + destruct (x <?y) eqn:B1 ; + destruct (x + 1 <=?y) eqn:B2 ; auto. + - rewrite Z.ltb_lt in B1. + rewrite Z.leb_nle in B2. + apply Zorder.Zlt_le_succ in B1. + unfold Z.succ in B1. + tauto. + - rewrite Z.ltb_nlt in B1. + rewrite Z.leb_le in B2. + apply Zorder.Zle_lt_succ in B2. + unfold Z.succ in B2. + apply Zorder.Zplus_lt_reg_r in B2. + tauto. +Qed. + + +(** Comparison over Z *) + +Instance Op_Zeqb : BinOp Z.eqb := + { TBOp := fun x y => isZero (Z.sub x y) ; TBOpInj := Z_eqb_isZero}. + +Instance Op_Zleb : BinOp Z.leb := + { TBOp := fun x y => isLeZero (x-y) ; + TBOpInj := + ltac: (intros;unfold isLeZero; + rewrite Z_leb_sub; + auto) }. +Add BinOp Op_Zleb. + +Instance Op_Zgeb : BinOp Z.geb := + { TBOp := fun x y => isLeZero (y-x) ; + TBOpInj := ltac:( + intros; + unfold isLeZero; + rewrite Z.geb_leb; + rewrite Z_leb_sub; + auto) }. +Add BinOp Op_Zgeb. + +Instance Op_Zltb : BinOp Z.ltb := + { TBOp := fun x y => isLeZero (x+1-y) ; + TBOpInj := ltac:( + intros; + unfold isLeZero; + rewrite Z_ltb_leb; + rewrite <- Z_leb_sub; + reflexivity) }. + +Instance Op_Zgtb : BinOp Z.gtb := + { TBOp := fun x y => isLeZero (y-x+1) ; + TBOpInj := ltac:( + intros; + unfold isLeZero; + rewrite Z.gtb_ltb; + rewrite Z_ltb_leb; + rewrite Z_leb_sub; + rewrite Z.add_sub_swap; + reflexivity) }. +Add BinOp Op_Zgtb. + +(** Comparison over nat *) + + +Lemma Z_of_nat_eqb_iff : forall n m, + (n =? m)%nat = (Z.of_nat n =? Z.of_nat m). +Proof. + intros. + rewrite Nat.eqb_compare. + rewrite Z.eqb_compare. + rewrite Nat2Z.inj_compare. + reflexivity. +Qed. + +Lemma Z_of_nat_leb_iff : forall n m, + (n <=? m)%nat = (Z.of_nat n <=? Z.of_nat m). +Proof. + intros. + rewrite Nat.leb_compare. + rewrite Z.leb_compare. + rewrite Nat2Z.inj_compare. + reflexivity. +Qed. + +Lemma Z_of_nat_ltb_iff : forall n m, + (n <? m)%nat = (Z.of_nat n <? Z.of_nat m). +Proof. + intros. + rewrite Nat.ltb_compare. + rewrite Z.ltb_compare. + rewrite Nat2Z.inj_compare. + reflexivity. +Qed. + +Instance Op_nat_eqb : BinOp Nat.eqb := + { TBOp := fun x y => isZero (Z.sub x y) ; + TBOpInj := ltac:( + intros; simpl; + rewrite <- Z_eqb_isZero; + f_equal; apply Z_of_nat_eqb_iff) }. +Add BinOp Op_nat_eqb. + +Instance Op_nat_leb : BinOp Nat.leb := + { TBOp := fun x y => isLeZero (x-y) ; + TBOpInj := ltac:( + intros; + rewrite Z_of_nat_leb_iff; + unfold isLeZero; + rewrite Z_leb_sub; + auto) }. +Add BinOp Op_nat_leb. + +Instance Op_nat_ltb : BinOp Nat.ltb := + { TBOp := fun x y => isLeZero (x+1-y) ; + TBOpInj := ltac:( + intros; + rewrite Z_of_nat_ltb_iff; + unfold isLeZero; + rewrite Z_ltb_leb; + rewrite <- Z_leb_sub; + reflexivity) }. +Add BinOp Op_nat_ltb. + +(** Injected boolean operators *) + +Lemma Z_eqb_ZSpec_ok : forall x, x <> isZero x. +Proof. + intros. + unfold isZero. + destruct (x =? 0) eqn:EQ. + - apply Z.eqb_eq in EQ. + simpl. congruence. + - apply Z.eqb_neq in EQ. + simpl. auto. +Qed. + +Instance Z_eqb_ZSpec : UnOpSpec isZero := + {| UPred := fun n r => n <> r ; USpec := Z_eqb_ZSpec_ok |}. +Add Spec Z_eqb_ZSpec. + +Lemma leZeroSpec_ok : forall x, x <= 0 /\ isLeZero x = 1 \/ x > 0 /\ isLeZero x = 0. +Proof. + intros. + unfold isLeZero. + destruct (x <=? 0) eqn:EQ. + - apply Z.leb_le in EQ. + simpl. intuition congruence. + - simpl. + apply Z.leb_nle in EQ. + apply Zorder.Znot_le_gt in EQ. + tauto. +Qed. + +Instance leZeroSpec : UnOpSpec isLeZero := + {| UPred := fun n r => (n<=0 /\ r = 1) \/ (n > 0 /\ r = 0) ; USpec := leZeroSpec_ok|}. +Add Spec leZeroSpec. diff --git a/plugins/micromega/ZifyClasses.v b/plugins/micromega/ZifyClasses.v new file mode 100644 index 0000000000..d3f7f91074 --- /dev/null +++ b/plugins/micromega/ZifyClasses.v @@ -0,0 +1,232 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +Set Primitive Projections. + +(** An alternative to [zify] in ML parametrised by user-provided classes instances. + + The framework has currently several limitations that are in place for simplicity. + For instance, we only consider binary operators of type [Op: S -> S -> S]. + Another limitation is that our injection theorems e.g. [TBOpInj], + are using Leibniz equality; the payoff is that there is no need for morphisms... + *) + +(** An injection [InjTyp S T] declares an injection + from source type S to target type T. +*) +Class InjTyp (S : Type) (T : Type) := + mkinj { + (* [inj] is the injection function *) + inj : S -> T; + pred : T -> Prop; + (* [cstr] states that [pred] holds for any injected element. + [cstr (inj x)] is introduced in the goal for any leaf + term of the form [inj x] + *) + cstr : forall x, pred (inj x) + }. + +(** [BinOp Op] declares a source operator [Op: S1 -> S2 -> S3]. + *) +Class BinOp {S1 S2 S3:Type} {T:Type} (Op : S1 -> S2 -> S3) {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} {I3 : InjTyp S3 T} := + mkbop { + (* [TBOp] is the target operator after injection of operands. *) + TBOp : T -> T -> T; + (* [TBOpInj] states the correctness of the injection. *) + TBOpInj : forall (n:S1) (m:S2), inj (Op n m) = TBOp (inj n) (inj m) + }. + +(** [Unop Op] declares a source operator [Op : S1 -> S2]. *) +Class UnOp {S1 S2 T:Type} (Op : S1 -> S2) {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} := + mkuop { + (* [TUOp] is the target operator after injection of operands. *) + TUOp : T -> T; + (* [TUOpInj] states the correctness of the injection. *) + TUOpInj : forall (x:S1), inj (Op x) = TUOp (inj x) + }. + +(** [CstOp Op] declares a source constant [Op : S]. *) +Class CstOp {S T:Type} (Op : S) {I : InjTyp S T} := + mkcst { + (* [TCst] is the target constant. *) + TCst : T; + (* [TCstInj] states the correctness of the injection. *) + TCstInj : inj Op = TCst + }. + +(** In the framework, [Prop] is mapped to [Prop] and the injection is phrased in + terms of [=] instead of [<->]. +*) + +(** [BinRel R] declares the injection of a binary relation. *) +Class BinRel {S:Type} {T:Type} (R : S -> S -> Prop) {I : InjTyp S T} := + mkbrel { + TR : T -> T -> Prop; + TRInj : forall n m : S, R n m <-> TR (@inj _ _ I n) (inj m) + }. + +(** [PropOp Op] declares morphisms for [<->]. + This will be used to deal with e.g. [and], [or],... *) +Class PropOp (Op : Prop -> Prop -> Prop) := + mkprop { + op_iff : forall (p1 p2 q1 q2:Prop), (p1 <-> q1) -> (p2 <-> q2) -> (Op p1 p2 <-> Op q1 q2) + }. + +Class PropUOp (Op : Prop -> Prop) := + mkuprop { + uop_iff : forall (p1 q1 :Prop), (p1 <-> q1) -> (Op p1 <-> Op q1) + }. + + + +(** Once the term is injected, terms can be replaced by their specification. + NB1: The Ltac code is currently limited to (Op: Z -> Z -> Z) + NB2: This is not sufficient to cope with [Z.div] or [Z.mod] + *) +Class BinOpSpec {S T: Type} (Op : T -> T -> T) {I : InjTyp S T} := + mkbspec { + BPred : T -> T -> T -> Prop; + BSpec : forall x y, BPred x y (Op x y) + }. + +Class UnOpSpec {S T: Type} (Op : T -> T) {I : InjTyp S T} := + mkuspec { + UPred : T -> T -> Prop; + USpec : forall x, UPred x (Op x) + }. + +(** After injections, e.g. nat -> Z, + the fact that Z.of_nat x * Z.of_nat y is positive is lost. + This information can be recovered using instance of the [Saturate] class. +*) +Class Saturate {T: Type} (Op : T -> T -> T) := + mksat { + (** Given [Op x y], + - [PArg1] is the pre-condition of x + - [PArg2] is the pre-condition of y + - [PRes] is the pos-condition of (Op x y) *) + PArg1 : T -> Prop; + PArg2 : T -> Prop; + PRes : T -> Prop; + (** [SatOk] states the correctness of the reasoning *) + SatOk : forall x y, PArg1 x -> PArg2 y -> PRes (Op x y) + }. +(* The [ZifyInst.saturate] iterates over all the instances + and for every pattern of the form + [H1 : PArg1 ?x , H2 : PArg2 ?y , T : context[Op ?x ?y] |- _ ] + [H1 : PArg1 ?x , H2 : PArg2 ?y |- context[Op ?x ?y] ] + asserts (SatOK x y H1 H2) *) + +(** The rest of the file is for internal use by the ML tactic. + There are data-structures and lemmas used to inductively construct + the injected terms. *) + +(** The data-structures [injterm] and [injected_prop] + are used to store source and target expressions together + with a correctness proof. *) + +Record injterm {S T: Type} {I : S -> T} := + mkinjterm { source : S ; target : T ; inj_ok : I source = target}. + +Record injprop := + mkinjprop { + source_prop : Prop ; target_prop : Prop ; + injprop_ok : source_prop <-> target_prop}. + +(** Lemmas for building [injterm] and [injprop]. *) + +Definition mkprop_op (Op : Prop -> Prop -> Prop) (POp : PropOp Op) + (p1 :injprop) (p2: injprop) : injprop := + {| source_prop := (Op (source_prop p1) (source_prop p2)) ; + target_prop := (Op (target_prop p1) (target_prop p2)) ; + injprop_ok := (op_iff (source_prop p1) (source_prop p2) (target_prop p1) (target_prop p2) + (injprop_ok p1) (injprop_ok p2)) + |}. + + +Definition mkuprop_op (Op : Prop -> Prop) (POp : PropUOp Op) + (p1 :injprop) : injprop := + {| source_prop := (Op (source_prop p1)) ; + target_prop := (Op (target_prop p1)) ; + injprop_ok := (uop_iff (source_prop p1) (target_prop p1) (injprop_ok p1)) + |}. + + +Lemma mkapp2 (S1 S2 S3 T : Type) (Op : S1 -> S2 -> S3) + {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} {I3 : InjTyp S3 T} + (B : @BinOp S1 S2 S3 T Op I1 I2 I3) + (t1 : @injterm S1 T inj) (t2 : @injterm S2 T inj) + : @injterm S3 T inj. +Proof. + apply (mkinjterm _ _ inj (Op (source t1) (source t2)) (TBOp (target t1) (target t2))). + (rewrite <- inj_ok; + rewrite <- inj_ok; + apply TBOpInj). +Defined. + +Lemma mkapp (S1 S2 T : Type) (Op : S1 -> S2) + {I1 : InjTyp S1 T} + {I2 : InjTyp S2 T} + (B : @UnOp S1 S2 T Op I1 I2 ) + (t1 : @injterm S1 T inj) + : @injterm S2 T inj. +Proof. + apply (mkinjterm _ _ inj (Op (source t1)) (TUOp (target t1))). + (rewrite <- inj_ok; apply TUOpInj). +Defined. + +Lemma mkapp0 (S T : Type) (Op : S) + {I : InjTyp S T} + (B : @CstOp S T Op I) + : @injterm S T inj. +Proof. + apply (mkinjterm _ _ inj Op TCst). + (apply TCstInj). +Defined. + +Lemma mkrel (S T : Type) (R : S -> S -> Prop) + {Inj : InjTyp S T} + (B : @BinRel S T R Inj) + (t1 : @injterm S T inj) (t2 : @injterm S T inj) + : @injprop. +Proof. + apply (mkinjprop (R (source t1) (source t2)) (TR (target t1) (target t2))). + (rewrite <- inj_ok; rewrite <- inj_ok;apply TRInj). +Defined. + +(** Registering constants for use by the plugin *) +Register target_prop as ZifyClasses.target_prop. +Register mkrel as ZifyClasses.mkrel. +Register target as ZifyClasses.target. +Register mkapp2 as ZifyClasses.mkapp2. +Register mkapp as ZifyClasses.mkapp. +Register mkapp0 as ZifyClasses.mkapp0. +Register op_iff as ZifyClasses.op_iff. +Register uop_iff as ZifyClasses.uop_iff. +Register TR as ZifyClasses.TR. +Register TBOp as ZifyClasses.TBOp. +Register TUOp as ZifyClasses.TUOp. +Register TCst as ZifyClasses.TCst. +Register mkprop_op as ZifyClasses.mkprop_op. +Register mkuprop_op as ZifyClasses.mkuprop_op. +Register injprop_ok as ZifyClasses.injprop_ok. +Register inj_ok as ZifyClasses.inj_ok. +Register source as ZifyClasses.source. +Register source_prop as ZifyClasses.source_prop. +Register inj as ZifyClasses.inj. +Register TRInj as ZifyClasses.TRInj. +Register TUOpInj as ZifyClasses.TUOpInj. +Register not as ZifyClasses.not. +Register mkinjterm as ZifyClasses.mkinjterm. +Register eq_refl as ZifyClasses.eq_refl. +Register mkinjprop as ZifyClasses.mkinjprop. +Register iff_refl as ZifyClasses.iff_refl. +Register source_prop as ZifyClasses.source_prop. +Register injprop_ok as ZifyClasses.injprop_ok. +Register iff as ZifyClasses.iff. diff --git a/plugins/micromega/ZifyInst.v b/plugins/micromega/ZifyInst.v new file mode 100644 index 0000000000..1217e8a5f7 --- /dev/null +++ b/plugins/micromega/ZifyInst.v @@ -0,0 +1,449 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Instances of [ZifyClasses] for emulating the existing zify. + Each instance is registered using a Add 'class' 'name_of_instance'. + *) + +Require Import Arith Max Min BinInt BinNat Znat Nnat. +Require Import ZifyClasses. +Declare ML Module "zify_plugin". +Open Scope Z_scope. + +(** Propositional logic *) +Instance PropAnd : PropOp and. +Proof. + constructor. + tauto. +Defined. +Add PropOp PropAnd. + +Instance PropOr : PropOp or. +Proof. + constructor. + tauto. +Defined. +Add PropOp PropOr. + +Instance PropArrow : PropOp (fun x y => x -> y). +Proof. + constructor. + intros. + tauto. +Defined. +Add PropOp PropArrow. + +Instance PropIff : PropOp iff. +Proof. + constructor. + intros. + tauto. +Defined. +Add PropOp PropIff. + +Instance PropNot : PropUOp not. +Proof. + constructor. + intros. + tauto. +Defined. +Add PropUOp PropNot. + + +Instance Inj_Z_Z : InjTyp Z Z := + mkinj _ _ (fun x => x) (fun x => True ) (fun _ => I). +Add InjTyp Inj_Z_Z. + +(** Support for nat *) + +Instance Inj_nat_Z : InjTyp nat Z := + mkinj _ _ Z.of_nat (fun x => 0 <= x ) Nat2Z.is_nonneg. +Add InjTyp Inj_nat_Z. + +(* zify_nat_rel *) +Instance Op_ge : BinRel ge := + {| TR := Z.ge; TRInj := Nat2Z.inj_ge |}. +Add BinRel Op_ge. + +Instance Op_lt : BinRel lt := + {| TR := Z.lt; TRInj := Nat2Z.inj_lt |}. +Add BinRel Op_lt. + +Instance Op_gt : BinRel gt := + {| TR := Z.gt; TRInj := Nat2Z.inj_gt |}. +Add BinRel Op_gt. + +Instance Op_le : BinRel le := + {| TR := Z.le; TRInj := Nat2Z.inj_le |}. +Add BinRel Op_le. + +Instance Op_eq_nat : BinRel (@eq nat) := + {| TR := @eq Z ; TRInj := fun x y : nat => iff_sym (Nat2Z.inj_iff x y) |}. +Add BinRel Op_eq_nat. + +(* zify_nat_op *) +Instance Op_plus : BinOp Nat.add := + {| TBOp := Z.add; TBOpInj := Nat2Z.inj_add |}. +Add BinOp Op_plus. + +Instance Op_sub : BinOp Nat.sub := + {| TBOp := fun n m => Z.max 0 (n - m) ; TBOpInj := Nat2Z.inj_sub_max |}. +Add BinOp Op_sub. + +Instance Op_mul : BinOp Nat.mul := + {| TBOp := Z.mul ; TBOpInj := Nat2Z.inj_mul |}. +Add BinOp Op_mul. + +Instance Op_min : BinOp Nat.min := + {| TBOp := Z.min ; TBOpInj := Nat2Z.inj_min |}. +Add BinOp Op_min. + +Instance Op_max : BinOp Nat.max := + {| TBOp := Z.max ; TBOpInj := Nat2Z.inj_max |}. +Add BinOp Op_max. + +Instance Op_pred : UnOp Nat.pred := + {| TUOp := fun n => Z.max 0 (n - 1) ; TUOpInj := Nat2Z.inj_pred_max |}. +Add UnOp Op_pred. + +Instance Op_S : UnOp S := + {| TUOp := fun x => Z.add x 1 ; TUOpInj := Nat2Z.inj_succ |}. +Add UnOp Op_S. + +Instance Op_O : CstOp O := + {| TCst := Z0 ; TCstInj := eq_refl (Z.of_nat 0) |}. + +Instance Op_Z_abs_nat : UnOp Z.abs_nat := + { TUOp := Z.abs ; TUOpInj := Zabs2Nat.id_abs }. +Add UnOp Op_Z_abs_nat. + +(** Support for positive *) + +Instance Inj_pos_Z : InjTyp positive Z := + {| inj := Zpos ; pred := (fun x => 0 < x ) ; cstr := Pos2Z.pos_is_pos |}. +Add InjTyp Inj_pos_Z. + +Instance Op_pos_to_nat : UnOp Pos.to_nat := + {TUOp := (fun x => x); TUOpInj := positive_nat_Z}. +Add UnOp Op_pos_to_nat. + +Instance Inj_N_Z : InjTyp N Z := + mkinj _ _ Z.of_N (fun x => 0 <= x ) N2Z.is_nonneg. +Add InjTyp Inj_N_Z. + + +Instance Op_N_to_nat : UnOp N.to_nat := + { TUOp := fun x => x ; TUOpInj := N_nat_Z }. +Add UnOp Op_N_to_nat. + +(* zify_positive_rel *) + +Instance Op_pos_ge : BinRel Pos.ge := + {| TR := Z.ge; TRInj := fun x y => iff_refl (Z.pos x >= Z.pos y) |}. +Add BinRel Op_pos_ge. + +Instance Op_pos_lt : BinRel Pos.lt := + {| TR := Z.lt; TRInj := fun x y => iff_refl (Z.pos x < Z.pos y) |}. +Add BinRel Op_pos_lt. + +Instance Op_pos_gt : BinRel Pos.gt := + {| TR := Z.gt; TRInj := fun x y => iff_refl (Z.pos x > Z.pos y) |}. +Add BinRel Op_pos_gt. + +Instance Op_pos_le : BinRel Pos.le := + {| TR := Z.le; TRInj := fun x y => iff_refl (Z.pos x <= Z.pos y) |}. +Add BinRel Op_pos_le. + +Instance Op_eq_pos : BinRel (@eq positive) := + {| TR := @eq Z ; TRInj := fun x y => iff_sym (Pos2Z.inj_iff x y) |}. +Add BinRel Op_eq_pos. + +(* zify_positive_op *) + + +Program Instance Op_Z_of_N : UnOp Z.of_N := + { TUOp := (fun x => x) ; TUOpInj := fun x => eq_refl (Z.of_N x) }. +Add UnOp Op_Z_of_N. + +Instance Op_Z_to_N : UnOp Z.to_N := + { TUOp := fun x => Z.max 0 x ; TUOpInj := ltac:(now intro x; destruct x) }. +Add UnOp Op_Z_to_N. + +Instance Op_Z_neg : UnOp Z.neg := + { TUOp := Z.opp ; TUOpInj := (fun x => eq_refl (Zneg x))}. +Add UnOp Op_Z_neg. + +Instance Op_Z_pos : UnOp Z.pos := + { TUOp := (fun x => x) ; TUOpInj := (fun x => eq_refl (Z.pos x))}. +Add UnOp Op_Z_pos. + +Instance Op_pos_succ : UnOp Pos.succ := + { TUOp := fun x => x + 1; TUOpInj := Pos2Z.inj_succ }. +Add UnOp Op_pos_succ. + +Instance Op_pos_pred : UnOp Pos.pred := + { TUOp := fun x => Z.max 1 (x - 1) ; + TUOpInj := ltac : + (intros; + rewrite <- Pos.sub_1_r; + apply Pos2Z.inj_sub_max) }. +Add UnOp Op_pos_pred. + +Instance Op_pos_of_succ_nat : UnOp Pos.of_succ_nat := + { TUOp := fun x => x + 1 ; TUOpInj := Zpos_P_of_succ_nat }. +Add UnOp Op_pos_of_succ_nat. + +Program Instance Op_pos_add : BinOp Pos.add := + { TBOp := Z.add ; TBOpInj := ltac: (reflexivity) }. +Add BinOp Op_pos_add. + +Instance Op_pos_sub : BinOp Pos.sub := + { TBOp := fun n m => Z.max 1 (n - m) ;TBOpInj := Pos2Z.inj_sub_max }. +Add BinOp Op_pos_sub. + +Instance Op_pos_mul : BinOp Pos.mul := + { TBOp := Z.mul ; TBOpInj := ltac: (reflexivity) }. +Add BinOp Op_pos_mul. + +Instance Op_pos_min : BinOp Pos.min := + { TBOp := Z.min ; TBOpInj := Pos2Z.inj_min }. +Add BinOp Op_pos_min. + +Instance Op_pos_max : BinOp Pos.max := + { TBOp := Z.max ; TBOpInj := Pos2Z.inj_max }. +Add BinOp Op_pos_max. + +Instance Op_xO : UnOp xO := + { TUOp := fun x => 2 * x ; TUOpInj := ltac: (reflexivity) }. +Add UnOp Op_xO. + +Instance Op_xI : UnOp xI := + { TUOp := fun x => 2 * x + 1 ; TUOpInj := ltac: (reflexivity) }. +Add UnOp Op_xI. + +Instance Op_xH : CstOp xH := + { TCst := 1%Z ; TCstInj := ltac:(reflexivity)}. +Add CstOp Op_xH. + +Instance Op_Z_of_nat : UnOp Z.of_nat:= + { TUOp := fun x => x ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_of_nat. + +(* zify_N_rel *) +Instance Op_N_ge : BinRel N.ge := + {| TR := Z.ge ; TRInj := N2Z.inj_ge |}. +Add BinRel Op_N_ge. + +Instance Op_N_lt : BinRel N.lt := + {| TR := Z.lt ; TRInj := N2Z.inj_lt |}. +Add BinRel Op_N_lt. + +Instance Op_N_gt : BinRel N.gt := + {| TR := Z.gt ; TRInj := N2Z.inj_gt |}. +Add BinRel Op_N_gt. + +Instance Op_N_le : BinRel N.le := + {| TR := Z.le ; TRInj := N2Z.inj_le |}. +Add BinRel Op_N_le. + +Instance Op_eq_N : BinRel (@eq N) := + {| TR := @eq Z ; TRInj := fun x y : N => iff_sym (N2Z.inj_iff x y) |}. +Add BinRel Op_eq_N. + +(* zify_N_op *) +Instance Op_N_of_nat : UnOp N.of_nat := + { TUOp := fun x => x ; TUOpInj := nat_N_Z }. +Add UnOp Op_N_of_nat. + +Instance Op_Z_abs_N : UnOp Z.abs_N := + { TUOp := Z.abs ; TUOpInj := N2Z.inj_abs_N }. +Add UnOp Op_Z_abs_N. + +Instance Op_N_pos : UnOp N.pos := + { TUOp := fun x => x ; TUOpInj := ltac:(reflexivity)}. +Add UnOp Op_N_pos. + +Instance Op_N_add : BinOp N.add := + {| TBOp := Z.add ; TBOpInj := N2Z.inj_add |}. +Add BinOp Op_N_add. + +Instance Op_N_min : BinOp N.min := + {| TBOp := Z.min ; TBOpInj := N2Z.inj_min |}. +Add BinOp Op_N_min. + +Instance Op_N_max : BinOp N.max := + {| TBOp := Z.max ; TBOpInj := N2Z.inj_max |}. +Add BinOp Op_N_max. + +Instance Op_N_mul : BinOp N.mul := + {| TBOp := Z.mul ; TBOpInj := N2Z.inj_mul |}. +Add BinOp Op_N_mul. + +Instance Op_N_sub : BinOp N.sub := + {| TBOp := fun x y => Z.max 0 (x - y) ; TBOpInj := N2Z.inj_sub_max|}. +Add BinOp Op_N_sub. + +Instance Op_N_div : BinOp N.div := + {| TBOp := Z.div ; TBOpInj := N2Z.inj_div|}. +Add BinOp Op_N_div. + + + +Instance Op_N_mod : BinOp N.modulo := + {| TBOp := Z.rem ; TBOpInj := N2Z.inj_rem|}. +Add BinOp Op_N_mod. + +Instance Op_N_pred : UnOp N.pred := + { TUOp := fun x => Z.max 0 (x - 1) ; + TUOpInj := + ltac:(intros; rewrite N.pred_sub; apply N2Z.inj_sub_max) }. +Add UnOp Op_N_pred. + +Instance Op_N_succ : UnOp N.succ := + {| TUOp := fun x => x + 1 ; TUOpInj := N2Z.inj_succ |}. +Add UnOp Op_N_succ. + +(** Support for Z - injected to itself *) + +(* zify_Z_rel *) +Instance Op_Z_ge : BinRel Z.ge := + {| TR := Z.ge ; TRInj := fun x y => iff_refl (x>= y)|}. +Add BinRel Op_Z_ge. + +Instance Op_Z_lt : BinRel Z.lt := + {| TR := Z.lt ; TRInj := fun x y => iff_refl (x < y)|}. +Add BinRel Op_Z_lt. + +Instance Op_Z_gt : BinRel Z.gt := + {| TR := Z.gt ;TRInj := fun x y => iff_refl (x > y)|}. +Add BinRel Op_Z_gt. + +Instance Op_Z_le : BinRel Z.le := + {| TR := Z.le ;TRInj := fun x y => iff_refl (x <= y)|}. +Add BinRel Op_Z_le. + +Instance Op_eqZ : BinRel (@eq Z) := + { TR := @eq Z ; TRInj := fun x y => iff_refl (x = y) }. +Add BinRel Op_eqZ. + +Instance Op_Z_add : BinOp Z.add := + { TBOp := Z.add ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_add. + +Instance Op_Z_min : BinOp Z.min := + { TBOp := Z.min ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_min. + +Instance Op_Z_max : BinOp Z.max := + { TBOp := Z.max ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_max. + +Instance Op_Z_mul : BinOp Z.mul := + { TBOp := Z.mul ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_mul. + +Instance Op_Z_sub : BinOp Z.sub := + { TBOp := Z.sub ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_sub. + +Instance Op_Z_div : BinOp Z.div := + { TBOp := Z.div ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_div. + +Instance Op_Z_mod : BinOp Z.modulo := + { TBOp := Z.modulo ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_mod. + +Instance Op_Z_rem : BinOp Z.rem := + { TBOp := Z.rem ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_rem. + +Instance Op_Z_quot : BinOp Z.quot := + { TBOp := Z.quot ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_quot. + +Instance Op_Z_succ : UnOp Z.succ := + { TUOp := fun x => x + 1 ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_succ. + +Instance Op_Z_pred : UnOp Z.pred := + { TUOp := fun x => x - 1 ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_pred. + +Instance Op_Z_opp : UnOp Z.opp := + { TUOp := Z.opp ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_opp. + +Instance Op_Z_abs : UnOp Z.abs := + { TUOp := Z.abs ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_abs. + +Instance Op_Z_sgn : UnOp Z.sgn := + { TUOp := Z.sgn ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_sgn. + +Instance Op_Z_pow_pos : BinOp Z.pow_pos := + { TBOp := Z.pow ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_pow_pos. + +Lemma of_nat_to_nat_eq : forall x, Z.of_nat (Z.to_nat x) = Z.max 0 x. +Proof. + destruct x. + - reflexivity. + - rewrite Z2Nat.id. + reflexivity. + compute. congruence. + - reflexivity. +Qed. + +Instance Op_Z_to_nat : UnOp Z.to_nat := + { TUOp := fun x => Z.max 0 x ; TUOpInj := of_nat_to_nat_eq }. +Add UnOp Op_Z_to_nat. + +(** Specification of derived operators over Z *) + +Instance ZmaxSpec : BinOpSpec Z.max := + {| BPred := fun n m r => n < m /\ r = m \/ m <= n /\ r = n ; BSpec := Z.max_spec|}. +Add Spec ZmaxSpec. + +Instance ZminSpec : BinOpSpec Z.min := + {| BPred := fun n m r : Z => n < m /\ r = n \/ m <= n /\ r = m ; + BSpec := Z.min_spec|}. +Add Spec ZminSpec. + +Instance ZsgnSpec : UnOpSpec Z.sgn := + {| UPred := fun n r : Z => 0 < n /\ r = 1 \/ 0 = n /\ r = 0 \/ n < 0 /\ r = - (1) ; + USpec := Z.sgn_spec|}. +Add Spec ZsgnSpec. + +Instance ZabsSpec : UnOpSpec Z.abs := + {| UPred := fun n r: Z => 0 <= n /\ r = n \/ n < 0 /\ r = - n ; + USpec := Z.abs_spec|}. +Add Spec ZabsSpec. + +(** Saturate positivity constraints *) + +Instance SatProd : Saturate Z.mul := + {| + PArg1 := fun x => 0 <= x; + PArg2 := fun y => 0 <= y; + PRes := fun r => 0 <= r; + SatOk := Z.mul_nonneg_nonneg + |}. +Add Saturate SatProd. + +Instance SatProdPos : Saturate Z.mul := + {| + PArg1 := fun x => 0 < x; + PArg2 := fun y => 0 < y; + PRes := fun r => 0 < r; + SatOk := Z.mul_pos_pos + |}. +Add Saturate SatProdPos. diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 5cc2c2e061..1772a3c333 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -27,7 +27,7 @@ open Context open Tactypes (** - * Debug flag + * Debug flag *) let debug = false @@ -39,7 +39,7 @@ let max_depth = max_int (* Search limit for provers over Q R *) let lra_proof_depth = ref max_depth - + (* Search limit for provers over Z *) let lia_enum = ref true let lia_proof_depth = ref max_depth @@ -50,10 +50,15 @@ let get_lia_option () = let get_lra_option () = !lra_proof_depth +(* Enable/disable caches *) + +let use_lia_cache = ref true +let use_nia_cache = ref true +let use_nra_cache = ref true +let use_csdp_cache = ref true - let () = - + let int_opt l vref = { optdepr = false; @@ -63,7 +68,7 @@ let () = optwrite = (fun x -> vref := (match x with None -> max_depth | Some v -> v)) } in - let lia_enum_opt = + let lia_enum_opt = { optdepr = false; optname = "Lia Enum"; @@ -90,14 +95,45 @@ let () = optwrite = (fun x -> Certificate.dump_file := x) } in + let lia_cache_opt = + { + optdepr = false; + optname = "cache of lia (.lia.cache)"; + optkey = ["Lia" ; "Cache"]; + optread = (fun () -> !use_lia_cache); + optwrite = (fun x -> use_lia_cache := x) + } in + + let nia_cache_opt = + { + optdepr = false; + optname = "cache of nia (.nia.cache)"; + optkey = ["Nia" ; "Cache"]; + optread = (fun () -> !use_nia_cache); + optwrite = (fun x -> use_nia_cache := x) + } in + + let nra_cache_opt = + { + optdepr = false; + optname = "cache of nra (.nra.cache)"; + optkey = ["Nra" ; "Cache"]; + optread = (fun () -> !use_nra_cache); + optwrite = (fun x -> use_nra_cache := x) + } in + + let () = declare_bool_option solver_opt in + let () = declare_bool_option lia_cache_opt in + let () = declare_bool_option nia_cache_opt in + let () = declare_bool_option nra_cache_opt in let () = declare_stringopt_option dump_file_opt in let () = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in let () = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in let () = declare_bool_option lia_enum_opt in () - + (** * Initialize a tag type to the Tag module declaration (see Mutils). *) @@ -167,8 +203,8 @@ struct let logic_dir = ["Coq";"Logic";"Decidable"] - let mic_modules = - [ + let mic_modules = + [ ["Coq";"Lists";"List"]; ["Coq"; "micromega";"ZMicromega"]; ["Coq"; "micromega";"Tauto"]; @@ -419,7 +455,7 @@ struct | _ -> raise ParseError (* Access the Micromega module *) - + (* parse/dump/print from numbers up to expressions and formulas *) let rec parse_nat sigma term = @@ -437,15 +473,15 @@ struct | Mc.S p -> EConstr.mkApp(Lazy.force coq_S,[| dump_nat p |]) let rec parse_positive sigma term = - let (i,c) = get_left_construct sigma term in + let (i,c) = get_left_construct sigma term in match i with - | 1 -> Mc.XI (parse_positive sigma c.(0)) - | 2 -> Mc.XO (parse_positive sigma c.(0)) - | 3 -> Mc.XH - | i -> raise ParseError + | 1 -> Mc.XI (parse_positive sigma c.(0)) + | 2 -> Mc.XO (parse_positive sigma c.(0)) + | 3 -> Mc.XH + | i -> raise ParseError let rec dump_positive x = - match x with + match x with | Mc.XH -> Lazy.force coq_xH | Mc.XO p -> EConstr.mkApp(Lazy.force coq_xO,[| dump_positive p |]) | Mc.XI p -> EConstr.mkApp(Lazy.force coq_xI,[| dump_positive p |]) @@ -453,14 +489,14 @@ struct let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) let dump_n x = - match x with + match x with | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) (** [is_ground_term env sigma term] holds if the term [term] is an instance of the typeclass [DeclConstant.GT term] i.e. built from user-defined constants and functions. - NB: This mechanism is used to customise the reification process to decide + NB: This mechanism can be used to customise the reification process to decide what to consider as a constant (see [parse_constant]) *) @@ -468,10 +504,10 @@ struct match EConstr.kind evd t with | Const _ | Construct _ -> (* Restrict typeclass resolution to trivial cases *) begin - let typ = Retyping.get_type_of env evd t in - try - ignore (Typeclasses.resolve_one_typeclass env evd (EConstr.mkApp(Lazy.force coq_DeclaredConstant,[| typ;t|]))) ; true - with Not_found -> false + let typ = Retyping.get_type_of env evd t in + try + ignore (Typeclasses.resolve_one_typeclass env evd (EConstr.mkApp(Lazy.force coq_DeclaredConstant,[| typ;t|]))) ; true + with Not_found -> false end | _ -> false @@ -485,12 +521,12 @@ struct let parse_z sigma term = - let (i,c) = get_left_construct sigma term in + let (i,c) = get_left_construct sigma term in match i with - | 1 -> Mc.Z0 - | 2 -> Mc.Zpos (parse_positive sigma c.(0)) - | 3 -> Mc.Zneg (parse_positive sigma c.(0)) - | i -> raise ParseError + | 1 -> Mc.Z0 + | 2 -> Mc.Zpos (parse_positive sigma c.(0)) + | 3 -> Mc.Zneg (parse_positive sigma c.(0)) + | i -> raise ParseError let dump_z x = match x with @@ -512,7 +548,7 @@ struct | _ -> raise ParseError - let rec pp_Rcst o cst = + let rec pp_Rcst o cst = match cst with | Mc.C0 -> output_string o "C0" | Mc.C1 -> output_string o "C1" @@ -526,9 +562,9 @@ struct | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t - let rec dump_Rcst cst = + let rec dump_Rcst cst = match cst with - | Mc.C0 -> Lazy.force coq_C0 + | Mc.C0 -> Lazy.force coq_C0 | Mc.C1 -> Lazy.force coq_C1 | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_CQ, [| dump_q q |]) | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_CZ, [| dump_z z |]) @@ -682,7 +718,7 @@ struct type gl = { env : Environ.env; sigma : Evd.evar_map } - let is_convertible gl t1 t2 = + let is_convertible gl t1 t2 = Reductionops.is_conv gl.env gl.sigma t1 t2 let parse_zop gl (op,args) = @@ -746,7 +782,7 @@ struct (** [eq_constr gl x y] returns an updated [gl] if x and y can be unified *) let eq_constr gl x y = let evd = gl.sigma in - match EConstr.eq_constr_universes gl.env evd x y with + match EConstr.eq_constr_universes_proj gl.env evd x y with | Some csts -> let csts = UnivProblem.to_constraints ~force_weak:false (Evd.universes evd) csts in begin @@ -770,15 +806,16 @@ struct ({vars=vars';gl=gl'}, CamlToCoq.positive n) let get_rank env v = - let evd = env.gl.sigma in + let gl = env.gl in let rec _get_rank env n = match env with | [] -> raise (Invalid_argument "get_rank") | e::l -> - if EConstr.eq_constr evd e v - then n - else _get_rank l (n+1) in + match eq_constr gl e v with + | Some _ -> n + | None -> _get_rank l (n+1) + in _get_rank env.vars 1 let elements env = env.vars @@ -810,7 +847,7 @@ struct let parse_variable env term = let (env,n) = Env.compute_rank_add env term in - (Mc.PEX n , env) in + (Mc.PEX n , env) in let rec parse_expr env term = let combine env op (t1,t2) = @@ -826,12 +863,12 @@ struct match EConstr.kind gl.sigma t with | Const c -> ( match assoc_ops gl.sigma t ops_spec with - | Binop f -> combine env f (args.(0),args.(1)) + | Binop f -> combine env f (args.(0),args.(1)) | Opp -> let (expr,env) = parse_expr env args.(0) in (Mc.PEopp expr, env) | Power -> begin - try + try let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in (power , env) @@ -844,9 +881,9 @@ struct then (Printf.printf "unknown op: %s\n" s; flush stdout;); let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) ) - | _ -> parse_variable env term + | _ -> parse_variable env term ) - | _ -> parse_variable env term in + | _ -> parse_variable env term in parse_expr env term let zop_spec = @@ -920,14 +957,18 @@ struct Therefore, there is a specific parser for constant over R *) - let rconst_assoc = - [ + let rconst_assoc = + [ coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ; - coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; - coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; + coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; + coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) ] + + + + let rconstant gl term = let sigma = gl.sigma in @@ -950,12 +991,12 @@ struct f a b with ParseError -> - match op with - | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> + match op with + | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> let arg = rconstant args.(0) in if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} then raise ParseError (* This is a division by zero -- no semantics *) - else Mc.CInv(arg) + else Mc.CInv(arg) | op when EConstr.eq_constr sigma op (Lazy.force coq_Rpower) -> Mc.CPow(rconstant args.(0) , Mc.Inr (parse_more_constant nconstant gl args.(1))) | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> @@ -963,18 +1004,19 @@ struct | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> Mc.CZ (parse_more_constant zconstant gl args.(0)) | _ -> raise ParseError - end + end | _ -> raise ParseError in rconstant term + let rconstant gl term = if debug then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env gl.env gl.sigma term ++ fnl ()); let res = rconstant gl term in - if debug then - (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; + if debug then + (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; res @@ -1034,20 +1076,26 @@ struct (** * This is the big generic function for formula parsers. *) - + + let is_prop env sigma term = + let sort = Retyping.get_sort_of env sigma term in + Sorts.is_prop sort + let parse_formula gl parse_atom env tg term = let sigma = gl.sigma in + let is_prop term = is_prop gl.env gl.sigma term in + let parse_atom env tg t = try let (at,env) = parse_atom env t gl in (Mc.A(at,(tg,t)), env,Tag.next tg) - with e when CErrors.noncritical e -> (Mc.X(t),env,tg) in + with ParseError -> + if is_prop t + then (Mc.X(t),env,tg) + else raise ParseError + in - let is_prop term = - let sort = Retyping.get_sort_of gl.env gl.sigma term in - Sorts.is_prop sort in - let rec xparse_formula env tg term = match EConstr.kind sigma term with | App(l,rst) -> @@ -1106,7 +1154,7 @@ struct doit (doit env f1) f2 | N f -> doit env f in - + doit (Env.empty gl) form) let var_env_of_formula form = @@ -1118,7 +1166,7 @@ struct ISet.union (vars_of_expr e1) (vars_of_expr e2) | Mc.PEopp e | Mc.PEpow(e,_)-> vars_of_expr e in - + let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in Mc.( @@ -1129,10 +1177,10 @@ struct | N f -> doit f in doit form) - - + + type 'cst dump_expr = (* 'cst is the type of the syntactic constants *) { interp_typ : EConstr.constr; @@ -1169,12 +1217,12 @@ let dump_qexpr = lazy dump_mul = Lazy.force coq_Qmult; dump_pow = Lazy.force coq_Qpower; dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table + dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table } -let rec dump_Rcst_as_R cst = +let rec dump_Rcst_as_R cst = match cst with - | Mc.C0 -> Lazy.force coq_R0 + | Mc.C0 -> Lazy.force coq_R0 | Mc.C1 -> Lazy.force coq_R1 | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_IQR, [| dump_q q |]) | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_IZR, [| dump_z z |]) @@ -1201,18 +1249,11 @@ let dump_rexpr = lazy dump_mul = Lazy.force coq_Rmult; dump_pow = Lazy.force coq_Rpower; dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table + dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table } - - -(** [make_goal_of_formula depxr vars props form] where - - vars is an environment for the arithmetic variables occurring in form - - props is an environment for the propositions occurring in form - @return a goal where all the variables and propositions of the formula are quantified -*) let prodn n env b = let rec prodrec = function @@ -1222,17 +1263,29 @@ let prodn n env b = in prodrec (n,env,b) +(** [make_goal_of_formula depxr vars props form] where + - vars is an environment for the arithmetic variables occurring in form + - props is an environment for the propositions occurring in form + @return a goal where all the variables and propositions of the formula are quantified + +*) + let make_goal_of_formula gl dexpr form = let vars_idx = List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) - + let props = prop_env_of_formula gl form in - let vars_n = List.map (fun (_,i) -> (Names.Id.of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in - let props_n = List.mapi (fun i _ -> (Names.Id.of_string (Printf.sprintf "__p%i" (i+1))) , EConstr.mkProp) (Env.elements props) in + let fresh_var str i = Names.Id.of_string (str^(string_of_int i)) in + + let fresh_prop str i = + Names.Id.of_string (str^(string_of_int i)) in + + let vars_n = List.map (fun (_,i) -> fresh_var "__x" i, dexpr.interp_typ) vars_idx in + let props_n = List.mapi (fun i _ -> fresh_prop "__p" (i+1) , EConstr.mkProp) (Env.elements props) in let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in @@ -1251,16 +1304,16 @@ let make_goal_of_formula gl dexpr form = | Mc.PEpow(e,n) -> EConstr.mkApp(dexpr.dump_pow, [| dump_expr e; dexpr.dump_pow_arg n|]) in dump_expr e in - + let mkop op e1 e2 = try EConstr.mkApp(List.assoc op dexpr.dump_op, [| e1; e2|]) with Not_found -> EConstr.mkApp(Lazy.force coq_Eq,[|dexpr.interp_typ ; e1 ;e2|]) in - + let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } = mkop fop (dump_expr i flhs) (dump_expr i frhs) in - + let rec xdump pi xi f = match f with | Mc.TT -> Lazy.force coq_True @@ -1271,16 +1324,16 @@ let make_goal_of_formula gl dexpr form = | Mc.N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) | Mc.A(x,_) -> dump_cstr xi x | Mc.X(t) -> let idx = Env.get_rank props t in - EConstr.mkRel (pi+idx) in - + EConstr.mkRel (pi+idx) in + let nb_vars = List.length vars_n in - let nb_props = List.length props_n in + let nb_props = List.length props_n in (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) - + let subst_prop p = let idx = Env.get_rank props p in - EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in + EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in let form' = Mc.mapX subst_prop form in @@ -1288,13 +1341,13 @@ let make_goal_of_formula gl dexpr form = (prodn nb_vars (List.map (fun (x,y) -> Name.Name x,y) vars_n) (xdump (List.length vars_n) 0 form)), List.rev props_n, List.rev var_name_pos,form') - + (** * Given a conclusion and a list of affectations, rebuild a term prefixed by * the appropriate letins. * TODO: reverse the list of bindings! *) - + let set l concl = let rec xset acc = function | [] -> acc @@ -1306,7 +1359,7 @@ let make_goal_of_formula gl dexpr form = xset concl l end (** - * MODULE END: M + * MODULE END: M *) open M @@ -1317,14 +1370,14 @@ let coq_Branch = let coq_Elt = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Elt") -let coq_Empty = +let coq_Empty = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") -let coq_VarMap = +let coq_VarMap = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") - + let rec dump_varmap typ m = match m with @@ -1337,9 +1390,9 @@ let rec dump_varmap typ m = let vm_of_list env = match env with | [] -> Mc.Empty - | (d,_)::_ -> + | (d,_)::_ -> List.fold_left (fun vm (c,i) -> - Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env + Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env let rec dump_proof_term = function | Micromega.DoneProof -> Lazy.force coq_doneProof @@ -1347,12 +1400,12 @@ let rec dump_proof_term = function EConstr.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|]) | Micromega.CutProof(cone,prf) -> EConstr.mkApp(Lazy.force coq_cutProof, - [| dump_psatz coq_Z dump_z cone ; - dump_proof_term prf|]) + [| dump_psatz coq_Z dump_z cone ; + dump_proof_term prf|]) | Micromega.EnumProof(c1,c2,prfs) -> EConstr.mkApp (Lazy.force coq_enumProof, - [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; - dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) + [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; + dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) let rec size_of_psatz = function @@ -1369,8 +1422,8 @@ let rec size_of_pf = function | Micromega.CutProof(p,a) -> (size_of_pf a) + (size_of_psatz p) | Micromega.EnumProof(p1,p2,l) -> (size_of_psatz p1) + (size_of_psatz p2) + (List.fold_left (fun acc p -> size_of_pf p + acc) 0 l) -let dump_proof_term t = - if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; +let dump_proof_term t = + if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; dump_proof_term t @@ -1384,7 +1437,7 @@ let rec pp_proof_term o = function | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst | Micromega.EnumProof(c1,c2,rst) -> Printf.fprintf o "EP[%a,%a,%a]" - (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 + (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 (pp_list "[" "]" pp_proof_term) rst let rec parse_hyps gl parse_arith env tg hyps = @@ -1392,10 +1445,14 @@ let rec parse_hyps gl parse_arith env tg hyps = | [] -> ([],env,tg) | (i,t)::l -> let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in - try - let (c,env,tg) = parse_formula gl parse_arith env tg t in - ((i,c)::lhyps, env,tg) - with e when CErrors.noncritical e -> (lhyps,env,tg) + if is_prop gl.env gl.sigma t + then + try + let (c,env,tg) = parse_formula gl parse_arith env tg t in + ((i,c)::lhyps, env,tg) + with ParseError -> (lhyps,env,tg) + else (lhyps,env,tg) + let parse_goal gl parse_arith (env:Env.t) hyps term = let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in @@ -1408,8 +1465,8 @@ let parse_goal gl parse_arith (env:Env.t) hyps term = type ('synt_c, 'prf) domain_spec = { typ : EConstr.constr; (* is the type of the interpretation domain - Z, Q, R*) coeff : EConstr.constr ; (* is the type of the syntactic coeffs - Z , Q , Rcst *) - dump_coeff : 'synt_c -> EConstr.constr ; - proof_typ : EConstr.constr ; + dump_coeff : 'synt_c -> EConstr.constr ; + proof_typ : EConstr.constr ; dump_proof : 'prf -> EConstr.constr } @@ -1465,7 +1522,7 @@ let pre_processZ mt f = Mc.bound_problem_fr tag_of_var mt f (** Naive topological sort of constr according to the subterm-ordering *) -(* An element is minimal x is minimal w.r.t y if +(* An element is minimal x is minimal w.r.t y if x <= y or (x and y are incomparable) *) (** @@ -1473,7 +1530,7 @@ let pre_processZ mt f = * witness. *) -let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) = +let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) = (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in @@ -1490,7 +1547,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* ("__wit", cert, cert_typ) ] (Tacmach.New.pf_concl gl)) - ] + ] end @@ -1511,7 +1568,7 @@ type ('option,'a,'prf,'model) prover = { } - + (** * Given a prover and a disjunction of atoms, find a proof of any of * the atoms. Returns an (optional) pair of a proof and a prover @@ -1545,7 +1602,13 @@ let witness_list prover l = | Prf w -> Prf (w::l) in xwitness_list l -let witness_list_tags = witness_list +let witness_list_tags p g = witness_list p g +(* let t1 = System.get_time () in + let res = witness_list p g in + let t2 = System.get_time () in + Feedback.msg_info Pp.(str "Witness generation "++int (List.length g) ++ str " "++System.fmt_time_difference t1 t2) ; + res + *) (** * Prune the proof object, according to the 'diff' between two cnf formulas. @@ -1593,6 +1656,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = if debug then begin Printf.printf "CNFRES\n"; flush stdout; + Printf.printf "CNFOLD %a\n" pp_cnf_tag cnf_ff; List.iter (fun (cl,(prf,prover)) -> let hyps_idx = prover.hyps prf in let hyps = selecti hyps_idx cl in @@ -1619,37 +1683,27 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = * variables. See the Tag module in mutils.ml for more. *) -let abstract_formula hyps f = - Mc.( - let rec xabs f = - match f with - | X c -> X c - | A(a,(t,term)) -> if TagSet.mem t hyps then A(a,(t,term)) else X(term) - | Cj(f1,f2) -> - (match xabs f1 , xabs f2 with - | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_and, [|a1;a2|])) - | f1 , f2 -> Cj(f1,f2) ) - | D(f1,f2) -> - (match xabs f1 , xabs f2 with - | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_or, [|a1;a2|])) - | f1 , f2 -> D(f1,f2) ) - | N(f) -> - (match xabs f with - | X a -> X (EConstr.mkApp(Lazy.force coq_not, [|a|])) - | f -> N f) - | I(f1,hyp,f2) -> - (match xabs f1 , hyp, xabs f2 with - | X a1 , Some _ , af2 -> af2 - | X a1 , None , X a2 -> X (EConstr.mkArrow a1 Sorts.Relevant a2) - | af1 , _ , af2 -> I(af1,hyp,af2) - ) - | FF -> FF - | TT -> TT - in xabs f) + + +let abstract_formula : TagSet.t -> 'a formula -> 'a formula = + fun hyps f -> + let to_constr = Mc.({ + mkTT = Lazy.force coq_True; + mkFF = Lazy.force coq_False; + mkA = (fun a (tg, t) -> t); + mkCj = (let coq_and = Lazy.force coq_and in + fun x y -> EConstr.mkApp(coq_and,[|x;y|])); + mkD = (let coq_or = Lazy.force coq_or in + fun x y -> EConstr.mkApp(coq_or,[|x;y|])); + mkI = (fun x y -> EConstr.mkArrow x Sorts.Relevant y); + mkN = (let coq_not = Lazy.force coq_not in + (fun x -> EConstr.mkApp(coq_not,[|x|]))) + }) in + Mc.abst_form to_constr (fun (t,_) -> TagSet.mem t hyps) true f (* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) -let rec abstract_wrt_formula f1 f2 = +let rec abstract_wrt_formula f1 f2 = Mc.( match f1 , f2 with | X c , _ -> X c @@ -1669,13 +1723,13 @@ let rec abstract_wrt_formula f1 f2 = exception CsdpNotFound - + (** * This is the core of Micromega: apply the prover, analyze the result and * prune unused fomulas, and finally modify the proof state. *) -let formula_hyps_concl hyps concl = +let formula_hyps_concl hyps concl = List.fold_right (fun (id,f) (cc,ids) -> match f with @@ -1684,6 +1738,14 @@ let formula_hyps_concl hyps concl = hyps (concl,[]) +(* let time str f x = + let t1 = System.get_time () in + let res = f x in + let t2 = System.get_time () in + Feedback.msg_info (Pp.str str ++ Pp.str " " ++ System.fmt_time_difference t1 t2) ; + res + *) + let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl = (* Express the goal as one big implication *) @@ -1691,34 +1753,36 @@ let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst let mt = CamlToCoq.positive (max_tag ff) in (* Construction of cnf *) - let pre_ff = (pre_process mt ff) in + let pre_ff = pre_process mt (ff:'a formula) in let (cnf_ff,cnf_ff_tags) = cnf pre_ff in match witness_list_tags prover cnf_ff with | Model m -> Model m | Unknown -> Unknown | Prf res -> (*Printf.printf "\nList %i" (List.length `res); *) - let hyps = List.fold_left + let deps = List.fold_left (fun s (cl,(prf,p)) -> let tags = ISet.fold (fun i s -> let t = fst (snd (List.nth cl i)) in if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in - TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty (List.map fst cnf_ff_tags)) (List.combine cnf_ff res) in + TagSet.union s tags) (List.fold_left (fun s (i,_) -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in - let ff' = abstract_formula hyps ff in + let ff' = abstract_formula deps ff in - let pre_ff' = pre_process mt ff' in - let cnf_ff',_ = cnf pre_ff' in + let pre_ff' = pre_process mt ff' in + let (cnf_ff',_) = cnf pre_ff' in if debug then begin output_string stdout "\n"; Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; + Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff ; flush stdout; Printf.printf "TFormAbs : %a\n" pp_formula ff' ; flush stdout; Printf.printf "TFormPre : %a\n" pp_formula pre_ff ; flush stdout; Printf.printf "TFormPreAbs : %a\n" pp_formula pre_ff' ; flush stdout; + Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff' ; flush stdout; end; (* Even if it does not work, this does not mean it is not provable @@ -1730,6 +1794,7 @@ let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst | None -> failwith "abstraction is wrong" | Some res -> () end ; *) + let res' = compact_proofs cnf_ff res cnf_ff' in let (ff',res',ids) = (ff',res', Mc.ids_of_formula ff') in @@ -1749,12 +1814,22 @@ let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst (** * Parse the proof environment, and call micromega_tauto *) - let fresh_id avoid id gl = Tactics.fresh_id_in_env avoid id (Proofview.Goal.env gl) +let clear_all_no_check = + Proofview.Goal.enter begin fun gl -> + let concl = Tacmach.New.pf_concl gl in + let env = Environ.reset_with_named_context Environ.empty_named_context_val (Tacmach.New.pf_env gl) in + (Refine.refine ~typecheck:false begin fun sigma -> + Evarutil.new_evar env sigma ~principal:true concl + end) + end + + + let micromega_gen - parse_arith + parse_arith pre_process cnf spec dumpexpr prover tac = @@ -1771,52 +1846,48 @@ let micromega_gen if debug then Feedback.msg_debug (Pp.str "Env " ++ (Env.pp gl0 env)) ; - + match micromega_tauto pre_process cnf spec prover env hyps concl gl0 with | Unknown -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Model(m,e) -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Prf (ids,ff',res') -> let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 dumpexpr ff' in - let intro (id,_) = Tactics.introduction id in + let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in + (* let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in*) let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in + let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; + let tac_arith = Tacticals.New.tclTHENLIST [ clear_all_no_check ;intro_props ; intro_vars ; micromega_order_change spec res' (EConstr.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - - let arith_args = goal_props @ goal_vars in + let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - let kill_arith = - Tacticals.New.tclTHEN - (Tactics.keep []) - ((*Tactics.tclABSTRACT None*) - (Tacticals.New.tclTHEN tac_arith tac)) in + let arith_args = goal_props @ goal_vars in - Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) - [ - kill_arith; - (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args)) - ] ) - ] + let kill_arith = Tacticals.New.tclTHEN tac_arith tac in +(* +(*tclABSTRACT fails in certain corner cases.*) +Tacticals.New.tclTHEN + clear_all_no_check + (Abstract.tclABSTRACT ~opaque:false None (Tacticals.New.tclTHEN tac_arith tac)) in *) + + Tacticals.New.tclTHEN + (Tactics.assert_by (Names.Name goal_name) arith_goal + ((*Proofview.tclTIME (Some "kill_arith")*) kill_arith)) + ((*Proofview.tclTIME (Some "apply_arith") *) + (Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args@(List.map EConstr.mkVar ids))))) with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str + Tacticals.New.tclFAIL 0 (Pp.str (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" + ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) | x -> begin if debug then Tacticals.New.tclFAIL 0 (Pp.str (Printexc.get_backtrace ())) @@ -1824,13 +1895,13 @@ let micromega_gen end end -let micromega_order_changer cert env ff = +let micromega_order_changer cert env ff = (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) let coeff = Lazy.force coq_Rcst in let dump_coeff = dump_Rcst in let typ = Lazy.force coq_R in let cert_typ = (EConstr.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in - + let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[| coeff|])) in let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) (vm_of_list env) in @@ -1843,7 +1914,7 @@ let micromega_order_changer cert env ff = ("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [|formula_typ |])); ("__varmap", vm, EConstr.mkApp (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); ("__wit", cert, cert_typ) ] (Tacmach.New.pf_concl gl))); @@ -1870,68 +1941,62 @@ let micromega_genr prover tac = let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in let env = Env.elements env in let spec = Lazy.force spec in - + let hyps' = List.map (fun (n,f) -> (n, Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in let concl' = Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) concl in - + match micromega_tauto (fun _ x -> x) Mc.cnfQ spec prover env hyps' concl' gl0 with | Unknown | Model _ -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Prf (ids,ff',res') -> - let (ff,ids) = formula_hyps_concl - (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in + let (ff,ids) = formula_hyps_concl + (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in + let ff' = abstract_wrt_formula ff' ff in let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 (Lazy.force dump_rexpr) ff' in - let intro (id,_) = Tactics.introduction id in + let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - - let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; + let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in + + let tac_arith = Tacticals.New.tclTHENLIST [ clear_all_no_check ; intro_props ; intro_vars ; micromega_order_changer res' env' ff_arith ] in let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - + let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in + let arith_args = goal_props @ goal_vars in - let kill_arith = - Tacticals.New.tclTHEN + let kill_arith = Tacticals.New.tclTHEN tac_arith tac in + (* Tacticals.New.tclTHEN (Tactics.keep []) - ((*Tactics.tclABSTRACT None*) - (Tacticals.New.tclTHEN tac_arith tac)) in + (Tactics.tclABSTRACT None*) Tacticals.New.tclTHENS (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) [ kill_arith; (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args)) + [(Tactics.generalize (List.map EConstr.mkVar ids)); + (Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args))) ] ) ] with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str + Tacticals.New.tclFAIL 0 (Pp.str (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" + ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) end - - -let micromega_genr prover = (micromega_genr prover) - - let lift_ratproof prover l = match prover l with | Unknown | Model _ -> Unknown @@ -1951,13 +2016,47 @@ type provername = string * int option open Persistent_cache -module Cache = PHashtable(struct - type t = (provername * micromega_polys) - let equal = (=) - let hash = Hashtbl.hash -end) -let csdp_cache = ".csdp.cache" +module MakeCache(T : sig type prover_option + type coeff + val hash_prover_option : int -> prover_option -> int + val hash_coeff : int -> coeff -> int + val eq_prover_option : prover_option -> prover_option -> bool + val eq_coeff : coeff -> coeff -> bool + + end) = + struct + module E = + struct + type t = T.prover_option * (T.coeff Mc.pol * Mc.op1) list + + let equal = Hash.(eq_pair T.eq_prover_option (CList.equal (eq_pair (eq_pol T.eq_coeff) Hash.eq_op1))) + + let hash = + let hash_cstr = Hash.(hash_pair (hash_pol T.hash_coeff) hash_op1) in + Hash.( (hash_pair T.hash_prover_option (List.fold_left hash_cstr)) 0) + end + + include PHashtable(E) + + let memo_opt use_cache cache_file f = + let memof = memo cache_file f in + fun x -> if !use_cache then memof x else f x + + end + + + +module CacheCsdp = MakeCache(struct + type prover_option = provername + type coeff = Mc.q + let hash_prover_option = Hash.(hash_pair hash_string + (hash_elt (Option.hash (fun x -> x)))) + let eq_prover_option = Hash.(eq_pair String.equal + (Option.equal Int.equal)) + let hash_coeff = Hash.hash_q + let eq_coeff = Hash.eq_q + end) (** * Build the command to call csdpcert, and launch it. This in turn will call @@ -1966,7 +2065,7 @@ let csdp_cache = ".csdp.cache" *) let require_csdp = - if System.is_in_system_path "csdp" + if System.is_in_system_path "csdp" then lazy () else lazy (raise CsdpNotFound) @@ -1990,7 +2089,7 @@ let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivste *) let xcall_csdpcert = - Cache.memo csdp_cache (fun (prover,pb) -> really_call_csdpcert prover pb) + CacheCsdp.memo_opt use_csdp_cache ".csdp.cache" (fun (prover,pb) -> really_call_csdpcert prover pb) (** * Prover callback functions. @@ -2028,9 +2127,9 @@ let xhyps_of_cone base acc prf = match e with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in - if n >= base - then ISet.add (n-base) acc - else acc + if n >= base + then ISet.add (n-base) acc + else acc | Mc.PsatzMulC(_,c) -> xtract c acc | Mc.PsatzAdd(e1,e2) | Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in @@ -2059,8 +2158,8 @@ let hyps_of_pt pt = | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) | Mc.EnumProof(c1,c2,l) -> - let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in - List.fold_left (fun s x -> xhyps (base + 1) x s) s l in + let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in + List.fold_left (fun s x -> xhyps (base + 1) x s) s l in xhyps 0 pt ISet.empty @@ -2075,39 +2174,47 @@ let compact_pt pt f = | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)), - Mc.map (fun x -> compact_pt (ofset+1) x) l) in + Mc.map (fun x -> compact_pt (ofset+1) x) l) in compact_pt 0 pt -(** +(** * Definition of provers. * Instantiates the type ('a,'prf) prover defined above. *) let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) -module CacheZ = PHashtable(struct - type prover_option = bool * bool* int - type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list) - let equal = (=) - let hash = Hashtbl.hash -end) +module CacheZ = MakeCache(struct + type prover_option = bool * bool* int + type coeff = Mc.z + let hash_prover_option : int -> prover_option -> int = Hash.hash_elt Hashtbl.hash + let eq_prover_option : prover_option -> prover_option -> bool = (=) + let eq_coeff = Hash.eq_z + let hash_coeff = Hash.hash_z + end) + +module CacheQ = MakeCache(struct + type prover_option = int + type coeff = Mc.q + let hash_prover_option : int -> int -> int = Hash.hash_elt Hashtbl.hash + let eq_prover_option = Int.equal + let eq_coeff = Hash.eq_q + let hash_coeff = Hash.hash_q + end) -module CacheQ = PHashtable(struct - type t = int * ((Mc.q Mc.pol * Mc.op1) list) - let equal = (=) - let hash = Hashtbl.hash -end) +let memo_lia = CacheZ.memo_opt use_lia_cache ".lia.cache" + (fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) +let memo_nlia = CacheZ.memo_opt use_nia_cache ".nia.cache" + (fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) +let memo_nra = CacheQ.memo_opt use_nra_cache ".nra.cache" + (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) -let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) -let memo_nlia = CacheZ.memo ".nia.cache" (fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) -let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) - let linear_prover_Q = { name = "linear prover"; - get_option = get_lra_option ; + get_option = get_lra_option ; prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; hyps = hyps_of_cone ; compact = compact_cone ; @@ -2118,7 +2225,7 @@ let linear_prover_Q = { let linear_prover_R = { name = "linear prover"; - get_option = get_lra_option ; + get_option = get_lra_option ; prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; hyps = hyps_of_cone ; compact = compact_cone ; @@ -2127,70 +2234,85 @@ let linear_prover_R = { } let nlinear_prover_R = { - name = "nra"; - get_option = get_lra_option; - prover = memo_nra ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) + name = "nra"; + get_option = get_lra_option; + prover = memo_nra ; + hyps = hyps_of_cone ; + compact = compact_cone ; + pp_prf = pp_psatz pp_q ; + pp_f = fun o x -> pp_pol pp_q o (fst x) } let non_linear_prover_Q str o = { - name = "real nonlinear prover"; + name = "real nonlinear prover"; get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> call_csdpcert_q o l); - hyps = hyps_of_cone; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) + prover = (fun (o,l) -> call_csdpcert_q o l); + hyps = hyps_of_cone; + compact = compact_cone ; + pp_prf = pp_psatz pp_q ; + pp_f = fun o x -> pp_pol pp_q o (fst x) } let non_linear_prover_R str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> call_csdpcert_q o l); - hyps = hyps_of_cone; - compact = compact_cone; - pp_prf = pp_psatz pp_q; - pp_f = fun o x -> pp_pol pp_q o (fst x) + name = "real nonlinear prover"; + get_option = (fun () -> (str,o)); + prover = (fun (o,l) -> call_csdpcert_q o l); + hyps = hyps_of_cone; + compact = compact_cone; + pp_prf = pp_psatz pp_q; + pp_f = fun o x -> pp_pol pp_q o (fst x) } let non_linear_prover_Z str o = { - name = "real nonlinear prover"; + name = "real nonlinear prover"; get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) + prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); + hyps = hyps_of_pt; + compact = compact_pt; + pp_prf = pp_proof_term; + pp_f = fun o x -> pp_pol pp_z o (fst x) } let linear_Z = { - name = "lia"; - get_option = get_lia_option; - prover = memo_zlinear_prover ; - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) + name = "lia"; + get_option = get_lia_option; + prover = memo_lia ; + hyps = hyps_of_pt; + compact = compact_pt; + pp_prf = pp_proof_term; + pp_f = fun o x -> pp_pol pp_z o (fst x) } let nlinear_Z = { - name = "nlia"; - get_option = get_lia_option; - prover = memo_nlia ; - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) + name = "nlia"; + get_option = get_lia_option; + prover = memo_nlia ; + hyps = hyps_of_pt; + compact = compact_pt; + pp_prf = pp_proof_term; + pp_f = fun o x -> pp_pol pp_z o (fst x) } -(** +(** * Functions instantiating micromega_gen with the appropriate theories and * solvers *) +let exfalso_if_concl_not_Prop = + Proofview.Goal.enter begin fun gl -> + Tacmach.New.( + if is_prop (pf_env gl) (project gl) (pf_concl gl) + then Tacticals.New.tclIDTAC + else Tactics.elim_type (Lazy.force coq_False) + ) + end + +let micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac = + Tacticals.New.tclTHEN exfalso_if_concl_not_Prop (micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac) + +let micromega_genr prover tac = + Tacticals.New.tclTHEN exfalso_if_concl_not_Prop (micromega_genr prover tac) + let lra_Q = micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr linear_prover_Q @@ -2232,26 +2354,13 @@ let xnlia = micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr nlinear_Z -let nra = +let nra = micromega_genr nlinear_prover_R let nqa = micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr nlinear_prover_R -(** Let expose [is_ground_tac] *) - -let is_ground_tac t = - Proofview.Goal.enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let env = Tacmach.New.pf_env gl in - if is_ground_term env sigma t - then Tacticals.New.tclIDTAC - else Tacticals.New.tclFAIL 0 (Pp.str "Not ground") - end - - - (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli index 7567e7c322..844ff5b1a6 100644 --- a/plugins/micromega/coq_micromega.mli +++ b/plugins/micromega/coq_micromega.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val is_ground_tac : EConstr.constr -> unit Proofview.tactic +(*val is_ground_tac : EConstr.constr -> unit Proofview.tactic*) val psatz_Z : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_Q : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_R : int -> unit Proofview.tactic -> unit Proofview.tactic diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg index ffc803af44..bcf546f059 100644 --- a/plugins/micromega/g_micromega.mlg +++ b/plugins/micromega/g_micromega.mlg @@ -22,6 +22,8 @@ open Ltac_plugin open Stdarg open Tacarg + + } DECLARE PLUGIN "micromega_plugin" @@ -30,11 +32,6 @@ TACTIC EXTEND RED | [ "myred" ] -> { Tactics.red_in_concl } END -TACTIC EXTEND ISGROUND -| [ "is_ground" constr(t) ] -> { Coq_micromega.is_ground_tac t } -END - - TACTIC EXTEND PsatzZ | [ "psatz_Z" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Z i (Tacinterp.tactic_of_value ist t)) diff --git a/plugins/micromega/g_zify.mlg b/plugins/micromega/g_zify.mlg new file mode 100644 index 0000000000..424a7d7c54 --- /dev/null +++ b/plugins/micromega/g_zify.mlg @@ -0,0 +1,52 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +{ + +open Ltac_plugin +open Stdarg +open Tacarg + + +} + +DECLARE PLUGIN "zify_plugin" + +VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF +| ["Add" "InjTyp" constr(t) ] -> { Zify.InjTable.register t } +| ["Add" "BinOp" constr(t) ] -> { Zify.BinOp.register t } +| ["Add" "UnOp" constr(t) ] -> { Zify.UnOp.register t } +| ["Add" "CstOp" constr(t) ] -> { Zify.CstOp.register t } +| ["Add" "BinRel" constr(t) ] -> { Zify.BinRel.register t } +| ["Add" "PropOp" constr(t) ] -> { Zify.PropOp.register t } +| ["Add" "PropUOp" constr(t) ] -> { Zify.PropOp.register t } +| ["Add" "Spec" constr(t) ] -> { Zify.Spec.register t } +| ["Add" "BinOpSpec" constr(t) ] -> { Zify.Spec.register t } +| ["Add" "UnOpSpec" constr(t) ] -> { Zify.Spec.register t } +| ["Add" "Saturate" constr(t) ] -> { Zify.Saturate.register t } +END + +TACTIC EXTEND ITER +| [ "iter_specs" tactic(t)] -> { Zify.iter_specs t } +END + +TACTIC EXTEND TRANS +| [ "zify_tac" ] -> { Zify.zify_tac } +| [ "saturate" ] -> { Zify.saturate } +END + +VERNAC COMMAND EXTEND ZifyPrint CLASSIFIED AS SIDEFF +|[ "Show" "Zify" "InjTyp" ] -> { Zify.InjTable.print () } +|[ "Show" "Zify" "BinOp" ] -> { Zify.BinOp.print () } +|[ "Show" "Zify" "UnOp" ] -> { Zify.UnOp.print () } +|[ "Show" "Zify" "CstOp"] -> { Zify.CstOp.print () } +|[ "Show" "Zify" "BinRel"] -> { Zify.BinRel.print () } +|[ "Show" "Zify" "Spec"] -> { Zify.Spec.print () } +END diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index cd620bd4a9..f508b3dc56 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -67,12 +67,26 @@ let rec nth n0 l default = | [] -> default | _::t0 -> nth m t0 default) +(** val rev_append : 'a1 list -> 'a1 list -> 'a1 list **) + +let rec rev_append l l' = + match l with + | [] -> l' + | a::l0 -> rev_append l0 (a::l') + (** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) let rec map f = function | [] -> [] | a::t0 -> (f a)::(map f t0) +(** val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 **) + +let rec fold_left f l a0 = + match l with + | [] -> a0 + | b::t0 -> fold_left f t0 (f a0 b) + (** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) let rec fold_right f a0 = function @@ -1061,15 +1075,24 @@ let rec or_clause unsat deduce cl1 cl2 = | Some cl' -> or_clause unsat deduce cl cl' | None -> None) -(** val or_clause_cnf : +(** val xor_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) -let or_clause_cnf unsat deduce t0 f = - fold_right (fun e acc -> +let xor_clause_cnf unsat deduce t0 f = + fold_left (fun acc e -> match or_clause unsat deduce t0 e with | Some cl -> cl::acc - | None -> acc) [] f + | None -> acc) f [] + +(** val or_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf **) + +let or_clause_cnf unsat deduce t0 f = + match t0 with + | [] -> f + | _::_ -> xor_clause_cnf unsat deduce t0 f (** val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, @@ -1079,45 +1102,78 @@ let rec or_cnf unsat deduce f f' = match f with | [] -> cnf_tt | e::rst -> - app (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') + rev_append (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') (** val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) let and_cnf = - app + rev_append type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula +(** val is_cnf_tt : ('a1, 'a2) cnf -> bool **) + +let is_cnf_tt = function +| [] -> true +| _::_ -> false + +(** val is_cnf_ff : ('a1, 'a2) cnf -> bool **) + +let is_cnf_ff = function +| [] -> false +| c0::l -> + (match c0 with + | [] -> (match l with + | [] -> true + | _::_ -> false) + | _::_ -> false) + +(** val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) + +let and_cnf_opt f1 f2 = + if if is_cnf_ff f1 then true else is_cnf_ff f2 + then cnf_ff + else and_cnf f1 f2 + +(** val or_cnf_opt : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf **) + +let or_cnf_opt unsat deduce f1 f2 = + if if is_cnf_tt f1 then true else is_cnf_tt f2 + then cnf_tt + else if is_cnf_ff f2 then f1 else or_cnf unsat deduce f1 f2 + (** val xcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf **) -let rec xcnf unsat deduce normalise0 negate0 pol0 = function +let rec xcnf unsat deduce normalise1 negate0 pol0 = function | TT -> if pol0 then cnf_tt else cnf_ff | FF -> if pol0 then cnf_ff else cnf_tt | X _ -> cnf_ff -| A (x, t0) -> if pol0 then normalise0 x t0 else negate0 x t0 +| A (x, t0) -> if pol0 then normalise1 x t0 else negate0 x t0 | Cj (e1, e2) -> if pol0 - then and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) - else or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) + then and_cnf_opt (xcnf unsat deduce normalise1 negate0 pol0 e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) + else or_cnf_opt unsat deduce (xcnf unsat deduce normalise1 negate0 pol0 e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) | D (e1, e2) -> if pol0 - then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) - else and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) -| N e -> xcnf unsat deduce normalise0 negate0 (negb pol0) e + then or_cnf_opt unsat deduce (xcnf unsat deduce normalise1 negate0 pol0 e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) + else and_cnf_opt (xcnf unsat deduce normalise1 negate0 pol0 e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) +| N e -> xcnf unsat deduce normalise1 negate0 (negb pol0) e | I (e1, _, e2) -> if pol0 - then or_cnf unsat deduce - (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) - else and_cnf (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) + then or_cnf_opt unsat deduce + (xcnf unsat deduce normalise1 negate0 (negb pol0) e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) + else and_cnf_opt (xcnf unsat deduce normalise1 negate0 (negb pol0) e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) (** val radd_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) @@ -1153,19 +1209,28 @@ let rec ror_clause unsat deduce cl1 cl2 = | Inl cl' -> ror_clause unsat deduce cl cl' | Inr l -> Inr l) -(** val ror_clause_cnf : +(** val xror_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> ('a1, 'a2) clause list * 'a2 list **) -let ror_clause_cnf unsat deduce t0 f = - fold_right (fun e pat -> +let xror_clause_cnf unsat deduce t0 f = + fold_left (fun pat e -> let acc,tg = pat in (match ror_clause unsat deduce t0 e with | Inl cl -> (cl::acc),tg - | Inr l -> acc,(app tg l))) ([],[]) f + | Inr l -> acc,(rev_append tg l))) f ([],[]) + +(** val ror_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, + 'a2) clause list -> ('a1, 'a2) clause list * 'a2 list **) + +let ror_clause_cnf unsat deduce t0 f = + match t0 with + | [] -> f,[] + | _::_ -> xror_clause_cnf unsat deduce t0 f (** val ror_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list list -> + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> ('a1, 'a2) clause list -> ('a1, 'a2) cnf * 'a2 list **) let rec ror_cnf unsat deduce f f' = @@ -1174,37 +1239,159 @@ let rec ror_cnf unsat deduce f f' = | e::rst -> let rst_f',t0 = ror_cnf unsat deduce rst f' in let e_f',t' = ror_clause_cnf unsat deduce e f' in - (app rst_f' e_f'),(app t0 t') + (rev_append rst_f' e_f'),(rev_append t0 t') + +(** val ror_cnf_opt : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf * 'a2 list **) + +let ror_cnf_opt unsat deduce f1 f2 = + if is_cnf_tt f1 + then cnf_tt,[] + else if is_cnf_tt f2 + then cnf_tt,[] + else if is_cnf_ff f2 then f1,[] else ror_cnf unsat deduce f1 f2 + +(** val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 list **) + +let ratom c a = + if if is_cnf_ff c then true else is_cnf_tt c then c,(a::[]) else c,[] (** val rxcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list **) -let rec rxcnf unsat deduce normalise0 negate0 polarity = function +let rec rxcnf unsat deduce normalise1 negate0 polarity = function | TT -> if polarity then cnf_tt,[] else cnf_ff,[] | FF -> if polarity then cnf_ff,[] else cnf_tt,[] | X _ -> cnf_ff,[] -| A (x, t0) -> (if polarity then normalise0 x t0 else negate0 x t0),[] +| A (x, t0) -> ratom (if polarity then normalise1 x t0 else negate0 x t0) t0 | Cj (e1, e2) -> - let e3,t1 = rxcnf unsat deduce normalise0 negate0 polarity e1 in - let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + let e3,t1 = rxcnf unsat deduce normalise1 negate0 polarity e1 in + let e4,t2 = rxcnf unsat deduce normalise1 negate0 polarity e2 in if polarity - then (app e3 e4),(app t1 t2) - else let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) + then (and_cnf_opt e3 e4),(rev_append t1 t2) + else let f',t' = ror_cnf_opt unsat deduce e3 e4 in + f',(rev_append t1 (rev_append t2 t')) | D (e1, e2) -> - let e3,t1 = rxcnf unsat deduce normalise0 negate0 polarity e1 in - let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + let e3,t1 = rxcnf unsat deduce normalise1 negate0 polarity e1 in + let e4,t2 = rxcnf unsat deduce normalise1 negate0 polarity e2 in if polarity - then let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) - else (app e3 e4),(app t1 t2) -| N e -> rxcnf unsat deduce normalise0 negate0 (negb polarity) e + then let f',t' = ror_cnf_opt unsat deduce e3 e4 in + f',(rev_append t1 (rev_append t2 t')) + else (and_cnf_opt e3 e4),(rev_append t1 t2) +| N e -> rxcnf unsat deduce normalise1 negate0 (negb polarity) e | I (e1, _, e2) -> - let e3,t1 = rxcnf unsat deduce normalise0 negate0 (negb polarity) e1 in - let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + let e3,t1 = rxcnf unsat deduce normalise1 negate0 (negb polarity) e1 in if polarity - then let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) - else (and_cnf e3 e4),(app t1 t2) + then if is_cnf_ff e3 + then rxcnf unsat deduce normalise1 negate0 polarity e2 + else let e4,t2 = rxcnf unsat deduce normalise1 negate0 polarity e2 in + let f',t' = ror_cnf_opt unsat deduce e3 e4 in + f',(rev_append t1 (rev_append t2 t')) + else let e4,t2 = rxcnf unsat deduce normalise1 negate0 polarity e2 in + (and_cnf_opt e3 e4),(rev_append t1 t2) + +type ('term, 'annot, 'tX) to_constrT = { mkTT : 'tX; mkFF : 'tX; + mkA : ('term -> 'annot -> 'tX); + mkCj : ('tX -> 'tX -> 'tX); + mkD : ('tX -> 'tX -> 'tX); + mkI : ('tX -> 'tX -> 'tX); + mkN : ('tX -> 'tX) } + +(** val aformula : + ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 **) + +let rec aformula to_constr = function +| TT -> to_constr.mkTT +| FF -> to_constr.mkFF +| X p -> p +| A (x, t0) -> to_constr.mkA x t0 +| Cj (f1, f2) -> + to_constr.mkCj (aformula to_constr f1) (aformula to_constr f2) +| D (f1, f2) -> to_constr.mkD (aformula to_constr f1) (aformula to_constr f2) +| N f0 -> to_constr.mkN (aformula to_constr f0) +| I (f1, _, f2) -> + to_constr.mkI (aformula to_constr f1) (aformula to_constr f2) + +(** val is_X : ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option **) + +let is_X = function +| X p -> Some p +| _ -> None + +(** val abs_and : + ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula -> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) + gFormula **) + +let abs_and to_constr f1 f2 c = + match is_X f1 with + | Some _ -> X (aformula to_constr (c f1 f2)) + | None -> + (match is_X f2 with + | Some _ -> X (aformula to_constr (c f1 f2)) + | None -> c f1 f2) + +(** val abs_or : + ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula -> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) + gFormula **) + +let abs_or to_constr f1 f2 c = + match is_X f1 with + | Some _ -> + (match is_X f2 with + | Some _ -> X (aformula to_constr (c f1 f2)) + | None -> c f1 f2) + | None -> c f1 f2 + +(** val mk_arrow : + 'a4 option -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula **) + +let mk_arrow o f1 f2 = + match o with + | Some _ -> (match is_X f1 with + | Some _ -> f2 + | None -> I (f1, o, f2)) + | None -> I (f1, None, f2) + +(** val abst_form : + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a3, 'a2, 'a4) gFormula **) + +let rec abst_form to_constr needA pol0 = function +| TT -> if pol0 then TT else X to_constr.mkTT +| FF -> if pol0 then X to_constr.mkFF else FF +| X p -> X p +| A (x, t0) -> if needA t0 then A (x, t0) else X (to_constr.mkA x t0) +| Cj (f1, f2) -> + let f3 = abst_form to_constr needA pol0 f1 in + let f4 = abst_form to_constr needA pol0 f2 in + if pol0 + then abs_and to_constr f3 f4 (fun x x0 -> Cj (x, x0)) + else abs_or to_constr f3 f4 (fun x x0 -> Cj (x, x0)) +| D (f1, f2) -> + let f3 = abst_form to_constr needA pol0 f1 in + let f4 = abst_form to_constr needA pol0 f2 in + if pol0 + then abs_or to_constr f3 f4 (fun x x0 -> D (x, x0)) + else abs_and to_constr f3 f4 (fun x x0 -> D (x, x0)) +| N f0 -> + let f1 = abst_form to_constr needA (negb pol0) f0 in + (match is_X f1 with + | Some a -> X (to_constr.mkN a) + | None -> N f1) +| I (f1, o, f2) -> + let f3 = abst_form to_constr needA (negb pol0) f1 in + let f4 = abst_form to_constr needA pol0 f2 in + if pol0 + then abs_or to_constr f3 f4 (mk_arrow o) + else abs_and to_constr f3 f4 (mk_arrow o) (** val cnf_checker : (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool **) @@ -1222,8 +1409,8 @@ let rec cnf_checker checker f l = cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, 'a3, unit0) gFormula -> 'a4 list -> bool **) -let tauto_checker unsat deduce normalise0 negate0 checker f w = - cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w +let tauto_checker unsat deduce normalise1 negate0 checker f w = + cnf_checker checker (xcnf unsat deduce normalise1 negate0 true f) w (** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) @@ -1413,62 +1600,76 @@ let psub0 = let padd0 = padd -(** val xnormalise : +(** val popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) + +let popp0 = + popp + +(** val normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list **) + nFormula **) -let xnormalise cO cI cplus ctimes cminus copp ceqb t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in +let normalise cO cI cplus ctimes cminus copp ceqb f = + let { flhs = lhs; fop = op; frhs = rhs } = f in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in + (match op with + | OpEq -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal + | OpNEq -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonEqual + | OpLe -> (psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict + | OpGe -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict + | OpLt -> (psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict + | OpGt -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict) + +(** val xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) + +let xnormalise copp = function +| e,o -> (match o with - | OpEq -> - ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus - cminus copp - ceqb rhs0 lhs0),Strict)::[]) - | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] - | OpLe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[] - | OpGe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] - | OpLt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] - | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[]) + | Equal -> (e,Strict)::(((popp0 copp e),Strict)::[]) + | NonEqual -> (e,Equal)::[] + | Strict -> ((popp0 copp e),NonStrict)::[] + | NonStrict -> ((popp0 copp e),Strict)::[]) -(** val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> - ('a1 nFormula, 'a2) cnf **) +(** val xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) -let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 tg = - map (fun x -> (x,tg)::[]) - (xnormalise cO cI cplus ctimes cminus copp ceqb t0) +let xnegate copp = function +| e,o -> + (match o with + | NonEqual -> (e,Strict)::(((popp0 copp e),Strict)::[]) + | x -> (e,x)::[]) + +(** val cnf_of_list : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list + -> 'a2 -> ('a1 nFormula, 'a2) cnf **) + +let cnf_of_list cO ceqb cleb l tg = + fold_right (fun x acc -> + if check_inconsistent cO ceqb cleb x then acc else ((x,tg)::[])::acc) + cnf_tt l -(** val xnegate : +(** val cnf_normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list **) + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) + -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf **) -let xnegate cO cI cplus ctimes cminus copp ceqb t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in - let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in - (match o with - | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] - | OpNEq -> - ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus - cminus copp - ceqb rhs0 lhs0),Strict)::[]) - | OpLe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[] - | OpGe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] - | OpLt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] - | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[]) +let cnf_normalise cO cI cplus ctimes cminus copp ceqb cleb t0 tg = + let f = normalise cO cI cplus ctimes cminus copp ceqb t0 in + if check_inconsistent cO ceqb cleb f + then cnf_ff + else cnf_of_list cO ceqb cleb (xnormalise copp f) tg (** val cnf_negate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> - ('a1 nFormula, 'a2) cnf **) + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) + -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf **) -let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 tg = - map (fun x -> (x,tg)::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) +let cnf_negate cO cI cplus ctimes cminus copp ceqb cleb t0 tg = + let f = normalise cO cI cplus ctimes cminus copp ceqb t0 in + if check_inconsistent cO ceqb cleb f + then cnf_tt + else cnf_of_list cO ceqb cleb (xnegate copp f) tg (** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) @@ -1696,67 +1897,75 @@ let padd1 = let normZ = norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp zeq_bool -(** val xnormalise0 : z formula -> z nFormula list **) +(** val zunsat : z nFormula -> bool **) -let xnormalise0 t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = normZ lhs in - let rhs0 = normZ rhs in - (match o with - | OpEq -> - ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 - (padd1 lhs0 - (Pc (Zpos - XH)))),NonStrict)::[]) - | OpNEq -> ((psub1 lhs0 rhs0),Equal)::[] - | OpLe -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[] - | OpGe -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] - | OpLt -> ((psub1 lhs0 rhs0),NonStrict)::[] - | OpGt -> ((psub1 rhs0 lhs0),NonStrict)::[]) +let zunsat = + check_inconsistent Z0 zeq_bool Z.leb -(** val normalise : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) +(** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) -let normalise t0 tg = - map (fun x -> (x,tg)::[]) (xnormalise0 t0) +let zdeduce = + nformula_plus_nformula Z0 Z.add zeq_bool -(** val xnegate0 : z formula -> z nFormula list **) +(** val xnnormalise : z formula -> z nFormula **) -let xnegate0 t0 = +let xnnormalise t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = normZ lhs in let rhs0 = normZ rhs in (match o with - | OpEq -> ((psub1 lhs0 rhs0),Equal)::[] - | OpNEq -> - ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 - (padd1 lhs0 - (Pc (Zpos - XH)))),NonStrict)::[]) - | OpLe -> ((psub1 rhs0 lhs0),NonStrict)::[] - | OpGe -> ((psub1 lhs0 rhs0),NonStrict)::[] - | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] - | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[]) + | OpEq -> (psub1 rhs0 lhs0),Equal + | OpNEq -> (psub1 rhs0 lhs0),NonEqual + | OpLe -> (psub1 rhs0 lhs0),NonStrict + | OpGe -> (psub1 lhs0 rhs0),NonStrict + | OpLt -> (psub1 rhs0 lhs0),Strict + | OpGt -> (psub1 lhs0 rhs0),Strict) -(** val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) +(** val xnormalise0 : z nFormula -> z nFormula list **) -let negate t0 tg = - map (fun x -> (x,tg)::[]) (xnegate0 t0) +let xnormalise0 = function +| e,o -> + (match o with + | Equal -> + ((psub1 e (Pc (Zpos XH))),NonStrict)::(((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) + | NonEqual -> (e,Equal)::[] + | Strict -> ((psub1 (Pc Z0) e),NonStrict)::[] + | NonStrict -> ((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) -(** val zunsat : z nFormula -> bool **) +(** val cnf_of_list0 : + 'a1 -> z nFormula list -> (z nFormula * 'a1) list list **) -let zunsat = - check_inconsistent Z0 zeq_bool Z.leb +let cnf_of_list0 tg l = + fold_right (fun x acc -> if zunsat x then acc else ((x,tg)::[])::acc) + cnf_tt l -(** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) +(** val normalise0 : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) -let zdeduce = - nformula_plus_nformula Z0 Z.add zeq_bool +let normalise0 t0 tg = + let f = xnnormalise t0 in + if zunsat f then cnf_ff else cnf_of_list0 tg (xnormalise0 f) + +(** val xnegate0 : z nFormula -> z nFormula list **) + +let xnegate0 = function +| e,o -> + (match o with + | NonEqual -> + ((psub1 e (Pc (Zpos XH))),NonStrict)::(((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) + | Strict -> ((psub1 e (Pc (Zpos XH))),NonStrict)::[] + | x -> (e,x)::[]) + +(** val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) + +let negate t0 tg = + let f = xnnormalise t0 in + if zunsat f then cnf_tt else cnf_of_list0 tg (xnegate0 f) (** val cnfZ : (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list **) let cnfZ f = - rxcnf zunsat zdeduce normalise negate true f + rxcnf zunsat zdeduce normalise0 negate true f (** val ceiling : z -> z -> z **) @@ -2027,7 +2236,7 @@ let rec zChecker l = function (** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) let zTautoChecker f w = - tauto_checker zunsat zdeduce normalise negate (fun cl -> + tauto_checker zunsat zdeduce normalise0 negate (fun cl -> zChecker (map fst cl)) f w type qWitness = q psatz @@ -2042,13 +2251,13 @@ let qWeakChecker = let qnormalise t0 tg = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool t0 tg + qplus qmult qminus qopp qeq_bool qle_bool t0 tg (** val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) let qnegate t0 tg = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool t0 tg + qmult qminus qopp qeq_bool qle_bool t0 tg (** val qunsat : q nFormula -> bool **) @@ -2122,13 +2331,13 @@ let rWeakChecker = let rnormalise t0 tg = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool t0 tg + qplus qmult qminus qopp qeq_bool qle_bool t0 tg (** val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) let rnegate t0 tg = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool t0 tg + qmult qminus qopp qeq_bool qle_bool t0 tg (** val runsat : q nFormula -> bool **) diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 6da0c754f4..822fde9ab0 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -31,8 +31,12 @@ val add : nat -> nat -> nat val nth : nat -> 'a1 list -> 'a1 -> 'a1 +val rev_append : 'a1 list -> 'a1 list -> 'a1 list + val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list +val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 + val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 type positive = @@ -187,45 +191,43 @@ val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol - -> 'a1 pol + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> + 'a1 pol val psubI : - ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive + -> 'a1 pol -> 'a1 pol val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> - 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 + pol -> 'a1 pol val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 - pol -> positive -> 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol -val padd : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val psub : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 pol -> 'a1 pol -> 'a1 pol -val pmulC_aux : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol +val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 - pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) + -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 - pol -> 'a1 pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol + -> 'a1 pol -> 'a1 pol val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 - pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol + -> 'a1 pol type 'c pExpr = | PEc of 'c @@ -239,16 +241,16 @@ type 'c pExpr = val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 - pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol + -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 - pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol + -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol type ('tA, 'tX, 'aA, 'aF) gFormula = | TT @@ -284,56 +286,106 @@ val cnf_tt : ('a1, 'a2) cnf val cnf_ff : ('a1, 'a2) cnf val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> ('a1, - 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> ('a1, 'a2) + clause option val or_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) clause -> ('a1, 'a2) clause option +val xor_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf + val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> - ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula +val is_cnf_tt : ('a1, 'a2) cnf -> bool + +val is_cnf_ff : ('a1, 'a2) cnf -> bool + +val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf + +val or_cnf_opt : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf + val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> - 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 + -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val radd_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> - (('a1, 'a2) clause, 'a2 list) sum + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> (('a1, + 'a2) clause, 'a2 list) sum val ror_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause -> (('a1, 'a2) clause, 'a2 list) sum +val xror_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> + ('a1, 'a2) clause list * 'a2 list + val ror_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause - list -> ('a1, 'a2) clause list * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> + ('a1, 'a2) clause list * 'a2 list val ror_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list list -> ('a1, 'a2) - clause list -> ('a1, 'a2) cnf * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> ('a1, 'a2) clause + list -> ('a1, 'a2) cnf * 'a2 list + +val ror_cnf_opt : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf * 'a2 list + +val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 list val rxcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> - 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 - list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 + -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list + +type ('term, 'annot, 'tX) to_constrT = { mkTT : 'tX; mkFF : 'tX; + mkA : ('term -> 'annot -> 'tX); + mkCj : ('tX -> 'tX -> 'tX); mkD : ('tX -> 'tX -> 'tX); + mkI : ('tX -> 'tX -> 'tX); mkN : ('tX -> 'tX) } + +val aformula : ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 + +val is_X : ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option + +val abs_and : + ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula + -> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula + +val abs_or : + ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula + -> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula + +val mk_arrow : + 'a4 option -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula + +val abst_form : + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, + 'a3, 'a2, 'a4) gFormula val cnf_checker : (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> - 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, 'a3, unit0) - gFormula -> 'a4 list -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 + -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, 'a3, unit0) gFormula -> + 'a4 list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool @@ -367,27 +419,27 @@ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 - polC -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC + -> 'a1 nFormula -> 'a1 nFormula option val nformula_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> - 'a1 nFormula option + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 + nFormula option val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 - -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> + 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 - -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> + 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool type op2 = | OpEq @@ -400,31 +452,38 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol val psub0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 pol -> 'a1 pol -> 'a1 pol -val padd0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list +val popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol -val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf +val normalise : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula + +val xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list + +val xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list + +val cnf_of_list : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a2 -> ('a1 + nFormula, 'a2) cnf -val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list +val cnf_normalise : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, + 'a2) cnf val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, + 'a2) cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr @@ -487,17 +546,21 @@ val padd1 : z pol -> z pol -> z pol val normZ : z pExpr -> z pol -val xnormalise0 : z formula -> z nFormula list +val zunsat : z nFormula -> bool -val normalise : z formula -> 'a1 -> (z nFormula, 'a1) cnf +val zdeduce : z nFormula -> z nFormula -> z nFormula option -val xnegate0 : z formula -> z nFormula list +val xnnormalise : z formula -> z nFormula -val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf +val xnormalise0 : z nFormula -> z nFormula list -val zunsat : z nFormula -> bool +val cnf_of_list0 : 'a1 -> z nFormula list -> (z nFormula * 'a1) list list -val zdeduce : z nFormula -> z nFormula -> z nFormula option +val normalise0 : z formula -> 'a1 -> (z nFormula, 'a1) cnf + +val xnegate0 : z nFormula -> z nFormula list + +val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf val cnfZ : (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list @@ -565,8 +628,8 @@ val bound_var : positive -> z formula val mk_eq_pos : positive -> positive -> positive -> z formula val bound_vars : - (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, 'a1, - 'a2, 'a3) gFormula + (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, 'a1, 'a2, + 'a3) gFormula val bound_problem_fr : (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, 'a1, 'a2, 'a3) diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 537b6175b4..39905f8c52 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -233,6 +233,13 @@ struct | Zpos p -> (positive_big_int p) | Zneg p -> minus_big_int (positive_big_int p) + let z x = + match x with + | Z0 -> 0 + | Zpos p -> index p + | Zneg p -> - (index p) + + let q_to_num {qnum = x ; qden = y} = Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) @@ -420,6 +427,80 @@ let command exe_path args vl = stdout_read; stdout_write; stderr_read; stderr_write]) +(** Hashing utilities *) + +module Hash = + struct + + module Mc = Micromega + + open Hashset.Combine + + let int_of_eq_op1 = Mc.(function + | Equal -> 0 + | NonEqual -> 1 + | Strict -> 2 + | NonStrict -> 3) + + let eq_op1 o1 o2 = int_of_eq_op1 o1 = int_of_eq_op1 o2 + + let hash_op1 h o = combine h (int_of_eq_op1 o) + + + let rec eq_positive p1 p2 = + match p1 , p2 with + | Mc.XH , Mc.XH -> true + | Mc.XI p1 , Mc.XI p2 -> eq_positive p1 p2 + | Mc.XO p1 , Mc.XO p2 -> eq_positive p1 p2 + | _ , _ -> false + + let eq_z z1 z2 = + match z1 , z2 with + | Mc.Z0 , Mc.Z0 -> true + | Mc.Zpos p1, Mc.Zpos p2 + | Mc.Zneg p1, Mc.Zneg p2 -> eq_positive p1 p2 + | _ , _ -> false + + let eq_q {Mc.qnum = qn1 ; Mc.qden = qd1} {Mc.qnum = qn2 ; Mc.qden = qd2} = + eq_z qn1 qn2 && eq_positive qd1 qd2 + + let rec eq_pol eq p1 p2 = + match p1 , p2 with + | Mc.Pc c1 , Mc.Pc c2 -> eq c1 c2 + | Mc.Pinj(i1,p1) , Mc.Pinj(i2,p2) -> eq_positive i1 i2 && eq_pol eq p1 p2 + | Mc.PX(p1,i1,p1') , Mc.PX(p2,i2,p2') -> + eq_pol eq p1 p2 && eq_positive i1 i2 && eq_pol eq p1' p2' + | _ , _ -> false + + + let eq_pair eq1 eq2 (x1,y1) (x2,y2) = + eq1 x1 x2 && eq2 y1 y2 + + + let hash_pol helt = + let rec hash acc = function + | Mc.Pc c -> helt (combine acc 1) c + | Mc.Pinj(p,c) -> hash (combine (combine acc 1) (CoqToCaml.index p)) c + | Mc.PX(p1,i,p2) -> hash (hash (combine (combine acc 2) (CoqToCaml.index i)) p1) p2 in + hash + + + let hash_pair h1 h2 h (e1,e2) = + h2 (h1 h e1) e2 + + let hash_elt f h e = combine h (f e) + + let hash_string h (e:string) = hash_elt Hashtbl.hash h e + + let hash_z = hash_elt CoqToCaml.z + + let hash_q = hash_elt (fun q -> Hashtbl.hash (CoqToCaml.q_to_num q)) + + end + + + + (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index 8dbdea39e2..9692bc631b 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -67,14 +67,46 @@ end module CoqToCaml : sig val z_big_int : Micromega.z -> Big_int.big_int - val q_to_num : Micromega.q -> Num.num - val positive : Micromega.positive -> int - val n : Micromega.n -> int - val nat : Micromega.nat -> int - val index : Micromega.positive -> int + val z : Micromega.z -> int + val q_to_num : Micromega.q -> Num.num + val positive : Micromega.positive -> int + val n : Micromega.n -> int + val nat : Micromega.nat -> int + val index : Micromega.positive -> int end +module Hash : sig + + val eq_op1 : Micromega.op1 -> Micromega.op1 -> bool + + val eq_positive : Micromega.positive -> Micromega.positive -> bool + + val eq_z : Micromega.z -> Micromega.z -> bool + + val eq_q : Micromega.q -> Micromega.q -> bool + + val eq_pol : ('a -> 'a -> bool) -> 'a Micromega.pol -> 'a Micromega.pol -> bool + + val eq_pair : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> 'a * 'b -> 'a * 'b -> bool + + val hash_op1 : int -> Micromega.op1 -> int + + val hash_pol : (int -> 'a -> int) -> int -> 'a Micromega.pol -> int + + val hash_pair : (int -> 'a -> int) -> (int -> 'b -> int) -> int -> 'a * 'b -> int + + val hash_z : int -> Micromega.z -> int + + val hash_q : int -> Micromega.q -> int + + val hash_string : int -> string -> int + + val hash_elt : ('a -> int) -> int -> 'a -> int + +end + + val ppcm : Big_int.big_int -> Big_int.big_int -> Big_int.big_int val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 5829292a0c..14e2e40846 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -16,25 +16,19 @@ module type PHashtable = sig + (* see documentation in [persistent_cache.mli] *) type 'a t type key val open_in : string -> 'a t - (** [open_in f] rebuilds a table from the records stored in file [f]. - As marshaling is not type-safe, it might segfault. - *) val find : 'a t -> key -> 'a - (** find has the specification of Hashtable.find *) val add : 'a t -> key -> 'a -> unit - (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. - (and writes the binding to the file associated with [tbl].) - If [key] is already bound, raises KeyAlreadyBound *) val memo : string -> (key -> 'a) -> (key -> 'a) - (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. - Note that the cache will only be loaded when the function is used for the first time *) + + val memo_cond : string -> (key -> bool) -> (key -> 'a) -> (key -> 'a) end @@ -133,7 +127,7 @@ let open_in f = match read_key_elem inch with | None -> () | Some (key,elem) -> - Table.replace htbl key elem ; + Table.add htbl key elem ; xload () in try (* Locking of the (whole) file while reading *) @@ -170,7 +164,7 @@ let add t k e = else let fd = descr_of_out_channel outch in begin - Table.replace tbl k e ; + Table.add tbl k e ; do_under_lock Write fd (fun _ -> Marshal.to_channel outch (k,e) [Marshal.No_sharing] ; @@ -200,6 +194,24 @@ let memo cache f = add tbl x res ; res +let memo_cond cache cond f = + let tbl = lazy (try Some (open_in cache) with _ -> None) in + fun x -> + match Lazy.force tbl with + | None -> f x + | Some tbl -> + if cond x + then + begin + try find tbl x + with Not_found -> + let res = f x in + add tbl x res ; + res + end + else f x + + end diff --git a/plugins/micromega/persistent_cache.mli b/plugins/micromega/persistent_cache.mli index 4248407221..cb14d73972 100644 --- a/plugins/micromega/persistent_cache.mli +++ b/plugins/micromega/persistent_cache.mli @@ -32,6 +32,10 @@ module type PHashtable = (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. Note that the cache will only be loaded when the function is used for the first time *) + val memo_cond : string -> (key -> bool) -> (key -> 'a) -> (key -> 'a) + (** [memo cache cond f] only use the cache if [cond k] holds for the key [k]. *) + + end module PHashtable(Key:HashedType) : PHashtable with type key = Key.t diff --git a/plugins/micromega/plugin_base.dune b/plugins/micromega/plugin_base.dune index c2d396f0f9..4153d06161 100644 --- a/plugins/micromega/plugin_base.dune +++ b/plugins/micromega/plugin_base.dune @@ -2,7 +2,7 @@ (name micromega_plugin) (public_name coq.plugins.micromega) ; be careful not to link the executable to the plugin! - (modules (:standard \ csdpcert)) + (modules (:standard \ csdpcert g_zify zify)) (synopsis "Coq's micromega plugin") (libraries num coq.plugins.ltac)) @@ -13,3 +13,10 @@ (modules csdpcert) (flags :standard -open Micromega_plugin) (libraries coq.plugins.micromega)) + +(library + (name zify_plugin) + (public_name coq.plugins.zify) + (modules g_zify zify) + (synopsis "Coq's zify plugin") + (libraries coq.plugins.ltac)) diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml new file mode 100644 index 0000000000..be6037ccdb --- /dev/null +++ b/plugins/micromega/zify.ml @@ -0,0 +1,1117 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Constr +open Names +open Pp +open Lazy + +(** [get_type_of] performs beta reduction ; + Is it ok for Retyping.get_type_of (Zpower_nat n q) to return (fun _ : nat => Z) q ? *) +let get_type_of env evd e = + Tacred.cbv_beta env evd (Retyping.get_type_of env evd e) + +(** [unsafe_to_constr c] returns a [Constr.t] without considering an evar_map. + This is useful for calling Constr.hash *) +let unsafe_to_constr = EConstr.Unsafe.to_constr + +let pr_constr env evd e = Printer.pr_econstr_env env evd e + +(** [get_arrow_typ evd t] returns [t1;.tn] such that t = t1 -> .. -> tn.ci_npar + (only syntactic matching) + *) +let rec get_arrow_typ evd t = + match EConstr.kind evd t with + | Prod (a, p1, p2) (*when a.Context.binder_name = Names.Anonymous*) -> + p1 :: get_arrow_typ evd p2 + | _ -> [t] + +(** [get_binary_arrow t] return t' such that t = t' -> t' -> t' *) +let get_binary_arrow evd t = + let l = get_arrow_typ evd t in + match l with + | [] -> assert false + | [t1; t2; t3] -> Some (t1, t2, t3) + | _ -> None + +(** [get_unary_arrow t] return t' such that t = t' -> t' *) +let get_unary_arrow evd t = + let l = get_arrow_typ evd t in + match l with [] -> assert false | [t1; t2] -> Some (t1, t2) | _ -> None + +(** [HConstr] is a map indexed by EConstr.t. + It should only be used using closed terms. + *) +module HConstr = struct + module M = Map.Make (struct + type t = EConstr.t + + let compare c c' = + Constr.compare (unsafe_to_constr c) (unsafe_to_constr c') + end) + + let lfind h m = try M.find h m with Not_found -> [] + + let add h e m = + let l = lfind h m in + M.add h (e :: l) m + + let empty = M.empty + + let find h m = match lfind h m with e :: _ -> e | [] -> raise Not_found + + let find_all = lfind + + let fold f m acc = + M.fold (fun k l acc -> List.fold_left (fun acc e -> f k e acc) acc l) m acc + + let iter = M.iter + +end + +(** [get_projections_from_constant (evd,c) ] + returns an array of constr [| a1,.. an|] such that [c] is defined as + Definition c := mk a1 .. an with mk a constructor. + ai is therefore either a type parameter or a projection. + *) +let get_projections_from_constant (evd, i) = + match Constr.kind (unsafe_to_constr i) with + | Constr.Const (c, u) -> + (match Environ.constant_opt_value_in (Global.env ()) (c,u) with + | None -> failwith "Add Injection requires a constant (with a body)" + | Some c -> ( + match EConstr.kind evd (EConstr.of_constr c) with + | App (c, a) -> Some a + | _ -> None )) + | _ -> None + + +(** An instance of type, say T, is registered into a hashtable, say TableT. *) + +type 'a decl = + { decl: EConstr.t + ; (* Registered type instance *) + deriv: 'a + (* Projections of insterest *) } + +(* Different type of declarations *) +type decl_kind = + | PropOp + | InjTyp + | BinRel + | BinOp + | UnOp + | CstOp + | Saturate + +let string_of_decl = function + | PropOp -> "PropOp" + | InjTyp -> "InjTyp" + | BinRel -> "BinRel" + | BinOp -> "BinOp" + | UnOp -> "UnOp" + | CstOp -> "CstOp" + | Saturate -> "Saturate" + + + + + +module type Elt = sig + type elt + + val name : decl_kind + (** [name] of the table *) + + val get_key : int + (** [get_key] is the type-index used as key for the instance *) + + val mk_elt : Evd.evar_map -> EConstr.t -> EConstr.t array -> elt + (** [mk_elt evd i [a0,..,an] returns the element of the table + built from the type-instance i and the arguments (type indexes and projections) + of the type-class constructor. *) + + val reduce_term : Evd.evar_map -> EConstr.t -> EConstr.t + (** [reduce_term evd t] normalises [t] in a table dependent way. *) + +end + +module type S = sig + val register : Constrexpr.constr_expr -> unit + + val print : unit -> unit +end + +let not_registered = Summary.ref ~name:"zify_to_register" [] + +module MakeTable (E : Elt) = struct + (** Given a term [c] and its arguments ai, + we construct a HConstr.t table that is + indexed by ai for i = E.get_key. + The elements of the table are built using E.mk_elt c [|a0,..,an|] + *) + + let make_elt (evd, i) = + match get_projections_from_constant (evd, i) with + | None -> + let env = Global.env () in + let t = string_of_ppcmds (pr_constr env evd i) in + failwith ("Cannot register term " ^ t) + | Some a -> E.mk_elt evd i a + + let table = Summary.ref ~name:("zify_" ^ string_of_decl E.name) HConstr.empty + + let register_constr env evd c = + let c = EConstr.of_constr c in + let t = get_type_of env evd c in + match EConstr.kind evd t with + | App (intyp, args) -> + let styp = E.reduce_term evd args.(E.get_key) in + let elt = {decl= c; deriv= make_elt (evd, c)} in + table := HConstr.add styp elt !table + | _ -> failwith "Can only register terms of type [F X1 .. Xn]" + + let get evd c = + let c' = E.reduce_term evd c in + HConstr.find c' !table + + let get_all evd c = + let c' = E.reduce_term evd c in + HConstr.find_all c' !table + + let fold_declared_const f evd acc = + HConstr.fold + (fun _ e acc -> f (fst (EConstr.destConst evd e.decl)) acc) + !table acc + + exception FoundNorm of EConstr.t + + let can_unify evd k t = + try + let _ = Unification.w_unify (Global.env ()) evd Reduction.CONV k t in + true ; + with _ -> false + + let unify_with_key evd t = + try + HConstr.iter + (fun k _ -> + if can_unify evd k t + then raise (FoundNorm k) + else ()) !table ; t + with FoundNorm k -> k + + + let pp_keys () = + let env = Global.env () in + let evd = Evd.from_env env in + HConstr.fold + (fun k _ acc -> Pp.(pr_constr env evd k ++ str " " ++ acc)) + !table (Pp.str "") + + let register_obj : Constr.constr -> Libobject.obj = + let cache_constr (_, c) = + not_registered := (E.name,c)::!not_registered + in + let subst_constr (subst, c) = Mod_subst.subst_mps subst c in + Libobject.declare_object + @@ Libobject.superglobal_object_nodischarge + ("register-zify-" ^ string_of_decl E.name) + ~cache:cache_constr ~subst:(Some subst_constr) + + (** [register c] is called from the VERNACULAR ADD [name] constr(t). + The term [c] is interpreted and + registered as a [superglobal_object_nodischarge]. + TODO: pre-compute [get_type_of] - [cache_constr] is using another environment. + *) + let register c = + let env = Global.env () in + let evd = Evd.from_env env in + let evd, c = Constrintern.interp_open_constr env evd c in + let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in + () + + let print () = Feedback.msg_notice (pp_keys ()) +end + +(** Each type-class gives rise to a different table. + They only differ on how projections are extracted. *) +module InjElt = struct + type elt = + { isid: bool + ; (* S = T -> inj = fun x -> x*) + source: EConstr.t + ; (* S *) + target: EConstr.t + ; (* T *) + (* projections *) + inj: EConstr.t + ; (* S -> T *) + pred: EConstr.t + ; (* T -> Prop *) + cstr: EConstr.t option + (* forall x, pred (inj x) *) } + + let name = InjTyp + + let mk_elt evd i (a : EConstr.t array) = + let isid = EConstr.eq_constr evd a.(0) a.(1) in + { isid + ; source= a.(0) + ; target= a.(1) + ; inj= a.(2) + ; pred= a.(3) + ; cstr= (if isid then None else Some a.(4)) } + + let get_key = 0 + + let reduce_term evd t = t + +end + +module InjTable = MakeTable (InjElt) + + +let coq_eq = lazy ( EConstr.of_constr + (UnivGen.constr_of_monomorphic_global + (Coqlib.lib_ref ("core.eq.type")))) + +let reduce_type evd ty = + try ignore (InjTable.get evd ty) ; ty + with Not_found -> + (* Maybe it unifies *) + InjTable.unify_with_key evd ty + +module EBinOp = struct + type elt = + { (* Op : source1 -> source2 -> source3 *) + source1: EConstr.t + ; source2: EConstr.t + ; source3: EConstr.t + ; target: EConstr.t + ; inj1: EConstr.t + ; (* InjTyp source1 target *) + inj2: EConstr.t + ; (* InjTyp source2 target *) + inj3: EConstr.t + ; (* InjTyp source3 target *) + tbop: EConstr.t + (* TBOpInj *) } + + let name = BinOp + + let mk_elt evd i a = + { source1= a.(0) + ; source2= a.(1) + ; source3= a.(2) + ; target= a.(3) + ; inj1= a.(5) + ; inj2= a.(6) + ; inj3= a.(7) + ; tbop= a.(9) } + + let get_key = 4 + + let reduce_term evd t = t + +end + +module ECstOp = struct + type elt = {source: EConstr.t; target: EConstr.t; inj: EConstr.t} + + let name = CstOp + + let mk_elt evd i a = {source= a.(0); target= a.(1); inj= a.(3)} + + let get_key = 2 + + let reduce_term evd t = t + +end + + +module EUnOp = struct + type elt = + { source1: EConstr.t + ; source2: EConstr.t + ; target: EConstr.t + ; inj1_t: EConstr.t + ; inj2_t: EConstr.t + ; unop: EConstr.t } + + let name = UnOp + + let mk_elt evd i a = + { source1= a.(0) + ; source2= a.(1) + ; target= a.(2) + ; inj1_t= a.(4) + ; inj2_t= a.(5) + ; unop= a.(6) } + + let get_key = 3 + + let reduce_term evd t = t + +end + +open EUnOp + +module EBinRel = struct + type elt = + {source: EConstr.t; target: EConstr.t; inj: EConstr.t; brel: EConstr.t} + + let name = BinRel + + let mk_elt evd i a = {source= a.(0); target= a.(1); inj= a.(3); brel= a.(4)} + + let get_key = 2 + + + (** [reduce_term evd t] if t = @eq ty normalises ty to a declared type e.g Z if it exists. *) + let reduce_term evd t = + match EConstr.kind evd t with + | App(c,a) -> if EConstr.eq_constr evd (Lazy.force coq_eq) c + then + match a with + | [| ty |] -> EConstr.mkApp(c,[| reduce_type evd ty|]) + | _ -> t + else t + | _ -> t + +end + +module EPropOp = struct + type elt = EConstr.t + + let name = PropOp + + let mk_elt evd i a = i + + let get_key = 0 + + let reduce_term evd t = t + +end + +module ESat = struct + type elt = {parg1: EConstr.t; parg2: EConstr.t; satOK: EConstr.t} + + let name = Saturate + + let mk_elt evd i a = {parg1= a.(2); parg2= a.(3); satOK= a.(5)} + + let get_key = 1 + + let reduce_term evd t = t + +end + + + +module BinOp = MakeTable (EBinOp) +module UnOp = MakeTable (EUnOp) +module CstOp = MakeTable (ECstOp) +module BinRel = MakeTable (EBinRel) +module PropOp = MakeTable (EPropOp) +module Saturate = MakeTable (ESat) + + + + +(** The module [Spec] is used to register + the instances of [BinOpSpec], [UnOpSpec]. + They are not indexed and stored in a list. *) + +module Spec = struct + let table = Summary.ref ~name:"zify_Spec" [] + + let register_obj : Constr.constr -> Libobject.obj = + let cache_constr (_, c) = table := EConstr.of_constr c :: !table in + let subst_constr (subst, c) = Mod_subst.subst_mps subst c in + Libobject.declare_object + @@ Libobject.superglobal_object_nodischarge "register-zify-Spec" + ~cache:cache_constr ~subst:(Some subst_constr) + + let register c = + let env = Global.env () in + let evd = Evd.from_env env in + let _, c = Constrintern.interp_open_constr env evd c in + let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in + () + + let get () = !table + + let print () = + let env = Global.env () in + let evd = Evd.from_env env in + let constr_of_spec c = + let t = get_type_of env evd c in + match EConstr.kind evd t with + | App (intyp, args) -> pr_constr env evd args.(2) + | _ -> Pp.str "" + in + let l = + List.fold_left + (fun acc c -> Pp.(constr_of_spec c ++ str " " ++ acc)) + (Pp.str "") !table + in + Feedback.msg_notice l +end + + +let register_decl = function + | PropOp -> PropOp.register_constr + | InjTyp -> InjTable.register_constr + | BinRel -> BinRel.register_constr + | BinOp -> BinOp.register_constr + | UnOp -> UnOp.register_constr + | CstOp -> CstOp.register_constr + | Saturate -> Saturate.register_constr + + +let process_decl (d,c) = + let env = Global.env () in + let evd = Evd.from_env env in + register_decl d env evd c + +let process_all_decl () = + List.iter process_decl !not_registered ; + not_registered := [] + + +let unfold_decl evd = + let f cst acc = cst :: acc in + let acc = InjTable.fold_declared_const f evd [] in + let acc = BinOp.fold_declared_const f evd acc in + let acc = UnOp.fold_declared_const f evd acc in + let acc = CstOp.fold_declared_const f evd acc in + let acc = BinRel.fold_declared_const f evd acc in + let acc = PropOp.fold_declared_const f evd acc in + acc + +open InjElt + +(** Get constr of lemma and projections in ZifyClasses. *) + +let zify str = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global + (Coqlib.lib_ref ("ZifyClasses." ^ str))) + +let locate_const str = + let rf = "ZifyClasses." ^ str in + match Coqlib.lib_ref rf with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly Pp.(str rf ++ str " should be a constant") + +(* The following [constr] are necessary for constructing the proof terms *) +let mkapp2 = lazy (zify "mkapp2") + +let mkapp = lazy (zify "mkapp") + +let mkapp0 = lazy (zify "mkapp0") + +let mkdp = lazy (zify "mkinjterm") + +let eq_refl = lazy (zify "eq_refl") + +let mkrel = lazy (zify "mkrel") + +let mkprop_op = lazy (zify "mkprop_op") + +let mkuprop_op = lazy (zify "mkuprop_op") + +let mkdpP = lazy (zify "mkinjprop") + +let iff_refl = lazy (zify "iff_refl") + +let q = lazy (zify "target_prop") + +let ieq = lazy (zify "injprop_ok") + +let iff = lazy (zify "iff") + + + +(* A super-set of the previous are needed to unfold the generated proof terms. *) + +let to_unfold = + lazy + (List.map locate_const + [ "source_prop" + ; "target_prop" + ; "uop_iff" + ; "op_iff" + ; "mkuprop_op" + ; "TUOp" + ; "inj_ok" + ; "TRInj" + ; "inj" + ; "source" + ; "injprop_ok" + ; "TR" + ; "TBOp" + ; "TCst" + ; "target" + ; "mkrel" + ; "mkapp2" + ; "mkapp" + ; "mkapp0" + ; "mkprop_op" ]) + +(** Module [CstrTable] records terms [x] injected into [inj x] + together with the corresponding type constraint. + The terms are stored by side-effect during the traversal + of the goal. It must therefore be cleared before calling + the main tactic. + *) + +module CstrTable = struct + module HConstr = Hashtbl.Make (struct + type t = EConstr.t + + let hash c = Constr.hash (unsafe_to_constr c) + + let equal c c' = Constr.equal (unsafe_to_constr c) (unsafe_to_constr c') + end) + + let table : EConstr.t HConstr.t = HConstr.create 10 + + let register evd t (i : EConstr.t) = HConstr.replace table t i + + let get () = + let l = HConstr.fold (fun k i acc -> (k, i) :: acc) table [] in + HConstr.clear table ; l + + (** [gen_cstr table] asserts (cstr k) for each element of the table (k,cstr). + NB: the constraint is only asserted if it does not already exist in the context. + *) + let gen_cstr table = + Proofview.Goal.enter (fun gl -> + let evd = Tacmach.New.project gl in + (* Build the table of existing hypotheses *) + let has_hyp = + let hyps_table = HConstr.create 20 in + List.iter + (fun (_, (t : EConstr.types)) -> HConstr.replace hyps_table t ()) + (Tacmach.New.pf_hyps_types gl) ; + fun c -> HConstr.mem hyps_table c + in + (* Add the constraint (cstr k) if it is not already present *) + let gen k cstr = + Proofview.Goal.enter (fun gl -> + let env = Tacmach.New.pf_env gl in + let term = EConstr.mkApp (cstr, [|k|]) in + let types = get_type_of env evd term in + if has_hyp types then Tacticals.New.tclIDTAC + else + let n = + Tactics.fresh_id_in_env Id.Set.empty + (Names.Id.of_string "cstr") + env + in + Tactics.pose_proof (Names.Name n) term ) + in + List.fold_left + (fun acc (k, i) -> Tacticals.New.tclTHEN (gen k i) acc) + Tacticals.New.tclIDTAC table ) +end + +let mkvar red evd inj v = + ( if not red then + match inj.cstr with None -> () | Some ctr -> CstrTable.register evd v ctr + ) ; + let iv = EConstr.mkApp (inj.inj, [|v|]) in + let iv = if red then Tacred.compute (Global.env ()) evd iv else iv in + EConstr.mkApp + ( force mkdp + , [| inj.source + ; inj.target + ; inj.inj + ; v + ; iv + ; EConstr.mkApp (force eq_refl, [|inj.target; iv|]) |] ) + +type texpr = + | Var of InjElt.elt * EConstr.t + (** Var is a term that cannot be injected further *) + | Constant of InjElt.elt * EConstr.t + (** Constant is a term that is solely built from constructors *) + | Injterm of EConstr.t + (** Injected is an injected term represented by a term of type [injterm] *) + +let is_constant = function Constant _ -> true | _ -> false + +let constr_of_texpr = function + | Constant (i, e) | Var (i, e) -> if i.isid then Some e else None + | _ -> None + +let inj_term_of_texpr evd = function + | Injterm e -> e + | Var (inj, e) -> mkvar false evd inj e + | Constant (inj, e) -> mkvar true evd inj e + +let mkapp2_id evd i (* InjTyp S3 T *) + inj (* deriv i *) + t (* S1 -> S2 -> S3 *) + b (* Binop S1 S2 S3 t ... *) + dbop (* deriv b *) e1 e2 = + let default () = + let e1' = inj_term_of_texpr evd e1 in + let e2' = inj_term_of_texpr evd e2 in + EBinOp.( + Injterm + (EConstr.mkApp + ( force mkapp2 + , [| dbop.source1 + ; dbop.source2 + ; dbop.source3 + ; dbop.target + ; t + ; dbop.inj1 + ; dbop.inj2 + ; dbop.inj3 + ; b + ; e1' + ; e2' |] ))) + in + if not inj.isid then default () + else + match (e1, e2) with + | Constant (_, e1), Constant (_, e2) + |Var (_, e1), Var (_, e2) + |Constant (_, e1), Var (_, e2) + |Var (_, e1), Constant (_, e2) -> + Var (inj, EConstr.mkApp (t, [|e1; e2|])) + | _, _ -> default () + +let mkapp_id evd i inj (unop, u) f e1 = + if EConstr.eq_constr evd u.unop f then + (* Injection does nothing *) + match e1 with + | Constant (_, e) | Var (_, e) -> Var (inj, EConstr.mkApp (f, [|e|])) + | Injterm e1 -> + Injterm + (EConstr.mkApp + ( force mkapp + , [| u.source1 + ; u.source2 + ; u.target + ; f + ; u.inj1_t + ; u.inj2_t + ; unop + ; e1 |] )) + else + let e1 = inj_term_of_texpr evd e1 in + Injterm + (EConstr.mkApp + ( force mkapp + , [|u.source1; u.source2; u.target; f; u.inj1_t; u.inj2_t; unop; e1|] + )) + +type typed_constr = {constr: EConstr.t; typ: EConstr.t} + +type op = + | Unop of + { unop: EConstr.t + ; (* unop : typ unop_arg -> unop_typ *) + unop_typ: EConstr.t + ; unop_arg: typed_constr } + | Binop of + { binop: EConstr.t + ; (* binop : typ binop_arg1 -> typ binop_arg2 -> binop_typ *) + binop_typ: EConstr.t + ; binop_arg1: typed_constr + ; binop_arg2: typed_constr } + + +let rec trans_expr env evd e = + (* Get the injection *) + let {decl= i; deriv= inj} = InjTable.get evd e.typ in + let e = e.constr in + if EConstr.isConstruct evd e then Constant (inj, e) (* Evaluate later *) + else + try + (* The term [e] might be a registered constant *) + let {decl= c} = CstOp.get evd e in + Injterm + (EConstr.mkApp (force mkapp0, [|inj.source; inj.target; e; i; c|])) + with Not_found -> ( + (* Let decompose the term *) + match EConstr.kind evd e with + | App (t, a) -> ( + try + match Array.length a with + | 1 -> + let {decl= unop; deriv= u} = UnOp.get evd t in + let a' = trans_expr env evd {constr= a.(0); typ= u.source1} in + if is_constant a' && EConstr.isConstruct evd t then + Constant (inj, e) + else mkapp_id evd i inj (unop, u) t a' + | 2 -> + let {decl= bop; deriv= b} = BinOp.get evd t in + let a0 = + trans_expr env evd {constr= a.(0); typ= b.EBinOp.source1} + in + let a1 = + trans_expr env evd {constr= a.(1); typ= b.EBinOp.source2} + in + if is_constant a0 && is_constant a1 && EConstr.isConstruct evd t + then Constant (inj, e) + else mkapp2_id evd i inj t bop b a0 a1 + | _ -> Var (inj, e) + with Not_found -> Var (inj, e) ) + | _ -> Var (inj, e) ) + +let trans_expr env evd e = + try trans_expr env evd e with Not_found -> + raise + (CErrors.user_err + ( Pp.str "Missing injection for type " + ++ Printer.pr_leconstr_env env evd e.typ )) + +let is_prop env sigma term = + let sort = Retyping.get_sort_of env sigma term in + Sorts.is_prop sort + +let get_rel env evd e = + let is_arrow a p1 p2 = + is_prop env evd p1 && is_prop (EConstr.push_rel (Context.Rel.Declaration.LocalAssum(a,p1)) env) evd p2 + && (a.Context.binder_name = Names.Anonymous || EConstr.Vars.noccurn evd 1 p2) + in + match EConstr.kind evd e with + | Prod (a, p1, p2) when is_arrow a p1 p2 -> + (* X -> Y becomes (fun x y => x -> y) x y *) + let name x = + Context.make_annot (Name.mk_name (Names.Id.of_string x)) Sorts.Relevant + in + let arrow = + EConstr.mkLambda + ( name "x" + , EConstr.mkProp + , EConstr.mkLambda + ( name "y" + , EConstr.mkProp + , EConstr.mkProd + ( Context.make_annot Names.Anonymous Sorts.Relevant + , EConstr.mkRel 2 + , EConstr.mkRel 2 ) ) ) + in + Binop + { binop= arrow + ; binop_typ= EConstr.mkProp + ; binop_arg1= {constr= p1; typ= EConstr.mkProp} + ; binop_arg2= {constr= p2; typ= EConstr.mkProp} } + | App (c, a) -> + let len = Array.length a in + if len >= 2 then + let c, a1, a2 = + if len = 2 then (c, a.(0), a.(1)) + else if len > 2 then + ( EConstr.mkApp (c, Array.sub a 0 (len - 2)) + , a.(len - 2) + , a.(len - 1) ) + else raise Not_found + in + let typ = get_type_of env evd c in + match get_binary_arrow evd typ with + | None -> raise Not_found + | Some (t1, t2, t3) -> + Binop + { binop= c + ; binop_typ= t3 + ; binop_arg1= {constr= a1; typ= t1} + ; binop_arg2= {constr= a2; typ= t2} } + else if len = 1 then + let typ = get_type_of env evd c in + match get_unary_arrow evd typ with + | None -> raise Not_found + | Some (t1, t2) -> + Unop {unop= c; unop_typ= t2; unop_arg= {constr= a.(0); typ= t1}} + else raise Not_found + | _ -> raise Not_found + +let get_rel env evd e = try Some (get_rel env evd e) with Not_found -> None + +type tprop = + | TProp of EConstr.t (** Transformed proposition *) + | IProp of EConstr.t (** Identical proposition *) + +let mk_iprop e = + EConstr.mkApp (force mkdpP, [|e; e; EConstr.mkApp (force iff_refl, [|e|])|]) + +let inj_prop_of_tprop = function TProp p -> p | IProp e -> mk_iprop e + +let rec trans_prop env evd e = + match get_rel env evd e with + | None -> IProp e + | Some (Binop {binop= r; binop_typ= t1; binop_arg1= a1; binop_arg2= a2}) -> + assert (EConstr.eq_constr evd EConstr.mkProp t1) ; + if EConstr.eq_constr evd a1.typ a2.typ then + (* Arguments have the same type *) + if + EConstr.eq_constr evd EConstr.mkProp t1 + && EConstr.eq_constr evd EConstr.mkProp a1.typ + then + (* Prop -> Prop -> Prop *) + try + let {decl= rop} = PropOp.get evd r in + let t1 = trans_prop env evd a1.constr in + let t2 = trans_prop env evd a2.constr in + match (t1, t2) with + | IProp _, IProp _ -> IProp e + | _, _ -> + let t1 = inj_prop_of_tprop t1 in + let t2 = inj_prop_of_tprop t2 in + TProp (EConstr.mkApp (force mkprop_op, [|r; rop; t1; t2|])) + with Not_found -> IProp e + else + (* A -> A -> Prop *) + try + let {decl= br; deriv= rop} = BinRel.get evd r in + let a1 = trans_expr env evd {a1 with typ = rop.EBinRel.source} in + let a2 = trans_expr env evd {a2 with typ = rop.EBinRel.source} in + if EConstr.eq_constr evd r rop.EBinRel.brel then + match (constr_of_texpr a1, constr_of_texpr a2) with + | Some e1, Some e2 -> IProp (EConstr.mkApp (r, [|e1; e2|])) + | _, _ -> + let a1 = inj_term_of_texpr evd a1 in + let a2 = inj_term_of_texpr evd a2 in + TProp + (EConstr.mkApp + ( force mkrel + , [| rop.EBinRel.source + ; rop.EBinRel.target + ; r + ; rop.EBinRel.inj + ; br + ; a1 + ; a2 |] )) + else + let a1 = inj_term_of_texpr evd a1 in + let a2 = inj_term_of_texpr evd a2 in + TProp + (EConstr.mkApp + ( force mkrel + , [| rop.EBinRel.source + ; rop.EBinRel.target + ; r + ; rop.EBinRel.inj + ; br + ; a1 + ; a2 |] )) + with Not_found -> IProp e + else IProp e + | Some (Unop {unop; unop_typ; unop_arg}) -> + if + EConstr.eq_constr evd EConstr.mkProp unop_typ + && EConstr.eq_constr evd EConstr.mkProp unop_arg.typ + then + try + let {decl= rop} = PropOp.get evd unop in + let t1 = trans_prop env evd unop_arg.constr in + match t1 with + | IProp _ -> IProp e + | _ -> + let t1 = inj_prop_of_tprop t1 in + TProp (EConstr.mkApp (force mkuprop_op, [|unop; rop; t1|])) + with Not_found -> IProp e + else IProp e + +let unfold n env evd c = + let cbv l = + CClosure.RedFlags.( + Tacred.cbv_norm_flags + (mkflags + (fBETA :: fMATCH :: fFIX :: fCOFIX :: fZETA :: List.map fCONST l))) + in + let unfold_decl = unfold_decl evd in + (* Unfold the let binding *) + let c = + match n with + | None -> c + | Some n -> + Tacred.unfoldn [(Locus.AllOccurrences, Names.EvalVarRef n)] env evd c + in + (* Reduce the term *) + let c = cbv (force to_unfold @ unfold_decl) env evd c in + c + +let trans_check_prop env evd t = + if is_prop env evd t then + (*let t = Tacred.unfoldn [Locus.AllOccurrences, Names.EvalConstRef coq_not] env evd t in*) + match trans_prop env evd t with IProp e -> None | TProp e -> Some e + else None + +let trans_hyps env evd l = + List.fold_left + (fun acc (h, p) -> + match trans_check_prop env evd p with + | None -> acc + | Some p' -> (h, p, p') :: acc ) + [] (List.rev l) + +(* Only used if a direct rewrite fails *) +let trans_hyp h t = + Tactics.( + Tacticals.New.( + Proofview.Goal.enter (fun gl -> + let env = Tacmach.New.pf_env gl in + let n = + fresh_id_in_env Id.Set.empty (Names.Id.of_string "__zify") env + in + let h' = fresh_id_in_env Id.Set.empty h env in + tclTHENLIST + [ letin_tac None (Names.Name n) t None + Locus.{onhyps= None; concl_occs= NoOccurrences} + ; assert_by (Name.Name h') + (EConstr.mkApp (force q, [|EConstr.mkVar n|])) + (tclTHEN + (Equality.rewriteRL + (EConstr.mkApp (force ieq, [|EConstr.mkVar n|]))) + (exact_check (EConstr.mkVar h))) + ; reduct_in_hyp ~check:true ~reorder:false (unfold (Some n)) + (h', Locus.InHyp) + ; clear [n] + ; (* [clear H] may fail if [h] has dependencies *) + tclTRY (clear [h]) ] ))) + +let is_progress_rewrite evd t rew = + match EConstr.kind evd rew with + | App (c, [|lhs; rhs|]) -> + if EConstr.eq_constr evd (force iff) c then + (* This is a successful rewriting *) + not (EConstr.eq_constr evd lhs rhs) + else + CErrors.anomaly + Pp.( + str "is_progress_rewrite: not a rewrite" + ++ pr_constr (Global.env ()) evd rew) + | _ -> failwith "is_progress_rewrite: not even an application" + +let trans_hyp h t0 t = + Tacticals.New.( + Proofview.Goal.enter (fun gl -> + let env = Tacmach.New.pf_env gl in + let evd = Tacmach.New.project gl in + let t' = unfold None env evd (EConstr.mkApp (force ieq, [|t|])) in + if is_progress_rewrite evd t0 (get_type_of env evd t') then + tclFIRST + [ Equality.general_rewrite_in true Locus.AllOccurrences true false + h t' false + ; trans_hyp h t ] + else tclIDTAC )) + +let trans_concl t = + Tacticals.New.( + Proofview.Goal.enter (fun gl -> + let concl = Tacmach.New.pf_concl gl in + let env = Tacmach.New.pf_env gl in + let evd = Tacmach.New.project gl in + let t' = unfold None env evd (EConstr.mkApp (force ieq, [|t|])) in + if is_progress_rewrite evd concl (get_type_of env evd t') then + Equality.general_rewrite true Locus.AllOccurrences true false t' + else tclIDTAC )) + +let tclTHENOpt e tac tac' = + match e with None -> tac' | Some e' -> Tacticals.New.tclTHEN (tac e') tac' + +let zify_tac = + Proofview.Goal.enter (fun gl -> + Coqlib.check_required_library ["Coq"; "micromega"; "ZifyClasses"] ; + Coqlib.check_required_library ["Coq"; "micromega"; "ZifyInst"] ; + process_all_decl (); + let evd = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in + let concl = trans_check_prop env evd (Tacmach.New.pf_concl gl) in + let hyps = trans_hyps env evd (Tacmach.New.pf_hyps_types gl) in + let l = CstrTable.get () in + tclTHENOpt concl trans_concl + (Tacticals.New.tclTHEN + (Tacticals.New.tclTHENLIST + (List.map (fun (h, p, t) -> trans_hyp h p t) hyps)) + (CstrTable.gen_cstr l)) ) + +let iter_specs tac = + Tacticals.New.tclTHENLIST + (List.fold_right (fun d acc -> tac d :: acc) (Spec.get ()) []) + + +let iter_specs (tac: Ltac_plugin.Tacinterp.Value.t) = + iter_specs (fun c -> Ltac_plugin.Tacinterp.Value.apply tac [Ltac_plugin.Tacinterp.Value.of_constr c]) + +let find_hyp evd t l = + try Some (fst (List.find (fun (h, t') -> EConstr.eq_constr evd t t') l)) + with Not_found -> None + +let sat_constr c d = + Proofview.Goal.enter (fun gl -> + let evd = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in + let hyps = Tacmach.New.pf_hyps_types gl in + match EConstr.kind evd c with + | App (c, args) -> + if Array.length args = 2 then ( + let h1 = + Tacred.cbv_beta env evd + (EConstr.mkApp (d.ESat.parg1, [|args.(0)|])) + in + let h2 = + Tacred.cbv_beta env evd + (EConstr.mkApp (d.ESat.parg2, [|args.(1)|])) + in + match (find_hyp evd h1 hyps, find_hyp evd h2 hyps) with + | Some h1, Some h2 -> + let n = + Tactics.fresh_id_in_env Id.Set.empty + (Names.Id.of_string "__sat") + env + in + let trm = + EConstr.mkApp + ( d.ESat.satOK + , [|args.(0); args.(1); EConstr.mkVar h1; EConstr.mkVar h2|] + ) + in + Tactics.pose_proof (Names.Name n) trm + | _, _ -> Tacticals.New.tclIDTAC ) + else Tacticals.New.tclIDTAC + | _ -> Tacticals.New.tclIDTAC ) + +let saturate = + Proofview.Goal.enter (fun gl -> + let table = CstrTable.HConstr.create 20 in + let concl = Tacmach.New.pf_concl gl in + let hyps = Tacmach.New.pf_hyps_types gl in + let evd = Tacmach.New.project gl in + process_all_decl (); + let rec sat t = + match EConstr.kind evd t with + | App (c, args) -> + sat c ; + Array.iter sat args ; + if Array.length args = 2 then + let ds = Saturate.get_all evd c in + if ds = [] then () + else ( + List.iter (fun x -> CstrTable.HConstr.add table t x.deriv) ds ) + else () + | Prod (a, t1, t2) when a.Context.binder_name = Names.Anonymous -> + sat t1 ; sat t2 + | _ -> () + in + (* Collect all the potential saturation lemma *) + sat concl ; + List.iter (fun (_, t) -> sat t) hyps ; + Tacticals.New.tclTHENLIST + (CstrTable.HConstr.fold (fun c d acc -> sat_constr c d :: acc) table []) + ) diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli new file mode 100644 index 0000000000..f7844f53bc --- /dev/null +++ b/plugins/micromega/zify.mli @@ -0,0 +1,25 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +open Constrexpr + +module type S = sig val register : constr_expr -> unit val print : unit -> unit end + +module InjTable : S +module UnOp : S +module BinOp : S +module CstOp : S +module BinRel : S +module PropOp : S +module Spec : S +module Saturate : S + +val zify_tac : unit Proofview.tactic +val saturate : unit Proofview.tactic +val iter_specs : Ltac_plugin.Tacinterp.Value.t -> unit Proofview.tactic diff --git a/plugins/micromega/zify_plugin.mlpack b/plugins/micromega/zify_plugin.mlpack new file mode 100644 index 0000000000..8d301b53c4 --- /dev/null +++ b/plugins/micromega/zify_plugin.mlpack @@ -0,0 +1,2 @@ +Zify +G_zify diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index acc8214e3e..f5d53cbbf3 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -127,6 +127,8 @@ Module Z. Ltac to_euclidean_division_equations := div_mod_to_equations'; quot_rem_to_equations'; euclidean_division_equations_cleanup. End Z. +Set Warnings "-deprecated-tactic". + (** * zify: the Z-ification tactic *) (* This tactic searches for nat and N and positive elements in the goal and @@ -150,12 +152,14 @@ End Z. (** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *) +#[deprecated( note = "Use 'zify' instead")] Ltac zify_unop_core t thm a := (* Let's introduce the specification theorem for t *) pose proof (thm a); (* Then we replace (t a) everywhere with a fresh variable *) let z := fresh "z" in set (z:=t a) in *; clearbody z. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_unop_var_or_term t thm a := (* If a is a variable, no need for aliasing *) let za := fresh "z" in @@ -163,6 +167,7 @@ Ltac zify_unop_var_or_term t thm a := (* Otherwise, a is a complex term: we alias it. *) (remember a as za; zify_unop_core t thm za). +#[deprecated( note = "Use 'zify' instead")] Ltac zify_unop t thm a := (* If a is a scalar, we can simply reduce the unop. *) (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *) @@ -174,6 +179,7 @@ Ltac zify_unop t thm a := | _ => zify_unop_var_or_term t thm a end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_unop_nored t thm a := (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) let isz := isZcst a in @@ -182,6 +188,7 @@ Ltac zify_unop_nored t thm a := | _ => zify_unop_var_or_term t thm a end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_binop t thm a b:= (* works as zify_unop, except that we should be careful when dealing with b, since it can be equal to a *) @@ -197,6 +204,7 @@ Ltac zify_binop t thm a b:= end) end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_op_1 := match goal with | x := ?t : Z |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x @@ -213,9 +221,6 @@ Ltac zify_op_1 := Ltac zify_op := repeat zify_op_1. - - - (** II) Conversion from nat to Z *) @@ -226,6 +231,7 @@ Ltac hide_Z_of_nat t := change Z.of_nat with Z_of_nat' in z; unfold z in *; clear z. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_nat_rel := match goal with (* I: equalities *) @@ -321,11 +327,9 @@ Ltac zify_nat_op := pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. - - - (* III) conversion from positive to Z *) Definition Zpos' := Zpos. @@ -336,6 +340,7 @@ Ltac hide_Zpos t := change Zpos with Zpos' in z; unfold z in *; clear z. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_positive_rel := match goal with (* I: equalities *) @@ -357,6 +362,7 @@ Ltac zify_positive_rel := | |- context [ (?a >= ?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_positive_op := match goal with (* Z.pow_pos -> Z.pow *) @@ -453,6 +459,7 @@ Ltac zify_positive_op := | |- context [ Zpos ?a ] => pose proof (Pos2Z.is_pos a); hide_Zpos a end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_positive := repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. @@ -469,6 +476,7 @@ Ltac hide_Z_of_N t := change Z.of_N with Z_of_N' in z; unfold z in *; clear z. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_N_rel := match goal with (* I: equalities *) @@ -490,6 +498,7 @@ Ltac zify_N_rel := | |- context [ (?a >= ?b)%N ] => rewrite (N2Z.inj_ge a b) end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_N_op := match goal with (* misc type conversions: nat to positive *) @@ -556,10 +565,35 @@ Ltac zify_N_op := | |- context [ Z.of_N ?a ] => pose proof (N2Z.is_nonneg a); hide_Z_of_N a end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. +(** The complete Z-ification tactic *) +Require Import ZifyClasses ZifyInst. +Require Zify. + + +(** [is_inj T] returns true iff the type T has an injection *) +Ltac is_inj T := + match T with + | _ => let x := constr:(_ : InjTyp T _ ) in true + | _ => false + end. + +(* [elim_let] replaces a let binding (x := e : t) + by an equation (x = e) if t is an injected type *) +Ltac elim_let := + repeat + match goal with + | x := ?t : ?ty |- _ => + let b := is_inj ty in + match b with + | true => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x + end + end. -(** The complete Z-ification tactic *) -Ltac zify := repeat (zify_nat; zify_positive; zify_N); zify_op. +Ltac zify := + intros ; elim_let ; + Zify.zify ; ZifyInst.saturate. diff --git a/plugins/omega/g_omega.mlg b/plugins/omega/g_omega.mlg index bb9bee080a..84964a7bd2 100644 --- a/plugins/omega/g_omega.mlg +++ b/plugins/omega/g_omega.mlg @@ -54,6 +54,7 @@ END TACTIC EXTEND omega' | [ "omega" "with" ne_ident_list(l) ] -> { omega_tactic (List.map Names.Id.to_string l) } -| [ "omega" "with" "*" ] -> { omega_tactic ["nat";"positive";"N";"Z"] } +| [ "omega" "with" "*" ] -> + { Tacticals.New.tclTHEN (eval_tactic "zify") (omega_tactic []) } END diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 0ca39f0404..7e140f4399 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -4,7 +4,6 @@ Locusops Pretype_errors Reductionops Inductiveops -InferCumulativity Arguments_renaming Retyping Vnorm diff --git a/printing/prettyp.ml b/printing/prettyp.ml index fb0b1eca8d..c995887f31 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -38,11 +38,11 @@ type object_pr = { print_constant_with_infos : Opaqueproof.indirect_accessor -> Constant.t -> UnivNames.univ_name_list option -> Pp.t; print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; print_syntactic_def : env -> KerName.t -> Pp.t; - print_module : bool -> ModPath.t -> Pp.t; - print_modtype : ModPath.t -> Pp.t; + print_module : mod_ops:Printmod.mod_ops -> bool -> ModPath.t -> Pp.t; + print_modtype : mod_ops:Printmod.mod_ops -> ModPath.t -> Pp.t; print_named_decl : env -> Evd.evar_map -> Constr.named_declaration -> Pp.t; - print_library_entry : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; - print_context : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; + print_library_entry : mod_ops:Printmod.mod_ops -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; + print_context : mod_ops:Printmod.mod_ops -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } @@ -618,7 +618,7 @@ let gallina_print_syntactic_def env kn = Constrextern.without_specific_symbols [Notation.SynDefRule kn] (pr_glob_constr_env env) c) -let gallina_print_leaf_entry indirect_accessor env sigma with_values ((sp,kn as oname),lobj) = +let gallina_print_leaf_entry ~mod_ops indirect_accessor env sigma with_values ((sp,kn as oname),lobj) = let sep = if with_values then " = " else " : " in match lobj with | AtomicObject o -> @@ -639,17 +639,17 @@ let gallina_print_leaf_entry indirect_accessor env sigma with_values ((sp,kn as end | ModuleObject _ -> let (mp,l) = KerName.repr kn in - Some (print_module with_values (MPdot (mp,l))) + Some (print_module ~mod_ops with_values (MPdot (mp,l))) | ModuleTypeObject _ -> let (mp,l) = KerName.repr kn in - Some (print_modtype (MPdot (mp,l))) + Some (print_modtype ~mod_ops (MPdot (mp,l))) | _ -> None -let gallina_print_library_entry indirect_accessor env sigma with_values ent = +let gallina_print_library_entry ~mod_ops indirect_accessor env sigma with_values ent = let pr_name (sp,_) = Id.print (basename sp) in match ent with | (oname,Lib.Leaf lobj) -> - gallina_print_leaf_entry indirect_accessor env sigma with_values (oname,lobj) + gallina_print_leaf_entry ~mod_ops indirect_accessor env sigma with_values (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> Some (str " >>>>>>> Section " ++ pr_name oname) | (_,Lib.CompilingLibrary { Nametab.obj_dir; _ }) -> @@ -657,10 +657,10 @@ let gallina_print_library_entry indirect_accessor env sigma with_values ent = | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) -let gallina_print_context indirect_accessor env sigma with_values = +let gallina_print_context ~mod_ops indirect_accessor env sigma with_values = let rec prec n = function | h::rest when Option.is_empty n || Option.get n > 0 -> - (match gallina_print_library_entry indirect_accessor env sigma with_values h with + (match gallina_print_library_entry ~mod_ops indirect_accessor env sigma with_values h with | None -> prec n rest | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ()) | _ -> mt () @@ -698,8 +698,8 @@ let print_syntactic_def x = !object_pr.print_syntactic_def x let print_module x = !object_pr.print_module x let print_modtype x = !object_pr.print_modtype x let print_named_decl x = !object_pr.print_named_decl x -let print_library_entry x = !object_pr.print_library_entry x -let print_context x = !object_pr.print_context x +let print_library_entry ~mod_ops x = !object_pr.print_library_entry ~mod_ops x +let print_context ~mod_ops x = !object_pr.print_context ~mod_ops x let print_typed_value_in_env x = !object_pr.print_typed_value_in_env x let print_eval x = !object_pr.print_eval x @@ -720,10 +720,12 @@ let print_safe_judgment env sigma j = (*********************) (* *) -let print_full_context indirect_accessor env sigma = print_context indirect_accessor env sigma true None (Lib.contents ()) -let print_full_context_typ indirect_accessor env sigma = print_context indirect_accessor env sigma false None (Lib.contents ()) +let print_full_context ~mod_ops indirect_accessor env sigma = + print_context ~mod_ops indirect_accessor env sigma true None (Lib.contents ()) +let print_full_context_typ ~mod_ops indirect_accessor env sigma = + print_context ~mod_ops indirect_accessor env sigma false None (Lib.contents ()) -let print_full_pure_context ~library_accessor env sigma = +let print_full_pure_context ~mod_ops ~library_accessor env sigma = let rec prec = function | ((_,kn),Lib.Leaf AtomicObject lobj)::rest -> let pp = match object_tag lobj with @@ -758,11 +760,11 @@ let print_full_pure_context ~library_accessor env sigma = | ((_,kn),Lib.Leaf ModuleObject _)::rest -> (* TODO: make it reparsable *) let (mp,l) = KerName.repr kn in - prec rest ++ print_module true (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () + prec rest ++ print_module ~mod_ops true (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | ((_,kn),Lib.Leaf ModuleTypeObject _)::rest -> (* TODO: make it reparsable *) let (mp,l) = KerName.repr kn in - prec rest ++ print_modtype (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () + prec rest ++ print_modtype ~mod_ops (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | _::rest -> prec rest | _ -> mt () in prec (Lib.contents ()) @@ -787,11 +789,11 @@ let read_sec_context qid = let cxt = Lib.contents () in List.rev (get_cxt [] cxt) -let print_sec_context indirect_accessor env sigma sec = - print_context indirect_accessor env sigma true None (read_sec_context sec) +let print_sec_context ~mod_ops indirect_accessor env sigma sec = + print_context ~mod_ops indirect_accessor env sigma true None (read_sec_context sec) -let print_sec_context_typ indirect_accessor env sigma sec = - print_context indirect_accessor env sigma false None (read_sec_context sec) +let print_sec_context_typ ~mod_ops indirect_accessor env sigma sec = + print_context ~mod_ops indirect_accessor env sigma false None (read_sec_context sec) let maybe_error_reject_univ_decl na udecl = let open GlobRef in @@ -801,7 +803,7 @@ let maybe_error_reject_univ_decl na udecl = (* TODO Print na somehow *) user_err ~hdr:"reject_univ_decl" (str "This object does not support universe names.") -let print_any_name indirect_accessor env sigma na udecl = +let print_any_name ~mod_ops indirect_accessor env sigma na udecl = maybe_error_reject_univ_decl na udecl; let open GlobRef in match na with @@ -810,9 +812,10 @@ let print_any_name indirect_accessor env sigma na udecl = | Term (ConstructRef ((sp,_),_)) -> print_inductive sp udecl | Term (VarRef sp) -> print_section_variable env sigma sp | Syntactic kn -> print_syntactic_def env kn - | Dir (Nametab.GlobDirRef.DirModule Nametab.{ obj_dir; obj_mp; _ } ) -> print_module (printable_body obj_dir) obj_mp + | Dir (Nametab.GlobDirRef.DirModule Nametab.{ obj_dir; obj_mp; _ } ) -> + print_module ~mod_ops (printable_body obj_dir) obj_mp | Dir _ -> mt () - | ModuleType mp -> print_modtype mp + | ModuleType mp -> print_modtype ~mod_ops mp | Other (obj, info) -> info.print obj | Undefined qid -> try (* Var locale de but, pas var de section... donc pas d'implicits *) @@ -824,15 +827,15 @@ let print_any_name indirect_accessor env sigma na udecl = user_err ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") -let print_name indirect_accessor env sigma na udecl = +let print_name ~mod_ops indirect_accessor env sigma na udecl = match na with | {loc; v=Constrexpr.ByNotation (ntn,sc)} -> - print_any_name indirect_accessor env sigma + print_any_name ~mod_ops indirect_accessor env sigma (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) udecl | {loc; v=Constrexpr.AN ref} -> - print_any_name indirect_accessor env sigma (locate_any_name ref) udecl + print_any_name ~mod_ops indirect_accessor env sigma (locate_any_name ref) udecl let print_opaque_name indirect_accessor env sigma qid = let open GlobRef in @@ -888,8 +891,8 @@ let print_about env sigma na udecl = print_about_any ?loc env sigma (locate_any_name ref) udecl (* for debug *) -let inspect indirect_accessor env sigma depth = - print_context indirect_accessor env sigma false (Some depth) (Lib.contents ()) +let inspect ~mod_ops indirect_accessor env sigma depth = + print_context ~mod_ops indirect_accessor env sigma false (Some depth) (Lib.contents ()) (*************************************************************************) (* Pretty-printing functions coming from classops.ml *) diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 4299bcc880..c8b361d95b 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -19,28 +19,35 @@ val assumptions_for_print : Name.t list -> Termops.names_context val print_closed_sections : bool ref val print_context - : Opaqueproof.indirect_accessor + : mod_ops:Printmod.mod_ops + -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t val print_library_entry - : Opaqueproof.indirect_accessor + : mod_ops:Printmod.mod_ops + -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option val print_full_context - : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> Pp.t + : mod_ops:Printmod.mod_ops + -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> Pp.t val print_full_context_typ - : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> Pp.t + : mod_ops:Printmod.mod_ops + -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> Pp.t val print_full_pure_context - : library_accessor:Opaqueproof.indirect_accessor + : mod_ops:Printmod.mod_ops + -> library_accessor:Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> Pp.t val print_sec_context - : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t + : mod_ops:Printmod.mod_ops + -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t val print_sec_context_typ - : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t + : mod_ops:Printmod.mod_ops + -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t val print_judgment : env -> Evd.evar_map -> EConstr.unsafe_judgment -> Pp.t val print_safe_judgment : env -> Evd.evar_map -> Safe_typing.judgment -> Pp.t val print_eval : @@ -48,7 +55,8 @@ val print_eval : Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t val print_name - : Opaqueproof.indirect_accessor + : mod_ops:Printmod.mod_ops + -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid Constrexpr.or_by_notation -> UnivNames.univ_name_list option -> Pp.t val print_opaque_name @@ -69,7 +77,10 @@ val print_typeclasses : unit -> Pp.t val print_instances : GlobRef.t -> Pp.t val print_all_instances : unit -> Pp.t -val inspect : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> int -> Pp.t +val inspect + : mod_ops:Printmod.mod_ops + -> Opaqueproof.indirect_accessor + -> env -> Evd.evar_map -> int -> Pp.t (** {5 Locate} *) @@ -105,11 +116,11 @@ type object_pr = { print_constant_with_infos : Opaqueproof.indirect_accessor -> Constant.t -> UnivNames.univ_name_list option -> Pp.t; print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; print_syntactic_def : env -> KerName.t -> Pp.t; - print_module : bool -> ModPath.t -> Pp.t; - print_modtype : ModPath.t -> Pp.t; + print_module : mod_ops:Printmod.mod_ops -> bool -> ModPath.t -> Pp.t; + print_modtype : mod_ops:Printmod.mod_ops -> ModPath.t -> Pp.t; print_named_decl : env -> Evd.evar_map -> Constr.named_declaration -> Pp.t; - print_library_entry : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option; - print_context : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; + print_library_entry : mod_ops:Printmod.mod_ops -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option; + print_context : mod_ops:Printmod.mod_ops -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } diff --git a/printing/printmod.ml b/printing/printmod.ml index 141469ff9c..03921bca30 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -240,9 +240,14 @@ let nametab_register_body mp dir (l,body) = mip.mind_consnames) mib.mind_packets -let nametab_register_module_body mp struc = +type mod_ops = + { import_module : export:bool -> ModPath.t -> unit + ; process_module_binding : MBId.t -> Declarations.module_alg_expr -> unit + } + +let nametab_register_module_body ~mod_ops mp struc = (* If [mp] is a globally visible module, we simply import it *) - try Declaremods.import_module ~export:false mp + try mod_ops.import_module ~export:false mp with Not_found -> (* Otherwise we try to emulate an import by playing with nametab *) nametab_register_dir mp; @@ -252,7 +257,7 @@ let get_typ_expr_alg mtb = match mtb.mod_type_alg with | Some (NoFunctor me) -> me | _ -> raise Not_found -let nametab_register_modparam mbid mtb = +let nametab_register_modparam ~mod_ops mbid mtb = let id = MBId.to_id mbid in match mtb.mod_type with | MoreFunctor _ -> id (* functorial param : nothing to register *) @@ -260,7 +265,7 @@ let nametab_register_modparam mbid mtb = (* We first try to use the algebraic type expression if any, via a Declaremods function that converts back to module entries *) try - let () = Declaremods.process_module_binding mbid (get_typ_expr_alg mtb) in + let () = mod_ops.process_module_binding mbid (get_typ_expr_alg mtb) in id with e when CErrors.noncritical e -> (* Otherwise, we try to play with the nametab ourselves *) @@ -314,9 +319,9 @@ let print_body is_impl extent env mp (l,body) = let print_struct is_impl extent env mp struc = prlist_with_sep spc (print_body is_impl extent env mp) struc -let print_structure is_type extent env mp locals struc = +let print_structure ~mod_ops is_type extent env mp locals struc = let env' = Modops.add_structure mp struc Mod_subst.empty_delta_resolver env in - nametab_register_module_body mp struc; + nametab_register_module_body ~mod_ops mp struc; let kwd = if is_type then "Sig" else "Struct" in hv 2 (keyword kwd ++ spc () ++ print_struct false extent env' mp struc ++ brk (1,-2) ++ keyword "End") @@ -362,31 +367,31 @@ let print_mod_expr env mp locals = function (str"(" ++ prlist_with_sep spc (print_modpath locals) lapp ++ str")") | MEwith _ -> assert false (* No 'with' syntax for modules *) -let rec print_functor fty fatom is_type extent env mp locals = function - | NoFunctor me -> fatom is_type extent env mp locals me +let rec print_functor ~mod_ops fty fatom is_type extent env mp locals = function + | NoFunctor me -> fatom ~mod_ops is_type extent env mp locals me | MoreFunctor (mbid,mtb1,me2) -> - let id = nametab_register_modparam mbid mtb1 in + let id = nametab_register_modparam ~mod_ops mbid mtb1 in let mp1 = MPbound mbid in - let pr_mtb1 = fty extent env mp1 locals mtb1 in + let pr_mtb1 = fty ~mod_ops extent env mp1 locals mtb1 in let env' = Modops.add_module_type mp1 mtb1 env in let locals' = (mbid, get_new_id locals (MBId.to_id mbid))::locals in let kwd = if is_type then "Funsig" else "Functor" in hov 2 (keyword kwd ++ spc () ++ str "(" ++ Id.print id ++ str ":" ++ pr_mtb1 ++ str ")" ++ - spc() ++ print_functor fty fatom is_type extent env' mp locals' me2) + spc() ++ print_functor ~mod_ops fty fatom is_type extent env' mp locals' me2) -let rec print_expression x = - print_functor +let rec print_expression ~mod_ops x = + print_functor ~mod_ops print_modtype - (function true -> print_typ_expr | false -> fun _ -> print_mod_expr) x + (fun ~mod_ops -> function true -> print_typ_expr | false -> fun _ -> print_mod_expr) x -and print_signature x = - print_functor print_modtype print_structure x +and print_signature ~mod_ops x = + print_functor ~mod_ops print_modtype print_structure x -and print_modtype extent env mp locals mtb = match mtb.mod_type_alg with - | Some me -> print_expression true extent env mp locals me - | None -> print_signature true extent env mp locals mtb.mod_type +and print_modtype ~mod_ops extent env mp locals mtb = match mtb.mod_type_alg with + | Some me -> print_expression ~mod_ops true extent env mp locals me + | None -> print_signature ~mod_ops true extent env mp locals mtb.mod_type let rec printable_body dir = let dir = pop_dirpath dir in @@ -403,52 +408,52 @@ let rec printable_body dir = (** Since we might play with nametab above, we should reset to prior state after the printing *) -let print_expression' is_type extent env mp me = +let print_expression' ~mod_ops is_type extent env mp me = States.with_state_protection - (fun e -> print_expression is_type extent env mp [] e) me + (fun e -> print_expression ~mod_ops is_type extent env mp [] e) me -let print_signature' is_type extent env mp me = +let print_signature' ~mod_ops is_type extent env mp me = States.with_state_protection - (fun e -> print_signature is_type extent env mp [] e) me + (fun e -> print_signature ~mod_ops is_type extent env mp [] e) me -let unsafe_print_module extent env mp with_body mb = +let unsafe_print_module ~mod_ops extent env mp with_body mb = let name = print_modpath [] mp in let pr_equals = spc () ++ str ":= " in let body = match with_body, mb.mod_expr with | false, _ | true, Abstract -> mt() - | _, Algebraic me -> pr_equals ++ print_expression' false extent env mp me - | _, Struct sign -> pr_equals ++ print_signature' false extent env mp sign - | _, FullStruct -> pr_equals ++ print_signature' false extent env mp mb.mod_type + | _, Algebraic me -> pr_equals ++ print_expression' ~mod_ops false extent env mp me + | _, Struct sign -> pr_equals ++ print_signature' ~mod_ops false extent env mp sign + | _, FullStruct -> pr_equals ++ print_signature' ~mod_ops false extent env mp mb.mod_type in let modtype = match mb.mod_expr, mb.mod_type_alg with | FullStruct, _ -> mt () - | _, Some ty -> brk (1,1) ++ str": " ++ print_expression' true extent env mp ty - | _, _ -> brk (1,1) ++ str": " ++ print_signature' true extent env mp mb.mod_type + | _, Some ty -> brk (1,1) ++ str": " ++ print_expression' ~mod_ops true extent env mp ty + | _, _ -> brk (1,1) ++ str": " ++ print_signature' ~mod_ops true extent env mp mb.mod_type in hv 0 (keyword "Module" ++ spc () ++ name ++ modtype ++ body) exception ShortPrinting -let print_module with_body mp = +let print_module ~mod_ops with_body mp = let me = Global.lookup_module mp in try if !short then raise ShortPrinting; - unsafe_print_module WithContents + unsafe_print_module ~mod_ops WithContents (Global.env ()) mp with_body me ++ fnl () with e when CErrors.noncritical e -> - unsafe_print_module OnlyNames + unsafe_print_module ~mod_ops OnlyNames (Global.env ()) mp with_body me ++ fnl () -let print_modtype kn = +let print_modtype ~mod_ops kn = let mtb = Global.lookup_modtype kn in let name = print_kn [] kn in hv 1 (keyword "Module Type" ++ spc () ++ name ++ str " =" ++ spc () ++ try if !short then raise ShortPrinting; - print_signature' true WithContents + print_signature' ~mod_ops true WithContents (Global.env ()) kn mtb.mod_type with e when CErrors.noncritical e -> - print_signature' true OnlyNames + print_signature' ~mod_ops true OnlyNames (Global.env ()) kn mtb.mod_type) diff --git a/printing/printmod.mli b/printing/printmod.mli index 8fd1cb4183..4c9245ee27 100644 --- a/printing/printmod.mli +++ b/printing/printmod.mli @@ -16,5 +16,11 @@ val printable_body : DirPath.t -> bool val pr_mutual_inductive_body : Environ.env -> MutInd.t -> Declarations.mutual_inductive_body -> UnivNames.univ_name_list option -> Pp.t -val print_module : bool -> ModPath.t -> Pp.t -val print_modtype : ModPath.t -> Pp.t + +type mod_ops = + { import_module : export:bool -> ModPath.t -> unit + ; process_module_binding : MBId.t -> Declarations.module_alg_expr -> unit + } + +val print_module : mod_ops:mod_ops -> bool -> ModPath.t -> Pp.t +val print_modtype : mod_ops:mod_ops -> ModPath.t -> Pp.t diff --git a/tactics/declare.ml b/tactics/declare.ml index 3a02e5451a..e418240d3a 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -35,22 +35,36 @@ type import_status = ImportDefaultBehavior | ImportNeedQualified (** Monomorphic universes need to survive sections. *) -let input_universe_context : Univ.ContextSet.t -> Libobject.obj = - declare_object @@ local_object "Monomorphic section universes" - ~cache:(fun (na, uctx) -> Global.push_context_set false uctx) - ~discharge:(fun (_, x) -> Some x) +let name_instance inst = + let map lvl = match Univ.Level.name lvl with + | None -> (* Having Prop/Set/Var as section universes makes no sense *) + assert false + | Some na -> + try + let qid = Nametab.shortest_qualid_of_universe na in + Name (Libnames.qualid_basename qid) + with Not_found -> + (* Best-effort naming from the string representation of the level. + See univNames.ml for a similar hack. *) + Name (Id.of_string_soft (Univ.Level.to_string lvl)) + in + Array.map map (Univ.Instance.to_array inst) let declare_universe_context ~poly ctx = if poly then - (Global.push_context_set true ctx; Lib.add_section_context ctx) + (* FIXME: some upper layers declare universes several times, we hack around + by checking whether the universes already exist. *) + let (univs, cstr) = ctx in + let univs = Univ.LSet.filter (fun u -> not (Lib.is_polymorphic_univ u)) univs in + let uctx = Univ.ContextSet.to_context (univs, cstr) in + let nas = name_instance (Univ.UContext.instance uctx) in + Global.push_section_context (nas, uctx) else - Lib.add_anonymous_leaf (input_universe_context ctx) + Global.push_context_set false ctx (** Declaration of constants and parameters *) type constant_obj = { - cst_decl : Cooking.recipe option; - (** Non-empty only when rebuilding a constant after a section *) cst_kind : Decls.logical_kind; cst_locl : import_status; } @@ -81,12 +95,6 @@ let load_constant i ((sp,kn), obj) = Nametab.push (Nametab.Until i) sp (GlobRef.ConstRef con); Dumpglob.add_constant_kind con obj.cst_kind -let cooking_info segment = - let modlist = replacement_context () in - let { abstr_ctx = named_ctx; abstr_subst = subst; abstr_uctx = uctx } = segment in - let abstract = (named_ctx, subst, uctx) in - { Opaqueproof.modlist; abstract } - (* Opening means making the name without its module qualification available *) let open_constant i ((sp,kn), obj) = (* Never open a local definition *) @@ -106,33 +114,20 @@ let check_exists id = let cache_constant ((sp,kn), obj) = (* Invariant: the constant must exist in the logical environment, except when redefining it when exiting a section. See [discharge_constant]. *) - let id = Libnames.basename sp in let kn' = - match obj.cst_decl with - | None -> - if Global.exists_objlabel (Label.of_id (Libnames.basename sp)) - then Constant.make1 kn - else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(Libnames.basename sp) ++ str".") - | Some r -> - Global.add_recipe ~in_section:(Lib.sections_are_opened ()) id r + if Global.exists_objlabel (Label.of_id (Libnames.basename sp)) + then Constant.make1 kn + else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(Libnames.basename sp) ++ str".") in assert (Constant.equal kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (GlobRef.ConstRef (Constant.make1 kn)); - let cst = Global.lookup_constant kn' in - add_section_constant ~poly:(Declareops.constant_is_polymorphic cst) kn' cst.const_hyps; Dumpglob.add_constant_kind (Constant.make1 kn) obj.cst_kind let discharge_constant ((sp, kn), obj) = - let con = Constant.make1 kn in - let from = Global.lookup_constant con in - let info = cooking_info (section_segment_of_constant con) in - (* This is a hack: when leaving a section, we lose the constant definition, so - we have to store it in the libobject to be able to retrieve it after. *) - Some { obj with cst_decl = Some { Cooking.from; info } } + Some obj (* Hack to reduce the size of .vo: we keep only what load/open needs *) let dummy_constant cst = { - cst_decl = None; cst_kind = cst.cst_kind; cst_locl = cst.cst_locl; } @@ -157,7 +152,6 @@ let update_tables c = let register_constant kn kind local = let o = inConstant { - cst_decl = None; cst_kind = kind; cst_locl = local; } in @@ -352,7 +346,6 @@ let declare_variable ~name ~kind d = poly in Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); - add_section_variable ~name ~poly; Decls.(add_variable_data name {opaque;kind}); add_anonymous_leaf (inVariable ()); Impargs.declare_var_implicits ~impl name; @@ -366,12 +359,17 @@ let declare_inductive_argument_scopes kn mie = Notation.declare_ref_arguments_scope Evd.empty (GlobRef.ConstructRef ((kn,i),j)); done) mie.mind_entry_inds -let inductive_names sp kn mie = +type inductive_obj = { + ind_names : (Id.t * Id.t list) list + (* For each block, name of the type + name of constructors *) +} + +let inductive_names sp kn obj = let (dp,_) = Libnames.repr_path sp in let kn = Global.mind_of_delta_kn kn in let names, _ = List.fold_left - (fun (names, n) ind -> + (fun (names, n) (typename, consnames) -> let ind_p = (kn,n) in let names, _ = List.fold_left @@ -380,70 +378,37 @@ let inductive_names sp kn mie = Libnames.make_path dp l in ((sp, GlobRef.ConstructRef (ind_p,p)) :: names, p+1)) - (names, 1) ind.mind_entry_consnames in - let sp = Libnames.make_path dp ind.mind_entry_typename + (names, 1) consnames in + let sp = Libnames.make_path dp typename in ((sp, GlobRef.IndRef ind_p) :: names, n+1)) - ([], 0) mie.mind_entry_inds + ([], 0) obj.ind_names in names -let load_inductive i ((sp,kn),mie) = - let names = inductive_names sp kn mie in +let load_inductive i ((sp, kn), names) = + let names = inductive_names sp kn names in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref ) names -let open_inductive i ((sp,kn),mie) = - let names = inductive_names sp kn mie in +let open_inductive i ((sp, kn), names) = + let names = inductive_names sp kn names in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Exactly i) sp ref) names -let cache_inductive ((sp,kn),mie) = - let names = inductive_names sp kn mie in - List.iter check_exists (List.map (fun p -> Libnames.basename (fst p)) names); - let id = Libnames.basename sp in - let kn' = Global.add_mind id mie in - assert (MutInd.equal kn' (MutInd.make1 kn)); - let mind = Global.lookup_mind kn' in - add_section_kn ~poly:(Declareops.inductive_is_polymorphic mind) kn' mind.mind_hyps; +let cache_inductive ((sp, kn), names) = + let names = inductive_names sp kn names in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names -let discharge_inductive ((sp,kn),mie) = - let mind = Global.mind_of_delta_kn kn in - let mie = Global.lookup_mind mind in - let info = cooking_info (section_segment_of_mutual_inductive mind) in - Some (Cooking.cook_inductive info mie) - -let dummy_one_inductive_entry mie = { - mind_entry_typename = mie.mind_entry_typename; - mind_entry_arity = Constr.mkProp; - mind_entry_template = false; - mind_entry_consnames = mie.mind_entry_consnames; - mind_entry_lc = [] -} - -(* Hack to reduce the size of .vo: we keep only what load/open needs *) -let dummy_inductive_entry m = { - mind_entry_params = []; - mind_entry_record = None; - mind_entry_finite = Declarations.BiFinite; - mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; - mind_entry_universes = default_univ_entry; - mind_entry_variance = None; - mind_entry_private = None; -} - -(* reinfer subtyping constraints for inductive after section is dischared. *) -let rebuild_inductive mind_ent = - let env = Global.env () in - InferCumulativity.infer_inductive env mind_ent +let discharge_inductive ((sp, kn), names) = + Some names -let inInductive : mutual_inductive_entry -> obj = +let inInductive : inductive_obj -> obj = declare_object {(default_object "INDUCTIVE") with cache_function = cache_inductive; load_function = load_inductive; open_function = open_inductive; - classify_function = (fun a -> Substitute (dummy_inductive_entry a)); + classify_function = (fun a -> Substitute a); subst_function = ident_subst_function; discharge_function = discharge_inductive; - rebuild_function = rebuild_inductive } + } let cache_prim (_,(p,c)) = Recordops.register_primitive_projection p c @@ -500,7 +465,11 @@ let declare_mind mie = let id = match mie.mind_entry_inds with | ind::_ -> ind.mind_entry_typename | [] -> CErrors.anomaly (Pp.str "cannot declare an empty list of inductives.") in - let (sp,kn as oname) = add_leaf id (inInductive mie) in + let map_names mip = (mip.mind_entry_typename, mip.mind_entry_consnames) in + let names = List.map map_names mie.mind_entry_inds in + List.iter (fun (typ, cons) -> check_exists typ; List.iter check_exists cons) names; + let _kn' = Global.add_mind id mie in + let (sp,kn as oname) = add_leaf id (inInductive { ind_names = names }) in if is_unsafe_typing_flags() then feedback_axiom(); let mind = Global.mind_of_delta_kn kn in let isprim = declare_projections mie.mind_entry_universes mind in @@ -632,9 +601,9 @@ let do_universe ~poly l = let ctx = List.fold_left (fun ctx (_,qid) -> Univ.LSet.add (Univ.Level.make qid) ctx) Univ.LSet.empty l, Univ.Constraint.empty in - let () = declare_universe_context ~poly ctx in let src = if poly then BoundUniv else UnqualifiedUniv in - Lib.add_anonymous_leaf (input_univ_names (src, l)) + let () = Lib.add_anonymous_leaf (input_univ_names (src, l)) in + declare_universe_context ~poly ctx let do_constraint ~poly l = let open Univ in diff --git a/test-suite/.csdp.cache b/test-suite/.csdp.cache Binary files differindex e0324b0232..b3bcb5b056 100644 --- a/test-suite/.csdp.cache +++ b/test-suite/.csdp.cache diff --git a/test-suite/bugs/closed/bug_10757.v b/test-suite/bugs/closed/bug_10757.v new file mode 100644 index 0000000000..a531f6e563 --- /dev/null +++ b/test-suite/bugs/closed/bug_10757.v @@ -0,0 +1,38 @@ +Require Import Program Extraction ExtrOcamlBasic. +Print sig. +Section FIXPOINT. + +Variable A: Type. + +Variable eq: A -> A -> Prop. +Variable beq: A -> A -> bool. +Hypothesis beq_eq: forall x y, beq x y = true -> eq x y. +Hypothesis beq_neq: forall x y, beq x y = false -> ~eq x y. + +Variable le: A -> A -> Prop. +Hypothesis le_trans: forall x y z, le x y -> le y z -> le x z. + +Definition gt (x y: A) := le y x /\ ~eq y x. +Hypothesis gt_wf: well_founded gt. + +Variable F: A -> A. +Hypothesis F_mon: forall x y, le x y -> le (F x) (F y). + +Program Fixpoint iterate + (x: A) (PRE: le x (F x)) (SMALL: forall z, le (F z) z -> le x z) + {wf gt x} + : {y : A | eq y (F y) /\ forall z, le (F z) z -> le y z } := + let x' := F x in + match beq x x' with + | true => x + | false => iterate x' _ _ + end. +Next Obligation. + split. +- auto. +- apply beq_neq. auto. +Qed. + +End FIXPOINT. + +Recursive Extraction iterate. diff --git a/test-suite/bugs/closed/bug_10778.v b/test-suite/bugs/closed/bug_10778.v new file mode 100644 index 0000000000..25d729b7e6 --- /dev/null +++ b/test-suite/bugs/closed/bug_10778.v @@ -0,0 +1,32 @@ +(* Test that fresh avoid the variables of intro patterns but also of + simple intro patterns *) + +Ltac exploit_main t T pat cleanup + := + (lazymatch T with + | ?U1 -> ?U2 => + let H := fresh + in +idtac "H=" H; + assert U1 as H; + [cleanup () | exploit_main (t H) U2 pat ltac:(fun _ => clear H; cleanup ())] + | _ => + pose proof t as pat; + cleanup () + end). + +Tactic Notation "exploit" constr(t) "as" simple_intropattern(pat) + := + exploit_main t ltac:(type of t) pat ltac:(fun _ => idtac). + +Goal (True -> True) -> True. +intro H0. exploit H0 as H. +Abort. + +Tactic Notation "exploit'" constr(t) "as" intropattern(pat) + := + exploit_main t ltac:(type of t) pat ltac:(fun _ => idtac). + +Goal (True -> True) -> True. +intro H0. exploit' H0 as H. +Abort. diff --git a/test-suite/bugs/closed/bug_9512.v b/test-suite/bugs/closed/bug_9512.v new file mode 100644 index 0000000000..25285622a9 --- /dev/null +++ b/test-suite/bugs/closed/bug_9512.v @@ -0,0 +1,35 @@ +Require Import Coq.ZArith.BinInt Coq.omega.Omega Coq.micromega.Lia. + +Set Primitive Projections. +Record params := { width : Z }. +Definition p : params := Build_params 64. + +Set Printing All. + +Goal width p = 0%Z -> width p = 0%Z. + intros. + + assert_succeeds (enough True; [omega|]). + assert_succeeds (enough True; [lia|]). + +(* H : @eq Z (width p) Z0 *) +(* ============================ *) +(* @eq Z (width p) Z0 *) + + change tt with tt in H. + +(* H : @eq Z (width p) Z0 *) +(* ============================ *) +(* @eq Z (width p) Z0 *) + + assert_succeeds (enough True; [lia|]). + (* Tactic failure: <tactic closure> fails. *) + (* assert_succeeds (enough True; [omega|]). *) + (* Tactic failure: <tactic closure> fails. *) + + (* omega. *) + (* Error: Omega can't solve this system *) + + lia. + (* Tactic failure: Cannot find witness. *) +Qed. diff --git a/test-suite/bugs/opened/bug_1596.v b/test-suite/bugs/opened/bug_1596.v index 820022d995..27cb731151 100644 --- a/test-suite/bugs/opened/bug_1596.v +++ b/test-suite/bugs/opened/bug_1596.v @@ -69,9 +69,8 @@ Definition t := (X.t * Y.t)%type. elim (X.lt_not_eq H2 H3). elim H0;clear H0;intros. right. - split. - eauto. - eauto. + split; + eauto with ordered_type. Qed. Lemma lt_not_eq : forall (x y:t),(lt x y)->~(eq x y). @@ -97,7 +96,7 @@ Definition t := (X.t * Y.t)%type. apply EQ. split;trivial. apply GT. - right;auto. + right;auto with ordered_type. apply GT. left;trivial. Defined. diff --git a/test-suite/ltac2/constr.v b/test-suite/ltac2/constr.v new file mode 100644 index 0000000000..39601d99a8 --- /dev/null +++ b/test-suite/ltac2/constr.v @@ -0,0 +1,12 @@ +Require Import Ltac2.Constr Ltac2.Init Ltac2.Control. +Import Unsafe. + +Ltac2 Eval match (kind '(nat -> bool)) with + | Prod a b c => a + | _ => throw Match_failure end. + +Set Allow StrictProp. +Axiom something : SProp. +Ltac2 Eval match (kind '(forall x : something, bool)) with + | Prod a b c => a + | _ => throw Match_failure end. diff --git a/test-suite/micromega/bug_9162.v b/test-suite/micromega/bug_9162.v new file mode 100644 index 0000000000..4aedf57faf --- /dev/null +++ b/test-suite/micromega/bug_9162.v @@ -0,0 +1,8 @@ +Require Import ZArith Lia. +Local Open Scope Z_scope. + +Goal Z.of_N (Z.to_N 0) = 0. +Proof. lia. Qed. + +Goal forall q, (Z.of_N (Z.to_N 0) = 0 -> q = 0) -> Z.of_N (Z.to_N 0) = q. +Proof. lia. Qed. diff --git a/test-suite/micromega/non_lin_ci.v b/test-suite/micromega/non_lin_ci.v index ec39209230..2a66cc9a5a 100644 --- a/test-suite/micromega/non_lin_ci.v +++ b/test-suite/micromega/non_lin_ci.v @@ -43,18 +43,18 @@ Proof. Qed. Goal - forall (__x1 __x2 __x3 __x4 __x5 __x6 __x7 __x8 __x9 __x10 __x11 __x12 __x13 - __x14 __x15 __x16 : Z) - (H6 : __x8 < __x10 ^ 2 * __x15 ^ 2 + 2 * __x10 * __x15 * __x14 + __x14 ^ 2) - (H7 : 0 <= __x8) - (H12 : 0 <= __x14) - (H0 : __x8 = __x15 * __x11 + __x9) - (H14 : __x10 ^ 2 * __x15 + __x10 * __x14 < __x16) - (H17 : __x16 <= 0) - (H15 : 0 <= __x9) - (H18 : __x9 < __x15) - (H16 : 0 <= __x12) - (H19 : __x12 < (__x10 * __x15 + __x14) * __x10) + forall (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 + x14 x15 x16 : Z) + (H6 : x8 < x10 ^ 2 * x15 ^ 2 + 2 * x10 * x15 * x14 + x14 ^ 2) + (H7 : 0 <= x8) + (H12 : 0 <= x14) + (H0 : x8 = x15 * x11 + x9) + (H14 : x10 ^ 2 * x15 + x10 * x14 < x16) + (H17 : x16 <= 0) + (H15 : 0 <= x9) + (H18 : x9 < x15) + (H16 : 0 <= x12) + (H19 : x12 < (x10 * x15 + x14) * x10) , False. Proof. intros. diff --git a/test-suite/micromega/rexample.v b/test-suite/micromega/rexample.v index 52dc9ed2e0..354c608e23 100644 --- a/test-suite/micromega/rexample.v +++ b/test-suite/micromega/rexample.v @@ -24,6 +24,16 @@ Proof. lra. Qed. +Goal + forall (a c : R) + (Had : a <> a), + a > c. +Proof. + intros. + lra. +Qed. + + (* Other (simple) examples *) Lemma binomial : forall x y, ((x+y)^2 = x^2 + 2 *x*y + y^2). @@ -32,7 +42,6 @@ Proof. lra. Qed. - Lemma hol_light19 : forall m n, 2 * m + n = (n + m) + m. Proof. intros ; lra. diff --git a/test-suite/micromega/rsyntax.v b/test-suite/micromega/rsyntax.v index f02d93f911..a0afe99181 100644 --- a/test-suite/micromega/rsyntax.v +++ b/test-suite/micromega/rsyntax.v @@ -60,7 +60,6 @@ Proof. lia. (* exponent is a constant expr *) Qed. - Goal (1 / IZR (Z.pow_pos 10 25) = 1 / 10 ^ 25)%R. Proof. lra. diff --git a/test-suite/micromega/zomicron.v b/test-suite/micromega/zomicron.v index 55691f553c..3d99af95ec 100644 --- a/test-suite/micromega/zomicron.v +++ b/test-suite/micromega/zomicron.v @@ -1,5 +1,63 @@ Require Import ZArith. Require Import Lia. + +Section S. + Variables H1 H2 H3 H4 : True. + + Lemma bug_9848 : True. + Proof using. + lia. + Qed. +End S. + +Lemma concl_in_Type : forall (k : nat) + (H : (k < 0)%nat) (F : k < 0 -> Type), + F H. +Proof. + intros. + lia. +Qed. + +Lemma bug_10707 : forall + (T : Type) + (t : nat -> Type) + (k : nat) + (default : T) + (arr : t 0 -> T) + (H : (k < 0)%nat) of_nat_lt, + match k with + | 0 | _ => default + end = arr (of_nat_lt H). +Proof. + intros. + lia. +Qed. + +Axiom decompose_nat : nat -> nat -> nat. +Axiom inleft : forall {P}, {m : nat & P m} -> nat. +Axiom foo : nat. + +Lemma bug_7886 : forall (x x0 : nat) + (e : 0 = x0 + S x) + (H : decompose_nat x 0 = inleft (existT (fun m : nat => 0 = m + S x) x0 e)) + (x1 : nat) + (e0 : 0 = x1 + S (S x)) + (H1 : decompose_nat (S x) 0 = inleft (existT (fun m : nat => 0 = m + S (S x)) x1 e0)), + False. +Proof. + intros. + lia. +Qed. + + +Lemma bug_8898 : forall (p : 0 < 0) (H: p = p), False. +Proof. + intros p H. + lia. +Qed. + + + Open Scope Z_scope. Lemma two_x_eq_1 : forall x, 2 * x = 1 -> False. @@ -34,12 +92,12 @@ Proof. Qed. Lemma compact_proof : forall z, - (z < 0) -> - (z >= 0) -> - (0 >= z \/ 0 < z) -> False. + (z < 0) -> + (z >= 0) -> + (0 >= z \/ 0 < z) -> False. Proof. - intros. - lia. + intros. + lia. Qed. Lemma dummy_ex : exists (x:Z), x = x. @@ -74,9 +132,17 @@ Proof. lia. Qed. + +Lemma fresh1 : forall (__p1 __p2 __p3 __p5:Prop) (x y z:Z), (x = 0 /\ y = 0) /\ z = 0 -> x = 0. +Proof. + intros. + lia. +Qed. + + Class Foo {x : Z} := { T : Type ; dec : T -> Z }. Goal forall bound {F : @Foo bound} (x y : T), 0 <= dec x < bound -> 0 <= dec y -< bound -> dec x + dec y >= bound -> dec x + dec y < 2 * bound. + < bound -> dec x + dec y >= bound -> dec x + dec y < 2 * bound. Proof. intros. lia. @@ -98,7 +164,19 @@ Section S. lia. Qed. - End S. +End S. + +Section S. + Variable x y: Z. + Variable H1 : 1 > 0 -> x = 1. + Variable H2 : x = y. + + Goal x = y. + Proof using H2. + lia. + Qed. + +End S. (* Bug 5073 *) Lemma opp_eq_0_iff a : -a = 0 <-> a = 0. @@ -122,8 +200,50 @@ Goal forall (H5 : - b < r) (H6 : r <= 0) (H2 : 0 <= b), - b = 0 -> False. + b = 0 -> False. Proof. intros b q r. lia. Qed. + + +Section S. + (* From bedrock2, used to be slow *) + Variables (x3 q r q2 r3 : Z) + (H : 2 ^ 2 <> 0 -> r3 + 3 = 2 ^ 2 * q + r) + (H0 : 0 < 2 ^ 2 -> 0 <= r < 2 ^ 2) + (H1 : 2 ^ 2 < 0 -> 2 ^ 2 < r <= 0) + (H2 : 2 ^ 2 = 0 -> q = 0) + (H3 : 2 ^ 2 = 0 -> r = 0) + (q0 r0 : Z) + (H4 : 4 <> 0 -> 0 = 4 * q0 + r0) + (H5 : 0 < 4 -> 0 <= r0 < 4) + (H6 : 4 < 0 -> 4 < r0 <= 0) + (H7 : 4 = 0 -> q0 = 0) + (H8 : 4 = 0 -> r0 = 0) + (q1 r1 : Z) + (H9 : 4 <> 0 -> q + q + (q + q) = 4 * q1 + r1) + (H10 : 0 < 4 -> 0 <= r1 < 4) + (H11 : 4 < 0 -> 4 < r1 <= 0) + (H12 : 4 = 0 -> q1 = 0) + (H13 : 4 = 0 -> r1 = 0) + (r2 : Z) + (H14 : 2 ^ 16 <> 0 -> x3 = 2 ^ 16 * q2 + r2) + (H15 : 0 < 2 ^ 16 -> 0 <= r2 < 2 ^ 16) + (H16 : 2 ^ 16 < 0 -> 2 ^ 16 < r2 <= 0) + (H17 : 2 ^ 16 = 0 -> q2 = 0) + (H18 : 2 ^ 16 = 0 -> r2 = 0) + (q3 : Z) + (H19 : 16383 + 1 <> 0 -> q2 = (16383 + 1) * q3 + r3) + (H20 : 0 < 16383 + 1 -> 0 <= r3 < 16383 + 1) + (H21 : 16383 + 1 < 0 -> 16383 + 1 < r3 <= 0) + (H22 : 16383 + 1 = 0 -> q3 = 0) + (H23 : 16383 + 1 = 0 -> r3 = 0). + + Goal r0 = r1. + Proof using H10 H9 H5 H4. + intros. + lia. + Qed. + +End S. diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v index c0ef9b392d..668be1fdbc 100644 --- a/test-suite/output/MExtraction.v +++ b/test-suite/output/MExtraction.v @@ -1,14 +1,65 @@ -Require Import micromega.MExtraction. -Require Import RingMicromega. -Require Import QArith. -Require Import VarMap. +(************************************************************************) +(* * 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) *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +(* Used to generate micromega.ml *) + +Require Extraction. Require Import ZMicromega. Require Import QMicromega. Require Import RMicromega. +Require Import VarMap. +Require Import RingMicromega. +Require Import NArith. +Require Import QArith. + +Extract Inductive prod => "( * )" [ "(,)" ]. +Extract Inductive list => list [ "[]" "(::)" ]. +Extract Inductive bool => bool [ true false ]. +Extract Inductive sumbool => bool [ true false ]. +Extract Inductive option => option [ Some None ]. +Extract Inductive sumor => option [ Some None ]. +(** Then, in a ternary alternative { }+{ }+{ }, + - leftmost choice (Inleft Left) is (Some true), + - middle choice (Inleft Right) is (Some false), + - rightmost choice (Inright) is (None) *) + + +(** To preserve its laziness, andb is normally expanded. + Let's rather use the ocaml && *) +Extract Inlined Constant andb => "(&&)". + +Import Reals.Rdefinitions. + +Extract Constant R => "int". +Extract Constant R0 => "0". +Extract Constant R1 => "1". +Extract Constant Rplus => "( + )". +Extract Constant Rmult => "( * )". +Extract Constant Ropp => "fun x -> - x". +Extract Constant Rinv => "fun x -> 1 / x". +(** In order to avoid annoying build dependencies the actual + extraction is only performed as a test in the test suite. *) Recursive Extraction -Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula - ZMicromega.cnfZ ZMicromega.Zeval_const ZMicromega.bound_problem_fr QMicromega.cnfQ + Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula + Tauto.abst_form + ZMicromega.cnfZ ZMicromega.bound_problem_fr ZMicromega.Zeval_const QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/test-suite/prerequisite/ssr_mini_mathcomp.v b/test-suite/prerequisite/ssr_mini_mathcomp.v index 74f94a9bed..d293dc0533 100644 --- a/test-suite/prerequisite/ssr_mini_mathcomp.v +++ b/test-suite/prerequisite/ssr_mini_mathcomp.v @@ -196,7 +196,7 @@ Definition clone_subType U v := Variable sT : subType. -CoInductive Sub_spec : sT -> Type := SubSpec x Px : Sub_spec (Sub x Px). +Variant Sub_spec : sT -> Type := SubSpec x Px : Sub_spec (Sub x Px). Lemma SubP u : Sub_spec u. Proof. by case: sT Sub_spec SubSpec u => T' _ C rec /= _. Qed. @@ -209,7 +209,7 @@ Definition insub x := Definition insubd u0 x := odflt u0 (insub x). -CoInductive insub_spec x : option sT -> Type := +Variant insub_spec x : option sT -> Type := | InsubSome u of P x & val u = x : insub_spec x (Some u) | InsubNone of ~~ P x : insub_spec x None. @@ -568,7 +568,7 @@ Fixpoint nth s n {struct n} := Fixpoint rcons s z := if s is x :: s' then x :: rcons s' z else [:: z]. -CoInductive last_spec : seq T -> Type := +Variant last_spec : seq T -> Type := | LastNil : last_spec [::] | LastRcons s x : last_spec (rcons s x). @@ -1292,7 +1292,7 @@ Open Scope big_scope. (* packages both in in a term in which i occurs; it also depends on the *) (* iterated <op>, as this can give more information on the expected type of *) (* the <general_term>, thus allowing for the insertion of coercions. *) -CoInductive bigbody R I := BigBody of I & (R -> R -> R) & bool & R. +Variant bigbody R I := BigBody of I & (R -> R -> R) & bool & R. Definition applybig {R I} (body : bigbody R I) x := let: BigBody _ op b v := body in if b then op v x else x. diff --git a/test-suite/success/Nia.v b/test-suite/success/Nia.v index 62ecece792..2eac9660b4 100644 --- a/test-suite/success/Nia.v +++ b/test-suite/success/Nia.v @@ -4,7 +4,8 @@ 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. +Require Zify. +Ltac Zify.zify_post_hook ::= 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. diff --git a/test-suite/success/section_poly.v b/test-suite/success/section_poly.v new file mode 100644 index 0000000000..1e2201f2de --- /dev/null +++ b/test-suite/success/section_poly.v @@ -0,0 +1,74 @@ + + +Section Foo. + + Variable X : Type. + + Polymorphic Section Bar. + + Variable A : Type. + + Definition id (a:A) := a. + +End Bar. +Check id@{_}. +End Foo. +Check id@{_}. + +Polymorphic Section Foo. +Variable A : Type. +Section Bar. + Variable B : Type. + + Inductive prod := Prod : A -> B -> prod. +End Bar. +Check prod@{_}. +End Foo. +Check prod@{_ _}. + +Section Foo. + + Universe K. + Inductive bla := Bla : Type@{K} -> bla. + + Polymorphic Definition bli@{j} := Type@{j} -> bla. + + Definition bloo := bli@{_}. + + Polymorphic Universe i. + + Fail Definition x := Type. + Fail Inductive x : Type := . + Polymorphic Definition x := Type. + Polymorphic Inductive y : x := . + + Variable A : Type. (* adds a mono univ for the Type, which is unrelated to the others *) + + Fail Variable B : (y : Type@{i}). + (* not allowed: mono constraint (about a fresh univ for y) regarding + poly univ i *) + + Polymorphic Variable B : Type. (* new polymorphic stuff always OK *) + + Variable C : Type@{i}. (* no new univs so no problems *) + + Polymorphic Definition thing := bloo -> y -> A -> B. + +End Foo. +Check bli@{_}. +Check bloo@{}. + +Check thing@{_ _ _}. + +Section Foo. + + Polymorphic Universes i k. + Universe j. + Fail Constraint i < j. + Fail Constraint i < k. + + (* referring to mono univs in poly constraints is OK. *) + Polymorphic Constraint i < j. Polymorphic Constraint j < k. + + Polymorphic Definition foo := Type@{j}. +End Foo. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 8627ff7353..7c69350db4 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -593,14 +593,14 @@ Qed. Lemma MapsTo_1 : forall m x y e, X.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. - induction m; simpl; intuition_in; eauto. + induction m; simpl; intuition_in; eauto with ordered_type. Qed. Hint Immediate MapsTo_1 : core. Lemma In_1 : forall m x y, X.eq x y -> In x m -> In y m. Proof. - intros m x y; induction m; simpl; intuition_in; eauto. + intros m x y; induction m; simpl; intuition_in; eauto with ordered_type. Qed. Lemma In_node_iff : @@ -671,7 +671,7 @@ Qed. Lemma lt_tree_trans : forall x y, X.lt x y -> forall m, lt_tree x m -> lt_tree y m. Proof. - eauto. + eauto with ordered_type. Qed. Lemma gt_tree_not_in : @@ -683,7 +683,7 @@ Qed. Lemma gt_tree_trans : forall x y, X.lt y x -> forall m, gt_tree x m -> gt_tree y m. Proof. - eauto. + eauto with ordered_type. Qed. Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. @@ -707,7 +707,7 @@ Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. Proof. destruct m as [|r x e l h]; simpl; auto. - intro H; elim (H x e); auto. + intro H; elim (H x e); auto with ordered_type. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. @@ -732,7 +732,7 @@ Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e. Proof. intros m x; functional induction (find x m); auto; intros; clearf; inv bst; intuition_in; simpl; auto; - try solve [order | absurd (X.lt x y); eauto | absurd (X.lt y x); eauto]. + try solve [order | absurd (X.lt x y); eauto with ordered_type | absurd (X.lt y x); eauto with ordered_type]. Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. @@ -832,8 +832,8 @@ Lemma bal_bst : forall l x e r, bst l -> bst r -> Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv bst; repeat apply create_bst; auto; unfold create; try constructor; - (apply lt_tree_node || apply gt_tree_node); auto; - (eapply lt_tree_trans || eapply gt_tree_trans); eauto. + (apply lt_tree_node || apply gt_tree_node); auto with ordered_type; + (eapply lt_tree_trans || eapply gt_tree_trans); eauto with ordered_type. Qed. Hint Resolve bal_bst : core. @@ -865,7 +865,7 @@ Lemma add_in : forall m x y e, Proof. intros m x y e; functional induction (add x e m); auto; intros; try (rewrite bal_in, IHt); intuition_in. - apply In_1 with x; auto. + apply In_1 with x; auto with ordered_type. Qed. Lemma add_bst : forall m x e, bst m -> bst (add x e m). @@ -874,14 +874,14 @@ Proof. inv bst; try apply bal_bst; auto; intro z; rewrite add_in; intuition. apply MX.eq_lt with x; auto. - apply MX.lt_eq with x; auto. + apply MX.lt_eq with x; auto with ordered_type. Qed. Hint Resolve add_bst : core. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; functional induction (add x e m); - intros; inv bst; try rewrite bal_mapsto; unfold create; eauto. + intros; inv bst; try rewrite bal_mapsto; unfold create; eauto with ordered_type. Qed. Lemma add_2 : forall m x y e e', ~X.eq x y -> @@ -912,7 +912,7 @@ Proof. intros; rewrite find_mapsto_equiv; auto. split; eauto using add_2, add_3. destruct X.compare; try (apply H0; order). - auto using find_1, add_1. + auto using find_1, add_1 with ordered_type. Qed. (** * Extraction of minimum binding *) @@ -971,7 +971,7 @@ Proof. generalize (remove_min_in ll lx ld lr _x m#1). rewrite e0; simpl; intros. rewrite (bal_in l' x d r y) in H. - assert (In m#1 (Node ll lx ld lr _x)) by (rewrite H4; auto); clear H4. + assert (In m#1 (Node ll lx ld lr _x)) by (rewrite H4; auto with ordered_type); clear H4. assert (X.lt m#1 x) by order. decompose [or] H; order. Qed. @@ -1050,7 +1050,7 @@ Proof. (* EQ *) inv bst; clear e0. rewrite merge_in; intuition; [ order | order | intuition_in ]. - elim H4; eauto. + elim H4; eauto with ordered_type. (* GT *) inv bst; clear e0. rewrite bal_in; auto. @@ -1069,7 +1069,7 @@ Proof. destruct H; eauto. (* EQ *) inv bst. - apply merge_bst; eauto. + apply merge_bst; eauto with ordered_type. (* GT *) inv bst. apply bal_bst; auto. @@ -1124,8 +1124,8 @@ Lemma join_bst : forall l x d r, bst l -> bst r -> Proof. join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; clear Hrl Hlr; intro; intros; rewrite join_in in *. - intuition; [ apply MX.lt_eq with x | ]; eauto. - intuition; [ apply MX.eq_lt with x | ]; eauto. + intuition; [ apply MX.lt_eq with x | ]; eauto with ordered_type. + intuition; [ apply MX.eq_lt with x | ]; eauto with ordered_type. Qed. Hint Resolve join_bst : core. @@ -1135,8 +1135,8 @@ Lemma join_find : forall l x d r y, Proof. join_tac; auto; inv bst; simpl (join (Leaf elt)); - try (assert (X.lt lx x) by auto); - try (assert (X.lt x rx) by auto); + try (assert (X.lt lx x) by auto with ordered_type); + try (assert (X.lt x rx) by auto with ordered_type); rewrite ?add_find, ?bal_find; auto. simpl; destruct X.compare; auto. @@ -1260,7 +1260,7 @@ Proof. change (bst (m2',xd)#1). rewrite <-e1; eauto. intros y Hy. apply H1; auto. - rewrite remove_min_in, e1; simpl; auto. + rewrite remove_min_in, e1; simpl; auto with ordered_type. change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <-e1; eauto. Qed. Hint Resolve concat_bst : core. @@ -1283,9 +1283,9 @@ Proof. simpl; destruct X.compare as [Hlt| |Hlt]; simpl; auto. destruct (find y m2'); auto. symmetry; rewrite not_find_iff; auto; intro. - apply (MX.lt_not_gt Hlt); apply H1; auto; rewrite H3; auto. + apply (MX.lt_not_gt Hlt); apply H1; auto; rewrite H3; auto with ordered_type. - intros z Hz; apply H1; auto; rewrite H3; auto. + intros z Hz; apply H1; auto; rewrite H3; auto with ordered_type. Qed. @@ -1338,12 +1338,12 @@ Proof. apply InA_InfA with (eqA:=eqke); auto with *. intros (y',e') H6. destruct (elements_aux_mapsto r acc y' e'); intuition. red; simpl; eauto. - red; simpl; eauto. - intros. + red; simpl; eauto with ordered_type. + intros x e0 y0 H H6. inversion_clear H. destruct H7; simpl in *. order. - destruct (elements_aux_mapsto r acc x e0); intuition eauto. + destruct (elements_aux_mapsto r acc x e0); intuition eauto with ordered_type. Qed. Lemma elements_sort : forall s : t elt, bst s -> sort ltk (elements s). @@ -1567,7 +1567,7 @@ Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. induction m; simpl; inversion_clear 1; auto. -exists k; auto. +exists k; auto with ordered_type. destruct (IHm1 _ _ H0). exists x0; intuition. destruct (IHm2 _ _ H0). @@ -2072,7 +2072,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. - destruct c; simpl; intros; P.MX.elim_comp; auto. + destruct c; simpl; intros; P.MX.elim_comp; auto with ordered_type. Qed. Hint Resolve cons_Cmp : core. diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 1a531542cc..758f9d41b0 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -1822,7 +1822,7 @@ Module OrdProperties (M:S). destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto. unfold O.ltk in *; simpl in *; intros. symmetry; rewrite H2. - apply ME.eq_lt with a; auto. + apply ME.eq_lt with a; auto with ordered_type. rewrite <- H1; auto. unfold O.ltk in *; simpl in *; intros. rewrite H1. @@ -1869,7 +1869,7 @@ Module OrdProperties (M:S). rewrite <- elements_mapsto_iff in H1. assert (~E.eq x t0). contradict H. - exists e0; apply MapsTo_1 with t0; auto. + exists e0; apply MapsTo_1 with t0; auto with ordered_type. ME.order. apply (@filter_sort _ eqke); auto with *; clean_eauto. intros. @@ -1888,9 +1888,9 @@ Module OrdProperties (M:S). find_mapsto_iff, (H0 t0), <- find_mapsto_iff, add_mapsto_iff by (auto with *). unfold O.eqke, O.ltk; simpl. - destruct (E.compare t0 x); intuition; try fold (~E.eq x t0); auto. + destruct (E.compare t0 x); intuition; try fold (~E.eq x t0); auto with ordered_type. - elim H; exists e0; apply MapsTo_1 with t0; auto. - - fold (~E.lt t0 x); auto. + - fold (~E.lt t0 x); auto with ordered_type. Qed. Lemma elements_Add_Above : forall m m' x e, @@ -1905,7 +1905,7 @@ Module OrdProperties (M:S). destruct x0; destruct y. rewrite <- elements_mapsto_iff in H1. unfold O.eqke, O.ltk in *; simpl in *; destruct H3. - apply ME.lt_eq with x; auto. + apply ME.lt_eq with x; auto with ordered_type. apply H; firstorder. inversion H3. red; intros a; destruct a. @@ -1991,7 +1991,7 @@ Module OrdProperties (M:S). injection H as [= -> ->]. inversion_clear H1. red in H; simpl in *; intuition. - elim H0; eauto. + elim H0; eauto with ordered_type. inversion H. change (max_elt_aux (p::l) = Some (x,e)) in H. generalize (IHl x e H); clear IHl; intros IHl. @@ -2007,9 +2007,9 @@ Module OrdProperties (M:S). inversion_clear H2. inversion_clear H5. red in H2; simpl in H2; ME.order. - eapply IHl; eauto. + eapply IHl; eauto with ordered_type. econstructor; eauto. - red; eauto. + red; eauto with ordered_type. inversion H2; auto. Qed. @@ -2022,7 +2022,7 @@ Module OrdProperties (M:S). induction (elements m). simpl; try discriminate. destruct a; destruct l; simpl in *. - injection H; intros; subst; constructor; red; auto. + injection H; intros; subst; constructor; red; auto with ordered_type. constructor 2; auto. Qed. @@ -2069,7 +2069,7 @@ Module OrdProperties (M:S). destruct (elements m). simpl; try discriminate. destruct p; simpl in *. - injection H; intros; subst; constructor; red; auto. + injection H; intros; subst; constructor; red; auto with ordered_type. Qed. Lemma min_elt_Empty : @@ -2106,7 +2106,7 @@ Module OrdProperties (M:S). apply IHn. assert (S n = S (cardinal (remove k m))). rewrite Heqn. - eapply cardinal_2; eauto with map. + eapply cardinal_2; eauto with map ordered_type. inversion H1; auto. eapply max_elt_Above; eauto. @@ -2133,7 +2133,7 @@ Module OrdProperties (M:S). apply IHn. assert (S n = S (cardinal (remove k m))). rewrite Heqn. - eapply cardinal_2; eauto with map. + eapply cardinal_2; eauto with map ordered_type. inversion H1; auto. eapply min_elt_Below; eauto. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 8ca9401a06..0ef356b582 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -712,7 +712,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. - destruct c; simpl; intros; MX.elim_comp; auto. + destruct c; simpl; intros; MX.elim_comp; auto with ordered_type. Qed. Hint Resolve cons_Cmp : core. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index b21d809059..cad528644a 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -68,7 +68,7 @@ Proof. intros m. case m;auto. intros (k,e) l inlist. - absurd (InA eqke (k, e) ((k, e) :: l));auto. + absurd (InA eqke (k, e) ((k, e) :: l)); auto with ordered_type. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. @@ -106,14 +106,14 @@ Proof. elim (sort_inv sorted);auto. elim (In_inv belong1);auto. intro abs. - absurd (X.eq x k');auto. + absurd (X.eq x k'); auto with ordered_type. Qed. Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. Proof. intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail). - exists _x; auto. + exists _x; auto with ordered_type. induction IHb; auto. exists x0; auto. inversion_clear sorted; auto. @@ -135,7 +135,7 @@ Function find (k:key) (s: t elt) {struct s} : option elt := Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m x. unfold PX.MapsTo. - functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto. + functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto with ordered_type. Qed. Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. @@ -174,7 +174,7 @@ Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; generalize y; clear y. unfold PX.MapsTo. - functional induction (add x e m);simpl;auto. + functional induction (add x e m);simpl;auto with ordered_type. Qed. Lemma add_2 : forall m x y e e', @@ -195,12 +195,12 @@ Qed. Lemma add_3 : forall m x y e e', ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. -Proof. +Proof with auto with ordered_type. intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m);simpl; intros. - apply (In_inv_3 H0); compute; auto. - apply (In_inv_3 H0); compute; auto. - constructor 2; apply (In_inv_3 H0); compute; auto. + apply (In_inv_3 H0)... + apply (In_inv_3 H0)... + constructor 2; apply (In_inv_3 H0)... inversion_clear H0; auto. Qed. @@ -254,7 +254,7 @@ Proof. clear e0;inversion_clear Hm. apply Sort_Inf_NotIn with x0; auto. - apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto. + apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto with ordered_type. clear e0;inversion_clear Hm. assert (notin:~ In y (remove x l)) by auto. @@ -374,13 +374,13 @@ Definition Equivb cmp m m' := Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, Equivb cmp m m' -> equal cmp m m' = true. -Proof. +Proof with auto with ordered_type. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; intuition; subst. match goal with H: X.compare _ _ = _ |- _ => clear H end. assert (cmp_e_e':cmp e e' = true). - apply H1 with x; auto. + apply H1 with x... rewrite cmp_e_e'; simpl. apply IHb; auto. inversion_clear Hm; auto. @@ -388,7 +388,7 @@ Proof. unfold Equivb; intuition. destruct (H0 k). assert (In k ((x,e) ::l)). - destruct H as (e'', hyp); exists e''; auto. + destruct H as (e'', hyp); exists e''... destruct (In_inv (H2 H4)); auto. inversion_clear Hm. elim (Sort_Inf_NotIn H6 H7). @@ -396,20 +396,20 @@ Proof. apply MapsTo_eq with k; auto; order. destruct (H0 k). assert (In k ((x',e') ::l')). - destruct H as (e'', hyp); exists e''; auto. + destruct H as (e'', hyp); exists e''... destruct (In_inv (H3 H4)); auto. inversion_clear Hm'. elim (Sort_Inf_NotIn H6 H7). destruct H as (e'', hyp); exists e''; auto. apply MapsTo_eq with k; auto; order. - apply H1 with k; destruct (X.eq_dec x k); auto. + apply H1 with k; destruct (X.eq_dec x k)... destruct (X.compare x x') as [Hlt|Heq|Hlt]; try contradiction; clear y. destruct (H0 x). assert (In x ((x',e')::l')). apply H; auto. - exists e; auto. + exists e... destruct (In_inv H3). order. inversion_clear Hm'. @@ -420,7 +420,7 @@ Proof. destruct (H0 x'). assert (In x' ((x,e)::l)). apply H2; auto. - exists e'; auto. + exists e'... destruct (In_inv H3). order. inversion_clear Hm. @@ -434,13 +434,13 @@ Proof. clear H1;destruct p as (k,e). destruct (H0 k). destruct H1. - exists e; auto. + exists e... inversion H1. destruct p as (x,e). destruct (H0 x). destruct H. - exists e; auto. + exists e... inversion H. destruct p;destruct p0;contradiction. @@ -449,7 +449,7 @@ Qed. Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, equal cmp m m' = true -> Equivb cmp m m'. -Proof. +Proof with auto with ordered_type. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; intuition; try discriminate; subst; @@ -464,16 +464,16 @@ Proof. exists e'; constructor; split; trivial; apply X.eq_trans with x; auto. destruct (H k). destruct (H9 H8) as (e'',hyp). - exists e''; auto. + exists e''... inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. destruct (IHb H1 H3 H6). destruct (In_inv H0). - exists e; constructor; split; trivial; apply X.eq_trans with x'; auto. + exists e; constructor; split; trivial; apply X.eq_trans with x'... destruct (H k). destruct (H10 H8) as (e'',hyp). - exists e''; auto. + exists e''... inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. @@ -615,7 +615,8 @@ Proof. inversion_clear 1. exists x'. destruct H0; simpl in *. - split; auto. + split. + auto with ordered_type. constructor 1. unfold eqke in *; simpl in *; intuition congruence. destruct IHm as (y, hyp); auto. @@ -946,7 +947,7 @@ Proof. destruct (IHm0 H0) as (_,H4); apply H4; auto. case_eq (find x m0); intros; auto. assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). - red; auto. + red; auto with ordered_type. destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)). exists p; apply find_2; auto. (* k < x *) @@ -1315,7 +1316,7 @@ Proof. apply (IHm1 H0 (Build_slist H5)); intuition. Qed. -Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto. +Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto with ordered_type. Definition compare : forall m1 m2, Compare lt eq m1 m2. Proof. diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 6e08c38a49..f0b31e6986 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -63,11 +63,11 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. Proof. intros; exists (remove x s); intuition. - absurd (In x (remove x s)); auto with set. - apply In_1 with y; auto. + absurd (In x (remove x s)); auto with set ordered_type. + apply In_1 with y; auto with ordered_type. elim (E.eq_dec x y); intros; auto. - absurd (In x (remove x s)); auto with set. - apply In_1 with y; auto. + absurd (In x (remove x s)); auto with set ordered_type. + apply In_1 with y; auto with ordered_type. eauto with set. Qed. @@ -470,7 +470,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Hint Resolve elements_3 : core. Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). - Proof. auto. Qed. + Proof. auto with ordered_type. Qed. Definition min_elt (s : t) : option elt := match min_elt s with diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index c6b2e0a09d..e500debc73 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -939,7 +939,7 @@ Module OrdProperties (M:S). generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto. intros. symmetry; rewrite H1. - apply ME.eq_lt with a; auto. + apply ME.eq_lt with a; auto with ordered_type. rewrite <- H0; auto. intros. rewrite H0. @@ -1013,7 +1013,7 @@ Module OrdProperties (M:S). intros. inversion_clear H2. rewrite <- elements_iff in H1. - apply ME.lt_eq with x; auto. + apply ME.lt_eq with x; auto with ordered_type. inversion H3. red; intros a. rewrite InA_app_iff, InA_cons, InA_nil by auto with *. @@ -1052,7 +1052,7 @@ Module OrdProperties (M:S). apply X0 with (remove e s) e; auto with set. apply IHn. assert (S n = S (cardinal (remove e s))). - rewrite Heqn; apply cardinal_2 with e; auto with set. + rewrite Heqn; apply cardinal_2 with e; auto with set ordered_type. inversion H0; auto. red; intros. rewrite remove_iff in H0; destruct H0. @@ -1073,7 +1073,7 @@ Module OrdProperties (M:S). apply X0 with (remove e s) e; auto with set. apply IHn. assert (S n = S (cardinal (remove e s))). - rewrite Heqn; apply cardinal_2 with e; auto with set. + rewrite Heqn; apply cardinal_2 with e; auto with set ordered_type. inversion H0; auto. red; intros. rewrite remove_iff in H0; destruct H0. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 09a32e9483..4d84d61f9f 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -274,6 +274,22 @@ Inductive ex (A:Type) (P:A -> Prop) : Prop := ex_intro : forall x:A, P x -> ex (A:=A) P. Register ex as core.ex.type. +Register ex_intro as core.ex.intro. + +Section Projections. + + Variables (A:Prop) (P:A->Prop). + + Definition ex_proj1 (x:ex P) : A := + match x with ex_intro _ a _ => a end. + + Definition ex_proj2 (x:ex P) : P (ex_proj1 x) := + match x with ex_intro _ _ b => b end. + + Register ex_proj1 as core.ex.proj1. + Register ex_proj2 as core.ex.proj2. + +End Projections. Inductive ex2 (A:Type) (P Q:A -> Prop) : Prop := ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q. diff --git a/theories/Reals/ConstructiveCauchyReals.v b/theories/Reals/ConstructiveCauchyReals.v index 004854e751..965d31d403 100644 --- a/theories/Reals/ConstructiveCauchyReals.v +++ b/theories/Reals/ConstructiveCauchyReals.v @@ -15,34 +15,32 @@ Require Import Qround. Require Import Logic.ConstructiveEpsilon. Require CMorphisms. -Open Scope Q. +(** The constructive Cauchy real numbers, ie the Cauchy sequences + of rational numbers. This file is not supposed to be imported, + except in Rdefinitions.v, Raxioms.v, Rcomplete_constr.v + and ConstructiveRIneq.v. -(* The constructive Cauchy real numbers, ie the Cauchy sequences - of rational numbers. This file is not supposed to be imported, - except in Rdefinitions.v, Raxioms.v, Rcomplete_constr.v - and ConstructiveRIneq.v. + Constructive real numbers should be considered abstractly, + forgetting the fact that they are implemented as rational sequences. + All useful lemmas of this file are exposed in ConstructiveRIneq.v, + under more abstract names, like Rlt_asym instead of CRealLt_asym. - Constructive real numbers should be considered abstractly, - forgetting the fact that they are implemented as rational sequences. - All useful lemmas of this file are exposed in ConstructiveRIneq.v, - under more abstract names, like Rlt_asym instead of CRealLt_asym. + Cauchy reals are Cauchy sequences of rational numbers, + equipped with explicit moduli of convergence and + an equivalence relation (the difference converges to zero). - Cauchy reals are Cauchy sequences of rational numbers, - equipped with explicit moduli of convergence and - an equivalence relation (the difference converges to zero). + Without convergence moduli, we would fail to prove that a Cauchy + sequence of constructive reals converges. - Without convergence moduli, we would fail to prove that a Cauchy - sequence of constructive reals converges. + Because of the Specker sequences (increasing, computable + and bounded sequences of rationals that do not converge + to a computable real number), constructive reals do not + follow the least upper bound principle. - Because of the Specker sequences (increasing, computable - and bounded sequences of rationals that do not converge - to a computable real number), constructive reals do not - follow the least upper bound principle. - - The double quantification on p q is needed to avoid - forall un, QSeqEquiv un (fun _ => un O) (fun q => O) - which says nothing about the limit of un. + The double quantification on p q is needed to avoid + forall un, QSeqEquiv un (fun _ => un O) (fun q => O) + which says nothing about the limit of un. *) Definition QSeqEquiv (un vn : nat -> Q) (cvmod : positive -> nat) : Prop @@ -213,7 +211,7 @@ Delimit Scope CReal_scope with CReal. (* Automatically open scope R_scope for arguments of type R *) Bind Scope CReal_scope with CReal. -Open Scope CReal_scope. +Local Open Scope CReal_scope. (* So QSeqEquiv is the equivalence relation of this constructive pre-order *) @@ -470,7 +468,8 @@ Qed. Lemma CRealLt_above : forall (x y : CReal), CRealLt x y -> { k : positive | forall p:positive, - Pos.le k p -> Qlt (2 # k) (proj1_sig y (Pos.to_nat p) - proj1_sig x (Pos.to_nat p)) }. + Pos.le k p -> Qlt (2 # k) (proj1_sig y (Pos.to_nat p) + - proj1_sig x (Pos.to_nat p)) }. Proof. intros x y [n maj]. pose proof (CRealLt_aboveSig x y n maj). @@ -544,10 +543,9 @@ Proof. Qed. Lemma CRealLt_dec : forall x y z : CReal, - CRealLt x y -> CRealLt x z + CRealLt z y. + x < y -> sum (x < z) (z < y). Proof. - intros [xn limx] [yn limy] [zn limz] clt. - destruct clt as [n inf]. + intros [xn limx] [yn limy] [zn limz] [n inf]. unfold proj1_sig in inf. remember (yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2 # n)) as eps. assert (Qlt 0 eps) as epsPos. @@ -629,33 +627,33 @@ Defined. Definition linear_order_T x y z := CRealLt_dec x z y. -Lemma CRealLe_Lt_trans : forall x y z : CReal, +Lemma CReal_le_lt_trans : forall x y z : CReal, x <= y -> y < z -> x < z. Proof. intros. destruct (linear_order_T y x z H0). contradiction. apply c. -Qed. +Defined. -Lemma CRealLt_Le_trans : forall x y z : CReal, +Lemma CReal_lt_le_trans : forall x y z : CReal, x < y -> y <= z -> x < z. Proof. intros. destruct (linear_order_T x z y H). apply c. contradiction. -Qed. +Defined. -Lemma CRealLe_trans : forall x y z : CReal, +Lemma CReal_le_trans : forall x y z : CReal, x <= y -> y <= z -> x <= z. Proof. intros. intro abs. apply H0. - apply (CRealLt_Le_trans _ x); assumption. + apply (CReal_lt_le_trans _ x); assumption. Qed. -Lemma CRealLt_trans : forall x y z : CReal, +Lemma CReal_lt_trans : forall x y z : CReal, x < y -> y < z -> x < z. Proof. - intros. apply (CRealLt_Le_trans _ y _ H). + intros. apply (CReal_lt_le_trans _ y _ H). apply CRealLt_asym. exact H0. -Qed. +Defined. Lemma CRealEq_trans : forall x y z : CReal, CRealEq x y -> CRealEq y z -> CRealEq x z. @@ -776,6 +774,7 @@ Defined. Notation "0" := (inject_Q 0) : CReal_scope. Notation "1" := (inject_Q 1) : CReal_scope. +Notation "2" := (inject_Q 2) : CReal_scope. Lemma CRealLt_0_1 : CRealLt (inject_Q 0) (inject_Q 1). Proof. @@ -859,6 +858,56 @@ Proof. apply Pos.le_max_r. apply le_refl. Qed. +Lemma inject_Q_compare : forall (x : CReal) (p : positive), + x <= inject_Q (proj1_sig x (Pos.to_nat p) + (1#p)). +Proof. + intros. intros [n nmaj]. + destruct x as [xn xcau]; simpl in nmaj. + apply (Qplus_lt_l _ _ (1#p)) in nmaj. + ring_simplify in nmaj. + destruct (Pos.max_dec p n). + - apply Pos.max_l_iff in e. + apply Pos2Nat.inj_le in e. + specialize (xcau n (Pos.to_nat n) (Pos.to_nat p) (le_refl _) e). + apply (Qlt_le_trans _ _ (Qabs (xn (Pos.to_nat n) + -1 * xn (Pos.to_nat p)))) in nmaj. + 2: apply Qle_Qabs. + apply (Qlt_trans _ _ _ nmaj) in xcau. + apply (Qplus_lt_l _ _ (-(1#n)-(1#p))) in xcau. ring_simplify in xcau. + setoid_replace ((2 # n) + -1 * (1 # n)) with (1#n)%Q in xcau. + discriminate xcau. setoid_replace (-1 * (1 # n)) with (-1#n)%Q. 2: reflexivity. + rewrite Qinv_plus_distr. reflexivity. + - apply Pos.max_r_iff, Pos2Nat.inj_le in e. + specialize (xcau p (Pos.to_nat n) (Pos.to_nat p) e (le_refl _)). + apply (Qlt_le_trans _ _ (Qabs (xn (Pos.to_nat n) + -1 * xn (Pos.to_nat p)))) in nmaj. + 2: apply Qle_Qabs. + apply (Qlt_trans _ _ _ nmaj) in xcau. + apply (Qplus_lt_l _ _ (-(1#p))) in xcau. ring_simplify in xcau. discriminate. +Qed. + + +Add Parametric Morphism : inject_Q + with signature Qeq ==> CRealEq + as inject_Q_morph. +Proof. + split. + - intros [n abs]. simpl in abs. rewrite H in abs. + unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs. + - intros [n abs]. simpl in abs. rewrite H in abs. + unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs. +Qed. + +Instance inject_Q_morph_T + : CMorphisms.Proper + (CMorphisms.respectful Qeq CRealEq) inject_Q. +Proof. + split. + - intros [n abs]. simpl in abs. rewrite H in abs. + unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs. + - intros [n abs]. simpl in abs. rewrite H in abs. + unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs. +Qed. + + (* Algebraic operations *) @@ -1029,9 +1078,7 @@ Proof. Qed. Lemma CReal_plus_lt_compat_l : - forall x y z : CReal, - CRealLt y z - -> CRealLt (CReal_plus x y) (CReal_plus x z). + forall x y z : CReal, y < z -> x + y < x + z. Proof. intros. apply CRealLt_above in H. destruct H as [n maj]. @@ -1047,6 +1094,13 @@ Proof. simpl; ring. Qed. +Lemma CReal_plus_lt_compat_r : + forall x y z : CReal, y < z -> y + x < z + x. +Proof. + intros. do 2 rewrite <- (CReal_plus_comm x). + apply CReal_plus_lt_compat_l. assumption. +Qed. + Lemma CReal_plus_lt_reg_l : forall x y z : CReal, x + y < x + z -> y < z. Proof. @@ -1068,6 +1122,20 @@ Proof. apply CReal_plus_lt_reg_l in H. exact H. Qed. +Lemma CReal_plus_le_reg_l : + forall x y z : CReal, x + y <= x + z -> y <= z. +Proof. + intros. intro abs. apply H. clear H. + apply CReal_plus_lt_compat_l. exact abs. +Qed. + +Lemma CReal_plus_le_reg_r : + forall x y z : CReal, y + x <= z + x -> y <= z. +Proof. + intros. intro abs. apply H. clear H. + apply CReal_plus_lt_compat_r. exact abs. +Qed. + Lemma CReal_plus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2. Proof. intros. intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. @@ -1076,12 +1144,21 @@ Qed. Lemma CReal_plus_le_lt_compat : forall r1 r2 r3 r4 : CReal, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4. Proof. - intros; apply CRealLe_Lt_trans with (r2 + r3). + intros; apply CReal_le_lt_trans with (r2 + r3). intro abs. rewrite CReal_plus_comm, (CReal_plus_comm r1) in abs. apply CReal_plus_lt_reg_l in abs. contradiction. apply CReal_plus_lt_compat_l; exact H0. Qed. +Lemma CReal_plus_le_compat : + forall r1 r2 r3 r4 : CReal, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4. +Proof. + intros; apply CReal_le_trans with (r2 + r3). + intro abs. rewrite CReal_plus_comm, (CReal_plus_comm r1) in abs. + apply CReal_plus_lt_reg_l in abs. contradiction. + apply CReal_plus_le_compat_l; exact H0. +Qed. + Lemma CReal_plus_opp_r : forall x : CReal, x + - x == 0. Proof. @@ -1140,1812 +1217,110 @@ Proof. Qed. Lemma CReal_plus_eq_reg_l : forall (r r1 r2 : CReal), - CRealEq (CReal_plus r r1) (CReal_plus r r2) - -> CRealEq r1 r2. + r + r1 == r + r2 -> r1 == r2. Proof. intros. destruct H. split. - intro abs. apply (CReal_plus_lt_compat_l r) in abs. contradiction. - intro abs. apply (CReal_plus_lt_compat_l r) in abs. contradiction. Qed. -Fixpoint BoundFromZero (qn : nat -> Q) (k : nat) (A : positive) { struct k } - : (forall n:nat, le k n -> Qlt (Qabs (qn n)) (Z.pos A # 1)) - -> { B : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos B # 1) }. -Proof. - intro H. destruct k. - - exists A. intros. apply H. apply le_0_n. - - destruct (Qarchimedean (Qabs (qn k))) as [a maj]. - apply (BoundFromZero qn k (Pos.max A a)). - intros n H0. destruct (Nat.le_gt_cases n k). - + pose proof (Nat.le_antisymm n k H1 H0). subst k. - apply (Qlt_le_trans _ (Z.pos a # 1)). apply maj. - unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. - apply Pos.le_max_r. - + apply (Qlt_le_trans _ (Z.pos A # 1)). apply H. - apply H1. unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. - apply Pos.le_max_l. -Qed. - -Lemma QCauchySeq_bounded (qn : nat -> Q) (cvmod : positive -> nat) - : QCauchySeq qn cvmod - -> { A : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos A # 1) }. -Proof. - intros. remember (Zplus (Qnum (Qabs (qn (cvmod xH)))) 1) as z. - assert (Z.lt 0 z) as zPos. - { subst z. assert (Qle 0 (Qabs (qn (cvmod 1%positive)))). - apply Qabs_nonneg. destruct (Qabs (qn (cvmod 1%positive))). simpl. - unfold Qle in H0. simpl in H0. rewrite Zmult_1_r in H0. - apply (Z.lt_le_trans 0 1). unfold Z.lt. auto. - rewrite <- (Zplus_0_l 1). rewrite Zplus_assoc. apply Zplus_le_compat_r. - rewrite Zplus_0_r. assumption. } - assert { A : positive | forall n:nat, - le (cvmod xH) n -> Qlt ((Qabs (qn n)) * (1#A)) 1 }. - destruct z eqn:des. - - exfalso. apply (Z.lt_irrefl 0). assumption. - - exists p. intros. specialize (H xH (cvmod xH) n (le_refl _) H0). - assert (Qlt (Qabs (qn n)) (Qabs (qn (cvmod 1%positive)) + 1)). - { apply (Qplus_lt_l _ _ (-Qabs (qn (cvmod 1%positive)))). - rewrite <- (Qplus_comm 1). rewrite <- Qplus_assoc. rewrite Qplus_opp_r. - rewrite Qplus_0_r. apply (Qle_lt_trans _ (Qabs (qn n - qn (cvmod 1%positive)))). - apply Qabs_triangle_reverse. rewrite Qabs_Qminus. assumption. } - apply (Qlt_le_trans _ ((Qabs (qn (cvmod 1%positive)) + 1) * (1#p))). - apply Qmult_lt_r. unfold Qlt. simpl. unfold Z.lt. auto. assumption. - unfold Qle. simpl. rewrite Zmult_1_r. rewrite Zmult_1_r. rewrite Zmult_1_r. - rewrite Pos.mul_1_r. rewrite Pos2Z.inj_mul. rewrite Heqz. - destruct (Qabs (qn (cvmod 1%positive))) eqn:desAbs. - rewrite Z.mul_add_distr_l. rewrite Zmult_1_r. - apply Zplus_le_compat_r. rewrite <- (Zmult_1_l (QArith_base.Qnum (Qnum # Qden))). - rewrite Zmult_assoc. apply Zmult_le_compat_r. rewrite Zmult_1_r. - simpl. unfold Z.le. rewrite <- Pos2Z.inj_compare. - unfold Pos.compare. destruct Qden; discriminate. - simpl. assert (Qle 0 (Qnum # Qden)). rewrite <- desAbs. - apply Qabs_nonneg. unfold Qle in H2. simpl in H2. rewrite Zmult_1_r in H2. - assumption. - - exfalso. inversion zPos. - - destruct H0. apply (BoundFromZero _ (cvmod xH) x). intros n H0. - specialize (q n H0). setoid_replace (Z.pos x # 1)%Q with (/(1#x))%Q. - rewrite <- (Qmult_1_l (/(1#x))). apply Qlt_shift_div_l. - reflexivity. apply q. reflexivity. -Qed. - -Lemma CReal_mult_cauchy - : forall (xn yn zn : nat -> Q) (Ay Az : positive) (cvmod : positive -> nat), - QSeqEquiv xn yn cvmod - -> QCauchySeq zn Pos.to_nat - -> (forall n:nat, Qlt (Qabs (yn n)) (Z.pos Ay # 1)) - -> (forall n:nat, Qlt (Qabs (zn n)) (Z.pos Az # 1)) - -> QSeqEquiv (fun n:nat => xn n * zn n) (fun n:nat => yn n * zn n) - (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) - (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). -Proof. - intros xn yn zn Ay Az cvmod limx limz majy majz. - remember (Pos.mul 2 (Pos.max Ay Az)) as z. - intros k p q H H0. - assert (Pos.to_nat k <> O) as kPos. - { intro absurd. pose proof (Pos2Nat.is_pos k). - rewrite absurd in H1. inversion H1. } - setoid_replace (xn p * zn p - yn q * zn q)%Q - with ((xn p - yn q) * zn p + yn q * (zn p - zn q))%Q. - 2: ring. - apply (Qle_lt_trans _ (Qabs ((xn p - yn q) * zn p) - + Qabs (yn q * (zn p - zn q)))). - apply Qabs_triangle. rewrite Qabs_Qmult. rewrite Qabs_Qmult. - setoid_replace (1#k)%Q with ((1#2*k) + (1#2*k))%Q. - apply Qplus_lt_le_compat. - - apply (Qle_lt_trans _ ((1#z * k) * Qabs (zn p)%nat)). - + apply Qmult_le_compat_r. apply Qle_lteq. left. apply limx. - apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). - apply Nat.le_max_l. assumption. - apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). - apply Nat.le_max_l. assumption. apply Qabs_nonneg. - + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). - rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. - rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. - apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. - apply (Qle_lt_trans _ (Qabs (zn p)%nat * (1 # Az))). - rewrite <- (Qmult_comm (1 # Az)). apply Qmult_le_compat_r. - unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_r. - apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Az)). - rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. - setoid_replace (/(1#Az))%Q with (Z.pos Az # 1)%Q. apply majz. - reflexivity. intro abs. inversion abs. - - apply (Qle_trans _ ((1 # z * k) * Qabs (yn q)%nat)). - + rewrite Qmult_comm. apply Qmult_le_compat_r. apply Qle_lteq. - left. apply limz. - apply (le_trans _ (max (cvmod (z * k)%positive) - (Pos.to_nat (z * k)%positive))). - apply Nat.le_max_r. assumption. - apply (le_trans _ (max (cvmod (z * k)%positive) - (Pos.to_nat (z * k)%positive))). - apply Nat.le_max_r. assumption. apply Qabs_nonneg. - + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). - rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. - rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. - apply Qle_lteq. left. - apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. - apply (Qle_lt_trans _ (Qabs (yn q)%nat * (1 # Ay))). - rewrite <- (Qmult_comm (1 # Ay)). apply Qmult_le_compat_r. - unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_l. - apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Ay)). - rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. - setoid_replace (/(1#Ay))%Q with (Z.pos Ay # 1)%Q. apply majy. - reflexivity. intro abs. inversion abs. - - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. -Qed. - -Lemma linear_max : forall (p Ax Ay : positive) (i : nat), - le (Pos.to_nat p) i - -> (Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) - (Pos.to_nat (2 * Pos.max Ax Ay * p)) <= Pos.to_nat (2 * Pos.max Ax Ay) * i)%nat. -Proof. - intros. rewrite max_l. 2: apply le_refl. - rewrite Pos2Nat.inj_mul. apply Nat.mul_le_mono_nonneg. - apply le_0_n. apply le_refl. apply le_0_n. apply H. -Qed. - -Definition CReal_mult (x y : CReal) : CReal. -Proof. - destruct x as [xn limx]. destruct y as [yn limy]. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). - exists (fun n : nat => xn (Pos.to_nat (2 * Pos.max Ax Ay)* n)%nat - * yn (Pos.to_nat (2 * Pos.max Ax Ay) * n)%nat). - intros p n k H0 H1. - apply H; apply linear_max; assumption. -Defined. - -Infix "*" := CReal_mult : CReal_scope. - -Lemma CReal_mult_unfold : forall x y : CReal, - QSeqEquivEx (proj1_sig (CReal_mult x y)) - (fun n : nat => proj1_sig x n * proj1_sig y n)%Q. -Proof. - intros [xn limx] [yn limy]. unfold CReal_mult ; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - simpl. - pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). - exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) - (Pos.to_nat (2 * Pos.max Ax Ay * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - apply H. apply linear_max. - apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). - rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. - apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. - apply le_0_n. apply le_refl. apply H0. rewrite max_l. - apply H1. apply le_refl. -Qed. - -Lemma CReal_mult_assoc_bounded_r : forall (xn yn zn : nat -> Q), - QSeqEquivEx xn yn (* both are Cauchy with same limit *) - -> QSeqEquiv zn zn Pos.to_nat - -> QSeqEquivEx (fun n => xn n * zn n)%Q (fun n => yn n * zn n)%Q. -Proof. - intros. destruct H as [cvmod cveq]. - destruct (QCauchySeq_bounded yn (fun k => cvmod (2 * k)%positive) - (QSeqEquiv_cau_r xn yn cvmod cveq)) - as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat H0) as [Az majz]. - exists (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) - (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). - apply CReal_mult_cauchy; assumption. -Qed. - -Lemma CReal_mult_assoc : forall x y z : CReal, - CRealEq (CReal_mult (CReal_mult x y) z) - (CReal_mult x (CReal_mult y z)). -Proof. - intros. apply CRealEq_diff. apply CRealEq_modindep. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n * proj1_sig z n)%Q). - - apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n * proj1_sig z n)%Q). - apply CReal_mult_unfold. - destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - apply CReal_mult_assoc_bounded_r. 2: apply limz. - simpl. - pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). - exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) - (Pos.to_nat (2 * Pos.max Ax Ay * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - apply H. apply linear_max. - apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). - rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. - apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. - apply le_0_n. apply le_refl. apply H0. rewrite max_l. - apply H1. apply le_refl. - - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig (CReal_mult y z) n)%Q). - 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. - destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - simpl. - pose proof (CReal_mult_assoc_bounded_r (fun n0 : nat => yn n0 * zn n0)%Q (fun n : nat => - yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat - * zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat)%Q xn) - as [cvmod cveq]. - - pose proof (CReal_mult_cauchy yn yn zn Ay Az Pos.to_nat limy limz majy majz). - exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Az * p)) - (Pos.to_nat (2 * Pos.max Ay Az * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - apply H. rewrite max_l. apply H0. apply le_refl. - apply linear_max. - apply (le_trans _ (Pos.to_nat (2 * Pos.max Ay Az * p))). - rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. - apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. - apply le_0_n. apply le_refl. apply H1. - apply limx. - exists cvmod. intros p k n H1 H2. specialize (cveq p k n H1 H2). - setoid_replace (xn k * yn k * zn k - - xn n * - (yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * - zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat))%Q - with ((fun n : nat => yn n * zn n * xn n) k - - (fun n : nat => - yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * - zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * - xn n) n)%Q. - apply cveq. ring. -Qed. - -Lemma CReal_mult_comm : forall x y : CReal, - CRealEq (CReal_mult x y) (CReal_mult y x). -Proof. - intros. apply CRealEq_diff. apply CRealEq_modindep. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig y n * proj1_sig x n)%Q). - destruct x as [xn limx], y as [yn limy]; simpl. - 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]; simpl. - apply QSeqEquivEx_sym. - - pose proof (CReal_mult_cauchy yn yn xn Ay Ax Pos.to_nat limy limx majy majx). - exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Ax * p)) - (Pos.to_nat (2 * Pos.max Ay Ax * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - rewrite (Qmult_comm (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)). - apply (H p n). rewrite max_l. apply H0. apply le_refl. - rewrite max_l. apply (le_trans _ k). apply H1. - rewrite <- (mult_1_l k). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. - apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. - apply le_refl. -Qed. - -(* Axiom Rmult_eq_compat_l *) -Lemma CReal_mult_proper_l : forall x y z : CReal, - CRealEq y z -> CRealEq (CReal_mult x y) (CReal_mult x z). -Proof. - intros. apply CRealEq_diff. apply CRealEq_modindep. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n)%Q). - apply CReal_mult_unfold. - rewrite CRealEq_diff in H. rewrite <- CRealEq_modindep in H. - apply QSeqEquivEx_sym. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig z n)%Q). - apply CReal_mult_unfold. - destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. - destruct H. simpl in H. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - pose proof (CReal_mult_cauchy yn zn xn Az Ax x H limx majz majx). - apply QSeqEquivEx_sym. - exists (fun p : positive => - Init.Nat.max (x (2 * Pos.max Az Ax * p)%positive) - (Pos.to_nat (2 * Pos.max Az Ax * p))). - intros p n k H1 H2. specialize (H0 p n k H1 H2). - setoid_replace (xn n * yn n - xn k * zn k)%Q - with (yn n * xn n - zn k * xn k)%Q. - apply H0. ring. -Qed. - -Lemma CReal_mult_lt_0_compat : forall x y : CReal, - CRealLt (inject_Q 0) x - -> CRealLt (inject_Q 0) y - -> CRealLt (inject_Q 0) (CReal_mult x y). -Proof. - intros. destruct H as [x0 H], H0 as [x1 H0]. - pose proof (CRealLt_aboveSig (inject_Q 0) x x0 H). - pose proof (CRealLt_aboveSig (inject_Q 0) y x1 H0). - destruct x as [xn limx], y as [yn limy]. - simpl in H, H1, H2. simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (Qarchimedean (/ (xn (Pos.to_nat x0) - 0 - (2 # x0)))). - destruct (Qarchimedean (/ (yn (Pos.to_nat x1) - 0 - (2 # x1)))). - exists (Pos.max x0 x~0 * Pos.max x1 x2~0)%positive. - simpl. unfold Qminus. rewrite Qplus_0_r. - rewrite <- Pos2Nat.inj_mul. - unfold Qminus in H1, H2. - specialize (H1 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive). - assert (Pos.max x1 x2~0 <= (Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive. - { apply Pos2Nat.inj_le. - rewrite Pos.mul_assoc. rewrite Pos2Nat.inj_mul. - rewrite <- (mult_1_l (Pos.to_nat (Pos.max x1 x2~0))). - rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. - rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. - apply le_refl. } - specialize (H2 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive H3). - rewrite Qplus_0_r in H1, H2. - apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (2 # Pos.max x1 x2~0))). - unfold Qlt; simpl. assert (forall p : positive, (Z.pos p < Z.pos p~0)%Z). - intro p. rewrite <- (Z.mul_1_l (Z.pos p)). - replace (Z.pos p~0) with (2 * Z.pos p)%Z. apply Z.mul_lt_mono_pos_r. - apply Pos2Z.is_pos. reflexivity. reflexivity. - apply H4. - apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (yn (Pos.to_nat ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0)))))). - apply Qmult_lt_l. reflexivity. apply H2. apply Qmult_lt_r. - apply (Qlt_trans 0 (2 # Pos.max x1 x2~0)). reflexivity. apply H2. - apply H1. rewrite Pos.mul_comm. apply Pos2Nat.inj_le. - rewrite <- Pos.mul_assoc. rewrite Pos2Nat.inj_mul. - rewrite <- (mult_1_r (Pos.to_nat (Pos.max x0 x~0))). - rewrite <- mult_assoc. apply Nat.mul_le_mono_nonneg. - apply le_0_n. apply le_refl. auto. - rewrite mult_1_l. apply Pos2Nat.is_pos. -Qed. - -Lemma CReal_mult_plus_distr_l : forall r1 r2 r3 : CReal, - r1 * (r2 + r3) == (r1 * r2) + (r1 * r3). -Proof. - intros x y z. apply CRealEq_diff. apply CRealEq_modindep. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n - * (proj1_sig (CReal_plus y z) n))%Q). - apply CReal_mult_unfold. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n - + proj1_sig (CReal_mult x z) n))%Q. - 2: apply QSeqEquivEx_sym; exists (fun p => Pos.to_nat (2 * p)) - ; apply CReal_plus_unfold. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n - * (proj1_sig y n + proj1_sig z n))%Q). - - pose proof (CReal_plus_unfold y z). - destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl; simpl in H. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - pose proof (CReal_mult_cauchy (fun n => yn (n + (n + 0))%nat + zn (n + (n + 0))%nat)%Q - (fun n => yn n + zn n)%Q - xn (Ay + Az) Ax - (fun p => Pos.to_nat (2 * p)) H limx). - exists (fun p : positive => (Pos.to_nat (2 * (2 * Pos.max (Ay + Az) Ax * p)))). - intros p n k H1 H2. - setoid_replace (xn n * (yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) - xn k * (yn k + zn k))%Q - with ((yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) * xn n - (yn k + zn k) * xn k)%Q. - 2: ring. - assert (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p) <= - Pos.to_nat 2 * Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))%nat. - { rewrite (Pos2Nat.inj_mul 2). - rewrite <- (mult_1_l (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))). - rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. - simpl. auto. apply le_0_n. apply le_refl. } - apply H0. intro n0. apply (Qle_lt_trans _ (Qabs (yn n0) + Qabs (zn n0))). - apply Qabs_triangle. rewrite Pos2Z.inj_add. - rewrite <- Qinv_plus_distr. apply Qplus_lt_le_compat. - apply majy. apply Qlt_le_weak. apply majz. - apply majx. rewrite max_l. - apply H1. rewrite (Pos2Nat.inj_mul 2). apply H3. - rewrite max_l. apply H2. rewrite (Pos2Nat.inj_mul 2). - apply H3. - - destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - simpl. - exists (fun p : positive => (Pos.to_nat (2 * (Pos.max (Pos.max Ax Ay) Az) * (2 * p)))). - intros p n k H H0. - setoid_replace (xn n * (yn n + zn n) - - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * - yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat + - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * - zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q - with (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * - yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat) - + (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * - zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q. - 2: ring. - apply (Qle_lt_trans _ (Qabs (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * - yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)) - + Qabs (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * - zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))). - apply Qabs_triangle. - setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. - apply Qplus_lt_le_compat. - + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy). - apply H1. apply majx. apply majy. rewrite max_l. - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H. apply le_refl. - rewrite max_l. apply (le_trans _ k). - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H0. - rewrite <- (mult_1_l k). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. - rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. - apply le_refl. apply le_refl. - + apply Qlt_le_weak. - pose proof (CReal_mult_cauchy xn xn zn Ax Az Pos.to_nat limx limz). - apply H1. apply majx. apply majz. rewrite max_l. 2: apply le_refl. - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). - rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H. - rewrite max_l. apply (le_trans _ k). - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). - rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H0. - rewrite <- (mult_1_l k). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. - rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. - apply le_refl. apply le_refl. - + rewrite Qinv_plus_distr. unfold Qeq. reflexivity. -Qed. - -Lemma CReal_mult_plus_distr_r : forall r1 r2 r3 : CReal, - (r2 + r3) * r1 == (r2 * r1) + (r3 * r1). -Proof. - intros. - rewrite CReal_mult_comm, CReal_mult_plus_distr_l, - <- (CReal_mult_comm r1), <- (CReal_mult_comm r1). - reflexivity. -Qed. - -Lemma CReal_mult_1_l : forall r: CReal, 1 * r == r. -Proof. - intros [rn limr]. split. - - intros [m maj]. simpl in maj. - destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). - destruct (QCauchySeq_bounded rn Pos.to_nat limr). - simpl in maj. rewrite Qmult_1_l in maj. - specialize (limr m). - apply (Qlt_not_le (2 # m) (1 # m)). - apply (Qlt_trans _ (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat)). - apply maj. - apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat))). - apply Qle_Qabs. apply limr. apply le_refl. - rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. - apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. - apply Z.mul_le_mono_nonneg. discriminate. discriminate. - discriminate. apply Z.le_refl. - - intros [m maj]. simpl in maj. - destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). - destruct (QCauchySeq_bounded rn Pos.to_nat limr). - simpl in maj. rewrite Qmult_1_l in maj. - specialize (limr m). - apply (Qlt_not_le (2 # m) (1 # m)). - apply (Qlt_trans _ (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m))). - apply maj. - apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m)))). - apply Qle_Qabs. apply limr. - rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. - apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. - apply le_refl. apply Z.mul_le_mono_nonneg. discriminate. discriminate. - discriminate. apply Z.le_refl. -Qed. - -Lemma CReal_isRingExt : ring_eq_ext CReal_plus CReal_mult CReal_opp CRealEq. -Proof. - split. - - intros x y H z t H0. apply CReal_plus_morph; assumption. - - intros x y H z t H0. apply (CRealEq_trans _ (CReal_mult x t)). - apply CReal_mult_proper_l. apply H0. - apply (CRealEq_trans _ (CReal_mult t x)). apply CReal_mult_comm. - apply (CRealEq_trans _ (CReal_mult t y)). - apply CReal_mult_proper_l. apply H. apply CReal_mult_comm. - - intros x y H. apply (CReal_plus_eq_reg_l x). - apply (CRealEq_trans _ (inject_Q 0)). apply CReal_plus_opp_r. - apply (CRealEq_trans _ (CReal_plus y (CReal_opp y))). - apply CRealEq_sym. apply CReal_plus_opp_r. - apply CReal_plus_proper_r. apply CRealEq_sym. apply H. -Qed. - -Lemma CReal_isRing : ring_theory (inject_Q 0) (inject_Q 1) - CReal_plus CReal_mult - CReal_minus CReal_opp - CRealEq. -Proof. - intros. split. - - apply CReal_plus_0_l. - - apply CReal_plus_comm. - - intros x y z. symmetry. apply CReal_plus_assoc. - - apply CReal_mult_1_l. - - apply CReal_mult_comm. - - intros x y z. symmetry. apply CReal_mult_assoc. - - intros x y z. rewrite <- (CReal_mult_comm z). - rewrite CReal_mult_plus_distr_l. - apply (CRealEq_trans _ (CReal_plus (CReal_mult x z) (CReal_mult z y))). - apply CReal_plus_proper_r. apply CReal_mult_comm. - apply CReal_plus_proper_l. apply CReal_mult_comm. - - intros x y. apply CRealEq_refl. - - apply CReal_plus_opp_r. -Qed. - -Add Parametric Morphism : CReal_mult - with signature CRealEq ==> CRealEq ==> CRealEq - as CReal_mult_morph. -Proof. - apply CReal_isRingExt. -Qed. - -Instance CReal_mult_morph_T - : CMorphisms.Proper - (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_mult. -Proof. - apply CReal_isRingExt. -Qed. - -Add Parametric Morphism : CReal_opp - with signature CRealEq ==> CRealEq - as CReal_opp_morph. -Proof. - apply (Ropp_ext CReal_isRingExt). -Qed. - -Instance CReal_opp_morph_T - : CMorphisms.Proper - (CMorphisms.respectful CRealEq CRealEq) CReal_opp. -Proof. - apply CReal_isRingExt. -Qed. - -Add Parametric Morphism : CReal_minus - with signature CRealEq ==> CRealEq ==> CRealEq - as CReal_minus_morph. -Proof. - intros. unfold CReal_minus. rewrite H,H0. reflexivity. -Qed. - -Instance CReal_minus_morph_T - : CMorphisms.Proper - (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_minus. -Proof. - intros x y exy z t ezt. unfold CReal_minus. rewrite exy,ezt. reflexivity. -Qed. - -Add Ring CRealRing : CReal_isRing. - Lemma CReal_opp_0 : -0 == 0. Proof. - ring. + apply (CReal_plus_eq_reg_l 0). + rewrite CReal_plus_0_r, CReal_plus_opp_r. reflexivity. Qed. Lemma CReal_opp_plus_distr : forall r1 r2, - (r1 + r2) == - r1 + - r2. Proof. - intros; ring. + intros. apply (CReal_plus_eq_reg_l (r1+r2)). + rewrite CReal_plus_opp_r, (CReal_plus_comm (-r1)), CReal_plus_assoc. + rewrite <- (CReal_plus_assoc r2), CReal_plus_opp_r, CReal_plus_0_l. + rewrite CReal_plus_opp_r. reflexivity. Qed. Lemma CReal_opp_involutive : forall x:CReal, --x == x. Proof. - intro x. ring. + intros. apply (CReal_plus_eq_reg_l (-x)). + rewrite CReal_plus_opp_l, CReal_plus_opp_r. reflexivity. Qed. Lemma CReal_opp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. Proof. unfold CRealGt; intros. apply (CReal_plus_lt_reg_l (r2 + r1)). - setoid_replace (r2 + r1 + - r1) with r2 by ring. - setoid_replace (r2 + r1 + - r2) with r1 by ring. - exact H. -Qed. - -(**********) -Lemma CReal_mult_0_l : forall r, 0 * r == 0. -Proof. - intro; ring. -Qed. - -Lemma CReal_mult_0_r : forall r, r * 0 == 0. -Proof. - intro; ring. -Qed. - -(**********) -Lemma CReal_mult_1_r : forall r, r * 1 == r. -Proof. - intro; ring. -Qed. - -Lemma CReal_opp_mult_distr_l - : forall r1 r2 : CReal, CRealEq (CReal_opp (CReal_mult r1 r2)) - (CReal_mult (CReal_opp r1) r2). -Proof. - intros. ring. + rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r. + rewrite CReal_plus_comm, <- CReal_plus_assoc, CReal_plus_opp_l. + rewrite CReal_plus_0_l. exact H. Qed. -Lemma CReal_mult_lt_compat_l : forall x y z : CReal, - 0 < x -> y < z -> x*y < x*z. +Lemma CReal_opp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2. Proof. - intros. apply (CReal_plus_lt_reg_l - (CReal_opp (CReal_mult x y))). - rewrite CReal_plus_comm. pose proof CReal_plus_opp_r. - unfold CReal_minus in H1. rewrite H1. - rewrite CReal_mult_comm, CReal_opp_mult_distr_l, CReal_mult_comm. - rewrite <- CReal_mult_plus_distr_l. - apply CReal_mult_lt_0_compat. exact H. - apply (CReal_plus_lt_reg_l y). - rewrite CReal_plus_comm, CReal_plus_0_l. - rewrite <- CReal_plus_assoc, H1, CReal_plus_0_l. exact H0. + intros. intro abs. apply H. clear H. + apply (CReal_plus_lt_reg_r (-r1-r2)). + unfold CReal_minus. rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + rewrite (CReal_plus_comm (-r1)), <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + exact abs. Qed. -Lemma CReal_mult_lt_compat_r : forall x y z : CReal, - 0 < x -> y < z -> y*x < z*x. +Lemma inject_Q_plus : forall q r : Q, + inject_Q (q + r) == inject_Q q + inject_Q r. Proof. - intros. rewrite <- (CReal_mult_comm x), <- (CReal_mult_comm x). - apply (CReal_mult_lt_compat_l x); assumption. -Qed. - -Lemma CReal_mult_eq_reg_l : forall (r r1 r2 : CReal), - r # 0 - -> CRealEq (CReal_mult r r1) (CReal_mult r r2) - -> CRealEq r1 r2. -Proof. - intros. destruct H; split. - - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. - rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. - exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). - rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. - - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. - rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. - exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). - rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. - - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. - exact (CRealLt_irrefl _ abs). exact c. - - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. - exact (CRealLt_irrefl _ abs). exact c. -Qed. - - - -(*********************************************************) -(** * Field *) -(*********************************************************) - -(**********) -Fixpoint INR (n:nat) : CReal := - match n with - | O => 0 - | S O => 1 - | S n => INR n + 1 - end. -Arguments INR n%nat. - -(* compact representation for 2*p *) -Fixpoint IPR_2 (p:positive) : CReal := - match p with - | xH => 1 + 1 - | xO p => IPR_2 p + IPR_2 p - | xI p => (1 + IPR_2 p) + (1 + IPR_2 p) - end. - -Definition IPR (p:positive) : CReal := - match p with - | xH => 1 - | xO p => IPR_2 p - | xI p => 1 + IPR_2 p - end. -Arguments IPR p%positive : simpl never. - -(**********) -Definition IZR (z:Z) : CReal := - match z with - | Z0 => 0 - | Zpos n => IPR n - | Zneg n => - IPR n - end. -Arguments IZR z%Z : simpl never. - -Notation "2" := (IZR 2) : CReal_scope. - -(**********) -Lemma S_INR : forall n:nat, INR (S n) == INR n + 1. -Proof. - intro; destruct n. rewrite CReal_plus_0_l. reflexivity. reflexivity. -Qed. - -Lemma le_succ_r_T : forall n m : nat, (n <= S m)%nat -> {(n <= m)%nat} + {n = S m}. -Proof. - intros. destruct (le_lt_dec n m). left. exact l. - right. apply Nat.le_succ_r in H. destruct H. - exfalso. apply (le_not_lt n m); assumption. exact H. -Qed. - -Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m. -Proof. - induction m. - - intros. exfalso. inversion H. - - intros. unfold lt in H. apply le_S_n in H. destruct m. - assert (n = 0)%nat. - { inversion H. reflexivity. } - subst n. apply CRealLt_0_1. apply le_succ_r_T in H. destruct H. - rewrite S_INR. apply (CRealLt_trans _ (INR (S m) + 0)). - rewrite CReal_plus_comm, CReal_plus_0_l. apply IHm. - apply le_n_S. exact l. - apply CReal_plus_lt_compat_l. exact CRealLt_0_1. - subst n. rewrite (S_INR (S m)). rewrite <- (CReal_plus_0_l). - rewrite (CReal_plus_comm 0), CReal_plus_assoc. - apply CReal_plus_lt_compat_l. rewrite CReal_plus_0_l. - exact CRealLt_0_1. -Qed. - -(**********) -Lemma S_O_plus_INR : forall n:nat, INR (1 + n) == INR 1 + INR n. -Proof. - intros; destruct n. - - rewrite CReal_plus_comm, CReal_plus_0_l. reflexivity. - - rewrite CReal_plus_comm. reflexivity. -Qed. - -(**********) -Lemma plus_INR : forall n m:nat, INR (n + m) == INR n + INR m. -Proof. - intros n m; induction n as [| n Hrecn]. - - rewrite CReal_plus_0_l. reflexivity. - - replace (S n + m)%nat with (S (n + m)); auto with arith. - repeat rewrite S_INR. - rewrite Hrecn; ring. -Qed. - -(**********) -Lemma minus_INR : forall n m:nat, (m <= n)%nat -> INR (n - m) == INR n - INR m. -Proof. - intros n m le; pattern m, n; apply le_elim_rel. - intros. rewrite <- minus_n_O. unfold CReal_minus. - unfold INR. ring. - intros; repeat rewrite S_INR; simpl. - unfold CReal_minus. rewrite H0. ring. exact le. -Qed. - -(*********) -Lemma mult_INR : forall n m:nat, INR (n * m) == INR n * INR m. -Proof. - intros n m; induction n as [| n Hrecn]. - - rewrite CReal_mult_0_l. reflexivity. - - intros; repeat rewrite S_INR; simpl. - rewrite plus_INR. rewrite Hrecn; ring. -Qed. - -(**********) -Lemma IZN : forall n:Z, (0 <= n)%Z -> { m : nat | n = Z.of_nat m }. -Proof. - intros. exists (Z.to_nat n). rewrite Z2Nat.id. reflexivity. assumption. -Qed. - -Lemma INR_IPR : forall p, INR (Pos.to_nat p) == IPR p. -Proof. - assert (H: forall p, INR (Pos.to_nat p) + INR (Pos.to_nat p) == IPR_2 p). - { induction p as [p|p|]. - - unfold IPR_2; rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- IHp. - setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. - - unfold IPR_2; rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. - setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. - - reflexivity. } - intros [p|p|] ; unfold IPR. - rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H. - setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. - rewrite Pos2Nat.inj_xO, mult_INR, <- H. - setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. - easy. -Qed. - -(* This is stronger than Req to injectQ, because it - concerns all the rational sequence, not only its limit. *) -Lemma FinjectP2_CReal : forall (p:positive) (k:nat), - (proj1_sig (IPR_2 p) k == Z.pos p~0 # 1)%Q. -Proof. - induction p. - - intros. replace (IPR_2 p~1) with (1 + IPR_2 p + (1+ IPR_2 p)). - 2: reflexivity. do 2 rewrite CReal_plus_nth. rewrite IHp. - simpl. rewrite Pos2Z.inj_xO, (Pos2Z.inj_xO (p~1)), Pos2Z.inj_xI. - generalize (2*Z.pos p)%Z. intro z. - do 2 rewrite Qinv_plus_distr. apply f_equal2. - 2: reflexivity. unfold Qnum. ring. - - intros. replace (IPR_2 p~0) with (IPR_2 p + IPR_2 p). - 2: reflexivity. rewrite CReal_plus_nth, IHp. - rewrite Qinv_plus_distr. apply f_equal2. 2: reflexivity. - unfold Qnum. rewrite (Pos2Z.inj_xO (p~0)). ring. - - intros. reflexivity. -Qed. - -Lemma FinjectP_CReal : forall (p:positive) (k:nat), - (proj1_sig (IPR p) k == Z.pos p # 1)%Q. -Proof. - destruct p. - - intros. unfold IPR. - rewrite CReal_plus_nth, FinjectP2_CReal. unfold Qeq; simpl. - rewrite Pos.mul_1_r. reflexivity. - - intros. unfold IPR. rewrite FinjectP2_CReal. reflexivity. - - intros. reflexivity. -Qed. - -(* Inside this Cauchy real implementation, we can give - an instantaneous witness of this inequality, because - we know a priori that it will work. *) -Lemma IPR_pos : forall p:positive, 0 < IPR p. -Proof. - intro p. exists 3%positive. simpl. - rewrite FinjectP_CReal. apply (Qlt_le_trans _ 1). reflexivity. - unfold Qle; simpl. - rewrite <- (Zpos_max_1 (p*1*1)). apply Z.le_max_l. -Defined. - -Lemma IPR_double : forall p:positive, IPR (2*p) == 2 * IPR p. -Proof. - intro p. - destruct p; rewrite (CReal_mult_plus_distr_r _ 1 1), CReal_mult_1_l; reflexivity. -Qed. - -(**********) -Lemma INR_IZR_INZ : forall n:nat, INR n == IZR (Z.of_nat n). -Proof. - intros [|n]. - easy. - simpl Z.of_nat. unfold IZR. - now rewrite <- INR_IPR, SuccNat2Pos.id_succ. -Qed. - -Lemma plus_IZR_NEG_POS : - forall p q:positive, IZR (Zpos p + Zneg q) == IZR (Zpos p) + IZR (Zneg q). -Proof. - intros p q; simpl. rewrite Z.pos_sub_spec. - case Pos.compare_spec; intros H; unfold IZR. - subst. ring. - rewrite <- 3!INR_IPR, Pos2Nat.inj_sub. - rewrite minus_INR. - 2: (now apply lt_le_weak, Pos2Nat.inj_lt). - ring. - trivial. - rewrite <- 3!INR_IPR, Pos2Nat.inj_sub. - rewrite minus_INR. - 2: (now apply lt_le_weak, Pos2Nat.inj_lt). - ring. trivial. -Qed. - -Lemma plus_IPR : forall n m:positive, IPR (n + m) == IPR n + IPR m. -Proof. - intros. repeat rewrite <- INR_IPR. - rewrite Pos2Nat.inj_add. apply plus_INR. -Qed. - -(**********) -Lemma plus_IZR : forall n m:Z, IZR (n + m) == IZR n + IZR m. -Proof. - intro z; destruct z; intro t; destruct t; intros. - - rewrite CReal_plus_0_l. reflexivity. - - rewrite CReal_plus_0_l. rewrite Z.add_0_l. reflexivity. - - rewrite CReal_plus_0_l. reflexivity. - - rewrite CReal_plus_comm,CReal_plus_0_l. reflexivity. - - rewrite <- Pos2Z.inj_add. unfold IZR. apply plus_IPR. - - apply plus_IZR_NEG_POS. - - rewrite CReal_plus_comm,CReal_plus_0_l, Z.add_0_r. reflexivity. - - rewrite Z.add_comm; rewrite CReal_plus_comm; apply plus_IZR_NEG_POS. - - simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR. - ring. -Qed. - -Lemma mult_IPR : forall n m:positive, IPR (n * m) == IPR n * IPR m. -Proof. - intros. repeat rewrite <- INR_IPR. - rewrite Pos2Nat.inj_mul. apply mult_INR. -Qed. - -Lemma mult_IZR : forall n m:Z, IZR (n * m) == IZR n * IZR m. -Proof. - intros n m. destruct n. - - rewrite CReal_mult_0_l. rewrite Z.mul_0_l. reflexivity. - - destruct m. rewrite Z.mul_0_r, CReal_mult_0_r. reflexivity. - simpl; unfold IZR. apply mult_IPR. - simpl. unfold IZR. rewrite mult_IPR. ring. - - destruct m. rewrite Z.mul_0_r, CReal_mult_0_r. reflexivity. - simpl. unfold IZR. rewrite mult_IPR. ring. - simpl. unfold IZR. rewrite mult_IPR. ring. -Qed. - -Lemma opp_IZR : forall n:Z, IZR (- n) == - IZR n. -Proof. - intros [|z|z]; unfold IZR. rewrite CReal_opp_0. reflexivity. - reflexivity. rewrite CReal_opp_involutive. reflexivity. -Qed. - -Lemma minus_IZR : forall n m:Z, IZR (n - m) == IZR n - IZR m. -Proof. - intros; unfold Z.sub, CReal_minus. - rewrite <- opp_IZR. - apply plus_IZR. -Qed. - -Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m. -Proof. - assert (forall n:Z, Z.lt 0 n -> 0 < IZR n) as posCase. - { intros. destruct (IZN n). apply Z.lt_le_incl. apply H. - subst n. rewrite <- INR_IZR_INZ. apply (lt_INR 0). - apply Nat2Z.inj_lt. apply H. } - intros. apply (CReal_plus_lt_reg_r (-(IZR n))). - pose proof minus_IZR. unfold CReal_minus in H0. - repeat rewrite <- H0. unfold Zminus. - rewrite Z.add_opp_diag_r. apply posCase. - rewrite (Z.add_lt_mono_l _ _ n). ring_simplify. apply H. -Qed. - -Lemma Z_R_minus : forall n m:Z, IZR n - IZR m == IZR (n - m). -Proof. - intros z1 z2; unfold CReal_minus; unfold Z.sub. - rewrite plus_IZR, opp_IZR. reflexivity. -Qed. - -Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. -Proof. - intro z; case z; simpl; intros. - elim (CRealLt_irrefl _ H). - easy. exfalso. - apply (CRealLt_asym 0 (IZR (Z.neg p))). exact H. - apply (IZR_lt (Z.neg p) 0). reflexivity. -Qed. - -Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z. -Proof. - intros z1 z2 H; apply Z.lt_0_sub. - apply lt_0_IZR. - rewrite <- Z_R_minus. apply (CReal_plus_lt_reg_l (IZR z1)). - ring_simplify. exact H. -Qed. - -Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m. -Proof. - intros m n H. intro abs. apply (lt_IZR n m) in abs. omega. -Qed. - -Lemma CReal_iterate_one : forall (n : nat), - IZR (Z.of_nat n) == inject_Q (Z.of_nat n # 1). -Proof. - induction n. - - apply CRealEq_refl. - - replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z. - rewrite plus_IZR. - rewrite IHn. clear IHn. apply CRealEq_diff. intro k. simpl. - rewrite Z.mul_1_r. rewrite Z.mul_1_r. rewrite Z.mul_1_r. - rewrite Z.add_opp_diag_r. discriminate. - replace (S n) with (1 + n)%nat. 2: reflexivity. - rewrite (Nat2Z.inj_add 1 n). reflexivity. -Qed. - -(* The constant sequences of rationals are CRealEq to - the rational operations on the unity. *) -Lemma FinjectZ_CReal : forall z : Z, - IZR z == inject_Q (z # 1). -Proof. - intros. destruct z. - - apply CRealEq_refl. - - simpl. pose proof (CReal_iterate_one (Pos.to_nat p)). - rewrite positive_nat_Z in H. apply H. - - simpl. apply (CReal_plus_eq_reg_l (IZR (Z.pos p))). - pose proof CReal_plus_opp_r. rewrite H. - pose proof (CReal_iterate_one (Pos.to_nat p)). - rewrite positive_nat_Z in H0. rewrite H0. - apply CRealEq_diff. intro n. simpl. rewrite Z.pos_sub_diag. - discriminate. -Qed. - - -(* Axiom Rarchimed_constr *) -Lemma Rarchimedean - : forall x:CReal, - { n:Z & x < IZR n < x+2 }. -Proof. - (* Locate x within 1/4 and pick the first integer above this interval. *) - intros [xn limx]. - pose proof (Qlt_floor (xn 4%nat + (1#4))). unfold inject_Z in H. - pose proof (Qfloor_le (xn 4%nat + (1#4))). unfold inject_Z in H0. - remember (Qfloor (xn 4%nat + (1#4)))%Z as n. - exists (n+1)%Z. split. - - rewrite FinjectZ_CReal. - assert (Qlt 0 ((n + 1 # 1) - (xn 4%nat + (1 # 4)))) as epsPos. - { unfold Qminus. rewrite <- Qlt_minus_iff. exact H. } - destruct (Qarchimedean (/((1#2)*((n + 1 # 1) - (xn 4%nat + (1 # 4)))))) as [k kmaj]. - exists (Pos.max 4 k). simpl. - apply (Qlt_trans _ ((n + 1 # 1) - (xn 4%nat + (1 # 4)))). - + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. - rewrite <- Qinv_lt_contravar in kmaj. 2: reflexivity. - apply (Qle_lt_trans _ (2#k)). - rewrite <- (Qmult_le_l _ _ (1#2)). - setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. 2: reflexivity. - setoid_replace ((1 # 2) * (2 # Pos.max 4 k))%Q with (1#Pos.max 4 k)%Q. 2: reflexivity. - unfold Qle; simpl. apply Pos2Z.pos_le_pos. apply Pos.le_max_r. - reflexivity. - rewrite <- (Qmult_lt_l _ _ (1#2)). - setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. exact kmaj. - reflexivity. reflexivity. rewrite <- (Qmult_0_r (1#2)). - rewrite Qmult_lt_l. exact epsPos. reflexivity. - + rewrite <- (Qplus_lt_r _ _ (xn (Pos.to_nat (Pos.max 4 k)) - (n + 1 # 1) + (1#4))). - ring_simplify. - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max 4 k)) - xn 4%nat))). - apply Qle_Qabs. apply limx. - rewrite Pos2Nat.inj_max. apply Nat.le_max_l. apply le_refl. - - apply (CReal_plus_lt_reg_l (-IZR 2)). ring_simplify. - do 2 rewrite FinjectZ_CReal. - exists 4%positive. simpl. - rewrite <- Qinv_plus_distr. - rewrite <- (Qplus_lt_r _ _ ((n#1) - (1#2))). ring_simplify. - apply (Qle_lt_trans _ (xn 4%nat + (1 # 4)) _ H0). - unfold Pos.to_nat; simpl. - rewrite <- (Qplus_lt_r _ _ (-xn 4%nat)). ring_simplify. - reflexivity. -Qed. - -Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal, - (CRealLtProp a b \/ CRealLtProp c d) -> CRealLt a b + CRealLt c d. -Proof. - intros. - assert (exists n : nat, n <> O /\ - (Qlt (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n) - \/ Qlt (2 # Pos.of_nat n) (proj1_sig d n - proj1_sig c n))). - { destruct H. destruct H as [n maj]. exists (Pos.to_nat n). split. - intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. - inversion abs. left. rewrite Pos2Nat.id. apply maj. - destruct H as [n maj]. exists (Pos.to_nat n). split. - intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. - inversion abs. right. rewrite Pos2Nat.id. apply maj. } - apply constructive_indefinite_ground_description_nat in H0. - - destruct H0 as [n [nPos maj]]. - destruct (Qlt_le_dec (2 # Pos.of_nat n) - (proj1_sig b n - proj1_sig a n)). - left. exists (Pos.of_nat n). rewrite Nat2Pos.id. apply q. apply nPos. - assert (2 # Pos.of_nat n < proj1_sig d n - proj1_sig c n)%Q. - destruct maj. exfalso. - apply (Qlt_not_le (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n)); assumption. - assumption. clear maj. right. exists (Pos.of_nat n). rewrite Nat2Pos.id. - apply H0. apply nPos. - - clear H0. clear H. intro n. destruct n. right. - intros [abs _]. exact (abs (eq_refl O)). - destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig b (S n) - proj1_sig a (S n))). - left. split. discriminate. left. apply q. - destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig d (S n) - proj1_sig c (S n))). - left. split. discriminate. right. apply q0. - right. intros [_ [abs|abs]]. - apply (Qlt_not_le (2 # Pos.of_nat (S n)) - (proj1_sig b (S n) - proj1_sig a (S n))); assumption. - apply (Qlt_not_le (2 # Pos.of_nat (S n)) - (proj1_sig d (S n) - proj1_sig c (S n))); assumption. -Qed. - -Lemma CRealShiftReal : forall (x : CReal) (k : nat), - QCauchySeq (fun n => proj1_sig x (plus n k)) Pos.to_nat. -Proof. - intros x k n p q H H0. - destruct x as [xn cau]; unfold proj1_sig. - destruct k. rewrite plus_0_r. rewrite plus_0_r. apply cau; assumption. - specialize (cau (n + Pos.of_nat (S k))%positive (p + S k)%nat (q + S k)%nat). - apply (Qlt_trans _ (1 # n + Pos.of_nat (S k))). - apply cau. rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. - apply Nat.add_le_mono_r. apply H. discriminate. - rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. - apply Nat.add_le_mono_r. apply H0. discriminate. - apply Pos2Nat.inj_lt; simpl. rewrite Pos2Nat.inj_add. - rewrite <- (plus_0_r (Pos.to_nat n)). rewrite <- plus_assoc. - apply Nat.add_lt_mono_l. apply Pos2Nat.is_pos. -Qed. - -Lemma CRealShiftEqual : forall (x : CReal) (k : nat), - CRealEq x (exist _ (fun n => proj1_sig x (plus n k)) (CRealShiftReal x k)). -Proof. - intros. split. - - intros [n maj]. destruct x as [xn cau]; simpl in maj. - specialize (cau n (Pos.to_nat n + k)%nat (Pos.to_nat n)). - apply Qlt_not_le in maj. apply maj. clear maj. - apply (Qle_trans _ (Qabs (xn (Pos.to_nat n + k)%nat - xn (Pos.to_nat n)))). - apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. - apply cau. rewrite <- (plus_0_r (Pos.to_nat n)). - rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. - apply le_refl. apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. - discriminate. - - intros [n maj]. destruct x as [xn cau]; simpl in maj. - specialize (cau n (Pos.to_nat n) (Pos.to_nat n + k)%nat). - apply Qlt_not_le in maj. apply maj. clear maj. - apply (Qle_trans _ (Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat n + k)%nat))). - apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. - apply cau. apply le_refl. rewrite <- (plus_0_r (Pos.to_nat n)). - rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. - apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. discriminate. -Qed. - -(* Find an equal negative real number, which rational sequence - stays below 0, so that it can be inversed. *) -Definition CRealNegShift (x : CReal) - : CRealLt x (inject_Q 0) - -> { y : prod positive CReal | CRealEq x (snd y) - /\ forall n:nat, Qlt (proj1_sig (snd y) n) (-1 # fst y) }. -Proof. - intro xNeg. - pose proof (CRealLt_aboveSig x (inject_Q 0)). - pose proof (CRealShiftReal x). - pose proof (CRealShiftEqual x). - destruct xNeg as [n maj], x as [xn cau]; simpl in maj. - specialize (H n maj); simpl in H. - destruct (Qarchimedean (/ (0 - xn (Pos.to_nat n) - (2 # n)))) as [a _]. - remember (Pos.max n a~0) as k. - clear Heqk. clear maj. clear n. - exists (pair k - (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). - split. apply H1. intro n. simpl. apply Qlt_minus_iff. - destruct n. - - specialize (H k). - unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. - unfold Qminus. rewrite Qplus_comm. - apply (Qlt_trans _ (- xn (Pos.to_nat k)%nat - (2 #k))). apply H. - unfold Qminus. simpl. apply Qplus_lt_r. - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. apply Pos.le_refl. - - apply (Qlt_trans _ (-(2 # k) - xn (S n + Pos.to_nat k)%nat)). - rewrite <- (Nat2Pos.id (S n)). rewrite <- Pos2Nat.inj_add. - specialize (H (Pos.of_nat (S n) + k)%positive). - unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. - unfold Qminus. rewrite Qplus_comm. apply H. apply Pos2Nat.inj_le. - rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. - apply Nat.add_le_mono_r. apply le_0_n. discriminate. - apply Qplus_lt_l. - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. -Qed. - -Definition CRealPosShift (x : CReal) - : CRealLt (inject_Q 0) x - -> { y : prod positive CReal | CRealEq x (snd y) - /\ forall n:nat, Qlt (1 # fst y) (proj1_sig (snd y) n) }. -Proof. - intro xPos. - pose proof (CRealLt_aboveSig (inject_Q 0) x). - pose proof (CRealShiftReal x). - pose proof (CRealShiftEqual x). - destruct xPos as [n maj], x as [xn cau]; simpl in maj. - simpl in H. specialize (H n). - destruct (Qarchimedean (/ (xn (Pos.to_nat n) - 0 - (2 # n)))) as [a _]. - specialize (H maj); simpl in H. - remember (Pos.max n a~0) as k. - clear Heqk. clear maj. clear n. - exists (pair k - (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). - split. apply H1. intro n. simpl. apply Qlt_minus_iff. - destruct n. - - specialize (H k). - unfold Qminus in H. rewrite Qplus_0_r in H. - simpl. rewrite <- Qlt_minus_iff. - apply (Qlt_trans _ (2 #k)). - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. apply H. apply Pos.le_refl. - - rewrite <- Qlt_minus_iff. apply (Qlt_trans _ (2 # k)). - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. specialize (H (Pos.of_nat (S n) + k)%positive). - unfold Qminus in H. rewrite Qplus_0_r in H. - rewrite Pos2Nat.inj_add in H. rewrite Nat2Pos.id in H. - apply H. apply Pos2Nat.inj_le. - rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. - apply Nat.add_le_mono_r. apply le_0_n. discriminate. -Qed. - -Lemma CReal_inv_neg : forall (yn : nat -> Q) (k : positive), - (QCauchySeq yn Pos.to_nat) - -> (forall n : nat, yn n < -1 # k)%Q - -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. -Proof. - (* Prove the inverse sequence is Cauchy *) - intros yn k cau maj n p q H0 H1. - setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - - / yn (Pos.to_nat k ^ 2 * q)%nat)%Q - with ((yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) - / (yn (Pos.to_nat k ^ 2 * q)%nat * - yn (Pos.to_nat k ^ 2 * p)%nat)). - + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) - / (1 # (k^2)))). - assert (1 # k ^ 2 - < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. - { rewrite Qabs_Qmult. unfold "^"%positive; simpl. - rewrite factorDenom. rewrite Pos.mul_1_r. - apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). - apply Qmult_lt_l. reflexivity. rewrite Qabs_neg. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). - apply Qlt_minus_iff in maj. apply Qlt_minus_iff. - rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. - reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. - apply maj. discriminate. - apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. - rewrite Qabs_neg. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). - apply Qlt_minus_iff in maj. apply Qlt_minus_iff. - rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. - reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. - apply maj. discriminate. - rewrite Qabs_neg. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). - apply Qlt_minus_iff in maj. apply Qlt_minus_iff. - rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. - reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. - apply maj. discriminate. } - unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. - rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). - apply Qmult_le_compat_r. apply Qlt_le_weak. - rewrite <- Qmult_1_l. apply Qlt_shift_div_r. - apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. - rewrite Qmult_comm. apply Qlt_shift_div_l. - reflexivity. rewrite Qmult_1_l. apply H. - apply Qabs_nonneg. simpl in maj. - specialize (cau (n * (k^2))%positive - (Pos.to_nat k ^ 2 * q)%nat - (Pos.to_nat k ^ 2 * p)%nat). - apply Qlt_shift_div_r. reflexivity. - apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. - rewrite factorDenom. apply Qle_refl. - + field. split. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * p)%nat). - rewrite abs in maj. inversion maj. - intro abs. - specialize (maj (Pos.to_nat k ^ 2 * q)%nat). - rewrite abs in maj. inversion maj. -Qed. - -Lemma CReal_inv_pos : forall (yn : nat -> Q) (k : positive), - (QCauchySeq yn Pos.to_nat) - -> (forall n : nat, 1 # k < yn n)%Q - -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. -Proof. - intros yn k cau maj n p q H0 H1. - setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - - / yn (Pos.to_nat k ^ 2 * q)%nat)%Q - with ((yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) - / (yn (Pos.to_nat k ^ 2 * q)%nat * - yn (Pos.to_nat k ^ 2 * p)%nat)). - + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) - / (1 # (k^2)))). - assert (1 # k ^ 2 - < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. - { rewrite Qabs_Qmult. unfold "^"%positive; simpl. - rewrite factorDenom. rewrite Pos.mul_1_r. - apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). - apply Qmult_lt_l. reflexivity. rewrite Qabs_pos. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). - apply maj. apply (Qle_trans _ (1 # k)). - discriminate. apply Zlt_le_weak. apply maj. - apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. - rewrite Qabs_pos. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). - apply maj. apply (Qle_trans _ (1 # k)). discriminate. - apply Zlt_le_weak. apply maj. - rewrite Qabs_pos. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). - apply maj. apply (Qle_trans _ (1 # k)). discriminate. - apply Zlt_le_weak. apply maj. } - unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. - rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). - apply Qmult_le_compat_r. apply Qlt_le_weak. - rewrite <- Qmult_1_l. apply Qlt_shift_div_r. - apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. - rewrite Qmult_comm. apply Qlt_shift_div_l. - reflexivity. rewrite Qmult_1_l. apply H. - apply Qabs_nonneg. simpl in maj. - specialize (cau (n * (k^2))%positive - (Pos.to_nat k ^ 2 * q)%nat - (Pos.to_nat k ^ 2 * p)%nat). - apply Qlt_shift_div_r. reflexivity. - apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. - rewrite factorDenom. apply Qle_refl. - + field. split. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * p)%nat). - rewrite abs in maj. inversion maj. - intro abs. - specialize (maj (Pos.to_nat k ^ 2 * q)%nat). - rewrite abs in maj. inversion maj. -Qed. - -Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal. -Proof. - destruct xnz as [xNeg | xPos]. - - destruct (CRealNegShift x xNeg) as [[k y] [_ maj]]. - destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. - exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). - apply (CReal_inv_neg yn). apply cau. apply maj. - - destruct (CRealPosShift x xPos) as [[k y] [_ maj]]. - destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. - exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). - apply (CReal_inv_pos yn). apply cau. apply maj. -Defined. - -Notation "/ x" := (CReal_inv x) (at level 35, right associativity) : CReal_scope. - -Lemma CReal_inv_0_lt_compat - : forall (r : CReal) (rnz : r # 0), - 0 < r -> 0 < ((/ r) rnz). -Proof. - intros. unfold CReal_inv. simpl. - destruct rnz. - - exfalso. apply CRealLt_asym in H. contradiction. - - destruct (CRealPosShift r c) as [[k rpos] [req maj]]. - clear req. destruct rpos as [rn cau]; simpl in maj. - unfold CRealLt; simpl. - destruct (Qarchimedean (rn 1%nat)) as [A majA]. - exists (2 * (A + 1))%positive. unfold Qminus. rewrite Qplus_0_r. - rewrite <- (Qmult_1_l (Qinv (rn (Pos.to_nat k * (Pos.to_nat k * 1) * Pos.to_nat (2 * (A + 1)))%nat))). - apply Qlt_shift_div_l. apply (Qlt_trans 0 (1#k)). reflexivity. - apply maj. rewrite <- (Qmult_inv_r (Z.pos A + 1 # 1)). - setoid_replace (2 # 2 * (A + 1))%Q with (Qinv (Z.pos A + 1 # 1)). - 2: reflexivity. - rewrite Qmult_comm. apply Qmult_lt_r. reflexivity. - rewrite mult_1_r. rewrite <- Pos2Nat.inj_mul. rewrite <- Pos2Nat.inj_mul. - rewrite <- (Qplus_lt_l _ _ (- rn 1%nat)). - apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (k * k * (2 * (A + 1)))) + - rn 1%nat))). - apply Qle_Qabs. apply (Qlt_le_trans _ 1). apply cau. - apply Pos2Nat.is_pos. apply le_refl. - rewrite <- Qinv_plus_distr. rewrite <- (Qplus_comm 1). - rewrite <- Qplus_0_r. rewrite <- Qplus_assoc. rewrite <- Qplus_assoc. - rewrite Qplus_le_r. rewrite Qplus_0_l. apply Qlt_le_weak. - apply Qlt_minus_iff in majA. apply majA. - intro abs. inversion abs. -Qed. - -Lemma CReal_linear_shift : forall (x : CReal) (k : nat), - le 1 k -> QCauchySeq (fun n => proj1_sig x (k * n)%nat) Pos.to_nat. -Proof. - intros [xn limx] k lek p n m H H0. unfold proj1_sig. - apply limx. apply (le_trans _ n). apply H. - rewrite <- (mult_1_l n). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg_r. apply le_0_n. - rewrite mult_1_r. apply lek. apply (le_trans _ m). apply H0. - rewrite <- (mult_1_l m). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg_r. apply le_0_n. - rewrite mult_1_r. apply lek. -Qed. - -Lemma CReal_linear_shift_eq : forall (x : CReal) (k : nat) (kPos : le 1 k), - CRealEq x - (exist (fun n : nat -> Q => QCauchySeq n Pos.to_nat) - (fun n : nat => proj1_sig x (k * n)%nat) (CReal_linear_shift x k kPos)). -Proof. - intros. apply CRealEq_diff. intro n. - destruct x as [xn limx]; unfold proj1_sig. - specialize (limx n (Pos.to_nat n) (k * Pos.to_nat n)%nat). - apply (Qle_trans _ (1 # n)). apply Qlt_le_weak. apply limx. - apply le_refl. rewrite <- (mult_1_l (Pos.to_nat n)). - rewrite mult_assoc. apply Nat.mul_le_mono_nonneg_r. apply le_0_n. - rewrite mult_1_r. apply kPos. apply Z.mul_le_mono_nonneg_r. - discriminate. discriminate. -Qed. - -Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0), - ((/ r) rnz) * r == 1. -Proof. - intros. unfold CReal_inv; simpl. - destruct rnz. - - (* r < 0 *) destruct (CRealNegShift r c) as [[k rneg] [req maj]]. - simpl in req. apply CRealEq_diff. apply CRealEq_modindep. - apply (QSeqEquivEx_trans _ - (proj1_sig (CReal_mult ((let - (yn, cau) as s - return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in - fun maj0 : forall n : nat, yn n < -1 # k => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n))%nat) - (CReal_inv_neg yn k cau maj0)) maj) rneg)))%Q. - + apply CRealEq_modindep. apply CRealEq_diff. - apply CReal_mult_proper_l. apply req. - + assert (le 1 (Pos.to_nat k * (Pos.to_nat k * 1))%nat). rewrite mult_1_r. - rewrite <- Pos2Nat.inj_mul. apply Pos2Nat.is_pos. - apply (QSeqEquivEx_trans _ - (proj1_sig (CReal_mult ((let - (yn, cau) as s - return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in - fun maj0 : forall n : nat, yn n < -1 # k => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) - (CReal_inv_neg yn k cau maj0)) maj) - (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. - apply CRealEq_modindep. apply CRealEq_diff. - apply CReal_mult_proper_l. apply CReal_linear_shift_eq. - destruct r as [rn limr], rneg as [rnn limneg]; simpl. - destruct (QCauchySeq_bounded - (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) - Pos.to_nat (CReal_inv_neg rnn k limneg maj)). - destruct (QCauchySeq_bounded - (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) - Pos.to_nat - (CReal_linear_shift - (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) - (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. - exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. - rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. - reflexivity. intro abs. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) - * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). - simpl in maj. rewrite abs in maj. inversion maj. - - (* r > 0 *) destruct (CRealPosShift r c) as [[k rneg] [req maj]]. - simpl in req. apply CRealEq_diff. apply CRealEq_modindep. - apply (QSeqEquivEx_trans _ - (proj1_sig (CReal_mult ((let - (yn, cau) as s - return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in - fun maj0 : forall n : nat, 1 # k < yn n => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) - (CReal_inv_pos yn k cau maj0)) maj) rneg)))%Q. - + apply CRealEq_modindep. apply CRealEq_diff. - apply CReal_mult_proper_l. apply req. - + assert (le 1 (Pos.to_nat k * (Pos.to_nat k * 1))%nat). rewrite mult_1_r. - rewrite <- Pos2Nat.inj_mul. apply Pos2Nat.is_pos. - apply (QSeqEquivEx_trans _ - (proj1_sig (CReal_mult ((let - (yn, cau) as s - return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in - fun maj0 : forall n : nat, 1 # k < yn n => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) - (CReal_inv_pos yn k cau maj0)) maj) - (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. - apply CRealEq_modindep. apply CRealEq_diff. - apply CReal_mult_proper_l. apply CReal_linear_shift_eq. - destruct r as [rn limr], rneg as [rnn limneg]; simpl. - destruct (QCauchySeq_bounded - (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) - Pos.to_nat (CReal_inv_pos rnn k limneg maj)). - destruct (QCauchySeq_bounded - (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) - Pos.to_nat - (CReal_linear_shift - (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) - (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. - exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. - rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. - reflexivity. intro abs. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) - * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). - simpl in maj. rewrite abs in maj. inversion maj. -Qed. - -Lemma CReal_inv_r : forall (r:CReal) (rnz : r # 0), - r * ((/ r) rnz) == 1. -Proof. - intros. rewrite CReal_mult_comm, CReal_inv_l. - reflexivity. -Qed. - -Lemma CReal_inv_1 : forall nz : 1 # 0, (/ 1) nz == 1. -Proof. - intros. rewrite <- (CReal_mult_1_l ((/1) nz)). rewrite CReal_inv_r. - reflexivity. -Qed. - -Lemma CReal_inv_mult_distr : - forall r1 r2 (r1nz : r1 # 0) (r2nz : r2 # 0) (rmnz : (r1*r2) # 0), - (/ (r1 * r2)) rmnz == (/ r1) r1nz * (/ r2) r2nz. -Proof. - intros. apply (CReal_mult_eq_reg_l r1). exact r1nz. - rewrite <- CReal_mult_assoc. rewrite CReal_inv_r. rewrite CReal_mult_1_l. - apply (CReal_mult_eq_reg_l r2). exact r2nz. - rewrite CReal_inv_r. rewrite <- CReal_mult_assoc. - rewrite (CReal_mult_comm r2 r1). rewrite CReal_inv_r. - reflexivity. -Qed. - -Lemma Rinv_eq_compat : forall x y (rxnz : x # 0) (rynz : y # 0), - x == y - -> (/ x) rxnz == (/ y) rynz. -Proof. - intros. apply (CReal_mult_eq_reg_l x). exact rxnz. - rewrite CReal_inv_r, H, CReal_inv_r. reflexivity. -Qed. - -Lemma CReal_mult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. -Proof. - intros z x y H H0. - apply (CReal_mult_lt_compat_l ((/z) (inr H))) in H0. - repeat rewrite <- CReal_mult_assoc in H0. rewrite CReal_inv_l in H0. - repeat rewrite CReal_mult_1_l in H0. apply H0. - apply CReal_inv_0_lt_compat. exact H. -Qed. - -Lemma CReal_mult_lt_reg_r : forall r r1 r2, 0 < r -> r1 * r < r2 * r -> r1 < r2. -Proof. - intros. - apply CReal_mult_lt_reg_l with r. - exact H. - now rewrite 2!(CReal_mult_comm r). -Qed. - -Lemma CReal_mult_eq_reg_r : forall r r1 r2, r1 * r == r2 * r -> r # 0 -> r1 == r2. -Proof. - intros. apply (CReal_mult_eq_reg_l r). exact H0. - now rewrite 2!(CReal_mult_comm r). -Qed. - -Lemma CReal_mult_eq_compat_l : forall r r1 r2, r1 == r2 -> r * r1 == r * r2. -Proof. - intros. rewrite H. reflexivity. -Qed. - -Lemma CReal_mult_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 * r == r2 * r. -Proof. - intros. rewrite H. reflexivity. -Qed. - -Fixpoint pow (r:CReal) (n:nat) : CReal := - match n with - | O => 1 - | S n => r * (pow r n) - end. - - -(**********) -Definition IQR (q:Q) : CReal := - match q with - | Qmake a b => IZR a * (CReal_inv (IPR b)) (inr (IPR_pos b)) - end. -Arguments IQR q%Q : simpl never. - -Lemma mult_IPR_IZR : forall (n:positive) (m:Z), IZR (Z.pos n * m) == IPR n * IZR m. -Proof. - intros. rewrite mult_IZR. apply CReal_mult_eq_compat_r. reflexivity. -Qed. - -Lemma plus_IQR : forall n m:Q, IQR (n + m) == IQR n + IQR m. -Proof. - intros. destruct n,m; unfold Qplus,IQR; simpl. - rewrite plus_IZR. repeat rewrite mult_IZR. - setoid_replace ((/ IPR (Qden * Qden0)) (inr (IPR_pos (Qden * Qden0)))) - with ((/ IPR Qden) (inr (IPR_pos Qden)) - * (/ IPR Qden0) (inr (IPR_pos Qden0))). - rewrite CReal_mult_plus_distr_r. - repeat rewrite CReal_mult_assoc. rewrite <- (CReal_mult_assoc (IZR (Z.pos Qden))). - rewrite CReal_inv_r, CReal_mult_1_l. - rewrite (CReal_mult_comm ((/IPR Qden) (inr (IPR_pos Qden)))). - rewrite <- (CReal_mult_assoc (IZR (Z.pos Qden0))). - rewrite CReal_inv_r, CReal_mult_1_l. reflexivity. unfold IZR. - rewrite <- (CReal_inv_mult_distr - _ _ _ _ (inr (CReal_mult_lt_0_compat _ _ (IPR_pos _) (IPR_pos _)))). - apply Rinv_eq_compat. apply mult_IPR. -Qed. - -Lemma IQR_pos : forall q:Q, Qlt 0 q -> 0 < IQR q. -Proof. - intros. destruct q; unfold IQR. - apply CReal_mult_lt_0_compat. apply (IZR_lt 0). - unfold Qlt in H; simpl in H. - rewrite Z.mul_1_r in H. apply H. - apply CReal_inv_0_lt_compat. apply IPR_pos. + split. + - intros [n nmaj]. simpl in nmaj. + ring_simplify in nmaj. discriminate. + - intros [n nmaj]. simpl in nmaj. + ring_simplify in nmaj. discriminate. Qed. -Lemma opp_IQR : forall q:Q, IQR (- q) == - IQR q. +Lemma inject_Q_one : inject_Q 1 == 1. Proof. - intros [a b]; unfold IQR; simpl. - rewrite CReal_opp_mult_distr_l. - rewrite opp_IZR. reflexivity. + split. + - intros [n nmaj]. simpl in nmaj. + ring_simplify in nmaj. discriminate. + - intros [n nmaj]. simpl in nmaj. + ring_simplify in nmaj. discriminate. Qed. -Lemma lt_IQR : forall n m:Q, IQR n < IQR m -> (n < m)%Q. +Lemma inject_Q_lt : forall q r : Q, + Qlt q r -> inject_Q q < inject_Q r. Proof. - intros. destruct n,m; unfold IQR in H. - unfold Qlt; simpl. apply (CReal_mult_lt_compat_r (IPR Qden)) in H. - rewrite CReal_mult_assoc in H. rewrite CReal_inv_l in H. - rewrite CReal_mult_1_r in H. rewrite (CReal_mult_comm (IZR Qnum0)) in H. - apply (CReal_mult_lt_compat_l (IPR Qden0)) in H. - do 2 rewrite <- CReal_mult_assoc in H. rewrite CReal_inv_r in H. - rewrite CReal_mult_1_l in H. - rewrite (CReal_mult_comm (IZR Qnum0)) in H. - do 2 rewrite <- mult_IPR_IZR in H. apply lt_IZR in H. - rewrite Z.mul_comm. rewrite (Z.mul_comm Qnum0). - apply H. apply IPR_pos. apply IPR_pos. + intros. destruct (Qarchimedean (/(r-q))). + exists (2*x)%positive; simpl. + setoid_replace (2 # x~0)%Q with (/(Z.pos x#1))%Q. 2: reflexivity. + apply Qlt_shift_inv_r. reflexivity. + apply (Qmult_lt_l _ _ (r-q)) in q0. rewrite Qmult_inv_r in q0. + exact q0. intro abs. rewrite Qlt_minus_iff in H. + unfold Qminus in abs. rewrite abs in H. discriminate H. + unfold Qminus. rewrite <- Qlt_minus_iff. exact H. Qed. -Lemma CReal_mult_le_compat_l_half : forall r r1 r2, - 0 < r -> r1 <= r2 -> r * r1 <= r * r2. +Lemma opp_inject_Q : forall q : Q, + inject_Q (-q) == - inject_Q q. Proof. - intros. intro abs. apply (CReal_mult_lt_reg_l) in abs. - contradiction. apply H. + split. + - intros [n maj]. simpl in maj. ring_simplify in maj. discriminate. + - intros [n maj]. simpl in maj. ring_simplify in maj. discriminate. Qed. -Lemma IQR_lt : forall n m:Q, Qlt n m -> IQR n < IQR m. +Lemma lt_inject_Q : forall q r : Q, + inject_Q q < inject_Q r -> Qlt q r. Proof. - intros. apply (CReal_plus_lt_reg_r (-IQR n)). - rewrite CReal_plus_opp_r. rewrite <- opp_IQR. rewrite <- plus_IQR. - apply IQR_pos. apply (Qplus_lt_l _ _ n). - ring_simplify. apply H. + intros. destruct H. simpl in q0. + apply Qlt_minus_iff, (Qlt_trans _ (2#x)). + reflexivity. exact q0. Qed. -Lemma IQR_nonneg : forall q:Q, Qle 0 q -> 0 <= (IQR q). +Lemma le_inject_Q : forall q r : Q, + inject_Q q <= inject_Q r -> Qle q r. Proof. - intros [a b] H. unfold IQR. - apply (CRealLe_trans _ ((/ IPR b) (inr (IPR_pos b)) * 0)). - rewrite CReal_mult_0_r. apply CRealLe_refl. - rewrite (CReal_mult_comm (IZR a)). apply CReal_mult_le_compat_l_half. - apply CReal_inv_0_lt_compat. apply IPR_pos. - apply (IZR_le 0 a). unfold Qle in H; simpl in H. - rewrite Z.mul_1_r in H. apply H. + intros. destruct (Qlt_le_dec r q). 2: exact q0. + exfalso. apply H. clear H. apply inject_Q_lt. exact q0. Qed. -Lemma IQR_le : forall n m:Q, Qle n m -> IQR n <= IQR m. +Lemma inject_Q_le : forall q r : Q, + Qle q r -> inject_Q q <= inject_Q r. Proof. - intros. intro abs. apply (CReal_plus_lt_compat_l (-IQR n)) in abs. - rewrite CReal_plus_opp_l, <- opp_IQR, <- plus_IQR in abs. - apply IQR_nonneg in abs. contradiction. apply (Qplus_le_l _ _ n). - ring_simplify. apply H. + intros. intros [n maj]. simpl in maj. + apply (Qlt_not_le _ _ maj). apply (Qle_trans _ 0). + apply (Qplus_le_l _ _ r). ring_simplify. exact H. discriminate. Qed. - -Add Parametric Morphism : IQR - with signature Qeq ==> CRealEq - as IQR_morph. -Proof. - intros. destruct x,y; unfold IQR. - unfold Qeq in H; simpl in H. - apply (CReal_mult_eq_reg_r (IZR (Z.pos Qden))). - 2: right; apply IPR_pos. - rewrite CReal_mult_assoc. rewrite CReal_inv_l. rewrite CReal_mult_1_r. - rewrite (CReal_mult_comm (IZR Qnum0)). - apply (CReal_mult_eq_reg_l (IZR (Z.pos Qden0))). - right; apply IPR_pos. - rewrite <- CReal_mult_assoc, <- CReal_mult_assoc, CReal_inv_r. - rewrite CReal_mult_1_l. - repeat rewrite <- mult_IZR. - rewrite <- H. rewrite Zmult_comm. reflexivity. -Qed. - -Instance IQR_morph_T - : CMorphisms.Proper - (CMorphisms.respectful Qeq CRealEq) IQR. -Proof. - intros x y H. destruct x,y; unfold IQR. - unfold Qeq in H; simpl in H. - apply (CReal_mult_eq_reg_r (IZR (Z.pos Qden))). - 2: right; apply IPR_pos. - rewrite CReal_mult_assoc. rewrite CReal_inv_l. rewrite CReal_mult_1_r. - rewrite (CReal_mult_comm (IZR Qnum0)). - apply (CReal_mult_eq_reg_l (IZR (Z.pos Qden0))). - right; apply IPR_pos. - rewrite <- CReal_mult_assoc, <- CReal_mult_assoc, CReal_inv_r. - rewrite CReal_mult_1_l. - repeat rewrite <- mult_IZR. - rewrite <- H. rewrite Zmult_comm. reflexivity. -Qed. - -Lemma CReal_invQ : forall (b : positive) (pos : Qlt 0 (Z.pos b # 1)), - CRealEq (CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos))) - (inject_Q (1 # b)). -Proof. - intros. - apply (CReal_mult_eq_reg_l (inject_Q (Z.pos b # 1))). - - right. apply CReal_injectQPos. exact pos. - - rewrite CReal_mult_comm, CReal_inv_l. - apply CRealEq_diff. intro n. simpl; - destruct (QCauchySeq_bounded (fun _ : nat => 1 # b)%Q Pos.to_nat (ConstCauchy (1 # b))), - (QCauchySeq_bounded (fun _ : nat => Z.pos b # 1)%Q Pos.to_nat (ConstCauchy (Z.pos b # 1))); simpl. - do 2 rewrite Pos.mul_1_r. rewrite Z.pos_sub_diag. discriminate. -Qed. - -(* The constant sequences of rationals are CRealEq to - the rational operations on the unity. *) -Lemma FinjectQ_CReal : forall q : Q, - IQR q == inject_Q q. -Proof. - intros [a b]. unfold IQR. - pose proof (CReal_iterate_one (Pos.to_nat b)). - rewrite positive_nat_Z in H. simpl in H. - assert (0 < Z.pos b # 1)%Q as pos. reflexivity. - apply (CRealEq_trans _ (CReal_mult (IZR a) - (CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos))))). - - apply CReal_mult_proper_l. - apply (CReal_mult_eq_reg_l (IPR b)). - right. apply IPR_pos. - rewrite CReal_mult_comm, CReal_inv_l, H, CReal_mult_comm, CReal_inv_l. reflexivity. - - rewrite FinjectZ_CReal. rewrite CReal_invQ. apply CRealEq_diff. intro n. - simpl; - destruct (QCauchySeq_bounded (fun _ : nat => a # 1)%Q Pos.to_nat (ConstCauchy (a # 1))), - (QCauchySeq_bounded (fun _ : nat => 1 # b)%Q Pos.to_nat (ConstCauchy (1 # b))); simpl. - rewrite Z.mul_1_r. rewrite <- Z.mul_add_distr_r. - rewrite Z.add_opp_diag_r. rewrite Z.mul_0_l. simpl. - discriminate. -Qed. - -Lemma CReal_gen_inject : forall (n : nat), - gen_phiZ (inject_Q 0) (inject_Q 1) CReal_plus CReal_mult CReal_opp - (Z.of_nat n) - == inject_Q (Z.of_nat n # 1). -Proof. - induction n. - - apply CRealEq_refl. - - replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z. - rewrite (gen_phiZ_add CRealEq_rel CReal_isRingExt CReal_isRing). - rewrite IHn. clear IHn. apply CRealEq_diff. intro k. simpl. - rewrite Z.mul_1_r. rewrite Z.mul_1_r. rewrite Z.mul_1_r. - rewrite Z.add_opp_diag_r. discriminate. - replace (S n) with (1 + n)%nat. 2: reflexivity. - rewrite (Nat2Z.inj_add 1 n). reflexivity. -Qed. - -Lemma CRealArchimedean - : forall x:CReal, { n:Z & CRealLt x (gen_phiZ (inject_Q 0) (inject_Q 1) CReal_plus - CReal_mult CReal_opp n) }. -Proof. - intros [xn limx]. destruct (Qarchimedean (xn 1%nat)) as [k kmaj]. - exists (Z.pos (2 + k)). rewrite <- (positive_nat_Z (2 + k)). - rewrite CReal_gen_inject. rewrite (positive_nat_Z (2 + k)). - exists xH. - setoid_replace (2 # 1)%Q with - ((Z.pos (2 + k) # 1) - (Z.pos k # 1))%Q. - - apply Qplus_lt_r. apply Qlt_minus_iff. rewrite Qopp_involutive. - apply Qlt_minus_iff in kmaj. rewrite Qplus_comm. apply kmaj. - - unfold Qminus. setoid_replace (- (Z.pos k # 1))%Q with (-Z.pos k # 1)%Q. - 2: reflexivity. rewrite Qinv_plus_distr. - rewrite Pos2Z.inj_add. rewrite <- Zplus_assoc. - rewrite Zplus_opp_r. reflexivity. -Qed. - - -Close Scope CReal_scope. - -Close Scope Q. diff --git a/theories/Reals/ConstructiveCauchyRealsMult.v b/theories/Reals/ConstructiveCauchyRealsMult.v new file mode 100644 index 0000000000..d6d4e84560 --- /dev/null +++ b/theories/Reals/ConstructiveCauchyRealsMult.v @@ -0,0 +1,1415 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +(* The multiplication and division of Cauchy reals. *) + +Require Import QArith. +Require Import Qabs. +Require Import Qround. +Require Import Logic.ConstructiveEpsilon. +Require Export Reals.ConstructiveCauchyReals. +Require CMorphisms. + +Local Open Scope CReal_scope. + +Fixpoint BoundFromZero (qn : nat -> Q) (k : nat) (A : positive) { struct k } + : (forall n:nat, le k n -> Qlt (Qabs (qn n)) (Z.pos A # 1)) + -> { B : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos B # 1) }. +Proof. + intro H. destruct k. + - exists A. intros. apply H. apply le_0_n. + - destruct (Qarchimedean (Qabs (qn k))) as [a maj]. + apply (BoundFromZero qn k (Pos.max A a)). + intros n H0. destruct (Nat.le_gt_cases n k). + + pose proof (Nat.le_antisymm n k H1 H0). subst k. + apply (Qlt_le_trans _ (Z.pos a # 1)). apply maj. + unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. + apply Pos.le_max_r. + + apply (Qlt_le_trans _ (Z.pos A # 1)). apply H. + apply H1. unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. + apply Pos.le_max_l. +Qed. + +Lemma QCauchySeq_bounded (qn : nat -> Q) (cvmod : positive -> nat) + : QCauchySeq qn cvmod + -> { A : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos A # 1) }. +Proof. + intros. remember (Zplus (Qnum (Qabs (qn (cvmod xH)))) 1) as z. + assert (Z.lt 0 z) as zPos. + { subst z. assert (Qle 0 (Qabs (qn (cvmod 1%positive)))). + apply Qabs_nonneg. destruct (Qabs (qn (cvmod 1%positive))). simpl. + unfold Qle in H0. simpl in H0. rewrite Zmult_1_r in H0. + apply (Z.lt_le_trans 0 1). unfold Z.lt. auto. + rewrite <- (Zplus_0_l 1). rewrite Zplus_assoc. apply Zplus_le_compat_r. + rewrite Zplus_0_r. assumption. } + assert { A : positive | forall n:nat, + le (cvmod xH) n -> Qlt ((Qabs (qn n)) * (1#A)) 1 }. + destruct z eqn:des. + - exfalso. apply (Z.lt_irrefl 0). assumption. + - exists p. intros. specialize (H xH (cvmod xH) n (le_refl _) H0). + assert (Qlt (Qabs (qn n)) (Qabs (qn (cvmod 1%positive)) + 1)). + { apply (Qplus_lt_l _ _ (-Qabs (qn (cvmod 1%positive)))). + rewrite <- (Qplus_comm 1). rewrite <- Qplus_assoc. rewrite Qplus_opp_r. + rewrite Qplus_0_r. apply (Qle_lt_trans _ (Qabs (qn n - qn (cvmod 1%positive)))). + apply Qabs_triangle_reverse. rewrite Qabs_Qminus. assumption. } + apply (Qlt_le_trans _ ((Qabs (qn (cvmod 1%positive)) + 1) * (1#p))). + apply Qmult_lt_r. unfold Qlt. simpl. unfold Z.lt. auto. assumption. + unfold Qle. simpl. rewrite Zmult_1_r. rewrite Zmult_1_r. rewrite Zmult_1_r. + rewrite Pos.mul_1_r. rewrite Pos2Z.inj_mul. rewrite Heqz. + destruct (Qabs (qn (cvmod 1%positive))) eqn:desAbs. + rewrite Z.mul_add_distr_l. rewrite Zmult_1_r. + apply Zplus_le_compat_r. rewrite <- (Zmult_1_l (QArith_base.Qnum (Qnum # Qden))). + rewrite Zmult_assoc. apply Zmult_le_compat_r. rewrite Zmult_1_r. + simpl. unfold Z.le. rewrite <- Pos2Z.inj_compare. + unfold Pos.compare. destruct Qden; discriminate. + simpl. assert (Qle 0 (Qnum # Qden)). rewrite <- desAbs. + apply Qabs_nonneg. unfold Qle in H2. simpl in H2. rewrite Zmult_1_r in H2. + assumption. + - exfalso. inversion zPos. + - destruct H0. apply (BoundFromZero _ (cvmod xH) x). intros n H0. + specialize (q n H0). setoid_replace (Z.pos x # 1)%Q with (/(1#x))%Q. + rewrite <- (Qmult_1_l (/(1#x))). apply Qlt_shift_div_l. + reflexivity. apply q. reflexivity. +Qed. + +Lemma CReal_mult_cauchy + : forall (xn yn zn : nat -> Q) (Ay Az : positive) (cvmod : positive -> nat), + QSeqEquiv xn yn cvmod + -> QCauchySeq zn Pos.to_nat + -> (forall n:nat, Qlt (Qabs (yn n)) (Z.pos Ay # 1)) + -> (forall n:nat, Qlt (Qabs (zn n)) (Z.pos Az # 1)) + -> QSeqEquiv (fun n:nat => xn n * zn n) (fun n:nat => yn n * zn n) + (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) + (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). +Proof. + intros xn yn zn Ay Az cvmod limx limz majy majz. + remember (Pos.mul 2 (Pos.max Ay Az)) as z. + intros k p q H H0. + assert (Pos.to_nat k <> O) as kPos. + { intro absurd. pose proof (Pos2Nat.is_pos k). + rewrite absurd in H1. inversion H1. } + setoid_replace (xn p * zn p - yn q * zn q)%Q + with ((xn p - yn q) * zn p + yn q * (zn p - zn q))%Q. + 2: ring. + apply (Qle_lt_trans _ (Qabs ((xn p - yn q) * zn p) + + Qabs (yn q * (zn p - zn q)))). + apply Qabs_triangle. rewrite Qabs_Qmult. rewrite Qabs_Qmult. + setoid_replace (1#k)%Q with ((1#2*k) + (1#2*k))%Q. + apply Qplus_lt_le_compat. + - apply (Qle_lt_trans _ ((1#z * k) * Qabs (zn p)%nat)). + + apply Qmult_le_compat_r. apply Qle_lteq. left. apply limx. + apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). + apply Nat.le_max_l. assumption. + apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). + apply Nat.le_max_l. assumption. apply Qabs_nonneg. + + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). + rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. + rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. + apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. + apply (Qle_lt_trans _ (Qabs (zn p)%nat * (1 # Az))). + rewrite <- (Qmult_comm (1 # Az)). apply Qmult_le_compat_r. + unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_r. + apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Az)). + rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. + setoid_replace (/(1#Az))%Q with (Z.pos Az # 1)%Q. apply majz. + reflexivity. intro abs. inversion abs. + - apply (Qle_trans _ ((1 # z * k) * Qabs (yn q)%nat)). + + rewrite Qmult_comm. apply Qmult_le_compat_r. apply Qle_lteq. + left. apply limz. + apply (le_trans _ (max (cvmod (z * k)%positive) + (Pos.to_nat (z * k)%positive))). + apply Nat.le_max_r. assumption. + apply (le_trans _ (max (cvmod (z * k)%positive) + (Pos.to_nat (z * k)%positive))). + apply Nat.le_max_r. assumption. apply Qabs_nonneg. + + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). + rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. + rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. + apply Qle_lteq. left. + apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. + apply (Qle_lt_trans _ (Qabs (yn q)%nat * (1 # Ay))). + rewrite <- (Qmult_comm (1 # Ay)). apply Qmult_le_compat_r. + unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_l. + apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Ay)). + rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. + setoid_replace (/(1#Ay))%Q with (Z.pos Ay # 1)%Q. apply majy. + reflexivity. intro abs. inversion abs. + - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. +Qed. + +Lemma linear_max : forall (p Ax Ay : positive) (i : nat), + le (Pos.to_nat p) i + -> (Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) + (Pos.to_nat (2 * Pos.max Ax Ay * p)) <= Pos.to_nat (2 * Pos.max Ax Ay) * i)%nat. +Proof. + intros. rewrite max_l. 2: apply le_refl. + rewrite Pos2Nat.inj_mul. apply Nat.mul_le_mono_nonneg. + apply le_0_n. apply le_refl. apply le_0_n. apply H. +Qed. + +Definition CReal_mult (x y : CReal) : CReal. +Proof. + destruct x as [xn limx]. destruct y as [yn limy]. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + exists (fun n : nat => xn (Pos.to_nat (2 * Pos.max Ax Ay)* n)%nat + * yn (Pos.to_nat (2 * Pos.max Ax Ay) * n)%nat). + intros p n k H0 H1. + apply H; apply linear_max; assumption. +Defined. + +Infix "*" := CReal_mult : CReal_scope. + +Lemma CReal_mult_unfold : forall x y : CReal, + QSeqEquivEx (proj1_sig (CReal_mult x y)) + (fun n : nat => proj1_sig x n * proj1_sig y n)%Q. +Proof. + intros [xn limx] [yn limy]. unfold CReal_mult ; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + simpl. + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) + (Pos.to_nat (2 * Pos.max Ax Ay * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + apply H. apply linear_max. + apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). + rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. + apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. + apply le_0_n. apply le_refl. apply H0. rewrite max_l. + apply H1. apply le_refl. +Qed. + +Lemma CReal_mult_assoc_bounded_r : forall (xn yn zn : nat -> Q), + QSeqEquivEx xn yn (* both are Cauchy with same limit *) + -> QSeqEquiv zn zn Pos.to_nat + -> QSeqEquivEx (fun n => xn n * zn n)%Q (fun n => yn n * zn n)%Q. +Proof. + intros. destruct H as [cvmod cveq]. + destruct (QCauchySeq_bounded yn (fun k => cvmod (2 * k)%positive) + (QSeqEquiv_cau_r xn yn cvmod cveq)) + as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat H0) as [Az majz]. + exists (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) + (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). + apply CReal_mult_cauchy; assumption. +Qed. + +Lemma CReal_mult_assoc : forall x y z : CReal, + CRealEq (CReal_mult (CReal_mult x y) z) + (CReal_mult x (CReal_mult y z)). +Proof. + intros. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n * proj1_sig z n)%Q). + - apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n * proj1_sig z n)%Q). + apply CReal_mult_unfold. + destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + apply CReal_mult_assoc_bounded_r. 2: apply limz. + simpl. + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) + (Pos.to_nat (2 * Pos.max Ax Ay * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + apply H. apply linear_max. + apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). + rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. + apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. + apply le_0_n. apply le_refl. apply H0. rewrite max_l. + apply H1. apply le_refl. + - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig (CReal_mult y z) n)%Q). + 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. + destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + simpl. + pose proof (CReal_mult_assoc_bounded_r (fun n0 : nat => yn n0 * zn n0)%Q (fun n : nat => + yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat + * zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat)%Q xn) + as [cvmod cveq]. + + pose proof (CReal_mult_cauchy yn yn zn Ay Az Pos.to_nat limy limz majy majz). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Az * p)) + (Pos.to_nat (2 * Pos.max Ay Az * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + apply H. rewrite max_l. apply H0. apply le_refl. + apply linear_max. + apply (le_trans _ (Pos.to_nat (2 * Pos.max Ay Az * p))). + rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. + apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. + apply le_0_n. apply le_refl. apply H1. + apply limx. + exists cvmod. intros p k n H1 H2. specialize (cveq p k n H1 H2). + setoid_replace (xn k * yn k * zn k - + xn n * + (yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * + zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat))%Q + with ((fun n : nat => yn n * zn n * xn n) k - + (fun n : nat => + yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * + zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * + xn n) n)%Q. + apply cveq. ring. +Qed. + +Lemma CReal_mult_comm : forall x y : CReal, + CRealEq (CReal_mult x y) (CReal_mult y x). +Proof. + intros. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig y n * proj1_sig x n)%Q). + destruct x as [xn limx], y as [yn limy]; simpl. + 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]; simpl. + apply QSeqEquivEx_sym. + + pose proof (CReal_mult_cauchy yn yn xn Ay Ax Pos.to_nat limy limx majy majx). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Ax * p)) + (Pos.to_nat (2 * Pos.max Ay Ax * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + rewrite (Qmult_comm (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)). + apply (H p n). rewrite max_l. apply H0. apply le_refl. + rewrite max_l. apply (le_trans _ k). apply H1. + rewrite <- (mult_1_l k). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. + apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. + apply le_refl. +Qed. + +Lemma CReal_mult_proper_l : forall x y z : CReal, + CRealEq y z -> CRealEq (CReal_mult x y) (CReal_mult x z). +Proof. + intros. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n)%Q). + apply CReal_mult_unfold. + rewrite CRealEq_diff in H. rewrite <- CRealEq_modindep in H. + apply QSeqEquivEx_sym. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig z n)%Q). + apply CReal_mult_unfold. + destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. + destruct H. simpl in H. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + pose proof (CReal_mult_cauchy yn zn xn Az Ax x H limx majz majx). + apply QSeqEquivEx_sym. + exists (fun p : positive => + Init.Nat.max (x (2 * Pos.max Az Ax * p)%positive) + (Pos.to_nat (2 * Pos.max Az Ax * p))). + intros p n k H1 H2. specialize (H0 p n k H1 H2). + setoid_replace (xn n * yn n - xn k * zn k)%Q + with (yn n * xn n - zn k * xn k)%Q. + apply H0. ring. +Qed. + +Lemma CReal_mult_lt_0_compat : forall x y : CReal, + CRealLt (inject_Q 0) x + -> CRealLt (inject_Q 0) y + -> CRealLt (inject_Q 0) (CReal_mult x y). +Proof. + intros. destruct H as [x0 H], H0 as [x1 H0]. + pose proof (CRealLt_aboveSig (inject_Q 0) x x0 H). + pose proof (CRealLt_aboveSig (inject_Q 0) y x1 H0). + destruct x as [xn limx], y as [yn limy]. + simpl in H, H1, H2. simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (Qarchimedean (/ (xn (Pos.to_nat x0) - 0 - (2 # x0)))). + destruct (Qarchimedean (/ (yn (Pos.to_nat x1) - 0 - (2 # x1)))). + exists (Pos.max x0 x~0 * Pos.max x1 x2~0)%positive. + simpl. unfold Qminus. rewrite Qplus_0_r. + rewrite <- Pos2Nat.inj_mul. + unfold Qminus in H1, H2. + specialize (H1 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive). + assert (Pos.max x1 x2~0 <= (Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive. + { apply Pos2Nat.inj_le. + rewrite Pos.mul_assoc. rewrite Pos2Nat.inj_mul. + rewrite <- (mult_1_l (Pos.to_nat (Pos.max x1 x2~0))). + rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. + rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. + apply le_refl. } + specialize (H2 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive H3). + rewrite Qplus_0_r in H1, H2. + apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (2 # Pos.max x1 x2~0))). + unfold Qlt; simpl. assert (forall p : positive, (Z.pos p < Z.pos p~0)%Z). + intro p. rewrite <- (Z.mul_1_l (Z.pos p)). + replace (Z.pos p~0) with (2 * Z.pos p)%Z. apply Z.mul_lt_mono_pos_r. + apply Pos2Z.is_pos. reflexivity. reflexivity. + apply H4. + apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (yn (Pos.to_nat ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0)))))). + apply Qmult_lt_l. reflexivity. apply H2. apply Qmult_lt_r. + apply (Qlt_trans 0 (2 # Pos.max x1 x2~0)). reflexivity. apply H2. + apply H1. rewrite Pos.mul_comm. apply Pos2Nat.inj_le. + rewrite <- Pos.mul_assoc. rewrite Pos2Nat.inj_mul. + rewrite <- (mult_1_r (Pos.to_nat (Pos.max x0 x~0))). + rewrite <- mult_assoc. apply Nat.mul_le_mono_nonneg. + apply le_0_n. apply le_refl. auto. + rewrite mult_1_l. apply Pos2Nat.is_pos. +Qed. + +Lemma CReal_mult_plus_distr_l : forall r1 r2 r3 : CReal, + r1 * (r2 + r3) == (r1 * r2) + (r1 * r3). +Proof. + intros x y z. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n + * (proj1_sig (CReal_plus y z) n))%Q). + apply CReal_mult_unfold. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n + + proj1_sig (CReal_mult x z) n))%Q. + 2: apply QSeqEquivEx_sym; exists (fun p => Pos.to_nat (2 * p)) + ; apply CReal_plus_unfold. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n + * (proj1_sig y n + proj1_sig z n))%Q). + - pose proof (CReal_plus_unfold y z). + destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl; simpl in H. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + pose proof (CReal_mult_cauchy (fun n => yn (n + (n + 0))%nat + zn (n + (n + 0))%nat)%Q + (fun n => yn n + zn n)%Q + xn (Ay + Az) Ax + (fun p => Pos.to_nat (2 * p)) H limx). + exists (fun p : positive => (Pos.to_nat (2 * (2 * Pos.max (Ay + Az) Ax * p)))). + intros p n k H1 H2. + setoid_replace (xn n * (yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) - xn k * (yn k + zn k))%Q + with ((yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) * xn n - (yn k + zn k) * xn k)%Q. + 2: ring. + assert (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p) <= + Pos.to_nat 2 * Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))%nat. + { rewrite (Pos2Nat.inj_mul 2). + rewrite <- (mult_1_l (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))). + rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. + simpl. auto. apply le_0_n. apply le_refl. } + apply H0. intro n0. apply (Qle_lt_trans _ (Qabs (yn n0) + Qabs (zn n0))). + apply Qabs_triangle. rewrite Pos2Z.inj_add. + rewrite <- Qinv_plus_distr. apply Qplus_lt_le_compat. + apply majy. apply Qlt_le_weak. apply majz. + apply majx. rewrite max_l. + apply H1. rewrite (Pos2Nat.inj_mul 2). apply H3. + rewrite max_l. apply H2. rewrite (Pos2Nat.inj_mul 2). + apply H3. + - destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + simpl. + exists (fun p : positive => (Pos.to_nat (2 * (Pos.max (Pos.max Ax Ay) Az) * (2 * p)))). + intros p n k H H0. + setoid_replace (xn n * (yn n + zn n) - + (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * + yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat + + xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * + zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q + with (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * + yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat) + + (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * + zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q. + 2: ring. + apply (Qle_lt_trans _ (Qabs (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * + yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)) + + Qabs (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * + zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))). + apply Qabs_triangle. + setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. + apply Qplus_lt_le_compat. + + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy). + apply H1. apply majx. apply majy. rewrite max_l. + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H. apply le_refl. + rewrite max_l. apply (le_trans _ k). + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H0. + rewrite <- (mult_1_l k). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. + rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. + apply le_refl. apply le_refl. + + apply Qlt_le_weak. + pose proof (CReal_mult_cauchy xn xn zn Ax Az Pos.to_nat limx limz). + apply H1. apply majx. apply majz. rewrite max_l. 2: apply le_refl. + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). + rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H. + rewrite max_l. apply (le_trans _ k). + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). + rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H0. + rewrite <- (mult_1_l k). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. + rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. + apply le_refl. apply le_refl. + + rewrite Qinv_plus_distr. unfold Qeq. reflexivity. +Qed. + +Lemma CReal_mult_plus_distr_r : forall r1 r2 r3 : CReal, + (r2 + r3) * r1 == (r2 * r1) + (r3 * r1). +Proof. + intros. + rewrite CReal_mult_comm, CReal_mult_plus_distr_l, + <- (CReal_mult_comm r1), <- (CReal_mult_comm r1). + reflexivity. +Qed. + +Lemma CReal_mult_1_l : forall r: CReal, 1 * r == r. +Proof. + intros [rn limr]. split. + - intros [m maj]. simpl in maj. + destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). + destruct (QCauchySeq_bounded rn Pos.to_nat limr). + simpl in maj. rewrite Qmult_1_l in maj. + specialize (limr m). + apply (Qlt_not_le (2 # m) (1 # m)). + apply (Qlt_trans _ (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat)). + apply maj. + apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat))). + apply Qle_Qabs. apply limr. apply le_refl. + rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. + apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. + apply Z.mul_le_mono_nonneg. discriminate. discriminate. + discriminate. apply Z.le_refl. + - intros [m maj]. simpl in maj. + destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). + destruct (QCauchySeq_bounded rn Pos.to_nat limr). + simpl in maj. rewrite Qmult_1_l in maj. + specialize (limr m). + apply (Qlt_not_le (2 # m) (1 # m)). + apply (Qlt_trans _ (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m))). + apply maj. + apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m)))). + apply Qle_Qabs. apply limr. + rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. + apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. + apply le_refl. apply Z.mul_le_mono_nonneg. discriminate. discriminate. + discriminate. apply Z.le_refl. +Qed. + +Lemma CReal_isRingExt : ring_eq_ext CReal_plus CReal_mult CReal_opp CRealEq. +Proof. + split. + - intros x y H z t H0. apply CReal_plus_morph; assumption. + - intros x y H z t H0. apply (CRealEq_trans _ (CReal_mult x t)). + apply CReal_mult_proper_l. apply H0. + apply (CRealEq_trans _ (CReal_mult t x)). apply CReal_mult_comm. + apply (CRealEq_trans _ (CReal_mult t y)). + apply CReal_mult_proper_l. apply H. apply CReal_mult_comm. + - intros x y H. apply (CReal_plus_eq_reg_l x). + apply (CRealEq_trans _ (inject_Q 0)). apply CReal_plus_opp_r. + apply (CRealEq_trans _ (CReal_plus y (CReal_opp y))). + apply CRealEq_sym. apply CReal_plus_opp_r. + apply CReal_plus_proper_r. apply CRealEq_sym. apply H. +Qed. + +Lemma CReal_isRing : ring_theory (inject_Q 0) (inject_Q 1) + CReal_plus CReal_mult + CReal_minus CReal_opp + CRealEq. +Proof. + intros. split. + - apply CReal_plus_0_l. + - apply CReal_plus_comm. + - intros x y z. symmetry. apply CReal_plus_assoc. + - apply CReal_mult_1_l. + - apply CReal_mult_comm. + - intros x y z. symmetry. apply CReal_mult_assoc. + - intros x y z. rewrite <- (CReal_mult_comm z). + rewrite CReal_mult_plus_distr_l. + apply (CRealEq_trans _ (CReal_plus (CReal_mult x z) (CReal_mult z y))). + apply CReal_plus_proper_r. apply CReal_mult_comm. + apply CReal_plus_proper_l. apply CReal_mult_comm. + - intros x y. apply CRealEq_refl. + - apply CReal_plus_opp_r. +Qed. + +Add Parametric Morphism : CReal_mult + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_mult_morph. +Proof. + apply CReal_isRingExt. +Qed. + +Instance CReal_mult_morph_T + : CMorphisms.Proper + (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_mult. +Proof. + apply CReal_isRingExt. +Qed. + +Add Parametric Morphism : CReal_opp + with signature CRealEq ==> CRealEq + as CReal_opp_morph. +Proof. + apply (Ropp_ext CReal_isRingExt). +Qed. + +Instance CReal_opp_morph_T + : CMorphisms.Proper + (CMorphisms.respectful CRealEq CRealEq) CReal_opp. +Proof. + apply CReal_isRingExt. +Qed. + +Add Parametric Morphism : CReal_minus + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_minus_morph. +Proof. + intros. unfold CReal_minus. rewrite H,H0. reflexivity. +Qed. + +Instance CReal_minus_morph_T + : CMorphisms.Proper + (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_minus. +Proof. + intros x y exy z t ezt. unfold CReal_minus. rewrite exy,ezt. reflexivity. +Qed. + +Add Ring CRealRing : CReal_isRing. + +(**********) +Lemma CReal_mult_0_l : forall r, 0 * r == 0. +Proof. + intro; ring. +Qed. + +Lemma CReal_mult_0_r : forall r, r * 0 == 0. +Proof. + intro; ring. +Qed. + +(**********) +Lemma CReal_mult_1_r : forall r, r * 1 == r. +Proof. + intro; ring. +Qed. + +Lemma CReal_opp_mult_distr_l + : forall r1 r2 : CReal, - (r1 * r2) == (- r1) * r2. +Proof. + intros. ring. +Qed. + +Lemma CReal_opp_mult_distr_r + : forall r1 r2 : CReal, - (r1 * r2) == r1 * (- r2). +Proof. + intros. ring. +Qed. + +Lemma CReal_mult_lt_compat_l : forall x y z : CReal, + 0 < x -> y < z -> x*y < x*z. +Proof. + intros. apply (CReal_plus_lt_reg_l + (CReal_opp (CReal_mult x y))). + rewrite CReal_plus_comm. pose proof CReal_plus_opp_r. + unfold CReal_minus in H1. rewrite H1. + rewrite CReal_mult_comm, CReal_opp_mult_distr_l, CReal_mult_comm. + rewrite <- CReal_mult_plus_distr_l. + apply CReal_mult_lt_0_compat. exact H. + apply (CReal_plus_lt_reg_l y). + rewrite CReal_plus_comm, CReal_plus_0_l. + rewrite <- CReal_plus_assoc, H1, CReal_plus_0_l. exact H0. +Qed. + +Lemma CReal_mult_lt_compat_r : forall x y z : CReal, + 0 < x -> y < z -> y*x < z*x. +Proof. + intros. rewrite <- (CReal_mult_comm x), <- (CReal_mult_comm x). + apply (CReal_mult_lt_compat_l x); assumption. +Qed. + +Lemma CReal_mult_eq_reg_l : forall (r r1 r2 : CReal), + r # 0 + -> CRealEq (CReal_mult r r1) (CReal_mult r r2) + -> CRealEq r1 r2. +Proof. + intros. destruct H; split. + - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. + rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. + exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). + rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. + - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. + rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. + exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). + rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. + - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. + exact (CRealLt_irrefl _ abs). exact c. + - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. + exact (CRealLt_irrefl _ abs). exact c. +Qed. + +Lemma CReal_abs_appart_zero : forall (x : CReal) (n : positive), + Qlt (2#n) (Qabs (proj1_sig x (Pos.to_nat n))) + -> 0 # x. +Proof. + intros. destruct x as [xn xcau]. simpl in H. + destruct (Qlt_le_dec 0 (xn (Pos.to_nat n))). + - left. exists n; simpl. rewrite Qabs_pos in H. + ring_simplify. exact H. apply Qlt_le_weak. exact q. + - right. exists n; simpl. rewrite Qabs_neg in H. + unfold Qminus. rewrite Qplus_0_l. exact H. exact q. +Qed. + + +(*********************************************************) +(** * Field *) +(*********************************************************) + +Lemma CRealArchimedean + : forall x:CReal, { n:Z & x < inject_Q (n#1) < x+2 }. +Proof. + (* Locate x within 1/4 and pick the first integer above this interval. *) + intros [xn limx]. + pose proof (Qlt_floor (xn 4%nat + (1#4))). unfold inject_Z in H. + pose proof (Qfloor_le (xn 4%nat + (1#4))). unfold inject_Z in H0. + remember (Qfloor (xn 4%nat + (1#4)))%Z as n. + exists (n+1)%Z. split. + - assert (Qlt 0 ((n + 1 # 1) - (xn 4%nat + (1 # 4)))) as epsPos. + { unfold Qminus. rewrite <- Qlt_minus_iff. exact H. } + destruct (Qarchimedean (/((1#2)*((n + 1 # 1) - (xn 4%nat + (1 # 4)))))) as [k kmaj]. + exists (Pos.max 4 k). simpl. + apply (Qlt_trans _ ((n + 1 # 1) - (xn 4%nat + (1 # 4)))). + + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. + rewrite <- Qinv_lt_contravar in kmaj. 2: reflexivity. + apply (Qle_lt_trans _ (2#k)). + rewrite <- (Qmult_le_l _ _ (1#2)). + setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. 2: reflexivity. + setoid_replace ((1 # 2) * (2 # Pos.max 4 k))%Q with (1#Pos.max 4 k)%Q. 2: reflexivity. + unfold Qle; simpl. apply Pos2Z.pos_le_pos. apply Pos.le_max_r. + reflexivity. + rewrite <- (Qmult_lt_l _ _ (1#2)). + setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. exact kmaj. + reflexivity. reflexivity. rewrite <- (Qmult_0_r (1#2)). + rewrite Qmult_lt_l. exact epsPos. reflexivity. + + rewrite <- (Qplus_lt_r _ _ (xn (Pos.to_nat (Pos.max 4 k)) - (n + 1 # 1) + (1#4))). + ring_simplify. + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max 4 k)) - xn 4%nat))). + apply Qle_Qabs. apply limx. + rewrite Pos2Nat.inj_max. apply Nat.le_max_l. apply le_refl. + - apply (CReal_plus_lt_reg_l (-(2))). ring_simplify. + exists 4%positive. simpl. + rewrite <- Qinv_plus_distr. + rewrite <- (Qplus_lt_r _ _ ((n#1) - (1#2))). ring_simplify. + apply (Qle_lt_trans _ (xn 4%nat + (1 # 4)) _ H0). + unfold Pos.to_nat; simpl. + rewrite <- (Qplus_lt_r _ _ (-xn 4%nat)). ring_simplify. + reflexivity. +Defined. + +Definition Rup_pos (x : CReal) + : { n : positive & x < inject_Q (Z.pos n # 1) }. +Proof. + intros. destruct (CRealArchimedean x) as [p [maj _]]. + destruct p. + - exists 1%positive. apply (CReal_lt_trans _ 0 _ maj). apply CRealLt_0_1. + - exists p. exact maj. + - exists 1%positive. apply (CReal_lt_trans _ (inject_Q (Z.neg p # 1)) _ maj). + apply (CReal_lt_trans _ 0). apply inject_Q_lt. reflexivity. + apply CRealLt_0_1. +Qed. + +Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal, + (CRealLtProp a b \/ CRealLtProp c d) -> CRealLt a b + CRealLt c d. +Proof. + intros. + assert (exists n : nat, n <> O /\ + (Qlt (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n) + \/ Qlt (2 # Pos.of_nat n) (proj1_sig d n - proj1_sig c n))). + { destruct H. destruct H as [n maj]. exists (Pos.to_nat n). split. + intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. + inversion abs. left. rewrite Pos2Nat.id. apply maj. + destruct H as [n maj]. exists (Pos.to_nat n). split. + intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. + inversion abs. right. rewrite Pos2Nat.id. apply maj. } + apply constructive_indefinite_ground_description_nat in H0. + - destruct H0 as [n [nPos maj]]. + destruct (Qlt_le_dec (2 # Pos.of_nat n) + (proj1_sig b n - proj1_sig a n)). + left. exists (Pos.of_nat n). rewrite Nat2Pos.id. apply q. apply nPos. + assert (2 # Pos.of_nat n < proj1_sig d n - proj1_sig c n)%Q. + destruct maj. exfalso. + apply (Qlt_not_le (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n)); assumption. + assumption. clear maj. right. exists (Pos.of_nat n). rewrite Nat2Pos.id. + apply H0. apply nPos. + - clear H0. clear H. intro n. destruct n. right. + intros [abs _]. exact (abs (eq_refl O)). + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig b (S n) - proj1_sig a (S n))). + left. split. discriminate. left. apply q. + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig d (S n) - proj1_sig c (S n))). + left. split. discriminate. right. apply q0. + right. intros [_ [abs|abs]]. + apply (Qlt_not_le (2 # Pos.of_nat (S n)) + (proj1_sig b (S n) - proj1_sig a (S n))); assumption. + apply (Qlt_not_le (2 # Pos.of_nat (S n)) + (proj1_sig d (S n) - proj1_sig c (S n))); assumption. +Qed. + +Lemma CRealShiftReal : forall (x : CReal) (k : nat), + QCauchySeq (fun n => proj1_sig x (plus n k)) Pos.to_nat. +Proof. + intros x k n p q H H0. + destruct x as [xn cau]; unfold proj1_sig. + destruct k. rewrite plus_0_r. rewrite plus_0_r. apply cau; assumption. + specialize (cau (n + Pos.of_nat (S k))%positive (p + S k)%nat (q + S k)%nat). + apply (Qlt_trans _ (1 # n + Pos.of_nat (S k))). + apply cau. rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. + apply Nat.add_le_mono_r. apply H. discriminate. + rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. + apply Nat.add_le_mono_r. apply H0. discriminate. + apply Pos2Nat.inj_lt; simpl. rewrite Pos2Nat.inj_add. + rewrite <- (plus_0_r (Pos.to_nat n)). rewrite <- plus_assoc. + apply Nat.add_lt_mono_l. apply Pos2Nat.is_pos. +Qed. + +Lemma CRealShiftEqual : forall (x : CReal) (k : nat), + CRealEq x (exist _ (fun n => proj1_sig x (plus n k)) (CRealShiftReal x k)). +Proof. + intros. split. + - intros [n maj]. destruct x as [xn cau]; simpl in maj. + specialize (cau n (Pos.to_nat n + k)%nat (Pos.to_nat n)). + apply Qlt_not_le in maj. apply maj. clear maj. + apply (Qle_trans _ (Qabs (xn (Pos.to_nat n + k)%nat - xn (Pos.to_nat n)))). + apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. + apply cau. rewrite <- (plus_0_r (Pos.to_nat n)). + rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. + apply le_refl. apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. + discriminate. + - intros [n maj]. destruct x as [xn cau]; simpl in maj. + specialize (cau n (Pos.to_nat n) (Pos.to_nat n + k)%nat). + apply Qlt_not_le in maj. apply maj. clear maj. + apply (Qle_trans _ (Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat n + k)%nat))). + apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. + apply cau. apply le_refl. rewrite <- (plus_0_r (Pos.to_nat n)). + rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. + apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. discriminate. +Qed. + +(* Find an equal negative real number, which rational sequence + stays below 0, so that it can be inversed. *) +Definition CRealNegShift (x : CReal) + : CRealLt x (inject_Q 0) + -> { y : prod positive CReal | CRealEq x (snd y) + /\ forall n:nat, Qlt (proj1_sig (snd y) n) (-1 # fst y) }. +Proof. + intro xNeg. + pose proof (CRealLt_aboveSig x (inject_Q 0)). + pose proof (CRealShiftReal x). + pose proof (CRealShiftEqual x). + destruct xNeg as [n maj], x as [xn cau]; simpl in maj. + specialize (H n maj); simpl in H. + destruct (Qarchimedean (/ (0 - xn (Pos.to_nat n) - (2 # n)))) as [a _]. + remember (Pos.max n a~0) as k. + clear Heqk. clear maj. clear n. + exists (pair k + (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). + split. apply H1. intro n. simpl. apply Qlt_minus_iff. + destruct n. + - specialize (H k). + unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. + unfold Qminus. rewrite Qplus_comm. + apply (Qlt_trans _ (- xn (Pos.to_nat k)%nat - (2 #k))). apply H. + unfold Qminus. simpl. apply Qplus_lt_r. + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. apply Pos.le_refl. + - apply (Qlt_trans _ (-(2 # k) - xn (S n + Pos.to_nat k)%nat)). + rewrite <- (Nat2Pos.id (S n)). rewrite <- Pos2Nat.inj_add. + specialize (H (Pos.of_nat (S n) + k)%positive). + unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. + unfold Qminus. rewrite Qplus_comm. apply H. apply Pos2Nat.inj_le. + rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. + apply Nat.add_le_mono_r. apply le_0_n. discriminate. + apply Qplus_lt_l. + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. +Qed. + +Definition CRealPosShift (x : CReal) + : inject_Q 0 < x + -> { y : prod positive CReal | CRealEq x (snd y) + /\ forall n:nat, Qlt (1 # fst y) (proj1_sig (snd y) n) }. +Proof. + intro xPos. + pose proof (CRealLt_aboveSig (inject_Q 0) x). + pose proof (CRealShiftReal x). + pose proof (CRealShiftEqual x). + destruct xPos as [n maj], x as [xn cau]; simpl in maj. + simpl in H. specialize (H n). + destruct (Qarchimedean (/ (xn (Pos.to_nat n) - 0 - (2 # n)))) as [a _]. + specialize (H maj); simpl in H. + remember (Pos.max n a~0) as k. + clear Heqk. clear maj. clear n. + exists (pair k + (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). + split. apply H1. intro n. simpl. apply Qlt_minus_iff. + destruct n. + - specialize (H k). + unfold Qminus in H. rewrite Qplus_0_r in H. + simpl. rewrite <- Qlt_minus_iff. + apply (Qlt_trans _ (2 #k)). + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. apply H. apply Pos.le_refl. + - rewrite <- Qlt_minus_iff. apply (Qlt_trans _ (2 # k)). + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. specialize (H (Pos.of_nat (S n) + k)%positive). + unfold Qminus in H. rewrite Qplus_0_r in H. + rewrite Pos2Nat.inj_add in H. rewrite Nat2Pos.id in H. + apply H. apply Pos2Nat.inj_le. + rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. + apply Nat.add_le_mono_r. apply le_0_n. discriminate. +Qed. + +Lemma CReal_inv_neg : forall (yn : nat -> Q) (k : positive), + (QCauchySeq yn Pos.to_nat) + -> (forall n : nat, yn n < -1 # k)%Q + -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. +Proof. + (* Prove the inverse sequence is Cauchy *) + intros yn k cau maj n p q H0 H1. + setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - + / yn (Pos.to_nat k ^ 2 * q)%nat)%Q + with ((yn (Pos.to_nat k ^ 2 * q)%nat - + yn (Pos.to_nat k ^ 2 * p)%nat) + / (yn (Pos.to_nat k ^ 2 * q)%nat * + yn (Pos.to_nat k ^ 2 * p)%nat)). + + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat + - yn (Pos.to_nat k ^ 2 * p)%nat) + / (1 # (k^2)))). + assert (1 # k ^ 2 + < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. + { rewrite Qabs_Qmult. unfold "^"%positive; simpl. + rewrite factorDenom. rewrite Pos.mul_1_r. + apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). + apply Qmult_lt_l. reflexivity. rewrite Qabs_neg. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply Qlt_minus_iff in maj. apply Qlt_minus_iff. + rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. + reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. + apply maj. discriminate. + apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. + rewrite Qabs_neg. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply Qlt_minus_iff in maj. apply Qlt_minus_iff. + rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. + reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. + apply maj. discriminate. + rewrite Qabs_neg. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). + apply Qlt_minus_iff in maj. apply Qlt_minus_iff. + rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. + reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. + apply maj. discriminate. } + unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. + rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). + apply Qmult_le_compat_r. apply Qlt_le_weak. + rewrite <- Qmult_1_l. apply Qlt_shift_div_r. + apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. + rewrite Qmult_comm. apply Qlt_shift_div_l. + reflexivity. rewrite Qmult_1_l. apply H. + apply Qabs_nonneg. simpl in maj. + specialize (cau (n * (k^2))%positive + (Pos.to_nat k ^ 2 * q)%nat + (Pos.to_nat k ^ 2 * p)%nat). + apply Qlt_shift_div_r. reflexivity. + apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite factorDenom. apply Qle_refl. + + field. split. intro abs. + specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + rewrite abs in maj. inversion maj. + intro abs. + specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + rewrite abs in maj. inversion maj. +Qed. + +Lemma CReal_inv_pos : forall (yn : nat -> Q) (k : positive), + (QCauchySeq yn Pos.to_nat) + -> (forall n : nat, 1 # k < yn n)%Q + -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. +Proof. + intros yn k cau maj n p q H0 H1. + setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - + / yn (Pos.to_nat k ^ 2 * q)%nat)%Q + with ((yn (Pos.to_nat k ^ 2 * q)%nat - + yn (Pos.to_nat k ^ 2 * p)%nat) + / (yn (Pos.to_nat k ^ 2 * q)%nat * + yn (Pos.to_nat k ^ 2 * p)%nat)). + + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat + - yn (Pos.to_nat k ^ 2 * p)%nat) + / (1 # (k^2)))). + assert (1 # k ^ 2 + < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. + { rewrite Qabs_Qmult. unfold "^"%positive; simpl. + rewrite factorDenom. rewrite Pos.mul_1_r. + apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). + apply Qmult_lt_l. reflexivity. rewrite Qabs_pos. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply maj. apply (Qle_trans _ (1 # k)). + discriminate. apply Zlt_le_weak. apply maj. + apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. + rewrite Qabs_pos. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply maj. apply (Qle_trans _ (1 # k)). discriminate. + apply Zlt_le_weak. apply maj. + rewrite Qabs_pos. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). + apply maj. apply (Qle_trans _ (1 # k)). discriminate. + apply Zlt_le_weak. apply maj. } + unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. + rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). + apply Qmult_le_compat_r. apply Qlt_le_weak. + rewrite <- Qmult_1_l. apply Qlt_shift_div_r. + apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. + rewrite Qmult_comm. apply Qlt_shift_div_l. + reflexivity. rewrite Qmult_1_l. apply H. + apply Qabs_nonneg. simpl in maj. + specialize (cau (n * (k^2))%positive + (Pos.to_nat k ^ 2 * q)%nat + (Pos.to_nat k ^ 2 * p)%nat). + apply Qlt_shift_div_r. reflexivity. + apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite factorDenom. apply Qle_refl. + + field. split. intro abs. + specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + rewrite abs in maj. inversion maj. + intro abs. + specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + rewrite abs in maj. inversion maj. +Qed. + +Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal. +Proof. + destruct xnz as [xNeg | xPos]. + - destruct (CRealNegShift x xNeg) as [[k y] [_ maj]]. + destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. + exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). + apply (CReal_inv_neg yn). apply cau. apply maj. + - destruct (CRealPosShift x xPos) as [[k y] [_ maj]]. + destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. + exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). + apply (CReal_inv_pos yn). apply cau. apply maj. +Defined. + +Notation "/ x" := (CReal_inv x) (at level 35, right associativity) : CReal_scope. + +Lemma CReal_inv_0_lt_compat + : forall (r : CReal) (rnz : r # 0), + 0 < r -> 0 < ((/ r) rnz). +Proof. + intros. unfold CReal_inv. simpl. + destruct rnz. + - exfalso. apply CRealLt_asym in H. contradiction. + - destruct (CRealPosShift r c) as [[k rpos] [req maj]]. + clear req. destruct rpos as [rn cau]; simpl in maj. + unfold CRealLt; simpl. + destruct (Qarchimedean (rn 1%nat)) as [A majA]. + exists (2 * (A + 1))%positive. unfold Qminus. rewrite Qplus_0_r. + rewrite <- (Qmult_1_l (Qinv (rn (Pos.to_nat k * (Pos.to_nat k * 1) * Pos.to_nat (2 * (A + 1)))%nat))). + apply Qlt_shift_div_l. apply (Qlt_trans 0 (1#k)). reflexivity. + apply maj. rewrite <- (Qmult_inv_r (Z.pos A + 1 # 1)). + setoid_replace (2 # 2 * (A + 1))%Q with (Qinv (Z.pos A + 1 # 1)). + 2: reflexivity. + rewrite Qmult_comm. apply Qmult_lt_r. reflexivity. + rewrite mult_1_r. rewrite <- Pos2Nat.inj_mul. rewrite <- Pos2Nat.inj_mul. + rewrite <- (Qplus_lt_l _ _ (- rn 1%nat)). + apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (k * k * (2 * (A + 1)))) + - rn 1%nat))). + apply Qle_Qabs. apply (Qlt_le_trans _ 1). apply cau. + apply Pos2Nat.is_pos. apply le_refl. + rewrite <- Qinv_plus_distr. rewrite <- (Qplus_comm 1). + rewrite <- Qplus_0_r. rewrite <- Qplus_assoc. rewrite <- Qplus_assoc. + rewrite Qplus_le_r. rewrite Qplus_0_l. apply Qlt_le_weak. + apply Qlt_minus_iff in majA. apply majA. + intro abs. inversion abs. +Qed. + +Lemma CReal_linear_shift : forall (x : CReal) (k : nat), + le 1 k -> QCauchySeq (fun n => proj1_sig x (k * n)%nat) Pos.to_nat. +Proof. + intros [xn limx] k lek p n m H H0. unfold proj1_sig. + apply limx. apply (le_trans _ n). apply H. + rewrite <- (mult_1_l n). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg_r. apply le_0_n. + rewrite mult_1_r. apply lek. apply (le_trans _ m). apply H0. + rewrite <- (mult_1_l m). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg_r. apply le_0_n. + rewrite mult_1_r. apply lek. +Qed. + +Lemma CReal_linear_shift_eq : forall (x : CReal) (k : nat) (kPos : le 1 k), + CRealEq x + (exist (fun n : nat -> Q => QCauchySeq n Pos.to_nat) + (fun n : nat => proj1_sig x (k * n)%nat) (CReal_linear_shift x k kPos)). +Proof. + intros. apply CRealEq_diff. intro n. + destruct x as [xn limx]; unfold proj1_sig. + specialize (limx n (Pos.to_nat n) (k * Pos.to_nat n)%nat). + apply (Qle_trans _ (1 # n)). apply Qlt_le_weak. apply limx. + apply le_refl. rewrite <- (mult_1_l (Pos.to_nat n)). + rewrite mult_assoc. apply Nat.mul_le_mono_nonneg_r. apply le_0_n. + rewrite mult_1_r. apply kPos. apply Z.mul_le_mono_nonneg_r. + discriminate. discriminate. +Qed. + +Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0), + ((/ r) rnz) * r == 1. +Proof. + intros. unfold CReal_inv; simpl. + destruct rnz. + - (* r < 0 *) destruct (CRealNegShift r c) as [[k rneg] [req maj]]. + simpl in req. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in + fun maj0 : forall n : nat, yn n < -1 # k => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n))%nat) + (CReal_inv_neg yn k cau maj0)) maj) rneg)))%Q. + + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply req. + + assert (le 1 (Pos.to_nat k * (Pos.to_nat k * 1))%nat). rewrite mult_1_r. + rewrite <- Pos2Nat.inj_mul. apply Pos2Nat.is_pos. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in + fun maj0 : forall n : nat, yn n < -1 # k => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + (CReal_inv_neg yn k cau maj0)) maj) + (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply CReal_linear_shift_eq. + destruct r as [rn limr], rneg as [rnn limneg]; simpl. + destruct (QCauchySeq_bounded + (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + Pos.to_nat (CReal_inv_neg rnn k limneg maj)). + destruct (QCauchySeq_bounded + (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) + Pos.to_nat + (CReal_linear_shift + (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) + (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. + exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. + rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. + reflexivity. intro abs. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) + * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). + simpl in maj. rewrite abs in maj. inversion maj. + - (* r > 0 *) destruct (CRealPosShift r c) as [[k rneg] [req maj]]. + simpl in req. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in + fun maj0 : forall n : nat, 1 # k < yn n => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + (CReal_inv_pos yn k cau maj0)) maj) rneg)))%Q. + + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply req. + + assert (le 1 (Pos.to_nat k * (Pos.to_nat k * 1))%nat). rewrite mult_1_r. + rewrite <- Pos2Nat.inj_mul. apply Pos2Nat.is_pos. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in + fun maj0 : forall n : nat, 1 # k < yn n => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + (CReal_inv_pos yn k cau maj0)) maj) + (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply CReal_linear_shift_eq. + destruct r as [rn limr], rneg as [rnn limneg]; simpl. + destruct (QCauchySeq_bounded + (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + Pos.to_nat (CReal_inv_pos rnn k limneg maj)). + destruct (QCauchySeq_bounded + (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) + Pos.to_nat + (CReal_linear_shift + (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) + (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. + exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. + rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. + reflexivity. intro abs. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) + * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). + simpl in maj. rewrite abs in maj. inversion maj. +Qed. + +Lemma CReal_inv_r : forall (r:CReal) (rnz : r # 0), + r * ((/ r) rnz) == 1. +Proof. + intros. rewrite CReal_mult_comm, CReal_inv_l. + reflexivity. +Qed. + +Lemma CReal_inv_1 : forall nz : 1 # 0, (/ 1) nz == 1. +Proof. + intros. rewrite <- (CReal_mult_1_l ((/1) nz)). rewrite CReal_inv_r. + reflexivity. +Qed. + +Lemma CReal_inv_mult_distr : + forall r1 r2 (r1nz : r1 # 0) (r2nz : r2 # 0) (rmnz : (r1*r2) # 0), + (/ (r1 * r2)) rmnz == (/ r1) r1nz * (/ r2) r2nz. +Proof. + intros. apply (CReal_mult_eq_reg_l r1). exact r1nz. + rewrite <- CReal_mult_assoc. rewrite CReal_inv_r. rewrite CReal_mult_1_l. + apply (CReal_mult_eq_reg_l r2). exact r2nz. + rewrite CReal_inv_r. rewrite <- CReal_mult_assoc. + rewrite (CReal_mult_comm r2 r1). rewrite CReal_inv_r. + reflexivity. +Qed. + +Lemma Rinv_eq_compat : forall x y (rxnz : x # 0) (rynz : y # 0), + x == y + -> (/ x) rxnz == (/ y) rynz. +Proof. + intros. apply (CReal_mult_eq_reg_l x). exact rxnz. + rewrite CReal_inv_r, H, CReal_inv_r. reflexivity. +Qed. + +Lemma CReal_mult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. +Proof. + intros z x y H H0. + apply (CReal_mult_lt_compat_l ((/z) (inr H))) in H0. + repeat rewrite <- CReal_mult_assoc in H0. rewrite CReal_inv_l in H0. + repeat rewrite CReal_mult_1_l in H0. apply H0. + apply CReal_inv_0_lt_compat. exact H. +Qed. + +Lemma CReal_mult_lt_reg_r : forall r r1 r2, 0 < r -> r1 * r < r2 * r -> r1 < r2. +Proof. + intros. + apply CReal_mult_lt_reg_l with r. + exact H. + now rewrite 2!(CReal_mult_comm r). +Qed. + +Lemma CReal_mult_eq_reg_r : forall r r1 r2, r1 * r == r2 * r -> r # 0 -> r1 == r2. +Proof. + intros. apply (CReal_mult_eq_reg_l r). exact H0. + now rewrite 2!(CReal_mult_comm r). +Qed. + +Lemma CReal_mult_eq_compat_l : forall r r1 r2, r1 == r2 -> r * r1 == r * r2. +Proof. + intros. rewrite H. reflexivity. +Qed. + +Lemma CReal_mult_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 * r == r2 * r. +Proof. + intros. rewrite H. reflexivity. +Qed. + +(* In particular x * y == 1 implies that 0 # x, 0 # y and + that x and y are inverses of each other. *) +Lemma CReal_mult_pos_appart_zero : forall x y : CReal, 0 < x * y -> 0 # x. +Proof. + intros. destruct (linear_order_T 0 x 1 (CRealLt_0_1)). + left. exact c. destruct (linear_order_T (CReal_opp 1) x 0). + rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar, CRealLt_0_1. + 2: right; exact c0. + pose proof (CRealLt_above _ _ H). destruct H0 as [k kmaj]. + simpl in kmaj. + apply CRealLt_above in c. destruct c as [i imaj]. simpl in imaj. + apply CRealLt_above in c0. destruct c0 as [j jmaj]. simpl in jmaj. + pose proof (CReal_abs_appart_zero y). + destruct x as [xn xcau], y as [yn ycau]. simpl in kmaj. + destruct (QCauchySeq_bounded xn Pos.to_nat xcau) as [a amaj], + (QCauchySeq_bounded yn Pos.to_nat ycau) as [b bmaj]; simpl in kmaj. + clear amaj bmaj. simpl in imaj, jmaj. simpl in H0. + specialize (kmaj (Pos.max k (Pos.max i j)) (Pos.le_max_l _ _)). + destruct (H0 ((Pos.max a b)~0 * (Pos.max k (Pos.max i j)))%positive). + - apply (Qlt_trans _ (2#k)). + + unfold Qlt. rewrite <- Z.mul_lt_mono_pos_l. 2: reflexivity. + unfold Qden. apply Pos2Z.pos_lt_pos. + apply (Pos.le_lt_trans _ (1 * Pos.max k (Pos.max i j))). + rewrite Pos.mul_1_l. apply Pos.le_max_l. + apply Pos2Nat.inj_lt. do 2 rewrite Pos2Nat.inj_mul. + rewrite <- Nat.mul_lt_mono_pos_r. 2: apply Pos2Nat.is_pos. + fold (2*Pos.max a b)%positive. rewrite Pos2Nat.inj_mul. + apply Nat.lt_1_mul_pos. auto. apply Pos2Nat.is_pos. + + apply (Qlt_le_trans _ _ _ kmaj). unfold Qminus. rewrite Qplus_0_r. + rewrite <- (Qmult_1_l (Qabs (yn (Pos.to_nat ((Pos.max a b)~0 * Pos.max k (Pos.max i j)))))). + apply (Qle_trans _ _ _ (Qle_Qabs _)). rewrite Qabs_Qmult. + replace (Pos.to_nat (Pos.max a b)~0 * Pos.to_nat (Pos.max k (Pos.max i j)))%nat + with (Pos.to_nat ((Pos.max a b)~0 * Pos.max k (Pos.max i j))). + 2: apply Pos2Nat.inj_mul. + apply Qmult_le_compat_r. 2: apply Qabs_nonneg. + apply Qabs_Qle_condition. split. + apply Qlt_le_weak. apply Qlt_minus_iff, (Qlt_trans _ (2#j)). + reflexivity. apply jmaj. + apply (Pos.le_trans _ (1 * Pos.max k (Pos.max i j))). + rewrite Pos.mul_1_l. + apply (Pos.le_trans _ (Pos.max i j) _ (Pos.le_max_r _ _)). + apply Pos.le_max_r. + apply Pos2Nat.inj_le. do 2 rewrite Pos2Nat.inj_mul. + rewrite <- Nat.mul_le_mono_pos_r. 2: apply Pos2Nat.is_pos. + apply Pos2Nat.is_pos. + apply Qlt_le_weak. apply Qlt_minus_iff, (Qlt_trans _ (2#i)). + reflexivity. apply imaj. + apply (Pos.le_trans _ (1 * Pos.max k (Pos.max i j))). + rewrite Pos.mul_1_l. + apply (Pos.le_trans _ (Pos.max i j) _ (Pos.le_max_l _ _)). + apply Pos.le_max_r. + apply Pos2Nat.inj_le. do 2 rewrite Pos2Nat.inj_mul. + rewrite <- Nat.mul_le_mono_pos_r. 2: apply Pos2Nat.is_pos. + apply Pos2Nat.is_pos. + - left. apply (CReal_mult_lt_reg_r (exist _ yn ycau) _ _ c). + rewrite CReal_mult_0_l. exact H. + - right. apply (CReal_mult_lt_reg_r (CReal_opp (exist _ yn ycau))). + rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar. exact c. + rewrite CReal_mult_0_l, <- CReal_opp_0, <- CReal_opp_mult_distr_r. + apply CReal_opp_gt_lt_contravar. exact H. +Qed. + +Fixpoint pow (r:CReal) (n:nat) : CReal := + match n with + | O => 1 + | S n => r * (pow r n) + end. + + +Lemma CReal_mult_le_compat_l_half : forall r r1 r2, + 0 < r -> r1 <= r2 -> r * r1 <= r * r2. +Proof. + intros. intro abs. apply (CReal_mult_lt_reg_l) in abs. + contradiction. apply H. +Qed. + +Lemma CReal_invQ : forall (b : positive) (pos : Qlt 0 (Z.pos b # 1)), + CRealEq (CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos))) + (inject_Q (1 # b)). +Proof. + intros. + apply (CReal_mult_eq_reg_l (inject_Q (Z.pos b # 1))). + - right. apply CReal_injectQPos. exact pos. + - rewrite CReal_mult_comm, CReal_inv_l. + apply CRealEq_diff. intro n. simpl; + destruct (QCauchySeq_bounded (fun _ : nat => 1 # b)%Q Pos.to_nat (ConstCauchy (1 # b))), + (QCauchySeq_bounded (fun _ : nat => Z.pos b # 1)%Q Pos.to_nat (ConstCauchy (Z.pos b # 1))); simpl. + do 2 rewrite Pos.mul_1_r. rewrite Z.pos_sub_diag. discriminate. +Qed. + +Definition CRealQ_dense (a b : CReal) + : a < b -> { q : Q & a < inject_Q q < b }. +Proof. + (* Locate a and b at the index given by a<b, + and pick the middle rational number. *) + intros [p pmaj]. + exists ((proj1_sig a (Pos.to_nat p) + proj1_sig b (Pos.to_nat p)) * (1#2))%Q. + split. + - apply (CReal_le_lt_trans _ _ _ (inject_Q_compare a p)). apply inject_Q_lt. + apply (Qmult_lt_l _ _ 2). reflexivity. + apply (Qplus_lt_l _ _ (-2*proj1_sig a (Pos.to_nat p))). + field_simplify. field_simplify in pmaj. + setoid_replace (-2#2)%Q with (-1)%Q. 2: reflexivity. + setoid_replace (2*(1#p))%Q with (2#p)%Q. 2: reflexivity. + rewrite Qplus_comm. exact pmaj. + - apply (CReal_plus_lt_reg_l (-b)). + rewrite CReal_plus_opp_l. + apply (CReal_plus_lt_reg_r + (-inject_Q ((proj1_sig a (Pos.to_nat p) + proj1_sig b (Pos.to_nat p)) * (1 # 2)))). + rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r, CReal_plus_0_l. + rewrite <- opp_inject_Q. + apply (CReal_le_lt_trans _ _ _ (inject_Q_compare (-b) p)). apply inject_Q_lt. + apply (Qmult_lt_l _ _ 2). reflexivity. + apply (Qplus_lt_l _ _ (2*proj1_sig b (Pos.to_nat p))). + destruct b as [bn bcau]; simpl. simpl in pmaj. + field_simplify. field_simplify in pmaj. + setoid_replace (-2#2)%Q with (-1)%Q. 2: reflexivity. + setoid_replace (2*(1#p))%Q with (2#p)%Q. 2: reflexivity. exact pmaj. +Qed. + +Lemma inject_Q_mult : forall q r : Q, + inject_Q (q * r) == inject_Q q * inject_Q r. +Proof. + split. + - intros [n maj]. simpl in maj. + destruct (QCauchySeq_bounded (fun _ : nat => q) Pos.to_nat (ConstCauchy q)). + destruct (QCauchySeq_bounded (fun _ : nat => r) Pos.to_nat (ConstCauchy r)). + simpl in maj. ring_simplify in maj. discriminate maj. + - intros [n maj]. simpl in maj. + destruct (QCauchySeq_bounded (fun _ : nat => q) Pos.to_nat (ConstCauchy q)). + destruct (QCauchySeq_bounded (fun _ : nat => r) Pos.to_nat (ConstCauchy r)). + simpl in maj. ring_simplify in maj. discriminate maj. +Qed. diff --git a/theories/Reals/ConstructiveRIneq.v b/theories/Reals/ConstructiveRIneq.v index b53436be55..e0f08d2fbe 100644 --- a/theories/Reals/ConstructiveRIneq.v +++ b/theories/Reals/ConstructiveRIneq.v @@ -22,9 +22,8 @@ constructive reals, do not use ConstructiveCauchyReals directly. *) -Require Import ConstructiveCauchyReals. +Require Import ConstructiveCauchyRealsMult. Require Import ConstructiveRcomplete. -Require Import ConstructiveRealsLUB. Require Export ConstructiveReals. Require Import Zpower. Require Export ZArithRing. @@ -37,11 +36,11 @@ Declare Scope R_scope_constr. Local Open Scope Z_scope. Local Open Scope R_scope_constr. -Definition CR : ConstructiveReals. +Definition CRealImplem : ConstructiveReals. Proof. assert (isLinearOrder CReal CRealLt) as lin. { repeat split. exact CRealLt_asym. - exact CRealLt_trans. + exact CReal_lt_trans. intros. destruct (CRealLt_dec x z y H). left. exact c. right. exact c. } apply (Build_ConstructiveReals @@ -53,30 +52,25 @@ Proof. CReal_plus_lt_compat_l CReal_plus_lt_reg_l CReal_mult_lt_0_compat CReal_inv CReal_inv_l CReal_inv_0_lt_compat - CRealArchimedean). + inject_Q inject_Q_plus inject_Q_mult + inject_Q_one inject_Q_lt lt_inject_Q + CRealQ_dense Rup_pos). - intros. destruct (Rcauchy_complete xn) as [l cv]. - intro n. apply (H (IQR (1#n))). apply IQR_pos. reflexivity. - exists l. intros eps epsPos. - destruct (Rup_nat ((/eps) (inr epsPos))) as [n nmaj]. - specialize (cv (Pos.of_nat (S n))) as [p pmaj]. - exists p. intros. specialize (pmaj i H0). unfold absSmall in pmaj. - apply (CReal_mult_lt_compat_l eps) in nmaj. - rewrite CReal_inv_r, CReal_mult_comm in nmaj. - 2: apply epsPos. split. - + apply (CRealLt_trans _ (-IQR (1 # Pos.of_nat (S n)))). - 2: apply pmaj. clear pmaj. - apply CReal_opp_gt_lt_contravar. unfold CRealGt, IQR. - rewrite CReal_mult_1_l. apply (CReal_mult_lt_reg_l (IPR (Pos.of_nat (S n)))). - apply IPR_pos. rewrite CReal_inv_r, <- INR_IPR, Nat2Pos.id. - 2: discriminate. apply (CRealLt_trans _ (INR n * eps) _ nmaj). - apply CReal_mult_lt_compat_r. exact epsPos. apply lt_INR, le_refl. - + apply (CRealLt_trans _ (IQR (1 # Pos.of_nat (S n)))). - apply pmaj. unfold IQR. rewrite CReal_mult_1_l. - apply (CReal_mult_lt_reg_l (IPR (Pos.of_nat (S n)))). - apply IPR_pos. rewrite CReal_inv_r, <- INR_IPR, Nat2Pos.id. - 2: discriminate. apply (CRealLt_trans _ (INR n * eps) _ nmaj). - apply CReal_mult_lt_compat_r. exact epsPos. apply lt_INR, le_refl. - - exact sig_lub. + intro n. destruct (H n). exists x. intros. + specialize (a i j H0 H1) as [a b]. split. 2: exact b. + rewrite <- opp_inject_Q. + setoid_replace (-(1#n))%Q with (-1#n). exact a. reflexivity. + exists l. intros p. destruct (cv p). + exists x. intros. specialize (a i H0). split. 2: apply a. + unfold orderLe. + intro abs. setoid_replace (-1#p) with (-(1#p))%Q in abs. + rewrite opp_inject_Q in abs. destruct a. contradiction. + reflexivity. +Defined. + +Definition CR : ConstructiveReals. +Proof. + exact CRealImplem. Qed. (* Keep it opaque to possibly change the implementation later *) Definition R := CRcarrier CR. @@ -1673,6 +1667,19 @@ Proof. intro; destruct n. rewrite Rplus_0_l. reflexivity. reflexivity. Qed. +(**********) +Lemma IZN : forall n:Z, (0 <= n)%Z -> { m : nat | n = Z.of_nat m }. +Proof. + intros. exists (Z.to_nat n). rewrite Z2Nat.id. reflexivity. assumption. +Qed. + +Lemma le_succ_r_T : forall n m : nat, (n <= S m)%nat -> {(n <= m)%nat} + {n = S m}. +Proof. + intros. destruct (le_lt_dec n m). left. exact l. + right. apply Nat.le_succ_r in H. destruct H. + exfalso. apply (le_not_lt n m); assumption. exact H. +Qed. + Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m. Proof. induction m. @@ -2174,35 +2181,29 @@ Proof. contradiction. apply H. Qed. -Lemma INR_gen_phiZ : forall (n : nat), - gen_phiZ 0 1 Rplus Rmult Ropp (Z.of_nat n) == INR n. +Lemma INR_CR_of_Q : forall (n : nat), + CR_of_Q CR (Z.of_nat n # 1) == INR n. Proof. induction n. - - apply Req_refl. - - replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z. - rewrite (gen_phiZ_add Req_rel (CRisRingExt CR) RisRing). - rewrite IHn. clear IHn. simpl. rewrite (Rplus_comm 1). - destruct n. rewrite Rplus_0_l. reflexivity. reflexivity. + - apply CR_of_Q_zero. + - transitivity (CR_of_Q CR (1 + (Z.of_nat n # 1))). replace (S n) with (1 + n)%nat. 2: reflexivity. - rewrite (Nat2Z.inj_add 1 n). reflexivity. + rewrite (Nat2Z.inj_add 1 n). + apply CR_of_Q_proper. + rewrite <- (Qinv_plus_distr (Z.of_nat 1) (Z.of_nat n) 1). reflexivity. + rewrite CR_of_Q_plus. rewrite IHn. clear IHn. + setoid_replace (INR (S n)) with (1 + INR n). + rewrite CR_of_Q_one. reflexivity. + simpl. destruct n. rewrite Rplus_0_r. reflexivity. + rewrite Rplus_comm. reflexivity. Qed. Definition Rup_nat (x : R) : { n : nat & x < INR n }. Proof. - intros. destruct (CRarchimedean CR x) as [p maj]. - destruct p. - - exists O. apply maj. - - exists (Pos.to_nat p). - rewrite <- positive_nat_Z, (INR_gen_phiZ (Pos.to_nat p)) in maj. exact maj. - - exists O. apply (Rlt_trans _ _ _ maj). simpl. - rewrite <- Ropp_0. apply Ropp_gt_lt_contravar. - fold (gen_phiZ 0 1 Rplus Rmult Ropp (Z.pos p)). - replace (gen_phiPOS 1 (CRplus CR) (CRmult CR) p) - with (gen_phiZ 0 1 Rplus Rmult Ropp (Z.pos p)). - 2: reflexivity. - rewrite <- positive_nat_Z, (INR_gen_phiZ (Pos.to_nat p)). - apply (lt_INR 0). apply Pos2Nat.is_pos. + intros. destruct (CR_archimedean CR x) as [p maj]. + exists (Pos.to_nat p). + rewrite <- INR_CR_of_Q, positive_nat_Z. exact maj. Qed. Fixpoint Rarchimedean_ind (x:R) (n : Z) (p:nat) { struct p } diff --git a/theories/Reals/ConstructiveRcomplete.v b/theories/Reals/ConstructiveRcomplete.v index ce45bcd567..0a515672f2 100644 --- a/theories/Reals/ConstructiveRcomplete.v +++ b/theories/Reals/ConstructiveRcomplete.v @@ -11,227 +11,145 @@ Require Import QArith_base. Require Import Qabs. -Require Import ConstructiveCauchyReals. +Require Import ConstructiveCauchyRealsMult. Require Import Logic.ConstructiveEpsilon. Local Open Scope CReal_scope. +Definition absLe (a b : CReal) : Prop + := -b <= a <= b. + Lemma CReal_absSmall : forall (x y : CReal) (n : positive), (Qlt (2 # n) (proj1_sig x (Pos.to_nat n) - Qabs (proj1_sig y (Pos.to_nat n)))) - -> (CRealLt (CReal_opp x) y * CRealLt y x). + -> absLe y x. Proof. intros x y n maj. split. - - exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. simpl in maj. unfold Qminus. rewrite Qopp_involutive. rewrite Qplus_comm. apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). apply maj. apply Qplus_le_r. rewrite <- (Qopp_involutive (yn (Pos.to_nat n))). apply Qopp_le_compat. rewrite Qabs_opp. apply Qle_Qabs. - - exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. simpl in maj. apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). apply maj. apply Qplus_le_r. apply Qopp_le_compat. apply Qle_Qabs. Qed. -Definition absSmall (a b : CReal) : Set - := -b < a < b. - +(* We use absLe in sort Prop rather than Set, + to extract smaller programs. *) Definition Un_cv_mod (un : nat -> CReal) (l : CReal) : Set - := forall n : positive, - { p : nat & forall i:nat, le p i -> absSmall (un i - l) (IQR (1#n)) }. + := forall p : positive, + { n : nat | forall i:nat, le n i -> absLe (un i - l) (inject_Q (1#p)) }. Lemma Un_cv_mod_eq : forall (v u : nat -> CReal) (s : CReal), (forall n:nat, u n == v n) - -> Un_cv_mod u s -> Un_cv_mod v s. + -> Un_cv_mod u s + -> Un_cv_mod v s. Proof. intros v u s seq H1 p. specialize (H1 p) as [N H0]. - exists N. intros. unfold absSmall. split. + exists N. intros. split. rewrite <- seq. apply H0. apply H. rewrite <- seq. apply H0. apply H. Qed. Definition Un_cauchy_mod (un : nat -> CReal) : Set - := forall n : positive, - { p : nat & forall i j:nat, le p i - -> le p j - -> -IQR (1#n) < un i - un j < IQR (1#n) }. + := forall p : positive, + { n : nat | forall i j:nat, le n i -> le n j + -> absLe (un i - un j) (inject_Q (1#p)) }. (* Sharpen the archimedean property : constructive versions of - the usual floor and ceiling functions. - - n is a temporary parameter used for the recursion, - look at Ffloor below. *) -Fixpoint Rfloor_pos (a : CReal) (n : nat) { struct n } - : 0 < a - -> a < INR n - -> { p : nat & INR p < a < INR p + 2 }. -Proof. - (* Decreasing loop on n, until it is the first integer above a. *) - intros H H0. destruct n. - - exfalso. apply (CRealLt_asym 0 a); assumption. - - destruct n as [|p] eqn:des. - + (* n = 1 *) exists O. split. - apply H. rewrite CReal_plus_0_l. apply (CRealLt_trans a (1+0)). - rewrite CReal_plus_comm, CReal_plus_0_l. apply H0. - apply CReal_plus_le_lt_compat. - apply CRealLe_refl. apply CRealLt_0_1. - + (* n > 1 *) - destruct (linear_order_T (INR p) a (INR (S p))). - * rewrite <- CReal_plus_0_l, S_INR, CReal_plus_comm. apply CReal_plus_lt_compat_l. - apply CRealLt_0_1. - * exists p. split. exact c. - rewrite S_INR, S_INR, CReal_plus_assoc in H0. exact H0. - * apply (Rfloor_pos a n H). rewrite des. apply c. -Qed. - + the usual floor and ceiling functions. *) Definition Rfloor (a : CReal) - : { p : Z & IZR p < a < IZR p + 2 }. + : { p : Z & inject_Q (p#1) < a < inject_Q (p#1) + 2 }. Proof. - assert (forall x:CReal, 0 < x -> { n : nat & x < INR n }). - { intros. pose proof (Rarchimedean x) as [n [maj _]]. - destruct n. - + exfalso. apply (CRealLt_asym 0 x); assumption. - + exists (Pos.to_nat p). rewrite INR_IPR. apply maj. - + exfalso. apply (CRealLt_asym 0 x). apply H. - apply (CRealLt_trans x (IZR (Z.neg p))). apply maj. - apply (CReal_plus_lt_reg_l (-IZR (Z.neg p))). - rewrite CReal_plus_comm, CReal_plus_opp_r. rewrite <- opp_IZR. - rewrite CReal_plus_comm, CReal_plus_0_l. - apply (IZR_lt 0). reflexivity. } - destruct (linear_order_T 0 a 1 CRealLt_0_1). - - destruct (H a c). destruct (Rfloor_pos a x c c0). - exists (Z.of_nat x0). split; rewrite <- INR_IZR_INZ; apply p. - - apply (CReal_plus_lt_compat_l (-a)) in c. - rewrite CReal_plus_comm, CReal_plus_opp_r, CReal_plus_comm in c. - destruct (H (1-a) c). - destruct (Rfloor_pos (1-a) x c c0). - exists (-(Z.of_nat x0 + 1))%Z. split; rewrite opp_IZR, plus_IZR. - + rewrite <- (CReal_opp_involutive a). apply CReal_opp_gt_lt_contravar. - destruct p as [_ a0]. apply (CReal_plus_lt_reg_r 1). - rewrite CReal_plus_comm, CReal_plus_assoc. rewrite <- INR_IZR_INZ. apply a0. - + destruct p as [a0 _]. apply (CReal_plus_lt_compat_l a) in a0. - unfold CReal_minus in a0. - rewrite <- (CReal_plus_comm (1+-a)), CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_r in a0. - rewrite <- INR_IZR_INZ. - apply (CReal_plus_lt_reg_r (INR x0)). unfold IZR, IPR, IPR_2. - ring_simplify. exact a0. -Qed. + destruct (CRealArchimedean a) as [n [H H0]]. + exists (n-2)%Z. split. + - setoid_replace (n - 2 # 1)%Q with ((n#1) + - 2)%Q. + rewrite inject_Q_plus, (opp_inject_Q 2). + apply (CReal_plus_lt_reg_r 2). ring_simplify. + rewrite CReal_plus_comm. exact H0. + rewrite Qinv_plus_distr. reflexivity. + - setoid_replace (n - 2 # 1)%Q with ((n#1) + - 2)%Q. + rewrite inject_Q_plus, (opp_inject_Q 2). + ring_simplify. exact H. + rewrite Qinv_plus_distr. reflexivity. +Defined. -Definition Rup_nat (x : CReal) - : { n : nat & x < INR n }. -Proof. - intros. destruct (Rarchimedean x) as [p [maj _]]. - destruct p. - - exists O. apply maj. - - exists (Pos.to_nat p). rewrite INR_IPR. apply maj. - - exists O. apply (CRealLt_trans _ (IZR (Z.neg p)) _ maj). - apply (IZR_lt _ 0). reflexivity. -Qed. (* A point in an archimedean field is the limit of a sequence of rational numbers (n maps to the q between a and a+1/n). This will yield a maximum archimedean field, which is the field of real numbers. *) -Definition FQ_dense_pos (a b : CReal) - : 0 < b - -> a < b -> { q : Q & a < IQR q < b }. -Proof. - intros H H0. - assert (0 < b - a) as epsPos. - { apply (CReal_plus_lt_compat_l (-a)) in H0. - rewrite CReal_plus_opp_l, CReal_plus_comm in H0. - apply H0. } - pose proof (Rup_nat ((/(b-a)) (inr epsPos))) - as [n maj]. - destruct n as [|k]. - - exfalso. - apply (CReal_mult_lt_compat_l (b-a)) in maj. 2: apply epsPos. - rewrite CReal_mult_0_r in maj. rewrite CReal_inv_r in maj. - apply (CRealLt_asym 0 1). apply CRealLt_0_1. apply maj. - - (* 0 < n *) - pose (Pos.of_nat (S k)) as n. - destruct (Rfloor (IZR (2 * Z.pos n) * b)) as [p maj2]. - exists (p # (2*n))%Q. split. - + apply (CRealLt_trans a (b - IQR (1 # n))). - apply (CReal_plus_lt_reg_r (IQR (1#n))). - unfold CReal_minus. rewrite CReal_plus_assoc. rewrite CReal_plus_opp_l. - rewrite CReal_plus_0_r. apply (CReal_plus_lt_reg_l (-a)). - rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l. - rewrite CReal_plus_comm. unfold IQR. - rewrite CReal_mult_1_l. apply (CReal_mult_lt_reg_l (IPR n)). - apply IPR_pos. rewrite CReal_inv_r. - apply (CReal_mult_lt_compat_l (b-a)) in maj. - rewrite CReal_inv_r, CReal_mult_comm in maj. - rewrite <- INR_IPR. unfold n. rewrite Nat2Pos.id. - apply maj. discriminate. exact epsPos. - apply (CReal_plus_lt_reg_r (IQR (1 # n))). - unfold CReal_minus. rewrite CReal_plus_assoc, CReal_plus_opp_l. - rewrite CReal_plus_0_r. rewrite <- plus_IQR. - destruct maj2 as [_ maj2]. - setoid_replace ((p # 2 * n) + (1 # n))%Q - with ((p + 2 # 2 * n))%Q. unfold IQR. - apply (CReal_mult_lt_reg_r (IZR (Z.pos (2 * n)))). - apply (IZR_lt 0). reflexivity. rewrite CReal_mult_assoc. - rewrite CReal_inv_l. rewrite CReal_mult_1_r. rewrite CReal_mult_comm. - rewrite plus_IZR. apply maj2. - setoid_replace (1#n)%Q with (2#2*n)%Q. 2: reflexivity. - apply Qinv_plus_distr. - + destruct maj2 as [maj2 _]. unfold IQR. - apply (CReal_mult_lt_reg_r (IZR (Z.pos (2 * n)))). - apply (IZR_lt 0). apply Pos2Z.is_pos. rewrite CReal_mult_assoc, CReal_inv_l. - rewrite CReal_mult_1_r, CReal_mult_comm. apply maj2. -Qed. - Definition FQ_dense (a b : CReal) - : a < b - -> { q : Q & a < IQR q < b }. + : a < b -> { q : Q & a < inject_Q q < b }. Proof. - intros H. destruct (linear_order_T a 0 b). apply H. - - destruct (FQ_dense_pos (-b) (-a)) as [q maj]. - apply (CReal_plus_lt_compat_l (-a)) in c. rewrite CReal_plus_opp_l in c. - rewrite CReal_plus_0_r in c. apply c. - apply (CReal_plus_lt_compat_l (-a)) in H. + intros H. assert (0 < b - a) as epsPos. + { apply (CReal_plus_lt_compat_l (-a)) in H. rewrite CReal_plus_opp_l, CReal_plus_comm in H. - apply (CReal_plus_lt_compat_l (-b)) in H. rewrite <- CReal_plus_assoc in H. - rewrite CReal_plus_opp_l in H. rewrite CReal_plus_0_l in H. - rewrite CReal_plus_0_r in H. apply H. - exists (-q)%Q. split. - + destruct maj as [_ maj]. - apply (CReal_plus_lt_compat_l (-IQR q)) in maj. - rewrite CReal_plus_opp_l, <- opp_IQR, CReal_plus_comm in maj. - apply (CReal_plus_lt_compat_l a) in maj. rewrite <- CReal_plus_assoc in maj. - rewrite CReal_plus_opp_r, CReal_plus_0_l in maj. - rewrite CReal_plus_0_r in maj. apply maj. - + destruct maj as [maj _]. - apply (CReal_plus_lt_compat_l (-IQR q)) in maj. - rewrite CReal_plus_opp_l, <- opp_IQR, CReal_plus_comm in maj. - apply (CReal_plus_lt_compat_l b) in maj. rewrite <- CReal_plus_assoc in maj. - rewrite CReal_plus_opp_r in maj. rewrite CReal_plus_0_l in maj. - rewrite CReal_plus_0_r in maj. apply maj. - - apply FQ_dense_pos. apply c. apply H. + apply H. } + pose proof (Rup_pos ((/(b-a)) (inr epsPos))) + as [n maj]. + destruct (Rfloor (inject_Q (2 * Z.pos n # 1) * b)) as [p maj2]. + exists (p # (2*n))%Q. split. + - apply (CReal_lt_trans a (b - inject_Q (1 # n))). + apply (CReal_plus_lt_reg_r (inject_Q (1#n))). + unfold CReal_minus. rewrite CReal_plus_assoc. rewrite CReal_plus_opp_l. + rewrite CReal_plus_0_r. apply (CReal_plus_lt_reg_l (-a)). + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l. + rewrite CReal_plus_comm. + apply (CReal_mult_lt_reg_l (inject_Q (Z.pos n # 1))). + apply inject_Q_lt. reflexivity. rewrite <- inject_Q_mult. + setoid_replace ((Z.pos n # 1) * (1 # n))%Q with 1%Q. + apply (CReal_mult_lt_compat_l (b-a)) in maj. + rewrite CReal_inv_r, CReal_mult_comm in maj. exact maj. + exact epsPos. unfold Qeq; simpl. do 2 rewrite Pos.mul_1_r. reflexivity. + apply (CReal_plus_lt_reg_r (inject_Q (1 # n))). + unfold CReal_minus. rewrite CReal_plus_assoc, CReal_plus_opp_l. + rewrite CReal_plus_0_r. rewrite <- inject_Q_plus. + destruct maj2 as [_ maj2]. + setoid_replace ((p # 2 * n) + (1 # n))%Q + with ((p + 2 # 2 * n))%Q. + apply (CReal_mult_lt_reg_r (inject_Q (Z.pos (2 * n) # 1))). + apply inject_Q_lt. reflexivity. rewrite <- inject_Q_mult. + setoid_replace ((p + 2 # 2 * n) * (Z.pos (2 * n) # 1))%Q + with ((p#1) + 2)%Q. + rewrite inject_Q_plus. rewrite Pos2Z.inj_mul. + rewrite CReal_mult_comm. exact maj2. + unfold Qeq; simpl. rewrite Pos.mul_1_r, Z.mul_1_r. ring. + setoid_replace (1#n)%Q with (2#2*n)%Q. 2: reflexivity. + apply Qinv_plus_distr. + - destruct maj2 as [maj2 _]. + apply (CReal_mult_lt_reg_r (inject_Q (Z.pos (2 * n) # 1))). + apply inject_Q_lt. reflexivity. + rewrite <- inject_Q_mult. + setoid_replace ((p # 2 * n) * (Z.pos (2 * n) # 1))%Q + with ((p#1))%Q. + rewrite CReal_mult_comm. exact maj2. + unfold Qeq; simpl. rewrite Pos.mul_1_r, Z.mul_1_r. reflexivity. Qed. Definition RQ_limit : forall (x : CReal) (n:nat), - { q:Q & x < IQR q < x + IQR (1 # Pos.of_nat n) }. + { q:Q & x < inject_Q q < x + inject_Q (1 # Pos.of_nat n) }. Proof. - intros x n. apply (FQ_dense x (x + IQR (1 # Pos.of_nat n))). + intros x n. apply (FQ_dense x (x + inject_Q (1 # Pos.of_nat n))). rewrite <- (CReal_plus_0_r x). rewrite CReal_plus_assoc. - apply CReal_plus_lt_compat_l. rewrite CReal_plus_0_l. apply IQR_pos. + apply CReal_plus_lt_compat_l. rewrite CReal_plus_0_l. apply inject_Q_lt. reflexivity. Qed. Definition Un_cauchy_Q (xn : nat -> Q) : Set := forall n : positive, { k : nat | forall p q : nat, le k p -> le k q - -> Qlt (-(1#n)) (xn p - xn q) - /\ Qlt (xn p - xn q) (1#n) }. + -> Qle (-(1#n)) (xn p - xn q) + /\ Qle (xn p - xn q) (1#n) }. Lemma Rdiag_cauchy_sequence : forall (xn : nat -> CReal), Un_cauchy_mod xn - -> Un_cauchy_Q (fun n => let (l,_) := RQ_limit (xn n) n in l). + -> Un_cauchy_Q (fun n:nat => let (l,_) := RQ_limit (xn n) n in l). Proof. intros xn H p. specialize (H (2 * p)%positive) as [k cv]. exists (max k (2 * Pos.to_nat p)). intros. @@ -241,67 +159,69 @@ Proof. apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). apply Nat.le_max_l. apply H0. split. - - apply lt_IQR. unfold Qminus. - apply (CRealLt_trans _ (xn p0 - (xn q + IQR (1 # 2 * p)))). - + unfold CReal_minus. rewrite CReal_opp_plus_distr. unfold CReal_minus. + - apply le_inject_Q. unfold Qminus. + apply (CReal_le_trans _ (xn p0 - (xn q + inject_Q (1 # 2 * p)))). + + unfold CReal_minus. rewrite CReal_opp_plus_distr. rewrite <- CReal_plus_assoc. - apply (CReal_plus_lt_reg_r (IQR (1 # 2 * p))). + apply (CReal_plus_le_reg_r (inject_Q (1 # 2 * p))). rewrite CReal_plus_assoc. rewrite CReal_plus_opp_l. rewrite CReal_plus_0_r. - rewrite <- plus_IQR. + rewrite <- inject_Q_plus. setoid_replace (- (1 # p) + (1 # 2 * p))%Q with (- (1 # 2 * p))%Q. - rewrite opp_IQR. exact c. + rewrite opp_inject_Q. exact H1. rewrite Qplus_comm. setoid_replace (1#p)%Q with (2 # 2 *p)%Q. rewrite Qinv_minus_distr. reflexivity. reflexivity. - + rewrite plus_IQR. apply CReal_plus_le_lt_compat. + + rewrite inject_Q_plus. apply CReal_plus_le_compat. apply CRealLt_asym. destruct (RQ_limit (xn p0) p0); simpl. apply p1. + apply CRealLt_asym. destruct (RQ_limit (xn q) q); unfold proj1_sig. - rewrite opp_IQR. apply CReal_opp_gt_lt_contravar. - apply (CRealLt_Le_trans _ (xn q + IQR (1 # Pos.of_nat q))). - apply p1. apply CReal_plus_le_compat_l. apply IQR_le. + rewrite opp_inject_Q. apply CReal_opp_gt_lt_contravar. + apply (CReal_lt_le_trans _ (xn q + inject_Q (1 # Pos.of_nat q))). + apply p1. apply CReal_plus_le_compat_l. apply inject_Q_le. apply Z2Nat.inj_le. discriminate. discriminate. simpl. assert ((Pos.to_nat p~0 <= q)%nat). { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). 2: apply H0. replace (p~0)%positive with (2*p)%positive. 2: reflexivity. rewrite Pos2Nat.inj_mul. apply Nat.le_max_r. } - rewrite Nat2Pos.id. apply H1. intro abs. subst q. - inversion H1. pose proof (Pos2Nat.is_pos (p~0)). - rewrite H3 in H2. inversion H2. - - apply lt_IQR. unfold Qminus. - apply (CRealLt_trans _ (xn p0 + IQR (1 # 2 * p) - xn q)). - + rewrite plus_IQR. apply CReal_plus_le_lt_compat. + rewrite Nat2Pos.id. apply H3. intro abs. subst q. + inversion H3. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H5 in H4. inversion H4. + - apply le_inject_Q. unfold Qminus. + apply (CReal_le_trans _ (xn p0 + inject_Q (1 # 2 * p) - xn q)). + + rewrite inject_Q_plus. apply CReal_plus_le_compat. apply CRealLt_asym. destruct (RQ_limit (xn p0) p0); unfold proj1_sig. - apply (CRealLt_Le_trans _ (xn p0 + IQR (1 # Pos.of_nat p0))). - apply p1. apply CReal_plus_le_compat_l. apply IQR_le. + apply (CReal_lt_le_trans _ (xn p0 + inject_Q (1 # Pos.of_nat p0))). + apply p1. apply CReal_plus_le_compat_l. apply inject_Q_le. apply Z2Nat.inj_le. discriminate. discriminate. simpl. assert ((Pos.to_nat p~0 <= p0)%nat). { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). 2: apply H. replace (p~0)%positive with (2*p)%positive. 2: reflexivity. rewrite Pos2Nat.inj_mul. apply Nat.le_max_r. } - rewrite Nat2Pos.id. apply H1. intro abs. subst p0. - inversion H1. pose proof (Pos2Nat.is_pos (p~0)). - rewrite H3 in H2. inversion H2. - rewrite opp_IQR. apply CReal_opp_gt_lt_contravar. + rewrite Nat2Pos.id. apply H3. intro abs. subst p0. + inversion H3. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H5 in H4. inversion H4. + apply CRealLt_asym. + rewrite opp_inject_Q. apply CReal_opp_gt_lt_contravar. destruct (RQ_limit (xn q) q); simpl. apply p1. + unfold CReal_minus. rewrite (CReal_plus_comm (xn p0)). rewrite CReal_plus_assoc. - apply (CReal_plus_lt_reg_l (- IQR (1 # 2 * p))). + apply (CReal_plus_le_reg_l (- inject_Q (1 # 2 * p))). rewrite <- CReal_plus_assoc. rewrite CReal_plus_opp_l. rewrite CReal_plus_0_l. - rewrite <- opp_IQR. rewrite <- plus_IQR. + rewrite <- opp_inject_Q. rewrite <- inject_Q_plus. setoid_replace (- (1 # 2 * p) + (1 # p))%Q with (1 # 2 * p)%Q. - exact c0. rewrite Qplus_comm. + exact H2. rewrite Qplus_comm. setoid_replace (1#p)%Q with (2 # 2*p)%Q. rewrite Qinv_minus_distr. reflexivity. reflexivity. Qed. -Lemma doubleLtCovariant : forall a b c d e f : CReal, +Lemma doubleLeCovariant : forall a b c d e f : CReal, a == b -> c == d -> e == f - -> (a < c < e) - -> (b < d < f). + -> (a <= c <= e) + -> (b <= d <= f). Proof. split. rewrite <- H. rewrite <- H0. apply H2. rewrite <- H0. rewrite <- H1. apply H2. @@ -311,15 +231,13 @@ Qed. show that it converges to itself in CReal. *) Lemma CReal_cv_self : forall (qn : nat -> Q) (x : CReal) (cvmod : positive -> nat), QSeqEquiv qn (fun n => proj1_sig x n) cvmod - -> Un_cv_mod (fun n => IQR (qn n)) x. + -> Un_cv_mod (fun n => inject_Q (qn n)) x. Proof. intros qn x cvmod H p. specialize (H (2*p)%positive). exists (cvmod (2*p)%positive). - intros p0 H0. unfold absSmall, CReal_minus. - apply (doubleLtCovariant (-inject_Q (1#p)) _ (inject_Q (qn p0) - x) _ (inject_Q (1#p))). - rewrite FinjectQ_CReal. reflexivity. - rewrite FinjectQ_CReal. reflexivity. - rewrite FinjectQ_CReal. reflexivity. + intros p0 H0. unfold absLe, CReal_minus. + apply (doubleLeCovariant (-inject_Q (1#p)) _ (inject_Q (qn p0) - x) _ (inject_Q (1#p))). + reflexivity. reflexivity. reflexivity. apply (CReal_absSmall _ _ (Pos.max (4 * p)%positive (Pos.of_nat (cvmod (2 * p)%positive)))). setoid_replace (proj1_sig (inject_Q (1 # p)) (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))) with (1 # p)%Q. @@ -353,7 +271,7 @@ Lemma Un_cv_extens : forall (xn yn : nat -> CReal) (l : CReal), -> Un_cv_mod yn l. Proof. intros. intro p. destruct (H p) as [n cv]. exists n. - intros. unfold absSmall, CReal_minus. + intros. unfold absLe, CReal_minus. split; rewrite <- (H0 i); apply cv; apply H1. Qed. @@ -362,29 +280,28 @@ Qed. The biggest computable such field has all rational limits. *) Lemma R_has_all_rational_limits : forall qn : nat -> Q, Un_cauchy_Q qn - -> { r : CReal & Un_cv_mod (fun n => IQR (qn n)) r }. + -> { r : CReal & Un_cv_mod (fun n:nat => inject_Q (qn n)) r }. Proof. - (* qn is an element of CReal. Show that IQR qn + (* qn is an element of CReal. Show that inject_Q qn converges to it in CReal. *) intros. - destruct (standard_modulus qn (fun p => proj1_sig (H p))). - - intros p n k H0 H1. destruct (H p); simpl in H0,H1. - specialize (a n k H0 H1). apply Qabs_case. - intros _. apply a. intros _. - apply (Qplus_lt_r _ _ (qn n -qn k-(1#p))). ring_simplify. - destruct a. ring_simplify in H2. exact H2. + destruct (standard_modulus qn (fun p => proj1_sig (H (Pos.succ p)))). + - intros p n k H0 H1. destruct (H (Pos.succ p)%positive) as [x a]; simpl in H0,H1. + specialize (a n k H0 H1). + apply (Qle_lt_trans _ (1#Pos.succ p)). + apply Qabs_Qle_condition. exact a. + apply Pos2Z.pos_lt_pos. simpl. apply Pos.lt_succ_diag_r. - exists (exist _ (fun n : nat => - qn (increasing_modulus (fun p : positive => proj1_sig (H p)) n)) H0). - apply (Un_cv_extens (fun n : nat => IQR (qn n))). + qn (increasing_modulus (fun p : positive => proj1_sig (H (Pos.succ p))) n)) H0). apply (CReal_cv_self qn (exist _ (fun n : nat => - qn (increasing_modulus (fun p : positive => proj1_sig (H p)) n)) H0) - (fun p : positive => Init.Nat.max (proj1_sig (H p)) (Pos.to_nat p))). - apply H1. intro n. reflexivity. + qn (increasing_modulus (fun p : positive => proj1_sig (H (Pos.succ p))) n)) H0) + (fun p : positive => Init.Nat.max (proj1_sig (H (Pos.succ p))) (Pos.to_nat p))). + apply H1. Qed. Lemma Rcauchy_complete : forall (xn : nat -> CReal), Un_cauchy_mod xn - -> { l : CReal & Un_cv_mod xn l }. + -> { l : CReal & Un_cv_mod xn l }. Proof. intros xn cau. destruct (R_has_all_rational_limits (fun n => let (l,_) := RQ_limit (xn n) n in l) @@ -396,21 +313,21 @@ Proof. apply Nat.le_max_l. apply H. destruct (RQ_limit (xn p0) p0) as [q maj]; unfold proj1_sig in H0,H1. split. - - apply (CRealLt_trans _ (IQR q - IQR (1 # 2 * p) - l)). - + unfold CReal_minus. rewrite (CReal_plus_comm (IQR q)). - apply (CReal_plus_lt_reg_l (IQR (1 # 2 * p))). - ring_simplify. unfold CReal_minus. rewrite <- opp_IQR. rewrite <- plus_IQR. + - apply (CReal_le_trans _ (inject_Q q - inject_Q (1 # 2 * p) - l)). + + unfold CReal_minus. rewrite (CReal_plus_comm (inject_Q q)). + apply (CReal_plus_le_reg_l (inject_Q (1 # 2 * p))). + ring_simplify. unfold CReal_minus. rewrite <- opp_inject_Q. rewrite <- inject_Q_plus. setoid_replace ((1 # 2 * p) + - (1 # p))%Q with (-(1#2*p))%Q. - rewrite opp_IQR. apply H0. + rewrite opp_inject_Q. apply H0. setoid_replace (1#p)%Q with (2 # 2*p)%Q. rewrite Qinv_minus_distr. reflexivity. reflexivity. + unfold CReal_minus. - do 2 rewrite <- (CReal_plus_comm (-l)). apply CReal_plus_lt_compat_l. - apply (CReal_plus_lt_reg_r (IQR (1 # 2 * p))). + do 2 rewrite <- (CReal_plus_comm (-l)). apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_r (inject_Q (1 # 2 * p))). ring_simplify. rewrite CReal_plus_comm. - apply (CRealLt_Le_trans _ (xn p0 + IQR (1 # Pos.of_nat p0))). - apply maj. apply CReal_plus_le_compat_l. - apply IQR_le. + apply (CReal_le_trans _ (xn p0 + inject_Q (1 # Pos.of_nat p0))). + apply CRealLt_asym, maj. apply CReal_plus_le_compat_l. + apply inject_Q_le. apply Z2Nat.inj_le. discriminate. discriminate. simpl. assert ((Pos.to_nat p~0 <= p0)%nat). { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). @@ -420,13 +337,13 @@ Proof. rewrite Nat2Pos.id. apply H2. intro abs. subst p0. inversion H2. pose proof (Pos2Nat.is_pos (p~0)). rewrite H4 in H3. inversion H3. - - apply (CRealLt_trans _ (IQR q - l)). + - apply (CReal_le_trans _ (inject_Q q - l)). + unfold CReal_minus. do 2 rewrite <- (CReal_plus_comm (-l)). - apply CReal_plus_lt_compat_l. apply maj. - + apply (CRealLt_trans _ (IQR (1 # 2 * p))). - apply H1. apply IQR_lt. + apply CReal_plus_le_compat_l. apply CRealLt_asym, maj. + + apply (CReal_le_trans _ (inject_Q (1 # 2 * p))). + apply H1. apply inject_Q_le. rewrite <- Qplus_0_r. setoid_replace (1#p)%Q with ((1#2*p)+(1#2*p))%Q. - apply Qplus_lt_r. reflexivity. + apply Qplus_le_r. discriminate. rewrite Qinv_plus_distr. reflexivity. Qed. diff --git a/theories/Reals/ConstructiveReals.v b/theories/Reals/ConstructiveReals.v index fc3d6afe15..25242f5ea9 100644 --- a/theories/Reals/ConstructiveReals.v +++ b/theories/Reals/ConstructiveReals.v @@ -9,10 +9,10 @@ (************************************************************************) (************************************************************************) -(* An interface for constructive and computable real numbers. - All of its instances are isomorphic, for example it contains - the Cauchy reals implemented in file ConstructivecauchyReals - and the sumbool-based Dedekind reals defined by +(** An interface for constructive and computable real numbers. + All of its instances are isomorphic (see file ConstructiveRealsMorphisms). + For example it contains the Cauchy reals implemented in file + ConstructivecauchyReals and the sumbool-based Dedekind reals defined by Structure R := { (* The cuts are represented as propositional functions, rather than subsets, @@ -41,7 +41,22 @@ Structure R := { see github.com/andrejbauer/dedekind-reals for the Prop-based version of those Dedekind reals (although Prop fails to make - them an instance of ConstructiveReals). *) + them an instance of ConstructiveReals). + + Any computation about constructive reals, can be worked + in the fastest instance for it; we then transport the results + to all other instances by the isomorphisms. This way of working + is different from the usual interfaces, where we would rather + prove things abstractly, by quantifying universally on the instance. + + The functions of ConstructiveReals do not have a direct impact + on performance, because algorithms will be extracted from instances, + and because fast ConstructiveReals morphisms should be coded + manually. However, since instances are forced to implement + those functions, it is probable that they will also use them + in their algorithms. So those functions hint at what we think + will yield fast and small extracted programs. *) + Require Import QArith. @@ -56,6 +71,9 @@ Definition orderEq (X : Set) (Xlt : X -> X -> Set) (x y : X) : Prop Definition orderAppart (X : Set) (Xlt : X -> X -> Set) (x y : X) : Set := Xlt x y + Xlt y x. +Definition orderLe (X : Set) (Xlt : X -> X -> Set) (x y : X) : Prop + := Xlt y x -> False. + Definition sig_forall_dec_T : Type := forall (P : nat -> Prop), (forall n, {P n} + {~P n}) -> {n | ~P n} + {forall n, P n}. @@ -65,9 +83,17 @@ Definition sig_not_dec_T : Type := forall P : Prop, { ~~P } + { ~P }. Record ConstructiveReals : Type := { CRcarrier : Set; + + (* Put this order relation in sort Set rather than Prop, + to allow the definition of fast ConstructiveReals morphisms. + For example, the Cauchy reals do store information in + the proofs of CRlt, which is used in algorithms in sort Set. *) CRlt : CRcarrier -> CRcarrier -> Set; CRltLinear : isLinearOrder CRcarrier CRlt; + (* The propositional truncation of CRlt. It facilitates proofs + when computations are not considered important, for example in + classical reals with extra logical axioms. *) CRltProp : CRcarrier -> CRcarrier -> Prop; (* This choice algorithm can be slow, keep it for the classical quotient of the reals, where computations are blocked by @@ -114,36 +140,696 @@ Record ConstructiveReals : Type := CRinv_0_lt_compat : forall (r : CRcarrier) (rnz : orderAppart _ CRlt r CRzero), CRlt CRzero r -> CRlt CRzero (CRinv r rnz); - CRarchimedean : forall x : CRcarrier, - { k : Z & CRlt x (gen_phiZ CRzero CRone CRplus CRmult CRopp k) }; + (* The initial field morphism (in characteristic zero). + The abstract definition by iteration of addition is + probably the slowest. Let each instance implement + a faster (and often simpler) version. *) + CR_of_Q : Q -> CRcarrier; + CR_of_Q_plus : forall q r : Q, orderEq _ CRlt (CR_of_Q (q+r)) + (CRplus (CR_of_Q q) (CR_of_Q r)); + CR_of_Q_mult : forall q r : Q, orderEq _ CRlt (CR_of_Q (q*r)) + (CRmult (CR_of_Q q) (CR_of_Q r)); + CR_of_Q_one : orderEq _ CRlt (CR_of_Q 1) CRone; + CR_of_Q_lt : forall q r : Q, + Qlt q r -> CRlt (CR_of_Q q) (CR_of_Q r); + lt_CR_of_Q : forall q r : Q, + CRlt (CR_of_Q q) (CR_of_Q r) -> Qlt q r; + + (* This function is very fast in both the Cauchy and Dedekind + instances, because this rational number q is almost what + the proof of CRlt x y contains. + This function is also the heart of the computation of + constructive real numbers : it approximates x to any + requested precision y. *) + CR_Q_dense : forall x y : CRcarrier, CRlt x y -> + { q : Q & prod (CRlt x (CR_of_Q q)) + (CRlt (CR_of_Q q) y) }; + CR_archimedean : forall x : CRcarrier, + { n : positive & CRlt x (CR_of_Q (Z.pos n # 1)) }; CRminus (x y : CRcarrier) : CRcarrier := CRplus x (CRopp y); + + (* Definitions of convergence and Cauchy-ness. The formulas + with orderLe or CRlt are logically equivalent, the choice of + orderLe in sort Prop is a question of performance. + It is very rare to turn back to the strict order to + define functions in sort Set, so we prefer to discard + those proofs during extraction. And even in those rare cases, + it is easy to divide epsilon by 2 for example. *) CR_cv (un : nat -> CRcarrier) (l : CRcarrier) : Set - := forall eps:CRcarrier, - CRlt CRzero eps - -> { p : nat & forall i:nat, le p i -> CRlt (CRopp eps) (CRminus (un i) l) - * CRlt (CRminus (un i) l) eps }; + := forall p:positive, + { n : nat | forall i:nat, le n i + -> orderLe _ CRlt (CR_of_Q (-1#p)) (CRminus (un i) l) + /\ orderLe _ CRlt (CRminus (un i) l) (CR_of_Q (1#p)) }; CR_cauchy (un : nat -> CRcarrier) : Set - := forall eps:CRcarrier, - CRlt CRzero eps - -> { p : nat & forall i j:nat, le p i -> le p j -> - CRlt (CRopp eps) (CRminus (un i) (un j)) - * CRlt (CRminus (un i) (un j)) eps }; + := forall p : positive, + { n : nat | forall i j:nat, le n i -> le n j + -> orderLe _ CRlt (CR_of_Q (-1#p)) (CRminus (un i) (un j)) + /\ orderLe _ CRlt (CRminus (un i) (un j)) (CR_of_Q (1#p)) }; + (* For the Cauchy reals, this algorithm consists in building + a Cauchy sequence of rationals un : nat -> Q that has + the same limit as xn. For each n:nat, un n is a 1/n + rational approximation of a point of xn that has converged + within 1/n. *) CR_complete : - forall xn : nat -> CRcarrier, CR_cauchy xn -> { l : CRcarrier & CR_cv xn l }; - - (* Those are redundant, they could be proved from the previous hypotheses *) - CRis_upper_bound (E:CRcarrier -> Prop) (m:CRcarrier) - := forall x:CRcarrier, E x -> CRlt m x -> False; - - CR_sig_lub : - forall (E:CRcarrier -> Prop), - sig_forall_dec_T - -> sig_not_dec_T - -> (exists x : CRcarrier, E x) - -> (exists x : CRcarrier, CRis_upper_bound E x) - -> { u : CRcarrier | CRis_upper_bound E u /\ - forall y:CRcarrier, CRis_upper_bound E y -> CRlt y u -> False }; + forall xn : (nat -> CRcarrier), + CR_cauchy xn -> { l : CRcarrier & CR_cv xn l }; }. + +Lemma CRlt_asym : forall (R : ConstructiveReals) (x y : CRcarrier R), + CRlt R x y -> CRlt R y x -> False. +Proof. + intros. destruct (CRltLinear R), p. + apply (f x y); assumption. +Qed. + +Lemma CRlt_proper + : forall R : ConstructiveReals, + CMorphisms.Proper + (CMorphisms.respectful (orderEq _ (CRlt R)) + (CMorphisms.respectful (orderEq _ (CRlt R)) CRelationClasses.iffT)) (CRlt R). +Proof. + intros R x y H x0 y0 H0. destruct H, H0. + destruct (CRltLinear R). split. + - intro. destruct (s x y x0). assumption. + contradiction. destruct (s y y0 x0). + assumption. assumption. contradiction. + - intro. destruct (s y x y0). assumption. + contradiction. destruct (s x x0 y0). + assumption. assumption. contradiction. +Qed. + +Lemma CRle_refl : forall (R : ConstructiveReals) (x : CRcarrier R), + CRlt R x x -> False. +Proof. + intros. destruct (CRltLinear R), p. + exact (f x x H H). +Qed. + +Lemma CRle_lt_trans : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), + (CRlt R r2 r1 -> False) -> CRlt R r2 r3 -> CRlt R r1 r3. +Proof. + intros. destruct (CRltLinear R). + destruct (s r2 r1 r3 H0). contradiction. apply c. +Qed. + +Lemma CRlt_le_trans : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), + CRlt R r1 r2 -> (CRlt R r3 r2 -> False) -> CRlt R r1 r3. +Proof. + intros. destruct (CRltLinear R). + destruct (s r1 r3 r2 H). apply c. contradiction. +Qed. + +Lemma CRle_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), + orderLe _ (CRlt R) x y -> orderLe _ (CRlt R) y z -> orderLe _ (CRlt R) x z. +Proof. + intros. intro abs. apply H0. + apply (CRlt_le_trans _ _ x); assumption. +Qed. + +Lemma CRlt_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), + CRlt R x y -> CRlt R y z -> CRlt R x z. +Proof. + intros. apply (CRlt_le_trans R _ y _ H). + apply CRlt_asym. exact H0. +Defined. + +Lemma CRlt_trans_flip : forall (R : ConstructiveReals) (x y z : CRcarrier R), + CRlt R y z -> CRlt R x y -> CRlt R x z. +Proof. + intros. apply (CRlt_le_trans R _ y). exact H0. + apply CRlt_asym. exact H. +Defined. + +Lemma CReq_refl : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) x x. +Proof. + split; apply CRle_refl. +Qed. + +Lemma CReq_sym : forall (R : ConstructiveReals) (x y : CRcarrier R), + orderEq _ (CRlt R) x y + -> orderEq _ (CRlt R) y x. +Proof. + intros. destruct H. split; intro abs; contradiction. +Qed. + +Lemma CReq_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), + orderEq _ (CRlt R) x y + -> orderEq _ (CRlt R) y z + -> orderEq _ (CRlt R) x z. +Proof. + intros. destruct H,H0. destruct (CRltLinear R), p. split. + - intro abs. destruct (s _ y _ abs); contradiction. + - intro abs. destruct (s _ y _ abs); contradiction. +Qed. + +Lemma CR_setoid : forall R : ConstructiveReals, + Setoid_Theory (CRcarrier R) (orderEq _ (CRlt R)). +Proof. + split. intro x. apply CReq_refl. + intros x y. apply CReq_sym. + intros x y z. apply CReq_trans. +Qed. + +Lemma CRplus_0_r : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) (CRplus R x (CRzero R)) x. +Proof. + intros. destruct (CRisRing R). + apply (CReq_trans R _ (CRplus R (CRzero R) x)). + apply Radd_comm. apply Radd_0_l. +Qed. + +Lemma CRmult_1_r : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) (CRmult R x (CRone R)) x. +Proof. + intros. destruct (CRisRing R). + apply (CReq_trans R _ (CRmult R (CRone R) x)). + apply Rmul_comm. apply Rmul_1_l. +Qed. + +Lemma CRplus_opp_l : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) (CRplus R (CRopp R x) x) (CRzero R). +Proof. + intros. destruct (CRisRing R). + apply (CReq_trans R _ (CRplus R x (CRopp R x))). + apply Radd_comm. apply Ropp_def. +Qed. + +Lemma CRplus_lt_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R r1 r2 -> CRlt R (CRplus R r1 r) (CRplus R r2 r). +Proof. + intros. destruct (CRisRing R). + apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) + (CRplus R r2 r) (CRplus R r2 r)). + apply CReq_refl. + apply (CRlt_proper R _ _ (CReq_refl _ _) _ (CRplus R r r2)). + apply Radd_comm. apply CRplus_lt_compat_l. exact H. +Qed. + +Lemma CRplus_lt_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRplus R r1 r) (CRplus R r2 r) -> CRlt R r1 r2. +Proof. + intros. destruct (CRisRing R). + apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) + (CRplus R r2 r) (CRplus R r2 r)) in H. + 2: apply CReq_refl. + apply (CRlt_proper R _ _ (CReq_refl _ _) _ (CRplus R r r2)) in H. + apply CRplus_lt_reg_l in H. exact H. + apply Radd_comm. +Qed. + +Lemma CRplus_le_compat_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderLe _ (CRlt R) r1 r2 + -> orderLe _ (CRlt R) (CRplus R r r1) (CRplus R r r2). +Proof. + intros. intros abs. apply CRplus_lt_reg_l in abs. apply H. exact abs. +Qed. + +Lemma CRplus_le_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderLe _ (CRlt R) r1 r2 + -> orderLe _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r). +Proof. + intros. intros abs. apply CRplus_lt_reg_r in abs. apply H. exact abs. +Qed. + +Lemma CRplus_le_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderLe _ (CRlt R) (CRplus R r r1) (CRplus R r r2) + -> orderLe _ (CRlt R) r1 r2. +Proof. + intros. intro abs. apply H. clear H. + apply CRplus_lt_compat_l. exact abs. +Qed. + +Lemma CRplus_le_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderLe _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r) + -> orderLe _ (CRlt R) r1 r2. +Proof. + intros. intro abs. apply H. clear H. + apply CRplus_lt_compat_r. exact abs. +Qed. + +Lemma CRplus_lt_le_compat : + forall (R : ConstructiveReals) (r1 r2 r3 r4 : CRcarrier R), + CRlt R r1 r2 + -> (CRlt R r4 r3 -> False) + -> CRlt R (CRplus R r1 r3) (CRplus R r2 r4). +Proof. + intros. apply (CRlt_le_trans R _ (CRplus R r2 r3)). + apply CRplus_lt_compat_r. exact H. intro abs. + apply CRplus_lt_reg_l in abs. contradiction. +Qed. + +Lemma CRplus_eq_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderEq _ (CRlt R) (CRplus R r r1) (CRplus R r r2) + -> orderEq _ (CRlt R) r1 r2. +Proof. + intros. + destruct (CRisRingExt R). clear Rmul_ext Ropp_ext. + pose proof (Radd_ext + (CRopp R r) (CRopp R r) (CReq_refl _ _) + _ _ H). + destruct (CRisRing R). + apply (CReq_trans _ r1) in H0. + apply (CReq_trans R _ _ _ H0). + apply (CReq_trans R _ (CRplus R (CRplus R (CRopp R r) r) r2)). + apply Radd_assoc. + apply (CReq_trans R _ (CRplus R (CRzero R) r2)). + apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. + apply Radd_0_l. apply CReq_sym. + apply (CReq_trans R _ (CRplus R (CRplus R (CRopp R r) r) r1)). + apply Radd_assoc. + apply (CReq_trans R _ (CRplus R (CRzero R) r1)). + apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. + apply Radd_0_l. +Qed. + +Lemma CRplus_eq_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderEq _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r) + -> orderEq _ (CRlt R) r1 r2. +Proof. + intros. apply (CRplus_eq_reg_l R r). + apply (CReq_trans R _ (CRplus R r1 r)). apply (Radd_comm (CRisRing R)). + apply (CReq_trans R _ (CRplus R r2 r)). + exact H. apply (Radd_comm (CRisRing R)). +Qed. + +Lemma CRopp_involutive : forall (R : ConstructiveReals) (r : CRcarrier R), + orderEq _ (CRlt R) (CRopp R (CRopp R r)) r. +Proof. + intros. apply (CRplus_eq_reg_l R (CRopp R r)). + apply (CReq_trans R _ (CRzero R)). apply CRisRing. + apply CReq_sym, (CReq_trans R _ (CRplus R r (CRopp R r))). + apply CRisRing. apply CRisRing. +Qed. + +Lemma CRopp_gt_lt_contravar + : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), + CRlt R r2 r1 -> CRlt R (CRopp R r1) (CRopp R r2). +Proof. + intros. apply (CRplus_lt_reg_l R r1). + destruct (CRisRing R). + apply (CRle_lt_trans R _ (CRzero R)). apply Ropp_def. + apply (CRplus_lt_compat_l R (CRopp R r2)) in H. + apply (CRle_lt_trans R _ (CRplus R (CRopp R r2) r2)). + apply (CRle_trans R _ (CRplus R r2 (CRopp R r2))). + destruct (Ropp_def r2). exact H0. + destruct (Radd_comm r2 (CRopp R r2)). exact H1. + apply (CRlt_le_trans R _ _ _ H). + destruct (Radd_comm r1 (CRopp R r2)). exact H0. +Qed. + +Lemma CRopp_lt_cancel : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), + CRlt R (CRopp R r2) (CRopp R r1) -> CRlt R r1 r2. +Proof. + intros. apply (CRplus_lt_compat_r R r1) in H. + destruct (CRplus_opp_l R r1) as [_ H1]. + apply (CRlt_le_trans R _ _ _ H) in H1. clear H. + apply (CRplus_lt_compat_l R r2) in H1. + destruct (CRplus_0_r R r2) as [_ H0]. + apply (CRlt_le_trans R _ _ _ H1) in H0. clear H1. + destruct (Radd_assoc (CRisRing R) r2 (CRopp R r2) r1) as [H _]. + apply (CRle_lt_trans R _ _ _ H) in H0. clear H. + apply (CRle_lt_trans R _ (CRplus R (CRzero R) r1)). + apply (Radd_0_l (CRisRing R)). + apply (CRle_lt_trans R _ (CRplus R (CRplus R r2 (CRopp R r2)) r1)). + 2: exact H0. apply CRplus_le_compat_r. + destruct (Ropp_def (CRisRing R) r2). exact H. +Qed. + +Lemma CRopp_plus_distr : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), + orderEq _ (CRlt R) (CRopp R (CRplus R r1 r2)) (CRplus R (CRopp R r1) (CRopp R r2)). +Proof. + intros. destruct (CRisRing R), (CRisRingExt R). + apply (CRplus_eq_reg_l R (CRplus R r1 r2)). + apply (CReq_trans R _ (CRzero R)). apply Ropp_def. + apply (CReq_trans R _ (CRplus R (CRplus R r2 r1) (CRplus R (CRopp R r1) (CRopp R r2)))). + apply (CReq_trans R _ (CRplus R r2 (CRplus R r1 (CRplus R (CRopp R r1) (CRopp R r2))))). + apply (CReq_trans R _ (CRplus R r2 (CRopp R r2))). + apply CReq_sym. apply Ropp_def. apply Radd_ext. + apply CReq_refl. + apply (CReq_trans R _ (CRplus R (CRzero R) (CRopp R r2))). + apply CReq_sym, Radd_0_l. + apply (CReq_trans R _ (CRplus R (CRplus R r1 (CRopp R r1)) (CRopp R r2))). + apply Radd_ext. 2: apply CReq_refl. apply CReq_sym, Ropp_def. + apply CReq_sym, Radd_assoc. apply Radd_assoc. + apply Radd_ext. 2: apply CReq_refl. apply Radd_comm. +Qed. + +Lemma CRmult_plus_distr_l : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), + orderEq _ (CRlt R) (CRmult R r1 (CRplus R r2 r3)) + (CRplus R (CRmult R r1 r2) (CRmult R r1 r3)). +Proof. + intros. destruct (CRisRing R). + apply (CReq_trans R _ (CRmult R (CRplus R r2 r3) r1)). + apply Rmul_comm. + apply (CReq_trans R _ (CRplus R (CRmult R r2 r1) (CRmult R r3 r1))). + apply Rdistr_l. + apply (CReq_trans R _ (CRplus R (CRmult R r1 r2) (CRmult R r3 r1))). + destruct (CRisRingExt R). apply Radd_ext. + apply Rmul_comm. apply CReq_refl. + destruct (CRisRingExt R). apply Radd_ext. + apply CReq_refl. apply Rmul_comm. +Qed. + +(* x == x+x -> x == 0 *) +Lemma CRzero_double : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) x (CRplus R x x) + -> orderEq _ (CRlt R) x (CRzero R). +Proof. + intros. + apply (CRplus_eq_reg_l R x), CReq_sym, (CReq_trans R _ x). + apply CRplus_0_r. exact H. +Qed. + +Lemma CRmult_0_r : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) (CRmult R x (CRzero R)) (CRzero R). +Proof. + intros. apply CRzero_double. + apply (CReq_trans R _ (CRmult R x (CRplus R (CRzero R) (CRzero R)))). + destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. + apply CReq_sym, CRplus_0_r. + destruct (CRisRing R). apply CRmult_plus_distr_l. +Qed. + +Lemma CRopp_mult_distr_r : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), + orderEq _ (CRlt R) (CRopp R (CRmult R r1 r2)) + (CRmult R r1 (CRopp R r2)). +Proof. + intros. apply (CRplus_eq_reg_l R (CRmult R r1 r2)). + destruct (CRisRing R). + apply (CReq_trans R _ (CRzero R)). apply Ropp_def. + apply (CReq_trans R _ (CRmult R r1 (CRplus R r2 (CRopp R r2)))). + 2: apply CRmult_plus_distr_l. + apply (CReq_trans R _ (CRmult R r1 (CRzero R))). + apply CReq_sym, CRmult_0_r. + destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. + apply CReq_sym, Ropp_def. +Qed. + +Lemma CRopp_mult_distr_l : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), + orderEq _ (CRlt R) (CRopp R (CRmult R r1 r2)) + (CRmult R (CRopp R r1) r2). +Proof. + intros. apply (CReq_trans R _ (CRmult R r2 (CRopp R r1))). + apply (CReq_trans R _ (CRopp R (CRmult R r2 r1))). + apply (Ropp_ext (CRisRingExt R)). + apply CReq_sym, (Rmul_comm (CRisRing R)). + apply CRopp_mult_distr_r. + apply CReq_sym, (Rmul_comm (CRisRing R)). +Qed. + +Lemma CRmult_lt_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRzero R) r + -> CRlt R r1 r2 + -> CRlt R (CRmult R r1 r) (CRmult R r2 r). +Proof. + intros. apply (CRplus_lt_reg_r R (CRopp R (CRmult R r1 r))). + apply (CRle_lt_trans R _ (CRzero R)). + apply (Ropp_def (CRisRing R)). + apply (CRlt_le_trans R _ (CRplus R (CRmult R r2 r) (CRmult R (CRopp R r1) r))). + apply (CRlt_le_trans R _ (CRmult R (CRplus R r2 (CRopp R r1)) r)). + apply CRmult_lt_0_compat. 2: exact H. + apply (CRplus_lt_reg_r R r1). + apply (CRle_lt_trans R _ r1). apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans R _ r2 _ H0). + apply (CRle_trans R _ (CRplus R r2 (CRplus R (CRopp R r1) r1))). + apply (CRle_trans R _ (CRplus R r2 (CRzero R))). + destruct (CRplus_0_r R r2). exact H1. + apply CRplus_le_compat_l. destruct (CRplus_opp_l R r1). exact H1. + destruct (Radd_assoc (CRisRing R) r2 (CRopp R r1) r1). exact H2. + destruct (CRisRing R). + destruct (Rdistr_l r2 (CRopp R r1) r). exact H2. + apply CRplus_le_compat_l. destruct (CRopp_mult_distr_l R r1 r). + exact H1. +Qed. + +Lemma CRinv_r : forall (R : ConstructiveReals) (r:CRcarrier R) + (rnz : orderAppart _ (CRlt R) r (CRzero R)), + orderEq _ (CRlt R) (CRmult R r (CRinv R r rnz)) (CRone R). +Proof. + intros. apply (CReq_trans R _ (CRmult R (CRinv R r rnz) r)). + apply (CRisRing R). apply CRinv_l. +Qed. + +Lemma CRmult_lt_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRzero R) r + -> CRlt R (CRmult R r1 r) (CRmult R r2 r) + -> CRlt R r1 r2. +Proof. + intros. apply (CRmult_lt_compat_r R (CRinv R r (inr H))) in H0. + 2: apply CRinv_0_lt_compat, H. + apply (CRle_lt_trans R _ (CRmult R (CRmult R r1 r) (CRinv R r (inr H)))). + - clear H0. apply (CRle_trans R _ (CRmult R r1 (CRone R))). + destruct (CRmult_1_r R r1). exact H0. + apply (CRle_trans R _ (CRmult R r1 (CRmult R r (CRinv R r (inr H))))). + destruct (Rmul_ext (CRisRingExt R) r1 r1 (CReq_refl R r1) + (CRmult R r (CRinv R r (inr H))) (CRone R)). + apply CRinv_r. exact H0. + destruct (Rmul_assoc (CRisRing R) r1 r (CRinv R r (inr H))). exact H1. + - apply (CRlt_le_trans R _ (CRmult R (CRmult R r2 r) (CRinv R r (inr H)))). + exact H0. clear H0. + apply (CRle_trans R _ (CRmult R r2 (CRone R))). + 2: destruct (CRmult_1_r R r2); exact H1. + apply (CRle_trans R _ (CRmult R r2 (CRmult R r (CRinv R r (inr H))))). + destruct (Rmul_assoc (CRisRing R) r2 r (CRinv R r (inr H))). exact H0. + destruct (Rmul_ext (CRisRingExt R) r2 r2 (CReq_refl R r2) + (CRmult R r (CRinv R r (inr H))) (CRone R)). + apply CRinv_r. exact H1. +Qed. + +Lemma CRmult_lt_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRzero R) r + -> CRlt R (CRmult R r r1) (CRmult R r r2) + -> CRlt R r1 r2. +Proof. + intros. + destruct (Rmul_comm (CRisRing R) r r1) as [H1 _]. + apply (CRle_lt_trans R _ _ _ H1) in H0. clear H1. + destruct (Rmul_comm (CRisRing R) r r2) as [_ H1]. + apply (CRlt_le_trans R _ _ _ H0) in H1. clear H0. + apply CRmult_lt_reg_r in H1. + exact H1. exact H. +Qed. + +Lemma CRmult_le_compat_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRzero R) r + -> orderLe _ (CRlt R) r1 r2 + -> orderLe _ (CRlt R) (CRmult R r r1) (CRmult R r r2). +Proof. + intros. intro abs. apply CRmult_lt_reg_l in abs. + contradiction. exact H. +Qed. + +Lemma CRmult_le_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRzero R) r + -> orderLe _ (CRlt R) r1 r2 + -> orderLe _ (CRlt R) (CRmult R r1 r) (CRmult R r2 r). +Proof. + intros. intro abs. apply CRmult_lt_reg_r in abs. + contradiction. exact H. +Qed. + +Lemma CRmult_eq_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderAppart _ (CRlt R) (CRzero R) r + -> orderEq _ (CRlt R) (CRmult R r1 r) (CRmult R r2 r) + -> orderEq _ (CRlt R) r1 r2. +Proof. + intros. destruct H0,H. + - split. + + intro abs. apply H0. apply CRmult_lt_compat_r. + exact c. exact abs. + + intro abs. apply H1. apply CRmult_lt_compat_r. + exact c. exact abs. + - split. + + intro abs. apply H1. apply CRopp_lt_cancel. + apply (CRle_lt_trans R _ (CRmult R r1 (CRopp R r))). + apply CRopp_mult_distr_r. + apply (CRlt_le_trans R _ (CRmult R r2 (CRopp R r))). + 2: apply CRopp_mult_distr_r. + apply CRmult_lt_compat_r. 2: exact abs. + apply (CRplus_lt_reg_r R r). apply (CRle_lt_trans R _ r). + apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans R _ (CRzero R) _ c). + apply CRplus_opp_l. + + intro abs. apply H0. apply CRopp_lt_cancel. + apply (CRle_lt_trans R _ (CRmult R r2 (CRopp R r))). + apply CRopp_mult_distr_r. + apply (CRlt_le_trans R _ (CRmult R r1 (CRopp R r))). + 2: apply CRopp_mult_distr_r. + apply CRmult_lt_compat_r. 2: exact abs. + apply (CRplus_lt_reg_r R r). apply (CRle_lt_trans R _ r). + apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans R _ (CRzero R) _ c). + apply CRplus_opp_l. +Qed. + +Lemma CR_of_Q_proper : forall (R : ConstructiveReals) (q r : Q), + q == r -> orderEq _ (CRlt R) (CR_of_Q R q) (CR_of_Q R r). +Proof. + split. + - intro abs. apply lt_CR_of_Q in abs. rewrite H in abs. + exact (Qlt_not_le r r abs (Qle_refl r)). + - intro abs. apply lt_CR_of_Q in abs. rewrite H in abs. + exact (Qlt_not_le r r abs (Qle_refl r)). +Qed. + +Lemma CR_of_Q_zero : forall (R : ConstructiveReals), + orderEq _ (CRlt R) (CR_of_Q R 0) (CRzero R). +Proof. + intros. apply CRzero_double. + apply (CReq_trans R _ (CR_of_Q R (0+0))). apply CR_of_Q_proper. + reflexivity. apply CR_of_Q_plus. +Qed. + +Lemma CR_of_Q_opp : forall (R : ConstructiveReals) (q : Q), + orderEq _ (CRlt R) (CR_of_Q R (-q)) (CRopp R (CR_of_Q R q)). +Proof. + intros. apply (CRplus_eq_reg_l R (CR_of_Q R q)). + apply (CReq_trans R _ (CRzero R)). + apply (CReq_trans R _ (CR_of_Q R (q-q))). + apply CReq_sym, CR_of_Q_plus. + apply (CReq_trans R _ (CR_of_Q R 0)). + apply CR_of_Q_proper. ring. apply CR_of_Q_zero. + apply CReq_sym. apply (CRisRing R). +Qed. + +Lemma CR_of_Q_le : forall (R : ConstructiveReals) (r q : Q), + Qle r q + -> orderLe _ (CRlt R) (CR_of_Q R r) (CR_of_Q R q). +Proof. + intros. intro abs. apply lt_CR_of_Q in abs. + exact (Qlt_not_le _ _ abs H). +Qed. + +Lemma CR_of_Q_pos : forall (R : ConstructiveReals) (q:Q), + Qlt 0 q -> CRlt R (CRzero R) (CR_of_Q R q). +Proof. + intros. apply (CRle_lt_trans R _ (CR_of_Q R 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. exact H. +Qed. + +Lemma CR_cv_above_rat + : forall (R : ConstructiveReals) (xn : nat -> Q) (x : CRcarrier R) (q : Q), + CR_cv R (fun n : nat => CR_of_Q R (xn n)) x + -> CRlt R (CR_of_Q R q) x + -> { n : nat | forall p:nat, le n p -> Qlt q (xn p) }. +Proof. + intros. + destruct (CR_Q_dense R _ _ H0) as [r [H1 H2]]. + apply lt_CR_of_Q in H1. clear H0. + destruct (Qarchimedean (/(r-q))) as [p pmaj]. + destruct (H p) as [n nmaj]. + exists n. intros k lenk. specialize (nmaj k lenk) as [H3 _]. + apply (lt_CR_of_Q R), (CRlt_le_trans R _ (CRplus R x (CR_of_Q R (-1#p)))). + apply (CRlt_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (-1#p)))). + 2: apply CRplus_lt_compat_r, H2. + apply (CRlt_le_trans R _ (CR_of_Q R (r+(-1#p)))). + - apply CR_of_Q_lt. + apply (Qplus_lt_l _ _ (-(-1#p)-q)). field_simplify. + setoid_replace (-1*(-1#p)) with (1#p). 2: reflexivity. + apply (Qmult_lt_l _ _ (r-q)) in pmaj. + rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. + 2: reflexivity. setoid_replace (-1*q + r) with (r-q). exact pmaj. + ring. intro abs. apply Qlt_minus_iff in H1. + rewrite abs in H1. inversion H1. + apply Qlt_minus_iff in H1. exact H1. + - apply CR_of_Q_plus. + - apply (CRplus_le_reg_r R (CRopp R x)). + apply (CRle_trans R _ (CR_of_Q R (-1#p))). 2: exact H3. clear H3. + apply (CRle_trans R _ (CRplus R (CRopp R x) (CRplus R x (CR_of_Q R (-1 # p))))). + exact (proj1 (Radd_comm (CRisRing R) _ _)). + apply (CRle_trans R _ (CRplus R (CRplus R (CRopp R x) x) (CR_of_Q R (-1 # p)))). + exact (proj2 (Radd_assoc (CRisRing R) _ _ _)). + apply (CRle_trans R _ (CRplus R (CRzero R) (CR_of_Q R (-1 # p)))). + apply CRplus_le_compat_r. exact (proj2 (CRplus_opp_l R _)). + exact (proj2 (Radd_0_l (CRisRing R) _)). +Qed. + +Lemma CR_cv_below_rat + : forall (R : ConstructiveReals) (xn : nat -> Q) (x : CRcarrier R) (q : Q), + CR_cv R (fun n : nat => CR_of_Q R (xn n)) x + -> CRlt R x (CR_of_Q R q) + -> { n : nat | forall p:nat, le n p -> Qlt (xn p) q }. +Proof. + intros. + destruct (CR_Q_dense R _ _ H0) as [r [H1 H2]]. + apply lt_CR_of_Q in H2. clear H0. + destruct (Qarchimedean (/(q-r))) as [p pmaj]. + destruct (H p) as [n nmaj]. + exists n. intros k lenk. specialize (nmaj k lenk) as [_ H4]. + apply (lt_CR_of_Q R), (CRle_lt_trans R _ (CRplus R x (CR_of_Q R (1#p)))). + - apply (CRplus_le_reg_r R (CRopp R x)). + apply (CRle_trans R _ (CR_of_Q R (1#p))). exact H4. clear H4. + apply (CRle_trans R _ (CRplus R (CRopp R x) (CRplus R x (CR_of_Q R (1 # p))))). + 2: exact (proj1 (Radd_comm (CRisRing R) _ _)). + apply (CRle_trans R _ (CRplus R (CRplus R (CRopp R x) x) (CR_of_Q R (1 # p)))). + 2: exact (proj1 (Radd_assoc (CRisRing R) _ _ _)). + apply (CRle_trans R _ (CRplus R (CRzero R) (CR_of_Q R (1 # p)))). + exact (proj1 (Radd_0_l (CRisRing R) _)). + apply CRplus_le_compat_r. exact (proj1 (CRplus_opp_l R _)). + - apply (CRlt_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (1 # p)))). + apply CRplus_lt_compat_r. exact H1. + apply (CRle_lt_trans R _ (CR_of_Q R (r + (1#p)))). + apply CR_of_Q_plus. apply CR_of_Q_lt. + apply (Qmult_lt_l _ _ (q-r)) in pmaj. + rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. + apply (Qplus_lt_l _ _ (-r)). field_simplify. + setoid_replace (-1*r + q) with (q-r). exact pmaj. + ring. reflexivity. intro abs. apply Qlt_minus_iff in H2. + rewrite abs in H2. inversion H2. + apply Qlt_minus_iff in H2. exact H2. +Qed. + +Lemma CR_cv_const : forall (R : ConstructiveReals) (x y : CRcarrier R), + CR_cv R (fun _ => x) y -> orderEq _ (CRlt R) x y. +Proof. + intros. destruct (CRisRing R). split. + - intro abs. + destruct (CR_Q_dense R x y abs) as [q [H0 H1]]. + destruct (CR_Q_dense R _ _ H1) as [r [H2 H3]]. + apply lt_CR_of_Q in H2. + destruct (Qarchimedean (/(r-q))) as [p pmaj]. + destruct (H p) as [n nmaj]. specialize (nmaj n (le_refl n)) as [nmaj _]. + apply nmaj. clear nmaj. + apply (CRlt_trans R _ (CR_of_Q R (q-r))). + apply (CRlt_le_trans R _ (CRplus R (CR_of_Q R q) (CRopp R (CR_of_Q R r)))). + + apply CRplus_lt_le_compat. exact H0. + intro H4. apply CRopp_lt_cancel in H4. exact (CRlt_asym R _ _ H4 H3). + + apply (CRle_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R (-r)))). + apply CRplus_le_compat_l. exact (proj1 (CR_of_Q_opp R r)). + exact (proj1 (CR_of_Q_plus R _ _)). + + apply CR_of_Q_lt. + apply (Qplus_lt_l _ _ (-(-1#p)+r-q)). field_simplify. + setoid_replace (-1*(-1#p)) with (1#p). 2: reflexivity. + apply (Qmult_lt_l _ _ (r-q)) in pmaj. + rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. + 2: reflexivity. setoid_replace (-1*q + r) with (r-q). exact pmaj. + ring. intro H4. apply Qlt_minus_iff in H2. + rewrite H4 in H2. inversion H2. + apply Qlt_minus_iff in H2. exact H2. + - intro abs. + destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. + destruct (CR_Q_dense R _ _ H0) as [r [H2 H3]]. + apply lt_CR_of_Q in H3. + destruct (Qarchimedean (/(q-r))) as [p pmaj]. + destruct (H p) as [n nmaj]. specialize (nmaj n (le_refl n)) as [_ nmaj]. + apply nmaj. clear nmaj. + apply (CRlt_trans R _ (CR_of_Q R (q-r))). + + apply CR_of_Q_lt. + apply (Qmult_lt_l _ _ (q-r)) in pmaj. + rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. + exact pmaj. reflexivity. + intro H4. apply Qlt_minus_iff in H3. + rewrite H4 in H3. inversion H3. + apply Qlt_minus_iff in H3. exact H3. + + apply (CRle_lt_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R (-r)))). + apply CR_of_Q_plus. + apply (CRle_lt_trans R _ (CRplus R (CR_of_Q R q) (CRopp R (CR_of_Q R r)))). + apply CRplus_le_compat_l. exact (proj2 (CR_of_Q_opp R r)). + apply CRplus_lt_le_compat. exact H1. + intro H4. apply CRopp_lt_cancel in H4. + exact (CRlt_asym R _ _ H4 H2). +Qed. diff --git a/theories/Reals/ConstructiveRealsLUB.v b/theories/Reals/ConstructiveRealsLUB.v index f5c447f7db..3a26b8cefb 100644 --- a/theories/Reals/ConstructiveRealsLUB.v +++ b/theories/Reals/ConstructiveRealsLUB.v @@ -15,7 +15,9 @@ Require Import QArith_base. Require Import Qabs. -Require Import ConstructiveCauchyReals. +Require Import ConstructiveReals. +Require Import ConstructiveCauchyRealsMult. +Require Import ConstructiveRealsMorphisms. Require Import ConstructiveRcomplete. Require Import Logic.ConstructiveEpsilon. @@ -54,14 +56,15 @@ Lemma is_upper_bound_epsilon : sig_forall_dec_T -> sig_not_dec_T -> (exists x:CReal, is_upper_bound E x) - -> { n:nat | is_upper_bound E (INR n) }. + -> { n:nat | is_upper_bound E (inject_Q (Z.of_nat n # 1)) }. Proof. intros E lpo sig_not_dec Ebound. apply constructive_indefinite_ground_description_nat. - intro n. apply is_upper_bound_dec. exact lpo. exact sig_not_dec. - - destruct Ebound as [x H]. destruct (Rup_nat x). exists x0. + - destruct Ebound as [x H]. destruct (Rup_pos x). exists (Pos.to_nat x0). intros y ey. specialize (H y ey). - apply CRealLt_asym. apply (CRealLe_Lt_trans _ x); assumption. + apply CRealLt_asym. apply (CReal_le_lt_trans _ x). + exact H. rewrite positive_nat_Z. exact c. Qed. Lemma is_upper_bound_not_epsilon : @@ -69,15 +72,16 @@ Lemma is_upper_bound_not_epsilon : sig_forall_dec_T -> sig_not_dec_T -> (exists x : CReal, E x) - -> { m:nat | ~is_upper_bound E (-INR m) }. + -> { m:nat | ~is_upper_bound E (-inject_Q (Z.of_nat m # 1)) }. Proof. intros E lpo sig_not_dec H. apply constructive_indefinite_ground_description_nat. - - intro n. destruct (is_upper_bound_dec E (-INR n) lpo sig_not_dec). + - intro n. destruct (is_upper_bound_dec E (-inject_Q (Z.of_nat n # 1)) lpo sig_not_dec). right. intro abs. contradiction. left. exact n0. - - destruct H as [x H]. destruct (Rup_nat (-x)) as [n H0]. - exists n. intro abs. specialize (abs x H). - apply abs. apply (CReal_plus_lt_reg_l (INR n-x)). + - destruct H as [x H]. destruct (Rup_pos (-x)) as [n H0]. + exists (Pos.to_nat n). intro abs. specialize (abs x H). + apply abs. rewrite positive_nat_Z. + apply (CReal_plus_lt_reg_l (inject_Q (Z.pos n # 1)-x)). ring_simplify. exact H0. Qed. @@ -140,8 +144,8 @@ Proof. Qed. Lemma glb_dec_Q : forall upcut : DedekindDecCut, - { x : CReal | forall r:Q, (x < IQR r -> DDupcut upcut r) - /\ (IQR r < x -> ~DDupcut upcut r) }. + { x : CReal | forall r:Q, (x < inject_Q r -> DDupcut upcut r) + /\ (inject_Q r < x -> ~DDupcut upcut r) }. Proof. intros. assert (forall a b : Q, Qle a b -> Qle (-b) (-a)). @@ -175,7 +179,7 @@ Proof. pose (exist (fun qn => QSeqEquiv qn qn Pos.to_nat) _ H0) as l. exists l. split. - intros. (* find an upper point between the limit and r *) - rewrite FinjectQ_CReal in H1. destruct H1 as [p pmaj]. + destruct H1 as [p pmaj]. unfold l,proj1_sig in pmaj. destruct (DDcut_limit upcut (1 # Pos.of_nat (Pos.to_nat p)) eq_refl) as [q qmaj] ; simpl in pmaj. @@ -184,8 +188,7 @@ Proof. apply (Qle_trans _ ((2#p) + q)). apply (Qplus_le_l _ _ (-q)). ring_simplify. discriminate. apply Qlt_le_weak. exact pmaj. - - intros H1 abs. - rewrite FinjectQ_CReal in H1. destruct H1 as [p pmaj]. + - intros [p pmaj] abs. unfold l,proj1_sig in pmaj. destruct (DDcut_limit upcut (1 # Pos.of_nat (Pos.to_nat p)) eq_refl) as [q qmaj] ; simpl in pmaj. @@ -205,26 +208,24 @@ Lemma is_upper_bound_glb : -> sig_forall_dec_T -> (exists x : CReal, E x) -> (exists x : CReal, is_upper_bound E x) - -> { x : CReal | forall r:Q, (x < IQR r -> is_upper_bound E (IQR r)) - /\ (IQR r < x -> ~is_upper_bound E (IQR r)) }. + -> { x : CReal | forall r:Q, (x < inject_Q r -> is_upper_bound E (inject_Q r)) + /\ (inject_Q r < x -> ~is_upper_bound E (inject_Q r)) }. Proof. intros E sig_not_dec lpo Einhab Ebound. destruct (is_upper_bound_epsilon E lpo sig_not_dec Ebound) as [a luba]. destruct (is_upper_bound_not_epsilon E lpo sig_not_dec Einhab) as [b glbb]. - pose (fun q => is_upper_bound E (IQR q)) as upcut. + pose (fun q => is_upper_bound E (inject_Q q)) as upcut. assert (forall q:Q, { upcut q } + { ~upcut q } ). { intro q. apply is_upper_bound_dec. exact lpo. exact sig_not_dec. } assert (forall q r : Q, (q <= r)%Q -> upcut q -> upcut r). { intros. intros x Ex. specialize (H1 x Ex). intro abs. - apply H1. apply (CRealLe_Lt_trans _ (IQR r)). 2: exact abs. - apply IQR_le. exact H0. } + apply H1. apply (CReal_le_lt_trans _ (inject_Q r)). 2: exact abs. + apply inject_Q_le. exact H0. } assert (upcut (Z.of_nat a # 1)%Q). - { intros x Ex. unfold IQR. rewrite CReal_inv_1, CReal_mult_1_r. - specialize (luba x Ex). rewrite <- INR_IZR_INZ. exact luba. } + { intros x Ex. exact (luba x Ex). } assert (~upcut (- Z.of_nat b # 1)%Q). { intros abs. apply glbb. intros x Ex. - specialize (abs x Ex). unfold IQR in abs. - rewrite CReal_inv_1, CReal_mult_1_r, opp_IZR, <- INR_IZR_INZ in abs. + specialize (abs x Ex). rewrite <- opp_inject_Q. exact abs. } assert (forall q r : Q, (q == r)%Q -> upcut q -> upcut r). { intros. intros x Ex. specialize (H4 x Ex). rewrite <- H3. exact H4. } @@ -257,7 +258,7 @@ Proof. intro abs. destruct (FQ_dense b x abs) as [q [qmaj H0]]. specialize (a q) as [_ a]. apply a. exact H0. intros y Ey. specialize (H y Ey). intro abs2. - apply H. exact (CRealLt_trans _ (IQR q) _ qmaj abs2). + apply H. exact (CReal_lt_trans _ (inject_Q q) _ qmaj abs2). Qed. Lemma sig_lub : @@ -274,3 +275,44 @@ Proof. E sig_not_dec sig_forall_dec Einhab Ebound); simpl in H. exists x. exact H. Qed. + +Definition CRis_upper_bound (R : ConstructiveReals) (E:CRcarrier R -> Prop) (m:CRcarrier R) + := forall x:CRcarrier R, E x -> CRlt R m x -> False. + +Lemma CR_sig_lub : + forall (R : ConstructiveReals) (E:CRcarrier R -> Prop), + (forall x y : CRcarrier R, orderEq _ (CRlt R) x y -> (E x <-> E y)) + -> sig_forall_dec_T + -> sig_not_dec_T + -> (exists x : CRcarrier R, E x) + -> (exists x : CRcarrier R, CRis_upper_bound R E x) + -> { u : CRcarrier R | CRis_upper_bound R E u /\ + forall y:CRcarrier R, CRis_upper_bound R E y -> CRlt R y u -> False }. +Proof. + intros. destruct (sig_lub (fun x:CReal => E (CauchyMorph R x)) X X0) as [u ulub]. + - destruct H0. exists (CauchyMorph_inv R x). + specialize (H (CauchyMorph R (CauchyMorph_inv R x)) x + (CauchyMorph_surject R x)) as [_ H]. + exact (H H0). + - destruct H1. exists (CauchyMorph_inv R x). + intros y Ey. specialize (H1 (CauchyMorph R y) Ey). + intros abs. apply H1. + apply (CauchyMorph_increasing R) in abs. + apply (CRle_lt_trans R _ (CauchyMorph R (CauchyMorph_inv R x))). + 2: exact abs. apply (CauchyMorph_surject R x). + - exists (CauchyMorph R u). destruct ulub. split. + + intros y Ey abs. specialize (H2 (CauchyMorph_inv R y)). + simpl in H2. + specialize (H (CauchyMorph R (CauchyMorph_inv R y)) y + (CauchyMorph_surject R y)) as [_ H]. + specialize (H2 (H Ey)). apply H2. + apply CauchyMorph_inv_increasing in abs. + rewrite CauchyMorph_inject in abs. exact abs. + + intros. apply (H3 (CauchyMorph_inv R y)). + intros z Ez abs. specialize (H4 (CauchyMorph R z)). + apply (H4 Ez). apply (CauchyMorph_increasing R) in abs. + apply (CRle_lt_trans R _ (CauchyMorph R (CauchyMorph_inv R y))). + 2: exact abs. apply (CauchyMorph_surject R y). + apply CauchyMorph_inv_increasing in H5. + rewrite CauchyMorph_inject in H5. exact H5. +Qed. diff --git a/theories/Reals/ConstructiveRealsMorphisms.v b/theories/Reals/ConstructiveRealsMorphisms.v new file mode 100644 index 0000000000..0d3027d475 --- /dev/null +++ b/theories/Reals/ConstructiveRealsMorphisms.v @@ -0,0 +1,1158 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +(** Morphisms used to transport results from any instance of + ConstructiveReals to any other. + Between any two constructive reals structures R1 and R2, + all morphisms R1 -> R2 are extensionally equal. We will + further show that they exist, and so are isomorphisms. + The difference between two morphisms R1 -> R2 is therefore + the speed of computation. + + The canonical isomorphisms we provide here are often very slow, + when a new implementation of constructive reals is added, + it should define its own ad hoc isomorphisms for better speed. + + Apart from the speed, those unique isomorphisms also serve as + sanity checks of the interface ConstructiveReals : + it captures a concept with a strong notion of uniqueness. *) + +Require Import QArith. +Require Import Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveCauchyRealsMult. +Require Import ConstructiveRIneq. + + +Record ConstructiveRealsMorphism (R1 R2 : ConstructiveReals) : Set := + { + CRmorph : CRcarrier R1 -> CRcarrier R2; + CRmorph_rat : forall q : Q, + orderEq _ (CRlt R2) (CRmorph (CR_of_Q R1 q)) (CR_of_Q R2 q); + CRmorph_increasing : forall x y : CRcarrier R1, + CRlt R1 x y -> CRlt R2 (CRmorph x) (CRmorph y); + }. + + +Lemma CRmorph_increasing_inv + : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRlt R2 (CRmorph _ _ f x) (CRmorph _ _ f y) + -> CRlt R1 x y. +Proof. + intros. destruct (CR_Q_dense R2 _ _ H) as [q [H0 H1]]. + destruct (CR_Q_dense R2 _ _ H0) as [r [H2 H3]]. + apply lt_CR_of_Q, (CR_of_Q_lt R1) in H3. + destruct (CRltLinear R1). + destruct (s _ x _ H3). + - exfalso. apply (CRmorph_increasing _ _ f) in c. + destruct (CRmorph_rat _ _ f r) as [H4 _]. + apply (CRle_lt_trans R2 _ _ _ H4) in c. clear H4. + exact (CRlt_asym R2 _ _ c H2). + - clear H2 H3 r. apply (CRlt_trans R1 _ _ _ c). clear c. + destruct (CR_Q_dense R2 _ _ H1) as [t [H2 H3]]. + apply lt_CR_of_Q, (CR_of_Q_lt R1) in H2. + destruct (s _ y _ H2). exact c. + exfalso. apply (CRmorph_increasing _ _ f) in c. + destruct (CRmorph_rat _ _ f t) as [_ H4]. + apply (CRlt_le_trans R2 _ _ _ c) in H4. clear c. + exact (CRlt_asym R2 _ _ H4 H3). +Qed. + +Lemma CRmorph_unique : forall (R1 R2 : ConstructiveReals) + (f g : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + orderEq _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ g x). +Proof. + split. + - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. + destruct (CRmorph_rat _ _ f q) as [H1 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + destruct (CRmorph_rat _ _ g q) as [_ H2]. + apply (CRle_lt_trans R2 _ _ _ H2) in H0. clear H2. + apply CRmorph_increasing_inv in H0. + exact (CRlt_asym R1 _ _ H0 H1). + - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. + destruct (CRmorph_rat _ _ f q) as [_ H1]. + apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + destruct (CRmorph_rat _ _ g q) as [H2 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H2. clear H. + apply CRmorph_increasing_inv in H2. + exact (CRlt_asym R1 _ _ H0 H2). +Qed. + + +(* The identity is the only endomorphism of constructive reals. + For any ConstructiveReals R1, R2 and any morphisms + f : R1 -> R2 and g : R2 -> R1, + f and g are isomorphisms and are inverses of each other. *) +Lemma Endomorph_id : forall (R : ConstructiveReals) (f : ConstructiveRealsMorphism R R) + (x : CRcarrier R), + orderEq _ (CRlt R) (CRmorph _ _ f x) x. +Proof. + split. + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. + destruct (CRmorph_rat _ _ f q) as [H _]. + apply (CRlt_le_trans R _ _ _ H0) in H. clear H0. + apply CRmorph_increasing_inv in H. + exact (CRlt_asym R _ _ H1 H). + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. + destruct (CRmorph_rat _ _ f q) as [_ H]. + apply (CRle_lt_trans R _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + exact (CRlt_asym R _ _ H1 H0). +Qed. + +Lemma CRmorph_proper : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + orderEq _ (CRlt R1) x y + -> orderEq _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). +Proof. + split. + - intro abs. apply CRmorph_increasing_inv in abs. + destruct H. contradiction. + - intro abs. apply CRmorph_increasing_inv in abs. + destruct H. contradiction. +Qed. + +Definition CRmorph_compose (R1 R2 R3 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (g : ConstructiveRealsMorphism R2 R3) + : ConstructiveRealsMorphism R1 R3. +Proof. + apply (Build_ConstructiveRealsMorphism + R1 R3 (fun x:CRcarrier R1 => CRmorph _ _ g (CRmorph _ _ f x))). + - intro q. apply (CReq_trans R3 _ (CRmorph R2 R3 g (CR_of_Q R2 q))). + apply CRmorph_proper. apply CRmorph_rat. apply CRmorph_rat. + - intros. apply CRmorph_increasing. apply CRmorph_increasing. exact H. +Defined. + +Lemma CRmorph_le : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + orderLe _ (CRlt R1) x y + -> orderLe _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). +Proof. + intros. intro abs. apply CRmorph_increasing_inv in abs. contradiction. +Qed. + +Lemma CRmorph_le_inv : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + orderLe _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y) + -> orderLe _ (CRlt R1) x y. +Proof. + intros. intro abs. apply (CRmorph_increasing _ _ f) in abs. contradiction. +Qed. + +Lemma CRmorph_zero : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRzero R1)) (CRzero R2). +Proof. + intros. apply (CReq_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 0))). + apply CRmorph_proper. apply CReq_sym, CR_of_Q_zero. + apply (CReq_trans R2 _ (CR_of_Q R2 0)). + apply CRmorph_rat. apply CR_of_Q_zero. +Qed. + +Lemma CRmorph_one : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRone R1)) (CRone R2). +Proof. + intros. apply (CReq_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 1))). + apply CRmorph_proper. apply CReq_sym, CR_of_Q_one. + apply (CReq_trans R2 _ (CR_of_Q R2 1)). + apply CRmorph_rat. apply CR_of_Q_one. +Qed. + +Lemma CRmorph_opp : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRopp R1 x)) + (CRopp R2 (CRmorph _ _ f x)). +Proof. + split. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. + destruct (CRmorph_rat R1 R2 f q) as [H1 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply CRopp_gt_lt_contravar in H0. + destruct (CR_of_Q_opp R2 q) as [H2 _]. + apply (CRlt_le_trans R2 _ _ _ H0) in H2. clear H0. + pose proof (CRopp_involutive R2 (CRmorph R1 R2 f x)) as [H _]. + apply (CRle_lt_trans R2 _ _ _ H) in H2. clear H. + destruct (CRmorph_rat R1 R2 f (-q)) as [H _]. + apply (CRlt_le_trans R2 _ _ _ H2) in H. clear H2. + apply CRmorph_increasing_inv in H. + destruct (CR_of_Q_opp R1 q) as [_ H2]. + apply (CRlt_le_trans R1 _ _ _ H) in H2. clear H. + apply CRopp_gt_lt_contravar in H2. + pose proof (CRopp_involutive R1 (CR_of_Q R1 q)) as [H _]. + apply (CRle_lt_trans R1 _ _ _ H) in H2. clear H. + exact (CRlt_asym R1 _ _ H1 H2). + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. + destruct (CRmorph_rat R1 R2 f q) as [_ H1]. + apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + apply CRopp_gt_lt_contravar in H. + pose proof (CRopp_involutive R2 (CRmorph R1 R2 f x)) as [_ H1]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + destruct (CR_of_Q_opp R2 q) as [_ H2]. + apply (CRle_lt_trans R2 _ _ _ H2) in H1. clear H2. + destruct (CRmorph_rat R1 R2 f (-q)) as [_ H]. + apply (CRle_lt_trans R2 _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + destruct (CR_of_Q_opp R1 q) as [H2 _]. + apply (CRle_lt_trans R1 _ _ _ H2) in H1. clear H2. + apply CRopp_gt_lt_contravar in H1. + pose proof (CRopp_involutive R1 (CR_of_Q R1 q)) as [_ H]. + apply (CRlt_le_trans R1 _ _ _ H1) in H. clear H1. + exact (CRlt_asym R1 _ _ H0 H). +Qed. + +Lemma CRplus_pos_rat_lt : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), + Qlt 0 q -> CRlt R x (CRplus R x (CR_of_Q R q)). +Proof. + intros. + apply (CRle_lt_trans R _ (CRplus R x (CRzero R))). apply CRplus_0_r. + apply CRplus_lt_compat_l. + apply (CRle_lt_trans R _ (CR_of_Q R 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt. exact H. +Defined. + +Lemma CRplus_neg_rat_lt : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), + Qlt q 0 -> CRlt R (CRplus R x (CR_of_Q R q)) x. +Proof. + intros. + apply (CRlt_le_trans R _ (CRplus R x (CRzero R))). 2: apply CRplus_0_r. + apply CRplus_lt_compat_l. + apply (CRlt_le_trans R _ (CR_of_Q R 0)). + apply CR_of_Q_lt. exact H. apply CR_of_Q_zero. +Qed. + +Lemma CRmorph_plus_rat : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (q : Q), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRplus R1 x (CR_of_Q R1 q))) + (CRplus R2 (CRmorph _ _ f x) (CR_of_Q R2 q)). +Proof. + split. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat _ _ f r) as [H1 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply (CRlt_asym R1 _ _ H1). clear H1. + apply (CRplus_lt_reg_r R1 (CRopp R1 (CR_of_Q R1 q))). + apply (CRlt_le_trans R1 _ x). + apply (CRle_lt_trans R1 _ (CR_of_Q R1 (r-q))). + apply (CRle_trans R1 _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). + apply CRplus_le_compat_l. destruct (CR_of_Q_opp R1 q). exact H. + destruct (CR_of_Q_plus R1 r (-q)). exact H. + apply (CRmorph_increasing_inv _ _ f). + apply (CRle_lt_trans R2 _ (CR_of_Q R2 (r - q))). + apply CRmorph_rat. + apply (CRplus_lt_reg_r R2 (CR_of_Q R2 q)). + apply (CRle_lt_trans R2 _ (CR_of_Q R2 r)). 2: exact H0. + intro H. + destruct (CR_of_Q_plus R2 (r-q) q) as [H1 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + apply lt_CR_of_Q in H1. ring_simplify in H1. + exact (Qlt_not_le _ _ H1 (Qle_refl _)). + destruct (CRisRing R1). + apply (CRle_trans R1 _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). + apply (CRle_trans R1 _ (CRplus R1 x (CRzero R1))). + destruct (CRplus_0_r R1 x). exact H. + apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H. + destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). + exact H1. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat _ _ f r) as [_ H1]. + apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + apply (CRlt_asym R1 _ _ H0). clear H0. + apply (CRplus_lt_reg_r R1 (CRopp R1 (CR_of_Q R1 q))). + apply (CRle_lt_trans R1 _ x). + destruct (CRisRing R1). + apply (CRle_trans R1 _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). + destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). + exact H0. + apply (CRle_trans R1 _ (CRplus R1 x (CRzero R1))). + apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H1. + destruct (CRplus_0_r R1 x). exact H1. + apply (CRlt_le_trans R1 _ (CR_of_Q R1 (r-q))). + apply (CRmorph_increasing_inv _ _ f). + apply (CRlt_le_trans R2 _ (CR_of_Q R2 (r - q))). + apply (CRplus_lt_reg_r R2 (CR_of_Q R2 q)). + apply (CRlt_le_trans R2 _ _ _ H). + 2: apply CRmorph_rat. + apply (CRle_trans R2 _ (CR_of_Q R2 (r-q+q))). + intro abs. apply lt_CR_of_Q in abs. ring_simplify in abs. + exact (Qlt_not_le _ _ abs (Qle_refl _)). + destruct (CR_of_Q_plus R2 (r-q) q). exact H1. + apply (CRle_trans R1 _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). + destruct (CR_of_Q_plus R1 r (-q)). exact H1. + apply CRplus_le_compat_l. destruct (CR_of_Q_opp R1 q). exact H1. +Qed. + +Lemma CRmorph_plus : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRplus R1 x y)) + (CRplus R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). +Proof. + intros R1 R2 f. + assert (forall (x y : CRcarrier R1), + orderLe _ (CRlt R2) (CRplus R2 (CRmorph R1 R2 f x) (CRmorph R1 R2 f y)) + (CRmorph R1 R2 f (CRplus R1 x y))). + { intros x y abs. destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat _ _ f r) as [H1 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply (CRlt_asym R1 _ _ H1). clear H1. + destruct (CR_Q_dense R2 _ _ H0) as [q [H2 H3]]. + apply lt_CR_of_Q in H2. + assert (Qlt (r-q) 0) as epsNeg. + { apply (Qplus_lt_r _ _ q). ring_simplify. exact H2. } + destruct (CR_Q_dense R1 _ _ (CRplus_neg_rat_lt R1 x (r-q) epsNeg)) + as [s [H4 H5]]. + apply (CRlt_trans R1 _ (CRplus R1 (CR_of_Q R1 s) y)). + 2: apply CRplus_lt_compat_r, H5. + apply (CRmorph_increasing_inv _ _ f). + apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 s) (CRmorph _ _ f y))). + apply (CRmorph_increasing _ _ f) in H4. + destruct (CRmorph_plus_rat _ _ f x (r-q)) as [H _]. + apply (CRle_lt_trans R2 _ _ _ H) in H4. clear H. + destruct (CRmorph_rat _ _ f s) as [_ H1]. + apply (CRlt_le_trans R2 _ _ _ H4) in H1. clear H4. + apply (CRlt_trans R2 _ (CRplus R2 (CRplus R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (r - q))) + (CRmorph R1 R2 f y))). + 2: apply CRplus_lt_compat_r, H1. + apply (CRlt_le_trans R2 _ (CRplus R2 (CRplus R2 (CR_of_Q R2 (r - q)) (CRmorph R1 R2 f x)) + (CRmorph R1 R2 f y))). + apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 (r - q)) + (CRplus R2 (CRmorph R1 R2 f x) (CRmorph R1 R2 f y)))). + apply (CRle_lt_trans R2 _ (CRplus R2 (CR_of_Q R2 (r - q)) (CR_of_Q R2 q))). + 2: apply CRplus_lt_compat_l, H3. + intro abs. + destruct (CR_of_Q_plus R2 (r-q) q) as [_ H4]. + apply (CRle_lt_trans R2 _ _ _ H4) in abs. clear H4. + destruct (CRmorph_rat _ _ f r) as [_ H4]. + apply (CRlt_le_trans R2 _ _ _ abs) in H4. clear abs. + apply lt_CR_of_Q in H4. ring_simplify in H4. + exact (Qlt_not_le _ _ H4 (Qle_refl _)). + destruct (CRisRing R2); apply Radd_assoc. + apply CRplus_le_compat_r. destruct (CRisRing R2). + destruct (Radd_comm (CRmorph R1 R2 f x) (CR_of_Q R2 (r - q))). + exact H. + intro abs. + destruct (CRmorph_plus_rat _ _ f y s) as [H _]. apply H. clear H. + apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 s) (CRmorph R1 R2 f y))). + apply (CRle_lt_trans R2 _ (CRmorph R1 R2 f (CRplus R1 (CR_of_Q R1 s) y))). + apply CRmorph_proper. destruct (CRisRing R1); apply Radd_comm. + exact abs. destruct (CRisRing R2); apply Radd_comm. } + split. + - apply H. + - specialize (H (CRplus R1 x y) (CRopp R1 y)). + intro abs. apply H. clear H. + apply (CRle_lt_trans R2 _ (CRmorph R1 R2 f x)). + apply CRmorph_proper. destruct (CRisRing R1). + apply (CReq_trans R1 _ (CRplus R1 x (CRplus R1 y (CRopp R1 y)))). + apply CReq_sym, Radd_assoc. + apply (CReq_trans R1 _ (CRplus R1 x (CRzero R1))). 2: apply CRplus_0_r. + destruct (CRisRingExt R1). apply Radd_ext. + apply CReq_refl. apply Ropp_def. + apply (CRplus_lt_reg_r R2 (CRmorph R1 R2 f y)). + apply (CRlt_le_trans R2 _ _ _ abs). clear abs. + apply (CRle_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRplus R1 x y)) (CRzero R2))). + destruct (CRplus_0_r R2 (CRmorph R1 R2 f (CRplus R1 x y))). exact H. + apply (CRle_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRplus R1 x y)) + (CRplus R2 (CRmorph R1 R2 f (CRopp R1 y)) (CRmorph R1 R2 f y)))). + apply CRplus_le_compat_l. + apply (CRle_trans R2 _ (CRplus R2 (CRopp R2 (CRmorph R1 R2 f y)) (CRmorph R1 R2 f y))). + destruct (CRplus_opp_l R2 (CRmorph R1 R2 f y)). exact H. + apply CRplus_le_compat_r. destruct (CRmorph_opp _ _ f y). exact H. + destruct (CRisRing R2). + destruct (Radd_assoc (CRmorph R1 R2 f (CRplus R1 x y)) + (CRmorph R1 R2 f (CRopp R1 y)) (CRmorph R1 R2 f y)). + exact H0. +Qed. + +Lemma CRmorph_mult_pos : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (n : nat), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))) + (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (Z.of_nat n # 1))). +Proof. + induction n. + - simpl. destruct (CRisRingExt R1). + apply (CReq_trans R2 _ (CRzero R2)). + + apply (CReq_trans R2 _ (CRmorph R1 R2 f (CRzero R1))). + 2: apply CRmorph_zero. apply CRmorph_proper. + apply (CReq_trans R1 _ (CRmult R1 x (CRzero R1))). + 2: apply CRmult_0_r. apply Rmul_ext. apply CReq_refl. apply CR_of_Q_zero. + + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRzero R2))). + apply CReq_sym, CRmult_0_r. destruct (CRisRingExt R2). + apply Rmul_ext0. apply CReq_refl. apply CReq_sym, CR_of_Q_zero. + - destruct (CRisRingExt R1), (CRisRingExt R2). + apply (CReq_trans + R2 _ (CRmorph R1 R2 f (CRplus R1 x (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). + apply CRmorph_proper. + apply (CReq_trans R1 _ (CRmult R1 x (CRplus R1 (CRone R1) (CR_of_Q R1 (Z.of_nat n # 1))))). + apply Rmul_ext. apply CReq_refl. + apply (CReq_trans R1 _ (CR_of_Q R1 (1 + (Z.of_nat n # 1)))). + apply CR_of_Q_proper. rewrite Nat2Z.inj_succ. unfold Z.succ. + rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. + apply (CReq_trans R1 _ (CRplus R1 (CR_of_Q R1 1) (CR_of_Q R1 (Z.of_nat n # 1)))). + apply CR_of_Q_plus. apply Radd_ext. apply CR_of_Q_one. apply CReq_refl. + apply (CReq_trans R1 _ (CRplus R1 (CRmult R1 x (CRone R1)) + (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1))))). + apply CRmult_plus_distr_l. apply Radd_ext. apply CRmult_1_r. apply CReq_refl. + apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f x) + (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). + apply CRmorph_plus. + apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f x) + (CRmult R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply Radd_ext0. apply CReq_refl. exact IHn. + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRplus R2 (CRone R2) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply (CReq_trans R2 _ (CRplus R2 (CRmult R2 (CRmorph R1 R2 f x) (CRone R2)) + (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply Radd_ext0. 2: apply CReq_refl. apply CReq_sym, CRmult_1_r. + apply CReq_sym, CRmult_plus_distr_l. + apply Rmul_ext0. apply CReq_refl. + apply (CReq_trans R2 _ (CR_of_Q R2 (1 + (Z.of_nat n # 1)))). + apply (CReq_trans R2 _ (CRplus R2 (CR_of_Q R2 1) (CR_of_Q R2 (Z.of_nat n # 1)))). + apply Radd_ext0. apply CReq_sym, CR_of_Q_one. apply CReq_refl. + apply CReq_sym, CR_of_Q_plus. + apply CR_of_Q_proper. rewrite Nat2Z.inj_succ. unfold Z.succ. + rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. +Qed. + +Lemma NatOfZ : forall n : Z, { p : nat | n = Z.of_nat p \/ n = Z.opp (Z.of_nat p) }. +Proof. + intros [|p|n]. + - exists O. left. reflexivity. + - exists (Pos.to_nat p). left. rewrite positive_nat_Z. reflexivity. + - exists (Pos.to_nat n). right. rewrite positive_nat_Z. reflexivity. +Qed. + +Lemma CRmorph_mult_int : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (n : Z), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (n # 1)))) + (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (n # 1))). +Proof. + intros. destruct (NatOfZ n) as [p [pos|neg]]. + - subst n. apply CRmorph_mult_pos. + - subst n. + apply (CReq_trans R2 _ (CRopp R2 (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). + + apply (CReq_trans R2 _ (CRmorph R1 R2 f (CRopp R1 (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). + 2: apply CRmorph_opp. apply CRmorph_proper. + apply (CReq_trans R1 _ (CRmult R1 x (CR_of_Q R1 (- (Z.of_nat p # 1))))). + destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. + apply CR_of_Q_proper. reflexivity. + apply (CReq_trans R1 _ (CRmult R1 x (CRopp R1 (CR_of_Q R1 (Z.of_nat p # 1))))). + destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. + apply CR_of_Q_opp. apply CReq_sym, CRopp_mult_distr_r. + + apply (CReq_trans R2 _ (CRopp R2 (CRmult R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (Z.of_nat p # 1))))). + destruct (CRisRingExt R2). apply Ropp_ext. apply CRmorph_mult_pos. + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRopp R2 (CR_of_Q R2 (Z.of_nat p # 1))))). + apply CRopp_mult_distr_r. destruct (CRisRingExt R2). + apply Rmul_ext. apply CReq_refl. + apply (CReq_trans R2 _ (CR_of_Q R2 (- (Z.of_nat p # 1)))). + apply CReq_sym, CR_of_Q_opp. apply CR_of_Q_proper. reflexivity. +Qed. + +Lemma CRmorph_mult_inv : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (p : positive), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (1 # p)))) + (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (1 # p))). +Proof. + intros. apply (CRmult_eq_reg_r R2 (CR_of_Q R2 (Z.pos p # 1))). + left. apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + apply (CReq_trans R2 _ (CRmorph _ _ f x)). + - apply (CReq_trans + R2 _ (CRmorph R1 R2 f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (1 # p))) + (CR_of_Q R1 (Z.pos p # 1))))). + apply CReq_sym, CRmorph_mult_int. apply CRmorph_proper. + apply (CReq_trans + R1 _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (1 # p)) + (CR_of_Q R1 (Z.pos p # 1))))). + destruct (CRisRing R1). apply CReq_sym, Rmul_assoc. + apply (CReq_trans R1 _ (CRmult R1 x (CRone R1))). + apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. + apply (CReq_trans R1 _ (CR_of_Q R1 ((1#p) * (Z.pos p # 1)))). + apply CReq_sym, CR_of_Q_mult. + apply (CReq_trans R1 _ (CR_of_Q R1 1)). + apply CR_of_Q_proper. reflexivity. apply CR_of_Q_one. + apply CRmult_1_r. + - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) + (CRmult R2 (CR_of_Q R2 (1 # p)) (CR_of_Q R2 (Z.pos p # 1))))). + 2: apply (Rmul_assoc (CRisRing R2)). + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRone R2))). + apply CReq_sym, CRmult_1_r. + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans R2 _ (CR_of_Q R2 1)). + apply CReq_sym, CR_of_Q_one. + apply (CReq_trans R2 _ (CR_of_Q R2 ((1#p)*(Z.pos p # 1)))). + apply CR_of_Q_proper. reflexivity. apply CR_of_Q_mult. +Qed. + +Lemma CRmorph_mult_rat : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (q : Q), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 q))) + (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 q)). +Proof. + intros. destruct q as [a b]. + apply (CReq_trans R2 _ (CRmult R2 (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (a # 1)))) + (CR_of_Q R2 (1 # b)))). + - apply (CReq_trans + R2 _ (CRmorph R1 R2 f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (a # 1))) + (CR_of_Q R1 (1 # b))))). + 2: apply CRmorph_mult_inv. apply CRmorph_proper. + apply (CReq_trans R1 _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (a # 1)) + (CR_of_Q R1 (1 # b))))). + apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. + apply (CReq_trans R1 _ (CR_of_Q R1 ((a#1)*(1#b)))). + apply CR_of_Q_proper. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. + apply CR_of_Q_mult. + apply (Rmul_assoc (CRisRing R1)). + - apply (CReq_trans R2 _ (CRmult R2 (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (a # 1))) + (CR_of_Q R2 (1 # b)))). + apply (Rmul_ext (CRisRingExt R2)). apply CRmorph_mult_int. + apply CReq_refl. + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) + (CRmult R2 (CR_of_Q R2 (a # 1)) (CR_of_Q R2 (1 # b))))). + apply CReq_sym, (Rmul_assoc (CRisRing R2)). + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans R2 _ (CR_of_Q R2 ((a#1)*(1#b)))). + apply CReq_sym, CR_of_Q_mult. + apply CR_of_Q_proper. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. +Qed. + +Lemma CRmorph_mult_pos_pos_le : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRlt R1 (CRzero R1) y + -> orderLe _ (CRlt R2) (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) + (CRmorph _ _ f (CRmult R1 x y)). +Proof. + intros. intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. + destruct (CRmorph_rat _ _ f q) as [H3 _]. + apply (CRlt_le_trans R2 _ _ _ H1) in H3. clear H1. + apply CRmorph_increasing_inv in H3. + apply (CRlt_asym R1 _ _ H3). clear H3. + destruct (CR_Q_dense R2 _ _ H2) as [r [H1 H3]]. + apply lt_CR_of_Q in H1. + destruct (CR_archimedean R1 y) as [A Amaj]. + assert (/ ((r - q) * (1 # A)) * (q - r) == - (Z.pos A # 1)) as diveq. + { rewrite Qinv_mult_distr. setoid_replace (q-r) with (-1*(r-q)). + field_simplify. reflexivity. 2: field. + split. intro H4. inversion H4. intro H4. + apply Qlt_minus_iff in H1. rewrite H4 in H1. inversion H1. } + destruct (CR_Q_dense R1 (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A)))) x) + as [s [H4 H5]]. + - apply (CRlt_le_trans R1 _ (CRplus R1 x (CRzero R1))). + 2: apply CRplus_0_r. apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l R1 (CR_of_Q R1 ((r-q) * (1#A)))). + apply (CRle_lt_trans R1 _ (CRzero R1)). + apply (CRle_trans R1 _ (CR_of_Q R1 ((r-q)*(1#A) + (q-r)*(1#A)))). + destruct (CR_of_Q_plus R1 ((r-q)*(1#A)) ((q-r)*(1#A))). + exact H0. apply (CRle_trans R1 _ (CR_of_Q R1 0)). + 2: destruct (CR_of_Q_zero R1); exact H4. + intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. + inversion H4. + apply (CRlt_le_trans R1 _ (CR_of_Q R1 ((r - q) * (1 # A)))). + 2: apply CRplus_0_r. + apply (CRle_lt_trans R1 _ (CR_of_Q R1 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. + rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. + apply Qlt_minus_iff in H1. exact H1. reflexivity. + - apply (CRmorph_increasing _ _ f) in H4. + destruct (CRmorph_plus _ _ f x (CR_of_Q R1 ((q-r) * (1#A)))) as [H6 _]. + apply (CRle_lt_trans R2 _ _ _ H6) in H4. clear H6. + destruct (CRmorph_rat _ _ f s) as [_ H6]. + apply (CRlt_le_trans R2 _ _ _ H4) in H6. clear H4. + apply (CRmult_lt_compat_r R2 (CRmorph _ _ f y)) in H6. + destruct (Rdistr_l (CRisRing R2) (CRmorph _ _ f x) + (CRmorph R1 R2 f (CR_of_Q R1 ((q-r) * (1#A)))) + (CRmorph _ _ f y)) as [H4 _]. + apply (CRle_lt_trans R2 _ _ _ H4) in H6. clear H4. + apply (CRle_lt_trans R1 _ (CRmult R1 (CR_of_Q R1 s) y)). + 2: apply CRmult_lt_compat_r. 2: exact H. 2: exact H5. + apply (CRmorph_le_inv _ _ f). + apply (CRle_trans R2 _ (CR_of_Q R2 q)). + destruct (CRmorph_rat _ _ f q). exact H4. + apply (CRle_trans R2 _ (CRmult R2 (CR_of_Q R2 s) (CRmorph _ _ f y))). + apply (CRle_trans R2 _ (CRplus R2 (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) + (CR_of_Q R2 (q-r)))). + apply (CRle_trans R2 _ (CRplus R2 (CR_of_Q R2 r) (CR_of_Q R2 (q - r)))). + + apply (CRle_trans R2 _ (CR_of_Q R2 (r + (q-r)))). + intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. + exact (Qlt_not_le q q H4 (Qle_refl q)). + destruct (CR_of_Q_plus R2 r (q-r)). exact H4. + + apply CRplus_le_compat_r. intro H4. + apply (CRlt_asym R2 _ _ H3). exact H4. + + intro H4. apply (CRlt_asym R2 _ _ H4). clear H4. + apply (CRlt_trans_flip R2 _ _ _ H6). clear H6. + apply CRplus_lt_compat_l. + apply (CRlt_le_trans R2 _ (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) (CRmorph R1 R2 f y))). + apply (CRmult_lt_reg_l R2 (CR_of_Q R2 (/((r-q)*(1#A))))). + apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt, Qinv_lt_0_compat. + rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. + apply Qlt_minus_iff in H1. exact H1. reflexivity. + apply (CRle_lt_trans R2 _ (CRopp R2 (CR_of_Q R2 (Z.pos A # 1)))). + apply (CRle_trans R2 _ (CR_of_Q R2 (-(Z.pos A # 1)))). + apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) * (q - r)))). + destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) (q - r)). + exact H0. destruct (CR_of_Q_proper R2 (/ ((r - q) * (1 # A)) * (q - r)) + (-(Z.pos A # 1))). + exact diveq. intro H7. apply lt_CR_of_Q in H7. + rewrite diveq in H7. exact (Qlt_not_le _ _ H7 (Qle_refl _)). + destruct (CR_of_Q_opp R2 (Z.pos A # 1)). exact H4. + apply (CRlt_le_trans R2 _ (CRopp R2 (CRmorph _ _ f y))). + apply CRopp_gt_lt_contravar. + apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 (Z.pos A # 1)))). + apply CRmorph_increasing. exact Amaj. + destruct (CRmorph_rat _ _ f (Z.pos A # 1)). exact H4. + apply (CRle_trans R2 _ (CRmult R2 (CRopp R2 (CRone R2)) (CRmorph _ _ f y))). + apply (CRle_trans R2 _ (CRopp R2 (CRmult R2 (CRone R2) (CRmorph R1 R2 f y)))). + destruct (Ropp_ext (CRisRingExt R2) (CRmorph _ _ f y) + (CRmult R2 (CRone R2) (CRmorph R1 R2 f y))). + apply CReq_sym, (Rmul_1_l (CRisRing R2)). exact H4. + destruct (CRopp_mult_distr_l R2 (CRone R2) (CRmorph _ _ f y)). exact H4. + apply (CRle_trans R2 _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((r - q) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A)))) + (CRmorph R1 R2 f y))). + apply CRmult_le_compat_r. + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) + * ((q - r) * (1 # A))))). + apply (CRle_trans R2 _ (CR_of_Q R2 (-1))). + apply (CRle_trans R2 _ (CRopp R2 (CR_of_Q R2 1))). + destruct (Ropp_ext (CRisRingExt R2) (CRone R2) (CR_of_Q R2 1)). + apply CReq_sym, CR_of_Q_one. exact H4. + destruct (CR_of_Q_opp R2 1). exact H0. + destruct (CR_of_Q_proper R2 (-1) (/ ((r - q) * (1 # A)) * ((q - r) * (1 # A)))). + field. split. + intro H4. inversion H4. intro H4. apply Qlt_minus_iff in H1. + rewrite H4 in H1. inversion H1. exact H4. + destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) ((q - r) * (1 # A))). + exact H4. + destruct (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((r - q) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph R1 R2 f y)). + exact H0. + apply CRmult_le_compat_r. + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + destruct (CRmorph_rat _ _ f ((q - r) * (1 # A))). exact H0. + + apply (CRle_trans R2 _ (CRmorph _ _ f (CRmult R1 y (CR_of_Q R1 s)))). + apply (CRle_trans R2 _ (CRmult R2 (CRmorph R1 R2 f y) (CR_of_Q R2 s))). + destruct (Rmul_comm (CRisRing R2) (CRmorph R1 R2 f y) (CR_of_Q R2 s)). + exact H0. + destruct (CRmorph_mult_rat _ _ f y s). exact H0. + destruct (CRmorph_proper _ _ f (CRmult R1 y (CR_of_Q R1 s)) + (CRmult R1 (CR_of_Q R1 s) y)). + apply (Rmul_comm (CRisRing R1)). exact H4. + + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. +Qed. + +Lemma CRmorph_mult_pos_pos : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRlt R1 (CRzero R1) y + -> orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x y)) + (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). +Proof. + split. apply CRmorph_mult_pos_pos_le. exact H. + intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. + destruct (CRmorph_rat _ _ f q) as [_ H3]. + apply (CRle_lt_trans R2 _ _ _ H3) in H2. clear H3. + apply CRmorph_increasing_inv in H2. + apply (CRlt_asym R1 _ _ H2). clear H2. + destruct (CR_Q_dense R2 _ _ H1) as [r [H2 H3]]. + apply lt_CR_of_Q in H3. + destruct (CR_archimedean R1 y) as [A Amaj]. + destruct (CR_Q_dense R1 x (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A))))) + as [s [H4 H5]]. + - apply (CRle_lt_trans R1 _ (CRplus R1 x (CRzero R1))). + apply CRplus_0_r. apply CRplus_lt_compat_l. + apply (CRle_lt_trans R1 _ (CR_of_Q R1 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. + rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. + apply Qlt_minus_iff in H3. exact H3. reflexivity. + - apply (CRmorph_increasing _ _ f) in H5. + destruct (CRmorph_plus _ _ f x (CR_of_Q R1 ((q-r) * (1#A)))) as [_ H6]. + apply (CRlt_le_trans R2 _ _ _ H5) in H6. clear H5. + destruct (CRmorph_rat _ _ f s) as [H5 _ ]. + apply (CRle_lt_trans R2 _ _ _ H5) in H6. clear H5. + apply (CRmult_lt_compat_r R2 (CRmorph _ _ f y)) in H6. + apply (CRlt_le_trans R1 _ (CRmult R1 (CR_of_Q R1 s) y)). + apply CRmult_lt_compat_r. exact H. exact H4. clear H4. + apply (CRmorph_le_inv _ _ f). + apply (CRle_trans R2 _ (CR_of_Q R2 q)). + 2: destruct (CRmorph_rat _ _ f q); exact H0. + apply (CRle_trans R2 _ (CRmult R2 (CR_of_Q R2 s) (CRmorph R1 R2 f y))). + + apply (CRle_trans R2 _ (CRmorph _ _ f (CRmult R1 y (CR_of_Q R1 s)))). + destruct (CRmorph_proper _ _ f (CRmult R1 (CR_of_Q R1 s) y) + (CRmult R1 y (CR_of_Q R1 s))). + apply (Rmul_comm (CRisRing R1)). exact H4. + apply (CRle_trans R2 _ (CRmult R2 (CRmorph R1 R2 f y) (CR_of_Q R2 s))). + exact (proj2 (CRmorph_mult_rat _ _ f y s)). + destruct (Rmul_comm (CRisRing R2) (CR_of_Q R2 s) (CRmorph R1 R2 f y)). + exact H0. + + intro H5. apply (CRlt_asym R2 _ _ H5). clear H5. + apply (CRlt_trans R2 _ _ _ H6). clear H6. + apply (CRle_lt_trans + R2 _ (CRplus R2 + (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) + (CRmult R2 (CRmorph R1 R2 f (CR_of_Q R1 ((q - r) * (1 # A)))) + (CRmorph R1 R2 f y)))). + apply (Rdistr_l (CRisRing R2)). + apply (CRle_lt_trans + R2 _ (CRplus R2 (CR_of_Q R2 r) + (CRmult R2 (CRmorph R1 R2 f (CR_of_Q R1 ((q - r) * (1 # A)))) + (CRmorph R1 R2 f y)))). + apply CRplus_le_compat_r. intro H5. apply (CRlt_asym R2 _ _ H5 H2). + clear H2. + apply (CRle_lt_trans + R2 _ (CRplus R2 (CR_of_Q R2 r) + (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph R1 R2 f y)))). + apply CRplus_le_compat_l, CRmult_le_compat_r. + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + destruct (CRmorph_rat _ _ f ((q - r) * (1 # A))). exact H2. + apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 r) + (CR_of_Q R2 ((q - r))))). + apply CRplus_lt_compat_l. + * apply (CRmult_lt_reg_l R2 (CR_of_Q R2 (/((q - r) * (1 # A))))). + apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt, Qinv_lt_0_compat. + rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. + apply Qlt_minus_iff in H3. exact H3. reflexivity. + apply (CRle_lt_trans R2 _ (CRmorph _ _ f y)). + apply (CRle_trans R2 _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((q - r) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A)))) + (CRmorph R1 R2 f y))). + exact (proj2 (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((q - r) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph _ _ f y))). + apply (CRle_trans R2 _ (CRmult R2 (CRone R2) (CRmorph R1 R2 f y))). + apply CRmult_le_compat_r. + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * ((q - r) * (1 # A))))). + exact (proj1 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) ((q - r) * (1 # A)))). + apply (CRle_trans R2 _ (CR_of_Q R2 1)). + destruct (CR_of_Q_proper R2 (/ ((q - r) * (1 # A)) * ((q - r) * (1 # A))) 1). + field_simplify. reflexivity. split. + intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. + rewrite H5 in H3. inversion H3. exact H2. + destruct (CR_of_Q_one R2). exact H2. + destruct (Rmul_1_l (CRisRing R2) (CRmorph _ _ f y)). + intro H5. contradiction. + apply (CRlt_le_trans R2 _ (CR_of_Q R2 (Z.pos A # 1))). + apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 (Z.pos A # 1)))). + apply CRmorph_increasing. exact Amaj. + exact (proj2 (CRmorph_rat _ _ f (Z.pos A # 1))). + apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * (q - r)))). + 2: exact (proj2 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) (q - r))). + destruct (CR_of_Q_proper R2 (Z.pos A # 1) (/ ((q - r) * (1 # A)) * (q - r))). + field_simplify. reflexivity. split. + intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. + rewrite H5 in H3. inversion H3. exact H2. + * apply (CRle_trans R2 _ (CR_of_Q R2 (r + (q-r)))). + exact (proj1 (CR_of_Q_plus R2 r (q-r))). + destruct (CR_of_Q_proper R2 (r + (q-r)) q). ring. exact H2. + + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. +Qed. + +Lemma CRmorph_mult : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x y)) + (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). +Proof. + intros. + destruct (CR_archimedean R1 (CRopp R1 y)) as [p pmaj]. + apply (CRplus_eq_reg_r R2 (CRmult R2 (CRmorph _ _ f x) + (CR_of_Q R2 (Z.pos p # 1)))). + apply (CReq_trans R2 _ (CRmorph _ _ f (CRmult R1 x (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). + - apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRmult R1 x y)) + (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). + apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. + apply CReq_sym, CRmorph_mult_int. + apply (CReq_trans R2 _ (CRmorph _ _ f (CRplus R1 (CRmult R1 x y) + (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). + apply CReq_sym, CRmorph_plus. apply CRmorph_proper. + apply CReq_sym, CRmult_plus_distr_l. + - apply (CReq_trans R2 _ (CRmult R2 (CRmorph _ _ f x) + (CRmorph _ _ f (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). + apply CRmorph_mult_pos_pos. + apply (CRplus_lt_compat_l R1 y) in pmaj. + apply (CRle_lt_trans R1 _ (CRplus R1 y (CRopp R1 y))). + 2: exact pmaj. apply (CRisRing R1). + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) + (CRplus R2 (CRmorph R1 R2 f y) (CR_of_Q R2 (Z.pos p # 1))))). + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f y) + (CRmorph _ _ f (CR_of_Q R1 (Z.pos p # 1))))). + apply CRmorph_plus. + apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. + apply CRmorph_rat. + apply CRmult_plus_distr_l. +Qed. + +Lemma CRmorph_appart : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1) + (app : orderAppart _ (CRlt R1) x y), + orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). +Proof. + intros. destruct app. + - left. apply CRmorph_increasing. exact c. + - right. apply CRmorph_increasing. exact c. +Defined. + +Lemma CRmorph_appart_zero : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) + (app : orderAppart _ (CRlt R1) x (CRzero R1)), + orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRzero R2). +Proof. + intros. destruct app. + - left. apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_increasing. exact c. + exact (proj2 (CRmorph_zero _ _ f)). + - right. apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + exact (proj1 (CRmorph_zero _ _ f)). + apply CRmorph_increasing. exact c. +Defined. + +Lemma CRmorph_inv : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) + (xnz : orderAppart _ (CRlt R1) x (CRzero R1)) + (fxnz : orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRzero R2)), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRinv R1 x xnz)) + (CRinv R2 (CRmorph _ _ f x) fxnz). +Proof. + intros. apply (CRmult_eq_reg_r R2 (CRmorph _ _ f x)). + destruct fxnz. right. exact c. left. exact c. + apply (CReq_trans R2 _ (CRone R2)). + 2: apply CReq_sym, CRinv_l. + apply (CReq_trans R2 _ (CRmorph _ _ f (CRmult R1 (CRinv R1 x xnz) x))). + apply CReq_sym, CRmorph_mult. + apply (CReq_trans R2 _ (CRmorph _ _ f (CRone R1))). + apply CRmorph_proper. apply CRinv_l. + apply CRmorph_one. +Qed. + +Definition CauchyMorph (R : ConstructiveReals) + : CReal -> CRcarrier R. +Proof. + intros [xn xcau]. + destruct (CR_complete R (fun n:nat => CR_of_Q R (xn n))). + - intros p. exists (Pos.to_nat p). intros. + specialize (xcau p i j H H0). apply Qlt_le_weak in xcau. + rewrite Qabs_Qle_condition in xcau. split. + + unfold CRminus. + apply (CRle_trans R _ (CRplus R (CR_of_Q R (xn i)) (CR_of_Q R (-xn j)))). + apply (CRle_trans R _ (CR_of_Q R (xn i-xn j))). + apply CR_of_Q_le. apply xcau. exact (proj2 (CR_of_Q_plus R _ _)). + apply CRplus_le_compat_l. exact (proj2 (CR_of_Q_opp R (xn j))). + + unfold CRminus. + apply (CRle_trans R _ (CRplus R (CR_of_Q R (xn i)) (CR_of_Q R (-xn j)))). + apply CRplus_le_compat_l. exact (proj1 (CR_of_Q_opp R (xn j))). + apply (CRle_trans R _ (CR_of_Q R (xn i-xn j))). + exact (proj1 (CR_of_Q_plus R _ _)). + apply CR_of_Q_le. apply xcau. + - exact x. +Defined. + +Lemma CauchyMorph_rat : forall (R : ConstructiveReals) (q : Q), + orderEq _ (CRlt R) (CauchyMorph R (inject_Q q)) (CR_of_Q R q). +Proof. + intros. + unfold CauchyMorph; simpl; + destruct (CRltLinear R), p, (CR_complete R (fun _ : nat => CR_of_Q R q)). + apply CR_cv_const in c0. apply CReq_sym. exact c0. +Qed. + +Lemma CauchyMorph_increasing_Ql : forall (R : ConstructiveReals) (x : CReal) (q : Q), + CRealLt x (inject_Q q) -> CRlt R (CauchyMorph R x) (CR_of_Q R q). +Proof. + intros. + unfold CauchyMorph; simpl; + destruct x as [xn xcau], (CRltLinear R), p, (CR_complete R (fun n : nat => CR_of_Q R (xn n))). + destruct (CRealQ_dense _ _ H) as [r [H0 H1]]. + apply lt_inject_Q in H1. + destruct (s _ x _ (CR_of_Q_lt R _ _ H1)). 2: exact c1. exfalso. + clear H1 H q. + (* For an index high enough, xn should be both higher + and lower than r, which is absurd. *) + apply CRealLt_above in H0. + destruct H0 as [p pmaj]. simpl in pmaj. + destruct (CR_cv_above_rat R xn x r c0 c1). + assert (x0 <= Nat.max (Pos.to_nat p) (S x0))%nat. + { apply (le_trans _ (S x0)). apply le_S, le_refl. apply Nat.le_max_r. } + specialize (q (Nat.max (Pos.to_nat p) (S x0)) H). clear H. + specialize (pmaj (Pos.max p (Pos.of_nat (S x0))) (Pos.le_max_l _ _)). + rewrite Pos2Nat.inj_max, Nat2Pos.id in pmaj. 2: discriminate. + apply (Qlt_not_le _ _ q). apply Qlt_le_weak. + apply Qlt_minus_iff. apply (Qlt_trans _ (2#p)). reflexivity. exact pmaj. +Qed. + +Lemma CauchyMorph_increasing_Qr : forall (R : ConstructiveReals) (x : CReal) (q : Q), + CRealLt (inject_Q q) x -> CRlt R (CR_of_Q R q) (CauchyMorph R x). +Proof. + intros. + unfold CauchyMorph; simpl; + destruct x as [xn xcau], (CRltLinear R), p, (CR_complete R (fun n : nat => CR_of_Q R (xn n))). + destruct (CRealQ_dense _ _ H) as [r [H0 H1]]. + apply lt_inject_Q in H0. + destruct (s _ x _ (CR_of_Q_lt R _ _ H0)). exact c1. exfalso. + clear H0 H q. + (* For an index high enough, xn should be both higher + and lower than r, which is absurd. *) + apply CRealLt_above in H1. + destruct H1 as [p pmaj]. simpl in pmaj. + destruct (CR_cv_below_rat R xn x r c0 c1). + assert (x0 <= Nat.max (Pos.to_nat p) (S x0))%nat. + { apply (le_trans _ (S x0)). apply le_S, le_refl. apply Nat.le_max_r. } + specialize (q (Nat.max (Pos.to_nat p) (S x0)) H). clear H. + specialize (pmaj (Pos.max p (Pos.of_nat (S x0))) (Pos.le_max_l _ _)). + rewrite Pos2Nat.inj_max, Nat2Pos.id in pmaj. 2: discriminate. + apply (Qlt_not_le _ _ q). apply Qlt_le_weak. + apply Qlt_minus_iff. apply (Qlt_trans _ (2#p)). reflexivity. exact pmaj. +Qed. + +Lemma CauchyMorph_increasing : forall (R : ConstructiveReals) (x y : CReal), + CRealLt x y -> CRlt R (CauchyMorph R x) (CauchyMorph R y). +Proof. + intros. + destruct (CRealQ_dense _ _ H) as [q [H0 H1]]. + apply (CRlt_trans R _ (CR_of_Q R q)). + apply CauchyMorph_increasing_Ql. exact H0. + apply CauchyMorph_increasing_Qr. exact H1. +Qed. + +Definition CauchyMorphism (R : ConstructiveReals) : ConstructiveRealsMorphism CRealImplem R. +Proof. + apply (Build_ConstructiveRealsMorphism CRealImplem R (CauchyMorph R)). + exact (CauchyMorph_rat R). + exact (CauchyMorph_increasing R). +Defined. + +Lemma RightBound : forall (R : ConstructiveReals) (x : CRcarrier R) (p q r : Q), + CRlt R x (CR_of_Q R q) + -> CRlt R x (CR_of_Q R r) + -> CRlt R (CR_of_Q R q) (CRplus R x (CR_of_Q R p)) + -> CRlt R (CR_of_Q R r) (CRplus R x (CR_of_Q R p)) + -> Qlt (Qabs (q - r)) p. +Proof. + intros. apply Qabs_case. + - intros. apply (Qplus_lt_l _ _ r). ring_simplify. + apply (lt_CR_of_Q R), (CRlt_le_trans R _ _ _ H1). + apply (CRle_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R p))). + intro abs. apply CRplus_lt_reg_r in abs. + exact (CRlt_asym R _ _ abs H0). + destruct (CR_of_Q_plus R r p). exact H4. + - intros. apply (Qplus_lt_l _ _ q). ring_simplify. + apply (lt_CR_of_Q R), (CRlt_le_trans R _ _ _ H2). + apply (CRle_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R p))). + intro abs. apply CRplus_lt_reg_r in abs. + exact (CRlt_asym R _ _ abs H). + destruct (CR_of_Q_plus R q p). exact H4. +Qed. + +Definition CauchyMorph_inv (R : ConstructiveReals) + : CRcarrier R -> CReal. +Proof. + intro x. + exists (fun n:nat => let (q,_) := CR_Q_dense + R x _ (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S n)) (eq_refl _)) + in q). + intros n p q H0 H1. + destruct (CR_Q_dense R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S p)))) + (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S p)) (eq_refl _))) + as [r [H2 H3]]. + destruct (CR_Q_dense R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S q)))) + (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S q)) (eq_refl _))) + as [s [H4 H5]]. + apply (RightBound R x (1#n) r s). exact H2. exact H4. + apply (CRlt_trans R _ _ _ H3), CRplus_lt_compat_l, CR_of_Q_lt. + unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. + apply Pos2Z.pos_lt_pos, Pos2Nat.inj_lt. rewrite Nat2Pos.id. + 2: discriminate. apply le_n_S. exact H0. + apply (CRlt_trans R _ _ _ H5), CRplus_lt_compat_l, CR_of_Q_lt. + unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. + apply Pos2Z.pos_lt_pos, Pos2Nat.inj_lt. rewrite Nat2Pos.id. + 2: discriminate. apply le_n_S. exact H1. +Defined. + +Lemma CauchyMorph_inv_rat : forall (R : ConstructiveReals) (q : Q), + CRealEq (CauchyMorph_inv R (CR_of_Q R q)) (inject_Q q). +Proof. + split. + - intros [n nmaj]. unfold CauchyMorph_inv, proj1_sig, inject_Q in nmaj. + destruct (CR_Q_dense R (CR_of_Q R q) + (CRplus R (CR_of_Q R q) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat n))))) + (CRplus_pos_rat_lt R (CR_of_Q R q) (1 # Pos.of_nat (S (Pos.to_nat n))) + eq_refl)) + as [r [H _]]. + apply lt_CR_of_Q, Qlt_minus_iff in H. + apply (Qlt_not_le _ _ H), (Qplus_le_l _ _ (q-r)). + ring_simplify. apply (Qle_trans _ (2#n)). discriminate. + apply Qlt_le_weak. ring_simplify in nmaj. rewrite Qplus_comm. exact nmaj. + - intros [n nmaj]. unfold CauchyMorph_inv, proj1_sig, inject_Q in nmaj. + destruct (CR_Q_dense R (CR_of_Q R q) + (CRplus R (CR_of_Q R q) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat n))))) + (CRplus_pos_rat_lt R (CR_of_Q R q) (1 # Pos.of_nat (S (Pos.to_nat n))) + eq_refl)) + as [r [_ H0]]. + destruct (CR_of_Q_plus R q (1 # Pos.of_nat (S (Pos.to_nat n)))) as [H1 _]. + apply (CRlt_le_trans R _ _ _ H0) in H1. clear H0. + apply lt_CR_of_Q, (Qplus_lt_l _ _ (-q)) in H1. + ring_simplify in H1. ring_simplify in nmaj. + apply (Qlt_trans _ _ _ nmaj) in H1. clear nmaj. + apply (Qlt_not_le _ _ H1). clear H1. + apply (Qle_trans _ (1#n)). + unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. + apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. + rewrite Nat2Pos.id. 2: discriminate. apply le_S, le_refl. + unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. + 2: discriminate. apply Pos2Z.pos_is_nonneg. +Qed. + +(* The easier side, because CauchyMorph_inv takes a limit from above. *) +Lemma CauchyMorph_inv_increasing_Qr + : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), + CRlt R (CR_of_Q R q) x -> CRealLt (inject_Q q) (CauchyMorph_inv R x). +Proof. + intros. + destruct (CR_Q_dense R _ _ H) as [r [H2 H3]]. + apply lt_CR_of_Q in H2. + destruct (Qarchimedean (/(r-q))) as [p pmaj]. + exists (2*p)%positive. unfold CauchyMorph_inv, inject_Q, proj1_sig. + destruct (CR_Q_dense + R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (2*p)))))) + (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S (Pos.to_nat (2*p)))) eq_refl)) + as [t [H4 H5]]. + setoid_replace (2#2*p) with (1#p). 2: reflexivity. + apply (Qlt_trans _ (r-q)). + apply (Qmult_lt_l _ _ (r-q)) in pmaj. + rewrite Qmult_inv_r in pmaj. + apply Qlt_shift_inv_r in pmaj. 2: reflexivity. exact pmaj. + intro abs. apply Qlt_minus_iff in H2. + rewrite abs in H2. inversion H2. + apply Qlt_minus_iff in H2. exact H2. + apply Qplus_lt_l, (lt_CR_of_Q R), (CRlt_trans R _ x _ H3 H4). +Qed. + +Lemma CauchyMorph_inv_increasing : forall (R : ConstructiveReals) (x y : CRcarrier R), + CRlt R x y -> CRealLt (CauchyMorph_inv R x) (CauchyMorph_inv R y). +Proof. + intros. + destruct (CR_Q_dense R _ _ H) as [q [H0 H1]]. + apply (CReal_lt_trans _ (inject_Q q)). + - clear H1 H y. + destruct (CR_Q_dense R _ _ H0) as [r [H2 H3]]. + apply lt_CR_of_Q in H3. + destruct (Qarchimedean (/(q-r))) as [p pmaj]. + exists (4*p)%positive. unfold CauchyMorph_inv, inject_Q, proj1_sig. + destruct (CR_Q_dense + R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (4*p)))))) + (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S (Pos.to_nat (4*p)))) eq_refl)) + as [t [H4 H5]]. + setoid_replace (2#4*p) with (1#2*p). 2: reflexivity. + assert (1 # 2 * p < (q - r) / 2) as H. + { apply Qlt_shift_div_l. reflexivity. + setoid_replace ((1#2*p)*2) with (1#p). + apply (Qmult_lt_l _ _ (q-r)) in pmaj. + rewrite Qmult_inv_r in pmaj. + apply Qlt_shift_inv_r in pmaj. 2: reflexivity. exact pmaj. + intro abs. apply Qlt_minus_iff in H3. + rewrite abs in H3. inversion H3. + apply Qlt_minus_iff in H3. exact H3. + rewrite Qmult_comm. reflexivity. } + apply (Qlt_trans _ ((q-r)/2)). exact H. + apply (Qplus_lt_l _ _ (t + (r-q)/2)). field_simplify. + setoid_replace (2*t/2) with t. 2: field. + apply (lt_CR_of_Q R). apply (CRlt_trans R _ _ _ H5). + apply (CRlt_trans + R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (4 * p))))))). + apply CRplus_lt_compat_r. exact H2. + apply (CRle_lt_trans + R _ (CR_of_Q R (r + (1 # Pos.of_nat (S (Pos.to_nat (4 * p))))))). + apply CR_of_Q_plus. apply CR_of_Q_lt. + apply (Qlt_le_trans _ (r + (q-r)/2)). + 2: field_simplify; apply Qle_refl. + apply Qplus_lt_r. + apply (Qlt_trans _ (1#2*p)). 2: exact H. + unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. + apply Pos2Z.pos_lt_pos. + rewrite Nat2Pos.inj_succ, Pos2Nat.id. + apply (Pos.lt_trans _ (4*p)). apply Pos2Nat.inj_lt. + do 2 rewrite Pos2Nat.inj_mul. + apply Nat.mul_lt_mono_pos_r. apply Pos2Nat.is_pos. + unfold Pos.to_nat. simpl. auto. + apply Pos.lt_succ_diag_r. + intro abs. pose proof (Pos2Nat.is_pos (4*p)). + rewrite abs in H1. inversion H1. + - apply CauchyMorph_inv_increasing_Qr. exact H1. +Qed. + +Definition CauchyMorphismInv (R : ConstructiveReals) + : ConstructiveRealsMorphism R CRealImplem. +Proof. + apply (Build_ConstructiveRealsMorphism R CRealImplem (CauchyMorph_inv R)). + - apply CauchyMorph_inv_rat. + - apply CauchyMorph_inv_increasing. +Defined. + +Lemma CauchyMorph_surject : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) (CauchyMorph R (CauchyMorph_inv R x)) x. +Proof. + intros. + apply (Endomorph_id + R (CRmorph_compose _ _ _ (CauchyMorphismInv R) (CauchyMorphism R)) x). +Qed. + +Lemma CauchyMorph_inject : forall (R : ConstructiveReals) (x : CReal), + CRealEq (CauchyMorph_inv R (CauchyMorph R x)) x. +Proof. + intros. + apply (Endomorph_id CRealImplem (CRmorph_compose _ _ _ (CauchyMorphism R) (CauchyMorphismInv R)) x). +Qed. + +(* We call this morphism slow to remind that it should only be used + for proofs, not for computations. *) +Definition SlowConstructiveRealsMorphism (R1 R2 : ConstructiveReals) + : ConstructiveRealsMorphism R1 R2 + := CRmorph_compose R1 CRealImplem R2 + (CauchyMorphismInv R1) (CauchyMorphism R2). diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index f03b0ccea3..d856d1c7fe 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -21,6 +21,7 @@ Require Export ZArith_base. Require Import ConstructiveRIneq. +Require Import ConstructiveRealsLUB. Require Export Rdefinitions. Declare Scope R_scope. Local Open Scope R_scope. @@ -408,6 +409,10 @@ Lemma completeness : bound E -> (exists x : R, E x) -> { m:R | is_lub E m }. Proof. intros. pose (fun x:ConstructiveRIneq.R => E (Rabst x)) as Er. + assert (forall x y : CRcarrier CR, orderEq (CRcarrier CR) (CRlt CR) x y -> Er x <-> Er y) + as Erproper. + { intros. unfold Er. replace (Rabst x) with (Rabst y). reflexivity. + apply Rquot1. do 2 rewrite Rquot2. split; apply H1. } assert (exists x : ConstructiveRIneq.R, Er x) as Einhab. { destruct H0. exists (Rrepr x). unfold Er. replace (Rabst (Rrepr x)) with x. exact H0. @@ -418,7 +423,7 @@ Proof. { destruct H. exists (Rrepr x). intros y Ey. rewrite <- (Rquot2 y). apply Rrepr_le. apply H. exact Ey. } destruct (CR_sig_lub CR - Er sig_forall_dec sig_not_dec Einhab Ebound). + Er Erproper sig_forall_dec sig_not_dec Einhab Ebound). exists (Rabst x). split. intros y Ey. apply Rrepr_le. rewrite Rquot2. unfold ConstructiveRIneq.Rle. apply a. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index 566dd31a9e..a411c5e54e 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -26,6 +26,8 @@ Arguments LT [X lt eq x y] _. Arguments EQ [X lt eq x y] _. Arguments GT [X lt eq x y] _. +Create HintDb ordered_type. + Module Type MiniOrderedType. Parameter Inline t : Type. @@ -42,8 +44,8 @@ Module Type MiniOrderedType. Parameter compare : forall x y : t, Compare lt eq x y. - Hint Immediate eq_sym : core. - Hint Resolve eq_refl eq_trans lt_not_eq lt_trans : core. + Hint Immediate eq_sym : ordered_type. + Hint Resolve eq_refl eq_trans lt_not_eq lt_trans : ordered_type. End MiniOrderedType. @@ -60,9 +62,9 @@ Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. Include O. Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. - Proof. - intros; elim (compare x y); intro H; [ right | left | right ]; auto. - assert (~ eq y x); auto. + Proof with auto with ordered_type. + intros; elim (compare x y); intro H; [ right | left | right ]... + assert (~ eq y x)... Defined. End MOT_to_OT. @@ -79,31 +81,30 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_antirefl : forall x, ~ lt x x. Proof. - intros; intro; absurd (eq x x); auto. + intros; intro; absurd (eq x x); auto with ordered_type. Qed. Instance lt_strorder : StrictOrder lt. Proof. split; [ exact lt_antirefl | exact lt_trans]. Qed. Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. - Proof. + Proof with auto with ordered_type. intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. - elim (lt_not_eq H); apply eq_trans with z; auto. - elim (lt_not_eq (lt_trans Hlt H)); auto. + elim (lt_not_eq H); apply eq_trans with z... + elim (lt_not_eq (lt_trans Hlt H))... Qed. Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. - Proof. + Proof with auto with ordered_type. intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. - elim (lt_not_eq H0); apply eq_trans with x; auto. - elim (lt_not_eq (lt_trans H0 Hlt)); auto. + elim (lt_not_eq H0); apply eq_trans with x... + elim (lt_not_eq (lt_trans H0 Hlt))... Qed. Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. apply proper_sym_impl_iff_2; auto with *. intros x x' Hx y y' Hy H. - apply eq_lt with x; auto. + apply eq_lt with x; auto with ordered_type. apply lt_eq with y; auto. Qed. @@ -143,9 +144,9 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed. Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed. - Hint Resolve gt_not_eq eq_not_lt : core. - Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq : core. - Hint Resolve eq_not_gt lt_antirefl lt_not_gt : core. + Hint Resolve gt_not_eq eq_not_lt : ordered_type. + Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq : ordered_type. + Hint Resolve eq_not_gt lt_antirefl lt_not_gt : ordered_type. Lemma elim_compare_eq : forall x y : t, @@ -197,7 +198,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. Proof. - intros; elim (compare x y); [ left | right | right ]; auto. + intros; elim (compare x y); [ left | right | right ]; auto with ordered_type. Defined. Definition eqb x y : bool := if eq_dec x y then true else false. @@ -247,8 +248,8 @@ Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed. End ForNotations. -Hint Resolve ListIn_In Sort_NoDup Inf_lt : core. -Hint Immediate In_eq Inf_lt : core. +Hint Resolve ListIn_In Sort_NoDup Inf_lt : ordered_type. +Hint Immediate In_eq Inf_lt : ordered_type. End OrderedTypeFacts. @@ -266,8 +267,8 @@ Module KeyOrderedType(O:OrderedType). eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition ltk (p p':key*elt) := lt (fst p) (fst p'). - Hint Unfold eqk eqke ltk : core. - Hint Extern 2 (eqke ?a ?b) => split : core. + Hint Unfold eqk eqke ltk : ordered_type. + Hint Extern 2 (eqke ?a ?b) => split : ordered_type. (* eqke is stricter than eqk *) @@ -283,35 +284,35 @@ Module KeyOrderedType(O:OrderedType). Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. Proof. auto. Qed. - Hint Immediate ltk_right_r ltk_right_l : core. + Hint Immediate ltk_right_r ltk_right_l : ordered_type. (* eqk, eqke are equalities, ltk is a strict order *) Lemma eqk_refl : forall e, eqk e e. - Proof. auto. Qed. + Proof. auto with ordered_type. Qed. Lemma eqke_refl : forall e, eqke e e. - Proof. auto. Qed. + Proof. auto with ordered_type. Qed. Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. - Proof. auto. Qed. + Proof. auto with ordered_type. Qed. Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. Proof. unfold eqke; intuition. Qed. Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. - Proof. eauto. Qed. + Proof. eauto with ordered_type. Qed. Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. Proof. - unfold eqke; intuition; [ eauto | congruence ]. + unfold eqke; intuition; [ eauto with ordered_type | congruence ]. Qed. Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''. - Proof. eauto. Qed. + Proof. eauto with ordered_type. Qed. Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. - Proof. unfold eqk, ltk; auto. Qed. + Proof. unfold eqk, ltk; auto with ordered_type. Qed. Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. Proof. @@ -319,18 +320,18 @@ Module KeyOrderedType(O:OrderedType). exact (lt_not_eq H H1). Qed. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : core. - Hint Immediate eqk_sym eqke_sym : core. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. + Hint Immediate eqk_sym eqke_sym : ordered_type. Global Instance eqk_equiv : Equivalence eqk. - Proof. constructor; eauto. Qed. + Proof. constructor; eauto with ordered_type. Qed. Global Instance eqke_equiv : Equivalence eqke. - Proof. split; eauto. Qed. + Proof. split; eauto with ordered_type. Qed. Global Instance ltk_strorder : StrictOrder ltk. - Proof. constructor; eauto. intros x; apply (irreflexivity (x:=fst x)). Qed. + Proof. constructor; eauto with ordered_type. intros x; apply (irreflexivity (x:=fst x)). Qed. Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. Proof. @@ -348,45 +349,45 @@ Module KeyOrderedType(O:OrderedType). Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. Proof. - unfold eqk, ltk; simpl; auto. + unfold eqk, ltk; simpl; auto with ordered_type. Qed. Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. - Proof. eauto. Qed. + Proof. eauto with ordered_type. Qed. Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''. Proof. intros (k,e) (k',e') (k'',e''). - unfold ltk, eqk; simpl; eauto. + unfold ltk, eqk; simpl; eauto with ordered_type. Qed. - Hint Resolve eqk_not_ltk : core. - Hint Immediate ltk_eqk eqk_ltk : core. + Hint Resolve eqk_not_ltk : ordered_type. + Hint Immediate ltk_eqk eqk_ltk : ordered_type. Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. Proof. unfold eqke; induction 1; intuition. Qed. - Hint Resolve InA_eqke_eqk : core. + Hint Resolve InA_eqke_eqk : ordered_type. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). Definition In k m := exists e:elt, MapsTo k e m. Notation Sort := (sort ltk). Notation Inf := (lelistA ltk). - Hint Unfold MapsTo In : core. + Hint Unfold MapsTo In : ordered_type. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. - Proof. + Proof with auto with ordered_type. firstorder. - exists x; auto. + exists x... induction H. - destruct y. - exists e; auto. + destruct y. + exists e... destruct IHInA as [e H0]. - exists e; auto. + exists e... Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. @@ -405,8 +406,8 @@ Module KeyOrderedType(O:OrderedType). Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. Proof. exact (InfA_ltA ltk_strorder). Qed. - Hint Immediate Inf_eq : core. - Hint Resolve Inf_lt : core. + Hint Immediate Inf_eq : ordered_type. + Hint Resolve Inf_lt : ordered_type. Lemma Sort_Inf_In : forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. @@ -420,8 +421,8 @@ Module KeyOrderedType(O:OrderedType). intros; red; intros. destruct H1 as [e' H2]. elim (@ltk_not_eqk (k,e) (k,e')). - eapply Sort_Inf_In; eauto. - red; simpl; auto. + eapply Sort_Inf_In; eauto with ordered_type. + red; simpl; auto with ordered_type. Qed. Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. @@ -437,7 +438,7 @@ Module KeyOrderedType(O:OrderedType). Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> ltk e e' \/ eqk e e'. Proof. - inversion_clear 2; auto. + inversion_clear 2; auto with ordered_type. left; apply Sort_In_cons_1 with l; auto. Qed. @@ -451,7 +452,7 @@ Module KeyOrderedType(O:OrderedType). Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. inversion 1. - inversion_clear H0; eauto. + inversion_clear H0; eauto with ordered_type. destruct H1; simpl in *; intuition. Qed. @@ -469,19 +470,19 @@ Module KeyOrderedType(O:OrderedType). End Elt. - Hint Unfold eqk eqke ltk : core. - Hint Extern 2 (eqke ?a ?b) => split : core. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : core. - Hint Immediate eqk_sym eqke_sym : core. - Hint Resolve eqk_not_ltk : core. - Hint Immediate ltk_eqk eqk_ltk : core. - Hint Resolve InA_eqke_eqk : core. - Hint Unfold MapsTo In : core. - Hint Immediate Inf_eq : core. - Hint Resolve Inf_lt : core. - Hint Resolve Sort_Inf_NotIn : core. - Hint Resolve In_inv_2 In_inv_3 : core. + Hint Unfold eqk eqke ltk : ordered_type. + Hint Extern 2 (eqke ?a ?b) => split : ordered_type. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. + Hint Immediate eqk_sym eqke_sym : ordered_type. + Hint Resolve eqk_not_ltk : ordered_type. + Hint Immediate ltk_eqk eqk_ltk : ordered_type. + Hint Resolve InA_eqke_eqk : ordered_type. + Hint Unfold MapsTo In : ordered_type. + Hint Immediate Inf_eq : ordered_type. + Hint Resolve Inf_lt : ordered_type. + Hint Resolve Sort_Inf_NotIn : ordered_type. + Hint Resolve In_inv_2 In_inv_3 : ordered_type. End KeyOrderedType. diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v index 9b99fa5de4..a8e6993a63 100644 --- a/theories/Structures/OrderedTypeEx.v +++ b/theories/Structures/OrderedTypeEx.v @@ -178,7 +178,7 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. Lemma eq_refl : forall x : t, eq x x. Proof. - intros (x1,x2); red; simpl; auto. + intros (x1,x2); red; simpl; auto with ordered_type. Qed. Lemma eq_sym : forall x y : t, eq x y -> eq y x. @@ -188,16 +188,16 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. + intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto with ordered_type. Qed. Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. Proof. intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition. - left; eauto. + left; eauto with ordered_type. left; eapply MO1.lt_eq; eauto. left; eapply MO1.eq_lt; eauto. - right; split; eauto. + right; split; eauto with ordered_type. Qed. Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. @@ -214,7 +214,7 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. destruct (O2.compare x2 y2). apply LT; unfold lt; auto. apply EQ; unfold eq; auto. - apply GT; unfold lt; auto. + apply GT; unfold lt; auto with ordered_type. apply GT; unfold lt; auto. Defined. diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index 7658ad68a5..642dc94ab2 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -54,7 +54,10 @@ let coqc_main copts ~opts = if opts.Coqargs.post.Coqargs.output_context then begin let sigma, env = let e = Global.env () in Evd.from_env e, e in let library_accessor = Library.indirect_accessor in - Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context ~library_accessor env) sigma) ++ fnl ()) + let mod_ops = { Printmod.import_module = Declaremods.import_module + ; process_module_binding = Declaremods.process_module_binding + } in + Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context ~mod_ops ~library_accessor env) sigma) ++ fnl ()) end; CProfile.print_profile () diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v index 34299f3cf9..1e330b06d7 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -16,6 +16,10 @@ Ltac2 @ external type : constr -> constr := "ltac2" "constr_type". Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". (** Strict syntactic equality: only up to α-conversion and evar expansion *) +Ltac2 Type relevance := [ Relevant | Irrelevant ]. + +Ltac2 Type 'a binder_annot := { binder_name : 'a; binder_relevance : relevance }. + Module Unsafe. (** Low-level access to kernel terms. Use with care! *) @@ -29,16 +33,16 @@ Ltac2 Type kind := [ | Evar (evar, constr array) | Sort (sort) | Cast (constr, cast, constr) -| Prod (ident option, constr, constr) -| Lambda (ident option, constr, constr) -| LetIn (ident option, constr, constr, constr) +| Prod (ident option binder_annot, constr, constr) +| Lambda (ident option binder_annot, constr, constr) +| LetIn (ident option binder_annot, constr, constr, constr) | App (constr, constr array) | Constant (constant, instance) | Ind (inductive, instance) | Constructor (constructor, instance) | Case (case, constr, constr, constr array) -| Fix (int array, int, ident option array, constr array, constr array) -| CoFix (int, ident option array, constr array, constr array) +| Fix (int array, int, ident option binder_annot array, constr array, constr array) +| CoFix (int, ident option binder_annot array, constr array, constr array) | Proj (projection, constr) | Uint63 (uint63) ]. diff --git a/vernac/classes.ml b/vernac/classes.ml index d5f5656e1d..0a8c4e6b0f 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -371,10 +371,9 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids t the refinement manually.*) let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in - let scope = DeclareDef.Global Declare.ImportDefaultBehavior in let kind = Decls.(IsDefinition Instance) in let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global imps ?hook dref)) in - let info = Lemmas.Info.make ~hook ~scope ~kind () in + let info = Lemmas.Info.make ~hook ~kind () in let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info sigma (EConstr.of_constr termtype) in (* spiwack: I don't know what to do with the status here. *) let lemma = diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 3497e6369f..0e17f2b274 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -44,41 +44,68 @@ let mkSubset sigma name typ prop = let make_qref s = qualid_of_string s let lt_ref = make_qref "Init.Peano.lt" +type family = SPropF | PropF | TypeF +let family_of_sort_family = let open Sorts in function + | InSProp -> SPropF + | InProp -> PropF + | InSet | InType -> TypeF + +let get_sigmatypes sigma ~sort ~predsort = + let open EConstr in + let which, sigsort = match predsort, sort with + | SPropF, _ | _, SPropF -> + user_err Pp.(str "SProp arguments not supported by Program Fixpoint yet.") + | PropF, PropF -> "ex", PropF + | PropF, TypeF -> "sig", TypeF + | TypeF, (PropF|TypeF) -> "sigT", TypeF + in + let sigma, ty = Evarutil.new_global sigma (lib_ref ("core."^which^".type")) in + let uinstance = snd (destRef sigma ty) in + let intro = mkRef (lib_ref ("core."^which^".intro"), uinstance) in + let p1 = mkRef (lib_ref ("core."^which^".proj1"), uinstance) in + let p2 = mkRef (lib_ref ("core."^which^".proj2"), uinstance) in + sigma, ty, intro, p1, p2, sigsort + let rec telescope sigma l = let open EConstr in let open Vars in match l with | [] -> assert false - | [LocalAssum (n, t)] -> + | [LocalAssum (n, t), _] -> sigma, t, [LocalDef (n, mkRel 1, t)], mkRel 1 - | LocalAssum (n, t) :: tl -> - let sigma, ty, tys, (k, constr) = + | (LocalAssum (n, t), tsort) :: tl -> + let sigma, ty, _tysort, tys, (k, constr) = List.fold_left - (fun (sigma, ty, tys, (k, constr)) decl -> + (fun (sigma, ty, tysort, tys, (k, constr)) (decl,sort) -> let t = RelDecl.get_type decl in let pred = mkLambda (RelDecl.get_annot decl, t, ty) in - let sigma, ty = Evarutil.new_global sigma (lib_ref "core.sigT.type") in - let sigma, intro = Evarutil.new_global sigma (lib_ref "core.sigT.intro") in + let sigma, ty, intro, p1, p2, sigsort = get_sigmatypes sigma ~predsort:tysort ~sort in let sigty = mkApp (ty, [|t; pred|]) in let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in - (sigma, sigty, pred :: tys, (succ k, intro))) - (sigma, t, [], (2, mkRel 1)) tl + (sigma, sigty, sigsort, (pred, p1, p2) :: tys, (succ k, intro))) + (sigma, t, tsort, [], (2, mkRel 1)) tl in let sigma, last, subst = List.fold_right2 - (fun pred decl (sigma, prev, subst) -> + (fun (pred,p1,p2) (decl,_) (sigma, prev, subst) -> let t = RelDecl.get_type decl in - let sigma, p1 = Evarutil.new_global sigma (lib_ref "core.sigT.proj1") in - let sigma, p2 = Evarutil.new_global sigma (lib_ref "core.sigT.proj2") in let proj1 = applist (p1, [t; pred; prev]) in let proj2 = applist (p2, [t; pred; prev]) in (sigma, lift 1 proj2, LocalDef (get_annot decl, proj1, t) :: subst)) (List.rev tys) tl (sigma, mkRel 1, []) in sigma, ty, (LocalDef (n, last, t) :: subst), constr - | LocalDef (n, b, t) :: tl -> + | (LocalDef (n, b, t), _) :: tl -> let sigma, ty, subst, term = telescope sigma tl in sigma, ty, (LocalDef (n, b, t) :: subst), lift 1 term +let telescope env sigma l = + let l, _ = List.fold_right_map (fun d env -> + let s = Retyping.get_sort_family_of env sigma (RelDecl.get_type d) in + let env = EConstr.push_rel d env in + (d, family_of_sort_family s), env) l env + in + telescope sigma l + let nf_evar_context sigma ctx = List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx @@ -94,7 +121,7 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let top_env = push_rel_context binders_rel env in let sigma, top_arity = interp_type_evars ~program_mode:true top_env sigma arityc in let full_arity = it_mkProd_or_LetIn top_arity binders_rel in - let sigma, argtyp, letbinders, make = telescope sigma binders_rel in + let sigma, argtyp, letbinders, make = telescope env sigma binders_rel in let argname = Id.of_string "recarg" in let arg = LocalAssum (make_annot (Name argname) Sorts.Relevant, argtyp) in let binders = letbinders @ [arg] in diff --git a/library/declaremods.ml b/vernac/declaremods.ml index b4dc42bdfe..58a7dff5fd 100644 --- a/library/declaremods.ml +++ b/vernac/declaremods.ml @@ -35,8 +35,6 @@ type inline = | DefaultInline | InlineAt of int -type module_kind = Module | ModType | ModAny - let default_inline () = Some (Flags.get_inline_level ()) let inl2intopt = function @@ -457,15 +455,15 @@ let rec compute_subst env mbids sign mp_l inl = | _,[] -> mbids,empty_subst | [],r -> user_err Pp.(str "Application of a functor with too few arguments.") | mbid::mbids,mp::mp_l -> - let farg_id, farg_b, fbody_b = Modops.destr_functor sign in - let mb = Environ.lookup_module mp env in - let mbid_left,subst = compute_subst env mbids fbody_b mp_l inl in - let resolver = + let farg_id, farg_b, fbody_b = Modops.destr_functor sign in + let mb = Environ.lookup_module mp env in + let mbid_left,subst = compute_subst env mbids fbody_b mp_l inl in + let resolver = if Modops.is_functor mb.mod_type then empty_delta_resolver else Modops.inline_delta_resolver env inl mp farg_id farg_b mb.mod_delta - in - mbid_left,join (map_mbid mbid mp resolver) subst + in + mbid_left,join (map_mbid mbid mp resolver) subst (** Create the objects of a "with Module" structure. *) @@ -547,11 +545,11 @@ let process_module_binding mbid me = Objects in these parameters are also loaded. Output is accumulated on top of [acc] (in reverse order). *) -let intern_arg interp_modast (acc, cst) (idl,(typ,ann)) = +let intern_arg (acc, cst) (idl,(typ,ann)) = let inl = inl2intopt ann in let lib_dir = Lib.library_dp() in let env = Global.env() in - let (mty, _, cst') = interp_modast env ModType typ in + let (mty, _, cst') = Modintern.interp_module_ast env Modintern.ModType typ in let () = Global.push_context_set true cst' in let env = Global.env () in let sobjs = get_module_sobjs false env inl mty in @@ -579,8 +577,8 @@ let intern_arg interp_modast (acc, cst) (idl,(typ,ann)) = be more efficient and independent of [List.map] eval order. *) -let intern_args interp_modast params = - List.fold_left (intern_arg interp_modast) ([], Univ.ContextSet.empty) params +let intern_args params = + List.fold_left intern_arg ([], Univ.ContextSet.empty) params (** {6 Auxiliary functions concerning subtyping checks} *) @@ -588,10 +586,10 @@ let intern_args interp_modast params = let check_sub mtb sub_mtb_l = (* The constraints are checked and forgot immediately : *) ignore (List.fold_right - (fun sub_mtb env -> - Environ.add_constraints - (Subtyping.check_subtypes env mtb sub_mtb) env) - sub_mtb_l (Global.env())) + (fun sub_mtb env -> + Environ.add_constraints + (Subtyping.check_subtypes env mtb sub_mtb) env) + sub_mtb_l (Global.env())) (** This function checks if the type calculated for the module [mp] is a subtype of all signatures in [sub_mtb_l]. Uses only the global @@ -631,11 +629,11 @@ let mk_funct_type env args seb0 = (** Prepare the module type list for check of subtypes *) -let build_subtypes interp_modast env mp args mtys = +let build_subtypes env mp args mtys = let (cst, ans) = List.fold_left_map (fun cst (m,ann) -> let inl = inl2intopt ann in - let mte, _, cst' = interp_modast env ModType m in + let mte, _, cst' = Modintern.interp_module_ast env Modintern.ModType m in let env = Environ.push_context_set ~strict:true cst' env in let cst = Univ.ContextSet.union cst cst' in let mtb = Mod_typing.translate_modtype env mp inl ([],mte) in @@ -673,22 +671,22 @@ let openmodtype_info = module RawModOps = struct -let start_module interp_modast export id args res fs = +let start_module export id args res fs = let mp = Global.start_module id in - let arg_entries_r, cst = intern_args interp_modast args in + let arg_entries_r, cst = intern_args args in let () = Global.push_context_set true cst in let env = Global.env () in let res_entry_o, subtyps, cst = match res with | Enforce (res,ann) -> let inl = inl2intopt ann in - let (mte, _, cst) = interp_modast env ModType res in + let (mte, _, cst) = Modintern.interp_module_ast env Modintern.ModType res in let env = Environ.push_context_set ~strict:true cst env in (* We check immediately that mte is well-formed *) let _, _, _, cst' = Mod_typing.translate_mse env None inl mte in let cst = Univ.ContextSet.union cst cst' in Some (mte, inl), [], cst | Check resl -> - let typs, cst = build_subtypes interp_modast env mp arg_entries_r resl in + let typs, cst = build_subtypes env mp arg_entries_r resl in None, typs, cst in let () = Global.push_context_set true cst in @@ -735,25 +733,25 @@ let end_module () = mp -let declare_module interp_modast id args res mexpr_o fs = +let declare_module id args res mexpr_o fs = (* We simulate the beginning of an interactive module, then we adds the module parameters to the global env. *) let mp = Global.start_module id in - let arg_entries_r, cst = intern_args interp_modast args in + let arg_entries_r, cst = intern_args args in let params = mk_params_entry arg_entries_r in let env = Global.env () in let env = Environ.push_context_set ~strict:true cst env in let mty_entry_o, subs, inl_res, cst' = match res with | Enforce (mty,ann) -> let inl = inl2intopt ann in - let (mte, _, cst) = interp_modast env ModType mty in + let (mte, _, cst) = Modintern.interp_module_ast env Modintern.ModType mty in let env = Environ.push_context_set ~strict:true cst env in (* We check immediately that mte is well-formed *) let _, _, _, cst' = Mod_typing.translate_mse env None inl mte in let cst = Univ.ContextSet.union cst cst' in Some mte, [], inl, cst | Check mtys -> - let typs, cst = build_subtypes interp_modast env mp arg_entries_r mtys in + let typs, cst = build_subtypes env mp arg_entries_r mtys in None, typs, default_inline (), cst in let env = Environ.push_context_set ~strict:true cst' env in @@ -761,7 +759,7 @@ let declare_module interp_modast id args res mexpr_o fs = let mexpr_entry_o, inl_expr, cst' = match mexpr_o with | None -> None, default_inline (), Univ.ContextSet.empty | Some (mexpr,ann) -> - let (mte, _, cst) = interp_modast env Module mexpr in + let (mte, _, cst) = Modintern.interp_module_ast env Modintern.Module mexpr in Some mte, inl2intopt ann, cst in let env = Environ.push_context_set ~strict:true cst' env in @@ -803,12 +801,12 @@ end module RawModTypeOps = struct -let start_modtype interp_modast id args mtys fs = +let start_modtype id args mtys fs = let mp = Global.start_modtype id in - let arg_entries_r, cst = intern_args interp_modast args in + let arg_entries_r, cst = intern_args args in let () = Global.push_context_set true cst in let env = Global.env () in - let sub_mty_l, cst = build_subtypes interp_modast env mp arg_entries_r mtys in + let sub_mty_l, cst = build_subtypes env mp arg_entries_r mtys in let () = Global.push_context_set true cst in openmodtype_info := sub_mty_l; let prefix = Lib.start_modtype id mp fs in @@ -831,16 +829,16 @@ let end_modtype () = mp -let declare_modtype interp_modast id args mtys (mty,ann) fs = +let declare_modtype id args mtys (mty,ann) fs = let inl = inl2intopt ann in (* We simulate the beginning of an interactive module, then we adds the module parameters to the global env. *) let mp = Global.start_modtype id in - let arg_entries_r, cst = intern_args interp_modast args in + let arg_entries_r, cst = intern_args args in let () = Global.push_context_set true cst in let params = mk_params_entry arg_entries_r in let env = Global.env () in - let mte, _, cst = interp_modast env ModType mty in + let mte, _, cst = Modintern.interp_module_ast env Modintern.ModType mty in let () = Global.push_context_set true cst in let env = Global.env () in (* We check immediately that mte is well-formed *) @@ -848,7 +846,7 @@ let declare_modtype interp_modast id args mtys (mty,ann) fs = let () = Global.push_context_set true cst in let env = Global.env () in let entry = params, mte in - let sub_mty_l, cst = build_subtypes interp_modast env mp arg_entries_r mtys in + let sub_mty_l, cst = build_subtypes env mp arg_entries_r mtys in let () = Global.push_context_set true cst in let env = Global.env () in let sobjs = get_functor_sobjs false env inl entry in @@ -902,12 +900,12 @@ let type_of_incl env is_mod = function decompose_functor mp_l (type_of_mod mp0 env is_mod) |MEwith _ -> raise NoIncludeSelf -let declare_one_include interp_modast (me_ast,annot) = +let declare_one_include (me_ast,annot) = let env = Global.env() in - let me, kind, cst = interp_modast env ModAny me_ast in + let me, kind, cst = Modintern.interp_module_ast env Modintern.ModAny me_ast in let () = Global.push_context_set true cst in let env = Global.env () in - let is_mod = (kind == Module) in + let is_mod = (kind == Modintern.Module) in let cur_mp = Lib.current_mp () in let inl = inl2intopt annot in let mbids,aobjs = get_module_sobjs is_mod env inl me in @@ -925,8 +923,7 @@ let declare_one_include interp_modast (me_ast,annot) = let aobjs = subst_aobjs subst aobjs in ignore (add_leaf (Lib.current_mod_id ()) (IncludeObject aobjs)) -let declare_include interp me_asts = - List.iter (declare_one_include interp) me_asts +let declare_include me_asts = List.iter declare_one_include me_asts end @@ -942,40 +939,40 @@ let protect_summaries f = let () = Summary.unfreeze_summaries fs in iraise reraise -let start_module interp export id args res = - protect_summaries (RawModOps.start_module interp export id args res) +let start_module export id args res = + protect_summaries (RawModOps.start_module export id args res) let end_module = RawModOps.end_module -let declare_module interp id args mtys me_l = +let declare_module id args mtys me_l = let declare_me fs = match me_l with - | [] -> RawModOps.declare_module interp id args mtys None fs - | [me] -> RawModOps.declare_module interp id args mtys (Some me) fs + | [] -> RawModOps.declare_module id args mtys None fs + | [me] -> RawModOps.declare_module id args mtys (Some me) fs | me_l -> - ignore (RawModOps.start_module interp None id args mtys fs); - RawIncludeOps.declare_include interp me_l; - RawModOps.end_module () + ignore (RawModOps.start_module None id args mtys fs); + RawIncludeOps.declare_include me_l; + RawModOps.end_module () in protect_summaries declare_me -let start_modtype interp id args mtys = - protect_summaries (RawModTypeOps.start_modtype interp id args mtys) +let start_modtype id args mtys = + protect_summaries (RawModTypeOps.start_modtype id args mtys) let end_modtype = RawModTypeOps.end_modtype -let declare_modtype interp id args mtys mty_l = +let declare_modtype id args mtys mty_l = let declare_mt fs = match mty_l with | [] -> assert false - | [mty] -> RawModTypeOps.declare_modtype interp id args mtys mty fs + | [mty] -> RawModTypeOps.declare_modtype id args mtys mty fs | mty_l -> - ignore (RawModTypeOps.start_modtype interp id args mtys fs); - RawIncludeOps.declare_include interp mty_l; - RawModTypeOps.end_modtype () + ignore (RawModTypeOps.start_modtype id args mtys fs); + RawIncludeOps.declare_include mty_l; + RawModTypeOps.end_modtype () in protect_summaries declare_mt -let declare_include interp me_asts = - protect_summaries (fun _ -> RawIncludeOps.declare_include interp me_asts) +let declare_include me_asts = + protect_summaries (fun _ -> RawIncludeOps.declare_include me_asts) (** {6 Libraries} *) @@ -1055,12 +1052,7 @@ let iter_all_segments f = (** {6 Some types used to shorten declaremods.mli} *) -type 'modast module_interpretor = - Environ.env -> module_kind -> 'modast -> - Entries.module_struct_entry * module_kind * Univ.ContextSet.t - -type 'modast module_params = - (lident list * ('modast * inline)) list +type module_params = (lident list * (Constrexpr.module_ast * inline)) list (** {6 Debug} *) diff --git a/library/declaremods.mli b/vernac/declaremods.mli index b7c7cd1dba..ae84704656 100644 --- a/library/declaremods.mli +++ b/vernac/declaremods.mli @@ -29,34 +29,24 @@ type inline = (** Kinds of modules *) -type module_kind = Module | ModType | ModAny +type module_params = (lident list * (Constrexpr.module_ast * inline)) list -type 'modast module_interpretor = - Environ.env -> module_kind -> 'modast -> - Entries.module_struct_entry * module_kind * Univ.ContextSet.t - -type 'modast module_params = - (lident list * ('modast * inline)) list - -(** [declare_module interp_modast id fargs typ exprs] - declares module [id], with structure constructed by [interp_modast] - from functor arguments [fargs], with final type [typ]. - [exprs] is usually of length 1 (Module definition with a concrete - body), but it could also be empty ("Declare Module", with non-empty [typ]), - or multiple (body of the shape M <+ N <+ ...). *) +(** [declare_module id fargs typ exprs] declares module [id], from + functor arguments [fargs], with final type [typ]. [exprs] is + usually of length 1 (Module definition with a concrete body), but + it could also be empty ("Declare Module", with non-empty [typ]), or + multiple (body of the shape M <+ N <+ ...). *) val declare_module : - 'modast module_interpretor -> Id.t -> - 'modast module_params -> - ('modast * inline) module_signature -> - ('modast * inline) list -> ModPath.t + module_params -> + (Constrexpr.module_ast * inline) module_signature -> + (Constrexpr.module_ast * inline) list -> ModPath.t val start_module : - 'modast module_interpretor -> bool option -> Id.t -> - 'modast module_params -> - ('modast * inline) module_signature -> ModPath.t + module_params -> + (Constrexpr.module_ast * inline) module_signature -> ModPath.t val end_module : unit -> ModPath.t @@ -68,18 +58,16 @@ val end_module : unit -> ModPath.t Similar to [declare_module], except that the types could be multiple *) val declare_modtype : - 'modast module_interpretor -> Id.t -> - 'modast module_params -> - ('modast * inline) list -> - ('modast * inline) list -> + module_params -> + (Constrexpr.module_ast * inline) list -> + (Constrexpr.module_ast * inline) list -> ModPath.t val start_modtype : - 'modast module_interpretor -> Id.t -> - 'modast module_params -> - ('modast * inline) list -> ModPath.t + module_params -> + (Constrexpr.module_ast * inline) list -> ModPath.t val end_modtype : unit -> ModPath.t @@ -117,8 +105,7 @@ val import_modules : export:bool -> ModPath.t list -> unit (** Include *) -val declare_include : - 'modast module_interpretor -> ('modast * inline) list -> unit +val declare_include : (Constrexpr.module_ast * inline) list -> unit (** {6 ... } *) (** [iter_all_segments] iterate over all segments, the modules' diff --git a/vernac/himsg.ml b/vernac/himsg.ml index ea34b601e8..c335d3ad55 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1079,9 +1079,7 @@ let explain_incorrect_with_in_module () = let explain_incorrect_module_application () = str "Illegal application to a module type." -open Modintern - -let explain_module_internalization_error = function +let explain_module_internalization_error = let open Modintern in function | NotAModuleNorModtype s -> explain_not_module_nor_modtype s | IncorrectWithInModule -> explain_incorrect_with_in_module () | IncorrectModuleApplication -> explain_incorrect_module_application () diff --git a/vernac/obligations.ml b/vernac/obligations.ml index da14b6e979..c8cede1f84 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -397,8 +397,8 @@ let deps_remaining obls deps = deps [] -let goal_kind = DeclareDef.(Global Declare.ImportNeedQualified, Decls.(IsDefinition Definition)) -let goal_proof_kind = DeclareDef.(Global Declare.ImportNeedQualified, Decls.(IsProof Lemma)) +let goal_kind = Decls.(IsDefinition Definition) +let goal_proof_kind = Decls.(IsProof Lemma) let kind_of_obligation o = match o with @@ -487,7 +487,8 @@ let rec solve_obligation prg num tac = ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) remaining)); in let obl = subst_deps_obl obls obl in - let scope, kind = kind_of_obligation (snd obl.obl_status) in + let scope = DeclareDef.(Global Declare.ImportNeedQualified) in + let kind = kind_of_obligation (snd obl.obl_status) in let evd = Evd.from_ctx prg.prg_ctx in let evd = Evd.update_sigma_env evd (Global.env ()) in let auto n oblset tac = auto_solve_obligations n ~oblset tac in diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index cd13f83e96..4868182bb3 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -1,6 +1,7 @@ Vernacexpr Attributes Pvernac +Declaremods G_vernac G_proofs Vernacprop diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 43b58d6d4b..bc47ad8699 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -872,10 +872,7 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = if not (Option.is_empty export) then user_err Pp.(str "Arguments of a functor declaration cannot be exported. Remove the \"Export\" and \"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in - let mp = - Declaremods.declare_module Modintern.interp_module_ast - id binders_ast (Declaremods.Enforce mty_ast) [] - in + let mp = Declaremods.declare_module id binders_ast (Declaremods.Enforce mty_ast) [] in Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is declared"); Option.iter (fun export -> vernac_import export [qualid_of_ident id]) export @@ -892,10 +889,7 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt (fun (export,idl,ty) (args,argsexport) -> (idl,ty)::args, (List.map (fun {v=i} -> export,i)idl)@argsexport) binders_ast ([],[]) in - let mp = - Declaremods.start_module Modintern.interp_module_ast - export id binders_ast mty_ast_o - in + let mp = Declaremods.start_module export id binders_ast mty_ast_o in Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Interactive Module " ++ Id.print id ++ str " started"); @@ -911,7 +905,7 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt user_err Pp.(str "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in let mp = - Declaremods.declare_module Modintern.interp_module_ast + Declaremods.declare_module id binders_ast mty_ast_o mexpr_ast_l in Dumpglob.dump_moddef ?loc mp "mod"; @@ -938,10 +932,7 @@ let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = (idl,ty)::args, (List.map (fun {v=i} -> export,i)idl)@argsexport) binders_ast ([],[]) in - let mp = - Declaremods.start_modtype Modintern.interp_module_ast - id binders_ast mty_sign - in + let mp = Declaremods.start_modtype id binders_ast mty_sign in Dumpglob.dump_moddef ?loc mp "modtype"; Flags.if_verbose Feedback.msg_info (str "Interactive Module Type " ++ Id.print id ++ str " started"); @@ -957,10 +948,7 @@ let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = if not (Option.is_empty export) then user_err Pp.(str "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in - let mp = - Declaremods.declare_modtype Modintern.interp_module_ast - id binders_ast mty_sign mty_ast_l - in + let mp = Declaremods.declare_modtype id binders_ast mty_sign mty_ast_l in Dumpglob.dump_moddef ?loc mp "modtype"; Flags.if_verbose Feedback.msg_info (str "Module Type " ++ Id.print id ++ str " is defined") @@ -970,8 +958,7 @@ let vernac_end_modtype {loc;v=id} = Dumpglob.dump_modref ?loc mp "modtype"; Flags.if_verbose Feedback.msg_info (str "Module Type " ++ Id.print id ++ str " is defined") -let vernac_include l = - Declaremods.declare_include Modintern.interp_module_ast l +let vernac_include l = Declaremods.declare_include l (**********************) (* Gallina extensions *) @@ -980,7 +967,9 @@ let vernac_include l = let vernac_begin_section ~poly ({v=id} as lid) = Dumpglob.dump_definition lid true "sec"; - Lib.open_section ~poly id; + Lib.open_section id; + (* If there was no polymorphism attribute this just sets the option + to its current value ie noop. *) set_bool_option_value_gen ~locality:OptLocal ["Universe"; "Polymorphism"] poly let vernac_end_section {CAst.loc} = @@ -1966,26 +1955,29 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = print_about env sigma ref_or_by_not udecl let vernac_print ~pstate ~atts = + let mod_ops = { Printmod.import_module = Declaremods.import_module + ; process_module_binding = Declaremods.process_module_binding + } in let sigma, env = get_current_or_global_context ~pstate in function | PrintTypingFlags -> pr_typing_flags (Environ.typing_flags (Global.env ())) | PrintTables -> print_tables () - | PrintFullContext-> print_full_context_typ Library.indirect_accessor env sigma - | PrintSectionContext qid -> print_sec_context_typ Library.indirect_accessor env sigma qid - | PrintInspect n -> inspect Library.indirect_accessor env sigma n + | PrintFullContext-> print_full_context_typ ~mod_ops Library.indirect_accessor env sigma + | PrintSectionContext qid -> print_sec_context_typ ~mod_ops Library.indirect_accessor env sigma qid + | PrintInspect n -> inspect ~mod_ops Library.indirect_accessor env sigma n | PrintGrammar ent -> Metasyntax.pr_grammar ent | PrintCustomGrammar ent -> Metasyntax.pr_custom_grammar ent | PrintLoadPath dir -> (* For compatibility ? *) print_loadpath dir | PrintModules -> print_modules () - | PrintModule qid -> print_module qid - | PrintModuleType qid -> print_modtype qid + | PrintModule qid -> print_module ~mod_ops qid + | PrintModuleType qid -> print_modtype ~mod_ops qid | PrintNamespace ns -> print_namespace ~pstate ns | PrintMLLoadPath -> Mltop.print_ml_path () | PrintMLModules -> Mltop.print_ml_modules () | PrintDebugGC -> Mltop.print_gc () | PrintName (qid,udecl) -> dump_global qid; - print_name Library.indirect_accessor env sigma qid udecl + print_name ~mod_ops Library.indirect_accessor env sigma qid udecl | PrintGraph -> Prettyp.print_graph () | PrintClasses -> Prettyp.print_classes() | PrintTypeClasses -> Prettyp.print_typeclasses() |