diff options
73 files changed, 6498 insertions, 1749 deletions
@@ -108,7 +108,7 @@ GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) $(addsuffix .mli, $(GRAMFILES)) GENGRAMFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h -GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) +GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) kernel/genOpcodeFiles.exe COQ_EXPORTED += GRAMFILES GRAMMLFILES GENGRAMFILES GENMLFILES GENHFILES GENFILES ## More complex file lists @@ -263,7 +263,7 @@ clean-ide: rm -f ide/input_method_lexer.ml rm -f ide/highlight.ml ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml rm -f ide/utf8_convert.ml - rm -f ide/default.bindings + rm -f ide/default.bindings ide/default_bindings_src.exe rm -rf $(COQIDEAPP) mlgclean: diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 1648638555..862c54900f 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -58,7 +58,7 @@ jobs: displayName: 'Install system dependencies' env: HOMEBREW_NO_AUTO_UPDATE: "1" - HBCORE_DATE: "2019-06-18" + HBCORE_DATE: "2019-06-16" HBCORE_REF: "944a5b7d83e4b81c749d93831b514607bdd2b6a1" - script: | diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index dadb2bb8f1..ad22c394d8 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -181,9 +181,9 @@ ######################################################################## # SF ######################################################################## -: "${sf_lf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/lf-current/lf.tgz}" -: "${sf_plf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/plf-current/plf.tgz}" -: "${sf_vfa_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/vfa-current/vfa.tgz}" +: "${sf_lf_CI_TARURL:=https://softwarefoundations.cis.upenn.edu/lf-current/lf.tgz}" +: "${sf_plf_CI_TARURL:=https://softwarefoundations.cis.upenn.edu/plf-current/plf.tgz}" +: "${sf_vfa_CI_TARURL:=https://softwarefoundations.cis.upenn.edu/vfa-current/vfa.tgz}" ######################################################################## # TLC diff --git a/doc/changelog/08-tools/10430-extraction-int63.rst b/doc/changelog/08-tools/10430-extraction-int63.rst new file mode 100644 index 0000000000..68ae4591a4 --- /dev/null +++ b/doc/changelog/08-tools/10430-extraction-int63.rst @@ -0,0 +1,5 @@ +- Fix extraction to OCaml of primitive machine integers; + see :ref:`primitive-integers` + (`#10430 <https://github.com/coq/coq/pull/10430>`_, + fixes `#10361 <https://github.com/coq/coq/issues/10361>`_, + by Vincent Laporte). diff --git a/doc/changelog/10-standard-library/09811-remove-zlogarithm.rst b/doc/changelog/10-standard-library/09811-remove-zlogarithm.rst new file mode 100644 index 0000000000..ab625b9e03 --- /dev/null +++ b/doc/changelog/10-standard-library/09811-remove-zlogarithm.rst @@ -0,0 +1,4 @@ +- Removes deprecated modules `Coq.ZArith.Zlogarithm` + and `Coq.ZArith.Zsqrt_compat` + (#9881 <https://github.com/coq/coq/pull/9811> + by Vincent Laporte). diff --git a/doc/changelog/10-standard-library/10445-constructive-reals.rst b/doc/changelog/10-standard-library/10445-constructive-reals.rst new file mode 100644 index 0000000000..d69056fc2f --- /dev/null +++ b/doc/changelog/10-standard-library/10445-constructive-reals.rst @@ -0,0 +1,12 @@ +- New module `Reals.ConstructiveCauchyReals` defines constructive real numbers + by Cauchy sequences of rational numbers. Classical real numbers are now defined + as a quotient of these constructive real numbers, which significantly reduces + the number of axioms needed (see `Reals.Rdefinitions` and `Reals.Raxioms`), + while preserving backward compatibility. + + Futhermore, the new axioms for classical real numbers include the limited + principle of omniscience (`sig_forall_dec`), which is a logical principle + instead of an ad hoc property of the real numbers. + + See `#10445 <https://github.com/coq/coq/pull/10445>`_, by Vincent Semeria, + with the help and review of Guillaume Melquiond and Bas Spitters. diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index d1b95e6203..ac75240cfb 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -7,22 +7,20 @@ The |Coq| library single: Theories -The |Coq| library is structured into two parts: +The |Coq| library has two parts: - * **The initial library**: it contains elementary logical notions and - data-types. It constitutes the basic state of the system directly - available when running |Coq|; + * **The basic library**: definitions and theorems for + the most commonly used elementary logical notions and + data types. |Coq| normally loads these files automatically when it starts. - * **The standard library**: general-purpose libraries containing various - developments of |Coq| axiomatizations about sets, lists, sorting, - arithmetic, etc. This library comes with the system and its modules - are directly accessible through the ``Require`` command (see - Section :ref:`compiled-files`); + * **The standard library**: general-purpose libraries with + definitions and theorems for sets, lists, sorting, + arithmetic, etc. To use these files, users must load them explicitly + with the ``Require`` command (see :ref:`compiled-files`) -In addition, user-provided libraries or developments are provided by -|Coq| users' community. These libraries and developments are available -for download at http://coq.inria.fr (see -Section :ref:`userscontributions`). +There are also many libraries provided by |Coq| users' community. +These libraries and developments are available +for download at http://coq.inria.fr (see :ref:`userscontributions`). This chapter briefly reviews the |Coq| libraries whose contents can also be browsed at http://coq.inria.fr/stdlib. @@ -514,8 +512,8 @@ realizability interpretation. forall (A B:Prop) (P:Type), (A -> B -> P) -> A /\ B -> P. -Basic Arithmetics -~~~~~~~~~~~~~~~~~ +Basic Arithmetic +~~~~~~~~~~~~~~~~ The basic library includes a few elementary properties of natural numbers, together with the definitions of predecessor, addition and @@ -804,8 +802,8 @@ Notation Interpretation =============== =================== -Notations for integer arithmetics -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notations for integer arithmetic +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. index:: single: Arithmetical notations @@ -822,7 +820,7 @@ Notations for integer arithmetics The following table describes the syntax of expressions -for integer arithmetics. It is provided by requiring and opening the module ``ZArith`` and opening scope ``Z_scope``. +for integer arithmetic. It is provided by requiring and opening the module ``ZArith`` and opening scope ``Z_scope``. It specifies how notations are interpreted and, when not already reserved, the precedence and associativity. @@ -866,7 +864,7 @@ Notations for real numbers This is provided by requiring and opening the module ``Reals`` and opening scope ``R_scope``. This set of notations is very similar to -the notation for integer arithmetics. The inverse function was added. +the notation for integer arithmetic. The inverse function was added. =============== =================== Notation Interpretation diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index c93984661e..dc4f91e66b 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -260,10 +260,7 @@ To eliminate the (co-)inductive type, one must use its defined primitive project For compatibility, the parameters still appear to the user when printing terms even though they are absent in the actual AST manipulated by the kernel. This can be changed by unsetting the -:flag:`Printing Primitive Projection Parameters` flag. Further compatibility -printing can be deactivated thanks to the ``Printing Primitive Projection -Compatibility`` option which governs the printing of pattern matching -over primitive records. +:flag:`Printing Primitive Projection Parameters` flag. There are currently two ways to introduce primitive records types: @@ -2443,12 +2440,19 @@ The reduction machines (:tacn:`vm_compute`, :tacn:`native_compute`) implement dedicated, efficient, rules to reduce the applications of these primitive operations. -These primitives, when extracted to OCaml (see :ref:`extraction`), are mapped to -types and functions of a :g:`Uint63` module. Said module is not produced by +The extraction of these primitives can be customized similarly to the extraction +of regular axioms (see :ref:`extraction`). Nonetheless, the :g:`ExtrOCamlInt63` +module can be used when extracting to OCaml: it maps the Coq primitives to types +and functions of a :g:`Uint63` module. Said OCaml module is not produced by extraction. Instead, it has to be provided by the user (if they want to compile or execute the extracted code). For instance, an implementation of this module can be taken from the kernel of Coq. +Literal values (at type :g:`Int63.int`) are extracted to literal OCaml values +wrapped into the :g:`Uint63.of_int` (resp. :g:`Uint63.of_int64`) constructor on +64-bit (resp. 32-bit) platforms. Currently, this cannot be customized (see the +function :g:`Uint63.compile` from the kernel). + Bidirectionality hints ---------------------- diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 38f6714f46..91dfa34494 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -44,78 +44,91 @@ Lexical conventions =================== Blanks - Space, newline and horizontal tabulation are considered as blanks. + Space, newline and horizontal tab are considered blanks. Blanks are ignored but they separate tokens. Comments - Comments in Coq are enclosed between ``(*`` and ``*)``, and can be nested. - They can contain any character. However, :token:`string` literals must be + Comments are enclosed between ``(*`` and ``*)``. They can be nested. + They can contain any character. However, embedded :token:`string` literals must be correctly closed. Comments are treated as blanks. -Identifiers and access identifiers +Identifiers and field identifiers Identifiers, written :token:`ident`, are sequences of letters, digits, ``_`` and - ``'``, that do not start with a digit or ``'``. That is, they are - recognized by the following lexical class: + ``'``, that do not start with a digit or ``'``. That is, they are + recognized by the following grammar (except that the string ``_`` is reserved; + it is not a valid identifier): .. productionlist:: coq - first_letter : a..z ∣ A..Z ∣ _ ∣ unicode-letter - subsequent_letter : a..z ∣ A..Z ∣ 0..9 ∣ _ ∣ ' ∣ unicode-letter ∣ unicode-id-part ident : `first_letter`[`subsequent_letter`…`subsequent_letter`] - access_ident : .`ident` + field : .`ident` + first_letter : a..z ∣ A..Z ∣ _ ∣ `unicode_letter` + subsequent_letter : `first_letter` ∣ 0..9 ∣ ' ∣ `unicode_id_part` All characters are meaningful. In particular, identifiers are case-sensitive. - The entry ``unicode-letter`` non-exhaustively includes Latin, + :production:`unicode_letter` non-exhaustively includes Latin, Greek, Gothic, Cyrillic, Arabic, Hebrew, Georgian, Hangul, Hiragana and Katakana characters, CJK ideographs, mathematical letter-like - symbols, hyphens, non-breaking space, … The entry ``unicode-id-part`` + symbols and non-breaking space. :production:`unicode_id_part` non-exhaustively includes symbols for prime letters and subscripts. - Access identifiers, written :token:`access_ident`, are identifiers prefixed by - `.` (dot) without blank. They are used in the syntax of qualified - identifiers. + Field identifiers, written :token:`field`, are identifiers prefixed by + `.` (dot) with no blank between the dot and the identifier. They are used in + the syntax of qualified identifiers. Numerals - Numerals are sequences of digits with a potential fractional part - and exponent. Integers are numerals without fractional nor exponent - part and optionally preceded by a minus sign. Underscores ``_`` can - be used as comments in numerals. + Numerals are sequences of digits with an optional fractional part + and exponent, optionally preceded by a minus sign. :token:`int` is an integer; + a numeral without fractional or exponent parts. :token:`num` is a non-negative + integer. Underscores embedded in the digits are ignored, for example + ``1_000_000`` is the same as ``1000000``. .. productionlist:: coq - digit : 0..9 + numeral : `num`[. `num`][`exp`[`sign`]`num`] + int : [-]`num` num : `digit`…`digit` - integer : [-]`num` - dot : . + digit : 0..9 exp : e | E sign : + | - - numeral : `num`[`dot` `num`][`exp`[`sign`]`num`] Strings - Strings are delimited by ``"`` (double quote), and enclose a sequence of - any characters different from ``"`` or the sequence ``""`` to denote the - double quote character. In grammars, the entry for quoted strings is - :production:`string`. + Strings begin and end with ``"`` (double quote). Use ``""`` to represent + a double quote character within a string. In the grammar, strings are + identified with :production:`string`. Keywords - The following identifiers are reserved keywords, and cannot be - employed otherwise:: - - _ as at cofix else end exists exists2 fix for - forall fun if IF in let match mod return - SProp Prop Set Type then using where with - -Special tokens - The following sequences of characters are special tokens:: - - ! % & && ( () ) * + ++ , - -> . .( .. - / /\ : :: :< := :> ; < <- <-> <: <= <> = - => =_D > >-> >= ? ?= @ [ \/ ] ^ { | |- - || } ~ #[ - - Lexical ambiguities are resolved according to the “longest match” - rule: when a sequence of non alphanumerical characters can be - decomposed into several different ways, then the first token is the - longest possible one (among all tokens defined at this moment), and so - on. + The following character sequences are reserved keywords that cannot be + used as identifiers:: + + _ Axiom CoFixpoint Definition Fixpoint Hypothesis IF Parameter Prop + SProp Set Theorem Type Variable as at by cofix discriminated else + end exists exists2 fix for forall fun if in lazymatch let match + multimatch return then using where with + + Note that plugins may define additional keywords when they are loaded. + +Other tokens + The set of + 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 + loaded automatically at startup time. + + Here are the character sequences that Coq directly defines as tokens + without using :cmd:`Notation` (omitting 25 specialized tokens that begin with + ``#int63_``):: + + ! #[ % & ' ( () (bfs) (dfs) ) * ** + , - -> + . .( .. ... / : ::= := :> :>> ; < <+ <- <: + <<: <= = => > >-> >= ? @ @{ [ [= ] _ _eqn + `( `{ { {| | |- || } + + When multiple tokens match the beginning of a sequence of characters, + the longest matching token is used. + Occasionally you may need to insert spaces to separate tokens. For example, + if ``~`` and ``~~`` are both defined as tokens, the inputs ``~ ~`` and + ``~~`` generate different tokens, whereas if `~~` is not defined, then the + two inputs are equivalent. .. _term: @@ -164,7 +177,7 @@ is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. : ( `name` [: `term`] := `term` ) : ' `pattern` name : `ident` | _ - qualid : `ident` | `qualid` `access_ident` + qualid : `ident` | `qualid` `field` sort : SProp | Prop | Set | Type fix_bodies : `fix_body` : `fix_body` with `fix_body` with … with `fix_body` for `ident` diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index efb5df720a..7d6171285e 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -88,8 +88,6 @@ There are other buttons on the |CoqIDE| toolbar: a button to save the running buffer; a button to close the current buffer (an "X"); buttons to switch among buffers (left and right arrows); an "information" button; and a "gears" button. -The "information" button is described in Section :ref:`try-tactics-automatically`. - The "gears" button submits proof terms to the |Coq| kernel for type checking. When |Coq| uses asynchronous processing (see Chapter :ref:`asynchronousandparallelproofprocessing`), proofs may have been completed without kernel-checking of generated proof terms. @@ -100,27 +98,6 @@ processed color, though their preceding proofs have the processed color. Notice that for all these buttons, except for the "gears" button, their operations are also available in the menu, where their keyboard shortcuts are given. -.. _try-tactics-automatically: - -Trying tactics automatically ------------------------------- - -The menu Try Tactics provides some features for automatically trying -to solve the current goal using simple tactics. If such a tactic -succeeds in solving the goal, then its text is automatically inserted -into the script. There is finally a combination of these tactics, -called the *proof wizard* which will try each of them in turn. This -wizard is also available as a tool button (the "information" button). The set of -tactics tried by the wizard is customizable in the preferences. - -These tactics are general ones, in particular they do not refer to -particular hypotheses. You may also try specific tactics related to -the goal or one of the hypotheses, by clicking with the right mouse -button on the goal or the considered hypothesis. This is the -“contextual menu on goals” feature, that may be disabled in the -preferences if undesirable. - - Proof folding ------------------ @@ -202,13 +179,6 @@ compilation, printing, web browsing. In the browser command, you may use `%s` to denote the URL to open, for example: `firefox -remote "OpenURL(%s)"`. -The `Tactics Wizard` section allows defining the set of tactics that -should be tried, in sequence, to solve the current goal. - -The last section is for miscellaneous boolean settings, such as the -“contextual menu on goals” feature presented in the section -:ref:`Try tactics automatically <try-tactics-automatically>`. - Notice that these settings are saved in the file `.coqiderc` of your home directory. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 46f9826e41..362c3da6cb 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -31,10 +31,10 @@ Syntax The syntax of the tactic language is given below. See Chapter :ref:`gallinaspecificationlanguage` for a description of the BNF metasyntax used in these grammar rules. Various already defined entries will be used in this -chapter: entries :token:`natural`, :token:`integer`, :token:`ident`, +chapter: entries :token:`num`, :token:`int`, :token:`ident` :token:`qualid`, :token:`term`, :token:`cpattern` and :token:`tactic` -represent respectively the natural and integer numbers, the authorized -identificators and qualified names, Coq terms and patterns and all the atomic +represent respectively natural and integer numbers, +identifiers, qualified names, Coq terms, patterns and the atomic tactics described in Chapter :ref:`tactics`. The syntax of :production:`cpattern` is @@ -141,10 +141,10 @@ mode but it can also be used in toplevel definitions as shown below. : `atom` atom : `qualid` : () - : `integer` + : `int` : ( `ltac_expr` ) component : `string` | `qualid` - message_token : `string` | `ident` | `integer` + message_token : `string` | `ident` | `int` tacarg : `qualid` : () : ltac : `atom` @@ -159,11 +159,11 @@ mode but it can also be used in toplevel definitions as shown below. match_rule : `cpattern` => `ltac_expr` : context [`ident`] [ `cpattern` ] => `ltac_expr` : _ => `ltac_expr` - test : `integer` = `integer` - : `integer` (< | <= | > | >=) `integer` + test : `int` = `int` + : `int` (< | <= | > | >=) `int` selector : [`ident`] - : `integer` - : (`integer` | `integer` - `integer`), ..., (`integer` | `integer` - `integer`) + : `int` + : (`int` | `int` - `int`), ..., (`int` | `int` - `int`) toplevel_selector : `selector` : all : par diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 3036648b08..c545287fdd 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -17,16 +17,16 @@ Coq, yet it is at the same time its Achilles' heel. Indeed, Ltac: - is error-prone and fragile - has an intricate implementation -Following the need of users that start developing huge projects relying +Following the need of users who are developing huge projects relying critically on Ltac, we believe that we should offer a proper modern language that features at least the following: - at least informal, predictable semantics -- a typing system -- standard programming facilities (i.e. datatypes) +- a type system +- standard programming facilities (e.g., datatypes) This new language, called Ltac2, is described in this chapter. It is still -experimental but we encourage nonetheless users to start testing it, +experimental but we nonetheless encourage users to start testing it, especially wherever an advanced tactic language is needed. The previous implementation of Ltac, described in the previous chapter, will be referred to as Ltac1. @@ -36,9 +36,9 @@ as Ltac1. General design -------------- -There are various alternatives to Ltac1, such that Mtac or Rtac for instance. -While those alternatives can be quite distinct from Ltac1, we designed -Ltac2 to be closest as reasonably possible to Ltac1, while fixing the +There are various alternatives to Ltac1, such as Mtac or Rtac for instance. +While those alternatives can be quite different from Ltac1, we designed +Ltac2 to be as close as reasonably possible to Ltac1, while fixing the aforementioned defects. In particular, Ltac2 is: @@ -47,11 +47,11 @@ In particular, Ltac2 is: * a call-by-value functional language * with effects - * together with Hindley-Milner type system + * together with the Hindley-Milner type system - a language featuring meta-programming facilities for the manipulation of Coq-side terms -- a language featuring notation facilities to help writing palatable scripts +- a language featuring notation facilities to help write palatable scripts We describe more in details each point in the remainder of this document. @@ -77,7 +77,7 @@ Sticking to a standard ML type system can be considered somewhat weak for a meta-language designed to manipulate Coq terms. In particular, there is no way to statically guarantee that a Coq term resulting from an Ltac2 computation will be well-typed. This is actually a design choice, motivated -by retro-compatibility with Ltac1. Instead, well-typedness is deferred to +by backward compatibility with Ltac1. Instead, well-typedness is deferred to dynamic checks, allowing many primitive functions to fail whenever they are provided with an ill-typed term. @@ -92,7 +92,7 @@ Type Syntax ~~~~~~~~~~~ At the level of terms, we simply elaborate on Ltac1 syntax, which is quite -close to e.g. the one of OCaml. Types follow the simply-typed syntax of OCaml. +close to OCaml. Types follow the simply-typed syntax of OCaml. The non-terminal :production:`lident` designates identifiers starting with a lowercase. @@ -122,7 +122,7 @@ Built-in types include: Type declarations ~~~~~~~~~~~~~~~~~ -One can define new types by the following commands. +One can define new types with the following commands. .. cmd:: Ltac2 Type {? @ltac2_typeparams } @lident :name: Ltac2 Type @@ -149,7 +149,7 @@ One can define new types by the following commands. Variants are sum types defined by constructors and eliminated by pattern-matching. They can be recursive, but the `rec` flag must be - explicitly set. Pattern-maching must be exhaustive. + explicitly set. Pattern matching must be exhaustive. Records are product types with named fields and eliminated by projection. Likewise they can be recursive if the `rec` flag is set. @@ -158,15 +158,15 @@ One can define new types by the following commands. Open variants are a special kind of variant types whose constructors are not statically defined, but can instead be extended dynamically. A typical example - is the standard `exn` type. Pattern-matching must always include a catch-all - clause. They can be extended by this command. + is the standard `exn` type. Pattern matching on open variants must always include a catch-all + clause. They can be extended with this command. Term Syntax ~~~~~~~~~~~ The syntax of the functional fragment is very close to the one of Ltac1, except that it adds a true pattern-matching feature, as well as a few standard -constructions from ML. +constructs from ML. .. productionlist:: coq ltac2_var : `lident` @@ -179,7 +179,7 @@ constructions from ML. : let `ltac2_var` := `ltac2_term` in `ltac2_term` : let rec `ltac2_var` := `ltac2_term` in `ltac2_term` : match `ltac2_term` with `ltac2_branch` ... `ltac2_branch` end - : `integer` + : `int` : `string` : `ltac2_term` ; `ltac2_term` : [| `ltac2_term` ; ... ; `ltac2_term` |] @@ -202,7 +202,7 @@ constructions from ML. In practice, there is some additional syntactic sugar that allows e.g. to bind a variable and match on it at the same time, in the usual ML style. -There is a dedicated syntax for list and array literals. +There is dedicated syntax for list and array literals. .. note:: @@ -217,7 +217,7 @@ Ltac Definitions This command defines a new global Ltac2 value. For semantic reasons, the body of the Ltac2 definition must be a syntactical - value, i.e. a function, a constant or a pure constructor recursively applied to + value, that is, a function, a constant or a pure constructor recursively applied to values. If ``rec`` is set, the tactic is expanded into a recursive binding. @@ -247,7 +247,7 @@ if ever we implement native compilation. The expected equations are as follows:: (t any term, V values, C constructor) Note that call-by-value reduction is already a departure from Ltac1 which uses -heuristics to decide when evaluating an expression. For instance, the following +heuristics to decide when to evaluate an expression. For instance, the following expressions do not evaluate the same way in Ltac1. :n:`foo (idtac; let x := 0 in bar)` @@ -255,7 +255,7 @@ expressions do not evaluate the same way in Ltac1. :n:`foo (let x := 0 in bar)` Instead of relying on the :n:`idtac` idiom, we would now require an explicit thunk -not to compute the argument, and :n:`foo` would have e.g. type +to not compute the argument, and :n:`foo` would have e.g. type :n:`(unit -> unit) -> unit`. :n:`foo (fun () => let x := 0 in bar)` @@ -263,19 +263,19 @@ not to compute the argument, and :n:`foo` would have e.g. type Typing ~~~~~~ -Typing is strict and follows Hindley-Milner system. Unlike Ltac1, there +Typing is strict and follows the Hindley-Milner system. Unlike Ltac1, there are no type casts at runtime, and one has to resort to conversion functions. See notations though to make things more palatable. -In this setting, all usual argument-free tactics have type :n:`unit -> unit`, but -one can return as well a value of type :n:`t` thanks to terms of type :n:`unit -> t`, +In this setting, all the usual argument-free tactics have type :n:`unit -> unit`, but +one can return a value of type :n:`t` thanks to terms of type :n:`unit -> t`, or take additional arguments. Effects ~~~~~~~ Effects in Ltac2 are straightforward, except that instead of using the -standard IO monad as the ambient effectful world, Ltac2 is going to use the +standard IO monad as the ambient effectful world, Ltac2 is has a tactic monad. Note that the order of evaluation of application is *not* specified and is @@ -288,15 +288,15 @@ Intuitively a thunk of type :n:`unit -> 'a` can do the following: - It can perform non-backtracking IO like printing and setting mutable variables - It can fail in a non-recoverable way -- It can use first-class backtrack. The proper way to figure that is that we - morally have the following isomorphism: +- It can use first-class backtracking. One way to think about this is that + thunks are isomorphic to this type: :n:`(unit -> 'a) ~ (unit -> exn + ('a * (exn -> 'a)))` i.e. thunks can produce a lazy list of results where each tail is waiting for a continuation exception. -- It can access a backtracking proof state, made out amongst other things of +- It can access a backtracking proof state, consisting among other things of the current evar assignation and the list of goals under focus. -We describe more thoroughly the various effects existing in Ltac2 hereafter. +We now describe more thoroughly the various effects in Ltac2. Standard IO +++++++++++ @@ -315,28 +315,28 @@ Fatal errors ++++++++++++ The Ltac2 language provides non-backtracking exceptions, also known as *panics*, -through the following primitive in module `Control`.:: +through the following primitive in module `Control`:: val throw : exn -> 'a Unlike backtracking exceptions from the next section, this kind of error is never caught by backtracking primitives, that is, throwing an exception -destroys the stack. This is materialized by the following equation, where `E` -is an evaluation context.:: +destroys the stack. This is codified by the following equation, where `E` +is an evaluation context:: E[throw e] ≡ throw e (e value) -There is currently no way to catch such an exception and it is a design choice. -There might be at some future point a way to catch it in a brutal way, -destroying all backtrack and return values. +There is currently no way to catch such an exception, which is a deliberate design choice. +Eventually there might be a way to catch it and +destroy all backtrack and return values. -Backtrack -+++++++++ +Backtracking +++++++++++++ In Ltac2, we have the following backtracking primitives, defined in the -`Control` module.:: +`Control` module:: Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. @@ -344,7 +344,7 @@ In Ltac2, we have the following backtracking primitives, defined in the val plus : (unit -> 'a) -> (exn -> 'a) -> 'a val case : (unit -> 'a) -> ('a * (exn -> 'a)) result -If one sees thunks as lazy lists, then `zero` is the empty list and `plus` is +If one views thunks as lazy lists, then `zero` is the empty list and `plus` is list concatenation, while `case` is pattern-matching. The backtracking is first-class, i.e. one can write @@ -376,8 +376,8 @@ represent several goals, including none. Thus, there is no such thing as *the current goal*. Goals are naturally ordered, though. It is natural to do the same in Ltac2, but we must provide a way to get access -to a given goal. This is the role of the `enter` primitive, that applies a -tactic to each currently focused goal in turn.:: +to a given goal. This is the role of the `enter` primitive, which applies a +tactic to each currently focused goal in turn:: val enter : (unit -> unit) -> unit @@ -452,9 +452,9 @@ The following syntactic sugar is provided for two common cases. Strict vs. non-strict mode ++++++++++++++++++++++++++ -Depending on the context, quotations producing terms (i.e. ``constr`` or +Depending on the context, quotation-producing terms (i.e. ``constr`` or ``open_constr``) are not internalized in the same way. There are two possible -modes, respectively called the *strict* and the *non-strict* mode. +modes, the *strict* and the *non-strict* mode. - In strict mode, all simple identifiers appearing in a term quotation are required to be resolvable statically. That is, they must be the short name of @@ -467,7 +467,7 @@ modes, respectively called the *strict* and the *non-strict* mode. of the term at runtime will fail if there is no such variable in the dynamic context. -Strict mode is enforced by default, e.g. for all Ltac2 definitions. Non-strict +Strict mode is enforced by default, such as for all Ltac2 definitions. Non-strict mode is only set when evaluating Ltac2 snippets in interactive proof mode. The rationale is that it is cumbersome to explicitly add ``&`` interactively, while it is expected that global tactics enforce more invariants on their code. @@ -490,12 +490,12 @@ for their side-effects. Semantics +++++++++ -Interpretation of a quoted Coq term is done in two phases, internalization and +A quoted Coq term is interpreted in two phases, internalization and evaluation. -- Internalization is part of the static semantics, i.e. it is done at Ltac2 +- Internalization is part of the static semantics, that is, it is done at Ltac2 typing time. -- Evaluation is part of the dynamic semantics, i.e. it is done when +- Evaluation is part of the dynamic semantics, that is, it is done when a term gets effectively computed by Ltac2. Note that typing of Coq terms is a *dynamic* process occurring at Ltac2 @@ -670,9 +670,9 @@ A scope is a name given to a grammar entry used to produce some Ltac2 expression at parsing time. Scopes are described using a form of S-expression. .. prodn:: - ltac2_scope ::= {| @string | @integer | @lident ({+, @ltac2_scope}) } + ltac2_scope ::= {| @string | @int | @lident ({+, @ltac2_scope}) } -A few scopes contain antiquotation features. For sake of uniformity, all +A few scopes contain antiquotation features. For the sake of uniformity, all antiquotations are introduced by the syntax :n:`$@lident`. The following scopes are built-in. @@ -713,15 +713,15 @@ The following scopes are built-in. - :n:`self`: - + parses a Ltac2 expression at the current level and return it as is. + + parses a Ltac2 expression at the current level and returns it as is. - :n:`next`: - + parses a Ltac2 expression at the next level and return it as is. + + parses a Ltac2 expression at the next level and returns it as is. -- :n:`tactic(n = @integer)`: +- :n:`tactic(n = @int)`: - + parses a Ltac2 expression at the provided level :n:`n` and return it as is. + + parses a Ltac2 expression at the provided level :n:`n` and returns it as is. - :n:`thunk(@ltac2_scope)`: @@ -747,7 +747,7 @@ The following scopes are built-in. out of the parsed values in the same order. As an optimization, all subscopes of the form :n:`STRING` are left out of the returned tuple, instead of returning a useless unit value. It is forbidden for the various - subscopes to refer to the global entry using self or next. + subscopes to refer to the global entry using :n:`self` or :n:`next`. A few other specific scopes exist to handle Ltac1-like syntax, but their use is discouraged and they are thus not documented. @@ -758,9 +758,9 @@ planned. Notations ~~~~~~~~~ -The Ltac2 parser can be extended by syntactic notations. +The Ltac2 parser can be extended with syntactic notations. -.. cmd:: Ltac2 Notation {+ {| @lident (@ltac2_scope) | @string } } {? : @integer} := @ltac2_term +.. cmd:: Ltac2 Notation {+ {| @lident (@ltac2_scope) | @string } } {? : @int} := @ltac2_term :name: Ltac2 Notation A Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded @@ -793,10 +793,10 @@ Abbreviations .. cmdv:: Ltac2 Notation @lident := @ltac2_term - This command introduces a special kind of notations, called abbreviations, + This command introduces a special kind of notation, called an abbreviation, that is designed so that it does not add any parsing rules. It is similar in spirit to Coq abbreviations, insofar as its main purpose is to give an - absolute name to a piece of pure syntax, which can be transparently referred + absolute name to a piece of pure syntax, which can be transparently referred to by this name as if it were a proper definition. The abbreviation can then be manipulated just as a normal Ltac2 definition, @@ -851,7 +851,7 @@ corresponding code for its side effects. In particular, it cannot return values, and the quotation has type :n:`unit`. Ltac1 **cannot** implicitly access variables from the Ltac2 scope, but this can -be done via an explicit annotation to the :n:`ltac1` quotation. +be done with an explicit annotation on the :n:`ltac1` quotation. .. productionlist:: coq ltac2_term : ltac1 : ( `ident` ... `ident` |- `ltac_expr` ) @@ -888,7 +888,7 @@ 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, she has to resort to the good old +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. @@ -923,8 +923,8 @@ Due to conflicts, a few syntactic rules have changed. - The dispatch tactical :n:`tac; [foo|bar]` is now written :n:`tac > [foo|bar]`. - Levels of a few operators have been revised. Some tacticals now parse as if - they were a normal function, i.e. one has to put parentheses around the - argument when it is complex, e.g an abstraction. List of affected tacticals: + they were normal functions. Parentheses are now required around complex + arguments, such as abstractions. The tacticals affected are: :n:`try`, :n:`repeat`, :n:`do`, :n:`once`, :n:`progress`, :n:`time`, :n:`abstract`. - :n:`idtac` is no more. Either use :n:`()` if you expect nothing to happen, :n:`(fun () => ())` if you want a thunk (see next section), or use printing @@ -1010,4 +1010,4 @@ Exception catching Ltac2 features a proper exception-catching mechanism. For this reason, the Ltac1 mechanism relying on `fail` taking integers, and tacticals decreasing it, has been removed. Now exceptions are preserved by all tacticals, and it is -your duty to catch them and reraise them depending on your use. +your duty to catch them and re-raise them as needed. diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 5f3e82938d..774732825a 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -870,26 +870,6 @@ interactively, they cannot be part of a vernacular file loaded via have to undo some extra commands and end on a state :n:`@num′ ≤ @num` if necessary. - .. cmdv:: Backtrack @num @num @num - :name: Backtrack - - .. deprecated:: 8.4 - - :cmd:`Backtrack` is a *deprecated* form of - :cmd:`BackTo` which allows explicitly manipulating the proof environment. The - three numbers represent the following: - - + *first number* : State label to reach, as for :cmd:`BackTo`. - + *second number* : *Proof state number* to unbury once aborts have been done. - |Coq| will compute the number of :cmd:`Undo` to perform (see Chapter :ref:`proofhandling`). - + *third number* : Number of :cmd:`Abort` to perform, i.e. the number of currently - opened nested proofs that must be canceled (see Chapter :ref:`proofhandling`). - - .. exn:: Invalid backtrack. - - The destination state label is unknown. - - .. _quitting-and-debugging: Quitting and debugging diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index b25104ddb9..46175e37ed 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -12,6 +12,7 @@ plugins/extraction/ExtrHaskellZInteger.v plugins/extraction/ExtrHaskellZNum.v plugins/extraction/ExtrOcamlBasic.v plugins/extraction/ExtrOcamlBigIntConv.v +plugins/extraction/ExtrOCamlInt63.v plugins/extraction/ExtrOcamlIntConv.v plugins/extraction/ExtrOcamlNatBigInt.v plugins/extraction/ExtrOcamlNatInt.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index a561de1d0c..dcfe4a08f3 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -181,14 +181,12 @@ through the <tt>Require Import</tt> command.</p> theories/ZArith/Zhints.v (theories/ZArith/ZArith_base.v) theories/ZArith/Zcomplements.v - theories/ZArith/Zsqrt_compat.v theories/ZArith/Zpow_def.v theories/ZArith/Zpow_alt.v theories/ZArith/Zpower.v theories/ZArith/Zdiv.v theories/ZArith/Zquot.v theories/ZArith/Zeuclid.v - theories/ZArith/Zlogarithm.v (theories/ZArith/ZArith.v) theories/ZArith/Zgcd_alt.v theories/ZArith/Zwf.v @@ -516,7 +514,9 @@ through the <tt>Require Import</tt> command.</p> </dt> <dd> theories/Reals/Rdefinitions.v + theories/Reals/ConstructiveCauchyReals.v theories/Reals/Raxioms.v + theories/Reals/ConstructiveRIneq.v theories/Reals/RIneq.v theories/Reals/DiscrR.v theories/Reals/ROrderedType.v @@ -561,6 +561,7 @@ through the <tt>Require Import</tt> command.</p> theories/Reals/Ranalysis5.v theories/Reals/Ranalysis_reg.v theories/Reals/Rcomplete.v + theories/Reals/ConstructiveRcomplete.v theories/Reals/RiemannInt.v theories/Reals/RiemannInt_SF.v theories/Reals/Rpow_def.v diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 9f0a1942f9..eb86bab37e 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -1020,6 +1020,37 @@ let apply_edit_file g edits = in List.rev (List.concat (List.map traverse prod)) + (* get the special tokens in the grammar *) +let print_special_tokens g = + let rec traverse set = function + | Sterm s -> + let c = s.[0] in + if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') then set + else StringSet.add s set + | Snterm s -> set + | Slist1 sym + | Slist0 sym + | Sopt sym + -> traverse set sym + | Slist1sep (sym, sep) + | Slist0sep (sym, sep) + -> traverse (traverse set sym) sep + | Sparen sym_list -> traverse_prod set sym_list + | Sprod sym_list_list -> traverse_prods set sym_list_list + | Sedit _ + | Sedit2 _ -> set + and traverse_prod set prod = List.fold_left traverse set prod + and traverse_prods set prods = List.fold_left traverse_prod set prods + in + let spec_toks = List.fold_left (fun set b -> + let nt, prods = b in + traverse_prods set prods) + StringSet.empty (NTMap.bindings !g.map) + in + Printf.printf "Special tokens:"; + StringSet.iter (fun t -> Printf.printf " %s" t) spec_toks; + Printf.printf "\n\n" + (* get the transitive closure of a non-terminal excluding "stops" symbols. Preserve ordering to the extent possible *) (* todo: at the moment, the code doesn't use the ordering; consider switching to using @@ -1099,8 +1130,9 @@ let print_chunks g out fmt () = (*seen := StringSet.diff !seen (StringSet.of_list ssr_tops);*) (*print_chunk out g seen fmt "vernac_toplevel" ["vernac_toplevel"] [];*) -let start_symbols = ["vernac_toplevel"; "tactic_mode"] -let tokens = [ "BULLET"; "FIELD"; "IDENT"; "NUMERAL"; "STRING" ] (* don't report as undefined *) +let start_symbols = ["vernac_toplevel"] +(* don't report tokens as undefined *) +let tokens = [ "bullet"; "field"; "ident"; "int"; "num"; "numeral"; "string" ] let report_bad_nts g file = let rec get_nts refd defd bindings = @@ -1468,6 +1500,8 @@ let process_grammar args = print_in_order out g `MLG !g.order StringSet.empty; close_out out; finish_with_file (dir "fullGrammar") args.verify; + if args.verbose then + print_special_tokens g; if not args.fullGrammar then begin (* do shared edits *) diff --git a/ide/MacOS/default_accel_map b/ide/MacOS/default_accel_map index 54a592a04d..6bcf3b438f 100644 --- a/ide/MacOS/default_accel_map +++ b/ide/MacOS/default_accel_map @@ -7,7 +7,6 @@ ; (gtk_accel_path "<Actions>/Templates/Template Program Lemma" "") (gtk_accel_path "<Actions>/Templates/Lemma" "<Shift><Primary>l") ; (gtk_accel_path "<Actions>/Templates/Template Fact" "") -(gtk_accel_path "<Actions>/Tactics/auto" "<Primary><Control>a") ; (gtk_accel_path "<Actions>/Tactics/Tactic fold" "") ; (gtk_accel_path "<Actions>/Help/About Coq" "") ; (gtk_accel_path "<Actions>/Templates/Template Add Ring A Aplus Amult Aone Azero Ainv Aeq T [ c1 ... cn ]. " "") @@ -19,7 +18,6 @@ ; (gtk_accel_path "<Actions>/Tactics/Tactic inversion" "") ; (gtk_accel_path "<Actions>/Templates/Template Write State" "") ; (gtk_accel_path "<Actions>/Export/Export to" "") -(gtk_accel_path "<Actions>/Tactics/auto with *" "<Primary><Control>asterisk") ; (gtk_accel_path "<Actions>/Tactics/Tactic inversion--clear" "") ; (gtk_accel_path "<Actions>/Templates/Template Implicit Arguments" "") ; (gtk_accel_path "<Actions>/Edit/Copy" "<Primary>c") @@ -50,7 +48,6 @@ ; (gtk_accel_path "<Actions>/Tactics/Tactic fail" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic left" "") (gtk_accel_path "<Actions>/Edit/Undo" "<Primary>u") -(gtk_accel_path "<Actions>/Tactics/eauto with *" "<Primary><Control>ampersand") ; (gtk_accel_path "<Actions>/Templates/Template Infix" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic functional induction" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic clear" "") @@ -149,7 +146,6 @@ (gtk_accel_path "<Actions>/Templates/Theorem" "<Shift><Primary>t") ; (gtk_accel_path "<Actions>/Templates/Template Derive Dependent Inversion--clear" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic unfold" "") -; (gtk_accel_path "<Actions>/Tactics/Try Tactics" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic red in" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite <- -- in" "") ; (gtk_accel_path "<Actions>/Templates/Template Hint Extern" "") @@ -187,7 +183,6 @@ ; (gtk_accel_path "<Actions>/Tactics/Tactic intro -- after" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic fold -- in" "") ; (gtk_accel_path "<Actions>/Templates/Template Program Definition" "") -(gtk_accel_path "<Actions>/Tactics/Wizard" "<Primary><Control>dollar") ; (gtk_accel_path "<Actions>/Templates/Template Hint Resolve" "") ; (gtk_accel_path "<Actions>/Templates/Template Set Extraction Optimize" "") ; (gtk_accel_path "<Actions>/File/Revert all buffers" "") @@ -228,7 +223,6 @@ ; (gtk_accel_path "<Actions>/Export/Html" "") ; (gtk_accel_path "<Actions>/Templates/Template Extraction Inline" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic absurd" "") -(gtk_accel_path "<Actions>/Tactics/intuition" "<Primary><Control>i") ; (gtk_accel_path "<Actions>/Tactics/Tactic simple induction" "") ; (gtk_accel_path "<Actions>/Queries/Queries" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite -- in" "") @@ -289,7 +283,6 @@ ; (gtk_accel_path "<Actions>/Templates/Template Add Field" "") ; (gtk_accel_path "<Actions>/Templates/Template Require Export" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite <-" "") -(gtk_accel_path "<Actions>/Tactics/omega" "<Primary><Control>o") ; (gtk_accel_path "<Actions>/Tactics/Tactic split" "") ; (gtk_accel_path "<Actions>/File/Quit" "<Primary>q") (gtk_accel_path "<Actions>/View/Display existential variable instances" "<Shift><Control>e") @@ -328,7 +321,6 @@ ; (gtk_accel_path "<Actions>/Edit/Edit" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic firstorder" "") ; (gtk_accel_path "<Actions>/Templates/Template C" "") -(gtk_accel_path "<Actions>/Tactics/simpl" "<Primary><Control>s") ; (gtk_accel_path "<Actions>/Tactics/Tactic replace -- with" "") ; (gtk_accel_path "<Actions>/Templates/Template A" "") ; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Record" "") @@ -360,13 +352,11 @@ ; (gtk_accel_path "<Actions>/File/File" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic setoid--replace" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic generalize dependent" "") -(gtk_accel_path "<Actions>/Tactics/trivial" "<Primary><Control>v") ; (gtk_accel_path "<Actions>/Tactics/Tactic fix -- with" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic pose --:=--)" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic auto with" "") ; (gtk_accel_path "<Actions>/Templates/Template Add Printing Record" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- in" "") -(gtk_accel_path "<Actions>/Tactics/eauto" "<Primary><Control>e") ; (gtk_accel_path "<Actions>/File/Open" "<Primary>o") ; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- using" "") ; (gtk_accel_path "<Actions>/Templates/Template Hint" "") diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 566654218d..d52f038f1f 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -137,7 +137,6 @@ class type ops = object method go_to_insert : unit task method go_to_mark : GText.mark -> unit task - method tactic_wizard : string list -> unit task method process_next_phrase : unit task method process_until_end_or_error : unit task method handle_reset_initial : unit task @@ -806,48 +805,6 @@ object(self) else Coq.seq (self#backtrack_to_iter ~move_insert:false point) (Coq.lift (fun () -> Sentence.tag_on_insert buffer))) - method tactic_wizard l = - let insert_phrase phrase tag = - let stop = self#get_start_of_input in - let phrase' = if stop#starts_line then phrase else "\n"^phrase in - buffer#insert ~iter:stop phrase'; - Sentence.tag_on_insert buffer; - let start = self#get_start_of_input in - buffer#move_mark ~where:stop (`NAME "start_of_input"); - buffer#apply_tag tag ~start ~stop; - if self#get_insert#compare stop <= 0 then - buffer#place_cursor ~where:stop; - let sentence = - mk_sentence - ~start:(`MARK (buffer#create_mark start)) - ~stop:(`MARK (buffer#create_mark stop)) - [] in - Doc.push document sentence; - messages#default_route#clear; - self#show_goals - in - let display_error (loc, s) = - messages#default_route#add (Ideutils.validate s) in - let try_phrase phrase stop more = - let action = log "Sending to coq now" in - let route_id = 0 in - let query = Coq.query (route_id,(phrase,Stateid.dummy)) in - let next = function - | Fail (_, l, str) -> (* FIXME: check *) - display_error (l, str); - messages#default_route#add (Pp.str ("Unsuccessfully tried: "^phrase)); - more - | Good () -> stop Tags.Script.processed - in - Coq.bind (Coq.seq action query) next - in - let rec loop l = match l with - | [] -> Coq.return () - | p :: l' -> - try_phrase ("progress "^p^".") (insert_phrase (p^".")) (loop l') - in - loop l - method handle_reset_initial = let action () = (* clear the stack *) diff --git a/ide/coqOps.mli b/ide/coqOps.mli index 83ad8c15dc..1e8d87bb15 100644 --- a/ide/coqOps.mli +++ b/ide/coqOps.mli @@ -15,7 +15,6 @@ class type ops = object method go_to_insert : unit task method go_to_mark : GText.mark -> unit task - method tactic_wizard : string list -> unit task method process_next_phrase : unit task method process_until_end_or_error : unit task method handle_reset_initial : unit task diff --git a/ide/coqide.ml b/ide/coqide.ml index a22c51d36d..9cdfd0dc21 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -609,9 +609,6 @@ module Nav = struct let join_document _ = send_to_coq (fun sn -> sn.coqops#join_document) end -let tactic_wizard_callback l _ = - send_to_coq (fun sn -> sn.coqops#tactic_wizard l) - let printopts_callback opts v = let b = v#get_active in let () = List.iter (fun o -> Coq.PrintOpt.set o b) opts in @@ -887,10 +884,20 @@ let no_under = Util.String.map (fun x -> if x = '_' then '-' else x) let alpha_items menu_name item_name l = let mk_item text = let text' = - let last = String.length text - 1 in - if text.[last] = '.' - then text ^"\n" - else text ^" " + let len = String.length text in + let buf = Buffer.create (len + 1) in + let escaped = ref false in + String.iter (fun c -> + if !escaped then + let () = Buffer.add_char buf c in + escaped := false + else if c = '_' then escaped := true + else Buffer.add_char buf c + ) text; + if text.[len - 1] = '.' + then Buffer.add_char buf '\n' + else Buffer.add_char buf ' '; + Buffer.contents buf in let callback _ = on_current_term (fun sn -> sn.buffer#insert_interactive text') @@ -1112,25 +1119,8 @@ let build_ui () = ("Force", "_Force", `EXECUTE, Nav.join_document, "Fully check the document", "f"); ] end; - let tacitem s sc = - item s ~label:("_"^s) - ~accel:(modifier_for_tactics#get^sc) - ~callback:(tactic_wizard_callback [s]) - in menu tactics_menu [ - item "Try Tactics" ~label:"_Try Tactics"; - item "Wizard" ~label:"<Proof Wizard>" ~stock:`DIALOG_INFO - ~tooltip:"Proof Wizard" ~accel:(modifier_for_tactics#get^"dollar") - ~callback:(tactic_wizard_callback automatic_tactics#get); - tacitem "auto" "a"; - tacitem "auto with *" "asterisk"; - tacitem "eauto" "e"; - tacitem "eauto with *" "ampersand"; - tacitem "intuition" "i"; - tacitem "omega" "o"; - tacitem "simpl" "s"; - tacitem "tauto" "p"; - tacitem "trivial" "v"; + item "Tactics" ~label:"_Tactics"; ]; alpha_items tactics_menu "Tactic" Coq_commands.tactics; diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index d4a339f4f5..452808490d 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -100,18 +100,7 @@ let init () = \n <menuitem action='Previous' />\ \n <menuitem action='Next' />\ \n </menu>\ -\n <menu action='Try Tactics'>\ -\n <menuitem action='auto' />\ -\n <menuitem action='auto with *' />\ -\n <menuitem action='eauto' />\ -\n <menuitem action='eauto with *' />\ -\n <menuitem action='intuition' />\ -\n <menuitem action='omega' />\ -\n <menuitem action='simpl' />\ -\n <menuitem action='tauto' />\ -\n <menuitem action='trivial' />\ -\n <menuitem action='Wizard' />\ -\n <separator />\ +\n <menu action='Tactics'>\ \n %s\ \n </menu>\ \n <menu action='Templates'>\ @@ -173,7 +162,6 @@ let init () = \n <toolitem action='Interrupt' />\ \n <toolitem action='Previous' />\ \n <toolitem action='Next' />\ -\n <toolitem action='Wizard' />\ \n</toolbar>\ \n</ui>" (if Coq_config.gtk_platform <> `QUARTZ then "<menuitem action='Quit' />" else "") diff --git a/ide/preferences.ml b/ide/preferences.ml index ea0495bb19..bf9fe8922a 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -938,16 +938,6 @@ let configure ?(apply=(fun () -> ())) parent = else cmd_browse#get]) cmd_browse#get in -(* - let automatic_tactics = - strings - ~f:automatic_tactics#set - ~add:(fun () -> ["<edit me>"]) - "Wizard tactics to try in order" - automatic_tactics#get - - in -*) let contextual_menus_on_goal = pbool "Contextual menus on goal" contextual_menus_on_goal in @@ -1008,10 +998,6 @@ let configure ?(apply=(fun () -> ())) parent = Section("Externals", None, [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;cmd_editor;cmd_browse]); -(* - Section("Tactics Wizard", None, - [automatic_tactics]); -*) Section("Shortcuts", Some `PREFERENCES, [modifiers_valid; modifier_for_tactics; modifier_for_templates; modifier_for_display; modifier_for_navigation; diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index 1fdafc9d8f..9fbd3f83d8 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -111,51 +111,26 @@ value uint63_mulc(value x, value y, value* h) { #define le128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_leq(xl,yl))) #define maxuint63 ((uint64_t)0x7FFFFFFFFFFFFFFF) -/* precondition: y <> 0 */ -/* outputs r and sets ql to q % 2^63 s.t. x = q * y + r, r < y */ +/* precondition: xh < y */ +/* outputs r and sets ql to q s.t. x = q * y + r, r < y */ static value uint63_div21_aux(value xh, value xl, value y, value* ql) { - xh = uint63_of_value(xh); - xl = uint63_of_value(xl); + uint64_t nh = uint63_of_value(xh); + uint64_t nl = uint63_of_value(xl); y = uint63_of_value(y); - uint64_t maskh = 0; - uint64_t maskl = 1; - uint64_t dh = 0; - uint64_t dl = y; - int cmp = 1; - /* int n = 0 */ - /* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0, d < 2^(2*63) */ - while (!(dh >> (63 - 1)) && cmp) { - dh = (dh << 1) | (dl >> (63 - 1)); - dl = (dl << 1) & maxuint63; - maskh = (maskh << 1) | (maskl >> (63 - 1)); - maskl = (maskl << 1) & maxuint63; - /* ++n */ - cmp = lt128(dh,dl,xh,xl); + uint64_t q = 0; + for (int i = 0; i < 63; ++i) { + // invariants: 0 <= nh < y, nl = (xl*2^i) % 2^64, + // (q*y + nh) * 2^(63-i) + (xl % 2^(63-i)) = (xh%y) * 2^63 + xl + nl <<= 1; + nh = (nh << 1) | (nl >> 63); + q <<= 1; + if (nh >= y) { q |= 1; nh -= y; } } - uint64_t remh = xh; - uint64_t reml = xl; - /* uint64_t quotienth = 0; */ - uint64_t quotientl = 0; - /* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, - mask = floor(2^n), d = mask * y, n >= -1 */ - while (maskh | maskl) { - if (le128(dh,dl,remh,reml)) { /* if rem >= d, add one bit and subtract d */ - /* quotienth = quotienth | maskh */ - quotientl = quotientl | maskl; - remh = (uint63_lt(reml,dl)) ? (remh - dh - 1) : (remh - dh); - reml = reml - dl; - } - maskl = (maskl >> 1) | ((maskh << (63 - 1)) & maxuint63); - maskh = maskh >> 1; - dl = (dl >> 1) | ((dh << (63 - 1)) & maxuint63); - dh = dh >> 1; - /* decr n */ - } - *ql = Val_int(quotientl); - return Val_int(reml); + *ql = Val_int(q); + return Val_int(nh); } value uint63_div21(value xh, value xl, value y, value* ql) { - if (uint63_of_value(y) == 0) { + if (uint63_leq(y, xh)) { *ql = Val_int(0); return Val_int(0); } else { diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 1cc3dc3975..3fd613e905 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -1075,7 +1075,7 @@ module FNativeEntries = let mkInt env i = check_int env; - { mark = mark Norm KnownR; term = FInt i } + { mark = mark Cstr KnownR; term = FInt i } let mkBool env b = check_bool env; diff --git a/kernel/uint63.mli b/kernel/uint63.mli index 93632da110..5542716af2 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -37,6 +37,8 @@ val mul : t -> t -> t val div : t -> t -> t val rem : t -> t -> t +val diveucl : t -> t -> t * t + (* Specific arithmetic operations *) val mulc : t -> t -> t * t val addmuldiv : t -> t -> t -> t @@ -57,3 +59,13 @@ val head0 : t -> t val tail0 : t -> t val is_uint63 : Obj.t -> bool + +(* Arithmetic with explicit carries *) + +(* Analog of Numbers.Abstract.Cyclic.carry *) +type 'a carry = C0 of 'a | C1 of 'a + +val addc : t -> t -> t carry +val addcarryc : t -> t -> t carry +val subc : t -> t -> t carry +val subcarryc : t -> t -> t carry diff --git a/kernel/uint63_amd64_63.ml b/kernel/uint63_amd64_63.ml index 20b2f58496..5c4028e1c8 100644 --- a/kernel/uint63_amd64_63.ml +++ b/kernel/uint63_amd64_63.ml @@ -82,6 +82,8 @@ let div (x : int) (y : int) = let rem (x : int) (y : int) = if y = 0 then 0 else Int64.to_int (Int64.rem (to_uint64 x) (to_uint64 y)) +let diveucl x y = (div x y, rem x y) + let addmuldiv p x y = l_or (l_sl x p) (l_sr y (uint_size - p)) @@ -94,55 +96,32 @@ let le (x : int) (y : int) = (x lxor 0x4000000000000000) <= (y lxor 0x4000000000000000) [@@ocaml.inline always] -(* A few helper functions on 128 bits *) -let lt128 xh xl yh yl = - lt xh yh || (xh = yh && lt xl yl) - -let le128 xh xl yh yl = - lt xh yh || (xh = yh && le xl yl) - (* division of two numbers by one *) -(* precondition: y <> 0 *) -(* outputs: q % 2^63, r s.t. x = q * y + r, r < y *) +(* precondition: xh < y *) +(* outputs: q, r s.t. x = q * y + r, r < y *) let div21 xh xl y = - let maskh = ref 0 in - let maskl = ref 1 in - let dh = ref 0 in - let dl = ref y in - let cmp = ref true in - (* n = ref 0 *) - (* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0 *) - while !dh >= 0 && !cmp do (* dh >= 0 tests that dh highest bit is zero *) - (* We don't use addmuldiv below to avoid checks on 1 *) - dh := (!dh lsl 1) lor (!dl lsr (uint_size - 1)); - dl := !dl lsl 1; - maskh := (!maskh lsl 1) lor (!maskl lsr (uint_size - 1)); - maskl := !maskl lsl 1; - (* incr n *) - cmp := lt128 !dh !dl xh xl; - done; (* mask = 2^n, d = 2^n * y, 2 * d > x *) - let remh = ref xh in - let reml = ref xl in - (* quotienth = ref 0 *) - let quotientl = ref 0 in - (* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, - mask = floor(2^n), d = mask * y, n >= -1 *) - while !maskh lor !maskl <> 0 do - if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) - (* quotienth := !quotienth lor !maskh *) - quotientl := !quotientl lor !maskl; - remh := if lt !reml !dl then !remh - !dh - 1 else !remh - !dh; - reml := !reml - !dl; - end; - maskl := (!maskl lsr 1) lor (!maskh lsl (uint_size - 1)); - maskh := !maskh lsr 1; - dl := (!dl lsr 1) lor (!dh lsl (uint_size - 1)); - dh := !dh lsr 1; - (* decr n *) + (* nh might temporarily grow as large as 2*y - 1 in the loop body, + so we store it as a 64-bit unsigned integer *) + let nh = ref xh in + let nl = ref xl in + let q = ref 0 in + for _i = 0 to 62 do + (* invariants: 0 <= nh < y, nl = (xl*2^i) % 2^63, + (q*y + nh) * 2^(63-i) + (xl % 2^(63-i)) = (xh%y) * 2^63 + xl *) + nh := Int64.logor (Int64.shift_left !nh 1) (Int64.of_int (!nl lsr 62)); + nl := !nl lsl 1; + q := !q lsl 1; + (* TODO: use "Int64.unsigned_compare !nh y >= 0", + once OCaml 4.08 becomes the minimal required version *) + if Int64.compare !nh 0L < 0 || Int64.compare !nh y >= 0 then + begin q := !q lor 1; nh := Int64.sub !nh y; end done; - !quotientl, !reml + !q, Int64.to_int !nh -let div21 xh xl y = if y = 0 then 0, 0 else div21 xh xl y +let div21 xh xl y = + let xh = to_uint64 xh in + let y = to_uint64 y in + if Int64.compare y xh <= 0 then 0, 0 else div21 xh xl y (* exact multiplication *) (* TODO: check that none of these additions could be a logical or *) @@ -225,3 +204,24 @@ let tail0 x = let is_uint63 t = Obj.is_int t [@@ocaml.inline always] + +(* Arithmetic with explicit carries *) + +(* Analog of Numbers.Abstract.Cyclic.carry *) +type 'a carry = C0 of 'a | C1 of 'a + +let addc x y = + let r = x + y in + if lt r x then C1 r else C0 r + +let addcarryc x y = + let r = x + y + 1 in + if le r x then C1 r else C0 r + +let subc x y = + let r = x - y in + if le y x then C0 r else C1 r + +let subcarryc x y = + let r = x - y - 1 in + if lt y x then C0 r else C1 r diff --git a/kernel/uint63_i386_31.ml b/kernel/uint63_i386_31.ml index c3279779e1..b8eccd19fb 100644 --- a/kernel/uint63_i386_31.ml +++ b/kernel/uint63_i386_31.ml @@ -83,58 +83,33 @@ let div x y = let rem x y = if y = 0L then 0L else Int64.rem x y +let diveucl x y = (div x y, rem x y) + let addmuldiv p x y = l_or (l_sl x p) (l_sr y Int64.(sub (of_int uint_size) p)) -(* A few helper functions on 128 bits *) -let lt128 xh xl yh yl = - lt xh yh || (xh = yh && lt xl yl) - -let le128 xh xl yh yl = - lt xh yh || (xh = yh && le xl yl) - (* division of two numbers by one *) -(* precondition: y <> 0 *) -(* outputs: q % 2^63, r s.t. x = q * y + r, r < y *) +(* precondition: xh < y *) +(* outputs: q, r s.t. x = q * y + r, r < y *) let div21 xh xl y = - let maskh = ref zero in - let maskl = ref one in - let dh = ref zero in - let dl = ref y in - let cmp = ref true in - (* n = ref 0 *) - (* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0 *) - while Int64.equal (l_sr !dh (of_int (uint_size - 1))) zero && !cmp do - (* We don't use addmuldiv below to avoid checks on 1 *) - dh := l_or (l_sl !dh one) (l_sr !dl (of_int (uint_size - 1))); - dl := l_sl !dl one; - maskh := l_or (l_sl !maskh one) (l_sr !maskl (of_int (uint_size - 1))); - maskl := l_sl !maskl one; - (* incr n *) - cmp := lt128 !dh !dl xh xl; - done; (* mask = 2^n, d = 2^n * d, 2 * d > x *) - let remh = ref xh in - let reml = ref xl in - (* quotienth = ref 0 *) - let quotientl = ref zero in - (* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, - mask = floor(2^n), d = mask * y, n >= -1 *) - while not (Int64.equal (l_or !maskh !maskl) zero) do - if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) - (* quotienth := !quotienth lor !maskh *) - quotientl := l_or !quotientl !maskl; - remh := if lt !reml !dl then sub (sub !remh !dh) one else sub !remh !dh; - reml := sub !reml !dl - end; - maskl := l_or (l_sr !maskl one) (l_sl !maskh (of_int (uint_size - 1))); - maskh := l_sr !maskh one; - dl := l_or (l_sr !dl one) (l_sl !dh (of_int (uint_size - 1))); - dh := l_sr !dh one - (* decr n *) + let nh = ref xh in + let nl = ref xl in + let q = ref 0L in + for _i = 0 to 62 do + (* invariants: 0 <= nh < y, nl = (xl*2^i) % 2^64, + (q*y + nh) * 2^(63-i) + (xl % 2^(63-i)) = (xh%y) * 2^63 + xl *) + nl := Int64.shift_left !nl 1; + nh := Int64.logor (Int64.shift_left !nh 1) (Int64.shift_right_logical !nl 63); + q := Int64.shift_left !q 1; + (* TODO: use "Int64.unsigned_compare !nh y >= 0", + once OCaml 4.08 becomes the minimal required version *) + if Int64.compare !nh 0L < 0 || Int64.compare !nh y >= 0 then + begin q := Int64.logor !q 1L; nh := Int64.sub !nh y; end done; - !quotientl, !reml + !q, !nh -let div21 xh xl y = if Int64.equal y zero then zero, zero else div21 xh xl y +let div21 xh xl y = + if Int64.compare y xh <= 0 then zero, zero else div21 xh xl y (* exact multiplication *) let mulc x y = @@ -191,6 +166,27 @@ let is_uint63 t = Obj.is_block t && Int.equal (Obj.tag t) Obj.custom_tag && le (Obj.magic t) maxuint63 +(* Arithmetic with explicit carries *) + +(* Analog of Numbers.Abstract.Cyclic.carry *) +type 'a carry = C0 of 'a | C1 of 'a + +let addc x y = + let r = add x y in + if lt r x then C1 r else C0 r + +let addcarryc x y = + let r = addcarry x y in + if le r x then C1 r else C0 r + +let subc x y = + let r = sub x y in + if le y x then C0 r else C1 r + +let subcarryc x y = + let r = subcarry x y in + if lt y x then C0 r else C1 r + (* Register all exported functions so that they can be called from C code *) let () = diff --git a/plugins/extraction/ExtrOCamlInt63.v b/plugins/extraction/ExtrOCamlInt63.v new file mode 100644 index 0000000000..a2ee602313 --- /dev/null +++ b/plugins/extraction/ExtrOCamlInt63.v @@ -0,0 +1,56 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** Extraction to OCaml of native 63-bit machine integers. *) + +From Coq Require Int63 Extraction. + +(** Basic data types used by some primitive operators. *) + +Extract Inductive bool => bool [ true false ]. +Extract Inductive prod => "( * )" [ "" ]. +Extract Inductive comparison => int [ "0" "(-1)" "1" ]. +Extract Inductive DoubleType.carry => "Uint63.carry" [ "Uint63.C0" "Uint63.C1" ]. + +(** Primitive types and operators. *) +Extract Constant Int63.int => "Uint63.t". +Extraction Inline Int63.int. +(* Otherwise, the name conflicts with the primitive OCaml type [int] *) + +Extract Constant Int63.lsl => "Uint63.l_sl". +Extract Constant Int63.lsr => "Uint63.l_sr". +Extract Constant Int63.land => "Uint63.l_and". +Extract Constant Int63.lor => "Uint63.l_or". +Extract Constant Int63.lxor => "Uint63.l_xor". + +Extract Constant Int63.add => "Uint63.add". +Extract Constant Int63.sub => "Uint63.sub". +Extract Constant Int63.mul => "Uint63.mul". +Extract Constant Int63.mulc => "Uint63.mulc". +Extract Constant Int63.div => "Uint63.div". +Extract Constant Int63.mod => "Uint63.rem". + +Extract Constant Int63.eqb => "Uint63.equal". +Extract Constant Int63.ltb => "Uint63.lt". +Extract Constant Int63.leb => "Uint63.le". + +Extract Constant Int63.addc => "Uint63.addc". +Extract Constant Int63.addcarryc => "Uint63.addcarryc". +Extract Constant Int63.subc => "Uint63.subc". +Extract Constant Int63.subcarryc => "Uint63.subcarryc". + +Extract Constant Int63.diveucl => "Uint63.diveucl". +Extract Constant Int63.diveucl_21 => "Uint63.div21". +Extract Constant Int63.addmuldiv => "Uint63.addmuldiv". + +Extract Constant Int63.compare => "Uint63.compare". + +Extract Constant Int63.head0 => "Uint63.head0". +Extract Constant Int63.tail0 => "Uint63.tail0". diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 5f859b3e4b..1b75d3d966 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -148,9 +148,7 @@ END module Vernac = Pvernac.Vernac_ module Tactic = Pltac -type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located - -let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genarg.uniform_genarg_type) = +let (wit_function_rec_definition_loc : Vernacexpr.fixpoint_expr Loc.located Genarg.uniform_genarg_type) = Genarg.create_arg "function_rec_definition_loc" let function_rec_definition_loc = @@ -175,10 +173,10 @@ let () = let is_proof_termination_interactively_checked recsl = List.exists (function - | _,((_,( Some { CAst.v = CMeasureRec _ } - | Some { CAst.v = CWfRec _}),_,_,_),_) -> true - | _,((_,Some { CAst.v = CStructRec _ },_,_,_),_) - | _,((_,None,_,_,_),_) -> false) recsl + | _,( Vernacexpr.{ rec_order = Some { CAst.v = CMeasureRec _ } } + | Vernacexpr.{ rec_order = Some { CAst.v = CWfRec _} }) -> true + | _, Vernacexpr.{ rec_order = Some { CAst.v = CStructRec _ } } + | _, Vernacexpr.{ rec_order = None } -> false) recsl let classify_as_Fixpoint recsl = Vernac_classifier.classify_vernac diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 6e19ef4804..1987677d7d 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,3 +1,13 @@ +(************************************************************************) +(* * 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 CErrors open Sorts open Util @@ -157,17 +167,16 @@ let interp_casted_constr_with_implicits env sigma impls c = and not as a constr *) -let build_newrecursive - lnameargsardef = +let build_newrecursive lnameargsardef = let env0 = Global.env() in let sigma = Evd.from_env env0 in let (rec_sign,rec_impls) = List.fold_left - (fun (env,impls) (({CAst.v=recname},_),bl,arityc,_) -> - let arityc = Constrexpr_ops.mkCProdN bl arityc in + (fun (env,impls) { Vernacexpr.fname={CAst.v=recname}; binders; rtype } -> + let arityc = Constrexpr_ops.mkCProdN binders rtype in let arity,ctx = Constrintern.interp_type env0 sigma arityc in let evd = Evd.from_env env0 in - let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd bl in + let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd binders in let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in let open Context.Named.Declaration in let r = Sorts.Relevant in (* TODO relevance *) @@ -175,26 +184,18 @@ let build_newrecursive (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) - let f (_,bl,_,def) = - let def = abstract_glob_constr def bl in - interp_casted_constr_with_implicits - rec_sign sigma rec_impls def + let f { Vernacexpr.binders; body_def } = + match body_def with + | Some body_def -> + let def = abstract_glob_constr body_def binders in + interp_casted_constr_with_implicits + rec_sign sigma rec_impls def + | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in States.with_state_protection (List.map f) lnameargsardef in recdef,rec_impls -let build_newrecursive l = - let l' = List.map - (fun ((fixna,_,bll,ar,body_opt),lnot) -> - match body_opt with - | Some body -> - (fixna,bll,ar,body) - | None -> user_err ~hdr:"Function" (str "Body of Function must be given") - ) l - in - build_newrecursive l' - let error msg = user_err Pp.(str msg) (* Checks whether or not the mutual bloc is recursive *) @@ -237,8 +238,8 @@ let rec local_binders_length = function | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl | Constrexpr.CLocalPattern _::bl -> assert false -let prepare_body ((name,_,args,types,_),_) rt = - let n = local_binders_length args in +let prepare_body { Vernacexpr.binders; rtype } rt = + let n = local_binders_length binders in (* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') @@ -336,13 +337,13 @@ let error_error names e = | _ -> raise e let generate_principle (evd:Evd.evar_map ref) pconstants on_error - is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs interactive_proof + is_general do_built (fix_rec_l : Vernacexpr.fixpoint_expr list) recdefs interactive_proof (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> Tacmach.tactic) : unit = - let names = List.map (function (({CAst.v=name},_),_,_,_,_),_ -> name) fix_rec_l in + let names = List.map (function { Vernacexpr.fname = {CAst.v=name} } -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in - let funs_types = List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in + let funs_types = List.map (function { Vernacexpr.rtype } -> rtype) fix_rec_l in try (* We then register the Inductive graphs of the functions *) Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types recdefs; @@ -359,7 +360,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error locate_ind f_R_mut) in - let fname_kn (((fname,_),_,_,_,_),_) = + let fname_kn { Vernacexpr.fname } = let f_ref = qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in locate_with_msg (pr_qualid f_ref++str ": Not an inductive type!") @@ -398,23 +399,25 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error with e when CErrors.noncritical e -> on_error names e -let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = +let register_struct is_rec (fixpoint_exprl: Vernacexpr.fixpoint_expr list) = match fixpoint_exprl with - | [(({CAst.v=fname},pl),_,bl,ret_type,body),_] when not is_rec -> - let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in + | [ { Vernacexpr.fname; univs; binders; rtype; body_def } ] when not is_rec -> + let body = match body_def with + | Some body -> body + | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in ComDefinition.do_definition ~program_mode:false - ~name:fname + ~name:fname.CAst.v ~poly:false ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.Definition pl - bl None body (Some ret_type); + ~kind:Decls.Definition univs + binders None body (Some rtype); let evd,rev_pconstants = List.fold_left - (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> + (fun (evd,l) { Vernacexpr.fname } -> let evd,c = Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in let (cst, u) = destConst evd c in let u = EInstance.kind evd u in evd,((cst, u) :: l) @@ -427,10 +430,10 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp ComFixpoint.do_fixpoint ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false fixpoint_exprl; let evd,rev_pconstants = List.fold_left - (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> + (fun (evd,l) { Vernacexpr.fname } -> let evd,c = Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in let (cst, u) = destConst evd c in let u = EInstance.kind evd u in evd,((cst, u) :: l) @@ -464,7 +467,7 @@ let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf let unbounded_eq = let f_app_args = CAst.make @@ Constrexpr.CAppExpl( - (None,qualid_of_ident fname,None) , + (None,qualid_of_ident fname.CAst.v,None) , (List.map (function | {CAst.v=Anonymous} -> assert false @@ -485,13 +488,13 @@ let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); - derive_inversion [fname] + derive_inversion [fname.CAst.v] with e when CErrors.noncritical e -> (* No proof done *) () in Recdef.recursive_definition ~interactive_proof - ~is_mes fname rec_impls + ~is_mes fname.CAst.v rec_impls type_of_f wf_rel_expr rec_arg_num @@ -607,88 +610,93 @@ and rebuild_nal aux bk bl' nal typ = let rebuild_bl aux bl typ = rebuild_bl aux bl typ -let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = - let fixl,ntns = ComFixpoint.extract_fixpoint_components ~structonly:false fixpoint_exprl in - let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in +let recompute_binder_list fixpoint_exprl = + let fixl = + List.map (fun fix -> Vernacexpr.{ + fix + with rec_order = ComFixpoint.adjust_rec_order ~structonly:false fix.binders fix.rec_order }) fixpoint_exprl in + let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl in let constr_expr_typel = with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in let fixpoint_exprl_with_new_bl = - List.map2 (fun ((lna,rec_order_opt,bl,ret_typ,opt_body),notation_list) fix_typ -> - - let new_bl',new_ret_type = rebuild_bl [] bl fix_typ in - (((lna,rec_order_opt,new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) - ) - fixpoint_exprl constr_expr_typel + List.map2 (fun ({ Vernacexpr.binders } as fp) fix_typ -> + let binders, rtype = rebuild_bl [] binders fix_typ in + { fp with Vernacexpr.binders; rtype } + ) fixpoint_exprl constr_expr_typel in fixpoint_exprl_with_new_bl let do_generate_principle_aux pconstants on_error register_built interactive_proof - (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Lemmas.t option = - List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; + (fixpoint_exprl : Vernacexpr.fixpoint_expr list) : Lemmas.t option = + List.iter (fun { Vernacexpr.notations } -> + if not (List.is_empty notations) + then error "Function does not support notations for now") fixpoint_exprl; let lemma, _is_struct = match fixpoint_exprl with - | [((_,Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)},_,_,_),_) as fixpoint_expr] -> - let (((({CAst.v=name},pl),_,args,types,body)),_) as fixpoint_expr = - match recompute_binder_list [fixpoint_expr] with - | [e] -> e - | _ -> assert false - in - let fixpoint_exprl = [fixpoint_expr] in - let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let using_lemmas = [] in - let pre_hook pconstants = - generate_principle - (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs - true - in - if register_built - then register_wf interactive_proof name rec_impls wf_rel wf_x.CAst.v using_lemmas args types body pre_hook, false - else None, false - |[((_,Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)},_,_,_),_) as fixpoint_expr] -> - let (((({CAst.v=name},_),_,args,types,body)),_) as fixpoint_expr = - match recompute_binder_list [fixpoint_expr] with - | [e] -> e - | _ -> assert false - in - let fixpoint_exprl = [fixpoint_expr] in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let using_lemmas = [] in - let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - let pre_hook pconstants = - generate_principle - (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs - true - in - if register_built - then register_mes interactive_proof name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, true - else None, true + | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)} } as fixpoint_expr] -> + let { Vernacexpr.fname; univs; binders; rtype; body_def } as fixpoint_expr = + match recompute_binder_list [fixpoint_expr] with + | [e] -> e + | _ -> assert false + in + let fixpoint_exprl = [fixpoint_expr] in + let body = match body_def with + | Some body -> body + | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let using_lemmas = [] in + let pre_hook pconstants = + generate_principle + (ref (Evd.from_env (Global.env ()))) + pconstants + on_error + true + register_built + fixpoint_exprl + recdefs + true + in + if register_built + then register_wf interactive_proof fname rec_impls wf_rel wf_x.CAst.v using_lemmas binders rtype body pre_hook, false + else None, false + |[{ Vernacexpr.rec_order=Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)} } as fixpoint_expr] -> + let { Vernacexpr.fname; univs; binders; rtype; body_def} as fixpoint_expr = + match recompute_binder_list [fixpoint_expr] with + | [e] -> e + | _ -> assert false + in + let fixpoint_exprl = [fixpoint_expr] in + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let using_lemmas = [] in + let body = match body_def with + | Some body -> body + | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in + let pre_hook pconstants = + generate_principle + (ref (Evd.from_env (Global.env ()))) + pconstants + on_error + true + register_built + fixpoint_exprl + recdefs + true + in + if register_built + then register_mes interactive_proof fname rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas binders rtype body pre_hook, true + else None, true | _ -> - List.iter (function ((_na,ord,_args,_body,_type),_not) -> - match ord with - | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> - error - ("Cannot use mutual definition with well-founded recursion or measure") - | _ -> () + List.iter (function { Vernacexpr.rec_order } -> + match rec_order with + | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> + error + ("Cannot use mutual definition with well-founded recursion or measure") + | _ -> () ) fixpoint_exprl; let fixpoint_exprl = recompute_binder_list fixpoint_exprl in - let fix_names = - List.map (function ((({CAst.v=name},_),_,_,_,_),_) -> name) fixpoint_exprl - in + let fix_names = List.map (function { Vernacexpr.fname } -> fname.CAst.v) fixpoint_exprl in (* ok all the expressions are structural *) let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in @@ -845,59 +853,59 @@ let make_graph (f_ref : GlobRef.t) = | None -> error "Cannot build a graph over an axiom!" | Some (body, _, _) -> let env = Global.env () in - let extern_body,extern_type = - with_full_print (fun () -> - (Constrextern.extern_constr false env sigma (EConstr.of_constr body), - Constrextern.extern_type false env sigma - (EConstr.of_constr (*FIXME*) c_body.const_type) - ) + let extern_body,extern_type = + with_full_print (fun () -> + (Constrextern.extern_constr false env sigma (EConstr.of_constr body), + Constrextern.extern_type false env sigma + (EConstr.of_constr (*FIXME*) c_body.const_type) ) - () - in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b.CAst.v with - | Constrexpr.CFix(l_id,fixexprl) -> - let l = - List.map - (fun (id,recexp,bl,t,b) -> - let { CAst.loc; v=rec_id } = match Option.get recexp with - | { CAst.v = CStructRec id } -> id - | { CAst.v = CWfRec (id,_) } -> id - | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid - in - let new_args = - List.flatten - (List.map - (function - | Constrexpr.CLocalDef (na,_,_)-> [] - | Constrexpr.CLocalAssum (nal,_,_) -> - List.map - (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) - nal - | Constrexpr.CLocalPattern _ -> assert false - ) - nal_tas - ) - in - let b' = add_args id.CAst.v new_args b in - ((((id,None), ( Some (CAst.make (CStructRec (CAst.make rec_id)))),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) - ) - fixexprl + ) () + in + let (nal_tas,b,t) = get_args extern_body extern_type in + let expr_list = + match b.CAst.v with + | Constrexpr.CFix(l_id,fixexprl) -> + let l = + List.map + (fun (id,recexp,bl,t,b) -> + let { CAst.loc; v=rec_id } = match Option.get recexp with + | { CAst.v = CStructRec id } -> id + | { CAst.v = CWfRec (id,_) } -> id + | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid + in + let new_args = + List.flatten + (List.map + (function + | Constrexpr.CLocalDef (na,_,_)-> [] + | Constrexpr.CLocalAssum (nal,_,_) -> + List.map + (fun {CAst.loc;v=n} -> CAst.make ?loc @@ + CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) + nal + | Constrexpr.CLocalPattern _ -> assert false + ) + nal_tas + ) in - l - | _ -> - let id = Label.to_id (Constant.label c) in - [((CAst.make id,None),None,nal_tas,t,Some b),[]] - in - let mp = Constant.modpath c in - let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in - assert (Option.is_empty pstate); - (* We register the infos *) - List.iter - (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make2 mp (Label.of_id id))) - expr_list) + let b' = add_args id.CAst.v new_args b in + { Vernacexpr.fname=id; univs=None + ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) + ; binders = nal_tas@bl; rtype=t; body_def=Some b'; notations = []} + ) fixexprl in + l + | _ -> + let fname = CAst.make (Label.to_id (Constant.label c)) in + [{ Vernacexpr.fname; univs=None; rec_order = None; binders=nal_tas; rtype=t; body_def=Some b; notations=[]}] + in + let mp = Constant.modpath c in + let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in + assert (Option.is_empty pstate); + (* We register the infos *) + List.iter + (fun { Vernacexpr.fname= {CAst.v=id} } -> + add_Function false (Constant.make2 mp (Label.of_id id))) + expr_list) (* *************** statically typed entrypoints ************************* *) diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 3bc52272ac..bfc9686ae5 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -5,12 +5,9 @@ val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit -val do_generate_principle : - (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> unit +val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit -val do_generate_principle_interactive : - (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> - Lemmas.t +val do_generate_principle_interactive : Vernacexpr.fixpoint_expr list -> Lemmas.t val functional_induction : bool -> diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 1e2b23bf96..21d61d1f97 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -17,7 +17,6 @@ open Genarg open Stdarg open Tacarg open Extraargs -open Pcoq.Prim open Pltac open Mod_subst open Names @@ -258,19 +257,8 @@ END open Autorewrite -let pr_orient _prc _prlc _prt = function - | true -> Pp.mt () - | false -> Pp.str " <-" - -let pr_orient_string _prc _prlc _prt (orient, s) = - pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s - } -ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY { pr_orient_string } -| [ orient(r) preident(i) ] -> { r, i } -END - TACTIC EXTEND autorewrite | [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> { auto_multi_rewrite l ( cl) } diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index c09250ade5..962730d8dc 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -385,7 +385,6 @@ open Pltac ARGUMENT EXTEND ssrindex PRINTED BY { pr_ssrindex } INTERPRETED BY { interp_index } -| [ int_or_var(i) ] -> { mk_index ~loc i } END @@ -523,7 +522,6 @@ ARGUMENT EXTEND ssrterm GLOBALIZED BY { glob_ssrterm } SUBSTITUTED BY { subst_ssrterm } RAW_PRINTED BY { pr_ssrterm } GLOB_PRINTED BY { pr_ssrterm } -| [ "YouShouldNotTypeThis" constr(c) ] -> { mk_lterm c } END GRAMMAR EXTEND Gram @@ -570,7 +568,6 @@ let pr_ssrbwdview _ _ _ = pr_view ARGUMENT EXTEND ssrbwdview TYPED AS ssrterm list PRINTED BY { pr_ssrbwdview } -| [ "YouShouldNotTypeThis" ] -> { [] } END (* Pcoq *) @@ -594,7 +591,6 @@ let pr_ssrfwdview _ _ _ = pr_view2 ARGUMENT EXTEND ssrfwdview TYPED AS ast_closure_term list PRINTED BY { pr_ssrfwdview } -| [ "YouShouldNotTypeThis" ] -> { [] } END (* Pcoq *) @@ -762,7 +758,6 @@ let test_ident_no_do = } ARGUMENT EXTEND ident_no_do PRINTED BY { fun _ _ _ -> Names.Id.print } -| [ "YouShouldNotTypeThis" ident(id) ] -> { id } END @@ -857,7 +852,6 @@ let _test_nobinder = Pcoq.Entry.of_parser "test_nobinder" (reject_binder false 0 } ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY { pr_ssripat } - | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> { IPatCase(Regular x) } END (* Pcoq *) @@ -985,7 +979,6 @@ let pr_ssrintrosarg env sigma _ _ prt (tac, ipats) = ARGUMENT EXTEND ssrintrosarg TYPED AS (tactic * ssrintros) PRINTED BY { pr_ssrintrosarg env sigma } -| [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> { arg, ipats } END { @@ -1711,14 +1704,6 @@ let _ = add_internal_name (is_tagged perm_tag) (** Tactical extensions. *) -(* The TACTIC EXTEND facility can't be used for defining new user *) -(* tacticals, because: *) -(* - the concrete syntax must start with a fixed string *) -(* We use the following workaround: *) -(* - We use the (unparsable) "YouShouldNotTypeThis" token for tacticals that *) -(* don't start with a token, then redefine the grammar and *) -(* printer using GEXTEND and set_pr_ssrtac, respectively. *) - { type ssrargfmt = ArgSsr of string | ArgSep of string @@ -2243,8 +2228,6 @@ END (** The "congr" tactic *) -(* type ssrcongrarg = open_constr * (int * constr) *) - { let pr_ssrcongrarg _ _ _ ((n, f), dgens) = diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 649b51cb0e..66db924051 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -101,10 +101,11 @@ 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 glob_IZR = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") -let glob_Rmult = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "Rmult") +let glob_Rmult = GlobRef.ConstRef (Constant.make2 r_base_modpath @@ Label.make "Rmult") let glob_Rdiv = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "Rdiv") let binintdef = ["Coq";"ZArith";"BinIntDef"] diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 00831b5962..a9eb43e573 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -839,8 +839,9 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN f2 l2 | _ -> raise ex) - | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> - (try + | Case (ci1,p1,c1,cl1), Case (ci2,p2,c2,cl2) -> + (try + if not (eq_ind ci1.ci_ind ci2.ci_ind) then error_cannot_unify curenv sigma (cM,cN); let opt' = {opt with at_top = true; with_types = false} in Array.fold_left2 (unirec_rec curenvnb CONV {opt with at_top = true}) (unirec_rec curenvnb CONV opt' diff --git a/stm/stm.ml b/stm/stm.ml index d5e6e6fd8b..69dbebbc57 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1073,7 +1073,7 @@ let stm_vernac_interp ?route id st { verbose; expr } : Vernacstate.t = *) let is_filtered_command = function | VernacResetName _ | VernacResetInitial | VernacBack _ - | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ + | VernacRestart | VernacUndo _ | VernacUndoTo _ | VernacAbortAll | VernacAbort _ -> true | _ -> false in @@ -1216,8 +1216,6 @@ end = struct (* {{{ *) match Vcs_.branches vcs with [_] -> `Stop id | _ -> `Cont ()) () id in oid - | VernacBackTo id -> - Stateid.of_int id | _ -> anomaly Pp.(str "incorrect VtMeta classification") with | Not_found -> diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index aaba36287a..5af576dad2 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -106,8 +106,8 @@ let classify_vernac e = else GuaranteesOpacity in let ids, open_proof = - List.fold_left (fun (l,b) ((({v=id},_),_,_,_,p),_) -> - id::l, b || p = None) ([],false) l in + List.fold_left (fun (l,b) {Vernacexpr.fname={CAst.v=id}; body_def} -> + id::l, b || body_def = None) ([],false) l in if open_proof then VtStartProof (guarantee,ids) else VtSideff (ids, VtLater) @@ -118,8 +118,8 @@ let classify_vernac e = else GuaranteesOpacity in let ids, open_proof = - List.fold_left (fun (l,b) ((({v=id},_),_,_,p),_) -> - id::l, b || p = None) ([],false) l in + List.fold_left (fun (l,b) { Vernacexpr.fname={CAst.v=id}; body_def } -> + id::l, b || body_def = None) ([],false) l in if open_proof then VtStartProof (guarantee,ids) else VtSideff (ids, VtLater) @@ -193,7 +193,7 @@ let classify_vernac e = | VernacBack _ | VernacAbortAll | VernacUndoTo _ | VernacUndo _ | VernacResetName _ | VernacResetInitial - | VernacBackTo _ | VernacRestart -> VtMeta + | VernacRestart -> VtMeta (* What are these? *) | VernacRestoreState _ | VernacWriteState _ -> VtSideff ([], VtNow) diff --git a/test-suite/arithmetic/diveucl_21.v b/test-suite/arithmetic/diveucl_21.v index b888c97be3..b12dba429c 100644 --- a/test-suite/arithmetic/diveucl_21.v +++ b/test-suite/arithmetic/diveucl_21.v @@ -10,11 +10,11 @@ Check (eq_refl (4611686018427387904,1) <<: diveucl_21 1 1 2 = (46116860184273879 Definition compute1 := Eval compute in diveucl_21 1 1 2. Check (eq_refl compute1 : (4611686018427387904,1) = (4611686018427387904,1)). -Check (eq_refl : diveucl_21 3 1 2 = (4611686018427387904, 1)). -Check (eq_refl (4611686018427387904, 1) <: diveucl_21 3 1 2 = (4611686018427387904, 1)). -Check (eq_refl (4611686018427387904, 1) <<: diveucl_21 3 1 2 = (4611686018427387904, 1)). +Check (eq_refl : diveucl_21 3 1 2 = (0, 0)). +Check (eq_refl (0, 0) <: diveucl_21 3 1 2 = (0, 0)). +Check (eq_refl (0, 0) <<: diveucl_21 3 1 2 = (0, 0)). Definition compute2 := Eval compute in diveucl_21 3 1 2. -Check (eq_refl compute2 : (4611686018427387904, 1) = (4611686018427387904, 1)). +Check (eq_refl compute2 : (0, 0) = (0, 0)). Check (eq_refl : diveucl_21 1 1 0 = (0,0)). Check (eq_refl (0,0) <: diveucl_21 1 1 0 = (0,0)). @@ -23,3 +23,7 @@ Check (eq_refl (0,0) <<: diveucl_21 1 1 0 = (0,0)). Check (eq_refl : diveucl_21 9223372036854775807 0 1 = (0,0)). Check (eq_refl (0,0) <: diveucl_21 9223372036854775807 0 1 = (0,0)). Check (eq_refl (0,0) <<: diveucl_21 9223372036854775807 0 1 = (0,0)). + +Check (eq_refl : diveucl_21 9305446873517 1793572051078448654 4930380657631323783 = (17407905077428, 3068214991893055266)). +Check (eq_refl (17407905077428, 3068214991893055266) <: diveucl_21 9305446873517 1793572051078448654 4930380657631323783 = (17407905077428, 3068214991893055266)). +Check (eq_refl (17407905077428, 3068214991893055266) <<: diveucl_21 9305446873517 1793572051078448654 4930380657631323783 = (17407905077428, 3068214991893055266)). diff --git a/test-suite/bugs/closed/bug_10533.v b/test-suite/bugs/closed/bug_10533.v new file mode 100644 index 0000000000..e72957bdee --- /dev/null +++ b/test-suite/bugs/closed/bug_10533.v @@ -0,0 +1,8 @@ + +Require Import Eqdep Setoid. +Goal forall (t : unit) (pf : tt = t), + if (match pf with eq_refl => false end) then True else False. +Proof. + intros. + try setoid_rewrite <-Eqdep.Eq_rect_eq.eq_rect_eq. +Abort. diff --git a/test-suite/bugs/closed/bug_10560.v b/test-suite/bugs/closed/bug_10560.v new file mode 100644 index 0000000000..a9a0949d9a --- /dev/null +++ b/test-suite/bugs/closed/bug_10560.v @@ -0,0 +1,9 @@ +From Coq Require Import Int63. +Open Scope int63_scope. + +Lemma foo : + let n := opp 0 in add n 0 = n. +Proof. +cbv. +apply eq_refl. +Qed. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index 9bb16b97e2..9e9481341f 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -388,7 +388,7 @@ Axiom diveucl_def_spec : forall x y, diveucl x y = diveucl_def x y. Axiom diveucl_21_spec : forall a1 a2 b, let (q,r) := diveucl_21 a1 a2 b in let (q',r') := Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|] in - [|q|] = Z.modulo q' wB /\ [|r|] = r'. + [|a1|] < [|b|] -> [|q|] = q' /\ [|r|] = r'. Axiom addmuldiv_def_spec : forall p x y, addmuldiv p x y = addmuldiv_def p x y. @@ -812,14 +812,6 @@ Proof. eapply Z.lt_le_trans; [ | apply Zpower2_le_lin ]; auto with zarith. Qed. -Lemma lsr_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%int63. -Proof. - apply to_Z_inj. - rewrite -> add_spec, !lsl_spec, add_spec. - rewrite -> Zmult_mod_idemp_l, <-Zplus_mod. - apply f_equal2 with (f := Zmod); auto with zarith. -Qed. - (* LSL *) Lemma lsl0 i: 0 << i = 0%int63. Proof. @@ -1119,7 +1111,7 @@ Proof. generalize (add_le_r x y); rewrite Heq, lor_le; intro Hb. generalize Heq; rewrite (bit_split x) at 1; rewrite (bit_split y )at 1; clear Heq. rewrite (fun y => add_comm y (bit x 0)), <-!add_assoc, add_comm, - <-!add_assoc, (add_comm (bit y 0)), add_assoc, <-lsr_add_distr. + <-!add_assoc, (add_comm (bit y 0)), add_assoc, <-lsl_add_distr. rewrite (bit_split (x lor y)), lor_spec. intros Heq. assert (F: (bit x 0 + bit y 0)%int63 = (bit x 0 || bit y 0)). @@ -1429,26 +1421,9 @@ Proof. generalize (Z_div_mod ([|a1|]*wB+[|a2|]) [|b|] H). revert W. destruct (diveucl_21 a1 a2 b); destruct (Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]). - intros (H', H''); rewrite H', H''; clear H' H''. + intros (H', H''); auto; rewrite H', H''; clear H' H''. intros (H', H''); split; [ |exact H'']. - rewrite H', Zmult_comm, Z.mod_small; [reflexivity| ]. - split. - { revert H'; case z; [now simpl..|intros p H']. - exfalso; apply (Z.lt_irrefl 0), (Z.le_lt_trans _ ([|a1|] * wB + [|a2|])). - { now apply Z.add_nonneg_nonneg; [apply Z.mul_nonneg_nonneg| ]. } - rewrite H'; apply (Zplus_lt_reg_r _ _ (- z0)); ring_simplify. - apply (Z.le_lt_trans _ (- [|b|])); [ |now auto with zarith]. - rewrite Z.opp_eq_mul_m1; apply Zmult_le_compat_l; [ |now apply Wb]. - rewrite <-!Pos2Z.opp_pos, <-Z.opp_le_mono. - now change 1 with (Z.succ 0); apply Zlt_le_succ. } - rewrite <-Z.nle_gt; intro Hz; revert H2; apply Zle_not_lt. - rewrite (Z.div_unique_pos (wB * [|a1|] + [|a2|]) wB [|a1|] [|a2|]); - [ |now simpl..]. - rewrite Z.mul_comm, H'. - rewrite (Z.div_unique_pos (wB * [|b|] + z0) wB [|b|] z0) at 1; - [ |split; [ |apply (Z.lt_trans _ [|b|])]; now simpl|reflexivity]. - apply Z_div_le; [now simpl| ]; rewrite Z.mul_comm; apply Zplus_le_compat_r. - now apply Zmult_le_compat_l. + now rewrite H', Zmult_comm. Qed. Lemma div2_phi ih il j: (2^62 <= [|j|] -> [|ih|] < [|j|] -> diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index 28565b2fe3..2785e89c5d 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -648,40 +648,15 @@ Section ZModulo. apply two_power_pos_correct. Qed. - Definition head0 x := match [|x|] with + Definition head0 x := + match [| x |] with | Z0 => zdigits - | Zpos p => zdigits - log_inf p - 1 - | _ => 0 - end. + | Zneg _ => 0 + | (Zpos _) as p => zdigits - Z.log2 p - 1 + end. Lemma spec_head00: forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits. - Proof. - unfold head0; intros. - rewrite H; simpl. - apply spec_zdigits. - Qed. - - Lemma log_inf_bounded : forall x p, Zpos x < 2^p -> log_inf x < p. - Proof. - induction x; simpl; intros. - - assert (0 < p) by (destruct p; compute; auto with zarith; discriminate). - cut (log_inf x < p - 1); [omega| ]. - apply IHx. - change (Zpos x~1) with (2*(Zpos x)+1) in H. - replace p with (Z.succ (p-1)) in H; auto with zarith. - rewrite Z.pow_succ_r in H; auto with zarith. - - assert (0 < p) by (destruct p; compute; auto with zarith; discriminate). - cut (log_inf x < p - 1); [omega| ]. - apply IHx. - change (Zpos x~0) with (2*(Zpos x)) in H. - replace p with (Z.succ (p-1)) in H; auto with zarith. - rewrite Z.pow_succ_r in H; auto with zarith. - - simpl; intros; destruct p; compute; auto with zarith. - Qed. - + Proof. unfold head0; intros x ->; apply spec_zdigits. Qed. Lemma spec_head0 : forall x, 0 < [|x|] -> wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB. @@ -689,36 +664,35 @@ Section ZModulo. intros; unfold head0. generalize (spec_to_Z x). destruct [|x|]; try discriminate. + pose proof (Z.log2_nonneg (Zpos p)). + destruct (Z.log2_spec (Zpos p)); auto. intros. - destruct (log_inf_correct p). - rewrite 2 two_p_power2 in H2; auto with zarith. - assert (0 <= zdigits - log_inf p - 1 < wB). + assert (0 <= zdigits - Z.log2 (Zpos p) - 1 < wB) as Hrange. split. - cut (log_inf p < zdigits); try omega. + cut (Z.log2 (Zpos p) < zdigits). omega. unfold zdigits. unfold wB, base in *. - apply log_inf_bounded; auto with zarith. + apply Z.log2_lt_pow2; intuition. apply Z.lt_trans with zdigits. omega. unfold zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith. - unfold to_Z; rewrite (Zmod_small _ _ H3). - destruct H2. + unfold to_Z; rewrite (Zmod_small _ _ Hrange). split. - apply Z.le_trans with (2^(zdigits - log_inf p - 1)*(2^log_inf p)). + apply Z.le_trans with (2^(zdigits - Z.log2 (Zpos p) - 1)*(2^Z.log2 (Zpos p))). apply Zdiv_le_upper_bound; auto with zarith. rewrite <- Zpower_exp; auto with zarith. rewrite Z.mul_comm; rewrite <- Z.pow_succ_r; auto with zarith. - replace (Z.succ (zdigits - log_inf p -1 +log_inf p)) with zdigits + replace (Z.succ (zdigits - Z.log2 (Zpos p) -1 + Z.log2 (Zpos p))) with zdigits by ring. unfold wB, base, zdigits; auto with zarith. apply Z.mul_le_mono_nonneg; auto with zarith. apply Z.lt_le_trans - with (2^(zdigits - log_inf p - 1)*(2^(Z.succ (log_inf p)))). + with (2^(zdigits - Z.log2 (Zpos p) - 1)*(2^(Z.succ (Z.log2 (Zpos p))))). apply Z.mul_lt_mono_pos_l; auto with zarith. rewrite <- Zpower_exp; auto with zarith. - replace (zdigits - log_inf p -1 +Z.succ (log_inf p)) with zdigits + replace (zdigits - Z.log2 (Zpos p) -1 +Z.succ (Z.log2 (Zpos p))) with zdigits by ring. unfold wB, base, zdigits; auto with zarith. Qed. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 3a613c55ec..21bea6c315 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -562,6 +562,16 @@ Proof. apply Qdiv_mult_l; auto. Qed. +Lemma Qinv_plus_distr : forall a b c, ((a # c) + (b # c) == (a+b) # c)%Q. +Proof. + intros. unfold Qeq. simpl. rewrite Pos2Z.inj_mul. ring. +Qed. + +Lemma Qinv_minus_distr : forall a b c, (a # c) + - (b # c) == (a-b) # c. +Proof. + intros. unfold Qeq. simpl. rewrite Pos2Z.inj_mul. ring. +Qed. + (** Injectivity of Qmult (requires theory about Qinv above): *) Lemma Qmult_inj_r (x y z: Q): ~ z == 0 -> (x * z == y * z <-> x == y). diff --git a/theories/Reals/ConstructiveCauchyReals.v b/theories/Reals/ConstructiveCauchyReals.v new file mode 100644 index 0000000000..3ca9248600 --- /dev/null +++ b/theories/Reals/ConstructiveCauchyReals.v @@ -0,0 +1,2535 @@ +(************************************************************************) +(* * 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 QArith. +Require Import Qabs. +Require Import Qround. +Require Import Logic.ConstructiveEpsilon. + +Open Scope Q. + +(* The constructive Cauchy real numbers, ie the Cauchy sequences + of rational numbers. This file is not supposed to be imported, + except in Rdefinitions.v, Raxioms.v, Rcomplete_constr.v + and ConstructiveRIneq.v. + + 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. *) + + +(* First some limit results about Q *) +Lemma Qarchimedean : forall q : Q, { p : positive | Qlt q (Z.pos p # 1) }. +Proof. + intros. destruct q. unfold Qlt. simpl. + rewrite Zmult_1_r. destruct Qnum. + - exists xH. reflexivity. + - exists (p+1)%positive. apply (Z.lt_le_trans _ (Z.pos (p+1))). + apply Z.lt_succ_diag_r. rewrite Pos2Z.inj_mul. + rewrite <- (Zmult_1_r (Z.pos (p+1))). apply Z.mul_le_mono_nonneg. + discriminate. rewrite Zmult_1_r. apply Z.le_refl. discriminate. + apply Z2Nat.inj_le. discriminate. apply Pos2Z.is_nonneg. + apply Nat.le_succ_l. apply Nat2Z.inj_lt. + rewrite Z2Nat.id. apply Pos2Z.is_pos. apply Pos2Z.is_nonneg. + - exists xH. reflexivity. +Qed. + +Lemma Qinv_lt_contravar : forall a b : Q, + Qlt 0 a -> Qlt 0 b -> (Qlt a b <-> Qlt (/b) (/a)). +Proof. + intros. split. + - intro. rewrite <- Qmult_1_l. apply Qlt_shift_div_r. apply H0. + rewrite <- (Qmult_inv_r a). rewrite Qmult_comm. + apply Qmult_lt_l. apply Qinv_lt_0_compat. apply H. + apply H1. intro abs. rewrite abs in H. apply (Qlt_irrefl 0 H). + - intro. rewrite <- (Qinv_involutive b). rewrite <- (Qmult_1_l (// b)). + apply Qlt_shift_div_l. apply Qinv_lt_0_compat. apply H0. + rewrite <- (Qmult_inv_r a). apply Qmult_lt_l. apply H. + apply H1. intro abs. rewrite abs in H. apply (Qlt_irrefl 0 H). +Qed. + +Lemma Qabs_separation : forall q : Q, + (forall k:positive, Qlt (Qabs q) (1 # k)) + -> q == 0. +Proof. + intros. destruct (Qle_lt_or_eq 0 (Qabs q)). apply Qabs_nonneg. + - exfalso. destruct (Qarchimedean (Qinv (Qabs q))) as [p maj]. + specialize (H p). apply (Qlt_not_le (/ Qabs q) (Z.pos p # 1)). + apply maj. apply Qlt_le_weak. + setoid_replace (Z.pos p # 1) with (/(1#p)). 2: reflexivity. + rewrite <- Qinv_lt_contravar. apply H. apply H0. + reflexivity. + - destruct q. unfold Qeq in H0. simpl in H0. + rewrite Zmult_1_r in H0. replace Qnum with 0%Z. reflexivity. + destruct (Zabs_dec Qnum). rewrite e. rewrite H0. reflexivity. + rewrite e. rewrite <- H0. ring. +Qed. + +Lemma Qle_limit : forall (a b : Q), + (forall eps:Q, Qlt 0 eps -> Qlt a (b + eps)) + -> Qle a b. +Proof. + intros. destruct (Q_dec a b). destruct s. + apply Qlt_le_weak. assumption. exfalso. + assert (0 < a - b). unfold Qminus. apply (Qlt_minus_iff b a). + assumption. specialize (H (a-b) H0). + apply (Qlt_irrefl a). ring_simplify in H. assumption. + rewrite q. apply Qle_refl. +Qed. + +Lemma Qopp_lt_compat : forall p q, p<q -> -q < -p. +Proof. + intros (a1,a2) (b1,b2); unfold Qlt; simpl. + rewrite !Z.mul_opp_l. omega. +Qed. + +Lemma Qmult_minus_one : forall q : Q, inject_Z (-1) * q == - q. +Proof. + intros. field. +Qed. + +Lemma Qsub_comm : forall a b : Q, - a + b == b - a. +Proof. + intros. unfold Qeq. simpl. rewrite Pos.mul_comm. ring. +Qed. + +Lemma PosLt_le_total : forall p q, Pos.lt p q \/ Pos.le q p. +Proof. + intros. destruct (Pos.lt_total p q). left. assumption. + right. destruct H. subst q. apply Pos.le_refl. unfold Pos.lt in H. + unfold Pos.le. rewrite H. discriminate. +Qed. + + + + +(* + Cauchy reals are Cauchy sequences of rational numbers, + equipped with explicit moduli of convergence and + an equivalence relation (the difference converges to zero). + + Without convergence moduli, we would fail to prove that a Cauchy + sequence of constructive reals converges. + + Because of the Specker sequences (increasing, computable + and bounded sequences of rationals that do not converge + to a computable real number), constructive reals do not + follow the least upper bound principle. + + The double quantification on p q is needed to avoid + forall un, QSeqEquiv un (fun _ => un O) (fun q => O) + which says nothing about the limit of un. + *) +Definition QSeqEquiv (un vn : nat -> Q) (cvmod : positive -> nat) + : Prop + := forall (k : positive) (p q : nat), + le (cvmod k) p + -> le (cvmod k) q + -> Qlt (Qabs (un p - vn q)) (1 # k). + +(* A Cauchy sequence is a sequence equivalent to itself. + If sequences are equivalent, they are both Cauchy and have the same limit. *) +Definition QCauchySeq (un : nat -> Q) (cvmod : positive -> nat) : Prop + := QSeqEquiv un un cvmod. + +Lemma QSeqEquiv_sym : forall (un vn : nat -> Q) (cvmod : positive -> nat), + QSeqEquiv un vn cvmod + -> QSeqEquiv vn un cvmod. +Proof. + intros. intros k p q H0 H1. + rewrite Qabs_Qminus. apply H; assumption. +Qed. + +Lemma factorDenom : forall (a:Z) (b d:positive), (a # (d * b)) == (1#d) * (a#b). +Proof. + intros. unfold Qeq. simpl. destruct a; reflexivity. +Qed. + +Lemma QSeqEquiv_trans : forall (un vn wn : nat -> Q) + (cvmod cvmodw : positive -> nat), + QSeqEquiv un vn cvmod + -> QSeqEquiv vn wn cvmodw + -> QSeqEquiv un wn (fun q => max (cvmod (2 * q)%positive) (cvmodw (2 * q)%positive)). +Proof. + intros. intros k p q H1 H2. + setoid_replace (un p - wn q) with (un p - vn p + (vn p - wn q)). + apply (Qle_lt_trans + _ (Qabs (un p - vn p) + Qabs (vn p - wn q))). + apply Qabs_triangle. apply (Qlt_le_trans _ ((1 # (2*k)) + (1 # (2*k)))). + apply Qplus_lt_le_compat. + - assert ((cvmod (2 * k)%positive <= p)%nat). + { apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). + apply Nat.le_max_l. assumption. } + apply H. assumption. assumption. + - apply Qle_lteq. left. apply H0. + apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). + apply Nat.le_max_r. assumption. + apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). + apply Nat.le_max_r. assumption. + - rewrite (factorDenom _ _ 2). ring_simplify. apply Qle_refl. + - ring. +Qed. + +Definition QSeqEquivEx (un vn : nat -> Q) : Prop + := exists (cvmod : positive -> nat), QSeqEquiv un vn cvmod. + +Lemma QSeqEquivEx_sym : forall (un vn : nat -> Q), QSeqEquivEx un vn -> QSeqEquivEx vn un. +Proof. + intros. destruct H. exists x. apply QSeqEquiv_sym. apply H. +Qed. + +Lemma QSeqEquivEx_trans : forall un vn wn : nat -> Q, + QSeqEquivEx un vn + -> QSeqEquivEx vn wn + -> QSeqEquivEx un wn. +Proof. + intros. destruct H,H0. + exists (fun q => max (x (2 * q)%positive) (x0 (2 * q)%positive)). + apply (QSeqEquiv_trans un vn wn); assumption. +Qed. + +Lemma QSeqEquiv_cau_r : forall (un vn : nat -> Q) (cvmod : positive -> nat), + QSeqEquiv un vn cvmod + -> QCauchySeq vn (fun k => cvmod (2 * k)%positive). +Proof. + intros. intros k p q H0 H1. + setoid_replace (vn p - vn q) + with (vn p + - un (cvmod (2 * k)%positive) + + (un (cvmod (2 * k)%positive) - vn q)). + - apply (Qle_lt_trans + _ (Qabs (vn p + - un (cvmod (2 * k)%positive)) + + Qabs (un (cvmod (2 * k)%positive) - vn q))). + apply Qabs_triangle. + apply (Qlt_le_trans _ ((1 # (2 * k)) + (1 # (2 * k)))). + apply Qplus_lt_le_compat. + + rewrite Qabs_Qminus. apply H. apply le_refl. assumption. + + apply Qle_lteq. left. apply H. apply le_refl. assumption. + + rewrite (factorDenom _ _ 2). ring_simplify. apply Qle_refl. + - ring. +Qed. + +Fixpoint increasing_modulus (modulus : positive -> nat) (n : nat) + := match n with + | O => modulus xH + | S p => max (modulus (Pos.of_nat n)) (increasing_modulus modulus p) + end. + +Lemma increasing_modulus_inc : forall (modulus : positive -> nat) (n p : nat), + le (increasing_modulus modulus n) + (increasing_modulus modulus (p + n)). +Proof. + induction p. + - apply le_refl. + - apply (le_trans _ (increasing_modulus modulus (p + n))). + apply IHp. simpl. destruct (plus p n). apply Nat.le_max_r. apply Nat.le_max_r. +Qed. + +Lemma increasing_modulus_max : forall (modulus : positive -> nat) (p n : nat), + le n p -> le (modulus (Pos.of_nat n)) + (increasing_modulus modulus p). +Proof. + induction p. + - intros. inversion H. subst n. apply le_refl. + - intros. simpl. destruct p. simpl. + + destruct n. apply Nat.le_max_l. apply le_S_n in H. + inversion H. apply Nat.le_max_l. + + apply Nat.le_succ_r in H. destruct H. + apply (le_trans _ (increasing_modulus modulus (S p))). + 2: apply Nat.le_max_r. apply IHp. apply H. + subst n. apply (le_trans _ (modulus (Pos.succ (Pos.of_nat (S p))))). + apply le_refl. apply Nat.le_max_l. +Qed. + +(* Choice of a standard element in each QSeqEquiv class. *) +Lemma standard_modulus : forall (un : nat -> Q) (cvmod : positive -> nat), + QCauchySeq un cvmod + -> (QCauchySeq (fun n => un (increasing_modulus cvmod n)) Pos.to_nat + /\ QSeqEquiv un (fun n => un (increasing_modulus cvmod n)) + (fun p => max (cvmod p) (Pos.to_nat p))). +Proof. + intros. split. + - intros k p q H0 H1. apply H. + + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). + apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). + rewrite Pos2Nat.id. apply le_refl. + destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. + destruct (Nat.le_exists_sub (Pos.to_nat k) p H0) as [i [H2 H3]]. subst p. + apply increasing_modulus_inc. + + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). + apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). + rewrite Pos2Nat.id. apply le_refl. + destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. + destruct (Nat.le_exists_sub (Pos.to_nat k) q H1) as [i [H2 H3]]. subst q. + apply increasing_modulus_inc. + - intros k p q H0 H1. apply H. + + apply (le_trans _ (Init.Nat.max (cvmod k) (Pos.to_nat k))). + apply Nat.le_max_l. assumption. + + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). + apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). + rewrite Pos2Nat.id. apply le_refl. + destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. + assert (le (Pos.to_nat k) q). + { apply (le_trans _ (Init.Nat.max (cvmod k) (Pos.to_nat k))). + apply Nat.le_max_r. assumption. } + destruct (Nat.le_exists_sub (Pos.to_nat k) q H2) as [i [H3 H4]]. subst q. + apply increasing_modulus_inc. +Qed. + +(* A Cauchy real is a Cauchy sequence with the standard modulus *) +Definition CReal : Set + := { x : (nat -> Q) | QCauchySeq x Pos.to_nat }. + +Declare Scope R_scope_constr. + +(* Declare Scope R_scope with Key R *) +Delimit Scope R_scope_constr with CReal. + +(* Automatically open scope R_scope for arguments of type R *) +Bind Scope R_scope_constr with CReal. + +Open Scope R_scope_constr. + + + + +(* The equality on Cauchy reals is just QSeqEquiv, + which is independant of the convergence modulus. *) +Lemma CRealEq_modindep : forall (x y : CReal), + QSeqEquivEx (proj1_sig x) (proj1_sig y) + <-> forall n:positive, Qle (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) + (2 # n). +Proof. + intros [xn limx] [yn limy]. unfold proj1_sig. split. + - intros [cvmod H] n. unfold proj1_sig in H. + apply Qle_limit. intros. + destruct (Qarchimedean (/eps)) as [k maj]. + remember (max (cvmod k) (Pos.to_nat n)) as p. + assert (le (cvmod k) p). + { rewrite Heqp. apply Nat.le_max_l. } + assert (Pos.to_nat n <= p)%nat. + { rewrite Heqp. apply Nat.le_max_r. } + specialize (H k p p H1 H1). + setoid_replace (xn (Pos.to_nat n) - yn (Pos.to_nat n)) + with (xn (Pos.to_nat n) - xn p + (xn p - yn p + (yn p - yn (Pos.to_nat n)))). + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat n) - xn p) + + Qabs (xn p - yn p + (yn p - yn (Pos.to_nat n))))). + apply Qabs_triangle. + setoid_replace (2 # n) with ((1 # n) + (1#n)). rewrite <- Qplus_assoc. + apply Qplus_lt_le_compat. + apply limx. apply le_refl. assumption. + apply (Qle_trans _ (Qabs (xn p - yn p) + Qabs (yn p - yn (Pos.to_nat n)))). + apply Qabs_triangle. rewrite (Qplus_comm (1#n)). apply Qplus_le_compat. + apply Qle_lteq. left. apply (Qlt_trans _ (1 # k)). + assumption. + setoid_replace (Z.pos k #1) with (/ (1#k)) in maj. 2: reflexivity. + apply Qinv_lt_contravar. reflexivity. apply H0. apply maj. + apply Qle_lteq. left. + apply limy. assumption. apply le_refl. + ring_simplify. reflexivity. field. + - intros. exists (fun q => Pos.to_nat (2 * (3 * q))). intros k p q H0 H1. + unfold proj1_sig. specialize (H (2 * (3 * k))%positive). + assert ((Pos.to_nat (3 * k) <= Pos.to_nat (2 * (3 * k)))%nat). + { generalize (3 * k)%positive. intros. rewrite Pos2Nat.inj_mul. + rewrite <- (mult_1_l (Pos.to_nat p0)). apply Nat.mul_le_mono_nonneg. + auto. unfold Pos.to_nat. simpl. auto. + apply (le_trans 0 1). auto. apply Pos2Nat.is_pos. rewrite mult_1_l. + apply le_refl. } + setoid_replace (xn p - yn q) + with (xn p - xn (Pos.to_nat (2 * (3 * k))) + + (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k))) + + (yn (Pos.to_nat (2 * (3 * k))) - yn q))). + setoid_replace (1 # k) with ((1 # 3 * k) + ((1 # 3 * k) + (1 # 3 * k))). + apply (Qle_lt_trans + _ (Qabs (xn p - xn (Pos.to_nat (2 * (3 * k)))) + + (Qabs (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k))) + + (yn (Pos.to_nat (2 * (3 * k))) - yn q))))). + apply Qabs_triangle. apply Qplus_lt_le_compat. + apply limx. apply (le_trans _ (Pos.to_nat (2 * (3 * k)))). assumption. assumption. + assumption. + apply (Qle_trans + _ (Qabs (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k)))) + + Qabs (yn (Pos.to_nat (2 * (3 * k))) - yn q))). + apply Qabs_triangle. apply Qplus_le_compat. + setoid_replace (1 # 3 * k) with (2 # 2 * (3 * k)). apply H. + rewrite (factorDenom _ _ 3). rewrite (factorDenom _ _ 2). rewrite (factorDenom _ _ 3). + rewrite Qmult_assoc. rewrite (Qmult_comm (1#2)). + rewrite <- Qmult_assoc. apply Qmult_comp. reflexivity. + unfold Qeq. reflexivity. + apply Qle_lteq. left. apply limy. assumption. + apply (le_trans _ (Pos.to_nat (2 * (3 * k)))). assumption. assumption. + rewrite (factorDenom _ _ 3). ring_simplify. reflexivity. field. +Qed. + + +(* So QSeqEquiv is the equivalence relation of this constructive pre-order *) +Definition CRealLt (x y : CReal) : Prop + := exists n : positive, Qlt (2 # n) + (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)). + +Definition CRealGt (x y : CReal) := CRealLt y x. +Definition CReal_appart (x y : CReal) := CRealLt x y \/ CRealLt y x. + +Infix "<" := CRealLt : R_scope_constr. +Infix ">" := CRealGt : R_scope_constr. +Infix "#" := CReal_appart : R_scope_constr. + +(* This Prop can be extracted as a sigma type *) +Lemma CRealLtEpsilon : forall x y : CReal, + x < y + -> { n : positive | Qlt (2 # n) + (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)) }. +Proof. + intros. + assert (exists n : nat, n <> O + /\ Qlt (2 # Pos.of_nat n) (proj1_sig y n - proj1_sig x n)). + { destruct H as [n maj]. exists (Pos.to_nat n). split. + intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. + inversion abs. rewrite Pos2Nat.id. apply maj. } + apply constructive_indefinite_ground_description_nat in H0. + destruct H0 as [n maj]. exists (Pos.of_nat n). + rewrite Nat2Pos.id. apply maj. apply maj. + intro n. destruct n. right. + intros [abs _]. exact (abs (eq_refl O)). + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) + (proj1_sig y (S n) - proj1_sig x (S n))). + left. split. discriminate. apply q. + right. intros [_ abs]. + apply (Qlt_not_le (2 # Pos.of_nat (S n)) + (proj1_sig y (S n) - proj1_sig x (S n))); assumption. +Qed. + +(* Alias the quotient order equality *) +Definition CRealEq (x y : CReal) : Prop + := ~CRealLt x y /\ ~CRealLt y x. + +Infix "==" := CRealEq : R_scope_constr. + +(* Alias the large order *) +Definition CRealLe (x y : CReal) : Prop + := ~CRealLt y x. + +Definition CRealGe (x y : CReal) := CRealLe y x. + +Infix "<=" := CRealLe : R_scope_constr. +Infix ">=" := CRealGe : R_scope_constr. + +Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope_constr. +Notation "x <= y < z" := (x <= y /\ y < z) : R_scope_constr. +Notation "x < y < z" := (x < y /\ y < z) : R_scope_constr. +Notation "x < y <= z" := (x < y /\ y <= z) : R_scope_constr. + +Lemma CRealLe_not_lt : forall x y : CReal, + (forall n:positive, Qle (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n)) + (2 # n)) + <-> x <= y. +Proof. + intros. split. + - intros. intro H0. destruct H0 as [n H0]. specialize (H n). + apply (Qle_not_lt (2 # n) (2 # n)). apply Qle_refl. + apply (Qlt_le_trans _ (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))). + assumption. assumption. + - intros. + destruct (Qlt_le_dec (2 # n) (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))). + exfalso. apply H. exists n. assumption. assumption. +Qed. + +Lemma CRealEq_diff : forall (x y : CReal), + CRealEq x y + <-> forall n:positive, Qle (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) + (2 # n). +Proof. + intros. split. + - intros. destruct H. apply Qabs_case. intro. + pose proof (CRealLe_not_lt x y) as [_ H2]. apply H2. assumption. + intro. pose proof (CRealLe_not_lt y x) as [_ H2]. + setoid_replace (- (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) + with (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)). + apply H2. assumption. ring. + - intros. split. apply CRealLe_not_lt. intro n. specialize (H n). + rewrite Qabs_Qminus in H. + apply (Qle_trans _ (Qabs (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)))). + apply Qle_Qabs. apply H. + apply CRealLe_not_lt. intro n. specialize (H n). + apply (Qle_trans _ (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n)))). + apply Qle_Qabs. apply H. +Qed. + +(* Extend separation to all indices above *) +Lemma CRealLt_aboveSig : forall (x y : CReal) (n : positive), + (Qlt (2 # n) + (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n))) + -> let (k, _) := Qarchimedean (/(proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n) - (2#n))) + in forall p:positive, + Pos.le (Pos.max n (2*k)) p + -> Qlt (2 # (Pos.max n (2*k))) + (proj1_sig y (Pos.to_nat p) - proj1_sig x (Pos.to_nat p)). +Proof. + intros [xn limx] [yn limy] n maj. + unfold proj1_sig; unfold proj1_sig in maj. + pose (yn (Pos.to_nat n) - xn (Pos.to_nat n)) as dn. + destruct (Qarchimedean (/(yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2#n)))) as [k kmaj]. + assert (0 < yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2 # n))%Q as H0. + { rewrite <- (Qplus_opp_r (2#n)). apply Qplus_lt_l. assumption. } + intros. + remember (yn (Pos.to_nat p) - xn (Pos.to_nat p)) as dp. + + rewrite <- (Qplus_0_r dp). rewrite <- (Qplus_opp_r dn). + rewrite (Qplus_comm dn). rewrite Qplus_assoc. + assert (Qlt (Qabs (dp - dn)) (2#n)). + { rewrite Heqdp. unfold dn. + setoid_replace (yn (Pos.to_nat p) - xn (Pos.to_nat p) - (yn (Pos.to_nat n) - xn (Pos.to_nat n))) + with (yn (Pos.to_nat p) - yn (Pos.to_nat n) + + (xn (Pos.to_nat n) - xn (Pos.to_nat p))). + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat p) - yn (Pos.to_nat n)) + + Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat p)))). + apply Qabs_triangle. + setoid_replace (2#n)%Q with ((1#n) + (1#n))%Q. + apply Qplus_lt_le_compat. apply limy. + apply Pos2Nat.inj_le. apply (Pos.le_trans _ (Pos.max n (2 * k))). + apply Pos.le_max_l. assumption. + apply le_refl. apply Qlt_le_weak. apply limx. apply le_refl. + apply Pos2Nat.inj_le. apply (Pos.le_trans _ (Pos.max n (2 * k))). + apply Pos.le_max_l. assumption. + rewrite Qinv_plus_distr. reflexivity. field. } + apply (Qle_lt_trans _ (-(2#n) + dn)). + rewrite Qplus_comm. unfold dn. apply Qlt_le_weak. + apply (Qle_lt_trans _ (2 # (2 * k))). apply Pos.le_max_r. + setoid_replace (2 # 2 * k)%Q with (1 # k)%Q. 2: reflexivity. + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. + apply Qinv_lt_contravar. reflexivity. apply H0. apply kmaj. + apply Qplus_lt_l. rewrite <- Qplus_0_r. rewrite <- (Qplus_opp_r dn). + rewrite Qplus_assoc. apply Qplus_lt_l. rewrite Qplus_comm. + rewrite <- (Qplus_0_r dp). rewrite <- (Qplus_opp_r (2#n)). + rewrite Qplus_assoc. apply Qplus_lt_l. + rewrite <- (Qplus_0_l dn). rewrite <- (Qplus_opp_r dp). + rewrite <- Qplus_assoc. apply Qplus_lt_r. rewrite Qplus_comm. + apply (Qle_lt_trans _ (Qabs (dp - dn))). rewrite Qabs_Qminus. + unfold Qminus. apply Qle_Qabs. assumption. +Qed. + +Lemma CRealLt_above : forall (x y : CReal), + CRealLt x y + -> exists k : positive, forall p:positive, + Pos.le k p -> Qlt (2 # k) (proj1_sig y (Pos.to_nat p) - proj1_sig x (Pos.to_nat p)). +Proof. + intros x y [n maj]. + pose proof (CRealLt_aboveSig x y n maj). + destruct (Qarchimedean (/ (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n) - (2 # n)))) + as [k kmaj]. + exists (Pos.max n (2*k)). apply H. +Qed. + +(* The CRealLt index separates the Cauchy sequences *) +Lemma CRealLt_above_same : forall (x y : CReal) (n : positive), + Qlt (2 # n) + (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)) + -> forall p:positive, Pos.le n p + -> Qlt (proj1_sig x (Pos.to_nat p)) (proj1_sig y (Pos.to_nat p)). +Proof. + intros [xn limx] [yn limy] n inf p H. + simpl. simpl in inf. + apply (Qplus_lt_l _ _ (- xn (Pos.to_nat n))). + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat p) + - xn (Pos.to_nat n)))). + apply Qle_Qabs. apply (Qlt_trans _ (1#n)). + apply limx. apply Pos2Nat.inj_le. assumption. apply le_refl. + rewrite <- (Qplus_0_r (yn (Pos.to_nat p))). + rewrite <- (Qplus_opp_r (yn (Pos.to_nat n))). + rewrite (Qplus_comm (yn (Pos.to_nat n))). rewrite Qplus_assoc. + rewrite <- Qplus_assoc. + setoid_replace (1#n)%Q with (-(1#n) + (2#n))%Q. apply Qplus_lt_le_compat. + apply (Qplus_lt_l _ _ (1#n)). rewrite Qplus_opp_r. + apply (Qplus_lt_r _ _ (yn (Pos.to_nat n) + - yn (Pos.to_nat p))). + ring_simplify. + setoid_replace (yn (Pos.to_nat n) + (-1 # 1) * yn (Pos.to_nat p)) + with (yn (Pos.to_nat n) - yn (Pos.to_nat p)). + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat n) - yn (Pos.to_nat p)))). + apply Qle_Qabs. apply limy. apply le_refl. apply Pos2Nat.inj_le. assumption. + field. apply Qle_lteq. left. assumption. + rewrite Qplus_comm. rewrite Qinv_minus_distr. + reflexivity. +Qed. + +Lemma CRealLt_asym : forall x y : CReal, x < y -> x <= y. +Proof. + intros x y H [n q]. + apply CRealLt_above in H. destruct H as [p H]. + pose proof (CRealLt_above_same y x n q). + destruct (PosLt_le_total n p). + - apply (Qlt_not_le (proj1_sig y (Pos.to_nat p)) (proj1_sig x (Pos.to_nat p))). + apply H0. unfold Pos.le. unfold Pos.lt in H1. rewrite H1. discriminate. + apply Qlt_le_weak. apply (Qplus_lt_l _ _ (-proj1_sig x (Pos.to_nat p))). + rewrite Qplus_opp_r. apply (Qlt_trans _ (2#p)). + unfold Qlt. simpl. unfold Z.lt. auto. apply H. apply Pos.le_refl. + - apply (Qlt_not_le (proj1_sig y (Pos.to_nat n)) (proj1_sig x (Pos.to_nat n))). + apply H0. apply Pos.le_refl. apply Qlt_le_weak. + apply (Qplus_lt_l _ _ (-proj1_sig x (Pos.to_nat n))). + rewrite Qplus_opp_r. apply (Qlt_trans _ (2#p)). + unfold Qlt. simpl. unfold Z.lt. auto. apply H. assumption. +Qed. + +Lemma CRealLt_irrefl : forall x:CReal, ~(x < x). +Proof. + intros x abs. exact (CRealLt_asym x x abs abs). +Qed. + +Lemma CRealLe_refl : forall x : CReal, x <= x. +Proof. + intros. intro abs. + pose proof (CRealLt_asym x x abs). contradiction. +Qed. + +Lemma CRealEq_refl : forall x : CReal, x == x. +Proof. + intros. split; apply CRealLe_refl. +Qed. + +Lemma CRealEq_sym : forall x y : CReal, CRealEq x y -> CRealEq y x. +Proof. + intros. destruct H. split; intro abs; contradiction. +Qed. + +Lemma CRealLt_dec : forall x y z : CReal, + CRealLt x y -> { CRealLt x z } + { CRealLt z y }. +Proof. + intros [xn limx] [yn limy] [zn limz] clt. + destruct (CRealLtEpsilon _ _ clt) as [n inf]. + unfold proj1_sig in inf. + remember (yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2 # n)) as eps. + assert (Qlt 0 eps) as epsPos. + { subst eps. unfold Qminus. apply (Qlt_minus_iff (2#n)). assumption. } + assert (forall n p, Pos.to_nat n <= Pos.to_nat (Pos.max n p))%nat. + { intros. apply Pos2Nat.inj_le. unfold Pos.max. unfold Pos.le. + destruct (n0 ?= p)%positive eqn:des. + rewrite des. discriminate. rewrite des. discriminate. + unfold Pos.compare. rewrite Pos.compare_cont_refl. discriminate. } + destruct (Qarchimedean (/eps)) as [k kmaj]. + destruct (Qlt_le_dec ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2#1)) + (zn (Pos.to_nat (Pos.max n (4 * k))))) + as [decMiddle|decMiddle]. + - left. exists (Pos.max n (4 * k)). unfold proj1_sig. unfold Qminus. + rewrite <- (Qplus_0_r (zn (Pos.to_nat (Pos.max n (4 * k))))). + rewrite <- (Qplus_opp_r (xn (Pos.to_nat n))). + rewrite (Qplus_comm (xn (Pos.to_nat n))). rewrite Qplus_assoc. + rewrite <- Qplus_assoc. rewrite <- Qplus_0_r. + rewrite <- (Qplus_opp_r (1#n)). rewrite Qplus_assoc. + apply Qplus_lt_le_compat. + + apply (Qplus_lt_l _ _ (- xn (Pos.to_nat n))) in decMiddle. + apply (Qlt_trans _ ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1) + + - xn (Pos.to_nat n))). + setoid_replace ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1) + - xn (Pos.to_nat n)) + with ((yn (Pos.to_nat n) - xn (Pos.to_nat n)) / (2 # 1)). + apply Qlt_shift_div_l. unfold Qlt. simpl. unfold Z.lt. auto. + rewrite Qmult_plus_distr_l. + setoid_replace ((1 # n) * (2 # 1))%Q with (2#n)%Q. + apply (Qplus_lt_l _ _ (-(2#n))). rewrite <- Qplus_assoc. + rewrite Qplus_opp_r. unfold Qminus. unfold Qminus in Heqeps. + rewrite <- Heqeps. rewrite Qplus_0_r. + apply (Qle_lt_trans _ (1 # k)). unfold Qle. + simpl. rewrite Pos.mul_1_r. rewrite Pos2Z.inj_max. + apply Z.le_max_r. + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. + apply Qinv_lt_contravar. reflexivity. apply epsPos. apply kmaj. + unfold Qeq. simpl. rewrite Pos.mul_1_r. reflexivity. + field. assumption. + + setoid_replace (xn (Pos.to_nat n) + - xn (Pos.to_nat (Pos.max n (4 * k)))) + with (-(xn (Pos.to_nat (Pos.max n (4 * k))) - xn (Pos.to_nat n))). + apply Qopp_le_compat. + apply (Qle_trans _ (Qabs (xn (Pos.to_nat (Pos.max n (4 * k))) - xn (Pos.to_nat n)))). + apply Qle_Qabs. apply Qle_lteq. left. apply limx. apply H. + apply le_refl. field. + - right. exists (Pos.max n (4 * k)). unfold proj1_sig. unfold Qminus. + rewrite <- (Qplus_0_r (yn (Pos.to_nat (Pos.max n (4 * k))))). + rewrite <- (Qplus_opp_r (yn (Pos.to_nat n))). + rewrite (Qplus_comm (yn (Pos.to_nat n))). rewrite Qplus_assoc. + rewrite <- Qplus_assoc. rewrite <- Qplus_0_l. + rewrite <- (Qplus_opp_r (1#n)). rewrite (Qplus_comm (1#n)). + rewrite <- Qplus_assoc. apply Qplus_lt_le_compat. + + apply (Qplus_lt_l _ _ (1#n)). rewrite Qplus_opp_r. + apply (Qplus_lt_r _ _ (yn (Pos.to_nat n) - yn (Pos.to_nat (Pos.max n (4 * k))))). + ring_simplify. rewrite Qmult_minus_one. + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat n) + - yn (Pos.to_nat (Pos.max n (4 * k)))))). + apply Qle_Qabs. apply limy. apply le_refl. apply H. + + apply Qopp_le_compat in decMiddle. + apply (Qplus_le_r _ _ (yn (Pos.to_nat n))) in decMiddle. + apply (Qle_trans _ (yn (Pos.to_nat n) + - ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1)))). + setoid_replace (yn (Pos.to_nat n) + - ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1))) + with ((yn (Pos.to_nat n) - xn (Pos.to_nat n)) / (2 # 1)). + apply Qle_shift_div_l. unfold Qlt. simpl. unfold Z.lt. auto. + rewrite Qmult_plus_distr_l. + setoid_replace ((1 # n) * (2 # 1))%Q with (2#n)%Q. + apply (Qplus_le_r _ _ (-(2#n))). rewrite Qplus_assoc. + rewrite Qplus_opp_r. rewrite Qplus_0_l. rewrite (Qplus_comm (-(2#n))). + unfold Qminus in Heqeps. unfold Qminus. rewrite <- Heqeps. + apply (Qle_trans _ (1 # k)). unfold Qle. + simpl. rewrite Pos.mul_1_r. rewrite Pos2Z.inj_max. + apply Z.le_max_r. apply Qle_lteq. left. + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. + apply Qinv_lt_contravar. reflexivity. apply epsPos. apply kmaj. + unfold Qeq. simpl. rewrite Pos.mul_1_r. reflexivity. + field. assumption. +Qed. + +Definition linear_order_T x y z := CRealLt_dec x z y. + +Lemma CRealLe_Lt_trans : forall x y z : CReal, + x <= y -> y < z -> x < z. +Proof. + intros. + destruct (linear_order_T y x z H0). contradiction. apply c. +Qed. + +Lemma CRealLt_Le_trans : forall x y z : CReal, + CRealLt x y + -> CRealLe y z -> CRealLt x z. +Proof. + intros. + destruct (linear_order_T x z y H). apply c. contradiction. +Qed. + +Lemma CRealLt_trans : forall x y z : CReal, + x < y -> y < z -> x < z. +Proof. + intros. apply (CRealLt_Le_trans _ y _ H). + apply CRealLt_asym. exact H0. +Qed. + +Lemma CRealEq_trans : forall x y z : CReal, + CRealEq x y -> CRealEq y z -> CRealEq x z. +Proof. + intros. destruct H,H0. split. + - intro abs. destruct (CRealLt_dec _ _ y abs); contradiction. + - intro abs. destruct (CRealLt_dec _ _ y abs); contradiction. +Qed. + +Add Parametric Relation : CReal CRealEq + reflexivity proved by CRealEq_refl + symmetry proved by CRealEq_sym + transitivity proved by CRealEq_trans + as CRealEq_rel. + +Add Parametric Morphism : CRealLt + with signature CRealEq ==> CRealEq ==> iff + as CRealLt_morph. +Proof. + intros. destruct H, H0. split. + - intro. destruct (CRealLt_dec x x0 y). assumption. + contradiction. destruct (CRealLt_dec y x0 y0). + assumption. assumption. contradiction. + - intro. destruct (CRealLt_dec y y0 x). assumption. + contradiction. destruct (CRealLt_dec x y0 x0). + assumption. assumption. contradiction. +Qed. + +Add Parametric Morphism : CRealGt + with signature CRealEq ==> CRealEq ==> iff + as CRealGt_morph. +Proof. + intros. unfold CRealGt. apply CRealLt_morph; assumption. +Qed. + +Add Parametric Morphism : CReal_appart + with signature CRealEq ==> CRealEq ==> iff + as CReal_appart_morph. +Proof. + split. + - intros. destruct H1. left. rewrite <- H0, <- H. exact H1. + right. rewrite <- H0, <- H. exact H1. + - intros. destruct H1. left. rewrite H0, H. exact H1. + right. rewrite H0, H. exact H1. +Qed. + +Add Parametric Morphism : CRealLe + with signature CRealEq ==> CRealEq ==> iff + as CRealLe_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 : CRealGe + with signature CRealEq ==> CRealEq ==> iff + as CRealGe_morph. +Proof. + intros. unfold CRealGe. apply CRealLe_morph; assumption. +Qed. + +Lemma CRealLt_proper_l : forall x y z : CReal, + CRealEq x y + -> CRealLt x z -> CRealLt y z. +Proof. + intros. apply (CRealLt_morph x y H z z). + apply CRealEq_refl. apply H0. +Qed. + +Lemma CRealLt_proper_r : forall x y z : CReal, + CRealEq x y + -> CRealLt z x -> CRealLt z y. +Proof. + intros. apply (CRealLt_morph z z (CRealEq_refl z) x y). + apply H. apply H0. +Qed. + +Lemma CRealLe_proper_l : forall x y z : CReal, + CRealEq x y + -> CRealLe x z -> CRealLe y z. +Proof. + intros. apply (CRealLe_morph x y H z z). + apply CRealEq_refl. apply H0. +Qed. + +Lemma CRealLe_proper_r : forall x y z : CReal, + CRealEq x y + -> CRealLe z x -> CRealLe z y. +Proof. + intros. apply (CRealLe_morph z z (CRealEq_refl z) x y). + apply H. apply H0. +Qed. + + + +(* Injection of Q into CReal *) + +Lemma ConstCauchy : forall q : Q, + QCauchySeq (fun _ => q) Pos.to_nat. +Proof. + intros. intros k p r H H0. + unfold Qminus. rewrite Qplus_opp_r. unfold Qlt. simpl. + unfold Z.lt. auto. +Qed. + +Definition inject_Q : Q -> CReal. +Proof. + intro q. exists (fun n => q). apply ConstCauchy. +Defined. + +Notation "0" := (inject_Q 0) : R_scope_constr. +Notation "1" := (inject_Q 1) : R_scope_constr. + +Lemma CRealLt_0_1 : CRealLt (inject_Q 0) (inject_Q 1). +Proof. + exists 3%positive. reflexivity. +Qed. + +Lemma CReal_injectQPos : forall q : Q, + Qlt 0 q -> CRealLt (inject_Q 0) (inject_Q q). +Proof. + intros. destruct (Qarchimedean ((2#1) / q)). + exists x. simpl. unfold Qminus. rewrite Qplus_0_r. + apply (Qmult_lt_compat_r _ _ q) in q0. 2: apply H. + unfold Qdiv in q0. + rewrite <- Qmult_assoc in q0. rewrite <- (Qmult_comm q) in q0. + rewrite Qmult_inv_r in q0. rewrite Qmult_1_r in q0. + unfold Qlt; simpl. unfold Qlt in q0; simpl in q0. + rewrite Z.mul_1_r in q0. destruct q; simpl. simpl in q0. + destruct Qnum. apply q0. + rewrite <- Pos2Z.inj_mul. rewrite Pos.mul_comm. apply q0. + inversion H. intro abs. rewrite abs in H. apply (Qlt_irrefl 0 H). +Qed. + +(* A rational number has a constant Cauchy sequence realizing it + as a real number, which increases the precision of the majoration + by a factor 2. *) +Lemma CRealLtQ : forall (x : CReal) (q : Q), + CRealLt x (inject_Q q) + -> forall p:positive, Qlt (proj1_sig x (Pos.to_nat p)) (q + (1#p)). +Proof. + intros [xn cau] q maj p. simpl. + destruct (Qlt_le_dec (xn (Pos.to_nat p)) (q + (1 # p))). assumption. + exfalso. + apply CRealLt_above in maj. + destruct maj as [k maj]; simpl in maj. + specialize (maj (Pos.max k p) (Pos.le_max_l _ _)). + specialize (cau p (Pos.to_nat p) (Pos.to_nat (Pos.max k p)) (le_refl _)). + pose proof (Qplus_lt_le_compat (2#k) (q - xn (Pos.to_nat (Pos.max k p))) + (q + (1 # p)) (xn (Pos.to_nat p)) maj q0). + rewrite Qplus_comm in H. unfold Qminus in H. rewrite <- Qplus_assoc in H. + rewrite <- Qplus_assoc in H. apply Qplus_lt_r in H. + rewrite <- (Qplus_lt_r _ _ (xn (Pos.to_nat p))) in maj. + apply (Qlt_not_le (1#p) ((1 # p) + (2 # k))). + rewrite <- (Qplus_0_r (1#p)). rewrite <- Qplus_assoc. + apply Qplus_lt_r. reflexivity. + apply Qlt_le_weak. + apply (Qlt_trans _ (- xn (Pos.to_nat (Pos.max k p)) + xn (Pos.to_nat p)) _ H). + rewrite Qplus_comm. + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat p) - xn (Pos.to_nat (Pos.max k p))))). + apply Qle_Qabs. apply cau. apply Pos2Nat.inj_le. apply Pos.le_max_r. +Qed. + +Lemma CRealLtQopp : forall (x : CReal) (q : Q), + CRealLt (inject_Q q) x + -> forall p:positive, Qlt (q - (1#p)) (proj1_sig x (Pos.to_nat p)). +Proof. + intros [xn cau] q maj p. simpl. + destruct (Qlt_le_dec (q - (1 # p)) (xn (Pos.to_nat p))). assumption. + exfalso. + apply CRealLt_above in maj. + destruct maj as [k maj]; simpl in maj. + specialize (maj (Pos.max k p) (Pos.le_max_l _ _)). + specialize (cau p (Pos.to_nat (Pos.max k p)) (Pos.to_nat p)). + pose proof (Qplus_lt_le_compat (2#k) (xn (Pos.to_nat (Pos.max k p)) - q) + (xn (Pos.to_nat p)) (q - (1 # p)) maj q0). + unfold Qminus in H. rewrite <- Qplus_assoc in H. + rewrite (Qplus_assoc (-q)) in H. rewrite (Qplus_comm (-q)) in H. + rewrite Qplus_opp_r in H. rewrite Qplus_0_l in H. + apply (Qplus_lt_l _ _ (1#p)) in H. + rewrite <- (Qplus_assoc (xn (Pos.to_nat (Pos.max k p)))) in H. + rewrite (Qplus_comm (-(1#p))) in H. rewrite Qplus_opp_r in H. + rewrite Qplus_0_r in H. rewrite Qplus_comm in H. + rewrite Qplus_assoc in H. apply (Qplus_lt_l _ _ (- xn (Pos.to_nat p))) in H. + rewrite <- Qplus_assoc in H. rewrite Qplus_opp_r in H. rewrite Qplus_0_r in H. + apply (Qlt_not_le (1#p) ((1 # p) + (2 # k))). + rewrite <- (Qplus_0_r (1#p)). rewrite <- Qplus_assoc. + apply Qplus_lt_r. reflexivity. + apply Qlt_le_weak. + apply (Qlt_trans _ (xn (Pos.to_nat (Pos.max k p)) - xn (Pos.to_nat p)) _ H). + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max k p)) - xn (Pos.to_nat p)))). + apply Qle_Qabs. apply cau. apply Pos2Nat.inj_le. + apply Pos.le_max_r. apply le_refl. +Qed. + + +(* Algebraic operations *) + +Lemma CReal_plus_cauchy + : forall (xn yn zn : nat -> Q) (cvmod : positive -> nat), + QSeqEquiv xn yn cvmod + -> QCauchySeq zn Pos.to_nat + -> QSeqEquiv (fun n:nat => xn n + zn n) (fun n:nat => yn n + zn n) + (fun p => max (cvmod (2 * p)%positive) + (Pos.to_nat (2 * p)%positive)). +Proof. + intros. intros p n k H1 H2. + setoid_replace (xn n + zn n - (yn k + zn k)) + with (xn n - yn k + (zn n - zn k)). + 2: field. + apply (Qle_lt_trans _ (Qabs (xn n - yn k) + Qabs (zn n - zn k))). + apply Qabs_triangle. + setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. + apply Qplus_lt_le_compat. + - apply H. apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). + apply Nat.le_max_l. apply H1. + apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). + apply Nat.le_max_l. apply H2. + - apply Qle_lteq. left. apply H0. + apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). + apply Nat.le_max_r. apply H1. + apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). + apply Nat.le_max_r. apply H2. + - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. +Qed. + +Definition CReal_plus (x y : CReal) : CReal. +Proof. + destruct x as [xn limx], y as [yn limy]. + pose proof (CReal_plus_cauchy xn xn yn Pos.to_nat limx limy). + exists (fun n : nat => xn (2 * n)%nat + yn (2 * n)%nat). + intros p k n H0 H1. apply H. + - rewrite max_l. rewrite Pos2Nat.inj_mul. + apply Nat.mul_le_mono_nonneg. apply le_0_n. apply le_refl. + apply le_0_n. apply H0. apply le_refl. + - rewrite Pos2Nat.inj_mul. rewrite max_l. + apply Nat.mul_le_mono_nonneg. apply le_0_n. apply le_refl. + apply le_0_n. apply H1. apply le_refl. +Defined. + +Infix "+" := CReal_plus : R_scope_constr. + +Lemma CReal_plus_unfold : forall (x y : CReal), + QSeqEquiv (proj1_sig (CReal_plus x y)) + (fun n : nat => proj1_sig x n + proj1_sig y n)%Q + (fun p => Pos.to_nat (2 * p)). +Proof. + intros [xn limx] [yn limy]. + unfold CReal_plus; simpl. + intros p n k H H0. + setoid_replace (xn (2 * n)%nat + yn (2 * n)%nat - (xn k + yn k))%Q + with (xn (2 * n)%nat - xn k + (yn (2 * n)%nat - yn k))%Q. + 2: field. + apply (Qle_lt_trans _ (Qabs (xn (2 * n)%nat - xn k) + Qabs (yn (2 * n)%nat - yn k))). + apply Qabs_triangle. + setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. + apply Qplus_lt_le_compat. + - apply limx. apply (le_trans _ n). apply H. + rewrite <- (mult_1_l n). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. simpl. auto. + apply le_0_n. apply le_refl. apply H0. + - apply Qlt_le_weak. apply limy. apply (le_trans _ n). apply H. + rewrite <- (mult_1_l n). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. simpl. auto. + apply le_0_n. apply le_refl. apply H0. + - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. +Qed. + +Definition CReal_opp (x : CReal) : CReal. +Proof. + destruct x as [xn limx]. + exists (fun n : nat => - xn n). + intros k p q H H0. unfold Qminus. rewrite Qopp_involutive. + rewrite Qsub_comm. apply limx; assumption. +Defined. + +Notation "- x" := (CReal_opp x) : R_scope_constr. + +Definition CReal_minus (x y : CReal) : CReal + := CReal_plus x (CReal_opp y). + +Infix "-" := CReal_minus : R_scope_constr. + +Lemma belowMultiple : forall n p : nat, lt 0 p -> le n (p * n). +Proof. + intros. rewrite <- (mult_1_l n). apply Nat.mul_le_mono_nonneg. + auto. assumption. apply le_0_n. rewrite mult_1_l. apply le_refl. +Qed. + +Lemma CReal_plus_assoc : forall (x y z : CReal), + CRealEq (CReal_plus (CReal_plus x y) z) + (CReal_plus x (CReal_plus y z)). +Proof. + intros. apply CRealEq_diff. intro n. + destruct x as [xn limx], y as [yn limy], z as [zn limz]. + unfold CReal_plus; unfold proj1_sig. + setoid_replace (xn (2 * (2 * Pos.to_nat n))%nat + yn (2 * (2 * Pos.to_nat n))%nat + + zn (2 * Pos.to_nat n)%nat + - (xn (2 * Pos.to_nat n)%nat + (yn (2 * (2 * Pos.to_nat n))%nat + + zn (2 * (2 * Pos.to_nat n))%nat)))%Q + with (xn (2 * (2 * Pos.to_nat n))%nat - xn (2 * Pos.to_nat n)%nat + + (zn (2 * Pos.to_nat n)%nat - zn (2 * (2 * Pos.to_nat n))%nat))%Q. + apply (Qle_trans _ (Qabs (xn (2 * (2 * Pos.to_nat n))%nat - xn (2 * Pos.to_nat n)%nat) + + Qabs (zn (2 * Pos.to_nat n)%nat - zn (2 * (2 * Pos.to_nat n))%nat))). + apply Qabs_triangle. + rewrite <- (Qinv_plus_distr 1 1 n). apply Qplus_le_compat. + apply Qle_lteq. left. apply limx. rewrite mult_assoc. + apply belowMultiple. simpl. auto. apply belowMultiple. auto. + apply Qle_lteq. left. apply limz. apply belowMultiple. auto. + rewrite mult_assoc. apply belowMultiple. simpl. auto. field. +Qed. + +Lemma CReal_plus_comm : forall x y : CReal, + x + y == y + x. +Proof. + intros [xn limx] [yn limy]. apply CRealEq_diff. intros. + unfold CReal_plus, proj1_sig. + setoid_replace (xn (2 * Pos.to_nat n)%nat + yn (2 * Pos.to_nat n)%nat + - (yn (2 * Pos.to_nat n)%nat + xn (2 * Pos.to_nat n)%nat))%Q + with 0%Q. + unfold Qle. simpl. unfold Z.le. intro absurd. inversion absurd. + field. +Qed. + +Lemma CReal_plus_0_l : forall r : CReal, + CRealEq (CReal_plus (inject_Q 0) r) r. +Proof. + intro r. assert (forall n:nat, le n (2 * n)). + { intro n. simpl. rewrite <- (plus_0_r n). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. } + split. + - intros [n maj]. destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. + rewrite Qplus_0_l in maj. + specialize (q n (Pos.to_nat n) (mult 2 (Pos.to_nat n)) (le_refl _)). + apply (Qlt_not_le (2#n) (xn (Pos.to_nat n) - xn (2 * Pos.to_nat n)%nat)). + assumption. + apply (Qle_trans _ (Qabs (xn (Pos.to_nat n) - xn (2 * Pos.to_nat n)%nat))). + apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Qlt_le_weak. apply q. + apply H. unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_xO. + apply H. + - intros [n maj]. destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. + rewrite Qplus_0_l in maj. + specialize (q n (Pos.to_nat n) (mult 2 (Pos.to_nat n)) (le_refl _)). + rewrite Qabs_Qminus in q. + apply (Qlt_not_le (2#n) (xn (mult 2 (Pos.to_nat n)) - xn (Pos.to_nat n))). + assumption. + apply (Qle_trans _ (Qabs (xn (mult 2 (Pos.to_nat n)) - xn (Pos.to_nat n)))). + apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Qlt_le_weak. apply q. + apply H. unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_xO. + apply H. +Qed. + +Lemma CReal_plus_lt_compat_l : + forall x y z : CReal, + CRealLt y z + -> CRealLt (CReal_plus x y) (CReal_plus x z). +Proof. + intros. + apply CRealLt_above in H. destruct H as [n maj]. + exists n. specialize (maj (xO n)). + rewrite Pos2Nat.inj_xO in maj. + setoid_replace (proj1_sig (CReal_plus x z) (Pos.to_nat n) + - proj1_sig (CReal_plus x y) (Pos.to_nat n))%Q + with (proj1_sig z (2 * Pos.to_nat n)%nat - proj1_sig y (2 * Pos.to_nat n)%nat)%Q. + apply maj. apply Pos2Nat.inj_le. + rewrite <- (plus_0_r (Pos.to_nat n)). rewrite Pos2Nat.inj_xO. + simpl. apply Nat.add_le_mono_l. apply le_0_n. + simpl. destruct x as [xn limx], y as [yn limy], z as [zn limz]. + simpl; ring. +Qed. + +Lemma CReal_plus_lt_reg_l : + forall x y z : CReal, + CRealLt (CReal_plus x y) (CReal_plus x z) + -> CRealLt y z. +Proof. + intros. destruct H as [n maj]. exists (2*n)%positive. + setoid_replace (proj1_sig z (Pos.to_nat (2 * n)) - proj1_sig y (Pos.to_nat (2 * n)))%Q + with (proj1_sig (CReal_plus x z) (Pos.to_nat n) - proj1_sig (CReal_plus x y) (Pos.to_nat n))%Q. + apply (Qle_lt_trans _ (2#n)). unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. + rewrite <- (plus_0_r (Pos.to_nat n~0)). rewrite (Pos2Nat.inj_xO (n~0)). + simpl. apply Nat.add_le_mono_l. apply le_0_n. + apply maj. rewrite Pos2Nat.inj_xO. + destruct x as [xn limx], y as [yn limy], z as [zn limz]. + simpl; ring. +Qed. + +Lemma CReal_plus_opp_r : forall x : CReal, + x + - x == 0. +Proof. + intros [xn limx]. apply CRealEq_diff. intros. + unfold CReal_plus, CReal_opp, inject_Q, proj1_sig. + setoid_replace (xn (2 * Pos.to_nat n)%nat + - xn (2 * Pos.to_nat n)%nat - 0)%Q + with 0%Q. + unfold Qle. simpl. unfold Z.le. intro absurd. inversion absurd. field. +Qed. + +Lemma CReal_plus_proper_r : forall x y z : CReal, + CRealEq x y -> CRealEq (CReal_plus x z) (CReal_plus y z). +Proof. + intros. apply (CRealEq_trans _ (CReal_plus z x)). + apply CReal_plus_comm. apply (CRealEq_trans _ (CReal_plus z y)). + 2: apply CReal_plus_comm. + split. intro abs. apply CReal_plus_lt_reg_l in abs. + destruct H. contradiction. intro abs. apply CReal_plus_lt_reg_l in abs. + destruct H. contradiction. +Qed. + +Lemma CReal_plus_proper_l : forall x y z : CReal, + CRealEq x y -> CRealEq (CReal_plus z x) (CReal_plus z y). +Proof. + intros. split. intro abs. apply CReal_plus_lt_reg_l in abs. + destruct H. contradiction. intro abs. apply CReal_plus_lt_reg_l in abs. + destruct H. contradiction. +Qed. + +Add Parametric Morphism : CReal_plus + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_plus_morph. +Proof. + intros x y H z t H0. apply (CRealEq_trans _ (CReal_plus x t)). + - destruct H0. + split. intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. + intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. + - apply CReal_plus_proper_r. apply H. +Qed. + +Lemma CReal_plus_eq_reg_l : forall (r r1 r2 : CReal), + CRealEq (CReal_plus r r1) (CReal_plus r r2) + -> CRealEq r1 r2. +Proof. + intros. destruct H. split. + - intro abs. apply (CReal_plus_lt_compat_l r) in abs. contradiction. + - intro abs. apply (CReal_plus_lt_compat_l r) in abs. contradiction. +Qed. + +Fixpoint BoundFromZero (qn : nat -> Q) (k : nat) (A : positive) {struct k} + : (forall n:nat, le k n -> Qlt (Qabs (qn n)) (Z.pos A # 1)) + -> { B : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos B # 1) }. +Proof. + intro H. destruct k. + - exists A. intros. apply H. apply le_0_n. + - destruct (Qarchimedean (Qabs (qn k))) as [a maj]. + apply (BoundFromZero qn k (Pos.max A a)). + intros n H0. destruct (Nat.le_gt_cases n k). + + pose proof (Nat.le_antisymm n k H1 H0). subst k. + apply (Qlt_le_trans _ (Z.pos a # 1)). apply maj. + unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. + apply Pos.le_max_r. + + apply (Qlt_le_trans _ (Z.pos A # 1)). apply H. + apply H1. unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. + apply Pos.le_max_l. +Qed. + +Lemma QCauchySeq_bounded (qn : nat -> Q) (cvmod : positive -> nat) + : QCauchySeq qn cvmod + -> { A : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos A # 1) }. +Proof. + intros. remember (Zplus (Qnum (Qabs (qn (cvmod xH)))) 1) as z. + assert (Z.lt 0 z) as zPos. + { subst z. assert (Qle 0 (Qabs (qn (cvmod 1%positive)))). + apply Qabs_nonneg. destruct (Qabs (qn (cvmod 1%positive))). simpl. + unfold Qle in H0. simpl in H0. rewrite Zmult_1_r in H0. + apply (Z.lt_le_trans 0 1). unfold Z.lt. auto. + rewrite <- (Zplus_0_l 1). rewrite Zplus_assoc. apply Zplus_le_compat_r. + rewrite Zplus_0_r. assumption. } + assert { A : positive | forall n:nat, + le (cvmod xH) n -> Qlt ((Qabs (qn n)) * (1#A)) 1 }. + destruct z eqn:des. + - exfalso. apply (Z.lt_irrefl 0). assumption. + - exists p. intros. specialize (H xH (cvmod xH) n (le_refl _) H0). + assert (Qlt (Qabs (qn n)) (Qabs (qn (cvmod 1%positive)) + 1)). + { apply (Qplus_lt_l _ _ (-Qabs (qn (cvmod 1%positive)))). + rewrite <- (Qplus_comm 1). rewrite <- Qplus_assoc. rewrite Qplus_opp_r. + rewrite Qplus_0_r. apply (Qle_lt_trans _ (Qabs (qn n - qn (cvmod 1%positive)))). + apply Qabs_triangle_reverse. rewrite Qabs_Qminus. assumption. } + apply (Qlt_le_trans _ ((Qabs (qn (cvmod 1%positive)) + 1) * (1#p))). + apply Qmult_lt_r. unfold Qlt. simpl. unfold Z.lt. auto. assumption. + unfold Qle. simpl. rewrite Zmult_1_r. rewrite Zmult_1_r. rewrite Zmult_1_r. + rewrite Pos.mul_1_r. rewrite Pos2Z.inj_mul. rewrite Heqz. + destruct (Qabs (qn (cvmod 1%positive))) eqn:desAbs. + rewrite Z.mul_add_distr_l. rewrite Zmult_1_r. + apply Zplus_le_compat_r. rewrite <- (Zmult_1_l (QArith_base.Qnum (Qnum # Qden))). + rewrite Zmult_assoc. apply Zmult_le_compat_r. rewrite Zmult_1_r. + simpl. unfold Z.le. rewrite <- Pos2Z.inj_compare. + unfold Pos.compare. destruct Qden; discriminate. + simpl. assert (Qle 0 (Qnum # Qden)). rewrite <- desAbs. + apply Qabs_nonneg. unfold Qle in H2. simpl in H2. rewrite Zmult_1_r in H2. + assumption. + - exfalso. inversion zPos. + - destruct H0. apply (BoundFromZero _ (cvmod xH) x). intros n H0. + specialize (q n H0). setoid_replace (Z.pos x # 1)%Q with (/(1#x))%Q. + rewrite <- (Qmult_1_l (/(1#x))). apply Qlt_shift_div_l. + reflexivity. apply q. reflexivity. +Qed. + +Lemma CReal_mult_cauchy + : forall (xn yn zn : nat -> Q) (Ay Az : positive) (cvmod : positive -> nat), + QSeqEquiv xn yn cvmod + -> QCauchySeq zn Pos.to_nat + -> (forall n:nat, Qlt (Qabs (yn n)) (Z.pos Ay # 1)) + -> (forall n:nat, Qlt (Qabs (zn n)) (Z.pos Az # 1)) + -> QSeqEquiv (fun n:nat => xn n * zn n) (fun n:nat => yn n * zn n) + (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) + (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). +Proof. + intros xn yn zn Ay Az cvmod limx limz majy majz. + remember (Pos.mul 2 (Pos.max Ay Az)) as z. + intros k p q H H0. + assert (Pos.to_nat k <> O) as kPos. + { intro absurd. pose proof (Pos2Nat.is_pos k). + rewrite absurd in H1. inversion H1. } + setoid_replace (xn p * zn p - yn q * zn q)%Q + with ((xn p - yn q) * zn p + yn q * (zn p - zn q))%Q. + 2: ring. + apply (Qle_lt_trans _ (Qabs ((xn p - yn q) * zn p) + + Qabs (yn q * (zn p - zn q)))). + apply Qabs_triangle. rewrite Qabs_Qmult. rewrite Qabs_Qmult. + setoid_replace (1#k)%Q with ((1#2*k) + (1#2*k))%Q. + apply Qplus_lt_le_compat. + - apply (Qle_lt_trans _ ((1#z * k) * Qabs (zn p)%nat)). + + apply Qmult_le_compat_r. apply Qle_lteq. left. apply limx. + apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). + apply Nat.le_max_l. assumption. + apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). + apply Nat.le_max_l. assumption. apply Qabs_nonneg. + + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). + rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. + rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. + apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. + apply (Qle_lt_trans _ (Qabs (zn p)%nat * (1 # Az))). + rewrite <- (Qmult_comm (1 # Az)). apply Qmult_le_compat_r. + unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_r. + apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Az)). + rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. + setoid_replace (/(1#Az))%Q with (Z.pos Az # 1)%Q. apply majz. + reflexivity. intro abs. inversion abs. + - apply (Qle_trans _ ((1 # z * k) * Qabs (yn q)%nat)). + + rewrite Qmult_comm. apply Qmult_le_compat_r. apply Qle_lteq. + left. apply limz. + apply (le_trans _ (max (cvmod (z * k)%positive) + (Pos.to_nat (z * k)%positive))). + apply Nat.le_max_r. assumption. + apply (le_trans _ (max (cvmod (z * k)%positive) + (Pos.to_nat (z * k)%positive))). + apply Nat.le_max_r. assumption. apply Qabs_nonneg. + + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). + rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. + rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. + apply Qle_lteq. left. + apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. + apply (Qle_lt_trans _ (Qabs (yn q)%nat * (1 # Ay))). + rewrite <- (Qmult_comm (1 # Ay)). apply Qmult_le_compat_r. + unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_l. + apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Ay)). + rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. + setoid_replace (/(1#Ay))%Q with (Z.pos Ay # 1)%Q. apply majy. + reflexivity. intro abs. inversion abs. + - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. +Qed. + +Lemma linear_max : forall (p Ax Ay : positive) (i : nat), + le (Pos.to_nat p) i + -> (Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) + (Pos.to_nat (2 * Pos.max Ax Ay * p)) <= Pos.to_nat (2 * Pos.max Ax Ay) * i)%nat. +Proof. + intros. rewrite max_l. 2: apply le_refl. + rewrite Pos2Nat.inj_mul. apply Nat.mul_le_mono_nonneg. + apply le_0_n. apply le_refl. apply le_0_n. apply H. +Qed. + +Definition CReal_mult (x y : CReal) : CReal. +Proof. + destruct x as [xn limx]. destruct y as [yn limy]. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + exists (fun n : nat => xn (Pos.to_nat (2 * Pos.max Ax Ay)* n)%nat + * yn (Pos.to_nat (2 * Pos.max Ax Ay) * n)%nat). + intros p n k H0 H1. + apply H; apply linear_max; assumption. +Defined. + +Infix "*" := CReal_mult : R_scope_constr. + +Lemma CReal_mult_unfold : forall x y : CReal, + QSeqEquivEx (proj1_sig (CReal_mult x y)) + (fun n : nat => proj1_sig x n * proj1_sig y n)%Q. +Proof. + intros [xn limx] [yn limy]. unfold CReal_mult ; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + simpl. + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) + (Pos.to_nat (2 * Pos.max Ax Ay * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + apply H. apply linear_max. + apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). + rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. + apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. + apply le_0_n. apply le_refl. apply H0. rewrite max_l. + apply H1. apply le_refl. +Qed. + +Lemma CReal_mult_assoc_bounded_r : forall (xn yn zn : nat -> Q), + QSeqEquivEx xn yn (* both are Cauchy with same limit *) + -> QSeqEquiv zn zn Pos.to_nat + -> QSeqEquivEx (fun n => xn n * zn n)%Q (fun n => yn n * zn n)%Q. +Proof. + intros. destruct H as [cvmod cveq]. + destruct (QCauchySeq_bounded yn (fun k => cvmod (2 * k)%positive) + (QSeqEquiv_cau_r xn yn cvmod cveq)) + as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat H0) as [Az majz]. + exists (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) + (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). + apply CReal_mult_cauchy; assumption. +Qed. + +Lemma CReal_mult_assoc : forall x y z : CReal, + CRealEq (CReal_mult (CReal_mult x y) z) + (CReal_mult x (CReal_mult y z)). +Proof. + intros. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n * proj1_sig z n)%Q). + - apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n * proj1_sig z n)%Q). + apply CReal_mult_unfold. + destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + apply CReal_mult_assoc_bounded_r. 2: apply limz. + simpl. + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) + (Pos.to_nat (2 * Pos.max Ax Ay * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + apply H. apply linear_max. + apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). + rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. + apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. + apply le_0_n. apply le_refl. apply H0. rewrite max_l. + apply H1. apply le_refl. + - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig (CReal_mult y z) n)%Q). + 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. + destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + simpl. + pose proof (CReal_mult_assoc_bounded_r (fun n0 : nat => yn n0 * zn n0)%Q (fun n : nat => + yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat + * zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat)%Q xn) + as [cvmod cveq]. + + pose proof (CReal_mult_cauchy yn yn zn Ay Az Pos.to_nat limy limz majy majz). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Az * p)) + (Pos.to_nat (2 * Pos.max Ay Az * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + apply H. rewrite max_l. apply H0. apply le_refl. + apply linear_max. + apply (le_trans _ (Pos.to_nat (2 * Pos.max Ay Az * p))). + rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. + apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. + apply le_0_n. apply le_refl. apply H1. + apply limx. + exists cvmod. intros p k n H1 H2. specialize (cveq p k n H1 H2). + setoid_replace (xn k * yn k * zn k - + xn n * + (yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * + zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat))%Q + with ((fun n : nat => yn n * zn n * xn n) k - + (fun n : nat => + yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * + zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * + xn n) n)%Q. + apply cveq. ring. +Qed. + +Lemma CReal_mult_comm : forall x y : CReal, + CRealEq (CReal_mult x y) (CReal_mult y x). +Proof. + intros. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig y n * proj1_sig x n)%Q). + destruct x as [xn limx], y as [yn limy]; simpl. + 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]; simpl. + apply QSeqEquivEx_sym. + + pose proof (CReal_mult_cauchy yn yn xn Ay Ax Pos.to_nat limy limx majy majx). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Ax * p)) + (Pos.to_nat (2 * Pos.max Ay Ax * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + rewrite (Qmult_comm (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)). + apply (H p n). rewrite max_l. apply H0. apply le_refl. + rewrite max_l. apply (le_trans _ k). apply H1. + rewrite <- (mult_1_l k). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. + apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. + apply le_refl. +Qed. + +(* Axiom Rmult_eq_compat_l *) +Lemma CReal_mult_proper_l : forall x y z : CReal, + CRealEq y z -> CRealEq (CReal_mult x y) (CReal_mult x z). +Proof. + intros. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n)%Q). + apply CReal_mult_unfold. + rewrite CRealEq_diff in H. rewrite <- CRealEq_modindep in H. + apply QSeqEquivEx_sym. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig z n)%Q). + apply CReal_mult_unfold. + destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. + destruct H. simpl in H. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + pose proof (CReal_mult_cauchy yn zn xn Az Ax x H limx majz majx). + apply QSeqEquivEx_sym. + exists (fun p : positive => + Init.Nat.max (x (2 * Pos.max Az Ax * p)%positive) + (Pos.to_nat (2 * Pos.max Az Ax * p))). + intros p n k H1 H2. specialize (H0 p n k H1 H2). + setoid_replace (xn n * yn n - xn k * zn k)%Q + with (yn n * xn n - zn k * xn k)%Q. + apply H0. ring. +Qed. + +Lemma CReal_mult_lt_0_compat : forall x y : CReal, + CRealLt (inject_Q 0) x + -> CRealLt (inject_Q 0) y + -> CRealLt (inject_Q 0) (CReal_mult x y). +Proof. + intros. destruct H, H0. + pose proof (CRealLt_aboveSig (inject_Q 0) x x0 H). + pose proof (CRealLt_aboveSig (inject_Q 0) y x1 H0). + destruct x as [xn limx], y as [yn limy]. + simpl in H, H1, H2. simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (Qarchimedean (/ (xn (Pos.to_nat x0) - 0 - (2 # x0)))). + destruct (Qarchimedean (/ (yn (Pos.to_nat x1) - 0 - (2 # x1)))). + exists (Pos.max x0 x~0 * Pos.max x1 x2~0)%positive. + simpl. unfold Qminus. rewrite Qplus_0_r. + rewrite <- Pos2Nat.inj_mul. + unfold Qminus in H1, H2. + specialize (H1 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive). + assert (Pos.max x1 x2~0 <= (Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive. + { apply Pos2Nat.inj_le. + rewrite Pos.mul_assoc. rewrite Pos2Nat.inj_mul. + rewrite <- (mult_1_l (Pos.to_nat (Pos.max x1 x2~0))). + rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. + rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. + apply le_refl. } + specialize (H2 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive H3). + rewrite Qplus_0_r in H1, H2. + apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (2 # Pos.max x1 x2~0))). + unfold Qlt; simpl. assert (forall p : positive, (Z.pos p < Z.pos p~0)%Z). + intro p. rewrite <- (Z.mul_1_l (Z.pos p)). + replace (Z.pos p~0) with (2 * Z.pos p)%Z. apply Z.mul_lt_mono_pos_r. + apply Pos2Z.is_pos. reflexivity. reflexivity. + apply H4. + apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (yn (Pos.to_nat ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0)))))). + apply Qmult_lt_l. reflexivity. apply H2. apply Qmult_lt_r. + apply (Qlt_trans 0 (2 # Pos.max x1 x2~0)). reflexivity. apply H2. + apply H1. rewrite Pos.mul_comm. apply Pos2Nat.inj_le. + rewrite <- Pos.mul_assoc. rewrite Pos2Nat.inj_mul. + rewrite <- (mult_1_r (Pos.to_nat (Pos.max x0 x~0))). + rewrite <- mult_assoc. apply Nat.mul_le_mono_nonneg. + apply le_0_n. apply le_refl. auto. + rewrite mult_1_l. apply Pos2Nat.is_pos. +Qed. + +Lemma CReal_mult_plus_distr_l : forall r1 r2 r3 : CReal, + CRealEq (CReal_mult r1 (CReal_plus r2 r3)) + (CReal_plus (CReal_mult r1 r2) (CReal_mult r1 r3)). +Proof. + intros x y z. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n + * (proj1_sig (CReal_plus y z) n))%Q). + apply CReal_mult_unfold. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n + + proj1_sig (CReal_mult x z) n))%Q. + 2: apply QSeqEquivEx_sym; exists (fun p => Pos.to_nat (2 * p)) + ; apply CReal_plus_unfold. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n + * (proj1_sig y n + proj1_sig z n))%Q). + - pose proof (CReal_plus_unfold y z). + destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl; simpl in H. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + pose proof (CReal_mult_cauchy (fun n => yn (n + (n + 0))%nat + zn (n + (n + 0))%nat)%Q + (fun n => yn n + zn n)%Q + xn (Ay + Az) Ax + (fun p => Pos.to_nat (2 * p)) H limx). + exists (fun p : positive => (Pos.to_nat (2 * (2 * Pos.max (Ay + Az) Ax * p)))). + intros p n k H1 H2. + setoid_replace (xn n * (yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) - xn k * (yn k + zn k))%Q + with ((yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) * xn n - (yn k + zn k) * xn k)%Q. + 2: ring. + assert (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p) <= + Pos.to_nat 2 * Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))%nat. + { rewrite (Pos2Nat.inj_mul 2). + rewrite <- (mult_1_l (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))). + rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. + simpl. auto. apply le_0_n. apply le_refl. } + apply H0. intro n0. apply (Qle_lt_trans _ (Qabs (yn n0) + Qabs (zn n0))). + apply Qabs_triangle. rewrite Pos2Z.inj_add. + rewrite <- Qinv_plus_distr. apply Qplus_lt_le_compat. + apply majy. apply Qlt_le_weak. apply majz. + apply majx. rewrite max_l. + apply H1. rewrite (Pos2Nat.inj_mul 2). apply H3. + rewrite max_l. apply H2. rewrite (Pos2Nat.inj_mul 2). + apply H3. + - destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + simpl. + exists (fun p : positive => (Pos.to_nat (2 * (Pos.max (Pos.max Ax Ay) Az) * (2 * p)))). + intros p n k H H0. + setoid_replace (xn n * (yn n + zn n) - + (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * + yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat + + xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * + zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q + with (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * + yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat) + + (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * + zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q. + 2: ring. + apply (Qle_lt_trans _ (Qabs (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * + yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)) + + Qabs (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * + zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))). + apply Qabs_triangle. + setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. + apply Qplus_lt_le_compat. + + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy). + apply H1. apply majx. apply majy. rewrite max_l. + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H. apply le_refl. + rewrite max_l. apply (le_trans _ k). + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H0. + rewrite <- (mult_1_l k). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. + rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. + apply le_refl. apply le_refl. + + apply Qlt_le_weak. + pose proof (CReal_mult_cauchy xn xn zn Ax Az Pos.to_nat limx limz). + apply H1. apply majx. apply majz. rewrite max_l. 2: apply le_refl. + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). + rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H. + rewrite max_l. apply (le_trans _ k). + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). + rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H0. + rewrite <- (mult_1_l k). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. + rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. + apply le_refl. apply le_refl. + + rewrite Qinv_plus_distr. unfold Qeq. reflexivity. +Qed. + +Lemma CReal_mult_1_l : forall r: CReal, 1 * r == r. +Proof. + intros [rn limr]. split. + - intros [m maj]. simpl in maj. + destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). + destruct (QCauchySeq_bounded rn Pos.to_nat limr). + simpl in maj. rewrite Qmult_1_l in maj. + specialize (limr m). + apply (Qlt_not_le (2 # m) (1 # m)). + apply (Qlt_trans _ (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat)). + apply maj. + apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat))). + apply Qle_Qabs. apply limr. apply le_refl. + rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. + apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. + apply Z.mul_le_mono_nonneg. discriminate. discriminate. + discriminate. apply Z.le_refl. + - intros [m maj]. simpl in maj. + destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). + destruct (QCauchySeq_bounded rn Pos.to_nat limr). + simpl in maj. rewrite Qmult_1_l in maj. + specialize (limr m). + apply (Qlt_not_le (2 # m) (1 # m)). + apply (Qlt_trans _ (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m))). + apply maj. + apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m)))). + apply Qle_Qabs. apply limr. + rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. + apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. + apply le_refl. apply Z.mul_le_mono_nonneg. discriminate. discriminate. + discriminate. apply Z.le_refl. +Qed. + +Lemma CReal_isRingExt : ring_eq_ext CReal_plus CReal_mult CReal_opp CRealEq. +Proof. + split. + - intros x y H z t H0. apply CReal_plus_morph; assumption. + - intros x y H z t H0. apply (CRealEq_trans _ (CReal_mult x t)). + apply CReal_mult_proper_l. apply H0. + apply (CRealEq_trans _ (CReal_mult t x)). apply CReal_mult_comm. + apply (CRealEq_trans _ (CReal_mult t y)). + apply CReal_mult_proper_l. apply H. apply CReal_mult_comm. + - intros x y H. apply (CReal_plus_eq_reg_l x). + apply (CRealEq_trans _ (inject_Q 0)). apply CReal_plus_opp_r. + apply (CRealEq_trans _ (CReal_plus y (CReal_opp y))). + apply CRealEq_sym. apply CReal_plus_opp_r. + apply CReal_plus_proper_r. apply CRealEq_sym. apply H. +Qed. + +Lemma CReal_isRing : ring_theory (inject_Q 0) (inject_Q 1) + CReal_plus CReal_mult + CReal_minus CReal_opp + CRealEq. +Proof. + intros. split. + - apply CReal_plus_0_l. + - apply CReal_plus_comm. + - intros x y z. symmetry. apply CReal_plus_assoc. + - apply CReal_mult_1_l. + - apply CReal_mult_comm. + - intros x y z. symmetry. apply CReal_mult_assoc. + - intros x y z. rewrite <- (CReal_mult_comm z). + rewrite CReal_mult_plus_distr_l. + apply (CRealEq_trans _ (CReal_plus (CReal_mult x z) (CReal_mult z y))). + apply CReal_plus_proper_r. apply CReal_mult_comm. + apply CReal_plus_proper_l. apply CReal_mult_comm. + - intros x y. apply CRealEq_refl. + - apply CReal_plus_opp_r. +Qed. + +Add Parametric Morphism : CReal_mult + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_mult_morph. +Proof. + apply CReal_isRingExt. +Qed. + +Add Parametric Morphism : CReal_opp + with signature CRealEq ==> CRealEq + as CReal_opp_morph. +Proof. + apply (Ropp_ext CReal_isRingExt). +Qed. + +Add Parametric Morphism : CReal_minus + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_minus_morph. +Proof. + intros. unfold CReal_minus. rewrite H,H0. reflexivity. +Qed. + +Add Ring CRealRing : CReal_isRing. + +(**********) +Lemma CReal_mult_0_l : forall r, 0 * r == 0. +Proof. + intro; ring. +Qed. + +(**********) +Lemma CReal_mult_1_r : forall r, r * 1 == r. +Proof. + intro; ring. +Qed. + +Lemma CReal_opp_mult_distr_l + : forall r1 r2 : CReal, CRealEq (CReal_opp (CReal_mult r1 r2)) + (CReal_mult (CReal_opp r1) r2). +Proof. + intros. ring. +Qed. + +Lemma CReal_mult_lt_compat_l : forall x y z : CReal, + CRealLt (inject_Q 0) x + -> CRealLt y z + -> CRealLt (CReal_mult x y) (CReal_mult x z). +Proof. + intros. apply (CReal_plus_lt_reg_l + (CReal_opp (CReal_mult x y))). + rewrite CReal_plus_comm. pose proof CReal_plus_opp_r. + unfold CReal_minus in H1. rewrite H1. + rewrite CReal_mult_comm, CReal_opp_mult_distr_l, CReal_mult_comm. + rewrite <- CReal_mult_plus_distr_l. + apply CReal_mult_lt_0_compat. exact H. + apply (CReal_plus_lt_reg_l y). + rewrite CReal_plus_comm, CReal_plus_0_l. + rewrite <- CReal_plus_assoc, H1, CReal_plus_0_l. exact H0. +Qed. + +Lemma CReal_mult_eq_reg_l : forall (r r1 r2 : CReal), + r # 0 + -> CRealEq (CReal_mult r r1) (CReal_mult r r2) + -> CRealEq r1 r2. +Proof. + intros. destruct H; split. + - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. + rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. + exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). + rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact H. + - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. + rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. + exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). + rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact H. + - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. + exact (CRealLt_irrefl _ abs). exact H. + - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. + exact (CRealLt_irrefl _ abs). exact H. +Qed. + + + +(*********************************************************) +(** * Field *) +(*********************************************************) + +(**********) +Fixpoint INR (n:nat) : CReal := + match n with + | O => 0 + | S O => 1 + | S n => INR n + 1 + end. +Arguments INR n%nat. + +(* compact representation for 2*p *) +Fixpoint IPR_2 (p:positive) : CReal := + match p with + | xH => 1 + 1 + | xO p => (1 + 1) * IPR_2 p + | xI p => (1 + 1) * (1 + IPR_2 p) + end. + +Definition IPR (p:positive) : CReal := + match p with + | xH => 1 + | xO p => IPR_2 p + | xI p => 1 + IPR_2 p + end. +Arguments IPR p%positive : simpl never. + +(**********) +Definition IZR (z:Z) : CReal := + match z with + | Z0 => 0 + | Zpos n => IPR n + | Zneg n => - IPR n + end. +Arguments IZR z%Z : simpl never. + +Notation "2" := (IZR 2) : R_scope_constr. + +(**********) +Lemma S_INR : forall n:nat, INR (S n) == INR n + 1. +Proof. + intro; destruct n. rewrite CReal_plus_0_l. reflexivity. reflexivity. +Qed. + +Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m. +Proof. + induction m. + - intros. inversion H. + - intros. unfold lt in H. apply le_S_n in H. destruct m. + inversion H. apply CRealLt_0_1. apply Nat.le_succ_r in H. destruct H. + rewrite S_INR. apply (CRealLt_trans _ (INR (S m) + 0)). + rewrite CReal_plus_comm, CReal_plus_0_l. apply IHm. + apply le_n_S. exact H. + apply CReal_plus_lt_compat_l. exact CRealLt_0_1. + subst n. rewrite (S_INR (S m)). rewrite <- (CReal_plus_0_l). + rewrite (CReal_plus_comm 0), CReal_plus_assoc. + apply CReal_plus_lt_compat_l. rewrite CReal_plus_0_l. + exact CRealLt_0_1. +Qed. + +(**********) +Lemma S_O_plus_INR : forall n:nat, INR (1 + n) == INR 1 + INR n. +Proof. + intros; destruct n. + - rewrite CReal_plus_comm, CReal_plus_0_l. reflexivity. + - rewrite CReal_plus_comm. reflexivity. +Qed. + +(**********) +Lemma plus_INR : forall n m:nat, INR (n + m) == INR n + INR m. +Proof. + intros n m; induction n as [| n Hrecn]. + - rewrite CReal_plus_0_l. reflexivity. + - replace (S n + m)%nat with (S (n + m)); auto with arith. + repeat rewrite S_INR. + rewrite Hrecn; ring. +Qed. + +(**********) +Lemma minus_INR : forall n m:nat, (m <= n)%nat -> INR (n - m) == INR n - INR m. +Proof. + intros n m le; pattern m, n; apply le_elim_rel. + intros. rewrite <- minus_n_O. unfold CReal_minus. + unfold INR. ring. + intros; repeat rewrite S_INR; simpl. + unfold CReal_minus. rewrite H0. ring. exact le. +Qed. + +(*********) +Lemma mult_INR : forall n m:nat, INR (n * m) == INR n * INR m. +Proof. + intros n m; induction n as [| n Hrecn]. + - rewrite CReal_mult_0_l. reflexivity. + - intros; repeat rewrite S_INR; simpl. + rewrite plus_INR. rewrite Hrecn; ring. +Qed. + +(**********) +Lemma IZN : forall n:Z, (0 <= n)%Z -> exists m : nat, n = Z.of_nat m. +Proof. + intros z; idtac; apply Z_of_nat_complete; assumption. +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 CReal_plus_comm. reflexivity. + - unfold IPR_2; now rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. + - apply CReal_mult_1_r. } + intros [p|p|] ; unfold IPR. + rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H. + apply CReal_plus_comm. + now rewrite Pos2Nat.inj_xO, mult_INR, <- H. + easy. +Qed. + +Lemma IPR_pos : forall p:positive, 0 < IPR p. +Proof. + intro p. rewrite <- INR_IPR. apply (lt_INR 0), Pos2Nat.is_pos. +Qed. + +(**********) +Lemma INR_IZR_INZ : forall n:nat, INR n == IZR (Z.of_nat n). +Proof. + intros [|n]. + easy. + simpl Z.of_nat. unfold IZR. + now rewrite <- INR_IPR, SuccNat2Pos.id_succ. +Qed. + +Lemma plus_IZR_NEG_POS : + forall p q:positive, IZR (Zpos p + Zneg q) == IZR (Zpos p) + IZR (Zneg q). +Proof. + intros p q; simpl. rewrite Z.pos_sub_spec. + case Pos.compare_spec; intros H; unfold IZR. + subst. ring. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub. + rewrite minus_INR. + 2: (now apply lt_le_weak, Pos2Nat.inj_lt). + ring. + trivial. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub. + rewrite minus_INR. + 2: (now apply lt_le_weak, Pos2Nat.inj_lt). + ring. trivial. +Qed. + +Lemma plus_IPR : forall n m:positive, IPR (n + m) == IPR n + IPR m. +Proof. + intros. repeat rewrite <- INR_IPR. + rewrite Pos2Nat.inj_add. apply plus_INR. +Qed. + +(**********) +Lemma plus_IZR : forall n m:Z, IZR (n + m) == IZR n + IZR m. +Proof. + intro z; destruct z; intro t; destruct t; intros. + - rewrite CReal_plus_0_l. reflexivity. + - rewrite CReal_plus_0_l. rewrite Z.add_0_l. reflexivity. + - rewrite CReal_plus_0_l. reflexivity. + - rewrite CReal_plus_comm,CReal_plus_0_l. reflexivity. + - rewrite <- Pos2Z.inj_add. unfold IZR. apply plus_IPR. + - apply plus_IZR_NEG_POS. + - rewrite CReal_plus_comm,CReal_plus_0_l, Z.add_0_r. reflexivity. + - rewrite Z.add_comm; rewrite CReal_plus_comm; apply plus_IZR_NEG_POS. + - simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR. + ring. +Qed. + + +Lemma CReal_iterate_one : forall (n : nat), + IZR (Z.of_nat n) == inject_Q (Z.of_nat n # 1). +Proof. + induction n. + - apply CRealEq_refl. + - replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z. + rewrite plus_IZR. + rewrite IHn. clear IHn. apply CRealEq_diff. intro k. simpl. + rewrite Z.mul_1_r. rewrite Z.mul_1_r. rewrite Z.mul_1_r. + rewrite Z.add_opp_diag_r. discriminate. + replace (S n) with (1 + n)%nat. 2: reflexivity. + rewrite (Nat2Z.inj_add 1 n). reflexivity. +Qed. + +(* The constant sequences of rationals are CRealEq to + the rational operations on the unity. *) +Lemma FinjectZ_CReal : forall z : Z, + IZR z == inject_Q (z # 1). +Proof. + intros. destruct z. + - apply CRealEq_refl. + - simpl. pose proof (CReal_iterate_one (Pos.to_nat p)). + rewrite positive_nat_Z in H. apply H. + - simpl. apply (CReal_plus_eq_reg_l (IZR (Z.pos p))). + pose proof CReal_plus_opp_r. rewrite H. + pose proof (CReal_iterate_one (Pos.to_nat p)). + rewrite positive_nat_Z in H0. rewrite H0. + apply CRealEq_diff. intro n. simpl. rewrite Z.pos_sub_diag. + discriminate. +Qed. + + +(* Axiom Rarchimed_constr *) +Lemma Rarchimedean + : forall x:CReal, + { n:Z | x < IZR n /\ IZR n < x+2 }. +Proof. + (* Locate x within 1/4 and pick the first integer above this interval. *) + intros [xn limx]. + pose proof (Qlt_floor (xn 4%nat + (1#4))). unfold inject_Z in H. + pose proof (Qfloor_le (xn 4%nat + (1#4))). unfold inject_Z in H0. + remember (Qfloor (xn 4%nat + (1#4)))%Z as n. + exists (n+1)%Z. split. + - rewrite FinjectZ_CReal. + assert (Qlt 0 ((n + 1 # 1) - (xn 4%nat + (1 # 4)))) as epsPos. + { unfold Qminus. rewrite <- Qlt_minus_iff. exact H. } + destruct (Qarchimedean (/((1#2)*((n + 1 # 1) - (xn 4%nat + (1 # 4)))))) as [k kmaj]. + exists (Pos.max 4 k). simpl. + apply (Qlt_trans _ ((n + 1 # 1) - (xn 4%nat + (1 # 4)))). + + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. + rewrite <- Qinv_lt_contravar in kmaj. 2: reflexivity. + apply (Qle_lt_trans _ (2#k)). + rewrite <- (Qmult_le_l _ _ (1#2)). + setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. 2: reflexivity. + setoid_replace ((1 # 2) * (2 # Pos.max 4 k))%Q with (1#Pos.max 4 k)%Q. 2: reflexivity. + unfold Qle; simpl. apply Pos2Z.pos_le_pos. apply Pos.le_max_r. + reflexivity. + rewrite <- (Qmult_lt_l _ _ (1#2)). + setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. exact kmaj. + reflexivity. reflexivity. rewrite <- (Qmult_0_r (1#2)). + rewrite Qmult_lt_l. exact epsPos. reflexivity. + + rewrite <- (Qplus_lt_r _ _ (xn (Pos.to_nat (Pos.max 4 k)) - (n + 1 # 1) + (1#4))). + ring_simplify. + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max 4 k)) - xn 4%nat))). + apply Qle_Qabs. apply limx. + rewrite Pos2Nat.inj_max. apply Nat.le_max_l. apply le_refl. + - apply (CReal_plus_lt_reg_l (-IZR 2)). ring_simplify. + do 2 rewrite FinjectZ_CReal. + exists 4%positive. simpl. + rewrite <- Qinv_plus_distr. + rewrite <- (Qplus_lt_r _ _ ((n#1) - (1#2))). ring_simplify. + apply (Qle_lt_trans _ (xn 4%nat + (1 # 4)) _ H0). + unfold Pos.to_nat; simpl. + rewrite <- (Qplus_lt_r _ _ (-xn 4%nat)). ring_simplify. + reflexivity. +Qed. + +Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal, + (CRealLt a b \/ CRealLt c d) -> { CRealLt a b } + { CRealLt c d }. +Proof. + intros. + assert (exists n : nat, n <> O /\ + (Qlt (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n) + \/ Qlt (2 # Pos.of_nat n) (proj1_sig d n - proj1_sig c n))). + { destruct H. destruct H as [n maj]. exists (Pos.to_nat n). split. + intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. + inversion abs. left. rewrite Pos2Nat.id. apply maj. + destruct H as [n maj]. exists (Pos.to_nat n). split. + intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. + inversion abs. right. rewrite Pos2Nat.id. apply maj. } + apply constructive_indefinite_ground_description_nat in H0. + - destruct H0 as [n [nPos maj]]. + destruct (Qlt_le_dec (2 # Pos.of_nat n) + (proj1_sig b n - proj1_sig a n)). + left. exists (Pos.of_nat n). rewrite Nat2Pos.id. apply q. apply nPos. + assert (2 # Pos.of_nat n < proj1_sig d n - proj1_sig c n)%Q. + destruct maj. exfalso. + apply (Qlt_not_le (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n)); assumption. + assumption. clear maj. right. exists (Pos.of_nat n). rewrite Nat2Pos.id. + apply H0. apply nPos. + - clear H0. clear H. intro n. destruct n. right. + intros [abs _]. exact (abs (eq_refl O)). + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig b (S n) - proj1_sig a (S n))). + left. split. discriminate. left. apply q. + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig d (S n) - proj1_sig c (S n))). + left. split. discriminate. right. apply q0. + right. intros [_ [abs|abs]]. + apply (Qlt_not_le (2 # Pos.of_nat (S n)) + (proj1_sig b (S n) - proj1_sig a (S n))); assumption. + apply (Qlt_not_le (2 # Pos.of_nat (S n)) + (proj1_sig d (S n) - proj1_sig c (S n))); assumption. +Qed. + +Lemma CRealShiftReal : forall (x : CReal) (k : nat), + QCauchySeq (fun n => proj1_sig x (plus n k)) Pos.to_nat. +Proof. + intros x k n p q H H0. + destruct x as [xn cau]; unfold proj1_sig. + destruct k. rewrite plus_0_r. rewrite plus_0_r. apply cau; assumption. + specialize (cau (n + Pos.of_nat (S k))%positive (p + S k)%nat (q + S k)%nat). + apply (Qlt_trans _ (1 # n + Pos.of_nat (S k))). + apply cau. rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. + apply Nat.add_le_mono_r. apply H. discriminate. + rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. + apply Nat.add_le_mono_r. apply H0. discriminate. + apply Pos2Nat.inj_lt; simpl. rewrite Pos2Nat.inj_add. + rewrite <- (plus_0_r (Pos.to_nat n)). rewrite <- plus_assoc. + apply Nat.add_lt_mono_l. apply Pos2Nat.is_pos. +Qed. + +Lemma CRealShiftEqual : forall (x : CReal) (k : nat), + CRealEq x (exist _ (fun n => proj1_sig x (plus n k)) (CRealShiftReal x k)). +Proof. + intros. split. + - intros [n maj]. destruct x as [xn cau]; simpl in maj. + specialize (cau n (Pos.to_nat n + k)%nat (Pos.to_nat n)). + apply Qlt_not_le in maj. apply maj. clear maj. + apply (Qle_trans _ (Qabs (xn (Pos.to_nat n + k)%nat - xn (Pos.to_nat n)))). + apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. + apply cau. rewrite <- (plus_0_r (Pos.to_nat n)). + rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. + apply le_refl. apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. + discriminate. + - intros [n maj]. destruct x as [xn cau]; simpl in maj. + specialize (cau n (Pos.to_nat n) (Pos.to_nat n + k)%nat). + apply Qlt_not_le in maj. apply maj. clear maj. + apply (Qle_trans _ (Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat n + k)%nat))). + apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. + apply cau. apply le_refl. rewrite <- (plus_0_r (Pos.to_nat n)). + rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. + apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. discriminate. +Qed. + +(* Find an equal negative real number, which rational sequence + stays below 0, so that it can be inversed. *) +Definition CRealNegShift (x : CReal) + : CRealLt x (inject_Q 0) + -> { y : prod positive CReal | CRealEq x (snd y) + /\ forall n:nat, Qlt (proj1_sig (snd y) n) (-1 # fst y) }. +Proof. + intro xNeg. apply CRealLtEpsilon in xNeg. + pose proof (CRealLt_aboveSig x (inject_Q 0)). + pose proof (CRealShiftReal x). + pose proof (CRealShiftEqual x). + destruct xNeg as [n maj], x as [xn cau]; simpl in maj. + specialize (H n maj); simpl in H. + destruct (Qarchimedean (/ (0 - xn (Pos.to_nat n) - (2 # n)))) as [a _]. + remember (Pos.max n a~0) as k. + clear Heqk. clear maj. clear n. + exists (pair k + (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). + split. apply H1. intro n. simpl. apply Qlt_minus_iff. + destruct n. + - specialize (H k). + unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. + unfold Qminus. rewrite Qplus_comm. + apply (Qlt_trans _ (- xn (Pos.to_nat k)%nat - (2 #k))). apply H. + unfold Qminus. simpl. apply Qplus_lt_r. + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. apply Pos.le_refl. + - apply (Qlt_trans _ (-(2 # k) - xn (S n + Pos.to_nat k)%nat)). + rewrite <- (Nat2Pos.id (S n)). rewrite <- Pos2Nat.inj_add. + specialize (H (Pos.of_nat (S n) + k)%positive). + unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. + unfold Qminus. rewrite Qplus_comm. apply H. apply Pos2Nat.inj_le. + rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. + apply Nat.add_le_mono_r. apply le_0_n. discriminate. + apply Qplus_lt_l. + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. +Qed. + +Definition CRealPosShift (x : CReal) + : CRealLt (inject_Q 0) x + -> { y : prod positive CReal | CRealEq x (snd y) + /\ forall n:nat, Qlt (1 # fst y) (proj1_sig (snd y) n) }. +Proof. + intro xPos. apply CRealLtEpsilon in xPos. + pose proof (CRealLt_aboveSig (inject_Q 0) x). + pose proof (CRealShiftReal x). + pose proof (CRealShiftEqual x). + destruct xPos as [n maj], x as [xn cau]; simpl in maj. + simpl in H. specialize (H n). + destruct (Qarchimedean (/ (xn (Pos.to_nat n) - 0 - (2 # n)))) as [a _]. + specialize (H maj); simpl in H. + remember (Pos.max n a~0) as k. + clear Heqk. clear maj. clear n. + exists (pair k + (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). + split. apply H1. intro n. simpl. apply Qlt_minus_iff. + destruct n. + - specialize (H k). + unfold Qminus in H. rewrite Qplus_0_r in H. + simpl. rewrite <- Qlt_minus_iff. + apply (Qlt_trans _ (2 #k)). + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. apply H. apply Pos.le_refl. + - rewrite <- Qlt_minus_iff. apply (Qlt_trans _ (2 # k)). + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. specialize (H (Pos.of_nat (S n) + k)%positive). + unfold Qminus in H. rewrite Qplus_0_r in H. + rewrite Pos2Nat.inj_add in H. rewrite Nat2Pos.id in H. + apply H. apply Pos2Nat.inj_le. + rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. + apply Nat.add_le_mono_r. apply le_0_n. discriminate. +Qed. + +Lemma CReal_inv_neg : forall (yn : nat -> Q) (k : positive), + (QCauchySeq yn Pos.to_nat) + -> (forall n : nat, yn n < -1 # k)%Q + -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. +Proof. + (* Prove the inverse sequence is Cauchy *) + intros yn k cau maj n p q H0 H1. + setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - + / yn (Pos.to_nat k ^ 2 * q)%nat)%Q + with ((yn (Pos.to_nat k ^ 2 * q)%nat - + yn (Pos.to_nat k ^ 2 * p)%nat) + / (yn (Pos.to_nat k ^ 2 * q)%nat * + yn (Pos.to_nat k ^ 2 * p)%nat)). + + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat + - yn (Pos.to_nat k ^ 2 * p)%nat) + / (1 # (k^2)))). + assert (1 # k ^ 2 + < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. + { rewrite Qabs_Qmult. unfold "^"%positive; simpl. + rewrite factorDenom. rewrite Pos.mul_1_r. + apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). + apply Qmult_lt_l. reflexivity. rewrite Qabs_neg. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply Qlt_minus_iff in maj. apply Qlt_minus_iff. + rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. + reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. + apply maj. discriminate. + apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. + rewrite Qabs_neg. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply Qlt_minus_iff in maj. apply Qlt_minus_iff. + rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. + reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. + apply maj. discriminate. + rewrite Qabs_neg. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). + apply Qlt_minus_iff in maj. apply Qlt_minus_iff. + rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. + reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. + apply maj. discriminate. } + unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. + rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). + apply Qmult_le_compat_r. apply Qlt_le_weak. + rewrite <- Qmult_1_l. apply Qlt_shift_div_r. + apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. + rewrite Qmult_comm. apply Qlt_shift_div_l. + reflexivity. rewrite Qmult_1_l. apply H. + apply Qabs_nonneg. simpl in maj. + specialize (cau (n * (k^2))%positive + (Pos.to_nat k ^ 2 * q)%nat + (Pos.to_nat k ^ 2 * p)%nat). + apply Qlt_shift_div_r. reflexivity. + apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite factorDenom. apply Qle_refl. + + field. split. intro abs. + specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + rewrite abs in maj. inversion maj. + intro abs. + specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + rewrite abs in maj. inversion maj. +Qed. + +Lemma CReal_inv_pos : forall (yn : nat -> Q) (k : positive), + (QCauchySeq yn Pos.to_nat) + -> (forall n : nat, 1 # k < yn n)%Q + -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. +Proof. + intros yn k cau maj n p q H0 H1. + setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - + / yn (Pos.to_nat k ^ 2 * q)%nat)%Q + with ((yn (Pos.to_nat k ^ 2 * q)%nat - + yn (Pos.to_nat k ^ 2 * p)%nat) + / (yn (Pos.to_nat k ^ 2 * q)%nat * + yn (Pos.to_nat k ^ 2 * p)%nat)). + + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat + - yn (Pos.to_nat k ^ 2 * p)%nat) + / (1 # (k^2)))). + assert (1 # k ^ 2 + < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. + { rewrite Qabs_Qmult. unfold "^"%positive; simpl. + rewrite factorDenom. rewrite Pos.mul_1_r. + apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). + apply Qmult_lt_l. reflexivity. rewrite Qabs_pos. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply maj. apply (Qle_trans _ (1 # k)). + discriminate. apply Zlt_le_weak. apply maj. + apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. + rewrite Qabs_pos. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply maj. apply (Qle_trans _ (1 # k)). discriminate. + apply Zlt_le_weak. apply maj. + rewrite Qabs_pos. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). + apply maj. apply (Qle_trans _ (1 # k)). discriminate. + apply Zlt_le_weak. apply maj. } + unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. + rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). + apply Qmult_le_compat_r. apply Qlt_le_weak. + rewrite <- Qmult_1_l. apply Qlt_shift_div_r. + apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. + rewrite Qmult_comm. apply Qlt_shift_div_l. + reflexivity. rewrite Qmult_1_l. apply H. + apply Qabs_nonneg. simpl in maj. + specialize (cau (n * (k^2))%positive + (Pos.to_nat k ^ 2 * q)%nat + (Pos.to_nat k ^ 2 * p)%nat). + apply Qlt_shift_div_r. reflexivity. + apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite factorDenom. apply Qle_refl. + + field. split. intro abs. + specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + rewrite abs in maj. inversion maj. + intro abs. + specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + rewrite abs in maj. inversion maj. +Qed. + +Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal. +Proof. + apply CRealLtDisjunctEpsilon in xnz. destruct xnz as [xNeg | xPos]. + - destruct (CRealNegShift x xNeg) as [[k y] [_ maj]]. + destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. + exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). + apply (CReal_inv_neg yn). apply cau. apply maj. + - destruct (CRealPosShift x xPos) as [[k y] [_ maj]]. + destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. + exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). + apply (CReal_inv_pos yn). apply cau. apply maj. +Defined. + +Notation "/ x" := (CReal_inv x) (at level 35, right associativity) : R_scope_constr. + +Lemma CReal_inv_0_lt_compat + : forall (r : CReal) (rnz : r # 0), + 0 < r -> 0 < ((/ r) rnz). +Proof. + intros. unfold CReal_inv. simpl. + destruct (CRealLtDisjunctEpsilon r (inject_Q 0) (inject_Q 0) r rnz). + - exfalso. apply CRealLt_asym in H. contradiction. + - destruct (CRealPosShift r c) as [[k rpos] [req maj]]. + clear req. clear rnz. destruct rpos as [rn cau]; simpl in maj. + unfold CRealLt; simpl. + destruct (Qarchimedean (rn 1%nat)) as [A majA]. + exists (2 * (A + 1))%positive. unfold Qminus. rewrite Qplus_0_r. + rewrite <- (Qmult_1_l (Qinv (rn (Pos.to_nat k * (Pos.to_nat k * 1) * Pos.to_nat (2 * (A + 1)))%nat))). + apply Qlt_shift_div_l. apply (Qlt_trans 0 (1#k)). reflexivity. + apply maj. rewrite <- (Qmult_inv_r (Z.pos A + 1 # 1)). + setoid_replace (2 # 2 * (A + 1))%Q with (Qinv (Z.pos A + 1 # 1)). + 2: reflexivity. + rewrite Qmult_comm. apply Qmult_lt_r. reflexivity. + rewrite mult_1_r. rewrite <- Pos2Nat.inj_mul. rewrite <- Pos2Nat.inj_mul. + rewrite <- (Qplus_lt_l _ _ (- rn 1%nat)). + apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (k * k * (2 * (A + 1)))) + - rn 1%nat))). + apply Qle_Qabs. apply (Qlt_le_trans _ 1). apply cau. + apply Pos2Nat.is_pos. apply le_refl. + rewrite <- Qinv_plus_distr. rewrite <- (Qplus_comm 1). + rewrite <- Qplus_0_r. rewrite <- Qplus_assoc. rewrite <- Qplus_assoc. + rewrite Qplus_le_r. rewrite Qplus_0_l. apply Qlt_le_weak. + apply Qlt_minus_iff in majA. apply majA. + intro abs. inversion abs. +Qed. + +Lemma CReal_linear_shift : forall (x : CReal) (k : nat), + le 1 k -> QCauchySeq (fun n => proj1_sig x (k * n)%nat) Pos.to_nat. +Proof. + intros [xn limx] k lek p n m H H0. unfold proj1_sig. + apply limx. apply (le_trans _ n). apply H. + rewrite <- (mult_1_l n). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg_r. apply le_0_n. + rewrite mult_1_r. apply lek. apply (le_trans _ m). apply H0. + rewrite <- (mult_1_l m). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg_r. apply le_0_n. + rewrite mult_1_r. apply lek. +Qed. + +Lemma CReal_linear_shift_eq : forall (x : CReal) (k : nat) (kPos : le 1 k), + CRealEq x + (exist (fun n : nat -> Q => QCauchySeq n Pos.to_nat) + (fun n : nat => proj1_sig x (k * n)%nat) (CReal_linear_shift x k kPos)). +Proof. + intros. apply CRealEq_diff. intro n. + destruct x as [xn limx]; unfold proj1_sig. + specialize (limx n (Pos.to_nat n) (k * Pos.to_nat n)%nat). + apply (Qle_trans _ (1 # n)). apply Qlt_le_weak. apply limx. + apply le_refl. rewrite <- (mult_1_l (Pos.to_nat n)). + rewrite mult_assoc. apply Nat.mul_le_mono_nonneg_r. apply le_0_n. + rewrite mult_1_r. apply kPos. apply Z.mul_le_mono_nonneg_r. + discriminate. discriminate. +Qed. + +Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0), + ((/ r) rnz) * r == 1. +Proof. + intros. unfold CReal_inv; simpl. + destruct (CRealLtDisjunctEpsilon r (inject_Q 0) (inject_Q 0) r rnz). + - (* r < 0 *) destruct (CRealNegShift r c) as [[k rneg] [req maj]]. + simpl in req. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in + fun maj0 : forall n : nat, yn n < -1 # k => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n))%nat) + (CReal_inv_neg yn k cau maj0)) maj) rneg)))%Q. + + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply req. + + assert (le 1 (Pos.to_nat k * (Pos.to_nat k * 1))%nat). rewrite mult_1_r. + rewrite <- Pos2Nat.inj_mul. apply Pos2Nat.is_pos. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in + fun maj0 : forall n : nat, yn n < -1 # k => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + (CReal_inv_neg yn k cau maj0)) maj) + (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply CReal_linear_shift_eq. + destruct r as [rn limr], rneg as [rnn limneg]; simpl. + destruct (QCauchySeq_bounded + (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + Pos.to_nat (CReal_inv_neg rnn k limneg maj)). + destruct (QCauchySeq_bounded + (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) + Pos.to_nat + (CReal_linear_shift + (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) + (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. + exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. + rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. + reflexivity. intro abs. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) + * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). + simpl in maj. rewrite abs in maj. inversion maj. + - (* r > 0 *) destruct (CRealPosShift r c) as [[k rneg] [req maj]]. + simpl in req. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in + fun maj0 : forall n : nat, 1 # k < yn n => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + (CReal_inv_pos yn k cau maj0)) maj) rneg)))%Q. + + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply req. + + assert (le 1 (Pos.to_nat k * (Pos.to_nat k * 1))%nat). rewrite mult_1_r. + rewrite <- Pos2Nat.inj_mul. apply Pos2Nat.is_pos. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in + fun maj0 : forall n : nat, 1 # k < yn n => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + (CReal_inv_pos yn k cau maj0)) maj) + (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply CReal_linear_shift_eq. + destruct r as [rn limr], rneg as [rnn limneg]; simpl. + destruct (QCauchySeq_bounded + (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + Pos.to_nat (CReal_inv_pos rnn k limneg maj)). + destruct (QCauchySeq_bounded + (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) + Pos.to_nat + (CReal_linear_shift + (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) + (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. + exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. + rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. + reflexivity. intro abs. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) + * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). + simpl in maj. rewrite abs in maj. inversion maj. +Qed. + +Fixpoint pow (r:CReal) (n:nat) : CReal := + match n with + | O => 1 + | S n => r * (pow r n) + end. + + +(**********) +Definition IQR (q:Q) : CReal := + match q with + | Qmake a b => IZR a * (CReal_inv (IPR b)) (or_intror (IPR_pos b)) + end. +Arguments IQR q%Q : simpl never. + +Lemma CReal_invQ : forall (b : positive) (pos : Qlt 0 (Z.pos b # 1)), + CRealEq (CReal_inv (inject_Q (Z.pos b # 1)) (or_intror (CReal_injectQPos (Z.pos b # 1) pos))) + (inject_Q (1 # b)). +Proof. + intros. + apply (CReal_mult_eq_reg_l (inject_Q (Z.pos b # 1))). + - right. apply CReal_injectQPos. exact pos. + - rewrite CReal_mult_comm, CReal_inv_l. + apply CRealEq_diff. intro n. simpl; + destruct (QCauchySeq_bounded (fun _ : nat => 1 # b)%Q Pos.to_nat (ConstCauchy (1 # b))), + (QCauchySeq_bounded (fun _ : nat => Z.pos b # 1)%Q Pos.to_nat (ConstCauchy (Z.pos b # 1))); simpl. + do 2 rewrite Pos.mul_1_r. rewrite Z.pos_sub_diag. discriminate. +Qed. + +(* The constant sequences of rationals are CRealEq to + the rational operations on the unity. *) +Lemma FinjectQ_CReal : forall q : Q, + IQR q == inject_Q q. +Proof. + intros [a b]. unfold IQR; simpl. + pose proof (CReal_iterate_one (Pos.to_nat b)). + rewrite positive_nat_Z in H. simpl in H. + assert (0 < Z.pos b # 1)%Q as pos. reflexivity. + apply (CRealEq_trans _ (CReal_mult (IZR a) + (CReal_inv (inject_Q (Z.pos b # 1)) (or_intror (CReal_injectQPos (Z.pos b # 1) pos))))). + - apply CReal_mult_proper_l. + apply (CReal_mult_eq_reg_l (IPR b)). + right. apply IPR_pos. + rewrite CReal_mult_comm, CReal_inv_l, H, CReal_mult_comm, CReal_inv_l. reflexivity. + - rewrite FinjectZ_CReal. rewrite CReal_invQ. apply CRealEq_diff. intro n. + simpl; + destruct (QCauchySeq_bounded (fun _ : nat => a # 1)%Q Pos.to_nat (ConstCauchy (a # 1))), + (QCauchySeq_bounded (fun _ : nat => 1 # b)%Q Pos.to_nat (ConstCauchy (1 # b))); simpl. + rewrite Z.mul_1_r. rewrite <- Z.mul_add_distr_r. + rewrite Z.add_opp_diag_r. rewrite Z.mul_0_l. simpl. + discriminate. +Qed. + +Close Scope R_scope_constr. + +Close Scope Q. diff --git a/theories/Reals/ConstructiveRIneq.v b/theories/Reals/ConstructiveRIneq.v new file mode 100644 index 0000000000..adffa9b719 --- /dev/null +++ b/theories/Reals/ConstructiveRIneq.v @@ -0,0 +1,2235 @@ +(************************************************************************) +(* * 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 classical real numbers *) +(*********************************************************) + +Require Import ConstructiveCauchyReals. +Require Import Zpower. +Require Export ZArithRing. +Require Import Omega. +Require Import QArith_base. +Require Import Qring. + +Local Open Scope Z_scope. +Local Open Scope R_scope_constr. + +(* Export all axioms *) + +Notation Rplus_comm := CReal_plus_comm (only parsing). +Notation Rplus_assoc := CReal_plus_assoc (only parsing). +Notation Rplus_opp_r := CReal_plus_opp_r (only parsing). +Notation Rplus_0_l := CReal_plus_0_l (only parsing). +Notation Rmult_comm := CReal_mult_comm (only parsing). +Notation Rmult_assoc := CReal_mult_assoc (only parsing). +Notation Rinv_l := CReal_inv_l (only parsing). +Notation Rmult_1_l := CReal_mult_1_l (only parsing). +Notation Rmult_plus_distr_l := CReal_mult_plus_distr_l (only parsing). +Notation Rlt_0_1 := CRealLt_0_1 (only parsing). +Notation Rlt_asym := CRealLt_asym (only parsing). +Notation Rlt_trans := CRealLt_trans (only parsing). +Notation Rplus_lt_compat_l := CReal_plus_lt_compat_l (only parsing). +Notation Rmult_lt_compat_l := CReal_mult_lt_compat_l (only parsing). +Notation Rmult_0_l := CReal_mult_0_l (only parsing). + +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. + + +(*********************************************************) +(** ** Relation between orders and equality *) +(*********************************************************) + +(** Reflexivity of the large order *) + +Lemma Rle_refl : forall r, r <= r. +Proof. + intros r abs. apply (CRealLt_asym r r); exact abs. +Qed. +Hint Immediate Rle_refl: rorders. + +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. +Proof. + intros r H; eapply CRealLt_asym; eauto. +Qed. +Hint Resolve Rlt_irrefl: creal. + +Lemma Rgt_irrefl : forall r, ~ r > r. +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 H). + - intro abs. subst r2. exact (Rlt_irrefl r1 H). +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 (CRealLt_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 (CRealLt_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 -> r2 <= r1. +Proof. + intros. intro abs. contradiction. +Qed. + +Lemma Rnot_gt_le : forall r1 r2, ~ r1 > r2 -> r1 <= r2. +Proof. + intros. intro abs. contradiction. +Qed. + +Lemma Rnot_gt_ge : forall r1 r2, ~ r1 > r2 -> r2 >= r1. +Proof. + intros. intro abs. contradiction. +Qed. + +Lemma Rnot_lt_ge : forall r1 r2, ~ r1 < r2 -> r1 >= r2. +Proof. + intros. intro abs. contradiction. +Qed. + +(**********) +Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2. +Proof. + generalize CRealLt_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. +Proof. + intros r1 r2. generalize (CRealLt_asym r1 r2) (Rlt_dichotomy_converse r1 r2). + unfold CRealLe; intuition. +Qed. + +Lemma Rge_not_lt : forall r1 r2, r1 >= r2 -> ~ r1 < r2. +Proof. intros; apply Rle_not_lt; auto with creal. Qed. + +Lemma Rle_not_gt : forall r1 r2, r1 <= r2 -> ~ r1 > r2. +Proof. do 2 intro; apply Rle_not_lt. Qed. + +Lemma Rge_not_gt : forall r1 r2, r2 >= r1 -> ~ r1 > r2. +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: [CRealLt_asym] is an axiom *) + +Lemma Rgt_asym : forall r1 r2, r1 > r2 -> ~ r2 > r1. +Proof. do 2 intro; apply CRealLt_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 (CRealLt_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 c. +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 c. 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 CReal_inv_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, 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, H0, H1. + - 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 H1. apply H0. + - left. rewrite <- (Rmult_0_r r1). apply (Rmult_lt_compat_l). apply H0. apply H1. + - 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 : CReal) := 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 : forall r1 r2, - (r1 * r2) == - r1 * r2. +Proof. + intros; ring. +Qed. + +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; ring. +Qed. +Hint Resolve Rminus_0_r: creal. + +Lemma Rminus_0_l : forall r, 0 - r == - r. +Proof. + intro; 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; 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 CReal_minus; 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; + ring. +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_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. +Proof. + intros. apply CReal_plus_lt_reg_l in H. exact H. +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 CRealLt_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 (CRealLt_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 : core. + +Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. +Proof. + unfold CRealGt; auto with creal. +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. +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. +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. +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. +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 CRealLt_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) (or_intror rpos). +Proof. + intros. apply CReal_inv_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) (or_intror 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. + ring_simplify 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. + ring_simplify 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. +Qed. +Hint Immediate tech_Rplus: creal. + +(*********************************************************) +(** ** Zero is less than one *) +(*********************************************************) + +Lemma Rle_0_1 : 0 <= 1. +Proof. + intro abs. apply (CRealLt_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) (or_intror (Ropp_0_gt_lt_contravar _ c))). + { apply Rinv_0_lt_compat. } + rewrite <- (Ropp_inv_permute _ (or_introl 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) (or_introl rneg) < 0. +Proof. + intros. assert (0 < (/-r) (or_intror (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 CReal_minus; rewrite Rplus_assoc, Rplus_opp_l. + apply Rplus_lt_compat_l. exact H. +Qed. + +(*********************************************************) +(** ** Injection from [N] to [R] *) +(*********************************************************) + +Lemma Rpow_eq_compat : forall (x y : CReal) (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. + simple induction 1; intros. apply Rlt_0_1. + rewrite S_INR. apply (CRealLt_trans _ (INR m)). apply H1. apply Rlt_plus_1. +Qed. +Hint Resolve lt_0_INR: creal. + +Notation lt_INR := lt_INR (only parsing). +Notation plus_INR := plus_INR (only parsing). +Notation INR_IPR := INR_IPR (only parsing). +Notation plus_IZR_NEG_POS := plus_IZR_NEG_POS (only parsing). +Notation plus_IZR := plus_IZR (only parsing). + +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_or_lt n m); intros H1. + case (le_lt_or_eq _ _ H1); intros H2. + left. apply lt_INR. 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 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. + 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, CReal_minus. + 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 CReal_minus; 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 CReal_minus in H0. + repeat rewrite <- H0. unfold Zminus. + rewrite Z.add_opp_diag_r. apply posCase. + rewrite (Z.add_lt_mono_l _ _ n). ring_simplify. apply H. +Qed. + +(**********) +Lemma not_0_IZR : forall n:Z, n <> 0%Z -> IZR n # 0. +Proof. + intros. destruct (Z.lt_trichotomy n 0). + left. apply (IZR_lt n 0). exact H0. + destruct H0. contradiction. + right. apply (IZR_lt 0 n). exact H0. +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 CReal_minus 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; red; intro. + generalize (lt_IZR m n H0); intro; omega. +Qed. + +Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m. +Proof. + intros m n H; apply Rnot_gt_le; red; intro. + unfold CRealGt in H0; generalize (lt_IZR n m H0); intro; omega. +Qed. + +Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 # IZR z2. +Proof. + intros. destruct (Z.lt_trichotomy z1 z2). + left. apply IZR_lt. exact H0. + destruct H0. contradiction. + right. apply IZR_lt. exact H0. +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. + rewrite <- Z_R_minus; split. + 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 -> + (exists s : Z, s <> n /\ r < IZR s /\ 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. + + + +(*********************************************************) +(** ** Computable Reals *) +(*********************************************************) + +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 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 (Rarchimedean (b * (/ (-(a*b))) (or_intror (Ropp_0_gt_lt_contravar _ abs)))) + as [n [maj _]]. + destruct n as [|n|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 < IZR (Z.pos n)) as nPos. + apply (IZR_lt 0). reflexivity. + assert (b * (/ (IZR (Z.pos n))) (or_intror nPos) < -(a*b)). + { apply (Rmult_lt_reg_r (IZR (Z.pos 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 + (/ (IZR (Z.pos n))) (or_intror nPos)) + 0 b). + assert (a + (/ (IZR (Z.pos n))) (or_intror 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 ((/ (IZR (Z.pos n))) (or_intror nPos))). + apply H1. + - (* n < 0 *) + assert (b * (/ (- (a * b))) (or_intror (Ropp_0_gt_lt_contravar _ abs)) < 0). + apply (CRealLt_trans _ (IZR (Z.neg n)) _ maj). + apply Ropp_lt_cancel. rewrite Ropp_0. + rewrite <- opp_IZR. apply (IZR_lt 0). reflexivity. + apply (Rmult_lt_compat_r (-(a*b))) in H1. + rewrite Rmult_0_l in H1. rewrite Rmult_assoc in H1. + rewrite Rinv_l in H1. rewrite Rmult_1_r in H1. contradiction. + apply epsPos. +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 CReal_minus. 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. apply CRealLt_asym. + apply H1. 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 IPR_double : forall p:positive, IPR (2*p) == 2 * IPR p. +Proof. + intro p. destruct p. + - reflexivity. + - reflexivity. + - rewrite Rmult_1_r. reflexivity. +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. + +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)) (or_intror (IPR_pos (Qden * Qden0)))) + with ((/ IPR Qden) (or_intror (IPR_pos Qden)) + * (/ IPR Qden0) (or_intror (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) (or_intror (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 + _ _ _ _ (or_intror (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. + apply CRealLt_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 ==> CRealEq + 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. + +Definition Rup_nat (x : CReal) + : { n : nat | x < INR n }. +Proof. + intros. destruct (Rarchimedean x) as [p [maj _]]. + destruct p. + - exists O. apply maj. + - exists (Pos.to_nat p). rewrite INR_IPR. apply maj. + - exists O. apply (CRealLt_trans _ (IZR (Z.neg p)) _ maj). + apply (IZR_lt _ 0). reflexivity. +Qed. + +(* Sharpen the archimedean property : constructive versions of + the usual floor and ceiling functions. + + n is a temporary parameter used for the recursion, + look at Ffloor below. *) +Fixpoint Rfloor_pos (a : CReal) (n : nat) { struct n } + : 0 < a + -> a < INR n + -> { p : nat | INR p < a < INR p + 2 }. +Proof. + (* Decreasing loop on n, until it is the first integer above a. *) + intros H H0. destruct n. + - exfalso. apply (CRealLt_asym 0 a); assumption. + - destruct n as [|p] eqn:des. + + (* n = 1 *) exists O. split. + apply H. rewrite Rplus_0_l. apply (CRealLt_trans a (1+0)). + rewrite Rplus_0_r. 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_r, S_INR. apply Rplus_lt_compat_l. + apply Rlt_0_1. + * exists p. split. exact c. + rewrite S_INR, S_INR, Rplus_assoc in H0. exact H0. + * apply (Rfloor_pos a n H). rewrite des. apply c. +Qed. + +Definition Rfloor (a : CReal) + : { p : Z | IZR p < a < IZR p + 2 }. +Proof. + assert (forall x:CReal, 0 < x -> { n : nat | x < INR n }). + { intros. pose proof (Rarchimedean x) as [n [maj _]]. + destruct n. + + exfalso. apply (CRealLt_asym 0 x); assumption. + + exists (Pos.to_nat p). rewrite INR_IPR. apply maj. + + exfalso. apply (CRealLt_asym 0 x). apply H. + apply (CRealLt_trans x (IZR (Z.neg p))). apply maj. + apply (Rplus_lt_reg_r (-IZR (Z.neg p))). + rewrite Rplus_opp_r. rewrite <- opp_IZR. + rewrite Rplus_0_l. apply (IZR_lt 0). reflexivity. } + destruct (linear_order_T 0 a 1 Rlt_0_1). + - destruct (H a c). destruct (Rfloor_pos a x c c0). + exists (Z.of_nat x0). rewrite <- INR_IZR_INZ. apply a0. + - apply (Rplus_lt_compat_r (-a)) in c. + rewrite Rplus_opp_r in c. destruct (H (1-a) c). + destruct (Rfloor_pos (1-a) x c c0). + exists (-(Z.of_nat x0 + 1))%Z. rewrite opp_IZR. + rewrite plus_IZR. simpl. split. + + rewrite <- (Ropp_involutive a). apply Ropp_gt_lt_contravar. + destruct a0 as [_ a0]. apply (Rplus_lt_reg_r 1). + rewrite Rplus_comm, Rplus_assoc. rewrite <- INR_IZR_INZ. apply a0. + + destruct a0 as [a0 _]. apply (Rplus_lt_compat_l a) in a0. + ring_simplify in a0. rewrite <- INR_IZR_INZ. + apply (Rplus_lt_reg_r (INR x0)). unfold IZR, IPR, IPR_2. + ring_simplify. exact a0. +Qed. + +Lemma Qplus_same_denom : forall a b c, ((a # c) + (b # c) == (a+b) # c)%Q. +Proof. + intros. unfold Qeq. simpl. rewrite Pos2Z.inj_mul. ring. +Qed. + +(* A point in an archimedean field is the limit of a + sequence of rational numbers (n maps to the q between + a and a+1/n). This will yield a maximum + archimedean field, which is the field of real numbers. *) +Definition FQ_dense_pos (a b : CReal) + : 0 < b + -> a < b -> { q : Q | a < IQR q < b }. +Proof. + intros H H0. + assert (0 < b - a) as epsPos. + { apply (Rplus_lt_compat_r (-a)) in H0. + rewrite Rplus_opp_r in H0. apply H0. } + pose proof (Rarchimedean ((/(b-a)) (or_intror epsPos))) + as [n [maj _]]. + destruct n as [|n|n]. + - 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 (CRealLt_asym 0 1). apply Rlt_0_1. apply maj. + right. exact epsPos. + - (* 0 < n *) + destruct (Rfloor (IZR (2 * Z.pos n) * b)) as [p maj2]. + exists (p # (2*n))%Q. split. + + apply (CRealLt_trans a (b - IQR (1 # n))). + apply (Rplus_lt_reg_r (IQR (1#n))). + unfold CReal_minus. rewrite Rplus_assoc. rewrite Rplus_opp_l. + rewrite Rplus_0_r. apply (Rplus_lt_reg_l (-a)). + rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l. + rewrite Rplus_comm. unfold IQR. + rewrite Rmult_1_l. apply (Rmult_lt_reg_l (IZR (Z.pos n))). + apply (IZR_lt 0). reflexivity. rewrite Rinv_r. + apply (Rmult_lt_compat_r (b-a)) in maj. rewrite Rinv_l in maj. + apply maj. exact epsPos. + right. apply IPR_pos. + apply (Rplus_lt_reg_r (IQR (1 # n))). + unfold CReal_minus. rewrite Rplus_assoc. rewrite 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 Qplus_same_denom. + + 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. rewrite Rinv_l. + rewrite Rmult_1_r. rewrite Rmult_comm. apply maj2. + - exfalso. + apply (Rmult_lt_compat_l (b-a)) in maj. 2: apply epsPos. + rewrite Rinv_r in maj. apply (CRealLt_asym 0 1). apply Rlt_0_1. + apply (CRealLt_trans 1 ((b - a) * IZR (Z.neg n)) _ maj). + rewrite <- (Rmult_0_r (b-a)). + apply Rmult_lt_compat_l. apply epsPos. apply (IZR_lt _ 0). reflexivity. + right. apply epsPos. +Qed. + +Definition FQ_dense (a b : CReal) + : a < b + -> { q : Q | a < IQR q < b }. +Proof. + intros H. destruct (linear_order_T a 0 b). apply H. + - destruct (FQ_dense_pos (-b) (-a)) as [q maj]. + apply (Rplus_lt_compat_l (-a)) in c. rewrite Rplus_opp_l in c. + rewrite Rplus_0_r in c. apply c. + apply (Rplus_lt_compat_r (-a)) in H. + rewrite Rplus_opp_r in H. + apply (Rplus_lt_compat_l (-b)) in H. rewrite <- Rplus_assoc in H. + rewrite Rplus_opp_l in H. rewrite Rplus_0_l in H. + rewrite Rplus_0_r in H. apply H. + exists (-q)%Q. split. + + destruct maj as [_ maj]. + apply (Rplus_lt_compat_r (-IQR q)) in maj. + rewrite Rplus_opp_r in maj. rewrite <- opp_IQR in maj. + apply (Rplus_lt_compat_l a) in maj. rewrite <- Rplus_assoc in maj. + rewrite Rplus_opp_r in maj. rewrite Rplus_0_l in maj. + rewrite Rplus_0_r in maj. apply maj. + + destruct maj as [maj _]. + apply (Rplus_lt_compat_r (-IQR q)) in maj. + rewrite Rplus_opp_r in maj. rewrite <- opp_IQR in maj. + apply (Rplus_lt_compat_l b) in maj. rewrite <- Rplus_assoc in maj. + rewrite Rplus_opp_r in maj. rewrite Rplus_0_l in maj. + rewrite Rplus_0_r in maj. apply maj. + - apply FQ_dense_pos. apply c. apply H. +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) (or_intror 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) (or_intror ypos) <= (/ x) (or_intror 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 (CRealLt_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) (or_intror Rlt_0_2) + + r1 * (/ 2) (or_intror 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 CReal_plus CReal_mult CReal_minus CReal_opp CRealEq + 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. apply CRealLt_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) (or_intror 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) (or_intror 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. apply CRealLt_asym. apply Rlt_0_2. +Qed. + +(**********) +Lemma Rdiv_lt_0_compat : forall a b (bpos : 0 < b), + 0 < a -> 0 < a * (/b) (or_intror 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 CReal_minus; rewrite Rmult_plus_distr_r; ring. +Qed. + + +(*********************************************************) +(** * Definitions of new types *) +(*********************************************************) + +Record nonnegreal : Type := mknonnegreal + {nonneg :> CReal; cond_nonneg : 0 <= nonneg}. + +Record posreal : Type := mkposreal {pos :> CReal; cond_pos : 0 < pos}. + +Record nonposreal : Type := mknonposreal + {nonpos :> CReal; cond_nonpos : nonpos <= 0}. + +Record negreal : Type := mknegreal {neg :> CReal; cond_neg : neg < 0}. + +Record nonzeroreal : Type := mknonzeroreal + {nonzero :> CReal; cond_nonzero : nonzero <> 0}. diff --git a/theories/Reals/ConstructiveRcomplete.v b/theories/Reals/ConstructiveRcomplete.v new file mode 100644 index 0000000000..9fb98a528b --- /dev/null +++ b/theories/Reals/ConstructiveRcomplete.v @@ -0,0 +1,343 @@ +(************************************************************************) +(* * 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 QArith_base. +Require Import Qabs. +Require Import ConstructiveCauchyReals. +Require Import ConstructiveRIneq. + +Local Open Scope R_scope_constr. + +Lemma CReal_absSmall : forall x y : CReal, + (exists n : positive, Qlt (2 # n) + (proj1_sig x (Pos.to_nat n) - Qabs (proj1_sig y (Pos.to_nat n)))) + -> (CRealLt (CReal_opp x) y /\ CRealLt y x). +Proof. + intros. destruct H as [n maj]. split. + - exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + simpl in maj. unfold Qminus. rewrite Qopp_involutive. + rewrite Qplus_comm. + apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). + apply maj. apply Qplus_le_r. + rewrite <- (Qopp_involutive (yn (Pos.to_nat n))). + apply Qopp_le_compat. rewrite Qabs_opp. apply Qle_Qabs. + - exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + simpl in maj. + apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). + apply maj. apply Qplus_le_r. apply Qopp_le_compat. apply Qle_Qabs. +Qed. + +Definition Un_cv_mod (un : nat -> CReal) (l : CReal) : Set + := forall n : positive, + { p : nat | forall i:nat, le p i + -> -IQR (1#n) < un i - l < IQR (1#n) }. + +Lemma Un_cv_mod_eq : forall (v u : nat -> CReal) (s : CReal), + (forall n:nat, u n == v n) + -> Un_cv_mod u s -> Un_cv_mod v s. +Proof. + intros v u s seq H1 p. specialize (H1 p) as [N H0]. + exists N. intros. rewrite <- seq. apply H0. apply H. +Qed. + +Lemma IQR_double_inv : forall n : positive, + IQR (1 # 2*n) + IQR (1 # 2*n) == IQR (1 # n). +Proof. + intros. apply (Rmult_eq_reg_l (IPR (2*n))). + unfold IQR. do 2 rewrite Rmult_1_l. + rewrite Rmult_plus_distr_l, Rinv_r, IPR_double, Rmult_assoc, Rinv_r. + rewrite (Rmult_plus_distr_r 1 1). ring. + right. apply IPR_pos. + right. apply IPR_pos. + right. apply IPR_pos. +Qed. + +Lemma CV_mod_plus : + forall (An Bn:nat -> CReal) (l1 l2:CReal), + Un_cv_mod An l1 -> Un_cv_mod Bn l2 + -> Un_cv_mod (fun i:nat => An i + Bn i) (l1 + l2). +Proof. + assert (forall x:CReal, x + x == 2*x) as double. + { intro. rewrite (Rmult_plus_distr_r 1 1), Rmult_1_l. reflexivity. } + intros. intros n. + destruct (H (2*n)%positive). + destruct (H0 (2*n)%positive). + exists (Nat.max x x0). intros. + setoid_replace (An i + Bn i - (l1 + l2)) + with (An i - l1 + (Bn i - l2)). 2: ring. + rewrite <- IQR_double_inv. split. + - rewrite Ropp_plus_distr. + apply Rplus_lt_compat. apply a. apply (le_trans _ (max x x0)). + apply Nat.le_max_l. apply H1. + apply a0. apply (le_trans _ (max x x0)). + apply Nat.le_max_r. apply H1. + - apply Rplus_lt_compat. apply a. apply (le_trans _ (max x x0)). + apply Nat.le_max_l. apply H1. + apply a0. apply (le_trans _ (max x x0)). + apply Nat.le_max_r. apply H1. +Qed. + +Lemma Un_cv_mod_const : forall x : CReal, + Un_cv_mod (fun _ => x) x. +Proof. + intros. intro p. exists O. intros. + unfold CReal_minus. rewrite Rplus_opp_r. + split. rewrite <- Ropp_0. + apply Ropp_gt_lt_contravar. unfold IQR. rewrite Rmult_1_l. + apply Rinv_0_lt_compat. unfold IQR. rewrite Rmult_1_l. + apply Rinv_0_lt_compat. +Qed. + +(** Unicity of limit for convergent sequences *) +Lemma UL_sequence_mod : + forall (Un:nat -> CReal) (l1 l2:CReal), + Un_cv_mod Un l1 -> Un_cv_mod Un l2 -> l1 == l2. +Proof. + assert (forall (Un:nat -> CReal) (l1 l2:CReal), + Un_cv_mod Un l1 -> Un_cv_mod Un l2 + -> l1 <= l2). + - intros Un l1 l2; unfold Un_cv_mod; intros. intro abs. + assert (0 < l1 - l2) as epsPos. + { apply Rgt_minus. apply abs. } + destruct (Rup_nat ((/(l1-l2)) (or_intror epsPos))) as [n nmaj]. + assert (lt 0 n) as nPos. + { apply (INR_lt 0). apply (Rlt_trans _ ((/ (l1 - l2)) (or_intror epsPos))). + 2: apply nmaj. apply Rinv_0_lt_compat. } + specialize (H (2*Pos.of_nat n)%positive) as [i imaj]. + specialize (H0 (2*Pos.of_nat n))%positive as [j jmaj]. + specialize (imaj (max i j) (Nat.le_max_l _ _)) as [imaj _]. + specialize (jmaj (max i j) (Nat.le_max_r _ _)) as [_ jmaj]. + apply Ropp_gt_lt_contravar in imaj. rewrite Ropp_involutive in imaj. + unfold CReal_minus in imaj. rewrite Ropp_plus_distr in imaj. + rewrite Ropp_involutive in imaj. rewrite Rplus_comm in imaj. + apply (Rplus_lt_compat _ _ _ _ imaj) in jmaj. + clear imaj. + rewrite Rplus_assoc in jmaj. unfold CReal_minus in jmaj. + rewrite <- (Rplus_assoc (- Un (Init.Nat.max i j))) in jmaj. + rewrite Rplus_opp_l in jmaj. + rewrite <- double in jmaj. rewrite Rplus_0_l in jmaj. + rewrite (Rmult_plus_distr_r 1 1), Rmult_1_l, IQR_double_inv in jmaj. + unfold IQR in jmaj. rewrite Rmult_1_l in jmaj. + apply (Rmult_lt_compat_l (IPR (Pos.of_nat n))) in jmaj. + rewrite Rinv_r, <- INR_IPR, Nat2Pos.id in jmaj. + apply (Rmult_lt_compat_l (l1-l2)) in nmaj. + rewrite Rinv_r in nmaj. rewrite Rmult_comm in jmaj. + apply (CRealLt_asym 1 ((l1-l2)*INR n)); assumption. + right. apply epsPos. apply epsPos. + intro abss. subst n. inversion nPos. + right. apply IPR_pos. apply IPR_pos. + - intros. split; apply (H Un); assumption. +Qed. + +Definition Un_cauchy_mod (un : nat -> CReal) : Set + := forall n : positive, + { p : nat | forall i j:nat, le p i + -> le p j + -> -IQR (1#n) < un i - un j < IQR (1#n) }. + +Definition RQ_limit : forall (x : CReal) (n:nat), + { q:Q | x < IQR q < x + IQR (1 # Pos.of_nat n) }. +Proof. + intros x n. apply (FQ_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. + +Definition Un_cauchy_Q (xn : nat -> Q) : Set + := forall n : positive, + { k : nat | forall p q : nat, le k p -> le k q + -> Qlt (-(1#n)) (xn p - xn q) + /\ Qlt (xn p - xn q) (1#n) }. + +Lemma Rdiag_cauchy_sequence : forall (xn : nat -> CReal), + Un_cauchy_mod xn + -> Un_cauchy_Q (fun n => proj1_sig (RQ_limit (xn n) n)). +Proof. + intros xn H p. specialize (H (2 * p)%positive) as [k cv]. + exists (max k (2 * Pos.to_nat p)). intros. + specialize (cv p0 q). destruct cv. + apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). + apply Nat.le_max_l. apply H. + apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). + apply Nat.le_max_l. apply H0. + split. + - apply lt_IQR. unfold Qminus. + apply (Rlt_trans _ (xn p0 - (xn q + IQR (1 # 2 * p)))). + + unfold CReal_minus. rewrite Ropp_plus_distr. unfold CReal_minus. + rewrite <- Rplus_assoc. + apply (Rplus_lt_reg_r (IQR (1 # 2 * p))). + rewrite Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_r. + rewrite <- plus_IQR. + setoid_replace (- (1 # p) + (1 # 2 * p))%Q with (- (1 # 2 * p))%Q. + rewrite opp_IQR. exact H1. + rewrite Qplus_comm. + setoid_replace (1#p)%Q with (2 # 2 *p)%Q. rewrite Qinv_minus_distr. + reflexivity. reflexivity. + + rewrite plus_IQR. apply Rplus_lt_compat. + destruct (RQ_limit (xn p0) p0); simpl. apply a. + destruct (RQ_limit (xn q) q); unfold proj1_sig. + rewrite opp_IQR. apply Ropp_gt_lt_contravar. + apply (Rlt_le_trans _ (xn q + IQR (1 # Pos.of_nat q))). + apply a. apply Rplus_le_compat_l. apply IQR_le. + apply Z2Nat.inj_le. discriminate. discriminate. + simpl. assert ((Pos.to_nat p~0 <= q)%nat). + { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). + 2: apply H0. replace (p~0)%positive with (2*p)%positive. + 2: reflexivity. rewrite Pos2Nat.inj_mul. + apply Nat.le_max_r. } + rewrite Nat2Pos.id. apply H3. intro abs. subst q. + inversion H3. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H5 in H4. inversion H4. + - apply lt_IQR. unfold Qminus. + apply (Rlt_trans _ (xn p0 + IQR (1 # 2 * p) - xn q)). + + rewrite plus_IQR. apply Rplus_lt_compat. + destruct (RQ_limit (xn p0) p0); unfold proj1_sig. + apply (Rlt_le_trans _ (xn p0 + IQR (1 # Pos.of_nat p0))). + apply a. apply Rplus_le_compat_l. apply IQR_le. + apply Z2Nat.inj_le. discriminate. discriminate. + simpl. assert ((Pos.to_nat p~0 <= p0)%nat). + { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). + 2: apply H. replace (p~0)%positive with (2*p)%positive. + 2: reflexivity. rewrite Pos2Nat.inj_mul. + apply Nat.le_max_r. } + rewrite Nat2Pos.id. apply H3. intro abs. subst p0. + inversion H3. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H5 in H4. inversion H4. + rewrite opp_IQR. apply Ropp_gt_lt_contravar. + destruct (RQ_limit (xn q) q); simpl. apply a. + + unfold CReal_minus. rewrite (Rplus_comm (xn p0)). + rewrite Rplus_assoc. + apply (Rplus_lt_reg_l (- IQR (1 # 2 * p))). + rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l. + rewrite <- opp_IQR. rewrite <- plus_IQR. + setoid_replace (- (1 # 2 * p) + (1 # p))%Q with (1 # 2 * p)%Q. + exact H2. rewrite Qplus_comm. + setoid_replace (1#p)%Q with (2 # 2*p)%Q. rewrite Qinv_minus_distr. + reflexivity. reflexivity. +Qed. + +(* An element of CReal is a Cauchy sequence of rational numbers, + show that it converges to itself in CReal. *) +Lemma CReal_cv_self : forall (qn : nat -> Q) (x : CReal) (cvmod : positive -> nat), + QSeqEquiv qn (fun n => proj1_sig x n) cvmod + -> Un_cv_mod (fun n => IQR (qn n)) x. +Proof. + intros qn x cvmod H p. + specialize (H (2*p)%positive). exists (cvmod (2*p)%positive). + intros p0 H0. unfold CReal_minus. rewrite FinjectQ_CReal. + setoid_replace (IQR (qn p0)) with (inject_Q (qn p0)). + 2: apply FinjectQ_CReal. + apply CReal_absSmall. + exists (Pos.max (4 * p)%positive (Pos.of_nat (cvmod (2 * p)%positive))). + setoid_replace (proj1_sig (inject_Q (1 # p)) (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))) + with (1 # p)%Q. + 2: reflexivity. + setoid_replace (proj1_sig (CReal_plus (inject_Q (qn p0)) (CReal_opp x)) (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))) + with (qn p0 - proj1_sig x (2 * (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive)))))%nat)%Q. + 2: destruct x; reflexivity. + apply (Qle_lt_trans _ (1 # 2 * p)). + unfold Qle; simpl. rewrite Pos2Z.inj_max. apply Z.le_max_l. + rewrite <- (Qplus_lt_r _ _ (-(1#p))). unfold Qminus. rewrite Qplus_assoc. + rewrite (Qplus_comm _ (1#p)). rewrite Qplus_opp_r. rewrite Qplus_0_l. + setoid_replace (- (1 # p) + (1 # 2 * p))%Q with (-(1 # 2 * p))%Q. + apply Qopp_lt_compat. apply H. apply H0. + + rewrite Pos2Nat.inj_max. + apply (le_trans _ (1 * Nat.max (Pos.to_nat (4 * p)) (Pos.to_nat (Pos.of_nat (cvmod (2 * p)%positive))))). + destruct (cvmod (2*p)%positive). apply le_0_n. rewrite mult_1_l. + rewrite Nat2Pos.id. 2: discriminate. apply Nat.le_max_r. + apply Nat.mul_le_mono_nonneg_r. apply le_0_n. auto. + setoid_replace (1 # p)%Q with (2 # 2 * p)%Q. + rewrite Qplus_comm. rewrite Qinv_minus_distr. + reflexivity. reflexivity. +Qed. + +Lemma Un_cv_extens : forall (xn yn : nat -> CReal) (l : CReal), + Un_cv_mod xn l + -> (forall n : nat, xn n == yn n) + -> Un_cv_mod yn l. +Proof. + intros. intro p. destruct (H p) as [n cv]. exists n. + intros. unfold CReal_minus. rewrite <- (H0 i). apply cv. apply H1. +Qed. + +(* Q is dense in Archimedean fields, so all real numbers + are limits of rational sequences. + The biggest computable such field has all rational limits. *) +Lemma R_has_all_rational_limits : forall qn : nat -> Q, + Un_cauchy_Q qn + -> { r : CReal & Un_cv_mod (fun n => IQR (qn n)) r }. +Proof. + (* qn is an element of CReal. Show that IQR qn + converges to it in CReal. *) + intros. + destruct (standard_modulus qn (fun p => proj1_sig (H p))). + - intros p n k H0 H1. destruct (H p); simpl in H0,H1. + specialize (a n k H0 H1). apply Qabs_case. + intros _. apply a. intros _. + rewrite <- (Qopp_involutive (1#p)). apply Qopp_lt_compat. + apply a. + - exists (exist _ (fun n : nat => + qn (increasing_modulus (fun p : positive => proj1_sig (H p)) n)) H0). + apply (Un_cv_extens (fun n : nat => IQR (qn n))). + apply (CReal_cv_self qn (exist _ (fun n : nat => + qn (increasing_modulus (fun p : positive => proj1_sig (H p)) n)) H0) + (fun p : positive => Init.Nat.max (proj1_sig (H p)) (Pos.to_nat p))). + apply H1. intro n. reflexivity. +Qed. + +Lemma Rcauchy_complete : forall (xn : nat -> CReal), + Un_cauchy_mod xn + -> { l : CReal & Un_cv_mod xn l }. +Proof. + intros xn cau. + destruct (R_has_all_rational_limits (fun n => proj1_sig (RQ_limit (xn n) n)) + (Rdiag_cauchy_sequence xn cau)) + as [l cv]. + exists l. intro p. specialize (cv (2*p)%positive) as [k cv]. + exists (max k (2 * Pos.to_nat p)). intros p0 H. specialize (cv p0). + destruct cv. apply (le_trans _ (max k (2 * Pos.to_nat p))). + apply Nat.le_max_l. apply H. + destruct (RQ_limit (xn p0) p0) as [q maj]; unfold proj1_sig in H0,H1. + split. + - apply (Rlt_trans _ (IQR q - IQR (1 # 2 * p) - l)). + + unfold CReal_minus. rewrite (Rplus_comm (IQR q)). + apply (Rplus_lt_reg_l (IQR (1 # 2 * p))). + ring_simplify. unfold CReal_minus. rewrite <- opp_IQR. rewrite <- plus_IQR. + setoid_replace ((1 # 2 * p) + - (1 # p))%Q with (-(1#2*p))%Q. + rewrite opp_IQR. apply H0. + setoid_replace (1#p)%Q with (2 # 2*p)%Q. + rewrite Qinv_minus_distr. reflexivity. reflexivity. + + unfold CReal_minus. apply Rplus_lt_compat_r. + apply (Rplus_lt_reg_r (IQR (1 # 2 * p))). + ring_simplify. rewrite Rplus_comm. + apply (Rlt_le_trans _ (xn p0 + IQR (1 # Pos.of_nat p0))). + apply maj. apply Rplus_le_compat_l. + apply IQR_le. + apply Z2Nat.inj_le. discriminate. discriminate. + simpl. assert ((Pos.to_nat p~0 <= p0)%nat). + { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). + 2: apply H. replace (p~0)%positive with (2*p)%positive. + 2: reflexivity. rewrite Pos2Nat.inj_mul. + apply Nat.le_max_r. } + rewrite Nat2Pos.id. apply H2. intro abs. subst p0. + inversion H2. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H4 in H3. inversion H3. + - apply (Rlt_trans _ (IQR q - l)). + + apply Rplus_lt_compat_r. apply maj. + + apply (Rlt_trans _ (IQR (1 # 2 * p))). + apply H1. apply IQR_lt. + rewrite <- Qplus_0_r. + setoid_replace (1#p)%Q with ((1#2*p)+(1#2*p))%Q. + apply Qplus_lt_r. reflexivity. + rewrite Qplus_same_denom. reflexivity. +Qed. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 51ae0baf1b..72475b79d7 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -13,6 +13,7 @@ (** * Basic lemmas for the classical real numbers *) (*********************************************************) +Require Import ConstructiveRIneq. Require Export Raxioms. Require Import Rpow_def. Require Import Zpower. @@ -456,13 +457,11 @@ Qed. Lemma Rplus_eq_0_l : forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0. Proof. - 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. + 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. Qed. Lemma Rplus_eq_R0 : @@ -542,11 +541,9 @@ Qed. (**********) Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 = r * r2 -> r <> 0 -> r1 = r2. Proof. - intros; transitivity (/ r * r * r1). - field; trivial. - transitivity (/ r * r * r2). - repeat rewrite Rmult_assoc; rewrite H; trivial. - field; trivial. + intros. apply Rquot1. apply (Rmult_eq_reg_l (Rrepr r)). + rewrite <- Rrepr_mult, <- Rrepr_mult, H. reflexivity. + rewrite Rrepr_appart, Rrepr_0 in H0. exact H0. Qed. Lemma Rmult_eq_reg_r : forall r r1 r2, r1 * r = r2 * r -> r <> 0 -> r1 = r2. @@ -999,19 +996,15 @@ Qed. Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. Proof. - intros; cut (- r + r + r1 < - r + r + r2). - rewrite Rplus_opp_l. - elim (Rplus_ne r1); elim (Rplus_ne r2); intros; rewrite <- H3; rewrite <- H1; - auto with zarith real. - rewrite Rplus_assoc; rewrite Rplus_assoc; - apply (Rplus_lt_compat_l (- r) (r + r1) (r + r2) H). + intros. rewrite Rlt_def. apply (Rplus_lt_reg_l (Rrepr r)). + rewrite <- Rrepr_plus, <- Rrepr_plus. + rewrite Rlt_def in H. exact H. 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). + intros. rewrite Rlt_def. apply (Rplus_lt_reg_r (Rrepr r)). + rewrite <- Rrepr_plus, <- Rrepr_plus. rewrite Rlt_def in H. exact H. Qed. Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2. @@ -1081,17 +1074,16 @@ Qed. Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. Proof. - unfold Rgt; intros. - apply (Rplus_lt_reg_l (r2 + r1)). - replace (r2 + r1 + - r1) with r2 by ring. - replace (r2 + r1 + - r2) with r1 by ring. - exact H. + intros. rewrite Rlt_def. rewrite Rrepr_opp, Rrepr_opp. + apply Ropp_gt_lt_contravar. unfold Rgt in H. + rewrite Rlt_def in H. exact H. Qed. Hint Resolve Ropp_gt_lt_contravar : core. Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. Proof. - unfold Rgt; auto with real. + intros. unfold Rgt. rewrite Rlt_def. rewrite Rrepr_opp, Rrepr_opp. + apply Ropp_lt_gt_contravar. rewrite Rlt_def in H. exact H. Qed. Hint Resolve Ropp_lt_gt_contravar: real. @@ -1243,11 +1235,10 @@ 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 real. - repeat rewrite (fun x => Rmult_comm x t). - apply Rmult_le_compat_l; auto. - apply Rle_trans with z; auto. + 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. Qed. Hint Resolve Rmult_le_compat: real. @@ -1312,20 +1303,18 @@ 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. - 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. + intros. rewrite Rlt_def in H,H0. rewrite Rlt_def. + apply (Rmult_lt_reg_l (Rrepr r)). + rewrite <- Rrepr_0. exact H. + rewrite <- Rrepr_mult, <- Rrepr_mult. exact H0. Qed. Lemma Rmult_lt_reg_r : forall r r1 r2 : R, 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). + intros. rewrite Rlt_def. rewrite Rlt_def in H, H0. + apply (Rmult_lt_reg_r (Rrepr r)). + rewrite <- Rrepr_0. exact H. + rewrite <- Rrepr_mult, <- Rrepr_mult. exact H0. Qed. Lemma Rmult_gt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. @@ -1333,14 +1322,10 @@ 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 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. + intros. rewrite Rrepr_le. rewrite Rlt_def in H. apply (Rmult_le_reg_l (Rrepr r)). + rewrite <- Rrepr_0. exact H. + rewrite <- Rrepr_mult, <- Rrepr_mult. + rewrite <- Rrepr_le. exact H0. Qed. Lemma Rmult_le_reg_r : forall r r1 r2, 0 < r -> r1 * r <= r2 * r -> r1 <= r2. @@ -1522,7 +1507,7 @@ Qed. Lemma Rinv_1_lt_contravar : forall r1 r2, 1 <= r1 -> r1 < r2 -> / r2 < / r1. Proof. - intros x y H' H'0. + intros x y H' H'0. cut (0 < x); [ intros Lt0 | apply Rlt_le_trans with (r2 := 1) ]; auto with real. apply Rmult_lt_reg_l with (r := x); auto with real. @@ -1585,11 +1570,9 @@ Qed. (**********) Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m. Proof. - 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. + intros. apply Rquot1. + rewrite Rrepr_INR, Rrepr_plus, plus_INR, + <- Rrepr_INR, <- Rrepr_INR. reflexivity. Qed. Hint Resolve plus_INR: real. @@ -1658,16 +1641,8 @@ Hint Resolve pos_INR: real. 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). + intros. apply INR_lt. rewrite Rlt_def in H. + rewrite Rrepr_INR, Rrepr_INR in H. exact H. Qed. Hint Resolve INR_lt: real. @@ -1701,11 +1676,8 @@ Hint Resolve not_0_INR: real. Lemma not_INR : forall n m:nat, n <> m -> INR n <> INR m. Proof. - 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. + intros. rewrite Rrepr_appart, Rrepr_INR, Rrepr_INR. + apply not_INR. exact H. Qed. Hint Resolve not_INR: real. @@ -1746,17 +1718,8 @@ 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|] ; 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. + intros. apply Rquot1. rewrite Rrepr_INR, Rrepr_IPR. + apply INR_IPR. Qed. (**********) @@ -1771,26 +1734,15 @@ 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 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. + intros. apply Rquot1. rewrite Rrepr_plus. + do 3 rewrite Rrepr_IZR. apply plus_IZR_NEG_POS. 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; 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. + intros. apply Rquot1. + rewrite Rrepr_plus. do 3 rewrite Rrepr_IZR. apply plus_IZR. Qed. (**********) @@ -1800,14 +1752,21 @@ 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), + (ConstructiveCauchyReals.CRealEq (Rrepr (pow x n)) + (ConstructiveCauchyReals.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 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]. + intros. apply Rquot1. + rewrite Rrepr_IZR, Rrepr_pow. + rewrite (Rpow_eq_compat _ _ n (Rrepr_IZR z)). + apply pow_IZR. Qed. (**********) @@ -1841,34 +1800,22 @@ 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 real. + intros. apply lt_0_IZR. rewrite <- Rrepr_0, <- Rrepr_IZR. + rewrite Rlt_def in H. exact H. 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). + intros. apply lt_IZR. + rewrite <- Rrepr_IZR, <- Rrepr_IZR. rewrite Rlt_def in H. exact 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. - 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. + intros. apply eq_IZR_R0. + rewrite <- Rrepr_0, <- Rrepr_IZR, H. reflexivity. Qed. (**********) @@ -1944,26 +1891,20 @@ 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 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. + intros. apply one_IZR_lt1. do 2 rewrite Rlt_def in H. split. + rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_opp. apply H. + rewrite <- Rrepr_IZR, <- Rrepr_1. apply H. 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. - 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. + intros. rewrite Rlt_def in H, H0. apply (one_IZR_r_R1 (Rrepr r)); split. + rewrite <- Rrepr_IZR. apply H. + rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_plus, <- Rrepr_le. + apply H. rewrite <- Rrepr_IZR. apply H0. + rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_plus, <- Rrepr_le. + apply H0. Qed. @@ -1996,13 +1937,11 @@ Qed. Lemma Rinv_le_contravar : forall x y, 0 < x -> x <= y -> / y <= / x. Proof. - 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. + intros. apply Rrepr_le. assert (y <> 0). + intro abs. subst y. apply (Rlt_irrefl 0). exact (Rlt_le_trans 0 x 0 H H0). + rewrite Rrepr_appart, Rrepr_0 in H1. rewrite Rlt_def in H. rewrite Rrepr_0 in H. + rewrite (Rrepr_inv y H1), (Rrepr_inv x (or_intror H)). + apply Rinv_le_contravar. rewrite <- Rrepr_le. exact H0. Qed. Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x. @@ -2066,18 +2005,10 @@ Qed. Lemma le_epsilon : forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2. Proof. - 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. + 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. exact H0. Qed. (**********) @@ -2089,7 +2020,7 @@ Proof. Qed. Lemma Rdiv_lt_0_compat : forall a b, 0 < a -> 0 < b -> 0 < a/b. -Proof. +Proof. intros; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat]; assumption. Qed. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 0d29e821c6..8379829037 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -9,36 +9,117 @@ (************************************************************************) (*********************************************************) -(** Axiomatisation of the classical reals *) +(** Lifts of basic operations for classical reals *) (*********************************************************) Require Export ZArith_base. +Require Import ConstructiveCauchyReals. Require Export Rdefinitions. Declare Scope R_scope. Local Open Scope R_scope. (*********************************************************) -(** * Field axioms *) +(** * Field operations *) (*********************************************************) (*********************************************************) (** ** Addition *) (*********************************************************) +Lemma Rrepr_0 : (Rrepr 0 == 0)%CReal. +Proof. + intros. unfold IZR. rewrite RbaseSymbolsImpl.R0_def, (Rquot2 0). reflexivity. +Qed. + +Lemma Rrepr_1 : (Rrepr 1 == 1)%CReal. +Proof. + intros. unfold IZR, IPR. rewrite RbaseSymbolsImpl.R1_def, (Rquot2 1). reflexivity. +Qed. + +Lemma Rrepr_plus : forall x y:R, (Rrepr (x + y) == Rrepr x + Rrepr y)%CReal. +Proof. + intros. rewrite RbaseSymbolsImpl.Rplus_def, Rquot2. reflexivity. +Qed. + +Lemma Rrepr_opp : forall x:R, (Rrepr (- x) == - Rrepr x)%CReal. +Proof. + intros. rewrite RbaseSymbolsImpl.Ropp_def, Rquot2. reflexivity. +Qed. + +Lemma Rrepr_minus : forall x y:R, (Rrepr (x - y) == Rrepr x - Rrepr y)%CReal. +Proof. + intros. unfold Rminus, CReal_minus. + rewrite Rrepr_plus, Rrepr_opp. reflexivity. +Qed. + +Lemma Rrepr_mult : forall x y:R, (Rrepr (x * y) == Rrepr x * Rrepr y)%CReal. +Proof. + intros. rewrite RbaseSymbolsImpl.Rmult_def. rewrite Rquot2. reflexivity. +Qed. + +Lemma Rrepr_inv : forall (x:R) (xnz : (Rrepr x # 0)%CReal), + (Rrepr (/ x) == (/ Rrepr x) xnz)%CReal. +Proof. + intros. rewrite RinvImpl.Rinv_def. destruct (Req_appart_dec x R0). + - exfalso. subst x. destruct xnz. + rewrite Rrepr_0 in H. exact (CRealLt_irrefl 0 H). + rewrite Rrepr_0 in H. exact (CRealLt_irrefl 0 H). + - rewrite Rquot2. apply (CReal_mult_eq_reg_l (Rrepr x) _ _ xnz). + rewrite CReal_mult_comm, (CReal_mult_comm (Rrepr x)), CReal_inv_l, CReal_inv_l. + reflexivity. +Qed. + +Lemma Rrepr_le : forall x y:R, x <= y <-> (Rrepr x <= Rrepr y)%CReal. +Proof. + split. + - intros [H|H] abs. rewrite RbaseSymbolsImpl.Rlt_def 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. contradiction. +Qed. + +Lemma Rrepr_appart : forall x y:R, x <> y <-> (Rrepr x # Rrepr y)%CReal. +Proof. + split. + - intros. destruct (total_order_T x y). destruct s. + left. rewrite RbaseSymbolsImpl.Rlt_def in r. exact r. contradiction. + right. rewrite RbaseSymbolsImpl.Rlt_def in r. exact r. + - intros [H|H] abs. + destruct abs. exact (CRealLt_asym (Rrepr x) (Rrepr x) H H). + destruct abs. exact (CRealLt_asym (Rrepr x) (Rrepr x) H H). +Qed. + + (**********) -Axiom Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1. +Lemma Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1. +Proof. + intros. apply Rquot1. do 2 rewrite Rrepr_plus. apply CReal_plus_comm. +Qed. Hint Resolve Rplus_comm: real. (**********) -Axiom Rplus_assoc : forall r1 r2 r3:R, r1 + r2 + r3 = r1 + (r2 + r3). +Lemma Rplus_assoc : forall r1 r2 r3:R, r1 + r2 + r3 = r1 + (r2 + r3). +Proof. + intros. apply Rquot1. repeat rewrite Rrepr_plus. + apply CReal_plus_assoc. +Qed. Hint Resolve Rplus_assoc: real. (**********) -Axiom Rplus_opp_r : forall r:R, r + - r = 0. +Lemma Rplus_opp_r : forall r:R, r + - r = 0. +Proof. + intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_opp, Rrepr_0. + apply CReal_plus_opp_r. +Qed. Hint Resolve Rplus_opp_r: real. (**********) -Axiom Rplus_0_l : forall r:R, 0 + r = r. +Lemma Rplus_0_l : forall r:R, 0 + r = r. +Proof. + intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_0. + apply CReal_plus_0_l. +Qed. Hint Resolve Rplus_0_l: real. (***********************************************************) @@ -46,23 +127,52 @@ Hint Resolve Rplus_0_l: real. (***********************************************************) (**********) -Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. +Lemma Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. +Proof. + intros. apply Rquot1. do 2 rewrite Rrepr_mult. apply CReal_mult_comm. +Qed. Hint Resolve Rmult_comm: real. (**********) -Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3). +Lemma Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3). +Proof. + intros. apply Rquot1. repeat rewrite Rrepr_mult. + apply CReal_mult_assoc. +Qed. Hint Resolve Rmult_assoc: real. (**********) -Axiom Rinv_l : forall r:R, r <> 0 -> / r * r = 1. +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 CReal_inv_l. +Qed. Hint Resolve Rinv_l: real. (**********) -Axiom Rmult_1_l : forall r:R, 1 * r = r. +Lemma Rmult_1_l : forall r:R, 1 * r = r. +Proof. + intros. apply Rquot1. rewrite Rrepr_mult, Rrepr_1. + apply CReal_mult_1_l. +Qed. Hint Resolve Rmult_1_l: real. (**********) -Axiom R1_neq_R0 : 1 <> 0. +Lemma R1_neq_R0 : 1 <> 0. +Proof. + intro abs. + assert (1 == 0)%CReal. + { transitivity (Rrepr 1). symmetry. + replace 1 with (Rabst 1). 2: unfold IZR,IPR; rewrite RbaseSymbolsImpl.R1_def; reflexivity. + rewrite Rquot2. reflexivity. transitivity (Rrepr 0). + rewrite abs. reflexivity. + replace 0 with (Rabst 0). + 2: unfold IZR; rewrite RbaseSymbolsImpl.R0_def; reflexivity. + rewrite Rquot2. reflexivity. } + pose proof (CRealLt_morph 0 0 (CRealEq_refl _) 1 0 H). + apply (CRealLt_irrefl 0). apply H0. apply CRealLt_0_1. +Qed. Hint Resolve R1_neq_R0: real. (*********************************************************) @@ -70,36 +180,52 @@ Hint Resolve R1_neq_R0: real. (*********************************************************) (**********) -Axiom +Lemma Rmult_plus_distr_l : forall r1 r2 r3:R, r1 * (r2 + r3) = r1 * r2 + r1 * r3. +Proof. + intros. apply Rquot1. + rewrite Rrepr_mult, Rrepr_plus, Rrepr_plus, Rrepr_mult, Rrepr_mult. + apply CReal_mult_plus_distr_l. +Qed. Hint Resolve Rmult_plus_distr_l: real. (*********************************************************) -(** * Order axioms *) -(*********************************************************) -(*********************************************************) -(** ** Total Order *) +(** * Order *) (*********************************************************) -(**********) -Axiom total_order_T : forall r1 r2:R, {r1 < r2} + {r1 = r2} + {r1 > r2}. - (*********************************************************) (** ** Lower *) (*********************************************************) (**********) -Axiom Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1. +Lemma Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1. +Proof. + intros. intro abs. rewrite RbaseSymbolsImpl.Rlt_def in H, abs. + apply (CRealLt_asym (Rrepr r1) (Rrepr r2)); assumption. +Qed. (**********) -Axiom Rlt_trans : forall r1 r2 r3:R, r1 < r2 -> r2 < r3 -> r1 < r3. +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 (CRealLt_trans (Rrepr r1) (Rrepr r2) (Rrepr r3)); assumption. +Qed. (**********) -Axiom Rplus_lt_compat_l : forall r r1 r2:R, r1 < r2 -> r + r1 < r + r2. +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 CReal_plus_lt_compat_l. exact H. +Qed. (**********) -Axiom - Rmult_lt_compat_l : forall r r1 r2:R, 0 < r -> r1 < r2 -> r * r1 < r * r2. +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 CReal_mult_lt_compat_l. + rewrite <- (Rquot2 0). unfold IZR in H. rewrite RbaseSymbolsImpl.R0_def in H. exact H. + rewrite RbaseSymbolsImpl.Rlt_def in H0. exact H0. +Qed. Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real. @@ -116,13 +242,97 @@ Fixpoint INR (n:nat) : R := end. Arguments INR n%nat. - (**********************************************************) (** * [R] Archimedean *) (**********************************************************) +Lemma Rrepr_INR : forall n : nat, + (Rrepr (INR n) == ConstructiveCauchyReals.INR n)%CReal. +Proof. + induction n. + - apply Rrepr_0. + - simpl. destruct n. apply Rrepr_1. + rewrite Rrepr_plus, <- IHn, Rrepr_1. reflexivity. +Qed. + +Lemma Rrepr_IPR2 : forall n : positive, + (Rrepr (IPR_2 n) == ConstructiveCauchyReals.IPR_2 n)%CReal. +Proof. + induction n. + - unfold IPR_2, ConstructiveCauchyReals.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, ConstructiveCauchyReals.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, ConstructiveCauchyReals.IPR_2. + rewrite RbaseSymbolsImpl.R1_def. + rewrite Rrepr_plus, Rquot2. reflexivity. +Qed. + +Lemma Rrepr_IPR : forall n : positive, + (Rrepr (IPR n) == ConstructiveCauchyReals.IPR n)%CReal. +Proof. + intro n. destruct n. + - unfold IPR, ConstructiveCauchyReals.IPR. + rewrite Rrepr_plus, <- Rrepr_IPR2. + rewrite RbaseSymbolsImpl.R1_def. rewrite Rquot2. reflexivity. + - unfold IPR, ConstructiveCauchyReals.IPR. + apply Rrepr_IPR2. + - unfold IPR. rewrite RbaseSymbolsImpl.R1_def. apply Rquot2. +Qed. + +Lemma Rrepr_IZR : forall n : Z, + (Rrepr (IZR n) == ConstructiveCauchyReals.IZR n)%CReal. +Proof. + intros [|p|n]. + - unfold IZR. rewrite RbaseSymbolsImpl.R0_def. apply Rquot2. + - apply Rrepr_IPR. + - unfold IZR, ConstructiveCauchyReals.IZR. + rewrite <- Rrepr_IPR, Rrepr_opp. reflexivity. +Qed. + (**********) -Axiom archimed : forall r:R, IZR (up r) > r /\ IZR (up r) - r <= 1. +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 s. + - split. unfold Rgt. rewrite RbaseSymbolsImpl.Rlt_def. rewrite Rrepr_IZR. apply nmaj. + unfold Rle. left. exact r0. + - split. unfold Rgt. rewrite RbaseSymbolsImpl.Rlt_def. rewrite Rrepr_IZR. apply nmaj. + right. exact e. + - split. + + unfold Rgt, Z.pred. rewrite RbaseSymbolsImpl.Rlt_def. rewrite Rrepr_IZR, plus_IZR. + rewrite RbaseSymbolsImpl.Rlt_def in r0. rewrite Rrepr_minus in r0. + rewrite <- (Rrepr_IZR n). + unfold ConstructiveCauchyReals.IZR, ConstructiveCauchyReals.IPR. + apply (CReal_plus_lt_compat_l (Rrepr r - Rrepr R1)) in r0. + ring_simplify in r0. rewrite RbaseSymbolsImpl.R1_def in r0. rewrite Rquot2 in r0. + rewrite CReal_plus_comm. exact r0. + + destruct (total_order_T (IZR (Z.pred n) - r) 1). destruct s. + left. exact r1. right. exact e. + exfalso. rewrite <- Rrepr_IZR in nmaj. + apply (Rlt_asym (IZR n) (r + 2)). + rewrite RbaseSymbolsImpl.Rlt_def. rewrite Rrepr_plus. rewrite (Rrepr_plus 1 1). + apply (CRealLt_Le_trans _ (Rrepr r + 2)). apply nmaj. + unfold IZR, IPR. rewrite RbaseSymbolsImpl.R1_def, Rquot2. 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 ConstructiveCauchyReals.IZR, ConstructiveCauchyReals.IPR in r1. + rewrite RbaseSymbolsImpl.Rlt_def, Rrepr_plus. + apply (CReal_plus_lt_compat_l (Rrepr r + 1)) in r1. + ring_simplify in r1. + apply (CRealLe_Lt_trans _ (Rrepr r + Rrepr 1 + 1)). 2: apply r1. + rewrite (Rrepr_plus 1 1). unfold IZR, IPR. + rewrite RbaseSymbolsImpl.R1_def, (Rquot2 1), <- CReal_plus_assoc. + apply CRealLe_refl. +Qed. (**********************************************************) (** * [R] Complete *) @@ -139,6 +349,11 @@ Definition is_lub (E:R -> Prop) (m:R) := is_upper_bound E m /\ (forall b:R, is_upper_bound E b -> m <= b). (**********) +(* This axiom can be proved by excluded middle in sort Set. + For this, define a sequence by dichotomy, using excluded middle + to know whether the current point majorates E or not. + Then conclude by the Cauchy-completeness of R, which is proved + constructively. *) Axiom completeness : forall E:R -> Prop, diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index bb32000841..03eb6c8b44 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -8,11 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(*********************************************************) -(** Definitions for the axiomatization *) -(*********************************************************) +(* Classical quotient of the constructive Cauchy real numbers. *) Require Export ZArith_base. +Require Import QArith_base. +Require Import ConstructiveCauchyReals. Parameter R : Set. @@ -28,19 +28,69 @@ Bind Scope R_scope with R. Local Open Scope R_scope. -Parameter R0 : R. -Parameter R1 : R. -Parameter Rplus : R -> R -> R. -Parameter Rmult : R -> R -> R. -Parameter Ropp : R -> R. -Parameter Rinv : R -> R. -Parameter Rlt : R -> R -> Prop. -Parameter up : R -> Z. +(* 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 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. + +(* Those symbols must be kept opaque, for backward compatibility. *) +Module Type RbaseSymbolsSig. + Parameter R0 : R. + Parameter R1 : R. + Parameter Rplus : R -> R -> R. + Parameter Rmult : R -> R -> R. + Parameter Ropp : R -> R. + Parameter Rlt : R -> R -> Prop. + + Parameter R0_def : R0 = Rabst 0%CReal. + Parameter R1_def : R1 = Rabst 1%CReal. + Parameter Rplus_def : forall x y : R, + Rplus x y = Rabst (CReal_plus (Rrepr x) (Rrepr y)). + Parameter Rmult_def : forall x y : R, + Rmult x y = Rabst (CReal_mult (Rrepr x) (Rrepr y)). + Parameter Ropp_def : forall x : R, + Ropp x = Rabst (CReal_opp (Rrepr x)). + Parameter Rlt_def : forall x y : R, + Rlt x y = CRealLt (Rrepr x) (Rrepr y). +End RbaseSymbolsSig. + +Module RbaseSymbolsImpl : RbaseSymbolsSig. + Definition R0 : R := Rabst 0%CReal. + Definition R1 : R := Rabst 1%CReal. + Definition Rplus : R -> R -> R + := fun x y : R => Rabst (CReal_plus (Rrepr x) (Rrepr y)). + Definition Rmult : R -> R -> R + := fun x y : R => Rabst (CReal_mult (Rrepr x) (Rrepr y)). + Definition Ropp : R -> R + := fun x : R => Rabst (CReal_opp (Rrepr x)). + Definition Rlt : R -> R -> Prop + := fun x y : R => CRealLt (Rrepr x) (Rrepr y). + + Definition R0_def := eq_refl R0. + Definition R1_def := eq_refl R1. + Definition Rplus_def := fun x y => eq_refl (Rplus x y). + Definition Rmult_def := fun x y => eq_refl (Rmult x y). + Definition Ropp_def := fun x => eq_refl (Ropp x). + Definition Rlt_def := fun x y => eq_refl (Rlt x y). +End RbaseSymbolsImpl. +Export RbaseSymbolsImpl. + +(* Keep the same names as before *) +Notation R0 := RbaseSymbolsImpl.R0 (only parsing). +Notation R1 := RbaseSymbolsImpl.R1 (only parsing). +Notation Rplus := RbaseSymbolsImpl.Rplus (only parsing). +Notation Rmult := RbaseSymbolsImpl.Rmult (only parsing). +Notation Ropp := RbaseSymbolsImpl.Ropp (only parsing). +Notation Rlt := RbaseSymbolsImpl.Rlt (only parsing). Infix "+" := Rplus : R_scope. Infix "*" := Rmult : R_scope. Notation "- x" := (Ropp x) : R_scope. -Notation "/ x" := (Rinv x) : R_scope. Infix "<" := Rlt : R_scope. @@ -58,13 +108,10 @@ Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 = r2. (**********) Definition Rminus (r1 r2:R) : R := r1 + - r2. -(**********) -Definition Rdiv (r1 r2:R) : R := r1 * / r2. (**********) Infix "-" := Rminus : R_scope. -Infix "/" := Rdiv : R_scope. Infix "<=" := Rle : R_scope. Infix ">=" := Rge : R_scope. @@ -103,3 +150,82 @@ Definition IZR (z:Z) : R := | Zneg n => - IPR n end. Arguments IZR z%Z : simpl never. + +Lemma CRealLt_dec : forall x y : CReal, { CRealLt x y } + { ~CRealLt x y }. +Proof. + intros. + destruct (sig_forall_dec + (fun n:nat => Qle (proj1_sig y (S n) - proj1_sig x (S n)) (2 # Pos.of_nat (S n)))). + - intro n. destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) + (proj1_sig y (S n) - proj1_sig x (S n))). + right. apply Qlt_not_le. exact q. left. exact q. + - left. destruct s as [n nmaj]. exists (Pos.of_nat (S n)). + rewrite Nat2Pos.id. apply Qnot_le_lt. exact nmaj. discriminate. + - right. intro abs. destruct abs as [n majn]. + specialize (q (pred (Pos.to_nat n))). + replace (S (pred (Pos.to_nat n))) with (Pos.to_nat n) in q. + rewrite Pos2Nat.id in q. + pose proof (Qle_not_lt _ _ q). contradiction. + symmetry. apply Nat.succ_pred. intro abs. + pose proof (Pos2Nat.is_pos n). rewrite abs in H. inversion H. +Qed. + +Lemma total_order_T : forall r1 r2:R, {Rlt r1 r2} + {r1 = r2} + {Rlt r2 r1}. +Proof. + intros. destruct (CRealLt_dec (Rrepr r1) (Rrepr r2)). + - left. left. rewrite RbaseSymbolsImpl.Rlt_def. exact c. + - destruct (CRealLt_dec (Rrepr r2) (Rrepr r1)). + + right. rewrite RbaseSymbolsImpl.Rlt_def. exact c. + + left. right. apply Rquot1. split; assumption. +Qed. + +Lemma Req_appart_dec : forall x y : R, + { x = y } + { x < y \/ y < x }. +Proof. + intros. destruct (total_order_T x y). destruct s. + - right. left. exact r. + - left. exact e. + - right. right. exact r. +Qed. + +Lemma Rrepr_appart_0 : forall x:R, + (x < R0 \/ R0 < x) -> (Rrepr x # 0)%CReal. +Proof. + intros. 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. exact H. +Qed. + +Module Type RinvSig. + Parameter Rinv : R -> R. + 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 ((CReal_inv (Rrepr x) (Rrepr_appart_0 x r))) + end. +End RinvSig. + +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 ((CReal_inv (Rrepr x) (Rrepr_appart_0 x r))) + end. + Definition Rinv_def := fun x => eq_refl (Rinv x). +End RinvImpl. +Notation Rinv := RinvImpl.Rinv (only parsing). + +Notation "/ x" := (Rinv x) : R_scope. + +(**********) +Definition Rdiv (r1 r2:R) : R := r1 * / r2. +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 s. + - exact n. + - (* x = n-1 *) exact n. + - exact (Z.pred n). +Defined. diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index 5ed60b0a0f..2428fc495d 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -178,7 +178,7 @@ Proof. change (cos (PI / 4) <> 0); rewrite cos_PI4; apply R1_sqrt2_neq_0. Qed. -Lemma cos3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2. +Lemma cos_3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2. Proof. replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field. rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4. @@ -186,12 +186,16 @@ Proof. ring. Qed. -Lemma sin3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2. +#[deprecated(since="8.10",note="Use cos_3PI4 instead.")] Notation cos3PI4 := cos_3PI4. + +Lemma sin_3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2. Proof. replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field. now rewrite sin_shift, cos_neg, cos_PI4. Qed. +#[deprecated(since="8.10",note="Use sin_3PI4 instead.")] Notation sin3PI4 := sin_3PI4. + Lemma cos_PI6 : cos (PI / 6) = sqrt 3 / 2. Proof with trivial. apply Rsqr_inj... diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v index c2c97fca4f..b0744caa7b 100644 --- a/theories/ZArith/ZArith.v +++ b/theories/ZArith/ZArith.v @@ -21,6 +21,5 @@ Require Export Zpow_def. Require Export Zcomplements. Require Export Zpower. Require Export Zdiv. -Require Export Zlogarithm. Export ZArithRing. diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v deleted file mode 100644 index edbd3a18fe..0000000000 --- a/theories/ZArith/Zlogarithm.v +++ /dev/null @@ -1,273 +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) *) -(************************************************************************) - -(**********************************************************************) - -(** The integer logarithms with base 2. *) - -(** THIS FILE IS DEPRECATED. - Please rather use [Z.log2] (or [Z.log2_up]), which - are defined in [BinIntDef], and whose properties can - be found in [BinInt.Z]. *) - -(* There are three logarithms defined here, - depending on the rounding of the real 2-based logarithm: - - [Log_inf]: [y = (Log_inf x) iff 2^y <= x < 2^(y+1)] - i.e. [Log_inf x] is the biggest integer that is smaller than [Log x] - - [Log_sup]: [y = (Log_sup x) iff 2^(y-1) < x <= 2^y] - i.e. [Log_inf x] is the smallest integer that is bigger than [Log x] - - [Log_nearest]: [y= (Log_nearest x) iff 2^(y-1/2) < x <= 2^(y+1/2)] - i.e. [Log_nearest x] is the integer nearest from [Log x] *) - -Require Import ZArith_base Omega Zcomplements Zpower. -Local Open Scope Z_scope. - -Section Log_pos. (* Log of positive integers *) - - (** First we build [log_inf] and [log_sup] *) - - Fixpoint log_inf (p:positive) : Z := - match p with - | xH => 0 (* 1 *) - | xO q => Z.succ (log_inf q) (* 2n *) - | xI q => Z.succ (log_inf q) (* 2n+1 *) - end. - - Fixpoint log_sup (p:positive) : Z := - match p with - | xH => 0 (* 1 *) - | xO n => Z.succ (log_sup n) (* 2n *) - | xI n => Z.succ (Z.succ (log_inf n)) (* 2n+1 *) - end. - - Hint Unfold log_inf log_sup : core. - - Lemma Psize_log_inf : forall p, Zpos (Pos.size p) = Z.succ (log_inf p). - Proof. - induction p; simpl; now rewrite ?Pos2Z.inj_succ, ?IHp. - Qed. - - Lemma Zlog2_log_inf : forall p, Z.log2 (Zpos p) = log_inf p. - Proof. - unfold Z.log2. destruct p; simpl; trivial; apply Psize_log_inf. - Qed. - - Lemma Zlog2_up_log_sup : forall p, Z.log2_up (Zpos p) = log_sup p. - Proof. - induction p; simpl log_sup. - - change (Zpos p~1) with (2*(Zpos p)+1). - rewrite Z.log2_up_succ_double, Zlog2_log_inf; try easy. - unfold Z.succ. now rewrite !(Z.add_comm _ 1), Z.add_assoc. - - change (Zpos p~0) with (2*Zpos p). - now rewrite Z.log2_up_double, IHp. - - reflexivity. - Qed. - - (** Then we give the specifications of [log_inf] and [log_sup] - and prove their validity *) - - Hint Resolve Z.le_trans: zarith. - - Theorem log_inf_correct : - forall x:positive, - 0 <= log_inf x /\ two_p (log_inf x) <= Zpos x < two_p (Z.succ (log_inf x)). - Proof. - simple induction x; intros; simpl; - [ elim H; intros Hp HR; clear H; split; - [ auto with zarith - | rewrite two_p_S with (x := Z.succ (log_inf p)) by (apply Z.le_le_succ_r; trivial); - rewrite two_p_S by trivial; - rewrite two_p_S in HR by trivial; rewrite (BinInt.Pos2Z.inj_xI p); - omega ] - | elim H; intros Hp HR; clear H; split; - [ auto with zarith - | rewrite two_p_S with (x := Z.succ (log_inf p)) by (apply Z.le_le_succ_r; trivial); - rewrite two_p_S by trivial; - rewrite two_p_S in HR by trivial; rewrite (BinInt.Pos2Z.inj_xO p); - omega ] - | unfold two_power_pos; unfold shift_pos; simpl; - omega ]. - Qed. - - Definition log_inf_correct1 (p:positive) := proj1 (log_inf_correct p). - Definition log_inf_correct2 (p:positive) := proj2 (log_inf_correct p). - - Opaque log_inf_correct1 log_inf_correct2. - - Hint Resolve log_inf_correct1 log_inf_correct2: zarith. - - Lemma log_sup_correct1 : forall p:positive, 0 <= log_sup p. - Proof. - simple induction p; intros; simpl; auto with zarith. - Qed. - - (** For every [p], either [p] is a power of two and [(log_inf p)=(log_sup p)] - either [(log_sup p)=(log_inf p)+1] *) - - Theorem log_sup_log_inf : - forall p:positive, - IF Zpos p = two_p (log_inf p) then Zpos p = two_p (log_sup p) - else log_sup p = Z.succ (log_inf p). - Proof. - simple induction p; intros; - [ elim H; right; simpl; - rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); - rewrite BinInt.Pos2Z.inj_xI; unfold Z.succ; omega - | elim H; clear H; intro Hif; - [ left; simpl; - rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); - rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0)); - rewrite <- (proj1 Hif); rewrite <- (proj2 Hif); - auto - | right; simpl; - rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); - rewrite BinInt.Pos2Z.inj_xO; unfold Z.succ; - omega ] - | left; auto ]. - Qed. - - Theorem log_sup_correct2 : - forall x:positive, two_p (Z.pred (log_sup x)) < Zpos x <= two_p (log_sup x). - Proof. - intro. - elim (log_sup_log_inf x). - (* x is a power of two and [log_sup = log_inf] *) - intros [E1 E2]; rewrite E2. - split; [ apply two_p_pred; apply log_sup_correct1 | apply Z.le_refl ]. - intros [E1 E2]; rewrite E2. - rewrite (Z.pred_succ (log_inf x)). - generalize (log_inf_correct2 x); omega. - Qed. - - Lemma log_inf_le_log_sup : forall p:positive, log_inf p <= log_sup p. - Proof. - simple induction p; simpl; intros; omega. - Qed. - - Lemma log_sup_le_Slog_inf : forall p:positive, log_sup p <= Z.succ (log_inf p). - Proof. - simple induction p; simpl; intros; omega. - Qed. - - (** Now it's possible to specify and build the [Log] rounded to the nearest *) - - Fixpoint log_near (x:positive) : Z := - match x with - | xH => 0 - | xO xH => 1 - | xI xH => 2 - | xO y => Z.succ (log_near y) - | xI y => Z.succ (log_near y) - end. - - Theorem log_near_correct1 : forall p:positive, 0 <= log_near p. - Proof. - simple induction p; simpl; intros; - [ elim p0; auto with zarith - | elim p0; auto with zarith - | trivial with zarith ]. - intros; apply Z.le_le_succ_r. - generalize H0; now elim p1. - intros; apply Z.le_le_succ_r. - generalize H0; now elim p1. - Qed. - - Theorem log_near_correct2 : - forall p:positive, log_near p = log_inf p \/ log_near p = log_sup p. - Proof. - simple induction p. - intros p0 [Einf| Esup]. - simpl. rewrite Einf. - case p0; [ left | left | right ]; reflexivity. - simpl; rewrite Esup. - elim (log_sup_log_inf p0). - generalize (log_inf_le_log_sup p0). - generalize (log_sup_le_Slog_inf p0). - case p0; auto with zarith. - intros; omega. - case p0; intros; auto with zarith. - intros p0 [Einf| Esup]. - simpl. - repeat rewrite Einf. - case p0; intros; auto with zarith. - simpl. - repeat rewrite Esup. - case p0; intros; auto with zarith. - auto. - Qed. - -End Log_pos. - -Section divers. - - (** Number of significative digits. *) - - Definition N_digits (x:Z) := - match x with - | Zpos p => log_inf p - | Zneg p => log_inf p - | Z0 => 0 - end. - - Lemma ZERO_le_N_digits : forall x:Z, 0 <= N_digits x. - Proof. - simple induction x; simpl; - [ apply Z.le_refl | exact log_inf_correct1 | exact log_inf_correct1 ]. - Qed. - - Lemma log_inf_shift_nat : forall n:nat, log_inf (shift_nat n 1) = Z.of_nat n. - Proof. - simple induction n; intros; - [ try trivial | rewrite Nat2Z.inj_succ; rewrite <- H; reflexivity ]. - Qed. - - Lemma log_sup_shift_nat : forall n:nat, log_sup (shift_nat n 1) = Z.of_nat n. - Proof. - simple induction n; intros; - [ try trivial | rewrite Nat2Z.inj_succ; rewrite <- H; reflexivity ]. - Qed. - - (** [Is_power p] means that p is a power of two *) - Fixpoint Is_power (p:positive) : Prop := - match p with - | xH => True - | xO q => Is_power q - | xI q => False - end. - - Lemma Is_power_correct : - forall p:positive, Is_power p <-> (exists y : nat, p = shift_nat y 1). - Proof. - split; - [ elim p; - [ simpl; tauto - | simpl; intros; generalize (H H0); intro H1; elim H1; - intros y0 Hy0; exists (S y0); rewrite Hy0; reflexivity - | intro; exists 0%nat; reflexivity ] - | intros; elim H; intros; rewrite H0; elim x; intros; simpl; trivial ]. - Qed. - - Lemma Is_power_or : forall p:positive, Is_power p \/ ~ Is_power p. - Proof. - simple induction p; - [ intros; right; simpl; tauto - | intros; elim H; - [ intros; left; simpl; exact H0 - | intros; right; simpl; exact H0 ] - | left; simpl; trivial ]. - Qed. - -End divers. - - - - - - diff --git a/theories/ZArith/Zsqrt_compat.v b/theories/ZArith/Zsqrt_compat.v deleted file mode 100644 index 6873c737a7..0000000000 --- a/theories/ZArith/Zsqrt_compat.v +++ /dev/null @@ -1,234 +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) *) -(************************************************************************) - -Require Import ZArithRing. -Require Import Omega. -Require Export ZArith_base. -Local Open Scope Z_scope. - -(** THIS FILE IS DEPRECATED - - Instead of the various [Zsqrt] defined here, please use rather - [Z.sqrt] (or [Z.sqrtrem]). The latter are pure functions without - proof parts, and more results are available about them. - Some equivalence proofs between the old and the new versions - can be found below. Importing ZArith will provides by default - the new versions. - -*) - -(**********************************************************************) -(** Definition and properties of square root on Z *) - -(** The following tactic replaces all instances of (POS (xI ...)) by - `2*(POS ...)+1`, but only when ... is not made only with xO, XI, or xH. *) -Ltac compute_POS := - match goal with - | |- context [(Zpos (xI ?X1))] => - match constr:(X1) with - | context [1%positive] => fail 1 - | _ => rewrite (Pos2Z.inj_xI X1) - end - | |- context [(Zpos (xO ?X1))] => - match constr:(X1) with - | context [1%positive] => fail 1 - | _ => rewrite (Pos2Z.inj_xO X1) - end - end. - -Inductive sqrt_data (n:Z) : Set := - c_sqrt : forall s r:Z, n = s * s + r -> 0 <= r <= 2 * s -> sqrt_data n. - -Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p). - refine - (fix sqrtrempos (p:positive) : sqrt_data (Zpos p) := - match p return sqrt_data (Zpos p) with - | xH => c_sqrt 1 1 0 _ _ - | xO xH => c_sqrt 2 1 1 _ _ - | xI xH => c_sqrt 3 1 2 _ _ - | xO (xO p') => - match sqrtrempos p' with - | c_sqrt _ s' r' Heq Hint => - match Z_le_gt_dec (4 * s' + 1) (4 * r') with - | left Hle => - c_sqrt (Zpos (xO (xO p'))) (2 * s' + 1) - (4 * r' - (4 * s' + 1)) _ _ - | right Hgt => c_sqrt (Zpos (xO (xO p'))) (2 * s') (4 * r') _ _ - end - end - | xO (xI p') => - match sqrtrempos p' with - | c_sqrt _ s' r' Heq Hint => - match Z_le_gt_dec (4 * s' + 1) (4 * r' + 2) with - | left Hle => - c_sqrt (Zpos (xO (xI p'))) (2 * s' + 1) - (4 * r' + 2 - (4 * s' + 1)) _ _ - | right Hgt => - c_sqrt (Zpos (xO (xI p'))) (2 * s') (4 * r' + 2) _ _ - end - end - | xI (xO p') => - match sqrtrempos p' with - | c_sqrt _ s' r' Heq Hint => - match Z_le_gt_dec (4 * s' + 1) (4 * r' + 1) with - | left Hle => - c_sqrt (Zpos (xI (xO p'))) (2 * s' + 1) - (4 * r' + 1 - (4 * s' + 1)) _ _ - | right Hgt => - c_sqrt (Zpos (xI (xO p'))) (2 * s') (4 * r' + 1) _ _ - end - end - | xI (xI p') => - match sqrtrempos p' with - | c_sqrt _ s' r' Heq Hint => - match Z_le_gt_dec (4 * s' + 1) (4 * r' + 3) with - | left Hle => - c_sqrt (Zpos (xI (xI p'))) (2 * s' + 1) - (4 * r' + 3 - (4 * s' + 1)) _ _ - | right Hgt => - c_sqrt (Zpos (xI (xI p'))) (2 * s') (4 * r' + 3) _ _ - end - end - end); clear sqrtrempos; repeat compute_POS; - try (try rewrite Heq; ring); try omega. -Defined. - -(** Define with integer input, but with a strong (readable) specification. *) -Definition Zsqrt : - forall x:Z, - 0 <= x -> - {s : Z & {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}}. - refine - (fun x => - match - x - return - 0 <= x -> - {s : Z & {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}} - with - | Zpos p => - fun h => - match sqrtrempos p with - | c_sqrt _ s r Heq Hint => - existT - (fun s:Z => - {r : Z | - Zpos p = s * s + r /\ s * s <= Zpos p < (s + 1) * (s + 1)}) - s - (exist - (fun r:Z => - Zpos p = s * s + r /\ - s * s <= Zpos p < (s + 1) * (s + 1)) r _) - end - | Zneg p => - fun h => - False_rec - {s : Z & - {r : Z | - Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}} - (h (eq_refl Datatypes.Gt)) - | Z0 => - fun h => - existT - (fun s:Z => - {r : Z | 0 = s * s + r /\ s * s <= 0 < (s + 1) * (s + 1)}) 0 - (exist - (fun r:Z => 0 = 0 * 0 + r /\ 0 * 0 <= 0 < (0 + 1) * (0 + 1)) 0 - _) - end); try omega. - split; [ omega | rewrite Heq; ring_simplify (s*s) ((s + 1) * (s + 1)); omega ]. -Defined. - -(** Define a function of type Z->Z that computes the integer square root, - but only for positive numbers, and 0 for others. *) -Definition Zsqrt_plain (x:Z) : Z := - match x with - | Zpos p => - match Zsqrt (Zpos p) (Pos2Z.is_nonneg p) with - | existT _ s _ => s - end - | Zneg p => 0 - | Z0 => 0 - end. - -(** A basic theorem about Zsqrt_plain *) - -Theorem Zsqrt_interval : - forall n:Z, - 0 <= n -> - Zsqrt_plain n * Zsqrt_plain n <= n < - (Zsqrt_plain n + 1) * (Zsqrt_plain n + 1). -Proof. - intros [|p|p] Hp. - - now compute. - - unfold Zsqrt_plain. - now destruct Zsqrt as (s & r & Heq & Hint). - - now elim Hp. -Qed. - -(** Positivity *) - -Theorem Zsqrt_plain_is_pos: forall n, 0 <= n -> 0 <= Zsqrt_plain n. -Proof. - intros n m; case (Zsqrt_interval n); auto with zarith. - intros H1 H2; case (Z.le_gt_cases 0 (Zsqrt_plain n)); auto. - intros H3; contradict H2; auto; apply Z.le_ngt. - apply Z.le_trans with ( 2 := H1 ). - replace ((Zsqrt_plain n + 1) * (Zsqrt_plain n + 1)) - with (Zsqrt_plain n * Zsqrt_plain n + (2 * Zsqrt_plain n + 1)); - auto with zarith. - ring. -Qed. - -(** Direct correctness on squares. *) - -Theorem Zsqrt_square_id: forall a, 0 <= a -> Zsqrt_plain (a * a) = a. -Proof. - intros a H. - generalize (Zsqrt_plain_is_pos (a * a)); auto with zarith; intros Haa. - case (Zsqrt_interval (a * a)); auto with zarith. - intros H1 H2. - case (Z.le_gt_cases a (Zsqrt_plain (a * a))); intros H3. - - Z.le_elim H3; auto. - contradict H1; auto; apply Z.lt_nge; auto with zarith. - apply Z.le_lt_trans with (a * Zsqrt_plain (a * a)); auto with zarith. - apply Z.mul_lt_mono_pos_r; auto with zarith. - - contradict H2; auto; apply Z.le_ngt; auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. -Qed. - -(** [Zsqrt_plain] is increasing *) - -Theorem Zsqrt_le: - forall p q, 0 <= p <= q -> Zsqrt_plain p <= Zsqrt_plain q. -Proof. - intros p q [H1 H2]. - Z.le_elim H2; [ | subst q; auto with zarith]. - case (Z.le_gt_cases (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3. - assert (Hp: (0 <= Zsqrt_plain q)). - { apply Zsqrt_plain_is_pos; auto with zarith. } - absurd (q <= p); auto with zarith. - apply Z.le_trans with ((Zsqrt_plain q + 1) * (Zsqrt_plain q + 1)). - case (Zsqrt_interval q); auto with zarith. - apply Z.le_trans with (Zsqrt_plain p * Zsqrt_plain p); auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - case (Zsqrt_interval p); auto with zarith. -Qed. - - -(** Equivalence between Zsqrt_plain and [Z.sqrt] *) - -Lemma Zsqrt_equiv : forall n, Zsqrt_plain n = Z.sqrt n. -Proof. - intros. destruct (Z_le_gt_dec 0 n). - symmetry. apply Z.sqrt_unique; trivial. - now apply Zsqrt_interval. - now destruct n. -Qed. diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 0685f979c8..a44ddf7467 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -940,7 +940,7 @@ and escaped_coq = parse { (* likely to be a syntax error: we escape *) backtrack lexbuf } | eof { Tokens.flush_sublexer () } - | (identifier '.')* identifier + | identifier { Tokens.flush_sublexer(); Output.ident (lexeme lexbuf) None; escaped_coq lexbuf } diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index e49b1c0c07..2673995a86 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -383,7 +383,7 @@ let rec vernac_loop ~state = try let input = top_buffer.tokens in match read_sentence ~state input with - | Some (VernacBacktrack(bid,_,_)) -> + | Some (VernacBackTo bid) -> let bid = Stateid.of_int bid in let doc, res = Stm.edit_at ~doc:state.doc bid in assert (res = `NewTip); diff --git a/toplevel/g_toplevel.mlg b/toplevel/g_toplevel.mlg index fed337ab03..1a1537113e 100644 --- a/toplevel/g_toplevel.mlg +++ b/toplevel/g_toplevel.mlg @@ -17,7 +17,7 @@ open Vernacexpr (* Vernaculars specific to the toplevel *) type vernac_toplevel = - | VernacBacktrack of int * int * int + | VernacBackTo of int | VernacDrop | VernacQuit | VernacControl of vernac_control @@ -54,8 +54,8 @@ GRAMMAR EXTEND Gram vernac_toplevel: FIRST [ [ IDENT "Drop"; "." -> { Some VernacDrop } | IDENT "Quit"; "." -> { Some VernacQuit } - | IDENT "Backtrack"; n = natural ; m = natural ; p = natural; "." -> - { Some (VernacBacktrack (n,m,p)) } + | IDENT "BackTo"; n = natural; "." -> + { Some (VernacBackTo n) } (* show a goal for the specified proof state *) | test_show_goal; IDENT "Show"; IDENT "Goal"; gid = natural; IDENT "at"; sid = natural; "." -> { Some (VernacShowGoal {gid; sid}) } diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 3f13d772ab..74c9bc2886 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -107,26 +107,20 @@ let check_mutuality env evd isfix fixl = warn_non_full_mutual (x,xge,y,yge,isfix,rest) | _ -> () -type structured_fixpoint_expr = { - fix_name : Id.t; - fix_univs : universe_decl_expr option; - fix_annot : lident option; - fix_binders : local_binder_expr list; - fix_body : constr_expr option; - fix_type : constr_expr -} - let interp_fix_context ~program_mode ~cofix env sigma fix = - let before, after = if not cofix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in + let before, after = + if not cofix + then split_at_annot fix.Vernacexpr.binders fix.Vernacexpr.rec_order + else [], fix.Vernacexpr.binders in let sigma, (impl_env, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma before in let sigma, (impl_env', ((env'', ctx'), imps')) = interp_context_evars ~program_mode ~impl_env ~shift:(Context.Rel.nhyps ctx) env' sigma after in - let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in + let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.Vernacexpr.rec_order in sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) let interp_fix_ccl ~program_mode sigma impls (env,_) fix = - let sigma, (c, impl) = interp_type_evars_impls ~program_mode ~impls env sigma fix.fix_type in + let sigma, (c, impl) = interp_type_evars_impls ~program_mode ~impls env sigma fix.Vernacexpr.rtype in let r = Retyping.relevance_of_type env sigma c in sigma, (c, r, impl) @@ -135,7 +129,7 @@ let interp_fix_body ~program_mode env_rec sigma impls (_,ctx) fix ccl = Option.cata (fun body -> let env = push_rel_context ctx env_rec in let sigma, body = interp_casted_constr_evars ~program_mode env sigma ~impls body ccl in - sigma, Some (it_mkLambda_or_LetIn body ctx)) (sigma, None) fix.fix_body + sigma, Some (it_mkLambda_or_LetIn body ctx)) (sigma, None) fix.Vernacexpr.body_def let build_fix_type (_,ctx) ccl = EConstr.it_mkProd_or_LetIn ccl ctx @@ -167,16 +161,16 @@ type recursive_preentry = let fix_proto sigma = Evarutil.new_global sigma (Coqlib.lib_ref "program.tactic.fix_proto") -let interp_recursive ~program_mode ~cofix fixl notations = +let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen list) = let open Context.Named.Declaration in let open EConstr in let env = Global.env() in - let fixnames = List.map (fun fix -> fix.fix_name) fixl in + let fixnames = List.map (fun fix -> fix.Vernacexpr.fname.CAst.v) fixl in (* Interp arities allowing for unresolved types *) let all_universes = List.fold_right (fun sfe acc -> - match sfe.fix_univs , acc with + match sfe.Vernacexpr.univs , acc with | None , acc -> acc | x , None -> x | Some ls , Some us -> @@ -222,6 +216,7 @@ let interp_recursive ~program_mode ~cofix fixl notations = (* Interp bodies with rollback because temp use of notations/implicit *) let sigma, fixdefs = Metasyntax.with_syntax_protection (fun () -> + let notations = List.map_append (fun { Vernacexpr.notations } -> notations) fixl in List.iter (Metasyntax.set_notation_for_interpretation env_rec impls) notations; List.fold_left4_map (fun sigma fixctximpenv -> interp_fix_body ~program_mode env_rec sigma (Id.Map.fold Id.Map.add fixctximpenv impls)) @@ -248,8 +243,8 @@ let ground_fixpoint env evd (fixnames,fixrs,fixdefs,fixtypes) = let fixtypes = List.map EConstr.(to_constr evd) fixtypes in Evd.evar_universe_context evd, (fixnames,fixrs,fixdefs,fixtypes) -let interp_fixpoint ~cofix l ntns = - let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l ntns in +let interp_fixpoint ~cofix l = + let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l in check_recursive true env evd fix; let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) @@ -316,38 +311,29 @@ let extract_decreasing_argument ~structonly = function { CAst.v = v } -> match v | _ -> user_err Pp.(str "Well-founded induction requires Program Fixpoint or Function.") -let extract_fixpoint_components ~structonly l = - let fixl, ntnl = List.split l in - let fixl = List.map (fun (({CAst.v=id},pl),ann,bl,typ,def) -> - (* This is a special case: if there's only one binder, we pick it as the - recursive argument if none is provided. *) - let ann = Option.map (fun ann -> match bl, ann with - | [CLocalAssum([{ CAst.v = Name x }],_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> - CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) - | [CLocalDef({ CAst.v = Name x },_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> - CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) - | _, x -> x) ann - in - let ann = Option.map (extract_decreasing_argument ~structonly) ann in - {fix_name = id; fix_annot = ann; fix_univs = pl; - fix_binders = bl; fix_body = def; fix_type = typ}) fixl in - fixl, List.flatten ntnl - -let extract_cofixpoint_components l = - let fixl, ntnl = List.split l in - List.map (fun (({CAst.v=id},pl),bl,typ,def) -> - {fix_name = id; fix_annot = None; fix_univs = pl; - fix_binders = bl; fix_body = def; fix_type = typ}) fixl, - List.flatten ntnl +(* This is a special case: if there's only one binder, we pick it as + the recursive argument if none is provided. *) +let adjust_rec_order ~structonly binders rec_order = + let rec_order = Option.map (fun rec_order -> match binders, rec_order with + | [CLocalAssum([{ CAst.v = Name x }],_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> + CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) + | [CLocalDef({ CAst.v = Name x },_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> + CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) + | _, x -> x) rec_order + in + Option.map (extract_decreasing_argument ~structonly) rec_order let check_safe () = let open Declarations in let flags = Environ.typing_flags (Global.env ()) in flags.check_universes && flags.check_guarded -let do_fixpoint_common l = - let fixl, ntns = extract_fixpoint_components ~structonly:true l in - let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl ntns in +let do_fixpoint_common (fixl : Vernacexpr.fixpoint_expr list) = + let fixl = List.map (fun fix -> + Vernacexpr.{ fix + with rec_order = adjust_rec_order ~structonly:true fix.binders fix.rec_order }) fixl in + let ntns = List.map_append (fun { Vernacexpr.notations } -> notations ) fixl in + let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl in fixl, ntns, fix, List.map compute_possible_guardness_evidences info let do_fixpoint_interactive ~scope ~poly l : Lemmas.t = @@ -361,17 +347,18 @@ let do_fixpoint ~scope ~poly l = declare_fixpoint_generic ~indexes:possible_indexes ~scope ~poly fix ntns; if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () -let do_cofixpoint_common l = - let fixl,ntns = extract_cofixpoint_components l in - ntns, interp_fixpoint ~cofix:true fixl ntns +let do_cofixpoint_common (fixl : Vernacexpr.cofixpoint_expr list) = + let fixl = List.map (fun fix -> {fix with Vernacexpr.rec_order = None}) fixl in + let ntns = List.map_append (fun { Vernacexpr.notations } -> notations ) fixl in + interp_fixpoint ~cofix:true fixl, ntns let do_cofixpoint_interactive ~scope ~poly l = - let ntns, cofix = do_cofixpoint_common l in + let cofix, ntns = do_cofixpoint_common l in let lemma = declare_fixpoint_interactive_generic ~scope ~poly cofix ntns in if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); lemma let do_cofixpoint ~scope ~poly l = - let ntns, cofix = do_cofixpoint_common l in + let cofix, ntns = do_cofixpoint_common l in declare_fixpoint_generic ~scope ~poly cofix ntns; if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 982d316605..4f8e9018de 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -10,7 +10,6 @@ open Names open Constr -open Constrexpr open Vernacexpr (** {6 Fixpoints and cofixpoints} *) @@ -18,39 +17,35 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint_interactive : - scope:DeclareDef.locality -> poly:bool -> (fixpoint_expr * decl_notation list) list -> Lemmas.t + scope:DeclareDef.locality -> poly:bool -> fixpoint_expr list -> Lemmas.t val do_fixpoint : - scope:DeclareDef.locality -> poly:bool -> (fixpoint_expr * decl_notation list) list -> unit + scope:DeclareDef.locality -> poly:bool -> fixpoint_expr list -> unit val do_cofixpoint_interactive : - scope:DeclareDef.locality -> poly:bool -> (cofixpoint_expr * decl_notation list) list -> Lemmas.t + scope:DeclareDef.locality -> poly:bool -> cofixpoint_expr list -> Lemmas.t val do_cofixpoint : - scope:DeclareDef.locality -> poly:bool -> (cofixpoint_expr * decl_notation list) list -> unit + scope:DeclareDef.locality -> poly:bool -> cofixpoint_expr list -> unit (************************************************************************) (** Internal API *) (************************************************************************) -type structured_fixpoint_expr = { - fix_name : Id.t; - fix_univs : Constrexpr.universe_decl_expr option; - fix_annot : lident option; - fix_binders : local_binder_expr list; - fix_body : constr_expr option; - fix_type : constr_expr -} - (** Typing global fixpoints and cofixpoint_expr *) +val adjust_rec_order + : structonly:bool + -> Constrexpr.local_binder_expr list + -> Constrexpr.recursion_order_expr option + -> lident option + (** Exported for Program *) val interp_recursive : (* Misc arguments *) program_mode:bool -> cofix:bool -> (* Notations of the fixpoint / should that be folded in the previous argument? *) - structured_fixpoint_expr list -> decl_notation list -> - + lident option fix_expr_gen list -> (* env / signature / univs / evar_map *) (Environ.env * EConstr.named_context * UState.universe_decl * Evd.evar_map) * (* names / defs / types *) @@ -60,25 +55,13 @@ val interp_recursive : (** Exported for Funind *) -(** Extracting the semantical components out of the raw syntax of - (co)fixpoints declarations *) - -val extract_fixpoint_components : structonly:bool -> - (fixpoint_expr * decl_notation list) list -> - structured_fixpoint_expr list * decl_notation list +type recursive_preentry = Id.t list * Sorts.relevance list * constr option list * types list -val extract_cofixpoint_components : - (cofixpoint_expr * decl_notation list) list -> - structured_fixpoint_expr list * decl_notation list - -type recursive_preentry = - Id.t list * Sorts.relevance list * constr option list * types list - -val interp_fixpoint : - cofix:bool -> - structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * UState.universe_decl * UState.t * - (EConstr.rel_context * Impargs.manual_implicits * int option) list +val interp_fixpoint + : cofix:bool + -> lident option fix_expr_gen list + -> recursive_preentry * UState.universe_decl * UState.t * + (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Very private function, do not use *) val compute_possible_guardness_evidences : diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 65db4401d9..664010c917 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -80,9 +80,6 @@ type structured_one_inductive_expr = { ind_lc : (Id.t * constr_expr) list } -type structured_inductive_expr = - local_binder_expr list * structured_one_inductive_expr list - let minductive_message = function | [] -> user_err Pp.(str "No inductive definition.") | [x] -> (Id.print x ++ str " is defined") @@ -468,9 +465,6 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not InferCumulativity.infer_inductive env_ar mind_ent else mind_ent), Evd.universe_binders sigma, impls -let interp_mutual_inductive ~template udecl (paramsl,indl) notations ~cumulative ~poly ~private_ind finite = - interp_mutual_inductive_gen (Global.env()) ~template udecl ([],paramsl,indl) notations ~cumulative ~poly ~private_ind finite - (* Very syntactical equality *) let eq_local_binders bl1 bl2 = List.equal local_binder_eq bl1 bl2 diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 97f930c0a1..285be8cd51 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -10,7 +10,6 @@ open Names open Entries -open Libnames open Vernacexpr open Constrexpr @@ -33,12 +32,20 @@ val do_mutual_inductive -> Declarations.recursivity_kind -> unit +(** User-interface API *) + +(** Prepare a "match" template for a given inductive type. + For each branch of the match, we list the constructor name + followed by enough pattern variables. + [Not_found] is raised if the given string isn't the qualid of + a known inductive type. *) + +val make_cases : Names.inductive -> string list list + (************************************************************************) -(** Internal API *) +(** Internal API, exported for Record *) (************************************************************************) -(** Exported for Record and Funind *) - (** Registering a mutual inductive definition together with its associated schemes *) @@ -55,41 +62,3 @@ 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 inductive under consideration. *) - -(** Exported for Funind *) - -(** Extracting the semantical components out of the raw syntax of mutual - inductive declarations *) - -type structured_one_inductive_expr = { - ind_name : Id.t; - ind_arity : constr_expr; - ind_lc : (Id.t * constr_expr) list -} - -type structured_inductive_expr = - local_binder_expr list * structured_one_inductive_expr list - -val extract_mutual_inductive_declaration_components : - (one_inductive_expr * decl_notation list) list -> - structured_inductive_expr * (*coercions:*) qualid list * decl_notation list - -(** Typing mutual inductive definitions *) -val interp_mutual_inductive - : template:bool option - -> universe_decl_expr option - -> structured_inductive_expr - -> decl_notation list - -> cumulative:bool - -> poly:bool - -> private_ind:bool - -> Declarations.recursivity_kind - -> mutual_inductive_entry * UnivNames.universe_binders * one_inductive_impls list - -(** Prepare a "match" template for a given inductive type. - For each branch of the match, we list the constructor name - followed by enough pattern variables. - [Not_found] is raised if the given string isn't the qualid of - a known inductive type. *) - -val make_cases : Names.inductive -> string list list diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 0fd65ad9b4..c6e68effd7 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -244,10 +244,10 @@ let collect_evars_of_term evd c ty = Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) evars (Evd.from_ctx (Evd.evar_universe_context evd)) -let do_program_recursive ~scope ~poly fixkind fixl ntns = +let do_program_recursive ~scope ~poly fixkind fixl = let cofix = fixkind = DeclareObl.IsCoFixpoint in let (env, rec_sign, pl, evd), fix, info = - interp_recursive ~cofix ~program_mode:true fixl ntns + interp_recursive ~cofix ~program_mode:true fixl in (* Program-specific code *) (* Get the interesting evars, those that were not instantiated *) @@ -289,16 +289,19 @@ let do_program_recursive ~scope ~poly fixkind fixl ntns = | DeclareObl.IsFixpoint _ -> Decls.Fixpoint | DeclareObl.IsCoFixpoint -> Decls.CoFixpoint in + let ntns = List.map_append (fun { Vernacexpr.notations } -> notations ) fixl in Obligations.add_mutual_definitions defs ~poly ~scope ~kind ~univdecl:pl ctx ntns fixkind let do_program_fixpoint ~scope ~poly l = - let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in + let g = List.map (fun { Vernacexpr.rec_order } -> rec_order) l in match g, l with - | [Some { CAst.v = CWfRec (n,r) }], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> + | [Some { CAst.v = CWfRec (n,r) }], + [ Vernacexpr.{fname={CAst.v=id}; univs; binders; rtype; body_def; notations} ] -> let recarg = mkIdentC n.CAst.v in - build_wellfounded (id, pl, bl, typ, out_def def) poly r recarg ntn + build_wellfounded (id, univs, binders, rtype, out_def body_def) poly r recarg notations - | [Some { CAst.v = CMeasureRec (n, m, r) }], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> + | [Some { CAst.v = CMeasureRec (n, m, r) }], + [Vernacexpr.{fname={CAst.v=id}; univs; binders; rtype; body_def; notations }] -> (* We resolve here a clash between the syntax of Program Fixpoint and the one of funind *) let r = match n, r with | Some id, None -> @@ -308,25 +311,20 @@ let do_program_fixpoint ~scope ~poly l = user_err Pp.(str"Measure takes only two arguments in Program Fixpoint.") | _, _ -> r in - build_wellfounded (id, pl, bl, typ, out_def def) poly - (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m ntn + build_wellfounded (id, univs, binders, rtype, out_def body_def) poly + (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m notations | _, _ when List.for_all (fun ro -> match ro with None | Some { CAst.v = CStructRec _} -> true | _ -> false) g -> - let fixl,ntns = extract_fixpoint_components ~structonly:true l in - let fixkind = DeclareObl.IsFixpoint (List.map (fun d -> d.fix_annot) fixl) in - do_program_recursive ~scope ~poly fixkind fixl ntns + let annots = List.map (fun fix -> + Vernacexpr.(ComFixpoint.adjust_rec_order ~structonly:true fix.binders fix.rec_order)) l in + let fixkind = DeclareObl.IsFixpoint annots in + let l = List.map2 (fun fix rec_order -> { fix with Vernacexpr.rec_order }) l annots in + do_program_recursive ~scope ~poly fixkind l | _, _ -> user_err ~hdr:"do_program_fixpoint" (str "Well-founded fixpoints not allowed in mutually recursive blocks") -let extract_cofixpoint_components l = - let fixl, ntnl = List.split l in - List.map (fun (({CAst.v=id},pl),bl,typ,def) -> - {fix_name = id; fix_annot = None; fix_univs = pl; - fix_binders = bl; fix_body = def; fix_type = typ}) fixl, - List.flatten ntnl - let check_safe () = let open Declarations in let flags = Environ.typing_flags (Global.env ()) in @@ -336,7 +334,7 @@ let do_fixpoint ~scope ~poly l = do_program_fixpoint ~scope ~poly l; if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () -let do_cofixpoint ~scope ~poly l = - let fixl,ntns = extract_cofixpoint_components l in - do_program_recursive ~scope ~poly DeclareObl.IsCoFixpoint fixl ntns; +let do_cofixpoint ~scope ~poly fixl = + let fixl = List.map (fun fix -> { fix with Vernacexpr.rec_order = None }) fixl in + do_program_recursive ~scope ~poly DeclareObl.IsCoFixpoint fixl; if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/comProgramFixpoint.mli b/vernac/comProgramFixpoint.mli index f25abb95c3..a851e4dff5 100644 --- a/vernac/comProgramFixpoint.mli +++ b/vernac/comProgramFixpoint.mli @@ -1,11 +1,21 @@ +(************************************************************************) +(* * 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 Vernacexpr (** Special Fixpoint handling when command is activated. *) val do_fixpoint : (* When [false], assume guarded. *) - scope:DeclareDef.locality -> poly:bool -> (fixpoint_expr * decl_notation list) list -> unit + scope:DeclareDef.locality -> poly:bool -> fixpoint_expr list -> unit val do_cofixpoint : (* When [false], assume guarded. *) - scope:DeclareDef.locality -> poly:bool -> (cofixpoint_expr * decl_notation list) list -> unit + scope:DeclareDef.locality -> poly:bool -> cofixpoint_expr list -> unit diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index 0c45ff11d7..c5cbb095ca 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -29,9 +29,6 @@ type obligation = type obligations = obligation array * int -type notations = - (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list - type fixpoint_kind = | IsFixpoint of lident option list | IsCoFixpoint @@ -46,7 +43,7 @@ type program_info = ; prg_deps : Id.t list ; prg_fixkind : fixpoint_kind option ; prg_implicits : Impargs.manual_implicits - ; prg_notations : notations + ; prg_notations : Vernacexpr.decl_notation list ; prg_poly : bool ; prg_scope : DeclareDef.locality ; prg_kind : Decls.definition_object_kind diff --git a/vernac/declareObl.mli b/vernac/declareObl.mli index a8dd5040cb..2a8fa734b3 100644 --- a/vernac/declareObl.mli +++ b/vernac/declareObl.mli @@ -24,9 +24,6 @@ type obligation = type obligations = obligation array * int -type notations = - (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list - type fixpoint_kind = | IsFixpoint of lident option list | IsCoFixpoint @@ -41,7 +38,7 @@ type program_info = ; prg_deps : Id.t list ; prg_fixkind : fixpoint_kind option ; prg_implicits : Impargs.manual_implicits - ; prg_notations : notations + ; prg_notations : Vernacexpr.decl_notation list ; prg_poly : bool ; prg_scope : DeclareDef.locality ; prg_kind : Decls.definition_object_kind diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 2b475f1ef9..ad5d98669d 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -402,16 +402,19 @@ GRAMMAR EXTEND Gram ; (* (co)-fixpoints *) rec_definition: - [ [ id = ident_decl; + [ [ id_decl = ident_decl; bl = binders_fixannot; - ty = type_cstr; - def = OPT [":="; def = lconstr -> { def } ]; ntn = decl_notation -> - { let bl, annot = bl in ((id,annot,bl,ty,def),ntn) } ] ] + rtype = type_cstr; + body_def = OPT [":="; def = lconstr -> { def } ]; notations = decl_notation -> + { let binders, rec_order = bl in + {fname = fst id_decl; univs = snd id_decl; rec_order; binders; rtype; body_def; notations} + } ] ] ; corec_definition: - [ [ id = ident_decl; bl = binders; ty = type_cstr; - def = OPT [":="; def = lconstr -> { def }]; ntn = decl_notation -> - { ((id,bl,ty,def),ntn) } ] ] + [ [ id_decl = ident_decl; binders = binders; rtype = type_cstr; + body_def = OPT [":="; def = lconstr -> { def }]; notations = decl_notation -> + { {fname = fst id_decl; univs = snd id_decl; rec_order = (); binders; rtype; body_def; notations} + } ]] ; type_cstr: [ [ ":"; c=lconstr -> { c } @@ -1138,7 +1141,6 @@ GRAMMAR EXTEND Gram | IDENT "Reset"; id = identref -> { VernacResetName id } | IDENT "Back" -> { VernacBack 1 } | IDENT "Back"; n = natural -> { VernacBack n } - | IDENT "BackTo"; n = natural -> { VernacBackTo n } (* Tactic Debugger *) | IDENT "Debug"; IDENT "On" -> diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index ecea9ae4c9..6a754a0cde 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -113,46 +113,6 @@ let by tac pf = (* Creating a lemma-like constant *) (************************************************************************) -(* Support for mutually proved theorems *) - -let retrieve_first_recthm uctx = function - | GlobRef.VarRef id -> - NamedDecl.get_value (Global.lookup_named id), - Decls.variable_opacity id - | GlobRef.ConstRef cst -> - let cb = Global.lookup_constant cst in - (* we get the right order somehow but surely it could be enforced in a better way *) - let uctx = UState.context uctx in - let inst = Univ.UContext.instance uctx in - let map (c, _, _) = Vars.subst_instance_constr inst c in - (Option.map map (Global.body_of_constant_body Library.indirect_accessor cb), is_opaque cb) - | _ -> assert false - -let adjust_guardness_conditions const = function - | [] -> const (* Not a recursive statement *) - | possible_indexes -> - (* Try all combinations... not optimal *) - let env = Global.env() in - let open Proof_global in - { const with proof_entry_body = - Future.chain const.proof_entry_body - (fun ((body, ctx), eff) -> - match Constr.kind body with - | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> -(* let possible_indexes = - List.map2 (fun i c -> match i with Some i -> i | None -> - List.interval 0 (List.length ((lam_assum c)))) - lemma_guard (Array.to_list fixdefs) in -*) - let env = Safe_typing.push_private_constants env eff.Evd.seff_private in - let indexes = - search_guard env - possible_indexes fixdecls in - (mkFix ((indexes,0),fixdecls), ctx), eff - | _ -> (body, ctx), eff) } - -let default_thm_id = Id.of_string "Unnamed_thm" - let check_name_freshness locality {CAst.loc;v=id} : unit = (* We check existence here: it's a bit late at Qed time *) if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || @@ -160,52 +120,6 @@ let check_name_freshness locality {CAst.loc;v=id} : unit = then user_err ?loc (Id.print id ++ str " already exists.") -let save_remaining_recthms env sigma ~poly ~scope norm univs body opaq i { Recthm.name; typ; impargs } = - let t_i = norm typ in - let kind = Decls.(IsAssumption Conjectural) in - match body with - | None -> - let open DeclareDef in - (match scope with - | Discharge -> - let impl = false in (* copy values from Vernacentries *) - let univs = match univs with - | Polymorphic_entry (_, univs) -> - (* What is going on here? *) - Univ.ContextSet.of_context univs - | Monomorphic_entry univs -> univs - in - let c = Declare.SectionLocalAssum {typ=t_i; univs; poly; impl} in - let () = Declare.declare_variable ~name ~kind c in - (GlobRef.VarRef name,impargs) - | Global local -> - let kind = Decls.(IsAssumption Conjectural) in - let decl = Declare.ParameterEntry (None,(t_i,univs),None) in - let kn = Declare.declare_constant ~name ~local ~kind decl in - (GlobRef.ConstRef kn,impargs)) - | Some body -> - let body = norm body in - let rec body_i t = match Constr.kind t with - | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) - | CoFix (0,decls) -> mkCoFix (i,decls) - | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2) - | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) - | App (t, args) -> mkApp (body_i t, args) - | _ -> - anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr_env env sigma body ++ str ".") in - let body_i = body_i body in - let open DeclareDef in - match scope with - | Discharge -> - let const = Declare.definition_entry ~types:t_i ~opaque:opaq ~univs body_i in - let c = Declare.SectionLocalDef const in - let () = Declare.declare_variable ~name ~kind c in - (GlobRef.VarRef name,impargs) - | Global local -> - let const = Declare.definition_entry ~types:t_i ~univs ~opaque:opaq body_i in - let kn = Declare.declare_constant ~name ~local ~kind (Declare.DefinitionEntry const) in - (GlobRef.ConstRef kn,impargs) - let initialize_named_context_for_proof () = let sign = Global.named_context () in List.fold_right @@ -315,9 +229,73 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?inference_hook ?hook thms start_lemma_with_initialization ?hook ~poly ~scope ~kind evd ~udecl recguard thms snl (************************************************************************) -(* Commom constant saving path *) +(* Commom constant saving path, for both Qed and Admitted *) (************************************************************************) +(* Helper for process_recthms *) +let retrieve_first_recthm uctx = function + | GlobRef.VarRef id -> + NamedDecl.get_value (Global.lookup_named id), + Decls.variable_opacity id + | GlobRef.ConstRef cst -> + let cb = Global.lookup_constant cst in + (* we get the right order somehow but surely it could be enforced in a better way *) + let uctx = UState.context uctx in + let inst = Univ.UContext.instance uctx in + let map (c, _, _) = Vars.subst_instance_constr inst c in + (Option.map map (Global.body_of_constant_body Library.indirect_accessor cb), is_opaque cb) + | _ -> assert false + +(* Helper for process_recthms *) +let save_remaining_recthms env sigma ~poly ~scope ~udecl uctx body opaq i { Recthm.name; typ; impargs } = + let norm c = EConstr.to_constr (Evd.from_ctx uctx) c in + let body = Option.map EConstr.of_constr body in + let univs = UState.check_univ_decl ~poly uctx udecl in + let t_i = norm typ in + let kind = Decls.(IsAssumption Conjectural) in + match body with + | None -> + let open DeclareDef in + (match scope with + | Discharge -> + let impl = false in (* copy values from Vernacentries *) + let univs = match univs with + | Polymorphic_entry (_, univs) -> + (* What is going on here? *) + Univ.ContextSet.of_context univs + | Monomorphic_entry univs -> univs + in + let c = Declare.SectionLocalAssum {typ=t_i; univs; poly; impl} in + let () = Declare.declare_variable ~name ~kind c in + GlobRef.VarRef name, impargs + | Global local -> + let kind = Decls.(IsAssumption Conjectural) in + let decl = Declare.ParameterEntry (None,(t_i,univs),None) in + let kn = Declare.declare_constant ~name ~local ~kind decl in + GlobRef.ConstRef kn, impargs) + | Some body -> + let body = norm body in + let rec body_i t = match Constr.kind t with + | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) + | CoFix (0,decls) -> mkCoFix (i,decls) + | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2) + | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) + | App (t, args) -> mkApp (body_i t, args) + | _ -> + anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr_env env sigma body ++ str ".") in + let body_i = body_i body in + let open DeclareDef in + match scope with + | Discharge -> + let const = Declare.definition_entry ~types:t_i ~opaque:opaq ~univs body_i in + let c = Declare.SectionLocalDef const in + let () = Declare.declare_variable ~name ~kind c in + GlobRef.VarRef name, impargs + | Global local -> + let const = Declare.definition_entry ~types:t_i ~univs ~opaque:opaq body_i in + let kn = Declare.declare_constant ~name ~local ~kind (Declare.DefinitionEntry const) in + GlobRef.ConstRef kn, impargs + (* This declares implicits and calls the hooks for all the theorems, including the main one *) let process_recthms ?fix_exn ?hook env sigma uctx ~udecl ~poly ~scope dref imps other_thms = @@ -325,10 +303,7 @@ let process_recthms ?fix_exn ?hook env sigma uctx ~udecl ~poly ~scope dref imps if List.is_empty other_thms then [] else (* there are several theorems defined mutually *) let body,opaq = retrieve_first_recthm uctx dref in - let norm c = EConstr.to_constr (Evd.from_ctx uctx) c in - let body = Option.map EConstr.of_constr body in - let uctx = UState.check_univ_decl ~poly uctx udecl in - List.map_i (save_remaining_recthms env sigma ~poly ~scope norm uctx body opaq) 1 other_thms in + List.map_i (save_remaining_recthms env sigma ~poly ~scope ~udecl uctx body opaq) 1 other_thms in let thms_data = (dref,imps)::other_thms_data in List.iter (fun (dref,imps) -> maybe_declare_manual_implicits false dref imps; @@ -395,10 +370,33 @@ let save_lemma_admitted ~(lemma : t) : unit = (* Saving a lemma-like constant *) (************************************************************************) +let default_thm_id = Id.of_string "Unnamed_thm" + let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then user_err Pp.(str "This command can only be used for unnamed theorem.") +(* Support for mutually proved theorems *) + +(* Helper for finish_proved *) +let adjust_guardness_conditions const = function + | [] -> const (* Not a recursive statement *) + | possible_indexes -> + (* Try all combinations... not optimal *) + let env = Global.env() in + let open Proof_global in + { const with + proof_entry_body = + Future.chain const.proof_entry_body + (fun ((body, ctx), eff) -> + match Constr.kind body with + | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> + let env = Safe_typing.push_private_constants env eff.Evd.seff_private in + let indexes = search_guard env possible_indexes fixdecls in + (mkFix ((indexes,0),fixdecls), ctx), eff + | _ -> (body, ctx), eff) + } + let finish_proved env sigma idopt po info = let open Proof_global in let { Info.hook; compute_guard; impargs; other_thms; scope; kind } = info in diff --git a/vernac/obligations.mli b/vernac/obligations.mli index f97bc784c3..2a0d0aba97 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -18,27 +18,33 @@ val check_evars : env -> evar_map -> unit val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar_info * Evar.Set.t) list -(* env, id, evars, number of function prototypes to try to clear from - evars contexts, object and type *) -val eterm_obligations : env -> Id.t -> evar_map -> int -> - ?status:Evar_kinds.obligation_definition_status -> EConstr.constr -> EConstr.types -> - (Id.t * types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * - unit Proofview.tactic option) array - (* Existential key, obl. name, type as product, - location of the original evar, associated tactic, - status and dependencies as indexes into the array *) - * ((Evar.t * Id.t) list * ((Id.t -> EConstr.constr) -> EConstr.constr -> constr)) * - constr * types - (* Translations from existential identifiers to obligation identifiers - and for terms with existentials to closed terms, given a - translation from obligation identifiers to constrs, new term, new type *) - +(* ident, type, location, (opaque or transparent, expand or define), dependencies, tactic to solve it *) type obligation_info = (Id.t * types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array - (* ident, type, location, (opaque or transparent, expand or define), - dependencies, tactic to solve it *) + (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array + +(* env, id, evars, number of function prototypes to try to clear from + evars contexts, object and type *) +val eterm_obligations + : env + -> Id.t + -> evar_map + -> int + -> ?status:Evar_kinds.obligation_definition_status + -> EConstr.constr + -> EConstr.types + -> obligation_info * + + (* Existential key, obl. name, type as product, location of the + original evar, associated tactic, status and dependencies as + indexes into the array *) + ((Evar.t * Id.t) list * ((Id.t -> EConstr.constr) -> EConstr.constr -> constr)) * + + (* Translations from existential identifiers to obligation + identifiers and for terms with existentials to closed terms, + given a translation from obligation identifiers to constrs, + new term, new type *) + constr * types val default_tactic : unit Proofview.tactic ref @@ -69,7 +75,7 @@ val add_mutual_definitions -> ?kind:Decls.definition_object_kind -> ?reduce:(constr -> constr) -> ?hook:DeclareDef.Hook.t -> ?opaque:bool - -> DeclareObl.notations + -> Vernacexpr.decl_notation list -> DeclareObl.fixpoint_kind -> unit val obligation diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index e676fe94db..0eb0b1b6f6 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -419,15 +419,15 @@ let string_of_theorem_kind = let open Decls in function | l -> spc() ++ hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") - let pr_rec_definition ((iddecl,ro,bl,type_,def),ntn) = + let pr_rec_definition { fname; univs; rec_order; binders; rtype; body_def; notations } = let env = Global.env () in let sigma = Evd.from_env env in let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in - let annot = pr_guard_annot (pr_lconstr_expr env sigma) bl ro in - pr_ident_decl iddecl ++ pr_binders_arg bl ++ annot - ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr env sigma c) type_ - ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr env sigma def) def - ++ prlist (pr_decl_notation @@ pr_constr env sigma) ntn + let annot = pr_guard_annot (pr_lconstr_expr env sigma) binders rec_order in + pr_ident_decl (fname,univs) ++ pr_binders_arg binders ++ annot + ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr env sigma c) rtype + ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr env sigma def) body_def + ++ prlist (pr_decl_notation @@ pr_constr env sigma) notations let pr_statement head (idpl,(bl,c)) = let env = Global.env () in @@ -669,8 +669,6 @@ let string_of_definition_object_kind = let open Decls in function return ( if Int.equal i 1 then keyword "Back" else keyword "Back" ++ pr_intarg i ) - | VernacBackTo i -> - return (keyword "BackTo" ++ pr_intarg i) (* State management *) | VernacWriteState s -> @@ -858,11 +856,11 @@ let string_of_definition_object_kind = let open Decls in function | DoDischarge -> keyword "Let" ++ spc () | NoDischarge -> str "" in - let pr_onecorec ((iddecl,bl,c,def),ntn) = - pr_ident_decl iddecl ++ spc() ++ pr_binders env sigma bl ++ spc() ++ str":" ++ - spc() ++ pr_lconstr_expr env sigma c ++ - pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr env sigma def) def ++ - prlist (pr_decl_notation @@ pr_constr env sigma) ntn + let pr_onecorec {fname; univs; binders; rtype; body_def; notations } = + pr_ident_decl (fname,univs) ++ spc() ++ pr_binders env sigma binders ++ spc() ++ str":" ++ + spc() ++ pr_lconstr_expr env sigma rtype ++ + pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr env sigma def) body_def ++ + prlist (pr_decl_notation @@ pr_constr env sigma) notations in return ( hov 0 (local ++ keyword "CoFixpoint" ++ spc() ++ diff --git a/vernac/ppvernac.mli b/vernac/ppvernac.mli index d4d49a09a3..9ade5afb87 100644 --- a/vernac/ppvernac.mli +++ b/vernac/ppvernac.mli @@ -14,7 +14,7 @@ val pr_set_entry_type : ('a -> Pp.t) -> 'a Extend.constr_entry_key_gen -> Pp.t (** Prints a fixpoint body *) -val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.t +val pr_rec_definition : Vernacexpr.fixpoint_expr -> Pp.t (** Prints a vernac expression without dot *) val pr_vernac_expr : Vernacexpr.vernac_expr -> Pp.t diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index c9eb979a90..3bd252ecef 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -23,7 +23,7 @@ module Vernac_ : val command : vernac_expr Entry.t val syntax : vernac_expr Entry.t val vernac_control : vernac_control Entry.t - val rec_definition : (fixpoint_expr * decl_notation list) Entry.t + val rec_definition : fixpoint_expr Entry.t val noedit_mode : vernac_expr Entry.t val command_entry : vernac_expr Entry.t val main_entry : vernac_control option Entry.t diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 46ddf214ab..9af8d8b67c 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -772,7 +772,7 @@ let vernac_inductive ~atts cum lo finite indl = let vernac_fixpoint_common ~atts discharge l = if Dumpglob.dump () then - List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; + List.iter (fun { fname } -> Dumpglob.dump_definition fname false "def") l; enforce_locality_exp atts.DefAttributes.locality discharge let vernac_fixpoint_interactive ~atts discharge l = @@ -793,7 +793,7 @@ let vernac_fixpoint ~atts discharge l = let vernac_cofixpoint_common ~atts discharge l = if Dumpglob.dump () then - List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; + List.iter (fun { fname } -> Dumpglob.dump_definition fname false "def") l; enforce_locality_exp atts.DefAttributes.locality discharge let vernac_cofixpoint_interactive ~atts discharge l = @@ -2298,7 +2298,6 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with | VernacResetName _ | VernacResetInitial | VernacBack _ - | VernacBackTo _ | VernacAbort _ -> anomaly (str "type_vernac") (* Syntax *) @@ -2358,7 +2357,7 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with | VernacInductive (cum, priv, finite, l) -> VtDefault(fun () -> vernac_inductive ~atts cum priv finite l) | VernacFixpoint (discharge, l) -> - let opens = List.exists (fun ((_,_,_,_,p),_) -> Option.is_empty p) l in + let opens = List.exists (fun { body_def } -> Option.is_empty body_def) l in if opens then VtOpenProof (fun () -> with_def_attributes ~atts vernac_fixpoint_interactive discharge l) @@ -2366,7 +2365,7 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with VtDefault (fun () -> with_def_attributes ~atts vernac_fixpoint discharge l) | VernacCoFixpoint (discharge, l) -> - let opens = List.exists (fun ((_,_,_,p),_) -> Option.is_empty p) l in + let opens = List.exists (fun { body_def } -> Option.is_empty body_def) l in if opens then VtOpenProof(fun () -> with_def_attributes ~atts vernac_cofixpoint_interactive discharge l) else @@ -2630,7 +2629,6 @@ and interp_expr ?proof ~atts ~st c = | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm.") | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm.") | VernacBack _ -> anomaly (str "VernacBack not handled by Stm.") - | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm.") (* This one is possible to handle here *) | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index ee1f839b8d..0968632c2d 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -128,18 +128,26 @@ type definition_expr = | DefineBody of local_binder_expr list * Genredexpr.raw_red_expr option * constr_expr * constr_expr option -type fixpoint_expr = - ident_decl * recursion_order_expr option * local_binder_expr list * constr_expr * constr_expr option +type decl_notation = lstring * constr_expr * scope_name option + +type 'a fix_expr_gen = + { fname : lident + ; univs : universe_decl_expr option + ; rec_order : 'a + ; binders : local_binder_expr list + ; rtype : constr_expr + ; body_def : constr_expr option + ; notations : decl_notation list + } -type cofixpoint_expr = - ident_decl * local_binder_expr list * constr_expr * constr_expr option +type fixpoint_expr = recursion_order_expr option fix_expr_gen +type cofixpoint_expr = unit fix_expr_gen type local_decl_expr = | AssumExpr of lname * constr_expr | DefExpr of lname * constr_expr * constr_expr option type inductive_kind = Inductive_kw | CoInductive | Variant | Record | Structure | Class of bool (* true = definitional, false = inductive *) -type decl_notation = lstring * constr_expr * scope_name option type simple_binder = lident list * constr_expr type class_binder = lident * constr_expr list type 'a with_coercion = coercion_flag * 'a @@ -283,8 +291,8 @@ type nonrec vernac_expr = | VernacAssumption of (discharge * Decls.assumption_object_kind) * Declaremods.inline * (ident_decl list * constr_expr) with_coercion list | VernacInductive of vernac_cumulative option * bool (* private *) * inductive_flag * (inductive_expr * decl_notation list) list - | VernacFixpoint of discharge * (fixpoint_expr * decl_notation list) list - | VernacCoFixpoint of discharge * (cofixpoint_expr * decl_notation list) list + | VernacFixpoint of discharge * fixpoint_expr list + | VernacCoFixpoint of discharge * cofixpoint_expr list | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list @@ -351,7 +359,6 @@ type nonrec vernac_expr = | VernacResetName of lident | VernacResetInitial | VernacBack of int - | VernacBackTo of int (* Commands *) | VernacCreateHintDb of string * bool diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml index 1dd8164ebc..747998c6cc 100644 --- a/vernac/vernacprop.ml +++ b/vernac/vernacprop.ml @@ -32,7 +32,6 @@ let rec has_Fail v = v |> CAst.with_val (function let is_navigation_vernac_expr = function | VernacResetInitial | VernacResetName _ - | VernacBackTo _ | VernacBack _ -> true | _ -> false |