Merge PR #12186: CReal: changed epsilon for modulus of convergence from 1/n to 1/2^n

Reviewed-by: VincentSe

15 files changed, 3114 insertions, 2008 deletions

diff --git a/doc/changelog/10-standard-library/12186-creal-new-modulus.rst b/doc/changelog/10-standard-library/12186-creal-new-modulus.rst
new file mode 100644
index 0000000000..778bf78d59
--- /dev/null
+++ b/doc/changelog/10-standard-library/12186-creal-new-modulus.rst
@@ -0,0 +1,5 @@
+- **Changed:**
+  In the reals theory changed the epsilon in the definition of the modulus of convergence for CReal from 1/n (n in positive) to 2^z (z in Z)
+  so that a precision coarser than one is possible. Also added an upper bound to CReal to enable more efficient computations.
+  (`#12186 <https://github.com/coq/coq/pull/12186>`_,
+  by Michael Soegtrop).
diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files
index 0a9dba99a9..4badb20295 100644
--- a/doc/stdlib/hidden-files
+++ b/doc/stdlib/hidden-files
@@ -92,3 +92,6 @@ theories/setoid_ring/ZArithRing.v
 theories/ssr/ssrunder.v
 theories/ssr/ssrsetoid.v
 theories/ssrsearch/ssrsearch.vo
+theories/Reals/Cauchy/ConstructiveExtra.v
+theories/Reals/Cauchy/PosExtra.v
+theories/Reals/Cauchy/QExtra.v
diff --git a/test-suite/complexity/ConstructiveCauchyRealsPerformance.v b/test-suite/complexity/ConstructiveCauchyRealsPerformance.v
index f3bc1767da..94ee23f38e 100644
--- a/test-suite/complexity/ConstructiveCauchyRealsPerformance.v
+++ b/test-suite/complexity/ConstructiveCauchyRealsPerformance.v
@@ -4,92 +4,143 @@
 
 Require Import QArith Qabs.
 Require Import ConstructiveCauchyRealsMult.
+Require Import Lqa.
+Require Import Lia.
 
 Local Open Scope CReal_scope.
 
-Definition approx_sqrt_Q (q : Q) (n : positive) : Q
+(* We would need a shift instruction on positives to do this properly *)
+
+Definition CReal_sqrt_Q_seq (q : Q) (n : Z) : Q
   := let (k,j) := q in
      match k with
      | Z0 => 0
-     | Z.pos i => Z.pos (Pos.sqrt (i*j*n*n)) # (j*n)
+     | Z.pos i => match n with
+         | Z0
+         | Z.pos _ => Z.pos (Pos.sqrt (i*j)) # (j)
+         | Z.neg n' => Z.pos (Pos.sqrt (i*j*2^(2*n'))) # (j*2^n')
+         end
      | Z.neg i => 0 (* unused *)
      end.
 
-(* Approximation of the square root from below,
-   improves the convergence modulus. *)
-Lemma approx_sqrt_Q_le_below : forall (q : Q) (n : positive),
-    Qle 0 q -> Qle (approx_sqrt_Q q n * approx_sqrt_Q q n) q.
+Local Lemma Pos_pow_twice_r a b : (a^(2*b) = a^b * a^b)%positive.
 Proof.
-  intros. destruct q as [k j]. unfold approx_sqrt_Q.
-  destruct k as [|i|i]. apply Z.le_refl.
-  pose proof (Pos.sqrt_spec (i * j * n * n)). simpl in H0.
-  destruct H0 as [H0 _].
-  unfold Qle, Qmult, Qnum, Qden.
-  rewrite <- Pos2Z.inj_mul, <- Pos2Z.inj_mul, <- Pos2Z.inj_mul.
-  apply Pos2Z.pos_le_pos. rewrite (Pos.mul_comm i (j * n * (j * n))).
-  rewrite <- (Pos.mul_comm j), <- (Pos.mul_assoc j), <- (Pos.mul_assoc j).
-  apply Pos.mul_le_mono_l.
-  apply (Pos.le_trans _ _ _ H0).
-  rewrite <- (Pos.mul_comm n), <- (Pos.mul_assoc n).
-  apply Pos.mul_le_mono_l.
-  rewrite (Pos.mul_comm i j), <- Pos.mul_assoc, <- Pos.mul_assoc.
-  apply Pos.mul_le_mono_l. rewrite Pos.mul_comm. apply Pos.le_refl.
-  exfalso. unfold Qle, Z.le in H; simpl in H. exact (H eq_refl).
+  apply Pos2Z.inj.
+  rewrite Pos2Z.inj_mul.
+  do 2 rewrite Pos2Z.inj_pow.
+  rewrite Pos2Z.inj_mul.
+  apply Z.pow_twice_r.
 Qed.
 
-Require Import Lia.
-
-Lemma approx_sqrt_Q_le_below_lia : forall (q : Q) (n : positive),
-    (0 <= q)%Q -> (approx_sqrt_Q q n * approx_sqrt_Q q n <= q)%Q.
+(* Approximation of the square root from below,
+   improves the convergence modulus. *)
+Lemma CReal_sqrt_Q_le_below : forall (q : Q) (n : Z),
+    (0<=q)%Q -> (CReal_sqrt_Q_seq q n * CReal_sqrt_Q_seq q n <= q)%Q.
 Proof.
-  intros. destruct q as [k j]. unfold approx_sqrt_Q.
+  intros q n Hqpos. destruct q as [k j]. unfold CReal_sqrt_Q_seq.
   destruct k as [|i|i].
   - apply Z.le_refl.
-  - unfold Qle, Qmult, Qnum, Qden.
-    pose proof (Pos.sqrt_spec (i * j * n * n)) as Hsqrt; simpl in Hsqrt.
-    destruct Hsqrt as [Hsqrt _]; apply (Pos.mul_le_mono_l j) in Hsqrt.
-    lia.
-  - unfold Qle, Qnum, Qden in H; lia.
+  - destruct n as [|n|n].
+    + pose proof (Pos.sqrt_spec (i * j)) as H. simpl in H.
+      destruct H as [H _].
+      unfold Qle, Qmult, Qnum, Qden.
+      rewrite <- Pos2Z.inj_mul, <- Pos2Z.inj_mul, <- Pos2Z.inj_mul.
+      apply Pos2Z.pos_le_pos. rewrite (Pos.mul_assoc i j j).
+      apply Pos.mul_le_mono_r; exact H.
+    + pose proof (Pos.sqrt_spec (i * j)) as H. simpl in H.
+      destruct H as [H _].
+      unfold Qle, Qmult, Qnum, Qden.
+      rewrite <- Pos2Z.inj_mul, <- Pos2Z.inj_mul, <- Pos2Z.inj_mul.
+      apply Pos2Z.pos_le_pos. rewrite (Pos.mul_assoc i j j).
+      apply Pos.mul_le_mono_r; exact H.
+    + pose proof (Pos.sqrt_spec (i * j * 2^(2*n))) as H. simpl in H.
+      destruct H as [H _].
+      unfold Qle, Qmult, Qnum, Qden.
+      rewrite <- Pos2Z.inj_mul, <- Pos2Z.inj_mul, <- Pos2Z.inj_mul.
+      apply Pos2Z.pos_le_pos. rewrite (Pos.mul_comm j (2^n)) at 2.
+      do 3 rewrite Pos.mul_assoc.
+      apply Pos.mul_le_mono_r.
+      simpl.
+      rewrite Pos_pow_twice_r in H at 3.
+      rewrite Pos.mul_assoc in H.
+      exact H.
+  - exact Hqpos.
 Qed.
 
-Print Assumptions approx_sqrt_Q_le_below_lia.
-
-Lemma approx_sqrt_Q_lt_above : forall (q : Q) (n : positive),
-    Qle 0 q -> Qlt q ((approx_sqrt_Q q n + (1#n)) * (approx_sqrt_Q q n + (1#n))).
+Lemma CReal_sqrt_Q_lt_above : forall (q : Q) (n : Z),
+    (0 <= q)%Q -> (q < ((CReal_sqrt_Q_seq q n + 2^n) * (CReal_sqrt_Q_seq q n + 2^n)))%Q.
 Proof.
-  intros. destruct q as [k j]. unfold approx_sqrt_Q.
-  destruct k as [|i|i]. reflexivity.
-  2: exfalso; unfold Qle, Z.le in H; simpl in H; exact (H eq_refl).
-  pose proof (Pos.sqrt_spec (i * j * n * n)). simpl in H0.
-  destruct H0 as [_ H0].
-  apply (Qlt_le_trans
-           _ (((Z.pos ((Pos.sqrt (i * j * n * n)) + 1) # j * n))
-              * ((Z.pos ((Pos.sqrt (i * j * n * n)) + 1) # j * n)))).
-  unfold Qlt, Qmult, Qnum, Qden.
-  rewrite <- Pos2Z.inj_mul, <- Pos2Z.inj_mul, <- Pos2Z.inj_mul.
-  apply Pos2Z.pos_lt_pos.
-  rewrite Pos.mul_comm, <- Pos.mul_assoc, <- Pos.mul_assoc, Pos.mul_comm.
-  apply Pos.mul_lt_mono_r. rewrite Pplus_one_succ_r in H0.
-  refine (Pos.le_lt_trans _ _ _ _ H0). rewrite Pos.mul_comm.
-  apply Pos.mul_le_mono_r.
-  rewrite <- Pos.mul_assoc, (Pos.mul_comm i), <- Pos.mul_assoc.
-  apply Pos.mul_le_mono_l. rewrite Pos.mul_comm. apply Pos.le_refl.
-  setoid_replace (1#n)%Q with (Z.pos j#j*n)%Q. 2: reflexivity.
-  rewrite Qinv_plus_distr.
-  unfold Qle, Qmult, Qnum, Qden. apply Z.mul_le_mono_nonneg_r.
-  discriminate. apply Z.mul_le_mono_nonneg.
-  discriminate. 2: discriminate.
-  rewrite Pos2Z.inj_add. apply Z.add_le_mono_l.
-  apply Pos2Z.pos_le_pos. destruct j; discriminate.
-  rewrite Pos2Z.inj_add. apply Z.add_le_mono_l.
-  apply Pos2Z.pos_le_pos. destruct j; discriminate.
+  intros. destruct q as [k j]. unfold CReal_sqrt_Q_seq.
+  destruct k as [|i|i].
+  - ring_simplify.
+    setoid_rewrite <- Qpower.Qpower_mult.
+    setoid_rewrite QExtra.Qzero_eq.
+    pose proof QExtra.Qpower_pos_lt 2 (n*2)%Z ltac:(lra).
+    lra.
+  - destruct n as [|n|n].
+    + pose proof (Pos.sqrt_spec (i * j)). simpl in H0.
+      destruct H0 as [_ H0].
+      change (2^0)%Q with 1%Q.
+      unfold Qlt, Qplus, Qmult, Qnum, Qden.
+      rewrite Pos.mul_1_r, Z.mul_1_r, Z.mul_1_l.
+      repeat rewrite <- Pos2Z.inj_add, <- Pos2Z.inj_mul.
+      apply Pos2Z.pos_lt_pos.
+      rewrite Pos.mul_assoc.
+      apply Pos.mul_lt_mono_r.
+      apply (Pos.lt_le_trans _ _ _ H0).
+      apply Pos.mul_le_mono; lia.
+    + pose proof (Pos.sqrt_spec (i * j)). simpl in H0.
+      destruct H0 as [_ H0].
+      rewrite QExtra.Qpower_decomp'.
+      unfold Qlt, Qplus, Qmult, Qnum, Qden.
+      rewrite PosExtra.Pos_pow_1_r.
+      rewrite Pos.mul_1_r, Z.mul_1_r.
+      rewrite <- Pos2Z.inj_pow; do 2 rewrite <- Pos2Z.inj_mul; rewrite <- Pos2Z.inj_add.
+      apply Pos2Z.pos_lt_pos.
+      rewrite Pos.mul_assoc.
+      apply Pos.mul_lt_mono_r.
+      apply (Pos.lt_le_trans _ _ _ H0).
+      apply Pos.mul_le_mono;
+        pose proof Pos.le_1_l (2 ^ n * j)%positive; lia.
+    + pose proof (Pos.sqrt_spec (i * j * 2 ^ (2 * n))). simpl in H0.
+      destruct H0 as [_ H0].
+      rewrite <- Pos2Z.opp_pos, Qpower.Qpower_opp.
+      rewrite QExtra.Qpower_decomp'.
+      rewrite <- Pos2Z.inj_pow, PosExtra.Pos_pow_1_r, <- QExtra.Qinv_swap_pos.
+      unfold Qlt, Qplus, Qmult, Qnum, Qden.
+      repeat rewrite  Pos2Z.inj_mul.
+      ring_simplify.
+      replace (Z.pos i * Z.pos j ^ 2 * Z.pos (2 ^ n) ^ 4)%Z
+      with ((Z.pos i * Z.pos j * Z.pos (2 ^ n) ^ 2) * (Z.pos j * Z.pos (2 ^ n) ^ 2))%Z by ring.
+      replace (
+        Z.pos j ^ 3 * Z.pos (2 ^ n) ^ 2 +
+        2 * Z.pos j ^ 2 * Z.pos (2 ^ n) ^ 2 * Z.pos (Pos.sqrt (i * j * 2 ^ (2 * n))) +
+        Z.pos j * Z.pos (2 ^ n) ^ 2 * Z.pos (Pos.sqrt (i * j * 2 ^ (2 * n))) ^ 2)%Z
+      with (
+        (Z.pos j + Z.pos (Pos.sqrt (i * j * 2 ^ (2 * n))))^2 *
+        (Z.pos j * Z.pos (2 ^ n) ^ 2))%Z by ring.
+      repeat rewrite Pos2Z.inj_pow.
+      rewrite <- Z.pow_mul_r by lia.
+      repeat rewrite <- Pos2Z.inj_mul.
+      repeat rewrite <- Pos2Z.inj_pow.
+      repeat rewrite <- Pos2Z.inj_mul.
+      repeat rewrite <- Pos2Z.inj_add.
+      apply Pos2Z.pos_lt_pos.
+      rewrite (Pos.mul_comm n 2); change (2*n)%positive with (n~0)%positive.
+      apply Pos.mul_lt_mono_r.
+      apply (Pos.lt_le_trans _ _ _ H0).
+      apply Pos.mul_le_mono;
+        pose proof Pos.le_1_l (2 ^ n * j)%positive; lia.
+ - exfalso; unfold Qle, Z.le in H; simpl in H; exact (H eq_refl).
 Qed.
 
-Lemma approx_sqrt_Q_pos : forall (q : Q) (n : positive),
-    Qle 0 q -> Qle 0 (approx_sqrt_Q q n).
+Lemma CReal_sqrt_Q_pos : forall (q : Q) (n : Z),
+   (0 <= (CReal_sqrt_Q_seq q n))%Q.
 Proof.
-  intros. unfold approx_sqrt_Q. destruct q, Qnum.
-  apply Qle_refl. discriminate. apply Qle_refl.
+  intros. unfold CReal_sqrt_Q_seq. destruct q, Qnum.
+  - apply Qle_refl.
+  - destruct n as [|n|n]; discriminate.
+  - apply Qle_refl.
 Qed.
 
 Lemma Qsqrt_lt : forall q r :Q,
@@ -104,46 +155,95 @@ Proof.
   - exfalso. rewrite q0 in H0. exact (Qlt_irrefl _ H0).
 Qed.
 
-Lemma approx_sqrt_Q_cauchy :
-  forall q:Q, QCauchySeq (approx_sqrt_Q q).
+Lemma CReal_sqrt_Q_cauchy :
+  forall q:Q, QCauchySeq (CReal_sqrt_Q_seq q).
 Proof.
   intro q. destruct q as [k j]. destruct k.
-  - intros n a b H H0. reflexivity.
-  - assert (forall n a b, Pos.le n b ->
-               (approx_sqrt_Q (Z.pos p # j) a - approx_sqrt_Q (Z.pos p # j) b
-                < 1 # n)%Q).
-    { intros. rewrite <- (Qplus_lt_r _ _ (approx_sqrt_Q (Z.pos p # j) b)).
+  - intros n a b H H0.
+    change (Qabs _) with 0%Q.
+    apply QExtra.Qpower_pos_lt; reflexivity.
+  - assert (forall n a b, (b<=n)%Z ->
+               (CReal_sqrt_Q_seq (Z.pos p # j) a - CReal_sqrt_Q_seq (Z.pos p # j) b
+                < 2^n)%Q).
+    { intros.
+      pose proof QExtra.Qpower_pos_lt 2 n eq_refl as Hpow.
+      rewrite <- (Qplus_lt_r _ _ (CReal_sqrt_Q_seq (Z.pos p # j) b)).
       ring_simplify. apply Qsqrt_lt.
-      apply (Qle_trans _ (0+(1#n))). rewrite Qplus_0_l. discriminate.
-      apply Qplus_le_l. apply approx_sqrt_Q_pos. discriminate.
+        { apply (Qle_trans _ (0+2^n)). lra.
+          apply Qplus_le_l. apply CReal_sqrt_Q_pos. }
       apply (Qle_lt_trans _ (Z.pos p # j)).
-      apply approx_sqrt_Q_le_below. discriminate.
-      apply (Qlt_le_trans _ ((approx_sqrt_Q (Z.pos p # j) b + (1 # b)) *
-                             (approx_sqrt_Q (Z.pos p # j) b + (1 # b)))).
-      apply approx_sqrt_Q_lt_above. discriminate.
-      apply (Qle_trans _ ((approx_sqrt_Q (Z.pos p # j) b + (1 # n)) *
-                          (approx_sqrt_Q (Z.pos p # j) b + (1 # b)))).
-      apply Qmult_le_r.
-      apply (Qlt_le_trans _ (0+(1#b))). rewrite Qplus_0_l. reflexivity.
-      apply Qplus_le_l. apply approx_sqrt_Q_pos. discriminate.
-      apply Qplus_le_r. unfold Qle; simpl.
-      apply Pos2Z.pos_le_pos, H.
-      apply Qmult_le_l.
-      apply (Qlt_le_trans _ (0+(1#n))). rewrite Qplus_0_l. reflexivity.
-      apply Qplus_le_l. apply approx_sqrt_Q_pos. discriminate.
-      apply Qplus_le_r. unfold Qle; simpl.
-      apply Pos2Z.pos_le_pos, H. }
+        { apply CReal_sqrt_Q_le_below. discriminate. }
+      apply (Qlt_le_trans _ ((CReal_sqrt_Q_seq (Z.pos p # j) b + (2^b)) *
+                             (CReal_sqrt_Q_seq (Z.pos p # j) b + (2^b)))).
+        { apply CReal_sqrt_Q_lt_above. discriminate. }
+      apply (Qle_trans _ ((CReal_sqrt_Q_seq (Z.pos p # j) b + (2^n)) *
+                          (CReal_sqrt_Q_seq (Z.pos p # j) b + (2^b)))).
+        { apply Qmult_le_r.
+          - apply (Qlt_le_trans _ (0+(2^b))).
+            + rewrite Qplus_0_l. apply QExtra.Qpower_pos_lt. reflexivity.
+            + apply Qplus_le_l. apply CReal_sqrt_Q_pos.
+          - apply Qplus_le_r. apply QExtra.Qpower_le_compat.
+              exact H. discriminate. }
+      apply QExtra.Qmult_le_compat_nonneg.
+      - split.
+        + pose proof CReal_sqrt_Q_pos (Z.pos p # j) b.
+          lra.
+        + apply Qle_refl.
+      - split.
+        + pose proof CReal_sqrt_Q_pos (Z.pos p # j) b.
+          pose proof QExtra.Qpower_pos_lt 2 b eq_refl as Hpowb.
+          lra.
+        + apply Qplus_le_r.
+          apply QExtra.Qpower_le_compat.
+            exact H. discriminate.
+    }
     intros n a b H0 H1. apply Qabs_case.
     intros. apply H, H1.
     intros.
-    setoid_replace (- (approx_sqrt_Q (Z.pos p # j) a - approx_sqrt_Q (Z.pos p # j) b))%Q
-      with (approx_sqrt_Q (Z.pos p # j) b - approx_sqrt_Q (Z.pos p # j) a)%Q.
+    setoid_replace (- (CReal_sqrt_Q_seq (Z.pos p # j) a - CReal_sqrt_Q_seq (Z.pos p # j) b))%Q
+      with (CReal_sqrt_Q_seq (Z.pos p # j) b - CReal_sqrt_Q_seq (Z.pos p # j) a)%Q.
     2: ring. apply H, H0.
-  - intros n a b H H0. reflexivity.
+  - intros n a b H H0.
+    change (Qabs _) with 0%Q.
+    apply QExtra.Qpower_pos_lt; reflexivity.
 Qed.
 
-Definition CReal_sqrt_Q (q : Q) : CReal
-  := exist _ (approx_sqrt_Q q) (approx_sqrt_Q_cauchy q).
+Definition CReal_sqrt_Q_scale (q : Q) : Z
+  := ((QExtra.Qbound_lt_ZExp2 q + 1)/2)%Z.
+
+Lemma CReal_sqrt_Q_bound : forall (q : Q),
+  QBound (CReal_sqrt_Q_seq q) (CReal_sqrt_Q_scale q).
+Proof.
+  intros q k.
+  unfold CReal_sqrt_Q_scale.
+  rewrite Qabs_pos.
+    2: apply CReal_sqrt_Q_pos.
+  apply Qsqrt_lt.
+    1: apply Qpower.Qpower_pos; discriminate.
+  destruct (Qlt_le_dec q 0) as [Hq|Hq].
+  - destruct q as [[|n|n] d].
+    + discriminate Hq.
+    + discriminate Hq.
+    + reflexivity.
+  - apply (Qle_lt_trans _ _ _ (CReal_sqrt_Q_le_below _ _ Hq)).
+    rewrite <- Qpower.Qpower_plus.
+      2: discriminate.
+    rewrite Z.add_diag, Z.mul_comm.
+    pose proof Zdiv.Zmod_eq (QExtra.Qbound_lt_ZExp2 q + 1) 2 eq_refl as Hmod.
+    assert (forall a b c : Z, c=b-a -> a=b-c)%Z as H by (intros a b c H'; rewrite H';  ring).
+    apply H in Hmod; rewrite Hmod; clear H Hmod.
+    apply (Qlt_le_trans _ _ _ (QExtra.Qbound_lt_ZExp2_spec q)).
+    apply QExtra.Qpower_le_compat. 2: discriminate.
+    pose proof Z.mod_pos_bound (QExtra.Qbound_lt_ZExp2 q + 1)%Z 2%Z eq_refl.
+    lia.
+Qed.
 
+Definition CReal_sqrt_Q (q : Q) : CReal :=
+{|
+  seq := CReal_sqrt_Q_seq q;
+  scale := CReal_sqrt_Q_scale q;
+  cauchy := CReal_sqrt_Q_cauchy q;
+  bound := CReal_sqrt_Q_bound q
+|}.
 
-Time Eval vm_compute in (proj1_sig (CReal_sqrt_Q 2) (10 ^ 400)%positive).
+Time Eval vm_compute in (seq (CReal_sqrt_Q 2) (-1000)%Z).
diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v
index 22268daa83..8d590a797c 100644
--- a/test-suite/output/MExtraction.v
+++ b/test-suite/output/MExtraction.v
@@ -58,7 +58,7 @@ Recursive Extraction
            Tauto.abst_form
            ZMicromega.cnfZ  ZMicromega.Zeval_const QMicromega.cnfQ
            List.map simpl_cone (*map_cone  indexes*)
-           denorm Qpower vm_add
+           denorm QArith_base.Qpower vm_add
    normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
 
 (* Local Variables: *)
diff --git a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v
index 10b435d8b0..b77a14d693 100644
--- a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v
+++ b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v
@@ -12,9 +12,34 @@ Require Import QArith.
 Require Import Qabs.
 Require Import ConstructiveCauchyReals.
 Require Import ConstructiveCauchyRealsMult.
+Require Import Lia.
+Require Import Lqa.
+Require Import QExtra.
 
 Local Open Scope CReal_scope.
 
+Local Ltac simplify_Qabs :=
+  match goal with |- context [(Qabs ?a)%Q] => ring_simplify a end.
+
+Local Ltac simplify_Qlt :=
+  match goal with |- (?l < ?r)%Q => ring_simplify l; ring_simplify r end.
+
+Local Lemma Qopp_mult_mone : forall q : Q,
+  (-1 * q == -q)%Q.
+Proof.
+  intros; ring.
+Qed.
+
+Local Lemma Qabs_involutive: forall q : Q,
+  (Qabs (Qabs q) == Qabs q)%Q.
+Proof.
+  intros q; apply Qabs_case; intros Hcase.
+  - reflexivity.
+  - pose proof Qabs_nonneg q as Habspos.
+    pose proof Qle_antisym _ _ Hcase Habspos as Heq0.
+    setoid_rewrite Heq0.
+    reflexivity.
+Qed.
 
 (**
    The constructive formulation of the absolute value on the real numbers.
@@ -33,133 +58,136 @@ Local Open Scope CReal_scope.
    uniquely extends to a uniformly continuous function
    CReal_abs : CReal -> CReal
 *)
-Lemma CauchyAbsStable : forall xn : positive -> Q,
-    QCauchySeq xn
-    -> QCauchySeq (fun n => Qabs (xn n)).
-Proof.
-  intros xn cau n p q H H0.
-  specialize (cau n p q H H0).
-  apply (Qle_lt_trans _ (Qabs (xn p - xn q))).
-  2: exact cau. apply Qabs_Qle_condition. split.
+
+Definition CReal_abs_seq (x : CReal) (n : Z) := Qabs (seq x n).
+
+Definition CReal_abs_scale (x : CReal) := scale x.
+
+Lemma CReal_abs_cauchy: forall (x : CReal),
+    QCauchySeq (CReal_abs_seq x).
+Proof.
+  intros x n p q Hp Hq.
+  pose proof (cauchy x n p q Hp Hq) as Hxbnd.
+  apply (Qle_lt_trans _ (Qabs (seq x p - seq x q))).
+  2: exact Hxbnd. apply Qabs_Qle_condition. split.
   2: apply Qabs_triangle_reverse.
-  apply (Qplus_le_r _ _ (Qabs (xn q))).
+  apply (Qplus_le_r _ _ (Qabs (seq x q))).
   rewrite <- Qabs_opp.
   apply (Qle_trans _ _ _ (Qabs_triangle_reverse _ _)).
   ring_simplify.
-  setoid_replace (-xn q - (xn p - xn q))%Q with (-(xn p))%Q.
-  2: ring. rewrite Qabs_opp. apply Qle_refl.
-Qed.
-
-Definition CReal_abs (x : CReal) : CReal
-  := let (xn, cau) := x in
-     exist _ (fun n => Qabs (xn n)) (CauchyAbsStable xn cau).
-
-Lemma CReal_neg_nth : forall (x : CReal) (n : positive),
-    (proj1_sig x n < -1#n)%Q
-    -> x < 0.
-Proof.
-  intros. destruct x as [xn cau]; unfold proj1_sig in H.
-  apply Qlt_minus_iff in H.
-  setoid_replace ((-1 # n) + - xn n)%Q
-    with (- ((1 # n) + xn n))%Q in H.
-  destruct (Qarchimedean (2 / (-((1#n) + xn n)))) as [k kmaj].
-  exists (Pos.max k n). simpl. unfold Qminus; rewrite Qplus_0_l.
-  specialize (cau n n (Pos.max k n)
-                  (Pos.le_refl _) (Pos.le_max_r _ _)).
-  apply (Qle_lt_trans _ (2#k)).
-  unfold Qle, Qnum, Qden.
-  apply Z.mul_le_mono_nonneg_l. discriminate.
-  apply Pos2Z.pos_le_pos, Pos.le_max_l.
-  apply (Qmult_lt_l _ _ (-((1 # n) + xn n))) in kmaj.
-  rewrite Qmult_div_r in kmaj.
-  apply (Qmult_lt_r _ _ (1 # k)) in kmaj.
-  rewrite <- Qmult_assoc in kmaj.
-  setoid_replace ((Z.pos k # 1) * (1 # k))%Q with 1%Q in kmaj.
-  rewrite Qmult_1_r in kmaj.
-  setoid_replace (2#k)%Q with (2 * (1 # k))%Q. 2: reflexivity.
-  apply (Qlt_trans _ _ _ kmaj). clear kmaj.
-  apply (Qplus_lt_l _ _ ((1#n) + xn (Pos.max k n))).
-  ring_simplify. rewrite Qplus_comm.
-  apply (Qle_lt_trans _ (Qabs (xn n - xn (Pos.max k n)))).
-  2: exact cau.
-  rewrite <- Qabs_opp.
-  setoid_replace (- (xn n - xn (Pos.max k n)))%Q
-    with (xn (Pos.max k n) + -1 * xn n)%Q.
-  apply Qle_Qabs. ring. 2: reflexivity.
-  unfold Qmult, Qeq, Qnum, Qden.
-  rewrite Z.mul_1_r, Z.mul_1_r, Z.mul_1_l. reflexivity.
-  2: exact H. intro abs. rewrite abs in H. exact (Qlt_irrefl 0 H).
-  setoid_replace (-1 # n)%Q with (-(1#n))%Q. ring. reflexivity.
-Qed.
-
-Lemma CReal_nonneg : forall (x : CReal) (n : positive),
-    0 <= x -> (-1#n <= proj1_sig x n)%Q.
-Proof.
-  intros. destruct x as [xn cau]; unfold proj1_sig.
-  destruct (Qlt_le_dec (xn n) (-1#n)).
-  2: exact q. exfalso. apply H. clear H.
-  apply (CReal_neg_nth _ n). exact q.
+  unfold CReal_abs_seq.
+  simplify_Qabs; setoid_rewrite Qopp_mult_mone.
+  do 2 rewrite Qabs_opp.
+  lra.
+Qed.
+
+Lemma CReal_abs_bound : forall (x : CReal),
+  QBound (CReal_abs_seq x) (CReal_abs_scale x).
+Proof.
+  intros x n.
+  unfold CReal_abs_seq, CReal_abs_scale.
+  rewrite Qabs_involutive.
+  apply (bound x).
+Qed.
+
+Definition CReal_abs (x : CReal) : CReal :=
+{|
+  seq := CReal_abs_seq x;
+  scale := CReal_abs_scale x;
+  cauchy := CReal_abs_cauchy x;
+  bound := CReal_abs_bound x
+|}.
+
+Lemma CRealLt_RQ_from_single_dist : forall (r : CReal) (q : Q) (n :Z),
+    (2^n < q - seq r n)%Q
+ -> r < inject_Q q.
+Proof.
+  intros r q n Hapart.
+  pose proof Qpower_pos_lt 2 n ltac:(lra) as H2npos.
+  destruct (QarchimedeanLowExp2_Z (q - seq r n - 2^n) ltac:(lra)) as [k Hk].
+  unfold CRealLt; exists (Z.min n (k-1))%Z.
+  unfold inject_Q; rewrite CReal_red_seq.
+  pose proof cauchy r n n (Z.min n (k-1))%Z ltac:(lia) ltac:(lia) as Hrbnd.
+  pose proof Qpower_le_compat 2 (Z.min n (k - 1))%Z (k-1)%Z ltac:(lia) ltac:(lra).
+  apply (Qmult_le_l _ _ 2 ltac:(lra)) in H.
+  apply (Qle_lt_trans _ _ _ H); clear H.
+  rewrite Qpower_minus_pos.
+  simplify_Qlt.
+  apply Qabs_Qlt_condition in Hrbnd.
+  lra.
+Qed.
+
+Lemma CRealLe_0R_to_single_dist : forall (x : CReal) (n : Z),
+    0 <= x -> (-(2^n) <= seq x n)%Q.
+Proof.
+  intros x n Hxnonneg.
+  destruct (Qlt_le_dec (seq x n) (-(2^n))) as [Hdec|Hdec].
+  - exfalso; apply Hxnonneg.
+    apply (CRealLt_RQ_from_single_dist x 0 n); lra.
+  - exact Hdec.
 Qed.
 
 Lemma CReal_abs_right : forall x : CReal, 0 <= x -> CReal_abs x == x.
 Proof.
-  intros. apply CRealEq_diff. intro n.
-  destruct x as [xn cau]; unfold CReal_abs, proj1_sig.
-  apply (CReal_nonneg _ n) in H. simpl in H.
-  rewrite Qabs_pos.
-  2: unfold Qminus; rewrite <- Qle_minus_iff; apply Qle_Qabs.
-  destruct (Qlt_le_dec (xn n) 0).
-  - rewrite Qabs_neg. 2: apply Qlt_le_weak, q.
-    apply Qopp_le_compat in H.
-    apply (Qmult_le_l _ _ (1#2)). reflexivity. ring_simplify.
-    setoid_replace ((1 # 2) * (2 # n))%Q with (-(-1#n))%Q.
-    2: reflexivity.
-    setoid_replace ((-2 # 2) * xn n)%Q with (- xn n)%Q.
-    exact H. ring.
-  - rewrite Qabs_pos. unfold Qminus. rewrite Qplus_opp_r. discriminate. exact q.
+  intros x Hxnonneg; apply CRealEq_diff; intro n.
+  unfold CReal_abs, CReal_abs_seq, CReal_abs_scale;
+    rewrite CReal_red_seq.
+  pose proof CRealLe_0R_to_single_dist x n Hxnonneg.
+  pose proof Qpower_pos_lt 2 n ltac:(lra) as Hpowpos.
+  do 2 apply Qabs_case; intros H1 H2; lra.
 Qed.
 
 Lemma CReal_le_abs : forall x : CReal, x <= CReal_abs x.
 Proof.
-  intros. intros [n nmaj]. destruct x as [xn cau]; simpl in nmaj.
-  apply (Qle_not_lt _ _ (Qle_Qabs (xn n))).
-  apply Qlt_minus_iff. apply (Qlt_trans _ (2#n)).
-  reflexivity. exact nmaj.
+  intros x [n nmaj].
+  unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in nmaj;
+    rewrite CReal_red_seq in nmaj.
+  apply (Qle_not_lt _ _ (Qle_Qabs (seq x n))).
+  apply Qlt_minus_iff. apply (Qlt_trans _ (2*2^n)).
+  - pose proof Qpower_pos_lt 2 n ltac:(lra); lra.
+  - exact nmaj.
 Qed.
 
 Lemma CReal_abs_pos : forall x : CReal, 0 <= CReal_abs x.
 Proof.
-  intros. intros [n nmaj]. destruct x as [xn cau]; simpl in nmaj.
-  apply (Qle_not_lt _ _ (Qabs_nonneg (xn n))).
-  apply Qlt_minus_iff. apply (Qlt_trans _ (2#n)).
-  reflexivity. exact nmaj.
+  intros x [n nmaj].
+  unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in nmaj;
+    rewrite CReal_red_seq in nmaj.
+  apply (Qle_not_lt _ _ (Qabs_nonneg (seq x n))).
+  apply Qlt_minus_iff. apply (Qlt_trans _ (2*2^n)).
+  - pose proof Qpower_pos_lt 2 n ltac:(lra); lra.
+  - exact nmaj.
 Qed.
 
 Lemma CReal_abs_opp : forall x : CReal, CReal_abs (-x) == CReal_abs x.
 Proof.
-  intros. apply CRealEq_diff. intro n.
-  destruct x as [xn cau]; unfold CReal_abs, CReal_opp, proj1_sig.
-  rewrite Qabs_opp. unfold Qminus. rewrite Qplus_opp_r.
-  discriminate.
+  intros x; apply CRealEq_diff; intro n.
+  unfold CReal_abs, CReal_abs_seq, CReal_abs_scale;
+  unfold CReal_opp, CReal_opp_seq, CReal_opp_scale;
+    do 3 rewrite CReal_red_seq.
+  rewrite Qabs_opp. simplify_Qabs.
+  rewrite Qabs_pos by lra.
+  pose proof Qpower_pos_lt 2 n; lra.
 Qed.
 
 Lemma CReal_abs_left : forall x : CReal, x <= 0 -> CReal_abs x == -x.
 Proof.
-  intros.
-  apply CReal_opp_ge_le_contravar in H. rewrite CReal_opp_0 in H.
-  rewrite <- CReal_abs_opp. apply CReal_abs_right, H.
+  intros x Hxnonpos.
+  apply CReal_opp_ge_le_contravar in Hxnonpos. rewrite CReal_opp_0 in Hxnonpos.
+  rewrite <- CReal_abs_opp. apply CReal_abs_right, Hxnonpos.
 Qed.
 
 Lemma CReal_abs_appart_0 : forall x : CReal,
     0 < CReal_abs x -> x # 0.
 Proof.
-  intros x [n nmaj]. destruct x as [xn cau]; simpl in nmaj.
-  destruct (Qlt_le_dec (xn n) 0).
-  - left. exists n. simpl. rewrite Qabs_neg in nmaj.
-    apply (Qlt_le_trans _ _ _ nmaj). ring_simplify. apply Qle_refl.
-    apply Qlt_le_weak, q.
-  - right. exists n. simpl. rewrite Qabs_pos in nmaj.
-    exact nmaj. exact q.
+  intros x [n nmaj].
+  unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in nmaj;
+    rewrite CReal_red_seq in nmaj.
+  destruct (Qlt_le_dec (seq x n) 0) as [Hdec|Hdec].
+  - left. exists n. cbn in nmaj |- * .
+    rewrite Qabs_neg in nmaj; lra.
+  - right. exists n. cbn. rewrite Qabs_pos in nmaj.
+    exact nmaj. exact Hdec.
 Qed.
 
 Add Parametric Morphism : CReal_abs
@@ -189,15 +217,15 @@ Qed.
 
 Lemma CReal_abs_le : forall a b:CReal, -b <= a <= b -> CReal_abs a <= b.
 Proof.
-  intros a b H [n nmaj]. destruct a as [an cau]; simpl in nmaj.
-  destruct (Qlt_le_dec (an n) 0).
-  - rewrite Qabs_neg in nmaj. destruct H. apply H. clear H H0.
-    exists n. simpl.
-    destruct b as [bn caub]; simpl; simpl in nmaj.
-    unfold Qminus. rewrite Qplus_comm. exact nmaj.
-    apply Qlt_le_weak, q.
-  - rewrite Qabs_pos in nmaj. destruct H. apply H0. clear H H0.
-    exists n. simpl. exact nmaj. exact q.
+  intros a b H [n nmaj].
+  unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in nmaj;
+    rewrite CReal_red_seq in nmaj.
+  destruct (Qlt_le_dec (seq a n) 0) as [Hdec|Hdec].
+  - rewrite Qabs_neg in nmaj by lra. destruct H as [Hl Hr]. apply Hl. clear Hl Hr.
+    exists n; cbn.
+    unfold CReal_opp_seq; lra.
+  - rewrite Qabs_pos in nmaj. destruct H as [Hl Hr]. apply Hr. clear Hl Hr.
+    exists n; cbn. exact nmaj. exact Hdec.
 Qed.
 
 Lemma CReal_abs_minus_sym : forall x y : CReal,
@@ -250,46 +278,37 @@ Qed.
 Lemma CReal_abs_gt : forall x : CReal,
     x < CReal_abs x -> x < 0.
 Proof.
-  intros x [n nmaj]. destruct x as [xn cau]; simpl in nmaj.
-  assert (xn n < 0)%Q.
-  { destruct (Qlt_le_dec (xn n) 0). exact q.
-    exfalso. rewrite Qabs_pos in nmaj. unfold Qminus in nmaj.
-    rewrite Qplus_opp_r in nmaj. inversion nmaj. exact q. }
-  rewrite Qabs_neg in nmaj. 2: apply Qlt_le_weak, H.
-  apply (CReal_neg_nth _ n). simpl.
-  ring_simplify in nmaj.
-  apply (Qplus_lt_l _ _ ((1#n) - xn n)).
-  apply (Qmult_lt_l _ _ 2). reflexivity. ring_simplify.
-  setoid_replace (2 * (1 # n))%Q with (2 # n)%Q. 2: reflexivity.
-  rewrite <- Qplus_assoc.
-  setoid_replace ((2 # n) + 2 * (-1 # n))%Q with 0%Q.
-  rewrite Qplus_0_r. exact nmaj.
-  setoid_replace (2*(-1 # n))%Q with (-(2 # n))%Q.
-  rewrite Qplus_opp_r. reflexivity. reflexivity.
+  intros x [n nmaj].
+  unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in nmaj;
+    rewrite CReal_red_seq in nmaj.
+  assert (seq x n < 0)%Q.
+  { destruct (Qlt_le_dec (seq x n) 0) as [Hdec|Hdec].
+    - exact Hdec.
+    - exfalso. rewrite Qabs_pos in nmaj by apply Hdec.
+      pose proof Qpower_pos_lt 2 n; lra. }
+  rewrite Qabs_neg in nmaj by apply Qlt_le_weak, H.
+  apply (CRealLt_RQ_from_single_dist _ _ n); lra.
 Qed.
 
 Lemma Rabs_def1 : forall x y : CReal,
     x < y -> -x < y -> CReal_abs x < y.
 Proof.
-  intros. apply CRealLt_above in H. apply CRealLt_above in H0.
-  destruct H as [i imaj]. destruct H0 as [j jmaj].
-  exists (Pos.max i j). destruct x as [xn caux], y as [yn cauy]; simpl.
-  simpl in imaj, jmaj.
-  destruct (Qlt_le_dec (xn (Pos.max i j)) 0).
-  - rewrite Qabs_neg.
-    specialize (jmaj (Pos.max i j) (Pos.le_max_r _ _)).
-    apply (Qle_lt_trans _ (2#j)). 2: exact jmaj.
-    unfold Qle, Qnum, Qden.
-    apply Z.mul_le_mono_nonneg_l. discriminate.
-    apply Pos2Z.pos_le_pos, Pos.le_max_r.
-    apply Qlt_le_weak, q.
-  - rewrite Qabs_pos.
-    specialize (imaj (Pos.max i j) (Pos.le_max_l _ _)).
-    apply (Qle_lt_trans _ (2#i)). 2: exact imaj.
-    unfold Qle, Qnum, Qden.
-    apply Z.mul_le_mono_nonneg_l. discriminate.
-    apply Pos2Z.pos_le_pos, Pos.le_max_l.
-    apply q.
+  intros x y Hxlty Hmxlty.
+
+  apply CRealLt_above in Hxlty. apply CRealLt_above in Hmxlty.
+  destruct Hxlty as [i imaj]. destruct Hmxlty as [j jmaj].
+  specialize (imaj (Z.min i j) ltac:(lia)).
+  specialize (jmaj (Z.min i j) ltac:(lia)).
+  cbn in jmaj; unfold CReal_opp_seq in jmaj.
+
+  exists (Z.min i j).
+  unfold CReal_abs, CReal_abs_seq, CReal_abs_scale;
+    rewrite CReal_red_seq.
+
+  pose proof Qpower_pos_lt 2 (Z.min i j)%Z ltac:(lra) as Hpowij.
+  pose proof Qpower_le_compat 2 (Z.min i j)%Z i ltac:(lia) ltac:(lra) as Hpowlei.
+  pose proof Qpower_le_compat 2 (Z.min i j)%Z j ltac:(lia) ltac:(lra) as Hpowlej.
+  apply Qabs_case; intros Hcase; lra.
 Qed.
 
 (* The proof by cases on the signs of x and y applies constructively,
diff --git a/theories/Reals/Cauchy/ConstructiveCauchyReals.v b/theories/Reals/Cauchy/ConstructiveCauchyReals.v
index b332457a7b..8a11c155ce 100644
--- a/theories/Reals/Cauchy/ConstructiveCauchyReals.v
+++ b/theories/Reals/Cauchy/ConstructiveCauchyReals.v
@@ -10,10 +10,15 @@
 (************************************************************************)
 
 Require Import QArith.
+Require Import Qpower.
 Require Import Qabs.
 Require Import Qround.
 Require Import Logic.ConstructiveEpsilon.
 Require CMorphisms.
+Require Import Lia.
+Require Import Lqa.
+Require Import QExtra.
+Require Import ConstructiveExtra.
 
 (** The constructive Cauchy real numbers, ie the Cauchy sequences
     of rational numbers.
@@ -34,24 +39,36 @@ Require CMorphisms.
     forall un, QSeqEquiv un (fun _ => un O) (fun q => O)
     which says nothing about the limit of un.
 
-    We define sequences as positive -> Q instead of nat -> Q,
+    We define sequences as Z -> Q instead of nat -> Q,
     so that we can compute arguments like 2^n fast.
 
+    Todo: doc for Z->Q
+
     WARNING: this module is not meant to be imported directly,
     please import `Reals.Abstract.ConstructiveReals` instead.
 
     WARNING: this file is experimental and likely to change in future releases.
  *)
-Definition QCauchySeq (un : positive -> Q)
+
+Definition QCauchySeq (xn : Z -> Q)
+  : Prop
+  := forall (k : Z) (p q : Z),
+      Z.le p k
+   -> Z.le q k
+   -> Qabs (xn p - xn q) < 2 ^ k.
+
+Definition QBound (xn : Z -> Q) (scale : Z)
   : Prop
-  := forall (k : positive) (p q : positive),
-      Pos.le k p
-      -> Pos.le k q
-      -> Qlt (Qabs (un p - un q)) (1 # k).
+  := forall (k : Z),
+      Qabs (xn k) < 2 ^ scale.
 
-(* A Cauchy real is a Cauchy sequence with the standard modulus *)
-Definition CReal : Set
-  := { x : (positive -> Q) | QCauchySeq x }.
+(* A Cauchy real is a sequence with a proof that the sequence is Cauchy *)
+Record CReal := mkCReal {
+  seq : Z -> Q;
+  scale : Z;
+  cauchy : QCauchySeq seq;
+  bound : QBound seq scale
+}.
 
 Declare Scope CReal_scope.
 
@@ -63,13 +80,11 @@ Bind Scope CReal_scope with CReal.
 
 Local Open Scope CReal_scope.
 
-
-(* So QSeqEquiv is the equivalence relation of this constructive pre-order *)
 Definition CRealLt (x y : CReal) : Set
-  := { n : positive |  Qlt (2 # n) (proj1_sig y n - proj1_sig x n) }.
+  := { n : Z |  Qlt (2 * 2 ^ n) (seq y n - seq x n) }.
 
 Definition CRealLtProp (x y : CReal) : Prop
-  := exists n : positive, Qlt (2 # n) (proj1_sig y n - proj1_sig x n).
+  := exists n : Z, Qlt (2 * 2 ^ n)(seq y n - seq x n).
 
 Definition CRealGt (x y : CReal) := CRealLt y x.
 Definition CReal_appart (x y : CReal) := sum (CRealLt x y) (CRealLt y x).
@@ -82,23 +97,13 @@ Infix "#" := CReal_appart : CReal_scope.
 Lemma CRealLtEpsilon : forall x y : CReal,
     CRealLtProp x y -> x < y.
 Proof.
-  intros. unfold CRealLtProp in H.
-  (* Convert to nat to use indefinite description. *)
-  assert (exists n : nat, lt O n /\ Qlt (2 # Pos.of_nat n)
-                                (proj1_sig y (Pos.of_nat n) - proj1_sig x (Pos.of_nat n))).
-  { destruct H as [n maj]. exists (Pos.to_nat n). split. apply Pos2Nat.is_pos.
-    rewrite Pos2Nat.id. exact maj. }
-  clear H.
-  apply constructive_indefinite_ground_description_nat in H0.
-  destruct H0 as [n maj]. exists (Pos.of_nat n). exact (proj2 maj).
-  intro n. destruct n. right.
-  intros [abs _]. inversion abs.
-  destruct (Qlt_le_dec (2 # Pos.of_nat (S n))
-                       (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n)))).
-  left. split. apply le_n_S, le_0_n. apply q.
-  right. intros [_ abs].
-  apply (Qlt_not_le (2 # Pos.of_nat (S n))
-                    (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n)))); assumption.
+  intros x y H. unfold CRealLtProp in H.
+  apply constructive_indefinite_ground_description_Z in H. apply H.
+  intros n.
+  pose proof Qlt_le_dec (2 * 2 ^ n) (seq y n - seq x n) as Hdec.
+  destruct Hdec as [H1|H1].
+  - left; exact H1.
+  - right; apply Qle_not_lt in H1; exact H1.
 Qed.
 
 Lemma CRealLtForget : forall x y : CReal,
@@ -115,20 +120,18 @@ Lemma CRealLt_lpo_dec : forall x y : CReal,
     -> CRealLt x y + (CRealLt x y -> False).
 Proof.
   intros x y lpo.
-  destruct (lpo (fun n:nat => Qle (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n)))
-                             (2 # Pos.of_nat (S n)))).
-  - intro n. destruct (Qlt_le_dec (2 # Pos.of_nat (S n))
-                                  (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n)))).
-    right. apply Qlt_not_le. exact q. left. exact q.
-  - left. destruct s as [n nmaj]. exists (Pos.of_nat (S n)).
-    apply Qnot_le_lt. exact nmaj.
-  - 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.
+  destruct (lpo (fun n:nat =>
+    seq y (Z_inj_nat_rev n) - seq x (Z_inj_nat_rev n) <= 2 * 2 ^ (Z_inj_nat_rev n)
+  )).
+  - intro n. destruct (Qlt_le_dec (2 * 2 ^ (Z_inj_nat_rev n))
+                                  (seq y (Z_inj_nat_rev n) - seq x (Z_inj_nat_rev n))).
+    + right; lra.
+    + left; lra.
+  - left; destruct s as [n nmaj]; exists (Z_inj_nat_rev n); lra.
+  - right; intro abs; destruct abs as [n majn].
+    specialize (q (Z_inj_nat n)).
+    rewrite Z_inj_nat_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.
 
 (* Alias the large order *)
@@ -152,127 +155,103 @@ Definition CRealEq (x y : CReal) : Prop
 Infix "==" := CRealEq : CReal_scope.
 
 Lemma CRealLe_not_lt : forall x y : CReal,
-    (forall n:positive, Qle (proj1_sig x n - proj1_sig y n) (2 # n))
+    (forall n : Z, (seq x n - seq y n <= 2 * 2 ^ n)%Q)
     <-> 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 n - proj1_sig y n)).
-    assumption. assumption.
-  - intros.
-    destruct (Qlt_le_dec (2 # n) (proj1_sig x n - proj1_sig y n)).
-    exfalso. apply H. exists n. assumption. assumption.
+  - intros H H0.
+    destruct H0 as [n H0]; specialize (H n); lra.
+  - intros H n.
+    destruct (Qlt_le_dec (2 * 2 ^ n) (seq x n - seq y 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 n - proj1_sig y 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 n - proj1_sig y n))
-      with (proj1_sig y n - proj1_sig x 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 n - proj1_sig x n))).
-      apply Qle_Qabs. apply H.
-    + apply CRealLe_not_lt. intro n. specialize (H n).
-      apply (Qle_trans _ (Qabs (proj1_sig x n - proj1_sig y 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 n - proj1_sig x n))
-    -> let (k, _) := Qarchimedean (/(proj1_sig y n - proj1_sig x 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 p - proj1_sig x p).
-Proof.
-  intros [xn limx] [yn limy] n maj.
-  unfold proj1_sig; unfold proj1_sig in maj.
-  pose (yn n - xn n) as dn.
-  destruct (Qarchimedean (/(yn n - xn n - (2#n)))) as [k kmaj].
-  assert (0 < yn n - xn n - (2 # n))%Q as H0.
-  { rewrite <- (Qplus_opp_r (2#n)). apply Qplus_lt_l. assumption. }
-  intros. remember (yn p - xn 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 p - xn p - (yn n - xn n))
-      with (yn p - yn n + (xn n - xn p)).
-    apply (Qle_lt_trans _ (Qabs (yn p - yn n) + Qabs (xn n - xn p))).
-    apply Qabs_triangle.
-    setoid_replace (2#n)%Q with ((1#n) + (1#n))%Q.
-    apply Qplus_lt_le_compat. apply limy.
-    apply (Pos.le_trans _ (Pos.max n (2 * k))).
-    apply Pos.le_max_l. assumption.
-    apply Pos.le_refl. apply Qlt_le_weak. apply limx. apply Pos.le_refl.
-    apply (Pos.le_trans _ (Pos.max n (2 * k))).
-    apply Pos.le_max_l. assumption.
-    rewrite Qinv_plus_distr. reflexivity. ring. }
-  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.
+    <-> forall n:Z, ((Qabs (seq x n - seq y n)) <= (2 * 2 ^ n))%Q.
+Proof.
+  intros x y; split.
+  - intros H n; destruct H as [Hyx Hxy].
+    pose proof (CRealLe_not_lt x y) as [_ Hxy']. specialize (Hxy' Hxy n).
+    pose proof (CRealLe_not_lt y x) as [_ Hyx']. specialize (Hyx' Hyx n).
+    apply Qabs_Qle_condition; lra.
+  - intros H; split;
+      apply CRealLe_not_lt; intro n; specialize (H n);
+      apply Qabs_Qle_condition in H; lra.
+Qed.
+
+(** If the elements x(n) and y(n) of two Cauchy sequences x and are apart by
+    at least 2*eps(n), we can find a k such that all further elements of
+    the sequences are apart by at least 2*eps(k) *)
+
+Lemma CRealLt_aboveSig : forall (x y : CReal) (n : Z),
+    (2 * 2^n < seq y n - seq x n)%Q
+ -> let (k, _) := QarchimedeanExp2_Z (/(seq y n - seq x n - (2 * 2 ^ n)%Q))
+    in forall p:Z,
+        (p <= n)%Z
+     -> (2^(-k) < seq y p - seq x p)%Q.
+Proof.
+  intros x y n maj.
+  destruct (QarchimedeanExp2_Z (/((seq y) n - (seq x) n - (2*2^n)%Q))) as [k kmaj].
+  intros p Hp.
+  apply Qinv_lt_contravar in kmaj.
+    3: apply Qpower_pos_lt; lra.
+    2: apply Qinv_lt_0_compat; lra.
+  rewrite Qinv_involutive, <- Qpower_opp in kmaj; clear maj.
+  pose proof ((cauchy x) n n p ltac:(lia) ltac:(lia)) as HCSx.
+  pose proof ((cauchy y) n p n ltac:(lia) ltac:(lia)) as HCSy.
+  rewrite Qabs_Qlt_condition in HCSx, HCSy.
+  lra.
+Qed.
+
+(** This is a weakened form of CRealLt_aboveSig which a special shape of eps needed below *)
+
+Lemma CRealLt_aboveSig' : forall (x y : CReal) (n : Z),
+    (2 * 2^n < seq y n - seq x n)%Q
+ -> let (k, _) := QarchimedeanExp2_Z (/(seq y n - seq x n - (2 * 2 ^ n)%Q))
+    in forall p:Z,
+        (p <= n)%Z
+     -> (2 * 2^(Z.min (-k-1) n) < seq y p - seq x p)%Q.
+Proof.
+  intros x y n Hapart.
+  pose proof CRealLt_aboveSig x y n Hapart.
+  destruct (QarchimedeanExp2_Z (/ (seq y n - seq x n - (2 * 2 ^ n))))
+    as [k kmaj].
+  intros p Hp; specialize (H p Hp).
+  pose proof Qpower_le_compat 2 (Z.min (- k -1) n) (- k-1) (Z.le_min_l _ _) ltac:(lra) as H1.
+  rewrite Qpower_minus_pos in H1.
+  apply (Qmult_le_compat_r _ _ 2) in H1.
+  2: lra.
+  ring_simplify in H1.
+  exact (Qle_lt_trans _ _ _ H1 H).
 Qed.
 
 Lemma CRealLt_above : forall (x y : CReal),
     CRealLt x y
-    -> { k : positive | forall p:positive,
-          Pos.le k p -> Qlt (2 # k) (proj1_sig y p - proj1_sig x p) }.
+    -> { n : Z | forall p : Z,
+          (p <= n)%Z -> (2 * 2 ^ n < seq y p - seq x p)%Q }.
 Proof.
   intros x y [n maj].
-  pose proof (CRealLt_aboveSig x y n maj).
-  destruct (Qarchimedean (/ (proj1_sig y n - proj1_sig x n - (2 # n))))
+  pose proof (CRealLt_aboveSig' x y n maj) as H.
+  destruct (QarchimedeanExp2_Z (/ (seq y n - seq x n - (2 * 2 ^ n))))
     as [k kmaj].
-  exists (Pos.max n (2*k)). apply H.
+  exists (Z.min (-k - 1) n)%Z; intros p Hp.
+  apply H.
+  lia.
 Qed.
 
 (* The CRealLt index separates the Cauchy sequences *)
-Lemma CRealLt_above_same : forall (x y : CReal) (n : positive),
-    Qlt (2 # n)
-        (proj1_sig y n - proj1_sig x n)
-    -> forall p:positive, Pos.le n p -> Qlt (proj1_sig x p) (proj1_sig y p).
-Proof.
-  intros [xn limx] [yn limy] n inf p H.
-  simpl. simpl in inf.
-  apply (Qplus_lt_l _ _ (- xn n)).
-  apply (Qle_lt_trans _ (Qabs (xn p + - xn n))).
-  apply Qle_Qabs. apply (Qlt_trans _ (1#n)).
-  apply limx. exact H. apply Pos.le_refl.
-  rewrite <- (Qplus_0_r (yn p)).
-  rewrite <- (Qplus_opp_r (yn n)).
-  rewrite (Qplus_comm (yn 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 n + - yn p)).
-  ring_simplify.
-  setoid_replace (yn n + (-1 # 1) * yn p) with (yn n - yn p).
-  apply (Qle_lt_trans _ (Qabs (yn n - yn p))).
-  apply Qle_Qabs. apply limy. apply Pos.le_refl. assumption.
-  field. apply Qle_lteq. left. assumption.
-  rewrite Qplus_comm. rewrite Qinv_minus_distr.
-  reflexivity.
+Lemma CRealLt_above_same : forall (x y : CReal) (n : Z),
+    (2 * 2 ^ n < seq y n - seq x n)%Q
+ -> forall p:Z, (p <= n)%Z -> Qlt (seq x p) (seq y p).
+Proof.
+  intros x y n inf p H.
+  simpl in inf |- *.
+  pose proof ((cauchy x) n p n ltac:(lia) ltac:(lia)).
+  pose proof ((cauchy y) n p n ltac:(lia) ltac:(lia)).
+  rewrite Qabs_Qlt_condition in *.
+  lra.
 Qed.
 
 Lemma CRealLt_asym : forall x y : CReal, x < y -> x <= y.
@@ -280,12 +259,14 @@ 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).
-  apply (Qlt_not_le (proj1_sig y (Pos.max n p))
-                    (proj1_sig x (Pos.max n p))).
-  apply H0. apply Pos.le_max_l.
-  apply Qlt_le_weak. apply (Qplus_lt_l _ _ (-proj1_sig x (Pos.max n p))).
-  rewrite Qplus_opp_r. apply (Qlt_trans _ (2#p)).
-  unfold Qlt. simpl. unfold Z.lt. auto. apply H. apply Pos.le_max_r.
+  apply (Qlt_not_le (seq y (Z.min n p))
+                    (seq x (Z.min n p))).
+  apply H0. apply Z.le_min_l.
+  apply Qlt_le_weak. apply (Qplus_lt_l _ _ (-seq x (Z.min n p))).
+  rewrite Qplus_opp_r. apply (Qlt_trans _ (2*2^p)).
+  - pose proof Qpower_pos_lt 2 p ltac:(lra). lra.
+  - apply H. lia.
+  (* ToDo: use lra *)
 Qed.
 
 Lemma CRealLt_irrefl : forall x:CReal, x < x -> False.
@@ -312,114 +293,71 @@ Qed.
 Lemma CRealLt_dec : forall x y z : CReal,
     x < y -> sum (x < z) (z < y).
 Proof.
-  intros [xn limx] [yn limy] [zn limz] [n inf].
-  unfold proj1_sig in inf.
-  remember (yn n - xn n - (2 # n)) as eps.
-  assert (Qlt 0 eps) as epsPos.
-  { subst eps. unfold Qminus. apply (Qlt_minus_iff (2#n)). assumption. }
-  destruct (Qarchimedean (/eps)) as [k kmaj].
-  destruct (Qlt_le_dec ((yn n + xn n) / (2#1))
-                       (zn (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.max n (4 * k)))).
-    rewrite <- (Qplus_opp_r (xn n)).
-    rewrite (Qplus_comm (xn 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 n)) in decMiddle.
-      apply (Qlt_trans _ ((yn n + xn n) / (2 # 1) + - xn n)).
-      setoid_replace ((yn n + xn n) / (2 # 1) - xn n)
-        with ((yn n - xn 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 n + - xn (Pos.max n (4 * k)))
-        with (-(xn (Pos.max n (4 * k)) - xn n)).
-      apply Qopp_le_compat.
-      apply (Qle_trans _ (Qabs (xn (Pos.max n (4 * k)) - xn n))).
-      apply Qle_Qabs. apply Qle_lteq. left. apply limx. apply Pos.le_max_l.
-      apply Pos.le_refl. ring.
-  - right. exists (Pos.max n (4 * k)). unfold proj1_sig. unfold Qminus.
-    rewrite <- (Qplus_0_r (yn (Pos.max n (4 * k)))).
-    rewrite <- (Qplus_opp_r (yn n)).
-    rewrite (Qplus_comm (yn 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_r _ _ (yn n - yn (Pos.max n (4 * k)) + (1#n)))
-      ; ring_simplify.
-      setoid_replace (-1 * yn (Pos.max n (4 * k)))
-        with (- yn (Pos.max n (4 * k))). 2: ring.
-      apply (Qle_lt_trans _ (Qabs (yn n - yn (Pos.max n (4 * k))))).
-      apply Qle_Qabs. apply limy. apply Pos.le_refl. apply Pos.le_max_l.
-    + apply Qopp_le_compat in decMiddle.
-      apply (Qplus_le_r _ _ (yn n)) in decMiddle.
-      apply (Qle_trans _ (yn n + - ((yn n + xn n) / (2 # 1)))).
-      setoid_replace (yn n + - ((yn n + xn n) / (2 # 1)))
-        with ((yn n - xn 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.
-Defined.
+  intros x y z [n inf].
+  destruct (QarchimedeanExp2_Z (/((seq y) n - (seq x) n - (2 * 2 ^ n)))) as [k kmaj].
+  rewrite Qinv_lt_contravar, Qinv_involutive, <- Qpower_opp in kmaj.
+    3: apply Qpower_pos_lt; lra.
+    2: apply Qinv_lt_0_compat; lra.
+
+  destruct (Qlt_le_dec ((1#2) * ((seq y) n + (seq x) n)) ((seq z) (Z.min n (- k - 2))))
+    as [Hxyltz|Hzlexy]; [left; pose (cauchy x) as HCS|right; pose (cauchy y) as HCS].
+
+  all: exists (Z.min (n)%Z (-k - 2))%Z.
+  all: specialize (HCS n n (Z.min n (-k-2))%Z ltac:(lia) ltac:(lia)).
+  all: rewrite Qabs_Qlt_condition in HCS.
+  all: assert (2 ^ Z.min n (- k - 2) <= 2 ^ (- k - 2))%Q as Hpowmin
+         by (apply Qpower_le_compat; [lia|lra]).
+  all: rewrite Qpower_minus_pos in Hpowmin; lra.
+Qed.
 
 Definition linear_order_T x y z := CRealLt_dec x z y.
 
 Lemma CReal_le_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.
-Defined.
+  intros x y z Hle Hlt.
+  destruct (linear_order_T y x z Hlt) as [Hyltx|Hxltz].
+  - contradiction.
+  - exact Hxltz.
+Qed.
+(* Todo: this was Defined. Why *)
 
 Lemma CReal_lt_le_trans : forall x y z : CReal,
     x < y -> y <= z -> x < z.
 Proof.
-  intros.
-  destruct (linear_order_T x z y H). apply c. contradiction.
-Defined.
+  intros x y z Hlt Hle.
+  destruct (linear_order_T x z y Hlt) as [Hxltz|Hzlty].
+  - exact Hxltz.
+  - contradiction.
+Qed.
+(* Todo: this was Defined. Why *)
 
 Lemma CReal_le_trans : forall x y z : CReal,
     x <= y -> y <= z -> x <= z.
 Proof.
-  intros. intro abs. apply H0.
+  intros x y z Hxley Hylez contra.
+  apply Hylez.
   apply (CReal_lt_le_trans _ x); assumption.
 Qed.
 
 Lemma CReal_lt_trans : forall x y z : CReal,
     x < y -> y < z -> x < z.
 Proof.
-  intros. apply (CReal_lt_le_trans _ y _ H).
-  apply CRealLt_asym. exact H0.
-Defined.
+  intros x y z Hxlty Hyltz.
+  apply (CReal_lt_le_trans _ y _ Hxlty).
+  apply CRealLt_asym; exact Hyltz.
+Qed.
+(* Todo: this was Defined. Why *)
 
 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.
+  intros x y z Hxeqy Hyeqz.
+  destruct Hxeqy as [Hylex Hxley].
+  destruct Hyeqz as [Hzley Hylez].
+  split.
+  - intro contra. destruct (CRealLt_dec _ _ y contra); contradiction.
+  - intro contra. destruct (CRealLt_dec _ _ y contra); contradiction.
 Qed.
 
 Add Parametric Relation : CReal CRealEq
@@ -430,116 +368,143 @@ Add Parametric Relation : CReal CRealEq
 
 Instance CRealEq_relT : CRelationClasses.Equivalence CRealEq.
 Proof.
-  split. exact CRealEq_refl. exact CRealEq_sym. exact CRealEq_trans.
+  split.
+  - exact CRealEq_refl.
+  - exact CRealEq_sym.
+  - exact CRealEq_trans.
 Qed.
 
 Instance CRealLt_morph
   : CMorphisms.Proper
       (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRelationClasses.iffT)) CRealLt.
 Proof.
-  intros x y H x0 y0 H0. 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.
+  intros x y Hxeqy x0 y0 Hx0eqy0.
+  destruct Hxeqy as [Hylex Hxley].
+  destruct Hx0eqy0 as [Hy0lex0 Hx0ley0].
+  split.
+  - intro Hxltx0; destruct (CRealLt_dec x x0 y).
+    + assumption.
+    + contradiction.
+    + destruct (CRealLt_dec y x0 y0).
+        assumption. assumption. contradiction.
+  - intro Hylty0; destruct (CRealLt_dec y y0 x).
+    + assumption.
+    + contradiction.
+    + destruct (CRealLt_dec x y0 x0).
+        assumption. assumption. contradiction.
 Qed.
 
 Instance CRealGt_morph
   : CMorphisms.Proper
       (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRelationClasses.iffT)) CRealGt.
 Proof.
-  intros x y H x0 y0 H0. apply CRealLt_morph; assumption.
+  intros x y Hxeqy x0 y0 Hx0eqy0. apply CRealLt_morph; assumption.
 Qed.
 
 Instance CReal_appart_morph
   : CMorphisms.Proper
       (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRelationClasses.iffT)) CReal_appart.
 Proof.
+  intros x y Hxeqy x0 y0 Hx0eqy0.
   split.
-  - intros. destruct H1. left. rewrite <- H0, <- H. exact c.
-    right. rewrite <- H0, <- H. exact c.
-  - intros. destruct H1. left. rewrite H0, H. exact c.
-    right. rewrite H0, H. exact c.
+  - intros Hapart. destruct Hapart as [Hxltx0|Hx0ltx].
+    + left. rewrite <- Hx0eqy0, <- Hxeqy. exact Hxltx0.
+    + right. rewrite <- Hx0eqy0, <- Hxeqy. exact Hx0ltx.
+  - intros Hapart. destruct Hapart as [Hylty0|Hy0lty].
+    + left. rewrite Hx0eqy0, Hxeqy. exact Hylty0.
+    + right. rewrite Hx0eqy0, Hxeqy. exact Hy0lty.
 Qed.
 
 Add Parametric Morphism : CRealLtProp
     with signature CRealEq ==> CRealEq ==> iff
       as CRealLtProp_morph.
 Proof.
-  intros x y H x0 y0 H0. split.
-  - intro. apply CRealLtForget. apply CRealLtEpsilon in H1.
-    rewrite <- H, <- H0. exact H1.
-  - intro. apply CRealLtForget. apply CRealLtEpsilon in H1.
-    rewrite H, H0. exact H1.
+  intros x y Hxeqy x0 y0 Hx0eqy0.
+  split.
+  - intro Hxltpx0. apply CRealLtForget. apply CRealLtEpsilon in Hxltpx0.
+    rewrite <- Hxeqy, <- Hx0eqy0. exact Hxltpx0.
+  - intro Hylty0. apply CRealLtForget. apply CRealLtEpsilon in Hylty0.
+    rewrite Hxeqy, Hx0eqy0. exact Hylty0.
 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.
+  intros x y Hxeqy x0 y0 Hx0eqy0.
+  split.
+  - intros Hxlex0 Hyley0. unfold CRealLe in Hxlex0.
+    rewrite <- Hx0eqy0 in Hyley0. rewrite <- Hxeqy in Hyley0. contradiction.
+  - intros Hxlex0 Hyley0. unfold CRealLe in Hxlex0.
+    rewrite Hx0eqy0 in Hyley0. rewrite Hxeqy in Hyley0. contradiction.
 Qed.
 
 Add Parametric Morphism : CRealGe
     with signature CRealEq ==> CRealEq ==> iff
       as CRealGe_morph.
 Proof.
-  intros. unfold CRealGe. apply CRealLe_morph; assumption.
+  intros x y Hxeqy x0 y0 Hx0eqy0.
+  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.
+  intros x y z Hxeqy Hxltz.
+  apply (CRealLt_morph x y Hxeqy z z).
+  - apply CRealEq_refl.
+  - apply Hxltz.
 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.
+  intros x y z Hxeqy Hzltx.
+  apply (CRealLt_morph z z (CRealEq_refl z) x y).
+  - apply Hxeqy.
+  - apply Hzltx.
 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.
+  intros x y z Hxeqy Hxlez.
+  apply (CRealLe_morph x y Hxeqy z z).
+  - apply CRealEq_refl.
+  - apply Hxlez.
 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.
+  intros x y z Hxeqy Hzlex.
+  apply (CRealLe_morph z z (CRealEq_refl z) x y).
+  - apply Hxeqy.
+  - apply Hzlex.
 Qed.
 
 
 
 (* Injection of Q into CReal *)
 
-Lemma ConstCauchy : forall q : Q, QCauchySeq (fun _ => q).
+Lemma inject_Q_cauchy : forall q : Q, QCauchySeq (fun _ => q).
 Proof.
-  intros. intros k p r H H0.
-  unfold Qminus. rewrite Qplus_opp_r. unfold Qlt. simpl.
-  unfold Z.lt. auto.
+  intros q k p r Hp Hr.
+  apply Qabs_Qlt_condition.
+  pose proof Qpower_pos_lt 2 k; lra.
 Qed.
 
-Definition inject_Q : Q -> CReal.
-Proof.
-  intro q. exists (fun n => q). apply ConstCauchy.
-Defined.
+Definition inject_Q (q : Q) : CReal :=
+{|
+  seq := (fun n : Z => q);
+  scale := Qbound_ltabs_ZExp2 q;
+  cauchy := inject_Q_cauchy q;
+  bound := (fun _ : Z => Qbound_ltabs_ZExp2_spec q)
+|}.
 
 Definition inject_Z : Z -> CReal
   := fun n => inject_Q (n # 1).
@@ -550,177 +515,140 @@ Notation "2" := (inject_Q 2) : CReal_scope.
 
 Lemma CRealLt_0_1 : CRealLt (inject_Q 0) (inject_Q 1).
 Proof.
-  exists 3%positive. reflexivity.
+  exists (-2)%Z; cbn; lra.
 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 p) (q + (1#p)).
-Proof.
-  intros [xn cau] q maj p. simpl.
-  destruct (Qlt_le_dec (xn 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 p (Pos.max k p) (Pos.le_refl _)).
-  pose proof (Qplus_lt_le_compat (2#k) (q - xn (Pos.max k p))
-                                 (q + (1 # p)) (xn 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 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.max k p) + xn p) _ H).
-  rewrite Qplus_comm.
-  apply (Qle_lt_trans _ (Qabs (xn p - xn (Pos.max k p)))).
-  apply Qle_Qabs. apply cau. 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 p).
-Proof.
-  intros [xn cau] q maj p. simpl.
-  destruct (Qlt_le_dec (q - (1 # p)) (xn 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.max k p) p).
-  pose proof (Qplus_lt_le_compat (2#k) (xn (Pos.max k p) - q)
-                                 (xn 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.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 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.max k p) - xn p) _ H).
-  apply (Qle_lt_trans _ (Qabs (xn (Pos.max k p) - xn p))).
-  apply Qle_Qabs. apply cau.
-  apply Pos.le_max_r. apply Pos.le_refl.
-Qed.
-
-Lemma inject_Q_compare : forall (x : CReal) (p : positive),
-    x <= inject_Q (proj1_sig x p + (1#p)).
-Proof.
-  intros. intros [n nmaj].
-  destruct x as [xn xcau]; simpl in nmaj.
-  apply (Qplus_lt_l _ _ (1#p)) in nmaj.
-  ring_simplify in nmaj.
-  destruct (Pos.max_dec p n).
-  - apply Pos.max_l_iff in e.
-    specialize (xcau n n p (Pos.le_refl _) e).
-    apply (Qlt_le_trans _ _ (Qabs (xn n + -1 * xn p))) in nmaj.
-    2: apply Qle_Qabs.
-    apply (Qlt_trans _ _ _ nmaj) in xcau.
-    apply (Qplus_lt_l _ _ (-(1#n)-(1#p))) in xcau. ring_simplify in xcau.
-    setoid_replace ((2 # n) + -1 * (1 # n)) with (1#n)%Q in xcau.
-    discriminate xcau. setoid_replace (-1 * (1 # n)) with (-1#n)%Q. 2: reflexivity.
-    rewrite Qinv_plus_distr. reflexivity.
-  - apply Pos.max_r_iff in e.
-    specialize (xcau p n p e (Pos.le_refl _)).
-    apply (Qlt_le_trans _ _ (Qabs (xn n + -1 * xn p))) in nmaj.
-    2: apply Qle_Qabs.
-    apply (Qlt_trans _ _ _ nmaj) in xcau.
-    apply (Qplus_lt_l _ _ (-(1#p))) in xcau. ring_simplify in xcau. discriminate.
+    (0 < q)%Q -> CRealLt (inject_Q 0) (inject_Q q).
+Proof.
+  intros q Hq. destruct (QarchimedeanExp2_Z ((2#1) / q)) as [k Hk].
+  exists (-k)%Z; cbn.
+  apply (Qmult_lt_compat_r _ _ q) in Hk.
+    2: assumption.
+  apply (Qmult_lt_compat_r _ _ (2^(-k))) in Hk.
+    2: apply Qpower_pos_lt; lra.
+  field_simplify in Hk.
+    2: lra.
+  (* ToDo: field_simplify should collect powers - the next 3 lines ... *)
+  rewrite <- Qmult_assoc, <- Qpower_plus in Hk by lra.
+  ring_simplify (-k +k)%Z in Hk.
+  rewrite Qpower_0_r in Hk.
+  lra.
+Qed.
+
+Lemma inject_Q_compare : forall (x : CReal) (p : Z),
+    x <= inject_Q (seq x p + (2^p)).
+Proof.
+  intros x p [n nmaj].
+  cbn in nmaj.
+  assert(2^n>0)%Q by (apply Qpower_pos_lt; lra).
+  assert(2^p>0)%Q by (apply Qpower_pos_lt; lra).
+  pose proof x.(cauchy) as xcau.
+  destruct (Z.min_dec p n);
+    [ specialize (xcau n n p ltac:(lia) ltac:(lia)) |
+      specialize (xcau p n p ltac:(lia) ltac:(lia)) ].
+  all: apply Qabs_Qlt_condition in xcau; lra.
 Qed.
 
-
 Add Parametric Morphism : inject_Q
     with signature Qeq ==> CRealEq
       as inject_Q_morph.
 Proof.
-  split.
-  - intros [n abs]. simpl in abs. rewrite H in abs.
-    unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs.
-  - intros [n abs]. simpl in abs. rewrite H in abs.
-    unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs.
+  intros x y Heq; split.
+  all: intros [n Hapart]; cbn in Hapart; rewrite Heq in Hapart.
+  all: assert(2^n>0)%Q by (apply Qpower_pos_lt; lra); lra.
 Qed.
 
 Instance inject_Q_morph_T
   : CMorphisms.Proper
       (CMorphisms.respectful Qeq CRealEq) inject_Q.
 Proof.
-  split.
-  - intros [n abs]. simpl in abs. rewrite H in abs.
-    unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs.
-  - intros [n abs]. simpl in abs. rewrite H in abs.
-    unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs.
-Qed.
-
-
-
-(* Algebraic operations *)
-
-Lemma CReal_plus_cauchy
-  : forall (x y : CReal),
-    QCauchySeq (fun n : positive => Qred (proj1_sig x (2 * n)%positive
-                                       + proj1_sig y (2 * n)%positive)).
-Proof.
-  destruct x as [xn limx], y as [yn limy]; unfold proj1_sig.
-  intros n p q H H0.
-  rewrite Qred_correct, Qred_correct.
-  setoid_replace (xn (2 * p)%positive + yn (2 * p)%positive
-                        - (xn (2 * q)%positive + yn (2 * q)%positive))
-    with (xn (2 * p)%positive - xn (2 * q)%positive
-          + (yn (2 * p)%positive - yn (2 * q)%positive)).
-  2: ring.
-  apply (Qle_lt_trans _ _ _ (Qabs_triangle _ _)).
-  setoid_replace (1#n)%Q with ((1#2*n) + (1#2*n))%Q.
-  apply Qplus_lt_le_compat.
-  - apply limx. unfold id. apply Pos.mul_le_mono_l, H.
-    unfold id. apply Pos.mul_le_mono_l, H0.
-  - apply Qlt_le_weak, limy.
-    unfold id. apply Pos.mul_le_mono_l, H.
-    unfold id. apply Pos.mul_le_mono_l, H0.
-  - rewrite Qinv_plus_distr. unfold Qeq. reflexivity.
-Qed.
-
-(* We reduce the rational numbers to accelerate calculations. *)
-Definition CReal_plus (x y : CReal) : CReal
-  := exist _ (fun n : positive => Qred (proj1_sig x (2 * n)%positive
-                                     + proj1_sig y (2 * n)%positive))
-           (CReal_plus_cauchy x y).
+  intros x y Heq; split.
+  all: intros [n Hapart]; cbn in Hapart; rewrite Heq in Hapart.
+  all: assert(2^n>0)%Q by (apply Qpower_pos_lt; lra); lra.
+Qed.
+
+
+
+(** * Algebraic operations *)
+
+(** We reduce the rational numbers to accelerate calculations. *)
+Definition CReal_plus_seq (x y : CReal) :=
+  (fun n : Z => Qred (seq x (n-1)%Z + seq y (n-1)%Z)).
+
+Definition CReal_plus_scale (x y : CReal) : Z :=
+  Z.max x.(scale) y.(scale) + 1.
+
+Lemma CReal_plus_cauchy : forall (x y : CReal),
+  QCauchySeq (CReal_plus_seq x y).
+Proof.
+  intros x y n p q Hp Hq.
+  unfold CReal_plus_seq.
+  pose proof ((cauchy x) (n-1)%Z (p-1)%Z (q-1)%Z ltac:(lia) ltac:(lia)) as Hxbnd.
+  pose proof ((cauchy y) (n-1)%Z (p-1)%Z (q-1)%Z ltac:(lia) ltac:(lia)) as Hybnd.
+  do 2 rewrite Qred_correct.
+  rewrite Qabs_Qlt_condition in Hxbnd, Hybnd |- *.
+  rewrite Qpower_minus_pos in Hxbnd, Hybnd.
+  lra.
+Qed.
+
+Lemma CReal_plus_bound : forall (x y : CReal),
+  QBound (CReal_plus_seq x y) (CReal_plus_scale x y).
+Proof.
+  intros x y k.
+  unfold CReal_plus_seq, CReal_plus_scale.
+  pose proof (bound x (k-1)%Z) as Hxbnd.
+  pose proof (bound y (k-1)%Z) as Hybnd.
+  rewrite Qpower_plus by lra.
+  pose proof Qpower_le_compat 2 (scale x) (Z.max (scale x) (scale y)) ltac:(lia) ltac:(lra) as Hxmax.
+  pose proof Qpower_le_compat 2 (scale y) (Z.max (scale x) (scale y)) ltac:(lia) ltac:(lra) as Hymax.
+  rewrite Qabs_Qlt_condition in Hxbnd, Hybnd |- *.
+  rewrite Qred_correct.
+  lra.
+Qed.
+
+Definition CReal_plus (x y : CReal) : CReal :=
+{|
+  seq := CReal_plus_seq x y;
+  scale := CReal_plus_scale x y;
+  cauchy := CReal_plus_cauchy x y;
+  bound := CReal_plus_bound x y
+|}.
 
 Infix "+" := CReal_plus : CReal_scope.
 
-Definition CReal_opp (x : CReal) : CReal.
+Definition CReal_opp_seq (x : CReal) :=
+  (fun n : Z => - seq x n).
+
+Definition CReal_opp_scale (x : CReal) : Z :=
+  x.(scale).
+
+Lemma CReal_opp_cauchy : forall (x : CReal),
+  QCauchySeq (CReal_opp_seq x).
 Proof.
-  destruct x as [xn limx].
-  exists (fun n : positive => - xn n).
-  intros k p q H H0. unfold Qminus. rewrite Qopp_involutive.
-  rewrite Qplus_comm. apply limx; assumption.
-Defined.
+  intros x n p q Hp Hq; unfold CReal_opp_seq.
+  pose proof ((cauchy x) n p q ltac:(lia) ltac:(lia)) as Hxbnd.
+  rewrite Qabs_Qlt_condition in Hxbnd |- *.
+  lra.
+Qed.
+
+Lemma CReal_opp_bound : forall (x : CReal),
+  QBound (CReal_opp_seq x) (CReal_opp_scale x).
+Proof.
+  intros x k.
+  unfold CReal_opp_seq, CReal_opp_scale.
+  pose proof (bound x k) as Hxbnd.
+  rewrite Qabs_Qlt_condition in Hxbnd |- *.
+  lra.
+Qed.
+
+Definition CReal_opp (x : CReal) : CReal :=
+{|
+  seq := CReal_opp_seq x;
+  scale := CReal_opp_scale x;
+  cauchy := CReal_opp_cauchy x;
+  bound := CReal_opp_bound x
+|}.
 
 Notation "- x" := (CReal_opp x) : CReal_scope.
 
@@ -729,74 +657,52 @@ Definition CReal_minus (x y : CReal) : CReal
 
 Infix "-" := CReal_minus : CReal_scope.
 
-Lemma belowMultiple : forall n p : positive, Pos.le n (p * n).
+(* ToDo: make a tactic for this *)
+Lemma CReal_red_seq: forall (a : Z -> Q) (b : Z) (c : QCauchySeq a) (d : QBound a b),
+  seq (mkCReal a b c d) = a.
 Proof.
-  intros. apply (Pos.le_trans _ (1*n)). apply Pos.le_refl.
-  apply Pos.mul_le_mono_r. destruct p; discriminate.
+  reflexivity.
 Qed.
 
 Lemma CReal_plus_assoc : forall (x y z : CReal),
     (x + y) + z == x + (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.
-  rewrite Qred_correct, Qred_correct, Qred_correct, Qred_correct.
-  setoid_replace (xn (2 * (2 * n))%positive + yn (2 * (2 * n))%positive
-                  + zn (2 * n)%positive
-                    - (xn (2 * n)%positive + (yn (2 * (2 * n))%positive
-                                                    + zn (2 * (2 * n))%positive)))%Q
-    with (xn (2 * (2 * n))%positive - xn (2 * n)%positive
-          + (zn (2 * n)%positive - zn (2 * (2 * n))%positive))%Q.
-  apply (Qle_trans _ (Qabs (xn (2 * (2 * n))%positive - xn (2 * n)%positive)
-                      + Qabs (zn (2 * n)%positive - zn (2 * (2 * n))%positive))).
-  apply Qabs_triangle.
-  rewrite <- (Qinv_plus_distr 1 1 n). apply Qplus_le_compat.
-  apply Qle_lteq. left. apply limx. rewrite Pos.mul_assoc.
-  apply belowMultiple. apply belowMultiple.
-  apply Qle_lteq. left. apply limz. apply belowMultiple.
-  rewrite Pos.mul_assoc. apply belowMultiple. simpl. field.
+  intros x y z; apply CRealEq_diff; intro n.
+  unfold CReal_plus, CReal_plus_seq. do 4 rewrite CReal_red_seq.
+  do 4 rewrite Qred_correct.
+  ring_simplify (n-1-1)%Z.
+  pose proof ((cauchy x) (n-1)%Z (n-2)%Z (n-1)%Z ltac:(lia) ltac:(lia)) as Hxbnd.
+  specialize ((cauchy z) (n-1)%Z (n-2)%Z (n-1)%Z ltac:(lia) ltac:(lia)) as Hzbnd.
+  apply Qlt_le_weak.
+  rewrite Qabs_Qlt_condition in Hxbnd, Hzbnd |- *.
+  rewrite Qpower_minus_pos in Hxbnd, Hzbnd.
+  lra.
 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. rewrite Qred_correct, Qred_correct.
-  setoid_replace (xn (2 * n)%positive + yn (2 * n)%positive
-                    - (yn (2 * n)%positive + xn (2 * n)%positive))%Q
-    with 0%Q.
-  unfold Qle. simpl. unfold Z.le. intro absurd. inversion absurd.
-  ring.
+  intros x y; apply CRealEq_diff; intros n.
+  unfold CReal_plus, CReal_plus_seq. do 2 rewrite CReal_red_seq.
+  do 2 rewrite Qred_correct.
+  pose proof ((cauchy x) (n-1)%Z (n-1)%Z (n-1)%Z ltac:(lia) ltac:(lia)) as Hxbnd.
+  pose proof ((cauchy y) (n-1)%Z (n-1)%Z (n-1)%Z ltac:(lia) ltac:(lia)) as Hybnd.
+  apply Qlt_le_weak.
+  rewrite Qabs_Qlt_condition in Hxbnd, Hybnd |- *.
+  rewrite Qpower_minus_pos in Hxbnd, Hybnd.
+  lra.
 Qed.
 
 Lemma CReal_plus_0_l : forall r : CReal,
     inject_Q 0 + r == r.
 Proof.
-  intro r. split.
-  - intros [n maj].
-    destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj.
-    rewrite Qplus_0_l, Qred_correct in maj.
-    specialize (q n n (Pos.mul 2 n) (Pos.le_refl _)).
-    apply (Qlt_not_le (2#n) (xn n - xn (2 * n)%positive)).
-    assumption.
-    apply (Qle_trans _ (Qabs (xn n - xn (2 * n)%positive))).
-    apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Qlt_le_weak. apply q.
-    apply belowMultiple.
-    unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r.
-    discriminate. discriminate.
-  - intros [n maj].
-    destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj.
-    rewrite Qplus_0_l, Qred_correct in maj.
-    specialize (q n n (Pos.mul 2 n) (Pos.le_refl _)).
-    rewrite Qabs_Qminus in q.
-    apply (Qlt_not_le (2#n) (xn (Pos.mul 2 n) - xn n)).
-    assumption.
-    apply (Qle_trans _ (Qabs (xn (Pos.mul 2 n) - xn n))).
-    apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Qlt_le_weak. apply q.
-    apply belowMultiple.
-    unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r.
-    discriminate. discriminate.
+  intros x; apply CRealEq_diff; intros n.
+  unfold CReal_plus, CReal_plus_seq, inject_Q. do 2 rewrite CReal_red_seq.
+  rewrite Qred_correct.
+  pose proof ((cauchy x) (n)%Z (n-1)%Z (n)%Z ltac:(lia) ltac:(lia)) as Hxbnd.
+  apply Qlt_le_weak.
+  rewrite Qabs_Qlt_condition in Hxbnd |- *.
+  lra.
 Qed.
 
 Lemma CReal_plus_0_r : forall r : CReal,
@@ -808,94 +714,98 @@ Qed.
 Lemma CReal_plus_lt_compat_l :
   forall x y z : CReal, y < z -> x + y < x + z.
 Proof.
-  intros.
-  apply CRealLt_above in H. destruct H as [n maj].
-  exists n. specialize (maj (2 * n)%positive).
-  setoid_replace (proj1_sig (CReal_plus x z) n
-                  - proj1_sig (CReal_plus x y) n)%Q
-    with (proj1_sig z (2 * n)%positive - proj1_sig y (2 * n)%positive)%Q.
-  apply maj. apply belowMultiple.
-  destruct x as [xn limx], y as [yn limy], z as [zn limz];
-  unfold CReal_plus, proj1_sig.
-  rewrite Qred_correct, Qred_correct. ring.
+  intros  x y z Hlt.
+  apply CRealLt_above in Hlt; destruct Hlt as [n Hapart]; exists n.
+  unfold CReal_plus, CReal_plus_seq in Hapart |- *. do 2 rewrite CReal_red_seq.
+  do 2 rewrite Qred_correct.
+  specialize (Hapart (n-1)%Z ltac:(lia)).
+  lra.
 Qed.
 
 Lemma CReal_plus_lt_compat_r :
   forall x y z : CReal, y < z -> y + x < z + x.
 Proof.
-  intros. do 2 rewrite <- (CReal_plus_comm x).
-  apply CReal_plus_lt_compat_l. assumption.
+  intros x y z.
+  do 2 rewrite <- (CReal_plus_comm x).
+  apply CReal_plus_lt_compat_l.
 Qed.
 
 Lemma CReal_plus_lt_reg_l :
   forall x y z : CReal, x + y < x + z -> y < z.
 Proof.
-  intros. destruct H as [n maj]. exists (2*n)%positive.
-  setoid_replace (proj1_sig z (2 * n)%positive - proj1_sig y (2 * n)%positive)%Q
-      with (proj1_sig (CReal_plus x z) n - proj1_sig (CReal_plus x y) n)%Q.
-  apply (Qle_lt_trans _ (2#n)).
-  setoid_replace (2 # 2 * n)%Q with (1 # n)%Q. 2: reflexivity.
-  unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r.
-  discriminate. discriminate.
-  apply maj.
-  destruct x as [xn limx], y as [yn limy], z as [zn limz];
-    unfold CReal_plus, proj1_sig.
-  rewrite Qred_correct, Qred_correct. ring.
+  intros x y z Hlt.
+  destruct Hlt as [n maj]; exists (n - 1)%Z.
+  setoid_replace (seq z (n - 1)%Z - seq y (n - 1)%Z)%Q
+    with (seq (CReal_plus x z) n - seq (CReal_plus x y) n)%Q.
+  - rewrite Qpower_minus_pos.
+    assert (2 ^ n > 0)%Q by (apply Qpower_pos_lt; lra); lra.
+  - unfold CReal_plus, CReal_plus_seq in maj |- *.
+    do 2 rewrite CReal_red_seq in maj |- *.
+    do 2 rewrite Qred_correct; ring.
 Qed.
 
 Lemma CReal_plus_lt_reg_r :
   forall x y z : CReal, y + x < z + x -> y < z.
 Proof.
-  intros x y z H. rewrite (CReal_plus_comm y), (CReal_plus_comm z) in H.
-  apply CReal_plus_lt_reg_l in H. exact H.
+  intros x y z Hlt.
+  rewrite (CReal_plus_comm y), (CReal_plus_comm z) in Hlt.
+  apply CReal_plus_lt_reg_l in Hlt; exact Hlt.
 Qed.
 
 Lemma CReal_plus_le_reg_l :
   forall x y z : CReal, x + y <= x + z -> y <= z.
 Proof.
-  intros. intro abs. apply H. clear H.
-  apply CReal_plus_lt_compat_l. exact abs.
+  intros x y z Hlt contra.
+  apply Hlt.
+  apply CReal_plus_lt_compat_l; exact contra.
 Qed.
 
 Lemma CReal_plus_le_reg_r :
   forall x y z : CReal, y + x <= z + x -> y <= z.
 Proof.
-  intros. intro abs. apply H. clear H.
-  apply CReal_plus_lt_compat_r. exact abs.
+  intros x y z Hlt contra.
+  apply Hlt.
+  apply CReal_plus_lt_compat_r; exact contra.
 Qed.
 
 Lemma CReal_plus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2.
 Proof.
-  intros. intro abs. apply CReal_plus_lt_reg_l in abs. contradiction.
+  intros x y z Hlt contra.
+  apply Hlt.
+  apply CReal_plus_lt_reg_l in contra; exact contra.
 Qed.
 
 Lemma CReal_plus_le_lt_compat :
   forall r1 r2 r3 r4 : CReal, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4.
 Proof.
-  intros; apply CReal_le_lt_trans with (r2 + r3).
-  intro abs. rewrite CReal_plus_comm, (CReal_plus_comm r1) in abs.
-  apply CReal_plus_lt_reg_l in abs. contradiction.
-  apply CReal_plus_lt_compat_l; exact H0.
+  intros r1 r2 r3 r4 Hr1ler2 Hr3ltr4.
+  apply CReal_le_lt_trans with (r2 + r3).
+  intro contra; rewrite CReal_plus_comm, (CReal_plus_comm r1) in contra.
+  apply CReal_plus_lt_reg_l in contra. contradiction.
+  apply CReal_plus_lt_compat_l. exact Hr3ltr4.
 Qed.
 
 Lemma CReal_plus_le_compat :
   forall r1 r2 r3 r4 : CReal, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4.
 Proof.
-  intros; apply CReal_le_trans with (r2 + r3).
-  intro abs. rewrite CReal_plus_comm, (CReal_plus_comm r1) in abs.
-  apply CReal_plus_lt_reg_l in abs. contradiction.
-  apply CReal_plus_le_compat_l; exact H0.
+  intros r1 r2 r3 r4 Hr1ler2 Hr3ler4.
+  apply CReal_le_trans with (r2 + r3).
+  intro contra; rewrite CReal_plus_comm, (CReal_plus_comm r1) in contra.
+  apply CReal_plus_lt_reg_l in contra. contradiction.
+  apply CReal_plus_le_compat_l; exact Hr3ler4.
 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.
+  intros x; apply CRealEq_diff; intros n.
+  unfold CReal_plus, CReal_plus_seq, CReal_opp, CReal_opp_seq, inject_Q.
+  do 3 rewrite CReal_red_seq.
   rewrite Qred_correct.
-  setoid_replace (xn (2 * n)%positive + - xn (2 * n)%positive - 0)%Q
-    with 0%Q.
-  unfold Qle. simpl. unfold Z.le. intro absurd. inversion absurd. ring.
+  pose proof ((cauchy x) (n)%Z (n-1)%Z (n)%Z ltac:(lia) ltac:(lia)) as Hxbnd.
+  apply Qlt_le_weak.
+  rewrite Qabs_Qlt_condition in Hxbnd |- *.
+  lra.
 Qed.
 
 Lemma CReal_plus_opp_l : forall x : CReal,
@@ -994,80 +904,83 @@ Qed.
 Lemma inject_Q_plus : forall q r : Q,
     inject_Q (q + r) == inject_Q q + inject_Q r.
 Proof.
+  intros q r.
   split.
-  - intros [n nmaj]. unfold CReal_plus, inject_Q, proj1_sig in nmaj.
-    rewrite Qred_correct in nmaj.
-    ring_simplify in nmaj. discriminate.
-  - intros [n nmaj]. unfold CReal_plus, inject_Q, proj1_sig in nmaj.
-    rewrite Qred_correct in nmaj.
-    ring_simplify in nmaj. discriminate.
+  all: intros [n nmaj]; unfold CReal_plus, CReal_plus_seq, inject_Q in nmaj.
+  all: do 4 rewrite CReal_red_seq in nmaj.
+  all: rewrite Qred_correct in nmaj.
+  all: assert(2^n>0)%Q by (apply Qpower_pos_lt; lra); lra.
 Qed.
 
 Lemma inject_Q_one : inject_Q 1 == 1.
 Proof.
   split.
-  - intros [n nmaj]. simpl in nmaj.
-    ring_simplify in nmaj. discriminate.
-  - intros [n nmaj]. simpl in nmaj.
-    ring_simplify in nmaj. discriminate.
+  all: intros [n nmaj]; cbn in nmaj.
+  all: assert(2^n>0)%Q by (apply Qpower_pos_lt; lra); lra.
 Qed.
 
 Lemma inject_Q_lt : forall q r : Q,
     Qlt q r -> inject_Q q < inject_Q r.
 Proof.
-  intros. destruct (Qarchimedean (/(r-q))).
-  exists (2*x)%positive; simpl.
-  setoid_replace (2 # x~0)%Q with (/(Z.pos x#1))%Q. 2: reflexivity.
-  apply Qlt_shift_inv_r. reflexivity.
-  apply (Qmult_lt_l _ _ (r-q)) in q0. rewrite Qmult_inv_r in q0.
-  exact q0. intro abs. rewrite Qlt_minus_iff in H.
-  unfold Qminus in abs. rewrite abs in H. discriminate H.
-  unfold Qminus. rewrite <- Qlt_minus_iff. exact H.
+  intros q r Hlt.
+  destruct (QarchimedeanExp2_Z (/(r-q))) as [n Hn].
+  rewrite Qinv_lt_contravar, Qinv_involutive, <- Qpower_opp in Hn.
+  - exists (-n-1)%Z; cbn.
+    rewrite Qpower_minus_pos; lra.
+  - apply Qlt_shift_inv_l; lra.
+  - apply Qpower_pos_lt; lra.
 Qed.
 
 Lemma opp_inject_Q : forall q : Q,
     inject_Q (-q) == - inject_Q q.
 Proof.
+  intros q.
   split.
-  - intros [n maj]. simpl in maj. ring_simplify in maj. discriminate.
-  - intros [n maj]. simpl in maj. ring_simplify in maj. discriminate.
+  all: intros [n maj]; cbn in maj.
+  all: unfold CReal_opp_seq, inject_Q in maj.
+  all: rewrite CReal_red_seq in maj.
+  all: assert(2^n>0)%Q by (apply Qpower_pos_lt; lra); lra.
 Qed.
 
 Lemma lt_inject_Q : forall q r : Q,
-    inject_Q q < inject_Q r -> Qlt q r.
+    inject_Q q < inject_Q r -> (q < r)%Q.
 Proof.
-  intros. destruct H. simpl in q0.
-  apply Qlt_minus_iff, (Qlt_trans _ (2#x)).
-  reflexivity. exact q0.
+  intros q r [n Hn]; cbn in Hn.
+  apply Qlt_minus_iff.
+  assert(2^n>0)%Q by (apply Qpower_pos_lt; lra); lra.
 Qed.
 
 Lemma le_inject_Q : forall q r : Q,
-    inject_Q q <= inject_Q r -> Qle q r.
+    inject_Q q <= inject_Q r -> (q <= r)%Q.
 Proof.
-  intros. destruct (Qlt_le_dec r q). 2: exact q0.
-  exfalso. apply H. clear H. apply inject_Q_lt. exact q0.
+  intros q r Hle.
+  destruct (Qlt_le_dec r q) as [Hdec|Hdec].
+  - exfalso.
+    apply Hle; apply inject_Q_lt; exact Hdec.
+  - exact Hdec.
 Qed.
 
 Lemma inject_Q_le : forall q r : Q,
-    Qle q r -> inject_Q q <= inject_Q r.
+    (q <= r)%Q -> inject_Q q <= inject_Q r.
 Proof.
-  intros. intros [n maj]. simpl in maj.
-  apply (Qlt_not_le _ _ maj). apply (Qle_trans _ 0).
-  apply (Qplus_le_l _ _ r). ring_simplify. exact H. discriminate.
+  intros q r Hle [n maj]; cbn in maj.
+  assert(2^n>0)%Q by (apply Qpower_pos_lt; lra); lra.
 Qed.
 
 Lemma inject_Z_plus : forall q r : Z,
     inject_Z (q + r) == inject_Z q + inject_Z r.
 Proof.
-  intros. unfold inject_Z.
+  intros q r; unfold inject_Z.
   setoid_replace (q + r # 1)%Q with ((q#1) + (r#1))%Q.
-  apply inject_Q_plus. rewrite Qinv_plus_distr. reflexivity.
+  - apply inject_Q_plus.
+  - rewrite Qinv_plus_distr; reflexivity.
 Qed.
 
 Lemma opp_inject_Z : forall n : Z,
     inject_Z (-n) == - inject_Z n.
 Proof.
-  intros. unfold inject_Z.
+  intros n; unfold inject_Z.
   setoid_replace (-n # 1)%Q with (-(n#1))%Q.
-  rewrite opp_inject_Q. reflexivity. reflexivity.
+  - rewrite opp_inject_Q; reflexivity.
+  - reflexivity.
 Qed.
diff --git a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v
index 7b7eb716e6..a180e13444 100644
--- a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v
+++ b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v
@@ -14,129 +14,147 @@
     WARNING: this file is experimental and likely to change in future releases.
 *)
 
-Require Import QArith Qabs Qround.
+Require Import QArith Qabs Qround Qpower.
 Require Import Logic.ConstructiveEpsilon.
 Require Export ConstructiveCauchyReals.
 Require CMorphisms.
+Require Import Lia.
+Require Import Lqa.
+Require Import QExtra.
 
 Local Open Scope CReal_scope.
 
-Definition QCauchySeq_bound (qn : positive -> Q) (cvmod : positive -> positive)
-  : positive
-  := match Qnum (qn (cvmod 1%positive)) with
-     | Z0 => 1%positive
-     | Z.pos p => p + 1
-     | Z.neg p => p + 1
-     end.
+Definition CReal_mult_seq (x y : CReal) :=
+  (fun n : Z => seq x (n - scale y - 1)%Z
+              * seq y (n - scale x - 1)%Z).
+
+Definition CReal_mult_scale (x y : CReal) : Z :=
+  x.(scale) + y.(scale).
+
+Local Ltac simplify_Qpower_exponent :=
+  match goal with |- context [(_ ^ ?a)%Q] => ring_simplify a end.
+
+Local Ltac simplify_Qabs :=
+  match goal with |- context [(Qabs ?a)%Q] => ring_simplify a end.
+
+Local Ltac simplify_Qabs_in H :=
+  match type of H with context [(Qabs ?a)%Q] => ring_simplify a in H end.
+
+Local Ltac field_simplify_Qabs :=
+  match goal with |- context [(Qabs ?a)%Q] => field_simplify a end.
+
+Local Ltac pose_Qabs_pos :=
+  match goal with |- context [(Qabs ?a)%Q] => pose proof Qabs_nonneg a end.
+
+Local Ltac simplify_Qle :=
+  match goal with |- (?l <= ?r)%Q => ring_simplify l; ring_simplify r end.
+
+Local Ltac simplify_Qle_in H :=
+  match type of H with (?l <= ?r)%Q => ring_simplify l in H; ring_simplify r in H end.
+
+Local Ltac simplify_Qlt :=
+  match goal with |- (?l < ?r)%Q => ring_simplify l; ring_simplify r end.
+
+Local Ltac simplify_Qlt_in H :=
+  match type of H with (?l < ?r)%Q => ring_simplify l in H; ring_simplify r in H end.
+
+Local Ltac simplify_seq_idx :=
+  match goal with |- context [seq ?x ?n] => progress ring_simplify n end.
+
+Local Lemma Weaken_Qle_QpowerAddExp: forall (q : Q) (n m : Z),
+    (m >= 0)%Z
+ -> (q <= 2^n)%Q
+ -> (q <= 2^(n+m))%Q.
+Proof.
+  intros q n m Hmpos Hle.
+  pose proof Qpower_le_compat 2 n (n+m) ltac:(lia) ltac:(lra).
+  lra.
+Qed.
 
-Lemma QCauchySeq_bounded_prop (qn : positive -> Q)
-  : QCauchySeq qn
-    -> forall n:positive, Qlt (Qabs (qn n)) (Z.pos (QCauchySeq_bound qn id) # 1).
+Local Lemma Weaken_Qle_QpowerRemSubExp: forall (q : Q) (n m : Z),
+    (m >= 0)%Z
+ -> (q <= 2^(n-m))%Q
+ -> (q <= 2^n)%Q.
 Proof.
-  intros H n. unfold QCauchySeq_bound.
-  assert (1 <= n)%positive as H0. { destruct n; discriminate. }
-  specialize (H 1%positive (1%positive) n (Pos.le_refl _) H0).
-  unfold id.
-  destruct (qn (1%positive)) as [a b]. unfold Qnum.
-  rewrite Qabs_Qminus in H.
-  apply (Qplus_lt_l _ _ (-Qabs (a#b))).
-  apply (Qlt_le_trans _ 1).
-  exact (Qle_lt_trans _ _ _ (Qabs_triangle_reverse (qn n) (a#b)) H).
-  assert (forall p : positive,
-             (1 <= (Z.pos (p + 1) # 1) + - (Z.pos p # b))%Q).
-  { intro p. unfold Qle, Qopp, Qplus, Qnum, Qden.
-    rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_add, Pos.mul_1_l.
-    apply (Z.add_le_mono_l _ _ (Z.pos p -Z.pos b)).
-    ring_simplify. apply (Z.le_trans _ (Z.pos p * 1)).
-    rewrite Z.mul_1_r. apply Z.le_refl.
-    apply Z.mul_le_mono_nonneg_l. discriminate. destruct b; discriminate. }
-  destruct a.
-  - setoid_replace (Qabs (0#b)) with 0%Q. 2: reflexivity.
-    rewrite Qplus_0_r. apply Qle_refl.
-  - apply H1.
-  - apply H1.
+  intros q n m Hmpos Hle.
+  pose proof Qpower_le_compat 2 (n-m) n ltac:(lia) ltac:(lra).
+  lra.
 Qed.
 
-Lemma factorDenom : forall (a:Z) (b d:positive), ((a # (d * b)) == (1#d) * (a#b))%Q.
+Local Lemma Weaken_Qle_QpowerFac: forall (q r : Q) (n : Z),
+    (r >= 1)%Q
+ -> (q <= 2^n)%Q
+ -> (q <= r * 2^n)%Q.
 Proof.
-  intros. unfold Qeq. simpl. destruct a; reflexivity.
+  intros q r n Hrge1 Hle.
+  rewrite <- (Qmult_1_l (2^n)%Q) in Hle.
+  pose proof Qmult_le_compat_r 1 r (2^n)%Q Hrge1 (Qpower_pos 2 n ltac:(lra)) as Hpow.
+  lra.
 Qed.
 
-Lemma CReal_mult_cauchy
-  : forall (x y : CReal) (A : positive),
-    (forall n : positive, (Qabs (proj1_sig x n) < Z.pos A # 1)%Q)
-    -> (forall n : positive, (Qabs (proj1_sig y n) < Z.pos A # 1)%Q)
-    -> QCauchySeq (fun n : positive => proj1_sig x (2 * A * n)%positive
-                                   * proj1_sig y (2 * A * n)%positive).
+Lemma CReal_mult_cauchy: forall (x y : CReal),
+  QCauchySeq (CReal_mult_seq x y).
 Proof.
-  intros [xn limx] [yn limy] A. unfold proj1_sig.
-  intros majx majy k p q H H0.
-  setoid_replace (xn (2*A*p)%positive * yn (2*A*p)%positive
-                  - xn (2*A*q)%positive * yn (2*A*q)%positive)%Q
-    with ((xn (2*A*p)%positive - xn (2*A*q)%positive) * yn (2*A*p)%positive
-          + xn (2*A*q)%positive * (yn (2*A*p)%positive - yn (2*A*q)%positive))%Q.
-  2: ring.
+  intros x y n p q Hp Hq.
+  unfold CReal_mult_seq.
+
+  assert(forall xp xq yp yq : Q, xp * yp - xq * yq == (xp - xq) * yp + xq * (yp - yq))%Q
+    as H by (intros; ring).
+  rewrite H; clear H.
+
   apply (Qle_lt_trans _ _ _ (Qabs_triangle _ _)).
-  rewrite Qabs_Qmult, Qabs_Qmult.
-  setoid_replace (1#k)%Q with ((1#2*k) + (1#2*k))%Q.
-  2: rewrite Qinv_plus_distr; reflexivity.
+  do 2 rewrite Qabs_Qmult.
+
+  replace n with ((n-1)+1)%Z by ring.
+  rewrite Qpower_plus by lra.
+  setoid_replace (2 ^ (n - 1) * 2 ^1)%Q with (2 ^ (n - 1) + 2 ^ (n - 1))%Q by ring.
+
   apply Qplus_lt_le_compat.
-  - apply (Qle_lt_trans _ ((1#2*A * k) * Qabs (yn (2*A*p)%positive))).
-    + apply Qmult_le_compat_r. apply Qlt_le_weak. apply limx.
-      apply Pos.mul_le_mono_l, H. apply Pos.mul_le_mono_l, H0.
-      apply Qabs_nonneg.
-    + 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. reflexivity.
-      apply (Qle_lt_trans _ (Qabs (yn (2 * A * p)%positive) * (1 # A))).
-      rewrite <- (Qmult_comm (1 # A)). apply Qmult_le_compat_r.
-      unfold Qle. simpl. apply Z.le_refl.
-      apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#A)).
-      2: intro abs; inversion abs.
-      rewrite Qmult_comm. apply Qmult_lt_l. reflexivity.
-      setoid_replace (/(1#A))%Q with (Z.pos A # 1)%Q.
-      2: reflexivity.
-      apply majy.
-  - apply (Qle_trans _ ((1 # 2 * A * k) * Qabs (xn (2*A*q)%positive))).
-    + rewrite Qmult_comm. apply Qmult_le_compat_r.
-      apply Qlt_le_weak. apply limy.
-      apply Pos.mul_le_mono_l, H. apply Pos.mul_le_mono_l, H0.
-      apply Qabs_nonneg.
-    + 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 Qlt_le_weak.
-      apply Qmult_lt_l. reflexivity.
-      apply (Qle_lt_trans _ (Qabs (xn (2 * A * q)%positive) * (1 # A))).
-      rewrite <- (Qmult_comm (1 # A)). apply Qmult_le_compat_r.
-      apply Qle_refl.
-      apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#A)).
-      2: intro abs; inversion abs.
-      rewrite Qmult_comm. apply Qmult_lt_l. reflexivity.
-      setoid_replace (/(1#A))%Q with (Z.pos A # 1)%Q. 2: reflexivity.
-      apply majx.
+  - apply (Qle_lt_trans _ ((2 ^ (n - scale y - 1)) * Qabs (seq y (p - scale x - 1)))).
+    + apply Qmult_le_compat_r.
+        2: apply Qabs_nonneg.
+      apply Qlt_le_weak. apply (cauchy x); lia.
+    + apply (Qmult_lt_l _ _ (2 ^ -(n - scale y - 1))%Q).
+        apply Qpower_pos_lt; lra.
+      rewrite Qmult_assoc, <- Qpower_plus by lra.
+      rewrite <- Qpower_plus by lra.
+      simplify_Qpower_exponent; rewrite Qpower_0_r, Qmult_1_l.
+      simplify_Qpower_exponent.
+      apply (bound y).
+  - apply Qlt_le_weak.
+    apply (Qle_lt_trans _ ((2 ^ (n - scale x - 1)) * Qabs (seq x (q - scale y - 1)))).
+    + rewrite Qmult_comm; apply Qmult_le_compat_r.
+        2: apply Qabs_nonneg.
+      apply Qlt_le_weak; apply (cauchy y); lia.
+    + apply (Qmult_lt_l _ _ (2 ^ -(n - scale x - 1))%Q).
+        apply Qpower_pos_lt; lra.
+      rewrite Qmult_assoc, <- Qpower_plus by lra.
+      rewrite <- Qpower_plus by lra.
+      simplify_Qpower_exponent; rewrite Qpower_0_r, Qmult_1_l.
+      simplify_Qpower_exponent.
+      apply (bound x).
 Qed.
 
-Definition CReal_mult (x y : CReal) : CReal.
+Lemma CReal_mult_bound : forall (x y : CReal),
+  QBound (CReal_mult_seq x y) (CReal_mult_scale x y).
 Proof.
-  exists (fun n : positive => proj1_sig x ((2 * Pos.max (QCauchySeq_bound (proj1_sig x) id) (QCauchySeq_bound (proj1_sig y) id)) * n)%positive
-                                * proj1_sig y ((2 * Pos.max (QCauchySeq_bound (proj1_sig x) id)
-                                                            (QCauchySeq_bound (proj1_sig y) id)) * n)%positive).
-  apply (CReal_mult_cauchy x y).
-  - intro n. destruct x as [xn caux]. unfold proj1_sig.
-    pose proof (QCauchySeq_bounded_prop xn caux).
-    apply (Qlt_le_trans _ (Z.pos (QCauchySeq_bound xn id) # 1)).
-    apply H.
-    unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    rewrite Pos2Z.inj_max. apply Z.le_max_l.
-  - intro n. destruct y as [yn cauy]. unfold proj1_sig.
-    pose proof (QCauchySeq_bounded_prop yn cauy).
-    apply (Qlt_le_trans _ (Z.pos (QCauchySeq_bound yn id) # 1)).
-    apply H.
-    unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    rewrite Pos2Z.inj_max. apply Z.le_max_r.
-Defined.
+  intros x y k.
+  unfold CReal_mult_seq, CReal_mult_scale.
+  pose proof (bound x (k - scale y - 1)%Z) as Hxbnd.
+  pose proof (bound y (k - scale x - 1)%Z) as Hybnd.
+  pose proof Qabs_nonneg (seq x (k - scale y - 1)) as Habsx.
+  pose proof Qabs_nonneg (seq y (k - scale x - 1)) as Habsy.
+  rewrite Qabs_Qmult; rewrite Qpower_plus by lra.
+  apply Qmult_lt_compat_nonneg; lra.
+Qed.
+
+Definition CReal_mult (x y : CReal) : CReal :=
+{|
+  seq := CReal_mult_seq x y;
+  scale := CReal_mult_scale x y;
+  cauchy := CReal_mult_cauchy x y;
+  bound := CReal_mult_bound x y
+|}.
 
 Infix "*" := CReal_mult : CReal_scope.
 
@@ -144,42 +162,43 @@ Lemma CReal_mult_comm : forall x y : CReal, x * y == y * x.
 Proof.
   assert (forall x y : CReal, x * y <= y * x) as H.
   { intros x y [n nmaj]. apply (Qlt_not_le _ _ nmaj). clear nmaj.
-    unfold CReal_mult, proj1_sig.
-    destruct x as [xn limx], y as [yn limy].
-    rewrite Pos.max_comm, Qmult_comm. ring_simplify. discriminate. }
+    unfold CReal_mult, CReal_mult_seq; do 2 rewrite CReal_red_seq.
+    ring_simplify.
+    pose proof Qpower_pos_lt 2 n ltac:(lra); lra. }
   split; apply H.
 Qed.
 
+(* ToDo: make a tactic for this *)
+Lemma CReal_red_scale: forall (a : Z -> Q) (b : Z) (c : QCauchySeq a) (d : QBound a b),
+  scale (mkCReal a b c d) = b.
+Proof.
+  reflexivity.
+Qed.
+
 Lemma CReal_mult_proper_0_l : forall x y : CReal,
     y == 0 -> x * y == 0.
 Proof.
-  assert (forall a:Q, a-0 == a)%Q as Qmin0.
-  { intros. ring. }
-  intros. apply CRealEq_diff. intros n.
-  destruct x as [xn limx], y as [yn limy].
-  unfold CReal_mult, proj1_sig, inject_Q.
-  rewrite CRealEq_diff in H; unfold proj1_sig, inject_Q in H.
-  specialize (H (2 * Pos.max (QCauchySeq_bound xn id)
-                             (QCauchySeq_bound yn id) * n))%positive.
-  rewrite Qmin0 in H. rewrite Qmin0, Qabs_Qmult, Qmult_comm.
-  apply (Qle_trans
-           _ ((2 # (2 * Pos.max (QCauchySeq_bound xn id) (QCauchySeq_bound yn id) * n)%positive) *
-       (Qabs (xn (2 * Pos.max (QCauchySeq_bound xn id) (QCauchySeq_bound yn id) * n)%positive) ))).
-  apply Qmult_le_compat_r.
-  2: apply Qabs_nonneg. exact H. clear H. rewrite Qmult_comm.
-  apply (Qle_trans _ ((Z.pos (QCauchySeq_bound xn id) # 1)
-                      * (2 # (2 * Pos.max (QCauchySeq_bound xn id) (QCauchySeq_bound yn id) * n)%positive))).
-  apply Qmult_le_compat_r.
-  apply Qlt_le_weak, (QCauchySeq_bounded_prop xn limx).
-  discriminate.
-  unfold Qle, Qmult, Qnum, Qden.
-  rewrite Pos.mul_1_l. rewrite <- (Z.mul_comm 2), <- Z.mul_assoc.
-  apply Z.mul_le_mono_nonneg_l. discriminate.
-  rewrite <- Pos2Z.inj_mul. apply Pos2Z.pos_le_pos, Pos.mul_le_mono_r.
-  apply (Pos.le_trans _ (2 * QCauchySeq_bound xn id)).
-  apply (Pos.le_trans _ (1 * QCauchySeq_bound xn id)).
-  apply Pos.le_refl. apply Pos.mul_le_mono_r. discriminate.
-  apply Pos.mul_le_mono_l. apply Pos.le_max_l.
+  intros x y Hyeq0.
+
+  apply CRealEq_diff; intros n.
+  unfold CReal_mult, CReal_mult_seq, inject_Q; do 2 rewrite CReal_red_seq.
+  simplify_Qabs.
+
+  rewrite CRealEq_diff in Hyeq0.
+  unfold inject_Q in Hyeq0; rewrite CReal_red_seq in Hyeq0.
+  specialize (Hyeq0 (n - scale x - 1)%Z).
+  simplify_Qabs_in Hyeq0.
+  rewrite Qpower_minus_pos in Hyeq0 by lra; simplify_Qle_in Hyeq0.
+
+  pose proof bound x (n - scale y - 1)%Z as Hxbnd.
+  apply Weaken_Qle_QpowerFac; [lra|].
+
+  (* Now split the power of 2 and solve the goal*)
+  replace n with ((scale x) + (n - scale x))%Z at 3 by ring.
+  rewrite Qpower_plus by lra.
+  rewrite Qabs_Qmult.
+  apply Qmult_le_compat_nonneg;
+    (pose_Qabs_pos; lra).
 Qed.
 
 Lemma CReal_mult_0_r : forall r, r * 0 == 0.
@@ -192,270 +211,98 @@ Proof.
   intros. rewrite CReal_mult_comm. apply CReal_mult_0_r.
 Qed.
 
-Lemma CRealLt_0_aboveSig : forall (x : CReal) (n : positive),
-    Qlt (2 # n) (proj1_sig x n)
-    -> forall p:positive,
-      Pos.le n p -> Qlt (1 # n) (proj1_sig x p).
+Lemma CReal_scale_sep0_limit : forall (x : CReal) (n : Z),
+    (2 * (2^n)%Q < seq x n)%Q
+ -> (n <= scale x - 2)%Z.
 Proof.
-  intros. destruct x as [xn caux].
-  unfold proj1_sig. unfold proj1_sig in H.
-  specialize (caux n n p (Pos.le_refl n) H0).
-  apply (Qplus_lt_l _ _ (xn n-xn p)).
-  apply (Qlt_trans _ ((1#n) + (1#n))).
-  apply Qplus_lt_r. exact (Qle_lt_trans _ _ _ (Qle_Qabs _) caux).
-  rewrite Qinv_plus_distr. ring_simplify. exact H.
+  intros x n Hnx.
+  pose proof bound x n as Hxbnd.
+  apply Qabs_Qlt_condition in Hxbnd.
+  destruct Hxbnd as [_ Hxbnd].
+  apply (Qlt_trans _ _ _ Hnx) in Hxbnd.
+  replace n with ((n+1)-1)%Z in Hxbnd by lia.
+  rewrite Qpower_minus_pos in Hxbnd by lra.
+  simplify_Qlt_in Hxbnd.
+  apply (Qpower_lt_compat_inv) in Hxbnd.
+  - lia.
+  - lra.
 Qed.
 
 (* Correctness lemma for the Definition CReal_mult_lt_0_compat below. *)
 Lemma CReal_mult_lt_0_compat_correct
-  : forall (x y : CReal) (H : 0 < x) (H0 : 0 < y),
-    (2 # 2 * proj1_sig H * proj1_sig H0 <
-     proj1_sig (x * y)%CReal (2 * proj1_sig H * proj1_sig H0)%positive -
-     proj1_sig (inject_Q 0) (2 * proj1_sig H * proj1_sig H0)%positive)%Q.
+  : forall (x y : CReal) (Hx : 0 < x) (Hy : 0 < y),
+    (2 * 2^(proj1_sig Hx + proj1_sig Hy - 1)%Z <
+     seq (x * y)%CReal (proj1_sig Hx + proj1_sig Hy - 1)%Z -
+     seq (inject_Q 0) (proj1_sig Hx + proj1_sig Hy - 1)%Z)%Q.
 Proof.
-  intros.
-  destruct H as [x0 H], H0 as [x1 H0]. unfold proj1_sig.
-  unfold inject_Q, proj1_sig, Qminus in H. rewrite Qplus_0_r in H.
-  pose proof (CRealLt_0_aboveSig x x0 H) as H1.
-  unfold inject_Q, proj1_sig, Qminus in H0. rewrite Qplus_0_r in H0.
-  pose proof (CRealLt_0_aboveSig y x1 H0) as H2.
-  destruct x as [xn limx], y as [yn limy]; simpl in H, H1, H2, H0.
-  unfold CReal_mult, inject_Q, proj1_sig.
-  remember (QCauchySeq_bound xn id) as Ax.
-  remember (QCauchySeq_bound yn id) as Ay.
-  unfold Qminus. rewrite Qplus_0_r.
-  specialize (H2 (2 * (Pos.max Ax Ay) * (2 * x0 * x1))%positive).
-  setoid_replace (2 # 2 * x0 * x1)%Q with ((1#x0) * (1#x1))%Q.
-  assert (x0 <= 2 * Pos.max Ax Ay * (2 * x0 * x1))%positive.
-  { apply (Pos.le_trans _ (2 * Pos.max Ax Ay * x0)).
-    apply belowMultiple. apply Pos.mul_le_mono_l.
-    rewrite (Pos.mul_comm 2 x0), <- Pos.mul_assoc, Pos.mul_comm.
-    apply belowMultiple. }
-  apply (Qlt_trans _ (xn (2 * Pos.max Ax Ay * (2 * x0 * x1))%positive * (1#x1))).
-  - apply Qmult_lt_compat_r. reflexivity. apply H1, H3.
-  - apply Qmult_lt_l.
-    apply (Qlt_trans _ (1#x0)). reflexivity. apply H1, H3.
-    apply H2. apply (Pos.le_trans _ (2 * Pos.max Ax Ay * x1)).
-    apply belowMultiple. apply Pos.mul_le_mono_l. apply belowMultiple.
-  - unfold Qeq, Qmult, Qnum, Qden.
-    rewrite Z.mul_1_l, <- Pos2Z.inj_mul. reflexivity.
+  intros x y Hx Hy.
+  destruct Hx as [nx Hx], Hy as [ny Hy]; unfold proj1_sig.
+  unfold inject_Q, Qminus in Hx. rewrite CReal_red_seq, Qplus_0_r in Hx.
+  unfold inject_Q, Qminus in Hy. rewrite CReal_red_seq, Qplus_0_r in Hy.
+
+  unfold CReal_mult, CReal_mult_seq, inject_Q; do 2 rewrite CReal_red_seq.
+  rewrite Qpower_minus_pos by lra.
+  rewrite Qpower_plus by lra.
+  simplify_Qlt.
+  do 2 simplify_seq_idx.
+  apply Qmult_lt_compat_nonneg.
+  - split.
+    + pose proof Qpower_pos_lt 2 nx; lra.
+    + pose proof CReal_scale_sep0_limit y ny Hy as Hlimy.
+      pose proof cauchy x nx nx (nx + ny - scale y - 2)%Z ltac:(lia) ltac:(lia) as Hbndx.
+      apply Qabs_Qlt_condition in Hbndx.
+      lra.
+  - split.
+    + pose proof Qpower_pos_lt 2 ny; lra.
+    + pose proof CReal_scale_sep0_limit x nx Hx as Hlimx.
+      pose proof cauchy y ny ny (nx + ny - scale x - 2)%Z ltac:(lia) ltac:(lia) as Hbndy.
+      apply Qabs_Qlt_condition in Hbndy.
+      lra.
 Qed.
 
 (* Strict inequality on CReal is in sort Type, for example
    used in the computation of division. *)
 Definition CReal_mult_lt_0_compat : forall x y : CReal,
     0 < x -> 0 < y -> 0 < x * y
-  := fun x y H H0 => exist _ (2 * proj1_sig H * proj1_sig H0)%positive
+  := fun x y Hx Hy => exist _ (proj1_sig Hx + proj1_sig Hy - 1)%Z
                         (CReal_mult_lt_0_compat_correct
-                           x y H H0).
-
-Lemma CReal_mult_bound_indep
-  : forall (x y : CReal) (A : positive)
-      (xbound : forall n : positive, (Qabs (proj1_sig x n) < Z.pos A # 1)%Q)
-      (ybound : forall n : positive, (Qabs (proj1_sig y n) < Z.pos A # 1)%Q),
-    x * y == exist _
-                   (fun n : positive => proj1_sig x (2 * A * n)%positive
-                                     * proj1_sig y (2 * A * n)%positive)%Q
-                   (CReal_mult_cauchy x y A xbound ybound).
-Proof.
-  intros. apply CRealEq_diff.
-  pose proof (CReal_mult_cauchy x y) as xycau. intro n.
-  destruct x as [xn caux], y as [yn cauy];
-    unfold CReal_mult, CReal_plus, proj1_sig; unfold proj1_sig in xycau.
-  pose proof (xycau A xbound ybound).
-  remember (QCauchySeq_bound xn id) as Ax.
-  remember (QCauchySeq_bound yn id) as Ay.
-  remember (Pos.max Ax Ay) as B.
-  setoid_replace (xn (2*B*n)%positive * yn (2*B*n)%positive
-                  - xn (2*A*n)%positive * yn (2*A*n)%positive)%Q
-    with ((xn (2*B*n)%positive - xn (2*A*n)%positive) * yn (2*B*n)%positive
-          + xn (2*A*n)%positive * (yn (2*B*n)%positive - yn (2*A*n)%positive))%Q.
-  2: ring.
-  apply (Qle_trans _ _ _ (Qabs_triangle _ _)).
-  rewrite Qabs_Qmult, Qabs_Qmult.
-  setoid_replace (2#n)%Q with ((1#n) + (1#n))%Q.
-  2: rewrite Qinv_plus_distr; reflexivity.
-  apply Qplus_le_compat.
-  - apply (Qle_trans _ ((1#2*Pos.min A B * n) * Qabs (yn (2*B*n)%positive))).
-    + apply Qmult_le_compat_r. apply Qlt_le_weak. apply caux.
-      apply Pos.mul_le_mono_r, Pos.mul_le_mono_l, Pos.le_min_r.
-      apply Pos.mul_le_mono_r, Pos.mul_le_mono_l, Pos.le_min_l.
-      apply Qabs_nonneg.
-    + unfold proj1_sig in ybound. clear xbound.
-      apply (Qmult_le_l _ _ (Z.pos (2*Pos.min A B *n) # 1)).
-      reflexivity. rewrite Qmult_assoc.
-      setoid_replace ((Z.pos (2 * Pos.min A B * n) # 1) * (1 # 2 * Pos.min A B * n))%Q
-        with 1%Q.
-      rewrite Qmult_1_l.
-      setoid_replace ((Z.pos (2 * Pos.min A B * n) # 1) * (1 # n))%Q
-        with (Z.pos (2 * Pos.min A B) # 1)%Q.
-      apply (Qle_trans _ (Z.pos (Pos.min A B) # 1)).
-      destruct (Pos.lt_total A B). rewrite Pos.min_l.
-      apply Qlt_le_weak, ybound. apply Pos.lt_le_incl, H0.
-      destruct H0. rewrite Pos.min_l.
-      apply Qlt_le_weak, ybound. rewrite H0. apply Pos.le_refl.
-      rewrite Pos.min_r. subst B. apply (Qle_trans _ (Z.pos Ay #1)). subst Ay.
-      apply Qlt_le_weak, (QCauchySeq_bounded_prop yn cauy).
-      unfold Qle, Qnum, Qden.
-      rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_max. apply Z.le_max_r.
-      apply Pos.lt_le_incl, H0.
-      unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-      apply Pos2Z.pos_le_pos. apply belowMultiple.
-      unfold Qeq, Qmult, Qnum, Qden.
-      rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_mul. reflexivity.
-      unfold Qeq, Qmult, Qnum, Qden.
-      rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_mul. reflexivity.
-  - rewrite Qmult_comm.
-    apply (Qle_trans _ ((1#2*Pos.min A B * n) * Qabs (xn (2*A*n)%positive))).
-    + apply Qmult_le_compat_r. apply Qlt_le_weak. apply cauy.
-      apply Pos.mul_le_mono_r, Pos.mul_le_mono_l, Pos.le_min_r.
-      apply Pos.mul_le_mono_r, Pos.mul_le_mono_l, Pos.le_min_l.
-      apply Qabs_nonneg.
-    + unfold proj1_sig in xbound. clear ybound.
-      apply (Qmult_le_l _ _ (Z.pos (2*Pos.min A B *n) # 1)).
-      reflexivity. rewrite Qmult_assoc.
-      setoid_replace ((Z.pos (2 * Pos.min A B * n) # 1) * (1 # 2 * Pos.min A B * n))%Q
-        with 1%Q.
-      rewrite Qmult_1_l.
-      setoid_replace ((Z.pos (2 * Pos.min A B * n) # 1) * (1 # n))%Q
-        with (Z.pos (2 * Pos.min A B) # 1)%Q.
-      apply (Qle_trans _ (Z.pos (Pos.min A B) # 1)).
-      destruct (Pos.lt_total A B). rewrite Pos.min_l.
-      apply Qlt_le_weak, xbound. apply Pos.lt_le_incl, H0.
-      destruct H0. rewrite Pos.min_l.
-      apply Qlt_le_weak, xbound. rewrite H0. apply Pos.le_refl.
-      rewrite Pos.min_r. subst B. apply (Qle_trans _ (Z.pos Ax #1)). subst Ax.
-      apply Qlt_le_weak, (QCauchySeq_bounded_prop xn caux).
-      unfold Qle, Qnum, Qden.
-      rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_max. apply Z.le_max_l.
-      apply Pos.lt_le_incl, H0.
-      unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-      apply Pos2Z.pos_le_pos. apply belowMultiple.
-      unfold Qeq, Qmult, Qnum, Qden.
-      rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_mul. reflexivity.
-      unfold Qeq, Qmult, Qnum, Qden.
-      rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_mul. reflexivity.
-Qed.
+                           x y Hx Hy).
 
 Lemma CReal_mult_plus_distr_l : forall r1 r2 r3 : CReal,
     r1 * (r2 + r3) == (r1 * r2) + (r1 * r3).
 Proof.
-  (* Use same bound, max of the 3 bounds for every product. *)
-  intros x y z.
-  remember (QCauchySeq_bound (proj1_sig x) id) as Ax.
-  remember (QCauchySeq_bound (proj1_sig y) id) as Ay.
-  remember (QCauchySeq_bound (proj1_sig z) id) as Az.
-  pose (Pos.max Ax (Pos.add Ay Az)) as B.
-  assert (forall n : positive, (Qabs (proj1_sig x n) < Z.pos B # 1)%Q) as xbound.
-  { intro n. subst B. apply (Qlt_le_trans _ (Z.pos Ax #1)).
-    rewrite HeqAx.
-    apply (QCauchySeq_bounded_prop (proj1_sig x)).
-    destruct x. exact q.
-    unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    apply Pos2Z.pos_le_pos. apply Pos.le_max_l. }
-  assert (forall n : positive, (Qlt (Qabs (proj1_sig (y+z) n)) (Z.pos B # 1)))
-    as sumbound.
-  { intro n. destruct y as [yn cauy], z as [zn cauz].
-    unfold CReal_plus, proj1_sig. rewrite Qred_correct.
-    subst B. apply (Qlt_le_trans _ ((Z.pos Ay#1) + (Z.pos Az#1))).
-    apply (Qle_lt_trans _ _ _ (Qabs_triangle _ _)).
-    apply Qplus_lt_le_compat. rewrite HeqAy.
-    unfold proj1_sig. apply (QCauchySeq_bounded_prop yn cauy).
-    rewrite HeqAz.
-    unfold proj1_sig. apply Qlt_le_weak, (QCauchySeq_bounded_prop zn cauz).
-    unfold Qplus, Qle, Qnum, Qden.
-    apply Pos2Z.pos_le_pos. simpl. repeat rewrite Pos.mul_1_r.
-    apply Pos.le_max_r. }
-  rewrite (CReal_mult_bound_indep x (y+z) B xbound sumbound).
-  assert (forall n : positive, (Qabs (proj1_sig y n) < Z.pos B # 1)%Q) as ybound.
-  { intro n. subst B. apply (Qlt_le_trans _ (Z.pos Ay #1)).
-    rewrite HeqAy.
-    apply (QCauchySeq_bounded_prop (proj1_sig y)).
-    destruct y; exact q.
-    unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (Ay + Az)).
-    apply Pos2Nat.inj_le. rewrite <- (Nat.add_0_r (Pos.to_nat Ay)).
-    rewrite Pos2Nat.inj_add. apply Nat.add_le_mono_l, le_0_n.
-    apply Pos.le_max_r. }
-  rewrite (CReal_mult_bound_indep x y B xbound ybound).
-  assert (forall n : positive, (Qabs (proj1_sig z n) < Z.pos B # 1)%Q) as zbound.
-  { intro n. subst B. apply (Qlt_le_trans _ (Z.pos Az #1)).
-    rewrite HeqAz.
-    apply (QCauchySeq_bounded_prop (proj1_sig z)).
-    destruct z; exact q.
-    unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (Ay + Az)).
-    apply Pos2Nat.inj_le. rewrite <- (Nat.add_0_l (Pos.to_nat Az)).
-    rewrite Pos2Nat.inj_add. apply Nat.add_le_mono_r, le_0_n.
-    apply Pos.le_max_r. }
-  rewrite (CReal_mult_bound_indep x z B xbound zbound).
-  apply CRealEq_diff.
-  pose proof (CReal_mult_cauchy x y) as xycau. intro n.
-  destruct x as [xn caux], y as [yn cauy], z as [zn cauz];
-    unfold CReal_mult, CReal_plus, proj1_sig; unfold proj1_sig in xycau.
-  rewrite Qred_correct, Qred_correct.
-  assert (forall a b c d e : Q,
-             c * (d + e) - (a+b) == c*d-a + (c*e-b))%Q.
-  { intros. ring. }
-  rewrite H. clear H.
-  setoid_replace (2#n)%Q with ((1#n) + (1#n))%Q.
-  2: rewrite Qinv_plus_distr; reflexivity.
-  apply (Qle_trans _ _ _ (Qabs_triangle _ _)).
-  apply Qplus_le_compat.
-  - rewrite Qabs_Qminus.
-    replace (2 * B * (2 * n))%positive with (2 * (2 * B * n))%positive.
-    setoid_replace (xn (2 * (2 * B * n))%positive * yn (2 * (2 * B * n))%positive -
-                    xn (2 * B * n)%positive * yn (2 * (2 * B * n))%positive)%Q
-      with ((xn (2 * (2 * B * n))%positive - xn (2 * B * n)%positive)
-            * yn (2 * (2 * B * n))%positive)%Q.
-    2: ring. rewrite Qabs_Qmult.
-    apply (Qle_trans _ ((1 # 2*B*n) * Qabs (yn (2 * (2 * B * n))%positive))).
-    apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
-    apply Qlt_le_weak, caux. apply belowMultiple. apply Pos.le_refl.
-    apply (Qmult_le_l _ _ (Z.pos (2* B *n) # 1)).
-    reflexivity. rewrite Qmult_assoc.
-    setoid_replace ((Z.pos (2 * B * n) # 1) * (1 # 2 * B * n))%Q
-      with 1%Q.
-    rewrite Qmult_1_l.
-    setoid_replace ((Z.pos (2 * B * n) # 1) * (1 # n))%Q
-      with (Z.pos (2 * B) # 1)%Q.
-    apply (Qle_trans _ (Z.pos B # 1)).
-    apply Qlt_le_weak, ybound.
-    unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    apply Pos2Z.pos_le_pos. apply belowMultiple.
-    unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    rewrite Pos2Z.inj_mul. reflexivity.
-    unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    rewrite Pos2Z.inj_mul. reflexivity.
-    rewrite <- (Pos.mul_assoc 2 B (2*n)%positive).
-    apply f_equal. rewrite Pos.mul_assoc, (Pos.mul_comm 2 B). reflexivity.
-  - rewrite Qabs_Qminus.
-    replace (2 * B * (2 * n))%positive with (2 * (2 * B * n))%positive.
-    setoid_replace (xn (2 * (2 * B * n))%positive * zn (2 * (2 * B * n))%positive -
-                    xn (2 * B * n)%positive * zn (2 * (2 * B * n))%positive)%Q
-      with ((xn (2 * (2 * B * n))%positive - xn (2 * B * n)%positive)
-            * zn (2 * (2 * B * n))%positive)%Q.
-    2: ring. rewrite Qabs_Qmult.
-    apply (Qle_trans _ ((1 # 2*B*n) * Qabs (zn (2 * (2 * B * n))%positive))).
-    apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
-    apply Qlt_le_weak, caux. apply belowMultiple. apply Pos.le_refl.
-    apply (Qmult_le_l _ _ (Z.pos (2* B *n) # 1)).
-    reflexivity. rewrite Qmult_assoc.
-    setoid_replace ((Z.pos (2 * B * n) # 1) * (1 # 2 * B * n))%Q
-      with 1%Q.
-    rewrite Qmult_1_l.
-    setoid_replace ((Z.pos (2 * B * n) # 1) * (1 # n))%Q
-      with (Z.pos (2 * B) # 1)%Q.
-    apply (Qle_trans _ (Z.pos B # 1)).
-    apply Qlt_le_weak, zbound.
-    unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    apply Pos2Z.pos_le_pos. apply belowMultiple.
-    unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    rewrite Pos2Z.inj_mul. reflexivity.
-    unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    rewrite Pos2Z.inj_mul. reflexivity.
-    rewrite <- (Pos.mul_assoc 2 B (2*n)%positive).
-    apply f_equal. rewrite Pos.mul_assoc, (Pos.mul_comm 2 B). reflexivity.
+  intros x y z; apply CRealEq_diff; intros n.
+  unfold CReal_mult, CReal_mult_seq, CReal_mult_scale, CReal_plus, CReal_plus_seq, CReal_plus_scale.
+  do 5 rewrite CReal_red_seq.
+  do 1 rewrite CReal_red_scale.
+  do 2 rewrite Qred_correct.
+  do 5 simplify_seq_idx.
+  simplify_Qabs.
+  assert (forall y' z': CReal,
+    Qabs (
+      seq x (n - Z.max (scale y') (scale z') - 2) * seq y' (n - scale x - 2)
+    - seq x (n - scale y' - 2) * seq y' (n - scale x - 2))
+  <= 2 ^ n )%Q as Hdiffbnd.
+  {
+    intros y' z'.
+    assert (forall a b c : Q, a*c-b*c==(a-b)*c)%Q as H by (intros; ring).
+    rewrite H; clear H.
+    pose proof cauchy x (n - (scale y') - 2)%Z (n - Z.max (scale y') (scale z') - 2)%Z (n - scale y' - 2)%Z
+      ltac:(lia) ltac:(lia) as Hxbnd.
+    pose proof bound y' (n - scale x - 2)%Z as Hybnd.
+    replace n with ((n - scale y' - 2) + scale y' + 2)%Z at 4 by lia.
+    apply Weaken_Qle_QpowerAddExp.
+      lia.
+    rewrite Qpower_plus, Qabs_Qmult by lra.
+    apply Qmult_le_compat_nonneg; (split; [apply Qabs_nonneg | lra]).
+  }
+  pose proof Hdiffbnd y z as Hyz.
+  pose proof Hdiffbnd z y as Hzy; clear Hdiffbnd.
+  pose proof Qplus_le_compat _ _ _ _ Hyz Hzy as Hcomb; clear Hyz Hzy.
+  apply (Qle_trans _ _ _ (Qabs_triangle _ _)) in Hcomb.
+  rewrite (Z.max_comm (scale z) (scale y)) in Hcomb .
+  rewrite Qabs_Qle_condition in Hcomb |- *.
+  lra.
 Qed.
 
 Lemma CReal_mult_plus_distr_r : forall r1 r2 r3 : CReal,
@@ -492,189 +339,87 @@ Proof.
   apply CReal_mult_proper_l, H.
 Qed.
 
-Lemma CReal_mult_assoc : forall x y z : CReal, (x * y) * z == x * (y * z).
+Lemma CReal_mult_assoc : forall x y z : CReal,
+  (x * y) * z == x * (y * z).
 Proof.
-  intros.
-  remember (QCauchySeq_bound (proj1_sig x) id) as Ax.
-  remember (QCauchySeq_bound (proj1_sig y) id) as Ay.
-  remember (QCauchySeq_bound (proj1_sig z) id) as Az.
-  pose (Pos.add (Ax * Ay) (Ay * Az)) as B.
-  assert (forall n : positive, (Qabs (proj1_sig x n) < Z.pos B # 1)%Q) as xbound.
-  { intro n.
-    destruct x as [xn limx]; unfold CReal_mult, proj1_sig.
-    apply (Qlt_le_trans _ (Z.pos Ax#1)).
-    rewrite HeqAx.
-    apply (QCauchySeq_bounded_prop xn limx).
-    subst B. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (Ax*Ay)).
-    rewrite Pos.mul_comm. apply belowMultiple.
-    apply Pos.lt_le_incl, Pos.lt_add_r. }
-  assert (forall n : positive, (Qabs (proj1_sig y n) < Z.pos B # 1)%Q) as ybound.
-  { intro n.
-    destruct y as [xn limx]; unfold CReal_mult, proj1_sig.
-    apply (Qlt_le_trans _ (Z.pos Ay#1)).
-    rewrite HeqAy.
-    apply (QCauchySeq_bounded_prop xn limx).
-    subst B. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (Ax*Ay)).
-    apply belowMultiple. apply Pos.lt_le_incl, Pos.lt_add_r. }
-  assert (forall n : positive, (Qabs (proj1_sig z n) < Z.pos B # 1)%Q) as zbound.
-  { intro n.
-    destruct z as [xn limx]; unfold CReal_mult, proj1_sig.
-    apply (Qlt_le_trans _ (Z.pos Az#1)).
-    rewrite HeqAz.
-    apply (QCauchySeq_bounded_prop xn limx).
-    subst B. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
-    apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (Ay*Az)).
-    apply belowMultiple. rewrite Pos.add_comm.
-    apply Pos.lt_le_incl, Pos.lt_add_r. }
-  pose (exist (fun x0 : positive -> Q => QCauchySeq x0)
-    (fun n : positive =>
-     (proj1_sig x (2 * B * n)%positive * proj1_sig y (2 * B * n)%positive)%Q)
-    (CReal_mult_cauchy x y B xbound ybound)) as xy.
-  rewrite (CReal_mult_proper_r
-             z (x*y) xy
-             (CReal_mult_bound_indep x y B xbound ybound)).
-  pose (exist (fun x0 : positive -> Q => QCauchySeq x0)
-    (fun n : positive =>
-     (proj1_sig y (2 * B * n)%positive * proj1_sig z (2 * B * n)%positive)%Q)
-    (CReal_mult_cauchy y z B ybound zbound)) as yz.
-  rewrite (CReal_mult_proper_l
-             x (y*z) yz
-             (CReal_mult_bound_indep y z B ybound zbound)).
-  assert (forall n : positive, (Qabs (proj1_sig xy n) < Z.pos B # 1)%Q) as xybound.
-  { intro n. unfold xy, proj1_sig. clear xy yz.
-    destruct x as [xn limx], y as [yn limy]; unfold CReal_mult, proj1_sig.
-    rewrite Qabs_Qmult.
-    apply (Qle_lt_trans _ ((Z.pos Ax#1) * (Qabs (yn (2 * B * n)%positive)))).
-    apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
-    rewrite HeqAx.
-    apply Qlt_le_weak, (QCauchySeq_bounded_prop xn limx).
-    rewrite Qmult_comm.
-    apply (Qle_lt_trans _ ((Z.pos Ay#1) * (Z.pos Ax#1))).
-    apply Qmult_le_compat_r. 2: discriminate. rewrite HeqAy.
-    apply Qlt_le_weak, (QCauchySeq_bounded_prop yn limy).
-    subst B. unfold Qmult, Qlt, Qnum, Qden.
-    rewrite Pos.mul_1_r, Z.mul_1_r, Z.mul_1_r, <- Pos2Z.inj_mul.
-    apply Pos2Z.pos_lt_pos. rewrite Pos.mul_comm. apply Pos.lt_add_r. }
-  rewrite (CReal_mult_bound_indep _ z B xybound zbound).
-  assert (forall n : positive, (Qabs (proj1_sig yz n) < Z.pos B # 1)%Q) as yzbound.
-  { intro n. unfold yz, proj1_sig. clear xybound xy yz.
-    destruct z as [zn limz], y as [yn limy]; unfold CReal_mult, proj1_sig.
-    rewrite Qabs_Qmult.
-    apply (Qle_lt_trans _ ((Z.pos Ay#1) * (Qabs (zn (2 * B * n)%positive)))).
-    apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
-    rewrite HeqAy.
-    apply Qlt_le_weak, (QCauchySeq_bounded_prop yn limy).
-    rewrite Qmult_comm.
-    apply (Qle_lt_trans _ ((Z.pos Az#1) * (Z.pos Ay#1))).
-    apply Qmult_le_compat_r. 2: discriminate. rewrite HeqAz.
-    apply Qlt_le_weak, (QCauchySeq_bounded_prop zn limz).
-    subst B. unfold Qmult, Qlt, Qnum, Qden.
-    rewrite Pos.mul_1_r, Z.mul_1_r, Z.mul_1_r, <- Pos2Z.inj_mul.
-    apply Pos2Z.pos_lt_pos. rewrite Pos.add_comm, Pos.mul_comm.
-    apply Pos.lt_add_r. }
-  rewrite (CReal_mult_bound_indep x yz B xbound yzbound).
-  apply CRealEq_diff. intro n. unfold proj1_sig, xy, yz.
-  destruct x as [xn limx], y as [yn limy], z as [zn limz];
-    unfold CReal_mult, proj1_sig.
-  clear xybound yzbound xy yz.
-  assert (forall a b c d e : Q, a*b*c - d*(b*e) == b*(a*c - d*e))%Q.
-  { intros. ring. }
-  rewrite H. clear H. rewrite Qabs_Qmult, Qmult_comm.
-  setoid_replace (xn (2 * B * (2 * B * n))%positive * zn (2 * B * n)%positive -
-                  xn (2 * B * n)%positive * zn (2 * B * (2 * B * n))%positive)%Q
-    with ((xn (2 * B * (2 * B * n))%positive - xn (2 * B * n)%positive)
-          * zn (2 * B * n)%positive
-          + xn (2 * B * n)%positive *
-            (zn (2*B*n)%positive - zn (2 * B * (2 * B * n))%positive))%Q.
-  2: ring.
-  apply (Qle_trans _ ( (Qabs ((1 # (2 * B * n)) * zn (2 * B * n)%positive)
-                        + Qabs (xn (2 * B * n)%positive * (1 # (2 * B * n))))
-        * Qabs (yn (2 * B * (2 * B * n))%positive))).
-  apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
+  intros x y z; apply CRealEq_diff; intros n.
+
+  (* Expand and simplify the goal *)
+  unfold CReal_mult, CReal_mult_seq, CReal_mult_scale.
+  do 4 rewrite CReal_red_seq.
+  do 2 rewrite CReal_red_scale.
+  do 6 simplify_seq_idx.
+  (* Todo: it is a bug in ring_simplify that the scales are not sorted *)
+  replace (n - scale z - scale y)%Z with (n - scale y - scale z)%Z by ring.
+  replace (n - scale z - scale x)%Z with (n - scale x - scale z)%Z by ring.
+  simplify_Qabs.
+
+  (* Rearrange the goal such that it used only scale and cauchy bounds *)
+  (* Todo: it is also a bug in ring_simplify that the seq terms are not sorted by the first variable *)
+  assert (forall a1 a2 b c1 c2 : Q, a1*b*c1+(-1)*b*a2*c2==(a1*c1-a2*c2)*b)%Q as H by (intros; ring).
+  rewrite H; clear H.
+  remember (seq x (n - scale y - scale z - 1) - seq x (n - scale y - scale z - 2))%Q as dx eqn:Heqdx.
+  remember (seq z (n - scale x - scale y - 1) - seq z (n - scale x - scale y - 2))%Q as dz eqn:Heqdz.
+  setoid_replace (seq x (n - scale y - scale z - 1)) with (seq x (n - scale y - scale z - 2) + dx)%Q
+    by (rewrite Heqdx; ring).
+  setoid_replace (seq z (n - scale x - scale y - 1)) with (seq z (n - scale x - scale y - 2) + dz)%Q
+    by (rewrite Heqdz; ring).
+  match goal with |- (Qabs (?a * _) <= _)%Q => ring_simplify a end.
+
+  (* Now pose the scale and cauchy bounds we need to prove this, so that we see how to split the deviation budget *)
+  pose proof bound x (n - scale y - scale z - 2)%Z as Hbndx.
+  pose proof bound z (n - scale x - scale y - 2)%Z as Hbndz.
+  pose proof bound y (n - scale x - scale z - 2)%Z as Hbndy.
+  pose proof cauchy x (n - scale y - scale z - 1)%Z (n - scale y - scale z - 1)%Z (n - scale y - scale z - 2)%Z
+    ltac:(lia) ltac:(lia) as Hbnddx; rewrite <- Heqdx in Hbnddx; clear Heqdx.
+  pose proof cauchy z (n - scale x - scale y - 1)%Z (n - scale x - scale y - 1)%Z (n - scale x - scale y - 2)%Z
+    ltac:(lia) ltac:(lia) as Hbnddz; rewrite <- Heqdz in Hbnddz; clear Heqdz.
+
+  (* The rest is elementary arithmetic ... *)
+  rewrite Qabs_Qmult.
+  replace n with ((n - scale y) + scale y)%Z at 4 by lia.
+  rewrite Qpower_plus by lra.
+  rewrite Qmult_assoc.
+  apply Qmult_le_compat_nonneg.
+    2: (split; [apply Qabs_nonneg | lra]).
+
+  split; [apply Qabs_nonneg|].
   apply (Qle_trans _ _ _ (Qabs_triangle _ _)).
+  setoid_replace (2 * 2 ^ (n - scale y))%Q with (2 ^ (n - scale y) + 2 ^ (n - scale y))%Q by ring.
   apply Qplus_le_compat.
-  rewrite Qabs_Qmult, Qabs_Qmult.
-  apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
-  apply Qlt_le_weak, limx. apply belowMultiple. apply Pos.le_refl.
-  rewrite Qabs_Qmult, Qabs_Qmult, Qmult_comm, <- (Qmult_comm (Qabs (1 # 2 * B * n))).
-  apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
-  apply Qlt_le_weak, limz. apply Pos.le_refl. apply belowMultiple.
-  rewrite Qabs_Qmult, Qabs_Qmult.
-  rewrite (Qmult_comm (Qabs (1 # 2 * B * n))).
-  rewrite <- Qmult_plus_distr_l.
-  rewrite (Qabs_pos (1 # 2 * B * n)). 2: discriminate.
-  rewrite <- (Qmult_comm (1 # 2 * B * n)), <- Qmult_assoc.
-  apply (Qmult_le_l _ _ (Z.pos (2* B *n) # 1)).
-  reflexivity. rewrite Qmult_assoc.
-  setoid_replace ((Z.pos (2 * B * n) # 1) * (1 # 2 * B * n))%Q
-    with 1%Q.
-  rewrite Qmult_1_l.
-  setoid_replace ((Z.pos (2 * B * n) # 1) * (2 # n))%Q
-    with (Z.pos (2 * 2 * B) # 1)%Q.
-  apply (Qle_trans _ (((Z.pos Az#1) + (Z.pos Ax#1)) *
-                      Qabs (yn (2 * B * (2 * B * n))%positive))).
-  apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
-  apply Qplus_le_compat. rewrite HeqAz.
-  apply Qlt_le_weak, (QCauchySeq_bounded_prop zn limz).
-  rewrite HeqAx.
-  apply Qlt_le_weak, (QCauchySeq_bounded_prop xn limx).
-  rewrite Qmult_comm.
-  apply (Qle_trans _ ((Z.pos Ay#1)* ((Z.pos Az # 1) + (Z.pos Ax # 1)))).
-  apply Qmult_le_compat_r.
-  rewrite HeqAy.
-  apply Qlt_le_weak, (QCauchySeq_bounded_prop yn limy). discriminate.
-  rewrite Qinv_plus_distr. subst B.
-  unfold Qle, Qmult, Qplus, Qnum, Qden.
-  repeat rewrite Pos.mul_1_r. repeat rewrite Z.mul_1_r.
-  rewrite <- Pos2Z.inj_add, <- Pos2Z.inj_mul.
-  apply Pos2Z.pos_le_pos. rewrite Pos.mul_add_distr_l.
-  rewrite Pos.add_comm, Pos.mul_comm. apply belowMultiple.
-  unfold Qeq, Qmult, Qnum, Qden.
-  simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_comm. reflexivity.
-  unfold Qeq, Qmult, Qnum, Qden.
-  simpl. rewrite Pos.mul_1_r, Pos.mul_1_r. reflexivity.
+  - rewrite Qabs_Qmult.
+    replace (n - scale y)%Z with (scale x + (n - scale x - scale y))%Z at 2 by lia.
+    rewrite Qpower_plus by lra.
+    apply Qmult_le_compat_nonneg.
+    + (split; [apply Qabs_nonneg | lra]).
+    + split; [apply Qabs_nonneg|].
+      apply (Weaken_Qle_QpowerRemSubExp _ _ 1 ltac:(lia)), Qlt_le_weak, Hbnddz.
+  - rewrite Qabs_Qmult.
+    replace (n - scale y)%Z with (scale z + (n - scale y - scale z))%Z by lia.
+    rewrite Qpower_plus by lra.
+    apply Qmult_le_compat_nonneg.
+    + split; [apply Qabs_nonneg|].
+      rewrite <- Qabs_opp; simplify_Qabs; lra.
+    + split; [apply Qabs_nonneg|].
+      apply (Weaken_Qle_QpowerRemSubExp _ _ 1 ltac:(lia)), Qlt_le_weak, Hbnddx.
 Qed.
 
-
-Lemma CReal_mult_1_l : forall r: CReal, 1 * r == r.
+Lemma CReal_mult_1_l : forall r: CReal,
+  1 * r == r.
 Proof.
-  intros [rn limr]. split.
-  - intros [m maj]. simpl in maj.
-    rewrite Qmult_1_l in maj.
-    pose proof (QCauchySeq_bounded_prop (fun _ : positive => 1%Q) (ConstCauchy 1)).
-    pose proof (QCauchySeq_bounded_prop rn limr).
-    remember (QCauchySeq_bound (fun _ : positive => 1%Q) id) as x.
-    remember (QCauchySeq_bound rn id) as x0.
-    specialize (limr m).
-    apply (Qlt_not_le (2 # m) (1 # m)).
-    apply (Qlt_trans _ (rn m
-                        - rn ((Pos.max x x0)~0 * m)%positive)).
-    apply maj.
-    apply (Qle_lt_trans _ (Qabs (rn m - rn ((Pos.max x x0)~0 * m)%positive))).
-    apply Qle_Qabs. apply limr. apply Pos.le_refl.
-    rewrite <- (Pos.mul_1_l m). rewrite Pos.mul_assoc. unfold id.
-    apply Pos.mul_le_mono_r. discriminate.
-    apply Z.mul_le_mono_nonneg. discriminate. discriminate.
-    discriminate. apply Z.le_refl.
-  - intros [m maj]. simpl in maj.
-    pose proof (QCauchySeq_bounded_prop (fun _ : positive => 1%Q) (ConstCauchy 1)).
-    pose proof (QCauchySeq_bounded_prop rn limr).
-    remember (QCauchySeq_bound (fun _ : positive => 1%Q) id) as x.
-    remember (QCauchySeq_bound rn id) as x0.
-    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.max x x0)~0 * m)%positive - rn m)).
-    apply maj.
-    apply (Qle_lt_trans _ (Qabs (rn ((Pos.max x x0)~0 * m)%positive - rn m))).
-    apply Qle_Qabs. apply limr.
-    rewrite <- (Pos.mul_1_l m). rewrite Pos.mul_assoc. unfold id.
-    apply Pos.mul_le_mono_r. discriminate.
-    apply Pos.le_refl.
-    apply Z.mul_le_mono_nonneg. discriminate. discriminate.
-    discriminate. apply Z.le_refl.
+  intros r; apply CRealEq_diff; intros n.
+
+  unfold inject_Q, CReal_mult, CReal_mult_seq, CReal_mult_scale.
+  do 2 rewrite CReal_red_seq.
+  do 1 rewrite CReal_red_scale.
+  change (Qbound_ltabs_ZExp2 1)%Z with 1%Z.
+  do 1 simplify_seq_idx.
+  simplify_Qabs.
+
+  pose proof cauchy r n (n-2)%Z n ltac:(lia) ltac:(lia) as Hrbnd.
+  apply Qabs_Qlt_condition in Hrbnd.
+  apply Qabs_Qle_condition.
+  lra.
 Qed.
 
 Lemma CReal_isRingExt : ring_eq_ext CReal_plus CReal_mult CReal_opp CRealEq.
@@ -812,204 +557,183 @@ Proof.
     exact (CRealLe_refl _ abs). exact c.
 Qed.
 
-Lemma CReal_abs_appart_zero : forall (x : CReal) (n : positive),
-    Qlt (2#n) (Qabs (proj1_sig x n))
+Lemma CReal_abs_appart_zero : forall (x : CReal) (n : Z),
+    (2*2^n < Qabs (seq x n))%Q
     -> 0 # x.
 Proof.
-  intros. destruct x as [xn xcau]. simpl in H.
-  destruct (Qlt_le_dec 0 (xn n)).
-  - left. exists n; simpl. rewrite Qabs_pos in H.
-    ring_simplify. exact H. apply Qlt_le_weak. exact q.
-  - right. exists n; simpl. rewrite Qabs_neg in H.
-    unfold Qminus. rewrite Qplus_0_l. exact H. exact q.
+  intros x n Hapart.
+  unfold CReal_appart.
+  destruct (Qlt_le_dec 0 (seq x n)).
+  - left; exists n; cbn.
+    rewrite Qabs_pos in Hapart; lra.
+  - right; exists n; cbn.
+    rewrite Qabs_neg in Hapart; lra.
 Qed.
 
-
 (*********************************************************)
 (** * Field                                              *)
 (*********************************************************)
 
 Lemma CRealArchimedean
-  : forall x:CReal, { n:Z  &  x < inject_Q (n#1) < x+2 }.
+  : forall x:CReal, { n:Z  &  x < inject_Z 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%positive + (1#4))). unfold inject_Z in H.
-  pose proof (Qfloor_le (xn 4%positive + (1#4))). unfold inject_Z in H0.
-  remember (Qfloor (xn 4%positive + (1#4)))%Z as n.
-  exists (n+1)%Z. split.
-  - assert (Qlt 0 ((n + 1 # 1) - (xn 4%positive + (1 # 4)))) as epsPos.
-    { unfold Qminus. rewrite <- Qlt_minus_iff. exact H. }
-    destruct (Qarchimedean (/((1#2)*((n + 1 # 1) - (xn 4%positive + (1 # 4)))))) as [k kmaj].
-    exists (Pos.max 4 k). simpl.
-    apply (Qlt_trans _ ((n + 1 # 1) - (xn 4%positive + (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.max 4 k) - (n + 1 # 1) + (1#4))).
-      ring_simplify.
-      apply (Qle_lt_trans _ (Qabs (xn (Pos.max 4 k) - xn 4%positive))).
-      apply Qle_Qabs. apply limx.
-      apply Pos.le_max_l. apply Pos.le_refl.
-  - apply (CReal_plus_lt_reg_l (-(2))). ring_simplify.
-    exists 4%positive. unfold inject_Q, CReal_minus, CReal_plus, proj1_sig.
-    rewrite Qred_correct. simpl.
-    rewrite <- Qinv_plus_distr.
-    rewrite <- (Qplus_lt_r _ _ ((n#1) - (1#2))). ring_simplify.
-    apply (Qle_lt_trans _ (xn 4%positive + (1 # 4)) _ H0).
-    unfold Pos.to_nat; simpl.
-    rewrite <- (Qplus_lt_r _ _ (-xn 4%positive)). ring_simplify.
-    reflexivity.
-Defined.
+  intros x.
+  (* We add 3/2: 1/2 for the average rounding of floor + 1 to center in the interval.
+     This gives a margin of 1/2 in each inequality.
+     Since we need margin for Qlt of 2*2^-n plus 2^-n for the real addition, we need n=-3 *)
+  remember (seq x (-3)%Z + (3#2))%Q as q eqn: Heqq.
+  pose proof (Qlt_floor q) as Hltfloor; unfold QArith_base.inject_Z in Hltfloor.
+  pose proof (Qfloor_le q) as Hfloorle; unfold QArith_base.inject_Z in Hfloorle.
+  exists (Qfloor q); split.
+  - unfold inject_Z, inject_Q, CRealLt. rewrite CReal_red_seq.
+    exists (-3)%Z.
+    setoid_replace (2 * 2 ^ (-3))%Q with (1#4)%Q by reflexivity.
+    subst q; rewrite <- Qinv_plus_distr in Hltfloor.
+    lra.
+  - unfold inject_Z, inject_Q, CReal_plus, CReal_plus_seq, CRealLt. do 3 rewrite CReal_red_seq.
+    exists (-3)%Z.
+    setoid_replace (2 * 2 ^ (-3))%Q with (1#4)%Q by reflexivity.
+    simplify_seq_idx; rewrite Qred_correct.
+    pose proof cauchy x (-3)%Z (-3)%Z (-4)%Z ltac:(lia) ltac:(lia) as Hbnddx.
+    rewrite Qabs_Qlt_condition in Hbnddx.
+    setoid_replace (2 ^ (-3))%Q with (1#8)%Q in Hbnddx by reflexivity.
+    subst q; rewrite <- Qinv_plus_distr in Hltfloor.
+    lra.
+Qed.
 
-Definition Rup_pos (x : CReal)
-  : { n : positive  &  x < inject_Q (Z.pos n # 1) }.
+(* ToDo: This is not efficient.
+   We take the n for the 2^n lower bound fro x>0.
+   This limit can be arbitrarily small and far away from beeing tight.
+   To make this really computational, we need to compute a tight
+   limit starting from scale x and going down in steps of say 16 bits,
+   something which is still easy to compute but likely to succeed. *)
+
+Definition CRealLowerBound (x : CReal) (xPos : 0<x) : Z :=
+  proj1_sig (xPos).
+
+Lemma CRealLowerBoundSpec: forall (x : CReal) (xPos : 0<x),
+    forall p : Z, (p <= (CRealLowerBound x xPos))%Z
+ -> (seq x p > 2^(CRealLowerBound x xPos))%Q.
 Proof.
-  intros. destruct (CRealArchimedean x) as [p [maj _]].
-  destruct p.
-  - exists 1%positive. apply (CReal_lt_trans _ 0 _ maj). apply CRealLt_0_1.
-  - exists p. exact maj.
-  - exists 1%positive. apply (CReal_lt_trans _ (inject_Q (Z.neg p # 1)) _ maj).
-    apply (CReal_lt_trans _ 0). apply inject_Q_lt. reflexivity.
-    apply CRealLt_0_1.
+  intros x xPos p Hp.
+  unfold CRealLowerBound in *.
+  destruct xPos as [n Hn]; unfold proj1_sig in *.
+  unfold inject_Q in Hn; rewrite CReal_red_seq in Hn.
+  ring_simplify in Hn.
+  pose proof cauchy x n n p ltac:(lia) ltac:(lia) as Hxbnd.
+  rewrite Qabs_Qlt_condition in Hxbnd.
+  lra.
 Qed.
 
-Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal,
-    (CRealLtProp a b \/ CRealLtProp c d) -> CRealLt a b  +  CRealLt c d.
+Lemma CRealLowerBound_lt_scale: forall (r : CReal) (Hrpos : 0 < r),
+    (CRealLowerBound r Hrpos < scale r)%Z.
 Proof.
-  intros.
-  (* Convert to nat to use indefinite description. *)
-  assert (exists n : nat, n <> O /\
-             (Qlt (2 # Pos.of_nat n) (proj1_sig b (Pos.of_nat n) - proj1_sig a (Pos.of_nat n))
-              \/ Qlt (2 # Pos.of_nat n) (proj1_sig d (Pos.of_nat n) - proj1_sig c (Pos.of_nat 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 (Pos.of_nat n) - proj1_sig a (Pos.of_nat n))).
-    left. exists (Pos.of_nat n). apply q.
-    assert (2 # Pos.of_nat n < proj1_sig d (Pos.of_nat n) - proj1_sig c (Pos.of_nat n))%Q.
-    destruct maj. exfalso.
-    apply (Qlt_not_le (2 # Pos.of_nat n) (proj1_sig b (Pos.of_nat n) - proj1_sig a (Pos.of_nat n))); assumption.
-    assumption. clear maj. right. exists (Pos.of_nat n).
-    apply H0.
-  - 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 (Pos.of_nat (S n)) - proj1_sig a (Pos.of_nat (S n)))).
-    left. split. discriminate. left. apply q.
-    destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig d (Pos.of_nat (S n)) - proj1_sig c (Pos.of_nat (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 (Pos.of_nat (S n)) - proj1_sig a (Pos.of_nat (S n)))); assumption.
-    apply (Qlt_not_le (2 # Pos.of_nat (S n))
-                      (proj1_sig d (Pos.of_nat (S n)) - proj1_sig c (Pos.of_nat (S n)))); assumption.
+  intros r Hrpos.
+  pose proof CRealLowerBoundSpec r Hrpos (CRealLowerBound r Hrpos) ltac:(lia) as Hlow.
+  pose proof bound r (CRealLowerBound r Hrpos) as Hup; unfold QBound in Hup.
+  apply Qabs_Qlt_condition in Hup. destruct Hup as [_ Hup].
+  pose proof Qlt_trans _ _ _ Hlow Hup as Hpow.
+  apply Qpower_lt_compat_inv in Hpow.
+    2: lra.
+  exact Hpow.
 Qed.
 
-(* Find a positive index after which the Cauchy sequence proj1_sig x
-   stays above 0, so that it can be inverted. *)
-Lemma CRealPosShift_correct
-  : forall (x : CReal) (xPos : 0 < x) (n : positive),
-    Pos.le (proj1_sig xPos) n
-    -> Qlt (1 # proj1_sig xPos) (proj1_sig x n).
+(**
+Note on the convergence modulus for x when computing 1/x:
+Thinking in terms of absolute and relative errors and scales we get:
+- 2^n is absolute error of 1/x (the requested error)
+- 2^k is a lower bound of x -> 2^-k is an upper bound of 1/x
+For simplicity lets’ say 2^k is the scale of x and 2^-k is the scale of 1/x.
+
+With this we get:
+- relative error of 1/x = absolute error of 1/x / scale of 1/x = 2^n / 2^-k = 2^(n+k)
+- 1/x maintains relative error
+- relative error of x = relative error 1/x = 2^(n+k)
+- absolute error of x = relative error x * scale of x = 2^(n+k) * 2^k
+- absolute error of x = 2^(n+2*k)
+*)
+
+Definition CReal_inv_pos_cm (x : CReal) (xPos : 0 < x) (n : Z):=
+  (Z.min (CRealLowerBound x xPos) (n + 2 * (CRealLowerBound x xPos)))%Z.
+
+Definition CReal_inv_pos_seq (x : CReal) (xPos : 0 < x) (n : Z) :=
+  (/ seq x (CReal_inv_pos_cm x xPos n))%Q.
+
+Definition CReal_inv_pos_scale (x : CReal) (xPos : 0 < x) : Z :=
+  (- (CRealLowerBound x xPos))%Z.
+
+Lemma CReal_inv_pos_cauchy: forall (x : CReal) (xPos : 0 < x),
+    QCauchySeq (CReal_inv_pos_seq x xPos).
 Proof.
-  intros x xPos p pmaj.
-  destruct xPos as [n maj]; simpl in maj.
-  apply (CRealLt_0_aboveSig x n).
-  unfold proj1_sig in pmaj.
-  apply (Qlt_le_trans _ _ _ maj).
-  ring_simplify. apply Qle_refl. apply pmaj.
+  intros x Hxpos n p q Hp Hq; unfold CReal_inv_pos_seq.
+  unfold CReal_inv_pos_cm; remember (CRealLowerBound x Hxpos) as k.
+
+  (* These auxilliary lemmas are required a few times below *)
+  assert (forall m:Z, (2^k < seq x (Z.min k (m + 2 * k))))%Q as AuxAppart.
+  {
+    intros m.
+    pose proof CRealLowerBoundSpec x Hxpos (Z.min k (m + 2 * k))%Z ltac:(lia) as H1.
+    rewrite Heqk at 1.
+    lra.
+  }
+  assert (forall m:Z, (0 < seq x (Z.min k (m + 2 * k))))%Q as AuxPos.
+  {
+    intros m.
+    pose proof AuxAppart m as H1.
+    pose proof Qpower_pos_lt 2 k as H2.
+    lra.
+  }
+
+  assert( forall a b : Q, (a>0)%Q -> (b>0)%Q -> (/a - /b == (b - a) / (a * b))%Q )
+  as H by (intros; field; lra); rewrite H by apply AuxPos; clear H.
+
+  setoid_rewrite Qabs_Qmult; setoid_rewrite Qabs_Qinv.
+  apply Qlt_shift_div_r.
+  setoid_rewrite <- (Qmult_0_l 0); setoid_rewrite Qabs_Qmult.
+  apply Qmult_lt_compat_nonneg.
+    1,2: split; [lra | apply Qabs_gt, AuxPos].
+  assert( forall r:Q, (r == (r/2^k/2^k)*(2^k*2^k))%Q )
+  as H by (intros r; field; apply Qpower_not_0; lra); rewrite H; clear H.
+  apply Qmult_lt_compat_nonneg.
+  - split.
+    + do 2 (apply Qle_shift_div_l; [ apply Qpower_pos_lt; lra | rewrite Qmult_0_l ]).
+      apply Qabs_nonneg.
+    + do 2 (apply Qlt_shift_div_r; [apply Qpower_pos_lt; lra|]).
+      do 2 rewrite <- Qpower_plus by lra.
+      apply (cauchy x (n+k+k)%Z); lia.
+  - split.
+     + rewrite <- Qpower_plus by lra.
+       apply Qpower_pos; lra.
+     + setoid_rewrite Qabs_Qmult; apply Qmult_lt_compat_nonneg.
+       1,2: split; [apply Qpower_pos; lra | ].
+       1,2: apply Qabs_gt, AuxAppart.
 Qed.
 
-Lemma CReal_inv_pos_cauchy
-  : forall (x : CReal) (xPos : 0 < x) (k : positive),
-    (forall n:positive, Pos.le k n -> Qlt (1 # k) (proj1_sig x n))
-    -> QCauchySeq (fun n : positive => / proj1_sig x (k ^ 2 * n)%positive).
+Lemma CReal_inv_pos_bound : forall (x : CReal) (Hxpos : 0 < x),
+  QBound (CReal_inv_pos_seq x Hxpos) (CReal_inv_pos_scale x Hxpos).
 Proof.
-  intros [xn xcau] xPos k maj. unfold proj1_sig.
-  intros n p q H0 H1.
-  setoid_replace (/ xn (k ^ 2 * p)%positive - / xn (k ^ 2 * q)%positive)%Q
-    with ((xn (k ^ 2 * q)%positive -
-           xn (k ^ 2 * p)%positive)
-            / (xn (k ^ 2 * q)%positive *
-               xn (k ^ 2 * p)%positive)).
-  + apply (Qle_lt_trans _ (Qabs (xn (k ^ 2 * q)%positive
-                                 - xn (k ^ 2 * p)%positive)
-                                / (1 # (k^2)))).
-    assert (1 # k ^ 2
-            < Qabs (xn (k ^ 2 * q)%positive * xn (k ^ 2 * p)%positive))%Q.
-    { rewrite Qabs_Qmult. unfold "^"%positive; simpl.
-      rewrite factorDenom. rewrite Pos.mul_1_r.
-      apply (Qlt_trans _ ((1#k) * Qabs (xn (k * k * p)%positive))).
-      apply Qmult_lt_l. reflexivity. rewrite Qabs_pos.
-      specialize (maj (k * k * p)%positive).
-      apply maj. rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple.
-      apply (Qle_trans _ (1 # k)).
-      discriminate. apply Zlt_le_weak. apply maj.
-      rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple.
-      apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity.
-      rewrite Qabs_pos.
-      specialize (maj (k * k * p)%positive).
-      apply maj. rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple.
-      apply (Qle_trans _ (1 # k)). discriminate.
-      apply Zlt_le_weak. apply maj.
-      rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple.
-      rewrite Qabs_pos.
-      specialize (maj (k * k * q)%positive).
-      apply maj. rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple.
-      apply (Qle_trans _ (1 # k)). discriminate.
-      apply Zlt_le_weak.
-      apply maj. rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple. }
-    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.
-    pose proof (xcau (n * (k^2))%positive
-                     (k ^ 2 * q)%positive
-                     (k ^ 2 * p)%positive).
-    apply Qlt_shift_div_r. reflexivity.
-    apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply xcau.
-    rewrite Pos.mul_comm. unfold id.
-    apply Pos.mul_le_mono_l. exact H1.
-    unfold id. rewrite Pos.mul_comm.
-    apply Pos.mul_le_mono_l. exact H0.
-    rewrite factorDenom. apply Qle_refl.
-  + field. split. intro abs.
-    specialize (maj (k ^ 2 * p)%positive).
-    rewrite abs in maj. apply (Qlt_not_le (1#k) 0).
-    apply maj. unfold "^"%positive; simpl. rewrite <- Pos.mul_assoc.
-    rewrite Pos.mul_comm. apply belowMultiple. discriminate.
-    intro abs.
-    specialize (maj (k ^ 2 * q)%positive).
-    rewrite abs in maj. apply (Qlt_not_le (1#k) 0).
-    apply maj. unfold "^"%positive; simpl. rewrite <- Pos.mul_assoc.
-    rewrite Pos.mul_comm. apply belowMultiple. discriminate.
+  intros x Hxpos n.
+  unfold CReal_inv_pos_seq, CReal_inv_pos_scale, CReal_inv_pos_cm.
+  remember (CRealLowerBound x Hxpos) as k.
+  pose proof CRealLowerBoundSpec x Hxpos (Z.min k (n + 2 * k))%Z ltac:(lia) as Hlb.
+  rewrite <- Heqk in Hlb.
+  rewrite Qabs_pos.
+    2: apply Qinv_le_0_compat; pose proof Qpower_pos 2 k; lra.
+  rewrite Qpower_opp; apply -> Qinv_lt_contravar.
+  - exact Hlb.
+  - pose proof Qpower_pos_lt 2 k; lra.
+  - apply Qpower_pos_lt; lra.
 Qed.
 
-Definition CReal_inv_pos (x : CReal) (xPos : 0 < x) : CReal
-  := exist _
-           (fun n : positive => / proj1_sig x (proj1_sig xPos ^ 2 * n)%positive)
-           (CReal_inv_pos_cauchy
-              x xPos (proj1_sig xPos) (CRealPosShift_correct x xPos)).
+Definition CReal_inv_pos (x : CReal) (Hxpos : 0 < x) : CReal :=
+{|
+  seq := CReal_inv_pos_seq x Hxpos;
+  scale := CReal_inv_pos_scale x Hxpos;
+  cauchy := CReal_inv_pos_cauchy x Hxpos;
+  bound := CReal_inv_pos_bound x Hxpos
+|}.
+
+(* ToDo: make this more obviously computing *)
 
 Definition CReal_neg_lt_pos : forall x : CReal, x < 0 -> 0 < -x.
 Proof.
@@ -1030,91 +754,71 @@ Lemma CReal_inv_0_lt_compat
   : forall (r : CReal) (rnz : r # 0),
     0 < r -> 0 < ((/ r) rnz).
 Proof.
-  intros. unfold CReal_inv. simpl.
-  destruct rnz.
-  - exfalso. apply CRealLt_asym in H. contradiction.
-  - unfold CReal_inv_pos.
-    pose proof (CRealPosShift_correct r c) as maj.
-    destruct r as [xn cau].
-    unfold CRealLt; simpl.
-    destruct (Qarchimedean (xn 1%positive)) as [A majA].
-    exists (2 * (A + 1))%positive. unfold Qminus. rewrite Qplus_0_r.
-    rewrite <- (Qmult_1_l (/ xn (proj1_sig c ^ 2 * (2 * (A + 1)))%positive)).
-    apply Qlt_shift_div_l. apply (Qlt_trans 0 (1# proj1_sig c)). reflexivity.
-    apply maj. unfold "^"%positive, Pos.iter.
-    rewrite <- Pos.mul_assoc, Pos.mul_comm. apply belowMultiple.
-    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 <- (Qplus_lt_l _ _ (- xn 1%positive)).
-    apply (Qle_lt_trans _ (Qabs (xn (proj1_sig c ^ 2 * (2 * (A + 1)))%positive + - xn 1%positive))).
-    apply Qle_Qabs. apply (Qlt_le_trans _ 1). apply cau.
-    apply Pos.le_1_l. apply Pos.le_1_l.
-    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.
-Defined.
-
-Lemma CReal_linear_shift : forall (x : CReal) (k : positive),
-    QCauchySeq (fun n => proj1_sig x (k * n)%positive).
-Proof.
-  intros [xn limx] k p n m H H0. unfold proj1_sig.
-  apply limx. apply (Pos.le_trans _ n). apply H.
-  rewrite <- (Pos.mul_1_l n). rewrite Pos.mul_assoc.
-  apply Pos.mul_le_mono_r. destruct (k*1)%positive; discriminate.
-  apply (Pos.le_trans _ (1*m)). exact H0.
-  apply Pos.mul_le_mono_r. destruct k; discriminate.
+  intros r Hrnz Hrpos; unfold CReal_inv; cbn.
+  destruct Hrnz.
+  - exfalso. apply CRealLt_asym in Hrpos. contradiction.
+  - unfold CRealLt.
+    exists (- (scale r) - 1)%Z.
+    unfold inject_Q; rewrite CReal_red_seq; simplify_Qlt.
+    unfold CReal_inv_pos; rewrite CReal_red_seq.
+    unfold CReal_inv_pos_seq.
+    pose proof bound r as Hrbnd; unfold QBound in Hrbnd.
+    rewrite Qpower_minus by lra.
+    field_simplify (2 * (2 ^ (- scale r) / 2 ^ 1))%Q.
+    rewrite Qpower_opp; apply -> Qinv_lt_contravar.
+    + setoid_rewrite Qabs_Qlt_condition in Hrbnd.
+      specialize (Hrbnd (CReal_inv_pos_cm r c (- scale r - 1))%Z).
+      lra.
+    + apply Qpower_pos_lt; lra.
+    + unfold CReal_inv_pos_cm.
+      pose proof CRealLowerBoundSpec r c
+        ((Z.min (CRealLowerBound r c) (- scale r - 1 + 2 * CRealLowerBound r c)))%Z ltac:(lia) as Hlowbnd.
+      pose proof Qpower_pos_lt 2 (CRealLowerBound r c) as Hpow.
+      lra.
 Qed.
 
-Lemma CReal_linear_shift_eq : forall (x : CReal) (k : positive),
-    x ==
-    (exist (fun n : positive -> Q => QCauchySeq n)
-           (fun n : positive => proj1_sig x (k * n)%positive) (CReal_linear_shift x k)).
+Lemma CReal_inv_l_pos : forall (r:CReal) (Hrpos : 0 < r),
+    (CReal_inv_pos r Hrpos) * r == 1.
 Proof.
-  intros. apply CRealEq_diff. intro n.
-  destruct x as [xn limx]; unfold proj1_sig.
-  specialize (limx n n (k * n)%positive).
-  apply (Qle_trans _ (1 # n)). apply Qlt_le_weak. apply limx.
-  apply Pos.le_refl. rewrite <- (Pos.mul_1_l n).
-  rewrite Pos.mul_assoc. apply Pos.mul_le_mono_r.
-  destruct (k*1)%positive; discriminate.
-  apply Z.mul_le_mono_nonneg_r. discriminate. discriminate.
-Qed.
-
-Lemma CReal_inv_l_pos : forall (r:CReal) (rnz : 0 < r),
-    (CReal_inv_pos r rnz) * r == 1.
-Proof.
-  intros r c.
-  unfold CReal_inv_pos.
-  pose proof (CRealPosShift_correct r c) as maj.
-  rewrite (CReal_mult_proper_l
-             _ r (exist _ (fun n => proj1_sig r (proj1_sig c ^ 2 * n)%positive)
-                        (CReal_linear_shift r _))).
-  2: rewrite <- CReal_linear_shift_eq; apply reflexivity.
-  apply CRealEq_diff. intro n.
-  destruct r as [rn limr].
-  unfold CReal_mult, inject_Q, proj1_sig.
-  rewrite Qmult_comm, Qmult_inv_r.
-  unfold Qminus. rewrite Qplus_opp_r, Qabs_pos.
-  discriminate. apply Qle_refl.
-  unfold proj1_sig in maj.
-  intro abs.
-  specialize (maj ((let (a, _) := c in a) ^ 2 *
-            (2 *
-             Pos.max
-               (QCauchySeq_bound
-                  (fun n : positive => Qinv (rn ((let (a, _) := c in a) ^ 2 * n))) id)
-               (QCauchySeq_bound
-                  (fun n : positive => rn ((let (a, _) := c in a) ^ 2 * n)) id) * n))%positive).
-  simpl in maj. unfold proj1_sig in maj, abs.
-  rewrite abs in maj. clear abs.
-  apply (Qlt_not_le (1 # (let (a, _) := c in a)) 0).
-  apply maj. unfold "^"%positive, Pos.iter.
-  rewrite <- Pos.mul_assoc, Pos.mul_comm. apply belowMultiple.
-  discriminate.
+  intros r Hrpos; apply CRealEq_diff; intros n.
+  unfold CReal_mult, CReal_mult_seq, CReal_mult_scale;
+  unfold CReal_inv_pos, CReal_inv_pos_seq, CReal_inv_pos_scale, CReal_inv_pos_cm;
+  unfold inject_Q.
+  do 3 rewrite CReal_red_seq.
+  do 1 rewrite CReal_red_scale.
+  simplify_seq_idx.
+
+  (* This is needed several times below *)
+  remember (Z.min (CRealLowerBound r Hrpos) (n - scale r - 1 + 2 * CRealLowerBound r Hrpos))%Z as k.
+  assert (0 < seq r k)%Q as Hrseqpos.
+  { pose proof Qpower_pos_lt 2 (CRealLowerBound r Hrpos)%Z ltac:(lra) as Hpow.
+    pose proof CRealLowerBoundSpec r Hrpos k ltac:(lia) as Hlowbnd.
+    lra.
+  }
+  field_simplify_Qabs; [|lra]; unfold Qdiv.
+  rewrite Qabs_Qmult, Qabs_Qinv.
+  apply Qle_shift_div_r.
+    1: apply Qabs_gt; lra.
+
+  pose proof cauchy r (n + CRealLowerBound r Hrpos)%Z
+    (n + CRealLowerBound r Hrpos - 1)%Z k as Hrbnd.
+  pose proof CRealLowerBound_lt_scale r Hrpos as Hscale_lowbnd.
+  specialize (Hrbnd ltac:(lia) ltac:(lia)).
+  simplify_Qabs_in Hrbnd; simplify_Qabs.
+  rewrite Qplus_comm in Hrbnd.
+  apply Qlt_le_weak in Hrbnd.
+  apply (Qle_trans _ _ _ Hrbnd).
+
+  pose proof CRealLowerBoundSpec r Hrpos k ltac:(lia) as Hlowbnd.
+
+  rewrite Qpower_plus; [|lra].
+  apply Qmult_le_compat_nonneg.
+    pose proof Qpower_pos 2 n; split; lra.
+  split.
+  - apply Qpower_pos; lra.
+  - rewrite Qabs_pos; [lra|].
+    pose proof Qpower_pos_lt 2 (CRealLowerBound r Hrpos)%Z ltac:(lra) as Hpow.
+    lra.
 Qed.
 
 Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0),
@@ -1196,60 +900,59 @@ Qed.
    that x and y are inverses of each other. *)
 Lemma CReal_mult_pos_appart_zero : forall x y : CReal, 0 < x * y -> 0 # x.
 Proof.
-  intros. destruct (linear_order_T 0 x 1 (CRealLt_0_1)).
-  left. exact c. destruct (linear_order_T (CReal_opp 1) x 0).
-  rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar, CRealLt_0_1.
-  2: right; exact c0.
-  pose proof (CRealLt_above _ _ H). destruct H0 as [k kmaj].
-  simpl in kmaj.
-  apply CRealLt_above in c. destruct c as [i imaj]. simpl in imaj.
-  apply CRealLt_above in c0. destruct c0 as [j jmaj]. simpl in jmaj.
-  pose proof (CReal_abs_appart_zero y).
-  destruct x as [xn xcau], y as [yn ycau].
-  unfold CReal_mult, proj1_sig in kmaj.
-  remember (QCauchySeq_bound xn id) as a.
-  remember (QCauchySeq_bound yn id) as b.
-  simpl in imaj, jmaj. simpl in H0.
-  specialize (kmaj (Pos.max k (Pos.max i j)) (Pos.le_max_l _ _)).
-  destruct (H0 (2*(Pos.max a b) * (Pos.max k (Pos.max i j)))%positive).
-  - apply (Qlt_trans _ (2#k)).
-    + unfold Qlt. rewrite <- Z.mul_lt_mono_pos_l. 2: reflexivity.
-      unfold Qden. apply Pos2Z.pos_lt_pos.
-      apply (Pos.le_lt_trans _ (1 * Pos.max k (Pos.max i j))).
-      rewrite Pos.mul_1_l. apply Pos.le_max_l.
-      apply Pos2Nat.inj_lt. do 2 rewrite Pos2Nat.inj_mul.
-      rewrite <- Nat.mul_lt_mono_pos_r. 2: apply Pos2Nat.is_pos.
-      fold (2*Pos.max a b)%positive. rewrite Pos2Nat.inj_mul.
-      apply Nat.lt_1_mul_pos. auto. apply Pos2Nat.is_pos.
-    + apply (Qlt_le_trans _ _ _ kmaj). unfold Qminus. rewrite Qplus_0_r.
-      rewrite <- (Qmult_1_l (Qabs (yn (2*(Pos.max a b) * Pos.max k (Pos.max i j))%positive))).
-      apply (Qle_trans _ _ _ (Qle_Qabs _)). rewrite Qabs_Qmult.
-      apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
-      apply Qabs_Qle_condition. split.
-      apply Qlt_le_weak. apply Qlt_minus_iff, (Qlt_trans _ (2#j)).
-      reflexivity. apply jmaj.
-      apply (Pos.le_trans _ (2*j)). apply belowMultiple.
-      apply Pos.mul_le_mono_l.
-      apply (Pos.le_trans _ (1 * Pos.max k (Pos.max i j))).
-      rewrite Pos.mul_1_l.
-      apply (Pos.le_trans _ (Pos.max i j) _ (Pos.le_max_r _ _)).
-      apply Pos.le_max_r.
-      rewrite <- Pos.mul_le_mono_r. destruct (Pos.max a b); discriminate.
-      apply Qlt_le_weak. apply Qlt_minus_iff, (Qlt_trans _ (2#i)).
-      reflexivity. apply imaj.
-      apply (Pos.le_trans _ (2*i)). apply belowMultiple.
-      apply Pos.mul_le_mono_l.
-      apply (Pos.le_trans _ (1 * Pos.max k (Pos.max i j))).
-      rewrite Pos.mul_1_l.
-      apply (Pos.le_trans _ (Pos.max i j) _ (Pos.le_max_l _ _)).
-      apply Pos.le_max_r.
-      rewrite <- Pos.mul_le_mono_r. destruct (Pos.max a b); discriminate.
-  - left. apply (CReal_mult_lt_reg_r (exist _ yn ycau) _ _ c).
-    rewrite CReal_mult_0_l. exact H.
-  - right. apply (CReal_mult_lt_reg_r (CReal_opp (exist _ yn ycau))).
-    rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar. exact c.
-    rewrite CReal_mult_0_l, <- CReal_opp_0, <- CReal_opp_mult_distr_r.
-    apply CReal_opp_gt_lt_contravar. exact H.
+  intros x y H0ltxy.
+  unfold CRealLt, CReal_mult, CReal_mult_seq, CReal_mult_scale in H0ltxy;
+    rewrite CReal_red_seq in H0ltxy.
+  destruct H0ltxy as [n nmaj].
+  cbn in nmaj; setoid_rewrite Qplus_0_r in nmaj.
+  destruct (Q_dec 0 (seq y (n - scale x - 1)))%Q as [[H0lty|Hylt0]|Hyeq0].
+  - apply (Qmult_lt_compat_r _ _ (/(seq y (n - scale x - 1)))%Q ) in nmaj.
+      2: apply Qinv_lt_0_compat, H0lty.
+    setoid_rewrite <- Qmult_assoc in nmaj at 2.
+    setoid_rewrite Qmult_inv_r in nmaj.
+      2: lra.
+    setoid_rewrite Qmult_1_r in nmaj.
+    pose proof bound y (n - scale x - 1)%Z as Hybnd.
+    apply Qabs_Qlt_condition, proj2 in Hybnd.
+    apply Qinv_lt_contravar in Hybnd.
+      3: apply Qpower_pos_lt; lra.
+      2: exact H0lty.
+    apply (Qmult_lt_l _ _ (2 * (2 ^ n))) in Hybnd.
+      2: pose proof Qpower_pos_lt 2 n; lra.
+    apply (Qlt_trans _ _ _ Hybnd) in nmaj; clear Hybnd.
+    rewrite <- Qpower_opp, <- Qmult_assoc, <- Qpower_plus in nmaj by lra.
+    apply (CReal_abs_appart_zero x (n - scale y - 1)%Z), Qabs_gt.
+    rewrite Qpower_minus_pos.
+    ring_simplify. ring_simplify (n + - scale y)%Z in nmaj.
+    pose proof Qpower_pos_lt 2 (n - scale y)%Z; lra.
+  - (* This proof is the same as above, except that we swap the signs of x and y *)
+    (* ToDo: maybe assert teh goal for arbitrary y>0 and then apply twice *)
+    assert (forall a b : Q, ((-a)*(-b)==a*b)%Q) by (intros; ring).
+    setoid_rewrite <- H in nmaj at 2; clear H.
+    apply (Qmult_lt_compat_r _ _ (/-(seq y (n - scale x - 1)))%Q ) in nmaj.
+      2: apply Qinv_lt_0_compat; lra.
+    setoid_rewrite <- Qmult_assoc in nmaj at 2.
+    setoid_rewrite Qmult_inv_r in nmaj.
+      2: lra.
+    setoid_rewrite Qmult_1_r in nmaj.
+    pose proof bound y (n - scale x - 1)%Z as Hybnd.
+    apply Qabs_Qlt_condition, proj1 in Hybnd.
+    apply Qopp_lt_compat in Hybnd; rewrite Qopp_involutive in Hybnd.
+    apply Qinv_lt_contravar in Hybnd.
+      3: apply Qpower_pos_lt; lra.
+      2: lra.
+    apply (Qmult_lt_l _ _ (2 * (2 ^ n))) in Hybnd.
+      2: pose proof Qpower_pos_lt 2 n; lra.
+    apply (Qlt_trans _ _ _ Hybnd) in nmaj; clear Hybnd.
+    rewrite <- Qpower_opp, <- Qmult_assoc, <- Qpower_plus in nmaj by lra.
+    apply (CReal_abs_appart_zero x (n - scale y - 1)%Z).
+    pose proof Qpower_pos_lt 2 (n + - scale y)%Z ltac:(lra) as Hpowpos.
+    rewrite Qabs_neg by lra.
+    rewrite Qpower_minus_pos.
+    ring_simplify. ring_simplify (n + - scale y)%Z in nmaj.
+    pose proof Qpower_pos_lt 2 (n - scale y)%Z; lra.
+  - pose proof Qpower_pos_lt 2 n ltac:(lra).
+    rewrite <- Hyeq0 in nmaj. lra.
 Qed.
 
 Fixpoint pow (r:CReal) (n:nat) : CReal :=
@@ -1275,7 +978,8 @@ Proof.
   - right. apply CReal_injectQPos. exact pos.
   - rewrite CReal_mult_comm, CReal_inv_l.
     apply CRealEq_diff. intro n. simpl.
-    do 2 rewrite Pos.mul_1_r. rewrite Z.pos_sub_diag. discriminate.
+    do 2 rewrite Pos.mul_1_r. rewrite Z.pos_sub_diag.
+    pose proof Qpower_pos 2 n ltac:(lra). rewrite Z.abs_0, Qzero_eq. lra.
 Qed.
 
 Definition CRealQ_dense (a b : CReal)
@@ -1284,38 +988,32 @@ Proof.
   (* Locate a and b at the index given by a<b,
      and pick the middle rational number. *)
   intros [p pmaj].
-  exists ((proj1_sig a p + proj1_sig b p) * (1#2))%Q.
+  exists ((seq a p + seq b p) * (1#2))%Q.
   split.
   - apply (CReal_le_lt_trans _ _ _ (inject_Q_compare a p)). apply inject_Q_lt.
-    apply (Qmult_lt_l _ _ 2). reflexivity.
-    apply (Qplus_lt_l _ _ (-2*proj1_sig a p)).
-    field_simplify. field_simplify in pmaj.
-    setoid_replace (-2#2)%Q with (-1)%Q. 2: reflexivity.
-    setoid_replace (2*(1#p))%Q with (2#p)%Q. 2: reflexivity.
-    rewrite Qplus_comm. exact pmaj.
+    lra.
   - apply (CReal_plus_lt_reg_l (-b)).
     rewrite CReal_plus_opp_l.
     apply (CReal_plus_lt_reg_r
-             (-inject_Q ((proj1_sig a p + proj1_sig b p) * (1 # 2)))).
+             (-inject_Q ((seq a p + seq b p) * (1 # 2)))).
     rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r, CReal_plus_0_l.
     rewrite <- opp_inject_Q.
     apply (CReal_le_lt_trans _ _ _ (inject_Q_compare (-b) p)). apply inject_Q_lt.
-    apply (Qmult_lt_l _ _ 2). reflexivity.
-    apply (Qplus_lt_l _ _ (2*proj1_sig b p)).
-    destruct b as [bn bcau]; simpl. simpl in pmaj.
-    field_simplify. field_simplify in pmaj.
-    setoid_replace (-2#2)%Q with (-1)%Q. 2: reflexivity.
-    setoid_replace (2*(1#p))%Q with (2#p)%Q. 2: reflexivity. exact pmaj.
+    destruct b as [bseq]; simpl in pmaj |- *.
+    unfold CReal_opp_seq; rewrite CReal_red_seq.
+    lra.
 Qed.
 
 Lemma inject_Q_mult : forall q r : Q,
     inject_Q (q * r) == inject_Q q * inject_Q r.
 Proof.
   split.
-  - intros [n maj]. simpl in maj.
-    simpl in maj. ring_simplify in maj. discriminate maj.
-  - intros [n maj]. simpl in maj.
-    simpl in maj. ring_simplify in maj. discriminate maj.
+  - intros [n maj]; cbn in maj.
+    unfold CReal_mult_seq in maj; cbn in maj.
+    pose proof Qpower_pos_lt 2 n; lra.
+  - intros [n maj]; cbn in maj.
+    unfold CReal_mult_seq in maj; cbn in maj.
+    pose proof Qpower_pos_lt 2 n; lra.
 Qed.
 
 Definition Rup_nat (x : CReal)
diff --git a/theories/Reals/Cauchy/ConstructiveExtra.v b/theories/Reals/Cauchy/ConstructiveExtra.v
new file mode 100644
index 0000000000..0307a6a644
--- /dev/null
+++ b/theories/Reals/Cauchy/ConstructiveExtra.v
@@ -0,0 +1,76 @@
+Require Import ZArith.
+Require Import ConstructiveEpsilon.
+
+Definition Z_inj_nat (z : Z) : nat :=
+  match z with
+  | Z0 => 0
+  | Zpos p => Pos.to_nat (p~0)
+  | Zneg p => Pos.to_nat (Pos.pred_double p)
+  end.
+
+Definition Z_inj_nat_rev (n : nat) : Z :=
+  match n with
+  | O => 0
+  | S n' => match Pos.of_nat n with
+            | xH =>   Zneg xH
+            | xO p => Zpos p
+            | xI p => Zneg (Pos.succ p)
+            end
+  end.
+
+Lemma Pos_pred_double_inj: forall (p q : positive),
+    Pos.pred_double p = Pos.pred_double q -> p = q.
+Proof.
+  intros p q H.
+  apply (f_equal Pos.succ) in H.
+  do 2 rewrite Pos.succ_pred_double in H.
+  inversion H; reflexivity.
+Qed.
+
+Lemma Z_inj_nat_id: forall (z : Z),
+  Z_inj_nat_rev (Z_inj_nat z) = z.
+Proof.
+  intros z.
+  unfold Z_inj_nat, Z_inj_nat_rev.
+  destruct z eqn:Hdz.
+  - reflexivity.
+  - rewrite Pos2Nat.id.
+    destruct (Pos.to_nat p~0) eqn:Hd.
+    + pose proof Pos2Nat.is_pos p~0 as H.
+      rewrite <- Nat.neq_0_lt_0 in H.
+      exfalso; apply H, Hd.
+    + reflexivity.
+  - rewrite Pos2Nat.id.
+    destruct (Pos.to_nat (Pos.pred_double p)) eqn: Hd.
+    + pose proof Pos2Nat.is_pos (Pos.pred_double p) as H.
+      rewrite <- Nat.neq_0_lt_0 in H.
+      exfalso; apply H, Hd.
+    + destruct (Pos.pred_double p) eqn:Hd2.
+      * rewrite <- Pos.pred_double_succ in Hd2.
+        apply Pos_pred_double_inj in Hd2.
+        rewrite Hd2; reflexivity.
+      * apply (f_equal Pos.succ) in Hd2.
+        rewrite Pos.succ_pred_double in Hd2.
+        rewrite <- Pos.xI_succ_xO in Hd2.
+        inversion Hd2.
+      * change xH with (Pos.pred_double xH) in Hd2.
+        apply Pos_pred_double_inj in Hd2.
+        rewrite Hd2; reflexivity.
+Qed.
+
+Lemma Z_inj_nat_inj: forall (x y : Z),
+    Z_inj_nat x = Z_inj_nat y -> x = y.
+Proof.
+  intros x y H.
+  apply (f_equal Z_inj_nat_rev) in H.
+  do 2 rewrite Z_inj_nat_id in H.
+  assumption.
+Qed.
+
+Lemma constructive_indefinite_ground_description_Z:
+  forall P : Z -> Prop,
+  (forall z : Z, {P z} + {~ P z}) ->
+  (exists z : Z, P z) -> {z : Z | P z}.
+Proof.
+  apply (constructive_indefinite_ground_description Z Z_inj_nat Z_inj_nat_rev Z_inj_nat_id).
+Qed.
diff --git a/theories/Reals/Cauchy/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v
index a6843d598c..70d2861d17 100644
--- a/theories/Reals/Cauchy/ConstructiveRcomplete.v
+++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v
@@ -15,6 +15,12 @@ Require Import ConstructiveReals.
 Require Import ConstructiveCauchyRealsMult.
 Require Import Logic.ConstructiveEpsilon.
 Require Import ConstructiveCauchyAbs.
+Require Import Lia.
+Require Import Lqa.
+Require Import Qpower.
+Require Import QExtra.
+Require Import PosExtra.
+Require Import ConstructiveExtra.
 
 (** Proof that Cauchy reals are Cauchy-complete.
 
@@ -71,59 +77,7 @@ Proof.
     rewrite Qinv_plus_distr. reflexivity.
 Defined.
 
-
-(* 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 (a b : CReal)
-  : a < b -> { q : Q & a < inject_Q q < b }.
-Proof.
-  intros H. assert (0 < b - a) as epsPos.
-  { apply (CReal_plus_lt_compat_l (-a)) in H.
-    rewrite CReal_plus_opp_l, CReal_plus_comm in H.
-    apply H. }
-  pose proof (Rup_pos ((/(b-a)) (inr epsPos)))
-    as [n maj].
-  destruct (Rfloor (inject_Q (2 * Z.pos n # 1) * b)) as [p maj2].
-  exists (p # (2*n))%Q. split.
-  - apply (CReal_lt_trans a (b - inject_Q (1 # n))).
-    apply (CReal_plus_lt_reg_r (inject_Q (1#n))).
-    unfold CReal_minus. rewrite CReal_plus_assoc. rewrite CReal_plus_opp_l.
-    rewrite CReal_plus_0_r. apply (CReal_plus_lt_reg_l (-a)).
-    rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l.
-    rewrite CReal_plus_comm.
-    apply (CReal_mult_lt_reg_l (inject_Q (Z.pos n # 1))).
-    apply inject_Q_lt. reflexivity. rewrite <- inject_Q_mult.
-    setoid_replace ((Z.pos n # 1) * (1 # n))%Q with 1%Q.
-    apply (CReal_mult_lt_compat_l (b-a)) in maj.
-    rewrite CReal_inv_r, CReal_mult_comm in maj. exact maj.
-    exact epsPos. unfold Qeq; simpl. do 2 rewrite Pos.mul_1_r. reflexivity.
-    apply (CReal_plus_lt_reg_r (inject_Q (1 # n))).
-    unfold CReal_minus. rewrite CReal_plus_assoc, CReal_plus_opp_l.
-    rewrite CReal_plus_0_r. rewrite <- inject_Q_plus.
-    destruct maj2 as [_ maj2].
-    setoid_replace ((p # 2 * n) + (1 # n))%Q
-      with ((p + 2 # 2 * n))%Q.
-    apply (CReal_mult_lt_reg_r (inject_Q (Z.pos (2 * n) # 1))).
-    apply inject_Q_lt. reflexivity. rewrite <- inject_Q_mult.
-    setoid_replace ((p + 2 # 2 * n) * (Z.pos (2 * n) # 1))%Q
-      with ((p#1) + 2)%Q.
-    rewrite inject_Q_plus. rewrite Pos2Z.inj_mul.
-    rewrite CReal_mult_comm. exact maj2.
-    unfold Qeq; simpl. rewrite Pos.mul_1_r, Z.mul_1_r. ring.
-    setoid_replace (1#n)%Q with (2#2*n)%Q. 2: reflexivity.
-    apply Qinv_plus_distr.
-  - destruct maj2 as [maj2 _].
-    apply (CReal_mult_lt_reg_r (inject_Q (Z.pos (2 * n) # 1))).
-    apply inject_Q_lt. reflexivity.
-    rewrite <- inject_Q_mult.
-    setoid_replace ((p # 2 * n) * (Z.pos (2 * n) # 1))%Q
-      with ((p#1))%Q.
-    rewrite CReal_mult_comm. exact maj2.
-    unfold Qeq; simpl. rewrite Pos.mul_1_r, Z.mul_1_r. reflexivity.
-Qed.
-
+(* ToDo: Move to ConstructiveCauchyAbs.v *)
 Lemma Qabs_Rabs : forall q : Q,
     inject_Q (Qabs q) == CReal_abs (inject_Q q).
 Proof.
@@ -134,40 +88,122 @@ Proof.
     apply inject_Q_le, H.
 Qed.
 
+Lemma Qlt_trans_swap_hyp: forall x y z : Q,
+  (y < z)%Q -> (x < y)%Q -> (x < z)%Q.
+Proof.
+  intros x y z H1 H2.
+  apply (Qlt_trans x y z); assumption.
+Qed.
+
+Lemma Qle_trans_swap_hyp: forall x y z : Q,
+  (y <= z)%Q -> (x <= y)%Q -> (x <= z)%Q.
+Proof.
+  intros x y z H1 H2.
+  apply (Qle_trans x y z); assumption.
+Qed.
+
+(** This inequality is tight since it is equal for n=1 and n=2 *)
+
+Lemma Qpower_2powneg_le_inv: forall (n : positive),
+    (2 * 2 ^ Z.neg n <= 1 # n)%Q.
+Proof.
+  intros n.
+  induction n using Pos.peano_ind.
+  - cbn. lra.
+  - rewrite <- Pos2Z.opp_pos, Pos2Z.inj_succ, Z.opp_succ, Pos2Z.opp_pos, <- Z.sub_1_r.
+    rewrite Qpower_minus_pos.
+    ring_simplify.
+    apply (Qmult_le_l _ _ (1#2)) in IHn.
+      2: lra.
+    ring_simplify in IHn.
+    apply (Qle_trans _ _ _ IHn).
+    unfold Qle, Qmult, Qnum, Qden.
+    ring_simplify; rewrite Pos2Z.inj_succ, <- Z.add_1_l.
+    clear IHn; induction n using Pos.peano_ind.
+    + reflexivity.
+    + rewrite Pos2Z.inj_succ, <- Z.add_1_l.
+      (* ToDo: does this lemma really need to be named like this and have this statement? *)
+      rewrite <- POrderedType.Positive_as_OT.add_1_l.
+      rewrite POrderedType.Positive_as_OT.mul_add_distr_l.
+      rewrite Pos2Z.inj_add.
+      apply Z.add_le_mono.
+      * lia.
+      * exact IHn.
+Qed.
+
+Lemma Pospow_lin_le_2pow: forall (n : positive),
+    (2 * n <= 2 ^ n)%positive.
+Proof.
+  intros n.
+  induction n using Pos.peano_ind.
+  - cbn. lia.
+  - rewrite Pos.mul_succ_r, Pos.pow_succ_r.
+    lia.
+Qed.
 
-(* For instance the rational sequence 1/n converges to 0. *)
 Lemma CReal_cv_self : forall (x : CReal) (n : positive),
-    CReal_abs (x - inject_Q (proj1_sig x n)) <= inject_Q (1#n).
+    CReal_abs (x - inject_Q (seq x (Z.neg n))) <= inject_Q (1#n).
+Proof.
+  intros x n.
+  (* ToDo: CRealLt_asym should be names CRealLt_Le_weak and asym should be x<y /\ y<x -> False *)
+  apply CRealLt_asym.
+  apply (CRealLt_RQ_from_single_dist _ _ (Z.neg n - 1)%Z).
+  unfold CReal_abs, CReal_abs_seq, CReal_abs_scale.
+  unfold CReal_minus, CReal_plus, CReal_plus_seq, CReal_abs_scale.
+  unfold CReal_opp, CReal_opp_seq, CReal_opp_scale.
+  unfold inject_Q.
+  do 4 rewrite CReal_red_seq; rewrite Qred_correct.
+  ring_simplify (Z.neg n - 1 - 1)%Z.
+  pose proof cauchy x (Z.neg n) (Z.neg n - 2)%Z (Z.neg n) ltac:(lia) ltac:(lia) as Hxbnd.
+  apply Qround.Qopp_lt_compat in Hxbnd.
+  apply (Qplus_lt_r _ _ (1#n)) in Hxbnd.
+  apply (Qlt_trans_swap_hyp _ _ _ Hxbnd); clear Hxbnd x.
+  rewrite Qpower_minus_pos.
+  apply (Qplus_lt_r _ _ (2 ^ Z.neg n)%Q); ring_simplify.
+  pose proof Qpower_2powneg_le_inv n as Hpowinv.
+  pose proof Qpower_pos_lt 2 (Z.neg n) ltac:(lra) as Hpowpos.
+  lra.
+Qed.
+
+Lemma CReal_cv_self' : forall (x : CReal) (n : Z),
+    CReal_abs (x - inject_Q (seq x n)) <= inject_Q (2^n).
 Proof.
   intros x n [k kmaj].
-  destruct x as [xn cau].
-  unfold CReal_abs, CReal_minus, CReal_plus, CReal_opp, inject_Q, proj1_sig in kmaj.
+  unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in kmaj.
+  unfold CReal_minus, CReal_plus, CReal_plus_seq, CReal_abs_scale in kmaj.
+  unfold CReal_opp, CReal_opp_seq, CReal_opp_scale in kmaj.
+  unfold inject_Q in kmaj.
+  do 4 rewrite CReal_red_seq in kmaj; rewrite Qred_correct in kmaj.
   apply (Qlt_not_le _ _ kmaj). clear kmaj.
-  unfold QCauchySeq in cau.
-  rewrite <- (Qplus_le_l _ _ (1#n)). ring_simplify. unfold id in cau.
-  destruct (Pos.lt_total (2*k) n). 2: destruct H.
-  - specialize (cau k (2*k)%positive n).
-    assert (k <= 2 * k)%positive.
-    { apply (Pos.le_trans _ (1*k)). apply Pos.le_refl.
-      apply Pos.mul_le_mono_r. discriminate. }
-    apply (Qle_trans _ (1#k)). rewrite Qred_correct. apply Qlt_le_weak, cau.
-    exact H0. apply (Pos.le_trans _ _ _ H0). apply Pos.lt_le_incl, H.
-    rewrite <- (Qinv_plus_distr 1 1).
-    apply (Qplus_le_l _ _ (-(1#k))). ring_simplify. discriminate.
-  - subst n. rewrite Qplus_opp_r. discriminate.
-  - specialize (cau n (2*k)%positive n).
-    apply (Qle_trans _ (1#n)). rewrite Qred_correct. apply Qlt_le_weak, cau.
-    apply Pos.lt_le_incl, H. apply Pos.le_refl.
-    apply (Qplus_le_l _ _ (-(1#n))). ring_simplify. discriminate.
+  rewrite CReal_red_seq.
+  apply (Qplus_le_l _ _ (2^n)%Q); ring_simplify.
+  pose proof cauchy x (Z.max (k-1)%Z n) (k-1)%Z n ltac:(lia) ltac:(lia) as Hxbnd.
+  apply Qlt_le_weak in Hxbnd.
+  apply (Qle_trans _ _ _ Hxbnd); clear Hxbnd.
+  apply Z.max_case.
+  - rewrite <- Qplus_0_l; apply Qplus_le_compat.
+    + apply Qpower_pos; lra.
+    + rewrite Qpower_minus_pos.
+      pose proof (Qpower_pos_lt 2 k)%Q; lra.
+  - rewrite <- Qplus_0_r; apply Qplus_le_compat.
+    + lra.
+    + pose proof (Qpower_pos_lt 2 k)%Q; lra.
 Qed.
 
+Definition QCauchySeqLin (un : positive -> Q)
+  : Prop
+  := forall (k : positive) (p q : positive),
+      Pos.le k p
+      -> Pos.le k q
+      -> Qlt (Qabs (un p - un q)) (1 # k).
+
 (* We can probably reduce the factor 4. *)
 Lemma Rcauchy_limit : forall (xn : nat -> CReal) (xcau : Un_cauchy_mod xn),
-    QCauchySeq
+    QCauchySeqLin
       (fun n : positive =>
-         let (p, _) := xcau (4 * n)%positive in proj1_sig (xn p) (4 * n)%positive).
+         let (p, _) := xcau (4 * n)%positive in seq (xn p) (4 * Z.neg n)%Z).
 Proof.
-  intros xn xcau n p q H0 H1.
+  intros xn xcau n p q Hp Hq.
   destruct (xcau (4 * p)%positive) as [i imaj],
   (xcau (4 * q)%positive) as [j jmaj].
   assert (CReal_abs (xn i - xn j) <= inject_Q (1 # 4 * n)).
@@ -175,23 +211,23 @@ Proof.
     apply (CReal_le_trans _ _ _ (imaj i j (le_refl _) l)).
     apply inject_Q_le. unfold Qle, Qnum, Qden.
     rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos.
-    apply Pos.mul_le_mono_l, H0. apply le_S, le_S_n in l.
+    apply Pos.mul_le_mono_l, Hp. apply le_S, le_S_n in l.
     apply (CReal_le_trans _ _ _ (jmaj i j l (le_refl _))).
     apply inject_Q_le. unfold Qle, Qnum, Qden.
     rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos.
-    apply Pos.mul_le_mono_l, H1. }
+    apply Pos.mul_le_mono_l, Hq. }
   clear jmaj imaj.
   setoid_replace (1#n)%Q with ((1#(3*n)) + ((1#(3*n)) + (1#(3*n))))%Q.
   2: rewrite Qinv_plus_distr, Qinv_plus_distr; reflexivity.
   apply lt_inject_Q. rewrite inject_Q_plus.
   rewrite Qabs_Rabs.
-  apply (CReal_le_lt_trans _ (CReal_abs (inject_Q (proj1_sig (xn i) (4 * p)%positive) - xn i) + CReal_abs (xn i - inject_Q(proj1_sig (xn j) (4 * q)%positive)))).
+  apply (CReal_le_lt_trans _ (CReal_abs (inject_Q (seq (xn i) (4 * Z.neg p)%Z) - xn i) + CReal_abs (xn i - inject_Q(seq (xn j) (4 * Z.neg q)%Z)))).
   unfold Qminus.
   rewrite inject_Q_plus, opp_inject_Q.
-  setoid_replace (inject_Q (proj1_sig (xn i) (4 * p)%positive) +
-                  - inject_Q (proj1_sig (xn j) (4 * q)%positive))
-    with (inject_Q (proj1_sig (xn i) (4 * p)%positive) - xn i
-          + (xn i - inject_Q (proj1_sig (xn j) (4 * q)%positive))).
+  setoid_replace (inject_Q (seq (xn i) (4 * Z.neg p)%Z) +
+                  - inject_Q (seq (xn j) (4 * Z.neg q)%Z))
+    with (inject_Q (seq (xn i) (4 * Z.neg p)%Z) - xn i
+          + (xn i - inject_Q (seq (xn j) (4 * Z.neg q)%Z))).
   2: ring.
   apply CReal_abs_triang. apply CReal_plus_le_lt_compat.
   rewrite CReal_abs_minus_sym. apply (CReal_le_trans _ (inject_Q (1# 4*p))).
@@ -199,9 +235,9 @@ Proof.
   rewrite Z.mul_1_l, Z.mul_1_l.
   apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (4*n)).
   apply Pos.mul_le_mono_r. discriminate.
-  apply Pos.mul_le_mono_l. exact H0.
+  apply Pos.mul_le_mono_l. exact Hp.
   apply (CReal_le_lt_trans
-           _ (CReal_abs (xn i - xn j + (xn j - inject_Q (proj1_sig (xn j) (4 * q)%positive))))).
+           _ (CReal_abs (xn i - xn j + (xn j - inject_Q (seq (xn j) (4 * Z.neg q)%Z))))).
   apply CReal_abs_morph. ring.
   apply (CReal_le_lt_trans _ _ _ (CReal_abs_triang _ _)).
   rewrite inject_Q_plus. apply CReal_plus_le_lt_compat.
@@ -213,61 +249,405 @@ Proof.
   rewrite Z.mul_1_l, Z.mul_1_l.
   apply Pos2Z.pos_lt_pos. apply (Pos.lt_le_trans _ (4*n)).
   apply Pos.mul_lt_mono_r. reflexivity.
-  apply Pos.mul_le_mono_l. exact H1.
+  apply Pos.mul_le_mono_l. exact Hq.
+Qed.
+
+Definition CReal_from_cauchy_cm (n : Z) : positive :=
+  match n with
+    | Z0
+    | Zpos _ => 1%positive
+    | Zneg p => p
+    end.
+
+Lemma CReal_from_cauchy_cm_mono : forall (n p : Z),
+    (p <= n)%Z
+ -> (CReal_from_cauchy_cm n <= CReal_from_cauchy_cm p)%positive.
+Proof.
+  intros n p Hpn.
+  unfold CReal_from_cauchy_cm; destruct n; destruct p; lia.
+Qed.
+
+Definition CReal_from_cauchy_seq (xn : nat -> CReal) (xcau : Un_cauchy_mod xn) (n : Z) : Q :=
+  let p := CReal_from_cauchy_cm n in
+  let (q, _) := xcau (4 * 2^p)%positive in
+  seq (xn q) (Z.neg p - 2)%Z.
+
+Lemma CReal_from_cauchy_cauchy : forall (xn : nat -> CReal) (xcau : Un_cauchy_mod xn),
+    QCauchySeq (CReal_from_cauchy_seq xn xcau).
+Proof.
+  intros xn xcau n p q Hp Hq.
+  remember (CReal_from_cauchy_cm n) as n'.
+  remember (CReal_from_cauchy_cm p) as p'.
+  remember (CReal_from_cauchy_cm q) as q'.
+  unfold CReal_from_cauchy_seq.
+  rewrite <- Heqp', <- Heqq'.
+  destruct (xcau (4 * 2^p')%positive) as [i imaj].
+  destruct (xcau (4 * 2^q')%positive) as [j jmaj].
+  assert (CReal_abs (xn i - xn j) <= inject_Q (1 # 4 * 2^n')).
+  {
+    destruct (le_lt_dec i j).
+    apply (CReal_le_trans _ _ _ (imaj i j (le_refl _) l)).
+    apply inject_Q_le. unfold Qle, Qnum, Qden.
+    rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos.
+    subst; apply Pos.mul_le_mono_l, Pos_pow_le_mono_r, CReal_from_cauchy_cm_mono, Hp.
+    apply le_S, le_S_n in l.
+    apply (CReal_le_trans _ _ _ (jmaj i j l (le_refl _))).
+    apply inject_Q_le. unfold Qle, Qnum, Qden.
+    rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos.
+    subst; apply Pos.mul_le_mono_l, Pos_pow_le_mono_r, CReal_from_cauchy_cm_mono, Hq.
+  }
+  clear jmaj imaj.
+  setoid_replace (2^n)%Q with ((1#3)*2^n + ((1#3)*2^n + (1#3)*2^n))%Q by ring.
+  apply lt_inject_Q. rewrite inject_Q_plus.
+  rewrite Qabs_Rabs.
+  apply (CReal_le_lt_trans _ (CReal_abs (inject_Q (seq (xn i) (Z.neg p' - 2)%Z) - xn i) + CReal_abs (xn i - inject_Q(seq (xn j) (Z.neg q' - 2)%Z)))).
+  {
+    unfold Qminus.
+    rewrite inject_Q_plus, opp_inject_Q.
+    setoid_replace (inject_Q (seq (xn i) (Z.neg p' - 2)%Z) +
+                    - inject_Q (seq (xn j) (Z.neg q' -  2)%Z))
+      with (inject_Q (seq (xn i) (Z.neg p' - 2)%Z) - xn i
+            + (xn i - inject_Q (seq (xn j) (Z.neg q' - 2)%Z))).
+    2: ring.
+    apply CReal_abs_triang.
+  }
+  apply CReal_plus_le_lt_compat.
+  {
+    rewrite CReal_abs_minus_sym.
+    apply (CReal_le_trans _ (inject_Q ((1#4)*2^(Z.neg p')))).
+    - change (1#4)%Q with ((1#2)^2)%Q.
+      rewrite Qmult_comm, <- Qpower_minus_pos.
+      apply CReal_cv_self'.
+    - apply inject_Q_le.
+      apply Qmult_le_compat_nonneg.
+      + lra.
+      + { split.
+          - apply Qpower_pos; lra.
+          - apply Qpower_le_compat.
+            + subst; unfold CReal_from_cauchy_cm; destruct p; lia.
+            + lra. }
+  }
+  apply (CReal_le_lt_trans
+           _ (CReal_abs (xn i - xn j + (xn j - inject_Q (seq (xn j) (Z.neg q' - 2)%Z))))).
+    1: apply CReal_abs_morph; ring.
+  apply (CReal_le_lt_trans _ _ _ (CReal_abs_triang _ _)).
+  rewrite inject_Q_plus.
+  apply CReal_plus_le_lt_compat.
+  {
+    apply (CReal_le_trans _ _ _ H). apply inject_Q_le.
+    rewrite Q_factorDenom.
+    rewrite <- (Z.pow_1_l (Z.pos n')) at 2 by lia.
+    rewrite <- (Qpower_decomp').
+    change (1#2)%Q with (/2)%Q; rewrite Qinv_power, <- Qpower_opp.
+    apply Qmult_le_compat_nonneg.
+    - lra.
+    - { split.
+        - apply Qpower_pos; lra.
+        - apply Qpower_le_compat.
+          + subst; unfold CReal_from_cauchy_cm; destruct n; lia.
+          + lra. }
+  }
+  apply (CReal_le_lt_trans _ (inject_Q ((1#4)*2^(Z.neg q')))).
+  {
+    change (1#4)%Q with ((1#2)^2)%Q.
+    rewrite Qmult_comm, <- Qpower_minus_pos.
+    apply CReal_cv_self'.
+  }
+  apply inject_Q_lt.
+  setoid_rewrite Qmult_comm at 1 2.
+  apply Qmult_lt_le_compat_nonneg.
+  + { split.
+      - apply Qpower_pos_lt; lra.
+      - apply Qpower_le_compat.
+        + subst; unfold CReal_from_cauchy_cm. destruct q; lia.
+        + lra. }
+  + lra.
+Qed.
+
+Lemma Rup_pos (x : CReal)
+  : { n : positive  &  x < inject_Q (Z.pos n # 1) }.
+Proof.
+  intros. destruct (CRealArchimedean x) as [p [maj _]].
+  destruct p.
+  - exists 1%positive. apply (CReal_lt_trans _ 0 _ maj). apply CRealLt_0_1.
+  - exists p. exact maj.
+  - exists 1%positive. apply (CReal_lt_trans _ (inject_Q (Z.neg p # 1)) _ maj).
+    apply (CReal_lt_trans _ 0). apply inject_Q_lt. reflexivity.
+    apply CRealLt_0_1.
+Qed.
+
+Lemma CReal_abs_upper_bound (x : CReal)
+  : { n : positive  &  CReal_abs x < inject_Q (Z.pos n # 1) }.
+Proof.
+  intros.
+  destruct (Rup_pos x) as [np Hnp].
+  destruct (Rup_pos (-x)) as [nn Hnn].
+  exists (Pos.max np nn).
+  apply Rabs_def1.
+  - apply (CReal_lt_le_trans _ _ _ Hnp), inject_Q_le.
+    unfold Qle, Qnum, Qden; ring_simplify. lia.
+  - apply (CReal_lt_le_trans _ _ _ Hnn), inject_Q_le.
+    unfold Qle, Qnum, Qden; ring_simplify. lia.
+Qed.
+
+Require Import Qminmax.
+
+Lemma CRealLt_QR_from_single_dist : forall (q : Q) (r : CReal) (n :Z),
+    (2^n < seq r n - q)%Q
+ -> inject_Q q < r .
+Proof.
+  intros q r n Hapart.
+  pose proof Qpower_pos_lt 2 n ltac:(lra) as H2npos.
+  destruct (QarchimedeanLowExp2_Z (seq r n - q - 2^n) ltac:(lra)) as [k Hk].
+  unfold CRealLt; exists (Z.min n (k-1))%Z.
+  unfold inject_Q; rewrite CReal_red_seq.
+  pose proof cauchy r n n (Z.min n (k-1))%Z ltac:(lia) ltac:(lia) as Hrbnd.
+  pose proof Qpower_le_compat 2 (Z.min n (k - 1))%Z (k-1)%Z ltac:(lia) ltac:(lra).
+  apply (Qmult_le_l _ _ 2 ltac:(lra)) in H.
+  apply (Qle_lt_trans _ _ _ H); clear H.
+  rewrite Qpower_minus_pos.
+  ring_simplify.
+  apply Qabs_Qlt_condition in Hrbnd.
+  lra.
+Qed.
+
+Lemma CReal_abs_Qabs: forall (x : CReal) (q : Q) (n : Z),
+    CReal_abs x <= inject_Q q
+ -> (Qabs (seq x n) <= q + 2^n)%Q.
+Proof.
+  intros x q n Hr.
+  unfold CRealLe in Hr.
+  apply Qnot_lt_le; intros Hq; apply Hr; clear Hr.
+  apply (CRealLt_QR_from_single_dist _ _ n%Z).
+  unfold CReal_abs, CReal_abs_seq; rewrite CReal_red_seq.
+  lra.
+Qed.
+
+Lemma CReal_abs_Qabs_seq: forall (x : CReal) (n : Z),
+    (seq (CReal_abs x) n == Qabs (seq x n))%Q.
+Proof.
+  intros x n.
+  unfold CReal_abs, CReal_abs_seq; rewrite CReal_red_seq.
+  reflexivity.
 Qed.
 
+Lemma CReal_abs_Qabs_diff: forall (x y : CReal) (q : Q) (n : Z),
+    CReal_abs (x - y) <= inject_Q q
+ -> (Qabs (seq x n - seq y n) <= q + 2*2^n)%Q.
+Proof.
+  intros x y q n Hr.
+  unfold CRealLe in Hr.
+  apply Qnot_lt_le; intros Hq; apply Hr; clear Hr.
+  apply (CRealLt_QR_from_single_dist _ _ (n+1)%Z).
+  unfold CReal_abs, CReal_abs_seq; rewrite CReal_red_seq.
+  unfold CReal_minus, CReal_plus, CReal_plus_seq; rewrite CReal_red_seq, Qred_correct.
+  unfold CReal_opp, CReal_opp_seq; rewrite CReal_red_seq.
+  ring_simplify (n + 1 - 1)%Z.
+  rewrite Qpower_plus by lra.
+  ring_simplify; change (seq x n + - seq y n)%Q with (seq x n - seq y n)%Q.
+  lra.
+Qed.
+
+(** Note: the <= in the conclusion is likely tight *)
+
+Lemma CRealLt_QR_to_single_dist : forall (q : Q) (x : CReal) (n : Z),
+    inject_Q q < x -> (-(2^n) <= seq x n - q)%Q.
+Proof.
+  intros q x n Hqltx.
+  destruct (Qlt_le_dec (seq x n - q) (-(2^n))  ) as [Hdec|Hdec].
+  - exfalso.
+    pose proof CRealLt_RQ_from_single_dist x q n ltac:(lra) as contra.
+    apply CRealLt_asym in contra. apply contra, Hqltx.
+  - apply Hdec.
+Qed.
+
+Lemma CRealLt_RQ_to_single_dist : forall (x : CReal) (q : Q) (n : Z),
+    x < inject_Q q -> (-(2^n) <= q - seq x n)%Q.
+Proof.
+  intros x q n Hxltq.
+  destruct (Qlt_le_dec (q - seq x n) (-(2^n))  ) as [Hdec|Hdec].
+  - exfalso.
+    pose proof CRealLt_QR_from_single_dist q x n ltac:(lra) as contra.
+    apply CRealLt_asym in contra. apply contra, Hxltq.
+  - apply Hdec.
+Qed.
+
+Lemma Pos2Z_pos_is_pos : forall (p : positive),
+    (1 <= Z.pos p)%Z.
+Proof.
+  intros p.
+  lia.
+Qed.
+
+Lemma Pos_log2floor_plus1_spec_Qpower : forall (p : positive),
+    (2 ^ Z.pos (Pos_log2floor_plus1 p) <= 2 * (Z.pos p#1) < 2 * 2 ^ Z.pos (Pos_log2floor_plus1 p))%Q.
+Proof.
+  intros p; split.
+  -  rewrite Qpower_decomp', Pos_pow_1_r.
+     unfold Qle, Qmult, Qnum, Qden.
+     rewrite Pos.mul_1_r; ring_simplify.
+     pose proof Pos_log2floor_plus1_spec p as Hpos.
+     lia.
+  -  rewrite Qpower_decomp', Pos_pow_1_r.
+     unfold Qlt, Qmult, Qnum, Qden.
+     rewrite Pos.mul_1_r; ring_simplify.
+     pose proof Pos_log2floor_plus1_spec p as Hpos.
+     lia.
+Qed.
+
+Lemma Qabs_Qgt_condition: forall x y : Q,
+  (x < Qabs y)%Q <-> (x < y \/ x < -y)%Q.
+Proof.
+ intros x y.
+ apply Qabs_case; lra.
+Qed.
+
+Lemma CReal_from_cauchy_seq_bound :
+  forall (xn : nat -> CReal) (xcau : Un_cauchy_mod xn) (i j : Z),
+    (Qabs (CReal_from_cauchy_seq xn xcau i - CReal_from_cauchy_seq xn xcau j) <= 1)%Q.
+Proof.
+  intros xn xcau i j.
+  unfold CReal_from_cauchy_seq.
+  destruct (xcau (4 * 2 ^ CReal_from_cauchy_cm i)%positive) as [i' imaj].
+  destruct (xcau (4 * 2 ^ CReal_from_cauchy_cm j)%positive) as [j' jmaj].
+
+  assert (CReal_abs (xn i' - xn j') <= inject_Q (1#4)) as Hxij.
+    {
+    destruct (le_lt_dec i' j').
+    - apply (CReal_le_trans _ _ _ (imaj i' j' (le_refl _) l)).
+      apply inject_Q_le; unfold Qle, Qnum, Qden; ring_simplify.
+      apply Pos2Z_pos_is_pos.
+    - apply le_S, le_S_n in l.
+      apply (CReal_le_trans _ _ _ (jmaj i' j' l (le_refl _))).
+      apply inject_Q_le; unfold Qle, Qnum, Qden; ring_simplify.
+      apply Pos2Z_pos_is_pos.
+    }
+  clear imaj jmaj.
+  unfold CReal_abs, CReal_abs_seq in Hxij.
+  unfold CRealLe, CRealLt in Hxij.
+  rewrite CReal_red_seq in Hxij.
+  apply Qnot_lt_le; intros Hxij'; apply Hxij; clear Hxij.
+  exists (-2)%Z.
+  unfold inject_Q; rewrite CReal_red_seq.
+  unfold CReal_minus, CReal_plus, CReal_plus_seq; rewrite CReal_red_seq, Qred_correct.
+  unfold CReal_opp, CReal_opp_seq; rewrite CReal_red_seq.
+  change (2 * 2 ^ (-2))%Q with (2#4)%Q.
+  pose proof cauchy (xn i') (-3)%Z (-3)%Z (Z.neg (CReal_from_cauchy_cm i) - 2)%Z
+    ltac:(lia) ltac:(unfold CReal_from_cauchy_cm; destruct i; lia) as Hxibnd.
+  pose proof cauchy (xn j') (-3)%Z (-3)%Z (Z.neg (CReal_from_cauchy_cm j) - 2)%Z
+    ltac:(lia) ltac:(unfold CReal_from_cauchy_cm; destruct j; lia) as Hxjbnd.
+  apply (Qplus_lt_l _ _ (1 # 4)%Q); ring_simplify.
+  (* ToDo: ring_simplify should return reduced fractions *)
+  setoid_replace (12#16)%Q with (3#4)%Q by ring.
+  change (2^(-3))%Q with (1#8)%Q in Hxibnd, Hxjbnd.
+  change (-2-1)%Z with (-3)%Z.
+  apply Qabs_Qlt_condition in Hxibnd.
+  apply Qabs_Qlt_condition in Hxjbnd.
+  apply Qabs_Qgt_condition.
+  apply Qabs_Qgt_condition in Hxij'.
+  lra.
+Qed.
+
+Definition CReal_from_cauchy_scale (xn : nat -> CReal) (xcau : Un_cauchy_mod xn) : Z :=
+  Qbound_lt_ZExp2 (Qabs (CReal_from_cauchy_seq xn xcau (-1)) + 2)%Q.
+
+Lemma CReal_from_cauchy_bound : forall (xn : nat -> CReal) (xcau : Un_cauchy_mod xn),
+  QBound (CReal_from_cauchy_seq xn xcau) (CReal_from_cauchy_scale xn xcau).
+Proof.
+  intros xn xcau n.
+  unfold CReal_from_cauchy_scale.
+
+  (* Use the spec of Qbound_lt_ZExp2 to linearize the RHS *)
+  apply (Qlt_trans_swap_hyp _ _ _ (Qbound_lt_ZExp2_spec _)).
+
+  (* Massage the goal so that CReal_from_cauchy_seq_bound can be applied *)
+  apply (Qplus_lt_l _ _ (-Qabs (CReal_from_cauchy_seq xn xcau (-1)))%Q); ring_simplify.
+  assert(forall x y : Q, (x + -1*y == x-y)%Q) as Aux
+    by (intros x y; lra); rewrite Aux; clear Aux.
+  apply (Qle_lt_trans _ _ _ (Qabs_triangle_reverse _ _)).
+  apply (Qle_lt_trans _ 1%Q _).
+    2: lra.
+  apply CReal_from_cauchy_seq_bound.
+Qed.
+
+Definition CReal_from_cauchy (xn : nat -> CReal) (xcau : Un_cauchy_mod xn) : CReal :=
+{|
+  seq := CReal_from_cauchy_seq xn xcau;
+  scale := CReal_from_cauchy_scale xn xcau;
+  cauchy := CReal_from_cauchy_cauchy xn xcau;
+  bound := CReal_from_cauchy_bound xn xcau
+|}.
+
 Lemma Rcauchy_complete : forall (xn : nat -> CReal),
     Un_cauchy_mod xn
     -> { l : CReal  &  seq_cv xn l }.
 Proof.
   intros xn cau.
-  exists (exist _ (fun n : positive =>
-                let (p, _) := cau (4 * n)%positive in
-                proj1_sig (xn p) (4 * n)%positive)
-           (Rcauchy_limit xn cau)).
+  exists (CReal_from_cauchy xn cau).
+
   intro p.
-  pose proof (CReal_cv_self (exist _ (fun n : positive =>
-                let (p, _) := cau (4 * n)%positive in
-                proj1_sig (xn p) (4 * n)%positive)
-           (Rcauchy_limit xn cau)) (2*p)) as H.
-  unfold proj1_sig in H.
+  pose proof (CReal_cv_self' (CReal_from_cauchy xn cau) (Z.neg p - 1)%Z) as H.
+
   pose proof (cau (2*p)%positive) as [k cv].
-  destruct (cau (4 * (2 * p))%positive) as [i imaj].
-  (* The convergence modulus does not matter here, because a converging Cauchy
-     sequence always converges to its limit with twice the Cauchy modulus. *)
+
+  rewrite CReal_abs_minus_sym in H.
+  unfold CReal_from_cauchy at 1 in H.
+  rewrite CReal_red_seq in H.
+  unfold CReal_from_cauchy_seq in H.
+  remember (CReal_from_cauchy_cm (Z.neg p - 1))%positive as i'.
+  destruct (cau (4 * 2 ^ i')%positive) as [i imaj].
   exists (max k i).
+
   intros j H0.
-  setoid_replace (xn j -
-     exist (fun x : positive -> Q => QCauchySeq x)
-       (fun n : positive =>
-        let (p0, _) := cau (4 * n)%positive in proj1_sig (xn p0) (4 * n)%positive)
-       (Rcauchy_limit xn cau))
-    with (xn j - inject_Q (proj1_sig (xn i) (p~0~0~0)%positive)
-          + (inject_Q (proj1_sig (xn i) (p~0~0~0)%positive) -
-     exist (fun x : positive -> Q => QCauchySeq x)
-       (fun n : positive =>
-        let (p0, _) := cau (4 * n)%positive in proj1_sig (xn p0) (4 * n)%positive)
-       (Rcauchy_limit xn cau))).
-  2: ring. apply (CReal_le_trans _ _ _ (CReal_abs_triang _ _)).
+  setoid_replace (xn j - CReal_from_cauchy xn cau)
+  with (xn j -  inject_Q (seq (xn i) (Z.neg i' - 2)%Z)
+     + (inject_Q (seq (xn i) (Z.neg i' - 2)%Z) - CReal_from_cauchy xn cau)).
+  2: ring.
+  apply (CReal_le_trans _ _ _ (CReal_abs_triang _ _)).
   apply (CReal_le_trans _ (inject_Q (1#2*p) + inject_Q (1#2*p))).
-  apply CReal_plus_le_compat. unfold proj1_sig in H.
-  2: rewrite CReal_abs_minus_sym; exact H.
+  apply CReal_plus_le_compat.
+  2: { apply (CReal_le_trans _ _ _ H). apply inject_Q_le.
+       rewrite Qpower_minus_pos.
+       assert(forall (n:Z) (p q : positive), n#(p*q) == (n#p) * (1#q))%Q as Aux
+         by ( intros; unfold Qeq, Qmult, Qnum, Qden; ring ); rewrite Aux; clear Aux.
+       rewrite Qmult_comm; apply Qmult_le_l; [lra|].
+       pose proof Qpower_2powneg_le_inv p.
+       pose proof Qpower_pos_lt 2 (Z.neg p)%Z; lra. }
+
+  (* Use imaj to relate xn i and xn j *)
   specialize (imaj j i (le_trans _ _ _ (Nat.le_max_r _ _) H0) (le_refl _)).
-  apply (CReal_le_trans _ (inject_Q (1 # 4 * p) + inject_Q (1 # 4 * p))).
-  setoid_replace (xn j - inject_Q (proj1_sig (xn i) (p~0~0~0)%positive))
-    with (xn j - xn i
-          + (xn i - inject_Q (proj1_sig (xn i) (p~0~0~0)%positive))).
-  2: ring. apply (CReal_le_trans _ _ _ (CReal_abs_triang _ _)).
-  apply CReal_plus_le_compat. apply (CReal_le_trans _ _ _ imaj).
-  apply inject_Q_le. unfold Qle, Qnum, Qden.
-  rewrite Z.mul_1_l, Z.mul_1_l.
-  apply Pos2Z.pos_le_pos.
-  apply (Pos.mul_le_mono_r p 4 8). discriminate.
-  apply (CReal_le_trans _ _ _ (CReal_cv_self (xn i) (8*p))).
-  apply inject_Q_le. unfold Qle, Qnum, Qden.
-  rewrite Z.mul_1_l, Z.mul_1_l.
-  apply Pos2Z.pos_le_pos.
-  apply (Pos.mul_le_mono_r p 4 8). discriminate.
+    apply (CReal_le_trans _ (inject_Q (1 # 4 * p) + inject_Q (1 # 4 * p))).
+    setoid_replace (xn j - inject_Q (seq (xn i) (Z.neg i' - 2)))
+    with (xn j - xn i + (xn i - inject_Q (seq (xn i) (Z.neg i' - 2)))).
+      2: ring.
+    apply (CReal_le_trans _ _ _ (CReal_abs_triang _ _)).
+    apply CReal_plus_le_compat. apply (CReal_le_trans _ _ _ imaj).
+    rewrite Heqi'. change (Z.neg p - 1)%Z with (Z.neg (p + 1))%Z.
+    unfold CReal_from_cauchy_cm.
+    apply inject_Q_le.
+    unfold Qle, Qnum, Qden.
+    rewrite Z.mul_1_l, Z.mul_1_l.
+    apply Pos2Z.pos_le_pos, Pos.mul_le_mono_l.
+    pose proof Pospow_lin_le_2pow p.
+    rewrite Pos.add_1_r, Pos.pow_succ_r.
+    lia.
+    clear imaj.
+
+  (* Use CReal_cv_self' to relate xn i and seq (xn i) (...) *)
+  pose proof CReal_cv_self' (xn i) (Z.neg i' - 2).
+    apply (CReal_le_trans _ _ _ H1).
+    apply inject_Q_le.
+    rewrite Heqi'. change (Z.neg p - 1)%Z with (Z.neg (p + 1))%Z.
+    unfold CReal_from_cauchy_cm.
+    change (Z.neg (p + 1))%Z with (Z.neg p - 1)%Z.
+    ring_simplify (Z.neg p - 1 - 2)%Z.
+    rewrite Qpower_minus_pos.
+    assert(forall (n:Z) (p q : positive), n#(p*q) == (n#p) * (1#q))%Q as Aux
+      by ( intros; unfold Qeq, Qmult, Qnum, Qden; ring ); rewrite Aux; clear Aux.
+    pose proof Qpower_2powneg_le_inv p.
+    pose proof Qpower_pos_lt 2 (Z.neg p)%Z; lra.
+
+  (* Solve remaining aux goals *)
   rewrite <- inject_Q_plus. rewrite (inject_Q_morph _ (1#2*p)).
   apply CRealLe_refl. rewrite Qinv_plus_distr; reflexivity.
   rewrite <- inject_Q_plus. rewrite (inject_Q_morph _ (1#p)).
@@ -310,6 +690,65 @@ Proof.
   exists x. exact c.
 Defined.
 
+(* ToDO: Belongs into sumbool.v *)
+Section connectives.
+
+  Variables A B : Prop.
+
+  Hypothesis H1 : {A} + {~A}.
+  Hypothesis H2 : {B} + {~B}.
+
+  Definition sumbool_or_not_or : {A \/ B} + {~(A \/ B)}.
+    case H1; case H2; tauto.
+  Defined.
+
+End connectives.
+
+Lemma Qnot_le_iff_lt: forall x y : Q,
+  ~ (x <= y)%Q <-> (y < x)%Q.
+Proof.
+  intros x y; split.
+  - apply Qnot_le_lt.
+  - apply Qlt_not_le.
+Qed.
+
+Lemma Qnot_lt_iff_le: forall x y : Q,
+  ~ (x < y)%Q <-> (y <= x)%Q.
+Proof.
+  intros x y; split.
+  - apply Qnot_lt_le.
+  - apply Qle_not_lt.
+Qed.
+
+Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal,
+    (CRealLtProp a b \/ CRealLtProp c d) -> CRealLt a b  +  CRealLt c d.
+Proof.
+  intros.
+  (* Combine both existentials into one *)
+  assert (exists n : Z, 2*2^n < seq b n - seq a n \/ 2*2^n < seq d n - seq c n)%Q.
+  { destruct H.
+    - destruct H as [n maj]. exists n. left. apply maj.
+    - destruct H as [n maj]. exists n. right. apply maj. }
+  apply constructive_indefinite_ground_description_Z in H0.
+  - destruct H0 as [n maj].
+    destruct (Qlt_le_dec (2 * 2^n) (seq b n - seq a n)).
+    + left. exists n. apply q.
+    + assert (2 * 2^n < seq d n - seq c n)%Q.
+      { destruct maj. exfalso.
+        apply (Qlt_not_le (2 * 2^n) (seq b n - seq a n)); assumption.
+        assumption. }
+      clear maj. right. exists n.
+      apply H0.
+  - clear H0 H. intro n.
+    apply sumbool_or_not_or.
+    + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq b n - seq a n)%Q).
+      * left; assumption.
+      * right; apply Qle_not_lt; assumption.
+    + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq d n - seq c n)%Q).
+      * left; assumption.
+      * right; apply Qle_not_lt; assumption.
+Qed.
+
 Definition CRealConstructive : ConstructiveReals
   := Build_ConstructiveReals
        CReal CRealLt CRealLtIsLinear CRealLtProp
diff --git a/theories/Reals/Cauchy/PosExtra.v b/theories/Reals/Cauchy/PosExtra.v
new file mode 100644
index 0000000000..8f4d5c4fa4
--- /dev/null
+++ b/theories/Reals/Cauchy/PosExtra.v
@@ -0,0 +1,32 @@
+Require Import PArith.
+Require Import ZArith.
+Require Import Lia.
+
+Lemma Pos_pow_1_r: forall p : positive,
+  (1^p = 1)%positive.
+Proof.
+  intros p.
+  assert (forall q:positive, Pos.iter id 1 q = 1)%positive as H1.
+  { intros q; apply Pos.iter_invariant; tauto. }
+  induction p.
+  - cbn; rewrite IHp, H1; reflexivity.
+  - cbn; rewrite IHp, H1; reflexivity.
+  - reflexivity.
+Qed.
+
+Lemma Pos_le_multiple : forall n p : positive, (n <= p * n)%positive.
+Proof.
+  intros n p.
+  rewrite <- (Pos.mul_1_l n) at 1.
+  apply Pos.mul_le_mono_r.
+  destruct p; discriminate.
+Qed.
+
+Lemma Pos_pow_le_mono_r : forall a b c : positive,
+    (b <= c)%positive
+ -> (a ^ b <= a ^ c)%positive.
+Proof.
+  intros a b c.
+  pose proof Z.pow_le_mono_r (Z.pos a) (Z.pos b) (Z.pos c).
+  lia.
+Qed.
diff --git a/theories/Reals/Cauchy/QExtra.v b/theories/Reals/Cauchy/QExtra.v
new file mode 100644
index 0000000000..8b39c056e4
--- /dev/null
+++ b/theories/Reals/Cauchy/QExtra.v
@@ -0,0 +1,637 @@
+Require Import QArith.
+Require Import Qpower.
+Require Import Qabs.
+Require Import Qround.
+Require Import Lia.
+Require Import Lqa. (* This is only used in a few places and could be avoided *)
+Require Import PosExtra.
+
+(** * Lemmas on Q numerator denominator operations *)
+
+Lemma Q_factorDenom : forall (a:Z) (b d:positive), (a # (d * b)) == (1#d) * (a#b).
+Proof.
+  intros. unfold Qeq. simpl. destruct a; reflexivity.
+Qed.
+
+Lemma Q_factorNum_l : forall (a b : Z) (c : positive),
+  (a*b # c == (a # 1) * (b # c))%Q.
+Proof.
+  intros a b c.
+  unfold Qeq; cbn; lia.
+Qed.
+
+Lemma Q_factorNum : forall (a : Z) (b : positive),
+  (a # b == (a # 1) * (1 # b))%Q.
+Proof.
+  intros a b.
+  unfold Qeq; cbn; lia.
+Qed.
+
+Lemma Q_reduce_fl : forall (a b : positive),
+  (Z.pos a # a * b == (1 # b))%Q.
+Proof.
+  intros a b.
+  unfold Qeq; cbn; lia.
+Qed.
+
+(** * Lemmas on Q comparison *)
+
+Lemma Qle_neq: forall p q : Q, p < q <-> p <= q /\ ~ (p == q).
+Proof.
+  intros p q; split; intros H.
+  - rewrite Qlt_alt in H; rewrite Qle_alt, Qeq_alt.
+    rewrite H; split; intros H1; inversion H1.
+  - rewrite Qlt_alt; rewrite Qle_alt, Qeq_alt in H.
+    destruct (p ?= q); tauto.
+Qed.
+
+Lemma Qplus_lt_compat : forall x y z t : Q,
+  (x < y)%Q -> (z < t)%Q -> (x + z < y + t)%Q.
+Proof.
+  intros x y z t H1 H2.
+  apply Qplus_lt_le_compat.
+  - assumption.
+  - apply Qle_lteq; left; assumption.
+Qed.
+
+(* Qgt is just a notation, but one might now know this and search for this lemma *)
+
+Lemma Qgt_lt: forall p q : Q, p > q -> q < p.
+Proof.
+  intros p q H; assumption.
+Qed.
+
+Lemma Qlt_gt: forall p q : Q, p < q -> q > p.
+Proof.
+  intros p q H; assumption.
+Qed.
+
+Notation "x <= y < z" := (x<=y/\y<z) : Q_scope.
+Notation "x < y <= z" := (x<y/\y<=z) : Q_scope.
+Notation "x < y < z" := (x<y/\y<z) : Q_scope.
+
+(** * Lemmas on Qmult *)
+
+Lemma Qmult_lt_0_compat : forall a b : Q,
+    0 < a
+ -> 0 < b
+ -> 0 < a * b.
+Proof.
+  intros a b Ha Hb.
+  destruct a,b. unfold Qlt, Qmult, QArith_base.Qnum, QArith_base.Qden in *.
+  rewrite Pos2Z.inj_mul.
+  rewrite Z.mul_0_l, Z.mul_1_r in *.
+  apply Z.mul_pos_pos; assumption.
+Qed.
+
+Lemma Qmult_lt_1_compat:
+  forall a b : Q, (1 < a)%Q -> (1 < b)%Q -> (1 < a * b)%Q.
+Proof.
+  intros a b Ha Hb.
+  pose proof Qmult_lt_0_compat (a-1) (b-1) ltac:(lra) ltac:(lra).
+  lra.
+Qed.
+
+Lemma Qmult_le_1_compat:
+  forall a b : Q, (1 <= a)%Q -> (1 <= b)%Q -> (1 <= a * b)%Q.
+Proof.
+  intros a b Ha Hb.
+  pose proof Qmult_le_0_compat (a-1) (b-1) ltac:(lra) ltac:(lra).
+  lra.
+Qed.
+
+Lemma Qmult_lt_compat_nonneg: forall x y z t : Q,
+  (0 <= x < y)%Q -> (0 <= z < t)%Q -> (x * z < y * t)%Q.
+Proof.
+  intros [xn xd] [yn yd] [zn zd] [tn td] [H0lex Hxlty] [H0lez Hzltt].
+  (* ToDo: why do I need path qualification to Qnum? It is exported by QArith *)
+  unfold Qmult, Qlt, Qle, QArith_base.Qnum, QArith_base.Qden in *.
+  do 2 rewrite Pos2Z.inj_mul.
+  setoid_replace (xn * zn * (Z.pos yd * Z.pos td))%Z with ((xn * Z.pos yd) * (zn * Z.pos td))%Z by ring.
+  setoid_replace (yn * tn * (Z.pos xd * Z.pos zd))%Z with ((yn * Z.pos xd) * (tn * Z.pos zd))%Z by ring.
+  apply Z.mul_lt_mono_nonneg.
+  - rewrite <- (Z.mul_0_l 0); apply Z.mul_le_mono_nonneg; lia.
+  - exact Hxlty.
+  - rewrite <- (Z.mul_0_l 0); apply Z.mul_le_mono_nonneg; lia.
+  - exact Hzltt.
+Qed.
+
+Lemma Qmult_lt_le_compat_nonneg: forall x y z t : Q,
+  (0 < x <= y)%Q -> (0 < z < t)%Q -> (x * z < y * t)%Q.
+Proof.
+  intros [xn xd] [yn yd] [zn zd] [tn td] [H0lex Hxlty] [H0lez Hzltt].
+  (* ToDo: why do I need path qualification to Qnum? It is exported by QArith *)
+  unfold Qmult, Qlt, Qle, QArith_base.Qnum, QArith_base.Qden in *.
+  do 2 rewrite Pos2Z.inj_mul.
+  setoid_replace (xn * zn * (Z.pos yd * Z.pos td))%Z with ((xn * Z.pos yd) * (zn * Z.pos td))%Z by ring.
+  setoid_replace (yn * tn * (Z.pos xd * Z.pos zd))%Z with ((yn * Z.pos xd) * (tn * Z.pos zd))%Z by ring.
+  apply Zmult_lt_compat2; split.
+  - rewrite <- (Z.mul_0_l 0). apply Z.mul_lt_mono_nonneg; lia.
+  - exact Hxlty.
+  - rewrite <- (Z.mul_0_l 0). apply Z.mul_lt_mono_nonneg; lia.
+  - exact Hzltt.
+Qed.
+
+Lemma Qmult_le_compat_nonneg: forall x y z t : Q,
+  (0 <= x <= y)%Q -> (0 <= z <= t)%Q -> (x * z <= y * t)%Q.
+Proof.
+  intros [xn xd] [yn yd] [zn zd] [tn td] [H0lex Hxlty] [H0lez Hzltt].
+  (* ToDo: why do I need path qualification to Qnum? It is exported by QArith *)
+  unfold Qmult, Qlt, Qle, QArith_base.Qnum, QArith_base.Qden in *.
+  do 2 rewrite Pos2Z.inj_mul.
+  setoid_replace (xn * zn * (Z.pos yd * Z.pos td))%Z with ((xn * Z.pos yd) * (zn * Z.pos td))%Z by ring.
+  setoid_replace (yn * tn * (Z.pos xd * Z.pos zd))%Z with ((yn * Z.pos xd) * (tn * Z.pos zd))%Z by ring.
+  apply Z.mul_le_mono_nonneg.
+  - rewrite <- (Z.mul_0_l 0); apply Z.mul_le_mono_nonneg; lia.
+  - exact Hxlty.
+  - rewrite <- (Z.mul_0_l 0); apply Z.mul_le_mono_nonneg; lia.
+  - exact Hzltt.
+Qed.
+
+(** * Lemmas on Qinv *)
+
+Lemma Qinv_swap_pos: forall (a b : positive),
+  Z.pos a # b == / (Z.pos b # a).
+Proof.
+  intros a b.
+  reflexivity.
+Qed.
+
+Lemma Qinv_swap_neg: forall (a b : positive),
+  Z.neg a # b == / (Z.neg b # a).
+Proof.
+  intros a b.
+  reflexivity.
+Qed.
+
+(** * Lemmas on Qabs *)
+
+Lemma Qabs_Qlt_condition: forall x y : Q,
+  Qabs x < y <-> -y < x < y.
+Proof.
+ split.
+  split.
+   rewrite <- (Qopp_opp x).
+   apply Qopp_lt_compat.
+   apply Qle_lt_trans with (Qabs (-x)).
+   apply Qle_Qabs.
+   now rewrite Qabs_opp.
+  apply Qle_lt_trans with (Qabs x); auto using Qle_Qabs.
+ intros (H,H').
+ apply Qabs_case; trivial.
+ intros. rewrite <- (Qopp_opp y). now apply Qopp_lt_compat.
+Qed.
+
+Lemma Qabs_gt: forall r s : Q,
+    (r < s)%Q -> (r < Qabs s)%Q.
+Proof.
+  intros r s Hrlts.
+  apply Qabs_case; intros; lra.
+Qed.
+
+(** * Lemmas on Qpower *)
+
+Lemma Qpower_0_r: forall q:Q,
+  q^0 == 1.
+Proof.
+  intros q.
+  reflexivity.
+Qed.
+
+Lemma Qpower_1_r: forall q:Q,
+  q^1 == q.
+Proof.
+  intros q.
+  reflexivity.
+Qed.
+
+Lemma Qpower_not_0: forall (a : Q) (z : Z),
+  ~ a == 0 -> ~ Qpower a z == 0.
+Proof.
+  intros a z H; destruct z.
+  - discriminate.
+  - apply Qpower_not_0_positive; assumption.
+  - cbn. intros H1.
+    pose proof Qmult_inv_r (Qpower_positive a p) as H2.
+    specialize (H2 (Qpower_not_0_positive _ _ H)).
+    rewrite H1, Qmult_0_r in H2.
+    discriminate H2.
+Qed.
+
+(* Actually Qpower_pos should be named Qpower_nonneg *)
+
+Lemma Qpower_pos_lt: forall (a : Q) (z : Z),
+  a > 0 -> Qpower a z > 0.
+Proof.
+  intros q z Hpos.
+  pose proof Qpower_pos q z (Qlt_le_weak 0 q Hpos) as H1.
+  pose proof Qpower_not_0 q z as H2.
+  pose proof Qlt_not_eq 0 q Hpos as H3.
+  specialize (H2 (Qnot_eq_sym _ _ H3)); clear H3.
+  apply Qnot_eq_sym in H2.
+  apply Qle_neq; split; assumption.
+Qed.
+
+Lemma Qpower_minus: forall (a : Q) (n m : Z),
+  ~ a == 0 -> a ^ (n - m) == a ^ n / a ^ m.
+Proof.
+  intros a n m Hnz.
+  rewrite <- Z.add_opp_r.
+  rewrite Qpower_plus by assumption.
+  rewrite Qpower_opp.
+  field.
+  apply Qpower_not_0; assumption.
+Qed.
+
+Lemma Qpower_minus_pos: forall (a b : positive) (n m : Z),
+  (Z.pos a#b) ^ (n - m) == (Z.pos a#b) ^ n * (Z.pos b#a) ^ m.
+Proof.
+  intros a b n m.
+  rewrite Qpower_minus by discriminate.
+  rewrite (Qinv_swap_pos b a), Qinv_power.
+  reflexivity.
+Qed.
+
+Lemma Qpower_minus_neg: forall (a b : positive) (n m : Z),
+  (Z.neg a#b) ^ (n - m) == (Z.neg a#b) ^ n * (Z.neg b#a) ^ m.
+Proof.
+  intros a b n m.
+  rewrite Qpower_minus by discriminate.
+  rewrite (Qinv_swap_neg b a), Qinv_power.
+  reflexivity.
+Qed.
+
+Lemma Qpower_lt_1_increasing:
+  forall (q : Q) (n : positive), (1<q)%Q -> (1 < q ^ (Z.pos n))%Q.
+Proof.
+  intros q n Hq.
+  induction n.
+  - cbn in *.
+    apply Qmult_lt_1_compat. assumption.
+    apply Qmult_lt_1_compat; assumption.
+  - cbn in *.
+    apply Qmult_lt_1_compat; assumption.
+  - cbn; assumption.
+Qed.
+
+Lemma Qpower_lt_1_increasing':
+  forall (q : Q) (n : Z), (1<q)%Q -> (0<n)%Z -> (1 < q ^ n)%Q.
+Proof.
+  intros q n Hq Hn.
+  destruct n.
+  - inversion Hn.
+  - apply Qpower_lt_1_increasing; assumption.
+  - lia.
+Qed.
+
+Lemma Qzero_eq: forall (d : positive),
+  (0#d == 0)%Q.
+Proof.
+  intros d.
+  unfold Qeq, Qnum, Qden; reflexivity.
+Qed.
+
+Lemma Qpower_le_1_increasing:
+  forall (q : Q) (n : positive), (1<=q)%Q -> (1 <= q ^ (Z.pos n))%Q.
+Proof.
+  intros q n Hq.
+  induction n.
+  - cbn in *.
+    apply Qmult_le_1_compat. assumption.
+    apply Qmult_le_1_compat; assumption.
+  - cbn in *.
+    apply Qmult_le_1_compat; assumption.
+  - cbn; assumption.
+Qed.
+
+Lemma Qpower_le_1_increasing':
+  forall (q : Q) (n : Z), (1<=q)%Q -> (0<=n)%Z -> (1 <= q ^ n)%Q.
+Proof.
+  intros q n Hq Hn.
+  destruct n.
+  - apply Qle_refl.
+  - apply Qpower_le_1_increasing; assumption.
+  - lia.
+Qed.
+
+(* ToDo: check if name compat_r is more appropriate *)
+
+Lemma Qpower_lt_compat:
+  forall (q : Q) (n m : Z), (n < m)%Z -> (1<q)%Q -> (q ^ n < q ^ m)%Q.
+Proof.
+  intros q n m Hnm Hq.
+  replace m with (n+(m-n))%Z by ring.
+  rewrite Qpower_plus, <- Qmult_1_r, <- Qmult_assoc.
+    2: lra.
+  rewrite Qmult_lt_l, Qmult_1_l.
+    2: apply Qpower_pos_lt; lra.
+  remember (m-n)%Z as k.
+  apply Qpower_lt_1_increasing'.
+  - exact Hq.
+  - lia.
+Qed.
+
+Lemma Qpower_le_compat:
+  forall (q : Q) (n m : Z), (n <= m)%Z -> (1<=q)%Q -> (q ^ n <= q ^ m)%Q.
+Proof.
+  intros q n m Hnm Hq.
+  replace m with (n+(m-n))%Z by ring.
+  rewrite Qpower_plus, <- Qmult_1_r, <- Qmult_assoc.
+    2: lra.
+  rewrite Qmult_le_l, Qmult_1_l.
+    2: apply Qpower_pos_lt; lra.
+  remember (m-n)%Z as k.
+  apply Qpower_le_1_increasing'.
+  - exact Hq.
+  - lia.
+Qed.
+
+Lemma Qpower_lt_compat_inv:
+  forall (q : Q) (n m : Z), (q ^ n < q ^ m)%Q -> (1<q)%Q -> (n < m)%Z.
+Proof.
+  intros q n m Hnm Hq.
+  destruct (Z_lt_le_dec n m) as [Hd|Hd].
+  - assumption.
+  - pose proof Qpower_le_compat q m n Hd ltac:(lra).
+  lra.
+Qed.
+
+Lemma Qpower_le_compat_inv:
+  forall (q : Q) (n m : Z), (q ^ n <= q ^ m)%Q -> (1<q)%Q -> (n <= m)%Z.
+Proof.
+  intros q n m Hnm Hq.
+  destruct (Z_lt_le_dec m n) as [Hd|Hd].
+  - pose proof Qpower_lt_compat q m n Hd Hq.
+    lra.
+  - assumption.
+Qed.
+
+Lemma Qpower_decomp': forall (p : positive) (a : Z) (b : positive),
+  (a # b) ^ (Z.pos p) == a ^ (Z.pos p) # (b ^ p)%positive.
+Proof.
+  intros p a b.
+  pose proof Qpower_decomp p a b.
+  cbn; rewrite H; reflexivity.
+Qed.
+
+
+(** * Power of 2 open and closed upper and lower bounds for [q : Q] *)
+
+Lemma QarchimedeanExp2_Pos : forall q : Q,
+  {p : positive | (q < Z.pos (2^p) # 1)%Q}.
+Proof.
+  intros q.
+  destruct (Qarchimedean q) as [pexp Hpexp].
+  exists (Pos.size pexp).
+  pose proof Pos.size_gt pexp as H1.
+  unfold Qlt in *. cbn in *; Zify.zify.
+  apply (Z.mul_lt_mono_pos_r (QDen q)) in H1; [|assumption].
+  apply (Z.lt_trans _ _ _ Hpexp H1).
+Qed.
+
+Fixpoint Pos_log2floor_plus1 (p : positive) : positive :=
+  match p with
+  | (p'~1)%positive => Pos.succ (Pos_log2floor_plus1 p')
+  | (p'~0)%positive => Pos.succ (Pos_log2floor_plus1 p')
+  | 1%positive      => 1
+  end.
+
+Lemma Pos_log2floor_plus1_spec : forall (p : positive),
+  (Pos.pow 2 (Pos_log2floor_plus1 p) <= 2 * p < 2 * Pos.pow 2 (Pos_log2floor_plus1 p))%positive.
+Proof.
+  intros p.
+  split.
+  - induction p.
+    + cbn. rewrite Pos.pow_succ_r. lia.
+    + cbn. rewrite Pos.pow_succ_r. lia.
+    + cbn. lia.
+  - induction p.
+    + cbn. rewrite Pos.pow_succ_r. lia.
+    + cbn. rewrite Pos.pow_succ_r. lia.
+    + cbn. lia.
+Qed.
+
+Fixpoint Pos_log2ceil_plus1 (p : positive) : positive :=
+  match p with
+  | (p'~1)%positive => Pos.succ (Pos.succ (Pos_log2floor_plus1 p'))
+  | (p'~0)%positive => Pos.succ (Pos_log2ceil_plus1 p')
+  | 1%positive      => 1
+  end.
+
+Lemma Pos_log2ceil_plus1_spec : forall (p : positive),
+  (Pos.pow 2 (Pos_log2ceil_plus1 p) < 4 * p <= 2 * Pos.pow 2 (Pos_log2ceil_plus1 p))%positive.
+Proof.
+  intros p.
+  split.
+  - induction p.
+    + cbn. do 2 rewrite Pos.pow_succ_r.
+      pose proof Pos_log2floor_plus1_spec p. lia.
+    + cbn. rewrite Pos.pow_succ_r. lia.
+    + cbn. lia.
+  - induction p.
+    + cbn. do 2 rewrite Pos.pow_succ_r.
+      pose proof Pos_log2floor_plus1_spec p. lia.
+    + cbn. rewrite Pos.pow_succ_r. lia.
+    + cbn. lia.
+Qed.
+
+Fixpoint Pos_is_pow2 (p : positive) : bool :=
+  match p with
+  | (p'~1)%positive => false
+  | (p'~0)%positive => Pos_is_pow2 p'
+  | 1%positive      => true
+  end.
+
+(** ** Power of two closed upper bound [q <= 2^z] *)
+
+Definition Qbound_le_ZExp2 (q : Q) : Z :=
+  match Qnum q with
+  (* The -1000 is a compromise between a tight Archimedian and avoiding too large numbers *)
+  | Z0 => -1000
+  | Zneg p => 0
+  | Zpos p => (Z.pos (Pos_log2ceil_plus1 p) - Z.pos (Pos_log2floor_plus1 (Qden q)))%Z
+  end.
+
+Lemma Qbound_le_ZExp2_spec : forall (q : Q),
+  (q <= 2^(Qbound_le_ZExp2 q))%Q.
+Proof.
+  intros q.
+  destruct q as [num den]; unfold Qbound_le_ZExp2, Qnum; destruct num.
+  - intros contra; inversion contra.
+  - rewrite Qpower_minus by lra.
+    apply Qle_shift_div_l.
+      apply Qpower_pos_lt; lra.
+    do 2 rewrite Qpower_decomp', Pos_pow_1_r.
+    unfold Qle, Qmult, Qnum, Qden.
+    rewrite Pos.mul_1_r, Z.mul_1_r.
+    pose proof Pos_log2ceil_plus1_spec p as Hnom.
+    pose proof Pos_log2floor_plus1_spec den as Hden.
+
+    apply (Zmult_le_reg_r _ _ 2).
+        lia.
+    replace (Z.pos p * 2 ^ Z.pos (Pos_log2floor_plus1 den) * 2)%Z
+      with ((Z.pos p * 2) * 2 ^ Z.pos (Pos_log2floor_plus1 den))%Z by ring.
+    replace (2 ^ Z.pos (Pos_log2ceil_plus1 p) * Z.pos den * 2)%Z
+      with (2 ^ Z.pos (Pos_log2ceil_plus1 p) * (Z.pos den * 2))%Z by ring.
+    apply Z.mul_le_mono_nonneg; lia.
+  - intros contra; inversion contra.
+Qed.
+
+Definition Qbound_leabs_ZExp2 (q : Q) : Z := Qbound_le_ZExp2 (Qabs q).
+
+Lemma Qbound_leabs_ZExp2_spec : forall (q : Q),
+  (Qabs q <= 2^(Qbound_leabs_ZExp2 q))%Q.
+Proof.
+  intros q.
+  unfold Qbound_leabs_ZExp2; apply Qabs_case; intros.
+  1,2: apply Qbound_le_ZExp2_spec.
+Qed.
+
+(** ** Power of two open upper bound [q < 2^z] and [Qabs q < 2^z] *)
+
+(** Compute a z such that q<2^z.
+    z shall be close to as small as possible, but we need a compromise between
+    the tighness of the bound and the computation speed and proof complexity.
+    Looking just at the log2 of the numerator and denominator, this is a tight bound
+    except when the numerator is a power of 2 and the denomintor is not.
+    E.g. this return 4/5 < 2^1 instead of 4/5< 2^0.
+    If q==0, we return -1000, because as binary integer this has just 10 bits but
+    2^-1000 should be smaller than almost any number in practice.
+    If numbers are much smaller, computations might be inefficient. *)
+
+Definition Qbound_lt_ZExp2 (q : Q) : Z :=
+  match Qnum q with
+  (* The -1000 is a compromise between a tight Archimedian and avoiding too large numbers *)
+  | Z0 => -1000
+  | Zneg p => 0
+  | Zpos p => Z.pos_sub (Pos.succ (Pos_log2floor_plus1 p)) (Pos_log2floor_plus1 (Qden q))
+  end.
+
+Remark Qbound_lt_ZExp2_test_1 : Qbound_lt_ZExp2 (4#4) = 1%Z. reflexivity. Qed.
+Remark Qbound_lt_ZExp2_test_2 : Qbound_lt_ZExp2 (5#4) = 1%Z. reflexivity. Qed.
+Remark Qbound_lt_ZExp2_test_3 : Qbound_lt_ZExp2 (4#5) = 1%Z. reflexivity. Qed.
+Remark Qbound_lt_ZExp2_test_4 : Qbound_lt_ZExp2 (7#5) = 1%Z. reflexivity. Qed.
+
+Lemma Qbound_lt_ZExp2_spec : forall (q : Q),
+  (q < 2^(Qbound_lt_ZExp2 q))%Q.
+Proof.
+  intros q.
+  destruct q as [num den]; unfold Qbound_lt_ZExp2, Qnum; destruct num.
+  - reflexivity.
+  - (* Todo: A lemma like Pos2Z.add_neg_pos for minus would be nice *)
+    change
+      (Z.pos_sub (Pos.succ (Pos_log2floor_plus1 p)) (Pos_log2floor_plus1 (Qden (Z.pos p # den))))%Z
+    with
+      ((Z.pos (Pos.succ (Pos_log2floor_plus1 p)) - Z.pos (Pos_log2floor_plus1 (Qden (Z.pos p # den)))))%Z.
+    rewrite Qpower_minus by lra.
+    apply Qlt_shift_div_l.
+      apply Qpower_pos_lt; lra.
+    do 2 rewrite Qpower_decomp', Pos_pow_1_r.
+    unfold Qlt, Qmult, Qnum, Qden.
+    rewrite Pos.mul_1_r, Z.mul_1_r.
+    pose proof Pos_log2floor_plus1_spec p as Hnom.
+    pose proof Pos_log2floor_plus1_spec den as Hden.
+    apply (Zmult_lt_reg_r _ _ 2).
+      lia.
+    rewrite Pos2Z.inj_succ, <- Z.add_1_r.
+    rewrite Z.pow_add_r by lia.
+
+    replace (Z.pos p * 2 ^ Z.pos (Pos_log2floor_plus1 den) * 2)%Z
+      with (2 ^ Z.pos (Pos_log2floor_plus1 den) * (Z.pos p * 2))%Z by ring.
+    replace (2 ^ Z.pos (Pos_log2floor_plus1 p) * 2 ^ 1 * Z.pos den * 2)%Z
+      with ((Z.pos den * 2) * (2 * 2 ^ Z.pos (Pos_log2floor_plus1 p)))%Z by ring.
+
+    (* ToDo: this is weaker than neccessary: Z.mul_lt_mono_nonneg. *)
+    apply Zmult_lt_compat2; lia.
+  - cbn.
+    (* ToDo: lra could know that negative fractions are negative *)
+    assert (Z.neg p # den < 0) as Hnegfrac by (unfold Qlt, Qnum, Qden; lia).
+    lra.
+Qed.
+
+Definition Qbound_ltabs_ZExp2 (q : Q) : Z := Qbound_lt_ZExp2 (Qabs q).
+
+Lemma Qbound_ltabs_ZExp2_spec : forall (q : Q),
+  (Qabs q < 2^(Qbound_ltabs_ZExp2 q))%Q.
+Proof.
+  intros q.
+  unfold Qbound_ltabs_ZExp2; apply Qabs_case; intros.
+  1,2: apply Qbound_lt_ZExp2_spec.
+Qed.
+
+(** ** Power of 2 open lower bounds for [2^z < q] and [2^z < Qabs q] *)
+
+(** Note: the -2 is required cause of the Qlt limit.
+    In case q is a power of two, the lower and upper bound must be a factor of 4 apart *)
+Definition Qlowbound_ltabs_ZExp2 (q : Q) : Z := -2 + Qbound_ltabs_ZExp2 q.
+
+Lemma Qlowbound_ltabs_ZExp2_inv: forall q : Q,
+    q > 0
+ -> Qlowbound_ltabs_ZExp2 q = (- Qbound_ltabs_ZExp2 (/q))%Z.
+Proof.
+  intros q Hqgt0.
+  destruct q as [n d].
+  unfold Qlowbound_ltabs_ZExp2, Qbound_ltabs_ZExp2, Qbound_lt_ZExp2, Qnum.
+  destruct n.
+  - inversion Hqgt0.
+  - unfold Qabs, Z.abs, Qinv, Qnum, Qden.
+    rewrite -> Z.pos_sub_opp.
+    do 2 rewrite <- Pos2Z.add_pos_neg.
+    lia.
+  - inversion Hqgt0.
+Qed.
+
+Lemma Qlowbound_ltabs_ZExp2_opp: forall q : Q,
+  (Qlowbound_ltabs_ZExp2 q = Qlowbound_ltabs_ZExp2 (-q))%Z.
+Proof.
+  intros q.
+  destruct q as [[|n|n] d]; reflexivity.
+Qed.
+
+Lemma Qlowbound_lt_ZExp2_spec : forall (q : Q) (Hqgt0 : q > 0),
+  (2^(Qlowbound_ltabs_ZExp2 q) < q)%Q.
+Proof.
+  intros q Hqgt0.
+  pose proof Qbound_ltabs_ZExp2_spec (/q) as Hspecub.
+  rewrite Qlowbound_ltabs_ZExp2_inv by exact Hqgt0.
+  rewrite Qpower_opp.
+  setoid_rewrite <- (Qinv_involutive q) at 2.
+  apply -> Qinv_lt_contravar.
+  - rewrite Qabs_pos in Hspecub.
+    + exact Hspecub.
+    + apply Qlt_le_weak, Qinv_lt_0_compat, Hqgt0.
+  - apply Qpower_pos_lt; lra.
+  - apply Qinv_lt_0_compat, Hqgt0.
+Qed.
+
+Lemma Qlowbound_ltabs_ZExp2_spec : forall (q : Q) (Hqgt0 : ~ q == 0),
+  (2^(Qlowbound_ltabs_ZExp2 q) < Qabs q)%Q.
+Proof.
+  intros q Hqgt0.
+  destruct (Q_dec 0 q) as [[H|H]|H].
+  - rewrite Qabs_pos by lra.
+    apply Qlowbound_lt_ZExp2_spec, H.
+  - rewrite Qabs_neg by lra.
+    rewrite Qlowbound_ltabs_ZExp2_opp.
+    apply Qlowbound_lt_ZExp2_spec.
+    lra.
+  - lra.
+Qed.
+
+(** ** Existential formulations of power of 2 lower and upper bounds *)
+
+Definition QarchimedeanExp2_Z (q : Q)
+  :  {z : Z | (q < 2^z)%Q}
+  := exist _ (Qbound_lt_ZExp2 q) (Qbound_lt_ZExp2_spec q).
+
+Definition QarchimedeanAbsExp2_Z (q : Q)
+  :  {z : Z | (Qabs q < 2^z)%Q}
+  := exist _ (Qbound_ltabs_ZExp2 q) (Qbound_ltabs_ZExp2_spec q).
+
+Definition QarchimedeanLowExp2_Z (q : Q) (Hqgt0 : q > 0)
+  :  {z : Z | (2^z < q)%Q}
+  := exist _ (Qlowbound_ltabs_ZExp2 q) (Qlowbound_lt_ZExp2_spec q Hqgt0).
+
+Definition QarchimedeanLowAbsExp2_Z (q : Q) (Hqgt0 : ~ q == 0)
+  :  {z : Z | (2^z < Qabs q)%Q}
+  := exist _ (Qlowbound_ltabs_ZExp2 q) (Qlowbound_ltabs_ZExp2_spec q Hqgt0).
diff --git a/theories/Reals/ClassicalConstructiveReals.v b/theories/Reals/ClassicalConstructiveReals.v
index baeb937add..955739c1e0 100644
--- a/theories/Reals/ClassicalConstructiveReals.v
+++ b/theories/Reals/ClassicalConstructiveReals.v
@@ -219,7 +219,7 @@ Qed.
 Lemma Rarchimedean : forall x y : R, x < y -> {q : Q & ((x < IQR q) * (IQR q < y))%type}.
 Proof.
   intros. rewrite Rlt_def in H. apply CRealLtEpsilon in H.
-  apply FQ_dense in H. destruct H as [q [H2 H3]].
+  apply CRealQ_dense in H. destruct H as [q [H2 H3]].
   exists q. split. rewrite Rlt_def. apply CRealLtForget.
   unfold IQR. rewrite Rquot2. exact H2.
   rewrite Rlt_def. apply CRealLtForget.
diff --git a/theories/Reals/ClassicalDedekindReals.v b/theories/Reals/ClassicalDedekindReals.v
index 21f3a9cfca..500838ed26 100644
--- a/theories/Reals/ClassicalDedekindReals.v
+++ b/theories/Reals/ClassicalDedekindReals.v
@@ -15,6 +15,83 @@ Require Import QArith.
 Require Import Qabs.
 Require Import ConstructiveCauchyReals.
 Require Import ConstructiveRcomplete.
+Require Import Lia.
+Require Import Lqa.
+Require Import Qpower.
+Require Import QExtra.
+Require CMorphisms.
+
+(*****************************************************************************)
+(** * Q Auxiliary Lemmas                                                     *)
+(*****************************************************************************)
+
+(*
+Fixpoint PosPow2_nat (n : nat) : positive :=
+  match n with
+  | O => 1
+  | S n' => 2 * (PosPow2_nat n')
+  end.
+
+Local Lemma Qpower_2_neg_eq_pospow_inv : forall n : nat,
+    (2 ^ (- Z.of_nat n) == 1#(PosPow2_nat n)%positive)%Q.
+Proof.
+  intros n; induction n.
+  - reflexivity.
+  - change (PosPow2_nat (S n)) with (2*(PosPow2_nat n))%positive.
+    rewrite Q_factorDenom.
+    rewrite Nat2Z.inj_succ, Z.opp_succ, <- Z.sub_1_r.
+    rewrite Qpower_minus_pos.
+    change ((1 # 2) ^ 1)%Q with (1 # 2)%Q.
+    rewrite Qmult_comm, IHn; reflexivity.
+Qed.
+*)
+
+Local Lemma Qpower_2_neg_eq_natpow_inv : forall n : nat,
+    (2 ^ (- Z.of_nat n) == 1#(Pos.of_nat (2^n)%nat))%Q.
+Proof.
+  intros n; induction n.
+  - reflexivity.
+  - rewrite Nat.pow_succ_r'.
+    rewrite Nat2Pos.inj_mul.
+    3: apply Nat.pow_nonzero; intros contra; inversion contra.
+    2: intros contra; inversion contra.
+    change (Pos.of_nat 2)%nat with 2%positive.
+    rewrite Q_factorDenom.
+    rewrite Nat2Z.inj_succ, Z.opp_succ, <- Z.sub_1_r.
+    rewrite Qpower_minus_pos.
+    change ((1 # 2) ^ 1)%Q with (1 # 2)%Q.
+    rewrite Qmult_comm, IHn; reflexivity.
+Qed.
+
+
+Local Lemma Qpower_2_invneg_le_pow : forall n : Z,
+    (1 # Pos.of_nat (2 ^ Z.to_nat (- n)) <= 2 ^ n)%Q.
+Proof.
+  intros n; destruct n.
+  - intros contra; inversion contra.
+  - (* ToDo: find out why this works - somehow 1#(...) seems to be coereced to 1 *)
+    apply (Qpower_le_1_increasing 2 p ltac:(lra)).
+  - rewrite <- Qpower_2_neg_eq_natpow_inv.
+    rewrite Z2Nat.id by lia.
+    rewrite Z.opp_involutive.
+    apply Qle_refl.
+Qed.
+
+Local Lemma Qpower_2_neg_le_one : forall n : nat,
+    (2 ^ (- Z.of_nat n) <= 1)%Q.
+Proof.
+  intros n; induction n.
+  - intros contra; inversion contra.
+  - rewrite Nat2Z.inj_succ, Z.opp_succ, <- Z.sub_1_r.
+    rewrite Qpower_minus_pos.
+    lra.
+Qed.
+
+(*****************************************************************************)
+(** * Dedekind cuts                                                          *)
+(*****************************************************************************)
+
+(** ** Definition *)
 
 (**
    Classical Dedekind reals. With the 3 logical axioms funext,
@@ -44,6 +121,8 @@ Definition isLowerCut (f : Q -> bool) : Prop
         strictly lower than a real number. *)
      /\ (forall q:Q, f q = true -> ~(forall r:Q, Qle r q \/ f r = false)).
 
+(** ** Properties *)
+
 Lemma isLowerCut_hprop : forall (f : Q -> bool),
     IsHProp (isLowerCut f).
 Proof.
@@ -96,9 +175,35 @@ Proof.
     rewrite positive_nat_Z. apply Qlt_le_weak, pmaj. apply e.
 Qed.
 
+Lemma lowerUpper : forall (f : Q -> bool) (q r : Q),
+    isLowerCut f -> Qle q r -> f q = false -> f r = false.
+Proof.
+  intros. destruct H. specialize (H q r H0). destruct (f r) eqn:desR.
+  2: reflexivity. exfalso. specialize (H (eq_refl _)).
+  rewrite H in H1. discriminate.
+Qed.
+
+Lemma UpperAboveLower : forall (f : Q -> bool) (q r : Q),
+    isLowerCut f
+    -> f q = true
+    -> f r = false
+    -> Qlt q r.
+Proof.
+  intros. destruct H. apply Qnot_le_lt. intro abs.
+  rewrite (H r q abs) in H1. discriminate. exact H0.
+Qed.
+
+(*****************************************************************************)
+(** * Classical Dedekind reals                                               *)
+(*****************************************************************************)
+
+(** ** Definition *)
+
 Definition DReal : Set
   := { f : Q -> bool | isLowerCut f }.
 
+(** ** Induction principle *)
+
 Fixpoint DRealQlim_rec (f : Q -> bool) (low : isLowerCut f) (n p : nat) { struct p }
   : f (proj1_sig (lowerCutBelow f low) + (Z.of_nat p # Pos.of_nat (S n)))%Q = false
     -> { q : Q | f q = true /\ f (q + (1 # Pos.of_nat (S n)))%Q = false }.
@@ -124,134 +229,201 @@ Proof.
       exists q. exact qmaj.
 Qed.
 
-Definition DRealQlim (x : DReal) (n : nat)
-  : { q : Q | proj1_sig x q = true /\ proj1_sig x (q + (1# Pos.of_nat (S n)))%Q = false }.
-Proof.
-  destruct x as [f low].
-  destruct (lowerCutAbove f low).
-  destruct (Qarchimedean (x - proj1_sig (lowerCutBelow f low))) as [p pmaj].
-  apply (DRealQlim_rec f low n ((S n) * Pos.to_nat p)).
-  destruct (lowerCutBelow f low); unfold proj1_sig; unfold proj1_sig in pmaj.
-  destruct (f (x0 + (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n)))%Q) eqn:des.
-  2: reflexivity. exfalso. destruct low.
-  rewrite (H _ (x0 + (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n)))%Q) in e.
-  discriminate. 2: exact des.
-  setoid_replace (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n))%Q with (Z.pos p # 1)%Q.
-  apply (Qplus_lt_l _ _ x0) in pmaj. ring_simplify in pmaj.
-  apply Qlt_le_weak, pmaj. rewrite Nat2Z.inj_mul, positive_nat_Z.
-  unfold Qeq, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_comm.
-  replace (Z.of_nat (S n)) with (Z.pos (Pos.of_nat (S n))). reflexivity.
-  simpl. destruct n. reflexivity. apply f_equal.
-  apply Pos.succ_of_nat. discriminate.
-Qed.
+(** ** Conversion to and from constructive Cauchy real CReal *)
+
+(** *** Conversion from CReal to DReal *)
 
 Definition DRealAbstr : CReal -> DReal.
 Proof.
   intro x.
   assert (forall (q : Q) (n : nat),
-   {(fun n0 : nat => (proj1_sig x (Pos.of_nat (S n0)) <= q + (1 # Pos.of_nat (S n0)))%Q) n} +
-   {~ (fun n0 : nat => (proj1_sig x (Pos.of_nat (S n0)) <= q + (1 # Pos.of_nat (S n0)))%Q) n}).
-  { intros. destruct (Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (proj1_sig x (Pos.of_nat (S n)))).
+   {(fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n} +
+   {~ (fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n}).
+  { intros. destruct (Qlt_le_dec (q + (2^-Z.of_nat n)) (seq x (-Z.of_nat n))).
     right. apply (Qlt_not_le _ _ q0). left. exact q0. }
 
-  exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (proj1_sig x (Pos.of_nat (S n))) (q + (1#Pos.of_nat (S n)))) (H q)
+  exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (seq x (-Z.of_nat n)) (q + (2^-Z.of_nat n))) (H q)
              then true else false).
   repeat split.
   - intros.
-    destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q)
+    destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= q + (2^-Z.of_nat n))%Q)
                              (H q)).
     reflexivity. exfalso.
-    destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= r + (1 # Pos.of_nat (S n)))%Q)
+    destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= r + (2^-Z.of_nat n))%Q)
                              (H r)).
     destruct s. apply n.
     apply (Qle_trans _ _ _ (q0 x0)).
     apply Qplus_le_l. exact H0. discriminate.
   - intro abs. destruct (Rfloor x) as [z [_ zmaj]].
     specialize (abs (z+3 # 1)%Q).
-    destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= (z+3 # 1) + (1 # Pos.of_nat (S n)))%Q)
+    destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= (z+3 # 1) + (2^-Z.of_nat n))%Q)
                              (H (z+3 # 1)%Q)).
     2: exfalso; discriminate. clear abs. destruct s as [n nmaj]. apply nmaj.
     rewrite <- (inject_Q_plus (z#1) 2) in zmaj.
     apply CRealLt_asym in zmaj. rewrite <- CRealLe_not_lt in zmaj.
-    specialize (zmaj (Pos.of_nat (S n))). unfold inject_Q, proj1_sig in zmaj.
-    destruct x as [xn xcau]; unfold proj1_sig.
+    specialize (zmaj (-Z.of_nat n)%Z).
+    unfold inject_Q in zmaj; rewrite CReal_red_seq in zmaj.
+    destruct x as [xn xcau]; rewrite CReal_red_seq in H, nmaj, zmaj |- *.
     rewrite Qinv_plus_distr in zmaj.
     apply (Qplus_le_l _ _ (-(z + 2 # 1))). apply (Qle_trans _ _ _ zmaj).
-    apply (Qplus_le_l _ _ (-(1 # Pos.of_nat (S n)))). apply (Qle_trans _ 1).
-    unfold Qopp, Qnum, Qden. rewrite Qinv_plus_distr.
-    unfold Qle, Qnum, Qden. apply Z2Nat.inj_le. discriminate. discriminate.
-    do 2 rewrite Z.mul_1_l. unfold Z.to_nat. rewrite Nat2Pos.id. 2: discriminate.
-    apply le_n_S, le_0_n. setoid_replace (- (z + 2 # 1))%Q with (-(z+2) #1)%Q.
-    2: reflexivity. ring_simplify. rewrite Qinv_plus_distr.
-    replace (z + 3 + - (z + 2))%Z with 1%Z. apply Qle_refl. ring.
+    apply (Qplus_le_l _ _ (-(2^-Z.of_nat n))). apply (Qle_trans _ 1).
+    + ring_simplify. apply Qpower_2_neg_le_one.
+    + ring_simplify. rewrite <- (Qinv_plus_distr z 3 1), <- (Qinv_plus_distr z 2 1). lra.
   - intro abs. destruct (Rfloor x) as [z [zmaj _]].
     specialize (abs (z-4 # 1)%Q).
-    destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= (z-4 # 1) + (1 # Pos.of_nat (S n)))%Q)
+    destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= (z-4 # 1) + (2^-Z.of_nat n))%Q)
                              (H (z-4 # 1)%Q)).
     exfalso; discriminate. clear abs.
     apply CRealLt_asym in zmaj. apply zmaj. clear zmaj.
-    exists 1%positive. unfold inject_Q, proj1_sig.
+    exists 0%Z. unfold inject_Q; rewrite CReal_red_seq.
     specialize (q O).
-    destruct x as [xn xcau]; unfold proj1_sig; unfold proj1_sig in q.
-    unfold Pos.of_nat in q. rewrite Qinv_plus_distr in q.
-    apply (Qplus_lt_l _ _ (xn 1%positive - 2)).
-    ring_simplify. rewrite Qinv_plus_distr.
-    apply (Qle_lt_trans _ _ _ q). apply Qlt_minus_iff.
-    unfold Qopp, Qnum, Qden. rewrite Qinv_plus_distr.
-    replace (z + -2 + - (z - 4 + 1))%Z with 1%Z. 2: ring. reflexivity.
+    destruct x as [xn xcau].
+    rewrite CReal_red_seq in H, q |- *.
+    unfold Z.of_nat in q.
+    change (2 ^ (- 0))%Q with 1%Q in q. change (-0)%Z with 0%Z in q.
+    rewrite <- Qinv_minus_distr in q.
+    change (2^0)%Q with 1%Q.
+    lra.
   - intros q H0 abs.
-    destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q) (H q)).
+    destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= q + (2^-Z.of_nat n))%Q) (H q)).
     2: exfalso; discriminate. clear H0.
-    destruct x as [xn xcau]; unfold proj1_sig in abs, s.
     destruct s as [n nmaj].
     (* We have that q < x as real numbers. The middle
        (q + xSn - 1/Sn)/2 is also lower than x, witnessed by the same index n. *)
-    specialize (abs ((q + xn (Pos.of_nat (S n)) - (1 # Pos.of_nat (S n))%Q)/2)%Q).
+    specialize (abs ((q + seq x (-Z.of_nat n) - (2^-Z.of_nat n)%Q)/2)%Q).
     destruct abs.
     + apply (Qmult_le_r _ _ 2) in H0. field_simplify in H0.
-      apply (Qplus_le_r _ _ ((1 # Pos.of_nat (S n)) - q)) in H0.
+      apply (Qplus_le_r _ _ ((2^-Z.of_nat n) - q)) in H0.
       ring_simplify in H0. apply nmaj. rewrite Qplus_comm. exact H0. reflexivity.
     + destruct (sig_forall_dec
            (fun n0 : nat =>
-            (xn (Pos.of_nat (S n0)) <= (q + xn (Pos.of_nat (S n)) - (1 # Pos.of_nat (S n))) / 2 + (1 # Pos.of_nat (S n0)))%Q)
-           (H ((q + xn (Pos.of_nat (S n)) - (1 # Pos.of_nat (S n))) / 2)%Q)).
+            (seq x (-Z.of_nat n0) <= (q + seq x (-Z.of_nat n) - (2^-Z.of_nat n)) / 2 + (2^-Z.of_nat n0))%Q)
+           (H ((q + seq x (-Z.of_nat n) - (2^-Z.of_nat n)) / 2)%Q)).
       discriminate. clear H0. specialize (q0 n).
       apply (Qmult_le_l _ _ 2) in q0. field_simplify in q0.
-      apply (Qplus_le_l _ _ (-xn (Pos.of_nat (S n)))) in q0. ring_simplify in q0.
+      apply (Qplus_le_l _ _ (-seq x (-Z.of_nat n))) in q0. ring_simplify in q0.
       contradiction. reflexivity.
 Defined.
 
-Lemma UpperAboveLower : forall (f : Q -> bool) (q r : Q),
-    isLowerCut f
-    -> f q = true
-    -> f r = false
-    -> Qlt q r.
+(** *** Conversion from DReal to CReal *)
+
+Definition DRealQlim (x : DReal) (n : nat)
+  : { q : Q | proj1_sig x q = true /\ proj1_sig x (q + (1# Pos.of_nat (S n)))%Q = false }.
 Proof.
-  intros. destruct H. apply Qnot_le_lt. intro abs.
-  rewrite (H r q abs) in H1. discriminate. exact H0.
+  destruct x as [f low].
+  destruct (lowerCutAbove f low).
+  destruct (Qarchimedean (x - proj1_sig (lowerCutBelow f low))) as [p pmaj].
+  apply (DRealQlim_rec f low n ((S n) * Pos.to_nat p)).
+  destruct (lowerCutBelow f low); unfold proj1_sig; unfold proj1_sig in pmaj.
+  destruct (f (x0 + (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n)))%Q) eqn:des.
+  2: reflexivity. exfalso. destruct low.
+  rewrite (H _ (x0 + (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n)))%Q) in e.
+  discriminate. 2: exact des.
+  setoid_replace (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n))%Q with (Z.pos p # 1)%Q.
+  apply (Qplus_lt_l _ _ x0) in pmaj. ring_simplify in pmaj.
+  apply Qlt_le_weak, pmaj. rewrite Nat2Z.inj_mul, positive_nat_Z.
+  unfold Qeq, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_comm.
+  replace (Z.of_nat (S n)) with (Z.pos (Pos.of_nat (S n))). reflexivity.
+  simpl. destruct n. reflexivity. apply f_equal.
+  apply Pos.succ_of_nat. discriminate.
+Qed.
+
+Definition DRealQlimExp2 (x : DReal) (n : nat)
+  : { q : Q | proj1_sig x q = true /\ proj1_sig x (q + (1#(Pos.of_nat (2^n)%nat)))%Q = false }.
+Proof.
+  destruct (DRealQlim x (pred (2^n))%nat) as [q qmaj].
+  exists q.
+  rewrite Nat.succ_pred_pos in qmaj.
+    2: apply neq_0_lt, not_eq_sym, Nat.pow_nonzero; intros contra; inversion contra.
+  exact qmaj.
 Qed.
 
-Definition DRealRepr : DReal -> CReal.
+Definition CReal_of_DReal_seq (x : DReal) (n : Z) :=
+    proj1_sig (DRealQlimExp2 x (Z.to_nat (-n))).
+
+Lemma CReal_of_DReal_cauchy (x : DReal) :
+    QCauchySeq (CReal_of_DReal_seq x).
 Proof.
-  intro x. exists (fun n:positive => proj1_sig (DRealQlim x (Pos.to_nat n))).
-  intros n p q H H0.
-  destruct (DRealQlim x (Pos.to_nat p)), (DRealQlim x (Pos.to_nat q))
-  ; unfold proj1_sig.
-  destruct x as [f low]; unfold proj1_sig in a0, a.
+  unfold QCauchySeq, CReal_of_DReal_seq.
+  intros n k l Hk Hl.
+  destruct (DRealQlimExp2 x (Z.to_nat (-k))) as [q Hq].
+  destruct (DRealQlimExp2 x (Z.to_nat (-l))) as [r Hr].
+  destruct x as [f Hflc].
+  unfold proj1_sig in *.
   apply Qabs_case.
-  - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S (Pos.to_nat q)))).
-    apply (Qplus_lt_l _ _ x1). ring_simplify. apply (UpperAboveLower f).
-    exact low. apply a. apply a0. unfold Qle, Qnum, Qden.
-    do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos.
-    apply Pos2Nat.inj_le. rewrite Nat2Pos.id.
-    apply le_S, Pos2Nat.inj_le, H0. discriminate.
-  - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S (Pos.to_nat p)))).
-    apply (Qplus_lt_l _ _ x0). ring_simplify. apply (UpperAboveLower f).
-    exact low. apply a0. apply a. unfold Qle, Qnum, Qden.
-    do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos.
-    apply Pos2Nat.inj_le. rewrite Nat2Pos.id.
-    apply le_S, Pos2Nat.inj_le, H. discriminate.
-Defined.
+  - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (2 ^ Z.to_nat (-l)))).
+    + apply (Qplus_lt_l _ _ r); ring_simplify.
+      apply (UpperAboveLower f).
+        exact Hflc. apply Hq. apply Hr.
+    + apply (Qle_trans _ _ _ (Qpower_2_invneg_le_pow _)).
+      apply Qpower_le_compat; [lia|lra].
+  - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (2 ^ Z.to_nat (-k)))).
+    + apply (Qplus_lt_l _ _ q); ring_simplify.
+      apply (UpperAboveLower f).
+        exact Hflc. apply Hr. apply Hq.
+    + apply (Qle_trans _ _ _ (Qpower_2_invneg_le_pow _)).
+      apply Qpower_le_compat; [lia|lra].
+Qed.
+
+Lemma CReal_of_DReal_seq_max_prec_1 : forall (x : DReal) (n : Z),
+   (n>=0)%Z -> CReal_of_DReal_seq x n = CReal_of_DReal_seq x 0.
+Proof.
+  intros x n Hngt0.
+  unfold CReal_of_DReal_seq.
+  destruct n.
+  - reflexivity.
+  - reflexivity.
+  - lia.
+Qed.
+
+Lemma CReal_of_DReal_seq_bound :
+  forall (x : DReal) (i j : Z),
+    (Qabs (CReal_of_DReal_seq x i - CReal_of_DReal_seq x j) <= 1)%Q.
+Proof.
+  intros x i j.
+  pose proof CReal_of_DReal_cauchy x 0%Z as Hcau.
+  apply Qlt_le_weak; change (2^0)%Q with 1%Q in Hcau.
+  (* Either i, j are >= 0 in which case we can rewrite with CReal_of_DReal_seq_max_prec_1,
+     or they are <0, in which case Hcau can be used immediately *)
+  destruct (Z_gt_le_dec i 0) as [Hi|Hi];
+  destruct (Z_gt_le_dec j 0) as [Hj|Hj].
+  all: try rewrite (CReal_of_DReal_seq_max_prec_1 x i) by lia;
+       try rewrite (CReal_of_DReal_seq_max_prec_1 x j) by lia;
+       apply Hcau; lia.
+  (* ToDo: check if for CReal_from_cauchy_seq_bound a similar simple proof is possible *)
+Qed.
+
+Definition CReal_of_DReal_scale (x : DReal) : Z :=
+  Qbound_lt_ZExp2 (Qabs (CReal_of_DReal_seq x (-1)) + 2)%Q.
+
+Lemma CReal_of_DReal_bound : forall (x : DReal),
+  QBound (CReal_of_DReal_seq x) (CReal_of_DReal_scale x).
+Proof.
+  intros x n.
+  unfold CReal_of_DReal_scale.
+
+  (* Use the spec of Qbound_lt_ZExp2 to linearize the RHS *)
+  apply (Qlt_trans_swap_hyp _ _ _ (Qbound_lt_ZExp2_spec _)).
+
+  (* Massage the goal so that CReal_of_DReal_seq_bound can be applied *)
+  apply (Qplus_lt_l _ _ (-Qabs (CReal_of_DReal_seq x (-1)))%Q); ring_simplify.
+  assert(forall r s : Q, (r + -1*s == r-s)%Q) as Aux
+    by (intros; lra); rewrite Aux; clear Aux.
+  apply (Qle_lt_trans _ _ _ (Qabs_triangle_reverse _ _)).
+  apply (Qle_lt_trans _ 1%Q _).
+    2: lra.
+  apply CReal_of_DReal_seq_bound.
+Qed.
+
+Definition DRealRepr (x : DReal) : CReal :=
+{|
+  seq := CReal_of_DReal_seq x;
+  scale := CReal_of_DReal_scale x;
+  cauchy := CReal_of_DReal_cauchy x;
+  bound := CReal_of_DReal_bound x
+|}.
+
+(** ** Order for DReal *)
 
 Definition Rle (x y : DReal)
   := forall q:Q, proj1_sig x q = true -> proj1_sig y q = true.
@@ -273,14 +445,6 @@ Proof.
   apply isLowerCut_hprop.
 Qed.
 
-Lemma lowerUpper : forall (f : Q -> bool) (q r : Q),
-    isLowerCut f -> Qle q r -> f q = false -> f r = false.
-Proof.
-  intros. destruct H. specialize (H q r H0). destruct (f r) eqn:desR.
-  2: reflexivity. exfalso. specialize (H (eq_refl _)).
-  rewrite H in H1. discriminate.
-Qed.
-
 Lemma DRealOpen : forall (x : DReal) (q : Q),
     proj1_sig x q = true
     -> { r : Q | Qlt q r /\ proj1_sig x r = true }.
@@ -325,40 +489,27 @@ Lemma DRealReprQ : forall (x : DReal) (q : Q),
     proj1_sig x q = true
     -> CRealLt (inject_Q q) (DRealRepr x).
 Proof.
-  intros.
+  intros x q H.
+
+  (* expand and simplify goal and hypothesis *)
   destruct (DRealOpen x q H) as [r rmaj].
-  destruct (Qarchimedean (4/(r - q))) as [p pmaj].
-  exists p.
-  destruct x as [f low]; unfold DRealRepr, inject_Q, proj1_sig.
-  destruct (DRealQlim (exist _ f low) (Pos.to_nat p)) as [s smaj].
-  unfold proj1_sig in smaj, rmaj.
-  apply (Qplus_lt_l _ _ (q+ (1 # Pos.of_nat (S (Pos.to_nat p))))).
-  ring_simplify. rewrite <- (Qplus_comm s).
-  apply (UpperAboveLower f _ _ low). 2: apply smaj.
-  destruct low. apply (e _ r). 2: apply rmaj.
-  rewrite <- (Qplus_comm q).
-  apply (Qle_trans _ (q + (4#p))).
-  - rewrite <- Qplus_assoc. apply Qplus_le_r.
-    apply (Qle_trans _ ((2#p) + (1#p))).
-    apply Qplus_le_r.
-    unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l.
-    apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le.
-    rewrite Nat2Pos.id. apply le_S, le_refl. discriminate.
-    rewrite Qinv_plus_distr. unfold Qle, Qnum, Qden.
-    apply Z.mul_le_mono_nonneg_r. discriminate. discriminate.
-  - apply (Qle_trans _ (q + (r-q))). 2: ring_simplify; apply Qle_refl.
-    apply Qplus_le_r.
-    apply (Qmult_le_l _ _ ( (Z.pos p # 1) / (r-q))).
-    rewrite <- (Qmult_0_r (Z.pos p #1)). apply Qmult_lt_l.
-    reflexivity. apply Qinv_lt_0_compat.
-    unfold Qminus. rewrite <- Qlt_minus_iff. apply rmaj.
-    unfold Qdiv. rewrite Qmult_comm, <- Qmult_assoc.
-    rewrite (Qmult_comm (/(r-q))), Qmult_inv_r, Qmult_assoc.
-    setoid_replace ((4 # p) * (Z.pos p # 1))%Q with 4%Q.
-    2: reflexivity. rewrite Qmult_1_r.
-    apply Qlt_le_weak, pmaj. intro abs. destruct rmaj.
-    apply Qlt_minus_iff in H0.
-    rewrite abs in H0. apply (Qlt_not_le _ _ H0), Qle_refl.
+  destruct (QarchimedeanLowExp2_Z ((1#4)*(r - q))) as [p pmaj].
+    1: lra.
+  exists (p)%Z.
+  destruct x as [f low]; unfold DRealRepr, CReal_of_DReal_seq, inject_Q; do 2 rewrite CReal_red_seq.
+  destruct (DRealQlimExp2 (exist _ f low) (Z.to_nat (-p))) as [s smaj].
+  unfold proj1_sig in smaj, rmaj, H |- * .
+  rewrite <- (Qmult_lt_l _ _ 4%Q) in pmaj by lra.
+  setoid_replace (4 * ((1 # 4) * (r - q)))%Q with (r-q)%Q in pmaj by ring.
+  apply proj2 in rmaj.
+  apply proj2 in smaj.
+
+  (* Use the fact that s+eps is above the cut and r is below the cut.
+     This limits the distance between s and r. *)
+  pose proof UpperAboveLower f _ _ low rmaj smaj as Hrltse; clear rmaj smaj.
+  pose proof Qpower_2_invneg_le_pow p as Hpowcut.
+  pose proof Qpower_pos_lt 2 p ltac:(lra) as Hpowpos.
+  lra.
 Qed.
 
 Lemma DRealReprQup : forall (x : DReal) (q : Q),
@@ -366,13 +517,18 @@ Lemma DRealReprQup : forall (x : DReal) (q : Q),
     -> CRealLe (DRealRepr x) (inject_Q q).
 Proof.
   intros x q H [p pmaj].
-  unfold inject_Q, DRealRepr, proj1_sig in pmaj.
-  destruct (DRealQlim x (Pos.to_nat p)) as [r rmaj], rmaj.
-  clear H1. destruct x as [f low], low; unfold proj1_sig in H, H0.
-  apply (Qplus_lt_l _ _ q) in pmaj. ring_simplify in pmaj.
-  rewrite (e _ r) in H. discriminate. 2: exact H0.
-  apply Qlt_le_weak. apply (Qlt_trans _ ((2#p)+q)). 2: exact pmaj.
-  apply (Qplus_lt_l _ _ (-q)). ring_simplify. reflexivity.
+
+  (* expand and simplify goal and hypothesis *)
+  unfold inject_Q, DRealRepr, CReal_of_DReal_seq in pmaj. do 2 rewrite CReal_red_seq in pmaj.
+  destruct (DRealQlimExp2 x (Z.to_nat (- p))) as [r rmaj].
+  destruct x as [f low].
+  unfold proj1_sig in pmaj, rmaj, H.
+  apply proj1 in rmaj.
+
+  (* Use the fact that q is above the cut and r is below the cut. *)
+  pose proof UpperAboveLower f _ _ low rmaj H as Hrltse.
+  pose proof Qpower_pos_lt 2 p ltac:(lra) as Hpowpos.
+  lra.
 Qed.
 
 Lemma DRealQuot1 : forall x y:DReal, CRealEq (DRealRepr x) (DRealRepr y) -> x = y.
@@ -390,79 +546,106 @@ Qed.
 
 Lemma DRealAbstrFalse : forall (x : CReal) (q : Q) (n : nat),
     proj1_sig (DRealAbstr x) q = false
-    -> (proj1_sig x (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q.
+    -> (seq x (- Z.of_nat n) <= q + 2 ^ (- Z.of_nat n))%Q.
+Proof.
+  intros x q n H.
+  unfold DRealAbstr, proj1_sig in H.
+  match type of H with context [ if ?a then _ else _ ] => destruct a as [H'|H']end.
+  - discriminate.
+  - apply H'.
+Qed.
+
+(** For arbitrary n:Z, we need to relaxe the bound *)
+
+Lemma DRealAbstrFalse' : forall (x : CReal) (q : Q) (n : Z),
+    proj1_sig (DRealAbstr x) q = false
+    -> (seq x n <= q + 2*2^n)%Q.
 Proof.
-  intros. destruct x as [xn xcau].
+  intros x q n H.
   unfold DRealAbstr, proj1_sig in H.
-  destruct (
-        sig_forall_dec (fun n : nat => (xn (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q)
-          (fun n : nat =>
-           match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) with
-           | left q0 => right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) q0)
-           | right q0 => left q0
-           end)).
-  discriminate. apply q0.
+  match type of H with context [ if ?a then _ else _ ] => destruct a as [H'|H']end.
+  - discriminate.
+  - destruct (Z_le_gt_dec n 0) as [Hdec|Hdec].
+    + specialize (H' (Z.to_nat (-n) )).
+      rewrite (Z2Nat.id (-n)%Z ltac:(lia)), Z.opp_involutive in H'.
+      pose proof Qpower_pos_lt 2 n; lra.
+    + specialize (H' (Z.to_nat (0) )). cbn in H'.
+      pose proof cauchy x n%Z 0%Z n ltac:(lia) ltac:(lia) as Hxbnd.
+      apply Qabs_Qlt_condition in Hxbnd.
+      pose proof Qpower_le_1_increasing' 2 n ltac:(lra) ltac:(lia).
+      lra.
+Qed.
+
+Lemma DRealAbstrFalse'' : forall (x : CReal) (q : Q) (n : Z),
+    proj1_sig (DRealAbstr x) q = false
+    -> (seq x n <= q + 2^n + 1)%Q.
+Proof.
+  intros x q n H.
+  unfold DRealAbstr, proj1_sig in H.
+  match type of H with context [ if ?a then _ else _ ] => destruct a as [H'|H']end.
+  - discriminate.
+  - destruct (Z_le_gt_dec n 0) as [Hdec|Hdec].
+    + specialize (H' (Z.to_nat (-n) )).
+      rewrite (Z2Nat.id (-n)%Z ltac:(lia)), Z.opp_involutive in H'.
+      pose proof Qpower_pos_lt 2 n; lra.
+    + specialize (H' (Z.to_nat (0) )). cbn in H'.
+      pose proof cauchy x n%Z 0%Z n ltac:(lia) ltac:(lia) as Hxbnd.
+      apply Qabs_Qlt_condition in Hxbnd.
+      lra.
 Qed.
 
 Lemma DRealQuot2 : forall x:CReal, CRealEq (DRealRepr (DRealAbstr x)) x.
 Proof.
   split.
-  - intros [p pmaj]. unfold DRealRepr, proj1_sig in pmaj.
-    destruct x as [xn xcau].
-    destruct (DRealQlim (DRealAbstr (exist _ xn xcau)) (Pos.to_nat p))
-      as [q [_ qmaj]].
-    (* By pmaj, q + 1/p < x as real numbers.
-       But by qmaj x <= q + 1/(p+1), contradiction. *)
-    apply (DRealAbstrFalse _ _ (pred (Pos.to_nat p))) in qmaj.
-    unfold proj1_sig in qmaj.
-    rewrite Nat.succ_pred in qmaj.
-    apply (Qlt_not_le _ _ pmaj), (Qplus_le_l _ _ q).
-    ring_simplify. rewrite Pos2Nat.id in qmaj.
-    apply (Qle_trans _ _ _ qmaj).
-    rewrite <- Qplus_assoc. apply Qplus_le_r.
-    apply (Qle_trans _ ((1#p)+(1#p))).
-    apply Qplus_le_l. unfold Qle, Qnum, Qden.
-    do 2 rewrite Z.mul_1_l.
-    apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le.
-    rewrite Nat2Pos.id. apply le_S, le_refl. discriminate.
-    rewrite Qinv_plus_distr. apply Qle_refl.
-    intro abs. pose proof (Pos2Nat.is_pos p).
-    rewrite abs in H. inversion H.
-  - intros [p pmaj]. unfold DRealRepr, proj1_sig in pmaj.
-    destruct x as [xn xcau].
-    destruct (DRealQlim (DRealAbstr (exist _ xn xcau)) (Pos.to_nat p))
-      as [q [qmaj _]].
-    (* By pmaj, x < q - 1/p *)
-    unfold DRealAbstr, proj1_sig in qmaj.
-    destruct (
-           sig_forall_dec (fun n : nat => (xn (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q)
-             (fun n : nat =>
-              match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) with
-              | left q0 =>
-                  right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) q0)
-              | right q0 => left q0
-              end)).
-    2: discriminate. clear qmaj.
-    destruct s as [n nmaj]. apply nmaj.
-    apply (Qplus_lt_l _ _ (xn p + (1#Pos.of_nat (S n)))) in pmaj.
-    ring_simplify in pmaj. apply Qlt_le_weak. rewrite Qplus_comm.
-    apply (Qlt_trans _ ((2 # p) + xn p + (1 # Pos.of_nat (S n)))).
-    2: exact pmaj.
-    apply (Qplus_lt_l _ _ (-xn p)).
+  - intros [p pmaj].
+    unfold DRealRepr in pmaj.
+    rewrite CReal_red_seq in pmaj.
+    destruct (Z_ge_lt_dec 0 p) as [Hdec|Hdec].
+    + (* The usual case that p<=0 and 2^p is small *)
+      (* In this case the conversion of Z to nat and back is id *)
+      unfold CReal_of_DReal_seq in pmaj.
+      destruct (DRealQlimExp2 (DRealAbstr x) (Z.to_nat (- p))) as [q [Hql Hqr]].
+      unfold proj1_sig in pmaj.
+      pose proof (DRealAbstrFalse x _ (Z.to_nat (- p)) Hqr) as Hq; clear Hql Hqr.
+      rewrite <- Qpower_2_neg_eq_natpow_inv in Hq.
+      rewrite Z2Nat.id, Z.opp_involutive in Hq by lia; clear Hdec.
+      lra.
+    + (* The case that p>0 and 2^p is large *)
+      (* In this case we use CReal_of_DReal_seq_max_prec_1 to rewrite the index to 0 *)
+      rewrite CReal_of_DReal_seq_max_prec_1 in pmaj by lia.
+      unfold CReal_of_DReal_seq in pmaj.
+      change (Z.to_nat (-0))%Z with 0%nat in pmaj.
+      destruct (DRealQlimExp2 (DRealAbstr x) 0) as [q [Hql Hqr]].
+      unfold proj1_sig in pmaj.
+      pose proof (DRealAbstrFalse'' x _ p%nat Hqr) as Hq; clear Hql Hqr.
+      rewrite <- Qpower_2_neg_eq_natpow_inv in Hq.
+      change (- Z.of_nat 0)%Z with 0%Z in Hq.
+      pose proof (Qpower_le_compat 2 1 p ltac:(lia) ltac:(lra)) as Hpowle.
+      change (2^1)%Q with 2%Q in Hpowle.
+      lra.
+  - intros [p pmaj].
+    unfold DRealRepr in pmaj.
+    rewrite CReal_red_seq in pmaj.
+    unfold CReal_of_DReal_seq in pmaj.
+    destruct (DRealQlimExp2 (DRealAbstr x) (Z.to_nat (- p))) as [q [Hql Hqr]].
+    unfold proj1_sig in pmaj.
+    unfold DRealAbstr, proj1_sig in Hql.
+    match type of Hql with context [ if ?a then _ else _ ] => destruct a as [H'|H']end.
+      2: discriminate. clear Hql Hqr.
+    destruct H' as [n nmaj]. apply nmaj; clear nmaj.
+    apply (Qplus_lt_l _ _ (seq x p + 2 ^ (- Z.of_nat n))) in pmaj.
+   ring_simplify in pmaj. apply Qlt_le_weak. rewrite Qplus_comm.
+    apply (Qlt_trans _ ((2 * 2^p) + seq x p + (2 ^ (- Z.of_nat n)))).
+    2: exact pmaj. clear pmaj.
+    apply (Qplus_lt_l _ _ (-seq x p)).
     apply (Qle_lt_trans _ _ _ (Qle_Qabs _)).
-    destruct (le_lt_dec (S n) (Pos.to_nat p)).
-    + specialize (xcau (Pos.of_nat (S n)) (Pos.of_nat (S n)) p).
-      apply (Qlt_trans _ (1# Pos.of_nat (S n))). apply xcau.
-      apply Pos.le_refl. unfold id. apply Pos2Nat.inj_le.
-      rewrite Nat2Pos.id. exact l. discriminate.
-      apply (Qplus_lt_l _ _ (-(1#Pos.of_nat (S n)))).
-      ring_simplify. reflexivity.
-    + apply (Qlt_trans _ (1#p)). apply xcau.
-      apply le_S_n in l. unfold id. apply Pos2Nat.inj_le.
-      rewrite Nat2Pos.id.
-      apply le_S, l. discriminate. apply Pos.le_refl.
-      ring_simplify. apply (Qlt_trans _ (2#p)).
-      unfold Qlt, Qnum, Qden.
-      apply Z.mul_lt_mono_pos_r. reflexivity. reflexivity.
-      apply (Qplus_lt_l _ _ (-(2#p))). ring_simplify. reflexivity.
+    destruct (Z_le_gt_dec p (- Z.of_nat n)).
+    + apply (Qlt_trans _ (2 ^ (- Z.of_nat n))). apply (cauchy x).
+        1, 2: lia.
+      pose proof Qpower_pos_lt 2 p; lra.
+    + apply (Qlt_trans _ (2^p)). apply (cauchy x).
+        1, 2: lia.
+      pose proof Qpower_pos_lt 2 (- Z.of_nat n).
+      pose proof Qpower_pos_lt 2 p.
+      lra.
 Qed.
diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v
index 8c5bc8475b..338c939a06 100644
--- a/theories/Reals/Raxioms.v
+++ b/theories/Reals/Raxioms.v
@@ -370,7 +370,7 @@ Proof.
     + destruct (total_order_T (IZR (Z.pred n) - r) 1). destruct s.
       left. exact r1. right. exact e.
       exfalso. destruct nmaj as [_ nmaj].
-      pose proof Rrepr_IZR as iz. unfold inject_Z in iz.
+      pose proof Rrepr_IZR as iz.
       rewrite <- iz in nmaj.
       apply (Rlt_asym (IZR n) (r + 2)).
       rewrite RbaseSymbolsImpl.Rlt_def. rewrite Rrepr_plus. rewrite (Rrepr_plus 1 1).
diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v
index be887d0017..affa129771 100644
--- a/theories/Reals/Rdefinitions.v
+++ b/theories/Reals/Rdefinitions.v
@@ -18,6 +18,7 @@ Require Export ZArith_base.
 Require Import QArith_base.
 Require Import ConstructiveCauchyReals.
 Require Import ConstructiveCauchyRealsMult.
+Require Import ConstructiveRcomplete.
 Require Import ClassicalDedekindReals.