diff options
| -rw-r--r-- | doc/changelog/10-standard-library/10445-constructive-reals.rst | 12 | ||||
| -rw-r--r-- | doc/sphinx/language/gallina-extensions.rst | 5 | ||||
| -rw-r--r-- | doc/sphinx/proof-engine/ltac2.rst | 118 | ||||
| -rw-r--r-- | doc/stdlib/index-list.html.template | 3 | ||||
| -rw-r--r-- | plugins/syntax/r_syntax.ml | 3 | ||||
| -rw-r--r-- | theories/QArith/QArith_base.v | 10 | ||||
| -rw-r--r-- | theories/Reals/ConstructiveCauchyReals.v | 2535 | ||||
| -rw-r--r-- | theories/Reals/ConstructiveRIneq.v | 2235 | ||||
| -rw-r--r-- | theories/Reals/ConstructiveRcomplete.v | 343 | ||||
| -rw-r--r-- | theories/Reals/RIneq.v | 243 | ||||
| -rw-r--r-- | theories/Reals/Raxioms.v | 267 | ||||
| -rw-r--r-- | theories/Reals/Rdefinitions.v | 156 | ||||
| -rw-r--r-- | tools/coqdoc/cpretty.mll | 2 |
13 files changed, 5670 insertions, 262 deletions
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/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index acf68e9fd2..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: diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index ceaa2775bf..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` @@ -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 @@ -672,7 +672,7 @@ at parsing time. Scopes are described using a form of S-expression. .. prodn:: 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 = @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,7 +758,7 @@ 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 } } {? : @int} := @ltac2_term :name: Ltac2 Notation @@ -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/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 8b5ede7036..dcfe4a08f3 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -514,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 @@ -559,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/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/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/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 } |