diff options
142 files changed, 3420 insertions, 4673 deletions
diff --git a/META.coq.in b/META.coq.in index 0baacbc82e..9869e7f575 100644 --- a/META.coq.in +++ b/META.coq.in @@ -288,6 +288,8 @@ package "plugins" ( archive(byte) = "ltac_plugin.cmo" archive(native) = "ltac_plugin.cmx" + plugin(byte) = "ltac_plugin.cmo" + plugin(native) = "ltac_plugin.cmxs" ) package "tauto" ( @@ -300,6 +302,9 @@ package "plugins" ( archive(byte) = "tauto_plugin.cmo" archive(native) = "tauto_plugin.cmx" + + plugin(byte) = "tauto_plugin.cmo" + plugin(native) = "tauto_plugin.cmxs" ) package "omega" ( @@ -312,6 +317,9 @@ package "plugins" ( archive(byte) = "omega_plugin.cmo" archive(native) = "omega_plugin.cmx" + + plugin(byte) = "omega_plugin.cmo" + plugin(native) = "omega_plugin.cmxs" ) package "micromega" ( @@ -324,6 +332,24 @@ package "plugins" ( archive(byte) = "micromega_plugin.cmo" archive(native) = "micromega_plugin.cmx" + + plugin(byte) = "micromega_plugin.cmo" + plugin(native) = "micromega_plugin.cmxs" + ) + + package "zify" ( + + description = "Coq Zify plugin" + version = "8.11" + + requires = "coq.plugins.ltac" + directory = "micromega" + + archive(byte) = "zify_plugin.cmo" + archive(native) = "zify_plugin.cmx" + + plugin(byte) = "zify_plugin.cmo" + plugin(native) = "zify_plugin.cmxs" ) package "setoid_ring" ( @@ -336,6 +362,9 @@ package "plugins" ( archive(byte) = "newring_plugin.cmo" archive(native) = "newring_plugin.cmx" + + plugin(byte) = "newring_plugin.cmo" + plugin(native) = "newring_plugin.cmxs" ) package "extraction" ( @@ -348,6 +377,9 @@ package "plugins" ( archive(byte) = "extraction_plugin.cmo" archive(native) = "extraction_plugin.cmx" + + plugin(byte) = "extraction_plugin.cmo" + plugin(native) = "extraction_plugin.cmxs" ) package "cc" ( @@ -360,6 +392,9 @@ package "plugins" ( archive(byte) = "cc_plugin.cmo" archive(native) = "cc_plugin.cmx" + + plugin(byte) = "cc_plugin.cmo" + plugin(native) = "cc_plugin.cmxs" ) package "firstorder" ( @@ -372,6 +407,9 @@ package "plugins" ( archive(byte) = "ground_plugin.cmo" archive(native) = "ground_plugin.cmx" + + plugin(byte) = "ground_plugin.cmo" + plugin(native) = "ground_plugin.cmxs" ) package "rtauto" ( @@ -384,6 +422,9 @@ package "plugins" ( archive(byte) = "rtauto_plugin.cmo" archive(native) = "rtauto_plugin.cmx" + + plugin(byte) = "rtauto_plugin.cmo" + plugin(native) = "rtauto_plugin.cmxs" ) package "btauto" ( @@ -396,6 +437,9 @@ package "plugins" ( archive(byte) = "btauto_plugin.cmo" archive(native) = "btauto_plugin.cmx" + + plugin(byte) = "btauto_plugin.cmo" + plugin(native) = "btauto_plugin.cmxs" ) package "funind" ( @@ -408,6 +452,9 @@ package "plugins" ( archive(byte) = "recdef_plugin.cmo" archive(native) = "recdef_plugin.cmx" + + plugin(byte) = "recdef_plugin.cmo" + plugin(native) = "recdef_plugin.cmxs" ) package "nsatz" ( @@ -420,6 +467,9 @@ package "plugins" ( archive(byte) = "nsatz_plugin.cmo" archive(native) = "nsatz_plugin.cmx" + + plugin(byte) = "nsatz_plugin.cmo" + plugin(native) = "nsatz_plugin.cmxs" ) package "rsyntax" ( @@ -432,6 +482,9 @@ package "plugins" ( archive(byte) = "r_syntax_plugin.cmo" archive(native) = "r_syntax_plugin.cmx" + + plugin(byte) = "r_syntax_plugin.cmo" + plugin(native) = "r_syntax_plugin.cmxs" ) package "int63syntax" ( @@ -444,6 +497,9 @@ package "plugins" ( archive(byte) = "int63_syntax_plugin.cmo" archive(native) = "int63_syntax_plugin.cmx" + + plugin(byte) = "int63_syntax_plugin.cmo" + plugin(native) = "int63_syntax_plugin.cmxs" ) package "string_notation" ( @@ -456,6 +512,9 @@ package "plugins" ( archive(byte) = "string_notation_plugin.cmo" archive(native) = "string_notation_plugin.cmx" + + plugin(byte) = "string_notation_plugin.cmo" + plugin(native) = "string_notation_plugin.cmxs" ) package "derive" ( @@ -468,6 +527,9 @@ package "plugins" ( archive(byte) = "derive_plugin.cmo" archive(native) = "derive_plugin.cmx" + + plugin(byte) = "derive_plugin.cmo" + plugin(native) = "derive_plugin.cmxs" ) package "ssrmatching" ( @@ -480,6 +542,9 @@ package "plugins" ( archive(byte) = "ssrmatching_plugin.cmo" archive(native) = "ssrmatching_plugin.cmx" + + plugin(byte) = "ssrmatching_plugin.cmo" + plugin(native) = "ssrmatching_plugin.cmxs" ) package "ssreflect" ( @@ -492,5 +557,8 @@ package "plugins" ( archive(byte) = "ssreflect_plugin.cmo" archive(native) = "ssreflect_plugin.cmx" + + plugin(byte) = "ssreflect_plugin.cmo" + plugin(native) = "ssreflect_plugin.cmxs" ) ) diff --git a/Makefile.build b/Makefile.build index 35f5e26272..ed4cde2b16 100644 --- a/Makefile.build +++ b/Makefile.build @@ -81,7 +81,7 @@ coq.timing.diff: coqlib.timing.diff # shouldn't be done in a same make -j... run, otherwise both ocamlc and # ocamlopt might race for access to the same .cmi files. -byte: coqbyte coqide-byte pluginsbyte printers +byte: coqbyte coqide-byte pluginsbyte printers bin/votour.byte .PHONY: world coq byte world.timing.diff coq.timing.diff diff --git a/Makefile.common b/Makefile.common index 2d1200c071..1ad255d156 100644 --- a/Makefile.common +++ b/Makefile.common @@ -41,9 +41,10 @@ COQMAKE_ONE_TIME_FILE:=tools/make-one-time-file.py COQTIME_FILE_MAKER:=tools/TimeFileMaker.py COQMAKE_BOTH_TIME_FILES:=tools/make-both-time-files.py COQMAKE_BOTH_SINGLE_TIMING_FILES:=tools/make-both-single-timing-files.py +VOTOUR:=bin/votour TOOLS:=$(COQDEP) $(COQMAKEFILE) $(COQTEX) $(COQWC) $(COQDOC) $(COQC)\ - $(COQWORKMGR) $(COQPP) $(DOC_GRAM) + $(COQWORKMGR) $(COQPP) $(DOC_GRAM) $(VOTOUR) TOOLS_HELPERS:=tools/CoqMakefile.in $(COQMAKE_ONE_TIME_FILE) $(COQTIME_FILE_MAKER)\ $(COQMAKE_BOTH_TIME_FILES) $(COQMAKE_BOTH_SINGLE_TIMING_FILES) diff --git a/checker/votour.ml b/checker/votour.ml index 5a610e6938..97584831e5 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -364,7 +364,6 @@ let visit_vo f = make_seg "summary" Values.v_libsum; make_seg "library" Values.v_lib; make_seg "univ constraints of opaque proofs" Values.v_univopaques; - make_seg "discharging info" (Opt Any); make_seg "STM tasks" (Opt Values.v_stm_seg); make_seg "opaque proofs" Values.v_opaquetable; |] in diff --git a/configure.ml b/configure.ml index e59a41a8d4..8e04dc46b2 100644 --- a/configure.ml +++ b/configure.ml @@ -20,7 +20,7 @@ let state_magic = 581091 let is_a_released_version = false let distributed_exec = ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; - "coqc.opt";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep"] + "coqc.opt";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep";"votour"] let verbose = ref false (* for debugging this script *) diff --git a/dev/README.md b/dev/README.md index 4cda60a703..0c6b8020f1 100644 --- a/dev/README.md +++ b/dev/README.md @@ -28,7 +28,7 @@ | [`dev/doc/econstr.md`](doc/econstr.md) | Describes `Econstr`, implementation of treatment of `evar` in the engine | | [`dev/doc/primproj.md`](doc/primproj.md) | Describes primitive projections | | [`dev/doc/proof-engine.md`](doc/proof-engine.md) | Tutorial on new proof engine | -| [`dev/doc/xml-protocol.md`](doc/proof-engine.md) | XML protocol that coqtop and IDEs use to communicate | +| [`dev/doc/xml-protocol.md`](doc/xml-protocol.md) | XML protocol that coqtop and IDEs use to communicate | | [`dev/doc/MERGING.md`](doc/MERGING.md) | How pull requests should be merged into `master` | | [`dev/doc/release-process.md`](doc/release-process.md) | Process of creating a new Coq release | diff --git a/dev/ci/user-overlays/10516-ejgallego-proof+dup_save.sh b/dev/ci/user-overlays/10516-ejgallego-proof+dup_save.sh new file mode 100644 index 0000000000..7001c3d0c8 --- /dev/null +++ b/dev/ci/user-overlays/10516-ejgallego-proof+dup_save.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10516" ] || [ "$CI_BRANCH" = "proof+dup_save" ]; then + + elpi_CI_REF=proof+dup_save + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + +fi diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 78d7061259..6d90ced12d 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -250,6 +250,17 @@ Conversion machines exploit: test-suite/bugs/closed/bug_9684.v GH issue number: #9684 + component: lazy machine + summary: incorrect De Bruijn handling when inferring the relevance mark for a lambda + introduced: 2019-03-15, 23f84f37c674a07e925925b7e0d50d7ee8414093 and 71b9ad8526155020c8451dd326a52e391a9a8585, SkySkimmer + impacted released versions: 8.10.0 + impacted coqchk versions: 8.10.0 + found by: ppedrot investigating unexpected conversion failures with SProp + exploit: test-suite/bugs/closed/bug_10904.v + GH issue number: #10904 + risk: none without using -allow-sprop (off by default in 8.10.0), + otherwise could be exploited by mistake + Conflicts with axioms in library component: library of real numbers diff --git a/dev/doc/xml-protocol.md b/dev/doc/xml-protocol.md index a3e1a4e90b..0fc0a413ba 100644 --- a/dev/doc/xml-protocol.md +++ b/dev/doc/xml-protocol.md @@ -9,7 +9,7 @@ with Coq 8.5, and is used by CoqIDE. It will also be used in upcoming versions of Proof General. A somewhat out-of-date description of the async state machine is -[documented here](https://github.com/ejgallego/jscoq/blob/master/etc/notes/coq-notes.md). +[documented here](https://github.com/ejgallego/jscoq/blob/v8.10/etc/notes/coq-notes.md). OCaml types for the protocol can be found in the [`ide/protocol/interface.ml` file](/ide/protocol/interface.ml). Changes to the XML protocol are documented as part of [`dev/doc/changes.md`](/dev/doc/changes.md). @@ -45,6 +45,7 @@ Changes to the XML protocol are documented as part of [`dev/doc/changes.md`](/de - [File Loaded](#feedback-fileloaded) - [Message](#feedback-message) - [Custom](#feedback-custom) +* [Highlighting Text](#highlighting) Sentences: each command sent to Coqtop is a "sentence"; they are typically terminated by ".\s" (followed by whitespace or EOF). Examples: "Lemma a: True.", "(* asdf *) Qed.", "auto; reflexivity." @@ -753,3 +754,43 @@ Ex: `status = "Idle"` or `status = "proof: myLemmaName"` or `status = "Dead"` </feedback> ``` +## <a name="highlighting">Highlighting Text</a> + +[Proof diffs](https://coq.inria.fr/distrib/current/refman/proof-engine/proof-handling.html#showing-differences-between-proof-steps) +highlight differences between the current and previous proof states in the displayed output. +These are represented by tags embedded in output fields of the XML document. + +There are 4 tags that indicate how the enclosed text should be highlighted: +- diff.added - added text +- diff.removed - removed text +- diff.added.bg - unchanged text in a line that has additions ("bg" for "background") +- diff.removed.bg - unchanged text in a line that has removals + +CoqIDE, Proof General and coqtop currently use 2 shades of green and 2 shades of red +as the background color for highlights. Coqtop and CoqIDE also apply underlining and/or +strikeout highlighting for the sake of the color blind. + +For example, `<diff.added>ABC</diff.added>` indicates that "ABC" should be highlighted +as added text. Tags can be nested, such as: +`<diff.added.bg>A <diff.added> + 1</diff.added> + B</diff.added.bg>`. IDE code +displaying highlighted strings should maintain a stack for nested tags and the associated +highlight. Currently the diff code only nests at most 2 tags deep. +If an IDE uses other highlights such as text foreground color or italic text, it may +need to merge the background color with those other highlights to give the desired +(IDE dependent) behavior. + +The current implementations avoid highlighting white space at the beginning or the +end of a line. This gives a better appearance. + +There may be additional text that is marked with other tags in the output text. IDEs probably +should ignore and not display tags they don't recognize. + +Some internal details about generating tags within Coq (e.g. if you want to add +additional tags): + +Tagged output strings are generated from Pp.t's. Use Pp.tag to highlight a Pp.t using +one of the tags listed above. A span of tokens can be marked by using "start.<tag>" on +the first token and "end.<tag>" on the last token. (Span markers are needed because a span of +tokens in the output may not match nesting of layout boxes in the Pp.t.) +The conversion from the Pp.t to the XML-tagged string replaces the "start.\*" and "end.\*" +tags with the basic tags. diff --git a/doc/changelog/03-notations/10963-simplify-parser.rst b/doc/changelog/03-notations/10963-simplify-parser.rst new file mode 100644 index 0000000000..327a39bdb6 --- /dev/null +++ b/doc/changelog/03-notations/10963-simplify-parser.rst @@ -0,0 +1,6 @@ +- A simplification of parsing rules could cause a slight change of + parsing precedences for the very rare users who defined notations + with `constr` at level strictly between 100 and 200 and used these + notations on the right-hand side of a cast operator (`:`, `:>`, + `:>>`) (`#10963 <https://github.com/coq/coq/pull/10963>`_, by Théo + Zimmermann, simplification initially noticed by Jim Fehrle). diff --git a/doc/changelog/06-ssreflect/10932-void-type-ssr.rst b/doc/changelog/06-ssreflect/10932-void-type-ssr.rst new file mode 100644 index 0000000000..7366ef1190 --- /dev/null +++ b/doc/changelog/06-ssreflect/10932-void-type-ssr.rst @@ -0,0 +1,3 @@ +- Add a :g:`void` notation for the standard library empty type (:g:`Empty_set`) + (`#10932 <https://github.com/coq/coq/pull/10932>`_, by Arthur Azevedo de + Amorim). diff --git a/doc/changelog/08-tools/10947-coq-makefile-dep.rst b/doc/changelog/08-tools/10947-coq-makefile-dep.rst new file mode 100644 index 0000000000..f620b32cb8 --- /dev/null +++ b/doc/changelog/08-tools/10947-coq-makefile-dep.rst @@ -0,0 +1,5 @@ +- Renamed `VDFILE` from `.coqdeps.d` to `.<CoqMakefile>.d` in the `coq_makefile` + utility, where `<CoqMakefile>` is the name of the output file given by the + `-o` option. In this way two generated makefiles can coexist in the same + directory. + (`#10947 <https://github.com/coq/coq/pull/10947>`_, by Kazuhiko Sakaguchi). diff --git a/doc/changelog/10-standard-library/10827-dedekind-reals.rst b/doc/changelog/10-standard-library/10827-dedekind-reals.rst new file mode 100644 index 0000000000..5d8467025b --- /dev/null +++ b/doc/changelog/10-standard-library/10827-dedekind-reals.rst @@ -0,0 +1,11 @@ +- New module `Reals.ClassicalDedekindReals` defines Dedekind real numbers + as boolean-values functions along with 3 logical axioms: limited principle + of omniscience, excluded middle of negations and functional extensionality. + The exposed type :g:`R` in module :g:`Reals.Rdefinitions` is those + Dedekind reals, hidden behind an opaque module. + Classical Dedekind reals are a quotient of constructive reals, which allows + to transport many constructive proofs to the classical case. + + See `#10827 <https://github.com/coq/coq/pull/10827>`_, by Vincent Semeria, + based on discussions with Guillaume Melquiond, Bas Spitters and Hugo Herbelin, + code review by Hugo Herbelin. diff --git a/doc/changelog/10-standard-library/10895-master+weak-excluded-middle-de-morgan.rst b/doc/changelog/10-standard-library/10895-master+weak-excluded-middle-de-morgan.rst new file mode 100644 index 0000000000..6e87ff93c7 --- /dev/null +++ b/doc/changelog/10-standard-library/10895-master+weak-excluded-middle-de-morgan.rst @@ -0,0 +1 @@ +- ClassicalFacts: Adding the standard equivalence between weak excluded-middle and the classical instance of De Morgan's law (`#10895 <https://github.com/coq/coq/pull/10895>`_, by Hugo Herbelin). diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 9dd4700db5..307214089f 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -9,4 +9,4 @@ let edeclare ?hook ~name ~poly ~scope ~kind ~opaque sigma udecl body tyopt imps let declare_definition ~poly name sigma body = let udecl = UState.default_univ_decl in edeclare ~name ~poly ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.Definition ~opaque:false sigma udecl body None [] + ~kind:Decls.(IsDefinition Definition) ~opaque:false sigma udecl body None [] diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index b6fcf9da22..80a24b997c 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -726,6 +726,45 @@ Changes in 8.10.0 fixes `#9512 <https://github.com/coq/coq/issues/9512>`_ by Vincent Laporte). +Changes in 8.10.1 +~~~~~~~~~~~~~~~~~ + +A few bug fixes and documentation improvements, in particular: + +**Kernel** + +- Fix proof of False when using |SProp| (incorrect De Bruijn handling + when inferring the relevance mark of a function) (`#10904 + <https://github.com/coq/coq/pull/10904>`_, by Pierre-Marie Pédrot). + +**Tactics** + +- Fix an anomaly when unsolved evar in :cmd:`Add Ring` + (`#10891 <https://github.com/coq/coq/pull/10891>`_, + fixes `#9851 <https://github.com/coq/coq/issues/9851>`_, + by Gaëtan Gilbert). + +**Tactic language** + +- Fix Ltac regression in binding free names in uconstr + (`#10899 <https://github.com/coq/coq/pull/10899>`_, + fixes `#10894 <https://github.com/coq/coq/issues/10894>`_, + by Hugo Herbelin). + +**CoqIDE** + +- Fix handling of unicode input before space + (`#10852 <https://github.com/coq/coq/pull/10852>`_, + fixes `#10842 <https://github.com/coq/coq/issues/10842>`_, + by Arthur Charguéraud). + +**Extraction** + +- Fix custom extraction of inductives to JSON + (`#10897 <https://github.com/coq/coq/pull/10897>`_, + fixes `#4741 <https://github.com/coq/coq/issues/4741>`_, + by Helge Bahmann). + Version 8.9 ----------- diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 1611e9dd52..c08a9ed0e6 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -1147,7 +1147,7 @@ Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or Polymorphism`. An inductive type can be forced to be template polymorphic using the - ``template`` attribute: it should then fullfill the criterion to + ``template`` attribute: it should then fulfill the criterion to be template polymorphic or an error is raised. .. exn:: Inductive @ident cannot be made template polymorphic. diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 2d047a1058..f477bf239d 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -182,7 +182,7 @@ other arguments are the parameters of the inductive type. recursive (references to the record's name in the type of its field raises an error). To define recursive records, one can use the ``Inductive`` and ``CoInductive`` keywords, resulting in an inductive or co-inductive record. - Definition of mutal inductive or co-inductive records are also allowed, as long + Definition of mutually inductive or co-inductive records are also allowed, as long as all of the types in the block are records. .. note:: Induction schemes are automatically generated for inductive records. @@ -1415,7 +1415,7 @@ is needed. In this translation, names in the file system are called *physical* paths while |Coq| names are contrastingly called *logical* names. -A logical prefix Lib can be associated to a physical pathpath using +A logical prefix Lib can be associated with a physical path using the command line option ``-Q`` `path` ``Lib``. All subfolders of path are recursively associated to the logical path ``Lib`` extended with the corresponding suffix coming from the physical path. For instance, the diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 2cbd41af8b..ae9d284661 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -111,7 +111,7 @@ Other tokens tokens defined at any given time can vary because the :cmd:`Notation` command can define new tokens. A :cmd:`Require` command may load more notation definitions, while the end of a :cmd:`Section` may remove notations. Some notations - are defined in the basic library (see :ref:`thecoqlibrary`) and are normallly + are defined in the basic library (see :ref:`thecoqlibrary`) and are normally loaded automatically at startup time. Here are the character sequences that Coq directly defines as tokens @@ -395,7 +395,7 @@ stands for :n:`let @ident := fun {+ @binder} => @term in @term’`. Definition by case analysis --------------------------- -Objects of inductive types can be destructurated by a case-analysis +Objects of inductive types can be destructured by a case-analysis construction called *pattern matching* expression. A pattern matching expression is used to analyze the structure of an inductive object and to apply specific treatments accordingly. @@ -572,7 +572,7 @@ The Vernacular assertion : `assertion_keyword` `ident` [`binders`] : `term` . assertion_keyword : Theorem | Lemma : Remark | Fact - : Corollary | Proposition + : Corollary | Property | Proposition : Definition | Example proof : Proof . … Qed . : Proof . … Defined . diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 9e219bd503..e5edd08995 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -359,7 +359,7 @@ line timing data: pass ``TIMING=before`` or ``TIMING=after`` rather than ``TIMING=1``. .. note:: - The sorting used here is the same as in the ``print-pretty-timed -diff`` target. + The sorting used here is the same as in the ``print-pretty-timed-diff`` target. .. note:: This target requires python to build the table. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 362c3da6cb..79eddbd3b5 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -368,7 +368,7 @@ We can check if a tactic made progress with: :name: progress :n:`@ltac_expr` is evaluated to v which must be a tactic value. The tactic value ``v`` - is applied to each focued subgoal independently. If the application of ``v`` + is applied to each focused subgoal independently. If the application of ``v`` to one of the focused subgoal produced subgoals equal to the initial goals (up to syntactical equality), then an error of level 0 is raised. diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 045d028d02..18d2c79461 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -853,6 +853,9 @@ a Ltac1 expression, and semantics of this quotation is the evaluation of the corresponding code for its side effects. In particular, it cannot return values, and the quotation has type :n:`unit`. +.. productionlist:: coq + ltac2_term : ltac1 : ( `ltac_expr` ) + Ltac1 **cannot** implicitly access variables from the Ltac2 scope, but this can be done with an explicit annotation on the :n:`ltac1` quotation. @@ -890,10 +893,19 @@ Ltac2 from Ltac1 Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation instead. -Note that the tactic expression is evaluated eagerly, if one wants to use it as -an argument to a Ltac1 function, one has to resort to the good old -:n:`idtac; ltac2:(foo)` trick. For instance, the code below will fail immediately -and won't print anything. +.. productionlist:: coq + ltac_expr : ltac2 : ( `ltac2_term` ) + : ltac2 : ( `ident` ... `ident` |- `ltac2_term` ) + +The typing rules are dual, that is, the optional identifiers are bound +with type `Ltac2.Ltac1.t` in the Ltac2 expression, which is expected to have +type unit. The value returned by this quotation is an Ltac1 function with the +same arity as the number of bound variables. + +Note that when no variables are bound, the inner tactic expression is evaluated +eagerly, if one wants to use it as an argument to a Ltac1 function, one has to +resort to the good old :n:`idtac; ltac2:(foo)` trick. For instance, the code +below will fail immediately and won't print anything. .. coqtop:: in @@ -902,11 +914,17 @@ and won't print anything. .. coqtop:: all - Ltac mytac tac := idtac "wow"; tac. + Ltac mytac tac := idtac "I am being evaluated"; tac. Goal True. Proof. + (* Doesn't print anything *) Fail mytac ltac2:(fail). + (* Prints and fails *) + Fail mytac ltac:(idtac; ltac2:(fail)). + +In any case, the value returned by the fully applied quotation is an +unspecified dummy Ltac1 closure and should not be further used. Transition from Ltac1 --------------------- diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 03b30d5d97..57a54bc0ad 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -538,13 +538,11 @@ Requesting information .. cmdv:: Show Proof :name: Show Proof - It displays the proof term generated by the tactics - that have been applied. If the proof is not completed, this term - contain holes, which correspond to the sub-terms which are still to be - constructed. These holes appear as a question mark indexed by an - integer, and applied to the list of variables in the context, since it - may depend on them. The types obtained by abstracting away the context - from the type of each placeholder are also printed. + Displays the proof term generated by the tactics + that have been applied so far. If the proof is incomplete, the term + will contain holes, which correspond to subterms which are still to be + constructed. Each hole is an existential variable, which appears as a + question mark followed by an identifier. .. cmdv:: Show Conjectures :name: Show Conjectures @@ -574,9 +572,8 @@ Requesting information .. cmdv:: Show Existentials :name: Show Existentials - It displays the set of all uninstantiated - existential variables in the current proof tree, along with the type - and the context of each variable. + Displays all open goals / existential variables in the current proof + along with the type and the context of each variable. .. cmdv:: Show Match @ident diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index ed980bd4de..75897fec45 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -514,7 +514,7 @@ is a valid tactic expression. The pose tactic is also improved for the local definition of higher order terms. Local definitions of functions can use the same syntax as global ones. -For example, the tactic :tacn:`pose <pose (ssreflect)>` supoprts parameters: +For example, the tactic :tacn:`pose <pose (ssreflect)>` supports parameters: .. example:: @@ -684,7 +684,7 @@ conditions: + If this head is a projection of a canonical structure, then canonical structure equations are used for the matching. + If the head of term is *not* a constant, the subterm should have the - same structure (λ abstraction,let…in structure …). + same structure (λ abstraction, let…in structure …). + If the head of :token:`term` is a hole, the subterm should have at least as many arguments as :token:`term`. @@ -1151,7 +1151,7 @@ is basically equivalent to move: a H1 H2; tactic => a H1 H2. -with two differences: the in tactical will preserve the body of a ifa +with two differences: the in tactical will preserve the body of an if a is a defined constant, and if the ``*`` is omitted it will use a temporary abbreviation to hide the statement of the goal from ``tactic``. @@ -1706,7 +1706,7 @@ Intro patterns execution of tactic should thus generate exactly m subgoals, unless the ``[…]`` :token:`i_pattern` comes after an initial ``//`` or ``//=`` :token:`s_item` that closes some of the goals produced by ``tactic``, in - which case exactly m subgoals should remain after thes- item, or we have + which case exactly m subgoals should remain after the :token:`s_item`, or we have the trivial branching :token:`i_pattern` [], which always does nothing, regardless of the number of remaining subgoals. ``[`` :token:`i_item` * ``| … |`` :token:`i_item` * ``]`` @@ -2240,8 +2240,8 @@ then the tactic tactic ; last k [ tactic1 |…| tacticm ] || tacticn. -where natural denotes the integer k as above, applies tactic1 to the n -−k + 1-th goal, … tacticm to the n −k + 2 − m-th goal and tactic n +where natural denotes the integer :math:`k` as above, applies tactic1 to the +:math:`n−k+1`\-th goal, … tacticm to the :math:`n−k+2`\-th goal and tacticn to the others. .. example:: @@ -2631,7 +2631,7 @@ The :token:`i_item` and :token:`s_item` can be used to interpret the asserted hypothesis with views (see section :ref:`views_and_reflection_ssr`) or simplify the resulting goals. -The ``have`` tactic also supports a ``suff`` modifier which allows for +The :tacn:`have` tactic also supports a ``suff`` modifier which allows for asserting that a given statement implies the current goal without copying the goal itself. @@ -2651,7 +2651,7 @@ compatible with the presence of a list of binders. Generating let in context entries with have ``````````````````````````````````````````` -Since |SSR| 1.5 the ``have`` tactic supports a “transparent” modifier +Since |SSR| 1.5 the :tacn:`have` tactic supports a “transparent” modifier to generate let in context entries: the ``@`` symbol in front of the context entry name. @@ -2670,7 +2670,7 @@ context entry name. Lemma test n m (H : m + 1 < n) : True. have @i : 'I_n by apply: (Sub m); omega. -Note that the sub-term produced by ``omega`` is in general huge and +Note that the subterm produced by :tacn:`omega` is in general huge and uninteresting, and hence one may want to hide it. For this purpose the ``[: name ]`` intro pattern and the tactic ``abstract`` (see :ref:`abstract_ssr`) are provided. @@ -2782,7 +2782,7 @@ The ``have`` and ``suff`` tactics are equivalent and have the same syntax but: -+ the order of the generated subgoals is inversed ++ the order of the generated subgoals is inverted + the optional clear item is still performed in the *second* branch. This means that the tactic: @@ -4583,7 +4583,7 @@ The ``elim/`` tactic distinguishes two cases: passed to the eliminator as the last argument (``x`` in ``foo_ind``) and ``en−1 … e1`` are used as patterns to select in the goal the occurrences that will be bound by the predicate ``P``, thus it must be possible to unify - the sub-term of the goal matched by ``en−1`` with ``pm`` , the one matched + the subterm of the goal matched by ``en−1`` with ``pm`` , the one matched by ``en−2`` with ``pm−1`` and so on. :regular eliminator: in all the other cases. Here it must be possible to unify the term matched by ``en`` with ``pm`` , the one matched by @@ -5451,7 +5451,7 @@ equivalences are indeed taken into account, otherwise only single name of an open module. This command returns the list of lemmas: + whose *conclusion* contains a subterm matching the optional first - pattern. A - reverses the test, producing the list of lemmas whose + pattern. A ``-`` reverses the test, producing the list of lemmas whose conclusion does not contain any subterm matching the pattern; + whose name contains the given string. A ``-`` prefix reverses the test, producing the list of lemmas whose name does not contain the string. A diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index c910136406..78753fc053 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -157,10 +157,10 @@ The :n:`eqn:` construct in various tactics uses :n:`@naming_intropattern`. Use these elementary patterns to specify a name: -* :n:`@ident` - use the specified name -* :n:`?` - let Coq choose a name -* :n:`?@ident` - generate a name that begins with :n:`@ident` -* :n:`_` - discard the matched part (unless it is required for another +* :n:`@ident` — use the specified name +* :n:`?` — let Coq choose a name +* :n:`?@ident` — generate a name that begins with :n:`@ident` +* :n:`_` — discard the matched part (unless it is required for another hypothesis) * if a disjunction pattern omits a name, such as :g:`[|H2]`, Coq will choose a name @@ -186,7 +186,7 @@ use the :tacn:`split` tactic to replace the current goal with subgoals :g:`A` an For a goal :g:`A \/ B`, use :tacn:`left` to replace the current goal with :g:`A`, or :tacn:`right` to replace the current goal with :g:`B`. -* :n:`( {+, @simple_intropattern}` ) - matches +* :n:`( {+, @simple_intropattern}` ) — matches a product over an inductive type with a :ref:`single constructor <intropattern_cons_note>`. If the number of patterns @@ -196,7 +196,7 @@ For a goal :g:`A \/ B`, use :tacn:`left` to replace the current goal with :g:`A` If the number of patterns equals the number of constructor arguments plus the number of :n:`let-ins`, the patterns are applied to the arguments and :n:`let-in` variables. -* :n:`( {+& @simple_intropattern} )` - matches a right-hand nested term that consists +* :n:`( {+& @simple_intropattern} )` — matches a right-hand nested term that consists of one or more nested binary inductive types such as :g:`a1 OP1 a2 OP2 ...` (where the :g:`OPn` are right-associative). (If the :g:`OPn` are left-associative, additional parentheses will be needed to make the @@ -207,15 +207,15 @@ For a goal :g:`A \/ B`, use :tacn:`left` to replace the current goal with :g:`A` :ref:`single constructor with two parameters <intropattern_cons_note>`. :ref:`Example <intropattern_ampersand_ex>` -* :n:`[ {+| @intropattern_list} ]` - splits an inductive type that has +* :n:`[ {+| @intropattern_list} ]` — splits an inductive type that has :ref:`multiple constructors <intropattern_cons_note>` such as :n:`A \/ B` into multiple subgoals. The number of :token:`intropattern_list` must be the same as the number of constructors for the matched part. -* :n:`[ {+ @intropattern} ]` - splits an inductive type that has a +* :n:`[ {+ @intropattern} ]` — splits an inductive type that has a :ref:`single constructor with multiple parameters <intropattern_cons_note>` such as :n:`A /\ B` into multiple hypotheses. Use :n:`[H1 [H2 H3]]` to match :g:`A /\ B /\ C`. -* :n:`[]` - splits an inductive type: If the inductive +* :n:`[]` — splits an inductive type: If the inductive type has multiple constructors, such as :n:`A \/ B`, create one subgoal for each constructor. If the inductive type has a single constructor with multiple parameters, such as :n:`A /\ B`, split it into multiple hypotheses. @@ -224,14 +224,14 @@ For a goal :g:`A \/ B`, use :tacn:`left` to replace the current goal with :g:`A` These patterns can be used when the hypothesis is an equality: -* :n:`->` - replaces the right-hand side of the hypothesis with the left-hand +* :n:`->` — replaces the right-hand side of the hypothesis with the left-hand side of the hypothesis in the conclusion of the goal; the hypothesis is cleared; if the left-hand side of the hypothesis is a variable, it is substituted everywhere in the context and the variable is removed. :ref:`Example <intropattern_rarrow_ex>` -* :n:`<-` - similar to :n:`->`, but replaces the left-hand side of the hypothesis +* :n:`<-` — similar to :n:`->`, but replaces the left-hand side of the hypothesis with the right-hand side of the hypothesis. -* :n:`[= {*, @intropattern} ]` - If the product is over an equality type, +* :n:`[= {*, @intropattern} ]` — If the product is over an equality type, applies either :tacn:`injection` or :tacn:`discriminate`. If :tacn:`injection` is applicable, the intropattern is used on the hypotheses generated by :tacn:`injection`. If the @@ -241,16 +241,16 @@ These patterns can be used when the hypothesis is an equality: **Other patterns** -* :n:`*` - introduces one or more quantified variables from the result +* :n:`*` — introduces one or more quantified variables from the result until there are no more quantified variables. :ref:`Example <intropattern_star_ex>` -* :n:`**` - introduces one or more quantified variables or hypotheses from the result until there are +* :n:`**` — introduces one or more quantified variables or hypotheses from the result until there are no more quantified variables or implications (:g:`->`). :g:`intros **` is equivalent to :g:`intros`. :ref:`Example <intropattern_2stars_ex>` -* :n:`@simple_intropattern_closed {* % @term}` - first applies each of the terms +* :n:`@simple_intropattern_closed {* % @term}` — first applies each of the terms with the :tacn:`apply ... in` tactic on the hypothesis to be introduced, then it uses :n:`@simple_intropattern_closed`. :ref:`Example <intropattern_injection_ex>` @@ -1409,7 +1409,7 @@ Controlling the proof flow While the different variants of :tacn:`assert` expect that no existential variables are generated by the tactic, :tacn:`eassert` removes this constraint. - This allows not to specify the asserted statement completeley before starting + This lets you avoid specifying the asserted statement completely before starting to prove it. .. tacv:: pose proof @term {? as @simple_intropattern} @@ -1555,8 +1555,8 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. :name: instantiate The instantiate tactic refines (see :tacn:`refine`) an existential variable - :n:`@ident` with the term :n:`@term`. It is equivalent to only [ident]: - :n:`refine @term` (preferred alternative). + :n:`@ident` with the term :n:`@term`. It is equivalent to + :n:`only [ident]: refine @term` (preferred alternative). .. note:: To be able to refer to an existential variable by name, the user must have given the name explicitly (see :ref:`Existential-Variables`). @@ -2008,7 +2008,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) .. coqtop:: reset all - Lemma le_minus : forall n:nat, n < 1 -> n = 0. + Lemma lt_1_r : forall n:nat, n < 1 -> n = 0. intros n H ; induction H. Here we did not get any information on the indexes to help fulfill @@ -2020,7 +2020,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) .. coqtop:: reset all Require Import Coq.Program.Equality. - Lemma le_minus : forall n:nat, n < 1 -> n = 0. + Lemma lt_1_r : forall n:nat, n < 1 -> n = 0. intros n H ; dependent induction H. The subgoal is cleaned up as the tactic tries to automatically @@ -2691,7 +2691,7 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. This tactic applies to any goal. The type of :token:`term` must have the form - ``forall (x``:sub:`1` ``:A``:sub:`1` ``) ... (x``:sub:`n` ``:A``:sub:`n` ``). eq term``:sub:`1` ``term``:sub:`2` ``.`` + ``forall (x``:sub:`1` ``:A``:sub:`1` ``) ... (x``:sub:`n` ``:A``:sub:`n` ``), eq term``:sub:`1` ``term``:sub:`2` ``.`` where :g:`eq` is the Leibniz equality or a registered setoid equality. @@ -3224,8 +3224,8 @@ the conversion in hypotheses :n:`{+ @ident}`. even if an extra simplification is possible. In detail, the tactic :tacn:`simpl` first applies :math:`\beta`:math:`\iota`-reduction. Then, it - expands transparent constants and tries to reduce further using :math:`\beta`:math:`\iota`- - reduction. But, when no :math:`\iota` rule is applied after unfolding then + expands transparent constants and tries to reduce further using :math:`\beta`:math:`\iota`-reduction. + But, when no :math:`\iota` rule is applied after unfolding then :math:`\delta`-reductions are not applied. For instance trying to use :tacn:`simpl` on :g:`(plus n O) = n` changes nothing. @@ -4005,8 +4005,8 @@ use one or several databases specific to your development. This vernacular command adds the terms :n:`{+ @term}` (their types must be equalities) in the rewriting bases :n:`{+ @ident}` with the default orientation - (left to right). Notice that the rewriting bases are distinct from the ``auto`` - hint bases and thatauto does not take them into account. + (left to right). Notice that the rewriting bases are distinct from the :tacn:`auto` + hint bases and that :tacn:`auto` does not take them into account. This command is synchronous with the section mechanism (see :ref:`section-mechanism`): when closing a section, all aliases created by ``Hint Rewrite`` in that @@ -4553,7 +4553,7 @@ Inversion .. tacv:: functional inversion @num - This does the same thing as :n:`intros until @num` folowed by + This does the same thing as :n:`intros until @num` followed by :n:`functional inversion @ident` where :token:`ident` is the identifier for the last introduced hypothesis. @@ -4569,8 +4569,8 @@ Inversion Classical tactics ----------------- -In order to ease the proving process, when the Classical module is -loaded. A few more tactics are available. Make sure to load the module +In order to ease the proving process, when the ``Classical`` module is +loaded, a few more tactics are available. Make sure to load the module using the ``Require Import`` command. .. tacn:: classical_left @@ -4627,7 +4627,7 @@ Automating The tactic :tacn:`omega`, due to Pierre Crégut, is an automatic decision procedure for Presburger arithmetic. It solves quantifier-free - formulas built with `~`, `\/`, `/\`, `->` on top of equalities, + formulas built with `~`, `\\/`, `/\\`, `->` on top of equalities, inequalities and disequalities on both the type :g:`nat` of natural numbers and :g:`Z` of binary integers. This tactic must be loaded by the command ``Require Import Omega``. See the additional documentation about omega diff --git a/doc/sphinx/refman-preamble.rst b/doc/sphinx/refman-preamble.rst index c662028773..de95eda989 100644 --- a/doc/sphinx/refman-preamble.rst +++ b/doc/sphinx/refman-preamble.rst @@ -70,7 +70,11 @@ .. |p_i| replace:: `p`\ :math:`_{i}` .. |p_n| replace:: `p`\ :math:`_{n}` .. |Program| replace:: :strong:`Program` +.. |Prop| replace:: :math:`\Prop` +.. |SProp| replace:: :math:`\SProp` +.. |Set| replace:: :math:`\Set` .. |SSR| replace:: :smallcaps:`SSReflect` +.. |Type| replace:: :math:`\Type` .. |t_1| replace:: `t`\ :math:`_{1}` .. |t_i| replace:: `t`\ :math:`_{i}` .. |t_m| replace:: `t`\ :math:`_{m}` diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index fd315c097d..a28ce600ca 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -267,31 +267,30 @@ The second, more powerful control on printing is by using the format A *format* is an extension of the string denoting the notation with the possible following elements delimited by single quotes: -- extra spaces are translated into simple spaces +- tokens of the form ``'/ '`` are translated into breaking points. If + there is a line break, indents the number of spaces appearing after the + “``/``” (no indentation in the example) -- tokens of the form ``'/ '`` are translated into breaking point, in - case a line break occurs, an indentation of the number of spaces after - the “ ``/``” is applied (2 spaces in the given example) - -- token of the form ``'//'`` force writing on a new line +- tokens of the form ``'//'`` force writing on a new line - well-bracketed pairs of tokens of the form ``'[ '`` and ``']'`` are - translated into printing boxes; in case a line break occurs, an extra - indentation of the number of spaces given after the “ ``[``” is applied - (4 spaces in the example) + translated into printing boxes; if there is a line break, an extra + indentation of the number of spaces after the “``[``” is applied - well-bracketed pairs of tokens of the form ``'[hv '`` and ``']'`` are translated into horizontal-or-else-vertical printing boxes; if the content of the box does not fit on a single line, then every breaking - point forces a newline and an extra indentation of the number of - spaces given after the “ ``[``” is applied at the beginning of each - newline (3 spaces in the example) + point forces a new line and an extra indentation of the number of + spaces after the “``[hv``” is applied at the beginning of each new line - well-bracketed pairs of tokens of the form ``'[v '`` and ``']'`` are translated into vertical printing boxes; every breaking point forces a - newline, even if the line is large enough to display the whole content - of the box, and an extra indentation of the number of spaces given - after the “``[``” is applied at the beginning of each newline + new line, even if the line is large enough to display the whole content + of the box, and an extra indentation of the number of spaces + after the “``[v``” is applied at the beginning of each new line (3 spaces + in the example) + +- extra spaces in other tokens are preserved in the output Notations disappear when a section is closed. No typing of the denoted expression is performed at definition time. Type checking is done only @@ -592,7 +591,7 @@ placeholder being the nesting point. In the innermost occurrence of the nested iterating pattern, the second placeholder is finally filled with the terminating expression. -In the example above, the iterator :math:`φ([~]_E , [~]_I)` is :math:`cons [~]_E [~]_I` +In the example above, the iterator :math:`φ([~]_E , [~]_I)` is :math:`cons [~]_E\, [~]_I` and the terminating expression is ``nil``. Here are other examples: .. coqtop:: in @@ -751,12 +750,12 @@ level is otherwise given explicitly by using the syntax Levels are cumulative: a notation at level ``n`` of which the left end is a term shall use rules at level less than ``n`` to parse this -sub-term. More precisely, it shall use rules at level strictly less +subterm. More precisely, it shall use rules at level strictly less than ``n`` if the rule is declared with ``right associativity`` and rules at level less or equal than ``n`` if the rule is declared with ``left associativity``. Similarly, a notation at level ``n`` of which the right end is a term shall use by default rules at level strictly -less than ``n`` to parse this sub-term if the rule is declared left +less than ``n`` to parse this subterm if the rule is declared left associative and rules at level less or equal than ``n`` if the rule is declared right associative. This is what happens for instance in the rule diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index bc4d8b95ab..bb6df87970 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -44,6 +44,7 @@ plugins/micromega/ZCoeff.v plugins/micromega/ZMicromega.v plugins/micromega/ZifyInst.v plugins/micromega/ZifyBool.v +plugins/micromega/ZifyComparison.v plugins/micromega/ZifyClasses.v plugins/micromega/Zify.v plugins/nsatz/Nsatz.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 75c8c6c1ea..f0ada745e7 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -68,6 +68,7 @@ through the <tt>Require Import</tt> command.</p> theories/Logic/WKL.v theories/Logic/FinFun.v theories/Logic/PropFacts.v + theories/Logic/HLevels.v </dd> <dt> <b>Structures</b>: @@ -518,8 +519,8 @@ through the <tt>Require Import</tt> command.</p> theories/Reals/ConstructiveRealsMorphisms.v theories/Reals/ConstructiveCauchyReals.v theories/Reals/ConstructiveCauchyRealsMult.v + theories/Reals/ClassicalDedekindReals.v theories/Reals/Raxioms.v - theories/Reals/ConstructiveRIneq.v theories/Reals/ConstructiveRealsLUB.v theories/Reals/RIneq.v theories/Reals/DiscrR.v diff --git a/engine/uState.ml b/engine/uState.ml index af714f6282..ba17cdde93 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -520,7 +520,7 @@ let merge ?loc ~sideff rigid uctx ctx' = let merge_subst uctx s = { uctx with uctx_univ_variables = LMap.subst_union uctx.uctx_univ_variables s } -let demote_seff_univs (univs,_) uctx = +let demote_seff_univs univs uctx = let seff = LSet.union uctx.uctx_seff_univs univs in { uctx with uctx_seff_univs = seff } @@ -539,11 +539,9 @@ let merge_seff uctx ctx' = uctx_initial_universes = initial } let emit_side_effects eff u = - let uctxs = Safe_typing.universes_of_private eff in - List.fold_left (fun u uctx -> - let u = demote_seff_univs uctx u in - merge_seff u uctx) - u uctxs + let uctx = Safe_typing.universes_of_private eff in + let u = demote_seff_univs (fst uctx) u in + merge_seff u uctx let update_sigma_env uctx env = let univs = UGraph.make_sprop_cumulative (Environ.universes env) in diff --git a/engine/uState.mli b/engine/uState.mli index 7cb2f49780..23ef84c55d 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -112,6 +112,11 @@ val merge : ?loc:Loc.t -> sideff:bool -> rigid -> t -> Univ.ContextSet.t -> t val merge_subst : t -> UnivSubst.universe_opt_subst -> t val emit_side_effects : Safe_typing.private_constants -> t -> t +val demote_seff_univs : Univ.LSet.t -> t -> t +(** Mark the universes as not local any more, because they have been + globally declared by some side effect. You should be using + emit_side_effects instead. *) + val new_univ_variable : ?loc:Loc.t -> rigid -> Id.t option -> t -> t * Univ.Level.t val add_global_univ : t -> Univ.Level.t -> t diff --git a/interp/notation.ml b/interp/notation.ml index ea2173860d..70d3e4175e 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1836,7 +1836,7 @@ let locate_notation prglob ntn scope = str "Notation" ++ fnl () ++ prlist_with_sep fnl (fun (ntn,l) -> let scope = find_default ntn scopes in - prlist + prlist_with_sep fnl (fun (sc,r,(_,df)) -> hov 0 ( pr_notation_info prglob df r ++ diff --git a/kernel/entries.ml b/kernel/entries.ml index 1e6bc14935..046ea86872 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -99,14 +99,10 @@ type primitive_entry = { type 'a proof_output = constr Univ.in_universe_context_set * 'a type 'a const_entry_body = 'a proof_output Future.computation -(** Dummy wrapper type discriminable from unit *) -type 'a seff_wrap = { seff_wrap : 'a } - -type _ constant_entry = - | DefinitionEntry : definition_entry -> unit constant_entry - | OpaqueEntry : 'a const_entry_body opaque_entry -> 'a seff_wrap constant_entry - | ParameterEntry : parameter_entry -> unit constant_entry - | PrimitiveEntry : primitive_entry -> unit constant_entry +type constant_entry = + | DefinitionEntry : definition_entry -> constant_entry + | ParameterEntry : parameter_entry -> constant_entry + | PrimitiveEntry : primitive_entry -> constant_entry (** {6 Modules } *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 4a2aeea22d..98d66cafa1 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -50,12 +50,19 @@ type constant_key = Opaqueproof.opaque constant_body * (link_info ref * key) type mind_key = mutual_inductive_body * link_info ref -type globals = { - env_constants : constant_key Cmap_env.t; - env_inductives : mind_key Mindmap_env.t; - env_modules : module_body MPmap.t; - env_modtypes : module_type_body MPmap.t; -} +module Globals = struct + + type view = + { constants : constant_key Cmap_env.t + ; inductives : mind_key Mindmap_env.t + ; modules : module_body MPmap.t + ; modtypes : module_type_body MPmap.t + } + + type t = view + + let view x = x +end type stratification = { env_universes : UGraph.t; @@ -88,7 +95,7 @@ type rel_context_val = { } type env = { - env_globals : globals; + env_globals : Globals.t; env_named_context : named_context_val; (* section variables *) env_rel_context : rel_context_val; env_nb_rel : int; @@ -110,11 +117,12 @@ let empty_rel_context_val = { } let empty_env = { - env_globals = { - env_constants = Cmap_env.empty; - env_inductives = Mindmap_env.empty; - env_modules = MPmap.empty; - env_modtypes = MPmap.empty}; + env_globals = + { Globals.constants = Cmap_env.empty + ; inductives = Mindmap_env.empty + ; modules = MPmap.empty + ; modtypes = MPmap.empty + }; env_named_context = empty_named_context_val; env_rel_context = empty_rel_context_val; env_nb_rel = 0; @@ -215,29 +223,29 @@ let lookup_named_ctxt id ctxt = fst (Id.Map.find id ctxt.env_named_map) let fold_constants f env acc = - Cmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.env_constants acc + Cmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.Globals.constants acc let fold_inductives f env acc = - Mindmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.env_inductives acc + Mindmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.Globals.inductives acc (* Global constants *) let lookup_constant_key kn env = - Cmap_env.find kn env.env_globals.env_constants + Cmap_env.find kn env.env_globals.Globals.constants let lookup_constant kn env = - fst (Cmap_env.find kn env.env_globals.env_constants) + fst (Cmap_env.find kn env.env_globals.Globals.constants) (* Mutual Inductives *) let lookup_mind kn env = - fst (Mindmap_env.find kn env.env_globals.env_inductives) + fst (Mindmap_env.find kn env.env_globals.Globals.inductives) let mind_context env mind = let mib = lookup_mind mind env in Declareops.inductive_polymorphic_context mib let lookup_mind_key kn env = - Mindmap_env.find kn env.env_globals.env_inductives + Mindmap_env.find kn env.env_globals.Globals.inductives let oracle env = env.env_typing_flags.conv_oracle let set_oracle env o = @@ -468,10 +476,10 @@ let no_link_info = NotLinked let add_constant_key kn cb linkinfo env = let new_constants = - Cmap_env.add kn (cb,(ref linkinfo, ref None)) env.env_globals.env_constants in + Cmap_env.add kn (cb,(ref linkinfo, ref None)) env.env_globals.Globals.constants in let new_globals = { env.env_globals with - env_constants = new_constants } in + Globals.constants = new_constants } in { env with env_globals = new_globals } let add_constant kn cb env = @@ -598,10 +606,10 @@ let template_polymorphic_pind (ind,u) env = else template_polymorphic_ind ind env let add_mind_key kn (_mind, _ as mind_key) env = - let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in + let new_inds = Mindmap_env.add kn mind_key env.env_globals.Globals.inductives in let new_globals = { env.env_globals with - env_inductives = new_inds; } in + Globals.inductives = new_inds; } in { env with env_globals = new_globals } let add_mind kn mib env = @@ -688,22 +696,22 @@ let keep_hyps env needed = let add_modtype mtb env = let mp = mtb.mod_mp in - let new_modtypes = MPmap.add mp mtb env.env_globals.env_modtypes in - let new_globals = { env.env_globals with env_modtypes = new_modtypes } in + let new_modtypes = MPmap.add mp mtb env.env_globals.Globals.modtypes in + let new_globals = { env.env_globals with Globals.modtypes = new_modtypes } in { env with env_globals = new_globals } let shallow_add_module mb env = let mp = mb.mod_mp in - let new_mods = MPmap.add mp mb env.env_globals.env_modules in - let new_globals = { env.env_globals with env_modules = new_mods } in + let new_mods = MPmap.add mp mb env.env_globals.Globals.modules in + let new_globals = { env.env_globals with Globals.modules = new_mods } in { env with env_globals = new_globals } let lookup_module mp env = - MPmap.find mp env.env_globals.env_modules + MPmap.find mp env.env_globals.Globals.modules -let lookup_modtype mp env = - MPmap.find mp env.env_globals.env_modtypes +let lookup_modtype mp env = + MPmap.find mp env.env_globals.Globals.modtypes (*s Judgments. *) diff --git a/kernel/environ.mli b/kernel/environ.mli index f7de98dcfb..5af2a7288b 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -46,8 +46,18 @@ type constant_key = Opaqueproof.opaque constant_body * (link_info ref * key) type mind_key = mutual_inductive_body * link_info ref -type globals -(** globals = constants + projections + inductive types + modules + module-types *) +module Globals : sig + type t + + type view = + { constants : constant_key Cmap_env.t + ; inductives : mind_key Mindmap_env.t + ; modules : module_body MPmap.t + ; modtypes : module_type_body MPmap.t + } + + val view : t -> view +end type stratification = { env_universes : UGraph.t; @@ -67,7 +77,7 @@ type rel_context_val = private { } type env = private { - env_globals : globals; + env_globals : Globals.t; env_named_context : named_context_val; (* section variables *) env_rel_context : rel_context_val; env_nb_rel : int; diff --git a/kernel/retypeops.ml b/kernel/retypeops.ml index a51b762f95..f398e6a5da 100644 --- a/kernel/retypeops.ml +++ b/kernel/retypeops.ml @@ -71,6 +71,7 @@ let rec relevance_of_fterm env extra lft f = | FLambda (len, tys, bdy, e) -> let extra = List.rev_append (List.map (fun (x,_) -> binder_relevance x) tys) extra in let lft = Esubst.el_liftn len lft in + let e = Esubst.subs_liftn len e in relevance_of_term_extra env extra lft e bdy | FLetIn (x, _, _, bdy, e) -> relevance_of_term_extra env (x.binder_relevance :: extra) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 9b4d2e69ac..00559206ee 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -173,6 +173,8 @@ let is_initial senv = | [], NONE -> ModPath.equal senv.modpath ModPath.initial | _ -> false +let sections_are_opened senv = not (Section.is_empty senv.sections) + let delta_of_senv senv = senv.modresolver,senv.paramresolver let constant_of_delta_kn_senv senv kn = @@ -297,13 +299,6 @@ let lift_constant c = in { c with const_body = body } -let map_constant f c = - let body = match c.const_body with - | OpaqueDef o -> OpaqueDef (f o) - | Def _ | Undef _ | Primitive _ as body -> body - in - { c with const_body = body } - let push_private_constants env eff = let eff = side_effects_of_private_constants eff in let add_if_undefined env eff = @@ -318,10 +313,10 @@ let concat_private = SideEffects.concat let universes_of_private eff = let fold acc eff = match eff.seff_body.const_universes with - | Monomorphic ctx -> ctx :: acc + | Monomorphic ctx -> Univ.ContextSet.union ctx acc | Polymorphic _ -> acc in - List.fold_left fold [] (side_effects_of_private_constants eff) + List.fold_left fold Univ.ContextSet.empty (side_effects_of_private_constants eff) let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env @@ -577,20 +572,16 @@ let add_field ?(is_include=false) ((l,sfb) as field) gn senv = let update_resolver f senv = { senv with modresolver = f senv.modresolver } -(** Insertion of constants and parameters in environment *) -type 'a effect_entry = -| EffectEntry : private_constants Entries.seff_wrap effect_entry -| PureEntry : unit effect_entry - type global_declaration = - | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration +| ConstantEntry : Entries.constant_entry -> global_declaration +| OpaqueEntry : private_constants Entries.const_entry_body Entries.opaque_entry -> global_declaration type exported_private_constant = Constant.t -let add_constant_aux ~in_section senv (kn, cb) = +let add_constant_aux senv (kn, cb) = let l = Constant.label kn 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 = if sections_are_opened senv then cb else Declareops.hcons_const_body cb in let senv' = add_field (l,SFBconst cb) (C kn) senv in let senv'' = match cb.const_body with | Undef (Some lev) -> @@ -702,7 +693,7 @@ let check_signatures curmb sl = type side_effect_declaration = | DefinitionEff : Entries.definition_entry -> side_effect_declaration -| OpaqueEff : unit Entries.const_entry_body Entries.opaque_entry -> side_effect_declaration +| OpaqueEff : Constr.constr Entries.opaque_entry -> side_effect_declaration let constant_entry_of_side_effect eff = let cb = eff.seff_body in @@ -721,7 +712,7 @@ let constant_entry_of_side_effect eff = | _ -> assert false in if Declareops.is_opaque cb then OpaqueEff { - opaque_entry_body = Future.from_val ((p, Univ.ContextSet.empty), ()); + opaque_entry_body = p; opaque_entry_secctx = Context.Named.to_vars cb.const_hyps; opaque_entry_feedback = None; opaque_entry_type = cb.const_type; @@ -739,6 +730,25 @@ let constant_entry_of_side_effect eff = let export_eff eff = (eff.seff_constant, eff.seff_body) +let is_empty_private = function +| Opaqueproof.PrivateMonomorphic ctx -> Univ.ContextSet.is_empty ctx +| Opaqueproof.PrivatePolymorphic (_, ctx) -> Univ.ContextSet.is_empty ctx + +let empty_private univs = match univs with +| Monomorphic _ -> Opaqueproof.PrivateMonomorphic Univ.ContextSet.empty +| Polymorphic auctx -> Opaqueproof.PrivatePolymorphic (Univ.AUContext.size auctx, Univ.ContextSet.empty) + +(* Special function to call when the body of an opaque definition is provided. + It performs the type-checking of the body immediately. *) +let translate_direct_opaque env kn ce = + let cb, ctx = Term_typing.translate_opaque env kn ce in + let body = ce.Entries.opaque_entry_body, Univ.ContextSet.empty in + let handle _env c () = (c, Univ.ContextSet.empty, 0) in + let (c, u) = Term_typing.check_delayed handle ctx (body, ()) in + (* No constraints can be generated, we set it empty everywhere *) + let () = assert (is_empty_private u) in + { cb with const_body = OpaqueDef c } + let export_side_effects mb env (b_ctx, eff) = let not_exists e = try ignore(Environ.lookup_constant e.seff_constant env); false @@ -763,26 +773,14 @@ let export_side_effects mb env (b_ctx, eff) = if Int.equal sl 0 then let env, cb = let kn = eff.seff_constant in - let ce = constant_entry_of_side_effect eff in - let open Entries in - let open Term_typing in - let cb = match ce with - | DefinitionEff ce -> - Term_typing.translate_constant Pure env kn (DefinitionEntry ce) - | OpaqueEff ce -> - let handle _env c () = (c, Univ.ContextSet.empty, 0) in - Term_typing.translate_constant (SideEffects handle) env kn (OpaqueEntry ce) - in - let map cu = - let (c, u) = Future.force cu in - let () = match u with - | Opaqueproof.PrivateMonomorphic ctx - | Opaqueproof.PrivatePolymorphic (_, ctx) -> - assert (Univ.ContextSet.is_empty ctx) - in - c + let ce = constant_entry_of_side_effect eff in + let open Entries in + let cb = match ce with + | DefinitionEff ce -> + Term_typing.translate_constant env kn (DefinitionEntry ce) + | OpaqueEff ce -> + translate_direct_opaque env kn ce in - let cb = map_constant map cb in let eff = { eff with seff_body = cb } in (push_seff env eff, export_eff eff) in @@ -799,14 +797,11 @@ let push_opaque_proof pf senv = let senv = { senv with env = Environ.set_opaque_tables senv.env otab } in senv, o -let export_private_constants ~in_section ce senv = +let export_private_constants ce senv = let exported, ce = export_side_effects senv.revstruct senv.env ce in let map senv (kn, c) = match c.const_body with | OpaqueDef p -> - let local = match c.const_universes with - | Monomorphic _ -> Opaqueproof.PrivateMonomorphic Univ.ContextSet.empty - | Polymorphic auctx -> Opaqueproof.PrivatePolymorphic (Univ.AUContext.size auctx, Univ.ContextSet.empty) - in + let local = empty_private c.const_universes in let senv, o = push_opaque_proof (Future.from_val (p, local)) senv in senv, (kn, { c with const_body = OpaqueDef o }) | Def _ | Undef _ | Primitive _ as body -> @@ -815,22 +810,25 @@ let export_private_constants ~in_section ce senv = let senv, bodies = List.fold_left_map map senv 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 + let senv = List.fold_left add_constant_aux senv bodies in (ce, exported), senv -let add_constant (type a) ~(side_effect : a effect_entry) ~in_section l decl senv : (Constant.t * a) * safe_environment = +let add_constant l decl senv = let kn = Constant.make2 senv.modpath l in - let cb = + let cb = match decl with - | ConstantEntry (EffectEntry, ce) -> + | OpaqueEntry ce -> let handle env body eff = let body, uctx, signatures = inline_side_effects env body eff in let trusted = check_signatures senv.revstruct signatures in body, uctx, trusted in - Term_typing.translate_constant (Term_typing.SideEffects handle) senv.env kn ce - | ConstantEntry (PureEntry, ce) -> - Term_typing.translate_constant Term_typing.Pure senv.env kn ce + let cb, ctx = Term_typing.translate_opaque senv.env kn ce in + let map pf = Term_typing.check_delayed handle ctx pf in + let pf = Future.chain ce.Entries.opaque_entry_body map in + { cb with const_body = OpaqueDef pf } + | ConstantEntry ce -> + Term_typing.translate_constant senv.env kn ce in let senv = let senv, cb, delayed_cst = match cb.const_body with @@ -852,43 +850,45 @@ let add_constant (type a) ~(side_effect : a effect_entry) ~in_section l decl sen | Undef _ | Def _ | Primitive _ as body -> senv, { cb with const_body = body }, [] in - let senv = add_constant_aux ~in_section senv (kn, cb) in + let senv = add_constant_aux 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; _ })) -> - if in_section then CErrors.anomaly (Pp.str "Primitive type not allowed in sections"); + | ConstantEntry (Entries.PrimitiveEntry { Entries.prim_entry_content = CPrimitives.OT_type t; _ }) -> + if sections_are_opened senv then CErrors.anomaly (Pp.str "Primitive type not allowed in sections"); add_retroknowledge (Retroknowledge.Register_type(t,kn)) senv | _ -> senv in - let eff : a = match side_effect with - | PureEntry -> () - | EffectEntry -> - let body, univs = match cb.const_body with - | (Primitive _ | Undef _) -> assert false - | Def c -> (Def c, cb.const_universes) - | OpaqueDef o -> - let (b, delayed) = Future.force o in - match cb.const_universes, delayed with - | Monomorphic ctx', Opaqueproof.PrivateMonomorphic ctx -> - OpaqueDef b, Monomorphic (Univ.ContextSet.union ctx ctx') - | Polymorphic auctx, Opaqueproof.PrivatePolymorphic (_, ctx) -> - (* Upper layers enforce that there are no internal constraints *) - let () = assert (Univ.ContextSet.is_empty ctx) in - OpaqueDef b, Polymorphic auctx - | (Monomorphic _ | Polymorphic _), (Opaqueproof.PrivateMonomorphic _ | Opaqueproof.PrivatePolymorphic _) -> - assert false + kn, senv + +let add_private_constant l decl senv : (Constant.t * private_constants) * safe_environment = + let kn = Constant.make2 senv.modpath l in + let cb = + match decl with + | OpaqueEff ce -> + translate_direct_opaque senv.env kn ce + | DefinitionEff ce -> + Term_typing.translate_constant senv.env kn (Entries.DefinitionEntry ce) in - let cb = { cb with const_body = body; const_universes = univs } in + let senv, dcb = match cb.const_body with + | Def _ as const_body -> senv, { cb with const_body } + | OpaqueDef c -> + let local = empty_private cb.const_universes in + let senv, o = push_opaque_proof (Future.from_val (c, local)) senv in + senv, { cb with const_body = OpaqueDef o } + | Undef _ | Primitive _ -> assert false + in + let senv = add_constant_aux senv (kn, dcb) in + let eff = let from_env = CEphemeron.create senv.revstruct in let eff = { from_env = from_env; seff_constant = kn; seff_body = cb; } in - { Entries.seff_wrap = SideEffects.add eff empty_private_constants } + SideEffects.add eff empty_private_constants in (kn, eff), senv @@ -1001,12 +1001,11 @@ let close_section senv = 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) + add_constant_aux 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 diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index d97d61a72f..b2f6668577 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -59,7 +59,7 @@ val inline_private_constants : val push_private_constants : Environ.env -> private_constants -> Environ.env (** Push the constants in the environment if not already there. *) -val universes_of_private : private_constants -> Univ.ContextSet.t list +val universes_of_private : private_constants -> Univ.ContextSet.t val is_curmod_library : safe_environment -> bool @@ -73,23 +73,27 @@ val is_joined_environment : safe_environment -> bool (** Insertion of global axioms or definitions *) -type 'a effect_entry = -| EffectEntry : private_constants Entries.seff_wrap effect_entry -| PureEntry : unit effect_entry - type global_declaration = - | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration +| ConstantEntry : Entries.constant_entry -> global_declaration +| OpaqueEntry : private_constants Entries.const_entry_body Entries.opaque_entry -> global_declaration + +type side_effect_declaration = +| DefinitionEff : Entries.definition_entry -> side_effect_declaration +| OpaqueEff : Constr.constr Entries.opaque_entry -> side_effect_declaration type exported_private_constant = Constant.t -val export_private_constants : in_section:bool -> +val export_private_constants : private_constants Entries.proof_output -> (Constr.constr Univ.in_universe_context_set * exported_private_constant list) safe_transformer -(** returns the main constant plus a certificate of its validity *) +(** returns the main constant *) val add_constant : - side_effect:'a effect_entry -> in_section:bool -> Label.t -> global_declaration -> - (Constant.t * 'a) safe_transformer + Label.t -> global_declaration -> Constant.t safe_transformer + +(** Similar to add_constant but also returns a certificate *) +val add_private_constant : + Label.t -> side_effect_declaration -> (Constant.t * private_constants) safe_transformer (** Adding an inductive type *) @@ -138,6 +142,8 @@ val open_section : safe_transformer0 val close_section : safe_transformer0 +val sections_are_opened : safe_environment -> bool + (** Insertion of local declarations (Local or Variables) *) val push_named_assum : (Id.t * Constr.types) -> safe_transformer0 diff --git a/kernel/section.ml b/kernel/section.ml index babd9fe7a1..a1242f0faf 100644 --- a/kernel/section.ml +++ b/kernel/section.ml @@ -43,6 +43,8 @@ let empty = [] let is_empty = List.is_empty +let depth = List.length + let has_poly_univs = function | [] -> false | sec :: _ -> sec.has_poly_univs diff --git a/kernel/section.mli b/kernel/section.mli index 56b4d9ba8f..ec863b3b90 100644 --- a/kernel/section.mli +++ b/kernel/section.mli @@ -21,6 +21,9 @@ val empty : 'a t val is_empty : 'a t -> bool (** Checks whether there is no opened section *) +val depth : 'a t -> int +(** Number of nested sections (0 if no sections are open) *) + (** {6 Manipulating sections} *) type section_entry = diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index f70b2960cf..f85b3db413 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -29,10 +29,6 @@ module NamedDecl = Context.Named.Declaration type 'a effect_handler = env -> Constr.t -> 'a -> (Constr.t * Univ.ContextSet.t * int) -type _ trust = -| Pure : unit trust -| SideEffects : 'a effect_handler -> 'a Entries.seff_wrap trust - let skip_trusted_seff sl b e = let rec aux sl b e acc = let open Context.Rel.Declaration in @@ -64,7 +60,11 @@ let feedback_completion_typecheck = Option.iter (fun state_id -> Feedback.feedback ~id:state_id Feedback.Complete) -let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = +type typing_context = +| MonoTyCtx of Environ.env * unsafe_type_judgment * Univ.ContextSet.t * Id.Set.t * Stateid.t option +| PolyTyCtx of Environ.env * unsafe_type_judgment * Univ.universe_level_subst * Univ.AUContext.t * Id.Set.t * Stateid.t option + +let infer_declaration env (dcl : constant_entry) = match dcl with | ParameterEntry (ctx,(t,uctx),nl) -> let env = match uctx with @@ -112,79 +112,9 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = cook_relevance = Sorts.Relevant; } - (** Definition [c] is opaque (Qed), non polymorphic and with a specified type, - so we delay the typing and hash consing of its body. *) - - | OpaqueEntry ({ opaque_entry_type = typ; - opaque_entry_universes = Monomorphic_entry univs; _ } as c) -> - let env = push_context_set ~strict:true univs env in - let { opaque_entry_body = body; opaque_entry_feedback = feedback_id; _ } = c in - let tyj = Typeops.infer_type env typ in - let proofterm = - Future.chain body begin fun ((body,uctx),side_eff) -> - (* don't redeclare universes which are declared for the type *) - let uctx = Univ.ContextSet.diff uctx univs in - let SideEffects handle = trust in - let (body, uctx', valid_signatures) = handle env body side_eff in - let uctx = Univ.ContextSet.union uctx uctx' in - let env = push_context_set uctx env in - let body,env,ectx = skip_trusted_seff valid_signatures body env in - let j = Typeops.infer env body in - let j = unzip ectx j in - let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in - let c = j.uj_val in - feedback_completion_typecheck feedback_id; - c, Opaqueproof.PrivateMonomorphic uctx - end in - let def = OpaqueDef proofterm in - { - Cooking.cook_body = def; - cook_type = tyj.utj_val; - cook_universes = Monomorphic univs; - cook_relevance = Sorts.relevance_of_sort tyj.utj_type; - cook_inline = false; - cook_context = Some c.opaque_entry_secctx; - } - - (** Similar case for polymorphic entries. *) - - | OpaqueEntry ({ opaque_entry_type = typ; - opaque_entry_universes = Polymorphic_entry (nas, uctx); _ } as c) -> - let { opaque_entry_body = body; opaque_entry_feedback = feedback_id; _ } = c in - let env = push_context ~strict:false uctx env in - let tj = Typeops.infer_type env typ in - let sbst, auctx = Univ.abstract_universes nas uctx in - let usubst = Univ.make_instance_subst sbst in - let proofterm = Future.chain body begin fun ((body, ctx), side_eff) -> - let SideEffects handle = trust in - let body, ctx', _ = handle env body side_eff in - let ctx = Univ.ContextSet.union ctx ctx' in - (** [ctx] must contain local universes, such that it has no impact - on the rest of the graph (up to transitivity). *) - let env = push_subgraph ctx env in - let private_univs = on_snd (Univ.subst_univs_level_constraints usubst) ctx in - let j = Typeops.infer env body in - let _ = Typeops.judge_of_cast env j DEFAULTcast tj in - let def = Vars.subst_univs_level_constr usubst j.uj_val in - let () = feedback_completion_typecheck feedback_id in - def, Opaqueproof.PrivatePolymorphic (Univ.AUContext.size auctx, private_univs) - end in - let def = OpaqueDef proofterm in - let typ = Vars.subst_univs_level_constr usubst tj.utj_val in - { - Cooking.cook_body = def; - cook_type = typ; - cook_universes = Polymorphic auctx; - cook_relevance = Sorts.relevance_of_sort tj.utj_type; - cook_inline = false; - cook_context = Some c.opaque_entry_secctx; - } - - (** Other definitions have to be processed immediately. *) | DefinitionEntry c -> let { const_entry_type = typ; _ } = c in let { const_entry_body = body; const_entry_feedback = feedback_id; _ } = c in - let Pure = trust in let env, usubst, univs = match c.const_entry_universes with | Monomorphic_entry ctx -> let env = push_context_set ~strict:true ctx env in @@ -218,25 +148,66 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = cook_context = c.const_entry_secctx; } +(** Definition is opaque (Qed), so we delay the typing of its body. *) +let infer_opaque env = function + | ({ opaque_entry_type = typ; + opaque_entry_universes = Monomorphic_entry univs; _ } as c) -> + let env = push_context_set ~strict:true univs env in + let { opaque_entry_feedback = feedback_id; _ } = c in + let tyj = Typeops.infer_type env typ in + let context = MonoTyCtx (env, tyj, univs, c.opaque_entry_secctx, feedback_id) in + let def = OpaqueDef () in + { + Cooking.cook_body = def; + cook_type = tyj.utj_val; + cook_universes = Monomorphic univs; + cook_relevance = Sorts.relevance_of_sort tyj.utj_type; + cook_inline = false; + cook_context = Some c.opaque_entry_secctx; + }, context + + | ({ opaque_entry_type = typ; + opaque_entry_universes = Polymorphic_entry (nas, uctx); _ } as c) -> + let { opaque_entry_feedback = feedback_id; _ } = c in + let env = push_context ~strict:false uctx env in + let tj = Typeops.infer_type env typ in + let sbst, auctx = Univ.abstract_universes nas uctx in + let usubst = Univ.make_instance_subst sbst in + let context = PolyTyCtx (env, tj, usubst, auctx, c.opaque_entry_secctx, feedback_id) in + let def = OpaqueDef () in + let typ = Vars.subst_univs_level_constr usubst tj.utj_val in + { + Cooking.cook_body = def; + cook_type = typ; + cook_universes = Polymorphic auctx; + cook_relevance = Sorts.relevance_of_sort tj.utj_type; + cook_inline = false; + cook_context = Some c.opaque_entry_secctx; + }, context + +let check_section_variables env declared_set typ body = + let ids_typ = global_vars_set env typ in + let ids_def = global_vars_set env body in + let inferred_set = Environ.really_needed env (Id.Set.union ids_typ ids_def) in + if not (Id.Set.subset inferred_set declared_set) then + let l = Id.Set.elements (Id.Set.diff inferred_set declared_set) in + let n = List.length l in + let declared_vars = Pp.pr_sequence Id.print (Id.Set.elements declared_set) in + let inferred_vars = Pp.pr_sequence Id.print (Id.Set.elements inferred_set) in + let missing_vars = Pp.pr_sequence Id.print (List.rev l) in + user_err Pp.(prlist str + ["The following section "; (String.plural n "variable"); " "; + (String.conjugate_verb_to_be n); " used but not declared:"] ++ fnl () ++ + missing_vars ++ str "." ++ fnl () ++ fnl () ++ + str "You can either update your proof to not depend on " ++ missing_vars ++ + str ", or you can update your Proof line from" ++ fnl () ++ + str "Proof using " ++ declared_vars ++ fnl () ++ + str "to" ++ fnl () ++ + str "Proof using " ++ inferred_vars) + let build_constant_declaration env result = let open Cooking in let typ = result.cook_type in - let check declared_set inferred_set = - if not (Id.Set.subset inferred_set declared_set) then - let l = Id.Set.elements (Id.Set.diff inferred_set declared_set) in - let n = List.length l in - let declared_vars = Pp.pr_sequence Id.print (Id.Set.elements declared_set) in - let inferred_vars = Pp.pr_sequence Id.print (Id.Set.elements inferred_set) in - let missing_vars = Pp.pr_sequence Id.print (List.rev l) in - user_err Pp.(prlist str - ["The following section "; (String.plural n "variable"); " "; - (String.conjugate_verb_to_be n); " used but not declared:"] ++ fnl () ++ - missing_vars ++ str "." ++ fnl () ++ fnl () ++ - str "You can either update your proof to not depend on " ++ missing_vars ++ - str ", or you can update your Proof line from" ++ fnl () ++ - str "Proof using " ++ declared_vars ++ fnl () ++ - str "to" ++ fnl () ++ - str "Proof using " ++ inferred_vars) in (* We try to postpone the computation of used section variables *) let hyps, def = let context_ids = List.map NamedDecl.get_id (named_context env) in @@ -265,22 +236,10 @@ let build_constant_declaration env result = (* We use the declared set and chain a check of correctness *) declared, match def with - | Undef _ | Primitive _ as x -> x (* nothing to check *) + | Undef _ | Primitive _ | OpaqueDef _ as x -> x (* nothing to check *) | Def cs as x -> - let ids_typ = global_vars_set env typ in - let ids_def = global_vars_set env (Mod_subst.force_constr cs) in - let inferred = Environ.really_needed env (Id.Set.union ids_typ ids_def) in - check declared inferred; - x - | OpaqueDef lc -> (* In this case we can postpone the check *) - let iter k cu = Future.chain cu (fun (c, _ as p) -> k c; p) in - let kont c = - let ids_typ = global_vars_set env typ in - let ids_def = global_vars_set env c in - let inferred = Environ.really_needed env (Id.Set.union ids_typ ids_def) in - check declared inferred - in - OpaqueDef (iter kont lc) + let () = check_section_variables env declared typ (Mod_subst.force_constr cs) in + x in let univs = result.cook_universes in let hyps = List.filter (fun d -> Id.Set.mem (NamedDecl.get_id d) hyps) (Environ.named_context env) in @@ -297,11 +256,46 @@ let build_constant_declaration env result = const_inline_code = result.cook_inline; const_typing_flags = Environ.typing_flags env } +let check_delayed (type a) (handle : a effect_handler) tyenv (body : a proof_output) = match tyenv with +| MonoTyCtx (env, tyj, univs, declared, feedback_id) -> + let ((body, uctx), side_eff) = body in + (* don't redeclare universes which are declared for the type *) + let uctx = Univ.ContextSet.diff uctx univs in + let (body, uctx', valid_signatures) = handle env body side_eff in + let uctx = Univ.ContextSet.union uctx uctx' in + let env = push_context_set uctx env in + let body,env,ectx = skip_trusted_seff valid_signatures body env in + let j = Typeops.infer env body in + let j = unzip ectx j in + let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in + let c = j.uj_val in + let () = check_section_variables env declared tyj.utj_val body in + feedback_completion_typecheck feedback_id; + c, Opaqueproof.PrivateMonomorphic uctx +| PolyTyCtx (env, tj, usubst, auctx, declared, feedback_id) -> + let ((body, ctx), side_eff) = body in + let body, ctx', _ = handle env body side_eff in + let ctx = Univ.ContextSet.union ctx ctx' in + (** [ctx] must contain local universes, such that it has no impact + on the rest of the graph (up to transitivity). *) + let env = push_subgraph ctx env in + let private_univs = on_snd (Univ.subst_univs_level_constraints usubst) ctx in + let j = Typeops.infer env body in + let _ = Typeops.judge_of_cast env j DEFAULTcast tj in + let () = check_section_variables env declared tj.utj_val body in + let def = Vars.subst_univs_level_constr usubst j.uj_val in + let () = feedback_completion_typecheck feedback_id in + def, Opaqueproof.PrivatePolymorphic (Univ.AUContext.size auctx, private_univs) + (*s Global and local constant declaration. *) -let translate_constant mb env _kn ce = +let translate_constant env _kn ce = build_constant_declaration env - (infer_declaration ~trust:mb env ce) + (infer_declaration env ce) + +let translate_opaque env _kn ce = + let def, ctx = infer_opaque env ce in + build_constant_declaration env def, ctx let translate_local_assum env t = let j = Typeops.infer env t in @@ -336,7 +330,7 @@ let translate_local_def env _id centry = const_entry_universes = Monomorphic_entry Univ.ContextSet.empty; const_entry_inline_code = false; } in - let decl = infer_declaration ~trust:Pure env (DefinitionEntry centry) in + let decl = infer_declaration env (DefinitionEntry centry) in let typ = decl.cook_type in let () = match decl.cook_universes with | Monomorphic ctx -> assert (Univ.ContextSet.is_empty ctx) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index ef01ece185..c9f6d66e36 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -22,9 +22,7 @@ open Entries type 'a effect_handler = env -> Constr.t -> 'a -> (Constr.t * Univ.ContextSet.t * int) -type _ trust = -| Pure : unit trust -| SideEffects : 'a effect_handler -> 'a Entries.seff_wrap trust +type typing_context val translate_local_def : env -> Id.t -> section_def_entry -> constr * Sorts.relevance * types @@ -32,15 +30,21 @@ val translate_local_def : env -> Id.t -> section_def_entry -> val translate_local_assum : env -> types -> types * Sorts.relevance val translate_constant : - 'a trust -> env -> Constant.t -> 'a constant_entry -> - Opaqueproof.proofterm constant_body + env -> Constant.t -> constant_entry -> + 'a constant_body + +val translate_opaque : + env -> Constant.t -> 'a opaque_entry -> + unit constant_body * typing_context val translate_recipe : env -> Constant.t -> Cooking.recipe -> Opaqueproof.opaque constant_body +val check_delayed : 'a effect_handler -> typing_context -> 'a proof_output -> (Constr.t * Univ.ContextSet.t Opaqueproof.delayed_universes) + (** Internal functions, mentioned here for debug purpose only *) -val infer_declaration : trust:'a trust -> env -> - 'a constant_entry -> Opaqueproof.proofterm Cooking.result +val infer_declaration : env -> + constant_entry -> typing_context Cooking.result val build_constant_declaration : env -> Opaqueproof.proofterm Cooking.result -> Opaqueproof.proofterm constant_body diff --git a/library/global.ml b/library/global.ml index c4685370d1..98d3e9cb1f 100644 --- a/library/global.ml +++ b/library/global.ml @@ -102,8 +102,9 @@ let typing_flags () = Environ.typing_flags (env ()) let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative 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 export_private_constants cd = globalize (Safe_typing.export_private_constants cd) +let add_constant id d = globalize (Safe_typing.add_constant (i2l id) d) +let add_private_constant id d = globalize (Safe_typing.add_private_constant (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) @@ -111,6 +112,7 @@ 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 sections_are_opened () = Safe_typing.sections_are_opened (safe_env()) 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 c45bf65d84..f8b1f35f4d 100644 --- a/library/global.mli +++ b/library/global.mli @@ -46,12 +46,14 @@ 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 -> +val export_private_constants : Safe_typing.private_constants Entries.proof_output -> Constr.constr Univ.in_universe_context_set * Safe_typing.exported_private_constant list val add_constant : - side_effect:'a Safe_typing.effect_entry -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * 'a + Id.t -> Safe_typing.global_declaration -> Constant.t +val add_private_constant : + Id.t -> Safe_typing.side_effect_declaration -> Constant.t * Safe_typing.private_constants val add_mind : Id.t -> Entries.mutual_inductive_entry -> MutInd.t @@ -80,6 +82,8 @@ 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. *) +val sections_are_opened : unit -> bool + (** Interactive modules and module types *) val start_module : Id.t -> ModPath.t diff --git a/library/lib.ml b/library/lib.ml index 0d9efe2d5d..630c860a61 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -107,7 +107,6 @@ let segment_of_objects prefix = let initial_prefix = Nametab.{ obj_dir = default_library; obj_mp = ModPath.initial; - obj_sec = DirPath.empty; } type lib_state = { @@ -132,10 +131,10 @@ let library_dp () = let cwd () = !lib_state.path_prefix.Nametab.obj_dir let current_mp () = !lib_state.path_prefix.Nametab.obj_mp -let current_sections () = !lib_state.path_prefix.Nametab.obj_sec +let current_sections () = Safe_typing.sections_of_safe_env (Global.safe_env()) -let sections_depth () = List.length (Names.DirPath.repr (current_sections ())) -let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ())) +let sections_depth () = Section.depth (current_sections()) +let sections_are_opened = Global.sections_are_opened let cwd_except_section () = Libnames.pop_dirpath_n (sections_depth ()) (cwd ()) @@ -169,7 +168,6 @@ let pop_path_prefix () = let op = !lib_state.path_prefix in lib_state := { !lib_state with path_prefix = Nametab.{ op with obj_dir = pop_dirpath op.obj_dir; - obj_sec = pop_dirpath op.obj_sec; } } let find_entry_p p = @@ -282,7 +280,7 @@ let current_mod_id () = let start_mod is_type export id mp fs = let dir = add_dirpath_suffix (!lib_state.path_prefix.Nametab.obj_dir) id in - let prefix = Nametab.{ obj_dir = dir; obj_mp = mp; obj_sec = Names.DirPath.empty } in + let prefix = Nametab.{ obj_dir = dir; obj_mp = mp; } in let exists = if is_type then Nametab.exists_cci (make_path id) else Nametab.exists_dir dir @@ -330,9 +328,9 @@ let contents_after sp = let (after,_,_) = split_lib sp in after let start_compilation s mp = if !lib_state.comp_name != None then user_err Pp.(str "compilation unit is already started"); - if not (Names.DirPath.is_empty (!lib_state.path_prefix.Nametab.obj_sec)) then + if Global.sections_are_opened () then (* XXX not sure if we need this check *) user_err Pp.(str "some sections are already opened"); - let prefix = Nametab.{ obj_dir = s; obj_mp = mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir = s; obj_mp = mp } in add_anonymous_entry (CompilingLibrary prefix); lib_state := { !lib_state with comp_name = Some s; path_prefix = prefix } @@ -410,18 +408,12 @@ let find_opening_node id = - the list of substitution to do at section closing *) -type abstr_info = Section.abstr_info = private { - abstr_ctx : Constr.named_context; - abstr_subst : Univ.Instance.t; - abstr_uctx : Univ.AUContext.t; -} - let instance_from_variable_context = List.rev %> List.filter 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 args = instance_from_variable_context info.Section.abstr_ctx in + info.Section.abstr_subst, args let sections () = Safe_typing.sections_of_safe_env @@ Global.safe_env () @@ -443,7 +435,7 @@ let section_segment_of_reference = let open GlobRef in function | VarRef _ -> empty_segment let variable_section_segment_of_reference gr = - (section_segment_of_reference gr).abstr_ctx + (section_segment_of_reference gr).Section.abstr_ctx let is_in_section ref = Section.is_in_section (Global.env ()) ref (sections ()) @@ -465,7 +457,7 @@ 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 + let prefix = Nametab.{ obj_dir; obj_mp = opp.obj_mp; } in if Nametab.exists_dir obj_dir then user_err ~hdr:"open_section" (Id.print id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:false in @@ -559,7 +551,7 @@ let discharge_proj_repr = let _, newpars = Mindmap.find mind (snd modlist) in mind, npars + Array.length newpars) -let discharge_abstract_universe_context { abstr_subst = subst; abstr_uctx = abs_ctx } auctx = +let discharge_abstract_universe_context { Section.abstr_subst = subst; abstr_uctx = abs_ctx } auctx = let open Univ in let ainst = make_abstract_instance auctx in let subst = Instance.append subst ainst in diff --git a/library/lib.mli b/library/lib.mli index 59d77480e9..a313a62c2e 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -95,6 +95,7 @@ val make_kn : Id.t -> KerName.t (** Are we inside an opened section *) val sections_are_opened : unit -> bool +[@@ocaml.deprecated "Use Global.sections_are_opened"] val sections_depth : unit -> int (** Are we inside an opened module type *) @@ -163,18 +164,9 @@ val drop_objects : frozen -> frozen val init : unit -> unit (** {6 Section management for discharge } *) -type abstr_info = Section.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 *) -} - -val section_segment_of_constant : Constant.t -> abstr_info -val section_segment_of_mutual_inductive: MutInd.t -> abstr_info -val section_segment_of_reference : GlobRef.t -> abstr_info +val section_segment_of_constant : Constant.t -> Section.abstr_info +val section_segment_of_mutual_inductive: MutInd.t -> Section.abstr_info +val section_segment_of_reference : GlobRef.t -> Section.abstr_info val variable_section_segment_of_reference : GlobRef.t -> Constr.named_context @@ -189,4 +181,4 @@ val replacement_context : unit -> Opaqueproof.work_list val discharge_proj_repr : Projection.Repr.t -> Projection.Repr.t val discharge_abstract_universe_context : - abstr_info -> Univ.AUContext.t -> Univ.universe_level_subst * Univ.AUContext.t + Section.abstr_info -> Univ.AUContext.t -> Univ.universe_level_subst * Univ.AUContext.t diff --git a/library/nametab.ml b/library/nametab.ml index aed7d08ac1..8626ee1c59 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -18,12 +18,10 @@ open Globnames type object_prefix = { obj_dir : DirPath.t; obj_mp : ModPath.t; - obj_sec : DirPath.t; } let eq_op op1 op2 = DirPath.equal op1.obj_dir op2.obj_dir && - DirPath.equal op1.obj_sec op2.obj_sec && ModPath.equal op1.obj_mp op2.obj_mp (* to this type are mapped DirPath.t's in the nametab *) diff --git a/library/nametab.mli b/library/nametab.mli index 6ee22fc283..55458fe2c6 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -74,7 +74,6 @@ open Globnames type object_prefix = { obj_dir : DirPath.t; obj_mp : ModPath.t; - obj_sec : DirPath.t; } val eq_op : object_prefix -> object_prefix -> bool diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index ea44e748c9..87b9a8eea3 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -196,17 +196,11 @@ GRAMMAR EXTEND Gram [ "200" RIGHTA [ c = binder_constr -> { c } ] | "100" RIGHTA - [ c1 = operconstr; "<:"; c2 = binder_constr -> + [ c1 = operconstr; "<:"; c2 = operconstr LEVEL "200" -> { CAst.make ~loc @@ CCast(c1, CastVM c2) } - | c1 = operconstr; "<:"; c2 = SELF -> - { CAst.make ~loc @@ CCast(c1, CastVM c2) } - | c1 = operconstr; "<<:"; c2 = binder_constr -> - { CAst.make ~loc @@ CCast(c1, CastNative c2) } - | c1 = operconstr; "<<:"; c2 = SELF -> + | c1 = operconstr; "<<:"; c2 = operconstr LEVEL "200" -> { CAst.make ~loc @@ CCast(c1, CastNative c2) } - | c1 = operconstr; ":";c2 = binder_constr -> - { CAst.make ~loc @@ CCast(c1, CastConv c2) } - | c1 = operconstr; ":"; c2 = SELF -> + | c1 = operconstr; ":"; c2 = operconstr LEVEL "200" -> { CAst.make ~loc @@ CCast(c1, CastConv c2) } | c1 = operconstr; ":>" -> { CAst.make ~loc @@ CCast(c1, CastCoerce) } ] @@ -407,9 +401,7 @@ GRAMMAR EXTEND Gram pattern: [ "200" RIGHTA [ ] | "100" RIGHTA - [ p = pattern; ":"; ty = binder_constr -> - {CAst.make ~loc @@ CPatCast (p, ty) } - | p = pattern; ":"; ty = operconstr LEVEL "100" -> + [ p = pattern; ":"; ty = operconstr LEVEL "200" -> {CAst.make ~loc @@ CPatCast (p, ty) } ] | "99" RIGHTA [ ] | "90" RIGHTA [ ] diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml index fba6b7c780..912a20f389 100644 --- a/plugins/extraction/json.ml +++ b/plugins/extraction/json.ml @@ -16,7 +16,10 @@ let json_bool b = if b then str "true" else str "false" let json_global typ ref = - json_str (Common.pp_global typ ref) + if is_custom ref then + json_str (find_custom ref) + else + json_str (Common.pp_global typ ref) let json_id id = json_str (Id.to_string id) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 96a3d00dc2..be9259861a 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -380,7 +380,7 @@ let check_inside_module () = warn_extraction_inside_module () let check_inside_section () = - if Lib.sections_are_opened () then + if Global.sections_are_opened () then err (str "You can't do that within a section." ++ fnl () ++ str "Close it and try again.") diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 6011af74e5..0452665585 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -234,23 +234,6 @@ let change_property_sort evd toSort princ princName = ) (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.Tactics.params) -(* XXX: To be cleaned up soon in favor of common save path. *) -let save name const ?hook uctx scope kind = - let open Declare in - let open DeclareDef in - let fix_exn = Future.fix_exn_of const.Declare.proof_entry_body in - let r = match scope with - | Discharge -> - let c = SectionLocalDef const in - let () = declare_variable ~name ~kind c in - GlobRef.VarRef name - | Global local -> - let kn = declare_constant ~name ~kind ~local (DefinitionEntry const) in - GlobRef.ConstRef kn - in - DeclareDef.Hook.(call ?hook ~fix_exn { S.uctx; obls = []; scope; dref = r }); - definition_message name - let generate_functional_principle (evd: Evd.evar_map ref) interactive_proof old_princ_type sorts new_princ_name funs i proof_tac @@ -307,7 +290,14 @@ let generate_functional_principle (evd: Evd.evar_map ref) Don't forget to close the goal if an error is raised !!!! *) let uctx = Evd.evar_universe_context sigma in - save new_princ_name entry ~hook uctx (DeclareDef.Global Declare.ImportDefaultBehavior) Decls.(IsProof Theorem) + let hook_data = hook, uctx, [] in + let _ : Names.GlobRef.t = DeclareDef.declare_definition + ~name:new_princ_name ~hook_data + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:Decls.(IsProof Theorem) + UnivNames.empty_binders + entry [] in + () with e when CErrors.noncritical e -> raise (Defining_principle e) diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 80fc64fe65..b55d8537d6 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -10,8 +10,6 @@ let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" let mk_equation_id id = Nameops.add_suffix id "_equation" -let msgnl m = () - let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) let fresh_name avoid s = Name (fresh_id avoid s) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index cd5202a6c7..550f727951 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -9,9 +9,6 @@ val mk_correct_id : Id.t -> Id.t val mk_complete_id : Id.t -> Id.t val mk_equation_id : Id.t -> Id.t - -val msgnl : Pp.t -> unit - val fresh_id : Id.t list -> string -> Id.t val fresh_name : Id.t list -> string -> Name.t val get_name : Id.t list -> ?default:string -> Name.t -> Name.t diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 4c5eab1a9b..29356df81d 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1539,13 +1539,7 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref rec_arg_num (EConstr.of_constr rec_arg_type) - (nb_prod evd (EConstr.of_constr res)) relation; - Flags.if_verbose - msgnl (h 1 (Ppconstr.pr_id function_name ++ - spc () ++ str"is defined" )++ fnl () ++ - h 1 (Ppconstr.pr_id equation_id ++ - spc () ++ str"is defined" ) - ) + (nb_prod evd (EConstr.of_constr res)) relation in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) funind_purify (fun () -> diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 9b52b710c1..1b00a93834 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -182,10 +182,6 @@ let mkCLambdaN_simple bl c = match bl with let loc_of_ne_list l = Loc.merge_opt (List.hd l).CAst.loc (List.last l).CAst.loc -let map_int_or_var f = function - | ArgArg x -> ArgArg (f x) - | ArgVar _ as y -> y - let all_concl_occs_clause = { onhyps=Some[]; concl_occs=AllOccurrences } let merge_occurrences loc cl = function @@ -269,7 +265,7 @@ GRAMMAR EXTEND Gram [ [ nl = LIST1 nat_or_var -> { OnlyOccurrences nl } | "-"; n = nat_or_var; nl = LIST0 int_or_var -> (* have used int_or_var instead of nat_or_var for compatibility *) - { AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) } ] ] + { AllOccurrencesBut (List.map (Locusops.or_var_map abs) (n::nl)) } ] ] ; occs: [ [ "at"; occs = occs_nums -> { occs } | -> { AllOccurrences } ] ] diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index b6e7dd64b0..bf5d49f678 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -76,25 +76,21 @@ let subst_and_short_name f (c,n) = (* assert (n=None); *)(* since tacdef are strictly globalized *) (f c,None) -let subst_or_var f = let open Locus in function - | ArgVar _ as x -> x - | ArgArg x -> ArgArg (f x) - let subst_located f = Loc.map f let subst_reference subst = - subst_or_var (subst_located (subst_kn subst)) + Locusops.or_var_map (subst_located (subst_kn subst)) (*CSC: subst_global_reference is used "only" for RefArgType, that propagates to the syntactic non-terminals "global", used in commands such as Print. It is also used for non-evaluable references. *) let subst_global_reference subst = - subst_or_var (subst_located (subst_global_reference subst)) + Locusops.or_var_map (subst_located (subst_global_reference subst)) let subst_evaluable subst = let subst_eval_ref = subst_evaluable_reference subst in - subst_or_var (subst_and_short_name subst_eval_ref) + Locusops.or_var_map (subst_and_short_name subst_eval_ref) let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) diff --git a/plugins/micromega/Fourier_util.v b/plugins/micromega/Fourier_util.v index b62153dee4..95fa5b88df 100644 --- a/plugins/micromega/Fourier_util.v +++ b/plugins/micromega/Fourier_util.v @@ -1,7 +1,7 @@ Require Export Rbase. Require Import Lra. -Open Scope R_scope. +Local Open Scope R_scope. Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. intros x y H H0; try assumption. diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index 7e04fe0220..3351c7ef8a 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -44,9 +44,9 @@ Ltac zchecker_ext := (@eq_refl bool true <: @eq bool (ZTautoCheckerExt __ff __wit) true) (@find Z Z0 __varmap)). -Ltac lia := zify; xlia zchecker_ext. +Ltac lia := PreOmega.zify; xlia zchecker_ext. -Ltac nia := zify; xnlia zchecker. +Ltac nia := PreOmega.zify; xnlia zchecker. (* Local Variables: *) diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index d8282a1127..3651b54ed8 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -41,7 +41,7 @@ Proof. exact Rplus_opp_r. Qed. -Open Scope R_scope. +Local Open Scope R_scope. Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt. Proof. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index 47c77ea927..c160e11467 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -22,8 +22,9 @@ Require FSetPositive FSetEqProperties. Require Import ZCoeff. Require Import Refl. Require Import ZArith. +Require PreOmega. (*Declare ML Module "micromega_plugin".*) -Open Scope Z_scope. +Local Open Scope Z_scope. Ltac flatten_bool := repeat match goal with @@ -100,11 +101,16 @@ Require Import EnvRing. Lemma Zsor : SOR 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt. Proof. - constructor ; intros ; subst ; try (intuition (auto with zarith)). + constructor ; intros ; subst; try reflexivity. apply Zsth. apply Zth. + auto using Z.le_antisymm. + eauto using Z.le_trans. + apply Z.le_neq. destruct (Z.lt_trichotomy n m) ; intuition. + apply Z.add_le_mono_l; assumption. apply Z.mul_pos_pos ; auto. + discriminate. Qed. Lemma ZSORaddon : @@ -195,7 +201,8 @@ Proof. (fun x : N => x) (pow_N 1 Z.mul) env Flhs). 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 Frhs)). - destruct Fop ; simpl; intros ; intuition (auto with zarith). + destruct Fop ; simpl; intros; + intuition auto using Z.le_ge, Z.ge_le, Z.lt_gt, Z.gt_lt. Qed. @@ -489,7 +496,7 @@ Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : boo (* To get a complete checker, the proof format has to be enriched *) Require Import Zdiv. -Open Scope Z_scope. +Local Open Scope Z_scope. Definition ceiling (a b:Z) : Z := let (q,r) := Z.div_eucl a b in @@ -531,7 +538,10 @@ Proof. apply Z.mul_le_mono_pos_l in H; auto with zarith. - assert (0 < Z.pos r) by easy. rewrite Z.add_1_r, Z.le_succ_l. - apply Z.mul_lt_mono_pos_l with a; auto with zarith. + apply Z.mul_lt_mono_pos_l with a. + auto using Z.gt_lt. + eapply Z.lt_le_trans. 2: eassumption. + now apply Z.lt_add_pos_r. - now elim H1. Qed. @@ -627,20 +637,15 @@ Qed. Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0. Proof. - induction p. - simpl. auto with zarith. - simpl. auto. + induction p. 1-2: easy. simpl. case_eq (Zgcd_pol p1). case_eq (Zgcd_pol p3). intros. simpl. unfold ZgcdM. - generalize (Z.gcd_nonneg z1 z2). - generalize (Zmax_spec (Z.gcd z1 z2) 1). - generalize (Z.gcd_nonneg (Z.max (Z.gcd z1 z2) 1) z). - generalize (Zmax_spec (Z.gcd (Z.max (Z.gcd z1 z2) 1) z) 1). - auto with zarith. + apply Z.le_ge; transitivity 1. easy. + apply Z.le_max_r. Qed. Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) -> Zdivide_pol y p. @@ -698,7 +703,7 @@ Proof. induction p. simpl. intros. inversion H. - constructor. replace (c - 0) with c in H1 ; auto with zarith. + constructor. rewrite Z.sub_0_r in *. assumption. intros. constructor. simpl in H. inversion H ; subst; clear H. @@ -735,7 +740,7 @@ Proof. destruct HH2. rewrite H2. apply Zdivide_pol_sub ; auto. - auto with zarith. + apply Z.lt_le_trans with 1. reflexivity. now apply Z.ge_le. destruct HH2. rewrite H2. apply Zdivide_pol_one. unfold ZgcdM in HH1. unfold ZgcdM. @@ -1050,7 +1055,7 @@ Fixpoint bdepth (pf : ZArithProof) : nat := | DoneProof => O | RatProof _ p => S (bdepth p) | CutProof _ p => S (bdepth p) - | EnumProof _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x) O l) + | EnumProof _ _ l => S (List.fold_right (fun pf x => Nat.max (bdepth pf) x) O l) end. Require Import Wf_nat. @@ -1069,19 +1074,19 @@ Proof. unfold ltof. simpl. generalize ( (fold_right - (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat l)). + (fun (pf : ZArithProof) (x : nat) => Nat.max (bdepth pf) x) 0%nat l)). intros. generalize (bdepth y) ; intros. - generalize (Max.max_l n0 n) (Max.max_r n0 n). - auto with zarith. + rewrite Nat.lt_succ_r. apply Nat.le_max_l. generalize (IHl a0 b y H). unfold ltof. simpl. - generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat + generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Nat.max (bdepth pf) x) 0%nat l)). intros. - generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n). - auto with zarith. + eapply lt_le_trans. eassumption. + rewrite <- Nat.succ_le_mono. + apply Nat.le_max_r. Qed. @@ -1113,10 +1118,14 @@ Proof. intros. inv H2. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in *. - apply Zgcd_pol_correct_lt with (env:=env) in H1. - generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g)) H0). - auto with zarith. - auto with zarith. + apply Zgcd_pol_correct_lt with (env:=env) in H1. 2: auto using Z.gt_lt. + apply Z.le_add_le_sub_l, Z.ge_le; rewrite Z.add_0_r. + apply (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g)) H0). + apply Z.le_ge. + rewrite <- Z.sub_0_l. + apply Z.le_sub_le_add_r. + rewrite <- H1. + assumption. (* g <= 0 *) intros. inv H2. auto with zarith. Qed. @@ -1143,7 +1152,7 @@ Proof. case_eq (Z.gtb g 0). intros. rewrite <- Zgt_is_gt_bool in H. - rewrite Zgcd_pol_correct_lt with (1:= H1) in H2; auto with zarith. + rewrite Zgcd_pol_correct_lt with (1:= H1) in H2. 2: auto using Z.gt_lt. unfold nformula_of_cutting_plane. change (eval_pol env (padd e' (Pc z)) = 0). inv H3. @@ -1159,7 +1168,7 @@ Proof. apply Zeq_bool_eq in H0. subst. simpl. rewrite Z.add_0_r, Z.mul_eq_0 in H2. - intuition auto with zarith. + intuition subst; easy. rewrite negb_false_iff in H0. apply Zeq_bool_eq in H0. assert (HH := Zgcd_is_gcd g c). @@ -1168,14 +1177,15 @@ Proof. apply Zdivide_opp_r in H4. rewrite Zdivide_ceiling ; auto. apply Z.sub_move_0_r. - apply Z.div_unique_exact ; auto with zarith. + apply Z.div_unique_exact. now intros ->. + now rewrite Z.add_move_0_r in H2. intros. unfold nformula_of_cutting_plane. inv H3. change (eval_pol env (padd e' (Pc 0)) = 0). rewrite eval_pol_add. simpl. - auto with zarith. + now rewrite Z.add_0_r. (* NonEqual *) intros. inv H0. @@ -1184,7 +1194,7 @@ Proof. unfold nformula_of_cutting_plane. unfold eval_op1 in *. rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). - simpl. auto with zarith. + simpl. now rewrite Z.add_0_r. (* Strict *) destruct p as [[e' z] op]. case_eq (makeCuttingPlane (PsubC Z.sub e 1)). @@ -1193,7 +1203,7 @@ Proof. apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). simpl in *. rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). - auto with zarith. + now apply Z.lt_le_pred. (* NonStrict *) destruct p as [[e' z] op]. case_eq (makeCuttingPlane e). @@ -1220,13 +1230,14 @@ Proof. rewrite negb_true_iff in H. apply Zeq_bool_neq in H. change (eval_pol env p = 0) in H2. - rewrite Zgcd_pol_correct_lt with (1:= H0) in H2; auto with zarith. + rewrite Zgcd_pol_correct_lt with (1:= H0) in H2. 2: auto using Z.gt_lt. set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) in *; clearbody x. contradict H5. - apply Zis_gcd_gcd; auto with zarith. + apply Zis_gcd_gcd. apply Z.lt_le_incl, Z.gt_lt; assumption. constructor; auto with zarith. exists (-x). - rewrite Z.mul_opp_l, Z.mul_comm; auto with zarith. + rewrite Z.mul_opp_l, Z.mul_comm. + now apply Z.add_move_0_l. (**) destruct (makeCuttingPlane p); discriminate. discriminate. @@ -1321,11 +1332,13 @@ Proof. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutR. unfold eval_op1 in HCutR. destruct op1 ; simpl in Hop1 ; try discriminate; - rewrite eval_pol_add in HCutR; simpl in HCutR; auto with zarith. + rewrite eval_pol_add in HCutR; simpl in HCutR. + rewrite Z.add_move_0_l in HCutR; rewrite HCutR, Z.opp_involutive; reflexivity. + now apply Z.le_sub_le_add_r in HCutR. (**) apply is_pol_Z0_eval_pol with (env := env) in HZ0. - rewrite eval_pol_add in HZ0. - replace (eval_pol env p1) with (- eval_pol env p2) by omega. + rewrite eval_pol_add, Z.add_move_r, Z.sub_0_l in HZ0. + rewrite HZ0. apply eval_Psatz_sound with (env:=env) in Hf1 ; auto. apply cutting_plane_sound with (1:= Hf1) in HCutL. unfold nformula_of_cutting_plane in HCutL. @@ -1334,7 +1347,10 @@ Proof. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutL. unfold eval_op1 in HCutL. rewrite eval_pol_add in HCutL. simpl in HCutL. - destruct op2 ; simpl in Hop2 ; try discriminate ; omega. + destruct op2 ; simpl in Hop2 ; try discriminate. + rewrite Z.add_move_r, Z.sub_0_l in HCutL. + now rewrite HCutL, Z.opp_involutive. + now rewrite <- Z.le_sub_le_add_l in HCutL. revert Hfix. match goal with | |- context[?F pf (-z1) z2 = true] => set (FF := F) @@ -1348,26 +1364,24 @@ Proof. generalize (-z1). clear z1. intro z1. revert z1 z2. induction pf;simpl ;intros. - generalize (Zgt_cases z1 z2). - destruct (Z.gtb z1 z2). - intros. - apply False_ind ; omega. - discriminate. + revert Hfix. + now case (Z.gtb_spec); [ | easy ]; intros LT; elim (Zlt_not_le _ _ LT); transitivity x. flatten_bool. - assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega. - destruct HH. - subst. - exists a ; auto. - assert (z1 + 1 <= x <= z2)%Z by omega. - elim IHpf with (2:=H2) (3:= H4). - destruct H4. + destruct (Z_le_lt_eq_dec _ _ (proj1 H0)) as [ LT | -> ]. + 2: exists a; auto. + rewrite <- Z.le_succ_l in LT. + assert (LE: (Z.succ z1 <= x <= z2)%Z) by intuition. + elim IHpf with (2:=H2) (3:= LE). intros. exists x0 ; split;tauto. intros until 1. apply H ; auto. unfold ltof in *. simpl in *. - zify. omega. + PreOmega.zify. + intuition subst. assumption. + eapply Z.lt_le_trans. eassumption. + apply Z.add_le_mono_r. assumption. (*/asser *) destruct (HH _ H1) as [pr [Hin Hcheker]]. assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False). diff --git a/plugins/micromega/Zify.v b/plugins/micromega/Zify.v index 57d812b0fd..785a53fafa 100644 --- a/plugins/micromega/Zify.v +++ b/plugins/micromega/Zify.v @@ -87,4 +87,4 @@ Ltac applySpec S := (** [zify_post_hook] is there to be redefined. *) Ltac zify_post_hook := idtac. -Ltac zify := zify_tac ; (iter_specs applySpec) ; zify_post_hook. +Ltac zify := zify_op ; (iter_specs applySpec) ; zify_post_hook. diff --git a/plugins/micromega/ZifyBool.v b/plugins/micromega/ZifyBool.v index ec37c2003f..b94b74097b 100644 --- a/plugins/micromega/ZifyBool.v +++ b/plugins/micromega/ZifyBool.v @@ -8,8 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) Require Import Bool ZArith. -Require Import ZifyClasses. -Open Scope Z_scope. +Require Import Zify ZifyClasses. +Local 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. @@ -42,6 +42,16 @@ Instance Op_orb : BinOp orb := TBOpInj := ltac:(destruct n,m; reflexivity)}. Add BinOp Op_orb. +Instance Op_implb : BinOp implb := + { TBOp := fun x y => Z.max (1 - x) y; + TBOpInj := ltac:(destruct n,m; reflexivity) }. +Add BinOp Op_implb. + +Instance Op_xorb : BinOp xorb := + { TBOp := fun x y => Z.max (x - y) (y - x); + TBOpInj := ltac:(destruct n,m; reflexivity) }. +Add BinOp Op_xorb. + Instance Op_negb : UnOp negb := { TUOp := fun x => 1 - x ; TUOpInj := ltac:(destruct x; reflexivity)}. Add UnOp Op_negb. @@ -52,10 +62,11 @@ Add BinRel Op_eq_bool. Instance Op_true : CstOp true := { TCst := 1 ; TCstInj := eq_refl }. +Add CstOp Op_true. Instance Op_false : CstOp false := { TCst := 0 ; TCstInj := eq_refl }. - +Add CstOp Op_false. (** Comparisons are encoded using the predicates [isZero] and [isLeZero].*) @@ -222,19 +233,23 @@ Add BinOp Op_nat_ltb. (** Injected boolean operators *) -Lemma Z_eqb_ZSpec_ok : forall x, x <> isZero x. +Lemma Z_eqb_ZSpec_ok : forall x, 0 <= isZero x <= 1 /\ + (x = 0 <-> isZero x = 1). Proof. intros. unfold isZero. destruct (x =? 0) eqn:EQ. - apply Z.eqb_eq in EQ. - simpl. congruence. + simpl. intuition try congruence; + compute ; congruence. - apply Z.eqb_neq in EQ. - simpl. auto. + simpl. intuition try congruence; + compute ; congruence. Qed. + Instance Z_eqb_ZSpec : UnOpSpec isZero := - {| UPred := fun n r => n <> r ; USpec := Z_eqb_ZSpec_ok |}. + {| UPred := fun n r => 0 <= r <= 1 /\ (n = 0 <-> isZero n = 1) ; 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. diff --git a/plugins/micromega/ZifyComparison.v b/plugins/micromega/ZifyComparison.v new file mode 100644 index 0000000000..8a8b40ded8 --- /dev/null +++ b/plugins/micromega/ZifyComparison.v @@ -0,0 +1,81 @@ +(************************************************************************) +(* * 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. +Local Open Scope Z_scope. + +(** [Z_of_comparison] is the injection function for comparison *) +Definition Z_of_comparison (c : comparison) : Z := + match c with + | Lt => -1 + | Eq => 0 + | Gt => 1 + end. + +Lemma Z_of_comparison_bound : forall x, -1 <= Z_of_comparison x <= 1. +Proof. + destruct x ; simpl; compute; intuition congruence. +Qed. + +Instance Inj_comparison_Z : InjTyp comparison Z := + { inj := Z_of_comparison ; pred :=(fun x => -1 <= x <= 1) ; cstr := Z_of_comparison_bound}. +Add InjTyp Inj_comparison_Z. + +Definition ZcompareZ (x y : Z) := + Z_of_comparison (Z.compare x y). + +Program Instance BinOp_Zcompare : BinOp Z.compare := + { TBOp := ZcompareZ }. +Add BinOp BinOp_Zcompare. + +Instance Op_eq_comparison : BinRel (@eq comparison) := + {TR := @eq Z ; TRInj := ltac:(destruct n,m; simpl ; intuition congruence) }. +Add BinRel Op_eq_comparison. + +Instance Op_Eq : CstOp Eq := + { TCst := 0 ; TCstInj := eq_refl }. +Add CstOp Op_Eq. + +Instance Op_Lt : CstOp Lt := + { TCst := -1 ; TCstInj := eq_refl }. +Add CstOp Op_Lt. + +Instance Op_Gt : CstOp Gt := + { TCst := 1 ; TCstInj := eq_refl }. +Add CstOp Op_Gt. + + +Lemma Zcompare_spec : forall x y, + (x = y -> ZcompareZ x y = 0) + /\ + (x > y -> ZcompareZ x y = 1) + /\ + (x < y -> ZcompareZ x y = -1). +Proof. + unfold ZcompareZ. + intros. + destruct (x ?= y) eqn:C; simpl. + - rewrite Z.compare_eq_iff in C. + intuition. + - rewrite Z.compare_lt_iff in C. + intuition. + - rewrite Z.compare_gt_iff in C. + intuition. +Qed. + +Instance ZcompareSpec : BinOpSpec ZcompareZ := + {| BPred := fun x y r => (x = y -> r = 0) + /\ + (x > y -> r = 1) + /\ + (x < y -> r = -1) + ; BSpec := Zcompare_spec|}. +Add Spec ZcompareSpec. diff --git a/plugins/micromega/ZifyInst.v b/plugins/micromega/ZifyInst.v index 1217e8a5f7..afd7101667 100644 --- a/plugins/micromega/ZifyInst.v +++ b/plugins/micromega/ZifyInst.v @@ -15,7 +15,7 @@ Require Import Arith Max Min BinInt BinNat Znat Nnat. Require Import ZifyClasses. Declare ML Module "zify_plugin". -Open Scope Z_scope. +Local Open Scope Z_scope. (** Propositional logic *) Instance PropAnd : PropOp and. @@ -119,6 +119,7 @@ Add UnOp Op_S. Instance Op_O : CstOp O := {| TCst := Z0 ; TCstInj := eq_refl (Z.of_nat 0) |}. +Add CstOp Op_O. Instance Op_Z_abs_nat : UnOp Z.abs_nat := { TUOp := Z.abs ; TUOpInj := Zabs2Nat.id_abs }. @@ -409,13 +410,34 @@ Add UnOp Op_Z_to_nat. (** Specification of derived operators over Z *) +Lemma z_max_spec : forall n m, + n <= Z.max n m /\ m <= Z.max n m /\ (Z.max n m = n \/ Z.max n m = m). +Proof. + intros. + generalize (Z.le_max_l n m). + generalize (Z.le_max_r n m). + generalize (Z.max_spec_le n m). + intuition idtac. +Qed. + 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|}. +Lemma z_min_spec : forall n m, + Z.min n m <= n /\ Z.min n m <= m /\ (Z.min n m = n \/ Z.min n m = m). +Proof. + intros. + generalize (Z.le_min_l n m). + generalize (Z.le_min_r n m). + generalize (Z.min_spec_le n m). + intuition idtac. +Qed. + + +Program Instance ZminSpec : BinOpSpec Z.min := + {| BPred := fun n m r => n < m /\ r = n \/ m <= n /\ r = m ; + BSpec := Z.min_spec |}. Add Spec ZminSpec. Instance ZsgnSpec : UnOpSpec Z.sgn := diff --git a/plugins/micromega/g_zify.mlg b/plugins/micromega/g_zify.mlg index 424a7d7c54..66f263c0b1 100644 --- a/plugins/micromega/g_zify.mlg +++ b/plugins/micromega/g_zify.mlg @@ -26,7 +26,7 @@ VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF | ["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" "PropUOp" constr(t) ] -> { Zify.PropUnOp.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 } @@ -38,7 +38,7 @@ TACTIC EXTEND ITER END TACTIC EXTEND TRANS -| [ "zify_tac" ] -> { Zify.zify_tac } +| [ "zify_op" ] -> { Zify.zify_tac } | [ "saturate" ] -> { Zify.saturate } END diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 39905f8c52..cca66c0719 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -106,12 +106,15 @@ let extract_best red lt l = | Some(c,e), rst -> extractb c e [] rst -let rec find_some pred l = +let rec find_option pred l = match l with - | [] -> None + | [] -> raise Not_found | e::l -> match pred e with - | Some r -> Some r - | None -> find_some pred l + | Some r -> r + | None -> find_option pred l + +let find_some pred l = + try Some (find_option pred l) with Not_found -> None let extract_all pred l = diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index be6037ccdb..0a57677220 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -24,27 +24,13 @@ 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 +let rec find_option pred l = match l with - | [] -> assert false - | [t1; t2; t3] -> Some (t1, t2, t3) - | _ -> None + | [] -> raise Not_found + | e::l -> match pred e with + | Some r -> r + | None -> find_option pred l -(** [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. @@ -57,6 +43,8 @@ module HConstr = struct Constr.compare (unsafe_to_constr c) (unsafe_to_constr c') end) + type 'a t = 'a list M.t + let lfind h m = try M.find h m with Not_found -> [] let add h e m = @@ -72,27 +60,23 @@ module HConstr = struct 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 +let get_projections_from_constant (evd, i) = + match EConstr.kind evd (Reductionops.clos_whd_flags CClosure.all (Global.env ()) evd i) with + | App (c, a) -> Some a + | _ -> + raise (CErrors.user_err Pp.(str "The hnf of term " ++ pr_constr (Global.env ()) evd i + ++ str " should be an application i.e. (c a1 ... an)")) + (** An instance of type, say T, is registered into a hashtable, say TableT. *) type 'a decl = @@ -101,34 +85,111 @@ type 'a decl = 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 EInjT = struct + type t = + { 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) *) } +end +module EBinOpT = struct + type t = + { (* Op : source1 -> source2 -> source3 *) + source1: EConstr.t + ; source2: EConstr.t + ; source3: EConstr.t + ; target: EConstr.t + ; inj1: EConstr.t + ; (* InjTyp source1 target *) + inj2: EConstr.t + ; (* InjTyp source2 target *) + inj3: EConstr.t + ; (* InjTyp source3 target *) + tbop: EConstr.t + (* TBOpInj *) } +end +module ECstOpT = struct + type t = {source: EConstr.t; target: EConstr.t; inj: EConstr.t} +end +module EUnOpT = struct + type t = + { source1: EConstr.t + ; source2: EConstr.t + ; target: EConstr.t + ; inj1_t: EConstr.t + ; inj2_t: EConstr.t + ; unop: EConstr.t } +end + +module EBinRelT = struct + type t = + {source: EConstr.t; target: EConstr.t; inj: EConstr.t; brel: EConstr.t} +end + +module EPropBinOpT = struct + type t = EConstr.t +end + +module EPropUnOpT = struct + type t = EConstr.t +end + + +module ESatT = struct + type t = {parg1: EConstr.t; parg2: EConstr.t; satOK: EConstr.t} +end + +(* Different type of declarations *) +type decl_kind = + | PropOp of EPropBinOpT.t decl + | PropUnOp of EPropUnOpT.t decl + | InjTyp of EInjT.t decl + | BinRel of EBinRelT.t decl + | BinOp of EBinOpT.t decl + | UnOp of EUnOpT.t decl + | CstOp of ECstOpT.t decl + | Saturate of ESatT.t decl + + +let get_decl = function + | PropOp d -> d.decl + | PropUnOp d -> d.decl + | InjTyp d -> d.decl + | BinRel d -> d.decl + | BinOp d -> d.decl + | UnOp d -> d.decl + | CstOp d -> d.decl + | Saturate d -> d.decl + +type term_kind = + | Application of EConstr.constr + | OtherTerm of EConstr.constr module type Elt = sig type elt - val name : decl_kind - (** [name] of the table *) + val name : string + (** name *) + + val table : (term_kind * decl_kind) HConstr.t ref + + val cast : elt decl -> decl_kind + + val dest : decl_kind -> (elt decl) option val get_key : int (** [get_key] is the type-index used as key for the instance *) @@ -138,128 +199,36 @@ module type Elt = sig 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 arity : int*) - 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 table = Summary.ref ~name:("zify_table") 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 saturate = Summary.ref ~name:("zify_saturate") HConstr.empty - let get evd c = - let c' = E.reduce_term evd c in - HConstr.find c' !table +let table_cache = ref HConstr.empty +let saturate_cache = ref HConstr.empty - 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 +(** Each type-class gives rise to a different table. + They only differ on how projections are extracted. *) +module EInj = struct + open EInjT - exception FoundNorm of EConstr.t + type elt = EInjT.t - let can_unify evd k t = - try - let _ = Unification.w_unify (Global.env ()) evd Reduction.CONV k t in - true ; - with _ -> false + let name = "EInj" - 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 table = table + let cast x = InjTyp x - 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 dest = function + | InjTyp x -> Some x + | _ -> None - 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 @@ -272,40 +241,15 @@ module InjElt = struct 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 *) } + type elt = EBinOpT.t + open EBinOpT + + let name = "BinOp" - let name = BinOp + let table = table let mk_elt evd i a = { source1= a.(0) @@ -319,34 +263,50 @@ module EBinOp = struct let get_key = 4 - let reduce_term evd t = t + + let cast x = BinOp x + + let dest = function + | BinOp x -> Some x + | _ -> None end module ECstOp = struct - type elt = {source: EConstr.t; target: EConstr.t; inj: EConstr.t} + type elt = ECstOpT.t + open ECstOpT + + let name = "CstOp" + + let table = table + + let cast x = CstOp x + + let dest = function + | CstOp x -> Some x + | _ -> None - let 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 } + type elt = EUnOpT.t + open EUnOpT + + let name = "UnOp" + + let table = table + + let cast x = UnOp x + + let dest = function + | UnOp x -> Some x + | _ -> None - let name = UnOp let mk_elt evd i a = { source1= a.(0) @@ -358,72 +318,202 @@ module EUnOp = struct 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} + type elt = EBinRelT.t + open EBinRelT + + let name = "BinRel" + + let table = table + + let cast x = BinRel x - let name = BinRel + let dest = function + | BinRel x -> Some x + | _ -> None let mk_elt evd i a = {source= a.(0); target= a.(1); inj= a.(3); brel= a.(4)} let get_key = 2 +end + +module EPropOp = struct + type elt = EConstr.t + + let name = "PropBinOp" - (** [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 + let table = table + + let cast x = PropOp x + + let dest = function + | PropOp x -> Some x + | _ -> None + + let mk_elt evd i a = i + + let get_key = 0 end -module EPropOp = struct +module EPropUnOp = struct type elt = EConstr.t - let name = PropOp + let name = "PropUnOp" + + let table = table + + let cast x = PropUnOp x + + let dest = function + | PropUnOp x -> Some x + | _ -> None let mk_elt evd i a = i let get_key = 0 - let reduce_term evd t = t +end + + + +let constr_of_term_kind = function + | Application c -> c + | OtherTerm c -> c + + +let fold_declared_const f evd acc = + HConstr.fold + (fun _ (_,e) acc -> f (fst (EConstr.destConst evd (get_decl e))) acc) + (!table_cache) acc + + + +module type S = sig + val register : Constrexpr.constr_expr -> unit + + val print : unit -> unit end -module ESat = struct - type elt = {parg1: EConstr.t; parg2: EConstr.t; satOK: EConstr.t} - let name = Saturate +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 mk_elt evd i a = {parg1= a.(2); parg2= a.(3); satOK= a.(5)} + 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 register_hint evd t elt = + match EConstr.kind evd t with + | App(c,_) -> + E.table := HConstr.add c (Application t, E.cast elt) !E.table + | _ -> E.table := HConstr.add t (OtherTerm t, E.cast elt) !E.table - let get_key = 1 - let reduce_term evd t = t + + + let register_constr env evd c = + let c = EConstr.of_constr c in + let t = get_type_of env evd c in + match EConstr.kind evd t with + | App (intyp, args) -> + let styp = args.(E.get_key) in + let elt = {decl= c; deriv= (make_elt (evd, c))} in + register_hint evd styp elt + | _ -> + let env = Global.env () in + raise (CErrors.user_err Pp. + (str ": Cannot register term "++pr_constr env evd c++ + str ". It has type "++pr_constr env evd t++str " which should be of the form [F X1 .. Xn]")) + + let register_obj : Constr.constr -> Libobject.obj = + let cache_constr (_, c) = + let env = Global.env () in + let evd = Evd.from_env env in + register_constr env evd c + in + let subst_constr (subst, c) = Mod_subst.subst_mps subst c in + Libobject.declare_object + @@ Libobject.superglobal_object_nodischarge + ("register-zify-" ^ 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 = fun c -> + let env = Global.env () in + let evd = Evd.from_env env in + let evd, c = Constrintern.interp_open_constr env evd c in + let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in + () + + + let pp_keys () = + let env = Global.env () in + let evd = Evd.from_env env in + HConstr.fold + (fun _ (k,d) acc -> + match E.dest d with + | None -> acc + | Some _ -> + Pp.(pr_constr env evd (constr_of_term_kind k) ++ str " " ++ acc)) + (!E.table) (Pp.str "") + + + let print () = Feedback.msg_info (pp_keys ()) end +module InjTable = MakeTable (EInj) + + +module ESat = struct + type elt = ESatT.t + open ESatT + + let name = "Saturate" + + let table = saturate + + let cast x = Saturate x + + let dest = function + | Saturate x -> Some x + | _ -> None + + let mk_elt evd i a = {parg1= a.(2); parg2= a.(3); satOK= a.(5)} + + let get_key = 1 + +end module BinOp = MakeTable (EBinOp) module UnOp = MakeTable (EUnOp) module CstOp = MakeTable (ECstOp) module BinRel = MakeTable (EBinRel) module PropOp = MakeTable (EPropOp) +module PropUnOp = MakeTable (EPropUnOp) module Saturate = MakeTable (ESat) - +let init_cache () = + table_cache := !table; + saturate_cache := !saturate (** The module [Spec] is used to register @@ -467,37 +557,11 @@ module Spec = struct 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 + fold_declared_const f evd [] -open InjElt +open EInjT (** Get constr of lemma and projections in ZifyClasses. *) @@ -545,7 +609,7 @@ let iff = lazy (zify "iff") let to_unfold = lazy - (List.map locate_const + (List.rev_map locate_const [ "source_prop" ; "target_prop" ; "uop_iff" @@ -567,6 +631,7 @@ let to_unfold = ; "mkapp0" ; "mkprop_op" ]) + (** Module [CstrTable] records terms [x] injected into [inj x] together with the corresponding type constraint. The terms are stored by side-effect during the traversal @@ -585,7 +650,7 @@ module CstrTable = struct let table : EConstr.t HConstr.t = HConstr.create 10 - let register evd t (i : EConstr.t) = HConstr.replace table t i + let register evd t (i : EConstr.t) = HConstr.add table t i let get () = let l = HConstr.fold (fun k i acc -> (k, i) :: acc) table [] in @@ -601,7 +666,7 @@ module CstrTable = struct let has_hyp = let hyps_table = HConstr.create 20 in List.iter - (fun (_, (t : EConstr.types)) -> HConstr.replace hyps_table t ()) + (fun (_, (t : EConstr.types)) -> HConstr.add hyps_table t ()) (Tacmach.New.pf_hyps_types gl) ; fun c -> HConstr.mem hyps_table c in @@ -641,9 +706,9 @@ let mkvar red evd inj v = ; EConstr.mkApp (force eq_refl, [|inj.target; iv|]) |] ) type texpr = - | Var of InjElt.elt * EConstr.t + | Var of EInj.elt * EConstr.t (** Var is a term that cannot be injected further *) - | Constant of InjElt.elt * EConstr.t + | Constant of EInj.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] *) @@ -667,7 +732,7 @@ let mkapp2_id evd i (* InjTyp S3 T *) let default () = let e1' = inj_term_of_texpr evd e1 in let e2' = inj_term_of_texpr evd e2 in - EBinOp.( + EBinOpT.( Injterm (EConstr.mkApp ( force mkapp2 @@ -694,7 +759,7 @@ let mkapp2_id evd i (* InjTyp S3 T *) | _, _ -> default () let mkapp_id evd i inj (unop, u) f e1 = - if EConstr.eq_constr evd u.unop f then + EUnOpT.(if EConstr.eq_constr evd u.unop f then (* Injection does nothing *) match e1 with | Constant (_, e) | Var (_, e) -> Var (inj, EConstr.mkApp (f, [|e|])) @@ -716,61 +781,109 @@ let mkapp_id evd i inj (unop, u) f e1 = (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 = + + +let get_injection env evd t = + match snd (HConstr.find t !table_cache) with + | InjTyp i -> i + | _ -> raise Not_found + + + (* [arrow] is the term (fun (x:Prop) (y : Prop) => x -> y) *) + let arrow = + let name x = + Context.make_annot (Name.mk_name (Names.Id.of_string x)) Sorts.Relevant in + EConstr.mkLambda + ( name "x" + , EConstr.mkProp + , EConstr.mkLambda + ( name "y" + , EConstr.mkProp + , EConstr.mkProd + ( Context.make_annot Names.Anonymous Sorts.Relevant + , EConstr.mkRel 2 + , EConstr.mkRel 2 ) ) ) + + + let is_prop env sigma term = + let sort = Retyping.get_sort_of env sigma term in + Sorts.is_prop sort + + (** [get_application env evd e] expresses [e] as an application (c a) + where c is the head symbol and [a] is the array of arguments. + The function also transforms (x -> y) as (arrow x y) *) + let get_operator env evd e = + let is_arrow a p1 p2 = + is_prop env evd p1 && is_prop (EConstr.push_rel (Context.Rel.Declaration.LocalAssum(a,p1)) env) evd p2 + && (a.Context.binder_name = Names.Anonymous || EConstr.Vars.noccurn evd 1 p2) in + match EConstr.kind evd e with + | Prod (a, p1, p2) when is_arrow a p1 p2 -> + (arrow,[|p1 ;p2|]) + | App(c,a) -> (c,a) + | _ -> (e,[||]) + + + let is_convertible env evd k t = + Reductionops.check_conv env evd k t + + (** [match_operator env evd hd arg (t,d)] + - hd is head operator of t + - If t = OtherTerm _, then t = hd + - If t = Application _, then + we extract the relevant number of arguments from arg + and check for convertibility *) + let match_operator env evd hd args (t, d) = + let decomp t i = + let n = Array.length args in + let t' = EConstr.mkApp(hd,Array.sub args 0 (n-i)) in + if is_convertible env evd t' t + then Some (d,t) + else None in + + match t with + | OtherTerm t -> Some(d,t) + | Application t -> + match d with + | CstOp _ -> decomp t 0 + | UnOp _ -> decomp t 1 + | BinOp _ -> decomp t 2 + | BinRel _ -> decomp t 2 + | PropOp _ -> decomp t 2 + | PropUnOp _ -> decomp t 1 + | _ -> None + + + let rec trans_expr env evd e = (* Get the injection *) - let {decl= i; deriv= inj} = InjTable.get evd e.typ in + let {decl= i; deriv= inj} = get_injection env evd e.typ in let e = e.constr in if EConstr.isConstruct evd e then Constant (inj, e) (* Evaluate later *) else + let (c,a) = get_operator env evd e in 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 (k,t) = find_option (match_operator env evd c a) (HConstr.find_all c !table_cache) in + let n = Array.length a in + match k with + | CstOp {decl = c'} -> + Injterm (EConstr.mkApp (force mkapp0, [|inj.source; inj.target; e; i; c'|])) + | UnOp {decl = unop ; deriv = u} -> + let a' = trans_expr env evd {constr= a.(n-1); typ= u.EUnOpT.source1} in + if is_constant a' && EConstr.isConstruct evd t then + Constant (inj, e) + else mkapp_id evd i inj (unop, u) t a' + | BinOp {decl = binop ; deriv = b} -> + let a0 = trans_expr env evd {constr= a.(n-2); typ= b.EBinOpT.source1} in + let a1 = trans_expr env evd {constr= a.(n-1); typ= b.EBinOpT.source2} in + if is_constant a0 && is_constant a1 && EConstr.isConstruct evd t + then Constant (inj, e) + else mkapp2_id evd i inj t binop b a0 a1 + | d -> + Var (inj,e) + with Not_found -> Var (inj,e) let trans_expr env evd e = try trans_expr env evd e with Not_found -> @@ -779,68 +892,6 @@ let trans_expr env evd e = ( 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 *) @@ -852,47 +903,42 @@ let mk_iprop e = let inj_prop_of_tprop = function TProp p -> p | IProp e -> mk_iprop e let rec trans_prop env evd e = - 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 + let (c,a) = get_operator env evd e in + try + let (k,t) = find_option (match_operator env evd c a) (HConstr.find_all c !table_cache) in + let n = Array.length a in + match k with + | PropOp {decl= rop} -> + begin + try + let t1 = trans_prop env evd a.(n-2) in + let t2 = trans_prop env evd a.(n-1) in + match (t1, t2) with | IProp _, IProp _ -> IProp e | _, _ -> - let t1 = inj_prop_of_tprop t1 in + let 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 + TProp (EConstr.mkApp (force mkprop_op, [|t; rop; t1; t2|])) + with Not_found -> IProp e + end + | BinRel {decl = br ; deriv = rop} -> + begin + try + let a1 = trans_expr env evd {constr = a.(n-2) ; typ = rop.EBinRelT.source} in + let a2 = trans_expr env evd {constr = a.(n-1) ; typ = rop.EBinRelT.source} in + if EConstr.eq_constr evd t rop.EBinRelT.brel then match (constr_of_texpr a1, constr_of_texpr a2) with - | Some e1, Some e2 -> IProp (EConstr.mkApp (r, [|e1; e2|])) + | Some e1, Some e2 -> IProp (EConstr.mkApp (t, [|e1; e2|])) | _, _ -> let a1 = inj_term_of_texpr evd a1 in let a2 = inj_term_of_texpr evd a2 in TProp (EConstr.mkApp ( force mkrel - , [| rop.EBinRel.source - ; rop.EBinRel.target - ; r - ; rop.EBinRel.inj + , [| rop.EBinRelT.source + ; rop.EBinRelT.target + ; t + ; rop.EBinRelT.inj ; br ; a1 ; a2 |] )) @@ -902,37 +948,35 @@ let rec trans_prop env evd e = TProp (EConstr.mkApp ( force mkrel - , [| rop.EBinRel.source - ; rop.EBinRel.target - ; r - ; rop.EBinRel.inj + , [| rop.EBinRelT.source + ; rop.EBinRelT.target + ; t + ; rop.EBinRelT.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 + end + | PropUnOp {decl = rop} -> + begin + try + let t1 = trans_prop env evd a.(n-1) in + match t1 with + | IProp _ -> IProp e + | _ -> + let t1 = inj_prop_of_tprop t1 in + TProp (EConstr.mkApp (force mkuprop_op, [|t; rop; t1|])) + with Not_found -> IProp e + end + | _ -> IProp e + with Not_found -> 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))) + (fBETA :: fMATCH :: fFIX :: fCOFIX :: fZETA :: List.rev_map fCONST l))) in let unfold_decl = unfold_decl evd in (* Unfold the let binding *) @@ -943,7 +987,7 @@ let unfold n env evd c = 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 + let c = cbv (List.rev_append (force to_unfold) unfold_decl) env evd c in c let trans_check_prop env evd t = @@ -1029,7 +1073,7 @@ 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 (); + init_cache (); 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 @@ -1038,12 +1082,12 @@ let zify_tac = tclTHENOpt concl trans_concl (Tacticals.New.tclTHEN (Tacticals.New.tclTHENLIST - (List.map (fun (h, p, t) -> trans_hyp h p t) hyps)) + (List.rev_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 ()) []) + (List.fold_left (fun acc d -> tac d :: acc) [] (Spec.get ())) let iter_specs (tac: Ltac_plugin.Tacinterp.Value.t) = @@ -1063,11 +1107,11 @@ let sat_constr c d = if Array.length args = 2 then ( let h1 = Tacred.cbv_beta env evd - (EConstr.mkApp (d.ESat.parg1, [|args.(0)|])) + (EConstr.mkApp (d.ESatT.parg1, [|args.(0)|])) in let h2 = Tacred.cbv_beta env evd - (EConstr.mkApp (d.ESat.parg2, [|args.(1)|])) + (EConstr.mkApp (d.ESatT.parg2, [|args.(1)|])) in match (find_hyp evd h1 hyps, find_hyp evd h2 hyps) with | Some h1, Some h2 -> @@ -1078,7 +1122,7 @@ let sat_constr c d = in let trm = EConstr.mkApp - ( d.ESat.satOK + ( d.ESatT.satOK , [|args.(0); args.(1); EConstr.mkVar h1; EConstr.mkVar h2|] ) in @@ -1087,20 +1131,28 @@ let sat_constr c d = else Tacticals.New.tclIDTAC | _ -> Tacticals.New.tclIDTAC ) + +let get_all_sat env evd c = + List.fold_left (fun acc e -> + match e with + | (_,Saturate s) -> s::acc + | _ -> acc) [] (HConstr.find_all c !saturate_cache ) + let saturate = Proofview.Goal.enter (fun gl -> + init_cache (); 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 env = Tacmach.New.pf_env gl in 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 + let ds = get_all_sat env evd c in if ds = [] then () else ( List.iter (fun x -> CstrTable.HConstr.add table t x.deriv) ds ) diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli index f7844f53bc..54e8f07ddc 100644 --- a/plugins/micromega/zify.mli +++ b/plugins/micromega/zify.mli @@ -17,6 +17,7 @@ module BinOp : S module CstOp : S module BinRel : S module PropOp : S +module PropUnOp : S module Spec : S module Saturate : S diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 76c393450b..e3e787df2c 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -139,8 +139,8 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" let ic c = let env = Global.env() in let sigma = Evd.from_env env in - let sigma, c = Constrintern.interp_open_constr env sigma c in - (sigma, c) + let c, uctx = Constrintern.interp_constr env sigma c in + (Evd.from_ctx uctx, c) let ic_unsafe c = (*FIXME remove *) let env = Global.env() in diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index dc774e811e..b8affba541 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -56,6 +56,10 @@ Require Import ssreflect. Structure inference, as in the implementation of the mxdirect predicate in matrix.v. + - The empty type: + void == a notation for the Empty_set type of the standard library. + of_void T == the canonical injection void -> T. + - Sigma types: tag w == the i of w : {i : I & T i}. tagged w == the T i component of w : {i : I & T i}. @@ -483,6 +487,12 @@ Arguments idfun {T} x /. Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. +(** The empty type. **) + +Notation void := Empty_set. + +Definition of_void T (x : void) : T := match x with end. + (** Strong sigma types. **) Section Tag. @@ -642,6 +652,9 @@ End Injections. Lemma Some_inj {T : nonPropType} : injective (@Some T). Proof. by move=> x y []. Qed. +Lemma of_voidK T : pcancel (of_void T) [fun _ => None]. +Proof. by case. Qed. + (** cancellation lemmas for dependent type casts. **) Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). Proof. by case: y /. Qed. diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 66db924051..70c1077106 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -102,7 +102,7 @@ let bigint_of_z c = match DAst.get c with let rdefinitions = ["Coq";"Reals";"Rdefinitions"] let r_modpath = MPfile (make_dir rdefinitions) let r_base_modpath = MPdot (r_modpath, Label.make "RbaseSymbolsImpl") -let r_path = make_path rdefinitions "R" +let r_path = make_path ["Coq";"Reals";"Rdefinitions";"RbaseSymbolsImpl"] "R" let glob_IZR = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") let glob_Rmult = GlobRef.ConstRef (Constant.make2 r_base_modpath @@ Label.make "Rmult") diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index d49a39b547..aebe47a7a7 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -166,7 +166,7 @@ let interp_ltac_variable ?loc typing_fun env sigma id : Evd.evar_map * unsafe_ju here, as the call to the main pretyping function is caught inside the try but I want to avoid refactoring this function too much for now. *) - typing_fun {env with lvar} term + typing_fun {env with lvar; static_env = env.renamed_env} term with Not_found -> (* Check if [id] is a ltac variable not bound to a term *) (* and build a nice error message *) diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index 02c8f6a2a8..9c6cf090a2 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -10,6 +10,12 @@ open Locus +(** Utilities on or_var *) + +let or_var_map f = function + | ArgArg x -> ArgArg (f x) + | ArgVar _ as y -> y + (** Utilities on occurrences *) let occurrences_map f = function diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli index 195dbec935..47d2ffe797 100644 --- a/pretyping/locusops.mli +++ b/pretyping/locusops.mli @@ -11,6 +11,10 @@ open Names open Locus +(** Utilities on or_var *) + +val or_var_map : ('a -> 'b) -> 'a or_var -> 'b or_var + (** Utilities on occurrences *) val occurrences_map : diff --git a/printing/printmod.ml b/printing/printmod.ml index 03921bca30..4cc6bc2052 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -213,7 +213,7 @@ let print_kn locals kn = let nametab_register_dir obj_mp = let id = mk_fake_top () in let obj_dir = DirPath.make [id] in - Nametab.(push_dir (Until 1) obj_dir (GlobDirRef.DirModule { obj_dir; obj_mp; obj_sec = DirPath.empty })) + Nametab.(push_dir (Until 1) obj_dir (GlobDirRef.DirModule { obj_dir; obj_mp; })) (** Nota: the [global_reference] we register in the nametab below might differ from internal ones, since we cannot recreate here diff --git a/tactics/abstract.ml b/tactics/abstract.ml index edeb27ab88..03ab0a1c13 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -149,9 +149,12 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let (_, info) = CErrors.push src in iraise (e, info) in + let body, effs = Future.force const.Declare.proof_entry_body in + (* We drop the side-effects from the entry, they already exist in the ambient environment *) + let const = { const with Declare.proof_entry_body = Future.from_val (body, ()) } in let const, args = shrink_entry sign const in let args = List.map EConstr.of_constr args in - let cd = Declare.DefinitionEntry { const with Declare.proof_entry_opaque = opaque } in + let cd = { const with Declare.proof_entry_opaque = opaque } in let kind = if opaque then Decls.(IsProof Lemma) else Decls.(IsDefinition Definition) in let cst () = (* do not compute the implicit arguments, it may be costly *) @@ -172,8 +175,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = in let lem = mkConstU (cst, inst) in let evd = Evd.set_universe_context evd ectx in - let effs = Evd.concat_side_effects eff - (snd (Future.force const.Declare.proof_entry_body)) in + let effs = Evd.concat_side_effects eff effs in let solve = Proofview.tclEFFECTS effs <*> tacK lem args diff --git a/tactics/declare.ml b/tactics/declare.ml index 3590146dfb..57eeddb847 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -204,7 +204,11 @@ let cast_proof_entry e = const_entry_inline_code = e.proof_entry_inline_code; } -let cast_opaque_proof_entry e = +type ('a, 'b) effect_entry = +| EffectEntry : (private_constants, private_constants Entries.const_entry_body) effect_entry +| PureEntry : (unit, Constr.constr) effect_entry + +let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proof_entry) : b opaque_entry = let typ = match e.proof_entry_type with | None -> assert false | Some typ -> typ @@ -218,8 +222,15 @@ let cast_opaque_proof_entry e = Id.Set.empty, Id.Set.empty else let ids_typ = global_vars_set env typ in - let (pf, _), eff = Future.force e.proof_entry_body in - let env = Safe_typing.push_private_constants env eff in + let pf, env = match entry with + | PureEntry -> + let (pf, _), () = Future.force e.proof_entry_body in + pf, env + | EffectEntry -> + let (pf, _), eff = Future.force e.proof_entry_body in + let env = Safe_typing.push_private_constants env eff in + pf, env + in let vars = global_vars_set env pf in ids_typ, vars in @@ -227,12 +238,24 @@ let cast_opaque_proof_entry e = Environ.really_needed env (Id.Set.union hyp_typ hyp_def) | Some hyps -> hyps in + let (body, univs : b * _) = match entry with + | PureEntry -> + let (body, uctx), () = Future.force e.proof_entry_body in + let univs = match e.proof_entry_universes with + | Monomorphic_entry uctx' -> Monomorphic_entry (Univ.ContextSet.union uctx uctx') + | Polymorphic_entry _ -> + assert (Univ.ContextSet.is_empty uctx); + e.proof_entry_universes + in + body, univs + | EffectEntry -> e.proof_entry_body, e.proof_entry_universes + in { - opaque_entry_body = e.proof_entry_body; + opaque_entry_body = body; opaque_entry_secctx = secctx; opaque_entry_feedback = e.proof_entry_feedback; opaque_entry_type = typ; - opaque_entry_universes = e.proof_entry_universes; + opaque_entry_universes = univs; } let get_roles export eff = @@ -243,56 +266,64 @@ let get_roles export eff = List.map map export let feedback_axiom () = Feedback.(feedback AddedAxiom) + let is_unsafe_typing_flags () = let flags = Environ.typing_flags (Global.env()) in not (flags.check_universes && flags.check_guarded && flags.check_positive) -let define_constant ~side_effect ~name cd = +let define_constant ~name cd = (* Logically define the constant and its subproofs, no libobject tampering *) - let in_section = Lib.sections_are_opened () in let export, decl, unsafe = match cd with | DefinitionEntry de -> (* We deal with side effects *) if not de.proof_entry_opaque then (* This globally defines the side-effects in the environment. *) let body, eff = Future.force de.proof_entry_body in - let body, export = Global.export_private_constants ~in_section (body, eff.Evd.seff_private) in + let body, export = Global.export_private_constants (body, eff.Evd.seff_private) in let export = get_roles export eff in let de = { de with proof_entry_body = Future.from_val (body, ()) } in let cd = Entries.DefinitionEntry (cast_proof_entry de) in - export, ConstantEntry (PureEntry, cd), false + export, ConstantEntry cd, false else let map (body, eff) = body, eff.Evd.seff_private in let body = Future.chain de.proof_entry_body map in let de = { de with proof_entry_body = body } in - let de = cast_opaque_proof_entry de in - [], ConstantEntry (EffectEntry, Entries.OpaqueEntry de), false + let de = cast_opaque_proof_entry EffectEntry de in + [], OpaqueEntry de, false | ParameterEntry e -> - [], ConstantEntry (PureEntry, Entries.ParameterEntry e), not (Lib.is_modtype_strict()) + [], ConstantEntry (Entries.ParameterEntry e), not (Lib.is_modtype_strict()) | PrimitiveEntry e -> - [], ConstantEntry (PureEntry, Entries.PrimitiveEntry e), false + [], ConstantEntry (Entries.PrimitiveEntry e), false in - let kn, eff = Global.add_constant ~side_effect ~in_section name decl in + let kn = Global.add_constant name decl in if unsafe || is_unsafe_typing_flags() then feedback_axiom(); - kn, eff, export + kn, export let declare_constant ?(local = ImportDefaultBehavior) ~name ~kind cd = let () = check_exists name in - let kn, (), export = define_constant ~side_effect:PureEntry ~name cd in + let kn, export = define_constant ~name cd in (* Register the libobjects attached to the constants and its subproofs *) let () = List.iter register_side_effect export in let () = register_constant kn kind local in kn -let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind cd = - let kn, eff, export = define_constant ~side_effect:EffectEntry ~name cd in - let () = assert (CList.is_empty export) in +let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind de = + let kn, eff = + let de = + if not de.proof_entry_opaque then + DefinitionEff (cast_proof_entry de) + else + let de = cast_opaque_proof_entry PureEntry de in + OpaqueEff de + in + Global.add_private_constant name de + in let () = register_constant kn kind local in let seff_roles = match role with | None -> Cmap.empty | Some r -> Cmap.singleton kn r in - let eff = { Evd.seff_private = eff.Entries.seff_wrap; Evd.seff_roles; } in + let eff = { Evd.seff_private = eff; Evd.seff_roles; } in kn, eff (** Declaration of section variables and local definitions *) @@ -319,7 +350,7 @@ let declare_variable ~name ~kind d = (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) let (body, eff) = Future.force de.proof_entry_body in - let ((body, uctx), export) = Global.export_private_constants ~in_section:true (body, eff.Evd.seff_private) in + let ((body, uctx), export) = Global.export_private_constants (body, eff.Evd.seff_private) in let eff = get_roles export eff in let () = List.iter register_side_effect eff in let poly, univs = match de.proof_entry_universes with @@ -345,132 +376,6 @@ let declare_variable ~name ~kind d = Impargs.declare_var_implicits ~impl name; Notation.declare_ref_arguments_scope Evd.empty (GlobRef.VarRef name) -(** Declaration of inductive blocks *) -let declare_inductive_argument_scopes kn mie = - List.iteri (fun i {mind_entry_consnames=lc} -> - Notation.declare_ref_arguments_scope Evd.empty (GlobRef.IndRef (kn,i)); - for j=1 to List.length lc do - Notation.declare_ref_arguments_scope Evd.empty (GlobRef.ConstructRef ((kn,i),j)); - done) mie.mind_entry_inds - -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) (typename, consnames) -> - let ind_p = (kn,n) in - let names, _ = - List.fold_left - (fun (names, p) l -> - let sp = - Libnames.make_path dp l - in - ((sp, GlobRef.ConstructRef (ind_p,p)) :: names, p+1)) - (names, 1) consnames in - let sp = Libnames.make_path dp typename - in - ((sp, GlobRef.IndRef ind_p) :: names, n+1)) - ([], 0) obj.ind_names - in names - -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), 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), 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), names) = - Some names - -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 a); - subst_function = ident_subst_function; - discharge_function = discharge_inductive; - } - -let cache_prim (_,(p,c)) = Recordops.register_primitive_projection p c - -let load_prim _ p = cache_prim p - -let subst_prim (subst,(p,c)) = Mod_subst.subst_proj_repr subst p, Mod_subst.subst_constant subst c - -let discharge_prim (_,(p,c)) = Some (Lib.discharge_proj_repr p, c) - -let inPrim : (Projection.Repr.t * Constant.t) -> obj = - declare_object { - (default_object "PRIMPROJS") with - cache_function = cache_prim ; - load_function = load_prim; - subst_function = subst_prim; - classify_function = (fun x -> Substitute x); - discharge_function = discharge_prim } - -let declare_primitive_projection p c = Lib.add_anonymous_leaf (inPrim (p,c)) - -let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = - let name = Label.to_id label in - let univs, u = match univs with - | Monomorphic_entry _ -> - (* Global constraints already defined through the inductive *) - default_univ_entry, Univ.Instance.empty - | Polymorphic_entry (nas, ctx) -> - Polymorphic_entry (nas, ctx), Univ.UContext.instance ctx - in - let term = Vars.subst_instance_constr u term in - let types = Vars.subst_instance_constr u types in - let entry = definition_entry ~types ~univs term in - let cst = declare_constant ~name ~kind:Decls.(IsDefinition StructureComponent) (DefinitionEntry entry) in - let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in - declare_primitive_projection p cst - -let declare_projections univs mind = - let env = Global.env () in - let mib = Environ.lookup_mind mind env in - match mib.mind_record with - | PrimRecord info -> - let iter_ind i (_, labs, _, _) = - let ind = (mind, i) in - let projs = Inductiveops.compute_projections env ind in - Array.iter2_i (declare_one_projection univs ind ~proj_npars:mib.mind_nparams) labs projs - in - let () = Array.iteri iter_ind info in - true - | FakeRecord -> false - | NotRecord -> false - -(* for initial declaration *) -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 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 - Impargs.declare_mib_implicits mind; - declare_inductive_argument_scopes mind mie; - oname, isprim - (* Declaration messages *) let pr_rank i = pr_nth (i+1) @@ -508,106 +413,3 @@ let assumption_message id = the type of the object than to the name of the object (see discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is declared") - -(** Global universes are not substitutive objects but global objects - bound at the *library* or *module* level. The polymorphic flag is - used to distinguish universes declared in polymorphic sections, which - are discharged and do not remain in scope. *) - -type universe_source = - | BoundUniv (* polymorphic universe, bound in a function (this will go away someday) *) - | QualifiedUniv of Id.t (* global universe introduced by some global value *) - | UnqualifiedUniv (* other global universe *) - -type universe_name_decl = universe_source * (Id.t * Univ.Level.UGlobal.t) list - -let check_exists_universe sp = - if Nametab.exists_universe sp then - raise (AlreadyDeclared (Some "Universe", Libnames.basename sp)) - else () - -let qualify_univ i dp src id = - match src with - | BoundUniv | UnqualifiedUniv -> - i, Libnames.make_path dp id - | QualifiedUniv l -> - let dp = DirPath.repr dp in - Nametab.map_visibility succ i, Libnames.make_path (DirPath.make (l::dp)) id - -let do_univ_name ~check i dp src (id,univ) = - let i, sp = qualify_univ i dp src id in - if check then check_exists_universe sp; - Nametab.push_universe i sp univ - -let cache_univ_names ((sp, _), (src, univs)) = - let depth = sections_depth () in - let dp = Libnames.pop_dirpath_n depth (Libnames.dirpath sp) in - List.iter (do_univ_name ~check:true (Nametab.Until 1) dp src) univs - -let load_univ_names i ((sp, _), (src, univs)) = - List.iter (do_univ_name ~check:false (Nametab.Until i) (Libnames.dirpath sp) src) univs - -let open_univ_names i ((sp, _), (src, univs)) = - List.iter (do_univ_name ~check:false (Nametab.Exactly i) (Libnames.dirpath sp) src) univs - -let discharge_univ_names = function - | _, (BoundUniv, _) -> None - | _, ((QualifiedUniv _ | UnqualifiedUniv), _ as x) -> Some x - -let input_univ_names : universe_name_decl -> Libobject.obj = - declare_object - { (default_object "Global universe name state") with - cache_function = cache_univ_names; - load_function = load_univ_names; - open_function = open_univ_names; - discharge_function = discharge_univ_names; - subst_function = (fun (subst, a) -> (* Actually the name is generated once and for all. *) a); - classify_function = (fun a -> Substitute a) } - -let declare_univ_binders gr pl = - if Global.is_polymorphic gr then - () - else - let l = let open GlobRef in match gr with - | ConstRef c -> Label.to_id @@ Constant.label c - | IndRef (c, _) -> Label.to_id @@ MutInd.label c - | VarRef id -> - CErrors.anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on variable " ++ Id.print id ++ str".") - | ConstructRef _ -> - CErrors.anomaly ~label:"declare_univ_binders" - Pp.(str "declare_univ_binders on an constructor reference") - in - let univs = Id.Map.fold (fun id univ univs -> - match Univ.Level.name univ with - | None -> assert false (* having Prop/Set/Var as binders is nonsense *) - | Some univ -> (id,univ)::univs) pl [] - in - Lib.add_anonymous_leaf (input_univ_names (QualifiedUniv l, univs)) - -let do_universe ~poly l = - let in_section = Lib.sections_are_opened () in - let () = - if poly && not in_section then - CErrors.user_err ~hdr:"Constraint" - (str"Cannot declare polymorphic universes outside sections") - in - let l = List.map (fun {CAst.v=id} -> (id, UnivGen.new_univ_global ())) l in - 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 src = if poly then BoundUniv else UnqualifiedUniv in - 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 - let u_of_id x = - Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x - in - let constraints = List.fold_left (fun acc (l, d, r) -> - let lu = u_of_id l and ru = u_of_id r in - Constraint.add (lu, d, ru) acc) - Constraint.empty l - in - let uctx = ContextSet.add_constraints constraints ContextSet.empty in - declare_universe_context ~poly uctx diff --git a/tactics/declare.mli b/tactics/declare.mli index f4bfdb1547..1a037ef937 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -43,6 +43,8 @@ type 'a constant_entry = | ParameterEntry of parameter_entry | PrimitiveEntry of primitive_entry +val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit + val declare_variable : name:variable -> kind:Decls.logical_kind @@ -78,7 +80,7 @@ val declare_private_constant -> ?local:import_status -> name:Id.t -> kind:Decls.logical_kind - -> Evd.side_effects constant_entry + -> unit proof_entry -> Constant.t * Evd.side_effects (** Since transparent constants' side effects are globally declared, we @@ -86,11 +88,6 @@ val declare_private_constant val set_declare_scheme : (string -> (inductive * Constant.t) array -> unit) -> unit -(** [declare_mind me] declares a block of inductive types with - their constructors in the current section; it returns the path of - the whole block and a boolean indicating if it is a primitive record. *) -val declare_mind : mutual_inductive_entry -> Libobject.object_name * bool - (** Declaration messages *) val definition_message : Id.t -> unit @@ -100,15 +97,7 @@ val cofixpoint_message : Id.t list -> unit val recursive_message : bool (** true = fixpoint *) -> int array option -> Id.t list -> unit -val exists_name : Id.t -> bool - -(** Global universe contexts, names and constraints *) -val declare_univ_binders : GlobRef.t -> UnivNames.universe_binders -> unit - -val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit - -val do_universe : poly:bool -> lident list -> unit -val do_constraint : poly:bool -> Glob_term.glob_constraint list -> unit +val check_exists : Id.t -> unit (* Used outside this module only in indschemes *) exception AlreadyDeclared of (string option * Id.t) diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index 54393dce00..3f824a94bf 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -124,8 +124,17 @@ let define internal role id c poly univs = let ctx = UState.minimize univs in let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in let univs = UState.univ_entry ~poly ctx in - let entry = Declare.definition_entry ~univs c in - let kn, eff = Declare.declare_private_constant ~role ~kind:Decls.(IsDefinition Scheme) ~name:id (Declare.DefinitionEntry entry) in + let entry = { + Declare.proof_entry_body = + Future.from_val ((c,Univ.ContextSet.empty), ()); + proof_entry_secctx = None; + proof_entry_type = None; + proof_entry_universes = univs; + proof_entry_opaque = false; + proof_entry_inline_code = false; + proof_entry_feedback = None; + } in + let kn, eff = Declare.declare_private_constant ~role ~kind:Decls.(IsDefinition Scheme) ~name:id entry in let () = match internal with | InternalTacticRequest -> () | _-> Declare.definition_message id diff --git a/test-suite/Makefile b/test-suite/Makefile index c0bdb29fab..c60f39231e 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -32,18 +32,21 @@ include ../Makefile.common # Variables ####################################################################### -# Default value when called from a freshly compiled Coq, but can be -# easily overridden - +ifneq ($(wildcard ../_build),) +BIN:=$(shell cd ..; pwd)/_build/install/default/bin/ +COQLIB:=$(shell cd ..; pwd)/_build/install/default/lib/coq +else BIN := $(shell cd ..; pwd)/bin/ -COQFLAGS?= COQLIB?= ifeq ($(COQLIB),) COQLIB := $(shell ocaml ocaml_pwd.ml ..) endif +endif # exists ../_build export COQLIB +COQFLAGS?= + coqc := $(BIN)coqc -q -R prerequisite TestSuite $(COQFLAGS) coqchk := $(BIN)coqchk -R prerequisite TestSuite coqdoc := $(BIN)coqdoc diff --git a/test-suite/bugs/closed/bug_10894.v b/test-suite/bugs/closed/bug_10894.v new file mode 100644 index 0000000000..b8c9367951 --- /dev/null +++ b/test-suite/bugs/closed/bug_10894.v @@ -0,0 +1,12 @@ +(* Check that uconstrs are interpreted in the ltac-substituted environment *) +(* Was a regression introduced in 4dab4fc (#7288) *) + +Tactic Notation "bind" hyp(x) "in" uconstr(f) "as" ident(h) := + set (h := fun x => f). + +Fact test : nat -> nat. +Proof. + intros n. + bind n in (n*n) as f. + assert (f 0 = 0) by reflexivity. +Abort. diff --git a/test-suite/bugs/closed/bug_10904.v b/test-suite/bugs/closed/bug_10904.v new file mode 100644 index 0000000000..32b25ff726 --- /dev/null +++ b/test-suite/bugs/closed/bug_10904.v @@ -0,0 +1,8 @@ +Definition a := fun (P:SProp) (p:P) => p. + +Lemma foo : (let k := a in let k' := a in fun (x:nat) y => x) = (let k := a in fun x y => y). +Proof. + Fail reflexivity. + match goal with |- ?l = _ => exact_no_check (eq_refl l) end. +Fail Qed. +Abort. diff --git a/test-suite/bugs/closed/bug_6323.v b/test-suite/bugs/closed/bug_6323.v index fdc33befc6..24feb7155c 100644 --- a/test-suite/bugs/closed/bug_6323.v +++ b/test-suite/bugs/closed/bug_6323.v @@ -6,4 +6,5 @@ Goal True. simple refine (let id' : { x : X' | True } -> X' := _ in _); [ abstract refine (@proj1_sig _ _) | ] ]. -Abort. + exact I. +Defined. diff --git a/test-suite/bugs/closed/bug_9851.v b/test-suite/bugs/closed/bug_9851.v new file mode 100644 index 0000000000..1f57ce8471 --- /dev/null +++ b/test-suite/bugs/closed/bug_9851.v @@ -0,0 +1,18 @@ +Require Import Ring_base. +Record word : Type := Build_word + { rep : Type; + zero : rep; one: rep; + add : rep -> rep -> rep; + sub : rep -> rep -> rep; + opp : rep -> rep; + mul : rep -> rep -> rep; + }. +Axiom rth + : forall (word : word ), + @ring_theory (@rep word) + (@zero word) + (@one word) (@add word) + (@mul word) (@sub word) + (@opp word) (@eq (@rep word)). + +Fail Add Ring wring: (@rth _). diff --git a/test-suite/ltac2/ltac2env.v b/test-suite/ltac2/ltac2env.v new file mode 100644 index 0000000000..743e62932d --- /dev/null +++ b/test-suite/ltac2/ltac2env.v @@ -0,0 +1,15 @@ +Require Import Ltac2.Ltac2. + +Ltac2 get_opt o := match o with None => Control.throw Not_found | Some x => x end. + +Goal True. +Proof. +(* Fails at runtime because not fully applied *) +Fail ltac1:(ltac2:(x |- ())). +(* Type mismatch: Ltac1.t vs. constr *) +Fail ltac1:(ltac2:(x |- pose $x)). +(* Check that runtime cast is OK *) +ltac1:(let t := ltac2:(x |- let c := (get_opt (Ltac1.to_constr x)) in pose $c) in t nat). +(* Type mismatch *) +Fail ltac1:(let t := ltac2:(x |- let c := (get_opt (Ltac1.to_constr x)) in pose $c) in t ident:(foo)). +Abort. diff --git a/test-suite/misc/votour.sh b/test-suite/misc/votour.sh new file mode 100755 index 0000000000..ac26aed49b --- /dev/null +++ b/test-suite/misc/votour.sh @@ -0,0 +1,3 @@ +command -v "${BIN}votour" || { echo "Missing votour"; exit 1; } + +"${BIN}votour" prerequisite/ssr_mini_mathcomp.vo < /dev/null diff --git a/test-suite/output/locate.out b/test-suite/output/locate.out new file mode 100644 index 0000000000..473db2d312 --- /dev/null +++ b/test-suite/output/locate.out @@ -0,0 +1,3 @@ +Notation +"b1 && b2" := if b1 then b2 else false (default interpretation) +"x && y" := andb x y : bool_scope diff --git a/test-suite/output/locate.v b/test-suite/output/locate.v new file mode 100644 index 0000000000..af8b0ee193 --- /dev/null +++ b/test-suite/output/locate.v @@ -0,0 +1,3 @@ +Set Printing Width 400. +Notation "b1 && b2" := (if b1 then b2 else false). +Locate "&&". diff --git a/test-suite/success/Nsatz.v b/test-suite/success/Nsatz.v index 381fbabe72..998f3f7dd1 100644 --- a/test-suite/success/Nsatz.v +++ b/test-suite/success/Nsatz.v @@ -419,13 +419,13 @@ Qed. -Lemma Desargues: forall A B C A1 B1 C1 P Q R S:point, +Lemma Desargues: forall A B C A1 B1 C1 P Q T S:point, X S = 0 -> Y S = 0 -> Y A = 0 -> collinear A S A1 -> collinear B S B1 -> collinear C S C1 -> collinear B1 C1 P -> collinear B C P -> collinear A1 C1 Q -> collinear A C Q -> - collinear A1 B1 R -> collinear A B R -> - collinear P Q R + collinear A1 B1 T -> collinear A B T -> + collinear P Q T \/ X A = X B \/ X A = X C \/ X B = X C \/ X A = 0 \/ Y B = 0 \/ Y C = 0 \/ collinear S B C \/ parallel A C A1 C1 \/ parallel A B A1 B1. Proof. @@ -440,8 +440,8 @@ let lv := rev (X A :: Y A1 :: X A1 :: Y B1 :: Y C1 - :: X R - :: Y R + :: X T + :: Y T :: X Q :: Y Q :: X P :: Y P :: X C1 :: X B1 :: nil) in nsatz with radicalmax :=1%N strategy:=0%Z diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 7c69350db4..ea4062d9fe 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -1363,7 +1363,8 @@ Lemma elements_aux_cardinal : Proof. simple induction m; simpl; intuition. rewrite <- H; simpl. - rewrite <- H0; omega. + rewrite <- H0, Nat.add_succ_r, (Nat.add_comm (cardinal t)), Nat.add_assoc. + reflexivity. Qed. Lemma elements_cardinal : forall (m:t elt), cardinal m = length (elements m). diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 0ef356b582..fa553d9fce 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -68,7 +68,7 @@ Hint Constructors avl : core. Lemma height_non_negative : forall (s : t elt), avl s -> height s >= 0. Proof. - induction s; simpl; intros; auto with zarith. + induction s; simpl; intros. now apply Z.le_ge. inv avl; intuition; omega_max. Qed. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index e5133f66b2..342a51b39b 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -476,8 +476,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. unfold elements. intros m; set (p:=1); clearbody p; revert m p. induction m; simpl; auto; intros. - rewrite (IHm1 (append p 2)), (IHm2 (append p 3)); auto. - destruct o; rewrite app_length; simpl; omega. + rewrite (IHm1 (append p 2)), (IHm2 (append p 3)). + destruct o; rewrite app_length; simpl; auto. Qed. End CompcertSpec. diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index da504259f5..1983c6caa1 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -17,7 +17,7 @@ [mem x s=true] instead of [In x s], [equal s s'=true] instead of [Equal s s'], etc. *) -Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx. +Require Import FSetProperties Zerob Sumbool DecidableTypeEx. Module WEqProperties_fun (Import E:DecidableType)(M:WSfun E). Module Import MP := WProperties_fun E M. @@ -847,11 +847,16 @@ Proof. unfold sum. intros f g Hf Hg. assert (fc : compat_opL (fun x:elt =>plus (f x))). red; auto with fset. -assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega. +assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros x y z. + rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm (f x) (f y)); reflexivity. assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto with fset. -assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega. +assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros x y z. + rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm (g x) (g y)); reflexivity. assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). repeat red; auto. -assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. +assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros x y z. + set (u := (f x + g x)); set (v := (f y + g y)). + rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm u). + reflexivity. assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). intros s;pattern s; apply set_rec. intros. @@ -859,7 +864,10 @@ rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H). rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H). rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto. intros; do 3 (rewrite (fold_add _ _ st);auto). -rewrite H0;simpl;omega. +rewrite H0;simpl. +rewrite <- !(PeanoNat.Nat.add_assoc (f x)); f_equal. +rewrite !PeanoNat.Nat.add_assoc. f_equal. +apply PeanoNat.Nat.add_comm. do 3 rewrite fold_empty;auto. Qed. @@ -872,7 +880,11 @@ assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). repeat red; intros. rewrite (Hf _ _ H); auto. assert (ct : transposeL (fun x => plus (if f x then 1 else 0))). - red; intros; omega. + red; intros. + set (a := if f x then _ else _). + rewrite PeanoNat.Nat.add_comm. + rewrite <- !PeanoNat.Nat.add_assoc. f_equal. + apply PeanoNat.Nat.add_comm. intros s;pattern s; apply set_rec. intros. change elt with E.t. @@ -921,9 +933,11 @@ Lemma sum_compat : forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. intros. -unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with *. +unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with fset. intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. +intros x y z; rewrite !PeanoNat.Nat.add_assoc; f_equal; apply PeanoNat.Nat.add_comm. intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. +intros x y z; rewrite !PeanoNat.Nat.add_assoc; f_equal; apply PeanoNat.Nat.add_comm. Qed. End Sum. diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index 2a9e15ab37..8538b54c08 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -29,7 +29,7 @@ Table of contents: 3. Weak classical axioms -3.1. Weak excluded middle +3.1. Weak excluded middle and classical de Morgan law 3.2. Gödel-Dummett axiom and right distributivity of implication over disjunction @@ -514,7 +514,7 @@ End Weak_proof_irrelevance_CCI. (** * Weak classical axioms *) (** We show the following increasing in the strength of axioms: - - weak excluded-middle + - weak excluded-middle and classical De Morgan's law - right distributivity of implication over disjunction and Gödel-Dummett axiom - independence of general premises and drinker's paradox - excluded-middle @@ -523,11 +523,15 @@ End Weak_proof_irrelevance_CCI. (** ** Weak excluded-middle *) (** The weak classical logic based on [~~A \/ ~A] is referred to with - name KC in [[ChagrovZakharyaschev97]] + name KC in [[ChagrovZakharyaschev97]]. See [[SorbiTerwijn11]] for + a short survey. [[ChagrovZakharyaschev97]] Alexander Chagrov and Michael Zakharyaschev, "Modal Logic", Clarendon Press, 1997. -*) + + [[SorbiTerwijn11]] Andrea Sorbi and Sebastiaan A. Terwijn, + "Generalizations of the weak law of the excluded-middle", Notre + Dame J. Formal Logic, vol 56(2), pp 321-331, 2015. *) Definition weak_excluded_middle := forall A:Prop, ~~A \/ ~A. @@ -539,16 +543,21 @@ Definition weak_excluded_middle := Definition weak_generalized_excluded_middle := forall A B:Prop, ((A -> B) -> B) \/ (A -> B). +(** Classical De Morgan's law *) + +Definition classical_de_morgan_law := + forall A B:Prop, ~(A /\ B) -> ~A \/ ~B. + (** ** Gödel-Dummett axiom *) (** [(A->B) \/ (B->A)] is studied in [[Dummett59]] and is based on [[Gödel33]]. [[Dummett59]] Michael A. E. Dummett. "A Propositional Calculus - with a Denumerable Matrix", In the Journal of Symbolic Logic, Vol - 24 No. 2(1959), pp 97-103. + with a Denumerable Matrix", In the Journal of Symbolic Logic, vol + 24(2), pp 97-103, 1959. [[Gödel33]] Kurt Gödel. "Zum intuitionistischen Aussagenkalkül", - Ergeb. Math. Koll. 4 (1933), pp. 34-38. + Ergeb. Math. Koll. 4, pp. 34-38, 1933. *) Definition GodelDummett := forall A B:Prop, (A -> B) \/ (B -> A). @@ -590,6 +599,16 @@ Proof. right; intro HA; apply (HAnotA HA HA). Qed. +(** The weak excluded middle is equivalent to the classical De Morgan's law *) + +Lemma weak_excluded_middle_iff_classical_de_morgan_law : + weak_excluded_middle <-> classical_de_morgan_law. +Proof. + split; [intro WEM|intro CDML]; intros A *. + - destruct (WEM A); tauto. + - destruct (CDML A (~A)); tauto. +Qed. + (** ** Independence of general premises and drinker's paradox *) (** Independence of general premises is the unconstrained, non diff --git a/theories/Logic/HLevels.v b/theories/Logic/HLevels.v new file mode 100644 index 0000000000..010c4aad6f --- /dev/null +++ b/theories/Logic/HLevels.v @@ -0,0 +1,146 @@ +(************************************************************************) +(* * 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 first three levels of homotopy type theory: homotopy propositions, + homotopy sets and homotopy one types. For more information, + https://github.com/HoTT/HoTT + and + https://homotopytypetheory.org/book + + Univalence is not assumed here, and equality is Coq's usual inductive + type eq in sort Prop. This is a little different from HoTT, where + sort Prop does not exist and equality is directly in sort Type. *) + + +(* It is almost impossible to prove that a type is a homotopy proposition + without funext, so we assume it here. *) +Require Import Coq.Logic.FunctionalExtensionality. + +(* A homotopy proposition is a type that has at most one element. + Its unique inhabitant, when it exists, is to be interpreted as the + proof of the homotopy proposition. + Homotopy propositions are therefore an alternative to the sort Prop, + to select which types represent mathematical propositions. *) +Definition IsHProp (P : Type) : Prop + := forall p q : P, p = q. + +(* A homotopy set is a type such as each equality type x = y is a + homotopy proposition. For example, any type which equality is + decidable in sort Prop is a homotopy set, as shown in file + Coq.Logic.Eqdep_dec.v. *) +Definition IsHSet (X : Type) : Prop + := forall (x y : X) (p q : x = y), p = q. + +Definition IsHOneType (X : Type) : Prop + := forall (x y : X) (p q : x = y) (r s : p = q), r = s. + +Lemma forall_hprop : forall (A : Type) (P : A -> Prop), + (forall x:A, IsHProp (P x)) + -> IsHProp (forall x:A, P x). +Proof. + intros A P H p q. apply functional_extensionality_dep. + intro x. apply H. +Qed. + +(* Homotopy propositions are stable by conjunction, but not by disjunction, + which can have a proof by the left and another proof by the right. *) +Lemma and_hprop : forall P Q : Prop, + IsHProp P -> IsHProp Q -> IsHProp (P /\ Q). +Proof. + intros. intros p q. destruct p,q. + replace p0 with p. replace q0 with q. reflexivity. + apply H0. apply H. +Qed. + +Lemma impl_hprop : forall P Q : Prop, + IsHProp Q -> IsHProp (P -> Q). +Proof. + intros P Q H p q. apply functional_extensionality. + intros. apply H. +Qed. + +Lemma false_hprop : IsHProp False. +Proof. + intros p q. contradiction. +Qed. + +Lemma true_hprop : IsHProp True. +Proof. + intros p q. destruct p,q. reflexivity. +Qed. + +(* All negations are homotopy propositions. *) +Lemma not_hprop : forall P : Type, IsHProp (P -> False). +Proof. + intros P p q. apply functional_extensionality. + intros. contradiction. +Qed. + +(* Homotopy propositions are included in homotopy sets. + They are the first 2 levels of a cumulative hierarchy of types + indexed by the natural numbers. In homotopy type theory, + homotopy propositions are call (-1)-types and homotopy + sets 0-types. *) +Lemma hset_hprop : forall X : Type, + IsHProp X -> IsHSet X. +Proof. + intros X H. + assert (forall (x y z:X) (p : y = z), eq_trans (H x y) p = H x z). + { intros. unfold eq_trans, eq_ind. destruct p. reflexivity. } + assert (forall (x y z:X) (p : y = z), + p = eq_trans (eq_sym (H x y)) (H x z)). + { intros. rewrite <- (H0 x y z p). unfold eq_trans, eq_sym, eq_ind. + destruct p, (H x y). reflexivity. } + intros x y p q. + rewrite (H1 x x y p), (H1 x x y q). reflexivity. +Qed. + +Lemma eq_trans_cancel : forall {X : Type} {x y z : X} (p : x = y) (q r : y = z), + (eq_trans p q = eq_trans p r) -> q = r. +Proof. + intros. destruct p. simpl in H. destruct r. + simpl in H. rewrite eq_trans_refl_l in H. exact H. +Qed. + +Lemma hset_hOneType : forall X : Type, + IsHSet X -> IsHOneType X. +Proof. + intros X f x y p q. + pose (fun a => f x y p a) as g. + assert (forall a (r : q = a), eq_trans (g q) r = g a). + { intros. destruct a. subst q. reflexivity. } + intros r s. pose proof (H p (eq_sym r)). + pose proof (H p (eq_sym s)). + rewrite <- H1 in H0. apply eq_trans_cancel in H0. + rewrite <- eq_sym_involutive. rewrite <- (eq_sym_involutive r). + rewrite H0. reflexivity. +Qed. + +(* "IsHProp X" sounds like a proposition, because it asserts + a property of the type X. And indeed: *) +Lemma hprop_hprop : forall X : Type, + IsHProp (IsHProp X). +Proof. + intros X p q. + apply forall_hprop. intro x. + apply forall_hprop. intro y. intros f g. + apply (hset_hprop X p). +Qed. + +Lemma hprop_hset : forall X : Type, + IsHProp (IsHSet X). +Proof. + intros X f g. + apply functional_extensionality_dep. intro x. + apply functional_extensionality_dep. intro y. + apply functional_extensionality_dep. intro a. + apply functional_extensionality_dep. intro b. + apply (hset_hOneType). exact f. +Qed. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index b60feb9256..54d35cded2 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -79,7 +79,7 @@ Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope. Lemma inject_Z_injective (a b: Z): inject_Z a == inject_Z b <-> a = b. Proof. - unfold Qeq. simpl. omega. + unfold Qeq; simpl; rewrite !Z.mul_1_r; reflexivity. Qed. (** Another approach : using Qcompare for defining order relations. *) @@ -599,9 +599,7 @@ Proof. Qed. Lemma Qle_antisym x y : x<=y -> y<=x -> x==y. -Proof. - unfold Qle, Qeq; auto with zarith. -Qed. +Proof. apply Z.le_antisymm. Qed. Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z. Proof. @@ -618,14 +616,10 @@ Qed. Hint Resolve Qle_trans : qarith. Lemma Qlt_irrefl x : ~x<x. -Proof. - unfold Qlt. auto with zarith. -Qed. +Proof. apply Z.lt_irrefl. Qed. Lemma Qlt_not_eq x y : x<y -> ~ x==y. -Proof. - unfold Qlt, Qeq; auto with zarith. -Qed. +Proof. apply Z.lt_neq. Qed. Lemma Zle_Qle (x y: Z): (x <= y)%Z = (inject_Z x <= inject_Z y). Proof. @@ -647,9 +641,7 @@ Proof. Qed. Lemma Qlt_le_weak x y : x<y -> x<=y. -Proof. - unfold Qle, Qlt; auto with zarith. -Qed. +Proof. apply Z.lt_le_incl. Qed. Lemma Qle_lt_trans : forall x y z, x<=y -> y<z -> x<z. Proof. @@ -684,25 +676,17 @@ Qed. (** [x<y] iff [~(y<=x)] *) -Lemma Qnot_lt_le : forall x y, ~ x<y -> y<=x. -Proof. - unfold Qle, Qlt; auto with zarith. -Qed. +Lemma Qnot_lt_le x y : ~ x < y -> y <= x. +Proof. apply Z.nlt_ge. Qed. -Lemma Qnot_le_lt : forall x y, ~ x<=y -> y<x. -Proof. - unfold Qle, Qlt; auto with zarith. -Qed. +Lemma Qnot_le_lt x y : ~ x <= y -> y < x. +Proof. apply Z.nle_gt. Qed. -Lemma Qlt_not_le : forall x y, x<y -> ~ y<=x. -Proof. - unfold Qle, Qlt; auto with zarith. -Qed. +Lemma Qlt_not_le x y : x < y -> ~ y <= x. +Proof. apply Z.lt_nge. Qed. -Lemma Qle_not_lt : forall x y, x<=y -> ~ y<x. -Proof. - unfold Qle, Qlt; auto with zarith. -Qed. +Lemma Qle_not_lt x y : x <= y -> ~ y < x. +Proof. apply Z.le_ngt. Qed. Lemma Qle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y. Proof. @@ -746,21 +730,24 @@ Defined. Lemma Qopp_le_compat : forall p q, p<=q -> -q <= -p. Proof. intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl. - rewrite !Z.mul_opp_l. omega. + now rewrite !Z.mul_opp_l, <- Z.opp_le_mono. Qed. + Hint Resolve Qopp_le_compat : qarith. Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p. Proof. intros (x1,x2) (y1,y2); unfold Qle; simpl. - rewrite Z.mul_opp_l. omega. + rewrite Z.mul_1_r, Z.mul_opp_l, <- Z.le_sub_le_add_r, Z.opp_involutive. + reflexivity. Qed. Lemma Qlt_minus_iff : forall p q, p < q <-> 0 < q+-p. Proof. intros (x1,x2) (y1,y2); unfold Qlt; simpl. - rewrite Z.mul_opp_l. omega. + rewrite Z.mul_1_r, Z.mul_opp_l, <- Z.lt_sub_lt_add_r, Z.opp_involutive. + reflexivity. Qed. Lemma Qplus_le_compat : @@ -831,9 +818,11 @@ Lemma Qmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z. Proof. intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. Open Scope Z_scope. + rewrite Z.mul_1_r. intros; simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). - apply Z.mul_le_mono_nonneg_r; auto with zarith. + apply Z.mul_le_mono_nonneg_r; auto. + now apply Z.mul_nonneg_nonneg. Close Scope Z_scope. Qed. @@ -843,9 +832,10 @@ Proof. Open Scope Z_scope. simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). + rewrite Z.mul_1_r. intros LT LE. apply Z.mul_le_mono_pos_r in LE; trivial. - apply Z.mul_pos_pos; [omega|easy]. + apply Z.mul_pos_pos; easy. Close Scope Z_scope. Qed. @@ -866,10 +856,11 @@ Lemma Qmult_lt_compat_r : forall x y z, 0 < z -> x < y -> x*z < y*z. Proof. intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. Open Scope Z_scope. + rewrite Z.mul_1_r. intros; simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). apply Z.mul_lt_mono_pos_r; auto with zarith. - apply Z.mul_pos_pos; [omega|reflexivity]. + apply Z.mul_pos_pos; easy. Close Scope Z_scope. Qed. @@ -880,8 +871,9 @@ Proof. unfold Qle, Qlt; simpl. simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). + rewrite Z.mul_1_r. intro LT. rewrite <- Z.mul_lt_mono_pos_r. reflexivity. - apply Z.mul_pos_pos; [omega|reflexivity]. + now apply Z.mul_pos_pos. Close Scope Z_scope. Qed. @@ -896,6 +888,7 @@ Proof. intros a b Ha Hb. unfold Qle in *. simpl in *. +rewrite Z.mul_1_r in *. auto with *. Qed. diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index 78cd549ce6..e314f64028 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -35,7 +35,7 @@ Proof. rewrite <- Hg in LE; clear Hg. assert (0 <> g) by (intro; subst; discriminate). rewrite Z2Pos.id. ring. - rewrite <- (Z.mul_pos_cancel_l g); [now rewrite <- Hd | omega]. + now rewrite <- (Z.mul_pos_cancel_l g); [ rewrite <- Hd | apply Z.le_neq ]. Close Scope Z_scope. Qed. @@ -60,8 +60,8 @@ Proof. - congruence. - (*rel_prime*) constructor. - * exists aa; auto with zarith. - * exists bb; auto with zarith. + * exists aa; auto using Z.mul_1_r. + * exists bb; auto using Z.mul_1_r. * intros x Ha Hb. destruct Hg1 as (Hg11,Hg12,Hg13). destruct (Hg13 (g*x)) as (x',Hx). @@ -73,8 +73,8 @@ Proof. apply Z.mul_reg_l with g; auto. rewrite Hx at 1; ring. - (* rel_prime *) constructor. - * exists cc; auto with zarith. - * exists dd; auto with zarith. + * exists cc; auto using Z.mul_1_r. + * exists dd; auto using Z.mul_1_r. * intros x Hc Hd. inversion Hg'1 as (Hg'11,Hg'12,Hg'13). destruct (Hg'13 (g'*x)) as (x',Hx). @@ -85,9 +85,9 @@ Proof. exists x'. apply Z.mul_reg_l with g'; auto. rewrite Hx at 1; ring. - apply Z.lt_gt. - rewrite <- (Z.mul_pos_cancel_l g); [now rewrite <- Hg4 | omega]. + rewrite <- (Z.mul_pos_cancel_l g); [ now rewrite <- Hg4 | apply Z.le_neq; intuition ]. - apply Z.lt_gt. - rewrite <- (Z.mul_pos_cancel_l g'); [now rewrite <- Hg'4 | omega]. + rewrite <- (Z.mul_pos_cancel_l g'); [now rewrite <- Hg'4 | apply Z.le_neq; intuition ]. - apply Z.mul_reg_l with (g*g'). * rewrite Z.mul_eq_0. now destruct 1. * rewrite Z.mul_shuffle1, <- Hg3, <- Hg'4. diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v index af5c471d5d..8d68038582 100644 --- a/theories/QArith/Qround.v +++ b/theories/QArith/Qround.v @@ -13,7 +13,8 @@ Require Import QArith. Lemma Qopp_lt_compat: forall p q : Q, p < q -> - q < - p. Proof. intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl. -rewrite !Z.mul_opp_l; omega. +rewrite !Z.mul_opp_l. +apply Z.opp_lt_mono. Qed. Hint Resolve Qopp_lt_compat : qarith. @@ -38,7 +39,7 @@ intros z. unfold Qceiling. simpl. rewrite Zdiv_1_r. -auto with *. +apply Z.opp_involutive. Qed. Lemma Qfloor_le : forall x, Qfloor x <= x. @@ -119,7 +120,7 @@ Lemma Qceiling_resp_le : forall x y, x <= y -> (Qceiling x <= Qceiling y)%Z. Proof. intros x y Hxy. unfold Qceiling. -cut (Qfloor (-y) <= Qfloor (-x))%Z; auto with *. +rewrite <- Z.opp_le_mono; auto with qarith. Qed. Hint Resolve Qceiling_resp_le : qarith. diff --git a/theories/Reals/ClassicalDedekindReals.v b/theories/Reals/ClassicalDedekindReals.v new file mode 100644 index 0000000000..e32def29b8 --- /dev/null +++ b/theories/Reals/ClassicalDedekindReals.v @@ -0,0 +1,465 @@ +(************************************************************************) +(* * 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 Coq.Logic.Eqdep_dec. +Require Import Coq.Logic.FunctionalExtensionality. +Require Import Coq.Logic.HLevels. +Require Import QArith. +Require Import Qabs. +Require Import ConstructiveCauchyReals. +Require Import ConstructiveRcomplete. + +(** + Classical Dedekind reals. With the 3 logical axioms funext, + sig_forall_dec and sig_not_dec, the lower cuts defined as + functions Q -> bool have all the classical properties of the + real numbers. + + We could prove operations and theorems about them directly, + but instead we notice that they are a quotient of the + constructive Cauchy reals, from which they inherit many properties. +*) + +(* The limited principle of omniscience *) +Axiom sig_forall_dec + : forall (P : nat -> Prop), + (forall n, {P n} + {~P n}) + -> {n | ~P n} + {forall n, P n}. + +Axiom sig_not_dec : forall P : Prop, { ~~P } + { ~P }. + +(* Try to find a surjection CReal -> lower cuts. *) +Definition isLowerCut (f : Q -> bool) : Prop + := (forall q r:Q, Qle q r -> f r = true -> f q = true) (* interval *) + /\ ~(forall q:Q, f q = true) (* avoid positive infinity *) + /\ ~(forall q:Q, f q = false) (* avoid negative infinity *) + (* openness, the cut contains rational numbers + strictly lower than a real number. *) + /\ (forall q:Q, f q = true -> ~(forall r:Q, Qle r q \/ f r = false)). + +Lemma isLowerCut_hprop : forall (f : Q -> bool), + IsHProp (isLowerCut f). +Proof. + intro f. apply and_hprop. + 2: apply and_hprop. 2: apply not_hprop. + 2: apply and_hprop. 2: apply not_hprop. + - apply forall_hprop. intro x. + apply forall_hprop. intro y. + apply impl_hprop. apply impl_hprop. + intros p q. apply eq_proofs_unicity_on. + intro b. destruct (f x), b. + left. reflexivity. right. discriminate. + right. discriminate. left. reflexivity. + - apply forall_hprop. intro q. apply impl_hprop. apply not_hprop. +Qed. + +Lemma lowerCutBelow : forall f : Q -> bool, + isLowerCut f -> { q : Q | f q = true }. +Proof. + intros. + destruct (sig_forall_dec (fun n:nat => f (-(Z.of_nat n # 1))%Q = false)). + - intro n. destruct (f (-(Z.of_nat n # 1))%Q). + right. discriminate. left. reflexivity. + - destruct s. exists (-(Z.of_nat x # 1))%Q. + destruct (f (-(Z.of_nat x # 1))%Q). + reflexivity. exfalso. apply n. reflexivity. + - exfalso. destruct H, H0, H1. apply H1. intro q. + destruct (f q) eqn:des. 2: reflexivity. exfalso. + destruct (Qarchimedean (-q)) as [p pmaj]. + rewrite <- (Qplus_lt_l _ _ (q-(Z.pos p # 1))) in pmaj. + ring_simplify in pmaj. + specialize (H (- (Z.pos p#1))%Q q). + specialize (e (Pos.to_nat p)). + rewrite positive_nat_Z in e. rewrite H in e. discriminate. + 2: exact des. ring_simplify. apply Qlt_le_weak, pmaj. +Qed. + +Lemma lowerCutAbove : forall f : Q -> bool, + isLowerCut f -> { q : Q | f q = false }. +Proof. + intros. + destruct (sig_forall_dec (fun n => f (Z.of_nat n # 1)%Q = true)). + - intro n. destruct (f (Z.of_nat n # 1)%Q). + left. reflexivity. right. discriminate. + - destruct s. exists (Z.of_nat x # 1)%Q. destruct (f (Z.of_nat x # 1)%Q). + exfalso. apply n. reflexivity. reflexivity. + - exfalso. destruct H, H0, H1. apply H0. intro q. + destruct (Qarchimedean q) as [p pmaj]. + apply (H q (Z.of_nat (Pos.to_nat p) # 1)%Q). + rewrite positive_nat_Z. apply Qlt_le_weak, pmaj. apply e. +Qed. + +Definition DReal : Set + := { f : Q -> bool | isLowerCut f }. + +Fixpoint DRealQlim_rec (f : Q -> bool) (low : isLowerCut f) (n p : nat) { struct p } + : f (proj1_sig (lowerCutBelow f low) + (Z.of_nat p # Pos.of_nat (S n)))%Q = false + -> { q : Q | f q = true /\ f (q + (1 # Pos.of_nat (S n)))%Q = false }. +Proof. + intros. destruct p. + - exfalso. destruct (lowerCutBelow f low); unfold proj1_sig in H. + destruct low. rewrite (H0 _ x) in H. discriminate. simpl. + apply (Qplus_le_l _ _ (-x)). ring_simplify. discriminate. exact e. + - destruct (f (proj1_sig (lowerCutBelow f low) + (Z.of_nat p # Pos.of_nat (S n)))%Q) eqn:des. + + exists (proj1_sig (lowerCutBelow f low) + (Z.of_nat p # Pos.of_nat (S n)))%Q. + split. exact des. + destruct (f (proj1_sig (lowerCutBelow f low) + + (Z.of_nat p # Pos.of_nat (S n)) + (1 # Pos.of_nat (S n)))%Q) eqn:d. + 2: reflexivity. exfalso. + destruct low. + rewrite (e _ (proj1_sig (lowerCutBelow f (conj e a)) + (Z.of_nat p # Pos.of_nat (S n)) + (1 # Pos.of_nat (S n))))%Q in H. + discriminate. 2: exact d. rewrite <- Qplus_assoc, Qplus_le_r. + rewrite Qinv_plus_distr. + replace (Z.of_nat p + 1)%Z with (Z.of_nat (S p))%Z. apply Qle_refl. + replace 1%Z with (Z.of_nat 1). rewrite <- (Nat2Z.inj_add p 1). + apply f_equal. rewrite Nat.add_comm. reflexivity. reflexivity. + + destruct (DRealQlim_rec f low n p des) as [q qmaj]. + exists q. exact qmaj. +Qed. + +Definition DRealQlim (x : DReal) (n : nat) + : { q : Q | proj1_sig x q = true /\ proj1_sig x (q + (1# Pos.of_nat (S n)))%Q = false }. +Proof. + destruct x as [f low]. + destruct (lowerCutAbove f low). + destruct (Qarchimedean (x - proj1_sig (lowerCutBelow f low))) as [p pmaj]. + apply (DRealQlim_rec f low n ((S n) * Pos.to_nat p)). + destruct (lowerCutBelow f low); unfold proj1_sig; unfold proj1_sig in pmaj. + destruct (f (x0 + (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n)))%Q) eqn:des. + 2: reflexivity. exfalso. destruct low. + rewrite (H _ (x0 + (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n)))%Q) in e. + discriminate. 2: exact des. + setoid_replace (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n))%Q with (Z.pos p # 1)%Q. + apply (Qplus_lt_l _ _ x0) in pmaj. ring_simplify in pmaj. + apply Qlt_le_weak, pmaj. rewrite Nat2Z.inj_mul, positive_nat_Z. + unfold Qeq, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_comm. + replace (Z.of_nat (S n)) with (Z.pos (Pos.of_nat (S n))). reflexivity. + simpl. destruct n. reflexivity. apply f_equal. + apply Pos.succ_of_nat. discriminate. +Qed. + +Definition DRealAbstr : CReal -> DReal. +Proof. + intro x. + assert (forall (q : Q) (n : nat), + {(fun n0 : nat => (proj1_sig x (S n0) <= q + (1 # Pos.of_nat (S n0)))%Q) n} + + {~ (fun n0 : nat => (proj1_sig x (S n0) <= q + (1 # Pos.of_nat (S n0)))%Q) n}). + { intros. destruct (Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (proj1_sig x (S n))). + right. apply (Qlt_not_le _ _ q0). left. exact q0. } + + exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (proj1_sig x (S n)) (q + (1#Pos.of_nat (S n)))) (H q) + then true else false). + repeat split. + - intros. + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= q + (1 # Pos.of_nat (S n)))%Q) + (H q)). + reflexivity. exfalso. + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= r + (1 # Pos.of_nat (S n)))%Q) + (H r)). + destruct s. apply n. + apply (Qle_trans _ _ _ (q0 x0)). + apply Qplus_le_l. exact H0. discriminate. + - intro abs. destruct (Rfloor x) as [z [_ zmaj]]. + specialize (abs (z+3 # 1)%Q). + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= (z+3 # 1) + (1 # Pos.of_nat (S n)))%Q) + (H (z+3 # 1)%Q)). + 2: exfalso; discriminate. clear abs. destruct s as [n nmaj]. apply nmaj. + rewrite <- (inject_Q_plus (z#1) 2) in zmaj. + apply CRealLt_asym in zmaj. rewrite <- CRealLe_not_lt in zmaj. + specialize (zmaj (Pos.of_nat (S n))). unfold inject_Q, proj1_sig in zmaj. + rewrite Nat2Pos.id in zmaj. 2: discriminate. + destruct x as [xn xcau]; unfold proj1_sig. + rewrite Qinv_plus_distr in zmaj. + apply (Qplus_le_l _ _ (-(z + 2 # 1))). apply (Qle_trans _ _ _ zmaj). + apply (Qplus_le_l _ _ (-(1 # Pos.of_nat (S n)))). apply (Qle_trans _ 1). + unfold Qopp, Qnum, Qden. rewrite Qinv_plus_distr. + unfold Qle, Qnum, Qden. apply Z2Nat.inj_le. discriminate. discriminate. + do 2 rewrite Z.mul_1_l. unfold Z.to_nat. rewrite Nat2Pos.id. 2: discriminate. + apply le_n_S, le_0_n. setoid_replace (- (z + 2 # 1))%Q with (-(z+2) #1)%Q. + 2: reflexivity. ring_simplify. rewrite Qinv_plus_distr. + replace (z + 3 + - (z + 2))%Z with 1%Z. apply Qle_refl. ring. + - intro abs. destruct (Rfloor x) as [z [zmaj _]]. + specialize (abs (z-4 # 1)%Q). + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= (z-4 # 1) + (1 # Pos.of_nat (S n)))%Q) + (H (z-4 # 1)%Q)). + exfalso; discriminate. clear abs. + apply CRealLt_asym in zmaj. apply zmaj. clear zmaj. + exists 1%positive. unfold inject_Q, proj1_sig. + specialize (q O). + destruct x as [xn xcau]; unfold proj1_sig; unfold proj1_sig in q. + unfold Pos.of_nat in q. rewrite Qinv_plus_distr in q. + unfold Pos.to_nat; simpl. apply (Qplus_lt_l _ _ (xn 1%nat - 2)). + ring_simplify. rewrite Qinv_plus_distr. + apply (Qle_lt_trans _ _ _ q). apply Qlt_minus_iff. + unfold Qopp, Qnum, Qden. rewrite Qinv_plus_distr. + replace (z + -2 + - (z - 4 + 1))%Z with 1%Z. 2: ring. reflexivity. + - intros q H0 abs. + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= q + (1 # Pos.of_nat (S n)))%Q) (H q)). + 2: exfalso; discriminate. clear H0. + destruct x as [xn xcau]; unfold proj1_sig in abs, s. + destruct s as [n nmaj]. + (* We have that q < x as real numbers. The middle + (q + xSn - 1/Sn)/2 is also lower than x, witnessed by the same index n. *) + specialize (abs ((q + xn (S n) - (1 # Pos.of_nat (S n))%Q)/2)%Q). + destruct abs. + + apply (Qmult_le_r _ _ 2) in H0. field_simplify in H0. + apply (Qplus_le_r _ _ ((1 # Pos.of_nat (S n)) - q)) in H0. + ring_simplify in H0. apply nmaj. rewrite Qplus_comm. exact H0. reflexivity. + + destruct (sig_forall_dec + (fun n0 : nat => + (xn (S n0) <= (q + xn (S n) - (1 # Pos.of_nat (S n))) / 2 + (1 # Pos.of_nat (S n0)))%Q) + (H ((q + xn (S n) - (1 # Pos.of_nat (S n))) / 2)%Q)). + discriminate. clear H0. specialize (q0 n). + apply (Qmult_le_l _ _ 2) in q0. field_simplify in q0. + apply (Qplus_le_l _ _ (-xn (S n))) in q0. ring_simplify in q0. + contradiction. reflexivity. +Defined. + +Lemma UpperAboveLower : forall (f : Q -> bool) (q r : Q), + isLowerCut f + -> f q = true + -> f r = false + -> Qlt q r. +Proof. + intros. destruct H. apply Qnot_le_lt. intro abs. + rewrite (H r q abs) in H1. discriminate. exact H0. +Qed. + +Definition DRealRepr : DReal -> CReal. +Proof. + intro x. exists (fun n => proj1_sig (DRealQlim x n)). + intros n p q H H0. + destruct (DRealQlim x p), (DRealQlim x q); unfold proj1_sig. + destruct x as [f low]; unfold proj1_sig in a0, a. + apply Qabs_case. + - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S q))). + apply (Qplus_lt_l _ _ x1). ring_simplify. apply (UpperAboveLower f). + exact low. apply a. apply a0. unfold Qle, Qnum, Qden. + do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply (le_trans _ _ _ H0), le_S, le_refl. + discriminate. + - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S p))). + apply (Qplus_lt_l _ _ x0). ring_simplify. apply (UpperAboveLower f). + exact low. apply a0. apply a. unfold Qle, Qnum, Qden. + do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply (le_trans _ _ _ H), le_S, le_refl. + discriminate. +Defined. + +Definition Rle (x y : DReal) + := forall q:Q, proj1_sig x q = true -> proj1_sig y q = true. + +Lemma Rle_antisym : forall x y : DReal, + Rle x y + -> Rle y x + -> x = y. +Proof. + intros [f cf] [g cg] H H0. unfold Rle in H,H0; simpl in H, H0. + assert (f = g). + { apply functional_extensionality. intro q. + specialize (H q). specialize (H0 q). + destruct (f q), (g q). reflexivity. + exfalso. specialize (H (eq_refl _)). discriminate. + exfalso. specialize (H0 (eq_refl _)). discriminate. + reflexivity. } + subst g. replace cg with cf. reflexivity. + apply isLowerCut_hprop. +Qed. + +Lemma lowerUpper : forall (f : Q -> bool) (q r : Q), + isLowerCut f -> Qle q r -> f q = false -> f r = false. +Proof. + intros. destruct H. specialize (H q r H0). destruct (f r) eqn:desR. + 2: reflexivity. exfalso. specialize (H (eq_refl _)). + rewrite H in H1. discriminate. +Qed. + +Lemma DRealOpen : forall (x : DReal) (q : Q), + proj1_sig x q = true + -> { r : Q | Qlt q r /\ proj1_sig x r = true }. +Proof. + intros. + destruct (sig_forall_dec (fun n => Qle (proj1_sig (DRealQlim x n)) q)). + - intro n. destruct (DRealQlim x n); unfold proj1_sig. + destruct (Qlt_le_dec q x0). right. exact (Qlt_not_le _ _ q0). + left. exact q0. + - destruct s. apply Qnot_le_lt in n. + destruct (DRealQlim x x0); unfold proj1_sig in n. + exists x1. split. exact n. apply a. + - exfalso. destruct x as [f low]. unfold proj1_sig in H, q0. + destruct low, a, a. apply (n1 q H). intros. + destruct (Qlt_le_dec q r). 2: left; exact q1. right. + destruct (Qarchimedean (/(r - q))) as [p pmaj]. + specialize (q0 (Pos.to_nat p)). + destruct (DRealQlim (exist _ f (conj e (conj n (conj n0 n1)))) (Pos.to_nat p)) + as [s smaj]. + unfold proj1_sig in smaj. + apply (lowerUpper f (s + (1 # Pos.of_nat (S (Pos.to_nat p))))). + exact (conj e (conj n (conj n0 n1))). + 2: apply smaj. apply (Qle_trans _ (s + (r-q))). + apply Qplus_le_r. apply (Qle_trans _ (1 # p)). + unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. + apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. + rewrite Nat2Pos.id. apply le_S, le_refl. discriminate. + apply (Qmult_le_l _ _ ( (Z.pos p # 1) / (r-q))). + rewrite <- (Qmult_0_r (Z.pos p #1)). apply Qmult_lt_l. + reflexivity. apply Qinv_lt_0_compat. + unfold Qminus. rewrite <- Qlt_minus_iff. exact q1. + unfold Qdiv. rewrite Qmult_comm, <- Qmult_assoc. + rewrite (Qmult_comm (/(r-q))), Qmult_inv_r, Qmult_assoc. + setoid_replace ((1 # p) * (Z.pos p # 1))%Q with 1%Q. + 2: reflexivity. rewrite Qmult_1_l, Qmult_1_r. + apply Qlt_le_weak, pmaj. intro abs. apply Qlt_minus_iff in q1. + rewrite abs in q1. apply (Qlt_not_le _ _ q1), Qle_refl. + apply (Qplus_le_l _ _ (q-r)). ring_simplify. exact q0. +Qed. + +Lemma DRealReprQ : forall (x : DReal) (q : Q), + proj1_sig x q = true + -> CRealLt (inject_Q q) (DRealRepr x). +Proof. + intros. + destruct (DRealOpen x q H) as [r rmaj]. + destruct (Qarchimedean (4/(r - q))) as [p pmaj]. + exists p. + destruct x as [f low]; unfold DRealRepr, inject_Q, proj1_sig. + destruct (DRealQlim (exist _ f low) (Pos.to_nat p)) as [s smaj]. + unfold proj1_sig in smaj, rmaj. + apply (Qplus_lt_l _ _ (q+ (1 # Pos.of_nat (S (Pos.to_nat p))))). + ring_simplify. rewrite <- (Qplus_comm s). + apply (UpperAboveLower f _ _ low). 2: apply smaj. + destruct low. apply (e _ r). 2: apply rmaj. + rewrite <- (Qplus_comm q). + apply (Qle_trans _ (q + (4#p))). + - rewrite <- Qplus_assoc. apply Qplus_le_r. + apply (Qle_trans _ ((2#p) + (1#p))). + apply Qplus_le_r. + unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. + apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. + rewrite Nat2Pos.id. apply le_S, le_refl. discriminate. + rewrite Qinv_plus_distr. unfold Qle, Qnum, Qden. + apply Z.mul_le_mono_nonneg_r. discriminate. discriminate. + - apply (Qle_trans _ (q + (r-q))). 2: ring_simplify; apply Qle_refl. + apply Qplus_le_r. + apply (Qmult_le_l _ _ ( (Z.pos p # 1) / (r-q))). + rewrite <- (Qmult_0_r (Z.pos p #1)). apply Qmult_lt_l. + reflexivity. apply Qinv_lt_0_compat. + unfold Qminus. rewrite <- Qlt_minus_iff. apply rmaj. + unfold Qdiv. rewrite Qmult_comm, <- Qmult_assoc. + rewrite (Qmult_comm (/(r-q))), Qmult_inv_r, Qmult_assoc. + setoid_replace ((4 # p) * (Z.pos p # 1))%Q with 4%Q. + 2: reflexivity. rewrite Qmult_1_r. + apply Qlt_le_weak, pmaj. intro abs. destruct rmaj. + apply Qlt_minus_iff in H0. + rewrite abs in H0. apply (Qlt_not_le _ _ H0), Qle_refl. +Qed. + +Lemma DRealReprQup : forall (x : DReal) (q : Q), + proj1_sig x q = false + -> CRealLe (DRealRepr x) (inject_Q q). +Proof. + intros x q H [p pmaj]. + unfold inject_Q, DRealRepr, proj1_sig in pmaj. + destruct (DRealQlim x (Pos.to_nat p)) as [r rmaj], rmaj. + clear H1. destruct x as [f low], low; unfold proj1_sig in H, H0. + apply (Qplus_lt_l _ _ q) in pmaj. ring_simplify in pmaj. + rewrite (e _ r) in H. discriminate. 2: exact H0. + apply Qlt_le_weak. apply (Qlt_trans _ ((2#p)+q)). 2: exact pmaj. + apply (Qplus_lt_l _ _ (-q)). ring_simplify. reflexivity. +Qed. + +Lemma DRealQuot1 : forall x y:DReal, CRealEq (DRealRepr x) (DRealRepr y) -> x = y. +Proof. + intros. destruct H. apply Rle_antisym. + - clear H. intros q H1. destruct (proj1_sig y q) eqn:des. + reflexivity. exfalso. apply H0. + apply (CReal_le_lt_trans _ (inject_Q q)). apply DRealReprQup. + exact des. apply DRealReprQ. exact H1. + - clear H0. intros q H1. destruct (proj1_sig x q) eqn:des. + reflexivity. exfalso. apply H. + apply (CReal_le_lt_trans _ (inject_Q q)). apply DRealReprQup. + exact des. apply DRealReprQ. exact H1. +Qed. + +Lemma DRealAbstrFalse : forall (x : CReal) (q : Q) (n : nat), + proj1_sig (DRealAbstr x) q = false + -> (proj1_sig x (S n) <= q + (1 # Pos.of_nat (S n)))%Q. +Proof. + intros. destruct x as [xn xcau]. + unfold DRealAbstr, proj1_sig in H. + destruct ( + sig_forall_dec (fun n : nat => (xn (S n) <= q + (1 # Pos.of_nat (S n)))%Q) + (fun n : nat => + match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (S n)) with + | left q0 => right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (S n)) q0) + | right q0 => left q0 + end)). + discriminate. apply q0. +Qed. + +Lemma DRealQuot2 : forall x:CReal, CRealEq (DRealRepr (DRealAbstr x)) x. +Proof. + split. + - intros [p pmaj]. unfold DRealRepr, proj1_sig in pmaj. + destruct x as [xn xcau]. + destruct (DRealQlim (DRealAbstr (exist _ xn xcau)) (Pos.to_nat p)) + as [q [_ qmaj]]. + (* By pmaj, q + 1/p < x as real numbers. + But by qmaj x <= q + 1/(p+1), contradiction. *) + apply (DRealAbstrFalse _ _ (pred (Pos.to_nat p))) in qmaj. + unfold proj1_sig in qmaj. + rewrite Nat.succ_pred in qmaj. + apply (Qlt_not_le _ _ pmaj), (Qplus_le_l _ _ q). + ring_simplify. apply (Qle_trans _ _ _ qmaj). + rewrite <- Qplus_assoc. apply Qplus_le_r. + rewrite Pos2Nat.id. apply (Qle_trans _ ((1#p)+(1#p))). + apply Qplus_le_l. unfold Qle, Qnum, Qden. + do 2 rewrite Z.mul_1_l. + apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. + rewrite Nat2Pos.id. apply le_S, le_refl. discriminate. + rewrite Qinv_plus_distr. apply Qle_refl. + intro abs. pose proof (Pos2Nat.is_pos p). + rewrite abs in H. inversion H. + - intros [p pmaj]. unfold DRealRepr, proj1_sig in pmaj. + destruct x as [xn xcau]. + destruct (DRealQlim (DRealAbstr (exist _ xn xcau)) (Pos.to_nat p)) + as [q [qmaj _]]. + (* By pmaj, x < q - 1/p *) + unfold DRealAbstr, proj1_sig in qmaj. + destruct ( + sig_forall_dec (fun n : nat => (xn (S n) <= q + (1 # Pos.of_nat (S n)))%Q) + (fun n : nat => + match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (S n)) with + | left q0 => + right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (S n)) q0) + | right q0 => left q0 + end)). + 2: discriminate. clear qmaj. + destruct s as [n nmaj]. apply nmaj. + apply (Qplus_lt_l _ _ (xn (Pos.to_nat p) + (1#Pos.of_nat (S n)))) in pmaj. + ring_simplify in pmaj. apply Qlt_le_weak. rewrite Qplus_comm. + apply (Qlt_trans _ ((2 # p) + xn (Pos.to_nat p) + (1 # Pos.of_nat (S n)))). + 2: exact pmaj. + apply (Qplus_lt_l _ _ (-xn (Pos.to_nat p))). + apply (Qle_lt_trans _ _ _ (Qle_Qabs _)). + destruct (le_lt_dec (S n) (Pos.to_nat p)). + + specialize (xcau (Pos.of_nat (S n)) (S n) (Pos.to_nat p)). + apply (Qlt_trans _ (1# Pos.of_nat (S n))). apply xcau. + rewrite Nat2Pos.id. apply le_refl. discriminate. + rewrite Nat2Pos.id. exact l. discriminate. + apply (Qplus_lt_l _ _ (-(1#Pos.of_nat (S n)))). + ring_simplify. reflexivity. + + apply (Qlt_trans _ (1#p)). apply xcau. + apply le_S_n in l. apply le_S, l. apply le_refl. + ring_simplify. apply (Qlt_trans _ (2#p)). + unfold Qlt, Qnum, Qden. + apply Z.mul_lt_mono_pos_r. reflexivity. reflexivity. + apply (Qplus_lt_l _ _ (-(2#p))). ring_simplify. reflexivity. +Qed. diff --git a/theories/Reals/ConstructiveCauchyReals.v b/theories/Reals/ConstructiveCauchyReals.v index 965d31d403..b83f8581d0 100644 --- a/theories/Reals/ConstructiveCauchyReals.v +++ b/theories/Reals/ConstructiveCauchyReals.v @@ -16,15 +16,7 @@ Require Import Logic.ConstructiveEpsilon. Require CMorphisms. (** 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. - + of rational numbers. Cauchy reals are Cauchy sequences of rational numbers, equipped with explicit moduli of convergence and @@ -705,6 +697,17 @@ Proof. right. rewrite H0, H. exact c. Qed. +Add Parametric Morphism : CRealLtProp + with signature CRealEq ==> CRealEq ==> iff + as CRealLtProp_morph. +Proof. + intros x y H x0 y0 H0. split. + - intro. apply CRealLtForget. apply CRealLtEpsilon in H1. + rewrite <- H, <- H0. exact H1. + - intro. apply CRealLtForget. apply CRealLtEpsilon in H1. + rewrite H, H0. exact H1. +Qed. + Add Parametric Morphism : CRealLe with signature CRealEq ==> CRealEq ==> iff as CRealLe_morph. @@ -772,6 +775,9 @@ Proof. intro q. exists (fun n => q). apply ConstCauchy. Defined. +Definition inject_Z : Z -> CReal + := fun n => inject_Q (n # 1). + Notation "0" := (inject_Q 0) : CReal_scope. Notation "1" := (inject_Q 1) : CReal_scope. Notation "2" := (inject_Q 2) : CReal_scope. @@ -1324,3 +1330,19 @@ Proof. apply (Qlt_not_le _ _ maj). apply (Qle_trans _ 0). apply (Qplus_le_l _ _ r). ring_simplify. exact H. discriminate. Qed. + +Lemma inject_Z_plus : forall q r : Z, + inject_Z (q + r) == inject_Z q + inject_Z r. +Proof. + intros. unfold inject_Z. + setoid_replace (q + r # 1)%Q with ((q#1) + (r#1))%Q. + apply inject_Q_plus. rewrite Qinv_plus_distr. reflexivity. +Qed. + +Lemma opp_inject_Z : forall n : Z, + inject_Z (-n) == - inject_Z n. +Proof. + intros. unfold inject_Z. + setoid_replace (-n # 1)%Q with (-(n#1))%Q. + rewrite opp_inject_Q. reflexivity. reflexivity. +Qed. diff --git a/theories/Reals/ConstructiveRIneq.v b/theories/Reals/ConstructiveRIneq.v deleted file mode 100644 index e0f08d2fbe..0000000000 --- a/theories/Reals/ConstructiveRIneq.v +++ /dev/null @@ -1,2817 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) -(************************************************************************) - -(*********************************************************) -(** * Basic lemmas for the contructive real numbers *) -(*********************************************************) - -(* Implement interface ConstructiveReals opaquely with - Cauchy reals and prove basic results. - Those are therefore true for any implementation of - ConstructiveReals (for example with Dedekind reals). - - This file is the recommended import for working with - constructive reals, do not use ConstructiveCauchyReals - directly. *) - -Require Import ConstructiveCauchyRealsMult. -Require Import ConstructiveRcomplete. -Require Export ConstructiveReals. -Require Import Zpower. -Require Export ZArithRing. -Require Import Omega. -Require Import QArith_base. -Require Import Qring. - -Declare Scope R_scope_constr. - -Local Open Scope Z_scope. -Local Open Scope R_scope_constr. - -Definition CRealImplem : ConstructiveReals. -Proof. - assert (isLinearOrder CReal CRealLt) as lin. - { repeat split. exact CRealLt_asym. - exact CReal_lt_trans. - intros. destruct (CRealLt_dec x z y H). - left. exact c. right. exact c. } - apply (Build_ConstructiveReals - CReal CRealLt lin CRealLtProp - CRealLtEpsilon CRealLtForget CRealLtDisjunctEpsilon - (inject_Q 0) (inject_Q 1) - CReal_plus CReal_opp CReal_mult - CReal_isRing CReal_isRingExt CRealLt_0_1 - 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 - 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. 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. - -Definition Req := orderEq R (CRlt CR). -Definition Rle (x y : R) := CRlt CR y x -> False. -Definition Rge (x y : R) := CRlt CR x y -> False. -Definition Rlt := CRlt CR. -Definition RltProp := CRltProp CR. -Definition Rgt (x y : R) := CRlt CR y x. -Definition Rappart := orderAppart R (CRlt CR). - -Infix "==" := Req : R_scope_constr. -Infix "#" := Rappart : R_scope_constr. -Infix "<" := Rlt : R_scope_constr. -Infix ">" := Rgt : R_scope_constr. -Infix "<=" := Rle : R_scope_constr. -Infix ">=" := Rge : R_scope_constr. - -Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope_constr. -Notation "x <= y < z" := (prod (x <= y) (y < z)) : R_scope_constr. -Notation "x < y < z" := (prod (x < y) (y < z)) : R_scope_constr. -Notation "x < y <= z" := (prod (x < y) (y <= z)) : R_scope_constr. - -Lemma Rlt_epsilon : forall x y : R, RltProp x y -> x < y. -Proof. - exact (CRltEpsilon CR). -Qed. - -Lemma Rlt_forget : forall x y : R, x < y -> RltProp x y. -Proof. - exact (CRltForget CR). -Qed. - -Lemma Rle_refl : forall x : R, x <= x. -Proof. - intros. intro abs. - destruct (CRltLinear CR), p. - exact (f x x abs abs). -Qed. -Hint Immediate Rle_refl: rorders. - -Lemma Req_refl : forall x : R, x == x. -Proof. - intros. split; apply Rle_refl. -Qed. - -Lemma Req_sym : forall x y : R, x == y -> y == x. -Proof. - intros. destruct H. split; intro abs; contradiction. -Qed. - -Lemma Req_trans : forall x y z : R, x == y -> y == z -> x == z. -Proof. - intros. destruct H,H0. destruct (CRltLinear CR), p. split. - - intro abs. destruct (s _ y _ abs); contradiction. - - intro abs. destruct (s _ y _ abs); contradiction. -Qed. - -Add Parametric Relation : R Req - reflexivity proved by Req_refl - symmetry proved by Req_sym - transitivity proved by Req_trans - as Req_rel. - -Instance Req_relT : CRelationClasses.Equivalence Req. -Proof. - split. exact Req_refl. exact Req_sym. exact Req_trans. -Qed. - -Lemma linear_order_T : forall x y z : R, - x < z -> (x < y) + (y < z). -Proof. - intros. destruct (CRltLinear CR). apply s. exact H. -Qed. - -Instance Rlt_morph - : CMorphisms.Proper - (CMorphisms.respectful Req (CMorphisms.respectful Req CRelationClasses.iffT)) Rlt. -Proof. - intros x y H x0 y0 H0. destruct H, H0. split. - - intro. destruct (linear_order_T x y x0). assumption. - contradiction. destruct (linear_order_T y y0 x0). - assumption. assumption. contradiction. - - intro. destruct (linear_order_T y x y0). assumption. - contradiction. destruct (linear_order_T x x0 y0). - assumption. assumption. contradiction. -Qed. - -Instance RltProp_morph - : Morphisms.Proper - (Morphisms.respectful Req (Morphisms.respectful Req iff)) RltProp. -Proof. - intros x y H x0 y0 H0. destruct H, H0. split. - - intro. destruct (linear_order_T x y x0). - apply Rlt_epsilon. assumption. - contradiction. destruct (linear_order_T y y0 x0). - assumption. apply Rlt_forget. assumption. contradiction. - - intro. destruct (linear_order_T y x y0). - apply Rlt_epsilon. assumption. - contradiction. destruct (linear_order_T x x0 y0). - assumption. apply Rlt_forget. assumption. contradiction. -Qed. - -Instance Rgt_morph - : CMorphisms.Proper - (CMorphisms.respectful Req (CMorphisms.respectful Req CRelationClasses.iffT)) Rgt. -Proof. - intros x y H x0 y0 H0. unfold Rgt. apply Rlt_morph; assumption. -Qed. - -Instance Rappart_morph - : CMorphisms.Proper - (CMorphisms.respectful Req (CMorphisms.respectful Req CRelationClasses.iffT)) Rappart. -Proof. - split. - - intros. destruct H1. left. rewrite <- H0, <- H. exact c. - right. rewrite <- H0, <- H. exact c. - - intros. destruct H1. left. rewrite H0, H. exact c. - right. rewrite H0, H. exact c. -Qed. - -Add Parametric Morphism : Rle - with signature Req ==> Req ==> iff - as Rle_morph. -Proof. - intros. split. - - intros H1 H2. unfold CRealLe in H1. - rewrite <- H0 in H2. rewrite <- H in H2. contradiction. - - intros H1 H2. unfold CRealLe in H1. - rewrite H0 in H2. rewrite H in H2. contradiction. -Qed. - -Add Parametric Morphism : Rge - with signature Req ==> Req ==> iff - as Rge_morph. -Proof. - intros. unfold Rge. apply Rle_morph; assumption. -Qed. - - -Definition Rplus := CRplus CR. -Definition Rmult := CRmult CR. -Definition Rinv := CRinv CR. -Definition Ropp := CRopp CR. - -Add Parametric Morphism : Rplus - with signature Req ==> Req ==> Req - as Rplus_morph. -Proof. - apply CRisRingExt. -Qed. - -Instance Rplus_morph_T - : CMorphisms.Proper - (CMorphisms.respectful Req (CMorphisms.respectful Req Req)) Rplus. -Proof. - apply CRisRingExt. -Qed. - -Add Parametric Morphism : Rmult - with signature Req ==> Req ==> Req - as Rmult_morph. -Proof. - apply CRisRingExt. -Qed. - -Instance Rmult_morph_T - : CMorphisms.Proper - (CMorphisms.respectful Req (CMorphisms.respectful Req Req)) Rmult. -Proof. - apply CRisRingExt. -Qed. - -Add Parametric Morphism : Ropp - with signature Req ==> Req - as Ropp_morph. -Proof. - apply CRisRingExt. -Qed. - -Instance Ropp_morph_T - : CMorphisms.Proper - (CMorphisms.respectful Req Req) Ropp. -Proof. - apply CRisRingExt. -Qed. - -Infix "+" := Rplus : R_scope_constr. -Notation "- x" := (Ropp x) : R_scope_constr. -Definition Rminus (r1 r2:R) : R := r1 + - r2. -Infix "-" := Rminus : R_scope_constr. -Infix "*" := Rmult : R_scope_constr. -Notation "/ x" := (CRinv CR x) (at level 35, right associativity) : R_scope_constr. - -Notation "0" := (CRzero CR) : R_scope_constr. -Notation "1" := (CRone CR) : R_scope_constr. - -Add Parametric Morphism : Rminus - with signature Req ==> Req ==> Req - as Rminus_morph. -Proof. - intros. unfold Rminus, CRminus. rewrite H,H0. reflexivity. -Qed. - - -(* Help Add Ring to find the correct equality *) -Lemma RisRing : ring_theory 0 1 - Rplus Rmult - Rminus Ropp - Req. -Proof. - exact (CRisRing CR). -Qed. - -Add Ring CRealRing : RisRing. - -Lemma Rplus_comm : forall x y:R, x + y == y + x. -Proof. intros. ring. Qed. - -Lemma Rplus_assoc : forall x y z:R, (x + y) + z == x + (y + z). -Proof. intros. ring. Qed. - -Lemma Rplus_opp_r : forall x:R, x + -x == 0. -Proof. intros. ring. Qed. - -Lemma Rplus_0_l : forall x:R, 0 + x == x. -Proof. intros. ring. Qed. - -Lemma Rmult_0_l : forall x:R, 0 * x == 0. -Proof. intros. ring. Qed. - -Lemma Rmult_1_l : forall x:R, 1 * x == x. -Proof. intros. ring. Qed. - -Lemma Rmult_comm : forall x y:R, x * y == y * x. -Proof. intros. ring. Qed. - -Lemma Rmult_assoc : forall x y z:R, (x * y) * z == x * (y * z). -Proof. intros. ring. Qed. - -Definition Rinv_l := CRinv_l CR. - -Lemma Rmult_plus_distr_l : forall r1 r2 r3 : R, - r1 * (r2 + r3) == (r1 * r2) + (r1 * r3). -Proof. intros. ring. Qed. - -Definition Rlt_0_1 := CRzero_lt_one CR. - -Lemma Rlt_asym : forall x y :R, x < y -> y < x -> False. -Proof. - intros. destruct (CRltLinear CR), p. - apply (f x y); assumption. -Qed. - -Lemma Rlt_trans : forall x y z : R, x < y -> y < z -> x < z. -Proof. - intros. destruct (CRltLinear CR), p. - apply (c x y); assumption. -Qed. - -Lemma Rplus_lt_compat_l : forall x y z : R, - y < z -> x + y < x + z. -Proof. - intros. apply CRplus_lt_compat_l. exact H. -Qed. - -Lemma Ropp_mult_distr_l - : forall r1 r2 : R, -(r1 * r2) == (- r1) * r2. -Proof. - intros. ring. -Qed. - -Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. -Proof. - intros. apply CRplus_lt_reg_l in H. exact H. -Qed. - -Lemma Rmult_lt_compat_l : forall x y z : R, - 0 < x -> y < z -> x * y < x * z. -Proof. - intros. apply (CRplus_lt_reg_l CR (- (x * y))). - rewrite Rplus_comm. pose proof Rplus_opp_r. - rewrite H1. - rewrite Rmult_comm, Ropp_mult_distr_l, Rmult_comm. - rewrite <- Rmult_plus_distr_l. - apply CRmult_lt_0_compat. exact H. - apply (Rplus_lt_reg_l y). - rewrite Rplus_comm, Rplus_0_l. - rewrite <- Rplus_assoc, H1, Rplus_0_l. exact H0. -Qed. - -Hint Resolve Rplus_comm Rplus_assoc Rplus_opp_r Rplus_0_l - Rmult_comm Rmult_assoc Rinv_l Rmult_1_l Rmult_plus_distr_l - Rlt_0_1 Rlt_asym Rlt_trans Rplus_lt_compat_l Rmult_lt_compat_l - Rmult_0_l : creal. - -Fixpoint INR (n:nat) : R := - 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) : R := - match p with - | xH => 1 + 1 - | xO p => (1 + 1) * IPR_2 p - | xI p => (1 + 1) * (1 + IPR_2 p) - end. - -Definition IPR (p:positive) : R := - 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) : R := - match z with - | Z0 => 0 - | Zpos n => IPR n - | Zneg n => - IPR n - end. -Arguments IZR z%Z : simpl never. - -Notation "2" := (IZR 2) : R_scope_constr. - - -(*********************************************************) -(** ** Relation between orders and equality *) -(*********************************************************) - -Lemma Rge_refl : forall r, r <= r. -Proof. exact Rle_refl. Qed. -Hint Immediate Rge_refl: rorders. - -(** Irreflexivity of the strict order *) - -Lemma Rlt_irrefl : forall r, r < r -> False. -Proof. - intros r H; eapply Rlt_asym; eauto. -Qed. -Hint Resolve Rlt_irrefl: creal. - -Lemma Rgt_irrefl : forall r, r > r -> False. -Proof. exact Rlt_irrefl. Qed. - -Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> r1 <> r2. -Proof. - intros. intro abs. subst r2. exact (Rlt_irrefl r1 H). -Qed. - -Lemma Rgt_not_eq : forall r1 r2, r1 > r2 -> r1 <> r2. -Proof. - intros; apply not_eq_sym; apply Rlt_not_eq; auto with creal. -Qed. - -(**********) -Lemma Rlt_dichotomy_converse : forall r1 r2, ((r1 < r2) + (r1 > r2)) -> r1 <> r2. -Proof. - intros. destruct H. - - intro abs. subst r2. exact (Rlt_irrefl r1 r). - - intro abs. subst r2. exact (Rlt_irrefl r1 r). -Qed. -Hint Resolve Rlt_dichotomy_converse: creal. - -(** Reasoning by case on equality and order *) - - -(*********************************************************) -(** ** Relating [<], [>], [<=] and [>=] *) -(*********************************************************) - -(*********************************************************) -(** ** Order *) -(*********************************************************) - -(** *** Relating strict and large orders *) - -Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2. -Proof. - intros. intro abs. apply (Rlt_asym r1 r2); assumption. -Qed. -Hint Resolve Rlt_le: creal. - -Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2. -Proof. - intros. intro abs. apply (Rlt_asym r1 r2); assumption. -Qed. - -(**********) -Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1. -Proof. - intros. intros abs. contradiction. -Qed. -Hint Immediate Rle_ge: creal. -Hint Resolve Rle_ge: rorders. - -Lemma Rge_le : forall r1 r2, r1 >= r2 -> r2 <= r1. -Proof. - intros. intro abs. contradiction. -Qed. -Hint Resolve Rge_le: creal. -Hint Immediate Rge_le: rorders. - -(**********) -Lemma Rlt_gt : forall r1 r2, r1 < r2 -> r2 > r1. -Proof. - trivial. -Qed. -Hint Resolve Rlt_gt: rorders. - -Lemma Rgt_lt : forall r1 r2, r1 > r2 -> r2 < r1. -Proof. - trivial. -Qed. -Hint Immediate Rgt_lt: rorders. - -(**********) - -Lemma Rnot_lt_le : forall r1 r2, (r1 < r2 -> False) -> r2 <= r1. -Proof. - intros. exact H. -Qed. - -Lemma Rnot_gt_le : forall r1 r2, (r1 > r2 -> False) -> r1 <= r2. -Proof. - intros. intro abs. contradiction. -Qed. - -Lemma Rnot_gt_ge : forall r1 r2, (r1 > r2 -> False) -> r2 >= r1. -Proof. - intros. intro abs. contradiction. -Qed. - -Lemma Rnot_lt_ge : forall r1 r2, (r1 < r2 -> False) -> r1 >= r2. -Proof. - intros. intro abs. contradiction. -Qed. - -(**********) -Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2. -Proof. - generalize Rlt_asym Rlt_dichotomy_converse; unfold CRealLe. - unfold not; intuition eauto 3. -Qed. -Hint Immediate Rlt_not_le: creal. - -Lemma Rgt_not_le : forall r1 r2, r1 > r2 -> ~ r1 <= r2. -Proof. exact Rlt_not_le. Qed. - -Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2. -Proof. red; intros; eapply Rlt_not_le; eauto with creal. Qed. -Hint Immediate Rlt_not_ge: creal. - -Lemma Rgt_not_ge : forall r1 r2, r2 > r1 -> ~ r1 >= r2. -Proof. exact Rlt_not_ge. Qed. - -Lemma Rle_not_lt : forall r1 r2, r2 <= r1 -> r1 < r2 -> False. -Proof. - intros r1 r2. generalize (Rlt_asym r1 r2) (Rlt_dichotomy_converse r1 r2). - unfold CRealLe; intuition. -Qed. - -Lemma Rge_not_lt : forall r1 r2, r1 >= r2 -> r1 < r2 -> False. -Proof. intros; apply (Rle_not_lt r1 r2); auto with creal. Qed. - -Lemma Rle_not_gt : forall r1 r2, r1 <= r2 -> r1 > r2 -> False. -Proof. do 2 intro; apply Rle_not_lt. Qed. - -Lemma Rge_not_gt : forall r1 r2, r2 >= r1 -> r1 > r2 -> False. -Proof. do 2 intro; apply Rge_not_lt. Qed. - -(**********) -Lemma Req_le : forall r1 r2, r1 = r2 -> r1 <= r2. -Proof. - intros. intro abs. subst r2. exact (Rlt_irrefl r1 abs). -Qed. -Hint Immediate Req_le: creal. - -Lemma Req_ge : forall r1 r2, r1 = r2 -> r1 >= r2. -Proof. - intros. intro abs. subst r2. exact (Rlt_irrefl r1 abs). -Qed. -Hint Immediate Req_ge: creal. - -Lemma Req_le_sym : forall r1 r2, r2 = r1 -> r1 <= r2. -Proof. - intros. intro abs. subst r2. exact (Rlt_irrefl r1 abs). -Qed. -Hint Immediate Req_le_sym: creal. - -Lemma Req_ge_sym : forall r1 r2, r2 = r1 -> r1 >= r2. -Proof. - intros. intro abs. subst r2. exact (Rlt_irrefl r1 abs). -Qed. -Hint Immediate Req_ge_sym: creal. - -(** *** Asymmetry *) - -(** Remark: [Rlt_asym] is an axiom *) - -Lemma Rgt_asym : forall r1 r2, r1 > r2 -> r2 > r1 -> False. -Proof. do 2 intro; apply Rlt_asym. Qed. - - -(** *** Compatibility with equality *) - -Lemma Rlt_eq_compat : - forall r1 r2 r3 r4, r1 = r2 -> r2 < r4 -> r4 = r3 -> r1 < r3. -Proof. - intros x x' y y'; intros; replace x with x'; replace y with y'; assumption. -Qed. - -Lemma Rgt_eq_compat : - forall r1 r2 r3 r4, r1 = r2 -> r2 > r4 -> r4 = r3 -> r1 > r3. -Proof. intros; red; apply Rlt_eq_compat with (r2:=r4) (r4:=r2); auto. Qed. - -(** *** Transitivity *) - -Lemma Rle_trans : forall r1 r2 r3, r1 <= r2 -> r2 <= r3 -> r1 <= r3. -Proof. - intros. intro abs. - destruct (linear_order_T r3 r2 r1 abs); contradiction. -Qed. - -Lemma Rge_trans : forall r1 r2 r3, r1 >= r2 -> r2 >= r3 -> r1 >= r3. -Proof. - intros. apply (Rle_trans _ r2); assumption. -Qed. - -Lemma Rgt_trans : forall r1 r2 r3, r1 > r2 -> r2 > r3 -> r1 > r3. -Proof. - intros. apply (Rlt_trans _ r2); assumption. -Qed. - -(**********) -Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3. -Proof. - intros. - destruct (linear_order_T r2 r1 r3 H0). contradiction. apply r. -Qed. - -Lemma Rlt_le_trans : forall r1 r2 r3, r1 < r2 -> r2 <= r3 -> r1 < r3. -Proof. - intros. - destruct (linear_order_T r1 r3 r2 H). apply r. contradiction. -Qed. - -Lemma Rge_gt_trans : forall r1 r2 r3, r1 >= r2 -> r2 > r3 -> r1 > r3. -Proof. - intros. apply (Rlt_le_trans _ r2); assumption. -Qed. - -Lemma Rgt_ge_trans : forall r1 r2 r3, r1 > r2 -> r2 >= r3 -> r1 > r3. -Proof. - intros. apply (Rle_lt_trans _ r2); assumption. -Qed. - - -(*********************************************************) -(** ** Addition *) -(*********************************************************) - -(** Remark: [Rplus_0_l] is an axiom *) - -Lemma Rplus_0_r : forall r, r + 0 == r. -Proof. - intros. rewrite Rplus_comm. rewrite Rplus_0_l. reflexivity. -Qed. -Hint Resolve Rplus_0_r: creal. - -Lemma Rplus_ne : forall r, r + 0 == r /\ 0 + r == r. -Proof. - split. apply Rplus_0_r. apply Rplus_0_l. -Qed. -Hint Resolve Rplus_ne: creal. - -(**********) - -(** Remark: [Rplus_opp_r] is an axiom *) - -Lemma Rplus_opp_l : forall r, - r + r == 0. -Proof. - intros. rewrite Rplus_comm. apply Rplus_opp_r. -Qed. -Hint Resolve Rplus_opp_l: creal. - -(**********) -Lemma Rplus_opp_r_uniq : forall r1 r2, r1 + r2 == 0 -> r2 == - r1. -Proof. - intros x y H. rewrite <- (Rplus_0_l y). - rewrite <- (Rplus_opp_l x). rewrite Rplus_assoc. - rewrite H. rewrite Rplus_0_r. reflexivity. -Qed. - -Lemma Rplus_eq_compat_l : forall r r1 r2, r1 == r2 -> r + r1 == r + r2. -Proof. - intros. rewrite H. reflexivity. -Qed. - -Lemma Rplus_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 + r == r2 + r. -Proof. - intros. rewrite H. reflexivity. -Qed. - - -(**********) -Lemma Rplus_eq_reg_l : forall r r1 r2, r + r1 == r + r2 -> r1 == r2. -Proof. - intros; transitivity (- r + r + r1). - rewrite Rplus_opp_l. rewrite Rplus_0_l. reflexivity. - transitivity (- r + r + r2). - repeat rewrite Rplus_assoc; rewrite <- H; reflexivity. - rewrite Rplus_opp_l. rewrite Rplus_0_l. reflexivity. -Qed. -Hint Resolve Rplus_eq_reg_l: creal. - -Lemma Rplus_eq_reg_r : forall r r1 r2, r1 + r == r2 + r -> r1 == r2. -Proof. - intros r r1 r2 H. - apply Rplus_eq_reg_l with r. - now rewrite 2!(Rplus_comm r). -Qed. - -(**********) -Lemma Rplus_0_r_uniq : forall r r1, r + r1 == r -> r1 == 0. -Proof. - intros. apply (Rplus_eq_reg_l r). rewrite Rplus_0_r. exact H. -Qed. - - -(*********************************************************) -(** ** Multiplication *) -(*********************************************************) - -(**********) -Lemma Rinv_r : forall r (rnz : r # 0), - r # 0 -> r * ((/ r) rnz) == 1. -Proof. - intros. rewrite Rmult_comm. rewrite Rinv_l. - reflexivity. -Qed. -Hint Resolve Rinv_r: creal. - -Lemma Rinv_l_sym : forall r (rnz: r # 0), 1 == (/ r) rnz * r. -Proof. - intros. symmetry. apply Rinv_l. -Qed. -Hint Resolve Rinv_l_sym: creal. - -Lemma Rinv_r_sym : forall r (rnz : r # 0), 1 == r * (/ r) rnz. -Proof. - intros. symmetry. apply Rinv_r. apply rnz. -Qed. -Hint Resolve Rinv_r_sym: creal. - -(**********) -Lemma Rmult_0_r : forall r, r * 0 == 0. -Proof. - intro; ring. -Qed. -Hint Resolve Rmult_0_r: creal. - -(**********) -Lemma Rmult_ne : forall r, r * 1 == r /\ 1 * r == r. -Proof. - intro; split; ring. -Qed. -Hint Resolve Rmult_ne: creal. - -(**********) -Lemma Rmult_1_r : forall r, r * 1 == r. -Proof. - intro; ring. -Qed. -Hint Resolve Rmult_1_r: creal. - -(**********) -Lemma Rmult_eq_compat_l : forall r r1 r2, r1 == r2 -> r * r1 == r * r2. -Proof. - intros. rewrite H. reflexivity. -Qed. - -Lemma Rmult_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 * r == r2 * r. -Proof. - intros. rewrite H. reflexivity. -Qed. - -(**********) -Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 == r * r2 -> r # 0 -> r1 == r2. -Proof. - intros. transitivity ((/ r) H0 * r * r1). - rewrite Rinv_l. ring. - transitivity ((/ r) H0 * r * r2). - repeat rewrite Rmult_assoc; rewrite H; reflexivity. - rewrite Rinv_l. ring. -Qed. - -Lemma Rmult_eq_reg_r : forall r r1 r2, r1 * r == r2 * r -> r # 0 -> r1 == r2. -Proof. - intros. - apply Rmult_eq_reg_l with (2 := H0). - now rewrite 2!(Rmult_comm r). -Qed. - -(**********) -Lemma Rmult_eq_0_compat : forall r1 r2, r1 == 0 \/ r2 == 0 -> r1 * r2 == 0. -Proof. - intros r1 r2 [H| H]; rewrite H; auto with creal. -Qed. - -Hint Resolve Rmult_eq_0_compat: creal. - -(**********) -Lemma Rmult_eq_0_compat_r : forall r1 r2, r1 == 0 -> r1 * r2 == 0. -Proof. - auto with creal. -Qed. - -(**********) -Lemma Rmult_eq_0_compat_l : forall r1 r2, r2 == 0 -> r1 * r2 == 0. -Proof. - auto with creal. -Qed. - -(**********) -Lemma Rmult_integral_contrapositive : - forall r1 r2, (prod (r1 # 0) (r2 # 0)) -> (r1 * r2) # 0. -Proof. - assert (forall r, 0 > r -> 0 < - r). - { intros. rewrite <- (Rplus_opp_l r), <- (Rplus_0_r (-r)), Rplus_assoc. - apply Rplus_lt_compat_l. rewrite Rplus_0_l. apply H. } - intros. destruct H0, r, r0. - - right. setoid_replace (r1*r2) with (-r1 * -r2). 2: ring. - rewrite <- (Rmult_0_r (-r1)). apply Rmult_lt_compat_l; apply H; assumption. - - left. rewrite <- (Rmult_0_r r2). - rewrite Rmult_comm. apply (Rmult_lt_compat_l). apply c0. apply c. - - left. rewrite <- (Rmult_0_r r1). apply (Rmult_lt_compat_l). apply c. apply c0. - - right. rewrite <- (Rmult_0_r r1). apply Rmult_lt_compat_l; assumption. -Qed. -Hint Resolve Rmult_integral_contrapositive: creal. - -Lemma Rmult_integral_contrapositive_currified : - forall r1 r2, r1 # 0 -> r2 # 0 -> (r1 * r2) # 0. -Proof. - intros. apply Rmult_integral_contrapositive. - split; assumption. -Qed. - -(**********) -Lemma Rmult_plus_distr_r : - forall r1 r2 r3, (r1 + r2) * r3 == r1 * r3 + r2 * r3. -Proof. - intros; ring. -Qed. - -(*********************************************************) -(** ** Square function *) -(*********************************************************) - -(***********) -Definition Rsqr (r : R) := r * r. - -Notation "r ²" := (Rsqr r) (at level 1, format "r ²") : R_scope_constr. - -(***********) -Lemma Rsqr_0 : Rsqr 0 == 0. - unfold Rsqr; auto with creal. -Qed. - -(*********************************************************) -(** ** Opposite *) -(*********************************************************) - -(**********) -Lemma Ropp_eq_compat : forall r1 r2, r1 == r2 -> - r1 == - r2. -Proof. - intros. rewrite H. reflexivity. -Qed. -Hint Resolve Ropp_eq_compat: creal. - -(**********) -Lemma Ropp_0 : -0 == 0. -Proof. - ring. -Qed. -Hint Resolve Ropp_0: creal. - -(**********) -Lemma Ropp_eq_0_compat : forall r, r == 0 -> - r == 0. -Proof. - intros; rewrite H; auto with creal. -Qed. -Hint Resolve Ropp_eq_0_compat: creal. - -(**********) -Lemma Ropp_involutive : forall r, - - r == r. -Proof. - intro; ring. -Qed. -Hint Resolve Ropp_involutive: creal. - -(**********) -Lemma Ropp_plus_distr : forall r1 r2, - (r1 + r2) == - r1 + - r2. -Proof. - intros; ring. -Qed. -Hint Resolve Ropp_plus_distr: creal. - -(*********************************************************) -(** ** Opposite and multiplication *) -(*********************************************************) - -Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 == - (r1 * r2). -Proof. - intros; ring. -Qed. -Hint Resolve Ropp_mult_distr_l_reverse: creal. - -(**********) -Lemma Rmult_opp_opp : forall r1 r2, - r1 * - r2 == r1 * r2. -Proof. - intros; ring. -Qed. -Hint Resolve Rmult_opp_opp: creal. - -Lemma Ropp_mult_distr_r : forall r1 r2, - (r1 * r2) == r1 * - r2. -Proof. - intros; ring. -Qed. - -Lemma Ropp_mult_distr_r_reverse : forall r1 r2, r1 * - r2 == - (r1 * r2). -Proof. - intros; ring. -Qed. - -(*********************************************************) -(** ** Subtraction *) -(*********************************************************) - -Lemma Rminus_0_r : forall r, r - 0 == r. -Proof. - intro r. unfold Rminus. ring. -Qed. -Hint Resolve Rminus_0_r: creal. - -Lemma Rminus_0_l : forall r, 0 - r == - r. -Proof. - intro r. unfold Rminus. ring. -Qed. -Hint Resolve Rminus_0_l: creal. - -(**********) -Lemma Ropp_minus_distr : forall r1 r2, - (r1 - r2) == r2 - r1. -Proof. - intros; ring. -Qed. -Hint Resolve Ropp_minus_distr: creal. - -Lemma Ropp_minus_distr' : forall r1 r2, - (r2 - r1) == r1 - r2. -Proof. - intros; ring. -Qed. - -(**********) -Lemma Rminus_diag_eq : forall r1 r2, r1 == r2 -> r1 - r2 == 0. -Proof. - intros; rewrite H; unfold Rminus; ring. -Qed. -Hint Resolve Rminus_diag_eq: creal. - -(**********) -Lemma Rminus_diag_uniq : forall r1 r2, r1 - r2 == 0 -> r1 == r2. -Proof. - intros r1 r2. unfold Rminus,CRminus; rewrite Rplus_comm; intro. - rewrite <- (Ropp_involutive r2); apply (Rplus_opp_r_uniq (- r2) r1 H). -Qed. -Hint Immediate Rminus_diag_uniq: creal. - -Lemma Rminus_diag_uniq_sym : forall r1 r2, r2 - r1 == 0 -> r1 == r2. -Proof. - intros; generalize (Rminus_diag_uniq r2 r1 H); clear H; - intro H; rewrite H; reflexivity. -Qed. -Hint Immediate Rminus_diag_uniq_sym: creal. - -Lemma Rplus_minus : forall r1 r2, r1 + (r2 - r1) == r2. -Proof. - intros; ring. -Qed. -Hint Resolve Rplus_minus: creal. - -(**********) -Lemma Rmult_minus_distr_l : - forall r1 r2 r3, r1 * (r2 - r3) == r1 * r2 - r1 * r3. -Proof. - intros; ring. -Qed. - - -(*********************************************************) -(** ** Order and addition *) -(*********************************************************) - -(** *** Compatibility *) - -(** Remark: [Rplus_lt_compat_l] is an axiom *) - -Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2. -Proof. - intros. apply Rplus_lt_compat_l. apply H. -Qed. -Hint Resolve Rplus_gt_compat_l: creal. - -(**********) -Lemma Rplus_lt_compat_r : forall r r1 r2, r1 < r2 -> r1 + r < r2 + r. -Proof. - intros. - rewrite (Rplus_comm r1 r); rewrite (Rplus_comm r2 r). - apply Rplus_lt_compat_l. exact H. -Qed. -Hint Resolve Rplus_lt_compat_r: creal. - -Lemma Rplus_gt_compat_r : forall r r1 r2, r1 > r2 -> r1 + r > r2 + r. -Proof. do 3 intro; apply Rplus_lt_compat_r. Qed. - -(**********) - -Lemma Rplus_lt_reg_r : forall r r1 r2, r1 + r < r2 + r -> r1 < r2. -Proof. - intros. - apply (Rplus_lt_reg_l r). - now rewrite 2!(Rplus_comm r). -Qed. - -Lemma Rplus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2. -Proof. - intros. intro abs. apply Rplus_lt_reg_l in abs. contradiction. -Qed. - -Lemma Rplus_ge_compat_l : forall r r1 r2, r1 >= r2 -> r + r1 >= r + r2. -Proof. - intros. apply Rplus_le_compat_l. apply H. -Qed. -Hint Resolve Rplus_ge_compat_l: creal. - -(**********) -Lemma Rplus_le_compat_r : forall r r1 r2, r1 <= r2 -> r1 + r <= r2 + r. -Proof. - intros. intro abs. apply Rplus_lt_reg_r in abs. contradiction. -Qed. - -Hint Resolve Rplus_le_compat_l Rplus_le_compat_r: creal. - -Lemma Rplus_ge_compat_r : forall r r1 r2, r1 >= r2 -> r1 + r >= r2 + r. -Proof. - intros. apply Rplus_le_compat_r. apply H. -Qed. - -(*********) -Lemma Rplus_lt_compat : - forall r1 r2 r3 r4, r1 < r2 -> r3 < r4 -> r1 + r3 < r2 + r4. -Proof. - intros; apply Rlt_trans with (r2 + r3); auto with creal. -Qed. -Hint Immediate Rplus_lt_compat: creal. - -Lemma Rplus_le_compat : - forall r1 r2 r3 r4, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4. -Proof. - intros; apply Rle_trans with (r2 + r3); auto with creal. -Qed. -Hint Immediate Rplus_le_compat: creal. - -Lemma Rplus_gt_compat : - forall r1 r2 r3 r4, r1 > r2 -> r3 > r4 -> r1 + r3 > r2 + r4. -Proof. - intros. apply Rplus_lt_compat; assumption. -Qed. - -Lemma Rplus_ge_compat : - forall r1 r2 r3 r4, r1 >= r2 -> r3 >= r4 -> r1 + r3 >= r2 + r4. -Proof. - intros. apply Rplus_le_compat; assumption. -Qed. - -(*********) -Lemma Rplus_lt_le_compat : - forall r1 r2 r3 r4, r1 < r2 -> r3 <= r4 -> r1 + r3 < r2 + r4. -Proof. - intros; apply Rlt_le_trans with (r2 + r3); auto with creal. -Qed. - -Lemma Rplus_le_lt_compat : - forall r1 r2 r3 r4, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4. -Proof. - intros; apply Rle_lt_trans with (r2 + r3); auto with creal. -Qed. - -Hint Immediate Rplus_lt_le_compat Rplus_le_lt_compat: creal. - -Lemma Rplus_gt_ge_compat : - forall r1 r2 r3 r4, r1 > r2 -> r3 >= r4 -> r1 + r3 > r2 + r4. -Proof. - intros. apply Rplus_lt_le_compat; assumption. -Qed. - -Lemma Rplus_ge_gt_compat : - forall r1 r2 r3 r4, r1 >= r2 -> r3 > r4 -> r1 + r3 > r2 + r4. -Proof. - intros. apply Rplus_le_lt_compat; assumption. -Qed. - -(**********) -Lemma Rplus_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 + r2. -Proof. - intros. apply (Rlt_trans _ (r1+0)). rewrite Rplus_0_r. exact H. - apply Rplus_lt_compat_l. exact H0. -Qed. - -Lemma Rplus_le_lt_0_compat : forall r1 r2, 0 <= r1 -> 0 < r2 -> 0 < r1 + r2. -Proof. - intros. apply (Rle_lt_trans _ (r1+0)). rewrite Rplus_0_r. exact H. - apply Rplus_lt_compat_l. exact H0. -Qed. - -Lemma Rplus_lt_le_0_compat : forall r1 r2, 0 < r1 -> 0 <= r2 -> 0 < r1 + r2. -Proof. - intros x y; intros; rewrite <- Rplus_comm; apply Rplus_le_lt_0_compat; - assumption. -Qed. - -Lemma Rplus_le_le_0_compat : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2. -Proof. - intros. apply (Rle_trans _ (r1+0)). rewrite Rplus_0_r. exact H. - apply Rplus_le_compat_l. exact H0. -Qed. - -(**********) -Lemma sum_inequa_Rle_lt : - forall a x b c y d, - a <= x -> x < b -> c < y -> y <= d -> a + c < x + y < b + d. -Proof. - intros; split. - apply Rlt_le_trans with (a + y); auto with creal. - apply Rlt_le_trans with (b + y); auto with creal. -Qed. - -(** *** Cancellation *) - -Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2. -Proof. - intros. intro abs. apply (Rplus_lt_compat_l r) in abs. contradiction. -Qed. - -Lemma Rplus_le_reg_r : forall r r1 r2, r1 + r <= r2 + r -> r1 <= r2. -Proof. - intros. - apply (Rplus_le_reg_l r). - now rewrite 2!(Rplus_comm r). -Qed. - -Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2. -Proof. - unfold CRealGt; intros; apply (Rplus_lt_reg_l r r2 r1 H). -Qed. - -Lemma Rplus_ge_reg_l : forall r r1 r2, r + r1 >= r + r2 -> r1 >= r2. -Proof. - intros; apply Rle_ge; apply Rplus_le_reg_l with r; auto with creal. -Qed. - -(**********) -Lemma Rplus_le_reg_pos_r : - forall r1 r2 r3, 0 <= r2 -> r1 + r2 <= r3 -> r1 <= r3. -Proof. - intros. apply (Rle_trans _ (r1+r2)). 2: exact H0. - rewrite <- (Rplus_0_r r1), Rplus_assoc. - apply Rplus_le_compat_l. rewrite Rplus_0_l. exact H. -Qed. - -Lemma Rplus_lt_reg_pos_r : forall r1 r2 r3, 0 <= r2 -> r1 + r2 < r3 -> r1 < r3. -Proof. - intros. apply (Rle_lt_trans _ (r1+r2)). 2: exact H0. - rewrite <- (Rplus_0_r r1), Rplus_assoc. - apply Rplus_le_compat_l. rewrite Rplus_0_l. exact H. -Qed. - -Lemma Rplus_ge_reg_neg_r : - forall r1 r2 r3, 0 >= r2 -> r1 + r2 >= r3 -> r1 >= r3. -Proof. - intros. apply (Rge_trans _ (r1+r2)). 2: exact H0. - apply Rle_ge. rewrite <- (Rplus_0_r r1), Rplus_assoc. - apply Rplus_le_compat_l. rewrite Rplus_0_l. exact H. -Qed. - -Lemma Rplus_gt_reg_neg_r : forall r1 r2 r3, 0 >= r2 -> r1 + r2 > r3 -> r1 > r3. -Proof. - intros. apply (Rlt_le_trans _ (r1+r2)). exact H0. - rewrite <- (Rplus_0_r r1), Rplus_assoc. - apply Rplus_le_compat_l. rewrite Rplus_0_l. exact H. -Qed. - -(***********) -Lemma Rplus_eq_0_l : - forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 == 0 -> r1 == 0. -Proof. - intros. split. - - intro abs. rewrite <- (Rplus_opp_r r1) in H1. - apply Rplus_eq_reg_l in H1. rewrite H1 in H0. clear H1. - apply (Rplus_le_compat_l r1) in H0. - rewrite Rplus_opp_r in H0. rewrite Rplus_0_r in H0. - contradiction. - - intro abs. clear H. rewrite <- (Rplus_opp_r r1) in H1. - apply Rplus_eq_reg_l in H1. rewrite H1 in H0. clear H1. - apply (Rplus_le_compat_l r1) in H0. - rewrite Rplus_opp_r in H0. rewrite Rplus_0_r in H0. - contradiction. -Qed. - -Lemma Rplus_eq_R0 : - forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 == 0 -> r1 == 0 /\ r2 == 0. -Proof. - intros a b; split. - apply Rplus_eq_0_l with b; auto with creal. - apply Rplus_eq_0_l with a; auto with creal. - rewrite Rplus_comm; auto with creal. -Qed. - - -(*********************************************************) -(** ** Order and opposite *) -(*********************************************************) - -(** *** Contravariant compatibility *) - -Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. -Proof. - unfold CRealGt; intros. - apply (Rplus_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. -Hint Resolve Ropp_gt_lt_contravar : creal. - -Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. -Proof. - intros. apply Ropp_gt_lt_contravar. exact H. -Qed. -Hint Resolve Ropp_lt_gt_contravar: creal. - -(**********) -Lemma Ropp_lt_contravar : forall r1 r2, r2 < r1 -> - r1 < - r2. -Proof. - auto with creal. -Qed. -Hint Resolve Ropp_lt_contravar: creal. - -Lemma Ropp_gt_contravar : forall r1 r2, r2 > r1 -> - r1 > - r2. -Proof. auto with creal. Qed. - -(**********) - -Lemma Ropp_lt_cancel : forall r1 r2, - r2 < - r1 -> r1 < r2. -Proof. - intros x y H'. - rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y); - auto with creal. -Qed. -Hint Immediate Ropp_lt_cancel: creal. - -Lemma Ropp_gt_cancel : forall r1 r2, - r2 > - r1 -> r1 > r2. -Proof. - intros. apply Ropp_lt_cancel. apply H. -Qed. - -Lemma Ropp_le_ge_contravar : forall r1 r2, r1 <= r2 -> - r1 >= - r2. -Proof. - intros. intro abs. apply Ropp_lt_cancel in abs. contradiction. -Qed. -Hint Resolve Ropp_le_ge_contravar: creal. - -Lemma Ropp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2. -Proof. - intros. intro abs. apply Ropp_lt_cancel in abs. contradiction. -Qed. -Hint Resolve Ropp_ge_le_contravar: creal. - -(**********) -Lemma Ropp_le_contravar : forall r1 r2, r2 <= r1 -> - r1 <= - r2. -Proof. - intros. intro abs. apply Ropp_lt_cancel in abs. contradiction. -Qed. -Hint Resolve Ropp_le_contravar: creal. - -Lemma Ropp_ge_contravar : forall r1 r2, r2 >= r1 -> - r1 >= - r2. -Proof. - intros. apply Ropp_le_contravar. apply H. -Qed. - -(**********) -Lemma Ropp_0_lt_gt_contravar : forall r, 0 < r -> 0 > - r. -Proof. - intros; setoid_replace 0 with (-0); auto with creal. ring. -Qed. -Hint Resolve Ropp_0_lt_gt_contravar: creal. - -Lemma Ropp_0_gt_lt_contravar : forall r, 0 > r -> 0 < - r. -Proof. - intros; setoid_replace 0 with (-0); auto with creal. ring. -Qed. -Hint Resolve Ropp_0_gt_lt_contravar: creal. - -(**********) -Lemma Ropp_lt_gt_0_contravar : forall r, r > 0 -> - r < 0. -Proof. - intros; rewrite <- Ropp_0; auto with creal. -Qed. -Hint Resolve Ropp_lt_gt_0_contravar: creal. - -Lemma Ropp_gt_lt_0_contravar : forall r, r < 0 -> - r > 0. -Proof. - intros; rewrite <- Ropp_0; auto with creal. -Qed. -Hint Resolve Ropp_gt_lt_0_contravar: creal. - -(**********) -Lemma Ropp_0_le_ge_contravar : forall r, 0 <= r -> 0 >= - r. -Proof. - intros; setoid_replace 0 with (-0); auto with creal. ring. -Qed. -Hint Resolve Ropp_0_le_ge_contravar: creal. - -Lemma Ropp_0_ge_le_contravar : forall r, 0 >= r -> 0 <= - r. -Proof. - intros; setoid_replace 0 with (-0); auto with creal. ring. -Qed. -Hint Resolve Ropp_0_ge_le_contravar: creal. - -(** *** Cancellation *) - -Lemma Ropp_le_cancel : forall r1 r2, - r2 <= - r1 -> r1 <= r2. -Proof. - intros. intro abs. apply Ropp_lt_gt_contravar in abs. contradiction. -Qed. -Hint Immediate Ropp_le_cancel: creal. - -Lemma Ropp_ge_cancel : forall r1 r2, - r2 >= - r1 -> r1 >= r2. -Proof. - intros. apply Ropp_le_cancel. apply H. -Qed. - -(*********************************************************) -(** ** Order and multiplication *) -(*********************************************************) - -(** Remark: [Rmult_lt_compat_l] is an axiom *) - -(** *** Covariant compatibility *) - -Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r. -Proof. - intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with creal. -Qed. -Hint Resolve Rmult_lt_compat_r : core. - -Lemma Rmult_gt_compat_r : forall r r1 r2, r > 0 -> r1 > r2 -> r1 * r > r2 * r. -Proof. - intros. apply Rmult_lt_compat_r; assumption. -Qed. - -Lemma Rmult_gt_compat_l : forall r r1 r2, r > 0 -> r1 > r2 -> r * r1 > r * r2. -Proof. - intros. apply Rmult_lt_compat_l; assumption. -Qed. - -Lemma Rmult_gt_0_lt_compat : - forall r1 r2 r3 r4, - r3 > 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. -Proof. - intros; apply Rlt_trans with (r2 * r3); auto with creal. -Qed. - -(*********) -Lemma Rmult_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 * r2. -Proof. - intros; setoid_replace 0 with (0 * r2); auto with creal. - rewrite Rmult_0_l. reflexivity. -Qed. - -Lemma Rmult_gt_0_compat : forall r1 r2, r1 > 0 -> r2 > 0 -> r1 * r2 > 0. -Proof. - apply Rmult_lt_0_compat. -Qed. - -(** *** Contravariant compatibility *) - -Lemma Rmult_lt_gt_compat_neg_l : - forall r r1 r2, r < 0 -> r1 < r2 -> r * r1 > r * r2. -Proof. - intros; setoid_replace r with (- - r); auto with creal. - rewrite (Ropp_mult_distr_l_reverse (- r)); - rewrite (Ropp_mult_distr_l_reverse (- r)). - apply Ropp_lt_gt_contravar; auto with creal. - rewrite Ropp_involutive. reflexivity. -Qed. - -(** *** Cancellation *) - -Lemma Rinv_0_lt_compat : forall r (rpos : 0 < r), 0 < (/ r) (inr rpos). -Proof. - intros. apply CRinv_0_lt_compat. exact rpos. -Qed. - -Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. -Proof. - intros z x y H H0. - apply (Rmult_lt_compat_l ((/z) (inr H))) in H0. - repeat rewrite <- Rmult_assoc in H0. rewrite Rinv_l in H0. - repeat rewrite Rmult_1_l in H0. apply H0. - apply Rinv_0_lt_compat. -Qed. - -Lemma Rmult_lt_reg_r : forall r r1 r2, 0 < r -> r1 * r < r2 * r -> r1 < r2. -Proof. - intros. - apply Rmult_lt_reg_l with r. - exact H. - now rewrite 2!(Rmult_comm r). -Qed. - -Lemma Rmult_gt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. -Proof. - intros. apply Rmult_lt_reg_l in H0; assumption. -Qed. - -Lemma Rmult_le_reg_l : forall r r1 r2, 0 < r -> r * r1 <= r * r2 -> r1 <= r2. -Proof. - intros. intro abs. apply (Rmult_lt_compat_l r) in abs. - contradiction. apply H. -Qed. - -Lemma Rmult_le_reg_r : forall r r1 r2, 0 < r -> r1 * r <= r2 * r -> r1 <= r2. -Proof. - intros. - apply Rmult_le_reg_l with r. - exact H. - now rewrite 2!(Rmult_comm r). -Qed. - -(*********************************************************) -(** ** Order and substraction *) -(*********************************************************) - -Lemma Rlt_minus : forall r1 r2, r1 < r2 -> r1 - r2 < 0. -Proof. - intros; apply (Rplus_lt_reg_l r2). - setoid_replace (r2 + (r1 - r2)) with r1 by ring. - now rewrite Rplus_0_r. -Qed. -Hint Resolve Rlt_minus: creal. - -Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0. -Proof. - intros; apply (Rplus_lt_reg_l r2). - setoid_replace (r2 + (r1 - r2)) with r1 by ring. - now rewrite Rplus_0_r. -Qed. - -Lemma Rlt_Rminus : forall a b, a < b -> 0 < b - a. -Proof. - intros a b; apply Rgt_minus. -Qed. - -(**********) -Lemma Rle_minus : forall r1 r2, r1 <= r2 -> r1 - r2 <= 0. -Proof. - intros. intro abs. apply (Rplus_lt_compat_l r2) in abs. - unfold Rminus in abs. - rewrite Rplus_0_r, Rplus_comm, Rplus_assoc, Rplus_opp_l, Rplus_0_r in abs. - contradiction. -Qed. - -Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0. -Proof. - intros. intro abs. apply (Rplus_lt_compat_l r2) in abs. - unfold Rminus in abs. - rewrite Rplus_0_r, Rplus_comm, Rplus_assoc, Rplus_opp_l, Rplus_0_r in abs. - contradiction. -Qed. - -(**********) -Lemma Rminus_lt : forall r1 r2, r1 - r2 < 0 -> r1 < r2. -Proof. - intros. rewrite <- (Rplus_opp_r r2) in H. - apply Rplus_lt_reg_r in H. exact H. -Qed. - -Lemma Rminus_gt : forall r1 r2, r1 - r2 > 0 -> r1 > r2. -Proof. - intros. rewrite <- (Rplus_opp_r r2) in H. - apply Rplus_lt_reg_r in H. exact H. -Qed. - -Lemma Rminus_gt_0_lt : forall a b, 0 < b - a -> a < b. -Proof. intro; intro; apply Rminus_gt. Qed. - -(**********) -Lemma Rminus_le : forall r1 r2, r1 - r2 <= 0 -> r1 <= r2. -Proof. - intros. rewrite <- (Rplus_opp_r r2) in H. - apply Rplus_le_reg_r in H. exact H. -Qed. - -Lemma Rminus_ge : forall r1 r2, r1 - r2 >= 0 -> r1 >= r2. -Proof. - intros. rewrite <- (Rplus_opp_r r2) in H. - apply Rplus_le_reg_r in H. exact H. -Qed. - -(**********) -Lemma tech_Rplus : forall r s, 0 <= r -> 0 < s -> r + s <> 0. -Proof. - intros; apply not_eq_sym; apply Rlt_not_eq. - rewrite Rplus_comm; setoid_replace 0 with (0 + 0); auto with creal. ring. -Qed. -Hint Immediate tech_Rplus: creal. - -(*********************************************************) -(** ** Zero is less than one *) -(*********************************************************) - -Lemma Rle_0_1 : 0 <= 1. -Proof. - intro abs. apply (Rlt_asym 0 1). - apply Rlt_0_1. apply abs. -Qed. - - -(*********************************************************) -(** ** Inverse *) -(*********************************************************) - -Lemma Rinv_1 : forall nz : 1 # 0, (/ 1) nz == 1. -Proof. - intros. rewrite <- (Rmult_1_l ((/1) nz)). rewrite Rinv_r. - reflexivity. right. apply Rlt_0_1. -Qed. -Hint Resolve Rinv_1: creal. - -(*********) -Lemma Ropp_inv_permute : forall r (rnz : r # 0) (ronz : (-r) # 0), - - (/ r) rnz == (/ - r) ronz. -Proof. - intros. - apply (Rmult_eq_reg_l (-r)). rewrite Rinv_r. - rewrite <- Ropp_mult_distr_l. rewrite <- Ropp_mult_distr_r. - rewrite Ropp_involutive. rewrite Rinv_r. reflexivity. - exact rnz. exact ronz. exact ronz. -Qed. - -(*********) -Lemma Rinv_neq_0_compat : forall r (rnz : r # 0), ((/ r) rnz) # 0. -Proof. - intros. destruct rnz. left. - assert (0 < (/-r) (inr (Ropp_0_gt_lt_contravar _ c))). - { apply Rinv_0_lt_compat. } - rewrite <- (Ropp_inv_permute _ (inl c)) in H. - apply Ropp_lt_cancel. rewrite Ropp_0. exact H. - right. apply Rinv_0_lt_compat. -Qed. -Hint Resolve Rinv_neq_0_compat: creal. - -(*********) -Lemma Rinv_involutive : forall r (rnz : r # 0) (rinz : ((/ r) rnz) # 0), - (/ ((/ r) rnz)) rinz == r. -Proof. - intros. apply (Rmult_eq_reg_l ((/r) rnz)). rewrite Rinv_r. - rewrite Rinv_l. reflexivity. exact rinz. exact rinz. -Qed. -Hint Resolve Rinv_involutive: creal. - -(*********) -Lemma Rinv_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 (Rmult_eq_reg_l r1). 2: exact r1nz. - rewrite <- Rmult_assoc. rewrite Rinv_r. rewrite Rmult_1_l. - apply (Rmult_eq_reg_l r2). 2: exact r2nz. - rewrite Rinv_r. rewrite <- Rmult_assoc. - rewrite (Rmult_comm r2 r1). rewrite Rinv_r. - reflexivity. exact rmnz. exact r2nz. exact r1nz. -Qed. - -Lemma Rinv_r_simpl_r : forall r1 r2 (rnz : r1 # 0), r1 * (/ r1) rnz * r2 == r2. -Proof. - intros; transitivity (1 * r2); auto with creal. - rewrite Rinv_r; auto with creal. rewrite Rmult_1_l. reflexivity. -Qed. - -Lemma Rinv_r_simpl_l : forall r1 r2 (rnz : r1 # 0), - r2 * r1 * (/ r1) rnz == r2. -Proof. - intros. rewrite Rmult_assoc. rewrite Rinv_r, Rmult_1_r. - reflexivity. exact rnz. -Qed. - -Lemma Rinv_r_simpl_m : forall r1 r2 (rnz : r1 # 0), - r1 * r2 * (/ r1) rnz == r2. -Proof. - intros. rewrite Rmult_comm, <- Rmult_assoc, Rinv_l, Rmult_1_l. - reflexivity. -Qed. -Hint Resolve Rinv_r_simpl_l Rinv_r_simpl_r Rinv_r_simpl_m: creal. - -(*********) -Lemma Rinv_mult_simpl : - forall r1 r2 r3 (r1nz : r1 # 0) (r2nz : r2 # 0), - r1 * (/ r2) r2nz * (r3 * (/ r1) r1nz) == r3 * (/ r2) r2nz. -Proof. - intros a b c; intros. - transitivity (a * (/ a) r1nz * (c * (/ b) r2nz)); auto with creal. - ring. -Qed. - -Lemma Rinv_eq_compat : forall x y (rxnz : x # 0) (rynz : y # 0), - x == y - -> (/ x) rxnz == (/ y) rynz. -Proof. - intros. apply (Rmult_eq_reg_l x). rewrite Rinv_r. - rewrite H. rewrite Rinv_r. reflexivity. - exact rynz. exact rxnz. exact rxnz. -Qed. - - -(*********************************************************) -(** ** Order and inverse *) -(*********************************************************) - -Lemma Rinv_lt_0_compat : forall r (rneg : r < 0), (/ r) (inl rneg) < 0. -Proof. - intros. assert (0 < (/-r) (inr (Ropp_0_gt_lt_contravar r rneg))). - { apply Rinv_0_lt_compat. } - rewrite <- Ropp_inv_permute in H. rewrite <- Ropp_0 in H. - apply Ropp_lt_cancel in H. apply H. -Qed. -Hint Resolve Rinv_lt_0_compat: creal. - - - -(*********************************************************) -(** ** Miscellaneous *) -(*********************************************************) - -(**********) -Lemma Rle_lt_0_plus_1 : forall r, 0 <= r -> 0 < r + 1. -Proof. - intros. apply (Rle_lt_trans _ (r+0)). rewrite Rplus_0_r. - exact H. apply Rplus_lt_compat_l. apply Rlt_0_1. -Qed. -Hint Resolve Rle_lt_0_plus_1: creal. - -(**********) -Lemma Rlt_plus_1 : forall r, r < r + 1. -Proof. - intro r. rewrite <- Rplus_0_r. rewrite Rplus_assoc. - apply Rplus_lt_compat_l. rewrite Rplus_0_l. exact Rlt_0_1. -Qed. -Hint Resolve Rlt_plus_1: creal. - -(**********) -Lemma tech_Rgt_minus : forall r1 r2, 0 < r2 -> r1 > r1 - r2. -Proof. - intros. apply (Rplus_lt_reg_r r2). - unfold Rminus, CRminus; rewrite Rplus_assoc, Rplus_opp_l. - apply Rplus_lt_compat_l. exact H. -Qed. - -(*********************************************************) -(** ** Injection from [N] to [R] *) -(*********************************************************) - -(**********) -Lemma S_INR : forall n:nat, INR (S n) == INR n + 1. -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. - - 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 Rlt_0_1. apply le_succ_r_T in H. destruct H. - rewrite S_INR. apply (Rlt_trans _ (INR (S m) + 0)). - rewrite Rplus_comm, Rplus_0_l. apply IHm. - apply le_n_S. exact l. - apply Rplus_lt_compat_l. exact Rlt_0_1. - subst n. rewrite (S_INR (S m)). rewrite <- (Rplus_0_l). - rewrite (Rplus_comm 0), Rplus_assoc. - apply Rplus_lt_compat_l. rewrite Rplus_0_l. - exact Rlt_0_1. -Qed. - -(**********) -Lemma S_O_plus_INR : forall n:nat, INR (1 + n) == INR 1 + INR n. -Proof. - intros; destruct n. - - rewrite Rplus_comm, Rplus_0_l. reflexivity. - - rewrite Rplus_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 Rplus_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. simpl. - unfold Rminus, CRminus. rewrite Ropp_0, Rplus_0_r. reflexivity. - intros; repeat rewrite S_INR; simpl. - rewrite H0. unfold Rminus. 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 Rmult_0_l. reflexivity. - - intros; repeat rewrite S_INR; simpl. - rewrite plus_INR. rewrite Hrecn; ring. -Qed. - -Lemma INR_IPR : forall p, INR (Pos.to_nat p) == IPR p. -Proof. - assert (H: forall p, 2 * 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. - rewrite Rplus_comm. reflexivity. - - unfold IPR_2; now rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. - - apply Rmult_1_r. } - intros [p|p|] ; unfold IPR. - rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H. - apply Rplus_comm. - now rewrite Pos2Nat.inj_xO, mult_INR, <- H. - easy. -Qed. - -Fixpoint pow (r:R) (n:nat) : R := - match n with - | O => 1 - | S n => r * (pow r n) - end. - -Lemma Rpow_eq_compat : forall (x y : R) (n : nat), - x == y -> pow x n == pow y n. -Proof. - intro x. induction n. - - reflexivity. - - intros. simpl. rewrite IHn, H. reflexivity. exact H. -Qed. - -Lemma pow_INR (m n: nat) : INR (m ^ n) == pow (INR m) n. -Proof. now induction n as [|n IHn];[ | simpl; rewrite mult_INR, IHn]. Qed. - -(*********) -Lemma lt_0_INR : forall n:nat, (0 < n)%nat -> 0 < INR n. -Proof. - intros. apply (lt_INR 0). exact H. -Qed. -Hint Resolve lt_0_INR: creal. - -Lemma lt_1_INR : forall n:nat, (1 < n)%nat -> 1 < INR n. -Proof. - apply lt_INR. -Qed. -Hint Resolve lt_1_INR: creal. - -(**********) -Lemma pos_INR_nat_of_P : forall p:positive, 0 < INR (Pos.to_nat p). -Proof. - intro; apply lt_0_INR. - simpl; auto with creal. - apply Pos2Nat.is_pos. -Qed. -Hint Resolve pos_INR_nat_of_P: creal. - -(**********) -Lemma pos_INR : forall n:nat, 0 <= INR n. -Proof. - intro n; case n. - simpl; auto with creal. - auto with arith creal. -Qed. -Hint Resolve pos_INR: creal. - -Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat. -Proof. - intros n m. revert n. - induction m ; intros n H. - - elim (Rlt_irrefl 0). - apply Rle_lt_trans with (2 := H). - apply pos_INR. - - destruct n as [|n]. - apply Nat.lt_0_succ. - apply lt_n_S, IHm. - rewrite 2!S_INR in H. - apply Rplus_lt_reg_r with (1 := H). -Qed. -Hint Resolve INR_lt: creal. - -(*********) -Lemma le_INR : forall n m:nat, (n <= m)%nat -> INR n <= INR m. -Proof. - simple induction 1; intros; auto with creal. - rewrite S_INR. - apply Rle_trans with (INR m0); auto with creal. -Qed. -Hint Resolve le_INR: creal. - -(**********) -Lemma INR_not_0 : forall n:nat, INR n <> 0 -> n <> 0%nat. -Proof. - red; intros n H H1. - apply H. - rewrite H1; trivial. -Qed. -Hint Immediate INR_not_0: creal. - -(**********) -Lemma not_0_INR : forall n:nat, n <> 0%nat -> 0 < INR n. -Proof. - intro n; case n. - intro; absurd (0%nat = 0%nat); trivial. - intros; rewrite S_INR. - apply (Rlt_le_trans _ (0 + 1)). rewrite Rplus_0_l. apply Rlt_0_1. - apply Rplus_le_compat_r. apply pos_INR. -Qed. -Hint Resolve not_0_INR: creal. - -Lemma not_INR : forall n m:nat, n <> m -> INR n # INR m. -Proof. - intros n m H; case (le_lt_dec n m); intros H1. - left. apply lt_INR. - case (le_lt_or_eq _ _ H1); intros H2. - exact H2. contradiction. - right. apply lt_INR. exact H1. -Qed. -Hint Resolve not_INR: creal. - -Lemma INR_eq : forall n m:nat, INR n == INR m -> n = m. -Proof. - intros n m HR. - destruct (dec_eq_nat n m) as [H|H]. - exact H. exfalso. - apply not_INR in H. destruct HR,H; contradiction. -Qed. -Hint Resolve INR_eq: creal. - -Lemma INR_le : forall n m:nat, INR n <= INR m -> (n <= m)%nat. -Proof. - intros n m. revert n. - induction m ; intros n H. - - destruct n. apply le_refl. exfalso. - rewrite S_INR in H. - assert (0 + 1 <= 0). apply (Rle_trans _ (INR n + 1)). - apply Rplus_le_compat_r. apply pos_INR. apply H. - rewrite Rplus_0_l in H0. apply H0. apply Rlt_0_1. - - destruct n as [|n]. apply le_0_n. - apply le_n_S, IHm. - rewrite 2!S_INR in H. - apply Rplus_le_reg_r in H. apply H. -Qed. -Hint Resolve INR_le: creal. - -Lemma not_1_INR : forall n:nat, n <> 1%nat -> INR n # 1. -Proof. - intros n. - apply not_INR. -Qed. -Hint Resolve not_1_INR: creal. - -(*********************************************************) -(** ** Injection from [Z] to [R] *) -(*********************************************************) - -Lemma IPR_pos : forall p:positive, 0 < IPR p. -Proof. - intro p. rewrite <- INR_IPR. apply (lt_INR 0), Pos2Nat.is_pos. -Qed. - -Lemma IPR_double : forall p:positive, IPR (2*p) == 2 * IPR p. -Proof. - intro p. destruct p; try reflexivity. - rewrite Rmult_1_r. 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). - unfold Rminus. 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 Rplus_0_l. reflexivity. - - rewrite Rplus_0_l. rewrite Z.add_0_l. reflexivity. - - rewrite Rplus_0_l. reflexivity. - - rewrite Rplus_comm,Rplus_0_l. reflexivity. - - rewrite <- Pos2Z.inj_add. unfold IZR. apply plus_IPR. - - apply plus_IZR_NEG_POS. - - rewrite Rplus_comm,Rplus_0_l, Z.add_0_r. reflexivity. - - rewrite Z.add_comm; rewrite Rplus_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 Rmult_0_l. rewrite Z.mul_0_l. reflexivity. - - destruct m. rewrite Z.mul_0_r, Rmult_0_r. reflexivity. - simpl; unfold IZR. apply mult_IPR. - simpl. unfold IZR. rewrite mult_IPR. ring. - - destruct m. rewrite Z.mul_0_r, Rmult_0_r. reflexivity. - simpl. unfold IZR. rewrite mult_IPR. ring. - simpl. unfold IZR. rewrite mult_IPR. ring. -Qed. - -Lemma pow_IZR : forall z n, pow (IZR z) n == IZR (Z.pow z (Z.of_nat n)). -Proof. - intros z [|n];simpl; trivial. reflexivity. - rewrite Zpower_pos_nat. - rewrite SuccNat2Pos.id_succ. unfold Zpower_nat;simpl. - rewrite mult_IZR. - induction n;simpl;trivial. reflexivity. - rewrite mult_IZR;ring[IHn]. -Qed. - -(**********) -Lemma succ_IZR : forall n:Z, IZR (Z.succ n) == IZR n + 1. -Proof. - intro; unfold Z.succ; apply plus_IZR. -Qed. - -(**********) -Lemma opp_IZR : forall n:Z, IZR (- n) == - IZR n. -Proof. - intros [|z|z]; unfold IZR; simpl; auto with creal. - ring. - reflexivity. rewrite Ropp_involutive. reflexivity. -Qed. - -Definition Ropp_Ropp_IZR := opp_IZR. - -Lemma minus_IZR : forall n m:Z, IZR (n - m) == IZR n - IZR m. -Proof. - intros; unfold Z.sub, Rminus,CRminus. - rewrite <- opp_IZR. - apply plus_IZR. -Qed. - -(**********) -Lemma Z_R_minus : forall n m:Z, IZR n - IZR m == IZR (n - m). -Proof. - intros z1 z2; unfold Rminus,CRminus; unfold Z.sub. - rewrite <- (Ropp_Ropp_IZR z2); symmetry; apply plus_IZR. -Qed. - -(**********) -Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. -Proof. - intro z; case z; simpl; intros. - elim (Rlt_irrefl _ H). - easy. - elim (Rlt_not_le _ _ H). - unfold IZR. - rewrite <- INR_IPR. - auto with creal. -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. - exact (Rgt_minus (IZR z2) (IZR z1) H). -Qed. - -(**********) -Lemma eq_IZR_R0 : forall n:Z, IZR n == 0 -> n = 0%Z. -Proof. - intro z; destruct z; simpl; intros; auto with zarith. - unfold IZR in H. rewrite <- INR_IPR in H. - apply (INR_eq _ 0) in H. - exfalso. pose proof (Pos2Nat.is_pos p). - rewrite H in H0. inversion H0. - unfold IZR in H. rewrite <- INR_IPR in H. - apply (Rplus_eq_compat_r (INR (Pos.to_nat p))) in H. - rewrite Rplus_opp_l, Rplus_0_l in H. symmetry in H. - apply (INR_eq _ 0) in H. - exfalso. pose proof (Pos2Nat.is_pos p). - rewrite H in H0. inversion H0. -Qed. - -(**********) -Lemma eq_IZR : forall n m:Z, IZR n == IZR m -> n = m. -Proof. - intros z1 z2 H; generalize (Rminus_diag_eq (IZR z1) (IZR z2) H); - rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0); - intro; omega. -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 (Rplus_lt_reg_r (-(IZR n))). - pose proof minus_IZR. unfold Rminus,CRminus 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 not_0_IZR : forall n:Z, n <> 0%Z -> IZR n # 0. -Proof. - intros. destruct n. exfalso. apply H. reflexivity. - right. apply (IZR_lt 0). reflexivity. - left. apply (IZR_lt _ 0). reflexivity. -Qed. - -(*********) -Lemma le_0_IZR : forall n:Z, 0 <= IZR n -> (0 <= n)%Z. -Proof. - intros. destruct n. discriminate. discriminate. - exfalso. rewrite <- Ropp_0 in H. unfold IZR in H. apply H. - apply Ropp_gt_lt_contravar. rewrite <- INR_IPR. - apply (lt_INR 0). apply Pos2Nat.is_pos. -Qed. - -(**********) -Lemma le_IZR : forall n m:Z, IZR n <= IZR m -> (n <= m)%Z. -Proof. - intros. apply (Rplus_le_compat_r (-(IZR n))) in H. - pose proof minus_IZR. unfold Rminus,CRminus in H0. - repeat rewrite <- H0 in H. unfold Zminus in H. - rewrite Z.add_opp_diag_r in H. - apply (Z.add_le_mono_l _ _ (-n)). ring_simplify. - rewrite Z.add_comm. apply le_0_IZR. apply H. -Qed. - -(**********) -Lemma le_IZR_R1 : forall n:Z, IZR n <= 1 -> (n <= 1)%Z. -Proof. - intros. apply (le_IZR n 1). apply H. -Qed. - -(**********) -Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m. -Proof. - intros m n H; apply Rnot_lt_ge. intro abs. - apply lt_IZR in abs. omega. -Qed. - -Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m. -Proof. - intros m n H; apply Rnot_lt_ge. intro abs. - apply lt_IZR in abs. omega. -Qed. - -Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 # IZR z2. -Proof. - intros. destruct (not_0_IZR (z1-z2)). - intro abs. apply H. rewrite <- (Z.add_cancel_r _ _ (-z2)). - ring_simplify. exact abs. - left. apply IZR_lt. apply (lt_IZR _ 0) in c. - rewrite (Z.add_lt_mono_r _ _ (-z2)). - ring_simplify. exact c. - right. apply IZR_lt. apply (lt_IZR 0) in c. - rewrite (Z.add_lt_mono_l _ _ (-z2)). - ring_simplify. rewrite Z.add_comm. exact c. -Qed. - -Hint Extern 0 (IZR _ <= IZR _) => apply IZR_le, Zle_bool_imp_le, eq_refl : creal. -Hint Extern 0 (IZR _ >= IZR _) => apply Rle_ge, IZR_le, Zle_bool_imp_le, eq_refl : creal. -Hint Extern 0 (IZR _ < IZR _) => apply IZR_lt, eq_refl : creal. -Hint Extern 0 (IZR _ > IZR _) => apply IZR_lt, eq_refl : creal. -Hint Extern 0 (IZR _ <> IZR _) => apply IZR_neq, Zeq_bool_neq, eq_refl : creal. - -Lemma one_IZR_lt1 : forall n:Z, -(1) < IZR n < 1 -> n = 0%Z. -Proof. - intros z [H1 H2]. - apply Z.le_antisymm. - apply Z.lt_succ_r; apply lt_IZR; trivial. - change 0%Z with (Z.succ (-1)). - apply Z.le_succ_l; apply lt_IZR; trivial. -Qed. - -Lemma one_IZR_r_R1 : - forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m. -Proof. - intros r z x [H1 H2] [H3 H4]. - cut ((z - x)%Z = 0%Z); auto with zarith. - apply one_IZR_lt1. - split; rewrite <- Z_R_minus. - setoid_replace (-(1)) with (r - (r + 1)). - unfold CReal_minus; apply Rplus_lt_le_compat; auto with creal. - ring. - setoid_replace 1 with (r + 1 - r). - unfold CReal_minus; apply Rplus_le_lt_compat; auto with creal. - ring. -Qed. - - -(**********) -Lemma single_z_r_R1 : - forall r (n m:Z), - r < IZR n -> IZR n <= r + 1 -> r < IZR m -> IZR m <= r + 1 -> n = m. -Proof. - intros; apply one_IZR_r_R1 with r; auto. -Qed. - -(**********) -Lemma tech_single_z_r_R1 : - forall r (n:Z), - r < IZR n -> - IZR n <= r + 1 -> - { s : Z & prod (s <> n) (r < IZR s <= r + 1) } -> False. -Proof. - intros r z H1 H2 [s [H3 [H4 H5]]]. - apply H3; apply single_z_r_R1 with r; trivial. -Qed. - - -Lemma Rmult_le_compat_l_half : forall r r1 r2, - 0 < r -> r1 <= r2 -> r * r1 <= r * r2. -Proof. - intros. intro abs. apply (Rmult_lt_reg_l) in abs. - contradiction. apply H. -Qed. - -Lemma INR_CR_of_Q : forall (n : nat), - CR_of_Q CR (Z.of_nat n # 1) == INR n. -Proof. - induction n. - - 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). - 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 (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 } - : (x < IZR n < x + 2 + (INR p)) - -> { n:Z & x < IZR n < x+2 }. -Proof. - destruct p. - - exists n. destruct H. split. exact r. rewrite Rplus_0_r in r0; exact r0. - - intros. destruct (linear_order_T (x+1+INR p) (IZR n) (x+2+INR p)). - do 2 rewrite Rplus_assoc. apply Rplus_lt_compat_l, Rplus_lt_compat_r. - rewrite <- (Rplus_0_r 1). apply Rplus_lt_compat_l. apply Rlt_0_1. - + apply (Rarchimedean_ind x (n-1)%Z p). unfold Zminus. - split; rewrite plus_IZR, opp_IZR. - setoid_replace (IZR 1) with 1. 2: reflexivity. - apply (Rplus_lt_reg_l 1). ring_simplify. - apply (Rle_lt_trans _ (x + 1 + INR p)). 2: exact r. - rewrite Rplus_assoc. apply Rplus_le_compat_l. - rewrite <- (Rplus_0_r 1), Rplus_assoc. apply Rplus_le_compat_l. - rewrite Rplus_0_l. apply (le_INR 0), le_0_n. - setoid_replace (IZR 1) with 1. 2: reflexivity. - apply (Rplus_lt_reg_l 1). ring_simplify. - setoid_replace (x + 2 + INR p + 1) with (x + 2 + INR (S p)). - apply H. rewrite S_INR. ring. - + apply (Rarchimedean_ind x n p). split. apply H. exact r. -Qed. - -Lemma Rarchimedean (x:R) : { n : Z & x < IZR n < x + 2 }. -Proof. - destruct (Rup_nat x) as [n nmaj]. - destruct (Rup_nat (INR n + - (x + 2))) as [p pmaj]. - apply (Rplus_lt_compat_r (x+2)) in pmaj. - rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r in pmaj. - apply (Rarchimedean_ind x (Z.of_nat n) p). - split; rewrite <- INR_IZR_INZ. exact nmaj. - rewrite Rplus_comm in pmaj. exact pmaj. -Qed. - -Lemma Rmult_le_0_compat : forall a b, - 0 <= a -> 0 <= b -> 0 <= a * b. -Proof. - (* Limit of (a + 1/n)*b when n -> infty. *) - intros. intro abs. - assert (0 < -(a*b)) as epsPos. - { rewrite <- Ropp_0. apply Ropp_gt_lt_contravar. apply abs. } - pose proof (Rup_nat (b * (/ (-(a*b))) (inr (Ropp_0_gt_lt_contravar _ abs)))) - as [n maj]. - destruct n as [|n]. - - simpl in maj. apply (Rmult_lt_compat_r (-(a*b))) in maj. - rewrite Rmult_0_l in maj. - rewrite Rmult_assoc in maj. rewrite Rinv_l in maj. - rewrite Rmult_1_r in maj. contradiction. - apply epsPos. - - (* n > 0 *) - assert (0 < INR (S n)) as nPos. - { apply (lt_INR 0). apply le_n_S, le_0_n. } - assert (b * (/ (INR (S n))) (inr nPos) < -(a*b)). - { apply (Rmult_lt_reg_r (INR (S n))). apply nPos. - rewrite Rmult_assoc. rewrite Rinv_l. - rewrite Rmult_1_r. apply (Rmult_lt_compat_r (-(a*b))) in maj. - rewrite Rmult_assoc in maj. rewrite Rinv_l in maj. - rewrite Rmult_1_r in maj. rewrite Rmult_comm. - apply maj. exact epsPos. } - pose proof (Rmult_le_compat_l_half (a + (/ (INR (S n))) (inr nPos)) - 0 b). - assert (a + (/ (INR (S n))) (inr nPos) > 0 + 0). - apply Rplus_le_lt_compat. apply H. apply Rinv_0_lt_compat. - rewrite Rplus_0_l in H3. specialize (H2 H3 H0). - clear H3. rewrite Rmult_0_r in H2. - apply H2. clear H2. rewrite Rmult_plus_distr_r. - apply (Rplus_lt_compat_l (a*b)) in H1. - rewrite Rplus_opp_r in H1. - rewrite (Rmult_comm ((/ (INR (S n))) (inr nPos))). - apply H1. -Qed. - -Lemma Rmult_le_compat_l : forall r r1 r2, - 0 <= r -> r1 <= r2 -> r * r1 <= r * r2. -Proof. - intros. apply Rminus_ge. apply Rge_minus in H0. - unfold Rminus,CRminus. rewrite Ropp_mult_distr_r. - rewrite <- Rmult_plus_distr_l. - apply Rmult_le_0_compat; assumption. -Qed. -Hint Resolve Rmult_le_compat_l: creal. - -Lemma Rmult_le_compat_r : forall r r1 r2, - 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r. -Proof. - intros. rewrite <- (Rmult_comm r). rewrite <- (Rmult_comm r). - apply Rmult_le_compat_l; assumption. -Qed. -Hint Resolve Rmult_le_compat_r: creal. - -(*********) -Lemma Rmult_le_0_lt_compat : - forall r1 r2 r3 r4, - 0 <= r1 -> 0 <= r3 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. -Proof. - intros. apply (Rle_lt_trans _ (r2 * r3)). - apply Rmult_le_compat_r. apply H0. intro abs. apply (Rlt_asym r1 r2 H1). - apply abs. apply Rmult_lt_compat_l. exact (Rle_lt_trans 0 r1 r2 H H1). - exact H2. -Qed. - -Lemma Rmult_le_compat_neg_l : - forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r2 <= r * r1. -Proof. - intros. apply Ropp_le_cancel. - do 2 rewrite Ropp_mult_distr_l. apply Rmult_le_compat_l. - 2: exact H0. apply Ropp_0_ge_le_contravar. exact H. -Qed. -Hint Resolve Rmult_le_compat_neg_l: creal. - -Lemma Rmult_le_ge_compat_neg_l : - forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r1 >= r * r2. -Proof. - intros; apply Rle_ge; auto with creal. -Qed. -Hint Resolve Rmult_le_ge_compat_neg_l: creal. - - -(**********) -Lemma Rmult_ge_compat_l : - forall r r1 r2, r >= 0 -> r1 >= r2 -> r * r1 >= r * r2. -Proof. - intros. apply Rmult_le_compat_l; assumption. -Qed. - -Lemma Rmult_ge_compat_r : - forall r r1 r2, r >= 0 -> r1 >= r2 -> r1 * r >= r2 * r. -Proof. - intros. apply Rmult_le_compat_r; assumption. -Qed. - - -(**********) -Lemma Rmult_le_compat : - forall r1 r2 r3 r4, - 0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4. -Proof. - intros x y z t H' H'0 H'1 H'2. - apply Rle_trans with (r2 := x * t); auto with creal. - repeat rewrite (fun x => Rmult_comm x t). - apply Rmult_le_compat_l; auto. - apply Rle_trans with z; auto. -Qed. -Hint Resolve Rmult_le_compat: creal. - -Lemma Rmult_ge_compat : - forall r1 r2 r3 r4, - r2 >= 0 -> r4 >= 0 -> r1 >= r2 -> r3 >= r4 -> r1 * r3 >= r2 * r4. -Proof. auto with creal rorders. Qed. - -Lemma mult_IPR_IZR : forall (n:positive) (m:Z), IZR (Z.pos n * m) == IPR n * IZR m. -Proof. - intros. rewrite mult_IZR. apply Rmult_eq_compat_r. reflexivity. -Qed. - -Definition IQR (q:Q) : R := - match q with - | Qmake a b => IZR a * (/ (IPR b)) (inr (IPR_pos b)) - end. -Arguments IQR q%Q : simpl never. - -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 Rmult_plus_distr_r. - repeat rewrite Rmult_assoc. rewrite <- (Rmult_assoc (IZR (Z.pos Qden))). - rewrite Rinv_r. rewrite Rmult_1_l. - rewrite (Rmult_comm ((/IPR Qden) (inr (IPR_pos Qden)))). - rewrite <- (Rmult_assoc (IZR (Z.pos Qden0))). - rewrite Rinv_r. rewrite Rmult_1_l. reflexivity. unfold IZR. - right. apply IPR_pos. - right. apply IPR_pos. - rewrite <- (Rinv_mult_distr - _ _ _ _ (inr (Rmult_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 Rmult_lt_0_compat. apply (IZR_lt 0). - unfold Qlt in H; simpl in H. - rewrite Z.mul_1_r in H. apply H. - apply Rinv_0_lt_compat. -Qed. - -Lemma opp_IQR : forall q:Q, IQR (- q) == - IQR q. -Proof. - intros [a b]; unfold IQR; simpl. - rewrite Ropp_mult_distr_l. - rewrite opp_IZR. reflexivity. -Qed. - -Lemma lt_IQR : forall n m:Q, IQR n < IQR m -> (n < m)%Q. -Proof. - intros. destruct n,m; unfold IQR in H. - unfold Qlt; simpl. apply (Rmult_lt_compat_r (IPR Qden)) in H. - rewrite Rmult_assoc in H. rewrite Rinv_l in H. - rewrite Rmult_1_r in H. rewrite (Rmult_comm (IZR Qnum0)) in H. - apply (Rmult_lt_compat_l (IPR Qden0)) in H. - do 2 rewrite <- Rmult_assoc in H. rewrite Rinv_r in H. - rewrite Rmult_1_l in H. - rewrite (Rmult_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. - right. rewrite <- INR_IPR. apply (lt_INR 0). apply Pos2Nat.is_pos. - rewrite <- INR_IPR. apply (lt_INR 0). apply Pos2Nat.is_pos. - apply IPR_pos. -Qed. - -Lemma IQR_lt : forall n m:Q, Qlt n m -> IQR n < IQR m. -Proof. - intros. apply (Rplus_lt_reg_r (-IQR n)). - rewrite Rplus_opp_r. rewrite <- opp_IQR. rewrite <- plus_IQR. - apply IQR_pos. apply (Qplus_lt_l _ _ n). - ring_simplify. apply H. -Qed. - -Lemma IQR_nonneg : forall q:Q, Qle 0 q -> 0 <= (IQR q). -Proof. - intros [a b] H. unfold IQR;simpl. - apply (Rle_trans _ (IZR a * 0)). rewrite Rmult_0_r. apply Rle_refl. - apply Rmult_le_compat_l. - apply (IZR_le 0 a). unfold Qle in H; simpl in H. - rewrite Z.mul_1_r in H. apply H. - unfold Rle. apply Rlt_asym. apply Rinv_0_lt_compat. -Qed. - -Lemma IQR_le : forall n m:Q, Qle n m -> IQR n <= IQR m. -Proof. - intros. apply (Rplus_le_reg_r (-IQR n)). - rewrite Rplus_opp_r. rewrite <- opp_IQR. rewrite <- plus_IQR. - apply IQR_nonneg. apply (Qplus_le_l _ _ n). - ring_simplify. apply H. -Qed. - -Add Parametric Morphism : IQR - with signature Qeq ==> Req - as IQR_morph. -Proof. - intros. destruct x,y; unfold IQR; simpl. - unfold Qeq in H; simpl in H. - apply (Rmult_eq_reg_r (IZR (Z.pos Qden))). - rewrite Rmult_assoc. rewrite Rinv_l. rewrite Rmult_1_r. - rewrite (Rmult_comm (IZR Qnum0)). - apply (Rmult_eq_reg_l (IZR (Z.pos Qden0))). - rewrite <- Rmult_assoc. rewrite <- Rmult_assoc. rewrite Rinv_r. - rewrite Rmult_1_l. - repeat rewrite <- mult_IZR. - rewrite <- H. rewrite Zmult_comm. reflexivity. - right. apply IPR_pos. - right. apply (IZR_lt 0). apply Pos2Z.is_pos. - right. apply IPR_pos. -Qed. - -Instance IQR_morph_T - : CMorphisms.Proper - (CMorphisms.respectful Qeq Req) IQR. -Proof. - intros x y H. destruct x,y; unfold IQR. - unfold Qeq in H; simpl in H. - apply (Rmult_eq_reg_r (IZR (Z.pos Qden))). - 2: right; apply IPR_pos. - rewrite Rmult_assoc, Rinv_l, Rmult_1_r. - rewrite (Rmult_comm (IZR Qnum0)). - apply (Rmult_eq_reg_l (IZR (Z.pos Qden0))). - 2: right; apply IPR_pos. - rewrite <- Rmult_assoc, <- Rmult_assoc, Rinv_r. - rewrite Rmult_1_l. - repeat rewrite <- mult_IZR. - rewrite <- H. rewrite Zmult_comm. reflexivity. - right; apply IPR_pos. -Qed. - -Fixpoint Rfloor_pos (a : R) (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 (Rlt_asym 0 a); assumption. - - destruct n as [|p] eqn:des. - + (* n = 1 *) exists O. split. - apply H. rewrite Rplus_0_l. apply (Rlt_trans a (1+0)). - rewrite Rplus_comm, Rplus_0_l. apply H0. - apply Rplus_le_lt_compat. - apply Rle_refl. apply Rlt_0_1. - + (* n > 1 *) - destruct (linear_order_T (INR p) a (INR (S p))). - * rewrite <- Rplus_0_l, S_INR, Rplus_comm. apply Rplus_lt_compat_l. - apply Rlt_0_1. - * exists p. split. exact r. - rewrite S_INR, S_INR, Rplus_assoc in H0. exact H0. - * apply (Rfloor_pos a n H). rewrite des. apply r. -Qed. - -Definition Rfloor (a : R) - : { p : Z & IZR p < a < IZR p + 2 }. -Proof. - destruct (linear_order_T 0 a 1 Rlt_0_1). - - destruct (Rup_nat a). destruct (Rfloor_pos a x r r0). - exists (Z.of_nat x0). split; rewrite <- INR_IZR_INZ; apply p. - - apply (Rplus_lt_compat_l (-a)) in r. - rewrite Rplus_comm, Rplus_opp_r, Rplus_comm in r. - destruct (Rup_nat (1-a)). - destruct (Rfloor_pos (1-a) x r r0). - exists (-(Z.of_nat x0 + 1))%Z. split; rewrite opp_IZR, plus_IZR. - + rewrite <- (Ropp_involutive a). apply Ropp_gt_lt_contravar. - destruct p as [_ a0]. apply (Rplus_lt_reg_r 1). - rewrite Rplus_comm, Rplus_assoc. rewrite <- INR_IZR_INZ. apply a0. - + destruct p as [a0 _]. apply (Rplus_lt_compat_l a) in a0. - unfold Rminus in a0. - rewrite <- (Rplus_comm (1+-a)), Rplus_assoc, Rplus_opp_l, Rplus_0_r in a0. - rewrite <- INR_IZR_INZ. - apply (Rplus_lt_reg_r (INR x0)). unfold IZR, IPR, IPR_2. - ring_simplify. exact a0. -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 is how real numbers compute, - and they are measured by exact rational numbers. *) -Definition RQ_dense (a b : R) - : a < b -> { q : Q & a < IQR q < b }. -Proof. - intros H0. - assert (0 < b - a) as epsPos. - { apply (Rplus_lt_compat_r (-a)) in H0. - rewrite Rplus_opp_r in H0. apply H0. } - pose proof (Rup_nat ((/(b-a)) (inr epsPos))) - as [n maj]. - destruct n as [|k]. - - exfalso. - apply (Rmult_lt_compat_l (b-a)) in maj. 2: apply epsPos. - rewrite Rmult_0_r in maj. rewrite Rinv_r in maj. - apply (Rlt_asym 0 1). apply Rlt_0_1. apply maj. - right. apply epsPos. - - (* 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 (Rlt_trans a (b - IQR (1 # n))). - apply (Rplus_lt_reg_r (IQR (1#n))). - unfold Rminus,CRminus. rewrite Rplus_assoc. rewrite Rplus_opp_l. - rewrite Rplus_0_r. apply (Rplus_lt_reg_l (-a)). - rewrite <- Rplus_assoc, Rplus_opp_l, Rplus_0_l. - rewrite Rplus_comm. unfold IQR. - rewrite Rmult_1_l. apply (Rmult_lt_reg_l (IPR n)). - apply IPR_pos. rewrite Rinv_r. - apply (Rmult_lt_compat_l (b-a)) in maj. - rewrite Rinv_r, Rmult_comm in maj. - rewrite <- INR_IPR. unfold n. rewrite Nat2Pos.id. - apply maj. discriminate. right. exact epsPos. exact epsPos. - right. apply IPR_pos. - apply (Rplus_lt_reg_r (IQR (1 # n))). - unfold Rminus,CRminus. rewrite Rplus_assoc, Rplus_opp_l. - rewrite Rplus_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 (Rmult_lt_reg_r (IZR (Z.pos (2 * n)))). - apply (IZR_lt 0). reflexivity. rewrite Rmult_assoc. - rewrite Rinv_l. rewrite Rmult_1_r. rewrite Rmult_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 (Rmult_lt_reg_r (IZR (Z.pos (2 * n)))). - apply (IZR_lt 0). apply Pos2Z.is_pos. rewrite Rmult_assoc, Rinv_l. - rewrite Rmult_1_r, Rmult_comm. apply maj2. -Qed. - -Definition RQ_limit : forall (x : R) (n:nat), - { q:Q & x < IQR q < x + IQR (1 # Pos.of_nat n) }. -Proof. - intros x n. apply (RQ_dense x (x + IQR (1 # Pos.of_nat n))). - rewrite <- (Rplus_0_r x). rewrite Rplus_assoc. - apply Rplus_lt_compat_l. rewrite Rplus_0_l. apply IQR_pos. - reflexivity. -Qed. - -(* Rlt is decided by the LPO in Type, - which is a non-constructive oracle. *) -Lemma Rlt_lpo_dec : forall x y : R, - (forall (P : nat -> Prop), (forall n, {P n} + {~P n}) - -> {n | ~P n} + {forall n, P n}) - -> (x < y) + (y <= x). -Proof. - intros x y lpo. - pose (fun n => let (l,_) := RQ_limit x n in l) as xn. - pose (fun n => let (l,_) := RQ_limit y n in l) as yn. - destruct (lpo (fun n:nat => Qle (yn n - xn n) (1 # Pos.of_nat n))). - - intro n. destruct (Qlt_le_dec (1 # Pos.of_nat n) (yn n - xn n)). - right. apply Qlt_not_le. exact q. left. exact q. - - left. destruct s as [n nmaj]. unfold xn,yn in nmaj. - destruct (RQ_limit x n), (RQ_limit y n); unfold proj1_sig in nmaj. - apply Qnot_le_lt in nmaj. - apply (Rlt_le_trans x (IQR x0)). apply p. - apply (Rle_trans _ (IQR (x1 - (1# Pos.of_nat n)))). - apply IQR_le. apply (Qplus_le_l _ _ ((1#Pos.of_nat n) - x0)). - ring_simplify. ring_simplify in nmaj. rewrite Qplus_comm. - apply Qlt_le_weak. exact nmaj. - unfold Qminus. rewrite plus_IQR,opp_IQR. - apply (Rplus_le_reg_r (IQR (1#Pos.of_nat n))). - ring_simplify. unfold Rle. apply Rlt_asym. rewrite Rplus_comm. apply p0. - - right. intro abs. - pose ((y - x) * IQR (1#2)) as eps. - assert (0 < eps) as epsPos. - { apply Rmult_lt_0_compat. apply Rgt_minus. exact abs. - apply IQR_pos. reflexivity. } - destruct (Rup_nat ((/eps) (inr epsPos))) as [n nmaj]. - specialize (q (S n)). unfold xn, yn in q. - destruct (RQ_limit x (S n)) as [a amaj], (RQ_limit y (S n)) as [b bmaj]; - unfold proj1_sig in q. - assert (IQR (1 # Pos.of_nat (S n)) < eps). - { unfold IQR. rewrite Rmult_1_l. - apply (Rmult_lt_reg_l (IPR (Pos.of_nat (S n)))). apply IPR_pos. - rewrite Rinv_r, <- INR_IPR, Nat2Pos.id. 2: discriminate. - apply (Rlt_trans _ _ (INR (S n))) in nmaj. - apply (Rmult_lt_compat_l eps) in nmaj. - rewrite Rinv_r, Rmult_comm in nmaj. exact nmaj. - right. exact epsPos. exact epsPos. apply lt_INR. apply le_n_S, le_refl. - right. apply IPR_pos. } - unfold eps in H. apply (Rlt_asym y (IQR b)). - + apply bmaj. - + apply (Rlt_le_trans _ (IQR a + (y - x) * IQR (1 # 2))). - apply IQR_le in q. - apply (Rle_lt_trans _ _ _ q) in H. - apply (Rplus_lt_reg_l (-IQR a)). - rewrite <- Rplus_assoc, Rplus_opp_l, Rplus_0_l, Rplus_comm, - <- opp_IQR, <- plus_IQR. exact H. - apply (Rplus_lt_compat_l x) in H. - destruct amaj. apply (Rlt_trans _ _ _ r0) in H. - apply (Rplus_lt_compat_r ((y - x) * IQR (1 # 2))) in H. - unfold Rle. apply Rlt_asym. - setoid_replace (x + (y - x) * IQR (1 # 2) + (y - x) * IQR (1 # 2)) with y in H. - exact H. - rewrite Rplus_assoc, <- Rmult_plus_distr_r. - setoid_replace (y - x + (y - x)) with ((y-x)*2). - unfold IQR. rewrite Rmult_1_l, Rmult_assoc, Rinv_r. ring. - right. apply (IZR_lt 0). reflexivity. - unfold IZR, IPR, IPR_2. ring. -Qed. - -Lemma Rlt_lpo_floor : forall x : R, - (forall (P : nat -> Prop), (forall n, {P n} + {~P n}) - -> {n | ~P n} + {forall n, P n}) - -> { p : Z & IZR p <= x < IZR p + 1 }. -Proof. - intros x lpo. destruct (Rfloor x) as [n [H H0]]. - destruct (Rlt_lpo_dec x (IZR n + 1) lpo). - - exists n. split. unfold Rle. apply Rlt_asym. exact H. exact r. - - exists (n+1)%Z. split. rewrite plus_IZR. exact r. - rewrite plus_IZR, Rplus_assoc. exact H0. -Qed. - - -(*********) -Lemma Rmult_le_pos : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 * r2. -Proof. - intros x y H H0; rewrite <- (Rmult_0_l x); rewrite <- (Rmult_comm x); - apply (Rmult_le_compat_l x 0 y H H0). -Qed. - -Lemma Rinv_le_contravar : - forall x y (xpos : 0 < x) (ynz : y # 0), - x <= y -> (/ y) ynz <= (/ x) (inr xpos). -Proof. - intros. intro abs. apply (Rmult_lt_compat_l x) in abs. - 2: apply xpos. rewrite Rinv_r in abs. - apply (Rmult_lt_compat_r y) in abs. - rewrite Rmult_assoc in abs. rewrite Rinv_l in abs. - rewrite Rmult_1_r in abs. rewrite Rmult_1_l in abs. contradiction. - exact (Rlt_le_trans _ x _ xpos H). - right. exact xpos. -Qed. - -Lemma Rle_Rinv : forall x y (xpos : 0 < x) (ypos : 0 < y), - x <= y -> (/ y) (inr ypos) <= (/ x) (inr xpos). -Proof. - intros. - apply Rinv_le_contravar with (1 := H). -Qed. - -Lemma Ropp_div : forall x y (ynz : y # 0), - -x * (/y) ynz == - (x * (/ y) ynz). -Proof. - intros; ring. -Qed. - -Lemma double : forall r1, 2 * r1 == r1 + r1. -Proof. - intros. rewrite (Rmult_plus_distr_r 1 1 r1), Rmult_1_l. reflexivity. -Qed. - -Lemma Rlt_0_2 : 0 < 2. -Proof. - apply (Rlt_trans 0 (0+1)). rewrite Rplus_0_l. exact Rlt_0_1. - apply Rplus_lt_le_compat. exact Rlt_0_1. apply Rle_refl. -Qed. - -Lemma double_var : forall r1, r1 == r1 * (/ 2) (inr Rlt_0_2) - + r1 * (/ 2) (inr Rlt_0_2). -Proof. - intro; rewrite <- double; rewrite <- Rmult_assoc; - symmetry ; apply Rinv_r_simpl_m. -Qed. - -(* IZR : Z -> R is a ring morphism *) -Lemma R_rm : ring_morph - 0 1 Rplus Rmult Rminus Ropp Req - 0%Z 1%Z Zplus Zmult Zminus Z.opp Zeq_bool IZR. -Proof. -constructor ; try easy. -exact plus_IZR. -exact minus_IZR. -exact mult_IZR. -exact opp_IZR. -intros x y H. -replace y with x. reflexivity. -now apply Zeq_bool_eq. -Qed. - -Lemma Zeq_bool_IZR x y : - IZR x == IZR y -> Zeq_bool x y = true. -Proof. -intros H. -apply Zeq_is_eq_bool. -now apply eq_IZR. -Qed. - - -(*********************************************************) -(** ** Other rules about < and <= *) -(*********************************************************) - -Lemma Rmult_ge_0_gt_0_lt_compat : - forall r1 r2 r3 r4, - r3 >= 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. -Proof. - intros. apply (Rle_lt_trans _ (r2 * r3)). - apply Rmult_le_compat_r. apply H. unfold Rle. apply Rlt_asym. apply H1. - apply Rmult_lt_compat_l. apply H0. apply H2. -Qed. - -Lemma le_epsilon : - forall r1 r2, (forall eps, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2. -Proof. - intros x y H. intro abs. - assert (0 < (x - y) * (/ 2) (inr Rlt_0_2)). - { apply (Rplus_lt_compat_r (-y)) in abs. rewrite Rplus_opp_r in abs. - apply Rmult_lt_0_compat. exact abs. - apply Rinv_0_lt_compat. } - specialize (H ((x - y) * (/ 2) (inr Rlt_0_2)) H0). - apply (Rmult_le_compat_l 2) in H. - rewrite Rmult_plus_distr_l in H. - apply (Rplus_le_compat_l (-x)) in H. - rewrite (Rmult_comm (x-y)), <- Rmult_assoc, Rinv_r, Rmult_1_l, - (Rmult_plus_distr_r 1 1), (Rmult_plus_distr_r 1 1) - in H. - ring_simplify in H; contradiction. - right. apply Rlt_0_2. unfold Rle. apply Rlt_asym. apply Rlt_0_2. -Qed. - -(**********) -Lemma Rdiv_lt_0_compat : forall a b (bpos : 0 < b), - 0 < a -> 0 < a * (/b) (inr bpos). -Proof. -intros; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat]; assumption. -Qed. - -Lemma Rdiv_plus_distr : forall a b c (cnz : c # 0), - (a + b)* (/c) cnz == a* (/c) cnz + b* (/c) cnz. -Proof. - intros. apply Rmult_plus_distr_r. -Qed. - -Lemma Rdiv_minus_distr : forall a b c (cnz : c # 0), - (a - b)* (/c) cnz == a* (/c) cnz - b* (/c) cnz. -Proof. - intros; unfold Rminus,CRminus; rewrite Rmult_plus_distr_r. - apply Rplus_morph. reflexivity. - rewrite Ropp_mult_distr_l. reflexivity. -Qed. - - -(*********************************************************) -(** * Definitions of new types *) -(*********************************************************) - -Record nonnegreal : Type := mknonnegreal - {nonneg :> R; cond_nonneg : 0 <= nonneg}. - -Record posreal : Type := mkposreal {pos :> R; cond_pos : 0 < pos}. - -Record nonposreal : Type := mknonposreal - {nonpos :> R; cond_nonpos : nonpos <= 0}. - -Record negreal : Type := mknegreal {neg :> R; cond_neg : neg < 0}. - -Record nonzeroreal : Type := mknonzeroreal - {nonzero :> R; cond_nonzero : nonzero <> 0}. diff --git a/theories/Reals/ConstructiveRcomplete.v b/theories/Reals/ConstructiveRcomplete.v index 0a515672f2..b575c17961 100644 --- a/theories/Reals/ConstructiveRcomplete.v +++ b/theories/Reals/ConstructiveRcomplete.v @@ -11,6 +11,7 @@ Require Import QArith_base. Require Import Qabs. +Require Import ConstructiveReals. Require Import ConstructiveCauchyRealsMult. Require Import Logic.ConstructiveEpsilon. @@ -347,3 +348,35 @@ Proof. apply Qplus_le_r. discriminate. rewrite Qinv_plus_distr. reflexivity. Qed. + +Definition CRealImplem : ConstructiveReals. +Proof. + assert (isLinearOrder CReal CRealLt) as lin. + { repeat split. exact CRealLt_asym. + exact CReal_lt_trans. + intros. destruct (CRealLt_dec x z y H). + left. exact c. right. exact c. } + apply (Build_ConstructiveReals + CReal CRealLt lin CRealLtProp + CRealLtEpsilon CRealLtForget CRealLtDisjunctEpsilon + (inject_Q 0) (inject_Q 1) + CReal_plus CReal_opp CReal_mult + CReal_isRing CReal_isRingExt CRealLt_0_1 + 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 + 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. 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)%Q. 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)%Q with (-(1#p))%Q in abs. + rewrite opp_inject_Q in abs. destruct a. contradiction. + reflexivity. +Defined. diff --git a/theories/Reals/ConstructiveRealsMorphisms.v b/theories/Reals/ConstructiveRealsMorphisms.v index 0d3027d475..7954e9a96c 100644 --- a/theories/Reals/ConstructiveRealsMorphisms.v +++ b/theories/Reals/ConstructiveRealsMorphisms.v @@ -29,7 +29,7 @@ Require Import QArith. Require Import Qabs. Require Import ConstructiveReals. Require Import ConstructiveCauchyRealsMult. -Require Import ConstructiveRIneq. +Require Import ConstructiveRcomplete. Record ConstructiveRealsMorphism (R1 R2 : ConstructiveReals) : Set := diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 3b108b485a..7813c7b975 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -13,7 +13,8 @@ (** * Basic lemmas for the classical real numbers *) (*********************************************************) -Require Import ConstructiveRIneq. +Require Import ConstructiveCauchyReals. +Require Import ConstructiveCauchyRealsMult. Require Export Raxioms. Require Import Rpow_def. Require Import Zpower. @@ -457,11 +458,13 @@ Qed. Lemma Rplus_eq_0_l : forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0. Proof. - intros. apply Rquot1. rewrite Rrepr_0. - apply (Rplus_eq_0_l (Rrepr r1) (Rrepr r2)). - rewrite Rrepr_le, Rrepr_0 in H. exact H. - rewrite Rrepr_le, Rrepr_0 in H0. exact H0. - rewrite <- Rrepr_plus, H1, Rrepr_0. reflexivity. + intros a b H [H0| H0] H1; auto with real. + absurd (0 < a + b). + rewrite H1; auto with real. + apply Rle_lt_trans with (a + 0). + rewrite Rplus_0_r; assumption. + auto using Rplus_lt_compat_l with real. + rewrite <- H0, Rplus_0_r in H1; assumption. Qed. Lemma Rplus_eq_R0 : @@ -541,9 +544,10 @@ Qed. (**********) Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 = r * r2 -> r <> 0 -> r1 = r2. Proof. - intros. apply Rquot1. apply (Rmult_eq_reg_l (Rrepr r)). - rewrite <- Rrepr_mult, <- Rrepr_mult, H. reflexivity. + intros. apply Rquot1. apply (CReal_mult_eq_reg_l (Rrepr r)). apply Rrepr_appart in H0. rewrite Rrepr_0 in H0. exact H0. + apply Rrepr_appart in H0. + rewrite <- Rrepr_mult, <- Rrepr_mult, H. reflexivity. Qed. Lemma Rmult_eq_reg_r : forall r r1 r2, r1 * r = r2 * r -> r <> 0 -> r1 = r2. @@ -996,16 +1000,16 @@ Qed. Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. Proof. - intros. rewrite Rlt_def. apply Rlt_forget. apply (Rplus_lt_reg_l (Rrepr r)). + intros. rewrite Rlt_def. apply CRealLtForget. apply (CReal_plus_lt_reg_l (Rrepr r)). rewrite <- Rrepr_plus, <- Rrepr_plus. - rewrite Rlt_def in H. apply Rlt_epsilon. exact H. + rewrite Rlt_def in H. apply CRealLtEpsilon. exact H. Qed. Lemma Rplus_lt_reg_r : forall r r1 r2, r1 + r < r2 + r -> r1 < r2. Proof. - intros. rewrite Rlt_def. apply Rlt_forget. apply (Rplus_lt_reg_r (Rrepr r)). + intros. rewrite Rlt_def. apply CRealLtForget. apply (CReal_plus_lt_reg_r (Rrepr r)). rewrite <- Rrepr_plus, <- Rrepr_plus. rewrite Rlt_def in H. - apply Rlt_epsilon. exact H. + apply CRealLtEpsilon. exact H. Qed. Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2. @@ -1076,18 +1080,18 @@ Qed. Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. Proof. intros. rewrite Rlt_def. rewrite Rrepr_opp, Rrepr_opp. - apply Rlt_forget. - apply Ropp_gt_lt_contravar. unfold Rgt in H. - rewrite Rlt_def in H. apply Rlt_epsilon. exact H. + apply CRealLtForget. + apply CReal_opp_gt_lt_contravar. unfold Rgt in H. + rewrite Rlt_def in H. apply CRealLtEpsilon. exact H. Qed. Hint Resolve Ropp_gt_lt_contravar : core. Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. Proof. intros. unfold Rgt. rewrite Rlt_def. rewrite Rrepr_opp, Rrepr_opp. - apply Rlt_forget. - apply Ropp_lt_gt_contravar. rewrite Rlt_def in H. - apply Rlt_epsilon. exact H. + apply CRealLtForget. + apply CReal_opp_gt_lt_contravar. rewrite Rlt_def in H. + apply CRealLtEpsilon. exact H. Qed. Hint Resolve Ropp_lt_gt_contravar: real. @@ -1239,10 +1243,11 @@ Lemma Rmult_le_compat : forall r1 r2 r3 r4, 0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4. Proof. - intros. rewrite Rrepr_le, Rrepr_mult, Rrepr_mult. - apply Rmult_le_compat. rewrite <- Rrepr_0, <- Rrepr_le. exact H. - rewrite <- Rrepr_0, <- Rrepr_le. exact H0. - rewrite <- Rrepr_le. exact H1. rewrite <- Rrepr_le. exact H2. + intros x y z t H' H'0 H'1 H'2. + apply Rle_trans with (r2 := x * t); auto with real. + repeat rewrite (fun x => Rmult_comm x t). + apply Rmult_le_compat_l; auto. + apply Rle_trans with z; auto. Qed. Hint Resolve Rmult_le_compat: real. @@ -1307,18 +1312,20 @@ Qed. Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. Proof. - intros. rewrite Rlt_def in H,H0. rewrite Rlt_def. apply Rlt_forget. - apply (Rmult_lt_reg_l (Rrepr r)). - rewrite <- Rrepr_0. apply Rlt_epsilon. exact H. - rewrite <- Rrepr_mult, <- Rrepr_mult. apply Rlt_epsilon. exact H0. + intros z x y H H0. + case (Rtotal_order x y); intros Eq0; auto; elim Eq0; clear Eq0; intros Eq0. + rewrite Eq0 in H0; exfalso; apply (Rlt_irrefl (z * y)); auto. + generalize (Rmult_lt_compat_l z y x H Eq0); intro; exfalso; + generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); + intro; apply (Rlt_irrefl (z * x)); auto. Qed. Lemma Rmult_lt_reg_r : forall r r1 r2 : R, 0 < r -> r1 * r < r2 * r -> r1 < r2. Proof. - intros. rewrite Rlt_def. rewrite Rlt_def in H, H0. - apply Rlt_forget. apply (Rmult_lt_reg_r (Rrepr r)). - rewrite <- Rrepr_0. apply Rlt_epsilon. exact H. - rewrite <- Rrepr_mult, <- Rrepr_mult. apply Rlt_epsilon. exact H0. + intros. + apply Rmult_lt_reg_l with r. + exact H. + now rewrite 2!(Rmult_comm r). Qed. Lemma Rmult_gt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. @@ -1326,10 +1333,14 @@ Proof. eauto using Rmult_lt_reg_l with rorders. Qed. Lemma Rmult_le_reg_l : forall r r1 r2, 0 < r -> r * r1 <= r * r2 -> r1 <= r2. Proof. - intros. rewrite Rrepr_le. rewrite Rlt_def in H. apply (Rmult_le_reg_l (Rrepr r)). - rewrite <- Rrepr_0. apply Rlt_epsilon. exact H. - rewrite <- Rrepr_mult, <- Rrepr_mult. - rewrite <- Rrepr_le. exact H0. + intros z x y H H0; case H0; auto with real. + intros H1; apply Rlt_le. + apply Rmult_lt_reg_l with (r := z); auto. + intros H1; replace x with (/ z * (z * x)); auto with real. + replace y with (/ z * (z * y)). + rewrite H1; auto with real. + rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. + rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. Qed. Lemma Rmult_le_reg_r : forall r r1 r2, 0 < r -> r1 * r <= r2 * r -> r1 <= r2. @@ -1574,9 +1585,11 @@ Qed. (**********) Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m. Proof. - intros. apply Rquot1. - rewrite Rrepr_INR, Rrepr_plus, plus_INR, - <- Rrepr_INR, <- Rrepr_INR. reflexivity. + intros n m; induction n as [| n Hrecn]. + simpl; auto with real. + replace (S n + m)%nat with (S (n + m)); auto with arith. + repeat rewrite S_INR. + rewrite Hrecn; ring. Qed. Hint Resolve plus_INR: real. @@ -1645,8 +1658,16 @@ Hint Resolve pos_INR: real. Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat. Proof. - intros. apply INR_lt. rewrite Rlt_def in H. - rewrite Rrepr_INR, Rrepr_INR in H. apply Rlt_epsilon. exact H. + intros n m. revert n. + induction m ; intros n H. + - elim (Rlt_irrefl 0). + apply Rle_lt_trans with (2 := H). + apply pos_INR. + - destruct n as [|n]. + apply Nat.lt_0_succ. + apply lt_n_S, IHm. + rewrite 2!S_INR in H. + apply Rplus_lt_reg_r with (1 := H). Qed. Hint Resolve INR_lt: real. @@ -1680,8 +1701,11 @@ Hint Resolve not_0_INR: real. Lemma not_INR : forall n m:nat, n <> m -> INR n <> INR m. Proof. - intros. apply Rappart_repr. rewrite Rrepr_INR, Rrepr_INR. - apply not_INR. exact H. + intros n m H; case (le_or_lt n m); intros H1. + case (le_lt_or_eq _ _ H1); intros H2. + apply Rlt_dichotomy_converse; auto with real. + exfalso; auto. + apply not_eq_sym; apply Rlt_dichotomy_converse; auto with real. Qed. Hint Resolve not_INR: real. @@ -1721,8 +1745,17 @@ Qed. Lemma INR_IPR : forall p, INR (Pos.to_nat p) = IPR p. Proof. - intros. apply Rquot1. rewrite Rrepr_INR, Rrepr_IPR. - apply INR_IPR. + assert (H: forall p, 2 * INR (Pos.to_nat p) = IPR_2 p). + induction p as [p|p|] ; simpl IPR_2. + rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- IHp. + now rewrite (Rplus_comm (2 * _)). + now rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. + apply Rmult_1_r. + intros [p|p|] ; unfold IPR. + rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H. + apply Rplus_comm. + now rewrite Pos2Nat.inj_xO, mult_INR, <- H. + easy. Qed. (**********) @@ -1737,15 +1770,26 @@ Qed. Lemma plus_IZR_NEG_POS : forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q). Proof. - intros. apply Rquot1. rewrite Rrepr_plus. - do 3 rewrite Rrepr_IZR. apply plus_IZR_NEG_POS. + 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 by trivial. + rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt). + ring. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial. + rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt). + ring. Qed. (**********) Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m. Proof. - intros. apply Rquot1. - rewrite Rrepr_plus. do 3 rewrite Rrepr_IZR. apply plus_IZR. + intro z; destruct z; intro t; destruct t; intros; auto with real. + simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add. apply plus_INR. + apply plus_IZR_NEG_POS. + rewrite Z.add_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS. + simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR. + apply Ropp_plus_distr. Qed. (**********) @@ -1755,21 +1799,14 @@ Proof. unfold IZR; intros m n; rewrite <- 3!INR_IPR, Pos2Nat.inj_mul, mult_INR; ring. Qed. -Lemma Rrepr_pow : forall (x : R) (n : nat), - (ConstructiveRIneq.Req (Rrepr (pow x n)) - (ConstructiveRIneq.pow (Rrepr x) n)). -Proof. - intro x. induction n. - - apply Rrepr_1. - - simpl. rewrite Rrepr_mult, <- IHn. reflexivity. -Qed. - Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Z.pow z (Z.of_nat n)). Proof. - intros. apply Rquot1. - rewrite Rrepr_IZR, Rrepr_pow. - rewrite (Rpow_eq_compat _ _ n (Rrepr_IZR z)). - apply pow_IZR. + intros z [|n];simpl;trivial. + rewrite Zpower_pos_nat. + rewrite SuccNat2Pos.id_succ. unfold Zpower_nat;simpl. + rewrite mult_IZR. + induction n;simpl;trivial. + rewrite mult_IZR;ring[IHn]. Qed. (**********) @@ -1803,23 +1840,34 @@ Qed. (**********) Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. Proof. - intros. apply lt_0_IZR. rewrite <- Rrepr_0, <- Rrepr_IZR. - rewrite Rlt_def in H. apply Rlt_epsilon. exact H. + intro z; case z; simpl; intros. + elim (Rlt_irrefl _ H). + easy. + elim (Rlt_not_le _ _ H). + unfold IZR. + rewrite <- INR_IPR. + auto with real. Qed. (**********) Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z. Proof. - intros. apply lt_IZR. - rewrite <- Rrepr_IZR, <- Rrepr_IZR. rewrite Rlt_def in H. - apply Rlt_epsilon. exact H. + intros z1 z2 H; apply Z.lt_0_sub. + apply lt_0_IZR. + rewrite <- Z_R_minus. + exact (Rgt_minus (IZR z2) (IZR z1) H). Qed. (**********) Lemma eq_IZR_R0 : forall n:Z, IZR n = 0 -> n = 0%Z. Proof. - intros. apply eq_IZR_R0. - rewrite <- Rrepr_0, <- Rrepr_IZR, H. reflexivity. + intro z; destruct z; simpl; intros; auto with zarith. + elim Rgt_not_eq with (2 := H). + unfold IZR. rewrite <- INR_IPR. + apply lt_0_INR, Pos2Nat.is_pos. + elim Rlt_not_eq with (2 := H). + unfold IZR. rewrite <- INR_IPR. + apply Ropp_lt_gt_0_contravar, lt_0_INR, Pos2Nat.is_pos. Qed. (**********) @@ -1895,21 +1943,26 @@ Hint Extern 0 (IZR _ <> IZR _) => apply IZR_neq, Zeq_bool_neq, eq_refl : real. Lemma one_IZR_lt1 : forall n:Z, -1 < IZR n < 1 -> n = 0%Z. Proof. - intros. apply one_IZR_lt1. do 2 rewrite Rlt_def in H. split. - rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_opp. - apply Rlt_epsilon. apply H. - rewrite <- Rrepr_IZR, <- Rrepr_1. apply Rlt_epsilon. apply H. + intros z [H1 H2]. + apply Z.le_antisymm. + apply Z.lt_succ_r; apply lt_IZR; trivial. + change 0%Z with (Z.succ (-1)). + apply Z.le_succ_l; apply lt_IZR; trivial. Qed. Lemma one_IZR_r_R1 : forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m. Proof. - intros. rewrite Rlt_def in H, H0. apply (one_IZR_r_R1 (Rrepr r)); split. - rewrite <- Rrepr_IZR. apply Rlt_epsilon. apply H. - rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_plus, <- Rrepr_le. - apply H. rewrite <- Rrepr_IZR. apply Rlt_epsilon. apply H0. - rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_plus, <- Rrepr_le. - apply H0. + intros r z x [H1 H2] [H3 H4]. + cut ((z - x)%Z = 0%Z); auto with zarith. + apply one_IZR_lt1. + rewrite <- Z_R_minus; split. + replace (-1) with (r - (r + 1)). + unfold Rminus; apply Rplus_lt_le_compat; auto with real. + ring. + replace 1 with (r + 1 - r). + unfold Rminus; apply Rplus_le_lt_compat; auto with real. + ring. Qed. @@ -1942,13 +1995,13 @@ Qed. Lemma Rinv_le_contravar : forall x y, 0 < x -> x <= y -> / y <= / x. Proof. - intros. apply Rrepr_le. assert (y <> 0). - intro abs. subst y. apply (Rlt_irrefl 0). exact (Rlt_le_trans 0 x 0 H H0). - apply Rrepr_appart in H1. - rewrite Rrepr_0 in H1. rewrite Rlt_def in H. rewrite Rrepr_0 in H. - apply Rlt_epsilon in H. - rewrite (Rrepr_inv y H1), (Rrepr_inv x (inr H)). - apply Rinv_le_contravar. rewrite <- Rrepr_le. exact H0. + intros x y H1 [H2|H2]. + apply Rlt_le. + apply Rinv_lt_contravar with (2 := H2). + apply Rmult_lt_0_compat with (1 := H1). + now apply Rlt_trans with x. + rewrite H2. + apply Rle_refl. Qed. Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x. @@ -2012,10 +2065,18 @@ Qed. Lemma le_epsilon : forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2. Proof. - intros. rewrite Rrepr_le. apply le_epsilon. - intros. rewrite <- (Rquot2 eps), <- Rrepr_plus. - rewrite <- Rrepr_le. apply H. rewrite Rlt_def. - rewrite Rquot2, Rrepr_0. apply Rlt_forget. exact H0. + intros x y H. + destruct (Rle_or_lt x y) as [H1|H1]. + exact H1. + apply Rplus_le_reg_r with x. + replace (y + x) with (2 * (y + (x - y) * / 2)) by field. + replace (x + x) with (2 * x) by ring. + apply Rmult_le_compat_l. + now apply (IZR_le 0 2). + apply H. + apply Rmult_lt_0_compat. + now apply Rgt_minus. + apply Rinv_0_lt_compat, Rlt_0_2. Qed. (**********) diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index d856d1c7fe..be283fb7cf 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -20,10 +20,12 @@ (*********************************************************) Require Export ZArith_base. -Require Import ConstructiveRIneq. +Require Import ClassicalDedekindReals. +Require Import ConstructiveCauchyReals. +Require Import ConstructiveCauchyRealsMult. +Require Import ConstructiveRcomplete. Require Import ConstructiveRealsLUB. Require Export Rdefinitions. -Declare Scope R_scope. Local Open Scope R_scope. (*********************************************************) @@ -34,7 +36,7 @@ Local Open Scope R_scope. (** ** Addition *) (*********************************************************) -Open Scope R_scope_constr. +Open Scope CReal_scope. Lemma Rrepr_0 : Rrepr 0 == 0. Proof. @@ -58,7 +60,7 @@ Qed. Lemma Rrepr_minus : forall x y:R, Rrepr (x - y) == Rrepr x - Rrepr y. Proof. - intros. unfold Rminus, CRminus. + intros. unfold Rminus, CReal_minus. rewrite Rrepr_plus, Rrepr_opp. reflexivity. Qed. @@ -72,10 +74,10 @@ Lemma Rrepr_inv : forall (x:R) (xnz : Rrepr x # 0), Proof. intros. rewrite RinvImpl.Rinv_def. destruct (Req_appart_dec x R0). - exfalso. subst x. destruct xnz. - rewrite Rrepr_0 in c. exact (Rlt_irrefl 0 c). - rewrite Rrepr_0 in c. exact (Rlt_irrefl 0 c). - - rewrite Rquot2. apply (Rmult_eq_reg_l (Rrepr x)). 2: exact xnz. - rewrite Rmult_comm, (Rmult_comm (Rrepr x)), Rinv_l, Rinv_l. + rewrite Rrepr_0 in c. exact (CRealLt_irrefl 0 c). + rewrite Rrepr_0 in c. exact (CRealLt_irrefl 0 c). + - rewrite Rquot2. apply (CReal_mult_eq_reg_l (Rrepr x)). exact xnz. + rewrite CReal_mult_comm, (CReal_mult_comm (Rrepr x)), CReal_inv_l, CReal_inv_l. reflexivity. Qed. @@ -83,12 +85,12 @@ Lemma Rrepr_le : forall x y:R, (x <= y)%R <-> Rrepr x <= Rrepr y. Proof. split. - intros [H|H] abs. rewrite RbaseSymbolsImpl.Rlt_def in H. - apply Rlt_epsilon in H. - exact (Rlt_asym (Rrepr x) (Rrepr y) H abs). - destruct H. exact (Rlt_asym (Rrepr x) (Rrepr x) abs abs). + apply CRealLtEpsilon in H. + exact (CRealLt_asym (Rrepr x) (Rrepr y) H abs). + destruct H. exact (CRealLt_asym (Rrepr x) (Rrepr x) abs abs). - intros. destruct (total_order_T x y). destruct s. left. exact r. right. exact e. - rewrite RbaseSymbolsImpl.Rlt_def in r. apply Rlt_epsilon in r. contradiction. + rewrite RbaseSymbolsImpl.Rlt_def in r. apply CRealLtEpsilon in r. contradiction. Qed. Lemma Rrepr_appart : forall x y:R, @@ -96,26 +98,26 @@ Lemma Rrepr_appart : forall x y:R, Proof. intros. destruct (total_order_T x y). destruct s. left. rewrite RbaseSymbolsImpl.Rlt_def in r. - apply Rlt_epsilon. exact r. contradiction. + apply CRealLtEpsilon. exact r. contradiction. right. rewrite RbaseSymbolsImpl.Rlt_def in r. - apply Rlt_epsilon. exact r. + apply CRealLtEpsilon. exact r. Qed. Lemma Rappart_repr : forall x y:R, Rrepr x # Rrepr y -> (x <> y)%R. Proof. intros x y [H|H] abs. - destruct abs. exact (Rlt_asym (Rrepr x) (Rrepr x) H H). - destruct abs. exact (Rlt_asym (Rrepr x) (Rrepr x) H H). + destruct abs. exact (CRealLt_asym (Rrepr x) (Rrepr x) H H). + destruct abs. exact (CRealLt_asym (Rrepr x) (Rrepr x) H H). Qed. -Close Scope R_scope_constr. +Close Scope CReal_scope. (**********) Lemma Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1. Proof. - intros. apply Rquot1. do 2 rewrite Rrepr_plus. apply Rplus_comm. + intros. apply Rquot1. do 2 rewrite Rrepr_plus. apply CReal_plus_comm. Qed. Hint Resolve Rplus_comm: real. @@ -123,7 +125,7 @@ Hint Resolve Rplus_comm: real. Lemma Rplus_assoc : forall r1 r2 r3:R, r1 + r2 + r3 = r1 + (r2 + r3). Proof. intros. apply Rquot1. repeat rewrite Rrepr_plus. - apply Rplus_assoc. + apply CReal_plus_assoc. Qed. Hint Resolve Rplus_assoc: real. @@ -131,7 +133,7 @@ Hint Resolve Rplus_assoc: real. Lemma Rplus_opp_r : forall r:R, r + - r = 0. Proof. intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_opp, Rrepr_0. - apply Rplus_opp_r. + apply CReal_plus_opp_r. Qed. Hint Resolve Rplus_opp_r: real. @@ -139,7 +141,7 @@ Hint Resolve Rplus_opp_r: real. Lemma Rplus_0_l : forall r:R, 0 + r = r. Proof. intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_0. - apply Rplus_0_l. + apply CReal_plus_0_l. Qed. Hint Resolve Rplus_0_l: real. @@ -150,7 +152,7 @@ Hint Resolve Rplus_0_l: real. (**********) Lemma Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. Proof. - intros. apply Rquot1. do 2 rewrite Rrepr_mult. apply Rmult_comm. + intros. apply Rquot1. do 2 rewrite Rrepr_mult. apply CReal_mult_comm. Qed. Hint Resolve Rmult_comm: real. @@ -158,7 +160,7 @@ Hint Resolve Rmult_comm: real. Lemma Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3). Proof. intros. apply Rquot1. repeat rewrite Rrepr_mult. - apply Rmult_assoc. + apply CReal_mult_assoc. Qed. Hint Resolve Rmult_assoc: real. @@ -167,7 +169,7 @@ Lemma Rinv_l : forall r:R, r <> 0 -> / r * r = 1. Proof. intros. rewrite RinvImpl.Rinv_def; destruct (Req_appart_dec r R0). - contradiction. - - apply Rquot1. rewrite Rrepr_mult, Rquot2, Rrepr_1. apply Rinv_l. + - apply Rquot1. rewrite Rrepr_mult, Rquot2, Rrepr_1. apply CReal_inv_l. Qed. Hint Resolve Rinv_l: real. @@ -175,7 +177,7 @@ Hint Resolve Rinv_l: real. Lemma Rmult_1_l : forall r:R, 1 * r = r. Proof. intros. apply Rquot1. rewrite Rrepr_mult, Rrepr_1. - apply Rmult_1_l. + apply CReal_mult_1_l. Qed. Hint Resolve Rmult_1_l: real. @@ -183,17 +185,17 @@ Hint Resolve Rmult_1_l: real. Lemma R1_neq_R0 : 1 <> 0. Proof. intro abs. - assert (Req (CRone CR) (CRzero CR)). + assert (CRealEq 1%CReal 0%CReal). { transitivity (Rrepr 1). symmetry. - replace 1%R with (Rabst (CRone CR)). + replace 1%R with (Rabst 1%CReal). 2: unfold IZR,IPR; rewrite RbaseSymbolsImpl.R1_def; reflexivity. rewrite Rquot2. reflexivity. transitivity (Rrepr 0). rewrite abs. reflexivity. - replace 0%R with (Rabst (CRzero CR)). + replace 0%R with (Rabst 0%CReal). 2: unfold IZR; rewrite RbaseSymbolsImpl.R0_def; reflexivity. rewrite Rquot2. reflexivity. } - pose proof (Rlt_morph (CRzero CR) (CRzero CR) (Req_refl _) (CRone CR) (CRzero CR) H). - apply (Rlt_irrefl (CRzero CR)). apply H0. apply Rlt_0_1. + pose proof (CRealLt_morph 0%CReal 0%CReal (CRealEq_refl _) 1%CReal 0%CReal H). + apply (CRealLt_irrefl 0%CReal). apply H0. apply CRealLt_0_1. Qed. Hint Resolve R1_neq_R0: real. @@ -207,7 +209,7 @@ Lemma Proof. intros. apply Rquot1. rewrite Rrepr_mult, Rrepr_plus, Rrepr_plus, Rrepr_mult, Rrepr_mult. - apply Rmult_plus_distr_l. + apply CReal_mult_plus_distr_l. Qed. Hint Resolve Rmult_plus_distr_l: real. @@ -223,35 +225,35 @@ Hint Resolve Rmult_plus_distr_l: real. Lemma Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1. Proof. intros. intro abs. rewrite RbaseSymbolsImpl.Rlt_def in H, abs. - apply Rlt_epsilon in H. apply Rlt_epsilon in abs. - apply (Rlt_asym (Rrepr r1) (Rrepr r2)); assumption. + apply CRealLtEpsilon in H. apply CRealLtEpsilon in abs. + apply (CRealLt_asym (Rrepr r1) (Rrepr r2)); assumption. Qed. (**********) Lemma Rlt_trans : forall r1 r2 r3:R, r1 < r2 -> r2 < r3 -> r1 < r3. Proof. intros. rewrite RbaseSymbolsImpl.Rlt_def. rewrite RbaseSymbolsImpl.Rlt_def in H, H0. - apply Rlt_epsilon in H. apply Rlt_epsilon in H0. - apply Rlt_forget. - apply (Rlt_trans (Rrepr r1) (Rrepr r2) (Rrepr r3)); assumption. + apply CRealLtEpsilon in H. apply CRealLtEpsilon in H0. + apply CRealLtForget. + apply (CReal_lt_trans (Rrepr r1) (Rrepr r2) (Rrepr r3)); assumption. Qed. (**********) Lemma Rplus_lt_compat_l : forall r r1 r2:R, r1 < r2 -> r + r1 < r + r2. Proof. intros. rewrite RbaseSymbolsImpl.Rlt_def. rewrite RbaseSymbolsImpl.Rlt_def in H. - do 2 rewrite Rrepr_plus. apply Rlt_forget. - apply Rplus_lt_compat_l. apply Rlt_epsilon. exact H. + do 2 rewrite Rrepr_plus. apply CRealLtForget. + apply CReal_plus_lt_compat_l. apply CRealLtEpsilon. exact H. Qed. (**********) Lemma Rmult_lt_compat_l : forall r r1 r2:R, 0 < r -> r1 < r2 -> r * r1 < r * r2. Proof. intros. rewrite RbaseSymbolsImpl.Rlt_def. rewrite RbaseSymbolsImpl.Rlt_def in H. - do 2 rewrite Rrepr_mult. apply Rlt_forget. apply Rmult_lt_compat_l. - rewrite <- (Rquot2 (CRzero CR)). unfold IZR in H. - rewrite RbaseSymbolsImpl.R0_def in H. apply Rlt_epsilon. exact H. - rewrite RbaseSymbolsImpl.Rlt_def in H0. apply Rlt_epsilon. exact H0. + do 2 rewrite Rrepr_mult. apply CRealLtForget. apply CReal_mult_lt_compat_l. + rewrite <- (Rquot2 0%CReal). unfold IZR in H. + rewrite RbaseSymbolsImpl.R0_def in H. apply CRealLtEpsilon. exact H. + rewrite RbaseSymbolsImpl.Rlt_def in H0. apply CRealLtEpsilon. exact H0. Qed. Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real. @@ -274,119 +276,133 @@ Arguments INR n%nat. (**********************************************************) Lemma Rrepr_INR : forall n : nat, - Req (Rrepr (INR n)) (ConstructiveRIneq.INR n). + CRealEq (Rrepr (INR n)) (inject_Z (Z.of_nat n)). Proof. induction n. - apply Rrepr_0. - - simpl. destruct n. apply Rrepr_1. - rewrite Rrepr_plus, <- IHn, Rrepr_1. reflexivity. + - replace (Z.of_nat (S n)) with (Z.of_nat n + 1)%Z. + simpl. destruct n. apply Rrepr_1. + rewrite Rrepr_plus,inject_Z_plus, <- IHn, Rrepr_1. reflexivity. + replace 1%Z with (Z.of_nat 1). rewrite <- (Nat2Z.inj_add n 1). + apply f_equal. rewrite Nat.add_comm. reflexivity. reflexivity. Qed. Lemma Rrepr_IPR2 : forall n : positive, - Req (Rrepr (IPR_2 n)) (ConstructiveRIneq.IPR_2 n). + CRealEq (Rrepr (IPR_2 n)) (inject_Z (Z.pos (n~0))). Proof. induction n. - - unfold IPR_2, ConstructiveRIneq.IPR_2. - rewrite RbaseSymbolsImpl.R1_def, Rrepr_mult, Rrepr_plus, Rrepr_plus, <- IHn. - unfold IPR_2. - rewrite Rquot2. rewrite RbaseSymbolsImpl.R1_def. reflexivity. - - unfold IPR_2, ConstructiveRIneq.IPR_2. - rewrite Rrepr_mult, Rrepr_plus, <- IHn. - rewrite RbaseSymbolsImpl.R1_def. rewrite Rquot2. - unfold IPR_2. rewrite RbaseSymbolsImpl.R1_def. reflexivity. - - unfold IPR_2, ConstructiveRIneq.IPR_2. - rewrite RbaseSymbolsImpl.R1_def. - rewrite Rrepr_plus, Rquot2. reflexivity. + - simpl. replace (Z.pos n~1~0) with ((Z.pos n~0 + 1) + (Z.pos n~0 + 1))%Z. + rewrite RbaseSymbolsImpl.R1_def, Rrepr_mult, inject_Z_plus, inject_Z_plus. + rewrite Rrepr_plus, Rrepr_plus, <- IHn. + rewrite Rquot2, CReal_mult_plus_distr_r, CReal_mult_1_l. + rewrite (CReal_plus_comm 1%CReal). repeat rewrite CReal_plus_assoc. + apply CReal_plus_morph. reflexivity. + reflexivity. + repeat rewrite <- Pos2Z.inj_add. apply f_equal. + rewrite Pos.add_diag. apply f_equal. + rewrite Pos.add_1_r. reflexivity. + - simpl. replace (Z.pos n~0~0) with ((Z.pos n~0) + (Z.pos n~0))%Z. + rewrite RbaseSymbolsImpl.R1_def, Rrepr_mult, inject_Z_plus. + rewrite Rrepr_plus, <- IHn. + rewrite Rquot2, CReal_mult_plus_distr_r, CReal_mult_1_l. reflexivity. + rewrite <- Pos2Z.inj_add. apply f_equal. + rewrite Pos.add_diag. reflexivity. + - simpl. rewrite Rrepr_plus, RbaseSymbolsImpl.R1_def, Rquot2. + replace 2%Z with (1 + 1)%Z. rewrite inject_Z_plus. reflexivity. + reflexivity. Qed. Lemma Rrepr_IPR : forall n : positive, - Req (Rrepr (IPR n)) (ConstructiveRIneq.IPR n). + CRealEq (Rrepr (IPR n)) (inject_Z (Z.pos n)). Proof. intro n. destruct n. - - unfold IPR, ConstructiveRIneq.IPR. - rewrite Rrepr_plus, <- Rrepr_IPR2. - rewrite RbaseSymbolsImpl.R1_def. rewrite Rquot2. reflexivity. - - unfold IPR, ConstructiveRIneq.IPR. - apply Rrepr_IPR2. + - unfold IPR. rewrite Rrepr_plus. + replace (n~1)%positive with (n~0 + 1)%positive. + rewrite Pos2Z.inj_add, inject_Z_plus, <- Rrepr_IPR2, CReal_plus_comm. + rewrite RbaseSymbolsImpl.R1_def, Rquot2. reflexivity. + rewrite Pos.add_1_r. reflexivity. + - apply Rrepr_IPR2. - unfold IPR. rewrite RbaseSymbolsImpl.R1_def. apply Rquot2. Qed. Lemma Rrepr_IZR : forall n : Z, - Req (Rrepr (IZR n)) (ConstructiveRIneq.IZR n). + CRealEq (Rrepr (IZR n)) (inject_Z n). Proof. intros [|p|n]. - unfold IZR. rewrite RbaseSymbolsImpl.R0_def. apply Rquot2. - apply Rrepr_IPR. - - unfold IZR, ConstructiveRIneq.IZR. - rewrite <- Rrepr_IPR, Rrepr_opp. reflexivity. + - unfold IZR. rewrite Rrepr_opp, Rrepr_IPR. rewrite <- opp_inject_Z. + replace (- Z.pos n)%Z with (Z.neg n). reflexivity. reflexivity. Qed. (**********) Lemma archimed : forall r:R, IZR (up r) > r /\ IZR (up r) - r <= 1. Proof. intro r. unfold up. - destruct (Rarchimedean (Rrepr r)) as [n nmaj], (total_order_T (IZR n - r) R1). + destruct (CRealArchimedean (Rrepr r)) as [n nmaj], (total_order_T (IZR n - r) R1). destruct s. - split. unfold Rgt. rewrite RbaseSymbolsImpl.Rlt_def. rewrite Rrepr_IZR. - apply Rlt_forget. apply nmaj. + apply CRealLtForget. apply nmaj. unfold Rle. left. exact r0. - split. unfold Rgt. rewrite RbaseSymbolsImpl.Rlt_def. - rewrite Rrepr_IZR. apply Rlt_forget. apply nmaj. right. exact e. + rewrite Rrepr_IZR. apply CRealLtForget. apply nmaj. right. exact e. - split. + unfold Rgt, Z.pred. rewrite RbaseSymbolsImpl.Rlt_def. - rewrite Rrepr_IZR, plus_IZR. + rewrite Rrepr_IZR, inject_Z_plus. rewrite RbaseSymbolsImpl.Rlt_def in r0. rewrite Rrepr_minus in r0. rewrite <- (Rrepr_IZR n). - unfold ConstructiveRIneq.IZR, ConstructiveRIneq.IPR. - apply Rlt_forget. apply Rlt_epsilon in r0. - unfold ConstructiveRIneq.Rminus in r0. - apply (ConstructiveRIneq.Rplus_lt_compat_l - (ConstructiveRIneq.Rplus (Rrepr r) (ConstructiveRIneq.Ropp (Rrepr R1)))) + apply CRealLtForget. apply CRealLtEpsilon in r0. + unfold CReal_minus in r0. + apply (CReal_plus_lt_compat_l + (CReal_plus (Rrepr r) (CReal_opp (Rrepr R1)))) in r0. - rewrite ConstructiveRIneq.Rplus_assoc, - ConstructiveRIneq.Rplus_opp_l, - ConstructiveRIneq.Rplus_0_r, + rewrite CReal_plus_assoc, + CReal_plus_opp_l, + CReal_plus_0_r, RbaseSymbolsImpl.R1_def, Rquot2, - ConstructiveRIneq.Rplus_comm, - ConstructiveRIneq.Rplus_assoc, - <- (ConstructiveRIneq.Rplus_assoc (ConstructiveRIneq.Ropp (Rrepr r))), - ConstructiveRIneq.Rplus_opp_l, - ConstructiveRIneq.Rplus_0_l + CReal_plus_comm, + CReal_plus_assoc, + <- (CReal_plus_assoc (CReal_opp (Rrepr r))), + CReal_plus_opp_l, + CReal_plus_0_l in r0. - exact r0. + rewrite (opp_inject_Z 1). exact r0. + destruct (total_order_T (IZR (Z.pred n) - r) 1). destruct s. left. exact r1. right. exact e. - exfalso. destruct nmaj as [_ nmaj]. rewrite <- Rrepr_IZR in nmaj. + exfalso. destruct nmaj as [_ nmaj]. + pose proof Rrepr_IZR as iz. unfold inject_Z in iz. + rewrite <- iz in nmaj. apply (Rlt_asym (IZR n) (r + 2)). rewrite RbaseSymbolsImpl.Rlt_def. rewrite Rrepr_plus. rewrite (Rrepr_plus 1 1). - apply Rlt_forget. - apply (ConstructiveRIneq.Rlt_le_trans - _ (ConstructiveRIneq.Rplus (Rrepr r) (ConstructiveRIneq.IZR 2))). - apply nmaj. - unfold IZR, IPR. rewrite RbaseSymbolsImpl.R1_def, Rquot2. apply Rle_refl. + apply CRealLtForget. + apply (CReal_lt_le_trans _ _ _ nmaj). + unfold IZR, IPR. rewrite RbaseSymbolsImpl.R1_def, Rquot2. + rewrite <- (inject_Z_plus 1 1). apply CRealLe_refl. clear nmaj. unfold Z.pred in r1. rewrite RbaseSymbolsImpl.Rlt_def in r1. - rewrite Rrepr_minus, (Rrepr_IZR (n + -1)), plus_IZR, - <- (Rrepr_IZR n) - in r1. - unfold ConstructiveRIneq.IZR, ConstructiveRIneq.IPR in r1. + rewrite Rrepr_minus, (Rrepr_IZR (n + -1)) in r1. + rewrite inject_Z_plus, <- (Rrepr_IZR n) in r1. rewrite RbaseSymbolsImpl.Rlt_def, Rrepr_plus. - apply Rlt_epsilon in r1. - apply (ConstructiveRIneq.Rplus_lt_compat_l - (ConstructiveRIneq.Rplus (Rrepr r) (CRone CR))) in r1. - apply Rlt_forget. - apply (ConstructiveRIneq.Rle_lt_trans - _ (ConstructiveRIneq.Rplus (ConstructiveRIneq.Rplus (Rrepr r) (Rrepr 1)) (CRone CR))). + apply CRealLtEpsilon in r1. + apply (CReal_plus_lt_compat_l + (CReal_plus (Rrepr r) 1%CReal)) in r1. + apply CRealLtForget. + apply (CReal_le_lt_trans + _ (CReal_plus (CReal_plus (Rrepr r) (Rrepr 1)) 1%CReal)). rewrite (Rrepr_plus 1 1). unfold IZR, IPR. - rewrite RbaseSymbolsImpl.R1_def, (Rquot2 (CRone CR)), <- ConstructiveRIneq.Rplus_assoc. - apply Rle_refl. - rewrite <- (ConstructiveRIneq.Rplus_comm (Rrepr 1)), - <- ConstructiveRIneq.Rplus_assoc, - (ConstructiveRIneq.Rplus_comm (Rrepr 1)) + rewrite RbaseSymbolsImpl.R1_def, (Rquot2 1%CReal), <- CReal_plus_assoc. + apply CRealLe_refl. + rewrite <- (CReal_plus_comm (Rrepr 1)), + <- CReal_plus_assoc, + (CReal_plus_comm (Rrepr 1)) in r1. - apply (ConstructiveRIneq.Rlt_le_trans _ _ _ r1). - unfold ConstructiveRIneq.Rminus. - ring_simplify. apply ConstructiveRIneq.Rle_refl. + apply (CReal_lt_le_trans _ _ _ r1). + unfold CReal_minus. rewrite (opp_inject_Z 1). + rewrite (CReal_plus_comm (Rrepr (IZR n))), CReal_plus_assoc, + <- (CReal_plus_assoc 1), <- (CReal_plus_assoc 1), CReal_plus_opp_r. + rewrite CReal_plus_0_l, CReal_plus_comm, CReal_plus_assoc, + CReal_plus_opp_l, CReal_plus_0_r. + apply CRealLe_refl. Qed. (**********************************************************) @@ -408,29 +424,29 @@ Lemma completeness : forall E:R -> Prop, 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) + intros. pose (fun x:CReal => E (Rabst x)) as Er. + assert (forall x y : CReal, CRealEq 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. + assert (exists x : CReal, Er x) as Einhab. { destruct H0. exists (Rrepr x). unfold Er. replace (Rabst (Rrepr x)) with x. exact H0. apply Rquot1. rewrite Rquot2. reflexivity. } - assert (exists x : ConstructiveRIneq.R, - (forall y:ConstructiveRIneq.R, Er y -> ConstructiveRIneq.Rle y x)) + assert (exists x : CReal, + (forall y:CReal, Er y -> CRealLe y x)) as Ebound. { destruct H. exists (Rrepr x). intros y Ey. rewrite <- (Rquot2 y). apply Rrepr_le. apply H. exact Ey. } - destruct (CR_sig_lub CR + destruct (CR_sig_lub CRealImplem 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. + unfold CRealLe. apply a. unfold Er. replace (Rabst (Rrepr y)) with y. exact Ey. apply Rquot1. rewrite Rquot2. reflexivity. intros. destruct a. apply Rrepr_le. rewrite Rquot2. - unfold ConstructiveRIneq.Rle. apply H3. intros y Ey. + unfold CRealLe. apply H3. intros y Ey. intros. rewrite <- (Rquot2 y) in H4. apply Rrepr_le in H4. exact H4. apply H1, Ey. diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index b1ce8109ca..35025ba9bc 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -8,17 +8,18 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(* Classical quotient of the constructive Cauchy real numbers. - This file contains the definition of the classical real numbers - type R, its algebraic operations, its order and the proof that - it is total, and the proof that R is archimedean (up). - It also defines IZR, the ring morphism from Z to R. *) +(* Abstraction of classical Dedekind reals behind an opaque module, + for backward compatibility. + + This file also contains the proof that classical reals are a + quotient of constructive Cauchy reals. *) Require Export ZArith_base. Require Import QArith_base. -Require Import ConstructiveRIneq. +Require Import ConstructiveCauchyReals. +Require Import ConstructiveCauchyRealsMult. +Require Import ClassicalDedekindReals. -Parameter R : Set. (* Declare primitive numeral notations for Scope R_scope *) Declare Scope R_scope. @@ -27,26 +28,18 @@ Declare ML Module "r_syntax_plugin". (* Declare Scope R_scope with Key R *) Delimit Scope R_scope with R. -(* Automatically open scope R_scope for arguments of type R *) -Bind Scope R_scope with R. - Local Open Scope R_scope. -(* The limited principle of omniscience *) -Axiom sig_forall_dec - : forall (P : nat -> Prop), - (forall n, {P n} + {~P n}) - -> {n | ~P n} + {forall n, P n}. - -Axiom sig_not_dec : forall P : Prop, { ~~P } + { ~P }. - -Axiom Rabst : ConstructiveRIneq.R -> R. -Axiom Rrepr : R -> ConstructiveRIneq.R. -Axiom Rquot1 : forall x y:R, Req (Rrepr x) (Rrepr y) -> x = y. -Axiom Rquot2 : forall x:ConstructiveRIneq.R, Req (Rrepr (Rabst x)) x. (* Those symbols must be kept opaque, for backward compatibility. *) Module Type RbaseSymbolsSig. + Parameter R : Set. + Bind Scope R_scope with R. + Axiom Rabst : CReal -> R. + Axiom Rrepr : R -> CReal. + Axiom Rquot1 : forall x y:R, CRealEq (Rrepr x) (Rrepr y) -> x = y. + Axiom Rquot2 : forall x:CReal, CRealEq (Rrepr (Rabst x)) x. + Parameter R0 : R. Parameter R1 : R. Parameter Rplus : R -> R -> R. @@ -54,29 +47,34 @@ Module Type RbaseSymbolsSig. Parameter Ropp : R -> R. Parameter Rlt : R -> R -> Prop. - Parameter R0_def : R0 = Rabst (CRzero CR). - Parameter R1_def : R1 = Rabst (CRone CR). + Parameter R0_def : R0 = Rabst (inject_Q 0). + Parameter R1_def : R1 = Rabst (inject_Q 1). Parameter Rplus_def : forall x y : R, - Rplus x y = Rabst (ConstructiveRIneq.Rplus (Rrepr x) (Rrepr y)). + Rplus x y = Rabst (CReal_plus (Rrepr x) (Rrepr y)). Parameter Rmult_def : forall x y : R, - Rmult x y = Rabst (ConstructiveRIneq.Rmult (Rrepr x) (Rrepr y)). + Rmult x y = Rabst (CReal_mult (Rrepr x) (Rrepr y)). Parameter Ropp_def : forall x : R, - Ropp x = Rabst (ConstructiveRIneq.Ropp (Rrepr x)). + Ropp x = Rabst (CReal_opp (Rrepr x)). Parameter Rlt_def : forall x y : R, - Rlt x y = ConstructiveRIneq.RltProp (Rrepr x) (Rrepr y). + Rlt x y = CRealLtProp (Rrepr x) (Rrepr y). End RbaseSymbolsSig. Module RbaseSymbolsImpl : RbaseSymbolsSig. - Definition R0 : R := Rabst (CRzero CR). - Definition R1 : R := Rabst (CRone CR). + Definition R := DReal. + Definition Rabst := DRealAbstr. + Definition Rrepr := DRealRepr. + Definition Rquot1 := DRealQuot1. + Definition Rquot2 := DRealQuot2. + Definition R0 : R := Rabst (inject_Q 0). + Definition R1 : R := Rabst (inject_Q 1). Definition Rplus : R -> R -> R - := fun x y : R => Rabst (ConstructiveRIneq.Rplus (Rrepr x) (Rrepr y)). + := fun x y : R => Rabst (CReal_plus (Rrepr x) (Rrepr y)). Definition Rmult : R -> R -> R - := fun x y : R => Rabst (ConstructiveRIneq.Rmult (Rrepr x) (Rrepr y)). + := fun x y : R => Rabst (CReal_mult (Rrepr x) (Rrepr y)). Definition Ropp : R -> R - := fun x : R => Rabst (ConstructiveRIneq.Ropp (Rrepr x)). + := fun x : R => Rabst (CReal_opp (Rrepr x)). Definition Rlt : R -> R -> Prop - := fun x y : R => ConstructiveRIneq.RltProp (Rrepr x) (Rrepr y). + := fun x y : R => CRealLtProp (Rrepr x) (Rrepr y). Definition R0_def := eq_refl R0. Definition R1_def := eq_refl R1. @@ -88,6 +86,7 @@ End RbaseSymbolsImpl. Export RbaseSymbolsImpl. (* Keep the same names as before *) +Notation R := RbaseSymbolsImpl.R (only parsing). Notation R0 := RbaseSymbolsImpl.R0 (only parsing). Notation R1 := RbaseSymbolsImpl.R1 (only parsing). Notation Rplus := RbaseSymbolsImpl.Rplus (only parsing). @@ -95,6 +94,9 @@ Notation Rmult := RbaseSymbolsImpl.Rmult (only parsing). Notation Ropp := RbaseSymbolsImpl.Ropp (only parsing). Notation Rlt := RbaseSymbolsImpl.Rlt (only parsing). +(* Automatically open scope R_scope for arguments of type R *) +Bind Scope R_scope with R. + Infix "+" := Rplus : R_scope. Infix "*" := Rmult : R_scope. Notation "- x" := (Ropp x) : R_scope. @@ -160,11 +162,11 @@ Arguments IZR z%Z : simpl never. Lemma total_order_T : forall r1 r2:R, {Rlt r1 r2} + {r1 = r2} + {Rlt r2 r1}. Proof. - intros. destruct (Rlt_lpo_dec (Rrepr r1) (Rrepr r2) sig_forall_dec). + intros. destruct (CRealLt_lpo_dec (Rrepr r1) (Rrepr r2) sig_forall_dec). - left. left. rewrite RbaseSymbolsImpl.Rlt_def. - apply Rlt_forget. exact r. - - destruct (Rlt_lpo_dec (Rrepr r2) (Rrepr r1) sig_forall_dec). - + right. rewrite RbaseSymbolsImpl.Rlt_def. apply Rlt_forget. exact r0. + apply CRealLtForget. exact c. + - destruct (CRealLt_lpo_dec (Rrepr r2) (Rrepr r1) sig_forall_dec). + + right. rewrite RbaseSymbolsImpl.Rlt_def. apply CRealLtForget. exact c. + left. right. apply Rquot1. split; assumption. Qed. @@ -178,9 +180,9 @@ Proof. Qed. Lemma Rrepr_appart_0 : forall x:R, - (x < R0 \/ R0 < x) -> Rappart (Rrepr x) (CRzero CR). + (x < R0 \/ R0 < x) -> CReal_appart (Rrepr x) (inject_Q 0). Proof. - intros. apply CRltDisjunctEpsilon. destruct H. + intros. apply CRealLtDisjunctEpsilon. destruct H. left. rewrite RbaseSymbolsImpl.Rlt_def, RbaseSymbolsImpl.R0_def, Rquot2 in H. exact H. right. rewrite RbaseSymbolsImpl.Rlt_def, RbaseSymbolsImpl.R0_def, Rquot2 in H. @@ -192,7 +194,7 @@ Module Type RinvSig. Parameter Rinv_def : forall x : R, Rinv x = match Req_appart_dec x R0 with | left _ => R0 (* / 0 is undefined, we take 0 arbitrarily *) - | right r => Rabst ((ConstructiveRIneq.Rinv (Rrepr x) (Rrepr_appart_0 x r))) + | right r => Rabst ((CReal_inv (Rrepr x) (Rrepr_appart_0 x r))) end. End RinvSig. @@ -200,7 +202,7 @@ Module RinvImpl : RinvSig. Definition Rinv : R -> R := fun x => match Req_appart_dec x R0 with | left _ => R0 (* / 0 is undefined, we take 0 arbitrarily *) - | right r => Rabst ((ConstructiveRIneq.Rinv (Rrepr x) (Rrepr_appart_0 x r))) + | right r => Rabst ((CReal_inv (Rrepr x) (Rrepr_appart_0 x r))) end. Definition Rinv_def := fun x => eq_refl (Rinv x). End RinvImpl. @@ -215,7 +217,7 @@ Infix "/" := Rdiv : R_scope. (* First integer strictly above x *) Definition up (x : R) : Z. Proof. - destruct (Rarchimedean (Rrepr x)) as [n nmaj], (total_order_T (IZR n - x) R1). + destruct (CRealArchimedean (Rrepr x)) as [n nmaj], (total_order_T (IZR n - x) R1). destruct s. - exact n. - (* x = n-1 *) exact n. diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index a760a0af6a..0df1442f46 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -18,6 +18,7 @@ Require Export Cos_rel. Require Export Cos_plus. Require Import ZArith_base. Require Import Zcomplements. +Import Omega. Require Import Lra. Require Import Ranalysis1. Require Import Rsqrt_def. diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v index a8e6993a63..cc216b21f8 100644 --- a/theories/Structures/OrderedTypeEx.v +++ b/theories/Structures/OrderedTypeEx.v @@ -12,7 +12,6 @@ Require Import OrderedType. Require Import ZArith. Require Import PeanoNat. Require Import Ascii String. -Require Import Omega. Require Import NArith Ndec. Require Import Compare_dec. @@ -55,7 +54,7 @@ Module Nat_as_OT <: UsualOrderedType. Proof. unfold lt; intros; apply lt_trans with y; auto. Qed. Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. unfold lt, eq; intros; omega. Qed. + Proof. unfold lt, eq; intros ? ? LT ->; revert LT; apply Nat.lt_irrefl. Qed. Definition compare x y : Compare lt eq x y. Proof. @@ -85,10 +84,10 @@ Module Z_as_OT <: UsualOrderedType. Definition lt (x y:Z) := (x<y). Lemma lt_trans : forall x y z, x<y -> y<z -> x<z. - Proof. intros; omega. Qed. + Proof. exact Z.lt_trans. Qed. Lemma lt_not_eq : forall x y, x<y -> ~ x=y. - Proof. intros; omega. Qed. + Proof. intros x y LT ->; revert LT; apply Z.lt_irrefl. Qed. Definition compare x y : Compare lt eq x y. Proof. diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v index b0744caa7b..38f9336f1b 100644 --- a/theories/ZArith/ZArith.v +++ b/theories/ZArith/ZArith.v @@ -18,6 +18,7 @@ Require Export Zpow_def. (** Extra modules using [Omega] or [Ring]. *) +Require Export Omega. Require Export Zcomplements. Require Export Zpower. Require Export Zdiv. diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index 73c8ec11c6..0be6f8c8de 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -10,7 +10,6 @@ Require Import ZArithRing. Require Import ZArith_base. -Require Export Omega. Require Import Wf_nat. Local Open Scope Z_scope. @@ -40,10 +39,19 @@ Proof. reflexivity. Qed. Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. Proof. - unfold floor. induction p; simpl. - - rewrite !Pos2Z.inj_xI, (Pos2Z.inj_xO (xO _)), Pos2Z.inj_xO. omega. - - rewrite (Pos2Z.inj_xO (xO _)), (Pos2Z.inj_xO p), Pos2Z.inj_xO. omega. - - omega. + unfold floor. induction p as [p [IH1p IH2p]|p [IH1p IH2]|]; simpl. + - rewrite !Pos2Z.inj_xI, (Pos2Z.inj_xO (xO _)), Pos2Z.inj_xO. + split. + + apply Z.le_trans with (2 * Z.pos p); auto with zarith. + rewrite <- (Z.add_0_r (2 * Z.pos p)) at 1; auto with zarith. + + apply Z.lt_le_trans with (2 * (Z.pos p + 1)). + * rewrite Z.mul_add_distr_l, Z.mul_1_r. + apply Zplus_lt_compat_l; red; auto with zarith. + * apply Z.mul_le_mono_nonneg_l; auto with zarith. + rewrite Z.add_1_r; apply Zlt_le_succ; auto. + - rewrite (Pos2Z.inj_xO (xO _)), (Pos2Z.inj_xO p), Pos2Z.inj_xO. + split; auto with zarith. + - split; auto with zarith; red; auto. Qed. (**********************************************************************) @@ -64,9 +72,10 @@ Proof. - rewrite Z.abs_eq; auto; intros. destruct (H (Z.abs m)); auto with zarith. destruct (Zabs_dec m) as [-> | ->]; trivial. - - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. - destruct (H (Z.abs m)); auto with zarith. - destruct (Zabs_dec m) as [-> | ->]; trivial. + - rewrite Z.abs_neq, Z.opp_involutive; intros. + + destruct (H (Z.abs m)); auto with zarith. + destruct (Zabs_dec m) as [-> | ->]; trivial. + + apply Z.opp_le_mono; rewrite Z.opp_involutive; auto. Qed. Theorem Z_lt_abs_induction : @@ -84,9 +93,10 @@ Proof. - rewrite Z.abs_eq; auto; intros. elim (H (Z.abs m)); intros; auto with zarith. elim (Zabs_dec m); intro eq; rewrite eq; trivial. - - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. - destruct (H (Z.abs m)); auto with zarith. - destruct (Zabs_dec m) as [-> | ->]; trivial. + - rewrite Z.abs_neq, Z.opp_involutive; intros. + + destruct (H (Z.abs m)); auto with zarith. + destruct (Zabs_dec m) as [-> | ->]; trivial. + + apply Z.opp_le_mono; rewrite Z.opp_involutive; auto. Qed. (** To do case analysis over the sign of [z] *) @@ -129,7 +139,7 @@ Section Zlength_properties. clear l. induction l. auto with zarith. intros. simpl length; simpl Zlength_aux. - rewrite IHl, Nat2Z.inj_succ; auto with zarith. + rewrite IHl, Nat2Z.inj_succ, Z.add_succ_comm; auto. unfold Zlength. now rewrite H. Qed. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 78df9941c9..2aaab3e50e 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -14,7 +14,7 @@ (** Initial Contribution by Claude Marché and Xavier Urbain *) Require Export ZArith_base. -Require Import Zbool Omega ZArithRing Zcomplements Setoid Morphisms. +Require Import Zbool ZArithRing Zcomplements Setoid Morphisms. Local Open Scope Z_scope. (** The definition of the division is now in [BinIntDef], the initial @@ -67,7 +67,12 @@ Definition Remainder_alt r b := Z.abs r < Z.abs b /\ Z.sgn r <> - Z.sgn b. Lemma Remainder_equiv : forall r b, Remainder r b <-> Remainder_alt r b. Proof. - intros; unfold Remainder, Remainder_alt; omega with *. + unfold Remainder, Remainder_alt. + intros [ | r | r ] [ | b | b ]; intuition try easy. + - now apply Z.opp_lt_mono. + - right; split. + + now apply Z.opp_lt_mono. + + apply Pos2Z.neg_is_nonpos. Qed. Hint Unfold Remainder : core. @@ -104,7 +109,7 @@ Proof (Z.mod_neg_bound a b). Lemma Z_div_mod_eq a b : b > 0 -> a = b*(a/b) + (a mod b). Proof. - intros Hb; apply Z.div_mod; auto with zarith. + intros Hb; apply Z.div_mod; now intros ->. Qed. Lemma Zmod_eq_full a b : b<>0 -> a mod b = a - (a/b)*b. @@ -224,18 +229,25 @@ Proof Z.div_mul. (* Division of positive numbers is positive. *) Lemma Z_div_pos: forall a b, b > 0 -> 0 <= a -> 0 <= a/b. -Proof. intros. apply Z.div_pos; auto with zarith. Qed. +Proof. intros. apply Z.div_pos; auto using Z.gt_lt. Qed. Lemma Z_div_ge0: forall a b, b > 0 -> a >= 0 -> a/b >=0. Proof. - intros; generalize (Z_div_pos a b H); auto with zarith. + intros; apply Z.le_ge, Z_div_pos; auto using Z.ge_le. Qed. (** As soon as the divisor is greater or equal than 2, the division is strictly decreasing. *) Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> a/b < a. -Proof. intros. apply Z.div_lt; auto with zarith. Qed. +Proof. + intros a b b_ge_2 a_gt_0. + apply Z.div_lt. + - apply Z.gt_lt; exact a_gt_0. + - apply (Z.lt_le_trans _ 2). + + reflexivity. + + apply Z.ge_le; exact b_ge_2. +Qed. (** A division of a small number by a bigger one yields zero. *) @@ -250,17 +262,17 @@ Proof Z.mod_small. (** [Z.ge] is compatible with a positive division. *) Lemma Z_div_ge : forall a b c:Z, c > 0 -> a >= b -> a/c >= b/c. -Proof. intros. apply Z.le_ge. apply Z.div_le_mono; auto with zarith. Qed. +Proof. intros. apply Z.le_ge. apply Z.div_le_mono; auto using Z.gt_lt, Z.ge_le. Qed. (** Same, with [Z.le]. *) Lemma Z_div_le : forall a b c:Z, c > 0 -> a <= b -> a/c <= b/c. -Proof. intros. apply Z.div_le_mono; auto with zarith. Qed. +Proof. intros. apply Z.div_le_mono; auto using Z.gt_lt. Qed. (** With our choice of division, rounding of (a/b) is always done toward bottom: *) Lemma Z_mult_div_ge : forall a b:Z, b > 0 -> b*(a/b) <= a. -Proof. intros. apply Z.mul_div_le; auto with zarith. Qed. +Proof. intros. apply Z.mul_div_le; auto using Z.gt_lt. Qed. Lemma Z_mult_div_ge_neg : forall a b:Z, b < 0 -> b*(a/b) >= a. Proof. intros. apply Z.le_ge. apply Z.mul_div_ge; auto with zarith. Qed. @@ -296,14 +308,18 @@ Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_le_lower_bound. Qed. Lemma Zdiv_le_compat_l: forall p q r, 0 <= p -> 0 < q < r -> p / r <= p / q. -Proof. intros; apply Z.div_le_compat_l; auto with zarith. Qed. +Proof. intros; apply Z.div_le_compat_l; intuition auto using Z.lt_le_incl. Qed. Theorem Zdiv_sgn: forall a b, 0 <= Z.sgn (a/b) * Z.sgn a * Z.sgn b. Proof. destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; generalize (Z.div_pos (Zpos a) (Zpos b)); unfold Z.div, Z.div_eucl; - destruct Z.pos_div_eucl as (q,r); destruct r; omega with *. + destruct Z.pos_div_eucl as (q,r); destruct r; + rewrite ?Z.mul_1_r, <-?Z.opp_eq_mul_m1, ?Z.sgn_opp, ?Z.opp_involutive; + match goal with [|- (_ -> _ -> ?P) -> _] => + intros HH; assert (HH1 : P); auto with zarith + end; apply Z.sgn_nonneg; auto with zarith. Qed. (** * Relations between usual operations and Z.modulo and Z.div *) @@ -346,14 +362,14 @@ Proof. intros. zero_or_not b. apply Z.div_opp_l_z; auto. Qed. Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a)/b = -(a/b)-1. -Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_l_nz; auto. Qed. +Proof. intros a b. zero_or_not b. easy. intros; rewrite Z.div_opp_l_nz; auto. Qed. Lemma Z_div_zero_opp_r : forall a b:Z, a mod b = 0 -> a/(-b) = -(a/b). Proof. intros. zero_or_not b. apply Z.div_opp_r_z; auto. Qed. Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 -> a/(-b) = -(a/b)-1. -Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_r_nz; auto. Qed. +Proof. intros a b. zero_or_not b. easy. intros; rewrite Z.div_opp_r_nz; auto. Qed. (** Cancellations. *) @@ -372,14 +388,16 @@ Lemma Zmult_mod_distr_l: forall a b c, (c*a) mod (c*b) = c * (a mod b). Proof. intros. zero_or_not c. rewrite (Z.mul_comm c b); zero_or_not b. - rewrite (Z.mul_comm b c). apply Z.mul_mod_distr_l; auto. + + now rewrite Z.mul_0_r. + + rewrite (Z.mul_comm b c). apply Z.mul_mod_distr_l; auto. Qed. Lemma Zmult_mod_distr_r: forall a b c, (a*c) mod (b*c) = (a mod b) * c. Proof. intros. zero_or_not b. rewrite (Z.mul_comm b c); zero_or_not c. - rewrite (Z.mul_comm c b). apply Z.mul_mod_distr_r; auto. + + now rewrite Z.mul_0_r. + + rewrite (Z.mul_comm c b). apply Z.mul_mod_distr_r; auto. Qed. (** Operations modulo. *) @@ -456,7 +474,7 @@ Proof. unfold eqm; auto. Qed. Lemma eqm_trans : forall a b c, a == b -> b == c -> a == c. -Proof. unfold eqm; eauto with *. Qed. +Proof. now unfold eqm; intros a b c ->. Qed. Instance eqm_setoid : Equivalence eqm. Proof. @@ -501,7 +519,8 @@ End EqualityModulo. Lemma Zdiv_Zdiv : forall a b c, 0<=b -> 0<=c -> (a/b)/c = a/(b*c). Proof. intros. zero_or_not b. rewrite Z.mul_comm. zero_or_not c. - rewrite Z.mul_comm. apply Z.div_div; auto with zarith. + rewrite Z.mul_comm. apply Z.div_div; auto. + apply Z.le_neq; auto. Qed. (** Unfortunately, the previous result isn't always true on negative numbers. @@ -519,7 +538,10 @@ Qed. Theorem Zdiv_mult_le: forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b. Proof. - intros. zero_or_not b. apply Z.div_mul_le; auto with zarith. Qed. + intros. zero_or_not b. now rewrite Z.mul_0_r. + apply Z.div_mul_le; auto. + apply Z.le_neq; auto. +Qed. (** Z.modulo is related to divisibility (see more in Znumtheory) *) @@ -566,17 +588,17 @@ Qed. Lemma Z_div_same : forall a, a > 0 -> a/a = 1. Proof. - intros; apply Z_div_same_full; auto with zarith. + now intros; apply Z_div_same_full; intros ->. Qed. Lemma Z_div_plus : forall a b c:Z, c > 0 -> (a + b * c) / c = a / c + b. Proof. - intros; apply Z_div_plus_full; auto with zarith. + now intros; apply Z_div_plus_full; intros ->. Qed. Lemma Z_div_mult : forall a b:Z, b > 0 -> (a*b)/b = a. Proof. - intros; apply Z_div_mult_full; auto with zarith. + now intros; apply Z_div_mult_full; intros ->. Qed. Lemma Z_mod_plus : forall a b c:Z, c > 0 -> (a + b * c) mod c = a mod c. @@ -591,7 +613,7 @@ Qed. Lemma Z_div_exact_2 : forall a b:Z, b > 0 -> a mod b = 0 -> a = b*(a/b). Proof. - intros; apply Z_div_exact_full_2; auto with zarith. + now intros; apply Z_div_exact_full_2; auto; intros ->. Qed. Lemma Z_mod_zero_opp : forall a b:Z, b > 0 -> a mod b = 0 -> (-a) mod b = 0. @@ -673,14 +695,15 @@ Theorem Zdiv_eucl_extended : Proof. intros b Hb a. destruct (Z_le_gt_dec 0 b) as [Hb'|Hb']. - - assert (Hb'' : b > 0) by omega. + - assert (Hb'' : b > 0) by (apply Z.lt_gt, Z.le_neq; auto). rewrite Z.abs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ]. - - assert (Hb'' : - b > 0) by omega. + - assert (Hb'' : - b > 0). + { now apply Z.lt_gt, Z.opp_lt_mono; rewrite Z.opp_involutive; apply Z.gt_lt. } destruct (Zdiv_eucl_exist Hb'' a) as ((q,r),[]). exists (- q, r). split. + rewrite <- Z.mul_opp_comm; assumption. - + rewrite Z.abs_neq; [ assumption | omega ]. + + rewrite Z.abs_neq; [ assumption | apply Z.lt_le_incl, Z.gt_lt; auto ]. Qed. Arguments Zdiv_eucl_extended : default implicits. diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index 5d1a13ff6c..01365135c5 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -117,17 +117,23 @@ Proof. right. now rewrite <- Z.mod_divide. Defined. +Lemma Z_lt_neq {x y: Z} : x < y -> y <> x. +Proof. auto using Z.lt_neq, Z.neq_sym. Qed. + Theorem Zdivide_Zdiv_eq a b : 0 < a -> (a | b) -> b = a * (b / a). Proof. intros Ha H. - rewrite (Z.div_mod b a) at 1; auto with zarith. - rewrite Zdivide_mod; auto with zarith. + rewrite (Z.div_mod b a) at 1. + + rewrite Zdivide_mod; auto with zarith. + + auto using Z_lt_neq. Qed. Theorem Zdivide_Zdiv_eq_2 a b c : 0 < a -> (a | b) -> (c * b) / a = c * (b / a). Proof. - intros. apply Z.divide_div_mul_exact; auto with zarith. + intros. apply Z.divide_div_mul_exact. + + now apply Z_lt_neq. + + auto with zarith. Qed. Theorem Zdivide_le: forall a b : Z, @@ -139,28 +145,30 @@ Qed. Theorem Zdivide_Zdiv_lt_pos a b : 1 < a -> 0 < b -> (a | b) -> 0 < b / a < b . Proof. - intros H1 H2 H3; split. - apply Z.mul_pos_cancel_l with a; auto with zarith. - rewrite <- Zdivide_Zdiv_eq; auto with zarith. - now apply Z.div_lt. + intros H1 H2 H3. + assert (0 < a) by (now transitivity 1). + split. + + apply Z.mul_pos_cancel_l with a; auto. + rewrite <- Zdivide_Zdiv_eq; auto. + + now apply Z.div_lt. Qed. Lemma Zmod_div_mod n m a: 0 < n -> 0 < m -> (n | m) -> a mod n = (a mod m) mod n. -Proof. +Proof with auto using Z_lt_neq. intros H1 H2 (p,Hp). - rewrite (Z.div_mod a m) at 1; auto with zarith. + rewrite (Z.div_mod a m) at 1... rewrite Hp at 1. - rewrite Z.mul_shuffle0, Z.add_comm, Z.mod_add; auto with zarith. + rewrite Z.mul_shuffle0, Z.add_comm, Z.mod_add... Qed. Lemma Zmod_divide_minus a b c: 0 < b -> a mod b = c -> (b | a - c). -Proof. - intros H H1. apply Z.mod_divide; auto with zarith. - rewrite Zminus_mod; auto with zarith. +Proof with auto using Z_lt_neq. + intros H H1. apply Z.mod_divide... + rewrite Zminus_mod. rewrite H1. rewrite <- (Z.mod_small c b) at 1. - rewrite Z.sub_diag, Z.mod_0_l; auto with zarith. + rewrite Z.sub_diag, Z.mod_0_l... subst. now apply Z.mod_pos_bound. Qed. @@ -169,10 +177,11 @@ Lemma Zdivide_mod_minus a b c: Proof. intros (H1, H2) H3. assert (0 < b) by Z.order. - replace a with ((a - c) + c); auto with zarith. - rewrite Z.add_mod; auto with zarith. - rewrite (Zdivide_mod (a-c) b); try rewrite Z.add_0_l; auto with zarith. - rewrite Z.mod_mod; try apply Zmod_small; auto with zarith. + assert (b <> 0) by now apply Z_lt_neq. + replace a with ((a - c) + c) by ring. + rewrite Z.add_mod; auto. + rewrite (Zdivide_mod (a-c) b); try rewrite Z.add_0_l; auto. + rewrite Z.mod_mod; try apply Zmod_small; auto. Qed. (** * Greatest common divisor (gcd). *) @@ -300,8 +309,9 @@ Section extended_euclid_algorithm. set (q := u3 / x) in *. assert (Hq : 0 <= u3 - q * x < x). replace (u3 - q * x) with (u3 mod x). - apply Z_mod_lt; omega. - assert (xpos : x > 0). omega. + apply Z_mod_lt. + apply Z.lt_gt, Z.le_neq; auto. + assert (xpos : x > 0) by (apply Z.lt_gt, Z.le_neq; auto). generalize (Z_div_mod_eq u3 x xpos). unfold q. intro eq; pattern u3 at 2; rewrite eq; ring. @@ -325,11 +335,13 @@ Section extended_euclid_algorithm. intros; apply euclid_rec with (u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := 1) (v3 := b); - auto with zarith; ring. + auto; ring. intros; apply euclid_rec with (u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := -1) (v3 := - b); - auto with zarith; try ring. + auto; try ring. + now apply Z.opp_nonneg_nonpos, Z.lt_le_incl, Z.gt_lt. + auto with zarith. Qed. End extended_euclid_algorithm. @@ -433,22 +445,24 @@ Lemma rel_prime_cross_prod : rel_prime a b -> rel_prime c d -> b > 0 -> d > 0 -> a * d = b * c -> a = c /\ b = d. Proof. - intros a b c d; intros. + intros a b c d; intros H H0 H1 H2 H3. elim (Z.divide_antisym b d). - split; auto with zarith. - rewrite H4 in H3. - rewrite Z.mul_comm in H3. - apply Z.mul_reg_l with d; auto with zarith. - intros; omega. - apply Gauss with a. - rewrite H3. - auto with zarith. - red; auto with zarith. - apply Gauss with c. - rewrite Z.mul_comm. - rewrite <- H3. - auto with zarith. - red; auto with zarith. + - split; auto with zarith. + rewrite H4 in H3. + rewrite Z.mul_comm in H3. + apply Z.mul_reg_l with d; auto. + contradict H2; rewrite H2; discriminate. + - intros H4; contradict H1; rewrite H4. + apply Zgt_asym, Z.lt_gt, Z.opp_lt_mono. + now rewrite Z.opp_involutive; apply Z.gt_lt. + - apply Gauss with a. + + rewrite H3; auto with zarith. + + now apply Zis_gcd_sym. + - apply Gauss with c. + + rewrite Z.mul_comm. + rewrite <- H3. + auto with zarith. + + now apply Zis_gcd_sym. Qed. (** After factorization by a gcd, the original numbers are relatively prime. *) @@ -457,32 +471,35 @@ Lemma Zis_gcd_rel_prime : forall a b g:Z, b > 0 -> g >= 0 -> Zis_gcd a b g -> rel_prime (a / g) (b / g). Proof. - intros a b g; intros. - assert (g <> 0). - intro. - elim H1; intros. - elim H4; intros. - rewrite H2 in H6; subst b; omega. + intros a b g; intros H H0 H1. + assert (H2 : g <> 0) by + (intro; + elim H1; intros; + elim H4; intros; + rewrite H2 in H6; subst b; + contradict H; rewrite Z.mul_0_r; discriminate). + assert (H3 : g > 0) by + (apply Z.lt_gt, Z.le_neq; split; try apply Z.ge_le; auto). unfold rel_prime. - destruct H1. - destruct H1 as (a',H1). - destruct H3 as (b',H3). + destruct H1 as [Ha Hb Hab]. + destruct Ha as [a' Ha']. + destruct Hb as [b' Hb']. replace (a/g) with a'; - [|rewrite H1; rewrite Z_div_mult; auto with zarith]. + [|rewrite Ha'; rewrite Z_div_mult; auto with zarith]. replace (b/g) with b'; - [|rewrite H3; rewrite Z_div_mult; auto with zarith]. + [|rewrite Hb'; rewrite Z_div_mult; auto with zarith]. constructor. - exists a'; auto with zarith. - exists b'; auto with zarith. - intros x (xa,H5) (xb,H6). - destruct (H4 (x*g)) as (x',Hx'). - exists xa; rewrite Z.mul_assoc; rewrite <- H5; auto. - exists xb; rewrite Z.mul_assoc; rewrite <- H6; auto. - replace g with (1*g) in Hx'; auto with zarith. - do 2 rewrite Z.mul_assoc in Hx'. - apply Z.mul_reg_r in Hx'; trivial. - rewrite Z.mul_1_r in Hx'. - exists x'; auto with zarith. + - exists a'; rewrite ?Z.mul_1_r; auto with zarith. + - exists b'; rewrite ?Z.mul_1_r; auto with zarith. + - intros x (xa,H5) (xb,H6). + destruct (Hab (x*g)) as (x',Hx'). + exists xa; rewrite Z.mul_assoc; rewrite <- H5; auto. + exists xb; rewrite Z.mul_assoc; rewrite <- H6; auto. + replace g with (1*g) in Hx'; auto with zarith. + do 2 rewrite Z.mul_assoc in Hx'. + apply Z.mul_reg_r in Hx'; trivial. + rewrite Z.mul_1_r in Hx'. + exists x'; auto with zarith. Qed. Theorem rel_prime_sym: forall a b, rel_prime a b -> rel_prime b a. @@ -504,18 +521,18 @@ Qed. Theorem rel_prime_1: forall n, rel_prime 1 n. Proof. intros n; red; apply Zis_gcd_intro; auto. - exists 1; auto with zarith. - exists n; auto with zarith. + exists 1; reflexivity. + exists n; rewrite Z.mul_1_r; reflexivity. Qed. Theorem not_rel_prime_0: forall n, 1 < n -> ~ rel_prime 0 n. Proof. intros n H H1; absurd (n = 1 \/ n = -1). - intros [H2 | H2]; subst; contradict H; auto with zarith. + intros [H2 | H2]; subst; contradict H; discriminate. case (Zis_gcd_unique 0 n n 1); auto. apply Zis_gcd_intro; auto. - exists 0; auto with zarith. - exists 1; auto with zarith. + exists 0; reflexivity. + exists 1; rewrite Z.mul_1_l; reflexivity. Qed. Theorem rel_prime_mod: forall p q, 0 < q -> @@ -528,15 +545,16 @@ Proof. apply bezout_rel_prime. apply Bezout_intro with q1 (r1 + q1 * (p / q)). rewrite <- H2. - pattern p at 3; rewrite (Z_div_mod_eq p q); try ring; auto with zarith. + pattern p at 3; rewrite (Z_div_mod_eq p q); try ring. + now apply Z.lt_gt. Qed. Theorem rel_prime_mod_rev: forall p q, 0 < q -> rel_prime (p mod q) q -> rel_prime p q. Proof. intros p q H H0. - rewrite (Z_div_mod_eq p q); auto with zarith; red. - apply Zis_gcd_sym; apply Zis_gcd_for_euclid2; auto with zarith. + rewrite (Z_div_mod_eq p q) by now apply Z.lt_gt. red. + apply Zis_gcd_sym; apply Zis_gcd_for_euclid2; auto. Qed. Theorem Zrel_prime_neq_mod_0: forall a b, 1 < b -> rel_prime a b -> a mod b <> 0. @@ -544,7 +562,8 @@ Proof. intros a b H H1 H2. case (not_rel_prime_0 _ H). rewrite <- H2. - apply rel_prime_mod; auto with zarith. + apply rel_prime_mod; auto. + now transitivity 1. Qed. (** * Primality *) @@ -563,25 +582,56 @@ Proof. assert (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p). { assert (Z.abs a <= Z.abs p) as H2. - apply Zdivide_bounds; [ assumption | omega ]. + apply Zdivide_bounds; [ assumption | now intros -> ]. revert H2. pattern (Z.abs a); apply Zabs_ind; pattern (Z.abs p); apply Zabs_ind; - intros; omega. } + intros H2 H3 H4. + - destruct (Zle_lt_or_eq _ _ H4) as [H5 | H5]; try intuition. + destruct (Zle_lt_or_eq _ _ (Z.ge_le _ _ H3)) as [H6 | H6]; try intuition. + destruct (Zle_lt_or_eq _ _ (Zlt_le_succ _ _ H6)) as [H7 | H7]; intuition. + - contradict H2; apply Zlt_not_le; apply Z.lt_trans with (2 := H); red; auto. + - destruct (Zle_lt_or_eq _ _ H4) as [H5 | H5]. + + destruct (Zle_lt_or_eq _ _ H3) as [H6 | H6]; try intuition. + assert (H7 : a <= Z.pred 0) by (apply Z.lt_le_pred; auto). + destruct (Zle_lt_or_eq _ _ H7) as [H8 | H8]; intuition. + assert (- p < a < -1); try intuition. + now apply Z.opp_lt_mono; rewrite Z.opp_involutive. + + now left; rewrite <- H5, Z.opp_involutive. + - contradict H2. + apply Zlt_not_le; apply Z.lt_trans with (2 := H); red; auto. + } intuition idtac. (* -p < a < -1 *) - - absurd (rel_prime (- a) p); intuition. - inversion H2. - assert (- a | - a) by auto with zarith. - assert (- a | p) by auto with zarith. - apply H7, Z.divide_1_r in H8; intuition. + - absurd (rel_prime (- a) p). + + intros [H1p H2p H3p]. + assert (- a | - a) by auto with zarith. + assert (- a | p) by auto with zarith. + apply H3p, Z.divide_1_r in H5; auto with zarith. + destruct H5. + * contradict H4; rewrite <- (Z.opp_involutive a), H5 . + apply Z.lt_irrefl. + * contradict H4; rewrite <- (Z.opp_involutive a), H5 . + discriminate. + + apply H0; split. + * now apply Z.opp_le_mono; rewrite Z.opp_involutive; apply Z.lt_le_incl. + * now apply Z.opp_lt_mono; rewrite Z.opp_involutive. (* a = 0 *) - - inversion H1. subst a; omega. + - contradict H. + replace p with 0; try discriminate. + now apply sym_equal, Z.divide_0_l; rewrite <-H2. (* 1 < a < p *) - - absurd (rel_prime a p); intuition. - inversion H2. - assert (a | a) by auto with zarith. - assert (a | p) by auto with zarith. - apply H7, Z.divide_1_r in H8; intuition. + - absurd (rel_prime a p). + + intros [H1p H2p H3p]. + assert (a | a) by auto with zarith. + assert (a | p) by auto with zarith. + apply H3p, Z.divide_1_r in H5; auto with zarith. + destruct H5. + * contradict H3; rewrite <- (Z.opp_involutive a), H5 . + apply Z.lt_irrefl. + * contradict H3; rewrite <- (Z.opp_involutive a), H5 . + discriminate. + + apply H0; split; auto. + now apply Z.lt_le_incl. Qed. (** A prime number is relatively prime with any number it does not divide *) @@ -605,12 +655,17 @@ Proof. intros a p Hp [H1 H2]. apply rel_prime_sym; apply prime_rel_prime; auto. intros [q Hq]; subst a. - case (Z.le_gt_cases q 0); intros Hl. - absurd (q * p <= 0 * p); auto with zarith. - absurd (1 * p <= q * p); auto with zarith. + destruct Hp as [H3 H4]. + contradict H2; apply Zle_not_lt. + rewrite <- (Z.mul_1_l p) at 1. + apply Zmult_le_compat_r. + - apply (Zlt_le_succ 0). + apply Zmult_lt_0_reg_r with p. + + apply Z.le_succ_l, Z.lt_le_incl; auto. + + now apply Z.le_succ_l. + - apply Z.lt_le_incl, Z.le_succ_l, Z.lt_le_incl; auto. Qed. - (** If a prime [p] divides [ab] then it divides either [a] or [b] *) Lemma prime_mult : @@ -623,38 +678,44 @@ Qed. Lemma not_prime_0: ~ prime 0. Proof. - intros H1; case (prime_divisors _ H1 2); auto with zarith. + intros H1; case (prime_divisors _ H1 2); auto with zarith; intuition; discriminate. Qed. Lemma not_prime_1: ~ prime 1. Proof. - intros H1; absurd (1 < 1); auto with zarith. + intros H1; absurd (1 < 1). discriminate. inversion H1; auto. Qed. Lemma prime_2: prime 2. Proof. - apply prime_intro; auto with zarith. - intros n (H,H'); Z.le_elim H; auto with zarith. - - contradict H'; auto with zarith. - - subst n. constructor; auto with zarith. + apply prime_intro. + - red; auto. + - intros n (H,H'); Z.le_elim H; auto with zarith. + + contradict H'; auto with zarith. + now apply Zle_not_lt, (Zlt_le_succ 1). + + subst n. constructor; auto with zarith. Qed. Theorem prime_3: prime 3. Proof. apply prime_intro; auto with zarith. - intros n (H,H'); Z.le_elim H; auto with zarith. - - replace n with 2 by omega. - constructor; auto with zarith. - intros x (q,Hq) (q',Hq'). - exists (q' - q). ring_simplify. now rewrite <- Hq, <- Hq'. - - replace n with 1 by trivial. - constructor; auto with zarith. + - red; auto. + - intros n (H,H'); Z.le_elim H; auto with zarith. + + replace n with 2. + * constructor; auto with zarith. + intros x (q,Hq) (q',Hq'). + exists (q' - q). ring_simplify. now rewrite <- Hq, <- Hq'. + * apply Z.le_antisymm. + ++ now apply (Zlt_le_succ 1). + ++ now apply (Z.lt_le_pred _ 3). + + replace n with 1 by trivial. + constructor; auto with zarith. Qed. Theorem prime_ge_2 p : prime p -> 2 <= p. Proof. - intros (Hp,_); auto with zarith. + now intros (Hp,_); apply (Zlt_le_succ 1). Qed. Definition prime' p := 1<p /\ (forall n, 1<n<p -> ~ (n|p)). @@ -675,17 +736,24 @@ Proof. assert (Hx := Z.abs_nonneg x). set (y:=Z.abs x) in *; clearbody y; clear x; rename y into x. destruct (Z_0_1_more x Hx) as [->|[->|Hx']]. - + exfalso. apply Z.divide_0_l in Hxn. omega. + + exfalso. apply Z.divide_0_l in Hxn. + absurd (1 <= n). + * rewrite Hxn; red; auto. + * intuition. + now exists 1. + elim (H x); auto. split; trivial. - apply Z.le_lt_trans with n; auto with zarith. + apply Z.le_lt_trans with n; try intuition. apply Z.divide_pos_le; auto with zarith. + apply Z.lt_le_trans with (2 := H0); red; auto. - (* prime' -> prime *) constructor; trivial. intros n Hn Hnp. - case (Zis_gcd_unique n p n 1); auto with zarith. - constructor; auto with zarith. - apply H; auto with zarith. + case (Zis_gcd_unique n p n 1). + + constructor; auto with zarith. + + apply H; auto with zarith. + now intuition; apply Z.lt_le_incl. + + intros H1; intuition; subst n; discriminate. + + intros H1; intuition; subst n; discriminate. Qed. Theorem square_not_prime: forall a, ~ prime (a * a). @@ -698,7 +766,9 @@ Proof. assert (H' : 1 < a) by now apply (Z.square_lt_simpl_nonneg 1). apply (Ha' a). + split; trivial. - rewrite <- (Z.mul_1_l a) at 1. apply Z.mul_lt_mono_pos_r; omega. + rewrite <- (Z.mul_1_l a) at 1. + apply Z.mul_lt_mono_pos_r; auto. + apply Z.lt_trans with (2 := H'); red; auto. + exists a; auto. Qed. @@ -709,10 +779,11 @@ Proof. assert (Hp: 0 < p); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith. assert (Hq: 0 < q); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith. case prime_divisors with (2 := H2); auto. - intros H4; contradict Hp; subst; auto with zarith. - intros [H4| [H4 | H4]]; subst; auto. - contradict H; auto; apply not_prime_1. - contradict Hp; auto with zarith. + - intros H4; contradict Hp; subst; discriminate. + - intros [H4| [H4 | H4]]; subst; auto. + + contradict H; auto; apply not_prime_1. + + contradict Hp; apply Zle_not_lt, (Z.opp_le_mono _ 0). + now rewrite Z.opp_involutive; apply Z.lt_le_incl. Qed. (** we now prove that [Z.gcd] is indeed a gcd in @@ -748,6 +819,9 @@ Proof. apply Zgcd_is_gcd; auto. Z.le_elim H1. - generalize (Z.gcd_nonneg a b); auto with zarith. + intros H3 H4; contradict H3. + rewrite <- (Z.opp_involutive (Z.gcd a b)), <- H4. + now apply Zlt_not_le, Z.opp_lt_mono; rewrite Z.opp_involutive. - subst. now case (Z.gcd a b). Qed. @@ -801,7 +875,8 @@ Proof. case (Zis_gcd_unique a b (Z.gcd a b) 1); auto. apply Zgcd_is_gcd. intros H2; absurd (0 <= Z.gcd a b); auto with zarith. - generalize (Z.gcd_nonneg a b); auto with zarith. + - rewrite H2; red; auto. + - generalize (Z.gcd_nonneg a b); auto with zarith. Qed. Definition rel_prime_dec: forall a b, @@ -819,18 +894,25 @@ Definition prime_dec_aux: Proof. intros p m. case (Z_lt_dec 1 m); intros H1; - [ | left; intros; exfalso; omega ]. + [ | left; intros; exfalso; + contradict H1; apply Z.lt_trans with n; intuition]. pattern m; apply natlike_rec; auto with zarith. - left; intros; exfalso; omega. - intros x Hx IH; destruct IH as [F|E]. - destruct (rel_prime_dec x p) as [Y|N]. - left; intros n [HH1 HH2]. - rewrite Z.lt_succ_r in HH2. - Z.le_elim HH2; subst; auto with zarith. - - case (Z_lt_dec 1 x); intros HH1. - * right; exists x; split; auto with zarith. - * left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith. - - right; destruct E as (n,((H0,H2),H3)); exists n; auto with zarith. + - left; intros; exfalso. + absurd (1 < 0); try discriminate. + apply Z.lt_trans with n; intuition. + - intros x Hx IH; destruct IH as [F|E]. + + destruct (rel_prime_dec x p) as [Y|N]. + * left; intros n [HH1 HH2]. + rewrite Z.lt_succ_r in HH2. + Z.le_elim HH2; subst; auto with zarith. + * case (Z_lt_dec 1 x); intros HH1. + -- right; exists x; split; auto with zarith. + -- left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith. + apply Zle_not_lt; apply Z.le_trans with x. + ++ now apply Zlt_succ_le. + ++ now apply Znot_gt_le; contradict HH1; apply Z.gt_lt. + + right; destruct E as (n,((H0,H2),H3)); exists n; auto with zarith. + - apply Z.le_trans with (2 := Z.lt_le_incl _ _ H1); discriminate. Defined. Definition prime_dec: forall p, { prime p }+{ ~ prime p }. @@ -842,6 +924,7 @@ Proof. constructor; auto with zarith. * right; intros H3; inversion_clear H3 as [Hp1 Hp2]. case H2; intros n [Hn1 Hn2]; case Hn2; auto with zarith. + now apply Hp2; intuition; apply Z.lt_le_incl. + right; intros H3; inversion_clear H3 as [Hp1 Hp2]; case H1; auto. Defined. @@ -856,10 +939,15 @@ Proof. subst n; constructor; auto with zarith. - case H1; intros n (Hn1,Hn2). destruct (Z_0_1_more _ (Z.gcd_nonneg n p)) as [H|[H|H]]. - + exfalso. apply Z.gcd_eq_0_l in H. omega. + + exfalso. apply Z.gcd_eq_0_l in H. + absurd (1 < n). + * rewrite H; discriminate. + * now intuition. + elim Hn2. red. rewrite <- H. apply Zgcd_is_gcd. + exists (Z.gcd n p); split; [ split; auto | apply Z.gcd_divide_r ]. apply Z.le_lt_trans with n; auto with zarith. - apply Z.divide_pos_le; auto with zarith. - apply Z.gcd_divide_l. + * apply Z.divide_pos_le; auto with zarith. + -- apply Z.lt_trans with 1; intuition. + -- apply Z.gcd_divide_l. + * intuition. Qed. diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index 66e246616f..e65eb7cdc7 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import ZArith_base ZArithRing Zcomplements Zdiv Znumtheory. +Require Import ZArith_base ZArithRing Omega Zcomplements Zdiv Znumtheory. Require Export Zpower. Local Open Scope Z_scope. diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index f80d075b67..da8a9402dd 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Wf_nat ZArith_base Omega Zcomplements. +Require Import Wf_nat ZArith_base Zcomplements. Require Export Zpow_def. Local Open Scope Z_scope. @@ -220,7 +220,8 @@ Section Powers_of_2. Lemma two_p_pred x : 0 <= x -> two_p (Z.pred x) < two_p x. Proof. - rewrite !two_p_equiv. intros. apply Z.pow_lt_mono_r; auto with zarith. + rewrite !two_p_equiv. intros. apply Z.pow_lt_mono_r; auto using Z.lt_pred_l. + reflexivity. Qed. End Powers_of_2. @@ -265,17 +266,45 @@ Section power_div_with_rest. let '(q,r,d) := Pos.iter Zdiv_rest_aux (x, 0, 1) p in x = q * d + r /\ 0 <= r < d. Proof. - apply Pos.iter_invariant; [|omega]. - intros ((q,r),d) (H,H'). unfold Zdiv_rest_aux. - destruct q as [ |[q|q| ]|[q|q| ]]; try omega. + apply Pos.iter_invariant; [|rewrite Z.mul_1_r, Z.add_0_r; repeat split; auto; discriminate]. + intros ((q,r),d) (H,(H1',H2')). unfold Zdiv_rest_aux. + assert (H1 : 0 < d) by now apply Z.le_lt_trans with (1 := H1'). + assert (H2 : 0 <= d + r) by now apply Z.add_nonneg_nonneg; auto; apply Z.lt_le_incl. + assert (H3 : d + r < 2 * d) + by now rewrite <-Z.add_diag; apply Zplus_lt_compat_l. + assert (H4 : r < 2 * d) by now + apply Z.lt_le_trans with (1 * d); [ + rewrite Z.mul_1_l; auto | + apply Zmult_le_compat_r; try discriminate; + now apply Z.lt_le_incl]. + destruct q as [ |[q|q| ]|[q|q| ]]. + - repeat split; auto. - rewrite Pos2Z.inj_xI, Z.mul_add_distr_r in H. - rewrite Z.mul_shuffle3, Z.mul_assoc. omega. + rewrite Z.mul_shuffle3, Z.mul_assoc. + rewrite Z.mul_1_l in H; rewrite Z.add_assoc. + repeat split; auto with zarith. - rewrite Pos2Z.inj_xO in H. - rewrite Z.mul_shuffle3, Z.mul_assoc. omega. + rewrite Z.mul_shuffle3, Z.mul_assoc. + repeat split; auto. + - rewrite Z.mul_1_l in H; repeat split; auto. - rewrite Pos2Z.neg_xI, Z.mul_sub_distr_r in H. - rewrite Z.mul_sub_distr_r, Z.mul_shuffle3, Z.mul_assoc. omega. + rewrite Z.mul_sub_distr_r, Z.mul_shuffle3, Z.mul_assoc. + repeat split; auto. + rewrite !Z.mul_1_l, H, Z.add_assoc. + apply f_equal2 with (f := Z.add); auto. + rewrite <- Z.sub_sub_distr, <- !Z.add_diag, Z.add_simpl_r. + now rewrite Z.mul_1_l. - rewrite Pos2Z.neg_xO in H. - rewrite Z.mul_shuffle3, Z.mul_assoc. omega. + rewrite Z.mul_shuffle3, Z.mul_assoc. + repeat split; auto. + - repeat split; auto. + rewrite H, (Z.mul_opp_l 1), Z.mul_1_l, Z.add_assoc. + apply f_equal2 with (f := Z.add); auto. + rewrite Z.add_comm, <- Z.add_diag. + rewrite Z.mul_add_distr_l. + replace (-1 * d) with (-d). + + now rewrite Z.add_assoc, Z.add_opp_diag_r . + + now rewrite (Z.mul_opp_l 1), <-(Z.mul_opp_l 1). Qed. (** Old-style rich specification by proof of existence *) diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 08253e5a8f..626ac0fe67 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -226,7 +226,7 @@ COQTOPINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)/toploop) # We here define a bunch of variables about the files being part of the # Coq project in order to ease the writing of build target and build rules -VDFILE := .coqdeps +VDFILE := @DEP_FILE@ ALLSRCFILES := \ $(MLGFILES) \ @@ -312,7 +312,7 @@ else DO_NATDYNLINK = endif -ALLDFILES = $(addsuffix .d,$(ALLSRCFILES) $(VDFILE)) +ALLDFILES = $(addsuffix .d,$(ALLSRCFILES)) $(VDFILE) # Compilation targets ######################################################### @@ -732,7 +732,7 @@ $(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack # projects. Note that extra options might be on the command line. VDFILE_FLAGS:=$(if @PROJECT_FILE@,-f @PROJECT_FILE@,) $(CMDLINE_COQLIBS) $(CMDLINE_VFILES) -$(VDFILE).d: $(VFILES) +$(VDFILE): $(VFILES) $(SHOW)'COQDEP VFILES' $(HIDE)$(COQDEP) -dyndep var $(VDFILE_FLAGS) $(redir_if_ok) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 1bd52d5bf1..b091ff3b4e 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -122,7 +122,7 @@ let read_whole_file s = let quote s = if String.contains s ' ' || CString.is_empty s then "'" ^ s ^ "'" else s -let generate_makefile oc conf_file local_file args project = +let generate_makefile oc conf_file local_file dep_file args project = let coqlib = Envars.coqlib () in let makefile_template = let template = Filename.concat "tools" "CoqMakefile.in" in @@ -133,6 +133,7 @@ let generate_makefile oc conf_file local_file args project = (fun s (k,v) -> Str.global_substitute (Str.regexp_string k) (fun _ -> v) s) s [ "@CONF_FILE@", conf_file; "@LOCAL_FILE@", local_file; + "@DEP_FILE@", dep_file; "@COQ_VERSION@", Coq_config.version; "@PROJECT_FILE@", (Option.default "" project.project_file); "@COQ_MAKEFILE_INVOCATION@",String.concat " " (List.map quote args); @@ -412,6 +413,7 @@ let _ = let conf_file = Option.default "CoqMakefile" project.makefile ^ ".conf" in let local_file = Option.default "CoqMakefile" project.makefile ^ ".local" in + let dep_file = "." ^ Option.default "CoqMakefile" project.makefile ^ ".d" in if project.extra_targets <> [] then begin eprintf "Warning: -extra and -extra-phony are deprecated.\n"; @@ -434,7 +436,7 @@ let _ = Envars.set_coqlib ~fail:(fun x -> Printf.eprintf "Error: %s\n" x; exit 1); let ocm = Option.cata open_out stdout project.makefile in - generate_makefile ocm conf_file local_file (prog :: args) project; + generate_makefile ocm conf_file local_file dep_file (prog :: args) project; close_out ocm; let occ = open_out conf_file in generate_conf occ project (prog :: args); diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index adc1606016..8a878bb0d0 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -109,6 +109,7 @@ let tac2def_mut = Entry.create "tactic:tac2def_mut" let tac2mode = Entry.create "vernac:ltac2_command" let ltac1_expr = Pltac.tactic_expr +let tac2expr_in_env = Tac2entries.Pltac.tac2expr_in_env let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c @@ -129,7 +130,7 @@ let pattern_of_qualid qid = GRAMMAR EXTEND Gram GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn - tac2def_mut; + tac2def_mut tac2expr_in_env; tac2pat: [ "1" LEFTA [ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> { @@ -248,6 +249,18 @@ GRAMMAR EXTEND Gram | e = ltac1_expr -> { [], e } ] ] ; + tac2expr_in_env : + [ [ test_ltac1_env; ids = LIST0 locident; "|-"; e = tac2expr -> + { let check { CAst.v = id; CAst.loc = loc } = + if Tac2env.is_constructor (Libnames.qualid_of_ident ?loc id) then + CErrors.user_err ?loc Pp.(str "Invalid bound Ltac2 identifier " ++ Id.print id) + in + let () = List.iter check ids in + (ids, e) + } + | tac = tac2expr -> { [], tac } + ] ] + ; let_clause: [ [ binder = let_binder; ":="; te = tac2expr -> { let (pat, fn) = binder in @@ -860,7 +873,7 @@ let rules = [ Stop ++ Aentry test_ampersand_ident ++ Atoken (PKEYWORD "&") ++ Aentry Prim.ident, begin fun id _ _ loc -> let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) ([], tac) in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) end ); @@ -869,7 +882,7 @@ let rules = [ Stop ++ Atoken (PIDENT (Some "ltac2")) ++ Atoken (PKEYWORD ":") ++ Atoken (PKEYWORD "(") ++ Aentry tac2expr ++ Atoken (PKEYWORD ")"), begin fun _ tac _ _ _ loc -> - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) ([], tac) in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) end ) diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index f6775ddd1f..34870345a5 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1220,7 +1220,9 @@ let () = (** Ltac2 in terms *) let () = - let interp ist poly env sigma concl tac = + let interp ist poly env sigma concl (ids, tac) = + (* Syntax prevents bound variables in constr quotations *) + let () = assert (List.is_empty ids) in let ist = Tac2interp.get_env ist in let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in let name, poly = Id.of_string "ltac2", poly in @@ -1248,25 +1250,73 @@ let () = (** Ltac2 in Ltac1 *) let () = - let e = Tac2entries.Pltac.tac2expr in + let e = Tac2entries.Pltac.tac2expr_in_env in let inject (loc, v) = Ltac_plugin.Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) +(* Ltac1 runtime representation of Ltac2 closure quotations *) +let typ_ltac2 : (Id.t list * glb_tacexpr) Geninterp.Val.typ = + Geninterp.Val.create "ltac2:ltac2_eval" + +let ltac2_eval = + let open Ltac_plugin in + let ml_name = { + Tacexpr.mltac_plugin = "ltac2"; + mltac_tactic = "ltac2_eval"; + } in + let eval_fun args ist = match args with + | [] -> assert false + | tac :: args -> + (* By convention the first argument is the tactic being applied, the rest + being the arguments it should be fed with *) + let Geninterp.Val.Dyn (tag, tac) = tac in + let (ids, tac) : Id.t list * glb_tacexpr = match Geninterp.Val.eq tag typ_ltac2 with + | None -> assert false + | Some Refl -> tac + in + let fold accu id = match Id.Map.find id ist.Geninterp.lfun with + | v -> Id.Map.add id (Tac2ffi.of_ext val_ltac1 v) accu + | exception Not_found -> assert false + in + let env_ist = List.fold_left fold Id.Map.empty ids in + Proofview.tclIGNORE (Tac2interp.interp { env_ist } tac) + in + let () = Tacenv.register_ml_tactic ml_name [|eval_fun|] in + { Tacexpr.mltac_name = ml_name; mltac_index = 0 } + let () = let open Ltac_plugin in let open Tacinterp in - let idtac = Value.of_closure (default_ist ()) (Tacexpr.TacId []) in - let interp ist tac = -(* let ist = Tac2interp.get_env ist.Geninterp.lfun in *) + let interp ist (ids, tac as self) = match ids with + | [] -> + (* Evaluate the Ltac2 quotation eagerly *) + let idtac = Value.of_closure { ist with lfun = Id.Map.empty } (Tacexpr.TacId []) in let ist = { env_ist = Id.Map.empty } in Tac2interp.interp ist tac >>= fun _ -> Ftactic.return idtac + | _ :: _ -> + (* Return a closure [@f := {blob} |- fun ids => ltac2_eval(f, ids) ] *) + (* This name cannot clash with Ltac2 variables which are all lowercase *) + let self_id = Id.of_string "F" in + let nas = List.map (fun id -> Name id) ids in + let mk_arg id = Tacexpr.Reference (Locus.ArgVar (CAst.make id)) in + let args = List.map mk_arg ids in + let clos = Tacexpr.TacFun (nas, Tacexpr.TacML (CAst.make (ltac2_eval, mk_arg self_id :: args))) in + let self = Geninterp.Val.inject (Geninterp.Val.Base typ_ltac2) self in + let ist = { ist with lfun = Id.Map.singleton self_id self } in + Ftactic.return (Value.of_closure ist clos) in Geninterp.register_interp0 wit_ltac2 interp let () = let pr_raw _ = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in - let pr_glb e = Genprint.PrinterBasic (fun _env _sigma -> Tac2print.pr_glbexpr e) in + let pr_glb (ids, e) = + let ids = + if List.is_empty ids then mt () + else pr_sequence Id.print ids ++ str " |- " + in + Genprint.PrinterBasic Pp.(fun _env _sigma -> ids ++ Tac2print.pr_glbexpr e) + in let pr_top _ = Genprint.TopPrinterBasic mt in Genprint.register_print0 wit_ltac2 pr_raw pr_glb pr_top diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 17004bb012..6b7b75f0d4 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -25,6 +25,7 @@ open Tac2intern module Pltac = struct let tac2expr = Pcoq.Entry.create "tactic:tac2expr" +let tac2expr_in_env = Pcoq.Entry.create "tactic:tac2expr_in_env" let q_ident = Pcoq.Entry.create "tactic:q_ident" let q_bindings = Pcoq.Entry.create "tactic:q_bindings" diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index a913a62e45..d96a6a95c5 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -64,6 +64,7 @@ val backtrace : backtrace Exninfo.t module Pltac : sig val tac2expr : raw_tacexpr Pcoq.Entry.t +val tac2expr_in_env : (Id.t CAst.t list * raw_tacexpr) Pcoq.Entry.t (** Quoted entries. To be used for complex notations. *) diff --git a/user-contrib/Ltac2/tac2env.mli b/user-contrib/Ltac2/tac2env.mli index 2dbb16e184..2f4a49a0f5 100644 --- a/user-contrib/Ltac2/tac2env.mli +++ b/user-contrib/Ltac2/tac2env.mli @@ -140,7 +140,7 @@ val ltac1_prefix : ModPath.t (** {5 Generic arguments} *) -val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type +val wit_ltac2 : (Id.t CAst.t list * raw_tacexpr, Id.t list * glb_tacexpr, Util.Empty.t) genarg_type val wit_ltac2_quotation : (Id.t Loc.located, Id.t, Util.Empty.t) genarg_type (** {5 Helper functions} *) diff --git a/user-contrib/Ltac2/tac2intern.ml b/user-contrib/Ltac2/tac2intern.ml index 0961e9c9c9..5b3aa799a1 100644 --- a/user-contrib/Ltac2/tac2intern.ml +++ b/user-contrib/Ltac2/tac2intern.ml @@ -22,10 +22,12 @@ open Tac2expr (** Hardwired types and constants *) let coq_type n = KerName.make Tac2env.coq_prefix (Label.make n) +let ltac1_type n = KerName.make Tac2env.ltac1_prefix (Label.make n) let t_int = coq_type "int" let t_string = coq_type "string" let t_constr = coq_type "constr" +let t_ltac1 = ltac1_type "t" (** Union find *) @@ -1505,7 +1507,8 @@ let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with let () = let open Genintern in - let intern ist tac = + let intern ist (ids, tac) = + let ids = List.map (fun { CAst.v = id } -> id) ids in let env = match Genintern.Store.get ist.extra ltac2_env with | None -> (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) @@ -1514,13 +1517,17 @@ let () = else { env with env_str = false } | Some env -> env in + let fold env id = + push_name (Name id) (monomorphic (GTypRef (Other t_ltac1, []))) env + in + let env = List.fold_left fold env ids in let loc = tac.loc in let (tac, t) = intern_rec env tac in let () = check_elt_unit loc env t in - (ist, tac) + (ist, (ids, tac)) in Genintern.register_intern0 wit_ltac2 intern -let () = Genintern.register_subst0 wit_ltac2 subst_expr +let () = Genintern.register_subst0 wit_ltac2 (fun s (ids, e) -> ids, subst_expr s e) let () = let open Genintern in diff --git a/vernac/classes.ml b/vernac/classes.ml index 0a8c4e6b0f..09866a75c9 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -210,7 +210,7 @@ let discharge_class (_,cl) = in grs', discharge_rel_context subst 1 ctx @ ctx' in try let info = abs_context cl in - let ctx = info.Lib.abstr_ctx in + let ctx = info.Section.abstr_ctx in let ctx, subst = rel_of_variable_context ctx in let usubst, cl_univs' = Lib.discharge_abstract_universe_context info cl.cl_univs in let context = discharge_context ctx (subst, usubst) cl.cl_context in @@ -325,7 +325,7 @@ let declare_instance_constant info global imps ?hook name decl poly sigma term t let entry = Declare.definition_entry ~types:termtype ~univs:uctx term in let kn = Declare.declare_constant ~name ~kind (Declare.DefinitionEntry entry) in Declare.definition_message name; - Declare.declare_univ_binders (GlobRef.ConstRef kn) (Evd.universe_binders sigma); + DeclareUniv.declare_univ_binders (GlobRef.ConstRef kn) (Evd.universe_binders sigma); instance_hook info global imps ?hook (GlobRef.ConstRef kn) let do_declare_instance sigma ~global ~poly k u ctx ctx' pri decl imps subst name = @@ -338,7 +338,7 @@ let do_declare_instance sigma ~global ~poly k u ctx ctx' pri decl imps subst nam let sigma, entry = DeclareDef.prepare_parameter ~allow_evars:false ~poly sigma decl termtype in let cst = Declare.declare_constant ~name ~kind:Decls.(IsAssumption Logical) (Declare.ParameterEntry entry) in - Declare.declare_univ_binders (GlobRef.ConstRef cst) (Evd.universe_binders sigma); + DeclareUniv.declare_univ_binders (GlobRef.ConstRef cst) (Evd.universe_binders sigma); instance_hook pri global imps (GlobRef.ConstRef cst) let declare_instance_program env sigma ~global ~poly id pri imps decl term termtype = diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 5ba8b0ab3c..e5db6146ca 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -69,7 +69,7 @@ let declare_axiom is_coe ~poly ~local ~kind typ (univs, pl) imps nl {CAst.v=name let kn = Declare.declare_constant ~name ~local ~kind decl in let gr = GlobRef.ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in - let () = Declare.declare_univ_binders gr pl in + let () = DeclareUniv.declare_univ_binders gr pl in let () = Declare.assumption_message name in let env = Global.env () in let sigma = Evd.from_env env in @@ -217,7 +217,7 @@ let context_insection sigma ~poly ctx = in let entry = Declare.definition_entry ~univs ~types:t b in let _ : GlobRef.t = DeclareDef.declare_definition ~name ~scope:DeclareDef.Discharge - ~kind:Decls.Definition UnivNames.empty_binders entry [] + ~kind:Decls.(IsDefinition Definition) UnivNames.empty_binders entry [] in () in @@ -287,7 +287,7 @@ let context ~poly l = name,b,t,impl) ctx in - if Lib.sections_are_opened () + if Global.sections_are_opened () then context_insection sigma ~poly ctx else context_nosection sigma ~poly ctx diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 9745358ba2..5b3f15a08c 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -104,4 +104,5 @@ let do_definition ~program_mode ?hook ~name ~scope ~poly ~kind univdecl bl red_o let ce = check_definition ~program_mode def in let uctx = Evd.evar_universe_context evd in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in + let kind = Decls.IsDefinition kind in ignore(DeclareDef.declare_definition ~name ~scope ~kind ?hook_data (Evd.universe_binders evd) ce imps) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 98b869d72e..cee5b7c1f4 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -15,18 +15,15 @@ open Util open Constr open Context open Environ -open Declare open Names open Libnames open Nameops open Constrexpr open Constrexpr_ops open Constrintern -open Impargs open Reductionops open Type_errors open Pretyping -open Indschemes open Context.Rel.Declaration open Entries @@ -80,12 +77,6 @@ type structured_one_inductive_expr = { ind_lc : (Id.t * constr_expr) list } -let minductive_message = function - | [] -> user_err Pp.(str "No inductive definition.") - | [x] -> (Id.print x ++ str " is defined") - | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ - spc () ++ str "are defined") - let check_all_names_different indl = let ind_names = List.map (fun ind -> ind.ind_name) indl in let cstr_names = List.map_append (fun ind -> List.map fst ind.ind_lc) indl in @@ -541,62 +532,6 @@ let extract_mutual_inductive_declaration_components indl = let indl = extract_inductive indl in (params,indl), coes, List.flatten ntnl -let is_recursive mie = - let rec is_recursive_constructor lift typ = - match Constr.kind typ with - | Prod (_,arg,rest) -> - not (EConstr.Vars.noccurn Evd.empty (* FIXME *) lift (EConstr.of_constr arg)) || - is_recursive_constructor (lift+1) rest - | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest - | _ -> false - in - match mie.mind_entry_inds with - | [ind] -> - let nparams = List.length mie.mind_entry_params in - List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc - | _ -> false - -let warn_non_primitive_record = - CWarnings.create ~name:"non-primitive-record" ~category:"record" - (fun indsp -> - (hov 0 (str "The record " ++ Nametab.pr_global_env Id.Set.empty (GlobRef.IndRef indsp) ++ - strbrk" could not be defined as a primitive record"))) - -let declare_mutual_inductive_with_eliminations ?(primitive_expected=false) mie pl impls = - (* spiwack: raises an error if the structure is supposed to be non-recursive, - but isn't *) - begin match mie.mind_entry_finite with - | Declarations.BiFinite when is_recursive mie -> - if Option.has_some mie.mind_entry_record then - user_err Pp.(str "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command.") - else - user_err Pp.(str ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.")) - | _ -> () - end; - let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in - let (_, kn), prim = declare_mind mie in - let mind = Global.mind_of_delta_kn kn in - if primitive_expected && not prim then warn_non_primitive_record (mind,0); - Declare.declare_univ_binders (GlobRef.IndRef (mind,0)) pl; - List.iteri (fun i (indimpls, constrimpls) -> - let ind = (mind,i) in - let gr = GlobRef.IndRef ind in - maybe_declare_manual_implicits false gr indimpls; - List.iteri - (fun j impls -> - maybe_declare_manual_implicits false - (GlobRef.ConstructRef (ind, succ j)) impls) - constrimpls) - impls; - Flags.if_verbose Feedback.msg_info (minductive_message names); - if mie.mind_entry_private == None - then declare_default_schemes mind; - mind - -type one_inductive_impls = - Impargs.manual_implicits (* for inds *) * - Impargs.manual_implicits list (* for constrs *) - type uniform_inductive_flag = | UniformParameters | NonUniformParameters @@ -607,7 +542,7 @@ let do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind ~uni let indl = match uniform with UniformParameters -> (params, [], indl) | NonUniformParameters -> ([], params, indl) in let mie,pl,impls = interp_mutual_inductive_gen (Global.env()) ~template udecl indl ntns ~cumulative ~poly ~private_ind finite in (* Declare the mutual inductive block with its associated schemes *) - ignore (declare_mutual_inductive_with_eliminations mie pl impls); + ignore (DeclareInd.declare_mutual_inductive_with_eliminations mie pl impls); (* Declare the possible notations of inductive types *) List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns; (* Declare the coercions *) @@ -652,3 +587,5 @@ let make_cases ind = let consref = GlobRef.ConstructRef (ith_constructor_of_inductive ind (i + 1)) in (Libnames.string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty consref) :: al') :: l) mip.mind_nf_lc [] + +let declare_mutual_inductive_with_eliminations = DeclareInd.declare_mutual_inductive_with_eliminations diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 7587bd165f..067fb3d2ca 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Entries open Vernacexpr open Constrexpr @@ -42,22 +41,18 @@ val do_mutual_inductive val make_cases : Names.inductive -> string list list +val declare_mutual_inductive_with_eliminations + : ?primitive_expected:bool + -> Entries.mutual_inductive_entry + -> UnivNames.universe_binders + -> DeclareInd.one_inductive_impls list + -> Names.MutInd.t + [@@ocaml.deprecated "Please use DeclareInd.declare_mutual_inductive_with_eliminations"] + (************************************************************************) (** Internal API, exported for Record *) (************************************************************************) -(** Registering a mutual inductive definition together with its - associated schemes *) - -type one_inductive_impls = - Impargs.manual_implicits (* for inds *) * - Impargs.manual_implicits list (* for constrs *) - -val declare_mutual_inductive_with_eliminations : - ?primitive_expected:bool -> - mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list -> - MutInd.t - val should_auto_template : Id.t -> bool -> bool (** [should_auto_template x b] is [true] when [b] is [true] and we automatically use template polymorphism. [x] is the name of the @@ -72,7 +67,3 @@ val template_polymorphism_candidate : can be made parametric in its conclusion sort, if one is given. If the [Template Check] flag is false we just check that the conclusion sort is not small. *) - -val sign_level : Environ.env -> Evd.evar_map -> Constr.rel_declaration list -> Univ.Universe.t -(** [sign_level env sigma ctx] computes the universe level of the context [ctx] - as the [sup] of its individual assumptions, which should be well-typed in [env] and [sigma] *) diff --git a/vernac/comPrimitive.ml b/vernac/comPrimitive.ml index 06fafddafb..b66ff876d3 100644 --- a/vernac/comPrimitive.ml +++ b/vernac/comPrimitive.ml @@ -9,7 +9,7 @@ (************************************************************************) let do_primitive id prim typopt = - if Lib.sections_are_opened () then + if Global.sections_are_opened () then CErrors.user_err Pp.(str "Declaring a primitive is not allowed in sections."); if Dumpglob.dump () then Dumpglob.dump_definition id false "ax"; let env = Global.env () in diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 1926faaf0e..f044c025d8 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -48,13 +48,13 @@ let declare_definition ~name ~scope ~kind ?hook_data udecl ce imps = let gr = match scope with | Discharge -> let () = - declare_variable ~name ~kind:Decls.(IsDefinition kind) (SectionLocalDef ce) + declare_variable ~name ~kind (SectionLocalDef ce) in Names.GlobRef.VarRef name | Global local -> - let kn = declare_constant ~name ~local ~kind:Decls.(IsDefinition kind) (DefinitionEntry ce) in + let kn = declare_constant ~name ~local ~kind (DefinitionEntry ce) in let gr = Names.GlobRef.ConstRef kn in - let () = Declare.declare_univ_binders gr udecl in + let () = DeclareUniv.declare_univ_binders gr udecl in gr in let () = maybe_declare_manual_implicits false gr imps in @@ -69,6 +69,7 @@ let declare_definition ~name ~scope ~kind ?hook_data udecl ce imps = let declare_fix ?(opaque = false) ?hook_data ~name ~scope ~kind udecl univs ((def,_),eff) t imps = let ce = definition_entry ~opaque ~types:t ~univs ~eff def in + let kind = Decls.IsDefinition kind in declare_definition ~name ~scope ~kind ?hook_data udecl ce imps let check_definition_evars ~allow_evars sigma = diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 54a0c9a7e8..d6001f5970 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -42,7 +42,7 @@ end val declare_definition : name:Id.t -> scope:locality - -> kind:Decls.definition_object_kind + -> kind:Decls.logical_kind -> ?hook_data:(Hook.t * UState.t * (Id.t * Constr.t) list) -> UnivNames.universe_binders -> Evd.side_effects Declare.proof_entry diff --git a/vernac/declareInd.ml b/vernac/declareInd.ml new file mode 100644 index 0000000000..2375028541 --- /dev/null +++ b/vernac/declareInd.ml @@ -0,0 +1,214 @@ +(************************************************************************) +(* * 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 Entries + +(** Declaration of inductive blocks *) +let declare_inductive_argument_scopes kn mie = + List.iteri (fun i {mind_entry_consnames=lc} -> + Notation.declare_ref_arguments_scope Evd.empty (GlobRef.IndRef (kn,i)); + for j=1 to List.length lc do + Notation.declare_ref_arguments_scope Evd.empty (GlobRef.ConstructRef ((kn,i),j)); + done) mie.mind_entry_inds + +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) (typename, consnames) -> + let ind_p = (kn,n) in + let names, _ = + List.fold_left + (fun (names, p) l -> + let sp = + Libnames.make_path dp l + in + ((sp, GlobRef.ConstructRef (ind_p,p)) :: names, p+1)) + (names, 1) consnames in + let sp = Libnames.make_path dp typename + in + ((sp, GlobRef.IndRef ind_p) :: names, n+1)) + ([], 0) obj.ind_names + in names + +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), 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), 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), names) = + Some names + +let inInductive : inductive_obj -> Libobject.obj = + let open Libobject in + declare_object {(default_object "INDUCTIVE") with + cache_function = cache_inductive; + load_function = load_inductive; + open_function = open_inductive; + classify_function = (fun a -> Substitute a); + subst_function = ident_subst_function; + discharge_function = discharge_inductive; + } + + +let cache_prim (_,(p,c)) = Recordops.register_primitive_projection p c + +let load_prim _ p = cache_prim p + +let subst_prim (subst,(p,c)) = Mod_subst.subst_proj_repr subst p, Mod_subst.subst_constant subst c + +let discharge_prim (_,(p,c)) = Some (Lib.discharge_proj_repr p, c) + +let inPrim : (Projection.Repr.t * Constant.t) -> Libobject.obj = + let open Libobject in + declare_object { + (default_object "PRIMPROJS") with + cache_function = cache_prim ; + load_function = load_prim; + subst_function = subst_prim; + classify_function = (fun x -> Substitute x); + discharge_function = discharge_prim } + +let declare_primitive_projection p c = Lib.add_anonymous_leaf (inPrim (p,c)) + +let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = + let name = Label.to_id label in + let univs, u = match univs with + | Monomorphic_entry _ -> + (* Global constraints already defined through the inductive *) + Monomorphic_entry Univ.ContextSet.empty, Univ.Instance.empty + | Polymorphic_entry (nas, ctx) -> + Polymorphic_entry (nas, ctx), Univ.UContext.instance ctx + in + let term = Vars.subst_instance_constr u term in + let types = Vars.subst_instance_constr u types in + let entry = Declare.definition_entry ~types ~univs term in + let cst = Declare.declare_constant ~name ~kind:Decls.(IsDefinition StructureComponent) (Declare.DefinitionEntry entry) in + let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in + declare_primitive_projection p cst + +let declare_projections univs mind = + let env = Global.env () in + let mib = Environ.lookup_mind mind env in + let open Declarations in + match mib.mind_record with + | PrimRecord info -> + let iter_ind i (_, labs, _, _) = + let ind = (mind, i) in + let projs = Inductiveops.compute_projections env ind in + CArray.iter2_i (declare_one_projection univs ind ~proj_npars:mib.mind_nparams) labs projs + in + let () = Array.iteri iter_ind info in + true + | FakeRecord -> false + | NotRecord -> false + +let feedback_axiom () = Feedback.(feedback AddedAxiom) + +let is_unsafe_typing_flags () = + let open Declarations in + let flags = Environ.typing_flags (Global.env()) in + not (flags.check_universes && flags.check_guarded && flags.check_positive) + +(* for initial declaration *) +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 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) -> + Declare.check_exists typ; + List.iter Declare.check_exists cons) names; + let _kn' = Global.add_mind id mie in + let (sp,kn as oname) = Lib.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 + Impargs.declare_mib_implicits mind; + declare_inductive_argument_scopes mind mie; + oname, isprim + +let is_recursive mie = + let open Constr in + let rec is_recursive_constructor lift typ = + match Constr.kind typ with + | Prod (_,arg,rest) -> + not (EConstr.Vars.noccurn Evd.empty (* FIXME *) lift (EConstr.of_constr arg)) || + is_recursive_constructor (lift+1) rest + | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest + | _ -> false + in + match mie.mind_entry_inds with + | [ind] -> + let nparams = List.length mie.mind_entry_params in + List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc + | _ -> false + +let warn_non_primitive_record = + CWarnings.create ~name:"non-primitive-record" ~category:"record" + (fun indsp -> + Pp.(hov 0 (str "The record " ++ Nametab.pr_global_env Id.Set.empty (GlobRef.IndRef indsp) ++ + strbrk" could not be defined as a primitive record"))) + +let minductive_message = function + | [] -> CErrors.user_err Pp.(str "No inductive definition.") + | [x] -> Pp.(Id.print x ++ str " is defined") + | l -> Pp.(hov 0 (prlist_with_sep pr_comma Id.print l ++ + spc () ++ str "are defined")) + +type one_inductive_impls = + Impargs.manual_implicits (* for inds *) * + Impargs.manual_implicits list (* for constrs *) + +let declare_mutual_inductive_with_eliminations ?(primitive_expected=false) mie pl impls = + (* spiwack: raises an error if the structure is supposed to be non-recursive, + but isn't *) + begin match mie.mind_entry_finite with + | Declarations.BiFinite when is_recursive mie -> + if Option.has_some mie.mind_entry_record then + CErrors.user_err Pp.(str "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command.") + else + CErrors.user_err Pp.(str ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.")) + | _ -> () + end; + let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in + let (_, kn), prim = declare_mind mie in + let mind = Global.mind_of_delta_kn kn in + if primitive_expected && not prim then warn_non_primitive_record (mind,0); + DeclareUniv.declare_univ_binders (GlobRef.IndRef (mind,0)) pl; + List.iteri (fun i (indimpls, constrimpls) -> + let ind = (mind,i) in + let gr = GlobRef.IndRef ind in + Impargs.maybe_declare_manual_implicits false gr indimpls; + List.iteri + (fun j impls -> + Impargs.maybe_declare_manual_implicits false + (GlobRef.ConstructRef (ind, succ j)) impls) + constrimpls) + impls; + Flags.if_verbose Feedback.msg_info (minductive_message names); + if mie.mind_entry_private == None + then Indschemes.declare_default_schemes mind; + mind diff --git a/vernac/declareInd.mli b/vernac/declareInd.mli new file mode 100644 index 0000000000..df8895a999 --- /dev/null +++ b/vernac/declareInd.mli @@ -0,0 +1,23 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** Registering a mutual inductive definition together with its + associated schemes *) + +type one_inductive_impls = + Impargs.manual_implicits (* for inds *) * + Impargs.manual_implicits list (* for constrs *) + +val declare_mutual_inductive_with_eliminations + : ?primitive_expected:bool + -> Entries.mutual_inductive_entry + -> UnivNames.universe_binders + -> one_inductive_impls list + -> Names.MutInd.t diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index 8fd6bc7eab..2c56f707f1 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -351,7 +351,8 @@ let declare_definition prg = let ubinders = UState.universe_binders uctx in let hook_data = Option.map (fun hook -> hook, uctx, obls) prg.prg_hook in DeclareDef.declare_definition - ~name:prg.prg_name ~scope:prg.prg_scope ubinders ~kind:prg.prg_kind ce + ~name:prg.prg_name ~scope:prg.prg_scope ubinders + ~kind:Decls.(IsDefinition prg.prg_kind) ce prg.prg_implicits ?hook_data let rec lam_index n t acc = diff --git a/vernac/declareUniv.ml b/vernac/declareUniv.ml new file mode 100644 index 0000000000..69ba9d76ec --- /dev/null +++ b/vernac/declareUniv.ml @@ -0,0 +1,110 @@ +(************************************************************************) +(* * 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 + +type universe_source = + | BoundUniv (* polymorphic universe, bound in a function (this will go away someday) *) + | QualifiedUniv of Id.t (* global universe introduced by some global value *) + | UnqualifiedUniv (* other global universe *) + +type universe_name_decl = universe_source * (Id.t * Univ.Level.UGlobal.t) list + +let check_exists_universe sp = + if Nametab.exists_universe sp then + raise (Declare.AlreadyDeclared (Some "Universe", Libnames.basename sp)) + else () + +let qualify_univ i dp src id = + match src with + | BoundUniv | UnqualifiedUniv -> + i, Libnames.make_path dp id + | QualifiedUniv l -> + let dp = DirPath.repr dp in + Nametab.map_visibility succ i, Libnames.make_path (DirPath.make (l::dp)) id + +let do_univ_name ~check i dp src (id,univ) = + let i, sp = qualify_univ i dp src id in + if check then check_exists_universe sp; + Nametab.push_universe i sp univ + +let cache_univ_names ((sp, _), (src, univs)) = + let depth = Lib.sections_depth () in + let dp = Libnames.pop_dirpath_n depth (Libnames.dirpath sp) in + List.iter (do_univ_name ~check:true (Nametab.Until 1) dp src) univs + +let load_univ_names i ((sp, _), (src, univs)) = + List.iter (do_univ_name ~check:false (Nametab.Until i) (Libnames.dirpath sp) src) univs + +let open_univ_names i ((sp, _), (src, univs)) = + List.iter (do_univ_name ~check:false (Nametab.Exactly i) (Libnames.dirpath sp) src) univs + +let discharge_univ_names = function + | _, (BoundUniv, _) -> None + | _, ((QualifiedUniv _ | UnqualifiedUniv), _ as x) -> Some x + +let input_univ_names : universe_name_decl -> Libobject.obj = + let open Libobject in + declare_object + { (default_object "Global universe name state") with + cache_function = cache_univ_names; + load_function = load_univ_names; + open_function = open_univ_names; + discharge_function = discharge_univ_names; + subst_function = (fun (subst, a) -> (* Actually the name is generated once and for all. *) a); + classify_function = (fun a -> Substitute a) } + +let declare_univ_binders gr pl = + if Global.is_polymorphic gr then + () + else + let l = let open GlobRef in match gr with + | ConstRef c -> Label.to_id @@ Constant.label c + | IndRef (c, _) -> Label.to_id @@ MutInd.label c + | VarRef id -> + CErrors.anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on variable " ++ Id.print id ++ str".") + | ConstructRef _ -> + CErrors.anomaly ~label:"declare_univ_binders" + Pp.(str "declare_univ_binders on an constructor reference") + in + let univs = Id.Map.fold (fun id univ univs -> + match Univ.Level.name univ with + | None -> assert false (* having Prop/Set/Var as binders is nonsense *) + | Some univ -> (id,univ)::univs) pl [] + in + Lib.add_anonymous_leaf (input_univ_names (QualifiedUniv l, univs)) + +let do_universe ~poly l = + let in_section = Global.sections_are_opened () in + let () = + if poly && not in_section then + CErrors.user_err ~hdr:"Constraint" + (Pp.str"Cannot declare polymorphic universes outside sections") + in + let l = List.map (fun {CAst.v=id} -> (id, UnivGen.new_univ_global ())) l in + 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 src = if poly then BoundUniv else UnqualifiedUniv in + let () = Lib.add_anonymous_leaf (input_univ_names (src, l)) in + Declare.declare_universe_context ~poly ctx + +let do_constraint ~poly l = + let open Univ in + let u_of_id x = + Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x + in + let constraints = List.fold_left (fun acc (l, d, r) -> + let lu = u_of_id l and ru = u_of_id r in + Constraint.add (lu, d, ru) acc) + Constraint.empty l + in + let uctx = ContextSet.add_constraints constraints ContextSet.empty in + Declare.declare_universe_context ~poly uctx diff --git a/vernac/declareUniv.mli b/vernac/declareUniv.mli new file mode 100644 index 0000000000..ce2a6e225c --- /dev/null +++ b/vernac/declareUniv.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* * 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 + +(** Global universe contexts, names and constraints *) +val declare_univ_binders : GlobRef.t -> UnivNames.universe_binders -> unit + +val do_universe : poly:bool -> lident list -> unit +val do_constraint : poly:bool -> Glob_term.glob_constraint list -> unit diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index 58a7dff5fd..c7b68d18c2 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -211,7 +211,7 @@ let compute_visibility exists i = (** Iterate some function [iter_objects] on all components of a module *) let do_module exists iter_objects i obj_dir obj_mp sobjs kobjs = - let prefix = Nametab.{ obj_dir ; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir ; obj_mp; } in let dirinfo = Nametab.GlobDirRef.DirModule prefix in consistency_checks exists obj_dir dirinfo; Nametab.push_dir (compute_visibility exists i) obj_dir dirinfo; @@ -266,14 +266,14 @@ and load_objects i prefix objs = and load_include i ((sp,kn), aobjs) = let obj_dir = Libnames.dirpath sp in let obj_mp = KerName.modpath kn in - let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in load_objects i prefix o and load_keep i ((sp,kn),kobjs) = (* Invariant : seg isn't empty *) let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in - let prefix = Nametab.{ obj_dir ; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir ; obj_mp; } in let modobjs = try ModObjs.get obj_mp with Not_found -> assert false (* a substobjs should already be loaded *) @@ -327,7 +327,7 @@ let rec open_object i (name, obj) = | KeepObject objs -> open_keep i (name, objs) and open_module i obj_dir obj_mp sobjs = - let prefix = Nametab.{ obj_dir ; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir ; obj_mp; } in let dirinfo = Nametab.GlobDirRef.DirModule prefix in consistency_checks true obj_dir dirinfo; Nametab.push_dir (Nametab.Exactly i) obj_dir dirinfo; @@ -353,7 +353,7 @@ and open_modtype i ((sp,kn),_) = and open_include i ((sp,kn), aobjs) = let obj_dir = Libnames.dirpath sp in let obj_mp = KerName.modpath kn in - let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in open_objects i prefix o @@ -363,7 +363,7 @@ and open_export i mpl = and open_keep i ((sp,kn),kobjs) = let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in - let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir; obj_mp; } in open_objects i prefix kobjs let rec cache_object (name, obj) = @@ -380,7 +380,7 @@ let rec cache_object (name, obj) = and cache_include ((sp,kn), aobjs) = let obj_dir = Libnames.dirpath sp in let obj_mp = KerName.modpath kn in - let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in load_objects 1 prefix o; open_objects 1 prefix o diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index e49277c51b..5ace8b917c 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -335,7 +335,7 @@ let finish_admitted env sigma ~name ~poly ~scope pe ctx hook ~udecl impargs othe in let kn = Declare.declare_constant ~name ~local ~kind:Decls.(IsAssumption Conjectural) (Declare.ParameterEntry pe) in let () = Declare.assumption_message name in - Declare.declare_univ_binders (GlobRef.ConstRef kn) (UState.universe_binders ctx); + DeclareUniv.declare_univ_binders (GlobRef.ConstRef kn) (UState.universe_binders ctx); (* This takes care of the implicits and hook for the current constant*) process_recthms ?fix_exn:None ?hook env sigma ctx ~udecl ~poly ~scope:(Global local) (GlobRef.ConstRef kn) impargs other_thms @@ -425,7 +425,7 @@ let finish_proved env sigma idopt po info = then Proof_using.suggest_constant (Global.env ()) kn in let gr = GlobRef.ConstRef kn in - Declare.declare_univ_binders gr (UState.universe_binders universes); + DeclareUniv.declare_univ_binders gr (UState.universe_binders universes); gr in Declare.definition_message name; diff --git a/vernac/locality.ml b/vernac/locality.ml index f033d32874..5862f51b43 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -39,7 +39,7 @@ let enforce_locality_exp locality_flag discharge = match locality_flag, discharge with | Some b, NoDischarge -> Global (importability_of_bool b) | None, NoDischarge -> Global Declare.ImportDefaultBehavior - | None, DoDischarge when not (Lib.sections_are_opened ()) -> + | None, DoDischarge when not (Global.sections_are_opened ()) -> (* If a Let/Variable is defined outside a section, then we consider it as a local definition *) warn_local_declaration (); Global Declare.ImportNeedQualified @@ -55,7 +55,7 @@ let enforce_locality locality_flag = Local in sections is the default, Local not in section forces non-export *) let make_section_locality = - function Some b -> b | None -> Lib.sections_are_opened () + function Some b -> b | None -> Global.sections_are_opened () let enforce_section_locality locality_flag = make_section_locality locality_flag @@ -68,7 +68,7 @@ let enforce_section_locality locality_flag = let make_module_locality = function | Some false -> - if Lib.sections_are_opened () then + if Global.sections_are_opened () then CErrors.user_err Pp.(str "This command does not support the Global option in sections."); false diff --git a/vernac/record.ml b/vernac/record.ml index 831fb53549..b60bfdfa22 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -466,7 +466,7 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa in let mie = InferCumulativity.infer_inductive (Global.env ()) mie in let impls = List.map (fun _ -> paramimpls, []) record_data in - let kn = ComInductive.declare_mutual_inductive_with_eliminations mie ubinders impls + let kn = DeclareInd.declare_mutual_inductive_with_eliminations mie ubinders impls ~primitive_expected:!primitive_flag in let map i (_, _, _, _, fieldimpls, fields, is_coe, coers) = diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index afc701edbc..956b56e256 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -13,6 +13,7 @@ Ppvernac Proof_using Egramcoq Metasyntax +DeclareUniv DeclareDef DeclareObl Canonical @@ -28,6 +29,7 @@ ComDefinition Classes ComPrimitive ComAssumption +DeclareInd ComInductive ComFixpoint ComProgramFixpoint diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 4734ce1fb9..4ecd815dd2 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -810,18 +810,18 @@ let vernac_combined_scheme lid l = Indschemes.do_combined_scheme lid l let vernac_universe ~poly l = - if poly && not (Lib.sections_are_opened ()) then + if poly && not (Global.sections_are_opened ()) then user_err ~hdr:"vernac_universe" (str"Polymorphic universes can only be declared inside sections, " ++ str "use Monomorphic Universe instead"); - Declare.do_universe ~poly l + DeclareUniv.do_universe ~poly l let vernac_constraint ~poly l = - if poly && not (Lib.sections_are_opened ()) then + if poly && not (Global.sections_are_opened ()) then user_err ~hdr:"vernac_constraint" (str"Polymorphic universe constraints can only be declared" ++ str " inside sections, use Monomorphic Constraint instead"); - Declare.do_constraint ~poly l + DeclareUniv.do_constraint ~poly l (**********************) (* Modules *) @@ -837,7 +837,7 @@ let vernac_import export refl = let vernac_declare_module export {loc;v=id} binders_ast mty_ast = (* We check the state of the system (in section, in module type) and what module information is supplied *) - if Lib.sections_are_opened () then + if Global.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); let binders_ast = List.map (fun (export,idl,ty) -> @@ -852,7 +852,7 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) and what module information is supplied *) - if Lib.sections_are_opened () then + if Global.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mexpr_ast_l with | [] -> @@ -893,7 +893,7 @@ let vernac_end_module export {loc;v=id} = Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id]) export let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = - if Lib.sections_are_opened () then + if Global.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mty_ast_l with @@ -969,7 +969,7 @@ let warn_require_in_section = (fun () -> strbrk "Use of “Require” inside a section is deprecated.") let vernac_require from import qidl = - if Lib.sections_are_opened () then warn_require_in_section (); + if Global.sections_are_opened () then warn_require_in_section (); let root = match from with | None -> None | Some from -> @@ -2098,7 +2098,7 @@ let vernac_register qid r = | RegisterCoqlib n -> let ns, id = Libnames.repr_qualid n in if DirPath.equal (dirpath_of_string "kernel") ns then begin - if Lib.sections_are_opened () then + if Global.sections_are_opened () then user_err Pp.(str "Registering a kernel type is not allowed in sections"); let pind = match Id.to_string id with | "ind_bool" -> CPrimitives.PIT_bool |