Merge PR #10445: Split constructive and classical axioms for real numbers

Ack-by: Zimmi48
Ack-by: silene

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.