diff options
| -rw-r--r-- | doc/changelog/10-standard-library/10445-constructive-reals.rst | 12 | ||||
| -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 |
10 files changed, 5609 insertions, 198 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/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. |