Imported Upstream version 8.0pl1upstream/8.0pl1

207 files changed, 63712 insertions, 0 deletions

diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v
new file mode 100755
index 00000000..d44efb56
--- /dev/null
+++ b/theories/Arith/Arith.v
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Arith.v,v 1.11.2.1 2004/07/16 19:30:59 herbelin Exp $ i*)
+
+Require Export Le.
+Require Export Lt.
+Require Export Plus.
+Require Export Gt.
+Require Export Minus.
+Require Export Mult.
+Require Export Between.
+Require Export Minus.
+Require Export Peano_dec.
+Require Export Compare_dec.
+Require Export Factorial.
\ No newline at end of file
diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v
new file mode 100755
index 00000000..448ce002
--- /dev/null
+++ b/theories/Arith/Between.v
@@ -0,0 +1,189 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Between.v,v 1.12.2.1 2004/07/16 19:30:59 herbelin Exp $ i*)
+
+Require Import Le.
+Require Import Lt.
+
+Open Local Scope nat_scope.
+
+Implicit Types k l p q r : nat.
+
+Section Between.
+Variables P Q : nat -> Prop.
+
+Inductive between k : nat -> Prop :=
+  | bet_emp : between k k
+  | bet_S : forall l, between k l -> P l -> between k (S l).
+
+Hint Constructors between: arith v62.
+
+Lemma bet_eq : forall k l, l = k -> between k l.
+Proof.
+induction 1; auto with arith.
+Qed.
+
+Hint Resolve bet_eq: arith v62.
+
+Lemma between_le : forall k l, between k l -> k <= l.
+Proof.
+induction 1; auto with arith.
+Qed.
+Hint Immediate between_le: arith v62.
+
+Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l.
+Proof.
+induction 1.
+intros; absurd (S k <= k); auto with arith.
+destruct H; auto with arith.
+Qed.
+Hint Resolve between_Sk_l: arith v62.
+
+Lemma between_restr :
+ forall k l (m:nat), k <= l -> l <= m -> between k m -> between l m.
+Proof.
+induction 1; auto with arith.
+Qed.
+
+Inductive exists_between k : nat -> Prop :=
+  | exists_S : forall l, exists_between k l -> exists_between k (S l)
+  | exists_le : forall l, k <= l -> Q l -> exists_between k (S l).
+
+Hint Constructors exists_between: arith v62.
+
+Lemma exists_le_S : forall k l, exists_between k l -> S k <= l.
+Proof.
+induction 1; auto with arith.
+Qed.
+
+Lemma exists_lt : forall k l, exists_between k l -> k < l.
+Proof exists_le_S.
+Hint Immediate exists_le_S exists_lt: arith v62.
+
+Lemma exists_S_le : forall k l, exists_between k (S l) -> k <= l.
+Proof.
+intros; apply le_S_n; auto with arith.
+Qed.
+Hint Immediate exists_S_le: arith v62.
+
+Definition in_int p q r := p <= r /\ r < q.
+
+Lemma in_int_intro : forall p q r, p <= r -> r < q -> in_int p q r.
+Proof.
+red in |- *; auto with arith.
+Qed.
+Hint Resolve in_int_intro: arith v62.
+
+Lemma in_int_lt : forall p q r, in_int p q r -> p < q.
+Proof.
+induction 1; intros.
+apply le_lt_trans with r; auto with arith.
+Qed.
+
+Lemma in_int_p_Sq :
+ forall p q r, in_int p (S q) r -> in_int p q r \/ r = q :>nat.
+Proof.
+induction 1; intros.
+elim (le_lt_or_eq r q); auto with arith.
+Qed.
+
+Lemma in_int_S : forall p q r, in_int p q r -> in_int p (S q) r.
+Proof.
+induction 1; auto with arith.
+Qed.
+Hint Resolve in_int_S: arith v62.
+
+Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r.
+Proof.
+induction 1; auto with arith.
+Qed.
+Hint Immediate in_int_Sp_q: arith v62.
+
+Lemma between_in_int :
+ forall k l, between k l -> forall r, in_int k l r -> P r.
+Proof.
+induction 1; intros.
+absurd (k < k); auto with arith.
+apply in_int_lt with r; auto with arith.
+elim (in_int_p_Sq k l r); intros; auto with arith.
+rewrite H2; trivial with arith.
+Qed.
+
+Lemma in_int_between :
+ forall k l, k <= l -> (forall r, in_int k l r -> P r) -> between k l.
+Proof.
+induction 1; auto with arith.
+Qed.
+
+Lemma exists_in_int :
+ forall k l, exists_between k l ->  exists2 m : nat, in_int k l m & Q m.
+Proof.
+induction 1.
+case IHexists_between; intros p inp Qp; exists p; auto with arith.
+exists l; auto with arith.
+Qed.
+
+Lemma in_int_exists : forall k l r, in_int k l r -> Q r -> exists_between k l.
+Proof.
+destruct 1; intros.
+elim H0; auto with arith.
+Qed.
+
+Lemma between_or_exists :
+ forall k l,
+   k <= l ->
+   (forall n:nat, in_int k l n -> P n \/ Q n) ->
+   between k l \/ exists_between k l.
+Proof.
+induction 1; intros; auto with arith.
+elim IHle; intro; auto with arith.
+elim (H0 m); auto with arith.
+Qed.
+
+Lemma between_not_exists :
+ forall k l,
+   between k l ->
+   (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l.
+Proof.
+induction 1; red in |- *; intros.
+absurd (k < k); auto with arith.
+absurd (Q l); auto with arith.
+elim (exists_in_int k (S l)); auto with arith; intros l' inl' Ql'.
+replace l with l'; auto with arith.
+elim inl'; intros.
+elim (le_lt_or_eq l' l); auto with arith; intros.
+absurd (exists_between k l); auto with arith.
+apply in_int_exists with l'; auto with arith.
+Qed.
+
+Inductive P_nth (init:nat) : nat -> nat -> Prop :=
+  | nth_O : P_nth init init 0
+  | nth_S :
+      forall k l (n:nat),
+        P_nth init k n -> between (S k) l -> Q l -> P_nth init l (S n).
+
+Lemma nth_le : forall (init:nat) l (n:nat), P_nth init l n -> init <= l.
+Proof.
+induction 1; intros; auto with arith.
+apply le_trans with (S k); auto with arith.
+Qed.
+
+Definition eventually (n:nat) :=  exists2 k : nat, k <= n & Q k.
+
+Lemma event_O : eventually 0 -> Q 0.
+Proof.
+induction 1; intros.
+replace 0 with x; auto with arith.
+Qed.
+
+End Between.
+
+Hint Resolve nth_O bet_S bet_emp bet_eq between_Sk_l exists_S exists_le
+  in_int_S in_int_intro: arith v62. 
+Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith v62.
\ No newline at end of file
diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v
new file mode 100644
index 00000000..55dfd47f
--- /dev/null
+++ b/theories/Arith/Bool_nat.v
@@ -0,0 +1,39 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: Bool_nat.v,v 1.5.2.1 2004/07/16 19:30:59 herbelin Exp $ *)
+
+Require Export Compare_dec.
+Require Export Peano_dec.
+Require Import Sumbool.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n x y : nat.
+
+(** The decidability of equality and order relations over
+    type [nat] give some boolean functions with the adequate specification. *)
+
+Definition notzerop n := sumbool_not _ _ (zerop n).
+Definition lt_ge_dec : forall x y, {x < y} + {x >= y} :=
+  fun n m => sumbool_not _ _ (le_lt_dec m n).
+
+Definition nat_lt_ge_bool x y := bool_of_sumbool (lt_ge_dec x y).
+Definition nat_ge_lt_bool x y :=
+  bool_of_sumbool (sumbool_not _ _ (lt_ge_dec x y)).
+
+Definition nat_le_gt_bool x y := bool_of_sumbool (le_gt_dec x y).
+Definition nat_gt_le_bool x y :=
+  bool_of_sumbool (sumbool_not _ _ (le_gt_dec x y)).
+
+Definition nat_eq_bool x y := bool_of_sumbool (eq_nat_dec x y).
+Definition nat_noteq_bool x y :=
+  bool_of_sumbool (sumbool_not _ _ (eq_nat_dec x y)).
+
+Definition zerop_bool x := bool_of_sumbool (zerop x).
+Definition notzerop_bool x := bool_of_sumbool (notzerop x).
\ No newline at end of file
diff --git a/theories/Arith/Compare.v b/theories/Arith/Compare.v
new file mode 100755
index 00000000..46827bae
--- /dev/null
+++ b/theories/Arith/Compare.v
@@ -0,0 +1,59 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Compare.v,v 1.12.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+(** Equality is decidable on [nat] *)
+Open Local Scope nat_scope.
+
+(*
+Lemma not_eq_sym : (A:Set)(p,q:A)(~p=q) -> ~(q=p).
+Proof sym_not_eq.
+Hints Immediate not_eq_sym : arith.
+*)
+Notation not_eq_sym := sym_not_eq.
+
+Implicit Types m n p q : nat.
+
+Require Import Arith.
+Require Import Peano_dec.
+Require Import Compare_dec.
+
+Definition le_or_le_S := le_le_S_dec.
+
+Definition Pcompare := gt_eq_gt_dec.
+
+Lemma le_dec : forall n m, {n <= m} + {m <= n}.
+Proof le_ge_dec.
+
+Definition lt_or_eq n m := {m > n} + {n = m}.
+
+Lemma le_decide : forall n m, n <= m -> lt_or_eq n m.
+Proof le_lt_eq_dec.
+
+Lemma le_le_S_eq : forall n m, n <= m -> S n <= m \/ n = m.
+Proof le_lt_or_eq.
+
+(* By special request of G. Kahn - Used in Group Theory *)
+Lemma discrete_nat :
+ forall n m, n < m -> S n = m \/ (exists r : nat, m = S (S (n + r))).
+Proof.
+intros m n H.
+lapply (lt_le_S m n); auto with arith.
+intro H'; lapply (le_lt_or_eq (S m) n); auto with arith.
+induction 1; auto with arith.
+right; exists (n - S (S m)); simpl in |- *.
+rewrite (plus_comm m (n - S (S m))).
+rewrite (plus_n_Sm (n - S (S m)) m).
+rewrite (plus_n_Sm (n - S (S m)) (S m)).
+rewrite (plus_comm (n - S (S m)) (S (S m))); auto with arith.
+Qed.
+
+Require Export Wf_nat.
+
+Require Export Min.
diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v
new file mode 100755
index 00000000..ea21437d
--- /dev/null
+++ b/theories/Arith/Compare_dec.v
@@ -0,0 +1,107 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Compare_dec.v,v 1.13.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Le.
+Require Import Lt.
+Require Import Gt.
+Require Import Decidable.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n x y : nat.
+
+Definition zerop : forall n, {n = 0} + {0 < n}.
+destruct n; auto with arith.
+Defined.
+
+Definition lt_eq_lt_dec : forall n m, {n < m} + {n = m} + {m < n}.
+Proof.
+induction n; simple destruct m; auto with arith.
+intros m0; elim (IHn m0); auto with arith.
+induction 1; auto with arith.
+Defined.
+
+Lemma gt_eq_gt_dec : forall n m, {m > n} + {n = m} + {n > m}.
+Proof lt_eq_lt_dec.
+
+Lemma le_lt_dec : forall n m, {n <= m} + {m < n}.
+Proof.
+induction n.
+auto with arith.
+induction m.
+auto with arith.
+elim (IHn m); auto with arith.
+Defined.
+
+Definition le_le_S_dec : forall n m, {n <= m} + {S m <= n}.
+Proof.
+exact le_lt_dec.
+Defined.
+
+Definition le_ge_dec : forall n m, {n <= m} + {n >= m}.
+Proof.
+intros; elim (le_lt_dec n m); auto with arith.
+Defined.
+
+Definition le_gt_dec : forall n m, {n <= m} + {n > m}.
+Proof.
+exact le_lt_dec.
+Defined.
+
+Definition le_lt_eq_dec : forall n m, n <= m -> {n < m} + {n = m}.
+Proof.
+intros; elim (lt_eq_lt_dec n m); auto with arith.
+intros; absurd (m < n); auto with arith.
+Defined.
+
+(** Proofs of decidability *)
+
+Theorem dec_le : forall n m, decidable (n <= m).
+intros x y; unfold decidable in |- *; elim (le_gt_dec x y);
+ [ auto with arith | intro; right; apply gt_not_le; assumption ].
+Qed.
+
+Theorem dec_lt : forall n m, decidable (n < m).
+intros x y; unfold lt in |- *; apply dec_le.
+Qed.
+
+Theorem dec_gt : forall n m, decidable (n > m).
+intros x y; unfold gt in |- *; apply dec_lt.
+Qed.
+
+Theorem dec_ge : forall n m, decidable (n >= m).
+intros x y; unfold ge in |- *; apply dec_le.
+Qed.
+
+Theorem not_eq : forall n m, n <> m -> n < m \/ m < n.
+intros x y H; elim (lt_eq_lt_dec x y);
+ [ intros H1; elim H1;
+    [ auto with arith | intros H2; absurd (x = y); assumption ]
+ | auto with arith ].
+Qed.
+
+
+Theorem not_le : forall n m, ~ n <= m -> n > m.
+intros x y H; elim (le_gt_dec x y);
+ [ intros H1; absurd (x <= y); assumption | trivial with arith ].
+Qed.
+
+Theorem not_gt : forall n m, ~ n > m -> n <= m.
+intros x y H; elim (le_gt_dec x y);
+ [ trivial with arith | intros H1; absurd (x > y); assumption ].
+Qed.
+
+Theorem not_ge : forall n m, ~ n >= m -> n < m.
+intros x y H; exact (not_le y x H).
+Qed.
+
+Theorem not_lt : forall n m, ~ n < m -> n >= m.
+intros x y H; exact (not_gt y x H). 
+Qed.
diff --git a/theories/Arith/Div.v b/theories/Arith/Div.v
new file mode 100755
index 00000000..adb5593d
--- /dev/null
+++ b/theories/Arith/Div.v
@@ -0,0 +1,64 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Div.v,v 1.8.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+(** Euclidean division *)
+
+V7only [Import nat_scope.].
+Open Local Scope nat_scope.
+
+Require Le.
+Require Euclid_def.
+Require Compare_dec.
+
+Implicit Variables Type n,a,b,q,r:nat.
+
+Fixpoint inf_dec [n:nat] : nat->bool :=
+      [m:nat] Cases n m of
+                  O     _     => true
+              | (S n')  O     => false
+              | (S n') (S m') => (inf_dec n' m')
+             end.
+
+Theorem div1 : (b:nat)(gt b O)->(a:nat)(diveucl a b).
+Realizer Fix div1 {div1/2: nat->nat->diveucl :=
+  [b,a]Cases a of
+         O     => (O,O)
+       | (S n) =>
+           let (q,r) = (div1 b n) in
+             if (le_gt_dec b (S r)) then ((S q),O)
+	     else (q,(S r))
+       end}.
+Program_all.
+Rewrite e.
+Replace b with (S r).
+Simpl.
+Elim plus_n_O; Auto with arith.
+Apply le_antisym; Auto with arith.
+Elim plus_n_Sm; Auto with arith.
+Qed.
+
+Theorem div2 : (b:nat)(gt b O)->(a:nat)(diveucl a b).
+Realizer Fix div1 {div1/2: nat->nat->diveucl :=
+  [b,a]Cases a of
+         O     => (O,O)
+       | (S n) =>
+           let (q,r) = (div1 b n) in
+             if (inf_dec b (S r)) :: :: { {(le b (S r))}+{(gt b (S r))} }
+             then ((S q),O)
+	     else (q,(S r))
+       end}.
+Program_all.
+Rewrite e.
+Replace b with (S r).
+Simpl.
+Elim plus_n_O; Auto with arith.
+Apply le_antisym; Auto with arith.
+Elim plus_n_Sm; Auto with arith.
+Qed.
diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v
new file mode 100644
index 00000000..c005f061
--- /dev/null
+++ b/theories/Arith/Div2.v
@@ -0,0 +1,175 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Div2.v,v 1.15.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Lt.
+Require Import Plus.
+Require Import Compare_dec.
+Require Import Even.
+
+Open Local Scope nat_scope.
+
+Implicit Type n : nat.
+
+(** Here we define [n/2] and prove some of its properties *)
+
+Fixpoint div2 n : nat :=
+  match n with
+  | O => 0
+  | S O => 0
+  | S (S n') => S (div2 n')
+  end.
+
+(** Since [div2] is recursively defined on [0], [1] and [(S (S n))], it is
+    useful to prove the corresponding induction principle *)
+
+Lemma ind_0_1_SS :
+ forall P:nat -> Prop,
+   P 0 -> P 1 -> (forall n, P n -> P (S (S n))) -> forall n, P n.
+Proof.
+intros.
+cut (forall n, P n /\ P (S n)).
+intros. elim (H2 n). auto with arith.
+
+induction n0. auto with arith.
+intros. elim IHn0; auto with arith.
+Qed.
+
+(** [0 <n  =>  n/2 < n] *)
+
+Lemma lt_div2 : forall n, 0 < n -> div2 n < n.
+Proof.
+intro n. pattern n in |- *. apply ind_0_1_SS.
+intro. inversion H.
+auto with arith.
+intros. simpl in |- *.
+case (zerop n0).
+intro. rewrite e. auto with arith.
+auto with arith.
+Qed.
+
+Hint Resolve lt_div2: arith.
+
+(** Properties related to the parity *)
+
+Lemma even_odd_div2 :
+ forall n,
+   (even n <-> div2 n = div2 (S n)) /\ (odd n <-> S (div2 n) = div2 (S n)).
+Proof.
+intro n. pattern n in |- *. apply ind_0_1_SS.
+(* n  = 0 *)
+split. split; auto with arith. 
+split. intro H. inversion H.
+intro H.  absurd (S (div2 0) = div2 1); auto with arith.
+(* n = 1 *)
+split. split. intro. inversion H. inversion H1.
+intro H.  absurd (div2 1 = div2 2).
+simpl in |- *. discriminate. assumption.
+split; auto with arith.
+(* n = (S (S n')) *)
+intros. decompose [and] H. unfold iff in H0, H1.
+decompose [and] H0. decompose [and] H1. clear H H0 H1.
+split; split; auto with arith.
+intro H. inversion H. inversion H1.
+change (S (div2 n0) = S (div2 (S n0))) in |- *. auto with arith.
+intro H. inversion H. inversion H1.
+change (S (S (div2 n0)) = S (div2 (S n0))) in |- *. auto with arith.
+Qed.
+
+(** Specializations *)
+
+Lemma even_div2 : forall n, even n -> div2 n = div2 (S n).
+Proof fun n => proj1 (proj1 (even_odd_div2 n)).
+
+Lemma div2_even : forall n, div2 n = div2 (S n) -> even n.
+Proof fun n => proj2 (proj1 (even_odd_div2 n)).
+
+Lemma odd_div2 : forall n, odd n -> S (div2 n) = div2 (S n).
+Proof fun n => proj1 (proj2 (even_odd_div2 n)).
+
+Lemma div2_odd : forall n, S (div2 n) = div2 (S n) -> odd n.
+Proof fun n => proj2 (proj2 (even_odd_div2 n)).
+
+Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith.
+
+(** Properties related to the double ([2n]) *)
+
+Definition double n := n + n.
+
+Hint Unfold double: arith.
+
+Lemma double_S : forall n, double (S n) = S (S (double n)).
+Proof.
+intro. unfold double in |- *. simpl in |- *. auto with arith.
+Qed.
+
+Lemma double_plus : forall n (m:nat), double (n + m) = double n + double m.
+Proof.
+intros m n. unfold double in |- *.
+do 2 rewrite plus_assoc_reverse. rewrite (plus_permute n).
+reflexivity.
+Qed.
+
+Hint Resolve double_S: arith.
+
+Lemma even_odd_double :
+ forall n,
+   (even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))).
+Proof.
+intro n. pattern n in |- *. apply ind_0_1_SS.
+(* n = 0 *)
+split; split; auto with arith.
+intro H. inversion H.
+(* n = 1 *)
+split; split; auto with arith.
+intro H. inversion H. inversion H1.
+(* n = (S (S n')) *)
+intros. decompose [and] H. unfold iff in H0, H1.
+decompose [and] H0. decompose [and] H1. clear H H0 H1.
+split; split.
+intro H. inversion H. inversion H1.
+simpl in |- *. rewrite (double_S (div2 n0)). auto with arith.
+simpl in |- *. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
+intro H. inversion H. inversion H1.
+simpl in |- *. rewrite (double_S (div2 n0)). auto with arith.
+simpl in |- *. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
+Qed.
+
+
+(** Specializations *)
+
+Lemma even_double : forall n, even n -> n = double (div2 n).
+Proof fun n => proj1 (proj1 (even_odd_double n)).
+
+Lemma double_even : forall n, n = double (div2 n) -> even n.
+Proof fun n => proj2 (proj1 (even_odd_double n)).
+
+Lemma odd_double : forall n, odd n -> n = S (double (div2 n)).
+Proof fun n => proj1 (proj2 (even_odd_double n)).
+
+Lemma double_odd : forall n, n = S (double (div2 n)) -> odd n.
+Proof fun n => proj2 (proj2 (even_odd_double n)).
+
+Hint Resolve even_double double_even odd_double double_odd: arith.
+
+(** Application: 
+    - if [n] is even then there is a [p] such that [n = 2p]
+    - if [n] is odd  then there is a [p] such that [n = 2p+1]
+
+    (Immediate: it is [n/2]) *)
+
+Lemma even_2n : forall n, even n -> {p : nat | n = double p}.
+Proof.
+intros n H. exists (div2 n). auto with arith.
+Qed.
+
+Lemma odd_S2n : forall n, odd n -> {p : nat | n = S (double p)}.
+Proof.
+intros n H. exists (div2 n). auto with arith.
+Qed.
diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v
new file mode 100755
index 00000000..2e99e068
--- /dev/null
+++ b/theories/Arith/EqNat.v
@@ -0,0 +1,77 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: EqNat.v,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+(** Equality on natural numbers *)
+
+Open Local Scope nat_scope.
+
+Implicit Types m n x y : nat.
+
+Fixpoint eq_nat n m {struct n} : Prop :=
+  match n, m with
+  | O, O => True
+  | O, S _ => False
+  | S _, O => False
+  | S n1, S m1 => eq_nat n1 m1
+  end.
+
+Theorem eq_nat_refl : forall n, eq_nat n n.
+induction n; simpl in |- *; auto.
+Qed.
+Hint Resolve eq_nat_refl: arith v62.
+
+Theorem eq_eq_nat : forall n m, n = m -> eq_nat n m.
+induction 1; trivial with arith.
+Qed.
+Hint Immediate eq_eq_nat: arith v62.
+
+Theorem eq_nat_eq : forall n m, eq_nat n m -> n = m.
+induction n; induction m; simpl in |- *; contradiction || auto with arith.
+Qed.
+Hint Immediate eq_nat_eq: arith v62.
+
+Theorem eq_nat_elim :
+ forall n (P:nat -> Prop), P n -> forall m, eq_nat n m -> P m.
+intros; replace m with n; auto with arith.
+Qed.
+
+Theorem eq_nat_decide : forall n m, {eq_nat n m} + {~ eq_nat n m}.
+induction n.
+destruct m as [| n].
+auto with arith.
+intros; right; red in |- *; trivial with arith.
+destruct m as [| n0].
+right; red in |- *; auto with arith.
+intros.
+simpl in |- *.
+apply IHn.
+Defined.
+
+Fixpoint beq_nat n m {struct n} : bool :=
+  match n, m with
+  | O, O => true
+  | O, S _ => false
+  | S _, O => false
+  | S n1, S m1 => beq_nat n1 m1
+  end.
+
+Lemma beq_nat_refl : forall n, true = beq_nat n n.
+Proof.
+  intro x; induction x; simpl in |- *; auto.
+Qed.
+
+Definition beq_nat_eq : forall x y, true = beq_nat x y -> x = y.
+Proof.
+  double induction x y; simpl in |- *.
+    reflexivity.
+    intros; discriminate H0.
+    intros; discriminate H0.
+    intros; case (H0 _ H1); reflexivity.
+Defined.
diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v
new file mode 100644
index 00000000..e50e3d70
--- /dev/null
+++ b/theories/Arith/Euclid.v
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Euclid.v,v 1.7.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Mult.
+Require Import Compare_dec.
+Require Import Wf_nat.
+
+Open Local Scope nat_scope.
+
+Implicit Types a b n q r : nat.
+
+Inductive diveucl a b : Set :=
+    divex : forall q r, b > r -> a = q * b + r -> diveucl a b.
+
+
+Lemma eucl_dev : forall n, n > 0 -> forall m:nat, diveucl m n.
+intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
+elim (le_gt_dec b n).
+intro lebn.
+elim (H0 (n - b)); auto with arith.
+intros q r g e.
+apply divex with (S q) r; simpl in |- *; auto with arith.
+elim plus_assoc.
+elim e; auto with arith.
+intros gtbn.
+apply divex with 0 n; simpl in |- *; auto with arith.
+Qed.
+
+Lemma quotient :
+ forall n,
+   n > 0 ->
+   forall m:nat, {q : nat |  exists r : nat, m = q * n + r /\ n > r}.
+intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
+elim (le_gt_dec b n).
+intro lebn.
+elim (H0 (n - b)); auto with arith.
+intros q Hq; exists (S q).
+elim Hq; intros r Hr.
+exists r; simpl in |- *; elim Hr; intros.
+elim plus_assoc.
+elim H1; auto with arith.
+intros gtbn.
+exists 0; exists n; simpl in |- *; auto with arith.
+Qed.
+
+Lemma modulo :
+ forall n,
+   n > 0 ->
+   forall m:nat, {r : nat |  exists q : nat, m = q * n + r /\ n > r}.
+intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
+elim (le_gt_dec b n).
+intro lebn.
+elim (H0 (n - b)); auto with arith.
+intros r Hr; exists r.
+elim Hr; intros q Hq.
+elim Hq; intros; exists (S q); simpl in |- *.
+elim plus_assoc.
+elim H1; auto with arith.
+intros gtbn.
+exists n; exists 0; simpl in |- *; auto with arith.
+Qed.
\ No newline at end of file
diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v
new file mode 100644
index 00000000..f7a2ad71
--- /dev/null
+++ b/theories/Arith/Even.v
@@ -0,0 +1,305 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Even.v,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+(** Here we define the predicates [even] and [odd] by mutual induction
+    and we prove the decidability and the exclusion of those predicates.
+    The main results about parity are proved in the module Div2. *)
+
+Open Local Scope nat_scope.
+
+Implicit Types m n : nat.
+
+Inductive even : nat -> Prop :=
+  | even_O : even 0
+  | even_S : forall n, odd n -> even (S n)
+with odd : nat -> Prop :=
+    odd_S : forall n, even n -> odd (S n).
+
+Hint Constructors even: arith.
+Hint Constructors odd: arith.
+
+Lemma even_or_odd : forall n, even n \/ odd n.
+Proof.
+induction n.
+auto with arith.
+elim IHn; auto with arith.
+Qed.
+
+Lemma even_odd_dec : forall n, {even n} + {odd n}.
+Proof.
+induction n.
+auto with arith.
+elim IHn; auto with arith.
+Qed.
+
+Lemma not_even_and_odd : forall n, even n -> odd n -> False.
+Proof.
+induction n.
+intros. inversion H0.
+intros. inversion H. inversion H0. auto with arith.
+Qed.
+
+Lemma even_plus_aux :
+ forall n m,
+   (odd (n + m) <-> odd n /\ even m \/ even n /\ odd m) /\
+   (even (n + m) <-> even n /\ even m \/ odd n /\ odd m).
+Proof.
+intros n; elim n; simpl in |- *; auto with arith.
+intros m; split; auto.
+split.
+intros H; right; split; auto with arith.
+intros H'; case H'; auto with arith.
+intros H'0; elim H'0; intros H'1 H'2; inversion H'1.
+intros H; elim H; auto.
+split; auto with arith.
+intros H'; elim H'; auto with arith.
+intros H; elim H; auto.
+intros H'0; elim H'0; intros H'1 H'2; inversion H'1.
+intros n0 H' m; elim (H' m); intros H'1 H'2; elim H'1; intros E1 E2; elim H'2;
+ intros E3 E4; clear H'1 H'2.
+split; split.
+intros H'0; case E3.
+inversion H'0; auto.
+intros H; elim H; intros H0 H1; clear H; auto with arith.
+intros H; elim H; intros H0 H1; clear H; auto with arith.
+intros H'0; case H'0; intros C0; case C0; intros C1 C2.
+apply odd_S.
+apply E4; left; split; auto with arith.
+inversion C1; auto.
+apply odd_S.
+apply E4; right; split; auto with arith.
+inversion C1; auto.
+intros H'0.
+case E1.
+inversion H'0; auto.
+intros H; elim H; intros H0 H1; clear H; auto with arith.
+intros H; elim H; intros H0 H1; clear H; auto with arith.
+intros H'0; case H'0; intros C0; case C0; intros C1 C2.
+apply even_S.
+apply E2; left; split; auto with arith.
+inversion C1; auto.
+apply even_S.
+apply E2; right; split; auto with arith.
+inversion C1; auto.
+Qed.
+ 
+Lemma even_even_plus : forall n m, even n -> even m -> even (n + m).
+Proof.
+intros n m; case (even_plus_aux n m).
+intros H H0; case H0; auto.
+Qed.
+ 
+Lemma odd_even_plus : forall n m, odd n -> odd m -> even (n + m).
+Proof.
+intros n m; case (even_plus_aux n m).
+intros H H0; case H0; auto.
+Qed.
+ 
+Lemma even_plus_even_inv_r : forall n m, even (n + m) -> even n -> even m.
+Proof.
+intros n m H; case (even_plus_aux n m).
+intros H' H'0; elim H'0.
+intros H'1; case H'1; auto.
+intros H0; elim H0; auto.
+intros H0 H1 H2; case (not_even_and_odd n); auto.
+case H0; auto.
+Qed.
+ 
+Lemma even_plus_even_inv_l : forall n m, even (n + m) -> even m -> even n.
+Proof.
+intros n m H; case (even_plus_aux n m).
+intros H' H'0; elim H'0.
+intros H'1; case H'1; auto.
+intros H0; elim H0; auto.
+intros H0 H1 H2; case (not_even_and_odd m); auto.
+case H0; auto.
+Qed.
+ 
+Lemma even_plus_odd_inv_r : forall n m, even (n + m) -> odd n -> odd m.
+Proof.
+intros n m H; case (even_plus_aux n m).
+intros H' H'0; elim H'0.
+intros H'1; case H'1; auto.
+intros H0 H1 H2; case (not_even_and_odd n); auto.
+case H0; auto.
+intros H0; case H0; auto.
+Qed.
+ 
+Lemma even_plus_odd_inv_l : forall n m, even (n + m) -> odd m -> odd n.
+Proof.
+intros n m H; case (even_plus_aux n m).
+intros H' H'0; elim H'0.
+intros H'1; case H'1; auto.
+intros H0 H1 H2; case (not_even_and_odd m); auto.
+case H0; auto.
+intros H0; case H0; auto.
+Qed.
+Hint Resolve even_even_plus odd_even_plus: arith.
+ 
+Lemma odd_plus_l : forall n m, odd n -> even m -> odd (n + m).
+Proof.
+intros n m; case (even_plus_aux n m).
+intros H; case H; auto.
+Qed.
+ 
+Lemma odd_plus_r : forall n m, even n -> odd m -> odd (n + m).
+Proof.
+intros n m; case (even_plus_aux n m).
+intros H; case H; auto.
+Qed.
+ 
+Lemma odd_plus_even_inv_l : forall n m, odd (n + m) -> odd m -> even n.
+Proof.
+intros n m H; case (even_plus_aux n m).
+intros H' H'0; elim H'.
+intros H'1; case H'1; auto.
+intros H0 H1 H2; case (not_even_and_odd m); auto.
+case H0; auto.
+intros H0; case H0; auto.
+Qed.
+ 
+Lemma odd_plus_even_inv_r : forall n m, odd (n + m) -> odd n -> even m.
+Proof.
+intros n m H; case (even_plus_aux n m).
+intros H' H'0; elim H'.
+intros H'1; case H'1; auto.
+intros H0; case H0; auto.
+intros H0 H1 H2; case (not_even_and_odd n); auto.
+case H0; auto.
+Qed.
+ 
+Lemma odd_plus_odd_inv_l : forall n m, odd (n + m) -> even m -> odd n.
+Proof.
+intros n m H; case (even_plus_aux n m).
+intros H' H'0; elim H'.
+intros H'1; case H'1; auto.
+intros H0; case H0; auto.
+intros H0 H1 H2; case (not_even_and_odd m); auto.
+case H0; auto.
+Qed.
+ 
+Lemma odd_plus_odd_inv_r : forall n m, odd (n + m) -> even n -> odd m.
+Proof.
+intros n m H; case (even_plus_aux n m).
+intros H' H'0; elim H'.
+intros H'1; case H'1; auto.
+intros H0 H1 H2; case (not_even_and_odd n); auto.
+case H0; auto.
+intros H0; case H0; auto.
+Qed.
+Hint Resolve odd_plus_l odd_plus_r: arith.
+ 
+Lemma even_mult_aux :
+ forall n m,
+   (odd (n * m) <-> odd n /\ odd m) /\ (even (n * m) <-> even n \/ even m).
+Proof.
+intros n; elim n; simpl in |- *; auto with arith.
+intros m; split; split; auto with arith.
+intros H'; inversion H'.
+intros H'; elim H'; auto.
+intros n0 H' m; split; split; auto with arith.
+intros H'0.
+elim (even_plus_aux m (n0 * m)); intros H'3 H'4; case H'3; intros H'1 H'2;
+ case H'1; auto.
+intros H'5; elim H'5; intros H'6 H'7; auto with arith.
+split; auto with arith.
+case (H' m).
+intros H'8 H'9; case H'9.
+intros H'10; case H'10; auto with arith.
+intros H'11 H'12; case (not_even_and_odd m); auto with arith.
+intros H'5; elim H'5; intros H'6 H'7; case (not_even_and_odd (n0 * m)); auto.
+case (H' m).
+intros H'8 H'9; case H'9; auto.
+intros H'0; elim H'0; intros H'1 H'2; clear H'0.
+elim (even_plus_aux m (n0 * m)); auto.
+intros H'0 H'3.
+elim H'0.
+intros H'4 H'5; apply H'5; auto.
+left; split; auto with arith.
+case (H' m).
+intros H'6 H'7; elim H'7.
+intros H'8 H'9; apply H'9.
+left.
+inversion H'1; auto.
+intros H'0.
+elim (even_plus_aux m (n0 * m)); intros H'3 H'4; case H'4.
+intros H'1 H'2.
+elim H'1; auto.
+intros H; case H; auto.
+intros H'5; elim H'5; intros H'6 H'7; auto with arith.
+left.
+case (H' m).
+intros H'8; elim H'8.
+intros H'9; elim H'9; auto with arith.
+intros H'0; elim H'0; intros H'1.
+case (even_or_odd m); intros H'2.
+apply even_even_plus; auto.
+case (H' m).
+intros H H0; case H0; auto.
+apply odd_even_plus; auto.
+inversion H'1; case (H' m); auto.
+intros H1; case H1; auto.
+apply even_even_plus; auto.
+case (H' m).
+intros H H0; case H0; auto.
+Qed.
+ 
+Lemma even_mult_l : forall n m, even n -> even (n * m).
+Proof.
+intros n m; case (even_mult_aux n m); auto.
+intros H H0; case H0; auto.
+Qed.
+ 
+Lemma even_mult_r : forall n m, even m -> even (n * m).
+Proof.
+intros n m; case (even_mult_aux n m); auto.
+intros H H0; case H0; auto.
+Qed.
+Hint Resolve even_mult_l even_mult_r: arith.
+ 
+Lemma even_mult_inv_r : forall n m, even (n * m) -> odd n -> even m.
+Proof.
+intros n m H' H'0.
+case (even_mult_aux n m).
+intros H'1 H'2; elim H'2.
+intros H'3; elim H'3; auto.
+intros H; case (not_even_and_odd n); auto.
+Qed.
+ 
+Lemma even_mult_inv_l : forall n m, even (n * m) -> odd m -> even n.
+Proof.
+intros n m H' H'0.
+case (even_mult_aux n m).
+intros H'1 H'2; elim H'2.
+intros H'3; elim H'3; auto.
+intros H; case (not_even_and_odd m); auto.
+Qed.
+ 
+Lemma odd_mult : forall n m, odd n -> odd m -> odd (n * m).
+Proof.
+intros n m; case (even_mult_aux n m); intros H; case H; auto.
+Qed.
+Hint Resolve even_mult_l even_mult_r odd_mult: arith.
+ 
+Lemma odd_mult_inv_l : forall n m, odd (n * m) -> odd n.
+Proof.
+intros n m H'.
+case (even_mult_aux n m).
+intros H'1 H'2; elim H'1.
+intros H'3; elim H'3; auto.
+Qed.
+ 
+Lemma odd_mult_inv_r : forall n m, odd (n * m) -> odd m.
+Proof.
+intros n m H'.
+case (even_mult_aux n m).
+intros H'1 H'2; elim H'1.
+intros H'3; elim H'3; auto.
+Qed.
diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v
new file mode 100644
index 00000000..4db211e4
--- /dev/null
+++ b/theories/Arith/Factorial.v
@@ -0,0 +1,50 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Factorial.v,v 1.5.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Plus.
+Require Import Mult.
+Require Import Lt.
+Open Local Scope nat_scope.
+
+(** Factorial *)
+
+Fixpoint fact (n:nat) : nat :=
+  match n with
+  | O => 1
+  | S n => S n * fact n
+  end.
+
+Arguments Scope fact [nat_scope].
+
+Lemma lt_O_fact : forall n:nat, 0 < fact n.
+Proof.
+simple induction n; unfold lt in |- *; simpl in |- *; auto with arith.
+Qed.
+
+Lemma fact_neq_0 : forall n:nat, fact n <> 0.
+Proof.
+intro.
+apply sym_not_eq.
+apply lt_O_neq.
+apply lt_O_fact.
+Qed.
+
+Lemma fact_le : forall n m:nat, n <= m -> fact n <= fact m.
+Proof.
+induction 1.
+apply le_n.
+assert (1 * fact n <= S m * fact m).
+apply mult_le_compat.
+apply lt_le_S; apply lt_O_Sn.
+assumption.
+simpl (1 * fact n) in H0.
+rewrite <- plus_n_O in H0.
+assumption.
+Qed.
\ No newline at end of file
diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v
new file mode 100755
index 00000000..299c664d
--- /dev/null
+++ b/theories/Arith/Gt.v
@@ -0,0 +1,148 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Gt.v,v 1.8.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Le.
+Require Import Lt.
+Require Import Plus.
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+(** Order and successor *)
+
+Theorem gt_Sn_O : forall n, S n > 0.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve gt_Sn_O: arith v62.
+
+Theorem gt_Sn_n : forall n, S n > n.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve gt_Sn_n: arith v62.
+
+Theorem gt_n_S : forall n m, n > m -> S n > S m.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve gt_n_S: arith v62.
+
+Lemma gt_S_n : forall n m, S m > S n -> m > n.
+Proof.
+  auto with arith.
+Qed.
+Hint Immediate gt_S_n: arith v62.
+
+Theorem gt_S : forall n m, S n > m -> n > m \/ m = n.
+Proof.
+  intros n m H; unfold gt in |- *; apply le_lt_or_eq; auto with arith.
+Qed.
+
+Lemma gt_pred : forall n m, m > S n -> pred m > n.
+Proof.
+  auto with arith.
+Qed.
+Hint Immediate gt_pred: arith v62.
+
+(** Irreflexivity *)
+
+Lemma gt_irrefl : forall n, ~ n > n.
+Proof lt_irrefl.
+Hint Resolve gt_irrefl: arith v62.
+
+(** Asymmetry *)
+
+Lemma gt_asym : forall n m, n > m -> ~ m > n.
+Proof fun n m => lt_asym m n.
+
+Hint Resolve gt_asym: arith v62.
+
+(** Relating strict and large orders *)
+
+Lemma le_not_gt : forall n m, n <= m -> ~ n > m.
+Proof le_not_lt.
+Hint Resolve le_not_gt: arith v62.
+
+Lemma gt_not_le : forall n m, n > m -> ~ n <= m.
+Proof.
+auto with arith.
+Qed.
+
+Hint Resolve gt_not_le: arith v62.
+
+Theorem le_S_gt : forall n m, S n <= m -> m > n.
+Proof.
+  auto with arith.
+Qed.
+Hint Immediate le_S_gt: arith v62.
+
+Lemma gt_S_le : forall n m, S m > n -> n <= m.
+Proof.
+  intros n p; exact (lt_n_Sm_le n p).
+Qed.
+Hint Immediate gt_S_le: arith v62.
+
+Lemma gt_le_S : forall n m, m > n -> S n <= m.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve gt_le_S: arith v62.
+
+Lemma le_gt_S : forall n m, n <= m -> S m > n.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve le_gt_S: arith v62.
+
+(** Transitivity *)
+
+Theorem le_gt_trans : forall n m p, m <= n -> m > p -> n > p.
+Proof.
+  red in |- *; intros; apply lt_le_trans with m; auto with arith.
+Qed.
+
+Theorem gt_le_trans : forall n m p, n > m -> p <= m -> n > p.
+Proof.
+  red in |- *; intros; apply le_lt_trans with m; auto with arith.
+Qed.
+
+Lemma gt_trans : forall n m p, n > m -> m > p -> n > p.
+Proof.
+  red in |- *; intros n m p H1 H2.
+  apply lt_trans with m; auto with arith.
+Qed.
+
+Theorem gt_trans_S : forall n m p, S n > m -> m > p -> n > p.
+Proof.
+  red in |- *; intros; apply lt_le_trans with m; auto with arith.
+Qed.
+
+Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62.
+
+(** Comparison to 0 *)
+
+Theorem gt_O_eq : forall n, n > 0 \/ 0 = n.
+Proof.
+  intro n; apply gt_S; auto with arith.
+Qed.
+
+(** Simplification and compatibility *)
+
+Lemma plus_gt_reg_l : forall n m p, p + n > p + m -> n > m.
+Proof.
+  red in |- *; intros n m p H; apply plus_lt_reg_l with p; auto with arith.
+Qed.
+
+Lemma plus_gt_compat_l : forall n m p, n > m -> p + n > p + m.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve plus_gt_compat_l: arith v62.
\ No newline at end of file
diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v
new file mode 100755
index 00000000..a5378cff
--- /dev/null
+++ b/theories/Arith/Le.v
@@ -0,0 +1,122 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Le.v,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+(** Order on natural numbers *)
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+(** Reflexivity *)
+
+Theorem le_refl : forall n, n <= n.
+Proof.
+exact le_n.
+Qed.
+
+(** Transitivity *)
+
+Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p.
+Proof.
+  induction 2; auto.
+Qed.
+Hint Resolve le_trans: arith v62.
+
+(** Order, successor and predecessor *)
+
+Theorem le_n_S : forall n m, n <= m -> S n <= S m.
+Proof.
+  induction 1; auto.
+Qed.
+
+Theorem le_n_Sn : forall n, n <= S n.
+Proof.
+  auto.
+Qed.
+
+Theorem le_O_n : forall n, 0 <= n.
+Proof.
+  induction n; auto.
+Qed.
+
+Hint Resolve le_n_S le_n_Sn le_O_n le_n_S: arith v62.
+
+Theorem le_pred_n : forall n, pred n <= n.
+Proof.
+induction n; auto with arith.
+Qed.
+Hint Resolve le_pred_n: arith v62.
+
+Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
+Proof.
+intros n m H; apply le_trans with (S n); auto with arith.
+Qed.
+Hint Immediate le_Sn_le: arith v62.
+
+Theorem le_S_n : forall n m, S n <= S m -> n <= m.
+Proof.
+intros n m H; change (pred (S n) <= pred (S m)) in |- *.
+elim H; simpl in |- *; auto with arith.
+Qed.
+Hint Immediate le_S_n: arith v62.
+
+Theorem le_pred : forall n m, n <= m -> pred n <= pred m.
+Proof.
+induction n as [| n IHn]. simpl in |- *. auto with arith.
+destruct m as [| m]. simpl in |- *. intro H. inversion H.
+simpl in |- *. auto with arith.
+Qed.
+
+(** Comparison to 0 *)
+
+Theorem le_Sn_O : forall n, ~ S n <= 0.
+Proof.
+red in |- *; intros n H.
+change (IsSucc 0) in |- *; elim H; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve le_Sn_O: arith v62.
+
+Theorem le_n_O_eq : forall n, n <= 0 -> 0 = n.
+Proof.
+induction n; auto with arith.
+intro; contradiction le_Sn_O with n.
+Qed.
+Hint Immediate le_n_O_eq: arith v62.
+
+(** Negative properties *)
+
+Theorem le_Sn_n : forall n, ~ S n <= n.
+Proof.
+induction n; auto with arith.
+Qed.
+Hint Resolve le_Sn_n: arith v62.
+
+(** Antisymmetry *)
+
+Theorem le_antisym : forall n m, n <= m -> m <= n -> n = m.
+Proof.
+intros n m h; destruct h as [| m0 H]; auto with arith.
+intros H1.
+absurd (S m0 <= m0); auto with arith.
+apply le_trans with n; auto with arith.
+Qed.
+Hint Immediate le_antisym: arith v62.
+
+(** A different elimination principle for the order on natural numbers *)
+
+Lemma le_elim_rel :
+ forall P:nat -> nat -> Prop,
+   (forall p, P 0 p) ->
+   (forall p (q:nat), p <= q -> P p q -> P (S p) (S q)) ->
+   forall n m, n <= m -> P n m.
+Proof.
+induction n; auto with arith.
+intros m Le.
+elim Le; auto with arith.
+Qed.
\ No newline at end of file
diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v
new file mode 100755
index 00000000..e1b3e4b8
--- /dev/null
+++ b/theories/Arith/Lt.v
@@ -0,0 +1,175 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Lt.v,v 1.11.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Le.
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+(** Irreflexivity *)
+
+Theorem lt_irrefl : forall n, ~ n < n.
+Proof le_Sn_n.
+Hint Resolve lt_irrefl: arith v62.
+
+(** Relationship between [le] and [lt] *) 
+
+Theorem lt_le_S : forall n m, n < m -> S n <= m.
+Proof.
+auto with arith.
+Qed.
+Hint Immediate lt_le_S: arith v62.
+
+Theorem lt_n_Sm_le : forall n m, n < S m -> n <= m.
+Proof.
+auto with arith.
+Qed.
+Hint Immediate lt_n_Sm_le: arith v62.
+
+Theorem le_lt_n_Sm : forall n m, n <= m -> n < S m.
+Proof.
+auto with arith.
+Qed.
+Hint Immediate le_lt_n_Sm: arith v62.
+
+Theorem le_not_lt : forall n m, n <= m -> ~ m < n.
+Proof.
+induction 1; auto with arith.
+Qed.
+
+Theorem lt_not_le : forall n m, n < m -> ~ m <= n.
+Proof.
+red in |- *; intros n m Lt Le; exact (le_not_lt m n Le Lt).
+Qed.
+Hint Immediate le_not_lt lt_not_le: arith v62.
+
+(** Asymmetry *)
+
+Theorem lt_asym : forall n m, n < m -> ~ m < n.
+Proof.
+induction 1; auto with arith.
+Qed.
+
+(** Order and successor *)
+
+Theorem lt_n_Sn : forall n, n < S n.
+Proof.
+auto with arith.
+Qed.
+Hint Resolve lt_n_Sn: arith v62.
+
+Theorem lt_S : forall n m, n < m -> n < S m.
+Proof.
+auto with arith.
+Qed.
+Hint Resolve lt_S: arith v62.
+
+Theorem lt_n_S : forall n m, n < m -> S n < S m.
+Proof.
+auto with arith.
+Qed.
+Hint Resolve lt_n_S: arith v62.
+
+Theorem lt_S_n : forall n m, S n < S m -> n < m.
+Proof.
+auto with arith.
+Qed.
+Hint Immediate lt_S_n: arith v62.
+
+Theorem lt_O_Sn : forall n, 0 < S n.
+Proof.
+auto with arith.
+Qed.
+Hint Resolve lt_O_Sn: arith v62.
+
+Theorem lt_n_O : forall n, ~ n < 0.
+Proof le_Sn_O.
+Hint Resolve lt_n_O: arith v62.
+
+(** Predecessor *)
+
+Lemma S_pred : forall n m, m < n -> n = S (pred n).
+Proof.
+induction 1; auto with arith.
+Qed.
+
+Lemma lt_pred : forall n m, S n < m -> n < pred m.
+Proof.
+induction 1; simpl in |- *; auto with arith.
+Qed.
+Hint Immediate lt_pred: arith v62.
+
+Lemma lt_pred_n_n : forall n, 0 < n -> pred n < n.
+destruct 1; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve lt_pred_n_n: arith v62.
+
+(** Transitivity properties *)
+
+Theorem lt_trans : forall n m p, n < m -> m < p -> n < p.
+Proof.
+induction 2; auto with arith.
+Qed.
+
+Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p.
+Proof.
+induction 2; auto with arith.
+Qed.
+
+Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p.
+Proof.
+induction 2; auto with arith.
+Qed.
+
+Hint Resolve lt_trans lt_le_trans le_lt_trans: arith v62.
+
+(** Large = strict or equal *)
+
+Theorem le_lt_or_eq : forall n m, n <= m -> n < m \/ n = m.
+Proof.
+induction 1; auto with arith.
+Qed.
+
+Theorem lt_le_weak : forall n m, n < m -> n <= m.
+Proof.
+auto with arith.
+Qed.
+Hint Immediate lt_le_weak: arith v62.
+
+(** Dichotomy *)
+
+Theorem le_or_lt : forall n m, n <= m \/ m < n.
+Proof.
+intros n m; pattern n, m in |- *; apply nat_double_ind; auto with arith.
+induction 1; auto with arith.
+Qed.
+
+Theorem nat_total_order : forall n m, n <> m -> n < m \/ m < n.
+Proof.
+intros m n diff.
+elim (le_or_lt n m); [ intro H'0 | auto with arith ].
+elim (le_lt_or_eq n m); auto with arith.
+intro H'; elim diff; auto with arith.
+Qed.
+
+(** Comparison to 0 *)
+
+Theorem neq_O_lt : forall n, 0 <> n -> 0 < n.
+Proof.
+induction n; auto with arith.
+intros; absurd (0 = 0); trivial with arith.
+Qed.
+Hint Immediate neq_O_lt: arith v62.
+
+Theorem lt_O_neq : forall n, 0 < n -> 0 <> n.
+Proof.
+induction 1; auto with arith.
+Qed.
+Hint Immediate lt_O_neq: arith v62.
\ No newline at end of file
diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v
new file mode 100755
index 00000000..82673ed0
--- /dev/null
+++ b/theories/Arith/Max.v
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Max.v,v 1.7.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Arith.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n : nat.
+
+(** maximum of two natural numbers *)
+
+Fixpoint max n m {struct n} : nat :=
+  match n, m with
+  | O, _ => m
+  | S n', O => n
+  | S n', S m' => S (max n' m')
+  end.
+
+(** Simplifications of [max] *)
+
+Lemma max_SS : forall n m, S (max n m) = max (S n) (S m).
+Proof.
+auto with arith.
+Qed.
+
+Lemma max_comm : forall n m, max n m = max m n.
+Proof.
+induction n; induction m; simpl in |- *; auto with arith.
+Qed.
+
+(** [max] and [le] *)
+
+Lemma max_l : forall n m, m <= n -> max n m = n.
+Proof.
+induction n; induction m; simpl in |- *; auto with arith.
+Qed.
+
+Lemma max_r : forall n m, n <= m -> max n m = m.
+Proof.
+induction n; induction m; simpl in |- *; auto with arith.
+Qed.
+
+Lemma le_max_l : forall n m, n <= max n m.
+Proof.
+induction n; intros; simpl in |- *; auto with arith.
+elim m; intros; simpl in |- *; auto with arith.
+Qed.
+
+Lemma le_max_r : forall n m, m <= max n m.
+Proof.
+induction n; simpl in |- *; auto with arith.
+induction m; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve max_r max_l le_max_l le_max_r: arith v62.
+
+
+(** [max n m] is equal to [n] or [m] *)
+
+Lemma max_dec : forall n m, {max n m = n} + {max n m = m}.
+Proof.
+induction n; induction m; simpl in |- *; auto with arith.
+elim (IHn m); intro H; elim H; auto.
+Qed.
+
+Lemma max_case : forall n m (P:nat -> Set), P n -> P m -> P (max n m).
+Proof.
+induction n; simpl in |- *; auto with arith.
+induction m; intros; simpl in |- *; auto with arith.
+pattern (max n m) in |- *; apply IHn; auto with arith.
+Qed.
+
+Lemma max_case2 : forall n m (P:nat -> Prop), P n -> P m -> P (max n m).
+Proof.
+induction n; simpl in |- *; auto with arith.
+induction m; intros; simpl in |- *; auto with arith.
+pattern (max n m) in |- *; apply IHn; auto with arith.
+Qed.
+
diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v
new file mode 100755
index 00000000..912e7ba3
--- /dev/null
+++ b/theories/Arith/Min.v
@@ -0,0 +1,83 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Min.v,v 1.10.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Arith.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n : nat.
+
+(** minimum of two natural numbers *)
+
+Fixpoint min n m {struct n} : nat :=
+  match n, m with
+  | O, _ => 0
+  | S n', O => 0
+  | S n', S m' => S (min n' m')
+  end.
+
+(** Simplifications of [min] *)
+
+Lemma min_SS : forall n m, S (min n m) = min (S n) (S m).
+Proof.
+auto with arith.
+Qed.
+
+Lemma min_comm : forall n m, min n m = min m n.
+Proof.
+induction n; induction m; simpl in |- *; auto with arith.
+Qed.
+
+(** [min] and [le] *)
+
+Lemma min_l : forall n m, n <= m -> min n m = n.
+Proof.
+induction n; induction m; simpl in |- *; auto with arith.
+Qed.
+
+Lemma min_r : forall n m, m <= n -> min n m = m.
+Proof.
+induction n; induction m; simpl in |- *; auto with arith.
+Qed.
+
+Lemma le_min_l : forall n m, min n m <= n.
+Proof.
+induction n; intros; simpl in |- *; auto with arith.
+elim m; intros; simpl in |- *; auto with arith.
+Qed.
+
+Lemma le_min_r : forall n m, min n m <= m.
+Proof.
+induction n; simpl in |- *; auto with arith.
+induction m; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve min_l min_r le_min_l le_min_r: arith v62.
+
+(** [min n m] is equal to [n] or [m] *)
+
+Lemma min_dec : forall n m, {min n m = n} + {min n m = m}.
+Proof.
+induction n; induction m; simpl in |- *; auto with arith.
+elim (IHn m); intro H; elim H; auto.
+Qed.
+
+Lemma min_case : forall n m (P:nat -> Set), P n -> P m -> P (min n m).
+Proof.
+induction n; simpl in |- *; auto with arith.
+induction m; intros; simpl in |- *; auto with arith.
+pattern (min n m) in |- *; apply IHn; auto with arith.
+Qed.
+
+Lemma min_case2 : forall n m (P:nat -> Prop), P n -> P m -> P (min n m).
+Proof.
+induction n; simpl in |- *; auto with arith.
+induction m; intros; simpl in |- *; auto with arith.
+pattern (min n m) in |- *; apply IHn; auto with arith.
+Qed.
\ No newline at end of file
diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v
new file mode 100755
index 00000000..ba9a46ad
--- /dev/null
+++ b/theories/Arith/Minus.v
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Minus.v,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+(** Subtraction (difference between two natural numbers) *)
+
+Require Import Lt.
+Require Import Le.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+(** 0 is right neutral *)
+
+Lemma minus_n_O : forall n, n = n - 0.
+Proof.
+induction n; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve minus_n_O: arith v62.
+
+(** Permutation with successor *)
+
+Lemma minus_Sn_m : forall n m, m <= n -> S (n - m) = S n - m.
+Proof.
+intros n m Le; pattern m, n in |- *; apply le_elim_rel; simpl in |- *;
+ auto with arith.
+Qed.
+Hint Resolve minus_Sn_m: arith v62.
+
+Theorem pred_of_minus : forall n, pred n = n - 1.
+intro x; induction x; simpl in |- *; auto with arith.
+Qed.
+
+(** Diagonal *)
+
+Lemma minus_n_n : forall n, 0 = n - n.
+Proof.
+induction n; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve minus_n_n: arith v62.
+
+(** Simplification *)
+
+Lemma minus_plus_simpl_l_reverse : forall n m p, n - m = p + n - (p + m).
+Proof.
+  induction p; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve minus_plus_simpl_l_reverse: arith v62.
+
+(** Relation with plus *)
+
+Lemma plus_minus : forall n m p, n = m + p -> p = n - m.
+Proof.
+intros n m p; pattern m, n in |- *; apply nat_double_ind; simpl in |- *;
+ intros.
+replace (n0 - 0) with n0; auto with arith.
+absurd (0 = S (n0 + p)); auto with arith.
+auto with arith.
+Qed.
+Hint Immediate plus_minus: arith v62.
+
+Lemma minus_plus : forall n m, n + m - n = m.
+symmetry  in |- *; auto with arith.
+Qed.
+Hint Resolve minus_plus: arith v62.
+
+Lemma le_plus_minus : forall n m, n <= m -> m = n + (m - n).
+Proof.
+intros n m Le; pattern n, m in |- *; apply le_elim_rel; simpl in |- *;
+ auto with arith.
+Qed.
+Hint Resolve le_plus_minus: arith v62.
+
+Lemma le_plus_minus_r : forall n m, n <= m -> n + (m - n) = m.
+Proof.
+symmetry  in |- *; auto with arith.
+Qed.
+Hint Resolve le_plus_minus_r: arith v62.
+
+(** Relation with order *)
+
+Theorem le_minus : forall n m, n - m <= n.
+Proof.
+intros i h; pattern i, h in |- *; apply nat_double_ind;
+ [ auto
+ | auto
+ | intros m n H; simpl in |- *; apply le_trans with (m := m); auto ].
+Qed.
+
+Lemma lt_minus : forall n m, m <= n -> 0 < m -> n - m < n.
+Proof.
+intros n m Le; pattern m, n in |- *; apply le_elim_rel; simpl in |- *;
+ auto with arith.
+intros; absurd (0 < 0); auto with arith.
+intros p q lepq Hp gtp.
+elim (le_lt_or_eq 0 p); auto with arith.
+auto with arith.
+induction 1; elim minus_n_O; auto with arith.
+Qed.
+Hint Resolve lt_minus: arith v62.
+
+Lemma lt_O_minus_lt : forall n m, 0 < n - m -> m < n.
+Proof.
+intros n m; pattern n, m in |- *; apply nat_double_ind; simpl in |- *;
+ auto with arith.
+intros; absurd (0 < 0); trivial with arith.
+Qed.
+Hint Immediate lt_O_minus_lt: arith v62.
+
+Theorem not_le_minus_0 : forall n m, ~ m <= n -> n - m = 0.
+intros y x; pattern y, x in |- *; apply nat_double_ind;
+ [ simpl in |- *; trivial with arith
+ | intros n H; absurd (0 <= S n); [ assumption | apply le_O_n ]
+ | simpl in |- *; intros n m H1 H2; apply H1; unfold not in |- *; intros H3;
+    apply H2; apply le_n_S; assumption ].
+Qed.
\ No newline at end of file
diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v
new file mode 100755
index 00000000..abfade57
--- /dev/null
+++ b/theories/Arith/Mult.v
@@ -0,0 +1,211 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Mult.v,v 1.21.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Export Plus.
+Require Export Minus.
+Require Export Lt.
+Require Export Le.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+(** Zero property *)
+
+Lemma mult_0_r : forall n, n * 0 = 0.
+Proof.
+intro; symmetry  in |- *; apply mult_n_O.
+Qed.
+
+Lemma mult_0_l : forall n, 0 * n = 0.
+Proof.
+reflexivity.
+Qed.
+
+(** Distributivity *)
+
+Lemma mult_plus_distr_r : forall n m p, (n + m) * p = n * p + m * p.
+Proof.
+intros; elim n; simpl in |- *; intros; auto with arith.
+elim plus_assoc; elim H; auto with arith.
+Qed.
+Hint Resolve mult_plus_distr_r: arith v62.
+
+Lemma mult_plus_distr_l : forall n m p, n * (m + p) = n * m + n * p.
+Proof.
+  induction n. trivial.
+  intros. simpl in |- *. rewrite (IHn m p). apply sym_eq. apply plus_permute_2_in_4.
+Qed.
+
+Lemma mult_minus_distr_r : forall n m p, (n - m) * p = n * p - m * p.
+Proof.
+intros; pattern n, m in |- *; apply nat_double_ind; simpl in |- *; intros;
+ auto with arith.
+elim minus_plus_simpl_l_reverse; auto with arith.
+Qed.
+Hint Resolve mult_minus_distr_r: arith v62.
+
+(** Associativity *)
+
+Lemma mult_assoc_reverse : forall n m p, n * m * p = n * (m * p).
+Proof.
+intros; elim n; intros; simpl in |- *; auto with arith.
+rewrite mult_plus_distr_r.
+elim H; auto with arith.
+Qed.
+Hint Resolve mult_assoc_reverse: arith v62.
+
+Lemma mult_assoc : forall n m p, n * (m * p) = n * m * p.
+Proof.
+auto with arith.
+Qed.
+Hint Resolve mult_assoc: arith v62.
+
+(** Commutativity *)
+
+Lemma mult_comm : forall n m, n * m = m * n.
+Proof.
+intros; elim n; intros; simpl in |- *; auto with arith.
+elim mult_n_Sm.
+elim H; apply plus_comm.
+Qed.
+Hint Resolve mult_comm: arith v62.
+
+(** 1 is neutral *)
+
+Lemma mult_1_l : forall n, 1 * n = n.
+Proof.
+simpl in |- *; auto with arith.
+Qed.
+Hint Resolve mult_1_l: arith v62.
+
+Lemma mult_1_r : forall n, n * 1 = n.
+Proof.
+intro; elim mult_comm; auto with arith.
+Qed.
+Hint Resolve mult_1_r: arith v62.
+
+(** Compatibility with orders *)
+
+Lemma mult_O_le : forall n m, m = 0 \/ n <= m * n.
+Proof.
+induction m; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve mult_O_le: arith v62.
+
+Lemma mult_le_compat_l : forall n m p, n <= m -> p * n <= p * m.
+Proof.
+  induction p as [| p IHp]. intros. simpl in |- *. apply le_n.
+  intros. simpl in |- *. apply plus_le_compat. assumption.
+  apply IHp. assumption.
+Qed.
+Hint Resolve mult_le_compat_l: arith.
+
+
+Lemma mult_le_compat_r : forall n m p, n <= m -> n * p <= m * p.
+intros m n p H.
+rewrite mult_comm. rewrite (mult_comm n).
+auto with arith.
+Qed.
+
+Lemma mult_le_compat :
+ forall n m p (q:nat), n <= m -> p <= q -> n * p <= m * q.
+Proof.
+intros m n p q Hmn Hpq; induction Hmn.
+induction Hpq.
+(* m*p<=m*p *)
+apply le_n.
+(* m*p<=m*m0 -> m*p<=m*(S m0) *)
+rewrite <- mult_n_Sm; apply le_trans with (m * m0).
+assumption.
+apply le_plus_l.
+(* m*p<=m0*q -> m*p<=(S m0)*q *)
+simpl in |- *; apply le_trans with (m0 * q).
+assumption.
+apply le_plus_r.
+Qed.
+
+Lemma mult_S_lt_compat_l : forall n m p, m < p -> S n * m < S n * p.
+Proof.
+  intro m; induction m. intros. simpl in |- *. rewrite <- plus_n_O. rewrite <- plus_n_O. assumption.
+  intros. exact (plus_lt_compat _ _ _ _ H (IHm _ _ H)).
+Qed.
+
+Hint Resolve mult_S_lt_compat_l: arith.
+
+Lemma mult_lt_compat_r : forall n m p, n < m -> 0 < p -> n * p < m * p.
+intros m n p H H0.
+induction p.
+elim (lt_irrefl _ H0).
+rewrite mult_comm.
+replace (n * S p) with (S p * n); auto with arith.
+Qed.
+
+Lemma mult_S_le_reg_l : forall n m p, S n * m <= S n * p -> m <= p.
+Proof.
+  intros m n p H. elim (le_or_lt n p). trivial.
+  intro H0. cut (S m * n < S m * n). intro. elim (lt_irrefl _ H1).
+  apply le_lt_trans with (m := S m * p). assumption.
+  apply mult_S_lt_compat_l. assumption.
+Qed.
+
+(** n|->2*n and n|->2n+1 have disjoint image *)
+
+Theorem odd_even_lem : forall p q, 2 * p + 1 <> 2 * q.
+intros p; elim p; auto.
+intros q; case q; simpl in |- *.
+red in |- *; intros; discriminate.
+intros q'; rewrite (fun x y => plus_comm x (S y)); simpl in |- *; red in |- *;
+ intros; discriminate.
+intros p' H q; case q.
+simpl in |- *; red in |- *; intros; discriminate.
+intros q'; red in |- *; intros H0; case (H q').
+replace (2 * q') with (2 * S q' - 2).
+rewrite <- H0; simpl in |- *; auto.
+repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *; auto.
+simpl in |- *; repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *;
+ auto.
+case q'; simpl in |- *; auto.
+Qed.
+
+
+(** Tail-recursive mult *)
+
+(** [tail_mult] is an alternative definition for [mult] which is 
+    tail-recursive, whereas [mult] is not. This can be useful 
+    when extracting programs. *)
+
+Fixpoint mult_acc (s:nat) m n {struct n} : nat :=
+  match n with
+  | O => s
+  | S p => mult_acc (tail_plus m s) m p
+  end.
+
+Lemma mult_acc_aux : forall n m p, m + n * p = mult_acc m p n.
+Proof.
+induction n as [| p IHp]; simpl in |- *; auto.
+intros s m; rewrite <- plus_tail_plus; rewrite <- IHp.
+rewrite <- plus_assoc_reverse; apply (f_equal2 (A1:=nat) (A2:=nat)); auto.
+rewrite plus_comm; auto.
+Qed.
+
+Definition tail_mult n m := mult_acc 0 m n.
+
+Lemma mult_tail_mult : forall n m, n * m = tail_mult n m.
+Proof.
+intros; unfold tail_mult in |- *; rewrite <- mult_acc_aux; auto.
+Qed.
+
+(** [TailSimpl] transforms any [tail_plus] and [tail_mult] into [plus] 
+    and [mult] and simplify *)
+
+Ltac tail_simpl :=
+  repeat rewrite <- plus_tail_plus; repeat rewrite <- mult_tail_mult;
+   simpl in |- *. 
\ No newline at end of file
diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v
new file mode 100755
index 00000000..01204ee6
--- /dev/null
+++ b/theories/Arith/Peano_dec.v
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Peano_dec.v,v 1.10.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Decidable.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n x y : nat.
+
+Theorem O_or_S : forall n, {m : nat | S m = n} + {0 = n}.
+Proof.
+induction n.
+auto.
+left; exists n; auto.
+Defined.
+
+Theorem eq_nat_dec : forall n m, {n = m} + {n <> m}.
+Proof.
+induction n; induction m; auto.
+elim (IHn m); auto.
+Defined.
+
+Hint Resolve O_or_S eq_nat_dec: arith.
+
+Theorem dec_eq_nat : forall n m, decidable (n = m).
+intros x y; unfold decidable in |- *; elim (eq_nat_dec x y); auto with arith.
+Defined.
diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v
new file mode 100755
index 00000000..e4ac631e
--- /dev/null
+++ b/theories/Arith/Plus.v
@@ -0,0 +1,202 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Plus.v,v 1.18.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+(** Properties of addition *)
+
+Require Import Le.
+Require Import Lt.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n p q : nat.
+
+(** Zero is neutral *)
+
+Lemma plus_0_l : forall n, 0 + n = n.
+Proof.
+reflexivity.
+Qed.
+
+Lemma plus_0_r : forall n, n + 0 = n.
+Proof.
+intro; symmetry  in |- *; apply plus_n_O.
+Qed.
+
+(** Commutativity *)
+
+Lemma plus_comm : forall n m, n + m = m + n.
+Proof.
+intros n m; elim n; simpl in |- *; auto with arith.
+intros y H; elim (plus_n_Sm m y); auto with arith.
+Qed.
+Hint Immediate plus_comm: arith v62.
+
+(** Associativity *)
+
+Lemma plus_Snm_nSm : forall n m, S n + m = n + S m.
+intros.
+simpl in |- *.
+rewrite (plus_comm n m).
+rewrite (plus_comm n (S m)).
+trivial with arith.
+Qed.
+
+Lemma plus_assoc : forall n m p, n + (m + p) = n + m + p.
+Proof.
+intros n m p; elim n; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve plus_assoc: arith v62.
+
+Lemma plus_permute : forall n m p, n + (m + p) = m + (n + p).
+Proof. 
+intros; rewrite (plus_assoc m n p); rewrite (plus_comm m n); auto with arith.
+Qed.
+
+Lemma plus_assoc_reverse : forall n m p, n + m + p = n + (m + p).
+Proof.
+auto with arith.
+Qed.
+Hint Resolve plus_assoc_reverse: arith v62.
+
+(** Simplification *)
+
+Lemma plus_reg_l : forall n m p, p + n = p + m -> n = m.
+Proof.
+intros m p n; induction n; simpl in |- *; auto with arith.
+Qed.
+
+Lemma plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m.
+Proof.
+induction p; simpl in |- *; auto with arith.
+Qed.
+
+Lemma plus_lt_reg_l : forall n m p, p + n < p + m -> n < m.
+Proof.
+induction p; simpl in |- *; auto with arith.
+Qed.
+
+(** Compatibility with order *)
+
+Lemma plus_le_compat_l : forall n m p, n <= m -> p + n <= p + m.
+Proof.
+induction p; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve plus_le_compat_l: arith v62.
+
+Lemma plus_le_compat_r : forall n m p, n <= m -> n + p <= m + p.
+Proof.
+induction 1; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve plus_le_compat_r: arith v62.
+
+Lemma le_plus_l : forall n m, n <= n + m.
+Proof.
+induction n; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve le_plus_l: arith v62.
+
+Lemma le_plus_r : forall n m, m <= n + m.
+Proof.
+intros n m; elim n; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve le_plus_r: arith v62.
+
+Theorem le_plus_trans : forall n m p, n <= m -> n <= m + p.
+Proof.
+intros; apply le_trans with (m := m); auto with arith.
+Qed.
+Hint Resolve le_plus_trans: arith v62.
+
+Theorem lt_plus_trans : forall n m p, n < m -> n < m + p.
+Proof.
+intros; apply lt_le_trans with (m := m); auto with arith.
+Qed.
+Hint Immediate lt_plus_trans: arith v62.
+
+Lemma plus_lt_compat_l : forall n m p, n < m -> p + n < p + m.
+Proof.
+induction p; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve plus_lt_compat_l: arith v62.
+
+Lemma plus_lt_compat_r : forall n m p, n < m -> n + p < m + p.
+Proof.
+intros n m p H; rewrite (plus_comm n p); rewrite (plus_comm m p).
+elim p; auto with arith.
+Qed.
+Hint Resolve plus_lt_compat_r: arith v62.
+
+Lemma plus_le_compat : forall n m p q, n <= m -> p <= q -> n + p <= m + q.
+Proof.
+intros n m p q H H0.
+elim H; simpl in |- *; auto with arith.
+Qed.
+
+Lemma plus_le_lt_compat : forall n m p q, n <= m -> p < q -> n + p < m + q.
+Proof.
+  unfold lt in |- *. intros. change (S n + p <= m + q) in |- *. rewrite plus_Snm_nSm.
+  apply plus_le_compat; assumption.
+Qed.
+
+Lemma plus_lt_le_compat : forall n m p q, n < m -> p <= q -> n + p < m + q.
+Proof.
+  unfold lt in |- *. intros. change (S n + p <= m + q) in |- *. apply plus_le_compat; assumption.
+Qed.
+
+Lemma plus_lt_compat : forall n m p q, n < m -> p < q -> n + p < m + q.
+Proof.
+  intros. apply plus_lt_le_compat. assumption.
+  apply lt_le_weak. assumption.
+Qed.
+
+(** Inversion lemmas *)
+
+Lemma plus_is_O : forall n m, n + m = 0 -> n = 0 /\ m = 0.
+Proof.
+  intro m; destruct m as [| n]; auto.
+  intros. discriminate H.
+Qed.
+
+Definition plus_is_one :
+  forall m n, m + n = 1 -> {m = 0 /\ n = 1} + {m = 1 /\ n = 0}.
+Proof.
+  intro m; destruct m as [| n]; auto.
+  destruct n; auto.
+  intros. 
+  simpl in H. discriminate H.
+Defined.
+
+(** Derived properties *)
+
+Lemma plus_permute_2_in_4 : forall n m p q, n + m + (p + q) = n + p + (m + q).
+Proof.
+  intros m n p q. 
+  rewrite <- (plus_assoc m n (p + q)). rewrite (plus_assoc n p q).
+  rewrite (plus_comm n p). rewrite <- (plus_assoc p n q). apply plus_assoc.
+Qed.
+
+(** Tail-recursive plus *)
+
+(** [tail_plus] is an alternative definition for [plus] which is 
+    tail-recursive, whereas [plus] is not. This can be useful
+    when extracting programs. *)
+
+Fixpoint plus_acc q n {struct n} : nat :=
+  match n with
+  | O => q
+  | S p => plus_acc (S q) p
+  end.
+
+Definition tail_plus n m := plus_acc m n.
+
+Lemma plus_tail_plus : forall n m, n + m = tail_plus n m.
+unfold tail_plus in |- *; induction n as [| n IHn]; simpl in |- *; auto.
+intro m; rewrite <- IHn; simpl in |- *; auto.
+Qed.
\ No newline at end of file
diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v
new file mode 100755
index 00000000..8bf237b5
--- /dev/null
+++ b/theories/Arith/Wf_nat.v
@@ -0,0 +1,206 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Wf_nat.v,v 1.16.2.1 2004/07/16 19:31:01 herbelin Exp $ i*)
+
+(** Well-founded relations and natural numbers *)
+
+Require Import Lt.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+Section Well_founded_Nat.
+
+Variable A : Set.
+
+Variable f : A -> nat.
+Definition ltof (a b:A) := f a < f b.
+Definition gtof (a b:A) := f b > f a.
+
+Theorem well_founded_ltof : well_founded ltof.
+Proof.
+red in |- *.
+cut (forall n (a:A), f a < n -> Acc ltof a).
+intros H a; apply (H (S (f a))); auto with arith.
+induction n.
+intros; absurd (f a < 0); auto with arith.
+intros a ltSma.
+apply Acc_intro.
+unfold ltof in |- *; intros b ltfafb.
+apply IHn.
+apply lt_le_trans with (f a); auto with arith.
+Qed.
+
+Theorem well_founded_gtof : well_founded gtof.
+Proof well_founded_ltof.
+
+(** It is possible to directly prove the induction principle going
+   back to primitive recursion on natural numbers ([induction_ltof1])
+   or to use the previous lemmas to extract a program with a fixpoint
+   ([induction_ltof2]) 
+
+the ML-like program for [induction_ltof1] is : [[
+   let induction_ltof1 F a = indrec ((f a)+1) a 
+   where rec indrec = 
+        function 0    -> (function a -> error)
+               |(S m) -> (function a -> (F a (function y -> indrec y m)));;
+]]
+
+the ML-like program for [induction_ltof2] is : [[
+   let induction_ltof2 F a = indrec a
+   where rec indrec a = F a indrec;;
+]] *)
+
+Theorem induction_ltof1 :
+ forall P:A -> Set,
+   (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a.
+Proof.
+intros P F; cut (forall n (a:A), f a < n -> P a).
+intros H a; apply (H (S (f a))); auto with arith.
+induction n.
+intros; absurd (f a < 0); auto with arith.
+intros a ltSma.
+apply F.
+unfold ltof in |- *; intros b ltfafb.
+apply IHn.
+apply lt_le_trans with (f a); auto with arith.
+Defined. 
+
+Theorem induction_gtof1 :
+ forall P:A -> Set,
+   (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a.
+Proof.
+exact induction_ltof1.
+Defined.
+
+Theorem induction_ltof2 :
+ forall P:A -> Set,
+   (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a.
+Proof.
+exact (well_founded_induction well_founded_ltof).
+Defined.
+
+Theorem induction_gtof2 :
+ forall P:A -> Set,
+   (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a.
+Proof.
+exact induction_ltof2.
+Defined.
+
+(** If a relation [R] is compatible with [lt] i.e. if [x R y => f(x) < f(y)]
+    then [R] is well-founded. *)
+
+Variable R : A -> A -> Prop.
+
+Hypothesis H_compat : forall x y:A, R x y -> f x < f y.
+
+Theorem well_founded_lt_compat : well_founded R.
+Proof.
+red in |- *.
+cut (forall n (a:A), f a < n -> Acc R a).
+intros H a; apply (H (S (f a))); auto with arith.
+induction n.
+intros; absurd (f a < 0); auto with arith.
+intros a ltSma.
+apply Acc_intro.
+intros b ltfafb.
+apply IHn.
+apply lt_le_trans with (f a); auto with arith.
+Qed.
+
+End Well_founded_Nat.
+
+Lemma lt_wf : well_founded lt.
+Proof well_founded_ltof nat (fun m => m).
+
+Lemma lt_wf_rec1 :
+ forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
+Proof.
+exact
+ (fun p (P:nat -> Set) (F:forall n, (forall m, m < n -> P m) -> P n) =>
+    induction_ltof1 nat (fun m => m) P F p).
+Defined.
+
+Lemma lt_wf_rec :
+ forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
+Proof.
+exact
+ (fun p (P:nat -> Set) (F:forall n, (forall m, m < n -> P m) -> P n) =>
+    induction_ltof2 nat (fun m => m) P F p).
+Defined.
+
+Lemma lt_wf_ind :
+ forall n (P:nat -> Prop), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
+intro p; intros; elim (lt_wf p); auto with arith.
+Qed.
+
+Lemma gt_wf_rec :
+ forall n (P:nat -> Set), (forall n, (forall m, n > m -> P m) -> P n) -> P n.
+Proof.
+exact lt_wf_rec.
+Defined.
+
+Lemma gt_wf_ind :
+ forall n (P:nat -> Prop), (forall n, (forall m, n > m -> P m) -> P n) -> P n.
+Proof lt_wf_ind.
+
+Lemma lt_wf_double_rec :
+ forall P:nat -> nat -> Set,
+   (forall n m,
+      (forall p (q:nat), p < n -> P p q) ->
+      (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m.
+intros P Hrec p; pattern p in |- *; apply lt_wf_rec.
+intros n H q; pattern q in |- *; apply lt_wf_rec; auto with arith.
+Defined.
+
+Lemma lt_wf_double_ind :
+ forall P:nat -> nat -> Prop,
+   (forall n m,
+      (forall p (q:nat), p < n -> P p q) ->
+      (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m.
+intros P Hrec p; pattern p in |- *; apply lt_wf_ind.
+intros n H q; pattern q in |- *; apply lt_wf_ind; auto with arith.
+Qed.
+
+Hint Resolve lt_wf: arith.
+Hint Resolve well_founded_lt_compat: arith.
+
+Section LT_WF_REL.
+Variable A : Set.
+Variable R : A -> A -> Prop.
+
+(* Relational form of inversion *)
+Variable F : A -> nat -> Prop.
+Definition inv_lt_rel x y :=
+   exists2 n : _, F x n & (forall m, F y m -> n < m).
+
+Hypothesis F_compat : forall x y:A, R x y -> inv_lt_rel x y.
+Remark acc_lt_rel : forall x:A, (exists n : _, F x n) -> Acc R x.
+intros x [n fxn]; generalize x fxn; clear x fxn.
+pattern n in |- *; apply lt_wf_ind; intros.
+constructor; intros.
+case (F_compat y x); trivial; intros.
+apply (H x0); auto.
+Qed.
+
+Theorem well_founded_inv_lt_rel_compat : well_founded R.
+constructor; intros.
+case (F_compat y a); trivial; intros.
+apply acc_lt_rel; trivial.
+exists x; trivial.
+Qed.
+
+
+End LT_WF_REL.
+
+Lemma well_founded_inv_rel_inv_lt_rel :
+ forall (A:Set) (F:A -> nat -> Prop), well_founded (inv_lt_rel A F).
+intros; apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial.
+Qed.
\ No newline at end of file
diff --git a/theories/Arith/intro.tex b/theories/Arith/intro.tex
new file mode 100755
index 00000000..655de34c
--- /dev/null
+++ b/theories/Arith/intro.tex
@@ -0,0 +1,55 @@
+\section{Arith}\label{Arith}
+
+The {\tt Arith} library deals with various arithmetical notions and 
+their properties.
+
+\subsection*{Standard {\tt Arith} library}
+
+The following files are automatically loaded by {\tt Require Arith}.
+
+\begin{itemize}
+
+\item {\tt Le.v} states and proves properties of the large order {\tt le}.
+
+\item {\tt Lt.v} states and proves properties of the strict order {\tt 
+lt} (especially, the relationship with {\tt le}).
+
+\item {\tt Plus.v} states and proves properties on the addition.
+
+\item {\tt Gt.v} states and proves properties on the strict order {\tt gt}.
+
+\item {\tt Minus.v} defines the difference on 
+{\tt nat} and proves properties of it. On {\tt nat}, {\tt (minus n p)} is 
+{\tt O} if {\tt n} $<$ {\tt p}.
+
+\item {\tt Mult.v} states and proves properties on the multiplication.
+
+\item {\tt Between.v} defines modalities on {\tt nat} and proves properties 
+of them.
+
+\end{itemize}
+
+\subsection*{Additional {\tt Arith} library}
+
+\begin{itemize}
+
+\item {\tt Compare.v}, {\tt Compare\_dec.v} and {\tt Peano\_dec.v} state
+and prove various decidability results on {\tt nat}.
+
+\item {\tt Wf\_nat.v} states and proves various induction and recursion 
+principles on {\tt nat}. Especially, recursion for objects measurable by 
+a natural number and recursion on {\tt nat * nat} are provided.
+
+\item {\tt Min.v} defines the minimum of two natural numbers and proves 
+properties of it. 
+
+\item {\tt Eqnat.v} defines a specific equality on {\tt nat} and shows 
+the equivalence with Leibniz' equality.
+
+\item {\tt Euclid.v} proves that the euclidean
+division specification is realisable. Conversely, {\tt Div.v} exhibits
+two different algorithms and semi-automatically reconstruct the proof of
+their correctness. These files emphasize the extraction of program vs
+reconstruction of proofs paradigm.
+
+\end{itemize}
diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v
new file mode 100755
index 00000000..854eb9e3
--- /dev/null
+++ b/theories/Bool/Bool.v
@@ -0,0 +1,543 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Bool.v,v 1.29.2.1 2004/07/16 19:31:01 herbelin Exp $ i*)
+
+(** Booleans  *)
+
+(** The type [bool] is defined in the prelude as
+    [Inductive bool : Set := true : bool | false : bool] *)
+
+(** Interpretation of booleans as Proposition *)
+Definition Is_true (b:bool) :=
+  match b with
+  | true => True
+  | false => False
+  end.
+Hint Unfold Is_true: bool.
+
+Lemma Is_true_eq_left : forall x:bool, x = true -> Is_true x.
+Proof.
+  intros; rewrite H; auto with bool.
+Qed.
+
+Lemma Is_true_eq_right : forall x:bool, true = x -> Is_true x.
+Proof.
+  intros; rewrite <- H; auto with bool.
+Qed.
+
+Hint Immediate Is_true_eq_right Is_true_eq_left: bool.
+
+(*******************)
+(** Discrimination *)
+(*******************)
+
+Lemma diff_true_false : true <> false.
+Proof.
+unfold not in |- *; intro contr; change (Is_true false) in |- *.
+elim contr; simpl in |- *; trivial with bool.
+Qed.
+Hint Resolve diff_true_false: bool v62.
+
+Lemma diff_false_true : false <> true.
+Proof.
+red in |- *; intros H; apply diff_true_false.
+symmetry  in |- *.
+assumption.
+Qed.
+Hint Resolve diff_false_true: bool v62.
+
+Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False.
+intros b H; rewrite H; auto with bool.
+Qed.
+Hint Resolve eq_true_false_abs: bool.
+
+Lemma not_true_is_false : forall b:bool, b <> true -> b = false.
+destruct b.
+intros.
+red in H; elim H.
+reflexivity.
+intros abs.
+reflexivity.
+Qed.
+
+Lemma not_false_is_true : forall b:bool, b <> false -> b = true.
+destruct b.
+intros.
+reflexivity.
+intro H; red in H; elim H.
+reflexivity.
+Qed.
+
+(**********************)
+(** Order on booleans *)
+(**********************)
+
+Definition leb (b1 b2:bool) :=
+  match b1 with
+  | true => b2 = true
+  | false => True
+  end.
+Hint Unfold leb: bool v62.
+
+(*************)
+(** Equality *)
+(*************)
+
+Definition eqb (b1 b2:bool) : bool :=
+  match b1, b2 with
+  | true, true => true
+  | true, false => false
+  | false, true => false
+  | false, false => true
+  end.
+
+Lemma eqb_refl : forall x:bool, Is_true (eqb x x).
+destruct x; simpl in |- *; auto with bool.
+Qed.
+
+Lemma eqb_eq : forall x y:bool, Is_true (eqb x y) -> x = y.
+destruct x; destruct y; simpl in |- *; tauto.
+Qed.
+
+Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true.
+destruct x; simpl in |- *; tauto.
+Qed.
+ 
+Lemma Is_true_eq_true2 : forall x:bool, x = true -> Is_true x.
+destruct x; simpl in |- *; auto with bool.
+Qed.
+
+Lemma eqb_subst :
+ forall (P:bool -> Prop) (b1 b2:bool), eqb b1 b2 = true -> P b1 -> P b2.
+unfold eqb in |- *.
+intros P b1.
+intros b2.
+case b1.
+case b2.
+trivial with bool.
+intros H.
+inversion_clear H.
+case b2.
+intros H.
+inversion_clear H.
+trivial with bool.
+Qed.
+
+Lemma eqb_reflx : forall b:bool, eqb b b = true.
+intro b.
+case b.
+trivial with bool.
+trivial with bool.
+Qed.
+
+Lemma eqb_prop : forall a b:bool, eqb a b = true -> a = b.
+destruct a; destruct b; simpl in |- *; intro; discriminate H || reflexivity.
+Qed.
+
+
+(************************)
+(** Logical combinators *)
+(************************)
+ 
+Definition ifb (b1 b2 b3:bool) : bool :=
+  match b1 with
+  | true => b2
+  | false => b3
+  end.
+
+Definition andb (b1 b2:bool) : bool := ifb b1 b2 false.
+
+Definition orb (b1 b2:bool) : bool := ifb b1 true b2.
+
+Definition implb (b1 b2:bool) : bool := ifb b1 b2 true.
+
+Definition xorb (b1 b2:bool) : bool :=
+  match b1, b2 with
+  | true, true => false
+  | true, false => true
+  | false, true => true
+  | false, false => false
+  end.
+
+Definition negb (b:bool) := match b with
+                            | true => false
+                            | false => true
+                            end.
+
+Infix "||" := orb (at level 50, left associativity) : bool_scope.
+Infix "&&" := andb (at level 40, left associativity) : bool_scope.
+
+Open Scope bool_scope.
+
+Delimit Scope bool_scope with bool.
+
+Bind Scope bool_scope with bool.
+
+(**************************)
+(** Lemmas about [negb]   *)
+(**************************)
+
+Lemma negb_intro : forall b:bool, b = negb (negb b).
+Proof.
+destruct b; reflexivity.
+Qed.
+
+Lemma negb_elim : forall b:bool, negb (negb b) = b.
+Proof.
+destruct b; reflexivity.
+Qed.
+       
+Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2.
+Proof.
+  destruct b1; destruct b2; simpl in |- *; reflexivity.
+Qed.
+
+Lemma negb_andb : forall b1 b2:bool, negb (b1 && b2) = negb b1 || negb b2.
+Proof.
+  destruct b1; destruct b2; simpl in |- *; reflexivity.
+Qed.
+
+Lemma negb_sym : forall b b':bool, b' = negb b -> b = negb b'.
+Proof.
+destruct b; destruct b'; intros; simpl in |- *; trivial with bool.
+Qed.
+
+Lemma no_fixpoint_negb : forall b:bool, negb b <> b.
+Proof.
+destruct b; simpl in |- *; intro; apply diff_true_false;
+ auto with bool.
+Qed.
+
+Lemma eqb_negb1 : forall b:bool, eqb (negb b) b = false.
+destruct b.
+trivial with bool.
+trivial with bool.
+Qed.
+ 
+Lemma eqb_negb2 : forall b:bool, eqb b (negb b) = false.
+destruct b.
+trivial with bool.
+trivial with bool.
+Qed.
+
+
+Lemma if_negb :
+ forall (A:Set) (b:bool) (x y:A),
+   (if negb b then x else y) = (if b then y else x).
+Proof.
+  destruct b; trivial.
+Qed.
+
+
+(****************************)
+(** A few lemmas about [or] *)
+(****************************)
+
+Lemma orb_prop : forall a b:bool, a || b = true -> a = true \/ b = true.
+destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
+ auto with bool.
+Qed.
+
+Lemma orb_prop2 : forall a b:bool, Is_true (a || b) -> Is_true a \/ Is_true b.
+destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
+ auto with bool.
+Qed.
+
+Lemma orb_true_intro :
+ forall b1 b2:bool, b1 = true \/ b2 = true -> b1 || b2 = true.
+destruct b1; auto with bool.
+destruct 1; intros.
+elim diff_true_false; auto with bool.
+rewrite H; trivial with bool.
+Qed.
+Hint Resolve orb_true_intro: bool v62.
+
+Lemma orb_b_true : forall b:bool, b || true = true.
+auto with bool.
+Qed.
+Hint Resolve orb_b_true: bool v62.
+
+Lemma orb_true_b : forall b:bool, true || b = true.
+trivial with bool.
+Qed.
+
+Definition orb_true_elim :
+  forall b1 b2:bool, b1 || b2 = true -> {b1 = true} + {b2 = true}.
+destruct b1; simpl in |- *; auto with bool.
+Defined.
+
+Lemma orb_false_intro :
+ forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false.
+intros b1 b2 H1 H2; rewrite H1; rewrite H2; trivial with bool.
+Qed.
+Hint Resolve orb_false_intro: bool v62.
+
+Lemma orb_b_false : forall b:bool, b || false = b.
+Proof.
+  destruct b; trivial with bool.
+Qed.
+Hint Resolve orb_b_false: bool v62.
+
+Lemma orb_false_b : forall b:bool, false || b = b.
+Proof.
+  destruct b; trivial with bool.
+Qed.
+Hint Resolve orb_false_b: bool v62.
+
+Lemma orb_false_elim :
+ forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false.
+Proof.
+  destruct b1.
+  intros; elim diff_true_false; auto with bool.
+  destruct b2.
+  intros; elim diff_true_false; auto with bool.
+  auto with bool.
+Qed.
+
+Lemma orb_neg_b : forall b:bool, b || negb b = true.
+Proof.
+  destruct b; reflexivity.
+Qed.
+Hint Resolve orb_neg_b: bool v62.
+
+Lemma orb_comm : forall b1 b2:bool, b1 || b2 = b2 || b1.
+destruct b1; destruct b2; reflexivity.
+Qed.
+
+Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3.
+Proof.
+  destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Hint Resolve orb_comm orb_assoc orb_b_false orb_false_b: bool v62.
+
+(*****************************)
+(** A few lemmas about [and] *)
+(*****************************)
+
+Lemma andb_prop : forall a b:bool, a && b = true -> a = true /\ b = true.
+
+Proof.
+  destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
+   auto with bool.
+Qed.
+Hint Resolve andb_prop: bool v62.
+
+Definition andb_true_eq :
+  forall a b:bool, true = a && b -> true = a /\ true = b.
+Proof.
+  destruct a; destruct b; auto.
+Defined.
+
+Lemma andb_prop2 :
+ forall a b:bool, Is_true (a && b) -> Is_true a /\ Is_true b.
+Proof.
+  destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
+   auto with bool.
+Qed.
+Hint Resolve andb_prop2: bool v62.
+
+Lemma andb_true_intro :
+ forall b1 b2:bool, b1 = true /\ b2 = true -> b1 && b2 = true.
+Proof.
+  destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
+Qed.
+Hint Resolve andb_true_intro: bool v62.
+
+Lemma andb_true_intro2 :
+ forall b1 b2:bool, Is_true b1 -> Is_true b2 -> Is_true (b1 && b2).
+Proof.
+  destruct b1; destruct b2; simpl in |- *; tauto.
+Qed.
+Hint Resolve andb_true_intro2: bool v62.
+
+Lemma andb_false_intro1 : forall b1 b2:bool, b1 = false -> b1 && b2 = false.
+destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
+Qed.
+
+Lemma andb_false_intro2 : forall b1 b2:bool, b2 = false -> b1 && b2 = false.
+destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
+Qed.
+
+Lemma andb_b_false : forall b:bool, b && false = false.
+destruct b; auto with bool.
+Qed.
+
+Lemma andb_false_b : forall b:bool, false && b = false.
+trivial with bool.
+Qed.
+
+Lemma andb_b_true : forall b:bool, b && true = b.
+destruct b; auto with bool.
+Qed.
+
+Lemma andb_true_b : forall b:bool, true && b = b.
+trivial with bool.
+Qed.
+
+Definition andb_false_elim :
+  forall b1 b2:bool, b1 && b2 = false -> {b1 = false} + {b2 = false}.
+destruct b1; simpl in |- *; auto with bool.
+Defined.
+Hint Resolve andb_false_elim: bool v62.
+
+Lemma andb_neg_b : forall b:bool, b && negb b = false.
+destruct b; reflexivity.
+Qed.   
+Hint Resolve andb_neg_b: bool v62.
+
+Lemma andb_comm : forall b1 b2:bool, b1 && b2 = b2 && b1.
+destruct b1; destruct b2; reflexivity.
+Qed.
+
+Lemma andb_assoc : forall b1 b2 b3:bool, b1 && (b2 && b3) = b1 && b2 && b3.
+destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Hint Resolve andb_comm andb_assoc: bool v62.
+
+(*******************************)
+(** Properties of [xorb]       *)
+(*******************************)
+
+Lemma xorb_false : forall b:bool, xorb b false = b.
+Proof.
+  destruct b; trivial.
+Qed.
+
+Lemma false_xorb : forall b:bool, xorb false b = b.
+Proof.
+  destruct b; trivial.
+Qed.
+
+Lemma xorb_true : forall b:bool, xorb b true = negb b.
+Proof.
+  trivial.
+Qed.
+
+Lemma true_xorb : forall b:bool, xorb true b = negb b.
+Proof.
+  destruct b; trivial.
+Qed.
+
+Lemma xorb_nilpotent : forall b:bool, xorb b b = false.
+Proof.
+  destruct b; trivial.
+Qed.
+
+Lemma xorb_comm : forall b b':bool, xorb b b' = xorb b' b.
+Proof.
+  destruct b; destruct b'; trivial.
+Qed.
+
+Lemma xorb_assoc :
+ forall b b' b'':bool, xorb (xorb b b') b'' = xorb b (xorb b' b'').
+Proof.
+  destruct b; destruct b'; destruct b''; trivial.
+Qed.
+
+Lemma xorb_eq : forall b b':bool, xorb b b' = false -> b = b'.
+Proof.
+  destruct b; destruct b'; trivial.
+  unfold xorb in |- *. intros. rewrite H. reflexivity.
+Qed.
+
+Lemma xorb_move_l_r_1 :
+ forall b b' b'':bool, xorb b b' = b'' -> b' = xorb b b''.
+Proof.
+  intros. rewrite <- (false_xorb b'). rewrite <- (xorb_nilpotent b). rewrite xorb_assoc.
+  rewrite H. reflexivity.
+Qed.
+
+Lemma xorb_move_l_r_2 :
+ forall b b' b'':bool, xorb b b' = b'' -> b = xorb b'' b'.
+Proof.
+  intros. rewrite xorb_comm in H. rewrite (xorb_move_l_r_1 b' b b'' H). apply xorb_comm.
+Qed.
+
+Lemma xorb_move_r_l_1 :
+ forall b b' b'':bool, b = xorb b' b'' -> xorb b' b = b''.
+Proof.
+  intros. rewrite H. rewrite <- xorb_assoc. rewrite xorb_nilpotent. apply false_xorb.
+Qed.
+
+Lemma xorb_move_r_l_2 :
+ forall b b' b'':bool, b = xorb b' b'' -> xorb b b'' = b'.
+Proof.
+  intros. rewrite H. rewrite xorb_assoc. rewrite xorb_nilpotent. apply xorb_false.
+Qed.
+
+(*******************************)
+(** De Morgan's law            *)
+(*******************************)
+
+Lemma demorgan1 :
+ forall b1 b2 b3:bool, b1 && (b2 || b3) = b1 && b2 || b1 && b3.
+destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Lemma demorgan2 :
+ forall b1 b2 b3:bool, (b1 || b2) && b3 = b1 && b3 || b2 && b3.
+destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Lemma demorgan3 :
+ forall b1 b2 b3:bool, b1 || b2 && b3 = (b1 || b2) && (b1 || b3).
+destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Lemma demorgan4 :
+ forall b1 b2 b3:bool, b1 && b2 || b3 = (b1 || b3) && (b2 || b3).
+destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Lemma absoption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1.
+Proof.
+  destruct b1; destruct b2; simpl in |- *; reflexivity.
+Qed.
+
+Lemma absoption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1.
+Proof.
+  destruct b1; destruct b2; simpl in |- *; reflexivity.
+Qed.
+
+
+(** Misc. equalities between booleans (to be used by Auto) *)
+
+Lemma bool_1 : forall b1 b2:bool, (b1 = true <-> b2 = true) -> b1 = b2. 
+Proof. 
+ intros b1 b2; case b1; case b2; intuition.
+Qed.
+
+Lemma bool_2 : forall b1 b2:bool, b1 = b2 -> b1 = true -> b2 = true.
+Proof. 
+ intros b1 b2; case b1; case b2; intuition.
+Qed. 
+
+Lemma bool_3 : forall b:bool, negb b <> true -> b = true.
+Proof.
+  destruct b; intuition.
+Qed.
+
+Lemma bool_4 : forall b:bool, b = true -> negb b <> true.  
+Proof.
+  destruct b; intuition.
+Qed.
+
+Lemma bool_5 : forall b:bool, negb b = true -> b <> true.
+Proof.
+  destruct b; intuition.
+Qed.
+
+Lemma bool_6 : forall b:bool, b <> true -> negb b = true.  
+Proof.
+  destruct b; intuition.
+Qed.
+
+Hint Resolve bool_1 bool_2 bool_3 bool_4 bool_5 bool_6.
diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v
new file mode 100644
index 00000000..e038b3da
--- /dev/null
+++ b/theories/Bool/BoolEq.v
@@ -0,0 +1,73 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: BoolEq.v,v 1.4.2.1 2004/07/16 19:31:02 herbelin Exp $ i*)
+(* Cuihtlauac Alvarado - octobre 2000 *)
+
+(** Properties of a boolean equality   *)
+
+
+Require Export Bool.
+
+Section Bool_eq_dec.
+
+  Variable A : Set.
+
+  Variable beq : A -> A -> bool.
+
+  Variable beq_refl : forall x:A, true = beq x x.
+
+  Variable beq_eq : forall x y:A, true = beq x y -> x = y.
+
+  Definition beq_eq_true : forall x y:A, x = y -> true = beq x y.
+  Proof.
+    intros x y H.
+    case H.
+    apply beq_refl.
+  Defined.
+
+  Definition beq_eq_not_false : forall x y:A, x = y -> false <> beq x y.
+  Proof.
+    intros x y e.
+    rewrite <- beq_eq_true; trivial; discriminate.
+  Defined.
+
+  Definition beq_false_not_eq : forall x y:A, false = beq x y -> x <> y.
+  Proof.
+    exact
+     (fun (x y:A) (H:false = beq x y) (e:x = y) => beq_eq_not_false x y e H).
+  Defined.
+
+  Definition exists_beq_eq : forall x y:A, {b : bool | b = beq x y}.
+  Proof.
+    intros.
+    exists (beq x y).
+    constructor.
+  Defined.
+
+  Definition not_eq_false_beq : forall x y:A, x <> y -> false = beq x y.
+  Proof.
+    intros x y H.
+    symmetry  in |- *.
+    apply not_true_is_false.
+    intro.
+    apply H.
+    apply beq_eq.
+    symmetry  in |- *.
+    assumption.
+  Defined.
+
+  Definition eq_dec : forall x y:A, {x = y} + {x <> y}.
+  Proof.
+    intros x y; case (exists_beq_eq x y).
+    intros b; case b; intro H.
+      left; apply beq_eq; assumption.
+      right; apply beq_false_not_eq; assumption.
+  Defined.
+
+End Bool_eq_dec.
diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v
new file mode 100644
index 00000000..51d940cf
--- /dev/null
+++ b/theories/Bool/Bvector.v
@@ -0,0 +1,272 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Bvector.v,v 1.6.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+(** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *)
+
+Require Export Bool.
+Require Export Sumbool.
+Require Import Arith.
+
+Open Local Scope nat_scope.
+
+(*  
+On s'inspire de PolyList pour fabriquer les vecteurs de bits.
+La dimension du vecteur est un paramètre trop important pour
+se contenter de la fonction "length".
+La première idée est de faire un record avec la liste et la longueur.
+Malheureusement, cette verification a posteriori amene a faire
+de nombreux lemmes pour gerer les longueurs.
+La seconde idée est de faire un type dépendant dans lequel la
+longueur est un paramètre de construction. Cela complique un
+peu les inductions structurelles, la solution qui a ma préférence
+est alors d'utiliser un terme de preuve comme définition.
+
+(En effet une définition comme :
+Fixpoint Vunaire [n:nat; v:(vector n)]: (vector n) :=
+Cases v of
+	| Vnil => Vnil
+	| (Vcons a p v') => (Vcons (f a) p (Vunaire p v'))
+end.
+provoque ce message d'erreur :
+Coq < Error: Inference of annotation not yet implemented in this case).
+
+
+	Inductive list [A : Set]  : Set :=
+		nil : (list A) | cons : A->(list A)->(list A).
+	head = [A:Set; l:(list A)] Cases l of
+			| nil => Error
+ 			| (cons x _) => (Value x)
+ 			end
+     		: (A:Set)(list A)->(option A).
+	tail = [A:Set; l:(list A)]Cases l of
+                   			| nil => (nil A)
+                   			| (cons _ m) => m
+                   			end
+     		: (A:Set)(list A)->(list A).
+	length = [A:Set] Fix length {length [l:(list A)] : nat :=
+      		Cases l of
+       			| nil => O
+      			| (cons _ m) => (S (length m))
+      		end}
+     		: (A:Set)(list A)->nat.
+	map = [A,B:Set; f:(A->B)] Fix map {map [l:(list A)] : (list B) :=
+		Cases l of
+			| nil => (nil B)
+			| (cons a t) => (cons (f a) (map t))
+		end}
+		: (A,B:Set)(A->B)->(list A)->(list B)
+*)
+
+Section VECTORS.
+
+(* 
+Un vecteur est une liste de taille n d'éléments d'un ensemble A.
+Si la taille est non nulle, on peut extraire la première composante et 
+le reste du vecteur, la dernière composante ou rajouter ou enlever 
+une composante (carry) ou repeter la dernière composante en fin de vecteur.
+On peut aussi tronquer le vecteur de ses p dernières composantes ou
+au contraire l'étendre (concaténer) d'un vecteur de longueur p.
+Une fonction unaire sur A génère une fonction des vecteurs de taille n
+dans les vecteurs de taille n en appliquant f terme à terme.
+Une fonction binaire sur A génère une fonction des couple de vecteurs 
+de taille n dans les vecteurs de taille n en appliquant f terme à terme.
+*)
+
+Variable A : Set.
+
+Inductive vector : nat -> Set :=
+  | Vnil : vector 0
+  | Vcons : forall (a:A) (n:nat), vector n -> vector (S n).
+
+Definition Vhead : forall n:nat, vector (S n) -> A.
+Proof.
+	intros n v; inversion v; exact a.
+Defined.
+
+Definition Vtail : forall n:nat, vector (S n) -> vector n.
+Proof.
+	intros n v; inversion v; exact H0.
+Defined.
+
+Definition Vlast : forall n:nat, vector (S n) -> A.
+Proof.
+	induction n as [| n f]; intro v.
+	inversion v.
+	exact a.
+
+	inversion v.
+	exact (f H0).
+Defined.
+
+Definition Vconst : forall (a:A) (n:nat), vector n.
+Proof.
+	induction n as [| n v].
+	exact Vnil.
+
+	exact (Vcons a n v).
+Defined.
+
+Lemma Vshiftout : forall n:nat, vector (S n) -> vector n.
+Proof.
+	induction n as [| n f]; intro v.
+	exact Vnil.
+
+	inversion v.
+	exact (Vcons a n (f H0)).
+Defined.
+
+Lemma Vshiftin : forall n:nat, A -> vector n -> vector (S n).
+Proof.
+	induction n as [| n f]; intros a v.
+	exact (Vcons a 0 v).
+
+	inversion v.
+	exact (Vcons a (S n) (f a H0)).
+Defined.
+
+Lemma Vshiftrepeat : forall n:nat, vector (S n) -> vector (S (S n)).
+Proof.
+	induction n as [| n f]; intro v.
+	inversion v.
+	exact (Vcons a 1 v).
+
+	inversion v.
+	exact (Vcons a (S (S n)) (f H0)).
+Defined.
+
+(*
+Lemma S_minus_S : (n,p:nat) (gt n (S p)) -> (S (minus n (S p)))=(minus n p).
+Proof.
+  Intros.
+Save.
+*)
+
+Lemma Vtrunc : forall n p:nat, n > p -> vector n -> vector (n - p).
+Proof.
+	induction p as [| p f]; intros H v.
+	rewrite <- minus_n_O.
+	exact v.
+
+	apply (Vshiftout (n - S p)).
+
+rewrite minus_Sn_m.
+apply f.
+auto with *.
+exact v.
+auto with *.
+Defined.
+
+Lemma Vextend : forall n p:nat, vector n -> vector p -> vector (n + p).
+Proof.
+	induction n as [| n f]; intros p v v0.
+	simpl in |- *; exact v0.
+
+	inversion v.
+	simpl in |- *; exact (Vcons a (n + p) (f p H0 v0)).
+Defined.
+
+Variable f : A -> A.
+
+Lemma Vunary : forall n:nat, vector n -> vector n.
+Proof.
+	induction n as [| n g]; intro v.
+	exact Vnil.
+
+	inversion v.
+	exact (Vcons (f a) n (g H0)).
+Defined.
+
+Variable g : A -> A -> A.
+
+Lemma Vbinary : forall n:nat, vector n -> vector n -> vector n.
+Proof.
+	induction n as [| n h]; intros v v0.
+	exact Vnil.
+
+	inversion v; inversion v0.
+	exact (Vcons (g a a0) n (h H0 H2)).
+Defined.
+
+End VECTORS.
+
+(* suppressed: incompatible with Coq-Art book 
+Implicit Arguments Vnil [A].
+Implicit Arguments Vcons [A n].
+*)
+
+Section BOOLEAN_VECTORS.
+
+(* 
+Un vecteur de bits est un vecteur sur l'ensemble des booléens de longueur fixe. 
+ATTENTION : le stockage s'effectue poids FAIBLE en tête.
+On en extrait le bit  de poids faible (head) et la fin du vecteur (tail).
+On calcule la négation d'un vecteur, le et, le ou et le xor bit à bit de 2 vecteurs.
+On calcule les décalages d'une position vers la gauche (vers les poids forts, on
+utilise donc Vshiftout, vers la droite (vers les poids faibles, on utilise Vshiftin) en 
+insérant un bit 'carry' (logique) ou en répétant le bit de poids fort (arithmétique).
+ATTENTION : Tous les décalages prennent la taille moins un comme paramètre
+(ils ne travaillent que sur des vecteurs au moins de longueur un).
+*)
+
+Definition Bvector := vector bool.
+
+Definition Bnil := @Vnil bool.
+
+Definition Bcons := @Vcons bool.
+
+Definition Bvect_true := Vconst bool true.
+
+Definition Bvect_false := Vconst bool false.
+
+Definition Blow := Vhead bool.
+
+Definition Bhigh := Vtail bool.
+
+Definition Bsign := Vlast bool.
+
+Definition Bneg := Vunary bool negb.
+
+Definition BVand := Vbinary bool andb.
+
+Definition BVor := Vbinary bool orb.
+
+Definition BVxor := Vbinary bool xorb.
+
+Definition BshiftL (n:nat) (bv:Bvector (S n)) (carry:bool) :=
+  Bcons carry n (Vshiftout bool n bv).
+
+Definition BshiftRl (n:nat) (bv:Bvector (S n)) (carry:bool) :=
+  Bhigh (S n) (Vshiftin bool (S n) carry bv).
+
+Definition BshiftRa (n:nat) (bv:Bvector (S n)) :=
+  Bhigh (S n) (Vshiftrepeat bool n bv).
+
+Fixpoint BshiftL_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} :
+ Bvector (S n) :=
+  match p with
+  | O => bv
+  | S p' => BshiftL n (BshiftL_iter n bv p') false
+  end.
+
+Fixpoint BshiftRl_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} :
+ Bvector (S n) :=
+  match p with
+  | O => bv
+  | S p' => BshiftRl n (BshiftRl_iter n bv p') false
+  end.
+
+Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} :
+ Bvector (S n) :=
+  match p with
+  | O => bv
+  | S p' => BshiftRa n (BshiftRa_iter n bv p')
+  end.
+
+End BOOLEAN_VECTORS.
diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v
new file mode 100755
index 00000000..1998fb8e
--- /dev/null
+++ b/theories/Bool/DecBool.v
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: DecBool.v,v 1.6.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Set Implicit Arguments.
+
+Definition ifdec (A B:Prop) (C:Set) (H:{A} + {B}) (x y:C) : C :=
+  if H then x else y.
+
+
+Theorem ifdec_left :
+ forall (A B:Prop) (C:Set) (H:{A} + {B}),
+   ~ B -> forall x y:C, ifdec H x y = x.
+intros; case H; auto.
+intro; absurd B; trivial.
+Qed.
+
+Theorem ifdec_right :
+ forall (A B:Prop) (C:Set) (H:{A} + {B}),
+   ~ A -> forall x y:C, ifdec H x y = y.
+intros; case H; auto.
+intro; absurd A; trivial.
+Qed.
+
+Unset Implicit Arguments.
\ No newline at end of file
diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v
new file mode 100755
index 00000000..a00449d8
--- /dev/null
+++ b/theories/Bool/IfProp.v
@@ -0,0 +1,50 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: IfProp.v,v 1.7.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Require Import Bool.
+
+Inductive IfProp (A B:Prop) : bool -> Prop :=
+  | Iftrue : A -> IfProp A B true
+  | Iffalse : B -> IfProp A B false.
+
+Hint Resolve Iftrue Iffalse: bool v62.
+
+Lemma Iftrue_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = true -> A.
+destruct 1; intros; auto with bool.
+case diff_true_false; auto with bool.
+Qed.
+
+Lemma Iffalse_inv :
+ forall (A B:Prop) (b:bool), IfProp A B b -> b = false -> B.
+destruct 1; intros; auto with bool.
+case diff_true_false; trivial with bool.
+Qed.
+
+Lemma IfProp_true : forall A B:Prop, IfProp A B true -> A.
+intros.
+inversion H.
+assumption.
+Qed.
+
+Lemma IfProp_false : forall A B:Prop, IfProp A B false -> B.
+intros.
+inversion H.
+assumption.
+Qed.
+
+Lemma IfProp_or : forall (A B:Prop) (b:bool), IfProp A B b -> A \/ B.
+destruct 1; auto with bool.
+Qed.
+
+Lemma IfProp_sum : forall (A B:Prop) (b:bool), IfProp A B b -> {A} + {B}.
+destruct b; intro H.
+left; inversion H; auto with bool.
+right; inversion H; auto with bool.
+Qed.
\ No newline at end of file
diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v
new file mode 100644
index 00000000..8188f038
--- /dev/null
+++ b/theories/Bool/Sumbool.v
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Sumbool.v,v 1.12.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+(** Here are collected some results about the type sumbool (see INIT/Specif.v)
+   [sumbool A B], which is written [{A}+{B}], is the informative
+   disjunction "A or B", where A and B are logical propositions.
+   Its extraction is isomorphic to the type of booleans. *)
+
+(** A boolean is either [true] or [false], and this is decidable *)
+
+Definition sumbool_of_bool : forall b:bool, {b = true} + {b = false}.
+Proof.
+  destruct b; auto.
+Defined.
+
+Hint Resolve sumbool_of_bool: bool.
+
+Definition bool_eq_rec :
+  forall (b:bool) (P:bool -> Set),
+    (b = true -> P true) -> (b = false -> P false) -> P b.
+destruct b; auto.
+Defined.
+
+Definition bool_eq_ind :
+  forall (b:bool) (P:bool -> Prop),
+    (b = true -> P true) -> (b = false -> P false) -> P b.
+destruct b; auto.
+Defined.
+
+
+(*i pourquoi ce machin-la est dans BOOL et pas dans LOGIC ?  Papageno i*)
+
+(** Logic connectives on type [sumbool] *)
+
+Section connectives.
+
+Variables A B C D : Prop.
+
+Hypothesis H1 : {A} + {B}.
+Hypothesis H2 : {C} + {D}.
+
+Definition sumbool_and : {A /\ C} + {B \/ D}.
+Proof.
+case H1; case H2; auto.
+Defined.
+
+Definition sumbool_or : {A \/ C} + {B /\ D}.
+Proof.
+case H1; case H2; auto.
+Defined.
+
+Definition sumbool_not : {B} + {A}.
+Proof.
+case H1; auto.
+Defined.
+
+End connectives.
+
+Hint Resolve sumbool_and sumbool_or sumbool_not: core.
+
+
+(** Any decidability function in type [sumbool] can be turned into a function
+    returning a boolean with the corresponding specification: *)
+
+Definition bool_of_sumbool :
+  forall A B:Prop, {A} + {B} -> {b : bool | if b then A else B}.
+Proof.
+intros A B H.
+elim H; [ intro; exists true; assumption | intro; exists false; assumption ].
+Defined.
+Implicit Arguments bool_of_sumbool.
\ No newline at end of file
diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v
new file mode 100755
index 00000000..b654e556
--- /dev/null
+++ b/theories/Bool/Zerob.v
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Zerob.v,v 1.8.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Require Import Arith.
+Require Import Bool.
+
+Open Local Scope nat_scope.
+
+Definition zerob (n:nat) : bool :=
+  match n with
+  | O => true
+  | S _ => false
+  end.
+
+Lemma zerob_true_intro : forall n:nat, n = 0 -> zerob n = true.
+destruct n; [ trivial with bool | inversion 1 ].
+Qed.
+Hint Resolve zerob_true_intro: bool.
+
+Lemma zerob_true_elim : forall n:nat, zerob n = true -> n = 0.
+destruct n; [ trivial with bool | inversion 1 ].
+Qed.
+
+Lemma zerob_false_intro : forall n:nat, n <> 0 -> zerob n = false.
+destruct n; [ destruct 1; auto with bool | trivial with bool ].
+Qed.
+Hint Resolve zerob_false_intro: bool.
+
+Lemma zerob_false_elim : forall n:nat, zerob n = false -> n <> 0.
+destruct n; [ intro H; inversion H | auto with bool ].
+Qed.
\ No newline at end of file
diff --git a/theories/Bool/intro.tex b/theories/Bool/intro.tex
new file mode 100644
index 00000000..22ee38aa
--- /dev/null
+++ b/theories/Bool/intro.tex
@@ -0,0 +1,16 @@
+\section{Bool}\label{Bool}
+
+The BOOL library includes the following files:
+
+\begin{itemize}
+
+\item {\tt Bool.v} defines standard operations on booleans and states
+  and proves simple facts on them.
+\item {\tt IfProp.v} defines a disjunction which contains its proof
+  and states its properties.
+\item {\tt Zerob.v} defines the test against 0 on natural numbers and
+  states and proves properties of it.
+\item {\tt Orb.v} states and proves facts on the boolean or.
+\item {\tt DecBool.v} defines a conditional from a proof of
+  decidability and states its properties.
+\end{itemize}
diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v
new file mode 100755
index 00000000..6aeabe13
--- /dev/null
+++ b/theories/Init/Datatypes.v
@@ -0,0 +1,121 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Datatypes.v,v 1.26.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Require Import Notations.
+Require Import Logic.
+
+Set Implicit Arguments.
+
+(** [unit] is a singleton datatype with sole inhabitant [tt] *)
+
+Inductive unit : Set :=
+    tt : unit.
+
+(** [bool] is the datatype of the booleans values [true] and [false] *)
+
+Inductive bool : Set :=
+  | true : bool
+  | false : bool.
+
+Add Printing If bool.
+
+(** [nat] is the datatype of natural numbers built from [O] and successor [S];
+    note that zero is the letter O, not the numeral 0 *)
+
+Inductive nat : Set :=
+  | O : nat
+  | S : nat -> nat.
+
+Delimit Scope nat_scope with nat.
+Bind Scope nat_scope with nat.
+Arguments Scope S [nat_scope].
+
+(** [Empty_set] has no inhabitant *)
+
+Inductive Empty_set : Set :=.
+
+(** [identity A a] is the family of datatypes on [A] whose sole non-empty
+    member is the singleton datatype [identity A a a] whose
+    sole inhabitant is denoted [refl_identity A a] *)
+
+Inductive identity (A:Type) (a:A) : A -> Set :=
+    refl_identity : identity (A:=A) a a.
+Hint Resolve refl_identity: core v62.
+
+Implicit Arguments identity_ind [A].
+Implicit Arguments identity_rec [A].
+Implicit Arguments identity_rect [A].
+
+(** [option A] is the extension of A with a dummy element None *)
+
+Inductive option (A:Set) : Set :=
+  | Some : A -> option A
+  | None : option A.
+
+Implicit Arguments None [A].
+
+(** [sum A B], equivalently [A + B], is the disjoint sum of [A] and [B] *)
+(* Syntax defined in Specif.v *)
+Inductive sum (A B:Set) : Set :=
+  | inl : A -> sum A B
+  | inr : B -> sum A B.
+
+Notation "x + y" := (sum x y) : type_scope.
+
+(** [prod A B], written [A * B], is the product of [A] and [B];
+    the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *)
+
+Inductive prod (A B:Set) : Set :=
+    pair : A -> B -> prod A B.
+Add Printing Let prod.
+
+Notation "x * y" := (prod x y) : type_scope.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+
+Section projections.
+   Variables A B : Set.
+   Definition fst (p:A * B) := match p with
+                               | (x, y) => x
+                               end.
+   Definition snd (p:A * B) := match p with
+                               | (x, y) => y
+                               end.
+End projections. 
+
+Hint Resolve pair inl inr: core v62.
+
+Lemma surjective_pairing :
+ forall (A B:Set) (p:A * B), p = pair (fst p) (snd p).
+Proof.
+destruct p; reflexivity.
+Qed.
+
+Lemma injective_projections :
+ forall (A B:Set) (p1 p2:A * B),
+   fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2.
+Proof.
+destruct p1; destruct p2; simpl in |- *; intros Hfst Hsnd.
+rewrite Hfst; rewrite Hsnd; reflexivity. 
+Qed.
+
+
+(** Comparison *)
+
+Inductive comparison : Set :=
+  | Eq : comparison
+  | Lt : comparison
+  | Gt : comparison.
+
+Definition CompOpp (r:comparison) :=
+  match r with
+  | Eq => Eq
+  | Lt => Gt
+  | Gt => Lt
+  end.
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
new file mode 100755
index 00000000..bae8d4a1
--- /dev/null
+++ b/theories/Init/Logic.v
@@ -0,0 +1,279 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Logic.v,v 1.29.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Set Implicit Arguments.
+
+Require Import Notations.
+
+(** * Propositional connectives *)
+
+(** [True] is the always true proposition *)
+Inductive True : Prop :=
+    I : True. 
+
+(** [False] is the always false proposition *)
+Inductive False : Prop :=. 
+
+(** [not A], written [~A], is the negation of [A] *)
+Definition not (A:Prop) := A -> False.
+
+Notation "~ x" := (not x) : type_scope.
+
+Hint Unfold not: core.
+
+Inductive and (A B:Prop) : Prop :=
+    conj : A -> B -> A /\ B 
+ where "A /\ B" := (and A B) : type_scope.
+
+
+Section Conjunction.
+
+  (** [and A B], written [A /\ B], is the conjunction of [A] and [B]
+
+      [conj p q] is a proof of [A /\ B] as soon as 
+      [p] is a proof of [A] and [q] a proof of [B]
+
+      [proj1] and [proj2] are first and second projections of a conjunction *)
+
+  Variables A B : Prop.
+
+  Theorem proj1 : A /\ B -> A.
+  Proof.
+  destruct 1; trivial.
+  Qed.
+
+  Theorem proj2 : A /\ B -> B.
+  Proof.
+  destruct 1; trivial.
+  Qed.
+
+End Conjunction.
+
+(** [or A B], written [A \/ B], is the disjunction of [A] and [B] *)
+
+Inductive or (A B:Prop) : Prop :=
+  | or_introl : A -> A \/ B
+  | or_intror : B -> A \/ B 
+ where "A \/ B" := (or A B) : type_scope.
+
+(** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *)
+
+Definition iff (A B:Prop) := (A -> B) /\ (B -> A).
+
+Notation "A <-> B" := (iff A B) : type_scope.
+
+Section Equivalence.
+
+Theorem iff_refl : forall A:Prop, A <-> A.
+  Proof.
+    split; auto.
+  Qed.
+
+Theorem iff_trans : forall A B C:Prop, (A <-> B) -> (B <-> C) -> (A <-> C).
+  Proof.
+    intros A B C [H1 H2] [H3 H4]; split; auto.
+  Qed.
+
+Theorem iff_sym : forall A B:Prop, (A <-> B) -> (B <-> A).
+  Proof.
+    intros A B [H1 H2]; split; auto.
+  Qed.
+
+End Equivalence.
+
+(** [(IF_then_else P Q R)], written [IF P then Q else R] denotes
+    either [P] and [Q], or [~P] and [Q] *)
+
+Definition IF_then_else (P Q R:Prop) := P /\ Q \/ ~ P /\ R.
+
+Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3)
+  (at level 200) : type_scope.
+
+(** * First-order quantifiers
+  - [ex A P], or simply [exists x, P x], expresses the existence of an 
+      [x] of type [A] which satisfies the predicate [P] ([A] is of type 
+      [Set]). This is existential quantification.
+  - [ex2 A P Q], or simply [exists2 x, P x & Q x], expresses the
+      existence of an [x] of type [A] which satisfies both the predicates
+      [P] and [Q].
+  - Universal quantification (especially first-order one) is normally 
+    written [forall x:A, P x]. For duality with existential quantification, 
+    the construction [all P] is provided too.
+*)
+
+Inductive ex (A:Type) (P:A -> Prop) : Prop :=
+    ex_intro : forall x:A, P x -> ex (A:=A) P.
+
+Inductive ex2 (A:Type) (P Q:A -> Prop) : Prop :=
+    ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q.
+
+Definition all (A:Type) (P:A -> Prop) := forall x:A, P x. 
+
+(* Rule order is important to give printing priority to fully typed exists *)
+
+Notation "'exists' x , p" := (ex (fun x => p))
+  (at level 200, x ident) : type_scope.
+Notation "'exists' x : t , p" := (ex (fun x:t => p))
+  (at level 200, x ident, format "'exists'  '/  ' x  :  t ,  '/  ' p")
+  : type_scope.
+
+Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q))
+  (at level 200, x ident, p at level 200) : type_scope.
+Notation "'exists2' x : t , p & q" := (ex2 (fun x:t => p) (fun x:t => q))
+  (at level 200, x ident, t at level 200, p at level 200,
+   format "'exists2'  '/  ' x  :  t ,  '/  ' '[' p  &  '/' q ']'")
+  : type_scope.
+
+
+(** Derived rules for universal quantification *)
+
+Section universal_quantification.
+
+  Variable A : Type.
+  Variable P : A -> Prop.
+
+  Theorem inst : forall x:A, all (fun x => P x) -> P x.
+  Proof.
+  unfold all in |- *; auto.
+  Qed.
+
+  Theorem gen : forall (B:Prop) (f:forall y:A, B -> P y), B -> all P.
+  Proof.
+  red in |- *; auto.
+  Qed.
+
+End universal_quantification.
+
+(** * Equality *)
+
+(** [eq x y], or simply [x=y], expresses the (Leibniz') equality
+    of [x] and [y]. Both [x] and [y] must belong to the same type [A].
+    The definition is inductive and states the reflexivity of the equality.
+    The others properties (symmetry, transitivity, replacement of 
+    equals) are proved below. The type of [x] and [y] can be made explicit
+    using the notation [x = y :> A] *)
+
+Inductive eq (A:Type) (x:A) : A -> Prop :=
+    refl_equal : x = x :>A 
+ where "x = y :> A" := (@eq A x y) : type_scope.
+
+Notation "x = y" := (x = y :>_) : type_scope.
+Notation "x <> y  :> T" := (~ x = y :>T) : type_scope.
+Notation "x <> y" := (x <> y :>_) : type_scope.
+
+Implicit Arguments eq_ind [A].
+Implicit Arguments eq_rec [A].
+Implicit Arguments eq_rect [A].
+
+Hint Resolve I conj or_introl or_intror refl_equal: core v62.
+Hint Resolve ex_intro ex_intro2: core v62.
+
+Section Logic_lemmas.
+
+  Theorem absurd : forall A C:Prop, A -> ~ A -> C.
+  Proof.
+    unfold not in |- *; intros A C h1 h2.
+    destruct (h2 h1).
+  Qed.
+
+  Section equality.
+    Variables A B : Type.
+    Variable f : A -> B.
+    Variables x y z : A.
+
+    Theorem sym_eq : x = y -> y = x.
+    Proof.
+     destruct 1; trivial.
+    Defined.
+    Opaque sym_eq.
+
+    Theorem trans_eq : x = y -> y = z -> x = z.
+    Proof.
+     destruct 2; trivial.
+    Defined.
+    Opaque trans_eq.
+
+    Theorem f_equal : x = y -> f x = f y.
+    Proof.
+     destruct 1; trivial.
+    Defined.
+    Opaque f_equal.
+
+    Theorem sym_not_eq : x <> y -> y <> x.
+    Proof.
+     red in |- *; intros h1 h2; apply h1; destruct h2; trivial.
+    Qed.
+
+    Definition sym_equal := sym_eq.
+    Definition sym_not_equal := sym_not_eq.
+    Definition trans_equal := trans_eq.
+
+  End equality.
+
+(* Is now a primitive principle 
+  Theorem eq_rect: (A:Type)(x:A)(P:A->Type)(P x)->(y:A)(eq ? x y)->(P y).
+  Proof.
+   Intros.
+   Cut (identity A x y).
+   NewDestruct 1; Auto.
+   NewDestruct H; Auto.
+  Qed.
+*)
+
+  Definition eq_ind_r :
+    forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y.
+   intros A x P H y H0; elim sym_eq with (1 := H0); assumption.
+  Defined.
+
+  Definition eq_rec_r :
+    forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y = x -> P y.
+    intros A x P H y H0; elim sym_eq with (1 := H0); assumption.
+  Defined.
+
+  Definition eq_rect_r :
+    forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y = x -> P y.
+    intros A x P H y H0; elim sym_eq with (1 := H0); assumption.
+  Defined.
+End Logic_lemmas.
+
+Theorem f_equal2 :
+ forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1) 
+   (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
+Proof.
+  destruct 1; destruct 1; reflexivity.
+Qed.
+
+Theorem f_equal3 :
+ forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1) 
+   (x2 y2:A2) (x3 y3:A3),
+   x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3.
+Proof.
+  destruct 1; destruct 1; destruct 1; reflexivity.
+Qed.
+
+Theorem f_equal4 :
+ forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B) 
+   (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
+   x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> f x1 x2 x3 x4 = f y1 y2 y3 y4.
+Proof.
+  destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
+Qed.
+
+Theorem f_equal5 :
+ forall (A1 A2 A3 A4 A5 B:Type) (f:A1 -> A2 -> A3 -> A4 -> A5 -> B)
+   (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4) (x5 y5:A5),
+   x1 = y1 ->
+   x2 = y2 ->
+   x3 = y3 -> x4 = y4 -> x5 = y5 -> f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5.
+Proof.
+  destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
+Qed.
+
+Hint Immediate sym_eq sym_not_eq: core v62.
diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v
new file mode 100755
index 00000000..0e62e842
--- /dev/null
+++ b/theories/Init/Logic_Type.v
@@ -0,0 +1,89 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Logic_Type.v,v 1.19.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Set Implicit Arguments.
+
+(** This module defines quantification on the world [Type]
+    ([Logic.v] was defining it on the world [Set]) *)
+
+Require Import Datatypes.
+Require Export Logic.
+
+Definition notT (A:Type) := A -> False.
+
+Section identity_is_a_congruence.
+
+ Variables A B : Type.
+ Variable f : A -> B.
+
+ Variables x y z : A.
+ 
+ Lemma sym_id : identity x y -> identity y x.
+ Proof.
+  destruct 1; trivial.
+ Qed.
+
+ Lemma trans_id : identity x y -> identity y z -> identity x z.
+ Proof.
+  destruct 2; trivial.
+ Qed.
+
+ Lemma congr_id : identity x y -> identity (f x) (f y).
+ Proof.
+  destruct 1; trivial.
+ Qed.
+
+ Lemma sym_not_id : notT (identity x y) -> notT (identity y x).
+ Proof.
+  red in |- *; intros H H'; apply H; destruct H'; trivial.
+ Qed.
+
+End identity_is_a_congruence.
+
+Definition identity_ind_r :
+  forall (A:Type) (a:A) (P:A -> Prop), P a -> forall y:A, identity y a -> P y.
+ intros A x P H y H0; case sym_id with (1 := H0); trivial.
+Defined.
+
+Definition identity_rec_r :
+  forall (A:Type) (a:A) (P:A -> Set), P a -> forall y:A, identity y a -> P y.
+ intros A x P H y H0; case sym_id with (1 := H0); trivial.
+Defined.
+
+Definition identity_rect_r :
+  forall (A:Type) (a:A) (P:A -> Type), P a -> forall y:A, identity y a -> P y.
+ intros A x P H y H0; case sym_id with (1 := H0); trivial.
+Defined.
+
+Inductive prodT (A B:Type) : Type :=
+    pairT : A -> B -> prodT A B.
+
+Section prodT_proj.
+
+  Variables A B : Type.
+
+  Definition fstT (H:prodT A B) := match H with
+                                   | pairT x _ => x
+                                   end.
+  Definition sndT (H:prodT A B) := match H with
+                                   | pairT _ y => y
+                                   end.
+
+End prodT_proj.
+
+Definition prodT_uncurry (A B C:Type) (f:prodT A B -> C) 
+  (x:A) (y:B) : C := f (pairT x y).
+
+Definition prodT_curry (A B C:Type) (f:A -> B -> C) 
+  (p:prodT A B) : C := match p with
+                       | pairT x y => f x y
+                       end.
+
+Hint Immediate sym_id sym_not_id: core v62.
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
new file mode 100644
index 00000000..2e7cb1fc
--- /dev/null
+++ b/theories/Init/Notations.v
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Notations.v,v 1.24.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+(** These are the notations whose level and associativity is imposed by Coq *)
+
+(** Notations for logical connectives *)
+
+Reserved Notation "x <-> y" (at level 95, no associativity).
+Reserved Notation "x /\ y" (at level 80, right associativity).
+Reserved Notation "x \/ y" (at level 85, right associativity).
+Reserved Notation "~ x" (at level 75, right associativity).
+
+(** Notations for equality and inequalities *)
+
+Reserved Notation "x = y  :> T"
+(at level 70, y at next level, no associativity).
+Reserved Notation "x = y" (at level 70, no associativity).
+Reserved Notation "x = y = z"
+(at level 70, no associativity, y at next level).
+
+Reserved Notation "x <> y  :> T"
+(at level 70, y at next level, no associativity).
+Reserved Notation "x <> y" (at level 70, no associativity).
+
+Reserved Notation "x <= y" (at level 70, no associativity).
+Reserved Notation "x < y" (at level 70, no associativity).
+Reserved Notation "x >= y" (at level 70, no associativity).
+Reserved Notation "x > y" (at level 70, no associativity).
+
+Reserved Notation "x <= y <= z" (at level 70, y at next level).
+Reserved Notation "x <= y < z" (at level 70, y at next level).
+Reserved Notation "x < y < z" (at level 70, y at next level).
+Reserved Notation "x < y <= z" (at level 70, y at next level).
+
+(** Arithmetical notations (also used for type constructors) *)
+
+Reserved Notation "x + y" (at level 50, left associativity).
+Reserved Notation "x - y" (at level 50, left associativity).
+Reserved Notation "x * y" (at level 40, left associativity).
+Reserved Notation "x / y" (at level 40, left associativity).
+Reserved Notation "- x" (at level 35, right associativity).
+Reserved Notation "/ x" (at level 35, right associativity).
+Reserved Notation "x ^ y" (at level 30, right associativity).
+
+(** Notations for pairs *)
+
+Reserved Notation "( x , y , .. , z )" (at level 0).
+
+(** Notation "{ x }" is reserved and has a special status as component
+    of other notations; it is at level 0 to factor with {x:A|P} etc *)
+
+Reserved Notation "{ x }" (at level 0, x at level 99).
+
+(** Notations for sum-types *)
+
+Reserved Notation "{ A } + { B }" (at level 50, left associativity).
+Reserved Notation "A + { B }" (at level 50, left associativity).
+
+(** Notations for sigma-types or subsets *)
+
+Reserved Notation "{ x : A  |  P }" (at level 0, x at level 99).
+Reserved Notation "{ x : A  |  P  &  Q }" (at level 0, x at level 99).
+
+Reserved Notation "{ x : A  &  P }" (at level 0, x at level 99).
+Reserved Notation "{ x : A  &  P  &  Q }" (at level 0, x at level 99).
+
+Delimit Scope type_scope with type.
+Delimit Scope core_scope with core.
+
+Open Scope core_scope.
+Open Scope type_scope.
diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v
new file mode 100755
index 00000000..789a020f
--- /dev/null
+++ b/theories/Init/Peano.v
@@ -0,0 +1,210 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Peano.v,v 1.23.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+(** Natural numbers [nat] built from [O] and [S] are defined in Datatypes.v *)
+
+(** This module defines the following operations on natural numbers :
+    - predecessor [pred]
+    - addition [plus]
+    - multiplication [mult]
+    - less or equal order [le]
+    - less [lt]
+    - greater or equal [ge]
+    - greater [gt]
+
+   This module states various lemmas and theorems about natural numbers,
+   including Peano's axioms of arithmetic (in Coq, these are in fact provable)
+   Case analysis on [nat] and induction on [nat * nat] are provided too *)
+
+Require Import Notations.
+Require Import Datatypes.
+Require Import Logic.
+
+Open Scope nat_scope.
+
+Definition eq_S := f_equal S.
+
+Hint Resolve (f_equal S): v62.
+Hint Resolve (f_equal (A:=nat)): core.
+
+(** The predecessor function *)
+
+Definition pred (n:nat) : nat := match n with
+                                 | O => 0
+                                 | S u => u
+                                 end.
+Hint Resolve (f_equal pred): v62.
+
+Theorem pred_Sn : forall n:nat, n = pred (S n).
+Proof.
+  auto.
+Qed.
+
+Theorem eq_add_S : forall n m:nat, S n = S m -> n = m.
+Proof.
+  intros n m H; change (pred (S n) = pred (S m)) in |- *; auto.
+Qed.
+
+Hint Immediate eq_add_S: core v62.
+
+(** A consequence of the previous axioms *)
+
+Theorem not_eq_S : forall n m:nat, n <> m -> S n <> S m.
+Proof.
+  red in |- *; auto.
+Qed.
+Hint Resolve not_eq_S: core v62.
+
+Definition IsSucc (n:nat) : Prop :=
+  match n with
+  | O => False
+  | S p => True
+  end.
+
+
+Theorem O_S : forall n:nat, 0 <> S n.
+Proof.
+  red in |- *; intros n H.
+  change (IsSucc 0) in |- *.
+  rewrite <- (sym_eq (x:=0) (y:=(S n))); [ exact I | assumption ].
+Qed.
+Hint Resolve O_S: core v62.
+
+Theorem n_Sn : forall n:nat, n <> S n.
+Proof.
+  induction n; auto.
+Qed.
+Hint Resolve n_Sn: core v62.
+
+(** Addition *)
+
+Fixpoint plus (n m:nat) {struct n} : nat :=
+  match n with
+  | O => m
+  | S p => S (plus p m)
+  end.
+Hint Resolve (f_equal2 plus): v62.
+Hint Resolve (f_equal2 (A1:=nat) (A2:=nat)): core.
+
+Infix "+" := plus : nat_scope.
+
+Lemma plus_n_O : forall n:nat, n = n + 0.
+Proof.
+  induction n; simpl in |- *; auto.
+Qed.
+Hint Resolve plus_n_O: core v62.
+
+Lemma plus_O_n : forall n:nat, 0 + n = n.
+Proof.
+  auto.
+Qed.
+
+Lemma plus_n_Sm : forall n m:nat, S (n + m) = n + S m.
+Proof.
+  intros n m; induction n; simpl in |- *; auto.
+Qed.
+Hint Resolve plus_n_Sm: core v62.
+
+Lemma plus_Sn_m : forall n m:nat, S n + m = S (n + m).
+Proof.
+  auto.
+Qed.
+
+(** Multiplication *)
+
+Fixpoint mult (n m:nat) {struct n} : nat :=
+  match n with
+  | O => 0
+  | S p => m + mult p m
+  end.
+Hint Resolve (f_equal2 mult): core v62.
+
+Infix "*" := mult : nat_scope.
+
+Lemma mult_n_O : forall n:nat, 0 = n * 0.
+Proof.
+  induction n; simpl in |- *; auto.
+Qed.
+Hint Resolve mult_n_O: core v62.
+
+Lemma mult_n_Sm : forall n m:nat, n * m + n = n * S m.
+Proof.
+  intros; induction n as [| p H]; simpl in |- *; auto.
+  destruct H; rewrite <- plus_n_Sm; apply (f_equal S).
+  pattern m at 1 3 in |- *; elim m; simpl in |- *; auto.
+Qed.
+Hint Resolve mult_n_Sm: core v62.
+
+(** Definition of subtraction on [nat] : [m-n] is [0] if [n>=m] *)
+
+Fixpoint minus (n m:nat) {struct n} : nat :=
+  match n, m with
+  | O, _ => 0
+  | S k, O => S k
+  | S k, S l => minus k l
+  end. 
+
+Infix "-" := minus : nat_scope.
+
+(** Definition of the usual orders, the basic properties of [le] and [lt] 
+    can be found in files Le and Lt *)
+
+(** An inductive definition to define the order *)
+
+Inductive le (n:nat) : nat -> Prop :=
+  | le_n : le n n
+  | le_S : forall m:nat, le n m -> le n (S m).
+
+Infix "<=" := le : nat_scope.
+
+Hint Constructors le: core v62.
+(*i equivalent to : "Hints Resolve le_n le_S : core v62." i*)
+
+Definition lt (n m:nat) := S n <= m.
+Hint Unfold lt: core v62.
+
+Infix "<" := lt : nat_scope.
+
+Definition ge (n m:nat) := m <= n.
+Hint Unfold ge: core v62.
+
+Infix ">=" := ge : nat_scope.
+
+Definition gt (n m:nat) := m < n.
+Hint Unfold gt: core v62.
+
+Infix ">" := gt : nat_scope.
+
+Notation "x <= y <= z" := (x <= y /\ y <= z) : nat_scope.
+Notation "x <= y < z" := (x <= y /\ y < z) : nat_scope.
+Notation "x < y < z" := (x < y /\ y < z) : nat_scope.
+Notation "x < y <= z" := (x < y /\ y <= z) : nat_scope.
+
+(** Pattern-Matching on natural numbers *)
+
+Theorem nat_case :
+ forall (n:nat) (P:nat -> Prop), P 0 -> (forall m:nat, P (S m)) -> P n.
+Proof.
+  induction n; auto.
+Qed.
+
+(** Principle of double induction *)
+
+Theorem nat_double_ind :
+ forall R:nat -> nat -> Prop,
+   (forall n:nat, R 0 n) ->
+   (forall n:nat, R (S n) 0) ->
+   (forall n m:nat, R n m -> R (S n) (S m)) -> forall n m:nat, R n m.
+Proof.
+  induction n; auto.
+  destruct m as [| n0]; auto.
+Qed.
+
+(** Notations *)
diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v
new file mode 100755
index 00000000..2fe520c4
--- /dev/null
+++ b/theories/Init/Prelude.v
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Prelude.v,v 1.11.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Require Export Notations.
+Require Export Logic.
+Require Export Datatypes.
+Require Export Specif.
+Require Export Peano.
+Require Export Wf.
\ No newline at end of file
diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v
new file mode 100755
index 00000000..6855e689
--- /dev/null
+++ b/theories/Init/Specif.v
@@ -0,0 +1,212 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Specif.v,v 1.25.2.1 2004/07/16 19:31:04 herbelin Exp $ i*)
+
+Set Implicit Arguments.
+
+(** Basic specifications : Sets containing logical information *)
+
+Require Import Notations.
+Require Import Datatypes.
+Require Import Logic.
+
+(** Subsets *)
+
+(** [(sig A P)], or more suggestively [{x:A | (P x)}], denotes the subset 
+    of elements of the Set [A] which satisfy the predicate [P].
+    Similarly [(sig2 A P Q)], or [{x:A | (P x) & (Q x)}], denotes the subset 
+    of elements of the Set [A] which satisfy both [P] and [Q]. *)
+
+Inductive sig (A:Set) (P:A -> Prop) : Set :=
+    exist : forall x:A, P x -> sig (A:=A) P.
+
+Inductive sig2 (A:Set) (P Q:A -> Prop) : Set :=
+    exist2 : forall x:A, P x -> Q x -> sig2 (A:=A) P Q.
+
+(** [(sigS A P)], or more suggestively [{x:A & (P x)}], is a subtle variant
+    of subset where [P] is now of type [Set].
+    Similarly for [(sigS2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *)
+     
+Inductive sigS (A:Set) (P:A -> Set) : Set :=
+    existS : forall x:A, P x -> sigS (A:=A) P.
+
+Inductive sigS2 (A:Set) (P Q:A -> Set) : Set :=
+    existS2 : forall x:A, P x -> Q x -> sigS2 (A:=A) P Q.
+
+Arguments Scope sig [type_scope type_scope].
+Arguments Scope sig2 [type_scope type_scope type_scope].
+Arguments Scope sigS [type_scope type_scope].
+Arguments Scope sigS2 [type_scope type_scope type_scope].
+
+Notation "{ x : A  |  P }" := (sig (fun x:A => P)) : type_scope.
+Notation "{ x : A  |  P  &  Q }" := (sig2 (fun x:A => P) (fun x:A => Q)) :
+  type_scope.
+Notation "{ x : A  &  P }" := (sigS (fun x:A => P)) : type_scope.
+Notation "{ x : A  &  P  &  Q }" := (sigS2 (fun x:A => P) (fun x:A => Q)) :
+  type_scope.
+
+Add Printing Let sig.
+Add Printing Let sig2.
+Add Printing Let sigS.
+Add Printing Let sigS2.
+
+
+(** Projections of sig *)
+
+Section Subset_projections.
+
+  Variable A : Set.
+  Variable P : A -> Prop.
+
+  Definition proj1_sig (e:sig P) := match e with
+                                    | exist a b => a
+                                    end.
+
+  Definition proj2_sig (e:sig P) :=
+    match e return P (proj1_sig e) with
+    | exist a b => b
+    end.
+
+End Subset_projections.
+
+
+(** Projections of sigS *)
+
+Section Projections.
+
+  Variable A : Set.
+  Variable P : A -> Set.
+
+ (** An element [y] of a subset [{x:A & (P x)}] is the pair of an [a] of 
+     type [A] and of a proof [h] that [a] satisfies [P].
+     Then [(projS1 y)] is the witness [a]
+     and [(projS2 y)] is the proof of [(P a)] *)
+
+  Definition projS1 (x:sigS P) : A := match x with
+                                      | existS a _ => a
+                                      end.
+  Definition projS2 (x:sigS P) : P (projS1 x) :=
+    match x return P (projS1 x) with
+    | existS _ h => h
+    end.
+
+End Projections.
+
+
+(** Extended_booleans *)
+
+Inductive sumbool (A B:Prop) : Set :=
+  | left : A -> {A} + {B}
+  | right : B -> {A} + {B} 
+ where "{ A } + { B }" := (sumbool A B) : type_scope.
+
+Add Printing If sumbool.
+
+Inductive sumor (A:Set) (B:Prop) : Set :=
+  | inleft : A -> A + {B}
+  | inright : B -> A + {B} 
+ where "A + { B }" := (sumor A B) : type_scope.
+
+Add Printing If sumor.
+
+(** Choice *)
+
+Section Choice_lemmas.
+
+  (** The following lemmas state various forms of the axiom of choice *)
+
+  Variables S S' : Set.
+  Variable R : S -> S' -> Prop.
+  Variable R' : S -> S' -> Set.
+  Variables R1 R2 : S -> Prop.
+
+  Lemma Choice :
+   (forall x:S, sig (fun y:S' => R x y)) ->
+   sig (fun f:S -> S' => forall z:S, R z (f z)).
+  Proof.
+   intro H.
+   exists (fun z:S => match H z with
+                      | exist y _ => y
+                      end).
+   intro z; destruct (H z); trivial.
+  Qed.
+
+  Lemma Choice2 :
+   (forall x:S, sigS (fun y:S' => R' x y)) ->
+   sigS (fun f:S -> S' => forall z:S, R' z (f z)).
+  Proof.
+    intro H.
+    exists (fun z:S => match H z with
+                       | existS y _ => y
+                       end).
+    intro z; destruct (H z); trivial.
+  Qed.
+
+  Lemma bool_choice :
+   (forall x:S, {R1 x} + {R2 x}) ->
+   sig
+     (fun f:S -> bool =>
+        forall x:S, f x = true /\ R1 x \/ f x = false /\ R2 x).
+  Proof.
+    intro H.
+    exists
+     (fun z:S => match H z with
+                 | left _ => true
+                 | right _ => false
+                 end).
+    intro z; destruct (H z); auto.
+  Qed.
+
+End Choice_lemmas.
+
+ (** A result of type [(Exc A)] is either a normal value of type [A] or 
+     an [error] :
+     [Inductive Exc [A:Set] : Set := value : A->(Exc A) | error : (Exc A)]
+     it is implemented using the option type. *) 
+
+Definition Exc := option.
+Definition value := Some.
+Definition error := @None.
+
+Implicit Arguments error [A].
+
+Definition except := False_rec. (* for compatibility with previous versions *)
+
+Implicit Arguments except [P].
+
+Theorem absurd_set : forall (A:Prop) (C:Set), A -> ~ A -> C.
+Proof.
+  intros A C h1 h2.
+  apply False_rec.
+  apply (h2 h1).
+Qed.
+
+Hint Resolve left right inleft inright: core v62.
+
+(** Sigma Type at Type level [sigT] *)
+
+Inductive sigT (A:Type) (P:A -> Type) : Type :=
+    existT : forall x:A, P x -> sigT (A:=A) P.
+
+Section projections_sigT.
+
+  Variable A : Type.
+  Variable P : A -> Type.
+
+  Definition projT1 (H:sigT P) : A := match H with
+                                      | existT x _ => x
+                                      end.
+   
+  Definition projT2 : forall x:sigT P, P (projT1 x) :=
+    fun H:sigT P => match H return P (projT1 H) with
+                    | existT x h => h
+                    end.
+
+End projections_sigT.
+
diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v
new file mode 100755
index 00000000..7ab3723d
--- /dev/null
+++ b/theories/Init/Wf.v
@@ -0,0 +1,171 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Set Implicit Arguments.
+
+(*i $Id: Wf.v,v 1.17.2.1 2004/07/16 19:31:04 herbelin Exp $ i*)
+
+(** This module proves the validity of
+    - well-founded recursion (also called course of values)
+    - well-founded induction
+
+   from a well-founded ordering on a given set *)
+
+Require Import Notations.
+Require Import Logic.
+Require Import Datatypes.
+
+(** Well-founded induction principle on Prop *)
+
+Section Well_founded.
+
+ Variable A : Set.
+ Variable R : A -> A -> Prop.
+
+ (** The accessibility predicate is defined to be non-informative *)
+
+ Inductive Acc : A -> Prop :=
+     Acc_intro : forall x:A, (forall y:A, R y x -> Acc y) -> Acc x.
+
+ Lemma Acc_inv : forall x:A, Acc x -> forall y:A, R y x -> Acc y.
+  destruct 1; trivial.
+ Defined.
+
+  (** the informative elimination :
+     [let Acc_rec F = let rec wf x = F x wf in wf] *)
+
+ Section AccRecType.
+  Variable P : A -> Type.
+  Variable
+    F :
+      forall x:A,
+        (forall y:A, R y x -> Acc y) -> (forall y:A, R y x -> P y) -> P x.
+
+  Fixpoint Acc_rect (x:A) (a:Acc x) {struct a} : P x :=
+    F (Acc_inv a) (fun (y:A) (h:R y x) => Acc_rect (x:=y) (Acc_inv a h)).
+
+ End AccRecType.
+
+ Definition Acc_rec (P:A -> Set) := Acc_rect P.
+
+ (** A simplified version of Acc_rec(t) *)
+
+ Section AccIter.
+  Variable P : A -> Type. 
+  Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x.
+
+  Fixpoint Acc_iter (x:A) (a:Acc x) {struct a} : P x :=
+    F (fun (y:A) (h:R y x) => Acc_iter (x:=y) (Acc_inv a h)).
+
+ End AccIter.
+
+ (** A relation is well-founded if every element is accessible *)
+
+ Definition well_founded := forall a:A, Acc a.
+
+ (** well-founded induction on Set and Prop *)
+
+ Hypothesis Rwf : well_founded.
+
+ Theorem well_founded_induction_type :
+  forall P:A -> Type,
+    (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a.
+ Proof.
+  intros; apply (Acc_iter P); auto.
+ Defined.
+
+ Theorem well_founded_induction :
+  forall P:A -> Set,
+    (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a.
+ Proof.
+  exact (fun P:A -> Set => well_founded_induction_type P).
+ Defined.
+
+ Theorem well_founded_ind :
+  forall P:A -> Prop,
+    (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a.
+ Proof.
+  exact (fun P:A -> Prop => well_founded_induction_type P).
+ Defined.
+
+(** Building fixpoints  *) 
+
+Section FixPoint.
+
+Variable P : A -> Set.
+Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x.
+
+Fixpoint Fix_F (x:A) (r:Acc x) {struct r} : P x :=
+  F (fun (y:A) (p:R y x) => Fix_F (x:=y) (Acc_inv r p)).
+
+Definition Fix (x:A) := Fix_F (Rwf x).
+
+(** Proof that [well_founded_induction] satisfies the fixpoint equation. 
+    It requires an extra property of the functional *)
+
+Hypothesis
+  F_ext :
+    forall (x:A) (f g:forall y:A, R y x -> P y),
+      (forall (y:A) (p:R y x), f y p = g y p) -> F f = F g.
+
+Scheme Acc_inv_dep := Induction for Acc Sort Prop.
+
+Lemma Fix_F_eq :
+ forall (x:A) (r:Acc x),
+   F (fun (y:A) (p:R y x) => Fix_F (Acc_inv r p)) = Fix_F r.
+destruct r using Acc_inv_dep; auto.
+Qed.
+
+Lemma Fix_F_inv : forall (x:A) (r s:Acc x), Fix_F r = Fix_F s.
+intro x; induction (Rwf x); intros.
+rewrite <- (Fix_F_eq r); rewrite <- (Fix_F_eq s); intros.
+apply F_ext; auto.
+Qed.
+
+
+Lemma Fix_eq : forall x:A, Fix x = F (fun (y:A) (p:R y x) => Fix y).
+intro x; unfold Fix in |- *.
+rewrite <- (Fix_F_eq (x:=x)).
+apply F_ext; intros.
+apply Fix_F_inv.
+Qed.
+
+End FixPoint.
+
+End Well_founded. 
+
+(** A recursor over pairs *)
+
+Section Well_founded_2.
+
+  Variables A B : Set.
+  Variable R : A * B -> A * B -> Prop.
+
+  Variable P : A -> B -> Type. 
+  Variable
+    F :
+      forall (x:A) (x':B),
+        (forall (y:A) (y':B), R (y, y') (x, x') -> P y y') -> P x x'.
+
+  Fixpoint Acc_iter_2 (x:A) (x':B) (a:Acc R (x, x')) {struct a} : 
+   P x x' :=
+    F
+      (fun (y:A) (y':B) (h:R (y, y') (x, x')) =>
+         Acc_iter_2 (x:=y) (x':=y') (Acc_inv a (y, y') h)).
+
+  Hypothesis Rwf : well_founded R.
+
+  Theorem well_founded_induction_type_2 :
+   (forall (x:A) (x':B),
+      (forall (y:A) (y':B), R (y, y') (x, x') -> P y y') -> P x x') ->
+   forall (a:A) (b:B), P a b.
+  Proof.
+   intros; apply Acc_iter_2; auto.
+  Defined.
+
+End Well_founded_2.
diff --git a/theories/IntMap/.depend b/theories/IntMap/.depend
new file mode 100644
index 00000000..8c90ac99
--- /dev/null
+++ b/theories/IntMap/.depend
@@ -0,0 +1,48 @@
+Mapsubset.vo: Mapsubset.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo
+Mapsubset.vi: Mapsubset.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo
+Maplists.vo: Maplists.v Addr.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapsubset.vo Mapcard.vo Mapcanon.vo Mapc.vo Mapiter.vo Mapfold.vo
+Maplists.vi: Maplists.v Addr.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapsubset.vo Mapcard.vo Mapcanon.vo Mapc.vo Mapiter.vo Mapfold.vo
+Mapiter.vo: Mapiter.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo
+Mapiter.vi: Mapiter.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo
+Mapfold.vo: Mapfold.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Lsort.vo Mapsubset.vo
+Mapfold.vi: Mapfold.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Lsort.vo Mapsubset.vo
+Mapcard.vo: Mapcard.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Mapsubset.vo Lsort.vo
+Mapcard.vi: Mapcard.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Mapsubset.vo Lsort.vo
+Mapcanon.vo: Mapcanon.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Lsort.vo Mapsubset.vo Mapcard.vo
+Mapcanon.vi: Mapcanon.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Lsort.vo Mapsubset.vo Mapcard.vo
+Mapc.vo: Mapc.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapcard.vo Mapcanon.vo
+Mapc.vi: Mapc.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapcard.vo Mapcanon.vo
+Mapaxioms.vo: Mapaxioms.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo
+Mapaxioms.vi: Mapaxioms.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo
+Map.vo: Map.v Addr.vo Adist.vo Addec.vo
+Map.vi: Map.v Addr.vo Adist.vo Addec.vo
+Lsort.vo: Lsort.v Addr.vo Adist.vo Addec.vo Map.vo Mapiter.vo
+Lsort.vi: Lsort.v Addr.vo Adist.vo Addec.vo Map.vo Mapiter.vo
+Fset.vo: Fset.v Addr.vo Adist.vo Addec.vo Map.vo
+Fset.vi: Fset.v Addr.vo Adist.vo Addec.vo Map.vo
+Allmaps.vo: Allmaps.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapfold.vo Mapcard.vo Mapcanon.vo Mapc.vo Maplists.vo Adalloc.vo
+Allmaps.vi: Allmaps.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapfold.vo Mapcard.vo Mapcanon.vo Mapc.vo Maplists.vo Adalloc.vo
+Adist.vo: Adist.v Addr.vo
+Adist.vi: Adist.v Addr.vo
+Addr.vo: Addr.v
+Addr.vi: Addr.v
+Addec.vo: Addec.v Addr.vo
+Addec.vi: Addec.v Addr.vo
+Adalloc.vo: Adalloc.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo
+Adalloc.vi: Adalloc.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo
+Mapsubset.html: Mapsubset.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html
+Maplists.html: Maplists.v Addr.html Addec.html Map.html Fset.html Mapaxioms.html Mapsubset.html Mapcard.html Mapcanon.html Mapc.html Mapiter.html Mapfold.html
+Mapiter.html: Mapiter.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Fset.html
+Mapfold.html: Mapfold.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html Lsort.html Mapsubset.html
+Mapcard.html: Mapcard.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Mapiter.html Fset.html Mapsubset.html Lsort.html
+Mapcanon.html: Mapcanon.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Mapiter.html Fset.html Lsort.html Mapsubset.html Mapcard.html
+Mapc.html: Mapc.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Fset.html Mapiter.html Mapsubset.html Lsort.html Mapcard.html Mapcanon.html
+Mapaxioms.html: Mapaxioms.v Addr.html Adist.html Addec.html Map.html Fset.html
+Map.html: Map.v Addr.html Adist.html Addec.html
+Lsort.html: Lsort.v Addr.html Adist.html Addec.html Map.html Mapiter.html
+Fset.html: Fset.v Addr.html Adist.html Addec.html Map.html
+Allmaps.html: Allmaps.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html Mapsubset.html Lsort.html Mapfold.html Mapcard.html Mapcanon.html Mapc.html Maplists.html Adalloc.html
+Adist.html: Adist.v Addr.html
+Addr.html: Addr.v
+Addec.html: Addec.v Addr.html
+Adalloc.html: Adalloc.v Addr.html Adist.html Addec.html Map.html Fset.html
diff --git a/theories/IntMap/Adalloc.v b/theories/IntMap/Adalloc.v
new file mode 100644
index 00000000..9fde8f5f
--- /dev/null
+++ b/theories/IntMap/Adalloc.v
@@ -0,0 +1,365 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Adalloc.v,v 1.10.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import ZArith.
+Require Import Arith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Fset.
+
+Section AdAlloc.
+
+  Variable A : Set.
+
+  Definition nat_of_ad (a:ad) :=
+    match a with
+    | ad_z => 0
+    | ad_x p => nat_of_P p
+    end.
+
+  Fixpoint nat_le (m:nat) : nat -> bool :=
+    match m with
+    | O => fun _:nat => true
+    | S m' =>
+        fun n:nat => match n with
+                     | O => false
+                     | S n' => nat_le m' n'
+                     end
+    end.
+
+  Lemma nat_le_correct : forall m n:nat, m <= n -> nat_le m n = true.
+  Proof.
+    induction m as [| m IHm]. trivial.
+    destruct n. intro H. elim (le_Sn_O _ H).
+    intros. simpl in |- *. apply IHm. apply le_S_n. assumption.
+  Qed.
+
+  Lemma nat_le_complete : forall m n:nat, nat_le m n = true -> m <= n.
+  Proof.
+    induction m. trivial with arith.
+    destruct n. intro H. discriminate H.
+    auto with arith.
+  Qed.
+
+  Lemma nat_le_correct_conv : forall m n:nat, m < n -> nat_le n m = false.
+  Proof.
+    intros. elim (sumbool_of_bool (nat_le n m)). intro H0.
+    elim (lt_irrefl _ (lt_le_trans _ _ _ H (nat_le_complete _ _ H0))).
+    trivial.
+  Qed.
+
+  Lemma nat_le_complete_conv : forall m n:nat, nat_le n m = false -> m < n.
+  Proof.
+    intros. elim (le_or_lt n m). intro. conditional trivial rewrite nat_le_correct in H. discriminate H.
+    trivial.
+  Qed.
+
+  Definition ad_of_nat (n:nat) :=
+    match n with
+    | O => ad_z
+    | S n' => ad_x (P_of_succ_nat n')
+    end.
+
+  Lemma ad_of_nat_of_ad : forall a:ad, ad_of_nat (nat_of_ad a) = a.
+  Proof.
+    destruct a as [| p]. reflexivity.
+    simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *. rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H.
+    rewrite nat_of_P_inj with (1 := H). reflexivity.
+  Qed.
+
+  Lemma nat_of_ad_of_nat : forall n:nat, nat_of_ad (ad_of_nat n) = n.
+  Proof.
+    induction n. trivial.
+    intros. simpl in |- *. apply nat_of_P_o_P_of_succ_nat_eq_succ.
+  Qed.
+
+  Definition ad_le (a b:ad) := nat_le (nat_of_ad a) (nat_of_ad b).
+
+  Lemma ad_le_refl : forall a:ad, ad_le a a = true.
+  Proof.
+    intro. unfold ad_le in |- *. apply nat_le_correct. apply le_n.
+  Qed.
+
+  Lemma ad_le_antisym :
+   forall a b:ad, ad_le a b = true -> ad_le b a = true -> a = b.
+  Proof.
+    unfold ad_le in |- *. intros. rewrite <- (ad_of_nat_of_ad a). rewrite <- (ad_of_nat_of_ad b).
+    rewrite (le_antisym _ _ (nat_le_complete _ _ H) (nat_le_complete _ _ H0)). reflexivity.
+  Qed.
+
+  Lemma ad_le_trans :
+   forall a b c:ad, ad_le a b = true -> ad_le b c = true -> ad_le a c = true.
+  Proof.
+    unfold ad_le in |- *. intros. apply nat_le_correct. apply le_trans with (m := nat_of_ad b).
+    apply nat_le_complete. assumption.
+    apply nat_le_complete. assumption.
+  Qed.
+
+  Lemma ad_le_lt_trans :
+   forall a b c:ad,
+     ad_le a b = true -> ad_le c b = false -> ad_le c a = false.
+  Proof.
+    unfold ad_le in |- *. intros. apply nat_le_correct_conv. apply le_lt_trans with (m := nat_of_ad b).
+    apply nat_le_complete. assumption.
+    apply nat_le_complete_conv. assumption.
+  Qed.
+
+  Lemma ad_lt_le_trans :
+   forall a b c:ad,
+     ad_le b a = false -> ad_le b c = true -> ad_le c a = false.
+  Proof.
+    unfold ad_le in |- *. intros. apply nat_le_correct_conv. apply lt_le_trans with (m := nat_of_ad b).
+    apply nat_le_complete_conv. assumption.
+    apply nat_le_complete. assumption.
+  Qed.
+
+  Lemma ad_lt_trans :
+   forall a b c:ad,
+     ad_le b a = false -> ad_le c b = false -> ad_le c a = false.
+  Proof.
+    unfold ad_le in |- *. intros. apply nat_le_correct_conv. apply lt_trans with (m := nat_of_ad b).
+    apply nat_le_complete_conv. assumption.
+    apply nat_le_complete_conv. assumption.
+  Qed.
+
+  Lemma ad_lt_le_weak : forall a b:ad, ad_le b a = false -> ad_le a b = true.
+  Proof.
+    unfold ad_le in |- *. intros. apply nat_le_correct. apply lt_le_weak.
+    apply nat_le_complete_conv. assumption.
+  Qed.
+
+  Definition ad_min (a b:ad) := if ad_le a b then a else b.
+
+  Lemma ad_min_choice : forall a b:ad, {ad_min a b = a} + {ad_min a b = b}.
+  Proof.
+    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le a b)). intro H. left. rewrite H.
+    reflexivity.
+    intro H. right. rewrite H. reflexivity.
+  Qed.
+
+  Lemma ad_min_le_1 : forall a b:ad, ad_le (ad_min a b) a = true.
+  Proof.
+    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le a b)). intro H. rewrite H.
+    apply ad_le_refl.
+    intro H. rewrite H. apply ad_lt_le_weak. assumption.
+  Qed.
+
+  Lemma ad_min_le_2 : forall a b:ad, ad_le (ad_min a b) b = true.
+  Proof.
+    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le a b)). intro H. rewrite H. assumption.
+    intro H. rewrite H. apply ad_le_refl.
+  Qed.
+
+  Lemma ad_min_le_3 :
+   forall a b c:ad, ad_le a (ad_min b c) = true -> ad_le a b = true.
+  Proof.
+    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H.
+    assumption.
+    intro H0. rewrite H0 in H. apply ad_lt_le_weak. apply ad_le_lt_trans with (b := c); assumption.
+  Qed.
+
+  Lemma ad_min_le_4 :
+   forall a b c:ad, ad_le a (ad_min b c) = true -> ad_le a c = true.
+  Proof.
+    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H.
+    apply ad_le_trans with (b := b); assumption.
+    intro H0. rewrite H0 in H. assumption.
+  Qed.
+
+  Lemma ad_min_le_5 :
+   forall a b c:ad,
+     ad_le a b = true -> ad_le a c = true -> ad_le a (ad_min b c) = true.
+  Proof.
+    intros. elim (ad_min_choice b c). intro H1. rewrite H1. assumption.
+    intro H1. rewrite H1. assumption.
+  Qed.
+
+  Lemma ad_min_lt_3 :
+   forall a b c:ad, ad_le (ad_min b c) a = false -> ad_le b a = false.
+  Proof.
+    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H.
+    assumption.
+    intro H0. rewrite H0 in H. apply ad_lt_trans with (b := c); assumption.
+  Qed.
+
+  Lemma ad_min_lt_4 :
+   forall a b c:ad, ad_le (ad_min b c) a = false -> ad_le c a = false.
+  Proof.
+    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H.
+    apply ad_lt_le_trans with (b := b); assumption.
+    intro H0. rewrite H0 in H. assumption.
+  Qed.
+
+  (** Allocator: returns an address not in the domain of [m].
+  This allocator is optimal in that it returns the lowest possible address,
+  in the usual ordering on integers. It is not the most efficient, however. *)
+  Fixpoint ad_alloc_opt (m:Map A) : ad :=
+    match m with
+    | M0 => ad_z
+    | M1 a _ => if ad_eq a ad_z then ad_x 1 else ad_z
+    | M2 m1 m2 =>
+        ad_min (ad_double (ad_alloc_opt m1))
+          (ad_double_plus_un (ad_alloc_opt m2))
+    end.
+
+  Lemma ad_alloc_opt_allocates_1 :
+   forall m:Map A, MapGet A m (ad_alloc_opt m) = NONE A.
+  Proof.
+    induction m as [| a| m0 H m1 H0]. reflexivity.
+    simpl in |- *. elim (sumbool_of_bool (ad_eq a ad_z)). intro H. rewrite H.
+    rewrite (ad_eq_complete _ _ H). reflexivity.
+    intro H. rewrite H. rewrite H. reflexivity.
+    intros. change
+   (ad_alloc_opt (M2 A m0 m1)) with (ad_min (ad_double (ad_alloc_opt m0))
+                                       (ad_double_plus_un (ad_alloc_opt m1)))
+  in |- *.
+    elim
+     (ad_min_choice (ad_double (ad_alloc_opt m0))
+        (ad_double_plus_un (ad_alloc_opt m1))).
+    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_0. rewrite ad_double_div_2. assumption.
+    apply ad_double_bit_0.
+    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_1. rewrite ad_double_plus_un_div_2. assumption.
+    apply ad_double_plus_un_bit_0.
+  Qed.
+
+  Lemma ad_alloc_opt_allocates :
+   forall m:Map A, in_dom A (ad_alloc_opt m) m = false.
+  Proof.
+    unfold in_dom in |- *. intro. rewrite (ad_alloc_opt_allocates_1 m). reflexivity.
+  Qed.
+
+  (** Moreover, this is optimal: all addresses below [(ad_alloc_opt m)]
+      are in [dom m]: *)
+
+  Lemma nat_of_ad_double :
+   forall a:ad, nat_of_ad (ad_double a) = 2 * nat_of_ad a.
+  Proof.
+    destruct a as [| p]. trivial.
+    exact (nat_of_P_xO p).
+  Qed.
+
+  Lemma nat_of_ad_double_plus_un :
+   forall a:ad, nat_of_ad (ad_double_plus_un a) = S (2 * nat_of_ad a).
+  Proof.
+    destruct a as [| p]. trivial.
+    exact (nat_of_P_xI p).
+  Qed.
+
+  Lemma ad_le_double_mono :
+   forall a b:ad,
+     ad_le a b = true -> ad_le (ad_double a) (ad_double b) = true.
+  Proof.
+    unfold ad_le in |- *. intros. rewrite nat_of_ad_double. rewrite nat_of_ad_double. apply nat_le_correct.
+    simpl in |- *. apply plus_le_compat. apply nat_le_complete. assumption.
+    apply plus_le_compat. apply nat_le_complete. assumption.
+    apply le_n.
+  Qed.
+
+  Lemma ad_le_double_plus_un_mono :
+   forall a b:ad,
+     ad_le a b = true ->
+     ad_le (ad_double_plus_un a) (ad_double_plus_un b) = true.
+  Proof.
+    unfold ad_le in |- *. intros. rewrite nat_of_ad_double_plus_un. rewrite nat_of_ad_double_plus_un.
+    apply nat_le_correct. apply le_n_S. simpl in |- *. apply plus_le_compat. apply nat_le_complete.
+    assumption.
+    apply plus_le_compat. apply nat_le_complete. assumption.
+    apply le_n.
+  Qed.
+
+  Lemma ad_le_double_mono_conv :
+   forall a b:ad,
+     ad_le (ad_double a) (ad_double b) = true -> ad_le a b = true.
+  Proof.
+    unfold ad_le in |- *. intros a b. rewrite nat_of_ad_double. rewrite nat_of_ad_double. intro.
+    apply nat_le_correct. apply (mult_S_le_reg_l 1). apply nat_le_complete. assumption.
+  Qed.
+
+  Lemma ad_le_double_plus_un_mono_conv :
+   forall a b:ad,
+     ad_le (ad_double_plus_un a) (ad_double_plus_un b) = true ->
+     ad_le a b = true.
+  Proof.
+    unfold ad_le in |- *. intros a b. rewrite nat_of_ad_double_plus_un. rewrite nat_of_ad_double_plus_un.
+    intro. apply nat_le_correct. apply (mult_S_le_reg_l 1). apply le_S_n. apply nat_le_complete.
+    assumption.
+  Qed.
+
+  Lemma ad_lt_double_mono :
+   forall a b:ad,
+     ad_le a b = false -> ad_le (ad_double a) (ad_double b) = false.
+  Proof.
+    intros. elim (sumbool_of_bool (ad_le (ad_double a) (ad_double b))). intro H0.
+    rewrite (ad_le_double_mono_conv _ _ H0) in H. discriminate H.
+    trivial.
+  Qed.
+
+  Lemma ad_lt_double_plus_un_mono :
+   forall a b:ad,
+     ad_le a b = false ->
+     ad_le (ad_double_plus_un a) (ad_double_plus_un b) = false.
+  Proof.
+    intros. elim (sumbool_of_bool (ad_le (ad_double_plus_un a) (ad_double_plus_un b))). intro H0.
+    rewrite (ad_le_double_plus_un_mono_conv _ _ H0) in H. discriminate H.
+    trivial.
+  Qed.
+
+  Lemma ad_lt_double_mono_conv :
+   forall a b:ad,
+     ad_le (ad_double a) (ad_double b) = false -> ad_le a b = false.
+  Proof.
+    intros. elim (sumbool_of_bool (ad_le a b)). intro H0. rewrite (ad_le_double_mono _ _ H0) in H.
+    discriminate H.
+    trivial.
+  Qed.
+
+  Lemma ad_lt_double_plus_un_mono_conv :
+   forall a b:ad,
+     ad_le (ad_double_plus_un a) (ad_double_plus_un b) = false ->
+     ad_le a b = false.
+  Proof.
+    intros. elim (sumbool_of_bool (ad_le a b)). intro H0.
+    rewrite (ad_le_double_plus_un_mono _ _ H0) in H. discriminate H.
+    trivial.
+  Qed.
+
+  Lemma ad_alloc_opt_optimal_1 :
+   forall (m:Map A) (a:ad),
+     ad_le (ad_alloc_opt m) a = false -> {y : A | MapGet A m a = SOME A y}.
+  Proof.
+    induction m as [| a y| m0 H m1 H0]. simpl in |- *. unfold ad_le in |- *. simpl in |- *. intros. discriminate H.
+    simpl in |- *. intros b H. elim (sumbool_of_bool (ad_eq a ad_z)). intro H0. rewrite H0 in H.
+    unfold ad_le in H. cut (ad_z = b). intro. split with y. rewrite <- H1. rewrite H0. reflexivity.
+    rewrite <- (ad_of_nat_of_ad b).
+    rewrite <- (le_n_O_eq _ (le_S_n _ _ (nat_le_complete_conv _ _ H))). reflexivity.
+    intro H0. rewrite H0 in H. discriminate H.
+    intros. simpl in H1. elim (ad_double_or_double_plus_un a). intro H2. elim H2. intros a0 H3.
+    rewrite H3 in H1. elim (H _ (ad_lt_double_mono_conv _ _ (ad_min_lt_3 _ _ _ H1))). intros y H4.
+    split with y. rewrite H3. rewrite MapGet_M2_bit_0_0. rewrite ad_double_div_2. assumption.
+    apply ad_double_bit_0.
+    intro H2. elim H2. intros a0 H3. rewrite H3 in H1.
+    elim (H0 _ (ad_lt_double_plus_un_mono_conv _ _ (ad_min_lt_4 _ _ _ H1))). intros y H4.
+    split with y. rewrite H3. rewrite MapGet_M2_bit_0_1. rewrite ad_double_plus_un_div_2.
+    assumption.
+    apply ad_double_plus_un_bit_0.
+  Qed.
+
+  Lemma ad_alloc_opt_optimal :
+   forall (m:Map A) (a:ad),
+     ad_le (ad_alloc_opt m) a = false -> in_dom A a m = true.
+  Proof.
+    intros. unfold in_dom in |- *. elim (ad_alloc_opt_optimal_1 m a H). intros y H0. rewrite H0.
+    reflexivity.
+  Qed.
+
+End AdAlloc.
diff --git a/theories/IntMap/Addec.v b/theories/IntMap/Addec.v
new file mode 100644
index 00000000..7dba9ef6
--- /dev/null
+++ b/theories/IntMap/Addec.v
@@ -0,0 +1,193 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Addec.v,v 1.7.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+(** Equality on adresses *)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import ZArith.
+Require Import Addr.
+
+Fixpoint ad_eq_1 (p1 p2:positive) {struct p2} : bool :=
+  match p1, p2 with
+  | xH, xH => true
+  | xO p'1, xO p'2 => ad_eq_1 p'1 p'2
+  | xI p'1, xI p'2 => ad_eq_1 p'1 p'2
+  | _, _ => false
+  end.
+
+Definition ad_eq (a a':ad) :=
+  match a, a' with
+  | ad_z, ad_z => true
+  | ad_x p, ad_x p' => ad_eq_1 p p'
+  | _, _ => false
+  end.
+
+Lemma ad_eq_correct : forall a:ad, ad_eq a a = true.
+Proof.
+  destruct a; trivial.
+  induction p; trivial.
+Qed.
+
+Lemma ad_eq_complete : forall a a':ad, ad_eq a a' = true -> a = a'.
+Proof.
+  destruct a. destruct a'; trivial. destruct p.
+  discriminate 1.
+  discriminate 1.
+  discriminate 1.
+  destruct a'. intros. discriminate H.
+  unfold ad_eq in |- *. intros. cut (p = p0). intros. rewrite H0. reflexivity.
+  generalize dependent p0.
+  induction p as [p IHp| p IHp| ]. destruct p0; intro H.
+  rewrite (IHp p0). reflexivity.
+  exact H.
+  discriminate H.
+  discriminate H.
+  destruct p0; intro H. discriminate H.
+  rewrite (IHp p0 H). reflexivity.
+  discriminate H.
+  destruct p0 as [p| p| ]; intro H. discriminate H.
+  discriminate H.
+  trivial.
+Qed.
+
+Lemma ad_eq_comm : forall a a':ad, ad_eq a a' = ad_eq a' a.
+Proof.
+  intros. cut (forall b b':bool, ad_eq a a' = b -> ad_eq a' a = b' -> b = b').
+  intros. apply H. reflexivity.
+  reflexivity.
+  destruct b. intros. cut (a = a').
+  intro. rewrite H1 in H0. rewrite (ad_eq_correct a') in H0. exact H0.
+  apply ad_eq_complete. exact H.
+  destruct b'. intros. cut (a' = a).
+  intro. rewrite H1 in H. rewrite H1 in H0. rewrite <- H. exact H0.
+  apply ad_eq_complete. exact H0.
+  trivial.
+Qed.
+
+Lemma ad_xor_eq_true :
+ forall a a':ad, ad_xor a a' = ad_z -> ad_eq a a' = true.
+Proof.
+  intros. rewrite (ad_xor_eq a a' H). apply ad_eq_correct.
+Qed.
+
+Lemma ad_xor_eq_false :
+ forall (a a':ad) (p:positive), ad_xor a a' = ad_x p -> ad_eq a a' = false.
+Proof.
+  intros. elim (sumbool_of_bool (ad_eq a a')). intro H0.
+  rewrite (ad_eq_complete a a' H0) in H. rewrite (ad_xor_nilpotent a') in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma ad_bit_0_1_not_double :
+ forall a:ad,
+   ad_bit_0 a = true -> forall a0:ad, ad_eq (ad_double a0) a = false.
+Proof.
+  intros. elim (sumbool_of_bool (ad_eq (ad_double a0) a)). intro H0.
+  rewrite <- (ad_eq_complete _ _ H0) in H. rewrite (ad_double_bit_0 a0) in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma ad_not_div_2_not_double :
+ forall a a0:ad,
+   ad_eq (ad_div_2 a) a0 = false -> ad_eq a (ad_double a0) = false.
+Proof.
+  intros. elim (sumbool_of_bool (ad_eq (ad_double a0) a)). intro H0.
+  rewrite <- (ad_eq_complete _ _ H0) in H. rewrite (ad_double_div_2 a0) in H.
+  rewrite (ad_eq_correct a0) in H. discriminate H.
+  intro. rewrite ad_eq_comm. assumption.
+Qed.
+
+Lemma ad_bit_0_0_not_double_plus_un :
+ forall a:ad,
+   ad_bit_0 a = false -> forall a0:ad, ad_eq (ad_double_plus_un a0) a = false.
+Proof.
+  intros. elim (sumbool_of_bool (ad_eq (ad_double_plus_un a0) a)). intro H0.
+  rewrite <- (ad_eq_complete _ _ H0) in H. rewrite (ad_double_plus_un_bit_0 a0) in H.
+  discriminate H.
+  trivial.
+Qed.
+
+Lemma ad_not_div_2_not_double_plus_un :
+ forall a a0:ad,
+   ad_eq (ad_div_2 a) a0 = false -> ad_eq (ad_double_plus_un a0) a = false.
+Proof.
+  intros. elim (sumbool_of_bool (ad_eq a (ad_double_plus_un a0))). intro H0.
+  rewrite (ad_eq_complete _ _ H0) in H. rewrite (ad_double_plus_un_div_2 a0) in H.
+  rewrite (ad_eq_correct a0) in H. discriminate H.
+  intro H0. rewrite ad_eq_comm. assumption.
+Qed.
+
+Lemma ad_bit_0_neq :
+ forall a a':ad,
+   ad_bit_0 a = false -> ad_bit_0 a' = true -> ad_eq a a' = false.
+Proof.
+  intros. elim (sumbool_of_bool (ad_eq a a')). intro H1. rewrite (ad_eq_complete _ _ H1) in H.
+  rewrite H in H0. discriminate H0.
+  trivial.
+Qed.
+
+Lemma ad_div_eq :
+ forall a a':ad, ad_eq a a' = true -> ad_eq (ad_div_2 a) (ad_div_2 a') = true.
+Proof.
+  intros. cut (a = a'). intros. rewrite H0. apply ad_eq_correct.
+  apply ad_eq_complete. exact H.
+Qed.
+
+Lemma ad_div_neq :
+ forall a a':ad,
+   ad_eq (ad_div_2 a) (ad_div_2 a') = false -> ad_eq a a' = false.
+Proof.
+  intros. elim (sumbool_of_bool (ad_eq a a')). intro H0.
+  rewrite (ad_eq_complete _ _ H0) in H. rewrite (ad_eq_correct (ad_div_2 a')) in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma ad_div_bit_eq :
+ forall a a':ad,
+   ad_bit_0 a = ad_bit_0 a' -> ad_div_2 a = ad_div_2 a' -> a = a'.
+Proof.
+  intros. apply ad_faithful. unfold eqf in |- *. destruct n.
+  rewrite ad_bit_0_correct. rewrite ad_bit_0_correct. assumption.
+  rewrite <- ad_div_2_correct. rewrite <- ad_div_2_correct.
+  rewrite H0. reflexivity.
+Qed.
+
+Lemma ad_div_bit_neq :
+ forall a a':ad,
+   ad_eq a a' = false ->
+   ad_bit_0 a = ad_bit_0 a' -> ad_eq (ad_div_2 a) (ad_div_2 a') = false.
+Proof.
+  intros. elim (sumbool_of_bool (ad_eq (ad_div_2 a) (ad_div_2 a'))). intro H1.
+  rewrite (ad_div_bit_eq _ _ H0 (ad_eq_complete _ _ H1)) in H.
+  rewrite (ad_eq_correct a') in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma ad_neq :
+ forall a a':ad,
+   ad_eq a a' = false ->
+   ad_bit_0 a = negb (ad_bit_0 a') \/
+   ad_eq (ad_div_2 a) (ad_div_2 a') = false.
+Proof.
+  intros. cut (ad_bit_0 a = ad_bit_0 a' \/ ad_bit_0 a = negb (ad_bit_0 a')).
+  intros. elim H0. intro. right. apply ad_div_bit_neq. assumption.
+  assumption.
+  intro. left. assumption.
+  case (ad_bit_0 a); case (ad_bit_0 a'); auto.
+Qed.
+
+Lemma ad_double_or_double_plus_un :
+ forall a:ad,
+   {a0 : ad | a = ad_double a0} + {a1 : ad | a = ad_double_plus_un a1}.
+Proof.
+  intro. elim (sumbool_of_bool (ad_bit_0 a)). intro H. right. split with (ad_div_2 a).
+  rewrite (ad_div_2_double_plus_un a H). reflexivity.
+  intro H. left. split with (ad_div_2 a). rewrite (ad_div_2_double a H). reflexivity.
+Qed.
\ No newline at end of file
diff --git a/theories/IntMap/Addr.v b/theories/IntMap/Addr.v
new file mode 100644
index 00000000..1370d72d
--- /dev/null
+++ b/theories/IntMap/Addr.v
@@ -0,0 +1,491 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Addr.v,v 1.8.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+(** Representation of adresses by the [positive] type of binary numbers *)
+
+Require Import Bool.
+Require Import ZArith.
+
+Inductive ad : Set :=
+  | ad_z : ad
+  | ad_x : positive -> ad.
+
+Lemma ad_sum : forall a:ad, {p : positive | a = ad_x p} + {a = ad_z}.
+Proof.
+  destruct a; auto.
+  left; exists p; trivial.
+Qed.
+
+Fixpoint p_xor (p p2:positive) {struct p} : ad :=
+  match p with
+  | xH =>
+      match p2 with
+      | xH => ad_z
+      | xO p'2 => ad_x (xI p'2)
+      | xI p'2 => ad_x (xO p'2)
+      end
+  | xO p' =>
+      match p2 with
+      | xH => ad_x (xI p')
+      | xO p'2 =>
+          match p_xor p' p'2 with
+          | ad_z => ad_z
+          | ad_x p'' => ad_x (xO p'')
+          end
+      | xI p'2 =>
+          match p_xor p' p'2 with
+          | ad_z => ad_x 1
+          | ad_x p'' => ad_x (xI p'')
+          end
+      end
+  | xI p' =>
+      match p2 with
+      | xH => ad_x (xO p')
+      | xO p'2 =>
+          match p_xor p' p'2 with
+          | ad_z => ad_x 1
+          | ad_x p'' => ad_x (xI p'')
+          end
+      | xI p'2 =>
+          match p_xor p' p'2 with
+          | ad_z => ad_z
+          | ad_x p'' => ad_x (xO p'')
+          end
+      end
+  end.
+
+Definition ad_xor (a a':ad) :=
+  match a with
+  | ad_z => a'
+  | ad_x p => match a' with
+              | ad_z => a
+              | ad_x p' => p_xor p p'
+              end
+  end.
+
+Lemma ad_xor_neutral_left : forall a:ad, ad_xor ad_z a = a.
+Proof.
+  trivial.
+Qed.
+
+Lemma ad_xor_neutral_right : forall a:ad, ad_xor a ad_z = a.
+Proof.
+  destruct a; trivial.
+Qed.
+
+Lemma ad_xor_comm : forall a a':ad, ad_xor a a' = ad_xor a' a.
+Proof.
+  destruct a; destruct a'; simpl in |- *; auto.
+  generalize p0; clear p0; induction p as [p Hrecp| p Hrecp| ]; simpl in |- *;
+   auto.
+  destruct p0; simpl in |- *; trivial; intros.
+  rewrite Hrecp; trivial.
+  rewrite Hrecp; trivial.
+  destruct p0; simpl in |- *; trivial; intros.
+  rewrite Hrecp; trivial.
+  rewrite Hrecp; trivial.
+  destruct p0 as [p| p| ]; simpl in |- *; auto.
+Qed.
+
+Lemma ad_xor_nilpotent : forall a:ad, ad_xor a a = ad_z.
+Proof.
+  destruct a; trivial.
+  simpl in |- *. induction p as [p IHp| p IHp| ]; trivial.
+  simpl in |- *. rewrite IHp; reflexivity.
+  simpl in |- *. rewrite IHp; reflexivity.
+Qed.
+
+Fixpoint ad_bit_1 (p:positive) : nat -> bool :=
+  match p with
+  | xH => fun n:nat => match n with
+                       | O => true
+                       | S _ => false
+                       end
+  | xO p =>
+      fun n:nat => match n with
+                   | O => false
+                   | S n' => ad_bit_1 p n'
+                   end
+  | xI p => fun n:nat => match n with
+                         | O => true
+                         | S n' => ad_bit_1 p n'
+                         end
+  end.
+
+Definition ad_bit (a:ad) :=
+  match a with
+  | ad_z => fun _:nat => false
+  | ad_x p => ad_bit_1 p
+  end.
+
+Definition eqf (f g:nat -> bool) := forall n:nat, f n = g n.
+
+Lemma ad_faithful_1 : forall a:ad, eqf (ad_bit ad_z) (ad_bit a) -> ad_z = a.
+Proof.
+  destruct a. trivial.
+  induction p as [p IHp| p IHp| ]; intro H. absurd (ad_z = ad_x p). discriminate.
+  exact (IHp (fun n:nat => H (S n))).
+  absurd (ad_z = ad_x p). discriminate.
+  exact (IHp (fun n:nat => H (S n))).
+  absurd (false = true). discriminate.
+  exact (H 0).
+Qed.
+
+Lemma ad_faithful_2 :
+ forall a:ad, eqf (ad_bit (ad_x 1)) (ad_bit a) -> ad_x 1 = a.
+Proof.
+  destruct a. intros. absurd (true = false). discriminate.
+  exact (H 0).
+  destruct p. intro H. absurd (ad_z = ad_x p). discriminate.
+  exact (ad_faithful_1 (ad_x p) (fun n:nat => H (S n))).
+  intros. absurd (true = false). discriminate.
+  exact (H 0).
+  trivial.
+Qed.
+
+Lemma ad_faithful_3 :
+ forall (a:ad) (p:positive),
+   (forall p':positive, eqf (ad_bit (ad_x p)) (ad_bit (ad_x p')) -> p = p') ->
+   eqf (ad_bit (ad_x (xO p))) (ad_bit a) -> ad_x (xO p) = a.
+Proof.
+  destruct a. intros. cut (eqf (ad_bit ad_z) (ad_bit (ad_x (xO p)))).
+  intro. rewrite (ad_faithful_1 (ad_x (xO p)) H1). reflexivity.
+  unfold eqf in |- *. intro. unfold eqf in H0. rewrite H0. reflexivity.
+  case p. intros. absurd (false = true). discriminate.
+  exact (H0 0).
+  intros. rewrite (H p0 (fun n:nat => H0 (S n))). reflexivity.
+  intros. absurd (false = true). discriminate.
+  exact (H0 0).
+Qed.
+
+Lemma ad_faithful_4 :
+ forall (a:ad) (p:positive),
+   (forall p':positive, eqf (ad_bit (ad_x p)) (ad_bit (ad_x p')) -> p = p') ->
+   eqf (ad_bit (ad_x (xI p))) (ad_bit a) -> ad_x (xI p) = a.
+Proof.
+  destruct a. intros. cut (eqf (ad_bit ad_z) (ad_bit (ad_x (xI p)))).
+  intro. rewrite (ad_faithful_1 (ad_x (xI p)) H1). reflexivity.
+  unfold eqf in |- *. intro. unfold eqf in H0. rewrite H0. reflexivity.
+  case p. intros. rewrite (H p0 (fun n:nat => H0 (S n))). reflexivity.
+  intros. absurd (true = false). discriminate.
+  exact (H0 0).
+  intros. absurd (ad_z = ad_x p0). discriminate.
+  cut (eqf (ad_bit (ad_x 1)) (ad_bit (ad_x (xI p0)))).
+  intro. exact (ad_faithful_1 (ad_x p0) (fun n:nat => H1 (S n))).
+  unfold eqf in |- *. unfold eqf in H0. intro. rewrite H0. reflexivity.
+Qed.
+
+Lemma ad_faithful : forall a a':ad, eqf (ad_bit a) (ad_bit a') -> a = a'.
+Proof.
+  destruct a. exact ad_faithful_1.
+  induction p. intros a' H. apply ad_faithful_4. intros. cut (ad_x p = ad_x p').
+  intro. inversion H1. reflexivity.
+  exact (IHp (ad_x p') H0).
+  assumption.
+  intros. apply ad_faithful_3. intros. cut (ad_x p = ad_x p'). intro. inversion H1. reflexivity.
+  exact (IHp (ad_x p') H0).
+  assumption.
+  exact ad_faithful_2.
+Qed.
+
+Definition adf_xor (f g:nat -> bool) (n:nat) := xorb (f n) (g n).
+
+Lemma ad_xor_sem_1 : forall a':ad, ad_bit (ad_xor ad_z a') 0 = ad_bit a' 0.
+Proof.
+  trivial.
+Qed.
+
+Lemma ad_xor_sem_2 :
+ forall a':ad, ad_bit (ad_xor (ad_x 1) a') 0 = negb (ad_bit a' 0).
+Proof.
+  intro. case a'. trivial.
+  simpl in |- *. intro. 
+  case p; trivial.
+Qed.
+
+Lemma ad_xor_sem_3 :
+ forall (p:positive) (a':ad),
+   ad_bit (ad_xor (ad_x (xO p)) a') 0 = ad_bit a' 0.
+Proof.
+  intros. case a'. trivial.
+  simpl in |- *. intro. 
+  case p0; trivial. intro. 
+  case (p_xor p p1); trivial.
+  intro. case (p_xor p p1); trivial.
+Qed.
+
+Lemma ad_xor_sem_4 :
+ forall (p:positive) (a':ad),
+   ad_bit (ad_xor (ad_x (xI p)) a') 0 = negb (ad_bit a' 0).
+Proof.
+  intros. case a'. trivial.
+  simpl in |- *. intro. case p0; trivial. intro. 
+  case (p_xor p p1); trivial.
+  intro. 
+  case (p_xor p p1); trivial.
+Qed.
+
+Lemma ad_xor_sem_5 :
+ forall a a':ad, ad_bit (ad_xor a a') 0 = adf_xor (ad_bit a) (ad_bit a') 0.
+Proof.
+  destruct a. intro. change (ad_bit a' 0 = xorb false (ad_bit a' 0)) in |- *. rewrite false_xorb. trivial.
+  case p. exact ad_xor_sem_4.
+  intros. change (ad_bit (ad_xor (ad_x (xO p0)) a') 0 = xorb false (ad_bit a' 0))
+  in |- *.
+  rewrite false_xorb. apply ad_xor_sem_3. exact ad_xor_sem_2.
+Qed.
+
+Lemma ad_xor_sem_6 :
+ forall n:nat,
+   (forall a a':ad, ad_bit (ad_xor a a') n = adf_xor (ad_bit a) (ad_bit a') n) ->
+   forall a a':ad,
+     ad_bit (ad_xor a a') (S n) = adf_xor (ad_bit a) (ad_bit a') (S n).
+Proof.
+  intros. case a. unfold adf_xor in |- *. unfold ad_bit at 2 in |- *. rewrite false_xorb. reflexivity.
+  case a'. unfold adf_xor in |- *. unfold ad_bit at 3 in |- *. intro. rewrite xorb_false. reflexivity.
+  intros. case p0. case p. intros.
+  change
+    (ad_bit (ad_xor (ad_x (xI p2)) (ad_x (xI p1))) (S n) =
+     adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) 
+   in |- *.
+  rewrite <- H. simpl in |- *. 
+  case (p_xor p2 p1); trivial.
+  intros.
+  change
+    (ad_bit (ad_xor (ad_x (xI p2)) (ad_x (xO p1))) (S n) =
+     adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) 
+   in |- *.
+  rewrite <- H. simpl in |- *. 
+  case (p_xor p2 p1); trivial.
+  intro. unfold adf_xor in |- *. unfold ad_bit at 3 in |- *. unfold ad_bit_1 in |- *. rewrite xorb_false. reflexivity.
+  case p. intros.
+  change
+    (ad_bit (ad_xor (ad_x (xO p2)) (ad_x (xI p1))) (S n) =
+     adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) 
+   in |- *.
+  rewrite <- H. simpl in |- *. 
+  case (p_xor p2 p1); trivial.
+  intros.
+  change
+    (ad_bit (ad_xor (ad_x (xO p2)) (ad_x (xO p1))) (S n) =
+     adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) 
+   in |- *.
+  rewrite <- H. simpl in |- *. 
+  case (p_xor p2 p1); trivial.
+  intro. unfold adf_xor in |- *. unfold ad_bit at 3 in |- *. unfold ad_bit_1 in |- *. rewrite xorb_false. reflexivity.
+  unfold adf_xor in |- *. unfold ad_bit at 2 in |- *. unfold ad_bit_1 in |- *. rewrite false_xorb. simpl in |- *.   case p; trivial.
+Qed.
+
+Lemma ad_xor_semantics :
+ forall a a':ad, eqf (ad_bit (ad_xor a a')) (adf_xor (ad_bit a) (ad_bit a')).
+Proof.
+  unfold eqf in |- *. intros. generalize a a'. elim n. exact ad_xor_sem_5.
+  exact ad_xor_sem_6.
+Qed.
+
+Lemma eqf_sym : forall f f':nat -> bool, eqf f f' -> eqf f' f.
+Proof.
+  unfold eqf in |- *. intros. rewrite H. reflexivity.
+Qed.
+
+Lemma eqf_refl : forall f:nat -> bool, eqf f f.
+Proof.
+  unfold eqf in |- *. trivial.
+Qed.
+
+Lemma eqf_trans :
+ forall f f' f'':nat -> bool, eqf f f' -> eqf f' f'' -> eqf f f''.
+Proof.
+  unfold eqf in |- *. intros. rewrite H. exact (H0 n).
+Qed.
+
+Lemma adf_xor_eq :
+ forall f f':nat -> bool, eqf (adf_xor f f') (fun n:nat => false) -> eqf f f'.
+Proof.
+  unfold eqf in |- *. unfold adf_xor in |- *. intros. apply xorb_eq. apply H.
+Qed.
+
+Lemma ad_xor_eq : forall a a':ad, ad_xor a a' = ad_z -> a = a'.
+Proof.
+  intros. apply ad_faithful. apply adf_xor_eq. apply eqf_trans with (f' := ad_bit (ad_xor a a')).
+  apply eqf_sym. apply ad_xor_semantics.
+  rewrite H. unfold eqf in |- *. trivial.
+Qed.
+
+Lemma adf_xor_assoc :
+ forall f f' f'':nat -> bool,
+   eqf (adf_xor (adf_xor f f') f'') (adf_xor f (adf_xor f' f'')).
+Proof.
+  unfold eqf in |- *. unfold adf_xor in |- *. intros. apply xorb_assoc.
+Qed.
+
+Lemma eqf_xor_1 :
+ forall f f' f'' f''':nat -> bool,
+   eqf f f' -> eqf f'' f''' -> eqf (adf_xor f f'') (adf_xor f' f''').
+Proof.
+  unfold eqf in |- *. intros. unfold adf_xor in |- *. rewrite H. rewrite H0. reflexivity.
+Qed.
+
+Lemma ad_xor_assoc :
+ forall a a' a'':ad, ad_xor (ad_xor a a') a'' = ad_xor a (ad_xor a' a'').
+Proof.
+  intros. apply ad_faithful.
+  apply eqf_trans with
+   (f' := adf_xor (adf_xor (ad_bit a) (ad_bit a')) (ad_bit a'')).
+  apply eqf_trans with (f' := adf_xor (ad_bit (ad_xor a a')) (ad_bit a'')).
+  apply ad_xor_semantics.
+  apply eqf_xor_1. apply ad_xor_semantics.
+  apply eqf_refl.
+  apply eqf_trans with
+   (f' := adf_xor (ad_bit a) (adf_xor (ad_bit a') (ad_bit a''))).
+  apply adf_xor_assoc.
+  apply eqf_trans with (f' := adf_xor (ad_bit a) (ad_bit (ad_xor a' a''))).
+  apply eqf_xor_1. apply eqf_refl.
+  apply eqf_sym. apply ad_xor_semantics.
+  apply eqf_sym. apply ad_xor_semantics.
+Qed.
+
+Definition ad_double (a:ad) :=
+  match a with
+  | ad_z => ad_z
+  | ad_x p => ad_x (xO p)
+  end.
+
+Definition ad_double_plus_un (a:ad) :=
+  match a with
+  | ad_z => ad_x 1
+  | ad_x p => ad_x (xI p)
+  end.
+
+Definition ad_div_2 (a:ad) :=
+  match a with
+  | ad_z => ad_z
+  | ad_x xH => ad_z
+  | ad_x (xO p) => ad_x p
+  | ad_x (xI p) => ad_x p
+  end.
+
+Lemma ad_double_div_2 : forall a:ad, ad_div_2 (ad_double a) = a.
+Proof.
+  destruct a; trivial.
+Qed.
+
+Lemma ad_double_plus_un_div_2 :
+ forall a:ad, ad_div_2 (ad_double_plus_un a) = a.
+Proof.
+  destruct a; trivial.
+Qed.
+
+Lemma ad_double_inj : forall a0 a1:ad, ad_double a0 = ad_double a1 -> a0 = a1.
+Proof.
+  intros. rewrite <- (ad_double_div_2 a0). rewrite H. apply ad_double_div_2.
+Qed.
+
+Lemma ad_double_plus_un_inj :
+ forall a0 a1:ad, ad_double_plus_un a0 = ad_double_plus_un a1 -> a0 = a1.
+Proof.
+  intros. rewrite <- (ad_double_plus_un_div_2 a0). rewrite H. apply ad_double_plus_un_div_2.
+Qed.
+
+Definition ad_bit_0 (a:ad) :=
+  match a with
+  | ad_z => false
+  | ad_x (xO _) => false
+  | _ => true
+  end.
+
+Lemma ad_double_bit_0 : forall a:ad, ad_bit_0 (ad_double a) = false.
+Proof.
+  destruct a; trivial.
+Qed.
+
+Lemma ad_double_plus_un_bit_0 :
+ forall a:ad, ad_bit_0 (ad_double_plus_un a) = true.
+Proof.
+  destruct a; trivial.
+Qed.
+
+Lemma ad_div_2_double :
+ forall a:ad, ad_bit_0 a = false -> ad_double (ad_div_2 a) = a.
+Proof.
+  destruct a. trivial. destruct p. intro H. discriminate H.
+  intros. reflexivity.
+  intro H. discriminate H.
+Qed.
+
+Lemma ad_div_2_double_plus_un :
+ forall a:ad, ad_bit_0 a = true -> ad_double_plus_un (ad_div_2 a) = a.
+Proof.
+  destruct a. intro. discriminate H.
+  destruct p. intros. reflexivity.
+  intro H. discriminate H.
+  intro. reflexivity.
+Qed.
+
+Lemma ad_bit_0_correct : forall a:ad, ad_bit a 0 = ad_bit_0 a.
+Proof.
+  destruct a; trivial.
+  destruct p; trivial.
+Qed.
+
+Lemma ad_div_2_correct :
+ forall (a:ad) (n:nat), ad_bit (ad_div_2 a) n = ad_bit a (S n).
+Proof.
+  destruct a; trivial.
+  destruct p; trivial.
+Qed.
+
+Lemma ad_xor_bit_0 :
+ forall a a':ad, ad_bit_0 (ad_xor a a') = xorb (ad_bit_0 a) (ad_bit_0 a').
+Proof.
+  intros. rewrite <- ad_bit_0_correct. rewrite (ad_xor_semantics a a' 0).
+  unfold adf_xor in |- *. rewrite ad_bit_0_correct. rewrite ad_bit_0_correct. reflexivity.
+Qed.
+
+Lemma ad_xor_div_2 :
+ forall a a':ad, ad_div_2 (ad_xor a a') = ad_xor (ad_div_2 a) (ad_div_2 a').
+Proof.
+  intros. apply ad_faithful. unfold eqf in |- *. intro.
+  rewrite (ad_xor_semantics (ad_div_2 a) (ad_div_2 a') n).
+  rewrite ad_div_2_correct.
+  rewrite (ad_xor_semantics a a' (S n)).
+  unfold adf_xor in |- *. rewrite ad_div_2_correct. rewrite ad_div_2_correct.
+  reflexivity.
+Qed.
+
+Lemma ad_neg_bit_0 :
+ forall a a':ad,
+   ad_bit_0 (ad_xor a a') = true -> ad_bit_0 a = negb (ad_bit_0 a').
+Proof.
+  intros. rewrite <- true_xorb. rewrite <- H. rewrite ad_xor_bit_0.
+  rewrite xorb_assoc. rewrite xorb_nilpotent. rewrite xorb_false. reflexivity.
+Qed.
+
+Lemma ad_neg_bit_0_1 :
+ forall a a':ad, ad_xor a a' = ad_x 1 -> ad_bit_0 a = negb (ad_bit_0 a').
+Proof.
+  intros. apply ad_neg_bit_0. rewrite H. reflexivity.
+Qed.
+
+Lemma ad_neg_bit_0_2 :
+ forall (a a':ad) (p:positive),
+   ad_xor a a' = ad_x (xI p) -> ad_bit_0 a = negb (ad_bit_0 a').
+Proof.
+  intros. apply ad_neg_bit_0. rewrite H. reflexivity.
+Qed.
+
+Lemma ad_same_bit_0 :
+ forall (a a':ad) (p:positive),
+   ad_xor a a' = ad_x (xO p) -> ad_bit_0 a = ad_bit_0 a'.
+Proof.
+  intros. rewrite <- (xorb_false (ad_bit_0 a)). cut (ad_bit_0 (ad_x (xO p)) = false).
+  intro. rewrite <- H0. rewrite <- H. rewrite ad_xor_bit_0. rewrite <- xorb_assoc.
+  rewrite xorb_nilpotent. rewrite false_xorb. reflexivity.
+  reflexivity.
+Qed.
\ No newline at end of file
diff --git a/theories/IntMap/Adist.v b/theories/IntMap/Adist.v
new file mode 100644
index 00000000..cdb4c885
--- /dev/null
+++ b/theories/IntMap/Adist.v
@@ -0,0 +1,336 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	     $Id: Adist.v,v 1.9.2.1 2004/07/16 19:31:04 herbelin Exp $	      i*)
+
+Require Import Bool.
+Require Import ZArith.
+Require Import Arith.
+Require Import Min.
+Require Import Addr.
+
+Fixpoint ad_plength_1 (p:positive) : nat :=
+  match p with
+  | xH => 0
+  | xI _ => 0
+  | xO p' => S (ad_plength_1 p')
+  end.
+
+Inductive natinf : Set :=
+  | infty : natinf
+  | ni : nat -> natinf.
+
+Definition ad_plength (a:ad) :=
+  match a with
+  | ad_z => infty
+  | ad_x p => ni (ad_plength_1 p)
+  end.
+
+Lemma ad_plength_infty : forall a:ad, ad_plength a = infty -> a = ad_z.
+Proof.
+  simple induction a; trivial. 
+  unfold ad_plength in |- *; intros; discriminate H.
+Qed.
+
+Lemma ad_plength_zeros :
+ forall (a:ad) (n:nat),
+   ad_plength a = ni n -> forall k:nat, k < n -> ad_bit a k = false.
+Proof.
+  simple induction a; trivial. 
+  simple induction p. simple induction n. intros. inversion H1.
+  simple induction k. simpl in H1. discriminate H1.
+  intros. simpl in H1. discriminate H1.
+  simple induction k. trivial.
+  generalize H0. case n. intros. inversion H3.
+  intros. simpl in |- *. unfold ad_bit in H. apply (H n0). simpl in H1. inversion H1. reflexivity.
+  exact (lt_S_n n1 n0 H3).
+  simpl in |- *. intros n H. inversion H. intros. inversion H0.
+Qed.
+
+Lemma ad_plength_one :
+ forall (a:ad) (n:nat), ad_plength a = ni n -> ad_bit a n = true.
+Proof.
+  simple induction a. intros. inversion H.
+  simple induction p. intros. simpl in H0. inversion H0. reflexivity.
+  intros. simpl in H0. inversion H0. simpl in |- *. unfold ad_bit in H. apply H. reflexivity.
+  intros. simpl in H. inversion H. reflexivity.
+Qed.
+
+Lemma ad_plength_first_one :
+ forall (a:ad) (n:nat),
+   (forall k:nat, k < n -> ad_bit a k = false) ->
+   ad_bit a n = true -> ad_plength a = ni n.
+Proof.
+  simple induction a. intros. simpl in H0. discriminate H0.
+  simple induction p. intros. generalize H0. case n. intros. reflexivity.
+  intros. absurd (ad_bit (ad_x (xI p0)) 0 = false). trivial with bool.
+  auto with bool arith.
+  intros. generalize H0 H1. case n. intros. simpl in H3. discriminate H3.
+  intros. simpl in |- *. unfold ad_plength in H.
+  cut (ni (ad_plength_1 p0) = ni n0). intro. inversion H4. reflexivity.
+  apply H. intros. change (ad_bit (ad_x (xO p0)) (S k) = false) in |- *. apply H2. apply lt_n_S. exact H4.
+  exact H3.
+  intro. case n. trivial.
+  intros. simpl in H0. discriminate H0.
+Qed.
+
+Definition ni_min (d d':natinf) :=
+  match d with
+  | infty => d'
+  | ni n => match d' with
+            | infty => d
+            | ni n' => ni (min n n')
+            end
+  end.
+
+Lemma ni_min_idemp : forall d:natinf, ni_min d d = d.
+Proof.
+  simple induction d; trivial.
+  unfold ni_min in |- *.
+  simple induction n; trivial.
+  intros.
+  simpl in |- *.
+  inversion H.
+  rewrite H1.
+  rewrite H1.
+  reflexivity.
+Qed.
+
+Lemma ni_min_comm : forall d d':natinf, ni_min d d' = ni_min d' d.
+Proof.
+  simple induction d. simple induction d'; trivial.
+  simple induction d'; trivial. elim n. simple induction n0; trivial.
+  intros. elim n1; trivial. intros. unfold ni_min in H. cut (min n0 n2 = min n2 n0).
+  intro. unfold ni_min in |- *. simpl in |- *. rewrite H1. reflexivity.
+  cut (ni (min n0 n2) = ni (min n2 n0)). intros.
+  inversion H1; trivial.
+  exact (H n2).
+Qed.
+
+Lemma ni_min_assoc :
+ forall d d' d'':natinf, ni_min (ni_min d d') d'' = ni_min d (ni_min d' d'').
+Proof.
+  simple induction d; trivial. simple induction d'; trivial. 
+  simple induction d''; trivial.
+  unfold ni_min in |- *. intro. cut (min (min n n0) n1 = min n (min n0 n1)).
+  intro. rewrite H. reflexivity.
+  generalize n0 n1. elim n; trivial. 
+  simple induction n3; trivial. simple induction n5; trivial.
+  intros. simpl in |- *. auto.
+Qed.
+
+Lemma ni_min_O_l : forall d:natinf, ni_min (ni 0) d = ni 0.
+Proof.
+  simple induction d; trivial.
+Qed.
+
+Lemma ni_min_O_r : forall d:natinf, ni_min d (ni 0) = ni 0.
+Proof.
+  intros. rewrite ni_min_comm. apply ni_min_O_l.
+Qed.
+
+Lemma ni_min_inf_l : forall d:natinf, ni_min infty d = d.
+Proof.
+  trivial.
+Qed.
+
+Lemma ni_min_inf_r : forall d:natinf, ni_min d infty = d.
+Proof.
+  simple induction d; trivial.
+Qed.
+
+Definition ni_le (d d':natinf) := ni_min d d' = d.
+
+Lemma ni_le_refl : forall d:natinf, ni_le d d.
+Proof.
+  exact ni_min_idemp.
+Qed.
+
+Lemma ni_le_antisym : forall d d':natinf, ni_le d d' -> ni_le d' d -> d = d'.
+Proof.
+  unfold ni_le in |- *. intros d d'. rewrite ni_min_comm. intro H. rewrite H. trivial.
+Qed.
+
+Lemma ni_le_trans :
+ forall d d' d'':natinf, ni_le d d' -> ni_le d' d'' -> ni_le d d''.
+Proof.
+  unfold ni_le in |- *. intros. rewrite <- H. rewrite ni_min_assoc. rewrite H0. reflexivity.
+Qed.
+
+Lemma ni_le_min_1 : forall d d':natinf, ni_le (ni_min d d') d.
+Proof.
+  unfold ni_le in |- *. intros. rewrite (ni_min_comm d d'). rewrite ni_min_assoc.
+  rewrite ni_min_idemp. reflexivity.
+Qed.
+
+Lemma ni_le_min_2 : forall d d':natinf, ni_le (ni_min d d') d'.
+Proof.
+  unfold ni_le in |- *. intros. rewrite ni_min_assoc. rewrite ni_min_idemp. reflexivity.
+Qed.
+
+Lemma ni_min_case : forall d d':natinf, ni_min d d' = d \/ ni_min d d' = d'.
+Proof.
+  simple induction d. intro. right. exact (ni_min_inf_l d').
+  simple induction d'. left. exact (ni_min_inf_r (ni n)).
+  unfold ni_min in |- *. cut (forall n0:nat, min n n0 = n \/ min n n0 = n0).
+  intros. case (H n0). intro. left. rewrite H0. reflexivity.
+  intro. right. rewrite H0. reflexivity.
+  elim n. intro. left. reflexivity.
+  simple induction n1. right. reflexivity.
+  intros. case (H n2). intro. left. simpl in |- *. rewrite H1. reflexivity.
+  intro. right. simpl in |- *. rewrite H1. reflexivity.
+Qed.
+
+Lemma ni_le_total : forall d d':natinf, ni_le d d' \/ ni_le d' d.
+Proof.
+  unfold ni_le in |- *. intros. rewrite (ni_min_comm d' d). apply ni_min_case.
+Qed.
+
+Lemma ni_le_min_induc :
+ forall d d' dm:natinf,
+   ni_le dm d ->
+   ni_le dm d' ->
+   (forall d'':natinf, ni_le d'' d -> ni_le d'' d' -> ni_le d'' dm) ->
+   ni_min d d' = dm.
+Proof.
+  intros. case (ni_min_case d d'). intro. rewrite H2.
+  apply ni_le_antisym. apply H1. apply ni_le_refl.
+  exact H2.
+  exact H.
+  intro. rewrite H2. apply ni_le_antisym. apply H1. unfold ni_le in |- *. rewrite ni_min_comm. exact H2.
+  apply ni_le_refl.
+  exact H0.
+Qed.
+
+Lemma le_ni_le : forall m n:nat, m <= n -> ni_le (ni m) (ni n).
+Proof.
+  cut (forall m n:nat, m <= n -> min m n = m).
+  intros. unfold ni_le, ni_min in |- *. rewrite (H m n H0). reflexivity.
+  simple induction m. trivial.
+  simple induction n0. intro. inversion H0.
+  intros. simpl in |- *. rewrite (H n1 (le_S_n n n1 H1)). reflexivity.
+Qed.
+
+Lemma ni_le_le : forall m n:nat, ni_le (ni m) (ni n) -> m <= n.
+Proof.
+  unfold ni_le in |- *. unfold ni_min in |- *. intros. inversion H. apply le_min_r.
+Qed.
+
+Lemma ad_plength_lb :
+ forall (a:ad) (n:nat),
+   (forall k:nat, k < n -> ad_bit a k = false) -> ni_le (ni n) (ad_plength a).
+Proof.
+  simple induction a. intros. exact (ni_min_inf_r (ni n)).
+  intros. unfold ad_plength in |- *. apply le_ni_le. case (le_or_lt n (ad_plength_1 p)). trivial.
+  intro. absurd (ad_bit (ad_x p) (ad_plength_1 p) = false).
+  rewrite
+   (ad_plength_one (ad_x p) (ad_plength_1 p)
+      (refl_equal (ad_plength (ad_x p)))).
+  discriminate.
+  apply H. exact H0.
+Qed.
+
+Lemma ad_plength_ub :
+ forall (a:ad) (n:nat), ad_bit a n = true -> ni_le (ad_plength a) (ni n).
+Proof.
+  simple induction a. intros. discriminate H.
+  intros. unfold ad_plength in |- *. apply le_ni_le. case (le_or_lt (ad_plength_1 p) n). trivial.
+  intro. absurd (ad_bit (ad_x p) n = true).
+  rewrite
+   (ad_plength_zeros (ad_x p) (ad_plength_1 p)
+      (refl_equal (ad_plength (ad_x p))) n H0).
+  discriminate.
+  exact H.
+Qed.
+
+
+(** We define an ultrametric distance between addresses: 
+    $d(a,a')=1/2^pd(a,a')$, 
+    where $pd(a,a')$ is the number of identical bits at the beginning 
+    of $a$ and $a'$ (infinity if $a=a'$).  
+    Instead of working with $d$, we work with $pd$, namely
+    [ad_pdist]: *)
+
+Definition ad_pdist (a a':ad) := ad_plength (ad_xor a a').
+
+(** d is a distance, so $d(a,a')=0$ iff $a=a'$; this means that
+    $pd(a,a')=infty$ iff $a=a'$: *)
+
+Lemma ad_pdist_eq_1 : forall a:ad, ad_pdist a a = infty.
+Proof.
+  intros. unfold ad_pdist in |- *. rewrite ad_xor_nilpotent. reflexivity.
+Qed.
+
+Lemma ad_pdist_eq_2 : forall a a':ad, ad_pdist a a' = infty -> a = a'.
+Proof.
+  intros. apply ad_xor_eq. apply ad_plength_infty. exact H.
+Qed.
+
+(** $d$ is a distance, so $d(a,a')=d(a',a)$: *)
+
+Lemma ad_pdist_comm : forall a a':ad, ad_pdist a a' = ad_pdist a' a.
+Proof.
+  unfold ad_pdist in |- *. intros. rewrite ad_xor_comm. reflexivity.
+Qed.
+
+(** $d$ is an ultrametric distance, that is, not only $d(a,a')\leq
+    d(a,a'')+d(a'',a')$,
+  but in fact $d(a,a')\leq max(d(a,a''),d(a'',a'))$.
+  This means that $min(pd(a,a''),pd(a'',a'))<=pd(a,a')$ (lemma [ad_pdist_ultra] below).
+  This follows from the fact that $a ~Ra~|a| = 1/2^{\texttt{ad\_plength}}(a))$
+  is an ultrametric norm, i.e. that $|a-a'| \leq max (|a-a''|, |a''-a'|)$,
+  or equivalently that $|a+b|<=max(|a|,|b|)$, i.e. that
+  min $(\texttt{ad\_plength}(a), \texttt{ad\_plength}(b)) \leq 
+  \texttt{ad\_plength} (a~\texttt{xor}~ b)$
+  (lemma [ad_plength_ultra]).
+*)
+
+Lemma ad_plength_ultra_1 :
+ forall a a':ad,
+   ni_le (ad_plength a) (ad_plength a') ->
+   ni_le (ad_plength a) (ad_plength (ad_xor a a')).
+Proof.
+  simple induction a. intros. unfold ni_le in H. unfold ad_plength at 1 3 in H.
+  rewrite (ni_min_inf_l (ad_plength a')) in H.
+  rewrite (ad_plength_infty a' H). simpl in |- *. apply ni_le_refl.
+  intros. unfold ad_plength at 1 in |- *. apply ad_plength_lb. intros.
+  cut (forall a'':ad, ad_xor (ad_x p) a' = a'' -> ad_bit a'' k = false).
+  intros. apply H1. reflexivity.
+  intro a''. case a''. intro. reflexivity.
+  intros. rewrite <- H1. rewrite (ad_xor_semantics (ad_x p) a' k). unfold adf_xor in |- *.
+  rewrite
+   (ad_plength_zeros (ad_x p) (ad_plength_1 p)
+      (refl_equal (ad_plength (ad_x p))) k H0).
+  generalize H. case a'. trivial.
+  intros. cut (ad_bit (ad_x p1) k = false). intros. rewrite H3. reflexivity.
+  apply ad_plength_zeros with (n := ad_plength_1 p1). reflexivity.
+  apply (lt_le_trans k (ad_plength_1 p) (ad_plength_1 p1)). exact H0.
+  apply ni_le_le. exact H2.
+Qed.
+
+Lemma ad_plength_ultra :
+ forall a a':ad,
+   ni_le (ni_min (ad_plength a) (ad_plength a')) (ad_plength (ad_xor a a')).
+Proof.
+  intros. case (ni_le_total (ad_plength a) (ad_plength a')). intro.
+  cut (ni_min (ad_plength a) (ad_plength a') = ad_plength a).
+  intro. rewrite H0. apply ad_plength_ultra_1. exact H.
+  exact H.
+  intro. cut (ni_min (ad_plength a) (ad_plength a') = ad_plength a').
+  intro. rewrite H0. rewrite ad_xor_comm. apply ad_plength_ultra_1. exact H.
+  rewrite ni_min_comm. exact H.
+Qed.
+
+Lemma ad_pdist_ultra :
+ forall a a' a'':ad,
+   ni_le (ni_min (ad_pdist a a'') (ad_pdist a'' a')) (ad_pdist a a').
+Proof.
+  intros. unfold ad_pdist in |- *. cut (ad_xor (ad_xor a a'') (ad_xor a'' a') = ad_xor a a').
+  intro. rewrite <- H. apply ad_plength_ultra.
+  rewrite ad_xor_assoc. rewrite <- (ad_xor_assoc a'' a'' a'). rewrite ad_xor_nilpotent.
+  rewrite ad_xor_neutral_left. reflexivity.
+Qed.
\ No newline at end of file
diff --git a/theories/IntMap/Allmaps.v b/theories/IntMap/Allmaps.v
new file mode 100644
index 00000000..68744220
--- /dev/null
+++ b/theories/IntMap/Allmaps.v
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Allmaps.v,v 1.3.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Export Addr.
+Require Export Adist.
+Require Export Addec.
+Require Export Map.
+
+Require Export Fset.
+Require Export Mapaxioms.
+Require Export Mapiter.
+
+Require Export Mapsubset.
+Require Export Lsort.
+Require Export Mapfold.
+Require Export Mapcard.
+Require Export Mapcanon.
+Require Export Mapc.
+Require Export Maplists.
+Require Export Adalloc.
\ No newline at end of file
diff --git a/theories/IntMap/Fset.v b/theories/IntMap/Fset.v
new file mode 100644
index 00000000..8d217be9
--- /dev/null
+++ b/theories/IntMap/Fset.v
@@ -0,0 +1,371 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Fset.v,v 1.5.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+(*s Sets operations on maps *)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+
+Section Dom.
+
+  Variables A B : Set.
+
+  Fixpoint MapDomRestrTo (m:Map A) : Map B -> Map A :=
+    match m with
+    | M0 => fun _:Map B => M0 A
+    | M1 a y =>
+        fun m':Map B => match MapGet B m' a with
+                        | NONE => M0 A
+                        | _ => m
+                        end
+    | M2 m1 m2 =>
+        fun m':Map B =>
+          match m' with
+          | M0 => M0 A
+          | M1 a' y' =>
+              match MapGet A m a' with
+              | NONE => M0 A
+              | SOME y => M1 A a' y
+              end
+          | M2 m'1 m'2 =>
+              makeM2 A (MapDomRestrTo m1 m'1) (MapDomRestrTo m2 m'2)
+          end
+    end.
+
+  Lemma MapDomRestrTo_semantics :
+   forall (m:Map A) (m':Map B),
+     eqm A (MapGet A (MapDomRestrTo m m'))
+       (fun a0:ad =>
+          match MapGet B m' a0 with
+          | NONE => NONE A
+          | _ => MapGet A m a0
+          end).
+  Proof.
+    unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial.
+    intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a a1)). intro H. rewrite H.
+    rewrite <- (ad_eq_complete _ _ H). case (MapGet B m' a). reflexivity.
+    intro. apply M1_semantics_1.
+    intro H. rewrite H. case (MapGet B m' a). 
+    case (MapGet B m' a1); reflexivity.
+    case (MapGet B m' a1); intros; exact (M1_semantics_2 A a a1 a0 H).
+    simple induction m'. trivial.
+    unfold MapDomRestrTo in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)).
+    intro H1.
+    rewrite (ad_eq_complete _ _ H1). rewrite (M1_semantics_1 B a1 a0).
+    case (MapGet A (M2 A m0 m1) a1). reflexivity.
+    intro. apply M1_semantics_1.
+    intro H1. rewrite (M1_semantics_2 B a a1 a0 H1). case (MapGet A (M2 A m0 m1) a). reflexivity.
+    intro. exact (M1_semantics_2 A a a1 a2 H1).
+    intros. change
+   (MapGet A (makeM2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3)) a =
+    match MapGet B (M2 B m2 m3) a with
+    | NONE => NONE A
+    | SOME _ => MapGet A (M2 A m0 m1) a
+    end) in |- *.
+    rewrite (makeM2_M2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3) a).
+    rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (ad_div_2 a)). rewrite (H m2 (ad_div_2 a)).
+    rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a).
+    case (ad_bit_0 a); reflexivity.
+  Qed.
+
+  Fixpoint MapDomRestrBy (m:Map A) : Map B -> Map A :=
+    match m with
+    | M0 => fun _:Map B => M0 A
+    | M1 a y =>
+        fun m':Map B => match MapGet B m' a with
+                        | NONE => m
+                        | _ => M0 A
+                        end
+    | M2 m1 m2 =>
+        fun m':Map B =>
+          match m' with
+          | M0 => m
+          | M1 a' y' => MapRemove A m a'
+          | M2 m'1 m'2 =>
+              makeM2 A (MapDomRestrBy m1 m'1) (MapDomRestrBy m2 m'2)
+          end
+    end.
+
+  Lemma MapDomRestrBy_semantics :
+   forall (m:Map A) (m':Map B),
+     eqm A (MapGet A (MapDomRestrBy m m'))
+       (fun a0:ad =>
+          match MapGet B m' a0 with
+          | NONE => MapGet A m a0
+          | _ => NONE A
+          end).
+  Proof.
+    unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial.
+    intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a a1)). intro H. rewrite H.
+    rewrite (ad_eq_complete _ _ H). case (MapGet B m' a1). apply M1_semantics_1.
+    trivial.
+    intro H. rewrite H. case (MapGet B m' a). rewrite (M1_semantics_2 A a a1 a0 H).
+    case (MapGet B m' a1); trivial.
+    case (MapGet B m' a1); trivial.
+    simple induction m'. trivial.
+    unfold MapDomRestrBy in |- *. intros. rewrite (MapRemove_semantics A (M2 A m0 m1) a a1).
+    elim (sumbool_of_bool (ad_eq a a1)). intro H1. rewrite H1. rewrite (ad_eq_complete _ _ H1).
+    rewrite (M1_semantics_1 B a1 a0). reflexivity.
+    intro H1. rewrite H1. rewrite (M1_semantics_2 B a a1 a0 H1). reflexivity.
+    intros. change
+   (MapGet A (makeM2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3)) a =
+    match MapGet B (M2 B m2 m3) a with
+    | NONE => MapGet A (M2 A m0 m1) a
+    | SOME _ => NONE A
+    end) in |- *.
+    rewrite (makeM2_M2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3) a).
+    rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (ad_div_2 a)). rewrite (H m2 (ad_div_2 a)).
+    rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a).
+    case (ad_bit_0 a); reflexivity.
+  Qed.
+
+  Definition in_dom (a:ad) (m:Map A) :=
+    match MapGet A m a with
+    | NONE => false
+    | _ => true
+    end.
+
+  Lemma in_dom_M0 : forall a:ad, in_dom a (M0 A) = false.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma in_dom_M1 : forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = ad_eq a a0.
+  Proof.
+    unfold in_dom in |- *. intros. simpl in |- *. case (ad_eq a a0); reflexivity.
+  Qed.
+
+  Lemma in_dom_M1_1 : forall (a:ad) (y:A), in_dom a (M1 A a y) = true.
+  Proof.
+    intros. rewrite in_dom_M1. apply ad_eq_correct.
+  Qed.
+
+  Lemma in_dom_M1_2 :
+   forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = true -> a = a0.
+  Proof.
+    intros. apply (ad_eq_complete a a0). rewrite (in_dom_M1 a a0 y) in H. assumption.
+  Qed.
+
+  Lemma in_dom_some :
+   forall (m:Map A) (a:ad),
+     in_dom a m = true -> {y : A | MapGet A m a = SOME A y}.
+  Proof.
+    unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). trivial.
+    intro H0. rewrite H0 in H. discriminate H.
+  Qed.
+
+  Lemma in_dom_none :
+   forall (m:Map A) (a:ad), in_dom a m = false -> MapGet A m a = NONE A.
+  Proof.
+    unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). intro H0. elim H0.
+    intros y H1. rewrite H1 in H. discriminate H.
+    trivial.
+  Qed.
+
+  Lemma in_dom_put :
+   forall (m:Map A) (a0:ad) (y0:A) (a:ad),
+     in_dom a (MapPut A m a0 y0) = orb (ad_eq a a0) (in_dom a m).
+  Proof.
+    unfold in_dom in |- *. intros. rewrite (MapPut_semantics A m a0 y0 a).
+    elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H. rewrite (ad_eq_comm a a0) in H.
+    rewrite H. rewrite orb_true_b. reflexivity.
+    intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. rewrite H. rewrite orb_false_b.
+    reflexivity.
+  Qed.
+
+  Lemma in_dom_put_behind :
+   forall (m:Map A) (a0:ad) (y0:A) (a:ad),
+     in_dom a (MapPut_behind A m a0 y0) = orb (ad_eq a a0) (in_dom a m).
+  Proof.
+    unfold in_dom in |- *. intros. rewrite (MapPut_behind_semantics A m a0 y0 a).
+    elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H. rewrite (ad_eq_comm a a0) in H.
+    rewrite H. case (MapGet A m a); reflexivity.
+    intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. rewrite H. case (MapGet A m a); trivial.
+  Qed.
+
+  Lemma in_dom_remove :
+   forall (m:Map A) (a0 a:ad),
+     in_dom a (MapRemove A m a0) = andb (negb (ad_eq a a0)) (in_dom a m).
+  Proof.
+    unfold in_dom in |- *. intros. rewrite (MapRemove_semantics A m a0 a).
+    elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H. rewrite (ad_eq_comm a a0) in H.
+    rewrite H. reflexivity.
+    intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. rewrite H.
+    case (MapGet A m a); reflexivity.
+  Qed.
+
+  Lemma in_dom_merge :
+   forall (m m':Map A) (a:ad),
+     in_dom a (MapMerge A m m') = orb (in_dom a m) (in_dom a m').
+  Proof.
+    unfold in_dom in |- *. intros. rewrite (MapMerge_semantics A m m' a).
+    elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y H0. rewrite H0.
+    case (MapGet A m a); reflexivity.
+    intro H. rewrite H. rewrite orb_b_false. reflexivity.
+  Qed.
+
+  Lemma in_dom_delta :
+   forall (m m':Map A) (a:ad),
+     in_dom a (MapDelta A m m') = xorb (in_dom a m) (in_dom a m').
+  Proof.
+    unfold in_dom in |- *. intros. rewrite (MapDelta_semantics A m m' a).
+    elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y H0. rewrite H0.
+    case (MapGet A m a); reflexivity.
+    intro H. rewrite H. case (MapGet A m a); reflexivity.
+  Qed.
+
+End Dom.
+
+Section InDom.
+
+  Variables A B : Set.
+
+  Lemma in_dom_restrto :
+   forall (m:Map A) (m':Map B) (a:ad),
+     in_dom A a (MapDomRestrTo A B m m') =
+     andb (in_dom A a m) (in_dom B a m').
+  Proof.
+    unfold in_dom in |- *. intros. rewrite (MapDomRestrTo_semantics A B m m' a).
+    elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y H0. rewrite H0.
+    rewrite andb_b_true. reflexivity.
+    intro H. rewrite H. rewrite andb_b_false. reflexivity.
+  Qed.
+
+  Lemma in_dom_restrby :
+   forall (m:Map A) (m':Map B) (a:ad),
+     in_dom A a (MapDomRestrBy A B m m') =
+     andb (in_dom A a m) (negb (in_dom B a m')).
+  Proof.
+    unfold in_dom in |- *. intros. rewrite (MapDomRestrBy_semantics A B m m' a).
+    elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y H0. rewrite H0.
+    unfold negb in |- *. rewrite andb_b_false. reflexivity.
+    intro H. rewrite H. unfold negb in |- *. rewrite andb_b_true. reflexivity.
+  Qed.
+
+End InDom.
+
+Definition FSet := Map unit.
+
+Section FSetDefs.
+
+  Variable A : Set.
+
+  Definition in_FSet : ad -> FSet -> bool := in_dom unit.
+
+  Fixpoint MapDom (m:Map A) : FSet :=
+    match m with
+    | M0 => M0 unit
+    | M1 a _ => M1 unit a tt
+    | M2 m m' => M2 unit (MapDom m) (MapDom m')
+    end.
+
+  Lemma MapDom_semantics_1 :
+   forall (m:Map A) (a:ad) (y:A),
+     MapGet A m a = SOME A y -> in_FSet a (MapDom m) = true.
+  Proof.
+    simple induction m. intros. discriminate H.
+    unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0 y0.
+    case (ad_eq a a0). trivial.
+    intro. discriminate H.
+    intros m0 H m1 H0 a y. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *.
+    unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a).
+    case (ad_bit_0 a). unfold in_FSet, in_dom in H0. intro. apply H0 with (y := y). assumption.
+    unfold in_FSet, in_dom in H. intro. apply H with (y := y). assumption.
+  Qed.
+
+  Lemma MapDom_semantics_2 :
+   forall (m:Map A) (a:ad),
+     in_FSet a (MapDom m) = true -> {y : A | MapGet A m a = SOME A y}.
+  Proof.
+    simple induction m. intros. discriminate H.
+    unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0. case (ad_eq a a0).
+    intro. split with y. reflexivity.
+    intro. discriminate H.
+    intros m0 H m1 H0 a. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *.
+    unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a).
+    case (ad_bit_0 a). unfold in_FSet, in_dom in H0. intro. apply H0. assumption.
+    unfold in_FSet, in_dom in H. intro. apply H. assumption.
+  Qed.
+
+  Lemma MapDom_semantics_3 :
+   forall (m:Map A) (a:ad),
+     MapGet A m a = NONE A -> in_FSet a (MapDom m) = false.
+  Proof.
+    intros. elim (sumbool_of_bool (in_FSet a (MapDom m))). intro H0.
+    elim (MapDom_semantics_2 m a H0). intros y H1. rewrite H in H1. discriminate H1.
+    trivial.
+  Qed.
+
+  Lemma MapDom_semantics_4 :
+   forall (m:Map A) (a:ad),
+     in_FSet a (MapDom m) = false -> MapGet A m a = NONE A.
+  Proof.
+    intros. elim (option_sum A (MapGet A m a)). intro H0. elim H0. intros y H1.
+    rewrite (MapDom_semantics_1 m a y H1) in H. discriminate H.
+    trivial.
+  Qed.
+
+  Lemma MapDom_Dom :
+   forall (m:Map A) (a:ad), in_dom A a m = in_FSet a (MapDom m).
+  Proof.
+    intros. elim (sumbool_of_bool (in_FSet a (MapDom m))). intro H.
+    elim (MapDom_semantics_2 m a H). intros y H0. rewrite H. unfold in_dom in |- *. rewrite H0.
+    reflexivity.
+    intro H. rewrite H. unfold in_dom in |- *. rewrite (MapDom_semantics_4 m a H). reflexivity.
+  Qed.
+
+  Definition FSetUnion (s s':FSet) : FSet := MapMerge unit s s'.
+
+  Lemma in_FSet_union :
+   forall (s s':FSet) (a:ad),
+     in_FSet a (FSetUnion s s') = orb (in_FSet a s) (in_FSet a s').
+  Proof.
+    exact (in_dom_merge unit).
+  Qed.
+
+  Definition FSetInter (s s':FSet) : FSet := MapDomRestrTo unit unit s s'.
+
+  Lemma in_FSet_inter :
+   forall (s s':FSet) (a:ad),
+     in_FSet a (FSetInter s s') = andb (in_FSet a s) (in_FSet a s').
+  Proof.
+    exact (in_dom_restrto unit unit).
+  Qed.
+
+  Definition FSetDiff (s s':FSet) : FSet := MapDomRestrBy unit unit s s'.
+
+  Lemma in_FSet_diff :
+   forall (s s':FSet) (a:ad),
+     in_FSet a (FSetDiff s s') = andb (in_FSet a s) (negb (in_FSet a s')).
+  Proof.
+    exact (in_dom_restrby unit unit).
+  Qed.
+
+  Definition FSetDelta (s s':FSet) : FSet := MapDelta unit s s'.
+
+  Lemma in_FSet_delta :
+   forall (s s':FSet) (a:ad),
+     in_FSet a (FSetDelta s s') = xorb (in_FSet a s) (in_FSet a s').
+  Proof.
+    exact (in_dom_delta unit).
+  Qed.
+
+End FSetDefs.
+
+Lemma FSet_Dom : forall s:FSet, MapDom unit s = s.
+Proof.
+  simple induction s. trivial.
+  simpl in |- *. intros a t. elim t. reflexivity.
+  intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+Qed.
\ No newline at end of file
diff --git a/theories/IntMap/Lsort.v b/theories/IntMap/Lsort.v
new file mode 100644
index 00000000..48972872
--- /dev/null
+++ b/theories/IntMap/Lsort.v
@@ -0,0 +1,628 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Lsort.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import List.
+Require Import Mapiter.
+
+Section LSort.
+
+  Variable A : Set.
+
+  Fixpoint ad_less_1 (a a':ad) (p:positive) {struct p} : bool :=
+    match p with
+    | xO p' => ad_less_1 (ad_div_2 a) (ad_div_2 a') p'
+    | _ => andb (negb (ad_bit_0 a)) (ad_bit_0 a')
+    end.
+
+  Definition ad_less (a a':ad) :=
+    match ad_xor a a' with
+    | ad_z => false
+    | ad_x p => ad_less_1 a a' p
+    end.
+
+  Lemma ad_bit_0_less :
+   forall a a':ad,
+     ad_bit_0 a = false -> ad_bit_0 a' = true -> ad_less a a' = true.
+  Proof.
+    intros. elim (ad_sum (ad_xor a a')). intro H1. elim H1. intros p H2. unfold ad_less in |- *.
+    rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+    intros. cut (ad_bit_0 (ad_xor a a') = false). intro. rewrite (ad_xor_bit_0 a a') in H5.
+    rewrite H in H5. rewrite H0 in H5. discriminate H5.
+    rewrite H4. reflexivity.
+    intro. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+    intro H1. cut (ad_bit_0 (ad_xor a a') = false). intro. rewrite (ad_xor_bit_0 a a') in H2.
+    rewrite H in H2. rewrite H0 in H2. discriminate H2.
+    rewrite H1. reflexivity.
+  Qed.
+
+  Lemma ad_bit_0_gt :
+   forall a a':ad,
+     ad_bit_0 a = true -> ad_bit_0 a' = false -> ad_less a a' = false.
+  Proof.
+    intros. elim (ad_sum (ad_xor a a')). intro H1. elim H1. intros p H2. unfold ad_less in |- *.
+    rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+    intros. cut (ad_bit_0 (ad_xor a a') = false). intro. rewrite (ad_xor_bit_0 a a') in H5.
+    rewrite H in H5. rewrite H0 in H5. discriminate H5.
+    rewrite H4. reflexivity.
+    intro. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+    intro H1. unfold ad_less in |- *. rewrite H1. reflexivity.
+  Qed.
+
+  Lemma ad_less_not_refl : forall a:ad, ad_less a a = false.
+  Proof.
+    intro. unfold ad_less in |- *. rewrite (ad_xor_nilpotent a). reflexivity.
+  Qed.
+
+  Lemma ad_ind_double :
+   forall (a:ad) (P:ad -> Prop),
+     P ad_z ->
+     (forall a:ad, P a -> P (ad_double a)) ->
+     (forall a:ad, P a -> P (ad_double_plus_un a)) -> P a.
+  Proof.
+    intros; elim a. trivial.
+    simple induction p. intros. 
+    apply (H1 (ad_x p0)); trivial.
+    intros; apply (H0 (ad_x p0)); trivial.
+    intros; apply (H1 ad_z); assumption.
+  Qed.
+
+  Lemma ad_rec_double :
+   forall (a:ad) (P:ad -> Set),
+     P ad_z ->
+     (forall a:ad, P a -> P (ad_double a)) ->
+     (forall a:ad, P a -> P (ad_double_plus_un a)) -> P a.
+  Proof.
+    intros; elim a. trivial.
+    simple induction p. intros. 
+    apply (H1 (ad_x p0)); trivial.
+    intros; apply (H0 (ad_x p0)); trivial.
+    intros; apply (H1 ad_z); assumption.
+  Qed.
+
+  Lemma ad_less_def_1 :
+   forall a a':ad, ad_less (ad_double a) (ad_double a') = ad_less a a'.
+  Proof.
+    simple induction a. simple induction a'. reflexivity.
+    trivial.
+    simple induction a'. unfold ad_less in |- *. simpl in |- *. elim p; trivial.
+    unfold ad_less in |- *. simpl in |- *. intro. case (p_xor p p0). reflexivity.
+    trivial.
+  Qed.
+
+  Lemma ad_less_def_2 :
+   forall a a':ad,
+     ad_less (ad_double_plus_un a) (ad_double_plus_un a') = ad_less a a'.
+  Proof.
+    simple induction a. simple induction a'. reflexivity.
+    trivial.
+    simple induction a'. unfold ad_less in |- *. simpl in |- *. elim p; trivial.
+    unfold ad_less in |- *. simpl in |- *. intro. case (p_xor p p0). reflexivity.
+    trivial.
+  Qed.
+
+  Lemma ad_less_def_3 :
+   forall a a':ad, ad_less (ad_double a) (ad_double_plus_un a') = true.
+  Proof.
+    intros. apply ad_bit_0_less. apply ad_double_bit_0.
+    apply ad_double_plus_un_bit_0.
+  Qed.
+
+  Lemma ad_less_def_4 :
+   forall a a':ad, ad_less (ad_double_plus_un a) (ad_double a') = false.
+  Proof.
+    intros. apply ad_bit_0_gt. apply ad_double_plus_un_bit_0.
+    apply ad_double_bit_0.
+  Qed.
+
+  Lemma ad_less_z : forall a:ad, ad_less a ad_z = false.
+  Proof.
+    simple induction a. reflexivity.
+    unfold ad_less in |- *. intro. rewrite (ad_xor_neutral_right (ad_x p)). elim p; trivial.
+  Qed.
+
+  Lemma ad_z_less_1 :
+   forall a:ad, ad_less ad_z a = true -> {p : positive | a = ad_x p}.
+  Proof.
+    simple induction a. intro. discriminate H.
+    intros. split with p. reflexivity.
+  Qed.
+
+  Lemma ad_z_less_2 : forall a:ad, ad_less ad_z a = false -> a = ad_z.
+  Proof.
+    simple induction a. trivial.
+    unfold ad_less in |- *. simpl in |- *. cut (forall p:positive, ad_less_1 ad_z (ad_x p) p = false -> False).
+    intros. elim (H p H0).
+    simple induction p. intros. discriminate H0.
+    intros. exact (H H0).
+    intro. discriminate H.
+  Qed.
+
+  Lemma ad_less_trans :
+   forall a a' a'':ad,
+     ad_less a a' = true -> ad_less a' a'' = true -> ad_less a a'' = true.
+  Proof.
+    intro a. apply ad_ind_double with
+  (P := fun a:ad =>
+          forall a' a'':ad,
+            ad_less a a' = true ->
+            ad_less a' a'' = true -> ad_less a a'' = true).
+    intros. elim (sumbool_of_bool (ad_less ad_z a'')). trivial.
+    intro H1. rewrite (ad_z_less_2 a'' H1) in H0. rewrite (ad_less_z a') in H0. discriminate H0.
+    intros a0 H a'. apply ad_ind_double with
+  (P := fun a':ad =>
+          forall a'':ad,
+            ad_less (ad_double a0) a' = true ->
+            ad_less a' a'' = true -> ad_less (ad_double a0) a'' = true).
+    intros. rewrite (ad_less_z (ad_double a0)) in H0. discriminate H0.
+    intros a1 H0 a'' H1. rewrite (ad_less_def_1 a0 a1) in H1.
+    apply ad_ind_double with
+     (P := fun a'':ad =>
+             ad_less (ad_double a1) a'' = true ->
+             ad_less (ad_double a0) a'' = true).
+    intro. rewrite (ad_less_z (ad_double a1)) in H2. discriminate H2.
+    intros. rewrite (ad_less_def_1 a1 a2) in H3. rewrite (ad_less_def_1 a0 a2).
+    exact (H a1 a2 H1 H3).
+    intros. apply ad_less_def_3.
+    intros a1 H0 a'' H1. apply ad_ind_double with
+  (P := fun a'':ad =>
+          ad_less (ad_double_plus_un a1) a'' = true ->
+          ad_less (ad_double a0) a'' = true).
+    intro. rewrite (ad_less_z (ad_double_plus_un a1)) in H2. discriminate H2.
+    intros. rewrite (ad_less_def_4 a1 a2) in H3. discriminate H3.
+    intros. apply ad_less_def_3.
+    intros a0 H a'. apply ad_ind_double with
+  (P := fun a':ad =>
+          forall a'':ad,
+            ad_less (ad_double_plus_un a0) a' = true ->
+            ad_less a' a'' = true ->
+            ad_less (ad_double_plus_un a0) a'' = true).
+    intros. rewrite (ad_less_z (ad_double_plus_un a0)) in H0. discriminate H0.
+    intros. rewrite (ad_less_def_4 a0 a1) in H1. discriminate H1.
+    intros a1 H0 a'' H1. apply ad_ind_double with
+  (P := fun a'':ad =>
+          ad_less (ad_double_plus_un a1) a'' = true ->
+          ad_less (ad_double_plus_un a0) a'' = true).
+    intro. rewrite (ad_less_z (ad_double_plus_un a1)) in H2. discriminate H2.
+    intros. rewrite (ad_less_def_4 a1 a2) in H3. discriminate H3.
+    rewrite (ad_less_def_2 a0 a1) in H1. intros. rewrite (ad_less_def_2 a1 a2) in H3.
+    rewrite (ad_less_def_2 a0 a2). exact (H a1 a2 H1 H3).
+  Qed.
+
+  Fixpoint alist_sorted (l:alist A) : bool :=
+    match l with
+    | nil => true
+    | (a, _) :: l' =>
+        match l' with
+        | nil => true
+        | (a', y') :: l'' => andb (ad_less a a') (alist_sorted l')
+        end
+    end.
+
+  Fixpoint alist_nth_ad (n:nat) (l:alist A) {struct l} : ad :=
+    match l with
+    | nil => ad_z (* dummy *)
+    | (a, y) :: l' => match n with
+                      | O => a
+                      | S n' => alist_nth_ad n' l'
+                      end
+    end.
+
+  Definition alist_sorted_1 (l:alist A) :=
+    forall n:nat,
+      S (S n) <= length l ->
+      ad_less (alist_nth_ad n l) (alist_nth_ad (S n) l) = true.
+
+  Lemma alist_sorted_imp_1 :
+   forall l:alist A, alist_sorted l = true -> alist_sorted_1 l.
+  Proof.
+    unfold alist_sorted_1 in |- *. simple induction l. intros. elim (le_Sn_O (S n) H0).
+    intro r. elim r. intros a y. simple induction l0. intros. simpl in H1.
+    elim (le_Sn_O n (le_S_n (S n) 0 H1)).
+    intro r0. elim r0. intros a0 y0. simple induction n. intros. simpl in |- *. simpl in H1.
+    exact (proj1 (andb_prop _ _ H1)).
+    intros. change
+   (ad_less (alist_nth_ad n0 ((a0, y0) :: l1))
+      (alist_nth_ad (S n0) ((a0, y0) :: l1)) = true) 
+  in |- *.
+    apply H0. exact (proj2 (andb_prop _ _ H1)).
+    apply le_S_n. exact H3.
+  Qed.
+
+  Definition alist_sorted_2 (l:alist A) :=
+    forall m n:nat,
+      m < n ->
+      S n <= length l -> ad_less (alist_nth_ad m l) (alist_nth_ad n l) = true.
+
+  Lemma alist_sorted_1_imp_2 :
+   forall l:alist A, alist_sorted_1 l -> alist_sorted_2 l.
+  Proof.
+    unfold alist_sorted_1, alist_sorted_2, lt in |- *. intros l H m n H0. elim H0. exact (H m).
+    intros. apply ad_less_trans with (a' := alist_nth_ad m0 l). apply H2. apply le_Sn_le.
+    assumption.
+    apply H. assumption.
+  Qed.
+
+  Lemma alist_sorted_2_imp :
+   forall l:alist A, alist_sorted_2 l -> alist_sorted l = true.
+  Proof.
+    unfold alist_sorted_2, lt in |- *. simple induction l. trivial.
+    intro r. elim r. intros a y. simple induction l0. trivial.
+    intro r0. elim r0. intros a0 y0. intros.
+    change (andb (ad_less a a0) (alist_sorted ((a0, y0) :: l1)) = true)
+     in |- *.
+    apply andb_true_intro. split. apply (H1 0 1). apply le_n.
+    simpl in |- *. apply le_n_S. apply le_n_S. apply le_O_n.
+    apply H0. intros. apply (H1 (S m) (S n)). apply le_n_S. assumption.
+    exact (le_n_S _ _ H3).
+  Qed.
+
+  Lemma app_length :
+   forall (C:Set) (l l':list C), length (l ++ l') = length l + length l'.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (H l'). reflexivity.
+  Qed.
+
+  Lemma aapp_length :
+   forall l l':alist A, length (aapp A l l') = length l + length l'.
+  Proof.
+    exact (app_length (ad * A)).
+  Qed.
+
+  Lemma alist_nth_ad_aapp_1 :
+   forall (l l':alist A) (n:nat),
+     S n <= length l -> alist_nth_ad n (aapp A l l') = alist_nth_ad n l.
+  Proof.
+    simple induction l. intros. elim (le_Sn_O n H).
+    intro r. elim r. intros a y l' H l''. simple induction n. trivial.
+    intros. simpl in |- *. apply H. apply le_S_n. exact H1.
+  Qed.
+
+  Lemma alist_nth_ad_aapp_2 :
+   forall (l l':alist A) (n:nat),
+     S n <= length l' ->
+     alist_nth_ad (length l + n) (aapp A l l') = alist_nth_ad n l'.
+  Proof.
+    simple induction l. trivial.
+    intro r. elim r. intros a y l' H l'' n H0. simpl in |- *. apply H. exact H0.
+  Qed.
+
+  Lemma interval_split :
+   forall p q n:nat,
+     S n <= p + q -> {n' : nat | S n' <= q /\ n = p + n'} + {S n <= p}.
+  Proof.
+    simple induction p. simpl in |- *. intros. left. split with n. split; [ assumption | reflexivity ].
+    intros p' H q. simple induction n. intros. right. apply le_n_S. apply le_O_n.
+    intros. elim (H _ _ (le_S_n _ _ H1)). intro H2. left. elim H2. intros n' H3.
+    elim H3. intros H4 H5. split with n'. split; [ assumption | rewrite H5; reflexivity ].
+    intro H2. right. apply le_n_S. assumption.
+  Qed.
+
+  Lemma alist_conc_sorted :
+   forall l l':alist A,
+     alist_sorted_2 l ->
+     alist_sorted_2 l' ->
+     (forall n n':nat,
+        S n <= length l ->
+        S n' <= length l' ->
+        ad_less (alist_nth_ad n l) (alist_nth_ad n' l') = true) ->
+     alist_sorted_2 (aapp A l l').
+  Proof.
+    unfold alist_sorted_2, lt in |- *. intros. rewrite (aapp_length l l') in H3.
+    elim
+     (interval_split (length l) (length l') m
+        (le_trans _ _ _ (le_n_S _ _ (lt_le_weak m n H2)) H3)).
+    intro H4. elim H4. intros m' H5. elim H5. intros. rewrite H7.
+    rewrite (alist_nth_ad_aapp_2 l l' m' H6). elim (interval_split (length l) (length l') n H3).
+    intro H8. elim H8. intros n' H9. elim H9. intros. rewrite H11.
+    rewrite (alist_nth_ad_aapp_2 l l' n' H10). apply H0. rewrite H7 in H2. rewrite H11 in H2.
+    change (S (length l) + m' <= length l + n') in H2.
+    rewrite (plus_Snm_nSm (length l) m') in H2. exact ((fun p n m:nat => plus_le_reg_l n m p) (length l) (S m') n' H2).
+    exact H10.
+    intro H8. rewrite H7 in H2. cut (S (length l) <= length l). intros. elim (le_Sn_n _ H9).
+    apply le_trans with (m := S n). apply le_n_S. apply le_trans with (m := S (length l + m')).
+    apply le_trans with (m := length l + m'). apply le_plus_l.
+    apply le_n_Sn.
+    exact H2.
+    exact H8.
+    intro H4. rewrite (alist_nth_ad_aapp_1 l l' m H4).
+    elim (interval_split (length l) (length l') n H3). intro H5. elim H5. intros n' H6. elim H6.
+    intros. rewrite H8. rewrite (alist_nth_ad_aapp_2 l l' n' H7). exact (H1 m n' H4 H7).
+    intro H5. rewrite (alist_nth_ad_aapp_1 l l' n H5). exact (H m n H2 H5).
+  Qed.
+
+  Lemma alist_nth_ad_semantics :
+   forall (l:alist A) (n:nat),
+     S n <= length l ->
+     {y : A | alist_semantics A l (alist_nth_ad n l) = SOME A y}.
+  Proof.
+    simple induction l. intros. elim (le_Sn_O _ H).
+    intro r. elim r. intros a y l0 H. simple induction n. simpl in |- *. intro. split with y.
+    rewrite (ad_eq_correct a). reflexivity.
+    intros. elim (H _ (le_S_n _ _ H1)). intros y0 H2.
+    elim (sumbool_of_bool (ad_eq a (alist_nth_ad n0 l0))). intro H3. split with y.
+    rewrite (ad_eq_complete _ _ H3). simpl in |- *. rewrite (ad_eq_correct (alist_nth_ad n0 l0)).
+    reflexivity.
+    intro H3. split with y0. simpl in |- *. rewrite H3. assumption.
+  Qed.
+
+  Lemma alist_of_Map_nth_ad :
+   forall (m:Map A) (pf:ad -> ad) (l:alist A),
+     l =
+     MapFold1 A (alist A) (anil A) (aapp A)
+       (fun (a0:ad) (y:A) => acons A (a0, y) (anil A)) pf m ->
+     forall n:nat, S n <= length l -> {a' : ad | alist_nth_ad n l = pf a'}.
+  Proof.
+    intros. elim (alist_nth_ad_semantics l n H0). intros y H1.
+    apply (alist_of_Map_semantics_1_1 A m pf (alist_nth_ad n l) y).
+    rewrite <- H. assumption.
+  Qed.
+
+  Definition ad_monotonic (pf:ad -> ad) :=
+    forall a a':ad, ad_less a a' = true -> ad_less (pf a) (pf a') = true.
+
+  Lemma ad_double_monotonic : ad_monotonic ad_double.
+  Proof.
+    unfold ad_monotonic in |- *. intros. rewrite ad_less_def_1. assumption.
+  Qed.
+
+  Lemma ad_double_plus_un_monotonic : ad_monotonic ad_double_plus_un.
+  Proof.
+    unfold ad_monotonic in |- *. intros. rewrite ad_less_def_2. assumption.
+  Qed.
+
+  Lemma ad_comp_monotonic :
+   forall pf pf':ad -> ad,
+     ad_monotonic pf ->
+     ad_monotonic pf' -> ad_monotonic (fun a0:ad => pf (pf' a0)).
+  Proof.
+    unfold ad_monotonic in |- *. intros. apply H. apply H0. exact H1.
+  Qed.
+
+  Lemma ad_comp_double_monotonic :
+   forall pf:ad -> ad,
+     ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (ad_double a0)).
+  Proof.
+    intros. apply ad_comp_monotonic. assumption.
+    exact ad_double_monotonic.
+  Qed.
+
+  Lemma ad_comp_double_plus_un_monotonic :
+   forall pf:ad -> ad,
+     ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (ad_double_plus_un a0)).
+  Proof.
+    intros. apply ad_comp_monotonic. assumption.
+    exact ad_double_plus_un_monotonic.
+  Qed.
+
+  Lemma alist_of_Map_sorts_1 :
+   forall (m:Map A) (pf:ad -> ad),
+     ad_monotonic pf ->
+     alist_sorted_2
+       (MapFold1 A (alist A) (anil A) (aapp A)
+          (fun (a:ad) (y:A) => acons A (a, y) (anil A)) pf m).
+  Proof.
+    simple induction m. simpl in |- *. intros. apply alist_sorted_1_imp_2. apply alist_sorted_imp_1. reflexivity.
+    intros. simpl in |- *. apply alist_sorted_1_imp_2. apply alist_sorted_imp_1. reflexivity.
+    intros. simpl in |- *. apply alist_conc_sorted.
+    exact
+     (H (fun a0:ad => pf (ad_double a0)) (ad_comp_double_monotonic pf H1)).
+    exact
+     (H0 (fun a0:ad => pf (ad_double_plus_un a0))
+        (ad_comp_double_plus_un_monotonic pf H1)).
+    intros. elim
+  (alist_of_Map_nth_ad m0 (fun a0:ad => pf (ad_double a0))
+     (MapFold1 A (alist A) (anil A) (aapp A)
+        (fun (a0:ad) (y:A) => acons A (a0, y) (anil A))
+        (fun a0:ad => pf (ad_double a0)) m0) (refl_equal _) n H2).
+    intros a H4. rewrite H4. elim
+  (alist_of_Map_nth_ad m1 (fun a0:ad => pf (ad_double_plus_un a0))
+     (MapFold1 A (alist A) (anil A) (aapp A)
+        (fun (a0:ad) (y:A) => acons A (a0, y) (anil A))
+        (fun a0:ad => pf (ad_double_plus_un a0)) m1) (
+     refl_equal _) n' H3).
+    intros a' H5. rewrite H5. unfold ad_monotonic in H1. apply H1. apply ad_less_def_3.
+  Qed.
+
+  Lemma alist_of_Map_sorts :
+   forall m:Map A, alist_sorted (alist_of_Map A m) = true.
+  Proof.
+    intro. apply alist_sorted_2_imp.
+    exact
+     (alist_of_Map_sorts_1 m (fun a0:ad => a0)
+        (fun (a a':ad) (p:ad_less a a' = true) => p)).
+  Qed.
+
+  Lemma alist_of_Map_sorts1 :
+   forall m:Map A, alist_sorted_1 (alist_of_Map A m).
+  Proof.
+    intro. apply alist_sorted_imp_1. apply alist_of_Map_sorts.
+  Qed.
+ 
+  Lemma alist_of_Map_sorts2 :
+   forall m:Map A, alist_sorted_2 (alist_of_Map A m).
+  Proof.
+    intro. apply alist_sorted_1_imp_2. apply alist_of_Map_sorts1.
+  Qed.
+ 
+  Lemma ad_less_total :
+   forall a a':ad, {ad_less a a' = true} + {ad_less a' a = true} + {a = a'}.
+  Proof.
+    intro a. refine
+  (ad_rec_double a
+     (fun a:ad =>
+        forall a':ad,
+          {ad_less a a' = true} + {ad_less a' a = true} + {a = a'}) _ _ _).
+    intro. elim (sumbool_of_bool (ad_less ad_z a')). intro H. left. left. assumption.
+    intro H. right. rewrite (ad_z_less_2 a' H). reflexivity.
+    intros a0 H a'. refine
+  (ad_rec_double a'
+     (fun a':ad =>
+        {ad_less (ad_double a0) a' = true} +
+        {ad_less a' (ad_double a0) = true} + {ad_double a0 = a'}) _ _ _).
+    elim (sumbool_of_bool (ad_less ad_z (ad_double a0))). intro H0. left. right. assumption.
+    intro H0. right. exact (ad_z_less_2 _ H0).
+    intros a1 H0. rewrite ad_less_def_1. rewrite ad_less_def_1. elim (H a1). intro H1.
+    left. assumption.
+    intro H1. right. rewrite H1. reflexivity.
+    intros a1 H0. left. left. apply ad_less_def_3.
+    intros a0 H a'. refine
+  (ad_rec_double a'
+     (fun a':ad =>
+        {ad_less (ad_double_plus_un a0) a' = true} +
+        {ad_less a' (ad_double_plus_un a0) = true} +
+        {ad_double_plus_un a0 = a'}) _ _ _).
+    left. right. case a0; reflexivity.
+    intros a1 H0. left. right. apply ad_less_def_3.
+    intros a1 H0. rewrite ad_less_def_2. rewrite ad_less_def_2. elim (H a1). intro H1.
+    left. assumption.
+    intro H1. right. rewrite H1. reflexivity.
+  Qed.
+
+  Lemma alist_too_low :
+   forall (l:alist A) (a a':ad) (y:A),
+     ad_less a a' = true ->
+     alist_sorted_2 ((a', y) :: l) ->
+     alist_semantics A ((a', y) :: l) a = NONE A.
+  Proof.
+    simple induction l. intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a' a)). intro H1.
+    rewrite (ad_eq_complete _ _ H1) in H. rewrite (ad_less_not_refl a) in H. discriminate H.
+    intro H1. rewrite H1. reflexivity.
+    intro r. elim r. intros a y l0 H a0 a1 y0 H0 H1.
+    change
+      (match ad_eq a1 a0 with
+       | true => SOME A y0
+       | false => alist_semantics A ((a, y) :: l0) a0
+       end = NONE A) in |- *.
+    elim (sumbool_of_bool (ad_eq a1 a0)). intro H2. rewrite (ad_eq_complete _ _ H2) in H0.
+    rewrite (ad_less_not_refl a0) in H0. discriminate H0.
+    intro H2. rewrite H2. apply H. apply ad_less_trans with (a' := a1). assumption.
+    unfold alist_sorted_2 in H1. apply (H1 0 1). apply lt_n_Sn.
+    simpl in |- *. apply le_n_S. apply le_n_S. apply le_O_n.
+    apply alist_sorted_1_imp_2. apply alist_sorted_imp_1.
+    cut (alist_sorted ((a1, y0) :: (a, y) :: l0) = true). intro H3.
+    exact (proj2 (andb_prop _ _ H3)).
+    apply alist_sorted_2_imp. assumption.
+  Qed.
+
+  Lemma alist_semantics_nth_ad :
+   forall (l:alist A) (a:ad) (y:A),
+     alist_semantics A l a = SOME A y ->
+     {n : nat | S n <= length l /\ alist_nth_ad n l = a}.
+  Proof.
+    simple induction l. intros. discriminate H.
+    intro r. elim r. intros a y l0 H a0 y0 H0. simpl in H0. elim (sumbool_of_bool (ad_eq a a0)).
+    intro H1. rewrite H1 in H0. split with 0. split. simpl in |- *. apply le_n_S. apply le_O_n.
+    simpl in |- *. exact (ad_eq_complete _ _ H1).
+    intro H1. rewrite H1 in H0. elim (H a0 y0 H0). intros n' H2. split with (S n'). split.
+    simpl in |- *. apply le_n_S. exact (proj1 H2).
+    exact (proj2 H2).
+  Qed.
+
+  Lemma alist_semantics_tail :
+   forall (l:alist A) (a:ad) (y:A),
+     alist_sorted_2 ((a, y) :: l) ->
+     eqm A (alist_semantics A l)
+       (fun a0:ad =>
+          if ad_eq a a0 then NONE A else alist_semantics A ((a, y) :: l) a0).
+  Proof.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0.
+    rewrite <- (ad_eq_complete _ _ H0). unfold alist_sorted_2 in H.
+    elim (option_sum A (alist_semantics A l a)). intro H1. elim H1. intros y0 H2.
+    elim (alist_semantics_nth_ad l a y0 H2). intros n H3. elim H3. intros.
+    cut
+     (ad_less (alist_nth_ad 0 ((a, y) :: l))
+        (alist_nth_ad (S n) ((a, y) :: l)) = true).
+    intro. simpl in H6. rewrite H5 in H6. rewrite (ad_less_not_refl a) in H6. discriminate H6.
+    apply H. apply lt_O_Sn.
+    simpl in |- *. apply le_n_S. assumption.
+    trivial.
+    intro H0. simpl in |- *. rewrite H0. reflexivity.
+  Qed.
+
+  Lemma alist_semantics_same_tail :
+   forall (l l':alist A) (a:ad) (y:A),
+     alist_sorted_2 ((a, y) :: l) ->
+     alist_sorted_2 ((a, y) :: l') ->
+     eqm A (alist_semantics A ((a, y) :: l))
+       (alist_semantics A ((a, y) :: l')) ->
+     eqm A (alist_semantics A l) (alist_semantics A l').
+  Proof.
+    unfold eqm in |- *. intros. rewrite (alist_semantics_tail _ _ _ H a0).
+    rewrite (alist_semantics_tail _ _ _ H0 a0). case (ad_eq a a0). reflexivity.
+    exact (H1 a0).
+  Qed.
+
+  Lemma alist_sorted_tail :
+   forall (l:alist A) (a:ad) (y:A),
+     alist_sorted_2 ((a, y) :: l) -> alist_sorted_2 l.
+  Proof.
+    unfold alist_sorted_2 in |- *. intros. apply (H (S m) (S n)). apply lt_n_S. assumption.
+    simpl in |- *. apply le_n_S. assumption.
+  Qed.
+
+  Lemma alist_canonical :
+   forall l l':alist A,
+     eqm A (alist_semantics A l) (alist_semantics A l') ->
+     alist_sorted_2 l -> alist_sorted_2 l' -> l = l'.
+  Proof.
+    unfold eqm in |- *. simple induction l. simple induction l'. trivial.
+    intro r. elim r. intros a y l0 H H0 H1 H2. simpl in H0.
+    cut
+     (NONE A =
+      match ad_eq a a with
+      | true => SOME A y
+      | false => alist_semantics A l0 a
+      end).
+    rewrite (ad_eq_correct a). intro. discriminate H3.
+    exact (H0 a).
+    intro r. elim r. intros a y l0 H. simple induction l'. intros. simpl in H0.
+    cut
+     (match ad_eq a a with
+      | true => SOME A y
+      | false => alist_semantics A l0 a
+      end = NONE A).
+    rewrite (ad_eq_correct a). intro. discriminate H3.
+    exact (H0 a).
+    intro r'. elim r'. intros a' y' l'0 H0 H1 H2 H3. elim (ad_less_total a a'). intro H4.
+    elim H4. intro H5.
+    cut
+     (alist_semantics A ((a, y) :: l0) a =
+      alist_semantics A ((a', y') :: l'0) a).
+    intro. rewrite (alist_too_low l'0 a a' y' H5 H3) in H6. simpl in H6.
+    rewrite (ad_eq_correct a) in H6. discriminate H6.
+    exact (H1 a).
+    intro H5. cut
+  (alist_semantics A ((a, y) :: l0) a' =
+   alist_semantics A ((a', y') :: l'0) a').
+    intro. rewrite (alist_too_low l0 a' a y H5 H2) in H6. simpl in H6.
+    rewrite (ad_eq_correct a') in H6. discriminate H6.
+    exact (H1 a').
+    intro H4. rewrite H4.
+    cut
+     (alist_semantics A ((a, y) :: l0) a =
+      alist_semantics A ((a', y') :: l'0) a).
+    intro. simpl in H5. rewrite H4 in H5. rewrite (ad_eq_correct a') in H5. inversion H5.
+    rewrite H4 in H1. rewrite H7 in H1. cut (l0 = l'0). intro. rewrite H6. reflexivity.
+    apply H. rewrite H4 in H2. rewrite H7 in H2.
+    exact (alist_semantics_same_tail l0 l'0 a' y' H2 H3 H1).
+    exact (alist_sorted_tail _ _ _ H2).
+    exact (alist_sorted_tail _ _ _ H3).
+    exact (H1 a).
+  Qed.
+
+End LSort.
\ No newline at end of file
diff --git a/theories/IntMap/Map.v b/theories/IntMap/Map.v
new file mode 100644
index 00000000..da1fa99e
--- /dev/null
+++ b/theories/IntMap/Map.v
@@ -0,0 +1,865 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Map.v,v 1.7.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+(** Definition of finite sets as trees indexed by adresses *)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+
+
+Section MapDefs.
+
+(** We define maps from ad to A. *)
+  Variable A : Set.  
+
+  Inductive Map : Set :=
+    | M0 : Map
+    | M1 : ad -> A -> Map
+    | M2 : Map -> Map -> Map.
+
+  Inductive option : Set :=
+    | NONE : option
+    | SOME : A -> option.
+
+  Lemma option_sum : forall o:option, {y : A | o = SOME y} + {o = NONE}.
+  Proof.
+    simple induction o. right. reflexivity.
+    left. split with a. reflexivity.
+  Qed.
+
+  (** The semantics of maps is given by the function [MapGet].
+      The semantics of a map [m] is a partial, finite function from
+      [ad] to [A]: *)
+
+  Fixpoint MapGet (m:Map) : ad -> option :=
+    match m with
+    | M0 => fun a:ad => NONE
+    | M1 x y => fun a:ad => if ad_eq x a then SOME y else NONE
+    | M2 m1 m2 =>
+        fun a:ad =>
+          match a with
+          | ad_z => MapGet m1 ad_z
+          | ad_x xH => MapGet m2 ad_z
+          | ad_x (xO p) => MapGet m1 (ad_x p)
+          | ad_x (xI p) => MapGet m2 (ad_x p)
+          end
+    end.
+
+  Definition newMap := M0.
+
+  Definition MapSingleton := M1.
+
+  Definition eqm (g g':ad -> option) := forall a:ad, g a = g' a.
+
+  Lemma newMap_semantics : eqm (MapGet newMap) (fun a:ad => NONE).
+  Proof.
+    simpl in |- *. unfold eqm in |- *. trivial.
+  Qed.
+
+  Lemma MapSingleton_semantics :
+   forall (a:ad) (y:A),
+     eqm (MapGet (MapSingleton a y))
+       (fun a':ad => if ad_eq a a' then SOME y else NONE).
+  Proof.
+    simpl in |- *. unfold eqm in |- *. trivial.
+  Qed.
+
+  Lemma M1_semantics_1 : forall (a:ad) (y:A), MapGet (M1 a y) a = SOME y.
+  Proof.
+    unfold MapGet in |- *. intros. rewrite (ad_eq_correct a). reflexivity.
+  Qed.
+
+  Lemma M1_semantics_2 :
+   forall (a a':ad) (y:A), ad_eq a a' = false -> MapGet (M1 a y) a' = NONE.
+  Proof.
+    intros. simpl in |- *. rewrite H. reflexivity.
+  Qed.
+
+  Lemma Map2_semantics_1 :
+   forall m m':Map,
+     eqm (MapGet m) (fun a:ad => MapGet (M2 m m') (ad_double a)).
+  Proof.
+    unfold eqm in |- *. simple induction a; trivial.
+  Qed.
+
+  Lemma Map2_semantics_1_eq :
+   forall (m m':Map) (f:ad -> option),
+     eqm (MapGet (M2 m m')) f -> eqm (MapGet m) (fun a:ad => f (ad_double a)).
+  Proof.
+    unfold eqm in |- *.
+    intros.
+    rewrite <- (H (ad_double a)).
+    exact (Map2_semantics_1 m m' a).
+  Qed.
+
+  Lemma Map2_semantics_2 :
+   forall m m':Map,
+     eqm (MapGet m') (fun a:ad => MapGet (M2 m m') (ad_double_plus_un a)).
+  Proof.
+    unfold eqm in |- *. simple induction a; trivial.
+  Qed.
+
+  Lemma Map2_semantics_2_eq :
+   forall (m m':Map) (f:ad -> option),
+     eqm (MapGet (M2 m m')) f ->
+     eqm (MapGet m') (fun a:ad => f (ad_double_plus_un a)).
+  Proof.
+    unfold eqm in |- *.
+    intros.
+    rewrite <- (H (ad_double_plus_un a)).
+    exact (Map2_semantics_2 m m' a).
+  Qed.
+
+  Lemma MapGet_M2_bit_0_0 :
+   forall a:ad,
+     ad_bit_0 a = false ->
+     forall m m':Map, MapGet (M2 m m') a = MapGet m (ad_div_2 a).
+  Proof.
+    simple induction a; trivial. simple induction p. intros. discriminate H0.
+    trivial.
+    intros. discriminate H.
+  Qed.
+
+  Lemma MapGet_M2_bit_0_1 :
+   forall a:ad,
+     ad_bit_0 a = true ->
+     forall m m':Map, MapGet (M2 m m') a = MapGet m' (ad_div_2 a).
+  Proof.
+    simple induction a. intros. discriminate H.
+    simple induction p. trivial.
+    intros. discriminate H0.
+    trivial.
+  Qed.
+
+  Lemma MapGet_M2_bit_0_if :
+   forall (m m':Map) (a:ad),
+     MapGet (M2 m m') a =
+     (if ad_bit_0 a then MapGet m' (ad_div_2 a) else MapGet m (ad_div_2 a)).
+  Proof.
+    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H. rewrite H.
+    apply MapGet_M2_bit_0_1; assumption.
+    intro H. rewrite H. apply MapGet_M2_bit_0_0; assumption.
+  Qed.
+
+  Lemma MapGet_M2_bit_0 :
+   forall (m m' m'':Map) (a:ad),
+     (if ad_bit_0 a then MapGet (M2 m' m) a else MapGet (M2 m m'') a) =
+     MapGet m (ad_div_2 a).
+  Proof.
+    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H. rewrite H.
+    apply MapGet_M2_bit_0_1; assumption.
+    intro H. rewrite H. apply MapGet_M2_bit_0_0; assumption.
+  Qed.
+
+  Lemma Map2_semantics_3 :
+   forall m m':Map,
+     eqm (MapGet (M2 m m'))
+       (fun a:ad =>
+          match ad_bit_0 a with
+          | false => MapGet m (ad_div_2 a)
+          | true => MapGet m' (ad_div_2 a)
+          end).
+  Proof.
+    unfold eqm in |- *.
+    simple induction a; trivial.
+    simple induction p; trivial.
+  Qed.
+
+  Lemma Map2_semantics_3_eq :
+   forall (m m':Map) (f f':ad -> option),
+     eqm (MapGet m) f ->
+     eqm (MapGet m') f' ->
+     eqm (MapGet (M2 m m'))
+       (fun a:ad =>
+          match ad_bit_0 a with
+          | false => f (ad_div_2 a)
+          | true => f' (ad_div_2 a)
+          end).
+  Proof.
+    unfold eqm in |- *.
+    intros.
+    rewrite <- (H (ad_div_2 a)).
+    rewrite <- (H0 (ad_div_2 a)).
+    exact (Map2_semantics_3 m m' a).
+  Qed.
+
+  Fixpoint MapPut1 (a:ad) (y:A) (a':ad) (y':A) (p:positive) {struct p} :
+   Map :=
+    match p with
+    | xO p' =>
+        let m := MapPut1 (ad_div_2 a) y (ad_div_2 a') y' p' in
+        match ad_bit_0 a with
+        | false => M2 m M0
+        | true => M2 M0 m
+        end
+    | _ =>
+        match ad_bit_0 a with
+        | false => M2 (M1 (ad_div_2 a) y) (M1 (ad_div_2 a') y')
+        | true => M2 (M1 (ad_div_2 a') y') (M1 (ad_div_2 a) y)
+        end
+    end.
+
+  Lemma MapGet_if_commute :
+   forall (b:bool) (m m':Map) (a:ad),
+     MapGet (if b then m else m') a = (if b then MapGet m a else MapGet m' a).
+  Proof.
+    intros. case b; trivial.
+  Qed.
+
+  (*i
+  Lemma MapGet_M2_bit_0_1' : (m,m',m'',m''':Map)
+      (a:ad) (MapGet (if (ad_bit_0 a) then (M2 m m') else (M2 m'' m''')) a)=
+             (MapGet (if (ad_bit_0 a) then m' else m'') (ad_div_2 a)).
+  Proof.
+    Intros. Rewrite (MapGet_if_commute (ad_bit_0 a)). Rewrite (MapGet_if_commute (ad_bit_0 a)).
+    Cut (ad_bit_0 a)=false\/(ad_bit_0 a)=true. Intros. Elim H. Intros. Rewrite H0.
+    Apply MapGet_M2_bit_0_0. Assumption.
+    Intros. Rewrite H0. Apply MapGet_M2_bit_0_1. Assumption.
+    Case (ad_bit_0 a); Auto.
+  Qed.
+  i*)
+
+  Lemma MapGet_if_same :
+   forall (m:Map) (b:bool) (a:ad), MapGet (if b then m else m) a = MapGet m a.
+  Proof.
+    simple induction b; trivial.
+  Qed.
+
+  Lemma MapGet_M2_bit_0_2 :
+   forall (m m' m'':Map) (a:ad),
+     MapGet (if ad_bit_0 a then M2 m m' else M2 m' m'') a =
+     MapGet m' (ad_div_2 a).
+  Proof.
+    intros. rewrite MapGet_if_commute. apply MapGet_M2_bit_0.
+  Qed.
+
+  Lemma MapPut1_semantics_1 :
+   forall (p:positive) (a a':ad) (y y':A),
+     ad_xor a a' = ad_x p -> MapGet (MapPut1 a y a' y' p) a = SOME y.
+  Proof.
+    simple induction p. intros. unfold MapPut1 in |- *. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
+    intros. simpl in |- *. rewrite MapGet_M2_bit_0_2. apply H. rewrite <- ad_xor_div_2. rewrite H0.
+    reflexivity.
+    intros. unfold MapPut1 in |- *. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
+  Qed.
+
+  Lemma MapPut1_semantics_2 :
+   forall (p:positive) (a a':ad) (y y':A),
+     ad_xor a a' = ad_x p -> MapGet (MapPut1 a y a' y' p) a' = SOME y'.
+  Proof.
+    simple induction p. intros. unfold MapPut1 in |- *. rewrite (ad_neg_bit_0_2 a a' p0 H0).
+    rewrite if_negb. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
+    intros. simpl in |- *. rewrite (ad_same_bit_0 a a' p0 H0). rewrite MapGet_M2_bit_0_2.
+    apply H. rewrite <- ad_xor_div_2. rewrite H0. reflexivity.
+    intros. unfold MapPut1 in |- *. rewrite (ad_neg_bit_0_1 a a' H). rewrite if_negb.
+    rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
+  Qed.
+
+  Lemma MapGet_M2_both_NONE :
+   forall (m m':Map) (a:ad),
+     MapGet m (ad_div_2 a) = NONE ->
+     MapGet m' (ad_div_2 a) = NONE -> MapGet (M2 m m') a = NONE.
+  Proof.
+    intros. rewrite (Map2_semantics_3 m m' a). 
+    case (ad_bit_0 a); assumption.
+  Qed.
+ 
+  Lemma MapPut1_semantics_3 :
+   forall (p:positive) (a a' a0:ad) (y y':A),
+     ad_xor a a' = ad_x p ->
+     ad_eq a a0 = false ->
+     ad_eq a' a0 = false -> MapGet (MapPut1 a y a' y' p) a0 = NONE.
+  Proof.
+    simple induction p. intros. unfold MapPut1 in |- *. elim (ad_neq a a0 H1). intro. rewrite H3. rewrite if_negb.
+    rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply ad_div_bit_neq. assumption.
+    rewrite (ad_neg_bit_0_2 a a' p0 H0) in H3. rewrite (negb_intro (ad_bit_0 a')).
+    rewrite (negb_intro (ad_bit_0 a0)). rewrite H3. reflexivity.
+    intro. elim (ad_neq a' a0 H2). intro. rewrite (ad_neg_bit_0_2 a a' p0 H0). rewrite H4.
+    rewrite (negb_elim (ad_bit_0 a0)). rewrite MapGet_M2_bit_0_2.
+    apply M1_semantics_2; assumption.
+    intro; case (ad_bit_0 a); apply MapGet_M2_both_NONE; apply M1_semantics_2;
+     assumption.
+    intros. simpl in |- *. elim (ad_neq a a0 H1). intro. rewrite H3. rewrite if_negb.
+    rewrite MapGet_M2_bit_0_2. reflexivity.
+    intro. elim (ad_neq a' a0 H2). intro. rewrite (ad_same_bit_0 a a' p0 H0). rewrite H4.
+    rewrite if_negb. rewrite MapGet_M2_bit_0_2. reflexivity.
+    intro. cut (ad_xor (ad_div_2 a) (ad_div_2 a') = ad_x p0). intro.
+    case (ad_bit_0 a); apply MapGet_M2_both_NONE; trivial; apply H;
+     assumption.
+    rewrite <- ad_xor_div_2. rewrite H0. reflexivity.
+    intros. simpl in |- *. elim (ad_neq a a0 H0). intro. rewrite H2. rewrite if_negb.
+    rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply ad_div_bit_neq. assumption.
+    rewrite (ad_neg_bit_0_1 a a' H) in H2. rewrite (negb_intro (ad_bit_0 a')).
+    rewrite (negb_intro (ad_bit_0 a0)). rewrite H2. reflexivity.
+    intro. elim (ad_neq a' a0 H1). intro. rewrite (ad_neg_bit_0_1 a a' H). rewrite H3.
+    rewrite (negb_elim (ad_bit_0 a0)). rewrite MapGet_M2_bit_0_2.
+    apply M1_semantics_2; assumption.
+    intro. case (ad_bit_0 a); apply MapGet_M2_both_NONE; apply M1_semantics_2;
+  assumption.
+  Qed.
+
+  Lemma MapPut1_semantics :
+   forall (p:positive) (a a':ad) (y y':A),
+     ad_xor a a' = ad_x p ->
+     eqm (MapGet (MapPut1 a y a' y' p))
+       (fun a0:ad =>
+          if ad_eq a a0
+          then SOME y
+          else if ad_eq a' a0 then SOME y' else NONE).
+  Proof.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0.
+    rewrite <- (ad_eq_complete _ _ H0). exact (MapPut1_semantics_1 p a a' y y' H).
+    intro H0. rewrite H0. elim (sumbool_of_bool (ad_eq a' a0)). intro H1.
+    rewrite <- (ad_eq_complete _ _ H1). rewrite (ad_eq_correct a').
+    exact (MapPut1_semantics_2 p a a' y y' H).
+    intro H1. rewrite H1. exact (MapPut1_semantics_3 p a a' a0 y y' H H0 H1).
+  Qed.
+
+  Lemma MapPut1_semantics' :
+   forall (p:positive) (a a':ad) (y y':A),
+     ad_xor a a' = ad_x p ->
+     eqm (MapGet (MapPut1 a y a' y' p))
+       (fun a0:ad =>
+          if ad_eq a' a0
+          then SOME y'
+          else if ad_eq a a0 then SOME y else NONE).
+  Proof.
+    unfold eqm in |- *. intros. rewrite (MapPut1_semantics p a a' y y' H a0).
+    elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0.
+    rewrite <- (ad_eq_complete a a0 H0). rewrite (ad_eq_comm a' a).
+    rewrite (ad_xor_eq_false a a' p H). reflexivity.
+    intro H0. rewrite H0. reflexivity.
+  Qed.
+
+  Fixpoint MapPut (m:Map) : ad -> A -> Map :=
+    match m with
+    | M0 => M1
+    | M1 a y =>
+        fun (a':ad) (y':A) =>
+          match ad_xor a a' with
+          | ad_z => M1 a' y'
+          | ad_x p => MapPut1 a y a' y' p
+          end
+    | M2 m1 m2 =>
+        fun (a:ad) (y:A) =>
+          match a with
+          | ad_z => M2 (MapPut m1 ad_z y) m2
+          | ad_x xH => M2 m1 (MapPut m2 ad_z y)
+          | ad_x (xO p) => M2 (MapPut m1 (ad_x p) y) m2
+          | ad_x (xI p) => M2 m1 (MapPut m2 (ad_x p) y)
+          end
+    end.
+
+  Lemma MapPut_semantics_1 :
+   forall (a:ad) (y:A) (a0:ad),
+     MapGet (MapPut M0 a y) a0 = MapGet (M1 a y) a0.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapPut_semantics_2_1 :
+   forall (a:ad) (y y':A) (a0:ad),
+     MapGet (MapPut (M1 a y) a y') a0 =
+     (if ad_eq a a0 then SOME y' else NONE).
+  Proof.
+    simpl in |- *. intros. rewrite (ad_xor_nilpotent a). trivial.
+  Qed.
+
+  Lemma MapPut_semantics_2_2 :
+   forall (a a':ad) (y y':A) (a0 a'':ad),
+     ad_xor a a' = a'' ->
+     MapGet (MapPut (M1 a y) a' y') a0 =
+     (if ad_eq a' a0 then SOME y' else if ad_eq a a0 then SOME y else NONE).
+  Proof.
+    simple induction a''. intro. rewrite (ad_xor_eq _ _ H). rewrite MapPut_semantics_2_1.
+    case (ad_eq a' a0); trivial.
+    intros. simpl in |- *. rewrite H. rewrite (MapPut1_semantics p a a' y y' H a0).
+    elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0. rewrite <- (ad_eq_complete _ _ H0).
+    rewrite (ad_eq_comm a' a). rewrite (ad_xor_eq_false _ _ _ H). reflexivity.
+    intro H0. rewrite H0. reflexivity.
+  Qed.
+
+  Lemma MapPut_semantics_2 :
+   forall (a a':ad) (y y':A) (a0:ad),
+     MapGet (MapPut (M1 a y) a' y') a0 =
+     (if ad_eq a' a0 then SOME y' else if ad_eq a a0 then SOME y else NONE).
+  Proof.
+    intros. apply MapPut_semantics_2_2 with (a'' := ad_xor a a'); trivial.
+  Qed.
+
+  Lemma MapPut_semantics_3_1 :
+   forall (m m':Map) (a:ad) (y:A),
+     MapPut (M2 m m') a y =
+     (if ad_bit_0 a
+      then M2 m (MapPut m' (ad_div_2 a) y)
+      else M2 (MapPut m (ad_div_2 a) y) m').
+  Proof.
+    simple induction a. trivial.
+    simple induction p; trivial.
+  Qed.
+
+  Lemma MapPut_semantics :
+   forall (m:Map) (a:ad) (y:A),
+     eqm (MapGet (MapPut m a y))
+       (fun a':ad => if ad_eq a a' then SOME y else MapGet m a').
+  Proof.
+    unfold eqm in |- *. simple induction m. exact MapPut_semantics_1.
+    intros. unfold MapGet at 2 in |- *. apply MapPut_semantics_2; assumption.
+    intros. rewrite MapPut_semantics_3_1. rewrite (MapGet_M2_bit_0_if m0 m1 a0).
+    elim (sumbool_of_bool (ad_bit_0 a)). intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if.
+    elim (sumbool_of_bool (ad_bit_0 a0)). intro H2. rewrite H2.
+    rewrite (H0 (ad_div_2 a) y (ad_div_2 a0)). elim (sumbool_of_bool (ad_eq a a0)).
+    intro H3. rewrite H3. rewrite (ad_div_eq _ _ H3). reflexivity.
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq _ _ H3 H1). reflexivity.
+    intro H2. rewrite H2. rewrite (ad_eq_comm a a0). rewrite (ad_bit_0_neq a0 a H2 H1).
+    reflexivity.
+    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a0)).
+    intro H2. rewrite H2. rewrite (ad_bit_0_neq a a0 H1 H2). reflexivity.
+    intro H2. rewrite H2. rewrite (H (ad_div_2 a) y (ad_div_2 a0)).
+    elim (sumbool_of_bool (ad_eq a a0)). intro H3. rewrite H3.
+    rewrite (ad_div_eq a a0 H3). reflexivity.
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq a a0 H3 H1). reflexivity.
+  Qed.
+
+  Fixpoint MapPut_behind (m:Map) : ad -> A -> Map :=
+    match m with
+    | M0 => M1
+    | M1 a y =>
+        fun (a':ad) (y':A) =>
+          match ad_xor a a' with
+          | ad_z => m
+          | ad_x p => MapPut1 a y a' y' p
+          end
+    | M2 m1 m2 =>
+        fun (a:ad) (y:A) =>
+          match a with
+          | ad_z => M2 (MapPut_behind m1 ad_z y) m2
+          | ad_x xH => M2 m1 (MapPut_behind m2 ad_z y)
+          | ad_x (xO p) => M2 (MapPut_behind m1 (ad_x p) y) m2
+          | ad_x (xI p) => M2 m1 (MapPut_behind m2 (ad_x p) y)
+          end
+    end.
+
+  Lemma MapPut_behind_semantics_3_1 :
+   forall (m m':Map) (a:ad) (y:A),
+     MapPut_behind (M2 m m') a y =
+     (if ad_bit_0 a
+      then M2 m (MapPut_behind m' (ad_div_2 a) y)
+      else M2 (MapPut_behind m (ad_div_2 a) y) m').
+  Proof.
+    simple induction a. trivial.
+    simple induction p; trivial.
+  Qed.
+
+  Lemma MapPut_behind_as_before_1 :
+   forall a a' a0:ad,
+     ad_eq a' a0 = false ->
+     forall y y':A,
+       MapGet (MapPut (M1 a y) a' y') a0 =
+       MapGet (MapPut_behind (M1 a y) a' y') a0.
+  Proof.
+    intros a a' a0. simpl in |- *. intros H y y'. elim (ad_sum (ad_xor a a')). intro H0. elim H0.
+    intros p H1. rewrite H1. reflexivity.
+    intro H0. rewrite H0. rewrite (ad_xor_eq _ _ H0). rewrite (M1_semantics_2 a' a0 y H).
+    exact (M1_semantics_2 a' a0 y' H).
+  Qed.
+
+  Lemma MapPut_behind_as_before :
+   forall (m:Map) (a:ad) (y:A) (a0:ad),
+     ad_eq a a0 = false ->
+     MapGet (MapPut m a y) a0 = MapGet (MapPut_behind m a y) a0.
+  Proof.
+    simple induction m. trivial.
+    intros a y a' y' a0 H. exact (MapPut_behind_as_before_1 a a' a0 H y y').
+    intros. rewrite MapPut_semantics_3_1. rewrite MapPut_behind_semantics_3_1.
+    elim (sumbool_of_bool (ad_bit_0 a)). intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if.
+    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a0)). intro H3.
+    rewrite H3. apply H0. rewrite <- H3 in H2. exact (ad_div_bit_neq a a0 H1 H2).
+    intro H3. rewrite H3. reflexivity.
+    intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if. rewrite MapGet_M2_bit_0_if.
+    elim (sumbool_of_bool (ad_bit_0 a0)). intro H3. rewrite H3. reflexivity.
+    intro H3. rewrite H3. apply H. rewrite <- H3 in H2. exact (ad_div_bit_neq a a0 H1 H2).
+  Qed.
+
+  Lemma MapPut_behind_new :
+   forall (m:Map) (a:ad) (y:A),
+     MapGet (MapPut_behind m a y) a =
+     match MapGet m a with
+     | SOME y' => SOME y'
+     | _ => SOME y
+     end.
+  Proof.
+    simple induction m. simpl in |- *. intros. rewrite (ad_eq_correct a). reflexivity.
+    intros. elim (ad_sum (ad_xor a a1)). intro H. elim H. intros p H0. simpl in |- *.
+    rewrite H0. rewrite (ad_xor_eq_false a a1 p). exact (MapPut1_semantics_2 p a a1 a0 y H0).
+    assumption.
+    intro H. simpl in |- *. rewrite H. rewrite <- (ad_xor_eq _ _ H). rewrite (ad_eq_correct a).
+    exact (M1_semantics_1 a a0).
+    intros. rewrite MapPut_behind_semantics_3_1. rewrite (MapGet_M2_bit_0_if m0 m1 a).
+    elim (sumbool_of_bool (ad_bit_0 a)). intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_1 a H1).
+    exact (H0 (ad_div_2 a) y).
+    intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_0 a H1). exact (H (ad_div_2 a) y).
+  Qed.
+
+  Lemma MapPut_behind_semantics :
+   forall (m:Map) (a:ad) (y:A),
+     eqm (MapGet (MapPut_behind m a y))
+       (fun a':ad =>
+          match MapGet m a' with
+          | SOME y' => SOME y'
+          | _ => if ad_eq a a' then SOME y else NONE
+          end).
+  Proof.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H.
+    rewrite (ad_eq_complete _ _ H). apply MapPut_behind_new.
+    intro H. rewrite H. rewrite <- (MapPut_behind_as_before m a y a0 H).
+    rewrite (MapPut_semantics m a y a0). rewrite H. case (MapGet m a0); trivial.
+  Qed.
+
+  Definition makeM2 (m m':Map) :=
+    match m, m' with
+    | M0, M0 => M0
+    | M0, M1 a y => M1 (ad_double_plus_un a) y
+    | M1 a y, M0 => M1 (ad_double a) y
+    | _, _ => M2 m m'
+    end.
+
+  Lemma makeM2_M2 :
+   forall m m':Map, eqm (MapGet (makeM2 m m')) (MapGet (M2 m m')).
+  Proof.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H.
+    rewrite (MapGet_M2_bit_0_1 a H m m'). case m'. case m. reflexivity.
+    intros a0 y. simpl in |- *. rewrite (ad_bit_0_1_not_double a H a0). reflexivity.
+    intros m1 m2. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity.
+    assumption.
+    case m. intros a0 y. simpl in |- *. elim (sumbool_of_bool (ad_eq a0 (ad_div_2 a))).
+    intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H0). rewrite (ad_div_2_double_plus_un a H).
+    rewrite (ad_eq_correct a). reflexivity.
+    intro H0. rewrite H0. rewrite (ad_eq_comm a0 (ad_div_2 a)) in H0.
+    rewrite (ad_not_div_2_not_double_plus_un a a0 H0). reflexivity.
+    intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity.
+    assumption.
+    intros m1 m2 a0 y. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity.
+    assumption.
+    intros m1 m2. unfold makeM2 in |- *.
+    cut (MapGet (M2 m (M2 m1 m2)) a = MapGet (M2 m1 m2) (ad_div_2 a)). 
+    case m; trivial.
+    exact (MapGet_M2_bit_0_1 a H m (M2 m1 m2)).
+    intro H. rewrite (MapGet_M2_bit_0_0 a H m m'). case m. case m'. reflexivity.
+    intros a0 y. simpl in |- *. rewrite (ad_bit_0_0_not_double_plus_un a H a0). reflexivity.
+    intros m1 m2. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity.
+    assumption.
+    case m'. intros a0 y. simpl in |- *. elim (sumbool_of_bool (ad_eq a0 (ad_div_2 a))). intro H0.
+    rewrite H0. rewrite (ad_eq_complete _ _ H0). rewrite (ad_div_2_double a H).
+    rewrite (ad_eq_correct a). reflexivity.
+    intro H0. rewrite H0. rewrite (ad_eq_comm (ad_double a0) a).
+    rewrite (ad_eq_comm a0 (ad_div_2 a)) in H0. rewrite (ad_not_div_2_not_double a a0 H0).
+    reflexivity.
+    intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity.
+    assumption.
+    intros m1 m2 a0 y. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity.
+    assumption.
+    intros m1 m2. unfold makeM2 in |- *. exact (MapGet_M2_bit_0_0 a H (M2 m1 m2) m').
+  Qed.
+
+  Fixpoint MapRemove (m:Map) : ad -> Map :=
+    match m with
+    | M0 => fun _:ad => M0
+    | M1 a y =>
+        fun a':ad => match ad_eq a a' with
+                     | true => M0
+                     | false => m
+                     end
+    | M2 m1 m2 =>
+        fun a:ad =>
+          if ad_bit_0 a
+          then makeM2 m1 (MapRemove m2 (ad_div_2 a))
+          else makeM2 (MapRemove m1 (ad_div_2 a)) m2
+    end.
+
+  Lemma MapRemove_semantics :
+   forall (m:Map) (a:ad),
+     eqm (MapGet (MapRemove m a))
+       (fun a':ad => if ad_eq a a' then NONE else MapGet m a').
+  Proof.
+    unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (ad_eq a a0); trivial.
+    intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a1 a2)). intro H. rewrite H.
+    elim (sumbool_of_bool (ad_eq a a1)). intro H0. rewrite H0. reflexivity.
+    intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H) in H0. exact (M1_semantics_2 a a2 a0 H0).
+    intro H. elim (sumbool_of_bool (ad_eq a a1)). intro H0. rewrite H0. rewrite H.
+    rewrite <- (ad_eq_complete _ _ H0) in H. rewrite H. reflexivity.
+    intro H0. rewrite H0. rewrite H. reflexivity.
+    intros. change
+   (MapGet
+      (if ad_bit_0 a
+       then makeM2 m0 (MapRemove m1 (ad_div_2 a))
+       else makeM2 (MapRemove m0 (ad_div_2 a)) m1) a0 =
+    (if ad_eq a a0 then NONE else MapGet (M2 m0 m1) a0)) 
+  in |- *.
+    elim (sumbool_of_bool (ad_bit_0 a)). intro H1. rewrite H1.
+    rewrite (makeM2_M2 m0 (MapRemove m1 (ad_div_2 a)) a0). elim (sumbool_of_bool (ad_bit_0 a0)).
+    intro H2. rewrite MapGet_M2_bit_0_1. rewrite (H0 (ad_div_2 a) (ad_div_2 a0)).
+    elim (sumbool_of_bool (ad_eq a a0)). intro H3. rewrite H3. rewrite (ad_div_eq _ _ H3).
+    reflexivity.
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq _ _ H3 H1).
+    rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). reflexivity.
+    assumption.
+    intro H2. rewrite (MapGet_M2_bit_0_0 a0 H2 m0 (MapRemove m1 (ad_div_2 a))).
+    rewrite (ad_eq_comm a a0). rewrite (ad_bit_0_neq _ _ H2 H1).
+    rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). reflexivity.
+    intro H1. rewrite H1. rewrite (makeM2_M2 (MapRemove m0 (ad_div_2 a)) m1 a0).
+    elim (sumbool_of_bool (ad_bit_0 a0)). intro H2. rewrite MapGet_M2_bit_0_1.
+    rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). rewrite (ad_bit_0_neq a a0 H1 H2). reflexivity.
+    assumption.
+    intro H2. rewrite MapGet_M2_bit_0_0. rewrite (H (ad_div_2 a) (ad_div_2 a0)).
+    rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). elim (sumbool_of_bool (ad_eq a a0)). intro H3.
+    rewrite H3. rewrite (ad_div_eq _ _ H3). reflexivity.
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq _ _ H3 H1). reflexivity.
+    assumption.
+  Qed.
+
+  Fixpoint MapCard (m:Map) : nat :=
+    match m with
+    | M0 => 0
+    | M1 _ _ => 1
+    | M2 m m' => MapCard m + MapCard m'
+    end.
+
+  Fixpoint MapMerge (m:Map) : Map -> Map :=
+    match m with
+    | M0 => fun m':Map => m'
+    | M1 a y => fun m':Map => MapPut_behind m' a y
+    | M2 m1 m2 =>
+        fun m':Map =>
+          match m' with
+          | M0 => m
+          | M1 a' y' => MapPut m a' y'
+          | M2 m'1 m'2 => M2 (MapMerge m1 m'1) (MapMerge m2 m'2)
+          end
+    end.
+
+  Lemma MapMerge_semantics :
+   forall m m':Map,
+     eqm (MapGet (MapMerge m m'))
+       (fun a0:ad =>
+          match MapGet m' a0 with
+          | SOME y' => SOME y'
+          | NONE => MapGet m a0
+          end).
+  Proof.
+    unfold eqm in |- *. simple induction m. intros. simpl in |- *. case (MapGet m' a); trivial.
+    intros. simpl in |- *. rewrite (MapPut_behind_semantics m' a a0 a1). reflexivity.
+    simple induction m'. trivial.
+    intros. unfold MapMerge in |- *. rewrite (MapPut_semantics (M2 m0 m1) a a0 a1).
+    elim (sumbool_of_bool (ad_eq a a1)). intro H1. rewrite H1. rewrite (ad_eq_complete _ _ H1).
+    rewrite (M1_semantics_1 a1 a0). reflexivity.
+    intro H1. rewrite H1. rewrite (M1_semantics_2 a a1 a0 H1). reflexivity.
+    intros. cut (MapMerge (M2 m0 m1) (M2 m2 m3) = M2 (MapMerge m0 m2) (MapMerge m1 m3)).
+    intro. rewrite H3. rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (ad_div_2 a)).
+    rewrite (H m2 (ad_div_2 a)). rewrite (MapGet_M2_bit_0_if m2 m3 a).
+    rewrite (MapGet_M2_bit_0_if m0 m1 a). case (ad_bit_0 a); trivial.
+    reflexivity.
+  Qed.
+
+  (** [MapInter], [MapRngRestrTo], [MapRngRestrBy], [MapInverse] 
+      not implemented: need a decidable equality on [A]. *)
+
+  Fixpoint MapDelta (m:Map) : Map -> Map :=
+    match m with
+    | M0 => fun m':Map => m'
+    | M1 a y =>
+        fun m':Map =>
+          match MapGet m' a with
+          | NONE => MapPut m' a y
+          | _ => MapRemove m' a
+          end
+    | M2 m1 m2 =>
+        fun m':Map =>
+          match m' with
+          | M0 => m
+          | M1 a' y' =>
+              match MapGet m a' with
+              | NONE => MapPut m a' y'
+              | _ => MapRemove m a'
+              end
+          | M2 m'1 m'2 => makeM2 (MapDelta m1 m'1) (MapDelta m2 m'2)
+          end
+    end.
+
+  Lemma MapDelta_semantics_comm :
+   forall m m':Map, eqm (MapGet (MapDelta m m')) (MapGet (MapDelta m' m)).
+  Proof.
+    unfold eqm in |- *. simple induction m. simple induction m'; reflexivity.
+    simple induction m'. reflexivity.
+    unfold MapDelta in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H.
+    rewrite <- (ad_eq_complete _ _ H). rewrite (M1_semantics_1 a a2).
+    rewrite (M1_semantics_1 a a0). simpl in |- *. rewrite (ad_eq_correct a). reflexivity.
+    intro H. rewrite (M1_semantics_2 a a1 a0 H). rewrite (ad_eq_comm a a1) in H.
+    rewrite (M1_semantics_2 a1 a a2 H). rewrite (MapPut_semantics (M1 a a0) a1 a2 a3).
+    rewrite (MapPut_semantics (M1 a1 a2) a a0 a3). elim (sumbool_of_bool (ad_eq a a3)).
+    intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H0) in H. rewrite H.
+    rewrite (ad_eq_complete _ _ H0). rewrite (M1_semantics_1 a3 a0). reflexivity.
+    intro H0. rewrite H0. rewrite (M1_semantics_2 a a3 a0 H0).
+    elim (sumbool_of_bool (ad_eq a1 a3)). intro H1. rewrite H1.
+    rewrite (ad_eq_complete _ _ H1). exact (M1_semantics_1 a3 a2).
+    intro H1. rewrite H1. exact (M1_semantics_2 a1 a3 a2 H1).
+    intros. reflexivity.
+    simple induction m'. reflexivity.
+    reflexivity.
+    intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
+    rewrite (makeM2_M2 (MapDelta m2 m0) (MapDelta m3 m1) a).
+    rewrite (MapGet_M2_bit_0_if (MapDelta m0 m2) (MapDelta m1 m3) a).
+    rewrite (MapGet_M2_bit_0_if (MapDelta m2 m0) (MapDelta m3 m1) a).
+    rewrite (H0 m3 (ad_div_2 a)). rewrite (H m2 (ad_div_2 a)). reflexivity.
+  Qed.
+
+  Lemma MapDelta_semantics_1_1 :
+   forall (a:ad) (y:A) (m':Map) (a0:ad),
+     MapGet (M1 a y) a0 = NONE ->
+     MapGet m' a0 = NONE -> MapGet (MapDelta (M1 a y) m') a0 = NONE.
+  Proof.
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a a0)). intro H1.
+    rewrite (ad_eq_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H.
+    intro H1. case (MapGet m' a). rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption.
+    rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial.
+  Qed.
+
+  Lemma MapDelta_semantics_1 :
+   forall (m m':Map) (a:ad),
+     MapGet m a = NONE ->
+     MapGet m' a = NONE -> MapGet (MapDelta m m') a = NONE.
+  Proof.
+    simple induction m. trivial.
+    exact MapDelta_semantics_1_1.
+    simple induction m'. trivial.
+    intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
+    apply MapDelta_semantics_1_1; trivial.
+    intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
+    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a)). intro H5. rewrite H5.
+    apply H0. rewrite (MapGet_M2_bit_0_1 a H5 m0 m1) in H3. exact H3.
+    rewrite (MapGet_M2_bit_0_1 a H5 m2 m3) in H4. exact H4.
+    intro H5. rewrite H5. apply H. rewrite (MapGet_M2_bit_0_0 a H5 m0 m1) in H3. exact H3.
+    rewrite (MapGet_M2_bit_0_0 a H5 m2 m3) in H4. exact H4.
+  Qed.
+
+  Lemma MapDelta_semantics_2_1 :
+   forall (a:ad) (y:A) (m':Map) (a0:ad) (y0:A),
+     MapGet (M1 a y) a0 = NONE ->
+     MapGet m' a0 = SOME y0 -> MapGet (MapDelta (M1 a y) m') a0 = SOME y0.
+  Proof.
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a a0)). intro H1.
+    rewrite (ad_eq_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H.
+    intro H1. case (MapGet m' a). rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption.
+    rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial.
+  Qed.
+
+  Lemma MapDelta_semantics_2_2 :
+   forall (a:ad) (y:A) (m':Map) (a0:ad) (y0:A),
+     MapGet (M1 a y) a0 = SOME y0 ->
+     MapGet m' a0 = NONE -> MapGet (MapDelta (M1 a y) m') a0 = SOME y0.
+  Proof.
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a a0)). intro H1.
+    rewrite (ad_eq_complete _ _ H1) in H. rewrite (ad_eq_complete _ _ H1).
+    rewrite H0. rewrite (MapPut_semantics m' a0 y a0). rewrite (ad_eq_correct a0).
+    rewrite (M1_semantics_1 a0 y) in H. simple inversion H. assumption.
+    intro H1. rewrite (M1_semantics_2 a a0 y H1) in H. discriminate H.
+  Qed.
+
+  Lemma MapDelta_semantics_2 :
+   forall (m m':Map) (a:ad) (y:A),
+     MapGet m a = NONE ->
+     MapGet m' a = SOME y -> MapGet (MapDelta m m') a = SOME y.
+  Proof.
+    simple induction m. trivial.
+    exact MapDelta_semantics_2_1.
+    simple induction m'. intros. discriminate H2.
+    intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
+    apply MapDelta_semantics_2_2; assumption.
+    intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
+    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a)). intro H5. rewrite H5.
+    apply H0. rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). assumption.
+    rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). assumption.
+    intro H5. rewrite H5. apply H. rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). assumption.
+    rewrite <- (MapGet_M2_bit_0_0 a H5 m2 m3). assumption.
+  Qed.
+
+  Lemma MapDelta_semantics_3_1 :
+   forall (a0:ad) (y0:A) (m':Map) (a:ad) (y y':A),
+     MapGet (M1 a0 y0) a = SOME y ->
+     MapGet m' a = SOME y' -> MapGet (MapDelta (M1 a0 y0) m') a = NONE.
+  Proof.
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a0 a)). intro H1.
+    rewrite (ad_eq_complete a0 a H1). rewrite H0. rewrite (MapRemove_semantics m' a a).
+    rewrite (ad_eq_correct a). reflexivity.
+    intro H1. rewrite (M1_semantics_2 a0 a y0 H1) in H. discriminate H.
+  Qed.
+
+  Lemma MapDelta_semantics_3 :
+   forall (m m':Map) (a:ad) (y y':A),
+     MapGet m a = SOME y ->
+     MapGet m' a = SOME y' -> MapGet (MapDelta m m') a = NONE.
+  Proof.
+    simple induction m. intros. discriminate H.
+    exact MapDelta_semantics_3_1.
+    simple induction m'. intros. discriminate H2.
+    intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
+    exact (MapDelta_semantics_3_1 a a0 (M2 m0 m1) a1 y' y H2 H1).
+    intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
+    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a)). intro H5. rewrite H5.
+    apply (H0 m3 (ad_div_2 a) y y'). rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). assumption.
+    rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). assumption.
+    intro H5. rewrite H5. apply (H m2 (ad_div_2 a) y y').
+    rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). assumption.
+    rewrite <- (MapGet_M2_bit_0_0 a H5 m2 m3). assumption.
+  Qed.
+
+  Lemma MapDelta_semantics :
+   forall m m':Map,
+     eqm (MapGet (MapDelta m m'))
+       (fun a0:ad =>
+          match MapGet m a0, MapGet m' a0 with
+          | NONE, SOME y' => SOME y'
+          | SOME y, NONE => SOME y
+          | _, _ => NONE
+          end).
+  Proof.
+    unfold eqm in |- *. intros. elim (option_sum (MapGet m' a)). intro H. elim H. intros a0 H0.
+    rewrite H0. elim (option_sum (MapGet m a)). intro H1. elim H1. intros a1 H2. rewrite H2.
+    exact (MapDelta_semantics_3 m m' a a1 a0 H2 H0).
+    intro H1. rewrite H1. exact (MapDelta_semantics_2 m m' a a0 H1 H0).
+    intro H. rewrite H. elim (option_sum (MapGet m a)). intro H0. elim H0. intros a0 H1.
+    rewrite H1. rewrite (MapDelta_semantics_comm m m' a).
+    exact (MapDelta_semantics_2 m' m a a0 H H1).
+    intro H0. rewrite H0. exact (MapDelta_semantics_1 m m' a H0 H).
+  Qed.
+
+  Definition MapEmptyp (m:Map) := match m with
+                                  | M0 => true
+                                  | _ => false
+                                  end.
+
+  Lemma MapEmptyp_correct : MapEmptyp M0 = true.
+  Proof.
+    reflexivity.
+  Qed.
+
+  Lemma MapEmptyp_complete : forall m:Map, MapEmptyp m = true -> m = M0.
+  Proof.
+    simple induction m; trivial. intros. discriminate H.
+    intros. discriminate H1.
+  Qed.
+
+  (** [MapSplit] not implemented: not the preferred way of recursing over Maps
+      (use [MapSweep], [MapCollect], or [MapFold] in Mapiter.v. *)
+
+End MapDefs.
\ No newline at end of file
diff --git a/theories/IntMap/Mapaxioms.v b/theories/IntMap/Mapaxioms.v
new file mode 100644
index 00000000..9d09f2a9
--- /dev/null
+++ b/theories/IntMap/Mapaxioms.v
@@ -0,0 +1,763 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Mapaxioms.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Fset.
+
+Section MapAxioms.
+
+  Variables A B C : Set.
+
+  Lemma eqm_sym : forall f f':ad -> option A, eqm A f f' -> eqm A f' f.
+  Proof.
+    unfold eqm in |- *. intros. rewrite H. reflexivity.
+  Qed.
+
+  Lemma eqm_refl : forall f:ad -> option A, eqm A f f.
+  Proof.
+    unfold eqm in |- *. trivial.
+  Qed.
+
+  Lemma eqm_trans :
+   forall f f' f'':ad -> option A, eqm A f f' -> eqm A f' f'' -> eqm A f f''.
+  Proof.
+    unfold eqm in |- *. intros. rewrite H. exact (H0 a).
+  Qed.
+
+  Definition eqmap (m m':Map A) := eqm A (MapGet A m) (MapGet A m').
+
+  Lemma eqmap_sym : forall m m':Map A, eqmap m m' -> eqmap m' m.
+  Proof.
+    intros. unfold eqmap in |- *. apply eqm_sym. assumption.
+  Qed.
+
+  Lemma eqmap_refl : forall m:Map A, eqmap m m.
+  Proof.
+    intros. unfold eqmap in |- *. apply eqm_refl.
+  Qed.
+
+  Lemma eqmap_trans :
+   forall m m' m'':Map A, eqmap m m' -> eqmap m' m'' -> eqmap m m''.
+  Proof.
+    intros. exact (eqm_trans (MapGet A m) (MapGet A m') (MapGet A m'') H H0).
+  Qed.
+
+  Lemma MapPut_as_Merge :
+   forall (m:Map A) (a:ad) (y:A),
+     eqmap (MapPut A m a y) (MapMerge A m (M1 A a y)).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapPut_semantics A m a y a0).
+    rewrite (MapMerge_semantics A m (M1 A a y) a0). unfold MapGet at 2 in |- *.
+    elim (sumbool_of_bool (ad_eq a a0)); intro H; rewrite H; reflexivity.
+  Qed.
+
+  Lemma MapPut_ext :
+   forall m m':Map A,
+     eqmap m m' ->
+     forall (a:ad) (y:A), eqmap (MapPut A m a y) (MapPut A m' a y).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapPut_semantics A m' a y a0).
+    rewrite (MapPut_semantics A m a y a0). 
+    case (ad_eq a a0); [ reflexivity | apply H ].
+  Qed.
+
+  Lemma MapPut_behind_as_Merge :
+   forall (m:Map A) (a:ad) (y:A),
+     eqmap (MapPut_behind A m a y) (MapMerge A (M1 A a y) m).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapPut_behind_semantics A m a y a0).
+    rewrite (MapMerge_semantics A (M1 A a y) m a0). reflexivity.
+  Qed.
+
+  Lemma MapPut_behind_ext :
+   forall m m':Map A,
+     eqmap m m' ->
+     forall (a:ad) (y:A),
+       eqmap (MapPut_behind A m a y) (MapPut_behind A m' a y).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapPut_behind_semantics A m' a y a0).
+    rewrite (MapPut_behind_semantics A m a y a0). rewrite (H a0). reflexivity.
+  Qed.
+
+  Lemma MapMerge_empty_m_1 : forall m:Map A, MapMerge A (M0 A) m = m.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapMerge_empty_m : forall m:Map A, eqmap (MapMerge A (M0 A) m) m.
+  Proof.
+    unfold eqmap, eqm in |- *. trivial.
+  Qed.
+
+  Lemma MapMerge_m_empty_1 : forall m:Map A, MapMerge A m (M0 A) = m.
+  Proof.
+    simple induction m; trivial.
+  Qed.
+
+  Lemma MapMerge_m_empty : forall m:Map A, eqmap (MapMerge A m (M0 A)) m.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite MapMerge_m_empty_1. reflexivity.
+  Qed.
+
+  Lemma MapMerge_empty_l :
+   forall m m':Map A, eqmap (MapMerge A m m') (M0 A) -> eqmap m (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. cut (MapGet A (MapMerge A m m') a = MapGet A (M0 A) a).
+    rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a). trivial.
+    intros. discriminate H0.
+    exact (H a).
+  Qed.
+
+  Lemma MapMerge_empty_r :
+   forall m m':Map A, eqmap (MapMerge A m m') (M0 A) -> eqmap m' (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. cut (MapGet A (MapMerge A m m') a = MapGet A (M0 A) a).
+    rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a). trivial.
+    intros. discriminate H0.
+    exact (H a).
+  Qed.
+
+  Lemma MapMerge_assoc :
+   forall m m' m'':Map A,
+     eqmap (MapMerge A (MapMerge A m m') m'')
+       (MapMerge A m (MapMerge A m' m'')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A (MapMerge A m m') m'' a).
+    rewrite (MapMerge_semantics A m (MapMerge A m' m'') a). rewrite (MapMerge_semantics A m m' a).
+    rewrite (MapMerge_semantics A m' m'' a).
+    case (MapGet A m'' a); case (MapGet A m' a); trivial.
+  Qed.
+
+  Lemma MapMerge_idempotent : forall m:Map A, eqmap (MapMerge A m m) m.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A m m a).
+    case (MapGet A m a); trivial.
+  Qed.
+
+  Lemma MapMerge_ext :
+   forall m1 m2 m'1 m'2:Map A,
+     eqmap m1 m'1 ->
+     eqmap m2 m'2 -> eqmap (MapMerge A m1 m2) (MapMerge A m'1 m'2).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A m1 m2 a).
+    rewrite (MapMerge_semantics A m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity.
+  Qed.
+
+  Lemma MapMerge_ext_l :
+   forall m1 m'1 m2:Map A,
+     eqmap m1 m'1 -> eqmap (MapMerge A m1 m2) (MapMerge A m'1 m2).
+  Proof.
+    intros. apply MapMerge_ext. assumption.
+    apply eqmap_refl.
+  Qed.
+
+  Lemma MapMerge_ext_r :
+   forall m1 m2 m'2:Map A,
+     eqmap m2 m'2 -> eqmap (MapMerge A m1 m2) (MapMerge A m1 m'2).
+  Proof.
+    intros. apply MapMerge_ext. apply eqmap_refl.
+    assumption.
+  Qed.
+
+  Lemma MapMerge_RestrTo_l :
+   forall m m' m'':Map A,
+     eqmap (MapMerge A (MapDomRestrTo A A m m') m'')
+       (MapDomRestrTo A A (MapMerge A m m'') (MapMerge A m' m'')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A (MapDomRestrTo A A m m') m'' a).
+    rewrite (MapDomRestrTo_semantics A A m m' a).
+    rewrite
+     (MapDomRestrTo_semantics A A (MapMerge A m m'') (MapMerge A m' m'') a)
+     .
+    rewrite (MapMerge_semantics A m' m'' a). rewrite (MapMerge_semantics A m m'' a).
+    case (MapGet A m'' a); case (MapGet A m' a); reflexivity.
+  Qed.
+
+  Lemma MapRemove_as_RestrBy :
+   forall (m:Map A) (a:ad) (y:B),
+     eqmap (MapRemove A m a) (MapDomRestrBy A B m (M1 B a y)).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapRemove_semantics A m a a0).
+    rewrite (MapDomRestrBy_semantics A B m (M1 B a y) a0). elim (sumbool_of_bool (ad_eq a a0)).
+    intro H. rewrite H. rewrite (ad_eq_complete a a0 H). rewrite (M1_semantics_1 B a0 y).
+    reflexivity.
+    intro H. rewrite H. rewrite (M1_semantics_2 B a a0 y H). reflexivity.
+  Qed.
+
+  Lemma MapRemove_ext :
+   forall m m':Map A,
+     eqmap m m' -> forall a:ad, eqmap (MapRemove A m a) (MapRemove A m' a).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapRemove_semantics A m' a a0).
+    rewrite (MapRemove_semantics A m a a0). 
+    case (ad_eq a a0); [ reflexivity | apply H ].
+  Qed.
+
+  Lemma MapDomRestrTo_empty_m_1 :
+   forall m:Map B, MapDomRestrTo A B (M0 A) m = M0 A.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_empty_m :
+   forall m:Map B, eqmap (MapDomRestrTo A B (M0 A) m) (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_m_empty_1 :
+   forall m:Map A, MapDomRestrTo A B m (M0 B) = M0 A.
+  Proof.
+    simple induction m; trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_m_empty :
+   forall m:Map A, eqmap (MapDomRestrTo A B m (M0 B)) (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_m_empty_1 m). reflexivity.
+  Qed.
+
+  Lemma MapDomRestrTo_assoc :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     eqmap (MapDomRestrTo A C (MapDomRestrTo A B m m') m'')
+       (MapDomRestrTo A B m (MapDomRestrTo B C m' m'')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDomRestrTo_semantics A C (MapDomRestrTo A B m m') m'' a).
+    rewrite (MapDomRestrTo_semantics A B m m' a).
+    rewrite (MapDomRestrTo_semantics A B m (MapDomRestrTo B C m' m'') a).
+    rewrite (MapDomRestrTo_semantics B C m' m'' a).
+    case (MapGet C m'' a); case (MapGet B m' a); trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_idempotent :
+   forall m:Map A, eqmap (MapDomRestrTo A A m m) m.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A A m m a).
+    case (MapGet A m a); trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_Dom :
+   forall (m:Map A) (m':Map B),
+     eqmap (MapDomRestrTo A B m m') (MapDomRestrTo A unit m (MapDom B m')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A B m m' a).
+    rewrite (MapDomRestrTo_semantics A unit m (MapDom B m') a).
+    elim (sumbool_of_bool (in_FSet a (MapDom B m'))). intro H.
+    elim (MapDom_semantics_2 B m' a H). intros y H0. rewrite H0. unfold in_FSet, in_dom in H.
+    generalize H. case (MapGet unit (MapDom B m') a); trivial. intro H1. discriminate H1.
+    intro H. rewrite (MapDom_semantics_4 B m' a H). unfold in_FSet, in_dom in H.
+    generalize H. case (MapGet unit (MapDom B m') a). trivial.
+    intros H0 H1. discriminate H1.
+  Qed.
+
+  Lemma MapDomRestrBy_empty_m_1 :
+   forall m:Map B, MapDomRestrBy A B (M0 A) m = M0 A.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapDomRestrBy_empty_m :
+   forall m:Map B, eqmap (MapDomRestrBy A B (M0 A) m) (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. trivial.
+  Qed.
+
+  Lemma MapDomRestrBy_m_empty_1 :
+   forall m:Map A, MapDomRestrBy A B m (M0 B) = m.
+  Proof.
+    simple induction m; trivial.
+  Qed.
+
+  Lemma MapDomRestrBy_m_empty :
+   forall m:Map A, eqmap (MapDomRestrBy A B m (M0 B)) m.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_m_empty_1 m). reflexivity.
+  Qed.
+
+  Lemma MapDomRestrBy_Dom :
+   forall (m:Map A) (m':Map B),
+     eqmap (MapDomRestrBy A B m m') (MapDomRestrBy A unit m (MapDom B m')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A B m m' a).
+    rewrite (MapDomRestrBy_semantics A unit m (MapDom B m') a).
+    elim (sumbool_of_bool (in_FSet a (MapDom B m'))). intro H.
+    elim (MapDom_semantics_2 B m' a H). intros y H0. rewrite H0.
+    unfold in_FSet, in_dom in H. generalize H. case (MapGet unit (MapDom B m') a); trivial.
+    intro H1. discriminate H1.
+    intro H. rewrite (MapDom_semantics_4 B m' a H). unfold in_FSet, in_dom in H.
+    generalize H. case (MapGet unit (MapDom B m') a). trivial.
+    intros H0 H1. discriminate H1.
+  Qed.
+
+  Lemma MapDomRestrBy_m_m_1 :
+   forall m:Map A, eqmap (MapDomRestrBy A A m m) (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A A m m a).
+    case (MapGet A m a); trivial.
+  Qed.
+
+  Lemma MapDomRestrBy_By :
+   forall (m:Map A) (m' m'':Map B),
+     eqmap (MapDomRestrBy A B (MapDomRestrBy A B m m') m'')
+       (MapDomRestrBy A B m (MapMerge B m' m'')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDomRestrBy_semantics A B (MapDomRestrBy A B m m') m'' a).
+    rewrite (MapDomRestrBy_semantics A B m m' a).
+    rewrite (MapDomRestrBy_semantics A B m (MapMerge B m' m'') a).
+    rewrite (MapMerge_semantics B m' m'' a).
+    case (MapGet B m'' a); case (MapGet B m' a); trivial.
+  Qed.
+
+  Lemma MapDomRestrBy_By_comm :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     eqmap (MapDomRestrBy A C (MapDomRestrBy A B m m') m'')
+       (MapDomRestrBy A B (MapDomRestrBy A C m m'') m').
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDomRestrBy_semantics A C (MapDomRestrBy A B m m') m'' a).
+    rewrite (MapDomRestrBy_semantics A B m m' a).
+    rewrite (MapDomRestrBy_semantics A B (MapDomRestrBy A C m m'') m' a).
+    rewrite (MapDomRestrBy_semantics A C m m'' a).
+    case (MapGet C m'' a); case (MapGet B m' a); trivial.
+  Qed.
+
+  Lemma MapDomRestrBy_To :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     eqmap (MapDomRestrBy A C (MapDomRestrTo A B m m') m'')
+       (MapDomRestrTo A B m (MapDomRestrBy B C m' m'')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDomRestrBy_semantics A C (MapDomRestrTo A B m m') m'' a).
+    rewrite (MapDomRestrTo_semantics A B m m' a).
+    rewrite (MapDomRestrTo_semantics A B m (MapDomRestrBy B C m' m'') a).
+    rewrite (MapDomRestrBy_semantics B C m' m'' a).
+    case (MapGet C m'' a); case (MapGet B m' a); trivial.
+  Qed.
+
+  Lemma MapDomRestrBy_To_comm :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     eqmap (MapDomRestrBy A C (MapDomRestrTo A B m m') m'')
+       (MapDomRestrTo A B (MapDomRestrBy A C m m'') m').
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDomRestrBy_semantics A C (MapDomRestrTo A B m m') m'' a).
+    rewrite (MapDomRestrTo_semantics A B m m' a).
+    rewrite (MapDomRestrTo_semantics A B (MapDomRestrBy A C m m'') m' a).
+    rewrite (MapDomRestrBy_semantics A C m m'' a).
+    case (MapGet C m'' a); case (MapGet B m' a); trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_By :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     eqmap (MapDomRestrTo A C (MapDomRestrBy A B m m') m'')
+       (MapDomRestrTo A C m (MapDomRestrBy C B m'' m')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDomRestrTo_semantics A C (MapDomRestrBy A B m m') m'' a).
+    rewrite (MapDomRestrBy_semantics A B m m' a).
+    rewrite (MapDomRestrTo_semantics A C m (MapDomRestrBy C B m'' m') a).
+    rewrite (MapDomRestrBy_semantics C B m'' m' a).
+    case (MapGet C m'' a); case (MapGet B m' a); trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_By_comm :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     eqmap (MapDomRestrTo A C (MapDomRestrBy A B m m') m'')
+       (MapDomRestrBy A B (MapDomRestrTo A C m m'') m').
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDomRestrTo_semantics A C (MapDomRestrBy A B m m') m'' a).
+    rewrite (MapDomRestrBy_semantics A B m m' a).
+    rewrite (MapDomRestrBy_semantics A B (MapDomRestrTo A C m m'') m' a).
+    rewrite (MapDomRestrTo_semantics A C m m'' a).
+    case (MapGet C m'' a); case (MapGet B m' a); trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_To_comm :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     eqmap (MapDomRestrTo A C (MapDomRestrTo A B m m') m'')
+       (MapDomRestrTo A B (MapDomRestrTo A C m m'') m').
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDomRestrTo_semantics A C (MapDomRestrTo A B m m') m'' a).
+    rewrite (MapDomRestrTo_semantics A B m m' a).
+    rewrite (MapDomRestrTo_semantics A B (MapDomRestrTo A C m m'') m' a).
+    rewrite (MapDomRestrTo_semantics A C m m'' a).
+    case (MapGet C m'' a); case (MapGet B m' a); trivial.
+  Qed.
+
+  Lemma MapMerge_DomRestrTo :
+   forall (m m':Map A) (m'':Map B),
+     eqmap (MapDomRestrTo A B (MapMerge A m m') m'')
+       (MapMerge A (MapDomRestrTo A B m m'') (MapDomRestrTo A B m' m'')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDomRestrTo_semantics A B (MapMerge A m m') m'' a).
+    rewrite (MapMerge_semantics A m m' a).
+    rewrite
+     (MapMerge_semantics A (MapDomRestrTo A B m m'')
+        (MapDomRestrTo A B m' m'') a).
+    rewrite (MapDomRestrTo_semantics A B m' m'' a).
+    rewrite (MapDomRestrTo_semantics A B m m'' a).
+    case (MapGet B m'' a); case (MapGet A m' a); trivial.
+  Qed.
+
+  Lemma MapMerge_DomRestrBy :
+   forall (m m':Map A) (m'':Map B),
+     eqmap (MapDomRestrBy A B (MapMerge A m m') m'')
+       (MapMerge A (MapDomRestrBy A B m m'') (MapDomRestrBy A B m' m'')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDomRestrBy_semantics A B (MapMerge A m m') m'' a).
+    rewrite (MapMerge_semantics A m m' a).
+    rewrite
+     (MapMerge_semantics A (MapDomRestrBy A B m m'')
+        (MapDomRestrBy A B m' m'') a).
+    rewrite (MapDomRestrBy_semantics A B m' m'' a).
+    rewrite (MapDomRestrBy_semantics A B m m'' a).
+    case (MapGet B m'' a); case (MapGet A m' a); trivial.
+  Qed.
+
+  Lemma MapDelta_empty_m_1 : forall m:Map A, MapDelta A (M0 A) m = m.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapDelta_empty_m : forall m:Map A, eqmap (MapDelta A (M0 A) m) m.
+  Proof.
+    unfold eqmap, eqm in |- *. trivial.
+  Qed.
+
+  Lemma MapDelta_m_empty_1 : forall m:Map A, MapDelta A m (M0 A) = m.
+  Proof.
+    simple induction m; trivial.
+  Qed.
+
+  Lemma MapDelta_m_empty : forall m:Map A, eqmap (MapDelta A m (M0 A)) m.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite MapDelta_m_empty_1. reflexivity.
+  Qed.
+
+  Lemma MapDelta_nilpotent : forall m:Map A, eqmap (MapDelta A m m) (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m a).
+    case (MapGet A m a); trivial.
+  Qed.
+
+  Lemma MapDelta_as_Merge :
+   forall m m':Map A,
+     eqmap (MapDelta A m m')
+       (MapMerge A (MapDomRestrBy A A m m') (MapDomRestrBy A A m' m)).
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDelta_semantics A m m' a).
+    rewrite
+     (MapMerge_semantics A (MapDomRestrBy A A m m') (
+        MapDomRestrBy A A m' m) a).
+    rewrite (MapDomRestrBy_semantics A A m' m a).
+    rewrite (MapDomRestrBy_semantics A A m m' a).
+    case (MapGet A m a); case (MapGet A m' a); trivial.
+  Qed.
+
+  Lemma MapDelta_as_DomRestrBy :
+   forall m m':Map A,
+     eqmap (MapDelta A m m')
+       (MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a).
+    rewrite
+     (MapDomRestrBy_semantics A A (MapMerge A m m') (
+        MapDomRestrTo A A m m') a).
+    rewrite (MapDomRestrTo_semantics A A m m' a). rewrite (MapMerge_semantics A m m' a).
+    case (MapGet A m a); case (MapGet A m' a); trivial.
+  Qed.
+
+  Lemma MapDelta_as_DomRestrBy_2 :
+   forall m m':Map A,
+     eqmap (MapDelta A m m')
+       (MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m' m)).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a).
+    rewrite
+     (MapDomRestrBy_semantics A A (MapMerge A m m') (
+        MapDomRestrTo A A m' m) a).
+    rewrite (MapDomRestrTo_semantics A A m' m a). rewrite (MapMerge_semantics A m m' a).
+    case (MapGet A m a); case (MapGet A m' a); trivial.
+  Qed.
+
+  Lemma MapDelta_sym :
+   forall m m':Map A, eqmap (MapDelta A m m') (MapDelta A m' m).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a).
+    rewrite (MapDelta_semantics A m' m a). 
+    case (MapGet A m a); case (MapGet A m' a); trivial.
+  Qed.
+
+  Lemma MapDelta_ext :
+   forall m1 m2 m'1 m'2:Map A,
+     eqmap m1 m'1 ->
+     eqmap m2 m'2 -> eqmap (MapDelta A m1 m2) (MapDelta A m'1 m'2).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m1 m2 a).
+    rewrite (MapDelta_semantics A m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity.
+  Qed.
+
+  Lemma MapDelta_ext_l :
+   forall m1 m'1 m2:Map A,
+     eqmap m1 m'1 -> eqmap (MapDelta A m1 m2) (MapDelta A m'1 m2).
+  Proof.
+    intros. apply MapDelta_ext. assumption.
+    apply eqmap_refl.
+  Qed.
+
+  Lemma MapDelta_ext_r :
+   forall m1 m2 m'2:Map A,
+     eqmap m2 m'2 -> eqmap (MapDelta A m1 m2) (MapDelta A m1 m'2).
+  Proof.
+    intros. apply MapDelta_ext. apply eqmap_refl.
+    assumption.
+  Qed.
+
+  Lemma MapDom_Split_1 :
+   forall (m:Map A) (m':Map B),
+     eqmap m (MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite
+     (MapMerge_semantics A (MapDomRestrTo A B m m') (
+        MapDomRestrBy A B m m') a).
+    rewrite (MapDomRestrBy_semantics A B m m' a).
+    rewrite (MapDomRestrTo_semantics A B m m' a).
+    case (MapGet B m' a); case (MapGet A m a); trivial.
+  Qed.
+ 
+  Lemma MapDom_Split_2 :
+   forall (m:Map A) (m':Map B),
+     eqmap m (MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m')).
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite
+     (MapMerge_semantics A (MapDomRestrBy A B m m') (
+        MapDomRestrTo A B m m') a).
+    rewrite (MapDomRestrBy_semantics A B m m' a).
+    rewrite (MapDomRestrTo_semantics A B m m' a).
+    case (MapGet B m' a); case (MapGet A m a); trivial.
+  Qed.
+
+  Lemma MapDom_Split_3 :
+   forall (m:Map A) (m':Map B),
+     eqmap
+       (MapDomRestrTo A A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m'))
+       (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. intros.
+    rewrite
+     (MapDomRestrTo_semantics A A (MapDomRestrTo A B m m')
+        (MapDomRestrBy A B m m') a).
+    rewrite (MapDomRestrBy_semantics A B m m' a).
+    rewrite (MapDomRestrTo_semantics A B m m' a).
+    case (MapGet B m' a); case (MapGet A m a); trivial.
+  Qed.
+
+End MapAxioms.
+
+Lemma MapDomRestrTo_ext :
+ forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A) 
+   (m'2:Map B),
+   eqmap A m1 m'1 ->
+   eqmap B m2 m'2 ->
+   eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m'1 m'2).
+Proof.
+  unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A B m1 m2 a).
+  rewrite (MapDomRestrTo_semantics A B m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity.
+Qed.
+
+Lemma MapDomRestrTo_ext_l :
+ forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A),
+   eqmap A m1 m'1 ->
+   eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m'1 m2).
+Proof.
+  intros. apply MapDomRestrTo_ext; [ assumption | apply eqmap_refl ].
+Qed.
+
+Lemma MapDomRestrTo_ext_r :
+ forall (A B:Set) (m1:Map A) (m2 m'2:Map B),
+   eqmap B m2 m'2 ->
+   eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m1 m'2).
+Proof.
+  intros. apply MapDomRestrTo_ext; [ apply eqmap_refl | assumption ].
+Qed.
+
+Lemma MapDomRestrBy_ext :
+ forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A) 
+   (m'2:Map B),
+   eqmap A m1 m'1 ->
+   eqmap B m2 m'2 ->
+   eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m'1 m'2).
+Proof.
+  unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A B m1 m2 a).
+  rewrite (MapDomRestrBy_semantics A B m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity.
+Qed.
+
+Lemma MapDomRestrBy_ext_l :
+ forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A),
+   eqmap A m1 m'1 ->
+   eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m'1 m2).
+Proof.
+  intros. apply MapDomRestrBy_ext; [ assumption | apply eqmap_refl ].
+Qed.
+
+Lemma MapDomRestrBy_ext_r :
+ forall (A B:Set) (m1:Map A) (m2 m'2:Map B),
+   eqmap B m2 m'2 ->
+   eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m1 m'2).
+Proof.
+  intros. apply MapDomRestrBy_ext; [ apply eqmap_refl | assumption ].
+Qed.
+
+Lemma MapDomRestrBy_m_m :
+ forall (A:Set) (m:Map A),
+   eqmap A (MapDomRestrBy A unit m (MapDom A m)) (M0 A).
+Proof.
+  intros. apply eqmap_trans with (m' := MapDomRestrBy A A m m). apply eqmap_sym.
+  apply MapDomRestrBy_Dom.
+  apply MapDomRestrBy_m_m_1.
+Qed.
+
+Lemma FSetDelta_assoc :
+ forall s s' s'':FSet,
+   eqmap unit (MapDelta _ (MapDelta _ s s') s'')
+     (MapDelta _ s (MapDelta _ s' s'')).
+Proof.
+  unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics unit (MapDelta unit s s') s'' a).
+  rewrite (MapDelta_semantics unit s s' a).
+  rewrite (MapDelta_semantics unit s (MapDelta unit s' s'') a).
+  rewrite (MapDelta_semantics unit s' s'' a).
+  case (MapGet _ s a); case (MapGet _ s' a); case (MapGet _ s'' a); trivial.
+  intros. elim u. elim u1. reflexivity.
+Qed.
+
+Lemma FSet_ext :
+ forall s s':FSet,
+   (forall a:ad, in_FSet a s = in_FSet a s') -> eqmap unit s s'.
+Proof.
+  unfold in_FSet, eqmap, eqm in |- *. intros. elim (sumbool_of_bool (in_dom _ a s)). intro H0.
+  elim (in_dom_some _ s a H0). intros y H1. rewrite (H a) in H0. elim (in_dom_some _ s' a H0).
+  intros y' H2. rewrite H1. rewrite H2. elim y. elim y'. reflexivity.
+  intro H0. rewrite (in_dom_none _ s a H0). rewrite (H a) in H0. rewrite (in_dom_none _ s' a H0).
+  reflexivity.
+Qed.
+
+Lemma FSetUnion_comm :
+ forall s s':FSet, eqmap unit (FSetUnion s s') (FSetUnion s' s).
+Proof.
+  intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_union. apply orb_comm.
+Qed.
+
+Lemma FSetUnion_assoc :
+ forall s s' s'':FSet,
+   eqmap unit (FSetUnion (FSetUnion s s') s'')
+     (FSetUnion s (FSetUnion s' s'')).
+Proof.
+  exact (MapMerge_assoc unit).
+Qed.
+
+Lemma FSetUnion_M0_s : forall s:FSet, eqmap unit (FSetUnion (M0 unit) s) s.
+Proof.
+  exact (MapMerge_empty_m unit).
+Qed.
+
+Lemma FSetUnion_s_M0 : forall s:FSet, eqmap unit (FSetUnion s (M0 unit)) s.
+Proof.
+  exact (MapMerge_m_empty unit).
+Qed.
+
+Lemma FSetUnion_idempotent : forall s:FSet, eqmap unit (FSetUnion s s) s.
+Proof.
+  exact (MapMerge_idempotent unit).
+Qed.
+
+Lemma FSetInter_comm :
+ forall s s':FSet, eqmap unit (FSetInter s s') (FSetInter s' s).
+Proof.
+  intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_inter. apply andb_comm.
+Qed.
+
+Lemma FSetInter_assoc :
+ forall s s' s'':FSet,
+   eqmap unit (FSetInter (FSetInter s s') s'')
+     (FSetInter s (FSetInter s' s'')).
+Proof.
+  exact (MapDomRestrTo_assoc unit unit unit).
+Qed.
+
+Lemma FSetInter_M0_s :
+ forall s:FSet, eqmap unit (FSetInter (M0 unit) s) (M0 unit).
+Proof.
+  exact (MapDomRestrTo_empty_m unit unit).
+Qed.
+
+Lemma FSetInter_s_M0 :
+ forall s:FSet, eqmap unit (FSetInter s (M0 unit)) (M0 unit).
+Proof.
+  exact (MapDomRestrTo_m_empty unit unit).
+Qed.
+
+Lemma FSetInter_idempotent : forall s:FSet, eqmap unit (FSetInter s s) s.
+Proof.
+  exact (MapDomRestrTo_idempotent unit).
+Qed.
+
+Lemma FSetUnion_Inter_l :
+ forall s s' s'':FSet,
+   eqmap unit (FSetUnion (FSetInter s s') s'')
+     (FSetInter (FSetUnion s s'') (FSetUnion s' s'')).
+Proof.
+  intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_inter.
+  rewrite in_FSet_inter. rewrite in_FSet_union. rewrite in_FSet_union.
+  case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity.
+Qed.
+
+Lemma FSetUnion_Inter_r :
+ forall s s' s'':FSet,
+   eqmap unit (FSetUnion s (FSetInter s' s''))
+     (FSetInter (FSetUnion s s') (FSetUnion s s'')).
+Proof.
+  intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_inter.
+  rewrite in_FSet_inter. rewrite in_FSet_union. rewrite in_FSet_union.
+  case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity.
+Qed.
+
+Lemma FSetInter_Union_l :
+ forall s s' s'':FSet,
+   eqmap unit (FSetInter (FSetUnion s s') s'')
+     (FSetUnion (FSetInter s s'') (FSetInter s' s'')).
+Proof.
+  intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_union.
+  rewrite in_FSet_union. rewrite in_FSet_inter. rewrite in_FSet_inter.
+  case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity.
+Qed.
+
+Lemma FSetInter_Union_r :
+ forall s s' s'':FSet,
+   eqmap unit (FSetInter s (FSetUnion s' s''))
+     (FSetUnion (FSetInter s s') (FSetInter s s'')).
+Proof.
+  intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_union.
+  rewrite in_FSet_union. rewrite in_FSet_inter. rewrite in_FSet_inter.
+  case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity.
+Qed.
\ No newline at end of file
diff --git a/theories/IntMap/Mapc.v b/theories/IntMap/Mapc.v
new file mode 100644
index 00000000..7a394abb
--- /dev/null
+++ b/theories/IntMap/Mapc.v
@@ -0,0 +1,542 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Mapc.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Mapaxioms.
+Require Import Fset.
+Require Import Mapiter.
+Require Import Mapsubset.
+Require Import List.
+Require Import Lsort.
+Require Import Mapcard.
+Require Import Mapcanon.
+
+Section MapC.
+
+  Variables A B C : Set.
+
+  Lemma MapPut_as_Merge_c :
+   forall m:Map A,
+     mapcanon A m ->
+     forall (a:ad) (y:A), MapPut A m a y = MapMerge A m (M1 A a y).
+  Proof.
+    intros. apply mapcanon_unique. exact (MapPut_canon A m H a y).
+    apply MapMerge_canon. assumption.
+    apply M1_canon.
+    apply MapPut_as_Merge.
+  Qed.
+
+  Lemma MapPut_behind_as_Merge_c :
+   forall m:Map A,
+     mapcanon A m ->
+     forall (a:ad) (y:A), MapPut_behind A m a y = MapMerge A (M1 A a y) m.
+  Proof.
+    intros. apply mapcanon_unique. exact (MapPut_behind_canon A m H a y).
+    apply MapMerge_canon. apply M1_canon.
+    assumption.
+    apply MapPut_behind_as_Merge.
+  Qed.
+
+  Lemma MapMerge_empty_m_c : forall m:Map A, MapMerge A (M0 A) m = m.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapMerge_assoc_c :
+   forall m m' m'':Map A,
+     mapcanon A m ->
+     mapcanon A m' ->
+     mapcanon A m'' ->
+     MapMerge A (MapMerge A m m') m'' = MapMerge A m (MapMerge A m' m'').
+  Proof.
+    intros. apply mapcanon_unique.
+    apply MapMerge_canon; try assumption. apply MapMerge_canon; try assumption.
+    apply MapMerge_canon; try assumption. apply MapMerge_canon; try assumption.
+    apply MapMerge_assoc.
+  Qed.
+
+  Lemma MapMerge_idempotent_c :
+   forall m:Map A, mapcanon A m -> MapMerge A m m = m.
+  Proof.
+    intros. apply mapcanon_unique. apply MapMerge_canon; assumption.
+    assumption.
+    apply MapMerge_idempotent.
+  Qed.
+
+  Lemma MapMerge_RestrTo_l_c :
+   forall m m' m'':Map A,
+     mapcanon A m ->
+     mapcanon A m'' ->
+     MapMerge A (MapDomRestrTo A A m m') m'' =
+     MapDomRestrTo A A (MapMerge A m m'') (MapMerge A m' m'').
+  Proof.
+    intros. apply mapcanon_unique. apply MapMerge_canon. apply MapDomRestrTo_canon; assumption.
+    assumption.
+    apply MapDomRestrTo_canon; apply MapMerge_canon; assumption.
+    apply MapMerge_RestrTo_l.
+  Qed.
+
+  Lemma MapRemove_as_RestrBy_c :
+   forall m:Map A,
+     mapcanon A m ->
+     forall (a:ad) (y:B), MapRemove A m a = MapDomRestrBy A B m (M1 B a y).
+  Proof.
+    intros. apply mapcanon_unique. apply MapRemove_canon; assumption.
+    apply MapDomRestrBy_canon; assumption.
+    apply MapRemove_as_RestrBy.
+  Qed.
+
+  Lemma MapDomRestrTo_assoc_c :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     mapcanon A m ->
+     MapDomRestrTo A C (MapDomRestrTo A B m m') m'' =
+     MapDomRestrTo A B m (MapDomRestrTo B C m' m'').
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrTo_canon; try assumption.
+    apply MapDomRestrTo_canon; try assumption.
+    apply MapDomRestrTo_canon; try assumption.
+    apply MapDomRestrTo_assoc.
+  Qed.
+
+  Lemma MapDomRestrTo_idempotent_c :
+   forall m:Map A, mapcanon A m -> MapDomRestrTo A A m m = m.
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrTo_canon; assumption.
+    assumption.
+    apply MapDomRestrTo_idempotent.
+  Qed.
+
+  Lemma MapDomRestrTo_Dom_c :
+   forall (m:Map A) (m':Map B),
+     mapcanon A m ->
+     MapDomRestrTo A B m m' = MapDomRestrTo A unit m (MapDom B m').
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrTo_canon; assumption.
+    apply MapDomRestrTo_canon; assumption.
+    apply MapDomRestrTo_Dom.
+  Qed.
+
+  Lemma MapDomRestrBy_Dom_c :
+   forall (m:Map A) (m':Map B),
+     mapcanon A m ->
+     MapDomRestrBy A B m m' = MapDomRestrBy A unit m (MapDom B m').
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrBy_canon; assumption.
+    apply MapDomRestrBy_canon; assumption.
+    apply MapDomRestrBy_Dom.
+  Qed.
+
+  Lemma MapDomRestrBy_By_c :
+   forall (m:Map A) (m' m'':Map B),
+     mapcanon A m ->
+     MapDomRestrBy A B (MapDomRestrBy A B m m') m'' =
+     MapDomRestrBy A B m (MapMerge B m' m'').
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrBy_canon; try assumption.
+    apply MapDomRestrBy_canon; try assumption.
+    apply MapDomRestrBy_canon; try assumption.
+    apply MapDomRestrBy_By.
+  Qed.
+
+  Lemma MapDomRestrBy_By_comm_c :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     mapcanon A m ->
+     MapDomRestrBy A C (MapDomRestrBy A B m m') m'' =
+     MapDomRestrBy A B (MapDomRestrBy A C m m'') m'.
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrBy_canon.
+    apply MapDomRestrBy_canon; assumption.
+    apply MapDomRestrBy_canon. apply MapDomRestrBy_canon; assumption.
+    apply MapDomRestrBy_By_comm.
+  Qed.
+
+  Lemma MapDomRestrBy_To_c :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     mapcanon A m ->
+     MapDomRestrBy A C (MapDomRestrTo A B m m') m'' =
+     MapDomRestrTo A B m (MapDomRestrBy B C m' m'').
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrBy_canon.
+    apply MapDomRestrTo_canon; assumption.
+    apply MapDomRestrTo_canon; assumption.
+    apply MapDomRestrBy_To.
+  Qed.
+
+  Lemma MapDomRestrBy_To_comm_c :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     mapcanon A m ->
+     MapDomRestrBy A C (MapDomRestrTo A B m m') m'' =
+     MapDomRestrTo A B (MapDomRestrBy A C m m'') m'.
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrBy_canon.
+    apply MapDomRestrTo_canon; assumption.
+    apply MapDomRestrTo_canon. apply MapDomRestrBy_canon; assumption.
+    apply MapDomRestrBy_To_comm.
+  Qed.
+
+  Lemma MapDomRestrTo_By_c :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     mapcanon A m ->
+     MapDomRestrTo A C (MapDomRestrBy A B m m') m'' =
+     MapDomRestrTo A C m (MapDomRestrBy C B m'' m').
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrTo_canon.
+    apply MapDomRestrBy_canon; assumption.
+    apply MapDomRestrTo_canon; assumption.
+    apply MapDomRestrTo_By.
+  Qed.
+
+  Lemma MapDomRestrTo_By_comm_c :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     mapcanon A m ->
+     MapDomRestrTo A C (MapDomRestrBy A B m m') m'' =
+     MapDomRestrBy A B (MapDomRestrTo A C m m'') m'.
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrTo_canon.
+    apply MapDomRestrBy_canon; assumption.
+    apply MapDomRestrBy_canon. apply MapDomRestrTo_canon; assumption.
+    apply MapDomRestrTo_By_comm.
+  Qed.
+
+  Lemma MapDomRestrTo_To_comm_c :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     mapcanon A m ->
+     MapDomRestrTo A C (MapDomRestrTo A B m m') m'' =
+     MapDomRestrTo A B (MapDomRestrTo A C m m'') m'.
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrTo_canon.
+    apply MapDomRestrTo_canon; assumption.
+    apply MapDomRestrTo_canon. apply MapDomRestrTo_canon; assumption.
+    apply MapDomRestrTo_To_comm.
+  Qed.
+
+  Lemma MapMerge_DomRestrTo_c :
+   forall (m m':Map A) (m'':Map B),
+     mapcanon A m ->
+     mapcanon A m' ->
+     MapDomRestrTo A B (MapMerge A m m') m'' =
+     MapMerge A (MapDomRestrTo A B m m'') (MapDomRestrTo A B m' m'').
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrTo_canon.
+    apply MapMerge_canon; assumption.
+    apply MapMerge_canon. apply MapDomRestrTo_canon; assumption.
+    apply MapDomRestrTo_canon; assumption.
+    apply MapMerge_DomRestrTo.
+  Qed.
+
+  Lemma MapMerge_DomRestrBy_c :
+   forall (m m':Map A) (m'':Map B),
+     mapcanon A m ->
+     mapcanon A m' ->
+     MapDomRestrBy A B (MapMerge A m m') m'' =
+     MapMerge A (MapDomRestrBy A B m m'') (MapDomRestrBy A B m' m'').
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrBy_canon. apply MapMerge_canon; assumption.
+    apply MapMerge_canon. apply MapDomRestrBy_canon; assumption.
+    apply MapDomRestrBy_canon; assumption.
+    apply MapMerge_DomRestrBy.
+  Qed.
+
+  Lemma MapDelta_nilpotent_c :
+   forall m:Map A, mapcanon A m -> MapDelta A m m = M0 A.
+  Proof.
+    intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
+    apply M0_canon.
+    apply MapDelta_nilpotent.
+  Qed.
+
+  Lemma MapDelta_as_Merge_c :
+   forall m m':Map A,
+     mapcanon A m ->
+     mapcanon A m' ->
+     MapDelta A m m' =
+     MapMerge A (MapDomRestrBy A A m m') (MapDomRestrBy A A m' m).
+  Proof.
+    intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
+    apply MapMerge_canon; apply MapDomRestrBy_canon; assumption.
+    apply MapDelta_as_Merge.
+  Qed.
+
+  Lemma MapDelta_as_DomRestrBy_c :
+   forall m m':Map A,
+     mapcanon A m ->
+     mapcanon A m' ->
+     MapDelta A m m' =
+     MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m').
+  Proof.
+    intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
+    apply MapDomRestrBy_canon. apply MapMerge_canon; assumption.
+    apply MapDelta_as_DomRestrBy.
+  Qed.
+
+  Lemma MapDelta_as_DomRestrBy_2_c :
+   forall m m':Map A,
+     mapcanon A m ->
+     mapcanon A m' ->
+     MapDelta A m m' =
+     MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m' m).
+  Proof.
+    intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
+    apply MapDomRestrBy_canon. apply MapMerge_canon; assumption.
+    apply MapDelta_as_DomRestrBy_2.
+  Qed.
+
+  Lemma MapDelta_sym_c :
+   forall m m':Map A,
+     mapcanon A m -> mapcanon A m' -> MapDelta A m m' = MapDelta A m' m.
+  Proof.
+    intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
+    apply MapDelta_canon; assumption. apply MapDelta_sym.
+  Qed.
+
+  Lemma MapDom_Split_1_c :
+   forall (m:Map A) (m':Map B),
+     mapcanon A m ->
+     m = MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m').
+  Proof.
+    intros. apply mapcanon_unique. assumption.
+    apply MapMerge_canon. apply MapDomRestrTo_canon; assumption.
+    apply MapDomRestrBy_canon; assumption.
+    apply MapDom_Split_1.
+  Qed.
+
+  Lemma MapDom_Split_2_c :
+   forall (m:Map A) (m':Map B),
+     mapcanon A m ->
+     m = MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m').
+  Proof.
+    intros. apply mapcanon_unique. assumption.
+    apply MapMerge_canon. apply MapDomRestrBy_canon; assumption.
+    apply MapDomRestrTo_canon; assumption.
+    apply MapDom_Split_2.
+  Qed.
+
+  Lemma MapDom_Split_3_c :
+   forall (m:Map A) (m':Map B),
+     mapcanon A m ->
+     MapDomRestrTo A A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m') =
+     M0 A.
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrTo_canon.
+    apply MapDomRestrTo_canon; assumption.
+    apply M0_canon.
+    apply MapDom_Split_3.
+  Qed.
+
+  Lemma Map_of_alist_of_Map_c :
+   forall m:Map A, mapcanon A m -> Map_of_alist A (alist_of_Map A m) = m.
+  Proof.
+    intros. apply mapcanon_unique; try assumption. apply Map_of_alist_canon.
+    apply Map_of_alist_of_Map.
+  Qed.
+
+  Lemma alist_of_Map_of_alist_c :
+   forall l:alist A,
+     alist_sorted_2 A l -> alist_of_Map A (Map_of_alist A l) = l.
+  Proof.
+    intros. apply alist_canonical. apply alist_of_Map_of_alist.
+    apply alist_of_Map_sorts2.
+    assumption.
+  Qed.
+
+  Lemma MapSubset_antisym_c :
+   forall (m:Map A) (m':Map B),
+     mapcanon A m ->
+     mapcanon B m' ->
+     MapSubset A B m m' -> MapSubset B A m' m -> MapDom A m = MapDom B m'.
+  Proof.
+    intros. apply (mapcanon_unique unit). apply MapDom_canon; assumption.
+    apply MapDom_canon; assumption.
+    apply MapSubset_antisym; assumption.
+  Qed.
+
+  Lemma FSubset_antisym_c :
+   forall s s':FSet,
+     mapcanon unit s ->
+     mapcanon unit s' -> MapSubset _ _ s s' -> MapSubset _ _ s' s -> s = s'.
+  Proof.
+    intros. apply (mapcanon_unique unit); try assumption. apply FSubset_antisym; assumption.
+  Qed.
+
+  Lemma MapDisjoint_empty_c :
+   forall m:Map A, mapcanon A m -> MapDisjoint A A m m -> m = M0 A.
+  Proof.
+    intros. apply mapcanon_unique; try assumption; try apply M0_canon.
+    apply MapDisjoint_empty; assumption.
+  Qed.
+
+  Lemma MapDelta_disjoint_c :
+   forall m m':Map A,
+     mapcanon A m ->
+     mapcanon A m' ->
+     MapDisjoint A A m m' -> MapDelta A m m' = MapMerge A m m'.
+  Proof.
+    intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
+    apply MapMerge_canon; assumption. apply MapDelta_disjoint; assumption.
+  Qed.
+
+End MapC.
+
+Lemma FSetDelta_assoc_c :
+ forall s s' s'':FSet,
+   mapcanon unit s ->
+   mapcanon unit s' ->
+   mapcanon unit s'' ->
+   MapDelta _ (MapDelta _ s s') s'' = MapDelta _ s (MapDelta _ s' s'').
+Proof.
+  intros. apply (mapcanon_unique unit). apply MapDelta_canon. apply MapDelta_canon; assumption.
+  assumption.
+  apply MapDelta_canon. assumption.
+  apply MapDelta_canon; assumption.
+  apply FSetDelta_assoc; assumption.
+Qed.
+
+Lemma FSet_ext_c :
+ forall s s':FSet,
+   mapcanon unit s ->
+   mapcanon unit s' -> (forall a:ad, in_FSet a s = in_FSet a s') -> s = s'.
+Proof.
+  intros. apply (mapcanon_unique unit); try assumption. apply FSet_ext. assumption.
+Qed.
+
+Lemma FSetUnion_comm_c :
+ forall s s':FSet,
+   mapcanon unit s -> mapcanon unit s' -> FSetUnion s s' = FSetUnion s' s.
+Proof.
+  intros.
+  apply (mapcanon_unique unit);
+   try (unfold FSetUnion in |- *; apply MapMerge_canon; assumption).
+  apply FSetUnion_comm.
+Qed.
+
+Lemma FSetUnion_assoc_c :
+ forall s s' s'':FSet,
+   mapcanon unit s ->
+   mapcanon unit s' ->
+   mapcanon unit s'' ->
+   FSetUnion (FSetUnion s s') s'' = FSetUnion s (FSetUnion s' s'').
+Proof.
+  exact (MapMerge_assoc_c unit).
+Qed.
+
+Lemma FSetUnion_M0_s_c : forall s:FSet, FSetUnion (M0 unit) s = s.
+Proof.
+  exact (MapMerge_empty_m_c unit).
+Qed.
+
+Lemma FSetUnion_s_M0_c : forall s:FSet, FSetUnion s (M0 unit) = s.
+Proof.
+  exact (MapMerge_m_empty_1 unit).
+Qed.
+
+Lemma FSetUnion_idempotent :
+ forall s:FSet, mapcanon unit s -> FSetUnion s s = s.
+Proof.
+  exact (MapMerge_idempotent_c unit).
+Qed.
+
+Lemma FSetInter_comm_c :
+ forall s s':FSet,
+   mapcanon unit s -> mapcanon unit s' -> FSetInter s s' = FSetInter s' s.
+Proof.
+  intros.
+  apply (mapcanon_unique unit);
+   try (unfold FSetInter in |- *; apply MapDomRestrTo_canon; assumption).
+  apply FSetInter_comm.
+Qed.
+
+Lemma FSetInter_assoc_c :
+ forall s s' s'':FSet,
+   mapcanon unit s ->
+   FSetInter (FSetInter s s') s'' = FSetInter s (FSetInter s' s'').
+Proof.
+  exact (MapDomRestrTo_assoc_c unit unit unit).
+Qed.
+
+Lemma FSetInter_M0_s_c : forall s:FSet, FSetInter (M0 unit) s = M0 unit.
+Proof.
+  trivial.
+Qed.
+
+Lemma FSetInter_s_M0_c : forall s:FSet, FSetInter s (M0 unit) = M0 unit.
+Proof.
+  exact (MapDomRestrTo_m_empty_1 unit unit).
+Qed.
+
+Lemma FSetInter_idempotent :
+ forall s:FSet, mapcanon unit s -> FSetInter s s = s.
+Proof.
+  exact (MapDomRestrTo_idempotent_c unit).
+Qed.
+
+Lemma FSetUnion_Inter_l_c :
+ forall s s' s'':FSet,
+   mapcanon unit s ->
+   mapcanon unit s'' ->
+   FSetUnion (FSetInter s s') s'' =
+   FSetInter (FSetUnion s s'') (FSetUnion s' s'').
+Proof.
+  intros. apply (mapcanon_unique unit). unfold FSetUnion in |- *. apply MapMerge_canon; try assumption.
+  unfold FSetInter in |- *. apply MapDomRestrTo_canon; assumption.
+  unfold FSetInter in |- *; unfold FSetUnion in |- *;
+   apply MapDomRestrTo_canon; apply MapMerge_canon; 
+   assumption.
+  apply FSetUnion_Inter_l.
+Qed.
+
+Lemma FSetUnion_Inter_r :
+ forall s s' s'':FSet,
+   mapcanon unit s ->
+   mapcanon unit s' ->
+   FSetUnion s (FSetInter s' s'') =
+   FSetInter (FSetUnion s s') (FSetUnion s s'').
+Proof.
+  intros. apply (mapcanon_unique unit). unfold FSetUnion in |- *. apply MapMerge_canon; try assumption.
+  unfold FSetInter in |- *. apply MapDomRestrTo_canon; assumption.
+  unfold FSetInter in |- *; unfold FSetUnion in |- *;
+   apply MapDomRestrTo_canon; apply MapMerge_canon; 
+   assumption.
+  apply FSetUnion_Inter_r.
+Qed.
+
+Lemma FSetInter_Union_l_c :
+ forall s s' s'':FSet,
+   mapcanon unit s ->
+   mapcanon unit s' ->
+   FSetInter (FSetUnion s s') s'' =
+   FSetUnion (FSetInter s s'') (FSetInter s' s'').
+Proof.
+  intros. apply (mapcanon_unique unit). unfold FSetInter in |- *.
+  apply MapDomRestrTo_canon; try assumption. unfold FSetUnion in |- *.
+  apply MapMerge_canon; assumption.
+  unfold FSetUnion in |- *; unfold FSetInter in |- *; apply MapMerge_canon;
+   apply MapDomRestrTo_canon; assumption.
+  apply FSetInter_Union_l.
+Qed.
+
+Lemma FSetInter_Union_r :
+ forall s s' s'':FSet,
+   mapcanon unit s ->
+   mapcanon unit s' ->
+   FSetInter s (FSetUnion s' s'') =
+   FSetUnion (FSetInter s s') (FSetInter s s'').
+Proof.
+  intros. apply (mapcanon_unique unit). unfold FSetInter in |- *.
+  apply MapDomRestrTo_canon; try assumption.
+  unfold FSetUnion in |- *. apply MapMerge_canon; unfold FSetInter in |- *; apply MapDomRestrTo_canon;
+  assumption.
+  apply FSetInter_Union_r.
+Qed.
\ No newline at end of file
diff --git a/theories/IntMap/Mapcanon.v b/theories/IntMap/Mapcanon.v
new file mode 100644
index 00000000..868fbe5e
--- /dev/null
+++ b/theories/IntMap/Mapcanon.v
@@ -0,0 +1,399 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Mapcanon.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Mapaxioms.
+Require Import Mapiter.
+Require Import Fset.
+Require Import List.
+Require Import Lsort.
+Require Import Mapsubset.
+Require Import Mapcard.
+
+Section MapCanon.
+
+  Variable A : Set.
+
+  Inductive mapcanon : Map A -> Prop :=
+    | M0_canon : mapcanon (M0 A)
+    | M1_canon : forall (a:ad) (y:A), mapcanon (M1 A a y)
+    | M2_canon :
+        forall m1 m2:Map A,
+          mapcanon m1 ->
+          mapcanon m2 -> 2 <= MapCard A (M2 A m1 m2) -> mapcanon (M2 A m1 m2).
+
+  Lemma mapcanon_M2 :
+   forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> 2 <= MapCard A (M2 A m1 m2).
+  Proof.
+    intros. inversion H. assumption.
+  Qed.
+
+  Lemma mapcanon_M2_1 :
+   forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m1.
+  Proof.
+    intros. inversion H. assumption.
+  Qed.
+
+  Lemma mapcanon_M2_2 :
+   forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m2.
+  Proof.
+    intros. inversion H. assumption.
+  Qed.
+
+  Lemma M2_eqmap_1 :
+   forall m0 m1 m2 m3:Map A,
+     eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m0 m2.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite <- (ad_double_div_2 a).
+    rewrite <- (MapGet_M2_bit_0_0 A _ (ad_double_bit_0 a) m0 m1).
+    rewrite <- (MapGet_M2_bit_0_0 A _ (ad_double_bit_0 a) m2 m3).
+    exact (H (ad_double a)).
+  Qed.
+
+  Lemma M2_eqmap_2 :
+   forall m0 m1 m2 m3:Map A,
+     eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m1 m3.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite <- (ad_double_plus_un_div_2 a).
+    rewrite <- (MapGet_M2_bit_0_1 A _ (ad_double_plus_un_bit_0 a) m0 m1).
+    rewrite <- (MapGet_M2_bit_0_1 A _ (ad_double_plus_un_bit_0 a) m2 m3).
+    exact (H (ad_double_plus_un a)).
+  Qed.
+
+  Lemma mapcanon_unique :
+   forall m m':Map A, mapcanon m -> mapcanon m' -> eqmap A m m' -> m = m'.
+  Proof.
+    simple induction m. simple induction m'. trivial.
+    intros a y H H0 H1. cut (NONE A = MapGet A (M1 A a y) a). simpl in |- *. rewrite (ad_eq_correct a).
+    intro. discriminate H2.
+    exact (H1 a).
+    intros. cut (2 <= MapCard A (M0 A)). intro. elim (le_Sn_O _ H4).
+    rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2).
+    intros a y. simple induction m'. intros. cut (MapGet A (M1 A a y) a = NONE A). simpl in |- *.
+    rewrite (ad_eq_correct a). intro. discriminate H2.
+    exact (H1 a).
+    intros a0 y0 H H0 H1. cut (MapGet A (M1 A a y) a = MapGet A (M1 A a0 y0) a). simpl in |- *.
+    rewrite (ad_eq_correct a). intro. elim (sumbool_of_bool (ad_eq a0 a)). intro H3.
+    rewrite H3 in H2. inversion H2. rewrite (ad_eq_complete _ _ H3). reflexivity.
+    intro H3. rewrite H3 in H2. discriminate H2.
+    exact (H1 a).
+    intros. cut (2 <= MapCard A (M1 A a y)). intro. elim (le_Sn_O _ (le_S_n _ _ H4)).
+    rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2).
+    simple induction m'. intros. cut (2 <= MapCard A (M0 A)). intro. elim (le_Sn_O _ H4).
+    rewrite <- (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H1).
+    intros a y H1 H2 H3. cut (2 <= MapCard A (M1 A a y)). intro.
+    elim (le_Sn_O _ (le_S_n _ _ H4)).
+    rewrite <- (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H1).
+    intros. rewrite (H m2). rewrite (H0 m3). reflexivity.
+    exact (mapcanon_M2_2 _ _ H3).
+    exact (mapcanon_M2_2 _ _ H4).
+    exact (M2_eqmap_2 _ _ _ _ H5).
+    exact (mapcanon_M2_1 _ _ H3).
+    exact (mapcanon_M2_1 _ _ H4).
+    exact (M2_eqmap_1 _ _ _ _ H5).
+  Qed.
+
+  Lemma MapPut1_canon :
+   forall (p:positive) (a a':ad) (y y':A), mapcanon (MapPut1 A a y a' y' p).
+  Proof.
+    simple induction p. simpl in |- *. intros. case (ad_bit_0 a). apply M2_canon. apply M1_canon.
+    apply M1_canon.
+    apply le_n.
+    apply M2_canon. apply M1_canon.
+    apply M1_canon.
+    apply le_n.
+    simpl in |- *. intros. case (ad_bit_0 a). apply M2_canon. apply M0_canon.
+    apply H.
+    simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n.
+    apply M2_canon. apply H.
+    apply M0_canon.
+    simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n.
+    simpl in |- *. simpl in |- *. intros. case (ad_bit_0 a). apply M2_canon. apply M1_canon.
+    apply M1_canon.
+    simpl in |- *. apply le_n.
+    apply M2_canon. apply M1_canon.
+    apply M1_canon.
+    simpl in |- *. apply le_n.
+  Qed.
+
+  Lemma MapPut_canon :
+   forall m:Map A,
+     mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut A m a y).
+  Proof.
+    simple induction m. intros. simpl in |- *. apply M1_canon.
+    intros a0 y0 H a y. simpl in |- *. case (ad_xor a0 a). apply M1_canon.
+    intro. apply MapPut1_canon.
+    intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
+    exact (mapcanon_M2_2 m0 m1 H1).
+    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1).
+    apply plus_le_compat. exact (MapCard_Put_lb A m0 ad_z y).
+    apply le_n.
+    intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1).
+    apply H0. exact (mapcanon_M2_2 m0 m1 H1).
+    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
+    exact (mapcanon_M2 m0 m1 H1).
+    apply plus_le_compat_l. exact (MapCard_Put_lb A m1 (ad_x p0) y).
+    intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
+    exact (mapcanon_M2_2 m0 m1 H1).
+    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
+    exact (mapcanon_M2 m0 m1 H1).
+    apply plus_le_compat_r. exact (MapCard_Put_lb A m0 (ad_x p0) y).
+    apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1).
+    apply H0. apply (mapcanon_M2_2 m0 m1 H1).
+    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
+    exact (mapcanon_M2 m0 m1 H1).
+    apply plus_le_compat_l. exact (MapCard_Put_lb A m1 ad_z y).
+  Qed.
+
+  Lemma MapPut_behind_canon :
+   forall m:Map A,
+     mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut_behind A m a y).
+  Proof.
+    simple induction m. intros. simpl in |- *. apply M1_canon.
+    intros a0 y0 H a y. simpl in |- *. case (ad_xor a0 a). apply M1_canon.
+    intro. apply MapPut1_canon.
+    intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
+    exact (mapcanon_M2_2 m0 m1 H1).
+    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1).
+    apply plus_le_compat. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 ad_z y).
+    apply le_n.
+    intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1).
+    apply H0. exact (mapcanon_M2_2 m0 m1 H1).
+    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
+    exact (mapcanon_M2 m0 m1 H1).
+    apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 (ad_x p0) y).
+    intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
+    exact (mapcanon_M2_2 m0 m1 H1).
+    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
+    exact (mapcanon_M2 m0 m1 H1).
+    apply plus_le_compat_r. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 (ad_x p0) y).
+    apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1).
+    apply H0. apply (mapcanon_M2_2 m0 m1 H1).
+    simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
+    exact (mapcanon_M2 m0 m1 H1).
+    apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 ad_z y).
+  Qed.
+
+  Lemma makeM2_canon :
+   forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (makeM2 A m m').
+  Proof.
+    intro. case m. intro. case m'. intros. exact M0_canon.
+    intros a y H H0. exact (M1_canon (ad_double_plus_un a) y).
+    intros. simpl in |- *. apply M2_canon; try assumption. exact (mapcanon_M2 m0 m1 H0).
+    intros a y m'. case m'. intros. exact (M1_canon (ad_double a) y).
+    intros a0 y0 H H0. simpl in |- *. apply M2_canon; try assumption. apply le_n.
+    intros. simpl in |- *. apply M2_canon; try assumption.
+    apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H0).
+    exact (le_plus_r (MapCard A (M1 A a y)) (MapCard A (M2 A m0 m1))).
+    simpl in |- *. intros. apply M2_canon; try assumption.
+    apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H).
+    exact (le_plus_l (MapCard A (M2 A m0 m1)) (MapCard A m')).
+  Qed.
+
+  Fixpoint MapCanonicalize (m:Map A) : Map A :=
+    match m with
+    | M2 m0 m1 => makeM2 A (MapCanonicalize m0) (MapCanonicalize m1)
+    | _ => m
+    end.
+
+  Lemma mapcanon_exists_1 : forall m:Map A, eqmap A m (MapCanonicalize m).
+  Proof.
+    simple induction m. apply eqmap_refl.
+    intros. apply eqmap_refl.
+    intros. simpl in |- *. unfold eqmap, eqm in |- *. intro.
+    rewrite (makeM2_M2 A (MapCanonicalize m0) (MapCanonicalize m1) a).
+    rewrite MapGet_M2_bit_0_if. rewrite MapGet_M2_bit_0_if.
+    rewrite <- (H (ad_div_2 a)). rewrite <- (H0 (ad_div_2 a)). reflexivity.
+  Qed.
+
+  Lemma mapcanon_exists_2 : forall m:Map A, mapcanon (MapCanonicalize m).
+  Proof.
+    simple induction m. apply M0_canon.
+    intros. simpl in |- *. apply M1_canon.
+    intros. simpl in |- *. apply makeM2_canon; assumption.
+  Qed.
+
+  Lemma mapcanon_exists :
+   forall m:Map A, {m' : Map A | eqmap A m m' /\ mapcanon m'}.
+  Proof.
+    intro. split with (MapCanonicalize m). split. apply mapcanon_exists_1.
+    apply mapcanon_exists_2.
+  Qed.
+
+  Lemma MapRemove_canon :
+   forall m:Map A, mapcanon m -> forall a:ad, mapcanon (MapRemove A m a).
+  Proof.
+    simple induction m. intros. exact M0_canon.
+    intros a y H a0. simpl in |- *. case (ad_eq a a0). exact M0_canon.
+    assumption.
+    intros. simpl in |- *. case (ad_bit_0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1).
+    apply H0. exact (mapcanon_M2_2 _ _ H1).
+    apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1).
+    exact (mapcanon_M2_2 _ _ H1).
+  Qed.
+
+  Lemma MapMerge_canon :
+   forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapMerge A m m').
+  Proof.
+    simple induction m. intros. exact H0.
+    simpl in |- *. intros a y m' H H0. exact (MapPut_behind_canon m' H0 a y).
+    simple induction m'. intros. exact H1.
+    intros a y H1 H2. unfold MapMerge in |- *. exact (MapPut_canon _ H1 a y).
+    intros. simpl in |- *. apply M2_canon. apply H. exact (mapcanon_M2_1 _ _ H3).
+    exact (mapcanon_M2_1 _ _ H4).
+    apply H0. exact (mapcanon_M2_2 _ _ H3).
+    exact (mapcanon_M2_2 _ _ H4).
+    change (2 <= MapCard A (MapMerge A (M2 A m0 m1) (M2 A m2 m3))) in |- *.
+    apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H3).
+    exact (MapMerge_Card_lb_l A (M2 A m0 m1) (M2 A m2 m3)).
+  Qed.
+
+  Lemma MapDelta_canon :
+   forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapDelta A m m').
+  Proof.
+    simple induction m. intros. exact H0.
+    simpl in |- *. intros a y m' H H0. case (MapGet A m' a). exact (MapPut_canon m' H0 a y).
+    intro. exact (MapRemove_canon m' H0 a).
+    simple induction m'. intros. exact H1.
+    unfold MapDelta in |- *. intros a y H1 H2. case (MapGet A (M2 A m0 m1) a).
+    exact (MapPut_canon _ H1 a y).
+    intro. exact (MapRemove_canon _ H1 a).
+    intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H3).
+    exact (mapcanon_M2_1 _ _ H4).
+    apply H0. exact (mapcanon_M2_2 _ _ H3).
+    exact (mapcanon_M2_2 _ _ H4).
+  Qed.
+
+  Variable B : Set.
+
+  Lemma MapDomRestrTo_canon :
+   forall m:Map A,
+     mapcanon m -> forall m':Map B, mapcanon (MapDomRestrTo A B m m').
+  Proof.
+    simple induction m. intros. exact M0_canon.
+    simpl in |- *. intros a y H m'. case (MapGet B m' a). exact M0_canon.
+    intro. apply M1_canon.
+    simple induction m'. exact M0_canon.
+    unfold MapDomRestrTo in |- *. intros a y. case (MapGet A (M2 A m0 m1) a). exact M0_canon.
+    intro. apply M1_canon.
+    intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
+    apply H0. exact (mapcanon_M2_2 m0 m1 H1).
+  Qed.
+
+  Lemma MapDomRestrBy_canon :
+   forall m:Map A,
+     mapcanon m -> forall m':Map B, mapcanon (MapDomRestrBy A B m m').
+  Proof.
+    simple induction m. intros. exact M0_canon.
+    simpl in |- *. intros a y H m'. case (MapGet B m' a). assumption.
+    intro. exact M0_canon.
+    simple induction m'. exact H1.
+    intros a y. simpl in |- *. case (ad_bit_0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1).
+    apply MapRemove_canon. exact (mapcanon_M2_2 _ _ H1).
+    apply makeM2_canon. apply MapRemove_canon. exact (mapcanon_M2_1 _ _ H1).
+    exact (mapcanon_M2_2 _ _ H1).
+    intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1).
+    apply H0. exact (mapcanon_M2_2 _ _ H1).
+  Qed.
+
+  Lemma Map_of_alist_canon : forall l:alist A, mapcanon (Map_of_alist A l).
+  Proof.
+    simple induction l. exact M0_canon.
+    intro r. elim r. intros a y l0 H. simpl in |- *. apply MapPut_canon. assumption.
+  Qed.
+
+  Lemma MapSubset_c_1 :
+   forall (m:Map A) (m':Map B),
+     mapcanon m -> MapSubset A B m m' -> MapDomRestrBy A B m m' = M0 A.
+  Proof.
+    intros. apply mapcanon_unique. apply MapDomRestrBy_canon. assumption.
+    apply M0_canon.
+    exact (MapSubset_imp_2 _ _ m m' H0).
+  Qed.
+
+  Lemma MapSubset_c_2 :
+   forall (m:Map A) (m':Map B),
+     MapDomRestrBy A B m m' = M0 A -> MapSubset A B m m'.
+  Proof.
+    intros. apply MapSubset_2_imp. unfold MapSubset_2 in |- *. rewrite H. apply eqmap_refl.
+  Qed.
+
+End MapCanon.
+
+Section FSetCanon.
+
+  Variable A : Set.
+
+  Lemma MapDom_canon :
+   forall m:Map A, mapcanon A m -> mapcanon unit (MapDom A m).
+  Proof.
+    simple induction m. intro. exact (M0_canon unit).
+    intros a y H. exact (M1_canon unit a _).
+    intros. simpl in |- *. apply M2_canon. apply H. exact (mapcanon_M2_1 A _ _ H1).
+    apply H0. exact (mapcanon_M2_2 A _ _ H1).
+    change (2 <= MapCard unit (MapDom A (M2 A m0 m1))) in |- *. rewrite <- MapCard_Dom.
+    exact (mapcanon_M2 A _ _ H1).
+  Qed.
+
+End FSetCanon.
+
+Section MapFoldCanon.
+
+  Variables A B : Set.
+
+  Lemma MapFold_canon_1 :
+   forall m0:Map B,
+     mapcanon B m0 ->
+     forall op:Map B -> Map B -> Map B,
+       (forall m1:Map B,
+          mapcanon B m1 ->
+          forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) ->
+       forall f:ad -> A -> Map B,
+         (forall (a:ad) (y:A), mapcanon B (f a y)) ->
+         forall (m:Map A) (pf:ad -> ad),
+           mapcanon B (MapFold1 A (Map B) m0 op f pf m).
+  Proof.
+    simple induction m. intro. exact H.
+    intros a y pf. simpl in |- *. apply H1.
+    intros. simpl in |- *. apply H0. apply H2.
+    apply H3.
+  Qed.
+
+  Lemma MapFold_canon :
+   forall m0:Map B,
+     mapcanon B m0 ->
+     forall op:Map B -> Map B -> Map B,
+       (forall m1:Map B,
+          mapcanon B m1 ->
+          forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) ->
+       forall f:ad -> A -> Map B,
+         (forall (a:ad) (y:A), mapcanon B (f a y)) ->
+         forall m:Map A, mapcanon B (MapFold A (Map B) m0 op f m).
+  Proof.
+    intros. exact (MapFold_canon_1 m0 H op H0 f H1 m (fun a:ad => a)).
+  Qed.
+
+  Lemma MapCollect_canon :
+   forall f:ad -> A -> Map B,
+     (forall (a:ad) (y:A), mapcanon B (f a y)) ->
+     forall m:Map A, mapcanon B (MapCollect A B f m).
+  Proof.
+    intros. rewrite MapCollect_as_Fold. apply MapFold_canon. apply M0_canon.
+    intros. exact (MapMerge_canon B m1 m2 H0 H1).
+    assumption.
+  Qed.
+
+End MapFoldCanon.
\ No newline at end of file
diff --git a/theories/IntMap/Mapcard.v b/theories/IntMap/Mapcard.v
new file mode 100644
index 00000000..49f9fe91
--- /dev/null
+++ b/theories/IntMap/Mapcard.v
@@ -0,0 +1,764 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Mapcard.v,v 1.5.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Mapaxioms.
+Require Import Mapiter.
+Require Import Fset.
+Require Import Mapsubset.
+Require Import List.
+Require Import Lsort.
+Require Import Peano_dec.
+
+Section MapCard.
+
+  Variables A B : Set.
+
+  Lemma MapCard_M0 : MapCard A (M0 A) = 0.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapCard_M1 : forall (a:ad) (y:A), MapCard A (M1 A a y) = 1.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapCard_is_O :
+   forall m:Map A, MapCard A m = 0 -> forall a:ad, MapGet A m a = NONE A.
+  Proof.
+    simple induction m. trivial.
+    intros a y H. discriminate H.
+    intros. simpl in H1. elim (plus_is_O _ _ H1). intros. rewrite (MapGet_M2_bit_0_if A m0 m1 a).
+    case (ad_bit_0 a). apply H0. assumption.
+    apply H. assumption.
+  Qed.
+
+  Lemma MapCard_is_not_O :
+   forall (m:Map A) (a:ad) (y:A),
+     MapGet A m a = SOME A y -> {n : nat | MapCard A m = S n}.
+  Proof.
+    simple induction m. intros. discriminate H.
+    intros a y a0 y0 H. simpl in H. elim (sumbool_of_bool (ad_eq a a0)). intro H0. split with 0.
+    reflexivity.
+    intro H0. rewrite H0 in H. discriminate H.
+    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H2.
+    rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. elim (H0 (ad_div_2 a) y H1). intros n H3.
+    simpl in |- *. rewrite H3. split with (MapCard A m0 + n).
+    rewrite <- (plus_Snm_nSm (MapCard A m0) n). reflexivity.
+    intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. elim (H (ad_div_2 a) y H1).
+    intros n H3. simpl in |- *. rewrite H3. split with (n + MapCard A m1). reflexivity.
+  Qed.
+
+  Lemma MapCard_is_one :
+   forall m:Map A,
+     MapCard A m = 1 -> {a : ad &  {y : A | MapGet A m a = SOME A y}}.
+  Proof.
+    simple induction m. intro. discriminate H.
+    intros a y H. split with a. split with y. apply M1_semantics_1.
+    intros. simpl in H1. elim (plus_is_one (MapCard A m0) (MapCard A m1) H1).
+    intro H2. elim H2. intros. elim (H0 H4). intros a H5. split with (ad_double_plus_un a).
+    rewrite (MapGet_M2_bit_0_1 A _ (ad_double_plus_un_bit_0 a) m0 m1).
+    rewrite ad_double_plus_un_div_2. exact H5.
+    intro H2. elim H2. intros. elim (H H3). intros a H5. split with (ad_double a).
+    rewrite (MapGet_M2_bit_0_0 A _ (ad_double_bit_0 a) m0 m1).
+    rewrite ad_double_div_2. exact H5.
+  Qed.
+
+  Lemma MapCard_is_one_unique :
+   forall m:Map A,
+     MapCard A m = 1 ->
+     forall (a a':ad) (y y':A),
+       MapGet A m a = SOME A y ->
+       MapGet A m a' = SOME A y' -> a = a' /\ y = y'.
+  Proof.
+    simple induction m. intro. discriminate H.
+    intros. elim (sumbool_of_bool (ad_eq a a1)). intro H2. rewrite (ad_eq_complete _ _ H2) in H0.
+    rewrite (M1_semantics_1 A a1 a0) in H0. inversion H0. elim (sumbool_of_bool (ad_eq a a')).
+    intro H5. rewrite (ad_eq_complete _ _ H5) in H1. rewrite (M1_semantics_1 A a' a0) in H1.
+    inversion H1. rewrite <- (ad_eq_complete _ _ H2). rewrite <- (ad_eq_complete _ _ H5).
+    rewrite <- H4. rewrite <- H6. split; reflexivity.
+    intro H5. rewrite (M1_semantics_2 A a a' a0 H5) in H1. discriminate H1.
+    intro H2. rewrite (M1_semantics_2 A a a1 a0 H2) in H0. discriminate H0.
+    intros. simpl in H1. elim (plus_is_one _ _ H1). intro H4. elim H4. intros.
+    rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2. elim (sumbool_of_bool (ad_bit_0 a)).
+    intro H7. rewrite H7 in H2. rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3.
+    elim (sumbool_of_bool (ad_bit_0 a')). intro H8. rewrite H8 in H3. elim (H0 H6 _ _ _ _ H2 H3).
+    intros. split. rewrite <- (ad_div_2_double_plus_un a H7).
+    rewrite <- (ad_div_2_double_plus_un a' H8). rewrite H9. reflexivity.
+    assumption.
+    intro H8. rewrite H8 in H3. rewrite (MapCard_is_O m0 H5 (ad_div_2 a')) in H3.
+    discriminate H3.
+    intro H7. rewrite H7 in H2. rewrite (MapCard_is_O m0 H5 (ad_div_2 a)) in H2.
+    discriminate H2.
+    intro H4. elim H4. intros. rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2.
+    elim (sumbool_of_bool (ad_bit_0 a)). intro H7. rewrite H7 in H2.
+    rewrite (MapCard_is_O m1 H6 (ad_div_2 a)) in H2. discriminate H2.
+    intro H7. rewrite H7 in H2. rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3.
+    elim (sumbool_of_bool (ad_bit_0 a')). intro H8. rewrite H8 in H3.
+    rewrite (MapCard_is_O m1 H6 (ad_div_2 a')) in H3. discriminate H3.
+    intro H8. rewrite H8 in H3. elim (H H5 _ _ _ _ H2 H3). intros. split.
+    rewrite <- (ad_div_2_double a H7). rewrite <- (ad_div_2_double a' H8).
+    rewrite H9. reflexivity.
+    assumption.
+  Qed.
+
+  Lemma length_as_fold :
+   forall (C:Set) (l:list C),
+     length l = fold_right (fun (_:C) (n:nat) => S n) 0 l.
+  Proof.
+    simple induction l. reflexivity.
+    intros. simpl in |- *. rewrite H. reflexivity.
+  Qed.
+
+  Lemma length_as_fold_2 :
+   forall l:alist A,
+     length l =
+     fold_right (fun (r:ad * A) (n:nat) => let (a, y) := r in 1 + n) 0 l.
+  Proof.
+    simple induction l. reflexivity.
+    intros. simpl in |- *. rewrite H. elim a; reflexivity.
+  Qed.
+
+  Lemma MapCard_as_Fold_1 :
+   forall (m:Map A) (pf:ad -> ad),
+     MapCard A m = MapFold1 A nat 0 plus (fun (_:ad) (_:A) => 1) pf m.
+  Proof.
+    simple induction m. trivial.
+    trivial.
+    intros. simpl in |- *. rewrite <- (H (fun a0:ad => pf (ad_double a0))).
+    rewrite <- (H0 (fun a0:ad => pf (ad_double_plus_un a0))). reflexivity.
+  Qed.
+
+  Lemma MapCard_as_Fold :
+   forall m:Map A,
+     MapCard A m = MapFold A nat 0 plus (fun (_:ad) (_:A) => 1) m.
+  Proof.
+    intro. exact (MapCard_as_Fold_1 m (fun a0:ad => a0)).
+  Qed.
+ 
+  Lemma MapCard_as_length :
+   forall m:Map A, MapCard A m = length (alist_of_Map A m).
+  Proof.
+    intro. rewrite MapCard_as_Fold. rewrite length_as_fold_2.
+    apply MapFold_as_fold with
+     (op := plus) (neutral := 0) (f := fun (_:ad) (_:A) => 1). exact plus_assoc_reverse.
+    trivial.
+    intro. rewrite <- plus_n_O. reflexivity.
+  Qed.
+
+  Lemma MapCard_Put1_equals_2 :
+   forall (p:positive) (a a':ad) (y y':A),
+     MapCard A (MapPut1 A a y a' y' p) = 2.
+  Proof.
+    simple induction p. intros. simpl in |- *. case (ad_bit_0 a); reflexivity.
+    intros. simpl in |- *. case (ad_bit_0 a). exact (H (ad_div_2 a) (ad_div_2 a') y y').
+    simpl in |- *. rewrite <- plus_n_O. exact (H (ad_div_2 a) (ad_div_2 a') y y').
+    intros. simpl in |- *. case (ad_bit_0 a); reflexivity.
+  Qed.
+
+  Lemma MapCard_Put_sum :
+   forall (m m':Map A) (a:ad) (y:A) (n n':nat),
+     m' = MapPut A m a y ->
+     n = MapCard A m -> n' = MapCard A m' -> {n' = n} + {n' = S n}.
+  Proof.
+    simple induction m. simpl in |- *. intros. rewrite H in H1. simpl in H1. right.
+    rewrite H0. rewrite H1. reflexivity.
+    intros a y m' a0 y0 n n' H H0 H1. simpl in H. elim (ad_sum (ad_xor a a0)). intro H2.
+    elim H2. intros p H3. rewrite H3 in H. rewrite H in H1.
+    rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H1. simpl in H0. right.
+    rewrite H0. rewrite H1. reflexivity.
+    intro H2. rewrite H2 in H. rewrite H in H1. simpl in H1. simpl in H0. left.
+    rewrite H0. rewrite H1. reflexivity.
+    intros. simpl in H2. rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H1.
+    elim (sumbool_of_bool (ad_bit_0 a)). intro H4. rewrite H4 in H1.
+    elim
+     (H0 (MapPut A m1 (ad_div_2 a) y) (ad_div_2 a) y (
+        MapCard A m1) (MapCard A (MapPut A m1 (ad_div_2 a) y)) (
+        refl_equal _) (refl_equal _) (refl_equal _)).
+    intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. rewrite <- H2 in H3. left.
+    assumption.
+    intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3.
+    rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)) in H3.
+    simpl in H3. rewrite <- H2 in H3. right. assumption.
+    intro H4. rewrite H4 in H1.
+    elim
+     (H (MapPut A m0 (ad_div_2 a) y) (ad_div_2 a) y (
+        MapCard A m0) (MapCard A (MapPut A m0 (ad_div_2 a) y)) (
+        refl_equal _) (refl_equal _) (refl_equal _)).
+    intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. rewrite <- H2 in H3.
+    left. assumption.
+    intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. simpl in H3. rewrite <- H2 in H3.
+    right. assumption.
+  Qed.
+
+  Lemma MapCard_Put_lb :
+   forall (m:Map A) (a:ad) (y:A), MapCard A (MapPut A m a y) >= MapCard A m.
+  Proof.
+    unfold ge in |- *. intros.
+    elim
+     (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m)
+        (MapCard A (MapPut A m a y)) (refl_equal _) (
+        refl_equal _) (refl_equal _)).
+    intro H. rewrite H. apply le_n.
+    intro H. rewrite H. apply le_n_Sn.
+  Qed.
+
+  Lemma MapCard_Put_ub :
+   forall (m:Map A) (a:ad) (y:A),
+     MapCard A (MapPut A m a y) <= S (MapCard A m).
+  Proof.
+    intros.
+    elim
+     (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m)
+        (MapCard A (MapPut A m a y)) (refl_equal _) (
+        refl_equal _) (refl_equal _)).
+    intro H. rewrite H. apply le_n_Sn.
+    intro H. rewrite H. apply le_n.
+  Qed.
+
+  Lemma MapCard_Put_1 :
+   forall (m:Map A) (a:ad) (y:A),
+     MapCard A (MapPut A m a y) = MapCard A m ->
+     {y : A | MapGet A m a = SOME A y}.
+  Proof.
+    simple induction m. intros. discriminate H.
+    intros a y a0 y0 H. simpl in H. elim (ad_sum (ad_xor a a0)). intro H0. elim H0.
+    intros p H1. rewrite H1 in H. rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H.
+    discriminate H.
+    intro H0. rewrite H0 in H. rewrite (ad_xor_eq _ _ H0). split with y. apply M1_semantics_1.
+    intros. rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H1. elim (sumbool_of_bool (ad_bit_0 a)).
+    intro H2. rewrite H2 in H1. simpl in H1. elim (H0 (ad_div_2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1)).
+    intros y0 H3. split with y0. rewrite <- H3. exact (MapGet_M2_bit_0_1 A a H2 m0 m1).
+    intro H2. rewrite H2 in H1. simpl in H1.
+    rewrite
+     (plus_comm (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1))
+      in H1.
+    rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1.
+    elim (H (ad_div_2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1)). intros y0 H3. split with y0.
+    rewrite <- H3. exact (MapGet_M2_bit_0_0 A a H2 m0 m1).
+  Qed.
+
+  Lemma MapCard_Put_2 :
+   forall (m:Map A) (a:ad) (y:A),
+     MapCard A (MapPut A m a y) = S (MapCard A m) -> MapGet A m a = NONE A.
+  Proof.
+    simple induction m. trivial.
+    intros. simpl in H. elim (sumbool_of_bool (ad_eq a a1)). intro H0.
+    rewrite (ad_eq_complete _ _ H0) in H. rewrite (ad_xor_nilpotent a1) in H. discriminate H.
+    intro H0. exact (M1_semantics_2 A a a1 a0 H0).
+    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H2.
+    rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply (H0 (ad_div_2 a) y).
+    apply (fun n m p:nat => plus_reg_l m p n) with (n := MapCard A m0).
+    rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)). simpl in H1. simpl in |- *. rewrite <- H1.
+    clear H1.
+    induction a. discriminate H2.
+    induction p. reflexivity.
+    discriminate H2.
+    reflexivity.
+    intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply (H (ad_div_2 a) y).
+    cut
+     (MapCard A (MapPut A m0 (ad_div_2 a) y) + MapCard A m1 =
+      S (MapCard A m0) + MapCard A m1).
+    intro. rewrite (plus_comm (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1))
+   in H3.
+    rewrite (plus_comm (S (MapCard A m0)) (MapCard A m1)) in H3. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H3).
+    simpl in |- *. simpl in H1. rewrite <- H1. induction a. trivial.
+    induction p. discriminate H2.
+    reflexivity.
+    discriminate H2.
+  Qed.
+
+  Lemma MapCard_Put_1_conv :
+   forall (m:Map A) (a:ad) (y y':A),
+     MapGet A m a = SOME A y -> MapCard A (MapPut A m a y') = MapCard A m.
+  Proof.
+    intros.
+    elim
+     (MapCard_Put_sum m (MapPut A m a y') a y' (MapCard A m)
+        (MapCard A (MapPut A m a y')) (refl_equal _) (
+        refl_equal _) (refl_equal _)).
+    trivial.
+    intro H0. rewrite (MapCard_Put_2 m a y' H0) in H. discriminate H.
+  Qed.
+
+  Lemma MapCard_Put_2_conv :
+   forall (m:Map A) (a:ad) (y:A),
+     MapGet A m a = NONE A -> MapCard A (MapPut A m a y) = S (MapCard A m).
+  Proof.
+    intros.
+    elim
+     (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m)
+        (MapCard A (MapPut A m a y)) (refl_equal _) (
+        refl_equal _) (refl_equal _)).
+    intro H0. elim (MapCard_Put_1 m a y H0). intros y' H1. rewrite H1 in H. discriminate H.
+    trivial.
+  Qed.
+
+  Lemma MapCard_ext :
+   forall m m':Map A,
+     eqm A (MapGet A m) (MapGet A m') -> MapCard A m = MapCard A m'.
+  Proof.
+    unfold eqm in |- *. intros. rewrite (MapCard_as_length m). rewrite (MapCard_as_length m').
+    rewrite (alist_canonical A (alist_of_Map A m) (alist_of_Map A m')). reflexivity.
+    unfold eqm in |- *. intro. rewrite (Map_of_alist_semantics A (alist_of_Map A m) a).
+    rewrite (Map_of_alist_semantics A (alist_of_Map A m') a). rewrite (Map_of_alist_of_Map A m' a).
+    rewrite (Map_of_alist_of_Map A m a). exact (H a).
+    apply alist_of_Map_sorts2.
+    apply alist_of_Map_sorts2.
+  Qed.
+
+  Lemma MapCard_Dom : forall m:Map A, MapCard A m = MapCard unit (MapDom A m).
+  Proof.
+    simple induction m; trivial. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+  Qed.
+
+  Lemma MapCard_Dom_Put_behind :
+   forall (m:Map A) (a:ad) (y:A),
+     MapDom A (MapPut_behind A m a y) = MapDom A (MapPut A m a y).
+  Proof.
+    simple induction m. trivial.
+    intros a y a0 y0. simpl in |- *. elim (ad_sum (ad_xor a a0)). intro H. elim H.
+    intros p H0. rewrite H0. reflexivity.
+    intro H. rewrite H. rewrite (ad_xor_eq _ _ H). reflexivity.
+    intros. simpl in |- *. elim (ad_sum a). intro H1. elim H1. intros p H2. rewrite H2. case p.
+    intro p0. simpl in |- *. rewrite H0. reflexivity.
+    intro p0. simpl in |- *. rewrite H. reflexivity.
+    simpl in |- *. rewrite H0. reflexivity.
+    intro H1. rewrite H1. simpl in |- *. rewrite H. reflexivity.
+  Qed.
+
+  Lemma MapCard_Put_behind_Put :
+   forall (m:Map A) (a:ad) (y:A),
+     MapCard A (MapPut_behind A m a y) = MapCard A (MapPut A m a y).
+  Proof.
+    intros. rewrite MapCard_Dom. rewrite MapCard_Dom. rewrite MapCard_Dom_Put_behind.
+    reflexivity.
+  Qed.
+
+  Lemma MapCard_Put_behind_sum :
+   forall (m m':Map A) (a:ad) (y:A) (n n':nat),
+     m' = MapPut_behind A m a y ->
+     n = MapCard A m -> n' = MapCard A m' -> {n' = n} + {n' = S n}.
+  Proof.
+    intros. apply (MapCard_Put_sum m (MapPut A m a y) a y n n'); trivial.
+    rewrite <- MapCard_Put_behind_Put. rewrite <- H. assumption.
+  Qed.
+
+  Lemma MapCard_makeM2 :
+   forall m m':Map A, MapCard A (makeM2 A m m') = MapCard A m + MapCard A m'.
+  Proof.
+    intros. rewrite (MapCard_ext _ _ (makeM2_M2 A m m')). reflexivity.
+  Qed.
+ 
+  Lemma MapCard_Remove_sum :
+   forall (m m':Map A) (a:ad) (n n':nat),
+     m' = MapRemove A m a ->
+     n = MapCard A m -> n' = MapCard A m' -> {n = n'} + {n = S n'}.
+  Proof.
+    simple induction m. simpl in |- *. intros. rewrite H in H1. simpl in H1. left. rewrite H1. assumption.
+    simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H2. rewrite H2 in H.
+    rewrite H in H1. simpl in H1. right. rewrite H1. assumption.
+    intro H2. rewrite H2 in H. rewrite H in H1. simpl in H1. left. rewrite H1. assumption.
+    intros. simpl in H1. simpl in H2. elim (sumbool_of_bool (ad_bit_0 a)). intro H4.
+    rewrite H4 in H1. rewrite H1 in H3.
+    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H3.
+    elim
+     (H0 (MapRemove A m1 (ad_div_2 a)) (ad_div_2 a) (
+        MapCard A m1) (MapCard A (MapRemove A m1 (ad_div_2 a)))
+        (refl_equal _) (refl_equal _) (refl_equal _)).
+    intro H5. rewrite H5 in H2. left. rewrite H3. exact H2.
+    intro H5. rewrite H5 in H2.
+    rewrite <-
+     (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (ad_div_2 a))))
+      in H2.
+    right. rewrite H3. exact H2.
+    intro H4. rewrite H4 in H1. rewrite H1 in H3.
+    rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H3.
+    elim
+     (H (MapRemove A m0 (ad_div_2 a)) (ad_div_2 a) (
+        MapCard A m0) (MapCard A (MapRemove A m0 (ad_div_2 a)))
+        (refl_equal _) (refl_equal _) (refl_equal _)).
+    intro H5. rewrite H5 in H2. left. rewrite H3. exact H2.
+    intro H5. rewrite H5 in H2. right. rewrite H3. exact H2.
+  Qed.
+
+  Lemma MapCard_Remove_ub :
+   forall (m:Map A) (a:ad), MapCard A (MapRemove A m a) <= MapCard A m.
+  Proof.
+    intros.
+    elim
+     (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
+        (MapCard A (MapRemove A m a)) (refl_equal _) (
+        refl_equal _) (refl_equal _)).
+    intro H. rewrite H. apply le_n.
+    intro H. rewrite H. apply le_n_Sn.
+  Qed.
+
+  Lemma MapCard_Remove_lb :
+   forall (m:Map A) (a:ad), S (MapCard A (MapRemove A m a)) >= MapCard A m.
+  Proof.
+    unfold ge in |- *. intros.
+    elim
+     (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
+        (MapCard A (MapRemove A m a)) (refl_equal _) (
+        refl_equal _) (refl_equal _)).
+    intro H. rewrite H. apply le_n_Sn.
+    intro H. rewrite H. apply le_n.
+  Qed.
+
+  Lemma MapCard_Remove_1 :
+   forall (m:Map A) (a:ad),
+     MapCard A (MapRemove A m a) = MapCard A m -> MapGet A m a = NONE A.
+  Proof.
+    simple induction m. trivial.
+    simpl in |- *. intros a y a0 H. elim (sumbool_of_bool (ad_eq a a0)). intro H0.
+    rewrite H0 in H. discriminate H.
+    intro H0. rewrite H0. reflexivity.
+    intros. simpl in H1. elim (sumbool_of_bool (ad_bit_0 a)). intro H2. rewrite H2 in H1.
+    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H1.
+    rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply H0. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1).
+    intro H2. rewrite H2 in H1.
+    rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H1.
+    rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply H.
+    rewrite
+     (plus_comm (MapCard A (MapRemove A m0 (ad_div_2 a))) (MapCard A m1))
+      in H1.
+    rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1).
+  Qed.
+
+  Lemma MapCard_Remove_2 :
+   forall (m:Map A) (a:ad),
+     S (MapCard A (MapRemove A m a)) = MapCard A m ->
+     {y : A | MapGet A m a = SOME A y}.
+  Proof.
+    simple induction m. intros. discriminate H.
+    intros a y a0 H. simpl in H. elim (sumbool_of_bool (ad_eq a a0)). intro H0.
+    rewrite (ad_eq_complete _ _ H0). split with y. exact (M1_semantics_1 A a0 y).
+    intro H0. rewrite H0 in H. discriminate H.
+    intros. simpl in H1. elim (sumbool_of_bool (ad_bit_0 a)). intro H2. rewrite H2 in H1.
+    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H1.
+    rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply H0.
+    change
+      (S (MapCard A m0) + MapCard A (MapRemove A m1 (ad_div_2 a)) =
+       MapCard A m0 + MapCard A m1) in H1.
+    rewrite
+     (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (ad_div_2 a))))
+      in H1.
+    exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1).
+    intro H2. rewrite H2 in H1. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply H.
+    rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H1.
+    change
+      (S (MapCard A (MapRemove A m0 (ad_div_2 a))) + MapCard A m1 =
+       MapCard A m0 + MapCard A m1) in H1.
+    rewrite
+     (plus_comm (S (MapCard A (MapRemove A m0 (ad_div_2 a)))) (MapCard A m1))
+      in H1.
+    rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1).
+  Qed.
+
+  Lemma MapCard_Remove_1_conv :
+   forall (m:Map A) (a:ad),
+     MapGet A m a = NONE A -> MapCard A (MapRemove A m a) = MapCard A m.
+  Proof.
+    intros.
+    elim
+     (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
+        (MapCard A (MapRemove A m a)) (refl_equal _) (
+        refl_equal _) (refl_equal _)).
+    intro H0. rewrite H0. reflexivity.
+    intro H0. elim (MapCard_Remove_2 m a (sym_eq H0)). intros y H1. rewrite H1 in H.
+    discriminate H.
+  Qed.
+
+  Lemma MapCard_Remove_2_conv :
+   forall (m:Map A) (a:ad) (y:A),
+     MapGet A m a = SOME A y -> S (MapCard A (MapRemove A m a)) = MapCard A m.
+  Proof.
+    intros.
+    elim
+     (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
+        (MapCard A (MapRemove A m a)) (refl_equal _) (
+        refl_equal _) (refl_equal _)).
+    intro H0. rewrite (MapCard_Remove_1 m a (sym_eq H0)) in H. discriminate H.
+    intro H0. rewrite H0. reflexivity.
+  Qed.
+
+  Lemma MapMerge_Restr_Card :
+   forall m m':Map A,
+     MapCard A m + MapCard A m' =
+     MapCard A (MapMerge A m m') + MapCard A (MapDomRestrTo A A m m').
+  Proof.
+    simple induction m. simpl in |- *. intro. apply plus_n_O.
+    simpl in |- *. intros a y m'. elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y0 H0.
+    rewrite H0. rewrite MapCard_Put_behind_Put. rewrite (MapCard_Put_1_conv m' a y0 y H0).
+    simpl in |- *. rewrite <- plus_Snm_nSm. apply plus_n_O.
+    intro H. rewrite H. rewrite MapCard_Put_behind_Put. rewrite (MapCard_Put_2_conv m' a y H).
+    apply plus_n_O.
+    intros.
+    change
+      (MapCard A m0 + MapCard A m1 + MapCard A m' =
+       MapCard A (MapMerge A (M2 A m0 m1) m') +
+       MapCard A (MapDomRestrTo A A (M2 A m0 m1) m')) 
+     in |- *.
+    elim m'. reflexivity.
+    intros a y. unfold MapMerge in |- *. unfold MapDomRestrTo in |- *.
+    elim (option_sum A (MapGet A (M2 A m0 m1) a)). intro H1. elim H1. intros y0 H2. rewrite H2.
+    rewrite (MapCard_Put_1_conv (M2 A m0 m1) a y0 y H2). reflexivity.
+    intro H1. rewrite H1. rewrite (MapCard_Put_2_conv (M2 A m0 m1) a y H1). simpl in |- *.
+    rewrite <- (plus_Snm_nSm (MapCard A m0 + MapCard A m1) 0). reflexivity.
+    intros. simpl in |- *.
+    rewrite
+     (plus_permute_2_in_4 (MapCard A m0) (MapCard A m1) (
+        MapCard A m2) (MapCard A m3)).
+    rewrite (H m2). rewrite (H0 m3).
+    rewrite
+     (MapCard_makeM2 (MapDomRestrTo A A m0 m2) (MapDomRestrTo A A m1 m3))
+     .
+    apply plus_permute_2_in_4.
+  Qed.
+
+  Lemma MapMerge_disjoint_Card :
+   forall m m':Map A,
+     MapDisjoint A A m m' ->
+     MapCard A (MapMerge A m m') = MapCard A m + MapCard A m'.
+  Proof.
+    intros. rewrite (MapMerge_Restr_Card m m').
+    rewrite (MapCard_ext _ _ (MapDisjoint_imp_2 _ _ _ _ H)). apply plus_n_O.
+  Qed.
+
+  Lemma MapSplit_Card :
+   forall (m:Map A) (m':Map B),
+     MapCard A m =
+     MapCard A (MapDomRestrTo A B m m') + MapCard A (MapDomRestrBy A B m m').
+  Proof.
+    intros. rewrite (MapCard_ext _ _ (MapDom_Split_1 A B m m')). apply MapMerge_disjoint_Card.
+    apply MapDisjoint_2_imp. unfold MapDisjoint_2 in |- *. apply MapDom_Split_3.
+  Qed.
+
+  Lemma MapMerge_Card_ub :
+   forall m m':Map A,
+     MapCard A (MapMerge A m m') <= MapCard A m + MapCard A m'.
+  Proof.
+    intros. rewrite MapMerge_Restr_Card. apply le_plus_l.
+  Qed.
+
+  Lemma MapDomRestrTo_Card_ub_l :
+   forall (m:Map A) (m':Map B),
+     MapCard A (MapDomRestrTo A B m m') <= MapCard A m.
+  Proof.
+    intros. rewrite (MapSplit_Card m m'). apply le_plus_l.
+  Qed.
+
+  Lemma MapDomRestrBy_Card_ub_l :
+   forall (m:Map A) (m':Map B),
+     MapCard A (MapDomRestrBy A B m m') <= MapCard A m.
+  Proof.
+    intros. rewrite (MapSplit_Card m m'). apply le_plus_r.
+  Qed.
+
+  Lemma MapMerge_Card_disjoint :
+   forall m m':Map A,
+     MapCard A (MapMerge A m m') = MapCard A m + MapCard A m' ->
+     MapDisjoint A A m m'.
+  Proof.
+    simple induction m. intros. apply Map_M0_disjoint.
+    simpl in |- *. intros. rewrite (MapCard_Put_behind_Put m' a a0) in H. unfold MapDisjoint, in_dom in |- *.
+    simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H2.
+    rewrite (ad_eq_complete _ _ H2) in H. rewrite (MapCard_Put_2 m' a1 a0 H) in H1.
+    discriminate H1.
+    intro H2. rewrite H2 in H0. discriminate H0.
+    simple induction m'. intros. apply Map_disjoint_M0.
+    intros a y H1. rewrite <- (MapCard_ext _ _ (MapPut_as_Merge A (M2 A m0 m1) a y)) in H1.
+    unfold MapCard at 3 in H1. rewrite <- (plus_Snm_nSm (MapCard A (M2 A m0 m1)) 0) in H1.
+    rewrite <- (plus_n_O (S (MapCard A (M2 A m0 m1)))) in H1. unfold MapDisjoint, in_dom in |- *.
+    unfold MapGet at 2 in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H4.
+    rewrite <- (ad_eq_complete _ _ H4) in H2. rewrite (MapCard_Put_2 _ _ _ H1) in H2.
+    discriminate H2.
+    intro H4. rewrite H4 in H3. discriminate H3.
+    intros. unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H6.
+    unfold MapDisjoint in H0. apply H0 with (m' := m3) (a := ad_div_2 a). apply le_antisym.
+    apply MapMerge_Card_ub.
+    apply (fun p n m:nat => plus_le_reg_l n m p) with
+     (p := MapCard A m0 + MapCard A m2).
+    rewrite
+     (plus_permute_2_in_4 (MapCard A m0) (MapCard A m2) (
+        MapCard A m1) (MapCard A m3)).
+    change
+      (MapCard A (M2 A (MapMerge A m0 m2) (MapMerge A m1 m3)) =
+       MapCard A m0 + MapCard A m1 + (MapCard A m2 + MapCard A m3)) 
+     in H3.
+    rewrite <- H3. simpl in |- *. apply plus_le_compat_r. apply MapMerge_Card_ub.
+    elim (in_dom_some _ _ _ H4). intros y H7. rewrite (MapGet_M2_bit_0_1 _ a H6 m0 m1) in H7.
+    unfold in_dom in |- *. rewrite H7. reflexivity.
+    elim (in_dom_some _ _ _ H5). intros y H7. rewrite (MapGet_M2_bit_0_1 _ a H6 m2 m3) in H7.
+    unfold in_dom in |- *. rewrite H7. reflexivity.
+    intro H6. unfold MapDisjoint in H. apply H with (m' := m2) (a := ad_div_2 a). apply le_antisym.
+    apply MapMerge_Card_ub.
+    apply (fun p n m:nat => plus_le_reg_l n m p) with
+     (p := MapCard A m1 + MapCard A m3).
+    rewrite
+     (plus_comm (MapCard A m1 + MapCard A m3) (MapCard A m0 + MapCard A m2))
+     .
+    rewrite
+     (plus_permute_2_in_4 (MapCard A m0) (MapCard A m2) (
+        MapCard A m1) (MapCard A m3)).
+    rewrite
+     (plus_comm (MapCard A m1 + MapCard A m3) (MapCard A (MapMerge A m0 m2)))
+     .
+    change
+      (MapCard A (MapMerge A m0 m2) + MapCard A (MapMerge A m1 m3) =
+       MapCard A m0 + MapCard A m1 + (MapCard A m2 + MapCard A m3)) 
+     in H3.
+    rewrite <- H3. apply plus_le_compat_l. apply MapMerge_Card_ub.
+    elim (in_dom_some _ _ _ H4). intros y H7. rewrite (MapGet_M2_bit_0_0 _ a H6 m0 m1) in H7.
+    unfold in_dom in |- *. rewrite H7. reflexivity.
+    elim (in_dom_some _ _ _ H5). intros y H7. rewrite (MapGet_M2_bit_0_0 _ a H6 m2 m3) in H7.
+    unfold in_dom in |- *. rewrite H7. reflexivity.
+  Qed.
+
+  Lemma MapCard_is_Sn :
+   forall (m:Map A) (n:nat),
+     MapCard _ m = S n -> {a : ad | in_dom _ a m = true}.
+  Proof.
+    simple induction m. intros. discriminate H.
+    intros a y n H. split with a. unfold in_dom in |- *. rewrite (M1_semantics_1 _ a y). reflexivity.
+    intros. simpl in H1. elim (O_or_S (MapCard _ m0)). intro H2. elim H2. intros m2 H3.
+    elim (H _ (sym_eq H3)). intros a H4. split with (ad_double a). unfold in_dom in |- *.
+    rewrite (MapGet_M2_bit_0_0 A (ad_double a) (ad_double_bit_0 a) m0 m1).
+    rewrite (ad_double_div_2 a). elim (in_dom_some _ _ _ H4). intros y H5. rewrite H5. reflexivity.
+    intro H2. rewrite <- H2 in H1. simpl in H1. elim (H0 _ H1). intros a H3.
+    split with (ad_double_plus_un a). unfold in_dom in |- *.
+    rewrite
+     (MapGet_M2_bit_0_1 A (ad_double_plus_un a) (ad_double_plus_un_bit_0 a)
+        m0 m1).
+    rewrite (ad_double_plus_un_div_2 a). elim (in_dom_some _ _ _ H3). intros y H4. rewrite H4.
+    reflexivity.
+  Qed.
+
+End MapCard.
+
+Section MapCard2.
+
+  Variables A B : Set.
+
+  Lemma MapSubset_card_eq_1 :
+   forall (n:nat) (m:Map A) (m':Map B),
+     MapSubset _ _ m m' ->
+     MapCard _ m = n -> MapCard _ m' = n -> MapSubset _ _ m' m.
+  Proof.
+    simple induction n. intros. unfold MapSubset, in_dom in |- *. intro. rewrite (MapCard_is_O _ m H0 a).
+    rewrite (MapCard_is_O _ m' H1 a). intro H2. discriminate H2.
+    intros. elim (MapCard_is_Sn A m n0 H1). intros a H3. elim (in_dom_some _ _ _ H3).
+    intros y H4. elim (in_dom_some _ _ _ (H0 _ H3)). intros y' H6.
+    cut (eqmap _ (MapPut _ (MapRemove _ m a) a y) m). intro.
+    cut (eqmap _ (MapPut _ (MapRemove _ m' a) a y') m'). intro.
+    apply MapSubset_ext with
+     (m0 := MapPut _ (MapRemove _ m' a) a y')
+     (m2 := MapPut _ (MapRemove _ m a) a y).
+    assumption.
+    assumption.
+    apply MapSubset_Put_mono. apply H. apply MapSubset_Remove_mono. assumption.
+    rewrite <- (MapCard_Remove_2_conv _ m a y H4) in H1. inversion_clear H1. reflexivity.
+    rewrite <- (MapCard_Remove_2_conv _ m' a y' H6) in H2. inversion_clear H2. reflexivity.
+    unfold eqmap, eqm in |- *. intro. rewrite (MapPut_semantics _ (MapRemove B m' a) a y' a0).
+    elim (sumbool_of_bool (ad_eq a a0)). intro H7. rewrite H7. rewrite <- (ad_eq_complete _ _ H7).
+    apply sym_eq. assumption.
+    intro H7. rewrite H7. rewrite (MapRemove_semantics _ m' a a0). rewrite H7. reflexivity.
+    unfold eqmap, eqm in |- *. intro. rewrite (MapPut_semantics _ (MapRemove A m a) a y a0).
+    elim (sumbool_of_bool (ad_eq a a0)). intro H7. rewrite H7. rewrite <- (ad_eq_complete _ _ H7).
+    apply sym_eq. assumption.
+    intro H7. rewrite H7. rewrite (MapRemove_semantics A m a a0). rewrite H7. reflexivity.
+  Qed.
+
+  Lemma MapDomRestrTo_Card_ub_r :
+   forall (m:Map A) (m':Map B),
+     MapCard A (MapDomRestrTo A B m m') <= MapCard B m'.
+  Proof.
+    simple induction m. intro. simpl in |- *. apply le_O_n.
+    intros a y m'. simpl in |- *. elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y0 H0.
+    rewrite H0. elim (MapCard_is_not_O B m' a y0 H0). intros n H1. rewrite H1. simpl in |- *.
+    apply le_n_S. apply le_O_n.
+    intro H. rewrite H. simpl in |- *. apply le_O_n.
+    simple induction m'. simpl in |- *. apply le_O_n.
+
+    intros a y. unfold MapDomRestrTo in |- *. case (MapGet A (M2 A m0 m1) a). simpl in |- *. apply le_O_n.
+    intro. simpl in |- *. apply le_n.
+    intros. simpl in |- *. rewrite
+  (MapCard_makeM2 A (MapDomRestrTo A B m0 m2) (MapDomRestrTo A B m1 m3))
+  .
+    apply plus_le_compat. apply H.
+    apply H0.
+  Qed.
+
+End MapCard2.
+
+Section MapCard3.
+
+  Variables A B : Set.
+
+  Lemma MapMerge_Card_lb_l :
+   forall m m':Map A, MapCard A (MapMerge A m m') >= MapCard A m.
+  Proof.
+    unfold ge in |- *. intros. apply ((fun p n m:nat => plus_le_reg_l n m p) (MapCard A m')).
+    rewrite (plus_comm (MapCard A m') (MapCard A m)).
+    rewrite (plus_comm (MapCard A m') (MapCard A (MapMerge A m m'))).
+    rewrite (MapMerge_Restr_Card A m m'). apply plus_le_compat_l. apply MapDomRestrTo_Card_ub_r.
+  Qed.
+
+  Lemma MapMerge_Card_lb_r :
+   forall m m':Map A, MapCard A (MapMerge A m m') >= MapCard A m'.
+  Proof.
+    unfold ge in |- *. intros. apply ((fun p n m:nat => plus_le_reg_l n m p) (MapCard A m)). rewrite (MapMerge_Restr_Card A m m').
+    rewrite
+     (plus_comm (MapCard A (MapMerge A m m'))
+        (MapCard A (MapDomRestrTo A A m m'))).
+    apply plus_le_compat_r. apply MapDomRestrTo_Card_ub_l.
+  Qed.
+
+  Lemma MapDomRestrBy_Card_lb :
+   forall (m:Map A) (m':Map B),
+     MapCard B m' + MapCard A (MapDomRestrBy A B m m') >= MapCard A m.
+  Proof.
+    unfold ge in |- *. intros. rewrite (MapSplit_Card A B m m'). apply plus_le_compat_r.
+    apply MapDomRestrTo_Card_ub_r.
+  Qed.
+
+  Lemma MapSubset_Card_le :
+   forall (m:Map A) (m':Map B),
+     MapSubset A B m m' -> MapCard A m <= MapCard B m'.
+  Proof.
+    intros. apply le_trans with (m := MapCard B m' + MapCard A (MapDomRestrBy A B m m')).
+    exact (MapDomRestrBy_Card_lb m m').
+    rewrite (MapCard_ext _ _ _ (MapSubset_imp_2 _ _ _ _ H)). simpl in |- *. rewrite <- plus_n_O.
+    apply le_n.
+  Qed.
+
+  Lemma MapSubset_card_eq :
+   forall (m:Map A) (m':Map B),
+     MapSubset _ _ m m' ->
+     MapCard _ m' <= MapCard _ m -> eqmap _ (MapDom _ m) (MapDom _ m').
+  Proof.
+    intros. apply MapSubset_antisym. assumption.
+    cut (MapCard B m' = MapCard A m). intro. apply (MapSubset_card_eq_1 A B (MapCard A m)).
+    assumption.
+    reflexivity.
+    assumption.
+    apply le_antisym. assumption.
+    apply MapSubset_Card_le. assumption.
+  Qed.
+
+End MapCard3.
\ No newline at end of file
diff --git a/theories/IntMap/Mapfold.v b/theories/IntMap/Mapfold.v
new file mode 100644
index 00000000..641529ee
--- /dev/null
+++ b/theories/IntMap/Mapfold.v
@@ -0,0 +1,424 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i   	  $Id: Mapfold.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $      i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Fset.
+Require Import Mapaxioms.
+Require Import Mapiter.
+Require Import Lsort.
+Require Import Mapsubset.
+Require Import List.
+
+Section MapFoldResults.
+
+  Variable A : Set.
+
+  Variable M : Set.
+  Variable neutral : M.
+  Variable op : M -> M -> M.
+
+  Variable nleft : forall a:M, op neutral a = a.
+  Variable nright : forall a:M, op a neutral = a.
+  Variable assoc : forall a b c:M, op (op a b) c = op a (op b c).
+
+  Lemma MapFold_ext :
+   forall (f:ad -> A -> M) (m m':Map A),
+     eqmap A m m' -> MapFold _ _ neutral op f m = MapFold _ _ neutral op f m'.
+  Proof.
+    intros. rewrite (MapFold_as_fold A M neutral op assoc nleft nright f m).
+    rewrite (MapFold_as_fold A M neutral op assoc nleft nright f m').
+    cut (alist_of_Map A m = alist_of_Map A m'). intro. rewrite H0. reflexivity.
+    apply alist_canonical. unfold eqmap in H. apply eqm_trans with (f' := MapGet A m).
+    apply eqm_sym. apply alist_of_Map_semantics.
+    apply eqm_trans with (f' := MapGet A m'). assumption.
+    apply alist_of_Map_semantics.
+    apply alist_of_Map_sorts2.
+    apply alist_of_Map_sorts2.
+  Qed.
+
+  Lemma MapFold_ext_f_1 :
+   forall (m:Map A) (f g:ad -> A -> M) (pf:ad -> ad),
+     (forall (a:ad) (y:A), MapGet _ m a = SOME _ y -> f (pf a) y = g (pf a) y) ->
+     MapFold1 _ _ neutral op f pf m = MapFold1 _ _ neutral op g pf m.
+  Proof.
+    simple induction m. trivial.
+    simpl in |- *. intros. apply H. rewrite (ad_eq_correct a). reflexivity.
+    intros. simpl in |- *. rewrite (H f g (fun a0:ad => pf (ad_double a0))).
+    rewrite (H0 f g (fun a0:ad => pf (ad_double_plus_un a0))). reflexivity.
+    intros. apply H1. rewrite MapGet_M2_bit_0_1. rewrite ad_double_plus_un_div_2. assumption.
+    apply ad_double_plus_un_bit_0.
+    intros. apply H1. rewrite MapGet_M2_bit_0_0. rewrite ad_double_div_2. assumption.
+    apply ad_double_bit_0.
+  Qed.
+
+  Lemma MapFold_ext_f :
+   forall (f g:ad -> A -> M) (m:Map A),
+     (forall (a:ad) (y:A), MapGet _ m a = SOME _ y -> f a y = g a y) ->
+     MapFold _ _ neutral op f m = MapFold _ _ neutral op g m.
+  Proof.
+    intros. exact (MapFold_ext_f_1 m f g (fun a0:ad => a0) H).
+  Qed.
+
+  Lemma MapFold1_as_Fold_1 :
+   forall (m:Map A) (f f':ad -> A -> M) (pf pf':ad -> ad),
+     (forall (a:ad) (y:A), f (pf a) y = f' (pf' a) y) ->
+     MapFold1 _ _ neutral op f pf m = MapFold1 _ _ neutral op f' pf' m.
+  Proof.
+    simple induction m. trivial.
+    intros. simpl in |- *. apply H.
+    intros. simpl in |- *.
+    rewrite
+     (H f f' (fun a0:ad => pf (ad_double a0))
+        (fun a0:ad => pf' (ad_double a0))).
+    rewrite
+     (H0 f f' (fun a0:ad => pf (ad_double_plus_un a0))
+        (fun a0:ad => pf' (ad_double_plus_un a0))).
+    reflexivity.
+    intros. apply H1.
+    intros. apply H1.
+  Qed.
+
+  Lemma MapFold1_as_Fold :
+   forall (f:ad -> A -> M) (pf:ad -> ad) (m:Map A),
+     MapFold1 _ _ neutral op f pf m =
+     MapFold _ _ neutral op (fun (a:ad) (y:A) => f (pf a) y) m.
+  Proof.
+    intros. unfold MapFold in |- *. apply MapFold1_as_Fold_1. trivial.
+  Qed.
+
+  Lemma MapFold1_ext :
+   forall (f:ad -> A -> M) (m m':Map A),
+     eqmap A m m' ->
+     forall pf:ad -> ad,
+       MapFold1 _ _ neutral op f pf m = MapFold1 _ _ neutral op f pf m'.
+  Proof.
+    intros. rewrite MapFold1_as_Fold. rewrite MapFold1_as_Fold. apply MapFold_ext. assumption.
+  Qed.
+
+  Variable comm : forall a b:M, op a b = op b a.
+
+  Lemma MapFold_Put_disjoint_1 :
+   forall (p:positive) (f:ad -> A -> M) (pf:ad -> ad) 
+     (a1 a2:ad) (y1 y2:A),
+     ad_xor a1 a2 = ad_x p ->
+     MapFold1 A M neutral op f pf (MapPut1 A a1 y1 a2 y2 p) =
+     op (f (pf a1) y1) (f (pf a2) y2).
+  Proof.
+    simple induction p. intros. simpl in |- *. elim (sumbool_of_bool (ad_bit_0 a1)). intro H1. rewrite H1.
+    simpl in |- *. rewrite ad_div_2_double_plus_un. rewrite ad_div_2_double. apply comm.
+    change (ad_bit_0 a2 = negb true) in |- *. rewrite <- H1. rewrite (ad_neg_bit_0_2 _ _ _ H0).
+    rewrite negb_elim. reflexivity.
+    assumption.
+    intro H1. rewrite H1. simpl in |- *. rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un.
+    reflexivity.
+    change (ad_bit_0 a2 = negb false) in |- *. rewrite <- H1. rewrite (ad_neg_bit_0_2 _ _ _ H0).
+    rewrite negb_elim. reflexivity.
+    assumption.
+    simpl in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a1)). intro H1. rewrite H1. simpl in |- *.
+    rewrite nleft.
+    rewrite
+     (H f (fun a0:ad => pf (ad_double_plus_un a0)) (
+        ad_div_2 a1) (ad_div_2 a2) y1 y2).
+    rewrite ad_div_2_double_plus_un. rewrite ad_div_2_double_plus_un. reflexivity.
+    rewrite <- (ad_same_bit_0 _ _ _ H0). assumption.
+    assumption.
+    rewrite <- ad_xor_div_2. rewrite H0. reflexivity.
+    intro H1. rewrite H1. simpl in |- *. rewrite nright.
+    rewrite
+     (H f (fun a0:ad => pf (ad_double a0)) (ad_div_2 a1) (ad_div_2 a2) y1 y2)
+     .
+    rewrite ad_div_2_double. rewrite ad_div_2_double. reflexivity.
+    rewrite <- (ad_same_bit_0 _ _ _ H0). assumption.
+    assumption.
+    rewrite <- ad_xor_div_2. rewrite H0. reflexivity.
+    intros. simpl in |- *. elim (sumbool_of_bool (ad_bit_0 a1)). intro H0. rewrite H0. simpl in |- *.
+    rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un. apply comm.
+    assumption.
+    change (ad_bit_0 a2 = negb true) in |- *. rewrite <- H0. rewrite (ad_neg_bit_0_1 _ _ H).
+    rewrite negb_elim. reflexivity.
+    intro H0. rewrite H0. simpl in |- *. rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un.
+    reflexivity.
+    change (ad_bit_0 a2 = negb false) in |- *. rewrite <- H0. rewrite (ad_neg_bit_0_1 _ _ H).
+    rewrite negb_elim. reflexivity.
+    assumption.
+  Qed.
+
+  Lemma MapFold_Put_disjoint_2 :
+   forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A) (pf:ad -> ad),
+     MapGet A m a = NONE A ->
+     MapFold1 A M neutral op f pf (MapPut A m a y) =
+     op (f (pf a) y) (MapFold1 A M neutral op f pf m).
+  Proof.
+    simple induction m. intros. simpl in |- *. rewrite (nright (f (pf a) y)). reflexivity.
+    intros a1 y1 a2 y2 pf H. simpl in |- *. elim (ad_sum (ad_xor a1 a2)). intro H0. elim H0.
+    intros p H1. rewrite H1. rewrite comm. exact (MapFold_Put_disjoint_1 p f pf a1 a2 y1 y2 H1).
+    intro H0. rewrite (ad_eq_complete _ _ (ad_xor_eq_true _ _ H0)) in H.
+    rewrite (M1_semantics_1 A a2 y1) in H. discriminate H.
+    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H2.
+    cut (MapPut A (M2 A m0 m1) a y = M2 A m0 (MapPut A m1 (ad_div_2 a) y)). intro.
+    rewrite H3. simpl in |- *. rewrite (H0 (ad_div_2 a) y (fun a0:ad => pf (ad_double_plus_un a0))).
+    rewrite ad_div_2_double_plus_un. rewrite <- assoc.
+    rewrite
+     (comm (MapFold1 A M neutral op f (fun a0:ad => pf (ad_double a0)) m0)
+        (f (pf a) y)).
+    rewrite assoc. reflexivity.
+    assumption.
+    rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. assumption.
+    simpl in |- *. elim (ad_sum a). intro H3. elim H3. intro p. elim p. intros p0 H4 H5. rewrite H5.
+    reflexivity.
+    intros p0 H4 H5. rewrite H5 in H2. discriminate H2.
+    intro H4. rewrite H4. reflexivity.
+    intro H3. rewrite H3 in H2. discriminate H2.
+    intro H2. cut (MapPut A (M2 A m0 m1) a y = M2 A (MapPut A m0 (ad_div_2 a) y) m1).
+    intro. rewrite H3. simpl in |- *. rewrite (H (ad_div_2 a) y (fun a0:ad => pf (ad_double a0))).
+    rewrite ad_div_2_double. rewrite <- assoc. reflexivity.
+    assumption.
+    rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. assumption.
+    simpl in |- *. elim (ad_sum a). intro H3. elim H3. intro p. elim p. intros p0 H4 H5. rewrite H5 in H2.
+    discriminate H2.
+    intros p0 H4 H5. rewrite H5. reflexivity.
+    intro H4. rewrite H4 in H2. discriminate H2.
+    intro H3. rewrite H3. reflexivity.
+  Qed.
+
+  Lemma MapFold_Put_disjoint :
+   forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A),
+     MapGet A m a = NONE A ->
+     MapFold A M neutral op f (MapPut A m a y) =
+     op (f a y) (MapFold A M neutral op f m).
+  Proof.
+    intros. exact (MapFold_Put_disjoint_2 f m a y (fun a0:ad => a0) H).
+  Qed.
+
+  Lemma MapFold_Put_behind_disjoint_2 :
+   forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A) (pf:ad -> ad),
+     MapGet A m a = NONE A ->
+     MapFold1 A M neutral op f pf (MapPut_behind A m a y) =
+     op (f (pf a) y) (MapFold1 A M neutral op f pf m).
+  Proof.
+    intros. cut (eqmap A (MapPut_behind A m a y) (MapPut A m a y)). intro.
+    rewrite (MapFold1_ext f _ _ H0 pf). apply MapFold_Put_disjoint_2. assumption.
+    apply eqmap_trans with (m' := MapMerge A (M1 A a y) m). apply MapPut_behind_as_Merge.
+    apply eqmap_trans with (m' := MapMerge A m (M1 A a y)).
+    apply eqmap_trans with (m' := MapDelta A (M1 A a y) m). apply eqmap_sym. apply MapDelta_disjoint.
+    unfold MapDisjoint in |- *. unfold in_dom in |- *. simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)).
+    intro H2. rewrite (ad_eq_complete _ _ H2) in H. rewrite H in H1. discriminate H1.
+    intro H2. rewrite H2 in H0. discriminate H0.
+    apply eqmap_trans with (m' := MapDelta A m (M1 A a y)). apply MapDelta_sym.
+    apply MapDelta_disjoint. unfold MapDisjoint in |- *. unfold in_dom in |- *. simpl in |- *. intros.
+    elim (sumbool_of_bool (ad_eq a a0)). intro H2. rewrite (ad_eq_complete _ _ H2) in H.
+    rewrite H in H0. discriminate H0.
+    intro H2. rewrite H2 in H1. discriminate H1.
+    apply eqmap_sym. apply MapPut_as_Merge.
+  Qed.
+
+  Lemma MapFold_Put_behind_disjoint :
+   forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A),
+     MapGet A m a = NONE A ->
+     MapFold A M neutral op f (MapPut_behind A m a y) =
+     op (f a y) (MapFold A M neutral op f m).
+  Proof.
+    intros. exact (MapFold_Put_behind_disjoint_2 f m a y (fun a0:ad => a0) H).
+  Qed.
+
+  Lemma MapFold_Merge_disjoint_1 :
+   forall (f:ad -> A -> M) (m1 m2:Map A) (pf:ad -> ad),
+     MapDisjoint A A m1 m2 ->
+     MapFold1 A M neutral op f pf (MapMerge A m1 m2) =
+     op (MapFold1 A M neutral op f pf m1) (MapFold1 A M neutral op f pf m2).
+  Proof.
+    simple induction m1. simpl in |- *. intros. rewrite nleft. reflexivity.
+    intros. unfold MapMerge in |- *. apply (MapFold_Put_behind_disjoint_2 f m2 a a0 pf).
+    apply in_dom_none. exact (MapDisjoint_M1_l _ _ m2 a a0 H).
+    simple induction m2. intros. simpl in |- *. rewrite nright. reflexivity.
+    intros. unfold MapMerge in |- *. rewrite (MapFold_Put_disjoint_2 f (M2 A m m0) a a0 pf). apply comm.
+    apply in_dom_none. exact (MapDisjoint_M1_r _ _ (M2 A m m0) a a0 H1).
+    intros. simpl in |- *. rewrite (H m3 (fun a0:ad => pf (ad_double a0))).
+    rewrite (H0 m4 (fun a0:ad => pf (ad_double_plus_un a0))).
+    cut (forall a b c d:M, op (op a b) (op c d) = op (op a c) (op b d)). intro. apply H4.
+    intros. rewrite assoc. rewrite <- (assoc b c d). rewrite (comm b c). rewrite (assoc c b d).
+    rewrite assoc. reflexivity.
+    exact (MapDisjoint_M2_r _ _ _ _ _ _ H3).
+    exact (MapDisjoint_M2_l _ _ _ _ _ _ H3).
+  Qed.
+
+  Lemma MapFold_Merge_disjoint :
+   forall (f:ad -> A -> M) (m1 m2:Map A),
+     MapDisjoint A A m1 m2 ->
+     MapFold A M neutral op f (MapMerge A m1 m2) =
+     op (MapFold A M neutral op f m1) (MapFold A M neutral op f m2).
+  Proof.
+    intros. exact (MapFold_Merge_disjoint_1 f m1 m2 (fun a0:ad => a0) H).
+  Qed.
+ 
+End MapFoldResults.
+
+Section MapFoldDistr.
+
+  Variable A : Set.
+
+  Variable M : Set.
+  Variable neutral : M.
+  Variable op : M -> M -> M.
+
+  Variable M' : Set.
+  Variable neutral' : M'.
+  Variable op' : M' -> M' -> M'.
+
+  Variable N : Set.
+
+  Variable times : M -> N -> M'.
+
+  Variable absorb : forall c:N, times neutral c = neutral'.
+  Variable
+    distr :
+      forall (a b:M) (c:N), times (op a b) c = op' (times a c) (times b c).
+
+  Lemma MapFold_distr_r_1 :
+   forall (f:ad -> A -> M) (m:Map A) (c:N) (pf:ad -> ad),
+     times (MapFold1 A M neutral op f pf m) c =
+     MapFold1 A M' neutral' op' (fun (a:ad) (y:A) => times (f a y) c) pf m.
+  Proof.
+    simple induction m. intros. exact (absorb c).
+    trivial.
+    intros. simpl in |- *. rewrite distr. rewrite H. rewrite H0. reflexivity.
+  Qed.
+
+  Lemma MapFold_distr_r :
+   forall (f:ad -> A -> M) (m:Map A) (c:N),
+     times (MapFold A M neutral op f m) c =
+     MapFold A M' neutral' op' (fun (a:ad) (y:A) => times (f a y) c) m.
+  Proof.
+    intros. exact (MapFold_distr_r_1 f m c (fun a:ad => a)).
+  Qed.
+
+End MapFoldDistr.
+
+Section MapFoldDistrL.
+
+  Variable A : Set.
+
+  Variable M : Set.
+  Variable neutral : M.
+  Variable op : M -> M -> M.
+
+  Variable M' : Set.
+  Variable neutral' : M'.
+  Variable op' : M' -> M' -> M'.
+
+  Variable N : Set.
+
+  Variable times : N -> M -> M'.
+
+  Variable absorb : forall c:N, times c neutral = neutral'.
+  Variable
+    distr :
+      forall (a b:M) (c:N), times c (op a b) = op' (times c a) (times c b).
+
+  Lemma MapFold_distr_l :
+   forall (f:ad -> A -> M) (m:Map A) (c:N),
+     times c (MapFold A M neutral op f m) =
+     MapFold A M' neutral' op' (fun (a:ad) (y:A) => times c (f a y)) m.
+  Proof.
+    intros. apply MapFold_distr_r with (times := fun (a:M) (b:N) => times b a);
+  assumption.
+  Qed.
+
+End MapFoldDistrL.
+
+Section MapFoldExists.
+
+  Variable A : Set.
+
+  Lemma MapFold_orb_1 :
+   forall (f:ad -> A -> bool) (m:Map A) (pf:ad -> ad),
+     MapFold1 A bool false orb f pf m =
+     match MapSweep1 A f pf m with
+     | SOME _ => true
+     | _ => false
+     end.
+  Proof.
+    simple induction m. trivial.
+    intros a y pf. simpl in |- *. unfold MapSweep2 in |- *. case (f (pf a) y); reflexivity.
+    intros. simpl in |- *. rewrite (H (fun a0:ad => pf (ad_double a0))).
+    rewrite (H0 (fun a0:ad => pf (ad_double_plus_un a0))).
+    case (MapSweep1 A f (fun a0:ad => pf (ad_double a0)) m0); reflexivity.
+  Qed.
+
+  Lemma MapFold_orb :
+   forall (f:ad -> A -> bool) (m:Map A),
+     MapFold A bool false orb f m =
+     match MapSweep A f m with
+     | SOME _ => true
+     | _ => false
+     end.
+  Proof.
+    intros. exact (MapFold_orb_1 f m (fun a:ad => a)).
+  Qed.
+
+End MapFoldExists.
+
+Section DMergeDef.
+
+  Variable A : Set.
+
+  Definition DMerge :=
+    MapFold (Map A) (Map A) (M0 A) (MapMerge A) (fun (_:ad) (m:Map A) => m).
+
+  Lemma in_dom_DMerge_1 :
+   forall (m:Map (Map A)) (a:ad),
+     in_dom A a (DMerge m) =
+     match MapSweep _ (fun (_:ad) (m0:Map A) => in_dom A a m0) m with
+     | SOME _ => true
+     | _ => false
+     end.
+  Proof.
+    unfold DMerge in |- *. intros.
+    rewrite
+     (MapFold_distr_l (Map A) (Map A) (M0 A) (MapMerge A) bool false orb ad
+        (in_dom A) (fun c:ad => refl_equal _) (in_dom_merge A))
+     .
+    apply MapFold_orb.
+  Qed.
+
+  Lemma in_dom_DMerge_2 :
+   forall (m:Map (Map A)) (a:ad),
+     in_dom A a (DMerge m) = true ->
+     {b : ad & 
+     {m0 : Map A | MapGet _ m b = SOME _ m0 /\ in_dom A a m0 = true}}.
+  Proof.
+    intros m a. rewrite in_dom_DMerge_1.
+    elim
+     (option_sum _
+        (MapSweep (Map A) (fun (_:ad) (m0:Map A) => in_dom A a m0) m)).
+    intro H. elim H. intro r. elim r. intros b m0 H0. intro. split with b. split with m0.
+    split. exact (MapSweep_semantics_2 _ _ _ _ _ H0).
+    exact (MapSweep_semantics_1 _ _ _ _ _ H0).
+    intro H. rewrite H. intro. discriminate H0.
+  Qed.
+
+  Lemma in_dom_DMerge_3 :
+   forall (m:Map (Map A)) (a b:ad) (m0:Map A),
+     MapGet _ m a = SOME _ m0 ->
+     in_dom A b m0 = true -> in_dom A b (DMerge m) = true.
+  Proof.
+    intros m a b m0 H H0. rewrite in_dom_DMerge_1.
+    elim
+     (MapSweep_semantics_4 _ (fun (_:ad) (m'0:Map A) => in_dom A b m'0) _ _ _
+        H H0).
+    intros a' H1. elim H1. intros m'0 H2. rewrite H2. reflexivity.
+  Qed.
+
+End DMergeDef.
\ No newline at end of file
diff --git a/theories/IntMap/Mapiter.v b/theories/IntMap/Mapiter.v
new file mode 100644
index 00000000..f5d443cc
--- /dev/null
+++ b/theories/IntMap/Mapiter.v
@@ -0,0 +1,620 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Mapiter.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Mapaxioms.
+Require Import Fset.
+Require Import List.
+
+Section MapIter.
+
+  Variable A : Set.
+
+  Section MapSweepDef.
+
+  Variable f : ad -> A -> bool.
+
+  Definition MapSweep2 (a0:ad) (y:A) :=
+    if f a0 y then SOME _ (a0, y) else NONE _.
+
+  Fixpoint MapSweep1 (pf:ad -> ad) (m:Map A) {struct m} : 
+   option (ad * A) :=
+    match m with
+    | M0 => NONE _
+    | M1 a y => MapSweep2 (pf a) y
+    | M2 m m' =>
+        match MapSweep1 (fun a:ad => pf (ad_double a)) m with
+        | SOME r => SOME _ r
+        | NONE => MapSweep1 (fun a:ad => pf (ad_double_plus_un a)) m'
+        end
+    end.
+
+  Definition MapSweep (m:Map A) := MapSweep1 (fun a:ad => a) m.
+
+  Lemma MapSweep_semantics_1_1 :
+   forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A),
+     MapSweep1 pf m = SOME _ (a, y) -> f a y = true.
+  Proof.
+    simple induction m. intros. discriminate H.
+    simpl in |- *. intros a y pf a0 y0. elim (sumbool_of_bool (f (pf a) y)). intro H. unfold MapSweep2 in |- *.
+    rewrite H. intro H0. inversion H0. rewrite <- H3. assumption.
+    intro H. unfold MapSweep2 in |- *. rewrite H. intro H0. discriminate H0.
+    simpl in |- *. intros. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)).
+    intro H2. elim H2. intros r H3. rewrite H3 in H1. inversion H1. rewrite H5 in H3.
+    exact (H (fun a0:ad => pf (ad_double a0)) a y H3).
+    intro H2. rewrite H2 in H1. exact (H0 (fun a0:ad => pf (ad_double_plus_un a0)) a y H1).
+  Qed.
+
+  Lemma MapSweep_semantics_1 :
+   forall (m:Map A) (a:ad) (y:A), MapSweep m = SOME _ (a, y) -> f a y = true.
+  Proof.
+    intros. exact (MapSweep_semantics_1_1 m (fun a:ad => a) a y H).
+  Qed.
+
+  Lemma MapSweep_semantics_2_1 :
+   forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A),
+     MapSweep1 pf m = SOME _ (a, y) -> {a' : ad | a = pf a'}.
+  Proof.
+    simple induction m. intros. discriminate H.
+    simpl in |- *. unfold MapSweep2 in |- *. intros a y pf a0 y0. case (f (pf a) y). intros. split with a.
+    inversion H. reflexivity.
+    intro. discriminate H.
+    intros m0 H m1 H0 pf a y. simpl in |- *.
+    elim
+     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). intro H1. elim H1.
+    intros r H2. rewrite H2. intro H3. inversion H3. rewrite H5 in H2.
+    elim (H (fun a0:ad => pf (ad_double a0)) a y H2). intros a0 H6. split with (ad_double a0).
+    assumption.
+    intro H1. rewrite H1. intro H2. elim (H0 (fun a0:ad => pf (ad_double_plus_un a0)) a y H2).
+    intros a0 H3. split with (ad_double_plus_un a0). assumption.
+  Qed.
+
+  Lemma MapSweep_semantics_2_2 :
+   forall (m:Map A) (pf fp:ad -> ad),
+     (forall a0:ad, fp (pf a0) = a0) ->
+     forall (a:ad) (y:A),
+       MapSweep1 pf m = SOME _ (a, y) -> MapGet A m (fp a) = SOME _ y.
+  Proof.
+    simple induction m. intros. discriminate H0.
+    simpl in |- *. intros a y pf fp H a0 y0. unfold MapSweep2 in |- *. elim (sumbool_of_bool (f (pf a) y)).
+    intro H0. rewrite H0. intro H1. inversion H1. rewrite (H a). rewrite (ad_eq_correct a).
+    reflexivity.
+    intro H0. rewrite H0. intro H1. discriminate H1.
+    intros. rewrite (MapGet_M2_bit_0_if A m0 m1 (fp a)). elim (sumbool_of_bool (ad_bit_0 (fp a))).
+    intro H3. rewrite H3. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)).
+    intro H4. simpl in H2. apply
+  (H0 (fun a0:ad => pf (ad_double_plus_un a0))
+     (fun a0:ad => ad_div_2 (fp a0))).
+    intro. rewrite H1. apply ad_double_plus_un_div_2.
+    elim
+     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). intro H5. elim H5.
+    intros r H6. rewrite H6 in H2. inversion H2. rewrite H8 in H6.
+    elim (MapSweep_semantics_2_1 m0 (fun a0:ad => pf (ad_double a0)) a y H6). intros a0 H9.
+    rewrite H9 in H3. rewrite (H1 (ad_double a0)) in H3. rewrite (ad_double_bit_0 a0) in H3.
+    discriminate H3.
+    intro H5. rewrite H5 in H2. assumption.
+    intro H4. simpl in H2. rewrite H4 in H2.
+    apply
+     (H0 (fun a0:ad => pf (ad_double_plus_un a0))
+        (fun a0:ad => ad_div_2 (fp a0))). intro.
+    rewrite H1. apply ad_double_plus_un_div_2.
+    assumption.
+    intro H3. rewrite H3. simpl in H2.
+    elim
+     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). intro H4. elim H4.
+    intros r H5. rewrite H5 in H2. inversion H2. rewrite H7 in H5.
+    apply
+     (H (fun a0:ad => pf (ad_double a0)) (fun a0:ad => ad_div_2 (fp a0))). intro. rewrite H1.
+    apply ad_double_div_2.
+    assumption.
+    intro H4. rewrite H4 in H2.
+    elim
+     (MapSweep_semantics_2_1 m1 (fun a0:ad => pf (ad_double_plus_un a0)) a y
+        H2).
+    intros a0 H5. rewrite H5 in H3. rewrite (H1 (ad_double_plus_un a0)) in H3.
+    rewrite (ad_double_plus_un_bit_0 a0) in H3. discriminate H3.
+  Qed.
+
+  Lemma MapSweep_semantics_2 :
+   forall (m:Map A) (a:ad) (y:A),
+     MapSweep m = SOME _ (a, y) -> MapGet A m a = SOME _ y.
+  Proof.
+    intros.
+    exact
+     (MapSweep_semantics_2_2 m (fun a0:ad => a0) (fun a0:ad => a0)
+        (fun a0:ad => refl_equal a0) a y H).
+  Qed.
+
+  Lemma MapSweep_semantics_3_1 :
+   forall (m:Map A) (pf:ad -> ad),
+     MapSweep1 pf m = NONE _ ->
+     forall (a:ad) (y:A), MapGet A m a = SOME _ y -> f (pf a) y = false.
+  Proof.
+    simple induction m. intros. discriminate H0.
+    simpl in |- *. unfold MapSweep2 in |- *. intros a y pf. elim (sumbool_of_bool (f (pf a) y)). intro H.
+    rewrite H. intro. discriminate H0.
+    intro H. rewrite H. intros H0 a0 y0. elim (sumbool_of_bool (ad_eq a a0)). intro H1. rewrite H1.
+    intro H2. inversion H2. rewrite <- H4. rewrite <- (ad_eq_complete _ _ H1). assumption.
+    intro H1. rewrite H1. intro. discriminate H2.
+    intros. simpl in H1. elim (option_sum (ad * A) (MapSweep1 (fun a:ad => pf (ad_double a)) m0)).
+    intro H3. elim H3. intros r H4. rewrite H4 in H1. discriminate H1.
+    intro H3. rewrite H3 in H1. elim (sumbool_of_bool (ad_bit_0 a)). intro H4.
+    rewrite (MapGet_M2_bit_0_1 A a H4 m0 m1) in H2. rewrite <- (ad_div_2_double_plus_un a H4).
+    exact (H0 (fun a:ad => pf (ad_double_plus_un a)) H1 (ad_div_2 a) y H2).
+    intro H4. rewrite (MapGet_M2_bit_0_0 A a H4 m0 m1) in H2. rewrite <- (ad_div_2_double a H4).
+    exact (H (fun a:ad => pf (ad_double a)) H3 (ad_div_2 a) y H2).
+  Qed.
+
+  Lemma MapSweep_semantics_3 :
+   forall m:Map A,
+     MapSweep m = NONE _ ->
+     forall (a:ad) (y:A), MapGet A m a = SOME _ y -> f a y = false.
+  Proof.
+    intros.
+    exact (MapSweep_semantics_3_1 m (fun a0:ad => a0) H a y H0).
+  Qed.
+
+  Lemma MapSweep_semantics_4_1 :
+   forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A),
+     MapGet A m a = SOME A y ->
+     f (pf a) y = true ->
+     {a' : ad &  {y' : A | MapSweep1 pf m = SOME _ (a', y')}}.
+  Proof.
+    simple induction m. intros. discriminate H.
+    intros. elim (sumbool_of_bool (ad_eq a a1)). intro H1. split with (pf a1). split with y.
+    rewrite (ad_eq_complete _ _ H1). unfold MapSweep1, MapSweep2 in |- *.
+    rewrite (ad_eq_complete _ _ H1) in H. rewrite (M1_semantics_1 _ a1 a0) in H.
+    inversion H. rewrite H0. reflexivity.
+
+    intro H1. rewrite (M1_semantics_2 _ a a1 a0 H1) in H. discriminate H.
+
+    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H3.
+    rewrite (MapGet_M2_bit_0_1 _ _ H3 m0 m1) in H1.
+    rewrite <- (ad_div_2_double_plus_un a H3) in H2.
+    elim (H0 (fun a0:ad => pf (ad_double_plus_un a0)) (ad_div_2 a) y H1 H2). intros a'' H4. elim H4.
+    intros y'' H5. simpl in |- *. elim (option_sum _ (MapSweep1 (fun a:ad => pf (ad_double a)) m0)).
+    intro H6. elim H6. intro r. elim r. intros a''' y''' H7. rewrite H7. split with a'''.
+    split with y'''. reflexivity.
+    intro H6. rewrite H6. split with a''. split with y''. assumption.
+    intro H3. rewrite (MapGet_M2_bit_0_0 _ _ H3 m0 m1) in H1.
+    rewrite <- (ad_div_2_double a H3) in H2.
+    elim (H (fun a0:ad => pf (ad_double a0)) (ad_div_2 a) y H1 H2). intros a'' H4. elim H4.
+    intros y'' H5. split with a''. split with y''. simpl in |- *. rewrite H5. reflexivity.
+  Qed.
+
+  Lemma MapSweep_semantics_4 :
+   forall (m:Map A) (a:ad) (y:A),
+     MapGet A m a = SOME A y ->
+     f a y = true -> {a' : ad &  {y' : A | MapSweep m = SOME _ (a', y')}}.
+  Proof.
+    intros. exact (MapSweep_semantics_4_1 m (fun a0:ad => a0) a y H H0).
+  Qed.
+
+  End MapSweepDef.
+
+  Variable B : Set.
+
+  Fixpoint MapCollect1 (f:ad -> A -> Map B) (pf:ad -> ad) 
+   (m:Map A) {struct m} : Map B :=
+    match m with
+    | M0 => M0 B
+    | M1 a y => f (pf a) y
+    | M2 m1 m2 =>
+        MapMerge B (MapCollect1 f (fun a0:ad => pf (ad_double a0)) m1)
+          (MapCollect1 f (fun a0:ad => pf (ad_double_plus_un a0)) m2)
+    end.
+
+  Definition MapCollect (f:ad -> A -> Map B) (m:Map A) :=
+    MapCollect1 f (fun a:ad => a) m.
+
+  Section MapFoldDef.
+
+    Variable M : Set.
+    Variable neutral : M.
+    Variable op : M -> M -> M.
+
+    Fixpoint MapFold1 (f:ad -> A -> M) (pf:ad -> ad) 
+     (m:Map A) {struct m} : M :=
+      match m with
+      | M0 => neutral
+      | M1 a y => f (pf a) y
+      | M2 m1 m2 =>
+          op (MapFold1 f (fun a0:ad => pf (ad_double a0)) m1)
+            (MapFold1 f (fun a0:ad => pf (ad_double_plus_un a0)) m2)
+      end.
+
+    Definition MapFold (f:ad -> A -> M) (m:Map A) :=
+      MapFold1 f (fun a:ad => a) m.
+
+    Lemma MapFold_empty : forall f:ad -> A -> M, MapFold f (M0 A) = neutral.
+    Proof.
+      trivial.
+    Qed.
+
+    Lemma MapFold_M1 :
+     forall (f:ad -> A -> M) (a:ad) (y:A), MapFold f (M1 A a y) = f a y.
+    Proof.
+      trivial.
+    Qed.
+
+    Variable State : Set.
+    Variable f : State -> ad -> A -> State * M.
+
+    Fixpoint MapFold1_state (state:State) (pf:ad -> ad) 
+     (m:Map A) {struct m} : State * M :=
+      match m with
+      | M0 => (state, neutral)
+      | M1 a y => f state (pf a) y
+      | M2 m1 m2 =>
+          match MapFold1_state state (fun a0:ad => pf (ad_double a0)) m1 with
+          | (state1, x1) =>
+              match
+                MapFold1_state state1
+                  (fun a0:ad => pf (ad_double_plus_un a0)) m2
+              with
+              | (state2, x2) => (state2, op x1 x2)
+              end
+          end
+      end.
+
+    Definition MapFold_state (state:State) :=
+      MapFold1_state state (fun a:ad => a).
+
+    Lemma pair_sp : forall (B C:Set) (x:B * C), x = (fst x, snd x).
+    Proof.
+      simple induction x. trivial.
+    Qed.
+
+    Lemma MapFold_state_stateless_1 :
+     forall (m:Map A) (g:ad -> A -> M) (pf:ad -> ad),
+       (forall (state:State) (a:ad) (y:A), snd (f state a y) = g a y) ->
+       forall state:State, snd (MapFold1_state state pf m) = MapFold1 g pf m.
+    Proof.
+      simple induction m. trivial.
+      intros. simpl in |- *. apply H.
+      intros. simpl in |- *. rewrite
+  (pair_sp _ _ (MapFold1_state state (fun a0:ad => pf (ad_double a0)) m0))
+  .
+      rewrite (H g (fun a0:ad => pf (ad_double a0)) H1 state).
+      rewrite
+       (pair_sp _ _
+          (MapFold1_state
+             (fst (MapFold1_state state (fun a0:ad => pf (ad_double a0)) m0))
+             (fun a0:ad => pf (ad_double_plus_un a0)) m1))
+       .
+      simpl in |- *.
+      rewrite
+       (H0 g (fun a0:ad => pf (ad_double_plus_un a0)) H1
+          (fst (MapFold1_state state (fun a0:ad => pf (ad_double a0)) m0)))
+       .
+      reflexivity.
+    Qed.
+
+    Lemma MapFold_state_stateless :
+     forall g:ad -> A -> M,
+       (forall (state:State) (a:ad) (y:A), snd (f state a y) = g a y) ->
+       forall (state:State) (m:Map A),
+         snd (MapFold_state state m) = MapFold g m.
+    Proof.
+      intros. exact (MapFold_state_stateless_1 m g (fun a0:ad => a0) H state).
+    Qed.
+
+  End MapFoldDef.
+
+  Lemma MapCollect_as_Fold :
+   forall (f:ad -> A -> Map B) (m:Map A),
+     MapCollect f m = MapFold (Map B) (M0 B) (MapMerge B) f m.
+  Proof.
+    simple induction m; trivial.
+  Qed.
+
+  Definition alist := list (ad * A).
+  Definition anil := nil (A:=(ad * A)).
+  Definition acons := cons (A:=(ad * A)).
+  Definition aapp := app (A:=(ad * A)).
+
+  Definition alist_of_Map :=
+    MapFold alist anil aapp (fun (a:ad) (y:A) => acons (a, y) anil).
+
+  Fixpoint alist_semantics (l:alist) : ad -> option A :=
+    match l with
+    | nil => fun _:ad => NONE A
+    | (a, y) :: l' =>
+        fun a0:ad => if ad_eq a a0 then SOME A y else alist_semantics l' a0
+    end.
+
+  Lemma alist_semantics_app :
+   forall (l l':alist) (a:ad),
+     alist_semantics (aapp l l') a =
+     match alist_semantics l a with
+     | NONE => alist_semantics l' a
+     | SOME y => SOME A y
+     end.
+  Proof.
+    unfold aapp in |- *. simple induction l. trivial.
+    intros. elim a. intros a1 y1. simpl in |- *. case (ad_eq a1 a0). reflexivity.
+    apply H.
+  Qed.
+
+  Lemma alist_of_Map_semantics_1_1 :
+   forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A),
+     alist_semantics
+       (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) pf
+          m) a = SOME A y -> {a' : ad | a = pf a'}.
+  Proof.
+    simple induction m. simpl in |- *. intros. discriminate H.
+    simpl in |- *. intros a y pf a0 y0. elim (sumbool_of_bool (ad_eq (pf a) a0)). intro H. rewrite H.
+    intro H0. split with a. rewrite (ad_eq_complete _ _ H). reflexivity.
+    intro H. rewrite H. intro H0. discriminate H0.
+    intros. change
+   (alist_semantics
+      (aapp
+         (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
+            (fun a0:ad => pf (ad_double a0)) m0)
+         (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
+            (fun a0:ad => pf (ad_double_plus_un a0)) m1)) a = 
+    SOME A y) in H1.
+    rewrite
+     (alist_semantics_app
+        (MapFold1 alist anil aapp (fun (a0:ad) (y0:A) => acons (a0, y0) anil)
+           (fun a0:ad => pf (ad_double a0)) m0)
+        (MapFold1 alist anil aapp (fun (a0:ad) (y0:A) => acons (a0, y0) anil)
+           (fun a0:ad => pf (ad_double_plus_un a0)) m1) a)
+      in H1.
+    elim
+     (option_sum A
+        (alist_semantics
+           (MapFold1 alist anil aapp
+              (fun (a0:ad) (y0:A) => acons (a0, y0) anil)
+              (fun a0:ad => pf (ad_double a0)) m0) a)).
+    intro H2. elim H2. intros y0 H3. elim (H (fun a0:ad => pf (ad_double a0)) a y0 H3). intros a0 H4.
+    split with (ad_double a0). assumption.
+    intro H2. rewrite H2 in H1. elim (H0 (fun a0:ad => pf (ad_double_plus_un a0)) a y H1).
+    intros a0 H3. split with (ad_double_plus_un a0). assumption.
+  Qed.
+
+  Definition ad_inj (pf:ad -> ad) :=
+    forall a0 a1:ad, pf a0 = pf a1 -> a0 = a1.
+
+  Lemma ad_comp_double_inj :
+   forall pf:ad -> ad, ad_inj pf -> ad_inj (fun a0:ad => pf (ad_double a0)).
+  Proof.
+    unfold ad_inj in |- *. intros. apply ad_double_inj. exact (H _ _ H0).
+  Qed.
+
+  Lemma ad_comp_double_plus_un_inj :
+   forall pf:ad -> ad,
+     ad_inj pf -> ad_inj (fun a0:ad => pf (ad_double_plus_un a0)).
+  Proof.
+    unfold ad_inj in |- *. intros. apply ad_double_plus_un_inj. exact (H _ _ H0).
+  Qed.
+
+  Lemma alist_of_Map_semantics_1 :
+   forall (m:Map A) (pf:ad -> ad),
+     ad_inj pf ->
+     forall a:ad,
+       MapGet A m a =
+       alist_semantics
+         (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
+            pf m) (pf a).
+  Proof.
+    simple induction m. trivial.
+    simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H0. rewrite H0.
+    rewrite (ad_eq_complete _ _ H0). rewrite (ad_eq_correct (pf a1)). reflexivity.
+    intro H0. rewrite H0. elim (sumbool_of_bool (ad_eq (pf a) (pf a1))). intro H1.
+    rewrite (H a a1 (ad_eq_complete _ _ H1)) in H0. rewrite (ad_eq_correct a1) in H0.
+    discriminate H0.
+    intro H1. rewrite H1. reflexivity.
+    intros. change
+   (MapGet A (M2 A m0 m1) a =
+    alist_semantics
+      (aapp
+         (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
+            (fun a0:ad => pf (ad_double a0)) m0)
+         (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
+            (fun a0:ad => pf (ad_double_plus_un a0)) m1)) (
+      pf a)) in |- *.
+    rewrite alist_semantics_app. rewrite (MapGet_M2_bit_0_if A m0 m1 a).
+    elim (ad_double_or_double_plus_un a). intro H2. elim H2. intros a0 H3. rewrite H3.
+    rewrite (ad_double_bit_0 a0).
+    rewrite <-
+     (H (fun a1:ad => pf (ad_double a1)) (ad_comp_double_inj pf H1) a0)
+     .
+    rewrite ad_double_div_2. case (MapGet A m0 a0).
+    elim
+     (option_sum A
+        (alist_semantics
+           (MapFold1 alist anil aapp
+              (fun (a1:ad) (y:A) => acons (a1, y) anil)
+              (fun a1:ad => pf (ad_double_plus_un a1)) m1)
+           (pf (ad_double a0)))).
+    intro H4. elim H4. intros y H5.
+    elim
+     (alist_of_Map_semantics_1_1 m1 (fun a1:ad => pf (ad_double_plus_un a1))
+        (pf (ad_double a0)) y H5).
+    intros a1 H6. cut (ad_bit_0 (ad_double a0) = ad_bit_0 (ad_double_plus_un a1)).
+    intro. rewrite (ad_double_bit_0 a0) in H7. rewrite (ad_double_plus_un_bit_0 a1) in H7.
+    discriminate H7.
+    rewrite (H1 (ad_double a0) (ad_double_plus_un a1) H6). reflexivity.
+    intro H4. rewrite H4. reflexivity.
+    trivial.
+    intro H2. elim H2. intros a0 H3. rewrite H3. rewrite (ad_double_plus_un_bit_0 a0).
+    rewrite <-
+     (H0 (fun a1:ad => pf (ad_double_plus_un a1))
+        (ad_comp_double_plus_un_inj pf H1) a0).
+    rewrite ad_double_plus_un_div_2.
+    elim
+     (option_sum A
+        (alist_semantics
+           (MapFold1 alist anil aapp
+              (fun (a1:ad) (y:A) => acons (a1, y) anil)
+              (fun a1:ad => pf (ad_double a1)) m0)
+           (pf (ad_double_plus_un a0)))).
+    intro H4. elim H4. intros y H5.
+    elim
+     (alist_of_Map_semantics_1_1 m0 (fun a1:ad => pf (ad_double a1))
+        (pf (ad_double_plus_un a0)) y H5).
+    intros a1 H6. cut (ad_bit_0 (ad_double_plus_un a0) = ad_bit_0 (ad_double a1)).
+    intro H7. rewrite (ad_double_plus_un_bit_0 a0) in H7. rewrite (ad_double_bit_0 a1) in H7.
+    discriminate H7.
+    rewrite (H1 (ad_double_plus_un a0) (ad_double a1) H6). reflexivity.
+    intro H4. rewrite H4. reflexivity.
+  Qed.
+
+  Lemma alist_of_Map_semantics :
+   forall m:Map A, eqm A (MapGet A m) (alist_semantics (alist_of_Map m)).
+  Proof.
+    unfold eqm in |- *. intros. exact
+  (alist_of_Map_semantics_1 m (fun a0:ad => a0)
+     (fun (a0 a1:ad) (p:a0 = a1) => p) a).
+  Qed.
+
+  Fixpoint Map_of_alist (l:alist) : Map A :=
+    match l with
+    | nil => M0 A
+    | (a, y) :: l' => MapPut A (Map_of_alist l') a y
+    end.
+
+  Lemma Map_of_alist_semantics :
+   forall l:alist, eqm A (alist_semantics l) (MapGet A (Map_of_alist l)).
+  Proof.
+    unfold eqm in |- *. simple induction l. trivial.
+    intros r l0 H a. elim r. intros a0 y0. simpl in |- *. elim (sumbool_of_bool (ad_eq a0 a)).
+    intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H0).
+    rewrite (MapPut_semantics A (Map_of_alist l0) a y0 a). rewrite (ad_eq_correct a).
+    reflexivity.
+    intro H0. rewrite H0. rewrite (MapPut_semantics A (Map_of_alist l0) a0 y0 a).
+    rewrite H0. apply H.
+  Qed.
+
+  Lemma Map_of_alist_of_Map :
+   forall m:Map A, eqmap A (Map_of_alist (alist_of_Map m)) m.
+  Proof.
+    unfold eqmap in |- *. intro. apply eqm_trans with (f' := alist_semantics (alist_of_Map m)).
+    apply eqm_sym. apply Map_of_alist_semantics.
+    apply eqm_sym. apply alist_of_Map_semantics.
+  Qed.
+
+  Lemma alist_of_Map_of_alist :
+   forall l:alist,
+     eqm A (alist_semantics (alist_of_Map (Map_of_alist l)))
+       (alist_semantics l).
+  Proof.
+    intro. apply eqm_trans with (f' := MapGet A (Map_of_alist l)).
+    apply eqm_sym. apply alist_of_Map_semantics.
+    apply eqm_sym. apply Map_of_alist_semantics.
+  Qed.
+
+  Lemma fold_right_aapp :
+   forall (M:Set) (neutral:M) (op:M -> M -> M),
+     (forall a b c:M, op (op a b) c = op a (op b c)) ->
+     (forall a:M, op neutral a = a) ->
+     forall (f:ad -> A -> M) (l l':alist),
+       fold_right (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m)
+         neutral (aapp l l') =
+       op
+         (fold_right
+            (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) neutral
+            l)
+         (fold_right
+            (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) neutral
+            l').
+  Proof.
+    simple induction l. simpl in |- *. intro. rewrite H0. reflexivity.
+    intros r l0 H1 l'. elim r. intros a y. simpl in |- *. rewrite H. rewrite (H1 l'). reflexivity.
+  Qed.
+
+  Lemma MapFold_as_fold_1 :
+   forall (M:Set) (neutral:M) (op:M -> M -> M),
+     (forall a b c:M, op (op a b) c = op a (op b c)) ->
+     (forall a:M, op neutral a = a) ->
+     (forall a:M, op a neutral = a) ->
+     forall (f:ad -> A -> M) (m:Map A) (pf:ad -> ad),
+       MapFold1 M neutral op f pf m =
+       fold_right (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m)
+         neutral
+         (MapFold1 alist anil aapp (fun (a:ad) (y:A) => acons (a, y) anil) pf
+            m).
+  Proof.
+    simple induction m. trivial.
+    intros. simpl in |- *. rewrite H1. reflexivity.
+    intros. simpl in |- *. rewrite (fold_right_aapp M neutral op H H0 f).
+    rewrite (H2 (fun a0:ad => pf (ad_double a0))). rewrite (H3 (fun a0:ad => pf (ad_double_plus_un a0))).
+    reflexivity.
+  Qed.
+
+  Lemma MapFold_as_fold :
+   forall (M:Set) (neutral:M) (op:M -> M -> M),
+     (forall a b c:M, op (op a b) c = op a (op b c)) ->
+     (forall a:M, op neutral a = a) ->
+     (forall a:M, op a neutral = a) ->
+     forall (f:ad -> A -> M) (m:Map A),
+       MapFold M neutral op f m =
+       fold_right (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m)
+         neutral (alist_of_Map m).
+  Proof.
+    intros. exact (MapFold_as_fold_1 M neutral op H H0 H1 f m (fun a0:ad => a0)).
+  Qed.
+
+  Lemma alist_MapMerge_semantics :
+   forall m m':Map A,
+     eqm A (alist_semantics (aapp (alist_of_Map m') (alist_of_Map m)))
+       (alist_semantics (alist_of_Map (MapMerge A m m'))).
+  Proof.
+    unfold eqm in |- *. intros. rewrite alist_semantics_app. rewrite <- (alist_of_Map_semantics m a).
+    rewrite <- (alist_of_Map_semantics m' a).
+    rewrite <- (alist_of_Map_semantics (MapMerge A m m') a).
+    rewrite (MapMerge_semantics A m m' a). reflexivity.
+  Qed.
+
+  Lemma alist_MapMerge_semantics_disjoint :
+   forall m m':Map A,
+     eqmap A (MapDomRestrTo A A m m') (M0 A) ->
+     eqm A (alist_semantics (aapp (alist_of_Map m) (alist_of_Map m')))
+       (alist_semantics (alist_of_Map (MapMerge A m m'))).
+  Proof.
+    unfold eqm in |- *. intros. rewrite alist_semantics_app. rewrite <- (alist_of_Map_semantics m a).
+    rewrite <- (alist_of_Map_semantics m' a).
+    rewrite <- (alist_of_Map_semantics (MapMerge A m m') a). rewrite (MapMerge_semantics A m m' a).
+    elim (option_sum _ (MapGet A m a)). intro H0. elim H0. intros y H1. rewrite H1.
+    elim (option_sum _ (MapGet A m' a)). intro H2. elim H2. intros y' H3.
+    cut (MapGet A (MapDomRestrTo A A m m') a = NONE A).
+    rewrite (MapDomRestrTo_semantics A A m m' a). rewrite H3. rewrite H1. intro. discriminate H4.
+    exact (H a).
+    intro H2. rewrite H2. reflexivity.
+    intro H0. rewrite H0. case (MapGet A m' a); trivial.
+  Qed.
+
+  Lemma alist_semantics_disjoint_comm :
+   forall l l':alist,
+     eqmap A (MapDomRestrTo A A (Map_of_alist l) (Map_of_alist l')) (M0 A) ->
+     eqm A (alist_semantics (aapp l l')) (alist_semantics (aapp l' l)).
+  Proof.
+    unfold eqm in |- *. intros. rewrite (alist_semantics_app l l' a). rewrite (alist_semantics_app l' l a).
+    rewrite <- (alist_of_Map_of_alist l a). rewrite <- (alist_of_Map_of_alist l' a).
+    rewrite <-
+     (alist_semantics_app (alist_of_Map (Map_of_alist l))
+        (alist_of_Map (Map_of_alist l')) a).
+    rewrite <-
+     (alist_semantics_app (alist_of_Map (Map_of_alist l'))
+        (alist_of_Map (Map_of_alist l)) a).
+    rewrite (alist_MapMerge_semantics (Map_of_alist l) (Map_of_alist l') a).
+    rewrite
+     (alist_MapMerge_semantics_disjoint (Map_of_alist l) (
+        Map_of_alist l') H a).
+    reflexivity.
+  Qed.
+
+End MapIter.
diff --git a/theories/IntMap/Maplists.v b/theories/IntMap/Maplists.v
new file mode 100644
index 00000000..645c3407
--- /dev/null
+++ b/theories/IntMap/Maplists.v
@@ -0,0 +1,437 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Maplists.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Addr.
+Require Import Addec.
+Require Import Map.
+Require Import Fset.
+Require Import Mapaxioms.
+Require Import Mapsubset.
+Require Import Mapcard.
+Require Import Mapcanon.
+Require Import Mapc.
+Require Import Bool.
+Require Import Sumbool.
+Require Import List.
+Require Import Arith.
+Require Import Mapiter.
+Require Import Mapfold.
+
+Section MapLists.
+
+  Fixpoint ad_in_list (a:ad) (l:list ad) {struct l} : bool :=
+    match l with
+    | nil => false
+    | a' :: l' => orb (ad_eq a a') (ad_in_list a l')
+    end.
+
+  Fixpoint ad_list_stutters (l:list ad) : bool :=
+    match l with
+    | nil => false
+    | a :: l' => orb (ad_in_list a l') (ad_list_stutters l')
+    end.
+
+  Lemma ad_in_list_forms_circuit :
+   forall (x:ad) (l:list ad),
+     ad_in_list x l = true ->
+     {l1 : list ad &  {l2 : list ad | l = l1 ++ x :: l2}}.
+  Proof.
+    simple induction l. intro. discriminate H.
+    intros. elim (sumbool_of_bool (ad_eq x a)). intro H1. simpl in H0. split with (nil (A:=ad)).
+    split with l0. rewrite (ad_eq_complete _ _ H1). reflexivity.
+    intro H2. simpl in H0. rewrite H2 in H0. simpl in H0. elim (H H0). intros l'1 H3.
+    split with (a :: l'1). elim H3. intros l2 H4. split with l2. rewrite H4. reflexivity.
+  Qed.
+
+  Lemma ad_list_stutters_has_circuit :
+   forall l:list ad,
+     ad_list_stutters l = true ->
+     {x : ad & 
+     {l0 : list ad & 
+     {l1 : list ad &  {l2 : list ad | l = l0 ++ x :: l1 ++ x :: l2}}}}.
+  Proof.
+    simple induction l. intro. discriminate H.
+    intros. simpl in H0. elim (orb_true_elim _ _ H0). intro H1. split with a.
+    split with (nil (A:=ad)). simpl in |- *. elim (ad_in_list_forms_circuit a l0 H1). intros l1 H2.
+    split with l1. elim H2. intros l2 H3. split with l2. rewrite H3. reflexivity.
+    intro H1. elim (H H1). intros x H2. split with x. elim H2. intros l1 H3.
+    split with (a :: l1). elim H3. intros l2 H4. split with l2. elim H4. intros l3 H5.
+    split with l3. rewrite H5. reflexivity.
+  Qed.
+
+  Fixpoint Elems (l:list ad) : FSet :=
+    match l with
+    | nil => M0 unit
+    | a :: l' => MapPut _ (Elems l') a tt
+    end.
+
+  Lemma Elems_canon : forall l:list ad, mapcanon _ (Elems l).
+  Proof.
+    simple induction l. exact (M0_canon unit).
+    intros. simpl in |- *. apply MapPut_canon. assumption.
+  Qed.
+
+  Lemma Elems_app :
+   forall l l':list ad, Elems (l ++ l') = FSetUnion (Elems l) (Elems l').
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (MapPut_as_Merge_c unit (Elems l0)).
+    rewrite (MapPut_as_Merge_c unit (Elems (l0 ++ l'))).
+    change
+      (FSetUnion (Elems (l0 ++ l')) (M1 unit a tt) =
+       FSetUnion (FSetUnion (Elems l0) (M1 unit a tt)) (Elems l')) 
+     in |- *.
+    rewrite FSetUnion_comm_c. rewrite (FSetUnion_comm_c (Elems l0) (M1 unit a tt)).
+    rewrite FSetUnion_assoc_c. rewrite (H l'). reflexivity.
+    apply M1_canon.
+    apply Elems_canon.
+    apply Elems_canon.
+    apply Elems_canon.
+    apply M1_canon.
+    apply Elems_canon.
+    apply M1_canon.
+    apply Elems_canon.
+    apply Elems_canon.
+  Qed.
+
+  Lemma Elems_rev : forall l:list ad, Elems (rev l) = Elems l.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite Elems_app. simpl in |- *. rewrite (MapPut_as_Merge_c unit (Elems l0)).
+    rewrite H. reflexivity.
+    apply Elems_canon.
+  Qed.
+
+  Lemma ad_in_elems_in_list :
+   forall (l:list ad) (a:ad), in_FSet a (Elems l) = ad_in_list a l.
+  Proof.
+    simple induction l. trivial.
+    simpl in |- *. unfold in_FSet in |- *. intros. rewrite (in_dom_put _ (Elems l0) a tt a0).
+    rewrite (H a0). reflexivity.
+  Qed.
+
+  Lemma ad_list_not_stutters_card :
+   forall l:list ad,
+     ad_list_stutters l = false -> length l = MapCard _ (Elems l).
+  Proof.
+    simple induction l. trivial.
+    simpl in |- *. intros. rewrite MapCard_Put_2_conv. rewrite H. reflexivity.
+    elim (orb_false_elim _ _ H0). trivial.
+    elim (sumbool_of_bool (in_FSet a (Elems l0))). rewrite ad_in_elems_in_list.
+    intro H1. rewrite H1 in H0. discriminate H0.
+    exact (in_dom_none unit (Elems l0) a).
+  Qed.
+
+  Lemma ad_list_card : forall l:list ad, MapCard _ (Elems l) <= length l.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. apply le_trans with (m := S (MapCard _ (Elems l0))). apply MapCard_Put_ub.
+    apply le_n_S. assumption.
+  Qed.
+
+  Lemma ad_list_stutters_card :
+   forall l:list ad,
+     ad_list_stutters l = true -> MapCard _ (Elems l) < length l.
+  Proof.
+    simple induction l. intro. discriminate H.
+    intros. simpl in |- *. simpl in H0. elim (orb_true_elim _ _ H0). intro H1.
+    rewrite <- (ad_in_elems_in_list l0 a) in H1. elim (in_dom_some _ _ _ H1). intros y H2.
+    rewrite (MapCard_Put_1_conv _ _ _ _ tt H2). apply le_lt_trans with (m := length l0).
+    apply ad_list_card.
+    apply lt_n_Sn.
+    intro H1. apply le_lt_trans with (m := S (MapCard _ (Elems l0))). apply MapCard_Put_ub.
+    apply lt_n_S. apply H. assumption.
+  Qed.
+
+  Lemma ad_list_not_stutters_card_conv :
+   forall l:list ad,
+     length l = MapCard _ (Elems l) -> ad_list_stutters l = false.
+  Proof.
+    intros. elim (sumbool_of_bool (ad_list_stutters l)). intro H0.
+    cut (MapCard _ (Elems l) < length l). intro. rewrite H in H1. elim (lt_irrefl _ H1).
+    exact (ad_list_stutters_card _ H0).
+    trivial.
+  Qed.
+
+  Lemma ad_list_stutters_card_conv :
+   forall l:list ad,
+     MapCard _ (Elems l) < length l -> ad_list_stutters l = true.
+  Proof.
+    intros. elim (sumbool_of_bool (ad_list_stutters l)). trivial.
+    intro H0. rewrite (ad_list_not_stutters_card _ H0) in H. elim (lt_irrefl _ H).
+  Qed.
+
+  Lemma ad_in_list_l :
+   forall (l l':list ad) (a:ad),
+     ad_in_list a l = true -> ad_in_list a (l ++ l') = true.
+  Proof.
+    simple induction l. intros. discriminate H.
+    intros. simpl in |- *. simpl in H0. elim (orb_true_elim _ _ H0). intro H1. rewrite H1. reflexivity.
+    intro H1. rewrite (H l' a0 H1). apply orb_b_true.
+  Qed.
+
+  Lemma ad_list_stutters_app_l :
+   forall l l':list ad,
+     ad_list_stutters l = true -> ad_list_stutters (l ++ l') = true.
+  Proof.
+    simple induction l. intros. discriminate H.
+    intros. simpl in |- *. simpl in H0. elim (orb_true_elim _ _ H0). intro H1.
+    rewrite (ad_in_list_l l0 l' a H1). reflexivity.
+    intro H1. rewrite (H l' H1). apply orb_b_true.
+  Qed.
+
+  Lemma ad_in_list_r :
+   forall (l l':list ad) (a:ad),
+     ad_in_list a l' = true -> ad_in_list a (l ++ l') = true.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (H l' a0 H0). apply orb_b_true. 
+  Qed.
+
+  Lemma ad_list_stutters_app_r :
+   forall l l':list ad,
+     ad_list_stutters l' = true -> ad_list_stutters (l ++ l') = true.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (H l' H0). apply orb_b_true.
+  Qed.
+
+  Lemma ad_list_stutters_app_conv_l :
+   forall l l':list ad,
+     ad_list_stutters (l ++ l') = false -> ad_list_stutters l = false.
+  Proof.
+    intros. elim (sumbool_of_bool (ad_list_stutters l)). intro H0.
+    rewrite (ad_list_stutters_app_l l l' H0) in H. discriminate H.
+    trivial.
+  Qed.
+
+  Lemma ad_list_stutters_app_conv_r :
+   forall l l':list ad,
+     ad_list_stutters (l ++ l') = false -> ad_list_stutters l' = false.
+  Proof.
+    intros. elim (sumbool_of_bool (ad_list_stutters l')). intro H0.
+    rewrite (ad_list_stutters_app_r l l' H0) in H. discriminate H.
+    trivial.
+  Qed.
+
+  Lemma ad_in_list_app_1 :
+   forall (l l':list ad) (x:ad), ad_in_list x (l ++ x :: l') = true.
+  Proof.
+    simple induction l. simpl in |- *. intros. rewrite (ad_eq_correct x). reflexivity.
+    intros. simpl in |- *. rewrite (H l' x). apply orb_b_true.
+  Qed.
+
+  Lemma ad_in_list_app :
+   forall (l l':list ad) (x:ad),
+     ad_in_list x (l ++ l') = orb (ad_in_list x l) (ad_in_list x l').
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite <- orb_assoc. rewrite (H l' x). reflexivity.
+  Qed.
+
+  Lemma ad_in_list_rev :
+   forall (l:list ad) (x:ad), ad_in_list x (rev l) = ad_in_list x l.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite ad_in_list_app. rewrite (H x). simpl in |- *. rewrite orb_b_false.
+    apply orb_comm.
+  Qed.
+
+  Lemma ad_list_has_circuit_stutters :
+   forall (l0 l1 l2:list ad) (x:ad),
+     ad_list_stutters (l0 ++ x :: l1 ++ x :: l2) = true.
+  Proof.
+    simple induction l0. simpl in |- *. intros. rewrite (ad_in_list_app_1 l1 l2 x). reflexivity.
+    intros. simpl in |- *. rewrite (H l1 l2 x). apply orb_b_true.
+  Qed.
+
+  Lemma ad_list_stutters_prev_l :
+   forall (l l':list ad) (x:ad),
+     ad_in_list x l = true -> ad_list_stutters (l ++ x :: l') = true.
+  Proof.
+    intros. elim (ad_in_list_forms_circuit _ _ H). intros l0 H0. elim H0. intros l1 H1.
+    rewrite H1. rewrite app_ass. simpl in |- *. apply ad_list_has_circuit_stutters.
+  Qed.
+
+  Lemma ad_list_stutters_prev_conv_l :
+   forall (l l':list ad) (x:ad),
+     ad_list_stutters (l ++ x :: l') = false -> ad_in_list x l = false.
+  Proof.
+    intros. elim (sumbool_of_bool (ad_in_list x l)). intro H0.
+    rewrite (ad_list_stutters_prev_l l l' x H0) in H. discriminate H.
+    trivial.
+  Qed.
+
+  Lemma ad_list_stutters_prev_r :
+   forall (l l':list ad) (x:ad),
+     ad_in_list x l' = true -> ad_list_stutters (l ++ x :: l') = true.
+  Proof.
+    intros. elim (ad_in_list_forms_circuit _ _ H). intros l0 H0. elim H0. intros l1 H1.
+    rewrite H1. apply ad_list_has_circuit_stutters.
+  Qed.
+
+  Lemma ad_list_stutters_prev_conv_r :
+   forall (l l':list ad) (x:ad),
+     ad_list_stutters (l ++ x :: l') = false -> ad_in_list x l' = false.
+  Proof.
+    intros. elim (sumbool_of_bool (ad_in_list x l')). intro H0.
+    rewrite (ad_list_stutters_prev_r l l' x H0) in H. discriminate H.
+    trivial.
+  Qed.
+
+  Lemma ad_list_Elems :
+   forall l l':list ad,
+     MapCard _ (Elems l) = MapCard _ (Elems l') ->
+     length l = length l' -> ad_list_stutters l = ad_list_stutters l'.
+  Proof.
+    intros. elim (sumbool_of_bool (ad_list_stutters l)). intro H1. rewrite H1. apply sym_eq.
+    apply ad_list_stutters_card_conv. rewrite <- H. rewrite <- H0. apply ad_list_stutters_card.
+    assumption.
+    intro H1. rewrite H1. apply sym_eq. apply ad_list_not_stutters_card_conv. rewrite <- H.
+    rewrite <- H0. apply ad_list_not_stutters_card. assumption.
+  Qed.
+
+  Lemma ad_list_app_length :
+   forall l l':list ad, length (l ++ l') = length l + length l'.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (H l'). reflexivity.
+  Qed.
+
+  Lemma ad_list_stutters_permute :
+   forall l l':list ad,
+     ad_list_stutters (l ++ l') = ad_list_stutters (l' ++ l).
+  Proof.
+    intros. apply ad_list_Elems. rewrite Elems_app. rewrite Elems_app.
+    rewrite (FSetUnion_comm_c _ _ (Elems_canon l) (Elems_canon l')). reflexivity.
+    rewrite ad_list_app_length. rewrite ad_list_app_length. apply plus_comm.
+  Qed.
+
+  Lemma ad_list_rev_length : forall l:list ad, length (rev l) = length l.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite ad_list_app_length. simpl in |- *. rewrite H. rewrite <- plus_Snm_nSm.
+    rewrite <- plus_n_O. reflexivity.
+  Qed.
+
+  Lemma ad_list_stutters_rev :
+   forall l:list ad, ad_list_stutters (rev l) = ad_list_stutters l.
+  Proof.
+    intros. apply ad_list_Elems. rewrite Elems_rev. reflexivity.
+    apply ad_list_rev_length.
+  Qed.
+
+  Lemma ad_list_app_rev :
+   forall (l l':list ad) (x:ad), rev l ++ x :: l' = rev (x :: l) ++ l'.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (app_ass (rev l0) (a :: nil) (x :: l')). simpl in |- *.
+    rewrite (H (x :: l') a). simpl in |- *.
+    rewrite (app_ass (rev l0) (a :: nil) (x :: nil)). simpl in |- *.
+    rewrite app_ass. simpl in |- *. rewrite app_ass. reflexivity.
+  Qed.
+
+  Section ListOfDomDef.
+
+  Variable A : Set.
+
+  Definition ad_list_of_dom :=
+    MapFold A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil).
+
+  Lemma ad_in_list_of_dom_in_dom :
+   forall (m:Map A) (a:ad), ad_in_list a (ad_list_of_dom m) = in_dom A a m.
+  Proof.
+    unfold ad_list_of_dom in |- *. intros.
+    rewrite
+     (MapFold_distr_l A (list ad) nil (app (A:=ad)) bool false orb ad
+        (fun (a:ad) (l:list ad) => ad_in_list a l) (
+        fun c:ad => refl_equal _) ad_in_list_app
+        (fun (a0:ad) (_:A) => a0 :: nil) m a).
+    simpl in |- *. rewrite (MapFold_orb A (fun (a0:ad) (_:A) => orb (ad_eq a a0) false) m).
+    elim
+     (option_sum _
+        (MapSweep A (fun (a0:ad) (_:A) => orb (ad_eq a a0) false) m)). intro H. elim H.
+    intro r. elim r. intros a0 y H0. rewrite H0. unfold in_dom in |- *.
+    elim (orb_prop _ _ (MapSweep_semantics_1 _ _ _ _ _ H0)). intro H1.
+    rewrite (ad_eq_complete _ _ H1). rewrite (MapSweep_semantics_2 A _ _ _ _ H0). reflexivity.
+    intro H1. discriminate H1.
+    intro H. rewrite H. elim (sumbool_of_bool (in_dom A a m)). intro H0.
+    elim (in_dom_some A m a H0). intros y H1.
+    elim (orb_false_elim _ _ (MapSweep_semantics_3 _ _ _ H _ _ H1)). intro H2.
+    rewrite (ad_eq_correct a) in H2. discriminate H2.
+    exact (sym_eq (y:=_)).
+  Qed.
+
+  Lemma Elems_of_list_of_dom :
+   forall m:Map A, eqmap unit (Elems (ad_list_of_dom m)) (MapDom A m).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. elim (sumbool_of_bool (in_FSet a (Elems (ad_list_of_dom m)))).
+    intro H. elim (in_dom_some _ _ _ H). intro t. elim t. intro H0.
+    rewrite (ad_in_elems_in_list (ad_list_of_dom m) a) in H.
+    rewrite (ad_in_list_of_dom_in_dom m a) in H. rewrite (MapDom_Dom A m a) in H.
+    elim (in_dom_some _ _ _ H). intro t'. elim t'. intro H1. rewrite H1. assumption.
+    intro H. rewrite (in_dom_none _ _ _ H).
+    rewrite (ad_in_elems_in_list (ad_list_of_dom m) a) in H.
+    rewrite (ad_in_list_of_dom_in_dom m a) in H. rewrite (MapDom_Dom A m a) in H.
+    rewrite (in_dom_none _ _ _ H). reflexivity.
+  Qed.
+
+  Lemma Elems_of_list_of_dom_c :
+   forall m:Map A, mapcanon A m -> Elems (ad_list_of_dom m) = MapDom A m.
+  Proof.
+    intros. apply (mapcanon_unique unit). apply Elems_canon.
+    apply MapDom_canon. assumption.
+    apply Elems_of_list_of_dom.
+  Qed.
+
+  Lemma ad_list_of_dom_card_1 :
+   forall (m:Map A) (pf:ad -> ad),
+     length
+       (MapFold1 A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil)
+          pf m) = MapCard A m.
+  Proof.
+    simple induction m; try trivial. simpl in |- *. intros. rewrite ad_list_app_length.
+    rewrite (H (fun a0:ad => pf (ad_double a0))). rewrite (H0 (fun a0:ad => pf (ad_double_plus_un a0))).
+    reflexivity.
+  Qed.
+
+  Lemma ad_list_of_dom_card :
+   forall m:Map A, length (ad_list_of_dom m) = MapCard A m.
+  Proof.
+    exact (fun m:Map A => ad_list_of_dom_card_1 m (fun a:ad => a)).
+  Qed.
+
+  Lemma ad_list_of_dom_not_stutters :
+   forall m:Map A, ad_list_stutters (ad_list_of_dom m) = false.
+  Proof.
+    intro. apply ad_list_not_stutters_card_conv. rewrite ad_list_of_dom_card. apply sym_eq.
+    rewrite (MapCard_Dom A m). apply MapCard_ext. exact (Elems_of_list_of_dom m).
+  Qed.
+
+  End ListOfDomDef.
+
+  Lemma ad_list_of_dom_Dom_1 :
+   forall (A:Set) (m:Map A) (pf:ad -> ad),
+     MapFold1 A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil) pf
+       m =
+     MapFold1 unit (list ad) nil (app (A:=ad))
+       (fun (a:ad) (_:unit) => a :: nil) pf (MapDom A m).
+  Proof.
+    simple induction m; try trivial. simpl in |- *. intros. rewrite (H (fun a0:ad => pf (ad_double a0))).
+    rewrite (H0 (fun a0:ad => pf (ad_double_plus_un a0))). reflexivity.
+  Qed.
+
+  Lemma ad_list_of_dom_Dom :
+   forall (A:Set) (m:Map A),
+     ad_list_of_dom A m = ad_list_of_dom unit (MapDom A m).
+  Proof.
+    intros. exact (ad_list_of_dom_Dom_1 A m (fun a0:ad => a0)).
+  Qed.
+
+End MapLists.
\ No newline at end of file
diff --git a/theories/IntMap/Mapsubset.v b/theories/IntMap/Mapsubset.v
new file mode 100644
index 00000000..33b412e3
--- /dev/null
+++ b/theories/IntMap/Mapsubset.v
@@ -0,0 +1,606 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Mapsubset.v,v 1.4.2.1 2004/07/16 19:31:05 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Fset.
+Require Import Mapaxioms.
+Require Import Mapiter.
+
+Section MapSubsetDef.
+
+  Variables A B : Set.
+
+  Definition MapSubset (m:Map A) (m':Map B) :=
+    forall a:ad, in_dom A a m = true -> in_dom B a m' = true.
+
+  Definition MapSubset_1 (m:Map A) (m':Map B) :=
+    match MapSweep A (fun (a:ad) (_:A) => negb (in_dom B a m')) m with
+    | NONE => true
+    | _ => false
+    end.
+
+  Definition MapSubset_2 (m:Map A) (m':Map B) :=
+    eqmap A (MapDomRestrBy A B m m') (M0 A).
+
+  Lemma MapSubset_imp_1 :
+   forall (m:Map A) (m':Map B), MapSubset m m' -> MapSubset_1 m m' = true.
+  Proof.
+    unfold MapSubset, MapSubset_1 in |- *. intros.
+    elim
+     (option_sum _ (MapSweep A (fun (a:ad) (_:A) => negb (in_dom B a m')) m)).
+    intro H0. elim H0. intro r. elim r. intros a y H1. cut (negb (in_dom B a m') = true).
+    intro. cut (in_dom A a m = false). intro. unfold in_dom in H3.
+    rewrite (MapSweep_semantics_2 _ _ m a y H1) in H3. discriminate H3.
+    elim (sumbool_of_bool (in_dom A a m)). intro H3. rewrite (H a H3) in H2. discriminate H2.
+    trivial.
+    exact (MapSweep_semantics_1 _ _ m a y H1).
+    intro H0. rewrite H0. reflexivity.
+  Qed.
+
+  Lemma MapSubset_1_imp :
+   forall (m:Map A) (m':Map B), MapSubset_1 m m' = true -> MapSubset m m'.
+  Proof.
+    unfold MapSubset, MapSubset_1 in |- *. unfold in_dom at 2 in |- *. intros. elim (option_sum _ (MapGet A m a)).
+    intro H1. elim H1. intros y H2.
+    elim
+     (option_sum _ (MapSweep A (fun (a:ad) (_:A) => negb (in_dom B a m')) m)). intro H3.
+    elim H3. intro r. elim r. intros a' y' H4. rewrite H4 in H. discriminate H.
+    intro H3. cut (negb (in_dom B a m') = false). intro. rewrite (negb_intro (in_dom B a m')).
+    rewrite H4. reflexivity.
+    exact (MapSweep_semantics_3 _ _ m H3 a y H2).
+    intro H1. rewrite H1 in H0. discriminate H0.
+  Qed.
+
+  Lemma map_dom_empty_1 :
+   forall m:Map A, eqmap A m (M0 A) -> forall a:ad, in_dom _ a m = false.
+  Proof.
+    unfold eqmap, eqm, in_dom in |- *. intros. rewrite (H a). reflexivity.
+  Qed.
+
+  Lemma map_dom_empty_2 :
+   forall m:Map A, (forall a:ad, in_dom _ a m = false) -> eqmap A m (M0 A).
+  Proof.
+    unfold eqmap, eqm, in_dom in |- *. intros.
+    cut
+     (match MapGet A m a with
+      | NONE => false
+      | SOME _ => true
+      end = false).
+    case (MapGet A m a). trivial.
+    intros. discriminate H0.
+    exact (H a).
+  Qed.
+
+  Lemma MapSubset_imp_2 :
+   forall (m:Map A) (m':Map B), MapSubset m m' -> MapSubset_2 m m'.
+  Proof.
+    unfold MapSubset, MapSubset_2 in |- *. intros. apply map_dom_empty_2. intro. rewrite in_dom_restrby.
+    elim (sumbool_of_bool (in_dom A a m)). intro H0. rewrite H0. rewrite (H a H0). reflexivity.
+    intro H0. rewrite H0. reflexivity.
+  Qed.
+
+  Lemma MapSubset_2_imp :
+   forall (m:Map A) (m':Map B), MapSubset_2 m m' -> MapSubset m m'.
+  Proof.
+    unfold MapSubset, MapSubset_2 in |- *. intros. cut (in_dom _ a (MapDomRestrBy A B m m') = false).
+    rewrite in_dom_restrby. intro. elim (andb_false_elim _ _ H1). rewrite H0.
+    intro H2. discriminate H2.
+    intro H2. rewrite (negb_intro (in_dom B a m')). rewrite H2. reflexivity.
+    exact (map_dom_empty_1 _ H a).
+  Qed.
+
+End MapSubsetDef.
+
+Section MapSubsetOrder.
+
+  Variables A B C : Set.
+
+  Lemma MapSubset_refl : forall m:Map A, MapSubset A A m m.
+  Proof.
+      unfold MapSubset in |- *. trivial.
+  Qed.
+
+  Lemma MapSubset_antisym :
+   forall (m:Map A) (m':Map B),
+     MapSubset A B m m' ->
+     MapSubset B A m' m -> eqmap unit (MapDom A m) (MapDom B m').
+  Proof.
+    unfold MapSubset, eqmap, eqm in |- *. intros. elim (option_sum _ (MapGet _ (MapDom A m) a)).
+    intro H1. elim H1. intro t. elim t. intro H2. elim (option_sum _ (MapGet _ (MapDom B m') a)).
+    intro H3. elim H3. intro t'. elim t'. intro H4. rewrite H4. exact H2. 
+    intro H3. cut (in_dom B a m' = true). intro. rewrite (MapDom_Dom B m' a) in H4.
+    unfold in_FSet, in_dom in H4. rewrite H3 in H4. discriminate H4.
+    apply H. rewrite (MapDom_Dom A m a). unfold in_FSet, in_dom in |- *. rewrite H2. reflexivity.
+    intro H1. elim (option_sum _ (MapGet _ (MapDom B m') a)). intro H2. elim H2. intros t H3.
+    cut (in_dom A a m = true). intro. rewrite (MapDom_Dom A m a) in H4. unfold in_FSet, in_dom in H4.
+    rewrite H1 in H4. discriminate H4.
+    apply H0. rewrite (MapDom_Dom B m' a). unfold in_FSet, in_dom in |- *. rewrite H3. reflexivity.
+    intro H2. rewrite H2. exact H1.
+  Qed.
+
+  Lemma MapSubset_trans :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     MapSubset A B m m' -> MapSubset B C m' m'' -> MapSubset A C m m''.
+  Proof.
+    unfold MapSubset in |- *. intros. apply H0. apply H. assumption.
+  Qed.
+
+End MapSubsetOrder.
+
+Section FSubsetOrder.
+
+  Lemma FSubset_refl : forall s:FSet, MapSubset _ _ s s.
+  Proof.
+    exact (MapSubset_refl unit).
+  Qed.
+
+  Lemma FSubset_antisym :
+   forall s s':FSet,
+     MapSubset _ _ s s' -> MapSubset _ _ s' s -> eqmap unit s s'.
+  Proof.
+    intros. rewrite <- (FSet_Dom s). rewrite <- (FSet_Dom s').
+    exact (MapSubset_antisym _ _ s s' H H0).
+  Qed.
+
+  Lemma FSubset_trans :
+   forall s s' s'':FSet,
+     MapSubset _ _ s s' -> MapSubset _ _ s' s'' -> MapSubset _ _ s s''.
+  Proof.
+    exact (MapSubset_trans unit unit unit).
+  Qed.
+
+End FSubsetOrder.
+
+Section MapSubsetExtra.
+
+  Variables A B : Set.
+
+  Lemma MapSubset_Dom_1 :
+   forall (m:Map A) (m':Map B),
+     MapSubset A B m m' -> MapSubset unit unit (MapDom A m) (MapDom B m').
+  Proof.
+    unfold MapSubset in |- *. intros. elim (MapDom_semantics_2 _ m a H0). intros y H1.
+    cut (in_dom A a m = true -> in_dom B a m' = true). intro. unfold in_dom in H2.
+    rewrite H1 in H2. elim (option_sum _ (MapGet B m' a)). intro H3. elim H3.
+    intros y' H4. exact (MapDom_semantics_1 _ m' a y' H4).
+    intro H3. rewrite H3 in H2. cut (false = true). intro. discriminate H4.
+    apply H2. reflexivity.
+    exact (H a).
+  Qed.
+
+  Lemma MapSubset_Dom_2 :
+   forall (m:Map A) (m':Map B),
+     MapSubset unit unit (MapDom A m) (MapDom B m') -> MapSubset A B m m'.
+  Proof.
+    unfold MapSubset in |- *. intros. unfold in_dom in H0. elim (option_sum _ (MapGet A m a)).
+    intro H1. elim H1. intros y H2.
+    elim (MapDom_semantics_2 _ _ _ (H a (MapDom_semantics_1 _ _ _ _ H2))). intros y' H3.
+    unfold in_dom in |- *. rewrite H3. reflexivity.
+    intro H1. rewrite H1 in H0. discriminate H0.
+  Qed.
+
+  Lemma MapSubset_1_Dom :
+   forall (m:Map A) (m':Map B),
+     MapSubset_1 A B m m' = MapSubset_1 unit unit (MapDom A m) (MapDom B m').
+  Proof.
+    intros. elim (sumbool_of_bool (MapSubset_1 A B m m')). intro H. rewrite H.
+    apply sym_eq. apply MapSubset_imp_1. apply MapSubset_Dom_1. exact (MapSubset_1_imp _ _ _ _ H).
+    intro H. rewrite H. elim (sumbool_of_bool (MapSubset_1 unit unit (MapDom A m) (MapDom B m'))).
+    intro H0.
+    rewrite
+     (MapSubset_imp_1 _ _ _ _
+        (MapSubset_Dom_2 _ _ (MapSubset_1_imp _ _ _ _ H0)))
+      in H.
+    discriminate H.
+    intro. apply sym_eq. assumption.
+  Qed.
+
+  Lemma MapSubset_Put :
+   forall (m:Map A) (a:ad) (y:A), MapSubset A A m (MapPut A m a y).
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_put. rewrite H. apply orb_b_true.
+  Qed.
+
+  Lemma MapSubset_Put_mono :
+   forall (m:Map A) (m':Map B) (a:ad) (y:A) (y':B),
+     MapSubset A B m m' -> MapSubset A B (MapPut A m a y) (MapPut B m' a y').
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_put. rewrite (in_dom_put A m a y a0) in H0.
+    elim (orb_true_elim _ _ H0). intro H1. rewrite H1. reflexivity.
+    intro H1. rewrite (H _ H1). apply orb_b_true.
+  Qed.
+
+  Lemma MapSubset_Put_behind :
+   forall (m:Map A) (a:ad) (y:A), MapSubset A A m (MapPut_behind A m a y).
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_put_behind. rewrite H. apply orb_b_true.
+  Qed.
+
+  Lemma MapSubset_Put_behind_mono :
+   forall (m:Map A) (m':Map B) (a:ad) (y:A) (y':B),
+     MapSubset A B m m' ->
+     MapSubset A B (MapPut_behind A m a y) (MapPut_behind B m' a y').
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_put_behind.
+    rewrite (in_dom_put_behind A m a y a0) in H0.
+    elim (orb_true_elim _ _ H0). intro H1. rewrite H1. reflexivity.
+    intro H1. rewrite (H _ H1). apply orb_b_true.
+  Qed.
+
+  Lemma MapSubset_Remove :
+   forall (m:Map A) (a:ad), MapSubset A A (MapRemove A m a) m.
+  Proof.
+    unfold MapSubset in |- *. intros. unfold MapSubset in |- *. intros. rewrite (in_dom_remove _ m a a0) in H.
+    elim (andb_prop _ _ H). trivial.
+  Qed.
+
+  Lemma MapSubset_Remove_mono :
+   forall (m:Map A) (m':Map B) (a:ad),
+     MapSubset A B m m' -> MapSubset A B (MapRemove A m a) (MapRemove B m' a).
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_remove. rewrite (in_dom_remove A m a a0) in H0.
+    elim (andb_prop _ _ H0). intros. rewrite H1. rewrite (H _ H2). reflexivity.
+  Qed.
+
+  Lemma MapSubset_Merge_l :
+   forall m m':Map A, MapSubset A A m (MapMerge A m m').
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_merge. rewrite H. reflexivity.
+  Qed.
+
+  Lemma MapSubset_Merge_r :
+   forall m m':Map A, MapSubset A A m' (MapMerge A m m').
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_merge. rewrite H. apply orb_b_true.
+  Qed.
+
+  Lemma MapSubset_Merge_mono :
+   forall (m m':Map A) (m'' m''':Map B),
+     MapSubset A B m m'' ->
+     MapSubset A B m' m''' ->
+     MapSubset A B (MapMerge A m m') (MapMerge B m'' m''').
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_merge. rewrite (in_dom_merge A m m' a) in H1.
+    elim (orb_true_elim _ _ H1). intro H2. rewrite (H _ H2). reflexivity.
+    intro H2. rewrite (H0 _ H2). apply orb_b_true.
+  Qed.
+
+  Lemma MapSubset_DomRestrTo_l :
+   forall (m:Map A) (m':Map B), MapSubset A A (MapDomRestrTo A B m m') m.
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite (in_dom_restrto _ _ m m' a) in H. elim (andb_prop _ _ H).
+    trivial.
+  Qed.
+
+  Lemma MapSubset_DomRestrTo_r :
+   forall (m:Map A) (m':Map B), MapSubset A B (MapDomRestrTo A B m m') m'.
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite (in_dom_restrto _ _ m m' a) in H. elim (andb_prop _ _ H).
+    trivial.
+  Qed.
+
+  Lemma MapSubset_ext :
+   forall (m0 m1:Map A) (m2 m3:Map B),
+     eqmap A m0 m1 ->
+     eqmap B m2 m3 -> MapSubset A B m0 m2 -> MapSubset A B m1 m3.
+  Proof.
+    intros. apply MapSubset_2_imp. unfold MapSubset_2 in |- *.
+    apply eqmap_trans with (m' := MapDomRestrBy A B m0 m2). apply MapDomRestrBy_ext. apply eqmap_sym.
+    assumption.
+    apply eqmap_sym. assumption.
+    exact (MapSubset_imp_2 _ _ _ _ H1).
+  Qed.
+
+  Variables C D : Set.
+
+  Lemma MapSubset_DomRestrTo_mono :
+   forall (m:Map A) (m':Map B) (m'':Map C) (m''':Map D),
+     MapSubset _ _ m m'' ->
+     MapSubset _ _ m' m''' ->
+     MapSubset _ _ (MapDomRestrTo _ _ m m') (MapDomRestrTo _ _ m'' m''').
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_restrto. rewrite (in_dom_restrto A B m m' a) in H1.
+    elim (andb_prop _ _ H1). intros. rewrite (H _ H2). rewrite (H0 _ H3). reflexivity.
+  Qed.
+
+  Lemma MapSubset_DomRestrBy_l :
+   forall (m:Map A) (m':Map B), MapSubset A A (MapDomRestrBy A B m m') m.
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite (in_dom_restrby _ _ m m' a) in H. elim (andb_prop _ _ H).
+    trivial.
+  Qed.
+
+  Lemma MapSubset_DomRestrBy_mono :
+   forall (m:Map A) (m':Map B) (m'':Map C) (m''':Map D),
+     MapSubset _ _ m m'' ->
+     MapSubset _ _ m''' m' ->
+     MapSubset _ _ (MapDomRestrBy _ _ m m') (MapDomRestrBy _ _ m'' m''').
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_restrby. rewrite (in_dom_restrby A B m m' a) in H1.
+    elim (andb_prop _ _ H1). intros. rewrite (H _ H2). elim (sumbool_of_bool (in_dom D a m''')).
+    intro H4. rewrite (H0 _ H4) in H3. discriminate H3.
+    intro H4. rewrite H4. reflexivity.
+  Qed.
+  
+End MapSubsetExtra.
+
+Section MapDisjointDef.
+
+  Variables A B : Set.
+
+  Definition MapDisjoint (m:Map A) (m':Map B) :=
+    forall a:ad, in_dom A a m = true -> in_dom B a m' = true -> False.
+
+  Definition MapDisjoint_1 (m:Map A) (m':Map B) :=
+    match MapSweep A (fun (a:ad) (_:A) => in_dom B a m') m with
+    | NONE => true
+    | _ => false
+    end.
+
+  Definition MapDisjoint_2 (m:Map A) (m':Map B) :=
+    eqmap A (MapDomRestrTo A B m m') (M0 A).
+
+  Lemma MapDisjoint_imp_1 :
+   forall (m:Map A) (m':Map B), MapDisjoint m m' -> MapDisjoint_1 m m' = true.
+  Proof.
+    unfold MapDisjoint, MapDisjoint_1 in |- *. intros.
+    elim (option_sum _ (MapSweep A (fun (a:ad) (_:A) => in_dom B a m') m)). intro H0. elim H0.
+    intro r. elim r. intros a y H1. cut (in_dom A a m = true -> in_dom B a m' = true -> False).
+    intro. unfold in_dom at 1 in H2. rewrite (MapSweep_semantics_2 _ _ _ _ _ H1) in H2.
+    rewrite (MapSweep_semantics_1 _ _ _ _ _ H1) in H2. elim (H2 (refl_equal _) (refl_equal _)).
+    exact (H a).
+    intro H0. rewrite H0. reflexivity.
+  Qed.
+
+  Lemma MapDisjoint_1_imp :
+   forall (m:Map A) (m':Map B), MapDisjoint_1 m m' = true -> MapDisjoint m m'.
+  Proof.
+    unfold MapDisjoint, MapDisjoint_1 in |- *. intros.
+    elim (option_sum _ (MapSweep A (fun (a:ad) (_:A) => in_dom B a m') m)). intro H2. elim H2.
+    intro r. elim r. intros a' y' H3. rewrite H3 in H. discriminate H.
+    intro H2. unfold in_dom in H0. elim (option_sum _ (MapGet A m a)). intro H3. elim H3.
+    intros y H4. rewrite (MapSweep_semantics_3 _ _ _ H2 a y H4) in H1. discriminate H1.
+    intro H3. rewrite H3 in H0. discriminate H0.
+  Qed.
+
+  Lemma MapDisjoint_imp_2 :
+   forall (m:Map A) (m':Map B), MapDisjoint m m' -> MapDisjoint_2 m m'.
+  Proof.
+    unfold MapDisjoint, MapDisjoint_2 in |- *. unfold eqmap, eqm in |- *. intros.
+    rewrite (MapDomRestrTo_semantics A B m m' a).
+    cut (in_dom A a m = true -> in_dom B a m' = true -> False). intro.
+    elim (option_sum _ (MapGet A m a)). intro H1. elim H1. intros y H2. unfold in_dom at 1 in H0.
+    elim (option_sum _ (MapGet B m' a)). intro H3. elim H3. intros y' H4. unfold in_dom at 1 in H0.
+    rewrite H4 in H0. rewrite H2 in H0. elim (H0 (refl_equal _) (refl_equal _)).
+    intro H3. rewrite H3. reflexivity.
+    intro H1. rewrite H1. case (MapGet B m' a); reflexivity.
+    exact (H a).
+  Qed.
+
+  Lemma MapDisjoint_2_imp :
+   forall (m:Map A) (m':Map B), MapDisjoint_2 m m' -> MapDisjoint m m'.
+  Proof.
+    unfold MapDisjoint, MapDisjoint_2 in |- *. unfold eqmap, eqm in |- *. intros. elim (in_dom_some _ _ _ H0).
+    intros y H2. elim (in_dom_some _ _ _ H1). intros y' H3.
+    cut (MapGet A (MapDomRestrTo A B m m') a = NONE A). intro.
+    rewrite (MapDomRestrTo_semantics _ _ m m' a) in H4. rewrite H3 in H4. rewrite H2 in H4.
+    discriminate H4.
+    exact (H a).
+  Qed.
+
+  Lemma Map_M0_disjoint : forall m:Map B, MapDisjoint (M0 A) m.
+  Proof.
+    unfold MapDisjoint, in_dom in |- *. intros. discriminate H.
+  Qed.
+
+  Lemma Map_disjoint_M0 : forall m:Map A, MapDisjoint m (M0 B).
+  Proof.
+    unfold MapDisjoint, in_dom in |- *. intros. discriminate H0.
+  Qed.
+
+End MapDisjointDef.
+
+Section MapDisjointExtra.
+
+  Variables A B : Set.
+
+  Lemma MapDisjoint_ext :
+   forall (m0 m1:Map A) (m2 m3:Map B),
+     eqmap A m0 m1 ->
+     eqmap B m2 m3 -> MapDisjoint A B m0 m2 -> MapDisjoint A B m1 m3.
+  Proof.
+    intros. apply MapDisjoint_2_imp. unfold MapDisjoint_2 in |- *.
+    apply eqmap_trans with (m' := MapDomRestrTo A B m0 m2). apply eqmap_sym. apply MapDomRestrTo_ext.
+    assumption.
+    assumption.
+    exact (MapDisjoint_imp_2 _ _ _ _ H1).
+  Qed.
+
+  Lemma MapMerge_disjoint :
+   forall m m':Map A,
+     MapDisjoint A A m m' ->
+     forall a:ad,
+       in_dom A a (MapMerge A m m') =
+       orb (andb (in_dom A a m) (negb (in_dom A a m')))
+         (andb (in_dom A a m') (negb (in_dom A a m))).
+  Proof.
+    unfold MapDisjoint in |- *. intros. rewrite in_dom_merge. elim (sumbool_of_bool (in_dom A a m)).
+    intro H0. rewrite H0. elim (sumbool_of_bool (in_dom A a m')). intro H1. elim (H a H0 H1).
+    intro H1. rewrite H1. reflexivity.
+    intro H0. rewrite H0. simpl in |- *. rewrite andb_b_true. reflexivity.
+  Qed.
+
+  Lemma MapDisjoint_M2_l :
+   forall (m0 m1:Map A) (m2 m3:Map B),
+     MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3) -> MapDisjoint A B m0 m2.
+  Proof.
+    unfold MapDisjoint, in_dom in |- *. intros. elim (option_sum _ (MapGet A m0 a)). intro H2.
+    elim H2. intros y H3. elim (option_sum _ (MapGet B m2 a)). intro H4. elim H4.
+    intros y' H5. apply (H (ad_double a)).
+    rewrite (MapGet_M2_bit_0_0 _ (ad_double a) (ad_double_bit_0 a) m0 m1).
+    rewrite (ad_double_div_2 a). rewrite H3. reflexivity.
+    rewrite (MapGet_M2_bit_0_0 _ (ad_double a) (ad_double_bit_0 a) m2 m3).
+    rewrite (ad_double_div_2 a). rewrite H5. reflexivity.
+    intro H4. rewrite H4 in H1. discriminate H1.
+    intro H2. rewrite H2 in H0. discriminate H0.
+  Qed.
+
+  Lemma MapDisjoint_M2_r :
+   forall (m0 m1:Map A) (m2 m3:Map B),
+     MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3) -> MapDisjoint A B m1 m3.
+  Proof.
+    unfold MapDisjoint, in_dom in |- *. intros. elim (option_sum _ (MapGet A m1 a)). intro H2.
+    elim H2. intros y H3. elim (option_sum _ (MapGet B m3 a)). intro H4. elim H4.
+    intros y' H5. apply (H (ad_double_plus_un a)).
+    rewrite
+     (MapGet_M2_bit_0_1 _ (ad_double_plus_un a) (ad_double_plus_un_bit_0 a)
+        m0 m1).
+    rewrite (ad_double_plus_un_div_2 a). rewrite H3. reflexivity.
+    rewrite
+     (MapGet_M2_bit_0_1 _ (ad_double_plus_un a) (ad_double_plus_un_bit_0 a)
+        m2 m3).
+    rewrite (ad_double_plus_un_div_2 a). rewrite H5. reflexivity.
+    intro H4. rewrite H4 in H1. discriminate H1.
+    intro H2. rewrite H2 in H0. discriminate H0.
+  Qed.
+
+  Lemma MapDisjoint_M2 :
+   forall (m0 m1:Map A) (m2 m3:Map B),
+     MapDisjoint A B m0 m2 ->
+     MapDisjoint A B m1 m3 -> MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3).
+  Proof.
+    unfold MapDisjoint, in_dom in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H3.
+    rewrite (MapGet_M2_bit_0_1 A a H3 m0 m1) in H1.
+    rewrite (MapGet_M2_bit_0_1 B a H3 m2 m3) in H2. exact (H0 (ad_div_2 a) H1 H2).
+    intro H3. rewrite (MapGet_M2_bit_0_0 A a H3 m0 m1) in H1.
+    rewrite (MapGet_M2_bit_0_0 B a H3 m2 m3) in H2. exact (H (ad_div_2 a) H1 H2).
+  Qed.
+
+  Lemma MapDisjoint_M1_l :
+   forall (m:Map A) (a:ad) (y:B),
+     MapDisjoint B A (M1 B a y) m -> in_dom A a m = false.
+  Proof.
+    unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (in_dom A a m)). intro H0.
+    elim (H a (in_dom_M1_1 B a y) H0).
+    trivial.
+  Qed.
+
+  Lemma MapDisjoint_M1_r :
+   forall (m:Map A) (a:ad) (y:B),
+     MapDisjoint A B m (M1 B a y) -> in_dom A a m = false.
+  Proof.
+    unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (in_dom A a m)). intro H0.
+    elim (H a H0 (in_dom_M1_1 B a y)).
+    trivial.
+  Qed.
+
+  Lemma MapDisjoint_M1_conv_l :
+   forall (m:Map A) (a:ad) (y:B),
+     in_dom A a m = false -> MapDisjoint B A (M1 B a y) m.
+  Proof.
+    unfold MapDisjoint in |- *. intros. rewrite (in_dom_M1_2 B a a0 y H0) in H. rewrite H1 in H.
+    discriminate H.
+  Qed.
+
+  Lemma MapDisjoint_M1_conv_r :
+   forall (m:Map A) (a:ad) (y:B),
+     in_dom A a m = false -> MapDisjoint A B m (M1 B a y).
+  Proof.
+    unfold MapDisjoint in |- *. intros. rewrite (in_dom_M1_2 B a a0 y H1) in H. rewrite H0 in H.
+    discriminate H.
+  Qed.
+ 
+  Lemma MapDisjoint_sym :
+   forall (m:Map A) (m':Map B), MapDisjoint A B m m' -> MapDisjoint B A m' m.
+  Proof.
+    unfold MapDisjoint in |- *. intros. exact (H _ H1 H0).
+  Qed.
+
+  Lemma MapDisjoint_empty :
+   forall m:Map A, MapDisjoint A A m m -> eqmap A m (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite <- (MapDomRestrTo_idempotent A m a).
+    exact (MapDisjoint_imp_2 A A m m H a).
+  Qed.
+
+  Lemma MapDelta_disjoint :
+   forall m m':Map A,
+     MapDisjoint A A m m' -> eqmap A (MapDelta A m m') (MapMerge A m m').
+  Proof.
+    intros.
+    apply eqmap_trans with
+     (m' := MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m')).
+    apply MapDelta_as_DomRestrBy.
+    apply eqmap_trans with (m' := MapDomRestrBy A A (MapMerge A m m') (M0 A)).
+    apply MapDomRestrBy_ext. apply eqmap_refl.
+    exact (MapDisjoint_imp_2 A A m m' H).
+    apply MapDomRestrBy_m_empty.
+  Qed.
+
+  Variable C : Set.
+
+  Lemma MapDomRestr_disjoint :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     MapDisjoint A B (MapDomRestrTo A C m m'') (MapDomRestrBy B C m' m'').
+  Proof.
+    unfold MapDisjoint in |- *. intros m m' m'' a. rewrite in_dom_restrto. rewrite in_dom_restrby.
+    intros. elim (andb_prop _ _ H). elim (andb_prop _ _ H0). intros. rewrite H4 in H2.
+    discriminate H2.
+  Qed.
+
+  Lemma MapDelta_RestrTo_disjoint :
+   forall m m':Map A,
+     MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m m').
+  Proof.
+    unfold MapDisjoint in |- *. intros m m' a. rewrite in_dom_delta. rewrite in_dom_restrto.
+    intros. elim (andb_prop _ _ H0). intros. rewrite H1 in H. rewrite H2 in H. discriminate H.
+  Qed.
+
+  Lemma MapDelta_RestrTo_disjoint_2 :
+   forall m m':Map A,
+     MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m' m).
+  Proof.
+    unfold MapDisjoint in |- *. intros m m' a. rewrite in_dom_delta. rewrite in_dom_restrto.
+    intros. elim (andb_prop _ _ H0). intros. rewrite H1 in H. rewrite H2 in H. discriminate H.
+  Qed.
+
+  Variable D : Set.
+
+  Lemma MapSubset_Disjoint :
+   forall (m:Map A) (m':Map B) (m'':Map C) (m''':Map D),
+     MapSubset _ _ m m' ->
+     MapSubset _ _ m'' m''' ->
+     MapDisjoint _ _ m' m''' -> MapDisjoint _ _ m m''.
+  Proof.
+    unfold MapSubset, MapDisjoint in |- *. intros. exact (H1 _ (H _ H2) (H0 _ H3)).
+  Qed.
+
+  Lemma MapSubset_Disjoint_l :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     MapSubset _ _ m m' -> MapDisjoint _ _ m' m'' -> MapDisjoint _ _ m m''.
+  Proof.
+    unfold MapSubset, MapDisjoint in |- *. intros. exact (H0 _ (H _ H1) H2).
+  Qed.
+
+  Lemma MapSubset_Disjoint_r :
+   forall (m:Map A) (m'':Map C) (m''':Map D),
+     MapSubset _ _ m'' m''' ->
+     MapDisjoint _ _ m m''' -> MapDisjoint _ _ m m''.
+  Proof.
+    unfold MapSubset, MapDisjoint in |- *. intros. exact (H0 _ H1 (H _ H2)).
+  Qed.
+
+End MapDisjointExtra.
\ No newline at end of file
diff --git a/theories/IntMap/intro.tex b/theories/IntMap/intro.tex
new file mode 100644
index 00000000..9ad93050
--- /dev/null
+++ b/theories/IntMap/intro.tex
@@ -0,0 +1,6 @@
+\section{Maps indexed by binary integers : IntMap}\label{IntMap}
+
+This library contains a data structure for finite sets implemented by
+an efficient structure of map (trees indexed by binary integers).
+It was initially developed by Jean Goubault.
+
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
new file mode 100755
index 00000000..c3f65d67
--- /dev/null
+++ b/theories/Lists/List.v
@@ -0,0 +1,655 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: List.v,v 1.9.2.1 2004/07/16 19:31:05 herbelin Exp $ i*)
+
+Require Import Le.
+
+
+Section Lists.
+
+Variable A : Set.
+
+Set Implicit Arguments.
+
+Inductive list : Set :=
+  | nil : list
+  | cons : A -> list -> list.
+
+Infix "::" := cons (at level 60, right associativity) : list_scope.
+
+Open Scope list_scope.
+
+(*************************)
+(** Discrimination       *)
+(*************************)
+
+Lemma nil_cons : forall (a:A) (m:list), nil <> a :: m.
+Proof. 
+  intros; discriminate.
+Qed.
+
+(*************************)
+(** Concatenation        *)
+(*************************)
+
+Fixpoint app (l m:list) {struct l} : list :=
+  match l with
+  | nil => m
+  | a :: l1 => a :: app l1 m
+  end.
+
+Infix "++" := app (right associativity, at level 60) : list_scope.
+
+Lemma app_nil_end : forall l:list, l = l ++ nil.
+Proof. 
+	induction l; simpl in |- *; auto.
+        rewrite <- IHl; auto.
+Qed.
+Hint Resolve app_nil_end.
+
+Ltac now_show c := change c in |- *.
+
+Lemma app_ass : forall l m n:list, (l ++ m) ++ n = l ++ m ++ n.
+Proof. 
+	intros. induction l; simpl in |- *; auto.
+        now_show (a :: (l ++ m) ++ n = a :: l ++ m ++ n).
+	rewrite <- IHl; auto.
+Qed.
+Hint Resolve app_ass.
+
+Lemma ass_app : forall l m n:list, l ++ m ++ n = (l ++ m) ++ n.
+Proof. 
+	auto.
+Qed.
+Hint Resolve ass_app.
+
+Lemma app_comm_cons : forall (x y:list) (a:A), a :: x ++ y = (a :: x) ++ y.
+Proof.
+ auto.
+Qed.
+
+Lemma app_eq_nil : forall x y:list, x ++ y = nil -> x = nil /\ y = nil.
+Proof.
+  destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ];
+   simpl in |- *; auto.
+  intros H; discriminate H.
+  intros; discriminate H.
+Qed.
+
+Lemma app_cons_not_nil : forall (x y:list) (a:A), nil <> x ++ a :: y.
+Proof.
+unfold not in |- *.
+  destruct x as [| a l]; simpl in |- *; intros.
+  discriminate H.
+  discriminate H.
+Qed.
+
+Lemma app_eq_unit :
+ forall (x y:list) (a:A),
+   x ++ y = a :: nil -> x = nil /\ y = a :: nil \/ x = a :: nil /\ y = nil.
+
+Proof.
+  destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ];
+   simpl in |- *.
+  intros a H; discriminate H.
+  left; split; auto.
+  right; split; auto.
+  generalize H.
+  generalize (app_nil_end l); intros E.
+  rewrite <- E; auto.
+  intros.
+  injection H.
+  intro.
+  cut (nil = l ++ a0 :: l0); auto.
+  intro.
+  generalize (app_cons_not_nil _ _ _ H1); intro.
+  elim H2.
+Qed.
+
+Lemma app_inj_tail :
+ forall (x y:list) (a b:A), x ++ a :: nil = y ++ b :: nil -> x = y /\ a = b.
+Proof.
+  induction x as [| x l IHl];
+   [ destruct y as [| a l] | destruct y as [| a l0] ]; 
+   simpl in |- *; auto.
+  intros a b H.
+  injection H.
+  auto.
+  intros a0 b H.
+  injection H; intros.
+  generalize (app_cons_not_nil _ _ _ H0); destruct 1.
+  intros a b H.
+  injection H; intros.
+  cut (nil = l ++ a :: nil); auto.
+  intro.
+  generalize (app_cons_not_nil _ _ _ H2); destruct 1.
+  intros a0 b H.
+  injection H; intros.
+  destruct (IHl l0 a0 b H0). 
+  split; auto.
+  rewrite <- H1; rewrite <- H2; reflexivity.
+Qed.
+
+(*************************)
+(** Head and tail        *)
+(*************************)
+
+Definition head (l:list) :=
+  match l with
+  | nil => error
+  | x :: _ => value x
+  end.
+
+Definition tail (l:list) : list :=
+  match l with
+  | nil => nil
+  | a :: m => m
+  end.
+
+(****************************************)
+(** Length of lists                     *)
+(****************************************)
+
+Fixpoint length (l:list) : nat :=
+  match l with
+  | nil => 0
+  | _ :: m => S (length m)
+  end.
+
+(******************************)
+(** Length order of lists     *)
+(******************************)
+
+Section length_order.
+Definition lel (l m:list) := length l <= length m.
+
+Variables a b : A.
+Variables l m n : list.
+
+Lemma lel_refl : lel l l.
+Proof. 
+	unfold lel in |- *; auto with arith.
+Qed.
+
+Lemma lel_trans : lel l m -> lel m n -> lel l n.
+Proof. 
+	unfold lel in |- *; intros.
+        now_show (length l <= length n).
+        apply le_trans with (length m); auto with arith.
+Qed.
+
+Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m).
+Proof. 
+	unfold lel in |- *; simpl in |- *; auto with arith.
+Qed.
+
+Lemma lel_cons : lel l m -> lel l (b :: m).
+Proof. 
+	unfold lel in |- *; simpl in |- *; auto with arith.
+Qed.
+
+Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m.
+Proof. 
+	unfold lel in |- *; simpl in |- *; auto with arith.
+Qed.
+
+Lemma lel_nil : forall l':list, lel l' nil -> nil = l'.
+Proof. 
+	intro l'; elim l'; auto with arith.
+	intros a' y H H0.
+        now_show (nil = a' :: y).
+	absurd (S (length y) <= 0); auto with arith.
+Qed.
+End length_order.
+
+Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons.
+
+(*********************************)
+(** The [In] predicate           *)
+(*********************************)
+
+Fixpoint In (a:A) (l:list) {struct l} : Prop :=
+  match l with
+  | nil => False
+  | b :: m => b = a \/ In a m
+  end.
+
+Lemma in_eq : forall (a:A) (l:list), In a (a :: l).
+Proof. 
+	simpl in |- *; auto.
+Qed.
+Hint Resolve in_eq.
+
+Lemma in_cons : forall (a b:A) (l:list), In b l -> In b (a :: l).
+Proof. 
+	simpl in |- *; auto.
+Qed.
+Hint Resolve in_cons.
+
+Lemma in_nil : forall a:A, ~ In a nil.
+Proof.
+  unfold not in |- *; intros a H; inversion_clear H.
+Qed.
+
+
+Lemma in_inv : forall (a b:A) (l:list), In b (a :: l) -> a = b \/ In b l.
+Proof.
+ intros a b l H; inversion_clear H; auto.
+Qed.
+
+Lemma In_dec :
+ (forall x y:A, {x = y} + {x <> y}) ->
+ forall (a:A) (l:list), {In a l} + {~ In a l}.
+
+Proof.
+  induction l as [| a0 l IHl].
+  right; apply in_nil.
+  destruct (H a0 a); simpl in |- *; auto.
+  destruct IHl; simpl in |- *; auto. 
+  right; unfold not in |- *; intros [Hc1| Hc2]; auto.
+Qed.
+
+Lemma in_app_or : forall (l m:list) (a:A), In a (l ++ m) -> In a l \/ In a m.
+Proof. 
+	intros l m a.
+	elim l; simpl in |- *; auto.
+	intros a0 y H H0.
+	now_show ((a0 = a \/ In a y) \/ In a m).
+	elim H0; auto.
+	intro H1.
+        now_show ((a0 = a \/ In a y) \/ In a m).
+	elim (H H1); auto.
+Qed.
+Hint Immediate in_app_or.
+
+Lemma in_or_app : forall (l m:list) (a:A), In a l \/ In a m -> In a (l ++ m).
+Proof. 
+	intros l m a.
+	elim l; simpl in |- *; intro H.
+        now_show (In a m).
+	elim H; auto; intro H0.
+	now_show (In a m).
+	elim H0. (* subProof completed *)
+	intros y H0 H1.
+	now_show (H = a \/ In a (y ++ m)).
+	elim H1; auto 4.
+	intro H2.
+	now_show (H = a \/ In a (y ++ m)).
+	elim H2; auto.
+Qed.
+Hint Resolve in_or_app.
+
+(***************************)
+(** Set inclusion on list  *)
+(***************************)
+
+Definition incl (l m:list) := forall a:A, In a l -> In a m.
+Hint Unfold incl.
+
+Lemma incl_refl : forall l:list, incl l l.
+Proof. 
+	auto.
+Qed.
+Hint Resolve incl_refl.
+
+Lemma incl_tl : forall (a:A) (l m:list), incl l m -> incl l (a :: m).
+Proof. 
+	auto.
+Qed.
+Hint Immediate incl_tl.
+
+Lemma incl_tran : forall l m n:list, incl l m -> incl m n -> incl l n.
+Proof. 
+	auto.
+Qed.
+
+Lemma incl_appl : forall l m n:list, incl l n -> incl l (n ++ m).
+Proof. 
+	auto.
+Qed.
+Hint Immediate incl_appl.
+
+Lemma incl_appr : forall l m n:list, incl l n -> incl l (m ++ n).
+Proof. 
+	auto.
+Qed.
+Hint Immediate incl_appr.
+
+Lemma incl_cons :
+ forall (a:A) (l m:list), In a m -> incl l m -> incl (a :: l) m.
+Proof. 
+	unfold incl in |- *; simpl in |- *; intros a l m H H0 a0 H1.
+        now_show (In a0 m).
+	elim H1.
+	now_show (a = a0 -> In a0 m).
+	elim H1; auto; intro H2.
+	now_show (a = a0 -> In a0 m).
+	elim H2; auto. (* solves subgoal *)
+	now_show (In a0 l -> In a0 m).
+	auto.
+Qed.
+Hint Resolve incl_cons.
+
+Lemma incl_app : forall l m n:list, incl l n -> incl m n -> incl (l ++ m) n.
+Proof. 
+	unfold incl in |- *; simpl in |- *; intros l m n H H0 a H1.
+        now_show (In a n).
+	elim (in_app_or _ _ _ H1); auto.
+Qed.
+Hint Resolve incl_app.
+
+(**************************)
+(** Nth element of a list *)
+(**************************)
+
+Fixpoint nth (n:nat) (l:list) (default:A) {struct l} : A :=
+  match n, l with
+  | O, x :: l' => x
+  | O, other => default
+  | S m, nil => default
+  | S m, x :: t => nth m t default
+  end.
+
+Fixpoint nth_ok (n:nat) (l:list) (default:A) {struct l} : bool :=
+  match n, l with
+  | O, x :: l' => true
+  | O, other => false
+  | S m, nil => false
+  | S m, x :: t => nth_ok m t default
+  end.
+
+Lemma nth_in_or_default :
+ forall (n:nat) (l:list) (d:A), {In (nth n l d) l} + {nth n l d = d}.
+(* Realizer nth_ok. Program_all. *)
+Proof. 
+  intros n l d; generalize n; induction l; intro n0.
+  right; case n0; trivial.
+  case n0; simpl in |- *.
+  auto.
+  intro n1; elim (IHl n1); auto.     
+Qed.
+
+Lemma nth_S_cons :
+ forall (n:nat) (l:list) (d a:A),
+   In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l).
+Proof. 
+  simpl in |- *; auto.
+Qed.
+
+Fixpoint nth_error (l:list) (n:nat) {struct n} : Exc A :=
+  match n, l with
+  | O, x :: _ => value x
+  | S n, _ :: l => nth_error l n
+  | _, _ => error
+  end.
+
+Definition nth_default (default:A) (l:list) (n:nat) : A :=
+  match nth_error l n with
+  | Some x => x
+  | None => default
+  end.
+
+Lemma nth_In :
+ forall (n:nat) (l:list) (d:A), n < length l -> In (nth n l d) l.
+
+Proof.
+unfold lt in |- *; induction n as [| n hn]; simpl in |- *.
+destruct l; simpl in |- *; [ inversion 2 | auto ].
+destruct l as [| a l hl]; simpl in |- *.
+inversion 2.
+intros d ie; right; apply hn; auto with arith.
+Qed.
+
+(********************************)
+(** Decidable equality on lists *)
+(********************************)
+
+
+Lemma list_eq_dec :
+ (forall x y:A, {x = y} + {x <> y}) -> forall x y:list, {x = y} + {x <> y}.
+Proof.
+  induction x as [| a l IHl]; destruct y as [| a0 l0]; auto.
+  destruct (H a a0) as [e| e].
+  destruct (IHl l0) as [e'| e'].
+  left; rewrite e; rewrite e'; trivial.
+  right; red in |- *; intro.
+  apply e'; injection H0; trivial.
+  right; red in |- *; intro.
+  apply e; injection H0; trivial.
+Qed.
+
+(*************************)
+(**  Reverse             *)
+(*************************)
+
+Fixpoint rev (l:list) : list :=
+  match l with
+  | nil => nil
+  | x :: l' => rev l' ++ x :: nil
+  end.
+
+Lemma distr_rev : forall x y:list, rev (x ++ y) = rev y ++ rev x.
+Proof.
+ induction x as [| a l IHl].
+ destruct y as [| a l].
+ simpl in |- *.
+ auto.
+
+ simpl in |- *.
+ apply app_nil_end; auto.
+
+ intro y.
+ simpl in |- *.
+ rewrite (IHl y).
+ apply (app_ass (rev y) (rev l) (a :: nil)).
+Qed.
+
+Remark rev_unit : forall (l:list) (a:A), rev (l ++ a :: nil) = a :: rev l.
+Proof.
+ intros.
+ apply (distr_rev l (a :: nil)); simpl in |- *; auto.
+Qed.
+
+Lemma rev_involutive : forall l:list, rev (rev l) = l.
+Proof.
+ induction l as [| a l IHl].
+ simpl in |- *; auto.
+
+ simpl in |- *.
+ rewrite (rev_unit (rev l) a).
+ rewrite IHl; auto.
+Qed.
+
+(*********************************************)
+(**  Reverse Induction Principle on Lists    *)
+(*********************************************)
+
+Section Reverse_Induction.
+
+Unset Implicit Arguments.
+
+Remark rev_list_ind :
+ forall P:list -> Prop,
+   P nil ->
+   (forall (a:A) (l:list), P (rev l) -> P (rev (a :: l))) ->
+   forall l:list, P (rev l).
+Proof.
+ induction l; auto.
+Qed.
+Set Implicit Arguments.
+
+Lemma rev_ind :
+ forall P:list -> Prop,
+   P nil ->
+   (forall (x:A) (l:list), P l -> P (l ++ x :: nil)) -> forall l:list, P l.
+Proof.
+ intros.
+ generalize (rev_involutive l).
+ intros E; rewrite <- E.
+ apply (rev_list_ind P).
+ auto.
+
+ simpl in |- *.
+ intros.
+ apply (H0 a (rev l0)).
+ auto.
+Qed.
+
+End Reverse_Induction.
+
+End Lists.
+
+Implicit Arguments nil [A].
+
+Hint Resolve nil_cons app_nil_end ass_app app_ass: datatypes v62.
+Hint Resolve app_comm_cons app_cons_not_nil: datatypes v62.
+Hint Immediate app_eq_nil: datatypes v62.
+Hint Resolve app_eq_unit app_inj_tail: datatypes v62. 
+Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons:
+  datatypes v62.
+Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes v62.
+Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons
+  incl_app: datatypes v62.
+
+Section Functions_on_lists.
+
+(****************************************************************)
+(** Some generic functions on lists and basic functions of them *)
+(****************************************************************)
+
+Section Map.
+Variables A B : Set.
+Variable f : A -> B.
+Fixpoint map (l:list A) : list B :=
+  match l with
+  | nil => nil
+  | cons a t => cons (f a) (map t)
+  end.
+End Map.
+
+Lemma in_map :
+ forall (A B:Set) (f:A -> B) (l:list A) (x:A), In x l -> In (f x) (map f l).
+Proof. 
+  induction l as [| a l IHl]; simpl in |- *;
+   [ auto
+   | destruct 1; [ left; apply f_equal with (f := f); assumption | auto ] ].
+Qed.
+
+Fixpoint flat_map (A B:Set) (f:A -> list B) (l:list A) {struct l} : 
+ list B :=
+  match l with
+  | nil => nil
+  | cons x t => app (f x) (flat_map f t)
+  end.
+
+Fixpoint list_prod (A B:Set) (l:list A) (l':list B) {struct l} :
+ list (A * B) :=
+  match l with
+  | nil => nil
+  | cons x t => app (map (fun y:B => (x, y)) l') (list_prod t l')
+  end.
+
+Lemma in_prod_aux :
+ forall (A B:Set) (x:A) (y:B) (l:list B),
+   In y l -> In (x, y) (map (fun y0:B => (x, y0)) l).
+Proof. 
+  induction l;
+   [ simpl in |- *; auto
+   | simpl in |- *; destruct 1 as [H1| ];
+      [ left; rewrite H1; trivial | right; auto ] ].
+Qed.
+
+Lemma in_prod :
+ forall (A B:Set) (l:list A) (l':list B) (x:A) (y:B),
+   In x l -> In y l' -> In (x, y) (list_prod l l').
+Proof. 
+  induction l;
+   [ simpl in |- *; tauto
+   | simpl in |- *; intros; apply in_or_app; destruct H;
+      [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ].
+Qed.
+
+(** [(list_power x y)] is [y^x], or the set of sequences of elts of [y]
+    indexed by elts of [x], sorted in lexicographic order. *)
+
+Fixpoint list_power (A B:Set) (l:list A) (l':list B) {struct l} :
+ list (list (A * B)) :=
+  match l with
+  | nil => cons nil nil
+  | cons x t =>
+      flat_map (fun f:list (A * B) => map (fun y:B => cons (x, y) f) l')
+        (list_power t l')
+  end.
+
+(************************************)
+(** Left-to-right iterator on lists *)
+(************************************)
+
+Section Fold_Left_Recursor.
+Variables A B : Set.
+Variable f : A -> B -> A.
+Fixpoint fold_left (l:list B) (a0:A) {struct l} : A :=
+  match l with
+  | nil => a0
+  | cons b t => fold_left t (f a0 b)
+  end.
+End Fold_Left_Recursor.
+
+(************************************)
+(** Right-to-left iterator on lists *)
+(************************************)
+
+Section Fold_Right_Recursor.
+Variables A B : Set.
+Variable f : B -> A -> A.
+Variable a0 : A.
+Fixpoint fold_right (l:list B) : A :=
+  match l with
+  | nil => a0
+  | cons b t => f b (fold_right t)
+  end.
+End Fold_Right_Recursor.
+
+Theorem fold_symmetric :
+ forall (A:Set) (f:A -> A -> A),
+   (forall x y z:A, f x (f y z) = f (f x y) z) ->
+   (forall x y:A, f x y = f y x) ->
+   forall (a0:A) (l:list A), fold_left f l a0 = fold_right f a0 l.
+Proof.
+destruct l as [| a l].
+reflexivity.
+simpl in |- *.
+rewrite <- H0.
+generalize a0 a.
+induction l as [| a3 l IHl]; simpl in |- *.
+trivial.
+intros.
+rewrite H.
+rewrite (H0 a2).
+rewrite <- (H a1).
+rewrite (H0 a1).
+rewrite IHl.
+reflexivity.
+Qed.
+
+End Functions_on_lists.
+
+
+(** Exporting list notations *)
+
+Infix "::" := cons (at level 60, right associativity) : list_scope.
+
+Infix "++" := app (right associativity, at level 60) : list_scope.
+
+Open Scope list_scope.
+
+(** Declare Scope list_scope with key list *)
+Delimit Scope list_scope with list.
+
+Bind Scope list_scope with list.
diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v
new file mode 100644
index 00000000..d5ecad9c
--- /dev/null
+++ b/theories/Lists/ListSet.v
@@ -0,0 +1,398 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: ListSet.v,v 1.13.2.1 2004/07/16 19:31:05 herbelin Exp $ i*)
+
+(** A Library for finite sets, implemented as lists 
+    A Library with similar interface will soon be available under
+    the name TreeSet in the theories/Trees directory *)
+
+(** PolyList is loaded, but not exported.
+    This allow to "hide" the definitions, functions and theorems of PolyList
+    and to see only the ones of ListSet *)
+
+Require Import List.
+
+Set Implicit Arguments.
+
+Section first_definitions.
+
+  Variable A : Set.
+  Hypothesis Aeq_dec : forall x y:A, {x = y} + {x <> y}.
+
+  Definition set := list A.
+
+  Definition empty_set : set := nil.
+
+  Fixpoint set_add (a:A) (x:set) {struct x} : set :=
+    match x with
+    | nil => a :: nil
+    | a1 :: x1 =>
+        match Aeq_dec a a1 with
+        | left _ => a1 :: x1
+        | right _ => a1 :: set_add a x1
+        end
+    end.
+
+
+  Fixpoint set_mem (a:A) (x:set) {struct x} : bool :=
+    match x with
+    | nil => false
+    | a1 :: x1 =>
+        match Aeq_dec a a1 with
+        | left _ => true
+        | right _ => set_mem a x1
+        end
+    end.
+ 
+  (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing *)
+  Fixpoint set_remove (a:A) (x:set) {struct x} : set :=
+    match x with
+    | nil => empty_set
+    | a1 :: x1 =>
+        match Aeq_dec a a1 with
+        | left _ => x1
+        | right _ => a1 :: set_remove a x1
+        end
+    end.
+
+  Fixpoint set_inter (x:set) : set -> set :=
+    match x with
+    | nil => fun y => nil
+    | a1 :: x1 =>
+        fun y =>
+          if set_mem a1 y then a1 :: set_inter x1 y else set_inter x1 y
+    end.
+
+  Fixpoint set_union (x y:set) {struct y} : set :=
+    match y with
+    | nil => x
+    | a1 :: y1 => set_add a1 (set_union x y1)
+    end.
+        
+  (** returns the set of all els of [x] that does not belong to [y] *)
+  Fixpoint set_diff (x y:set) {struct x} : set :=
+    match x with
+    | nil => nil
+    | a1 :: x1 =>
+        if set_mem a1 y then set_diff x1 y else set_add a1 (set_diff x1 y)
+    end.
+   
+
+  Definition set_In : A -> set -> Prop := In (A:=A).
+
+  Lemma set_In_dec : forall (a:A) (x:set), {set_In a x} + {~ set_In a x}.
+
+  Proof.
+    unfold set_In in |- *.
+    (*** Realizer set_mem. Program_all. ***)
+    simple induction x.
+    auto.
+    intros a0 x0 Ha0. case (Aeq_dec a a0); intro eq.
+    rewrite eq; simpl in |- *; auto with datatypes.
+    elim Ha0.
+    auto with datatypes.
+    right; simpl in |- *; unfold not in |- *; intros [Hc1| Hc2];
+     auto with datatypes.
+  Qed.
+
+  Lemma set_mem_ind :
+   forall (B:Set) (P:B -> Prop) (y z:B) (a:A) (x:set),
+     (set_In a x -> P y) -> P z -> P (if set_mem a x then y else z).
+
+  Proof.
+    simple induction x; simpl in |- *; intros.
+    assumption.
+    elim (Aeq_dec a a0); auto with datatypes.
+  Qed.
+
+  Lemma set_mem_ind2 :
+   forall (B:Set) (P:B -> Prop) (y z:B) (a:A) (x:set),
+     (set_In a x -> P y) ->
+     (~ set_In a x -> P z) -> P (if set_mem a x then y else z).
+
+  Proof.
+    simple induction x; simpl in |- *; intros.
+    apply H0; red in |- *; trivial.
+    case (Aeq_dec a a0); auto with datatypes.
+    intro; apply H; intros; auto.
+    apply H1; red in |- *; intro.
+    case H3; auto.
+  Qed.
+
+ 
+  Lemma set_mem_correct1 :
+   forall (a:A) (x:set), set_mem a x = true -> set_In a x.
+  Proof.
+    simple induction x; simpl in |- *.
+    discriminate.
+    intros a0 l; elim (Aeq_dec a a0); auto with datatypes.
+  Qed.
+
+  Lemma set_mem_correct2 :
+   forall (a:A) (x:set), set_In a x -> set_mem a x = true.
+  Proof.
+    simple induction x; simpl in |- *.
+    intro Ha; elim Ha.
+    intros a0 l; elim (Aeq_dec a a0); auto with datatypes.
+    intros H1 H2 [H3| H4].
+    absurd (a0 = a); auto with datatypes.
+    auto with datatypes.
+  Qed.
+
+  Lemma set_mem_complete1 :
+   forall (a:A) (x:set), set_mem a x = false -> ~ set_In a x.
+  Proof.
+    simple induction x; simpl in |- *.
+    tauto.
+    intros a0 l; elim (Aeq_dec a a0).
+    intros; discriminate H0.
+    unfold not in |- *; intros; elim H1; auto with datatypes.
+  Qed.
+
+  Lemma set_mem_complete2 :
+   forall (a:A) (x:set), ~ set_In a x -> set_mem a x = false.
+  Proof.
+    simple induction x; simpl in |- *.
+    tauto.
+    intros a0 l; elim (Aeq_dec a a0).
+    intros; elim H0; auto with datatypes.
+    tauto.
+  Qed.
+
+  Lemma set_add_intro1 :
+   forall (a b:A) (x:set), set_In a x -> set_In a (set_add b x).
+
+  Proof.
+    unfold set_In in |- *; simple induction x; simpl in |- *.
+    auto with datatypes.
+    intros a0 l H [Ha0a| Hal].
+    elim (Aeq_dec b a0); left; assumption.
+    elim (Aeq_dec b a0); right; [ assumption | auto with datatypes ].
+  Qed.
+
+  Lemma set_add_intro2 :
+   forall (a b:A) (x:set), a = b -> set_In a (set_add b x).
+
+  Proof.
+    unfold set_In in |- *; simple induction x; simpl in |- *.
+    auto with datatypes.
+    intros a0 l H Hab.
+    elim (Aeq_dec b a0);
+     [ rewrite Hab; intro Hba0; rewrite Hba0; simpl in |- *;
+        auto with datatypes
+     | auto with datatypes ].
+  Qed.
+
+  Hint Resolve set_add_intro1 set_add_intro2.
+
+  Lemma set_add_intro :
+   forall (a b:A) (x:set), a = b \/ set_In a x -> set_In a (set_add b x).
+  
+  Proof.
+    intros a b x [H1| H2]; auto with datatypes.
+  Qed.
+ 
+  Lemma set_add_elim :
+   forall (a b:A) (x:set), set_In a (set_add b x) -> a = b \/ set_In a x.
+
+  Proof.
+    unfold set_In in |- *.
+    simple induction x.
+    simpl in |- *; intros [H1| H2]; auto with datatypes.
+    simpl in |- *; do 3 intro.
+    elim (Aeq_dec b a0).
+    simpl in |- *; tauto.
+    simpl in |- *; intros; elim H0.
+    trivial with datatypes.
+    tauto.
+    tauto.
+  Qed.
+
+  Lemma set_add_elim2 :
+   forall (a b:A) (x:set), set_In a (set_add b x) -> a <> b -> set_In a x.
+   intros a b x H; case (set_add_elim _ _ _ H); intros; trivial.
+   case H1; trivial.
+   Qed.
+
+  Hint Resolve set_add_intro set_add_elim set_add_elim2.
+
+  Lemma set_add_not_empty : forall (a:A) (x:set), set_add a x <> empty_set.
+  Proof.
+    simple induction x; simpl in |- *.
+    discriminate.
+    intros; elim (Aeq_dec a a0); intros; discriminate.
+  Qed.   
+
+
+  Lemma set_union_intro1 :
+   forall (a:A) (x y:set), set_In a x -> set_In a (set_union x y).
+  Proof.
+    simple induction y; simpl in |- *; auto with datatypes.
+  Qed.
+
+  Lemma set_union_intro2 :
+   forall (a:A) (x y:set), set_In a y -> set_In a (set_union x y).
+  Proof.
+    simple induction y; simpl in |- *.
+    tauto.
+    intros; elim H0; auto with datatypes.
+  Qed.
+
+  Hint Resolve set_union_intro2 set_union_intro1.
+
+  Lemma set_union_intro :
+   forall (a:A) (x y:set),
+     set_In a x \/ set_In a y -> set_In a (set_union x y).
+  Proof.
+    intros; elim H; auto with datatypes.
+  Qed.
+
+  Lemma set_union_elim :
+   forall (a:A) (x y:set),
+     set_In a (set_union x y) -> set_In a x \/ set_In a y.
+  Proof.
+    simple induction y; simpl in |- *.
+    auto with datatypes.
+    intros.
+    generalize (set_add_elim _ _ _ H0).
+    intros [H1| H1].
+    auto with datatypes.
+    tauto.
+  Qed.
+
+  Lemma set_union_emptyL :
+   forall (a:A) (x:set), set_In a (set_union empty_set x) -> set_In a x.
+    intros a x H; case (set_union_elim _ _ _ H); auto || contradiction.
+  Qed.
+
+
+  Lemma set_union_emptyR :
+   forall (a:A) (x:set), set_In a (set_union x empty_set) -> set_In a x.
+    intros a x H; case (set_union_elim _ _ _ H); auto || contradiction.
+  Qed.
+
+
+  Lemma set_inter_intro :
+   forall (a:A) (x y:set),
+     set_In a x -> set_In a y -> set_In a (set_inter x y).
+  Proof.
+    simple induction x.
+    auto with datatypes.
+    simpl in |- *; intros a0 l Hrec y [Ha0a| Hal] Hy.
+    simpl in |- *; rewrite Ha0a.
+    generalize (set_mem_correct1 a y).
+    generalize (set_mem_complete1 a y).
+    elim (set_mem a y); simpl in |- *; intros.
+    auto with datatypes.
+    absurd (set_In a y); auto with datatypes.
+    elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ].     
+  Qed.
+
+  Lemma set_inter_elim1 :
+   forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a x.
+  Proof.
+    simple induction x.
+    auto with datatypes.
+    simpl in |- *; intros a0 l Hrec y.
+    generalize (set_mem_correct1 a0 y).
+    elim (set_mem a0 y); simpl in |- *; intros.
+    elim H0; eauto with datatypes.
+    eauto with datatypes.
+  Qed.
+
+  Lemma set_inter_elim2 :
+   forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a y.
+  Proof.
+    simple induction x.
+    simpl in |- *; tauto.
+    simpl in |- *; intros a0 l Hrec y.
+    generalize (set_mem_correct1 a0 y).
+    elim (set_mem a0 y); simpl in |- *; intros.
+    elim H0;
+     [ intro Hr; rewrite <- Hr; eauto with datatypes | eauto with datatypes ].
+    eauto with datatypes.
+  Qed.
+
+  Hint Resolve set_inter_elim1 set_inter_elim2.
+
+  Lemma set_inter_elim :
+   forall (a:A) (x y:set),
+     set_In a (set_inter x y) -> set_In a x /\ set_In a y.
+  Proof.
+    eauto with datatypes.
+  Qed. 
+
+  Lemma set_diff_intro :
+   forall (a:A) (x y:set),
+     set_In a x -> ~ set_In a y -> set_In a (set_diff x y).
+  Proof.
+    simple induction x.
+    simpl in |- *; tauto.
+    simpl in |- *; intros a0 l Hrec y [Ha0a| Hal] Hay.
+    rewrite Ha0a; generalize (set_mem_complete2 _ _ Hay).
+    elim (set_mem a y);
+     [ intro Habs; discriminate Habs | auto with datatypes ].
+    elim (set_mem a0 y); auto with datatypes.
+  Qed.
+
+  Lemma set_diff_elim1 :
+   forall (a:A) (x y:set), set_In a (set_diff x y) -> set_In a x.
+  Proof.
+    simple induction x.
+    simpl in |- *; tauto.
+    simpl in |- *; intros a0 l Hrec y; elim (set_mem a0 y).
+    eauto with datatypes.
+    intro; generalize (set_add_elim _ _ _ H).
+    intros [H1| H2]; eauto with datatypes.
+  Qed.
+
+  Lemma set_diff_elim2 :
+   forall (a:A) (x y:set), set_In a (set_diff x y) -> ~ set_In a y.
+  intros a x y; elim x; simpl in |- *.
+  intros; contradiction.
+  intros a0 l Hrec. 
+  apply set_mem_ind2; auto.
+  intros H1 H2; case (set_add_elim _ _ _ H2); intros; auto.
+  rewrite H; trivial.
+  Qed.
+
+  Lemma set_diff_trivial : forall (a:A) (x:set), ~ set_In a (set_diff x x).
+  red in |- *; intros a x H.
+  apply (set_diff_elim2 _ _ _ H).
+  apply (set_diff_elim1 _ _ _ H).
+  Qed.
+
+Hint Resolve set_diff_intro set_diff_trivial.
+
+
+End first_definitions.
+
+Section other_definitions.
+
+  Variables A B : Set.
+
+  Definition set_prod : set A -> set B -> set (A * B) :=
+    list_prod (A:=A) (B:=B).
+
+  (** [B^A], set of applications from [A] to [B] *)
+  Definition set_power : set A -> set B -> set (set (A * B)) :=
+    list_power (A:=A) (B:=B).
+
+  Definition set_map : (A -> B) -> set A -> set B := map (A:=A) (B:=B).
+
+  Definition set_fold_left : (B -> A -> B) -> set A -> B -> B :=
+    fold_left (A:=B) (B:=A).
+
+  Definition set_fold_right (f:A -> B -> B) (x:set A) 
+    (b:B) : B := fold_right f b x.
+
+ 
+End other_definitions.
+
+Unset Implicit Arguments.
\ No newline at end of file
diff --git a/theories/Lists/MonoList.v b/theories/Lists/MonoList.v
new file mode 100755
index 00000000..d639a39d
--- /dev/null
+++ b/theories/Lists/MonoList.v
@@ -0,0 +1,269 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: MonoList.v,v 1.2.2.1 2004/07/16 19:31:05 herbelin Exp $ i*)
+
+(** THIS IS A OLD CONTRIB. IT IS NO LONGER MAINTAINED ***)
+
+Require Import Le.
+
+Parameter List_Dom : Set.
+Definition A := List_Dom.
+
+Inductive list : Set :=
+  | nil : list
+  | cons : A -> list -> list.
+
+Fixpoint app (l m:list) {struct l} : list :=
+  match l return list with
+  | nil => m
+  | cons a l1 => cons a (app l1 m)
+  end.
+
+
+Lemma app_nil_end : forall l:list, l = app l nil.
+Proof. 
+	intro l; elim l; simpl in |- *; auto.
+        simple induction 1; auto.
+Qed.
+Hint Resolve app_nil_end: list v62.
+
+Lemma app_ass : forall l m n:list, app (app l m) n = app l (app m n).
+Proof. 
+	intros l m n; elim l; simpl in |- *; auto with list.
+	simple induction 1; auto with list.
+Qed.
+Hint Resolve app_ass: list v62.
+
+Lemma ass_app : forall l m n:list, app l (app m n) = app (app l m) n.
+Proof. 
+	auto with list.
+Qed.
+Hint Resolve ass_app: list v62.
+
+Definition tail (l:list) : list :=
+  match l return list with
+  | cons _ m => m
+  | _ => nil
+  end.
+                   
+
+Lemma nil_cons : forall (a:A) (m:list), nil <> cons a m.
+  intros; discriminate.
+Qed.
+
+(****************************************)
+(* Length of lists                      *)
+(****************************************)
+
+Fixpoint length (l:list) : nat :=
+  match l return nat with
+  | cons _ m => S (length m)
+  | _ => 0
+  end.
+
+(******************************)
+(* Length order of lists      *)
+(******************************)
+
+Section length_order.
+Definition lel (l m:list) := length l <= length m.
+
+Hint Unfold lel: list.
+
+Variables a b : A.
+Variables l m n : list.
+
+Lemma lel_refl : lel l l.
+Proof. 
+	unfold lel in |- *; auto with list.
+Qed.
+
+Lemma lel_trans : lel l m -> lel m n -> lel l n.
+Proof. 
+	unfold lel in |- *; intros.
+        apply le_trans with (length m); auto with list.
+Qed.
+
+Lemma lel_cons_cons : lel l m -> lel (cons a l) (cons b m).
+Proof. 
+	unfold lel in |- *; simpl in |- *; auto with list arith.
+Qed.
+
+Lemma lel_cons : lel l m -> lel l (cons b m).
+Proof. 
+	unfold lel in |- *; simpl in |- *; auto with list arith.
+Qed.
+
+Lemma lel_tail : lel (cons a l) (cons b m) -> lel l m.
+Proof. 
+	unfold lel in |- *; simpl in |- *; auto with list arith.
+Qed.
+
+Lemma lel_nil : forall l':list, lel l' nil -> nil = l'.
+Proof. 
+	intro l'; elim l'; auto with list arith.
+	intros a' y H H0.
+	(*  <list>nil=(cons a' y)
+	    ============================
+	      H0 : (lel (cons a' y) nil)
+	      H : (lel y nil)->(<list>nil=y)
+	      y : list
+	      a' : A
+	      l' : list *)
+	absurd (S (length y) <= 0); auto with list arith.
+Qed.
+End length_order.
+
+Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons: list
+  v62.
+
+Fixpoint In (a:A) (l:list) {struct l} : Prop :=
+  match l with
+  | nil => False
+  | cons b m => b = a \/ In a m
+  end.
+
+Lemma in_eq : forall (a:A) (l:list), In a (cons a l).
+Proof. 
+	simpl in |- *; auto with list.
+Qed.
+Hint Resolve in_eq: list v62.
+
+Lemma in_cons : forall (a b:A) (l:list), In b l -> In b (cons a l).
+Proof. 
+	simpl in |- *; auto with list.
+Qed.
+Hint Resolve in_cons: list v62.
+
+Lemma in_app_or : forall (l m:list) (a:A), In a (app l m) -> In a l \/ In a m.
+Proof. 
+	intros l m a.
+	elim l; simpl in |- *; auto with list.
+	intros a0 y H H0.
+	(*  ((<A>a0=a)\/(In a y))\/(In a m)
+	    ============================
+	      H0 : (<A>a0=a)\/(In a (app y m))
+	      H : (In a (app y m))->((In a y)\/(In a m))
+	      y : list
+	      a0 : A
+	      a : A
+	      m : list
+	      l : list *)
+	elim H0; auto with list.
+	intro H1.
+	(*  ((<A>a0=a)\/(In a y))\/(In a m)
+	    ============================
+	      H1 : (In a (app y m)) *)
+	elim (H H1); auto with list.
+Qed.
+Hint Immediate in_app_or: list v62.
+
+Lemma in_or_app : forall (l m:list) (a:A), In a l \/ In a m -> In a (app l m).
+Proof. 
+	intros l m a.
+	elim l; simpl in |- *; intro H.
+	(* 1 (In a m)
+	    ============================
+	      H : False\/(In a m)
+	      a : A
+	      m : list
+	      l : list *)
+	elim H; auto with list; intro H0.
+	(*  (In a m)
+	    ============================
+	      H0 : False *)
+	elim H0. (* subProof completed *)
+	intros y H0 H1.
+	(*  2 (<A>H=a)\/(In a (app y m))
+	    ============================
+	      H1 : ((<A>H=a)\/(In a y))\/(In a m)
+	      H0 : ((In a y)\/(In a m))->(In a (app y m))
+	      y : list *)
+	elim H1; auto 4 with list.
+	intro H2.
+	(*  (<A>H=a)\/(In a (app y m))
+	    ============================
+	      H2 : (<A>H=a)\/(In a y) *)
+	elim H2; auto with list.
+Qed.
+Hint Resolve in_or_app: list v62.
+
+Definition incl (l m:list) := forall a:A, In a l -> In a m.
+
+Hint Unfold incl: list v62.
+
+Lemma incl_refl : forall l:list, incl l l.
+Proof. 
+	auto with list.
+Qed.
+Hint Resolve incl_refl: list v62.
+
+Lemma incl_tl : forall (a:A) (l m:list), incl l m -> incl l (cons a m).
+Proof. 
+	auto with list.
+Qed.
+Hint Immediate incl_tl: list v62.
+
+Lemma incl_tran : forall l m n:list, incl l m -> incl m n -> incl l n.
+Proof. 
+	auto with list.
+Qed.
+
+Lemma incl_appl : forall l m n:list, incl l n -> incl l (app n m).
+Proof. 
+	auto with list.
+Qed.
+Hint Immediate incl_appl: list v62.
+
+Lemma incl_appr : forall l m n:list, incl l n -> incl l (app m n).
+Proof. 
+	auto with list.
+Qed.
+Hint Immediate incl_appr: list v62.
+
+Lemma incl_cons :
+ forall (a:A) (l m:list), In a m -> incl l m -> incl (cons a l) m.
+Proof. 
+	unfold incl in |- *; simpl in |- *; intros a l m H H0 a0 H1.
+	(*  (In a0 m)
+	    ============================
+	      H1 : (<A>a=a0)\/(In a0 l)
+	      a0 : A
+	      H0 : (a:A)(In a l)->(In a m)
+	      H : (In a m)
+	      m : list
+	      l : list
+	      a : A *)
+	elim H1.
+	(*  1 (<A>a=a0)->(In a0 m) *)
+	elim H1; auto with list; intro H2.
+	(*  (<A>a=a0)->(In a0 m)
+	    ============================
+	      H2 : <A>a=a0 *)
+	elim H2; auto with list. (* solves subgoal *)
+	(*  2 (In a0 l)->(In a0 m) *)
+	auto with list.
+Qed.
+Hint Resolve incl_cons: list v62.
+
+Lemma incl_app : forall l m n:list, incl l n -> incl m n -> incl (app l m) n.
+Proof. 
+	unfold incl in |- *; simpl in |- *; intros l m n H H0 a H1.
+	(*  (In a n)
+	    ============================
+	      H1 : (In a (app l m))
+	      a : A
+	      H0 : (a:A)(In a m)->(In a n)
+	      H : (a:A)(In a l)->(In a n)
+	      n : list
+	      m : list
+	      l : list *)
+	elim (in_app_or l m a); auto with list.
+Qed.
+Hint Resolve incl_app: list v62.
\ No newline at end of file
diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v
new file mode 100755
index 00000000..3c433ba2
--- /dev/null
+++ b/theories/Lists/Streams.v
@@ -0,0 +1,177 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Streams.v,v 1.15.2.1 2004/07/16 19:31:05 herbelin Exp $ i*)
+
+Set Implicit Arguments.
+
+(** Streams *)
+
+Section Streams.
+
+Variable A : Set.
+
+CoInductive Stream : Set :=
+    Cons : A -> Stream -> Stream.
+
+
+Definition hd (x:Stream) := match x with
+                            | Cons a _ => a
+                            end.
+
+Definition tl (x:Stream) := match x with
+                            | Cons _ s => s
+                            end.
+
+
+Fixpoint Str_nth_tl (n:nat) (s:Stream) {struct n} : Stream :=
+  match n with
+  | O => s
+  | S m => Str_nth_tl m (tl s)
+  end.
+
+Definition Str_nth (n:nat) (s:Stream) : A := hd (Str_nth_tl n s).
+
+
+Lemma unfold_Stream :
+ forall x:Stream, x = match x with
+                      | Cons a s => Cons a s
+                      end. 
+Proof.
+  intro x.
+  case x.
+  trivial.
+Qed.
+
+Lemma tl_nth_tl :
+ forall (n:nat) (s:Stream), tl (Str_nth_tl n s) = Str_nth_tl n (tl s).
+Proof.
+  simple induction n; simpl in |- *; auto.
+Qed.
+Hint Resolve tl_nth_tl: datatypes v62.
+
+Lemma Str_nth_tl_plus :
+ forall (n m:nat) (s:Stream),
+   Str_nth_tl n (Str_nth_tl m s) = Str_nth_tl (n + m) s.
+simple induction n; simpl in |- *; intros; auto with datatypes.
+rewrite <- H.
+rewrite tl_nth_tl; trivial with datatypes.
+Qed.
+
+Lemma Str_nth_plus :
+ forall (n m:nat) (s:Stream), Str_nth n (Str_nth_tl m s) = Str_nth (n + m) s.
+intros; unfold Str_nth in |- *; rewrite Str_nth_tl_plus;
+ trivial with datatypes.
+Qed.
+
+(** Extensional Equality between two streams  *)
+
+CoInductive EqSt : Stream -> Stream -> Prop :=
+    eqst :
+      forall s1 s2:Stream,
+        hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2.
+
+(** A coinduction principle *)
+
+Ltac coinduction proof :=
+  cofix proof; intros; constructor;
+   [ clear proof | try (apply proof; clear proof) ].
+
+
+(** Extensional equality is an equivalence relation *)
+
+Theorem EqSt_reflex : forall s:Stream, EqSt s s.
+coinduction EqSt_reflex.
+reflexivity.
+Qed.
+
+Theorem sym_EqSt : forall s1 s2:Stream, EqSt s1 s2 -> EqSt s2 s1.
+coinduction Eq_sym.
+case H; intros; symmetry  in |- *; assumption.
+case H; intros; assumption.
+Qed.
+
+
+Theorem trans_EqSt :
+ forall s1 s2 s3:Stream, EqSt s1 s2 -> EqSt s2 s3 -> EqSt s1 s3.
+coinduction Eq_trans.
+transitivity (hd s2).
+case H; intros; assumption.
+case H0; intros; assumption.
+apply (Eq_trans (tl s1) (tl s2) (tl s3)).
+case H; trivial with datatypes.
+case H0; trivial with datatypes.
+Qed.
+
+(** The definition given is equivalent to require the elements at each
+    position to be equal *)
+
+Theorem eqst_ntheq :
+ forall (n:nat) (s1 s2:Stream), EqSt s1 s2 -> Str_nth n s1 = Str_nth n s2.
+unfold Str_nth in |- *; simple induction n.
+intros s1 s2 H; case H; trivial with datatypes.
+intros m hypind.
+simpl in |- *.
+intros s1 s2 H.
+apply hypind.
+case H; trivial with datatypes.
+Qed.
+
+Theorem ntheq_eqst :
+ forall s1 s2:Stream,
+   (forall n:nat, Str_nth n s1 = Str_nth n s2) -> EqSt s1 s2.
+coinduction Equiv2.
+apply (H 0).
+intros n; apply (H (S n)).
+Qed.
+
+Section Stream_Properties.
+
+Variable P : Stream -> Prop.
+
+(*i
+Inductive Exists : Stream -> Prop :=
+  | Here    : forall x:Stream, P x -> Exists x
+  | Further : forall x:Stream, ~ P x -> Exists (tl x) -> Exists x.
+i*)
+
+Inductive Exists : Stream -> Prop :=
+  | Here : forall x:Stream, P x -> Exists x
+  | Further : forall x:Stream, Exists (tl x) -> Exists x.
+
+CoInductive ForAll : Stream -> Prop :=
+    HereAndFurther : forall x:Stream, P x -> ForAll (tl x) -> ForAll x.
+
+
+Section Co_Induction_ForAll.
+Variable Inv : Stream -> Prop.
+Hypothesis InvThenP : forall x:Stream, Inv x -> P x.
+Hypothesis InvIsStable : forall x:Stream, Inv x -> Inv (tl x).
+
+Theorem ForAll_coind : forall x:Stream, Inv x -> ForAll x.
+coinduction ForAll_coind; auto.
+Qed.
+End Co_Induction_ForAll.
+
+End Stream_Properties.
+
+End Streams.
+
+Section Map.
+Variables A B : Set.
+Variable f : A -> B.
+CoFixpoint map (s:Stream A) : Stream B := Cons (f (hd s)) (map (tl s)).
+End Map.
+
+Section Constant_Stream.
+Variable A : Set.
+Variable a : A.
+CoFixpoint const  : Stream A := Cons a const.
+End Constant_Stream.
+
+Unset Implicit Arguments.
\ No newline at end of file
diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v
new file mode 100755
index 00000000..fbeb97ce
--- /dev/null
+++ b/theories/Lists/TheoryList.v
@@ -0,0 +1,403 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: TheoryList.v,v 1.15.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Some programs and results about lists following CAML Manual *)
+
+Require Export List.
+Set Implicit Arguments.
+Section Lists.
+
+Variable A : Set.
+
+(**********************)
+(** The null function *)
+(**********************)
+
+Definition Isnil (l:list A) : Prop := nil = l.
+
+Lemma Isnil_nil : Isnil nil.
+red in |- *; auto.
+Qed.
+Hint Resolve Isnil_nil.
+
+Lemma not_Isnil_cons : forall (a:A) (l:list A), ~ Isnil (a :: l).
+unfold Isnil in |- *.
+intros; discriminate.
+Qed.
+
+Hint Resolve Isnil_nil not_Isnil_cons.
+
+Lemma Isnil_dec : forall l:list A, {Isnil l} + {~ Isnil l}.
+intro l; case l; auto.
+(*
+Realizer (fun l => match l with
+  | nil => true
+  | _ => false
+  end).
+*)
+Qed.
+
+(************************)
+(** The Uncons function *)
+(************************)
+
+Lemma Uncons :
+ forall l:list A, {a : A &  {m : list A | a :: m = l}} + {Isnil l}.
+intro l; case l.
+auto.
+intros a m; intros; left; exists a; exists m; reflexivity.
+(*
+Realizer (fun l => match l with
+  | nil => error
+  | (cons a m) => value (a,m)
+  end).
+*)
+Qed.
+
+(********************************)
+(** The head function           *)
+(********************************)
+
+Lemma Hd :
+ forall l:list A, {a : A |  exists m : list A, a :: m = l} + {Isnil l}.
+intro l; case l.
+auto.
+intros a m; intros; left; exists a; exists m; reflexivity.
+(*
+Realizer (fun l => match l with
+  | nil => error
+  | (cons a m) => value a
+  end).
+*)
+Qed.
+
+Lemma Tl :
+ forall l:list A,
+   {m : list A | (exists a : A, a :: m = l) \/ Isnil l /\ Isnil m}.
+intro l; case l.
+exists (nil (A:=A)); auto.
+intros a m; intros; exists m; left; exists a; reflexivity.
+(*
+Realizer (fun l => match l with
+  | nil => nil
+  | (cons a m) => m
+  end).
+*)
+Qed.
+
+(****************************************)
+(** Length of lists                     *)
+(****************************************)
+
+(* length is defined in List *)
+Fixpoint Length_l (l:list A) (n:nat) {struct l} : nat :=
+  match l with
+  | nil => n
+  | _ :: m => Length_l m (S n)
+  end.
+
+(* A tail recursive version *)
+Lemma Length_l_pf : forall (l:list A) (n:nat), {m : nat | n + length l = m}.
+induction l as [| a m lrec].
+intro n; exists n; simpl in |- *; auto.
+intro n; elim (lrec (S n)); simpl in |- *; intros.
+exists x; transitivity (S (n + length m)); auto.
+(*
+Realizer Length_l.
+*)
+Qed.
+
+Lemma Length : forall l:list A, {m : nat | length l = m}.
+intro l. apply (Length_l_pf l 0).
+(*
+Realizer (fun l -> Length_l_pf l O).
+*)
+Qed.
+
+(*******************************)
+(** Members of lists           *)
+(*******************************)
+Inductive In_spec (a:A) : list A -> Prop :=
+  | in_hd : forall l:list A, In_spec a (a :: l)
+  | in_tl : forall (l:list A) (b:A), In a l -> In_spec a (b :: l).
+Hint Resolve in_hd in_tl.
+Hint Unfold In.
+Hint Resolve in_cons.
+
+Theorem In_In_spec : forall (a:A) (l:list A), In a l <-> In_spec a l.
+split.
+elim l;
+ [ intros; contradiction
+ | intros; elim H0; [ intros; rewrite H1; auto | auto ] ].
+intros; elim H; auto.
+Qed.
+
+Inductive AllS (P:A -> Prop) : list A -> Prop :=
+  | allS_nil : AllS P nil
+  | allS_cons : forall (a:A) (l:list A), P a -> AllS P l -> AllS P (a :: l).
+Hint Resolve allS_nil allS_cons.
+
+Hypothesis eqA_dec : forall a b:A, {a = b} + {a <> b}.
+
+Fixpoint mem (a:A) (l:list A) {struct l} : bool :=
+  match l with
+  | nil => false
+  | b :: m => if eqA_dec a b then true else mem a m
+  end.
+
+Hint Unfold In.
+Lemma Mem : forall (a:A) (l:list A), {In a l} + {AllS (fun b:A => b <> a) l}.
+intros a l.
+induction l.
+auto.
+elim (eqA_dec a a0).
+auto.
+simpl in |- *. elim IHl; auto.
+(*
+Realizer mem.
+*)
+Qed.
+
+(*********************************)
+(** Index of elements            *)
+(*********************************)
+
+Require Import Le.
+Require Import Lt.
+
+Inductive nth_spec : list A -> nat -> A -> Prop :=
+  | nth_spec_O : forall (a:A) (l:list A), nth_spec (a :: l) 1 a
+  | nth_spec_S :
+      forall (n:nat) (a b:A) (l:list A),
+        nth_spec l n a -> nth_spec (b :: l) (S n) a.
+Hint Resolve nth_spec_O nth_spec_S.
+
+Inductive fst_nth_spec : list A -> nat -> A -> Prop :=
+  | fst_nth_O : forall (a:A) (l:list A), fst_nth_spec (a :: l) 1 a
+  | fst_nth_S :
+      forall (n:nat) (a b:A) (l:list A),
+        a <> b -> fst_nth_spec l n a -> fst_nth_spec (b :: l) (S n) a.
+Hint Resolve fst_nth_O fst_nth_S.
+
+Lemma fst_nth_nth :
+ forall (l:list A) (n:nat) (a:A), fst_nth_spec l n a -> nth_spec l n a.
+induction 1; auto.
+Qed.
+Hint Immediate fst_nth_nth.
+
+Lemma nth_lt_O : forall (l:list A) (n:nat) (a:A), nth_spec l n a -> 0 < n.
+induction 1; auto.
+Qed.
+
+Lemma nth_le_length :
+ forall (l:list A) (n:nat) (a:A), nth_spec l n a -> n <= length l.
+induction 1; simpl in |- *; auto with arith.
+Qed.
+
+Fixpoint Nth_func (l:list A) (n:nat) {struct l} : Exc A :=
+  match l, n with
+  | a :: _, S O => value a
+  | _ :: l', S (S p) => Nth_func l' (S p)
+  | _, _ => error
+  end.
+
+Lemma Nth :
+ forall (l:list A) (n:nat),
+   {a : A | nth_spec l n a} + {n = 0 \/ length l < n}.
+induction l as [| a l IHl].
+intro n; case n; simpl in |- *; auto with arith.
+intro n; destruct n as [| [| n1]]; simpl in |- *; auto.
+left; exists a; auto.
+destruct (IHl (S n1)) as [[b]| o].
+left; exists b; auto.
+right; destruct o.
+absurd (S n1 = 0); auto.
+auto with arith.
+(*
+Realizer Nth_func.
+*)
+Qed.
+
+Lemma Item :
+ forall (l:list A) (n:nat), {a : A | nth_spec l (S n) a} + {length l <= n}.
+intros l n; case (Nth l (S n)); intro.
+case s; intro a; left; exists a; auto.
+right; case o; intro.
+absurd (S n = 0); auto.
+auto with arith.
+Qed.
+
+Require Import Minus.
+Require Import DecBool.
+
+Fixpoint index_p (a:A) (l:list A) {struct l} : nat -> Exc nat :=
+  match l with
+  | nil => fun p => error
+  | b :: m => fun p => ifdec (eqA_dec a b) (value p) (index_p a m (S p))
+  end.
+
+Lemma Index_p :
+ forall (a:A) (l:list A) (p:nat),
+   {n : nat | fst_nth_spec l (S n - p) a} + {AllS (fun b:A => a <> b) l}.
+induction l as [| b m irec].
+auto.
+intro p.
+destruct (eqA_dec a b) as [e| e].
+left; exists p.
+destruct e; elim minus_Sn_m; trivial; elim minus_n_n; auto with arith.
+destruct (irec (S p)) as [[n H]| ].
+left; exists n; auto with arith.
+elim minus_Sn_m; auto with arith.
+apply lt_le_weak; apply lt_O_minus_lt; apply nth_lt_O with m a;
+ auto with arith.
+auto.
+Qed.
+
+Lemma Index :
+ forall (a:A) (l:list A),
+   {n : nat | fst_nth_spec l n a} + {AllS (fun b:A => a <> b) l}.
+
+intros a l; case (Index_p a l 1); auto.
+intros [n P]; left; exists n; auto.
+rewrite (minus_n_O n); trivial.
+(*
+Realizer (fun a l -> Index_p a l (S O)).
+*)
+Qed.
+
+Section Find_sec.
+Variables R P : A -> Prop.
+
+Inductive InR : list A -> Prop :=
+  | inR_hd : forall (a:A) (l:list A), R a -> InR (a :: l)
+  | inR_tl : forall (a:A) (l:list A), InR l -> InR (a :: l).
+Hint Resolve inR_hd inR_tl.
+
+Definition InR_inv (l:list A) :=
+  match l with
+  | nil => False
+  | b :: m => R b \/ InR m
+  end.
+
+Lemma InR_INV : forall l:list A, InR l -> InR_inv l.
+induction 1; simpl in |- *; auto.
+Qed.
+
+Lemma InR_cons_inv : forall (a:A) (l:list A), InR (a :: l) -> R a \/ InR l.
+intros a l H; exact (InR_INV H).
+Qed.
+
+Lemma InR_or_app : forall l m:list A, InR l \/ InR m -> InR (l ++ m).
+intros l m [| ].
+induction 1; simpl in |- *; auto.
+intro. induction l; simpl in |- *; auto.
+Qed.
+
+Lemma InR_app_or : forall l m:list A, InR (l ++ m) -> InR l \/ InR m.
+intros l m; elim l; simpl in |- *; auto.
+intros b l' Hrec IAc; elim (InR_cons_inv IAc); auto.
+intros; elim Hrec; auto.
+Qed.
+
+Hypothesis RS_dec : forall a:A, {R a} + {P a}.
+
+Fixpoint find (l:list A) : Exc A :=
+  match l with
+  | nil => error
+  | a :: m => ifdec (RS_dec a) (value a) (find m)
+  end.
+
+Lemma Find : forall l:list A, {a : A | In a l &  R a} + {AllS P l}.
+induction l as [| a m [[b H1 H2]| H]]; auto.
+left; exists b; auto.
+destruct (RS_dec a).
+left; exists a; auto.
+auto.
+(*
+Realizer find.
+*)
+Qed.
+
+Variable B : Set.
+Variable T : A -> B -> Prop.
+
+Variable TS_dec : forall a:A, {c : B | T a c} + {P a}.
+
+Fixpoint try_find (l:list A) : Exc B :=
+  match l with
+  | nil => error
+  | a :: l1 =>
+      match TS_dec a with
+      | inleft (exist c _) => value c
+      | inright _ => try_find l1
+      end
+  end.
+
+Lemma Try_find :
+ forall l:list A, {c : B |  exists2 a : A, In a l & T a c} + {AllS P l}.
+induction l as [| a m [[b H1]| H]].
+auto.
+left; exists b; destruct H1 as [a' H2 H3]; exists a'; auto.
+destruct (TS_dec a) as [[c H1]| ].
+left; exists c.
+exists a; auto.
+auto.
+(* 
+Realizer try_find.
+*)
+Qed.
+
+End Find_sec.
+
+Section Assoc_sec.
+
+Variable B : Set.
+Fixpoint assoc (a:A) (l:list (A * B)) {struct l} : 
+ Exc B :=
+  match l with
+  | nil => error
+  | (a', b) :: m => ifdec (eqA_dec a a') (value b) (assoc a m)
+  end.
+
+Inductive AllS_assoc (P:A -> Prop) : list (A * B) -> Prop :=
+  | allS_assoc_nil : AllS_assoc P nil
+  | allS_assoc_cons :
+      forall (a:A) (b:B) (l:list (A * B)),
+        P a -> AllS_assoc P l -> AllS_assoc P ((a, b) :: l).
+
+Hint Resolve allS_assoc_nil allS_assoc_cons.
+
+(* The specification seems too weak: it is enough to return b if the
+   list has at least an element (a,b); probably the intention is to have
+   the specification
+
+   (a:A)(l:(list A*B)){b:B|(In_spec (a,b) l)}+{(AllS_assoc [a':A]~(a=a') l)}.
+*)
+
+Lemma Assoc :
+ forall (a:A) (l:list (A * B)), B + {AllS_assoc (fun a':A => a <> a') l}.
+induction l as [| [a' b] m assrec]. auto.
+destruct (eqA_dec a a').
+left; exact b.
+destruct assrec as [b'| ].
+left; exact b'.
+right; auto.
+(*
+Realizer assoc.
+*)
+Qed.
+
+End Assoc_sec.
+
+End Lists.
+
+Hint Resolve Isnil_nil not_Isnil_cons in_hd in_tl in_cons allS_nil allS_cons:
+  datatypes.
+Hint Immediate fst_nth_nth: datatypes.
diff --git a/theories/Lists/intro.tex b/theories/Lists/intro.tex
new file mode 100755
index 00000000..344bba59
--- /dev/null
+++ b/theories/Lists/intro.tex
@@ -0,0 +1,24 @@
+\section{Lists}\label{Lists}
+
+This library includes the following files:
+
+\begin{itemize}
+
+\item {\tt List.v} THIS OLD LIBRARY IS HERE ONLY FOR COMPATIBILITY
+  WITH OLDER VERSIONS OF COQS. THE USER SHOULD USE POLYLIST INSTEAD.
+
+\item {\tt PolyList.v} contains definitions of (polymorphic) lists, 
+  functions on lists such as head, tail, map, append and prove some
+  properties of these functions. Implicit arguments are used in this
+  library, so you should read the Referance Manual about implicit
+  arguments before using it.
+
+\item {\tt TheoryList.v} contains complementary results on lists. Here
+  a more theoric point of view is assumed : one extracts functions
+  from propositions, rather than defining functions and then prove them.
+
+\item {\tt Streams.v} defines the type of infinite lists (streams). It is a
+  coinductive type. Basic facts are stated and proved. The streams are
+  also polymorphic.
+
+\end{itemize}
diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v
new file mode 100644
index 00000000..7e950c17
--- /dev/null
+++ b/theories/Logic/Berardi.v
@@ -0,0 +1,159 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Berardi.v,v 1.5.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** This file formalizes Berardi's paradox which says that in
+   the calculus of constructions, excluded middle (EM) and axiom of
+   choice (AC) implie proof irrelevenace (PI).
+   Here, the axiom of choice is not necessary because of the use
+   of inductive types.
+<<
+@article{Barbanera-Berardi:JFP96,
+   author    = {F. Barbanera and S. Berardi},
+   title     = {Proof-irrelevance out of Excluded-middle and Choice
+                in the Calculus of Constructions},
+   journal   = {Journal of Functional Programming},
+   year      = {1996},
+   volume    = {6},
+   number    = {3},
+   pages     = {519-525}
+}
+>> *)
+
+Set Implicit Arguments.
+
+Section Berardis_paradox.
+
+(** Excluded middle *)
+Hypothesis EM : forall P:Prop, P \/ ~ P.
+
+(** Conditional on any proposition. *)
+Definition IFProp (P B:Prop) (e1 e2:P) :=
+  match EM B with
+  | or_introl _ => e1
+  | or_intror _ => e2
+  end.
+
+(** Axiom of choice applied to disjunction.
+    Provable in Coq because of dependent elimination. *)
+Lemma AC_IF :
+ forall (P B:Prop) (e1 e2:P) (Q:P -> Prop),
+   (B -> Q e1) -> (~ B -> Q e2) -> Q (IFProp B e1 e2).
+Proof.
+intros P B e1 e2 Q p1 p2.
+unfold IFProp in |- *.
+case (EM B); assumption.
+Qed.
+
+
+(** We assume a type with two elements. They play the role of booleans.
+    The main theorem under the current assumptions is that [T=F] *)
+Variable Bool : Prop.
+Variable T : Bool.
+Variable F : Bool.
+
+(** The powerset operator *)
+Definition pow (P:Prop) := P -> Bool.
+
+
+(** A piece of theory about retracts *)
+Section Retracts.
+
+Variables A B : Prop.
+
+Record retract : Prop := 
+  {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}.
+
+Record retract_cond : Prop := 
+  {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}.
+
+
+(** The dependent elimination above implies the axiom of choice: *)
+Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a.
+Proof.
+intros r.
+case r; simpl in |- *.
+trivial.
+Qed.
+
+End Retracts.
+
+(** This lemma is basically a commutation of implication and existential
+    quantification:  (EX x | A -> P(x))  <=> (A -> EX x | P(x))
+    which is provable in classical logic ( => is already provable in
+    intuitionnistic logic). *)
+
+Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B).
+Proof.
+intros A B.
+elim (EM (retract (pow A) (pow B))).
+intros [f0 g0 e].
+exists f0 g0.
+trivial.
+
+intros hf.
+exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F).
+intros; elim hf; auto.
+Qed.
+
+
+(** The paradoxical set *)
+Definition U := forall P:Prop, pow P.
+
+(** Bijection between [U] and [(pow U)] *)
+Definition f (u:U) : pow U := u U.
+
+Definition g (h:pow U) : U :=
+  fun X => let lX := j2 (L1 X U) in let rU := i2 (L1 U U) in lX (rU h).
+
+(** We deduce that the powerset of [U] is a retract of [U].
+    This lemma is stated in Berardi's article, but is not used
+    afterwards. *)
+Lemma retract_pow_U_U : retract (pow U) U.
+Proof.
+exists g f.
+intro a.
+unfold f, g in |- *; simpl in |- *.
+apply AC.
+exists (fun x:pow U => x) (fun x:pow U => x).
+trivial.
+Qed.
+
+(** Encoding of Russel's paradox *)
+
+(** The boolean negation. *)
+Definition Not_b (b:Bool) := IFProp (b = T) F T.
+
+(** the set of elements not belonging to itself *)
+Definition R : U := g (fun u:U => Not_b (u U u)).
+
+
+Lemma not_has_fixpoint : R R = Not_b (R R).
+Proof.
+unfold R at 1 in |- *.
+unfold g in |- *.
+rewrite AC with (r := L1 U U) (a := fun u:U => Not_b (u U u)).
+trivial.
+exists (fun x:pow U => x) (fun x:pow U => x); trivial.
+Qed.
+
+
+Theorem classical_proof_irrelevence : T = F.
+Proof.
+generalize not_has_fixpoint.
+unfold Not_b in |- *.
+apply AC_IF.
+intros is_true is_false.
+elim is_true; elim is_false; trivial.
+
+intros not_true is_true.
+elim not_true; trivial.
+Qed.
+
+End Berardis_paradox.
\ No newline at end of file
diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v
new file mode 100644
index 00000000..a1f4417c
--- /dev/null
+++ b/theories/Logic/ChoiceFacts.v
@@ -0,0 +1,139 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: ChoiceFacts.v,v 1.7.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(* We show that the functional formulation of the axiom of Choice
+   (usual formulation in type theory) is equivalent to its relational
+   formulation (only formulation of set theory) + the axiom of
+   (parametric) definite description (aka axiom of unique choice) *)
+
+(* This shows that the axiom of choice can be assumed (under its
+   relational formulation) without known inconsistency with classical logic,
+   though definite description conflicts with classical logic *)
+
+Definition RelationalChoice :=
+  forall (A B:Type) (R:A -> B -> Prop),
+    (forall x:A,  exists y : B, R x y) ->
+     exists R' : A -> B -> Prop,
+      (forall x:A,
+          exists y : B, R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')).
+
+Definition FunctionalChoice :=
+  forall (A B:Type) (R:A -> B -> Prop),
+    (forall x:A,  exists y : B, R x y) ->
+     exists f : A -> B, (forall x:A, R x (f x)).
+
+Definition ParamDefiniteDescription :=
+  forall (A B:Type) (R:A -> B -> Prop),
+    (forall x:A,  exists y : B, R x y /\ (forall y':B, R x y' -> y = y')) ->
+     exists f : A -> B, (forall x:A, R x (f x)).
+
+Lemma description_rel_choice_imp_funct_choice :
+ ParamDefiniteDescription -> RelationalChoice -> FunctionalChoice.
+intros Descr RelCh.
+red in |- *; intros A B R H.
+destruct (RelCh A B R H) as [R' H0].
+destruct (Descr A B R') as [f H1].
+intro x.
+elim (H0 x); intros y [H2 [H3 H4]]; exists y; split; [ exact H3 | exact H4 ].
+exists f; intro x.
+elim (H0 x); intros y [H2 [H3 H4]].
+rewrite <- (H4 (f x) (H1 x)).
+exact H2.
+Qed.
+
+Lemma funct_choice_imp_rel_choice : FunctionalChoice -> RelationalChoice.
+intros FunCh.
+red in |- *; intros A B R H.
+destruct (FunCh A B R H) as [f H0].
+exists (fun x y => y = f x).
+intro x; exists (f x); split;
+ [ apply H0
+ | split; [ reflexivity | intros y H1; symmetry  in |- *; exact H1 ] ].
+Qed.
+
+Lemma funct_choice_imp_description :
+ FunctionalChoice -> ParamDefiniteDescription.
+intros FunCh.
+red in |- *; intros A B R H.
+destruct (FunCh A B R) as [f H0].
+(* 1 *)
+intro x.
+elim (H x); intros y [H0 H1].
+exists y; exact H0.
+(* 2 *)
+exists f; exact H0.
+Qed.
+
+Theorem FunChoice_Equiv_RelChoice_and_ParamDefinDescr :
+ FunctionalChoice <-> RelationalChoice /\ ParamDefiniteDescription.
+split.
+intro H; split;
+ [ exact (funct_choice_imp_rel_choice H)
+ | exact (funct_choice_imp_description H) ].
+intros [H H0]; exact (description_rel_choice_imp_funct_choice H0 H).
+Qed.
+
+(* We show that the guarded relational formulation of the axiom of Choice
+   comes from the non guarded formulation in presence either of the
+   independance of premises or proof-irrelevance *)
+
+Definition GuardedRelationalChoice :=
+  forall (A B:Type) (P:A -> Prop) (R:A -> B -> Prop),
+    (forall x:A, P x ->  exists y : B, R x y) ->
+     exists R' : A -> B -> Prop,
+      (forall x:A,
+         P x ->
+          exists y : B, R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')).
+
+Definition ProofIrrelevance := forall (A:Prop) (a1 a2:A), a1 = a2.
+
+Lemma rel_choice_and_proof_irrel_imp_guarded_rel_choice :
+ RelationalChoice -> ProofIrrelevance -> GuardedRelationalChoice.
+Proof.
+intros rel_choice proof_irrel.
+red in |- *; intros A B P R H.
+destruct (rel_choice _ _ (fun (x:sigT P) (y:B) => R (projT1 x) y)) as [R' H0].
+intros [x HPx].
+destruct (H x HPx) as [y HRxy].
+exists y; exact HRxy.
+set (R'' := fun (x:A) (y:B) =>  exists H : P x, R' (existT P x H) y).
+exists R''; intros x HPx.
+destruct (H0 (existT P x HPx)) as [y [HRxy [HR'xy Huniq]]].
+exists y. split.
+  exact HRxy.
+  split.
+    red in |- *; exists HPx; exact HR'xy.
+    intros y' HR''xy'.
+      apply Huniq.
+      unfold R'' in HR''xy'.
+      destruct HR''xy' as [H'Px HR'xy'].
+      rewrite proof_irrel with (a1 := HPx) (a2 := H'Px).
+      exact HR'xy'.
+Qed.
+
+Definition IndependenceOfPremises :=
+  forall (A:Type) (P:A -> Prop) (Q:Prop),
+    (Q ->  exists x : _, P x) ->  exists x : _, Q -> P x.
+
+Lemma rel_choice_indep_of_premises_imp_guarded_rel_choice :
+ RelationalChoice -> IndependenceOfPremises -> GuardedRelationalChoice.
+Proof.
+intros RelCh IndPrem.
+red in |- *; intros A B P R H.
+destruct (RelCh A B (fun x y => P x -> R x y)) as [R' H0].
+  intro x. apply IndPrem.
+    apply H.
+  exists R'.
+  intros x HPx.
+    destruct (H0 x) as [y [H1 H2]].
+    exists y. split. 
+      apply (H1 HPx).
+      exact H2.
+Qed.
diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v
new file mode 100755
index 00000000..044cee17
--- /dev/null
+++ b/theories/Logic/Classical.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Classical.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Classical Logic *)
+
+Require Export Classical_Prop.
+Require Export Classical_Pred_Type.
\ No newline at end of file
diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v
new file mode 100644
index 00000000..51f758e2
--- /dev/null
+++ b/theories/Logic/ClassicalChoice.v
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: ClassicalChoice.v,v 1.4.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** This file provides classical logic and functional choice *)
+
+(** This file extends ClassicalDescription.v with the axiom of choice.
+    As ClassicalDescription.v, it implies the double-negation of
+    excluded-middle in Set and implies a strongly classical
+    world. Especially it conflicts with impredicativity of Set, knowing
+    that true<>false in Set.
+*)
+
+Require Export ClassicalDescription.
+Require Export RelationalChoice.
+Require Import ChoiceFacts.
+
+Theorem choice :
+ forall (A B:Type) (R:A -> B -> Prop),
+   (forall x:A,  exists y : B, R x y) ->
+    exists f : A -> B, (forall x:A, R x (f x)).
+Proof.
+apply description_rel_choice_imp_funct_choice.
+exact description.
+exact relational_choice.
+Qed.
\ No newline at end of file
diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v
new file mode 100644
index 00000000..6602cd73
--- /dev/null
+++ b/theories/Logic/ClassicalDescription.v
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: ClassicalDescription.v,v 1.7.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** This file provides classical logic and definite description *)
+
+(** Classical logic and definite description, as shown in [1],
+    implies the double-negation of excluded-middle in Set, hence it
+    implies a strongly classical world. Especially it conflicts with
+    impredicativity of Set, knowing that true<>false in Set.
+
+    [1] Laurent Chicli, Loïc Pottier, Carlos Simpson, Mathematical
+    Quotients and Quotient Types in Coq, Proceedings of TYPES 2002,
+    Lecture Notes in Computer Science 2646, Springer Verlag.
+*)
+
+Require Export Classical.
+
+Axiom
+  dependent_description :
+    forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop),
+      (forall x:A,
+          exists y : B x, R x y /\ (forall y':B x, R x y' -> y = y')) ->
+       exists f : forall x:A, B x, (forall x:A, R x (f x)).
+
+(** Principle of definite descriptions (aka axiom of unique choice) *)
+
+Theorem description :
+ forall (A B:Type) (R:A -> B -> Prop),
+   (forall x:A,  exists y : B, R x y /\ (forall y':B, R x y' -> y = y')) ->
+    exists f : A -> B, (forall x:A, R x (f x)).
+Proof.
+intros A B.
+apply (dependent_description A (fun _ => B)).
+Qed.
+
+(** The followig proof comes from [1] *)
+
+Theorem classic_set : ((forall P:Prop, {P} + {~ P}) -> False) -> False.
+Proof.
+intro HnotEM.
+set (R := fun A b => A /\ true = b \/ ~ A /\ false = b).
+assert (H :  exists f : Prop -> bool, (forall A:Prop, R A (f A))).
+apply description.
+intro A.
+destruct (classic A) as [Ha| Hnota].
+  exists true; split.
+    left; split; [ assumption | reflexivity ].
+    intros y [[_ Hy]| [Hna _]].
+      assumption.
+      contradiction.
+  exists false; split.
+    right; split; [ assumption | reflexivity ].
+    intros y [[Ha _]| [_ Hy]].
+      contradiction.
+      assumption.
+destruct H as [f Hf].
+apply HnotEM.
+intro P.
+assert (HfP := Hf P).
+(* Elimination from Hf to Set is not allowed but from f to Set yes ! *)
+destruct (f P).
+  left.
+  destruct HfP as [[Ha _]| [_ Hfalse]].
+    assumption.
+    discriminate.
+  right.
+  destruct HfP as [[_ Hfalse]| [Hna _]].
+    discriminate.
+    assumption.
+Qed.
+ 
diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v
new file mode 100644
index 00000000..cb14fb0e
--- /dev/null
+++ b/theories/Logic/ClassicalFacts.v
@@ -0,0 +1,219 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: ClassicalFacts.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Some facts and definitions about classical logic *)
+
+(** [prop_degeneracy] (also referred as propositional completeness) *)
+(*  asserts (up to consistency) that there are only two distinct formulas *)
+Definition prop_degeneracy := forall A:Prop, A = True \/ A = False.
+
+(** [prop_extensionality] asserts equivalent formulas are equal *)
+Definition prop_extensionality := forall A B:Prop, (A <-> B) -> A = B.
+
+(** [excluded_middle] asserts we can reason by case on the truth *)
+(*  or falsity of any formula *)
+Definition excluded_middle := forall A:Prop, A \/ ~ A.
+
+(** [proof_irrelevance] asserts equality of all proofs of a given formula *)
+Definition proof_irrelevance := forall (A:Prop) (a1 a2:A), a1 = a2.
+
+(** We show [prop_degeneracy <-> (prop_extensionality /\ excluded_middle)] *)
+
+Lemma prop_degen_ext : prop_degeneracy -> prop_extensionality.
+Proof.
+intros H A B [Hab Hba].
+destruct (H A); destruct (H B).
+  rewrite H1; exact H0.
+  absurd B.
+    rewrite H1; exact (fun H => H).
+    apply Hab; rewrite H0; exact I.
+  absurd A.
+    rewrite H0; exact (fun H => H).
+    apply Hba; rewrite H1; exact I.
+  rewrite H1; exact H0.
+Qed.
+
+Lemma prop_degen_em : prop_degeneracy -> excluded_middle.
+Proof.
+intros H A.
+destruct (H A).
+  left; rewrite H0; exact I.
+  right; rewrite H0; exact (fun x => x).
+Qed.
+
+Lemma prop_ext_em_degen :
+ prop_extensionality -> excluded_middle -> prop_degeneracy.
+Proof.
+intros Ext EM A.
+destruct (EM A).
+  left; apply (Ext A True); split;
+   [ exact (fun _ => I) | exact (fun _ => H) ].
+  right; apply (Ext A False); split; [ exact H | apply False_ind ].
+Qed.
+
+(** We successively show that:
+
+   [prop_extensionality]
+     implies equality of [A] and [A->A] for inhabited [A], which 
+     implies the existence of a (trivial) retract from [A->A] to [A]
+        (just take the identity), which
+     implies the existence of a fixpoint operator in [A]
+        (e.g. take the Y combinator of lambda-calculus)
+*)
+
+Definition inhabited (A:Prop) := A.
+
+Lemma prop_ext_A_eq_A_imp_A :
+ prop_extensionality -> forall A:Prop, inhabited A -> (A -> A) = A.
+Proof.
+intros Ext A a.
+apply (Ext (A -> A) A); split; [ exact (fun _ => a) | exact (fun _ _ => a) ].
+Qed.
+
+Record retract (A B:Prop) : Prop := 
+  {f1 : A -> B; f2 : B -> A; f1_o_f2 : forall x:B, f1 (f2 x) = x}.
+
+Lemma prop_ext_retract_A_A_imp_A :
+ prop_extensionality -> forall A:Prop, inhabited A -> retract A (A -> A).
+Proof.
+intros Ext A a.
+rewrite (prop_ext_A_eq_A_imp_A Ext A a).
+exists (fun x:A => x) (fun x:A => x).
+reflexivity.
+Qed.
+
+Record has_fixpoint (A:Prop) : Prop := 
+  {F : (A -> A) -> A; Fix : forall f:A -> A, F f = f (F f)}.
+
+Lemma ext_prop_fixpoint :
+ prop_extensionality -> forall A:Prop, inhabited A -> has_fixpoint A.
+Proof.
+intros Ext A a.
+case (prop_ext_retract_A_A_imp_A Ext A a); intros g1 g2 g1_o_g2.
+exists (fun f => (fun x:A => f (g1 x x)) (g2 (fun x => f (g1 x x)))).
+intro f.
+pattern (g1 (g2 (fun x:A => f (g1 x x)))) at 1 in |- *.
+rewrite (g1_o_g2 (fun x:A => f (g1 x x))).
+reflexivity.
+Qed.
+
+(** Assume we have booleans with the property that there is at most 2
+    booleans (which is equivalent to dependent case analysis). Consider
+    the fixpoint of the negation function: it is either true or false by
+    dependent case analysis, but also the opposite by fixpoint. Hence
+    proof-irrelevance.
+
+    We then map bool proof-irrelevance to all propositions.
+*)
+
+Section Proof_irrelevance_gen.
+
+Variable bool : Prop.
+Variable true : bool.
+Variable false : bool.
+Hypothesis bool_elim : forall C:Prop, C -> C -> bool -> C.
+Hypothesis
+  bool_elim_redl : forall (C:Prop) (c1 c2:C), c1 = bool_elim C c1 c2 true.
+Hypothesis
+  bool_elim_redr : forall (C:Prop) (c1 c2:C), c2 = bool_elim C c1 c2 false.
+Let bool_dep_induction :=
+  forall P:bool -> Prop, P true -> P false -> forall b:bool, P b.
+
+Lemma aux : prop_extensionality -> bool_dep_induction -> true = false.
+Proof.
+intros Ext Ind.
+case (ext_prop_fixpoint Ext bool true); intros G Gfix.
+set (neg := fun b:bool => bool_elim bool false true b).
+generalize (refl_equal (G neg)).
+pattern (G neg) at 1 in |- *.
+apply Ind with (b := G neg); intro Heq.
+rewrite (bool_elim_redl bool false true).
+change (true = neg true) in |- *; rewrite Heq; apply Gfix.
+rewrite (bool_elim_redr bool false true).
+change (neg false = false) in |- *; rewrite Heq; symmetry  in |- *;
+ apply Gfix.
+Qed.
+
+Lemma ext_prop_dep_proof_irrel_gen :
+ prop_extensionality -> bool_dep_induction -> proof_irrelevance.
+Proof.
+intros Ext Ind A a1 a2.
+set (f := fun b:bool => bool_elim A a1 a2 b).
+rewrite (bool_elim_redl A a1 a2).
+change (f true = a2) in |- *.
+rewrite (bool_elim_redr A a1 a2).
+change (f true = f false) in |- *.
+rewrite (aux Ext Ind).
+reflexivity.
+Qed.
+
+End Proof_irrelevance_gen.
+
+(** In the pure Calculus of Constructions, we can define the boolean
+    proposition bool = (C:Prop)C->C->C but we cannot prove that it has at
+    most 2 elements.
+*)
+
+Section Proof_irrelevance_CC.
+
+Definition BoolP := forall C:Prop, C -> C -> C.
+Definition TrueP : BoolP := fun C c1 c2 => c1.
+Definition FalseP : BoolP := fun C c1 c2 => c2.
+Definition BoolP_elim C c1 c2 (b:BoolP) := b C c1 c2.
+Definition BoolP_elim_redl (C:Prop) (c1 c2:C) :
+  c1 = BoolP_elim C c1 c2 TrueP := refl_equal c1.
+Definition BoolP_elim_redr (C:Prop) (c1 c2:C) :
+  c2 = BoolP_elim C c1 c2 FalseP := refl_equal c2.
+
+Definition BoolP_dep_induction :=
+  forall P:BoolP -> Prop, P TrueP -> P FalseP -> forall b:BoolP, P b.
+
+Lemma ext_prop_dep_proof_irrel_cc :
+ prop_extensionality -> BoolP_dep_induction -> proof_irrelevance.
+Proof
+  ext_prop_dep_proof_irrel_gen BoolP TrueP FalseP BoolP_elim BoolP_elim_redl
+    BoolP_elim_redr.
+
+End Proof_irrelevance_CC.
+
+(** In the Calculus of Inductive Constructions, inductively defined booleans
+    enjoy dependent case analysis, hence directly proof-irrelevance from
+    propositional extensionality.
+*)
+
+Section Proof_irrelevance_CIC.
+
+Inductive boolP : Prop :=
+  | trueP : boolP
+  | falseP : boolP.
+Definition boolP_elim_redl (C:Prop) (c1 c2:C) :
+  c1 = boolP_ind C c1 c2 trueP := refl_equal c1.
+Definition boolP_elim_redr (C:Prop) (c1 c2:C) :
+  c2 = boolP_ind C c1 c2 falseP := refl_equal c2.
+Scheme boolP_indd := Induction for boolP Sort Prop.
+
+Lemma ext_prop_dep_proof_irrel_cic : prop_extensionality -> proof_irrelevance.
+Proof
+  fun pe =>
+    ext_prop_dep_proof_irrel_gen boolP trueP falseP boolP_ind boolP_elim_redl
+      boolP_elim_redr pe boolP_indd.
+
+End Proof_irrelevance_CIC.
+
+(** Can we state proof irrelevance from propositional degeneracy
+  (i.e. propositional extensionality + excluded middle) without
+  dependent case analysis ?
+
+  Conjecture: it seems possible to build a model of CC interpreting
+  all non-empty types by the set of all lambda-terms. Such a model would
+  satisfy propositional degeneracy without satisfying proof-irrelevance
+  (nor dependent case analysis). This would imply that the previous
+  results cannot be refined.
+*)
diff --git a/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v
new file mode 100755
index 00000000..c8f87fe8
--- /dev/null
+++ b/theories/Logic/Classical_Pred_Set.v
@@ -0,0 +1,70 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Classical_Pred_Set.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Classical Predicate Logic on Set*)
+
+Require Import Classical_Prop.
+
+Section Generic.
+Variable U : Set.
+
+(** de Morgan laws for quantifiers *)
+
+Lemma not_all_ex_not :
+ forall P:U -> Prop, ~ (forall n:U, P n) ->  exists n : U, ~ P n.
+Proof.
+unfold not in |- *; intros P notall.
+apply NNPP; unfold not in |- *.
+intro abs.
+cut (forall n:U, P n); auto.
+intro n; apply NNPP.
+unfold not in |- *; intros.
+apply abs; exists n; trivial.
+Qed.
+
+Lemma not_all_not_ex :
+ forall P:U -> Prop, ~ (forall n:U, ~ P n) ->  exists n : U, P n.
+Proof.
+intros P H.
+elim (not_all_ex_not (fun n:U => ~ P n) H); intros n Pn; exists n.
+apply NNPP; trivial.
+Qed.
+
+Lemma not_ex_all_not :
+ forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n.
+Proof.
+unfold not in |- *; intros P notex n abs.
+apply notex.
+exists n; trivial.
+Qed. 
+
+Lemma not_ex_not_all :
+ forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n.
+Proof.
+intros P H n.
+apply NNPP.
+red in |- *; intro K; apply H; exists n; trivial.
+Qed.
+
+Lemma ex_not_not_all :
+ forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n).
+Proof.
+unfold not in |- *; intros P exnot allP.
+elim exnot; auto.
+Qed.
+
+Lemma all_not_not_ex :
+ forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n).
+Proof.
+unfold not in |- *; intros P allnot exP; elim exP; intros n p.
+apply allnot with n; auto.
+Qed.
+
+End Generic.
\ No newline at end of file
diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v
new file mode 100755
index 00000000..804ff32d
--- /dev/null
+++ b/theories/Logic/Classical_Pred_Type.v
@@ -0,0 +1,70 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Classical_Pred_Type.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Classical Predicate Logic on Type *)
+
+Require Import Classical_Prop.
+
+Section Generic.
+Variable U : Type.
+
+(** de Morgan laws for quantifiers *)
+
+Lemma not_all_ex_not :
+ forall P:U -> Prop, ~ (forall n:U, P n) ->  exists n : U, ~ P n.
+Proof.
+unfold not in |- *; intros P notall.
+apply NNPP; unfold not in |- *.
+intro abs.
+cut (forall n:U, P n); auto.
+intro n; apply NNPP.
+unfold not in |- *; intros.
+apply abs; exists n; trivial.
+Qed.
+
+Lemma not_all_not_ex :
+ forall P:U -> Prop, ~ (forall n:U, ~ P n) ->  exists n : U, P n.
+Proof.
+intros P H.
+elim (not_all_ex_not (fun n:U => ~ P n) H); intros n Pn; exists n.
+apply NNPP; trivial.
+Qed.
+
+Lemma not_ex_all_not :
+ forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n.
+Proof.
+unfold not in |- *; intros P notex n abs.
+apply notex.
+exists n; trivial.
+Qed. 
+
+Lemma not_ex_not_all :
+ forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n.
+Proof.
+intros P H n.
+apply NNPP.
+red in |- *; intro K; apply H; exists n; trivial.
+Qed.
+
+Lemma ex_not_not_all :
+ forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n).
+Proof.
+unfold not in |- *; intros P exnot allP.
+elim exnot; auto.
+Qed.
+
+Lemma all_not_not_ex :
+ forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n).
+Proof.
+unfold not in |- *; intros P allnot exP; elim exP; intros n p.
+apply allnot with n; auto.
+Qed.
+
+End Generic.
\ No newline at end of file
diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v
new file mode 100755
index 00000000..ccc26df1
--- /dev/null
+++ b/theories/Logic/Classical_Prop.v
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Classical_Prop.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Classical Propositional Logic *)
+
+Require Import ProofIrrelevance.
+
+Hint Unfold not: core.
+
+Axiom classic : forall P:Prop, P \/ ~ P.
+
+Lemma NNPP : forall p:Prop, ~ ~ p -> p.
+Proof.
+unfold not in |- *; intros; elim (classic p); auto.
+intro NP; elim (H NP).
+Qed.
+
+Lemma not_imply_elim : forall P Q:Prop, ~ (P -> Q) -> P.
+Proof.
+intros; apply NNPP; red in |- *.
+intro; apply H; intro; absurd P; trivial.
+Qed.
+
+Lemma not_imply_elim2 : forall P Q:Prop, ~ (P -> Q) -> ~ Q.
+Proof.
+intros; elim (classic Q); auto.
+Qed.
+
+Lemma imply_to_or : forall P Q:Prop, (P -> Q) -> ~ P \/ Q.
+Proof.
+intros; elim (classic P); auto.
+Qed.
+
+Lemma imply_to_and : forall P Q:Prop, ~ (P -> Q) -> P /\ ~ Q.
+Proof.
+intros; split.
+apply not_imply_elim with Q; trivial.
+apply not_imply_elim2 with P; trivial.
+Qed.
+
+Lemma or_to_imply : forall P Q:Prop, ~ P \/ Q -> P -> Q.
+Proof.
+simple induction 1; auto.
+intros H1 H2; elim (H1 H2).
+Qed.
+
+Lemma not_and_or : forall P Q:Prop, ~ (P /\ Q) -> ~ P \/ ~ Q.
+Proof.
+intros; elim (classic P); auto.
+Qed.
+
+Lemma or_not_and : forall P Q:Prop, ~ P \/ ~ Q -> ~ (P /\ Q).
+Proof.
+simple induction 1; red in |- *; simple induction 2; auto.
+Qed.
+
+Lemma not_or_and : forall P Q:Prop, ~ (P \/ Q) -> ~ P /\ ~ Q.
+Proof.
+intros; elim (classic P); auto.
+Qed.
+
+Lemma and_not_or : forall P Q:Prop, ~ P /\ ~ Q -> ~ (P \/ Q).
+Proof.
+simple induction 1; red in |- *; simple induction 3; trivial.
+Qed.
+
+Lemma imply_and_or : forall P Q:Prop, (P -> Q) -> P \/ Q -> Q.
+Proof.
+simple induction 2; trivial.
+Qed.
+
+Lemma imply_and_or2 : forall P Q R:Prop, (P -> Q) -> P \/ R -> Q \/ R.
+Proof.
+simple induction 2; auto.
+Qed.
+
+Lemma proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.
+Proof proof_irrelevance_cci classic.
\ No newline at end of file
diff --git a/theories/Logic/Classical_Type.v b/theories/Logic/Classical_Type.v
new file mode 100755
index 00000000..753b8590
--- /dev/null
+++ b/theories/Logic/Classical_Type.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Classical_Type.v,v 1.5.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Classical Logic for Type *)
+
+Require Export Classical_Prop.
+Require Export Classical_Pred_Type.
\ No newline at end of file
diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v
new file mode 100644
index 00000000..08babda9
--- /dev/null
+++ b/theories/Logic/Decidable.v
@@ -0,0 +1,60 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i 	$Id: Decidable.v,v 1.5.2.1 2004/07/16 19:31:06 herbelin Exp $	 i*)
+
+(** Properties of decidable propositions *)
+
+Definition decidable (P:Prop) := P \/ ~ P.
+
+Theorem dec_not_not : forall P:Prop, decidable P -> (~ P -> False) -> P.
+unfold decidable in |- *; tauto. 
+Qed.
+
+Theorem dec_True : decidable True.
+unfold decidable in |- *; auto.
+Qed.
+
+Theorem dec_False : decidable False.
+unfold decidable, not in |- *; auto.
+Qed.
+
+Theorem dec_or :
+ forall A B:Prop, decidable A -> decidable B -> decidable (A \/ B).
+unfold decidable in |- *; tauto. 
+Qed.
+
+Theorem dec_and :
+ forall A B:Prop, decidable A -> decidable B -> decidable (A /\ B).
+unfold decidable in |- *; tauto. 
+Qed.
+
+Theorem dec_not : forall A:Prop, decidable A -> decidable (~ A).
+unfold decidable in |- *; tauto. 
+Qed.
+
+Theorem dec_imp :
+ forall A B:Prop, decidable A -> decidable B -> decidable (A -> B).
+unfold decidable in |- *; tauto. 
+Qed.
+
+Theorem not_not : forall P:Prop, decidable P -> ~ ~ P -> P.
+unfold decidable in |- *; tauto. Qed.
+
+Theorem not_or : forall A B:Prop, ~ (A \/ B) -> ~ A /\ ~ B.
+tauto. Qed.
+
+Theorem not_and : forall A B:Prop, decidable A -> ~ (A /\ B) -> ~ A \/ ~ B.
+unfold decidable in |- *; tauto. Qed.
+
+Theorem not_imp : forall A B:Prop, decidable A -> ~ (A -> B) -> A /\ ~ B.
+unfold decidable in |- *; tauto.
+Qed.
+
+Theorem imp_simp : forall A B:Prop, decidable A -> (A -> B) -> ~ A \/ B.
+unfold decidable in |- *; tauto.
+Qed.
diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v
new file mode 100644
index 00000000..55eed096
--- /dev/null
+++ b/theories/Logic/Diaconescu.v
@@ -0,0 +1,138 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Diaconescu.v,v 1.5.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(* R. Diaconescu [Diaconescu] showed that the Axiom of Choice in Set Theory
+   entails Excluded-Middle; S. Lacas and B. Werner [LacasWerner]
+   adapted the proof to show that the axiom of choice in equivalence
+   classes entails Excluded-Middle in Type Theory.
+
+   This is an adaptatation of the proof by Hugo Herbelin to show that
+   the relational form of the Axiom of Choice + Extensionality for
+   predicates entails Excluded-Middle
+
+   [Diaconescu] R. Diaconescu, Axiom of Choice and Complementation, in
+   Proceedings of AMS, vol 51, pp 176-178, 1975.
+
+   [LacasWerner] S. Lacas, B Werner, Which Choices imply the excluded middle?,
+   preprint, 1999.
+
+*)
+
+Section PredExt_GuardRelChoice_imp_EM.
+
+(* The axiom of extensionality for predicates *)
+
+Definition PredicateExtensionality :=
+  forall P Q:bool -> Prop, (forall b:bool, P b <-> Q b) -> P = Q.
+
+(* From predicate extensionality we get propositional extensionality
+   hence proof-irrelevance *)
+
+Require Import ClassicalFacts.
+
+Variable pred_extensionality : PredicateExtensionality.
+  
+Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B.
+Proof.
+  intros A B H.
+  change ((fun _ => A) true = (fun _ => B) true) in |- *.
+  rewrite
+   pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B).
+    reflexivity.
+    intros _; exact H.
+Qed.
+
+Lemma proof_irrel : forall (A:Prop) (a1 a2:A), a1 = a2.
+Proof.
+  apply (ext_prop_dep_proof_irrel_cic prop_ext).
+Qed.
+
+(* From proof-irrelevance and relational choice, we get guarded
+   relational choice *)
+
+Require Import ChoiceFacts.
+
+Variable rel_choice : RelationalChoice.
+
+Lemma guarded_rel_choice :
+ forall (A B:Type) (P:A -> Prop) (R:A -> B -> Prop),
+   (forall x:A, P x ->  exists y : B, R x y) ->
+    exists R' : A -> B -> Prop,
+     (forall x:A,
+        P x ->
+         exists y : B, R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')).
+Proof.
+  exact
+   (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel).
+Qed.
+
+(* The form of choice we need: there is a functional relation which chooses
+   an element in any non empty subset of bool *)
+
+Require Import Bool.
+
+Lemma AC :
+  exists R : (bool -> Prop) -> bool -> Prop,
+   (forall P:bool -> Prop,
+      (exists b : bool, P b) ->
+       exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')).
+Proof.
+  apply guarded_rel_choice with
+   (P := fun Q:bool -> Prop =>  exists y : _, Q y)
+   (R := fun (Q:bool -> Prop) (y:bool) => Q y).
+  exact (fun _ H => H).
+Qed.
+
+(* The proof of the excluded middle *)
+(* Remark: P could have been in Set or Type *)
+
+Theorem pred_ext_and_rel_choice_imp_EM : forall P:Prop, P \/ ~ P.
+Proof.
+intro P.
+
+(* first we exhibit the choice functional relation R *)
+destruct AC as [R H].
+
+set (class_of_true := fun b => b = true \/ P).
+set (class_of_false := fun b => b = false \/ P).
+
+(* the actual "decision": is (R class_of_true) = true or false? *)
+destruct (H class_of_true) as [b0 [H0 [H0' H0'']]].
+exists true; left; reflexivity.
+destruct H0.
+
+(* the actual "decision": is (R class_of_false) = true or false? *)
+destruct (H class_of_false) as [b1 [H1 [H1' H1'']]].
+exists false; left; reflexivity.
+destruct H1.
+
+(* case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *)
+right.
+intro HP.
+assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b).
+intro b; split.
+unfold class_of_false in |- *; right; assumption.
+unfold class_of_true in |- *; right; assumption.
+assert (Heq : class_of_true = class_of_false).
+apply pred_extensionality with (1 := Hequiv).
+apply diff_true_false.
+rewrite <- H0.
+rewrite <- H1.
+rewrite <- H0''. reflexivity.
+rewrite Heq.
+assumption.
+
+(* cases where P is true *)
+left; assumption.
+left; assumption.
+
+Qed.
+
+End PredExt_GuardRelChoice_imp_EM.
diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v
new file mode 100755
index 00000000..24905039
--- /dev/null
+++ b/theories/Logic/Eqdep.v
@@ -0,0 +1,188 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Eqdep.v,v 1.10.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** This file defines dependent equality and shows its equivalence with
+    equality on dependent pairs (inhabiting sigma-types). It axiomatizes
+    the invariance by substitution of reflexive equality proofs and 
+    shows the equivalence between the 4 following statements
+
+    - Invariance by Substitution of Reflexive Equality Proofs.
+    - Injectivity of Dependent Equality
+    - Uniqueness of Identity Proofs
+    - Uniqueness of Reflexive Identity Proofs
+    - Streicher's Axiom K
+
+  These statements are independent of the calculus of constructions [2].
+
+  References:
+
+  [1] T. Streicher, Semantical Investigations into Intensional Type Theory,
+      Habilitationsschrift, LMU München, 1993.
+  [2] M. Hofmann, T. Streicher, The groupoid interpretation of type theory,
+      Proceedings of the meeting Twenty-five years of constructive
+      type theory, Venice, Oxford University Press, 1998
+*)
+
+Section Dependent_Equality.
+
+Variable U : Type.
+Variable P : U -> Type.
+
+(** Dependent equality *)
+
+Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop :=
+    eq_dep_intro : eq_dep p x p x.
+Hint Constructors eq_dep: core v62.
+
+Lemma eq_dep_sym :
+ forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep q y p x.
+Proof.
+destruct 1; auto.
+Qed.
+Hint Immediate eq_dep_sym: core v62.
+
+Lemma eq_dep_trans :
+ forall (p q r:U) (x:P p) (y:P q) (z:P r),
+   eq_dep p x q y -> eq_dep q y r z -> eq_dep p x r z.
+Proof.
+destruct 1; auto.
+Qed.
+
+Scheme eq_indd := Induction for eq Sort Prop.
+
+Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop :=
+    eq_dep1_intro : forall h:q = p, x = eq_rect q P y p h -> eq_dep1 p x q y.
+
+Lemma eq_dep1_dep :
+ forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y.
+Proof.
+destruct 1 as (eq_qp, H).
+destruct eq_qp using eq_indd.
+rewrite H.
+apply eq_dep_intro.
+Qed.
+
+Lemma eq_dep_dep1 :
+ forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y.
+Proof.
+destruct 1.
+apply eq_dep1_intro with (refl_equal p).
+simpl in |- *; trivial.
+Qed.
+
+(** Invariance by Substitution of Reflexive Equality Proofs *)
+
+Axiom eq_rect_eq :
+    forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
+
+(** Injectivity of Dependent Equality is a consequence of *)
+(** Invariance by Substitution of Reflexive Equality Proof *)
+
+Lemma eq_dep1_eq : forall (p:U) (x y:P p), eq_dep1 p x p y -> x = y.
+Proof.
+simple destruct 1; intro.
+rewrite <- eq_rect_eq; auto.
+Qed.
+
+Lemma eq_dep_eq : forall (p:U) (x y:P p), eq_dep p x p y -> x = y.
+Proof.
+intros; apply eq_dep1_eq; apply eq_dep_dep1; trivial.
+Qed.
+
+End Dependent_Equality.
+
+(** Uniqueness of Identity Proofs (UIP) is a consequence of *)
+(** Injectivity of Dependent Equality *)
+
+Lemma UIP : forall (U:Type) (x y:U) (p1 p2:x = y), p1 = p2.
+Proof.
+intros; apply eq_dep_eq with (P := fun y => x = y).
+elim p2 using eq_indd.
+elim p1 using eq_indd.
+apply eq_dep_intro.
+Qed.
+
+(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)
+
+Lemma UIP_refl : forall (U:Type) (x:U) (p:x = x), p = refl_equal x.
+Proof.
+intros; apply UIP.
+Qed.
+
+(** Streicher axiom K is a direct consequence of Uniqueness of
+    Reflexive Identity Proofs *)
+
+Lemma Streicher_K :
+ forall (U:Type) (x:U) (P:x = x -> Prop),
+   P (refl_equal x) -> forall p:x = x, P p.
+Proof.
+intros; rewrite UIP_refl; assumption.
+Qed.
+
+(** We finally recover eq_rec_eq (alternatively eq_rect_eq) from K *)
+
+Lemma eq_rec_eq :
+ forall (U:Type) (P:U -> Set) (p:U) (x:P p) (h:p = p), x = eq_rec p P x p h.
+Proof.
+intros.
+apply Streicher_K with (p := h).
+reflexivity.
+Qed.
+
+(** Dependent equality is equivalent to equality on dependent pairs *)
+
+Lemma equiv_eqex_eqdep :
+ forall (U:Set) (P:U -> Set) (p q:U) (x:P p) (y:P q),
+   existS P p x = existS P q y <-> eq_dep U P p x q y.
+Proof.
+split. 
+(* -> *)
+intro H.
+change p with (projS1 (existS P p x)) in |- *.
+change x at 2 with (projS2 (existS P p x)) in |- *.
+rewrite H.
+apply eq_dep_intro.
+(* <- *)
+destruct 1; reflexivity.
+Qed.
+
+(** UIP implies the injectivity of equality on dependent pairs *)
+
+Lemma inj_pair2 :
+ forall (U:Set) (P:U -> Set) (p:U) (x y:P p),
+   existS P p x = existS P p y -> x = y.
+Proof.
+intros.
+apply (eq_dep_eq U P).
+generalize (equiv_eqex_eqdep U P p p x y).
+simple induction 1.
+intros.
+auto.
+Qed.
+
+(** UIP implies the injectivity of equality on dependent pairs *)
+
+Lemma inj_pairT2 :
+ forall (U:Type) (P:U -> Type) (p:U) (x y:P p),
+   existT P p x = existT P p y -> x = y.
+Proof.
+intros.
+apply (eq_dep_eq U P).
+change p at 1 with (projT1 (existT P p x)) in |- *.
+change x at 2 with (projT2 (existT P p x)) in |- *.
+rewrite H.
+apply eq_dep_intro.
+Qed.
+
+(** The main results to be exported *)
+
+Hint Resolve eq_dep_intro eq_dep_eq: core v62.
+Hint Immediate eq_dep_sym: core v62.
+Hint Resolve inj_pair2 inj_pairT2: core.
diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v
new file mode 100644
index 00000000..7caf403c
--- /dev/null
+++ b/theories/Logic/Eqdep_dec.v
@@ -0,0 +1,158 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Eqdep_dec.v,v 1.14.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** We prove that there is only one proof of [x=x], i.e [(refl_equal ? x)].
+   This holds if the equality upon the set of [x] is decidable.
+   A corollary of this theorem is the equality of the right projections
+   of two equal dependent pairs.
+
+   Author:   Thomas Kleymann |<tms@dcs.ed.ac.uk>| in Lego
+             adapted to Coq by B. Barras
+
+   Credit:   Proofs up to [K_dec] follows an outline by Michael Hedberg
+*)
+
+
+(** We need some dependent elimination schemes *)
+
+Set Implicit Arguments.
+
+  (** Bijection between [eq] and [eqT] *)
+  Definition eq2eqT (A:Set) (x y:A) (eqxy:x = y) : 
+    x = y :=
+    match eqxy in (_ = y) return x = y with
+    | refl_equal => refl_equal x
+    end.
+
+  Definition eqT2eq (A:Set) (x y:A) (eqTxy:x = y) : 
+    x = y :=
+    match eqTxy in (_ = y) return x = y with
+    | refl_equal => refl_equal x
+    end.
+
+  Lemma eq_eqT_bij : forall (A:Set) (x y:A) (p:x = y), p = eqT2eq (eq2eqT p).
+intros.
+case p; reflexivity.
+Qed.
+
+  Lemma eqT_eq_bij : forall (A:Set) (x y:A) (p:x = y), p = eq2eqT (eqT2eq p).
+intros.
+case p; reflexivity.
+Qed.
+
+
+Section DecidableEqDep.
+
+  Variable A : Type.
+
+  Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' :=
+    eq_ind _ (fun a => a = y') eq2 _ eq1.
+
+  Remark trans_sym_eqT : forall (x y:A) (u:x = y), comp u u = refl_equal y.
+intros.
+case u; trivial.
+Qed.
+
+
+
+  Variable eq_dec : forall x y:A, x = y \/ x <> y.
+
+  Variable x : A.
+
+
+  Let nu (y:A) (u:x = y) : x = y :=
+    match eq_dec x y with
+    | or_introl eqxy => eqxy
+    | or_intror neqxy => False_ind _ (neqxy u)
+    end.
+
+  Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v.
+intros.
+unfold nu in |- *.
+case (eq_dec x y); intros.
+reflexivity.
+
+case n; trivial.
+Qed.
+
+
+  Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (refl_equal x)) v.
+
+
+  Remark nu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u.
+intros.
+case u; unfold nu_inv in |- *.
+apply trans_sym_eqT.
+Qed.
+
+
+  Theorem eq_proofs_unicity : forall (y:A) (p1 p2:x = y), p1 = p2.
+intros.
+elim nu_left_inv with (u := p1).
+elim nu_left_inv with (u := p2).
+elim nu_constant with y p1 p2.
+reflexivity.
+Qed.
+
+  Theorem K_dec :
+   forall P:x = x -> Prop, P (refl_equal x) -> forall p:x = x, P p.
+intros.
+elim eq_proofs_unicity with x (refl_equal x) p.
+trivial.
+Qed.
+
+
+  (** The corollary *)
+
+  Let proj (P:A -> Prop) (exP:ex P) (def:P x) : P x :=
+    match exP with
+    | ex_intro x' prf =>
+        match eq_dec x' x with
+        | or_introl eqprf => eq_ind x' P prf x eqprf
+        | _ => def
+        end
+    end.
+
+
+  Theorem inj_right_pair :
+   forall (P:A -> Prop) (y y':P x),
+     ex_intro P x y = ex_intro P x y' -> y = y'.
+intros.
+cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y).
+simpl in |- *.
+case (eq_dec x x).
+intro e.
+elim e using K_dec; trivial.
+
+intros.
+case n; trivial.
+
+case H.
+reflexivity.
+Qed.
+
+End DecidableEqDep.
+
+  (** We deduce the [K] axiom for (decidable) Set *)
+  Theorem K_dec_set :
+   forall A:Set,
+     (forall x y:A, {x = y} + {x <> y}) ->
+     forall (x:A) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+intros.
+rewrite eq_eqT_bij.
+elim (eq2eqT p) using K_dec.
+intros.
+case (H x0 y); intros.
+elim e; left; reflexivity.
+
+right; red in |- *; intro neq; apply n; elim neq; reflexivity.
+
+trivial.
+Qed.
\ No newline at end of file
diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v
new file mode 100644
index 00000000..46a57432
--- /dev/null
+++ b/theories/Logic/Hurkens.v
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                              Hurkens.v                               *)
+(************************************************************************)
+
+(** This is Hurkens paradox [Hurkens] in system U-, adapted by Herman
+    Geuvers [Geuvers] to show the inconsistency in the pure calculus of
+    constructions of a retract from Prop into a small type.
+
+    References:
+
+    - [Hurkens] A. J. Hurkens, "A simplification of Girard's paradox",
+      Proceedings of the 2nd international conference Typed Lambda-Calculi
+      and Applications (TLCA'95), 1995.
+
+    - [Geuvers] "Inconsistency of Classical Logic in Type Theory", 2001
+      (see www.cs.kun.nl/~herman/note.ps.gz).
+*)
+
+Section Paradox.
+
+Variable bool : Prop.
+Variable p2b : Prop -> bool.
+Variable b2p : bool -> Prop.
+Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A.
+Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A).
+Variable B : Prop.
+
+Definition V := forall A:Prop, ((A -> bool) -> A -> bool) -> A -> bool.
+Definition U := V -> bool.
+Definition sb (z:V) : V := fun A r a => r (z A r) a.
+Definition le (i:U -> bool) (x:U) : bool :=
+  x (fun A r a => i (fun v => sb v A r a)).
+Definition induct (i:U -> bool) : Prop :=
+  forall x:U, b2p (le i x) -> b2p (i x).
+Definition WF : U := fun z => p2b (induct (z U le)).
+Definition I (x:U) : Prop :=
+  (forall i:U -> bool, b2p (le i x) -> b2p (i (fun v => sb v U le x))) -> B.
+
+Lemma Omega : forall i:U -> bool, induct i -> b2p (i WF).
+Proof.
+intros i y.
+apply y.
+unfold le, WF, induct in |- *.
+apply p2p2.
+intros x H0.
+apply y.
+exact H0.
+Qed.
+
+Lemma lemma1 : induct (fun u => p2b (I u)).
+Proof.
+unfold induct in |- *.
+intros x p.
+apply (p2p2 (I x)).
+intro q.
+apply (p2p1 (I (fun v:V => sb v U le x)) (q (fun u => p2b (I u)) p)).
+intro i.
+apply q with (i := fun y => i (fun v:V => sb v U le y)).
+Qed.
+
+Lemma lemma2 : (forall i:U -> bool, induct i -> b2p (i WF)) -> B.
+Proof.
+intro x.
+apply (p2p1 (I WF) (x (fun u => p2b (I u)) lemma1)).
+intros i H0.
+apply (x (fun y => i (fun v => sb v U le y))).
+apply (p2p1 _ H0).
+Qed.
+
+Theorem paradox : B.
+Proof.
+exact (lemma2 Omega).
+Qed.
+
+End Paradox.
diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v
new file mode 100644
index 00000000..5b7528be
--- /dev/null
+++ b/theories/Logic/JMeq.v
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: JMeq.v,v 1.8.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** John Major's Equality as proposed by C. Mc Bride *)
+
+Set Implicit Arguments.
+
+Inductive JMeq (A:Set) (x:A) : forall B:Set, B -> Prop :=
+    JMeq_refl : JMeq x x.
+Reset JMeq_ind.
+
+Hint Resolve JMeq_refl.
+
+Lemma sym_JMeq : forall (A B:Set) (x:A) (y:B), JMeq x y -> JMeq y x.
+destruct 1; trivial.
+Qed.
+
+Hint Immediate sym_JMeq.
+
+Lemma trans_JMeq :
+ forall (A B C:Set) (x:A) (y:B) (z:C), JMeq x y -> JMeq y z -> JMeq x z.
+destruct 1; trivial.
+Qed.
+
+Axiom JMeq_eq : forall (A:Set) (x y:A), JMeq x y -> x = y.
+
+Lemma JMeq_ind : forall (A:Set) (x y:A) (P:A -> Prop), P x -> JMeq x y -> P y.
+intros A x y P H H'; case JMeq_eq with (1 := H'); trivial.
+Qed.
+
+Lemma JMeq_rec : forall (A:Set) (x y:A) (P:A -> Set), P x -> JMeq x y -> P y.
+intros A x y P H H'; case JMeq_eq with (1 := H'); trivial.
+Qed.
+
+Lemma JMeq_ind_r :
+ forall (A:Set) (x y:A) (P:A -> Prop), P y -> JMeq x y -> P x.
+intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial.
+Qed.
+
+Lemma JMeq_rec_r :
+ forall (A:Set) (x y:A) (P:A -> Set), P y -> JMeq x y -> P x.
+intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial.
+Qed.
+
+(** [JMeq] is equivalent to [(eq_dep Set [X]X)] *)
+
+Require Import Eqdep.
+
+Lemma JMeq_eq_dep :
+ forall (A B:Set) (x:A) (y:B), JMeq x y -> eq_dep Set (fun X => X) A x B y.
+Proof.
+destruct 1.
+apply eq_dep_intro.
+Qed.
+
+Lemma eq_dep_JMeq :
+ forall (A B:Set) (x:A) (y:B), eq_dep Set (fun X => X) A x B y -> JMeq x y.
+Proof.
+destruct 1.
+apply JMeq_refl. 
+Qed.
\ No newline at end of file
diff --git a/theories/Logic/ProofIrrelevance.v b/theories/Logic/ProofIrrelevance.v
new file mode 100644
index 00000000..afdc0ffe
--- /dev/null
+++ b/theories/Logic/ProofIrrelevance.v
@@ -0,0 +1,114 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This is a proof in the pure Calculus of Construction that
+    classical logic in Prop + dependent elimination of disjunction entails
+    proof-irrelevance.
+
+    Since, dependent elimination is derivable in the Calculus of
+    Inductive Constructions (CCI), we get proof-irrelevance from classical
+    logic in the CCI.
+
+    Reference:
+
+    - [Coquand] T. Coquand, "Metamathematical Investigations of a
+      Calculus of Constructions", Proceedings of Logic in Computer Science
+      (LICS'90), 1990.
+
+    Proof skeleton: classical logic + dependent elimination of
+    disjunction + discrimination of proofs implies the existence of a
+    retract from [Prop] into [bool], hence inconsistency by encoding any
+    paradox of system U- (e.g. Hurkens' paradox).
+*)
+
+Require Import Hurkens.
+
+Section Proof_irrelevance_CC.
+
+Variable or : Prop -> Prop -> Prop.
+Variable or_introl : forall A B:Prop, A -> or A B.
+Variable or_intror : forall A B:Prop, B -> or A B.
+Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C.
+Hypothesis
+  or_elim_redl :
+    forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A),
+      f a = or_elim A B C f g (or_introl A B a).
+Hypothesis
+  or_elim_redr :
+    forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B),
+      g b = or_elim A B C f g (or_intror A B b).
+Hypothesis
+  or_dep_elim :
+    forall (A B:Prop) (P:or A B -> Prop),
+      (forall a:A, P (or_introl A B a)) ->
+      (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b.
+
+Hypothesis em : forall A:Prop, or A (~ A).
+Variable B : Prop.
+Variables b1 b2 : B.
+
+(** [p2b] and [b2p] form a retract if [~b1=b2] *)
+
+Definition p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A).
+Definition b2p b := b1 = b.
+
+Lemma p2p1 : forall A:Prop, A -> b2p (p2b A).
+Proof.
+  unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A);
+   unfold b2p in |- *; intros.
+  apply (or_elim_redl A (~ A) B (fun _ => b1) (fun _ => b2)).
+  destruct (b H).
+Qed.
+Lemma p2p2 : b1 <> b2 -> forall A:Prop, b2p (p2b A) -> A.
+Proof.
+  intro not_eq_b1_b2.
+  unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A);
+   unfold b2p in |- *; intros.
+  assumption.
+  destruct not_eq_b1_b2.
+  rewrite <- (or_elim_redr A (~ A) B (fun _ => b1) (fun _ => b2)) in H.
+  assumption.
+Qed.
+
+(** Using excluded-middle a second time, we get proof-irrelevance *)
+
+Theorem proof_irrelevance_cc : b1 = b2.
+Proof.
+  refine (or_elim _ _ _ _ _ (em (b1 = b2))); intro H.
+    trivial.
+  apply (paradox B p2b b2p (p2p2 H) p2p1).
+Qed.
+
+End Proof_irrelevance_CC.
+
+
+(** The Calculus of Inductive Constructions (CCI) enjoys dependent
+    elimination, hence classical logic in CCI entails proof-irrelevance.
+*)
+
+Section Proof_irrelevance_CCI.
+
+Hypothesis em : forall A:Prop, A \/ ~ A.
+
+Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C) 
+  (a:A) : f a = or_ind f g (or_introl B a) := refl_equal (f a).
+Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C) 
+  (b:B) : g b = or_ind f g (or_intror A b) := refl_equal (g b).
+Scheme or_indd := Induction for or Sort Prop.
+
+Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2.
+Proof
+  proof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl
+    or_elim_redr or_indd em.
+
+End Proof_irrelevance_CCI.
+
+(** Remark: in CCI, [bool] can be taken in [Set] as well in the
+    paradox and since [~true=false] for [true] and [false] in
+    [bool], we get the inconsistency of [em : forall A:Prop, {A}+{~A}] in CCI
+*)
diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v
new file mode 100644
index 00000000..ca7b760e
--- /dev/null
+++ b/theories/Logic/RelationalChoice.v
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: RelationalChoice.v,v 1.3.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(* This file axiomatizes the relational form of the axiom of choice *)
+
+Axiom
+  relational_choice :
+    forall (A B:Type) (R:A -> B -> Prop),
+      (forall x:A,  exists y : B, R x y) ->
+       exists R' : A -> B -> Prop,
+        (forall x:A,
+            exists y : B,
+             R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')).
diff --git a/theories/Logic/intro.tex b/theories/Logic/intro.tex
new file mode 100755
index 00000000..1fb294f2
--- /dev/null
+++ b/theories/Logic/intro.tex
@@ -0,0 +1,8 @@
+\section{Logic}\label{Logic}
+
+This library deals with classical logic and its properties.
+The main file is {\tt Classical.v}.
+
+This library also provides some facts on equalities for dependent
+types. See the files {\tt Eqdep.v} and {\tt JMeq.v}.
+
diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v
new file mode 100644
index 00000000..e6a14938
--- /dev/null
+++ b/theories/NArith/BinNat.v
@@ -0,0 +1,212 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: BinNat.v,v 1.7.2.1 2004/07/16 19:31:07 herbelin Exp $ i*)
+
+Require Import BinPos.
+
+(**********************************************************************)
+(** Binary natural numbers *)
+
+Inductive N : Set :=
+  | N0 : N
+  | Npos : positive -> N.
+
+(** Declare binding key for scope positive_scope *)
+
+Delimit Scope N_scope with N.
+
+(** Automatically open scope N_scope for the constructors of N *)
+
+Bind Scope N_scope with N.
+Arguments Scope Npos [N_scope].
+
+Open Local Scope N_scope.
+
+(** Operation x -> 2*x+1 *)
+
+Definition Ndouble_plus_one x :=
+  match x with
+  | N0 => Npos 1%positive
+  | Npos p => Npos (xI p)
+  end.
+
+(** Operation x -> 2*x *)
+
+Definition Ndouble n := match n with
+                        | N0 => N0
+                        | Npos p => Npos (xO p)
+                        end.
+
+(** Successor *)
+
+Definition Nsucc n :=
+  match n with
+  | N0 => Npos 1%positive
+  | Npos p => Npos (Psucc p)
+  end.
+
+(** Addition *)
+
+Definition Nplus n m :=
+  match n, m with
+  | N0, _ => m
+  | _, N0 => n
+  | Npos p, Npos q => Npos (p + q)%positive
+  end.
+
+Infix "+" := Nplus : N_scope.
+
+(** Multiplication *)
+
+Definition Nmult n m :=
+  match n, m with
+  | N0, _ => N0
+  | _, N0 => N0
+  | Npos p, Npos q => Npos (p * q)%positive
+  end.
+
+Infix "*" := Nmult : N_scope.
+
+(** Order *)
+
+Definition Ncompare n m :=
+  match n, m with
+  | N0, N0 => Eq
+  | N0, Npos m' => Lt
+  | Npos n', N0 => Gt
+  | Npos n', Npos m' => (n' ?= m')%positive Eq
+  end.
+
+Infix "?=" := Ncompare (at level 70, no associativity) : N_scope.
+
+(** Peano induction on binary natural numbers *)
+
+Theorem Nind :
+ forall P:N -> Prop,
+   P N0 -> (forall n:N, P n -> P (Nsucc n)) -> forall n:N, P n.
+Proof.
+destruct n.
+  assumption.
+  apply Pind with (P := fun p => P (Npos p)).
+exact (H0 N0 H).
+intro p'; exact (H0 (Npos p')).
+Qed.
+
+(** Properties of addition *)
+
+Theorem Nplus_0_l : forall n:N, N0 + n = n.
+Proof.
+reflexivity.
+Qed.
+
+Theorem Nplus_0_r : forall n:N, n + N0 = n.
+Proof.
+destruct n; reflexivity.
+Qed.
+
+Theorem Nplus_comm : forall n m:N, n + m = m + n.
+Proof.
+intros.
+destruct n; destruct m; simpl in |- *; try reflexivity.
+rewrite Pplus_comm; reflexivity.
+Qed.
+
+Theorem Nplus_assoc : forall n m p:N, n + (m + p) = n + m + p.
+Proof.
+intros.
+destruct n; try reflexivity.
+destruct m; try reflexivity.
+destruct p; try reflexivity.
+simpl in |- *; rewrite Pplus_assoc; reflexivity.
+Qed.
+
+Theorem Nplus_succ : forall n m:N, Nsucc n + m = Nsucc (n + m).
+Proof.
+destruct n; destruct m.
+  simpl in |- *; reflexivity.
+  unfold Nsucc, Nplus in |- *; rewrite <- Pplus_one_succ_l; reflexivity.
+  simpl in |- *; reflexivity.
+  simpl in |- *; rewrite Pplus_succ_permute_l; reflexivity.
+Qed.
+
+Theorem Nsucc_inj : forall n m:N, Nsucc n = Nsucc m -> n = m.
+Proof.
+destruct n; destruct m; simpl in |- *; intro H; reflexivity || injection H;
+ clear H; intro H.
+  symmetry  in H; contradiction Psucc_not_one with p.
+  contradiction Psucc_not_one with p.
+  rewrite Psucc_inj with (1 := H); reflexivity.
+Qed.
+
+Theorem Nplus_reg_l : forall n m p:N, n + m = n + p -> m = p.
+Proof.
+intro n; pattern n in |- *; apply Nind; clear n; simpl in |- *.
+  trivial.
+  intros n IHn m p H0; do 2 rewrite Nplus_succ in H0.
+  apply IHn; apply Nsucc_inj; assumption.
+Qed.
+
+(** Properties of multiplication *)
+
+Theorem Nmult_1_l : forall n:N, Npos 1%positive * n = n.
+Proof.
+destruct n; reflexivity.
+Qed.
+
+Theorem Nmult_1_r : forall n:N, n * Npos 1%positive = n.
+Proof.
+destruct n; simpl in |- *; try reflexivity.
+rewrite Pmult_1_r; reflexivity.
+Qed.
+
+Theorem Nmult_comm : forall n m:N, n * m = m * n.
+Proof.
+intros.
+destruct n; destruct m; simpl in |- *; try reflexivity.
+rewrite Pmult_comm; reflexivity.
+Qed.
+
+Theorem Nmult_assoc : forall n m p:N, n * (m * p) = n * m * p.
+Proof.
+intros.
+destruct n; try reflexivity.
+destruct m; try reflexivity.
+destruct p; try reflexivity.
+simpl in |- *; rewrite Pmult_assoc; reflexivity.
+Qed.
+
+Theorem Nmult_plus_distr_r : forall n m p:N, (n + m) * p = n * p + m * p.
+Proof.
+intros.
+destruct n; try reflexivity.
+destruct m; destruct p; try reflexivity.
+simpl in |- *; rewrite Pmult_plus_distr_r; reflexivity.
+Qed.
+
+Theorem Nmult_reg_r : forall n m p:N, p <> N0 -> n * p = m * p -> n = m.
+Proof.
+destruct p; intros Hp H.
+contradiction Hp; reflexivity.
+destruct n; destruct m; reflexivity || (try discriminate H).
+injection H; clear H; intro H; rewrite Pmult_reg_r with (1 := H); reflexivity.
+Qed. 
+
+Theorem Nmult_0_l : forall n:N, N0 * n = N0.
+Proof.
+reflexivity.
+Qed.
+
+(** Properties of comparison *)
+
+Theorem Ncompare_Eq_eq : forall n m:N, (n ?= m) = Eq -> n = m.
+Proof.
+destruct n as [| n]; destruct m as [| m]; simpl in |- *; intro H;
+ reflexivity || (try discriminate H).
+  rewrite (Pcompare_Eq_eq n m H); reflexivity.
+Qed.
diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v
new file mode 100644
index 00000000..fffb10c1
--- /dev/null
+++ b/theories/NArith/BinPos.v
@@ -0,0 +1,961 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: BinPos.v,v 1.7.2.1 2004/07/16 19:31:07 herbelin Exp $ i*)
+
+(**********************************************************************)
+(** Binary positive numbers *)
+
+(** Original development by Pierre Crégut, CNET, Lannion, France *)
+
+Inductive positive : Set :=
+  | xI : positive -> positive
+  | xO : positive -> positive
+  | xH : positive.
+
+(** Declare binding key for scope positive_scope *)
+
+Delimit Scope positive_scope with positive.
+
+(** Automatically open scope positive_scope for type positive, xO and xI *)
+
+Bind Scope positive_scope with positive.
+Arguments Scope xO [positive_scope].
+Arguments Scope xI [positive_scope].
+
+(** Successor *)
+
+Fixpoint Psucc (x:positive) : positive :=
+  match x with
+  | xI x' => xO (Psucc x')
+  | xO x' => xI x'
+  | xH => xO xH
+  end.
+
+(** Addition *)
+
+Fixpoint Pplus (x y:positive) {struct x} : positive :=
+  match x, y with
+  | xI x', xI y' => xO (Pplus_carry x' y')
+  | xI x', xO y' => xI (Pplus x' y')
+  | xI x', xH => xO (Psucc x')
+  | xO x', xI y' => xI (Pplus x' y')
+  | xO x', xO y' => xO (Pplus x' y')
+  | xO x', xH => xI x'
+  | xH, xI y' => xO (Psucc y')
+  | xH, xO y' => xI y'
+  | xH, xH => xO xH
+  end
+ 
+ with Pplus_carry (x y:positive) {struct x} : positive :=
+  match x, y with
+  | xI x', xI y' => xI (Pplus_carry x' y')
+  | xI x', xO y' => xO (Pplus_carry x' y')
+  | xI x', xH => xI (Psucc x')
+  | xO x', xI y' => xO (Pplus_carry x' y')
+  | xO x', xO y' => xI (Pplus x' y')
+  | xO x', xH => xO (Psucc x')
+  | xH, xI y' => xI (Psucc y')
+  | xH, xO y' => xO (Psucc y')
+  | xH, xH => xI xH
+  end.
+
+Infix "+" := Pplus : positive_scope.
+
+Open Local Scope positive_scope.
+
+(** From binary positive numbers to Peano natural numbers *)
+
+Fixpoint Pmult_nat (x:positive) (pow2:nat) {struct x} : nat :=
+  match x with
+  | xI x' => (pow2 + Pmult_nat x' (pow2 + pow2))%nat
+  | xO x' => Pmult_nat x' (pow2 + pow2)%nat
+  | xH => pow2
+  end.
+
+Definition nat_of_P (x:positive) := Pmult_nat x 1.
+
+(** From Peano natural numbers to binary positive numbers *)
+
+Fixpoint P_of_succ_nat (n:nat) : positive :=
+  match n with
+  | O => xH
+  | S x' => Psucc (P_of_succ_nat x')
+  end.
+
+(** Operation x -> 2*x-1 *)
+
+Fixpoint Pdouble_minus_one (x:positive) : positive :=
+  match x with
+  | xI x' => xI (xO x')
+  | xO x' => xI (Pdouble_minus_one x')
+  | xH => xH
+  end.
+
+(** Predecessor *)
+
+Definition Ppred (x:positive) :=
+  match x with
+  | xI x' => xO x'
+  | xO x' => Pdouble_minus_one x'
+  | xH => xH
+  end.
+
+(** An auxiliary type for subtraction *)
+
+Inductive positive_mask : Set :=
+  | IsNul : positive_mask
+  | IsPos : positive -> positive_mask
+  | IsNeg : positive_mask.
+
+(** Operation x -> 2*x+1 *)
+
+Definition Pdouble_plus_one_mask (x:positive_mask) :=
+  match x with
+  | IsNul => IsPos xH
+  | IsNeg => IsNeg
+  | IsPos p => IsPos (xI p)
+  end.
+
+(** Operation x -> 2*x *)
+
+Definition Pdouble_mask (x:positive_mask) :=
+  match x with
+  | IsNul => IsNul
+  | IsNeg => IsNeg
+  | IsPos p => IsPos (xO p)
+  end.
+
+(** Operation x -> 2*x-2 *)
+
+Definition Pdouble_minus_two (x:positive) :=
+  match x with
+  | xI x' => IsPos (xO (xO x'))
+  | xO x' => IsPos (xO (Pdouble_minus_one x'))
+  | xH => IsNul
+  end.
+
+(** Subtraction of binary positive numbers into a positive numbers mask *)
+
+Fixpoint Pminus_mask (x y:positive) {struct y} : positive_mask :=
+  match x, y with
+  | xI x', xI y' => Pdouble_mask (Pminus_mask x' y')
+  | xI x', xO y' => Pdouble_plus_one_mask (Pminus_mask x' y')
+  | xI x', xH => IsPos (xO x')
+  | xO x', xI y' => Pdouble_plus_one_mask (Pminus_mask_carry x' y')
+  | xO x', xO y' => Pdouble_mask (Pminus_mask x' y')
+  | xO x', xH => IsPos (Pdouble_minus_one x')
+  | xH, xH => IsNul
+  | xH, _ => IsNeg
+  end
+ 
+ with Pminus_mask_carry (x y:positive) {struct y} : positive_mask :=
+  match x, y with
+  | xI x', xI y' => Pdouble_plus_one_mask (Pminus_mask_carry x' y')
+  | xI x', xO y' => Pdouble_mask (Pminus_mask x' y')
+  | xI x', xH => IsPos (Pdouble_minus_one x')
+  | xO x', xI y' => Pdouble_mask (Pminus_mask_carry x' y')
+  | xO x', xO y' => Pdouble_plus_one_mask (Pminus_mask_carry x' y')
+  | xO x', xH => Pdouble_minus_two x'
+  | xH, _ => IsNeg
+  end.
+
+(** Subtraction of binary positive numbers x and y, returns 1 if x<=y *)
+
+Definition Pminus (x y:positive) :=
+  match Pminus_mask x y with
+  | IsPos z => z
+  | _ => xH
+  end.
+
+Infix "-" := Pminus : positive_scope.
+
+(** Multiplication on binary positive numbers *)
+
+Fixpoint Pmult (x y:positive) {struct x} : positive :=
+  match x with
+  | xI x' => y + xO (Pmult x' y)
+  | xO x' => xO (Pmult x' y)
+  | xH => y
+  end.
+
+Infix "*" := Pmult : positive_scope.
+
+(** Division by 2 rounded below but for 1 *)
+
+Definition Pdiv2 (z:positive) :=
+  match z with
+  | xH => xH
+  | xO p => p
+  | xI p => p
+  end.
+
+Infix "/" := Pdiv2 : positive_scope.
+
+(** Comparison on binary positive numbers *)
+
+Fixpoint Pcompare (x y:positive) (r:comparison) {struct y} : comparison :=
+  match x, y with
+  | xI x', xI y' => Pcompare x' y' r
+  | xI x', xO y' => Pcompare x' y' Gt
+  | xI x', xH => Gt
+  | xO x', xI y' => Pcompare x' y' Lt
+  | xO x', xO y' => Pcompare x' y' r
+  | xO x', xH => Gt
+  | xH, xI y' => Lt
+  | xH, xO y' => Lt
+  | xH, xH => r
+  end.
+
+Infix "?=" := Pcompare (at level 70, no associativity) : positive_scope.
+
+(**********************************************************************)
+(** Miscellaneous properties of binary positive numbers *)
+
+Lemma ZL11 : forall p:positive, p = xH \/ p <> xH.
+Proof.
+intros x; case x; intros; (left; reflexivity) || (right; discriminate).
+Qed.
+
+(**********************************************************************)
+(** Properties of successor on binary positive numbers *)
+
+(** Specification of [xI] in term of [Psucc] and [xO] *)
+
+Lemma xI_succ_xO : forall p:positive, xI p = Psucc (xO p).
+Proof.
+reflexivity.
+Qed.
+
+Lemma Psucc_discr : forall p:positive, p <> Psucc p.
+Proof.
+intro x; destruct x as [p| p| ]; discriminate.
+Qed.
+
+(** Successor and double *)
+
+Lemma Psucc_o_double_minus_one_eq_xO :
+ forall p:positive, Psucc (Pdouble_minus_one p) = xO p.
+Proof.
+intro x; induction x as [x IHx| x| ]; simpl in |- *; try rewrite IHx;
+ reflexivity.
+Qed.
+
+Lemma Pdouble_minus_one_o_succ_eq_xI :
+ forall p:positive, Pdouble_minus_one (Psucc p) = xI p.
+Proof.
+intro x; induction x as [x IHx| x| ]; simpl in |- *; try rewrite IHx;
+ reflexivity.
+Qed.
+
+Lemma xO_succ_permute :
+ forall p:positive, xO (Psucc p) = Psucc (Psucc (xO p)).
+Proof.
+intro y; induction  y as [y Hrecy| y Hrecy| ]; simpl in |- *; auto.
+Qed.
+
+Lemma double_moins_un_xO_discr :
+ forall p:positive, Pdouble_minus_one p <> xO p.
+Proof.
+intro x; destruct x as [p| p| ]; discriminate.
+Qed.
+
+(** Successor and predecessor *)
+
+Lemma Psucc_not_one : forall p:positive, Psucc p <> xH.
+Proof.
+intro x; destruct x as [x| x| ]; discriminate.
+Qed.
+
+Lemma Ppred_succ : forall p:positive, Ppred (Psucc p) = p.
+Proof.
+intro x; destruct x as [p| p| ]; [ idtac | idtac | simpl in |- *; auto ];
+ (induction p as [p IHp| | ]; [ idtac | reflexivity | reflexivity ]);
+ simpl in |- *; simpl in IHp; try rewrite <- IHp; reflexivity.
+Qed.
+
+Lemma Psucc_pred : forall p:positive, p = xH \/ Psucc (Ppred p) = p.
+Proof.
+intro x; induction  x as [x Hrecx| x Hrecx| ];
+ [ simpl in |- *; auto
+ | simpl in |- *; intros; right; apply Psucc_o_double_minus_one_eq_xO
+ | auto ].
+Qed.
+
+(** Injectivity of successor *)
+
+Lemma Psucc_inj : forall p q:positive, Psucc p = Psucc q -> p = q.
+Proof.
+intro x; induction x; intro y; destruct y as [y| y| ]; simpl in |- *; intro H;
+ discriminate H || (try (injection H; clear H; intro H)).
+rewrite (IHx y H); reflexivity.
+absurd (Psucc x = xH); [ apply Psucc_not_one | assumption ].
+apply f_equal with (1 := H); assumption.
+absurd (Psucc y = xH);
+ [ apply Psucc_not_one | symmetry  in |- *; assumption ].
+reflexivity.
+Qed.
+
+(**********************************************************************)
+(** Properties of addition on binary positive numbers *)
+
+(** Specification of [Psucc] in term of [Pplus] *)
+
+Lemma Pplus_one_succ_r : forall p:positive, Psucc p = p + xH.
+Proof.
+intro q; destruct q as [p| p| ]; reflexivity.
+Qed.
+
+Lemma Pplus_one_succ_l : forall p:positive, Psucc p = xH + p.
+Proof.
+intro q; destruct q as [p| p| ]; reflexivity.
+Qed.
+
+(** Specification of [Pplus_carry] *)
+
+Theorem Pplus_carry_spec :
+ forall p q:positive, Pplus_carry p q = Psucc (p + q).
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; auto; rewrite IHp; 
+ auto.
+Qed.
+
+(** Commutativity *)
+
+Theorem Pplus_comm : forall p q:positive, p + q = q + p.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; auto;
+ try do 2 rewrite Pplus_carry_spec; rewrite IHp; auto.
+Qed. 
+
+(** Permutation of [Pplus] and [Psucc] *)
+
+Theorem Pplus_succ_permute_r :
+ forall p q:positive, p + Psucc q = Psucc (p + q).
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; auto;
+ [ rewrite Pplus_carry_spec; rewrite IHp; auto
+ | rewrite Pplus_carry_spec; auto
+ | destruct p; simpl in |- *; auto
+ | rewrite IHp; auto
+ | destruct p; simpl in |- *; auto ].
+Qed.
+
+Theorem Pplus_succ_permute_l :
+ forall p q:positive, Psucc p + q = Psucc (p + q).
+Proof.
+intros x y; rewrite Pplus_comm; rewrite Pplus_comm with (p := x);
+ apply Pplus_succ_permute_r.
+Qed.
+
+Theorem Pplus_carry_pred_eq_plus :
+ forall p q:positive, q <> xH -> Pplus_carry p (Ppred q) = p + q.
+Proof.
+intros q z H; elim (Psucc_pred z);
+ [ intro; absurd (z = xH); auto
+ | intros E; pattern z at 2 in |- *; rewrite <- E;
+    rewrite Pplus_succ_permute_r; rewrite Pplus_carry_spec; 
+    trivial ].
+Qed. 
+
+(** No neutral for addition on strictly positive numbers *)
+
+Lemma Pplus_no_neutral : forall p q:positive, q + p <> p.
+Proof.
+intro x; induction x; intro y; destruct y as [y| y| ]; simpl in |- *; intro H;
+ discriminate H || injection H; clear H; intro H; apply (IHx y H).
+Qed.
+
+Lemma Pplus_carry_no_neutral :
+ forall p q:positive, Pplus_carry q p <> Psucc p.
+Proof.
+intros x y H; absurd (y + x = x);
+ [ apply Pplus_no_neutral
+ | apply Psucc_inj; rewrite <- Pplus_carry_spec; assumption ].
+Qed.
+
+(** Simplification *)
+
+Lemma Pplus_carry_plus :
+ forall p q r s:positive, Pplus_carry p r = Pplus_carry q s -> p + r = q + s.
+Proof.
+intros x y z t H; apply Psucc_inj; do 2 rewrite <- Pplus_carry_spec;
+ assumption.
+Qed.
+
+Lemma Pplus_reg_r : forall p q r:positive, p + r = q + r -> p = q.
+Proof.
+intros x y z; generalize x y; clear x y.
+induction z as [z| z| ].
+  destruct x as [x| x| ]; intro y; destruct y as [y| y| ]; simpl in |- *;
+   intro H; discriminate H || (try (injection H; clear H; intro H)).
+    rewrite IHz with (1 := Pplus_carry_plus _ _ _ _ H); reflexivity.
+    absurd (Pplus_carry x z = Psucc z);
+     [ apply Pplus_carry_no_neutral | assumption ].
+    rewrite IHz with (1 := H); reflexivity.
+    symmetry  in H; absurd (Pplus_carry y z = Psucc z);
+     [ apply Pplus_carry_no_neutral | assumption ].
+    reflexivity.
+  destruct x as [x| x| ]; intro y; destruct y as [y| y| ]; simpl in |- *;
+   intro H; discriminate H || (try (injection H; clear H; intro H)).
+    rewrite IHz with (1 := H); reflexivity.
+    absurd (x + z = z); [ apply Pplus_no_neutral | assumption ].
+    rewrite IHz with (1 := H); reflexivity.
+    symmetry  in H; absurd (y + z = z);
+     [ apply Pplus_no_neutral | assumption ].
+    reflexivity.
+  intros H x y; apply Psucc_inj; do 2 rewrite Pplus_one_succ_r; assumption.
+Qed.
+
+Lemma Pplus_reg_l : forall p q r:positive, p + q = p + r -> q = r.
+Proof.
+intros x y z H; apply Pplus_reg_r with (r := x);
+ rewrite Pplus_comm with (p := z); rewrite Pplus_comm with (p := y);
+ assumption.
+Qed.
+
+Lemma Pplus_carry_reg_r :
+ forall p q r:positive, Pplus_carry p r = Pplus_carry q r -> p = q.
+Proof.
+intros x y z H; apply Pplus_reg_r with (r := z); apply Pplus_carry_plus;
+ assumption.
+Qed.
+
+Lemma Pplus_carry_reg_l :
+ forall p q r:positive, Pplus_carry p q = Pplus_carry p r -> q = r.
+Proof.
+intros x y z H; apply Pplus_reg_r with (r := x);
+ rewrite Pplus_comm with (p := z); rewrite Pplus_comm with (p := y);
+ apply Pplus_carry_plus; assumption.
+Qed.
+
+(** Addition on positive is associative *)
+
+Theorem Pplus_assoc : forall p q r:positive, p + (q + r) = p + q + r.
+Proof.
+intros x y; generalize x; clear x.
+induction y as [y| y| ]; intro x.
+  destruct x as [x| x| ]; intro z; destruct z as [z| z| ]; simpl in |- *;
+   repeat rewrite Pplus_carry_spec; repeat rewrite Pplus_succ_permute_r;
+   repeat rewrite Pplus_succ_permute_l;
+   reflexivity || (repeat apply f_equal with (A := positive)); 
+   apply IHy.
+  destruct x as [x| x| ]; intro z; destruct z as [z| z| ]; simpl in |- *;
+   repeat rewrite Pplus_carry_spec; repeat rewrite Pplus_succ_permute_r;
+   repeat rewrite Pplus_succ_permute_l;
+   reflexivity || (repeat apply f_equal with (A := positive)); 
+   apply IHy.
+  intro z; rewrite Pplus_comm with (p := xH);
+   do 2 rewrite <- Pplus_one_succ_r; rewrite Pplus_succ_permute_l;
+   rewrite Pplus_succ_permute_r; reflexivity.
+Qed.
+
+(** Commutation of addition with the double of a positive number *)
+
+Lemma Pplus_xI_double_minus_one :
+ forall p q:positive, xO (p + q) = xI p + Pdouble_minus_one q.
+Proof.
+intros; change (xI p) with (xO p + xH) in |- *.
+rewrite <- Pplus_assoc; rewrite <- Pplus_one_succ_l;
+ rewrite Psucc_o_double_minus_one_eq_xO.
+reflexivity.
+Qed.
+
+Lemma Pplus_xO_double_minus_one :
+ forall p q:positive, Pdouble_minus_one (p + q) = xO p + Pdouble_minus_one q.
+Proof.
+induction p as [p IHp| p IHp| ]; destruct q as [q| q| ]; simpl in |- *;
+ try rewrite Pplus_carry_spec; try rewrite Pdouble_minus_one_o_succ_eq_xI;
+ try rewrite IHp; try rewrite Pplus_xI_double_minus_one; 
+ try reflexivity.
+ rewrite <- Psucc_o_double_minus_one_eq_xO; rewrite Pplus_one_succ_l;
+  reflexivity. 
+Qed.
+
+(** Misc *)
+
+Lemma Pplus_diag : forall p:positive, p + p = xO p.
+Proof.
+intro x; induction x; simpl in |- *; try rewrite Pplus_carry_spec;
+ try rewrite IHx; reflexivity.
+Qed.
+
+(**********************************************************************)
+(** Peano induction on binary positive positive numbers *)
+
+Fixpoint plus_iter (x y:positive) {struct x} : positive :=
+  match x with
+  | xH => Psucc y
+  | xO x => plus_iter x (plus_iter x y)
+  | xI x => plus_iter x (plus_iter x (Psucc y))
+  end.
+
+Lemma plus_iter_eq_plus : forall p q:positive, plus_iter p q = p + q.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; reflexivity || (do 2 rewrite IHp);
+ rewrite Pplus_assoc; rewrite Pplus_diag; try reflexivity.
+rewrite Pplus_carry_spec; rewrite <- Pplus_succ_permute_r; reflexivity.
+rewrite Pplus_one_succ_r; reflexivity.
+Qed.
+
+Lemma plus_iter_xO : forall p:positive, plus_iter p p = xO p.
+Proof.
+intro; rewrite <- Pplus_diag; apply plus_iter_eq_plus.
+Qed.
+
+Lemma plus_iter_xI : forall p:positive, Psucc (plus_iter p p) = xI p.
+Proof.
+intro; rewrite xI_succ_xO; rewrite <- Pplus_diag;
+ apply (f_equal (A:=positive)); apply plus_iter_eq_plus.
+Qed.
+
+Lemma iterate_add :
+ forall P:positive -> Type,
+   (forall n:positive, P n -> P (Psucc n)) ->
+   forall p q:positive, P q -> P (plus_iter p q).
+Proof.
+intros P H; induction p; simpl in |- *; intros.
+apply IHp; apply IHp; apply H; assumption.
+apply IHp; apply IHp; assumption.
+apply H; assumption.
+Defined.
+
+(** Peano induction *)
+
+Theorem Pind :
+ forall P:positive -> Prop,
+   P xH -> (forall n:positive, P n -> P (Psucc n)) -> forall p:positive, P p.
+Proof.
+intros P H1 Hsucc n; induction n.
+rewrite <- plus_iter_xI; apply Hsucc; apply iterate_add; assumption.
+rewrite <- plus_iter_xO; apply iterate_add; assumption.
+assumption.
+Qed.
+
+(** Peano recursion *)
+
+Definition Prec (A:Set) (a:A) (f:positive -> A -> A) : 
+  positive -> A :=
+  (fix Prec (p:positive) : A :=
+     match p with
+     | xH => a
+     | xO p => iterate_add (fun _ => A) f p p (Prec p)
+     | xI p => f (plus_iter p p) (iterate_add (fun _ => A) f p p (Prec p))
+     end).
+
+(** Peano case analysis *)
+
+Theorem Pcase :
+ forall P:positive -> Prop,
+   P xH -> (forall n:positive, P (Psucc n)) -> forall p:positive, P p.
+Proof.
+intros; apply Pind; auto.
+Qed.
+
+(*
+Check
+  (let fact := Prec positive xH (fun p r => Psucc p * r) in
+   let seven := xI (xI xH) in
+   let five_thousand_forty :=
+     xO (xO (xO (xO (xI (xI (xO (xI (xI (xI (xO (xO xH))))))))))) in
+   refl_equal _:fact seven = five_thousand_forty).
+*)
+
+(**********************************************************************)
+(** Properties of multiplication on binary positive numbers *)
+
+(** One is right neutral for multiplication *)
+
+Lemma Pmult_1_r : forall p:positive, p * xH = p.
+Proof.
+intro x; induction x; simpl in |- *.
+  rewrite IHx; reflexivity.
+  rewrite IHx; reflexivity.
+  reflexivity.
+Qed.
+
+(** Right reduction properties for multiplication *)
+
+Lemma Pmult_xO_permute_r : forall p q:positive, p * xO q = xO (p * q).
+Proof.
+intros x y; induction x; simpl in |- *.
+  rewrite IHx; reflexivity.
+  rewrite IHx; reflexivity.
+  reflexivity.
+Qed.
+
+Lemma Pmult_xI_permute_r : forall p q:positive, p * xI q = p + xO (p * q).
+Proof.
+intros x y; induction x; simpl in |- *.
+  rewrite IHx; do 2 rewrite Pplus_assoc; rewrite Pplus_comm with (p := y);
+   reflexivity.
+  rewrite IHx; reflexivity.
+  reflexivity.
+Qed.
+
+(** Commutativity of multiplication *)
+
+Theorem Pmult_comm : forall p q:positive, p * q = q * p.
+Proof.
+intros x y; induction y; simpl in |- *.
+  rewrite <- IHy; apply Pmult_xI_permute_r.
+  rewrite <- IHy; apply Pmult_xO_permute_r.
+  apply Pmult_1_r.
+Qed.
+
+(** Distributivity of multiplication over addition *)
+
+Theorem Pmult_plus_distr_l :
+ forall p q r:positive, p * (q + r) = p * q + p * r.
+Proof.
+intros x y z; induction x; simpl in |- *.
+  rewrite IHx; rewrite <- Pplus_assoc with (q := xO (x * y));
+   rewrite Pplus_assoc with (p := xO (x * y));
+   rewrite Pplus_comm with (p := xO (x * y));
+   rewrite <- Pplus_assoc with (q := xO (x * y));
+   rewrite Pplus_assoc with (q := z); reflexivity.
+  rewrite IHx; reflexivity.
+  reflexivity.
+Qed.
+
+Theorem Pmult_plus_distr_r :
+ forall p q r:positive, (p + q) * r = p * r + q * r.
+Proof.
+intros x y z; do 3 rewrite Pmult_comm with (q := z); apply Pmult_plus_distr_l.
+Qed.
+
+(** Associativity of multiplication *)
+
+Theorem Pmult_assoc : forall p q r:positive, p * (q * r) = p * q * r.
+Proof.
+intro x; induction x as [x| x| ]; simpl in |- *; intros y z.
+  rewrite IHx; rewrite Pmult_plus_distr_r; reflexivity.
+  rewrite IHx; reflexivity.
+  reflexivity.
+Qed.
+
+(** Parity properties of multiplication *)
+
+Lemma Pmult_xI_mult_xO_discr : forall p q r:positive, xI p * r <> xO q * r.
+Proof.
+intros x y z; induction z as [| z IHz| ]; try discriminate.
+intro H; apply IHz; clear IHz.
+do 2 rewrite Pmult_xO_permute_r in H.
+injection H; clear H; intro H; exact H.
+Qed.
+
+Lemma Pmult_xO_discr : forall p q:positive, xO p * q <> q.
+Proof.
+intros x y; induction y; try discriminate.
+rewrite Pmult_xO_permute_r; injection; assumption.
+Qed.
+
+(** Simplification properties of multiplication *)
+
+Theorem Pmult_reg_r : forall p q r:positive, p * r = q * r -> p = q.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ];
+ intros z H; reflexivity || apply (f_equal (A:=positive)) || apply False_ind.
+  simpl in H; apply IHp with (xO z); simpl in |- *;
+   do 2 rewrite Pmult_xO_permute_r; apply Pplus_reg_l with (1 := H).
+  apply Pmult_xI_mult_xO_discr with (1 := H).
+  simpl in H; rewrite Pplus_comm in H; apply Pplus_no_neutral with (1 := H).
+  symmetry  in H; apply Pmult_xI_mult_xO_discr with (1 := H).
+  apply IHp with (xO z); simpl in |- *; do 2 rewrite Pmult_xO_permute_r;
+   assumption.
+  apply Pmult_xO_discr with (1 := H).
+  simpl in H; symmetry  in H; rewrite Pplus_comm in H;
+   apply Pplus_no_neutral with (1 := H).
+  symmetry  in H; apply Pmult_xO_discr with (1 := H).
+Qed.
+
+Theorem Pmult_reg_l : forall p q r:positive, r * p = r * q -> p = q.
+Proof.
+intros x y z H; apply Pmult_reg_r with (r := z).
+rewrite Pmult_comm with (p := x); rewrite Pmult_comm with (p := y);
+ assumption.
+Qed.
+
+(** Inversion of multiplication *)
+
+Lemma Pmult_1_inversion_l : forall p q:positive, p * q = xH -> p = xH.
+Proof.
+intros x y; destruct x as [p| p| ]; simpl in |- *.
+ destruct y as [p0| p0| ]; intro; discriminate.
+ intro; discriminate.
+ reflexivity.
+Qed.
+
+(**********************************************************************)
+(** Properties of comparison on binary positive numbers *)
+
+Theorem Pcompare_not_Eq :
+ forall p q:positive, (p ?= q) Gt <> Eq /\ (p ?= q) Lt <> Eq.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ];
+ split; simpl in |- *; auto; discriminate || (elim (IHp q); auto).
+Qed.
+
+Theorem Pcompare_Eq_eq : forall p q:positive, (p ?= q) Eq = Eq -> p = q.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ];
+ simpl in |- *; auto; intro H;
+ [ rewrite (IHp q); trivial
+ | absurd ((p ?= q) Gt = Eq);
+    [ elim (Pcompare_not_Eq p q); auto | assumption ]
+ | discriminate H
+ | absurd ((p ?= q) Lt = Eq);
+    [ elim (Pcompare_not_Eq p q); auto | assumption ]
+ | rewrite (IHp q); auto
+ | discriminate H
+ | discriminate H
+ | discriminate H ].
+Qed.
+
+Lemma Pcompare_Gt_Lt :
+ forall p q:positive, (p ?= q) Gt = Lt -> (p ?= q) Eq = Lt.
+Proof.
+intro x; induction  x as [x Hrecx| x Hrecx| ]; intro y;
+ [ induction  y as [y Hrecy| y Hrecy| ]
+ | induction  y as [y Hrecy| y Hrecy| ]
+ | induction  y as [y Hrecy| y Hrecy| ] ]; simpl in |- *; 
+ auto; discriminate || intros H; discriminate H.
+Qed.
+
+Lemma Pcompare_Lt_Gt :
+ forall p q:positive, (p ?= q) Lt = Gt -> (p ?= q) Eq = Gt.
+Proof.
+intro x; induction  x as [x Hrecx| x Hrecx| ]; intro y;
+ [ induction  y as [y Hrecy| y Hrecy| ]
+ | induction  y as [y Hrecy| y Hrecy| ]
+ | induction  y as [y Hrecy| y Hrecy| ] ]; simpl in |- *; 
+ auto; discriminate || intros H; discriminate H.
+Qed.
+
+Lemma Pcompare_Lt_Lt :
+ forall p q:positive, (p ?= q) Lt = Lt -> (p ?= q) Eq = Lt \/ p = q.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ];
+ simpl in |- *; auto; try discriminate; intro H2; elim (IHp q H2); 
+ auto; intros E; rewrite E; auto.
+Qed.
+
+Lemma Pcompare_Gt_Gt :
+ forall p q:positive, (p ?= q) Gt = Gt -> (p ?= q) Eq = Gt \/ p = q.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ];
+ simpl in |- *; auto; try discriminate; intro H2; elim (IHp q H2); 
+ auto; intros E; rewrite E; auto.
+Qed.
+
+Lemma Dcompare : forall r:comparison, r = Eq \/ r = Lt \/ r = Gt.
+Proof.
+simple induction r; auto. 
+Qed.
+
+Ltac ElimPcompare c1 c2 :=
+  elim (Dcompare ((c1 ?= c2) Eq));
+   [ idtac | let x := fresh "H" in
+             (intro x; case x; clear x) ].
+
+Theorem Pcompare_refl : forall p:positive, (p ?= p) Eq = Eq.
+intro x; induction  x as [x Hrecx| x Hrecx| ]; auto.
+Qed.
+
+Lemma Pcompare_antisym :
+ forall (p q:positive) (r:comparison),
+   CompOpp ((p ?= q) r) = (q ?= p) (CompOpp r).
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; intro r;
+ reflexivity ||
+   (symmetry  in |- *; assumption) || discriminate H || simpl in |- *;
+ apply IHp || (try rewrite IHp); try reflexivity.
+Qed.
+
+Lemma ZC1 : forall p q:positive, (p ?= q) Eq = Gt -> (q ?= p) Eq = Lt.
+Proof.
+intros; change Eq with (CompOpp Eq) in |- *.
+rewrite <- Pcompare_antisym; rewrite H; reflexivity.
+Qed.
+
+Lemma ZC2 : forall p q:positive, (p ?= q) Eq = Lt -> (q ?= p) Eq = Gt.
+Proof.
+intros; change Eq with (CompOpp Eq) in |- *.
+rewrite <- Pcompare_antisym; rewrite H; reflexivity.
+Qed.
+
+Lemma ZC3 : forall p q:positive, (p ?= q) Eq = Eq -> (q ?= p) Eq = Eq.
+Proof.
+intros; change Eq with (CompOpp Eq) in |- *.
+rewrite <- Pcompare_antisym; rewrite H; reflexivity.
+Qed.
+
+Lemma ZC4 : forall p q:positive, (p ?= q) Eq = CompOpp ((q ?= p) Eq).
+Proof.
+intros; change Eq at 1 with (CompOpp Eq) in |- *.
+symmetry  in |- *; apply Pcompare_antisym.
+Qed.
+
+(**********************************************************************)
+(** Properties of subtraction on binary positive numbers *)
+
+Lemma double_eq_zero_inversion :
+ forall p:positive_mask, Pdouble_mask p = IsNul -> p = IsNul.
+Proof.
+destruct p; simpl in |- *; [ trivial | discriminate 1 | discriminate 1 ].
+Qed.
+
+Lemma double_plus_one_zero_discr :
+ forall p:positive_mask, Pdouble_plus_one_mask p <> IsNul.
+Proof.
+simple induction p; intros; discriminate.
+Qed.
+
+Lemma double_plus_one_eq_one_inversion :
+ forall p:positive_mask, Pdouble_plus_one_mask p = IsPos xH -> p = IsNul.
+Proof.
+destruct p; simpl in |- *; [ trivial | discriminate 1 | discriminate 1 ].
+Qed.
+
+Lemma double_eq_one_discr :
+ forall p:positive_mask, Pdouble_mask p <> IsPos xH.
+Proof.
+simple induction p; intros; discriminate.
+Qed.
+
+Theorem Pminus_mask_diag : forall p:positive, Pminus_mask p p = IsNul.
+Proof.
+intro x; induction x as [p IHp| p IHp| ];
+ [ simpl in |- *; rewrite IHp; simpl in |- *; trivial
+ | simpl in |- *; rewrite IHp; auto
+ | auto ].
+Qed.
+
+Lemma ZL10 :
+ forall p q:positive,
+   Pminus_mask p q = IsPos xH -> Pminus_mask_carry p q = IsNul.
+Proof.
+intro x; induction x as [p| p| ]; intro y; destruct y as [q| q| ];
+ simpl in |- *; intro H; try discriminate H;
+ [ absurd (Pdouble_mask (Pminus_mask p q) = IsPos xH);
+    [ apply double_eq_one_discr | assumption ]
+ | assert (Heq : Pminus_mask p q = IsNul);
+    [ apply double_plus_one_eq_one_inversion; assumption
+    | rewrite Heq; reflexivity ]
+ | assert (Heq : Pminus_mask_carry p q = IsNul);
+    [ apply double_plus_one_eq_one_inversion; assumption
+    | rewrite Heq; reflexivity ]
+ | absurd (Pdouble_mask (Pminus_mask p q) = IsPos xH);
+    [ apply double_eq_one_discr | assumption ]
+ | destruct p; simpl in |- *;
+    [ discriminate H | discriminate H | reflexivity ] ].
+Qed.
+
+(** Properties of subtraction valid only for x>y *)
+
+Lemma Pminus_mask_Gt :
+ forall p q:positive,
+   (p ?= q) Eq = Gt ->
+    exists h : positive,
+     Pminus_mask p q = IsPos h /\
+     q + h = p /\ (h = xH \/ Pminus_mask_carry p q = IsPos (Ppred h)).
+Proof.
+intro x; induction x as [p| p| ]; intro y; destruct y as [q| q| ];
+ simpl in |- *; intro H; try discriminate H.
+  destruct (IHp q H) as [z [H4 [H6 H7]]]; exists (xO z); split.
+    rewrite H4; reflexivity.
+    split.
+      simpl in |- *; rewrite H6; reflexivity.
+      right; clear H6; destruct (ZL11 z) as [H8| H8];
+       [ rewrite H8; rewrite H8 in H4; rewrite ZL10;
+          [ reflexivity | assumption ]
+       | clear H4; destruct H7 as [H9| H9];
+          [ absurd (z = xH); assumption
+          | rewrite H9; clear H9; destruct z as [p0| p0| ];
+             [ reflexivity | reflexivity | absurd (xH = xH); trivial ] ] ].
+  case Pcompare_Gt_Gt with (1 := H);
+   [ intros H3; elim (IHp q H3); intros z H4; exists (xI z); elim H4;
+      intros H5 H6; elim H6; intros H7 H8; split;
+      [ simpl in |- *; rewrite H5; auto
+      | split;
+         [ simpl in |- *; rewrite H7; trivial
+         | right;
+            change (Pdouble_mask (Pminus_mask p q) = IsPos (Ppred (xI z)))
+             in |- *; rewrite H5; auto ] ]
+   | intros H3; exists xH; rewrite H3; split;
+      [ simpl in |- *; rewrite Pminus_mask_diag; auto | split; auto ] ].
+  exists (xO p); auto.
+  destruct (IHp q) as [z [H4 [H6 H7]]].
+    apply Pcompare_Lt_Gt; assumption.
+    destruct (ZL11 z) as [vZ| ];
+     [ exists xH; split;
+        [ rewrite ZL10; [ reflexivity | rewrite vZ in H4; assumption ]
+        | split;
+           [ simpl in |- *; rewrite Pplus_one_succ_r; rewrite <- vZ;
+              rewrite H6; trivial
+           | auto ] ]
+     | exists (xI (Ppred z)); destruct H7 as [| H8];
+        [ absurd (z = xH); assumption
+        | split;
+           [ rewrite H8; trivial
+           | split;
+              [ simpl in |- *; rewrite Pplus_carry_pred_eq_plus;
+                 [ rewrite H6; trivial | assumption ]
+              | right; rewrite H8; reflexivity ] ] ] ].
+  destruct (IHp q H) as [z [H4 [H6 H7]]].
+  exists (xO z); split;
+   [ rewrite H4; auto
+   | split;
+      [ simpl in |- *; rewrite H6; reflexivity
+      | right;
+         change
+           (Pdouble_plus_one_mask (Pminus_mask_carry p q) =
+            IsPos (Pdouble_minus_one z)) in |- *;
+         destruct (ZL11 z) as [H8| H8];
+         [ rewrite H8; simpl in |- *;
+            assert (H9 : Pminus_mask_carry p q = IsNul);
+            [ apply ZL10; rewrite <- H8; assumption
+            | rewrite H9; reflexivity ]
+         | destruct H7 as [H9| H9];
+            [ absurd (z = xH); auto
+            | rewrite H9; destruct z as [p0| p0| ]; simpl in |- *;
+               [ reflexivity
+               | reflexivity
+               | absurd (xH = xH); [ assumption | reflexivity ] ] ] ] ] ].
+  exists (Pdouble_minus_one p); split;
+   [ reflexivity
+   | clear IHp; split;
+      [ destruct p; simpl in |- *;
+         [ reflexivity
+         | rewrite Psucc_o_double_minus_one_eq_xO; reflexivity
+         | reflexivity ]
+      | destruct p; [ right | right | left ]; reflexivity ] ].
+Qed.
+
+Theorem Pplus_minus :
+ forall p q:positive, (p ?= q) Eq = Gt -> q + (p - q) = p.
+Proof.
+intros x y H; elim Pminus_mask_Gt with (1 := H); intros z H1; elim H1;
+ intros H2 H3; elim H3; intros H4 H5; unfold Pminus in |- *; 
+ rewrite H2; exact H4.
+Qed.
diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v
new file mode 100644
index 00000000..b1bdaaf0
--- /dev/null
+++ b/theories/NArith/NArith.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: NArith.v,v 1.2.2.1 2004/07/16 19:31:07 herbelin Exp $ *)
+
+(** Library for binary natural numbers *)
+
+Require Export BinPos.
+Require Export BinNat.
\ No newline at end of file
diff --git a/theories/NArith/Pnat.v b/theories/NArith/Pnat.v
new file mode 100644
index 00000000..f5bbb1c9
--- /dev/null
+++ b/theories/NArith/Pnat.v
@@ -0,0 +1,485 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Pnat.v,v 1.3.2.1 2004/07/16 19:31:07 herbelin Exp $ i*)
+
+Require Import BinPos.
+
+(**********************************************************************)
+(** Properties of the injection from binary positive numbers to Peano 
+    natural numbers *)
+
+(** Original development by Pierre Crégut, CNET, Lannion, France *)
+
+Require Import Le.
+Require Import Lt.
+Require Import Gt.
+Require Import Plus.
+Require Import Mult.
+Require Import Minus.
+
+(** [nat_of_P] is a morphism for addition *)
+
+Lemma Pmult_nat_succ_morphism :
+ forall (p:positive) (n:nat), Pmult_nat (Psucc p) n = n + Pmult_nat p n.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; simpl in |- *; auto; intro m;
+ rewrite IHp; rewrite plus_assoc; trivial.
+Qed.
+
+Lemma nat_of_P_succ_morphism :
+ forall p:positive, nat_of_P (Psucc p) = S (nat_of_P p).
+Proof.
+  intro; change (S (nat_of_P p)) with (1 + nat_of_P p) in |- *;
+   unfold nat_of_P in |- *; apply Pmult_nat_succ_morphism.
+Qed.
+
+Theorem Pmult_nat_plus_carry_morphism :
+ forall (p q:positive) (n:nat),
+   Pmult_nat (Pplus_carry p q) n = n + Pmult_nat (p + q) n.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; auto with arith; 
+ intro m;
+ [ rewrite IHp; rewrite plus_assoc; trivial with arith
+ | rewrite IHp; rewrite plus_assoc; trivial with arith
+ | rewrite Pmult_nat_succ_morphism; rewrite plus_assoc; trivial with arith
+ | rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ].
+Qed.
+
+Theorem nat_of_P_plus_carry_morphism :
+ forall p q:positive, nat_of_P (Pplus_carry p q) = S (nat_of_P (p + q)).
+Proof.
+intros; unfold nat_of_P in |- *; rewrite Pmult_nat_plus_carry_morphism;
+ simpl in |- *; trivial with arith.
+Qed.
+
+Theorem Pmult_nat_l_plus_morphism :
+ forall (p q:positive) (n:nat),
+   Pmult_nat (p + q) n = Pmult_nat p n + Pmult_nat q n.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; auto with arith;
+ [ intros m; rewrite Pmult_nat_plus_carry_morphism; rewrite IHp;
+    rewrite plus_assoc_reverse; rewrite plus_assoc_reverse;
+    rewrite (plus_permute m (Pmult_nat p (m + m))); 
+    trivial with arith
+ | intros m; rewrite IHp; apply plus_assoc
+ | intros m; rewrite Pmult_nat_succ_morphism;
+    rewrite (plus_comm (m + Pmult_nat p (m + m))); 
+    apply plus_assoc_reverse
+ | intros m; rewrite IHp; apply plus_permute
+ | intros m; rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ].
+Qed.
+
+Theorem nat_of_P_plus_morphism :
+ forall p q:positive, nat_of_P (p + q) = nat_of_P p + nat_of_P q.
+Proof.
+intros x y; exact (Pmult_nat_l_plus_morphism x y 1).
+Qed.
+
+(** [Pmult_nat] is a morphism for addition *)
+
+Lemma Pmult_nat_r_plus_morphism :
+ forall (p:positive) (n:nat),
+   Pmult_nat p (n + n) = Pmult_nat p n + Pmult_nat p n.
+Proof.
+intro y; induction y as [p H| p H| ]; intro m;
+ [ simpl in |- *; rewrite H; rewrite plus_assoc_reverse;
+    rewrite (plus_permute m (Pmult_nat p (m + m)));
+    rewrite plus_assoc_reverse; auto with arith
+ | simpl in |- *; rewrite H; auto with arith
+ | simpl in |- *; trivial with arith ].
+Qed.
+
+Lemma ZL6 : forall p:positive, Pmult_nat p 2 = nat_of_P p + nat_of_P p.
+Proof.
+intro p; change 2 with (1 + 1) in |- *; rewrite Pmult_nat_r_plus_morphism;
+ trivial.
+Qed.
+ 
+(** [nat_of_P] is a morphism for multiplication *)
+
+Theorem nat_of_P_mult_morphism :
+ forall p q:positive, nat_of_P (p * q) = nat_of_P p * nat_of_P q.
+Proof.
+intros x y; induction x as [x' H| x' H| ];
+ [ change (xI x' * y)%positive with (y + xO (x' * y))%positive in |- *;
+    rewrite nat_of_P_plus_morphism; unfold nat_of_P at 2 3 in |- *;
+    simpl in |- *; do 2 rewrite ZL6; rewrite H; rewrite mult_plus_distr_r;
+    reflexivity
+ | unfold nat_of_P at 1 2 in |- *; simpl in |- *; do 2 rewrite ZL6; rewrite H;
+    rewrite mult_plus_distr_r; reflexivity
+ | simpl in |- *; rewrite <- plus_n_O; reflexivity ].
+Qed.
+
+(** [nat_of_P] maps to the strictly positive subset of [nat] *)
+
+Lemma ZL4 : forall p:positive,  exists h : nat, nat_of_P p = S h.
+Proof.
+intro y; induction y as [p H| p H| ];
+ [ destruct H as [x H1]; exists (S x + S x); unfold nat_of_P in |- *;
+    simpl in |- *; change 2 with (1 + 1) in |- *;
+    rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H1; 
+    rewrite H1; auto with arith
+ | destruct H as [x H2]; exists (x + S x); unfold nat_of_P in |- *;
+    simpl in |- *; change 2 with (1 + 1) in |- *;
+    rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H2; 
+    rewrite H2; auto with arith
+ | exists 0; auto with arith ].
+Qed.
+
+(** Extra lemmas on [lt] on Peano natural numbers *)
+
+Lemma ZL7 : forall n m:nat, n < m -> n + n < m + m.
+Proof.
+intros m n H; apply lt_trans with (m := m + n);
+ [ apply plus_lt_compat_l with (1 := H)
+ | rewrite (plus_comm m n); apply plus_lt_compat_l with (1 := H) ].
+Qed.
+
+Lemma ZL8 : forall n m:nat, n < m -> S (n + n) < m + m.
+Proof.
+intros m n H; apply le_lt_trans with (m := m + n);
+ [ change (m + m < m + n) in |- *; apply plus_lt_compat_l with (1 := H)
+ | rewrite (plus_comm m n); apply plus_lt_compat_l with (1 := H) ].
+Qed.
+
+(** [nat_of_P] is a morphism from [positive] to [nat] for [lt] (expressed
+    from [compare] on [positive])
+
+    Part 1: [lt] on [positive] is finer than [lt] on [nat]
+*)
+
+Lemma nat_of_P_lt_Lt_compare_morphism :
+ forall p q:positive, (p ?= q)%positive Eq = Lt -> nat_of_P p < nat_of_P q.
+Proof.
+intro x; induction x as [p H| p H| ]; intro y; destruct y as [q| q| ];
+ intro H2;
+ [ unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; do 2 rewrite ZL6;
+    apply ZL7; apply H; simpl in H2; assumption
+ | unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6; apply ZL8;
+    apply H; simpl in H2; apply Pcompare_Gt_Lt; assumption
+ | simpl in |- *; discriminate H2
+ | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    elim (Pcompare_Lt_Lt p q H2);
+    [ intros H3; apply lt_S; apply ZL7; apply H; apply H3
+    | intros E; rewrite E; apply lt_n_Sn ]
+ | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    apply ZL7; apply H; assumption
+ | simpl in |- *; discriminate H2
+ | unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; rewrite ZL6;
+    elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *; 
+    apply lt_O_Sn
+ | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 q);
+    intros h H3; rewrite H3; simpl in |- *; rewrite <- plus_n_Sm;
+    apply lt_n_S; apply lt_O_Sn
+ | simpl in |- *; discriminate H2 ].
+Qed.
+
+(** [nat_of_P] is a morphism from [positive] to [nat] for [gt] (expressed
+    from [compare] on [positive])
+
+    Part 1: [gt] on [positive] is finer than [gt] on [nat]
+*)
+
+Lemma nat_of_P_gt_Gt_compare_morphism :
+ forall p q:positive, (p ?= q)%positive Eq = Gt -> nat_of_P p > nat_of_P q.
+Proof.
+unfold gt in |- *; intro x; induction x as [p H| p H| ]; intro y;
+ destruct y as [q| q| ]; intro H2;
+ [ simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    apply lt_n_S; apply ZL7; apply H; assumption
+ | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    elim (Pcompare_Gt_Gt p q H2);
+    [ intros H3; apply lt_S; apply ZL7; apply H; assumption
+    | intros E; rewrite E; apply lt_n_Sn ]
+ | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 p);
+    intros h H3; rewrite H3; simpl in |- *; apply lt_n_S; 
+    apply lt_O_Sn
+ | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    apply ZL8; apply H; apply Pcompare_Lt_Gt; assumption
+ | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    apply ZL7; apply H; assumption
+ | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 p);
+    intros h H3; rewrite H3; simpl in |- *; rewrite <- plus_n_Sm;
+    apply lt_n_S; apply lt_O_Sn
+ | simpl in |- *; discriminate H2
+ | simpl in |- *; discriminate H2
+ | simpl in |- *; discriminate H2 ].
+Qed.
+
+(** [nat_of_P] is a morphism from [positive] to [nat] for [lt] (expressed
+    from [compare] on [positive])
+
+    Part 2: [lt] on [nat] is finer than [lt] on [positive]
+*)
+
+Lemma nat_of_P_lt_Lt_compare_complement_morphism :
+ forall p q:positive, nat_of_P p < nat_of_P q -> (p ?= q)%positive Eq = Lt.
+Proof.
+intros x y; unfold gt in |- *; elim (Dcompare ((x ?= y)%positive Eq));
+ [ intros E; rewrite (Pcompare_Eq_eq x y E); intros H;
+    absurd (nat_of_P y < nat_of_P y); [ apply lt_irrefl | assumption ]
+ | intros H; elim H;
+    [ auto
+    | intros H1 H2; absurd (nat_of_P x < nat_of_P y);
+       [ apply lt_asym; change (nat_of_P x > nat_of_P y) in |- *;
+          apply nat_of_P_gt_Gt_compare_morphism; assumption
+       | assumption ] ] ].
+Qed.
+
+(** [nat_of_P] is a morphism from [positive] to [nat] for [gt] (expressed
+    from [compare] on [positive])
+
+    Part 2: [gt] on [nat] is finer than [gt] on [positive]
+*)
+
+Lemma nat_of_P_gt_Gt_compare_complement_morphism :
+ forall p q:positive, nat_of_P p > nat_of_P q -> (p ?= q)%positive Eq = Gt.
+Proof.
+intros x y; unfold gt in |- *; elim (Dcompare ((x ?= y)%positive Eq));
+ [ intros E; rewrite (Pcompare_Eq_eq x y E); intros H;
+    absurd (nat_of_P y < nat_of_P y); [ apply lt_irrefl | assumption ]
+ | intros H; elim H;
+    [ intros H1 H2; absurd (nat_of_P y < nat_of_P x);
+       [ apply lt_asym; apply nat_of_P_lt_Lt_compare_morphism; assumption
+       | assumption ]
+    | auto ] ].
+Qed.
+
+(** [nat_of_P] is strictly positive *)
+
+Lemma le_Pmult_nat : forall (p:positive) (n:nat), n <= Pmult_nat p n.
+induction p; simpl in |- *; auto with arith.
+intro m; apply le_trans with (m + m); auto with arith.
+Qed.
+
+Lemma lt_O_nat_of_P : forall p:positive, 0 < nat_of_P p.
+intro; unfold nat_of_P in |- *; apply lt_le_trans with 1; auto with arith.
+apply le_Pmult_nat.
+Qed.
+
+(** Pmult_nat permutes with multiplication *)
+
+Lemma Pmult_nat_mult_permute :
+ forall (p:positive) (n m:nat), Pmult_nat p (m * n) = m * Pmult_nat p n.
+Proof.
+  simple induction p. intros. simpl in |- *. rewrite mult_plus_distr_l. rewrite <- (mult_plus_distr_l m n n).
+  rewrite (H (n + n) m). reflexivity.
+  intros. simpl in |- *. rewrite <- (mult_plus_distr_l m n n). apply H.
+  trivial.
+Qed.
+
+Lemma Pmult_nat_2_mult_2_permute :
+ forall p:positive, Pmult_nat p 2 = 2 * Pmult_nat p 1.
+Proof.
+  intros. rewrite <- Pmult_nat_mult_permute. reflexivity.
+Qed.
+
+Lemma Pmult_nat_4_mult_2_permute :
+ forall p:positive, Pmult_nat p 4 = 2 * Pmult_nat p 2.
+Proof.
+  intros. rewrite <- Pmult_nat_mult_permute. reflexivity.
+Qed.
+
+(** Mapping of xH, xO and xI through [nat_of_P] *)
+
+Lemma nat_of_P_xH : nat_of_P 1 = 1.
+Proof.
+  reflexivity.
+Qed.
+
+Lemma nat_of_P_xO : forall p:positive, nat_of_P (xO p) = 2 * nat_of_P p.
+Proof.
+  simple induction p. unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute.
+  rewrite Pmult_nat_4_mult_2_permute. rewrite H. simpl in |- *. rewrite <- plus_Snm_nSm. reflexivity.
+  unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute. rewrite Pmult_nat_4_mult_2_permute.
+  rewrite H. reflexivity.
+  reflexivity.
+Qed.
+
+Lemma nat_of_P_xI : forall p:positive, nat_of_P (xI p) = S (2 * nat_of_P p).
+Proof.
+  simple induction p. unfold nat_of_P in |- *. simpl in |- *. intro p0. intro. rewrite Pmult_nat_2_mult_2_permute.
+  rewrite Pmult_nat_4_mult_2_permute; injection H; intro H1; rewrite H1;
+   rewrite <- plus_Snm_nSm; reflexivity.
+  unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute. rewrite Pmult_nat_4_mult_2_permute.
+  injection H; intro H1; rewrite H1; reflexivity.
+  reflexivity.
+Qed.
+
+(**********************************************************************)
+(** Properties of the shifted injection from Peano natural numbers to 
+    binary positive numbers *)
+
+(** Composition of [P_of_succ_nat] and [nat_of_P] is successor on [nat] *)
+
+Theorem nat_of_P_o_P_of_succ_nat_eq_succ :
+ forall n:nat, nat_of_P (P_of_succ_nat n) = S n.
+Proof.
+intro m; induction m as [| n H];
+ [ reflexivity
+ | simpl in |- *; rewrite nat_of_P_succ_morphism; rewrite H; auto ].
+Qed.
+
+(** Miscellaneous lemmas on [P_of_succ_nat] *)
+
+Lemma ZL3 :
+ forall n:nat, Psucc (P_of_succ_nat (n + n)) = xO (P_of_succ_nat n).
+Proof.
+intro x; induction x as [| n H];
+ [ simpl in |- *; auto with arith
+ | simpl in |- *; rewrite plus_comm; simpl in |- *; rewrite H;
+    rewrite xO_succ_permute; auto with arith ].
+Qed.
+
+Lemma ZL5 : forall n:nat, P_of_succ_nat (S n + S n) = xI (P_of_succ_nat n).
+Proof.
+intro x; induction x as [| n H]; simpl in |- *;
+ [ auto with arith
+ | rewrite <- plus_n_Sm; simpl in |- *; simpl in H; rewrite H;
+    auto with arith ].
+Qed.
+
+(** Composition of [nat_of_P] and [P_of_succ_nat] is successor on [positive] *)
+
+Theorem P_of_succ_nat_o_nat_of_P_eq_succ :
+ forall p:positive, P_of_succ_nat (nat_of_P p) = Psucc p.
+Proof.
+intro x; induction x as [p H| p H| ];
+ [ simpl in |- *; rewrite <- H; change 2 with (1 + 1) in |- *;
+    rewrite Pmult_nat_r_plus_morphism; elim (ZL4 p); 
+    unfold nat_of_P in |- *; intros n H1; rewrite H1; 
+    rewrite ZL3; auto with arith
+ | unfold nat_of_P in |- *; simpl in |- *; change 2 with (1 + 1) in |- *;
+    rewrite Pmult_nat_r_plus_morphism;
+    rewrite <- (Ppred_succ (P_of_succ_nat (Pmult_nat p 1 + Pmult_nat p 1)));
+    rewrite <- (Ppred_succ (xI p)); simpl in |- *; 
+    rewrite <- H; elim (ZL4 p); unfold nat_of_P in |- *; 
+    intros n H1; rewrite H1; rewrite ZL5; simpl in |- *; 
+    trivial with arith
+ | unfold nat_of_P in |- *; simpl in |- *; auto with arith ].
+Qed.
+
+(** Composition of [nat_of_P], [P_of_succ_nat] and [Ppred] is identity
+    on [positive] *)
+
+Theorem pred_o_P_of_succ_nat_o_nat_of_P_eq_id :
+ forall p:positive, Ppred (P_of_succ_nat (nat_of_P p)) = p.
+Proof.
+intros x; rewrite P_of_succ_nat_o_nat_of_P_eq_succ; rewrite Ppred_succ;
+ trivial with arith.
+Qed.
+
+(**********************************************************************)
+(** Extra properties of the injection from binary positive numbers to Peano 
+    natural numbers *)
+
+(** [nat_of_P] is a morphism for subtraction on positive numbers *)
+
+Theorem nat_of_P_minus_morphism :
+ forall p q:positive,
+   (p ?= q)%positive Eq = Gt -> nat_of_P (p - q) = nat_of_P p - nat_of_P q.
+Proof.
+intros x y H; apply plus_reg_l with (nat_of_P y); rewrite le_plus_minus_r;
+ [ rewrite <- nat_of_P_plus_morphism; rewrite Pplus_minus; auto with arith
+ | apply lt_le_weak; exact (nat_of_P_gt_Gt_compare_morphism x y H) ].
+Qed.
+
+(** [nat_of_P] is injective *)
+
+Lemma nat_of_P_inj : forall p q:positive, nat_of_P p = nat_of_P q -> p = q.
+Proof.
+intros x y H; rewrite <- (pred_o_P_of_succ_nat_o_nat_of_P_eq_id x);
+ rewrite <- (pred_o_P_of_succ_nat_o_nat_of_P_eq_id y); 
+ rewrite H; trivial with arith.
+Qed.
+
+Lemma ZL16 : forall p q:positive, nat_of_P p - nat_of_P q < nat_of_P p.
+Proof.
+intros p q; elim (ZL4 p); elim (ZL4 q); intros h H1 i H2; rewrite H1;
+ rewrite H2; simpl in |- *; unfold lt in |- *; apply le_n_S; 
+ apply le_minus.
+Qed.
+
+Lemma ZL17 : forall p q:positive, nat_of_P p < nat_of_P (p + q).
+Proof.
+intros p q; rewrite nat_of_P_plus_morphism; unfold lt in |- *; elim (ZL4 q);
+ intros k H; rewrite H; rewrite plus_comm; simpl in |- *; 
+ apply le_n_S; apply le_plus_r.
+Qed.
+
+(** Comparison and subtraction *)
+
+Lemma Pcompare_minus_r :
+ forall p q r:positive,
+   (q ?= p)%positive Eq = Lt ->
+   (r ?= p)%positive Eq = Gt ->
+   (r ?= q)%positive Eq = Gt -> (r - p ?= r - q)%positive Eq = Lt.
+Proof.
+intros; apply nat_of_P_lt_Lt_compare_complement_morphism;
+ rewrite nat_of_P_minus_morphism;
+ [ rewrite nat_of_P_minus_morphism;
+    [ apply plus_lt_reg_l with (p := nat_of_P q); rewrite le_plus_minus_r;
+       [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p);
+          rewrite plus_assoc; rewrite le_plus_minus_r;
+          [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l;
+             apply nat_of_P_lt_Lt_compare_morphism; 
+             assumption
+          | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+             apply ZC1; assumption ]
+       | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1;
+          assumption ]
+    | assumption ]
+ | assumption ].
+Qed.
+
+Lemma Pcompare_minus_l :
+ forall p q r:positive,
+   (q ?= p)%positive Eq = Lt ->
+   (p ?= r)%positive Eq = Gt ->
+   (q ?= r)%positive Eq = Gt -> (q - r ?= p - r)%positive Eq = Lt.
+Proof.
+intros p q z; intros; apply nat_of_P_lt_Lt_compare_complement_morphism;
+ rewrite nat_of_P_minus_morphism;
+ [ rewrite nat_of_P_minus_morphism;
+    [ unfold gt in |- *; apply plus_lt_reg_l with (p := nat_of_P z);
+       rewrite le_plus_minus_r;
+       [ rewrite le_plus_minus_r;
+          [ apply nat_of_P_lt_Lt_compare_morphism; assumption
+          | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+             apply ZC1; assumption ]
+       | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1;
+          assumption ]
+    | assumption ]
+ | assumption ].
+Qed.
+
+(** Distributivity of multiplication over subtraction *)
+
+Theorem Pmult_minus_distr_l :
+ forall p q r:positive,
+   (q ?= r)%positive Eq = Gt ->
+   (p * (q - r))%positive = (p * q - p * r)%positive.
+Proof.
+intros x y z H; apply nat_of_P_inj; rewrite nat_of_P_mult_morphism;
+ rewrite nat_of_P_minus_morphism;
+ [ rewrite nat_of_P_minus_morphism;
+    [ do 2 rewrite nat_of_P_mult_morphism;
+       do 3 rewrite (mult_comm (nat_of_P x)); apply mult_minus_distr_r
+    | apply nat_of_P_gt_Gt_compare_complement_morphism;
+       do 2 rewrite nat_of_P_mult_morphism; unfold gt in |- *; 
+       elim (ZL4 x); intros h H1; rewrite H1; apply mult_S_lt_compat_l;
+       exact (nat_of_P_gt_Gt_compare_morphism y z H) ]
+ | assumption ].
+Qed.
diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v
new file mode 100644
index 00000000..a691b189
--- /dev/null
+++ b/theories/Reals/Alembert.v
@@ -0,0 +1,726 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Alembert.v,v 1.14.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import SeqProp.
+Require Import PartSum.
+Require Import Max.
+
+Open Local Scope R_scope.
+
+(***************************************************)
+(* Various versions of the criterion of D'Alembert *)
+(***************************************************)
+
+Lemma Alembert_C1 :
+ forall An:nat -> R,
+   (forall n:nat, 0 < An n) ->
+   Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
+   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+intros An H H0.
+cut
+ (sigT (fun l:R => is_lub (EUn (fun N:nat => sum_f_R0 An N)) l) ->
+  sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)).
+intro; apply X.
+apply completeness.
+unfold Un_cv in H0; unfold bound in |- *; cut (0 < / 2);
+ [ intro | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (H0 (/ 2) H1); intros.
+exists (sum_f_R0 An x + 2 * An (S x)).
+unfold is_upper_bound in |- *; intros; unfold EUn in H3; elim H3; intros.
+rewrite H4; assert (H5 := lt_eq_lt_dec x1 x).
+elim H5; intros.
+elim a; intro.
+replace (sum_f_R0 An x) with
+ (sum_f_R0 An x1 + sum_f_R0 (fun i:nat => An (S x1 + i)%nat) (x - S x1)).
+pattern (sum_f_R0 An x1) at 1 in |- *; rewrite <- Rplus_0_r;
+ rewrite Rplus_assoc; apply Rplus_le_compat_l.
+left; apply Rplus_lt_0_compat.
+apply tech1; intros; apply H.
+apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
+symmetry  in |- *; apply tech2; assumption.
+rewrite b; pattern (sum_f_R0 An x) at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_le_compat_l.
+left; apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
+replace (sum_f_R0 An x1) with
+ (sum_f_R0 An x + sum_f_R0 (fun i:nat => An (S x + i)%nat) (x1 - S x)).
+apply Rplus_le_compat_l.
+cut
+ (sum_f_R0 (fun i:nat => An (S x + i)%nat) (x1 - S x) <=
+  An (S x) * sum_f_R0 (fun i:nat => (/ 2) ^ i) (x1 - S x)).
+intro;
+ apply Rle_trans with
+  (An (S x) * sum_f_R0 (fun i:nat => (/ 2) ^ i) (x1 - S x)).
+assumption.
+rewrite <- (Rmult_comm (An (S x))); apply Rmult_le_compat_l.
+left; apply H.
+rewrite tech3.
+replace (1 - / 2) with (/ 2).
+unfold Rdiv in |- *; rewrite Rinv_involutive.
+pattern 2 at 3 in |- *; rewrite <- Rmult_1_r; rewrite <- (Rmult_comm 2);
+ apply Rmult_le_compat_l.
+left; prove_sup0.
+left; apply Rplus_lt_reg_r with ((/ 2) ^ S (x1 - S x)).
+replace ((/ 2) ^ S (x1 - S x) + (1 - (/ 2) ^ S (x1 - S x))) with 1;
+ [ idtac | ring ].
+rewrite <- (Rplus_comm 1); pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_lt_compat_l.
+apply pow_lt; apply Rinv_0_lt_compat; prove_sup0.
+discrR.
+apply Rmult_eq_reg_l with 2.
+rewrite Rmult_minus_distr_l; rewrite <- Rinv_r_sym.
+ring.
+discrR.
+discrR.
+pattern 1 at 3 in |- *; replace 1 with (/ 1);
+ [ apply tech7; discrR | apply Rinv_1 ].
+replace (An (S x)) with (An (S x + 0)%nat).
+apply (tech6 (fun i:nat => An (S x + i)%nat) (/ 2)).
+left; apply Rinv_0_lt_compat; prove_sup0.
+intro; cut (forall n:nat, (n >= x)%nat -> An (S n) < / 2 * An n).
+intro; replace (S x + S i)%nat with (S (S x + i)).
+apply H6; unfold ge in |- *; apply tech8.
+apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
+intros; unfold R_dist in H2; apply Rmult_lt_reg_l with (/ An n).
+apply Rinv_0_lt_compat; apply H.
+do 2 rewrite (Rmult_comm (/ An n)); rewrite Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r;
+ replace (An (S n) * / An n) with (Rabs (Rabs (An (S n) / An n) - 0)).
+apply H2; assumption.
+unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+ rewrite Rabs_Rabsolu; rewrite Rabs_right.
+unfold Rdiv in |- *; reflexivity.
+left; unfold Rdiv in |- *; change (0 < An (S n) * / An n) in |- *;
+ apply Rmult_lt_0_compat; [ apply H | apply Rinv_0_lt_compat; apply H ].
+red in |- *; intro; assert (H8 := H n); rewrite H7 in H8;
+ elim (Rlt_irrefl _ H8).
+replace (S x + 0)%nat with (S x); [ reflexivity | ring ].
+symmetry  in |- *; apply tech2; assumption.
+exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
+intro; elim X; intros.
+apply existT with x; apply tech10;
+ [ unfold Un_growing in |- *; intro; rewrite tech5;
+    pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_le_compat_l; left; apply H
+ | apply p ].
+Qed.
+
+Lemma Alembert_C2 :
+ forall An:nat -> R,
+   (forall n:nat, An n <> 0) ->
+   Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
+   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+intros.
+set (Vn := fun i:nat => (2 * Rabs (An i) + An i) / 2).
+set (Wn := fun i:nat => (2 * Rabs (An i) - An i) / 2).
+cut (forall n:nat, 0 < Vn n).
+intro; cut (forall n:nat, 0 < Wn n).
+intro; cut (Un_cv (fun n:nat => Rabs (Vn (S n) / Vn n)) 0).
+intro; cut (Un_cv (fun n:nat => Rabs (Wn (S n) / Wn n)) 0).
+intro; assert (H5 := Alembert_C1 Vn H1 H3).
+assert (H6 := Alembert_C1 Wn H2 H4).
+elim H5; intros.
+elim H6; intros.
+apply existT with (x - x0); unfold Un_cv in |- *; unfold Un_cv in p;
+ unfold Un_cv in p0; intros; cut (0 < eps / 2).
+intro; elim (p (eps / 2) H8); clear p; intros.
+elim (p0 (eps / 2) H8); clear p0; intros.
+set (N := max x1 x2).
+exists N; intros;
+ replace (sum_f_R0 An n) with (sum_f_R0 Vn n - sum_f_R0 Wn n).
+unfold R_dist in |- *;
+ replace (sum_f_R0 Vn n - sum_f_R0 Wn n - (x - x0)) with
+  (sum_f_R0 Vn n - x + - (sum_f_R0 Wn n - x0)); [ idtac | ring ];
+ apply Rle_lt_trans with
+  (Rabs (sum_f_R0 Vn n - x) + Rabs (- (sum_f_R0 Wn n - x0))).
+apply Rabs_triang.
+rewrite Rabs_Ropp; apply Rlt_le_trans with (eps / 2 + eps / 2).
+apply Rplus_lt_compat.
+unfold R_dist in H9; apply H9; unfold ge in |- *; apply le_trans with N;
+ [ unfold N in |- *; apply le_max_l | assumption ].
+unfold R_dist in H10; apply H10; unfold ge in |- *; apply le_trans with N;
+ [ unfold N in |- *; apply le_max_r | assumption ].
+right; symmetry  in |- *; apply double_var.
+symmetry  in |- *; apply tech11; intro; unfold Vn, Wn in |- *;
+ unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ 2));
+ apply Rmult_eq_reg_l with 2.
+rewrite Rmult_minus_distr_l; repeat rewrite <- Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+ring.
+discrR.
+discrR.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+cut (forall n:nat, / 2 * Rabs (An n) <= Wn n <= 3 * / 2 * Rabs (An n)).
+intro; cut (forall n:nat, / Wn n <= 2 * / Rabs (An n)).
+intro; cut (forall n:nat, Wn (S n) / Wn n <= 3 * Rabs (An (S n) / An n)).
+intro; unfold Un_cv in |- *; intros; unfold Un_cv in H0; cut (0 < eps / 3).
+intro; elim (H0 (eps / 3) H8); intros.
+exists x; intros.
+assert (H11 := H9 n H10).
+unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold R_dist in H11;
+ unfold Rminus in H11; rewrite Ropp_0 in H11; rewrite Rplus_0_r in H11;
+ rewrite Rabs_Rabsolu in H11; rewrite Rabs_right.
+apply Rle_lt_trans with (3 * Rabs (An (S n) / An n)).
+apply H6.
+apply Rmult_lt_reg_l with (/ 3).
+apply Rinv_0_lt_compat; prove_sup0.
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ];
+ rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H11;
+ exact H11.
+left; change (0 < Wn (S n) / Wn n) in |- *; unfold Rdiv in |- *;
+ apply Rmult_lt_0_compat.
+apply H2.
+apply Rinv_0_lt_compat; apply H2.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+intro; unfold Rdiv in |- *; rewrite Rabs_mult; rewrite <- Rmult_assoc;
+ replace 3 with (2 * (3 * / 2));
+ [ idtac | rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR ];
+ apply Rle_trans with (Wn (S n) * 2 * / Rabs (An n)).
+rewrite Rmult_assoc; apply Rmult_le_compat_l.
+left; apply H2.
+apply H5.
+rewrite Rabs_Rinv.
+replace (Wn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Wn (S n));
+ [ idtac | ring ];
+ replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with
+  (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); 
+ [ idtac | ring ]; apply Rmult_le_compat_l.
+left; apply Rmult_lt_0_compat.
+prove_sup0.
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply H.
+elim (H4 (S n)); intros; assumption.
+apply H.
+intro; apply Rmult_le_reg_l with (Wn n).
+apply H2.
+rewrite <- Rinv_r_sym.
+apply Rmult_le_reg_l with (Rabs (An n)).
+apply Rabs_pos_lt; apply H.
+rewrite Rmult_1_r;
+ replace (Rabs (An n) * (Wn n * (2 * / Rabs (An n)))) with
+  (2 * Wn n * (Rabs (An n) * / Rabs (An n))); [ idtac | ring ];
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; apply Rmult_le_reg_l with (/ 2).
+apply Rinv_0_lt_compat; prove_sup0.
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; elim (H4 n); intros; assumption.
+discrR.
+apply Rabs_no_R0; apply H.
+red in |- *; intro; assert (H6 := H2 n); rewrite H5 in H6;
+ elim (Rlt_irrefl _ H6).
+intro; split.
+unfold Wn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+ apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; prove_sup0.
+pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double;
+ unfold Rminus in |- *; rewrite Rplus_assoc; apply Rplus_le_compat_l.
+apply Rplus_le_reg_l with (An n).
+rewrite Rplus_0_r; rewrite (Rplus_comm (An n)); rewrite Rplus_assoc;
+ rewrite Rplus_opp_l; rewrite Rplus_0_r; apply RRle_abs.
+unfold Wn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
+ repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; prove_sup0.
+unfold Rminus in |- *; rewrite double;
+ replace (3 * Rabs (An n)) with (Rabs (An n) + Rabs (An n) + Rabs (An n));
+ [ idtac | ring ]; repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
+rewrite <- Rabs_Ropp; apply RRle_abs.
+cut (forall n:nat, / 2 * Rabs (An n) <= Vn n <= 3 * / 2 * Rabs (An n)).
+intro; cut (forall n:nat, / Vn n <= 2 * / Rabs (An n)).
+intro; cut (forall n:nat, Vn (S n) / Vn n <= 3 * Rabs (An (S n) / An n)).
+intro; unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / 3).
+intro; elim (H0 (eps / 3) H7); intros.
+exists x; intros.
+assert (H10 := H8 n H9).
+unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold R_dist in H10;
+ unfold Rminus in H10; rewrite Ropp_0 in H10; rewrite Rplus_0_r in H10;
+ rewrite Rabs_Rabsolu in H10; rewrite Rabs_right.
+apply Rle_lt_trans with (3 * Rabs (An (S n) / An n)).
+apply H5.
+apply Rmult_lt_reg_l with (/ 3).
+apply Rinv_0_lt_compat; prove_sup0.
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ];
+ rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H10;
+ exact H10.
+left; change (0 < Vn (S n) / Vn n) in |- *; unfold Rdiv in |- *;
+ apply Rmult_lt_0_compat.
+apply H1.
+apply Rinv_0_lt_compat; apply H1.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+intro; unfold Rdiv in |- *; rewrite Rabs_mult; rewrite <- Rmult_assoc;
+ replace 3 with (2 * (3 * / 2));
+ [ idtac | rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR ];
+ apply Rle_trans with (Vn (S n) * 2 * / Rabs (An n)).
+rewrite Rmult_assoc; apply Rmult_le_compat_l.
+left; apply H1.
+apply H4.
+rewrite Rabs_Rinv.
+replace (Vn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Vn (S n));
+ [ idtac | ring ];
+ replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with
+  (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); 
+ [ idtac | ring ]; apply Rmult_le_compat_l.
+left; apply Rmult_lt_0_compat.
+prove_sup0.
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply H.
+elim (H3 (S n)); intros; assumption.
+apply H.
+intro; apply Rmult_le_reg_l with (Vn n).
+apply H1.
+rewrite <- Rinv_r_sym.
+apply Rmult_le_reg_l with (Rabs (An n)).
+apply Rabs_pos_lt; apply H.
+rewrite Rmult_1_r;
+ replace (Rabs (An n) * (Vn n * (2 * / Rabs (An n)))) with
+  (2 * Vn n * (Rabs (An n) * / Rabs (An n))); [ idtac | ring ];
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; apply Rmult_le_reg_l with (/ 2).
+apply Rinv_0_lt_compat; prove_sup0.
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; elim (H3 n); intros; assumption.
+discrR.
+apply Rabs_no_R0; apply H.
+red in |- *; intro; assert (H5 := H1 n); rewrite H4 in H5;
+ elim (Rlt_irrefl _ H5).
+intro; split.
+unfold Vn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+ apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; prove_sup0.
+pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double;
+ rewrite Rplus_assoc; apply Rplus_le_compat_l.
+apply Rplus_le_reg_l with (- An n); rewrite Rplus_0_r;
+ rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc; 
+ rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp; 
+ apply RRle_abs.
+unfold Vn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
+ repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; prove_sup0.
+unfold Rminus in |- *; rewrite double;
+ replace (3 * Rabs (An n)) with (Rabs (An n) + Rabs (An n) + Rabs (An n));
+ [ idtac | ring ]; repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l;
+ apply RRle_abs.
+intro; unfold Wn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_0_r (/ 2));
+ rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
+apply Rinv_0_lt_compat; prove_sup0.
+apply Rplus_lt_reg_r with (An n); rewrite Rplus_0_r; unfold Rminus in |- *;
+ rewrite (Rplus_comm (An n)); rewrite Rplus_assoc; 
+ rewrite Rplus_opp_l; rewrite Rplus_0_r;
+ apply Rle_lt_trans with (Rabs (An n)).
+apply RRle_abs.
+rewrite double; pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H.
+intro; unfold Vn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_0_r (/ 2));
+ rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
+apply Rinv_0_lt_compat; prove_sup0.
+apply Rplus_lt_reg_r with (- An n); rewrite Rplus_0_r; unfold Rminus in |- *;
+ rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc; 
+ rewrite Rplus_opp_r; rewrite Rplus_0_r;
+ apply Rle_lt_trans with (Rabs (An n)).
+rewrite <- Rabs_Ropp; apply RRle_abs.
+rewrite double; pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H.
+Qed.
+
+Lemma AlembertC3_step1 :
+ forall (An:nat -> R) (x:R),
+   x <> 0 ->
+   (forall n:nat, An n <> 0) ->
+   Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
+   sigT (fun l:R => Pser An x l).
+intros; set (Bn := fun i:nat => An i * x ^ i).
+cut (forall n:nat, Bn n <> 0).
+intro; cut (Un_cv (fun n:nat => Rabs (Bn (S n) / Bn n)) 0).
+intro; assert (H4 := Alembert_C2 Bn H2 H3).
+elim H4; intros.
+apply existT with x0; unfold Bn in p; apply tech12; assumption.
+unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / Rabs x).
+intro; elim (H1 (eps / Rabs x) H4); intros.
+exists x0; intros; unfold R_dist in |- *; unfold Rminus in |- *;
+ rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
+ unfold Bn in |- *;
+ replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
+rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs x).
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+rewrite <- (Rmult_comm (Rabs x)); rewrite <- Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H5;
+ replace (Rabs (An (S n) / An n)) with (R_dist (Rabs (An (S n) * / An n)) 0).
+apply H5; assumption.
+unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv in |- *; 
+ reflexivity.
+apply Rabs_no_R0; assumption.
+replace (S n) with (n + 1)%nat; [ idtac | ring ]; rewrite pow_add;
+ unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+replace (An (n + 1)%nat * (x ^ n * x ^ 1) * (/ An n * / x ^ n)) with
+ (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n)); 
+ [ idtac | ring ]; rewrite <- Rinv_r_sym.
+simpl in |- *; ring.
+apply pow_nonzero; assumption.
+apply H0.
+apply pow_nonzero; assumption.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
+intro; unfold Bn in |- *; apply prod_neq_R0;
+ [ apply H0 | apply pow_nonzero; assumption ].
+Qed.
+
+Lemma AlembertC3_step2 :
+ forall (An:nat -> R) (x:R), x = 0 -> sigT (fun l:R => Pser An x l).
+intros; apply existT with (An 0%nat).
+unfold Pser in |- *; unfold infinit_sum in |- *; intros; exists 0%nat; intros;
+ replace (sum_f_R0 (fun n0:nat => An n0 * x ^ n0) n) with (An 0%nat).
+unfold R_dist in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rabs_R0; assumption.
+induction  n as [| n Hrecn].
+simpl in |- *; ring.
+rewrite tech5; rewrite Hrecn;
+ [ rewrite H; simpl in |- *; ring | unfold ge in |- *; apply le_O_n ].
+Qed.
+
+(* An useful criterion of convergence for power series *)
+Theorem Alembert_C3 :
+ forall (An:nat -> R) (x:R),
+   (forall n:nat, An n <> 0) ->
+   Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
+   sigT (fun l:R => Pser An x l).
+intros; case (total_order_T x 0); intro.
+elim s; intro.
+cut (x <> 0).
+intro; apply AlembertC3_step1; assumption.
+red in |- *; intro; rewrite H1 in a; elim (Rlt_irrefl _ a).
+apply AlembertC3_step2; assumption.
+cut (x <> 0).
+intro; apply AlembertC3_step1; assumption.
+red in |- *; intro; rewrite H1 in r; elim (Rlt_irrefl _ r).
+Qed.
+
+Lemma Alembert_C4 :
+ forall (An:nat -> R) (k:R),
+   0 <= k < 1 ->
+   (forall n:nat, 0 < An n) ->
+   Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
+   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+intros An k Hyp H H0.
+cut
+ (sigT (fun l:R => is_lub (EUn (fun N:nat => sum_f_R0 An N)) l) ->
+  sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)).
+intro; apply X.
+apply completeness.
+assert (H1 := tech13 _ _ Hyp H0).
+elim H1; intros.
+elim H2; intros.
+elim H4; intros.
+unfold bound in |- *; exists (sum_f_R0 An x0 + / (1 - x) * An (S x0)).
+unfold is_upper_bound in |- *; intros; unfold EUn in H6.
+elim H6; intros.
+rewrite H7.
+assert (H8 := lt_eq_lt_dec x2 x0).
+elim H8; intros.
+elim a; intro.
+replace (sum_f_R0 An x0) with
+ (sum_f_R0 An x2 + sum_f_R0 (fun i:nat => An (S x2 + i)%nat) (x0 - S x2)).
+pattern (sum_f_R0 An x2) at 1 in |- *; rewrite <- Rplus_0_r.
+rewrite Rplus_assoc; apply Rplus_le_compat_l.
+left; apply Rplus_lt_0_compat.
+apply tech1.
+intros; apply H.
+apply Rmult_lt_0_compat.
+apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
+ replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
+apply H.
+symmetry  in |- *; apply tech2; assumption.
+rewrite b; pattern (sum_f_R0 An x0) at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_le_compat_l.
+left; apply Rmult_lt_0_compat.
+apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
+ replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
+apply H.
+replace (sum_f_R0 An x2) with
+ (sum_f_R0 An x0 + sum_f_R0 (fun i:nat => An (S x0 + i)%nat) (x2 - S x0)).
+apply Rplus_le_compat_l.
+cut
+ (sum_f_R0 (fun i:nat => An (S x0 + i)%nat) (x2 - S x0) <=
+  An (S x0) * sum_f_R0 (fun i:nat => x ^ i) (x2 - S x0)).
+intro;
+ apply Rle_trans with (An (S x0) * sum_f_R0 (fun i:nat => x ^ i) (x2 - S x0)).
+assumption.
+rewrite <- (Rmult_comm (An (S x0))); apply Rmult_le_compat_l.
+left; apply H.
+rewrite tech3.
+unfold Rdiv in |- *; apply Rmult_le_reg_l with (1 - x).
+apply Rplus_lt_reg_r with x; rewrite Rplus_0_r.
+replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
+do 2 rewrite (Rmult_comm (1 - x)).
+rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; apply Rplus_le_reg_l with (x ^ S (x2 - S x0)).
+replace (x ^ S (x2 - S x0) + (1 - x ^ S (x2 - S x0))) with 1;
+ [ idtac | ring ].
+rewrite <- (Rplus_comm 1); pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_le_compat_l.
+left; apply pow_lt.
+apply Rle_lt_trans with k.
+elim Hyp; intros; assumption.
+elim H3; intros; assumption.
+apply Rminus_eq_contra.
+red in |- *; intro.
+elim H3; intros.
+rewrite H10 in H12; elim (Rlt_irrefl _ H12).
+red in |- *; intro.
+elim H3; intros.
+rewrite H10 in H12; elim (Rlt_irrefl _ H12).
+replace (An (S x0)) with (An (S x0 + 0)%nat).
+apply (tech6 (fun i:nat => An (S x0 + i)%nat) x).
+left; apply Rle_lt_trans with k.
+elim Hyp; intros; assumption.
+elim H3; intros; assumption.
+intro.
+cut (forall n:nat, (n >= x0)%nat -> An (S n) < x * An n).
+intro.
+replace (S x0 + S i)%nat with (S (S x0 + i)).
+apply H9.
+unfold ge in |- *.
+apply tech8.
+  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR;
+   ring.
+intros.
+apply Rmult_lt_reg_l with (/ An n).
+apply Rinv_0_lt_compat; apply H.
+do 2 rewrite (Rmult_comm (/ An n)).
+rewrite Rmult_assoc.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r.
+replace (An (S n) * / An n) with (Rabs (An (S n) / An n)).
+apply H5; assumption.
+rewrite Rabs_right.
+unfold Rdiv in |- *; reflexivity.
+left; unfold Rdiv in |- *; change (0 < An (S n) * / An n) in |- *;
+ apply Rmult_lt_0_compat.
+apply H.
+apply Rinv_0_lt_compat; apply H.
+red in |- *; intro.
+assert (H11 := H n).
+rewrite H10 in H11; elim (Rlt_irrefl _ H11).
+replace (S x0 + 0)%nat with (S x0); [ reflexivity | ring ].
+symmetry  in |- *; apply tech2; assumption.
+exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
+intro; elim X; intros.
+apply existT with x; apply tech10;
+ [ unfold Un_growing in |- *; intro; rewrite tech5;
+    pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_le_compat_l; left; apply H
+ | apply p ].
+Qed.
+
+Lemma Alembert_C5 :
+ forall (An:nat -> R) (k:R),
+   0 <= k < 1 ->
+   (forall n:nat, An n <> 0) ->
+   Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
+   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+intros.
+cut
+ (sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l) ->
+  sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)).
+intro Hyp0; apply Hyp0.
+apply cv_cauchy_2.
+apply cauchy_abs.
+apply cv_cauchy_1.
+cut
+ (sigT
+    (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l) ->
+  sigT
+    (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l)).
+intro Hyp; apply Hyp.
+apply (Alembert_C4 (fun i:nat => Rabs (An i)) k).
+assumption.
+intro; apply Rabs_pos_lt; apply H0.
+unfold Un_cv in |- *.
+unfold Un_cv in H1.
+unfold Rdiv in |- *.
+intros.
+elim (H1 eps H2); intros.
+exists x; intros.
+rewrite <- Rabs_Rinv.
+rewrite <- Rabs_mult.
+rewrite Rabs_Rabsolu.
+unfold Rdiv in H3; apply H3; assumption.
+apply H0.
+intro.
+elim X; intros.
+apply existT with x.
+assumption.
+intro.
+elim X; intros.
+apply existT with x.
+assumption.
+Qed.
+
+(* Convergence of power series in D(O,1/k) *)
+(*     k=0 is described in Alembert_C3     *)
+Lemma Alembert_C6 :
+ forall (An:nat -> R) (x k:R),
+   0 < k ->
+   (forall n:nat, An n <> 0) ->
+   Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
+   Rabs x < / k -> sigT (fun l:R => Pser An x l).
+intros.
+cut
+ (sigT
+    (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l)).
+intro.
+elim X; intros.
+apply existT with x0.
+apply tech12; assumption.
+case (total_order_T x 0); intro.
+elim s; intro.
+eapply Alembert_C5 with (k * Rabs x).
+split.
+unfold Rdiv in |- *; apply Rmult_le_pos.
+left; assumption.
+left; apply Rabs_pos_lt.
+red in |- *; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
+apply Rmult_lt_reg_l with (/ k).
+apply Rinv_0_lt_compat; assumption.
+rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+rewrite Rmult_1_r; assumption.
+red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
+intro; apply prod_neq_R0.
+apply H0.
+apply pow_nonzero.
+red in |- *; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
+unfold Un_cv in |- *; unfold Un_cv in H1.
+intros.
+cut (0 < eps / Rabs x).
+intro.
+elim (H1 (eps / Rabs x) H4); intros.
+exists x0.
+intros.
+replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
+unfold R_dist in |- *.
+rewrite Rabs_mult.
+replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with
+ (Rabs x * (Rabs (An (S n) / An n) - k)); [ idtac | ring ].
+rewrite Rabs_mult.
+rewrite Rabs_Rabsolu.
+apply Rmult_lt_reg_l with (/ Rabs x).
+apply Rinv_0_lt_compat; apply Rabs_pos_lt.
+red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+rewrite <- (Rmult_comm eps).
+unfold R_dist in H5.
+unfold Rdiv in |- *; unfold Rdiv in H5; apply H5; assumption.
+apply Rabs_no_R0.
+red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+unfold Rdiv in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+rewrite pow_add.
+simpl in |- *.
+rewrite Rmult_1_r.
+rewrite Rinv_mult_distr.
+replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
+ (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); 
+ [ idtac | ring ].
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; reflexivity.
+apply pow_nonzero.
+red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+apply H0.
+apply pow_nonzero.
+red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+assumption.
+apply Rinv_0_lt_compat; apply Rabs_pos_lt.
+red in |- *; intro H7; rewrite H7 in a; elim (Rlt_irrefl _ a).
+apply existT with (An 0%nat).
+unfold Un_cv in |- *.
+intros.
+exists 0%nat.
+intros.
+unfold R_dist in |- *.
+replace (sum_f_R0 (fun i:nat => An i * x ^ i) n) with (An 0%nat).
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+induction  n as [| n Hrecn].
+simpl in |- *; ring.
+rewrite tech5.
+rewrite <- Hrecn.
+rewrite b; simpl in |- *; ring.
+unfold ge in |- *; apply le_O_n.
+eapply Alembert_C5 with (k * Rabs x).
+split.
+unfold Rdiv in |- *; apply Rmult_le_pos.
+left; assumption.
+left; apply Rabs_pos_lt.
+red in |- *; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
+apply Rmult_lt_reg_l with (/ k).
+apply Rinv_0_lt_compat; assumption.
+rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+rewrite Rmult_1_r; assumption.
+red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
+intro; apply prod_neq_R0.
+apply H0.
+apply pow_nonzero.
+red in |- *; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
+unfold Un_cv in |- *; unfold Un_cv in H1.
+intros.
+cut (0 < eps / Rabs x).
+intro.
+elim (H1 (eps / Rabs x) H4); intros.
+exists x0.
+intros.
+replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
+unfold R_dist in |- *.
+rewrite Rabs_mult.
+replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with
+ (Rabs x * (Rabs (An (S n) / An n) - k)); [ idtac | ring ].
+rewrite Rabs_mult.
+rewrite Rabs_Rabsolu.
+apply Rmult_lt_reg_l with (/ Rabs x).
+apply Rinv_0_lt_compat; apply Rabs_pos_lt.
+red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+rewrite <- (Rmult_comm eps).
+unfold R_dist in H5.
+unfold Rdiv in |- *; unfold Rdiv in H5; apply H5; assumption.
+apply Rabs_no_R0.
+red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+unfold Rdiv in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+rewrite pow_add.
+simpl in |- *.
+rewrite Rmult_1_r.
+rewrite Rinv_mult_distr.
+replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
+ (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); 
+ [ idtac | ring ].
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; reflexivity.
+apply pow_nonzero.
+red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+apply H0.
+apply pow_nonzero.
+red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+assumption.
+apply Rinv_0_lt_compat; apply Rabs_pos_lt.
+red in |- *; intro H7; rewrite H7 in r; elim (Rlt_irrefl _ r).
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v
new file mode 100644
index 00000000..166a8a46
--- /dev/null
+++ b/theories/Reals/AltSeries.v
@@ -0,0 +1,448 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: AltSeries.v,v 1.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import SeqProp.
+Require Import PartSum.
+Require Import Max.
+Open Local Scope R_scope.
+
+(**********)
+Definition tg_alt (Un:nat -> R) (i:nat) : R := (-1) ^ i * Un i.
+Definition positivity_seq (Un:nat -> R) : Prop := forall n:nat, 0 <= Un n.
+
+Lemma CV_ALT_step0 :
+ forall Un:nat -> R,
+   Un_decreasing Un ->
+   Un_growing (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
+intros; unfold Un_growing in |- *; intro.
+cut ((2 * S n)%nat = S (S (2 * n))).
+intro; rewrite H0.
+do 4 rewrite tech5; repeat rewrite Rplus_assoc; apply Rplus_le_compat_l.
+pattern (tg_alt Un (S (2 * n))) at 1 in |- *; rewrite <- Rplus_0_r.
+apply Rplus_le_compat_l.
+unfold tg_alt in |- *; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
+ rewrite Rmult_1_l.
+apply Rplus_le_reg_l with (Un (S (2 * S n))).
+rewrite Rplus_0_r;
+ replace (Un (S (2 * S n)) + (Un (2 * S n)%nat + -1 * Un (S (2 * S n)))) with
+  (Un (2 * S n)%nat); [ idtac | ring ].
+apply H.
+cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
+rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
+Qed.
+
+Lemma CV_ALT_step1 :
+ forall Un:nat -> R,
+   Un_decreasing Un ->
+   Un_decreasing (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)).
+intros; unfold Un_decreasing in |- *; intro.
+cut ((2 * S n)%nat = S (S (2 * n))).
+intro; rewrite H0; do 2 rewrite tech5; repeat rewrite Rplus_assoc.
+pattern (sum_f_R0 (tg_alt Un) (2 * n)) at 2 in |- *; rewrite <- Rplus_0_r.
+apply Rplus_le_compat_l.
+unfold tg_alt in |- *; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
+ rewrite Rmult_1_l.
+apply Rplus_le_reg_l with (Un (S (2 * n))).
+rewrite Rplus_0_r;
+ replace (Un (S (2 * n)) + (-1 * Un (S (2 * n)) + Un (2 * S n)%nat)) with
+  (Un (2 * S n)%nat); [ idtac | ring ].
+rewrite H0; apply H.
+cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
+rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
+Qed.
+
+(**********)
+Lemma CV_ALT_step2 :
+ forall (Un:nat -> R) (N:nat),
+   Un_decreasing Un ->
+   positivity_seq Un ->
+   sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0. 
+intros; induction  N as [| N HrecN].
+simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
+replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ].
+apply Rplus_le_reg_l with (Un 1%nat); rewrite Rplus_0_r.
+replace (Un 1%nat + (-1 * Un 1%nat + Un 2%nat)) with (Un 2%nat);
+ [ apply H | ring ].
+cut (S (2 * S N) = S (S (S (2 * N)))).
+intro; rewrite H1; do 2 rewrite tech5.
+apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))).
+pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))) at 2 in |- *;
+ rewrite <- Rplus_0_r.
+rewrite Rplus_assoc; apply Rplus_le_compat_l.
+unfold tg_alt in |- *; rewrite <- H1.
+rewrite pow_1_odd.
+cut (S (S (2 * S N)) = (2 * S (S N))%nat).
+intro; rewrite H2; rewrite pow_1_even; rewrite Rmult_1_l; rewrite <- H2.
+apply Rplus_le_reg_l with (Un (S (2 * S N))).
+rewrite Rplus_0_r;
+ replace (Un (S (2 * S N)) + (-1 * Un (S (2 * S N)) + Un (S (S (2 * S N)))))
+  with (Un (S (S (2 * S N)))); [ idtac | ring ].
+apply H.
+apply INR_eq; rewrite mult_INR; repeat rewrite S_INR; rewrite mult_INR;
+ repeat rewrite S_INR; ring.
+apply HrecN.
+apply INR_eq; repeat rewrite S_INR; do 2 rewrite mult_INR;
+ repeat rewrite S_INR; ring.
+Qed.
+
+(* A more general inequality *)
+Lemma CV_ALT_step3 :
+ forall (Un:nat -> R) (N:nat),
+   Un_decreasing Un ->
+   positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0. 
+intros; induction  N as [| N HrecN].
+simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
+apply Rplus_le_reg_l with (Un 1%nat).
+rewrite Rplus_0_r; replace (Un 1%nat + -1 * Un 1%nat) with 0;
+ [ apply H0 | ring ].
+assert (H1 := even_odd_cor N).
+elim H1; intros.
+elim H2; intro.
+rewrite H3; apply CV_ALT_step2; assumption.
+rewrite H3; rewrite tech5.
+apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))).
+pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))) at 2 in |- *;
+ rewrite <- Rplus_0_r.
+apply Rplus_le_compat_l.
+unfold tg_alt in |- *; simpl in |- *.
+replace (x + (x + 0))%nat with (2 * x)%nat; [ idtac | ring ].
+rewrite pow_1_even.
+replace (-1 * (-1 * (-1 * 1)) * Un (S (S (S (2 * x))))) with
+ (- Un (S (S (S (2 * x))))); [ idtac | ring ].
+apply Rplus_le_reg_l with (Un (S (S (S (2 * x))))).
+rewrite Rplus_0_r; rewrite Rplus_opp_r.
+apply H0.
+apply CV_ALT_step2; assumption.
+Qed.
+
+(**********)
+Lemma CV_ALT_step4 :
+ forall Un:nat -> R,
+   Un_decreasing Un ->
+   positivity_seq Un ->
+   has_ub (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
+intros; unfold has_ub in |- *; unfold bound in |- *.
+exists (Un 0%nat).
+unfold is_upper_bound in |- *; intros; elim H1; intros.
+rewrite H2; rewrite decomp_sum.
+replace (tg_alt Un 0) with (Un 0%nat).
+pattern (Un 0%nat) at 2 in |- *; rewrite <- Rplus_0_r.
+apply Rplus_le_compat_l.
+apply CV_ALT_step3; assumption.
+unfold tg_alt in |- *; simpl in |- *; ring.
+apply lt_O_Sn.
+Qed.
+
+(* This lemma gives an interesting result about alternated series *)
+Lemma CV_ALT :
+ forall Un:nat -> R,
+   Un_decreasing Un ->
+   positivity_seq Un ->
+   Un_cv Un 0 ->
+   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l).
+intros.
+assert (H2 := CV_ALT_step0 _ H).
+assert (H3 := CV_ALT_step4 _ H H0).
+assert (X := growing_cv _ H2 H3).
+elim X; intros.
+apply existT with x.
+unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
+ unfold R_dist in H1; unfold Un_cv in p; unfold R_dist in p.
+intros; cut (0 < eps / 2);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+elim (H1 (eps / 2) H5); intros N2 H6.
+elim (p (eps / 2) H5); intros N1 H7.
+set (N := max (S (2 * N1)) N2).
+exists N; intros.
+assert (H9 := even_odd_cor n).
+elim H9; intros P H10.
+cut (N1 <= P)%nat.
+intro; elim H10; intro.
+replace (sum_f_R0 (tg_alt Un) n - x) with
+ (sum_f_R0 (tg_alt Un) (S n) - x + - tg_alt Un (S n)).
+apply Rle_lt_trans with
+ (Rabs (sum_f_R0 (tg_alt Un) (S n) - x) + Rabs (- tg_alt Un (S n))).
+apply Rabs_triang.
+rewrite (double_var eps); apply Rplus_lt_compat.
+rewrite H12; apply H7; assumption.
+rewrite Rabs_Ropp; unfold tg_alt in |- *; rewrite Rabs_mult;
+ rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6;
+ rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n))); 
+ apply H6.
+unfold ge in |- *; apply le_trans with n.
+apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ].
+apply le_n_Sn.
+rewrite tech5; ring.
+rewrite H12; apply Rlt_trans with (eps / 2).
+apply H7; assumption.
+unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+prove_sup0.
+rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
+ [ rewrite Rmult_1_r | discrR ].
+rewrite double.
+pattern eps at 1 in |- *; rewrite <- (Rplus_0_r eps); apply Rplus_lt_compat_l;
+ assumption.
+elim H10; intro; apply le_double.
+rewrite <- H11; apply le_trans with N.
+unfold N in |- *; apply le_trans with (S (2 * N1));
+ [ apply le_n_Sn | apply le_max_l ].
+assumption.
+apply lt_n_Sm_le.
+rewrite <- H11.
+apply lt_le_trans with N.
+unfold N in |- *; apply lt_le_trans with (S (2 * N1)).
+apply lt_n_Sn.
+apply le_max_l.
+assumption.
+Qed.
+
+(************************************************)
+(*        Convergence of alternated series      *)
+(*                                              *)
+(*         Applications: PI, cos, sin           *)
+(************************************************)
+Theorem alternated_series :
+ forall Un:nat -> R,
+   Un_decreasing Un ->
+   Un_cv Un 0 ->
+   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l).
+intros; apply CV_ALT.
+assumption.
+unfold positivity_seq in |- *; apply decreasing_ineq; assumption.
+assumption.
+Qed.
+
+Theorem alternated_series_ineq :
+ forall (Un:nat -> R) (l:R) (N:nat),
+   Un_decreasing Un ->
+   Un_cv Un 0 ->
+   Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l ->
+   sum_f_R0 (tg_alt Un) (S (2 * N)) <= l <= sum_f_R0 (tg_alt Un) (2 * N).
+intros.
+cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)) l).
+cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))) l).
+intros; split.
+apply (growing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N)))).
+apply CV_ALT_step0; assumption.
+assumption.
+apply (decreasing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N))).
+apply CV_ALT_step1; assumption.
+assumption.
+unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
+ unfold R_dist in H1; intros. 
+elim (H1 eps H2); intros.
+exists x; intros.
+apply H3.
+unfold ge in |- *; apply le_trans with (2 * n)%nat.
+apply le_trans with n.
+assumption.
+assert (H5 := mult_O_le n 2).
+elim H5; intro. 
+cut (0%nat <> 2%nat);
+ [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
+assumption.
+apply le_n_Sn.
+unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
+ unfold R_dist in H1; intros. 
+elim (H1 eps H2); intros.
+exists x; intros.
+apply H3.
+unfold ge in |- *; apply le_trans with n.
+assumption.
+assert (H5 := mult_O_le n 2).
+elim H5; intro. 
+cut (0%nat <> 2%nat);
+ [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
+assumption.
+Qed.
+
+(************************************)
+(* Application : construction of PI *)
+(************************************)
+
+Definition PI_tg (n:nat) := / INR (2 * n + 1).
+
+Lemma PI_tg_pos : forall n:nat, 0 <= PI_tg n.
+intro; unfold PI_tg in |- *; left; apply Rinv_0_lt_compat; apply lt_INR_0;
+ replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
+Qed.
+
+Lemma PI_tg_decreasing : Un_decreasing PI_tg.
+unfold PI_tg, Un_decreasing in |- *; intro.
+apply Rmult_le_reg_l with (INR (2 * n + 1)).
+apply lt_INR_0.
+replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
+rewrite <- Rinv_r_sym.
+apply Rmult_le_reg_l with (INR (2 * S n + 1)).
+apply lt_INR_0.
+replace (2 * S n + 1)%nat with (S (2 * S n)); [ apply lt_O_Sn | ring ].
+rewrite (Rmult_comm (INR (2 * S n + 1))); rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+do 2 rewrite Rmult_1_r; apply le_INR.
+replace (2 * S n + 1)%nat with (S (S (2 * n + 1))).
+apply le_trans with (S (2 * n + 1)); apply le_n_Sn.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite plus_INR;
+ do 2 rewrite mult_INR; repeat rewrite S_INR; ring.
+apply not_O_INR; discriminate.
+apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
+ [ discriminate | ring ].
+Qed.
+
+Lemma PI_tg_cv : Un_cv PI_tg 0.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+cut (0 < 2 * eps);
+ [ intro | apply Rmult_lt_0_compat; [ prove_sup0 | assumption ] ].
+assert (H1 := archimed (/ (2 * eps))).
+cut (0 <= up (/ (2 * eps)))%Z.
+intro; assert (H3 := IZN (up (/ (2 * eps))) H2).
+elim H3; intros N H4.
+cut (0 < N)%nat.
+intro; exists N; intros.
+cut (0 < n)%nat.
+intro; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+ rewrite Rabs_right.
+unfold PI_tg in |- *; apply Rlt_trans with (/ INR (2 * n)).
+apply Rmult_lt_reg_l with (INR (2 * n)).
+apply lt_INR_0.
+replace (2 * n)%nat with (n + n)%nat; [ idtac | ring ].
+apply lt_le_trans with n.
+assumption.
+apply le_plus_l.
+rewrite <- Rinv_r_sym.
+apply Rmult_lt_reg_l with (INR (2 * n + 1)).
+apply lt_INR_0.
+replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
+rewrite (Rmult_comm (INR (2 * n + 1))).
+rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+do 2 rewrite Rmult_1_r; apply lt_INR.
+replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_n_Sn | ring ].
+apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
+ [ discriminate | ring ].
+replace n with (S (pred n)).
+apply not_O_INR; discriminate.
+symmetry  in |- *; apply S_pred with 0%nat.
+assumption.
+apply Rle_lt_trans with (/ INR (2 * N)).
+apply Rmult_le_reg_l with (INR (2 * N)).
+rewrite mult_INR; apply Rmult_lt_0_compat;
+ [ simpl in |- *; prove_sup0 | apply lt_INR_0; assumption ].
+rewrite <- Rinv_r_sym.
+apply Rmult_le_reg_l with (INR (2 * n)).
+rewrite mult_INR; apply Rmult_lt_0_compat;
+ [ simpl in |- *; prove_sup0 | apply lt_INR_0; assumption ].
+rewrite (Rmult_comm (INR (2 * n))); rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+do 2 rewrite Rmult_1_r; apply le_INR.
+apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
+replace n with (S (pred n)).
+apply not_O_INR; discriminate.
+symmetry  in |- *; apply S_pred with 0%nat.
+assumption.
+replace N with (S (pred N)).
+apply not_O_INR; discriminate.
+symmetry  in |- *; apply S_pred with 0%nat.
+assumption.
+rewrite mult_INR.
+rewrite Rinv_mult_distr.
+replace (INR 2) with 2; [ idtac | reflexivity ].
+apply Rmult_lt_reg_l with 2.
+prove_sup0.
+rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; [ idtac | discrR ].
+rewrite Rmult_1_l; apply Rmult_lt_reg_l with (INR N).
+apply lt_INR_0; assumption.
+rewrite <- Rinv_r_sym.
+apply Rmult_lt_reg_l with (/ (2 * eps)).
+apply Rinv_0_lt_compat; assumption.
+rewrite Rmult_1_r;
+ replace (/ (2 * eps) * (INR N * (2 * eps))) with
+  (INR N * (2 * eps * / (2 * eps))); [ idtac | ring ].
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; replace (INR N) with (IZR (Z_of_nat N)).
+rewrite <- H4.
+elim H1; intros; assumption.
+symmetry  in |- *; apply INR_IZR_INZ.
+apply prod_neq_R0;
+ [ discrR | red in |- *; intro; rewrite H8 in H; elim (Rlt_irrefl _ H) ].
+apply not_O_INR.
+red in |- *; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
+replace (INR 2) with 2; [ discrR | reflexivity ].
+apply not_O_INR.
+red in |- *; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
+apply Rle_ge; apply PI_tg_pos.
+apply lt_le_trans with N; assumption.
+elim H1; intros H5 _.
+assert (H6 := lt_eq_lt_dec 0 N).
+elim H6; intro.
+elim a; intro.
+assumption.
+rewrite <- b in H4.
+rewrite H4 in H5.
+simpl in H5.
+cut (0 < / (2 * eps)); [ intro | apply Rinv_0_lt_compat; assumption ].
+elim (Rlt_irrefl _ (Rlt_trans _ _ _ H7 H5)).
+elim (lt_n_O _ b).
+apply le_IZR.
+simpl in |- *.
+left; apply Rlt_trans with (/ (2 * eps)).
+apply Rinv_0_lt_compat; assumption.
+elim H1; intros; assumption.
+Qed.
+
+Lemma exist_PI :
+ sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt PI_tg) N) l).
+apply alternated_series.
+apply PI_tg_decreasing.
+apply PI_tg_cv.
+Qed.
+
+(* Now, PI is defined *)
+Definition PI : R := 4 * match exist_PI with
+                         | existT a b => a
+                         end.
+
+(* We can get an approximation of PI with the following inequality *)
+Lemma PI_ineq :
+ forall N:nat,
+   sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= PI / 4 <=
+   sum_f_R0 (tg_alt PI_tg) (2 * N).
+intro; apply alternated_series_ineq.
+apply PI_tg_decreasing.
+apply PI_tg_cv.
+unfold PI in |- *; case exist_PI; intro.
+replace (4 * x / 4) with x.
+trivial.
+unfold Rdiv in |- *; rewrite (Rmult_comm 4); rewrite Rmult_assoc;
+ rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | discrR ].
+Qed.
+
+Lemma PI_RGT_0 : 0 < PI.
+assert (H := PI_ineq 0).
+apply Rmult_lt_reg_l with (/ 4).
+apply Rinv_0_lt_compat; prove_sup0.
+rewrite Rmult_0_r; rewrite Rmult_comm.
+elim H; clear H; intros H _.
+unfold Rdiv in H;
+ apply Rlt_le_trans with (sum_f_R0 (tg_alt PI_tg) (S (2 * 0))).
+simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_l;
+ rewrite Rmult_1_r; apply Rplus_lt_reg_r with (PI_tg 1).
+rewrite Rplus_0_r;
+ replace (PI_tg 1 + (PI_tg 0 + -1 * PI_tg 1)) with (PI_tg 0);
+ [ unfold PI_tg in |- * | ring ].
+simpl in |- *; apply Rinv_lt_contravar.
+rewrite Rmult_1_l; replace (2 + 1) with 3; [ prove_sup0 | ring ].
+rewrite Rplus_comm; pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_lt_compat_l; prove_sup0.
+assumption.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v
new file mode 100644
index 00000000..ad535a9d
--- /dev/null
+++ b/theories/Reals/ArithProp.v
@@ -0,0 +1,178 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: ArithProp.v,v 1.11.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rbasic_fun.
+Require Import Even.
+Require Import Div2.
+Open Local Scope Z_scope.
+Open Local Scope R_scope.
+
+Lemma minus_neq_O : forall n i:nat, (i < n)%nat -> (n - i)%nat <> 0%nat.
+intros; red in |- *; intro.
+cut (forall n m:nat, (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
+intro; assert (H2 := H1 _ _ (lt_le_weak _ _ H) H0); rewrite H2 in H;
+ elim (lt_irrefl _ H).
+set (R := fun n m:nat => (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
+cut
+ ((forall n m:nat, R n m) ->
+  forall n0 m:nat, (m <= n0)%nat -> (n0 - m)%nat = 0%nat -> n0 = m).
+intro; apply H1.
+apply nat_double_ind.
+unfold R in |- *; intros; inversion H2; reflexivity.
+unfold R in |- *; intros; simpl in H3; assumption.
+unfold R in |- *; intros; simpl in H4; assert (H5 := le_S_n _ _ H3);
+ assert (H6 := H2 H5 H4); rewrite H6; reflexivity.
+unfold R in |- *; intros; apply H1; assumption.
+Qed.
+
+Lemma le_minusni_n : forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat.
+set (R := fun m n:nat => (n <= m)%nat -> (m - n <= m)%nat).
+cut
+ ((forall m n:nat, R m n) -> forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat).
+intro; apply H.
+apply nat_double_ind.
+unfold R in |- *; intros; simpl in |- *; apply le_n.
+unfold R in |- *; intros; simpl in |- *; apply le_n.
+unfold R in |- *; intros; simpl in |- *; apply le_trans with n.
+apply H0; apply le_S_n; assumption.
+apply le_n_Sn.
+unfold R in |- *; intros; apply H; assumption.
+Qed.
+
+Lemma lt_minus_O_lt : forall m n:nat, (m < n)%nat -> (0 < n - m)%nat.
+intros n m; pattern n, m in |- *; apply nat_double_ind;
+ [ intros; rewrite <- minus_n_O; assumption
+ | intros; elim (lt_n_O _ H)
+ | intros; simpl in |- *; apply H; apply lt_S_n; assumption ].
+Qed.
+
+Lemma even_odd_cor :
+ forall n:nat,  exists p : nat, n = (2 * p)%nat \/ n = S (2 * p).
+intro.
+assert (H := even_or_odd n).
+exists (div2 n).
+assert (H0 := even_odd_double n).
+elim H0; intros.
+elim H1; intros H3 _.
+elim H2; intros H4 _.
+replace (2 * div2 n)%nat with (double (div2 n)).
+elim H; intro.
+left.
+apply H3; assumption.
+right.
+apply H4; assumption.
+unfold double in |- *; ring.
+Qed.
+
+(* 2m <= 2n => m<=n *)
+Lemma le_double : forall m n:nat, (2 * m <= 2 * n)%nat -> (m <= n)%nat.
+intros; apply INR_le.
+assert (H1 := le_INR _ _ H).
+do 2 rewrite mult_INR in H1.
+apply Rmult_le_reg_l with (INR 2).
+replace (INR 2) with 2; [ prove_sup0 | reflexivity ].
+assumption.
+Qed.
+
+(* Here, we have the euclidian division *)
+(* This lemma is used in the proof of sin_eq_0 : (sin x)=0<->x=kPI *)
+Lemma euclidian_division :
+ forall x y:R,
+   y <> 0 ->
+    exists k : Z, (exists r : R, x = IZR k * y + r /\ 0 <= r < Rabs y).
+intros.
+set
+ (k0 :=
+  match Rcase_abs y with
+  | left _ => (1 - up (x / - y))%Z
+  | right _ => (up (x / y) - 1)%Z
+  end).
+exists k0.
+exists (x - IZR k0 * y).
+split.
+ring.
+unfold k0 in |- *; case (Rcase_abs y); intro.
+assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl in |- *;
+ unfold Rminus in |- *.
+replace (- ((1 + - IZR (up (x / - y))) * y)) with
+ ((IZR (up (x / - y)) - 1) * y); [ idtac | ring ].
+split.
+apply Rmult_le_reg_l with (/ - y).
+apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
+rewrite Rmult_0_r; rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
+ rewrite <- Ropp_inv_permute; [ idtac | assumption ].
+rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
+ rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ].
+apply Rplus_le_reg_l with (IZR (up (x / - y)) - x / - y).
+rewrite Rplus_0_r; unfold Rdiv in |- *; pattern (/ - y) at 4 in |- *;
+ rewrite <- Ropp_inv_permute; [ idtac | assumption ].
+replace
+ (IZR (up (x * / - y)) - x * - / y +
+  (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1; 
+ [ idtac | ring ].
+elim H0; intros _ H1; unfold Rdiv in H1; exact H1.
+rewrite (Rabs_left _ r); apply Rmult_lt_reg_l with (/ - y).
+apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
+rewrite <- Rinv_l_sym.
+rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
+ rewrite <- Ropp_inv_permute; [ idtac | assumption ].
+rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
+ rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ];
+ apply Rplus_lt_reg_r with (IZR (up (x / - y)) - 1).
+replace (IZR (up (x / - y)) - 1 + 1) with (IZR (up (x / - y)));
+ [ idtac | ring ].
+replace (IZR (up (x / - y)) - 1 + (- (x * / y) + - (IZR (up (x / - y)) - 1)))
+ with (- (x * / y)); [ idtac | ring ].
+rewrite <- Ropp_mult_distr_r_reverse; rewrite (Ropp_inv_permute _ H); elim H0;
+ unfold Rdiv in |- *; intros H1 _; exact H1.
+apply Ropp_neq_0_compat; assumption.
+assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl in |- *;
+ cut (0 < y).
+intro; unfold Rminus in |- *;
+ replace (- ((IZR (up (x / y)) + -1) * y)) with ((1 - IZR (up (x / y))) * y);
+ [ idtac | ring ].
+split.
+apply Rmult_le_reg_l with (/ y).
+apply Rinv_0_lt_compat; assumption.
+rewrite Rmult_0_r; rewrite (Rmult_comm (/ y)); rewrite Rmult_plus_distr_r;
+ rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
+ [ rewrite Rmult_1_r | assumption ];
+ apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y); 
+ rewrite Rplus_0_r; unfold Rdiv in |- *;
+ replace
+  (IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with
+  1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2; 
+ exact H2.
+rewrite (Rabs_right _ r); apply Rmult_lt_reg_l with (/ y).
+apply Rinv_0_lt_compat; assumption.
+rewrite <- (Rinv_l_sym _ H); rewrite (Rmult_comm (/ y));
+ rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
+ [ rewrite Rmult_1_r | assumption ];
+ apply Rplus_lt_reg_r with (IZR (up (x / y)) - 1);
+ replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y))); 
+ [ idtac | ring ];
+ replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with
+  (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *; 
+ intros H2 _; exact H2.
+case (total_order_T 0 y); intro.
+elim s; intro.
+assumption.
+elim H; symmetry  in |- *; exact b.
+assert (H1 := Rge_le _ _ r); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r0)).
+Qed.
+
+Lemma tech8 : forall n i:nat, (n <= S n + i)%nat.
+intros; induction  i as [| i Hreci].
+replace (S n + 0)%nat with (S n); [ apply le_n_Sn | ring ].
+replace (S n + S i)%nat with (S (S n + i)).
+apply le_S; assumption.
+apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v
new file mode 100644
index 00000000..e31b623c
--- /dev/null
+++ b/theories/Reals/Binomial.v
@@ -0,0 +1,204 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Binomial.v,v 1.9.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import PartSum.
+Open Local Scope R_scope.
+
+Definition C (n p:nat) : R :=
+  INR (fact n) / (INR (fact p) * INR (fact (n - p))).
+
+Lemma pascal_step1 : forall n i:nat, (i <= n)%nat -> C n i = C n (n - i).
+intros; unfold C in |- *; replace (n - (n - i))%nat with i.
+rewrite Rmult_comm.
+reflexivity.
+apply plus_minus; rewrite plus_comm; apply le_plus_minus; assumption.
+Qed.
+
+Lemma pascal_step2 :
+ forall n i:nat,
+   (i <= n)%nat -> C (S n) i = INR (S n) / INR (S n - i) * C n i.
+intros; unfold C in |- *; replace (S n - i)%nat with (S (n - i)).
+cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
+intro; repeat rewrite H0.
+unfold Rdiv in |- *; repeat rewrite mult_INR; repeat rewrite Rinv_mult_distr.
+ring.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply not_O_INR; discriminate.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply prod_neq_R0.
+apply not_O_INR; discriminate.
+apply INR_fact_neq_0.
+intro; reflexivity.
+apply minus_Sn_m; assumption.
+Qed.
+
+Lemma pascal_step3 :
+ forall n i:nat, (i < n)%nat -> C n (S i) = INR (n - i) / INR (S i) * C n i.
+intros; unfold C in |- *.
+cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
+intro.
+cut ((n - i)%nat = S (n - S i)).
+intro.
+pattern (n - i)%nat at 2 in |- *; rewrite H1.
+repeat rewrite H0; unfold Rdiv in |- *; repeat rewrite mult_INR;
+ repeat rewrite Rinv_mult_distr.
+rewrite <- H1; rewrite (Rmult_comm (/ INR (n - i)));
+ repeat rewrite Rmult_assoc; rewrite (Rmult_comm (INR (n - i)));
+ repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+ring.
+apply not_O_INR; apply minus_neq_O; assumption.
+apply not_O_INR; discriminate.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
+apply not_O_INR; discriminate.
+apply INR_fact_neq_0.
+apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
+apply INR_fact_neq_0.
+rewrite minus_Sn_m.
+simpl in |- *; reflexivity.
+apply lt_le_S; assumption.
+intro; reflexivity.
+Qed.
+
+(**********)
+Lemma pascal :
+ forall n i:nat, (i < n)%nat -> C n i + C n (S i) = C (S n) (S i).
+intros.
+rewrite pascal_step3; [ idtac | assumption ].
+replace (C n i + INR (n - i) / INR (S i) * C n i) with
+ (C n i * (1 + INR (n - i) / INR (S i))); [ idtac | ring ].
+replace (1 + INR (n - i) / INR (S i)) with (INR (S n) / INR (S i)).
+rewrite pascal_step1.
+rewrite Rmult_comm; replace (S i) with (S n - (n - i))%nat.
+rewrite <- pascal_step2.
+apply pascal_step1.
+apply le_trans with n.
+apply le_minusni_n.
+apply lt_le_weak; assumption.
+apply le_n_Sn.
+apply le_minusni_n.
+apply lt_le_weak; assumption.
+rewrite <- minus_Sn_m.
+cut ((n - (n - i))%nat = i).
+intro; rewrite H0; reflexivity.
+symmetry  in |- *; apply plus_minus.
+rewrite plus_comm; rewrite le_plus_minus_r.
+reflexivity.
+apply lt_le_weak; assumption.
+apply le_minusni_n; apply lt_le_weak; assumption.
+apply lt_le_weak; assumption.
+unfold Rdiv in |- *.
+repeat rewrite S_INR.
+rewrite minus_INR.
+cut (INR i + 1 <> 0).
+intro.
+apply Rmult_eq_reg_l with (INR i + 1); [ idtac | assumption ].
+rewrite Rmult_plus_distr_l.
+rewrite Rmult_1_r.
+do 2 rewrite (Rmult_comm (INR i + 1)).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym; [ idtac | assumption ].
+ring.
+rewrite <- S_INR.
+apply not_O_INR; discriminate.
+apply lt_le_weak; assumption.
+Qed.
+
+(*********************)
+(*********************)
+Lemma binomial :
+ forall (x y:R) (n:nat),
+   (x + y) ^ n = sum_f_R0 (fun i:nat => C n i * x ^ i * y ^ (n - i)) n.
+intros; induction  n as [| n Hrecn].
+unfold C in |- *; simpl in |- *; unfold Rdiv in |- *;
+ repeat rewrite Rmult_1_r; rewrite Rinv_1; ring.
+pattern (S n) at 1 in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+rewrite pow_add; rewrite Hrecn.
+replace ((x + y) ^ 1) with (x + y); [ idtac | simpl in |- *; ring ].
+rewrite tech5.
+cut (forall p:nat, C p p = 1).
+cut (forall p:nat, C p 0 = 1).
+intros; rewrite H0; rewrite <- minus_n_n; rewrite Rmult_1_l.
+replace (y ^ 0) with 1; [ rewrite Rmult_1_r | simpl in |- *; reflexivity ].
+induction  n as [| n Hrecn0].
+simpl in |- *; do 2 rewrite H; ring.
+(* N >= 1 *)
+set (N := S n).
+rewrite Rmult_plus_distr_l.
+replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * x) with
+ (sum_f_R0 (fun i:nat => C N i * x ^ S i * y ^ (N - i)) N).
+replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * y) with
+ (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (S N - i)) N).
+rewrite (decomp_sum (fun i:nat => C (S N) i * x ^ i * y ^ (S N - i)) N).
+rewrite H; replace (x ^ 0) with 1; [ idtac | reflexivity ].
+do 2 rewrite Rmult_1_l.
+replace (S N - 0)%nat with (S N); [ idtac | reflexivity ].
+set (An := fun i:nat => C N i * x ^ S i * y ^ (N - i)).
+set (Bn := fun i:nat => C N (S i) * x ^ S i * y ^ (N - i)).
+replace (pred N) with n.
+replace (sum_f_R0 (fun i:nat => C (S N) (S i) * x ^ S i * y ^ (S N - S i)) n)
+ with (sum_f_R0 (fun i:nat => An i + Bn i) n).
+rewrite plus_sum.
+replace (x ^ S N) with (An (S n)).
+rewrite (Rplus_comm (sum_f_R0 An n)).
+repeat rewrite Rplus_assoc.
+rewrite <- tech5.
+fold N in |- *.
+set (Cn := fun i:nat => C N i * x ^ i * y ^ (S N - i)).
+cut (forall i:nat, (i < N)%nat -> Cn (S i) = Bn i).
+intro; replace (sum_f_R0 Bn n) with (sum_f_R0 (fun i:nat => Cn (S i)) n).
+replace (y ^ S N) with (Cn 0%nat).
+rewrite <- Rplus_assoc; rewrite (decomp_sum Cn N).
+replace (pred N) with n.
+ring.
+unfold N in |- *; simpl in |- *; reflexivity.
+unfold N in |- *; apply lt_O_Sn.
+unfold Cn in |- *; rewrite H; simpl in |- *; ring.
+apply sum_eq.
+intros; apply H1.
+unfold N in |- *; apply le_lt_trans with n; [ assumption | apply lt_n_Sn ].
+intros; unfold Bn, Cn in |- *.
+replace (S N - S i)%nat with (N - i)%nat; reflexivity.
+unfold An in |- *; fold N in |- *; rewrite <- minus_n_n; rewrite H0;
+ simpl in |- *; ring.
+apply sum_eq.
+intros; unfold An, Bn in |- *; replace (S N - S i)%nat with (N - i)%nat;
+ [ idtac | reflexivity ].
+rewrite <- pascal;
+ [ ring
+ | apply le_lt_trans with n; [ assumption | unfold N in |- *; apply lt_n_Sn ] ].
+unfold N in |- *; reflexivity.
+unfold N in |- *; apply lt_O_Sn.
+rewrite <- (Rmult_comm y); rewrite scal_sum; apply sum_eq.
+intros; replace (S N - i)%nat with (S (N - i)).
+replace (S (N - i)) with (N - i + 1)%nat; [ idtac | ring ].
+rewrite pow_add; replace (y ^ 1) with y; [ idtac | simpl in |- *; ring ];
+ ring.
+apply minus_Sn_m; assumption.
+rewrite <- (Rmult_comm x); rewrite scal_sum; apply sum_eq.
+intros; replace (S i) with (i + 1)%nat; [ idtac | ring ]; rewrite pow_add;
+ replace (x ^ 1) with x; [ idtac | simpl in |- *; ring ]; 
+ ring.
+intro; unfold C in |- *.
+replace (INR (fact 0)) with 1; [ idtac | reflexivity ].
+replace (p - 0)%nat with p; [ idtac | apply minus_n_O ].
+rewrite Rmult_1_l; unfold Rdiv in |- *; rewrite <- Rinv_r_sym;
+ [ reflexivity | apply INR_fact_neq_0 ].
+intro; unfold C in |- *.
+replace (p - p)%nat with 0%nat; [ idtac | apply minus_n_n ].
+replace (INR (fact 0)) with 1; [ idtac | reflexivity ].
+rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym;
+ [ reflexivity | apply INR_fact_neq_0 ].
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v
new file mode 100644
index 00000000..41a6284f
--- /dev/null
+++ b/theories/Reals/Cauchy_prod.v
@@ -0,0 +1,458 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Cauchy_prod.v,v 1.10.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import PartSum.
+Open Local Scope R_scope.
+
+(**********)
+Lemma sum_N_predN :
+ forall (An:nat -> R) (N:nat),
+   (0 < N)%nat -> sum_f_R0 An N = sum_f_R0 An (pred N) + An N.
+intros.
+replace N with (S (pred N)).
+rewrite tech5.
+reflexivity.
+symmetry  in |- *; apply S_pred with 0%nat; assumption.
+Qed.
+
+(**********)
+Lemma sum_plus :
+ forall (An Bn:nat -> R) (N:nat),
+   sum_f_R0 (fun l:nat => An l + Bn l) N = sum_f_R0 An N + sum_f_R0 Bn N.
+intros.
+induction  N as [| N HrecN].
+reflexivity.
+do 3 rewrite tech5.
+rewrite HrecN; ring.
+Qed.
+
+(* The main result *)
+Theorem cauchy_finite :
+ forall (An Bn:nat -> R) (N:nat),
+   (0 < N)%nat ->
+   sum_f_R0 An N * sum_f_R0 Bn N =
+   sum_f_R0 (fun k:nat => sum_f_R0 (fun p:nat => An p * Bn (k - p)%nat) k) N +
+   sum_f_R0
+     (fun k:nat =>
+        sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat)
+          (pred (N - k))) (pred N). 
+intros; induction  N as [| N HrecN].
+elim (lt_irrefl _ H).
+cut (N = 0%nat \/ (0 < N)%nat).
+intro; elim H0; intro.
+rewrite H1; simpl in |- *; ring.
+replace (pred (S N)) with (S (pred N)).
+do 5 rewrite tech5.
+rewrite Rmult_plus_distr_r; rewrite Rmult_plus_distr_l; rewrite (HrecN H1).
+repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
+replace (pred (S N - S (pred N))) with 0%nat.
+rewrite Rmult_plus_distr_l;
+ replace
+  (sum_f_R0 (fun l:nat => An (S (l + S (pred N))) * Bn (S N - l)%nat) 0) with
+  (An (S N) * Bn (S N)).
+repeat rewrite <- Rplus_assoc;
+ do 2 rewrite <- (Rplus_comm (An (S N) * Bn (S N)));
+ repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
+rewrite <- minus_n_n; cut (N = 1%nat \/ (2 <= N)%nat).
+intro; elim H2; intro.
+rewrite H3; simpl in |- *; ring.
+replace
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) (pred (N - k)))
+    (pred N)) with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+         (pred (pred (N - k)))) (pred (pred N)) +
+  sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)).
+replace (sum_f_R0 (fun p:nat => An p * Bn (S N - p)%nat) N) with
+ (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N) +
+  An 0%nat * Bn (S N)).
+repeat rewrite <- Rplus_assoc;
+ rewrite <-
+  (Rplus_comm (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)))
+  ; repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
+replace
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (S N - l)%nat)
+         (pred (S N - k))) (pred N)) with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+         (pred (N - k))) (pred N) +
+  Bn (S N) * sum_f_R0 (fun l:nat => An (S l)) (pred N)).
+rewrite (decomp_sum An N H1); rewrite Rmult_plus_distr_r;
+ repeat rewrite <- Rplus_assoc; rewrite <- (Rplus_comm (An 0%nat * Bn (S N)));
+ repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
+repeat rewrite <- Rplus_assoc;
+ rewrite <-
+  (Rplus_comm (sum_f_R0 (fun i:nat => An (S i)) (pred N) * Bn (S N)))
+  ;
+ rewrite <-
+  (Rplus_comm (Bn (S N) * sum_f_R0 (fun i:nat => An (S i)) (pred N)))
+  ; rewrite (Rmult_comm (Bn (S N))); repeat rewrite Rplus_assoc;
+ apply Rplus_eq_compat_l.
+replace
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+         (pred (N - k))) (pred N)) with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+         (pred (pred (N - k)))) (pred (pred N)) +
+  An (S N) * sum_f_R0 (fun l:nat => Bn (S l)) (pred N)).
+rewrite (decomp_sum Bn N H1); rewrite Rmult_plus_distr_l.
+set
+ (Z :=
+  sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+         (pred (pred (N - k)))) (pred (pred N)));
+ set (Z2 := sum_f_R0 (fun i:nat => Bn (S i)) (pred N)); 
+ ring.
+rewrite
+ (sum_N_predN
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+         (pred (N - k))) (pred N)).
+replace
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+         (pred (N - k))) (pred (pred N))) with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+         (pred (pred (N - k))) + An (S N) * Bn (S k)) (
+    pred (pred N))).
+rewrite
+ (sum_plus
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+         (pred (pred (N - k)))) (fun k:nat => An (S N) * Bn (S k))
+    (pred (pred N))).
+repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
+replace (pred (N - pred N)) with 0%nat.
+simpl in |- *; rewrite <- minus_n_O.
+replace (S (pred N)) with N.
+replace (sum_f_R0 (fun k:nat => An (S N) * Bn (S k)) (pred (pred N))) with
+ (sum_f_R0 (fun k:nat => Bn (S k) * An (S N)) (pred (pred N))).
+rewrite <- (scal_sum (fun l:nat => Bn (S l)) (pred (pred N)) (An (S N)));
+ rewrite (sum_N_predN (fun l:nat => Bn (S l)) (pred N)).
+replace (S (pred N)) with N.
+ring.
+apply S_pred with 0%nat; assumption.
+apply lt_pred; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | assumption ].
+apply sum_eq; intros; apply Rmult_comm.
+apply S_pred with 0%nat; assumption.
+replace (N - pred N)%nat with 1%nat.
+reflexivity.
+pattern N at 1 in |- *; replace N with (S (pred N)).
+rewrite <- minus_Sn_m.
+rewrite <- minus_n_n; reflexivity.
+apply le_n.
+symmetry  in |- *; apply S_pred with 0%nat; assumption.
+apply sum_eq; intros;
+ rewrite
+  (sum_N_predN (fun l:nat => An (S (S (l + i))) * Bn (N - l)%nat)
+     (pred (N - i))).
+replace (S (S (pred (N - i) + i))) with (S N).
+replace (N - pred (N - i))%nat with (S i).
+ring.
+rewrite pred_of_minus; apply INR_eq; repeat rewrite minus_INR.
+rewrite S_INR; ring.
+apply le_trans with (pred (pred N)).
+assumption.
+apply le_trans with (pred N); apply le_pred_n.
+apply INR_le; rewrite minus_INR.
+apply Rplus_le_reg_l with (INR i - 1).
+replace (INR i - 1 + INR 1) with (INR i); [ idtac | ring ].
+replace (INR i - 1 + (INR N - INR i)) with (INR N - INR 1); [ idtac | ring ].
+rewrite <- minus_INR.
+apply le_INR; apply le_trans with (pred (pred N)).
+assumption.
+rewrite <- pred_of_minus; apply le_pred_n.
+apply le_trans with 2%nat.
+apply le_n_Sn.
+assumption.
+apply le_trans with (pred (pred N)).
+assumption.
+apply le_trans with (pred N); apply le_pred_n.
+rewrite <- pred_of_minus.
+apply le_trans with (pred N).
+apply le_S_n.
+replace (S (pred N)) with N.
+replace (S (pred (N - i))) with (N - i)%nat.
+apply (fun p n m:nat => plus_le_reg_l n m p) with i; rewrite le_plus_minus_r.
+apply le_plus_r.
+apply le_trans with (pred (pred N));
+ [ assumption | apply le_trans with (pred N); apply le_pred_n ].
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with i; rewrite le_plus_minus_r.
+replace (i + 0)%nat with i; [ idtac | ring ].
+apply le_lt_trans with (pred (pred N));
+ [ assumption | apply lt_trans with (pred N); apply lt_pred_n_n ].
+apply lt_S_n.
+replace (S (pred N)) with N.
+apply lt_le_trans with 2%nat.
+apply lt_n_Sn.
+assumption.
+apply S_pred with 0%nat; assumption.
+assumption.
+apply le_trans with (pred (pred N)).
+assumption.
+apply le_trans with (pred N); apply le_pred_n.
+apply S_pred with 0%nat; assumption.
+apply le_pred_n.
+apply INR_eq; rewrite pred_of_minus; do 3 rewrite S_INR; rewrite plus_INR;
+ repeat rewrite minus_INR.
+ring.
+apply le_trans with (pred (pred N)).
+assumption.
+apply le_trans with (pred N); apply le_pred_n.
+apply INR_le.
+rewrite minus_INR.
+apply Rplus_le_reg_l with (INR i - 1).
+replace (INR i - 1 + INR 1) with (INR i); [ idtac | ring ].
+replace (INR i - 1 + (INR N - INR i)) with (INR N - INR 1); [ idtac | ring ].
+rewrite <- minus_INR.
+apply le_INR.
+apply le_trans with (pred (pred N)).
+assumption.
+rewrite <- pred_of_minus.
+apply le_pred_n.
+apply le_trans with 2%nat.
+apply le_n_Sn.
+assumption.
+apply le_trans with (pred (pred N)).
+assumption.
+apply le_trans with (pred N); apply le_pred_n.
+apply lt_le_trans with 1%nat.
+apply lt_O_Sn.
+apply INR_le.
+rewrite pred_of_minus.
+repeat rewrite minus_INR.
+apply Rplus_le_reg_l with (INR i - 1).
+replace (INR i - 1 + INR 1) with (INR i); [ idtac | ring ].
+replace (INR i - 1 + (INR N - INR i - INR 1)) with (INR N - INR 1 - INR 1).
+repeat rewrite <- minus_INR.
+apply le_INR.
+apply le_trans with (pred (pred N)).
+assumption.
+do 2 rewrite <- pred_of_minus.
+apply le_n.
+apply (fun p n m:nat => plus_le_reg_l n m p) with 1%nat.
+rewrite le_plus_minus_r.
+simpl in |- *; assumption.
+apply le_trans with 2%nat; [ apply le_n_Sn | assumption ].
+apply le_trans with 2%nat; [ apply le_n_Sn | assumption ].
+ring.
+apply le_trans with (pred (pred N)).
+assumption.
+apply le_trans with (pred N); apply le_pred_n.
+apply (fun p n m:nat => plus_le_reg_l n m p) with i.
+rewrite le_plus_minus_r.
+replace (i + 1)%nat with (S i).
+replace N with (S (pred N)).
+apply le_n_S.
+apply le_trans with (pred (pred N)).
+assumption.
+apply le_pred_n.
+symmetry  in |- *; apply S_pred with 0%nat; assumption.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; reflexivity.
+apply le_trans with (pred (pred N)).
+assumption.
+apply le_trans with (pred N); apply le_pred_n.
+apply lt_le_trans with 1%nat.
+apply lt_O_Sn.
+apply le_S_n.
+replace (S (pred N)) with N.
+assumption.
+apply S_pred with 0%nat; assumption.
+replace
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (S N - l)%nat)
+         (pred (S N - k))) (pred N)) with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+         (pred (N - k)) + An (S k) * Bn (S N)) (pred N)).
+rewrite
+ (sum_plus
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+         (pred (N - k))) (fun k:nat => An (S k) * Bn (S N)))
+ .
+apply Rplus_eq_compat_l.
+rewrite scal_sum; reflexivity.
+apply sum_eq; intros; rewrite Rplus_comm;
+ rewrite
+  (decomp_sum (fun l:nat => An (S (l + i)) * Bn (S N - l)%nat)
+     (pred (S N - i))).
+replace (0 + i)%nat with i; [ idtac | ring ].
+rewrite <- minus_n_O; apply Rplus_eq_compat_l.
+replace (pred (pred (S N - i))) with (pred (N - i)).
+apply sum_eq; intros.
+replace (S N - S i0)%nat with (N - i0)%nat; [ idtac | reflexivity ].
+replace (S i0 + i)%nat with (S (i0 + i)).
+reflexivity.
+apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; rewrite S_INR; ring.
+cut ((N - i)%nat = pred (S N - i)).
+intro; rewrite H5; reflexivity.
+rewrite pred_of_minus.
+apply INR_eq; repeat rewrite minus_INR.
+rewrite S_INR; ring.
+apply le_trans with N.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply (fun p n m:nat => plus_le_reg_l n m p) with i.
+rewrite le_plus_minus_r.
+replace (i + 1)%nat with (S i).
+apply le_n_S.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; ring.
+apply le_trans with N.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+replace (pred (S N - i)) with (S N - S i)%nat.
+replace (S N - S i)%nat with (N - i)%nat; [ idtac | reflexivity ].
+apply plus_lt_reg_l with i.
+rewrite le_plus_minus_r.
+replace (i + 0)%nat with i; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+assumption.
+apply lt_pred_n_n.
+assumption.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+rewrite pred_of_minus.
+apply INR_eq; repeat rewrite minus_INR.
+repeat rewrite S_INR; ring.
+apply le_trans with N.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply (fun p n m:nat => plus_le_reg_l n m p) with i.
+rewrite le_plus_minus_r.
+replace (i + 1)%nat with (S i).
+apply le_n_S.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; ring.
+apply le_trans with N.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply le_n_S.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+rewrite Rplus_comm.
+rewrite (decomp_sum (fun p:nat => An p * Bn (S N - p)%nat) N).
+rewrite <- minus_n_O.
+apply Rplus_eq_compat_l.
+apply sum_eq; intros.
+reflexivity.
+assumption.
+rewrite Rplus_comm.
+rewrite
+ (decomp_sum
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) (pred (N - k)))
+    (pred N)).
+rewrite <- minus_n_O.
+replace (sum_f_R0 (fun l:nat => An (S (l + 0)) * Bn (N - l)%nat) (pred N))
+ with (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)).
+apply Rplus_eq_compat_l.
+apply sum_eq; intros.
+replace (pred (N - S i)) with (pred (pred (N - i))).
+apply sum_eq; intros.
+replace (i0 + S i)%nat with (S (i0 + i)).
+reflexivity.
+apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; rewrite S_INR; ring.
+cut (pred (N - i) = (N - S i)%nat).
+intro; rewrite H5; reflexivity.
+rewrite pred_of_minus.
+apply INR_eq.
+repeat rewrite minus_INR.
+repeat rewrite S_INR; ring.
+apply le_trans with (S (pred (pred N))).
+apply le_n_S; assumption.
+replace (S (pred (pred N))) with (pred N).
+apply le_pred_n.
+apply S_pred with 0%nat.
+apply lt_S_n.
+replace (S (pred N)) with N.
+apply lt_le_trans with 2%nat.
+apply lt_n_Sn.
+assumption.
+apply S_pred with 0%nat; assumption.
+apply le_trans with (pred (pred N)).
+assumption.
+apply le_trans with (pred N); apply le_pred_n.
+apply (fun p n m:nat => plus_le_reg_l n m p) with i.
+rewrite le_plus_minus_r.
+replace (i + 1)%nat with (S i).
+replace N with (S (pred N)).
+apply le_n_S.
+apply le_trans with (pred (pred N)).
+assumption.
+apply le_pred_n.
+symmetry  in |- *; apply S_pred with 0%nat; assumption.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; ring.
+apply le_trans with (pred (pred N)).
+assumption.
+apply le_trans with (pred N); apply le_pred_n.
+apply sum_eq; intros.
+replace (i + 0)%nat with i; [ reflexivity | trivial ].
+apply lt_S_n.
+replace (S (pred N)) with N.
+apply lt_le_trans with 2%nat; [ apply lt_n_Sn | assumption ].
+apply S_pred with 0%nat; assumption.
+inversion H1.
+left; reflexivity.
+right; apply le_n_S; assumption.
+simpl in |- *.
+replace (S (pred N)) with N.
+reflexivity.
+apply S_pred with 0%nat; assumption.
+simpl in |- *.
+cut ((N - pred N)%nat = 1%nat).
+intro; rewrite H2; reflexivity.
+rewrite pred_of_minus.
+apply INR_eq; repeat rewrite minus_INR.
+ring.
+apply lt_le_S; assumption.
+rewrite <- pred_of_minus; apply le_pred_n.
+simpl in |- *; symmetry  in |- *; apply S_pred with 0%nat; assumption.
+inversion H.
+left; reflexivity.
+right; apply lt_le_trans with 1%nat; [ apply lt_n_Sn | exact H1 ].
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v
new file mode 100644
index 00000000..422eb4a4
--- /dev/null
+++ b/theories/Reals/Cos_plus.v
@@ -0,0 +1,1061 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Cos_plus.v,v 1.11.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo_def.
+Require Import Cos_rel.
+Require Import Max. Open Local Scope nat_scope. Open Local Scope R_scope.
+
+Definition Majxy (x y:R) (n:nat) : R :=
+  Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S n) / INR (fact n).
+
+Lemma Majxy_cv_R0 : forall x y:R, Un_cv (Majxy x y) 0.
+intros.
+set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
+set (C0 := C ^ 4).
+cut (0 < C).
+intro.
+cut (0 < C0).
+intro.
+assert (H1 := cv_speed_pow_fact C0).
+unfold Un_cv in H1; unfold R_dist in H1.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+cut (0 < eps / C0);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; assumption ] ].
+elim (H1 (eps / C0) H3); intros N0 H4.
+exists N0; intros.
+replace (Majxy x y n) with (C0 ^ S n / INR (fact n)).
+simpl in |- *.
+apply Rmult_lt_reg_l with (Rabs (/ C0)).
+apply Rabs_pos_lt.
+apply Rinv_neq_0_compat.
+red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
+rewrite <- Rabs_mult.
+unfold Rminus in |- *; rewrite Rmult_plus_distr_l.
+rewrite Ropp_0; rewrite Rmult_0_r.
+unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+rewrite (Rabs_right (/ C0)).
+rewrite <- (Rmult_comm eps).
+replace (C0 ^ n * / INR (fact n) + 0) with (C0 ^ n * / INR (fact n) - 0);
+ [ idtac | ring ].
+unfold Rdiv in H4; apply H4; assumption.
+apply Rle_ge; left; apply Rinv_0_lt_compat; assumption.
+red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
+unfold Majxy in |- *.
+unfold C0 in |- *.
+rewrite pow_mult.
+unfold C in |- *; reflexivity.
+unfold C0 in |- *; apply pow_lt; assumption.
+apply Rlt_le_trans with 1.
+apply Rlt_0_1.
+unfold C in |- *.
+apply RmaxLess1.
+Qed.
+
+Lemma reste1_maj :
+ forall (x y:R) (N:nat),
+   (0 < N)%nat -> Rabs (Reste1 x y N) <= Majxy x y (pred N).
+intros.
+set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
+unfold Reste1 in |- *.
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       Rabs
+         (sum_f_R0
+            (fun l:nat =>
+               (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
+               x ^ (2 * S (l + k)) *
+               ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
+               y ^ (2 * (N - l))) (pred (N - k)))) (
+    pred N)).
+apply
+ (Rsum_abs
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
+            x ^ (2 * S (l + k)) * ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
+            y ^ (2 * (N - l))) (pred (N - k))) (pred N)).
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            Rabs
+              ((-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
+               x ^ (2 * S (l + k)) *
+               ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
+               y ^ (2 * (N - l)))) (pred (N - k))) (
+    pred N)).
+apply sum_Rle.
+intros.
+apply
+ (Rsum_abs
+    (fun l:nat =>
+       (-1) ^ S (l + n) / INR (fact (2 * S (l + n))) * x ^ (2 * S (l + n)) *
+       ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * 
+       y ^ (2 * (N - l))) (pred (N - n))).
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) *
+            C ^ (2 * S (N + k))) (pred (N - k))) (pred N)).
+apply sum_Rle; intros.
+apply sum_Rle; intros.
+unfold Rdiv in |- *; repeat rewrite Rabs_mult.
+do 2 rewrite pow_1_abs.
+do 2 rewrite Rmult_1_l.
+rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n))))).
+rewrite (Rabs_right (/ INR (fact (2 * (N - n0))))).
+rewrite mult_INR.
+rewrite Rinv_mult_distr.
+repeat rewrite Rmult_assoc.
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+rewrite <- Rmult_assoc.
+rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0))))).
+rewrite Rmult_assoc.
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+do 2 rewrite <- RPow_abs.
+apply Rle_trans with (Rabs x ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
+apply Rmult_le_compat_l.
+apply pow_le; apply Rabs_pos.
+apply pow_incr.
+split.
+apply Rabs_pos.
+unfold C in |- *.
+apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
+apply Rle_trans with (C ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
+do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0)))).
+apply Rmult_le_compat_l.
+apply pow_le.
+apply Rle_trans with 1.
+left; apply Rlt_0_1.
+unfold C in |- *; apply RmaxLess1.
+apply pow_incr.
+split.
+apply Rabs_pos.
+unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
+apply RmaxLess1.
+apply RmaxLess2.
+right.
+replace (2 * S (N + n))%nat with (2 * (N - n0) + 2 * S (n0 + n))%nat.
+rewrite pow_add.
+apply Rmult_comm.
+apply INR_eq; rewrite plus_INR; do 3 rewrite mult_INR.
+rewrite minus_INR.
+repeat rewrite S_INR; do 2 rewrite plus_INR; ring.
+apply le_trans with (pred (N - n)).
+exact H1.
+apply le_S_n.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_trans with N.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+assumption.
+apply lt_pred_n_n; assumption.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) * C ^ (4 * N))
+         (pred (N - k))) (pred N)).
+apply sum_Rle; intros.
+apply sum_Rle; intros.
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat.
+rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
+apply Rle_pow.
+unfold C in |- *; apply RmaxLess1.
+replace (4 * N)%nat with (2 * (2 * N))%nat; [ idtac | ring ].
+apply (fun m n p:nat => mult_le_compat_l p n m).
+replace (2 * N)%nat with (S (N + pred N)).
+apply le_n_S.
+apply plus_le_compat_l; assumption.
+rewrite pred_of_minus.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
+ rewrite minus_INR.
+repeat rewrite S_INR; ring.
+apply lt_le_S; assumption.
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => C ^ (4 * N) * Rsqr (/ INR (fact (S (N + k)))))
+         (pred (N - k))) (pred N)).
+apply sum_Rle; intros.
+apply sum_Rle; intros.
+rewrite <- (Rmult_comm (C ^ (4 * N))).
+apply Rmult_le_compat_l.
+apply pow_le.
+left; apply Rlt_le_trans with 1.
+apply Rlt_0_1.
+unfold C in |- *; apply RmaxLess1.
+replace (/ INR (fact (2 * S (n0 + n)) * fact (2 * (N - n0)))) with
+ (Binomial.C (2 * S (N + n)) (2 * S (n0 + n)) / INR (fact (2 * S (N + n)))).
+apply Rle_trans with
+ (Binomial.C (2 * S (N + n)) (S (N + n)) / INR (fact (2 * S (N + n)))).
+unfold Rdiv in |- *;
+ do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (N + n))))).
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply C_maj.
+apply (fun m n p:nat => mult_le_compat_l p n m).
+apply le_n_S.
+apply plus_le_compat_r.
+apply le_trans with (pred (N - n)).
+assumption.
+apply le_S_n.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_trans with N.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+assumption.
+apply lt_pred_n_n; assumption.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+right.
+unfold Rdiv in |- *; rewrite Rmult_comm.
+unfold Binomial.C in |- *.
+unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+replace (2 * S (N + n) - S (N + n))%nat with (S (N + n)).
+rewrite Rinv_mult_distr.
+unfold Rsqr in |- *; reflexivity.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_eq; rewrite S_INR; rewrite minus_INR.
+rewrite mult_INR; repeat rewrite S_INR; rewrite plus_INR; ring.
+apply le_n_2n.
+apply INR_fact_neq_0.
+unfold Rdiv in |- *; rewrite Rmult_comm.
+unfold Binomial.C in |- *.
+unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+replace (2 * S (N + n) - 2 * S (n0 + n))%nat with (2 * (N - n0))%nat.
+rewrite mult_INR.
+reflexivity.
+apply INR_eq; rewrite minus_INR.
+do 3 rewrite mult_INR; repeat rewrite S_INR; do 2 rewrite plus_INR;
+ rewrite minus_INR.
+ring.
+apply le_trans with (pred (N - n)).
+assumption.
+apply le_S_n.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_trans with N.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+assumption.
+apply lt_pred_n_n; assumption.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply (fun m n p:nat => mult_le_compat_l p n m).
+apply le_n_S.
+apply plus_le_compat_r.
+apply le_trans with (pred (N - n)).
+assumption.
+apply le_S_n.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_trans with N.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+assumption.
+apply lt_pred_n_n; assumption.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply INR_fact_neq_0.
+apply Rle_trans with
+ (sum_f_R0 (fun k:nat => INR N / INR (fact (S N)) * C ^ (4 * N)) (pred N)).
+apply sum_Rle; intros.
+rewrite <-
+ (scal_sum (fun _:nat => C ^ (4 * N)) (pred (N - n))
+    (Rsqr (/ INR (fact (S (N + n)))))).
+rewrite sum_cte.
+rewrite <- Rmult_assoc.
+do 2 rewrite <- (Rmult_comm (C ^ (4 * N))).
+rewrite Rmult_assoc.
+apply Rmult_le_compat_l.
+apply pow_le.
+left; apply Rlt_le_trans with 1.
+apply Rlt_0_1.
+unfold C in |- *; apply RmaxLess1.
+apply Rle_trans with (Rsqr (/ INR (fact (S (N + n)))) * INR N).
+apply Rmult_le_compat_l.
+apply Rle_0_sqr.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_INR.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+assumption.
+apply lt_pred_n_n; assumption.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
+apply pos_INR.
+apply Rle_trans with (/ INR (fact (S (N + n)))).
+pattern (/ INR (fact (S (N + n)))) at 2 in |- *; rewrite <- Rmult_1_r.
+unfold Rsqr in |- *.
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
+apply INR_fact_lt_0.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r.
+replace 1 with (INR 1).
+apply le_INR.
+apply lt_le_S.
+apply INR_lt; apply INR_fact_lt_0.
+reflexivity.
+apply INR_fact_neq_0.
+apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
+apply INR_fact_lt_0.
+rewrite <- Rinv_r_sym.
+apply Rmult_le_reg_l with (INR (fact (S N))).
+apply INR_fact_lt_0.
+rewrite Rmult_1_r.
+rewrite (Rmult_comm (INR (fact (S N)))).
+rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+apply le_INR.
+apply fact_le.
+apply le_n_S.
+apply le_plus_l.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+rewrite sum_cte.
+apply Rle_trans with (C ^ (4 * N) / INR (fact (pred N))).
+rewrite <- (Rmult_comm (C ^ (4 * N))).
+unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+apply pow_le.
+left; apply Rlt_le_trans with 1.
+apply Rlt_0_1.
+unfold C in |- *; apply RmaxLess1.
+cut (S (pred N) = N).
+intro; rewrite H0.
+pattern N at 2 in |- *; rewrite <- H0.
+do 2 rewrite fact_simpl.
+rewrite H0.
+repeat rewrite mult_INR.
+repeat rewrite Rinv_mult_distr.
+rewrite (Rmult_comm (/ INR (S N))).
+repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l.
+pattern (/ INR (fact (pred N))) at 2 in |- *; rewrite <- Rmult_1_r.
+rewrite Rmult_assoc.
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply Rmult_le_reg_l with (INR (S N)).
+apply lt_INR_0; apply lt_O_Sn.
+rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; rewrite Rmult_1_l.
+apply le_INR; apply le_n_Sn.
+apply not_O_INR; discriminate.
+apply not_O_INR.
+red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
+apply not_O_INR.
+red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
+apply INR_fact_neq_0.
+apply not_O_INR; discriminate.
+apply prod_neq_R0.
+apply not_O_INR.
+red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
+apply INR_fact_neq_0.
+symmetry  in |- *; apply S_pred with 0%nat; assumption.
+right.
+unfold Majxy in |- *.
+unfold C in |- *.
+replace (S (pred N)) with N.
+reflexivity.
+apply S_pred with 0%nat; assumption.
+Qed.
+
+Lemma reste2_maj :
+ forall (x y:R) (N:nat), (0 < N)%nat -> Rabs (Reste2 x y N) <= Majxy x y N.
+intros.
+set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
+unfold Reste2 in |- *.
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       Rabs
+         (sum_f_R0
+            (fun l:nat =>
+               (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
+               x ^ (2 * S (l + k) + 1) *
+               ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
+               y ^ (2 * (N - l) + 1)) (pred (N - k)))) (
+    pred N)).
+apply
+ (Rsum_abs
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
+            x ^ (2 * S (l + k) + 1) *
+            ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
+            y ^ (2 * (N - l) + 1)) (pred (N - k))) (
+    pred N)).
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            Rabs
+              ((-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
+               x ^ (2 * S (l + k) + 1) *
+               ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
+               y ^ (2 * (N - l) + 1))) (pred (N - k))) (
+    pred N)).
+apply sum_Rle.
+intros.
+apply
+ (Rsum_abs
+    (fun l:nat =>
+       (-1) ^ S (l + n) / INR (fact (2 * S (l + n) + 1)) *
+       x ^ (2 * S (l + n) + 1) *
+       ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
+       y ^ (2 * (N - l) + 1)) (pred (N - n))).
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
+            C ^ (2 * S (S (N + k)))) (pred (N - k))) (
+    pred N)).
+apply sum_Rle; intros.
+apply sum_Rle; intros.
+unfold Rdiv in |- *; repeat rewrite Rabs_mult.
+do 2 rewrite pow_1_abs.
+do 2 rewrite Rmult_1_l.
+rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n) + 1)))).
+rewrite (Rabs_right (/ INR (fact (2 * (N - n0) + 1)))).
+rewrite mult_INR.
+rewrite Rinv_mult_distr.
+repeat rewrite Rmult_assoc.
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+rewrite <- Rmult_assoc.
+rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0) + 1)))).
+rewrite Rmult_assoc.
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+do 2 rewrite <- RPow_abs.
+apply Rle_trans with (Rabs x ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
+apply Rmult_le_compat_l.
+apply pow_le; apply Rabs_pos.
+apply pow_incr.
+split.
+apply Rabs_pos.
+unfold C in |- *.
+apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
+apply Rle_trans with (C ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
+do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0) + 1))).
+apply Rmult_le_compat_l.
+apply pow_le.
+apply Rle_trans with 1.
+left; apply Rlt_0_1.
+unfold C in |- *; apply RmaxLess1.
+apply pow_incr.
+split.
+apply Rabs_pos.
+unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
+apply RmaxLess1.
+apply RmaxLess2.
+right.
+replace (2 * S (S (N + n)))%nat with
+ (2 * (N - n0) + 1 + (2 * S (n0 + n) + 1))%nat.
+repeat rewrite pow_add.
+ring.
+apply INR_eq; repeat rewrite plus_INR; do 3 rewrite mult_INR.
+rewrite minus_INR.
+repeat rewrite S_INR; do 2 rewrite plus_INR; ring.
+apply le_trans with (pred (N - n)).
+exact H1.
+apply le_S_n.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_trans with N.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+assumption.
+apply lt_pred_n_n; assumption.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply Rle_ge; left; apply Rinv_0_lt_compat.
+apply INR_fact_lt_0.
+apply Rle_ge; left; apply Rinv_0_lt_compat.
+apply INR_fact_lt_0.
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
+            C ^ (4 * S N)) (pred (N - k))) (pred N)).
+apply sum_Rle; intros.
+apply sum_Rle; intros.
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat.
+rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
+apply Rle_pow.
+unfold C in |- *; apply RmaxLess1.
+replace (4 * S N)%nat with (2 * (2 * S N))%nat; [ idtac | ring ].
+apply (fun m n p:nat => mult_le_compat_l p n m).
+replace (2 * S N)%nat with (S (S (N + N))).
+repeat apply le_n_S.
+apply plus_le_compat_l.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply INR_eq; do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR.
+repeat rewrite S_INR; ring.
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat => C ^ (4 * S N) * Rsqr (/ INR (fact (S (S (N + k))))))
+         (pred (N - k))) (pred N)).
+apply sum_Rle; intros.
+apply sum_Rle; intros.
+rewrite <- (Rmult_comm (C ^ (4 * S N))).
+apply Rmult_le_compat_l.
+apply pow_le.
+left; apply Rlt_le_trans with 1.
+apply Rlt_0_1.
+unfold C in |- *; apply RmaxLess1.
+replace (/ INR (fact (2 * S (n0 + n) + 1) * fact (2 * (N - n0) + 1))) with
+ (Binomial.C (2 * S (S (N + n))) (2 * S (n0 + n) + 1) /
+  INR (fact (2 * S (S (N + n))))).
+apply Rle_trans with
+ (Binomial.C (2 * S (S (N + n))) (S (S (N + n))) /
+  INR (fact (2 * S (S (N + n))))).
+unfold Rdiv in |- *;
+ do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (S (N + n)))))).
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply C_maj.
+apply le_trans with (2 * S (S (n0 + n)))%nat.
+replace (2 * S (S (n0 + n)))%nat with (S (2 * S (n0 + n) + 1)).
+apply le_n_Sn.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite mult_INR;
+ repeat rewrite S_INR; rewrite plus_INR; ring.
+apply (fun m n p:nat => mult_le_compat_l p n m).
+repeat apply le_n_S.
+apply plus_le_compat_r.
+apply le_trans with (pred (N - n)).
+assumption.
+apply le_S_n.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_trans with N.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+assumption.
+apply lt_pred_n_n; assumption.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+right.
+unfold Rdiv in |- *; rewrite Rmult_comm.
+unfold Binomial.C in |- *.
+unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+replace (2 * S (S (N + n)) - S (S (N + n)))%nat with (S (S (N + n))).
+rewrite Rinv_mult_distr.
+unfold Rsqr in |- *; reflexivity.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_eq; do 2 rewrite S_INR; rewrite minus_INR.
+rewrite mult_INR; repeat rewrite S_INR; rewrite plus_INR; ring.
+apply le_n_2n.
+apply INR_fact_neq_0.
+unfold Rdiv in |- *; rewrite Rmult_comm.
+unfold Binomial.C in |- *.
+unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+replace (2 * S (S (N + n)) - (2 * S (n0 + n) + 1))%nat with
+ (2 * (N - n0) + 1)%nat.
+rewrite mult_INR.
+reflexivity.
+apply INR_eq; rewrite minus_INR.
+do 2 rewrite plus_INR; do 3 rewrite mult_INR; repeat rewrite S_INR;
+ do 2 rewrite plus_INR; rewrite minus_INR.
+ring.
+apply le_trans with (pred (N - n)).
+assumption.
+apply le_S_n.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_trans with N.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+assumption.
+apply lt_pred_n_n; assumption.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_trans with (2 * S (S (n0 + n)))%nat.
+replace (2 * S (S (n0 + n)))%nat with (S (2 * S (n0 + n) + 1)).
+apply le_n_Sn.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite mult_INR;
+ repeat rewrite S_INR; rewrite plus_INR; ring.
+apply (fun m n p:nat => mult_le_compat_l p n m).
+repeat apply le_n_S.
+apply plus_le_compat_r.
+apply le_trans with (pred (N - n)).
+assumption.
+apply le_S_n.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_trans with N.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply le_n_Sn.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+assumption.
+apply lt_pred_n_n; assumption.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply INR_fact_neq_0.
+apply Rle_trans with
+ (sum_f_R0 (fun k:nat => INR N / INR (fact (S (S N))) * C ^ (4 * S N))
+    (pred N)).
+apply sum_Rle; intros.
+rewrite <-
+ (scal_sum (fun _:nat => C ^ (4 * S N)) (pred (N - n))
+    (Rsqr (/ INR (fact (S (S (N + n))))))).
+rewrite sum_cte.
+rewrite <- Rmult_assoc.
+do 2 rewrite <- (Rmult_comm (C ^ (4 * S N))).
+rewrite Rmult_assoc.
+apply Rmult_le_compat_l.
+apply pow_le.
+left; apply Rlt_le_trans with 1.
+apply Rlt_0_1.
+unfold C in |- *; apply RmaxLess1.
+apply Rle_trans with (Rsqr (/ INR (fact (S (S (N + n))))) * INR N).
+apply Rmult_le_compat_l.
+apply Rle_0_sqr.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_INR.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+assumption.
+apply lt_pred_n_n; assumption.
+apply le_trans with (pred N).
+assumption.
+apply le_pred_n.
+rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
+apply pos_INR.
+apply Rle_trans with (/ INR (fact (S (S (N + n))))).
+pattern (/ INR (fact (S (S (N + n))))) at 2 in |- *; rewrite <- Rmult_1_r.
+unfold Rsqr in |- *.
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
+apply INR_fact_lt_0.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r.
+replace 1 with (INR 1).
+apply le_INR.
+apply lt_le_S.
+apply INR_lt; apply INR_fact_lt_0.
+reflexivity.
+apply INR_fact_neq_0.
+apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
+apply INR_fact_lt_0.
+rewrite <- Rinv_r_sym.
+apply Rmult_le_reg_l with (INR (fact (S (S N)))).
+apply INR_fact_lt_0.
+rewrite Rmult_1_r.
+rewrite (Rmult_comm (INR (fact (S (S N))))).
+rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+apply le_INR.
+apply fact_le.
+repeat apply le_n_S.
+apply le_plus_l.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+rewrite sum_cte.
+apply Rle_trans with (C ^ (4 * S N) / INR (fact N)).
+rewrite <- (Rmult_comm (C ^ (4 * S N))).
+unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+apply pow_le.
+left; apply Rlt_le_trans with 1.
+apply Rlt_0_1.
+unfold C in |- *; apply RmaxLess1.
+cut (S (pred N) = N).
+intro; rewrite H0.
+do 2 rewrite fact_simpl.
+repeat rewrite mult_INR.
+repeat rewrite Rinv_mult_distr.
+apply Rle_trans with
+ (INR (S (S N)) * (/ INR (S (S N)) * (/ INR (S N) * / INR (fact N))) * INR N).
+repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm (INR N)).
+rewrite (Rmult_comm (INR (S (S N)))).
+apply Rmult_le_compat_l.
+repeat apply Rmult_le_pos.
+left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+left; apply Rinv_0_lt_compat.
+apply INR_fact_lt_0.
+apply pos_INR.
+apply le_INR.
+apply le_trans with (S N); apply le_n_Sn.
+repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l.
+apply Rle_trans with (/ INR (S N) * / INR (fact N) * INR (S N)).
+repeat rewrite Rmult_assoc.
+repeat apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply le_INR; apply le_n_Sn.
+rewrite (Rmult_comm (/ INR (S N))).
+rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; right; reflexivity.
+apply not_O_INR; discriminate.
+apply not_O_INR; discriminate.
+apply not_O_INR; discriminate.
+apply INR_fact_neq_0.
+apply not_O_INR; discriminate.
+apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
+symmetry  in |- *; apply S_pred with 0%nat; assumption.
+right.
+unfold Majxy in |- *.
+unfold C in |- *.
+reflexivity.
+Qed.
+
+Lemma reste1_cv_R0 : forall x y:R, Un_cv (Reste1 x y) 0.
+intros.
+assert (H := Majxy_cv_R0 x y).
+unfold Un_cv in H; unfold R_dist in H.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+elim (H eps H0); intros N0 H1.
+exists (S N0); intros.
+unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
+apply Rle_lt_trans with (Rabs (Majxy x y (pred n))).
+rewrite (Rabs_right (Majxy x y (pred n))).
+apply reste1_maj.
+apply lt_le_trans with (S N0).
+apply lt_O_Sn.
+assumption.
+apply Rle_ge.
+unfold Majxy in |- *.
+unfold Rdiv in |- *; apply Rmult_le_pos.
+apply pow_le.
+apply Rle_trans with 1.
+left; apply Rlt_0_1.
+apply RmaxLess1.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+replace (Majxy x y (pred n)) with (Majxy x y (pred n) - 0); [ idtac | ring ].
+apply H1.
+unfold ge in |- *; apply le_S_n.
+replace (S (pred n)) with n.
+assumption.
+apply S_pred with 0%nat.
+apply lt_le_trans with (S N0); [ apply lt_O_Sn | assumption ].
+Qed.
+
+Lemma reste2_cv_R0 : forall x y:R, Un_cv (Reste2 x y) 0.
+intros.
+assert (H := Majxy_cv_R0 x y).
+unfold Un_cv in H; unfold R_dist in H.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+elim (H eps H0); intros N0 H1.
+exists (S N0); intros.
+unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
+apply Rle_lt_trans with (Rabs (Majxy x y n)).
+rewrite (Rabs_right (Majxy x y n)).
+apply reste2_maj.
+apply lt_le_trans with (S N0).
+apply lt_O_Sn.
+assumption.
+apply Rle_ge.
+unfold Majxy in |- *.
+unfold Rdiv in |- *; apply Rmult_le_pos.
+apply pow_le.
+apply Rle_trans with 1.
+left; apply Rlt_0_1.
+apply RmaxLess1.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+replace (Majxy x y n) with (Majxy x y n - 0); [ idtac | ring ].
+apply H1.
+unfold ge in |- *; apply le_trans with (S N0).
+apply le_n_Sn.
+exact H2.
+Qed.
+
+Lemma reste_cv_R0 : forall x y:R, Un_cv (Reste x y) 0.
+intros.
+unfold Reste in |- *.
+set (An := fun n:nat => Reste2 x y n).
+set (Bn := fun n:nat => Reste1 x y (S n)).
+cut
+ (Un_cv (fun n:nat => An n - Bn n) (0 - 0) ->
+  Un_cv (fun N:nat => Reste2 x y N - Reste1 x y (S N)) 0).
+intro.
+apply H.
+apply CV_minus.
+unfold An in |- *.
+replace (fun n:nat => Reste2 x y n) with (Reste2 x y).
+apply reste2_cv_R0.
+reflexivity.
+unfold Bn in |- *.
+assert (H0 := reste1_cv_R0 x y).
+unfold Un_cv in H0; unfold R_dist in H0.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+elim (H0 eps H1); intros N0 H2.
+exists N0; intros.
+apply H2.
+unfold ge in |- *; apply le_trans with (S N0).
+apply le_n_Sn.
+apply le_n_S; assumption.
+unfold An, Bn in |- *.
+intro.
+replace 0 with (0 - 0); [ idtac | ring ].
+exact H.
+Qed.
+
+Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y. 
+intros. 
+cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)). 
+cut (Un_cv (C1 x y) (cos (x + y))). 
+intros. 
+apply UL_sequence with (C1 x y); assumption. 
+apply C1_cvg. 
+unfold Un_cv in |- *; unfold R_dist in |- *. 
+intros. 
+assert (H0 := A1_cvg x). 
+assert (H1 := A1_cvg y). 
+assert (H2 := B1_cvg x). 
+assert (H3 := B1_cvg y). 
+assert (H4 := CV_mult _ _ _ _ H0 H1). 
+assert (H5 := CV_mult _ _ _ _ H2 H3). 
+assert (H6 := reste_cv_R0 x y).
+unfold Un_cv in H4; unfold Un_cv in H5; unfold Un_cv in H6.
+unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6. 
+cut (0 < eps / 3);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. 
+elim (H4 (eps / 3) H7); intros N1 H8. 
+elim (H5 (eps / 3) H7); intros N2 H9. 
+elim (H6 (eps / 3) H7); intros N3 H10.
+set (N := S (S (max (max N1 N2) N3))). 
+exists N. 
+intros. 
+cut (n = S (pred n)). 
+intro; rewrite H12. 
+rewrite <- cos_plus_form. 
+rewrite <- H12. 
+apply Rle_lt_trans with
+ (Rabs (A1 x n * A1 y n - cos x * cos y) +
+  Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))). 
+replace
+ (A1 x n * A1 y n - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n) -
+  (cos x * cos y - sin x * sin y)) with
+ (A1 x n * A1 y n - cos x * cos y +
+  (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n)));
+ [ apply Rabs_triang | ring ].
+replace eps with (eps / 3 + (eps / 3 + eps / 3)).
+apply Rplus_lt_compat. 
+apply H8. 
+unfold ge in |- *; apply le_trans with N. 
+unfold N in |- *. 
+apply le_trans with (max N1 N2). 
+apply le_max_l. 
+apply le_trans with (max (max N1 N2) N3).
+apply le_max_l.
+apply le_trans with (S (max (max N1 N2) N3)); apply le_n_Sn.
+assumption. 
+apply Rle_lt_trans with
+ (Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n)) +
+  Rabs (Reste x y (pred n))).
+apply Rabs_triang.
+apply Rplus_lt_compat.
+rewrite <- Rabs_Ropp. 
+rewrite Ropp_minus_distr. 
+apply H9. 
+unfold ge in |- *; apply le_trans with (max N1 N2). 
+apply le_max_r. 
+apply le_S_n. 
+rewrite <- H12. 
+apply le_trans with N.
+unfold N in |- *.
+apply le_n_S.
+apply le_trans with (max (max N1 N2) N3).
+apply le_max_l.
+apply le_n_Sn.
+assumption.
+replace (Reste x y (pred n)) with (Reste x y (pred n) - 0).
+apply H10.
+unfold ge in |- *.
+apply le_S_n.
+rewrite <- H12.
+apply le_trans with N.
+unfold N in |- *.
+apply le_n_S.
+apply le_trans with (max (max N1 N2) N3).
+apply le_max_r.
+apply le_n_Sn.
+assumption.
+ring.
+pattern eps at 4 in |- *; replace eps with (3 * (eps / 3)).
+ring.
+unfold Rdiv in |- *.
+rewrite <- Rmult_assoc.
+apply Rinv_r_simpl_m.
+discrR.
+apply lt_le_trans with (pred N).
+unfold N in |- *; simpl in |- *; apply lt_O_Sn.
+apply le_S_n.
+rewrite <- H12.
+replace (S (pred N)) with N.
+assumption.
+unfold N in |- *; simpl in |- *; reflexivity.
+cut (0 < N)%nat. 
+intro. 
+cut (0 < n)%nat. 
+intro. 
+apply S_pred with 0%nat; assumption.
+apply lt_le_trans with N; assumption. 
+unfold N in |- *; apply lt_O_Sn.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v
new file mode 100644
index 00000000..9f76a5ad
--- /dev/null
+++ b/theories/Reals/Cos_rel.v
@@ -0,0 +1,420 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Cos_rel.v,v 1.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo_def.
+Open Local Scope R_scope.
+
+Definition A1 (x:R) (N:nat) : R :=
+  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N. 
+ 
+Definition B1 (x:R) (N:nat) : R :=
+  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
+    N. 
+ 
+Definition C1 (x y:R) (N:nat) : R :=
+  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N. 
+ 
+Definition Reste1 (x y:R) (N:nat) : R :=
+  sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
+            x ^ (2 * S (l + k)) * ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
+            y ^ (2 * (N - l))) (pred (N - k))) (pred N).
+
+Definition Reste2 (x y:R) (N:nat) : R :=
+  sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
+            x ^ (2 * S (l + k) + 1) *
+            ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
+            y ^ (2 * (N - l) + 1)) (pred (N - k))) (
+    pred N).
+
+Definition Reste (x y:R) (N:nat) : R := Reste2 x y N - Reste1 x y (S N).
+
+(* Here is the main result that will be used to prove that (cos (x+y))=(cos x)(cos y)-(sin x)(sin y) *)
+Theorem cos_plus_form :
+ forall (x y:R) (n:nat),
+   (0 < n)%nat ->
+   A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n). 
+intros.
+unfold A1, B1 in |- *.
+rewrite
+ (cauchy_finite (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k))
+    (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * y ^ (2 * k)) (
+    S n)).
+rewrite
+ (cauchy_finite
+    (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
+    (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * y ^ (2 * k + 1)) n H)
+ .
+unfold Reste in |- *.
+replace
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
+            x ^ (2 * S (l + k)) *
+            ((-1) ^ (S n - l) / INR (fact (2 * (S n - l))) *
+             y ^ (2 * (S n - l)))) (pred (S n - k))) (
+    pred (S n))) with (Reste1 x y (S n)).
+replace
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
+            x ^ (2 * S (l + k) + 1) *
+            ((-1) ^ (n - l) / INR (fact (2 * (n - l) + 1)) *
+             y ^ (2 * (n - l) + 1))) (pred (n - k))) (
+    pred n)) with (Reste2 x y n).
+ring.
+replace
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun p:nat =>
+            (-1) ^ p / INR (fact (2 * p)) * x ^ (2 * p) *
+            ((-1) ^ (k - p) / INR (fact (2 * (k - p))) * y ^ (2 * (k - p))))
+         k) (S n)) with
+ (sum_f_R0
+    (fun k:nat =>
+       (-1) ^ k / INR (fact (2 * k)) *
+       sum_f_R0
+         (fun l:nat => C (2 * k) (2 * l) * x ^ (2 * l) * y ^ (2 * (k - l))) k)
+    (S n)).
+set
+ (sin_nnn :=
+  fun n:nat =>
+    match n with
+    | O => 0
+    | S p =>
+        (-1) ^ S p / INR (fact (2 * S p)) *
+        sum_f_R0
+          (fun l:nat =>
+             C (2 * S p) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (p - l))) p
+    end).
+replace
+ (-
+  sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun p:nat =>
+            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
+            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
+             y ^ (2 * (k - p) + 1))) k) n) with (sum_f_R0 sin_nnn (S n)).
+rewrite <- sum_plus.
+unfold C1 in |- *.
+apply sum_eq; intros.
+induction  i as [| i Hreci].
+simpl in |- *.
+rewrite Rplus_0_l.
+replace (C 0 0) with 1.
+unfold Rdiv in |- *; rewrite Rinv_1.
+ring.
+unfold C in |- *.
+rewrite <- minus_n_n.
+simpl in |- *.
+unfold Rdiv in |- *; rewrite Rmult_1_r; rewrite Rinv_1; ring.
+unfold sin_nnn in |- *.
+rewrite <- Rmult_plus_distr_l.
+apply Rmult_eq_compat_l.
+rewrite binomial.
+set (Wn := fun i0:nat => C (2 * S i) i0 * x ^ i0 * y ^ (2 * S i - i0)).
+replace
+ (sum_f_R0
+    (fun l:nat => C (2 * S i) (2 * l) * x ^ (2 * l) * y ^ (2 * (S i - l)))
+    (S i)) with (sum_f_R0 (fun l:nat => Wn (2 * l)%nat) (S i)).
+replace
+ (sum_f_R0
+    (fun l:nat =>
+       C (2 * S i) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (i - l))) i) with
+ (sum_f_R0 (fun l:nat => Wn (S (2 * l))) i).
+rewrite Rplus_comm.
+apply sum_decomposition.
+apply sum_eq; intros.
+unfold Wn in |- *.
+apply Rmult_eq_compat_l.
+replace (2 * S i - S (2 * i0))%nat with (S (2 * (i - i0))).
+reflexivity.
+apply INR_eq.
+rewrite S_INR; rewrite mult_INR.
+repeat rewrite minus_INR.
+rewrite mult_INR; repeat rewrite S_INR.
+rewrite mult_INR; repeat rewrite S_INR; ring.
+replace (2 * S i)%nat with (S (S (2 * i))).
+apply le_n_S.
+apply le_trans with (2 * i)%nat.
+apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
+apply le_n_Sn.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+assumption.
+apply sum_eq; intros.
+unfold Wn in |- *.
+apply Rmult_eq_compat_l.
+replace (2 * S i - 2 * i0)%nat with (2 * (S i - i0))%nat.
+reflexivity.
+apply INR_eq.
+rewrite mult_INR.
+repeat rewrite minus_INR.
+rewrite mult_INR; repeat rewrite S_INR.
+rewrite mult_INR; repeat rewrite S_INR; ring.
+apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
+assumption.
+rewrite <- (Ropp_involutive (sum_f_R0 sin_nnn (S n))).
+apply Ropp_eq_compat.
+replace (- sum_f_R0 sin_nnn (S n)) with (-1 * sum_f_R0 sin_nnn (S n));
+ [ idtac | ring ].
+rewrite scal_sum.
+rewrite decomp_sum.
+replace (sin_nnn 0%nat) with 0.
+rewrite Rmult_0_l; rewrite Rplus_0_l.
+replace (pred (S n)) with n; [ idtac | reflexivity ].
+apply sum_eq; intros.
+rewrite Rmult_comm.
+unfold sin_nnn in |- *.
+rewrite scal_sum.
+rewrite scal_sum.
+apply sum_eq; intros.
+unfold Rdiv in |- *.
+repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm (/ INR (fact (2 * S i)))).
+repeat rewrite <- Rmult_assoc.
+rewrite <- (Rmult_comm (/ INR (fact (2 * S i)))).
+repeat rewrite <- Rmult_assoc.
+replace (/ INR (fact (2 * S i)) * C (2 * S i) (S (2 * i0))) with
+ (/ INR (fact (2 * i0 + 1)) * / INR (fact (2 * (i - i0) + 1))).
+replace (S (2 * i0)) with (2 * i0 + 1)%nat; [ idtac | ring ].
+replace (S (2 * (i - i0))) with (2 * (i - i0) + 1)%nat; [ idtac | ring ].
+replace ((-1) ^ S i) with (-1 * (-1) ^ i0 * (-1) ^ (i - i0)).
+ring.
+simpl in |- *.
+pattern i at 2 in |- *; replace i with (i0 + (i - i0))%nat.
+rewrite pow_add.
+ring.
+symmetry  in |- *; apply le_plus_minus; assumption.
+unfold C in |- *.
+unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+rewrite Rinv_mult_distr.
+replace (S (2 * i0)) with (2 * i0 + 1)%nat;
+ [ apply Rmult_eq_compat_l | ring ].
+replace (2 * S i - (2 * i0 + 1))%nat with (2 * (i - i0) + 1)%nat.
+reflexivity.
+apply INR_eq.
+rewrite plus_INR; rewrite mult_INR; repeat rewrite minus_INR.
+rewrite plus_INR; do 2 rewrite mult_INR; repeat rewrite S_INR; ring.
+replace (2 * i0 + 1)%nat with (S (2 * i0)).
+replace (2 * S i)%nat with (S (S (2 * i))).
+apply le_n_S.
+apply le_trans with (2 * i)%nat.
+apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
+apply le_n_Sn.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
+ repeat rewrite S_INR; ring.
+assumption.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+reflexivity.
+apply lt_O_Sn.
+apply sum_eq; intros.
+rewrite scal_sum.
+apply sum_eq; intros.
+unfold Rdiv in |- *.
+repeat rewrite <- Rmult_assoc.
+rewrite <- (Rmult_comm (/ INR (fact (2 * i)))).
+repeat rewrite <- Rmult_assoc.
+replace (/ INR (fact (2 * i)) * C (2 * i) (2 * i0)) with
+ (/ INR (fact (2 * i0)) * / INR (fact (2 * (i - i0)))).
+replace ((-1) ^ i) with ((-1) ^ i0 * (-1) ^ (i - i0)).
+ring.
+pattern i at 2 in |- *; replace i with (i0 + (i - i0))%nat.
+rewrite pow_add.
+ring.
+symmetry  in |- *; apply le_plus_minus; assumption.
+unfold C in |- *.
+unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+rewrite Rinv_mult_distr.
+replace (2 * i - 2 * i0)%nat with (2 * (i - i0))%nat.
+reflexivity.
+apply INR_eq.
+rewrite mult_INR; repeat rewrite minus_INR.
+do 2 rewrite mult_INR; repeat rewrite S_INR; ring.
+apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
+assumption.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+unfold Reste2 in |- *; apply sum_eq; intros.
+apply sum_eq; intros.
+unfold Rdiv in |- *; ring. 
+unfold Reste1 in |- *; apply sum_eq; intros.
+apply sum_eq; intros.
+unfold Rdiv in |- *; ring.
+apply lt_O_Sn.
+Qed.
+
+Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i. 
+intros. 
+assert (H := pow_Rsqr x i).
+unfold Rsqr in H; exact H.
+Qed. 
+ 
+Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x). 
+intro. 
+assert (H := exist_cos (x * x)). 
+elim H; intros. 
+assert (p_i := p). 
+unfold cos_in in p. 
+unfold cos_n, infinit_sum in p. 
+unfold R_dist in p. 
+cut (cos x = x0). 
+intro. 
+rewrite H0. 
+unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
+elim (p eps H1); intros. 
+exists x1; intros. 
+unfold A1 in |- *. 
+replace
+ (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with
+ (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n). 
+apply H2; assumption. 
+apply sum_eq. 
+intros. 
+replace ((x * x) ^ i) with (x ^ (2 * i)). 
+reflexivity. 
+apply pow_sqr. 
+unfold cos in |- *. 
+case (exist_cos (Rsqr x)). 
+unfold Rsqr in |- *; intros. 
+unfold cos_in in p_i. 
+unfold cos_in in c. 
+apply uniqueness_sum with (fun i:nat => cos_n i * (x * x) ^ i); assumption. 
+Qed. 
+ 
+Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)). 
+intros. 
+assert (H := exist_cos ((x + y) * (x + y))). 
+elim H; intros. 
+assert (p_i := p). 
+unfold cos_in in p. 
+unfold cos_n, infinit_sum in p. 
+unfold R_dist in p. 
+cut (cos (x + y) = x0). 
+intro. 
+rewrite H0. 
+unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
+elim (p eps H1); intros. 
+exists x1; intros. 
+unfold C1 in |- *. 
+replace
+ (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n)
+ with
+ (sum_f_R0
+    (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n). 
+apply H2; assumption. 
+apply sum_eq. 
+intros. 
+replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)). 
+reflexivity. 
+apply pow_sqr. 
+unfold cos in |- *. 
+case (exist_cos (Rsqr (x + y))). 
+unfold Rsqr in |- *; intros. 
+unfold cos_in in p_i. 
+unfold cos_in in c. 
+apply uniqueness_sum with (fun i:nat => cos_n i * ((x + y) * (x + y)) ^ i);
+ assumption. 
+Qed. 
+ 
+Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x). 
+intro. 
+case (Req_dec x 0); intro. 
+rewrite H. 
+rewrite sin_0. 
+unfold B1 in |- *. 
+unfold Un_cv in |- *; unfold R_dist in |- *; intros; exists 0%nat; intros. 
+replace
+ (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1))
+    n) with 0. 
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. 
+induction  n as [| n Hrecn]. 
+simpl in |- *; ring. 
+rewrite tech5; rewrite <- Hrecn. 
+simpl in |- *; ring. 
+unfold ge in |- *; apply le_O_n. 
+assert (H0 := exist_sin (x * x)). 
+elim H0; intros. 
+assert (p_i := p). 
+unfold sin_in in p. 
+unfold sin_n, infinit_sum in p. 
+unfold R_dist in p. 
+cut (sin x = x * x0). 
+intro. 
+rewrite H1. 
+unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
+cut (0 < eps / Rabs x);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ]. 
+elim (p (eps / Rabs x) H3); intros. 
+exists x1; intros. 
+unfold B1 in |- *. 
+replace
+ (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
+    n) with
+ (x *
+  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n). 
+replace
+ (x *
+  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
+  x * x0) with
+ (x *
+  (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
+   x0)); [ idtac | ring ]. 
+rewrite Rabs_mult. 
+apply Rmult_lt_reg_l with (/ Rabs x). 
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. 
+rewrite <- Rmult_assoc. 
+rewrite <- Rinv_l_sym. 
+rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H4; apply H4;
+ assumption. 
+apply Rabs_no_R0; assumption. 
+rewrite scal_sum. 
+apply sum_eq. 
+intros. 
+rewrite pow_add. 
+rewrite pow_sqr. 
+simpl in |- *. 
+ring. 
+unfold sin in |- *. 
+case (exist_sin (Rsqr x)). 
+unfold Rsqr in |- *; intros. 
+unfold sin_in in p_i. 
+unfold sin_in in s. 
+assert
+ (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s). 
+rewrite H1; reflexivity. 
+Qed. 
\ No newline at end of file
diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v
new file mode 100644
index 00000000..f897e258
--- /dev/null
+++ b/theories/Reals/DiscrR.v
@@ -0,0 +1,97 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i        $Id: DiscrR.v,v 1.21.2.1 2004/07/16 19:31:10 herbelin Exp $       i*)
+
+Require Import RIneq.
+Require Import Omega. Open Local Scope R_scope.
+
+Lemma Rlt_R0_R2 : 0 < 2.
+replace 2 with (INR 2); [ apply lt_INR_0; apply lt_O_Sn | reflexivity ].
+Qed.
+
+Lemma Rplus_lt_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x + y.
+intros.
+apply Rlt_trans with x.
+assumption. 
+pattern x at 1 in |- *; rewrite <- Rplus_0_r.
+apply Rplus_lt_compat_l.
+assumption.
+Qed.
+
+Lemma IZR_eq : forall z1 z2:Z, z1 = z2 -> IZR z1 = IZR z2.
+intros; rewrite H; reflexivity.
+Qed.
+
+Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 <> IZR z2.
+intros; red in |- *; intro; elim H; apply eq_IZR; assumption.
+Qed.
+
+Ltac discrR :=
+  try
+   match goal with
+   |  |- (?X1 <> ?X2) =>
+       replace 2 with (IZR 2);
+        [ replace 1 with (IZR 1);
+           [ replace 0 with (IZR 0);
+              [ repeat
+                 rewrite <- plus_IZR ||
+                   rewrite <- mult_IZR ||
+                     rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
+                 apply IZR_neq; try discriminate
+              | reflexivity ]
+           | reflexivity ]
+        | reflexivity ]
+   end.
+
+Ltac prove_sup0 :=
+  match goal with
+  |  |- (0 < 1) => apply Rlt_0_1
+  |  |- (0 < ?X1) =>
+      repeat
+       (apply Rmult_lt_0_compat || apply Rplus_lt_pos;
+         try apply Rlt_0_1 || apply Rlt_R0_R2)
+  |  |- (?X1 > 0) => change (0 < X1) in |- *; prove_sup0
+  end.
+
+Ltac omega_sup :=
+  replace 2 with (IZR 2);
+   [ replace 1 with (IZR 1);
+      [ replace 0 with (IZR 0);
+         [ repeat
+            rewrite <- plus_IZR ||
+              rewrite <- mult_IZR ||
+                rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; 
+            apply IZR_lt; omega
+         | reflexivity ]
+      | reflexivity ]
+   | reflexivity ].
+  
+Ltac prove_sup :=
+  match goal with
+  |  |- (?X1 > ?X2) => change (X2 < X1) in |- *; prove_sup
+  |  |- (0 < ?X1) => prove_sup0
+  |  |- (- ?X1 < 0) => rewrite <- Ropp_0; prove_sup
+  |  |- (- ?X1 < - ?X2) => apply Ropp_lt_gt_contravar; prove_sup
+  |  |- (- ?X1 < ?X2) => apply Rlt_trans with 0; prove_sup
+  |  |- (?X1 < ?X2) => omega_sup
+  | _ => idtac
+  end.
+
+Ltac Rcompute :=
+  replace 2 with (IZR 2);
+   [ replace 1 with (IZR 1);
+      [ replace 0 with (IZR 0);
+         [ repeat
+            rewrite <- plus_IZR ||
+              rewrite <- mult_IZR ||
+                rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; 
+            apply IZR_eq; try reflexivity
+         | reflexivity ]
+      | reflexivity ]
+   | reflexivity ].
\ No newline at end of file
diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v
new file mode 100644
index 00000000..fcaeb11e
--- /dev/null
+++ b/theories/Reals/Exp_prop.v
@@ -0,0 +1,1011 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Exp_prop.v,v 1.16.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import Ranalysis1.
+Require Import PSeries_reg.
+Require Import Div2.
+Require Import Even.
+Require Import Max.
+Open Local Scope nat_scope.
+Open Local Scope R_scope.
+
+Definition E1 (x:R) (N:nat) : R :=
+  sum_f_R0 (fun k:nat => / INR (fact k) * x ^ k) N.
+
+Lemma E1_cvg : forall x:R, Un_cv (E1 x) (exp x).
+intro; unfold exp in |- *; unfold projT1 in |- *.
+case (exist_exp x); intro.
+unfold exp_in, Un_cv in |- *; unfold infinit_sum, E1 in |- *; trivial.
+Qed.
+
+Definition Reste_E (x y:R) (N:nat) : R :=
+  sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            / INR (fact (S (l + k))) * x ^ S (l + k) *
+            (/ INR (fact (N - l)) * y ^ (N - l))) (
+         pred (N - k))) (pred N).
+
+Lemma exp_form :
+ forall (x y:R) (n:nat),
+   (0 < n)%nat -> E1 x n * E1 y n - Reste_E x y n = E1 (x + y) n.
+intros; unfold E1 in |- *.
+rewrite cauchy_finite.
+unfold Reste_E in |- *; unfold Rminus in |- *; rewrite Rplus_assoc;
+ rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq; 
+ intros.
+rewrite binomial.
+rewrite scal_sum; apply sum_eq; intros.
+unfold C in |- *; unfold Rdiv in |- *; repeat rewrite Rmult_assoc;
+ rewrite (Rmult_comm (INR (fact i))); repeat rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; rewrite Rinv_mult_distr.
+ring.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply H.
+Qed.
+
+Definition maj_Reste_E (x y:R) (N:nat) : R :=
+  4 *
+  (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * N) /
+   Rsqr (INR (fact (div2 (pred N))))).
+
+Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x.
+intros; apply Rmult_le_reg_l with x.
+apply H.
+rewrite <- Rinv_r_sym.
+apply Rmult_le_reg_l with y.
+apply H0.
+rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; apply H1.
+red in |- *; intro; rewrite H2 in H0; elim (Rlt_irrefl _ H0).
+red in |- *; intro; rewrite H2 in H; elim (Rlt_irrefl _ H).
+Qed.
+
+(**********)
+Lemma div2_double : forall N:nat, div2 (2 * N) = N.
+intro; induction  N as [| N HrecN].
+reflexivity.
+replace (2 * S N)%nat with (S (S (2 * N))).
+simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+Qed.
+
+Lemma div2_S_double : forall N:nat, div2 (S (2 * N)) = N.
+intro; induction  N as [| N HrecN].
+reflexivity.
+replace (2 * S N)%nat with (S (S (2 * N))).
+simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+Qed.
+
+Lemma div2_not_R0 : forall N:nat, (1 < N)%nat -> (0 < div2 N)%nat.
+intros; induction  N as [| N HrecN].
+elim (lt_n_O _ H).
+cut ((1 < N)%nat \/ N = 1%nat).
+intro; elim H0; intro.
+assert (H2 := even_odd_dec N).
+elim H2; intro.
+rewrite <- (even_div2 _ a); apply HrecN; assumption.
+rewrite <- (odd_div2 _ b); apply lt_O_Sn.
+rewrite H1; simpl in |- *; apply lt_O_Sn.
+inversion H.
+right; reflexivity.
+left; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | apply H1 ].
+Qed.
+
+Lemma Reste_E_maj :
+ forall (x y:R) (N:nat),
+   (0 < N)%nat -> Rabs (Reste_E x y N) <= maj_Reste_E x y N.
+intros; set (M := Rmax 1 (Rmax (Rabs x) (Rabs y))).
+apply Rle_trans with
+ (M ^ (2 * N) *
+  sum_f_R0
+    (fun k:nat =>
+       sum_f_R0 (fun l:nat => / Rsqr (INR (fact (div2 (S N)))))
+         (pred (N - k))) (pred N)). 
+unfold Reste_E in |- *.
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       Rabs
+         (sum_f_R0
+            (fun l:nat =>
+               / INR (fact (S (l + k))) * x ^ S (l + k) *
+               (/ INR (fact (N - l)) * y ^ (N - l))) (
+            pred (N - k)))) (pred N)).
+apply
+ (Rsum_abs
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            / INR (fact (S (l + k))) * x ^ S (l + k) *
+            (/ INR (fact (N - l)) * y ^ (N - l))) (
+         pred (N - k))) (pred N)).
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            Rabs
+              (/ INR (fact (S (l + k))) * x ^ S (l + k) *
+               (/ INR (fact (N - l)) * y ^ (N - l)))) (
+         pred (N - k))) (pred N)).
+apply sum_Rle; intros.
+apply
+ (Rsum_abs
+    (fun l:nat =>
+       / INR (fact (S (l + n))) * x ^ S (l + n) *
+       (/ INR (fact (N - l)) * y ^ (N - l)))).
+apply Rle_trans with
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun l:nat =>
+            M ^ (2 * N) * / INR (fact (S l)) * / INR (fact (N - l)))
+         (pred (N - k))) (pred N)).
+apply sum_Rle; intros.
+apply sum_Rle; intros.
+repeat rewrite Rabs_mult.
+do 2 rewrite <- RPow_abs.
+rewrite (Rabs_right (/ INR (fact (S (n0 + n))))).
+rewrite (Rabs_right (/ INR (fact (N - n0)))).
+replace
+ (/ INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
+  (/ INR (fact (N - n0)) * Rabs y ^ (N - n0))) with
+ (/ INR (fact (N - n0)) * / INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
+  Rabs y ^ (N - n0)); [ idtac | ring ].
+rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
+repeat rewrite Rmult_assoc.
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply Rle_trans with
+ (/ INR (fact (S n0)) * Rabs x ^ S (n0 + n) * Rabs y ^ (N - n0)).
+rewrite (Rmult_comm (/ INR (fact (S (n0 + n)))));
+ rewrite (Rmult_comm (/ INR (fact (S n0)))); repeat rewrite Rmult_assoc;
+ apply Rmult_le_compat_l.
+apply pow_le; apply Rabs_pos.
+rewrite (Rmult_comm (/ INR (fact (S n0)))); apply Rmult_le_compat_l.
+apply pow_le; apply Rabs_pos.
+apply Rle_Rinv.
+apply INR_fact_lt_0.
+apply INR_fact_lt_0.
+apply le_INR; apply fact_le; apply le_n_S.
+apply le_plus_l.
+rewrite (Rmult_comm (M ^ (2 * N))); rewrite Rmult_assoc;
+ apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply Rle_trans with (M ^ S (n0 + n) * Rabs y ^ (N - n0)).
+do 2 rewrite <- (Rmult_comm (Rabs y ^ (N - n0))).
+apply Rmult_le_compat_l.
+apply pow_le; apply Rabs_pos.
+apply pow_incr; split.
+apply Rabs_pos.
+apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
+apply RmaxLess1.
+unfold M in |- *; apply RmaxLess2.
+apply Rle_trans with (M ^ S (n0 + n) * M ^ (N - n0)).
+apply Rmult_le_compat_l.
+apply pow_le; apply Rle_trans with 1.
+left; apply Rlt_0_1.
+unfold M in |- *; apply RmaxLess1.
+apply pow_incr; split.
+apply Rabs_pos.
+apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
+apply RmaxLess2.
+unfold M in |- *; apply RmaxLess2.
+rewrite <- pow_add; replace (S (n0 + n) + (N - n0))%nat with (N + S n)%nat.
+apply Rle_pow.
+unfold M in |- *; apply RmaxLess1.
+replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ].
+apply plus_le_compat_l.
+replace N with (S (pred N)).
+apply le_n_S; apply H0.
+symmetry  in |- *; apply S_pred with 0%nat; apply H.
+apply INR_eq; do 2 rewrite plus_INR; do 2 rewrite S_INR; rewrite plus_INR;
+ rewrite minus_INR.
+ring.
+apply le_trans with (pred (N - n)).
+apply H1.
+apply le_S_n.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_trans with N.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+apply H0.
+apply le_pred_n.
+apply le_n_Sn.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+apply H0.
+apply lt_pred_n_n.
+apply H.
+apply le_trans with (pred N).
+apply H0.
+apply le_pred_n.
+apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+rewrite scal_sum.
+apply sum_Rle; intros.
+rewrite <- Rmult_comm.
+rewrite scal_sum.
+apply sum_Rle; intros.
+rewrite (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
+rewrite Rmult_assoc; apply Rmult_le_compat_l.
+apply pow_le.
+apply Rle_trans with 1.
+left; apply Rlt_0_1.
+unfold M in |- *; apply RmaxLess1.
+assert (H2 := even_odd_cor N).
+elim H2; intros N0 H3.
+elim H3; intro.
+apply Rle_trans with (/ INR (fact n0) * / INR (fact (N - n0))).
+do 2 rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply Rle_Rinv.
+apply INR_fact_lt_0.
+apply INR_fact_lt_0.
+apply le_INR.
+apply fact_le.
+apply le_n_Sn.
+replace (/ INR (fact n0) * / INR (fact (N - n0))) with
+ (C N n0 / INR (fact N)).
+pattern N at 1 in |- *; rewrite H4.
+apply Rle_trans with (C N N0 / INR (fact N)).
+unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact N))).
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+rewrite H4.
+apply C_maj.
+rewrite <- H4; apply le_trans with (pred (N - n)).
+apply H1.
+apply le_S_n.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_trans with N.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+apply H0.
+apply le_pred_n.
+apply le_n_Sn.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+apply H0.
+apply lt_pred_n_n.
+apply H.
+apply le_trans with (pred N).
+apply H0.
+apply le_pred_n.
+replace (C N N0 / INR (fact N)) with (/ Rsqr (INR (fact N0))).
+rewrite H4; rewrite div2_S_double; right; reflexivity.
+unfold Rsqr, C, Rdiv in |- *.
+repeat rewrite Rinv_mult_distr.
+rewrite (Rmult_comm (INR (fact N))).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; replace (N - N0)%nat with N0.
+ring.
+replace N with (N0 + N0)%nat.
+symmetry  in |- *; apply minus_plus.
+rewrite H4.
+apply INR_eq; rewrite plus_INR; rewrite mult_INR; do 2 rewrite S_INR; ring.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+unfold C, Rdiv in |- *.
+rewrite (Rmult_comm (INR (fact N))).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_r_sym.
+rewrite Rinv_mult_distr.
+rewrite Rmult_1_r; ring.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+replace (/ INR (fact (S n0)) * / INR (fact (N - n0))) with
+ (C (S N) (S n0) / INR (fact (S N))).
+apply Rle_trans with (C (S N) (S N0) / INR (fact (S N))).
+unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact (S N)))).
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+cut (S N = (2 * S N0)%nat).
+intro; rewrite H5; apply C_maj.
+rewrite <- H5; apply le_n_S.
+apply le_trans with (pred (N - n)).
+apply H1.
+apply le_S_n.
+replace (S (pred (N - n))) with (N - n)%nat.
+apply le_trans with N.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+apply H0.
+apply le_pred_n.
+apply le_n_Sn.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+apply H0.
+apply lt_pred_n_n.
+apply H.
+apply le_trans with (pred N).
+apply H0.
+apply le_pred_n.
+apply INR_eq; rewrite H4.
+do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR; ring.
+cut (S N = (2 * S N0)%nat).
+intro.
+replace (C (S N) (S N0) / INR (fact (S N))) with (/ Rsqr (INR (fact (S N0)))).
+rewrite H5; rewrite div2_double.
+right; reflexivity.
+unfold Rsqr, C, Rdiv in |- *.
+repeat rewrite Rinv_mult_distr.
+replace (S N - S N0)%nat with (S N0).
+rewrite (Rmult_comm (INR (fact (S N)))).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; reflexivity.
+apply INR_fact_neq_0.
+replace (S N) with (S N0 + S N0)%nat.
+symmetry  in |- *; apply minus_plus.
+rewrite H5; ring.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_eq; rewrite H4; do 2 rewrite S_INR; do 2 rewrite mult_INR;
+ repeat rewrite S_INR; ring.
+unfold C, Rdiv in |- *.
+rewrite (Rmult_comm (INR (fact (S N)))).
+rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; rewrite Rinv_mult_distr.
+reflexivity.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+unfold maj_Reste_E in |- *.
+unfold Rdiv in |- *; rewrite (Rmult_comm 4).
+rewrite Rmult_assoc.
+apply Rmult_le_compat_l.
+apply pow_le.
+apply Rle_trans with 1.
+left; apply Rlt_0_1.
+apply RmaxLess1.
+apply Rle_trans with
+ (sum_f_R0 (fun k:nat => INR (N - k) * / Rsqr (INR (fact (div2 (S N)))))
+    (pred N)).
+apply sum_Rle; intros.
+rewrite sum_cte.
+replace (S (pred (N - n))) with (N - n)%nat.
+right; apply Rmult_comm.
+apply S_pred with 0%nat.
+apply plus_lt_reg_l with n.
+rewrite <- le_plus_minus.
+replace (n + 0)%nat with n; [ idtac | ring ].
+apply le_lt_trans with (pred N).
+apply H0.
+apply lt_pred_n_n.
+apply H.
+apply le_trans with (pred N).
+apply H0.
+apply le_pred_n.
+apply Rle_trans with
+ (sum_f_R0 (fun k:nat => INR N * / Rsqr (INR (fact (div2 (S N))))) (pred N)).
+apply sum_Rle; intros.
+do 2 rewrite <- (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt.
+apply INR_fact_neq_0.
+apply le_INR.
+apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+rewrite <- le_plus_minus.
+apply le_plus_r.
+apply le_trans with (pred N).
+apply H0.
+apply le_pred_n.
+rewrite sum_cte; replace (S (pred N)) with N.
+cut (div2 (S N) = S (div2 (pred N))).
+intro; rewrite H0.
+rewrite fact_simpl; rewrite mult_comm; rewrite mult_INR; rewrite Rsqr_mult.
+rewrite Rinv_mult_distr.
+rewrite (Rmult_comm (INR N)); repeat rewrite Rmult_assoc;
+ apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0.
+rewrite <- H0.
+cut (INR N <= INR (2 * div2 (S N))).
+intro; apply Rmult_le_reg_l with (Rsqr (INR (div2 (S N)))).
+apply Rsqr_pos_lt.
+apply not_O_INR; red in |- *; intro.
+cut (1 < S N)%nat.
+intro; assert (H4 := div2_not_R0 _ H3).
+rewrite H2 in H4; elim (lt_n_O _ H4).
+apply lt_n_S; apply H.
+repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l.
+replace (INR N * INR N) with (Rsqr (INR N)); [ idtac | reflexivity ].
+rewrite Rmult_assoc.
+rewrite Rmult_comm.
+replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ].
+rewrite <- Rsqr_mult.
+apply Rsqr_incr_1.
+replace 2 with (INR 2).
+rewrite <- mult_INR; apply H1.
+reflexivity.
+left; apply lt_INR_0; apply H.
+left; apply Rmult_lt_0_compat.
+prove_sup0.
+apply lt_INR_0; apply div2_not_R0.
+apply lt_n_S; apply H.
+cut (1 < S N)%nat.
+intro; unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; intro;
+ assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4; 
+ elim (lt_n_O _ H4).
+apply lt_n_S; apply H.
+assert (H1 := even_odd_cor N).
+elim H1; intros N0 H2.
+elim H2; intro.
+pattern N at 2 in |- *; rewrite H3.
+rewrite div2_S_double.
+right; rewrite H3; reflexivity.
+pattern N at 2 in |- *; rewrite H3.
+replace (S (S (2 * N0))) with (2 * S N0)%nat.
+rewrite div2_double.
+rewrite H3.
+rewrite S_INR; do 2 rewrite mult_INR.
+rewrite (S_INR N0).
+rewrite Rmult_plus_distr_l.
+apply Rplus_le_compat_l.
+rewrite Rmult_1_r.
+simpl in |- *.
+pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+ apply Rlt_0_1.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+unfold Rsqr in |- *; apply prod_neq_R0; apply INR_fact_neq_0.
+unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; discriminate.
+assert (H0 := even_odd_cor N).
+elim H0; intros N0 H1.
+elim H1; intro.
+cut (0 < N0)%nat.
+intro; rewrite H2.
+rewrite div2_S_double.
+replace (2 * N0)%nat with (S (S (2 * pred N0))).
+replace (pred (S (S (2 * pred N0)))) with (S (2 * pred N0)).
+rewrite div2_S_double.
+apply S_pred with 0%nat; apply H3.
+reflexivity.
+replace N0 with (S (pred N0)).
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+symmetry  in |- *; apply S_pred with 0%nat; apply H3.
+rewrite H2 in H.
+apply neq_O_lt.
+red in |- *; intro.
+rewrite <- H3 in H.
+simpl in H.
+elim (lt_n_O _ H).
+rewrite H2.
+replace (pred (S (2 * N0))) with (2 * N0)%nat; [ idtac | reflexivity ].
+replace (S (S (2 * N0))) with (2 * S N0)%nat.
+do 2 rewrite div2_double.
+reflexivity.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+apply S_pred with 0%nat; apply H.
+Qed.
+
+Lemma maj_Reste_cv_R0 : forall x y:R, Un_cv (maj_Reste_E x y) 0.
+intros; assert (H := Majxy_cv_R0 x y).
+unfold Un_cv in H; unfold Un_cv in |- *; intros.
+cut (0 < eps / 4);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+elim (H _ H1); intros N0 H2.
+exists (max (2 * S N0) 2); intros.
+unfold R_dist in H2; unfold R_dist in |- *; rewrite Rminus_0_r;
+ unfold Majxy in H2; unfold maj_Reste_E in |- *.
+rewrite Rabs_right.
+apply Rle_lt_trans with
+ (4 *
+  (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
+   INR (fact (div2 (pred n))))).
+apply Rmult_le_compat_l.
+left; prove_sup0.
+unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+rewrite (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)));
+ rewrite
+  (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n)))))
+  ; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply Rle_trans with (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)).
+rewrite Rmult_comm;
+ pattern (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)) at 2 in |- *;
+ rewrite <- Rmult_1_r; apply Rmult_le_compat_l.
+apply pow_le; apply Rle_trans with 1.
+left; apply Rlt_0_1.
+apply RmaxLess1.
+apply Rmult_le_reg_l with (INR (fact (div2 (pred n)))).
+apply INR_fact_lt_0.
+rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
+replace 1 with (INR 1); [ apply le_INR | reflexivity ].
+apply lt_le_S.
+apply INR_lt.
+apply INR_fact_lt_0.
+apply INR_fact_neq_0.
+apply Rle_pow.
+apply RmaxLess1.
+assert (H4 := even_odd_cor n).
+elim H4; intros N1 H5.
+elim H5; intro.
+cut (0 < N1)%nat.
+intro.
+rewrite H6.
+replace (pred (2 * N1)) with (S (2 * pred N1)).
+rewrite div2_S_double.
+replace (S (pred N1)) with N1.
+apply INR_le.
+right.
+do 3 rewrite mult_INR; repeat rewrite S_INR; ring.
+apply S_pred with 0%nat; apply H7.
+replace (2 * N1)%nat with (S (S (2 * pred N1))).
+reflexivity.
+pattern N1 at 2 in |- *; replace N1 with (S (pred N1)).
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+symmetry  in |- *; apply S_pred with 0%nat; apply H7.
+apply INR_lt.
+apply Rmult_lt_reg_l with (INR 2).
+simpl in |- *; prove_sup0.
+rewrite Rmult_0_r; rewrite <- mult_INR.
+apply lt_INR_0.
+rewrite <- H6.
+apply lt_le_trans with 2%nat.
+apply lt_O_Sn.
+apply le_trans with (max (2 * S N0) 2).
+apply le_max_r.
+apply H3.
+rewrite H6.
+replace (pred (S (2 * N1))) with (2 * N1)%nat.
+rewrite div2_double.
+replace (4 * S N1)%nat with (2 * (2 * S N1))%nat.
+apply (fun m n p:nat => mult_le_compat_l p n m).
+replace (2 * S N1)%nat with (S (S (2 * N1))).
+apply le_n_Sn.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+ring.
+reflexivity.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply Rmult_lt_reg_l with (/ 4).
+apply Rinv_0_lt_compat; prove_sup0.
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; rewrite Rmult_comm.
+replace
+ (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
+  INR (fact (div2 (pred n)))) with
+ (Rabs
+    (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
+     INR (fact (div2 (pred n))) - 0)).
+apply H2; unfold ge in |- *.
+cut (2 * S N0 <= n)%nat.
+intro; apply le_S_n.
+apply INR_le; apply Rmult_le_reg_l with (INR 2).
+simpl in |- *; prove_sup0.
+do 2 rewrite <- mult_INR; apply le_INR.
+apply le_trans with n.
+apply H4.
+assert (H5 := even_odd_cor n).
+elim H5; intros N1 H6.
+elim H6; intro.
+cut (0 < N1)%nat.
+intro.
+rewrite H7.
+apply (fun m n p:nat => mult_le_compat_l p n m).
+replace (pred (2 * N1)) with (S (2 * pred N1)).
+rewrite div2_S_double.
+replace (S (pred N1)) with N1.
+apply le_n.
+apply S_pred with 0%nat; apply H8.
+replace (2 * N1)%nat with (S (S (2 * pred N1))).
+reflexivity.
+pattern N1 at 2 in |- *; replace N1 with (S (pred N1)).
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+symmetry  in |- *; apply S_pred with 0%nat; apply H8.
+apply INR_lt.
+apply Rmult_lt_reg_l with (INR 2).
+simpl in |- *; prove_sup0.
+rewrite Rmult_0_r; rewrite <- mult_INR.
+apply lt_INR_0.
+rewrite <- H7.
+apply lt_le_trans with 2%nat.
+apply lt_O_Sn.
+apply le_trans with (max (2 * S N0) 2).
+apply le_max_r.
+apply H3.
+rewrite H7.
+replace (pred (S (2 * N1))) with (2 * N1)%nat.
+rewrite div2_double.
+replace (2 * S N1)%nat with (S (S (2 * N1))).
+apply le_n_Sn.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+reflexivity.
+apply le_trans with (max (2 * S N0) 2).
+apply le_max_l.
+apply H3.
+rewrite Rminus_0_r; apply Rabs_right.
+apply Rle_ge.
+unfold Rdiv in |- *; repeat apply Rmult_le_pos.
+apply pow_le.
+apply Rle_trans with 1.
+left; apply Rlt_0_1.
+apply RmaxLess1.
+left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+discrR.
+apply Rle_ge.
+unfold Rdiv in |- *; apply Rmult_le_pos.
+left; prove_sup0.
+apply Rmult_le_pos.
+apply pow_le.
+apply Rle_trans with 1.
+left; apply Rlt_0_1.
+apply RmaxLess1.
+left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0.
+Qed.
+
+(**********)
+Lemma Reste_E_cv : forall x y:R, Un_cv (Reste_E x y) 0.
+intros; assert (H := maj_Reste_cv_R0 x y).
+unfold Un_cv in H; unfold Un_cv in |- *; intros; elim (H _ H0); intros.
+exists (max x0 1); intros.
+unfold R_dist in |- *; rewrite Rminus_0_r.
+apply Rle_lt_trans with (maj_Reste_E x y n).
+apply Reste_E_maj.
+apply lt_le_trans with 1%nat.
+apply lt_O_Sn.
+apply le_trans with (max x0 1).
+apply le_max_r.
+apply H2.
+replace (maj_Reste_E x y n) with (R_dist (maj_Reste_E x y n) 0).
+apply H1.
+unfold ge in |- *; apply le_trans with (max x0 1).
+apply le_max_l.
+apply H2.
+unfold R_dist in |- *; rewrite Rminus_0_r; apply Rabs_right.
+apply Rle_ge; apply Rle_trans with (Rabs (Reste_E x y n)).
+apply Rabs_pos.
+apply Reste_E_maj.
+apply lt_le_trans with 1%nat.
+apply lt_O_Sn.
+apply le_trans with (max x0 1).
+apply le_max_r.
+apply H2.
+Qed.
+
+(**********)
+Lemma exp_plus : forall x y:R, exp (x + y) = exp x * exp y.
+intros; assert (H0 := E1_cvg x).
+assert (H := E1_cvg y).
+assert (H1 := E1_cvg (x + y)).
+eapply UL_sequence.
+apply H1.
+assert (H2 := CV_mult _ _ _ _ H0 H).
+assert (H3 := CV_minus _ _ _ _ H2 (Reste_E_cv x y)).
+unfold Un_cv in |- *; unfold Un_cv in H3; intros.
+elim (H3 _ H4); intros.
+exists (S x0); intros.
+rewrite <- (exp_form x y n).
+rewrite Rminus_0_r in H5.
+apply H5.
+unfold ge in |- *; apply le_trans with (S x0).
+apply le_n_Sn.
+apply H6.
+apply lt_le_trans with (S x0).
+apply lt_O_Sn.
+apply H6.
+Qed.
+
+(**********)
+Lemma exp_pos_pos : forall x:R, 0 < x -> 0 < exp x.
+intros; set (An := fun N:nat => / INR (fact N) * x ^ N).
+cut (Un_cv (fun n:nat => sum_f_R0 An n) (exp x)).
+intro; apply Rlt_le_trans with (sum_f_R0 An 0).
+unfold An in |- *; simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r;
+ apply Rlt_0_1.
+apply sum_incr.
+assumption.
+intro; unfold An in |- *; left; apply Rmult_lt_0_compat.
+apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply (pow_lt _ n H).
+unfold exp in |- *; unfold projT1 in |- *; case (exist_exp x); intro.
+unfold exp_in in |- *; unfold infinit_sum, Un_cv in |- *; trivial.
+Qed.
+
+(**********)
+Lemma exp_pos : forall x:R, 0 < exp x.
+intro; case (total_order_T 0 x); intro.
+elim s; intro.
+apply (exp_pos_pos _ a).
+rewrite <- b; rewrite exp_0; apply Rlt_0_1.
+replace (exp x) with (1 / exp (- x)).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply Rlt_0_1.
+apply Rinv_0_lt_compat; apply exp_pos_pos.
+apply (Ropp_0_gt_lt_contravar _ r).
+cut (exp (- x) <> 0).
+intro; unfold Rdiv in |- *; apply Rmult_eq_reg_l with (exp (- x)).
+rewrite Rmult_1_l; rewrite <- Rinv_r_sym.
+rewrite <- exp_plus.
+rewrite Rplus_opp_l; rewrite exp_0; reflexivity.
+apply H.
+apply H.
+assert (H := exp_plus x (- x)).
+rewrite Rplus_opp_r in H; rewrite exp_0 in H.
+red in |- *; intro; rewrite H0 in H.
+rewrite Rmult_0_r in H.
+elim R1_neq_R0; assumption.
+Qed.
+
+(* ((exp h)-1)/h -> 0 quand h->0 *)
+Lemma derivable_pt_lim_exp_0 : derivable_pt_lim exp 0 1.
+unfold derivable_pt_lim in |- *; intros.
+set (fn := fun (N:nat) (x:R) => x ^ N / INR (fact (S N))).
+cut (CVN_R fn).
+intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)).
+intro cv; cut (forall n:nat, continuity (fn n)).
+intro; cut (continuity (SFL fn cv)).
+intro; unfold continuity in H1.
+assert (H2 := H1 0).
+unfold continuity_pt in H2; unfold continue_in in H2; unfold limit1_in in H2;
+ unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
+elim (H2 _ H); intros alp H3.
+elim H3; intros.
+exists (mkposreal _ H4); intros.
+rewrite Rplus_0_l; rewrite exp_0.
+replace ((exp h - 1) / h) with (SFL fn cv h).
+replace 1 with (SFL fn cv 0).
+apply H5.
+split.
+unfold D_x, no_cond in |- *; split.
+trivial.
+apply (sym_not_eq H6).
+rewrite Rminus_0_r; apply H7.
+unfold SFL in |- *.
+case (cv 0); intros.
+eapply UL_sequence.
+apply u.
+unfold Un_cv, SP in |- *.
+intros; exists 1%nat; intros.
+unfold R_dist in |- *; rewrite decomp_sum.
+rewrite (Rplus_comm (fn 0%nat 0)).
+replace (fn 0%nat 0) with 1.
+unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_r;
+ rewrite Rplus_0_r.
+replace (sum_f_R0 (fun i:nat => fn (S i) 0) (pred n)) with 0.
+rewrite Rabs_R0; apply H8.
+symmetry  in |- *; apply sum_eq_R0; intros.
+unfold fn in |- *.
+simpl in |- *.
+unfold Rdiv in |- *; do 2 rewrite Rmult_0_l; reflexivity.
+unfold fn in |- *; simpl in |- *.
+unfold Rdiv in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
+apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H9 ].
+unfold SFL, exp in |- *.
+unfold projT1 in |- *.
+case (cv h); case (exist_exp h); intros.
+eapply UL_sequence.
+apply u.
+unfold Un_cv in |- *; intros.
+unfold exp_in in e.
+unfold infinit_sum in e.
+cut (0 < eps0 * Rabs h).
+intro; elim (e _ H9); intros N0 H10.
+exists N0; intros.
+unfold R_dist in |- *.
+apply Rmult_lt_reg_l with (Rabs h).
+apply Rabs_pos_lt; assumption.
+rewrite <- Rabs_mult.
+rewrite Rmult_minus_distr_l.
+replace (h * ((x - 1) / h)) with (x - 1).
+unfold R_dist in H10.
+replace (h * SP fn n h - (x - 1)) with
+ (sum_f_R0 (fun i:nat => / INR (fact i) * h ^ i) (S n) - x).
+rewrite (Rmult_comm (Rabs h)).
+apply H10.
+unfold ge in |- *.
+apply le_trans with (S N0).
+apply le_n_Sn.
+apply le_n_S; apply H11.
+rewrite decomp_sum.
+replace (/ INR (fact 0) * h ^ 0) with 1.
+unfold Rminus in |- *.
+rewrite Ropp_plus_distr.
+rewrite Ropp_involutive.
+rewrite <- (Rplus_comm (- x)).
+rewrite <- (Rplus_comm (- x + 1)).
+rewrite Rplus_assoc; repeat apply Rplus_eq_compat_l.
+replace (pred (S n)) with n; [ idtac | reflexivity ].
+unfold SP in |- *.
+rewrite scal_sum.
+apply sum_eq; intros.
+unfold fn in |- *.
+replace (h ^ S i) with (h * h ^ i).
+unfold Rdiv in |- *; ring.
+simpl in |- *; ring.
+simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
+apply lt_O_Sn.
+unfold Rdiv in |- *.
+rewrite <- Rmult_assoc.
+symmetry  in |- *; apply Rinv_r_simpl_m.
+assumption.
+apply Rmult_lt_0_compat.
+apply H8.
+apply Rabs_pos_lt; assumption.
+apply SFL_continuity; assumption.
+intro; unfold fn in |- *.
+replace (fun x:R => x ^ n / INR (fact (S n))) with
+ (pow_fct n / fct_cte (INR (fact (S n))))%F; [ idtac | reflexivity ].
+apply continuity_div.
+apply derivable_continuous; apply (derivable_pow n).
+apply derivable_continuous; apply derivable_const.
+intro; unfold fct_cte in |- *; apply INR_fact_neq_0.
+apply (CVN_R_CVS _ X).
+assert (H0 := Alembert_exp).
+unfold CVN_R in |- *.
+intro; unfold CVN_r in |- *.
+apply existT with (fun N:nat => r ^ N / INR (fact (S N))).
+cut
+ (sigT
+    (fun l:R =>
+       Un_cv
+         (fun n:nat =>
+            sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l)).
+intro.
+elim X; intros.
+exists x; intros.
+split.
+apply p.
+unfold Boule in |- *; intros.
+rewrite Rminus_0_r in H1.
+unfold fn in |- *.
+unfold Rdiv in |- *; rewrite Rabs_mult.
+cut (0 < INR (fact (S n))).
+intro.
+rewrite (Rabs_right (/ INR (fact (S n)))).
+do 2 rewrite <- (Rmult_comm (/ INR (fact (S n)))).
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply H2.
+rewrite <- RPow_abs.
+apply pow_maj_Rabs.
+rewrite Rabs_Rabsolu; left; apply H1.
+apply Rle_ge; left; apply Rinv_0_lt_compat; apply H2.
+apply INR_fact_lt_0.
+cut ((r:R) <> 0).
+intro; apply Alembert_C2.
+intro; apply Rabs_no_R0.
+unfold Rdiv in |- *; apply prod_neq_R0.
+apply pow_nonzero; assumption.
+apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+unfold Un_cv in H0.
+unfold Un_cv in |- *; intros.
+cut (0 < eps0 / r);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; apply (cond_pos r) ] ].
+elim (H0 _ H3); intros N0 H4.
+exists N0; intros.
+cut (S n >= N0)%nat.
+intro hyp_sn.
+assert (H6 := H4 _ hyp_sn).
+unfold R_dist in H6; rewrite Rminus_0_r in H6.
+rewrite Rabs_Rabsolu in H6.
+unfold R_dist in |- *; rewrite Rminus_0_r.
+rewrite Rabs_Rabsolu.
+replace
+ (Rabs (r ^ S n / INR (fact (S (S n)))) / Rabs (r ^ n / INR (fact (S n))))
+ with (r * / INR (fact (S (S n))) * / / INR (fact (S n))).
+rewrite Rmult_assoc; rewrite Rabs_mult.
+rewrite (Rabs_right r).
+apply Rmult_lt_reg_l with (/ r).
+apply Rinv_0_lt_compat; apply (cond_pos r).
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; rewrite <- (Rmult_comm eps0).
+apply H6.
+assumption.
+apply Rle_ge; left; apply (cond_pos r).
+unfold Rdiv in |- *.
+repeat rewrite Rabs_mult.
+repeat rewrite Rabs_Rinv.
+rewrite Rinv_mult_distr.
+repeat rewrite Rabs_right.
+rewrite Rinv_involutive.
+rewrite (Rmult_comm r).
+rewrite (Rmult_comm (r ^ S n)).
+repeat rewrite Rmult_assoc.
+apply Rmult_eq_compat_l.
+rewrite (Rmult_comm r).
+rewrite <- Rmult_assoc; rewrite <- (Rmult_comm (INR (fact (S n)))).
+apply Rmult_eq_compat_l.
+simpl in |- *.
+rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+ring.
+apply pow_nonzero; assumption.
+apply INR_fact_neq_0.
+apply Rle_ge; left; apply INR_fact_lt_0.
+apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
+apply Rle_ge; left; apply INR_fact_lt_0.
+apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
+apply Rabs_no_R0; apply pow_nonzero; assumption.
+apply Rinv_neq_0_compat; apply Rabs_no_R0; apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+unfold ge in |- *; apply le_trans with n.
+apply H5.
+apply le_n_Sn.
+assert (H1 := cond_pos r); red in |- *; intro; rewrite H2 in H1;
+ elim (Rlt_irrefl _ H1).
+Qed.
+
+(**********)
+Lemma derivable_pt_lim_exp : forall x:R, derivable_pt_lim exp x (exp x).
+intro; assert (H0 := derivable_pt_lim_exp_0).
+unfold derivable_pt_lim in H0; unfold derivable_pt_lim in |- *; intros.
+cut (0 < eps / exp x);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply H | apply Rinv_0_lt_compat; apply exp_pos ] ].
+elim (H0 _ H1); intros del H2.
+exists del; intros.
+assert (H5 := H2 _ H3 H4).
+rewrite Rplus_0_l in H5; rewrite exp_0 in H5.
+replace ((exp (x + h) - exp x) / h - exp x) with
+ (exp x * ((exp h - 1) / h - 1)).
+rewrite Rabs_mult; rewrite (Rabs_right (exp x)).
+apply Rmult_lt_reg_l with (/ exp x).
+apply Rinv_0_lt_compat; apply exp_pos.
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; rewrite <- (Rmult_comm eps).
+apply H5.
+assert (H6 := exp_pos x); red in |- *; intro; rewrite H7 in H6;
+ elim (Rlt_irrefl _ H6).
+apply Rle_ge; left; apply exp_pos.
+rewrite Rmult_minus_distr_l.
+rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
+ rewrite Rmult_minus_distr_l.
+rewrite Rmult_1_r; rewrite exp_plus; reflexivity.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v
new file mode 100644
index 00000000..c3c3d9bb
--- /dev/null
+++ b/theories/Reals/Integration.v
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Integration.v,v 1.1.6.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Export NewtonInt.
+Require Export RiemannInt_SF.
+Require Export RiemannInt.
\ No newline at end of file
diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v
new file mode 100644
index 00000000..baa61304
--- /dev/null
+++ b/theories/Reals/MVT.v
@@ -0,0 +1,699 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: MVT.v,v 1.10.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Ranalysis1.
+Require Import Rtopology. Open Local Scope R_scope.
+
+(* The Mean Value Theorem *)
+Theorem MVT :
+ forall (f g:R -> R) (a b:R) (pr1:forall c:R, a < c < b -> derivable_pt f c)
+   (pr2:forall c:R, a < c < b -> derivable_pt g c),
+   a < b ->
+   (forall c:R, a <= c <= b -> continuity_pt f c) ->
+   (forall c:R, a <= c <= b -> continuity_pt g c) ->
+    exists c : R,
+     (exists P : a < c < b,
+        (g b - g a) * derive_pt f c (pr1 c P) =
+        (f b - f a) * derive_pt g c (pr2 c P)).
+intros; assert (H2 := Rlt_le _ _ H).
+set (h := fun y:R => (g b - g a) * f y - (f b - f a) * g y).
+cut (forall c:R, a < c < b -> derivable_pt h c).
+intro; cut (forall c:R, a <= c <= b -> continuity_pt h c).
+intro; assert (H4 := continuity_ab_maj h a b H2 H3).
+assert (H5 := continuity_ab_min h a b H2 H3).
+elim H4; intros Mx H6.
+elim H5; intros mx H7.
+cut (h a = h b).
+intro; set (M := h Mx); set (m := h mx).
+cut
+ (forall (c:R) (P:a < c < b),
+    derive_pt h c (X c P) =
+    (g b - g a) * derive_pt f c (pr1 c P) -
+    (f b - f a) * derive_pt g c (pr2 c P)).
+intro; case (Req_dec (h a) M); intro.
+case (Req_dec (h a) m); intro.
+cut (forall c:R, a <= c <= b -> h c = M).
+intro; cut (a < (a + b) / 2 < b).
+(*** h constant ***)
+intro; exists ((a + b) / 2).
+exists H13.
+apply Rminus_diag_uniq; rewrite <- H9; apply deriv_constant2 with a b.
+elim H13; intros; assumption.
+elim H13; intros; assumption.
+intros; rewrite (H12 ((a + b) / 2)).
+apply H12; split; left; assumption.
+elim H13; intros; split; left; assumption.
+split.
+apply Rmult_lt_reg_l with 2.
+prove_sup0.
+unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H.
+discrR.
+apply Rmult_lt_reg_l with 2.
+prove_sup0.
+unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; rewrite Rplus_comm; rewrite double;
+ apply Rplus_lt_compat_l; apply H.
+discrR.
+intros; elim H6; intros H13 _.
+elim H7; intros H14 _.
+apply Rle_antisym.
+apply H13; apply H12.
+rewrite H10 in H11; rewrite H11; apply H14; apply H12.
+cut (a < mx < b).
+(*** h admet un minimum global sur [a,b] ***)
+intro; exists mx.
+exists H12.
+apply Rminus_diag_uniq; rewrite <- H9; apply deriv_minimum with a b.
+elim H12; intros; assumption.
+elim H12; intros; assumption.
+intros; elim H7; intros.
+apply H15; split; left; assumption.
+elim H7; intros _ H12; elim H12; intros; split.
+inversion H13.
+apply H15.
+rewrite H15 in H11; elim H11; reflexivity.
+inversion H14.
+apply H15.
+rewrite H8 in H11; rewrite <- H15 in H11; elim H11; reflexivity.
+cut (a < Mx < b).
+(*** h admet un maximum global sur [a,b] ***)
+intro; exists Mx.
+exists H11.
+apply Rminus_diag_uniq; rewrite <- H9; apply deriv_maximum with a b.
+elim H11; intros; assumption.
+elim H11; intros; assumption.
+intros; elim H6; intros; apply H14.
+split; left; assumption.
+elim H6; intros _ H11; elim H11; intros; split.
+inversion H12.
+apply H14.
+rewrite H14 in H10; elim H10; reflexivity.
+inversion H13.
+apply H14.
+rewrite H8 in H10; rewrite <- H14 in H10; elim H10; reflexivity.
+intros; unfold h in |- *;
+ replace
+  (derive_pt (fun y:R => (g b - g a) * f y - (f b - f a) * g y) c (X c P))
+  with
+  (derive_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F) c
+     (derivable_pt_minus _ _ _
+        (derivable_pt_mult _ _ _ (derivable_pt_const (g b - g a) c) (pr1 c P))
+        (derivable_pt_mult _ _ _ (derivable_pt_const (f b - f a) c) (pr2 c P))));
+ [ idtac | apply pr_nu ].
+rewrite derive_pt_minus; do 2 rewrite derive_pt_mult;
+ do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l; 
+ do 2 rewrite Rplus_0_l; reflexivity.
+unfold h in |- *; ring.
+intros; unfold h in |- *;
+ change
+   (continuity_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
+      c) in |- *.
+apply continuity_pt_minus; apply continuity_pt_mult.
+apply derivable_continuous_pt; apply derivable_const.
+apply H0; apply H3.
+apply derivable_continuous_pt; apply derivable_const.
+apply H1; apply H3.
+intros;
+ change
+   (derivable_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
+      c) in |- *.
+apply derivable_pt_minus; apply derivable_pt_mult.
+apply derivable_pt_const.
+apply (pr1 _ H3).
+apply derivable_pt_const.
+apply (pr2 _ H3).
+Qed.
+
+(* Corollaries ... *)
+Lemma MVT_cor1 :
+ forall (f:R -> R) (a b:R) (pr:derivable f),
+   a < b ->
+    exists c : R, f b - f a = derive_pt f c (pr c) * (b - a) /\ a < c < b.
+intros f a b pr H; cut (forall c:R, a < c < b -> derivable_pt f c);
+ [ intro | intros; apply pr ].
+cut (forall c:R, a < c < b -> derivable_pt id c);
+ [ intro | intros; apply derivable_pt_id ].
+cut (forall c:R, a <= c <= b -> continuity_pt f c);
+ [ intro | intros; apply derivable_continuous_pt; apply pr ].
+cut (forall c:R, a <= c <= b -> continuity_pt id c);
+ [ intro | intros; apply derivable_continuous_pt; apply derivable_id ].
+assert (H2 := MVT f id a b X X0 H H0 H1).
+elim H2; intros c H3; elim H3; intros.
+exists c; split.
+cut (derive_pt id c (X0 c x) = derive_pt id c (derivable_pt_id c));
+ [ intro | apply pr_nu ].
+rewrite H5 in H4; rewrite (derive_pt_id c) in H4; rewrite Rmult_1_r in H4;
+ rewrite <- H4; replace (derive_pt f c (X c x)) with (derive_pt f c (pr c));
+ [ idtac | apply pr_nu ]; apply Rmult_comm.
+apply x.
+Qed.
+
+Theorem MVT_cor2 :
+ forall (f f':R -> R) (a b:R),
+   a < b ->
+   (forall c:R, a <= c <= b -> derivable_pt_lim f c (f' c)) ->
+    exists c : R, f b - f a = f' c * (b - a) /\ a < c < b.
+intros f f' a b H H0; cut (forall c:R, a <= c <= b -> derivable_pt f c).
+intro; cut (forall c:R, a < c < b -> derivable_pt f c).
+intro; cut (forall c:R, a <= c <= b -> continuity_pt f c).
+intro; cut (forall c:R, a <= c <= b -> derivable_pt id c).
+intro; cut (forall c:R, a < c < b -> derivable_pt id c).
+intro; cut (forall c:R, a <= c <= b -> continuity_pt id c).
+intro; elim (MVT f id a b X0 X2 H H1 H2); intros; elim H3; clear H3; intros;
+ exists x; split.
+cut (derive_pt id x (X2 x x0) = 1).
+cut (derive_pt f x (X0 x x0) = f' x).
+intros; rewrite H4 in H3; rewrite H5 in H3; unfold id in H3;
+ rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry  in |- *; 
+ assumption.
+apply derive_pt_eq_0; apply H0; elim x0; intros; split; left; assumption.
+apply derive_pt_eq_0; apply derivable_pt_lim_id.
+assumption.
+intros; apply derivable_continuous_pt; apply X1; assumption.
+intros; apply derivable_pt_id.
+intros; apply derivable_pt_id.
+intros; apply derivable_continuous_pt; apply X; assumption.
+intros; elim H1; intros; apply X; split; left; assumption.
+intros; unfold derivable_pt in |- *; apply existT with (f' c); apply H0;
+ apply H1.
+Qed.
+
+Lemma MVT_cor3 :
+ forall (f f':R -> R) (a b:R),
+   a < b ->
+   (forall x:R, a <= x -> x <= b -> derivable_pt_lim f x (f' x)) ->
+    exists c : R, a <= c /\ c <= b /\ f b = f a + f' c * (b - a).
+intros f f' a b H H0;
+ assert (H1 :  exists c : R, f b - f a = f' c * (b - a) /\ a < c < b);
+ [ apply MVT_cor2; [ apply H | intros; elim H1; intros; apply (H0 _ H2 H3) ]
+ | elim H1; intros; exists x; elim H2; intros; elim H4; intros; split;
+    [ left; assumption | split; [ left; assumption | rewrite <- H3; ring ] ] ].
+Qed.
+
+Lemma Rolle :
+ forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x),
+   (forall x:R, a <= x <= b -> continuity_pt f x) ->
+   a < b ->
+   f a = f b ->
+    exists c : R, (exists P : a < c < b, derive_pt f c (pr c P) = 0).
+intros; assert (H2 : forall x:R, a < x < b -> derivable_pt id x).
+intros; apply derivable_pt_id.
+assert (H3 := MVT f id a b pr H2 H0 H);
+ assert (H4 : forall x:R, a <= x <= b -> continuity_pt id x).
+intros; apply derivable_continuous; apply derivable_id.
+elim (H3 H4); intros; elim H5; intros; exists x; exists x0; rewrite H1 in H6;
+ unfold id in H6; unfold Rminus in H6; rewrite Rplus_opp_r in H6;
+ rewrite Rmult_0_l in H6; apply Rmult_eq_reg_l with (b - a);
+ [ rewrite Rmult_0_r; apply H6
+ | apply Rminus_eq_contra; red in |- *; intro; rewrite H7 in H0;
+    elim (Rlt_irrefl _ H0) ].
+Qed.
+
+(**********)
+Lemma nonneg_derivative_1 :
+ forall (f:R -> R) (pr:derivable f),
+   (forall x:R, 0 <= derive_pt f x (pr x)) -> increasing f.
+intros.
+unfold increasing in |- *.
+intros.
+case (total_order_T x y); intro.
+elim s; intro.
+apply Rplus_le_reg_l with (- f x).
+rewrite Rplus_opp_l; rewrite Rplus_comm.
+assert (H1 := MVT_cor1 f _ _ pr a).
+elim H1; intros.
+elim H2; intros.
+unfold Rminus in H3.
+rewrite H3.
+apply Rmult_le_pos.
+apply H.
+apply Rplus_le_reg_l with x.
+rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
+rewrite b; right; reflexivity.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r)).
+Qed.
+ 
+(**********)
+Lemma nonpos_derivative_0 :
+ forall (f:R -> R) (pr:derivable f),
+   decreasing f -> forall x:R, derive_pt f x (pr x) <= 0.
+intros f pr H x; assert (H0 := H); unfold decreasing in H0;
+ generalize (derivable_derive f x (pr x)); intro; elim H1; 
+ intros l H2.
+rewrite H2; case (Rtotal_order l 0); intro.
+left; assumption.
+elim H3; intro.
+right; assumption.
+generalize (derive_pt_eq_1 f x l (pr x) H2); intros; cut (0 < l / 2).
+intro; elim (H5 (l / 2) H6); intros delta H7;
+ cut (delta / 2 <> 0 /\ 0 < delta / 2 /\ Rabs (delta / 2) < delta).
+intro; decompose [and] H8; intros; generalize (H7 (delta / 2) H9 H12);
+ cut ((f (x + delta / 2) - f x) / (delta / 2) <= 0).
+intro; cut (0 < - ((f (x + delta / 2) - f x) / (delta / 2) - l)).
+intro; unfold Rabs in |- *;
+ case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)).
+intros;
+ generalize
+  (Rplus_lt_compat_r (- l) (- ((f (x + delta / 2) - f x) / (delta / 2) - l))
+     (l / 2) H14); unfold Rminus in |- *.
+replace (l / 2 + - l) with (- (l / 2)).
+replace (- ((f (x + delta / 2) + - f x) / (delta / 2) + - l) + - l) with
+ (- ((f (x + delta / 2) + - f x) / (delta / 2))).
+intro.
+generalize
+ (Ropp_lt_gt_contravar (- ((f (x + delta / 2) + - f x) / (delta / 2)))
+    (- (l / 2)) H15). 
+repeat rewrite Ropp_involutive.
+intro.
+generalize
+ (Rlt_trans 0 (l / 2) ((f (x + delta / 2) - f x) / (delta / 2)) H6 H16);
+ intro.
+elim
+ (Rlt_irrefl 0
+    (Rlt_le_trans 0 ((f (x + delta / 2) - f x) / (delta / 2)) 0 H17 H10)).
+ring.
+pattern l at 3 in |- *; rewrite double_var.
+ring.
+intros.
+generalize
+ (Ropp_ge_le_contravar ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 r).
+rewrite Ropp_0.
+intro.
+elim
+ (Rlt_irrefl 0
+    (Rlt_le_trans 0 (- ((f (x + delta / 2) - f x) / (delta / 2) - l)) 0 H13
+       H15)).
+replace (- ((f (x + delta / 2) - f x) / (delta / 2) - l)) with
+ ((f x - f (x + delta / 2)) / (delta / 2) + l).
+unfold Rminus in |- *.
+apply Rplus_le_lt_0_compat.
+unfold Rdiv in |- *; apply Rmult_le_pos.
+cut (x <= x + delta * / 2).
+intro; generalize (H0 x (x + delta * / 2) H13); intro;
+ generalize
+  (Rplus_le_compat_l (- f (x + delta / 2)) (f (x + delta / 2)) (f x) H14);
+ rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
+pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+ left; assumption.
+left; apply Rinv_0_lt_compat; assumption.
+assumption.
+rewrite Ropp_minus_distr.
+unfold Rminus in |- *.
+rewrite (Rplus_comm l).
+unfold Rdiv in |- *.
+rewrite <- Ropp_mult_distr_l_reverse.
+rewrite Ropp_plus_distr.
+rewrite Ropp_involutive.
+rewrite (Rplus_comm (f x)).
+reflexivity.
+replace ((f (x + delta / 2) - f x) / (delta / 2)) with
+ (- ((f x - f (x + delta / 2)) / (delta / 2))).
+rewrite <- Ropp_0.
+apply Ropp_ge_le_contravar.
+apply Rle_ge.
+unfold Rdiv in |- *; apply Rmult_le_pos.
+cut (x <= x + delta * / 2).
+intro; generalize (H0 x (x + delta * / 2) H10); intro.
+generalize
+ (Rplus_le_compat_l (- f (x + delta / 2)) (f (x + delta / 2)) (f x) H13);
+ rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
+pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+ left; assumption.
+left; apply Rinv_0_lt_compat; assumption.
+unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
+rewrite Ropp_minus_distr.
+reflexivity.
+split.
+unfold Rdiv in |- *; apply prod_neq_R0.
+generalize (cond_pos delta); intro; red in |- *; intro H9; rewrite H9 in H8;
+ elim (Rlt_irrefl 0 H8).
+apply Rinv_neq_0_compat; discrR.
+split.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+rewrite Rabs_right.
+unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+prove_sup0.
+rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; rewrite double; pattern (pos delta) at 1 in |- *;
+ rewrite <- Rplus_0_r.
+apply Rplus_lt_compat_l; apply (cond_pos delta).
+discrR.
+apply Rle_ge; unfold Rdiv in |- *; left; apply Rmult_lt_0_compat.
+apply (cond_pos delta).
+apply Rinv_0_lt_compat; prove_sup0.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply H4 | apply Rinv_0_lt_compat; prove_sup0 ].
+Qed.
+
+(**********)
+Lemma increasing_decreasing_opp :
+ forall f:R -> R, increasing f -> decreasing (- f)%F.
+unfold increasing, decreasing, opp_fct in |- *; intros; generalize (H x y H0);
+ intro; apply Ropp_ge_le_contravar; apply Rle_ge; assumption.
+Qed.
+
+(**********)
+Lemma nonpos_derivative_1 :
+ forall (f:R -> R) (pr:derivable f),
+   (forall x:R, derive_pt f x (pr x) <= 0) -> decreasing f.
+intros.
+cut (forall h:R, - - f h = f h).
+intro.
+generalize (increasing_decreasing_opp (- f)%F).
+unfold decreasing in |- *.
+unfold opp_fct in |- *.
+intros.
+rewrite <- (H0 x); rewrite <- (H0 y).
+apply H1.
+cut (forall x:R, 0 <= derive_pt (- f) x (derivable_opp f pr x)).
+intros.
+replace (fun x:R => - f x) with (- f)%F; [ idtac | reflexivity ].
+apply (nonneg_derivative_1 (- f)%F (derivable_opp f pr) H3).
+intro.
+assert (H3 := derive_pt_opp f x0 (pr x0)).
+cut
+ (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) =
+  derive_pt (- f) x0 (derivable_opp f pr x0)).
+intro.
+rewrite <- H4.
+rewrite H3.
+rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; apply (H x0).
+apply pr_nu.
+assumption.
+intro; ring.
+Qed.
+ 
+(**********)
+Lemma positive_derivative :
+ forall (f:R -> R) (pr:derivable f),
+   (forall x:R, 0 < derive_pt f x (pr x)) -> strict_increasing f.
+intros.
+unfold strict_increasing in |- *.
+intros.
+apply Rplus_lt_reg_r with (- f x).
+rewrite Rplus_opp_l; rewrite Rplus_comm.
+assert (H1 := MVT_cor1 f _ _ pr H0).
+elim H1; intros.
+elim H2; intros.
+unfold Rminus in H3.
+rewrite H3.
+apply Rmult_lt_0_compat.
+apply H.
+apply Rplus_lt_reg_r with x.
+rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
+Qed.
+
+(**********)
+Lemma strictincreasing_strictdecreasing_opp :
+ forall f:R -> R, strict_increasing f -> strict_decreasing (- f)%F.
+unfold strict_increasing, strict_decreasing, opp_fct in |- *; intros;
+ generalize (H x y H0); intro; apply Ropp_lt_gt_contravar; 
+ assumption.
+Qed.
+ 
+(**********)
+Lemma negative_derivative :
+ forall (f:R -> R) (pr:derivable f),
+   (forall x:R, derive_pt f x (pr x) < 0) -> strict_decreasing f.
+intros.
+cut (forall h:R, - - f h = f h).
+intros.
+generalize (strictincreasing_strictdecreasing_opp (- f)%F).
+unfold strict_decreasing, opp_fct in |- *.
+intros.
+rewrite <- (H0 x).
+rewrite <- (H0 y).
+apply H1; [ idtac | assumption ].
+cut (forall x:R, 0 < derive_pt (- f) x (derivable_opp f pr x)).
+intros; eapply positive_derivative; apply H3.
+intro.
+assert (H3 := derive_pt_opp f x0 (pr x0)).
+cut
+ (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) =
+  derive_pt (- f) x0 (derivable_opp f pr x0)).
+intro.
+rewrite <- H4; rewrite H3.
+rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply (H x0).
+apply pr_nu.
+intro; ring.
+Qed.
+ 
+(**********)
+Lemma null_derivative_0 :
+ forall (f:R -> R) (pr:derivable f),
+   constant f -> forall x:R, derive_pt f x (pr x) = 0. 
+intros.
+unfold constant in H.
+apply derive_pt_eq_0.
+intros; exists (mkposreal 1 Rlt_0_1); simpl in |- *; intros.
+rewrite (H x (x + h)); unfold Rminus in |- *; unfold Rdiv in |- *;
+ rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r; 
+ rewrite Rabs_R0; assumption.
+Qed.
+
+(**********)
+Lemma increasing_decreasing :
+ forall f:R -> R, increasing f -> decreasing f -> constant f.
+unfold increasing, decreasing, constant in |- *; intros;
+ case (Rtotal_order x y); intro.
+generalize (Rlt_le x y H1); intro;
+ apply (Rle_antisym (f x) (f y) (H x y H2) (H0 x y H2)).
+elim H1; intro.
+rewrite H2; reflexivity.
+generalize (Rlt_le y x H2); intro; symmetry  in |- *;
+ apply (Rle_antisym (f y) (f x) (H y x H3) (H0 y x H3)).
+Qed.
+
+(**********)
+Lemma null_derivative_1 :
+ forall (f:R -> R) (pr:derivable f),
+   (forall x:R, derive_pt f x (pr x) = 0) -> constant f.
+intros.
+cut (forall x:R, derive_pt f x (pr x) <= 0).
+cut (forall x:R, 0 <= derive_pt f x (pr x)).
+intros.
+assert (H2 := nonneg_derivative_1 f pr H0).
+assert (H3 := nonpos_derivative_1 f pr H1).
+apply increasing_decreasing; assumption.
+intro; right; symmetry  in |- *; apply (H x).
+intro; right; apply (H x).
+Qed.
+
+(**********)
+Lemma derive_increasing_interv_ax :
+ forall (a b:R) (f:R -> R) (pr:derivable f),
+   a < b ->
+   ((forall t:R, a < t < b -> 0 < derive_pt f t (pr t)) ->
+    forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y) /\
+   ((forall t:R, a < t < b -> 0 <= derive_pt f t (pr t)) ->
+    forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y).
+intros.
+split; intros.
+apply Rplus_lt_reg_r with (- f x).
+rewrite Rplus_opp_l; rewrite Rplus_comm.
+assert (H4 := MVT_cor1 f _ _ pr H3).
+elim H4; intros.
+elim H5; intros.
+unfold Rminus in H6.
+rewrite H6.
+apply Rmult_lt_0_compat.
+apply H0.
+elim H7; intros.
+split.
+elim H1; intros.
+apply Rle_lt_trans with x; assumption.
+elim H2; intros.
+apply Rlt_le_trans with y; assumption.
+apply Rplus_lt_reg_r with x.
+rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
+apply Rplus_le_reg_l with (- f x).
+rewrite Rplus_opp_l; rewrite Rplus_comm.
+assert (H4 := MVT_cor1 f _ _ pr H3).
+elim H4; intros.
+elim H5; intros.
+unfold Rminus in H6.
+rewrite H6.
+apply Rmult_le_pos.
+apply H0.
+elim H7; intros.
+split.
+elim H1; intros.
+apply Rle_lt_trans with x; assumption.
+elim H2; intros.
+apply Rlt_le_trans with y; assumption.
+apply Rplus_le_reg_l with x.
+rewrite Rplus_0_r; replace (x + (y + - x)) with y;
+ [ left; assumption | ring ].
+Qed.
+
+(**********)
+Lemma derive_increasing_interv :
+ forall (a b:R) (f:R -> R) (pr:derivable f),
+   a < b ->
+   (forall t:R, a < t < b -> 0 < derive_pt f t (pr t)) ->
+   forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y.
+intros.
+generalize (derive_increasing_interv_ax a b f pr H); intro.
+elim H4; intros H5 _; apply (H5 H0 x y H1 H2 H3).
+Qed.
+
+(**********)
+Lemma derive_increasing_interv_var :
+ forall (a b:R) (f:R -> R) (pr:derivable f),
+   a < b ->
+   (forall t:R, a < t < b -> 0 <= derive_pt f t (pr t)) ->
+   forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y.
+intros a b f pr H H0 x y H1 H2 H3;
+ generalize (derive_increasing_interv_ax a b f pr H); 
+ intro; elim H4; intros _ H5; apply (H5 H0 x y H1 H2 H3).
+Qed.
+
+(**********)
+(**********)
+Theorem IAF :
+ forall (f:R -> R) (a b k:R) (pr:derivable f),
+   a <= b ->
+   (forall c:R, a <= c <= b -> derive_pt f c (pr c) <= k) ->
+   f b - f a <= k * (b - a).
+intros.
+case (total_order_T a b); intro.
+elim s; intro.
+assert (H1 := MVT_cor1 f _ _ pr a0).
+elim H1; intros.
+elim H2; intros.
+rewrite H3.
+do 2 rewrite <- (Rmult_comm (b - a)).
+apply Rmult_le_compat_l.
+apply Rplus_le_reg_l with a; rewrite Rplus_0_r.
+replace (a + (b - a)) with b; [ assumption | ring ].
+apply H0.
+elim H4; intros.
+split; left; assumption.
+rewrite b0.
+unfold Rminus in |- *; do 2 rewrite Rplus_opp_r.
+rewrite Rmult_0_r; right; reflexivity.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+Qed.
+
+Lemma IAF_var :
+ forall (f g:R -> R) (a b:R) (pr1:derivable f) (pr2:derivable g),
+   a <= b ->
+   (forall c:R, a <= c <= b -> derive_pt g c (pr2 c) <= derive_pt f c (pr1 c)) ->
+   g b - g a <= f b - f a.
+intros.
+cut (derivable (g - f)).
+intro.
+cut (forall c:R, a <= c <= b -> derive_pt (g - f) c (X c) <= 0).
+intro. 
+assert (H2 := IAF (g - f)%F a b 0 X H H1).
+rewrite Rmult_0_l in H2; unfold minus_fct in H2.
+apply Rplus_le_reg_l with (- f b + f a).
+replace (- f b + f a + (f b - f a)) with 0; [ idtac | ring ].
+replace (- f b + f a + (g b - g a)) with (g b - f b - (g a - f a));
+ [ apply H2 | ring ].
+intros.
+cut
+ (derive_pt (g - f) c (X c) =
+  derive_pt (g - f) c (derivable_pt_minus _ _ _ (pr2 c) (pr1 c))).
+intro.
+rewrite H2.
+rewrite derive_pt_minus.
+apply Rplus_le_reg_l with (derive_pt f c (pr1 c)).
+rewrite Rplus_0_r.
+replace
+ (derive_pt f c (pr1 c) + (derive_pt g c (pr2 c) - derive_pt f c (pr1 c)))
+ with (derive_pt g c (pr2 c)); [ idtac | ring ].
+apply H0; assumption.
+apply pr_nu.
+apply derivable_minus; assumption.
+Qed.
+
+(* If f has a null derivative in ]a,b[ and is continue in [a,b], *)
+(* then f is constant on [a,b] *)
+Lemma null_derivative_loc :
+ forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x),
+   (forall x:R, a <= x <= b -> continuity_pt f x) ->
+   (forall (x:R) (P:a < x < b), derive_pt f x (pr x P) = 0) ->
+   constant_D_eq f (fun x:R => a <= x <= b) (f a).
+intros; unfold constant_D_eq in |- *; intros; case (total_order_T a b); intro.
+elim s; intro.
+assert (H2 : forall y:R, a < y < x -> derivable_pt id y).
+intros; apply derivable_pt_id.
+assert (H3 : forall y:R, a <= y <= x -> continuity_pt id y).
+intros; apply derivable_continuous; apply derivable_id.
+assert (H4 : forall y:R, a < y < x -> derivable_pt f y).
+intros; apply pr; elim H4; intros; split.
+assumption.
+elim H1; intros; apply Rlt_le_trans with x; assumption.
+assert (H5 : forall y:R, a <= y <= x -> continuity_pt f y).
+intros; apply H; elim H5; intros; split.
+assumption.
+elim H1; intros; apply Rle_trans with x; assumption.
+elim H1; clear H1; intros; elim H1; clear H1; intro.
+assert (H7 := MVT f id a x H4 H2 H1 H5 H3).
+elim H7; intros; elim H8; intros; assert (H10 : a < x0 < b).
+elim x1; intros; split.
+assumption.
+apply Rlt_le_trans with x; assumption.
+assert (H11 : derive_pt f x0 (H4 x0 x1) = 0).
+replace (derive_pt f x0 (H4 x0 x1)) with (derive_pt f x0 (pr x0 H10));
+ [ apply H0 | apply pr_nu ].
+assert (H12 : derive_pt id x0 (H2 x0 x1) = 1).
+apply derive_pt_eq_0; apply derivable_pt_lim_id.
+rewrite H11 in H9; rewrite H12 in H9; rewrite Rmult_0_r in H9;
+ rewrite Rmult_1_r in H9; apply Rminus_diag_uniq; symmetry  in |- *;
+ assumption.
+rewrite H1; reflexivity.
+assert (H2 : x = a).
+rewrite <- b0 in H1; elim H1; intros; apply Rle_antisym; assumption.
+rewrite H2; reflexivity.
+elim H1; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H2 H3) r)).
+Qed.
+
+(* Unicity of the antiderivative *)
+Lemma antiderivative_Ucte :
+ forall (f g1 g2:R -> R) (a b:R),
+   antiderivative f g1 a b ->
+   antiderivative f g2 a b ->
+    exists c : R, (forall x:R, a <= x <= b -> g1 x = g2 x + c).
+unfold antiderivative in |- *; intros; elim H; clear H; intros; elim H0;
+ clear H0; intros H0 _; exists (g1 a - g2 a); intros;
+ assert (H3 : forall x:R, a <= x <= b -> derivable_pt g1 x).
+intros; unfold derivable_pt in |- *; apply existT with (f x0); elim (H x0 H3);
+ intros; eapply derive_pt_eq_1; symmetry  in |- *; 
+ apply H4.
+assert (H4 : forall x:R, a <= x <= b -> derivable_pt g2 x).
+intros; unfold derivable_pt in |- *; apply existT with (f x0);
+ elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry  in |- *; 
+ apply H5.
+assert (H5 : forall x:R, a < x < b -> derivable_pt (g1 - g2) x).
+intros; elim H5; intros; apply derivable_pt_minus;
+ [ apply H3; split; left; assumption | apply H4; split; left; assumption ].
+assert (H6 : forall x:R, a <= x <= b -> continuity_pt (g1 - g2) x).
+intros; apply derivable_continuous_pt; apply derivable_pt_minus;
+ [ apply H3 | apply H4 ]; assumption.
+assert (H7 : forall (x:R) (P:a < x < b), derive_pt (g1 - g2) x (H5 x P) = 0).
+intros; elim P; intros; apply derive_pt_eq_0; replace 0 with (f x0 - f x0);
+ [ idtac | ring ].
+assert (H9 : a <= x0 <= b).
+split; left; assumption.
+apply derivable_pt_lim_minus; [ elim (H _ H9) | elim (H0 _ H9) ]; intros;
+ eapply derive_pt_eq_1; symmetry  in |- *; apply H10.
+assert (H8 := null_derivative_loc (g1 - g2)%F a b H5 H6 H7);
+ unfold constant_D_eq in H8; assert (H9 := H8 _ H2); 
+ unfold minus_fct in H9; rewrite <- H9; ring.
+Qed.
diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v
new file mode 100644
index 00000000..97cd4b94
--- /dev/null
+++ b/theories/Reals/NewtonInt.v
@@ -0,0 +1,788 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: NewtonInt.v,v 1.11.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import Ranalysis. Open Local Scope R_scope.
+
+(*******************************************)
+(*            Newton's Integral            *)
+(*******************************************)
+
+Definition Newton_integrable (f:R -> R) (a b:R) : Type :=
+  sigT (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a).
+
+Definition NewtonInt (f:R -> R) (a b:R) (pr:Newton_integrable f a b) : R :=
+  let g := match pr with
+           | existT a b => a
+           end in g b - g a.
+
+(* If f is differentiable, then f' is Newton integrable (Tautology ?) *)
+Lemma FTCN_step1 :
+ forall (f:Differential) (a b:R),
+   Newton_integrable (fun x:R => derive_pt f x (cond_diff f x)) a b.
+intros f a b; unfold Newton_integrable in |- *; apply existT with (d1 f);
+ unfold antiderivative in |- *; intros; case (Rle_dec a b); 
+ intro;
+ [ left; split; [ intros; exists (cond_diff f x); reflexivity | assumption ]
+ | right; split;
+    [ intros; exists (cond_diff f x); reflexivity | auto with real ] ].
+Defined.
+
+(* By definition, we have the Fondamental Theorem of Calculus *)
+Lemma FTC_Newton :
+ forall (f:Differential) (a b:R),
+   NewtonInt (fun x:R => derive_pt f x (cond_diff f x)) a b
+     (FTCN_step1 f a b) = f b - f a.
+intros; unfold NewtonInt in |- *; reflexivity.
+Qed.
+
+(* $\int_a^a f$ exists forall a:R and f:R->R *)
+Lemma NewtonInt_P1 : forall (f:R -> R) (a:R), Newton_integrable f a a.
+intros f a; unfold Newton_integrable in |- *;
+ apply existT with (fct_cte (f a) * id)%F; left;
+ unfold antiderivative in |- *; split.
+intros; assert (H1 : derivable_pt (fct_cte (f a) * id) x).
+apply derivable_pt_mult.
+apply derivable_pt_const.
+apply derivable_pt_id.
+exists H1; assert (H2 : x = a).
+elim H; intros; apply Rle_antisym; assumption.
+symmetry  in |- *; apply derive_pt_eq_0;
+ replace (f x) with (0 * id x + fct_cte (f a) x * 1);
+ [ apply (derivable_pt_lim_mult (fct_cte (f a)) id x);
+    [ apply derivable_pt_lim_const | apply derivable_pt_lim_id ]
+ | unfold id, fct_cte in |- *; rewrite H2; ring ].
+right; reflexivity.
+Defined.
+
+(* $\int_a^a f = 0$ *)
+Lemma NewtonInt_P2 :
+ forall (f:R -> R) (a:R), NewtonInt f a a (NewtonInt_P1 f a) = 0.
+intros; unfold NewtonInt in |- *; simpl in |- *;
+ unfold mult_fct, fct_cte, id in |- *; ring.
+Qed.
+
+(* If $\int_a^b f$ exists, then $\int_b^a f$ exists too *)
+Lemma NewtonInt_P3 :
+ forall (f:R -> R) (a b:R) (X:Newton_integrable f a b),
+   Newton_integrable f b a.
+unfold Newton_integrable in |- *; intros; elim X; intros g H;
+ apply existT with g; tauto.
+Defined.
+
+(* $\int_a^b f = -\int_b^a f$ *)
+Lemma NewtonInt_P4 :
+ forall (f:R -> R) (a b:R) (pr:Newton_integrable f a b),
+   NewtonInt f a b pr = - NewtonInt f b a (NewtonInt_P3 f a b pr).
+intros; unfold Newton_integrable in pr; elim pr; intros; elim p; intro.
+unfold NewtonInt in |- *;
+ case
+  (NewtonInt_P3 f a b
+     (existT
+        (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a) x
+        p)).
+intros; elim o; intro.
+unfold antiderivative in H0; elim H0; intros; elim H2; intro.
+unfold antiderivative in H; elim H; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3)).
+rewrite H3; ring.
+assert (H1 := antiderivative_Ucte f x x0 a b H H0); elim H1; intros;
+ unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+assert (H3 : a <= a <= b).
+split; [ right; reflexivity | assumption ].
+assert (H4 : a <= b <= b).
+split; [ assumption | right; reflexivity ].
+assert (H5 := H2 _ H3); assert (H6 := H2 _ H4); rewrite H5; rewrite H6; ring.
+unfold NewtonInt in |- *;
+ case
+  (NewtonInt_P3 f a b
+     (existT
+        (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a) x
+        p)); intros; elim o; intro.
+assert (H1 := antiderivative_Ucte f x x0 b a H H0); elim H1; intros;
+ unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+assert (H3 : b <= a <= a).
+split; [ assumption | right; reflexivity ].
+assert (H4 : b <= b <= a).
+split; [ right; reflexivity | assumption ].
+assert (H5 := H2 _ H3); assert (H6 := H2 _ H4); rewrite H5; rewrite H6; ring.
+unfold antiderivative in H0; elim H0; intros; elim H2; intro.
+unfold antiderivative in H; elim H; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3)).
+rewrite H3; ring.
+Qed.
+
+(* The set of Newton integrable functions is a vectorial space *)
+Lemma NewtonInt_P5 :
+ forall (f g:R -> R) (l a b:R),
+   Newton_integrable f a b ->
+   Newton_integrable g a b ->
+   Newton_integrable (fun x:R => l * f x + g x) a b.
+unfold Newton_integrable in |- *; intros; elim X; intros; elim X0; intros;
+ exists (fun y:R => l * x y + x0 y).
+elim p; intro.
+elim p0; intro.
+left; unfold antiderivative in |- *; unfold antiderivative in H, H0; elim H;
+ clear H; intros; elim H0; clear H0; intros H0 _.
+split.
+intros; elim (H _ H2); elim (H0 _ H2); intros.
+assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1).
+reg.
+exists H5; symmetry  in |- *; reg; rewrite <- H3; rewrite <- H4; reflexivity.
+assumption.
+unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro.
+elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)).
+left; rewrite <- H5; unfold antiderivative in |- *; split.
+intros; elim H6; intros; assert (H9 : x1 = a).
+apply Rle_antisym; assumption.
+assert (H10 : a <= x1 <= b).
+split; right; [ symmetry  in |- *; assumption | rewrite <- H5; assumption ].
+assert (H11 : b <= x1 <= a).
+split; right; [ rewrite <- H5; symmetry  in |- *; assumption | assumption ].
+assert (H12 : derivable_pt x x1).
+unfold derivable_pt in |- *; exists (f x1); elim (H3 _ H10); intros;
+ eapply derive_pt_eq_1; symmetry  in |- *; apply H12.
+assert (H13 : derivable_pt x0 x1).
+unfold derivable_pt in |- *; exists (g x1); elim (H1 _ H11); intros;
+ eapply derive_pt_eq_1; symmetry  in |- *; apply H13.
+assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1).
+reg.
+exists H14; symmetry  in |- *; reg.
+assert (H15 : derive_pt x0 x1 H13 = g x1).
+elim (H1 _ H11); intros; rewrite H15; apply pr_nu.
+assert (H16 : derive_pt x x1 H12 = f x1).
+elim (H3 _ H10); intros; rewrite H16; apply pr_nu.
+rewrite H15; rewrite H16; ring.
+right; reflexivity.
+elim p0; intro.
+unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro.
+elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)).
+left; rewrite H5; unfold antiderivative in |- *; split.
+intros; elim H6; intros; assert (H9 : x1 = a).
+apply Rle_antisym; assumption.
+assert (H10 : a <= x1 <= b).
+split; right; [ symmetry  in |- *; assumption | rewrite H5; assumption ].
+assert (H11 : b <= x1 <= a).
+split; right; [ rewrite H5; symmetry  in |- *; assumption | assumption ].
+assert (H12 : derivable_pt x x1).
+unfold derivable_pt in |- *; exists (f x1); elim (H3 _ H11); intros;
+ eapply derive_pt_eq_1; symmetry  in |- *; apply H12.
+assert (H13 : derivable_pt x0 x1).
+unfold derivable_pt in |- *; exists (g x1); elim (H1 _ H10); intros;
+ eapply derive_pt_eq_1; symmetry  in |- *; apply H13.
+assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1).
+reg.
+exists H14; symmetry  in |- *; reg.
+assert (H15 : derive_pt x0 x1 H13 = g x1).
+elim (H1 _ H10); intros; rewrite H15; apply pr_nu.
+assert (H16 : derive_pt x x1 H12 = f x1).
+elim (H3 _ H11); intros; rewrite H16; apply pr_nu.
+rewrite H15; rewrite H16; ring.
+right; reflexivity.
+right; unfold antiderivative in |- *; unfold antiderivative in H, H0; elim H;
+ clear H; intros; elim H0; clear H0; intros H0 _; split.
+intros; elim (H _ H2); elim (H0 _ H2); intros.
+assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1).
+reg.
+exists H5; symmetry  in |- *; reg; rewrite <- H3; rewrite <- H4; reflexivity.
+assumption.
+Defined.
+
+(**********)
+Lemma antiderivative_P1 :
+ forall (f g F G:R -> R) (l a b:R),
+   antiderivative f F a b ->
+   antiderivative g G a b ->
+   antiderivative (fun x:R => l * f x + g x) (fun x:R => l * F x + G x) a b.
+unfold antiderivative in |- *; intros; elim H; elim H0; clear H H0; intros;
+ split.
+intros; elim (H _ H3); elim (H1 _ H3); intros.
+assert (H6 : derivable_pt (fun x:R => l * F x + G x) x).
+reg.
+exists H6; symmetry  in |- *; reg; rewrite <- H4; rewrite <- H5; ring.
+assumption.
+Qed.
+
+(* $\int_a^b \lambda f + g = \lambda \int_a^b f + \int_a^b f *)
+Lemma NewtonInt_P6 :
+ forall (f g:R -> R) (l a b:R) (pr1:Newton_integrable f a b)
+   (pr2:Newton_integrable g a b),
+   NewtonInt (fun x:R => l * f x + g x) a b (NewtonInt_P5 f g l a b pr1 pr2) =
+   l * NewtonInt f a b pr1 + NewtonInt g a b pr2.
+intros f g l a b pr1 pr2; unfold NewtonInt in |- *;
+ case (NewtonInt_P5 f g l a b pr1 pr2); intros; case pr1; 
+ intros; case pr2; intros; case (total_order_T a b); 
+ intro.
+elim s; intro.
+elim o; intro.
+elim o0; intro.
+elim o1; intro.
+assert (H2 := antiderivative_P1 f g x0 x1 l a b H0 H1);
+ assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); 
+ elim H3; intros; assert (H5 : a <= a <= b).
+split; [ right; reflexivity | left; assumption ].
+assert (H6 : a <= b <= b).
+split; [ left; assumption | right; reflexivity ].
+assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring.
+unfold antiderivative in H1; elim H1; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 a0)).
+unfold antiderivative in H0; elim H0; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
+unfold antiderivative in H; elim H; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 a0)).
+rewrite b0; ring.
+elim o; intro.
+unfold antiderivative in H; elim H; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r)).
+elim o0; intro.
+unfold antiderivative in H0; elim H0; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 r)).
+elim o1; intro.
+unfold antiderivative in H1; elim H1; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 r)).
+assert (H2 := antiderivative_P1 f g x0 x1 l b a H0 H1);
+ assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); 
+ elim H3; intros; assert (H5 : b <= a <= a).
+split; [ left; assumption | right; reflexivity ].
+assert (H6 : b <= b <= a).
+split; [ right; reflexivity | left; assumption ].
+assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring.
+Qed.
+
+Lemma antiderivative_P2 :
+ forall (f F0 F1:R -> R) (a b c:R),
+   antiderivative f F0 a b ->
+   antiderivative f F1 b c ->
+   antiderivative f
+     (fun x:R =>
+        match Rle_dec x b with
+        | left _ => F0 x
+        | right _ => F1 x + (F0 b - F1 b)
+        end) a c.
+unfold antiderivative in |- *; intros; elim H; clear H; intros; elim H0;
+ clear H0; intros; split.
+2: apply Rle_trans with b; assumption.
+intros; elim H3; clear H3; intros; case (total_order_T x b); intro.
+elim s; intro.
+assert (H5 : a <= x <= b).
+split; [ assumption | left; assumption ].
+assert (H6 := H _ H5); elim H6; clear H6; intros;
+ assert
+  (H7 :
+   derivable_pt_lim
+     (fun x:R =>
+        match Rle_dec x b with
+        | left _ => F0 x
+        | right _ => F1 x + (F0 b - F1 b)
+        end) x (f x)).
+unfold derivable_pt_lim in |- *; assert (H7 : derive_pt F0 x x0 = f x).
+symmetry  in |- *; assumption.
+assert (H8 := derive_pt_eq_1 F0 x (f x) x0 H7); unfold derivable_pt_lim in H8;
+ intros; elim (H8 _ H9); intros; set (D := Rmin x1 (b - x)).
+assert (H11 : 0 < D).
+unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x1 (b - x)); intro.
+apply (cond_pos x1).
+apply Rlt_Rminus; assumption.
+exists (mkposreal _ H11); intros; case (Rle_dec x b); intro.
+case (Rle_dec (x + h) b); intro.
+apply H10.
+assumption.
+apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_l ].
+elim n; left; apply Rlt_le_trans with (x + D).
+apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h).
+apply RRle_abs.
+apply H13.
+apply Rplus_le_reg_l with (- x); rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
+ rewrite Rplus_0_l; rewrite Rplus_comm; unfold D in |- *; 
+ apply Rmin_r.
+elim n; left; assumption.
+assert
+ (H8 :
+  derivable_pt
+    (fun x:R =>
+       match Rle_dec x b with
+       | left _ => F0 x
+       | right _ => F1 x + (F0 b - F1 b)
+       end) x).
+unfold derivable_pt in |- *; apply existT with (f x); apply H7.
+exists H8; symmetry  in |- *; apply derive_pt_eq_0; apply H7.
+assert (H5 : a <= x <= b).
+split; [ assumption | right; assumption ].
+assert (H6 : b <= x <= c).
+split; [ right; symmetry  in |- *; assumption | assumption ].
+elim (H _ H5); elim (H0 _ H6); intros; assert (H9 : derive_pt F0 x x1 = f x).
+symmetry  in |- *; assumption.
+assert (H10 : derive_pt F1 x x0 = f x).
+symmetry  in |- *; assumption.
+assert (H11 := derive_pt_eq_1 F0 x (f x) x1 H9);
+ assert (H12 := derive_pt_eq_1 F1 x (f x) x0 H10);
+ assert
+  (H13 :
+   derivable_pt_lim
+     (fun x:R =>
+        match Rle_dec x b with
+        | left _ => F0 x
+        | right _ => F1 x + (F0 b - F1 b)
+        end) x (f x)).
+unfold derivable_pt_lim in |- *; unfold derivable_pt_lim in H11, H12; intros;
+ elim (H11 _ H13); elim (H12 _ H13); intros; set (D := Rmin x2 x3);
+ assert (H16 : 0 < D).
+unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x2 x3); intro.
+apply (cond_pos x2).
+apply (cond_pos x3).
+exists (mkposreal _ H16); intros; case (Rle_dec x b); intro.
+case (Rle_dec (x + h) b); intro.
+apply H15.
+assumption.
+apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_r ].
+replace (F1 (x + h) + (F0 b - F1 b) - F0 x) with (F1 (x + h) - F1 x).
+apply H14.
+assumption.
+apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_l ].
+rewrite b0; ring.
+elim n; right; assumption.
+assert
+ (H14 :
+  derivable_pt
+    (fun x:R =>
+       match Rle_dec x b with
+       | left _ => F0 x
+       | right _ => F1 x + (F0 b - F1 b)
+       end) x).
+unfold derivable_pt in |- *; apply existT with (f x); apply H13.
+exists H14; symmetry  in |- *; apply derive_pt_eq_0; apply H13.
+assert (H5 : b <= x <= c).
+split; [ left; assumption | assumption ].
+assert (H6 := H0 _ H5); elim H6; clear H6; intros;
+ assert
+  (H7 :
+   derivable_pt_lim
+     (fun x:R =>
+        match Rle_dec x b with
+        | left _ => F0 x
+        | right _ => F1 x + (F0 b - F1 b)
+        end) x (f x)).
+unfold derivable_pt_lim in |- *; assert (H7 : derive_pt F1 x x0 = f x).
+symmetry  in |- *; assumption.
+assert (H8 := derive_pt_eq_1 F1 x (f x) x0 H7); unfold derivable_pt_lim in H8;
+ intros; elim (H8 _ H9); intros; set (D := Rmin x1 (x - b));
+ assert (H11 : 0 < D).
+unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x1 (x - b)); intro.
+apply (cond_pos x1).
+apply Rlt_Rminus; assumption.
+exists (mkposreal _ H11); intros; case (Rle_dec x b); intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 r)).
+case (Rle_dec (x + h) b); intro.
+cut (b < x + h).
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14)).
+apply Rplus_lt_reg_r with (- h - b); replace (- h - b + b) with (- h);
+ [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b); 
+ [ idtac | ring ]; apply Rle_lt_trans with (Rabs h).
+rewrite <- Rabs_Ropp; apply RRle_abs.
+apply Rlt_le_trans with D.
+apply H13.
+unfold D in |- *; apply Rmin_r.
+replace (F1 (x + h) + (F0 b - F1 b) - (F1 x + (F0 b - F1 b))) with
+ (F1 (x + h) - F1 x); [ idtac | ring ]; apply H10.
+assumption.
+apply Rlt_le_trans with D.
+assumption.
+unfold D in |- *; apply Rmin_l.
+assert
+ (H8 :
+  derivable_pt
+    (fun x:R =>
+       match Rle_dec x b with
+       | left _ => F0 x
+       | right _ => F1 x + (F0 b - F1 b)
+       end) x).
+unfold derivable_pt in |- *; apply existT with (f x); apply H7.
+exists H8; symmetry  in |- *; apply derive_pt_eq_0; apply H7.
+Qed.
+
+Lemma antiderivative_P3 :
+ forall (f F0 F1:R -> R) (a b c:R),
+   antiderivative f F0 a b ->
+   antiderivative f F1 c b ->
+   antiderivative f F1 c a \/ antiderivative f F0 a c.
+intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
+ intros; case (total_order_T a c); intro.
+elim s; intro.
+right; unfold antiderivative in |- *; split.
+intros; apply H1; elim H3; intros; split;
+ [ assumption | apply Rle_trans with c; assumption ].
+left; assumption.
+right; unfold antiderivative in |- *; split.
+intros; apply H1; elim H3; intros; split;
+ [ assumption | apply Rle_trans with c; assumption ].
+right; assumption.
+left; unfold antiderivative in |- *; split.
+intros; apply H; elim H3; intros; split;
+ [ assumption | apply Rle_trans with a; assumption ].
+left; assumption.
+Qed.
+
+Lemma antiderivative_P4 :
+ forall (f F0 F1:R -> R) (a b c:R),
+   antiderivative f F0 a b ->
+   antiderivative f F1 a c ->
+   antiderivative f F1 b c \/ antiderivative f F0 c b.
+intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
+ intros; case (total_order_T c b); intro.
+elim s; intro.
+right; unfold antiderivative in |- *; split.
+intros; apply H1; elim H3; intros; split;
+ [ apply Rle_trans with c; assumption | assumption ].
+left; assumption.
+right; unfold antiderivative in |- *; split.
+intros; apply H1; elim H3; intros; split;
+ [ apply Rle_trans with c; assumption | assumption ].
+right; assumption.
+left; unfold antiderivative in |- *; split.
+intros; apply H; elim H3; intros; split;
+ [ apply Rle_trans with b; assumption | assumption ].
+left; assumption.
+Qed.
+
+Lemma NewtonInt_P7 :
+ forall (f:R -> R) (a b c:R),
+   a < b ->
+   b < c ->
+   Newton_integrable f a b ->
+   Newton_integrable f b c -> Newton_integrable f a c.
+unfold Newton_integrable in |- *; intros f a b c Hab Hbc X X0; elim X;
+ clear X; intros F0 H0; elim X0; clear X0; intros F1 H1;
+ set
+  (g :=
+   fun x:R =>
+     match Rle_dec x b with
+     | left _ => F0 x
+     | right _ => F1 x + (F0 b - F1 b)
+     end); apply existT with g; left; unfold g in |- *;
+ apply antiderivative_P2.
+elim H0; intro.
+assumption.
+unfold antiderivative in H; elim H; clear H; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hab)).
+elim H1; intro.
+assumption.
+unfold antiderivative in H; elim H; clear H; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hbc)).
+Qed.
+
+Lemma NewtonInt_P8 :
+ forall (f:R -> R) (a b c:R),
+   Newton_integrable f a b ->
+   Newton_integrable f b c -> Newton_integrable f a c.
+intros.
+elim X; intros F0 H0.
+elim X0; intros F1 H1.
+case (total_order_T a b); intro.
+elim s; intro.
+case (total_order_T b c); intro.
+elim s0; intro.
+(* a<b & b<c *)
+unfold Newton_integrable in |- *;
+ apply existT with
+  (fun x:R =>
+     match Rle_dec x b with
+     | left _ => F0 x
+     | right _ => F1 x + (F0 b - F1 b)
+     end).
+elim H0; intro.
+elim H1; intro.
+left; apply antiderivative_P2; assumption.
+unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a1)).
+unfold antiderivative in H; elim H; clear H; intros _ H.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
+(* a<b & b=c *)
+rewrite b0 in X; apply X.
+(* a<b & b>c *)
+case (total_order_T a c); intro.
+elim s0; intro.
+unfold Newton_integrable in |- *; apply existT with F0.
+left.
+elim H1; intro.
+unfold antiderivative in H; elim H; clear H; intros _ H.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+elim H0; intro.
+assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H).
+elim H3; intro.
+unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 a1)).
+assumption.
+unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
+rewrite b0; apply NewtonInt_P1.
+unfold Newton_integrable in |- *; apply existT with F1.
+right.
+elim H1; intro.
+unfold antiderivative in H; elim H; clear H; intros _ H.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+elim H0; intro.
+assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H).
+elim H3; intro.
+assumption.
+unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 r0)).
+unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
+(* a=b *)
+rewrite b0; apply X0.
+case (total_order_T b c); intro.
+elim s; intro.
+(* a>b & b<c *)
+case (total_order_T a c); intro.
+elim s0; intro.
+unfold Newton_integrable in |- *; apply existT with F1.
+left.
+elim H1; intro.
+(*****************)
+elim H0; intro.
+unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 r)).
+assert (H3 := antiderivative_P4 f F0 F1 b a c H2 H).
+elim H3; intro.
+assumption.
+unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 a1)).
+unfold antiderivative in H; elim H; clear H; intros _ H.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
+rewrite b0; apply NewtonInt_P1.
+unfold Newton_integrable in |- *; apply existT with F0.
+right.
+elim H0; intro.
+unfold antiderivative in H; elim H; clear H; intros _ H.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+elim H1; intro.
+assert (H3 := antiderivative_P4 f F0 F1 b a c H H2).
+elim H3; intro.
+unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 r0)).
+assumption.
+unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
+(* a>b & b=c *)
+rewrite b0 in X; apply X.
+(* a>b & b>c *)
+assert (X1 := NewtonInt_P3 f a b X).
+assert (X2 := NewtonInt_P3 f b c X0).
+apply NewtonInt_P3.
+apply NewtonInt_P7 with b; assumption.
+Defined.
+
+(* Chasles' relation *)
+Lemma NewtonInt_P9 :
+ forall (f:R -> R) (a b c:R) (pr1:Newton_integrable f a b)
+   (pr2:Newton_integrable f b c),
+   NewtonInt f a c (NewtonInt_P8 f a b c pr1 pr2) =
+   NewtonInt f a b pr1 + NewtonInt f b c pr2.
+intros; unfold NewtonInt in |- *.
+case (NewtonInt_P8 f a b c pr1 pr2); intros.
+case pr1; intros.
+case pr2; intros.
+case (total_order_T a b); intro.
+elim s; intro.
+case (total_order_T b c); intro.
+elim s0; intro.
+(* a<b & b<c *)
+elim o0; intro.
+elim o1; intro.
+elim o; intro.
+assert (H2 := antiderivative_P2 f x0 x1 a b c H H0).
+assert
+ (H3 :=
+  antiderivative_Ucte f x
+    (fun x:R =>
+       match Rle_dec x b with
+       | left _ => x0 x
+       | right _ => x1 x + (x0 b - x1 b)
+       end) a c H1 H2).
+elim H3; intros.
+assert (H5 : a <= a <= c).
+split; [ right; reflexivity | left; apply Rlt_trans with b; assumption ].
+assert (H6 : a <= c <= c).
+split; [ left; apply Rlt_trans with b; assumption | right; reflexivity ].
+rewrite (H4 _ H5); rewrite (H4 _ H6).
+case (Rle_dec a b); intro.
+case (Rle_dec c b); intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 a1)).
+ring.
+elim n; left; assumption.
+unfold antiderivative in H1; elim H1; clear H1; intros _ H1.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ a0 a1))).
+unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a1)).
+unfold antiderivative in H; elim H; clear H; intros _ H.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
+(* a<b & b=c *)
+rewrite <- b0.
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r.
+rewrite <- b0 in o.
+elim o0; intro.
+elim o; intro.
+assert (H1 := antiderivative_Ucte f x x0 a b H0 H).
+elim H1; intros.
+rewrite (H2 b).
+rewrite (H2 a).
+ring.
+split; [ right; reflexivity | left; assumption ].
+split; [ left; assumption | right; reflexivity ].
+unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
+unfold antiderivative in H; elim H; clear H; intros _ H.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
+(* a<b & b>c *)
+elim o1; intro.
+unfold antiderivative in H; elim H; clear H; intros _ H.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+elim o0; intro.
+elim o; intro.
+assert (H2 := antiderivative_P2 f x x1 a c b H1 H).
+assert (H3 := antiderivative_Ucte _ _ _ a b H0 H2).
+elim H3; intros.
+rewrite (H4 a).
+rewrite (H4 b).
+case (Rle_dec b c); intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 r)).
+case (Rle_dec a c); intro.
+ring.
+elim n0; unfold antiderivative in H1; elim H1; intros; assumption.
+split; [ left; assumption | right; reflexivity ].
+split; [ right; reflexivity | left; assumption ].
+assert (H2 := antiderivative_P2 _ _ _ _ _ _ H1 H0).
+assert (H3 := antiderivative_Ucte _ _ _ c b H H2).
+elim H3; intros.
+rewrite (H4 c).
+rewrite (H4 b).
+case (Rle_dec b a); intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 a0)).
+case (Rle_dec c a); intro.
+ring.
+elim n0; unfold antiderivative in H1; elim H1; intros; assumption.
+split; [ left; assumption | right; reflexivity ].
+split; [ right; reflexivity | left; assumption ].
+unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
+(* a=b *)
+rewrite b0 in o; rewrite b0.
+elim o; intro.
+elim o1; intro.
+assert (H1 := antiderivative_Ucte _ _ _ b c H H0).
+elim H1; intros.
+assert (H3 : b <= c).
+unfold antiderivative in H; elim H; intros; assumption.
+rewrite (H2 b).
+rewrite (H2 c).
+ring.
+split; [ assumption | right; reflexivity ].
+split; [ right; reflexivity | assumption ].
+assert (H1 : b = c).
+unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym;
+ assumption.
+rewrite H1; ring.
+elim o1; intro.
+assert (H1 : b = c).
+unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym;
+ assumption.
+rewrite H1; ring.
+assert (H1 := antiderivative_Ucte _ _ _ c b H H0).
+elim H1; intros.
+assert (H3 : c <= b).
+unfold antiderivative in H; elim H; intros; assumption.
+rewrite (H2 c).
+rewrite (H2 b).
+ring.
+split; [ assumption | right; reflexivity ].
+split; [ right; reflexivity | assumption ].
+(* a>b & b<c *)
+case (total_order_T b c); intro.
+elim s; intro.
+elim o0; intro.
+unfold antiderivative in H; elim H; clear H; intros _ H.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+elim o1; intro.
+elim o; intro.
+assert (H2 := antiderivative_P2 _ _ _ _ _ _ H H1).
+assert (H3 := antiderivative_Ucte _ _ _ b c H0 H2).
+elim H3; intros.
+rewrite (H4 b).
+rewrite (H4 c).
+case (Rle_dec b a); intro.
+case (Rle_dec c a); intro.
+assert (H5 : a = c).
+unfold antiderivative in H1; elim H1; intros; apply Rle_antisym; assumption.
+rewrite H5; ring.
+ring.
+elim n; left; assumption.
+split; [ left; assumption | right; reflexivity ].
+split; [ right; reflexivity | left; assumption ].
+assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H1).
+assert (H3 := antiderivative_Ucte _ _ _ b a H H2).
+elim H3; intros.
+rewrite (H4 a).
+rewrite (H4 b).
+case (Rle_dec b c); intro.
+case (Rle_dec a c); intro.
+assert (H5 : a = c).
+unfold antiderivative in H1; elim H1; intros; apply Rle_antisym; assumption.
+rewrite H5; ring.
+ring.
+elim n; left; assumption.
+split; [ right; reflexivity | left; assumption ].
+split; [ left; assumption | right; reflexivity ].
+unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
+(* a>b & b=c *)
+rewrite <- b0.
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r.
+rewrite <- b0 in o.
+elim o0; intro.
+unfold antiderivative in H; elim H; clear H; intros _ H.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+elim o; intro.
+unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r)).
+assert (H1 := antiderivative_Ucte f x x0 b a H0 H).
+elim H1; intros.
+rewrite (H2 b).
+rewrite (H2 a).
+ring.
+split; [ left; assumption | right; reflexivity ].
+split; [ right; reflexivity | left; assumption ].
+(* a>b & b>c *)
+elim o0; intro.
+unfold antiderivative in H; elim H; clear H; intros _ H.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+elim o1; intro.
+unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r0)).
+elim o; intro.
+unfold antiderivative in H1; elim H1; clear H1; intros _ H1.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ r0 r))).
+assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H).
+assert (H3 := antiderivative_Ucte _ _ _ c a H1 H2).
+elim H3; intros.
+assert (H5 : c <= a).
+unfold antiderivative in H1; elim H1; intros; assumption.
+rewrite (H4 c).
+rewrite (H4 a).
+case (Rle_dec a b); intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r1 r)).
+case (Rle_dec c b); intro.
+ring.
+elim n0; left; assumption.
+split; [ assumption | right; reflexivity ].
+split; [ right; reflexivity | assumption ].
+Qed.
diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v
new file mode 100644
index 00000000..0c19c8da
--- /dev/null
+++ b/theories/Reals/PSeries_reg.v
@@ -0,0 +1,259 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: PSeries_reg.v,v 1.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Ranalysis1.
+Require Import Max.
+Require Import Even. Open Local Scope R_scope.
+
+Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r.
+
+(* Uniform convergence *)
+Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R) 
+  (r:posreal) : Prop :=
+  forall eps:R,
+    0 < eps ->
+     exists N : nat,
+      (forall (n:nat) (y:R),
+         (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps). 
+
+(* Normal convergence *)
+Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type :=
+  sigT
+    (fun An:nat -> R =>
+       sigT
+         (fun l:R =>
+            Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n) l /\
+            (forall (n:nat) (y:R), Boule 0 r y -> Rabs (fn n y) <= An n))).
+
+Definition CVN_R (fn:nat -> R -> R) : Type := forall r:posreal, CVN_r fn r.
+
+Definition SFL (fn:nat -> R -> R)
+  (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)) 
+  (y:R) : R := match cv y with
+               | existT a b => a
+               end.
+
+(* In a complete space, normal convergence implies uniform convergence *)
+Lemma CVN_CVU :
+ forall (fn:nat -> R -> R)
+   (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l))
+   (r:posreal), CVN_r fn r -> CVU (fun n:nat => SP fn n) (SFL fn cv) 0 r.
+intros; unfold CVU in |- *; intros.
+unfold CVN_r in X.
+elim X; intros An X0.
+elim X0; intros s H0.
+elim H0; intros.
+cut (Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n - s) 0).
+intro; unfold Un_cv in H3.
+elim (H3 eps H); intros N0 H4.
+exists N0; intros.
+apply Rle_lt_trans with (Rabs (sum_f_R0 (fun k:nat => Rabs (An k)) n - s)).
+rewrite <- (Rabs_Ropp (sum_f_R0 (fun k:nat => Rabs (An k)) n - s));
+ rewrite Ropp_minus_distr';
+ rewrite (Rabs_right (s - sum_f_R0 (fun k:nat => Rabs (An k)) n)).
+eapply sum_maj1.
+unfold SFL in |- *; case (cv y); intro.
+trivial.
+apply H1.
+intro; elim H0; intros.
+rewrite (Rabs_right (An n0)).
+apply H8; apply H6.
+apply Rle_ge; apply Rle_trans with (Rabs (fn n0 y)).
+apply Rabs_pos.
+apply H8; apply H6.
+apply Rle_ge;
+ apply Rplus_le_reg_l with (sum_f_R0 (fun k:nat => Rabs (An k)) n).
+rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm s);
+ rewrite <- Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_l;
+ apply sum_incr.
+apply H1.
+intro; apply Rabs_pos.
+unfold R_dist in H4; unfold Rminus in H4; rewrite Ropp_0 in H4.
+assert (H7 := H4 n H5).
+rewrite Rplus_0_r in H7; apply H7.
+unfold Un_cv in H1; unfold Un_cv in |- *; intros.
+elim (H1 _ H3); intros.
+exists x; intros.
+unfold R_dist in |- *; unfold R_dist in H4.
+rewrite Rminus_0_r; apply H4; assumption.
+Qed.
+
+(* Each limit of a sequence of functions which converges uniformly is continue *)
+Lemma CVU_continuity :
+ forall (fn:nat -> R -> R) (f:R -> R) (x:R) (r:posreal),
+   CVU fn f x r ->
+   (forall (n:nat) (y:R), Boule x r y -> continuity_pt (fn n) y) ->
+   forall y:R, Boule x r y -> continuity_pt f y.
+intros; unfold continuity_pt in |- *; unfold continue_in in |- *;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ simpl in |- *; unfold R_dist in |- *; intros.
+unfold CVU in H.
+cut (0 < eps / 3);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+elim (H _ H3); intros N0 H4.
+assert (H5 := H0 N0 y H1).
+cut (exists del : posreal, (forall h:R, Rabs h < del -> Boule x r (y + h))).
+intro.
+elim H6; intros del1 H7.
+unfold continuity_pt in H5; unfold continue_in in H5; unfold limit1_in in H5;
+ unfold limit_in in H5; simpl in H5; unfold R_dist in H5.
+elim (H5 _ H3); intros del2 H8.
+set (del := Rmin del1 del2).
+exists del; intros.
+split.
+unfold del in |- *; unfold Rmin in |- *; case (Rle_dec del1 del2); intro.
+apply (cond_pos del1).
+elim H8; intros; assumption.
+intros;
+ apply Rle_lt_trans with (Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - f y)).
+replace (f x0 - f y) with (f x0 - fn N0 x0 + (fn N0 x0 - f y));
+ [ apply Rabs_triang | ring ].
+apply Rle_lt_trans with
+ (Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - fn N0 y) + Rabs (fn N0 y - f y)).
+rewrite Rplus_assoc; apply Rplus_le_compat_l.
+replace (fn N0 x0 - f y) with (fn N0 x0 - fn N0 y + (fn N0 y - f y));
+ [ apply Rabs_triang | ring ].
+replace eps with (eps / 3 + eps / 3 + eps / 3).
+repeat apply Rplus_lt_compat.
+apply H4.
+apply le_n.
+replace x0 with (y + (x0 - y)); [ idtac | ring ]; apply H7.
+elim H9; intros.
+apply Rlt_le_trans with del.
+assumption.
+unfold del in |- *; apply Rmin_l.
+elim H8; intros.
+apply H11.
+split.
+elim H9; intros; assumption.
+elim H9; intros; apply Rlt_le_trans with del.
+assumption.
+unfold del in |- *; apply Rmin_r.
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H4.
+apply le_n.
+assumption.
+apply Rmult_eq_reg_l with 3.
+do 2 rewrite Rmult_plus_distr_l; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
+ rewrite Rinv_r_simpl_m.
+ring.
+discrR.
+discrR.
+cut (0 < r - Rabs (x - y)).
+intro; exists (mkposreal _ H6).
+simpl in |- *; intros.
+unfold Boule in |- *; replace (y + h - x) with (h + (y - x));
+ [ idtac | ring ]; apply Rle_lt_trans with (Rabs h + Rabs (y - x)).
+apply Rabs_triang.
+apply Rplus_lt_reg_r with (- Rabs (x - y)).
+rewrite <- (Rabs_Ropp (y - x)); rewrite Ropp_minus_distr'.
+replace (- Rabs (x - y) + r) with (r - Rabs (x - y)).
+replace (- Rabs (x - y) + (Rabs h + Rabs (x - y))) with (Rabs h).
+apply H7.
+ring.
+ring.
+unfold Boule in H1; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr';
+ apply Rplus_lt_reg_r with (Rabs (y - x)).
+rewrite Rplus_0_r; replace (Rabs (y - x) + (r - Rabs (y - x))) with (pos r);
+ [ apply H1 | ring ].
+Qed.
+
+(**********)
+Lemma continuity_pt_finite_SF :
+ forall (fn:nat -> R -> R) (N:nat) (x:R),
+   (forall n:nat, (n <= N)%nat -> continuity_pt (fn n) x) ->
+   continuity_pt (fun y:R => sum_f_R0 (fun k:nat => fn k y) N) x.
+intros; induction  N as [| N HrecN].
+simpl in |- *; apply (H 0%nat); apply le_n.
+simpl in |- *;
+ replace (fun y:R => sum_f_R0 (fun k:nat => fn k y) N + fn (S N) y) with
+  ((fun y:R => sum_f_R0 (fun k:nat => fn k y) N) + (fun y:R => fn (S N) y))%F;
+ [ idtac | reflexivity ].
+apply continuity_pt_plus.
+apply HrecN.
+intros; apply H.
+apply le_trans with N; [ assumption | apply le_n_Sn ].
+apply (H (S N)); apply le_n.
+Qed.
+
+(* Continuity and normal convergence *)
+Lemma SFL_continuity_pt :
+ forall (fn:nat -> R -> R)
+   (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l))
+   (r:posreal),
+   CVN_r fn r ->
+   (forall (n:nat) (y:R), Boule 0 r y -> continuity_pt (fn n) y) ->
+   forall y:R, Boule 0 r y -> continuity_pt (SFL fn cv) y.
+intros; eapply CVU_continuity.
+apply CVN_CVU.
+apply X.
+intros; unfold SP in |- *; apply continuity_pt_finite_SF.
+intros; apply H.
+apply H1.
+apply H0.
+Qed.
+
+Lemma SFL_continuity :
+ forall (fn:nat -> R -> R)
+   (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)),
+   CVN_R fn -> (forall n:nat, continuity (fn n)) -> continuity (SFL fn cv).
+intros; unfold continuity in |- *; intro.
+cut (0 < Rabs x + 1);
+ [ intro | apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ] ].
+cut (Boule 0 (mkposreal _ H0) x).
+intro; eapply SFL_continuity_pt with (mkposreal _ H0).
+apply X.
+intros; apply (H n y).
+apply H1.
+unfold Boule in |- *; simpl in |- *; rewrite Rminus_0_r;
+ pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; 
+ apply Rplus_lt_compat_l; apply Rlt_0_1.
+Qed.
+
+(* As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *) 
+Lemma CVN_R_CVS :
+ forall fn:nat -> R -> R,
+   CVN_R fn -> forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l).
+intros; apply R_complete.
+unfold SP in |- *; set (An := fun N:nat => fn N x).
+change (Cauchy_crit_series An) in |- *.
+apply cauchy_abs.
+unfold Cauchy_crit_series in |- *; apply CV_Cauchy.
+unfold CVN_R in X; cut (0 < Rabs x + 1).
+intro; assert (H0 := X (mkposreal _ H)).
+unfold CVN_r in H0; elim H0; intros Bn H1.
+elim H1; intros l H2.
+elim H2; intros.
+apply Rseries_CV_comp with Bn.
+intro; split.
+apply Rabs_pos.
+unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *;
+ rewrite Rminus_0_r.
+pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+ apply Rlt_0_1.
+apply existT with l.
+cut (forall n:nat, 0 <= Bn n).
+intro; unfold Un_cv in H3; unfold Un_cv in |- *; intros.
+elim (H3 _ H6); intros.
+exists x0; intros.
+replace (sum_f_R0 Bn n) with (sum_f_R0 (fun k:nat => Rabs (Bn k)) n).
+apply H7; assumption.
+apply sum_eq; intros; apply Rabs_right; apply Rle_ge; apply H5.
+intro; apply Rle_trans with (Rabs (An n)).
+apply Rabs_pos.
+unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *;
+ rewrite Rminus_0_r; pattern (Rabs x) at 1 in |- *; 
+ rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1.
+apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ].
+Qed.
diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v
new file mode 100644
index 00000000..13070bde
--- /dev/null
+++ b/theories/Reals/PartSum.v
@@ -0,0 +1,603 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: PartSum.v,v 1.11.2.1 2004/07/16 19:31:11 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import Rcomplete.
+Require Import Max.
+Open Local Scope R_scope.
+
+Lemma tech1 :
+ forall (An:nat -> R) (N:nat),
+   (forall n:nat, (n <= N)%nat -> 0 < An n) -> 0 < sum_f_R0 An N.
+intros; induction  N as [| N HrecN].
+simpl in |- *; apply H; apply le_n.
+simpl in |- *; apply Rplus_lt_0_compat.
+apply HrecN; intros; apply H; apply le_S; assumption.
+apply H; apply le_n.
+Qed.
+
+(* Chasles' relation *)
+Lemma tech2 :
+ forall (An:nat -> R) (m n:nat),
+   (m < n)%nat ->
+   sum_f_R0 An n =
+   sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m). 
+intros; induction  n as [| n Hrecn].
+elim (lt_n_O _ H).
+cut ((m < n)%nat \/ m = n).
+intro; elim H0; intro.
+replace (sum_f_R0 An (S n)) with (sum_f_R0 An n + An (S n));
+ [ idtac | reflexivity ].
+replace (S n - S m)%nat with (S (n - S m)).
+replace (sum_f_R0 (fun i:nat => An (S m + i)%nat) (S (n - S m))) with
+ (sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m) +
+  An (S m + S (n - S m))%nat); [ idtac | reflexivity ].
+replace (S m + S (n - S m))%nat with (S n).
+rewrite (Hrecn H1).
+ring.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite S_INR;
+ rewrite minus_INR.
+rewrite S_INR; ring.
+apply lt_le_S; assumption.
+apply INR_eq; rewrite S_INR; repeat rewrite minus_INR.
+repeat rewrite S_INR; ring.
+apply le_n_S; apply lt_le_weak; assumption.
+apply lt_le_S; assumption.
+rewrite H1; rewrite <- minus_n_n; simpl in |- *.
+replace (n + 0)%nat with n; [ reflexivity | ring ].
+inversion H.
+right; reflexivity.
+left; apply lt_le_trans with (S m); [ apply lt_n_Sn | assumption ].
+Qed.
+
+(* Sum of geometric sequences *)
+Lemma tech3 :
+ forall (k:R) (N:nat),
+   k <> 1 -> sum_f_R0 (fun i:nat => k ^ i) N = (1 - k ^ S N) / (1 - k).
+intros; cut (1 - k <> 0).
+intro; induction  N as [| N HrecN].
+simpl in |- *; rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym.
+reflexivity.
+apply H0.
+replace (sum_f_R0 (fun i:nat => k ^ i) (S N)) with
+ (sum_f_R0 (fun i:nat => k ^ i) N + k ^ S N); [ idtac | reflexivity ];
+ rewrite HrecN;
+ replace ((1 - k ^ S N) / (1 - k) + k ^ S N) with
+  ((1 - k ^ S N + (1 - k) * k ^ S N) / (1 - k)).
+apply Rmult_eq_reg_l with (1 - k).
+unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ (1 - k)));
+ repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+ [ do 2 rewrite Rmult_1_l; simpl in |- *; ring | apply H0 ].
+apply H0.
+unfold Rdiv in |- *; rewrite Rmult_plus_distr_r; rewrite (Rmult_comm (1 - k));
+ repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; reflexivity.
+apply H0.
+apply Rminus_eq_contra; red in |- *; intro; elim H; symmetry  in |- *;
+ assumption.
+Qed.
+
+Lemma tech4 :
+ forall (An:nat -> R) (k:R) (N:nat),
+   0 <= k -> (forall i:nat, An (S i) < k * An i) -> An N <= An 0%nat * k ^ N.
+intros; induction  N as [| N HrecN].
+simpl in |- *; right; ring.
+apply Rle_trans with (k * An N).
+left; apply (H0 N).
+replace (S N) with (N + 1)%nat; [ idtac | ring ].
+rewrite pow_add; simpl in |- *; rewrite Rmult_1_r;
+ replace (An 0%nat * (k ^ N * k)) with (k * (An 0%nat * k ^ N));
+ [ idtac | ring ]; apply Rmult_le_compat_l.
+assumption.
+apply HrecN.
+Qed.
+
+Lemma tech5 :
+ forall (An:nat -> R) (N:nat), sum_f_R0 An (S N) = sum_f_R0 An N + An (S N).
+intros; reflexivity.
+Qed.
+
+Lemma tech6 :
+ forall (An:nat -> R) (k:R) (N:nat),
+   0 <= k ->
+   (forall i:nat, An (S i) < k * An i) ->
+   sum_f_R0 An N <= An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N.
+intros; induction  N as [| N HrecN].
+simpl in |- *; right; ring.
+apply Rle_trans with (An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N + An (S N)).
+rewrite tech5; do 2 rewrite <- (Rplus_comm (An (S N)));
+ apply Rplus_le_compat_l.
+apply HrecN.
+rewrite tech5; rewrite Rmult_plus_distr_l; apply Rplus_le_compat_l.
+apply tech4; assumption.
+Qed.
+
+Lemma tech7 : forall r1 r2:R, r1 <> 0 -> r2 <> 0 -> r1 <> r2 -> / r1 <> / r2.
+intros; red in |- *; intro.
+assert (H3 := Rmult_eq_compat_l r1 _ _ H2).
+rewrite <- Rinv_r_sym in H3; [ idtac | assumption ].
+assert (H4 := Rmult_eq_compat_l r2 _ _ H3).
+rewrite Rmult_1_r in H4; rewrite <- Rmult_assoc in H4.
+rewrite Rinv_r_simpl_m in H4; [ idtac | assumption ].
+elim H1; symmetry  in |- *; assumption.
+Qed.
+
+Lemma tech11 :
+ forall (An Bn Cn:nat -> R) (N:nat),
+   (forall i:nat, An i = Bn i - Cn i) ->
+   sum_f_R0 An N = sum_f_R0 Bn N - sum_f_R0 Cn N.
+intros; induction  N as [| N HrecN].
+simpl in |- *; apply H.
+do 3 rewrite tech5; rewrite HrecN; rewrite (H (S N)); ring.
+Qed.
+
+Lemma tech12 :
+ forall (An:nat -> R) (x l:R),
+   Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l ->
+   Pser An x l.
+intros; unfold Pser in |- *; unfold infinit_sum in |- *; unfold Un_cv in H;
+ assumption.
+Qed. 
+
+Lemma scal_sum :
+ forall (An:nat -> R) (N:nat) (x:R),
+   x * sum_f_R0 An N = sum_f_R0 (fun i:nat => An i * x) N.
+intros; induction  N as [| N HrecN].
+simpl in |- *; ring.
+do 2 rewrite tech5.
+rewrite Rmult_plus_distr_l; rewrite <- HrecN; ring.
+Qed.
+
+Lemma decomp_sum :
+ forall (An:nat -> R) (N:nat),
+   (0 < N)%nat ->
+   sum_f_R0 An N = An 0%nat + sum_f_R0 (fun i:nat => An (S i)) (pred N).
+intros; induction  N as [| N HrecN].
+elim (lt_irrefl _ H).
+cut ((0 < N)%nat \/ N = 0%nat).
+intro; elim H0; intro.
+cut (S (pred N) = pred (S N)).
+intro; rewrite <- H2.
+do 2 rewrite tech5.
+replace (S (S (pred N))) with (S N).
+rewrite (HrecN H1); ring.
+rewrite H2; simpl in |- *; reflexivity.
+assert (H2 := O_or_S N).
+elim H2; intros.
+elim a; intros.
+rewrite <- p.
+simpl in |- *; reflexivity.
+rewrite <- b in H1; elim (lt_irrefl _ H1).
+rewrite H1; simpl in |- *; reflexivity.
+inversion H.
+right; reflexivity.
+left; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
+Qed.
+
+Lemma plus_sum :
+ forall (An Bn:nat -> R) (N:nat),
+   sum_f_R0 (fun i:nat => An i + Bn i) N = sum_f_R0 An N + sum_f_R0 Bn N.
+intros; induction  N as [| N HrecN].
+simpl in |- *; ring.
+do 3 rewrite tech5; rewrite HrecN; ring.
+Qed.
+
+Lemma sum_eq :
+ forall (An Bn:nat -> R) (N:nat),
+   (forall i:nat, (i <= N)%nat -> An i = Bn i) ->
+   sum_f_R0 An N = sum_f_R0 Bn N.
+intros; induction  N as [| N HrecN].
+simpl in |- *; apply H; apply le_n.
+do 2 rewrite tech5; rewrite HrecN.
+rewrite (H (S N)); [ reflexivity | apply le_n ].
+intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ].
+Qed.
+
+(* Unicity of the limit defined by convergent series *)
+Lemma uniqueness_sum :
+ forall (An:nat -> R) (l1 l2:R),
+   infinit_sum An l1 -> infinit_sum An l2 -> l1 = l2.
+unfold infinit_sum in |- *; intros.
+case (Req_dec l1 l2); intro.
+assumption.
+cut (0 < Rabs ((l1 - l2) / 2)); [ intro | apply Rabs_pos_lt ].
+elim (H (Rabs ((l1 - l2) / 2)) H2); intros.
+elim (H0 (Rabs ((l1 - l2) / 2)) H2); intros.
+set (N := max x0 x); cut (N >= x0)%nat.
+cut (N >= x)%nat.
+intros; assert (H7 := H3 N H5); assert (H8 := H4 N H6).
+cut (Rabs (l1 - l2) <= R_dist (sum_f_R0 An N) l1 + R_dist (sum_f_R0 An N) l2).
+intro; assert (H10 := Rplus_lt_compat _ _ _ _ H7 H8);
+ assert (H11 := Rle_lt_trans _ _ _ H9 H10); unfold Rdiv in H11;
+ rewrite Rabs_mult in H11.
+cut (Rabs (/ 2) = / 2).
+intro; rewrite H12 in H11; assert (H13 := double_var); unfold Rdiv in H13;
+ rewrite <- H13 in H11.
+elim (Rlt_irrefl _ H11).
+apply Rabs_right; left; change (0 < / 2) in |- *; apply Rinv_0_lt_compat;
+ cut (0%nat <> 2%nat);
+ [ intro H20; generalize (lt_INR_0 2 (neq_O_lt 2 H20)); unfold INR in |- *;
+    intro; assumption
+ | discriminate ].
+unfold R_dist in |- *; rewrite <- (Rabs_Ropp (sum_f_R0 An N - l1));
+ rewrite Ropp_minus_distr'.
+replace (l1 - l2) with (l1 - sum_f_R0 An N + (sum_f_R0 An N - l2));
+ [ idtac | ring ].
+apply Rabs_triang.
+unfold ge in |- *; unfold N in |- *; apply le_max_r.
+unfold ge in |- *; unfold N in |- *; apply le_max_l.
+unfold Rdiv in |- *; apply prod_neq_R0.
+apply Rminus_eq_contra; assumption.
+apply Rinv_neq_0_compat; discrR.
+Qed.
+
+Lemma minus_sum :
+ forall (An Bn:nat -> R) (N:nat),
+   sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N. 
+intros; induction  N as [| N HrecN]. 
+simpl in |- *; ring. 
+do 3 rewrite tech5; rewrite HrecN; ring. 
+Qed. 
+
+Lemma sum_decomposition :
+ forall (An:nat -> R) (N:nat),
+   sum_f_R0 (fun l:nat => An (2 * l)%nat) (S N) +
+   sum_f_R0 (fun l:nat => An (S (2 * l))) N = sum_f_R0 An (2 * S N).
+intros.
+induction  N as [| N HrecN].
+simpl in |- *; ring.
+rewrite tech5.
+rewrite (tech5 (fun l:nat => An (S (2 * l))) N).
+replace (2 * S (S N))%nat with (S (S (2 * S N))).
+rewrite (tech5 An (S (2 * S N))).
+rewrite (tech5 An (2 * S N)).
+rewrite <- HrecN.
+ring.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR.
+ring.
+Qed.
+
+Lemma sum_Rle :
+ forall (An Bn:nat -> R) (N:nat),
+   (forall n:nat, (n <= N)%nat -> An n <= Bn n) ->
+   sum_f_R0 An N <= sum_f_R0 Bn N.
+intros.
+induction  N as [| N HrecN].
+simpl in |- *; apply H.
+apply le_n.
+do 2 rewrite tech5.
+apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
+apply Rplus_le_compat_l.
+apply H.
+apply le_n.
+do 2 rewrite <- (Rplus_comm (Bn (S N))).
+apply Rplus_le_compat_l.
+apply HrecN.
+intros; apply H.
+apply le_trans with N; [ assumption | apply le_n_Sn ].
+Qed.
+
+Lemma Rsum_abs :
+ forall (An:nat -> R) (N:nat),
+   Rabs (sum_f_R0 An N) <= sum_f_R0 (fun l:nat => Rabs (An l)) N.
+intros.
+induction  N as [| N HrecN].
+simpl in |- *.
+right; reflexivity.
+do 2 rewrite tech5.
+apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
+apply Rabs_triang.
+do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
+apply Rplus_le_compat_l.
+apply HrecN.
+Qed.
+
+Lemma sum_cte :
+ forall (x:R) (N:nat), sum_f_R0 (fun _:nat => x) N = x * INR (S N).
+intros.
+induction  N as [| N HrecN].
+simpl in |- *; ring.
+rewrite tech5.
+rewrite HrecN; repeat rewrite S_INR; ring.
+Qed.
+
+(**********)
+Lemma sum_growing :
+ forall (An Bn:nat -> R) (N:nat),
+   (forall n:nat, An n <= Bn n) -> sum_f_R0 An N <= sum_f_R0 Bn N.
+intros.
+induction  N as [| N HrecN].
+simpl in |- *; apply H.
+do 2 rewrite tech5.
+apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
+apply Rplus_le_compat_l; apply H.
+do 2 rewrite <- (Rplus_comm (Bn (S N))).
+apply Rplus_le_compat_l; apply HrecN.
+Qed.
+
+(**********)
+Lemma Rabs_triang_gen :
+ forall (An:nat -> R) (N:nat),
+   Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N. 
+intros.
+induction  N as [| N HrecN].
+simpl in |- *.
+right; reflexivity.
+do 2 rewrite tech5.
+apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
+apply Rabs_triang.
+do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
+apply Rplus_le_compat_l; apply HrecN.
+Qed.
+
+(**********)
+Lemma cond_pos_sum :
+ forall (An:nat -> R) (N:nat),
+   (forall n:nat, 0 <= An n) -> 0 <= sum_f_R0 An N.
+intros.
+induction  N as [| N HrecN].
+simpl in |- *; apply H.
+rewrite tech5.
+apply Rplus_le_le_0_compat.
+apply HrecN.
+apply H.
+Qed.
+
+(* Cauchy's criterion for series *)
+Definition Cauchy_crit_series (An:nat -> R) : Prop :=
+  Cauchy_crit (fun N:nat => sum_f_R0 An N).
+
+(* If (|An|) satisfies the Cauchy's criterion for series, then (An) too *)
+Lemma cauchy_abs :
+ forall An:nat -> R,
+   Cauchy_crit_series (fun i:nat => Rabs (An i)) -> Cauchy_crit_series An.
+unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
+intros.
+elim (H eps H0); intros.
+exists x.
+intros.
+cut
+ (R_dist (sum_f_R0 An n) (sum_f_R0 An m) <=
+  R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
+    (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
+intro.
+apply Rle_lt_trans with
+ (R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
+    (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
+assumption.
+apply H1; assumption.
+assert (H4 := lt_eq_lt_dec n m).
+elim H4; intro.
+elim a; intro.
+rewrite (tech2 An n m); [ idtac | assumption ].
+rewrite (tech2 (fun i:nat => Rabs (An i)) n m); [ idtac | assumption ].
+unfold R_dist in |- *.
+unfold Rminus in |- *.
+do 2 rewrite Ropp_plus_distr.
+do 2 rewrite <- Rplus_assoc.
+do 2 rewrite Rplus_opp_r.
+do 2 rewrite Rplus_0_l.
+do 2 rewrite Rabs_Ropp.
+rewrite
+ (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S n + i)%nat)) (m - S n)))
+ .
+set (Bn := fun i:nat => An (S n + i)%nat).
+replace (fun i:nat => Rabs (An (S n + i)%nat)) with
+ (fun i:nat => Rabs (Bn i)).
+apply Rabs_triang_gen.
+unfold Bn in |- *; reflexivity.
+apply Rle_ge.
+apply cond_pos_sum.
+intro; apply Rabs_pos.
+rewrite b.
+unfold R_dist in |- *.
+unfold Rminus in |- *; do 2 rewrite Rplus_opp_r.
+rewrite Rabs_R0; right; reflexivity.
+rewrite (tech2 An m n); [ idtac | assumption ].
+rewrite (tech2 (fun i:nat => Rabs (An i)) m n); [ idtac | assumption ].
+unfold R_dist in |- *.
+unfold Rminus in |- *.
+do 2 rewrite Rplus_assoc.
+rewrite (Rplus_comm (sum_f_R0 An m)).
+rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
+do 2 rewrite Rplus_assoc.
+do 2 rewrite Rplus_opp_l.
+do 2 rewrite Rplus_0_r.
+rewrite
+ (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S m + i)%nat)) (n - S m)))
+ .
+set (Bn := fun i:nat => An (S m + i)%nat).
+replace (fun i:nat => Rabs (An (S m + i)%nat)) with
+ (fun i:nat => Rabs (Bn i)).
+apply Rabs_triang_gen.
+unfold Bn in |- *; reflexivity.
+apply Rle_ge.
+apply cond_pos_sum.
+intro; apply Rabs_pos.
+Qed.
+
+(**********)
+Lemma cv_cauchy_1 :
+ forall An:nat -> R,
+   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l) ->
+   Cauchy_crit_series An.
+intros.
+elim X; intros.
+unfold Un_cv in p.
+unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
+intros.
+cut (0 < eps / 2).
+intro.
+elim (p (eps / 2) H0); intros.
+exists x0.
+intros.
+apply Rle_lt_trans with (R_dist (sum_f_R0 An n) x + R_dist (sum_f_R0 An m) x).
+unfold R_dist in |- *.
+replace (sum_f_R0 An n - sum_f_R0 An m) with
+ (sum_f_R0 An n - x + - (sum_f_R0 An m - x)); [ idtac | ring ].
+rewrite <- (Rabs_Ropp (sum_f_R0 An m - x)).
+apply Rabs_triang.
+apply Rlt_le_trans with (eps / 2 + eps / 2).
+apply Rplus_lt_compat.
+apply H1; assumption.
+apply H1; assumption.
+right; symmetry  in |- *; apply double_var.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+Qed.
+
+Lemma cv_cauchy_2 :
+ forall An:nat -> R,
+   Cauchy_crit_series An ->
+   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+intros.
+apply R_complete.
+unfold Cauchy_crit_series in H.
+exact H.
+Qed.
+
+(**********)
+Lemma sum_eq_R0 :
+ forall (An:nat -> R) (N:nat),
+   (forall n:nat, (n <= N)%nat -> An n = 0) -> sum_f_R0 An N = 0.
+intros; induction  N as [| N HrecN].
+simpl in |- *; apply H; apply le_n.
+rewrite tech5; rewrite HrecN;
+ [ rewrite Rplus_0_l; apply H; apply le_n
+ | intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ] ].
+Qed.
+
+Definition SP (fn:nat -> R -> R) (N:nat) (x:R) : R :=
+  sum_f_R0 (fun k:nat => fn k x) N.
+
+(**********)
+Lemma sum_incr :
+ forall (An:nat -> R) (N:nat) (l:R),
+   Un_cv (fun n:nat => sum_f_R0 An n) l ->
+   (forall n:nat, 0 <= An n) -> sum_f_R0 An N <= l.
+intros; case (total_order_T (sum_f_R0 An N) l); intro.
+elim s; intro.
+left; apply a.
+right; apply b.
+cut (Un_growing (fun n:nat => sum_f_R0 An n)).
+intro; set (l1 := sum_f_R0 An N).
+fold l1 in r.
+unfold Un_cv in H; cut (0 < l1 - l).
+intro; elim (H _ H2); intros.
+set (N0 := max x N); cut (N0 >= x)%nat.
+intro; assert (H5 := H3 N0 H4).
+cut (l1 <= sum_f_R0 An N0).
+intro; unfold R_dist in H5; rewrite Rabs_right in H5.
+cut (sum_f_R0 An N0 < l1).
+intro; elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H7 H6)).
+apply Rplus_lt_reg_r with (- l).
+do 2 rewrite (Rplus_comm (- l)).
+apply H5.
+apply Rle_ge; apply Rplus_le_reg_l with l.
+rewrite Rplus_0_r; replace (l + (sum_f_R0 An N0 - l)) with (sum_f_R0 An N0);
+ [ idtac | ring ]; apply Rle_trans with l1.
+left; apply r.
+apply H6.
+unfold l1 in |- *; apply Rge_le;
+ apply (growing_prop (fun k:nat => sum_f_R0 An k)).
+apply H1.
+unfold ge, N0 in |- *; apply le_max_r.
+unfold ge, N0 in |- *; apply le_max_l.
+apply Rplus_lt_reg_r with l; rewrite Rplus_0_r;
+ replace (l + (l1 - l)) with l1; [ apply r | ring ].
+unfold Un_growing in |- *; intro; simpl in |- *;
+ pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_le_compat_l; apply H0.
+Qed.
+
+(**********)
+Lemma sum_cv_maj :
+ forall (An:nat -> R) (fn:nat -> R -> R) (x l1 l2:R),
+   Un_cv (fun n:nat => SP fn n x) l1 ->
+   Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
+   (forall n:nat, Rabs (fn n x) <= An n) -> Rabs l1 <= l2.
+intros; case (total_order_T (Rabs l1) l2); intro.
+elim s; intro.
+left; apply a.
+right; apply b.
+cut (forall n0:nat, Rabs (SP fn n0 x) <= sum_f_R0 An n0).
+intro; cut (0 < (Rabs l1 - l2) / 2).
+intro; unfold Un_cv in H, H0.
+elim (H _ H3); intros Na H4.
+elim (H0 _ H3); intros Nb H5.
+set (N := max Na Nb).
+unfold R_dist in H4, H5.
+cut (Rabs (sum_f_R0 An N - l2) < (Rabs l1 - l2) / 2).
+intro; cut (Rabs (Rabs l1 - Rabs (SP fn N x)) < (Rabs l1 - l2) / 2).
+intro; cut (sum_f_R0 An N < (Rabs l1 + l2) / 2).
+intro; cut ((Rabs l1 + l2) / 2 < Rabs (SP fn N x)).
+intro; cut (sum_f_R0 An N < Rabs (SP fn N x)).
+intro; assert (H11 := H2 N).
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H10)).
+apply Rlt_trans with ((Rabs l1 + l2) / 2); assumption.
+case (Rcase_abs (Rabs l1 - Rabs (SP fn N x))); intro.
+apply Rlt_trans with (Rabs l1).
+apply Rmult_lt_reg_l with 2.
+prove_sup0.
+unfold Rdiv in |- *; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply r.
+discrR.
+apply (Rminus_lt _ _ r0).
+rewrite (Rabs_right _ r0) in H7.
+apply Rplus_lt_reg_r with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)).
+replace ((Rabs l1 - l2) / 2 - Rabs (SP fn N x) + (Rabs l1 + l2) / 2) with
+ (Rabs l1 - Rabs (SP fn N x)).
+unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+ rewrite Rplus_0_r; apply H7.
+unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
+ rewrite <- (Rmult_comm (/ 2)); rewrite Rmult_minus_distr_l;
+ repeat rewrite (Rmult_comm (/ 2)); pattern (Rabs l1) at 1 in |- *;
+ rewrite double_var; unfold Rdiv in |- *; ring.
+case (Rcase_abs (sum_f_R0 An N - l2)); intro.
+apply Rlt_trans with l2.
+apply (Rminus_lt _ _ r0).
+apply Rmult_lt_reg_l with 2.
+prove_sup0.
+rewrite (double l2); unfold Rdiv in |- *; rewrite (Rmult_comm 2);
+ rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; rewrite (Rplus_comm (Rabs l1)); apply Rplus_lt_compat_l;
+ apply r.
+discrR.
+rewrite (Rabs_right _ r0) in H6; apply Rplus_lt_reg_r with (- l2).
+replace (- l2 + (Rabs l1 + l2) / 2) with ((Rabs l1 - l2) / 2).
+rewrite Rplus_comm; apply H6.
+unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+ rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_r;
+ pattern l2 at 2 in |- *; rewrite double_var;
+ repeat rewrite (Rmult_comm (/ 2)); rewrite Ropp_plus_distr;
+ unfold Rdiv in |- *; ring.
+apply Rle_lt_trans with (Rabs (SP fn N x - l1)).
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply Rabs_triang_inv2.
+apply H4; unfold ge, N in |- *; apply le_max_l.
+apply H5; unfold ge, N in |- *; apply le_max_r.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply Rplus_lt_reg_r with l2.
+rewrite Rplus_0_r; replace (l2 + (Rabs l1 - l2)) with (Rabs l1);
+ [ apply r | ring ].
+apply Rinv_0_lt_compat; prove_sup0.
+intros; induction  n0 as [| n0 Hrecn0].
+unfold SP in |- *; simpl in |- *; apply H1.
+unfold SP in |- *; simpl in |- *.
+apply Rle_trans with
+ (Rabs (sum_f_R0 (fun k:nat => fn k x) n0) + Rabs (fn (S n0) x)).
+apply Rabs_triang.
+apply Rle_trans with (sum_f_R0 An n0 + Rabs (fn (S n0) x)).
+do 2 rewrite <- (Rplus_comm (Rabs (fn (S n0) x))).
+apply Rplus_le_compat_l; apply Hrecn0.
+apply Rplus_le_compat_l; apply H1.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v
new file mode 100644
index 00000000..a23f53ff
--- /dev/null
+++ b/theories/Reals/RIneq.v
@@ -0,0 +1,1631 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: RIneq.v,v 1.23.2.1 2004/07/16 19:31:11 herbelin Exp $ i*)
+
+(***************************************************************************)
+(**              Basic lemmas for the classical reals numbers              *)
+(***************************************************************************)
+
+Require Export Raxioms.
+Require Export ZArithRing.
+Require Import Omega.
+Require Export Field.
+
+Open Local Scope Z_scope.
+Open Local Scope R_scope.
+
+Implicit Type r : R.
+
+(***************************************************************************)
+(**       Instantiating Ring tactic on reals                               *)
+(***************************************************************************)
+
+Lemma RTheory : Ring_Theory Rplus Rmult 1 0 Ropp (fun x y:R => false).
+  split.
+  exact Rplus_comm.
+  symmetry  in |- *; apply Rplus_assoc.
+  exact Rmult_comm.
+  symmetry  in |- *; apply Rmult_assoc.
+  intro; apply Rplus_0_l.
+  intro; apply Rmult_1_l.
+  exact Rplus_opp_r.
+  intros.
+  rewrite Rmult_comm.
+  rewrite (Rmult_comm n p).
+  rewrite (Rmult_comm m p).
+  apply Rmult_plus_distr_l.
+  intros; contradiction.
+Defined.
+
+Add Field R Rplus Rmult 1 0 Ropp (fun x y:R => false) Rinv RTheory Rinv_l
+ with minus := Rminus div := Rdiv.
+
+(**************************************************************************)
+(**  Relation between orders and equality                                 *)
+(**************************************************************************)
+
+(**********)
+Lemma Rlt_irrefl : forall r, ~ r < r.
+  generalize Rlt_asym. intuition eauto.
+Qed.
+Hint Resolve Rlt_irrefl: real.
+
+Lemma Rle_refl : forall r, r <= r.
+intro; right; reflexivity.
+Qed.
+
+Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> r1 <> r2.
+  red in |- *; intros r1 r2 H H0; apply (Rlt_irrefl r1).
+  pattern r1 at 2 in |- *; rewrite H0; trivial.
+Qed.
+
+Lemma Rgt_not_eq : forall r1 r2, r1 > r2 -> r1 <> r2.
+intros; apply sym_not_eq; apply Rlt_not_eq; auto with real.
+Qed.
+
+(**********)
+Lemma Rlt_dichotomy_converse : forall r1 r2, r1 < r2 \/ r1 > r2 -> r1 <> r2.
+generalize Rlt_not_eq Rgt_not_eq. intuition eauto.
+Qed.
+Hint Resolve Rlt_dichotomy_converse: real.
+
+(** Reasoning by case on equalities and order *)
+
+(**********)
+Lemma Req_dec : forall r1 r2, r1 = r2 \/ r1 <> r2.
+intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse;
+ intuition eauto 3. 
+Qed.
+Hint Resolve Req_dec: real.
+
+(**********)
+Lemma Rtotal_order : forall r1 r2, r1 < r2 \/ r1 = r2 \/ r1 > r2.
+intros; generalize (total_order_T r1 r2); tauto.
+Qed.
+
+(**********)
+Lemma Rdichotomy : forall r1 r2, r1 <> r2 -> r1 < r2 \/ r1 > r2.
+intros; generalize (total_order_T r1 r2); tauto.
+Qed.
+
+
+(*********************************************************************************)
+(**       Order Lemma  : relating [<], [>], [<=] and [>=]  	                 *)
+(*********************************************************************************)
+
+(**********)
+Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2.
+intros; red in |- *; tauto.
+Qed.
+Hint Resolve Rlt_le: real.
+
+(**********)
+Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1.
+destruct 1; red in |- *; auto with real.
+Qed.
+
+Hint Immediate Rle_ge: real.
+
+(**********)
+Lemma Rge_le : forall r1 r2, r1 >= r2 -> r2 <= r1.
+destruct 1; red in |- *; auto with real.
+Qed.
+
+Hint Resolve Rge_le: real.
+
+(**********)
+Lemma Rnot_le_lt : forall r1 r2, ~ r1 <= r2 -> r2 < r1.
+intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rle in |- *; tauto.
+Qed.
+
+Hint Immediate Rnot_le_lt: real.
+
+Lemma Rnot_ge_lt : forall r1 r2, ~ r1 >= r2 -> r1 < r2.
+intros; apply Rnot_le_lt; auto with real.
+Qed.
+
+(**********)
+Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2.
+generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle in |- *.
+intuition eauto 3.
+Qed.
+
+Lemma Rgt_not_le : forall r1 r2, r1 > r2 -> ~ r1 <= r2.
+Proof Rlt_not_le.
+
+Hint Immediate Rlt_not_le: real.
+
+Lemma Rle_not_lt : forall r1 r2, r2 <= r1 -> ~ r1 < r2.
+intros r1 r2. generalize (Rlt_asym r1 r2) (Rlt_dichotomy_converse r1 r2).
+unfold Rle in |- *; intuition.
+Qed.
+
+(**********)
+Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2.
+generalize Rlt_not_le. unfold Rle, Rge in |- *. intuition eauto 3.
+Qed.
+
+Hint Immediate Rlt_not_ge: real.
+
+(**********)
+Lemma Req_le : forall r1 r2, r1 = r2 -> r1 <= r2.
+unfold Rle in |- *; tauto.
+Qed.
+Hint Immediate Req_le: real.
+
+Lemma Req_ge : forall r1 r2, r1 = r2 -> r1 >= r2.
+unfold Rge in |- *; tauto.
+Qed.
+Hint Immediate Req_ge: real.
+
+Lemma Req_le_sym : forall r1 r2, r2 = r1 -> r1 <= r2.
+unfold Rle in |- *; auto.
+Qed.
+Hint Immediate Req_le_sym: real.
+
+Lemma Req_ge_sym : forall r1 r2, r2 = r1 -> r1 >= r2.
+unfold Rge in |- *; auto.
+Qed.
+Hint Immediate Req_ge_sym: real.
+
+Lemma Rle_antisym : forall r1 r2, r1 <= r2 -> r2 <= r1 -> r1 = r2.
+intros r1 r2; generalize (Rlt_asym r1 r2); unfold Rle in |- *; intuition.
+Qed.
+Hint Resolve Rle_antisym: real.
+
+(**********)
+Lemma Rle_le_eq : forall r1 r2, r1 <= r2 /\ r2 <= r1 <-> r1 = r2.
+intuition.
+Qed.
+
+Lemma Rlt_eq_compat :
+ forall r1 r2 r3 r4, r1 = r2 -> r2 < r4 -> r4 = r3 -> r1 < r3.
+intros x x' y y'; intros; replace x with x'; replace y with y'; assumption.
+Qed.
+
+(**********)
+Lemma Rle_trans : forall r1 r2 r3, r1 <= r2 -> r2 <= r3 -> r1 <= r3.
+generalize trans_eq Rlt_trans Rlt_eq_compat.
+unfold Rle in |- *.
+intuition eauto 2.
+Qed.
+
+(**********)
+Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3.
+generalize Rlt_trans Rlt_eq_compat. 
+unfold Rle in |- *.
+intuition eauto 2.
+Qed.
+
+(**********)
+Lemma Rlt_le_trans : forall r1 r2 r3, r1 < r2 -> r2 <= r3 -> r1 < r3.
+generalize Rlt_trans Rlt_eq_compat; unfold Rle in |- *; intuition eauto 2.
+Qed.
+
+
+(** Decidability of the order *)
+Lemma Rlt_dec : forall r1 r2, {r1 < r2} + {~ r1 < r2}.
+intros; generalize (total_order_T r1 r2) (Rlt_dichotomy_converse r1 r2);
+ intuition.
+Qed.
+
+(**********)
+Lemma Rle_dec : forall r1 r2, {r1 <= r2} + {~ r1 <= r2}.
+intros r1 r2.
+generalize (total_order_T r1 r2) (Rlt_dichotomy_converse r1 r2).
+intuition eauto 4 with real.
+Qed.
+
+(**********)
+Lemma Rgt_dec : forall r1 r2, {r1 > r2} + {~ r1 > r2}.
+intros; unfold Rgt in |- *; intros; apply Rlt_dec.
+Qed.
+
+(**********)
+Lemma Rge_dec : forall r1 r2, {r1 >= r2} + {~ r1 >= r2}.
+intros; generalize (Rle_dec r2 r1); intuition.
+Qed.
+
+Lemma Rlt_le_dec : forall r1 r2, {r1 < r2} + {r2 <= r1}.
+intros; generalize (total_order_T r1 r2); intuition.
+Qed.
+
+Lemma Rle_or_lt : forall r1 r2, r1 <= r2 \/ r2 < r1.
+intros n m; elim (Rlt_le_dec m n); auto with real.
+Qed.
+
+Lemma Rle_lt_or_eq_dec : forall r1 r2, r1 <= r2 -> {r1 < r2} + {r1 = r2}.
+intros r1 r2 H; generalize (total_order_T r1 r2); intuition.
+Qed.
+
+(**********)
+Lemma inser_trans_R :
+ forall r1 r2 r3 r4, r1 <= r2 < r3 -> {r1 <= r2 < r4} + {r4 <= r2 < r3}.
+intros n m p q; intros; generalize (Rlt_le_dec m q); intuition.
+Qed.
+
+(****************************************************************)
+(**        Field Lemmas                                         *)
+(* This part contains lemma involving the Fields operations     *)
+(****************************************************************)
+(*********************************************************)
+(**      Addition                                        *)
+(*********************************************************)
+
+Lemma Rplus_ne : forall r, r + 0 = r /\ 0 + r = r.
+intro; split; ring.
+Qed.
+Hint Resolve Rplus_ne: real v62.
+
+Lemma Rplus_0_r : forall r, r + 0 = r.
+intro; ring.
+Qed.
+Hint Resolve Rplus_0_r: real.
+
+(**********)
+Lemma Rplus_opp_l : forall r, - r + r = 0.
+  intro; ring.
+Qed.
+Hint Resolve Rplus_opp_l: real.
+
+
+(**********)
+Lemma Rplus_opp_r_uniq : forall r1 r2, r1 + r2 = 0 -> r2 = - r1.
+  intros x y H; replace y with (- x + x + y);
+   [ rewrite Rplus_assoc; rewrite H; ring | ring ].
+Qed.
+
+(*i New i*)
+Hint Resolve (f_equal (A:=R)): real.
+
+Lemma Rplus_eq_compat_l : forall r r1 r2, r1 = r2 -> r + r1 = r + r2.
+  auto with real.
+Qed.
+
+(*i Old i*)Hint Resolve Rplus_eq_compat_l: v62.
+
+(**********)
+Lemma Rplus_eq_reg_l : forall r r1 r2, r + r1 = r + r2 -> r1 = r2.
+  intros; transitivity (- r + r + r1).
+  ring.
+  transitivity (- r + r + r2).
+  repeat rewrite Rplus_assoc; rewrite <- H; reflexivity.
+  ring.
+Qed.
+Hint Resolve Rplus_eq_reg_l: real.
+
+(**********)
+Lemma Rplus_0_r_uniq : forall r r1, r + r1 = r -> r1 = 0.
+  intros r b; pattern r at 2 in |- *; replace r with (r + 0); eauto with real.
+Qed.
+
+(***********************************************************)       
+(**       Multiplication                                   *)
+(***********************************************************)
+
+(**********)
+Lemma Rinv_r : forall r, r <> 0 -> r * / r = 1.
+  intros; rewrite Rmult_comm; auto with real.
+Qed.
+Hint Resolve Rinv_r: real.
+
+Lemma Rinv_l_sym : forall r, r <> 0 -> 1 = / r * r.
+  symmetry  in |- *; auto with real.
+Qed.
+
+Lemma Rinv_r_sym : forall r, r <> 0 -> 1 = r * / r.
+  symmetry  in |- *; auto with real.
+Qed.
+Hint Resolve Rinv_l_sym Rinv_r_sym: real.
+
+
+(**********)
+Lemma Rmult_0_r : forall r, r * 0 = 0.
+intro; ring.
+Qed.
+Hint Resolve Rmult_0_r: real v62.
+
+(**********)
+Lemma Rmult_0_l : forall r, 0 * r = 0.
+intro; ring.
+Qed.
+Hint Resolve Rmult_0_l: real v62.
+
+(**********)
+Lemma Rmult_ne : forall r, r * 1 = r /\ 1 * r = r.
+intro; split; ring.
+Qed.
+Hint Resolve Rmult_ne: real v62.
+
+(**********)
+Lemma Rmult_1_r : forall r, r * 1 = r.
+intro; ring.
+Qed.
+Hint Resolve Rmult_1_r: real.
+
+(**********)
+Lemma Rmult_eq_compat_l : forall r r1 r2, r1 = r2 -> r * r1 = r * r2.
+  auto with real.
+Qed.
+
+(*i OLD i*)Hint Resolve Rmult_eq_compat_l: v62.
+
+(**********)
+Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 = r * r2 -> r <> 0 -> r1 = r2.
+  intros; transitivity (/ r * r * r1).
+  rewrite Rinv_l; auto with real.
+  transitivity (/ r * r * r2).
+  repeat rewrite Rmult_assoc; rewrite H; trivial.
+  rewrite Rinv_l; auto with real.
+Qed.
+
+(**********)
+Lemma Rmult_integral : forall r1 r2, r1 * r2 = 0 -> r1 = 0 \/ r2 = 0.
+  intros; case (Req_dec r1 0); [ intro Hz | intro Hnotz ].
+  auto.
+  right; apply Rmult_eq_reg_l with r1; trivial.
+  rewrite H; auto with real.
+Qed.
+
+(**********)
+Lemma Rmult_eq_0_compat : forall r1 r2, r1 = 0 \/ r2 = 0 -> r1 * r2 = 0.
+  intros r1 r2 [H| H]; rewrite H; auto with real.
+Qed.
+
+Hint Resolve Rmult_eq_0_compat: real.
+
+(**********)
+Lemma Rmult_eq_0_compat_r : forall r1 r2, r1 = 0 -> r1 * r2 = 0.
+  auto with real.
+Qed.
+
+(**********)
+Lemma Rmult_eq_0_compat_l : forall r1 r2, r2 = 0 -> r1 * r2 = 0.
+  auto with real.
+Qed.
+
+
+(**********) 
+Lemma Rmult_neq_0_reg : forall r1 r2, r1 * r2 <> 0 -> r1 <> 0 /\ r2 <> 0.
+intros r1 r2 H; split; red in |- *; intro; apply H; auto with real.
+Qed.
+
+(**********) 
+Lemma Rmult_integral_contrapositive :
+ forall r1 r2, r1 <> 0 /\ r2 <> 0 -> r1 * r2 <> 0.
+red in |- *; intros r1 r2 [H1 H2] H.
+case (Rmult_integral r1 r2); auto with real.
+Qed.
+Hint Resolve Rmult_integral_contrapositive: real.
+
+(**********) 
+Lemma Rmult_plus_distr_r :
+ forall r1 r2 r3, (r1 + r2) * r3 = r1 * r3 + r2 * r3.
+intros; ring.
+Qed.
+
+(** Square function *)
+
+(***********)
+Definition Rsqr r : R := r * r.
+
+(***********)
+Lemma Rsqr_0 : Rsqr 0 = 0.
+  unfold Rsqr in |- *; auto with real.
+Qed.
+
+(***********)
+Lemma Rsqr_0_uniq : forall r, Rsqr r = 0 -> r = 0.
+unfold Rsqr in |- *; intros; elim (Rmult_integral r r H); trivial.
+Qed.
+
+(*********************************************************)
+(**      Opposite                                        *)
+(*********************************************************)
+
+(**********)
+Lemma Ropp_eq_compat : forall r1 r2, r1 = r2 -> - r1 = - r2.
+  auto with real.
+Qed.
+Hint Resolve Ropp_eq_compat: real.
+
+(**********)
+Lemma Ropp_0 : -0 = 0.
+  ring.
+Qed.
+Hint Resolve Ropp_0: real v62.
+
+(**********)
+Lemma Ropp_eq_0_compat : forall r, r = 0 -> - r = 0.
+  intros; rewrite H; auto with real.
+Qed.
+Hint Resolve Ropp_eq_0_compat: real.
+
+(**********)
+Lemma Ropp_involutive : forall r, - - r = r.
+  intro; ring.
+Qed.
+Hint Resolve Ropp_involutive: real.
+
+(*********)
+Lemma Ropp_neq_0_compat : forall r, r <> 0 -> - r <> 0.
+red in |- *; intros r H H0.
+apply H.
+transitivity (- - r); auto with real.
+Qed.
+Hint Resolve Ropp_neq_0_compat: real.
+
+(**********)
+Lemma Ropp_plus_distr : forall r1 r2, - (r1 + r2) = - r1 + - r2.
+  intros; ring.
+Qed.
+Hint Resolve Ropp_plus_distr: real.
+
+(** Opposite and multiplication *)
+
+Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 = - (r1 * r2).
+  intros; ring.
+Qed.
+Hint Resolve Ropp_mult_distr_l_reverse: real.
+
+(**********)
+Lemma Rmult_opp_opp : forall r1 r2, - r1 * - r2 = r1 * r2.
+  intros; ring.
+Qed.
+Hint Resolve Rmult_opp_opp: real.
+
+Lemma Ropp_mult_distr_r_reverse : forall r1 r2, r1 * - r2 = - (r1 * r2).
+intros; rewrite <- Ropp_mult_distr_l_reverse; ring.
+Qed.
+
+(** Substraction *)
+
+Lemma Rminus_0_r : forall r, r - 0 = r.
+intro; ring.
+Qed.
+Hint Resolve Rminus_0_r: real.
+
+Lemma Rminus_0_l : forall r, 0 - r = - r.
+intro; ring.
+Qed.
+Hint Resolve Rminus_0_l: real.
+
+(**********)
+Lemma Ropp_minus_distr : forall r1 r2, - (r1 - r2) = r2 - r1.
+  intros; ring.
+Qed.
+Hint Resolve Ropp_minus_distr: real.
+
+Lemma Ropp_minus_distr' : forall r1 r2, - (r2 - r1) = r1 - r2.
+intros; ring.
+Qed.
+Hint Resolve Ropp_minus_distr': real. 
+
+(**********)
+Lemma Rminus_diag_eq : forall r1 r2, r1 = r2 -> r1 - r2 = 0.
+  intros; rewrite H; ring.
+Qed.
+Hint Resolve Rminus_diag_eq: real.
+
+(**********)
+Lemma Rminus_diag_uniq : forall r1 r2, r1 - r2 = 0 -> r1 = r2.
+  intros r1 r2; unfold Rminus in |- *; rewrite Rplus_comm; intro.
+  rewrite <- (Ropp_involutive r2); apply (Rplus_opp_r_uniq (- r2) r1 H).
+Qed.
+Hint Immediate Rminus_diag_uniq: real.
+
+Lemma Rminus_diag_uniq_sym : forall r1 r2, r2 - r1 = 0 -> r1 = r2.
+intros; generalize (Rminus_diag_uniq r2 r1 H); clear H; intro H; rewrite H;
+ ring.
+Qed.
+Hint Immediate Rminus_diag_uniq_sym: real.
+
+Lemma Rplus_minus : forall r1 r2, r1 + (r2 - r1) = r2.
+intros; ring.
+Qed.
+Hint Resolve Rplus_minus: real.
+
+(**********)
+Lemma Rminus_eq_contra : forall r1 r2, r1 <> r2 -> r1 - r2 <> 0.
+red in |- *; intros r1 r2 H H0.
+apply H; auto with real.
+Qed.
+Hint Resolve Rminus_eq_contra: real.
+
+Lemma Rminus_not_eq : forall r1 r2, r1 - r2 <> 0 -> r1 <> r2.
+red in |- *; intros; elim H; apply Rminus_diag_eq; auto.
+Qed.
+Hint Resolve Rminus_not_eq: real.
+
+Lemma Rminus_not_eq_right : forall r1 r2, r2 - r1 <> 0 -> r1 <> r2.
+red in |- *; intros; elim H; rewrite H0; ring.
+Qed.
+Hint Resolve Rminus_not_eq_right: real. 
+
+
+(**********)
+Lemma Rmult_minus_distr_l :
+ forall r1 r2 r3, r1 * (r2 - r3) = r1 * r2 - r1 * r3.
+intros; ring.
+Qed.
+
+(** Inverse *)
+Lemma Rinv_1 : / 1 = 1.
+field; auto with real.
+Qed.
+Hint Resolve Rinv_1: real.
+
+(*********)
+Lemma Rinv_neq_0_compat : forall r, r <> 0 -> / r <> 0.
+red in |- *; intros; apply R1_neq_R0.
+replace 1 with (/ r * r); auto with real.
+Qed.
+Hint Resolve Rinv_neq_0_compat: real.
+
+(*********)
+Lemma Rinv_involutive : forall r, r <> 0 -> / / r = r.
+intros; field; auto with real.
+Qed.
+Hint Resolve Rinv_involutive: real.
+
+(*********)
+Lemma Rinv_mult_distr :
+ forall r1 r2, r1 <> 0 -> r2 <> 0 -> / (r1 * r2) = / r1 * / r2.
+intros; field; auto with real.
+Qed.
+
+(*********)
+Lemma Ropp_inv_permute : forall r, r <> 0 -> - / r = / - r.
+intros; field; auto with real.
+Qed.
+
+Lemma Rinv_r_simpl_r : forall r1 r2, r1 <> 0 -> r1 * / r1 * r2 = r2.
+intros; transitivity (1 * r2); auto with real.
+rewrite Rinv_r; auto with real.
+Qed.
+
+Lemma Rinv_r_simpl_l : forall r1 r2, r1 <> 0 -> r2 * r1 * / r1 = r2.
+intros; transitivity (r2 * 1); auto with real.
+transitivity (r2 * (r1 * / r1)); auto with real.
+Qed.
+
+Lemma Rinv_r_simpl_m : forall r1 r2, r1 <> 0 -> r1 * r2 * / r1 = r2.
+intros; transitivity (r2 * 1); auto with real.
+transitivity (r2 * (r1 * / r1)); auto with real.
+ring.
+Qed.
+Hint Resolve Rinv_r_simpl_l Rinv_r_simpl_r Rinv_r_simpl_m: real.
+
+(*********)
+Lemma Rinv_mult_simpl :
+ forall r1 r2 r3, r1 <> 0 -> r1 * / r2 * (r3 * / r1) = r3 * / r2.
+intros a b c; intros.
+transitivity (a * / a * (c * / b)); auto with real.
+ring.
+Qed.
+
+(** Order and addition *)
+
+Lemma Rplus_lt_compat_r : forall r r1 r2, r1 < r2 -> r1 + r < r2 + r.
+intros.
+rewrite (Rplus_comm r1 r); rewrite (Rplus_comm r2 r); auto with real.
+Qed.
+
+Hint Resolve Rplus_lt_compat_r: real.
+
+(**********)
+Lemma Rplus_lt_reg_r : forall r r1 r2, r + r1 < r + r2 -> r1 < r2.
+intros; cut (- r + r + r1 < - r + r + r2).
+rewrite Rplus_opp_l.
+elim (Rplus_ne r1); elim (Rplus_ne r2); intros; rewrite <- H3; rewrite <- H1;
+ auto with zarith real.
+rewrite Rplus_assoc; rewrite Rplus_assoc;
+ apply (Rplus_lt_compat_l (- r) (r + r1) (r + r2) H).
+Qed.
+
+(**********)
+Lemma Rplus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2.
+unfold Rle in |- *; intros; elim H; intro.
+left; apply (Rplus_lt_compat_l r r1 r2 H0).
+right; rewrite <- H0; auto with zarith real.
+Qed.
+
+(**********)
+Lemma Rplus_le_compat_r : forall r r1 r2, r1 <= r2 -> r1 + r <= r2 + r.
+unfold Rle in |- *; intros; elim H; intro.
+left; apply (Rplus_lt_compat_r r r1 r2 H0).
+right; rewrite <- H0; auto with real.
+Qed.
+
+Hint Resolve Rplus_le_compat_l Rplus_le_compat_r: real.
+
+(**********)
+Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2.
+unfold Rle in |- *; intros; elim H; intro.
+left; apply (Rplus_lt_reg_r r r1 r2 H0).
+right; apply (Rplus_eq_reg_l r r1 r2 H0).
+Qed.
+
+(**********)
+Lemma sum_inequa_Rle_lt :
+ forall a x b c y d:R,
+   a <= x -> x < b -> c < y -> y <= d -> a + c < x + y < b + d.
+intros; split.
+apply Rlt_le_trans with (a + y); auto with real.
+apply Rlt_le_trans with (b + y); auto with real.
+Qed.
+
+(*********)
+Lemma Rplus_lt_compat :
+ forall r1 r2 r3 r4, r1 < r2 -> r3 < r4 -> r1 + r3 < r2 + r4.
+intros; apply Rlt_trans with (r2 + r3); auto with real.
+Qed.
+
+Lemma Rplus_le_compat :
+ forall r1 r2 r3 r4, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4.
+intros; apply Rle_trans with (r2 + r3); auto with real.
+Qed.
+
+(*********)
+Lemma Rplus_lt_le_compat :
+ forall r1 r2 r3 r4, r1 < r2 -> r3 <= r4 -> r1 + r3 < r2 + r4.
+intros; apply Rlt_le_trans with (r2 + r3); auto with real.
+Qed.
+
+(*********)
+Lemma Rplus_le_lt_compat :
+ forall r1 r2 r3 r4, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4.
+intros; apply Rle_lt_trans with (r2 + r3); auto with real.
+Qed.
+
+Hint Immediate Rplus_lt_compat Rplus_le_compat Rplus_lt_le_compat
+  Rplus_le_lt_compat: real.
+
+(** Order and Opposite *)
+
+(**********)
+Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2.
+unfold Rgt in |- *; intros.
+apply (Rplus_lt_reg_r (r2 + r1)).
+replace (r2 + r1 + - r1) with r2.
+replace (r2 + r1 + - r2) with r1.
+trivial.
+ring.
+ring.
+Qed.
+Hint Resolve Ropp_gt_lt_contravar.
+
+(**********)
+Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2.
+unfold Rgt in |- *; auto with real.
+Qed.
+Hint Resolve Ropp_lt_gt_contravar: real.
+
+Lemma Ropp_lt_cancel : forall r1 r2, - r2 < - r1 -> r1 < r2.
+intros x y H'.
+rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y);
+ auto with real.
+Qed.
+Hint Immediate Ropp_lt_cancel: real.
+
+Lemma Ropp_lt_contravar : forall r1 r2, r2 < r1 -> - r1 < - r2.
+auto with real.
+Qed.
+Hint Resolve Ropp_lt_contravar: real.
+
+(**********)
+Lemma Ropp_le_ge_contravar : forall r1 r2, r1 <= r2 -> - r1 >= - r2.
+unfold Rge in |- *; intros r1 r2 [H| H]; auto with real.
+Qed.
+Hint Resolve Ropp_le_ge_contravar: real.
+
+Lemma Ropp_le_cancel : forall r1 r2, - r2 <= - r1 -> r1 <= r2.
+intros x y H.
+elim H; auto with real.
+intro H1; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y);
+ rewrite H1; auto with real.
+Qed.
+Hint Immediate Ropp_le_cancel: real.
+
+Lemma Ropp_le_contravar : forall r1 r2, r2 <= r1 -> - r1 <= - r2.
+intros r1 r2 H; elim H; auto with real.
+Qed.
+Hint Resolve Ropp_le_contravar: real.
+
+(**********)
+Lemma Ropp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2.
+unfold Rge in |- *; intros r1 r2 [H| H]; auto with real.
+Qed.
+Hint Resolve Ropp_ge_le_contravar: real.
+
+(**********)
+Lemma Ropp_0_lt_gt_contravar : forall r, 0 < r -> 0 > - r.
+intros; replace 0 with (-0); auto with real.
+Qed.
+Hint Resolve Ropp_0_lt_gt_contravar: real.
+
+(**********)
+Lemma Ropp_0_gt_lt_contravar : forall r, 0 > r -> 0 < - r.
+intros; replace 0 with (-0); auto with real.
+Qed.
+Hint Resolve Ropp_0_gt_lt_contravar: real.
+
+(**********)
+Lemma Ropp_lt_gt_0_contravar : forall r, r > 0 -> - r < 0.
+intros; rewrite <- Ropp_0; auto with real.
+Qed.
+
+(**********)
+Lemma Ropp_gt_lt_0_contravar : forall r, r < 0 -> - r > 0.
+intros; rewrite <- Ropp_0; auto with real.
+Qed.
+Hint Resolve Ropp_lt_gt_0_contravar Ropp_gt_lt_0_contravar: real.
+
+(**********)
+Lemma Ropp_0_le_ge_contravar : forall r, 0 <= r -> 0 >= - r.
+intros; replace 0 with (-0); auto with real.
+Qed.
+Hint Resolve Ropp_0_le_ge_contravar: real.
+
+(**********)
+Lemma Ropp_0_ge_le_contravar : forall r, 0 >= r -> 0 <= - r.
+intros; replace 0 with (-0); auto with real.
+Qed.
+Hint Resolve Ropp_0_ge_le_contravar: real.
+
+(** Order and multiplication *)
+
+Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r.
+intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real.
+Qed.
+Hint Resolve Rmult_lt_compat_r.
+
+Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2.
+intros z x y H H0.
+case (Rtotal_order x y); intros Eq0; auto; elim Eq0; clear Eq0; intros Eq0.
+ rewrite Eq0 in H0; elimtype False; apply (Rlt_irrefl (z * y)); auto.
+generalize (Rmult_lt_compat_l z y x H Eq0); intro; elimtype False;
+ generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); 
+ intro; apply (Rlt_irrefl (z * x)); auto.
+Qed.
+
+
+Lemma Rmult_lt_gt_compat_neg_l :
+ forall r r1 r2, r < 0 -> r1 < r2 -> r * r1 > r * r2.
+intros; replace r with (- - r); auto with real.
+rewrite (Ropp_mult_distr_l_reverse (- r));
+ rewrite (Ropp_mult_distr_l_reverse (- r)).
+apply Ropp_lt_gt_contravar; auto with real.
+Qed.
+
+(**********)
+Lemma Rmult_le_compat_l :
+ forall r r1 r2, 0 <= r -> r1 <= r2 -> r * r1 <= r * r2.
+intros r r1 r2 H H0; destruct H; destruct H0; unfold Rle in |- *;
+ auto with real.
+right; rewrite <- H; do 2 rewrite Rmult_0_l; reflexivity.
+Qed.
+Hint Resolve Rmult_le_compat_l: real.
+
+Lemma Rmult_le_compat_r :
+ forall r r1 r2, 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r.
+intros r r1 r2 H; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r);
+ auto with real.
+Qed.
+Hint Resolve Rmult_le_compat_r: real.
+
+Lemma Rmult_le_reg_l : forall r r1 r2, 0 < r -> r * r1 <= r * r2 -> r1 <= r2.
+intros z x y H H0; case H0; auto with real.
+intros H1; apply Rlt_le.
+apply Rmult_lt_reg_l with (r := z); auto.
+intros H1; replace x with (/ z * (z * x)); auto with real.
+replace y with (/ z * (z * y)).
+ rewrite H1; auto with real.
+rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real.
+rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real.
+Qed.
+
+Lemma Rmult_le_compat_neg_l :
+ forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r2 <= r * r1.
+intros; replace r with (- - r); auto with real.
+do 2 rewrite (Ropp_mult_distr_l_reverse (- r)).
+apply Ropp_le_contravar; auto with real.
+Qed.
+Hint Resolve Rmult_le_compat_neg_l: real.
+
+Lemma Rmult_le_ge_compat_neg_l :
+ forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r1 >= r * r2.
+intros; apply Rle_ge; auto with real.
+Qed.
+Hint Resolve Rmult_le_ge_compat_neg_l: real.
+
+Lemma Rmult_le_compat :
+ forall r1 r2 r3 r4,
+   0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4.
+intros x y z t H' H'0 H'1 H'2.
+apply Rle_trans with (r2 := x * t); auto with real.
+repeat rewrite (fun x => Rmult_comm x t).
+apply Rmult_le_compat_l; auto.
+apply Rle_trans with z; auto.
+Qed.
+Hint Resolve Rmult_le_compat: real.
+
+Lemma Rmult_gt_0_lt_compat :
+ forall r1 r2 r3 r4,
+   r3 > 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
+intros; apply Rlt_trans with (r2 * r3); auto with real.
+Qed.
+
+(*********)
+Lemma Rmult_ge_0_gt_0_lt_compat :
+ forall r1 r2 r3 r4,
+   r3 >= 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
+intros; apply Rle_lt_trans with (r2 * r3); auto with real.
+Qed.
+
+(** Order and Substractions *)
+Lemma Rlt_minus : forall r1 r2, r1 < r2 -> r1 - r2 < 0.
+intros; apply (Rplus_lt_reg_r r2).
+replace (r2 + (r1 - r2)) with r1.
+replace (r2 + 0) with r2; auto with real.
+ring.
+Qed.
+Hint Resolve Rlt_minus: real.
+
+(**********)
+Lemma Rle_minus : forall r1 r2, r1 <= r2 -> r1 - r2 <= 0.
+destruct 1; unfold Rle in |- *; auto with real.
+Qed.
+
+(**********)
+Lemma Rminus_lt : forall r1 r2, r1 - r2 < 0 -> r1 < r2.
+intros; replace r1 with (r1 - r2 + r2).
+pattern r2 at 3 in |- *; replace r2 with (0 + r2); auto with real.
+ring.
+Qed.
+
+(**********)
+Lemma Rminus_le : forall r1 r2, r1 - r2 <= 0 -> r1 <= r2.
+intros; replace r1 with (r1 - r2 + r2).
+pattern r2 at 3 in |- *; replace r2 with (0 + r2); auto with real.
+ring.
+Qed.
+
+(**********)
+Lemma tech_Rplus : forall r (s:R), 0 <= r -> 0 < s -> r + s <> 0.
+intros; apply sym_not_eq; apply Rlt_not_eq.
+rewrite Rplus_comm; replace 0 with (0 + 0); auto with real.
+Qed.
+Hint Immediate tech_Rplus: real.
+
+(** Order and the square function *)
+Lemma Rle_0_sqr : forall r, 0 <= Rsqr r.
+intro; case (Rlt_le_dec r 0); unfold Rsqr in |- *; intro.
+replace (r * r) with (- r * - r); auto with real.
+replace 0 with (- r * 0); auto with real.
+replace 0 with (0 * r); auto with real.
+Qed.
+
+(***********)
+Lemma Rlt_0_sqr : forall r, r <> 0 -> 0 < Rsqr r.
+intros; case (Rdichotomy r 0); trivial; unfold Rsqr in |- *; intro.
+replace (r * r) with (- r * - r); auto with real.
+replace 0 with (- r * 0); auto with real.
+replace 0 with (0 * r); auto with real.
+Qed.
+Hint Resolve Rle_0_sqr Rlt_0_sqr: real.
+
+(** Zero is less than one *)
+Lemma Rlt_0_1 : 0 < 1.
+replace 1 with (Rsqr 1); auto with real.
+unfold Rsqr in |- *; auto with real.
+Qed.
+Hint Resolve Rlt_0_1: real.
+
+Lemma Rle_0_1 : 0 <= 1.
+left.
+exact Rlt_0_1.
+Qed.
+
+(** Order and inverse *)
+Lemma Rinv_0_lt_compat : forall r, 0 < r -> 0 < / r.
+intros; apply Rnot_le_lt; red in |- *; intros.
+absurd (1 <= 0); auto with real.
+replace 1 with (r * / r); auto with real.
+replace 0 with (r * 0); auto with real.
+Qed.
+Hint Resolve Rinv_0_lt_compat: real.
+
+(*********)
+Lemma Rinv_lt_0_compat : forall r, r < 0 -> / r < 0.
+intros; apply Rnot_le_lt; red in |- *; intros.
+absurd (1 <= 0); auto with real.
+replace 1 with (r * / r); auto with real.
+replace 0 with (r * 0); auto with real.
+Qed.
+Hint Resolve Rinv_lt_0_compat: real.
+
+(*********)
+Lemma Rinv_lt_contravar : forall r1 r2, 0 < r1 * r2 -> r1 < r2 -> / r2 < / r1.
+intros; apply Rmult_lt_reg_l with (r1 * r2); auto with real.
+case (Rmult_neq_0_reg r1 r2); intros; auto with real.
+replace (r1 * r2 * / r2) with r1.
+replace (r1 * r2 * / r1) with r2; trivial.
+symmetry  in |- *; auto with real.
+symmetry  in |- *; auto with real.
+Qed.
+
+Lemma Rinv_1_lt_contravar : forall r1 r2, 1 <= r1 -> r1 < r2 -> / r2 < / r1.
+intros x y H' H'0.
+cut (0 < x); [ intros Lt0 | apply Rlt_le_trans with (r2 := 1) ];
+ auto with real.
+apply Rmult_lt_reg_l with (r := x); auto with real.
+rewrite (Rmult_comm x (/ x)); rewrite Rinv_l; auto with real.
+apply Rmult_lt_reg_l with (r := y); auto with real.
+apply Rlt_trans with (r2 := x); auto.
+cut (y * (x * / y) = x).
+intro H1; rewrite H1; rewrite (Rmult_1_r y); auto.
+rewrite (Rmult_comm x); rewrite <- Rmult_assoc; rewrite (Rmult_comm y (/ y));
+ rewrite Rinv_l; auto with real.
+apply Rlt_dichotomy_converse; right.
+red in |- *; apply Rlt_trans with (r2 := x); auto with real.
+Qed.
+Hint Resolve Rinv_1_lt_contravar: real.
+
+(*********************************************************)        
+(**      Greater                                         *)
+(*********************************************************)
+
+(**********)
+Lemma Rge_antisym : forall r1 r2, r1 >= r2 -> r2 >= r1 -> r1 = r2.
+intros; apply Rle_antisym; auto with real.
+Qed.
+
+(**********)
+Lemma Rnot_lt_ge : forall r1 r2, ~ r1 < r2 -> r1 >= r2.
+intros; unfold Rge in |- *; elim (Rtotal_order r1 r2); intro.
+absurd (r1 < r2); trivial.
+case H0; auto.
+Qed.
+
+(**********)
+Lemma Rnot_lt_le : forall r1 r2, ~ r1 < r2 -> r2 <= r1.
+intros; apply Rge_le; apply Rnot_lt_ge; assumption.
+Qed.
+
+(**********)
+Lemma Rnot_gt_le : forall r1 r2, ~ r1 > r2 -> r1 <= r2.
+intros r1 r2 H; apply Rge_le.
+exact (Rnot_lt_ge r2 r1 H).
+Qed.
+
+(**********)
+Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2.
+red in |- *; auto with real.
+Qed.
+
+
+(**********)
+Lemma Rge_gt_trans : forall r1 r2 r3, r1 >= r2 -> r2 > r3 -> r1 > r3.
+unfold Rgt in |- *; intros; apply Rlt_le_trans with r2; auto with real.
+Qed.
+
+(**********)
+Lemma Rgt_ge_trans : forall r1 r2 r3, r1 > r2 -> r2 >= r3 -> r1 > r3.
+unfold Rgt in |- *; intros; apply Rle_lt_trans with r2; auto with real.
+Qed.
+
+(**********)
+Lemma Rgt_trans : forall r1 r2 r3, r1 > r2 -> r2 > r3 -> r1 > r3.
+unfold Rgt in |- *; intros; apply Rlt_trans with r2; auto with real.
+Qed.
+
+(**********)
+Lemma Rge_trans : forall r1 r2 r3, r1 >= r2 -> r2 >= r3 -> r1 >= r3.
+intros; apply Rle_ge.
+apply Rle_trans with r2; auto with real.
+Qed.
+
+(**********)
+Lemma Rle_lt_0_plus_1 : forall r, 0 <= r -> 0 < r + 1.
+intros.
+apply Rlt_le_trans with 1; auto with real.
+pattern 1 at 1 in |- *; replace 1 with (0 + 1); auto with real.
+Qed.
+Hint Resolve Rle_lt_0_plus_1: real.
+
+(**********)
+Lemma Rlt_plus_1 : forall r, r < r + 1.
+intros.
+pattern r at 1 in |- *; replace r with (r + 0); auto with real.
+Qed.
+Hint Resolve Rlt_plus_1: real.
+
+(**********)
+Lemma tech_Rgt_minus : forall r1 r2, 0 < r2 -> r1 > r1 - r2.
+red in |- *; unfold Rminus in |- *; intros.
+pattern r1 at 2 in |- *; replace r1 with (r1 + 0); auto with real.
+Qed.
+
+(***********)
+Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2.
+unfold Rgt in |- *; auto with real.
+Qed.
+Hint Resolve Rplus_gt_compat_l: real.
+
+(***********)
+Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2.
+unfold Rgt in |- *; intros; apply (Rplus_lt_reg_r r r2 r1 H).
+Qed.
+
+(***********)
+Lemma Rplus_ge_compat_l : forall r r1 r2, r1 >= r2 -> r + r1 >= r + r2.
+intros; apply Rle_ge; auto with real.
+Qed.
+Hint Resolve Rplus_ge_compat_l: real.
+
+(***********)
+Lemma Rplus_ge_reg_l : forall r r1 r2, r + r1 >= r + r2 -> r1 >= r2.
+intros; apply Rle_ge; apply Rplus_le_reg_l with r; auto with real.
+Qed.
+
+(***********)
+Lemma Rmult_ge_compat_r :
+ forall r r1 r2, r >= 0 -> r1 >= r2 -> r1 * r >= r2 * r.
+intros; apply Rle_ge; apply Rmult_le_compat_r; apply Rge_le; assumption.
+Qed.
+
+(***********)
+Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0.
+intros; replace 0 with (r2 - r2); auto with real.
+unfold Rgt, Rminus in |- *; auto with real.
+Qed.
+
+(*********)
+Lemma minus_Rgt : forall r1 r2, r1 - r2 > 0 -> r1 > r2.
+intros; replace r2 with (r2 + 0); auto with real.
+intros; replace r1 with (r2 + (r1 - r2)); auto with real.
+Qed.
+
+(**********)
+Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0.
+unfold Rge in |- *; intros; elim H; intro.
+left; apply (Rgt_minus r1 r2 H0).
+right; apply (Rminus_diag_eq r1 r2 H0).
+Qed.
+
+(*********)
+Lemma minus_Rge : forall r1 r2, r1 - r2 >= 0 -> r1 >= r2.
+intros; replace r2 with (r2 + 0); auto with real.
+intros; replace r1 with (r2 + (r1 - r2)); auto with real.
+Qed.
+
+
+(*********)
+Lemma Rmult_gt_0_compat : forall r1 r2, r1 > 0 -> r2 > 0 -> r1 * r2 > 0.
+unfold Rgt in |- *; intros.
+replace 0 with (0 * r2); auto with real.
+Qed.
+
+(*********)
+Lemma Rmult_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 * r2.
+Proof Rmult_gt_0_compat.
+
+(***********)
+Lemma Rplus_eq_0_l :
+ forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0.
+intros a b [H| H] H0 H1; auto with real.
+absurd (0 < a + b).
+rewrite H1; auto with real.
+replace 0 with (0 + 0); auto with real.
+Qed.
+
+
+Lemma Rplus_eq_R0 :
+ forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0 /\ r2 = 0.
+intros a b; split.
+apply Rplus_eq_0_l with b; auto with real.
+apply Rplus_eq_0_l with a; auto with real.
+rewrite Rplus_comm; auto with real.
+Qed.
+
+
+(***********)
+Lemma Rplus_sqr_eq_0_l : forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0.
+intros a b; intros; apply Rsqr_0_uniq; apply Rplus_eq_0_l with (Rsqr b);
+ auto with real.
+Qed.
+
+Lemma Rplus_sqr_eq_0 :
+ forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0 /\ r2 = 0.
+intros a b; split.
+apply Rplus_sqr_eq_0_l with b; auto with real.
+apply Rplus_sqr_eq_0_l with a; auto with real.
+rewrite Rplus_comm; auto with real.
+Qed.
+
+
+(**********************************************************) 
+(**       Injection from [N] to [R]                       *)
+(**********************************************************)
+
+(**********)
+Lemma S_INR : forall n:nat, INR (S n) = INR n + 1.
+intro; case n; auto with real.
+Qed.
+
+(**********)
+Lemma S_O_plus_INR : forall n:nat, INR (1 + n) = INR 1 + INR n.
+intro; simpl in |- *; case n; intros; auto with real.
+Qed.
+
+(**********)
+Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m. 
+intros n m; induction  n as [| n Hrecn].
+simpl in |- *; auto with real.
+replace (S n + m)%nat with (S (n + m)); auto with arith.
+repeat rewrite S_INR.
+rewrite Hrecn; ring.
+Qed.
+
+(**********)
+Lemma minus_INR : forall n m:nat, (m <= n)%nat -> INR (n - m) = INR n - INR m.
+intros n m le; pattern m, n in |- *; apply le_elim_rel; auto with real.
+intros; rewrite <- minus_n_O; auto with real.
+intros; repeat rewrite S_INR; simpl in |- *.
+rewrite H0; ring.
+Qed.
+
+(*********)
+Lemma mult_INR : forall n m:nat, INR (n * m) = INR n * INR m.
+intros n m; induction  n as [| n Hrecn].
+simpl in |- *; auto with real.
+intros; repeat rewrite S_INR; simpl in |- *.
+rewrite plus_INR; rewrite Hrecn; ring.
+Qed.
+
+Hint Resolve plus_INR minus_INR mult_INR: real.
+
+(*********)
+Lemma lt_INR_0 : forall n:nat, (0 < n)%nat -> 0 < INR n.
+simple induction 1; intros; auto with real.
+rewrite S_INR; auto with real.
+Qed.
+Hint Resolve lt_INR_0: real.
+
+Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m.
+simple induction 1; intros; auto with real.
+rewrite S_INR; auto with real.
+rewrite S_INR; apply Rlt_trans with (INR m0); auto with real.
+Qed.
+Hint Resolve lt_INR: real.
+
+Lemma INR_lt_1 : forall n:nat, (1 < n)%nat -> 1 < INR n.
+intros; replace 1 with (INR 1); auto with real.
+Qed.
+Hint Resolve INR_lt_1: real.
+
+(**********)
+Lemma INR_pos : forall p:positive, 0 < INR (nat_of_P p).
+intro; apply lt_INR_0.
+simpl in |- *; auto with real.
+apply lt_O_nat_of_P.
+Qed.
+Hint Resolve INR_pos: real.
+
+(**********)
+Lemma pos_INR : forall n:nat, 0 <= INR n.
+intro n; case n.
+simpl in |- *; auto with real.
+auto with arith real.
+Qed.
+Hint Resolve pos_INR: real.
+
+Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat.
+double induction n m; intros.
+simpl in |- *; elimtype False; apply (Rlt_irrefl 0); auto.
+auto with arith.
+generalize (pos_INR (S n0)); intro; cut (INR 0 = 0);
+ [ intro H2; rewrite H2 in H0; idtac | simpl in |- *; trivial ]. 
+generalize (Rle_lt_trans 0 (INR (S n0)) 0 H1 H0); intro; elimtype False;
+ apply (Rlt_irrefl 0); auto.
+do 2 rewrite S_INR in H1; cut (INR n1 < INR n0).
+intro H2; generalize (H0 n0 H2); intro; auto with arith.
+apply (Rplus_lt_reg_r 1 (INR n1) (INR n0)).
+rewrite Rplus_comm; rewrite (Rplus_comm 1 (INR n0)); trivial.
+Qed.
+Hint Resolve INR_lt: real.
+
+(*********)
+Lemma le_INR : forall n m:nat, (n <= m)%nat -> INR n <= INR m.
+simple induction 1; intros; auto with real.
+rewrite S_INR.
+apply Rle_trans with (INR m0); auto with real.
+Qed.
+Hint Resolve le_INR: real.
+
+(**********)
+Lemma not_INR_O : forall n:nat, INR n <> 0 -> n <> 0%nat.
+red in |- *; intros n H H1.
+apply H.
+rewrite H1; trivial.
+Qed.
+Hint Immediate not_INR_O: real.
+
+(**********)
+Lemma not_O_INR : forall n:nat, n <> 0%nat -> INR n <> 0.
+intro n; case n.
+intro; absurd (0%nat = 0%nat); trivial.
+intros; rewrite S_INR.
+apply Rgt_not_eq; red in |- *; auto with real.
+Qed.
+Hint Resolve not_O_INR: real.
+
+Lemma not_nm_INR : forall n m:nat, n <> m -> INR n <> INR m.
+intros n m H; case (le_or_lt n m); intros H1.
+case (le_lt_or_eq _ _ H1); intros H2.
+apply Rlt_dichotomy_converse; auto with real.
+elimtype False; auto.
+apply sym_not_eq; apply Rlt_dichotomy_converse; auto with real.
+Qed.
+Hint Resolve not_nm_INR: real.
+
+Lemma INR_eq : forall n m:nat, INR n = INR m -> n = m.
+intros; case (le_or_lt n m); intros H1.
+case (le_lt_or_eq _ _ H1); intros H2; auto.
+cut (n <> m).
+intro H3; generalize (not_nm_INR n m H3); intro H4; elimtype False; auto.
+omega.
+symmetry  in |- *; cut (m <> n).
+intro H3; generalize (not_nm_INR m n H3); intro H4; elimtype False; auto.
+omega.
+Qed.
+Hint Resolve INR_eq: real.
+
+Lemma INR_le : forall n m:nat, INR n <= INR m -> (n <= m)%nat.
+intros; elim H; intro.
+generalize (INR_lt n m H0); intro; auto with arith.
+generalize (INR_eq n m H0); intro; rewrite H1; auto.
+Qed.
+Hint Resolve INR_le: real.
+
+Lemma not_1_INR : forall n:nat, n <> 1%nat -> INR n <> 1.
+replace 1 with (INR 1); auto with real.
+Qed.
+Hint Resolve not_1_INR: real.
+
+(**********************************************************) 
+(**      Injection from [Z] to [R]                        *)
+(**********************************************************)
+
+
+(**********)
+Lemma IZN : forall n:Z, (0 <= n)%Z ->  exists m : nat, n = Z_of_nat m.
+intros z; idtac; apply Z_of_nat_complete; assumption.
+Qed.
+
+(**********)
+Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z_of_nat n).
+simple induction n; auto with real.
+intros; simpl in |- *; rewrite nat_of_P_o_P_of_succ_nat_eq_succ;
+ auto with real.
+Qed.
+
+Lemma plus_IZR_NEG_POS :
+ forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q).
+intros.
+case (lt_eq_lt_dec (nat_of_P p) (nat_of_P q)).
+intros [H| H]; simpl in |- *.
+rewrite nat_of_P_lt_Lt_compare_complement_morphism; simpl in |- *; trivial.
+rewrite (nat_of_P_minus_morphism q p).
+rewrite minus_INR; auto with arith; ring.
+apply ZC2; apply nat_of_P_lt_Lt_compare_complement_morphism; trivial.
+rewrite (nat_of_P_inj p q); trivial.
+rewrite Pcompare_refl; simpl in |- *; auto with real.
+intro H; simpl in |- *.
+rewrite nat_of_P_gt_Gt_compare_complement_morphism; simpl in |- *;
+ auto with arith.
+rewrite (nat_of_P_minus_morphism p q).
+rewrite minus_INR; auto with arith; ring.
+apply ZC2; apply nat_of_P_lt_Lt_compare_complement_morphism; trivial.
+Qed.
+
+(**********)
+Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m.
+intro z; destruct z; intro t; destruct t; intros; auto with real.
+simpl in |- *; intros; rewrite nat_of_P_plus_morphism; auto with real.
+apply plus_IZR_NEG_POS.
+rewrite Zplus_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS.
+simpl in |- *; intros; rewrite nat_of_P_plus_morphism; rewrite plus_INR;
+ auto with real.
+Qed.
+
+(**********)
+Lemma mult_IZR : forall n m:Z, IZR (n * m) = IZR n * IZR m.
+intros z t; case z; case t; simpl in |- *; auto with real.
+intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
+intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
+rewrite Rmult_comm.
+rewrite Ropp_mult_distr_l_reverse; auto with real.
+apply Ropp_eq_compat; rewrite mult_comm; auto with real.
+intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
+rewrite Ropp_mult_distr_l_reverse; auto with real.
+intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
+rewrite Rmult_opp_opp; auto with real.
+Qed.
+
+(**********)
+Lemma Ropp_Ropp_IZR : forall n:Z, IZR (- n) = - IZR n.
+intro z; case z; simpl in |- *; auto with real.
+Qed.
+
+(**********)
+Lemma Z_R_minus : forall n m:Z, IZR n - IZR m = IZR (n - m).
+intros z1 z2; unfold Rminus in |- *; unfold Zminus in |- *.
+rewrite <- (Ropp_Ropp_IZR z2); symmetry  in |- *; apply plus_IZR.
+Qed. 
+
+(**********)
+Lemma lt_O_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z.
+intro z; case z; simpl in |- *; intros.
+absurd (0 < 0); auto with real.
+unfold Zlt in |- *; simpl in |- *; trivial.
+case Rlt_not_le with (1 := H).
+replace 0 with (-0); auto with real.
+Qed.
+
+(**********)
+Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z.
+intros z1 z2 H; apply Zlt_O_minus_lt. 
+apply lt_O_IZR.
+rewrite <- Z_R_minus.
+exact (Rgt_minus (IZR z2) (IZR z1) H).
+Qed.
+
+(**********)
+Lemma eq_IZR_R0 : forall n:Z, IZR n = 0 -> n = 0%Z.
+intro z; destruct z; simpl in |- *; intros; auto with zarith.
+case (Rlt_not_eq 0 (INR (nat_of_P p))); auto with real.
+case (Rlt_not_eq (- INR (nat_of_P p)) 0); auto with real.
+apply Ropp_lt_gt_0_contravar. unfold Rgt in |- *; apply INR_pos.
+Qed.
+
+(**********)
+Lemma eq_IZR : forall n m:Z, IZR n = IZR m -> n = m.
+intros z1 z2 H; generalize (Rminus_diag_eq (IZR z1) (IZR z2) H);
+ rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0); 
+ intro; omega.
+Qed.
+
+(**********)
+Lemma not_O_IZR : forall n:Z, n <> 0%Z -> IZR n <> 0.
+intros z H; red in |- *; intros H0; case H.
+apply eq_IZR; auto.
+Qed.
+
+(*********)
+Lemma le_O_IZR : forall n:Z, 0 <= IZR n -> (0 <= n)%Z.
+unfold Rle in |- *; intros z [H| H].
+red in |- *; intro; apply (Zlt_le_weak 0 z (lt_O_IZR z H)); assumption.
+rewrite (eq_IZR_R0 z); auto with zarith real.
+Qed.
+
+(**********)
+Lemma le_IZR : forall n m:Z, IZR n <= IZR m -> (n <= m)%Z.
+unfold Rle in |- *; intros z1 z2 [H| H].
+apply (Zlt_le_weak z1 z2); auto with real.
+apply lt_IZR; trivial.
+rewrite (eq_IZR z1 z2); auto with zarith real.
+Qed.
+
+(**********)
+Lemma le_IZR_R1 : forall n:Z, IZR n <= 1 -> (n <= 1)%Z.
+pattern 1 at 1 in |- *; replace 1 with (IZR 1); intros; auto.
+apply le_IZR; trivial.
+Qed.
+
+(**********)
+Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m.
+intros m n H; apply Rnot_lt_ge; red in |- *; intro.
+generalize (lt_IZR m n H0); intro; omega.
+Qed.
+
+Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m.
+intros m n H; apply Rnot_gt_le; red in |- *; intro.
+unfold Rgt in H0; generalize (lt_IZR n m H0); intro; omega.
+Qed.
+
+Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m.
+intros m n H; cut (m <= n)%Z.
+intro H0; elim (IZR_le m n H0); intro; auto.
+generalize (eq_IZR m n H1); intro; elimtype False; omega.
+omega.
+Qed.
+
+Lemma one_IZR_lt1 : forall n:Z, -1 < IZR n < 1 -> n = 0%Z.
+intros z [H1 H2].
+apply Zle_antisym.
+apply Zlt_succ_le; apply lt_IZR; trivial.
+replace 0%Z with (Zsucc (-1)); trivial.
+apply Zlt_le_succ; apply lt_IZR; trivial.
+Qed.
+
+Lemma one_IZR_r_R1 :
+ forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m.
+intros r z x [H1 H2] [H3 H4].
+cut ((z - x)%Z = 0%Z); auto with zarith.
+apply one_IZR_lt1.
+rewrite <- Z_R_minus; split.
+replace (-1) with (r - (r + 1)).
+unfold Rminus in |- *; apply Rplus_lt_le_compat; auto with real.
+ring.
+replace 1 with (r + 1 - r).
+unfold Rminus in |- *; apply Rplus_le_lt_compat; auto with real.
+ring.
+Qed.
+
+
+(**********)
+Lemma single_z_r_R1 :
+ forall r (n m:Z),
+   r < IZR n -> IZR n <= r + 1 -> r < IZR m -> IZR m <= r + 1 -> n = m.
+intros; apply one_IZR_r_R1 with r; auto.
+Qed.
+
+(**********)
+Lemma tech_single_z_r_R1 :
+ forall r (n:Z),
+   r < IZR n ->
+   IZR n <= r + 1 ->
+   (exists s : Z, s <> n /\ r < IZR s /\ IZR s <= r + 1) -> False.
+intros r z H1 H2 [s [H3 [H4 H5]]].
+apply H3; apply single_z_r_R1 with r; trivial.
+Qed.
+
+(*****************************************************************)
+(** Definitions of new types                                     *)
+(*****************************************************************)
+
+Record nonnegreal : Type := mknonnegreal
+  {nonneg :> R; cond_nonneg : 0 <= nonneg}.
+
+Record posreal : Type := mkposreal {pos :> R; cond_pos : 0 < pos}.
+
+Record nonposreal : Type := mknonposreal
+  {nonpos :> R; cond_nonpos : nonpos <= 0}.
+
+Record negreal : Type := mknegreal {neg :> R; cond_neg : neg < 0}.
+
+Record nonzeroreal : Type := mknonzeroreal
+  {nonzero :> R; cond_nonzero : nonzero <> 0}.
+
+(**********)
+Lemma prod_neq_R0 : forall r1 r2, r1 <> 0 -> r2 <> 0 -> r1 * r2 <> 0.
+intros x y; intros; red in |- *; intro; generalize (Rmult_integral x y H1);
+ intro; elim H2; intro;
+ [ rewrite H3 in H; elim H | rewrite H3 in H0; elim H0 ]; 
+ reflexivity.
+Qed.
+
+(*********)
+Lemma Rmult_le_pos : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 * r2.
+intros x y H H0; rewrite <- (Rmult_0_l x); rewrite <- (Rmult_comm x);
+ apply (Rmult_le_compat_l x 0 y H H0).
+Qed.
+
+Lemma double : forall r1, 2 * r1 = r1 + r1.
+intro; ring.
+Qed.
+
+Lemma double_var : forall r1, r1 = r1 / 2 + r1 / 2.
+intro; rewrite <- double; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
+ symmetry  in |- *; apply Rinv_r_simpl_m.
+replace 2 with (INR 2);
+ [ apply not_O_INR; discriminate | unfold INR in |- *; ring ].
+Qed.
+
+(**********************************************************)
+(** Other rules about < and <=                            *)
+(**********************************************************)
+
+Lemma Rplus_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 + r2.
+intros x y; intros; apply Rlt_trans with x;
+ [ assumption
+ | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l;
+    assumption ].
+Qed.
+
+Lemma Rplus_le_lt_0_compat : forall r1 r2, 0 <= r1 -> 0 < r2 -> 0 < r1 + r2.
+intros x y; intros; apply Rle_lt_trans with x;
+ [ assumption
+ | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l;
+    assumption ].
+Qed.
+
+Lemma Rplus_lt_le_0_compat : forall r1 r2, 0 < r1 -> 0 <= r2 -> 0 < r1 + r2.
+intros x y; intros; rewrite <- Rplus_comm; apply Rplus_le_lt_0_compat;
+ assumption.
+Qed.
+
+Lemma Rplus_le_le_0_compat : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2.
+intros x y; intros; apply Rle_trans with x;
+ [ assumption
+ | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+    assumption ].
+Qed.
+
+Lemma plus_le_is_le : forall r1 r2 r3, 0 <= r2 -> r1 + r2 <= r3 -> r1 <= r3.
+intros x y z; intros; apply Rle_trans with (x + y);
+ [ pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+    assumption
+ | assumption ].
+Qed.
+
+Lemma plus_lt_is_lt : forall r1 r2 r3, 0 <= r2 -> r1 + r2 < r3 -> r1 < r3.
+intros x y z; intros; apply Rle_lt_trans with (x + y);
+ [ pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+    assumption
+ | assumption ].
+Qed.
+
+Lemma Rmult_le_0_lt_compat :
+ forall r1 r2 r3 r4,
+   0 <= r1 -> 0 <= r3 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
+intros; apply Rle_lt_trans with (r2 * r3);
+ [ apply Rmult_le_compat_r; [ assumption | left; assumption ]
+ | apply Rmult_lt_compat_l;
+    [ apply Rle_lt_trans with r1; assumption | assumption ] ].
+Qed.
+
+Lemma le_epsilon :
+ forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2.
+intros x y; intros; elim (Rtotal_order x y); intro.
+left; assumption.
+elim H0; intro.
+right; assumption.
+clear H0; generalize (Rgt_minus x y H1); intro H2; change (0 < x - y) in H2.
+cut (0 < 2).
+intro.
+generalize (Rmult_lt_0_compat (x - y) (/ 2) H2 (Rinv_0_lt_compat 2 H0));
+ intro H3; generalize (H ((x - y) * / 2) H3);
+ replace (y + (x - y) * / 2) with ((y + x) * / 2).
+intro H4;
+ generalize (Rmult_le_compat_l 2 x ((y + x) * / 2) (Rlt_le 0 2 H0) H4);
+ rewrite <- (Rmult_comm ((y + x) * / 2)); rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; replace (2 * x) with (x + x).
+rewrite (Rplus_comm y); intro H5; apply Rplus_le_reg_l with x; assumption.
+ring. 
+replace 2 with (INR 2); [ apply not_O_INR; discriminate | ring ].
+pattern y at 2 in |- *; replace y with (y / 2 + y / 2).
+unfold Rminus, Rdiv in |- *.
+repeat rewrite Rmult_plus_distr_r.
+ring.
+cut (forall z:R, 2 * z = z + z).
+intro.
+rewrite <- (H4 (y / 2)).
+unfold Rdiv in |- *.
+rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
+replace 2 with (INR 2).
+apply not_O_INR.
+discriminate.
+unfold INR in |- *; reflexivity.
+intro; ring.
+cut (0%nat <> 2%nat);
+ [ intro H0; generalize (lt_INR_0 2 (neq_O_lt 2 H0)); unfold INR in |- *;
+    intro; assumption
+ | discriminate ].
+Qed.
+
+(**********)
+Lemma completeness_weak :
+ forall E:R -> Prop,
+   bound E -> (exists x : R, E x) ->  exists m : R, is_lub E m.
+intros; elim (completeness E H H0); intros; split with x; assumption.
+Qed.
diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v
new file mode 100644
index 00000000..3b58c02f
--- /dev/null
+++ b/theories/Reals/RList.v
@@ -0,0 +1,744 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: RList.v,v 1.10.2.1 2004/07/16 19:31:11 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Open Local Scope R_scope.
+
+Inductive Rlist : Type :=
+  | nil : Rlist
+  | cons : R -> Rlist -> Rlist.
+
+Fixpoint In (x:R) (l:Rlist) {struct l} : Prop :=
+  match l with
+  | nil => False
+  | cons a l' => x = a \/ In x l'
+  end.
+
+Fixpoint Rlength (l:Rlist) : nat :=
+  match l with
+  | nil => 0%nat
+  | cons a l' => S (Rlength l')
+  end.
+
+Fixpoint MaxRlist (l:Rlist) : R :=
+  match l with
+  | nil => 0
+  | cons a l1 =>
+      match l1 with
+      | nil => a
+      | cons a' l2 => Rmax a (MaxRlist l1)
+      end
+  end.
+
+Fixpoint MinRlist (l:Rlist) : R :=
+  match l with
+  | nil => 1
+  | cons a l1 =>
+      match l1 with
+      | nil => a
+      | cons a' l2 => Rmin a (MinRlist l1)
+      end
+  end.
+
+Lemma MaxRlist_P1 : forall (l:Rlist) (x:R), In x l -> x <= MaxRlist l.
+intros; induction  l as [| r l Hrecl].
+simpl in H; elim H.
+induction  l as [| r0 l Hrecl0].
+simpl in H; elim H; intro.
+simpl in |- *; right; assumption.
+elim H0.
+replace (MaxRlist (cons r (cons r0 l))) with (Rmax r (MaxRlist (cons r0 l))).
+simpl in H; decompose [or] H.
+rewrite H0; apply RmaxLess1.
+unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); intro.
+apply Hrecl; simpl in |- *; tauto.
+apply Rle_trans with (MaxRlist (cons r0 l));
+ [ apply Hrecl; simpl in |- *; tauto | left; auto with real ].
+unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); intro.
+apply Hrecl; simpl in |- *; tauto.
+apply Rle_trans with (MaxRlist (cons r0 l));
+ [ apply Hrecl; simpl in |- *; tauto | left; auto with real ].
+reflexivity.
+Qed.
+
+Fixpoint AbsList (l:Rlist) (x:R) {struct l} : Rlist :=
+  match l with
+  | nil => nil
+  | cons a l' => cons (Rabs (a - x) / 2) (AbsList l' x)
+  end.
+
+Lemma MinRlist_P1 : forall (l:Rlist) (x:R), In x l -> MinRlist l <= x.
+intros; induction  l as [| r l Hrecl].
+simpl in H; elim H.
+induction  l as [| r0 l Hrecl0].
+simpl in H; elim H; intro.
+simpl in |- *; right; symmetry  in |- *; assumption.
+elim H0.
+replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))).
+simpl in H; decompose [or] H.
+rewrite H0; apply Rmin_l.
+unfold Rmin in |- *; case (Rle_dec r (MinRlist (cons r0 l))); intro.
+apply Rle_trans with (MinRlist (cons r0 l)).
+assumption.
+apply Hrecl; simpl in |- *; tauto.
+apply Hrecl; simpl in |- *; tauto.
+apply Rle_trans with (MinRlist (cons r0 l)).
+apply Rmin_r.
+apply Hrecl; simpl in |- *; tauto.
+reflexivity.
+Qed.
+
+Lemma AbsList_P1 :
+ forall (l:Rlist) (x y:R), In y l -> In (Rabs (y - x) / 2) (AbsList l x).
+intros; induction  l as [| r l Hrecl].
+elim H.
+simpl in |- *; simpl in H; elim H; intro.
+left; rewrite H0; reflexivity.
+right; apply Hrecl; assumption.
+Qed.
+
+Lemma MinRlist_P2 :
+ forall l:Rlist, (forall y:R, In y l -> 0 < y) -> 0 < MinRlist l.
+intros; induction  l as [| r l Hrecl].
+apply Rlt_0_1.
+induction  l as [| r0 l Hrecl0].
+simpl in |- *; apply H; simpl in |- *; tauto.
+replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))).
+unfold Rmin in |- *; case (Rle_dec r (MinRlist (cons r0 l))); intro.
+apply H; simpl in |- *; tauto.
+apply Hrecl; intros; apply H; simpl in |- *; simpl in H0; tauto.
+reflexivity.
+Qed.
+
+Lemma AbsList_P2 :
+ forall (l:Rlist) (x y:R),
+   In y (AbsList l x) ->  exists z : R, In z l /\ y = Rabs (z - x) / 2.
+intros; induction  l as [| r l Hrecl].
+elim H.
+elim H; intro.
+exists r; split.
+simpl in |- *; tauto.
+assumption.
+assert (H1 := Hrecl H0); elim H1; intros; elim H2; clear H2; intros;
+ exists x0; simpl in |- *; simpl in H2; tauto.
+Qed.
+
+Lemma MaxRlist_P2 :
+ forall l:Rlist, (exists y : R, In y l) -> In (MaxRlist l) l.
+intros; induction  l as [| r l Hrecl].
+simpl in H; elim H; trivial.
+induction  l as [| r0 l Hrecl0].
+simpl in |- *; left; reflexivity.
+change (In (Rmax r (MaxRlist (cons r0 l))) (cons r (cons r0 l))) in |- *;
+ unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); 
+ intro.
+right; apply Hrecl; exists r0; left; reflexivity.
+left; reflexivity.
+Qed.
+
+Fixpoint pos_Rl (l:Rlist) (i:nat) {struct l} : R :=
+  match l with
+  | nil => 0
+  | cons a l' => match i with
+                 | O => a
+                 | S i' => pos_Rl l' i'
+                 end
+  end.
+
+Lemma pos_Rl_P1 :
+ forall (l:Rlist) (a:R),
+   (0 < Rlength l)%nat ->
+   pos_Rl (cons a l) (Rlength l) = pos_Rl l (pred (Rlength l)).
+intros; induction  l as [| r l Hrecl];
+ [ elim (lt_n_O _ H)
+ | simpl in |- *; case (Rlength l); [ reflexivity | intro; reflexivity ] ].
+Qed.
+
+Lemma pos_Rl_P2 :
+ forall (l:Rlist) (x:R),
+   In x l <-> (exists i : nat, (i < Rlength l)%nat /\ x = pos_Rl l i).
+intros; induction  l as [| r l Hrecl].
+split; intro;
+ [ elim H | elim H; intros; elim H0; intros; elim (lt_n_O _ H1) ].
+split; intro.
+elim H; intro.
+exists 0%nat; split;
+ [ simpl in |- *; apply lt_O_Sn | simpl in |- *; apply H0 ].
+elim Hrecl; intros; assert (H3 := H1 H0); elim H3; intros; elim H4; intros;
+ exists (S x0); split;
+ [ simpl in |- *; apply lt_n_S; assumption | simpl in |- *; assumption ].
+elim H; intros; elim H0; intros; elim (zerop x0); intro.
+rewrite a in H2; simpl in H2; left; assumption.
+right; elim Hrecl; intros; apply H4; assert (H5 : S (pred x0) = x0).
+symmetry  in |- *; apply S_pred with 0%nat; assumption.
+exists (pred x0); split;
+ [ simpl in H1; apply lt_S_n; rewrite H5; assumption
+ | rewrite <- H5 in H2; simpl in H2; assumption ].
+Qed.
+
+Lemma Rlist_P1 :
+ forall (l:Rlist) (P:R -> R -> Prop),
+   (forall x:R, In x l ->  exists y : R, P x y) ->
+    exists l' : Rlist,
+     Rlength l = Rlength l' /\
+     (forall i:nat, (i < Rlength l)%nat -> P (pos_Rl l i) (pos_Rl l' i)).
+intros; induction  l as [| r l Hrecl].
+exists nil; intros; split;
+ [ reflexivity | intros; simpl in H0; elim (lt_n_O _ H0) ].
+assert (H0 : In r (cons r l)).
+simpl in |- *; left; reflexivity.
+assert (H1 := H _ H0);
+ assert (H2 : forall x:R, In x l ->  exists y : R, P x y).
+intros; apply H; simpl in |- *; right; assumption.
+assert (H3 := Hrecl H2); elim H1; intros; elim H3; intros; exists (cons x x0);
+ intros; elim H5; clear H5; intros; split.
+simpl in |- *; rewrite H5; reflexivity.
+intros; elim (zerop i); intro.
+rewrite a; simpl in |- *; assumption.
+assert (H8 : i = S (pred i)).
+apply S_pred with 0%nat; assumption.
+rewrite H8; simpl in |- *; apply H6; simpl in H7; apply lt_S_n; rewrite <- H8;
+ assumption.
+Qed.
+
+Definition ordered_Rlist (l:Rlist) : Prop :=
+  forall i:nat, (i < pred (Rlength l))%nat -> pos_Rl l i <= pos_Rl l (S i).
+
+Fixpoint insert (l:Rlist) (x:R) {struct l} : Rlist :=
+  match l with
+  | nil => cons x nil
+  | cons a l' =>
+      match Rle_dec a x with
+      | left _ => cons a (insert l' x)
+      | right _ => cons x l
+      end
+  end.
+
+Fixpoint cons_Rlist (l k:Rlist) {struct l} : Rlist :=
+  match l with
+  | nil => k
+  | cons a l' => cons a (cons_Rlist l' k)
+  end.
+
+Fixpoint cons_ORlist (k l:Rlist) {struct k} : Rlist :=
+  match k with
+  | nil => l
+  | cons a k' => cons_ORlist k' (insert l a)
+  end.
+
+Fixpoint app_Rlist (l:Rlist) (f:R -> R) {struct l} : Rlist :=
+  match l with
+  | nil => nil
+  | cons a l' => cons (f a) (app_Rlist l' f)
+  end.
+
+Fixpoint mid_Rlist (l:Rlist) (x:R) {struct l} : Rlist :=
+  match l with
+  | nil => nil
+  | cons a l' => cons ((x + a) / 2) (mid_Rlist l' a)
+  end.
+
+Definition Rtail (l:Rlist) : Rlist :=
+  match l with
+  | nil => nil
+  | cons a l' => l'
+  end.
+
+Definition FF (l:Rlist) (f:R -> R) : Rlist :=
+  match l with
+  | nil => nil
+  | cons a l' => app_Rlist (mid_Rlist l' a) f
+  end.
+
+Lemma RList_P0 :
+ forall (l:Rlist) (a:R),
+   pos_Rl (insert l a) 0 = a \/ pos_Rl (insert l a) 0 = pos_Rl l 0.
+intros; induction  l as [| r l Hrecl];
+ [ left; reflexivity
+ | simpl in |- *; case (Rle_dec r a); intro;
+    [ right; reflexivity | left; reflexivity ] ].
+Qed.
+
+Lemma RList_P1 :
+ forall (l:Rlist) (a:R), ordered_Rlist l -> ordered_Rlist (insert l a).
+intros; induction  l as [| r l Hrecl].
+simpl in |- *; unfold ordered_Rlist in |- *; intros; simpl in H0;
+ elim (lt_n_O _ H0).
+simpl in |- *; case (Rle_dec r a); intro.
+assert (H1 : ordered_Rlist l).
+unfold ordered_Rlist in |- *; unfold ordered_Rlist in H; intros;
+ assert (H1 : (S i < pred (Rlength (cons r l)))%nat);
+ [ simpl in |- *; replace (Rlength l) with (S (pred (Rlength l)));
+    [ apply lt_n_S; assumption
+    | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+       intro; rewrite <- H1 in H0; simpl in H0; elim (lt_n_O _ H0) ]
+ | apply (H _ H1) ].
+assert (H2 := Hrecl H1); unfold ordered_Rlist in |- *; intros;
+ induction  i as [| i Hreci].
+simpl in |- *; assert (H3 := RList_P0 l a); elim H3; intro.
+rewrite H4; assumption.
+induction  l as [| r1 l Hrecl0];
+ [ simpl in |- *; assumption
+ | rewrite H4; apply (H 0%nat); simpl in |- *; apply lt_O_Sn ].
+simpl in |- *; apply H2; simpl in H0; apply lt_S_n;
+ replace (S (pred (Rlength (insert l a)))) with (Rlength (insert l a));
+ [ assumption
+ | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+    rewrite <- H3 in H0; elim (lt_n_O _ H0) ].
+unfold ordered_Rlist in |- *; intros; induction  i as [| i Hreci];
+ [ simpl in |- *; auto with real
+ | change (pos_Rl (cons r l) i <= pos_Rl (cons r l) (S i)) in |- *; apply H;
+    simpl in H0; simpl in |- *; apply (lt_S_n _ _ H0) ].
+Qed.
+
+Lemma RList_P2 :
+ forall l1 l2:Rlist, ordered_Rlist l2 -> ordered_Rlist (cons_ORlist l1 l2).
+simple induction l1;
+ [ intros; simpl in |- *; apply H
+ | intros; simpl in |- *; apply H; apply RList_P1; assumption ].
+Qed.
+
+Lemma RList_P3 :
+ forall (l:Rlist) (x:R),
+   In x l <-> (exists i : nat, x = pos_Rl l i /\ (i < Rlength l)%nat).
+intros; split; intro;
+ [ induction  l as [| r l Hrecl] | induction  l as [| r l Hrecl] ].
+elim H.
+elim H; intro;
+ [ exists 0%nat; split; [ apply H0 | simpl in |- *; apply lt_O_Sn ]
+ | elim (Hrecl H0); intros; elim H1; clear H1; intros; exists (S x0); split;
+    [ apply H1 | simpl in |- *; apply lt_n_S; assumption ] ].
+elim H; intros; elim H0; intros; elim (lt_n_O _ H2).
+simpl in |- *; elim H; intros; elim H0; clear H0; intros;
+ induction  x0 as [| x0 Hrecx0];
+ [ left; apply H0
+ | right; apply Hrecl; exists x0; split;
+    [ apply H0 | simpl in H1; apply lt_S_n; assumption ] ].
+Qed.
+
+Lemma RList_P4 :
+ forall (l1:Rlist) (a:R), ordered_Rlist (cons a l1) -> ordered_Rlist l1.
+intros; unfold ordered_Rlist in |- *; intros; apply (H (S i)); simpl in |- *;
+ replace (Rlength l1) with (S (pred (Rlength l1)));
+ [ apply lt_n_S; assumption
+ | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+    intro; rewrite <- H1 in H0; elim (lt_n_O _ H0) ].
+Qed.
+
+Lemma RList_P5 :
+ forall (l:Rlist) (x:R), ordered_Rlist l -> In x l -> pos_Rl l 0 <= x.
+intros; induction  l as [| r l Hrecl];
+ [ elim H0
+ | simpl in |- *; elim H0; intro;
+    [ rewrite H1; right; reflexivity
+    | apply Rle_trans with (pos_Rl l 0);
+       [ apply (H 0%nat); simpl in |- *; induction  l as [| r0 l Hrecl0];
+          [ elim H1 | simpl in |- *; apply lt_O_Sn ]
+       | apply Hrecl; [ eapply RList_P4; apply H | assumption ] ] ] ].
+Qed.
+
+Lemma RList_P6 :
+ forall l:Rlist,
+   ordered_Rlist l <->
+   (forall i j:nat,
+      (i <= j)%nat -> (j < Rlength l)%nat -> pos_Rl l i <= pos_Rl l j).
+simple induction l; split; intro.
+intros; right; reflexivity.
+unfold ordered_Rlist in |- *; intros; simpl in H0; elim (lt_n_O _ H0).
+intros; induction  i as [| i Hreci];
+ [ induction  j as [| j Hrecj];
+    [ right; reflexivity
+    | simpl in |- *; apply Rle_trans with (pos_Rl r0 0);
+       [ apply (H0 0%nat); simpl in |- *; simpl in H2; apply neq_O_lt;
+          red in |- *; intro; rewrite <- H3 in H2;
+          assert (H4 := lt_S_n _ _ H2); elim (lt_n_O _ H4)
+       | elim H; intros; apply H3;
+          [ apply RList_P4 with r; assumption
+          | apply le_O_n
+          | simpl in H2; apply lt_S_n; assumption ] ] ]
+ | induction  j as [| j Hrecj];
+    [ elim (le_Sn_O _ H1)
+    | simpl in |- *; elim H; intros; apply H3;
+       [ apply RList_P4 with r; assumption
+       | apply le_S_n; assumption
+       | simpl in H2; apply lt_S_n; assumption ] ] ].
+unfold ordered_Rlist in |- *; intros; apply H0;
+ [ apply le_n_Sn | simpl in |- *; simpl in H1; apply lt_n_S; assumption ].
+Qed.
+
+Lemma RList_P7 :
+ forall (l:Rlist) (x:R),
+   ordered_Rlist l -> In x l -> x <= pos_Rl l (pred (Rlength l)).
+intros; assert (H1 := RList_P6 l); elim H1; intros H2 _; assert (H3 := H2 H);
+ clear H1 H2; assert (H1 := RList_P3 l x); elim H1; 
+ clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4; 
+ intros; elim H4; clear H4; intros; rewrite H4;
+ assert (H6 : Rlength l = S (pred (Rlength l))).
+apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+ rewrite <- H6 in H5; elim (lt_n_O _ H5).
+apply H3;
+ [ rewrite H6 in H5; apply lt_n_Sm_le; assumption
+ | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H7 in H5;
+    elim (lt_n_O _ H5) ].
+Qed.
+
+Lemma RList_P8 :
+ forall (l:Rlist) (a x:R), In x (insert l a) <-> x = a \/ In x l.
+simple induction l.
+intros; split; intro; simpl in H; apply H.
+intros; split; intro;
+ [ simpl in H0; generalize H0; case (Rle_dec r a); intros;
+    [ simpl in H1; elim H1; intro;
+       [ right; left; assumption
+       | elim (H a x); intros; elim (H3 H2); intro;
+          [ left; assumption | right; right; assumption ] ]
+    | simpl in H1; decompose [or] H1;
+       [ left; assumption
+       | right; left; assumption
+       | right; right; assumption ] ]
+ | simpl in |- *; case (Rle_dec r a); intro;
+    [ simpl in H0; decompose [or] H0;
+       [ right; elim (H a x); intros; apply H3; left
+       | left
+       | right; elim (H a x); intros; apply H3; right ]
+    | simpl in H0; decompose [or] H0; [ left | right; left | right; right ] ];
+    assumption ].
+Qed.
+
+Lemma RList_P9 :
+ forall (l1 l2:Rlist) (x:R), In x (cons_ORlist l1 l2) <-> In x l1 \/ In x l2.
+simple induction l1.
+intros; split; intro;
+ [ simpl in H; right; assumption
+ | simpl in |- *; elim H; intro; [ elim H0 | assumption ] ].
+intros; split.
+simpl in |- *; intros; elim (H (insert l2 r) x); intros; assert (H3 := H1 H0);
+ elim H3; intro;
+ [ left; right; assumption
+ | elim (RList_P8 l2 r x); intros H5 _; assert (H6 := H5 H4); elim H6; intro;
+    [ left; left; assumption | right; assumption ] ].
+intro; simpl in |- *; elim (H (insert l2 r) x); intros _ H1; apply H1;
+ elim H0; intro;
+ [ elim H2; intro;
+    [ right; elim (RList_P8 l2 r x); intros _ H4; apply H4; left; assumption
+    | left; assumption ]
+ | right; elim (RList_P8 l2 r x); intros _ H3; apply H3; right; assumption ].
+Qed.
+
+Lemma RList_P10 :
+ forall (l:Rlist) (a:R), Rlength (insert l a) = S (Rlength l).
+intros; induction  l as [| r l Hrecl];
+ [ reflexivity
+ | simpl in |- *; case (Rle_dec r a); intro;
+    [ simpl in |- *; rewrite Hrecl; reflexivity | reflexivity ] ].
+Qed.
+
+Lemma RList_P11 :
+ forall l1 l2:Rlist,
+   Rlength (cons_ORlist l1 l2) = (Rlength l1 + Rlength l2)%nat.
+simple induction l1;
+ [ intro; reflexivity
+ | intros; simpl in |- *; rewrite (H (insert l2 r)); rewrite RList_P10;
+    apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; 
+    rewrite S_INR; ring ].
+Qed.
+
+Lemma RList_P12 :
+ forall (l:Rlist) (i:nat) (f:R -> R),
+   (i < Rlength l)%nat -> pos_Rl (app_Rlist l f) i = f (pos_Rl l i).
+simple induction l;
+ [ intros; elim (lt_n_O _ H)
+ | intros; induction  i as [| i Hreci];
+    [ reflexivity | simpl in |- *; apply H; apply lt_S_n; apply H0 ] ].
+Qed.
+
+Lemma RList_P13 :
+ forall (l:Rlist) (i:nat) (a:R),
+   (i < pred (Rlength l))%nat ->
+   pos_Rl (mid_Rlist l a) (S i) = (pos_Rl l i + pos_Rl l (S i)) / 2.
+simple induction l.
+intros; simpl in H; elim (lt_n_O _ H).
+simple induction r0.
+intros; simpl in H0; elim (lt_n_O _ H0).
+intros; simpl in H1; induction  i as [| i Hreci].
+reflexivity.
+change
+  (pos_Rl (mid_Rlist (cons r1 r2) r) (S i) =
+   (pos_Rl (cons r1 r2) i + pos_Rl (cons r1 r2) (S i)) / 2) 
+ in |- *; apply H0; simpl in |- *; apply lt_S_n; assumption.
+Qed.
+
+Lemma RList_P14 : forall (l:Rlist) (a:R), Rlength (mid_Rlist l a) = Rlength l.
+simple induction l; intros;
+ [ reflexivity | simpl in |- *; rewrite (H r); reflexivity ].
+Qed.
+
+Lemma RList_P15 :
+ forall l1 l2:Rlist,
+   ordered_Rlist l1 ->
+   ordered_Rlist l2 ->
+   pos_Rl l1 0 = pos_Rl l2 0 -> pos_Rl (cons_ORlist l1 l2) 0 = pos_Rl l1 0.
+intros; apply Rle_antisym.
+induction  l1 as [| r l1 Hrecl1];
+ [ simpl in |- *; simpl in H1; right; symmetry  in |- *; assumption
+ | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) 0)); intros;
+    assert
+     (H4 :
+      In (pos_Rl (cons r l1) 0) (cons r l1) \/ In (pos_Rl (cons r l1) 0) l2);
+    [ left; left; reflexivity
+    | assert (H5 := H3 H4); apply RList_P5;
+       [ apply RList_P2; assumption | assumption ] ] ].
+induction  l1 as [| r l1 Hrecl1];
+ [ simpl in |- *; simpl in H1; right; assumption
+ | assert
+    (H2 :
+     In (pos_Rl (cons_ORlist (cons r l1) l2) 0) (cons_ORlist (cons r l1) l2));
+    [ elim
+       (RList_P3 (cons_ORlist (cons r l1) l2)
+          (pos_Rl (cons_ORlist (cons r l1) l2) 0)); 
+       intros; apply H3; exists 0%nat; split;
+       [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ]
+    | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) 0));
+       intros; assert (H5 := H3 H2); elim H5; intro;
+       [ apply RList_P5; assumption
+       | rewrite H1; apply RList_P5; assumption ] ] ].
+Qed.
+
+Lemma RList_P16 :
+ forall l1 l2:Rlist,
+   ordered_Rlist l1 ->
+   ordered_Rlist l2 ->
+   pos_Rl l1 (pred (Rlength l1)) = pos_Rl l2 (pred (Rlength l2)) ->
+   pos_Rl (cons_ORlist l1 l2) (pred (Rlength (cons_ORlist l1 l2))) =
+   pos_Rl l1 (pred (Rlength l1)).
+intros; apply Rle_antisym.
+induction  l1 as [| r l1 Hrecl1].
+simpl in |- *; simpl in H1; right; symmetry  in |- *; assumption. 
+assert
+ (H2 :
+  In
+    (pos_Rl (cons_ORlist (cons r l1) l2)
+       (pred (Rlength (cons_ORlist (cons r l1) l2))))
+    (cons_ORlist (cons r l1) l2));
+ [ elim
+    (RList_P3 (cons_ORlist (cons r l1) l2)
+       (pos_Rl (cons_ORlist (cons r l1) l2)
+          (pred (Rlength (cons_ORlist (cons r l1) l2))))); 
+    intros; apply H3; exists (pred (Rlength (cons_ORlist (cons r l1) l2)));
+    split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ]
+ | elim
+    (RList_P9 (cons r l1) l2
+       (pos_Rl (cons_ORlist (cons r l1) l2)
+          (pred (Rlength (cons_ORlist (cons r l1) l2))))); 
+    intros; assert (H5 := H3 H2); elim H5; intro;
+    [ apply RList_P7; assumption | rewrite H1; apply RList_P7; assumption ] ].
+induction  l1 as [| r l1 Hrecl1].
+simpl in |- *; simpl in H1; right; assumption.
+elim
+ (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))));
+ intros;
+ assert
+  (H4 :
+   In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) (cons r l1) \/
+   In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) l2);
+ [ left; change (In (pos_Rl (cons r l1) (Rlength l1)) (cons r l1)) in |- *;
+    elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1))); 
+    intros; apply H5; exists (Rlength l1); split;
+    [ reflexivity | simpl in |- *; apply lt_n_Sn ]
+ | assert (H5 := H3 H4); apply RList_P7;
+    [ apply RList_P2; assumption
+    | elim
+       (RList_P9 (cons r l1) l2
+          (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); 
+       intros; apply H7; left;
+       elim
+        (RList_P3 (cons r l1)
+           (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); 
+       intros; apply H9; exists (pred (Rlength (cons r l1))); 
+       split; [ reflexivity | simpl in |- *; apply lt_n_Sn ] ] ].
+Qed.
+
+Lemma RList_P17 :
+ forall (l1:Rlist) (x:R) (i:nat),
+   ordered_Rlist l1 ->
+   In x l1 ->
+   pos_Rl l1 i < x -> (i < pred (Rlength l1))%nat -> pos_Rl l1 (S i) <= x.
+simple induction l1.
+intros; elim H0.
+intros; induction  i as [| i Hreci].
+simpl in |- *; elim H1; intro;
+ [ simpl in H2; rewrite H4 in H2; elim (Rlt_irrefl _ H2)
+ | apply RList_P5; [ apply RList_P4 with r; assumption | assumption ] ].
+simpl in |- *; simpl in H2; elim H1; intro.
+rewrite H4 in H2; assert (H5 : r <= pos_Rl r0 i);
+ [ apply Rle_trans with (pos_Rl r0 0);
+    [ apply (H0 0%nat); simpl in |- *; simpl in H3; apply neq_O_lt;
+       red in |- *; intro; rewrite <- H5 in H3; elim (lt_n_O _ H3)
+    | elim (RList_P6 r0); intros; apply H5;
+       [ apply RList_P4 with r; assumption
+       | apply le_O_n
+       | simpl in H3; apply lt_S_n; apply lt_trans with (Rlength r0);
+          [ apply H3 | apply lt_n_Sn ] ] ]
+ | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H2)) ].
+apply H; try assumption;
+ [ apply RList_P4 with r; assumption
+ | simpl in H3; apply lt_S_n;
+    replace (S (pred (Rlength r0))) with (Rlength r0);
+    [ apply H3
+    | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+       rewrite <- H5 in H3; elim (lt_n_O _ H3) ] ].
+Qed.
+
+Lemma RList_P18 :
+ forall (l:Rlist) (f:R -> R), Rlength (app_Rlist l f) = Rlength l.
+simple induction l; intros;
+ [ reflexivity | simpl in |- *; rewrite H; reflexivity ].
+Qed.
+
+Lemma RList_P19 :
+ forall l:Rlist,
+   l <> nil ->  exists r : R, (exists r0 : Rlist, l = cons r r0).
+intros; induction  l as [| r l Hrecl];
+ [ elim H; reflexivity | exists r; exists l; reflexivity ].
+Qed.
+
+Lemma RList_P20 :
+ forall l:Rlist,
+   (2 <= Rlength l)%nat ->
+    exists r : R,
+     (exists r1 : R, (exists l' : Rlist, l = cons r (cons r1 l'))). 
+intros; induction  l as [| r l Hrecl];
+ [ simpl in H; elim (le_Sn_O _ H)
+ | induction  l as [| r0 l Hrecl0];
+    [ simpl in H; elim (le_Sn_O _ (le_S_n _ _ H))
+    | exists r; exists r0; exists l; reflexivity ] ].
+Qed.
+
+Lemma RList_P21 : forall l l':Rlist, l = l' -> Rtail l = Rtail l'.
+intros; rewrite H; reflexivity.
+Qed.
+
+Lemma RList_P22 :
+ forall l1 l2:Rlist, l1 <> nil -> pos_Rl (cons_Rlist l1 l2) 0 = pos_Rl l1 0.
+simple induction l1; [ intros; elim H; reflexivity | intros; reflexivity ].
+Qed.
+
+Lemma RList_P23 :
+ forall l1 l2:Rlist,
+   Rlength (cons_Rlist l1 l2) = (Rlength l1 + Rlength l2)%nat.
+simple induction l1;
+ [ intro; reflexivity | intros; simpl in |- *; rewrite H; reflexivity ].
+Qed.
+
+Lemma RList_P24 :
+ forall l1 l2:Rlist,
+   l2 <> nil ->
+   pos_Rl (cons_Rlist l1 l2) (pred (Rlength (cons_Rlist l1 l2))) =
+   pos_Rl l2 (pred (Rlength l2)).
+simple induction l1.
+intros; reflexivity.
+intros; rewrite <- (H l2 H0); induction  l2 as [| r1 l2 Hrecl2].
+elim H0; reflexivity.
+do 2 rewrite RList_P23;
+ replace (Rlength (cons r r0) + Rlength (cons r1 l2))%nat with
+  (S (S (Rlength r0 + Rlength l2)));
+ [ replace (Rlength r0 + Rlength (cons r1 l2))%nat with
+    (S (Rlength r0 + Rlength l2));
+    [ reflexivity
+    | simpl in |- *; apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR;
+       rewrite S_INR; ring ]
+ | simpl in |- *; apply INR_eq; do 3 rewrite S_INR; do 2 rewrite plus_INR;
+    rewrite S_INR; ring ].
+Qed.
+
+Lemma RList_P25 :
+ forall l1 l2:Rlist,
+   ordered_Rlist l1 ->
+   ordered_Rlist l2 ->
+   pos_Rl l1 (pred (Rlength l1)) <= pos_Rl l2 0 ->
+   ordered_Rlist (cons_Rlist l1 l2).
+simple induction l1.
+intros; simpl in |- *; assumption.
+simple induction r0.
+intros; simpl in |- *; simpl in H2; unfold ordered_Rlist in |- *; intros;
+ simpl in H3.
+induction  i as [| i Hreci].
+simpl in |- *; assumption.
+change (pos_Rl l2 i <= pos_Rl l2 (S i)) in |- *; apply (H1 i); apply lt_S_n;
+ replace (S (pred (Rlength l2))) with (Rlength l2);
+ [ assumption
+ | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+    rewrite <- H4 in H3; elim (lt_n_O _ H3) ].
+intros; clear H; assert (H : ordered_Rlist (cons_Rlist (cons r1 r2) l2)).
+apply H0; try assumption.
+apply RList_P4 with r; assumption.
+unfold ordered_Rlist in |- *; intros; simpl in H4;
+ induction  i as [| i Hreci].
+simpl in |- *; apply (H1 0%nat); simpl in |- *; apply lt_O_Sn.
+change
+  (pos_Rl (cons_Rlist (cons r1 r2) l2) i <=
+   pos_Rl (cons_Rlist (cons r1 r2) l2) (S i)) in |- *; 
+ apply (H i); simpl in |- *; apply lt_S_n; assumption.
+Qed.
+
+Lemma RList_P26 :
+ forall (l1 l2:Rlist) (i:nat),
+   (i < Rlength l1)%nat -> pos_Rl (cons_Rlist l1 l2) i = pos_Rl l1 i.
+simple induction l1.
+intros; elim (lt_n_O _ H).
+intros; induction  i as [| i Hreci].
+apply RList_P22; discriminate.
+apply (H l2 i); simpl in H0; apply lt_S_n; assumption.
+Qed.
+
+Lemma RList_P27 :
+ forall l1 l2 l3:Rlist,
+   cons_Rlist l1 (cons_Rlist l2 l3) = cons_Rlist (cons_Rlist l1 l2) l3.
+simple induction l1; intros;
+ [ reflexivity | simpl in |- *; rewrite (H l2 l3); reflexivity ].
+Qed.
+
+Lemma RList_P28 : forall l:Rlist, cons_Rlist l nil = l.
+simple induction l;
+ [ reflexivity | intros; simpl in |- *; rewrite H; reflexivity ].
+Qed.
+
+Lemma RList_P29 :
+ forall (l2 l1:Rlist) (i:nat),
+   (Rlength l1 <= i)%nat ->
+   (i < Rlength (cons_Rlist l1 l2))%nat ->
+   pos_Rl (cons_Rlist l1 l2) i = pos_Rl l2 (i - Rlength l1).
+simple induction l2.
+intros; rewrite RList_P28 in H0; elim (lt_irrefl _ (le_lt_trans _ _ _ H H0)).
+intros;
+ replace (cons_Rlist l1 (cons r r0)) with
+  (cons_Rlist (cons_Rlist l1 (cons r nil)) r0).
+inversion H0.
+rewrite <- minus_n_n; simpl in |- *; rewrite RList_P26.
+clear l2 r0 H i H0 H1 H2; induction  l1 as [| r0 l1 Hrecl1].
+reflexivity.
+simpl in |- *; assumption.
+rewrite RList_P23; rewrite plus_comm; simpl in |- *; apply lt_n_Sn.
+replace (S m - Rlength l1)%nat with (S (S m - S (Rlength l1))).
+rewrite H3; simpl in |- *;
+ replace (S (Rlength l1)) with (Rlength (cons_Rlist l1 (cons r nil))).
+apply (H (cons_Rlist l1 (cons r nil)) i).
+rewrite RList_P23; rewrite plus_comm; simpl in |- *; rewrite <- H3;
+ apply le_n_S; assumption.
+repeat rewrite RList_P23; simpl in |- *; rewrite RList_P23 in H1;
+ rewrite plus_comm in H1; simpl in H1; rewrite (plus_comm (Rlength l1));
+ simpl in |- *; rewrite plus_comm; apply H1.
+rewrite RList_P23; rewrite plus_comm; reflexivity.
+change (S (m - Rlength l1) = (S m - Rlength l1)%nat) in |- *;
+ apply minus_Sn_m; assumption.
+replace (cons r r0) with (cons_Rlist (cons r nil) r0);
+ [ symmetry  in |- *; apply RList_P27 | reflexivity ].
+Qed.
diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v
new file mode 100644
index 00000000..289b1921
--- /dev/null
+++ b/theories/Reals/R_Ifp.v
@@ -0,0 +1,545 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: R_Ifp.v,v 1.14.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(**********************************************************)
+(** Complements for the reals.Integer and fractional part *)
+(*                                                        *)
+(**********************************************************)
+
+Require Import Rbase.
+Require Import Omega.
+Open Local Scope R_scope.
+
+(*********************************************************)
+(**      Fractional part                                 *)
+(*********************************************************)
+
+(**********)
+Definition Int_part (r:R) : Z := (up r - 1)%Z.
+
+(**********)
+Definition frac_part (r:R) : R := r - IZR (Int_part r).
+
+(**********)
+Lemma tech_up : forall (r:R) (z:Z), r < IZR z -> IZR z <= r + 1 -> z = up r.
+intros; generalize (archimed r); intro; elim H1; intros; clear H1;
+ unfold Rgt in H2; unfold Rminus in H3;
+ generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3); 
+ intro; clear H3; rewrite (Rplus_comm (IZR (up r)) (- r)) in H1;
+ rewrite <- (Rplus_assoc r (- r) (IZR (up r))) in H1;
+ rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r))); 
+ intros a b; rewrite b in H1; clear a b; apply (single_z_r_R1 r z (up r));
+ auto with zarith real.
+Qed.
+
+(**********)
+Lemma up_tech :
+ forall (r:R) (z:Z), IZR z <= r -> r < IZR (z + 1) -> (z + 1)%Z = up r.
+intros; generalize (Rplus_le_compat_l 1 (IZR z) r H); intro; clear H;
+ rewrite (Rplus_comm 1 (IZR z)) in H1; rewrite (Rplus_comm 1 r) in H1;
+ cut (1 = IZR 1); auto with zarith real.
+intro; generalize H1; pattern 1 at 1 in |- *; rewrite H; intro; clear H H1;
+ rewrite <- (plus_IZR z 1) in H2; apply (tech_up r (z + 1));
+ auto with zarith real.
+Qed.
+
+(**********)
+Lemma fp_R0 : frac_part 0 = 0.
+unfold frac_part in |- *; unfold Int_part in |- *; elim (archimed 0); intros;
+ unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1))); 
+ intros a b; rewrite b; clear a b; rewrite <- Z_R_minus; 
+ cut (up 0 = 1%Z).
+intro; rewrite H1;
+ rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1))); 
+ apply Ropp_0. 
+elim (archimed 0); intros; clear H2; unfold Rgt in H1;
+ rewrite (Rminus_0_r (IZR (up 0))) in H0; generalize (lt_O_IZR (up 0) H1);
+ intro; clear H1; generalize (le_IZR_R1 (up 0) H0); 
+ intro; clear H H0; omega.
+Qed.
+
+(**********)
+Lemma for_base_fp : forall r:R, IZR (up r) - r > 0 /\ IZR (up r) - r <= 1.
+intro; split; cut (IZR (up r) > r /\ IZR (up r) - r <= 1).
+intro; elim H; intros.
+apply (Rgt_minus (IZR (up r)) r H0).
+apply archimed.
+intro; elim H; intros.
+exact H1.
+apply archimed.
+Qed.
+
+(**********)
+Lemma base_fp : forall r:R, frac_part r >= 0 /\ frac_part r < 1.
+intro; unfold frac_part in |- *; unfold Int_part in |- *; split.
+     (*sup a O*)
+cut (r - IZR (up r) >= -1).
+rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
+ rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
+ fold (r - IZR (up r)) in |- *; fold (r - IZR (up r) - -1) in |- *;
+ apply Rge_minus; auto with zarith real.
+rewrite <- Ropp_minus_distr; apply Ropp_le_ge_contravar; elim (for_base_fp r);
+ auto with zarith real.
+    (*inf a 1*) 
+cut (r - IZR (up r) < 0).
+rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
+ rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
+ fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive; 
+ elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *; 
+ rewrite <- a; clear a b; rewrite (Rplus_comm (r - IZR (up r)) 1);
+ apply Rplus_lt_compat_l; auto with zarith real.
+elim (for_base_fp r); intros; rewrite <- Ropp_0; rewrite <- Ropp_minus_distr;
+ apply Ropp_gt_lt_contravar; auto with zarith real.
+Qed.
+
+(*********************************************************)
+(**      Properties                                      *)
+(*********************************************************)
+
+(**********)
+Lemma base_Int_part :
+ forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1. 
+intro; unfold Int_part in |- *; elim (archimed r); intros.
+split; rewrite <- (Z_R_minus (up r) 1); simpl in |- *.
+generalize (Rle_minus (IZR (up r) - r) 1 H0); intro; unfold Rminus in H1;
+ rewrite (Rplus_assoc (IZR (up r)) (- r) (-1)) in H1;
+ rewrite (Rplus_comm (- r) (-1)) in H1;
+ rewrite <- (Rplus_assoc (IZR (up r)) (-1) (- r)) in H1;
+ fold (IZR (up r) - 1) in H1; fold (IZR (up r) - 1 - r) in H1;
+ apply Rminus_le; auto with zarith real.
+generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro;
+ rewrite (Rplus_comm (-1) (IZR (up r))) in H1;
+ generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1); 
+ intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2;
+ fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2;
+ rewrite (Rplus_comm (- r) (-1 + r)) in H2;
+ rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2;
+ elim (Rplus_ne (-1)); intros a b; rewrite a in H2; 
+ clear a b; auto with zarith real.  
+Qed.
+
+(**********)
+Lemma Int_part_INR : forall n:nat, Int_part (INR n) = Z_of_nat n.
+intros n; unfold Int_part in |- *.
+cut (up (INR n) = (Z_of_nat n + Z_of_nat 1)%Z).
+intros H'; rewrite H'; simpl in |- *; ring.
+apply sym_equal; apply tech_up; auto.
+replace (Z_of_nat n + Z_of_nat 1)%Z with (Z_of_nat (S n)).
+repeat rewrite <- INR_IZR_INZ.
+apply lt_INR; auto.
+rewrite Zplus_comm; rewrite <- Znat.inj_plus; simpl in |- *; auto.
+rewrite plus_IZR; simpl in |- *; auto with real.
+repeat rewrite <- INR_IZR_INZ; auto with real.
+Qed.
+
+(**********)
+Lemma fp_nat : forall r:R, frac_part r = 0 ->  exists c : Z, r = IZR c.
+unfold frac_part in |- *; intros; split with (Int_part r);
+ apply Rminus_diag_uniq; auto with zarith real.
+Qed.
+
+(**********)
+Lemma R0_fp_O : forall r:R, 0 <> frac_part r -> 0 <> r.
+red in |- *; intros; rewrite <- H0 in H; generalize fp_R0; intro;
+ auto with zarith real.
+Qed.
+
+(**********)
+Lemma Rminus_Int_part1 :
+ forall r1 r2:R,
+   frac_part r1 >= frac_part r2 ->
+   Int_part (r1 - r2) = (Int_part r1 - Int_part r2)%Z.
+intros; elim (base_fp r1); elim (base_fp r2); intros;
+ generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
+ generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); 
+ intro; clear H4; rewrite Ropp_0 in H0;
+ generalize (Rge_le 0 (- frac_part r2) H0); intro; 
+ clear H0; generalize (Rge_le (frac_part r1) 0 H2); 
+ intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
+ intro; clear H1; unfold Rgt in H2;
+ generalize
+  (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
+ intro; elim H1; intros; clear H1; elim (Rplus_ne 1); 
+ intros a b; rewrite a in H6; clear a b H5;
+ generalize (Rge_minus (frac_part r1) (frac_part r2) H); 
+ intro; clear H; fold (frac_part r1 - frac_part r2) in H6;
+ generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1); 
+ intro; clear H1 H3 H4 H0 H2; unfold frac_part in H6, H;
+ unfold Rminus in H6, H;
+ rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H;
+ rewrite (Ropp_involutive (IZR (Int_part r2))) in H;
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
+   in H;
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
+   in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H;
+ rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
+ rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
+   in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
+ fold (r1 - r2) in H; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H;
+ generalize
+  (Rplus_le_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) 0
+     (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H); 
+ intro; clear H;
+ rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
+ rewrite <-
+  (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
+     (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
+   in H0; unfold Rminus in H0; fold (r1 - r2) in H0;
+ rewrite
+  (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
+     (IZR (Int_part r2) + - IZR (Int_part r1))) in H0;
+ rewrite <-
+  (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
+     (- IZR (Int_part r1))) in H0;
+ rewrite (Rplus_opp_l (IZR (Int_part r2))) in H0;
+ elim (Rplus_ne (- IZR (Int_part r1))); intros a b; 
+ rewrite b in H0; clear a b;
+ elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2))); 
+ intros a b; rewrite a in H0; clear a b;
+ rewrite (Rplus_opp_r (IZR (Int_part r1))) in H0; elim (Rplus_ne (r1 - r2));
+ intros a b; rewrite b in H0; clear a b;
+ fold (IZR (Int_part r1) - IZR (Int_part r2)) in H0;
+ rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H6;
+ rewrite (Ropp_involutive (IZR (Int_part r2))) in H6;
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
+   in H6;
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
+   in H6; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H6;
+ rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
+ rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
+   in H6;
+ rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
+ fold (r1 - r2) in H6; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H6;
+ generalize
+  (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
+     (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6); 
+ intro; clear H6;
+ rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
+ rewrite <-
+  (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
+     (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
+   in H;
+ rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
+ rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H;
+ elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; 
+ clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
+ rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; 
+ cut (1 = IZR 1); auto with zarith real.
+intro; rewrite H1 in H; clear H1;
+ rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H;
+ generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); 
+ intros; clear H H0; unfold Int_part at 1 in |- *; 
+ omega.
+Qed.
+
+(**********)
+Lemma Rminus_Int_part2 :
+ forall r1 r2:R,
+   frac_part r1 < frac_part r2 ->
+   Int_part (r1 - r2) = (Int_part r1 - Int_part r2 - 1)%Z.
+intros; elim (base_fp r1); elim (base_fp r2); intros;
+ generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
+ generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); 
+ intro; clear H4; rewrite Ropp_0 in H0;
+ generalize (Rge_le 0 (- frac_part r2) H0); intro; 
+ clear H0; generalize (Rge_le (frac_part r1) 0 H2); 
+ intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
+ intro; clear H1; unfold Rgt in H2;
+ generalize
+  (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
+ intro; elim H1; intros; clear H1; elim (Rplus_ne (-1)); 
+ intros a b; rewrite b in H5; clear a b H6;
+ generalize (Rlt_minus (frac_part r1) (frac_part r2) H); 
+ intro; clear H; fold (frac_part r1 - frac_part r2) in H5; 
+ clear H3 H4 H0 H2; unfold frac_part in H5, H1; unfold Rminus in H5, H1;
+ rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H5;
+ rewrite (Ropp_involutive (IZR (Int_part r2))) in H5;
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
+   in H5;
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
+   in H5; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H5;
+ rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
+ rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
+   in H5;
+ rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
+ fold (r1 - r2) in H5; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H5;
+ generalize
+  (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) (-1)
+     (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5); 
+ intro; clear H5;
+ rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
+ rewrite <-
+  (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
+     (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
+   in H; unfold Rminus in H; fold (r1 - r2) in H;
+ rewrite
+  (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
+     (IZR (Int_part r2) + - IZR (Int_part r1))) in H;
+ rewrite <-
+  (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
+     (- IZR (Int_part r1))) in H;
+ rewrite (Rplus_opp_l (IZR (Int_part r2))) in H;
+ elim (Rplus_ne (- IZR (Int_part r1))); intros a b; 
+ rewrite b in H; clear a b; rewrite (Rplus_opp_r (IZR (Int_part r1))) in H;
+ elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; 
+ clear a b; fold (IZR (Int_part r1) - IZR (Int_part r2)) in H;
+ fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H;
+ rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H1;
+ rewrite (Ropp_involutive (IZR (Int_part r2))) in H1;
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
+   in H1;
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
+   in H1; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H1;
+ rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
+ rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
+   in H1;
+ rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
+ fold (r1 - r2) in H1; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H1;
+ generalize
+  (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
+     (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1); 
+ intro; clear H1;
+ rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
+ rewrite <-
+  (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
+     (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
+   in H0;
+ rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
+ rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0;
+ elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; 
+ clear a b; rewrite <- (Rplus_opp_l 1) in H0;
+ rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1)
+   in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0;
+ rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
+ rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; 
+ cut (1 = IZR 1); auto with zarith real.
+intro; rewrite H1 in H; rewrite H1 in H0; clear H1;
+ rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H;
+ rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0;
+ rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0;
+ generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H); 
+ intro; clear H;
+ generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0); 
+ intros; clear H0 H1; unfold Int_part at 1 in |- *; 
+ omega.
+Qed.
+
+(**********)
+Lemma Rminus_fp1 :
+ forall r1 r2:R,
+   frac_part r1 >= frac_part r2 ->
+   frac_part (r1 - r2) = frac_part r1 - frac_part r2.
+intros; unfold frac_part in |- *; generalize (Rminus_Int_part1 r1 r2 H);
+ intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
+ unfold Rminus in |- *;
+ rewrite (Ropp_plus_distr (IZR (Int_part r1)) (- IZR (Int_part r2)));
+ rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
+ rewrite (Ropp_involutive (IZR (Int_part r2)));
+ rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
+ rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
+ rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); 
+ auto with zarith real.
+Qed.
+
+(**********)
+Lemma Rminus_fp2 :
+ forall r1 r2:R,
+   frac_part r1 < frac_part r2 ->
+   frac_part (r1 - r2) = frac_part r1 - frac_part r2 + 1.
+intros; unfold frac_part in |- *; generalize (Rminus_Int_part2 r1 r2 H);
+ intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1 - Int_part r2) 1);
+ rewrite <- (Z_R_minus (Int_part r1) (Int_part r2)); 
+ unfold Rminus in |- *;
+ rewrite
+  (Ropp_plus_distr (IZR (Int_part r1) + - IZR (Int_part r2)) (- IZR 1))
+  ; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
+ rewrite (Ropp_involutive (IZR 1));
+ rewrite (Ropp_involutive (IZR (Int_part r2)));
+ rewrite (Ropp_plus_distr (IZR (Int_part r1)));
+ rewrite (Ropp_involutive (IZR (Int_part r2))); simpl in |- *;
+ rewrite <-
+  (Rplus_assoc (r1 + - r2) (- IZR (Int_part r1) + IZR (Int_part r2)) 1)
+  ; rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
+ rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
+ rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); 
+ auto with zarith real.
+Qed.
+
+(**********)
+Lemma plus_Int_part1 :
+ forall r1 r2:R,
+   frac_part r1 + frac_part r2 >= 1 ->
+   Int_part (r1 + r2) = (Int_part r1 + Int_part r2 + 1)%Z.
+intros; generalize (Rge_le (frac_part r1 + frac_part r2) 1 H); intro; clear H;
+ elim (base_fp r1); elim (base_fp r2); intros; clear H H2;
+ generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3); 
+ intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1); 
+ intro; clear H1; rewrite (Rplus_comm 1 (frac_part r2)) in H2;
+ generalize
+  (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2); 
+ intro; clear H H2; rewrite (Rplus_comm (frac_part r2) (frac_part r1)) in H1;
+ unfold frac_part in H0, H1; unfold Rminus in H0, H1;
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
+   in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
+   in H1;
+ rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
+ rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
+   in H1;
+ rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
+   in H0; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H0;
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
+   in H0;
+ rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H0;
+ rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
+   in H0;
+ rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
+ generalize
+  (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 1
+     (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0); 
+ intro; clear H0;
+ generalize
+  (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
+     (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1); 
+ intro; clear H1;
+ rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
+   in H;
+ rewrite <-
+  (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
+     (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
+   in H; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H;
+ elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H; 
+ clear a b;
+ rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
+   in H0;
+ rewrite <-
+  (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
+     (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
+   in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
+ elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; 
+ clear a b;
+ rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0;
+ cut (1 = IZR 1); auto with zarith real.
+intro; rewrite H1 in H0; rewrite H1 in H; clear H1;
+ rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H;
+ rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
+ rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H;
+ rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0;
+ rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0;
+ generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0); 
+ intro; clear H H0; unfold Int_part at 1 in |- *; omega.
+Qed.
+
+(**********)
+Lemma plus_Int_part2 :
+ forall r1 r2:R,
+   frac_part r1 + frac_part r2 < 1 ->
+   Int_part (r1 + r2) = (Int_part r1 + Int_part r2)%Z.
+intros; elim (base_fp r1); elim (base_fp r2); intros; clear H1 H3;
+ generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
+ generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2;
+ generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1); 
+ intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b; 
+ rewrite a in H2; clear a b;
+ generalize (Rle_trans 0 (frac_part r1) (frac_part r1 + frac_part r2) H0 H2);
+ intro; clear H0 H2; unfold frac_part in H, H1; unfold Rminus in H, H1;
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
+   in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
+   in H1;
+ rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
+ rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
+   in H1;
+ rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
+   in H; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H;
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2) in H;
+ rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H;
+ rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
+   in H;
+ rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
+ generalize
+  (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 0
+     (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1); 
+ intro; clear H1;
+ generalize
+  (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
+     (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H); 
+ intro; clear H;
+ rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
+   in H1;
+ rewrite <-
+  (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
+     (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
+   in H1; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H1;
+ elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1; 
+ clear a b;
+ rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
+   in H0;
+ rewrite <-
+  (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
+     (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
+   in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
+ elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2))); 
+ intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2));
+ intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1);
+ auto with zarith real.
+intro; rewrite H in H1; clear H;
+ rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
+ rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1;
+ rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1;
+ generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1); 
+ intro; clear H0 H1; unfold Int_part at 1 in |- *; 
+ omega.
+Qed.
+
+(**********)
+Lemma plus_frac_part1 :
+ forall r1 r2:R,
+   frac_part r1 + frac_part r2 >= 1 ->
+   frac_part (r1 + r2) = frac_part r1 + frac_part r2 - 1.
+intros; unfold frac_part in |- *; generalize (plus_Int_part1 r1 r2 H); intro;
+ rewrite H0; rewrite (plus_IZR (Int_part r1 + Int_part r2) 1);
+ rewrite (plus_IZR (Int_part r1) (Int_part r2)); simpl in |- *;
+ unfold Rminus at 3 4 in |- *;
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
+ rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
+ rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
+ rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
+ rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
+ unfold Rminus in |- *;
+ rewrite
+  (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-1))
+  ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1);
+ trivial with zarith real.
+Qed.
+
+(**********)
+Lemma plus_frac_part2 :
+ forall r1 r2:R,
+   frac_part r1 + frac_part r2 < 1 ->
+   frac_part (r1 + r2) = frac_part r1 + frac_part r2.
+intros; unfold frac_part in |- *; generalize (plus_Int_part2 r1 r2 H); intro;
+ rewrite H0; rewrite (plus_IZR (Int_part r1) (Int_part r2));
+ unfold Rminus at 2 3 in |- *;
+ rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
+ rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
+ rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
+ rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
+ rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
+ rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
+ unfold Rminus in |- *; trivial with zarith real.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v
new file mode 100644
index 00000000..0abf9064
--- /dev/null
+++ b/theories/Reals/R_sqr.v
@@ -0,0 +1,330 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: R_sqr.v,v 1.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rbasic_fun. Open Local Scope R_scope.
+
+(****************************************************)
+(* Rsqr : some results                              *)
+(****************************************************)
+
+Ltac ring_Rsqr := unfold Rsqr in |- *; ring.
+
+Lemma Rsqr_neg : forall x:R, Rsqr x = Rsqr (- x).
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_mult : forall x y:R, Rsqr (x * y) = Rsqr x * Rsqr y.
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_plus : forall x y:R, Rsqr (x + y) = Rsqr x + Rsqr y + 2 * x * y.
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_minus : forall x y:R, Rsqr (x - y) = Rsqr x + Rsqr y - 2 * x * y.
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_neg_minus : forall x y:R, Rsqr (x - y) = Rsqr (y - x).
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_1 : Rsqr 1 = 1.
+ring_Rsqr.
+Qed.
+
+Lemma Rsqr_gt_0_0 : forall x:R, 0 < Rsqr x -> x <> 0.
+intros; red in |- *; intro; rewrite H0 in H; rewrite Rsqr_0 in H;
+ elim (Rlt_irrefl 0 H).
+Qed.
+
+Lemma Rsqr_pos_lt : forall x:R, x <> 0 -> 0 < Rsqr x.
+intros; case (Rtotal_order 0 x); intro;
+ [ unfold Rsqr in |- *; apply Rmult_lt_0_compat; assumption
+ | elim H0; intro;
+    [ elim H; symmetry  in |- *; exact H1
+    | rewrite Rsqr_neg; generalize (Ropp_lt_gt_contravar x 0 H1);
+       rewrite Ropp_0; intro; unfold Rsqr in |- *; 
+       apply Rmult_lt_0_compat; assumption ] ].
+Qed.
+
+Lemma Rsqr_div : forall x y:R, y <> 0 -> Rsqr (x / y) = Rsqr x / Rsqr y.
+intros; unfold Rsqr in |- *.
+unfold Rdiv in |- *.
+rewrite Rinv_mult_distr.
+repeat rewrite Rmult_assoc.
+apply Rmult_eq_compat_l.
+pattern x at 2 in |- *; rewrite Rmult_comm.
+repeat rewrite Rmult_assoc.
+apply Rmult_eq_compat_l.
+reflexivity.
+assumption.
+assumption.
+Qed.
+
+Lemma Rsqr_eq_0 : forall x:R, Rsqr x = 0 -> x = 0.
+unfold Rsqr in |- *; intros; generalize (Rmult_integral x x H); intro;
+ elim H0; intro; assumption.
+Qed.
+
+Lemma Rsqr_minus_plus : forall a b:R, (a - b) * (a + b) = Rsqr a - Rsqr b.
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_plus_minus : forall a b:R, (a + b) * (a - b) = Rsqr a - Rsqr b.
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_incr_0 :
+ forall x y:R, Rsqr x <= Rsqr y -> 0 <= x -> 0 <= y -> x <= y.
+intros; case (Rle_dec x y); intro;
+ [ assumption
+ | cut (y < x);
+    [ intro; unfold Rsqr in H;
+       generalize (Rmult_le_0_lt_compat y x y x H1 H1 H2 H2); 
+       intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H3); 
+       intro; elim (Rlt_irrefl (x * x) H4)
+    | auto with real ] ].
+Qed.
+
+Lemma Rsqr_incr_0_var : forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> x <= y.
+intros; case (Rle_dec x y); intro;
+ [ assumption
+ | cut (y < x);
+    [ intro; unfold Rsqr in H;
+       generalize (Rmult_le_0_lt_compat y x y x H0 H0 H1 H1); 
+       intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H2); 
+       intro; elim (Rlt_irrefl (x * x) H3)
+    | auto with real ] ].
+Qed.
+
+Lemma Rsqr_incr_1 :
+ forall x y:R, x <= y -> 0 <= x -> 0 <= y -> Rsqr x <= Rsqr y.
+intros; unfold Rsqr in |- *; apply Rmult_le_compat; assumption.
+Qed.
+
+Lemma Rsqr_incrst_0 :
+ forall x y:R, Rsqr x < Rsqr y -> 0 <= x -> 0 <= y -> x < y.
+intros; case (Rtotal_order x y); intro;
+ [ assumption
+ | elim H2; intro;
+    [ rewrite H3 in H; elim (Rlt_irrefl (Rsqr y) H)
+    | generalize (Rmult_le_0_lt_compat y x y x H1 H1 H3 H3); intro;
+       unfold Rsqr in H; generalize (Rlt_trans (x * x) (y * y) (x * x) H H4);
+       intro; elim (Rlt_irrefl (x * x) H5) ] ].
+Qed.
+
+Lemma Rsqr_incrst_1 :
+ forall x y:R, x < y -> 0 <= x -> 0 <= y -> Rsqr x < Rsqr y.
+intros; unfold Rsqr in |- *; apply Rmult_le_0_lt_compat; assumption.
+Qed.
+
+Lemma Rsqr_neg_pos_le_0 :
+ forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> - y <= x.
+intros; case (Rcase_abs x); intro.
+generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
+ generalize (Rlt_le 0 (- x) H1); intro; rewrite (Rsqr_neg x) in H;
+ generalize (Rsqr_incr_0 (- x) y H H2 H0); intro;
+ rewrite <- (Ropp_involutive x); apply Ropp_ge_le_contravar; 
+ apply Rle_ge; assumption.
+apply Rle_trans with 0;
+ [ rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption
+ | apply Rge_le; assumption ].
+Qed.
+
+Lemma Rsqr_neg_pos_le_1 :
+ forall x y:R, - y <= x -> x <= y -> 0 <= y -> Rsqr x <= Rsqr y.
+intros; case (Rcase_abs x); intro.
+generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
+ generalize (Rlt_le 0 (- x) H2); intro;
+ generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; 
+ intro; generalize (Rge_le y (- x) H4); intro; rewrite (Rsqr_neg x);
+ apply Rsqr_incr_1; assumption.
+generalize (Rge_le x 0 r); intro; apply Rsqr_incr_1; assumption.
+Qed.
+
+Lemma neg_pos_Rsqr_le : forall x y:R, - y <= x -> x <= y -> Rsqr x <= Rsqr y.
+intros; case (Rcase_abs x); intro.
+generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
+ generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; 
+ intro; generalize (Rge_le y (- x) H2); intro; generalize (Rlt_le 0 (- x) H1);
+ intro; generalize (Rle_trans 0 (- x) y H4 H3); intro; 
+ rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption.
+generalize (Rge_le x 0 r); intro; generalize (Rle_trans 0 x y H1 H0); intro;
+ apply Rsqr_incr_1; assumption.
+Qed.
+
+Lemma Rsqr_abs : forall x:R, Rsqr x = Rsqr (Rabs x).
+intro; unfold Rabs in |- *; case (Rcase_abs x); intro;
+ [ apply Rsqr_neg | reflexivity ].
+Qed.
+
+Lemma Rsqr_le_abs_0 : forall x y:R, Rsqr x <= Rsqr y -> Rabs x <= Rabs y.
+intros; apply Rsqr_incr_0; repeat rewrite <- Rsqr_abs;
+ [ assumption | apply Rabs_pos | apply Rabs_pos ].
+Qed.
+
+Lemma Rsqr_le_abs_1 : forall x y:R, Rabs x <= Rabs y -> Rsqr x <= Rsqr y.
+intros; rewrite (Rsqr_abs x); rewrite (Rsqr_abs y);
+ apply (Rsqr_incr_1 (Rabs x) (Rabs y) H (Rabs_pos x) (Rabs_pos y)).
+Qed.
+
+Lemma Rsqr_lt_abs_0 : forall x y:R, Rsqr x < Rsqr y -> Rabs x < Rabs y.
+intros; apply Rsqr_incrst_0; repeat rewrite <- Rsqr_abs;
+ [ assumption | apply Rabs_pos | apply Rabs_pos ].
+Qed.
+
+Lemma Rsqr_lt_abs_1 : forall x y:R, Rabs x < Rabs y -> Rsqr x < Rsqr y.
+intros; rewrite (Rsqr_abs x); rewrite (Rsqr_abs y);
+ apply (Rsqr_incrst_1 (Rabs x) (Rabs y) H (Rabs_pos x) (Rabs_pos y)).
+Qed.
+
+Lemma Rsqr_inj : forall x y:R, 0 <= x -> 0 <= y -> Rsqr x = Rsqr y -> x = y.
+intros; generalize (Rle_le_eq (Rsqr x) (Rsqr y)); intro; elim H2; intros _ H3;
+ generalize (H3 H1); intro; elim H4; intros; apply Rle_antisym;
+ apply Rsqr_incr_0; assumption.
+Qed.
+
+Lemma Rsqr_eq_abs_0 : forall x y:R, Rsqr x = Rsqr y -> Rabs x = Rabs y.
+intros; unfold Rabs in |- *; case (Rcase_abs x); case (Rcase_abs y); intros.
+rewrite (Rsqr_neg x) in H; rewrite (Rsqr_neg y) in H;
+ generalize (Ropp_lt_gt_contravar y 0 r);
+ generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; 
+ intros; generalize (Rlt_le 0 (- x) H0); generalize (Rlt_le 0 (- y) H1);
+ intros; apply Rsqr_inj; assumption.
+rewrite (Rsqr_neg x) in H; generalize (Rge_le y 0 r); intro;
+ generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; 
+ intro; generalize (Rlt_le 0 (- x) H1); intro; apply Rsqr_inj; 
+ assumption.
+rewrite (Rsqr_neg y) in H; generalize (Rge_le x 0 r0); intro;
+ generalize (Ropp_lt_gt_contravar y 0 r); rewrite Ropp_0; 
+ intro; generalize (Rlt_le 0 (- y) H1); intro; apply Rsqr_inj; 
+ assumption.
+generalize (Rge_le x 0 r0); generalize (Rge_le y 0 r); intros; apply Rsqr_inj;
+ assumption.
+Qed.
+
+Lemma Rsqr_eq_asb_1 : forall x y:R, Rabs x = Rabs y -> Rsqr x = Rsqr y.
+intros; cut (Rsqr (Rabs x) = Rsqr (Rabs y)).
+intro; repeat rewrite <- Rsqr_abs in H0; assumption.
+rewrite H; reflexivity.
+Qed.
+
+Lemma triangle_rectangle :
+ forall x y z:R,
+   0 <= z -> Rsqr x + Rsqr y <= Rsqr z -> - z <= x <= z /\ - z <= y <= z.
+intros;
+ generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H0);
+ rewrite Rplus_comm in H0;
+ generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H0);
+ intros; split;
+ [ split;
+    [ apply Rsqr_neg_pos_le_0; assumption
+    | apply Rsqr_incr_0_var; assumption ]
+ | split;
+    [ apply Rsqr_neg_pos_le_0; assumption
+    | apply Rsqr_incr_0_var; assumption ] ].
+Qed.
+
+Lemma triangle_rectangle_lt :
+ forall x y z:R,
+   Rsqr x + Rsqr y < Rsqr z -> Rabs x < Rabs z /\ Rabs y < Rabs z.
+intros; split;
+ [ generalize (plus_lt_is_lt (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H);
+    intro; apply Rsqr_lt_abs_0; assumption
+ | rewrite Rplus_comm in H;
+    generalize (plus_lt_is_lt (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H);
+    intro; apply Rsqr_lt_abs_0; assumption ].
+Qed.
+
+Lemma triangle_rectangle_le :
+ forall x y z:R,
+   Rsqr x + Rsqr y <= Rsqr z -> Rabs x <= Rabs z /\ Rabs y <= Rabs z.
+intros; split;
+ [ generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H);
+    intro; apply Rsqr_le_abs_0; assumption
+ | rewrite Rplus_comm in H;
+    generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H);
+    intro; apply Rsqr_le_abs_0; assumption ].
+Qed.
+
+Lemma Rsqr_inv : forall x:R, x <> 0 -> Rsqr (/ x) = / Rsqr x.
+intros; unfold Rsqr in |- *.
+rewrite Rinv_mult_distr; try reflexivity || assumption.
+Qed.
+
+Lemma canonical_Rsqr :
+ forall (a:nonzeroreal) (b c x:R),
+   a * Rsqr x + b * x + c =
+   a * Rsqr (x + b / (2 * a)) + (4 * a * c - Rsqr b) / (4 * a).
+intros.
+rewrite Rsqr_plus.
+repeat rewrite Rmult_plus_distr_l.
+repeat rewrite Rplus_assoc.
+apply Rplus_eq_compat_l.
+unfold Rdiv, Rminus in |- *.
+replace (2 * 1 + 2 * 1) with 4; [ idtac | ring ].
+rewrite (Rmult_plus_distr_r (4 * a * c) (- Rsqr b) (/ (4 * a))).
+rewrite Rsqr_mult.
+repeat rewrite Rinv_mult_distr.
+repeat rewrite (Rmult_comm a).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+rewrite (Rmult_comm 2).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+rewrite (Rmult_comm (/ 2)).
+rewrite (Rmult_comm 2).
+repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+rewrite (Rmult_comm a).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+rewrite (Rmult_comm 2).
+repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+repeat rewrite Rplus_assoc.
+rewrite (Rplus_comm (Rsqr b * (Rsqr (/ a * / 2) * a))).
+repeat rewrite Rplus_assoc.
+rewrite (Rmult_comm x).
+apply Rplus_eq_compat_l.
+rewrite (Rmult_comm (/ a)).
+unfold Rsqr in |- *; repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+ring.
+apply (cond_nonzero a).
+discrR.
+apply (cond_nonzero a).
+discrR.
+discrR.
+apply (cond_nonzero a).
+discrR.
+discrR.
+discrR.
+apply (cond_nonzero a).
+discrR.
+apply (cond_nonzero a).
+Qed.
+
+Lemma Rsqr_eq : forall x y:R, Rsqr x = Rsqr y -> x = y \/ x = - y.
+intros; unfold Rsqr in H;
+ generalize (Rplus_eq_compat_l (- (y * y)) (x * x) (y * y) H);
+ rewrite Rplus_opp_l; replace (- (y * y) + x * x) with ((x - y) * (x + y)).
+intro; generalize (Rmult_integral (x - y) (x + y) H0); intro; elim H1; intros.
+left; apply Rminus_diag_uniq; assumption.
+right; apply Rminus_diag_uniq; unfold Rminus in |- *; rewrite Ropp_involutive;
+ assumption.
+ring.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v
new file mode 100644
index 00000000..660b0527
--- /dev/null
+++ b/theories/Reals/R_sqrt.v
@@ -0,0 +1,399 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: R_sqrt.v,v 1.10.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rsqrt_def. Open Local Scope R_scope.
+
+(* Here is a continuous extension of Rsqrt on R *)
+Definition sqrt (x:R) : R :=
+  match Rcase_abs x with
+  | left _ => 0
+  | right a => Rsqrt (mknonnegreal x (Rge_le _ _ a))
+  end.
+
+Lemma sqrt_positivity : forall x:R, 0 <= x -> 0 <= sqrt x.
+intros.
+unfold sqrt in |- *.
+case (Rcase_abs x); intro.
+elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)).
+apply Rsqrt_positivity.
+Qed.
+
+Lemma sqrt_sqrt : forall x:R, 0 <= x -> sqrt x * sqrt x = x.
+intros.
+unfold sqrt in |- *.
+case (Rcase_abs x); intro.
+elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)).
+rewrite Rsqrt_Rsqrt; reflexivity.
+Qed.
+
+Lemma sqrt_0 : sqrt 0 = 0.
+apply Rsqr_eq_0; unfold Rsqr in |- *; apply sqrt_sqrt; right; reflexivity. 
+Qed.
+
+Lemma sqrt_1 : sqrt 1 = 1.
+apply (Rsqr_inj (sqrt 1) 1);
+ [ apply sqrt_positivity; left
+ | left
+ | unfold Rsqr in |- *; rewrite sqrt_sqrt; [ ring | left ] ]; 
+ apply Rlt_0_1.
+Qed.
+
+Lemma sqrt_eq_0 : forall x:R, 0 <= x -> sqrt x = 0 -> x = 0.
+intros; cut (Rsqr (sqrt x) = 0).
+intro; unfold Rsqr in H1; rewrite sqrt_sqrt in H1; assumption.
+rewrite H0; apply Rsqr_0.
+Qed.
+
+Lemma sqrt_lem_0 : forall x y:R, 0 <= x -> 0 <= y -> sqrt x = y -> y * y = x.
+intros; rewrite <- H1; apply (sqrt_sqrt x H).
+Qed.
+
+Lemma sqtr_lem_1 : forall x y:R, 0 <= x -> 0 <= y -> y * y = x -> sqrt x = y.
+intros; apply Rsqr_inj;
+ [ apply (sqrt_positivity x H)
+ | assumption
+ | unfold Rsqr in |- *; rewrite H1; apply (sqrt_sqrt x H) ].
+Qed.
+
+Lemma sqrt_def : forall x:R, 0 <= x -> sqrt x * sqrt x = x.
+intros; apply (sqrt_sqrt x H).
+Qed.
+
+Lemma sqrt_square : forall x:R, 0 <= x -> sqrt (x * x) = x.
+intros;
+ apply
+  (Rsqr_inj (sqrt (Rsqr x)) x (sqrt_positivity (Rsqr x) (Rle_0_sqr x)) H);
+ unfold Rsqr in |- *; apply (sqrt_sqrt (Rsqr x) (Rle_0_sqr x)).
+Qed.
+
+Lemma sqrt_Rsqr : forall x:R, 0 <= x -> sqrt (Rsqr x) = x.
+intros; unfold Rsqr in |- *; apply sqrt_square; assumption.
+Qed.
+
+Lemma sqrt_Rsqr_abs : forall x:R, sqrt (Rsqr x) = Rabs x.
+intro x; rewrite Rsqr_abs; apply sqrt_Rsqr; apply Rabs_pos.
+Qed.
+
+Lemma Rsqr_sqrt : forall x:R, 0 <= x -> Rsqr (sqrt x) = x.
+intros x H1; unfold Rsqr in |- *; apply (sqrt_sqrt x H1).
+Qed.
+
+Lemma sqrt_mult :
+ forall x y:R, 0 <= x -> 0 <= y -> sqrt (x * y) = sqrt x * sqrt y.
+intros x y H1 H2;
+ apply
+  (Rsqr_inj (sqrt (x * y)) (sqrt x * sqrt y)
+     (sqrt_positivity (x * y) (Rmult_le_pos x y H1 H2))
+     (Rmult_le_pos (sqrt x) (sqrt y) (sqrt_positivity x H1)
+        (sqrt_positivity y H2))); rewrite Rsqr_mult; 
+ repeat rewrite Rsqr_sqrt;
+ [ ring | assumption | assumption | apply (Rmult_le_pos x y H1 H2) ].
+Qed.
+
+Lemma sqrt_lt_R0 : forall x:R, 0 < x -> 0 < sqrt x.
+intros x H1; apply Rsqr_incrst_0;
+ [ rewrite Rsqr_0; rewrite Rsqr_sqrt; [ assumption | left; assumption ]
+ | right; reflexivity
+ | apply (sqrt_positivity x (Rlt_le 0 x H1)) ].
+Qed.
+
+Lemma sqrt_div :
+ forall x y:R, 0 <= x -> 0 < y -> sqrt (x / y) = sqrt x / sqrt y.
+intros x y H1 H2; apply Rsqr_inj;
+ [ apply sqrt_positivity; apply (Rmult_le_pos x (/ y));
+    [ assumption
+    | generalize (Rinv_0_lt_compat y H2); clear H2; intro H2; left;
+       assumption ]
+ | apply (Rmult_le_pos (sqrt x) (/ sqrt y));
+    [ apply (sqrt_positivity x H1)
+    | generalize (sqrt_lt_R0 y H2); clear H2; intro H2;
+       generalize (Rinv_0_lt_compat (sqrt y) H2); clear H2; 
+       intro H2; left; assumption ]
+ | rewrite Rsqr_div; repeat rewrite Rsqr_sqrt;
+    [ reflexivity
+    | left; assumption
+    | assumption
+    | generalize (Rinv_0_lt_compat y H2); intro H3;
+       generalize (Rlt_le 0 (/ y) H3); intro H4;
+       apply (Rmult_le_pos x (/ y) H1 H4)
+    | red in |- *; intro H3; generalize (Rlt_le 0 y H2); intro H4;
+       generalize (sqrt_eq_0 y H4 H3); intro H5; rewrite H5 in H2;
+       elim (Rlt_irrefl 0 H2) ] ].
+Qed.
+
+Lemma sqrt_lt_0 : forall x y:R, 0 <= x -> 0 <= y -> sqrt x < sqrt y -> x < y.
+intros x y H1 H2 H3;
+ generalize
+  (Rsqr_incrst_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1)
+     (sqrt_positivity y H2)); intro H4; rewrite (Rsqr_sqrt x H1) in H4;
+ rewrite (Rsqr_sqrt y H2) in H4; assumption.
+Qed.
+
+Lemma sqrt_lt_1 : forall x y:R, 0 <= x -> 0 <= y -> x < y -> sqrt x < sqrt y.
+intros x y H1 H2 H3; apply Rsqr_incrst_0;
+ [ rewrite (Rsqr_sqrt x H1); rewrite (Rsqr_sqrt y H2); assumption
+ | apply (sqrt_positivity x H1)
+ | apply (sqrt_positivity y H2) ].
+Qed.
+
+Lemma sqrt_le_0 :
+ forall x y:R, 0 <= x -> 0 <= y -> sqrt x <= sqrt y -> x <= y.
+intros x y H1 H2 H3;
+ generalize
+  (Rsqr_incr_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1)
+     (sqrt_positivity y H2)); intro H4; rewrite (Rsqr_sqrt x H1) in H4;
+ rewrite (Rsqr_sqrt y H2) in H4; assumption.
+Qed.
+
+Lemma sqrt_le_1 :
+ forall x y:R, 0 <= x -> 0 <= y -> x <= y -> sqrt x <= sqrt y.
+intros x y H1 H2 H3; apply Rsqr_incr_0;
+ [ rewrite (Rsqr_sqrt x H1); rewrite (Rsqr_sqrt y H2); assumption
+ | apply (sqrt_positivity x H1)
+ | apply (sqrt_positivity y H2) ].
+Qed.
+
+Lemma sqrt_inj : forall x y:R, 0 <= x -> 0 <= y -> sqrt x = sqrt y -> x = y.
+intros; cut (Rsqr (sqrt x) = Rsqr (sqrt y)).
+intro; rewrite (Rsqr_sqrt x H) in H2; rewrite (Rsqr_sqrt y H0) in H2;
+ assumption.
+rewrite H1; reflexivity.
+Qed.
+
+Lemma sqrt_less : forall x:R, 0 <= x -> 1 < x -> sqrt x < x.
+intros x H1 H2; generalize (sqrt_lt_1 1 x (Rlt_le 0 1 Rlt_0_1) H1 H2);
+ intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); 
+ intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 2 in |- *;
+ rewrite <- (sqrt_def x H1);
+ apply
+  (Rmult_lt_compat_l (sqrt x) 1 (sqrt x)
+     (sqrt_lt_R0 x (Rlt_trans 0 1 x Rlt_0_1 H2)) H3).
+Qed.
+
+Lemma sqrt_more : forall x:R, 0 < x -> x < 1 -> x < sqrt x.
+intros x H1 H2;
+ generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2); 
+ intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); 
+ intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 1 in |- *;
+ rewrite <- (sqrt_def x (Rlt_le 0 x H1));
+ apply (Rmult_lt_compat_l (sqrt x) (sqrt x) 1 (sqrt_lt_R0 x H1) H3).
+Qed.
+
+Lemma sqrt_cauchy :
+ forall a b c d:R,
+   a * c + b * d <= sqrt (Rsqr a + Rsqr b) * sqrt (Rsqr c + Rsqr d).
+intros a b c d; apply Rsqr_incr_0_var;
+ [ rewrite Rsqr_mult; repeat rewrite Rsqr_sqrt; unfold Rsqr in |- *;
+    [ replace ((a * c + b * d) * (a * c + b * d)) with
+       (a * a * c * c + b * b * d * d + 2 * a * b * c * d);
+       [ replace ((a * a + b * b) * (c * c + d * d)) with
+          (a * a * c * c + b * b * d * d + (a * a * d * d + b * b * c * c));
+          [ apply Rplus_le_compat_l;
+             replace (a * a * d * d + b * b * c * c) with
+              (2 * a * b * c * d +
+               (a * a * d * d + b * b * c * c - 2 * a * b * c * d));
+             [ pattern (2 * a * b * c * d) at 1 in |- *; rewrite <- Rplus_0_r;
+                apply Rplus_le_compat_l;
+                replace (a * a * d * d + b * b * c * c - 2 * a * b * c * d)
+                 with (Rsqr (a * d - b * c));
+                [ apply Rle_0_sqr | unfold Rsqr in |- *; ring ]
+             | ring ]
+          | ring ]
+       | ring ]
+    | apply
+       (Rplus_le_le_0_compat (Rsqr c) (Rsqr d) (Rle_0_sqr c) (Rle_0_sqr d))
+    | apply
+       (Rplus_le_le_0_compat (Rsqr a) (Rsqr b) (Rle_0_sqr a) (Rle_0_sqr b)) ]
+ | apply Rmult_le_pos; apply sqrt_positivity; apply Rplus_le_le_0_compat;
+    apply Rle_0_sqr ].
+Qed.
+
+(************************************************************)
+(* Resolution of [a*X^2+b*X+c=0]                            *)
+(************************************************************)
+
+Definition Delta (a:nonzeroreal) (b c:R) : R := Rsqr b - 4 * a * c.
+
+Definition Delta_is_pos (a:nonzeroreal) (b c:R) : Prop := 0 <= Delta a b c.
+
+Definition sol_x1 (a:nonzeroreal) (b c:R) : R :=
+  (- b + sqrt (Delta a b c)) / (2 * a).
+
+Definition sol_x2 (a:nonzeroreal) (b c:R) : R :=
+  (- b - sqrt (Delta a b c)) / (2 * a).
+
+Lemma Rsqr_sol_eq_0_1 :
+ forall (a:nonzeroreal) (b c x:R),
+   Delta_is_pos a b c ->
+   x = sol_x1 a b c \/ x = sol_x2 a b c -> a * Rsqr x + b * x + c = 0.
+intros; elim H0; intro.
+unfold sol_x1 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv in |- *;
+ repeat rewrite Rsqr_mult; rewrite Rsqr_plus; rewrite <- Rsqr_neg;
+ rewrite Rsqr_sqrt.
+rewrite Rsqr_inv.
+unfold Rsqr in |- *; repeat rewrite Rinv_mult_distr.
+repeat rewrite Rmult_assoc; rewrite (Rmult_comm a).
+repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; rewrite Rmult_plus_distr_r.
+repeat rewrite Rmult_assoc.
+pattern 2 at 2 in |- *; rewrite (Rmult_comm 2).
+repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+rewrite
+ (Rmult_plus_distr_r (- b) (sqrt (b * b - 2 * (2 * (a * c)))) (/ 2 * / a))
+ .
+rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc.
+replace
+ (- b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) +
+  (b * (- b * (/ 2 * / a)) +
+   (b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + c))) with
+ (b * (- b * (/ 2 * / a)) + c).
+unfold Rminus in |- *; repeat rewrite <- Rplus_assoc.
+replace (b * b + b * b) with (2 * (b * b)).
+rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
+ rewrite (Rmult_comm 2).
+repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc;
+ rewrite (Rmult_comm 2).
+repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm a); rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; rewrite <- Rmult_opp_opp.
+ring.
+apply (cond_nonzero a).
+discrR.
+discrR.
+discrR.
+ring.
+ring.
+discrR.
+apply (cond_nonzero a).
+discrR.
+apply (cond_nonzero a).
+apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
+apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
+apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
+assumption.
+unfold sol_x2 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv in |- *;
+ repeat rewrite Rsqr_mult; rewrite Rsqr_minus; rewrite <- Rsqr_neg;
+ rewrite Rsqr_sqrt.
+rewrite Rsqr_inv.
+unfold Rsqr in |- *; repeat rewrite Rinv_mult_distr;
+ repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm a); repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; unfold Rminus in |- *; rewrite Rmult_plus_distr_r.
+rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
+ pattern 2 at 2 in |- *; rewrite (Rmult_comm 2).
+repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r;
+ rewrite
+  (Rmult_plus_distr_r (- b) (- sqrt (b * b + - (2 * (2 * (a * c)))))
+     (/ 2 * / a)).
+rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc.
+rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_involutive.
+replace
+ (b * (sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) +
+  (b * (- b * (/ 2 * / a)) +
+   (b * (- sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) + c))) with
+ (b * (- b * (/ 2 * / a)) + c).
+repeat rewrite <- Rplus_assoc; replace (b * b + b * b) with (2 * (b * b)).
+rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc;
+ rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; 
+ rewrite <- Rinv_l_sym.
+rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; repeat rewrite Rmult_assoc; rewrite (Rmult_comm a);
+ rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; rewrite <- Rmult_opp_opp; ring.
+apply (cond_nonzero a).
+discrR.
+discrR.
+discrR.
+ring.
+ring.
+discrR.
+apply (cond_nonzero a).
+discrR.
+discrR.
+apply (cond_nonzero a).
+apply prod_neq_R0; discrR || apply (cond_nonzero a).
+apply prod_neq_R0; discrR || apply (cond_nonzero a).
+apply prod_neq_R0; discrR || apply (cond_nonzero a).
+assumption.
+Qed.
+
+Lemma Rsqr_sol_eq_0_0 :
+ forall (a:nonzeroreal) (b c x:R),
+   Delta_is_pos a b c ->
+   a * Rsqr x + b * x + c = 0 -> x = sol_x1 a b c \/ x = sol_x2 a b c.
+intros; rewrite (canonical_Rsqr a b c x) in H0; rewrite Rplus_comm in H0;
+ generalize
+  (Rplus_opp_r_uniq ((4 * a * c - Rsqr b) / (4 * a))
+     (a * Rsqr (x + b / (2 * a))) H0); cut (Rsqr b - 4 * a * c = Delta a b c).
+intro;
+ replace (- ((4 * a * c - Rsqr b) / (4 * a))) with
+  ((Rsqr b - 4 * a * c) / (4 * a)).
+rewrite H1; intro;
+ generalize
+  (Rmult_eq_compat_l (/ a) (a * Rsqr (x + b / (2 * a)))
+     (Delta a b c / (4 * a)) H2);
+ replace (/ a * (a * Rsqr (x + b / (2 * a)))) with (Rsqr (x + b / (2 * a))).
+replace (/ a * (Delta a b c / (4 * a))) with
+ (Rsqr (sqrt (Delta a b c) / (2 * a))).
+intro;
+ generalize (Rsqr_eq (x + b / (2 * a)) (sqrt (Delta a b c) / (2 * a)) H3);
+ intro; elim H4; intro.
+left; unfold sol_x1 in |- *;
+ generalize
+  (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a))
+     (sqrt (Delta a b c) / (2 * a)) H5);
+ replace (- (b / (2 * a)) + (x + b / (2 * a))) with x.
+intro; rewrite H6; unfold Rdiv in |- *; ring.
+ring.
+right; unfold sol_x2 in |- *;
+ generalize
+  (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a))
+     (- (sqrt (Delta a b c) / (2 * a))) H5);
+ replace (- (b / (2 * a)) + (x + b / (2 * a))) with x.
+intro; rewrite H6; unfold Rdiv in |- *; ring.
+ring.
+rewrite Rsqr_div.
+rewrite Rsqr_sqrt.
+unfold Rdiv in |- *.
+repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm (/ a)).
+rewrite Rmult_assoc.
+rewrite <- Rinv_mult_distr.
+replace (2 * (2 * a) * a) with (Rsqr (2 * a)).
+reflexivity.
+ring_Rsqr.
+rewrite <- Rmult_assoc; apply prod_neq_R0;
+ [ discrR | apply (cond_nonzero a) ].
+apply (cond_nonzero a).
+assumption.
+apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+symmetry  in |- *; apply Rmult_1_l.
+apply (cond_nonzero a).
+unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
+rewrite Ropp_minus_distr.
+reflexivity.
+reflexivity.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v
new file mode 100644
index 00000000..88af8b20
--- /dev/null
+++ b/theories/Reals/Ranalysis.v
@@ -0,0 +1,802 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Ranalysis.v,v 1.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rtrigo.
+Require Import SeqSeries.
+Require Export Ranalysis1.
+Require Export Ranalysis2.
+Require Export Ranalysis3.
+Require Export Rtopology.
+Require Export MVT.
+Require Export PSeries_reg.
+Require Export Exp_prop.
+Require Export Rtrigo_reg.
+Require Export Rsqrt_def.
+Require Export R_sqrt.
+Require Export Rtrigo_calc.
+Require Export Rgeom.
+Require Export RList.
+Require Export Sqrt_reg.
+Require Export Ranalysis4.
+Require Export Rpower. Open Local Scope R_scope.
+
+Axiom AppVar : R.
+
+(**********)
+Ltac intro_hyp_glob trm :=
+  match constr:trm with
+  | (?X1 + ?X2)%F =>
+      match goal with
+      |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+      |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+      | _ => idtac
+      end
+  | (?X1 - ?X2)%F =>
+      match goal with
+      |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+      |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+      | _ => idtac
+      end
+  | (?X1 * ?X2)%F =>
+      match goal with
+      |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+      |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+      | _ => idtac
+      end
+  | (?X1 / ?X2)%F =>
+      let aux := constr:X2 in
+      match goal with
+      | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
+          intro_hyp_glob X1; intro_hyp_glob X2
+      | _:(forall x0:R, aux x0 <> 0) |- (continuity _) =>
+          intro_hyp_glob X1; intro_hyp_glob X2
+      |  |- (derivable _) =>
+          cut (forall x0:R, aux x0 <> 0);
+           [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
+      |  |- (continuity _) =>
+          cut (forall x0:R, aux x0 <> 0);
+           [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
+      | _ => idtac
+      end
+  | (comp ?X1 ?X2) =>
+      match goal with
+      |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+      |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+      | _ => idtac
+      end
+  | (- ?X1)%F =>
+      match goal with
+      |  |- (derivable _) => intro_hyp_glob X1
+      |  |- (continuity _) => intro_hyp_glob X1
+      | _ => idtac
+      end
+  | (/ ?X1)%F =>
+      let aux := constr:X1 in
+      match goal with
+      | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
+          intro_hyp_glob X1
+      | _:(forall x0:R, aux x0 <> 0) |- (continuity _) => 
+      intro_hyp_glob X1
+      |  |- (derivable _) =>
+          cut (forall x0:R, aux x0 <> 0);
+           [ intro; intro_hyp_glob X1 | try assumption ]
+      |  |- (continuity _) =>
+          cut (forall x0:R, aux x0 <> 0);
+           [ intro; intro_hyp_glob X1 | try assumption ]
+      | _ => idtac
+      end
+  | cos => idtac
+  | sin => idtac
+  | cosh => idtac
+  | sinh => idtac
+  | exp => idtac
+  | Rsqr => idtac
+  | sqrt => idtac
+  | id => idtac
+  | (fct_cte _) => idtac
+  | (pow_fct _) => idtac
+  | Rabs => idtac
+  | ?X1 =>
+      let p := constr:X1 in
+      match goal with
+      | _:(derivable p) |- _ => idtac
+      |  |- (derivable p) => idtac
+      |  |- (derivable _) =>
+          cut (True -> derivable p);
+           [ intro HYPPD; cut (derivable p);
+              [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+           | idtac ]
+      | _:(continuity p) |- _ => idtac
+      |  |- (continuity p) => idtac
+      |  |- (continuity _) =>
+          cut (True -> continuity p);
+           [ intro HYPPD; cut (continuity p);
+              [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+           | idtac ]
+      | _ => idtac
+      end
+  end.
+
+(**********)
+Ltac intro_hyp_pt trm pt :=
+  match constr:trm with
+  | (?X1 + ?X2)%F =>
+      match goal with
+      |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      |  |- (derive_pt _ _ _ = _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      | _ => idtac
+      end
+  | (?X1 - ?X2)%F =>
+      match goal with
+      |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      |  |- (derive_pt _ _ _ = _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      | _ => idtac
+      end
+  | (?X1 * ?X2)%F =>
+      match goal with
+      |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      |  |- (derive_pt _ _ _ = _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      | _ => idtac
+      end
+  | (?X1 / ?X2)%F =>
+      let aux := constr:X2 in
+      match goal with
+      | _:(aux pt <> 0) |- (derivable_pt _ _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      | _:(aux pt <> 0) |- (continuity_pt _ _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
+          generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
+          generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
+          generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      |  |- (derivable_pt _ _) =>
+          cut (aux pt <> 0);
+           [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
+      |  |- (continuity_pt _ _) =>
+          cut (aux pt <> 0);
+           [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
+      |  |- (derive_pt _ _ _ = _) =>
+          cut (aux pt <> 0);
+           [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
+      | _ => idtac
+      end
+  | (comp ?X1 ?X2) =>
+      match goal with
+      |  |- (derivable_pt _ _) =>
+          let pt_f1 := eval cbv beta in (X2 pt) in
+          (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
+      |  |- (continuity_pt _ _) =>
+          let pt_f1 := eval cbv beta in (X2 pt) in
+          (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
+      |  |- (derive_pt _ _ _ = _) =>
+          let pt_f1 := eval cbv beta in (X2 pt) in
+          (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
+      | _ => idtac
+      end
+  | (- ?X1)%F =>
+      match goal with
+      |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt
+      |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt
+      |  |- (derive_pt _ _ _ = _) => intro_hyp_pt X1 pt
+      | _ => idtac
+      end
+  | (/ ?X1)%F =>
+      let aux := constr:X1 in
+      match goal with
+      | _:(aux pt <> 0) |- (derivable_pt _ _) =>
+          intro_hyp_pt X1 pt
+      | _:(aux pt <> 0) |- (continuity_pt _ _) =>
+          intro_hyp_pt X1 pt
+      | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
+          intro_hyp_pt X1 pt
+      | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
+          generalize (id pt); intro; intro_hyp_pt X1 pt
+      | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
+          generalize (id pt); intro; intro_hyp_pt X1 pt
+      | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
+          generalize (id pt); intro; intro_hyp_pt X1 pt
+      |  |- (derivable_pt _ _) =>
+          cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
+      |  |- (continuity_pt _ _) =>
+          cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
+      |  |- (derive_pt _ _ _ = _) =>
+          cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
+      | _ => idtac
+      end
+  | cos => idtac
+  | sin => idtac
+  | cosh => idtac
+  | sinh => idtac
+  | exp => idtac
+  | Rsqr => idtac
+  | id => idtac
+  | (fct_cte _) => idtac
+  | (pow_fct _) => idtac
+  | sqrt =>
+      match goal with
+      |  |- (derivable_pt _ _) => cut (0 < pt); [ intro | try assumption ]
+      |  |- (continuity_pt _ _) =>
+          cut (0 <= pt); [ intro | try assumption ]
+      |  |- (derive_pt _ _ _ = _) =>
+          cut (0 < pt); [ intro | try assumption ]
+      | _ => idtac
+      end
+  | Rabs =>
+      match goal with
+      |  |- (derivable_pt _ _) =>
+          cut (pt <> 0); [ intro | try assumption ]
+      | _ => idtac
+      end
+  | ?X1 =>
+      let p := constr:X1 in
+      match goal with
+      | _:(derivable_pt p pt) |- _ => idtac
+      |  |- (derivable_pt p pt) => idtac
+      |  |- (derivable_pt _ _) =>
+          cut (True -> derivable_pt p pt);
+           [ intro HYPPD; cut (derivable_pt p pt);
+              [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+           | idtac ]
+      | _:(continuity_pt p pt) |- _ => idtac
+      |  |- (continuity_pt p pt) => idtac
+      |  |- (continuity_pt _ _) =>
+          cut (True -> continuity_pt p pt);
+           [ intro HYPPD; cut (continuity_pt p pt);
+              [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+           | idtac ]
+      |  |- (derive_pt _ _ _ = _) =>
+          cut (True -> derivable_pt p pt);
+           [ intro HYPPD; cut (derivable_pt p pt);
+              [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+           | idtac ]
+      | _ => idtac
+      end
+  end.
+ 
+(**********)
+Ltac is_diff_pt :=
+  match goal with
+  |  |- (derivable_pt Rsqr _) =>
+      
+  (* fonctions de base *)
+  apply derivable_pt_Rsqr
+  |  |- (derivable_pt id ?X1) => apply (derivable_pt_id X1)
+  |  |- (derivable_pt (fct_cte _) _) => apply derivable_pt_const
+  |  |- (derivable_pt sin _) => apply derivable_pt_sin
+  |  |- (derivable_pt cos _) => apply derivable_pt_cos
+  |  |- (derivable_pt sinh _) => apply derivable_pt_sinh
+  |  |- (derivable_pt cosh _) => apply derivable_pt_cosh
+  |  |- (derivable_pt exp _) => apply derivable_pt_exp
+  |  |- (derivable_pt (pow_fct _) _) =>
+      unfold pow_fct in |- *; apply derivable_pt_pow
+  |  |- (derivable_pt sqrt ?X1) =>
+      apply (derivable_pt_sqrt X1);
+       assumption ||
+         unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
+          comp, id, fct_cte, pow_fct in |- *
+  |  |- (derivable_pt Rabs ?X1) =>
+      apply (Rderivable_pt_abs X1);
+       assumption ||
+         unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
+          comp, id, fct_cte, pow_fct in |- *
+        (* regles de differentiabilite *)
+        (* PLUS *)
+  |  |- (derivable_pt (?X1 + ?X2) ?X3) =>
+      apply (derivable_pt_plus X1 X2 X3); is_diff_pt
+       (* MOINS *)
+  |  |- (derivable_pt (?X1 - ?X2) ?X3) =>
+      apply (derivable_pt_minus X1 X2 X3); is_diff_pt
+       (* OPPOSE *)
+  |  |- (derivable_pt (- ?X1) ?X2) =>
+      apply (derivable_pt_opp X1 X2);
+       is_diff_pt
+       (* MULTIPLICATION PAR UN SCALAIRE *)
+  |  |- (derivable_pt (mult_real_fct ?X1 ?X2) ?X3) =>
+      apply (derivable_pt_scal X2 X1 X3); is_diff_pt
+       (* MULTIPLICATION *)
+  |  |- (derivable_pt (?X1 * ?X2) ?X3) =>
+      apply (derivable_pt_mult X1 X2 X3); is_diff_pt
+       (* DIVISION *)
+  |  |- (derivable_pt (?X1 / ?X2) ?X3) =>
+      apply (derivable_pt_div X1 X2 X3);
+       [ is_diff_pt
+       | is_diff_pt
+       | try
+          assumption ||
+            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+             comp, pow_fct, id, fct_cte in |- * ]
+  |  |- (derivable_pt (/ ?X1) ?X2) =>
+      
+       (* INVERSION *)
+       apply (derivable_pt_inv X1 X2);
+       [ assumption ||
+           unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+            comp, pow_fct, id, fct_cte in |- *
+       | is_diff_pt ]
+  |  |- (derivable_pt (comp ?X1 ?X2) ?X3) =>
+      
+       (* COMPOSITION *)
+       apply (derivable_pt_comp X2 X1 X3); is_diff_pt
+  | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) =>
+      assumption
+  | _:(derivable ?X1) |- (derivable_pt ?X1 ?X2) =>
+      cut (derivable X1); [ intro HypDDPT; apply HypDDPT | assumption ]
+  |  |- (True -> derivable_pt _ _) =>
+      intro HypTruE; clear HypTruE; is_diff_pt
+  | _ =>
+      try
+       unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+        fct_cte, comp, pow_fct in |- *
+  end.
+
+(**********)
+Ltac is_diff_glob :=
+  match goal with
+  |  |- (derivable Rsqr) => 
+  (* fonctions de base *)
+  apply derivable_Rsqr
+  |  |- (derivable id) => apply derivable_id
+  |  |- (derivable (fct_cte _)) => apply derivable_const
+  |  |- (derivable sin) => apply derivable_sin
+  |  |- (derivable cos) => apply derivable_cos
+  |  |- (derivable cosh) => apply derivable_cosh
+  |  |- (derivable sinh) => apply derivable_sinh
+  |  |- (derivable exp) => apply derivable_exp
+  |  |- (derivable (pow_fct _)) =>
+      unfold pow_fct in |- *;
+       apply derivable_pow
+        (* regles de differentiabilite *)
+        (* PLUS *)
+  |  |- (derivable (?X1 + ?X2)) =>
+      apply (derivable_plus X1 X2); is_diff_glob
+       (* MOINS *)
+  |  |- (derivable (?X1 - ?X2)) =>
+      apply (derivable_minus X1 X2); is_diff_glob
+       (* OPPOSE *)
+  |  |- (derivable (- ?X1)) =>
+      apply (derivable_opp X1);
+       is_diff_glob
+       (* MULTIPLICATION PAR UN SCALAIRE *)
+  |  |- (derivable (mult_real_fct ?X1 ?X2)) =>
+      apply (derivable_scal X2 X1); is_diff_glob
+       (* MULTIPLICATION *)
+  |  |- (derivable (?X1 * ?X2)) =>
+      apply (derivable_mult X1 X2); is_diff_glob
+       (* DIVISION *)
+  |  |- (derivable (?X1 / ?X2)) =>
+      apply (derivable_div X1 X2);
+       [ is_diff_glob
+       | is_diff_glob
+       | try
+          assumption ||
+            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+             id, fct_cte, comp, pow_fct in |- * ]
+  |  |- (derivable (/ ?X1)) =>
+      
+       (* INVERSION *)
+       apply (derivable_inv X1);
+       [ try
+          assumption ||
+            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+             id, fct_cte, comp, pow_fct in |- *
+       | is_diff_glob ]
+  |  |- (derivable (comp sqrt _)) =>
+      
+       (* COMPOSITION *)
+       unfold derivable in |- *; intro; try is_diff_pt
+  |  |- (derivable (comp Rabs _)) =>
+      unfold derivable in |- *; intro; try is_diff_pt
+  |  |- (derivable (comp ?X1 ?X2)) =>
+      apply (derivable_comp X2 X1); is_diff_glob
+  | _:(derivable ?X1) |- (derivable ?X1) => assumption
+  |  |- (True -> derivable _) =>
+      intro HypTruE; clear HypTruE; is_diff_glob
+  | _ =>
+      try
+       unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+        fct_cte, comp, pow_fct in |- *
+  end.
+
+(**********)
+Ltac is_cont_pt :=
+  match goal with
+  |  |- (continuity_pt Rsqr _) =>
+      
+       (* fonctions de base *)
+       apply derivable_continuous_pt; apply derivable_pt_Rsqr
+  |  |- (continuity_pt id ?X1) =>
+      apply derivable_continuous_pt; apply (derivable_pt_id X1)
+  |  |- (continuity_pt (fct_cte _) _) =>
+      apply derivable_continuous_pt; apply derivable_pt_const
+  |  |- (continuity_pt sin _) =>
+      apply derivable_continuous_pt; apply derivable_pt_sin
+  |  |- (continuity_pt cos _) =>
+      apply derivable_continuous_pt; apply derivable_pt_cos
+  |  |- (continuity_pt sinh _) =>
+      apply derivable_continuous_pt; apply derivable_pt_sinh
+  |  |- (continuity_pt cosh _) =>
+      apply derivable_continuous_pt; apply derivable_pt_cosh
+  |  |- (continuity_pt exp _) =>
+      apply derivable_continuous_pt; apply derivable_pt_exp
+  |  |- (continuity_pt (pow_fct _) _) =>
+      unfold pow_fct in |- *; apply derivable_continuous_pt;
+       apply derivable_pt_pow
+  |  |- (continuity_pt sqrt ?X1) =>
+      apply continuity_pt_sqrt;
+       assumption ||
+         unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
+          comp, id, fct_cte, pow_fct in |- *
+  |  |- (continuity_pt Rabs ?X1) =>
+      apply (Rcontinuity_abs X1)
+       (* regles de differentiabilite *)
+       (* PLUS *)
+  |  |- (continuity_pt (?X1 + ?X2) ?X3) =>
+      apply (continuity_pt_plus X1 X2 X3); is_cont_pt
+       (* MOINS *)
+  |  |- (continuity_pt (?X1 - ?X2) ?X3) =>
+      apply (continuity_pt_minus X1 X2 X3); is_cont_pt
+       (* OPPOSE *)
+  |  |- (continuity_pt (- ?X1) ?X2) =>
+      apply (continuity_pt_opp X1 X2);
+       is_cont_pt
+       (* MULTIPLICATION PAR UN SCALAIRE *)
+  |  |- (continuity_pt (mult_real_fct ?X1 ?X2) ?X3) =>
+      apply (continuity_pt_scal X2 X1 X3); is_cont_pt
+       (* MULTIPLICATION *)
+  |  |- (continuity_pt (?X1 * ?X2) ?X3) =>
+      apply (continuity_pt_mult X1 X2 X3); is_cont_pt
+       (* DIVISION *)
+  |  |- (continuity_pt (?X1 / ?X2) ?X3) =>
+      apply (continuity_pt_div X1 X2 X3);
+       [ is_cont_pt
+       | is_cont_pt
+       | try
+          assumption ||
+            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+             comp, id, fct_cte, pow_fct in |- * ]
+  |  |- (continuity_pt (/ ?X1) ?X2) =>
+      
+       (* INVERSION *)
+       apply (continuity_pt_inv X1 X2);
+       [ is_cont_pt
+       | assumption ||
+           unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+            comp, id, fct_cte, pow_fct in |- * ]
+  |  |- (continuity_pt (comp ?X1 ?X2) ?X3) =>
+      
+       (* COMPOSITION *)
+       apply (continuity_pt_comp X2 X1 X3); is_cont_pt
+  | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
+      assumption
+  | _:(continuity ?X1) |- (continuity_pt ?X1 ?X2) =>
+      cut (continuity X1); [ intro HypDDPT; apply HypDDPT | assumption ]
+  | _:(derivable_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
+      apply derivable_continuous_pt; assumption
+  | _:(derivable ?X1) |- (continuity_pt ?X1 ?X2) =>
+      cut (continuity X1);
+       [ intro HypDDPT; apply HypDDPT
+       | apply derivable_continuous; assumption ]
+  |  |- (True -> continuity_pt _ _) =>
+      intro HypTruE; clear HypTruE; is_cont_pt
+  | _ =>
+      try
+       unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+        fct_cte, comp, pow_fct in |- *
+  end.
+
+(**********)
+Ltac is_cont_glob :=
+  match goal with
+  |  |- (continuity Rsqr) =>
+      
+       (* fonctions de base *)
+       apply derivable_continuous; apply derivable_Rsqr
+  |  |- (continuity id) => apply derivable_continuous; apply derivable_id
+  |  |- (continuity (fct_cte _)) =>
+      apply derivable_continuous; apply derivable_const
+  |  |- (continuity sin) => apply derivable_continuous; apply derivable_sin
+  |  |- (continuity cos) => apply derivable_continuous; apply derivable_cos
+  |  |- (continuity exp) => apply derivable_continuous; apply derivable_exp
+  |  |- (continuity (pow_fct _)) =>
+      unfold pow_fct in |- *; apply derivable_continuous; apply derivable_pow
+  |  |- (continuity sinh) =>
+      apply derivable_continuous; apply derivable_sinh
+  |  |- (continuity cosh) =>
+      apply derivable_continuous; apply derivable_cosh
+  |  |- (continuity Rabs) =>
+      apply Rcontinuity_abs
+       (* regles de continuite *)
+       (* PLUS *)
+  |  |- (continuity (?X1 + ?X2)) =>
+      apply (continuity_plus X1 X2);
+       try is_cont_glob || assumption
+            (* MOINS *)
+  |  |- (continuity (?X1 - ?X2)) =>
+      apply (continuity_minus X1 X2);
+       try is_cont_glob || assumption
+            (* OPPOSE *)
+  |  |- (continuity (- ?X1)) =>
+      apply (continuity_opp X1); try is_cont_glob || assumption
+                                      (* INVERSE *)
+  |  |- (continuity (/ ?X1)) =>
+      apply (continuity_inv X1);
+       try is_cont_glob || assumption
+            (* MULTIPLICATION PAR UN SCALAIRE *)
+  |  |- (continuity (mult_real_fct ?X1 ?X2)) =>
+      apply (continuity_scal X2 X1);
+       try is_cont_glob || assumption
+            (* MULTIPLICATION *)
+  |  |- (continuity (?X1 * ?X2)) =>
+      apply (continuity_mult X1 X2);
+       try is_cont_glob || assumption
+            (* DIVISION *)
+  |  |- (continuity (?X1 / ?X2)) =>
+      apply (continuity_div X1 X2);
+       [ try is_cont_glob || assumption
+       | try is_cont_glob || assumption
+       | try
+          assumption ||
+            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+             id, fct_cte, pow_fct in |- * ]
+  |  |- (continuity (comp sqrt _)) =>
+      
+       (* COMPOSITION *)
+       unfold continuity_pt in |- *; intro; try is_cont_pt
+  |  |- (continuity (comp ?X1 ?X2)) =>
+      apply (continuity_comp X2 X1); try is_cont_glob || assumption
+  | _:(continuity ?X1) |- (continuity ?X1) => assumption
+  |  |- (True -> continuity _) =>
+      intro HypTruE; clear HypTruE; is_cont_glob
+  | _:(derivable ?X1) |- (continuity ?X1) =>
+      apply derivable_continuous; assumption
+  | _ =>
+      try
+       unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+        fct_cte, comp, pow_fct in |- *
+  end.
+
+(**********)
+Ltac rew_term trm :=
+  match constr:trm with
+  | (?X1 + ?X2) =>
+      let p1 := rew_term X1 with p2 := rew_term X2 in
+      match constr:p1 with
+      | (fct_cte ?X3) =>
+          match constr:p2 with
+          | (fct_cte ?X4) => constr:(fct_cte (X3 + X4))
+          | _ => constr:(p1 + p2)%F
+          end
+      | _ => constr:(p1 + p2)%F
+      end
+  | (?X1 - ?X2) =>
+      let p1 := rew_term X1 with p2 := rew_term X2 in
+      match constr:p1 with
+      | (fct_cte ?X3) =>
+          match constr:p2 with
+          | (fct_cte ?X4) => constr:(fct_cte (X3 - X4))
+          | _ => constr:(p1 - p2)%F
+          end
+      | _ => constr:(p1 - p2)%F
+      end
+  | (?X1 / ?X2) =>
+      let p1 := rew_term X1 with p2 := rew_term X2 in
+      match constr:p1 with
+      | (fct_cte ?X3) =>
+          match constr:p2 with
+          | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
+          | _ => constr:(p1 / p2)%F
+          end
+      | _ =>
+          match constr:p2 with
+          | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
+          | _ => constr:(p1 / p2)%F
+          end
+      end
+  | (?X1 * / ?X2) =>
+      let p1 := rew_term X1 with p2 := rew_term X2 in
+      match constr:p1 with
+      | (fct_cte ?X3) =>
+          match constr:p2 with
+          | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
+          | _ => constr:(p1 / p2)%F
+          end
+      | _ =>
+          match constr:p2 with
+          | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
+          | _ => constr:(p1 / p2)%F
+          end
+      end
+  | (?X1 * ?X2) =>
+      let p1 := rew_term X1 with p2 := rew_term X2 in
+      match constr:p1 with
+      | (fct_cte ?X3) =>
+          match constr:p2 with
+          | (fct_cte ?X4) => constr:(fct_cte (X3 * X4))
+          | _ => constr:(p1 * p2)%F
+          end
+      | _ => constr:(p1 * p2)%F
+      end
+  | (- ?X1) =>
+      let p := rew_term X1 in
+      match constr:p with
+      | (fct_cte ?X2) => constr:(fct_cte (- X2))
+      | _ => constr:(- p)%F
+      end
+  | (/ ?X1) =>
+      let p := rew_term X1 in
+      match constr:p with
+      | (fct_cte ?X2) => constr:(fct_cte (/ X2))
+      | _ => constr:(/ p)%F
+      end
+  | (?X1 AppVar) => constr:X1
+  | (?X1 ?X2) =>
+      let p := rew_term X2 in
+      match constr:p with
+      | (fct_cte ?X3) => constr:(fct_cte (X1 X3))
+      | _ => constr:(comp X1 p)
+      end
+  | AppVar => constr:id
+  | (AppVar ^ ?X1) => constr:(pow_fct X1)
+  | (?X1 ^ ?X2) =>
+      let p := rew_term X1 in
+      match constr:p with
+      | (fct_cte ?X3) => constr:(fct_cte (pow_fct X2 X3))
+      | _ => constr:(comp (pow_fct X2) p)
+      end
+  | ?X1 => constr:(fct_cte X1)
+  end.
+
+(**********)
+Ltac deriv_proof trm pt :=
+  match constr:trm with
+  | (?X1 + ?X2)%F =>
+      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
+      constr:(derivable_pt_plus X1 X2 pt p1 p2)
+  | (?X1 - ?X2)%F =>
+      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
+      constr:(derivable_pt_minus X1 X2 pt p1 p2)
+  | (?X1 * ?X2)%F =>
+      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
+      constr:(derivable_pt_mult X1 X2 pt p1 p2)
+  | (?X1 / ?X2)%F =>
+      match goal with
+      | id:(?X2 pt <> 0) |- _ =>
+          let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
+          constr:(derivable_pt_div X1 X2 pt p1 p2 id)
+      | _ => constr:False
+      end
+  | (/ ?X1)%F =>
+      match goal with
+      | id:(?X1 pt <> 0) |- _ =>
+          let p1 := deriv_proof X1 pt in
+          constr:(derivable_pt_inv X1 pt p1 id)
+      | _ => constr:False
+      end
+  | (comp ?X1 ?X2) =>
+      let pt_f1 := eval cbv beta in (X2 pt) in
+      let p1 := deriv_proof X1 pt_f1 with p2 := deriv_proof X2 pt in
+      constr:(derivable_pt_comp X2 X1 pt p2 p1)
+  | (- ?X1)%F =>
+      let p1 := deriv_proof X1 pt in
+      constr:(derivable_pt_opp X1 pt p1)
+  | sin => constr:(derivable_pt_sin pt)
+  | cos => constr:(derivable_pt_cos pt)
+  | sinh => constr:(derivable_pt_sinh pt)
+  | cosh => constr:(derivable_pt_cosh pt)
+  | exp => constr:(derivable_pt_exp pt)
+  | id => constr:(derivable_pt_id pt)
+  | Rsqr => constr:(derivable_pt_Rsqr pt)
+  | sqrt =>
+      match goal with
+      | id:(0 < pt) |- _ => constr:(derivable_pt_sqrt pt id)
+      | _ => constr:False
+      end
+  | (fct_cte ?X1) => constr:(derivable_pt_const X1 pt)
+  | ?X1 =>
+      let aux := constr:X1 in
+      match goal with
+      | id:(derivable_pt aux pt) |- _ => constr:id
+      | id:(derivable aux) |- _ => constr:(id pt)
+      | _ => constr:False
+      end
+  end.
+
+(**********)
+Ltac simplify_derive trm pt :=
+  match constr:trm with
+  | (?X1 + ?X2)%F =>
+      try rewrite derive_pt_plus; simplify_derive X1 pt;
+       simplify_derive X2 pt
+  | (?X1 - ?X2)%F =>
+      try rewrite derive_pt_minus; simplify_derive X1 pt;
+       simplify_derive X2 pt
+  | (?X1 * ?X2)%F =>
+      try rewrite derive_pt_mult; simplify_derive X1 pt;
+       simplify_derive X2 pt
+  | (?X1 / ?X2)%F =>
+      try rewrite derive_pt_div; simplify_derive X1 pt; simplify_derive X2 pt
+  | (comp ?X1 ?X2) =>
+      let pt_f1 := eval cbv beta in (X2 pt) in
+      (try rewrite derive_pt_comp; simplify_derive X1 pt_f1;
+        simplify_derive X2 pt)
+  | (- ?X1)%F => try rewrite derive_pt_opp; simplify_derive X1 pt
+  | (/ ?X1)%F =>
+      try rewrite derive_pt_inv; simplify_derive X1 pt
+  | (fct_cte ?X1) => try rewrite derive_pt_const
+  | id => try rewrite derive_pt_id
+  | sin => try rewrite derive_pt_sin
+  | cos => try rewrite derive_pt_cos
+  | sinh => try rewrite derive_pt_sinh
+  | cosh => try rewrite derive_pt_cosh
+  | exp => try rewrite derive_pt_exp
+  | Rsqr => try rewrite derive_pt_Rsqr
+  | sqrt => try rewrite derive_pt_sqrt
+  | ?X1 =>
+      let aux := constr:X1 in
+      match goal with
+      | id:(derive_pt aux pt ?X2 = _),H:(derivable aux) |- _ =>
+          try replace (derive_pt aux pt (H pt)) with (derive_pt aux pt X2);
+           [ rewrite id | apply pr_nu ]
+      | id:(derive_pt aux pt ?X2 = _),H:(derivable_pt aux pt) |- _ =>
+          try replace (derive_pt aux pt H) with (derive_pt aux pt X2);
+           [ rewrite id | apply pr_nu ]
+      | _ => idtac
+      end
+  | _ => idtac
+  end.
+
+(**********)
+Ltac reg :=
+  match goal with
+  |  |- (derivable_pt ?X1 ?X2) =>
+      let trm := eval cbv beta in (X1 AppVar) in
+      let aux := rew_term trm in
+      (intro_hyp_pt aux X2;
+        try (change (derivable_pt aux X2) in |- *; is_diff_pt) || is_diff_pt)
+  |  |- (derivable ?X1) =>
+      let trm := eval cbv beta in (X1 AppVar) in
+      let aux := rew_term trm in
+      (intro_hyp_glob aux;
+        try (change (derivable aux) in |- *; is_diff_glob) || is_diff_glob)
+  |  |- (continuity ?X1) =>
+      let trm := eval cbv beta in (X1 AppVar) in
+      let aux := rew_term trm in
+      (intro_hyp_glob aux;
+        try (change (continuity aux) in |- *; is_cont_glob) || is_cont_glob)
+  |  |- (continuity_pt ?X1 ?X2) =>
+      let trm := eval cbv beta in (X1 AppVar) in
+      let aux := rew_term trm in
+      (intro_hyp_pt aux X2;
+        try (change (continuity_pt aux X2) in |- *; is_cont_pt) || is_cont_pt)
+  |  |- (derive_pt ?X1 ?X2 ?X3 = ?X4) =>
+      let trm := eval cbv beta in (X1 AppVar) in
+      let aux := rew_term trm in
+      (intro_hyp_pt aux X2;
+        let aux2 := deriv_proof aux X2 in
+        (try
+          (replace (derive_pt X1 X2 X3) with (derive_pt aux X2 aux2);
+            [ simplify_derive aux X2;
+               try
+                unfold plus_fct, minus_fct, mult_fct, div_fct, id, fct_cte,
+                 inv_fct, opp_fct in |- *; try ring
+            | try apply pr_nu ]) || is_diff_pt))
+  end.
\ No newline at end of file
diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v
new file mode 100644
index 00000000..918ebfc0
--- /dev/null
+++ b/theories/Reals/Ranalysis1.v
@@ -0,0 +1,1479 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Ranalysis1.v,v 1.21.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Export Rlimit.
+Require Export Rderiv. Open Local Scope R_scope.
+Implicit Type f : R -> R.
+
+(****************************************************)
+(**           Basic operations on functions         *)
+(****************************************************)
+Definition plus_fct f1 f2 (x:R) : R := f1 x + f2 x.
+Definition opp_fct f (x:R) : R := - f x.
+Definition mult_fct f1 f2 (x:R) : R := f1 x * f2 x.
+Definition mult_real_fct (a:R) f (x:R) : R := a * f x.
+Definition minus_fct f1 f2 (x:R) : R := f1 x - f2 x.
+Definition div_fct f1 f2 (x:R) : R := f1 x / f2 x.
+Definition div_real_fct (a:R) f (x:R) : R := a / f x.
+Definition comp f1 f2 (x:R) : R := f1 (f2 x).
+Definition inv_fct f (x:R) : R := / f x.
+
+Infix "+" := plus_fct : Rfun_scope.
+Notation "- x" := (opp_fct x) : Rfun_scope.
+Infix "*" := mult_fct : Rfun_scope.
+Infix "-" := minus_fct : Rfun_scope.
+Infix "/" := div_fct : Rfun_scope.
+Notation Local "f1 'o' f2" := (comp f1 f2)
+  (at level 20, right associativity) : Rfun_scope.
+Notation "/ x" := (inv_fct x) : Rfun_scope.
+
+Delimit Scope Rfun_scope with F.
+
+Definition fct_cte (a x:R) : R := a.
+Definition id (x:R) := x.
+
+(****************************************************)
+(**            Variations of functions              *)
+(****************************************************)
+Definition increasing f : Prop := forall x y:R, x <= y -> f x <= f y.
+Definition decreasing f : Prop := forall x y:R, x <= y -> f y <= f x.
+Definition strict_increasing f : Prop := forall x y:R, x < y -> f x < f y.
+Definition strict_decreasing f : Prop := forall x y:R, x < y -> f y < f x.
+Definition constant f : Prop := forall x y:R, f x = f y.
+  
+(**********) 
+Definition no_cond (x:R) : Prop := True.
+
+(**********)
+Definition constant_D_eq f (D:R -> Prop) (c:R) : Prop :=
+  forall x:R, D x -> f x = c.
+
+(***************************************************)
+(**      Definition of continuity as a limit       *)
+(***************************************************)
+
+(**********)
+Definition continuity_pt f (x0:R) : Prop := continue_in f no_cond x0.
+Definition continuity f : Prop := forall x:R, continuity_pt f x.
+
+Arguments Scope continuity_pt [Rfun_scope R_scope].
+Arguments Scope continuity [Rfun_scope].
+
+(**********)
+Lemma continuity_pt_plus :
+ forall f1 f2 (x0:R),
+   continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 + f2) x0.
+unfold continuity_pt, plus_fct in |- *; unfold continue_in in |- *; intros;
+ apply limit_plus; assumption.
+Qed.
+
+Lemma continuity_pt_opp :
+ forall f (x0:R), continuity_pt f x0 -> continuity_pt (- f) x0.
+unfold continuity_pt, opp_fct in |- *; unfold continue_in in |- *; intros;
+ apply limit_Ropp; assumption.
+Qed.
+ 
+Lemma continuity_pt_minus :
+ forall f1 f2 (x0:R),
+   continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 - f2) x0.
+unfold continuity_pt, minus_fct in |- *; unfold continue_in in |- *; intros;
+ apply limit_minus; assumption.
+Qed.
+
+Lemma continuity_pt_mult :
+ forall f1 f2 (x0:R),
+   continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 * f2) x0.
+unfold continuity_pt, mult_fct in |- *; unfold continue_in in |- *; intros;
+ apply limit_mul; assumption.
+Qed.
+
+Lemma continuity_pt_const : forall f (x0:R), constant f -> continuity_pt f x0.
+unfold constant, continuity_pt in |- *; unfold continue_in in |- *;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ intros; exists 1; split;
+ [ apply Rlt_0_1
+ | intros; generalize (H x x0); intro; rewrite H2; simpl in |- *;
+    rewrite R_dist_eq; assumption ].
+Qed.
+
+Lemma continuity_pt_scal :
+ forall f (a x0:R),
+   continuity_pt f x0 -> continuity_pt (mult_real_fct a f) x0.
+unfold continuity_pt, mult_real_fct in |- *; unfold continue_in in |- *;
+ intros; apply (limit_mul (fun x:R => a) f (D_x no_cond x0) a (f x0) x0).
+unfold limit1_in in |- *; unfold limit_in in |- *; intros; exists 1; split.
+apply Rlt_0_1.
+intros; rewrite R_dist_eq; assumption.
+assumption.
+Qed.
+
+Lemma continuity_pt_inv :
+ forall f (x0:R), continuity_pt f x0 -> f x0 <> 0 -> continuity_pt (/ f) x0.
+intros.
+replace (/ f)%F with (fun x:R => / f x).
+unfold continuity_pt in |- *; unfold continue_in in |- *; intros;
+ apply limit_inv; assumption.
+unfold inv_fct in |- *; reflexivity.
+Qed.
+ 
+Lemma div_eq_inv : forall f1 f2, (f1 / f2)%F = (f1 * / f2)%F.
+intros; reflexivity.
+Qed.
+ 
+Lemma continuity_pt_div :
+ forall f1 f2 (x0:R),
+   continuity_pt f1 x0 ->
+   continuity_pt f2 x0 -> f2 x0 <> 0 -> continuity_pt (f1 / f2) x0.
+intros; rewrite (div_eq_inv f1 f2); apply continuity_pt_mult;
+ [ assumption | apply continuity_pt_inv; assumption ].
+Qed.
+
+Lemma continuity_pt_comp :
+ forall f1 f2 (x:R),
+   continuity_pt f1 x -> continuity_pt f2 (f1 x) -> continuity_pt (f2 o f1) x.
+unfold continuity_pt in |- *; unfold continue_in in |- *; intros;
+ unfold comp in |- *.
+cut
+ (limit1_in (fun x0:R => f2 (f1 x0))
+    (Dgf (D_x no_cond x) (D_x no_cond (f1 x)) f1) (
+    f2 (f1 x)) x ->
+  limit1_in (fun x0:R => f2 (f1 x0)) (D_x no_cond x) (f2 (f1 x)) x).
+intro; apply H1.
+eapply limit_comp.
+apply H.
+apply H0.
+unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
+ simpl in |- *; unfold R_dist in |- *; intros.
+assert (H3 := H1 eps H2).
+elim H3; intros.
+exists x0.
+split.
+elim H4; intros; assumption.
+intros; case (Req_dec (f1 x) (f1 x1)); intro.
+rewrite H6; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ assumption.
+elim H4; intros; apply H8.
+split.
+unfold Dgf, D_x, no_cond in |- *.
+split.
+split.
+trivial.
+elim H5; unfold D_x, no_cond in |- *; intros.
+elim H9; intros; assumption.
+split.
+trivial.
+assumption.
+elim H5; intros; assumption.
+Qed.
+
+(**********) 
+Lemma continuity_plus :
+ forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 + f2).
+unfold continuity in |- *; intros;
+ apply (continuity_pt_plus f1 f2 x (H x) (H0 x)).
+Qed.
+
+Lemma continuity_opp : forall f, continuity f -> continuity (- f).
+unfold continuity in |- *; intros; apply (continuity_pt_opp f x (H x)).
+Qed.
+
+Lemma continuity_minus :
+ forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 - f2).
+unfold continuity in |- *; intros;
+ apply (continuity_pt_minus f1 f2 x (H x) (H0 x)).
+Qed.
+ 
+Lemma continuity_mult :
+ forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 * f2).
+unfold continuity in |- *; intros;
+ apply (continuity_pt_mult f1 f2 x (H x) (H0 x)).
+Qed.
+
+Lemma continuity_const : forall f, constant f -> continuity f.
+unfold continuity in |- *; intros; apply (continuity_pt_const f x H).
+Qed.
+
+Lemma continuity_scal :
+ forall f (a:R), continuity f -> continuity (mult_real_fct a f).
+unfold continuity in |- *; intros; apply (continuity_pt_scal f a x (H x)).
+Qed.
+  
+Lemma continuity_inv :
+ forall f, continuity f -> (forall x:R, f x <> 0) -> continuity (/ f).
+unfold continuity in |- *; intros; apply (continuity_pt_inv f x (H x) (H0 x)).
+Qed.
+
+Lemma continuity_div :
+ forall f1 f2,
+   continuity f1 ->
+   continuity f2 -> (forall x:R, f2 x <> 0) -> continuity (f1 / f2).
+unfold continuity in |- *; intros;
+ apply (continuity_pt_div f1 f2 x (H x) (H0 x) (H1 x)).
+Qed.
+ 
+Lemma continuity_comp :
+ forall f1 f2, continuity f1 -> continuity f2 -> continuity (f2 o f1).
+unfold continuity in |- *; intros.
+apply (continuity_pt_comp f1 f2 x (H x) (H0 (f1 x))).
+Qed.
+
+
+(*****************************************************)
+(**  Derivative's definition using Landau's kernel   *)
+(*****************************************************)
+
+Definition derivable_pt_lim f (x l:R) : Prop :=
+  forall eps:R,
+    0 < eps ->
+     exists delta : posreal,
+      (forall h:R,
+         h <> 0 -> Rabs h < delta -> Rabs ((f (x + h) - f x) / h - l) < eps).
+
+Definition derivable_pt_abs f (x l:R) : Prop := derivable_pt_lim f x l.
+
+Definition derivable_pt f (x:R) := sigT (derivable_pt_abs f x).
+Definition derivable f := forall x:R, derivable_pt f x.
+
+Definition derive_pt f (x:R) (pr:derivable_pt f x) := projT1 pr.
+Definition derive f (pr:derivable f) (x:R) := derive_pt f x (pr x).
+
+Arguments Scope derivable_pt_lim [Rfun_scope R_scope].
+Arguments Scope derivable_pt_abs [Rfun_scope R_scope R_scope].
+Arguments Scope derivable_pt [Rfun_scope R_scope].
+Arguments Scope derivable [Rfun_scope].
+Arguments Scope derive_pt [Rfun_scope R_scope _].
+Arguments Scope derive [Rfun_scope _].
+
+Definition antiderivative f (g:R -> R) (a b:R) : Prop :=
+  (forall x:R,
+     a <= x <= b ->  exists pr : derivable_pt g x, f x = derive_pt g x pr) /\
+  a <= b.
+(************************************)
+(** Class of differential functions *)
+(************************************)
+Record Differential : Type := mkDifferential
+  {d1 :> R -> R; cond_diff : derivable d1}.
+ 
+Record Differential_D2 : Type := mkDifferential_D2
+  {d2 :> R -> R;
+   cond_D1 : derivable d2;
+   cond_D2 : derivable (derive d2 cond_D1)}.
+
+(**********)
+Lemma uniqueness_step1 :
+ forall f (x l1 l2:R),
+   limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l1 0 ->
+   limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l2 0 ->
+   l1 = l2.
+intros;
+ apply
+  (single_limit (fun h:R => (f (x + h) - f x) / h) (
+     fun h:R => h <> 0) l1 l2 0); try assumption.
+unfold adhDa in |- *; intros; exists (alp / 2).
+split.
+unfold Rdiv in |- *; apply prod_neq_R0.
+red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
+apply Rinv_neq_0_compat; discrR.
+unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; unfold Rdiv in |- *; rewrite Rabs_mult.
+replace (Rabs (/ 2)) with (/ 2).
+replace (Rabs alp) with alp.
+apply Rmult_lt_reg_l with 2.
+prove_sup0.
+rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
+ [ idtac | discrR ]; rewrite Rmult_1_r; rewrite double;
+ pattern alp at 1 in |- *; replace alp with (alp + 0); 
+ [ idtac | ring ]; apply Rplus_lt_compat_l; assumption.
+symmetry  in |- *; apply Rabs_right; left; assumption.
+symmetry  in |- *; apply Rabs_right; left; change (0 < / 2) in |- *;
+ apply Rinv_0_lt_compat; prove_sup0. 
+Qed.
+
+Lemma uniqueness_step2 :
+ forall f (x l:R),
+   derivable_pt_lim f x l ->
+   limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0.
+unfold derivable_pt_lim in |- *; intros; unfold limit1_in in |- *;
+ unfold limit_in in |- *; intros.
+assert (H1 := H eps H0).
+elim H1; intros.
+exists (pos x0).
+split.
+apply (cond_pos x0).
+simpl in |- *; unfold R_dist in |- *; intros.
+elim H3; intros.
+apply H2;
+ [ assumption
+ | unfold Rminus in H5; rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5;
+    assumption ].
+Qed.
+
+Lemma uniqueness_step3 :
+ forall f (x l:R),
+   limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 ->
+   derivable_pt_lim f x l.
+unfold limit1_in, derivable_pt_lim in |- *; unfold limit_in in |- *;
+ unfold dist in |- *; simpl in |- *; intros.
+elim (H eps H0).
+intros; elim H1; intros.
+exists (mkposreal x0 H2).
+simpl in |- *; intros; unfold R_dist in H3; apply (H3 h).
+split;
+ [ assumption
+ | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; assumption ].
+Qed.
+
+Lemma uniqueness_limite :
+ forall f (x l1 l2:R),
+   derivable_pt_lim f x l1 -> derivable_pt_lim f x l2 -> l1 = l2.
+intros.
+assert (H1 := uniqueness_step2 _ _ _ H).
+assert (H2 := uniqueness_step2 _ _ _ H0).
+assert (H3 := uniqueness_step1 _ _ _ _ H1 H2).
+assumption.
+Qed.
+
+Lemma derive_pt_eq :
+ forall f (x l:R) (pr:derivable_pt f x),
+   derive_pt f x pr = l <-> derivable_pt_lim f x l.
+intros; split.
+intro; assert (H1 := projT2 pr); unfold derive_pt in H; rewrite H in H1;
+ assumption.
+intro; assert (H1 := projT2 pr); unfold derivable_pt_abs in H1.
+assert (H2 := uniqueness_limite _ _ _ _ H H1).
+unfold derive_pt in |- *; unfold derivable_pt_abs in |- *.
+symmetry  in |- *; assumption.
+Qed.
+
+(**********)
+Lemma derive_pt_eq_0 :
+ forall f (x l:R) (pr:derivable_pt f x),
+   derivable_pt_lim f x l -> derive_pt f x pr = l.
+intros; elim (derive_pt_eq f x l pr); intros.
+apply (H1 H).
+Qed.
+
+(**********)
+Lemma derive_pt_eq_1 :
+ forall f (x l:R) (pr:derivable_pt f x),
+   derive_pt f x pr = l -> derivable_pt_lim f x l.
+intros; elim (derive_pt_eq f x l pr); intros.
+apply (H0 H).
+Qed.
+
+
+(********************************************************************)
+(** Equivalence of this definition with the one using limit concept *)
+(********************************************************************)
+Lemma derive_pt_D_in :
+ forall f (df:R -> R) (x:R) (pr:derivable_pt f x),
+   D_in f df no_cond x <-> derive_pt f x pr = df x.
+intros; split.
+unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
+ simpl in |- *; unfold R_dist in |- *; intros.
+apply derive_pt_eq_0. 
+unfold derivable_pt_lim in |- *.
+intros; elim (H eps H0); intros alpha H1; elim H1; intros;
+ exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); 
+ intro; cut (x + h - x = h);
+ [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
+    [ intro; generalize (H6 H8); rewrite H7; intro; assumption
+    | split;
+       [ unfold D_x in |- *; split;
+          [ unfold no_cond in |- *; trivial
+          | apply Rminus_not_eq_right; rewrite H7; assumption ]
+       | rewrite H7; assumption ] ]
+ | ring ].
+intro.
+assert (H0 := derive_pt_eq_1 f x (df x) pr H).
+unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
+ unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+ intros.
+elim (H0 eps H1); intros alpha H2; exists (pos alpha); split.
+apply (cond_pos alpha).
+intros; elim H3; intros; unfold D_x in H4; elim H4; intros; cut (x0 - x <> 0).
+intro; generalize (H2 (x0 - x) H8 H5); replace (x + (x0 - x)) with x0.
+intro; assumption.
+ring.
+auto with real.
+Qed.
+
+Lemma derivable_pt_lim_D_in :
+ forall f (df:R -> R) (x:R),
+   D_in f df no_cond x <-> derivable_pt_lim f x (df x).
+intros; split.
+unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
+ simpl in |- *; unfold R_dist in |- *; intros.
+unfold derivable_pt_lim in |- *.
+intros; elim (H eps H0); intros alpha H1; elim H1; intros;
+ exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); 
+ intro; cut (x + h - x = h);
+ [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
+    [ intro; generalize (H6 H8); rewrite H7; intro; assumption
+    | split;
+       [ unfold D_x in |- *; split;
+          [ unfold no_cond in |- *; trivial
+          | apply Rminus_not_eq_right; rewrite H7; assumption ]
+       | rewrite H7; assumption ] ]
+ | ring ].
+intro.
+unfold derivable_pt_lim in H.
+unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
+ unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+ intros.
+elim (H eps H0); intros alpha H2; exists (pos alpha); split.
+apply (cond_pos alpha).
+intros.
+elim H1; intros; unfold D_x in H3; elim H3; intros; cut (x0 - x <> 0).
+intro; generalize (H2 (x0 - x) H7 H4); replace (x + (x0 - x)) with x0.
+intro; assumption.
+ring.
+auto with real.
+Qed.
+
+
+(***********************************)
+(**   derivability -> continuity   *)
+(***********************************)
+(**********)
+Lemma derivable_derive :
+ forall f (x:R) (pr:derivable_pt f x),  exists l : R, derive_pt f x pr = l.
+intros; exists (projT1 pr).
+unfold derive_pt in |- *; reflexivity.
+Qed.
+
+Theorem derivable_continuous_pt :
+ forall f (x:R), derivable_pt f x -> continuity_pt f x.
+intros.
+generalize (derivable_derive f x X); intro.
+elim H; intros l H1.
+cut (l = fct_cte l x).
+intro.
+rewrite H0 in H1.
+generalize (derive_pt_D_in f (fct_cte l) x); intro.
+elim (H2 X); intros.
+generalize (H4 H1); intro.
+unfold continuity_pt in |- *.
+apply (cont_deriv f (fct_cte l) no_cond x H5).
+unfold fct_cte in |- *; reflexivity.
+Qed.
+
+Theorem derivable_continuous : forall f, derivable f -> continuity f.
+unfold derivable, continuity in |- *; intros.
+apply (derivable_continuous_pt f x (X x)).
+Qed.
+
+(****************************************************************)
+(**                      Main rules                             *)
+(****************************************************************)
+
+Lemma derivable_pt_lim_plus :
+ forall f1 f2 (x l1 l2:R),
+   derivable_pt_lim f1 x l1 ->
+   derivable_pt_lim f2 x l2 -> derivable_pt_lim (f1 + f2) x (l1 + l2).
+intros.
+apply uniqueness_step3.
+assert (H1 := uniqueness_step2 _ _ _ H).
+assert (H2 := uniqueness_step2 _ _ _ H0).
+unfold plus_fct in |- *.
+cut
+ (forall h:R,
+    (f1 (x + h) + f2 (x + h) - (f1 x + f2 x)) / h =
+    (f1 (x + h) - f1 x) / h + (f2 (x + h) - f2 x) / h).
+intro.
+generalize
+ (limit_plus (fun h':R => (f1 (x + h') - f1 x) / h')
+    (fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2).
+unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
+ simpl in |- *; unfold R_dist in |- *; intros.
+elim (H4 eps H5); intros.
+exists x0.
+elim H6; intros.
+split.
+assumption.
+intros; rewrite H3; apply H8; assumption.
+intro; unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma derivable_pt_lim_opp :
+ forall f (x l:R), derivable_pt_lim f x l -> derivable_pt_lim (- f) x (- l).
+intros.
+apply uniqueness_step3.
+assert (H1 := uniqueness_step2 _ _ _ H).
+unfold opp_fct in |- *.
+cut (forall h:R, (- f (x + h) - - f x) / h = - ((f (x + h) - f x) / h)).
+intro.
+generalize
+ (limit_Ropp (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 H1).
+unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
+ simpl in |- *; unfold R_dist in |- *; intros.
+elim (H2 eps H3); intros.
+exists x0.
+elim H4; intros.
+split.
+assumption.
+intros; rewrite H0; apply H6; assumption.
+intro; unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma derivable_pt_lim_minus :
+ forall f1 f2 (x l1 l2:R),
+   derivable_pt_lim f1 x l1 ->
+   derivable_pt_lim f2 x l2 -> derivable_pt_lim (f1 - f2) x (l1 - l2).
+intros.
+apply uniqueness_step3.
+assert (H1 := uniqueness_step2 _ _ _ H).
+assert (H2 := uniqueness_step2 _ _ _ H0).
+unfold minus_fct in |- *.
+cut
+ (forall h:R,
+    (f1 (x + h) - f1 x) / h - (f2 (x + h) - f2 x) / h =
+    (f1 (x + h) - f2 (x + h) - (f1 x - f2 x)) / h).
+intro.
+generalize
+ (limit_minus (fun h':R => (f1 (x + h') - f1 x) / h')
+    (fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2).
+unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
+ simpl in |- *; unfold R_dist in |- *; intros.
+elim (H4 eps H5); intros.
+exists x0.
+elim H6; intros.
+split.
+assumption.
+intros; rewrite <- H3; apply H8; assumption.
+intro; unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma derivable_pt_lim_mult :
+ forall f1 f2 (x l1 l2:R),
+   derivable_pt_lim f1 x l1 ->
+   derivable_pt_lim f2 x l2 ->
+   derivable_pt_lim (f1 * f2) x (l1 * f2 x + f1 x * l2).
+intros.
+assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x).
+elim H1; intros.
+assert (H4 := H3 H).
+assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) x).
+elim H5; intros.
+assert (H8 := H7 H0).
+clear H1 H2 H3 H5 H6 H7.
+assert
+ (H1 :=
+  derivable_pt_lim_D_in (f1 * f2)%F (fun y:R => l1 * f2 x + f1 x * l2) x).
+elim H1; intros.
+clear H1 H3.
+apply H2.
+unfold mult_fct in |- *.
+apply (Dmult no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x); assumption.
+Qed.
+
+Lemma derivable_pt_lim_const : forall a x:R, derivable_pt_lim (fct_cte a) x 0.
+intros; unfold fct_cte, derivable_pt_lim in |- *.
+intros; exists (mkposreal 1 Rlt_0_1); intros; unfold Rminus in |- *;
+ rewrite Rplus_opp_r; unfold Rdiv in |- *; rewrite Rmult_0_l;
+ rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+Qed.
+
+Lemma derivable_pt_lim_scal :
+ forall f (a x l:R),
+   derivable_pt_lim f x l -> derivable_pt_lim (mult_real_fct a f) x (a * l).
+intros.
+assert (H0 := derivable_pt_lim_const a x).
+replace (mult_real_fct a f) with (fct_cte a * f)%F.
+replace (a * l) with (0 * f x + a * l); [ idtac | ring ].
+apply (derivable_pt_lim_mult (fct_cte a) f x 0 l); assumption.
+unfold mult_real_fct, mult_fct, fct_cte in |- *; reflexivity.
+Qed.
+
+Lemma derivable_pt_lim_id : forall x:R, derivable_pt_lim id x 1.
+intro; unfold derivable_pt_lim in |- *.
+intros eps Heps; exists (mkposreal eps Heps); intros h H1 H2;
+ unfold id in |- *; replace ((x + h - x) / h - 1) with 0.
+rewrite Rabs_R0; apply Rle_lt_trans with (Rabs h).
+apply Rabs_pos.
+assumption.
+unfold Rminus in |- *; rewrite Rplus_assoc; rewrite (Rplus_comm x);
+ rewrite Rplus_assoc.
+rewrite Rplus_opp_l; rewrite Rplus_0_r; unfold Rdiv in |- *;
+ rewrite <- Rinv_r_sym.
+symmetry  in |- *; apply Rplus_opp_r.
+assumption.
+Qed.
+
+Lemma derivable_pt_lim_Rsqr : forall x:R, derivable_pt_lim Rsqr x (2 * x).
+intro; unfold derivable_pt_lim in |- *.
+unfold Rsqr in |- *; intros eps Heps; exists (mkposreal eps Heps);
+ intros h H1 H2; replace (((x + h) * (x + h) - x * x) / h - 2 * x) with h.
+assumption.
+replace ((x + h) * (x + h) - x * x) with (2 * x * h + h * h);
+ [ idtac | ring ].
+unfold Rdiv in |- *; rewrite Rmult_plus_distr_r.
+repeat rewrite Rmult_assoc.
+repeat rewrite <- Rinv_r_sym; [ idtac | assumption ].
+ring.
+Qed.
+
+Lemma derivable_pt_lim_comp :
+ forall f1 f2 (x l1 l2:R),
+   derivable_pt_lim f1 x l1 ->
+   derivable_pt_lim f2 (f1 x) l2 -> derivable_pt_lim (f2 o f1) x (l2 * l1).
+intros; assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x).
+elim H1; intros.
+assert (H4 := H3 H).
+assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) (f1 x)).
+elim H5; intros.
+assert (H8 := H7 H0).
+clear H1 H2 H3 H5 H6 H7.
+assert (H1 := derivable_pt_lim_D_in (f2 o f1)%F (fun y:R => l2 * l1) x).
+elim H1; intros.
+clear H1 H3; apply H2.
+unfold comp in |- *;
+ cut
+  (D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1)
+     (Dgf no_cond no_cond f1) x ->
+   D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1) no_cond x).
+intro; apply H1.
+rewrite Rmult_comm;
+ apply (Dcomp no_cond no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x);
+ assumption.
+unfold Dgf, D_in, no_cond in |- *; unfold limit1_in in |- *;
+ unfold limit_in in |- *; unfold dist in |- *; simpl in |- *;
+ unfold R_dist in |- *; intros.
+elim (H1 eps H3); intros.
+exists x0; intros; split.
+elim H5; intros; assumption.
+intros; elim H5; intros; apply H9; split.
+unfold D_x in |- *; split.
+split; trivial.
+elim H6; intros; unfold D_x in H10; elim H10; intros; assumption.
+elim H6; intros; assumption.
+Qed.
+
+Lemma derivable_pt_plus :
+ forall f1 f2 (x:R),
+   derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 + f2) x.
+unfold derivable_pt in |- *; intros.
+elim X; intros.
+elim X0; intros.
+apply existT with (x0 + x1).
+apply derivable_pt_lim_plus; assumption.
+Qed.
+
+Lemma derivable_pt_opp :
+ forall f (x:R), derivable_pt f x -> derivable_pt (- f) x.
+unfold derivable_pt in |- *; intros.
+elim X; intros.
+apply existT with (- x0).
+apply derivable_pt_lim_opp; assumption.
+Qed.
+
+Lemma derivable_pt_minus :
+ forall f1 f2 (x:R),
+   derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 - f2) x.
+unfold derivable_pt in |- *; intros.
+elim X; intros.
+elim X0; intros.
+apply existT with (x0 - x1).
+apply derivable_pt_lim_minus; assumption.
+Qed.
+
+Lemma derivable_pt_mult :
+ forall f1 f2 (x:R),
+   derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 * f2) x.
+unfold derivable_pt in |- *; intros.
+elim X; intros.
+elim X0; intros.
+apply existT with (x0 * f2 x + f1 x * x1).
+apply derivable_pt_lim_mult; assumption.
+Qed.
+
+Lemma derivable_pt_const : forall a x:R, derivable_pt (fct_cte a) x.
+intros; unfold derivable_pt in |- *.
+apply existT with 0.
+apply derivable_pt_lim_const.
+Qed.
+
+Lemma derivable_pt_scal :
+ forall f (a x:R), derivable_pt f x -> derivable_pt (mult_real_fct a f) x.
+unfold derivable_pt in |- *; intros.
+elim X; intros.
+apply existT with (a * x0).
+apply derivable_pt_lim_scal; assumption.
+Qed.
+
+Lemma derivable_pt_id : forall x:R, derivable_pt id x.
+unfold derivable_pt in |- *; intro.
+exists 1.
+apply derivable_pt_lim_id.
+Qed.
+
+Lemma derivable_pt_Rsqr : forall x:R, derivable_pt Rsqr x.
+unfold derivable_pt in |- *; intro; apply existT with (2 * x).
+apply derivable_pt_lim_Rsqr.
+Qed.
+
+Lemma derivable_pt_comp :
+ forall f1 f2 (x:R),
+   derivable_pt f1 x -> derivable_pt f2 (f1 x) -> derivable_pt (f2 o f1) x.
+unfold derivable_pt in |- *; intros.
+elim X; intros.
+elim X0; intros.
+apply existT with (x1 * x0).
+apply derivable_pt_lim_comp; assumption.
+Qed.
+
+Lemma derivable_plus :
+ forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 + f2).
+unfold derivable in |- *; intros.
+apply (derivable_pt_plus _ _ x (X _) (X0 _)).
+Qed.
+
+Lemma derivable_opp : forall f, derivable f -> derivable (- f).
+unfold derivable in |- *; intros.
+apply (derivable_pt_opp _ x (X _)).
+Qed.
+
+Lemma derivable_minus :
+ forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 - f2).
+unfold derivable in |- *; intros.
+apply (derivable_pt_minus _ _ x (X _) (X0 _)).
+Qed.
+
+Lemma derivable_mult :
+ forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 * f2).
+unfold derivable in |- *; intros.
+apply (derivable_pt_mult _ _ x (X _) (X0 _)).
+Qed.
+
+Lemma derivable_const : forall a:R, derivable (fct_cte a).
+unfold derivable in |- *; intros.
+apply derivable_pt_const.
+Qed.
+
+Lemma derivable_scal :
+ forall f (a:R), derivable f -> derivable (mult_real_fct a f).
+unfold derivable in |- *; intros.
+apply (derivable_pt_scal _ a x (X _)).
+Qed.
+
+Lemma derivable_id : derivable id.
+unfold derivable in |- *; intro; apply derivable_pt_id.
+Qed.
+
+Lemma derivable_Rsqr : derivable Rsqr.
+unfold derivable in |- *; intro; apply derivable_pt_Rsqr.
+Qed.
+
+Lemma derivable_comp :
+ forall f1 f2, derivable f1 -> derivable f2 -> derivable (f2 o f1).
+unfold derivable in |- *; intros.
+apply (derivable_pt_comp _ _ x (X _) (X0 _)).
+Qed.
+
+Lemma derive_pt_plus :
+ forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
+   derive_pt (f1 + f2) x (derivable_pt_plus _ _ _ pr1 pr2) =
+   derive_pt f1 x pr1 + derive_pt f2 x pr2.
+intros.
+assert (H := derivable_derive f1 x pr1).
+assert (H0 := derivable_derive f2 x pr2).
+assert
+ (H1 := derivable_derive (f1 + f2)%F x (derivable_pt_plus _ _ _ pr1 pr2)).
+elim H; clear H; intros l1 H.
+elim H0; clear H0; intros l2 H0.
+elim H1; clear H1; intros l H1.
+rewrite H; rewrite H0; apply derive_pt_eq_0.
+assert (H3 := projT2 pr1).
+unfold derive_pt in H; rewrite H in H3.
+assert (H4 := projT2 pr2).
+unfold derive_pt in H0; rewrite H0 in H4.
+apply derivable_pt_lim_plus; assumption.
+Qed.
+
+Lemma derive_pt_opp :
+ forall f (x:R) (pr1:derivable_pt f x),
+   derive_pt (- f) x (derivable_pt_opp _ _ pr1) = - derive_pt f x pr1.
+intros.
+assert (H := derivable_derive f x pr1).
+assert (H0 := derivable_derive (- f)%F x (derivable_pt_opp _ _ pr1)).
+elim H; clear H; intros l1 H.
+elim H0; clear H0; intros l2 H0.
+rewrite H; apply derive_pt_eq_0.
+assert (H3 := projT2 pr1).
+unfold derive_pt in H; rewrite H in H3.
+apply derivable_pt_lim_opp; assumption.
+Qed.
+
+Lemma derive_pt_minus :
+ forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
+   derive_pt (f1 - f2) x (derivable_pt_minus _ _ _ pr1 pr2) =
+   derive_pt f1 x pr1 - derive_pt f2 x pr2.
+intros.
+assert (H := derivable_derive f1 x pr1).
+assert (H0 := derivable_derive f2 x pr2).
+assert
+ (H1 := derivable_derive (f1 - f2)%F x (derivable_pt_minus _ _ _ pr1 pr2)).
+elim H; clear H; intros l1 H.
+elim H0; clear H0; intros l2 H0.
+elim H1; clear H1; intros l H1.
+rewrite H; rewrite H0; apply derive_pt_eq_0.
+assert (H3 := projT2 pr1).
+unfold derive_pt in H; rewrite H in H3.
+assert (H4 := projT2 pr2).
+unfold derive_pt in H0; rewrite H0 in H4.
+apply derivable_pt_lim_minus; assumption.
+Qed.
+
+Lemma derive_pt_mult :
+ forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
+   derive_pt (f1 * f2) x (derivable_pt_mult _ _ _ pr1 pr2) =
+   derive_pt f1 x pr1 * f2 x + f1 x * derive_pt f2 x pr2.
+intros.
+assert (H := derivable_derive f1 x pr1).
+assert (H0 := derivable_derive f2 x pr2).
+assert
+ (H1 := derivable_derive (f1 * f2)%F x (derivable_pt_mult _ _ _ pr1 pr2)).
+elim H; clear H; intros l1 H.
+elim H0; clear H0; intros l2 H0.
+elim H1; clear H1; intros l H1.
+rewrite H; rewrite H0; apply derive_pt_eq_0.
+assert (H3 := projT2 pr1).
+unfold derive_pt in H; rewrite H in H3.
+assert (H4 := projT2 pr2).
+unfold derive_pt in H0; rewrite H0 in H4.
+apply derivable_pt_lim_mult; assumption.
+Qed.
+
+Lemma derive_pt_const :
+ forall a x:R, derive_pt (fct_cte a) x (derivable_pt_const a x) = 0.
+intros.
+apply derive_pt_eq_0.
+apply derivable_pt_lim_const.
+Qed.
+
+Lemma derive_pt_scal :
+ forall f (a x:R) (pr:derivable_pt f x),
+   derive_pt (mult_real_fct a f) x (derivable_pt_scal _ _ _ pr) =
+   a * derive_pt f x pr.
+intros.
+assert (H := derivable_derive f x pr).
+assert
+ (H0 := derivable_derive (mult_real_fct a f) x (derivable_pt_scal _ _ _ pr)).
+elim H; clear H; intros l1 H.
+elim H0; clear H0; intros l2 H0.
+rewrite H; apply derive_pt_eq_0.
+assert (H3 := projT2 pr).
+unfold derive_pt in H; rewrite H in H3.
+apply derivable_pt_lim_scal; assumption.
+Qed.
+
+Lemma derive_pt_id : forall x:R, derive_pt id x (derivable_pt_id _) = 1.
+intros.
+apply derive_pt_eq_0.
+apply derivable_pt_lim_id.
+Qed.
+
+Lemma derive_pt_Rsqr :
+ forall x:R, derive_pt Rsqr x (derivable_pt_Rsqr _) = 2 * x.
+intros.
+apply derive_pt_eq_0.
+apply derivable_pt_lim_Rsqr.
+Qed.
+
+Lemma derive_pt_comp :
+ forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 (f1 x)),
+   derive_pt (f2 o f1) x (derivable_pt_comp _ _ _ pr1 pr2) =
+   derive_pt f2 (f1 x) pr2 * derive_pt f1 x pr1.
+intros.
+assert (H := derivable_derive f1 x pr1).
+assert (H0 := derivable_derive f2 (f1 x) pr2).
+assert
+ (H1 := derivable_derive (f2 o f1)%F x (derivable_pt_comp _ _ _ pr1 pr2)).
+elim H; clear H; intros l1 H.
+elim H0; clear H0; intros l2 H0.
+elim H1; clear H1; intros l H1.
+rewrite H; rewrite H0; apply derive_pt_eq_0.
+assert (H3 := projT2 pr1).
+unfold derive_pt in H; rewrite H in H3.
+assert (H4 := projT2 pr2).
+unfold derive_pt in H0; rewrite H0 in H4.
+apply derivable_pt_lim_comp; assumption.
+Qed.
+
+(* Pow *)
+Definition pow_fct (n:nat) (y:R) : R := y ^ n.
+
+Lemma derivable_pt_lim_pow_pos :
+ forall (x:R) (n:nat),
+   (0 < n)%nat -> derivable_pt_lim (fun y:R => y ^ n) x (INR n * x ^ pred n).
+intros.
+induction  n as [| n Hrecn].
+elim (lt_irrefl _ H).
+cut (n = 0%nat \/ (0 < n)%nat).
+intro; elim H0; intro.
+rewrite H1; simpl in |- *.
+replace (fun y:R => y * 1) with (id * fct_cte 1)%F.
+replace (1 * 1) with (1 * fct_cte 1 x + id x * 0).
+apply derivable_pt_lim_mult.
+apply derivable_pt_lim_id.
+apply derivable_pt_lim_const.
+unfold fct_cte, id in |- *; ring.
+reflexivity.
+replace (fun y:R => y ^ S n) with (fun y:R => y * y ^ n).
+replace (pred (S n)) with n; [ idtac | reflexivity ].
+replace (fun y:R => y * y ^ n) with (id * (fun y:R => y ^ n))%F.
+set (f := fun y:R => y ^ n).
+replace (INR (S n) * x ^ n) with (1 * f x + id x * (INR n * x ^ pred n)).
+apply derivable_pt_lim_mult.
+apply derivable_pt_lim_id.
+unfold f in |- *; apply Hrecn; assumption.
+unfold f in |- *.
+pattern n at 1 5 in |- *; replace n with (S (pred n)).
+unfold id in |- *; rewrite S_INR; simpl in |- *.
+ring.
+symmetry  in |- *; apply S_pred with 0%nat; assumption.
+unfold mult_fct, id in |- *; reflexivity.
+reflexivity.
+inversion H.
+left; reflexivity.
+right.
+apply lt_le_trans with 1%nat.
+apply lt_O_Sn.
+assumption.
+Qed.
+
+Lemma derivable_pt_lim_pow :
+ forall (x:R) (n:nat),
+   derivable_pt_lim (fun y:R => y ^ n) x (INR n * x ^ pred n).
+intros.
+induction  n as [| n Hrecn].
+simpl in |- *.
+rewrite Rmult_0_l.
+replace (fun _:R => 1) with (fct_cte 1);
+ [ apply derivable_pt_lim_const | reflexivity ].
+apply derivable_pt_lim_pow_pos.
+apply lt_O_Sn.
+Qed.
+
+Lemma derivable_pt_pow :
+ forall (n:nat) (x:R), derivable_pt (fun y:R => y ^ n) x.
+intros; unfold derivable_pt in |- *.
+apply existT with (INR n * x ^ pred n).
+apply derivable_pt_lim_pow.
+Qed.
+
+Lemma derivable_pow : forall n:nat, derivable (fun y:R => y ^ n).
+intro; unfold derivable in |- *; intro; apply derivable_pt_pow.
+Qed.
+
+Lemma derive_pt_pow :
+ forall (n:nat) (x:R),
+   derive_pt (fun y:R => y ^ n) x (derivable_pt_pow n x) = INR n * x ^ pred n.
+intros; apply derive_pt_eq_0.
+apply derivable_pt_lim_pow.
+Qed.
+
+Lemma pr_nu :
+ forall f (x:R) (pr1 pr2:derivable_pt f x),
+   derive_pt f x pr1 = derive_pt f x pr2. 
+intros.
+unfold derivable_pt in pr1.
+unfold derivable_pt in pr2.
+elim pr1; intros.
+elim pr2; intros.
+unfold derivable_pt_abs in p.
+unfold derivable_pt_abs in p0.
+simpl in |- *.
+apply (uniqueness_limite f x x0 x1 p p0).
+Qed.
+
+
+(************************************************************)
+(**             Local extremum's condition                  *)
+(************************************************************)
+
+Theorem deriv_maximum :
+ forall f (a b c:R) (pr:derivable_pt f c),
+   a < c ->
+   c < b ->
+   (forall x:R, a < x -> x < b -> f x <= f c) -> derive_pt f c pr = 0.
+intros; case (Rtotal_order 0 (derive_pt f c pr)); intro.
+assert (H3 := derivable_derive f c pr).
+elim H3; intros l H4; rewrite H4 in H2.
+assert (H5 := derive_pt_eq_1 f c l pr H4).
+cut (0 < l / 2);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+elim (H5 (l / 2) H6); intros delta H7.
+cut (0 < (b - c) / 2).
+intro; cut (Rmin (delta / 2) ((b - c) / 2) <> 0).
+intro; cut (Rabs (Rmin (delta / 2) ((b - c) / 2)) < delta).
+intro.
+assert (H11 := H7 (Rmin (delta / 2) ((b - c) / 2)) H9 H10).
+cut (0 < Rmin (delta / 2) ((b - c) / 2)).
+intro; cut (a < c + Rmin (delta / 2) ((b - c) / 2)).
+intro; cut (c + Rmin (delta / 2) ((b - c) / 2) < b).
+intro; assert (H15 := H1 (c + Rmin (delta / 2) ((b - c) / 2)) H13 H14).
+cut
+ ((f (c + Rmin (delta / 2) ((b - c) / 2)) - f c) /
+  Rmin (delta / 2) ((b - c) / 2) <= 0).
+intro; cut (- l < 0).
+intro; unfold Rminus in H11.
+cut
+ ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+  Rmin (delta / 2) ((b + - c) / 2) + - l < 0).
+intro;
+ cut
+  (Rabs
+     ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+      Rmin (delta / 2) ((b + - c) / 2) + - l) < l / 2).
+unfold Rabs in |- *;
+ case
+  (Rcase_abs
+     ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+      Rmin (delta / 2) ((b + - c) / 2) + - l)); intro.
+replace
+ (-
+  ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+   Rmin (delta / 2) ((b + - c) / 2) + - l)) with
+ (l +
+  -
+  ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+   Rmin (delta / 2) ((b + - c) / 2))).
+intro;
+ generalize
+  (Rplus_lt_compat_l (- l)
+     (l +
+      -
+      ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+       Rmin (delta / 2) ((b + - c) / 2))) (l / 2) H19);
+ repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; 
+ rewrite Rplus_0_l; replace (- l + l / 2) with (- (l / 2)).
+intro;
+ generalize
+  (Ropp_lt_gt_contravar
+     (-
+      ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+       Rmin (delta / 2) ((b + - c) / 2))) (- (l / 2)) H20);
+ repeat rewrite Ropp_involutive; intro;
+ generalize
+  (Rlt_trans 0 (l / 2)
+     ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+      Rmin (delta / 2) ((b + - c) / 2)) H6 H21); intro;
+ elim
+  (Rlt_irrefl 0
+     (Rlt_le_trans 0
+        ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+         Rmin (delta / 2) ((b + - c) / 2)) 0 H22 H16)).
+pattern l at 2 in |- *; rewrite double_var.
+ring.
+ring.
+intro.
+assert
+ (H20 :=
+  Rge_le
+    ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+     Rmin (delta / 2) ((b + - c) / 2) + - l) 0 r).
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)). 
+assumption.
+rewrite <- Ropp_0;
+ replace
+  ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+   Rmin (delta / 2) ((b + - c) / 2) + - l) with
+  (-
+   (l +
+    -
+    ((f (c + Rmin (delta / 2) ((b + - c) / 2)) - f c) /
+     Rmin (delta / 2) ((b + - c) / 2)))).
+apply Ropp_gt_lt_contravar;
+ change
+   (0 <
+    l +
+    -
+    ((f (c + Rmin (delta / 2) ((b + - c) / 2)) - f c) /
+     Rmin (delta / 2) ((b + - c) / 2))) in |- *; apply Rplus_lt_le_0_compat;
+ [ assumption
+ | rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption ].
+ring.
+rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
+replace
+ ((f (c + Rmin (delta / 2) ((b - c) / 2)) - f c) /
+  Rmin (delta / 2) ((b - c) / 2)) with
+ (-
+  ((f c - f (c + Rmin (delta / 2) ((b - c) / 2))) /
+   Rmin (delta / 2) ((b - c) / 2))).
+rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge;
+ unfold Rdiv in |- *; apply Rmult_le_pos;
+ [ generalize
+    (Rplus_le_compat_r (- f (c + Rmin (delta * / 2) ((b - c) * / 2)))
+       (f (c + Rmin (delta * / 2) ((b - c) * / 2))) (
+       f c) H15); rewrite Rplus_opp_r; intro; assumption
+ | left; apply Rinv_0_lt_compat; assumption ].
+unfold Rdiv in |- *.
+rewrite <- Ropp_mult_distr_l_reverse.
+repeat rewrite <- (Rmult_comm (/ Rmin (delta * / 2) ((b - c) * / 2))).
+apply Rmult_eq_reg_l with (Rmin (delta * / 2) ((b - c) * / 2)).
+repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_r_sym.
+repeat rewrite Rmult_1_l.
+ring.
+red in |- *; intro.
+unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12).
+red in |- *; intro.
+unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12).
+assert (H14 := Rmin_r (delta / 2) ((b - c) / 2)).
+assert
+ (H15 :=
+  Rplus_le_compat_l c (Rmin (delta / 2) ((b - c) / 2)) ((b - c) / 2) H14).
+apply Rle_lt_trans with (c + (b - c) / 2).
+assumption.
+apply Rmult_lt_reg_l with 2.
+prove_sup0.
+replace (2 * (c + (b - c) / 2)) with (c + b).
+replace (2 * b) with (b + b).
+apply Rplus_lt_compat_r; assumption.
+ring.
+unfold Rdiv in |- *; rewrite Rmult_plus_distr_l.
+repeat rewrite (Rmult_comm 2).
+rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+ring.
+discrR.
+apply Rlt_trans with c.
+assumption.
+pattern c at 1 in |- *; rewrite <- (Rplus_0_r c); apply Rplus_lt_compat_l;
+ assumption.
+cut (0 < delta / 2).
+intro;
+ apply
+  (Rmin_stable_in_posreal (mkposreal (delta / 2) H12)
+     (mkposreal ((b - c) / 2) H8)).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+unfold Rabs in |- *; case (Rcase_abs (Rmin (delta / 2) ((b - c) / 2))).
+intro.
+cut (0 < delta / 2).
+intro.
+generalize
+ (Rmin_stable_in_posreal (mkposreal (delta / 2) H10)
+    (mkposreal ((b - c) / 2) H8)); simpl in |- *; intro;
+ elim (Rlt_irrefl 0 (Rlt_trans 0 (Rmin (delta / 2) ((b - c) / 2)) 0 H11 r)).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+intro; apply Rle_lt_trans with (delta / 2).
+apply Rmin_l.
+unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+prove_sup0.
+rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l.
+replace (2 * delta) with (delta + delta). 
+pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta);
+ apply Rplus_lt_compat_l.
+rewrite Rplus_0_r; apply (cond_pos delta).
+symmetry  in |- *; apply double.
+discrR.
+cut (0 < delta / 2).
+intro;
+ generalize
+  (Rmin_stable_in_posreal (mkposreal (delta / 2) H9)
+     (mkposreal ((b - c) / 2) H8)); simpl in |- *; 
+ intro; red in |- *; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+generalize (Rplus_lt_compat_r (- c) c b H0); rewrite Rplus_opp_r; intro;
+ assumption.
+apply Rinv_0_lt_compat; prove_sup0.
+elim H2; intro.
+symmetry  in |- *; assumption.
+generalize (derivable_derive f c pr); intro; elim H4; intros l H5.
+rewrite H5 in H3; generalize (derive_pt_eq_1 f c l pr H5); intro;
+ cut (0 < - (l / 2)).
+intro; elim (H6 (- (l / 2)) H7); intros delta H9.
+cut (0 < (c - a) / 2).
+intro; cut (Rmax (- (delta / 2)) ((a - c) / 2) < 0).
+intro; cut (Rmax (- (delta / 2)) ((a - c) / 2) <> 0).
+intro; cut (Rabs (Rmax (- (delta / 2)) ((a - c) / 2)) < delta).
+intro; generalize (H9 (Rmax (- (delta / 2)) ((a - c) / 2)) H11 H12); intro;
+ cut (a < c + Rmax (- (delta / 2)) ((a - c) / 2)).
+cut (c + Rmax (- (delta / 2)) ((a - c) / 2) < b).
+intros; generalize (H1 (c + Rmax (- (delta / 2)) ((a - c) / 2)) H15 H14);
+ intro;
+ cut
+  (0 <=
+   (f (c + Rmax (- (delta / 2)) ((a - c) / 2)) - f c) /
+   Rmax (- (delta / 2)) ((a - c) / 2)).
+intro; cut (0 < - l).
+intro; unfold Rminus in H13;
+ cut
+  (0 <
+   (f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
+   Rmax (- (delta / 2)) ((a + - c) / 2) + - l).
+intro;
+ cut
+  (Rabs
+     ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
+      Rmax (- (delta / 2)) ((a + - c) / 2) + - l) < 
+   - (l / 2)).
+unfold Rabs in |- *;
+ case
+  (Rcase_abs
+     ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
+      Rmax (- (delta / 2)) ((a + - c) / 2) + - l)).
+intro;
+ elim
+  (Rlt_irrefl 0
+     (Rlt_trans 0
+        ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
+         Rmax (- (delta / 2)) ((a + - c) / 2) + - l) 0 H19 r)).
+intros;
+ generalize
+  (Rplus_lt_compat_r l
+     ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
+      Rmax (- (delta / 2)) ((a + - c) / 2) + - l) (
+     - (l / 2)) H20); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l;
+ rewrite Rplus_0_r; replace (- (l / 2) + l) with (l / 2).
+cut (l / 2 < 0).
+intros;
+ generalize
+  (Rlt_trans
+     ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
+      Rmax (- (delta / 2)) ((a + - c) / 2)) (l / 2) 0 H22 H21); 
+ intro;
+ elim
+  (Rlt_irrefl 0
+     (Rle_lt_trans 0
+        ((f (c + Rmax (- (delta / 2)) ((a - c) / 2)) - f c) /
+         Rmax (- (delta / 2)) ((a - c) / 2)) 0 H17 H23)).
+rewrite <- (Ropp_involutive (l / 2)); rewrite <- Ropp_0;
+ apply Ropp_lt_gt_contravar; assumption.
+pattern l at 3 in |- *; rewrite double_var.
+ring.
+assumption.
+apply Rplus_le_lt_0_compat; assumption.
+rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
+unfold Rdiv in |- *;
+ replace
+  ((f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c) *
+   / Rmax (- (delta * / 2)) ((a - c) * / 2)) with
+  (- (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c) *
+   / - Rmax (- (delta * / 2)) ((a - c) * / 2)).
+apply Rmult_le_pos.
+generalize
+ (Rplus_le_compat_l (- f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)))
+    (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2))) (
+    f c) H16); rewrite Rplus_opp_l;
+ replace (- (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c)) with
+  (- f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) + f c).
+intro; assumption.
+ring.
+left; apply Rinv_0_lt_compat; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar;
+ assumption.
+unfold Rdiv in |- *.
+rewrite <- Ropp_inv_permute.
+rewrite Rmult_opp_opp.
+reflexivity.
+unfold Rdiv in H11; assumption.
+generalize (Rplus_lt_compat_l c (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H10);
+ rewrite Rplus_0_r; intro; apply Rlt_trans with c; 
+ assumption.
+generalize (RmaxLess2 (- (delta / 2)) ((a - c) / 2)); intro;
+ generalize
+  (Rplus_le_compat_l c ((a - c) / 2) (Rmax (- (delta / 2)) ((a - c) / 2)) H14);
+ intro; apply Rlt_le_trans with (c + (a - c) / 2).
+apply Rmult_lt_reg_l with 2.
+prove_sup0.
+replace (2 * (c + (a - c) / 2)) with (a + c).
+rewrite double.
+apply Rplus_lt_compat_l; assumption.
+ring.
+rewrite <- Rplus_assoc.
+rewrite <- double_var.
+ring.
+assumption.
+unfold Rabs in |- *; case (Rcase_abs (Rmax (- (delta / 2)) ((a - c) / 2))).
+intro; generalize (RmaxLess1 (- (delta / 2)) ((a - c) / 2)); intro;
+ generalize
+  (Ropp_le_ge_contravar (- (delta / 2)) (Rmax (- (delta / 2)) ((a - c) / 2))
+     H12); rewrite Ropp_involutive; intro;
+ generalize (Rge_le (delta / 2) (- Rmax (- (delta / 2)) ((a - c) / 2)) H13);
+ intro; apply Rle_lt_trans with (delta / 2).
+assumption.
+apply Rmult_lt_reg_l with 2. 
+prove_sup0.
+unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; rewrite double.
+pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta);
+ apply Rplus_lt_compat_l; rewrite Rplus_0_r; apply (cond_pos delta).
+discrR. 
+cut (- (delta / 2) < 0).
+cut ((a - c) / 2 < 0).
+intros;
+ generalize
+  (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H13)
+     (mknegreal ((a - c) / 2) H12)); simpl in |- *; 
+ intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 r); 
+ intro;
+ elim
+  (Rlt_irrefl 0
+     (Rle_lt_trans 0 (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H15 H14)).
+rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2));
+ apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
+assumption.
+unfold Rdiv in |- *.
+rewrite <- Ropp_mult_distr_l_reverse. 
+rewrite (Ropp_minus_distr a c).
+reflexivity.
+rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv in |- *;
+ apply Rmult_lt_0_compat;
+ [ apply (cond_pos delta)
+ | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
+red in |- *; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
+cut ((a - c) / 2 < 0).
+intro; cut (- (delta / 2) < 0).
+intro;
+ apply
+  (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H11)
+     (mknegreal ((a - c) / 2) H10)).
+rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv in |- *;
+ apply Rmult_lt_0_compat;
+ [ apply (cond_pos delta)
+ | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
+rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2));
+ apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
+assumption.
+unfold Rdiv in |- *.
+rewrite <- Ropp_mult_distr_l_reverse. 
+rewrite (Ropp_minus_distr a c).
+reflexivity.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ generalize (Rplus_lt_compat_r (- a) a c H); rewrite Rplus_opp_r; intro;
+    assumption
+ | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
+replace (- (l / 2)) with (- l / 2).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
+assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ].
+unfold Rdiv in |- *; apply Ropp_mult_distr_l_reverse.
+Qed.
+
+Theorem deriv_minimum :
+ forall f (a b c:R) (pr:derivable_pt f c),
+   a < c ->
+   c < b ->
+   (forall x:R, a < x -> x < b -> f c <= f x) -> derive_pt f c pr = 0.
+intros.
+rewrite <- (Ropp_involutive (derive_pt f c pr)).
+apply Ropp_eq_0_compat.
+rewrite <- (derive_pt_opp f c pr).
+cut (forall x:R, a < x -> x < b -> (- f)%F x <= (- f)%F c).
+intro.
+apply (deriv_maximum (- f)%F a b c (derivable_pt_opp _ _ pr) H H0 H2).
+intros; unfold opp_fct in |- *; apply Ropp_ge_le_contravar; apply Rle_ge.
+apply (H1 x H2 H3).
+Qed.
+ 
+Theorem deriv_constant2 :
+ forall f (a b c:R) (pr:derivable_pt f c),
+   a < c ->
+   c < b -> (forall x:R, a < x -> x < b -> f x = f c) -> derive_pt f c pr = 0.
+intros.
+eapply deriv_maximum with a b; try assumption.
+intros; right; apply (H1 x H2 H3).
+Qed.
+
+(**********)
+Lemma nonneg_derivative_0 :
+ forall f (pr:derivable f),
+   increasing f -> forall x:R, 0 <= derive_pt f x (pr x).
+intros; unfold increasing in H.
+assert (H0 := derivable_derive f x (pr x)).
+elim H0; intros l H1.
+rewrite H1; case (Rtotal_order 0 l); intro.
+left; assumption.
+elim H2; intro.
+right; assumption.
+assert (H4 := derive_pt_eq_1 f x l (pr x) H1).
+cut (0 < - (l / 2)).
+intro; elim (H4 (- (l / 2)) H5); intros delta H6.
+cut (delta / 2 <> 0 /\ 0 < delta / 2 /\ Rabs (delta / 2) < delta).
+intro; decompose [and] H7; intros; generalize (H6 (delta / 2) H8 H11);
+ cut (0 <= (f (x + delta / 2) - f x) / (delta / 2)).
+intro; cut (0 <= (f (x + delta / 2) - f x) / (delta / 2) - l).
+intro; unfold Rabs in |- *;
+ case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)).
+intro;
+ elim
+  (Rlt_irrefl 0
+     (Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 H12 r)).
+intros;
+ generalize
+  (Rplus_lt_compat_r l ((f (x + delta / 2) - f x) / (delta / 2) - l)
+     (- (l / 2)) H13); unfold Rminus in |- *;
+ replace (- (l / 2) + l) with (l / 2).
+rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; intro;
+ generalize
+  (Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2)) (l / 2) H9 H14);
+ intro; cut (l / 2 < 0).
+intro; elim (Rlt_irrefl 0 (Rlt_trans 0 (l / 2) 0 H15 H16)).
+rewrite <- Ropp_0 in H5;
+ generalize (Ropp_lt_gt_contravar (-0) (- (l / 2)) H5);
+ repeat rewrite Ropp_involutive; intro; assumption.
+pattern l at 3 in |- *; rewrite double_var.
+ring.
+unfold Rminus in |- *; apply Rplus_le_le_0_compat.
+unfold Rdiv in |- *; apply Rmult_le_pos.
+cut (x <= x + delta * / 2).
+intro; generalize (H x (x + delta * / 2) H12); intro;
+ generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H13);
+ rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
+pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+ left; assumption.
+left; apply Rinv_0_lt_compat; assumption.
+left; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
+unfold Rdiv in |- *; apply Rmult_le_pos.
+cut (x <= x + delta * / 2).
+intro; generalize (H x (x + delta * / 2) H9); intro;
+ generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H12);
+ rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
+pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+ left; assumption. 
+left; apply Rinv_0_lt_compat; assumption.
+split.
+unfold Rdiv in |- *; apply prod_neq_R0.
+generalize (cond_pos delta); intro; red in |- *; intro H9; rewrite H9 in H7;
+ elim (Rlt_irrefl 0 H7).
+apply Rinv_neq_0_compat; discrR.
+split.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+replace (Rabs (delta / 2)) with (delta / 2).
+unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+prove_sup0.
+rewrite (Rmult_comm 2).
+rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
+rewrite Rmult_1_r.
+rewrite double.
+pattern (pos delta) at 1 in |- *; rewrite <- Rplus_0_r.
+apply Rplus_lt_compat_l; apply (cond_pos delta).
+symmetry  in |- *; apply Rabs_right.
+left; change (0 < delta / 2) in |- *; unfold Rdiv in |- *;
+ apply Rmult_lt_0_compat;
+ [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse;
+ apply Rmult_lt_0_compat.
+apply Rplus_lt_reg_r with l.
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r; assumption.
+apply Rinv_0_lt_compat; prove_sup0.
+Qed.
diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v
new file mode 100644
index 00000000..35f7eab8
--- /dev/null
+++ b/theories/Reals/Ranalysis2.v
@@ -0,0 +1,450 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Ranalysis2.v,v 1.11.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Ranalysis1. Open Local Scope R_scope.
+
+(**********)
+Lemma formule :
+ forall (x h l1 l2:R) (f1 f2:R -> R),
+   h <> 0 ->
+   f2 x <> 0 ->
+   f2 (x + h) <> 0 ->
+   (f1 (x + h) / f2 (x + h) - f1 x / f2 x) / h -
+   (l1 * f2 x - l2 * f1 x) / Rsqr (f2 x) =
+   / f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1) +
+   l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h)) -
+   f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2) +
+   l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x).
+intros; unfold Rdiv, Rminus, Rsqr in |- *.
+repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
+ repeat rewrite Rinv_mult_distr; try assumption.
+replace (l1 * f2 x * (/ f2 x * / f2 x)) with (l1 * / f2 x * (f2 x * / f2 x));
+ [ idtac | ring ].
+replace (l1 * (/ f2 x * / f2 (x + h)) * f2 x) with
+ (l1 * / f2 (x + h) * (f2 x * / f2 x)); [ idtac | ring ].
+replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with
+ (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))); [ idtac | ring ].
+replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with
+ (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h))); 
+ [ idtac | ring ].
+replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with
+ (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x))); 
+ [ idtac | ring ].
+replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with
+ (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h)));
+ [ idtac | ring ].
+replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with
+ (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x))); 
+ [ idtac | ring ].
+repeat rewrite <- Rinv_r_sym; try assumption || ring.
+apply prod_neq_R0; assumption.
+Qed.
+
+Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y.
+intros; unfold Rmin in |- *.
+case (Rle_dec x y); intro; assumption.
+Qed.
+
+Lemma maj_term1 :
+ forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal) 
+   (f1 f2:R -> R),
+   0 < eps ->
+   f2 x <> 0 ->
+   f2 (x + h) <> 0 ->
+   (forall h:R,
+      h <> 0 ->
+      Rabs h < alp_f1d ->
+      Rabs ((f1 (x + h) - f1 x) / h - l1) < Rabs (eps * f2 x / 8)) ->
+   (forall a:R,
+      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
+   h <> 0 ->
+   Rabs h < alp_f1d ->
+   Rabs h < Rmin eps_f2 alp_f2 ->
+   Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) < eps / 4.
+intros.
+assert (H7 := H3 h H6).
+assert (H8 := H2 h H4 H5).
+apply Rle_lt_trans with
+ (2 / Rabs (f2 x) * Rabs ((f1 (x + h) - f1 x) / h - l1)).
+rewrite Rabs_mult.
+apply Rmult_le_compat_r.
+apply Rabs_pos.
+rewrite Rabs_Rinv; [ left; exact H7 | assumption ].
+apply Rlt_le_trans with (2 / Rabs (f2 x) * Rabs (eps * f2 x / 8)).
+apply Rmult_lt_compat_l.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ prove_sup0 | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
+exact H8.
+right; unfold Rdiv in |- *.
+repeat rewrite Rabs_mult.
+rewrite Rabs_Rinv; discrR.
+replace (Rabs 8) with 8.
+replace 8 with 8; [ idtac | ring ].
+rewrite Rinv_mult_distr; [ idtac | discrR | discrR ].
+replace (2 * / Rabs (f2 x) * (Rabs eps * Rabs (f2 x) * (/ 2 * / 4))) with
+ (Rabs eps * / 4 * (2 * / 2) * (Rabs (f2 x) * / Rabs (f2 x)));
+ [ idtac | ring ].
+replace (Rabs eps) with eps.
+repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
+ring.
+symmetry  in |- *; apply Rabs_right; left; assumption.
+symmetry  in |- *; apply Rabs_right; left; prove_sup.
+Qed.
+
+Lemma maj_term2 :
+ forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal) 
+   (f2:R -> R),
+   0 < eps ->
+   f2 x <> 0 ->
+   f2 (x + h) <> 0 ->
+   (forall a:R,
+      Rabs a < alp_f2t2 ->
+      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))) ->
+   (forall a:R,
+      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
+   h <> 0 ->
+   Rabs h < alp_f2t2 ->
+   Rabs h < Rmin eps_f2 alp_f2 ->
+   l1 <> 0 -> Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) < eps / 4.
+intros.
+assert (H8 := H3 h H6).
+assert (H9 := H2 h H5).
+apply Rle_lt_trans with
+ (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
+rewrite Rabs_mult; apply Rmult_le_compat_l.
+apply Rabs_pos.
+rewrite <- (Rabs_Ropp (f2 x - f2 (x + h))); rewrite Ropp_minus_distr.
+left; apply H9.
+apply Rlt_le_trans with
+ (Rabs (2 * (l1 / (f2 x * f2 x))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
+apply Rmult_lt_compat_r.
+apply Rabs_pos_lt.
+unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
+ try assumption || discrR.
+red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
+apply Rinv_neq_0_compat; apply prod_neq_R0; try assumption || discrR.
+unfold Rdiv in |- *.
+repeat rewrite Rinv_mult_distr; try assumption.
+repeat rewrite Rabs_mult.
+replace (Rabs 2) with 2.
+rewrite (Rmult_comm 2).
+replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
+ (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); 
+ [ idtac | ring ].
+repeat apply Rmult_lt_compat_l.
+apply Rabs_pos_lt; assumption.
+apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
+repeat rewrite Rabs_Rinv; try assumption.
+rewrite <- (Rmult_comm 2).
+unfold Rdiv in H8; exact H8.
+symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+right.
+unfold Rsqr, Rdiv in |- *.
+do 1 rewrite Rinv_mult_distr; try assumption || discrR.
+do 1 rewrite Rinv_mult_distr; try assumption || discrR.
+repeat rewrite Rabs_mult.
+repeat rewrite Rabs_Rinv; try assumption || discrR.
+replace (Rabs eps) with eps.
+replace (Rabs 8) with 8.
+replace (Rabs 2) with 2.
+replace 8 with (4 * 2); [ idtac | ring ].
+rewrite Rinv_mult_distr; discrR.
+replace
+ (2 * (Rabs l1 * (/ Rabs (f2 x) * / Rabs (f2 x))) *
+  (eps * (Rabs (f2 x) * Rabs (f2 x)) * (/ 4 * / 2 * / Rabs l1))) with
+ (eps * / 4 * (Rabs l1 * / Rabs l1) * (Rabs (f2 x) * / Rabs (f2 x)) *
+  (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
+repeat rewrite <- Rinv_r_sym; try (apply Rabs_no_R0; assumption) || discrR.
+ring.
+symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+symmetry  in |- *; apply Rabs_right; left; prove_sup.
+symmetry  in |- *; apply Rabs_right; left; assumption.
+Qed.
+
+Lemma maj_term3 :
+ forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal) 
+   (f1 f2:R -> R),
+   0 < eps ->
+   f2 x <> 0 ->
+   f2 (x + h) <> 0 ->
+   (forall h:R,
+      h <> 0 ->
+      Rabs h < alp_f2d ->
+      Rabs ((f2 (x + h) - f2 x) / h - l2) <
+      Rabs (Rsqr (f2 x) * eps / (8 * f1 x))) ->
+   (forall a:R,
+      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
+   h <> 0 ->
+   Rabs h < alp_f2d ->
+   Rabs h < Rmin eps_f2 alp_f2 ->
+   f1 x <> 0 ->
+   Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) <
+   eps / 4.
+intros.
+assert (H8 := H2 h H4 H5).
+assert (H9 := H3 h H6).
+apply Rle_lt_trans with
+ (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
+rewrite Rabs_mult.
+apply Rmult_le_compat_l.
+apply Rabs_pos.
+left; apply H8.
+apply Rlt_le_trans with
+ (Rabs (2 * (f1 x / (f2 x * f2 x))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
+apply Rmult_lt_compat_r.
+apply Rabs_pos_lt.
+unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
+ try assumption.
+red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
+apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption.
+unfold Rdiv in |- *.
+repeat rewrite Rinv_mult_distr; try assumption.
+repeat rewrite Rabs_mult.
+replace (Rabs 2) with 2.
+rewrite (Rmult_comm 2).
+replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
+ (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); 
+ [ idtac | ring ].
+repeat apply Rmult_lt_compat_l.
+apply Rabs_pos_lt; assumption.
+apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
+repeat rewrite Rabs_Rinv; assumption || idtac.
+rewrite <- (Rmult_comm 2).
+unfold Rdiv in H9; exact H9.
+symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+right.
+unfold Rsqr, Rdiv in |- *.
+rewrite Rinv_mult_distr; try assumption || discrR.
+rewrite Rinv_mult_distr; try assumption || discrR.
+repeat rewrite Rabs_mult.
+repeat rewrite Rabs_Rinv; try assumption || discrR.
+replace (Rabs eps) with eps.
+replace (Rabs 8) with 8.
+replace (Rabs 2) with 2.
+replace 8 with (4 * 2); [ idtac | ring ].
+rewrite Rinv_mult_distr; discrR.
+replace
+ (2 * (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x))) *
+  (Rabs (f2 x) * Rabs (f2 x) * eps * (/ 4 * / 2 * / Rabs (f1 x)))) with
+ (eps * / 4 * (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
+  (Rabs (f1 x) * / Rabs (f1 x)) * (2 * / 2)); [ idtac | ring ].
+repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
+ring.
+symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+symmetry  in |- *; apply Rabs_right; left; prove_sup.
+symmetry  in |- *; apply Rabs_right; left; assumption.
+Qed.
+
+Lemma maj_term4 :
+ forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal) 
+   (f1 f2:R -> R),
+   0 < eps ->
+   f2 x <> 0 ->
+   f2 (x + h) <> 0 ->
+   (forall a:R,
+      Rabs a < alp_f2c ->
+      Rabs (f2 (x + a) - f2 x) <
+      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) ->
+   (forall a:R,
+      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
+   h <> 0 ->
+   Rabs h < alp_f2c ->
+   Rabs h < Rmin eps_f2 alp_f2 ->
+   f1 x <> 0 ->
+   l2 <> 0 ->
+   Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x)) <
+   eps / 4.
+intros.
+assert (H9 := H2 h H5).
+assert (H10 := H3 h H6).
+apply Rle_lt_trans with
+ (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) *
+  Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
+rewrite Rabs_mult.
+apply Rmult_le_compat_l.
+apply Rabs_pos.
+left; apply H9.
+apply Rlt_le_trans with
+ (Rabs (2 * l2 * (f1 x / (Rsqr (f2 x) * f2 x))) *
+  Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
+apply Rmult_lt_compat_r.
+apply Rabs_pos_lt.
+unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
+ assumption || idtac.
+red in |- *; intro H11; rewrite H11 in H; elim (Rlt_irrefl _ H).
+apply Rinv_neq_0_compat; apply prod_neq_R0.
+apply prod_neq_R0.
+discrR.
+assumption.
+assumption.
+unfold Rdiv in |- *.
+repeat rewrite Rinv_mult_distr;
+ try assumption || (unfold Rsqr in |- *; apply prod_neq_R0; assumption).
+repeat rewrite Rabs_mult.
+replace (Rabs 2) with 2.
+replace
+ (2 * Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 x)))) with
+ (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * (Rabs (/ f2 x) * 2))));
+ [ idtac | ring ].
+replace
+ (Rabs l2 * Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))) with
+ (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))));
+ [ idtac | ring ].
+repeat apply Rmult_lt_compat_l.
+apply Rabs_pos_lt; assumption.
+apply Rabs_pos_lt; assumption.
+apply Rabs_pos_lt; apply Rinv_neq_0_compat; unfold Rsqr in |- *;
+ apply prod_neq_R0; assumption.
+repeat rewrite Rabs_Rinv; [ idtac | assumption | assumption ].
+rewrite <- (Rmult_comm 2).
+unfold Rdiv in H10; exact H10.
+symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+right; unfold Rsqr, Rdiv in |- *.
+rewrite Rinv_mult_distr; try assumption || discrR.
+rewrite Rinv_mult_distr; try assumption || discrR.
+rewrite Rinv_mult_distr; try assumption || discrR.
+rewrite Rinv_mult_distr; try assumption || discrR.
+repeat rewrite Rabs_mult.
+repeat rewrite Rabs_Rinv; try assumption || discrR.
+replace (Rabs eps) with eps.
+replace (Rabs 8) with 8.
+replace (Rabs 2) with 2.
+replace 8 with (4 * 2); [ idtac | ring ].
+rewrite Rinv_mult_distr; discrR.
+replace
+ (2 * Rabs l2 *
+  (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x) * / Rabs (f2 x))) *
+  (Rabs (f2 x) * Rabs (f2 x) * Rabs (f2 x) * eps *
+   (/ 4 * / 2 * / Rabs (f1 x) * / Rabs l2))) with
+ (eps * / 4 * (Rabs l2 * / Rabs l2) * (Rabs (f1 x) * / Rabs (f1 x)) *
+  (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
+  (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
+repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
+ring.
+symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+symmetry  in |- *; apply Rabs_right; left; prove_sup.
+symmetry  in |- *; apply Rabs_right; left; assumption.
+apply prod_neq_R0; assumption || discrR.
+apply prod_neq_R0; assumption.
+Qed.
+
+Lemma D_x_no_cond : forall x a:R, a <> 0 -> D_x no_cond x (x + a).
+intros.
+unfold D_x, no_cond in |- *.
+split.
+trivial.
+apply Rminus_not_eq.
+unfold Rminus in |- *.
+rewrite Ropp_plus_distr.
+rewrite <- Rplus_assoc.
+rewrite Rplus_opp_r.
+rewrite Rplus_0_l.
+apply Ropp_neq_0_compat; assumption.
+Qed.
+
+Lemma Rabs_4 :
+ forall a b c d:R, Rabs (a + b + c + d) <= Rabs a + Rabs b + Rabs c + Rabs d.
+intros.
+apply Rle_trans with (Rabs (a + b) + Rabs (c + d)).
+replace (a + b + c + d) with (a + b + (c + d)); [ apply Rabs_triang | ring ].
+apply Rle_trans with (Rabs a + Rabs b + Rabs (c + d)).
+apply Rplus_le_compat_r.
+apply Rabs_triang.
+repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
+apply Rabs_triang.
+Qed.
+
+Lemma Rlt_4 :
+ forall a b c d e f g h:R,
+   a < b -> c < d -> e < f -> g < h -> a + c + e + g < b + d + f + h.
+intros; apply Rlt_trans with (b + c + e + g).
+repeat apply Rplus_lt_compat_r; assumption.
+repeat rewrite Rplus_assoc; apply Rplus_lt_compat_l.
+apply Rlt_trans with (d + e + g).
+rewrite Rplus_assoc; apply Rplus_lt_compat_r; assumption.
+rewrite Rplus_assoc; apply Rplus_lt_compat_l; apply Rlt_trans with (f + g).
+apply Rplus_lt_compat_r; assumption.
+apply Rplus_lt_compat_l; assumption.
+Qed.
+
+Lemma Rmin_2 : forall a b c:R, a < b -> a < c -> a < Rmin b c.
+intros; unfold Rmin in |- *; case (Rle_dec b c); intro; assumption.
+Qed.
+
+Lemma quadruple : forall x:R, 4 * x = x + x + x + x.
+intro; ring.
+Qed.
+
+Lemma quadruple_var : forall x:R, x = x / 4 + x / 4 + x / 4 + x / 4.
+intro; rewrite <- quadruple.
+unfold Rdiv in |- *; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m; discrR.
+reflexivity.
+Qed.
+
+(**********)
+Lemma continuous_neq_0 :
+ forall (f:R -> R) (x0:R),
+   continuity_pt f x0 ->
+   f x0 <> 0 ->
+    exists eps : posreal, (forall h:R, Rabs h < eps -> f (x0 + h) <> 0).
+intros; unfold continuity_pt in H; unfold continue_in in H;
+ unfold limit1_in in H; unfold limit_in in H; elim (H (Rabs (f x0 / 2))).
+intros; elim H1; intros.
+exists (mkposreal x H2).
+intros; assert (H5 := H3 (x0 + h)).
+cut
+ (dist R_met (x0 + h) x0 < x ->
+  dist R_met (f (x0 + h)) (f x0) < Rabs (f x0 / 2)).
+unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
+ replace (x0 + h - x0) with h.
+intros; assert (H7 := H6 H4).
+red in |- *; intro.
+rewrite H8 in H7; unfold Rminus in H7; rewrite Rplus_0_l in H7;
+ rewrite Rabs_Ropp in H7; unfold Rdiv in H7; rewrite Rabs_mult in H7;
+ pattern (Rabs (f x0)) at 1 in H7; rewrite <- Rmult_1_r in H7.
+cut (0 < Rabs (f x0)).
+intro; assert (H10 := Rmult_lt_reg_l _ _ _ H9 H7).
+cut (Rabs (/ 2) = / 2).
+assert (Hyp : 0 < 2).
+prove_sup0.
+intro; rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l 2 _ _ Hyp H10);
+ rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12; 
+ [ idtac | discrR ].
+cut (IZR 1 < IZR 2).
+unfold IZR in |- *; unfold INR, nat_of_P in |- *; simpl in |- *; intro;
+ elim (Rlt_irrefl 1 (Rlt_trans _ _ _ H13 H12)).
+apply IZR_lt; omega.
+unfold Rabs in |- *; case (Rcase_abs (/ 2)); intro.
+assert (Hyp : 0 < 2).
+prove_sup0.
+assert (H11 := Rmult_lt_compat_l 2 _ _ Hyp r); rewrite Rmult_0_r in H11;
+ rewrite <- Rinv_r_sym in H11; [ idtac | discrR ].
+elim (Rlt_irrefl 0 (Rlt_trans _ _ _ Rlt_0_1 H11)).
+reflexivity.
+apply (Rabs_pos_lt _ H0).
+ring.
+assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro.
+intro; rewrite <- H7; unfold dist, R_met in |- *; unfold R_dist in |- *;
+ unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ apply Rabs_pos_lt.
+unfold Rdiv in |- *; apply prod_neq_R0;
+ [ assumption | apply Rinv_neq_0_compat; discrR ].
+intro; apply H5.
+split.
+unfold D_x, no_cond in |- *.
+split; trivial || assumption.
+assumption.
+change (0 < Rabs (f x0 / 2)) in |- *.
+apply Rabs_pos_lt; unfold Rdiv in |- *; apply prod_neq_R0.
+assumption.
+apply Rinv_neq_0_compat; discrR.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v
new file mode 100644
index 00000000..9f85b00a
--- /dev/null
+++ b/theories/Reals/Ranalysis3.v
@@ -0,0 +1,793 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Ranalysis3.v,v 1.10.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Ranalysis1.
+Require Import Ranalysis2. Open Local Scope R_scope.
+
+(* Division *)
+Theorem derivable_pt_lim_div :
+ forall (f1 f2:R -> R) (x l1 l2:R),
+   derivable_pt_lim f1 x l1 ->
+   derivable_pt_lim f2 x l2 ->
+   f2 x <> 0 ->
+   derivable_pt_lim (f1 / f2) x ((l1 * f2 x - l2 * f1 x) / Rsqr (f2 x)).
+intros.
+cut (derivable_pt f2 x);
+ [ intro | unfold derivable_pt in |- *; apply existT with l2; exact H0 ].
+assert (H2 := continuous_neq_0 _ _ (derivable_continuous_pt _ _ X) H1).
+elim H2; clear H2; intros eps_f2 H2.
+unfold div_fct in |- *.
+assert (H3 := derivable_continuous_pt _ _ X).
+unfold continuity_pt in H3; unfold continue_in in H3; unfold limit1_in in H3;
+ unfold limit_in in H3; unfold dist in H3.
+simpl in H3; unfold R_dist in H3.
+elim (H3 (Rabs (f2 x) / 2));
+ [ idtac
+ | unfold Rdiv in |- *; change (0 < Rabs (f2 x) * / 2) in |- *;
+    apply Rmult_lt_0_compat;
+    [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+clear H3; intros alp_f2 H3.
+cut
+ (forall x0:R,
+    Rabs (x0 - x) < alp_f2 -> Rabs (f2 x0 - f2 x) < Rabs (f2 x) / 2).
+intro H4.
+cut (forall a:R, Rabs (a - x) < alp_f2 -> Rabs (f2 x) / 2 < Rabs (f2 a)).
+intro H5.
+cut
+ (forall a:R,
+    Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)).
+intro Maj.
+unfold derivable_pt_lim in |- *; intros.
+elim (H (Rabs (eps * f2 x / 8)));
+ [ idtac
+ | unfold Rdiv in |- *; change (0 < Rabs (eps * f2 x * / 8)) in |- *;
+    apply Rabs_pos_lt; repeat apply prod_neq_R0;
+    [ red in |- *; intro H7; rewrite H7 in H6; elim (Rlt_irrefl _ H6)
+    | assumption
+    | apply Rinv_neq_0_compat; discrR ] ].
+intros alp_f1d H7.
+case (Req_dec (f1 x) 0); intro.
+case (Req_dec l1 0); intro.
+(***********************************)
+(*              Cas n° 1           *)
+(*           (f1 x)=0  l1 =0       *)
+(***********************************)
+cut (0 < Rmin eps_f2 (Rmin alp_f2 alp_f1d));
+ [ intro
+ | repeat apply Rmin_pos;
+    [ apply (cond_pos eps_f2)
+    | elim H3; intros; assumption
+    | apply (cond_pos alp_f1d) ] ].
+exists (mkposreal (Rmin eps_f2 (Rmin alp_f2 alp_f1d)) H10).
+simpl in |- *; intros.
+assert (H13 := Rlt_le_trans _ _ _ H12 (Rmin_r _ _)).
+assert (H14 := Rlt_le_trans _ _ _ H12 (Rmin_l _ _)).
+assert (H15 := Rlt_le_trans _ _ _ H13 (Rmin_r _ _)).
+assert (H16 := Rlt_le_trans _ _ _ H13 (Rmin_l _ _)).
+assert (H17 := H7 _ H11 H15).
+rewrite formule; [ idtac | assumption | assumption | apply H2; apply H14 ].
+apply Rle_lt_trans with
+ (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+unfold Rminus in |- *.
+rewrite <-
+ (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+ .
+apply Rabs_4.
+repeat rewrite Rabs_mult.
+apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+cut
+ (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+  eps / 4).
+cut
+ (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+  eps / 4).
+intros.
+apply Rlt_4; assumption.
+rewrite H8.
+unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+rewrite Rabs_R0; rewrite Rmult_0_l.
+apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+rewrite H8.
+unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+rewrite Rabs_R0; rewrite Rmult_0_l.
+apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+rewrite H9.
+unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+rewrite Rabs_R0; rewrite Rmult_0_l.
+apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+rewrite <- Rabs_mult.
+apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2);
+ try assumption || apply H2.
+apply H14.
+apply Rmin_2; assumption.
+right; symmetry  in |- *; apply quadruple_var.
+(***********************************)
+(*              Cas n° 2           *)
+(*           (f1 x)=0  l1<>0       *)
+(***********************************)
+assert (H10 := derivable_continuous_pt _ _ X).
+unfold continuity_pt in H10.
+unfold continue_in in H10.
+unfold limit1_in in H10.
+unfold limit_in in H10.
+unfold dist in H10.
+simpl in H10.
+unfold R_dist in H10.
+elim (H10 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
+clear H10; intros alp_f2t2 H10.
+cut
+ (forall a:R,
+    Rabs a < alp_f2t2 ->
+    Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
+intro H11.
+cut (0 < Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)).
+intro.
+exists (mkposreal (Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)) H12).
+simpl in |- *.
+intros.
+assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
+assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
+assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
+assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
+assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
+assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
+clear H14 H15 H16.
+rewrite formule; try assumption.
+apply Rle_lt_trans with
+ (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+unfold Rminus in |- *.
+rewrite <-
+ (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+ .
+apply Rabs_4.
+repeat rewrite Rabs_mult.
+apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+cut
+ (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+  eps / 4).
+cut
+ (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+  eps / 4).
+intros.
+apply Rlt_4; assumption.
+rewrite H8.
+unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+rewrite Rabs_R0; rewrite Rmult_0_l.
+apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+rewrite H8.
+unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+rewrite Rabs_R0; rewrite Rmult_0_l.
+apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+rewrite <- Rabs_mult.
+apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+rewrite <- Rabs_mult.
+apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+right; symmetry  in |- *; apply quadruple_var.
+apply H2; assumption.
+repeat apply Rmin_pos.
+apply (cond_pos eps_f2).
+apply (cond_pos alp_f1d).
+elim H3; intros; assumption.
+elim H10; intros; assumption.
+intros.
+elim H10; intros.
+case (Req_dec a 0); intro.
+rewrite H14; rewrite Rplus_0_r.
+unfold Rminus in |- *; rewrite Rplus_opp_r.
+rewrite Rabs_R0.
+apply Rabs_pos_lt.
+unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc.
+repeat apply prod_neq_R0; try assumption.
+red in |- *; intro; rewrite H15 in H6; elim (Rlt_irrefl _ H6).
+apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption.
+apply H13.
+split.
+apply D_x_no_cond; assumption.
+replace (x + a - x) with a; [ assumption | ring ].
+change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *.
+apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc;
+ repeat apply prod_neq_R0.
+red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
+assumption. 
+assumption.
+apply Rinv_neq_0_compat; repeat apply prod_neq_R0;
+ [ discrR | discrR | discrR | assumption ].
+(***********************************)
+(*              Cas n° 3           *)
+(*     (f1 x)<>0  l1=0  l2=0       *)
+(***********************************)
+case (Req_dec l1 0); intro.
+case (Req_dec l2 0); intro.
+elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
+ [ idtac
+ | apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc;
+    repeat apply prod_neq_R0;
+    [ assumption
+    | assumption
+    | red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6)
+    | apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption ] ].
+intros alp_f2d H12.
+cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)).
+intro.
+exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) H11).
+simpl in |- *.
+intros.
+assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
+assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
+assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
+assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
+assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
+assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
+clear H15 H16.
+rewrite formule; try assumption.
+apply Rle_lt_trans with
+ (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+unfold Rminus in |- *.
+rewrite <-
+ (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+ .
+apply Rabs_4.
+repeat rewrite Rabs_mult.
+apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+cut
+ (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+  eps / 4).
+cut
+ (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+  eps / 4).
+intros.
+apply Rlt_4; assumption.
+rewrite H10.
+unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+rewrite Rabs_R0; rewrite Rmult_0_l.
+apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+rewrite <- Rabs_mult.
+apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+rewrite H9.
+unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+rewrite Rabs_R0; rewrite Rmult_0_l.
+apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+rewrite <- Rabs_mult.
+apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); assumption || idtac.
+apply H2; assumption.
+apply Rmin_2; assumption.
+right; symmetry  in |- *; apply quadruple_var.
+apply H2; assumption.
+repeat apply Rmin_pos.
+apply (cond_pos eps_f2).
+elim H3; intros; assumption.
+apply (cond_pos alp_f1d).
+apply (cond_pos alp_f2d).
+(***********************************)
+(*              Cas n° 4           *)
+(*    (f1 x)<>0  l1=0  l2<>0       *)
+(***********************************)
+elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
+ [ idtac
+ | apply Rabs_pos_lt; unfold Rsqr, Rdiv in |- *;
+    repeat rewrite Rinv_mult_distr; repeat apply prod_neq_R0;
+    try assumption || discrR ].
+intros alp_f2d H11.
+assert (H12 := derivable_continuous_pt _ _ X).
+unfold continuity_pt in H12.
+unfold continue_in in H12.
+unfold limit1_in in H12.
+unfold limit_in in H12.
+unfold dist in H12.
+simpl in H12.
+unfold R_dist in H12.
+elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))).
+intros alp_f2c H13.
+cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))).
+intro.
+exists
+ (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c)))
+    H14).
+simpl in |- *; intros.
+assert (H17 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
+assert (H18 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
+assert (H19 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
+assert (H20 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)).
+assert (H21 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)).
+assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
+assert (H23 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
+assert (H24 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
+clear H16 H17 H18 H19.
+cut
+ (forall a:R,
+    Rabs a < alp_f2c ->
+    Rabs (f2 (x + a) - f2 x) <
+    Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
+intro.
+rewrite formule; try assumption.
+apply Rle_lt_trans with
+ (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+unfold Rminus in |- *.
+rewrite <-
+ (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+ .
+apply Rabs_4.
+repeat rewrite Rabs_mult.
+apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+cut
+ (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+  eps / 4).
+cut
+ (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+  eps / 4).
+intros.
+apply Rlt_4; assumption.
+rewrite <- Rabs_mult.
+apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+rewrite <- Rabs_mult.
+apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+rewrite H9.
+unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+rewrite Rabs_R0; rewrite Rmult_0_l.
+apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+rewrite <- Rabs_mult.
+apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+right; symmetry  in |- *; apply quadruple_var.
+apply H2; assumption.
+intros.
+case (Req_dec a 0); intro.
+rewrite H17; rewrite Rplus_0_r.
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0.
+apply Rabs_pos_lt.
+unfold Rdiv, Rsqr in |- *.
+repeat rewrite Rinv_mult_distr; try assumption.
+repeat apply prod_neq_R0; try assumption.
+red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). 
+apply Rinv_neq_0_compat; discrR.
+apply Rinv_neq_0_compat; discrR.
+apply Rinv_neq_0_compat; discrR.
+apply Rinv_neq_0_compat; assumption.
+apply Rinv_neq_0_compat; assumption.
+discrR.
+discrR.
+discrR.
+discrR.
+discrR.
+apply prod_neq_R0; [ discrR | assumption ].
+elim H13; intros.
+apply H19.
+split.
+apply D_x_no_cond; assumption.
+replace (x + a - x) with a; [ assumption | ring ].
+repeat apply Rmin_pos.
+apply (cond_pos eps_f2).
+elim H3; intros; assumption.
+apply (cond_pos alp_f1d).
+apply (cond_pos alp_f2d).
+elim H13; intros; assumption.
+change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) in |- *.
+apply Rabs_pos_lt.
+unfold Rsqr, Rdiv in |- *.
+repeat rewrite Rinv_mult_distr; try assumption || discrR.
+repeat apply prod_neq_R0; try assumption.
+red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6). 
+apply Rinv_neq_0_compat; discrR.
+apply Rinv_neq_0_compat; discrR.
+apply Rinv_neq_0_compat; discrR.
+apply Rinv_neq_0_compat; assumption.
+apply Rinv_neq_0_compat; assumption.
+apply prod_neq_R0; [ discrR | assumption ].
+red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6). 
+apply Rinv_neq_0_compat; discrR.
+apply Rinv_neq_0_compat; discrR.
+apply Rinv_neq_0_compat; discrR.
+apply Rinv_neq_0_compat; assumption.
+(***********************************)
+(*              Cas n° 5           *)
+(*    (f1 x)<>0  l1<>0  l2=0       *)
+(***********************************)
+case (Req_dec l2 0); intro.
+assert (H11 := derivable_continuous_pt _ _ X).
+unfold continuity_pt in H11.
+unfold continue_in in H11.
+unfold limit1_in in H11.
+unfold limit_in in H11.
+unfold dist in H11.
+simpl in H11.
+unfold R_dist in H11.
+elim (H11 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
+clear H11; intros alp_f2t2 H11.
+elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))).
+intros alp_f2d H12.
+cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))).
+intro.
+exists
+ (mkposreal
+    (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))) H13).
+simpl in |- *.
+intros.
+cut
+ (forall a:R,
+    Rabs a < alp_f2t2 ->
+    Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
+intro.
+assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
+assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
+assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
+assert (H20 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
+assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
+assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
+assert (H23 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)).
+assert (H24 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)).
+clear H15 H17 H18 H21.
+rewrite formule; try assumption.
+apply Rle_lt_trans with
+ (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+unfold Rminus in |- *.
+rewrite <-
+ (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+ .
+apply Rabs_4.
+repeat rewrite Rabs_mult.
+apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+cut
+ (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+  eps / 4).
+cut
+ (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+  eps / 4).
+intros.
+apply Rlt_4; assumption.
+rewrite H10.
+unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+rewrite Rabs_R0; rewrite Rmult_0_l.
+apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+rewrite <- Rabs_mult.
+apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+rewrite <- Rabs_mult.
+apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+rewrite <- Rabs_mult.
+apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+right; symmetry  in |- *; apply quadruple_var.
+apply H2; assumption.
+intros.
+case (Req_dec a 0); intro.
+rewrite H17; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rabs_R0.
+apply Rabs_pos_lt.
+unfold Rdiv in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
+unfold Rsqr in |- *.
+repeat apply prod_neq_R0;
+ assumption ||
+   (apply Rinv_neq_0_compat; assumption) ||
+     (apply Rinv_neq_0_compat; discrR) ||
+       (red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6)).
+elim H11; intros.
+apply H19.
+split.
+apply D_x_no_cond; assumption.
+replace (x + a - x) with a; [ assumption | ring ].
+repeat apply Rmin_pos.
+apply (cond_pos eps_f2).
+elim H3; intros; assumption.
+apply (cond_pos alp_f1d). 
+apply (cond_pos alp_f2d).
+elim H11; intros; assumption.
+apply Rabs_pos_lt.
+unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
+repeat apply prod_neq_R0;
+ assumption ||
+   (apply Rinv_neq_0_compat; assumption) ||
+     (apply Rinv_neq_0_compat; discrR) ||
+       (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
+change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *.
+apply Rabs_pos_lt.
+unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
+repeat apply prod_neq_R0;
+ assumption ||
+   (apply Rinv_neq_0_compat; assumption) ||
+     (apply Rinv_neq_0_compat; discrR) ||
+       (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
+(***********************************)
+(*              Cas n° 6           *)
+(*    (f1 x)<>0  l1<>0  l2<>0      *)
+(***********************************)
+elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))).
+intros alp_f2d H11.
+assert (H12 := derivable_continuous_pt _ _ X).
+unfold continuity_pt in H12.
+unfold continue_in in H12.
+unfold limit1_in in H12.
+unfold limit_in in H12.
+unfold dist in H12.
+simpl in H12.
+unfold R_dist in H12.
+elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))).
+intros alp_f2c H13.
+elim (H12 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
+intros alp_f2t2 H14.
+cut
+ (0 <
+  Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))
+    (Rmin alp_f2c alp_f2t2)).
+intro.
+exists
+ (mkposreal
+    (Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))
+       (Rmin alp_f2c alp_f2t2)) H15).
+simpl in |- *.
+intros.
+assert (H18 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
+assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
+assert (H20 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
+assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
+assert (H22 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)).
+assert (H23 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)).
+assert (H24 := Rlt_le_trans _ _ _ H20 (Rmin_l _ _)).
+assert (H25 := Rlt_le_trans _ _ _ H20 (Rmin_r _ _)).
+assert (H26 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)).
+assert (H27 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)).
+clear H17 H18 H19 H20 H21.
+cut
+ (forall a:R,
+    Rabs a < alp_f2t2 ->
+    Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
+cut
+ (forall a:R,
+    Rabs a < alp_f2c ->
+    Rabs (f2 (x + a) - f2 x) <
+    Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
+intros.
+rewrite formule; try assumption.
+apply Rle_lt_trans with
+ (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+unfold Rminus in |- *.
+rewrite <-
+ (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+ .
+apply Rabs_4.
+repeat rewrite Rabs_mult.
+apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+cut
+ (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+  eps / 4).
+cut
+ (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+  eps / 4).
+intros.
+apply Rlt_4; assumption.
+rewrite <- Rabs_mult.
+apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+rewrite <- Rabs_mult.
+apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+rewrite <- Rabs_mult.
+apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+rewrite <- Rabs_mult.
+apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
+apply H2; assumption.
+apply Rmin_2; assumption.
+right; symmetry  in |- *; apply quadruple_var.
+apply H2; assumption.
+intros.
+case (Req_dec a 0); intro.
+rewrite H18; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rabs_R0; apply Rabs_pos_lt.
+unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+repeat apply prod_neq_R0;
+ assumption ||
+   (apply Rinv_neq_0_compat; assumption) ||
+     (apply Rinv_neq_0_compat; discrR) ||
+       (red in |- *; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
+apply prod_neq_R0; [ discrR | assumption ].
+apply prod_neq_R0; [ discrR | assumption ].
+assumption.
+elim H13; intros.
+apply H20.
+split.
+apply D_x_no_cond; assumption.
+replace (x + a - x) with a; [ assumption | ring ].
+intros.
+case (Req_dec a 0); intro.
+rewrite H18; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rabs_R0; apply Rabs_pos_lt.
+unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+repeat apply prod_neq_R0;
+ assumption ||
+   (apply Rinv_neq_0_compat; assumption) ||
+     (apply Rinv_neq_0_compat; discrR) ||
+       (red in |- *; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
+discrR.
+assumption.
+elim H14; intros.
+apply H20.
+split.
+unfold D_x, no_cond in |- *; split.
+trivial.
+apply Rminus_not_eq_right.
+replace (x + a - x) with a; [ assumption | ring ].
+replace (x + a - x) with a; [ assumption | ring ].
+repeat apply Rmin_pos.
+apply (cond_pos eps_f2).
+elim H3; intros; assumption.
+apply (cond_pos alp_f1d).
+apply (cond_pos alp_f2d).
+elim H13; intros; assumption.
+elim H14; intros; assumption.
+change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *; apply Rabs_pos_lt.
+unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
+repeat apply prod_neq_R0;
+ assumption ||
+   (apply Rinv_neq_0_compat; assumption) ||
+     (apply Rinv_neq_0_compat; discrR) ||
+       (red in |- *; intro H14; rewrite H14 in H6; elim (Rlt_irrefl _ H6)).
+change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) in |- *;
+ apply Rabs_pos_lt.
+unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+repeat apply prod_neq_R0;
+ assumption ||
+   (apply Rinv_neq_0_compat; assumption) ||
+     (apply Rinv_neq_0_compat; discrR) ||
+       (red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6)).
+apply prod_neq_R0; [ discrR | assumption ].
+apply prod_neq_R0; [ discrR | assumption ].
+assumption.
+apply Rabs_pos_lt.
+unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr;
+ [ idtac | discrR | assumption ].
+repeat apply prod_neq_R0;
+ assumption ||
+   (apply Rinv_neq_0_compat; assumption) ||
+     (apply Rinv_neq_0_compat; discrR) ||
+       (red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6)).
+intros.
+unfold Rdiv in |- *.
+apply Rmult_lt_reg_l with (Rabs (f2 (x + a))).
+apply Rabs_pos_lt; apply H2.
+apply Rlt_le_trans with (Rmin eps_f2 alp_f2).
+assumption.
+apply Rmin_l.
+rewrite <- Rinv_r_sym.
+apply Rmult_lt_reg_l with (Rabs (f2 x)).
+apply Rabs_pos_lt; assumption.
+rewrite Rmult_1_r.
+rewrite (Rmult_comm (Rabs (f2 x))).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+apply Rmult_lt_reg_l with (/ 2).
+apply Rinv_0_lt_compat; prove_sup0.
+repeat rewrite (Rmult_comm (/ 2)).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r.
+unfold Rdiv in H5; apply H5.
+replace (x + a - x) with a.
+assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_r _ _)); assumption.
+ring.
+discrR.
+apply Rabs_no_R0; assumption.
+apply Rabs_no_R0; apply H2.
+assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_l _ _)); assumption.
+intros.
+assert (H6 := H4 a H5).
+rewrite <- (Rabs_Ropp (f2 a - f2 x)) in H6.
+rewrite Ropp_minus_distr in H6.
+assert (H7 := Rle_lt_trans _ _ _ (Rabs_triang_inv _ _) H6).
+apply Rplus_lt_reg_r with (- Rabs (f2 a) + Rabs (f2 x) / 2).
+rewrite Rplus_assoc.
+rewrite <- double_var.
+do 2 rewrite (Rplus_comm (- Rabs (f2 a))).
+rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
+unfold Rminus in H7; assumption.
+intros.
+case (Req_dec x x0); intro.
+rewrite <- H5; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim H3; intros.
+apply H7.
+split.
+unfold D_x, no_cond in |- *; split.
+trivial.
+assumption.
+assumption.
+Qed.
+
+Lemma derivable_pt_div :
+ forall (f1 f2:R -> R) (x:R),
+   derivable_pt f1 x ->
+   derivable_pt f2 x -> f2 x <> 0 -> derivable_pt (f1 / f2) x.
+unfold derivable_pt in |- *.
+intros.
+elim X; intros.
+elim X0; intros.
+apply existT with ((x0 * f2 x - x1 * f1 x) / Rsqr (f2 x)).
+apply derivable_pt_lim_div; assumption.
+Qed.
+
+Lemma derivable_div :
+ forall f1 f2:R -> R,
+   derivable f1 ->
+   derivable f2 -> (forall x:R, f2 x <> 0) -> derivable (f1 / f2).
+unfold derivable in |- *; intros.
+apply (derivable_pt_div _ _ _ (X x) (X0 x) (H x)).
+Qed.
+
+Lemma derive_pt_div :
+ forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x) 
+   (pr2:derivable_pt f2 x) (na:f2 x <> 0),
+   derive_pt (f1 / f2) x (derivable_pt_div _ _ _ pr1 pr2 na) =
+   (derive_pt f1 x pr1 * f2 x - derive_pt f2 x pr2 * f1 x) / Rsqr (f2 x).
+intros.
+assert (H := derivable_derive f1 x pr1).
+assert (H0 := derivable_derive f2 x pr2).
+assert
+ (H1 := derivable_derive (f1 / f2)%F x (derivable_pt_div _ _ _ pr1 pr2 na)).
+elim H; clear H; intros l1 H.
+elim H0; clear H0; intros l2 H0.
+elim H1; clear H1; intros l H1.
+rewrite H; rewrite H0; apply derive_pt_eq_0.
+assert (H3 := projT2 pr1).
+unfold derive_pt in H; rewrite H in H3.
+assert (H4 := projT2 pr2).
+unfold derive_pt in H0; rewrite H0 in H4.
+apply derivable_pt_lim_div; assumption.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v
new file mode 100644
index 00000000..86f49cd4
--- /dev/null
+++ b/theories/Reals/Ranalysis4.v
@@ -0,0 +1,384 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Ranalysis4.v,v 1.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import Ranalysis1.
+Require Import Ranalysis3.
+Require Import Exp_prop. Open Local Scope R_scope.
+
+(**********)
+Lemma derivable_pt_inv :
+ forall (f:R -> R) (x:R),
+   f x <> 0 -> derivable_pt f x -> derivable_pt (/ f) x.
+intros; cut (derivable_pt (fct_cte 1 / f) x -> derivable_pt (/ f) x).
+intro; apply X0.
+apply derivable_pt_div.
+apply derivable_pt_const.
+assumption.
+assumption.
+unfold div_fct, inv_fct, fct_cte in |- *; intro; elim X0; intros;
+ unfold derivable_pt in |- *; apply existT with x0;
+ unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *;
+ unfold derivable_pt_abs in p; unfold derivable_pt_lim in p; 
+ intros; elim (p eps H0); intros; exists x1; intros; 
+ unfold Rdiv in H1; unfold Rdiv in |- *; rewrite <- (Rmult_1_l (/ f x));
+ rewrite <- (Rmult_1_l (/ f (x + h))).
+apply H1; assumption.
+Qed.
+
+(**********)
+Lemma pr_nu_var :
+ forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x),
+   f = g -> derive_pt f x pr1 = derive_pt g x pr2.
+unfold derivable_pt, derive_pt in |- *; intros.
+elim pr1; intros.
+elim pr2; intros.
+simpl in |- *.
+rewrite H in p.
+apply uniqueness_limite with g x; assumption.
+Qed.
+
+(**********)
+Lemma pr_nu_var2 :
+ forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x),
+   (forall h:R, f h = g h) -> derive_pt f x pr1 = derive_pt g x pr2.
+unfold derivable_pt, derive_pt in |- *; intros.
+elim pr1; intros.
+elim pr2; intros.
+simpl in |- *.
+assert (H0 := uniqueness_step2 _ _ _ p). 
+assert (H1 := uniqueness_step2 _ _ _ p0). 
+cut (limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) x1 0).
+intro; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2). 
+assumption.
+unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
+ simpl in |- *; unfold R_dist in |- *; unfold limit1_in in H1;
+ unfold limit_in in H1; unfold dist in H1; simpl in H1; 
+ unfold R_dist in H1.
+intros; elim (H1 eps H2); intros.
+elim H3; intros.
+exists x2.
+split.
+assumption.
+intros; do 2 rewrite H; apply H5; assumption.
+Qed.
+
+(**********)
+Lemma derivable_inv :
+ forall f:R -> R, (forall x:R, f x <> 0) -> derivable f -> derivable (/ f).
+intros.
+unfold derivable in |- *; intro.
+apply derivable_pt_inv.
+apply (H x).
+apply (X x).
+Qed.
+
+Lemma derive_pt_inv :
+ forall (f:R -> R) (x:R) (pr:derivable_pt f x) (na:f x <> 0),
+   derive_pt (/ f) x (derivable_pt_inv f x na pr) =
+   - derive_pt f x pr / Rsqr (f x).
+intros;
+ replace (derive_pt (/ f) x (derivable_pt_inv f x na pr)) with
+  (derive_pt (fct_cte 1 / f) x
+     (derivable_pt_div (fct_cte 1) f x (derivable_pt_const 1 x) pr na)).
+rewrite derive_pt_div; rewrite derive_pt_const; unfold fct_cte in |- *;
+ rewrite Rmult_0_l; rewrite Rmult_1_r; unfold Rminus in |- *;
+ rewrite Rplus_0_l; reflexivity.
+apply pr_nu_var2.
+intro; unfold div_fct, fct_cte, inv_fct in |- *.
+unfold Rdiv in |- *; ring.
+Qed.
+
+(* Rabsolu *)
+Lemma Rabs_derive_1 : forall x:R, 0 < x -> derivable_pt_lim Rabs x 1.
+intros.
+unfold derivable_pt_lim in |- *; intros.
+exists (mkposreal x H); intros.
+rewrite (Rabs_right x).
+rewrite (Rabs_right (x + h)).
+rewrite Rplus_comm.
+unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_r.
+rewrite Rplus_0_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym.
+rewrite Rplus_opp_r; rewrite Rabs_R0; apply H0.
+apply H1.
+apply Rle_ge.
+case (Rcase_abs h); intro.
+rewrite (Rabs_left h r) in H2.
+left; rewrite Rplus_comm; apply Rplus_lt_reg_r with (- h); rewrite Rplus_0_r;
+ rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; 
+ apply H2.
+apply Rplus_le_le_0_compat.
+left; apply H.
+apply Rge_le; apply r.
+left; apply H.
+Qed.
+
+Lemma Rabs_derive_2 : forall x:R, x < 0 -> derivable_pt_lim Rabs x (-1).
+intros.
+unfold derivable_pt_lim in |- *; intros.
+cut (0 < - x).
+intro; exists (mkposreal (- x) H1); intros.
+rewrite (Rabs_left x).
+rewrite (Rabs_left (x + h)).
+rewrite Rplus_comm.
+rewrite Ropp_plus_distr.
+unfold Rminus in |- *; rewrite Ropp_involutive; rewrite Rplus_assoc;
+ rewrite Rplus_opp_l.
+rewrite Rplus_0_r; unfold Rdiv in |- *.
+rewrite Ropp_mult_distr_l_reverse.
+rewrite <- Rinv_r_sym.
+rewrite Ropp_involutive; rewrite Rplus_opp_l; rewrite Rabs_R0; apply H0.
+apply H2.
+case (Rcase_abs h); intro.
+apply Ropp_lt_cancel.
+rewrite Ropp_0; rewrite Ropp_plus_distr; apply Rplus_lt_0_compat.
+apply H1.
+apply Ropp_0_gt_lt_contravar; apply r.
+rewrite (Rabs_right h r) in H3.
+apply Rplus_lt_reg_r with (- x); rewrite Rplus_0_r; rewrite <- Rplus_assoc;
+ rewrite Rplus_opp_l; rewrite Rplus_0_l; apply H3.
+apply H.
+apply Ropp_0_gt_lt_contravar; apply H.
+Qed.
+
+(* Rabsolu is derivable for all x <> 0 *)
+Lemma Rderivable_pt_abs : forall x:R, x <> 0 -> derivable_pt Rabs x.
+intros.
+case (total_order_T x 0); intro.
+elim s; intro.
+unfold derivable_pt in |- *; apply existT with (-1).
+apply (Rabs_derive_2 x a).
+elim H; exact b.
+unfold derivable_pt in |- *; apply existT with 1.
+apply (Rabs_derive_1 x r).
+Qed.
+
+(* Rabsolu is continuous for all x *)
+Lemma Rcontinuity_abs : continuity Rabs.
+unfold continuity in |- *; intro.
+case (Req_dec x 0); intro.
+unfold continuity_pt in |- *; unfold continue_in in |- *;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ simpl in |- *; unfold R_dist in |- *; intros; exists eps; 
+ split.
+apply H0.
+intros; rewrite H; rewrite Rabs_R0; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; rewrite Rabs_Rabsolu; elim H1; 
+ intros; rewrite H in H3; unfold Rminus in H3; rewrite Ropp_0 in H3;
+ rewrite Rplus_0_r in H3; apply H3.
+apply derivable_continuous_pt; apply (Rderivable_pt_abs x H).
+Qed.
+
+(* Finite sums : Sum a_k x^k *)
+Lemma continuity_finite_sum :
+ forall (An:nat -> R) (N:nat),
+   continuity (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N).
+intros; unfold continuity in |- *; intro.
+induction  N as [| N HrecN].
+simpl in |- *.
+apply continuity_pt_const.
+unfold constant in |- *; intros; reflexivity.
+replace (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) (S N)) with
+ ((fun y:R => sum_f_R0 (fun k:nat => (An k * y ^ k)%R) N) +
+  (fun y:R => (An (S N) * y ^ S N)%R))%F.
+apply continuity_pt_plus.
+apply HrecN.
+replace (fun y:R => An (S N) * y ^ S N) with
+ (mult_real_fct (An (S N)) (fun y:R => y ^ S N)).
+apply continuity_pt_scal.
+apply derivable_continuous_pt.
+apply derivable_pt_pow.
+reflexivity.
+reflexivity.
+Qed.
+
+Lemma derivable_pt_lim_fs :
+ forall (An:nat -> R) (x:R) (N:nat),
+   (0 < N)%nat ->
+   derivable_pt_lim (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x
+     (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N)).
+intros; induction  N as [| N HrecN].
+elim (lt_irrefl _ H).
+cut (N = 0%nat \/ (0 < N)%nat).
+intro; elim H0; intro.
+rewrite H1.
+simpl in |- *.
+replace (fun y:R => An 0%nat * 1 + An 1%nat * (y * 1)) with
+ (fct_cte (An 0%nat * 1) + mult_real_fct (An 1%nat) (id * fct_cte 1))%F.
+replace (1 * An 1%nat * 1) with (0 + An 1%nat * (1 * fct_cte 1 x + id x * 0)).
+apply derivable_pt_lim_plus.
+apply derivable_pt_lim_const.
+apply derivable_pt_lim_scal.
+apply derivable_pt_lim_mult.
+apply derivable_pt_lim_id.
+apply derivable_pt_lim_const.
+unfold fct_cte, id in |- *; ring.
+reflexivity.
+replace (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) (S N)) with
+ ((fun y:R => sum_f_R0 (fun k:nat => (An k * y ^ k)%R) N) +
+  (fun y:R => (An (S N) * y ^ S N)%R))%F.
+replace (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N)))
+ with
+ (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N) +
+  An (S N) * (INR (S (pred (S N))) * x ^ pred (S N))).
+apply derivable_pt_lim_plus.
+apply HrecN.
+assumption.
+replace (fun y:R => An (S N) * y ^ S N) with
+ (mult_real_fct (An (S N)) (fun y:R => y ^ S N)).
+apply derivable_pt_lim_scal.
+replace (pred (S N)) with N; [ idtac | reflexivity ].
+pattern N at 3 in |- *; replace N with (pred (S N)).
+apply derivable_pt_lim_pow.
+reflexivity.
+reflexivity.
+cut (pred (S N) = S (pred N)).
+intro; rewrite H2.
+rewrite tech5.
+apply Rplus_eq_compat_l.
+rewrite <- H2.
+replace (pred (S N)) with N; [ idtac | reflexivity ].
+ring.
+simpl in |- *.
+apply S_pred with 0%nat; assumption.
+unfold plus_fct in |- *.
+simpl in |- *; reflexivity.
+inversion H.
+left; reflexivity.
+right; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
+Qed.
+
+Lemma derivable_pt_lim_finite_sum :
+ forall (An:nat -> R) (x:R) (N:nat),
+   derivable_pt_lim (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x
+     match N with
+     | O => 0
+     | _ => sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N)
+     end.
+intros.
+induction  N as [| N HrecN].
+simpl in |- *.
+rewrite Rmult_1_r.
+replace (fun _:R => An 0%nat) with (fct_cte (An 0%nat));
+ [ apply derivable_pt_lim_const | reflexivity ].
+apply derivable_pt_lim_fs; apply lt_O_Sn.
+Qed.
+
+Lemma derivable_pt_finite_sum :
+ forall (An:nat -> R) (N:nat) (x:R),
+   derivable_pt (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x.
+intros.
+unfold derivable_pt in |- *.
+assert (H := derivable_pt_lim_finite_sum An x N).
+induction  N as [| N HrecN].
+apply existT with 0; apply H.
+apply existT with
+ (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N))); 
+ apply H.
+Qed.
+
+Lemma derivable_finite_sum :
+ forall (An:nat -> R) (N:nat),
+   derivable (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N).
+intros; unfold derivable in |- *; intro; apply derivable_pt_finite_sum.
+Qed.
+
+(* Regularity of hyperbolic functions *)
+Lemma derivable_pt_lim_cosh : forall x:R, derivable_pt_lim cosh x (sinh x).
+intro.
+unfold cosh, sinh in |- *; unfold Rdiv in |- *.
+replace (fun x0:R => (exp x0 + exp (- x0)) * / 2) with
+ ((exp + comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ].
+replace ((exp x - exp (- x)) * / 2) with
+ ((exp x + exp (- x) * -1) * fct_cte (/ 2) x +
+  (exp + comp exp (- id))%F x * 0). 
+apply derivable_pt_lim_mult.
+apply derivable_pt_lim_plus.
+apply derivable_pt_lim_exp.
+apply derivable_pt_lim_comp.
+apply derivable_pt_lim_opp.
+apply derivable_pt_lim_id.
+apply derivable_pt_lim_exp.
+apply derivable_pt_lim_const.
+unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte in |- *; ring.
+Qed.
+
+Lemma derivable_pt_lim_sinh : forall x:R, derivable_pt_lim sinh x (cosh x).
+intro.
+unfold cosh, sinh in |- *; unfold Rdiv in |- *.
+replace (fun x0:R => (exp x0 - exp (- x0)) * / 2) with
+ ((exp - comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ].
+replace ((exp x + exp (- x)) * / 2) with
+ ((exp x - exp (- x) * -1) * fct_cte (/ 2) x +
+  (exp - comp exp (- id))%F x * 0). 
+apply derivable_pt_lim_mult.
+apply derivable_pt_lim_minus.
+apply derivable_pt_lim_exp.
+apply derivable_pt_lim_comp.
+apply derivable_pt_lim_opp.
+apply derivable_pt_lim_id.
+apply derivable_pt_lim_exp.
+apply derivable_pt_lim_const.
+unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte in |- *; ring.
+Qed.
+
+Lemma derivable_pt_exp : forall x:R, derivable_pt exp x.
+intro.
+unfold derivable_pt in |- *.
+apply existT with (exp x).
+apply derivable_pt_lim_exp.
+Qed.
+
+Lemma derivable_pt_cosh : forall x:R, derivable_pt cosh x.
+intro.
+unfold derivable_pt in |- *.
+apply existT with (sinh x).
+apply derivable_pt_lim_cosh.
+Qed.
+
+Lemma derivable_pt_sinh : forall x:R, derivable_pt sinh x.
+intro.
+unfold derivable_pt in |- *.
+apply existT with (cosh x).
+apply derivable_pt_lim_sinh.
+Qed.
+
+Lemma derivable_exp : derivable exp.
+unfold derivable in |- *; apply derivable_pt_exp.
+Qed.
+
+Lemma derivable_cosh : derivable cosh.
+unfold derivable in |- *; apply derivable_pt_cosh.
+Qed.
+
+Lemma derivable_sinh : derivable sinh.
+unfold derivable in |- *; apply derivable_pt_sinh.
+Qed.
+
+Lemma derive_pt_exp :
+ forall x:R, derive_pt exp x (derivable_pt_exp x) = exp x.
+intro; apply derive_pt_eq_0.
+apply derivable_pt_lim_exp.
+Qed.
+
+Lemma derive_pt_cosh :
+ forall x:R, derive_pt cosh x (derivable_pt_cosh x) = sinh x.
+intro; apply derive_pt_eq_0.
+apply derivable_pt_lim_cosh.
+Qed.
+
+Lemma derive_pt_sinh :
+ forall x:R, derive_pt sinh x (derivable_pt_sinh x) = cosh x.
+intro; apply derive_pt_eq_0.
+apply derivable_pt_lim_sinh.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v
new file mode 100644
index 00000000..bef9f89c
--- /dev/null
+++ b/theories/Reals/Raxioms.v
@@ -0,0 +1,157 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Raxioms.v,v 1.20.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(*********************************************************)
+(**    Axiomatisation of the classical reals             *)
+(*********************************************************)
+
+Require Export ZArith_base.
+Require Export Rdefinitions.
+Open Local Scope R_scope.
+
+(*********************************************************)
+(*               Field axioms                            *)
+(*********************************************************)
+
+(*********************************************************)
+(**      Addition                                        *)
+(*********************************************************)
+
+(**********)
+Axiom Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1.
+Hint Resolve Rplus_comm: real.
+
+(**********)
+Axiom Rplus_assoc : forall r1 r2 r3:R, r1 + r2 + r3 = r1 + (r2 + r3).
+Hint Resolve Rplus_assoc: real.
+
+(**********)
+Axiom Rplus_opp_r : forall r:R, r + - r = 0.
+Hint Resolve Rplus_opp_r: real v62.
+
+(**********)
+Axiom Rplus_0_l : forall r:R, 0 + r = r.
+Hint Resolve Rplus_0_l: real.
+
+(***********************************************************)       
+(**       Multiplication                                   *)
+(***********************************************************)
+
+(**********)
+Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1.
+Hint Resolve Rmult_comm: real v62. 
+
+(**********)
+Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3).
+Hint Resolve Rmult_assoc: real v62.
+
+(**********)
+Axiom Rinv_l : forall r:R, r <> 0 -> / r * r = 1.
+Hint Resolve Rinv_l: real.
+
+(**********)
+Axiom Rmult_1_l : forall r:R, 1 * r = r.
+Hint Resolve Rmult_1_l: real.
+
+(**********)
+Axiom R1_neq_R0 : 1 <> 0.
+Hint Resolve R1_neq_R0: real.
+
+(*********************************************************)
+(**      Distributivity                                  *)
+(*********************************************************)
+
+(**********)
+Axiom
+  Rmult_plus_distr_l : forall r1 r2 r3:R, r1 * (r2 + r3) = r1 * r2 + r1 * r3.
+Hint Resolve Rmult_plus_distr_l: real v62.
+
+(*********************************************************)
+(**      Order axioms                                    *)
+(*********************************************************)
+(*********************************************************)
+(**      Total Order                                     *)
+(*********************************************************)
+
+(**********)
+Axiom total_order_T : forall r1 r2:R, {r1 < r2} + {r1 = r2} + {r1 > r2}.
+
+(*********************************************************)
+(**      Lower                                           *)
+(*********************************************************)
+
+(**********)
+Axiom Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1.
+
+(**********)
+Axiom Rlt_trans : forall r1 r2 r3:R, r1 < r2 -> r2 < r3 -> r1 < r3.
+
+(**********)
+Axiom Rplus_lt_compat_l : forall r r1 r2:R, r1 < r2 -> r + r1 < r + r2.
+
+(**********)
+Axiom
+  Rmult_lt_compat_l : forall r r1 r2:R, 0 < r -> r1 < r2 -> r * r1 < r * r2.
+
+Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real.
+
+(**********************************************************) 
+(**      Injection from N to R                            *)
+(**********************************************************)
+
+(**********)
+Fixpoint INR (n:nat) : R :=
+  match n with
+  | O => 0
+  | S O => 1
+  | S n => INR n + 1
+  end.  
+Arguments Scope INR [nat_scope].
+
+
+(**********************************************************) 
+(**      Injection from [Z] to [R]                        *)
+(**********************************************************)
+
+(**********)
+Definition IZR (z:Z) : R :=
+  match z with
+  | Z0 => 0
+  | Zpos n => INR (nat_of_P n)
+  | Zneg n => - INR (nat_of_P n)
+  end.  
+Arguments Scope IZR [Z_scope].
+
+(**********************************************************)
+(**      [R] Archimedian                                  *)
+(**********************************************************)
+
+(**********)
+Axiom archimed : forall r:R, IZR (up r) > r /\ IZR (up r) - r <= 1.
+
+(**********************************************************)
+(**      [R] Complete                                     *)
+(**********************************************************)
+
+(**********)
+Definition is_upper_bound (E:R -> Prop) (m:R) := forall x:R, E x -> x <= m.
+
+(**********)
+Definition bound (E:R -> Prop) :=  exists m : R, is_upper_bound E m.
+
+(**********)
+Definition is_lub (E:R -> Prop) (m:R) :=
+  is_upper_bound E m /\ (forall b:R, is_upper_bound E b -> m <= b).
+
+(**********)
+Axiom
+  completeness :
+    forall E:R -> Prop,
+      bound E -> (exists x : R, E x) -> sigT (fun m:R => is_lub E m).
diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v
new file mode 100644
index 00000000..773819a2
--- /dev/null
+++ b/theories/Reals/Rbase.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rbase.v,v 1.39.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Export Rdefinitions.
+Require Export Raxioms.
+Require Export RIneq.
+Require Export DiscrR.
\ No newline at end of file
diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v
new file mode 100644
index 00000000..49ba48f7
--- /dev/null
+++ b/theories/Reals/Rbasic_fun.v
@@ -0,0 +1,470 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rbasic_fun.v,v 1.22.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(*********************************************************)
+(**          Complements for the real numbers            *)
+(*                                                       *)
+(*********************************************************)
+
+Require Import Rbase.
+Require Import R_Ifp.
+Require Import Fourier. Open Local Scope R_scope.
+
+Implicit Type r : R.
+
+(*******************************)
+(**          Rmin              *)
+(*******************************)
+
+(*********)
+Definition Rmin (x y:R) : R :=
+  match Rle_dec x y with
+  | left _ => x
+  | right _ => y
+  end.
+
+(*********)
+Lemma Rmin_Rgt_l : forall r1 r2 r, Rmin r1 r2 > r -> r1 > r /\ r2 > r.
+intros r1 r2 r; unfold Rmin in |- *; case (Rle_dec r1 r2); intros.
+split.
+assumption.
+unfold Rgt in |- *; unfold Rgt in H; exact (Rlt_le_trans r r1 r2 H r0).
+split.
+generalize (Rnot_le_lt r1 r2 n); intro; exact (Rgt_trans r1 r2 r H0 H).
+assumption.
+Qed.
+
+(*********)
+Lemma Rmin_Rgt_r : forall r1 r2 r, r1 > r /\ r2 > r -> Rmin r1 r2 > r.
+intros; unfold Rmin in |- *; case (Rle_dec r1 r2); elim H; clear H; intros;
+ assumption.
+Qed.
+
+(*********)
+Lemma Rmin_Rgt : forall r1 r2 r, Rmin r1 r2 > r <-> r1 > r /\ r2 > r.
+intros; split.
+exact (Rmin_Rgt_l r1 r2 r).
+exact (Rmin_Rgt_r r1 r2 r).
+Qed.
+
+(*********)
+Lemma Rmin_l : forall x y:R, Rmin x y <= x.
+intros; unfold Rmin in |- *; case (Rle_dec x y); intro H1;
+ [ right; reflexivity | auto with real ].
+Qed.
+ 
+(*********)
+Lemma Rmin_r : forall x y:R, Rmin x y <= y.
+intros; unfold Rmin in |- *; case (Rle_dec x y); intro H1;
+ [ assumption | auto with real ].
+Qed.
+
+(*********)
+Lemma Rmin_comm : forall a b:R, Rmin a b = Rmin b a.
+intros; unfold Rmin in |- *; case (Rle_dec a b); case (Rle_dec b a); intros;
+ try reflexivity || (apply Rle_antisym; assumption || auto with real).
+Qed.
+
+(*********)
+Lemma Rmin_stable_in_posreal : forall x y:posreal, 0 < Rmin x y.
+intros; apply Rmin_Rgt_r; split; [ apply (cond_pos x) | apply (cond_pos y) ].
+Qed.
+
+(*******************************)
+(**          Rmax              *)
+(*******************************)
+
+(*********)
+Definition Rmax (x y:R) : R :=
+  match Rle_dec x y with
+  | left _ => y
+  | right _ => x
+  end.
+
+(*********)
+Lemma Rmax_Rle : forall r1 r2 r, r <= Rmax r1 r2 <-> r <= r1 \/ r <= r2.
+intros; split.
+unfold Rmax in |- *; case (Rle_dec r1 r2); intros; auto.
+intro; unfold Rmax in |- *; case (Rle_dec r1 r2); elim H; clear H; intros;
+ auto.
+apply (Rle_trans r r1 r2); auto.
+generalize (Rnot_le_lt r1 r2 n); clear n; intro; unfold Rgt in H0;
+ apply (Rlt_le r r1 (Rle_lt_trans r r2 r1 H H0)).
+Qed.
+
+Lemma RmaxLess1 : forall r1 r2, r1 <= Rmax r1 r2.
+intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real.
+Qed.
+ 
+Lemma RmaxLess2 : forall r1 r2, r2 <= Rmax r1 r2.
+intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real.
+Qed.
+ 
+Lemma RmaxSym : forall p q:R, Rmax p q = Rmax q p.
+intros p q; unfold Rmax in |- *; case (Rle_dec p q); case (Rle_dec q p); auto;
+ intros H1 H2; apply Rle_antisym; auto with real.
+Qed.
+
+Lemma RmaxRmult :
+ forall (p q:R) r, 0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q.
+intros p q r H; unfold Rmax in |- *.
+case (Rle_dec p q); case (Rle_dec (r * p) (r * q)); auto; intros H1 H2; auto.
+case H; intros E1.
+case H1; auto with real.
+rewrite <- E1; repeat rewrite Rmult_0_l; auto.
+case H; intros E1.
+case H2; auto with real.
+apply Rmult_le_reg_l with (r := r); auto.
+rewrite <- E1; repeat rewrite Rmult_0_l; auto.
+Qed.
+
+Lemma Rmax_stable_in_negreal : forall x y:negreal, Rmax x y < 0.
+intros; unfold Rmax in |- *; case (Rle_dec x y); intro;
+ [ apply (cond_neg y) | apply (cond_neg x) ].
+Qed.
+
+(*******************************)
+(**          Rabsolu           *)
+(*******************************)
+
+(*********)
+Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}. 
+intro; generalize (Rle_dec 0 r); intro X; elim X; intro; clear X.
+right; apply (Rle_ge 0 r a).
+left; fold (0 > r) in |- *; apply (Rnot_le_lt 0 r b).
+Qed.
+
+(*********)
+Definition Rabs r : R :=
+  match Rcase_abs r with
+  | left _ => - r
+  | right _ => r
+  end.
+
+(*********)
+Lemma Rabs_R0 : Rabs 0 = 0.
+unfold Rabs in |- *; case (Rcase_abs 0); auto; intro.
+generalize (Rlt_irrefl 0); intro; elimtype False; auto.
+Qed.
+
+Lemma Rabs_R1 : Rabs 1 = 1.
+unfold Rabs in |- *; case (Rcase_abs 1); auto with real.
+intros H; absurd (1 < 0); auto with real.
+Qed.
+
+(*********)
+Lemma Rabs_no_R0 : forall r, r <> 0 -> Rabs r <> 0.
+intros; unfold Rabs in |- *; case (Rcase_abs r); intro; auto.
+apply Ropp_neq_0_compat; auto.
+Qed.
+
+(*********)
+Lemma Rabs_left : forall r, r < 0 -> Rabs r = - r.
+intros; unfold Rabs in |- *; case (Rcase_abs r); trivial; intro;
+ absurd (r >= 0).
+exact (Rlt_not_ge r 0 H).
+assumption.
+Qed.
+
+(*********)
+Lemma Rabs_right : forall r, r >= 0 -> Rabs r = r.
+intros; unfold Rabs in |- *; case (Rcase_abs r); intro.
+absurd (r >= 0).
+exact (Rlt_not_ge r 0 r0).
+assumption.
+trivial.
+Qed.
+
+Lemma Rabs_left1 : forall a:R, a <= 0 -> Rabs a = - a.
+intros a H; case H; intros H1.
+apply Rabs_left; auto.
+rewrite H1; simpl in |- *; rewrite Rabs_right; auto with real.
+Qed.
+
+(*********)
+Lemma Rabs_pos : forall x:R, 0 <= Rabs x.
+intros; unfold Rabs in |- *; case (Rcase_abs x); intro.
+generalize (Ropp_lt_gt_contravar x 0 r); intro; unfold Rgt in H;
+ rewrite Ropp_0 in H; unfold Rle in |- *; left; assumption.
+apply Rge_le; assumption.
+Qed.
+
+Lemma RRle_abs : forall x:R, x <= Rabs x.
+intro; unfold Rabs in |- *; case (Rcase_abs x); intros; fourier.
+Qed.
+
+(*********)
+Lemma Rabs_pos_eq : forall x:R, 0 <= x -> Rabs x = x.
+intros; unfold Rabs in |- *; case (Rcase_abs x); intro;
+ [ generalize (Rgt_not_le 0 x r); intro; elimtype False; auto | trivial ].
+Qed.
+
+(*********)
+Lemma Rabs_Rabsolu : forall x:R, Rabs (Rabs x) = Rabs x.
+intro; apply (Rabs_pos_eq (Rabs x) (Rabs_pos x)).
+Qed.
+
+(*********)
+Lemma Rabs_pos_lt : forall x:R, x <> 0 -> 0 < Rabs x.
+intros; generalize (Rabs_pos x); intro; unfold Rle in H0; elim H0; intro;
+ auto.
+elimtype False; clear H0; elim H; clear H; generalize H1; unfold Rabs in |- *;
+ case (Rcase_abs x); intros; auto.
+clear r H1; generalize (Rplus_eq_compat_l x 0 (- x) H0);
+ rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x); 
+ trivial.
+Qed.
+
+(*********)
+Lemma Rabs_minus_sym : forall x y:R, Rabs (x - y) = Rabs (y - x).
+intros; unfold Rabs in |- *; case (Rcase_abs (x - y));
+ case (Rcase_abs (y - x)); intros.
+ generalize (Rminus_lt y x r); generalize (Rminus_lt x y r0); intros;
+  generalize (Rlt_asym x y H); intro; elimtype False; 
+  auto.
+rewrite (Ropp_minus_distr x y); trivial.
+rewrite (Ropp_minus_distr y x); trivial.
+unfold Rge in r, r0; elim r; elim r0; intros; clear r r0.
+generalize (Ropp_lt_gt_0_contravar (x - y) H); rewrite (Ropp_minus_distr x y);
+ intro; unfold Rgt in H0; generalize (Rlt_asym 0 (y - x) H0); 
+ intro; elimtype False; auto.
+rewrite (Rminus_diag_uniq x y H); trivial.
+rewrite (Rminus_diag_uniq y x H0); trivial.
+rewrite (Rminus_diag_uniq y x H0); trivial.
+Qed.
+
+(*********)
+Lemma Rabs_mult : forall x y:R, Rabs (x * y) = Rabs x * Rabs y.
+intros; unfold Rabs in |- *; case (Rcase_abs (x * y)); case (Rcase_abs x);
+ case (Rcase_abs y); intros; auto.
+generalize (Rmult_lt_gt_compat_neg_l y x 0 r r0); intro;
+ rewrite (Rmult_0_r y) in H; generalize (Rlt_asym (x * y) 0 r1); 
+ intro; unfold Rgt in H; elimtype False; rewrite (Rmult_comm y x) in H; 
+ auto.
+rewrite (Ropp_mult_distr_l_reverse x y); trivial. 
+rewrite (Rmult_comm x (- y)); rewrite (Ropp_mult_distr_l_reverse y x);
+ rewrite (Rmult_comm x y); trivial.
+unfold Rge in r, r0; elim r; elim r0; clear r r0; intros; unfold Rgt in H, H0.
+generalize (Rmult_lt_compat_l x 0 y H H0); intro; rewrite (Rmult_0_r x) in H1;
+ generalize (Rlt_asym (x * y) 0 r1); intro; elimtype False; 
+ auto.
+rewrite H in r1; rewrite (Rmult_0_l y) in r1; generalize (Rlt_irrefl 0);
+ intro; elimtype False; auto.
+rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
+ intro; elimtype False; auto.
+rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
+ intro; elimtype False; auto.
+rewrite (Rmult_opp_opp x y); trivial.
+unfold Rge in r, r1; elim r; elim r1; clear r r1; intros; unfold Rgt in H0, H.
+generalize (Rmult_lt_compat_l y x 0 H0 r0); intro;
+ rewrite (Rmult_0_r y) in H1; rewrite (Rmult_comm y x) in H1;
+ generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; 
+ auto.
+generalize (Rlt_dichotomy_converse x 0 (or_introl (x > 0) r0));
+ generalize (Rlt_dichotomy_converse y 0 (or_intror (y < 0) H0)); 
+ intros; generalize (Rmult_integral x y H); intro; 
+ elim H3; intro; elimtype False; auto.  
+rewrite H0 in H; rewrite (Rmult_0_r x) in H; unfold Rgt in H;
+ generalize (Rlt_irrefl 0); intro; elimtype False; 
+ auto.
+rewrite H0; rewrite (Rmult_0_r x); rewrite (Rmult_0_r (- x)); trivial.
+unfold Rge in r0, r1; elim r0; elim r1; clear r0 r1; intros;
+ unfold Rgt in H0, H.
+generalize (Rmult_lt_compat_l x y 0 H0 r); intro; rewrite (Rmult_0_r x) in H1;
+ generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; 
+ auto.
+generalize (Rlt_dichotomy_converse y 0 (or_introl (y > 0) r));
+ generalize (Rlt_dichotomy_converse 0 x (or_introl (0 > x) H0)); 
+ intros; generalize (Rmult_integral x y H); intro; 
+ elim H3; intro; elimtype False; auto.  
+rewrite H0 in H; rewrite (Rmult_0_l y) in H; unfold Rgt in H;
+ generalize (Rlt_irrefl 0); intro; elimtype False; 
+ auto.
+rewrite H0; rewrite (Rmult_0_l y); rewrite (Rmult_0_l (- y)); trivial.
+Qed.
+
+(*********)
+Lemma Rabs_Rinv : forall r, r <> 0 -> Rabs (/ r) = / Rabs r.
+intro; unfold Rabs in |- *; case (Rcase_abs r); case (Rcase_abs (/ r)); auto;
+ intros.
+apply Ropp_inv_permute; auto.
+generalize (Rinv_lt_0_compat r r1); intro; unfold Rge in r0; elim r0; intros.
+unfold Rgt in H1; generalize (Rlt_asym 0 (/ r) H1); intro; elimtype False;
+ auto.
+generalize (Rlt_dichotomy_converse (/ r) 0 (or_introl (/ r > 0) H0)); intro;
+ elimtype False; auto.
+unfold Rge in r1; elim r1; clear r1; intro.
+unfold Rgt in H0; generalize (Rlt_asym 0 (/ r) (Rinv_0_lt_compat r H0));
+ intro; elimtype False; auto.
+elimtype False; auto.
+Qed. 
+
+Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x.
+intro; cut (- x = -1 * x).
+intros; rewrite H.
+rewrite Rabs_mult.
+cut (Rabs (-1) = 1).
+intros; rewrite H0.
+ring.
+unfold Rabs in |- *; case (Rcase_abs (-1)).
+intro; ring.
+intro H0; generalize (Rge_le (-1) 0 H0); intros.
+generalize (Ropp_le_ge_contravar 0 (-1) H1).
+rewrite Ropp_involutive; rewrite Ropp_0.
+intro; generalize (Rgt_not_le 1 0 Rlt_0_1); intro; generalize (Rge_le 0 1 H2);
+ intro; elimtype False; auto.  
+ring.
+Qed.
+
+(*********)
+Lemma Rabs_triang : forall a b:R, Rabs (a + b) <= Rabs a + Rabs b.
+intros a b; unfold Rabs in |- *; case (Rcase_abs (a + b)); case (Rcase_abs a);
+ case (Rcase_abs b); intros.
+apply (Req_le (- (a + b)) (- a + - b)); rewrite (Ropp_plus_distr a b);
+ reflexivity.
+(**)
+rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b);
+ unfold Rle in |- *; unfold Rge in r; elim r; intro.
+left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- b) 0 b H); intro;
+ elim (Rplus_ne (- b)); intros v w; rewrite v in H0; 
+ clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H).
+right; rewrite H; apply Ropp_0.
+(**)
+rewrite (Ropp_plus_distr a b); rewrite (Rplus_comm (- a) (- b));
+ rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a);
+ unfold Rle in |- *; unfold Rge in r0; elim r0; intro.
+left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- a) 0 a H); intro;
+ elim (Rplus_ne (- a)); intros v w; rewrite v in H0; 
+ clear v w; rewrite (Rplus_opp_l a) in H0; apply (Rlt_trans (- a) 0 a H0 H).
+right; rewrite H; apply Ropp_0.
+(**)
+elimtype False; generalize (Rplus_ge_compat_l a b 0 r); intro;
+ elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
+ generalize (Rge_trans (a + b) a 0 H r0); intro; clear H; 
+ unfold Rge in H0; elim H0; intro; clear H0.
+unfold Rgt in H; generalize (Rlt_asym (a + b) 0 r1); intro; auto.
+absurd (a + b = 0); auto.
+apply (Rlt_dichotomy_converse (a + b) 0); left; assumption.
+(**)
+elimtype False; generalize (Rplus_lt_compat_l a b 0 r); intro;
+ elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
+ generalize (Rlt_trans (a + b) a 0 H r0); intro; clear H; 
+ unfold Rge in r1; elim r1; clear r1; intro.
+unfold Rgt in H; generalize (Rlt_trans (a + b) 0 (a + b) H0 H); intro;
+ apply (Rlt_irrefl (a + b)); assumption.
+rewrite H in H0; apply (Rlt_irrefl 0); assumption.
+(**)
+rewrite (Rplus_comm a b); rewrite (Rplus_comm (- a) b);
+ apply (Rplus_le_compat_l b a (- a)); apply (Rminus_le a (- a));
+ unfold Rminus in |- *; rewrite (Ropp_involutive a);
+ generalize (Rplus_lt_compat_l a a 0 r0); clear r r1; 
+ intro; elim (Rplus_ne a); intros v w; rewrite v in H; 
+ clear v w; generalize (Rlt_trans (a + a) a 0 H r0); 
+ intro; apply (Rlt_le (a + a) 0 H0).
+(**)
+apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b));
+ unfold Rminus in |- *; rewrite (Ropp_involutive b);
+ generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1; 
+ intro; elim (Rplus_ne b); intros v w; rewrite v in H; 
+ clear v w; generalize (Rlt_trans (b + b) b 0 H r); 
+ intro; apply (Rlt_le (b + b) 0 H0).
+(**)
+unfold Rle in |- *; right; reflexivity.
+Qed.
+
+(*********)
+Lemma Rabs_triang_inv : forall a b:R, Rabs a - Rabs b <= Rabs (a - b).
+intros; apply (Rplus_le_reg_l (Rabs b) (Rabs a - Rabs b) (Rabs (a - b)));
+ unfold Rminus in |- *; rewrite <- (Rplus_assoc (Rabs b) (Rabs a) (- Rabs b));
+ rewrite (Rplus_comm (Rabs b) (Rabs a));
+ rewrite (Rplus_assoc (Rabs a) (Rabs b) (- Rabs b));
+ rewrite (Rplus_opp_r (Rabs b)); rewrite (proj1 (Rplus_ne (Rabs a)));
+ replace (Rabs a) with (Rabs (a + 0)).
+ rewrite <- (Rplus_opp_r b); rewrite <- (Rplus_assoc a b (- b));
+  rewrite (Rplus_comm a b); rewrite (Rplus_assoc b a (- b)).
+ exact (Rabs_triang b (a + - b)).
+ rewrite (proj1 (Rplus_ne a)); trivial.
+Qed.
+
+(* ||a|-|b||<=|a-b| *)
+Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b). 
+cut
+ (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)). 
+intros; destruct (Rtotal_order (Rabs a) (Rabs b)) as [Hlt| [Heq| Hgt]].
+rewrite <- (Rabs_Ropp (Rabs a - Rabs b)); rewrite <- (Rabs_Ropp (a - b));
+ do 2 rewrite Ropp_minus_distr. 
+apply H; left; assumption. 
+rewrite Heq; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ apply Rabs_pos. 
+apply H; left; assumption. 
+intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b). 
+apply Rabs_triang_inv. 
+rewrite (Rabs_right (Rabs a - Rabs b));
+ [ reflexivity
+ | apply Rle_ge; apply Rplus_le_reg_l with (Rabs b); rewrite Rplus_0_r;
+    replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a); 
+    [ assumption | ring ] ]. 
+Qed. 
+
+(*********)
+Lemma Rabs_def1 : forall x a:R, x < a -> - a < x -> Rabs x < a.
+unfold Rabs in |- *; intros; case (Rcase_abs x); intro.
+generalize (Ropp_lt_gt_contravar (- a) x H0); unfold Rgt in |- *;
+ rewrite Ropp_involutive; intro; assumption.
+assumption.
+Qed.
+
+(*********)
+Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x.
+unfold Rabs in |- *; intro x; case (Rcase_abs x); intros.
+generalize (Ropp_gt_lt_0_contravar x r); unfold Rgt in |- *; intro;
+ generalize (Rlt_trans 0 (- x) a H0 H); intro; split. 
+apply (Rlt_trans x 0 a r H1).
+generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x);
+ unfold Rgt in |- *; trivial.
+fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H r); intro;
+ generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a) in |- *;
+ generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt in |- *; 
+ intro; split; assumption.
+Qed.
+
+Lemma RmaxAbs :
+ forall (p q:R) r, p <= q -> q <= r -> Rabs q <= Rmax (Rabs p) (Rabs r).
+intros p q r H' H'0; case (Rle_or_lt 0 p); intros H'1.
+repeat rewrite Rabs_right; auto with real.
+apply Rle_trans with r; auto with real.
+apply RmaxLess2; auto.
+apply Rge_trans with p; auto with real; apply Rge_trans with q;
+ auto with real.
+apply Rge_trans with p; auto with real.
+rewrite (Rabs_left p); auto.
+case (Rle_or_lt 0 q); intros H'2.
+repeat rewrite Rabs_right; auto with real.
+apply Rle_trans with r; auto.
+apply RmaxLess2; auto.
+apply Rge_trans with q; auto with real.
+rewrite (Rabs_left q); auto.
+case (Rle_or_lt 0 r); intros H'3.
+repeat rewrite Rabs_right; auto with real.
+apply Rle_trans with (- p); auto with real.
+apply RmaxLess1; auto.
+rewrite (Rabs_left r); auto.
+apply Rle_trans with (- p); auto with real.
+apply RmaxLess1; auto.
+Qed.
+
+Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Zabs z).
+intros z; case z; simpl in |- *; auto with real.
+apply Rabs_right; auto with real.
+intros p0; apply Rabs_right; auto with real zarith.
+intros p0; rewrite Rabs_Ropp.
+apply Rabs_right; auto with real zarith.
+Qed.
+ 
\ No newline at end of file
diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v
new file mode 100644
index 00000000..dd8379cb
--- /dev/null
+++ b/theories/Reals/Rcomplete.v
@@ -0,0 +1,198 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Rcomplete.v,v 1.10.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import SeqProp.
+Require Import Max.
+Open Local Scope R_scope.
+
+(****************************************************)
+(*              R is complete :                     *)
+(*        Each sequence which satisfies             *)
+(*       the Cauchy's criterion converges           *)
+(*                                                  *)
+(*    Proof with adjacent sequences (Vn and Wn)     *)
+(****************************************************)
+
+Theorem R_complete :
+ forall Un:nat -> R, Cauchy_crit Un -> sigT (fun l:R => Un_cv Un l).
+intros.
+set (Vn := sequence_minorant Un (cauchy_min Un H)).
+set (Wn := sequence_majorant Un (cauchy_maj Un H)).
+assert (H0 := maj_cv Un H).
+fold Wn in H0.
+assert (H1 := min_cv Un H).
+fold Vn in H1.
+elim H0; intros.
+elim H1; intros.
+cut (x = x0).
+intros.
+apply existT with x.
+rewrite <- H2 in p0.
+unfold Un_cv in |- *.
+intros.
+unfold Un_cv in p; unfold Un_cv in p0.
+cut (0 < eps / 3).
+intro.
+elim (p (eps / 3) H4); intros.
+elim (p0 (eps / 3) H4); intros.
+exists (max x1 x2).
+intros.
+unfold R_dist in |- *.
+apply Rle_lt_trans with (Rabs (Un n - Vn n) + Rabs (Vn n - x)).
+replace (Un n - x) with (Un n - Vn n + (Vn n - x));
+ [ apply Rabs_triang | ring ].
+apply Rle_lt_trans with (Rabs (Wn n - Vn n) + Rabs (Vn n - x)).
+do 2 rewrite <- (Rplus_comm (Rabs (Vn n - x))).
+apply Rplus_le_compat_l.
+repeat rewrite Rabs_right.
+unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- Vn n));
+ apply Rplus_le_compat_l.
+assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
+fold Vn Wn in H8.
+elim (H8 n); intros.
+assumption.
+apply Rle_ge.
+unfold Rminus in |- *; apply Rplus_le_reg_l with (Vn n).
+rewrite Rplus_0_r.
+replace (Vn n + (Wn n + - Vn n)) with (Wn n); [ idtac | ring ].
+assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
+fold Vn Wn in H8.
+elim (H8 n); intros.
+apply Rle_trans with (Un n); assumption.
+apply Rle_ge.
+unfold Rminus in |- *; apply Rplus_le_reg_l with (Vn n).
+rewrite Rplus_0_r.
+replace (Vn n + (Un n + - Vn n)) with (Un n); [ idtac | ring ].
+assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
+fold Vn Wn in H8.
+elim (H8 n); intros.
+assumption.
+apply Rle_lt_trans with (Rabs (Wn n - x) + Rabs (x - Vn n) + Rabs (Vn n - x)).
+do 2 rewrite <- (Rplus_comm (Rabs (Vn n - x))).
+apply Rplus_le_compat_l.
+replace (Wn n - Vn n) with (Wn n - x + (x - Vn n));
+ [ apply Rabs_triang | ring ].
+apply Rlt_le_trans with (eps / 3 + eps / 3 + eps / 3).
+repeat apply Rplus_lt_compat.
+unfold R_dist in H5.
+apply H5.
+unfold ge in |- *; apply le_trans with (max x1 x2).
+apply le_max_l.
+assumption.
+rewrite <- Rabs_Ropp.
+replace (- (x - Vn n)) with (Vn n - x); [ idtac | ring ].
+unfold R_dist in H6.
+apply H6.
+unfold ge in |- *; apply le_trans with (max x1 x2).
+apply le_max_r.
+assumption.
+unfold R_dist in H6.
+apply H6.
+unfold ge in |- *; apply le_trans with (max x1 x2).
+apply le_max_r.
+assumption.
+right.
+pattern eps at 4 in |- *; replace eps with (3 * (eps / 3)).
+ring.
+unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+apply cond_eq.
+intros.
+cut (0 < eps / 5).
+intro.
+unfold Un_cv in p; unfold Un_cv in p0.
+unfold R_dist in p; unfold R_dist in p0.
+elim (p (eps / 5) H3); intros N1 H4.
+elim (p0 (eps / 5) H3); intros N2 H5.
+unfold Cauchy_crit in H.
+unfold R_dist in H.
+elim (H (eps / 5) H3); intros N3 H6.
+set (N := max (max N1 N2) N3).
+apply Rle_lt_trans with (Rabs (x - Wn N) + Rabs (Wn N - x0)).
+replace (x - x0) with (x - Wn N + (Wn N - x0)); [ apply Rabs_triang | ring ].
+apply Rle_lt_trans with
+ (Rabs (x - Wn N) + Rabs (Wn N - Vn N) + Rabs (Vn N - x0)).
+rewrite Rplus_assoc.
+apply Rplus_le_compat_l.
+replace (Wn N - x0) with (Wn N - Vn N + (Vn N - x0));
+ [ apply Rabs_triang | ring ].
+replace eps with (eps / 5 + 3 * (eps / 5) + eps / 5).
+repeat apply Rplus_lt_compat.
+rewrite <- Rabs_Ropp.
+replace (- (x - Wn N)) with (Wn N - x); [ apply H4 | ring ].
+unfold ge, N in |- *.
+apply le_trans with (max N1 N2); apply le_max_l.
+unfold Wn, Vn in |- *.
+unfold sequence_majorant, sequence_minorant in |- *.
+assert
+ (H7 :=
+  approx_maj (fun k:nat => Un (N + k)%nat) (maj_ss Un N (cauchy_maj Un H))).
+assert
+ (H8 :=
+  approx_min (fun k:nat => Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))).
+cut
+ (Wn N =
+  majorant (fun k:nat => Un (N + k)%nat) (maj_ss Un N (cauchy_maj Un H))).
+cut
+ (Vn N =
+  minorant (fun k:nat => Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))).
+intros.
+rewrite <- H9; rewrite <- H10.
+rewrite <- H9 in H8.
+rewrite <- H10 in H7.
+elim (H7 (eps / 5) H3); intros k2 H11.
+elim (H8 (eps / 5) H3); intros k1 H12.
+apply Rle_lt_trans with
+ (Rabs (Wn N - Un (N + k2)%nat) + Rabs (Un (N + k2)%nat - Vn N)).
+replace (Wn N - Vn N) with
+ (Wn N - Un (N + k2)%nat + (Un (N + k2)%nat - Vn N));
+ [ apply Rabs_triang | ring ].
+apply Rle_lt_trans with
+ (Rabs (Wn N - Un (N + k2)%nat) + Rabs (Un (N + k2)%nat - Un (N + k1)%nat) +
+  Rabs (Un (N + k1)%nat - Vn N)).
+rewrite Rplus_assoc.
+apply Rplus_le_compat_l.
+replace (Un (N + k2)%nat - Vn N) with
+ (Un (N + k2)%nat - Un (N + k1)%nat + (Un (N + k1)%nat - Vn N));
+ [ apply Rabs_triang | ring ].
+replace (3 * (eps / 5)) with (eps / 5 + eps / 5 + eps / 5);
+ [ repeat apply Rplus_lt_compat | ring ].
+assumption.
+apply H6.
+unfold ge in |- *.
+apply le_trans with N.
+unfold N in |- *; apply le_max_r.
+apply le_plus_l.
+unfold ge in |- *.
+apply le_trans with N.
+unfold N in |- *; apply le_max_r.
+apply le_plus_l.
+rewrite <- Rabs_Ropp.
+replace (- (Un (N + k1)%nat - Vn N)) with (Vn N - Un (N + k1)%nat);
+ [ assumption | ring ].
+reflexivity.
+reflexivity.
+apply H5.
+unfold ge in |- *; apply le_trans with (max N1 N2).
+apply le_max_r.
+unfold N in |- *; apply le_max_l.
+pattern eps at 4 in |- *; replace eps with (5 * (eps / 5)).
+ring.
+unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
+discrR.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+assumption.
+apply Rinv_0_lt_compat.
+prove_sup0; try apply lt_O_Sn.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v
new file mode 100644
index 00000000..33f494df
--- /dev/null
+++ b/theories/Reals/Rdefinitions.v
@@ -0,0 +1,69 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i $Id: Rdefinitions.v,v 1.14.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+
+(*********************************************************)
+(**          Definitions for the axiomatization          *)
+(*                                                       *)
+(*********************************************************)
+
+Require Export ZArith_base.
+
+Parameter R : Set.
+
+(* Declare Scope positive_scope with Key R *)
+Delimit Scope R_scope with R.
+
+(* Automatically open scope R_scope for arguments of type R *)
+Bind Scope R_scope with R.
+
+Parameter R0 : R.
+Parameter R1 : R.
+Parameter Rplus : R -> R -> R.
+Parameter Rmult : R -> R -> R.
+Parameter Ropp : R -> R.
+Parameter Rinv : R -> R. 
+Parameter Rlt : R -> R -> Prop.    
+Parameter up : R -> Z.
+
+Infix "+" := Rplus : R_scope.
+Infix "*" := Rmult : R_scope.
+Notation "- x" := (Ropp x) : R_scope.
+Notation "/ x" := (Rinv x) : R_scope.
+
+Infix "<" := Rlt : R_scope.
+
+(*i*******************************************************i*)
+
+(**********)
+Definition Rgt (r1 r2:R) : Prop := (r2 < r1)%R.
+
+(**********)
+Definition Rle (r1 r2:R) : Prop := (r1 < r2)%R \/ r1 = r2.
+
+(**********)
+Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 = r2.
+
+(**********)
+Definition Rminus (r1 r2:R) : R := (r1 + - r2)%R.
+
+(**********)
+Definition Rdiv (r1 r2:R) : R := (r1 * / r2)%R.
+
+Infix "-" := Rminus : R_scope.
+Infix "/" := Rdiv : R_scope.
+
+Infix "<=" := Rle : R_scope.
+Infix ">=" := Rge : R_scope.
+Infix ">" := Rgt : R_scope.
+
+Notation "x <= y <= z" := ((x <= y)%R /\ (y <= z)%R) : R_scope.
+Notation "x <= y < z" := ((x <= y)%R /\ (y < z)%R) : R_scope.
+Notation "x < y < z" := ((x < y)%R /\ (y < z)%R) : R_scope.
+Notation "x < y <= z" := ((x < y)%R /\ (y <= z)%R) : R_scope.
\ No newline at end of file
diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v
new file mode 100644
index 00000000..81db80ab
--- /dev/null
+++ b/theories/Reals/Rderiv.v
@@ -0,0 +1,431 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rderiv.v,v 1.15.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(*********************************************************)
+(**     Definition of the derivative,continuity          *)
+(*                                                       *)
+(*********************************************************)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rlimit.
+Require Import Fourier.
+Require Import Classical_Prop.
+Require Import Classical_Pred_Type.
+Require Import Omega. Open Local Scope R_scope.
+
+(*********)
+Definition D_x (D:R -> Prop) (y x:R) : Prop := D x /\ y <> x.
+
+(*********)
+Definition continue_in (f:R -> R) (D:R -> Prop) (x0:R) : Prop :=
+  limit1_in f (D_x D x0) (f x0) x0.
+
+(*********)
+Definition D_in (f d:R -> R) (D:R -> Prop) (x0:R) : Prop :=
+  limit1_in (fun x:R => (f x - f x0) / (x - x0)) (D_x D x0) (d x0) x0.
+
+(*********)
+Lemma cont_deriv :
+ forall (f d:R -> R) (D:R -> Prop) (x0:R),
+   D_in f d D x0 -> continue_in f D x0.
+unfold continue_in in |- *; unfold D_in in |- *; unfold limit1_in in |- *;
+ unfold limit_in in |- *; unfold Rdiv in |- *; simpl in |- *; 
+ intros; elim (H eps H0); clear H; intros; elim H; 
+ clear H; intros; elim (Req_dec (d x0) 0); intro.
+split with (Rmin 1 x); split.
+elim (Rmin_Rgt 1 x 0); intros a b; apply (b (conj Rlt_0_1 H)).
+intros; elim H3; clear H3; intros;
+ generalize (let (H1, H2) := Rmin_Rgt 1 x (R_dist x1 x0) in H1);
+ unfold Rgt in |- *; intro; elim (H5 H4); clear H5; 
+ intros; generalize (H1 x1 (conj H3 H6)); clear H1; 
+ intro; unfold D_x in H3; elim H3; intros.
+rewrite H2 in H1; unfold R_dist in |- *; unfold R_dist in H1;
+ cut (Rabs (f x1 - f x0) < eps * Rabs (x1 - x0)).
+intro; unfold R_dist in H5;
+ generalize (Rmult_lt_compat_l eps (Rabs (x1 - x0)) 1 H0 H5);
+ rewrite Rmult_1_r; intro; apply Rlt_trans with (r2 := eps * Rabs (x1 - x0));
+ assumption.
+rewrite (Rminus_0_r ((f x1 - f x0) * / (x1 - x0))) in H1;
+ rewrite Rabs_mult in H1; cut (x1 - x0 <> 0).
+intro; rewrite (Rabs_Rinv (x1 - x0) H9) in H1;
+ generalize
+  (Rmult_lt_compat_l (Rabs (x1 - x0)) (Rabs (f x1 - f x0) * / Rabs (x1 - x0))
+     eps (Rabs_pos_lt (x1 - x0) H9) H1); intro; rewrite Rmult_comm in H10;
+ rewrite Rmult_assoc in H10; rewrite Rinv_l in H10.
+rewrite Rmult_1_r in H10; rewrite Rmult_comm; assumption.
+apply Rabs_no_R0; auto.
+apply Rminus_eq_contra; auto.
+(**)
+ split with (Rmin (Rmin (/ 2) x) (eps * / Rabs (2 * d x0))); split.
+cut (Rmin (/ 2) x > 0).
+cut (eps * / Rabs (2 * d x0) > 0).
+intros; elim (Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) 0);
+ intros a b; apply (b (conj H4 H3)).
+apply Rmult_gt_0_compat; auto.
+unfold Rgt in |- *; apply Rinv_0_lt_compat; apply Rabs_pos_lt;
+ apply Rmult_integral_contrapositive; split.
+discrR.
+assumption.
+elim (Rmin_Rgt (/ 2) x 0); intros a b; cut (0 < 2).
+intro; generalize (Rinv_0_lt_compat 2 H3); intro; fold (/ 2 > 0) in H4;
+ apply (b (conj H4 H)).
+fourier.
+intros; elim H3; clear H3; intros;
+ generalize
+  (let (H1, H2) :=
+       Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) (R_dist x1 x0) in
+   H1); unfold Rgt in |- *; intro; elim (H5 H4); clear H5; 
+ intros; generalize (let (H1, H2) := Rmin_Rgt (/ 2) x (R_dist x1 x0) in H1);
+ unfold Rgt in |- *; intro; elim (H7 H5); clear H7; 
+ intros; clear H4 H5; generalize (H1 x1 (conj H3 H8)); 
+ clear H1; intro; unfold D_x in H3; elim H3; intros;
+ generalize (sym_not_eq H5); clear H5; intro H5;
+ generalize (Rminus_eq_contra x1 x0 H5); intro; generalize H1;
+ pattern (d x0) at 1 in |- *;
+ rewrite <- (let (H1, H2) := Rmult_ne (d x0) in H2);
+ rewrite <- (Rinv_l (x1 - x0) H9); unfold R_dist in |- *;
+ unfold Rminus at 1 in |- *; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0)));
+ rewrite (Rmult_comm (/ (x1 - x0) * (x1 - x0)) (d x0));
+ rewrite <- (Ropp_mult_distr_l_reverse (d x0) (/ (x1 - x0) * (x1 - x0)));
+ rewrite (Rmult_comm (- d x0) (/ (x1 - x0) * (x1 - x0)));
+ rewrite (Rmult_assoc (/ (x1 - x0)) (x1 - x0) (- d x0));
+ rewrite <-
+  (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) ((x1 - x0) * - d x0))
+  ; rewrite (Rabs_mult (/ (x1 - x0)) (f x1 - f x0 + (x1 - x0) * - d x0));
+ clear H1; intro;
+ generalize
+  (Rmult_lt_compat_l (Rabs (x1 - x0))
+     (Rabs (/ (x1 - x0)) * Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) eps
+     (Rabs_pos_lt (x1 - x0) H9) H1);
+ rewrite <-
+  (Rmult_assoc (Rabs (x1 - x0)) (Rabs (/ (x1 - x0)))
+     (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)));
+ rewrite (Rabs_Rinv (x1 - x0) H9);
+ rewrite (Rinv_r (Rabs (x1 - x0)) (Rabs_no_R0 (x1 - x0) H9));
+ rewrite
+  (let (H1, H2) := Rmult_ne (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) in H2)
+  ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0)); 
+ intro; rewrite (Rmult_comm (x1 - x0) (- d x0));
+ rewrite (Ropp_mult_distr_l_reverse (d x0) (x1 - x0));
+ fold (f x1 - f x0 - d x0 * (x1 - x0)) in |- *;
+ rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1; 
+ intro;
+ generalize
+  (Rle_lt_trans (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0)))
+     (Rabs (f x1 - f x0 - d x0 * (x1 - x0))) (Rabs (x1 - x0) * eps) H10 H1);
+ clear H1; intro;
+ generalize
+  (Rplus_lt_compat_l (Rabs (d x0 * (x1 - x0)))
+     (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0))) (
+     Rabs (x1 - x0) * eps) H1); unfold Rminus at 2 in |- *;
+ rewrite (Rplus_comm (Rabs (f x1 - f x0)) (- Rabs (d x0 * (x1 - x0))));
+ rewrite <-
+  (Rplus_assoc (Rabs (d x0 * (x1 - x0))) (- Rabs (d x0 * (x1 - x0)))
+     (Rabs (f x1 - f x0))); rewrite (Rplus_opp_r (Rabs (d x0 * (x1 - x0))));
+ rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2); 
+ clear H1; intro; cut (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps < eps).
+intro;
+ apply
+  (Rlt_trans (Rabs (f x1 - f x0))
+     (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11). 
+clear H1 H5 H3 H10; generalize (Rabs_pos_lt (d x0) H2); intro;
+ unfold Rgt in H0;
+ generalize (Rmult_lt_compat_l eps (R_dist x1 x0) (/ 2) H0 H7); 
+ clear H7; intro;
+ generalize
+  (Rmult_lt_compat_l (Rabs (d x0)) (R_dist x1 x0) (
+     eps * / Rabs (2 * d x0)) H1 H6); clear H6; intro;
+ rewrite (Rmult_comm eps (R_dist x1 x0)) in H3; unfold R_dist in H3, H5;
+ rewrite <- (Rabs_mult (d x0) (x1 - x0)) in H5;
+ rewrite (Rabs_mult 2 (d x0)) in H5; cut (Rabs 2 <> 0).
+intro; fold (Rabs (d x0) > 0) in H1;
+ rewrite
+  (Rinv_mult_distr (Rabs 2) (Rabs (d x0)) H6
+     (Rlt_dichotomy_converse (Rabs (d x0)) 0 (or_intror (Rabs (d x0) < 0) H1)))
+   in H5;
+ rewrite (Rmult_comm (Rabs (d x0)) (eps * (/ Rabs 2 * / Rabs (d x0)))) in H5;
+ rewrite <- (Rmult_assoc eps (/ Rabs 2) (/ Rabs (d x0))) in H5;
+ rewrite (Rmult_assoc (eps * / Rabs 2) (/ Rabs (d x0)) (Rabs (d x0))) in H5;
+ rewrite
+  (Rinv_l (Rabs (d x0))
+     (Rlt_dichotomy_converse (Rabs (d x0)) 0 (or_intror (Rabs (d x0) < 0) H1)))
+   in H5; rewrite (let (H1, H2) := Rmult_ne (eps * / Rabs 2) in H1) in H5;
+ cut (Rabs 2 = 2).
+intro; rewrite H7 in H5;
+ generalize
+  (Rplus_lt_compat (Rabs (d x0 * (x1 - x0))) (eps * / 2)
+     (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro; 
+ rewrite eps2 in H10; assumption.
+unfold Rabs in |- *; case (Rcase_abs 2); auto.
+ intro; cut (0 < 2).
+intro; generalize (Rlt_asym 0 2 H7); intro; elimtype False; auto.
+fourier.
+apply Rabs_no_R0.
+discrR.
+Qed.
+
+
+(*********)
+Lemma Dconst :
+ forall (D:R -> Prop) (y x0:R), D_in (fun x:R => y) (fun x:R => 0) D x0.
+unfold D_in in |- *; intros; unfold limit1_in in |- *;
+ unfold limit_in in |- *; unfold Rdiv in |- *; intros; 
+ simpl in |- *; split with eps; split; auto.
+intros; rewrite (Rminus_diag_eq y y (refl_equal y)); rewrite Rmult_0_l;
+ unfold R_dist in |- *; rewrite (Rminus_diag_eq 0 0 (refl_equal 0));
+ unfold Rabs in |- *; case (Rcase_abs 0); intro.
+absurd (0 < 0); auto.
+red in |- *; intro; apply (Rlt_irrefl 0 H1).
+unfold Rgt in H0; assumption.
+Qed.
+
+(*********)
+Lemma Dx :
+ forall (D:R -> Prop) (x0:R), D_in (fun x:R => x) (fun x:R => 1) D x0.
+unfold D_in in |- *; unfold Rdiv in |- *; intros; unfold limit1_in in |- *;
+ unfold limit_in in |- *; intros; simpl in |- *; split with eps; 
+ split; auto.
+intros; elim H0; clear H0; intros; unfold D_x in H0; elim H0; intros;
+ rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (sym_not_eq H3)));
+ unfold R_dist in |- *; rewrite (Rminus_diag_eq 1 1 (refl_equal 1));
+ unfold Rabs in |- *; case (Rcase_abs 0); intro.
+absurd (0 < 0); auto.
+red in |- *; intro; apply (Rlt_irrefl 0 r).
+unfold Rgt in H; assumption.
+Qed. 
+
+(*********)
+Lemma Dadd :
+ forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
+   D_in f df D x0 ->
+   D_in g dg D x0 ->
+   D_in (fun x:R => f x + g x) (fun x:R => df x + dg x) D x0.
+unfold D_in in |- *; intros;
+ generalize
+  (limit_plus (fun x:R => (f x - f x0) * / (x - x0))
+     (fun x:R => (g x - g x0) * / (x - x0)) (D_x D x0) (
+     df x0) (dg x0) x0 H H0); clear H H0; unfold limit1_in in |- *;
+ unfold limit_in in |- *; simpl in |- *; intros; elim (H eps H0); 
+ clear H; intros; elim H; clear H; intros; split with x; 
+ split; auto; intros; generalize (H1 x1 H2); clear H1; 
+ intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
+ rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
+ rewrite <- (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) (g x1 - g x0))
+   in H1;
+ rewrite (Rmult_comm (/ (x1 - x0)) (f x1 - f x0 + (g x1 - g x0))) in H1;
+ cut (f x1 - f x0 + (g x1 - g x0) = f x1 + g x1 - (f x0 + g x0)).
+intro; rewrite H3 in H1; assumption.
+ring.
+Qed.
+
+(*********)
+Lemma Dmult :
+ forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
+   D_in f df D x0 ->
+   D_in g dg D x0 ->
+   D_in (fun x:R => f x * g x) (fun x:R => df x * g x + f x * dg x) D x0.
+intros; unfold D_in in |- *; generalize H H0; intros; unfold D_in in H, H0;
+ generalize (cont_deriv f df D x0 H1); unfold continue_in in |- *; 
+ intro;
+ generalize
+  (limit_mul (fun x:R => (g x - g x0) * / (x - x0)) (
+     fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3); 
+ intro; cut (limit1_in (fun x:R => g x0) (D_x D x0) (g x0) x0).
+intro;
+ generalize
+  (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
+     fun _:R => g x0) (D_x D x0) (df x0) (g x0) x0 H H5);
+ clear H H0 H1 H2 H3 H5; intro;
+ generalize
+  (limit_plus (fun x:R => (f x - f x0) * / (x - x0) * g x0)
+     (fun x:R => (g x - g x0) * / (x - x0) * f x) (
+     D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4); 
+ clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H; 
+ simpl in H; unfold limit1_in in |- *; unfold limit_in in |- *; 
+ simpl in |- *; intros; elim (H eps H0); clear H; intros; 
+ elim H; clear H; intros; split with x; split; auto; 
+ intros; generalize (H1 x1 H2); clear H1; intro;
+ rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
+ rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
+ rewrite (Rmult_assoc (/ (x1 - x0)) (f x1 - f x0) (g x0)) in H1;
+ rewrite (Rmult_assoc (/ (x1 - x0)) (g x1 - g x0) (f x1)) in H1;
+ rewrite <-
+  (Rmult_plus_distr_l (/ (x1 - x0)) ((f x1 - f x0) * g x0)
+     ((g x1 - g x0) * f x1)) in H1;
+ rewrite
+  (Rmult_comm (/ (x1 - x0)) ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1))
+   in H1; rewrite (Rmult_comm (dg x0) (f x0)) in H1;
+ cut
+  ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1 = f x1 * g x1 - f x0 * g x0).
+intro; rewrite H3 in H1; assumption.
+ring.
+unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+ split with eps; split; auto; intros; elim (R_dist_refl (g x0) (g x0));
+ intros a b; rewrite (b (refl_equal (g x0))); unfold Rgt in H; 
+ assumption.
+Qed.
+
+(*********)
+Lemma Dmult_const :
+ forall (D:R -> Prop) (f df:R -> R) (x0 a:R),
+   D_in f df D x0 -> D_in (fun x:R => a * f x) (fun x:R => a * df x) D x0.
+intros;
+ generalize (Dmult D (fun _:R => 0) df (fun _:R => a) f x0 (Dconst D a x0) H);
+ unfold D_in in |- *; intros; rewrite (Rmult_0_l (f x0)) in H0;
+ rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0; 
+ assumption.
+Qed.
+
+(*********)
+Lemma Dopp :
+ forall (D:R -> Prop) (f df:R -> R) (x0:R),
+   D_in f df D x0 -> D_in (fun x:R => - f x) (fun x:R => - df x) D x0.
+intros; generalize (Dmult_const D f df x0 (-1) H); unfold D_in in |- *;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ intros; generalize (H0 eps H1); clear H0; intro; elim H0; 
+ clear H0; intros; elim H0; clear H0; simpl in |- *; 
+ intros; split with x; split; auto.
+intros; generalize (H2 x1 H3); clear H2; intro;
+ rewrite Ropp_mult_distr_l_reverse in H2;
+ rewrite Ropp_mult_distr_l_reverse in H2;
+ rewrite Ropp_mult_distr_l_reverse in H2;
+ rewrite (let (H1, H2) := Rmult_ne (f x1) in H2) in H2;
+ rewrite (let (H1, H2) := Rmult_ne (f x0) in H2) in H2;
+ rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2; 
+ assumption.
+Qed.
+
+(*********)
+Lemma Dminus :
+ forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
+   D_in f df D x0 ->
+   D_in g dg D x0 ->
+   D_in (fun x:R => f x - g x) (fun x:R => df x - dg x) D x0.
+unfold Rminus in |- *; intros; generalize (Dopp D g dg x0 H0); intro;
+ apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0); 
+ assumption. 
+Qed.
+
+(*********)
+Lemma Dx_pow_n :
+ forall (n:nat) (D:R -> Prop) (x0:R),
+   D_in (fun x:R => x ^ n) (fun x:R => INR n * x ^ (n - 1)) D x0.
+simple induction n; intros.
+simpl in |- *; rewrite Rmult_0_l; apply Dconst.
+intros; cut (n0 = (S n0 - 1)%nat);
+ [ intro a; rewrite <- a; clear a | simpl in |- *; apply minus_n_O ].
+generalize
+ (Dmult D (fun _:R => 1) (fun x:R => INR n0 * x ^ (n0 - 1)) (
+    fun x:R => x) (fun x:R => x ^ n0) x0 (Dx D x0) (
+    H D x0)); unfold D_in in |- *; unfold limit1_in in |- *;
+ unfold limit_in in |- *; simpl in |- *; intros; elim (H0 eps H1); 
+ clear H0; intros; elim H0; clear H0; intros; split with x; 
+ split; auto.
+intros; generalize (H2 x1 H3); clear H2 H3; intro;
+ rewrite (let (H1, H2) := Rmult_ne (x0 ^ n0) in H2) in H2;
+ rewrite (tech_pow_Rmult x1 n0) in H2; rewrite (tech_pow_Rmult x0 n0) in H2;
+ rewrite (Rmult_comm (INR n0) (x0 ^ (n0 - 1))) in H2;
+ rewrite <- (Rmult_assoc x0 (x0 ^ (n0 - 1)) (INR n0)) in H2;
+ rewrite (tech_pow_Rmult x0 (n0 - 1)) in H2; elim (classic (n0 = 0%nat));
+ intro cond.
+rewrite cond in H2; rewrite cond; simpl in H2; simpl in |- *;
+ cut (1 + x0 * 1 * 0 = 1 * 1);
+ [ intro A; rewrite A in H2; assumption | ring ].
+cut (n0 <> 0%nat -> S (n0 - 1) = n0); [ intro | omega ];
+ rewrite (H3 cond) in H2; rewrite (Rmult_comm (x0 ^ n0) (INR n0)) in H2;
+ rewrite (tech_pow_Rplus x0 n0 n0) in H2; assumption.
+Qed.
+
+(*********)
+Lemma Dcomp :
+ forall (Df Dg:R -> Prop) (df dg f g:R -> R) (x0:R),
+   D_in f df Df x0 ->
+   D_in g dg Dg (f x0) ->
+   D_in (fun x:R => g (f x)) (fun x:R => df x * dg (f x)) (Dgf Df Dg f) x0.
+intros Df Dg df dg f g x0 H H0; generalize H H0; unfold D_in in |- *;
+ unfold Rdiv in |- *; intros;
+ generalize
+  (limit_comp f (fun x:R => (g x - g (f x0)) * / (x - f x0)) (
+     D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0); 
+ intro; generalize (cont_deriv f df Df x0 H); intro; 
+ unfold continue_in in H4; generalize (H3 H4 H2); clear H3; 
+ intro;
+ generalize
+  (limit_mul (fun x:R => (g (f x) - g (f x0)) * / (f x - f x0))
+     (fun x:R => (f x - f x0) * / (x - x0))
+     (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (dg (f x0)) (
+     df x0) x0 H3); intro;
+ cut
+  (limit1_in (fun x:R => (f x - f x0) * / (x - x0))
+     (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (df x0) x0).
+intro; generalize (H5 H6); clear H5; intro;
+ generalize
+  (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
+     fun x:R => dg (f x0)) (D_x Df x0) (df x0) (dg (f x0)) x0 H1
+     (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0)); 
+ intro; unfold limit1_in in |- *; unfold limit_in in |- *; 
+ simpl in |- *; unfold limit1_in in H5, H7; unfold limit_in in H5, H7;
+ simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8); 
+ clear H5 H7; intros; elim H5; elim H7; clear H5 H7; 
+ intros; split with (Rmin x x1); split.
+elim (Rmin_Rgt x x1 0); intros a b; apply (b (conj H9 H5)); clear a b.
+intros; elim H11; clear H11; intros; elim (Rmin_Rgt x x1 (R_dist x2 x0));
+ intros a b; clear b; unfold Rgt in a; elim (a H12); 
+ clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10; 
+ clear H12; elim (classic (f x2 = f x0)); intro.
+elim H11; clear H11; intros; elim H11; clear H11; intros;
+ generalize (H10 x2 (conj (conj H11 H14) H5)); intro;
+ rewrite (Rminus_diag_eq (f x2) (f x0) H12) in H16;
+ rewrite (Rmult_0_l (/ (x2 - x0))) in H16;
+ rewrite (Rmult_0_l (dg (f x0))) in H16; rewrite H12;
+ rewrite (Rminus_diag_eq (g (f x0)) (g (f x0)) (refl_equal (g (f x0))));
+ rewrite (Rmult_0_l (/ (x2 - x0))); assumption.
+clear H10 H5; elim H11; clear H11; intros; elim H5; clear H5; intros;
+ cut
+  (((Df x2 /\ x0 <> x2) /\ Dg (f x2) /\ f x0 <> f x2) /\ R_dist x2 x0 < x1);
+ auto; intro; generalize (H7 x2 H14); intro;
+ generalize (Rminus_eq_contra (f x2) (f x0) H12); intro;
+ rewrite
+  (Rmult_assoc (g (f x2) - g (f x0)) (/ (f x2 - f x0))
+     ((f x2 - f x0) * / (x2 - x0))) in H15;
+ rewrite <- (Rmult_assoc (/ (f x2 - f x0)) (f x2 - f x0) (/ (x2 - x0)))
+   in H15; rewrite (Rinv_l (f x2 - f x0) H16) in H15;
+ rewrite (let (H1, H2) := Rmult_ne (/ (x2 - x0)) in H2) in H15;
+ rewrite (Rmult_comm (df x0) (dg (f x0))); assumption.
+clear H5 H3 H4 H2; unfold limit1_in in |- *; unfold limit_in in |- *;
+ simpl in |- *; unfold limit1_in in H1; unfold limit_in in H1; 
+ simpl in H1; intros; elim (H1 eps H2); clear H1; intros; 
+ elim H1; clear H1; intros; split with x; split; auto; 
+ intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4; 
+ intros; elim H4; clear H4; intros; exact (H3 x1 (conj H4 H5)).
+Qed.   
+
+(*********)
+Lemma D_pow_n :
+ forall (n:nat) (D:R -> Prop) (x0:R) (expr dexpr:R -> R),
+   D_in expr dexpr D x0 ->
+   D_in (fun x:R => expr x ^ n)
+     (fun x:R => INR n * expr x ^ (n - 1) * dexpr x) (
+     Dgf D D expr) x0.
+intros n D x0 expr dexpr H;
+ generalize
+  (Dcomp D D dexpr (fun x:R => INR n * x ^ (n - 1)) expr (
+     fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0))); 
+ intro; unfold D_in in |- *; unfold limit1_in in |- *;
+ unfold limit_in in |- *; simpl in |- *; intros; unfold D_in in H0;
+ unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; 
+ elim (H0 eps H1); clear H0; intros; elim H0; clear H0; 
+ intros; split with x; split; intros; auto.
+cut
+ (dexpr x0 * (INR n * expr x0 ^ (n - 1)) =
+  INR n * expr x0 ^ (n - 1) * dexpr x0);
+ [ intro Rew; rewrite <- Rew; exact (H2 x1 H3) | ring ].
+Qed.
diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v
new file mode 100644
index 00000000..5e4b3e7b
--- /dev/null
+++ b/theories/Reals/Reals.v
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Reals.v,v 1.24.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(* The library REALS is divided in 6 parts :
+   - Rbase: basic lemmas on R
+            equalities and inequalities
+            Ring and Field are instantiated on R
+   - Rfunctions: some useful functions (Rabsolu, Rmin, Rmax, fact...)
+   - SeqSeries: theory of sequences and series
+   - Rtrigo: theory of trigonometric functions
+   - Ranalysis: some topology and general results of real analysis (mean value theorem, intermediate value theorem,...)
+   - Integration: Newton and Riemann' integrals
+
+  Tactics are:
+  - DiscrR: for goals like ``?1<>0``
+  - Sup: for goals like ``?1<?2``
+  - RCompute: for equalities with constants like ``10*10==100``
+  - Reg: for goals like (continuity_pt ?1 ?2) or (derivable_pt ?1 ?2) *)
+  
+Require Export Rbase.
+Require Export Rfunctions.
+Require Export SeqSeries.
+Require Export Rtrigo.
+Require Export Ranalysis.
+Require Export Integration.
\ No newline at end of file
diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v
new file mode 100644
index 00000000..cdff9fcb
--- /dev/null
+++ b/theories/Reals/Rfunctions.v
@@ -0,0 +1,801 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rfunctions.v,v 1.31.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(*i Some properties about pow and sum have been made with John Harrison i*)
+(*i Some Lemmas (about pow and powerRZ) have been done by Laurent Thery i*)
+
+(********************************************************)
+(**          Definition of the sum functions            *)
+(*                                                      *)
+(********************************************************)
+
+Require Import Rbase.
+Require Export R_Ifp.
+Require Export Rbasic_fun.
+Require Export R_sqr.
+Require Export SplitAbsolu.
+Require Export SplitRmult.
+Require Export ArithProp.
+Require Import Omega.
+Require Import Zpower.
+Open Local Scope nat_scope.
+Open Local Scope R_scope.
+
+(*******************************)
+(**  Lemmas about factorial    *)
+(*******************************)
+(*********)
+Lemma INR_fact_neq_0 : forall n:nat, INR (fact n) <> 0.
+Proof.
+intro; red in |- *; intro; apply (not_O_INR (fact n) (fact_neq_0 n));
+ assumption.
+Qed.    
+
+(*********)
+Lemma fact_simpl : forall n:nat, fact (S n) = (S n * fact n)%nat.
+Proof.
+intro; reflexivity.
+Qed. 
+
+(*********)
+Lemma simpl_fact :
+ forall n:nat, / INR (fact (S n)) * / / INR (fact n) = / INR (S n).
+Proof.
+intro; rewrite (Rinv_involutive (INR (fact n)) (INR_fact_neq_0 n));
+ unfold fact at 1 in |- *; cbv beta iota in |- *; fold fact in |- *;
+ rewrite (mult_INR (S n) (fact n));
+ rewrite (Rinv_mult_distr (INR (S n)) (INR (fact n))).
+rewrite (Rmult_assoc (/ INR (S n)) (/ INR (fact n)) (INR (fact n)));
+ rewrite (Rinv_l (INR (fact n)) (INR_fact_neq_0 n));
+ apply (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1).
+apply not_O_INR; auto.
+apply INR_fact_neq_0.
+Qed.
+
+(*******************************)
+(*          Power              *)
+(*******************************)
+(*********)
+Fixpoint pow (r:R) (n:nat) {struct n} : R :=
+  match n with
+  | O => 1
+  | S n => r * pow r n
+  end.
+
+Infix "^" := pow : R_scope.
+
+Lemma pow_O : forall x:R, x ^ 0 = 1.
+Proof.
+reflexivity.
+Qed.
+ 
+Lemma pow_1 : forall x:R, x ^ 1 = x.
+Proof.
+simpl in |- *; auto with real.
+Qed.
+ 
+Lemma pow_add : forall (x:R) (n m:nat), x ^ (n + m) = x ^ n * x ^ m.
+Proof.
+intros x n; elim n; simpl in |- *; auto with real.
+intros n0 H' m; rewrite H'; auto with real.
+Qed.
+
+Lemma pow_nonzero : forall (x:R) (n:nat), x <> 0 -> x ^ n <> 0.
+Proof.
+intro; simple induction n; simpl in |- *.
+intro; red in |- *; intro; apply R1_neq_R0; assumption.
+intros; red in |- *; intro; elim (Rmult_integral x (x ^ n0) H1).
+intro; auto.
+apply H; assumption.
+Qed.
+
+Hint Resolve pow_O pow_1 pow_add pow_nonzero: real.
+ 
+Lemma pow_RN_plus :
+ forall (x:R) (n m:nat), x <> 0 -> x ^ n = x ^ (n + m) * / x ^ m.
+Proof.
+intros x n; elim n; simpl in |- *; auto with real.
+intros n0 H' m H'0.
+rewrite Rmult_assoc; rewrite <- H'; auto.
+Qed.
+
+Lemma pow_lt : forall (x:R) (n:nat), 0 < x -> 0 < x ^ n.
+Proof.
+intros x n; elim n; simpl in |- *; auto with real.
+intros n0 H' H'0; replace 0 with (x * 0); auto with real.
+Qed.
+Hint Resolve pow_lt: real.
+
+Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n.
+Proof.
+intros x n; elim n; simpl in |- *; auto with real.
+intros H' H'0; elimtype False; omega.
+intros n0; case n0.
+simpl in |- *; rewrite Rmult_1_r; auto.
+intros n1 H' H'0 H'1.
+replace 1 with (1 * 1); auto with real.
+apply Rlt_trans with (r2 := x * 1); auto with real.
+apply Rmult_lt_compat_l; auto with real.
+apply Rlt_trans with (r2 := 1); auto with real.
+apply H'; auto with arith.
+Qed.
+Hint Resolve Rlt_pow_R1: real.
+
+Lemma Rlt_pow : forall (x:R) (n m:nat), 1 < x -> (n < m)%nat -> x ^ n < x ^ m.
+Proof.
+intros x n m H' H'0; replace m with (m - n + n)%nat.
+rewrite pow_add.
+pattern (x ^ n) at 1 in |- *; replace (x ^ n) with (1 * x ^ n);
+ auto with real.
+apply Rminus_lt.
+repeat rewrite (fun y:R => Rmult_comm y (x ^ n));
+ rewrite <- Rmult_minus_distr_l.
+replace 0 with (x ^ n * 0); auto with real.
+apply Rmult_lt_compat_l; auto with real.
+apply pow_lt; auto with real.
+apply Rlt_trans with (r2 := 1); auto with real.
+apply Rlt_minus; auto with real.
+apply Rlt_pow_R1; auto with arith.
+apply plus_lt_reg_l with (p := n); auto with arith.
+rewrite le_plus_minus_r; auto with arith; rewrite <- plus_n_O; auto.
+rewrite plus_comm; auto with arith.
+Qed.
+Hint Resolve Rlt_pow: real.
+
+(*********)
+Lemma tech_pow_Rmult : forall (x:R) (n:nat), x * x ^ n = x ^ S n.
+Proof.
+simple induction n; simpl in |- *; trivial.
+Qed.
+
+(*********)
+Lemma tech_pow_Rplus :
+ forall (x:R) (a n:nat), x ^ a + INR n * x ^ a = INR (S n) * x ^ a.
+Proof.
+intros; pattern (x ^ a) at 1 in |- *;
+ rewrite <- (let (H1, H2) := Rmult_ne (x ^ a) in H1);
+ rewrite (Rmult_comm (INR n) (x ^ a));
+ rewrite <- (Rmult_plus_distr_l (x ^ a) 1 (INR n));
+ rewrite (Rplus_comm 1 (INR n)); rewrite <- (S_INR n); 
+ apply Rmult_comm.
+Qed.
+
+Lemma poly : forall (n:nat) (x:R), 0 < x -> 1 + INR n * x <= (1 + x) ^ n.
+Proof.
+intros; elim n.
+simpl in |- *; cut (1 + 0 * x = 1).
+intro; rewrite H0; unfold Rle in |- *; right; reflexivity.
+ring.
+intros; unfold pow in |- *; fold pow in |- *;
+ apply
+  (Rle_trans (1 + INR (S n0) * x) ((1 + x) * (1 + INR n0 * x))
+     ((1 + x) * (1 + x) ^ n0)).
+cut ((1 + x) * (1 + INR n0 * x) = 1 + INR (S n0) * x + INR n0 * (x * x)).
+intro; rewrite H1; pattern (1 + INR (S n0) * x) at 1 in |- *;
+ rewrite <- (let (H1, H2) := Rplus_ne (1 + INR (S n0) * x) in H1);
+ apply Rplus_le_compat_l; elim n0; intros.
+simpl in |- *; rewrite Rmult_0_l; unfold Rle in |- *; right; auto.
+unfold Rle in |- *; left; generalize Rmult_gt_0_compat; unfold Rgt in |- *;
+ intro; fold (Rsqr x) in |- *;
+ apply (H3 (INR (S n1)) (Rsqr x) (lt_INR_0 (S n1) (lt_O_Sn n1)));
+ fold (x > 0) in H;
+ apply (Rlt_0_sqr x (Rlt_dichotomy_converse x 0 (or_intror (x < 0) H))).
+rewrite (S_INR n0); ring.
+unfold Rle in H0; elim H0; intro. 
+unfold Rle in |- *; left; apply Rmult_lt_compat_l.
+rewrite Rplus_comm; apply (Rle_lt_0_plus_1 x (Rlt_le 0 x H)).
+assumption.
+rewrite H1; unfold Rle in |- *; right; trivial.
+Qed.
+
+Lemma Power_monotonic :
+ forall (x:R) (m n:nat),
+   Rabs x > 1 -> (m <= n)%nat -> Rabs (x ^ m) <= Rabs (x ^ n).
+Proof.
+intros x m n H; induction  n as [| n Hrecn]; intros; inversion H0.
+unfold Rle in |- *; right; reflexivity.
+unfold Rle in |- *; right; reflexivity.
+apply (Rle_trans (Rabs (x ^ m)) (Rabs (x ^ n)) (Rabs (x ^ S n))).
+apply Hrecn; assumption.
+simpl in |- *; rewrite Rabs_mult.
+pattern (Rabs (x ^ n)) at 1 in |- *.
+rewrite <- Rmult_1_r.
+rewrite (Rmult_comm (Rabs x) (Rabs (x ^ n))).
+apply Rmult_le_compat_l.
+apply Rabs_pos.
+unfold Rgt in H.
+apply Rlt_le; assumption.
+Qed.
+
+Lemma RPow_abs : forall (x:R) (n:nat), Rabs x ^ n = Rabs (x ^ n).
+Proof.
+intro; simple induction n; simpl in |- *.
+apply sym_eq; apply Rabs_pos_eq; apply Rlt_le; apply Rlt_0_1.
+intros; rewrite H; apply sym_eq; apply Rabs_mult.
+Qed.
+
+
+Lemma Pow_x_infinity :
+ forall x:R,
+   Rabs x > 1 ->
+   forall b:R,
+      exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) >= b).
+Proof.
+intros; elim (archimed (b * / (Rabs x - 1))); intros; clear H1;
+ cut (exists N : nat, INR N >= b * / (Rabs x - 1)).
+intro; elim H1; clear H1; intros; exists x0; intros;
+ apply (Rge_trans (Rabs (x ^ n)) (Rabs (x ^ x0)) b).
+apply Rle_ge; apply Power_monotonic; assumption.
+rewrite <- RPow_abs; cut (Rabs x = 1 + (Rabs x - 1)).
+intro; rewrite H3;
+ apply (Rge_trans ((1 + (Rabs x - 1)) ^ x0) (1 + INR x0 * (Rabs x - 1)) b).
+apply Rle_ge; apply poly; fold (Rabs x - 1 > 0) in |- *; apply Rgt_minus;
+ assumption.
+apply (Rge_trans (1 + INR x0 * (Rabs x - 1)) (INR x0 * (Rabs x - 1)) b).
+apply Rle_ge; apply Rlt_le; rewrite (Rplus_comm 1 (INR x0 * (Rabs x - 1)));
+ pattern (INR x0 * (Rabs x - 1)) at 1 in |- *;
+ rewrite <- (let (H1, H2) := Rplus_ne (INR x0 * (Rabs x - 1)) in H1);
+ apply Rplus_lt_compat_l; apply Rlt_0_1.
+cut (b = b * / (Rabs x - 1) * (Rabs x - 1)).
+intros; rewrite H4; apply Rmult_ge_compat_r.
+apply Rge_minus; unfold Rge in |- *; left; assumption.
+assumption.
+rewrite Rmult_assoc; rewrite Rinv_l.
+ring.
+apply Rlt_dichotomy_converse; right; apply Rgt_minus; assumption.
+ring.
+cut ((0 <= up (b * / (Rabs x - 1)))%Z \/ (up (b * / (Rabs x - 1)) <= 0)%Z).
+intros; elim H1; intro.
+elim (IZN (up (b * / (Rabs x - 1))) H2); intros; exists x0;
+ apply
+  (Rge_trans (INR x0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
+rewrite INR_IZR_INZ; apply IZR_ge; omega.
+unfold Rge in |- *; left; assumption.
+exists 0%nat;
+ apply
+  (Rge_trans (INR 0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
+rewrite INR_IZR_INZ; apply IZR_ge; simpl in |- *; omega.
+unfold Rge in |- *; left; assumption.
+omega.
+Qed.
+
+Lemma pow_ne_zero : forall n:nat, n <> 0%nat -> 0 ^ n = 0.
+Proof.
+simple induction n.
+simpl in |- *; auto.
+intros; elim H; reflexivity.
+intros; simpl in |- *; apply Rmult_0_l.
+Qed.
+
+Lemma Rinv_pow : forall (x:R) (n:nat), x <> 0 -> / x ^ n = (/ x) ^ n.
+Proof.
+intros; elim n; simpl in |- *.
+apply Rinv_1.
+intro m; intro; rewrite Rinv_mult_distr.
+rewrite H0; reflexivity; assumption.
+assumption.
+apply pow_nonzero; assumption.
+Qed.
+
+Lemma pow_lt_1_zero :
+ forall x:R,
+   Rabs x < 1 ->
+   forall y:R,
+     0 < y ->
+      exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) < y).
+Proof.
+intros; elim (Req_dec x 0); intro. 
+exists 1%nat; rewrite H1; intros n GE; rewrite pow_ne_zero.
+rewrite Rabs_R0; assumption.
+inversion GE; auto.
+cut (Rabs (/ x) > 1).
+intros; elim (Pow_x_infinity (/ x) H2 (/ y + 1)); intros N.
+exists N; intros; rewrite <- (Rinv_involutive y).
+rewrite <- (Rinv_involutive (Rabs (x ^ n))).
+apply Rinv_lt_contravar.
+apply Rmult_lt_0_compat.
+apply Rinv_0_lt_compat.
+assumption.
+apply Rinv_0_lt_compat.
+apply Rabs_pos_lt.
+apply pow_nonzero.
+assumption.
+rewrite <- Rabs_Rinv.
+rewrite Rinv_pow.
+apply (Rlt_le_trans (/ y) (/ y + 1) (Rabs ((/ x) ^ n))).
+pattern (/ y) at 1 in |- *.
+rewrite <- (let (H1, H2) := Rplus_ne (/ y) in H1).
+apply Rplus_lt_compat_l.
+apply Rlt_0_1.
+apply Rge_le.
+apply H3.
+assumption.
+assumption.
+apply pow_nonzero.
+assumption.
+apply Rabs_no_R0.
+apply pow_nonzero.
+assumption.
+apply Rlt_dichotomy_converse.
+right; unfold Rgt in |- *; assumption.
+rewrite <- (Rinv_involutive 1).
+rewrite Rabs_Rinv.
+unfold Rgt in |- *; apply Rinv_lt_contravar.
+apply Rmult_lt_0_compat.
+apply Rabs_pos_lt.
+assumption.
+rewrite Rinv_1; apply Rlt_0_1.
+rewrite Rinv_1; assumption.
+assumption.
+red in |- *; intro; apply R1_neq_R0; assumption.
+Qed.
+
+Lemma pow_R1 : forall (r:R) (n:nat), r ^ n = 1 -> Rabs r = 1 \/ n = 0%nat.
+Proof.
+intros r n H'.
+case (Req_dec (Rabs r) 1); auto; intros H'1.
+case (Rdichotomy _ _ H'1); intros H'2.
+generalize H'; case n; auto.
+intros n0 H'0.
+cut (r <> 0); [ intros Eq1 | idtac ].
+cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto.
+absurd (Rabs (/ r) ^ 0 < Rabs (/ r) ^ S n0); auto.
+replace (Rabs (/ r) ^ S n0) with 1.
+simpl in |- *; apply Rlt_irrefl; auto.
+rewrite Rabs_Rinv; auto.
+rewrite <- Rinv_pow; auto.
+rewrite RPow_abs; auto.
+rewrite H'0; rewrite Rabs_right; auto with real.
+apply Rle_ge; auto with real.
+apply Rlt_pow; auto with arith.
+rewrite Rabs_Rinv; auto.
+apply Rmult_lt_reg_l with (r := Rabs r).
+case (Rabs_pos r); auto.
+intros H'3; case Eq2; auto.
+rewrite Rmult_1_r; rewrite Rinv_r; auto with real.
+red in |- *; intro; absurd (r ^ S n0 = 1); auto.
+simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real.
+generalize H'; case n; auto.
+intros n0 H'0.
+cut (r <> 0); [ intros Eq1 | auto with real ].
+cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto.
+absurd (Rabs r ^ 0 < Rabs r ^ S n0); auto with real arith.
+repeat rewrite RPow_abs; rewrite H'0; simpl in |- *; auto with real.
+red in |- *; intro; absurd (r ^ S n0 = 1); auto.
+simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real.
+Qed.
+
+Lemma pow_Rsqr : forall (x:R) (n:nat), x ^ (2 * n) = Rsqr x ^ n.
+Proof.
+intros; induction  n as [| n Hrecn].
+reflexivity.
+replace (2 * S n)%nat with (S (S (2 * n))).
+replace (x ^ S (S (2 * n))) with (x * x * x ^ (2 * n)).
+rewrite Hrecn; reflexivity.
+simpl in |- *; ring.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+Qed.
+
+Lemma pow_le : forall (a:R) (n:nat), 0 <= a -> 0 <= a ^ n.
+Proof.
+intros; induction  n as [| n Hrecn].
+simpl in |- *; left; apply Rlt_0_1.
+simpl in |- *; apply Rmult_le_pos; assumption.
+Qed.
+
+(**********)
+Lemma pow_1_even : forall n:nat, (-1) ^ (2 * n) = 1.
+Proof.
+intro; induction  n as [| n Hrecn].
+reflexivity.
+replace (2 * S n)%nat with (2 + 2 * n)%nat.
+rewrite pow_add; rewrite Hrecn; simpl in |- *; ring.
+replace (S n) with (n + 1)%nat; [ ring | ring ].
+Qed.
+
+(**********)
+Lemma pow_1_odd : forall n:nat, (-1) ^ S (2 * n) = -1.
+Proof.
+intro; replace (S (2 * n)) with (2 * n + 1)%nat; [ idtac | ring ].
+rewrite pow_add; rewrite pow_1_even; simpl in |- *; ring.
+Qed.
+
+(**********)
+Lemma pow_1_abs : forall n:nat, Rabs ((-1) ^ n) = 1.
+Proof.
+intro; induction  n as [| n Hrecn].
+simpl in |- *; apply Rabs_R1.
+replace (S n) with (n + 1)%nat; [ rewrite pow_add | ring ].
+rewrite Rabs_mult.
+rewrite Hrecn; rewrite Rmult_1_l; simpl in |- *; rewrite Rmult_1_r;
+ rewrite Rabs_Ropp; apply Rabs_R1.
+Qed.
+
+Lemma pow_mult : forall (x:R) (n1 n2:nat), x ^ (n1 * n2) = (x ^ n1) ^ n2.
+Proof.
+intros; induction  n2 as [| n2 Hrecn2].
+simpl in |- *; replace (n1 * 0)%nat with 0%nat; [ reflexivity | ring ].
+replace (n1 * S n2)%nat with (n1 * n2 + n1)%nat.
+replace (S n2) with (n2 + 1)%nat; [ idtac | ring ].
+do 2 rewrite pow_add.
+rewrite Hrecn2.
+simpl in |- *.
+ring.
+apply INR_eq; rewrite plus_INR; do 2 rewrite mult_INR; rewrite S_INR; ring.
+Qed.
+
+Lemma pow_incr : forall (x y:R) (n:nat), 0 <= x <= y -> x ^ n <= y ^ n.
+Proof.
+intros.
+induction  n as [| n Hrecn].
+right; reflexivity.
+simpl in |- *.
+elim H; intros.
+apply Rle_trans with (y * x ^ n).
+do 2 rewrite <- (Rmult_comm (x ^ n)).
+apply Rmult_le_compat_l.
+apply pow_le; assumption.
+assumption.
+apply Rmult_le_compat_l.
+apply Rle_trans with x; assumption.
+apply Hrecn.
+Qed.
+
+Lemma pow_R1_Rle : forall (x:R) (k:nat), 1 <= x -> 1 <= x ^ k.
+Proof.
+intros.
+induction  k as [| k Hreck].
+right; reflexivity.
+simpl in |- *.
+apply Rle_trans with (x * 1).
+rewrite Rmult_1_r; assumption.
+apply Rmult_le_compat_l.
+left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ].
+exact Hreck.
+Qed.
+
+Lemma Rle_pow :
+ forall (x:R) (m n:nat), 1 <= x -> (m <= n)%nat -> x ^ m <= x ^ n.
+Proof.
+intros.
+replace n with (n - m + m)%nat.
+rewrite pow_add.
+rewrite Rmult_comm.
+pattern (x ^ m) at 1 in |- *; rewrite <- Rmult_1_r.
+apply Rmult_le_compat_l.
+apply pow_le; left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ].
+apply pow_R1_Rle; assumption.
+rewrite plus_comm.
+symmetry  in |- *; apply le_plus_minus; assumption.
+Qed.
+
+Lemma pow1 : forall n:nat, 1 ^ n = 1.
+Proof.
+intro; induction  n as [| n Hrecn].
+reflexivity.
+simpl in |- *; rewrite Hrecn; rewrite Rmult_1_r; reflexivity.
+Qed.
+
+Lemma pow_Rabs : forall (x:R) (n:nat), x ^ n <= Rabs x ^ n.
+Proof.
+intros; induction  n as [| n Hrecn].
+right; reflexivity.
+simpl in |- *; case (Rcase_abs x); intro.
+apply Rle_trans with (Rabs (x * x ^ n)).
+apply RRle_abs.
+rewrite Rabs_mult.
+apply Rmult_le_compat_l.
+apply Rabs_pos.
+right; symmetry  in |- *; apply RPow_abs.
+pattern (Rabs x) at 1 in |- *; rewrite (Rabs_right x r);
+ apply Rmult_le_compat_l.
+apply Rge_le; exact r.
+apply Hrecn.
+Qed.
+
+Lemma pow_maj_Rabs : forall (x y:R) (n:nat), Rabs y <= x -> y ^ n <= x ^ n.
+Proof.
+intros; cut (0 <= x).
+intro; apply Rle_trans with (Rabs y ^ n).
+apply pow_Rabs.
+induction  n as [| n Hrecn].
+right; reflexivity.
+simpl in |- *; apply Rle_trans with (x * Rabs y ^ n).
+do 2 rewrite <- (Rmult_comm (Rabs y ^ n)).
+apply Rmult_le_compat_l.
+apply pow_le; apply Rabs_pos.
+assumption.
+apply Rmult_le_compat_l.
+apply H0.
+apply Hrecn.
+apply Rle_trans with (Rabs y); [ apply Rabs_pos | exact H ].
+Qed.
+
+(*******************************)
+(**         PowerRZ            *)
+(*******************************)
+(*i Due to L.Thery i*)
+
+Ltac case_eq name :=
+  generalize (refl_equal name); pattern name at -1 in |- *; case name.
+
+Definition powerRZ (x:R) (n:Z) :=
+  match n with
+  | Z0 => 1
+  | Zpos p => x ^ nat_of_P p
+  | Zneg p => / x ^ nat_of_P p
+  end.
+
+Infix Local "^Z" := powerRZ (at level 30, right associativity) : R_scope.
+
+Lemma Zpower_NR0 :
+ forall (x:Z) (n:nat), (0 <= x)%Z -> (0 <= Zpower_nat x n)%Z.
+Proof.
+induction n; unfold Zpower_nat in |- *; simpl in |- *; auto with zarith.
+Qed.
+
+Lemma powerRZ_O : forall x:R, x ^Z 0 = 1.
+Proof.
+reflexivity.
+Qed.
+ 
+Lemma powerRZ_1 : forall x:R, x ^Z Zsucc 0 = x.
+Proof.
+simpl in |- *; auto with real.
+Qed.
+ 
+Lemma powerRZ_NOR : forall (x:R) (z:Z), x <> 0 -> x ^Z z <> 0.
+Proof.
+destruct z; simpl in |- *; auto with real.
+Qed.
+ 
+Lemma powerRZ_add :
+ forall (x:R) (n m:Z), x <> 0 -> x ^Z (n + m) = x ^Z n * x ^Z m.
+Proof.
+intro x; destruct n as [| n1| n1]; destruct m as [| m1| m1]; simpl in |- *;
+ auto with real.
+(* POS/POS *)
+rewrite nat_of_P_plus_morphism; auto with real.
+(* POS/NEG *)
+case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real.
+intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real.
+intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real.
+rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1));
+ auto with real.
+rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
+rewrite Rinv_mult_distr; auto with real.
+rewrite Rinv_involutive; auto with real.
+apply lt_le_weak.
+apply nat_of_P_lt_Lt_compare_morphism; auto.
+apply ZC2; auto.
+intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real.
+rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1));
+ auto with real.
+rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
+apply lt_le_weak.
+change (nat_of_P n1 > nat_of_P m1)%nat in |- *.
+apply nat_of_P_gt_Gt_compare_morphism; auto.
+(* NEG/POS *)
+case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real.
+intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real.
+intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real.
+rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1));
+ auto with real.
+rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
+apply lt_le_weak.
+apply nat_of_P_lt_Lt_compare_morphism; auto.
+apply ZC2; auto.
+intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real.
+rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1));
+ auto with real.
+rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
+rewrite Rinv_mult_distr; auto with real.
+apply lt_le_weak.
+change (nat_of_P n1 > nat_of_P m1)%nat in |- *.
+apply nat_of_P_gt_Gt_compare_morphism; auto.
+(* NEG/NEG *)
+rewrite nat_of_P_plus_morphism; auto with real.
+intros H'; rewrite pow_add; auto with real.
+apply Rinv_mult_distr; auto.
+apply pow_nonzero; auto.
+apply pow_nonzero; auto.
+Qed.
+Hint Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add: real.
+ 
+Lemma Zpower_nat_powerRZ :
+ forall n m:nat, IZR (Zpower_nat (Z_of_nat n) m) = INR n ^Z Z_of_nat m.
+Proof.
+intros n m; elim m; simpl in |- *; auto with real.
+intros m1 H'; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; simpl in |- *.
+replace (Zpower_nat (Z_of_nat n) (S m1)) with
+ (Z_of_nat n * Zpower_nat (Z_of_nat n) m1)%Z.
+rewrite mult_IZR; auto with real.
+repeat rewrite <- INR_IZR_INZ; simpl in |- *.
+rewrite H'; simpl in |- *.
+case m1; simpl in |- *; auto with real.
+intros m2; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto.
+unfold Zpower_nat in |- *; auto.
+Qed.
+ 
+Lemma powerRZ_lt : forall (x:R) (z:Z), 0 < x -> 0 < x ^Z z.
+Proof.
+intros x z; case z; simpl in |- *; auto with real.
+Qed.
+Hint Resolve powerRZ_lt: real.
+ 
+Lemma powerRZ_le : forall (x:R) (z:Z), 0 < x -> 0 <= x ^Z z.
+Proof.
+intros x z H'; apply Rlt_le; auto with real.
+Qed.
+Hint Resolve powerRZ_le: real.
+ 
+Lemma Zpower_nat_powerRZ_absolu :
+ forall n m:Z, (0 <= m)%Z -> IZR (Zpower_nat n (Zabs_nat m)) = IZR n ^Z m.
+Proof.
+intros n m; case m; simpl in |- *; auto with zarith.
+intros p H'; elim (nat_of_P p); simpl in |- *; auto with zarith.
+intros n0 H'0; rewrite <- H'0; simpl in |- *; auto with zarith.
+rewrite <- mult_IZR; auto.
+intros p H'; absurd (0 <= Zneg p)%Z; auto with zarith.
+Qed.
+
+Lemma powerRZ_R1 : forall n:Z, 1 ^Z n = 1.
+Proof.
+intros n; case n; simpl in |- *; auto.
+intros p; elim (nat_of_P p); simpl in |- *; auto; intros n0 H'; rewrite H';
+ ring.
+intros p; elim (nat_of_P p); simpl in |- *.
+exact Rinv_1.
+intros n1 H'; rewrite Rinv_mult_distr; try rewrite Rinv_1; try rewrite H';
+ auto with real.
+Qed.
+
+(*******************************)
+(* For easy interface          *)
+(*******************************)
+(* decimal_exp r z is defined as r 10^z *)
+ 
+Definition decimal_exp (r:R) (z:Z) : R := (r * 10 ^Z z).
+
+
+(*******************************)
+(** Sum of n first naturals    *)
+(*******************************)
+(*********)
+Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) {struct n} : nat :=
+  match n with
+  | O => f 0%nat
+  | S n' => (sum_nat_f_O f n' + f (S n'))%nat
+  end.
+
+(*********)
+Definition sum_nat_f (s n:nat) (f:nat -> nat) : nat :=
+  sum_nat_f_O (fun x:nat => f (x + s)%nat) (n - s).
+
+(*********)
+Definition sum_nat_O (n:nat) : nat := sum_nat_f_O (fun x:nat => x) n.
+
+(*********)
+Definition sum_nat (s n:nat) : nat := sum_nat_f s n (fun x:nat => x).
+
+(*******************************)
+(**            Sum             *)
+(*******************************)
+(*********)
+Fixpoint sum_f_R0 (f:nat -> R) (N:nat) {struct N} : R :=
+  match N with
+  | O => f 0%nat
+  | S i => sum_f_R0 f i + f (S i)
+  end.
+
+(*********)
+Definition sum_f (s n:nat) (f:nat -> R) : R :=
+  sum_f_R0 (fun x:nat => f (x + s)%nat) (n - s).
+
+Lemma GP_finite :
+ forall (x:R) (n:nat),
+   sum_f_R0 (fun n:nat => x ^ n) n * (x - 1) = x ^ (n + 1) - 1.
+Proof.
+intros; induction  n as [| n Hrecn]; simpl in |- *.
+ring.
+rewrite Rmult_plus_distr_r; rewrite Hrecn; cut ((n + 1)%nat = S n).
+intro H; rewrite H; simpl in |- *; ring.
+omega.
+Qed.
+
+Lemma sum_f_R0_triangle :
+ forall (x:nat -> R) (n:nat),
+   Rabs (sum_f_R0 x n) <= sum_f_R0 (fun i:nat => Rabs (x i)) n.
+Proof.
+intro; simple induction n; simpl in |- *.
+unfold Rle in |- *; right; reflexivity.
+intro m; intro;
+ apply
+  (Rle_trans (Rabs (sum_f_R0 x m + x (S m)))
+     (Rabs (sum_f_R0 x m) + Rabs (x (S m)))
+     (sum_f_R0 (fun i:nat => Rabs (x i)) m + Rabs (x (S m)))).
+apply Rabs_triang.
+rewrite Rplus_comm;
+ rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (x i)) m) (Rabs (x (S m))));
+ apply Rplus_le_compat_l; assumption.
+Qed.
+
+(*******************************)
+(*        Distance  in R       *)
+(*******************************)
+
+(*********)
+Definition R_dist (x y:R) : R := Rabs (x - y).
+
+(*********)
+Lemma R_dist_pos : forall x y:R, R_dist x y >= 0.
+Proof.
+intros; unfold R_dist in |- *; unfold Rabs in |- *; case (Rcase_abs (x - y));
+ intro l.
+unfold Rge in |- *; left; apply (Ropp_gt_lt_0_contravar (x - y) l).
+trivial.
+Qed.
+
+(*********)
+Lemma R_dist_sym : forall x y:R, R_dist x y = R_dist y x.
+Proof.
+unfold R_dist in |- *; intros; split_Rabs; ring.
+generalize (Ropp_gt_lt_0_contravar (y - x) r); intro;
+ rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 r0);
+ intro; unfold Rgt in H; elimtype False; auto.
+generalize (minus_Rge y x r); intro; generalize (minus_Rge x y r0); intro;
+ generalize (Rge_antisym x y H0 H); intro; rewrite H1; 
+ ring.
+Qed.
+
+(*********)
+Lemma R_dist_refl : forall x y:R, R_dist x y = 0 <-> x = y.
+Proof.
+unfold R_dist in |- *; intros; split_Rabs; split; intros.
+rewrite (Ropp_minus_distr x y) in H; apply sym_eq;
+ apply (Rminus_diag_uniq y x H).
+rewrite (Ropp_minus_distr x y); generalize (sym_eq H); intro;
+ apply (Rminus_diag_eq y x H0).
+apply (Rminus_diag_uniq x y H).
+apply (Rminus_diag_eq x y H). 
+Qed.
+
+Lemma R_dist_eq : forall x:R, R_dist x x = 0.
+Proof.
+unfold R_dist in |- *; intros; split_Rabs; intros; ring.
+Qed.
+
+(***********)
+Lemma R_dist_tri : forall x y z:R, R_dist x y <= R_dist x z + R_dist z y.
+Proof.
+intros; unfold R_dist in |- *; replace (x - y) with (x - z + (z - y));
+ [ apply (Rabs_triang (x - z) (z - y)) | ring ].
+Qed.
+
+(*********)
+Lemma R_dist_plus :
+ forall a b c d:R, R_dist (a + c) (b + d) <= R_dist a b + R_dist c d.
+Proof.
+intros; unfold R_dist in |- *;
+ replace (a + c - (b + d)) with (a - b + (c - d)).
+exact (Rabs_triang (a - b) (c - d)).
+ring.
+Qed.
+
+(*******************************)
+(**       Infinit Sum          *)
+(*******************************)
+(*********)
+Definition infinit_sum (s:nat -> R) (l:R) : Prop :=
+  forall eps:R,
+    eps > 0 ->
+     exists N : nat,
+      (forall n:nat, (n >= N)%nat -> R_dist (sum_f_R0 s n) l < eps).
diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v
new file mode 100644
index 00000000..a01e7b52
--- /dev/null
+++ b/theories/Reals/Rgeom.v
@@ -0,0 +1,187 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rgeom.v,v 1.13.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import R_sqrt. Open Local Scope R_scope.
+
+Definition dist_euc (x0 y0 x1 y1:R) : R :=
+  sqrt (Rsqr (x0 - x1) + Rsqr (y0 - y1)).
+
+Lemma distance_refl : forall x0 y0:R, dist_euc x0 y0 x0 y0 = 0.
+intros x0 y0; unfold dist_euc in |- *; apply Rsqr_inj;
+ [ apply sqrt_positivity; apply Rplus_le_le_0_compat;
+    [ apply Rle_0_sqr | apply Rle_0_sqr ]
+ | right; reflexivity
+ | rewrite Rsqr_0; rewrite Rsqr_sqrt;
+    [ unfold Rsqr in |- *; ring
+    | apply Rplus_le_le_0_compat; [ apply Rle_0_sqr | apply Rle_0_sqr ] ] ].
+Qed.
+
+Lemma distance_symm :
+ forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0. 
+intros x0 y0 x1 y1; unfold dist_euc in |- *; apply Rsqr_inj;
+ [ apply sqrt_positivity; apply Rplus_le_le_0_compat
+ | apply sqrt_positivity; apply Rplus_le_le_0_compat
+ | repeat rewrite Rsqr_sqrt;
+    [ unfold Rsqr in |- *; ring
+    | apply Rplus_le_le_0_compat
+    | apply Rplus_le_le_0_compat ] ]; apply Rle_0_sqr.
+Qed.
+
+Lemma law_cosines :
+ forall x0 y0 x1 y1 x2 y2 ac:R,
+   let a := dist_euc x1 y1 x0 y0 in
+   let b := dist_euc x2 y2 x0 y0 in
+   let c := dist_euc x2 y2 x1 y1 in
+   a * c * cos ac = (x0 - x1) * (x2 - x1) + (y0 - y1) * (y2 - y1) ->
+   Rsqr b = Rsqr c + Rsqr a - 2 * (a * c * cos ac).
+unfold dist_euc in |- *; intros; repeat rewrite Rsqr_sqrt;
+ [ rewrite H; unfold Rsqr in |- *; ring
+ | apply Rplus_le_le_0_compat
+ | apply Rplus_le_le_0_compat
+ | apply Rplus_le_le_0_compat ]; apply Rle_0_sqr.
+Qed.
+
+Lemma triangle :
+ forall x0 y0 x1 y1 x2 y2:R,
+   dist_euc x0 y0 x1 y1 <= dist_euc x0 y0 x2 y2 + dist_euc x2 y2 x1 y1.
+intros; unfold dist_euc in |- *; apply Rsqr_incr_0;
+ [ rewrite Rsqr_plus; repeat rewrite Rsqr_sqrt;
+    [ replace (Rsqr (x0 - x1)) with
+       (Rsqr (x0 - x2) + Rsqr (x2 - x1) + 2 * (x0 - x2) * (x2 - x1));
+       [ replace (Rsqr (y0 - y1)) with
+          (Rsqr (y0 - y2) + Rsqr (y2 - y1) + 2 * (y0 - y2) * (y2 - y1));
+          [ apply Rplus_le_reg_l with
+             (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
+              Rsqr (y2 - y1));
+             replace
+              (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
+               Rsqr (y2 - y1) +
+               (Rsqr (x0 - x2) + Rsqr (x2 - x1) + 2 * (x0 - x2) * (x2 - x1) +
+                (Rsqr (y0 - y2) + Rsqr (y2 - y1) + 2 * (y0 - y2) * (y2 - y1))))
+              with (2 * ((x0 - x2) * (x2 - x1) + (y0 - y2) * (y2 - y1)));
+             [ replace
+                (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
+                 Rsqr (y2 - y1) +
+                 (Rsqr (x0 - x2) + Rsqr (y0 - y2) +
+                  (Rsqr (x2 - x1) + Rsqr (y2 - y1)) +
+                  2 * sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) *
+                  sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1)))) with
+                (2 *
+                 (sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) *
+                  sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1))));
+                [ apply Rmult_le_compat_l;
+                   [ left; cut (0%nat <> 2%nat);
+                      [ intros; generalize (lt_INR_0 2 (neq_O_lt 2 H));
+                         intro H0; assumption
+                      | discriminate ]
+                   | apply sqrt_cauchy ]
+                | ring ]
+             | ring ]
+          | ring_Rsqr ]
+       | ring_Rsqr ]
+    | apply Rplus_le_le_0_compat; apply Rle_0_sqr
+    | apply Rplus_le_le_0_compat; apply Rle_0_sqr
+    | apply Rplus_le_le_0_compat; apply Rle_0_sqr ]
+ | apply sqrt_positivity; apply Rplus_le_le_0_compat; apply Rle_0_sqr
+ | apply Rplus_le_le_0_compat; apply sqrt_positivity;
+    apply Rplus_le_le_0_compat; apply Rle_0_sqr ].
+Qed.
+
+(******************************************************************)
+(**                         Translation                           *)
+(******************************************************************)
+
+Definition xt (x tx:R) : R := x + tx.
+Definition yt (y ty:R) : R := y + ty.
+
+Lemma translation_0 : forall x y:R, xt x 0 = x /\ yt y 0 = y.
+intros x y; split; [ unfold xt in |- * | unfold yt in |- * ]; ring.
+Qed.
+
+Lemma isometric_translation :
+ forall x1 x2 y1 y2 tx ty:R,
+   Rsqr (x1 - x2) + Rsqr (y1 - y2) =
+   Rsqr (xt x1 tx - xt x2 tx) + Rsqr (yt y1 ty - yt y2 ty).
+intros; unfold Rsqr, xt, yt in |- *; ring.
+Qed.
+
+(******************************************************************)
+(**                           Rotation                            *)
+(******************************************************************)
+
+Definition xr (x y theta:R) : R := x * cos theta + y * sin theta.
+Definition yr (x y theta:R) : R := - x * sin theta + y * cos theta.
+
+Lemma rotation_0 : forall x y:R, xr x y 0 = x /\ yr x y 0 = y.
+intros x y; unfold xr, yr in |- *; split; rewrite cos_0; rewrite sin_0; ring.
+Qed.
+
+Lemma rotation_PI2 :
+ forall x y:R, xr x y (PI / 2) = y /\ yr x y (PI / 2) = - x.
+intros x y; unfold xr, yr in |- *; split; rewrite cos_PI2; rewrite sin_PI2;
+ ring.
+Qed.
+
+Lemma isometric_rotation_0 :
+ forall x1 y1 x2 y2 theta:R,
+   Rsqr (x1 - x2) + Rsqr (y1 - y2) =
+   Rsqr (xr x1 y1 theta - xr x2 y2 theta) +
+   Rsqr (yr x1 y1 theta - yr x2 y2 theta).
+intros; unfold xr, yr in |- *;
+ replace
+  (x1 * cos theta + y1 * sin theta - (x2 * cos theta + y2 * sin theta)) with
+  (cos theta * (x1 - x2) + sin theta * (y1 - y2));
+ [ replace
+    (- x1 * sin theta + y1 * cos theta - (- x2 * sin theta + y2 * cos theta))
+    with (cos theta * (y1 - y2) + sin theta * (x2 - x1));
+    [ repeat rewrite Rsqr_plus; repeat rewrite Rsqr_mult; repeat rewrite cos2;
+       ring; replace (x2 - x1) with (- (x1 - x2));
+       [ rewrite <- Rsqr_neg; ring | ring ]
+    | ring ]
+ | ring ].
+Qed.
+
+Lemma isometric_rotation :
+ forall x1 y1 x2 y2 theta:R,
+   dist_euc x1 y1 x2 y2 =
+   dist_euc (xr x1 y1 theta) (yr x1 y1 theta) (xr x2 y2 theta)
+     (yr x2 y2 theta).
+unfold dist_euc in |- *; intros; apply Rsqr_inj;
+ [ apply sqrt_positivity; apply Rplus_le_le_0_compat
+ | apply sqrt_positivity; apply Rplus_le_le_0_compat
+ | repeat rewrite Rsqr_sqrt;
+    [ apply isometric_rotation_0
+    | apply Rplus_le_le_0_compat
+    | apply Rplus_le_le_0_compat ] ]; apply Rle_0_sqr.
+Qed.
+
+(******************************************************************)
+(**                         Similarity                            *)
+(******************************************************************)
+
+Lemma isometric_rot_trans :
+ forall x1 y1 x2 y2 tx ty theta:R,
+   Rsqr (x1 - x2) + Rsqr (y1 - y2) =
+   Rsqr (xr (xt x1 tx) (yt y1 ty) theta - xr (xt x2 tx) (yt y2 ty) theta) +
+   Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta). 
+intros; rewrite <- isometric_rotation_0; apply isometric_translation.
+Qed.
+
+Lemma isometric_trans_rot :
+ forall x1 y1 x2 y2 tx ty theta:R,
+   Rsqr (x1 - x2) + Rsqr (y1 - y2) =
+   Rsqr (xt (xr x1 y1 theta) tx - xt (xr x2 y2 theta) tx) +
+   Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty). 
+intros; rewrite <- isometric_translation; apply isometric_rotation_0.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v
new file mode 100644
index 00000000..51323ac4
--- /dev/null
+++ b/theories/Reals/RiemannInt.v
@@ -0,0 +1,3263 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: RiemannInt.v,v 1.18.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Ranalysis.
+Require Import Rbase.
+Require Import RiemannInt_SF.
+Require Import Classical_Prop.
+Require Import Classical_Pred_Type.
+Require Import Max. Open Local Scope R_scope.
+
+Set Implicit Arguments.
+
+(********************************************)
+(*            Riemann's Integral            *)
+(********************************************)
+
+Definition Riemann_integrable (f:R -> R) (a b:R) : Type :=
+  forall eps:posreal,
+    sigT
+      (fun phi:StepFun a b =>
+         sigT
+           (fun psi:StepFun a b =>
+              (forall t:R,
+                 Rmin a b <= t <= Rmax a b -> Rabs (f t - phi t) <= psi t) /\
+              Rabs (RiemannInt_SF psi) < eps)).
+
+Definition phi_sequence (un:nat -> posreal) (f:R -> R) 
+  (a b:R) (pr:Riemann_integrable f a b) (n:nat) := 
+  projT1 (pr (un n)).
+
+Lemma phi_sequence_prop :
+ forall (un:nat -> posreal) (f:R -> R) (a b:R) (pr:Riemann_integrable f a b)
+   (N:nat),
+   sigT
+     (fun psi:StepFun a b =>
+        (forall t:R,
+           Rmin a b <= t <= Rmax a b ->
+           Rabs (f t - phi_sequence un pr N t) <= psi t) /\
+        Rabs (RiemannInt_SF psi) < un N).
+intros; apply (projT2 (pr (un N))).
+Qed.
+
+Lemma RiemannInt_P1 :
+ forall (f:R -> R) (a b:R),
+   Riemann_integrable f a b -> Riemann_integrable f b a.
+unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; intros;
+ elim p; clear p; intros; apply existT with (mkStepFun (StepFun_P6 (pre x)));
+ apply existT with (mkStepFun (StepFun_P6 (pre x0))); 
+ elim p; clear p; intros; split.
+intros; apply (H t); elim H1; clear H1; intros; split;
+ [ apply Rle_trans with (Rmin b a); try assumption; right;
+    unfold Rmin in |- *
+ | apply Rle_trans with (Rmax b a); try assumption; right;
+    unfold Rmax in |- * ];
+ (case (Rle_dec a b); case (Rle_dec b a); intros;
+   try reflexivity || apply Rle_antisym;
+   [ assumption | assumption | auto with real | auto with real ]).
+generalize H0; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
+ case (Rle_dec b a); intros;
+ (replace
+   (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre x0))))
+      (subdivision (mkStepFun (StepFun_P6 (pre x0))))) with
+   (Int_SF (subdivision_val x0) (subdivision x0));
+   [ idtac
+   | apply StepFun_P17 with (fe x0) a b;
+      [ apply StepFun_P1
+      | apply StepFun_P2;
+         apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre x0)))) ] ]).
+apply H1.
+rewrite Rabs_Ropp; apply H1.
+rewrite Rabs_Ropp in H1; apply H1.
+apply H1.
+Qed.
+
+Lemma RiemannInt_P2 :
+ forall (f:R -> R) (a b:R) (un:nat -> posreal) (vn wn:nat -> StepFun a b),
+   Un_cv un 0 ->
+   a <= b ->
+   (forall n:nat,
+      (forall t:R, Rmin a b <= t <= Rmax a b -> Rabs (f t - vn n t) <= wn n t) /\
+      Rabs (RiemannInt_SF (wn n)) < un n) ->
+   sigT (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (vn N)) l).
+intros; apply R_complete; unfold Un_cv in H; unfold Cauchy_crit in |- *;
+ intros; assert (H3 : 0 < eps / 2).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (H _ H3); intros N0 H4; exists N0; intros; unfold R_dist in |- *;
+ unfold R_dist in H4; elim (H1 n); elim (H1 m); intros;
+ replace (RiemannInt_SF (vn n) - RiemannInt_SF (vn m)) with
+  (RiemannInt_SF (vn n) + -1 * RiemannInt_SF (vn m)); 
+ [ idtac | ring ]; rewrite <- StepFun_P30;
+ apply Rle_lt_trans with
+  (RiemannInt_SF
+     (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (vn n) (vn m)))))).
+apply StepFun_P34; assumption.
+apply Rle_lt_trans with
+ (RiemannInt_SF (mkStepFun (StepFun_P28 1 (wn n) (wn m)))).
+apply StepFun_P37; try assumption.
+intros; simpl in |- *;
+ apply Rle_trans with (Rabs (vn n x - f x) + Rabs (f x - vn m x)).
+replace (vn n x + -1 * vn m x) with (vn n x - f x + (f x - vn m x));
+ [ apply Rabs_triang | ring ].
+assert (H12 : Rmin a b = a).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+assert (H13 : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+rewrite <- H12 in H11; pattern b at 2 in H11; rewrite <- H13 in H11;
+ rewrite Rmult_1_l; apply Rplus_le_compat.
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9.
+elim H11; intros; split; left; assumption.
+apply H7.
+elim H11; intros; split; left; assumption.
+rewrite StepFun_P30; rewrite Rmult_1_l; apply Rlt_trans with (un n + un m).
+apply Rle_lt_trans with
+ (Rabs (RiemannInt_SF (wn n)) + Rabs (RiemannInt_SF (wn m))).
+apply Rplus_le_compat; apply RRle_abs.
+apply Rplus_lt_compat; assumption.
+apply Rle_lt_trans with (Rabs (un n) + Rabs (un m)).
+apply Rplus_le_compat; apply RRle_abs.
+replace (pos (un n)) with (un n - 0); [ idtac | ring ];
+ replace (pos (un m)) with (un m - 0); [ idtac | ring ];
+ rewrite (double_var eps); apply Rplus_lt_compat; apply H4; 
+ assumption.
+Qed.
+
+Lemma RiemannInt_P3 :
+ forall (f:R -> R) (a b:R) (un:nat -> posreal) (vn wn:nat -> StepFun a b),
+   Un_cv un 0 ->
+   (forall n:nat,
+      (forall t:R, Rmin a b <= t <= Rmax a b -> Rabs (f t - vn n t) <= wn n t) /\
+      Rabs (RiemannInt_SF (wn n)) < un n) ->
+   sigT (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (vn N)) l).
+intros; case (Rle_dec a b); intro.
+apply RiemannInt_P2 with f un wn; assumption.
+assert (H1 : b <= a); auto with real.
+set (vn' := fun n:nat => mkStepFun (StepFun_P6 (pre (vn n))));
+ set (wn' := fun n:nat => mkStepFun (StepFun_P6 (pre (wn n))));
+ assert
+  (H2 :
+   forall n:nat,
+     (forall t:R,
+        Rmin b a <= t <= Rmax b a -> Rabs (f t - vn' n t) <= wn' n t) /\
+     Rabs (RiemannInt_SF (wn' n)) < un n).
+intro; elim (H0 n0); intros; split.
+intros; apply (H2 t); elim H4; clear H4; intros; split;
+ [ apply Rle_trans with (Rmin b a); try assumption; right;
+    unfold Rmin in |- *
+ | apply Rle_trans with (Rmax b a); try assumption; right;
+    unfold Rmax in |- * ];
+ (case (Rle_dec a b); case (Rle_dec b a); intros;
+   try reflexivity || apply Rle_antisym;
+   [ assumption | assumption | auto with real | auto with real ]).
+generalize H3; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
+ case (Rle_dec b a); unfold wn' in |- *; intros;
+ (replace
+   (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (wn n0)))))
+      (subdivision (mkStepFun (StepFun_P6 (pre (wn n0)))))) with
+   (Int_SF (subdivision_val (wn n0)) (subdivision (wn n0)));
+   [ idtac
+   | apply StepFun_P17 with (fe (wn n0)) a b;
+      [ apply StepFun_P1
+      | apply StepFun_P2;
+         apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (wn n0))))) ] ]).
+apply H4.
+rewrite Rabs_Ropp; apply H4.
+rewrite Rabs_Ropp in H4; apply H4.
+apply H4.
+assert (H3 := RiemannInt_P2 _ _ _ _ H H1 H2); elim H3; intros;
+ apply existT with (- x); unfold Un_cv in |- *; unfold Un_cv in p; 
+ intros; elim (p _ H4); intros; exists x0; intros; 
+ generalize (H5 _ H6); unfold R_dist, RiemannInt_SF in |- *;
+ case (Rle_dec b a); case (Rle_dec a b); intros.
+elim n; assumption.
+unfold vn' in H7;
+ replace (Int_SF (subdivision_val (vn n0)) (subdivision (vn n0))) with
+  (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n0)))))
+     (subdivision (mkStepFun (StepFun_P6 (pre (vn n0))))));
+ [ unfold Rminus in |- *; rewrite Ropp_involutive; rewrite <- Rabs_Ropp;
+    rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
+    apply H7
+ | symmetry  in |- *; apply StepFun_P17 with (fe (vn n0)) a b;
+    [ apply StepFun_P1
+    | apply StepFun_P2;
+       apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (vn n0))))) ] ].
+elim n1; assumption.
+elim n2; assumption.
+Qed.
+
+Lemma RiemannInt_exists :
+ forall (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) 
+   (un:nat -> posreal),
+   Un_cv un 0 ->
+   sigT
+     (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr N)) l).
+intros f; intros;
+ apply RiemannInt_P3 with
+  f un (fun n:nat => projT1 (phi_sequence_prop un pr n));
+ [ apply H | intro; apply (projT2 (phi_sequence_prop un pr n)) ].
+Qed.
+
+Lemma RiemannInt_P4 :
+ forall (f:R -> R) (a b l:R) (pr1 pr2:Riemann_integrable f a b)
+   (un vn:nat -> posreal),
+   Un_cv un 0 ->
+   Un_cv vn 0 ->
+   Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr1 N)) l ->
+   Un_cv (fun N:nat => RiemannInt_SF (phi_sequence vn pr2 N)) l.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros f; intros;
+ assert (H3 : 0 < eps / 3).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (H _ H3); clear H; intros N0 H; elim (H0 _ H3); clear H0; intros N1 H0;
+ elim (H1 _ H3); clear H1; intros N2 H1; set (N := max (max N0 N1) N2);
+ exists N; intros;
+ apply Rle_lt_trans with
+  (Rabs
+     (RiemannInt_SF (phi_sequence vn pr2 n) -
+      RiemannInt_SF (phi_sequence un pr1 n)) +
+   Rabs (RiemannInt_SF (phi_sequence un pr1 n) - l)).
+replace (RiemannInt_SF (phi_sequence vn pr2 n) - l) with
+ (RiemannInt_SF (phi_sequence vn pr2 n) -
+  RiemannInt_SF (phi_sequence un pr1 n) +
+  (RiemannInt_SF (phi_sequence un pr1 n) - l)); [ apply Rabs_triang | ring ].
+replace eps with (2 * (eps / 3) + eps / 3).
+apply Rplus_lt_compat.
+elim (phi_sequence_prop vn pr2 n); intros psi_vn H5;
+ elim (phi_sequence_prop un pr1 n); intros psi_un H6;
+ replace
+  (RiemannInt_SF (phi_sequence vn pr2 n) -
+   RiemannInt_SF (phi_sequence un pr1 n)) with
+  (RiemannInt_SF (phi_sequence vn pr2 n) +
+   -1 * RiemannInt_SF (phi_sequence un pr1 n)); [ idtac | ring ];
+ rewrite <- StepFun_P30.
+case (Rle_dec a b); intro.
+apply Rle_lt_trans with
+ (RiemannInt_SF
+    (mkStepFun
+       (StepFun_P32
+          (mkStepFun
+             (StepFun_P28 (-1) (phi_sequence vn pr2 n)
+                (phi_sequence un pr1 n)))))).
+apply StepFun_P34; assumption.
+apply Rle_lt_trans with
+ (RiemannInt_SF (mkStepFun (StepFun_P28 1 psi_un psi_vn))).
+apply StepFun_P37; try assumption; intros; simpl in |- *; rewrite Rmult_1_l;
+ apply Rle_trans with
+  (Rabs (phi_sequence vn pr2 n x - f x) +
+   Rabs (f x - phi_sequence un pr1 n x)).
+replace (phi_sequence vn pr2 n x + -1 * phi_sequence un pr1 n x) with
+ (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x));
+ [ apply Rabs_triang | ring ].
+assert (H10 : Rmin a b = a).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+assert (H11 : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+rewrite (Rplus_comm (psi_un x)); apply Rplus_le_compat.
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim H5; intros; apply H8.
+rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
+elim H6; intros; apply H8.
+rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
+rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
+apply Rlt_trans with (pos (un n)).
+elim H6; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_un)).
+apply RRle_abs.
+assumption.
+replace (pos (un n)) with (Rabs (un n - 0));
+ [ apply H; unfold ge in |- *; apply le_trans with N; try assumption;
+    unfold N in |- *; apply le_trans with (max N0 N1); 
+    apply le_max_l
+ | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+    apply Rle_ge; left; apply (cond_pos (un n)) ].
+apply Rlt_trans with (pos (vn n)).
+elim H5; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_vn)).
+apply RRle_abs; assumption.
+assumption.
+replace (pos (vn n)) with (Rabs (vn n - 0));
+ [ apply H0; unfold ge in |- *; apply le_trans with N; try assumption;
+    unfold N in |- *; apply le_trans with (max N0 N1);
+    [ apply le_max_r | apply le_max_l ]
+ | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+    apply Rle_ge; left; apply (cond_pos (vn n)) ].
+rewrite StepFun_P39; rewrite Rabs_Ropp;
+ apply Rle_lt_trans with
+  (RiemannInt_SF
+     (mkStepFun
+        (StepFun_P32
+           (mkStepFun
+              (StepFun_P6
+                 (pre
+                    (mkStepFun
+                       (StepFun_P28 (-1) (phi_sequence vn pr2 n)
+                          (phi_sequence un pr1 n))))))))).
+apply StepFun_P34; try auto with real.
+apply Rle_lt_trans with
+ (RiemannInt_SF
+    (mkStepFun (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 psi_vn psi_un)))))).
+apply StepFun_P37.
+auto with real.
+intros; simpl in |- *; rewrite Rmult_1_l;
+ apply Rle_trans with
+  (Rabs (phi_sequence vn pr2 n x - f x) +
+   Rabs (f x - phi_sequence un pr1 n x)).
+replace (phi_sequence vn pr2 n x + -1 * phi_sequence un pr1 n x) with
+ (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x));
+ [ apply Rabs_triang | ring ].
+assert (H10 : Rmin a b = b).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ elim n0; assumption | reflexivity ].
+assert (H11 : Rmax a b = a).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ elim n0; assumption | reflexivity ].
+apply Rplus_le_compat.
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim H5; intros; apply H8.
+rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
+elim H6; intros; apply H8.
+rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
+rewrite <-
+ (Ropp_involutive
+    (RiemannInt_SF
+       (mkStepFun
+          (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 psi_vn psi_un)))))))
+ ; rewrite <- StepFun_P39; rewrite StepFun_P30; rewrite Rmult_1_l;
+ rewrite double; rewrite Ropp_plus_distr; apply Rplus_lt_compat.
+apply Rlt_trans with (pos (vn n)).
+elim H5; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_vn)).
+rewrite <- Rabs_Ropp; apply RRle_abs.
+assumption.
+replace (pos (vn n)) with (Rabs (vn n - 0));
+ [ apply H0; unfold ge in |- *; apply le_trans with N; try assumption;
+    unfold N in |- *; apply le_trans with (max N0 N1);
+    [ apply le_max_r | apply le_max_l ]
+ | unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+    left; apply (cond_pos (vn n)) ].
+apply Rlt_trans with (pos (un n)).
+elim H6; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_un)).
+rewrite <- Rabs_Ropp; apply RRle_abs; assumption.
+assumption.
+replace (pos (un n)) with (Rabs (un n - 0));
+ [ apply H; unfold ge in |- *; apply le_trans with N; try assumption;
+    unfold N in |- *; apply le_trans with (max N0 N1); 
+    apply le_max_l
+ | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+    apply Rle_ge; left; apply (cond_pos (un n)) ].
+apply H1; unfold ge in |- *; apply le_trans with N; try assumption;
+ unfold N in |- *; apply le_max_r.
+apply Rmult_eq_reg_l with 3;
+ [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym; [ ring | discrR ]
+ | discrR ].
+Qed.
+
+Lemma RinvN_pos : forall n:nat, 0 < / (INR n + 1).
+intro; apply Rinv_0_lt_compat; apply Rplus_le_lt_0_compat;
+ [ apply pos_INR | apply Rlt_0_1 ].
+Qed.
+
+Definition RinvN (N:nat) : posreal := mkposreal _ (RinvN_pos N).
+ 
+Lemma RinvN_cv : Un_cv RinvN 0.
+unfold Un_cv in |- *; intros; assert (H0 := archimed (/ eps)); elim H0;
+ clear H0; intros; assert (H2 : (0 <= up (/ eps))%Z).
+apply le_IZR; left; apply Rlt_trans with (/ eps);
+ [ apply Rinv_0_lt_compat; assumption | assumption ].
+elim (IZN _ H2); intros; exists x; intros; unfold R_dist in |- *;
+ simpl in |- *; unfold Rminus in |- *; rewrite Ropp_0; 
+ rewrite Rplus_0_r; assert (H5 : 0 < INR n + 1).
+apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
+rewrite Rabs_right;
+ [ idtac
+ | left; change (0 < / (INR n + 1)) in |- *; apply Rinv_0_lt_compat;
+    assumption ]; apply Rle_lt_trans with (/ (INR x + 1)).
+apply Rle_Rinv.
+apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
+assumption.
+do 2 rewrite <- (Rplus_comm 1); apply Rplus_le_compat_l; apply le_INR;
+ apply H4.
+rewrite <- (Rinv_involutive eps).
+apply Rinv_lt_contravar.
+apply Rmult_lt_0_compat.
+apply Rinv_0_lt_compat; assumption.
+apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
+apply Rlt_trans with (INR x);
+ [ rewrite INR_IZR_INZ; rewrite <- H3; apply H0
+ | pattern (INR x) at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_lt_compat_l; apply Rlt_0_1 ].
+red in |- *; intro; rewrite H6 in H; elim (Rlt_irrefl _ H).
+Qed.
+
+(**********) 
+Definition RiemannInt (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) : R :=
+  match RiemannInt_exists pr RinvN RinvN_cv with
+  | existT a' b' => a'
+  end.
+
+Lemma RiemannInt_P5 :
+ forall (f:R -> R) (a b:R) (pr1 pr2:Riemann_integrable f a b),
+   RiemannInt pr1 = RiemannInt pr2.
+intros; unfold RiemannInt in |- *;
+ case (RiemannInt_exists pr1 RinvN RinvN_cv);
+ case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; 
+ eapply UL_sequence;
+ [ apply u0
+ | apply RiemannInt_P4 with pr2 RinvN; apply RinvN_cv || assumption ].
+Qed.
+
+(**************************************)
+(* C°([a,b]) is included in L1([a,b]) *)
+(**************************************)
+
+Lemma maxN :
+ forall (a b:R) (del:posreal),
+   a < b ->
+   sigT (fun n:nat => a + INR n * del < b /\ b <= a + INR (S n) * del).
+intros; set (I := fun n:nat => a + INR n * del < b);
+ assert (H0 :  exists n : nat, I n).
+exists 0%nat; unfold I in |- *; rewrite Rmult_0_l; rewrite Rplus_0_r;
+ assumption.
+cut (Nbound I).
+intro; assert (H2 := Nzorn H0 H1); elim H2; intros; exists x; elim p; intros;
+ split.
+apply H3.
+case (total_order_T (a + INR (S x) * del) b); intro.
+elim s; intro.
+assert (H5 := H4 (S x) a0); elim (le_Sn_n _ H5).
+right; symmetry  in |- *; assumption.
+left; apply r.
+assert (H1 : 0 <= (b - a) / del).
+unfold Rdiv in |- *; apply Rmult_le_pos;
+ [ apply Rge_le; apply Rge_minus; apply Rle_ge; left; apply H
+ | left; apply Rinv_0_lt_compat; apply (cond_pos del) ].
+elim (archimed ((b - a) / del)); intros;
+ assert (H4 : (0 <= up ((b - a) / del))%Z).
+apply le_IZR; simpl in |- *; left; apply Rle_lt_trans with ((b - a) / del);
+ assumption.
+assert (H5 := IZN _ H4); elim H5; clear H5; intros N H5;
+ unfold Nbound in |- *; exists N; intros; unfold I in H6; 
+ apply INR_le; rewrite H5 in H2; rewrite <- INR_IZR_INZ in H2; 
+ left; apply Rle_lt_trans with ((b - a) / del); try assumption;
+ apply Rmult_le_reg_l with (pos del);
+ [ apply (cond_pos del)
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ del));
+    rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite Rmult_comm; apply Rplus_le_reg_l with a;
+       replace (a + (b - a)) with b; [ left; assumption | ring ]
+    | assert (H7 := cond_pos del); red in |- *; intro; rewrite H8 in H7;
+       elim (Rlt_irrefl _ H7) ] ].
+Qed.
+
+Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) {struct N} : Rlist :=
+  match N with
+  | O => cons y nil
+  | S p => cons x (SubEquiN p (x + del) y del)
+  end.
+
+Definition max_N (a b:R) (del:posreal) (h:a < b) : nat :=
+  match maxN del h with
+  | existT N H0 => N
+  end.
+
+Definition SubEqui (a b:R) (del:posreal) (h:a < b) : Rlist :=
+  SubEquiN (S (max_N del h)) a b del.
+
+Lemma Heine_cor1 :
+ forall (f:R -> R) (a b:R),
+   a < b ->
+   (forall x:R, a <= x <= b -> continuity_pt f x) ->
+   forall eps:posreal,
+     sigT
+       (fun delta:posreal =>
+          delta <= b - a /\
+          (forall x y:R,
+             a <= x <= b ->
+             a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps)).
+intro f; intros;
+ set
+  (E :=
+   fun l:R =>
+     0 < l <= b - a /\
+     (forall x y:R,
+        a <= x <= b ->
+        a <= y <= b -> Rabs (x - y) < l -> Rabs (f x - f y) < eps));
+ assert (H1 : bound E).
+unfold bound in |- *; exists (b - a); unfold is_upper_bound in |- *; intros;
+ unfold E in H1; elim H1; clear H1; intros H1 _; elim H1; 
+ intros; assumption.
+assert (H2 :  exists x : R, E x).
+assert (H2 := Heine f (fun x:R => a <= x <= b) (compact_P3 a b) H0 eps);
+ elim H2; intros; exists (Rmin x (b - a)); unfold E in |- *; 
+ split;
+ [ split;
+    [ unfold Rmin in |- *; case (Rle_dec x (b - a)); intro;
+       [ apply (cond_pos x) | apply Rlt_Rminus; assumption ]
+    | apply Rmin_r ]
+ | intros; apply H3; try assumption; apply Rlt_le_trans with (Rmin x (b - a));
+    [ assumption | apply Rmin_l ] ].
+assert (H3 := completeness E H1 H2); elim H3; intros; cut (0 < x <= b - a).
+intro; elim H4; clear H4; intros; apply existT with (mkposreal _ H4); split.
+apply H5.
+unfold is_lub in p; elim p; intros; unfold is_upper_bound in H6;
+ set (D := Rabs (x0 - y)); elim (classic (exists y : R, D < y /\ E y));
+ intro.
+elim H11; intros; elim H12; clear H12; intros; unfold E in H13; elim H13;
+ intros; apply H15; assumption.
+assert (H12 := not_ex_all_not _ (fun y:R => D < y /\ E y) H11);
+ assert (H13 : is_upper_bound E D).
+unfold is_upper_bound in |- *; intros; assert (H14 := H12 x1);
+ elim (not_and_or (D < x1) (E x1) H14); intro.
+case (Rle_dec x1 D); intro.
+assumption.
+elim H15; auto with real.
+elim H15; assumption.
+assert (H14 := H7 _ H13); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H10)).
+unfold is_lub in p; unfold is_upper_bound in p; elim p; clear p; intros;
+ split.
+elim H2; intros; assert (H7 := H4 _ H6); unfold E in H6; elim H6; clear H6;
+ intros H6 _; elim H6; intros; apply Rlt_le_trans with x0; 
+ assumption.
+apply H5; intros; unfold E in H6; elim H6; clear H6; intros H6 _; elim H6;
+ intros; assumption.
+Qed.
+
+Lemma Heine_cor2 :
+ forall (f:R -> R) (a b:R),
+   (forall x:R, a <= x <= b -> continuity_pt f x) ->
+   forall eps:posreal,
+     sigT
+       (fun delta:posreal =>
+          forall x y:R,
+            a <= x <= b ->
+            a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps).
+intro f; intros; case (total_order_T a b); intro.
+elim s; intro.
+assert (H0 := Heine_cor1 a0 H eps); elim H0; intros; apply existT with x;
+ elim p; intros; apply H2; assumption.
+apply existT with (mkposreal _ Rlt_0_1); intros; assert (H3 : x = y);
+ [ elim H0; elim H1; intros; rewrite b0 in H3; rewrite b0 in H5;
+    apply Rle_antisym; apply Rle_trans with b; assumption
+ | rewrite H3; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    apply (cond_pos eps) ].
+apply existT with (mkposreal _ Rlt_0_1); intros; elim H0; intros;
+ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H3 H4) r)).
+Qed.
+
+Lemma SubEqui_P1 :
+ forall (a b:R) (del:posreal) (h:a < b), pos_Rl (SubEqui del h) 0 = a.
+intros; unfold SubEqui in |- *; case (maxN del h); intros; reflexivity.
+Qed.
+
+Lemma SubEqui_P2 :
+ forall (a b:R) (del:posreal) (h:a < b),
+   pos_Rl (SubEqui del h) (pred (Rlength (SubEqui del h))) = b.
+intros; unfold SubEqui in |- *; case (maxN del h); intros; clear a0;
+ cut
+  (forall (x:nat) (a:R) (del:posreal),
+     pos_Rl (SubEquiN (S x) a b del)
+       (pred (Rlength (SubEquiN (S x) a b del))) = b);
+ [ intro; apply H
+ | simple induction x0;
+    [ intros; reflexivity
+    | intros;
+       change
+         (pos_Rl (SubEquiN (S n) (a0 + del0) b del0)
+            (pred (Rlength (SubEquiN (S n) (a0 + del0) b del0))) = b) 
+        in |- *; apply H ] ].
+Qed.
+
+Lemma SubEqui_P3 :
+ forall (N:nat) (a b:R) (del:posreal), Rlength (SubEquiN N a b del) = S N.
+simple induction N; intros;
+ [ reflexivity | simpl in |- *; rewrite H; reflexivity ].
+Qed.
+
+Lemma SubEqui_P4 :
+ forall (N:nat) (a b:R) (del:posreal) (i:nat),
+   (i < S N)%nat -> pos_Rl (SubEquiN (S N) a b del) i = a + INR i * del.
+simple induction N;
+ [ intros; inversion H; [ simpl in |- *; ring | elim (le_Sn_O _ H1) ]
+ | intros; induction  i as [| i Hreci];
+    [ simpl in |- *; ring
+    | change
+        (pos_Rl (SubEquiN (S n) (a + del) b del) i = a + INR (S i) * del)
+       in |- *; rewrite H; [ rewrite S_INR; ring | apply lt_S_n; apply H0 ] ] ].
+Qed.
+
+Lemma SubEqui_P5 :
+ forall (a b:R) (del:posreal) (h:a < b),
+   Rlength (SubEqui del h) = S (S (max_N del h)).
+intros; unfold SubEqui in |- *; apply SubEqui_P3.
+Qed.
+
+Lemma SubEqui_P6 :
+ forall (a b:R) (del:posreal) (h:a < b) (i:nat),
+   (i < S (max_N del h))%nat -> pos_Rl (SubEqui del h) i = a + INR i * del.
+intros; unfold SubEqui in |- *; apply SubEqui_P4; assumption.
+Qed.
+
+Lemma SubEqui_P7 :
+ forall (a b:R) (del:posreal) (h:a < b), ordered_Rlist (SubEqui del h).
+intros; unfold ordered_Rlist in |- *; intros; rewrite SubEqui_P5 in H;
+ simpl in H; inversion H.
+rewrite (SubEqui_P6 del h (i:=(max_N del h))).
+replace (S (max_N del h)) with (pred (Rlength (SubEqui del h))).
+rewrite SubEqui_P2; unfold max_N in |- *; case (maxN del h); intros; left;
+ elim a0; intros; assumption.
+rewrite SubEqui_P5; reflexivity.
+apply lt_n_Sn.
+repeat rewrite SubEqui_P6.
+3: assumption.
+2: apply le_lt_n_Sm; assumption.
+apply Rplus_le_compat_l; rewrite S_INR; rewrite Rmult_plus_distr_r;
+ pattern (INR i * del) at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_le_compat_l; rewrite Rmult_1_l; left; 
+ apply (cond_pos del).
+Qed.
+
+Lemma SubEqui_P8 :
+ forall (a b:R) (del:posreal) (h:a < b) (i:nat),
+   (i < Rlength (SubEqui del h))%nat -> a <= pos_Rl (SubEqui del h) i <= b.
+intros; split.
+pattern a at 1 in |- *; rewrite <- (SubEqui_P1 del h); apply RList_P5.
+apply SubEqui_P7.
+elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); intros; apply H1;
+ exists i; split; [ reflexivity | assumption ].
+pattern b at 2 in |- *; rewrite <- (SubEqui_P2 del h); apply RList_P7;
+ [ apply SubEqui_P7
+ | elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); intros;
+    apply H1; exists i; split; [ reflexivity | assumption ] ].
+Qed.
+
+Lemma SubEqui_P9 :
+ forall (a b:R) (del:posreal) (f:R -> R) (h:a < b),
+   sigT
+     (fun g:StepFun a b =>
+        g b = f b /\
+        (forall i:nat,
+           (i < pred (Rlength (SubEqui del h)))%nat ->
+           constant_D_eq g
+             (co_interval (pos_Rl (SubEqui del h) i)
+                (pos_Rl (SubEqui del h) (S i)))
+             (f (pos_Rl (SubEqui del h) i)))).
+intros; apply StepFun_P38;
+ [ apply SubEqui_P7 | apply SubEqui_P1 | apply SubEqui_P2 ].
+Qed.
+
+Lemma RiemannInt_P6 :
+ forall (f:R -> R) (a b:R),
+   a < b ->
+   (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b.
+intros; unfold Riemann_integrable in |- *; intro;
+ assert (H1 : 0 < eps / (2 * (b - a))).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos eps)
+ | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
+    [ prove_sup0 | apply Rlt_Rminus; assumption ] ].
+assert (H2 : Rmin a b = a).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; left; assumption ].
+assert (H3 : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; left; assumption ].
+elim (Heine_cor2 H0 (mkposreal _ H1)); intros del H4;
+ elim (SubEqui_P9 del f H); intros phi [H5 H6]; split with phi;
+ split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a))))); 
+ split.
+2: rewrite StepFun_P18; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+2: do 2 rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+2: rewrite Rmult_1_r; rewrite Rabs_right.
+2: apply Rmult_lt_reg_l with 2.
+2: prove_sup0.
+2: rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+2: rewrite Rmult_1_l; pattern (pos eps) at 1 in |- *; rewrite <- Rplus_0_r;
+    rewrite double; apply Rplus_lt_compat_l; apply (cond_pos eps).
+2: discrR.
+2: apply Rle_ge; left; apply Rmult_lt_0_compat.
+2: apply (cond_pos eps).
+2: apply Rinv_0_lt_compat; prove_sup0.
+2: apply Rminus_eq_contra; red in |- *; intro; clear H6; rewrite H7 in H;
+    elim (Rlt_irrefl _ H).
+2: discrR.
+2: apply Rminus_eq_contra; red in |- *; intro; clear H6; rewrite H7 in H;
+    elim (Rlt_irrefl _ H).
+intros; rewrite H2 in H7; rewrite H3 in H7; simpl in |- *;
+ unfold fct_cte in |- *;
+ cut
+  (forall t:R,
+     a <= t <= b ->
+     t = b \/
+     (exists i : nat,
+        (i < pred (Rlength (SubEqui del H)))%nat /\
+        co_interval (pos_Rl (SubEqui del H) i) (pos_Rl (SubEqui del H) (S i))
+          t)).
+intro; elim (H8 _ H7); intro.
+rewrite H9; rewrite H5; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rabs_R0; left; assumption.
+elim H9; clear H9; intros I [H9 H10]; assert (H11 := H6 I H9 t H10);
+ rewrite H11; left; apply H4.
+assumption.
+apply SubEqui_P8; apply lt_trans with (pred (Rlength (SubEqui del H))).
+assumption.
+apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H9;
+ elim (lt_n_O _ H9).
+unfold co_interval in H10; elim H10; clear H10; intros; rewrite Rabs_right.
+rewrite SubEqui_P5 in H9; simpl in H9; inversion H9.
+apply Rplus_lt_reg_r with (pos_Rl (SubEqui del H) (max_N del H)).
+replace
+ (pos_Rl (SubEqui del H) (max_N del H) +
+  (t - pos_Rl (SubEqui del H) (max_N del H))) with t; 
+ [ idtac | ring ]; apply Rlt_le_trans with b.
+rewrite H14 in H12;
+ assert (H13 : S (max_N del H) = pred (Rlength (SubEqui del H))).
+rewrite SubEqui_P5; reflexivity.
+rewrite H13 in H12; rewrite SubEqui_P2 in H12; apply H12.
+rewrite SubEqui_P6.
+2: apply lt_n_Sn.
+unfold max_N in |- *; case (maxN del H); intros; elim a0; clear a0;
+ intros _ H13; replace (a + INR x * del + del) with (a + INR (S x) * del);
+ [ assumption | rewrite S_INR; ring ].
+apply Rplus_lt_reg_r with (pos_Rl (SubEqui del H) I);
+ replace (pos_Rl (SubEqui del H) I + (t - pos_Rl (SubEqui del H) I)) with t;
+ [ idtac | ring ];
+ replace (pos_Rl (SubEqui del H) I + del) with (pos_Rl (SubEqui del H) (S I)).
+assumption.
+repeat rewrite SubEqui_P6.
+rewrite S_INR; ring.
+assumption.
+apply le_lt_n_Sm; assumption.
+apply Rge_minus; apply Rle_ge; assumption.
+intros; clear H0 H1 H4 phi H5 H6 t H7; case (Req_dec t0 b); intro.
+left; assumption.
+right; set (I := fun j:nat => a + INR j * del <= t0);
+ assert (H1 :  exists n : nat, I n).
+exists 0%nat; unfold I in |- *; rewrite Rmult_0_l; rewrite Rplus_0_r; elim H8;
+ intros; assumption.
+assert (H4 : Nbound I).
+unfold Nbound in |- *; exists (S (max_N del H)); intros; unfold max_N in |- *;
+ case (maxN del H); intros; elim a0; clear a0; intros _ H5; 
+ apply INR_le; apply Rmult_le_reg_l with (pos del).
+apply (cond_pos del).
+apply Rplus_le_reg_l with a; do 2 rewrite (Rmult_comm del);
+ apply Rle_trans with t0; unfold I in H4; try assumption;
+ apply Rle_trans with b; try assumption; elim H8; intros; 
+ assumption.
+elim (Nzorn H1 H4); intros N [H5 H6]; assert (H7 : (N < S (max_N del H))%nat).
+unfold max_N in |- *; case (maxN del H); intros; apply INR_lt;
+ apply Rmult_lt_reg_l with (pos del).
+apply (cond_pos del).
+apply Rplus_lt_reg_r with a; do 2 rewrite (Rmult_comm del);
+ apply Rle_lt_trans with t0; unfold I in H5; try assumption; 
+ elim a0; intros; apply Rlt_le_trans with b; try assumption; 
+ elim H8; intros.
+elim H11; intro.
+assumption.
+elim H0; assumption.
+exists N; split.
+rewrite SubEqui_P5; simpl in |- *; assumption.
+unfold co_interval in |- *; split.
+rewrite SubEqui_P6.
+apply H5.
+assumption.
+inversion H7.
+replace (S (max_N del H)) with (pred (Rlength (SubEqui del H))).
+rewrite (SubEqui_P2 del H); elim H8; intros.
+elim H11; intro.
+assumption.
+elim H0; assumption.
+rewrite SubEqui_P5; reflexivity.
+rewrite SubEqui_P6.
+case (Rle_dec (a + INR (S N) * del) t0); intro.
+assert (H11 := H6 (S N) r); elim (le_Sn_n _ H11).
+auto with real.
+apply le_lt_n_Sm; assumption.
+Qed.
+
+Lemma RiemannInt_P7 : forall (f:R -> R) (a:R), Riemann_integrable f a a.
+unfold Riemann_integrable in |- *; intro f; intros;
+ split with (mkStepFun (StepFun_P4 a a (f a)));
+ split with (mkStepFun (StepFun_P4 a a 0)); split.
+intros; simpl in |- *; unfold fct_cte in |- *; replace t with a.
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; right;
+ reflexivity.
+generalize H; unfold Rmin, Rmax in |- *; case (Rle_dec a a); intros; elim H0;
+ intros; apply Rle_antisym; assumption.
+rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; apply (cond_pos eps).
+Qed.
+
+Lemma continuity_implies_RiemannInt :
+ forall (f:R -> R) (a b:R),
+   a <= b ->
+   (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b.
+intros; case (total_order_T a b); intro;
+ [ elim s; intro;
+    [ apply RiemannInt_P6; assumption | rewrite b0; apply RiemannInt_P7 ]
+ | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)) ].
+Qed.
+
+Lemma RiemannInt_P8 :
+ forall (f:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
+   (pr2:Riemann_integrable f b a), RiemannInt pr1 = - RiemannInt pr2.
+intro f; intros; eapply UL_sequence.
+unfold RiemannInt in |- *; case (RiemannInt_exists pr1 RinvN RinvN_cv);
+ intros; apply u.
+unfold RiemannInt in |- *; case (RiemannInt_exists pr2 RinvN RinvN_cv);
+ intros;
+ cut
+  (exists psi1 : nat -> StepFun a b,
+     (forall n:nat,
+        (forall t:R,
+           Rmin a b <= t /\ t <= Rmax a b ->
+           Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\
+        Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
+cut
+ (exists psi2 : nat -> StepFun b a,
+    (forall n:nat,
+       (forall t:R,
+          Rmin a b <= t /\ t <= Rmax a b ->
+          Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\
+       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+intros; elim H; clear H; intros psi2 H; elim H0; clear H0; intros psi1 H0;
+ assert (H1 := RinvN_cv); unfold Un_cv in |- *; intros;
+ assert (H3 : 0 < eps / 3).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+unfold Un_cv in H1; elim (H1 _ H3); clear H1; intros N0 H1;
+ unfold R_dist in H1; simpl in H1;
+ assert (H4 : forall n:nat, (n >= N0)%nat -> RinvN n < eps / 3).
+intros; assert (H5 := H1 _ H4);
+ replace (pos (RinvN n)) with (Rabs (/ (INR n + 1) - 0));
+ [ assumption
+ | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+    left; apply (cond_pos (RinvN n)) ].
+clear H1; unfold Un_cv in u; elim (u _ H3); clear u; intros N1 H1;
+ exists (max N0 N1); intros; unfold R_dist in |- *;
+ apply Rle_lt_trans with
+  (Rabs
+     (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+      RiemannInt_SF (phi_sequence RinvN pr2 n)) +
+   Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)).
+rewrite <- (Rabs_Ropp (RiemannInt_SF (phi_sequence RinvN pr2 n) - x));
+ replace (RiemannInt_SF (phi_sequence RinvN pr1 n) - - x) with
+  (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+   RiemannInt_SF (phi_sequence RinvN pr2 n) +
+   - (RiemannInt_SF (phi_sequence RinvN pr2 n) - x));
+ [ apply Rabs_triang | ring ].
+replace eps with (2 * (eps / 3) + eps / 3).
+apply Rplus_lt_compat.
+rewrite (StepFun_P39 (phi_sequence RinvN pr2 n));
+ replace
+  (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+   - RiemannInt_SF (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))))
+  with
+  (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+   -1 *
+   RiemannInt_SF (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))));
+ [ idtac | ring ]; rewrite <- StepFun_P30.
+case (Rle_dec a b); intro.
+apply Rle_lt_trans with
+ (RiemannInt_SF
+    (mkStepFun
+       (StepFun_P32
+          (mkStepFun
+             (StepFun_P28 (-1) (phi_sequence RinvN pr1 n)
+                (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n))))))))).
+apply StepFun_P34; assumption.
+apply Rle_lt_trans with
+ (RiemannInt_SF
+    (mkStepFun
+       (StepFun_P28 1 (psi1 n) (mkStepFun (StepFun_P6 (pre (psi2 n))))))).
+apply StepFun_P37; try assumption.
+intros; simpl in |- *; rewrite Rmult_1_l;
+ apply Rle_trans with
+  (Rabs (phi_sequence RinvN pr1 n x0 - f x0) +
+   Rabs (f x0 - phi_sequence RinvN pr2 n x0)).
+replace (phi_sequence RinvN pr1 n x0 + -1 * phi_sequence RinvN pr2 n x0) with
+ (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0));
+ [ apply Rabs_triang | ring ].
+assert (H7 : Rmin a b = a).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+assert (H8 : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+apply Rplus_le_compat.
+elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9;
+ rewrite H7; rewrite H8.
+elim H6; intros; split; left; assumption.
+elim (H n); intros; apply H9; rewrite H7; rewrite H8.
+elim H6; intros; split; left; assumption.
+rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
+elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n)));
+ [ apply RRle_abs
+ | apply Rlt_trans with (pos (RinvN n));
+    [ assumption
+    | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+       [ apply le_max_l | assumption ] ] ].
+elim (H n); intros;
+ rewrite <-
+  (Ropp_involutive (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (psi2 n))))))
+  ; rewrite <- StepFun_P39;
+ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n)));
+ [ rewrite <- Rabs_Ropp; apply RRle_abs
+ | apply Rlt_trans with (pos (RinvN n));
+    [ assumption
+    | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+       [ apply le_max_l | assumption ] ] ].
+assert (Hyp : b <= a).
+auto with real.
+rewrite StepFun_P39; rewrite Rabs_Ropp;
+ apply Rle_lt_trans with
+  (RiemannInt_SF
+     (mkStepFun
+        (StepFun_P32
+           (mkStepFun
+              (StepFun_P6
+                 (StepFun_P28 (-1) (phi_sequence RinvN pr1 n)
+                    (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))))))))).
+apply StepFun_P34; assumption.
+apply Rle_lt_trans with
+ (RiemannInt_SF
+    (mkStepFun
+       (StepFun_P28 1 (mkStepFun (StepFun_P6 (pre (psi1 n)))) (psi2 n)))).
+apply StepFun_P37; try assumption.
+intros; simpl in |- *; rewrite Rmult_1_l;
+ apply Rle_trans with
+  (Rabs (phi_sequence RinvN pr1 n x0 - f x0) +
+   Rabs (f x0 - phi_sequence RinvN pr2 n x0)).
+replace (phi_sequence RinvN pr1 n x0 + -1 * phi_sequence RinvN pr2 n x0) with
+ (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0));
+ [ apply Rabs_triang | ring ].
+assert (H7 : Rmin a b = b).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ elim n0; assumption | reflexivity ].
+assert (H8 : Rmax a b = a).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ elim n0; assumption | reflexivity ].
+apply Rplus_le_compat.
+elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9;
+ rewrite H7; rewrite H8.
+elim H6; intros; split; left; assumption.
+elim (H n); intros; apply H9; rewrite H7; rewrite H8; elim H6; intros; split;
+ left; assumption.
+rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
+elim (H0 n); intros;
+ rewrite <-
+  (Ropp_involutive (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (psi1 n))))))
+  ; rewrite <- StepFun_P39;
+ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n)));
+ [ rewrite <- Rabs_Ropp; apply RRle_abs
+ | apply Rlt_trans with (pos (RinvN n));
+    [ assumption
+    | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+       [ apply le_max_l | assumption ] ] ].
+elim (H n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n)));
+ [ apply RRle_abs
+ | apply Rlt_trans with (pos (RinvN n));
+    [ assumption
+    | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+       [ apply le_max_l | assumption ] ] ].
+unfold R_dist in H1; apply H1; unfold ge in |- *;
+ apply le_trans with (max N0 N1); [ apply le_max_r | assumption ].
+apply Rmult_eq_reg_l with 3;
+ [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym; [ ring | discrR ]
+ | discrR ].
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
+ rewrite Rmin_comm; rewrite RmaxSym;
+ apply (projT2 (phi_sequence_prop RinvN pr2 n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr1 n)).
+Qed.
+
+Lemma RiemannInt_P9 :
+ forall (f:R -> R) (a:R) (pr:Riemann_integrable f a a), RiemannInt pr = 0.
+intros; assert (H := RiemannInt_P8 pr pr); apply Rmult_eq_reg_l with 2;
+ [ rewrite Rmult_0_r; rewrite double; pattern (RiemannInt pr) at 2 in |- *;
+    rewrite H; apply Rplus_opp_r
+ | discrR ].
+Qed.
+
+Lemma Req_EM_T : forall r1 r2:R, {r1 = r2} + {r1 <> r2}.
+intros; elim (total_order_T r1 r2); intros;
+ [ elim a; intro;
+    [ right; red in |- *; intro; rewrite H in a0; elim (Rlt_irrefl r2 a0)
+    | left; assumption ]
+ | right; red in |- *; intro; rewrite H in b; elim (Rlt_irrefl r2 b) ].
+Qed.
+
+(* L1([a,b]) is a vectorial space *)
+Lemma RiemannInt_P10 :
+ forall (f g:R -> R) (a b l:R),
+   Riemann_integrable f a b ->
+   Riemann_integrable g a b ->
+   Riemann_integrable (fun x:R => f x + l * g x) a b.
+unfold Riemann_integrable in |- *; intros f g; intros; case (Req_EM_T l 0);
+ intro.
+elim (X eps); intros; split with x; elim p; intros; split with x0; elim p0;
+ intros; split; try assumption; rewrite e; intros; 
+ rewrite Rmult_0_l; rewrite Rplus_0_r; apply H; assumption.
+assert (H : 0 < eps / 2).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
+assert (H0 : 0 < eps / (2 * Rabs l)).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos eps)
+ | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
+    [ prove_sup0 | apply Rabs_pos_lt; assumption ] ].
+elim (X (mkposreal _ H)); intros; elim (X0 (mkposreal _ H0)); intros;
+ split with (mkStepFun (StepFun_P28 l x x0)); elim p0; 
+ elim p; intros; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2)); 
+ elim p1; elim p2; clear p1 p2 p0 p X X0; intros; split.
+intros; simpl in |- *;
+ apply Rle_trans with (Rabs (f t - x t) + Rabs (l * (g t - x0 t))).
+replace (f t + l * g t - (x t + l * x0 t)) with
+ (f t - x t + l * (g t - x0 t)); [ apply Rabs_triang | ring ].
+apply Rplus_le_compat;
+ [ apply H3; assumption
+ | rewrite Rabs_mult; apply Rmult_le_compat_l;
+    [ apply Rabs_pos | apply H1; assumption ] ].
+rewrite StepFun_P30;
+ apply Rle_lt_trans with
+  (Rabs (RiemannInt_SF x1) + Rabs (Rabs l * RiemannInt_SF x2)).
+apply Rabs_triang.
+rewrite (double_var eps); apply Rplus_lt_compat.
+apply H4.
+rewrite Rabs_mult; rewrite Rabs_Rabsolu; apply Rmult_lt_reg_l with (/ Rabs l).
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym;
+ [ rewrite Rmult_1_l;
+    replace (/ Rabs l * (eps / 2)) with (eps / (2 * Rabs l));
+    [ apply H2
+    | unfold Rdiv in |- *; rewrite Rinv_mult_distr;
+       [ ring | discrR | apply Rabs_no_R0; assumption ] ]
+ | apply Rabs_no_R0; assumption ].
+Qed.
+
+Lemma RiemannInt_P11 :
+ forall (f:R -> R) (a b l:R) (un:nat -> posreal)
+   (phi1 phi2 psi1 psi2:nat -> StepFun a b),
+   Un_cv un 0 ->
+   (forall n:nat,
+      (forall t:R,
+         Rmin a b <= t <= Rmax a b -> Rabs (f t - phi1 n t) <= psi1 n t) /\
+      Rabs (RiemannInt_SF (psi1 n)) < un n) ->
+   (forall n:nat,
+      (forall t:R,
+         Rmin a b <= t <= Rmax a b -> Rabs (f t - phi2 n t) <= psi2 n t) /\
+      Rabs (RiemannInt_SF (psi2 n)) < un n) ->
+   Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) l ->
+   Un_cv (fun N:nat => RiemannInt_SF (phi2 N)) l.
+unfold Un_cv in |- *; intro f; intros; intros.
+case (Rle_dec a b); intro Hyp.
+assert (H4 : 0 < eps / 3).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (H _ H4); clear H; intros N0 H.
+elim (H2 _ H4); clear H2; intros N1 H2.
+set (N := max N0 N1); exists N; intros; unfold R_dist in |- *.
+apply Rle_lt_trans with
+ (Rabs (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) +
+  Rabs (RiemannInt_SF (phi1 n) - l)).
+replace (RiemannInt_SF (phi2 n) - l) with
+ (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n) +
+  (RiemannInt_SF (phi1 n) - l)); [ apply Rabs_triang | ring ].
+replace eps with (2 * (eps / 3) + eps / 3).
+apply Rplus_lt_compat.
+replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with
+ (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); 
+ [ idtac | ring ].
+rewrite <- StepFun_P30.
+apply Rle_lt_trans with
+ (RiemannInt_SF
+    (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (phi2 n) (phi1 n)))))).
+apply StepFun_P34; assumption.
+apply Rle_lt_trans with
+ (RiemannInt_SF (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n)))).
+apply StepFun_P37; try assumption; intros; simpl in |- *; rewrite Rmult_1_l.
+apply Rle_trans with (Rabs (phi2 n x - f x) + Rabs (f x - phi1 n x)).
+replace (phi2 n x + -1 * phi1 n x) with (phi2 n x - f x + (f x - phi1 n x));
+ [ apply Rabs_triang | ring ].
+rewrite (Rplus_comm (psi1 n x)); apply Rplus_le_compat.
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim (H1 n); intros; apply H7.
+assert (H10 : Rmin a b = a).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+assert (H11 : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
+elim (H0 n); intros; apply H7; assert (H10 : Rmin a b = a).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+assert (H11 : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
+rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
+apply Rlt_trans with (pos (un n)).
+elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))).
+apply RRle_abs.
+assumption.
+replace (pos (un n)) with (R_dist (un n) 0).
+apply H; unfold ge in |- *; apply le_trans with N; try assumption.
+unfold N in |- *; apply le_max_l.
+unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; apply Rabs_right.
+apply Rle_ge; left; apply (cond_pos (un n)).
+apply Rlt_trans with (pos (un n)).
+elim (H1 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))).
+apply RRle_abs; assumption.
+assumption.
+replace (pos (un n)) with (R_dist (un n) 0).
+apply H; unfold ge in |- *; apply le_trans with N; try assumption;
+ unfold N in |- *; apply le_max_l.
+unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+ left; apply (cond_pos (un n)).
+unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N;
+ try assumption; unfold N in |- *; apply le_max_r.
+apply Rmult_eq_reg_l with 3;
+ [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym; [ ring | discrR ]
+ | discrR ].
+assert (H4 : 0 < eps / 3).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (H _ H4); clear H; intros N0 H.
+elim (H2 _ H4); clear H2; intros N1 H2.
+set (N := max N0 N1); exists N; intros; unfold R_dist in |- *.
+apply Rle_lt_trans with
+ (Rabs (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) +
+  Rabs (RiemannInt_SF (phi1 n) - l)).
+replace (RiemannInt_SF (phi2 n) - l) with
+ (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n) +
+  (RiemannInt_SF (phi1 n) - l)); [ apply Rabs_triang | ring ].
+assert (Hyp_b : b <= a).
+auto with real.
+replace eps with (2 * (eps / 3) + eps / 3).
+apply Rplus_lt_compat.
+replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with
+ (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); 
+ [ idtac | ring ].
+rewrite <- StepFun_P30.
+rewrite StepFun_P39.
+rewrite Rabs_Ropp.
+apply Rle_lt_trans with
+ (RiemannInt_SF
+    (mkStepFun
+       (StepFun_P32
+          (mkStepFun
+             (StepFun_P6
+                (pre (mkStepFun (StepFun_P28 (-1) (phi2 n) (phi1 n))))))))).
+apply StepFun_P34; try assumption.
+apply Rle_lt_trans with
+ (RiemannInt_SF
+    (mkStepFun
+       (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n))))))).
+apply StepFun_P37; try assumption.
+intros; simpl in |- *; rewrite Rmult_1_l.
+apply Rle_trans with (Rabs (phi2 n x - f x) + Rabs (f x - phi1 n x)).
+replace (phi2 n x + -1 * phi1 n x) with (phi2 n x - f x + (f x - phi1 n x));
+ [ apply Rabs_triang | ring ].
+rewrite (Rplus_comm (psi1 n x)); apply Rplus_le_compat.
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim (H1 n); intros; apply H7.
+assert (H10 : Rmin a b = b).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ elim Hyp; assumption | reflexivity ].
+assert (H11 : Rmax a b = a).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ elim Hyp; assumption | reflexivity ].
+rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
+elim (H0 n); intros; apply H7; assert (H10 : Rmin a b = b).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ elim Hyp; assumption | reflexivity ].
+assert (H11 : Rmax a b = a).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ elim Hyp; assumption | reflexivity ].
+rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
+rewrite <-
+ (Ropp_involutive
+    (RiemannInt_SF
+       (mkStepFun
+          (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n))))))))
+ .
+rewrite <- StepFun_P39.
+rewrite StepFun_P30.
+rewrite Rmult_1_l; rewrite double.
+rewrite Ropp_plus_distr; apply Rplus_lt_compat.
+apply Rlt_trans with (pos (un n)).
+elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))).
+rewrite <- Rabs_Ropp; apply RRle_abs.
+assumption.
+replace (pos (un n)) with (R_dist (un n) 0).
+apply H; unfold ge in |- *; apply le_trans with N; try assumption.
+unfold N in |- *; apply le_max_l.
+unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; apply Rabs_right.
+apply Rle_ge; left; apply (cond_pos (un n)).
+apply Rlt_trans with (pos (un n)).
+elim (H1 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))).
+rewrite <- Rabs_Ropp; apply RRle_abs; assumption.
+assumption.
+replace (pos (un n)) with (R_dist (un n) 0).
+apply H; unfold ge in |- *; apply le_trans with N; try assumption;
+ unfold N in |- *; apply le_max_l.
+unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+ left; apply (cond_pos (un n)).
+unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N;
+ try assumption; unfold N in |- *; apply le_max_r.
+apply Rmult_eq_reg_l with 3;
+ [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym; [ ring | discrR ]
+ | discrR ].
+Qed.
+
+Lemma RiemannInt_P12 :
+ forall (f g:R -> R) (a b l:R) (pr1:Riemann_integrable f a b)
+   (pr2:Riemann_integrable g a b)
+   (pr3:Riemann_integrable (fun x:R => f x + l * g x) a b),
+   a <= b -> RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2.
+intro f; intros; case (Req_dec l 0); intro.
+pattern l at 2 in |- *; rewrite H0; rewrite Rmult_0_l; rewrite Rplus_0_r;
+ unfold RiemannInt in |- *; case (RiemannInt_exists pr3 RinvN RinvN_cv);
+ case (RiemannInt_exists pr1 RinvN RinvN_cv); intros; 
+ eapply UL_sequence;
+ [ apply u0
+ | set (psi1 := fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n));
+    set (psi2 := fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n));
+    apply RiemannInt_P11 with f RinvN (phi_sequence RinvN pr1) psi1 psi2;
+    [ apply RinvN_cv
+    | intro; apply (projT2 (phi_sequence_prop RinvN pr1 n))
+    | intro;
+       assert
+        (H1 :
+         (forall t:R,
+            Rmin a b <= t /\ t <= Rmax a b ->
+            Rabs (f t + l * g t - phi_sequence RinvN pr3 n t) <= psi2 n t) /\
+         Rabs (RiemannInt_SF (psi2 n)) < RinvN n);
+       [ apply (projT2 (phi_sequence_prop RinvN pr3 n))
+       | elim H1; intros; split; try assumption; intros;
+          replace (f t) with (f t + l * g t);
+          [ apply H2; assumption | rewrite H0; ring ] ]
+    | assumption ] ].
+eapply UL_sequence.
+unfold RiemannInt in |- *; case (RiemannInt_exists pr3 RinvN RinvN_cv);
+ intros; apply u.
+unfold Un_cv in |- *; intros; unfold RiemannInt in |- *;
+ case (RiemannInt_exists pr1 RinvN RinvN_cv);
+ case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv in |- *; 
+ intros; assert (H2 : 0 < eps / 5).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (u0 _ H2); clear u0; intros N0 H3; assert (H4 := RinvN_cv);
+ unfold Un_cv in H4; elim (H4 _ H2); clear H4 H2; intros N1 H4;
+ assert (H5 : 0 < eps / (5 * Rabs l)). 
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption
+ | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
+    [ prove_sup0 | apply Rabs_pos_lt; assumption ] ].
+elim (u _ H5); clear u; intros N2 H6; assert (H7 := RinvN_cv);
+ unfold Un_cv in H7; elim (H7 _ H5); clear H7 H5; intros N3 H5;
+ unfold R_dist in H3, H4, H5, H6; set (N := max (max N0 N1) (max N2 N3)).
+assert (H7 : forall n:nat, (n >= N1)%nat -> RinvN n < eps / 5).
+intros; replace (pos (RinvN n)) with (Rabs (RinvN n - 0));
+ [ unfold RinvN in |- *; apply H4; assumption
+ | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+    left; apply (cond_pos (RinvN n)) ].
+clear H4; assert (H4 := H7); clear H7;
+ assert (H7 : forall n:nat, (n >= N3)%nat -> RinvN n < eps / (5 * Rabs l)).
+intros; replace (pos (RinvN n)) with (Rabs (RinvN n - 0));
+ [ unfold RinvN in |- *; apply H5; assumption
+ | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+    left; apply (cond_pos (RinvN n)) ].
+clear H5; assert (H5 := H7); clear H7; exists N; intros;
+ unfold R_dist in |- *.
+apply Rle_lt_trans with
+ (Rabs
+    (RiemannInt_SF (phi_sequence RinvN pr3 n) -
+     (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+      l * RiemannInt_SF (phi_sequence RinvN pr2 n))) +
+  Rabs (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0) +
+  Rabs l * Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)).
+apply Rle_trans with
+ (Rabs
+    (RiemannInt_SF (phi_sequence RinvN pr3 n) -
+     (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+      l * RiemannInt_SF (phi_sequence RinvN pr2 n))) +
+  Rabs
+    (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
+     l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x))).
+replace (RiemannInt_SF (phi_sequence RinvN pr3 n) - (x0 + l * x)) with
+ (RiemannInt_SF (phi_sequence RinvN pr3 n) -
+  (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+   l * RiemannInt_SF (phi_sequence RinvN pr2 n)) +
+  (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
+   l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)));
+ [ apply Rabs_triang | ring ].
+rewrite Rplus_assoc; apply Rplus_le_compat_l; rewrite <- Rabs_mult;
+ replace
+  (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
+   l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)) with
+  (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
+   l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x));
+ [ apply Rabs_triang | ring ].
+replace eps with (3 * (eps / 5) + eps / 5 + eps / 5).
+repeat apply Rplus_lt_compat.
+assert
+ (H7 :
+   exists psi1 : nat -> StepFun a b,
+    (forall n:nat,
+       (forall t:R,
+          Rmin a b <= t /\ t <= Rmax a b ->
+          Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\
+       Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr1 n0)).
+assert
+ (H8 :
+   exists psi2 : nat -> StepFun a b,
+    (forall n:nat,
+       (forall t:R,
+          Rmin a b <= t /\ t <= Rmax a b ->
+          Rabs (g t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\
+       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr2 n0)).
+assert
+ (H9 :
+   exists psi3 : nat -> StepFun a b,
+    (forall n:nat,
+       (forall t:R,
+          Rmin a b <= t /\ t <= Rmax a b ->
+          Rabs (f t + l * g t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\
+       Rabs (RiemannInt_SF (psi3 n)) < RinvN n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr3 n0)).
+elim H7; clear H7; intros psi1 H7; elim H8; clear H8; intros psi2 H8; elim H9;
+ clear H9; intros psi3 H9;
+ replace
+  (RiemannInt_SF (phi_sequence RinvN pr3 n) -
+   (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+    l * RiemannInt_SF (phi_sequence RinvN pr2 n))) with
+  (RiemannInt_SF (phi_sequence RinvN pr3 n) +
+   -1 *
+   (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+    l * RiemannInt_SF (phi_sequence RinvN pr2 n))); 
+ [ idtac | ring ]; do 2 rewrite <- StepFun_P30; assert (H10 : Rmin a b = a).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+assert (H11 : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+rewrite H10 in H7; rewrite H10 in H8; rewrite H10 in H9; rewrite H11 in H7;
+ rewrite H11 in H8; rewrite H11 in H9;
+ apply Rle_lt_trans with
+  (RiemannInt_SF
+     (mkStepFun
+        (StepFun_P32
+           (mkStepFun
+              (StepFun_P28 (-1) (phi_sequence RinvN pr3 n)
+                 (mkStepFun
+                    (StepFun_P28 l (phi_sequence RinvN pr1 n)
+                       (phi_sequence RinvN pr2 n)))))))).
+apply StepFun_P34; assumption.
+apply Rle_lt_trans with
+ (RiemannInt_SF
+    (mkStepFun
+       (StepFun_P28 1 (psi3 n)
+          (mkStepFun (StepFun_P28 (Rabs l) (psi1 n) (psi2 n)))))).
+apply StepFun_P37; try assumption.
+intros; simpl in |- *; rewrite Rmult_1_l.
+apply Rle_trans with
+ (Rabs (phi_sequence RinvN pr3 n x1 - (f x1 + l * g x1)) +
+  Rabs
+    (f x1 + l * g x1 +
+     -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1))).
+replace
+ (phi_sequence RinvN pr3 n x1 +
+  -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1)) with
+ (phi_sequence RinvN pr3 n x1 - (f x1 + l * g x1) +
+  (f x1 + l * g x1 +
+   -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1)));
+ [ apply Rabs_triang | ring ].
+rewrite Rplus_assoc; apply Rplus_le_compat.
+elim (H9 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr;
+ apply H13.
+elim H12; intros; split; left; assumption. 
+apply Rle_trans with
+ (Rabs (f x1 - phi_sequence RinvN pr1 n x1) +
+  Rabs l * Rabs (g x1 - phi_sequence RinvN pr2 n x1)).
+rewrite <- Rabs_mult;
+ replace
+  (f x1 +
+   (l * g x1 +
+    -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1)))
+  with
+  (f x1 - phi_sequence RinvN pr1 n x1 +
+   l * (g x1 - phi_sequence RinvN pr2 n x1)); [ apply Rabs_triang | ring ].
+apply Rplus_le_compat.
+elim (H7 n); intros; apply H13.
+elim H12; intros; split; left; assumption.
+apply Rmult_le_compat_l;
+ [ apply Rabs_pos
+ | elim (H8 n); intros; apply H13; elim H12; intros; split; left; assumption ].
+do 2 rewrite StepFun_P30; rewrite Rmult_1_l;
+ replace (3 * (eps / 5)) with (eps / 5 + (eps / 5 + eps / 5));
+ [ repeat apply Rplus_lt_compat | ring ].
+apply Rlt_trans with (pos (RinvN n));
+ [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi3 n)));
+    [ apply RRle_abs | elim (H9 n); intros; assumption ]
+ | apply H4; unfold ge in |- *; apply le_trans with N;
+    [ apply le_trans with (max N0 N1);
+       [ apply le_max_r | unfold N in |- *; apply le_max_l ]
+    | assumption ] ].
+apply Rlt_trans with (pos (RinvN n));
+ [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n)));
+    [ apply RRle_abs | elim (H7 n); intros; assumption ]
+ | apply H4; unfold ge in |- *; apply le_trans with N;
+    [ apply le_trans with (max N0 N1);
+       [ apply le_max_r | unfold N in |- *; apply le_max_l ]
+    | assumption ] ].
+apply Rmult_lt_reg_l with (/ Rabs l).
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; replace (/ Rabs l * (eps / 5)) with (eps / (5 * Rabs l)).
+apply Rlt_trans with (pos (RinvN n));
+ [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n)));
+    [ apply RRle_abs | elim (H8 n); intros; assumption ]
+ | apply H5; unfold ge in |- *; apply le_trans with N;
+    [ apply le_trans with (max N2 N3);
+       [ apply le_max_r | unfold N in |- *; apply le_max_r ]
+    | assumption ] ].
+unfold Rdiv in |- *; rewrite Rinv_mult_distr;
+ [ ring | discrR | apply Rabs_no_R0; assumption ].
+apply Rabs_no_R0; assumption.
+apply H3; unfold ge in |- *; apply le_trans with (max N0 N1);
+ [ apply le_max_l
+ | apply le_trans with N; [ unfold N in |- *; apply le_max_l | assumption ] ].
+apply Rmult_lt_reg_l with (/ Rabs l).
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; replace (/ Rabs l * (eps / 5)) with (eps / (5 * Rabs l)).
+apply H6; unfold ge in |- *; apply le_trans with (max N2 N3);
+ [ apply le_max_l
+ | apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ] ].
+unfold Rdiv in |- *; rewrite Rinv_mult_distr;
+ [ ring | discrR | apply Rabs_no_R0; assumption ].
+apply Rabs_no_R0; assumption.
+apply Rmult_eq_reg_l with 5;
+ [ unfold Rdiv in |- *; do 2 rewrite Rmult_plus_distr_l;
+    do 3 rewrite (Rmult_comm 5); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym; [ ring | discrR ]
+ | discrR ]. 
+Qed.
+
+Lemma RiemannInt_P13 :
+ forall (f g:R -> R) (a b l:R) (pr1:Riemann_integrable f a b)
+   (pr2:Riemann_integrable g a b)
+   (pr3:Riemann_integrable (fun x:R => f x + l * g x) a b),
+   RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2.
+intros; case (Rle_dec a b); intro;
+ [ apply RiemannInt_P12; assumption
+ | assert (H : b <= a);
+    [ auto with real
+    | replace (RiemannInt pr3) with (- RiemannInt (RiemannInt_P1 pr3));
+       [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
+       replace (RiemannInt pr2) with (- RiemannInt (RiemannInt_P1 pr2));
+       [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
+       replace (RiemannInt pr1) with (- RiemannInt (RiemannInt_P1 pr1));
+       [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
+       rewrite
+        (RiemannInt_P12 (RiemannInt_P1 pr1) (RiemannInt_P1 pr2)
+           (RiemannInt_P1 pr3) H); ring ] ].
+Qed.
+
+Lemma RiemannInt_P14 : forall a b c:R, Riemann_integrable (fct_cte c) a b.
+unfold Riemann_integrable in |- *; intros;
+ split with (mkStepFun (StepFun_P4 a b c));
+ split with (mkStepFun (StepFun_P4 a b 0)); split;
+ [ intros; simpl in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rabs_R0; unfold fct_cte in |- *; right; 
+    reflexivity
+ | rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0;
+    apply (cond_pos eps) ].
+Qed.
+
+Lemma RiemannInt_P15 :
+ forall (a b c:R) (pr:Riemann_integrable (fct_cte c) a b),
+   RiemannInt pr = c * (b - a).
+intros; unfold RiemannInt in |- *; case (RiemannInt_exists pr RinvN RinvN_cv);
+ intros; eapply UL_sequence.
+apply u.
+set (phi1 := fun N:nat => phi_sequence RinvN pr N);
+ change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) (c * (b - a))) in |- *;
+ set (f := fct_cte c);
+ assert
+  (H1 :
+    exists psi1 : nat -> StepFun a b,
+     (forall n:nat,
+        (forall t:R,
+           Rmin a b <= t /\ t <= Rmax a b ->
+           Rabs (f t - phi_sequence RinvN pr n t) <= psi1 n t) /\
+        Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr n)).
+elim H1; clear H1; intros psi1 H1;
+ set (phi2 := fun n:nat => mkStepFun (StepFun_P4 a b c));
+ set (psi2 := fun n:nat => mkStepFun (StepFun_P4 a b 0));
+ apply RiemannInt_P11 with f RinvN phi2 psi2 psi1; 
+ try assumption.
+apply RinvN_cv.
+intro; split.
+intros; unfold f in |- *; simpl in |- *; unfold Rminus in |- *;
+ rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte in |- *; 
+ right; reflexivity.
+unfold psi2 in |- *; rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0;
+ apply (cond_pos (RinvN n)).
+unfold Un_cv in |- *; intros; split with 0%nat; intros; unfold R_dist in |- *;
+ unfold phi2 in |- *; rewrite StepFun_P18; unfold Rminus in |- *;
+ rewrite Rplus_opp_r; rewrite Rabs_R0; apply H.
+Qed.
+
+Lemma RiemannInt_P16 :
+ forall (f:R -> R) (a b:R),
+   Riemann_integrable f a b -> Riemann_integrable (fun x:R => Rabs (f x)) a b.
+unfold Riemann_integrable in |- *; intro f; intros; elim (X eps); clear X;
+ intros phi [psi [H H0]]; split with (mkStepFun (StepFun_P32 phi));
+ split with psi; split; try assumption; intros; simpl in |- *;
+ apply Rle_trans with (Rabs (f t - phi t));
+ [ apply Rabs_triang_inv2 | apply H; assumption ].
+Qed.
+
+Lemma Rle_cv_lim :
+ forall (Un Vn:nat -> R) (l1 l2:R),
+   (forall n:nat, Un n <= Vn n) -> Un_cv Un l1 -> Un_cv Vn l2 -> l1 <= l2.
+intros; case (Rle_dec l1 l2); intro.
+assumption.
+assert (H2 : l2 < l1).
+auto with real.
+clear n; assert (H3 : 0 < (l1 - l2) / 2).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply Rlt_Rminus; assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (H1 _ H3); elim (H0 _ H3); clear H0 H1; unfold R_dist in |- *; intros;
+ set (N := max x x0); cut (Vn N < Un N).
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (H N) H4)).
+apply Rlt_trans with ((l1 + l2) / 2).
+apply Rplus_lt_reg_r with (- l2);
+ replace (- l2 + (l1 + l2) / 2) with ((l1 - l2) / 2).
+rewrite Rplus_comm; apply Rle_lt_trans with (Rabs (Vn N - l2)).
+apply RRle_abs.
+apply H1; unfold ge in |- *; unfold N in |- *; apply le_max_r.
+apply Rmult_eq_reg_l with 2;
+ [ unfold Rdiv in |- *; do 2 rewrite (Rmult_comm 2);
+    rewrite (Rmult_plus_distr_r (- l2) ((l1 + l2) * / 2) 2);
+    repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; 
+    [ ring | discrR ]
+ | discrR ].
+apply Ropp_lt_cancel; apply Rplus_lt_reg_r with l1;
+ replace (l1 + - ((l1 + l2) / 2)) with ((l1 - l2) / 2).
+apply Rle_lt_trans with (Rabs (Un N - l1)).
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
+apply H0; unfold ge in |- *; unfold N in |- *; apply le_max_l.
+apply Rmult_eq_reg_l with 2;
+ [ unfold Rdiv in |- *; do 2 rewrite (Rmult_comm 2);
+    rewrite (Rmult_plus_distr_r l1 (- ((l1 + l2) * / 2)) 2);
+    rewrite <- Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym; [ ring | discrR ]
+ | discrR ].
+Qed.
+
+Lemma RiemannInt_P17 :
+ forall (f:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
+   (pr2:Riemann_integrable (fun x:R => Rabs (f x)) a b),
+   a <= b -> Rabs (RiemannInt pr1) <= RiemannInt pr2.
+intro f; intros; unfold RiemannInt in |- *;
+ case (RiemannInt_exists pr1 RinvN RinvN_cv);
+ case (RiemannInt_exists pr2 RinvN RinvN_cv); intros;
+ set (phi1 := phi_sequence RinvN pr1);
+ set (phi2 := fun N:nat => mkStepFun (StepFun_P32 (phi1 N)));
+ apply Rle_cv_lim with
+  (fun N:nat => Rabs (RiemannInt_SF (phi1 N)))
+  (fun N:nat => RiemannInt_SF (phi2 N)).
+intro; unfold phi2 in |- *; apply StepFun_P34; assumption.
+fold phi1 in u0;
+ apply (continuity_seq Rabs (fun N:nat => RiemannInt_SF (phi1 N)) x0);
+ try assumption.
+apply Rcontinuity_abs.
+set (phi3 := phi_sequence RinvN pr2);
+ assert
+  (H0 :
+    exists psi3 : nat -> StepFun a b,
+     (forall n:nat,
+        (forall t:R,
+           Rmin a b <= t /\ t <= Rmax a b ->
+           Rabs (Rabs (f t) - phi3 n t) <= psi3 n t) /\
+        Rabs (RiemannInt_SF (psi3 n)) < RinvN n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr2 n)). 
+assert
+ (H1 :
+   exists psi2 : nat -> StepFun a b,
+    (forall n:nat,
+       (forall t:R,
+          Rmin a b <= t /\ t <= Rmax a b ->
+          Rabs (Rabs (f t) - phi2 n t) <= psi2 n t) /\
+       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+assert
+ (H1 :
+   exists psi2 : nat -> StepFun a b,
+    (forall n:nat,
+       (forall t:R,
+          Rmin a b <= t /\ t <= Rmax a b -> Rabs (f t - phi1 n t) <= psi2 n t) /\
+       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr1 n)).
+elim H1; clear H1; intros psi2 H1; split with psi2; intros; elim (H1 n);
+ clear H1; intros; split; try assumption.
+intros; unfold phi2 in |- *; simpl in |- *;
+ apply Rle_trans with (Rabs (f t - phi1 n t)).
+apply Rabs_triang_inv2.
+apply H1; assumption.
+elim H0; clear H0; intros psi3 H0; elim H1; clear H1; intros psi2 H1;
+ apply RiemannInt_P11 with (fun x:R => Rabs (f x)) RinvN phi3 psi3 psi2;
+ try assumption; apply RinvN_cv.
+Qed.
+
+Lemma RiemannInt_P18 :
+ forall (f g:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
+   (pr2:Riemann_integrable g a b),
+   a <= b ->
+   (forall x:R, a < x < b -> f x = g x) -> RiemannInt pr1 = RiemannInt pr2.
+intro f; intros; unfold RiemannInt in |- *;
+ case (RiemannInt_exists pr1 RinvN RinvN_cv);
+ case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; 
+ eapply UL_sequence.
+apply u0.
+set (phi1 := fun N:nat => phi_sequence RinvN pr1 N);
+ change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) x) in |- *;
+ assert
+  (H1 :
+    exists psi1 : nat -> StepFun a b,
+     (forall n:nat,
+        (forall t:R,
+           Rmin a b <= t /\ t <= Rmax a b ->
+           Rabs (f t - phi1 n t) <= psi1 n t) /\
+        Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr1 n)). 
+elim H1; clear H1; intros psi1 H1;
+ set (phi2 := fun N:nat => phi_sequence RinvN pr2 N).
+set
+ (phi2_aux :=
+  fun (N:nat) (x:R) =>
+    match Req_EM_T x a with
+    | left _ => f a
+    | right _ =>
+        match Req_EM_T x b with
+        | left _ => f b
+        | right _ => phi2 N x
+        end
+    end).
+cut (forall N:nat, IsStepFun (phi2_aux N) a b).
+intro; set (phi2_m := fun N:nat => mkStepFun (X N)).
+assert
+ (H2 :
+   exists psi2 : nat -> StepFun a b,
+    (forall n:nat,
+       (forall t:R,
+          Rmin a b <= t /\ t <= Rmax a b -> Rabs (g t - phi2 n t) <= psi2 n t) /\
+       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr2 n)). 
+elim H2; clear H2; intros psi2 H2;
+ apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1; 
+ try assumption. 
+apply RinvN_cv.
+intro; elim (H2 n); intros; split; try assumption.
+intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
+ case (Req_EM_T t a); case (Req_EM_T t b); intros.
+rewrite e0; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ apply Rle_trans with (Rabs (g t - phi2 n t)).
+apply Rabs_pos.
+pattern a at 3 in |- *; rewrite <- e0; apply H3; assumption.
+rewrite e; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ apply Rle_trans with (Rabs (g t - phi2 n t)).
+apply Rabs_pos.
+pattern a at 3 in |- *; rewrite <- e; apply H3; assumption.
+rewrite e; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ apply Rle_trans with (Rabs (g t - phi2 n t)).
+apply Rabs_pos.
+pattern b at 3 in |- *; rewrite <- e; apply H3; assumption.
+replace (f t) with (g t).
+apply H3; assumption.
+symmetry  in |- *; apply H0; elim H5; clear H5; intros.
+assert (H7 : Rmin a b = a).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n2; assumption ].
+assert (H8 : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n2; assumption ].
+rewrite H7 in H5; rewrite H8 in H6; split.
+elim H5; intro; [ assumption | elim n1; symmetry  in |- *; assumption ].
+elim H6; intro; [ assumption | elim n0; assumption ].
+cut (forall N:nat, RiemannInt_SF (phi2_m N) = RiemannInt_SF (phi2 N)).
+intro; unfold Un_cv in |- *; intros; elim (u _ H4); intros; exists x1; intros;
+ rewrite (H3 n); apply H5; assumption.
+intro; apply Rle_antisym.
+apply StepFun_P37; try assumption.
+intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
+ case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros.
+elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4).
+elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4).
+elim H3; intros; rewrite e in H5; elim (Rlt_irrefl _ H5).
+right; reflexivity.
+apply StepFun_P37; try assumption.
+intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
+ case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros.
+elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4).
+elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4).
+elim H3; intros; rewrite e in H5; elim (Rlt_irrefl _ H5).
+right; reflexivity.
+intro; assert (H2 := pre (phi2 N)); unfold IsStepFun in H2;
+ unfold is_subdivision in H2; elim H2; clear H2; intros l [lf H2];
+ split with l; split with lf; unfold adapted_couple in H2; 
+ decompose [and] H2; clear H2; unfold adapted_couple in |- *; 
+ repeat split; try assumption.
+intros; assert (H9 := H8 i H2); unfold constant_D_eq, open_interval in H9;
+ unfold constant_D_eq, open_interval in |- *; intros; 
+ rewrite <- (H9 x1 H7); assert (H10 : a <= pos_Rl l i).
+replace a with (Rmin a b).
+rewrite <- H5; elim (RList_P6 l); intros; apply H10.
+assumption.
+apply le_O_n.
+apply lt_trans with (pred (Rlength l)); [ assumption | apply lt_pred_n_n ].
+apply neq_O_lt; intro; rewrite <- H12 in H6; discriminate.
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+assert (H11 : pos_Rl l (S i) <= b).
+replace b with (Rmax a b).
+rewrite <- H4; elim (RList_P6 l); intros; apply H11.
+assumption.
+apply lt_le_S; assumption.
+apply lt_pred_n_n; apply neq_O_lt; intro; rewrite <- H13 in H6; discriminate.
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+elim H7; clear H7; intros; unfold phi2_aux in |- *; case (Req_EM_T x1 a);
+ case (Req_EM_T x1 b); intros.
+rewrite e in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)).
+rewrite e in H7; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H7)).
+rewrite e in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)).
+reflexivity.
+Qed.
+
+Lemma RiemannInt_P19 :
+ forall (f g:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
+   (pr2:Riemann_integrable g a b),
+   a <= b ->
+   (forall x:R, a < x < b -> f x <= g x) -> RiemannInt pr1 <= RiemannInt pr2.
+intro f; intros; apply Rplus_le_reg_l with (- RiemannInt pr1);
+ rewrite Rplus_opp_l; rewrite Rplus_comm;
+ apply Rle_trans with (Rabs (RiemannInt (RiemannInt_P10 (-1) pr2 pr1))).
+apply Rabs_pos.
+replace (RiemannInt pr2 + - RiemannInt pr1) with
+ (RiemannInt (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))).
+apply
+ (RiemannInt_P17 (RiemannInt_P10 (-1) pr2 pr1)
+    (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))); 
+ assumption.
+replace (RiemannInt pr2 + - RiemannInt pr1) with
+ (RiemannInt (RiemannInt_P10 (-1) pr2 pr1)).
+apply RiemannInt_P18; try assumption.
+intros; apply Rabs_right.
+apply Rle_ge; apply Rplus_le_reg_l with (f x); rewrite Rplus_0_r;
+ replace (f x + (g x + -1 * f x)) with (g x); [ apply H0; assumption | ring ].
+rewrite (RiemannInt_P12 pr2 pr1 (RiemannInt_P10 (-1) pr2 pr1));
+ [ ring | assumption ].
+Qed.
+
+Lemma FTC_P1 :
+ forall (f:R -> R) (a b:R),
+   a <= b ->
+   (forall x:R, a <= x <= b -> continuity_pt f x) ->
+   forall x:R, a <= x -> x <= b -> Riemann_integrable f a x.
+intros; apply continuity_implies_RiemannInt;
+ [ assumption
+ | intros; apply H0; elim H3; intros; split;
+    assumption || apply Rle_trans with x; assumption ].
+Qed.
+
+Definition primitive (f:R -> R) (a b:R) (h:a <= b)
+  (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x) 
+  (x:R) : R :=
+  match Rle_dec a x with
+  | left r =>
+      match Rle_dec x b with
+      | left r0 => RiemannInt (pr x r r0)
+      | right _ => f b * (x - b) + RiemannInt (pr b h (Rle_refl b))
+      end
+  | right _ => f a * (x - a)
+  end.
+
+Lemma RiemannInt_P20 :
+ forall (f:R -> R) (a b:R) (h:a <= b)
+   (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x)
+   (pr0:Riemann_integrable f a b),
+   RiemannInt pr0 = primitive h pr b - primitive h pr a.
+intros; replace (primitive h pr a) with 0.
+replace (RiemannInt pr0) with (primitive h pr b).
+ring.
+unfold primitive in |- *; case (Rle_dec a b); case (Rle_dec b b); intros;
+ [ apply RiemannInt_P5
+ | elim n; right; reflexivity
+ | elim n; assumption
+ | elim n0; assumption ].
+symmetry  in |- *; unfold primitive in |- *; case (Rle_dec a a);
+ case (Rle_dec a b); intros;
+ [ apply RiemannInt_P9
+ | elim n; assumption
+ | elim n; right; reflexivity
+ | elim n0; right; reflexivity ].
+Qed.
+
+Lemma RiemannInt_P21 :
+ forall (f:R -> R) (a b c:R),
+   a <= b ->
+   b <= c ->
+   Riemann_integrable f a b ->
+   Riemann_integrable f b c -> Riemann_integrable f a c.
+unfold Riemann_integrable in |- *; intros f a b c Hyp1 Hyp2 X X0 eps.
+assert (H : 0 < eps / 2).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (X (mkposreal _ H)); clear X; intros phi1 [psi1 H1];
+ elim (X0 (mkposreal _ H)); clear X0; intros phi2 [psi2 H2].
+set
+ (phi3 :=
+  fun x:R =>
+    match Rle_dec a x with
+    | left _ =>
+        match Rle_dec x b with
+        | left _ => phi1 x
+        | right _ => phi2 x
+        end
+    | right _ => 0
+    end).
+set
+ (psi3 :=
+  fun x:R =>
+    match Rle_dec a x with
+    | left _ =>
+        match Rle_dec x b with
+        | left _ => psi1 x
+        | right _ => psi2 x
+        end
+    | right _ => 0
+    end).
+cut (IsStepFun phi3 a c).
+intro; cut (IsStepFun psi3 a b).
+intro; cut (IsStepFun psi3 b c).
+intro; cut (IsStepFun psi3 a c).
+intro; split with (mkStepFun X); split with (mkStepFun X2); simpl in |- *;
+ split.
+intros; unfold phi3, psi3 in |- *; case (Rle_dec t b); case (Rle_dec a t);
+ intros.
+elim H1; intros; apply H3.
+replace (Rmin a b) with a.
+replace (Rmax a b) with b.
+split; assumption.
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+elim n; replace a with (Rmin a c).
+elim H0; intros; assumption.
+unfold Rmin in |- *; case (Rle_dec a c); intro;
+ [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
+elim H2; intros; apply H3.
+replace (Rmax b c) with (Rmax a c).
+elim H0; intros; split; try assumption.
+replace (Rmin b c) with b.
+auto with real.
+unfold Rmin in |- *; case (Rle_dec b c); intro;
+ [ reflexivity | elim n0; assumption ].
+unfold Rmax in |- *; case (Rle_dec a c); case (Rle_dec b c); intros;
+ try (elim n0; assumption || elim n0; apply Rle_trans with b; assumption).
+reflexivity.
+elim n; replace a with (Rmin a c).
+elim H0; intros; assumption.
+unfold Rmin in |- *; case (Rle_dec a c); intro;
+ [ reflexivity | elim n1; apply Rle_trans with b; assumption ].
+rewrite <- (StepFun_P43 X0 X1 X2).
+apply Rle_lt_trans with
+ (Rabs (RiemannInt_SF (mkStepFun X0)) + Rabs (RiemannInt_SF (mkStepFun X1))).
+apply Rabs_triang.
+rewrite (double_var eps);
+ replace (RiemannInt_SF (mkStepFun X0)) with (RiemannInt_SF psi1).
+replace (RiemannInt_SF (mkStepFun X1)) with (RiemannInt_SF psi2).
+apply Rplus_lt_compat.
+elim H1; intros; assumption.
+elim H2; intros; assumption.
+apply Rle_antisym.
+apply StepFun_P37; try assumption.
+simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+ case (Rle_dec a x); case (Rle_dec x b); intros;
+ [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0))
+ | right; reflexivity
+ | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
+ | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+apply StepFun_P37; try assumption.
+simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+ case (Rle_dec a x); case (Rle_dec x b); intros;
+ [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0))
+ | right; reflexivity
+ | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
+ | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+apply Rle_antisym.
+apply StepFun_P37; try assumption.
+simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+ case (Rle_dec a x); case (Rle_dec x b); intros;
+ [ right; reflexivity
+ | elim n; left; assumption
+ | elim n; left; assumption
+ | elim n0; left; assumption ].
+apply StepFun_P37; try assumption.
+simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+ case (Rle_dec a x); case (Rle_dec x b); intros;
+ [ right; reflexivity
+ | elim n; left; assumption
+ | elim n; left; assumption
+ | elim n0; left; assumption ].
+apply StepFun_P46 with b; assumption.
+assert (H3 := pre psi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
+ elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
+ split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
+ clear H3; unfold adapted_couple in |- *; repeat split; 
+ try assumption.
+intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+ unfold constant_D_eq, open_interval in H9; intros; 
+ rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x).
+apply Rle_lt_trans with (pos_Rl l1 i).
+replace b with (Rmin b c).
+rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption.
+apply le_O_n.
+apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
+ apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; 
+ discriminate. 
+unfold Rmin in |- *; case (Rle_dec b c); intro;
+ [ reflexivity | elim n; assumption ].
+elim H7; intros; assumption.
+case (Rle_dec a x); case (Rle_dec x b); intros;
+ [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10))
+ | reflexivity
+ | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
+ | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+assert (H3 := pre psi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
+ elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
+ split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
+ clear H3; unfold adapted_couple in |- *; repeat split; 
+ try assumption.
+intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+ unfold constant_D_eq, open_interval in H9; intros; 
+ rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b).
+apply Rle_trans with (pos_Rl l1 (S i)).
+elim H7; intros; left; assumption.
+replace b with (Rmax a b).
+rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
+apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
+ discriminate. 
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+assert (H11 : a <= x).
+apply Rle_trans with (pos_Rl l1 i).
+replace a with (Rmin a b).
+rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption.
+apply le_O_n.
+apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
+ apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; 
+ discriminate. 
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+left; elim H7; intros; assumption.
+case (Rle_dec a x); case (Rle_dec x b); intros; reflexivity || elim n;
+ assumption.
+apply StepFun_P46 with b.
+assert (H3 := pre phi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
+ elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
+ split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
+ clear H3; unfold adapted_couple in |- *; repeat split; 
+ try assumption.
+intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+ unfold constant_D_eq, open_interval in H9; intros; 
+ rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b).
+apply Rle_trans with (pos_Rl l1 (S i)).
+elim H7; intros; left; assumption.
+replace b with (Rmax a b).
+rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
+apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
+ discriminate. 
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+assert (H11 : a <= x).
+apply Rle_trans with (pos_Rl l1 i).
+replace a with (Rmin a b).
+rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption.
+apply le_O_n.
+apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
+ apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; 
+ discriminate. 
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+left; elim H7; intros; assumption.
+unfold phi3 in |- *; case (Rle_dec a x); case (Rle_dec x b); intros;
+ reflexivity || elim n; assumption.
+assert (H3 := pre phi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
+ elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
+ split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
+ clear H3; unfold adapted_couple in |- *; repeat split; 
+ try assumption.
+intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+ unfold constant_D_eq, open_interval in H9; intros; 
+ rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x).
+apply Rle_lt_trans with (pos_Rl l1 i).
+replace b with (Rmin b c).
+rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption.
+apply le_O_n.
+apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
+ apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; 
+ discriminate. 
+unfold Rmin in |- *; case (Rle_dec b c); intro;
+ [ reflexivity | elim n; assumption ].
+elim H7; intros; assumption.
+unfold phi3 in |- *; case (Rle_dec a x); case (Rle_dec x b); intros;
+ [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10))
+ | reflexivity
+ | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
+ | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+Qed.
+
+Lemma RiemannInt_P22 :
+ forall (f:R -> R) (a b c:R),
+   Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f a c.
+unfold Riemann_integrable in |- *; intros; elim (X eps); clear X;
+ intros phi [psi H0]; elim H; elim H0; clear H H0; 
+ intros; assert (H3 : IsStepFun phi a c).
+apply StepFun_P44 with b.
+apply (pre phi).
+split; assumption.
+assert (H4 : IsStepFun psi a c).
+apply StepFun_P44 with b.
+apply (pre psi).
+split; assumption.
+split with (mkStepFun H3); split with (mkStepFun H4); split.
+simpl in |- *; intros; apply H.
+replace (Rmin a b) with (Rmin a c).
+elim H5; intros; split; try assumption.
+apply Rle_trans with (Rmax a c); try assumption.
+replace (Rmax a b) with b.
+replace (Rmax a c) with c.
+assumption.
+unfold Rmax in |- *; case (Rle_dec a c); intro;
+ [ reflexivity | elim n; assumption ].
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+unfold Rmin in |- *; case (Rle_dec a c); case (Rle_dec a b); intros;
+ [ reflexivity
+ | elim n; apply Rle_trans with c; assumption
+ | elim n; assumption
+ | elim n0; assumption ].
+rewrite Rabs_right.
+assert (H5 : IsStepFun psi c b).
+apply StepFun_P46 with a.
+apply StepFun_P6; assumption.
+apply (pre psi).
+replace (RiemannInt_SF (mkStepFun H4)) with
+ (RiemannInt_SF psi - RiemannInt_SF (mkStepFun H5)).
+apply Rle_lt_trans with (RiemannInt_SF psi).
+unfold Rminus in |- *; pattern (RiemannInt_SF psi) at 2 in |- *;
+ rewrite <- Rplus_0_r; apply Rplus_le_compat_l; rewrite <- Ropp_0;
+ apply Ropp_ge_le_contravar; apply Rle_ge;
+ replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b 0))).
+apply StepFun_P37; try assumption.
+intros; simpl in |- *; unfold fct_cte in |- *;
+ apply Rle_trans with (Rabs (f x - phi x)).
+apply Rabs_pos.
+apply H.
+replace (Rmin a b) with a.
+replace (Rmax a b) with b.
+elim H6; intros; split; left.
+apply Rle_lt_trans with c; assumption.
+assumption.
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+rewrite StepFun_P18; ring.
+apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)).
+apply RRle_abs.
+assumption.
+assert (H6 : IsStepFun psi a b).
+apply (pre psi).
+replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)).
+rewrite <- (StepFun_P43 H4 H5 H6); ring.
+unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+eapply StepFun_P17.
+apply StepFun_P1.
+simpl in |- *; apply StepFun_P1.
+apply Ropp_eq_compat; eapply StepFun_P17.
+apply StepFun_P1.
+simpl in |- *; apply StepFun_P1.
+apply Rle_ge; replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c 0))).
+apply StepFun_P37; try assumption.
+intros; simpl in |- *; unfold fct_cte in |- *;
+ apply Rle_trans with (Rabs (f x - phi x)).
+apply Rabs_pos.
+apply H.
+replace (Rmin a b) with a.
+replace (Rmax a b) with b.
+elim H5; intros; split; left.
+assumption.
+apply Rlt_le_trans with c; assumption.
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+rewrite StepFun_P18; ring.
+Qed.
+
+Lemma RiemannInt_P23 :
+ forall (f:R -> R) (a b c:R),
+   Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f c b.
+unfold Riemann_integrable in |- *; intros; elim (X eps); clear X;
+ intros phi [psi H0]; elim H; elim H0; clear H H0; 
+ intros; assert (H3 : IsStepFun phi c b).
+apply StepFun_P45 with a.
+apply (pre phi).
+split; assumption.
+assert (H4 : IsStepFun psi c b).
+apply StepFun_P45 with a.
+apply (pre psi).
+split; assumption.
+split with (mkStepFun H3); split with (mkStepFun H4); split.
+simpl in |- *; intros; apply H.
+replace (Rmax a b) with (Rmax c b).
+elim H5; intros; split; try assumption.
+apply Rle_trans with (Rmin c b); try assumption.
+replace (Rmin a b) with a.
+replace (Rmin c b) with c.
+assumption.
+unfold Rmin in |- *; case (Rle_dec c b); intro;
+ [ reflexivity | elim n; assumption ].
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+unfold Rmax in |- *; case (Rle_dec c b); case (Rle_dec a b); intros;
+ [ reflexivity
+ | elim n; apply Rle_trans with c; assumption
+ | elim n; assumption
+ | elim n0; assumption ].
+rewrite Rabs_right.
+assert (H5 : IsStepFun psi a c).
+apply StepFun_P46 with b.
+apply (pre psi).
+apply StepFun_P6; assumption.
+replace (RiemannInt_SF (mkStepFun H4)) with
+ (RiemannInt_SF psi - RiemannInt_SF (mkStepFun H5)).
+apply Rle_lt_trans with (RiemannInt_SF psi).
+unfold Rminus in |- *; pattern (RiemannInt_SF psi) at 2 in |- *;
+ rewrite <- Rplus_0_r; apply Rplus_le_compat_l; rewrite <- Ropp_0;
+ apply Ropp_ge_le_contravar; apply Rle_ge;
+ replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c 0))).
+apply StepFun_P37; try assumption.
+intros; simpl in |- *; unfold fct_cte in |- *;
+ apply Rle_trans with (Rabs (f x - phi x)).
+apply Rabs_pos.
+apply H.
+replace (Rmin a b) with a.
+replace (Rmax a b) with b.
+elim H6; intros; split; left.
+assumption.
+apply Rlt_le_trans with c; assumption.
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+rewrite StepFun_P18; ring.
+apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)).
+apply RRle_abs.
+assumption.
+assert (H6 : IsStepFun psi a b).
+apply (pre psi).
+replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)).
+rewrite <- (StepFun_P43 H5 H4 H6); ring.
+unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+eapply StepFun_P17.
+apply StepFun_P1.
+simpl in |- *; apply StepFun_P1.
+apply Ropp_eq_compat; eapply StepFun_P17.
+apply StepFun_P1.
+simpl in |- *; apply StepFun_P1.
+apply Rle_ge; replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b 0))).
+apply StepFun_P37; try assumption.
+intros; simpl in |- *; unfold fct_cte in |- *;
+ apply Rle_trans with (Rabs (f x - phi x)).
+apply Rabs_pos.
+apply H.
+replace (Rmin a b) with a.
+replace (Rmax a b) with b.
+elim H5; intros; split; left.
+apply Rle_lt_trans with c; assumption.
+assumption.
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+rewrite StepFun_P18; ring.
+Qed.
+
+Lemma RiemannInt_P24 :
+ forall (f:R -> R) (a b c:R),
+   Riemann_integrable f a b ->
+   Riemann_integrable f b c -> Riemann_integrable f a c.
+intros; case (Rle_dec a b); case (Rle_dec b c); intros.
+apply RiemannInt_P21 with b; assumption.
+case (Rle_dec a c); intro.
+apply RiemannInt_P22 with b; try assumption.
+split; [ assumption | auto with real ].
+apply RiemannInt_P1; apply RiemannInt_P22 with b.
+apply RiemannInt_P1; assumption.
+split; auto with real.
+case (Rle_dec a c); intro.
+apply RiemannInt_P23 with b; try assumption.
+split; auto with real.
+apply RiemannInt_P1; apply RiemannInt_P23 with b.
+apply RiemannInt_P1; assumption.
+split; [ assumption | auto with real ].
+apply RiemannInt_P1; apply RiemannInt_P21 with b;
+ auto with real || apply RiemannInt_P1; assumption.
+Qed.
+
+Lemma RiemannInt_P25 :
+ forall (f:R -> R) (a b c:R) (pr1:Riemann_integrable f a b)
+   (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c),
+   a <= b -> b <= c -> RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3.
+intros f a b c pr1 pr2 pr3 Hyp1 Hyp2; unfold RiemannInt in |- *;
+ case (RiemannInt_exists pr1 RinvN RinvN_cv);
+ case (RiemannInt_exists pr2 RinvN RinvN_cv);
+ case (RiemannInt_exists pr3 RinvN RinvN_cv); intros; 
+ symmetry  in |- *; eapply UL_sequence.
+apply u.
+unfold Un_cv in |- *; intros; assert (H0 : 0 < eps / 3).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (u1 _ H0); clear u1; intros N1 H1; elim (u0 _ H0); clear u0;
+ intros N2 H2;
+ cut
+  (Un_cv
+     (fun n:nat =>
+        RiemannInt_SF (phi_sequence RinvN pr3 n) -
+        (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+         RiemannInt_SF (phi_sequence RinvN pr2 n))) 0).
+intro; elim (H3 _ H0); clear H3; intros N3 H3;
+ set (N0 := max (max N1 N2) N3); exists N0; intros; 
+ unfold R_dist in |- *;
+ apply Rle_lt_trans with
+  (Rabs
+     (RiemannInt_SF (phi_sequence RinvN pr3 n) -
+      (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+       RiemannInt_SF (phi_sequence RinvN pr2 n))) +
+   Rabs
+     (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+      RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0))).
+replace (RiemannInt_SF (phi_sequence RinvN pr3 n) - (x1 + x0)) with
+ (RiemannInt_SF (phi_sequence RinvN pr3 n) -
+  (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+   RiemannInt_SF (phi_sequence RinvN pr2 n)) +
+  (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+   RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0)));
+ [ apply Rabs_triang | ring ].
+replace eps with (eps / 3 + eps / 3 + eps / 3).
+rewrite Rplus_assoc; apply Rplus_lt_compat.
+unfold R_dist in H3; cut (n >= N3)%nat.
+intro; assert (H6 := H3 _ H5); unfold Rminus in H6; rewrite Ropp_0 in H6;
+ rewrite Rplus_0_r in H6; apply H6.
+unfold ge in |- *; apply le_trans with N0;
+ [ unfold N0 in |- *; apply le_max_r | assumption ].
+apply Rle_lt_trans with
+ (Rabs (RiemannInt_SF (phi_sequence RinvN pr1 n) - x1) +
+  Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x0)).
+replace
+ (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+  RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0)) with
+ (RiemannInt_SF (phi_sequence RinvN pr1 n) - x1 +
+  (RiemannInt_SF (phi_sequence RinvN pr2 n) - x0));
+ [ apply Rabs_triang | ring ].
+apply Rplus_lt_compat.
+unfold R_dist in H1; apply H1.
+unfold ge in |- *; apply le_trans with N0;
+ [ apply le_trans with (max N1 N2);
+    [ apply le_max_l | unfold N0 in |- *; apply le_max_l ]
+ | assumption ].
+unfold R_dist in H2; apply H2.
+unfold ge in |- *; apply le_trans with N0;
+ [ apply le_trans with (max N1 N2);
+    [ apply le_max_r | unfold N0 in |- *; apply le_max_l ]
+ | assumption ].
+apply Rmult_eq_reg_l with 3;
+ [ unfold Rdiv in |- *; repeat rewrite Rmult_plus_distr_l;
+    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym; [ ring | discrR ]
+ | discrR ].
+clear x u x0 x1 eps H H0 N1 H1 N2 H2;
+ assert
+  (H1 :
+    exists psi1 : nat -> StepFun a b,
+     (forall n:nat,
+        (forall t:R,
+           Rmin a b <= t /\ t <= Rmax a b ->
+           Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\
+        Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr1 n)). 
+assert
+ (H2 :
+   exists psi2 : nat -> StepFun b c,
+    (forall n:nat,
+       (forall t:R,
+          Rmin b c <= t /\ t <= Rmax b c ->
+          Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\
+       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr2 n)). 
+assert
+ (H3 :
+   exists psi3 : nat -> StepFun a c,
+    (forall n:nat,
+       (forall t:R,
+          Rmin a c <= t /\ t <= Rmax a c ->
+          Rabs (f t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\
+       Rabs (RiemannInt_SF (psi3 n)) < RinvN n)).
+split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n)); intro;
+ apply (projT2 (phi_sequence_prop RinvN pr3 n)). 
+elim H1; clear H1; intros psi1 H1; elim H2; clear H2; intros psi2 H2; elim H3;
+ clear H3; intros psi3 H3; assert (H := RinvN_cv); 
+ unfold Un_cv in |- *; intros; assert (H4 : 0 < eps / 3).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (H _ H4); clear H; intros N0 H;
+ assert (H5 : forall n:nat, (n >= N0)%nat -> RinvN n < eps / 3).
+intros;
+ replace (pos (RinvN n)) with
+  (R_dist (mkposreal (/ (INR n + 1)) (RinvN_pos n)) 0).
+apply H; assumption.
+unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+ left; apply (cond_pos (RinvN n)).
+exists N0; intros; elim (H1 n); elim (H2 n); elim (H3 n); clear H1 H2 H3;
+ intros; unfold R_dist in |- *; unfold Rminus in |- *; 
+ rewrite Ropp_0; rewrite Rplus_0_r; set (phi1 := phi_sequence RinvN pr1 n);
+ fold phi1 in H8; set (phi2 := phi_sequence RinvN pr2 n); 
+ fold phi2 in H3; set (phi3 := phi_sequence RinvN pr3 n); 
+ fold phi2 in H1; assert (H10 : IsStepFun phi3 a b).
+apply StepFun_P44 with c.
+apply (pre phi3).
+split; assumption.
+assert (H11 : IsStepFun (psi3 n) a b).
+apply StepFun_P44 with c.
+apply (pre (psi3 n)).
+split; assumption.
+assert (H12 : IsStepFun phi3 b c).
+apply StepFun_P45 with a.
+apply (pre phi3).
+split; assumption.
+assert (H13 : IsStepFun (psi3 n) b c).
+apply StepFun_P45 with a.
+apply (pre (psi3 n)).
+split; assumption.
+replace (RiemannInt_SF phi3) with
+ (RiemannInt_SF (mkStepFun H10) + RiemannInt_SF (mkStepFun H12)).
+apply Rle_lt_trans with
+ (Rabs (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1) +
+  Rabs (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2)).
+replace
+ (RiemannInt_SF (mkStepFun H10) + RiemannInt_SF (mkStepFun H12) +
+  - (RiemannInt_SF phi1 + RiemannInt_SF phi2)) with
+ (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1 +
+  (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2));
+ [ apply Rabs_triang | ring ].
+replace (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1) with
+ (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1))).
+replace (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2) with
+ (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))).
+apply Rle_lt_trans with
+ (RiemannInt_SF
+    (mkStepFun
+       (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1)))) +
+  RiemannInt_SF
+    (mkStepFun
+       (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))))).
+apply Rle_trans with
+ (Rabs (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1))) +
+  RiemannInt_SF
+    (mkStepFun
+       (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))))).
+apply Rplus_le_compat_l.
+apply StepFun_P34; try assumption.
+do 2
+ rewrite <-
+  (Rplus_comm
+     (RiemannInt_SF
+        (mkStepFun
+           (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))))))
+  ; apply Rplus_le_compat_l; apply StepFun_P34; try assumption.
+apply Rle_lt_trans with
+ (RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H11) (psi1 n))) +
+  RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))).
+apply Rle_trans with
+ (RiemannInt_SF
+    (mkStepFun
+       (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1)))) +
+  RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))).
+apply Rplus_le_compat_l; apply StepFun_P37; try assumption.
+intros; simpl in |- *; rewrite Rmult_1_l;
+ apply Rle_trans with (Rabs (f x - phi3 x) + Rabs (f x - phi2 x)).
+rewrite <- (Rabs_Ropp (f x - phi3 x)); rewrite Ropp_minus_distr;
+ replace (phi3 x + -1 * phi2 x) with (phi3 x - f x + (f x - phi2 x));
+ [ apply Rabs_triang | ring ].
+apply Rplus_le_compat.
+fold phi3 in H1; apply H1.
+elim H14; intros; split.
+replace (Rmin a c) with a.
+apply Rle_trans with b; try assumption.
+left; assumption.
+unfold Rmin in |- *; case (Rle_dec a c); intro;
+ [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
+replace (Rmax a c) with c.
+left; assumption.
+unfold Rmax in |- *; case (Rle_dec a c); intro;
+ [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
+apply H3.
+elim H14; intros; split.
+replace (Rmin b c) with b.
+left; assumption.
+unfold Rmin in |- *; case (Rle_dec b c); intro;
+ [ reflexivity | elim n0; assumption ].
+replace (Rmax b c) with c.
+left; assumption.
+unfold Rmax in |- *; case (Rle_dec b c); intro;
+ [ reflexivity | elim n0; assumption ].
+do 2
+ rewrite <-
+  (Rplus_comm
+     (RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))))
+  ; apply Rplus_le_compat_l; apply StepFun_P37; try assumption.
+intros; simpl in |- *; rewrite Rmult_1_l;
+ apply Rle_trans with (Rabs (f x - phi3 x) + Rabs (f x - phi1 x)).
+rewrite <- (Rabs_Ropp (f x - phi3 x)); rewrite Ropp_minus_distr;
+ replace (phi3 x + -1 * phi1 x) with (phi3 x - f x + (f x - phi1 x));
+ [ apply Rabs_triang | ring ].
+apply Rplus_le_compat.
+apply H1.
+elim H14; intros; split.
+replace (Rmin a c) with a.
+left; assumption.
+unfold Rmin in |- *; case (Rle_dec a c); intro;
+ [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
+replace (Rmax a c) with c.
+apply Rle_trans with b.
+left; assumption.
+assumption.
+unfold Rmax in |- *; case (Rle_dec a c); intro;
+ [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
+apply H8.
+elim H14; intros; split.
+replace (Rmin a b) with a.
+left; assumption.
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+replace (Rmax a b) with b.
+left; assumption.
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n0; assumption ].
+do 2 rewrite StepFun_P30.
+do 2 rewrite Rmult_1_l;
+ replace
+  (RiemannInt_SF (mkStepFun H11) + RiemannInt_SF (psi1 n) +
+   (RiemannInt_SF (mkStepFun H13) + RiemannInt_SF (psi2 n))) with
+  (RiemannInt_SF (psi3 n) + RiemannInt_SF (psi1 n) + RiemannInt_SF (psi2 n)).
+replace eps with (eps / 3 + eps / 3 + eps / 3).
+repeat rewrite Rplus_assoc; repeat apply Rplus_lt_compat.
+apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi3 n))).
+apply RRle_abs.
+apply Rlt_trans with (pos (RinvN n)).
+assumption.
+apply H5; assumption.
+apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))).
+apply RRle_abs.
+apply Rlt_trans with (pos (RinvN n)).
+assumption.
+apply H5; assumption.
+apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))).
+apply RRle_abs.
+apply Rlt_trans with (pos (RinvN n)).
+assumption.
+apply H5; assumption.
+apply Rmult_eq_reg_l with 3;
+ [ unfold Rdiv in |- *; repeat rewrite Rmult_plus_distr_l;
+    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym; [ ring | discrR ]
+ | discrR ].
+replace (RiemannInt_SF (psi3 n)) with
+ (RiemannInt_SF (mkStepFun (pre (psi3 n)))).
+rewrite <- (StepFun_P43 H11 H13 (pre (psi3 n))); ring.
+reflexivity.
+rewrite StepFun_P30; ring.
+rewrite StepFun_P30; ring.
+apply (StepFun_P43 H10 H12 (pre phi3)).
+Qed.
+
+Lemma RiemannInt_P26 :
+ forall (f:R -> R) (a b c:R) (pr1:Riemann_integrable f a b)
+   (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c),
+   RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3.
+intros; case (Rle_dec a b); case (Rle_dec b c); intros.
+apply RiemannInt_P25; assumption.
+case (Rle_dec a c); intro.
+assert (H : c <= b).
+auto with real.
+rewrite <- (RiemannInt_P25 pr3 (RiemannInt_P1 pr2) pr1 r0 H);
+ rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2)); ring.
+assert (H : c <= a).
+auto with real.
+rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2));
+ rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr3) pr1 (RiemannInt_P1 pr2) H r);
+ rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); ring.
+assert (H : b <= a).
+auto with real.
+case (Rle_dec a c); intro.
+rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr1) pr3 pr2 H r0);
+ rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1)); ring.
+assert (H0 : c <= a).
+auto with real.
+rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1));
+ rewrite <- (RiemannInt_P25 pr2 (RiemannInt_P1 pr3) (RiemannInt_P1 pr1) r H0);
+ rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); ring.
+rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1));
+ rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2));
+ rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3));
+ rewrite <-
+  (RiemannInt_P25 (RiemannInt_P1 pr2) (RiemannInt_P1 pr1) (RiemannInt_P1 pr3))
+  ; [ ring | auto with real | auto with real ].
+Qed.
+
+Lemma RiemannInt_P27 :
+ forall (f:R -> R) (a b x:R) (h:a <= b)
+   (C0:forall x:R, a <= x <= b -> continuity_pt f x),
+   a < x < b -> derivable_pt_lim (primitive h (FTC_P1 h C0)) x (f x).
+intro f; intros; elim H; clear H; intros; assert (H1 : continuity_pt f x).
+apply C0; split; left; assumption.
+unfold derivable_pt_lim in |- *; intros; assert (Hyp : 0 < eps / 2).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (H1 _ Hyp); unfold dist, D_x, no_cond in |- *; simpl in |- *;
+ unfold R_dist in |- *; intros; set (del := Rmin x0 (Rmin (b - x) (x - a)));
+ assert (H4 : 0 < del).
+unfold del in |- *; unfold Rmin in |- *; case (Rle_dec (b - x) (x - a));
+ intro.
+case (Rle_dec x0 (b - x)); intro;
+ [ elim H3; intros; assumption | apply Rlt_Rminus; assumption ].
+case (Rle_dec x0 (x - a)); intro;
+ [ elim H3; intros; assumption | apply Rlt_Rminus; assumption ].
+split with (mkposreal _ H4); intros;
+ assert (H7 : Riemann_integrable f x (x + h0)).
+case (Rle_dec x (x + h0)); intro.
+apply continuity_implies_RiemannInt; try assumption.
+intros; apply C0; elim H7; intros; split.
+apply Rle_trans with x; [ left; assumption | assumption ].
+apply Rle_trans with (x + h0).
+assumption.
+left; apply Rlt_le_trans with (x + del).
+apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h0);
+ [ apply RRle_abs | apply H6 ].
+unfold del in |- *; apply Rle_trans with (x + Rmin (b - x) (x - a)).
+apply Rplus_le_compat_l; apply Rmin_r.
+pattern b at 2 in |- *; replace b with (x + (b - x));
+ [ apply Rplus_le_compat_l; apply Rmin_l | ring ].
+apply RiemannInt_P1; apply continuity_implies_RiemannInt; auto with real.
+intros; apply C0; elim H7; intros; split.
+apply Rle_trans with (x + h0).
+left; apply Rle_lt_trans with (x - del).
+unfold del in |- *; apply Rle_trans with (x - Rmin (b - x) (x - a)).
+pattern a at 1 in |- *; replace a with (x + (a - x)); [ idtac | ring ].
+unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
+rewrite Ropp_involutive; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
+ rewrite (Rplus_comm x); apply Rmin_r.
+unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
+do 2 rewrite Ropp_involutive; apply Rmin_r.
+unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_cancel.
+rewrite Ropp_involutive; apply Rle_lt_trans with (Rabs h0);
+ [ rewrite <- Rabs_Ropp; apply RRle_abs | apply H6 ].
+assumption.
+apply Rle_trans with x; [ assumption | left; assumption ].
+replace (primitive h (FTC_P1 h C0) (x + h0) - primitive h (FTC_P1 h C0) x)
+ with (RiemannInt H7).
+replace (f x) with (RiemannInt (RiemannInt_P14 x (x + h0) (f x)) / h0).
+replace
+ (RiemannInt H7 / h0 - RiemannInt (RiemannInt_P14 x (x + h0) (f x)) / h0)
+ with ((RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) / h0).
+replace (RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) with
+ (RiemannInt (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))).
+unfold Rdiv in |- *; rewrite Rabs_mult; case (Rle_dec x (x + h0)); intro.
+apply Rle_lt_trans with
+ (RiemannInt
+    (RiemannInt_P16
+       (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))) *
+  Rabs (/ h0)).
+do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+apply Rabs_pos.
+apply
+ (RiemannInt_P17 (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))
+    (RiemannInt_P16
+       (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))));
+ assumption.
+apply Rle_lt_trans with
+ (RiemannInt (RiemannInt_P14 x (x + h0) (eps / 2)) * Rabs (/ h0)).
+do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+apply Rabs_pos.
+apply RiemannInt_P19; try assumption.
+intros; replace (f x1 + -1 * fct_cte (f x) x1) with (f x1 - f x).
+unfold fct_cte in |- *; case (Req_dec x x1); intro.
+rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; left;
+ assumption.
+elim H3; intros; left; apply H11.
+repeat split.
+assumption.
+rewrite Rabs_right.
+apply Rplus_lt_reg_r with x; replace (x + (x1 - x)) with x1; [ idtac | ring ].
+apply Rlt_le_trans with (x + h0).
+elim H8; intros; assumption.
+apply Rplus_le_compat_l; apply Rle_trans with del.
+left; apply Rle_lt_trans with (Rabs h0); [ apply RRle_abs | assumption ].
+unfold del in |- *; apply Rmin_l.
+apply Rge_minus; apply Rle_ge; left; elim H8; intros; assumption.
+unfold fct_cte in |- *; ring.
+rewrite RiemannInt_P15.
+rewrite Rmult_assoc; replace ((x + h0 - x) * Rabs (/ h0)) with 1.
+rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+       rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+rewrite Rabs_right.
+replace (x + h0 - x) with h0; [ idtac | ring ].
+apply Rinv_r_sym.
+assumption.
+apply Rle_ge; left; apply Rinv_0_lt_compat.
+elim r; intro.
+apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; assumption.
+elim H5; symmetry  in |- *; apply Rplus_eq_reg_l with x; rewrite Rplus_0_r;
+ assumption.
+apply Rle_lt_trans with
+ (RiemannInt
+    (RiemannInt_P16
+       (RiemannInt_P1
+          (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))) *
+  Rabs (/ h0)).
+do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+apply Rabs_pos.
+replace
+ (RiemannInt (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))) with
+ (-
+  RiemannInt
+    (RiemannInt_P1 (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))).
+rewrite Rabs_Ropp;
+ apply
+  (RiemannInt_P17
+     (RiemannInt_P1
+        (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))
+     (RiemannInt_P16
+        (RiemannInt_P1
+           (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))));
+ auto with real.
+symmetry  in |- *; apply RiemannInt_P8.
+apply Rle_lt_trans with
+ (RiemannInt (RiemannInt_P14 (x + h0) x (eps / 2)) * Rabs (/ h0)).
+do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+apply Rabs_pos.
+apply RiemannInt_P19.
+auto with real.
+intros; replace (f x1 + -1 * fct_cte (f x) x1) with (f x1 - f x).
+unfold fct_cte in |- *; case (Req_dec x x1); intro.
+rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; left;
+ assumption.
+elim H3; intros; left; apply H11.
+repeat split.
+assumption.
+rewrite Rabs_left.
+apply Rplus_lt_reg_r with (x1 - x0); replace (x1 - x0 + x0) with x1;
+ [ idtac | ring ].
+replace (x1 - x0 + - (x1 - x)) with (x - x0); [ idtac | ring ].
+apply Rle_lt_trans with (x + h0).
+unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
+rewrite Ropp_involutive; apply Rle_trans with (Rabs h0).
+rewrite <- Rabs_Ropp; apply RRle_abs.
+apply Rle_trans with del;
+ [ left; assumption | unfold del in |- *; apply Rmin_l ].
+elim H8; intros; assumption.
+apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
+ replace (x + (x1 - x)) with x1; [ elim H8; intros; assumption | ring ].
+unfold fct_cte in |- *; ring.
+rewrite RiemannInt_P15.
+rewrite Rmult_assoc; replace ((x - (x + h0)) * Rabs (/ h0)) with 1.
+rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+       rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+rewrite Rabs_left.
+replace (x - (x + h0)) with (- h0); [ idtac | ring ].
+rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_mult_distr_r_reverse;
+ rewrite Ropp_involutive; apply Rinv_r_sym.
+assumption.
+apply Rinv_lt_0_compat.
+assert (H8 : x + h0 < x).
+auto with real.
+apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; assumption.
+rewrite
+ (RiemannInt_P13 H7 (RiemannInt_P14 x (x + h0) (f x))
+    (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))
+ .
+ring.
+unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
+rewrite RiemannInt_P15; apply Rmult_eq_reg_l with h0;
+ [ unfold Rdiv in |- *; rewrite (Rmult_comm h0); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym; [ ring | assumption ]
+ | assumption ].
+cut (a <= x + h0).
+cut (x + h0 <= b).
+intros; unfold primitive in |- *.
+case (Rle_dec a (x + h0)); case (Rle_dec (x + h0) b); case (Rle_dec a x);
+ case (Rle_dec x b); intros; try (elim n; assumption || left; assumption).
+rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r0 r) H7 (FTC_P1 h C0 r2 r1)); ring.
+apply Rplus_le_reg_l with (- x); replace (- x + (x + h0)) with h0;
+ [ idtac | ring ].
+rewrite Rplus_comm; apply Rle_trans with (Rabs h0).
+apply RRle_abs.
+apply Rle_trans with del;
+ [ left; assumption
+ | unfold del in |- *; apply Rle_trans with (Rmin (b - x) (x - a));
+    [ apply Rmin_r | apply Rmin_l ] ].
+apply Ropp_le_cancel; apply Rplus_le_reg_l with x;
+ replace (x + - (x + h0)) with (- h0); [ idtac | ring ].
+apply Rle_trans with (Rabs h0);
+ [ rewrite <- Rabs_Ropp; apply RRle_abs
+ | apply Rle_trans with del;
+    [ left; assumption
+    | unfold del in |- *; apply Rle_trans with (Rmin (b - x) (x - a));
+       apply Rmin_r ] ].
+Qed.
+
+Lemma RiemannInt_P28 :
+ forall (f:R -> R) (a b x:R) (h:a <= b)
+   (C0:forall x:R, a <= x <= b -> continuity_pt f x),
+   a <= x <= b -> derivable_pt_lim (primitive h (FTC_P1 h C0)) x (f x).
+intro f; intros; elim h; intro.
+elim H; clear H; intros; elim H; intro.
+elim H1; intro.
+apply RiemannInt_P27; split; assumption.
+set
+ (f_b := fun x:R => f b * (x - b) + RiemannInt (FTC_P1 h C0 h (Rle_refl b)));
+ rewrite H3.
+assert (H4 : derivable_pt_lim f_b b (f b)).
+unfold f_b in |- *; pattern (f b) at 2 in |- *; replace (f b) with (f b + 0).
+change
+  (derivable_pt_lim
+     ((fct_cte (f b) * (id - fct_cte b))%F +
+      fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b (
+     f b + 0)) in |- *. 
+apply derivable_pt_lim_plus.
+pattern (f b) at 2 in |- *;
+ replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1).
+apply derivable_pt_lim_mult.
+apply derivable_pt_lim_const.
+replace 1 with (1 - 0); [ idtac | ring ].
+apply derivable_pt_lim_minus.
+apply derivable_pt_lim_id.
+apply derivable_pt_lim_const.
+unfold fct_cte in |- *; ring.
+apply derivable_pt_lim_const.
+ring.
+unfold derivable_pt_lim in |- *; intros; elim (H4 _ H5); intros;
+ assert (H7 : continuity_pt f b).
+apply C0; split; [ left; assumption | right; reflexivity ].
+assert (H8 : 0 < eps / 2).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (H7 _ H8); unfold D_x, no_cond, dist in |- *; simpl in |- *;
+ unfold R_dist in |- *; intros; set (del := Rmin x0 (Rmin x1 (b - a)));
+ assert (H10 : 0 < del).
+unfold del in |- *; unfold Rmin in |- *; case (Rle_dec x1 (b - a)); intros.
+case (Rle_dec x0 x1); intro;
+ [ apply (cond_pos x0) | elim H9; intros; assumption ].
+case (Rle_dec x0 (b - a)); intro;
+ [ apply (cond_pos x0) | apply Rlt_Rminus; assumption ].
+split with (mkposreal _ H10); intros; case (Rcase_abs h0); intro.
+assert (H14 : b + h0 < b).
+pattern b at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+ assumption.
+assert (H13 : Riemann_integrable f (b + h0) b).
+apply continuity_implies_RiemannInt.
+left; assumption.
+intros; apply C0; elim H13; intros; split; try assumption.
+apply Rle_trans with (b + h0); try assumption.
+apply Rplus_le_reg_l with (- a - h0).
+replace (- a - h0 + a) with (- h0); [ idtac | ring ].
+replace (- a - h0 + (b + h0)) with (b - a); [ idtac | ring ].
+apply Rle_trans with del.
+apply Rle_trans with (Rabs h0).
+rewrite <- Rabs_Ropp; apply RRle_abs.
+left; assumption.
+unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
+replace (primitive h (FTC_P1 h C0) (b + h0) - primitive h (FTC_P1 h C0) b)
+ with (- RiemannInt H13).
+replace (f b) with (- RiemannInt (RiemannInt_P14 (b + h0) b (f b)) / h0).
+rewrite <- Rabs_Ropp; unfold Rminus in |- *; unfold Rdiv in |- *;
+ rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_plus_distr;
+ repeat rewrite Ropp_involutive;
+ replace
+  (RiemannInt H13 * / h0 +
+   - RiemannInt (RiemannInt_P14 (b + h0) b (f b)) * / h0) with
+  ((RiemannInt H13 - RiemannInt (RiemannInt_P14 (b + h0) b (f b))) / h0).
+replace (RiemannInt H13 - RiemannInt (RiemannInt_P14 (b + h0) b (f b))) with
+ (RiemannInt (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))).
+unfold Rdiv in |- *; rewrite Rabs_mult;
+ apply Rle_lt_trans with
+  (RiemannInt
+     (RiemannInt_P16
+        (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))) *
+   Rabs (/ h0)).
+do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+apply Rabs_pos.
+apply
+ (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))
+    (RiemannInt_P16
+       (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))); 
+ left; assumption.
+apply Rle_lt_trans with
+ (RiemannInt (RiemannInt_P14 (b + h0) b (eps / 2)) * Rabs (/ h0)).
+do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+apply Rabs_pos.
+apply RiemannInt_P19.
+left; assumption.
+intros; replace (f x2 + -1 * fct_cte (f b) x2) with (f x2 - f b).
+unfold fct_cte in |- *; case (Req_dec b x2); intro.
+rewrite H16; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ left; assumption.
+elim H9; intros; left; apply H18.
+repeat split.
+assumption.
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right.
+apply Rplus_lt_reg_r with (x2 - x1);
+ replace (x2 - x1 + (b - x2)) with (b - x1); [ idtac | ring ].
+replace (x2 - x1 + x1) with x2; [ idtac | ring ].
+apply Rlt_le_trans with (b + h0).
+2: elim H15; intros; left; assumption.
+unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_cancel;
+ rewrite Ropp_involutive; apply Rle_lt_trans with (Rabs h0).
+rewrite <- Rabs_Ropp; apply RRle_abs.
+apply Rlt_le_trans with del;
+ [ assumption
+ | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a));
+    [ apply Rmin_r | apply Rmin_l ] ].
+apply Rle_ge; left; apply Rlt_Rminus; elim H15; intros; assumption.
+unfold fct_cte in |- *; ring.
+rewrite RiemannInt_P15.
+rewrite Rmult_assoc; replace ((b - (b + h0)) * Rabs (/ h0)) with 1.
+rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+       rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+rewrite Rabs_left.
+apply Rmult_eq_reg_l with h0;
+ [ do 2 rewrite (Rmult_comm h0); rewrite Rmult_assoc;
+    rewrite Ropp_mult_distr_l_reverse; rewrite <- Rinv_l_sym;
+    [ ring | assumption ]
+ | assumption ].
+apply Rinv_lt_0_compat; assumption.
+rewrite
+ (RiemannInt_P13 H13 (RiemannInt_P14 (b + h0) b (f b))
+    (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))
+ ; ring.
+unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
+rewrite RiemannInt_P15.
+rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_eq_reg_l with h0;
+ [ repeat rewrite (Rmult_comm h0); unfold Rdiv in |- *;
+    repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; 
+    [ ring | assumption ]
+ | assumption ].
+cut (a <= b + h0).
+cut (b + h0 <= b).
+intros; unfold primitive in |- *; case (Rle_dec a (b + h0));
+ case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b); 
+ intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
+rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r3 r2) H13 (FTC_P1 h C0 r1 r0)); ring.
+elim n; assumption.
+left; assumption.
+apply Rplus_le_reg_l with (- a - h0).
+replace (- a - h0 + a) with (- h0); [ idtac | ring ].
+replace (- a - h0 + (b + h0)) with (b - a); [ idtac | ring ].
+apply Rle_trans with del.
+apply Rle_trans with (Rabs h0).
+rewrite <- Rabs_Ropp; apply RRle_abs.
+left; assumption.
+unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
+cut (primitive h (FTC_P1 h C0) b = f_b b).
+intro; cut (primitive h (FTC_P1 h C0) (b + h0) = f_b (b + h0)).
+intro; rewrite H13; rewrite H14; apply H6.
+assumption.
+apply Rlt_le_trans with del;
+ [ assumption | unfold del in |- *; apply Rmin_l ].
+assert (H14 : b < b + h0).
+pattern b at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+assert (H14 := Rge_le _ _ r); elim H14; intro.
+assumption.
+elim H11; symmetry  in |- *; assumption.
+unfold primitive in |- *; case (Rle_dec a (b + h0));
+ case (Rle_dec (b + h0) b); intros;
+ [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14))
+ | unfold f_b in |- *; reflexivity
+ | elim n; left; apply Rlt_trans with b; assumption
+ | elim n0; left; apply Rlt_trans with b; assumption ].
+unfold f_b in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rmult_0_r; rewrite Rplus_0_l; unfold primitive in |- *;
+ case (Rle_dec a b); case (Rle_dec b b); intros;
+ [ apply RiemannInt_P5
+ | elim n; right; reflexivity
+ | elim n; left; assumption
+ | elim n; right; reflexivity ].
+(*****)
+set (f_a := fun x:R => f a * (x - a)); rewrite <- H2;
+ assert (H3 : derivable_pt_lim f_a a (f a)).
+unfold f_a in |- *;
+ change (derivable_pt_lim (fct_cte (f a) * (id - fct_cte a)%F) a (f a))
+  in |- *; pattern (f a) at 2 in |- *;
+ replace (f a) with (0 * (id - fct_cte a)%F a + fct_cte (f a) a * 1).
+apply derivable_pt_lim_mult.
+apply derivable_pt_lim_const.
+replace 1 with (1 - 0); [ idtac | ring ].
+apply derivable_pt_lim_minus.
+apply derivable_pt_lim_id.
+apply derivable_pt_lim_const.
+unfold fct_cte in |- *; ring.
+unfold derivable_pt_lim in |- *; intros; elim (H3 _ H4); intros.
+assert (H6 : continuity_pt f a).
+apply C0; split; [ right; reflexivity | left; assumption ].
+assert (H7 : 0 < eps / 2).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+elim (H6 _ H7); unfold D_x, no_cond, dist in |- *; simpl in |- *;
+ unfold R_dist in |- *; intros.
+set (del := Rmin x0 (Rmin x1 (b - a))).
+assert (H9 : 0 < del).
+unfold del in |- *; unfold Rmin in |- *.
+case (Rle_dec x1 (b - a)); intros.
+case (Rle_dec x0 x1); intro.
+apply (cond_pos x0).
+elim H8; intros; assumption.
+case (Rle_dec x0 (b - a)); intro.
+apply (cond_pos x0).
+apply Rlt_Rminus; assumption.
+split with (mkposreal _ H9).
+intros; case (Rcase_abs h0); intro.
+assert (H12 : a + h0 < a).
+pattern a at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+ assumption.
+unfold primitive in |- *.
+case (Rle_dec a (a + h0)); case (Rle_dec (a + h0) b); case (Rle_dec a a);
+ case (Rle_dec a b); intros;
+ try (elim n; left; assumption) || (elim n; right; reflexivity).
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H12)).
+elim n; left; apply Rlt_trans with a; assumption.
+rewrite RiemannInt_P9; replace 0 with (f_a a).
+replace (f a * (a + h0 - a)) with (f_a (a + h0)).
+apply H5; try assumption.
+apply Rlt_le_trans with del;
+ [ assumption | unfold del in |- *; apply Rmin_l ].
+unfold f_a in |- *; ring.
+unfold f_a in |- *; ring.
+elim n; left; apply Rlt_trans with a; assumption.
+assert (H12 : a < a + h0).
+pattern a at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+assert (H12 := Rge_le _ _ r); elim H12; intro.
+assumption.
+elim H10; symmetry  in |- *; assumption.
+assert (H13 : Riemann_integrable f a (a + h0)).
+apply continuity_implies_RiemannInt.
+left; assumption.
+intros; apply C0; elim H13; intros; split; try assumption.
+apply Rle_trans with (a + h0); try assumption.
+apply Rplus_le_reg_l with (- b - h0).
+replace (- b - h0 + b) with (- h0); [ idtac | ring ].
+replace (- b - h0 + (a + h0)) with (a - b); [ idtac | ring ].
+apply Ropp_le_cancel; rewrite Ropp_involutive; rewrite Ropp_minus_distr;
+ apply Rle_trans with del.
+apply Rle_trans with (Rabs h0); [ apply RRle_abs | left; assumption ].
+unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
+replace (primitive h (FTC_P1 h C0) (a + h0) - primitive h (FTC_P1 h C0) a)
+ with (RiemannInt H13).
+replace (f a) with (RiemannInt (RiemannInt_P14 a (a + h0) (f a)) / h0).
+replace
+ (RiemannInt H13 / h0 - RiemannInt (RiemannInt_P14 a (a + h0) (f a)) / h0)
+ with ((RiemannInt H13 - RiemannInt (RiemannInt_P14 a (a + h0) (f a))) / h0).
+replace (RiemannInt H13 - RiemannInt (RiemannInt_P14 a (a + h0) (f a))) with
+ (RiemannInt (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))).
+unfold Rdiv in |- *; rewrite Rabs_mult;
+ apply Rle_lt_trans with
+  (RiemannInt
+     (RiemannInt_P16
+        (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))) *
+   Rabs (/ h0)).
+do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+apply Rabs_pos.
+apply
+ (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))
+    (RiemannInt_P16
+       (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))); 
+ left; assumption.
+apply Rle_lt_trans with
+ (RiemannInt (RiemannInt_P14 a (a + h0) (eps / 2)) * Rabs (/ h0)).
+do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+apply Rabs_pos.
+apply RiemannInt_P19.
+left; assumption.
+intros; replace (f x2 + -1 * fct_cte (f a) x2) with (f x2 - f a).
+unfold fct_cte in |- *; case (Req_dec a x2); intro.
+rewrite H15; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ left; assumption.
+elim H8; intros; left; apply H17; repeat split.
+assumption.
+rewrite Rabs_right.
+apply Rplus_lt_reg_r with a; replace (a + (x2 - a)) with x2; [ idtac | ring ].
+apply Rlt_le_trans with (a + h0).
+elim H14; intros; assumption.
+apply Rplus_le_compat_l; left; apply Rle_lt_trans with (Rabs h0).
+apply RRle_abs.
+apply Rlt_le_trans with del;
+ [ assumption
+ | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a));
+    [ apply Rmin_r | apply Rmin_l ] ].
+apply Rle_ge; left; apply Rlt_Rminus; elim H14; intros; assumption.
+unfold fct_cte in |- *; ring.
+rewrite RiemannInt_P15.
+rewrite Rmult_assoc; replace ((a + h0 - a) * Rabs (/ h0)) with 1.
+rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+       rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+rewrite Rabs_right.
+rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
+ rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite <- Rinv_r_sym;
+ [ reflexivity | assumption ].
+apply Rle_ge; left; apply Rinv_0_lt_compat; assert (H14 := Rge_le _ _ r);
+ elim H14; intro.
+assumption.
+elim H10; symmetry  in |- *; assumption.
+rewrite
+ (RiemannInt_P13 H13 (RiemannInt_P14 a (a + h0) (f a))
+    (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))
+ ; ring.
+unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
+rewrite RiemannInt_P15.
+rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
+ rewrite Rplus_opp_r; rewrite Rplus_0_r; unfold Rdiv in |- *;
+ rewrite Rmult_assoc; rewrite <- Rinv_r_sym; [ ring | assumption ].
+cut (a <= a + h0).
+cut (a + h0 <= b).
+intros; unfold primitive in |- *; case (Rle_dec a (a + h0));
+ case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); 
+ intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
+rewrite RiemannInt_P9; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; apply RiemannInt_P5.
+elim n; assumption.
+elim n; assumption.
+2: left; assumption.
+apply Rplus_le_reg_l with (- a); replace (- a + (a + h0)) with h0;
+ [ idtac | ring ].
+rewrite Rplus_comm; apply Rle_trans with del;
+ [ apply Rle_trans with (Rabs h0); [ apply RRle_abs | left; assumption ]
+ | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r ].
+(*****)
+assert (H1 : x = a).
+rewrite <- H0 in H; elim H; intros; apply Rle_antisym; assumption.
+set (f_a := fun x:R => f a * (x - a)).
+assert (H2 : derivable_pt_lim f_a a (f a)).
+unfold f_a in |- *;
+ change (derivable_pt_lim (fct_cte (f a) * (id - fct_cte a)%F) a (f a))
+  in |- *; pattern (f a) at 2 in |- *;
+ replace (f a) with (0 * (id - fct_cte a)%F a + fct_cte (f a) a * 1).
+apply derivable_pt_lim_mult.
+apply derivable_pt_lim_const.
+replace 1 with (1 - 0); [ idtac | ring ].
+apply derivable_pt_lim_minus.
+apply derivable_pt_lim_id.
+apply derivable_pt_lim_const.
+unfold fct_cte in |- *; ring.
+set
+ (f_b := fun x:R => f b * (x - b) + RiemannInt (FTC_P1 h C0 h (Rle_refl b))).
+assert (H3 : derivable_pt_lim f_b b (f b)).
+unfold f_b in |- *; pattern (f b) at 2 in |- *; replace (f b) with (f b + 0).
+change
+  (derivable_pt_lim
+     ((fct_cte (f b) * (id - fct_cte b))%F +
+      fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b (
+     f b + 0)) in |- *. 
+apply derivable_pt_lim_plus.
+pattern (f b) at 2 in |- *;
+ replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1).
+apply derivable_pt_lim_mult.
+apply derivable_pt_lim_const.
+replace 1 with (1 - 0); [ idtac | ring ].
+apply derivable_pt_lim_minus.
+apply derivable_pt_lim_id.
+apply derivable_pt_lim_const.
+unfold fct_cte in |- *; ring.
+apply derivable_pt_lim_const.
+ring.
+unfold derivable_pt_lim in |- *; intros; elim (H2 _ H4); intros;
+ elim (H3 _ H4); intros; set (del := Rmin x0 x1).
+assert (H7 : 0 < del).
+unfold del in |- *; unfold Rmin in |- *; case (Rle_dec x0 x1); intro.
+apply (cond_pos x0).
+apply (cond_pos x1).
+split with (mkposreal _ H7); intros; case (Rcase_abs h0); intro.
+assert (H10 : a + h0 < a).
+pattern a at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+ assumption.
+rewrite H1; unfold primitive in |- *; case (Rle_dec a (a + h0));
+ case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); 
+ intros; try (elim n; right; assumption || reflexivity).
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H10)).
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)).
+rewrite RiemannInt_P9; replace 0 with (f_a a).
+replace (f a * (a + h0 - a)) with (f_a (a + h0)).
+apply H5; try assumption.
+apply Rlt_le_trans with del; try assumption.
+unfold del in |- *; apply Rmin_l.
+unfold f_a in |- *; ring.
+unfold f_a in |- *; ring.
+elim n; rewrite <- H0; left; assumption.
+assert (H10 : a < a + h0).
+pattern a at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+assert (H10 := Rge_le _ _ r); elim H10; intro.
+assumption.
+elim H8; symmetry  in |- *; assumption.
+rewrite H0 in H1; rewrite H1; unfold primitive in |- *;
+ case (Rle_dec a (b + h0)); case (Rle_dec (b + h0) b); 
+ case (Rle_dec a b); case (Rle_dec b b); intros;
+ try (elim n; right; assumption || reflexivity).
+rewrite H0 in H10; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)).
+repeat rewrite RiemannInt_P9.
+replace (RiemannInt (FTC_P1 h C0 r1 r0)) with (f_b b).
+fold (f_b (b + h0)) in |- *.
+apply H6; try assumption.
+apply Rlt_le_trans with del; try assumption.
+unfold del in |- *; apply Rmin_r.
+unfold f_b in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rmult_0_r; rewrite Rplus_0_l; apply RiemannInt_P5.
+elim n; rewrite <- H0; left; assumption.
+elim n0; rewrite <- H0; left; assumption.
+Qed.
+
+Lemma RiemannInt_P29 :
+ forall (f:R -> R) a b (h:a <= b)
+   (C0:forall x:R, a <= x <= b -> continuity_pt f x),
+   antiderivative f (primitive h (FTC_P1 h C0)) a b.
+intro f; intros; unfold antiderivative in |- *; split; try assumption; intros;
+ assert (H0 := RiemannInt_P28 h C0 H);
+ assert (H1 : derivable_pt (primitive h (FTC_P1 h C0)) x);
+ [ unfold derivable_pt in |- *; split with (f x); apply H0
+ | split with H1; symmetry  in |- *; apply derive_pt_eq_0; apply H0 ].
+Qed.
+
+Lemma RiemannInt_P30 :
+ forall (f:R -> R) (a b:R),
+   a <= b ->
+   (forall x:R, a <= x <= b -> continuity_pt f x) ->
+   sigT (fun g:R -> R => antiderivative f g a b).
+intros; split with (primitive H (FTC_P1 H H0)); apply RiemannInt_P29.
+Qed.
+
+Record C1_fun : Type := mkC1
+  {c1 :> R -> R; diff0 : derivable c1; cont1 : continuity (derive c1 diff0)}.
+
+Lemma RiemannInt_P31 :
+ forall (f:C1_fun) (a b:R),
+   a <= b -> antiderivative (derive f (diff0 f)) f a b.
+intro f; intros; unfold antiderivative in |- *; split; try assumption; intros;
+ split with (diff0 f x); reflexivity.
+Qed.
+
+Lemma RiemannInt_P32 :
+ forall (f:C1_fun) (a b:R), Riemann_integrable (derive f (diff0 f)) a b.
+intro f; intros; case (Rle_dec a b); intro;
+ [ apply continuity_implies_RiemannInt; try assumption; intros;
+    apply (cont1 f)
+ | assert (H : b <= a);
+    [ auto with real
+    | apply RiemannInt_P1; apply continuity_implies_RiemannInt;
+       try assumption; intros; apply (cont1 f) ] ].
+Qed.
+
+Lemma RiemannInt_P33 :
+ forall (f:C1_fun) (a b:R) (pr:Riemann_integrable (derive f (diff0 f)) a b),
+   a <= b -> RiemannInt pr = f b - f a.
+intro f; intros;
+ assert
+  (H0 : forall x:R, a <= x <= b -> continuity_pt (derive f (diff0 f)) x).
+intros; apply (cont1 f).
+rewrite (RiemannInt_P20 H (FTC_P1 H H0) pr);
+ assert (H1 := RiemannInt_P29 H H0); assert (H2 := RiemannInt_P31 f H);
+ elim (antiderivative_Ucte (derive f (diff0 f)) _ _ _ _ H1 H2); 
+ intros C H3; repeat rewrite H3;
+ [ ring
+ | split; [ right; reflexivity | assumption ]
+ | split; [ assumption | right; reflexivity ] ].
+Qed.
+
+Lemma FTC_Riemann :
+ forall (f:C1_fun) (a b:R) (pr:Riemann_integrable (derive f (diff0 f)) a b),
+   RiemannInt pr = f b - f a.
+intro f; intros; case (Rle_dec a b); intro;
+ [ apply RiemannInt_P33; assumption
+ | assert (H : b <= a);
+    [ auto with real
+    | assert (H0 := RiemannInt_P1 pr); rewrite (RiemannInt_P8 pr H0);
+       rewrite (RiemannInt_P33 _ H0 H); ring ] ].
+Qed.
diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v
new file mode 100644
index 00000000..0ae8f9f2
--- /dev/null
+++ b/theories/Reals/RiemannInt_SF.v
@@ -0,0 +1,2632 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: RiemannInt_SF.v,v 1.16.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Ranalysis.
+Require Import Classical_Prop.
+Open Local Scope R_scope.
+
+Set Implicit Arguments.
+
+(**************************************************)
+(* Each bounded subset of N has a maximal element *)
+(**************************************************)
+
+Definition Nbound (I:nat -> Prop) : Prop :=
+   exists n : nat, (forall i:nat, I i -> (i <= n)%nat).
+
+Lemma IZN_var : forall z:Z, (0 <= z)%Z -> {n : nat | z = Z_of_nat n}.
+intros; apply Z_of_nat_complete_inf; assumption.
+Qed.
+
+Lemma Nzorn :
+ forall I:nat -> Prop,
+   (exists n : nat, I n) ->
+   Nbound I -> sigT (fun n:nat => I n /\ (forall i:nat, I i -> (i <= n)%nat)).
+intros I H H0; set (E := fun x:R =>  exists i : nat, I i /\ INR i = x);
+ assert (H1 : bound E).
+unfold Nbound in H0; elim H0; intros N H1; unfold bound in |- *;
+ exists (INR N); unfold is_upper_bound in |- *; intros; 
+ unfold E in H2; elim H2; intros; elim H3; intros; 
+ rewrite <- H5; apply le_INR; apply H1; assumption.
+assert (H2 :  exists x : R, E x).
+elim H; intros; exists (INR x); unfold E in |- *; exists x; split;
+ [ assumption | reflexivity ].
+assert (H3 := completeness E H1 H2); elim H3; intros; unfold is_lub in p;
+ elim p; clear p; intros; unfold is_upper_bound in H4, H5;
+ assert (H6 : 0 <= x).
+elim H2; intros; unfold E in H6; elim H6; intros; elim H7; intros;
+ apply Rle_trans with x0;
+ [ rewrite <- H9; change (INR 0 <= INR x1) in |- *; apply le_INR;
+    apply le_O_n
+ | apply H4; assumption ].
+assert (H7 := archimed x); elim H7; clear H7; intros;
+ assert (H9 : x <= IZR (up x) - 1).
+apply H5; intros; assert (H10 := H4 _ H9); unfold E in H9; elim H9; intros;
+ elim H11; intros; rewrite <- H13; apply Rplus_le_reg_l with 1;
+ replace (1 + (IZR (up x) - 1)) with (IZR (up x)); 
+ [ idtac | ring ]; replace (1 + INR x1) with (INR (S x1));
+ [ idtac | rewrite S_INR; ring ].
+assert (H14 : (0 <= up x)%Z).
+apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ].
+assert (H15 := IZN _ H14); elim H15; clear H15; intros; rewrite H15;
+ rewrite <- INR_IZR_INZ; apply le_INR; apply lt_le_S; 
+ apply INR_lt; rewrite H13; apply Rle_lt_trans with x;
+ [ assumption | rewrite INR_IZR_INZ; rewrite <- H15; assumption ].
+assert (H10 : x = IZR (up x) - 1).
+apply Rle_antisym;
+ [ assumption
+ | apply Rplus_le_reg_l with (- x + 1);
+    replace (- x + 1 + (IZR (up x) - 1)) with (IZR (up x) - x);
+    [ idtac | ring ]; replace (- x + 1 + x) with 1; 
+    [ assumption | ring ] ].
+assert (H11 : (0 <= up x)%Z).
+apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ].
+assert (H12 := IZN_var H11); elim H12; clear H12; intros; assert (H13 : E x).
+elim (classic (E x)); intro; try assumption.
+cut (forall y:R, E y -> y <= x - 1).
+intro; assert (H14 := H5 _ H13); cut (x - 1 < x).
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H15)).
+apply Rminus_lt; replace (x - 1 - x) with (-1); [ idtac | ring ];
+ rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply Rlt_0_1.
+intros; assert (H14 := H4 _ H13); elim H14; intro; unfold E in H13; elim H13;
+ intros; elim H16; intros; apply Rplus_le_reg_l with 1.
+replace (1 + (x - 1)) with x; [ idtac | ring ]; rewrite <- H18;
+ replace (1 + INR x1) with (INR (S x1)); [ idtac | rewrite S_INR; ring ].
+cut (x = INR (pred x0)).
+intro; rewrite H19; apply le_INR; apply lt_le_S; apply INR_lt; rewrite H18;
+ rewrite <- H19; assumption.
+rewrite H10; rewrite p; rewrite <- INR_IZR_INZ; replace 1 with (INR 1);
+ [ idtac | reflexivity ]; rewrite <- minus_INR.
+replace (x0 - 1)%nat with (pred x0);
+ [ reflexivity
+ | case x0; [ reflexivity | intro; simpl in |- *; apply minus_n_O ] ].
+induction  x0 as [| x0 Hrecx0];
+ [ rewrite p in H7; rewrite <- INR_IZR_INZ in H7; simpl in H7;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H7))
+ | apply le_n_S; apply le_O_n ].
+rewrite H15 in H13; elim H12; assumption.
+split with (pred x0); unfold E in H13; elim H13; intros; elim H12; intros;
+ rewrite H10 in H15; rewrite p in H15; rewrite <- INR_IZR_INZ in H15;
+ assert (H16 : INR x0 = INR x1 + 1).
+rewrite H15; ring.
+rewrite <- S_INR in H16; assert (H17 := INR_eq _ _ H16); rewrite H17;
+ simpl in |- *; split.
+assumption.
+intros; apply INR_le; rewrite H15; rewrite <- H15; elim H12; intros;
+ rewrite H20; apply H4; unfold E in |- *; exists i; 
+ split; [ assumption | reflexivity ].
+Qed.
+
+(*******************************************)
+(*             Step functions              *)
+(*******************************************)
+
+Definition open_interval (a b x:R) : Prop := a < x < b.
+Definition co_interval (a b x:R) : Prop := a <= x < b. 
+
+Definition adapted_couple (f:R -> R) (a b:R) (l lf:Rlist) : Prop :=
+  ordered_Rlist l /\
+  pos_Rl l 0 = Rmin a b /\
+  pos_Rl l (pred (Rlength l)) = Rmax a b /\
+  Rlength l = S (Rlength lf) /\
+  (forall i:nat,
+     (i < pred (Rlength l))%nat ->
+     constant_D_eq f (open_interval (pos_Rl l i) (pos_Rl l (S i)))
+       (pos_Rl lf i)).
+
+Definition adapted_couple_opt (f:R -> R) (a b:R) (l lf:Rlist) :=
+  adapted_couple f a b l lf /\
+  (forall i:nat,
+     (i < pred (Rlength lf))%nat ->
+     pos_Rl lf i <> pos_Rl lf (S i) \/ f (pos_Rl l (S i)) <> pos_Rl lf i) /\
+  (forall i:nat, (i < pred (Rlength l))%nat -> pos_Rl l i <> pos_Rl l (S i)).
+
+Definition is_subdivision (f:R -> R) (a b:R) (l:Rlist) : Type :=
+  sigT (fun l0:Rlist => adapted_couple f a b l l0).
+
+Definition IsStepFun (f:R -> R) (a b:R) : Type :=
+  sigT (fun l:Rlist => is_subdivision f a b l).
+
+(* Class of step functions *)
+Record StepFun (a b:R) : Type := mkStepFun
+  {fe :> R -> R; pre : IsStepFun fe a b}.
+
+Definition subdivision (a b:R) (f:StepFun a b) : Rlist := projT1 (pre f).
+
+Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist :=
+  match projT2 (pre f) with
+  | existT a b => a
+  end.
+
+Fixpoint Int_SF (l k:Rlist) {struct l} : R :=
+  match l with
+  | nil => 0
+  | cons a l' =>
+      match k with
+      | nil => 0
+      | cons x nil => 0
+      | cons x (cons y k') => a * (y - x) + Int_SF l' (cons y k')
+      end
+  end.
+
+(* Integral of step functions *)
+Definition RiemannInt_SF (a b:R) (f:StepFun a b) : R :=
+  match Rle_dec a b with
+  | left _ => Int_SF (subdivision_val f) (subdivision f)
+  | right _ => - Int_SF (subdivision_val f) (subdivision f)
+  end.
+
+(********************************)
+(* Properties of step functions *)
+(********************************)
+
+Lemma StepFun_P1 :
+ forall (a b:R) (f:StepFun a b),
+   adapted_couple f a b (subdivision f) (subdivision_val f).
+intros a b f; unfold subdivision_val in |- *; case (projT2 (pre f)); intros;
+ apply a0.
+Qed.
+
+Lemma StepFun_P2 :
+ forall (a b:R) (f:R -> R) (l lf:Rlist),
+   adapted_couple f a b l lf -> adapted_couple f b a l lf.
+unfold adapted_couple in |- *; intros; decompose [and] H; clear H;
+ repeat split; try assumption.
+rewrite H2; unfold Rmin in |- *; case (Rle_dec a b); intro;
+ case (Rle_dec b a); intro; try reflexivity.
+apply Rle_antisym; assumption.
+apply Rle_antisym; auto with real.
+rewrite H1; unfold Rmax in |- *; case (Rle_dec a b); intro;
+ case (Rle_dec b a); intro; try reflexivity.
+apply Rle_antisym; assumption.
+apply Rle_antisym; auto with real.
+Qed.
+
+Lemma StepFun_P3 :
+ forall a b c:R,
+   a <= b ->
+   adapted_couple (fct_cte c) a b (cons a (cons b nil)) (cons c nil).
+intros; unfold adapted_couple in |- *; repeat split.
+unfold ordered_Rlist in |- *; intros; simpl in H0; inversion H0;
+ [ simpl in |- *; assumption | elim (le_Sn_O _ H2) ].
+simpl in |- *; unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+simpl in |- *; unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+unfold constant_D_eq, open_interval in |- *; intros; simpl in H0;
+ inversion H0; [ reflexivity | elim (le_Sn_O _ H3) ].
+Qed.
+
+Lemma StepFun_P4 : forall a b c:R, IsStepFun (fct_cte c) a b.
+intros; unfold IsStepFun in |- *; case (Rle_dec a b); intro.
+apply existT with (cons a (cons b nil)); unfold is_subdivision in |- *;
+ apply existT with (cons c nil); apply (StepFun_P3 c r).
+apply existT with (cons b (cons a nil)); unfold is_subdivision in |- *;
+ apply existT with (cons c nil); apply StepFun_P2; 
+ apply StepFun_P3; auto with real.
+Qed.
+
+Lemma StepFun_P5 :
+ forall (a b:R) (f:R -> R) (l:Rlist),
+   is_subdivision f a b l -> is_subdivision f b a l.
+unfold is_subdivision in |- *; intros; elim X; intros; exists x;
+ unfold adapted_couple in p; decompose [and] p; clear p;
+ unfold adapted_couple in |- *; repeat split; try assumption.
+rewrite H1; unfold Rmin in |- *; case (Rle_dec a b); intro;
+ case (Rle_dec b a); intro; try reflexivity.
+apply Rle_antisym; assumption.
+apply Rle_antisym; auto with real.
+rewrite H0; unfold Rmax in |- *; case (Rle_dec a b); intro;
+ case (Rle_dec b a); intro; try reflexivity.
+apply Rle_antisym; assumption.
+apply Rle_antisym; auto with real.
+Qed.
+
+Lemma StepFun_P6 :
+ forall (f:R -> R) (a b:R), IsStepFun f a b -> IsStepFun f b a.
+unfold IsStepFun in |- *; intros; elim X; intros; apply existT with x;
+ apply StepFun_P5; assumption.
+Qed.
+
+Lemma StepFun_P7 :
+ forall (a b r1 r2 r3:R) (f:R -> R) (l lf:Rlist),
+   a <= b ->
+   adapted_couple f a b (cons r1 (cons r2 l)) (cons r3 lf) ->
+   adapted_couple f r2 b (cons r2 l) lf.
+unfold adapted_couple in |- *; intros; decompose [and] H0; clear H0;
+ assert (H5 : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+assert (H7 : r2 <= b).
+rewrite H5 in H2; rewrite <- H2; apply RList_P7;
+ [ assumption | simpl in |- *; right; left; reflexivity ].
+repeat split.
+apply RList_P4 with r1; assumption.
+rewrite H5 in H2; unfold Rmin in |- *; case (Rle_dec r2 b); intro;
+ [ reflexivity | elim n; assumption ].
+unfold Rmax in |- *; case (Rle_dec r2 b); intro;
+ [ rewrite H5 in H2; rewrite <- H2; reflexivity | elim n; assumption ].
+simpl in H4; simpl in |- *; apply INR_eq; apply Rplus_eq_reg_l with 1;
+ do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR; 
+ rewrite H4; reflexivity.
+intros; unfold constant_D_eq, open_interval in |- *; intros;
+ unfold constant_D_eq, open_interval in H6;
+ assert (H9 : (S i < pred (Rlength (cons r1 (cons r2 l))))%nat).
+simpl in |- *; simpl in H0; apply lt_n_S; assumption.
+assert (H10 := H6 _ H9); apply H10; assumption.
+Qed.
+
+Lemma StepFun_P8 :
+ forall (f:R -> R) (l1 lf1:Rlist) (a b:R),
+   adapted_couple f a b l1 lf1 -> a = b -> Int_SF lf1 l1 = 0.
+simple induction l1.
+intros; induction  lf1 as [| r lf1 Hreclf1]; reflexivity.
+simple induction r0.
+intros; induction  lf1 as [| r1 lf1 Hreclf1].
+reflexivity.
+unfold adapted_couple in H0; decompose [and] H0; clear H0; simpl in H5;
+ discriminate.
+intros; induction  lf1 as [| r3 lf1 Hreclf1].
+reflexivity.
+simpl in |- *; cut (r = r1).
+intro; rewrite H3; rewrite (H0 lf1 r b).
+ring.
+rewrite H3; apply StepFun_P7 with a r r3; [ right; assumption | assumption ].
+clear H H0 Hreclf1 r0; unfold adapted_couple in H1; decompose [and] H1;
+ intros; simpl in H4; rewrite H4; unfold Rmin in |- *; 
+ case (Rle_dec a b); intro; [ assumption | reflexivity ].
+unfold adapted_couple in H1; decompose [and] H1; intros; apply Rle_antisym.
+apply (H3 0%nat); simpl in |- *; apply lt_O_Sn.
+simpl in H5; rewrite H2 in H5; rewrite H5; replace (Rmin b b) with (Rmax a b);
+ [ rewrite <- H4; apply RList_P7;
+    [ assumption | simpl in |- *; right; left; reflexivity ]
+ | unfold Rmin, Rmax in |- *; case (Rle_dec b b); case (Rle_dec a b); intros;
+    try assumption || reflexivity ].
+Qed.
+
+Lemma StepFun_P9 :
+ forall (a b:R) (f:R -> R) (l lf:Rlist),
+   adapted_couple f a b l lf -> a <> b -> (2 <= Rlength l)%nat.
+intros; unfold adapted_couple in H; decompose [and] H; clear H;
+ induction  l as [| r l Hrecl];
+ [ simpl in H4; discriminate
+ | induction  l as [| r0 l Hrecl0];
+    [ simpl in H3; simpl in H2; generalize H3; generalize H2;
+       unfold Rmin, Rmax in |- *; case (Rle_dec a b); 
+       intros; elim H0; rewrite <- H5; rewrite <- H7; 
+       reflexivity
+    | simpl in |- *; do 2 apply le_n_S; apply le_O_n ] ].
+Qed.
+
+Lemma StepFun_P10 :
+ forall (f:R -> R) (l lf:Rlist) (a b:R),
+   a <= b ->
+   adapted_couple f a b l lf ->
+    exists l' : Rlist,
+     (exists lf' : Rlist, adapted_couple_opt f a b l' lf').
+simple induction l.
+intros; unfold adapted_couple in H0; decompose [and] H0; simpl in H4;
+ discriminate.
+intros; case (Req_dec a b); intro.
+exists (cons a nil); exists nil; unfold adapted_couple_opt in |- *;
+ unfold adapted_couple in |- *; unfold ordered_Rlist in |- *; 
+ repeat split; try (intros; simpl in H3; elim (lt_n_O _ H3)).
+simpl in |- *; rewrite <- H2; unfold Rmin in |- *; case (Rle_dec a a); intro;
+ reflexivity.
+simpl in |- *; rewrite <- H2; unfold Rmax in |- *; case (Rle_dec a a); intro;
+ reflexivity.
+elim (RList_P20 _ (StepFun_P9 H1 H2)); intros t1 [t2 [t3 H3]];
+ induction  lf as [| r1 lf Hreclf].
+unfold adapted_couple in H1; decompose [and] H1; rewrite H3 in H7;
+ simpl in H7; discriminate.
+clear Hreclf; assert (H4 : adapted_couple f t2 b r0 lf).
+rewrite H3 in H1; assert (H4 := RList_P21 _ _ H3); simpl in H4; rewrite H4;
+ eapply StepFun_P7; [ apply H0 | apply H1 ].
+cut (t2 <= b).
+intro; assert (H6 := H _ _ _ H5 H4); case (Req_dec t1 t2); intro Hyp_eq.
+replace a with t2.
+apply H6.
+rewrite <- Hyp_eq; rewrite H3 in H1; unfold adapted_couple in H1;
+ decompose [and] H1; clear H1; simpl in H9; rewrite H9; 
+ unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+elim H6; clear H6; intros l' [lf' H6]; case (Req_dec t2 b); intro.
+exists (cons a (cons b nil)); exists (cons r1 nil);
+ unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+ repeat split.
+unfold ordered_Rlist in |- *; intros; simpl in H8; inversion H8;
+ [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
+simpl in |- *; unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+simpl in |- *; unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+intros; simpl in H8; inversion H8.
+unfold constant_D_eq, open_interval in |- *; intros; simpl in |- *;
+ simpl in H9; rewrite H3 in H1; unfold adapted_couple in H1;
+ decompose [and] H1; apply (H16 0%nat).
+simpl in |- *; apply lt_O_Sn.
+unfold open_interval in |- *; simpl in |- *; rewrite H7; simpl in H13;
+ rewrite H13; unfold Rmin in |- *; case (Rle_dec a b); 
+ intro; [ assumption | elim n; assumption ].
+elim (le_Sn_O _ H10).
+intros; simpl in H8; elim (lt_n_O _ H8).
+intros; simpl in H8; inversion H8;
+ [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
+assert (Hyp_min : Rmin t2 b = t2).
+unfold Rmin in |- *; case (Rle_dec t2 b); intro;
+ [ reflexivity | elim n; assumption ].
+unfold adapted_couple in H6; elim H6; clear H6; intros;
+ elim (RList_P20 _ (StepFun_P9 H6 H7)); intros s1 [s2 [s3 H9]];
+ induction  lf' as [| r2 lf' Hreclf'].
+unfold adapted_couple in H6; decompose [and] H6; rewrite H9 in H13;
+ simpl in H13; discriminate.
+clear Hreclf'; case (Req_dec r1 r2); intro.
+case (Req_dec (f t2) r1); intro.
+exists (cons t1 (cons s2 s3)); exists (cons r1 lf'); rewrite H3 in H1;
+ rewrite H9 in H6; unfold adapted_couple in H6, H1; 
+ decompose [and] H1; decompose [and] H6; clear H1 H6;
+ unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+ repeat split.
+unfold ordered_Rlist in |- *; intros; simpl in H1;
+ induction  i as [| i Hreci].
+simpl in |- *; apply Rle_trans with s1.
+replace s1 with t2.
+apply (H12 0%nat).
+simpl in |- *; apply lt_O_Sn.
+simpl in H19; rewrite H19; symmetry  in |- *; apply Hyp_min.
+apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
+change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i)) in |- *;
+ apply (H16 (S i)); simpl in |- *; assumption.
+simpl in |- *; simpl in H14; rewrite H14; reflexivity.
+simpl in |- *; simpl in H18; rewrite H18; unfold Rmax in |- *;
+ case (Rle_dec a b); case (Rle_dec t2 b); intros; reflexivity || elim n;
+ assumption.
+simpl in |- *; simpl in H20; apply H20.
+intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
+ induction  i as [| i Hreci].
+simpl in |- *; simpl in H6; case (total_order_T x t2); intro.
+elim s; intro.
+apply (H17 0%nat);
+ [ simpl in |- *; apply lt_O_Sn
+ | unfold open_interval in |- *; simpl in |- *; elim H6; intros; split;
+    assumption ].
+rewrite b0; assumption.
+rewrite H10; apply (H22 0%nat);
+ [ simpl in |- *; apply lt_O_Sn
+ | unfold open_interval in |- *; simpl in |- *; replace s1 with t2;
+    [ elim H6; intros; split; assumption
+    | simpl in H19; rewrite H19; rewrite Hyp_min; reflexivity ] ].
+simpl in |- *; simpl in H6; apply (H22 (S i));
+ [ simpl in |- *; assumption
+ | unfold open_interval in |- *; simpl in |- *; apply H6 ].
+intros; simpl in H1; rewrite H10;
+ change
+   (pos_Rl (cons r2 lf') i <> pos_Rl (cons r2 lf') (S i) \/
+    f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r2 lf') i)
+  in |- *; rewrite <- H9; elim H8; intros; apply H6; 
+ simpl in |- *; apply H1.
+intros; induction  i as [| i Hreci].
+simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
+apply (H12 0%nat); simpl in |- *; apply lt_O_Sn.
+rewrite <- Hyp_min; rewrite H6; simpl in H19; rewrite <- H19;
+ apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
+elim H8; intros; rewrite H9 in H21; apply (H21 (S i)); simpl in |- *;
+ simpl in H1; apply H1.
+exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6;
+ rewrite H3 in H1; unfold adapted_couple in H1, H6; 
+ decompose [and] H6; decompose [and] H1; clear H6 H1;
+ unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+ repeat split.
+rewrite H9; unfold ordered_Rlist in |- *; intros; simpl in H1;
+ induction  i as [| i Hreci].
+simpl in |- *; replace s1 with t2.
+apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
+simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
+change
+  (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i))
+ in |- *; apply (H12 i); simpl in |- *; apply lt_S_n; 
+ assumption.
+simpl in |- *; simpl in H19; apply H19.
+rewrite H9; simpl in |- *; simpl in H13; rewrite H13; unfold Rmax in |- *;
+ case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n;
+ assumption.
+rewrite H9; simpl in |- *; simpl in H15; rewrite H15; reflexivity.
+intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
+ induction  i as [| i Hreci].
+simpl in |- *; rewrite H9 in H6; simpl in H6; apply (H22 0%nat).
+simpl in |- *; apply lt_O_Sn.
+unfold open_interval in |- *; simpl in |- *.
+replace t2 with s1.
+assumption.
+simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
+change (f x = pos_Rl (cons r2 lf') i) in |- *; clear Hreci; apply (H17 i).
+simpl in |- *; rewrite H9 in H1; simpl in H1; apply lt_S_n; apply H1.
+rewrite H9 in H6; unfold open_interval in |- *; apply H6.
+intros; simpl in H1; induction  i as [| i Hreci].
+simpl in |- *; rewrite H9; right; simpl in |- *; replace s1 with t2.
+assumption.
+simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
+elim H8; intros; apply (H6 i).
+simpl in |- *; apply lt_S_n; apply H1.
+intros; rewrite H9; induction  i as [| i Hreci].
+simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
+apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
+rewrite <- Hyp_min; rewrite H6; simpl in H14; rewrite <- H14; right;
+ reflexivity.
+elim H8; intros; rewrite <- H9; apply (H21 i); rewrite H9; rewrite H9 in H1;
+ simpl in |- *; simpl in H1; apply lt_S_n; apply H1.
+exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6;
+ rewrite H3 in H1; unfold adapted_couple in H1, H6; 
+ decompose [and] H6; decompose [and] H1; clear H6 H1;
+ unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+ repeat split.
+rewrite H9; unfold ordered_Rlist in |- *; intros; simpl in H1;
+ induction  i as [| i Hreci].
+simpl in |- *; replace s1 with t2.
+apply (H15 0%nat); simpl in |- *; apply lt_O_Sn.
+simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity.
+change
+  (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i))
+ in |- *; apply (H11 i); simpl in |- *; apply lt_S_n; 
+ assumption.
+simpl in |- *; simpl in H18; apply H18.
+rewrite H9; simpl in |- *; simpl in H12; rewrite H12; unfold Rmax in |- *;
+ case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n;
+ assumption.
+rewrite H9; simpl in |- *; simpl in H14; rewrite H14; reflexivity.
+intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
+ induction  i as [| i Hreci].
+simpl in |- *; rewrite H9 in H6; simpl in H6; apply (H21 0%nat).
+simpl in |- *; apply lt_O_Sn.
+unfold open_interval in |- *; simpl in |- *; replace t2 with s1.
+assumption.
+simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity.
+change (f x = pos_Rl (cons r2 lf') i) in |- *; clear Hreci; apply (H16 i).
+simpl in |- *; rewrite H9 in H1; simpl in H1; apply lt_S_n; apply H1.
+rewrite H9 in H6; unfold open_interval in |- *; apply H6.
+intros; simpl in H1; induction  i as [| i Hreci].
+simpl in |- *; left; assumption.
+elim H8; intros; apply (H6 i).
+simpl in |- *; apply lt_S_n; apply H1.
+intros; rewrite H9; induction  i as [| i Hreci].
+simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
+apply (H15 0%nat); simpl in |- *; apply lt_O_Sn.
+rewrite <- Hyp_min; rewrite H6; simpl in H13; rewrite <- H13; right;
+ reflexivity.
+elim H8; intros; rewrite <- H9; apply (H20 i); rewrite H9; rewrite H9 in H1;
+ simpl in |- *; simpl in H1; apply lt_S_n; apply H1.
+rewrite H3 in H1; clear H4; unfold adapted_couple in H1; decompose [and] H1;
+ clear H1; clear H H7 H9; cut (Rmax a b = b);
+ [ intro; rewrite H in H5; rewrite <- H5; apply RList_P7;
+    [ assumption | simpl in |- *; right; left; reflexivity ]
+ | unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ] ].
+Qed.
+
+Lemma StepFun_P11 :
+ forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) 
+   (f:R -> R),
+   a < b ->
+   adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) ->
+   adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2.
+intros; unfold adapted_couple_opt in H1; elim H1; clear H1; intros;
+ unfold adapted_couple in H0, H1; decompose [and] H0; 
+ decompose [and] H1; clear H0 H1; assert (H12 : r = s1).
+simpl in H10; simpl in H5; rewrite H10; rewrite H5; reflexivity.
+assert (H14 := H3 0%nat (lt_O_Sn _)); simpl in H14; elim H14; intro.
+assert (H15 := H7 0%nat (lt_O_Sn _)); simpl in H15; elim H15; intro.
+rewrite <- H12 in H1; case (Rle_dec r1 s2); intro; try assumption.
+assert (H16 : s2 < r1); auto with real.
+induction  s3 as [| r0 s3 Hrecs3].
+simpl in H9; rewrite H9 in H16; cut (r1 <= Rmax a b).
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H17 H16)).
+rewrite <- H4; apply RList_P7;
+ [ assumption | simpl in |- *; right; left; reflexivity ].
+clear Hrecs3; induction  lf2 as [| r5 lf2 Hreclf2].
+simpl in H11; discriminate.
+clear Hreclf2; assert (H17 : r3 = r4).
+set (x := (r + s2) / 2); assert (H17 := H8 0%nat (lt_O_Sn _));
+ assert (H18 := H13 0%nat (lt_O_Sn _));
+ unfold constant_D_eq, open_interval in H17, H18; simpl in H17; 
+ simpl in H18; rewrite <- (H17 x).
+rewrite <- (H18 x).
+reflexivity.
+rewrite <- H12; unfold x in |- *; split.
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite (Rplus_comm r); rewrite double;
+       apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+unfold x in |- *; split.
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+apply Rlt_trans with s2;
+ [ apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+    | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+       rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+       [ rewrite Rmult_1_l; rewrite (Rplus_comm r); rewrite double;
+          apply Rplus_lt_compat_l; assumption
+       | discrR ] ]
+ | assumption ].
+assert (H18 : f s2 = r3).
+apply (H8 0%nat);
+ [ simpl in |- *; apply lt_O_Sn
+ | unfold open_interval in |- *; simpl in |- *; split; assumption ].
+assert (H19 : r3 = r5).
+assert (H19 := H7 1%nat); simpl in H19;
+ assert (H20 := H19 (lt_n_S _ _ (lt_O_Sn _))); elim H20; 
+ intro.
+set (x := (s2 + Rmin r1 r0) / 2); assert (H22 := H8 0%nat);
+ assert (H23 := H13 1%nat); simpl in H22; simpl in H23;
+ rewrite <- (H22 (lt_O_Sn _) x).
+rewrite <- (H23 (lt_n_S _ _ (lt_O_Sn _)) x).
+reflexivity.
+unfold open_interval in |- *; simpl in |- *; unfold x in |- *; split.
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
+       unfold Rmin in |- *; case (Rle_dec r1 r0); intro; 
+       assumption
+    | discrR ] ].
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double;
+       apply Rlt_le_trans with (r0 + Rmin r1 r0);
+       [ do 2 rewrite <- (Rplus_comm (Rmin r1 r0)); apply Rplus_lt_compat_l;
+          assumption
+       | apply Rplus_le_compat_l; apply Rmin_r ]
+    | discrR ] ].
+unfold open_interval in |- *; simpl in |- *; unfold x in |- *; split.
+apply Rlt_trans with s2;
+ [ assumption
+ | apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+    | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+       rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+       [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
+          unfold Rmin in |- *; case (Rle_dec r1 r0); 
+          intro; assumption
+       | discrR ] ] ].
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double;
+       apply Rlt_le_trans with (r1 + Rmin r1 r0);
+       [ do 2 rewrite <- (Rplus_comm (Rmin r1 r0)); apply Rplus_lt_compat_l;
+          assumption
+       | apply Rplus_le_compat_l; apply Rmin_l ]
+    | discrR ] ].
+elim H2; clear H2; intros; assert (H23 := H22 1%nat); simpl in H23;
+ assert (H24 := H23 (lt_n_S _ _ (lt_O_Sn _))); elim H24; 
+ assumption.
+elim H2; intros; assert (H22 := H20 0%nat); simpl in H22;
+ assert (H23 := H22 (lt_O_Sn _)); elim H23; intro;
+ [ elim H24; rewrite <- H17; rewrite <- H19; reflexivity
+ | elim H24; rewrite <- H17; assumption ].
+elim H2; clear H2; intros; assert (H17 := H16 0%nat); simpl in H17;
+ elim (H17 (lt_O_Sn _)); assumption.
+rewrite <- H0; rewrite H12; apply (H7 0%nat); simpl in |- *; apply lt_O_Sn.
+Qed.
+
+Lemma StepFun_P12 :
+ forall (a b:R) (f:R -> R) (l lf:Rlist),
+   adapted_couple_opt f a b l lf -> adapted_couple_opt f b a l lf.
+unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; intros;
+ decompose [and] H; clear H; repeat split; try assumption.
+rewrite H0; unfold Rmin in |- *; case (Rle_dec a b); intro;
+ case (Rle_dec b a); intro; try reflexivity.
+apply Rle_antisym; assumption.
+apply Rle_antisym; auto with real.
+rewrite H3; unfold Rmax in |- *; case (Rle_dec a b); intro;
+ case (Rle_dec b a); intro; try reflexivity.
+apply Rle_antisym; assumption.
+apply Rle_antisym; auto with real.
+Qed.
+
+Lemma StepFun_P13 :
+ forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) 
+   (f:R -> R),
+   a <> b ->
+   adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) ->
+   adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2.
+intros; case (total_order_T a b); intro.
+elim s; intro.
+eapply StepFun_P11; [ apply a0 | apply H0 | apply H1 ].
+elim H; assumption.
+eapply StepFun_P11;
+ [ apply r0 | apply StepFun_P2; apply H0 | apply StepFun_P12; apply H1 ].
+Qed.
+
+Lemma StepFun_P14 :
+ forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R),
+   a <= b ->
+   adapted_couple f a b l1 lf1 ->
+   adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
+simple induction l1.
+intros l2 lf1 lf2 a b Hyp H H0; unfold adapted_couple in H; decompose [and] H;
+ clear H H0 H2 H3 H1 H6; simpl in H4; discriminate.
+simple induction r0.
+intros; case (Req_dec a b); intro.
+unfold adapted_couple_opt in H2; elim H2; intros; rewrite (StepFun_P8 H4 H3);
+ rewrite (StepFun_P8 H1 H3); reflexivity.
+assert (H4 := StepFun_P9 H1 H3); simpl in H4;
+ elim (le_Sn_O _ (le_S_n _ _ H4)).
+intros; clear H; unfold adapted_couple_opt in H3; elim H3; clear H3; intros;
+ case (Req_dec a b); intro.
+rewrite (StepFun_P8 H2 H4); rewrite (StepFun_P8 H H4); reflexivity.
+assert (Hyp_min : Rmin a b = a).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+assert (Hyp_max : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+elim (RList_P20 _ (StepFun_P9 H H4)); intros s1 [s2 [s3 H5]]; rewrite H5 in H;
+ rewrite H5; induction  lf1 as [| r3 lf1 Hreclf1].
+unfold adapted_couple in H2; decompose [and] H2;
+ clear H H2 H4 H5 H3 H6 H8 H7 H11; simpl in H9; discriminate.
+clear Hreclf1; induction  lf2 as [| r4 lf2 Hreclf2].
+unfold adapted_couple in H; decompose [and] H;
+ clear H H2 H4 H5 H3 H6 H8 H7 H11; simpl in H9; discriminate.
+clear Hreclf2; assert (H6 : r = s1).
+unfold adapted_couple in H, H2; decompose [and] H; decompose [and] H2;
+ clear H H2; simpl in H13; simpl in H8; rewrite H13; 
+ rewrite H8; reflexivity.
+assert (H7 : r3 = r4 \/ r = r1).
+case (Req_dec r r1); intro.
+right; assumption.
+left; cut (r1 <= s2).
+intro; unfold adapted_couple in H2, H; decompose [and] H; decompose [and] H2;
+ clear H H2; set (x := (r + r1) / 2); assert (H18 := H14 0%nat);
+ assert (H20 := H19 0%nat); unfold constant_D_eq, open_interval in H18, H20;
+ simpl in H18; simpl in H20; rewrite <- (H18 (lt_O_Sn _) x).
+rewrite <- (H20 (lt_O_Sn _) x).
+reflexivity.
+assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21; intro;
+ [ idtac | elim H7; assumption ]; unfold x in |- *; 
+ split.
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H
+    | discrR ] ].
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite <- (Rplus_comm r1); rewrite double;
+       apply Rplus_lt_compat_l; apply H
+    | discrR ] ].
+rewrite <- H6; assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21;
+ intro; [ idtac | elim H7; assumption ]; unfold x in |- *; 
+ split.
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H
+    | discrR ] ].
+apply Rlt_le_trans with r1;
+ [ apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+    | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+       rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+       [ rewrite Rmult_1_l; rewrite <- (Rplus_comm r1); rewrite double;
+          apply Rplus_lt_compat_l; apply H
+       | discrR ] ]
+ | assumption ].
+eapply StepFun_P13.
+apply H4.
+apply H2.
+unfold adapted_couple_opt in |- *; split.
+apply H.
+rewrite H5 in H3; apply H3.
+assert (H8 : r1 <= s2).
+eapply StepFun_P13.
+apply H4.
+apply H2.
+unfold adapted_couple_opt in |- *; split.
+apply H.
+rewrite H5 in H3; apply H3.
+elim H7; intro.
+simpl in |- *; elim H8; intro.
+replace (r4 * (s2 - s1)) with (r3 * (r1 - r) + r3 * (s2 - r1));
+ [ idtac | rewrite H9; rewrite H6; ring ].
+rewrite Rplus_assoc; apply Rplus_eq_compat_l;
+ change
+   (Int_SF lf1 (cons r1 r2) = Int_SF (cons r3 lf2) (cons r1 (cons s2 s3)))
+  in |- *; apply H0 with r1 b.
+unfold adapted_couple in H2; decompose [and] H2; clear H2;
+ replace b with (Rmax a b).
+rewrite <- H12; apply RList_P7;
+ [ assumption | simpl in |- *; right; left; reflexivity ].
+eapply StepFun_P7.
+apply H1.
+apply H2.
+unfold adapted_couple_opt in |- *; split.
+apply StepFun_P7 with a a r3.
+apply H1.
+unfold adapted_couple in H2, H; decompose [and] H2; decompose [and] H;
+ clear H H2; assert (H20 : r = a).
+simpl in H13; rewrite H13; apply Hyp_min.
+unfold adapted_couple in |- *; repeat split.
+unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
+simpl in |- *; rewrite <- H20; apply (H11 0%nat).
+simpl in |- *; apply lt_O_Sn.
+induction  i as [| i Hreci0].
+simpl in |- *; assumption.
+change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i)) in |- *;
+ apply (H15 (S i)); simpl in |- *; apply lt_S_n; assumption.
+simpl in |- *; symmetry  in |- *; apply Hyp_min.
+rewrite <- H17; reflexivity.
+simpl in H19; simpl in |- *; rewrite H19; reflexivity.
+intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
+ induction  i as [| i Hreci].
+simpl in |- *; apply (H16 0%nat).
+simpl in |- *; apply lt_O_Sn.
+simpl in H2; rewrite <- H20 in H2; unfold open_interval in |- *;
+ simpl in |- *; apply H2.
+clear Hreci; induction  i as [| i Hreci].
+simpl in |- *; simpl in H2; rewrite H9; apply (H21 0%nat).
+simpl in |- *; apply lt_O_Sn.
+unfold open_interval in |- *; simpl in |- *; elim H2; intros; split.
+apply Rle_lt_trans with r1; try assumption; rewrite <- H6; apply (H11 0%nat);
+ simpl in |- *; apply lt_O_Sn.
+assumption.
+clear Hreci; simpl in |- *; apply (H21 (S i)).
+simpl in |- *; apply lt_S_n; assumption.
+unfold open_interval in |- *; apply H2.
+elim H3; clear H3; intros; split.
+rewrite H9;
+ change
+   (forall i:nat,
+      (i < pred (Rlength (cons r4 lf2)))%nat ->
+      pos_Rl (cons r4 lf2) i <> pos_Rl (cons r4 lf2) (S i) \/
+      f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r4 lf2) i)
+  in |- *; rewrite <- H5; apply H3.
+rewrite H5 in H11; intros; simpl in H12; induction  i as [| i Hreci].
+simpl in |- *; red in |- *; intro; rewrite H13 in H10;
+ elim (Rlt_irrefl _ H10).
+clear Hreci; apply (H11 (S i)); simpl in |- *; apply H12.
+rewrite H9; rewrite H10; rewrite H6; apply Rplus_eq_compat_l; rewrite <- H10;
+ apply H0 with r1 b.
+unfold adapted_couple in H2; decompose [and] H2; clear H2;
+ replace b with (Rmax a b).
+rewrite <- H12; apply RList_P7;
+ [ assumption | simpl in |- *; right; left; reflexivity ].
+eapply StepFun_P7.
+apply H1.
+apply H2.
+unfold adapted_couple_opt in |- *; split.
+apply StepFun_P7 with a a r3.
+apply H1.
+unfold adapted_couple in H2, H; decompose [and] H2; decompose [and] H;
+ clear H H2; assert (H20 : r = a).
+simpl in H13; rewrite H13; apply Hyp_min.
+unfold adapted_couple in |- *; repeat split.
+unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
+simpl in |- *; rewrite <- H20; apply (H11 0%nat); simpl in |- *;
+ apply lt_O_Sn.
+rewrite H10; apply (H15 (S i)); simpl in |- *; assumption.
+simpl in |- *; symmetry  in |- *; apply Hyp_min.
+rewrite <- H17; rewrite H10; reflexivity.
+simpl in H19; simpl in |- *; apply H19.
+intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
+ induction  i as [| i Hreci].
+simpl in |- *; apply (H16 0%nat).
+simpl in |- *; apply lt_O_Sn.
+simpl in H2; rewrite <- H20 in H2; unfold open_interval in |- *;
+ simpl in |- *; apply H2.
+clear Hreci; simpl in |- *; apply (H21 (S i)).
+simpl in |- *; assumption.
+rewrite <- H10; unfold open_interval in |- *; apply H2.
+elim H3; clear H3; intros; split.
+rewrite H5 in H3; intros; apply (H3 (S i)).
+simpl in |- *; replace (Rlength lf2) with (S (pred (Rlength lf2))).
+apply lt_n_S; apply H12.
+symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+ intro; rewrite <- H13 in H12; elim (lt_n_O _ H12).
+intros; simpl in H12; rewrite H10; rewrite H5 in H11; apply (H11 (S i));
+ simpl in |- *; apply lt_n_S; apply H12.
+simpl in |- *; rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rmult_0_r; rewrite Rplus_0_l;
+ change
+   (Int_SF lf1 (cons r1 r2) = Int_SF (cons r4 lf2) (cons s1 (cons s2 s3)))
+  in |- *; eapply H0.
+apply H1.
+2: rewrite H5 in H3; unfold adapted_couple_opt in |- *; split; assumption.
+assert (H10 : r = a).
+unfold adapted_couple in H2; decompose [and] H2; clear H2; simpl in H12;
+ rewrite H12; apply Hyp_min.
+rewrite <- H9; rewrite H10; apply StepFun_P7 with a r r3;
+ [ apply H1
+ | pattern a at 2 in |- *; rewrite <- H10; pattern r at 2 in |- *; rewrite H9;
+    apply H2 ].
+Qed.
+
+Lemma StepFun_P15 :
+ forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R),
+   adapted_couple f a b l1 lf1 ->
+   adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
+intros; case (Rle_dec a b); intro;
+ [ apply (StepFun_P14 r H H0)
+ | assert (H1 : b <= a);
+    [ auto with real
+    | eapply StepFun_P14;
+       [ apply H1 | apply StepFun_P2; apply H | apply StepFun_P12; apply H0 ] ] ].
+Qed.
+
+Lemma StepFun_P16 :
+ forall (f:R -> R) (l lf:Rlist) (a b:R),
+   adapted_couple f a b l lf ->
+    exists l' : Rlist,
+     (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). 
+intros; case (Rle_dec a b); intro;
+ [ apply (StepFun_P10 r H)
+ | assert (H1 : b <= a);
+    [ auto with real
+    | assert (H2 := StepFun_P10 H1 (StepFun_P2 H)); elim H2;
+       intros l' [lf' H3]; exists l'; exists lf'; apply StepFun_P12;
+       assumption ] ].
+Qed.
+
+Lemma StepFun_P17 :
+ forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R),
+   adapted_couple f a b l1 lf1 ->
+   adapted_couple f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
+intros; elim (StepFun_P16 H); intros l' [lf' H1]; rewrite (StepFun_P15 H H1);
+ rewrite (StepFun_P15 H0 H1); reflexivity.
+Qed.
+
+Lemma StepFun_P18 :
+ forall a b c:R, RiemannInt_SF (mkStepFun (StepFun_P4 a b c)) = c * (b - a).
+intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+replace
+ (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c)))
+    (subdivision (mkStepFun (StepFun_P4 a b c)))) with
+ (Int_SF (cons c nil) (cons a (cons b nil)));
+ [ simpl in |- *; ring
+ | apply StepFun_P17 with (fct_cte c) a b;
+    [ apply StepFun_P3; assumption
+    | apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c))) ] ].
+replace
+ (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c)))
+    (subdivision (mkStepFun (StepFun_P4 a b c)))) with
+ (Int_SF (cons c nil) (cons b (cons a nil)));
+ [ simpl in |- *; ring
+ | apply StepFun_P17 with (fct_cte c) a b;
+    [ apply StepFun_P2; apply StepFun_P3; auto with real
+    | apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c))) ] ].
+Qed.
+
+Lemma StepFun_P19 :
+ forall (l1:Rlist) (f g:R -> R) (l:R),
+   Int_SF (FF l1 (fun x:R => f x + l * g x)) l1 =
+   Int_SF (FF l1 f) l1 + l * Int_SF (FF l1 g) l1.
+intros; induction  l1 as [| r l1 Hrecl1];
+ [ simpl in |- *; ring
+ | induction  l1 as [| r0 l1 Hrecl0]; simpl in |- *;
+    [ ring | simpl in Hrecl1; rewrite Hrecl1; ring ] ].
+Qed.
+
+Lemma StepFun_P20 :
+ forall (l:Rlist) (f:R -> R),
+   (0 < Rlength l)%nat -> Rlength l = S (Rlength (FF l f)).
+intros l f H; induction l;
+ [ elim (lt_irrefl _ H)
+ | simpl in |- *; rewrite RList_P18; rewrite RList_P14; reflexivity ].
+Qed.
+
+Lemma StepFun_P21 :
+ forall (a b:R) (f:R -> R) (l:Rlist),
+   is_subdivision f a b l -> adapted_couple f a b l (FF l f).
+intros; unfold adapted_couple in |- *; unfold is_subdivision in X;
+ unfold adapted_couple in X; elim X; clear X; intros; 
+ decompose [and] p; clear p; repeat split; try assumption.
+apply StepFun_P20; rewrite H2; apply lt_O_Sn.
+intros; assert (H5 := H4 _ H3); unfold constant_D_eq, open_interval in H5;
+ unfold constant_D_eq, open_interval in |- *; intros;
+ induction  l as [| r l Hrecl].
+discriminate.
+unfold FF in |- *; rewrite RList_P12.
+simpl in |- *;
+ change (f x0 = f (pos_Rl (mid_Rlist (cons r l) r) (S i))) in |- *;
+ rewrite RList_P13; try assumption; rewrite (H5 x0 H6); 
+ rewrite H5.
+reflexivity.
+split.
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; elim H6;
+       intros; apply Rlt_trans with x0; assumption
+    | discrR ] ].
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double;
+       rewrite (Rplus_comm (pos_Rl (cons r l) i)); 
+       apply Rplus_lt_compat_l; elim H6; intros; apply Rlt_trans with x0;
+       assumption
+    | discrR ] ].
+rewrite RList_P14; simpl in H3; apply H3.
+Qed.
+
+Lemma StepFun_P22 :
+ forall (a b:R) (f g:R -> R) (lf lg:Rlist),
+   a <= b ->
+   is_subdivision f a b lf ->
+   is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg).
+unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0;
+ clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+assert (Hyp_max : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+apply existT with (FF (cons_ORlist lf lg) f); unfold adapted_couple in p, p0;
+ decompose [and] p; decompose [and] p0; clear p p0; 
+ rewrite Hyp_min in H6; rewrite Hyp_min in H1; rewrite Hyp_max in H0;
+ rewrite Hyp_max in H5; unfold adapted_couple in |- *; 
+ repeat split.
+apply RList_P2; assumption.
+rewrite Hyp_min; symmetry  in |- *; apply Rle_antisym.
+induction  lf as [| r lf Hreclf].
+simpl in |- *; right; symmetry  in |- *; assumption.
+assert
+ (H10 :
+  In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)).
+elim
+ (RList_P3 (cons_ORlist (cons r lf) lg)
+    (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; 
+ apply H10; exists 0%nat; split;
+ [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ].
+elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0));
+ intros H12 _; assert (H13 := H12 H10); elim H13; intro.
+elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0));
+ intros H11 _; assert (H14 := H11 H8); elim H14; intros; 
+ elim H15; clear H15; intros; rewrite H15; rewrite <- H6;
+ elim (RList_P6 (cons r lf)); intros; apply H17;
+ [ assumption | apply le_O_n | assumption ].
+elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _;
+ assert (H14 := H11 H8); elim H14; intros; elim H15; 
+ clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); 
+ intros; apply H17; [ assumption | apply le_O_n | assumption ].
+induction  lf as [| r lf Hreclf].
+simpl in |- *; right; assumption.
+assert (H8 : In a (cons_ORlist (cons r lf) lg)).
+elim (RList_P9 (cons r lf) lg a); intros; apply H10; left;
+ elim (RList_P3 (cons r lf) a); intros; apply H12; 
+ exists 0%nat; split;
+ [ symmetry  in |- *; assumption | simpl in |- *; apply lt_O_Sn ].
+apply RList_P5; [ apply RList_P2; assumption | assumption ].
+rewrite Hyp_max; apply Rle_antisym.
+induction  lf as [| r lf Hreclf].
+simpl in |- *; right; assumption.
+assert
+ (H8 :
+  In
+    (pos_Rl (cons_ORlist (cons r lf) lg)
+       (pred (Rlength (cons_ORlist (cons r lf) lg))))
+    (cons_ORlist (cons r lf) lg)).
+elim
+ (RList_P3 (cons_ORlist (cons r lf) lg)
+    (pos_Rl (cons_ORlist (cons r lf) lg)
+       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+ intros _ H10; apply H10;
+ exists (pred (Rlength (cons_ORlist (cons r lf) lg))); 
+ split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ].
+elim
+ (RList_P9 (cons r lf) lg
+    (pos_Rl (cons_ORlist (cons r lf) lg)
+       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+ intros H10 _.
+assert (H11 := H10 H8); elim H11; intro.
+elim
+ (RList_P3 (cons r lf)
+    (pos_Rl (cons_ORlist (cons r lf) lg)
+       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+ intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+ elim H15; clear H15; intros; rewrite H15; rewrite <- H5;
+ elim (RList_P6 (cons r lf)); intros; apply H17;
+ [ assumption
+ | simpl in |- *; simpl in H14; apply lt_n_Sm_le; assumption
+ | simpl in |- *; apply lt_n_Sn ].
+elim
+ (RList_P3 lg
+    (pos_Rl (cons_ORlist (cons r lf) lg)
+       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+ intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+ elim H15; clear H15; intros.
+rewrite H15; assert (H17 : Rlength lg = S (pred (Rlength lg))).
+apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+ rewrite <- H17 in H16; elim (lt_n_O _ H16).
+rewrite <- H0; elim (RList_P6 lg); intros; apply H18;
+ [ assumption
+ | rewrite H17 in H16; apply lt_n_Sm_le; assumption
+ | apply lt_pred_n_n; rewrite H17; apply lt_O_Sn ].
+induction  lf as [| r lf Hreclf].
+simpl in |- *; right; symmetry  in |- *; assumption.
+assert (H8 : In b (cons_ORlist (cons r lf) lg)).
+elim (RList_P9 (cons r lf) lg b); intros; apply H10; left;
+ elim (RList_P3 (cons r lf) b); intros; apply H12;
+ exists (pred (Rlength (cons r lf))); split;
+ [ symmetry  in |- *; assumption | simpl in |- *; apply lt_n_Sn ].
+apply RList_P7; [ apply RList_P2; assumption | assumption ].
+apply StepFun_P20; rewrite RList_P11; rewrite H2; rewrite H7; simpl in |- *;
+ apply lt_O_Sn.
+intros; unfold constant_D_eq, open_interval in |- *; intros;
+ cut
+  (exists l : R,
+     constant_D_eq f
+       (open_interval (pos_Rl (cons_ORlist lf lg) i)
+          (pos_Rl (cons_ORlist lf lg) (S i))) l).
+intros; elim H11; clear H11; intros; assert (H12 := H11);
+ assert
+  (Hyp_cons :
+    exists r : R, (exists r0 : Rlist, cons_ORlist lf lg = cons r r0)).
+apply RList_P19; red in |- *; intro; rewrite H13 in H8; elim (lt_n_O _ H8).
+elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons;
+ unfold FF in |- *; rewrite RList_P12.
+change (f x = f (pos_Rl (mid_Rlist (cons r r0) r) (S i))) in |- *;
+ rewrite <- Hyp_cons; rewrite RList_P13.
+assert (H13 := RList_P2 _ _ H _ H8); elim H13; intro.
+unfold constant_D_eq, open_interval in H11, H12; rewrite (H11 x H10);
+ assert
+  (H15 :
+   pos_Rl (cons_ORlist lf lg) i <
+   (pos_Rl (cons_ORlist lf lg) i + pos_Rl (cons_ORlist lf lg) (S i)) / 2 <
+   pos_Rl (cons_ORlist lf lg) (S i)).
+split.
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double;
+       rewrite (Rplus_comm (pos_Rl (cons_ORlist lf lg) i));
+       apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+rewrite (H11 _ H15); reflexivity.
+elim H10; intros; rewrite H14 in H15;
+ elim (Rlt_irrefl _ (Rlt_trans _ _ _ H16 H15)).
+apply H8.
+rewrite RList_P14; rewrite Hyp_cons in H8; simpl in H8; apply H8.
+assert (H11 : a < b).
+apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i).
+rewrite <- H6; rewrite <- (RList_P15 lf lg).
+elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
+apply RList_P2; assumption.
+apply le_O_n.
+apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
+ [ assumption
+ | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
+    rewrite <- H13 in H8; elim (lt_n_O _ H8) ].
+assumption.
+assumption.
+rewrite H1; assumption.
+apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
+elim H10; intros; apply Rlt_trans with x; assumption.
+rewrite <- H5; rewrite <- (RList_P16 lf lg); try assumption.
+elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
+apply RList_P2; assumption.
+apply lt_n_Sm_le; apply lt_n_S; assumption.
+apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H8;
+ elim (lt_n_O _ H8).
+rewrite H0; assumption.
+set
+ (I :=
+  fun j:nat =>
+    pos_Rl lf j <= pos_Rl (cons_ORlist lf lg) i /\ (j < Rlength lf)%nat);
+ assert (H12 : Nbound I).
+unfold Nbound in |- *; exists (Rlength lf); intros; unfold I in H12; elim H12;
+ intros; apply lt_le_weak; assumption.
+assert (H13 :  exists n : nat, I n).
+exists 0%nat; unfold I in |- *; split.
+apply Rle_trans with (pos_Rl (cons_ORlist lf lg) 0).
+right; symmetry  in |- *.
+apply RList_P15; try assumption; rewrite H1; assumption.
+elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13.
+apply RList_P2; assumption.
+apply le_O_n.
+apply lt_trans with (pred (Rlength (cons_ORlist lf lg))).
+assumption.
+apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H15 in H8;
+ elim (lt_n_O _ H8).
+apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H5;
+ rewrite <- H6 in H11; rewrite <- H5 in H11; elim (Rlt_irrefl _ H11).
+assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14;
+ exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval in |- *; 
+ intros; assert (H16 := H9 x0); assert (H17 : (x0 < pred (Rlength lf))%nat).
+elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros;
+ apply lt_S_n; replace (S (pred (Rlength lf))) with (Rlength lf).
+inversion H18.
+2: apply lt_n_S; assumption.
+cut (x0 = pred (Rlength lf)).
+intro; rewrite H19 in H14; rewrite H5 in H14;
+ cut (pos_Rl (cons_ORlist lf lg) i < b).
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H21)).
+apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
+elim H10; intros; apply Rlt_trans with x; assumption.
+rewrite <- H5;
+ apply Rle_trans with
+  (pos_Rl (cons_ORlist lf lg) (pred (Rlength (cons_ORlist lf lg)))).
+elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21.
+apply RList_P2; assumption.
+apply lt_n_Sm_le; apply lt_n_S; assumption.
+apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H23 in H8;
+ elim (lt_n_O _ H8).
+right; apply RList_P16; try assumption; rewrite H0; assumption.
+rewrite <- H20; reflexivity.
+apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+ rewrite <- H19 in H18; elim (lt_n_O _ H18).
+assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
+ rewrite (H18 x1).
+reflexivity.
+elim H15; clear H15; intros; elim H14; clear H14; intros; unfold I in H14;
+ elim H14; clear H14; intros; split.
+apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); assumption.
+apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)); try assumption.
+assert (H22 : (S x0 < Rlength lf)%nat).
+replace (Rlength lf) with (S (pred (Rlength lf)));
+ [ apply lt_n_S; assumption
+ | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+    intro; rewrite <- H22 in H21; elim (lt_n_O _ H21) ].
+elim (Rle_dec (pos_Rl lf (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro.
+assert (H23 : (S x0 <= x0)%nat).
+apply H20; unfold I in |- *; split; assumption.
+elim (le_Sn_n _ H23).
+assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lf (S x0)).
+auto with real.
+clear b0; apply RList_P17; try assumption.
+apply RList_P2; assumption.
+elim (RList_P9 lf lg (pos_Rl lf (S x0))); intros; apply H25; left;
+ elim (RList_P3 lf (pos_Rl lf (S x0))); intros; apply H27; 
+ exists (S x0); split; [ reflexivity | apply H22 ].
+Qed.
+
+Lemma StepFun_P23 :
+ forall (a b:R) (f g:R -> R) (lf lg:Rlist),
+   is_subdivision f a b lf ->
+   is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg).
+intros; case (Rle_dec a b); intro;
+ [ apply StepFun_P22 with g; assumption
+ | apply StepFun_P5; apply StepFun_P22 with g;
+    [ auto with real
+    | apply StepFun_P5; assumption
+    | apply StepFun_P5; assumption ] ].
+Qed.
+
+Lemma StepFun_P24 :
+ forall (a b:R) (f g:R -> R) (lf lg:Rlist),
+   a <= b ->
+   is_subdivision f a b lf ->
+   is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg).
+unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0;
+ clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+assert (Hyp_max : Rmax a b = b).
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+apply existT with (FF (cons_ORlist lf lg) g); unfold adapted_couple in p, p0;
+ decompose [and] p; decompose [and] p0; clear p p0; 
+ rewrite Hyp_min in H1; rewrite Hyp_min in H6; rewrite Hyp_max in H0;
+ rewrite Hyp_max in H5; unfold adapted_couple in |- *; 
+ repeat split.
+apply RList_P2; assumption.
+rewrite Hyp_min; symmetry  in |- *; apply Rle_antisym.
+induction  lf as [| r lf Hreclf].
+simpl in |- *; right; symmetry  in |- *; assumption.
+assert
+ (H10 :
+  In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)).
+elim
+ (RList_P3 (cons_ORlist (cons r lf) lg)
+    (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; 
+ apply H10; exists 0%nat; split;
+ [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ].
+elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0));
+ intros H12 _; assert (H13 := H12 H10); elim H13; intro.
+elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0));
+ intros H11 _; assert (H14 := H11 H8); elim H14; intros; 
+ elim H15; clear H15; intros; rewrite H15; rewrite <- H6;
+ elim (RList_P6 (cons r lf)); intros; apply H17;
+ [ assumption | apply le_O_n | assumption ].
+elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _;
+ assert (H14 := H11 H8); elim H14; intros; elim H15; 
+ clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); 
+ intros; apply H17; [ assumption | apply le_O_n | assumption ].
+induction  lf as [| r lf Hreclf].
+simpl in |- *; right; assumption.
+assert (H8 : In a (cons_ORlist (cons r lf) lg)).
+elim (RList_P9 (cons r lf) lg a); intros; apply H10; left;
+ elim (RList_P3 (cons r lf) a); intros; apply H12; 
+ exists 0%nat; split;
+ [ symmetry  in |- *; assumption | simpl in |- *; apply lt_O_Sn ].
+apply RList_P5; [ apply RList_P2; assumption | assumption ].
+rewrite Hyp_max; apply Rle_antisym.
+induction  lf as [| r lf Hreclf].
+simpl in |- *; right; assumption.
+assert
+ (H8 :
+  In
+    (pos_Rl (cons_ORlist (cons r lf) lg)
+       (pred (Rlength (cons_ORlist (cons r lf) lg))))
+    (cons_ORlist (cons r lf) lg)).
+elim
+ (RList_P3 (cons_ORlist (cons r lf) lg)
+    (pos_Rl (cons_ORlist (cons r lf) lg)
+       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+ intros _ H10; apply H10;
+ exists (pred (Rlength (cons_ORlist (cons r lf) lg))); 
+ split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ].
+elim
+ (RList_P9 (cons r lf) lg
+    (pos_Rl (cons_ORlist (cons r lf) lg)
+       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+ intros H10 _; assert (H11 := H10 H8); elim H11; intro.
+elim
+ (RList_P3 (cons r lf)
+    (pos_Rl (cons_ORlist (cons r lf) lg)
+       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+ intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+ elim H15; clear H15; intros; rewrite H15; rewrite <- H5;
+ elim (RList_P6 (cons r lf)); intros; apply H17;
+ [ assumption
+ | simpl in |- *; simpl in H14; apply lt_n_Sm_le; assumption
+ | simpl in |- *; apply lt_n_Sn ].
+elim
+ (RList_P3 lg
+    (pos_Rl (cons_ORlist (cons r lf) lg)
+       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+ intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+ elim H15; clear H15; intros; rewrite H15;
+ assert (H17 : Rlength lg = S (pred (Rlength lg))).
+apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+ rewrite <- H17 in H16; elim (lt_n_O _ H16).
+rewrite <- H0; elim (RList_P6 lg); intros; apply H18;
+ [ assumption
+ | rewrite H17 in H16; apply lt_n_Sm_le; assumption
+ | apply lt_pred_n_n; rewrite H17; apply lt_O_Sn ].
+induction  lf as [| r lf Hreclf].
+simpl in |- *; right; symmetry  in |- *; assumption.
+assert (H8 : In b (cons_ORlist (cons r lf) lg)).
+elim (RList_P9 (cons r lf) lg b); intros; apply H10; left;
+ elim (RList_P3 (cons r lf) b); intros; apply H12;
+ exists (pred (Rlength (cons r lf))); split;
+ [ symmetry  in |- *; assumption | simpl in |- *; apply lt_n_Sn ].
+apply RList_P7; [ apply RList_P2; assumption | assumption ].
+apply StepFun_P20; rewrite RList_P11; rewrite H7; rewrite H2; simpl in |- *;
+ apply lt_O_Sn.
+unfold constant_D_eq, open_interval in |- *; intros;
+ cut
+  (exists l : R,
+     constant_D_eq g
+       (open_interval (pos_Rl (cons_ORlist lf lg) i)
+          (pos_Rl (cons_ORlist lf lg) (S i))) l).
+intros; elim H11; clear H11; intros; assert (H12 := H11);
+ assert
+  (Hyp_cons :
+    exists r : R, (exists r0 : Rlist, cons_ORlist lf lg = cons r r0)).
+apply RList_P19; red in |- *; intro; rewrite H13 in H8; elim (lt_n_O _ H8).
+elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons;
+ unfold FF in |- *; rewrite RList_P12.
+change (g x = g (pos_Rl (mid_Rlist (cons r r0) r) (S i))) in |- *;
+ rewrite <- Hyp_cons; rewrite RList_P13.
+assert (H13 := RList_P2 _ _ H _ H8); elim H13; intro.
+unfold constant_D_eq, open_interval in H11, H12; rewrite (H11 x H10);
+ assert
+  (H15 :
+   pos_Rl (cons_ORlist lf lg) i <
+   (pos_Rl (cons_ORlist lf lg) i + pos_Rl (cons_ORlist lf lg) (S i)) / 2 <
+   pos_Rl (cons_ORlist lf lg) (S i)).
+split.
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double;
+       rewrite (Rplus_comm (pos_Rl (cons_ORlist lf lg) i));
+       apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+rewrite (H11 _ H15); reflexivity.
+elim H10; intros; rewrite H14 in H15;
+ elim (Rlt_irrefl _ (Rlt_trans _ _ _ H16 H15)).
+apply H8.
+rewrite RList_P14; rewrite Hyp_cons in H8; simpl in H8; apply H8.
+assert (H11 : a < b).
+apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i).
+rewrite <- H6; rewrite <- (RList_P15 lf lg); try assumption.
+elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
+apply RList_P2; assumption.
+apply le_O_n.
+apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
+ [ assumption
+ | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
+    rewrite <- H13 in H8; elim (lt_n_O _ H8) ].
+rewrite H1; assumption.
+apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
+elim H10; intros; apply Rlt_trans with x; assumption.
+rewrite <- H5; rewrite <- (RList_P16 lf lg); try assumption.
+elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
+apply RList_P2; assumption.
+apply lt_n_Sm_le; apply lt_n_S; assumption.
+apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H8;
+ elim (lt_n_O _ H8).
+rewrite H0; assumption.
+set
+ (I :=
+  fun j:nat =>
+    pos_Rl lg j <= pos_Rl (cons_ORlist lf lg) i /\ (j < Rlength lg)%nat);
+ assert (H12 : Nbound I).
+unfold Nbound in |- *; exists (Rlength lg); intros; unfold I in H12; elim H12;
+ intros; apply lt_le_weak; assumption.
+assert (H13 :  exists n : nat, I n).
+exists 0%nat; unfold I in |- *; split.
+apply Rle_trans with (pos_Rl (cons_ORlist lf lg) 0).
+right; symmetry  in |- *; rewrite H1; rewrite <- H6; apply RList_P15;
+ try assumption; rewrite H1; assumption.
+elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13;
+ [ apply RList_P2; assumption
+ | apply le_O_n
+ | apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
+    [ assumption
+    | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
+       rewrite <- H15 in H8; elim (lt_n_O _ H8) ] ].
+apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H0;
+ rewrite <- H1 in H11; rewrite <- H0 in H11; elim (Rlt_irrefl _ H11).
+assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14;
+ exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval in |- *; 
+ intros; assert (H16 := H4 x0); assert (H17 : (x0 < pred (Rlength lg))%nat).
+elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros;
+ apply lt_S_n; replace (S (pred (Rlength lg))) with (Rlength lg).
+inversion H18.
+2: apply lt_n_S; assumption.
+cut (x0 = pred (Rlength lg)).
+intro; rewrite H19 in H14; rewrite H0 in H14;
+ cut (pos_Rl (cons_ORlist lf lg) i < b).
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H21)).
+apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
+elim H10; intros; apply Rlt_trans with x; assumption.
+rewrite <- H0;
+ apply Rle_trans with
+  (pos_Rl (cons_ORlist lf lg) (pred (Rlength (cons_ORlist lf lg)))).
+elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21.
+apply RList_P2; assumption.
+apply lt_n_Sm_le; apply lt_n_S; assumption.
+apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H23 in H8;
+ elim (lt_n_O _ H8).
+right; rewrite H0; rewrite <- H5; apply RList_P16; try assumption.
+rewrite H0; assumption.
+rewrite <- H20; reflexivity.
+apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+ rewrite <- H19 in H18; elim (lt_n_O _ H18).
+assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
+ rewrite (H18 x1).
+reflexivity.
+elim H15; clear H15; intros; elim H14; clear H14; intros; unfold I in H14;
+ elim H14; clear H14; intros; split.
+apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); assumption.
+apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)); try assumption.
+assert (H22 : (S x0 < Rlength lg)%nat).
+replace (Rlength lg) with (S (pred (Rlength lg))).
+apply lt_n_S; assumption.
+symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+ intro; rewrite <- H22 in H21; elim (lt_n_O _ H21).
+elim (Rle_dec (pos_Rl lg (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro.
+assert (H23 : (S x0 <= x0)%nat);
+ [ apply H20; unfold I in |- *; split; assumption | elim (le_Sn_n _ H23) ].
+assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lg (S x0)).
+auto with real.
+clear b0; apply RList_P17; try assumption;
+ [ apply RList_P2; assumption
+ | elim (RList_P9 lf lg (pos_Rl lg (S x0))); intros; apply H25; right;
+    elim (RList_P3 lg (pos_Rl lg (S x0))); intros; 
+    apply H27; exists (S x0); split; [ reflexivity | apply H22 ] ].
+Qed.
+
+Lemma StepFun_P25 :
+ forall (a b:R) (f g:R -> R) (lf lg:Rlist),
+   is_subdivision f a b lf ->
+   is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg).
+intros a b f g lf lg H H0; case (Rle_dec a b); intro;
+ [ apply StepFun_P24 with f; assumption
+ | apply StepFun_P5; apply StepFun_P24 with f;
+    [ auto with real
+    | apply StepFun_P5; assumption
+    | apply StepFun_P5; assumption ] ].
+Qed.
+
+Lemma StepFun_P26 :
+ forall (a b l:R) (f g:R -> R) (l1:Rlist),
+   is_subdivision f a b l1 ->
+   is_subdivision g a b l1 ->
+   is_subdivision (fun x:R => f x + l * g x) a b l1.
+intros a b l f g l1; unfold is_subdivision in |- *; intros; elim X; elim X0;
+ intros; clear X X0; unfold adapted_couple in p, p0; 
+ decompose [and] p; decompose [and] p0; clear p p0;
+ apply existT with (FF l1 (fun x:R => f x + l * g x));
+ unfold adapted_couple in |- *; repeat split; try assumption.
+apply StepFun_P20; apply neq_O_lt; red in |- *; intro; rewrite <- H8 in H7;
+ discriminate.
+intros; unfold constant_D_eq, open_interval in |- *;
+ unfold constant_D_eq, open_interval in H9, H4; intros;
+ rewrite (H9 _ H8 _ H10); rewrite (H4 _ H8 _ H10); 
+ assert (H11 : l1 <> nil).
+red in |- *; intro; rewrite H11 in H8; elim (lt_n_O _ H8).
+assert (H12 := RList_P19 _ H11); elim H12; clear H12; intros r [r0 H12];
+ rewrite H12; unfold FF in |- *;
+ change
+   (pos_Rl x0 i + l * pos_Rl x i =
+    pos_Rl
+      (app_Rlist (mid_Rlist (cons r r0) r) (fun x2:R => f x2 + l * g x2))
+      (S i)) in |- *; rewrite RList_P12.
+rewrite RList_P13.
+rewrite <- H12; rewrite (H9 _ H8); try rewrite (H4 _ H8);
+ reflexivity ||
+   (elim H10; clear H10; intros; split;
+     [ apply Rmult_lt_reg_l with 2;
+        [ prove_sup0
+        | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+           rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
+              apply Rlt_trans with x1; assumption
+           | discrR ] ]
+     | apply Rmult_lt_reg_l with 2;
+        [ prove_sup0
+        | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+           rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+           [ rewrite Rmult_1_l; rewrite double;
+              rewrite (Rplus_comm (pos_Rl l1 i)); apply Rplus_lt_compat_l;
+              apply Rlt_trans with x1; assumption
+           | discrR ] ] ]).
+rewrite <- H12; assumption.
+rewrite RList_P14; simpl in |- *; rewrite H12 in H8; simpl in H8;
+ apply lt_n_S; apply H8.
+Qed.
+
+Lemma StepFun_P27 :
+ forall (a b l:R) (f g:R -> R) (lf lg:Rlist),
+   is_subdivision f a b lf ->
+   is_subdivision g a b lg ->
+   is_subdivision (fun x:R => f x + l * g x) a b (cons_ORlist lf lg).
+intros a b l f g lf lg H H0; apply StepFun_P26;
+ [ apply StepFun_P23 with g; assumption
+ | apply StepFun_P25 with f; assumption ].
+Qed.
+
+(* The set of step functions on [a,b] is a vectorial space *)
+Lemma StepFun_P28 :
+ forall (a b l:R) (f g:StepFun a b), IsStepFun (fun x:R => f x + l * g x) a b.
+intros a b l f g; unfold IsStepFun in |- *; assert (H := pre f);
+ assert (H0 := pre g); unfold IsStepFun in H, H0; elim H; 
+ elim H0; intros; apply existT with (cons_ORlist x0 x); 
+ apply StepFun_P27; assumption.
+Qed.
+
+Lemma StepFun_P29 :
+ forall (a b:R) (f:StepFun a b), is_subdivision f a b (subdivision f).
+intros a b f; unfold is_subdivision in |- *;
+ apply existT with (subdivision_val f); apply StepFun_P1.
+Qed.
+
+Lemma StepFun_P30 :
+ forall (a b l:R) (f g:StepFun a b),
+   RiemannInt_SF (mkStepFun (StepFun_P28 l f g)) =
+   RiemannInt_SF f + l * RiemannInt_SF g.
+intros a b l f g; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
+ (intro;
+   replace
+    (Int_SF (subdivision_val (mkStepFun (StepFun_P28 l f g)))
+       (subdivision (mkStepFun (StepFun_P28 l f g)))) with
+    (Int_SF
+       (FF (cons_ORlist (subdivision f) (subdivision g))
+          (fun x:R => f x + l * g x))
+       (cons_ORlist (subdivision f) (subdivision g)));
+   [ rewrite StepFun_P19;
+      replace
+       (Int_SF (FF (cons_ORlist (subdivision f) (subdivision g)) f)
+          (cons_ORlist (subdivision f) (subdivision g))) with
+       (Int_SF (subdivision_val f) (subdivision f));
+      [ replace
+         (Int_SF (FF (cons_ORlist (subdivision f) (subdivision g)) g)
+            (cons_ORlist (subdivision f) (subdivision g))) with
+         (Int_SF (subdivision_val g) (subdivision g));
+         [ ring
+         | apply StepFun_P17 with (fe g) a b;
+            [ apply StepFun_P1
+            | apply StepFun_P21; apply StepFun_P25 with (fe f);
+               apply StepFun_P29 ] ]
+      | apply StepFun_P17 with (fe f) a b;
+         [ apply StepFun_P1
+         | apply StepFun_P21; apply StepFun_P23 with (fe g);
+            apply StepFun_P29 ] ]
+   | apply StepFun_P17 with (fun x:R => f x + l * g x) a b;
+      [ apply StepFun_P21; apply StepFun_P27; apply StepFun_P29
+      | apply (StepFun_P1 (mkStepFun (StepFun_P28 l f g))) ] ]).
+Qed.
+
+Lemma StepFun_P31 :
+ forall (a b:R) (f:R -> R) (l lf:Rlist),
+   adapted_couple f a b l lf ->
+   adapted_couple (fun x:R => Rabs (f x)) a b l (app_Rlist lf Rabs).
+unfold adapted_couple in |- *; intros; decompose [and] H; clear H;
+ repeat split; try assumption.
+symmetry  in |- *; rewrite H3; rewrite RList_P18; reflexivity.
+intros; unfold constant_D_eq, open_interval in |- *;
+ unfold constant_D_eq, open_interval in H5; intros; 
+ rewrite (H5 _ H _ H4); rewrite RList_P12;
+ [ reflexivity | rewrite H3 in H; simpl in H; apply H ].
+Qed.
+
+Lemma StepFun_P32 :
+ forall (a b:R) (f:StepFun a b), IsStepFun (fun x:R => Rabs (f x)) a b.
+intros a b f; unfold IsStepFun in |- *; apply existT with (subdivision f);
+ unfold is_subdivision in |- *;
+ apply existT with (app_Rlist (subdivision_val f) Rabs); 
+ apply StepFun_P31; apply StepFun_P1.
+Qed.
+
+Lemma StepFun_P33 :
+ forall l2 l1:Rlist,
+   ordered_Rlist l1 -> Rabs (Int_SF l2 l1) <= Int_SF (app_Rlist l2 Rabs) l1.
+simple induction l2; intros.
+simpl in |- *; rewrite Rabs_R0; right; reflexivity.
+simpl in |- *; induction  l1 as [| r1 l1 Hrecl1].
+rewrite Rabs_R0; right; reflexivity.
+induction  l1 as [| r2 l1 Hrecl0].
+rewrite Rabs_R0; right; reflexivity.
+apply Rle_trans with (Rabs (r * (r2 - r1)) + Rabs (Int_SF r0 (cons r2 l1))).
+apply Rabs_triang.
+rewrite Rabs_mult; rewrite (Rabs_right (r2 - r1));
+ [ apply Rplus_le_compat_l; apply H; apply RList_P4 with r1; assumption
+ | apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl in |- *;
+    apply lt_O_Sn ].
+Qed.
+
+Lemma StepFun_P34 :
+ forall (a b:R) (f:StepFun a b),
+   a <= b ->
+   Rabs (RiemannInt_SF f) <= RiemannInt_SF (mkStepFun (StepFun_P32 f)).
+intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+replace
+ (Int_SF (subdivision_val (mkStepFun (StepFun_P32 f)))
+    (subdivision (mkStepFun (StepFun_P32 f)))) with
+ (Int_SF (app_Rlist (subdivision_val f) Rabs) (subdivision f)).
+apply StepFun_P33; assert (H0 := StepFun_P29 f); unfold is_subdivision in H0;
+ elim H0; intros; unfold adapted_couple in p; decompose [and] p; 
+ assumption.
+apply StepFun_P17 with (fun x:R => Rabs (f x)) a b;
+ [ apply StepFun_P31; apply StepFun_P1
+ | apply (StepFun_P1 (mkStepFun (StepFun_P32 f))) ].
+elim n; assumption.
+Qed.
+
+Lemma StepFun_P35 :
+ forall (l:Rlist) (a b:R) (f g:R -> R),
+   ordered_Rlist l ->
+   pos_Rl l 0 = a ->
+   pos_Rl l (pred (Rlength l)) = b ->
+   (forall x:R, a < x < b -> f x <= g x) ->
+   Int_SF (FF l f) l <= Int_SF (FF l g) l.
+simple induction l; intros.
+right; reflexivity.
+simpl in |- *; induction  r0 as [| r0 r1 Hrecr0].
+right; reflexivity.
+simpl in |- *; apply Rplus_le_compat.
+case (Req_dec r r0); intro.
+rewrite H4; right; ring.
+do 2 rewrite <- (Rmult_comm (r0 - r)); apply Rmult_le_compat_l.
+apply Rge_le; apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl in |- *;
+ apply lt_O_Sn.
+apply H3; split.
+apply Rmult_lt_reg_l with 2.
+prove_sup0.
+unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+assert (H5 : r = a).
+apply H1.
+rewrite H5; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l.
+assert (H6 := H0 0%nat (lt_O_Sn _)).
+simpl in H6.
+elim H6; intro.
+rewrite H5 in H7; apply H7.
+elim H4; assumption.
+discrR.
+apply Rmult_lt_reg_l with 2.
+prove_sup0.
+unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; rewrite double; assert (H5 : r0 <= b).
+replace b with
+ (pos_Rl (cons r (cons r0 r1)) (pred (Rlength (cons r (cons r0 r1))))).
+replace r0 with (pos_Rl (cons r (cons r0 r1)) 1).
+elim (RList_P6 (cons r (cons r0 r1))); intros; apply H5.
+assumption.
+simpl in |- *; apply le_n_S.
+apply le_O_n.
+simpl in |- *; apply lt_n_Sn.
+reflexivity.
+apply Rle_lt_trans with (r + b).
+apply Rplus_le_compat_l; assumption.
+rewrite (Rplus_comm r); apply Rplus_lt_compat_l.
+apply Rlt_le_trans with r0.
+assert (H6 := H0 0%nat (lt_O_Sn _)).
+simpl in H6.
+elim H6; intro.
+apply H7.
+elim H4; assumption.
+assumption.
+discrR.
+simpl in H; apply H with r0 b.
+apply RList_P4 with r; assumption.
+reflexivity.
+rewrite <- H2; reflexivity.
+intros; apply H3; elim H4; intros; split; try assumption.
+apply Rle_lt_trans with r0; try assumption.
+rewrite <- H1.
+simpl in |- *; apply (H0 0%nat); simpl in |- *; apply lt_O_Sn.
+Qed.
+
+Lemma StepFun_P36 :
+ forall (a b:R) (f g:StepFun a b) (l:Rlist),
+   a <= b ->
+   is_subdivision f a b l ->
+   is_subdivision g a b l ->
+   (forall x:R, a < x < b -> f x <= g x) ->
+   RiemannInt_SF f <= RiemannInt_SF g.
+intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+replace (Int_SF (subdivision_val f) (subdivision f)) with (Int_SF (FF l f) l).
+replace (Int_SF (subdivision_val g) (subdivision g)) with (Int_SF (FF l g) l).
+unfold is_subdivision in X; elim X; clear X; intros;
+ unfold adapted_couple in p; decompose [and] p; clear p;
+ assert (H5 : Rmin a b = a);
+ [ unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ]
+ | assert (H7 : Rmax a b = b);
+    [ unfold Rmax in |- *; case (Rle_dec a b); intro;
+       [ reflexivity | elim n; assumption ]
+    | rewrite H5 in H3; rewrite H7 in H2; eapply StepFun_P35 with a b;
+       assumption ] ].
+apply StepFun_P17 with (fe g) a b;
+ [ apply StepFun_P21; assumption | apply StepFun_P1 ].
+apply StepFun_P17 with (fe f) a b;
+ [ apply StepFun_P21; assumption | apply StepFun_P1 ].
+elim n; assumption.
+Qed.
+
+Lemma StepFun_P37 :
+ forall (a b:R) (f g:StepFun a b),
+   a <= b ->
+   (forall x:R, a < x < b -> f x <= g x) ->
+   RiemannInt_SF f <= RiemannInt_SF g.
+intros; eapply StepFun_P36; try assumption.
+eapply StepFun_P25; apply StepFun_P29.
+eapply StepFun_P23; apply StepFun_P29.
+Qed.
+
+Lemma StepFun_P38 :
+ forall (l:Rlist) (a b:R) (f:R -> R),
+   ordered_Rlist l ->
+   pos_Rl l 0 = a ->
+   pos_Rl l (pred (Rlength l)) = b ->
+   sigT
+     (fun g:StepFun a b =>
+        g b = f b /\
+        (forall i:nat,
+           (i < pred (Rlength l))%nat ->
+           constant_D_eq g (co_interval (pos_Rl l i) (pos_Rl l (S i)))
+             (f (pos_Rl l i)))).
+intros l a b f; generalize a; clear a; induction l. 
+intros a H H0 H1; simpl in H0; simpl in H1;
+ exists (mkStepFun (StepFun_P4 a b (f b))); split.
+reflexivity.
+intros; elim (lt_n_O _ H2).
+intros; destruct l as [| r1 l].
+simpl in H1; simpl in H0; exists (mkStepFun (StepFun_P4 a b (f b))); split.
+reflexivity.
+intros i H2; elim (lt_n_O _ H2).
+intros; assert (H2 : ordered_Rlist (cons r1 l)).
+apply RList_P4 with r; assumption.
+assert (H3 : pos_Rl (cons r1 l) 0 = r1).
+reflexivity.
+assert (H4 : pos_Rl (cons r1 l) (pred (Rlength (cons r1 l))) = b).
+rewrite <- H1; reflexivity.
+elim (IHl r1 H2 H3 H4); intros g [H5 H6].
+set
+ (g' :=
+  fun x:R => match Rle_dec r1 x with
+             | left _ => g x
+             | right _ => f a
+             end).
+assert (H7 : r1 <= b).
+rewrite <- H4; apply RList_P7; [ assumption | left; reflexivity ].
+assert (H8 : IsStepFun g' a b).
+unfold IsStepFun in |- *; assert (H8 := pre g); unfold IsStepFun in H8;
+ elim H8; intros lg H9; unfold is_subdivision in H9; 
+ elim H9; clear H9; intros lg2 H9; split with (cons a lg);
+ unfold is_subdivision in |- *; split with (cons (f a) lg2);
+ unfold adapted_couple in H9; decompose [and] H9; clear H9;
+ unfold adapted_couple in |- *; repeat split.
+unfold ordered_Rlist in |- *; intros; simpl in H9;
+ induction  i as [| i Hreci].
+simpl in |- *; rewrite H12; replace (Rmin r1 b) with r1.
+simpl in H0; rewrite <- H0; apply (H 0%nat); simpl in |- *; apply lt_O_Sn.
+unfold Rmin in |- *; case (Rle_dec r1 b); intro;
+ [ reflexivity | elim n; assumption ].
+apply (H10 i); apply lt_S_n.
+replace (S (pred (Rlength lg))) with (Rlength lg).
+apply H9.
+apply S_pred with 0%nat; apply neq_O_lt; intro; rewrite <- H14 in H9;
+ elim (lt_n_O _ H9).
+simpl in |- *; assert (H14 : a <= b).
+rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7;
+ [ assumption | left; reflexivity ].
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+assert (H14 : a <= b).
+rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7;
+ [ assumption | left; reflexivity ].
+replace (Rmax a b) with (Rmax r1 b).
+rewrite <- H11; induction  lg as [| r0 lg Hreclg].
+simpl in H13; discriminate.
+reflexivity.
+unfold Rmax in |- *; case (Rle_dec a b); case (Rle_dec r1 b); intros;
+ reflexivity || elim n; assumption.
+simpl in |- *; rewrite H13; reflexivity.
+intros; simpl in H9; induction  i as [| i Hreci].
+unfold constant_D_eq, open_interval in |- *; simpl in |- *; intros;
+ assert (H16 : Rmin r1 b = r1).
+unfold Rmin in |- *; case (Rle_dec r1 b); intro;
+ [ reflexivity | elim n; assumption ].
+rewrite H16 in H12; rewrite H12 in H14; elim H14; clear H14; intros _ H14;
+ unfold g' in |- *; case (Rle_dec r1 x); intro r3.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H14)).
+reflexivity.
+change
+  (constant_D_eq g' (open_interval (pos_Rl lg i) (pos_Rl lg (S i)))
+     (pos_Rl lg2 i)) in |- *; clear Hreci; assert (H16 := H15 i);
+ assert (H17 : (i < pred (Rlength lg))%nat).
+apply lt_S_n.
+replace (S (pred (Rlength lg))) with (Rlength lg).
+assumption.
+apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+ rewrite <- H14 in H9; elim (lt_n_O _ H9).
+assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
+ unfold constant_D_eq, open_interval in |- *; intros;
+ assert (H19 := H18 _ H14); rewrite <- H19; unfold g' in |- *;
+ case (Rle_dec r1 x); intro.
+reflexivity.
+elim n; replace r1 with (Rmin r1 b).
+rewrite <- H12; elim H14; clear H14; intros H14 _; left;
+ apply Rle_lt_trans with (pos_Rl lg i); try assumption.
+apply RList_P5.
+assumption.
+elim (RList_P3 lg (pos_Rl lg i)); intros; apply H21; exists i; split.
+reflexivity.
+apply lt_trans with (pred (Rlength lg)); try assumption.
+apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H22 in H17;
+ elim (lt_n_O _ H17).
+unfold Rmin in |- *; case (Rle_dec r1 b); intro;
+ [ reflexivity | elim n0; assumption ].
+exists (mkStepFun H8); split.
+simpl in |- *; unfold g' in |- *; case (Rle_dec r1 b); intro.
+assumption.
+elim n; assumption.
+intros; simpl in H9; induction  i as [| i Hreci].
+unfold constant_D_eq, co_interval in |- *; simpl in |- *; intros; simpl in H0;
+ rewrite H0; elim H10; clear H10; intros; unfold g' in |- *;
+ case (Rle_dec r1 x); intro r3.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H11)).
+reflexivity.
+clear Hreci;
+ change
+   (constant_D_eq (mkStepFun H8)
+      (co_interval (pos_Rl (cons r1 l) i) (pos_Rl (cons r1 l) (S i)))
+      (f (pos_Rl (cons r1 l) i))) in |- *; assert (H10 := H6 i);
+ assert (H11 : (i < pred (Rlength (cons r1 l)))%nat).
+simpl in |- *; apply lt_S_n; assumption.
+assert (H12 := H10 H11); unfold constant_D_eq, co_interval in H12;
+ unfold constant_D_eq, co_interval in |- *; intros; 
+ rewrite <- (H12 _ H13); simpl in |- *; unfold g' in |- *;
+ case (Rle_dec r1 x); intro.
+reflexivity.
+elim n; elim H13; clear H13; intros;
+ apply Rle_trans with (pos_Rl (cons r1 l) i); try assumption;
+ change (pos_Rl (cons r1 l) 0 <= pos_Rl (cons r1 l) i) in |- *;
+ elim (RList_P6 (cons r1 l)); intros; apply H15;
+ [ assumption
+ | apply le_O_n
+ | simpl in |- *; apply lt_trans with (Rlength l);
+    [ apply lt_S_n; assumption | apply lt_n_Sn ] ].
+Qed.
+
+Lemma StepFun_P39 :
+ forall (a b:R) (f:StepFun a b),
+   RiemannInt_SF f = - RiemannInt_SF (mkStepFun (StepFun_P6 (pre f))).
+intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); case (Rle_dec b a);
+ intros.
+assert (H : adapted_couple f a b (subdivision f) (subdivision_val f));
+ [ apply StepFun_P1
+ | assert
+    (H0 :
+     adapted_couple (mkStepFun (StepFun_P6 (pre f))) b a
+       (subdivision (mkStepFun (StepFun_P6 (pre f))))
+       (subdivision_val (mkStepFun (StepFun_P6 (pre f)))));
+    [ apply StepFun_P1
+    | assert (H1 : a = b);
+       [ apply Rle_antisym; assumption
+       | rewrite (StepFun_P8 H H1); assert (H2 : b = a);
+          [ symmetry  in |- *; apply H1 | rewrite (StepFun_P8 H0 H2); ring ] ] ] ].
+rewrite Ropp_involutive; eapply StepFun_P17;
+ [ apply StepFun_P1
+ | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H;
+    elim H; intros; unfold is_subdivision in |- *; 
+    elim p; intros; apply p0 ].
+apply Ropp_eq_compat; eapply StepFun_P17;
+ [ apply StepFun_P1
+ | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H;
+    elim H; intros; unfold is_subdivision in |- *; 
+    elim p; intros; apply p0 ].
+assert (H : a < b);
+ [ auto with real
+ | assert (H0 : b < a);
+    [ auto with real | elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H0)) ] ].
+Qed.
+
+Lemma StepFun_P40 :
+ forall (f:R -> R) (a b c:R) (l1 l2 lf1 lf2:Rlist),
+   a < b ->
+   b < c ->
+   adapted_couple f a b l1 lf1 ->
+   adapted_couple f b c l2 lf2 ->
+   adapted_couple f a c (cons_Rlist l1 l2) (FF (cons_Rlist l1 l2) f).
+intros f a b c l1 l2 lf1 lf2 H H0 H1 H2; unfold adapted_couple in H1, H2;
+ unfold adapted_couple in |- *; decompose [and] H1; 
+ decompose [and] H2; clear H1 H2; repeat split.
+apply RList_P25; try assumption.
+rewrite H10; rewrite H4; unfold Rmin, Rmax in |- *; case (Rle_dec a b);
+ case (Rle_dec b c); intros;
+ (right; reflexivity) || (elim n; left; assumption).
+rewrite RList_P22.
+rewrite H5; unfold Rmin, Rmax in |- *; case (Rle_dec a b); case (Rle_dec a c);
+ intros;
+ [ reflexivity
+ | elim n; apply Rle_trans with b; left; assumption
+ | elim n; left; assumption
+ | elim n0; left; assumption ].
+red in |- *; intro; rewrite H1 in H6; discriminate.
+rewrite RList_P24.
+rewrite H9; unfold Rmin, Rmax in |- *; case (Rle_dec b c); case (Rle_dec a c);
+ intros;
+ [ reflexivity
+ | elim n; apply Rle_trans with b; left; assumption
+ | elim n; left; assumption
+ | elim n0; left; assumption ].
+red in |- *; intro; rewrite H1 in H11; discriminate.
+apply StepFun_P20.
+rewrite RList_P23; apply neq_O_lt; red in |- *; intro.
+assert (H2 : (Rlength l1 + Rlength l2)%nat = 0%nat).
+symmetry  in |- *; apply H1.
+elim (plus_is_O _ _ H2); intros; rewrite H12 in H6; discriminate.
+unfold constant_D_eq, open_interval in |- *; intros;
+ elim (le_or_lt (S (S i)) (Rlength l1)); intro.
+assert (H14 : pos_Rl (cons_Rlist l1 l2) i = pos_Rl l1 i).
+apply RList_P26; apply lt_S_n; apply le_lt_n_Sm; apply le_S_n;
+ apply le_trans with (Rlength l1); [ assumption | apply le_n_Sn ].
+assert (H15 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l1 (S i)).
+apply RList_P26; apply lt_S_n; apply le_lt_n_Sm; assumption.
+rewrite H14 in H2; rewrite H15 in H2; assert (H16 : (2 <= Rlength l1)%nat).
+apply le_trans with (S (S i));
+ [ repeat apply le_n_S; apply le_O_n | assumption ].
+elim (RList_P20 _ H16); intros r1 [r2 [r3 H17]]; rewrite H17;
+ change
+   (f x = pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i)
+  in |- *; rewrite RList_P12.
+induction  i as [| i Hreci].
+simpl in |- *; assert (H18 := H8 0%nat);
+ unfold constant_D_eq, open_interval in H18;
+ assert (H19 : (0 < pred (Rlength l1))%nat).
+rewrite H17; simpl in |- *; apply lt_O_Sn.
+assert (H20 := H18 H19); repeat rewrite H20.
+reflexivity.
+assert (H21 : r1 <= r2).
+rewrite H17 in H3; apply (H3 0%nat).
+simpl in |- *; apply lt_O_Sn.
+elim H21; intro.
+split.
+rewrite H17; simpl in |- *; apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+rewrite H17; simpl in |- *; apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite (Rplus_comm r1); rewrite double;
+       apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+elim H2; intros; rewrite H17 in H23; rewrite H17 in H24; simpl in H24;
+ simpl in H23; rewrite H22 in H23;
+ elim (Rlt_irrefl _ (Rlt_trans _ _ _ H23 H24)).
+assumption.
+clear Hreci; rewrite RList_P13.
+rewrite H17 in H14; rewrite H17 in H15;
+ change
+   (pos_Rl (cons_Rlist (cons r2 r3) l2) i =
+    pos_Rl (cons r1 (cons r2 r3)) (S i)) in H14; rewrite H14;
+ change
+   (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) =
+    pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15; 
+ rewrite H15; assert (H18 := H8 (S i));
+ unfold constant_D_eq, open_interval in H18;
+ assert (H19 : (S i < pred (Rlength l1))%nat).
+apply lt_pred; apply lt_S_n; apply le_lt_n_Sm; assumption.
+assert (H20 := H18 H19); repeat rewrite H20.
+reflexivity.
+rewrite <- H17; assert (H21 : pos_Rl l1 (S i) <= pos_Rl l1 (S (S i))).
+apply (H3 (S i)); apply lt_pred; apply lt_S_n; apply le_lt_n_Sm; assumption.
+elim H21; intro.
+split.
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l1 (S i)));
+       rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+elim H2; intros; rewrite H22 in H23;
+ elim (Rlt_irrefl _ (Rlt_trans _ _ _ H23 H24)).
+assumption.
+simpl in |- *; rewrite H17 in H1; simpl in H1; apply lt_S_n; assumption.
+rewrite RList_P14; rewrite H17 in H1; simpl in H1; apply H1.
+inversion H12.
+assert (H16 : pos_Rl (cons_Rlist l1 l2) (S i) = b).
+rewrite RList_P29.
+rewrite H15; rewrite <- minus_n_n; rewrite H10; unfold Rmin in |- *;
+ case (Rle_dec b c); intro; [ reflexivity | elim n; left; assumption ].
+rewrite H15; apply le_n.
+induction  l1 as [| r l1 Hrecl1].
+simpl in H15; discriminate.
+clear Hrecl1; simpl in H1; simpl in |- *; apply lt_n_S; assumption.
+assert (H17 : pos_Rl (cons_Rlist l1 l2) i = b).
+rewrite RList_P26.
+replace i with (pred (Rlength l1));
+ [ rewrite H4; unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; left; assumption ]
+ | rewrite H15; reflexivity ].
+rewrite H15; apply lt_n_Sn.
+rewrite H16 in H2; rewrite H17 in H2; elim H2; intros;
+ elim (Rlt_irrefl _ (Rlt_trans _ _ _ H14 H18)).
+assert (H16 : pos_Rl (cons_Rlist l1 l2) i = pos_Rl l2 (i - Rlength l1)).
+apply RList_P29.
+apply le_S_n; assumption.
+apply lt_le_trans with (pred (Rlength (cons_Rlist l1 l2)));
+ [ assumption | apply le_pred_n ].
+assert
+ (H17 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l2 (S (i - Rlength l1))).
+replace (S (i - Rlength l1)) with (S i - Rlength l1)%nat.
+apply RList_P29.
+apply le_S_n; apply le_trans with (S i); [ assumption | apply le_n_Sn ].
+induction  l1 as [| r l1 Hrecl1].
+simpl in H6; discriminate.
+clear Hrecl1; simpl in H1; simpl in |- *; apply lt_n_S; assumption.
+symmetry  in |- *; apply minus_Sn_m; apply le_S_n; assumption.
+assert (H18 : (2 <= Rlength l1)%nat).
+clear f c l2 lf2 H0 H3 H8 H7 H10 H9 H11 H13 i H1 x H2 H12 m H14 H15 H16 H17;
+ induction  l1 as [| r l1 Hrecl1].
+discriminate.
+clear Hrecl1; induction  l1 as [| r0 l1 Hrecl1].
+simpl in H5; simpl in H4; assert (H0 : Rmin a b < Rmax a b).
+unfold Rmin, Rmax in |- *; case (Rle_dec a b); intro;
+ [ assumption | elim n; left; assumption ].
+rewrite <- H5 in H0; rewrite <- H4 in H0; elim (Rlt_irrefl _ H0).
+clear Hrecl1; simpl in |- *; repeat apply le_n_S; apply le_O_n.
+elim (RList_P20 _ H18); intros r1 [r2 [r3 H19]]; rewrite H19;
+ change
+   (f x = pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i)
+  in |- *; rewrite RList_P12.
+induction  i as [| i Hreci].
+assert (H20 := le_S_n _ _ H15); assert (H21 := le_trans _ _ _ H18 H20);
+ elim (le_Sn_O _ H21).
+clear Hreci; rewrite RList_P13.
+rewrite H19 in H16; rewrite H19 in H17;
+ change
+   (pos_Rl (cons_Rlist (cons r2 r3) l2) i =
+    pos_Rl l2 (S i - Rlength (cons r1 (cons r2 r3)))) 
+  in H16; rewrite H16;
+ change
+   (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) =
+    pos_Rl l2 (S (S i - Rlength (cons r1 (cons r2 r3))))) 
+  in H17; rewrite H17; assert (H20 := H13 (S i - Rlength l1)%nat);
+ unfold constant_D_eq, open_interval in H20;
+ assert (H21 : (S i - Rlength l1 < pred (Rlength l2))%nat).
+apply lt_pred; rewrite minus_Sn_m.
+apply plus_lt_reg_l with (Rlength l1); rewrite <- le_plus_minus.
+rewrite H19 in H1; simpl in H1; rewrite H19; simpl in |- *;
+ rewrite RList_P23 in H1; apply lt_n_S; assumption.
+apply le_trans with (S i); [ apply le_S_n; assumption | apply le_n_Sn ].
+apply le_S_n; assumption.
+assert (H22 := H20 H21); repeat rewrite H22.
+reflexivity.
+rewrite <- H19;
+ assert
+  (H23 : pos_Rl l2 (S i - Rlength l1) <= pos_Rl l2 (S (S i - Rlength l1))).
+apply H7; apply lt_pred.
+rewrite minus_Sn_m.
+apply plus_lt_reg_l with (Rlength l1); rewrite <- le_plus_minus.
+rewrite H19 in H1; simpl in H1; rewrite H19; simpl in |- *;
+ rewrite RList_P23 in H1; apply lt_n_S; assumption.
+apply le_trans with (S i); [ apply le_S_n; assumption | apply le_n_Sn ].
+apply le_S_n; assumption.
+elim H23; intro.
+split.
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+apply Rmult_lt_reg_l with 2;
+ [ prove_sup0
+ | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym;
+    [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l2 (S i - Rlength l1)));
+       rewrite double; apply Rplus_lt_compat_l; assumption
+    | discrR ] ].
+rewrite <- H19 in H16; rewrite <- H19 in H17; elim H2; intros;
+ rewrite H19 in H25; rewrite H19 in H26; simpl in H25; 
+ simpl in H16; rewrite H16 in H25; simpl in H26; simpl in H17;
+ rewrite H17 in H26; simpl in H24; rewrite H24 in H25;
+ elim (Rlt_irrefl _ (Rlt_trans _ _ _ H25 H26)).
+assert (H23 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l2 (S i - Rlength l1)).
+rewrite H19; simpl in |- *; simpl in H16; apply H16.
+assert
+ (H24 :
+  pos_Rl (cons_Rlist l1 l2) (S (S i)) = pos_Rl l2 (S (S i - Rlength l1))).
+rewrite H19; simpl in |- *; simpl in H17; apply H17.
+rewrite <- H23; rewrite <- H24; assumption.
+simpl in |- *; rewrite H19 in H1; simpl in H1; apply lt_S_n; assumption.
+rewrite RList_P14; rewrite H19 in H1; simpl in H1; simpl in |- *; apply H1.
+Qed.
+
+Lemma StepFun_P41 :
+ forall (f:R -> R) (a b c:R),
+   a <= b -> b <= c -> IsStepFun f a b -> IsStepFun f b c -> IsStepFun f a c.
+unfold IsStepFun in |- *; unfold is_subdivision in |- *; intros; elim X;
+ clear X; intros l1 [lf1 H1]; elim X0; clear X0; intros l2 [lf2 H2];
+ case (total_order_T a b); intro.
+elim s; intro.
+case (total_order_T b c); intro.
+elim s0; intro.
+split with (cons_Rlist l1 l2); split with (FF (cons_Rlist l1 l2) f);
+ apply StepFun_P40 with b lf1 lf2; assumption.
+split with l1; split with lf1; rewrite b0 in H1; assumption.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r)).
+split with l2; split with lf2; rewrite <- b0 in H2; assumption.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+Qed.
+
+Lemma StepFun_P42 :
+ forall (l1 l2:Rlist) (f:R -> R),
+   pos_Rl l1 (pred (Rlength l1)) = pos_Rl l2 0 ->
+   Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2) =
+   Int_SF (FF l1 f) l1 + Int_SF (FF l2 f) l2.
+intros l1 l2 f; induction l1 as [| r l1 IHl1]; intros H;
+ [ simpl in |- *; ring
+ | destruct l1 as [| r0 r1];
+    [ simpl in H; simpl in |- *; destruct l2 as [| r0 r1];
+       [ simpl in |- *; ring | simpl in |- *; simpl in H; rewrite H; ring ]
+    | simpl in |- *; rewrite Rplus_assoc; apply Rplus_eq_compat_l; apply IHl1;
+       rewrite <- H; reflexivity ] ].
+Qed.
+
+Lemma StepFun_P43 :
+ forall (f:R -> R) (a b c:R) (pr1:IsStepFun f a b) 
+   (pr2:IsStepFun f b c) (pr3:IsStepFun f a c),
+   RiemannInt_SF (mkStepFun pr1) + RiemannInt_SF (mkStepFun pr2) =
+   RiemannInt_SF (mkStepFun pr3).
+intros f; intros;
+ assert
+  (H1 :
+   sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a b l l0))).
+apply pr1.
+assert
+ (H2 :
+  sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f b c l l0))).
+apply pr2.
+assert
+ (H3 :
+  sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a c l l0))).
+apply pr3.
+elim H1; clear H1; intros l1 [lf1 H1]; elim H2; clear H2; intros l2 [lf2 H2];
+ elim H3; clear H3; intros l3 [lf3 H3].
+replace (RiemannInt_SF (mkStepFun pr1)) with
+ match Rle_dec a b with
+ | left _ => Int_SF lf1 l1
+ | right _ => - Int_SF lf1 l1
+ end.
+replace (RiemannInt_SF (mkStepFun pr2)) with
+ match Rle_dec b c with
+ | left _ => Int_SF lf2 l2
+ | right _ => - Int_SF lf2 l2
+ end.
+replace (RiemannInt_SF (mkStepFun pr3)) with
+ match Rle_dec a c with
+ | left _ => Int_SF lf3 l3
+ | right _ => - Int_SF lf3 l3
+ end.
+case (Rle_dec a b); case (Rle_dec b c); case (Rle_dec a c); intros.
+elim r1; intro.
+elim r0; intro.
+replace (Int_SF lf3 l3) with
+ (Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2)).
+replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
+replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
+symmetry  in |- *; apply StepFun_P42.
+unfold adapted_couple in H1, H2; decompose [and] H1; decompose [and] H2;
+ clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+ case (Rle_dec a b); case (Rle_dec b c); intros; reflexivity || elim n;
+ assumption.
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2;
+    assumption
+ | assumption ].
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+ | assumption ].
+eapply StepFun_P17; [ apply (StepFun_P40 H H0 H1 H2) | apply H3 ].
+replace (Int_SF lf2 l2) with 0.
+rewrite Rplus_0_r; eapply StepFun_P17;
+ [ apply H1 | rewrite <- H0 in H3; apply H3 ].
+symmetry  in |- *; eapply StepFun_P8; [ apply H2 | assumption ].
+replace (Int_SF lf1 l1) with 0.
+rewrite Rplus_0_l; eapply StepFun_P17;
+ [ apply H2 | rewrite H in H3; apply H3 ].
+symmetry  in |- *; eapply StepFun_P8; [ apply H1 | assumption ].
+elim n; apply Rle_trans with b; assumption.
+apply Rplus_eq_reg_l with (Int_SF lf2 l2);
+ replace (Int_SF lf2 l2 + (Int_SF lf1 l1 + - Int_SF lf2 l2)) with
+  (Int_SF lf1 l1); [ idtac | ring ].
+assert (H : c < b).
+auto with real.
+elim r; intro.
+rewrite Rplus_comm;
+ replace (Int_SF lf1 l1) with
+  (Int_SF (FF (cons_Rlist l3 l2) f) (cons_Rlist l3 l2)).
+replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
+replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
+apply StepFun_P42.
+unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3;
+ clear H3 H2; rewrite H10; rewrite H6; unfold Rmax, Rmin in |- *;
+ case (Rle_dec a c); case (Rle_dec b c); intros;
+ [ elim n; assumption
+ | reflexivity
+ | elim n0; assumption
+ | elim n1; assumption ].
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
+ | assumption ].
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+ | assumption ].
+eapply StepFun_P17;
+ [ apply (StepFun_P40 H0 H H3 (StepFun_P2 H2)) | apply H1 ].
+replace (Int_SF lf3 l3) with 0.
+rewrite Rplus_0_r; eapply StepFun_P17;
+ [ apply H1 | apply StepFun_P2; rewrite <- H0 in H2; apply H2 ].
+symmetry  in |- *; eapply StepFun_P8; [ apply H3 | assumption ].
+replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1).
+ring.
+elim r; intro.
+replace (Int_SF lf2 l2) with
+ (Int_SF (FF (cons_Rlist l3 l1) f) (cons_Rlist l3 l1)).
+replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
+replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
+symmetry  in |- *; apply StepFun_P42.
+unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3;
+ clear H3 H1; rewrite H9; rewrite H5; unfold Rmax, Rmin in |- *;
+ case (Rle_dec a c); case (Rle_dec a b); intros;
+ [ elim n; assumption
+ | elim n1; assumption
+ | reflexivity
+ | elim n1; assumption ].
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+ | assumption ].
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+ | assumption ].
+eapply StepFun_P17.
+assert (H0 : c < a).
+auto with real.
+apply (StepFun_P40 H0 H (StepFun_P2 H3) H1).
+apply StepFun_P2; apply H2.
+replace (Int_SF lf1 l1) with 0.
+rewrite Rplus_0_r; eapply StepFun_P17;
+ [ apply H3 | rewrite <- H in H2; apply H2 ].
+symmetry  in |- *; eapply StepFun_P8; [ apply H1 | assumption ].
+assert (H : b < a).
+auto with real.
+replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1).
+ring.
+rewrite Rplus_comm; elim r; intro.
+replace (Int_SF lf2 l2) with
+ (Int_SF (FF (cons_Rlist l1 l3) f) (cons_Rlist l1 l3)).
+replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
+replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
+symmetry  in |- *; apply StepFun_P42.
+unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3;
+ clear H3 H1; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+ case (Rle_dec a c); case (Rle_dec a b); intros;
+ [ elim n; assumption
+ | reflexivity
+ | elim n0; assumption
+ | elim n1; assumption ].
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+ | assumption ].
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+ | assumption ].
+eapply StepFun_P17.
+apply (StepFun_P40 H H0 (StepFun_P2 H1) H3).
+apply H2.
+replace (Int_SF lf3 l3) with 0.
+rewrite Rplus_0_r; eapply StepFun_P17;
+ [ apply H1 | rewrite <- H0 in H2; apply StepFun_P2; apply H2 ].
+symmetry  in |- *; eapply StepFun_P8; [ apply H3 | assumption ].
+assert (H : c < a).
+auto with real.
+replace (Int_SF lf1 l1) with (Int_SF lf2 l2 + Int_SF lf3 l3).
+ring.
+elim r; intro.
+replace (Int_SF lf1 l1) with
+ (Int_SF (FF (cons_Rlist l2 l3) f) (cons_Rlist l2 l3)).
+replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
+replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
+symmetry  in |- *; apply StepFun_P42.
+unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3;
+ clear H3 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+ case (Rle_dec a c); case (Rle_dec b c); intros;
+ [ elim n; assumption
+ | elim n1; assumption
+ | reflexivity
+ | elim n1; assumption ].
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
+ | assumption ].
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+ | assumption ].
+eapply StepFun_P17.
+apply (StepFun_P40 H0 H H2 (StepFun_P2 H3)).
+apply StepFun_P2; apply H1.
+replace (Int_SF lf2 l2) with 0.
+rewrite Rplus_0_l; eapply StepFun_P17;
+ [ apply H3 | rewrite H0 in H1; apply H1 ].
+symmetry  in |- *; eapply StepFun_P8; [ apply H2 | assumption ].
+elim n; apply Rle_trans with a; try assumption.
+auto with real.
+assert (H : c < b).
+auto with real.
+assert (H0 : b < a).
+auto with real.
+replace (Int_SF lf3 l3) with (Int_SF lf2 l2 + Int_SF lf1 l1).
+ring.
+replace (Int_SF lf3 l3) with
+ (Int_SF (FF (cons_Rlist l2 l1) f) (cons_Rlist l2 l1)).
+replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
+replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
+symmetry  in |- *; apply StepFun_P42.
+unfold adapted_couple in H2, H1; decompose [and] H2; decompose [and] H1;
+ clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+ case (Rle_dec a b); case (Rle_dec b c); intros;
+ [ elim n1; assumption
+ | elim n1; assumption
+ | elim n0; assumption
+ | reflexivity ].
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
+ | assumption ].
+eapply StepFun_P17;
+ [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+ | assumption ].
+eapply StepFun_P17.
+apply (StepFun_P40 H H0 (StepFun_P2 H2) (StepFun_P2 H1)).
+apply StepFun_P2; apply H3.
+unfold RiemannInt_SF in |- *; case (Rle_dec a c); intro.
+eapply StepFun_P17.
+apply H3.
+change
+  (adapted_couple (mkStepFun pr3) a c (subdivision (mkStepFun pr3))
+     (subdivision_val (mkStepFun pr3))) in |- *; apply StepFun_P1.
+apply Ropp_eq_compat; eapply StepFun_P17.
+apply H3.
+change
+  (adapted_couple (mkStepFun pr3) a c (subdivision (mkStepFun pr3))
+     (subdivision_val (mkStepFun pr3))) in |- *; apply StepFun_P1.
+unfold RiemannInt_SF in |- *; case (Rle_dec b c); intro.
+eapply StepFun_P17.
+apply H2.
+change
+  (adapted_couple (mkStepFun pr2) b c (subdivision (mkStepFun pr2))
+     (subdivision_val (mkStepFun pr2))) in |- *; apply StepFun_P1.
+apply Ropp_eq_compat; eapply StepFun_P17.
+apply H2.
+change
+  (adapted_couple (mkStepFun pr2) b c (subdivision (mkStepFun pr2))
+     (subdivision_val (mkStepFun pr2))) in |- *; apply StepFun_P1.
+unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+eapply StepFun_P17.
+apply H1.
+change
+  (adapted_couple (mkStepFun pr1) a b (subdivision (mkStepFun pr1))
+     (subdivision_val (mkStepFun pr1))) in |- *; apply StepFun_P1.
+apply Ropp_eq_compat; eapply StepFun_P17.
+apply H1.
+change
+  (adapted_couple (mkStepFun pr1) a b (subdivision (mkStepFun pr1))
+     (subdivision_val (mkStepFun pr1))) in |- *; apply StepFun_P1.
+Qed.
+
+Lemma StepFun_P44 :
+ forall (f:R -> R) (a b c:R),
+   IsStepFun f a b -> a <= c <= b -> IsStepFun f a c.
+intros f; intros; assert (H0 : a <= b).
+elim H; intros; apply Rle_trans with c; assumption.
+elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X;
+ elim X; clear X; intros l1 [lf1 H2];
+ cut
+  (forall (l1 lf1:Rlist) (a b c:R) (f:R -> R),
+     adapted_couple f a b l1 lf1 ->
+     a <= c <= b ->
+     sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a c l l0))).
+intros; unfold IsStepFun in |- *; unfold is_subdivision in |- *; eapply X.
+apply H2.
+split; assumption.
+clear f a b c H0 H H1 H2 l1 lf1; simple induction l1.
+intros; unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
+ discriminate.
+simple induction r0.
+intros; assert (H1 : a = b).
+unfold adapted_couple in H; decompose [and] H; clear H; simpl in H3;
+ simpl in H2; assert (H7 : a <= b).
+elim H0; intros; apply Rle_trans with c; assumption.
+replace a with (Rmin a b).
+pattern b at 2 in |- *; replace b with (Rmax a b).
+rewrite <- H2; rewrite H3; reflexivity.
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+split with (cons r nil); split with lf1; assert (H2 : c = b).
+rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption.
+rewrite H2; assumption.
+intros; clear X; induction  lf1 as [| r3 lf1 Hreclf1].
+unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
+ discriminate.
+clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}).
+case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ].
+elim H1; intro.
+split with (cons r (cons c nil)); split with (cons r3 nil);
+ unfold adapted_couple in H; decompose [and] H; clear H; 
+ assert (H6 : r = a).
+simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity
+ | elim n; elim H0; intros; apply Rle_trans with c; assumption ].
+elim H0; clear H0; intros; unfold adapted_couple in |- *; repeat split.
+rewrite H6; unfold ordered_Rlist in |- *; intros; simpl in H8; inversion H8;
+ [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
+simpl in |- *; unfold Rmin in |- *; case (Rle_dec a c); intro;
+ [ assumption | elim n; assumption ].
+simpl in |- *; unfold Rmax in |- *; case (Rle_dec a c); intro;
+ [ reflexivity | elim n; assumption ].
+unfold constant_D_eq, open_interval in |- *; intros; simpl in H8;
+ inversion H8.
+simpl in |- *; assert (H10 := H7 0%nat);
+ assert (H12 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat).
+simpl in |- *; apply lt_O_Sn.
+apply (H10 H12); unfold open_interval in |- *; simpl in |- *;
+ rewrite H11 in H9; simpl in H9; elim H9; clear H9; 
+ intros; split; try assumption.
+apply Rlt_le_trans with c; assumption.
+elim (le_Sn_O _ H11).
+cut (adapted_couple f r1 b (cons r1 r2) lf1).
+cut (r1 <= c <= b).
+intros.
+elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with (cons r l1');
+ split with (cons r3 lf1'); unfold adapted_couple in H, H4; 
+ decompose [and] H; decompose [and] H4; clear H H4 X0; 
+ assert (H14 : a <= b).
+elim H0; intros; apply Rle_trans with c; assumption.
+assert (H16 : r = a).
+simpl in H7; rewrite H7; unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+induction  l1' as [| r4 l1' Hrecl1'].
+simpl in H13; discriminate.
+clear Hrecl1'; unfold adapted_couple in |- *; repeat split.
+unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
+simpl in |- *; replace r4 with r1.
+apply (H5 0%nat).
+simpl in |- *; apply lt_O_Sn.
+simpl in H12; rewrite H12; unfold Rmin in |- *; case (Rle_dec r1 c); intro;
+ [ reflexivity | elim n; left; assumption ].
+apply (H9 i); simpl in |- *; apply lt_S_n; assumption.
+simpl in |- *; unfold Rmin in |- *; case (Rle_dec a c); intro;
+ [ assumption | elim n; elim H0; intros; assumption ].
+replace (Rmax a c) with (Rmax r1 c).
+rewrite <- H11; reflexivity.
+unfold Rmax in |- *; case (Rle_dec r1 c); case (Rle_dec a c); intros;
+ [ reflexivity
+ | elim n; elim H0; intros; assumption
+ | elim n; left; assumption
+ | elim n0; left; assumption ].
+simpl in |- *; simpl in H13; rewrite H13; reflexivity.
+intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
+ induction  i as [| i Hreci].
+simpl in |- *; assert (H17 := H10 0%nat);
+ assert (H18 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat).
+simpl in |- *; apply lt_O_Sn.
+apply (H17 H18); unfold open_interval in |- *; simpl in |- *; simpl in H4;
+ elim H4; clear H4; intros; split; try assumption; 
+ replace r1 with r4.
+assumption.
+simpl in H12; rewrite H12; unfold Rmin in |- *; case (Rle_dec r1 c); intro;
+ [ reflexivity | elim n; left; assumption ].
+clear Hreci; simpl in |- *; apply H15.
+simpl in |- *; apply lt_S_n; assumption.
+unfold open_interval in |- *; apply H4.
+split.
+left; assumption.
+elim H0; intros; assumption.
+eapply StepFun_P7;
+ [ elim H0; intros; apply Rle_trans with c; [ apply H2 | apply H3 ]
+ | apply H ].
+Qed.
+
+Lemma StepFun_P45 :
+ forall (f:R -> R) (a b c:R),
+   IsStepFun f a b -> a <= c <= b -> IsStepFun f c b.
+intros f; intros; assert (H0 : a <= b).
+elim H; intros; apply Rle_trans with c; assumption.
+elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X;
+ elim X; clear X; intros l1 [lf1 H2];
+ cut
+  (forall (l1 lf1:Rlist) (a b c:R) (f:R -> R),
+     adapted_couple f a b l1 lf1 ->
+     a <= c <= b ->
+     sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f c b l l0))).
+intros; unfold IsStepFun in |- *; unfold is_subdivision in |- *; eapply X;
+ [ apply H2 | split; assumption ].
+clear f a b c H0 H H1 H2 l1 lf1; simple induction l1.
+intros; unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
+ discriminate.
+simple induction r0.
+intros; assert (H1 : a = b).
+unfold adapted_couple in H; decompose [and] H; clear H; simpl in H3;
+ simpl in H2; assert (H7 : a <= b).
+elim H0; intros; apply Rle_trans with c; assumption.
+replace a with (Rmin a b).
+pattern b at 2 in |- *; replace b with (Rmax a b).
+rewrite <- H2; rewrite H3; reflexivity.
+unfold Rmax in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+unfold Rmin in |- *; case (Rle_dec a b); intro;
+ [ reflexivity | elim n; assumption ].
+split with (cons r nil); split with lf1; assert (H2 : c = b).
+rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption.
+rewrite <- H2 in H1; rewrite <- H1; assumption.
+intros; clear X; induction  lf1 as [| r3 lf1 Hreclf1].
+unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
+ discriminate.
+clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}).
+case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ].
+elim H1; intro.
+split with (cons c (cons r1 r2)); split with (cons r3 lf1);
+ unfold adapted_couple in H; decompose [and] H; clear H;
+ unfold adapted_couple in |- *; repeat split.
+unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
+simpl in |- *; assumption.
+clear Hreci; apply (H2 (S i)); simpl in |- *; assumption.
+simpl in |- *; unfold Rmin in |- *; case (Rle_dec c b); intro;
+ [ reflexivity | elim n; elim H0; intros; assumption ].
+replace (Rmax c b) with (Rmax a b).
+rewrite <- H3; reflexivity.
+unfold Rmax in |- *; case (Rle_dec a b); case (Rle_dec c b); intros;
+ [ reflexivity
+ | elim n; elim H0; intros; assumption
+ | elim n; elim H0; intros; apply Rle_trans with c; assumption
+ | elim n0; elim H0; intros; apply Rle_trans with c; assumption ].
+simpl in |- *; simpl in H5; apply H5.
+intros; simpl in H; induction  i as [| i Hreci].
+unfold constant_D_eq, open_interval in |- *; intros; simpl in |- *;
+ apply (H7 0%nat).
+simpl in |- *; apply lt_O_Sn.
+unfold open_interval in |- *; simpl in |- *; simpl in H6; elim H6; clear H6;
+ intros; split; try assumption; apply Rle_lt_trans with c; 
+ try assumption; replace r with a.
+elim H0; intros; assumption.
+simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intros;
+ [ reflexivity
+ | elim n; elim H0; intros; apply Rle_trans with c; assumption ].
+clear Hreci; apply (H7 (S i)); simpl in |- *; assumption.
+cut (adapted_couple f r1 b (cons r1 r2) lf1).
+cut (r1 <= c <= b).
+intros; elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with l1';
+ split with lf1'; assumption.
+split; [ left; assumption | elim H0; intros; assumption ].
+eapply StepFun_P7;
+ [ elim H0; intros; apply Rle_trans with c; [ apply H2 | apply H3 ]
+ | apply H ].
+Qed.
+
+Lemma StepFun_P46 :
+ forall (f:R -> R) (a b c:R),
+   IsStepFun f a b -> IsStepFun f b c -> IsStepFun f a c.
+intros f; intros; case (Rle_dec a b); case (Rle_dec b c); intros.
+apply StepFun_P41 with b; assumption.
+case (Rle_dec a c); intro.
+apply StepFun_P44 with b; try assumption.
+split; [ assumption | auto with real ].
+apply StepFun_P6; apply StepFun_P44 with b.
+apply StepFun_P6; assumption.
+split; auto with real.
+case (Rle_dec a c); intro.
+apply StepFun_P45 with b; try assumption.
+split; auto with real.
+apply StepFun_P6; apply StepFun_P45 with b.
+apply StepFun_P6; assumption.
+split; [ assumption | auto with real ].
+apply StepFun_P6; apply StepFun_P41 with b;
+ auto with real || apply StepFun_P6; assumption.
+Qed.
diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v
new file mode 100644
index 00000000..0fbb17c6
--- /dev/null
+++ b/theories/Reals/Rlimit.v
@@ -0,0 +1,557 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rlimit.v,v 1.23.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+(*********************************************************)
+(*           Definition of the limit                     *)
+(*                                                       *)
+(*********************************************************)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Classical_Prop.
+Require Import Fourier. Open Local Scope R_scope.
+
+(*******************************)
+(*      Calculus               *)
+(*******************************)
+(*********)
+Lemma eps2_Rgt_R0 : forall eps:R, eps > 0 -> eps * / 2 > 0.
+intros; fourier.
+Qed.
+
+(*********)
+Lemma eps2 : forall eps:R, eps * / 2 + eps * / 2 = eps.
+intro esp.
+assert (H := double_var esp).
+unfold Rdiv in H.
+symmetry  in |- *; exact H.
+Qed.
+
+(*********)
+Lemma eps4 : forall eps:R, eps * / (2 + 2) + eps * / (2 + 2) = eps * / 2.
+intro eps.
+replace (2 + 2) with 4.
+pattern eps at 3 in |- *; rewrite double_var.
+rewrite (Rmult_plus_distr_r (eps / 2) (eps / 2) (/ 2)).
+unfold Rdiv in |- *.
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_mult_distr.
+reflexivity.
+discrR.
+discrR.
+ring.
+Qed.
+
+(*********)
+Lemma Rlt_eps2_eps : forall eps:R, eps > 0 -> eps * / 2 < eps.
+intros.
+pattern eps at 2 in |- *; rewrite <- Rmult_1_r.
+repeat rewrite (Rmult_comm eps).
+apply Rmult_lt_compat_r.
+exact H.
+apply Rmult_lt_reg_l with 2.
+fourier.
+rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
+fourier.
+discrR.
+Qed.
+
+(*********)
+Lemma Rlt_eps4_eps : forall eps:R, eps > 0 -> eps * / (2 + 2) < eps.
+intros.
+replace (2 + 2) with 4.
+pattern eps at 2 in |- *; rewrite <- Rmult_1_r.
+repeat rewrite (Rmult_comm eps).
+apply Rmult_lt_compat_r.
+exact H.
+apply Rmult_lt_reg_l with 4.
+replace 4 with 4.
+apply Rmult_lt_0_compat; fourier.
+ring.
+rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
+fourier.
+discrR.
+ring.
+Qed. 
+
+(*********)
+Lemma prop_eps : forall r:R, (forall eps:R, eps > 0 -> r < eps) -> r <= 0.
+intros; elim (Rtotal_order r 0); intro.
+apply Rlt_le; assumption.
+elim H0; intro.
+apply Req_le; assumption.
+clear H0; generalize (H r H1); intro; generalize (Rlt_irrefl r); intro;
+ elimtype False; auto.
+Qed.
+
+(*********)
+Definition mul_factor (l l':R) := / (1 + (Rabs l + Rabs l')).
+
+(*********)
+Lemma mul_factor_wd : forall l l':R, 1 + (Rabs l + Rabs l') <> 0.
+intros; rewrite (Rplus_comm 1 (Rabs l + Rabs l')); apply tech_Rplus.
+cut (Rabs (l + l') <= Rabs l + Rabs l').
+cut (0 <= Rabs (l + l')).
+exact (Rle_trans _ _ _).
+exact (Rabs_pos (l + l')).
+exact (Rabs_triang _ _).
+exact Rlt_0_1.
+Qed.
+
+(*********)
+Lemma mul_factor_gt : forall eps l l':R, eps > 0 -> eps * mul_factor l l' > 0.
+intros; unfold Rgt in |- *; rewrite <- (Rmult_0_r eps);
+ apply Rmult_lt_compat_l.
+assumption.
+unfold mul_factor in |- *; apply Rinv_0_lt_compat;
+ cut (1 <= 1 + (Rabs l + Rabs l')).
+cut (0 < 1).
+exact (Rlt_le_trans _ _ _).
+exact Rlt_0_1.
+replace (1 <= 1 + (Rabs l + Rabs l')) with (1 + 0 <= 1 + (Rabs l + Rabs l')).
+apply Rplus_le_compat_l.
+cut (Rabs (l + l') <= Rabs l + Rabs l').
+cut (0 <= Rabs (l + l')).
+exact (Rle_trans _ _ _).
+exact (Rabs_pos _).
+exact (Rabs_triang _ _).
+rewrite (proj1 (Rplus_ne 1)); trivial.
+Qed.
+
+(*********)
+Lemma mul_factor_gt_f :
+ forall eps l l':R, eps > 0 -> Rmin 1 (eps * mul_factor l l') > 0.
+intros; apply Rmin_Rgt_r; split.
+exact Rlt_0_1.
+exact (mul_factor_gt eps l l' H).
+Qed.
+
+
+(*******************************)
+(*      Metric space           *)
+(*******************************)
+
+(*********)
+Record Metric_Space : Type := 
+  {Base : Type;
+   dist : Base -> Base -> R;
+   dist_pos : forall x y:Base, dist x y >= 0;
+   dist_sym : forall x y:Base, dist x y = dist y x;
+   dist_refl : forall x y:Base, dist x y = 0 <-> x = y;
+   dist_tri : forall x y z:Base, dist x y <= dist x z + dist z y}.
+
+(*******************************)
+(*     Limit in Metric space   *)
+(*******************************)
+
+(*********)
+Definition limit_in (X X':Metric_Space) (f:Base X -> Base X')
+  (D:Base X -> Prop) (x0:Base X) (l:Base X') :=
+  forall eps:R,
+    eps > 0 ->
+     exists alp : R,
+      alp > 0 /\
+      (forall x:Base X, D x /\ dist X x x0 < alp -> dist X' (f x) l < eps). 
+
+(*******************************)
+(*    R is a metric space      *)
+(*******************************)
+
+(*********)
+Definition R_met : Metric_Space :=
+  Build_Metric_Space R R_dist R_dist_pos R_dist_sym R_dist_refl R_dist_tri.
+
+(*******************************)
+(*         Limit 1 arg         *)
+(*******************************)
+(*********)
+Definition Dgf (Df Dg:R -> Prop) (f:R -> R) (x:R) := Df x /\ Dg (f x).
+
+(*********)
+Definition limit1_in (f:R -> R) (D:R -> Prop) (l x0:R) : Prop :=
+  limit_in R_met R_met f D x0 l.
+
+(*********)
+Lemma tech_limit :
+ forall (f:R -> R) (D:R -> Prop) (l x0:R),
+   D x0 -> limit1_in f D l x0 -> l = f x0.
+intros f D l x0 H H0.
+case (Rabs_pos (f x0 - l)); intros H1.
+absurd (dist R_met (f x0) l < dist R_met (f x0) l).
+apply Rlt_irrefl.
+case (H0 (dist R_met (f x0) l)); auto.
+intros alpha1 [H2 H3]; apply H3; auto; split; auto.
+case (dist_refl R_met x0 x0); intros Hr1 Hr2; rewrite Hr2; auto.
+case (dist_refl R_met (f x0) l); intros Hr1 Hr2; apply sym_eq; auto.
+Qed.
+
+(*********)
+Lemma tech_limit_contr :
+ forall (f:R -> R) (D:R -> Prop) (l x0:R),
+   D x0 -> l <> f x0 -> ~ limit1_in f D l x0.
+intros; generalize (tech_limit f D l x0); tauto.
+Qed.
+
+(*********)
+Lemma lim_x : forall (D:R -> Prop) (x0:R), limit1_in (fun x:R => x) D x0 x0.
+unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+ split with eps; split; auto; intros; elim H0; intros; 
+ auto.
+Qed.
+
+(*********)
+Lemma limit_plus :
+ forall (f g:R -> R) (D:R -> Prop) (l l' x0:R),
+   limit1_in f D l x0 ->
+   limit1_in g D l' x0 -> limit1_in (fun x:R => f x + g x) D (l + l') x0.
+intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
+ intros; elim (H (eps * / 2) (eps2_Rgt_R0 eps H1));
+ elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl in |- *; 
+ clear H H0; intros; elim H; elim H0; clear H H0; intros;
+ split with (Rmin x1 x); split.
+exact (Rmin_Rgt_r x1 x 0 (conj H H2)).
+intros; elim H4; clear H4; intros;
+ cut (R_dist (f x2) l + R_dist (g x2) l' < eps).
+ cut (R_dist (f x2 + g x2) (l + l') <= R_dist (f x2) l + R_dist (g x2) l').
+exact (Rle_lt_trans _ _ _).
+exact (R_dist_plus _ _ _ _).
+elim (Rmin_Rgt_l x1 x (R_dist x2 x0) H5); clear H5; intros.
+generalize (H3 x2 (conj H4 H6)); generalize (H0 x2 (conj H4 H5)); intros;
+ replace eps with (eps * / 2 + eps * / 2).
+exact (Rplus_lt_compat _ _ _ _ H7 H8).
+exact (eps2 eps).
+Qed.
+
+(*********)
+Lemma limit_Ropp :
+ forall (f:R -> R) (D:R -> Prop) (l x0:R),
+   limit1_in f D l x0 -> limit1_in (fun x:R => - f x) D (- l) x0.
+unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+ elim (H eps H0); clear H; intros; elim H; clear H; 
+ intros; split with x; split; auto; intros; generalize (H1 x1 H2); 
+ clear H1; intro; unfold R_dist in |- *; unfold Rminus in |- *;
+ rewrite (Ropp_involutive l); rewrite (Rplus_comm (- f x1) l);
+ fold (l - f x1) in |- *; fold (R_dist l (f x1)) in |- *; 
+ rewrite R_dist_sym; assumption.
+Qed.
+
+(*********)
+Lemma limit_minus :
+ forall (f g:R -> R) (D:R -> Prop) (l l' x0:R),
+   limit1_in f D l x0 ->
+   limit1_in g D l' x0 -> limit1_in (fun x:R => f x - g x) D (l - l') x0.
+intros; unfold Rminus in |- *; generalize (limit_Ropp g D l' x0 H0); intro;
+ exact (limit_plus f (fun x:R => - g x) D l (- l') x0 H H1).
+Qed.
+
+(*********)
+Lemma limit_free :
+ forall (f:R -> R) (D:R -> Prop) (x x0:R),
+   limit1_in (fun h:R => f x) D (f x) x0.
+unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+ split with eps; split; auto; intros; elim (R_dist_refl (f x) (f x));
+ intros a b; rewrite (b (refl_equal (f x))); unfold Rgt in H; 
+ assumption.
+Qed.
+
+(*********)
+Lemma limit_mul :
+ forall (f g:R -> R) (D:R -> Prop) (l l' x0:R),
+   limit1_in f D l x0 ->
+   limit1_in g D l' x0 -> limit1_in (fun x:R => f x * g x) D (l * l') x0.
+intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
+ intros;
+ elim (H (Rmin 1 (eps * mul_factor l l')) (mul_factor_gt_f eps l l' H1));
+ elim (H0 (eps * mul_factor l l') (mul_factor_gt eps l l' H1)); 
+ clear H H0; simpl in |- *; intros; elim H; elim H0; 
+ clear H H0; intros; split with (Rmin x1 x); split.
+exact (Rmin_Rgt_r x1 x 0 (conj H H2)).
+intros; elim H4; clear H4; intros; unfold R_dist in |- *;
+ replace (f x2 * g x2 - l * l') with (f x2 * (g x2 - l') + l' * (f x2 - l)).
+cut (Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l)) < eps). 
+cut
+ (Rabs (f x2 * (g x2 - l') + l' * (f x2 - l)) <=
+  Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l))).
+exact (Rle_lt_trans _ _ _).
+exact (Rabs_triang _ _).
+rewrite (Rabs_mult (f x2) (g x2 - l')); rewrite (Rabs_mult l' (f x2 - l));
+ cut
+  ((1 + Rabs l) * (eps * mul_factor l l') + Rabs l' * (eps * mul_factor l l') <=
+   eps).
+cut
+ (Rabs (f x2) * Rabs (g x2 - l') + Rabs l' * Rabs (f x2 - l) <
+  (1 + Rabs l) * (eps * mul_factor l l') + Rabs l' * (eps * mul_factor l l')).
+exact (Rlt_le_trans _ _ _).
+elim (Rmin_Rgt_l x1 x (R_dist x2 x0) H5); clear H5; intros;
+ generalize (H0 x2 (conj H4 H5)); intro; generalize (Rmin_Rgt_l _ _ _ H7);
+ intro; elim H8; intros; clear H0 H8; apply Rplus_lt_le_compat.
+apply Rmult_ge_0_gt_0_lt_compat.
+apply Rle_ge.
+exact (Rabs_pos (g x2 - l')).
+rewrite (Rplus_comm 1 (Rabs l)); unfold Rgt in |- *; apply Rle_lt_0_plus_1;
+ exact (Rabs_pos l).
+unfold R_dist in H9;
+ apply (Rplus_lt_reg_r (- Rabs l) (Rabs (f x2)) (1 + Rabs l)).
+rewrite <- (Rplus_assoc (- Rabs l) 1 (Rabs l));
+ rewrite (Rplus_comm (- Rabs l) 1);
+ rewrite (Rplus_assoc 1 (- Rabs l) (Rabs l)); rewrite (Rplus_opp_l (Rabs l));
+ rewrite (proj1 (Rplus_ne 1)); rewrite (Rplus_comm (- Rabs l) (Rabs (f x2)));
+ generalize H9; cut (Rabs (f x2) - Rabs l <= Rabs (f x2 - l)).
+exact (Rle_lt_trans _ _ _).
+exact (Rabs_triang_inv _ _).
+generalize (H3 x2 (conj H4 H6)); trivial.
+apply Rmult_le_compat_l.
+exact (Rabs_pos l').
+unfold Rle in |- *; left; assumption.
+rewrite (Rmult_comm (1 + Rabs l) (eps * mul_factor l l'));
+ rewrite (Rmult_comm (Rabs l') (eps * mul_factor l l'));
+ rewrite <-
+  (Rmult_plus_distr_l (eps * mul_factor l l') (1 + Rabs l) (Rabs l'))
+  ; rewrite (Rmult_assoc eps (mul_factor l l') (1 + Rabs l + Rabs l'));
+ rewrite (Rplus_assoc 1 (Rabs l) (Rabs l')); unfold mul_factor in |- *;
+ rewrite (Rinv_l (1 + (Rabs l + Rabs l')) (mul_factor_wd l l'));
+ rewrite (proj1 (Rmult_ne eps)); apply Req_le; trivial.
+ring.
+Qed.
+
+(*********)
+Definition adhDa (D:R -> Prop) (a:R) : Prop :=
+  forall alp:R, alp > 0 ->  exists x : R, D x /\ R_dist x a < alp.
+
+(*********)
+Lemma single_limit :
+ forall (f:R -> R) (D:R -> Prop) (l l' x0:R),
+   adhDa D x0 -> limit1_in f D l x0 -> limit1_in f D l' x0 -> l = l'.
+unfold limit1_in in |- *; unfold limit_in in |- *; intros.
+cut (forall eps:R, eps > 0 -> dist R_met l l' < 2 * eps).
+clear H0 H1; unfold dist in |- *; unfold R_met in |- *; unfold R_dist in |- *;
+ unfold Rabs in |- *; case (Rcase_abs (l - l')); intros.
+cut (forall eps:R, eps > 0 -> - (l - l') < eps).
+intro; generalize (prop_eps (- (l - l')) H1); intro;
+ generalize (Ropp_gt_lt_0_contravar (l - l') r); intro; 
+ unfold Rgt in H3; generalize (Rgt_not_le (- (l - l')) 0 H3); 
+ intro; elimtype False; auto.
+intros; cut (eps * / 2 > 0).
+intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2));
+ rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
+elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial.
+apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro;
+ unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); 
+ intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; 
+ clear a b; apply (Rlt_trans 0 1 2 H3 H4).
+unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
+ rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); 
+ auto.
+apply (Rinv_0_lt_compat 2); cut (1 < 2).
+intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2).
+generalize (Rplus_lt_compat_l 1 0 1 Rlt_0_1); elim (Rplus_ne 1); intros a b;
+ rewrite a; clear a b; trivial.
+(**)
+cut (forall eps:R, eps > 0 -> l - l' < eps).
+intro; generalize (prop_eps (l - l') H1); intro; elim (Rle_le_eq (l - l') 0);
+ intros a b; clear b; apply (Rminus_diag_uniq l l'); 
+ apply a; split.
+assumption.
+apply (Rge_le (l - l') 0 r).
+intros; cut (eps * / 2 > 0).
+intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2));
+ rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
+elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial.
+apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro;
+ unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); 
+ intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; 
+ clear a b; apply (Rlt_trans 0 1 2 H3 H4).
+unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
+ rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); 
+ auto.
+apply (Rinv_0_lt_compat 2); cut (1 < 2).
+intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2).
+generalize (Rplus_lt_compat_l 1 0 1 Rlt_0_1); elim (Rplus_ne 1); intros a b;
+ rewrite a; clear a b; trivial.
+(**)
+intros; unfold adhDa in H; elim (H0 eps H2); intros; elim (H1 eps H2); intros;
+ clear H0 H1; elim H3; elim H4; clear H3 H4; intros; 
+ simpl in |- *; simpl in H1, H4; generalize (Rmin_Rgt x x1 0); 
+ intro; elim H5; intros; clear H5; elim (H (Rmin x x1) (H7 (conj H3 H0)));
+ intros; elim H5; intros; clear H5 H H6 H7;
+ generalize (Rmin_Rgt x x1 (R_dist x2 x0)); intro; 
+ elim H; intros; clear H H6; unfold Rgt in H5; elim (H5 H9); 
+ intros; clear H5 H9; generalize (H1 x2 (conj H8 H6));
+ generalize (H4 x2 (conj H8 H)); clear H8 H H6 H1 H4 H0 H3; 
+ intros;
+ generalize
+  (Rplus_lt_compat (R_dist (f x2) l) eps (R_dist (f x2) l') eps H H0);
+ unfold R_dist in |- *; intros; rewrite (Rabs_minus_sym (f x2) l) in H1;
+ rewrite (Rmult_comm 2 eps); rewrite (Rmult_plus_distr_l eps 1 1);
+ elim (Rmult_ne eps); intros a b; rewrite a; clear a b;
+ generalize (R_dist_tri l l' (f x2)); unfold R_dist in |- *; 
+ intros;
+ apply
+  (Rle_lt_trans (Rabs (l - l')) (Rabs (l - f x2) + Rabs (f x2 - l'))
+     (eps + eps) H3 H1).
+Qed.
+
+(*********)
+Lemma limit_comp :
+ forall (f g:R -> R) (Df Dg:R -> Prop) (l l' x0:R),
+   limit1_in f Df l x0 ->
+   limit1_in g Dg l' l -> limit1_in (fun x:R => g (f x)) (Dgf Df Dg f) l' x0.
+unfold limit1_in, limit_in, Dgf in |- *; simpl in |- *.
+intros f g Df Dg l l' x0 Hf Hg eps eps_pos.
+elim (Hg eps eps_pos).
+intros alpg lg.
+elim (Hf alpg).
+2: tauto.
+intros alpf lf.
+exists alpf.
+intuition.
+Qed.
+
+(*********)
+
+Lemma limit_inv :
+ forall (f:R -> R) (D:R -> Prop) (l x0:R),
+   limit1_in f D l x0 -> l <> 0 -> limit1_in (fun x:R => / f x) D (/ l) x0.
+unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
+ unfold R_dist in |- *; intros; elim (H (Rabs l / 2)).
+intros delta1 H2; elim (H (eps * (Rsqr l / 2))).
+intros delta2 H3; elim H2; elim H3; intros; exists (Rmin delta1 delta2);
+ split.
+unfold Rmin in |- *; case (Rle_dec delta1 delta2); intro; assumption.
+intro; generalize (H5 x); clear H5; intro H5; generalize (H7 x); clear H7;
+ intro H7; intro H10; elim H10; intros; cut (D x /\ Rabs (x - x0) < delta1).
+cut (D x /\ Rabs (x - x0) < delta2).
+intros; generalize (H5 H11); clear H5; intro H5; generalize (H7 H12);
+ clear H7; intro H7; generalize (Rabs_triang_inv l (f x)); 
+ intro; rewrite Rabs_minus_sym in H7;
+ generalize
+  (Rle_lt_trans (Rabs l - Rabs (f x)) (Rabs (l - f x)) (Rabs l / 2) H13 H7);
+ intro;
+ generalize
+  (Rplus_lt_compat_l (Rabs (f x) - Rabs l / 2) (Rabs l - Rabs (f x))
+     (Rabs l / 2) H14);
+ replace (Rabs (f x) - Rabs l / 2 + (Rabs l - Rabs (f x))) with (Rabs l / 2).
+unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+ rewrite Rplus_0_r; intro; cut (f x <> 0).
+intro; replace (/ f x + - / l) with ((l - f x) * / (l * f x)).
+rewrite Rabs_mult; rewrite Rabs_Rinv.
+cut (/ Rabs (l * f x) < 2 / Rsqr l).
+intro; rewrite Rabs_minus_sym in H5; cut (0 <= / Rabs (l * f x)).
+intro;
+ generalize
+  (Rmult_le_0_lt_compat (Rabs (l - f x)) (eps * (Rsqr l / 2))
+     (/ Rabs (l * f x)) (2 / Rsqr l) (Rabs_pos (l - f x)) H18 H5 H17);
+ replace (eps * (Rsqr l / 2) * (2 / Rsqr l)) with eps.
+intro; assumption.
+unfold Rdiv in |- *; unfold Rsqr in |- *; rewrite Rinv_mult_distr.
+repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm l).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+rewrite (Rmult_comm l).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; reflexivity.
+discrR.
+exact H0.
+exact H0.
+exact H0.
+exact H0.
+left; apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply prod_neq_R0;
+ assumption.
+rewrite Rmult_comm; rewrite Rabs_mult; rewrite Rinv_mult_distr.
+rewrite (Rsqr_abs l); unfold Rsqr in |- *; unfold Rdiv in |- *;
+ rewrite Rinv_mult_distr.
+repeat rewrite <- Rmult_assoc; apply Rmult_lt_compat_r.
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+apply Rmult_lt_reg_l with (Rabs (f x) * Rabs l * / 2).
+repeat apply Rmult_lt_0_compat.
+apply Rabs_pos_lt; assumption.
+apply Rabs_pos_lt; assumption.
+apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
+ [ intro H17; generalize (lt_INR_0 2 (neq_O_lt 2 H17)); unfold INR in |- *;
+    intro H18; assumption
+ | discriminate ].
+replace (Rabs (f x) * Rabs l * / 2 * / Rabs (f x)) with (Rabs l / 2).
+replace (Rabs (f x) * Rabs l * / 2 * (2 * / Rabs l)) with (Rabs (f x)).
+assumption.
+repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm (Rabs l)).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; reflexivity.
+discrR.
+apply Rabs_no_R0.
+assumption.
+unfold Rdiv in |- *.
+repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm (Rabs (f x))).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+reflexivity.
+apply Rabs_no_R0; assumption.
+apply Rabs_no_R0; assumption.
+apply Rabs_no_R0; assumption.
+apply Rabs_no_R0; assumption.
+apply Rabs_no_R0; assumption.
+apply prod_neq_R0; assumption.
+rewrite (Rinv_mult_distr _ _ H0 H16).
+unfold Rminus in |- *; rewrite Rmult_plus_distr_r.
+rewrite <- Rmult_assoc.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l.
+rewrite Ropp_mult_distr_l_reverse.
+rewrite (Rmult_comm (f x)).
+rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+reflexivity.
+assumption.
+assumption.
+red in |- *; intro; rewrite H16 in H15; rewrite Rabs_R0 in H15;
+ cut (0 < Rabs l / 2).
+intro; elim (Rlt_irrefl 0 (Rlt_trans 0 (Rabs l / 2) 0 H17 H15)).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply Rabs_pos_lt; assumption.
+apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
+ [ intro H17; generalize (lt_INR_0 2 (neq_O_lt 2 H17)); unfold INR in |- *;
+    intro; assumption
+ | discriminate ].
+pattern (Rabs l) at 3 in |- *; rewrite double_var.
+ring.
+split;
+ [ assumption
+ | apply Rlt_le_trans with (Rmin delta1 delta2);
+    [ assumption | apply Rmin_r ] ].
+split;
+ [ assumption
+ | apply Rlt_le_trans with (Rmin delta1 delta2);
+    [ assumption | apply Rmin_l ] ].
+change (0 < eps * (Rsqr l / 2)) in |- *; unfold Rdiv in |- *;
+ repeat rewrite Rmult_assoc; repeat apply Rmult_lt_0_compat.
+assumption.
+apply Rsqr_pos_lt; assumption.
+apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
+ [ intro H3; generalize (lt_INR_0 2 (neq_O_lt 2 H3)); unfold INR in |- *;
+    intro; assumption
+ | discriminate ].
+change (0 < Rabs l / 2) in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply Rabs_pos_lt; assumption
+ | apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
+    [ intro H3; generalize (lt_INR_0 2 (neq_O_lt 2 H3)); unfold INR in |- *;
+       intro; assumption
+    | discriminate ] ].
+Qed.
diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v
new file mode 100644
index 00000000..7575d929
--- /dev/null
+++ b/theories/Reals/Rpower.v
@@ -0,0 +1,661 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Rpower.v,v 1.17.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+(*i Due to L.Thery i*) 
+
+(************************************************************)
+(* Definitions of log and Rpower : R->R->R; main properties *)
+(************************************************************)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import Ranalysis1.
+Require Import Exp_prop.
+Require Import Rsqrt_def.
+Require Import R_sqrt.
+Require Import MVT.
+Require Import Ranalysis4. Open Local Scope R_scope.
+
+Lemma P_Rmin : forall (P:R -> Prop) (x y:R), P x -> P y -> P (Rmin x y).
+intros P x y H1 H2; unfold Rmin in |- *; case (Rle_dec x y); intro;
+ assumption.
+Qed.
+
+Lemma exp_le_3 : exp 1 <= 3.
+assert (exp_1 : exp 1 <> 0).
+assert (H0 := exp_pos 1); red in |- *; intro; rewrite H in H0;
+ elim (Rlt_irrefl _ H0).
+apply Rmult_le_reg_l with (/ exp 1).
+apply Rinv_0_lt_compat; apply exp_pos.
+rewrite <- Rinv_l_sym.
+apply Rmult_le_reg_l with (/ 3).
+apply Rinv_0_lt_compat; prove_sup0.
+rewrite Rmult_1_r; rewrite <- (Rmult_comm 3); rewrite <- Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; replace (/ exp 1) with (exp (-1)).
+unfold exp in |- *; case (exist_exp (-1)); intros; simpl in |- *;
+ unfold exp_in in e;
+ assert (H := alternated_series_ineq (fun i:nat => / INR (fact i)) x 1).
+cut
+ (sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (S (2 * 1)) <= x <=
+  sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (2 * 1)).
+intro; elim H0; clear H0; intros H0 _; simpl in H0; unfold tg_alt in H0;
+ simpl in H0.
+replace (/ 3) with
+ (1 * / 1 + -1 * 1 * / 1 + -1 * (-1 * 1) * / 2 +
+  -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)).
+apply H0.
+repeat rewrite Rinv_1; repeat rewrite Rmult_1_r;
+ rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l;
+ rewrite Ropp_involutive; rewrite Rplus_opp_r; rewrite Rmult_1_r;
+ rewrite Rplus_0_l; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 6.
+rewrite Rmult_plus_distr_l; replace (2 + 1 + 1 + 1 + 1) with 6.
+rewrite <- (Rmult_comm (/ 6)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; replace 6 with 6.
+do 2 rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; rewrite (Rmult_comm 3); rewrite <- Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+ring.
+discrR.
+discrR.
+ring.
+discrR.
+ring.
+discrR.
+apply H.
+unfold Un_decreasing in |- *; intros;
+ apply Rmult_le_reg_l with (INR (fact n)).
+apply INR_fact_lt_0.
+apply Rmult_le_reg_l with (INR (fact (S n))).
+apply INR_fact_lt_0.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; apply le_INR; apply fact_le; apply le_n_Sn.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+assert (H0 := cv_speed_pow_fact 1); unfold Un_cv in |- *; unfold Un_cv in H0;
+ intros; elim (H0 _ H1); intros; exists x0; intros; 
+ unfold R_dist in H2; unfold R_dist in |- *;
+ replace (/ INR (fact n)) with (1 ^ n / INR (fact n)).
+apply (H2 _ H3).
+unfold Rdiv in |- *; rewrite pow1; rewrite Rmult_1_l; reflexivity.
+unfold infinit_sum in e; unfold Un_cv, tg_alt in |- *; intros; elim (e _ H0);
+ intros; exists x0; intros;
+ replace (sum_f_R0 (fun i:nat => (-1) ^ i * / INR (fact i)) n) with
+  (sum_f_R0 (fun i:nat => / INR (fact i) * (-1) ^ i) n).
+apply (H1 _ H2).
+apply sum_eq; intros; apply Rmult_comm.
+apply Rmult_eq_reg_l with (exp 1).
+rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0;
+ rewrite <- Rinv_r_sym.
+reflexivity.
+assumption.
+assumption.
+discrR.
+assumption.
+Qed.
+
+(******************************************************************)
+(*                        Properties of  Exp                      *)
+(******************************************************************)
+
+Theorem exp_increasing : forall x y:R, x < y -> exp x < exp y.
+intros x y H.
+assert (H0 : derivable exp).
+apply derivable_exp.
+assert (H1 := positive_derivative _ H0).
+unfold strict_increasing in H1.
+apply H1.
+intro.
+replace (derive_pt exp x0 (H0 x0)) with (exp x0).
+apply exp_pos.
+symmetry  in |- *; apply derive_pt_eq_0.
+apply (derivable_pt_lim_exp x0).
+apply H.
+Qed.
+ 
+Theorem exp_lt_inv : forall x y:R, exp x < exp y -> x < y.
+intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ].
+assumption.
+rewrite H1 in H; elim (Rlt_irrefl _ H).
+assert (H2 := exp_increasing _ _ H1).
+elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H2)).
+Qed.
+ 
+Lemma exp_ineq1 : forall x:R, 0 < x -> 1 + x < exp x.
+intros; apply Rplus_lt_reg_r with (- exp 0); rewrite <- (Rplus_comm (exp x));
+ assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0; 
+ intros; elim H1; intros; unfold Rminus in H2; rewrite H2; 
+ rewrite Ropp_0; rewrite Rplus_0_r;
+ replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0).
+rewrite exp_0; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
+ pattern x at 1 in |- *; rewrite <- Rmult_1_r; rewrite (Rmult_comm (exp x0));
+ apply Rmult_lt_compat_l.
+apply H.
+rewrite <- exp_0; apply exp_increasing; elim H3; intros; assumption.
+symmetry  in |- *; apply derive_pt_eq_0; apply derivable_pt_lim_exp.
+Qed.
+
+Lemma ln_exists1 : forall y:R, 0 < y -> 1 <= y -> sigT (fun z:R => y = exp z).
+intros; set (f := fun x:R => exp x - y); cut (f 0 <= 0).
+intro; cut (continuity f).
+intro; cut (0 <= f y).
+intro; cut (f 0 * f y <= 0).
+intro; assert (X := IVT_cor f 0 y H2 (Rlt_le _ _ H) H4); elim X; intros t H5;
+ apply existT with t; elim H5; intros; unfold f in H7;
+ apply Rminus_diag_uniq_sym; exact H7.
+pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y));
+ rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l; 
+ assumption.
+unfold f in |- *; apply Rplus_le_reg_l with y; left;
+ apply Rlt_trans with (1 + y).
+rewrite <- (Rplus_comm y); apply Rplus_lt_compat_l; apply Rlt_0_1.
+replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y H) | ring ].
+unfold f in |- *; change (continuity (exp - fct_cte y)) in |- *;
+ apply continuity_minus;
+ [ apply derivable_continuous; apply derivable_exp
+ | apply derivable_continuous; apply derivable_const ].
+unfold f in |- *; rewrite exp_0; apply Rplus_le_reg_l with y;
+ rewrite Rplus_0_r; replace (y + (1 - y)) with 1; [ apply H0 | ring ].
+Qed.
+
+(**********)
+Lemma ln_exists : forall y:R, 0 < y -> sigT (fun z:R => y = exp z).
+intros; case (Rle_dec 1 y); intro.
+apply (ln_exists1 _ H r).
+assert (H0 : 1 <= / y).
+apply Rmult_le_reg_l with y.
+apply H.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ n).
+red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
+assert (H1 : 0 < / y).
+apply Rinv_0_lt_compat; apply H.
+assert (H2 := ln_exists1 _ H1 H0); elim H2; intros; apply existT with (- x);
+ apply Rmult_eq_reg_l with (exp x / y).
+unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc;
+ rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0; 
+ rewrite Rmult_1_r; symmetry  in |- *; apply p.
+red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
+unfold Rdiv in |- *; apply prod_neq_R0.
+assert (H3 := exp_pos x); red in |- *; intro; rewrite H4 in H3;
+ elim (Rlt_irrefl _ H3).
+apply Rinv_neq_0_compat; red in |- *; intro; rewrite H3 in H;
+ elim (Rlt_irrefl _ H).
+Qed.
+
+(* Definition of log R+* -> R *)
+Definition Rln (y:posreal) : R :=
+  match ln_exists (pos y) (cond_pos y) with
+  | existT a b => a
+  end.
+
+(* Extension on R *)
+Definition ln (x:R) : R :=
+  match Rlt_dec 0 x with
+  | left a => Rln (mkposreal x a)
+  | right a => 0
+  end.
+
+Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x.
+intros; unfold ln in |- *; case (Rlt_dec 0 x); intro.
+unfold Rln in |- *;
+ case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r))); 
+ intros.
+simpl in e; symmetry  in |- *; apply e.
+elim n; apply H.
+Qed.
+
+Theorem exp_inv : forall x y:R, exp x = exp y -> x = y.
+intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ]; auto;
+ assert (H2 := exp_increasing _ _ H1); rewrite H in H2;
+ elim (Rlt_irrefl _ H2).
+Qed.
+ 
+Theorem exp_Ropp : forall x:R, exp (- x) = / exp x.
+intros x; assert (H : exp x <> 0).
+assert (H := exp_pos x); red in |- *; intro; rewrite H0 in H;
+ elim (Rlt_irrefl _ H).
+apply Rmult_eq_reg_l with (r := exp x).
+rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0.
+apply Rinv_r_sym.
+apply H.
+apply H.
+Qed.
+ 
+(******************************************************************)
+(*                        Properties of  Ln                       *)
+(******************************************************************)
+
+Theorem ln_increasing : forall x y:R, 0 < x -> x < y -> ln x < ln y.
+intros x y H H0; apply exp_lt_inv.
+repeat rewrite exp_ln. 
+apply H0.
+apply Rlt_trans with x; assumption.
+apply H.
+Qed.
+
+Theorem ln_exp : forall x:R, ln (exp x) = x.
+intros x; apply exp_inv.
+apply exp_ln.
+apply exp_pos.
+Qed.
+ 
+Theorem ln_1 : ln 1 = 0.
+rewrite <- exp_0; rewrite ln_exp; reflexivity.
+Qed.
+ 
+Theorem ln_lt_inv : forall x y:R, 0 < x -> 0 < y -> ln x < ln y -> x < y.
+intros x y H H0 H1; rewrite <- (exp_ln x); try rewrite <- (exp_ln y).
+apply exp_increasing; apply H1.
+assumption. 
+assumption.
+Qed.
+ 
+Theorem ln_inv : forall x y:R, 0 < x -> 0 < y -> ln x = ln y -> x = y.
+intros x y H H0 H'0; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ];
+ auto.
+assert (H2 := ln_increasing _ _ H H1); rewrite H'0 in H2;
+ elim (Rlt_irrefl _ H2).
+assert (H2 := ln_increasing _ _ H0 H1); rewrite H'0 in H2;
+ elim (Rlt_irrefl _ H2).
+Qed.
+ 
+Theorem ln_mult : forall x y:R, 0 < x -> 0 < y -> ln (x * y) = ln x + ln y.
+intros x y H H0; apply exp_inv.
+rewrite exp_plus.
+repeat rewrite exp_ln.
+reflexivity.
+assumption.
+assumption.
+apply Rmult_lt_0_compat; assumption.
+Qed.
+
+Theorem ln_Rinv : forall x:R, 0 < x -> ln (/ x) = - ln x.
+intros x H; apply exp_inv; repeat rewrite exp_ln || rewrite exp_Ropp.
+reflexivity.
+assumption. 
+apply Rinv_0_lt_compat; assumption.
+Qed.
+
+Theorem ln_continue :
+ forall y:R, 0 < y -> continue_in ln (fun x:R => 0 < x) y.
+intros y H.
+unfold continue_in, limit1_in, limit_in in |- *; intros eps Heps.
+cut (1 < exp eps); [ intros H1 | idtac ].
+cut (exp (- eps) < 1); [ intros H2 | idtac ].
+exists (Rmin (y * (exp eps - 1)) (y * (1 - exp (- eps)))); split.
+red in |- *; apply P_Rmin.
+apply Rmult_lt_0_compat.
+assumption.
+apply Rplus_lt_reg_r with 1.
+rewrite Rplus_0_r; replace (1 + (exp eps - 1)) with (exp eps);
+ [ apply H1 | ring ].
+apply Rmult_lt_0_compat.
+assumption.
+apply Rplus_lt_reg_r with (exp (- eps)).
+rewrite Rplus_0_r; replace (exp (- eps) + (1 - exp (- eps))) with 1;
+ [ apply H2 | ring ].
+unfold dist, R_met, R_dist in |- *; simpl in |- *.
+intros x [[H3 H4] H5].
+cut (y * (x * / y) = x).
+intro Hxyy. 
+replace (ln x - ln y) with (ln (x * / y)).
+case (Rtotal_order x y); [ intros Hxy | intros [Hxy| Hxy] ].
+rewrite Rabs_left.
+apply Ropp_lt_cancel; rewrite Ropp_involutive.
+apply exp_lt_inv.
+rewrite exp_ln.
+apply Rmult_lt_reg_l with (r := y).
+apply H.
+rewrite Hxyy.
+apply Ropp_lt_cancel.
+apply Rplus_lt_reg_r with (r := y).
+replace (y + - (y * exp (- eps))) with (y * (1 - exp (- eps)));
+ [ idtac | ring ].
+replace (y + - x) with (Rabs (x - y)); [ idtac | ring ].
+apply Rlt_le_trans with (1 := H5); apply Rmin_r.
+rewrite Rabs_left; [ ring | idtac ].
+apply (Rlt_minus _ _ Hxy).
+apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
+rewrite <- ln_1.
+apply ln_increasing.
+apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
+apply Rmult_lt_reg_l with (r := y).
+apply H.
+rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
+rewrite Hxy; rewrite Rinv_r.
+rewrite ln_1; rewrite Rabs_R0; apply Heps.
+red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
+rewrite Rabs_right.
+apply exp_lt_inv.
+rewrite exp_ln.
+apply Rmult_lt_reg_l with (r := y).
+apply H.
+rewrite Hxyy.
+apply Rplus_lt_reg_r with (r := - y).
+replace (- y + y * exp eps) with (y * (exp eps - 1)); [ idtac | ring ].
+replace (- y + x) with (Rabs (x - y)); [ idtac | ring ].
+apply Rlt_le_trans with (1 := H5); apply Rmin_l.
+rewrite Rabs_right; [ ring | idtac ].
+left; apply (Rgt_minus _ _ Hxy).
+apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
+rewrite <- ln_1.
+apply Rgt_ge; red in |- *; apply ln_increasing.
+apply Rlt_0_1.
+apply Rmult_lt_reg_l with (r := y).
+apply H.
+rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
+rewrite ln_mult.
+rewrite ln_Rinv.
+ring.
+assumption.
+assumption.
+apply Rinv_0_lt_compat; assumption.
+rewrite (Rmult_comm x); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+ring.
+red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
+apply Rmult_lt_reg_l with (exp eps).
+apply exp_pos.
+rewrite <- exp_plus; rewrite Rmult_1_r; rewrite Rplus_opp_r; rewrite exp_0;
+ apply H1.
+rewrite <- exp_0.
+apply exp_increasing; apply Heps.
+Qed.
+
+(******************************************************************)
+(*                        Definition of  Rpower                   *)
+(******************************************************************)
+ 
+Definition Rpower (x y:R) := exp (y * ln x).
+
+Infix Local "^R" := Rpower (at level 30, right associativity) : R_scope.
+
+(******************************************************************)
+(*                        Properties of  Rpower                   *)
+(******************************************************************)
+ 
+Theorem Rpower_plus : forall x y z:R, z ^R (x + y) = z ^R x * z ^R y.
+intros x y z; unfold Rpower in |- *.
+rewrite Rmult_plus_distr_r; rewrite exp_plus; auto.
+Qed.
+ 
+Theorem Rpower_mult : forall x y z:R, (x ^R y) ^R z = x ^R (y * z).
+intros x y z; unfold Rpower in |- *.
+rewrite ln_exp.
+replace (z * (y * ln x)) with (y * z * ln x).
+reflexivity.
+ring.
+Qed.
+ 
+Theorem Rpower_O : forall x:R, 0 < x -> x ^R 0 = 1.
+intros x H; unfold Rpower in |- *.
+rewrite Rmult_0_l; apply exp_0.
+Qed.
+ 
+Theorem Rpower_1 : forall x:R, 0 < x -> x ^R 1 = x.
+intros x H; unfold Rpower in |- *.
+rewrite Rmult_1_l; apply exp_ln; apply H.
+Qed.
+ 
+Theorem Rpower_pow : forall (n:nat) (x:R), 0 < x -> x ^R INR n = x ^ n.
+intros n; elim n; simpl in |- *; auto; fold INR in |- *.
+intros x H; apply Rpower_O; auto.
+intros n1; case n1.
+intros H x H0; simpl in |- *; rewrite Rmult_1_r; apply Rpower_1; auto.
+intros n0 H x H0; rewrite Rpower_plus; rewrite H; try rewrite Rpower_1;
+ try apply Rmult_comm || assumption.
+Qed.
+ 
+Theorem Rpower_lt :
+ forall x y z:R, 1 < x -> 0 <= y -> y < z -> x ^R y < x ^R z.
+intros x y z H H0 H1.
+unfold Rpower in |- *.
+apply exp_increasing.
+apply Rmult_lt_compat_r.
+rewrite <- ln_1; apply ln_increasing.
+apply Rlt_0_1.
+apply H.
+apply H1.
+Qed.
+ 
+Theorem Rpower_sqrt : forall x:R, 0 < x -> x ^R (/ 2) = sqrt x.
+intros x H.
+apply ln_inv.
+unfold Rpower in |- *; apply exp_pos.
+apply sqrt_lt_R0; apply H.
+apply Rmult_eq_reg_l with (INR 2).
+apply exp_inv.
+fold Rpower in |- *.
+cut ((x ^R (/ 2)) ^R INR 2 = sqrt x ^R INR 2).
+unfold Rpower in |- *; auto.
+rewrite Rpower_mult.
+rewrite Rinv_l.
+replace 1 with (INR 1); auto.
+repeat rewrite Rpower_pow; simpl in |- *.
+pattern x at 1 in |- *; rewrite <- (sqrt_sqrt x (Rlt_le _ _ H)).
+ring.
+apply sqrt_lt_R0; apply H.
+apply H.
+apply not_O_INR; discriminate.
+apply not_O_INR; discriminate.
+Qed.
+ 
+Theorem Rpower_Ropp : forall x y:R, x ^R (- y) = / x ^R y.
+unfold Rpower in |- *.
+intros x y; rewrite Ropp_mult_distr_l_reverse.
+apply exp_Ropp.
+Qed.
+ 
+Theorem Rle_Rpower :
+ forall e n m:R, 1 < e -> 0 <= n -> n <= m -> e ^R n <= e ^R m.
+intros e n m H H0 H1; case H1.
+intros H2; left; apply Rpower_lt; assumption.
+intros H2; rewrite H2; right; reflexivity.
+Qed.
+  
+Theorem ln_lt_2 : / 2 < ln 2.
+apply Rmult_lt_reg_l with (r := 2).
+prove_sup0.
+rewrite Rinv_r.
+apply exp_lt_inv.
+apply Rle_lt_trans with (1 := exp_le_3).
+change (3 < 2 ^R 2) in |- *.
+repeat rewrite Rpower_plus; repeat rewrite Rpower_1.
+repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
+ repeat rewrite Rmult_1_l.
+pattern 3 at 1 in |- *; rewrite <- Rplus_0_r; replace (2 + 2) with (3 + 1);
+ [ apply Rplus_lt_compat_l; apply Rlt_0_1 | ring ].
+prove_sup0.
+discrR.
+Qed.
+
+(**************************************)
+(* Differentiability of Ln and Rpower *)
+(**************************************)
+
+Theorem limit1_ext :
+ forall (f g:R -> R) (D:R -> Prop) (l x:R),
+   (forall x:R, D x -> f x = g x) -> limit1_in f D l x -> limit1_in g D l x.
+intros f g D l x H; unfold limit1_in, limit_in in |- *.
+intros H0 eps H1; case (H0 eps); auto.
+intros x0 [H2 H3]; exists x0; split; auto.
+intros x1 [H4 H5]; rewrite <- H; auto.
+Qed.
+
+Theorem limit1_imp :
+ forall (f:R -> R) (D D1:R -> Prop) (l x:R),
+   (forall x:R, D1 x -> D x) -> limit1_in f D l x -> limit1_in f D1 l x.
+intros f D D1 l x H; unfold limit1_in, limit_in in |- *.
+intros H0 eps H1; case (H0 eps H1); auto.
+intros alpha [H2 H3]; exists alpha; split; auto.
+intros d [H4 H5]; apply H3; split; auto.
+Qed.
+
+Theorem Rinv_Rdiv : forall x y:R, x <> 0 -> y <> 0 -> / (x / y) = y / x.
+intros x y H1 H2; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+rewrite Rinv_involutive.
+apply Rmult_comm.
+assumption.
+assumption.
+apply Rinv_neq_0_compat; assumption.
+Qed.
+
+Theorem Dln : forall y:R, 0 < y -> D_in ln Rinv (fun x:R => 0 < x) y.
+intros y Hy; unfold D_in in |- *.
+apply limit1_ext with
+ (f := fun x:R => / ((exp (ln x) - exp (ln y)) / (ln x - ln y))).
+intros x [HD1 HD2]; repeat rewrite exp_ln.
+unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+rewrite Rinv_involutive.
+apply Rmult_comm.
+apply Rminus_eq_contra.
+red in |- *; intros H2; case HD2.
+symmetry  in |- *; apply (ln_inv _ _ HD1 Hy H2).
+apply Rminus_eq_contra; apply (sym_not_eq HD2).
+apply Rinv_neq_0_compat; apply Rminus_eq_contra; red in |- *; intros H2;
+ case HD2; apply ln_inv; auto.
+assumption.
+assumption.
+apply limit_inv with
+ (f := fun x:R => (exp (ln x) - exp (ln y)) / (ln x - ln y)).
+apply limit1_imp with
+ (f := fun x:R => (fun x:R => (exp x - exp (ln y)) / (x - ln y)) (ln x))
+ (D := Dgf (D_x (fun x:R => 0 < x) y) (D_x (fun x:R => True) (ln y)) ln).
+intros x [H1 H2]; split.
+split; auto.
+split; auto.
+red in |- *; intros H3; case H2; apply ln_inv; auto.
+apply limit_comp with
+ (l := ln y) (g := fun x:R => (exp x - exp (ln y)) / (x - ln y)) (f := ln).
+apply ln_continue; auto.
+assert (H0 := derivable_pt_lim_exp (ln y)); unfold derivable_pt_lim in H0;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ simpl in |- *; unfold R_dist in |- *; intros; elim (H0 _ H); 
+ intros; exists (pos x); split.
+apply (cond_pos x).
+intros; pattern y at 3 in |- *; rewrite <- exp_ln.
+pattern x0 at 1 in |- *; replace x0 with (ln y + (x0 - ln y));
+ [ idtac | ring ].
+apply H1.
+elim H2; intros H3 _; unfold D_x in H3; elim H3; clear H3; intros _ H3;
+ apply Rminus_eq_contra; apply (sym_not_eq (A:=R)); 
+ apply H3.
+elim H2; clear H2; intros _ H2; apply H2.
+assumption.
+red in |- *; intro; rewrite H in Hy; elim (Rlt_irrefl _ Hy).
+Qed.
+
+Lemma derivable_pt_lim_ln : forall x:R, 0 < x -> derivable_pt_lim ln x (/ x).
+intros; assert (H0 := Dln x H); unfold D_in in H0; unfold limit1_in in H0;
+ unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
+ unfold derivable_pt_lim in |- *; intros; elim (H0 _ H1); 
+ intros; elim H2; clear H2; intros; set (alp := Rmin x0 (x / 2));
+ assert (H4 : 0 < alp).
+unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec x0 (x / 2)); intro.
+apply H2.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+exists (mkposreal _ H4); intros; pattern h at 2 in |- *;
+ replace h with (x + h - x); [ idtac | ring ].
+apply H3; split.
+unfold D_x in |- *; split.
+case (Rcase_abs h); intro.
+assert (H7 : Rabs h < x / 2).
+apply Rlt_le_trans with alp.
+apply H6.
+unfold alp in |- *; apply Rmin_r.
+apply Rlt_trans with (x / 2).
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+rewrite Rabs_left in H7.
+apply Rplus_lt_reg_r with (- h - x / 2).
+replace (- h - x / 2 + x / 2) with (- h); [ idtac | ring ].
+pattern x at 2 in |- *; rewrite double_var.
+replace (- h - x / 2 + (x / 2 + x / 2 + h)) with (x / 2); [ apply H7 | ring ].
+apply r.
+apply Rplus_lt_le_0_compat; [ assumption | apply Rge_le; apply r ].
+apply (sym_not_eq (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h;
+ [ apply H5 | ring ].
+replace (x + h - x) with h;
+ [ apply Rlt_le_trans with alp;
+    [ apply H6 | unfold alp in |- *; apply Rmin_l ]
+ | ring ].
+Qed.
+
+Theorem D_in_imp :
+ forall (f g:R -> R) (D D1:R -> Prop) (x:R),
+   (forall x:R, D1 x -> D x) -> D_in f g D x -> D_in f g D1 x.
+intros f g D D1 x H; unfold D_in in |- *.
+intros H0; apply limit1_imp with (D := D_x D x); auto.
+intros x1 [H1 H2]; split; auto.
+Qed.
+
+Theorem D_in_ext :
+ forall (f g h:R -> R) (D:R -> Prop) (x:R),
+   f x = g x -> D_in h f D x -> D_in h g D x.
+intros f g h D x H; unfold D_in in |- *.
+rewrite H; auto.
+Qed.
+
+Theorem Dpower :
+ forall y z:R,
+   0 < y ->
+   D_in (fun x:R => x ^R z) (fun x:R => z * x ^R (z - 1)) (
+     fun x:R => 0 < x) y.
+intros y z H;
+ apply D_in_imp with (D := Dgf (fun x:R => 0 < x) (fun x:R => True) ln).
+intros x H0; repeat split.
+assumption.
+apply D_in_ext with (f := fun x:R => / x * (z * exp (z * ln x))).
+unfold Rminus in |- *; rewrite Rpower_plus; rewrite Rpower_Ropp;
+ rewrite (Rpower_1 _ H); ring.
+apply Dcomp with
+ (f := ln)
+ (g := fun x:R => exp (z * x))
+ (df := Rinv)
+ (dg := fun x:R => z * exp (z * x)).
+apply (Dln _ H).
+apply D_in_imp with
+ (D := Dgf (fun x:R => True) (fun x:R => True) (fun x:R => z * x)).
+intros x H1; repeat split; auto.
+apply
+ (Dcomp (fun _:R => True) (fun _:R => True) (fun x => z) exp
+    (fun x:R => z * x) exp); simpl in |- *.
+apply D_in_ext with (f := fun x:R => z * 1).
+apply Rmult_1_r.
+apply (Dmult_const (fun x => True) (fun x => x) (fun x => 1)); apply Dx.
+assert (H0 := derivable_pt_lim_D_in exp exp (z * ln y)); elim H0; clear H0;
+ intros _ H0; apply H0; apply derivable_pt_lim_exp.
+Qed.
+
+Theorem derivable_pt_lim_power :
+ forall x y:R,
+   0 < x -> derivable_pt_lim (fun x => x ^R y) x (y * x ^R (y - 1)).
+intros x y H.
+unfold Rminus in |- *; rewrite Rpower_plus.
+rewrite Rpower_Ropp.
+rewrite Rpower_1; auto.
+rewrite <- Rmult_assoc.
+unfold Rpower in |- *.
+apply derivable_pt_lim_comp with (f1 := ln) (f2 := fun x => exp (y * x)).
+apply derivable_pt_lim_ln; assumption.
+rewrite (Rmult_comm y).
+apply derivable_pt_lim_comp with (f1 := fun x => y * x) (f2 := exp).
+pattern y at 2 in |- *; replace y with (0 * ln x + y * 1).
+apply derivable_pt_lim_mult with (f1 := fun x:R => y) (f2 := fun x:R => x).
+apply derivable_pt_lim_const with (a := y).
+apply derivable_pt_lim_id.
+ring.
+apply derivable_pt_lim_exp.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v
new file mode 100644
index 00000000..6577146f
--- /dev/null
+++ b/theories/Reals/Rprod.v
@@ -0,0 +1,191 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Rprod.v,v 1.10.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Compare.
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import PartSum.
+Require Import Binomial.
+Open Local Scope R_scope.
+
+(* TT Ak; 1<=k<=N *)
+Fixpoint prod_f_SO (An:nat -> R) (N:nat) {struct N} : R :=
+  match N with
+  | O => 1
+  | S p => prod_f_SO An p * An (S p)
+  end.
+
+(**********)
+Lemma prod_SO_split :
+ forall (An:nat -> R) (n k:nat),
+   (k <= n)%nat ->
+   prod_f_SO An n =
+   prod_f_SO An k * prod_f_SO (fun l:nat => An (k + l)%nat) (n - k).
+intros; induction  n as [| n Hrecn].
+cut (k = 0%nat);
+ [ intro; rewrite H0; simpl in |- *; ring | inversion H; reflexivity ].
+cut (k = S n \/ (k <= n)%nat).
+intro; elim H0; intro.
+rewrite H1; simpl in |- *; rewrite <- minus_n_n; simpl in |- *; ring.
+replace (S n - k)%nat with (S (n - k)).
+simpl in |- *; replace (k + S (n - k))%nat with (S n).
+rewrite Hrecn; [ ring | assumption ].
+apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite S_INR;
+ rewrite minus_INR; [ ring | assumption ].
+apply INR_eq; rewrite S_INR; repeat rewrite minus_INR.
+rewrite S_INR; ring.
+apply le_trans with n; [ assumption | apply le_n_Sn ].
+assumption.
+inversion H; [ left; reflexivity | right; assumption ].
+Qed.
+
+(**********)
+Lemma prod_SO_pos :
+ forall (An:nat -> R) (N:nat),
+   (forall n:nat, (n <= N)%nat -> 0 <= An n) -> 0 <= prod_f_SO An N.
+intros; induction  N as [| N HrecN].
+simpl in |- *; left; apply Rlt_0_1.
+simpl in |- *; apply Rmult_le_pos.
+apply HrecN; intros; apply H; apply le_trans with N;
+ [ assumption | apply le_n_Sn ].
+apply H; apply le_n.
+Qed.
+
+(**********)
+Lemma prod_SO_Rle :
+ forall (An Bn:nat -> R) (N:nat),
+   (forall n:nat, (n <= N)%nat -> 0 <= An n <= Bn n) ->
+   prod_f_SO An N <= prod_f_SO Bn N.
+intros; induction  N as [| N HrecN].
+right; reflexivity.
+simpl in |- *; apply Rle_trans with (prod_f_SO An N * Bn (S N)).
+apply Rmult_le_compat_l.
+apply prod_SO_pos; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
+ assumption.
+elim (H (S N) (le_n (S N))); intros; assumption.
+do 2 rewrite <- (Rmult_comm (Bn (S N))); apply Rmult_le_compat_l.
+elim (H (S N) (le_n (S N))); intros.
+apply Rle_trans with (An (S N)); assumption.
+apply HrecN; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
+ split; assumption.
+Qed.
+
+(* Application to factorial *)
+Lemma fact_prodSO :
+ forall n:nat, INR (fact n) = prod_f_SO (fun k:nat => INR k) n.
+intro; induction  n as [| n Hrecn].
+reflexivity.
+change (INR (S n * fact n) = prod_f_SO (fun k:nat => INR k) (S n)) in |- *.
+rewrite mult_INR; rewrite Rmult_comm; rewrite Hrecn; reflexivity.
+Qed.
+
+Lemma le_n_2n : forall n:nat, (n <= 2 * n)%nat.
+simple induction n.
+replace (2 * 0)%nat with 0%nat; [ apply le_n | ring ].
+intros; replace (2 * S n0)%nat with (S (S (2 * n0))).
+apply le_n_S; apply le_S; assumption.
+replace (S (S (2 * n0))) with (2 * n0 + 2)%nat; [ idtac | ring ].
+replace (S n0) with (n0 + 1)%nat; [ idtac | ring ].
+ring.
+Qed. 
+
+(* We prove that (N!)²<=(2N-k)!*k! forall k in [|O;2N|] *)
+Lemma RfactN_fact2N_factk :
+ forall N k:nat,
+   (k <= 2 * N)%nat ->
+   Rsqr (INR (fact N)) <= INR (fact (2 * N - k)) * INR (fact k).
+intros; unfold Rsqr in |- *; repeat rewrite fact_prodSO.
+cut ((k <= N)%nat \/ (N <= k)%nat).
+intro; elim H0; intro.
+rewrite (prod_SO_split (fun l:nat => INR l) (2 * N - k) N).
+rewrite Rmult_assoc; apply Rmult_le_compat_l.
+apply prod_SO_pos; intros; apply pos_INR.
+replace (2 * N - k - N)%nat with (N - k)%nat.
+rewrite Rmult_comm; rewrite (prod_SO_split (fun l:nat => INR l) N k).
+apply Rmult_le_compat_l.
+apply prod_SO_pos; intros; apply pos_INR.
+apply prod_SO_Rle; intros; split.
+apply pos_INR.
+apply le_INR; apply plus_le_compat_r; assumption.
+assumption.
+apply INR_eq; repeat rewrite minus_INR.
+rewrite mult_INR; repeat rewrite S_INR; ring.
+apply le_trans with N; [ assumption | apply le_n_2n ].
+apply (fun p n m:nat => plus_le_reg_l n m p) with k; rewrite <- le_plus_minus.
+replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ].
+apply plus_le_compat_r; assumption.
+assumption.
+assumption.
+apply (fun p n m:nat => plus_le_reg_l n m p) with k; rewrite <- le_plus_minus.
+replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ].
+apply plus_le_compat_r; assumption.
+assumption.
+rewrite <- (Rmult_comm (prod_f_SO (fun l:nat => INR l) k));
+ rewrite (prod_SO_split (fun l:nat => INR l) k N).
+rewrite Rmult_assoc; apply Rmult_le_compat_l.
+apply prod_SO_pos; intros; apply pos_INR.
+rewrite Rmult_comm;
+ rewrite (prod_SO_split (fun l:nat => INR l) N (2 * N - k)).
+apply Rmult_le_compat_l.
+apply prod_SO_pos; intros; apply pos_INR.
+replace (N - (2 * N - k))%nat with (k - N)%nat.
+apply prod_SO_Rle; intros; split.
+apply pos_INR.
+apply le_INR; apply plus_le_compat_r.
+apply (fun p n m:nat => plus_le_reg_l n m p) with k; rewrite <- le_plus_minus.
+replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ];
+ apply plus_le_compat_r; assumption.
+assumption.
+apply INR_eq; repeat rewrite minus_INR.
+rewrite mult_INR; do 2 rewrite S_INR; ring.
+assumption.
+apply (fun p n m:nat => plus_le_reg_l n m p) with k; rewrite <- le_plus_minus.
+replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ];
+ apply plus_le_compat_r; assumption.
+assumption.
+assumption.
+apply (fun p n m:nat => plus_le_reg_l n m p) with k; rewrite <- le_plus_minus.
+replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ];
+ apply plus_le_compat_r; assumption.
+assumption.
+assumption.
+elim (le_dec k N); intro; [ left; assumption | right; assumption ].
+Qed.
+
+(**********)
+Lemma INR_fact_lt_0 : forall n:nat, 0 < INR (fact n).
+intro; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
+ elim (fact_neq_0 n); symmetry  in |- *; assumption.
+Qed.
+
+(* We have the following inequality : (C 2N k) <= (C 2N N) forall k in [|O;2N|] *)
+Lemma C_maj : forall N k:nat, (k <= 2 * N)%nat -> C (2 * N) k <= C (2 * N) N.
+intros; unfold C in |- *; unfold Rdiv in |- *; apply Rmult_le_compat_l.
+apply pos_INR.
+replace (2 * N - N)%nat with N.
+apply Rmult_le_reg_l with (INR (fact N) * INR (fact N)).
+apply Rmult_lt_0_compat; apply INR_fact_lt_0.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_comm;
+ apply Rmult_le_reg_l with (INR (fact k) * INR (fact (2 * N - k))).
+apply Rmult_lt_0_compat; apply INR_fact_lt_0.
+rewrite Rmult_1_r; rewrite <- mult_INR; rewrite <- Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; rewrite mult_INR; rewrite (Rmult_comm (INR (fact k)));
+ replace (INR (fact N) * INR (fact N)) with (Rsqr (INR (fact N))).
+apply RfactN_fact2N_factk.
+assumption.
+reflexivity.
+rewrite mult_INR; apply prod_neq_R0; apply INR_fact_neq_0.
+apply prod_neq_R0; apply INR_fact_neq_0.
+apply INR_eq; rewrite minus_INR;
+ [ rewrite mult_INR; do 2 rewrite S_INR; ring | apply le_n_2n ].
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v
new file mode 100644
index 00000000..cbf93278
--- /dev/null
+++ b/theories/Reals/Rseries.v
@@ -0,0 +1,275 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rseries.v,v 1.11.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Classical.
+Require Import Compare.
+Open Local Scope R_scope.
+
+Implicit Type r : R.
+
+(* classical is needed for [Un_cv_crit] *)
+(*********************************************************)
+(*           Definition of sequence and properties       *)
+(*                                                       *)
+(*********************************************************)
+
+Section sequence.
+
+(*********)
+Variable Un : nat -> R.
+
+(*********)
+Fixpoint Rmax_N (N:nat) : R :=
+  match N with
+  | O => Un 0
+  | S n => Rmax (Un (S n)) (Rmax_N n)
+  end.
+
+(*********)
+Definition EUn r : Prop :=  exists i : nat, r = Un i.
+
+(*********)
+Definition Un_cv (l:R) : Prop :=
+  forall eps:R,
+    eps > 0 ->
+     exists N : nat, (forall n:nat, (n >= N)%nat -> R_dist (Un n) l < eps).
+
+(*********)
+Definition Cauchy_crit : Prop :=
+  forall eps:R,
+    eps > 0 ->
+     exists N : nat,
+      (forall n m:nat,
+         (n >= N)%nat -> (m >= N)%nat -> R_dist (Un n) (Un m) < eps).
+
+(*********)
+Definition Un_growing : Prop := forall n:nat, Un n <= Un (S n).
+
+(*********)
+Lemma EUn_noempty :  exists r : R, EUn r.
+unfold EUn in |- *; split with (Un 0); split with 0%nat; trivial.
+Qed.
+
+(*********)
+Lemma Un_in_EUn : forall n:nat, EUn (Un n).
+intro; unfold EUn in |- *; split with n; trivial.
+Qed.
+
+(*********)
+Lemma Un_bound_imp :
+ forall x:R, (forall n:nat, Un n <= x) -> is_upper_bound EUn x.
+intros; unfold is_upper_bound in |- *; intros; unfold EUn in H0; elim H0;
+ clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1; 
+ trivial.
+Qed.
+
+(*********)
+Lemma growing_prop :
+ forall n m:nat, Un_growing -> (n >= m)%nat -> Un n >= Un m.
+double induction n m; intros.
+unfold Rge in |- *; right; trivial.
+elimtype False; unfold ge in H1; generalize (le_Sn_O n0); intro; auto.
+cut (n0 >= 0)%nat.
+generalize H0; intros; unfold Un_growing in H0;
+ apply
+  (Rge_trans (Un (S n0)) (Un n0) (Un 0) (Rle_ge (Un n0) (Un (S n0)) (H0 n0))
+     (H 0%nat H2 H3)).
+elim n0; auto.
+elim (lt_eq_lt_dec n1 n0); intro y.
+elim y; clear y; intro y.
+unfold ge in H2; generalize (le_not_lt n0 n1 (le_S_n n0 n1 H2)); intro;
+ elimtype False; auto.
+rewrite y; unfold Rge in |- *; right; trivial.
+unfold ge in H0; generalize (H0 (S n0) H1 (lt_le_S n0 n1 y)); intro;
+ unfold Un_growing in H1;
+ apply
+  (Rge_trans (Un (S n1)) (Un n1) (Un (S n0))
+     (Rle_ge (Un n1) (Un (S n1)) (H1 n1)) H3).
+Qed.
+
+
+(* classical is needed: [not_all_not_ex] *)
+(*********)
+Lemma Un_cv_crit : Un_growing -> bound EUn ->  exists l : R, Un_cv l.
+unfold Un_growing, Un_cv in |- *; intros;
+ generalize (completeness_weak EUn H0 EUn_noempty); 
+ intro; elim H1; clear H1; intros; split with x; intros; 
+ unfold is_lub in H1; unfold bound in H0; unfold is_upper_bound in H0, H1;
+ elim H0; clear H0; intros; elim H1; clear H1; intros; 
+ generalize (H3 x0 H0); intro; cut (forall n:nat, Un n <= x); 
+ intro.
+cut (exists N : nat, x - eps < Un N).
+intro; elim H6; clear H6; intros; split with x1.
+intros; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps).
+unfold Rgt in H2;
+ apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H2).
+fold Un_growing in H; generalize (growing_prop n x1 H H7); intro;
+ generalize
+  (Rlt_le_trans (x - eps) (Un x1) (Un n) H6 (Rge_le (Un n) (Un x1) H8));
+ intro; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9);
+ unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps));
+ rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *;
+ rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2);
+ trivial.
+cut (~ (forall N:nat, x - eps >= Un N)).
+intro; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)); red in |- *;
+ intro; red in H6; elim H6; clear H6; intro;
+ apply (Rnot_lt_ge (x - eps) (Un N) (H7 N)).
+red in |- *; intro; cut (forall N:nat, Un N <= x - eps).
+intro; generalize (Un_bound_imp (x - eps) H7); intro;
+ unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); 
+ intro; generalize (Rle_minus x (x - eps) H9); unfold Rminus in |- *;
+ rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
+ rewrite (let (H1, H2) := Rplus_ne (- - eps) in H2); 
+ rewrite Ropp_involutive; intro; unfold Rgt in H2;
+ generalize (Rgt_not_le eps 0 H2); intro; auto.
+intro; elim (H6 N); intro; unfold Rle in |- *.
+left; unfold Rgt in H7; assumption.
+right; auto.
+apply (H1 (Un n) (Un_in_EUn n)).
+Qed.
+
+(*********)
+Lemma finite_greater :
+ forall N:nat,  exists M : R, (forall n:nat, (n <= N)%nat -> Un n <= M).
+intro; induction  N as [| N HrecN].
+split with (Un 0); intros; rewrite (le_n_O_eq n H);
+ apply (Req_le (Un n) (Un n) (refl_equal (Un n))).
+elim HrecN; clear HrecN; intros; split with (Rmax (Un (S N)) x); intros;
+ elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1; 
+ inversion H0.
+rewrite <- H1; rewrite <- H1 in H2;
+ apply
+  (H2 (or_introl (Un n <= x) (Req_le (Un n) (Un n) (refl_equal (Un n))))).
+apply (H2 (or_intror (Un n <= Un (S N)) (H n H3))).
+Qed.
+
+(*********)
+Lemma cauchy_bound : Cauchy_crit -> bound EUn.
+unfold Cauchy_crit, bound in |- *; intros; unfold is_upper_bound in |- *;
+ unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros; 
+ generalize (H x); intro; generalize (le_dec x); intro;
+ elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1)); 
+ clear H; intros; unfold EUn in H; elim H; clear H; 
+ intros; elim (H1 x2); clear H1; intro y.
+unfold ge in H0; generalize (H0 x2 (le_n x) y); clear H0; intro;
+ rewrite <- H in H0; unfold R_dist in H0; elim (Rabs_def2 (Un x - x1) 1 H0);
+ clear H0; intros; elim (Rmax_Rle x0 (Un x + 1) x1); 
+ intros; apply H4; clear H3 H4; right; clear H H0 y;
+ apply (Rlt_le x1 (Un x + 1)); generalize (Rlt_minus (-1) (Un x - x1) H1);
+ clear H1; intro; apply (Rminus_lt x1 (Un x + 1));
+ cut (-1 - (Un x - x1) = x1 - (Un x + 1));
+ [ intro; rewrite H0 in H; assumption | ring ].
+generalize (H2 x2 y); clear H2 H0; intro; rewrite <- H in H0;
+ elim (Rmax_Rle x0 (Un x + 1) x1); intros; clear H1; 
+ apply H2; left; assumption.
+Qed.
+
+End sequence.
+
+(*****************************************************************)
+(*           Definition of Power Series and properties           *)
+(*                                                               *)
+(*****************************************************************)
+
+Section Isequence.
+
+(*********)
+Variable An : nat -> R.
+
+(*********)
+Definition Pser (x l:R) : Prop := infinit_sum (fun n:nat => An n * x ^ n) l.
+
+End Isequence.
+
+Lemma GP_infinite :
+ forall x:R, Rabs x < 1 -> Pser (fun n:nat => 1) x (/ (1 - x)).
+intros; unfold Pser in |- *; unfold infinit_sum in |- *; intros;
+ elim (Req_dec x 0).
+intros; exists 0%nat; intros; rewrite H1; rewrite Rminus_0_r; rewrite Rinv_1;
+ cut (sum_f_R0 (fun n0:nat => 1 * 0 ^ n0) n = 1).
+intros; rewrite H3; rewrite R_dist_eq; auto.
+elim n; simpl in |- *.
+ring.
+intros; rewrite H3; ring.
+intro; cut (0 < eps * (Rabs (1 - x) * Rabs (/ x))).
+intro; elim (pow_lt_1_zero x H (eps * (Rabs (1 - x) * Rabs (/ x))) H2);
+ intro N; intros; exists N; intros;
+ cut
+  (sum_f_R0 (fun n0:nat => 1 * x ^ n0) n = sum_f_R0 (fun n0:nat => x ^ n0) n).
+intros; rewrite H5;
+ apply
+  (Rmult_lt_reg_l (Rabs (1 - x))
+     (R_dist (sum_f_R0 (fun n0:nat => x ^ n0) n) (/ (1 - x))) eps).
+apply Rabs_pos_lt.
+apply Rminus_eq_contra.
+apply Rlt_dichotomy_converse.
+right; unfold Rgt in |- *.
+apply (Rle_lt_trans x (Rabs x) 1).
+apply RRle_abs.
+assumption.
+unfold R_dist in |- *; rewrite <- Rabs_mult.
+rewrite Rmult_minus_distr_l.
+cut
+ ((1 - x) * sum_f_R0 (fun n0:nat => x ^ n0) n =
+  - (sum_f_R0 (fun n0:nat => x ^ n0) n * (x - 1))).
+intro; rewrite H6.
+rewrite GP_finite.
+rewrite Rinv_r.
+cut (- (x ^ (n + 1) - 1) - 1 = - x ^ (n + 1)).
+intro; rewrite H7.
+rewrite Rabs_Ropp; cut ((n + 1)%nat = S n); auto.
+intro H8; rewrite H8; simpl in |- *; rewrite Rabs_mult;
+ apply
+  (Rlt_le_trans (Rabs x * Rabs (x ^ n))
+     (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x)))) (
+     Rabs (1 - x) * eps)).
+apply Rmult_lt_compat_l.
+apply Rabs_pos_lt.
+assumption.
+auto.
+cut
+ (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x))) =
+  Rabs x * Rabs (/ x) * (eps * Rabs (1 - x))).
+clear H8; intros; rewrite H8; rewrite <- Rabs_mult; rewrite Rinv_r.  
+rewrite Rabs_R1; cut (1 * (eps * Rabs (1 - x)) = Rabs (1 - x) * eps).
+intros; rewrite H9; unfold Rle in |- *; right; reflexivity.
+ring.
+assumption.
+ring.
+ring.
+ring.
+apply Rminus_eq_contra.
+apply Rlt_dichotomy_converse.
+right; unfold Rgt in |- *.
+apply (Rle_lt_trans x (Rabs x) 1).
+apply RRle_abs.
+assumption.
+ring; ring.
+elim n; simpl in |- *.
+ring.
+intros; rewrite H5.
+ring.
+apply Rmult_lt_0_compat.
+auto.
+apply Rmult_lt_0_compat.
+apply Rabs_pos_lt.
+apply Rminus_eq_contra.
+apply Rlt_dichotomy_converse.
+right; unfold Rgt in |- *.
+apply (Rle_lt_trans x (Rabs x) 1).
+apply RRle_abs.
+assumption.
+apply Rabs_pos_lt.
+apply Rinv_neq_0_compat.
+assumption.
+Qed.
diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v
new file mode 100644
index 00000000..e54c3675
--- /dev/null
+++ b/theories/Reals/Rsigma.v
@@ -0,0 +1,140 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rsigma.v,v 1.12.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import PartSum.
+Open Local Scope R_scope.
+
+Set Implicit Arguments.
+
+Section Sigma.
+
+Variable f : nat -> R.
+
+Definition sigma (low high:nat) : R :=
+  sum_f_R0 (fun k:nat => f (low + k)) (high - low).
+
+Theorem sigma_split :
+ forall low high k:nat,
+   (low <= k)%nat ->
+   (k < high)%nat -> sigma low high = sigma low k + sigma (S k) high.
+intros; induction  k as [| k Hreck].
+cut (low = 0%nat).
+intro; rewrite H1; unfold sigma in |- *; rewrite <- minus_n_n;
+ rewrite <- minus_n_O; simpl in |- *; replace (high - 1)%nat with (pred high).
+apply (decomp_sum (fun k:nat => f k)).
+assumption.
+apply pred_of_minus.
+inversion H; reflexivity.
+cut ((low <= k)%nat \/ low = S k).
+intro; elim H1; intro.
+replace (sigma low (S k)) with (sigma low k + f (S k)).
+rewrite Rplus_assoc;
+ replace (f (S k) + sigma (S (S k)) high) with (sigma (S k) high).
+apply Hreck.
+assumption.
+apply lt_trans with (S k); [ apply lt_n_Sn | assumption ].
+unfold sigma in |- *; replace (high - S (S k))%nat with (pred (high - S k)).
+pattern (S k) at 3 in |- *; replace (S k) with (S k + 0)%nat;
+ [ idtac | ring ].
+replace (sum_f_R0 (fun k0:nat => f (S (S k) + k0)) (pred (high - S k))) with
+ (sum_f_R0 (fun k0:nat => f (S k + S k0)) (pred (high - S k))).
+apply (decomp_sum (fun i:nat => f (S k + i))).
+apply lt_minus_O_lt; assumption.
+apply sum_eq; intros; replace (S k + S i)%nat with (S (S k) + i)%nat.
+reflexivity.
+apply INR_eq; do 2 rewrite plus_INR; do 3 rewrite S_INR; ring.
+replace (high - S (S k))%nat with (high - S k - 1)%nat.
+apply pred_of_minus.
+apply INR_eq; repeat rewrite minus_INR.
+do 4 rewrite S_INR; ring.
+apply lt_le_S; assumption.
+apply lt_le_weak; assumption.
+apply lt_le_S; apply lt_minus_O_lt; assumption.
+unfold sigma in |- *; replace (S k - low)%nat with (S (k - low)).
+pattern (S k) at 1 in |- *; replace (S k) with (low + S (k - low))%nat.
+symmetry  in |- *; apply (tech5 (fun i:nat => f (low + i))).
+apply INR_eq; rewrite plus_INR; do 2 rewrite S_INR; rewrite minus_INR.
+ring.
+assumption.
+apply minus_Sn_m; assumption.
+rewrite <- H2; unfold sigma in |- *; rewrite <- minus_n_n; simpl in |- *;
+ replace (high - S low)%nat with (pred (high - low)).
+replace (sum_f_R0 (fun k0:nat => f (S (low + k0))) (pred (high - low))) with
+ (sum_f_R0 (fun k0:nat => f (low + S k0)) (pred (high - low))).
+apply (decomp_sum (fun k0:nat => f (low + k0))).
+apply lt_minus_O_lt.
+apply le_lt_trans with (S k); [ rewrite H2; apply le_n | assumption ].
+apply sum_eq; intros; replace (S (low + i)) with (low + S i)%nat.
+reflexivity.
+apply INR_eq; rewrite plus_INR; do 2 rewrite S_INR; rewrite plus_INR; ring.
+replace (high - S low)%nat with (high - low - 1)%nat.
+apply pred_of_minus.
+apply INR_eq; repeat rewrite minus_INR.
+do 2 rewrite S_INR; ring.
+apply lt_le_S; rewrite H2; assumption.
+rewrite H2; apply lt_le_weak; assumption.
+apply lt_le_S; apply lt_minus_O_lt; rewrite H2; assumption.
+inversion H; [ right; reflexivity | left; assumption ].
+Qed.
+
+Theorem sigma_diff :
+ forall low high k:nat,
+   (low <= k)%nat ->
+   (k < high)%nat -> sigma low high - sigma low k = sigma (S k) high.
+intros low high k H1 H2; symmetry  in |- *; rewrite (sigma_split H1 H2); ring.
+Qed.
+
+Theorem sigma_diff_neg :
+ forall low high k:nat,
+   (low <= k)%nat ->
+   (k < high)%nat -> sigma low k - sigma low high = - sigma (S k) high.
+intros low high k H1 H2; rewrite (sigma_split H1 H2); ring.
+Qed.
+
+Theorem sigma_first :
+ forall low high:nat,
+   (low < high)%nat -> sigma low high = f low + sigma (S low) high.
+intros low high H1; generalize (lt_le_S low high H1); intro H2;
+ generalize (lt_le_weak low high H1); intro H3;
+ replace (f low) with (sigma low low).
+apply sigma_split.
+apply le_n.
+assumption.
+unfold sigma in |- *; rewrite <- minus_n_n.
+simpl in |- *.
+replace (low + 0)%nat with low; [ reflexivity | ring ].
+Qed.
+
+Theorem sigma_last :
+ forall low high:nat,
+   (low < high)%nat -> sigma low high = f high + sigma low (pred high).
+intros low high H1; generalize (lt_le_S low high H1); intro H2;
+ generalize (lt_le_weak low high H1); intro H3;
+ replace (f high) with (sigma high high).
+rewrite Rplus_comm; cut (high = S (pred high)).
+intro; pattern high at 3 in |- *; rewrite H.
+apply sigma_split.
+apply le_S_n; rewrite <- H; apply lt_le_S; assumption.
+apply lt_pred_n_n; apply le_lt_trans with low; [ apply le_O_n | assumption ].
+apply S_pred with 0%nat; apply le_lt_trans with low;
+ [ apply le_O_n | assumption ].
+unfold sigma in |- *; rewrite <- minus_n_n; simpl in |- *;
+ replace (high + 0)%nat with high; [ reflexivity | ring ].
+Qed.
+
+Theorem sigma_eq_arg : forall low:nat, sigma low low = f low.
+intro; unfold sigma in |- *; rewrite <- minus_n_n.
+simpl in |- *; replace (low + 0)%nat with low; [ reflexivity | ring ].
+Qed.
+
+End Sigma.
\ No newline at end of file
diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v
new file mode 100644
index 00000000..459f2716
--- /dev/null
+++ b/theories/Reals/Rsqrt_def.v
@@ -0,0 +1,762 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Rsqrt_def.v,v 1.14.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Sumbool.
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Ranalysis1.
+Open Local Scope R_scope.
+
+Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
+  match N with
+  | O => x
+  | S n =>
+      let down := Dichotomy_lb x y P n in
+      let up := Dichotomy_ub x y P n in
+      let z := (down + up) / 2 in if P z then down else z
+  end
+ 
+ with Dichotomy_ub (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
+  match N with
+  | O => y
+  | S n =>
+      let down := Dichotomy_lb x y P n in
+      let up := Dichotomy_ub x y P n in
+      let z := (down + up) / 2 in if P z then z else up
+  end.
+
+Definition dicho_lb (x y:R) (P:R -> bool) (N:nat) : R := Dichotomy_lb x y P N.
+Definition dicho_up (x y:R) (P:R -> bool) (N:nat) : R := Dichotomy_ub x y P N.
+
+(**********)
+Lemma dicho_comp :
+ forall (x y:R) (P:R -> bool) (n:nat),
+   x <= y -> dicho_lb x y P n <= dicho_up x y P n.
+intros.
+induction  n as [| n Hrecn].
+simpl in |- *; assumption.
+simpl in |- *.
+case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+prove_sup0.
+pattern 2 at 1 in |- *; rewrite Rmult_comm.
+rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
+rewrite Rmult_1_r.
+rewrite double.
+apply Rplus_le_compat_l.
+assumption.
+unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+prove_sup0.
+pattern 2 at 3 in |- *; rewrite Rmult_comm.
+rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
+rewrite Rmult_1_r.
+rewrite double.
+rewrite <- (Rplus_comm (Dichotomy_ub x y P n)).
+apply Rplus_le_compat_l.
+assumption.
+Qed.
+
+Lemma dicho_lb_growing :
+ forall (x y:R) (P:R -> bool), x <= y -> Un_growing (dicho_lb x y P).
+intros.
+unfold Un_growing in |- *.
+intro.
+simpl in |- *.
+case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+right; reflexivity.
+unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+prove_sup0.
+pattern 2 at 1 in |- *; rewrite Rmult_comm.
+rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
+rewrite Rmult_1_r.
+rewrite double.
+apply Rplus_le_compat_l.
+replace (Dichotomy_ub x y P n) with (dicho_up x y P n);
+ [ apply dicho_comp; assumption | reflexivity ].
+Qed.
+
+Lemma dicho_up_decreasing :
+ forall (x y:R) (P:R -> bool), x <= y -> Un_decreasing (dicho_up x y P).
+intros.
+unfold Un_decreasing in |- *.
+intro.
+simpl in |- *.
+case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+prove_sup0.
+pattern 2 at 3 in |- *; rewrite Rmult_comm.
+rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
+rewrite Rmult_1_r.
+rewrite double.
+replace (Dichotomy_ub x y P n) with (dicho_up x y P n);
+ [ idtac | reflexivity ].
+replace (Dichotomy_lb x y P n) with (dicho_lb x y P n);
+ [ idtac | reflexivity ].
+rewrite <- (Rplus_comm (dicho_up x y P n)).
+apply Rplus_le_compat_l.
+apply dicho_comp; assumption.
+right; reflexivity.
+Qed.
+
+Lemma dicho_lb_maj_y :
+ forall (x y:R) (P:R -> bool), x <= y -> forall n:nat, dicho_lb x y P n <= y.
+intros.
+induction  n as [| n Hrecn].
+simpl in |- *; assumption.
+simpl in |- *.
+case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+assumption.
+unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+prove_sup0.
+pattern 2 at 3 in |- *; rewrite Rmult_comm.
+rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ rewrite Rmult_1_r | discrR ].
+rewrite double; apply Rplus_le_compat.
+assumption.
+pattern y at 2 in |- *; replace y with (Dichotomy_ub x y P 0);
+ [ idtac | reflexivity ].
+apply decreasing_prop.
+assert (H0 := dicho_up_decreasing x y P H).
+assumption.
+apply le_O_n.
+Qed.
+
+Lemma dicho_lb_maj :
+ forall (x y:R) (P:R -> bool), x <= y -> has_ub (dicho_lb x y P).
+intros.
+cut (forall n:nat, dicho_lb x y P n <= y).
+intro.
+unfold has_ub in |- *.
+unfold bound in |- *.
+exists y.
+unfold is_upper_bound in |- *.
+intros.
+elim H1; intros.
+rewrite H2; apply H0.
+apply dicho_lb_maj_y; assumption.
+Qed.
+
+Lemma dicho_up_min_x :
+ forall (x y:R) (P:R -> bool), x <= y -> forall n:nat, x <= dicho_up x y P n.
+intros.
+induction  n as [| n Hrecn].
+simpl in |- *; assumption.
+simpl in |- *.
+case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+prove_sup0.
+pattern 2 at 1 in |- *; rewrite Rmult_comm.
+rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ rewrite Rmult_1_r | discrR ].
+rewrite double; apply Rplus_le_compat.
+pattern x at 1 in |- *; replace x with (Dichotomy_lb x y P 0);
+ [ idtac | reflexivity ].
+apply tech9.
+assert (H0 := dicho_lb_growing x y P H).
+assumption.
+apply le_O_n.
+assumption.
+assumption.
+Qed.
+
+Lemma dicho_up_min :
+ forall (x y:R) (P:R -> bool), x <= y -> has_lb (dicho_up x y P).
+intros.
+cut (forall n:nat, x <= dicho_up x y P n).
+intro.
+unfold has_lb in |- *.
+unfold bound in |- *.
+exists (- x).
+unfold is_upper_bound in |- *.
+intros.
+elim H1; intros.
+rewrite H2.
+unfold opp_seq in |- *.
+apply Ropp_le_contravar.
+apply H0.
+apply dicho_up_min_x; assumption.
+Qed.
+
+Lemma dicho_lb_cv :
+ forall (x y:R) (P:R -> bool),
+   x <= y -> sigT (fun l:R => Un_cv (dicho_lb x y P) l).
+intros.
+apply growing_cv.
+apply dicho_lb_growing; assumption.
+apply dicho_lb_maj; assumption.
+Qed.
+
+Lemma dicho_up_cv :
+ forall (x y:R) (P:R -> bool),
+   x <= y -> sigT (fun l:R => Un_cv (dicho_up x y P) l).
+intros.
+apply decreasing_cv.
+apply dicho_up_decreasing; assumption.
+apply dicho_up_min; assumption.
+Qed.
+
+Lemma dicho_lb_dicho_up :
+ forall (x y:R) (P:R -> bool) (n:nat),
+   x <= y -> dicho_up x y P n - dicho_lb x y P n = (y - x) / 2 ^ n.
+intros.
+induction  n as [| n Hrecn].
+simpl in |- *.
+unfold Rdiv in |- *; rewrite Rinv_1; ring.
+simpl in |- *.
+case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+unfold Rdiv in |- *.
+replace
+ ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) * / 2 - Dichotomy_lb x y P n)
+ with ((dicho_up x y P n - dicho_lb x y P n) / 2).
+unfold Rdiv in |- *; rewrite Hrecn.
+unfold Rdiv in |- *.
+rewrite Rinv_mult_distr.
+ring.
+discrR.
+apply pow_nonzero; discrR.
+pattern (Dichotomy_lb x y P n) at 2 in |- *;
+ rewrite (double_var (Dichotomy_lb x y P n));
+ unfold dicho_up, dicho_lb, Rminus, Rdiv in |- *; ring.
+replace
+ (Dichotomy_ub x y P n - (Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)
+ with ((dicho_up x y P n - dicho_lb x y P n) / 2).
+unfold Rdiv in |- *; rewrite Hrecn.
+unfold Rdiv in |- *.
+rewrite Rinv_mult_distr.
+ring.
+discrR.
+apply pow_nonzero; discrR.
+pattern (Dichotomy_ub x y P n) at 1 in |- *;
+ rewrite (double_var (Dichotomy_ub x y P n));
+ unfold dicho_up, dicho_lb, Rminus, Rdiv in |- *; ring.
+Qed.
+
+Definition pow_2_n (n:nat) := 2 ^ n.
+
+Lemma pow_2_n_neq_R0 : forall n:nat, pow_2_n n <> 0.
+intro.
+unfold pow_2_n in |- *.
+apply pow_nonzero.
+discrR.
+Qed.
+
+Lemma pow_2_n_growing : Un_growing pow_2_n.
+unfold Un_growing in |- *.
+intro.
+replace (S n) with (n + 1)%nat;
+ [ unfold pow_2_n in |- *; rewrite pow_add | ring ].
+pattern (2 ^ n) at 1 in |- *; rewrite <- Rmult_1_r.
+apply Rmult_le_compat_l.
+left; apply pow_lt; prove_sup0.
+simpl in |- *.
+rewrite Rmult_1_r.
+pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+ apply Rlt_0_1.
+Qed.
+
+Lemma pow_2_n_infty : cv_infty pow_2_n.
+cut (forall N:nat, INR N <= 2 ^ N).
+intros.
+unfold cv_infty in |- *.
+intro.
+case (total_order_T 0 M); intro.
+elim s; intro.
+set (N := up M).
+cut (0 <= N)%Z.
+intro.
+elim (IZN N H0); intros N0 H1.
+exists N0.
+intros.
+apply Rlt_le_trans with (INR N0).
+rewrite INR_IZR_INZ.
+rewrite <- H1.
+unfold N in |- *.
+assert (H3 := archimed M).
+elim H3; intros; assumption.
+apply Rle_trans with (pow_2_n N0).
+unfold pow_2_n in |- *; apply H.
+apply Rge_le.
+apply growing_prop.
+apply pow_2_n_growing.
+assumption.
+apply le_IZR.
+unfold N in |- *.
+simpl in |- *.
+assert (H0 := archimed M); elim H0; intros.
+left; apply Rlt_trans with M; assumption.
+exists 0%nat; intros.
+rewrite <- b.
+unfold pow_2_n in |- *; apply pow_lt; prove_sup0.
+exists 0%nat; intros.
+apply Rlt_trans with 0.
+assumption.
+unfold pow_2_n in |- *; apply pow_lt; prove_sup0.
+simple induction N.
+simpl in |- *.
+left; apply Rlt_0_1.
+intros.
+pattern (S n) at 2 in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+rewrite S_INR; rewrite pow_add.
+simpl in |- *.
+rewrite Rmult_1_r.
+apply Rle_trans with (2 ^ n).
+rewrite <- (Rplus_comm 1).
+rewrite <- (Rmult_1_r (INR n)).
+apply (poly n 1).
+apply Rlt_0_1.
+pattern (2 ^ n) at 1 in |- *; rewrite <- Rplus_0_r.
+rewrite <- (Rmult_comm 2).
+rewrite double.
+apply Rplus_le_compat_l.
+left; apply pow_lt; prove_sup0.
+Qed.
+
+Lemma cv_dicho :
+ forall (x y l1 l2:R) (P:R -> bool),
+   x <= y ->
+   Un_cv (dicho_lb x y P) l1 -> Un_cv (dicho_up x y P) l2 -> l1 = l2.
+intros.
+assert (H2 := CV_minus _ _ _ _ H0 H1).
+cut (Un_cv (fun i:nat => dicho_lb x y P i - dicho_up x y P i) 0).
+intro.
+assert (H4 := UL_sequence _ _ _ H2 H3).
+symmetry  in |- *; apply Rminus_diag_uniq_sym; assumption.
+unfold Un_cv in |- *; unfold R_dist in |- *.
+intros.
+assert (H4 := cv_infty_cv_R0 pow_2_n pow_2_n_neq_R0 pow_2_n_infty).
+case (total_order_T x y); intro.
+elim s; intro.
+unfold Un_cv in H4; unfold R_dist in H4.
+cut (0 < y - x).
+intro Hyp.
+cut (0 < eps / (y - x)).
+intro.
+elim (H4 (eps / (y - x)) H5); intros N H6.
+exists N; intros.
+replace (dicho_lb x y P n - dicho_up x y P n - 0) with
+ (dicho_lb x y P n - dicho_up x y P n); [ idtac | ring ].
+rewrite <- Rabs_Ropp.
+rewrite Ropp_minus_distr'.
+rewrite dicho_lb_dicho_up.
+unfold Rdiv in |- *; rewrite Rabs_mult.
+rewrite (Rabs_right (y - x)).
+apply Rmult_lt_reg_l with (/ (y - x)).
+apply Rinv_0_lt_compat; assumption.
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+replace (/ 2 ^ n) with (/ 2 ^ n - 0);
+ [ unfold pow_2_n, Rdiv in H6; rewrite <- (Rmult_comm eps); apply H6;
+    assumption
+ | ring ].
+red in |- *; intro; rewrite H8 in Hyp; elim (Rlt_irrefl _ Hyp).
+apply Rle_ge.
+apply Rplus_le_reg_l with x; rewrite Rplus_0_r.
+replace (x + (y - x)) with y; [ assumption | ring ].
+assumption.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; assumption ].
+apply Rplus_lt_reg_r with x; rewrite Rplus_0_r.
+replace (x + (y - x)) with y; [ assumption | ring ].
+exists 0%nat; intros.
+replace (dicho_lb x y P n - dicho_up x y P n - 0) with
+ (dicho_lb x y P n - dicho_up x y P n); [ idtac | ring ].
+rewrite <- Rabs_Ropp.
+rewrite Ropp_minus_distr'.
+rewrite dicho_lb_dicho_up.
+rewrite b.
+unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r; rewrite Rmult_0_l;
+ rewrite Rabs_R0; assumption.
+assumption.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+Qed.
+
+Definition cond_positivity (x:R) : bool :=
+  match Rle_dec 0 x with
+  | left _ => true
+  | right _ => false
+  end.
+
+(* Sequential caracterisation of continuity *)
+Lemma continuity_seq :
+ forall (f:R -> R) (Un:nat -> R) (l:R),
+   continuity_pt f l -> Un_cv Un l -> Un_cv (fun i:nat => f (Un i)) (f l).
+unfold continuity_pt, Un_cv in |- *; unfold continue_in in |- *.
+unfold limit1_in in |- *.
+unfold limit_in in |- *.
+unfold dist in |- *.
+simpl in |- *.
+unfold R_dist in |- *.
+intros.
+elim (H eps H1); intros alp H2.
+elim H2; intros.
+elim (H0 alp H3); intros N H5.
+exists N; intros.
+case (Req_dec (Un n) l); intro.
+rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ assumption.
+apply H4.
+split.
+unfold D_x, no_cond in |- *.
+split.
+trivial.
+apply (sym_not_eq (A:=R)); assumption.
+apply H5; assumption.
+Qed.
+
+Lemma dicho_lb_car :
+ forall (x y:R) (P:R -> bool) (n:nat),
+   P x = false -> P (dicho_lb x y P n) = false.
+intros.
+induction  n as [| n Hrecn].
+simpl in |- *.
+assumption.
+simpl in |- *.
+assert
+ (X :=
+  sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))).
+elim X; intro.
+rewrite a.
+unfold dicho_lb in Hrecn; assumption.
+rewrite b.
+assumption.
+Qed.
+
+Lemma dicho_up_car :
+ forall (x y:R) (P:R -> bool) (n:nat),
+   P y = true -> P (dicho_up x y P n) = true.
+intros.
+induction  n as [| n Hrecn].
+simpl in |- *.
+assumption.
+simpl in |- *.
+assert
+ (X :=
+  sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))).
+elim X; intro.
+rewrite a.
+unfold dicho_lb in Hrecn; assumption.
+rewrite b.
+assumption.
+Qed.
+
+(* Intermediate Value Theorem *)
+Lemma IVT :
+ forall (f:R -> R) (x y:R),
+   continuity f ->
+   x < y -> f x < 0 -> 0 < f y -> sigT (fun z:R => x <= z <= y /\ f z = 0).
+intros.
+cut (x <= y).
+intro.
+generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). 
+generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). 
+intros.
+elim X; intros.
+elim X0; intros.
+assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p).
+rewrite H4 in p0.
+apply existT with x0.
+split.
+split.
+apply Rle_trans with (dicho_lb x y (fun z:R => cond_positivity (f z)) 0).
+simpl in |- *.
+right; reflexivity.
+apply growing_ineq.
+apply dicho_lb_growing; assumption.
+assumption.
+apply Rle_trans with (dicho_up x y (fun z:R => cond_positivity (f z)) 0).
+apply decreasing_ineq.
+apply dicho_up_decreasing; assumption.
+assumption.
+right; reflexivity.
+2: left; assumption.
+set (Vn := fun n:nat => dicho_lb x y (fun z:R => cond_positivity (f z)) n).
+set (Wn := fun n:nat => dicho_up x y (fun z:R => cond_positivity (f z)) n).
+cut ((forall n:nat, f (Vn n) <= 0) -> f x0 <= 0).
+cut ((forall n:nat, 0 <= f (Wn n)) -> 0 <= f x0).
+intros.
+cut (forall n:nat, f (Vn n) <= 0).
+cut (forall n:nat, 0 <= f (Wn n)).
+intros.
+assert (H9 := H6 H8).
+assert (H10 := H5 H7).
+apply Rle_antisym; assumption.
+intro.
+unfold Wn in |- *.
+cut (forall z:R, cond_positivity z = true <-> 0 <= z).
+intro.
+assert (H8 := dicho_up_car x y (fun z:R => cond_positivity (f z)) n).
+elim (H7 (f (dicho_up x y (fun z:R => cond_positivity (f z)) n))); intros.
+apply H9.
+apply H8.
+elim (H7 (f y)); intros.
+apply H12.
+left; assumption.
+intro.
+unfold cond_positivity in |- *.
+case (Rle_dec 0 z); intro.
+split.
+intro; assumption.
+intro; reflexivity.
+split.
+intro; elim diff_false_true; assumption.
+intro.
+elim n0; assumption.
+unfold Vn in |- *.
+cut (forall z:R, cond_positivity z = false <-> z < 0).
+intros.
+assert (H8 := dicho_lb_car x y (fun z:R => cond_positivity (f z)) n).
+left.
+elim (H7 (f (dicho_lb x y (fun z:R => cond_positivity (f z)) n))); intros.
+apply H9.
+apply H8.
+elim (H7 (f x)); intros.
+apply H12.
+assumption.
+intro.
+unfold cond_positivity in |- *.
+case (Rle_dec 0 z); intro.
+split.
+intro; elim diff_true_false; assumption.
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H7)).
+split.
+intro; auto with real.
+intro; reflexivity.
+cut (Un_cv Wn x0).
+intros.
+assert (H7 := continuity_seq f Wn x0 (H x0) H5).
+case (total_order_T 0 (f x0)); intro.
+elim s; intro.
+left; assumption.
+rewrite <- b; right; reflexivity.
+unfold Un_cv in H7; unfold R_dist in H7.
+cut (0 < - f x0).
+intro.
+elim (H7 (- f x0) H8); intros.
+cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
+assert (H11 := H9 x2 H10).
+rewrite Rabs_right in H11.
+pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11.
+unfold Rminus in H11; rewrite (Rplus_comm (f (Wn x2))) in H11.
+assert (H12 := Rplus_lt_reg_r _ _ _ H11).
+assert (H13 := H6 x2).
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)).
+apply Rle_ge; left; unfold Rminus in |- *; apply Rplus_le_lt_0_compat.
+apply H6.
+exact H8.
+apply Ropp_0_gt_lt_contravar; assumption.
+unfold Wn in |- *; assumption.
+cut (Un_cv Vn x0).
+intros.
+assert (H7 := continuity_seq f Vn x0 (H x0) H5).
+case (total_order_T 0 (f x0)); intro.
+elim s; intro.
+unfold Un_cv in H7; unfold R_dist in H7.
+elim (H7 (f x0) a); intros.
+cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
+assert (H10 := H8 x2 H9).
+rewrite Rabs_left in H10.
+pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10.
+rewrite Ropp_minus_distr' in H10.
+unfold Rminus in H10.
+assert (H11 := Rplus_lt_reg_r _ _ _ H10).
+assert (H12 := H6 x2).
+cut (0 < f (Vn x2)).
+intro.
+elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H13 H12)).
+rewrite <- (Ropp_involutive (f (Vn x2))).
+apply Ropp_0_gt_lt_contravar; assumption.
+apply Rplus_lt_reg_r with (f x0 - f (Vn x2)).
+rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0;
+ [ unfold Rminus in |- *; apply Rplus_lt_le_0_compat | ring ].
+assumption.
+apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6.
+right; rewrite <- b; reflexivity.
+left; assumption.
+unfold Vn in |- *; assumption.
+Qed.
+
+Lemma IVT_cor :
+ forall (f:R -> R) (x y:R),
+   continuity f ->
+   x <= y -> f x * f y <= 0 -> sigT (fun z:R => x <= z <= y /\ f z = 0).
+intros.
+case (total_order_T 0 (f x)); intro.
+case (total_order_T 0 (f y)); intro.
+elim s; intro.
+elim s0; intro.
+cut (0 < f x * f y);
+ [ intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 H2))
+ | apply Rmult_lt_0_compat; assumption ].
+exists y.
+split.
+split; [ assumption | right; reflexivity ].
+symmetry  in |- *; exact b.
+exists x.
+split.
+split; [ right; reflexivity | assumption ].
+symmetry  in |- *; exact b.
+elim s; intro.
+cut (x < y).
+intro.
+assert (H3 := IVT (- f)%F x y (continuity_opp f H) H2).
+cut ((- f)%F x < 0).
+cut (0 < (- f)%F y).
+intros.
+elim (H3 H5 H4); intros.
+apply existT with x0.
+elim p; intros.
+split.
+assumption.
+unfold opp_fct in H7.
+rewrite <- (Ropp_involutive (f x0)).
+apply Ropp_eq_0_compat; assumption.
+unfold opp_fct in |- *; apply Ropp_0_gt_lt_contravar; assumption.
+unfold opp_fct in |- *.
+apply Rplus_lt_reg_r with (f x); rewrite Rplus_opp_r; rewrite Rplus_0_r;
+ assumption.
+inversion H0.
+assumption.
+rewrite H2 in a.
+elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)).
+apply existT with x.
+split.
+split; [ right; reflexivity | assumption ].
+symmetry  in |- *; assumption.
+case (total_order_T 0 (f y)); intro.
+elim s; intro.
+cut (x < y).
+intro.
+apply IVT; assumption.
+inversion H0.
+assumption.
+rewrite H2 in r.
+elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)).
+apply existT with y.
+split.
+split; [ assumption | right; reflexivity ].
+symmetry  in |- *; assumption.
+cut (0 < f x * f y).
+intro.
+elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H2 H1)).
+rewrite <- Rmult_opp_opp; apply Rmult_lt_0_compat;
+ apply Ropp_0_gt_lt_contravar; assumption.
+Qed.
+
+(* We can now define the square root function as the reciprocal transformation of the square root function *)
+Lemma Rsqrt_exists :
+ forall y:R, 0 <= y -> sigT (fun z:R => 0 <= z /\ y = Rsqr z).
+intros.
+set (f := fun x:R => Rsqr x - y).
+cut (f 0 <= 0).
+intro.
+cut (continuity f).
+intro.
+case (total_order_T y 1); intro.
+elim s; intro.
+cut (0 <= f 1).
+intro.
+cut (f 0 * f 1 <= 0).
+intro.
+assert (X := IVT_cor f 0 1 H1 (Rlt_le _ _ Rlt_0_1) H3).
+elim X; intros t H4.
+apply existT with t.
+elim H4; intros.
+split.
+elim H5; intros; assumption.
+unfold f in H6.
+apply Rminus_diag_uniq_sym; exact H6.
+rewrite Rmult_comm; pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f 1)).
+apply Rmult_le_compat_l; assumption.
+unfold f in |- *.
+rewrite Rsqr_1.
+apply Rplus_le_reg_l with y.
+rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+ rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
+ left; assumption.
+apply existT with 1.
+split.
+left; apply Rlt_0_1.
+rewrite b; symmetry  in |- *; apply Rsqr_1.
+cut (0 <= f y).
+intro.
+cut (f 0 * f y <= 0).
+intro.
+assert (X := IVT_cor f 0 y H1 H H3).
+elim X; intros t H4.
+apply existT with t.
+elim H4; intros.
+split.
+elim H5; intros; assumption.
+unfold f in H6.
+apply Rminus_diag_uniq_sym; exact H6.
+rewrite Rmult_comm; pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y)).
+apply Rmult_le_compat_l; assumption.
+unfold f in |- *.
+apply Rplus_le_reg_l with y.
+rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+ rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
+pattern y at 1 in |- *; rewrite <- Rmult_1_r.
+unfold Rsqr in |- *; apply Rmult_le_compat_l.
+assumption.
+left; exact r.
+replace f with (Rsqr - fct_cte y)%F.
+apply continuity_minus.
+apply derivable_continuous; apply derivable_Rsqr.
+apply derivable_continuous; apply derivable_const.
+reflexivity.
+unfold f in |- *; rewrite Rsqr_0.
+unfold Rminus in |- *; rewrite Rplus_0_l.
+apply Rge_le.
+apply Ropp_0_le_ge_contravar; assumption.
+Qed.
+
+(* Definition of the square root: R+->R *)
+Definition Rsqrt (y:nonnegreal) : R :=
+  match Rsqrt_exists (nonneg y) (cond_nonneg y) with
+  | existT a b => a
+  end.
+
+(**********)
+Lemma Rsqrt_positivity : forall x:nonnegreal, 0 <= Rsqrt x.
+intro.
+assert (X := Rsqrt_exists (nonneg x) (cond_nonneg x)).
+elim X; intros.
+cut (x0 = Rsqrt x).
+intros.
+elim p; intros.
+rewrite H in H0; assumption.
+unfold Rsqrt in |- *.
+case (Rsqrt_exists x (cond_nonneg x)).
+intros.
+elim p; elim a; intros.
+apply Rsqr_inj.
+assumption.
+assumption.
+rewrite <- H0; rewrite <- H2; reflexivity.
+Qed.
+
+(**********)
+Lemma Rsqrt_Rsqrt : forall x:nonnegreal, Rsqrt x * Rsqrt x = x.
+intros.
+assert (X := Rsqrt_exists (nonneg x) (cond_nonneg x)).
+elim X; intros.
+cut (x0 = Rsqrt x).
+intros.
+rewrite <- H.
+elim p; intros.
+rewrite H1; reflexivity.
+unfold Rsqrt in |- *.
+case (Rsqrt_exists x (cond_nonneg x)).
+intros.
+elim p; elim a; intros.
+apply Rsqr_inj.
+assumption.
+assumption.
+rewrite <- H0; rewrite <- H2; reflexivity.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v
new file mode 100644
index 00000000..1c112bf1
--- /dev/null
+++ b/theories/Reals/Rtopology.v
@@ -0,0 +1,1825 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Rtopology.v,v 1.19.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Ranalysis1.
+Require Import RList.
+Require Import Classical_Prop.
+Require Import Classical_Pred_Type. Open Local Scope R_scope.
+
+Definition included (D1 D2:R -> Prop) : Prop := forall x:R, D1 x -> D2 x.
+Definition disc (x:R) (delta:posreal) (y:R) : Prop := Rabs (y - x) < delta.
+Definition neighbourhood (V:R -> Prop) (x:R) : Prop :=
+   exists delta : posreal, included (disc x delta) V.
+Definition open_set (D:R -> Prop) : Prop :=
+  forall x:R, D x -> neighbourhood D x.
+Definition complementary (D:R -> Prop) (c:R) : Prop := ~ D c.
+Definition closed_set (D:R -> Prop) : Prop := open_set (complementary D).
+Definition intersection_domain (D1 D2:R -> Prop) (c:R) : Prop := D1 c /\ D2 c.
+Definition union_domain (D1 D2:R -> Prop) (c:R) : Prop := D1 c \/ D2 c.
+Definition interior (D:R -> Prop) (x:R) : Prop := neighbourhood D x.
+
+Lemma interior_P1 : forall D:R -> Prop, included (interior D) D.
+intros; unfold included in |- *; unfold interior in |- *; intros;
+ unfold neighbourhood in H; elim H; intros; unfold included in H0; 
+ apply H0; unfold disc in |- *; unfold Rminus in |- *; 
+ rewrite Rplus_opp_r; rewrite Rabs_R0; apply (cond_pos x0).
+Qed.
+
+Lemma interior_P2 : forall D:R -> Prop, open_set D -> included D (interior D).
+intros; unfold open_set in H; unfold included in |- *; intros;
+ assert (H1 := H _ H0); unfold interior in |- *; apply H1.
+Qed.
+
+Definition point_adherent (D:R -> Prop) (x:R) : Prop :=
+  forall V:R -> Prop,
+    neighbourhood V x ->  exists y : R, intersection_domain V D y.
+Definition adherence (D:R -> Prop) (x:R) : Prop := point_adherent D x.
+
+Lemma adherence_P1 : forall D:R -> Prop, included D (adherence D).
+intro; unfold included in |- *; intros; unfold adherence in |- *;
+ unfold point_adherent in |- *; intros; exists x;
+ unfold intersection_domain in |- *; split.
+unfold neighbourhood in H0; elim H0; intros; unfold included in H1; apply H1;
+ unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rabs_R0; apply (cond_pos x0).
+apply H.
+Qed.
+
+Lemma included_trans :
+ forall D1 D2 D3:R -> Prop,
+   included D1 D2 -> included D2 D3 -> included D1 D3.
+unfold included in |- *; intros; apply H0; apply H; apply H1.
+Qed.
+
+Lemma interior_P3 : forall D:R -> Prop, open_set (interior D).
+intro; unfold open_set, interior in |- *; unfold neighbourhood in |- *;
+ intros; elim H; intros.
+exists x0; unfold included in |- *; intros.
+set (del := x0 - Rabs (x - x1)).
+cut (0 < del).
+intro; exists (mkposreal del H2); intros.
+cut (included (disc x1 (mkposreal del H2)) (disc x x0)).
+intro; assert (H5 := included_trans _ _ _ H4 H0).
+apply H5; apply H3.
+unfold included in |- *; unfold disc in |- *; intros.
+apply Rle_lt_trans with (Rabs (x3 - x1) + Rabs (x1 - x)).
+replace (x3 - x) with (x3 - x1 + (x1 - x)); [ apply Rabs_triang | ring ].
+replace (pos x0) with (del + Rabs (x1 - x)).
+do 2 rewrite <- (Rplus_comm (Rabs (x1 - x))); apply Rplus_lt_compat_l;
+ apply H4.
+unfold del in |- *; rewrite <- (Rabs_Ropp (x - x1)); rewrite Ropp_minus_distr;
+ ring.
+unfold del in |- *; apply Rplus_lt_reg_r with (Rabs (x - x1));
+ rewrite Rplus_0_r;
+ replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0);
+ [ idtac | ring ].
+unfold disc in H1; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H1.
+Qed.
+
+Lemma complementary_P1 :
+ forall D:R -> Prop,
+   ~ (exists y : R, intersection_domain D (complementary D) y).
+intro; red in |- *; intro; elim H; intros;
+ unfold intersection_domain, complementary in H0; elim H0; 
+ intros; elim H2; assumption.
+Qed.
+
+Lemma adherence_P2 :
+ forall D:R -> Prop, closed_set D -> included (adherence D) D.
+unfold closed_set in |- *; unfold open_set, complementary in |- *; intros;
+ unfold included, adherence in |- *; intros; assert (H1 := classic (D x));
+ elim H1; intro.
+assumption.
+assert (H3 := H _ H2); assert (H4 := H0 _ H3); elim H4; intros;
+ unfold intersection_domain in H5; elim H5; intros; 
+ elim H6; assumption.
+Qed.
+
+Lemma adherence_P3 : forall D:R -> Prop, closed_set (adherence D).
+intro; unfold closed_set, adherence in |- *;
+ unfold open_set, complementary, point_adherent in |- *; 
+ intros;
+ set
+  (P :=
+   fun V:R -> Prop =>
+     neighbourhood V x ->  exists y : R, intersection_domain V D y);
+ assert (H0 := not_all_ex_not _ P H); elim H0; intros V0 H1; 
+ unfold P in H1; assert (H2 := imply_to_and _ _ H1);
+ unfold neighbourhood in |- *; elim H2; intros; unfold neighbourhood in H3;
+ elim H3; intros; exists x0; unfold included in |- *; 
+ intros; red in |- *; intro.
+assert (H8 := H7 V0);
+ cut (exists delta : posreal, (forall x:R, disc x1 delta x -> V0 x)).
+intro; assert (H10 := H8 H9); elim H4; assumption.
+cut (0 < x0 - Rabs (x - x1)).
+intro; set (del := mkposreal _ H9); exists del; intros;
+ unfold included in H5; apply H5; unfold disc in |- *;
+ apply Rle_lt_trans with (Rabs (x2 - x1) + Rabs (x1 - x)).
+replace (x2 - x) with (x2 - x1 + (x1 - x)); [ apply Rabs_triang | ring ].
+replace (pos x0) with (del + Rabs (x1 - x)).
+do 2 rewrite <- (Rplus_comm (Rabs (x1 - x))); apply Rplus_lt_compat_l;
+ apply H10.
+unfold del in |- *; simpl in |- *; rewrite <- (Rabs_Ropp (x - x1));
+ rewrite Ropp_minus_distr; ring.
+apply Rplus_lt_reg_r with (Rabs (x - x1)); rewrite Rplus_0_r;
+ replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0);
+ [ rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H6 | ring ].
+Qed.
+
+Definition eq_Dom (D1 D2:R -> Prop) : Prop :=
+  included D1 D2 /\ included D2 D1.
+
+Infix "=_D" := eq_Dom (at level 70, no associativity).
+
+Lemma open_set_P1 : forall D:R -> Prop, open_set D <-> D =_D interior D.
+intro; split.
+intro; unfold eq_Dom in |- *; split.
+apply interior_P2; assumption.
+apply interior_P1.
+intro; unfold eq_Dom in H; elim H; clear H; intros; unfold open_set in |- *;
+ intros; unfold included, interior in H; unfold included in H0;
+ apply (H _ H1).
+Qed.
+
+Lemma closed_set_P1 : forall D:R -> Prop, closed_set D <-> D =_D adherence D.
+intro; split.
+intro; unfold eq_Dom in |- *; split.
+apply adherence_P1.
+apply adherence_P2; assumption.
+unfold eq_Dom in |- *; unfold included in |- *; intros;
+ assert (H0 := adherence_P3 D); unfold closed_set in H0;
+ unfold closed_set in |- *; unfold open_set in |- *; 
+ unfold open_set in H0; intros; assert (H2 : complementary (adherence D) x).
+unfold complementary in |- *; unfold complementary in H1; red in |- *; intro;
+ elim H; clear H; intros _ H; elim H1; apply (H _ H2).
+assert (H3 := H0 _ H2); unfold neighbourhood in |- *;
+ unfold neighbourhood in H3; elim H3; intros; exists x0;
+ unfold included in |- *; unfold included in H4; intros;
+ assert (H6 := H4 _ H5); unfold complementary in H6;
+ unfold complementary in |- *; red in |- *; intro; 
+ elim H; clear H; intros H _; elim H6; apply (H _ H7).
+Qed.
+
+Lemma neighbourhood_P1 :
+ forall (D1 D2:R -> Prop) (x:R),
+   included D1 D2 -> neighbourhood D1 x -> neighbourhood D2 x.
+unfold included, neighbourhood in |- *; intros; elim H0; intros; exists x0;
+ intros; unfold included in |- *; unfold included in H1; 
+ intros; apply (H _ (H1 _ H2)).
+Qed.
+
+Lemma open_set_P2 :
+ forall D1 D2:R -> Prop,
+   open_set D1 -> open_set D2 -> open_set (union_domain D1 D2).
+unfold open_set in |- *; intros; unfold union_domain in H1; elim H1; intro.
+apply neighbourhood_P1 with D1.
+unfold included, union_domain in |- *; tauto.
+apply H; assumption.
+apply neighbourhood_P1 with D2.
+unfold included, union_domain in |- *; tauto.
+apply H0; assumption.
+Qed.
+
+Lemma open_set_P3 :
+ forall D1 D2:R -> Prop,
+   open_set D1 -> open_set D2 -> open_set (intersection_domain D1 D2).
+unfold open_set in |- *; intros; unfold intersection_domain in H1; elim H1;
+ intros.
+assert (H4 := H _ H2); assert (H5 := H0 _ H3);
+ unfold intersection_domain in |- *; unfold neighbourhood in H4, H5; 
+ elim H4; clear H; intros del1 H; elim H5; clear H0; 
+ intros del2 H0; cut (0 < Rmin del1 del2).
+intro; set (del := mkposreal _ H6).
+exists del; unfold included in |- *; intros; unfold included in H, H0;
+ unfold disc in H, H0, H7.
+split.
+apply H; apply Rlt_le_trans with (pos del).
+apply H7.
+unfold del in |- *; simpl in |- *; apply Rmin_l.
+apply H0; apply Rlt_le_trans with (pos del).
+apply H7.
+unfold del in |- *; simpl in |- *; apply Rmin_r.
+unfold Rmin in |- *; case (Rle_dec del1 del2); intro.
+apply (cond_pos del1).
+apply (cond_pos del2).
+Qed.
+
+Lemma open_set_P4 : open_set (fun x:R => False).
+unfold open_set in |- *; intros; elim H.
+Qed.
+
+Lemma open_set_P5 : open_set (fun x:R => True).
+unfold open_set in |- *; intros; unfold neighbourhood in |- *.
+exists (mkposreal 1 Rlt_0_1); unfold included in |- *; intros; trivial.
+Qed.
+
+Lemma disc_P1 : forall (x:R) (del:posreal), open_set (disc x del).
+intros; assert (H := open_set_P1 (disc x del)).
+elim H; intros; apply H1.
+unfold eq_Dom in |- *; split.
+unfold included, interior, disc in |- *; intros;
+ cut (0 < del - Rabs (x - x0)).
+intro; set (del2 := mkposreal _ H3).
+exists del2; unfold included in |- *; intros.
+apply Rle_lt_trans with (Rabs (x1 - x0) + Rabs (x0 - x)).
+replace (x1 - x) with (x1 - x0 + (x0 - x)); [ apply Rabs_triang | ring ].
+replace (pos del) with (del2 + Rabs (x0 - x)).
+do 2 rewrite <- (Rplus_comm (Rabs (x0 - x))); apply Rplus_lt_compat_l.
+apply H4.
+unfold del2 in |- *; simpl in |- *; rewrite <- (Rabs_Ropp (x - x0));
+ rewrite Ropp_minus_distr; ring.
+apply Rplus_lt_reg_r with (Rabs (x - x0)); rewrite Rplus_0_r;
+ replace (Rabs (x - x0) + (del - Rabs (x - x0))) with (pos del);
+ [ rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H2 | ring ].
+apply interior_P1.
+Qed.
+
+Lemma continuity_P1 :
+ forall (f:R -> R) (x:R),
+   continuity_pt f x <->
+   (forall W:R -> Prop,
+      neighbourhood W (f x) ->
+       exists V : R -> Prop,
+        neighbourhood V x /\ (forall y:R, V y -> W (f y))).
+intros; split.
+intros; unfold neighbourhood in H0.
+elim H0; intros del1 H1.
+unfold continuity_pt in H; unfold continue_in in H; unfold limit1_in in H;
+ unfold limit_in in H; simpl in H; unfold R_dist in H.
+assert (H2 := H del1 (cond_pos del1)).
+elim H2; intros del2 H3.
+elim H3; intros.
+exists (disc x (mkposreal del2 H4)).
+intros; unfold included in H1; split.
+unfold neighbourhood, disc in |- *.
+exists (mkposreal del2 H4).
+unfold included in |- *; intros; assumption.
+intros; apply H1; unfold disc in |- *; case (Req_dec y x); intro.
+rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ apply (cond_pos del1).
+apply H5; split.
+unfold D_x, no_cond in |- *; split.
+trivial.
+apply (sym_not_eq (A:=R)); apply H7.
+unfold disc in H6; apply H6.
+intros; unfold continuity_pt in |- *; unfold continue_in in |- *;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ intros.
+assert (H1 := H (disc (f x) (mkposreal eps H0))).
+cut (neighbourhood (disc (f x) (mkposreal eps H0)) (f x)).
+intro; assert (H3 := H1 H2).
+elim H3; intros D H4; elim H4; intros; unfold neighbourhood in H5; elim H5;
+ intros del1 H7.
+exists (pos del1); split.
+apply (cond_pos del1).
+intros; elim H8; intros; simpl in H10; unfold R_dist in H10; simpl in |- *;
+ unfold R_dist in |- *; apply (H6 _ (H7 _ H10)).
+unfold neighbourhood, disc in |- *; exists (mkposreal eps H0);
+ unfold included in |- *; intros; assumption.
+Qed.
+
+Definition image_rec (f:R -> R) (D:R -> Prop) (x:R) : Prop := D (f x).
+
+(**********)
+Lemma continuity_P2 :
+ forall (f:R -> R) (D:R -> Prop),
+   continuity f -> open_set D -> open_set (image_rec f D).
+intros; unfold open_set in H0; unfold open_set in |- *; intros;
+ assert (H2 := continuity_P1 f x); elim H2; intros H3 _;
+ assert (H4 := H3 (H x)); unfold neighbourhood, image_rec in |- *;
+ unfold image_rec in H1; assert (H5 := H4 D (H0 (f x) H1)); 
+ elim H5; intros V0 H6; elim H6; intros; unfold neighbourhood in H7; 
+ elim H7; intros del H9; exists del; unfold included in H9;
+ unfold included in |- *; intros; apply (H8 _ (H9 _ H10)).
+Qed.
+
+(**********)
+Lemma continuity_P3 :
+ forall f:R -> R,
+   continuity f <->
+   (forall D:R -> Prop, open_set D -> open_set (image_rec f D)).
+intros; split.
+intros; apply continuity_P2; assumption.
+intros; unfold continuity in |- *; unfold continuity_pt in |- *;
+ unfold continue_in in |- *; unfold limit1_in in |- *;
+ unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+ intros; cut (open_set (disc (f x) (mkposreal _ H0))).
+intro; assert (H2 := H _ H1).
+unfold open_set, image_rec in H2; cut (disc (f x) (mkposreal _ H0) (f x)).
+intro; assert (H4 := H2 _ H3).
+unfold neighbourhood in H4; elim H4; intros del H5.
+exists (pos del); split.
+apply (cond_pos del).
+intros; unfold included in H5; apply H5; elim H6; intros; apply H8.
+unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rabs_R0; apply H0.
+apply disc_P1.
+Qed.
+
+(**********)
+Theorem Rsepare :
+ forall x y:R,
+   x <> y ->
+    exists V : R -> Prop,
+     (exists W : R -> Prop,
+        neighbourhood V x /\
+        neighbourhood W y /\ ~ (exists y : R, intersection_domain V W y)).
+intros x y Hsep; set (D := Rabs (x - y)).
+cut (0 < D / 2).
+intro; exists (disc x (mkposreal _ H)).
+exists (disc y (mkposreal _ H)); split.
+unfold neighbourhood in |- *; exists (mkposreal _ H); unfold included in |- *;
+ tauto.
+split.
+unfold neighbourhood in |- *; exists (mkposreal _ H); unfold included in |- *;
+ tauto.
+red in |- *; intro; elim H0; intros; unfold intersection_domain in H1;
+ elim H1; intros.
+cut (D < D).
+intro; elim (Rlt_irrefl _ H4).
+change (Rabs (x - y) < D) in |- *;
+ apply Rle_lt_trans with (Rabs (x - x0) + Rabs (x0 - y)).
+replace (x - y) with (x - x0 + (x0 - y)); [ apply Rabs_triang | ring ].
+rewrite (double_var D); apply Rplus_lt_compat.
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H2.
+apply H3.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+unfold D in |- *; apply Rabs_pos_lt; apply (Rminus_eq_contra _ _ Hsep).
+apply Rinv_0_lt_compat; prove_sup0.
+Qed.
+
+Record family : Type := mkfamily
+  {ind : R -> Prop;
+   f :> R -> R -> Prop;
+   cond_fam : forall x:R, (exists y : R, f x y) -> ind x}.
+
+Definition family_open_set (f:family) : Prop := forall x:R, open_set (f x).
+
+Definition domain_finite (D:R -> Prop) : Prop :=
+   exists l : Rlist, (forall x:R, D x <-> In x l).
+
+Definition family_finite (f:family) : Prop := domain_finite (ind f).
+
+Definition covering (D:R -> Prop) (f:family) : Prop :=
+  forall x:R, D x ->  exists y : R, f y x.
+
+Definition covering_open_set (D:R -> Prop) (f:family) : Prop :=
+  covering D f /\ family_open_set f.
+
+Definition covering_finite (D:R -> Prop) (f:family) : Prop :=
+  covering D f /\ family_finite f.
+
+Lemma restriction_family :
+ forall (f:family) (D:R -> Prop) (x:R),
+   (exists y : R, (fun z1 z2:R => f z1 z2 /\ D z1) x y) ->
+   intersection_domain (ind f) D x.
+intros; elim H; intros; unfold intersection_domain in |- *; elim H0; intros;
+ split.
+apply (cond_fam f0); exists x0; assumption.
+assumption.
+Qed.
+
+Definition subfamily (f:family) (D:R -> Prop) : family :=
+  mkfamily (intersection_domain (ind f) D) (fun x y:R => f x y /\ D x)
+    (restriction_family f D).
+
+Definition compact (X:R -> Prop) : Prop :=
+  forall f:family,
+    covering_open_set X f ->
+     exists D : R -> Prop, covering_finite X (subfamily f D).
+
+(**********)
+Lemma family_P1 :
+ forall (f:family) (D:R -> Prop),
+   family_open_set f -> family_open_set (subfamily f D).
+unfold family_open_set in |- *; intros; unfold subfamily in |- *;
+ simpl in |- *; assert (H0 := classic (D x)).
+elim H0; intro.
+cut (open_set (f0 x) -> open_set (fun y:R => f0 x y /\ D x)).
+intro; apply H2; apply H.
+unfold open_set in |- *; unfold neighbourhood in |- *; intros; elim H3;
+ intros; assert (H6 := H2 _ H4); elim H6; intros; exists x1;
+ unfold included in |- *; intros; split.
+apply (H7 _ H8).
+assumption.
+cut (open_set (fun y:R => False) -> open_set (fun y:R => f0 x y /\ D x)).
+intro; apply H2; apply open_set_P4.
+unfold open_set in |- *; unfold neighbourhood in |- *; intros; elim H3;
+ intros; elim H1; assumption.
+Qed.
+
+Definition bounded (D:R -> Prop) : Prop :=
+   exists m : R, (exists M : R, (forall x:R, D x -> m <= x <= M)).
+
+Lemma open_set_P6 :
+ forall D1 D2:R -> Prop, open_set D1 -> D1 =_D D2 -> open_set D2.
+unfold open_set in |- *; unfold neighbourhood in |- *; intros.
+unfold eq_Dom in H0; elim H0; intros.
+assert (H4 := H _ (H3 _ H1)).
+elim H4; intros.
+exists x0; apply included_trans with D1; assumption.
+Qed.
+
+(**********)
+Lemma compact_P1 : forall X:R -> Prop, compact X -> bounded X.
+intros; unfold compact in H; set (D := fun x:R => True);
+ set (g := fun x y:R => Rabs y < x);
+ cut (forall x:R, (exists y : _, g x y) -> True);
+ [ intro | intro; trivial ].
+set (f0 := mkfamily D g H0); assert (H1 := H f0);
+ cut (covering_open_set X f0).
+intro; assert (H3 := H1 H2); elim H3; intros D' H4;
+ unfold covering_finite in H4; elim H4; intros; unfold family_finite in H6;
+ unfold domain_finite in H6; elim H6; intros l H7; 
+ unfold bounded in |- *; set (r := MaxRlist l).
+exists (- r); exists r; intros.
+unfold covering in H5; assert (H9 := H5 _ H8); elim H9; intros;
+ unfold subfamily in H10; simpl in H10; elim H10; intros;
+ assert (H13 := H7 x0); simpl in H13; cut (intersection_domain D D' x0).
+elim H13; clear H13; intros.
+assert (H16 := H13 H15); unfold g in H11; split.
+cut (x0 <= r).
+intro; cut (Rabs x < r).
+intro; assert (H19 := Rabs_def2 x r H18); elim H19; intros; left; assumption.
+apply Rlt_le_trans with x0; assumption.
+apply (MaxRlist_P1 l x0 H16).
+cut (x0 <= r).
+intro; apply Rle_trans with (Rabs x).
+apply RRle_abs.
+apply Rle_trans with x0.
+left; apply H11.
+assumption.
+apply (MaxRlist_P1 l x0 H16).
+unfold intersection_domain, D in |- *; tauto.
+unfold covering_open_set in |- *; split.
+unfold covering in |- *; intros; simpl in |- *; exists (Rabs x + 1);
+ unfold g in |- *; pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_lt_compat_l; apply Rlt_0_1.
+unfold family_open_set in |- *; intro; case (Rtotal_order 0 x); intro.
+apply open_set_P6 with (disc 0 (mkposreal _ H2)).
+apply disc_P1.
+unfold eq_Dom in |- *; unfold f0 in |- *; simpl in |- *;
+ unfold g, disc in |- *; split.
+unfold included in |- *; intros; unfold Rminus in H3; rewrite Ropp_0 in H3;
+ rewrite Rplus_0_r in H3; apply H3.
+unfold included in |- *; intros; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; apply H3.
+apply open_set_P6 with (fun x:R => False).
+apply open_set_P4.
+unfold eq_Dom in |- *; split.
+unfold included in |- *; intros; elim H3.
+unfold included, f0 in |- *; simpl in |- *; unfold g in |- *; intros; elim H2;
+ intro;
+ [ rewrite <- H4 in H3; assert (H5 := Rabs_pos x0);
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3))
+ | assert (H6 := Rabs_pos x0); assert (H7 := Rlt_trans _ _ _ H3 H4);
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H7)) ].
+Qed.
+
+(**********)
+Lemma compact_P2 : forall X:R -> Prop, compact X -> closed_set X.
+intros; assert (H0 := closed_set_P1 X); elim H0; clear H0; intros _ H0;
+ apply H0; clear H0.
+unfold eq_Dom in |- *; split.
+apply adherence_P1.
+unfold included in |- *; unfold adherence in |- *;
+ unfold point_adherent in |- *; intros; unfold compact in H;
+ assert (H1 := classic (X x)); elim H1; clear H1; intro.
+assumption.
+cut (forall y:R, X y -> 0 < Rabs (y - x) / 2).
+intro; set (D := X);
+ set (g := fun y z:R => Rabs (y - z) < Rabs (y - x) / 2 /\ D y);
+ cut (forall x:R, (exists y : _, g x y) -> D x).
+intro; set (f0 := mkfamily D g H3); assert (H4 := H f0);
+ cut (covering_open_set X f0).
+intro; assert (H6 := H4 H5); elim H6; clear H6; intros D' H6.
+unfold covering_finite in H6; decompose [and] H6;
+ unfold covering, subfamily in H7; simpl in H7;
+ unfold family_finite, subfamily in H8; simpl in H8;
+ unfold domain_finite in H8; elim H8; clear H8; intros l H8;
+ set (alp := MinRlist (AbsList l x)); cut (0 < alp).
+intro; assert (H10 := H0 (disc x (mkposreal _ H9)));
+ cut (neighbourhood (disc x (mkposreal alp H9)) x).
+intro; assert (H12 := H10 H11); elim H12; clear H12; intros y H12;
+ unfold intersection_domain in H12; elim H12; clear H12; 
+ intros; assert (H14 := H7 _ H13); elim H14; clear H14; 
+ intros y0 H14; elim H14; clear H14; intros; unfold g in H14; 
+ elim H14; clear H14; intros; unfold disc in H12; simpl in H12;
+ cut (alp <= Rabs (y0 - x) / 2).
+intro; assert (H18 := Rlt_le_trans _ _ _ H12 H17);
+ cut (Rabs (y0 - x) < Rabs (y0 - x)).
+intro; elim (Rlt_irrefl _ H19).
+apply Rle_lt_trans with (Rabs (y0 - y) + Rabs (y - x)).
+replace (y0 - x) with (y0 - y + (y - x)); [ apply Rabs_triang | ring ].
+rewrite (double_var (Rabs (y0 - x))); apply Rplus_lt_compat; assumption.
+apply (MinRlist_P1 (AbsList l x) (Rabs (y0 - x) / 2)); apply AbsList_P1;
+ elim (H8 y0); clear H8; intros; apply H8; unfold intersection_domain in |- *;
+ split; assumption.
+assert (H11 := disc_P1 x (mkposreal alp H9)); unfold open_set in H11;
+ apply H11.
+unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rabs_R0; apply H9.
+unfold alp in |- *; apply MinRlist_P2; intros;
+ assert (H10 := AbsList_P2 _ _ _ H9); elim H10; clear H10; 
+ intros z H10; elim H10; clear H10; intros; rewrite H11; 
+ apply H2; elim (H8 z); clear H8; intros; assert (H13 := H12 H10);
+ unfold intersection_domain, D in H13; elim H13; clear H13; 
+ intros; assumption.
+unfold covering_open_set in |- *; split.
+unfold covering in |- *; intros; exists x0; simpl in |- *; unfold g in |- *;
+ split.
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ unfold Rminus in H2; apply (H2 _ H5).
+apply H5.
+unfold family_open_set in |- *; intro; simpl in |- *; unfold g in |- *;
+ elim (classic (D x0)); intro.
+apply open_set_P6 with (disc x0 (mkposreal _ (H2 _ H5))).
+apply disc_P1.
+unfold eq_Dom in |- *; split.
+unfold included, disc in |- *; simpl in |- *; intros; split.
+rewrite <- (Rabs_Ropp (x0 - x1)); rewrite Ropp_minus_distr; apply H6.
+apply H5.
+unfold included, disc in |- *; simpl in |- *; intros; elim H6; intros;
+ rewrite <- (Rabs_Ropp (x1 - x0)); rewrite Ropp_minus_distr; 
+ apply H7.
+apply open_set_P6 with (fun z:R => False).
+apply open_set_P4.
+unfold eq_Dom in |- *; split.
+unfold included in |- *; intros; elim H6.
+unfold included in |- *; intros; elim H6; intros; elim H5; assumption.
+intros; elim H3; intros; unfold g in H4; elim H4; clear H4; intros _ H4;
+ apply H4.
+intros; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply Rabs_pos_lt; apply Rminus_eq_contra; red in |- *; intro;
+ rewrite H3 in H2; elim H1; apply H2.
+apply Rinv_0_lt_compat; prove_sup0.
+Qed.
+
+(**********)
+Lemma compact_EMP : compact (fun _:R => False).
+unfold compact in |- *; intros; exists (fun x:R => False);
+ unfold covering_finite in |- *; split.
+unfold covering in |- *; intros; elim H0.
+unfold family_finite in |- *; unfold domain_finite in |- *; exists nil; intro.
+split.
+simpl in |- *; unfold intersection_domain in |- *; intros; elim H0.
+elim H0; clear H0; intros _ H0; elim H0.
+simpl in |- *; intro; elim H0.
+Qed.
+
+Lemma compact_eqDom :
+ forall X1 X2:R -> Prop, compact X1 -> X1 =_D X2 -> compact X2.
+unfold compact in |- *; intros; unfold eq_Dom in H0; elim H0; clear H0;
+ unfold included in |- *; intros; assert (H3 : covering_open_set X1 f0).
+unfold covering_open_set in |- *; unfold covering_open_set in H1; elim H1;
+ clear H1; intros; split.
+unfold covering in H1; unfold covering in |- *; intros;
+ apply (H1 _ (H0 _ H4)).
+apply H3.
+elim (H _ H3); intros D H4; exists D; unfold covering_finite in |- *;
+ unfold covering_finite in H4; elim H4; intros; split.
+unfold covering in H5; unfold covering in |- *; intros;
+ apply (H5 _ (H2 _ H7)).
+apply H6.
+Qed.
+
+(* Borel-Lebesgue's lemma *)
+Lemma compact_P3 : forall a b:R, compact (fun c:R => a <= c <= b).
+intros; case (Rle_dec a b); intro.
+unfold compact in |- *; intros;
+ set
+  (A :=
+   fun x:R =>
+     a <= x <= b /\
+     (exists D : R -> Prop,
+        covering_finite (fun c:R => a <= c <= x) (subfamily f0 D)));
+ cut (A a).
+intro; cut (bound A).
+intro; cut (exists a0 : R, A a0).
+intro; assert (H3 := completeness A H1 H2); elim H3; clear H3; intros m H3;
+ unfold is_lub in H3; cut (a <= m <= b).
+intro; unfold covering_open_set in H; elim H; clear H; intros;
+ unfold covering in H; assert (H6 := H m H4); elim H6; 
+ clear H6; intros y0 H6; unfold family_open_set in H5; 
+ assert (H7 := H5 y0); unfold open_set in H7; assert (H8 := H7 m H6);
+ unfold neighbourhood in H8; elim H8; clear H8; intros eps H8;
+ cut (exists x : R, A x /\ m - eps < x <= m).
+intro; elim H9; clear H9; intros x H9; elim H9; clear H9; intros;
+ case (Req_dec m b); intro.
+rewrite H11 in H10; rewrite H11 in H8; unfold A in H9; elim H9; clear H9;
+ intros; elim H12; clear H12; intros Dx H12;
+ set (Db := fun x:R => Dx x \/ x = y0); exists Db;
+ unfold covering_finite in |- *; split.
+unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12;
+ intros; unfold covering in H12; case (Rle_dec x0 x); 
+ intro.
+cut (a <= x0 <= x).
+intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
+ simpl in H16; simpl in |- *; unfold Db in |- *; elim H16; 
+ clear H16; intros; split; [ apply H16 | left; apply H17 ].
+split.
+elim H14; intros; assumption.
+assumption.
+exists y0; simpl in |- *; split.
+apply H8; unfold disc in |- *; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr;
+ rewrite Rabs_right.
+apply Rlt_trans with (b - x).
+unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
+ auto with real.
+elim H10; intros H15 _; apply Rplus_lt_reg_r with (x - eps);
+ replace (x - eps + (b - x)) with (b - eps);
+ [ replace (x - eps + eps) with x; [ apply H15 | ring ] | ring ].
+apply Rge_minus; apply Rle_ge; elim H14; intros _ H15; apply H15.
+unfold Db in |- *; right; reflexivity.
+unfold family_finite in |- *; unfold domain_finite in |- *;
+ unfold covering_finite in H12; elim H12; clear H12; 
+ intros; unfold family_finite in H13; unfold domain_finite in H13; 
+ elim H13; clear H13; intros l H13; exists (cons y0 l); 
+ intro; split.
+intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
+ clear H13; intros; case (Req_dec x0 y0); intro.
+simpl in |- *; left; apply H16.
+simpl in |- *; right; apply H13.
+simpl in |- *; unfold intersection_domain in |- *; unfold Db in H14;
+ decompose [and or] H14.
+split; assumption.
+elim H16; assumption.
+intro; simpl in H14; elim H14; intro; simpl in |- *;
+ unfold intersection_domain in |- *.
+split.
+apply (cond_fam f0); rewrite H15; exists m; apply H6.
+unfold Db in |- *; right; assumption.
+simpl in |- *; unfold intersection_domain in |- *; elim (H13 x0).
+intros _ H16; assert (H17 := H16 H15); simpl in H17;
+ unfold intersection_domain in H17; split.
+elim H17; intros; assumption.
+unfold Db in |- *; left; elim H17; intros; assumption.
+set (m' := Rmin (m + eps / 2) b); cut (A m').
+intro; elim H3; intros; unfold is_upper_bound in H13;
+ assert (H15 := H13 m' H12); cut (m < m').
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H15 H16)).
+unfold m' in |- *; unfold Rmin in |- *; case (Rle_dec (m + eps / 2) b); intro.
+pattern m at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+ unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
+elim H4; intros.
+elim H17; intro.
+assumption.
+elim H11; assumption.
+unfold A in |- *; split.
+split.
+apply Rle_trans with m.
+elim H4; intros; assumption.
+unfold m' in |- *; unfold Rmin in |- *; case (Rle_dec (m + eps / 2) b); intro.
+pattern m at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+ unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
+elim H4; intros.
+elim H13; intro.
+assumption.
+elim H11; assumption.
+unfold m' in |- *; apply Rmin_r.
+unfold A in H9; elim H9; clear H9; intros; elim H12; clear H12; intros Dx H12;
+ set (Db := fun x:R => Dx x \/ x = y0); exists Db;
+ unfold covering_finite in |- *; split.
+unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12;
+ intros; unfold covering in H12; case (Rle_dec x0 x); 
+ intro.
+cut (a <= x0 <= x).
+intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
+ simpl in H16; simpl in |- *; unfold Db in |- *.
+elim H16; clear H16; intros; split; [ apply H16 | left; apply H17 ].
+elim H14; intros; split; assumption.
+exists y0; simpl in |- *; split.
+apply H8; unfold disc in |- *; unfold Rabs in |- *; case (Rcase_abs (x0 - m));
+ intro.
+rewrite Ropp_minus_distr; apply Rlt_trans with (m - x).
+unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
+ auto with real.
+apply Rplus_lt_reg_r with (x - eps);
+ replace (x - eps + (m - x)) with (m - eps).
+replace (x - eps + eps) with x.
+elim H10; intros; assumption.
+ring.
+ring.
+apply Rle_lt_trans with (m' - m).
+unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- m));
+ apply Rplus_le_compat_l; elim H14; intros; assumption.
+apply Rplus_lt_reg_r with m; replace (m + (m' - m)) with m'.
+apply Rle_lt_trans with (m + eps / 2).
+unfold m' in |- *; apply Rmin_l.
+apply Rplus_lt_compat_l; apply Rmult_lt_reg_l with 2.
+prove_sup0.
+unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; pattern (pos eps) at 1 in |- *; rewrite <- Rplus_0_r;
+ rewrite double; apply Rplus_lt_compat_l; apply (cond_pos eps).
+discrR.
+ring.
+unfold Db in |- *; right; reflexivity.
+unfold family_finite in |- *; unfold domain_finite in |- *;
+ unfold covering_finite in H12; elim H12; clear H12; 
+ intros; unfold family_finite in H13; unfold domain_finite in H13; 
+ elim H13; clear H13; intros l H13; exists (cons y0 l); 
+ intro; split.
+intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
+ clear H13; intros; case (Req_dec x0 y0); intro.
+simpl in |- *; left; apply H16.
+simpl in |- *; right; apply H13; simpl in |- *;
+ unfold intersection_domain in |- *; unfold Db in H14; 
+ decompose [and or] H14.
+split; assumption.
+elim H16; assumption.
+intro; simpl in H14; elim H14; intro; simpl in |- *;
+ unfold intersection_domain in |- *.
+split.
+apply (cond_fam f0); rewrite H15; exists m; apply H6.
+unfold Db in |- *; right; assumption.
+elim (H13 x0); intros _ H16.
+assert (H17 := H16 H15).
+simpl in H17.
+unfold intersection_domain in H17.
+split.
+elim H17; intros; assumption.
+unfold Db in |- *; left; elim H17; intros; assumption.
+elim (classic (exists x : R, A x /\ m - eps < x <= m)); intro.
+assumption.
+elim H3; intros; cut (is_upper_bound A (m - eps)).
+intro; assert (H13 := H11 _ H12); cut (m - eps < m).
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H14)).
+pattern m at 2 in |- *; rewrite <- Rplus_0_r; unfold Rminus in |- *;
+ apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_involutive;
+ rewrite Ropp_0; apply (cond_pos eps).
+set (P := fun n:R => A n /\ m - eps < n <= m);
+ assert (H12 := not_ex_all_not _ P H9); unfold P in H12;
+ unfold is_upper_bound in |- *; intros;
+ assert (H14 := not_and_or _ _ (H12 x)); elim H14; 
+ intro.
+elim H15; apply H13.
+elim (not_and_or _ _ H15); intro.
+case (Rle_dec x (m - eps)); intro.
+assumption.
+elim H16; auto with real.
+unfold is_upper_bound in H10; assert (H17 := H10 x H13); elim H16; apply H17.
+elim H3; clear H3; intros.
+unfold is_upper_bound in H3.
+split.
+apply (H3 _ H0).
+apply (H4 b); unfold is_upper_bound in |- *; intros; unfold A in H5; elim H5;
+ clear H5; intros H5 _; elim H5; clear H5; intros _ H5; 
+ apply H5.
+exists a; apply H0.
+unfold bound in |- *; exists b; unfold is_upper_bound in |- *; intros;
+ unfold A in H1; elim H1; clear H1; intros H1 _; elim H1; 
+ clear H1; intros _ H1; apply H1.
+unfold A in |- *; split.
+split; [ right; reflexivity | apply r ].
+unfold covering_open_set in H; elim H; clear H; intros; unfold covering in H;
+ cut (a <= a <= b).
+intro; elim (H _ H1); intros y0 H2; set (D' := fun x:R => x = y0); exists D';
+ unfold covering_finite in |- *; split.
+unfold covering in |- *; simpl in |- *; intros; cut (x = a).
+intro; exists y0; split.
+rewrite H4; apply H2.
+unfold D' in |- *; reflexivity.
+elim H3; intros; apply Rle_antisym; assumption.
+unfold family_finite in |- *; unfold domain_finite in |- *;
+ exists (cons y0 nil); intro; split.
+simpl in |- *; unfold intersection_domain in |- *; intro; elim H3; clear H3;
+ intros; unfold D' in H4; left; apply H4.
+simpl in |- *; unfold intersection_domain in |- *; intro; elim H3; intro.
+split; [ rewrite H4; apply (cond_fam f0); exists a; apply H2 | apply H4 ].
+elim H4.
+split; [ right; reflexivity | apply r ].
+apply compact_eqDom with (fun c:R => False).
+apply compact_EMP.
+unfold eq_Dom in |- *; split.
+unfold included in |- *; intros; elim H.
+unfold included in |- *; intros; elim H; clear H; intros;
+ assert (H1 := Rle_trans _ _ _ H H0); elim n; apply H1.
+Qed.
+
+Lemma compact_P4 :
+ forall X F:R -> Prop, compact X -> closed_set F -> included F X -> compact F.
+unfold compact in |- *; intros; elim (classic (exists z : R, F z));
+ intro Hyp_F_NE.
+set (D := ind f0); set (g := f f0); unfold closed_set in H0.
+set (g' := fun x y:R => f0 x y \/ complementary F y /\ D x).
+set (D' := D).
+cut (forall x:R, (exists y : R, g' x y) -> D' x).
+intro; set (f' := mkfamily D' g' H3); cut (covering_open_set X f').
+intro; elim (H _ H4); intros DX H5; exists DX.
+unfold covering_finite in |- *; unfold covering_finite in H5; elim H5;
+ clear H5; intros.
+split.
+unfold covering in |- *; unfold covering in H5; intros.
+elim (H5 _ (H1 _ H7)); intros y0 H8; exists y0; simpl in H8; simpl in |- *;
+ elim H8; clear H8; intros.
+split.
+unfold g' in H8; elim H8; intro.
+apply H10.
+elim H10; intros H11 _; unfold complementary in H11; elim H11; apply H7.
+apply H9.
+unfold family_finite in |- *; unfold domain_finite in |- *;
+ unfold family_finite in H6; unfold domain_finite in H6; 
+ elim H6; clear H6; intros l H6; exists l; intro; assert (H7 := H6 x);
+ elim H7; clear H7; intros.
+split.
+intro; apply H7; simpl in |- *; unfold intersection_domain in |- *;
+ simpl in H9; unfold intersection_domain in H9; unfold D' in |- *; 
+ apply H9.
+intro; assert (H10 := H8 H9); simpl in H10; unfold intersection_domain in H10;
+ simpl in |- *; unfold intersection_domain in |- *; 
+ unfold D' in H10; apply H10.
+unfold covering_open_set in |- *; unfold covering_open_set in H2; elim H2;
+ clear H2; intros.
+split.
+unfold covering in |- *; unfold covering in H2; intros.
+elim (classic (F x)); intro.
+elim (H2 _ H6); intros y0 H7; exists y0; simpl in |- *; unfold g' in |- *;
+ left; assumption.
+cut (exists z : R, D z).
+intro; elim H7; clear H7; intros x0 H7; exists x0; simpl in |- *;
+ unfold g' in |- *; right.
+split.
+unfold complementary in |- *; apply H6.
+apply H7.
+elim Hyp_F_NE; intros z0 H7.
+assert (H8 := H2 _ H7).
+elim H8; clear H8; intros t H8; exists t; apply (cond_fam f0); exists z0;
+ apply H8.
+unfold family_open_set in |- *; intro; simpl in |- *; unfold g' in |- *;
+ elim (classic (D x)); intro.
+apply open_set_P6 with (union_domain (f0 x) (complementary F)).
+apply open_set_P2.
+unfold family_open_set in H4; apply H4.
+apply H0.
+unfold eq_Dom in |- *; split.
+unfold included, union_domain, complementary in |- *; intros.
+elim H6; intro; [ left; apply H7 | right; split; assumption ].
+unfold included, union_domain, complementary in |- *; intros.
+elim H6; intro; [ left; apply H7 | right; elim H7; intros; apply H8 ].
+apply open_set_P6 with (f0 x).
+unfold family_open_set in H4; apply H4.
+unfold eq_Dom in |- *; split.
+unfold included, complementary in |- *; intros; left; apply H6.
+unfold included, complementary in |- *; intros.
+elim H6; intro.
+apply H7.
+elim H7; intros _ H8; elim H5; apply H8.
+intros; elim H3; intros y0 H4; unfold g' in H4; elim H4; intro.
+apply (cond_fam f0); exists y0; apply H5.
+elim H5; clear H5; intros _ H5; apply H5.
+(* Cas ou F est l'ensemble vide *)
+cut (compact F).
+intro; apply (H3 f0 H2).
+apply compact_eqDom with (fun _:R => False).
+apply compact_EMP.
+unfold eq_Dom in |- *; split.
+unfold included in |- *; intros; elim H3.
+assert (H3 := not_ex_all_not _ _ Hyp_F_NE); unfold included in |- *; intros;
+ elim (H3 x); apply H4.
+Qed.
+
+(**********)
+Lemma compact_P5 : forall X:R -> Prop, closed_set X -> bounded X -> compact X.
+intros; unfold bounded in H0.
+elim H0; clear H0; intros m H0.
+elim H0; clear H0; intros M H0.
+assert (H1 := compact_P3 m M).
+apply (compact_P4 (fun c:R => m <= c <= M) X H1 H H0).
+Qed.
+
+(**********)
+Lemma compact_carac :
+ forall X:R -> Prop, compact X <-> closed_set X /\ bounded X.
+intro; split.
+intro; split; [ apply (compact_P2 _ H) | apply (compact_P1 _ H) ].
+intro; elim H; clear H; intros; apply (compact_P5 _ H H0).
+Qed.
+
+Definition image_dir (f:R -> R) (D:R -> Prop) (x:R) : Prop :=
+   exists y : R, x = f y /\ D y.
+
+(**********)
+Lemma continuity_compact :
+ forall (f:R -> R) (X:R -> Prop),
+   (forall x:R, continuity_pt f x) -> compact X -> compact (image_dir f X).
+unfold compact in |- *; intros; unfold covering_open_set in H1.
+elim H1; clear H1; intros.
+set (D := ind f1).
+set (g := fun x y:R => image_rec f0 (f1 x) y).
+cut (forall x:R, (exists y : R, g x y) -> D x).
+intro; set (f' := mkfamily D g H3).
+cut (covering_open_set X f').
+intro; elim (H0 f' H4); intros D' H5; exists D'.
+unfold covering_finite in H5; elim H5; clear H5; intros;
+ unfold covering_finite in |- *; split.
+unfold covering, image_dir in |- *; simpl in |- *; unfold covering in H5;
+ intros; elim H7; intros y H8; elim H8; intros; assert (H11 := H5 _ H10);
+ simpl in H11; elim H11; intros z H12; exists z; unfold g in H12;
+ unfold image_rec in H12; rewrite H9; apply H12.
+unfold family_finite in H6; unfold domain_finite in H6;
+ unfold family_finite in |- *; unfold domain_finite in |- *; 
+ elim H6; intros l H7; exists l; intro; elim (H7 x); 
+ intros; split; intro.
+apply H8; simpl in H10; simpl in |- *; apply H10.
+apply (H9 H10).
+unfold covering_open_set in |- *; split.
+unfold covering in |- *; intros; simpl in |- *; unfold covering in H1;
+ unfold image_dir in H1; unfold g in |- *; unfold image_rec in |- *; 
+ apply H1.
+exists x; split; [ reflexivity | apply H4 ].
+unfold family_open_set in |- *; unfold family_open_set in H2; intro;
+ simpl in |- *; unfold g in |- *;
+ cut ((fun y:R => image_rec f0 (f1 x) y) = image_rec f0 (f1 x)).
+intro; rewrite H4.
+apply (continuity_P2 f0 (f1 x) H (H2 x)).
+reflexivity.
+intros; apply (cond_fam f1); unfold g in H3; unfold image_rec in H3; elim H3;
+ intros; exists (f0 x0); apply H4.
+Qed.
+
+Lemma Rlt_Rminus : forall a b:R, a < b -> 0 < b - a.
+intros; apply Rplus_lt_reg_r with a; rewrite Rplus_0_r;
+ replace (a + (b - a)) with b; [ assumption | ring ].
+Qed.
+
+Lemma prolongement_C0 :
+ forall (f:R -> R) (a b:R),
+   a <= b ->
+   (forall c:R, a <= c <= b -> continuity_pt f c) ->
+    exists g : R -> R,
+     continuity g /\ (forall c:R, a <= c <= b -> g c = f c).
+intros; elim H; intro.
+set
+ (h :=
+  fun x:R =>
+    match Rle_dec x a with
+    | left _ => f0 a
+    | right _ =>
+        match Rle_dec x b with
+        | left _ => f0 x
+        | right _ => f0 b
+        end
+    end).
+assert (H2 : 0 < b - a).
+apply Rlt_Rminus; assumption.
+exists h; split.
+unfold continuity in |- *; intro; case (Rtotal_order x a); intro.
+unfold continuity_pt in |- *; unfold continue_in in |- *;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ simpl in |- *; unfold R_dist in |- *; intros; exists (a - x); 
+ split.
+change (0 < a - x) in |- *; apply Rlt_Rminus; assumption.
+intros; elim H5; clear H5; intros _ H5; unfold h in |- *.
+case (Rle_dec x a); intro.
+case (Rle_dec x0 a); intro.
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+elim n; left; apply Rplus_lt_reg_r with (- x);
+ do 2 rewrite (Rplus_comm (- x)); apply Rle_lt_trans with (Rabs (x0 - x)).
+apply RRle_abs.
+assumption.
+elim n; left; assumption.
+elim H3; intro.
+assert (H5 : a <= a <= b).
+split; [ right; reflexivity | left; assumption ].
+assert (H6 := H0 _ H5); unfold continuity_pt in H6; unfold continue_in in H6;
+ unfold limit1_in in H6; unfold limit_in in H6; simpl in H6;
+ unfold R_dist in H6; unfold continuity_pt in |- *;
+ unfold continue_in in |- *; unfold limit1_in in |- *;
+ unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+ intros; elim (H6 _ H7); intros; exists (Rmin x0 (b - a)); 
+ split.
+unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro.
+elim H8; intros; assumption.
+change (0 < b - a) in |- *; apply Rlt_Rminus; assumption.
+intros; elim H9; clear H9; intros _ H9; cut (x1 < b).
+intro; unfold h in |- *; case (Rle_dec x a); intro.
+case (Rle_dec x1 a); intro.
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+case (Rle_dec x1 b); intro.
+elim H8; intros; apply H12; split.
+unfold D_x, no_cond in |- *; split.
+trivial.
+red in |- *; intro; elim n; right; symmetry  in |- *; assumption.
+apply Rlt_le_trans with (Rmin x0 (b - a)).
+rewrite H4 in H9; apply H9.
+apply Rmin_l.
+elim n0; left; assumption.
+elim n; right; assumption.
+apply Rplus_lt_reg_r with (- a); do 2 rewrite (Rplus_comm (- a));
+ rewrite H4 in H9; apply Rle_lt_trans with (Rabs (x1 - a)).
+apply RRle_abs.
+apply Rlt_le_trans with (Rmin x0 (b - a)).
+assumption.
+apply Rmin_r.
+case (Rtotal_order x b); intro.
+assert (H6 : a <= x <= b).
+split; left; assumption.
+assert (H7 := H0 _ H6); unfold continuity_pt in H7; unfold continue_in in H7;
+ unfold limit1_in in H7; unfold limit_in in H7; simpl in H7;
+ unfold R_dist in H7; unfold continuity_pt in |- *;
+ unfold continue_in in |- *; unfold limit1_in in |- *;
+ unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+ intros; elim (H7 _ H8); intros; elim H9; clear H9; 
+ intros.
+assert (H11 : 0 < x - a).
+apply Rlt_Rminus; assumption.
+assert (H12 : 0 < b - x).
+apply Rlt_Rminus; assumption.
+exists (Rmin x0 (Rmin (x - a) (b - x))); split.
+unfold Rmin in |- *; case (Rle_dec (x - a) (b - x)); intro.
+case (Rle_dec x0 (x - a)); intro.
+assumption.
+assumption.
+case (Rle_dec x0 (b - x)); intro.
+assumption.
+assumption.
+intros; elim H13; clear H13; intros; cut (a < x1 < b).
+intro; elim H15; clear H15; intros; unfold h in |- *; case (Rle_dec x a);
+ intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
+case (Rle_dec x b); intro.
+case (Rle_dec x1 a); intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H15)).
+case (Rle_dec x1 b); intro.
+apply H10; split.
+assumption.
+apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
+assumption.
+apply Rmin_l.
+elim n1; left; assumption.
+elim n0; left; assumption.
+split.
+apply Ropp_lt_cancel; apply Rplus_lt_reg_r with x;
+ apply Rle_lt_trans with (Rabs (x1 - x)).
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
+apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
+assumption.
+apply Rle_trans with (Rmin (x - a) (b - x)).
+apply Rmin_r.
+apply Rmin_l.
+apply Rplus_lt_reg_r with (- x); do 2 rewrite (Rplus_comm (- x));
+ apply Rle_lt_trans with (Rabs (x1 - x)).
+apply RRle_abs.
+apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
+assumption.
+apply Rle_trans with (Rmin (x - a) (b - x)); apply Rmin_r.
+elim H5; intro.
+assert (H7 : a <= b <= b).
+split; [ left; assumption | right; reflexivity ].
+assert (H8 := H0 _ H7); unfold continuity_pt in H8; unfold continue_in in H8;
+ unfold limit1_in in H8; unfold limit_in in H8; simpl in H8;
+ unfold R_dist in H8; unfold continuity_pt in |- *;
+ unfold continue_in in |- *; unfold limit1_in in |- *;
+ unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+ intros; elim (H8 _ H9); intros; exists (Rmin x0 (b - a)); 
+ split.
+unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro.
+elim H10; intros; assumption.
+change (0 < b - a) in |- *; apply Rlt_Rminus; assumption.
+intros; elim H11; clear H11; intros _ H11; cut (a < x1).
+intro; unfold h in |- *; case (Rle_dec x a); intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
+case (Rle_dec x1 a); intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H12)).
+case (Rle_dec x b); intro.
+case (Rle_dec x1 b); intro.
+rewrite H6; elim H10; intros; elim r0; intro.
+apply H14; split.
+unfold D_x, no_cond in |- *; split.
+trivial.
+red in |- *; intro; rewrite <- H16 in H15; elim (Rlt_irrefl _ H15).
+rewrite H6 in H11; apply Rlt_le_trans with (Rmin x0 (b - a)).
+apply H11.
+apply Rmin_l.
+rewrite H15; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ assumption.
+rewrite H6; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ assumption.
+elim n1; right; assumption.
+rewrite H6 in H11; apply Ropp_lt_cancel; apply Rplus_lt_reg_r with b;
+ apply Rle_lt_trans with (Rabs (x1 - b)).
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
+apply Rlt_le_trans with (Rmin x0 (b - a)).
+assumption.
+apply Rmin_r.
+unfold continuity_pt in |- *; unfold continue_in in |- *;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ simpl in |- *; unfold R_dist in |- *; intros; exists (x - b); 
+ split.
+change (0 < x - b) in |- *; apply Rlt_Rminus; assumption.
+intros; elim H8; clear H8; intros.
+assert (H10 : b < x0).
+apply Ropp_lt_cancel; apply Rplus_lt_reg_r with x;
+ apply Rle_lt_trans with (Rabs (x0 - x)).
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
+assumption.
+unfold h in |- *; case (Rle_dec x a); intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
+case (Rle_dec x b); intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H6)).
+case (Rle_dec x0 a); intro.
+elim (Rlt_irrefl _ (Rlt_trans _ _ _ H1 (Rlt_le_trans _ _ _ H10 r))).
+case (Rle_dec x0 b); intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10)).
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+intros; elim H3; intros; unfold h in |- *; case (Rle_dec c a); intro.
+elim r; intro.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 H6)).
+rewrite H6; reflexivity.
+case (Rle_dec c b); intro.
+reflexivity.
+elim n0; assumption.
+exists (fun _:R => f0 a); split.
+apply derivable_continuous; apply (derivable_const (f0 a)).
+intros; elim H2; intros; rewrite H1 in H3; cut (b = c).
+intro; rewrite <- H5; rewrite H1; reflexivity.
+apply Rle_antisym; assumption.
+Qed.
+
+(**********)
+Lemma continuity_ab_maj :
+ forall (f:R -> R) (a b:R),
+   a <= b ->
+   (forall c:R, a <= c <= b -> continuity_pt f c) ->
+    exists Mx : R, (forall c:R, a <= c <= b -> f c <= f Mx) /\ a <= Mx <= b.
+intros;
+ cut
+  (exists g : R -> R,
+     continuity g /\ (forall c:R, a <= c <= b -> g c = f0 c)).
+intro HypProl.
+elim HypProl; intros g Hcont_eq.
+elim Hcont_eq; clear Hcont_eq; intros Hcont Heq.
+assert (H1 := compact_P3 a b).
+assert (H2 := continuity_compact g (fun c:R => a <= c <= b) Hcont H1).
+assert (H3 := compact_P2 _ H2).
+assert (H4 := compact_P1 _ H2).
+cut (bound (image_dir g (fun c:R => a <= c <= b))).
+cut (exists x : R, image_dir g (fun c:R => a <= c <= b) x).
+intros; assert (H7 := completeness _ H6 H5).
+elim H7; clear H7; intros M H7; cut (image_dir g (fun c:R => a <= c <= b) M).
+intro; unfold image_dir in H8; elim H8; clear H8; intros Mxx H8; elim H8;
+ clear H8; intros; exists Mxx; split.
+intros; rewrite <- (Heq c H10); rewrite <- (Heq Mxx H9); intros;
+ rewrite <- H8; unfold is_lub in H7; elim H7; clear H7; 
+ intros H7 _; unfold is_upper_bound in H7; apply H7; 
+ unfold image_dir in |- *; exists c; split; [ reflexivity | apply H10 ].
+apply H9.
+elim (classic (image_dir g (fun c:R => a <= c <= b) M)); intro.
+assumption.
+cut
+ (exists eps : posreal,
+    (forall y:R,
+       ~
+       intersection_domain (disc M eps)
+         (image_dir g (fun c:R => a <= c <= b)) y)).
+intro; elim H9; clear H9; intros eps H9; unfold is_lub in H7; elim H7;
+ clear H7; intros;
+ cut (is_upper_bound (image_dir g (fun c:R => a <= c <= b)) (M - eps)).
+intro; assert (H12 := H10 _ H11); cut (M - eps < M).
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H12 H13)).
+pattern M at 2 in |- *; rewrite <- Rplus_0_r; unfold Rminus in |- *;
+ apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_0;
+ rewrite Ropp_involutive; apply (cond_pos eps).
+unfold is_upper_bound, image_dir in |- *; intros; cut (x <= M).
+intro; case (Rle_dec x (M - eps)); intro.
+apply r.
+elim (H9 x); unfold intersection_domain, disc, image_dir in |- *; split.
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right.
+apply Rplus_lt_reg_r with (x - eps);
+ replace (x - eps + (M - x)) with (M - eps).
+replace (x - eps + eps) with x.
+auto with real.
+ring.
+ring.
+apply Rge_minus; apply Rle_ge; apply H12.
+apply H11.
+apply H7; apply H11.
+cut
+ (exists V : R -> Prop,
+    neighbourhood V M /\
+    (forall y:R,
+       ~ intersection_domain V (image_dir g (fun c:R => a <= c <= b)) y)).
+intro; elim H9; intros V H10; elim H10; clear H10; intros.
+unfold neighbourhood in H10; elim H10; intros del H12; exists del; intros;
+ red in |- *; intro; elim (H11 y).
+unfold intersection_domain in |- *; unfold intersection_domain in H13;
+ elim H13; clear H13; intros; split.
+apply (H12 _ H13).
+apply H14.
+cut (~ point_adherent (image_dir g (fun c:R => a <= c <= b)) M).
+intro; unfold point_adherent in H9.
+assert
+ (H10 :=
+  not_all_ex_not _
+    (fun V:R -> Prop =>
+       neighbourhood V M ->
+        exists y : R,
+         intersection_domain V (image_dir g (fun c:R => a <= c <= b)) y) H9).
+elim H10; intros V0 H11; exists V0; assert (H12 := imply_to_and _ _ H11);
+ elim H12; clear H12; intros.
+split.
+apply H12.
+apply (not_ex_all_not _ _ H13).
+red in |- *; intro; cut (adherence (image_dir g (fun c:R => a <= c <= b)) M).
+intro; elim (closed_set_P1 (image_dir g (fun c:R => a <= c <= b)));
+ intros H11 _; assert (H12 := H11 H3).
+elim H8.
+unfold eq_Dom in H12; elim H12; clear H12; intros.
+apply (H13 _ H10).
+apply H9.
+exists (g a); unfold image_dir in |- *; exists a; split.
+reflexivity.
+split; [ right; reflexivity | apply H ].
+unfold bound in |- *; unfold bounded in H4; elim H4; clear H4; intros m H4;
+ elim H4; clear H4; intros M H4; exists M; unfold is_upper_bound in |- *;
+ intros; elim (H4 _ H5); intros _ H6; apply H6.
+apply prolongement_C0; assumption.
+Qed.
+
+(**********)
+Lemma continuity_ab_min :
+ forall (f:R -> R) (a b:R),
+   a <= b ->
+   (forall c:R, a <= c <= b -> continuity_pt f c) ->
+    exists mx : R, (forall c:R, a <= c <= b -> f mx <= f c) /\ a <= mx <= b.
+intros.
+cut (forall c:R, a <= c <= b -> continuity_pt (- f0) c).
+intro; assert (H2 := continuity_ab_maj (- f0)%F a b H H1); elim H2;
+ intros x0 H3; exists x0; intros; split.
+intros; rewrite <- (Ropp_involutive (f0 x0));
+ rewrite <- (Ropp_involutive (f0 c)); apply Ropp_le_contravar; 
+ elim H3; intros; unfold opp_fct in H5; apply H5; apply H4.
+elim H3; intros; assumption.
+intros.
+assert (H2 := H0 _ H1).
+apply (continuity_pt_opp _ _ H2).
+Qed.
+
+
+(********************************************************)
+(*         Proof of Bolzano-Weierstrass theorem         *)
+(********************************************************)
+
+Definition ValAdh (un:nat -> R) (x:R) : Prop :=
+  forall (V:R -> Prop) (N:nat),
+    neighbourhood V x ->  exists p : nat, (N <= p)%nat /\ V (un p).
+
+Definition intersection_family (f:family) (x:R) : Prop :=
+  forall y:R, ind f y -> f y x.
+
+Lemma ValAdh_un_exists :
+ forall (un:nat -> R) (D:=fun x:R =>  exists n : nat, x = INR n)
+   (f:=
+    fun x:R =>
+      adherence
+        (fun y:R => (exists p : nat, y = un p /\ x <= INR p) /\ D x))
+   (x:R), (exists y : R, f x y) -> D x.
+intros; elim H; intros; unfold f in H0; unfold adherence in H0;
+ unfold point_adherent in H0;
+ assert (H1 : neighbourhood (disc x0 (mkposreal _ Rlt_0_1)) x0).
+unfold neighbourhood, disc in |- *; exists (mkposreal _ Rlt_0_1);
+ unfold included in |- *; trivial.
+elim (H0 _ H1); intros; unfold intersection_domain in H2; elim H2; intros;
+ elim H4; intros; apply H6.
+Qed.
+
+Definition ValAdh_un (un:nat -> R) : R -> Prop :=
+  let D := fun x:R =>  exists n : nat, x = INR n in
+  let f :=
+    fun x:R =>
+      adherence
+        (fun y:R => (exists p : nat, y = un p /\ x <= INR p) /\ D x) in
+  intersection_family (mkfamily D f (ValAdh_un_exists un)).
+
+Lemma ValAdh_un_prop :
+ forall (un:nat -> R) (x:R), ValAdh un x <-> ValAdh_un un x.
+intros; split; intro.
+unfold ValAdh in H; unfold ValAdh_un in |- *;
+ unfold intersection_family in |- *; simpl in |- *; 
+ intros; elim H0; intros N H1; unfold adherence in |- *;
+ unfold point_adherent in |- *; intros; elim (H V N H2); 
+ intros; exists (un x0); unfold intersection_domain in |- *; 
+ elim H3; clear H3; intros; split.
+assumption.
+split.
+exists x0; split; [ reflexivity | rewrite H1; apply (le_INR _ _ H3) ].
+exists N; assumption.
+unfold ValAdh in |- *; intros; unfold ValAdh_un in H;
+ unfold intersection_family in H; simpl in H;
+ assert
+  (H1 :
+   adherence
+     (fun y0:R =>
+        (exists p : nat, y0 = un p /\ INR N <= INR p) /\
+        (exists n : nat, INR N = INR n)) x).
+apply H; exists N; reflexivity.
+unfold adherence in H1; unfold point_adherent in H1; assert (H2 := H1 _ H0);
+ elim H2; intros; unfold intersection_domain in H3; 
+ elim H3; clear H3; intros; elim H4; clear H4; intros; 
+ elim H4; clear H4; intros; elim H4; clear H4; intros; 
+ exists x1; split.
+apply (INR_le _ _ H6).
+rewrite H4 in H3; apply H3.
+Qed.
+
+Lemma adherence_P4 :
+ forall F G:R -> Prop, included F G -> included (adherence F) (adherence G).
+unfold adherence, included in |- *; unfold point_adherent in |- *; intros;
+ elim (H0 _ H1); unfold intersection_domain in |- *; 
+ intros; elim H2; clear H2; intros; exists x0; split;
+ [ assumption | apply (H _ H3) ].
+Qed.
+
+Definition family_closed_set (f:family) : Prop :=
+  forall x:R, closed_set (f x).
+
+Definition intersection_vide_in (D:R -> Prop) (f:family) : Prop :=
+  forall x:R,
+    (ind f x -> included (f x) D) /\
+    ~ (exists y : R, intersection_family f y).
+
+Definition intersection_vide_finite_in (D:R -> Prop) 
+  (f:family) : Prop := intersection_vide_in D f /\ family_finite f.
+
+(**********)
+Lemma compact_P6 :
+ forall X:R -> Prop,
+   compact X ->
+   (exists z : R, X z) ->
+   forall g:family,
+     family_closed_set g ->
+     intersection_vide_in X g ->
+      exists D : R -> Prop, intersection_vide_finite_in X (subfamily g D).
+intros X H Hyp g H0 H1.
+set (D' := ind g).
+set (f' := fun x y:R => complementary (g x) y /\ D' x).
+assert (H2 : forall x:R, (exists y : R, f' x y) -> D' x).
+intros; elim H2; intros; unfold f' in H3; elim H3; intros; assumption.
+set (f0 := mkfamily D' f' H2).
+unfold compact in H; assert (H3 : covering_open_set X f0).
+unfold covering_open_set in |- *; split.
+unfold covering in |- *; intros; unfold intersection_vide_in in H1;
+ elim (H1 x); intros; unfold intersection_family in H5;
+ assert
+  (H6 := not_ex_all_not _ (fun y:R => forall y0:R, ind g y0 -> g y0 y) H5 x);
+ assert (H7 := not_all_ex_not _ (fun y0:R => ind g y0 -> g y0 x) H6); 
+ elim H7; intros; exists x0; elim (imply_to_and _ _ H8); 
+ intros; unfold f0 in |- *; simpl in |- *; unfold f' in |- *; 
+ split; [ apply H10 | apply H9 ].
+unfold family_open_set in |- *; intro; elim (classic (D' x)); intro.
+apply open_set_P6 with (complementary (g x)).
+unfold family_closed_set in H0; unfold closed_set in H0; apply H0.
+unfold f0 in |- *; simpl in |- *; unfold f' in |- *; unfold eq_Dom in |- *;
+ split.
+unfold included in |- *; intros; split; [ apply H4 | apply H3 ].
+unfold included in |- *; intros; elim H4; intros; assumption.
+apply open_set_P6 with (fun _:R => False).
+apply open_set_P4.
+unfold eq_Dom in |- *; unfold included in |- *; split; intros;
+ [ elim H4
+ | simpl in H4; unfold f' in H4; elim H4; intros; elim H3; assumption ].
+elim (H _ H3); intros SF H4; exists SF;
+ unfold intersection_vide_finite_in in |- *; split.
+unfold intersection_vide_in in |- *; simpl in |- *; intros; split.
+intros; unfold included in |- *; intros; unfold intersection_vide_in in H1;
+ elim (H1 x); intros; elim H6; intros; apply H7.
+unfold intersection_domain in H5; elim H5; intros; assumption.
+assumption.
+elim (classic (exists y : R, intersection_domain (ind g) SF y)); intro Hyp'.
+red in |- *; intro; elim H5; intros; unfold intersection_family in H6;
+ simpl in H6.
+cut (X x0).
+intro; unfold covering_finite in H4; elim H4; clear H4; intros H4 _;
+ unfold covering in H4; elim (H4 x0 H7); intros; simpl in H8;
+ unfold intersection_domain in H6; cut (ind g x1 /\ SF x1).
+intro; assert (H10 := H6 x1 H9); elim H10; clear H10; intros H10 _; elim H8;
+ clear H8; intros H8 _; unfold f' in H8; unfold complementary in H8; 
+ elim H8; clear H8; intros H8 _; elim H8; assumption.
+split.
+apply (cond_fam f0).
+exists x0; elim H8; intros; assumption.
+elim H8; intros; assumption.
+unfold intersection_vide_in in H1; elim Hyp'; intros; assert (H8 := H6 _ H7);
+ elim H8; intros; cut (ind g x1).
+intro; elim (H1 x1); intros; apply H12.
+apply H11.
+apply H9.
+apply (cond_fam g); exists x0; assumption.
+unfold covering_finite in H4; elim H4; clear H4; intros H4 _;
+ cut (exists z : R, X z).
+intro; elim H5; clear H5; intros; unfold covering in H4; elim (H4 x0 H5);
+ intros; simpl in H6; elim Hyp'; exists x1; elim H6; 
+ intros; unfold intersection_domain in |- *; split.
+apply (cond_fam f0); exists x0; apply H7.
+apply H8.
+apply Hyp.
+unfold covering_finite in H4; elim H4; clear H4; intros;
+ unfold family_finite in H5; unfold domain_finite in H5;
+ unfold family_finite in |- *; unfold domain_finite in |- *; 
+ elim H5; clear H5; intros l H5; exists l; intro; elim (H5 x); 
+ intros; split; intro;
+ [ apply H6; simpl in |- *; simpl in H8; apply H8 | apply (H7 H8) ].
+Qed.
+
+Theorem Bolzano_Weierstrass :
+ forall (un:nat -> R) (X:R -> Prop),
+   compact X -> (forall n:nat, X (un n)) ->  exists l : R, ValAdh un l.
+intros; cut (exists l : R, ValAdh_un un l).
+intro; elim H1; intros; exists x; elim (ValAdh_un_prop un x); intros;
+ apply (H4 H2).
+assert (H1 :  exists z : R, X z).
+exists (un 0%nat); apply H0.
+set (D := fun x:R =>  exists n : nat, x = INR n).
+set
+ (g :=
+  fun x:R =>
+    adherence (fun y:R => (exists p : nat, y = un p /\ x <= INR p) /\ D x)).
+assert (H2 : forall x:R, (exists y : R, g x y) -> D x).
+intros; elim H2; intros; unfold g in H3; unfold adherence in H3;
+ unfold point_adherent in H3.
+assert (H4 : neighbourhood (disc x0 (mkposreal _ Rlt_0_1)) x0).
+unfold neighbourhood in |- *; exists (mkposreal _ Rlt_0_1);
+ unfold included in |- *; trivial.
+elim (H3 _ H4); intros; unfold intersection_domain in H5; decompose [and] H5;
+ assumption.
+set (f0 := mkfamily D g H2).
+assert (H3 := compact_P6 X H H1 f0).
+elim (classic (exists l : R, ValAdh_un un l)); intro.
+assumption.
+cut (family_closed_set f0).
+intro; cut (intersection_vide_in X f0).
+intro; assert (H7 := H3 H5 H6).
+elim H7; intros SF H8; unfold intersection_vide_finite_in in H8; elim H8;
+ clear H8; intros; unfold intersection_vide_in in H8; 
+ elim (H8 0); intros _ H10; elim H10; unfold family_finite in H9;
+ unfold domain_finite in H9; elim H9; clear H9; intros l H9;
+ set (r := MaxRlist l); cut (D r).
+intro; unfold D in H11; elim H11; intros; exists (un x);
+ unfold intersection_family in |- *; simpl in |- *;
+ unfold intersection_domain in |- *; intros; split.
+unfold g in |- *; apply adherence_P1; split.
+exists x; split;
+ [ reflexivity
+ | rewrite <- H12; unfold r in |- *; apply MaxRlist_P1; elim (H9 y); intros;
+    apply H14; simpl in |- *; apply H13 ].
+elim H13; intros; assumption.
+elim H13; intros; assumption.
+elim (H9 r); intros.
+simpl in H12; unfold intersection_domain in H12; cut (In r l).
+intro; elim (H12 H13); intros; assumption.
+unfold r in |- *; apply MaxRlist_P2;
+ cut (exists z : R, intersection_domain (ind f0) SF z).
+intro; elim H13; intros; elim (H9 x); intros; simpl in H15;
+ assert (H17 := H15 H14); exists x; apply H17.
+elim (classic (exists z : R, intersection_domain (ind f0) SF z)); intro.
+assumption.
+elim (H8 0); intros _ H14; elim H1; intros;
+ assert
+  (H16 :=
+   not_ex_all_not _ (fun y:R => intersection_family (subfamily f0 SF) y) H14);
+ assert
+  (H17 :=
+   not_ex_all_not _ (fun z:R => intersection_domain (ind f0) SF z) H13);
+ assert (H18 := H16 x); unfold intersection_family in H18; 
+ simpl in H18;
+ assert
+  (H19 :=
+   not_all_ex_not _ (fun y:R => intersection_domain D SF y -> g y x /\ SF y)
+     H18); elim H19; intros; assert (H21 := imply_to_and _ _ H20);
+ elim (H17 x0); elim H21; intros; assumption.
+unfold intersection_vide_in in |- *; intros; split.
+intro; simpl in H6; unfold f0 in |- *; simpl in |- *; unfold g in |- *;
+ apply included_trans with (adherence X).
+apply adherence_P4.
+unfold included in |- *; intros; elim H7; intros; elim H8; intros; elim H10;
+ intros; rewrite H11; apply H0.
+apply adherence_P2; apply compact_P2; assumption.
+apply H4.
+unfold family_closed_set in |- *; unfold f0 in |- *; simpl in |- *;
+ unfold g in |- *; intro; apply adherence_P3.
+Qed.
+
+(********************************************************)
+(*               Proof of Heine's theorem               *)
+(********************************************************)
+
+Definition uniform_continuity (f:R -> R) (X:R -> Prop) : Prop :=
+  forall eps:posreal,
+     exists delta : posreal,
+      (forall x y:R,
+         X x -> X y -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps).
+
+Lemma is_lub_u :
+ forall (E:R -> Prop) (x y:R), is_lub E x -> is_lub E y -> x = y.
+unfold is_lub in |- *; intros; elim H; elim H0; intros; apply Rle_antisym;
+ [ apply (H4 _ H1) | apply (H2 _ H3) ].
+Qed.
+
+Lemma domain_P1 :
+ forall X:R -> Prop,
+   ~ (exists y : R, X y) \/
+   (exists y : R, X y /\ (forall x:R, X x -> x = y)) \/
+   (exists x : R, (exists y : R, X x /\ X y /\ x <> y)).
+intro; elim (classic (exists y : R, X y)); intro.
+right; elim H; intros; elim (classic (exists y : R, X y /\ y <> x)); intro.
+right; elim H1; intros; elim H2; intros; exists x; exists x0; intros.
+split;
+ [ assumption
+ | split; [ assumption | apply (sym_not_eq (A:=R)); assumption ] ].
+left; exists x; split.
+assumption.
+intros; case (Req_dec x0 x); intro.
+assumption.
+elim H1; exists x0; split; assumption.
+left; assumption.
+Qed.
+
+Theorem Heine :
+ forall (f:R -> R) (X:R -> Prop),
+   compact X ->
+   (forall x:R, X x -> continuity_pt f x) -> uniform_continuity f X.
+intros f0 X H0 H; elim (domain_P1 X); intro Hyp.
+(* X est vide *)
+unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1);
+ intros; elim Hyp; exists x; assumption.
+elim Hyp; clear Hyp; intro Hyp.
+(* X possède un seul élément *)
+unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1);
+ intros; elim Hyp; clear Hyp; intros; elim H4; clear H4; 
+ intros; assert (H6 := H5 _ H1); assert (H7 := H5 _ H2); 
+ rewrite H6; rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rabs_R0; apply (cond_pos eps).
+(* X possède au moins deux éléments distincts *)
+assert
+ (X_enc :
+   exists m : R, (exists M : R, (forall x:R, X x -> m <= x <= M) /\ m < M)).
+assert (H1 := compact_P1 X H0); unfold bounded in H1; elim H1; intros;
+ elim H2; intros; exists x; exists x0; split.
+apply H3.
+elim Hyp; intros; elim H4; intros; decompose [and] H5;
+ assert (H10 := H3 _ H6); assert (H11 := H3 _ H8); 
+ elim H10; intros; elim H11; intros; case (total_order_T x x0); 
+ intro.
+elim s; intro.
+assumption.
+rewrite b in H13; rewrite b in H7; elim H9; apply Rle_antisym;
+ apply Rle_trans with x0; assumption.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H13 H14) r)).
+elim X_enc; clear X_enc; intros m X_enc; elim X_enc; clear X_enc;
+ intros M X_enc; elim X_enc; clear X_enc Hyp; intros X_enc Hyp;
+ unfold uniform_continuity in |- *; intro;
+ assert (H1 : forall t:posreal, 0 < t / 2).
+intro; unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply (cond_pos t) | apply Rinv_0_lt_compat; prove_sup0 ].
+set
+ (g :=
+  fun x y:R =>
+    X x /\
+    (exists del : posreal,
+       (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\
+       is_lub
+         (fun zeta:R =>
+            0 < zeta <= M - m /\
+            (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2))
+         del /\ disc x (mkposreal (del / 2) (H1 del)) y)).
+assert (H2 : forall x:R, (exists y : R, g x y) -> X x).
+intros; elim H2; intros; unfold g in H3; elim H3; clear H3; intros H3 _;
+ apply H3.
+set (f' := mkfamily X g H2); unfold compact in H0;
+ assert (H3 : covering_open_set X f').
+unfold covering_open_set in |- *; split.
+unfold covering in |- *; intros; exists x; simpl in |- *; unfold g in |- *;
+ split.
+assumption.
+assert (H4 := H _ H3); unfold continuity_pt in H4; unfold continue_in in H4;
+ unfold limit1_in in H4; unfold limit_in in H4; simpl in H4;
+ unfold R_dist in H4; elim (H4 (eps / 2) (H1 eps)); 
+ intros;
+ set
+  (E :=
+   fun zeta:R =>
+     0 < zeta <= M - m /\
+     (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2));
+ assert (H6 : bound E).
+unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *;
+ unfold E in |- *; intros; elim H6; clear H6; intros H6 _; 
+ elim H6; clear H6; intros _ H6; apply H6.
+assert (H7 :  exists x : R, E x).
+elim H5; clear H5; intros; exists (Rmin x0 (M - m)); unfold E in |- *; intros;
+ split.
+split.
+unfold Rmin in |- *; case (Rle_dec x0 (M - m)); intro.
+apply H5.
+apply Rlt_Rminus; apply Hyp.
+apply Rmin_r.
+intros; case (Req_dec x z); intro.
+rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ apply (H1 eps).
+apply H7; split.
+unfold D_x, no_cond in |- *; split; [ trivial | assumption ].
+apply Rlt_le_trans with (Rmin x0 (M - m)); [ apply H8 | apply Rmin_l ].
+assert (H8 := completeness _ H6 H7); elim H8; clear H8; intros;
+ cut (0 < x1 <= M - m).
+intro; elim H8; clear H8; intros; exists (mkposreal _ H8); split.
+intros; cut (exists alp : R, Rabs (z - x) < alp <= x1 /\ E alp).
+intros; elim H11; intros; elim H12; clear H12; intros; unfold E in H13;
+ elim H13; intros; apply H15.
+elim H12; intros; assumption.
+elim (classic (exists alp : R, Rabs (z - x) < alp <= x1 /\ E alp)); intro.
+assumption.
+assert
+ (H12 :=
+  not_ex_all_not _ (fun alp:R => Rabs (z - x) < alp <= x1 /\ E alp) H11);
+ unfold is_lub in p; elim p; intros; cut (is_upper_bound E (Rabs (z - x))).
+intro; assert (H16 := H14 _ H15);
+ elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H16)).
+unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H13;
+ assert (H16 := H13 _ H15); case (Rle_dec x2 (Rabs (z - x))); 
+ intro.
+assumption.
+elim (H12 x2); split; [ split; [ auto with real | assumption ] | assumption ].
+split.
+apply p.
+unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+ rewrite Rabs_R0; simpl in |- *; unfold Rdiv in |- *; 
+ apply Rmult_lt_0_compat; [ apply H8 | apply Rinv_0_lt_compat; prove_sup0 ].
+elim H7; intros; unfold E in H8; elim H8; intros H9 _; elim H9; intros H10 _;
+ unfold is_lub in p; elim p; intros; unfold is_upper_bound in H12;
+ unfold is_upper_bound in H11; split.
+apply Rlt_le_trans with x2; [ assumption | apply (H11 _ H8) ].
+apply H12; intros; unfold E in H13; elim H13; intros; elim H14; intros;
+ assumption.
+unfold family_open_set in |- *; intro; simpl in |- *; elim (classic (X x));
+ intro.
+unfold g in |- *; unfold open_set in |- *; intros; elim H4; clear H4;
+ intros _ H4; elim H4; clear H4; intros; elim H4; clear H4; 
+ intros; unfold neighbourhood in |- *; case (Req_dec x x0); 
+ intro.
+exists (mkposreal _ (H1 x1)); rewrite <- H6; unfold included in |- *; intros;
+ split.
+assumption.
+exists x1; split.
+apply H4.
+split.
+elim H5; intros; apply H8.
+apply H7.
+set (d := x1 / 2 - Rabs (x0 - x)); assert (H7 : 0 < d).
+unfold d in |- *; apply Rlt_Rminus; elim H5; clear H5; intros;
+ unfold disc in H7; apply H7.
+exists (mkposreal _ H7); unfold included in |- *; intros; split.
+assumption.
+exists x1; split.
+apply H4.
+elim H5; intros; split.
+assumption.
+unfold disc in H8; simpl in H8; unfold disc in |- *; simpl in |- *;
+ unfold disc in H10; simpl in H10;
+ apply Rle_lt_trans with (Rabs (x2 - x0) + Rabs (x0 - x)).
+replace (x2 - x) with (x2 - x0 + (x0 - x)); [ apply Rabs_triang | ring ].
+replace (x1 / 2) with (d + Rabs (x0 - x)); [ idtac | unfold d in |- *; ring ].
+do 2 rewrite <- (Rplus_comm (Rabs (x0 - x))); apply Rplus_lt_compat_l;
+ apply H8.
+apply open_set_P6 with (fun _:R => False).
+apply open_set_P4.
+unfold eq_Dom in |- *; unfold included in |- *; intros; split.
+intros; elim H4.
+intros; unfold g in H4; elim H4; clear H4; intros H4 _; elim H3; apply H4.
+elim (H0 _ H3); intros DF H4; unfold covering_finite in H4; elim H4; clear H4;
+ intros; unfold family_finite in H5; unfold domain_finite in H5;
+ unfold covering in H4; simpl in H4; simpl in H5; elim H5; 
+ clear H5; intros l H5; unfold intersection_domain in H5;
+ cut
+  (forall x:R,
+     In x l ->
+      exists del : R,
+       0 < del /\
+       (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\
+       included (g x) (fun z:R => Rabs (z - x) < del / 2)).
+intros;
+ assert
+  (H7 :=
+   Rlist_P1 l
+     (fun x del:R =>
+        0 < del /\
+        (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\
+        included (g x) (fun z:R => Rabs (z - x) < del / 2)) H6); 
+ elim H7; clear H7; intros l' H7; elim H7; clear H7; 
+ intros; set (D := MinRlist l'); cut (0 < D / 2).
+intro; exists (mkposreal _ H9); intros; assert (H13 := H4 _ H10); elim H13;
+ clear H13; intros xi H13; assert (H14 : In xi l).
+unfold g in H13; decompose [and] H13; elim (H5 xi); intros; apply H14; split;
+ assumption.
+elim (pos_Rl_P2 l xi); intros H15 _; elim (H15 H14); intros i H16; elim H16;
+ intros; apply Rle_lt_trans with (Rabs (f0 x - f0 xi) + Rabs (f0 xi - f0 y)).
+replace (f0 x - f0 y) with (f0 x - f0 xi + (f0 xi - f0 y));
+ [ apply Rabs_triang | ring ].
+rewrite (double_var eps); apply Rplus_lt_compat.
+assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20;
+ elim H20; clear H20; intros; apply H20; unfold included in H21;
+ apply Rlt_trans with (pos_Rl l' i / 2).
+apply H21.
+elim H13; clear H13; intros; assumption.
+unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+prove_sup0.
+rewrite Rmult_comm; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; pattern (pos_Rl l' i) at 1 in |- *; rewrite <- Rplus_0_r;
+ rewrite double; apply Rplus_lt_compat_l; apply H19.
+discrR.
+assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20;
+ elim H20; clear H20; intros; rewrite <- Rabs_Ropp; 
+ rewrite Ropp_minus_distr; apply H20; unfold included in H21; 
+ elim H13; intros; assert (H24 := H21 x H22);
+ apply Rle_lt_trans with (Rabs (y - x) + Rabs (x - xi)).
+replace (y - xi) with (y - x + (x - xi)); [ apply Rabs_triang | ring ].
+rewrite (double_var (pos_Rl l' i)); apply Rplus_lt_compat.
+apply Rlt_le_trans with (D / 2).
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H12.
+unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ 2));
+ apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; prove_sup0.
+unfold D in |- *; apply MinRlist_P1; elim (pos_Rl_P2 l' (pos_Rl l' i));
+ intros; apply H26; exists i; split;
+ [ rewrite <- H7; assumption | reflexivity ].
+assumption.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ unfold D in |- *; apply MinRlist_P2; intros; elim (pos_Rl_P2 l' y); intros;
+    elim (H10 H9); intros; elim H12; intros; rewrite H14;
+    rewrite <- H7 in H13; elim (H8 x H13); intros; 
+    apply H15
+ | apply Rinv_0_lt_compat; prove_sup0 ].
+intros; elim (H5 x); intros; elim (H8 H6); intros;
+ set
+  (E :=
+   fun zeta:R =>
+     0 < zeta <= M - m /\
+     (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2));
+ assert (H11 : bound E).
+unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *;
+ unfold E in |- *; intros; elim H11; clear H11; intros H11 _; 
+ elim H11; clear H11; intros _ H11; apply H11.
+assert (H12 :  exists x : R, E x).
+assert (H13 := H _ H9); unfold continuity_pt in H13;
+ unfold continue_in in H13; unfold limit1_in in H13; 
+ unfold limit_in in H13; simpl in H13; unfold R_dist in H13;
+ elim (H13 _ (H1 eps)); intros; elim H12; clear H12; 
+ intros; exists (Rmin x0 (M - m)); unfold E in |- *; 
+ intros; split.
+split;
+ [ unfold Rmin in |- *; case (Rle_dec x0 (M - m)); intro;
+    [ apply H12 | apply Rlt_Rminus; apply Hyp ]
+ | apply Rmin_r ].
+intros; case (Req_dec x z); intro.
+rewrite H16; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+ apply (H1 eps).
+apply H14; split;
+ [ unfold D_x, no_cond in |- *; split; [ trivial | assumption ]
+ | apply Rlt_le_trans with (Rmin x0 (M - m)); [ apply H15 | apply Rmin_l ] ].
+assert (H13 := completeness _ H11 H12); elim H13; clear H13; intros;
+ cut (0 < x0 <= M - m).
+intro; elim H13; clear H13; intros; exists x0; split.
+assumption.
+split.
+intros; cut (exists alp : R, Rabs (z - x) < alp <= x0 /\ E alp).
+intros; elim H16; intros; elim H17; clear H17; intros; unfold E in H18;
+ elim H18; intros; apply H20; elim H17; intros; assumption.
+elim (classic (exists alp : R, Rabs (z - x) < alp <= x0 /\ E alp)); intro.
+assumption.
+assert
+ (H17 :=
+  not_ex_all_not _ (fun alp:R => Rabs (z - x) < alp <= x0 /\ E alp) H16);
+ unfold is_lub in p; elim p; intros; cut (is_upper_bound E (Rabs (z - x))).
+intro; assert (H21 := H19 _ H20);
+ elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H15 H21)).
+unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H18;
+ assert (H21 := H18 _ H20); case (Rle_dec x1 (Rabs (z - x))); 
+ intro.
+assumption.
+elim (H17 x1); split.
+split; [ auto with real | assumption ].
+assumption.
+unfold included, g in |- *; intros; elim H15; intros; elim H17; intros;
+ decompose [and] H18; cut (x0 = x2).
+intro; rewrite H20; apply H22.
+unfold E in p; eapply is_lub_u.
+apply p.
+apply H21.
+elim H12; intros; unfold E in H13; elim H13; intros H14 _; elim H14;
+ intros H15 _; unfold is_lub in p; elim p; intros;
+ unfold is_upper_bound in H16; unfold is_upper_bound in H17; 
+ split.
+apply Rlt_le_trans with x1; [ assumption | apply (H16 _ H13) ].
+apply H17; intros; unfold E in H18; elim H18; intros; elim H19; intros;
+ assumption.
+Qed.
diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v
new file mode 100644
index 00000000..e4cae6c6
--- /dev/null
+++ b/theories/Reals/Rtrigo.v
@@ -0,0 +1,1707 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rtrigo.v,v 1.40.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Export Rtrigo_fun.
+Require Export Rtrigo_def.
+Require Export Rtrigo_alt.
+Require Export Cos_rel.
+Require Export Cos_plus.
+Require Import ZArith_base.
+Require Import Zcomplements.
+Require Import Classical_Prop.
+Open Local Scope nat_scope.
+Open Local Scope R_scope.
+
+(** sin_PI2 is the only remaining axiom **)
+Axiom sin_PI2 : sin (PI / 2) = 1.
+
+(**********)
+Lemma PI_neq0 : PI <> 0.
+red in |- *; intro; assert (H0 := PI_RGT_0); rewrite H in H0;
+ elim (Rlt_irrefl _ H0).
+Qed.
+
+(**********) 
+Lemma cos_minus : forall x y:R, cos (x - y) = cos x * cos y + sin x * sin y.
+intros; unfold Rminus in |- *; rewrite cos_plus.
+rewrite <- cos_sym; rewrite sin_antisym; ring.
+Qed.
+
+(**********)
+Lemma sin2_cos2 : forall x:R, Rsqr (sin x) + Rsqr (cos x) = 1.
+intro; unfold Rsqr in |- *; rewrite Rplus_comm; rewrite <- (cos_minus x x);
+ unfold Rminus in |- *; rewrite Rplus_opp_r; apply cos_0.
+Qed.
+
+Lemma cos2 : forall x:R, Rsqr (cos x) = 1 - Rsqr (sin x).
+intro x; generalize (sin2_cos2 x); intro H1; rewrite <- H1;
+ unfold Rminus in |- *; rewrite <- (Rplus_comm (Rsqr (cos x)));
+ rewrite Rplus_assoc; rewrite Rplus_opp_r; symmetry  in |- *; 
+ apply Rplus_0_r.
+Qed.
+
+(**********)
+Lemma cos_PI2 : cos (PI / 2) = 0.
+apply Rsqr_eq_0; rewrite cos2; rewrite sin_PI2; rewrite Rsqr_1;
+ unfold Rminus in |- *; apply Rplus_opp_r.
+Qed.
+
+(**********)
+Lemma cos_PI : cos PI = -1.
+replace PI with (PI / 2 + PI / 2).
+rewrite cos_plus.
+rewrite sin_PI2; rewrite cos_PI2.
+ring.
+symmetry  in |- *; apply double_var.
+Qed.
+
+Lemma sin_PI : sin PI = 0.
+assert (H := sin2_cos2 PI).
+rewrite cos_PI in H.
+rewrite <- Rsqr_neg in H.
+rewrite Rsqr_1 in H.
+cut (Rsqr (sin PI) = 0).
+intro; apply (Rsqr_eq_0 _ H0).
+apply Rplus_eq_reg_l with 1.
+rewrite Rplus_0_r; rewrite Rplus_comm; exact H.
+Qed.
+
+(**********)
+Lemma neg_cos : forall x:R, cos (x + PI) = - cos x.
+intro x; rewrite cos_plus; rewrite sin_PI; rewrite cos_PI; ring.
+Qed.
+
+(**********)
+Lemma sin_cos : forall x:R, sin x = - cos (PI / 2 + x).
+intro x; rewrite cos_plus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Qed.
+
+(**********)
+Lemma sin_plus : forall x y:R, sin (x + y) = sin x * cos y + cos x * sin y.
+intros.
+rewrite (sin_cos (x + y)).
+replace (PI / 2 + (x + y)) with (PI / 2 + x + y); [ rewrite cos_plus | ring ].
+rewrite (sin_cos (PI / 2 + x)).
+replace (PI / 2 + (PI / 2 + x)) with (x + PI).
+rewrite neg_cos.
+replace (cos (PI / 2 + x)) with (- sin x).
+ring.
+rewrite sin_cos; rewrite Ropp_involutive; reflexivity.
+pattern PI at 1 in |- *; rewrite (double_var PI); ring.
+Qed.
+
+Lemma sin_minus : forall x y:R, sin (x - y) = sin x * cos y - cos x * sin y.
+intros; unfold Rminus in |- *; rewrite sin_plus.
+rewrite <- cos_sym; rewrite sin_antisym; ring.
+Qed.
+
+(**********)
+Definition tan (x:R) : R := sin x / cos x.
+
+Lemma tan_plus :
+ forall x y:R,
+   cos x <> 0 ->
+   cos y <> 0 ->
+   cos (x + y) <> 0 ->
+   1 - tan x * tan y <> 0 ->
+   tan (x + y) = (tan x + tan y) / (1 - tan x * tan y).
+intros; unfold tan in |- *; rewrite sin_plus; rewrite cos_plus;
+ unfold Rdiv in |- *;
+ replace (cos x * cos y - sin x * sin y) with
+  (cos x * cos y * (1 - sin x * / cos x * (sin y * / cos y))).
+rewrite Rinv_mult_distr.
+repeat rewrite <- Rmult_assoc;
+ replace ((sin x * cos y + cos x * sin y) * / (cos x * cos y)) with
+  (sin x * / cos x + sin y * / cos y).
+reflexivity.
+rewrite Rmult_plus_distr_r; rewrite Rinv_mult_distr.
+repeat rewrite Rmult_assoc; repeat rewrite (Rmult_comm (sin x));
+ repeat rewrite <- Rmult_assoc.
+repeat rewrite Rinv_r_simpl_m; [ reflexivity | assumption | assumption ].
+assumption.
+assumption.
+apply prod_neq_R0; assumption.
+assumption.
+unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
+ apply Rplus_eq_compat_l; repeat rewrite Rmult_assoc;
+ rewrite (Rmult_comm (sin x)); rewrite (Rmult_comm (cos y));
+ rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite <- Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; rewrite (Rmult_comm (sin x));
+ rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite Rmult_assoc;
+ apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y)); 
+ rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+apply Rmult_1_r.
+assumption.
+assumption.
+Qed.
+
+(*******************************************************)
+(* Some properties of cos, sin and tan                 *)
+(*******************************************************)
+
+Lemma sin2 : forall x:R, Rsqr (sin x) = 1 - Rsqr (cos x).
+intro x; generalize (cos2 x); intro H1; rewrite H1.
+unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
+ rewrite Rplus_opp_r; rewrite Rplus_0_l; symmetry  in |- *;
+ apply Ropp_involutive.
+Qed.
+
+Lemma sin_2a : forall x:R, sin (2 * x) = 2 * sin x * cos x.
+intro x; rewrite double; rewrite sin_plus.
+rewrite <- (Rmult_comm (sin x)); symmetry  in |- *; rewrite Rmult_assoc;
+ apply double.
+Qed.
+
+Lemma cos_2a : forall x:R, cos (2 * x) = cos x * cos x - sin x * sin x.
+intro x; rewrite double; apply cos_plus.
+Qed.
+
+Lemma cos_2a_cos : forall x:R, cos (2 * x) = 2 * cos x * cos x - 1.
+intro x; rewrite double; unfold Rminus in |- *; rewrite Rmult_assoc;
+ rewrite cos_plus; generalize (sin2_cos2 x); rewrite double; 
+ intro H1; rewrite <- H1; ring_Rsqr.
+Qed.
+
+Lemma cos_2a_sin : forall x:R, cos (2 * x) = 1 - 2 * sin x * sin x.
+intro x; rewrite Rmult_assoc; unfold Rminus in |- *; repeat rewrite double.
+generalize (sin2_cos2 x); intro H1; rewrite <- H1; rewrite cos_plus;
+ ring_Rsqr.
+Qed.
+
+Lemma tan_2a :
+ forall x:R,
+   cos x <> 0 ->
+   cos (2 * x) <> 0 ->
+   1 - tan x * tan x <> 0 -> tan (2 * x) = 2 * tan x / (1 - tan x * tan x).
+repeat rewrite double; intros; repeat rewrite double; rewrite double in H0;
+ apply tan_plus; assumption.
+Qed.
+
+Lemma sin_neg : forall x:R, sin (- x) = - sin x.
+apply sin_antisym.
+Qed.
+
+Lemma cos_neg : forall x:R, cos (- x) = cos x.
+intro; symmetry  in |- *; apply cos_sym.
+Qed.
+
+Lemma tan_0 : tan 0 = 0.
+unfold tan in |- *; rewrite sin_0; rewrite cos_0.
+unfold Rdiv in |- *; apply Rmult_0_l. 
+Qed.
+
+Lemma tan_neg : forall x:R, tan (- x) = - tan x.
+intros x; unfold tan in |- *; rewrite sin_neg; rewrite cos_neg;
+ unfold Rdiv in |- *.
+apply Ropp_mult_distr_l_reverse.
+Qed.
+
+Lemma tan_minus :
+ forall x y:R,
+   cos x <> 0 ->
+   cos y <> 0 ->
+   cos (x - y) <> 0 ->
+   1 + tan x * tan y <> 0 ->
+   tan (x - y) = (tan x - tan y) / (1 + tan x * tan y).
+intros; unfold Rminus in |- *; rewrite tan_plus.
+rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse;
+ rewrite Rmult_opp_opp; reflexivity.
+assumption.
+rewrite cos_neg; assumption.
+assumption.
+rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse;
+ rewrite Rmult_opp_opp; assumption.
+Qed.
+
+Lemma cos_3PI2 : cos (3 * (PI / 2)) = 0.
+replace (3 * (PI / 2)) with (PI + PI / 2).
+rewrite cos_plus; rewrite sin_PI; rewrite cos_PI2; ring.
+pattern PI at 1 in |- *; rewrite (double_var PI).
+ring.
+Qed.
+
+Lemma sin_2PI : sin (2 * PI) = 0.
+rewrite sin_2a; rewrite sin_PI; ring.
+Qed.
+
+Lemma cos_2PI : cos (2 * PI) = 1.
+rewrite cos_2a; rewrite sin_PI; rewrite cos_PI; ring.
+Qed.
+
+Lemma neg_sin : forall x:R, sin (x + PI) = - sin x.
+intro x; rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; ring.
+Qed.
+
+Lemma sin_PI_x : forall x:R, sin (PI - x) = sin x.
+intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI; rewrite Rmult_0_l;
+ unfold Rminus in |- *; rewrite Rplus_0_l; rewrite Ropp_mult_distr_l_reverse;
+ rewrite Ropp_involutive; apply Rmult_1_l.
+Qed.
+
+Lemma sin_period : forall (x:R) (k:nat), sin (x + 2 * INR k * PI) = sin x.
+intros x k; induction  k as [| k Hreck].
+cut (x + 2 * INR 0 * PI = x); [ intro; rewrite H; reflexivity | ring ].
+replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI);
+ [ rewrite sin_plus; rewrite sin_2PI; rewrite cos_2PI; ring; apply Hreck
+ | rewrite S_INR; ring ].
+Qed.
+
+Lemma cos_period : forall (x:R) (k:nat), cos (x + 2 * INR k * PI) = cos x.
+intros x k; induction  k as [| k Hreck].
+cut (x + 2 * INR 0 * PI = x); [ intro; rewrite H; reflexivity | ring ].
+replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI);
+ [ rewrite cos_plus; rewrite sin_2PI; rewrite cos_2PI; ring; apply Hreck
+ | rewrite S_INR; ring ].
+Qed.
+
+Lemma sin_shift : forall x:R, sin (PI / 2 - x) = cos x.
+intro x; rewrite sin_minus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Qed.
+
+Lemma cos_shift : forall x:R, cos (PI / 2 - x) = sin x.
+intro x; rewrite cos_minus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Qed.
+
+Lemma cos_sin : forall x:R, cos x = sin (PI / 2 + x).
+intro x; rewrite sin_plus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Qed.
+
+Lemma PI2_RGT_0 : 0 < PI / 2.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup ].
+Qed. 
+
+Lemma SIN_bound : forall x:R, -1 <= sin x <= 1.
+intro; case (Rle_dec (-1) (sin x)); intro.
+case (Rle_dec (sin x) 1); intro.
+split; assumption.
+cut (1 < sin x).
+intro;
+ generalize
+  (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1)
+     (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); 
+ rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0;
+ generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
+ repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; 
+ rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
+ generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
+ repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); 
+ intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
+auto with real.
+cut (sin x < -1).
+intro; generalize (Ropp_lt_gt_contravar (sin x) (-1) H);
+ rewrite Ropp_involutive; clear H; intro;
+ generalize
+  (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1)
+     (Rlt_le 0 (- sin x) (Rlt_trans 0 1 (- sin x) Rlt_0_1 H)));
+ rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; 
+ rewrite sin2 in H0; unfold Rminus in H0;
+ generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
+ repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; 
+ rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
+ generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
+ repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); 
+ intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
+auto with real.
+Qed.
+
+Lemma COS_bound : forall x:R, -1 <= cos x <= 1.
+intro; rewrite <- sin_shift; apply SIN_bound.
+Qed.
+
+Lemma cos_sin_0 : forall x:R, ~ (cos x = 0 /\ sin x = 0).
+intro; red in |- *; intro; elim H; intros; generalize (sin2_cos2 x); intro;
+ rewrite H0 in H2; rewrite H1 in H2; repeat rewrite Rsqr_0 in H2;
+ rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro; 
+ rewrite <- H2 in H3; elim (Rlt_irrefl 0 H3).
+Qed.
+  
+Lemma cos_sin_0_var : forall x:R, cos x <> 0 \/ sin x <> 0.
+intro; apply not_and_or; apply cos_sin_0.
+Qed.
+
+(*****************************************************************)
+(* Using series definitions of cos and sin                       *)
+(*****************************************************************)
+
+Definition sin_lb (a:R) : R := sin_approx a 3.
+Definition sin_ub (a:R) : R := sin_approx a 4.
+Definition cos_lb (a:R) : R := cos_approx a 3.
+Definition cos_ub (a:R) : R := cos_approx a 4.
+
+Lemma sin_lb_gt_0 : forall a:R, 0 < a -> a <= PI / 2 -> 0 < sin_lb a.
+intros.
+unfold sin_lb in |- *; unfold sin_approx in |- *; unfold sin_term in |- *.
+set (Un := fun i:nat => a ^ (2 * i + 1) / INR (fact (2 * i + 1))).
+replace
+ (sum_f_R0
+    (fun i:nat => (-1) ^ i * (a ^ (2 * i + 1) / INR (fact (2 * i + 1)))) 3)
+ with (sum_f_R0 (fun i:nat => (-1) ^ i * Un i) 3);
+ [ idtac | apply sum_eq; intros; unfold Un in |- *; reflexivity ].
+cut (forall n:nat, Un (S n) < Un n).
+intro; simpl in |- *.
+repeat rewrite Rmult_1_l; repeat rewrite Rmult_1_r;
+ replace (-1 * Un 1%nat) with (- Un 1%nat); [ idtac | ring ];
+ replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ];
+ replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat); 
+ [ idtac | ring ];
+ replace (Un 0%nat + - Un 1%nat + Un 2%nat + - Un 3%nat) with
+  (Un 0%nat - Un 1%nat + (Un 2%nat - Un 3%nat)); [ idtac | ring ].
+apply Rplus_lt_0_compat.
+unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 1%nat);
+ rewrite Rplus_0_r; rewrite (Rplus_comm (Un 1%nat)); 
+ rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
+ apply H1.
+unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 3%nat);
+ rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat)); 
+ rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
+ apply H1.
+intro; unfold Un in |- *.
+cut ((2 * S n + 1)%nat = (2 * n + 1 + 2)%nat).
+intro; rewrite H1.
+rewrite pow_add; unfold Rdiv in |- *; rewrite Rmult_assoc;
+ apply Rmult_lt_compat_l.
+apply pow_lt; assumption.
+rewrite <- H1; apply Rmult_lt_reg_l with (INR (fact (2 * n + 1))).
+apply lt_INR_0; apply neq_O_lt.
+assert (H2 := fact_neq_0 (2 * n + 1)).
+red in |- *; intro; elim H2; symmetry  in |- *; assumption.
+rewrite <- Rinv_r_sym.
+apply Rmult_lt_reg_l with (INR (fact (2 * S n + 1))).
+apply lt_INR_0; apply neq_O_lt.
+assert (H2 := fact_neq_0 (2 * S n + 1)).
+red in |- *; intro; elim H2; symmetry  in |- *; assumption.
+rewrite (Rmult_comm (INR (fact (2 * S n + 1)))); repeat rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+do 2 rewrite Rmult_1_r; apply Rle_lt_trans with (INR (fact (2 * n + 1)) * 4).
+apply Rmult_le_compat_l.
+replace 0 with (INR 0); [ idtac | reflexivity ]; apply le_INR; apply le_O_n.
+simpl in |- *; rewrite Rmult_1_r; replace 4 with (Rsqr 2);
+ [ idtac | ring_Rsqr ]; replace (a * a) with (Rsqr a);
+ [ idtac | reflexivity ]; apply Rsqr_incr_1.
+apply Rle_trans with (PI / 2);
+ [ assumption
+ | unfold Rdiv in |- *; apply Rmult_le_reg_l with 2;
+    [ prove_sup0
+    | rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m;
+       [ replace 4 with 4; [ apply PI_4 | ring ] | discrR ] ] ].
+left; assumption.
+left; prove_sup0.
+rewrite H1; replace (2 * n + 1 + 2)%nat with (S (S (2 * n + 1))).
+do 2 rewrite fact_simpl; do 2 rewrite mult_INR.
+repeat rewrite <- Rmult_assoc.
+rewrite <- (Rmult_comm (INR (fact (2 * n + 1)))).
+rewrite Rmult_assoc.
+apply Rmult_lt_compat_l.
+apply lt_INR_0; apply neq_O_lt.
+assert (H2 := fact_neq_0 (2 * n + 1)).
+red in |- *; intro; elim H2; symmetry  in |- *; assumption.
+do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; set (x := INR n);
+ unfold INR in |- *.
+replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6);
+ [ idtac | ring ].
+apply Rplus_lt_reg_r with (-4); rewrite Rplus_opp_l;
+ replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2);
+ [ idtac | ring ].
+apply Rplus_le_lt_0_compat.
+cut (0 <= x).
+intro; apply Rplus_le_le_0_compat; repeat apply Rmult_le_pos;
+ assumption || left; prove_sup.
+unfold x in |- *; replace 0 with (INR 0);
+ [ apply le_INR; apply le_O_n | reflexivity ].
+prove_sup0.
+apply INR_eq; do 2 rewrite S_INR; do 3 rewrite plus_INR; rewrite mult_INR;
+ repeat rewrite S_INR; ring.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_eq; do 3 rewrite plus_INR; do 2 rewrite mult_INR;
+ repeat rewrite S_INR; ring.
+Qed.
+
+Lemma SIN : forall a:R, 0 <= a -> a <= PI -> sin_lb a <= sin a <= sin_ub a.
+intros; unfold sin_lb, sin_ub in |- *; apply (sin_bound a 1 H H0).
+Qed.
+
+Lemma COS :
+ forall a:R, - PI / 2 <= a -> a <= PI / 2 -> cos_lb a <= cos a <= cos_ub a.
+intros; unfold cos_lb, cos_ub in |- *; apply (cos_bound a 1 H H0).
+Qed.
+
+(**********)
+Lemma _PI2_RLT_0 : - (PI / 2) < 0.
+rewrite <- Ropp_0; apply Ropp_lt_contravar; apply PI2_RGT_0.
+Qed.
+
+Lemma PI4_RLT_PI2 : PI / 4 < PI / 2.
+unfold Rdiv in |- *; apply Rmult_lt_compat_l.
+apply PI_RGT_0.
+apply Rinv_lt_contravar.
+apply Rmult_lt_0_compat; prove_sup0.
+pattern 2 at 1 in |- *; rewrite <- Rplus_0_r.
+replace 4 with (2 + 2); [ apply Rplus_lt_compat_l; prove_sup0 | ring ].
+Qed.
+
+Lemma PI2_Rlt_PI : PI / 2 < PI.
+unfold Rdiv in |- *; pattern PI at 2 in |- *; rewrite <- Rmult_1_r.
+apply Rmult_lt_compat_l.
+apply PI_RGT_0.
+pattern 1 at 3 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar.
+rewrite Rmult_1_l; prove_sup0.
+pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+ apply Rlt_0_1.
+Qed.
+
+(********************************************)
+(* Increasing and decreasing of COS and SIN *)
+(********************************************)
+Theorem sin_gt_0 : forall x:R, 0 < x -> x < PI -> 0 < sin x.
+intros; elim (SIN x (Rlt_le 0 x H) (Rlt_le x PI H0)); intros H1 _;
+ case (Rtotal_order x (PI / 2)); intro H2.
+apply Rlt_le_trans with (sin_lb x).
+apply sin_lb_gt_0; [ assumption | left; assumption ].
+assumption.
+elim H2; intro H3.
+rewrite H3; rewrite sin_PI2; apply Rlt_0_1.
+rewrite <- sin_PI_x; generalize (Ropp_gt_lt_contravar x (PI / 2) H3);
+ intro H4; generalize (Rplus_lt_compat_l PI (- x) (- (PI / 2)) H4).
+replace (PI + - x) with (PI - x).
+replace (PI + - (PI / 2)) with (PI / 2).
+intro H5; generalize (Ropp_lt_gt_contravar x PI H0); intro H6;
+ change (- PI < - x) in H6; generalize (Rplus_lt_compat_l PI (- PI) (- x) H6).
+rewrite Rplus_opp_r.
+replace (PI + - x) with (PI - x).
+intro H7;
+ elim
+  (SIN (PI - x) (Rlt_le 0 (PI - x) H7)
+     (Rlt_le (PI - x) PI (Rlt_trans (PI - x) (PI / 2) PI H5 PI2_Rlt_PI)));
+ intros H8 _;
+ generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5)); 
+ intro H9; apply (Rlt_le_trans 0 (sin_lb (PI - x)) (sin (PI - x)) H9 H8).
+reflexivity.
+pattern PI at 2 in |- *; rewrite double_var; ring.
+reflexivity.
+Qed.
+
+Theorem cos_gt_0 : forall x:R, - (PI / 2) < x -> x < PI / 2 -> 0 < cos x.
+intros; rewrite cos_sin;
+ generalize (Rplus_lt_compat_l (PI / 2) (- (PI / 2)) x H).
+rewrite Rplus_opp_r; intro H1;
+ generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0); 
+ rewrite <- double_var; intro H2; apply (sin_gt_0 (PI / 2 + x) H1 H2).
+Qed.
+
+Lemma sin_ge_0 : forall x:R, 0 <= x -> x <= PI -> 0 <= sin x.
+intros x H1 H2; elim H1; intro H3;
+ [ elim H2; intro H4;
+    [ left; apply (sin_gt_0 x H3 H4)
+    | rewrite H4; right; symmetry  in |- *; apply sin_PI ]
+ | rewrite <- H3; right; symmetry  in |- *; apply sin_0 ].
+Qed.
+
+Lemma cos_ge_0 : forall x:R, - (PI / 2) <= x -> x <= PI / 2 -> 0 <= cos x.
+intros x H1 H2; elim H1; intro H3;
+ [ elim H2; intro H4;
+    [ left; apply (cos_gt_0 x H3 H4)
+    | rewrite H4; right; symmetry  in |- *; apply cos_PI2 ]
+ | rewrite <- H3; rewrite cos_neg; right; symmetry  in |- *; apply cos_PI2 ].
+Qed.
+
+Lemma sin_le_0 : forall x:R, PI <= x -> x <= 2 * PI -> sin x <= 0.
+intros x H1 H2; apply Rge_le; rewrite <- Ropp_0;
+ rewrite <- (Ropp_involutive (sin x)); apply Ropp_le_ge_contravar;
+ rewrite <- neg_sin; replace (x + PI) with (x - PI + 2 * INR 1 * PI);
+ [ rewrite (sin_period (x - PI) 1); apply sin_ge_0;
+    [ replace (x - PI) with (x + - PI);
+       [ rewrite Rplus_comm; replace 0 with (- PI + PI);
+          [ apply Rplus_le_compat_l; assumption | ring ]
+       | ring ]
+    | replace (x - PI) with (x + - PI); rewrite Rplus_comm;
+       [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI);
+          [ apply Rplus_le_compat_l; assumption | ring ]
+       | ring ] ]
+ | unfold INR in |- *; ring ].
+Qed.
+
+Lemma cos_le_0 : forall x:R, PI / 2 <= x -> x <= 3 * (PI / 2) -> cos x <= 0.
+intros x H1 H2; apply Rge_le; rewrite <- Ropp_0;
+ rewrite <- (Ropp_involutive (cos x)); apply Ropp_le_ge_contravar;
+ rewrite <- neg_cos; replace (x + PI) with (x - PI + 2 * INR 1 * PI).
+rewrite cos_period; apply cos_ge_0.
+replace (- (PI / 2)) with (- PI + PI / 2).
+unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_le_compat_l;
+ assumption.
+pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+ ring.
+unfold Rminus in |- *; rewrite Rplus_comm;
+ replace (PI / 2) with (- PI + 3 * (PI / 2)).
+apply Rplus_le_compat_l; assumption.
+pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+ ring. 
+unfold INR in |- *; ring.
+Qed.
+
+Lemma sin_lt_0 : forall x:R, PI < x -> x < 2 * PI -> sin x < 0.
+intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (sin x));
+ apply Ropp_lt_gt_contravar; rewrite <- neg_sin;
+ replace (x + PI) with (x - PI + 2 * INR 1 * PI);
+ [ rewrite (sin_period (x - PI) 1); apply sin_gt_0;
+    [ replace (x - PI) with (x + - PI);
+       [ rewrite Rplus_comm; replace 0 with (- PI + PI);
+          [ apply Rplus_lt_compat_l; assumption | ring ]
+       | ring ]
+    | replace (x - PI) with (x + - PI); rewrite Rplus_comm;
+       [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI);
+          [ apply Rplus_lt_compat_l; assumption | ring ]
+       | ring ] ]
+ | unfold INR in |- *; ring ].
+Qed.
+
+Lemma sin_lt_0_var : forall x:R, - PI < x -> x < 0 -> sin x < 0.
+intros; generalize (Rplus_lt_compat_l (2 * PI) (- PI) x H);
+ replace (2 * PI + - PI) with PI;
+ [ intro H1; rewrite Rplus_comm in H1;
+    generalize (Rplus_lt_compat_l (2 * PI) x 0 H0); 
+    intro H2; rewrite (Rplus_comm (2 * PI)) in H2;
+    rewrite <- (Rplus_comm 0) in H2; rewrite Rplus_0_l in H2;
+    rewrite <- (sin_period x 1); unfold INR in |- *;
+    replace (2 * 1 * PI) with (2 * PI);
+    [ apply (sin_lt_0 (x + 2 * PI) H1 H2) | ring ]
+ | ring ].
+Qed.
+
+Lemma cos_lt_0 : forall x:R, PI / 2 < x -> x < 3 * (PI / 2) -> cos x < 0.
+intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (cos x));
+ apply Ropp_lt_gt_contravar; rewrite <- neg_cos;
+ replace (x + PI) with (x - PI + 2 * INR 1 * PI).
+rewrite cos_period; apply cos_gt_0.
+replace (- (PI / 2)) with (- PI + PI / 2).
+unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_lt_compat_l;
+ assumption.
+pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+ ring. 
+unfold Rminus in |- *; rewrite Rplus_comm;
+ replace (PI / 2) with (- PI + 3 * (PI / 2)).
+apply Rplus_lt_compat_l; assumption.
+pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+ ring. 
+unfold INR in |- *; ring.
+Qed.
+
+Lemma tan_gt_0 : forall x:R, 0 < x -> x < PI / 2 -> 0 < tan x.
+intros x H1 H2; unfold tan in |- *; generalize _PI2_RLT_0;
+ generalize (Rlt_trans 0 x (PI / 2) H1 H2); intros;
+ generalize (Rlt_trans (- (PI / 2)) 0 x H0 H1); intro H5;
+ generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI); 
+ intro H7; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply sin_gt_0; assumption.
+apply Rinv_0_lt_compat; apply cos_gt_0; assumption.
+Qed.
+
+Lemma tan_lt_0 : forall x:R, - (PI / 2) < x -> x < 0 -> tan x < 0.
+intros x H1 H2; unfold tan in |- *;
+ generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0)); 
+ intro H3; rewrite <- Ropp_0;
+ replace (sin x / cos x) with (- (- sin x / cos x)).
+rewrite <- sin_neg; apply Ropp_gt_lt_contravar;
+ change (0 < sin (- x) / cos x) in |- *; unfold Rdiv in |- *;
+ apply Rmult_lt_0_compat.
+apply sin_gt_0.
+rewrite <- Ropp_0; apply Ropp_gt_lt_contravar; assumption.
+apply Rlt_trans with (PI / 2).
+rewrite <- (Ropp_involutive (PI / 2)); apply Ropp_gt_lt_contravar; assumption.
+apply PI2_Rlt_PI.
+apply Rinv_0_lt_compat; assumption.
+unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma cos_ge_0_3PI2 :
+ forall x:R, 3 * (PI / 2) <= x -> x <= 2 * PI -> 0 <= cos x.
+intros; rewrite <- cos_neg; rewrite <- (cos_period (- x) 1);
+ unfold INR in |- *; replace (- x + 2 * 1 * PI) with (2 * PI - x).
+generalize (Ropp_le_ge_contravar x (2 * PI) H0); intro H1;
+ generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1; 
+ intro H1; generalize (Rplus_le_compat_l (2 * PI) (- (2 * PI)) (- x) H1).
+rewrite Rplus_opp_r. 
+intro H2; generalize (Ropp_le_ge_contravar (3 * (PI / 2)) x H); intro H3;
+ generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3; 
+ intro H3;
+ generalize (Rplus_le_compat_l (2 * PI) (- x) (- (3 * (PI / 2))) H3).
+replace (2 * PI + - (3 * (PI / 2))) with (PI / 2).
+intro H4;
+ apply
+  (cos_ge_0 (2 * PI - x)
+     (Rlt_le (- (PI / 2)) (2 * PI - x)
+        (Rlt_le_trans (- (PI / 2)) 0 (2 * PI - x) _PI2_RLT_0 H2)) H4).
+rewrite double; pattern PI at 2 3 in |- *; rewrite double_var; ring.
+ring.
+Qed.
+
+Lemma form1 :
+ forall p q:R, cos p + cos q = 2 * cos ((p - q) / 2) * cos ((p + q) / 2).
+intros p q; pattern p at 1 in |- *;
+ replace p with ((p - q) / 2 + (p + q) / 2).
+rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2).
+rewrite cos_plus; rewrite cos_minus; ring.
+pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma form2 :
+ forall p q:R, cos p - cos q = -2 * sin ((p - q) / 2) * sin ((p + q) / 2).
+intros p q; pattern p at 1 in |- *;
+ replace p with ((p - q) / 2 + (p + q) / 2).
+rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2).
+rewrite cos_plus; rewrite cos_minus; ring.
+pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma form3 :
+ forall p q:R, sin p + sin q = 2 * cos ((p - q) / 2) * sin ((p + q) / 2).
+intros p q; pattern p at 1 in |- *;
+ replace p with ((p - q) / 2 + (p + q) / 2).
+pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2).
+rewrite sin_plus; rewrite sin_minus; ring.
+pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma form4 :
+ forall p q:R, sin p - sin q = 2 * cos ((p + q) / 2) * sin ((p - q) / 2).
+intros p q; pattern p at 1 in |- *;
+ replace p with ((p - q) / 2 + (p + q) / 2).
+pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2).
+rewrite sin_plus; rewrite sin_minus; ring.
+pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+
+Qed.
+
+Lemma sin_increasing_0 :
+ forall x y:R,
+   - (PI / 2) <= x ->
+   x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x < sin y -> x < y.
+intros; cut (sin ((x - y) / 2) < 0).
+intro H4; case (Rtotal_order ((x - y) / 2) 0); intro H5.
+assert (Hyp : 0 < 2).
+prove_sup0.
+generalize (Rmult_lt_compat_l 2 ((x - y) / 2) 0 Hyp H5).
+unfold Rdiv in |- *.
+rewrite <- Rmult_assoc.
+rewrite Rinv_r_simpl_m.
+rewrite Rmult_0_r.
+clear H5; intro H5; apply Rminus_lt; assumption.
+discrR.
+elim H5; intro H6.
+rewrite H6 in H4; rewrite sin_0 in H4; elim (Rlt_irrefl 0 H4).
+change (0 < (x - y) / 2) in H6;
+ generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1).
+rewrite Ropp_involutive.
+intro H7; generalize (Rge_le (PI / 2) (- y) H7); clear H7; intro H7;
+ generalize (Rplus_le_compat x (PI / 2) (- y) (PI / 2) H0 H7).
+rewrite <- double_var.
+intro H8.
+assert (Hyp : 0 < 2).
+prove_sup0.
+generalize
+ (Rmult_le_compat_l (/ 2) (x - y) PI
+    (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H8).
+repeat rewrite (Rmult_comm (/ 2)). 
+intro H9;
+ generalize
+  (sin_gt_0 ((x - y) / 2) H6
+     (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI)); 
+ intro H10;
+ elim
+  (Rlt_irrefl (sin ((x - y) / 2))
+     (Rlt_trans (sin ((x - y) / 2)) 0 (sin ((x - y) / 2)) H4 H10)).
+generalize (Rlt_minus (sin x) (sin y) H3); clear H3; intro H3;
+ rewrite form4 in H3;
+ generalize (Rplus_le_compat x (PI / 2) y (PI / 2) H0 H2).
+rewrite <- double_var.
+assert (Hyp : 0 < 2).
+prove_sup0.
+intro H4;
+ generalize
+  (Rmult_le_compat_l (/ 2) (x + y) PI
+     (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H4).
+repeat rewrite (Rmult_comm (/ 2)). 
+clear H4; intro H4;
+ generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) y H H1);
+ replace (- (PI / 2) + - (PI / 2)) with (- PI).
+intro H5;
+ generalize
+  (Rmult_le_compat_l (/ 2) (- PI) (x + y)
+     (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H5).
+replace (/ 2 * (x + y)) with ((x + y) / 2).
+replace (/ 2 * - PI) with (- (PI / 2)).
+clear H5; intro H5; elim H4; intro H40.
+elim H5; intro H50.
+generalize (cos_gt_0 ((x + y) / 2) H50 H40); intro H6;
+ generalize (Rmult_lt_compat_l 2 0 (cos ((x + y) / 2)) Hyp H6).
+rewrite Rmult_0_r. 
+clear H6; intro H6; case (Rcase_abs (sin ((x - y) / 2))); intro H7.
+assumption.
+generalize (Rge_le (sin ((x - y) / 2)) 0 H7); clear H7; intro H7;
+ generalize
+  (Rmult_le_pos (2 * cos ((x + y) / 2)) (sin ((x - y) / 2))
+     (Rlt_le 0 (2 * cos ((x + y) / 2)) H6) H7); intro H8;
+ generalize
+  (Rle_lt_trans 0 (2 * cos ((x + y) / 2) * sin ((x - y) / 2)) 0 H8 H3);
+ intro H9; elim (Rlt_irrefl 0 H9).
+rewrite <- H50 in H3; rewrite cos_neg in H3; rewrite cos_PI2 in H3;
+ rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3; 
+ elim (Rlt_irrefl 0 H3).
+unfold Rdiv in H3.
+rewrite H40 in H3; assert (H50 := cos_PI2); unfold Rdiv in H50;
+ rewrite H50 in H3; rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3;
+ elim (Rlt_irrefl 0 H3).
+unfold Rdiv in |- *.
+rewrite <- Ropp_mult_distr_l_reverse.
+apply Rmult_comm.
+unfold Rdiv in |- *; apply Rmult_comm.
+pattern PI at 1 in |- *; rewrite double_var.
+rewrite Ropp_plus_distr.
+reflexivity.
+Qed.
+
+Lemma sin_increasing_1 :
+ forall x y:R,
+   - (PI / 2) <= x ->
+   x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x < y -> sin x < sin y.
+intros; generalize (Rplus_lt_compat_l x x y H3); intro H4;
+ generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) x H H);
+ replace (- (PI / 2) + - (PI / 2)) with (- PI).
+assert (Hyp : 0 < 2).
+prove_sup0.
+intro H5; generalize (Rle_lt_trans (- PI) (x + x) (x + y) H5 H4); intro H6;
+ generalize
+  (Rmult_lt_compat_l (/ 2) (- PI) (x + y) (Rinv_0_lt_compat 2 Hyp) H6);
+ replace (/ 2 * - PI) with (- (PI / 2)).
+replace (/ 2 * (x + y)) with ((x + y) / 2).
+clear H4 H5 H6; intro H4; generalize (Rplus_lt_compat_l y x y H3); intro H5;
+ rewrite Rplus_comm in H5;
+ generalize (Rplus_le_compat y (PI / 2) y (PI / 2) H2 H2).
+rewrite <- double_var.
+intro H6; generalize (Rlt_le_trans (x + y) (y + y) PI H5 H6); intro H7;
+ generalize (Rmult_lt_compat_l (/ 2) (x + y) PI (Rinv_0_lt_compat 2 Hyp) H7);
+ replace (/ 2 * PI) with (PI / 2).
+replace (/ 2 * (x + y)) with ((x + y) / 2).
+clear H5 H6 H7; intro H5; generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1);
+ rewrite Ropp_involutive; clear H1; intro H1;
+ generalize (Rge_le (PI / 2) (- y) H1); clear H1; intro H1;
+ generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2; 
+ intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2); 
+ clear H2; intro H2; generalize (Rplus_lt_compat_l (- y) x y H3);
+ replace (- y + x) with (x - y).
+rewrite Rplus_opp_l.
+intro H6;
+ generalize (Rmult_lt_compat_l (/ 2) (x - y) 0 (Rinv_0_lt_compat 2 Hyp) H6);
+ rewrite Rmult_0_r; replace (/ 2 * (x - y)) with ((x - y) / 2).
+clear H6; intro H6;
+ generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) (- y) H H2);
+ replace (- (PI / 2) + - (PI / 2)) with (- PI).
+replace (x + - y) with (x - y).
+intro H7;
+ generalize
+  (Rmult_le_compat_l (/ 2) (- PI) (x - y)
+     (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H7);
+ replace (/ 2 * - PI) with (- (PI / 2)).
+replace (/ 2 * (x - y)) with ((x - y) / 2).
+clear H7; intro H7; clear H H0 H1 H2; apply Rminus_lt; rewrite form4;
+ generalize (cos_gt_0 ((x + y) / 2) H4 H5); intro H8;
+ generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8); 
+ clear H8; intro H8; cut (- PI < - (PI / 2)).
+intro H9;
+ generalize
+  (sin_lt_0_var ((x - y) / 2)
+     (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6); 
+ intro H10;
+ generalize
+  (Rmult_lt_gt_compat_neg_l (sin ((x - y) / 2)) 0 (
+     2 * cos ((x + y) / 2)) H10 H8); intro H11; rewrite Rmult_0_r in H11;
+ rewrite Rmult_comm; assumption.
+apply Ropp_lt_gt_contravar; apply PI2_Rlt_PI.
+unfold Rdiv in |- *; apply Rmult_comm.
+unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_comm.
+reflexivity.
+pattern PI at 1 in |- *; rewrite double_var.
+rewrite Ropp_plus_distr.
+reflexivity.
+unfold Rdiv in |- *; apply Rmult_comm.
+unfold Rminus in |- *; apply Rplus_comm.
+unfold Rdiv in |- *; apply Rmult_comm.
+unfold Rdiv in |- *; apply Rmult_comm.
+unfold Rdiv in |- *; apply Rmult_comm.
+unfold Rdiv in |- *.
+rewrite <- Ropp_mult_distr_l_reverse.
+apply Rmult_comm.
+pattern PI at 1 in |- *; rewrite double_var.
+rewrite Ropp_plus_distr.
+reflexivity.
+Qed.
+
+Lemma sin_decreasing_0 :
+ forall x y:R,
+   x <= 3 * (PI / 2) ->
+   PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x < sin y -> y < x.
+intros; rewrite <- (sin_PI_x x) in H3; rewrite <- (sin_PI_x y) in H3;
+ generalize (Ropp_lt_gt_contravar (sin (PI - x)) (sin (PI - y)) H3);
+ repeat rewrite <- sin_neg;
+ generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H);
+ generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0);
+ generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1);
+ generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2);
+ replace (- PI + x) with (x - PI).
+replace (- PI + PI / 2) with (- (PI / 2)).
+replace (- PI + y) with (y - PI).
+replace (- PI + 3 * (PI / 2)) with (PI / 2).
+replace (- (PI - x)) with (x - PI).
+replace (- (PI - y)) with (y - PI).
+intros; change (sin (y - PI) < sin (x - PI)) in H8;
+ apply Rplus_lt_reg_r with (- PI); rewrite Rplus_comm;
+ replace (y + - PI) with (y - PI).
+rewrite Rplus_comm; replace (x + - PI) with (x - PI).
+apply (sin_increasing_0 (y - PI) (x - PI) H4 H5 H6 H7 H8).
+reflexivity.
+reflexivity.
+unfold Rminus in |- *; rewrite Ropp_plus_distr.
+rewrite Ropp_involutive.
+apply Rplus_comm.
+unfold Rminus in |- *; rewrite Ropp_plus_distr.
+rewrite Ropp_involutive.
+apply Rplus_comm.
+pattern PI at 2 in |- *; rewrite double_var.
+rewrite Ropp_plus_distr.
+ring.
+unfold Rminus in |- *; apply Rplus_comm.
+pattern PI at 2 in |- *; rewrite double_var.
+rewrite Ropp_plus_distr.
+ring.
+unfold Rminus in |- *; apply Rplus_comm.
+Qed.
+
+Lemma sin_decreasing_1 :
+ forall x y:R,
+   x <= 3 * (PI / 2) ->
+   PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> x < y -> sin y < sin x.
+intros; rewrite <- (sin_PI_x x); rewrite <- (sin_PI_x y);
+ generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H);
+ generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0);
+ generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1);
+ generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2);
+ generalize (Rplus_lt_compat_l (- PI) x y H3);
+ replace (- PI + PI / 2) with (- (PI / 2)).
+replace (- PI + y) with (y - PI).
+replace (- PI + 3 * (PI / 2)) with (PI / 2).
+replace (- PI + x) with (x - PI).
+intros; apply Ropp_lt_cancel; repeat rewrite <- sin_neg;
+ replace (- (PI - x)) with (x - PI).
+replace (- (PI - y)) with (y - PI).
+apply (sin_increasing_1 (x - PI) (y - PI) H7 H8 H5 H6 H4).
+unfold Rminus in |- *; rewrite Ropp_plus_distr.
+rewrite Ropp_involutive.
+apply Rplus_comm.
+unfold Rminus in |- *; rewrite Ropp_plus_distr.
+rewrite Ropp_involutive.
+apply Rplus_comm.
+unfold Rminus in |- *; apply Rplus_comm.
+pattern PI at 2 in |- *; rewrite double_var; ring.
+unfold Rminus in |- *; apply Rplus_comm.
+pattern PI at 2 in |- *; rewrite double_var; ring.
+Qed.
+
+Lemma cos_increasing_0 :
+ forall x y:R,
+   PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x < cos y -> x < y.
+intros x y H1 H2 H3 H4; rewrite <- (cos_neg x); rewrite <- (cos_neg y);
+ rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1);
+ unfold INR in |- *;
+ replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))).
+replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))).
+repeat rewrite cos_shift; intro H5;
+ generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1);
+ generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2);
+ generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3);
+ generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4).
+replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
+replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
+replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
+replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
+clear H1 H2 H3 H4; intros H1 H2 H3 H4;
+ apply Rplus_lt_reg_r with (-3 * (PI / 2));
+ replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
+replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
+apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5).
+unfold Rminus in |- *.
+rewrite Ropp_mult_distr_l_reverse. 
+apply Rplus_comm. 
+unfold Rminus in |- *.
+rewrite Ropp_mult_distr_l_reverse. 
+apply Rplus_comm. 
+pattern PI at 3 in |- *; rewrite double_var.
+ring.
+rewrite double; pattern PI at 3 4 in |- *; rewrite double_var.
+ring.
+unfold Rminus in |- *.
+rewrite Ropp_mult_distr_l_reverse. 
+apply Rplus_comm. 
+unfold Rminus in |- *.
+rewrite Ropp_mult_distr_l_reverse. 
+apply Rplus_comm. 
+rewrite Rmult_1_r.
+rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+ring.
+rewrite Rmult_1_r.
+rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+ring.
+Qed.
+
+Lemma cos_increasing_1 :
+ forall x y:R,
+   PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x < y -> cos x < cos y.
+intros x y H1 H2 H3 H4 H5;
+ generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1);
+ generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2);
+ generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3);
+ generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4);
+ generalize (Rplus_lt_compat_l (-3 * (PI / 2)) x y H5);
+ rewrite <- (cos_neg x); rewrite <- (cos_neg y);
+ rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1);
+ unfold INR in |- *; replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
+replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
+replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
+replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
+clear H1 H2 H3 H4 H5; intros H1 H2 H3 H4 H5;
+ replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))).
+replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))).
+repeat rewrite cos_shift;
+ apply
+  (sin_increasing_1 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H5 H4 H3 H2 H1).
+rewrite Rmult_1_r.
+rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+ring.
+rewrite Rmult_1_r.
+rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+ring.
+rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+ring.
+pattern PI at 3 in |- *; rewrite double_var; ring.
+unfold Rminus in |- *.
+rewrite <- Ropp_mult_distr_l_reverse.
+apply Rplus_comm.
+unfold Rminus in |- *.
+rewrite <- Ropp_mult_distr_l_reverse.
+apply Rplus_comm.
+Qed.
+
+Lemma cos_decreasing_0 :
+ forall x y:R,
+   0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x < cos y -> y < x.
+intros; generalize (Ropp_lt_gt_contravar (cos x) (cos y) H3);
+ repeat rewrite <- neg_cos; intro H4;
+ change (cos (y + PI) < cos (x + PI)) in H4; rewrite (Rplus_comm x) in H4;
+ rewrite (Rplus_comm y) in H4; generalize (Rplus_le_compat_l PI 0 x H);
+ generalize (Rplus_le_compat_l PI x PI H0);
+ generalize (Rplus_le_compat_l PI 0 y H1);
+ generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r.
+rewrite <- double.
+clear H H0 H1 H2 H3; intros; apply Rplus_lt_reg_r with PI;
+ apply (cos_increasing_0 (PI + y) (PI + x) H0 H H2 H1 H4).
+Qed.
+
+Lemma cos_decreasing_1 :
+ forall x y:R,
+   0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x < y -> cos y < cos x.
+intros; apply Ropp_lt_cancel; repeat rewrite <- neg_cos;
+ rewrite (Rplus_comm x); rewrite (Rplus_comm y);
+ generalize (Rplus_le_compat_l PI 0 x H);
+ generalize (Rplus_le_compat_l PI x PI H0);
+ generalize (Rplus_le_compat_l PI 0 y H1);
+ generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r.
+rewrite <- double.
+generalize (Rplus_lt_compat_l PI x y H3); clear H H0 H1 H2 H3; intros;
+ apply (cos_increasing_1 (PI + x) (PI + y) H3 H2 H1 H0 H).
+Qed.
+
+Lemma tan_diff :
+ forall x y:R,
+   cos x <> 0 -> cos y <> 0 -> tan x - tan y = sin (x - y) / (cos x * cos y).
+intros; unfold tan in |- *; rewrite sin_minus.
+unfold Rdiv in |- *. 
+unfold Rminus in |- *.
+rewrite Rmult_plus_distr_r.
+rewrite Rinv_mult_distr.
+repeat rewrite (Rmult_comm (sin x)).
+repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm (cos y)).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+rewrite (Rmult_comm (sin x)).
+apply Rplus_eq_compat_l.
+rewrite <- Ropp_mult_distr_l_reverse.
+rewrite <- Ropp_mult_distr_r_reverse.
+rewrite (Rmult_comm (/ cos x)).
+repeat rewrite Rmult_assoc.
+rewrite (Rmult_comm (cos x)).
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+reflexivity.
+assumption.
+assumption.
+assumption.
+assumption.
+Qed.
+
+Lemma tan_increasing_0 :
+ forall x y:R,
+   - (PI / 4) <= x ->
+   x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x < tan y -> x < y.
+intros; generalize PI4_RLT_PI2; intro H4;
+ generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); 
+ intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
+ generalize
+  (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+     (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1;
+ generalize
+  (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+     (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2;
+ generalize
+  (sym_not_eq
+     (Rlt_not_eq 0 (cos x)
+        (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+           (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); 
+ intro H6;
+ generalize
+  (sym_not_eq
+     (Rlt_not_eq 0 (cos y)
+        (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+           (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); 
+ intro H7; generalize (tan_diff x y H6 H7); intro H8;
+ generalize (Rlt_minus (tan x) (tan y) H3); clear H3; 
+ intro H3; rewrite H8 in H3; cut (sin (x - y) < 0).
+intro H9; generalize (Ropp_le_ge_contravar (- (PI / 4)) y H1);
+ rewrite Ropp_involutive; intro H10; generalize (Rge_le (PI / 4) (- y) H10);
+ clear H10; intro H10; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
+ intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); 
+ clear H11; intro H11;
+ generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
+ generalize (Rplus_le_compat x (PI / 4) (- y) (PI / 4) H0 H10);
+ replace (x + - y) with (x - y).
+replace (PI / 4 + PI / 4) with (PI / 2).
+replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)).
+intros; case (Rtotal_order 0 (x - y)); intro H14.
+generalize
+ (sin_gt_0 (x - y) H14 (Rle_lt_trans (x - y) (PI / 2) PI H12 PI2_Rlt_PI));
+ intro H15; elim (Rlt_irrefl 0 (Rlt_trans 0 (sin (x - y)) 0 H15 H9)).
+elim H14; intro H15.
+rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9). 
+apply Rminus_lt; assumption.
+pattern PI at 1 in |- *; rewrite double_var.
+unfold Rdiv in |- *.
+rewrite Rmult_plus_distr_r.
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_mult_distr.
+rewrite Ropp_plus_distr.
+replace 4 with 4.
+reflexivity.
+ring.
+discrR.
+discrR.
+pattern PI at 1 in |- *; rewrite double_var.
+unfold Rdiv in |- *.
+rewrite Rmult_plus_distr_r.
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_mult_distr.
+replace 4 with 4.
+reflexivity.
+ring.
+discrR.
+discrR.
+reflexivity.
+case (Rcase_abs (sin (x - y))); intro H9.
+assumption.
+generalize (Rge_le (sin (x - y)) 0 H9); clear H9; intro H9;
+ generalize (Rinv_0_lt_compat (cos x) HP1); intro H10;
+ generalize (Rinv_0_lt_compat (cos y) HP2); intro H11;
+ generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11);
+ replace (/ cos x * / cos y) with (/ (cos x * cos y)).
+intro H12;
+ generalize
+  (Rmult_le_pos (sin (x - y)) (/ (cos x * cos y)) H9
+     (Rlt_le 0 (/ (cos x * cos y)) H12)); intro H13;
+ elim
+  (Rlt_irrefl 0 (Rle_lt_trans 0 (sin (x - y) * / (cos x * cos y)) 0 H13 H3)).
+rewrite Rinv_mult_distr.
+reflexivity. 
+assumption.
+assumption.
+Qed.
+
+Lemma tan_increasing_1 :
+ forall x y:R,
+   - (PI / 4) <= x ->
+   x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x < y -> tan x < tan y.
+intros; apply Rminus_lt; generalize PI4_RLT_PI2; intro H4;
+ generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); 
+ intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
+ generalize
+  (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+     (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1;
+ generalize
+  (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+     (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2;
+ generalize
+  (sym_not_eq
+     (Rlt_not_eq 0 (cos x)
+        (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+           (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); 
+ intro H6;
+ generalize
+  (sym_not_eq
+     (Rlt_not_eq 0 (cos y)
+        (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+           (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); 
+ intro H7; rewrite (tan_diff x y H6 H7);
+ generalize (Rinv_0_lt_compat (cos x) HP1); intro H10;
+ generalize (Rinv_0_lt_compat (cos y) HP2); intro H11;
+ generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11);
+ replace (/ cos x * / cos y) with (/ (cos x * cos y)).
+clear H10 H11; intro H8; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
+ intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); 
+ clear H11; intro H11;
+ generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
+ replace (x + - y) with (x - y).
+replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)).
+clear H11; intro H9; generalize (Rlt_minus x y H3); clear H3; intro H3;
+ clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI; 
+ intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1); 
+ clear H1; intro H1;
+ generalize
+  (sin_lt_0_var (x - y) (Rlt_le_trans (- PI) (- (PI / 2)) (x - y) H1 H9) H3);
+ intro H2;
+ generalize
+  (Rmult_lt_gt_compat_neg_l (sin (x - y)) 0 (/ (cos x * cos y)) H2 H8);
+ rewrite Rmult_0_r; intro H4; assumption.
+pattern PI at 1 in |- *; rewrite double_var.
+unfold Rdiv in |- *.
+rewrite Rmult_plus_distr_r.
+repeat rewrite Rmult_assoc.
+rewrite <- Rinv_mult_distr.
+replace 4 with 4.
+rewrite Ropp_plus_distr.
+reflexivity.
+ring.
+discrR.
+discrR.
+reflexivity.
+apply Rinv_mult_distr; assumption.
+Qed.
+
+Lemma sin_incr_0 :
+ forall x y:R,
+   - (PI / 2) <= x ->
+   x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x <= sin y -> x <= y.
+intros; case (Rtotal_order (sin x) (sin y)); intro H4;
+ [ left; apply (sin_increasing_0 x y H H0 H1 H2 H4)
+ | elim H4; intro H5;
+    [ case (Rtotal_order x y); intro H6;
+       [ left; assumption
+       | elim H6; intro H7;
+          [ right; assumption
+          | generalize (sin_increasing_1 y x H1 H2 H H0 H7); intro H8;
+             rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8) ] ]
+    | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ].
+Qed.
+
+Lemma sin_incr_1 :
+ forall x y:R,
+   - (PI / 2) <= x ->
+   x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x <= y -> sin x <= sin y.
+intros; case (Rtotal_order x y); intro H4;
+ [ left; apply (sin_increasing_1 x y H H0 H1 H2 H4)
+ | elim H4; intro H5;
+    [ case (Rtotal_order (sin x) (sin y)); intro H6;
+       [ left; assumption
+       | elim H6; intro H7;
+          [ right; assumption
+          | generalize (sin_increasing_0 y x H1 H2 H H0 H7); intro H8;
+             rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
+    | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+Qed.
+
+Lemma sin_decr_0 :
+ forall x y:R,
+   x <= 3 * (PI / 2) ->
+   PI / 2 <= x ->
+   y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x <= sin y -> y <= x.
+intros; case (Rtotal_order (sin x) (sin y)); intro H4;
+ [ left; apply (sin_decreasing_0 x y H H0 H1 H2 H4)
+ | elim H4; intro H5;
+    [ case (Rtotal_order x y); intro H6;
+       [ generalize (sin_decreasing_1 x y H H0 H1 H2 H6); intro H8;
+          rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8)
+       | elim H6; intro H7;
+          [ right; symmetry  in |- *; assumption | left; assumption ] ]
+    | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ].
+Qed.
+
+Lemma sin_decr_1 :
+ forall x y:R,
+   x <= 3 * (PI / 2) ->
+   PI / 2 <= x ->
+   y <= 3 * (PI / 2) -> PI / 2 <= y -> x <= y -> sin y <= sin x.
+intros; case (Rtotal_order x y); intro H4;
+ [ left; apply (sin_decreasing_1 x y H H0 H1 H2 H4)
+ | elim H4; intro H5;
+    [ case (Rtotal_order (sin x) (sin y)); intro H6;
+       [ generalize (sin_decreasing_0 x y H H0 H1 H2 H6); intro H8;
+          rewrite H5 in H8; elim (Rlt_irrefl y H8)
+       | elim H6; intro H7;
+          [ right; symmetry  in |- *; assumption | left; assumption ] ]
+    | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+Qed.
+
+Lemma cos_incr_0 :
+ forall x y:R,
+   PI <= x ->
+   x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x <= cos y -> x <= y.
+intros; case (Rtotal_order (cos x) (cos y)); intro H4;
+ [ left; apply (cos_increasing_0 x y H H0 H1 H2 H4)
+ | elim H4; intro H5;
+    [ case (Rtotal_order x y); intro H6;
+       [ left; assumption
+       | elim H6; intro H7;
+          [ right; assumption
+          | generalize (cos_increasing_1 y x H1 H2 H H0 H7); intro H8;
+             rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8) ] ]
+    | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ].
+Qed.
+
+Lemma cos_incr_1 :
+ forall x y:R,
+   PI <= x ->
+   x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x <= y -> cos x <= cos y.
+intros; case (Rtotal_order x y); intro H4;
+ [ left; apply (cos_increasing_1 x y H H0 H1 H2 H4)
+ | elim H4; intro H5;
+    [ case (Rtotal_order (cos x) (cos y)); intro H6;
+       [ left; assumption
+       | elim H6; intro H7;
+          [ right; assumption
+          | generalize (cos_increasing_0 y x H1 H2 H H0 H7); intro H8;
+             rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
+    | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+Qed.
+
+Lemma cos_decr_0 :
+ forall x y:R,
+   0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x <= cos y -> y <= x.
+intros; case (Rtotal_order (cos x) (cos y)); intro H4;
+ [ left; apply (cos_decreasing_0 x y H H0 H1 H2 H4)
+ | elim H4; intro H5;
+    [ case (Rtotal_order x y); intro H6;
+       [ generalize (cos_decreasing_1 x y H H0 H1 H2 H6); intro H8;
+          rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8)
+       | elim H6; intro H7;
+          [ right; symmetry  in |- *; assumption | left; assumption ] ]
+    | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ].
+Qed.
+
+Lemma cos_decr_1 :
+ forall x y:R,
+   0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x <= y -> cos y <= cos x.
+intros; case (Rtotal_order x y); intro H4;
+ [ left; apply (cos_decreasing_1 x y H H0 H1 H2 H4)
+ | elim H4; intro H5;
+    [ case (Rtotal_order (cos x) (cos y)); intro H6;
+       [ generalize (cos_decreasing_0 x y H H0 H1 H2 H6); intro H8;
+          rewrite H5 in H8; elim (Rlt_irrefl y H8)
+       | elim H6; intro H7;
+          [ right; symmetry  in |- *; assumption | left; assumption ] ]
+    | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+Qed.
+
+Lemma tan_incr_0 :
+ forall x y:R,
+   - (PI / 4) <= x ->
+   x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x <= tan y -> x <= y.
+intros; case (Rtotal_order (tan x) (tan y)); intro H4;
+ [ left; apply (tan_increasing_0 x y H H0 H1 H2 H4)
+ | elim H4; intro H5;
+    [ case (Rtotal_order x y); intro H6;
+       [ left; assumption
+       | elim H6; intro H7;
+          [ right; assumption
+          | generalize (tan_increasing_1 y x H1 H2 H H0 H7); intro H8;
+             rewrite H5 in H8; elim (Rlt_irrefl (tan y) H8) ] ]
+    | elim (Rlt_irrefl (tan x) (Rle_lt_trans (tan x) (tan y) (tan x) H3 H5)) ] ].
+Qed.
+
+Lemma tan_incr_1 :
+ forall x y:R,
+   - (PI / 4) <= x ->
+   x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x <= y -> tan x <= tan y.
+intros; case (Rtotal_order x y); intro H4;
+ [ left; apply (tan_increasing_1 x y H H0 H1 H2 H4)
+ | elim H4; intro H5;
+    [ case (Rtotal_order (tan x) (tan y)); intro H6;
+       [ left; assumption
+       | elim H6; intro H7;
+          [ right; assumption
+          | generalize (tan_increasing_0 y x H1 H2 H H0 H7); intro H8;
+             rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
+    | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+Qed.
+
+(**********)
+Lemma sin_eq_0_1 : forall x:R, (exists k : Z, x = IZR k * PI) -> sin x = 0.
+intros.
+elim H; intros.
+apply (Zcase_sign x0).
+intro.
+rewrite H1 in H0.
+simpl in H0.
+rewrite H0; rewrite Rmult_0_l; apply sin_0.
+intro.
+cut (0 <= x0)%Z.
+intro.
+elim (IZN x0 H2); intros.
+rewrite H3 in H0.
+rewrite <- INR_IZR_INZ in H0.
+rewrite H0.
+elim (even_odd_cor x1); intros.
+elim H4; intro.
+rewrite H5.
+rewrite mult_INR.
+simpl in |- *.
+rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+rewrite sin_period.
+apply sin_0.
+rewrite H5.
+rewrite S_INR; rewrite mult_INR.
+simpl in |- *.
+rewrite Rmult_plus_distr_r.
+rewrite Rmult_1_l; rewrite sin_plus.
+rewrite sin_PI.
+rewrite Rmult_0_r.
+rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+rewrite sin_period.
+rewrite sin_0; ring.
+apply le_IZR.
+left; apply IZR_lt.
+assert (H2 := Zorder.Zgt_iff_lt).
+elim (H2 x0 0%Z); intros.
+apply H3; assumption.
+intro.
+rewrite H0.
+replace (sin (IZR x0 * PI)) with (- sin (- IZR x0 * PI)).
+cut (0 <= - x0)%Z.
+intro.
+rewrite <- Ropp_Ropp_IZR.
+elim (IZN (- x0) H2); intros.
+rewrite H3.
+rewrite <- INR_IZR_INZ.
+elim (even_odd_cor x1); intros.
+elim H4; intro.
+rewrite H5.
+rewrite mult_INR.
+simpl in |- *.
+rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+rewrite sin_period.
+rewrite sin_0; ring.
+rewrite H5.
+rewrite S_INR; rewrite mult_INR.
+simpl in |- *.
+rewrite Rmult_plus_distr_r.
+rewrite Rmult_1_l; rewrite sin_plus.
+rewrite sin_PI.
+rewrite Rmult_0_r.
+rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+rewrite sin_period.
+rewrite sin_0; ring.
+apply le_IZR.
+apply Rplus_le_reg_l with (IZR x0).
+rewrite Rplus_0_r.
+rewrite Ropp_Ropp_IZR.
+rewrite Rplus_opp_r.
+left; replace 0 with (IZR 0); [ apply IZR_lt | reflexivity ].
+assumption.
+rewrite <- sin_neg.
+rewrite Ropp_mult_distr_l_reverse.
+rewrite Ropp_involutive.
+reflexivity.
+Qed.
+
+Lemma sin_eq_0_0 : forall x:R, sin x = 0 ->  exists k : Z, x = IZR k * PI.
+intros.
+assert (H0 := euclidian_division x PI PI_neq0).
+elim H0; intros q H1.
+elim H1; intros r H2.
+exists q.
+cut (r = 0).
+intro.
+elim H2; intros H4 _; rewrite H4; rewrite H3.
+apply Rplus_0_r.
+elim H2; intros.
+rewrite H3 in H.
+rewrite sin_plus in H.
+cut (sin (IZR q * PI) = 0).
+intro.
+rewrite H5 in H.
+rewrite Rmult_0_l in H.
+rewrite Rplus_0_l in H.
+assert (H6 := Rmult_integral _ _ H).
+elim H6; intro.
+assert (H8 := sin2_cos2 (IZR q * PI)).
+rewrite H5 in H8; rewrite H7 in H8.
+rewrite Rsqr_0 in H8.
+rewrite Rplus_0_r in H8.
+elim R1_neq_R0; symmetry  in |- *; assumption.
+cut (r = 0 \/ 0 < r < PI).
+intro; elim H8; intro.
+assumption.
+elim H9; intros.
+assert (H12 := sin_gt_0 _ H10 H11).
+rewrite H7 in H12; elim (Rlt_irrefl _ H12).
+rewrite Rabs_right in H4.
+elim H4; intros.
+case (Rtotal_order 0 r); intro.
+right; split; assumption.
+elim H10; intro.
+left; symmetry  in |- *; assumption.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H8 H11)).
+apply Rle_ge.
+left; apply PI_RGT_0.
+apply sin_eq_0_1.
+exists q; reflexivity.
+Qed.
+
+Lemma cos_eq_0_0 :
+ forall x:R, cos x = 0 ->  exists k : Z, x = IZR k * PI + PI / 2. 
+intros x H; rewrite cos_sin in H; generalize (sin_eq_0_0 (PI / INR 2 + x) H);
+ intro H2; elim H2; intros x0 H3; exists (x0 - Z_of_nat 1)%Z;
+ rewrite <- Z_R_minus; ring; rewrite Rmult_comm; rewrite <- H3;
+ unfold INR in |- *.
+rewrite (double_var (- PI)); unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma cos_eq_0_1 :
+ forall x:R, (exists k : Z, x = IZR k * PI + PI / 2) -> cos x = 0.
+intros x H1; rewrite cos_sin; elim H1; intros x0 H2; rewrite H2;
+ replace (PI / 2 + (IZR x0 * PI + PI / 2)) with (IZR x0 * PI + PI).
+rewrite neg_sin; rewrite <- Ropp_0.
+apply Ropp_eq_compat; apply sin_eq_0_1; exists x0; reflexivity.
+pattern PI at 2 in |- *; rewrite (double_var PI); ring.
+Qed.
+
+Lemma sin_eq_O_2PI_0 :
+ forall x:R,
+   0 <= x -> x <= 2 * PI -> sin x = 0 -> x = 0 \/ x = PI \/ x = 2 * PI.
+intros; generalize (sin_eq_0_0 x H1); intro.
+elim H2; intros k0 H3.
+case (Rtotal_order PI x); intro.
+rewrite H3 in H4; rewrite H3 in H0.
+right; right.
+generalize
+ (Rmult_lt_compat_r (/ PI) PI (IZR k0 * PI) (Rinv_0_lt_compat PI PI_RGT_0) H4);
+ rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; intro;
+ generalize
+  (Rmult_le_compat_r (/ PI) (IZR k0 * PI) (2 * PI)
+     (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H0);
+ repeat rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
+repeat rewrite Rmult_1_r; intro;
+ generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H5); 
+ rewrite <- plus_IZR.
+replace (IZR (-2) + 1) with (-1).
+intro; generalize (Rplus_le_compat_l (IZR (-2)) (IZR k0) 2 H6);
+ rewrite <- plus_IZR.
+replace (IZR (-2) + 2) with 0.
+intro; cut (-1 < IZR (-2 + k0) < 1).
+intro; generalize (one_IZR_lt1 (-2 + k0) H9); intro.
+cut (k0 = 2%Z).
+intro; rewrite H11 in H3; rewrite H3; simpl in |- *.
+reflexivity.
+rewrite <- (Zplus_opp_l 2) in H10; generalize (Zplus_reg_l (-2) k0 2 H10);
+ intro; assumption.
+split.
+assumption.
+apply Rle_lt_trans with 0.
+assumption.
+apply Rlt_0_1.
+simpl in |- *; ring.
+simpl in |- *; ring.
+apply PI_neq0.
+apply PI_neq0.
+elim H4; intro.
+right; left.
+symmetry  in |- *; assumption.
+left.
+rewrite H3 in H5; rewrite H3 in H;
+ generalize
+  (Rmult_lt_compat_r (/ PI) (IZR k0 * PI) PI (Rinv_0_lt_compat PI PI_RGT_0)
+     H5); rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; intro;
+ generalize
+  (Rmult_le_compat_r (/ PI) 0 (IZR k0 * PI)
+     (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H);
+ repeat rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; rewrite Rmult_0_l; intro.
+cut (-1 < IZR k0 < 1).
+intro; generalize (one_IZR_lt1 k0 H8); intro; rewrite H9 in H3; rewrite H3;
+ simpl in |- *; apply Rmult_0_l.
+split.
+apply Rlt_le_trans with 0.
+rewrite <- Ropp_0; apply Ropp_gt_lt_contravar; apply Rlt_0_1.
+assumption.
+assumption.
+apply PI_neq0.
+apply PI_neq0.
+Qed.
+
+Lemma sin_eq_O_2PI_1 :
+ forall x:R,
+   0 <= x -> x <= 2 * PI -> x = 0 \/ x = PI \/ x = 2 * PI -> sin x = 0.
+intros x H1 H2 H3; elim H3; intro H4;
+ [ rewrite H4; rewrite sin_0; reflexivity
+ | elim H4; intro H5;
+    [ rewrite H5; rewrite sin_PI; reflexivity
+    | rewrite H5; rewrite sin_2PI; reflexivity ] ].
+Qed.
+
+Lemma cos_eq_0_2PI_0 :
+ forall x:R,
+   0 <= x -> x <= 2 * PI -> cos x = 0 -> x = PI / 2 \/ x = 3 * (PI / 2).
+intros; case (Rtotal_order x (3 * (PI / 2))); intro.
+rewrite cos_sin in H1.
+cut (0 <= PI / 2 + x).
+cut (PI / 2 + x <= 2 * PI).
+intros; generalize (sin_eq_O_2PI_0 (PI / 2 + x) H4 H3 H1); intros.
+decompose [or] H5.
+generalize (Rplus_le_compat_l (PI / 2) 0 x H); rewrite Rplus_0_r; rewrite H6;
+ intro.
+elim (Rlt_irrefl 0 (Rlt_le_trans 0 (PI / 2) 0 PI2_RGT_0 H7)).
+left.
+generalize (Rplus_eq_compat_l (- (PI / 2)) (PI / 2 + x) PI H7).
+replace (- (PI / 2) + (PI / 2 + x)) with x.
+replace (- (PI / 2) + PI) with (PI / 2).
+intro; assumption.
+pattern PI at 3 in |- *; rewrite (double_var PI); ring.
+ring.
+right.
+generalize (Rplus_eq_compat_l (- (PI / 2)) (PI / 2 + x) (2 * PI) H7).
+replace (- (PI / 2) + (PI / 2 + x)) with x.
+replace (- (PI / 2) + 2 * PI) with (3 * (PI / 2)).
+intro; assumption.
+rewrite double; pattern PI at 3 4 in |- *; rewrite (double_var PI); ring.
+ring.
+left; replace (2 * PI) with (PI / 2 + 3 * (PI / 2)).
+apply Rplus_lt_compat_l; assumption.
+rewrite (double PI); pattern PI at 3 4 in |- *; rewrite (double_var PI); ring.
+apply Rplus_le_le_0_compat.
+left; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply PI_RGT_0.
+apply Rinv_0_lt_compat; prove_sup0. 
+assumption.
+elim H2; intro.
+right; assumption.
+generalize (cos_eq_0_0 x H1); intro; elim H4; intros k0 H5.
+rewrite H5 in H3; rewrite H5 in H0;
+ generalize
+  (Rplus_lt_compat_l (- (PI / 2)) (3 * (PI / 2)) (IZR k0 * PI + PI / 2) H3);
+ generalize
+  (Rplus_le_compat_l (- (PI / 2)) (IZR k0 * PI + PI / 2) (2 * PI) H0).
+replace (- (PI / 2) + 3 * (PI / 2)) with PI.
+replace (- (PI / 2) + (IZR k0 * PI + PI / 2)) with (IZR k0 * PI).
+replace (- (PI / 2) + 2 * PI) with (3 * (PI / 2)).
+intros;
+ generalize
+  (Rmult_lt_compat_l (/ PI) PI (IZR k0 * PI) (Rinv_0_lt_compat PI PI_RGT_0)
+     H7);
+ generalize
+  (Rmult_le_compat_l (/ PI) (IZR k0 * PI) (3 * (PI / 2))
+     (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H6).
+replace (/ PI * (IZR k0 * PI)) with (IZR k0).
+replace (/ PI * (3 * (PI / 2))) with (3 * / 2).
+rewrite <- Rinv_l_sym.
+intros; generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H9);
+ rewrite <- plus_IZR.
+replace (IZR (-2) + 1) with (-1).
+intro; generalize (Rplus_le_compat_l (IZR (-2)) (IZR k0) (3 * / 2) H8);
+ rewrite <- plus_IZR.
+replace (IZR (-2) + 2) with 0.
+intro; cut (-1 < IZR (-2 + k0) < 1).
+intro; generalize (one_IZR_lt1 (-2 + k0) H12); intro.
+cut (k0 = 2%Z).
+intro; rewrite H14 in H8.
+assert (Hyp : 0 < 2).
+prove_sup0.
+generalize (Rmult_le_compat_l 2 (IZR 2) (3 * / 2) (Rlt_le 0 2 Hyp) H8);
+ simpl in |- *.
+replace 4 with 4.
+replace (2 * (3 * / 2)) with 3.
+intro; cut (3 < 4).
+intro; elim (Rlt_irrefl 3 (Rlt_le_trans 3 4 3 H16 H15)).
+generalize (Rplus_lt_compat_l 3 0 1 Rlt_0_1); rewrite Rplus_0_r.
+replace (3 + 1) with 4.
+intro; assumption.
+ring.
+symmetry  in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
+discrR.
+ring.
+rewrite <- (Zplus_opp_l 2) in H13; generalize (Zplus_reg_l (-2) k0 2 H13);
+ intro; assumption.
+split.
+assumption.
+apply Rle_lt_trans with (IZR (-2) + 3 * / 2).
+assumption.
+simpl in |- *; replace (-2 + 3 * / 2) with (- (1 * / 2)).
+apply Rlt_trans with 0.
+rewrite <- Ropp_0; apply Ropp_lt_gt_contravar.
+apply Rmult_lt_0_compat;
+ [ apply Rlt_0_1 | apply Rinv_0_lt_compat; prove_sup0 ].
+apply Rlt_0_1.
+rewrite Rmult_1_l; apply Rmult_eq_reg_l with 2.
+rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_r_sym.
+rewrite Rmult_plus_distr_l; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m.
+ring.
+discrR.
+discrR.
+discrR.
+simpl in |- *; ring.
+simpl in |- *; ring.
+apply PI_neq0.
+unfold Rdiv in |- *; pattern 3 at 1 in |- *; rewrite (Rmult_comm 3);
+ repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; apply Rmult_comm.
+apply PI_neq0.
+symmetry  in |- *; rewrite (Rmult_comm (/ PI)); rewrite Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+apply Rmult_1_r.
+apply PI_neq0.
+rewrite double; pattern PI at 3 4 in |- *; rewrite double_var; ring.
+ring.
+pattern PI at 1 in |- *; rewrite double_var; ring.
+Qed.
+
+Lemma cos_eq_0_2PI_1 :
+ forall x:R,
+   0 <= x -> x <= 2 * PI -> x = PI / 2 \/ x = 3 * (PI / 2) -> cos x = 0.
+intros x H1 H2 H3; elim H3; intro H4;
+ [ rewrite H4; rewrite cos_PI2; reflexivity
+ | rewrite H4; rewrite cos_3PI2; reflexivity ].
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v
new file mode 100644
index 00000000..3cda9290
--- /dev/null
+++ b/theories/Reals/Rtrigo_alt.v
@@ -0,0 +1,426 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Rtrigo_alt.v,v 1.16.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo_def.
+Open Local Scope R_scope.
+
+(*****************************************************************)
+(* Using series definitions of cos and sin                       *)
+(*****************************************************************)
+
+Definition sin_term (a:R) (i:nat) : R :=
+  (-1) ^ i * (a ^ (2 * i + 1) / INR (fact (2 * i + 1))).
+
+Definition cos_term (a:R) (i:nat) : R :=
+  (-1) ^ i * (a ^ (2 * i) / INR (fact (2 * i))).
+
+Definition sin_approx (a:R) (n:nat) : R := sum_f_R0 (sin_term a) n.
+
+Definition cos_approx (a:R) (n:nat) : R := sum_f_R0 (cos_term a) n.
+
+(**********)
+Lemma PI_4 : PI <= 4.
+assert (H0 := PI_ineq 0).
+elim H0; clear H0; intros _ H0.
+unfold tg_alt, PI_tg in H0; simpl in H0.
+rewrite Rinv_1 in H0; rewrite Rmult_1_r in H0; unfold Rdiv in H0.
+apply Rmult_le_reg_l with (/ 4).
+apply Rinv_0_lt_compat; prove_sup0.
+rewrite <- Rinv_l_sym; [ rewrite Rmult_comm; assumption | discrR ].
+Qed.
+
+(**********)
+Theorem sin_bound :
+ forall (a:R) (n:nat),
+   0 <= a ->
+   a <= PI -> sin_approx a (2 * n + 1) <= sin a <= sin_approx a (2 * (n + 1)).
+intros; case (Req_dec a 0); intro Hyp_a.
+rewrite Hyp_a; rewrite sin_0; split; right; unfold sin_approx in |- *;
+ apply sum_eq_R0 || (symmetry  in |- *; apply sum_eq_R0); 
+ intros; unfold sin_term in |- *; rewrite pow_add; 
+ simpl in |- *; unfold Rdiv in |- *; rewrite Rmult_0_l; 
+ ring.
+unfold sin_approx in |- *; cut (0 < a).
+intro Hyp_a_pos.
+rewrite (decomp_sum (sin_term a) (2 * n + 1)).
+rewrite (decomp_sum (sin_term a) (2 * (n + 1))).
+replace (sin_term a 0) with a.
+cut
+ (sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * n + 1)) <= sin a - a /\
+  sin a - a <= sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * (n + 1))) ->
+  a + sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * n + 1)) <= sin a /\
+  sin a <= a + sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * (n + 1)))).
+intro; apply H1.
+set (Un := fun n:nat => a ^ (2 * S n + 1) / INR (fact (2 * S n + 1))).
+replace (pred (2 * n + 1)) with (2 * n)%nat.
+replace (pred (2 * (n + 1))) with (S (2 * n)).
+replace (sum_f_R0 (fun i:nat => sin_term a (S i)) (2 * n)) with
+ (- sum_f_R0 (tg_alt Un) (2 * n)).
+replace (sum_f_R0 (fun i:nat => sin_term a (S i)) (S (2 * n))) with
+ (- sum_f_R0 (tg_alt Un) (S (2 * n))).
+cut
+ (sum_f_R0 (tg_alt Un) (S (2 * n)) <= a - sin a <=
+  sum_f_R0 (tg_alt Un) (2 * n) ->
+  - sum_f_R0 (tg_alt Un) (2 * n) <= sin a - a <=
+  - sum_f_R0 (tg_alt Un) (S (2 * n))).
+intro; apply H2.
+apply alternated_series_ineq.
+unfold Un_decreasing, Un in |- *; intro;
+ cut ((2 * S (S n0) + 1)%nat = S (S (2 * S n0 + 1))).
+intro; rewrite H3.
+replace (a ^ S (S (2 * S n0 + 1))) with (a ^ (2 * S n0 + 1) * (a * a)).
+unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+left; apply pow_lt; assumption.
+apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n0 + 1))))).
+rewrite <- H3; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
+ assert (H5 := sym_eq H4); elim (fact_neq_0 _ H5).
+rewrite <- H3; rewrite (Rmult_comm (INR (fact (2 * S (S n0) + 1))));
+ rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; rewrite H3; do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
+ repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r.
+do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
+ simpl in |- *;
+ replace
+  (((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1 + 1) *
+   ((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1)) with
+  (4 * INR n0 * INR n0 + 18 * INR n0 + 20); [ idtac | ring ].
+apply Rle_trans with 20.
+apply Rle_trans with 16.
+replace 16 with (Rsqr 4); [ idtac | ring_Rsqr ].
+replace (a * a) with (Rsqr a); [ idtac | reflexivity ].
+apply Rsqr_incr_1.
+apply Rle_trans with PI; [ assumption | apply PI_4 ].
+assumption.
+left; prove_sup0.
+rewrite <- (Rplus_0_r 16); replace 20 with (16 + 4);
+ [ apply Rplus_le_compat_l; left; prove_sup0 | ring ].
+rewrite <- (Rplus_comm 20); pattern 20 at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_le_compat_l.
+apply Rplus_le_le_0_compat.
+repeat apply Rmult_le_pos.
+left; prove_sup0.
+left; prove_sup0.
+replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+apply Rmult_le_pos.
+left; prove_sup0.
+replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+simpl in |- *; ring.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite plus_INR;
+ do 2 rewrite mult_INR; repeat rewrite S_INR; ring.
+assert (H3 := cv_speed_pow_fact a); unfold Un in |- *; unfold Un_cv in H3;
+ unfold R_dist in H3; unfold Un_cv in |- *; unfold R_dist in |- *; 
+ intros; elim (H3 eps H4); intros N H5.
+exists N; intros; apply H5.
+replace (2 * S n0 + 1)%nat with (S (2 * S n0)).
+unfold ge in |- *; apply le_trans with (2 * S n0)%nat.
+apply le_trans with (2 * S N)%nat.
+apply le_trans with (2 * N)%nat.
+apply le_n_2n.
+apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_Sn.
+apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption.
+apply le_n_Sn.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR; reflexivity.
+assert (X := exist_sin (Rsqr a)); elim X; intros.
+cut (x = sin a / a).
+intro; rewrite H3 in p; unfold sin_in in p; unfold infinit_sum in p;
+ unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; 
+ intros.
+cut (0 < eps / Rabs a).
+intro; elim (p _ H5); intros N H6.
+exists N; intros.
+replace (sum_f_R0 (tg_alt Un) n0) with
+ (a * (1 - sum_f_R0 (fun i:nat => sin_n i * Rsqr a ^ i) (S n0))).
+unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
+ rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
+ repeat rewrite Rplus_assoc; rewrite (Rplus_comm a);
+ rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc; 
+ rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rmult_lt_reg_l with (/ Rabs a).
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+pattern (/ Rabs a) at 1 in |- *; rewrite <- (Rabs_Rinv a Hyp_a).
+rewrite <- Rabs_mult; rewrite Rmult_plus_distr_l; rewrite <- Rmult_assoc;
+ rewrite <- Rinv_l_sym; [ rewrite Rmult_1_l | assumption ];
+ rewrite (Rmult_comm (/ a)); rewrite (Rmult_comm (/ Rabs a));
+ rewrite <- Rabs_Ropp; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
+ unfold Rminus, Rdiv in H6; apply H6; unfold ge in |- *;
+ apply le_trans with n0; [ exact H7 | apply le_n_Sn ].
+rewrite (decomp_sum (fun i:nat => sin_n i * Rsqr a ^ i) (S n0)).
+replace (sin_n 0) with 1.
+simpl in |- *; rewrite Rmult_1_r; unfold Rminus in |- *;
+ rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
+ rewrite Rplus_0_l; rewrite Ropp_mult_distr_r_reverse;
+ rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum; 
+ apply sum_eq.
+intros; unfold sin_n, Un, tg_alt in |- *;
+ replace ((-1) ^ S i) with (- (-1) ^ i).
+replace (a ^ (2 * S i + 1)) with (Rsqr a * Rsqr a ^ i * a).
+unfold Rdiv in |- *; ring.
+rewrite pow_add; rewrite pow_Rsqr; simpl in |- *; ring.
+simpl in |- *; ring.
+unfold sin_n in |- *; unfold Rdiv in |- *; simpl in |- *; rewrite Rinv_1;
+ rewrite Rmult_1_r; reflexivity.
+apply lt_O_Sn.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+assumption.
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+unfold sin in |- *; case (exist_sin (Rsqr a)).
+intros; cut (x = x0).
+intro; rewrite H3; unfold Rdiv in |- *.
+symmetry  in |- *; apply Rinv_r_simpl_m; assumption.
+unfold sin_in in p; unfold sin_in in s; eapply uniqueness_sum.
+apply p.
+apply s.
+intros; elim H2; intros.
+replace (sin a - a) with (- (a - sin a)); [ idtac | ring ].
+split; apply Ropp_le_contravar; assumption.
+replace (- sum_f_R0 (tg_alt Un) (S (2 * n))) with
+ (-1 * sum_f_R0 (tg_alt Un) (S (2 * n))); [ rewrite scal_sum | ring ].
+apply sum_eq; intros; unfold sin_term, Un, tg_alt in |- *;
+ replace ((-1) ^ S i) with (-1 * (-1) ^ i).
+unfold Rdiv in |- *; ring.
+reflexivity.
+replace (- sum_f_R0 (tg_alt Un) (2 * n)) with
+ (-1 * sum_f_R0 (tg_alt Un) (2 * n)); [ rewrite scal_sum | ring ].
+apply sum_eq; intros.
+unfold sin_term, Un, tg_alt in |- *;
+ replace ((-1) ^ S i) with (-1 * (-1) ^ i).
+unfold Rdiv in |- *; ring.
+reflexivity.
+replace (2 * (n + 1))%nat with (S (S (2 * n))).
+reflexivity.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; rewrite plus_INR;
+ repeat rewrite S_INR; ring.
+replace (2 * n + 1)%nat with (S (2 * n)).
+reflexivity.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
+ repeat rewrite S_INR; ring.
+intro; elim H1; intros.
+split.
+apply Rplus_le_reg_l with (- a).
+rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
+ rewrite (Rplus_comm (- a)); apply H2.
+apply Rplus_le_reg_l with (- a).
+rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
+ rewrite (Rplus_comm (- a)); apply H3.
+unfold sin_term in |- *; simpl in |- *; unfold Rdiv in |- *; rewrite Rinv_1;
+ ring.
+replace (2 * (n + 1))%nat with (S (S (2 * n))).
+apply lt_O_Sn.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; rewrite plus_INR;
+ repeat rewrite S_INR; ring.
+replace (2 * n + 1)%nat with (S (2 * n)).
+apply lt_O_Sn.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
+ repeat rewrite S_INR; ring.
+inversion H; [ assumption | elim Hyp_a; symmetry  in |- *; assumption ].
+Qed.
+
+(**********)
+Lemma cos_bound :
+ forall (a:R) (n:nat),
+   - PI / 2 <= a ->
+   a <= PI / 2 ->
+   cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)). 
+cut
+ ((forall (a:R) (n:nat),
+     0 <= a ->
+     a <= PI / 2 ->
+     cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))) ->
+  forall (a:R) (n:nat),
+    - PI / 2 <= a ->
+    a <= PI / 2 ->
+    cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))).
+intros H a n; apply H.
+intros; unfold cos_approx in |- *.
+rewrite (decomp_sum (cos_term a0) (2 * n0 + 1)).
+rewrite (decomp_sum (cos_term a0) (2 * (n0 + 1))).
+replace (cos_term a0 0) with 1.
+cut
+ (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * n0 + 1)) <= cos a0 - 1 /\
+  cos a0 - 1 <=
+  sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * (n0 + 1))) ->
+  1 + sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * n0 + 1)) <= cos a0 /\
+  cos a0 <=
+  1 + sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * (n0 + 1)))).
+intro; apply H2.
+set (Un := fun n:nat => a0 ^ (2 * S n) / INR (fact (2 * S n))).
+replace (pred (2 * n0 + 1)) with (2 * n0)%nat.
+replace (pred (2 * (n0 + 1))) with (S (2 * n0)).
+replace (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (2 * n0)) with
+ (- sum_f_R0 (tg_alt Un) (2 * n0)).
+replace (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (S (2 * n0))) with
+ (- sum_f_R0 (tg_alt Un) (S (2 * n0))).
+cut
+ (sum_f_R0 (tg_alt Un) (S (2 * n0)) <= 1 - cos a0 <=
+  sum_f_R0 (tg_alt Un) (2 * n0) ->
+  - sum_f_R0 (tg_alt Un) (2 * n0) <= cos a0 - 1 <=
+  - sum_f_R0 (tg_alt Un) (S (2 * n0))).
+intro; apply H3.
+apply alternated_series_ineq.
+unfold Un_decreasing in |- *; intro; unfold Un in |- *.
+cut ((2 * S (S n1))%nat = S (S (2 * S n1))).
+intro; rewrite H4;
+ replace (a0 ^ S (S (2 * S n1))) with (a0 ^ (2 * S n1) * (a0 * a0)).
+unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+apply pow_le; assumption.
+apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n1))))).
+rewrite <- H4; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
+ assert (H6 := sym_eq H5); elim (fact_neq_0 _ H6).
+rewrite <- H4; rewrite (Rmult_comm (INR (fact (2 * S (S n1)))));
+ rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; rewrite H4; do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
+ repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; do 2 rewrite S_INR; rewrite mult_INR; repeat rewrite S_INR;
+ simpl in |- *;
+ replace
+  (((0 + 1 + 1) * (INR n1 + 1) + 1 + 1) * ((0 + 1 + 1) * (INR n1 + 1) + 1))
+  with (4 * INR n1 * INR n1 + 14 * INR n1 + 12); [ idtac | ring ].
+apply Rle_trans with 12.
+apply Rle_trans with 4.
+replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ].
+replace (a0 * a0) with (Rsqr a0); [ idtac | reflexivity ].
+apply Rsqr_incr_1.
+apply Rle_trans with (PI / 2).
+assumption.
+unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+prove_sup0.
+rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m.
+replace 4 with 4; [ apply PI_4 | ring ].
+discrR.
+assumption.
+left; prove_sup0.
+pattern 4 at 1 in |- *; rewrite <- Rplus_0_r; replace 12 with (4 + 8);
+ [ apply Rplus_le_compat_l; left; prove_sup0 | ring ].
+rewrite <- (Rplus_comm 12); pattern 12 at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_le_compat_l.
+apply Rplus_le_le_0_compat.
+repeat apply Rmult_le_pos.
+left; prove_sup0.
+left; prove_sup0.
+replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+apply Rmult_le_pos.
+left; prove_sup0.
+replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+simpl in |- *; ring.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+assert (H4 := cv_speed_pow_fact a0); unfold Un in |- *; unfold Un_cv in H4;
+ unfold R_dist in H4; unfold Un_cv in |- *; unfold R_dist in |- *; 
+ intros; elim (H4 eps H5); intros N H6; exists N; intros.
+apply H6; unfold ge in |- *; apply le_trans with (2 * S N)%nat.
+apply le_trans with (2 * N)%nat.
+apply le_n_2n.
+apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_Sn.
+apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption.
+assert (X := exist_cos (Rsqr a0)); elim X; intros.
+cut (x = cos a0).
+intro; rewrite H4 in p; unfold cos_in in p; unfold infinit_sum in p;
+ unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; 
+ intros.
+elim (p _ H5); intros N H6.
+exists N; intros.
+replace (sum_f_R0 (tg_alt Un) n1) with
+ (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
+unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
+ repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1);
+ rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; 
+ rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp;
+ rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
+ unfold Rminus in H6; apply H6.
+unfold ge in |- *; apply le_trans with n1.
+exact H7.
+apply le_n_Sn.
+rewrite (decomp_sum (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
+replace (cos_n 0) with 1.
+simpl in |- *; rewrite Rmult_1_r; unfold Rminus in |- *;
+ rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
+ rewrite Rplus_0_l;
+ replace (- sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1)
+  with
+  (-1 * sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1);
+ [ idtac | ring ]; rewrite scal_sum; apply sum_eq; 
+ intros; unfold cos_n, Un, tg_alt in |- *.
+replace ((-1) ^ S i) with (- (-1) ^ i).
+replace (a0 ^ (2 * S i)) with (Rsqr a0 * Rsqr a0 ^ i).
+unfold Rdiv in |- *; ring.
+rewrite pow_Rsqr; reflexivity.
+simpl in |- *; ring.
+unfold cos_n in |- *; unfold Rdiv in |- *; simpl in |- *; rewrite Rinv_1;
+ rewrite Rmult_1_r; reflexivity.
+apply lt_O_Sn.
+unfold cos in |- *; case (exist_cos (Rsqr a0)); intros; unfold cos_in in p;
+ unfold cos_in in c; eapply uniqueness_sum.
+apply p.
+apply c.
+intros; elim H3; intros; replace (cos a0 - 1) with (- (1 - cos a0));
+ [ idtac | ring ].
+split; apply Ropp_le_contravar; assumption.
+replace (- sum_f_R0 (tg_alt Un) (S (2 * n0))) with
+ (-1 * sum_f_R0 (tg_alt Un) (S (2 * n0))); [ rewrite scal_sum | ring ].
+apply sum_eq; intros; unfold cos_term, Un, tg_alt in |- *;
+ replace ((-1) ^ S i) with (-1 * (-1) ^ i).
+unfold Rdiv in |- *; ring.
+reflexivity.
+replace (- sum_f_R0 (tg_alt Un) (2 * n0)) with
+ (-1 * sum_f_R0 (tg_alt Un) (2 * n0)); [ rewrite scal_sum | ring ];
+ apply sum_eq; intros; unfold cos_term, Un, tg_alt in |- *;
+ replace ((-1) ^ S i) with (-1 * (-1) ^ i).
+unfold Rdiv in |- *; ring.
+reflexivity.
+replace (2 * (n0 + 1))%nat with (S (S (2 * n0))).
+reflexivity.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; rewrite plus_INR;
+ repeat rewrite S_INR; ring.
+replace (2 * n0 + 1)%nat with (S (2 * n0)).
+reflexivity.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
+ repeat rewrite S_INR; ring.
+intro; elim H2; intros; split.
+apply Rplus_le_reg_l with (-1).
+rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
+ rewrite (Rplus_comm (-1)); apply H3.
+apply Rplus_le_reg_l with (-1).
+rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
+ rewrite (Rplus_comm (-1)); apply H4.
+unfold cos_term in |- *; simpl in |- *; unfold Rdiv in |- *; rewrite Rinv_1;
+ ring.
+replace (2 * (n0 + 1))%nat with (S (S (2 * n0))).
+apply lt_O_Sn.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; rewrite plus_INR;
+ repeat rewrite S_INR; ring.
+replace (2 * n0 + 1)%nat with (S (2 * n0)).
+apply lt_O_Sn.
+apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
+ repeat rewrite S_INR; ring.
+intros; case (total_order_T 0 a); intro.
+elim s; intro.
+apply H; [ left; assumption | assumption ].
+apply H; [ right; assumption | assumption ].
+cut (0 < - a).
+intro; cut (forall (x:R) (n:nat), cos_approx x n = cos_approx (- x) n).
+intro; rewrite H3; rewrite (H3 a (2 * (n + 1))%nat); rewrite cos_sym; apply H.
+left; assumption.
+rewrite <- (Ropp_involutive (PI / 2)); apply Ropp_le_contravar;
+ unfold Rdiv in |- *; unfold Rdiv in H0; rewrite <- Ropp_mult_distr_l_reverse;
+ exact H0.
+intros; unfold cos_approx in |- *; apply sum_eq; intros;
+ unfold cos_term in |- *; do 2 rewrite pow_Rsqr; rewrite Rsqr_neg;
+ unfold Rdiv in |- *; reflexivity.
+apply Ropp_0_gt_lt_contravar; assumption.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v
new file mode 100644
index 00000000..0ef87322
--- /dev/null
+++ b/theories/Reals/Rtrigo_calc.v
@@ -0,0 +1,434 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rtrigo_calc.v,v 1.15.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import R_sqrt.
+Open Local Scope R_scope.
+
+Lemma tan_PI : tan PI = 0.
+unfold tan in |- *; rewrite sin_PI; rewrite cos_PI; unfold Rdiv in |- *;
+ apply Rmult_0_l. 
+Qed.
+
+Lemma sin_3PI2 : sin (3 * (PI / 2)) = -1.
+replace (3 * (PI / 2)) with (PI + PI / 2).
+rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; rewrite sin_PI2; ring.
+pattern PI at 1 in |- *; rewrite (double_var PI); ring.
+Qed.
+
+Lemma tan_2PI : tan (2 * PI) = 0.
+unfold tan in |- *; rewrite sin_2PI; unfold Rdiv in |- *; apply Rmult_0_l.
+Qed.
+
+Lemma sin_cos_PI4 : sin (PI / 4) = cos (PI / 4).
+Proof with trivial.
+rewrite cos_sin...
+replace (PI / 2 + PI / 4) with (- (PI / 4) + PI)...
+rewrite neg_sin; rewrite sin_neg; ring...
+cut (PI = PI / 2 + PI / 2); [ intro | apply double_var ]...
+pattern PI at 2 3 in |- *; rewrite H; pattern PI at 2 3 in |- *; rewrite H...
+assert (H0 : 2 <> 0);
+ [ discrR | unfold Rdiv in |- *; rewrite Rinv_mult_distr; try ring ]...
+Qed.
+
+Lemma sin_PI3_cos_PI6 : sin (PI / 3) = cos (PI / 6).
+Proof with trivial.
+replace (PI / 6) with (PI / 2 - PI / 3)...
+rewrite cos_shift...
+assert (H0 : 6 <> 0); [ discrR | idtac ]...
+assert (H1 : 3 <> 0); [ discrR | idtac ]...
+assert (H2 : 2 <> 0); [ discrR | idtac ]...
+apply Rmult_eq_reg_l with 6...
+rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
+unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
+rewrite <- Rinv_l_sym...
+rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
+pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
+ repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
+ring...
+Qed.
+
+Lemma sin_PI6_cos_PI3 : cos (PI / 3) = sin (PI / 6).
+Proof with trivial.
+replace (PI / 6) with (PI / 2 - PI / 3)...
+rewrite sin_shift...
+assert (H0 : 6 <> 0); [ discrR | idtac ]...
+assert (H1 : 3 <> 0); [ discrR | idtac ]...
+assert (H2 : 2 <> 0); [ discrR | idtac ]...
+apply Rmult_eq_reg_l with 6...
+rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
+unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
+rewrite <- Rinv_l_sym...
+rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
+pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
+ repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
+ring...
+Qed.
+
+Lemma PI6_RGT_0 : 0 < PI / 6.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
+Qed.
+
+Lemma PI6_RLT_PI2 : PI / 6 < PI / 2.
+unfold Rdiv in |- *; apply Rmult_lt_compat_l.
+apply PI_RGT_0.
+apply Rinv_lt_contravar; prove_sup.
+Qed.
+
+Lemma sin_PI6 : sin (PI / 6) = 1 / 2.
+Proof with trivial.
+assert (H : 2 <> 0); [ discrR | idtac ]...
+apply Rmult_eq_reg_l with (2 * cos (PI / 6))...
+replace (2 * cos (PI / 6) * sin (PI / 6)) with
+ (2 * sin (PI / 6) * cos (PI / 6))...
+rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3)...
+rewrite sin_PI3_cos_PI6...
+unfold Rdiv in |- *; rewrite Rmult_1_l; rewrite Rmult_assoc;
+ pattern 2 at 2 in |- *; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym...
+rewrite Rmult_1_r...
+unfold Rdiv in |- *; rewrite Rinv_mult_distr...
+rewrite (Rmult_comm (/ 2)); rewrite (Rmult_comm 2);
+ repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
+rewrite Rmult_1_r...
+discrR...
+ring...
+apply prod_neq_R0...
+cut (0 < cos (PI / 6));
+ [ intro H1; auto with real
+ | apply cos_gt_0;
+    [ apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)
+    | apply PI6_RLT_PI2 ] ]...
+Qed.
+
+Lemma sqrt2_neq_0 : sqrt 2 <> 0.
+assert (Hyp : 0 < 2);
+ [ prove_sup0
+ | generalize (Rlt_le 0 2 Hyp); intro H1; red in |- *; intro H2;
+    generalize (sqrt_eq_0 2 H1 H2); intro H; absurd (2 = 0);
+    [ discrR | assumption ] ].
+Qed.
+
+Lemma R1_sqrt2_neq_0 : 1 / sqrt 2 <> 0.
+generalize (Rinv_neq_0_compat (sqrt 2) sqrt2_neq_0); intro H;
+ generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H); 
+ intro H0; assumption.
+Qed.
+
+Lemma sqrt3_2_neq_0 : 2 * sqrt 3 <> 0.
+apply prod_neq_R0;
+ [ discrR
+ | assert (Hyp : 0 < 3);
+    [ prove_sup0
+    | generalize (Rlt_le 0 3 Hyp); intro H1; red in |- *; intro H2;
+       generalize (sqrt_eq_0 3 H1 H2); intro H; absurd (3 = 0);
+       [ discrR | assumption ] ] ].
+Qed.
+
+Lemma Rlt_sqrt2_0 : 0 < sqrt 2.
+assert (Hyp : 0 < 2);
+ [ prove_sup0
+ | generalize (sqrt_positivity 2 (Rlt_le 0 2 Hyp)); intro H1; elim H1;
+    intro H2;
+    [ assumption
+    | absurd (0 = sqrt 2);
+       [ apply (sym_not_eq (A:=R)); apply sqrt2_neq_0 | assumption ] ] ].
+Qed.
+
+Lemma Rlt_sqrt3_0 : 0 < sqrt 3.
+cut (0%nat <> 1%nat);
+ [ intro H0; assert (Hyp : 0 < 2);
+    [ prove_sup0
+    | generalize (Rlt_le 0 2 Hyp); intro H1; assert (Hyp2 : 0 < 3);
+       [ prove_sup0
+       | generalize (Rlt_le 0 3 Hyp2); intro H2;
+          generalize (lt_INR_0 1 (neq_O_lt 1 H0)); 
+          unfold INR in |- *; intro H3;
+          generalize (Rplus_lt_compat_l 2 0 1 H3); 
+          rewrite Rplus_comm; rewrite Rplus_0_l; replace (2 + 1) with 3;
+          [ intro H4; generalize (sqrt_lt_1 2 3 H1 H2 H4); clear H3; intro H3;
+             apply (Rlt_trans 0 (sqrt 2) (sqrt 3) Rlt_sqrt2_0 H3)
+          | ring ] ] ]
+ | discriminate ].
+Qed.
+
+Lemma PI4_RGT_0 : 0 < PI / 4.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
+Qed.
+
+Lemma cos_PI4 : cos (PI / 4) = 1 / sqrt 2.
+Proof with trivial.
+apply Rsqr_inj...
+apply cos_ge_0...
+left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 4) _PI2_RLT_0 PI4_RGT_0)...
+left; apply PI4_RLT_PI2...
+left; apply (Rmult_lt_0_compat 1 (/ sqrt 2))...
+prove_sup...
+apply Rinv_0_lt_compat; apply Rlt_sqrt2_0...
+rewrite Rsqr_div...
+rewrite Rsqr_1; rewrite Rsqr_sqrt...
+assert (H : 2 <> 0); [ discrR | idtac ]...
+unfold Rsqr in |- *; pattern (cos (PI / 4)) at 1 in |- *;
+ rewrite <- sin_cos_PI4;
+ replace (sin (PI / 4) * cos (PI / 4)) with
+  (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4)))...
+rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2)...
+rewrite sin_PI2...
+apply Rmult_1_r...
+unfold Rdiv in |- *; rewrite (Rmult_comm 2); rewrite Rinv_mult_distr...
+repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
+rewrite Rmult_1_r...
+unfold Rdiv in |- *; rewrite Rmult_1_l; repeat rewrite <- Rmult_assoc...
+rewrite <- Rinv_l_sym...
+rewrite Rmult_1_l...
+left; prove_sup...
+apply sqrt2_neq_0...
+Qed.
+
+Lemma sin_PI4 : sin (PI / 4) = 1 / sqrt 2.
+rewrite sin_cos_PI4; apply cos_PI4.
+Qed.
+
+Lemma tan_PI4 : tan (PI / 4) = 1.
+unfold tan in |- *; rewrite sin_cos_PI4.
+unfold Rdiv in |- *; apply Rinv_r.
+change (cos (PI / 4) <> 0) in |- *; rewrite cos_PI4; apply R1_sqrt2_neq_0.
+Qed.
+
+Lemma cos3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2.
+Proof with trivial.
+replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
+rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4...
+unfold Rdiv in |- *; rewrite Ropp_mult_distr_l_reverse...
+unfold Rminus in |- *; rewrite Ropp_involutive; pattern PI at 1 in |- *;
+ rewrite double_var; unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
+ repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
+ [ ring | discrR | discrR ]...
+Qed.
+
+Lemma sin3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2.
+Proof with trivial.
+replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
+rewrite sin_shift; rewrite cos_neg; rewrite cos_PI4...
+unfold Rminus in |- *; rewrite Ropp_involutive; pattern PI at 1 in |- *;
+ rewrite double_var; unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
+ repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
+ [ ring | discrR | discrR ]...
+Qed.
+
+Lemma cos_PI6 : cos (PI / 6) = sqrt 3 / 2.
+Proof with trivial.
+apply Rsqr_inj...
+apply cos_ge_0...
+left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)...
+left; apply PI6_RLT_PI2...
+left; apply (Rmult_lt_0_compat (sqrt 3) (/ 2))...
+apply Rlt_sqrt3_0...
+apply Rinv_0_lt_compat; prove_sup0...
+assert (H : 2 <> 0); [ discrR | idtac ]...
+assert (H1 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
+rewrite Rsqr_div...
+rewrite cos2; unfold Rsqr in |- *; rewrite sin_PI6; rewrite sqrt_def...
+unfold Rdiv in |- *; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
+rewrite Rmult_minus_distr_l; rewrite (Rmult_comm 3);
+ repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym...
+rewrite Rmult_1_l; rewrite Rmult_1_r...
+rewrite <- (Rmult_comm (/ 2)); repeat rewrite <- Rmult_assoc...
+rewrite <- Rinv_l_sym...
+rewrite Rmult_1_l; rewrite <- Rinv_r_sym...
+ring...
+left; prove_sup0...
+Qed.
+
+Lemma tan_PI6 : tan (PI / 6) = 1 / sqrt 3.
+unfold tan in |- *; rewrite sin_PI6; rewrite cos_PI6; unfold Rdiv in |- *;
+ repeat rewrite Rmult_1_l; rewrite Rinv_mult_distr.
+rewrite Rinv_involutive.
+rewrite (Rmult_comm (/ 2)); rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+apply Rmult_1_r.
+discrR.
+discrR.
+red in |- *; intro; assert (H1 := Rlt_sqrt3_0); rewrite H in H1;
+ elim (Rlt_irrefl 0 H1).
+apply Rinv_neq_0_compat; discrR.
+Qed.
+
+Lemma sin_PI3 : sin (PI / 3) = sqrt 3 / 2.
+rewrite sin_PI3_cos_PI6; apply cos_PI6.
+Qed.
+
+Lemma cos_PI3 : cos (PI / 3) = 1 / 2.
+rewrite sin_PI6_cos_PI3; apply sin_PI6.
+Qed.
+
+Lemma tan_PI3 : tan (PI / 3) = sqrt 3.
+unfold tan in |- *; rewrite sin_PI3; rewrite cos_PI3; unfold Rdiv in |- *;
+ rewrite Rmult_1_l; rewrite Rinv_involutive.
+rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+apply Rmult_1_r.
+discrR.
+discrR.
+Qed.
+
+Lemma sin_2PI3 : sin (2 * (PI / 3)) = sqrt 3 / 2.
+rewrite double; rewrite sin_plus; rewrite sin_PI3; rewrite cos_PI3;
+ unfold Rdiv in |- *; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ 2));
+ repeat rewrite <- Rmult_assoc; rewrite double_var; 
+ reflexivity.
+Qed.
+
+Lemma cos_2PI3 : cos (2 * (PI / 3)) = -1 / 2.
+Proof with trivial.
+assert (H : 2 <> 0); [ discrR | idtac ]...
+assert (H0 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
+rewrite double; rewrite cos_plus; rewrite sin_PI3; rewrite cos_PI3;
+ unfold Rdiv in |- *; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
+rewrite Rmult_minus_distr_l; repeat rewrite Rmult_assoc;
+ rewrite (Rmult_comm 2)...
+repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
+rewrite Rmult_1_r; rewrite <- Rinv_r_sym...
+pattern 2 at 4 in |- *; rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym...
+rewrite Rmult_1_r; rewrite Ropp_mult_distr_r_reverse; rewrite Rmult_1_r...
+rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
+rewrite Rmult_1_r; rewrite (Rmult_comm 2); rewrite (Rmult_comm (/ 2))...
+repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
+rewrite Rmult_1_r; rewrite sqrt_def...
+ring...
+left; prove_sup...
+Qed.
+
+Lemma tan_2PI3 : tan (2 * (PI / 3)) = - sqrt 3.
+Proof with trivial.
+assert (H : 2 <> 0); [ discrR | idtac ]...
+unfold tan in |- *; rewrite sin_2PI3; rewrite cos_2PI3; unfold Rdiv in |- *;
+ rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l;
+ rewrite <- Ropp_inv_permute...
+rewrite Rinv_involutive...
+rewrite Rmult_assoc; rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_l_sym...
+ring...
+apply Rinv_neq_0_compat...
+Qed.
+
+Lemma cos_5PI4 : cos (5 * (PI / 4)) = -1 / sqrt 2.
+Proof with trivial.
+replace (5 * (PI / 4)) with (PI / 4 + PI)...
+rewrite neg_cos; rewrite cos_PI4; unfold Rdiv in |- *;
+ rewrite Ropp_mult_distr_l_reverse...
+pattern PI at 2 in |- *; rewrite double_var; pattern PI at 2 3 in |- *;
+ rewrite double_var; assert (H : 2 <> 0);
+ [ discrR | unfold Rdiv in |- *; repeat rewrite Rinv_mult_distr; try ring ]...
+Qed.
+
+Lemma sin_5PI4 : sin (5 * (PI / 4)) = -1 / sqrt 2.
+Proof with trivial.
+replace (5 * (PI / 4)) with (PI / 4 + PI)...
+rewrite neg_sin; rewrite sin_PI4; unfold Rdiv in |- *;
+ rewrite Ropp_mult_distr_l_reverse...
+pattern PI at 2 in |- *; rewrite double_var; pattern PI at 2 3 in |- *;
+ rewrite double_var; assert (H : 2 <> 0);
+ [ discrR | unfold Rdiv in |- *; repeat rewrite Rinv_mult_distr; try ring ]...
+Qed.
+
+Lemma sin_cos5PI4 : cos (5 * (PI / 4)) = sin (5 * (PI / 4)).
+rewrite cos_5PI4; rewrite sin_5PI4; reflexivity.
+Qed.
+
+Lemma Rgt_3PI2_0 : 0 < 3 * (PI / 2).
+apply Rmult_lt_0_compat;
+ [ prove_sup0
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ] ].
+Qed.
+
+Lemma Rgt_2PI_0 : 0 < 2 * PI.
+apply Rmult_lt_0_compat; [ prove_sup0 | apply PI_RGT_0 ].
+Qed.
+
+Lemma Rlt_PI_3PI2 : PI < 3 * (PI / 2).
+generalize PI2_RGT_0; intro H1;
+ generalize (Rplus_lt_compat_l PI 0 (PI / 2) H1);
+ replace (PI + PI / 2) with (3 * (PI / 2)).
+rewrite Rplus_0_r; intro H2; assumption.
+pattern PI at 2 in |- *; rewrite double_var; ring.
+Qed. 
+ 
+Lemma Rlt_3PI2_2PI : 3 * (PI / 2) < 2 * PI.
+generalize PI2_RGT_0; intro H1;
+ generalize (Rplus_lt_compat_l (3 * (PI / 2)) 0 (PI / 2) H1);
+ replace (3 * (PI / 2) + PI / 2) with (2 * PI).
+rewrite Rplus_0_r; intro H2; assumption.
+rewrite double; pattern PI at 1 2 in |- *; rewrite double_var; ring.
+Qed.
+
+(***************************************************************)
+(* Radian -> Degree | Degree -> Radian                         *)
+(***************************************************************)
+
+Definition plat : R := 180.
+Definition toRad (x:R) : R := x * PI * / plat.
+Definition toDeg (x:R) : R := x * plat * / PI.
+
+Lemma rad_deg : forall x:R, toRad (toDeg x) = x.
+intro; unfold toRad, toDeg in |- *;
+ replace (x * plat * / PI * PI * / plat) with
+  (x * (plat * / plat) * (PI * / PI)); [ idtac | ring ].
+repeat rewrite <- Rinv_r_sym.
+ring.
+apply PI_neq0.
+unfold plat in |- *; discrR.
+Qed.
+
+Lemma toRad_inj : forall x y:R, toRad x = toRad y -> x = y.
+intros; unfold toRad in H; apply Rmult_eq_reg_l with PI.
+rewrite <- (Rmult_comm x); rewrite <- (Rmult_comm y).
+apply Rmult_eq_reg_l with (/ plat).
+rewrite <- (Rmult_comm (x * PI)); rewrite <- (Rmult_comm (y * PI));
+ assumption.
+apply Rinv_neq_0_compat; unfold plat in |- *; discrR.
+apply PI_neq0.
+Qed.
+
+Lemma deg_rad : forall x:R, toDeg (toRad x) = x.
+intro x; apply toRad_inj; rewrite (rad_deg (toRad x)); reflexivity.
+Qed.
+
+Definition sind (x:R) : R := sin (toRad x).
+Definition cosd (x:R) : R := cos (toRad x).
+Definition tand (x:R) : R := tan (toRad x).
+
+Lemma Rsqr_sin_cos_d_one : forall x:R, Rsqr (sind x) + Rsqr (cosd x) = 1.
+intro x; unfold sind in |- *; unfold cosd in |- *; apply sin2_cos2.
+Qed.
+
+(***************************************************)
+(*                Other properties                 *)
+(***************************************************)
+
+Lemma sin_lb_ge_0 : forall a:R, 0 <= a -> a <= PI / 2 -> 0 <= sin_lb a.
+intros; case (Rtotal_order 0 a); intro.
+left; apply sin_lb_gt_0; assumption.
+elim H1; intro.
+rewrite <- H2; unfold sin_lb in |- *; unfold sin_approx in |- *;
+ unfold sum_f_R0 in |- *; unfold sin_term in |- *; 
+ repeat rewrite pow_ne_zero.
+unfold Rdiv in |- *; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r;
+ repeat rewrite Rplus_0_r; right; reflexivity.
+discriminate.
+discriminate.
+discriminate.
+discriminate.
+elim (Rlt_irrefl 0 (Rle_lt_trans 0 a 0 H H2)).
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v
new file mode 100644
index 00000000..92ec68ce
--- /dev/null
+++ b/theories/Reals/Rtrigo_def.v
@@ -0,0 +1,412 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Rtrigo_def.v,v 1.17.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo_fun.
+Require Import Max.
+Open Local Scope R_scope.
+
+(*****************************)
+(* Definition of exponential *)
+(*****************************)
+Definition exp_in (x l:R) : Prop :=
+  infinit_sum (fun i:nat => / INR (fact i) * x ^ i) l.
+
+Lemma exp_cof_no_R0 : forall n:nat, / INR (fact n) <> 0.
+intro.
+apply Rinv_neq_0_compat.
+apply INR_fact_neq_0.
+Qed.
+
+Lemma exist_exp : forall x:R, sigT (fun l:R => exp_in x l).
+intro;
+ generalize
+  (Alembert_C3 (fun n:nat => / INR (fact n)) x exp_cof_no_R0 Alembert_exp).
+unfold Pser, exp_in in |- *.
+trivial.
+Defined.
+
+Definition exp (x:R) : R := projT1 (exist_exp x).
+
+Lemma pow_i : forall i:nat, (0 < i)%nat -> 0 ^ i = 0.
+intros; apply pow_ne_zero.
+red in |- *; intro; rewrite H0 in H; elim (lt_irrefl _ H).
+Qed.
+
+(*i Calculus of $e^0$ *)
+Lemma exist_exp0 : sigT (fun l:R => exp_in 0 l).
+apply existT with 1.
+unfold exp_in in |- *; unfold infinit_sum in |- *; intros.
+exists 0%nat.
+intros; replace (sum_f_R0 (fun i:nat => / INR (fact i) * 0 ^ i) n) with 1.
+unfold R_dist in |- *; replace (1 - 1) with 0;
+ [ rewrite Rabs_R0; assumption | ring ].
+induction  n as [| n Hrecn].
+simpl in |- *; rewrite Rinv_1; ring.
+rewrite tech5.
+rewrite <- Hrecn.
+simpl in |- *.
+ring.
+unfold ge in |- *; apply le_O_n.
+Defined.
+
+Lemma exp_0 : exp 0 = 1. 
+cut (exp_in 0 (exp 0)).
+cut (exp_in 0 1).
+unfold exp_in in |- *; intros; eapply uniqueness_sum.
+apply H0.
+apply H.
+exact (projT2 exist_exp0).
+exact (projT2 (exist_exp 0)).
+Qed.
+
+(**************************************)
+(* Definition of hyperbolic functions *)
+(**************************************)
+Definition cosh (x:R) : R := (exp x + exp (- x)) / 2.
+Definition sinh (x:R) : R := (exp x - exp (- x)) / 2.
+Definition tanh (x:R) : R := sinh x / cosh x.
+
+Lemma cosh_0 : cosh 0 = 1.
+unfold cosh in |- *; rewrite Ropp_0; rewrite exp_0.
+unfold Rdiv in |- *; rewrite <- Rinv_r_sym; [ reflexivity | discrR ].
+Qed.
+
+Lemma sinh_0 : sinh 0 = 0.
+unfold sinh in |- *; rewrite Ropp_0; rewrite exp_0.
+unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r; apply Rmult_0_l.
+Qed.
+
+Definition cos_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n)).
+
+Lemma simpl_cos_n :
+ forall n:nat, cos_n (S n) / cos_n n = - / INR (2 * S n * (2 * n + 1)). 
+intro; unfold cos_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+rewrite Rinv_involutive.
+replace
+ ((-1) ^ n * (-1) ^ 1 * / INR (fact (2 * (n + 1))) *
+  (/ (-1) ^ n * INR (fact (2 * n)))) with
+ ((-1) ^ n * / (-1) ^ n * / INR (fact (2 * (n + 1))) * INR (fact (2 * n)) *
+  (-1) ^ 1); [ idtac | ring ].
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; unfold pow in |- *; rewrite Rmult_1_r.
+replace (2 * (n + 1))%nat with (S (S (2 * n))); [ idtac | ring ].
+do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
+ repeat rewrite Rinv_mult_distr; try (apply not_O_INR; discriminate).
+rewrite <- (Rmult_comm (-1)).
+repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r.
+replace (S (2 * n)) with (2 * n + 1)%nat; [ idtac | ring ].
+rewrite mult_INR; rewrite Rinv_mult_distr.
+ring.
+apply not_O_INR; discriminate.
+replace (2 * n + 1)%nat with (S (2 * n));
+ [ apply not_O_INR; discriminate | ring ].
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
+apply pow_nonzero; discrR.
+apply INR_fact_neq_0.
+apply pow_nonzero; discrR.
+apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+Qed.
+
+Lemma archimed_cor1 :
+ forall eps:R, 0 < eps ->  exists N : nat, / INR N < eps /\ (0 < N)%nat.
+intros; cut (/ eps < IZR (up (/ eps))).
+intro; cut (0 <= up (/ eps))%Z.
+intro; assert (H2 := IZN _ H1); elim H2; intros; exists (max x 1).
+split.
+cut (0 < IZR (Z_of_nat x)).
+intro; rewrite INR_IZR_INZ; apply Rle_lt_trans with (/ IZR (Z_of_nat x)).
+apply Rmult_le_reg_l with (IZR (Z_of_nat x)).
+assumption.
+rewrite <- Rinv_r_sym;
+ [ idtac | red in |- *; intro; rewrite H5 in H4; elim (Rlt_irrefl _ H4) ].
+apply Rmult_le_reg_l with (IZR (Z_of_nat (max x 1))).
+apply Rlt_le_trans with (IZR (Z_of_nat x)).
+assumption.
+repeat rewrite <- INR_IZR_INZ; apply le_INR; apply le_max_l.
+rewrite Rmult_1_r; rewrite (Rmult_comm (IZR (Z_of_nat (max x 1))));
+ rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; repeat rewrite <- INR_IZR_INZ; apply le_INR;
+ apply le_max_l.
+rewrite <- INR_IZR_INZ; apply not_O_INR.
+red in |- *; intro; assert (H6 := le_max_r x 1); cut (0 < 1)%nat;
+ [ intro | apply lt_O_Sn ]; assert (H8 := lt_le_trans _ _ _ H7 H6);
+ rewrite H5 in H8; elim (lt_irrefl _ H8).
+pattern eps at 1 in |- *; rewrite <- Rinv_involutive.
+apply Rinv_lt_contravar.
+apply Rmult_lt_0_compat; [ apply Rinv_0_lt_compat; assumption | assumption ].
+rewrite H3 in H0; assumption.
+red in |- *; intro; rewrite H5 in H; elim (Rlt_irrefl _ H).
+apply Rlt_trans with (/ eps).
+apply Rinv_0_lt_compat; assumption.
+rewrite H3 in H0; assumption.
+apply lt_le_trans with 1%nat; [ apply lt_O_Sn | apply le_max_r ].
+apply le_IZR; replace (IZR 0) with 0; [ idtac | reflexivity ]; left;
+ apply Rlt_trans with (/ eps);
+ [ apply Rinv_0_lt_compat; assumption | assumption ].
+assert (H0 := archimed (/ eps)).
+elim H0; intros; assumption.
+Qed.
+
+Lemma Alembert_cos : Un_cv (fun n:nat => Rabs (cos_n (S n) / cos_n n)) 0.
+unfold Un_cv in |- *; intros.
+assert (H0 := archimed_cor1 eps H).
+elim H0; intros; exists x.
+intros; rewrite simpl_cos_n; unfold R_dist in |- *; unfold Rminus in |- *;
+ rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
+ rewrite Rabs_Ropp; rewrite Rabs_right.
+rewrite mult_INR; rewrite Rinv_mult_distr.
+cut (/ INR (2 * S n) < 1).
+intro; cut (/ INR (2 * n + 1) < eps).
+intro; rewrite <- (Rmult_1_l eps).
+apply Rmult_gt_0_lt_compat; try assumption.
+change (0 < / INR (2 * n + 1)) in |- *; apply Rinv_0_lt_compat;
+ apply lt_INR_0.
+replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
+apply Rlt_0_1.
+cut (x < 2 * n + 1)%nat.
+intro; assert (H5 := lt_INR _ _ H4).
+apply Rlt_trans with (/ INR x).
+apply Rinv_lt_contravar.
+apply Rmult_lt_0_compat.
+apply lt_INR_0.
+elim H1; intros; assumption.
+apply lt_INR_0; replace (2 * n + 1)%nat with (S (2 * n));
+ [ apply lt_O_Sn | ring ].
+assumption.
+elim H1; intros; assumption.
+apply lt_le_trans with (S n).
+unfold ge in H2; apply le_lt_n_Sm; assumption.
+replace (2 * n + 1)%nat with (S (2 * n)); [ idtac | ring ].
+apply le_n_S; apply le_n_2n.
+apply Rmult_lt_reg_l with (INR (2 * S n)).
+apply lt_INR_0; replace (2 * S n)%nat with (S (S (2 * n))).
+apply lt_O_Sn.
+replace (S n) with (n + 1)%nat; [ idtac | ring ].
+ring.
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; replace 1 with (INR 1); [ apply lt_INR | reflexivity ].
+replace (2 * S n)%nat with (S (S (2 * n))).
+apply lt_n_S; apply lt_O_Sn.
+replace (S n) with (n + 1)%nat; [ ring | ring ].
+apply not_O_INR; discriminate.
+apply not_O_INR; discriminate.
+replace (2 * n + 1)%nat with (S (2 * n));
+ [ apply not_O_INR; discriminate | ring ].
+apply Rle_ge; left; apply Rinv_0_lt_compat.
+apply lt_INR_0.
+replace (2 * S n * (2 * n + 1))%nat with (S (S (4 * (n * n) + 6 * n))).
+apply lt_O_Sn.
+apply INR_eq.
+repeat rewrite S_INR; rewrite plus_INR; repeat rewrite mult_INR;
+ rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
+ replace (INR 0) with 0; [ ring | reflexivity ].
+Qed.
+
+Lemma cosn_no_R0 : forall n:nat, cos_n n <> 0.
+intro; unfold cos_n in |- *; unfold Rdiv in |- *; apply prod_neq_R0.
+apply pow_nonzero; discrR.
+apply Rinv_neq_0_compat.
+apply INR_fact_neq_0.
+Qed.
+
+(**********)
+Definition cos_in (x l:R) : Prop :=
+  infinit_sum (fun i:nat => cos_n i * x ^ i) l.
+
+(**********)
+Lemma exist_cos : forall x:R, sigT (fun l:R => cos_in x l).
+intro; generalize (Alembert_C3 cos_n x cosn_no_R0 Alembert_cos).
+unfold Pser, cos_in in |- *; trivial.
+Qed.
+
+(* Definition of cosinus *)
+(*************************)
+Definition cos (x:R) : R :=
+  match exist_cos (Rsqr x) with
+  | existT a b => a
+  end.
+
+
+Definition sin_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n + 1)).
+
+Lemma simpl_sin_n :
+ forall n:nat, sin_n (S n) / sin_n n = - / INR ((2 * S n + 1) * (2 * S n)). 
+intro; unfold sin_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+rewrite Rinv_involutive.
+replace
+ ((-1) ^ n * (-1) ^ 1 * / INR (fact (2 * (n + 1) + 1)) *
+  (/ (-1) ^ n * INR (fact (2 * n + 1)))) with
+ ((-1) ^ n * / (-1) ^ n * / INR (fact (2 * (n + 1) + 1)) *
+  INR (fact (2 * n + 1)) * (-1) ^ 1); [ idtac | ring ].
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; unfold pow in |- *; rewrite Rmult_1_r;
+ replace (2 * (n + 1) + 1)%nat with (S (S (2 * n + 1))).
+do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
+ repeat rewrite Rinv_mult_distr.
+rewrite <- (Rmult_comm (-1)); repeat rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; replace (S (2 * n + 1)) with (2 * (n + 1))%nat.
+repeat rewrite mult_INR; repeat rewrite Rinv_mult_distr.
+ring.
+apply not_O_INR; discriminate.
+replace (n + 1)%nat with (S n); [ apply not_O_INR; discriminate | ring ].
+apply not_O_INR; discriminate.
+apply prod_neq_R0.
+apply not_O_INR; discriminate.
+replace (n + 1)%nat with (S n); [ apply not_O_INR; discriminate | ring ].
+apply not_O_INR; discriminate.
+replace (n + 1)%nat with (S n); [ apply not_O_INR; discriminate | ring ].
+rewrite mult_plus_distr_l; cut (forall n:nat, S n = (n + 1)%nat).
+intros; rewrite (H (2 * n + 1)%nat).
+ring.
+intros; ring.
+apply INR_fact_neq_0.
+apply not_O_INR; discriminate.
+apply INR_fact_neq_0.
+apply not_O_INR; discriminate.
+apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
+cut (forall n:nat, S (S n) = (n + 2)%nat);
+ [ intros; rewrite (H (2 * n + 1)%nat); ring | intros; ring ].
+apply pow_nonzero; discrR.
+apply INR_fact_neq_0.
+apply pow_nonzero; discrR.
+apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+Qed.
+
+Lemma Alembert_sin : Un_cv (fun n:nat => Rabs (sin_n (S n) / sin_n n)) 0.
+unfold Un_cv in |- *; intros; assert (H0 := archimed_cor1 eps H).
+elim H0; intros; exists x.
+intros; rewrite simpl_sin_n; unfold R_dist in |- *; unfold Rminus in |- *;
+ rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
+ rewrite Rabs_Ropp; rewrite Rabs_right.
+rewrite mult_INR; rewrite Rinv_mult_distr.
+cut (/ INR (2 * S n) < 1).
+intro; cut (/ INR (2 * S n + 1) < eps).
+intro; rewrite <- (Rmult_1_l eps); rewrite (Rmult_comm (/ INR (2 * S n + 1)));
+ apply Rmult_gt_0_lt_compat; try assumption.
+change (0 < / INR (2 * S n + 1)) in |- *; apply Rinv_0_lt_compat;
+ apply lt_INR_0; replace (2 * S n + 1)%nat with (S (2 * S n));
+ [ apply lt_O_Sn | ring ].
+apply Rlt_0_1.
+cut (x < 2 * S n + 1)%nat.
+intro; assert (H5 := lt_INR _ _ H4); apply Rlt_trans with (/ INR x).
+apply Rinv_lt_contravar.
+apply Rmult_lt_0_compat.
+apply lt_INR_0; elim H1; intros; assumption.
+apply lt_INR_0; replace (2 * S n + 1)%nat with (S (2 * S n));
+ [ apply lt_O_Sn | ring ].
+assumption.
+elim H1; intros; assumption.
+apply lt_le_trans with (S n).
+unfold ge in H2; apply le_lt_n_Sm; assumption.
+replace (2 * S n + 1)%nat with (S (2 * S n)); [ idtac | ring ].
+apply le_S; apply le_n_2n.
+apply Rmult_lt_reg_l with (INR (2 * S n)).
+apply lt_INR_0; replace (2 * S n)%nat with (S (S (2 * n)));
+ [ apply lt_O_Sn | replace (S n) with (n + 1)%nat; [ idtac | ring ]; ring ].
+rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; replace 1 with (INR 1); [ apply lt_INR | reflexivity ].
+replace (2 * S n)%nat with (S (S (2 * n))).
+apply lt_n_S; apply lt_O_Sn.
+replace (S n) with (n + 1)%nat; [ ring | ring ].
+apply not_O_INR; discriminate.
+apply not_O_INR; discriminate.
+apply not_O_INR; discriminate.
+left; change (0 < / INR ((2 * S n + 1) * (2 * S n))) in |- *;
+ apply Rinv_0_lt_compat.
+apply lt_INR_0.
+replace ((2 * S n + 1) * (2 * S n))%nat with
+ (S (S (S (S (S (S (4 * (n * n) + 10 * n))))))).
+apply lt_O_Sn.
+apply INR_eq; repeat rewrite S_INR; rewrite plus_INR; repeat rewrite mult_INR;
+ rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
+ replace (INR 0) with 0; [ ring | reflexivity ].
+Qed.
+
+Lemma sin_no_R0 : forall n:nat, sin_n n <> 0.
+intro; unfold sin_n in |- *; unfold Rdiv in |- *; apply prod_neq_R0.
+apply pow_nonzero; discrR.
+apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+Qed.
+
+(**********)
+Definition sin_in (x l:R) : Prop :=
+  infinit_sum (fun i:nat => sin_n i * x ^ i) l.
+
+(**********)
+Lemma exist_sin : forall x:R, sigT (fun l:R => sin_in x l).
+intro; generalize (Alembert_C3 sin_n x sin_no_R0 Alembert_sin).
+unfold Pser, sin_n in |- *; trivial.
+Qed.
+
+(***********************)
+(* Definition of sinus *)
+Definition sin (x:R) : R :=
+  match exist_sin (Rsqr x) with
+  | existT a b => x * a
+  end.
+
+(*********************************************)
+(*                 PROPERTIES                *)
+(*********************************************)
+
+Lemma cos_sym : forall x:R, cos x = cos (- x).
+intros; unfold cos in |- *; replace (Rsqr (- x)) with (Rsqr x).
+reflexivity.
+apply Rsqr_neg.
+Qed.
+
+Lemma sin_antisym : forall x:R, sin (- x) = - sin x.
+intro; unfold sin in |- *; replace (Rsqr (- x)) with (Rsqr x);
+ [ idtac | apply Rsqr_neg ]. 
+case (exist_sin (Rsqr x)); intros; ring.
+Qed.
+
+Lemma sin_0 : sin 0 = 0.
+unfold sin in |- *; case (exist_sin (Rsqr 0)).
+intros; ring.
+Qed.
+
+Lemma exist_cos0 : sigT (fun l:R => cos_in 0 l).
+apply existT with 1.
+unfold cos_in in |- *; unfold infinit_sum in |- *; intros; exists 0%nat.
+intros.
+unfold R_dist in |- *.
+induction  n as [| n Hrecn].
+unfold cos_n in |- *; simpl in |- *.
+unfold Rdiv in |- *; rewrite Rinv_1.
+do 2 rewrite Rmult_1_r.
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+rewrite tech5.
+replace (cos_n (S n) * 0 ^ S n) with 0.
+rewrite Rplus_0_r.
+apply Hrecn; unfold ge in |- *; apply le_O_n.
+simpl in |- *; ring.
+Defined.
+
+(* Calculus of (cos 0) *)
+Lemma cos_0 : cos 0 = 1.
+cut (cos_in 0 (cos 0)).
+cut (cos_in 0 1).
+unfold cos_in in |- *; intros; eapply uniqueness_sum.
+apply H0.
+apply H.
+exact (projT2 exist_cos0).
+assert (H := projT2 (exist_cos (Rsqr 0))); unfold cos in |- *;
+ pattern 0 at 1 in |- *; replace 0 with (Rsqr 0); [ exact H | apply Rsqr_0 ].
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v
new file mode 100644
index 00000000..b0f29e5c
--- /dev/null
+++ b/theories/Reals/Rtrigo_fun.v
@@ -0,0 +1,109 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rtrigo_fun.v,v 1.7.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Open Local Scope R_scope.
+
+(*****************************************************************)
+(*           To define transcendental functions                  *)
+(*                                                               *)
+(*****************************************************************)
+(*****************************************************************)
+(*           For exponential function                            *)
+(*                                                               *)
+(*****************************************************************)
+
+(*********)
+Lemma Alembert_exp :
+ Un_cv (fun n:nat => Rabs (/ INR (fact (S n)) * / / INR (fact n))) 0.
+unfold Un_cv in |- *; intros; elim (Rgt_dec eps 1); intro.
+split with 0%nat; intros; rewrite (simpl_fact n); unfold R_dist in |- *;
+ rewrite (Rminus_0_r (Rabs (/ INR (S n))));
+ rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0).
+intro; rewrite (Rabs_pos_eq (/ INR (S n))).
+cut (/ eps - 1 < 0).
+intro; generalize (Rlt_le_trans (/ eps - 1) 0 (INR n) H2 (pos_INR n));
+ clear H2; intro; unfold Rminus in H2;
+ generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H2);
+ replace (1 + (/ eps + -1)) with (/ eps); [ clear H2; intro | ring ].
+rewrite (Rplus_comm 1 (INR n)) in H2; rewrite <- (S_INR n) in H2;
+ generalize (Rmult_gt_0_compat (/ INR (S n)) eps H1 H); 
+ intro; unfold Rgt in H3;
+ generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H3 H2);
+ intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H4;
+ rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H)))
+   in H4; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H4;
+ rewrite (Rmult_comm (/ INR (S n))) in H4;
+ rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H4;
+ rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H4;
+ rewrite (let (H1, H2) := Rmult_ne eps in H1) in H4; 
+ assumption.
+apply Rlt_minus; unfold Rgt in a; rewrite <- Rinv_1;
+ apply (Rinv_lt_contravar 1 eps); auto;
+ rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H; 
+ assumption.
+unfold Rgt in H1; apply Rlt_le; assumption.
+unfold Rgt in |- *; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+(**)
+cut (0 <= up (/ eps - 1))%Z.
+intro; elim (IZN (up (/ eps - 1)) H0); intros; split with x; intros;
+ rewrite (simpl_fact n); unfold R_dist in |- *;
+ rewrite (Rminus_0_r (Rabs (/ INR (S n))));
+ rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0).
+intro; rewrite (Rabs_pos_eq (/ INR (S n))).
+cut (/ eps - 1 < INR x).
+intro;
+ generalize
+  (Rlt_le_trans (/ eps - 1) (INR x) (INR n) H4
+     (le_INR x n ((fun (n m:nat) (H:(m >= n)%nat) => H) x n H2))); 
+ clear H4; intro; unfold Rminus in H4;
+ generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H4);
+ replace (1 + (/ eps + -1)) with (/ eps); [ clear H4; intro | ring ].
+rewrite (Rplus_comm 1 (INR n)) in H4; rewrite <- (S_INR n) in H4;
+ generalize (Rmult_gt_0_compat (/ INR (S n)) eps H3 H); 
+ intro; unfold Rgt in H5;
+ generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H5 H4);
+ intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H6;
+ rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H)))
+   in H6; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H6;
+ rewrite (Rmult_comm (/ INR (S n))) in H6;
+ rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H6;
+ rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H6;
+ rewrite (let (H1, H2) := Rmult_ne eps in H1) in H6; 
+ assumption.
+cut (IZR (up (/ eps - 1)) = IZR (Z_of_nat x));
+ [ intro | rewrite H1; trivial ].
+elim (archimed (/ eps - 1)); intros; clear H6; unfold Rgt in H5;
+ rewrite H4 in H5; rewrite INR_IZR_INZ; assumption.
+unfold Rgt in H1; apply Rlt_le; assumption.
+unfold Rgt in |- *; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+apply (le_O_IZR (up (/ eps - 1)));
+ apply (Rle_trans 0 (/ eps - 1) (IZR (up (/ eps - 1)))).
+generalize (Rnot_gt_le eps 1 b); clear b; unfold Rle in |- *; intro; elim H0;
+ clear H0; intro.
+left; unfold Rgt in H;
+ generalize (Rmult_lt_compat_l (/ eps) eps 1 (Rinv_0_lt_compat eps H) H0);
+ rewrite
+  (Rinv_l eps
+     (sym_not_eq (Rlt_dichotomy_converse 0 eps (or_introl (0 > eps) H))))
+  ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1); 
+ intro; fold (/ eps - 1 > 0) in |- *; apply Rgt_minus; 
+ unfold Rgt in |- *; assumption.
+right; rewrite H0; rewrite Rinv_1; apply sym_eq; apply Rminus_diag_eq; auto.
+elim (archimed (/ eps - 1)); intros; clear H1; unfold Rgt in H0; apply Rlt_le;
+ assumption.
+Qed.
+
+
+
+
+
diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v
new file mode 100644
index 00000000..9d3b60c6
--- /dev/null
+++ b/theories/Reals/Rtrigo_reg.v
@@ -0,0 +1,608 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Rtrigo_reg.v,v 1.15.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import Ranalysis1.
+Require Import PSeries_reg.
+Open Local Scope nat_scope.
+Open Local Scope R_scope.
+
+Lemma CVN_R_cos :
+ forall fn:nat -> R -> R,
+   fn = (fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)) ->
+   CVN_R fn.
+unfold CVN_R in |- *; intros.
+cut ((r:R) <> 0).
+intro hyp_r; unfold CVN_r in |- *.
+apply existT with (fun n:nat => / INR (fact (2 * n)) * r ^ (2 * n)).
+cut
+ (sigT
+    (fun l:R =>
+       Un_cv
+         (fun n:nat =>
+            sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k)) * r ^ (2 * k)))
+              n) l)).
+intro; elim X; intros.
+apply existT with x.
+split.
+apply p.
+intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult.
+rewrite pow_1_abs; rewrite Rmult_1_l.
+cut (0 < / INR (fact (2 * n))).
+intro; rewrite (Rabs_right _ (Rle_ge _ _ (Rlt_le _ _ H1))).
+apply Rmult_le_compat_l.
+left; apply H1.
+rewrite <- RPow_abs; apply pow_maj_Rabs.
+rewrite Rabs_Rabsolu.
+unfold Boule in H0; rewrite Rminus_0_r in H0.
+left; apply H0.
+apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+apply Alembert_C2.
+intro; apply Rabs_no_R0.
+apply prod_neq_R0.
+apply Rinv_neq_0_compat.
+apply INR_fact_neq_0.
+apply pow_nonzero; assumption.
+assert (H0 := Alembert_cos).
+unfold cos_n in H0; unfold Un_cv in H0; unfold Un_cv in |- *; intros.
+cut (0 < eps / Rsqr r).
+intro; elim (H0 _ H2); intros N0 H3.
+exists N0; intros.
+unfold R_dist in |- *; assert (H5 := H3 _ H4).
+unfold R_dist in H5;
+ replace
+  (Rabs
+     (Rabs (/ INR (fact (2 * S n)) * r ^ (2 * S n)) /
+      Rabs (/ INR (fact (2 * n)) * r ^ (2 * n)))) with
+  (Rsqr r *
+   Rabs ((-1) ^ S n / INR (fact (2 * S n)) / ((-1) ^ n / INR (fact (2 * n))))).
+apply Rmult_lt_reg_l with (/ Rsqr r).
+apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
+pattern (/ Rsqr r) at 1 in |- *; replace (/ Rsqr r) with (Rabs (/ Rsqr r)).
+rewrite <- Rabs_mult; rewrite Rmult_minus_distr_l; rewrite Rmult_0_r;
+ rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); apply H5.
+unfold Rsqr in |- *; apply prod_neq_R0; assumption.
+rewrite Rabs_Rinv.
+rewrite Rabs_right.
+reflexivity.
+apply Rle_ge; apply Rle_0_sqr.
+unfold Rsqr in |- *; apply prod_neq_R0; assumption.
+rewrite (Rmult_comm (Rsqr r)); unfold Rdiv in |- *; repeat rewrite Rabs_mult;
+ rewrite Rabs_Rabsolu; rewrite pow_1_abs; rewrite Rmult_1_l;
+ repeat rewrite Rmult_assoc; apply Rmult_eq_compat_l.
+rewrite Rabs_Rinv.
+rewrite Rabs_mult; rewrite (pow_1_abs n); rewrite Rmult_1_l;
+ rewrite <- Rabs_Rinv.
+rewrite Rinv_involutive.
+rewrite Rinv_mult_distr.
+rewrite Rabs_Rinv.
+rewrite Rinv_involutive.
+rewrite (Rmult_comm (Rabs (Rabs (r ^ (2 * S n))))); rewrite Rabs_mult;
+ rewrite Rabs_Rabsolu; rewrite Rmult_assoc; apply Rmult_eq_compat_l.
+rewrite Rabs_Rinv.
+do 2 rewrite Rabs_Rabsolu; repeat rewrite Rabs_right.
+replace (r ^ (2 * S n)) with (r ^ (2 * n) * r * r).
+repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+unfold Rsqr in |- *; ring.
+apply pow_nonzero; assumption.
+replace (2 * S n)%nat with (S (S (2 * n))).
+simpl in |- *; ring.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+apply Rle_ge; apply pow_le; left; apply (cond_pos r).
+apply Rle_ge; apply pow_le; left; apply (cond_pos r).
+apply Rabs_no_R0; apply pow_nonzero; assumption.
+apply Rabs_no_R0; apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply Rabs_no_R0; apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+apply Rabs_no_R0; apply pow_nonzero; assumption.
+apply INR_fact_neq_0.
+apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+apply prod_neq_R0.
+apply pow_nonzero; discrR.
+apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply H1.
+apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
+assert (H0 := cond_pos r); red in |- *; intro; rewrite H1 in H0;
+ elim (Rlt_irrefl _ H0).
+Qed.
+
+(**********)
+Lemma continuity_cos : continuity cos.
+set (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)).
+cut (CVN_R fn).
+intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)).
+intro cv; cut (forall n:nat, continuity (fn n)).
+intro; cut (forall x:R, cos x = SFL fn cv x).
+intro; cut (continuity (SFL fn cv) -> continuity cos).
+intro; apply H1.
+apply SFL_continuity; assumption.
+unfold continuity in |- *; unfold continuity_pt in |- *;
+ unfold continue_in in |- *; unfold limit1_in in |- *;
+ unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+ intros.
+elim (H1 x _ H2); intros.
+exists x0; intros.
+elim H3; intros.
+split.
+apply H4.
+intros; rewrite (H0 x); rewrite (H0 x1); apply H5; apply H6.
+intro; unfold cos, SFL in |- *.
+case (cv x); case (exist_cos (Rsqr x)); intros.
+symmetry  in |- *; eapply UL_sequence.
+apply u.
+unfold cos_in in c; unfold infinit_sum in c; unfold Un_cv in |- *; intros.
+elim (c _ H0); intros N0 H1.
+exists N0; intros.
+unfold R_dist in H1; unfold R_dist, SP in |- *.
+replace (sum_f_R0 (fun k:nat => fn k x) n) with
+ (sum_f_R0 (fun i:nat => cos_n i * Rsqr x ^ i) n).
+apply H1; assumption.
+apply sum_eq; intros.
+unfold cos_n, fn in |- *; apply Rmult_eq_compat_l.
+unfold Rsqr in |- *; rewrite pow_sqr; reflexivity.
+intro; unfold fn in |- *;
+ replace (fun x:R => (-1) ^ n / INR (fact (2 * n)) * x ^ (2 * n)) with
+  (fct_cte ((-1) ^ n / INR (fact (2 * n))) * pow_fct (2 * n))%F;
+ [ idtac | reflexivity ].
+apply continuity_mult.
+apply derivable_continuous; apply derivable_const.
+apply derivable_continuous; apply (derivable_pow (2 * n)).
+apply CVN_R_CVS; apply X.
+apply CVN_R_cos; unfold fn in |- *; reflexivity.
+Qed.
+
+(**********)
+Lemma continuity_sin : continuity sin.
+unfold continuity in |- *; intro.
+assert (H0 := continuity_cos (PI / 2 - x)).
+unfold continuity_pt in H0; unfold continue_in in H0; unfold limit1_in in H0;
+ unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
+ unfold continuity_pt in |- *; unfold continue_in in |- *;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ simpl in |- *; unfold R_dist in |- *; intros.
+elim (H0 _ H); intros.
+exists x0; intros.
+elim H1; intros.
+split.
+assumption.
+intros; rewrite <- (cos_shift x); rewrite <- (cos_shift x1); apply H3.
+elim H4; intros.
+split.
+unfold D_x, no_cond in |- *; split.
+trivial.
+red in |- *; intro; unfold D_x, no_cond in H5; elim H5; intros _ H8; elim H8;
+ rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive x1);
+ apply Ropp_eq_compat; apply Rplus_eq_reg_l with (PI / 2); 
+ apply H7.
+replace (PI / 2 - x1 - (PI / 2 - x)) with (x - x1); [ idtac | ring ];
+ rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H6.
+Qed.
+
+Lemma CVN_R_sin :
+ forall fn:nat -> R -> R,
+   fn =
+   (fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N + 1)) * x ^ (2 * N)) ->
+   CVN_R fn.
+unfold CVN_R in |- *; unfold CVN_r in |- *; intros fn H r.
+apply existT with (fun n:nat => / INR (fact (2 * n + 1)) * r ^ (2 * n)).
+cut
+ (sigT
+    (fun l:R =>
+       Un_cv
+         (fun n:nat =>
+            sum_f_R0
+              (fun k:nat => Rabs (/ INR (fact (2 * k + 1)) * r ^ (2 * k))) n)
+         l)).
+intro; elim X; intros.
+apply existT with x.
+split.
+apply p.
+intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult;
+ rewrite pow_1_abs; rewrite Rmult_1_l.
+cut (0 < / INR (fact (2 * n + 1))).
+intro; rewrite (Rabs_right _ (Rle_ge _ _ (Rlt_le _ _ H1))).
+apply Rmult_le_compat_l.
+left; apply H1.
+rewrite <- RPow_abs; apply pow_maj_Rabs.
+rewrite Rabs_Rabsolu; unfold Boule in H0; rewrite Rminus_0_r in H0; left;
+ apply H0.
+apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+cut ((r:R) <> 0).
+intro; apply Alembert_C2.
+intro; apply Rabs_no_R0.
+apply prod_neq_R0.
+apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+apply pow_nonzero; assumption.
+assert (H1 := Alembert_sin).
+unfold sin_n in H1; unfold Un_cv in H1; unfold Un_cv in |- *; intros.
+cut (0 < eps / Rsqr r).
+intro; elim (H1 _ H3); intros N0 H4.
+exists N0; intros.
+unfold R_dist in |- *; assert (H6 := H4 _ H5).
+unfold R_dist in H5;
+ replace
+  (Rabs
+     (Rabs (/ INR (fact (2 * S n + 1)) * r ^ (2 * S n)) /
+      Rabs (/ INR (fact (2 * n + 1)) * r ^ (2 * n)))) with
+  (Rsqr r *
+   Rabs
+     ((-1) ^ S n / INR (fact (2 * S n + 1)) /
+      ((-1) ^ n / INR (fact (2 * n + 1))))).
+apply Rmult_lt_reg_l with (/ Rsqr r).
+apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
+pattern (/ Rsqr r) at 1 in |- *; rewrite <- (Rabs_right (/ Rsqr r)).
+rewrite <- Rabs_mult.
+rewrite Rmult_minus_distr_l.
+rewrite Rmult_0_r; rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; rewrite <- (Rmult_comm eps).
+apply H6.
+unfold Rsqr in |- *; apply prod_neq_R0; assumption.
+apply Rle_ge; left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
+unfold Rdiv in |- *; rewrite (Rmult_comm (Rsqr r)); repeat rewrite Rabs_mult;
+ rewrite Rabs_Rabsolu; rewrite pow_1_abs.
+rewrite Rmult_1_l.
+repeat rewrite Rmult_assoc; apply Rmult_eq_compat_l.
+rewrite Rinv_mult_distr.
+rewrite Rinv_involutive.
+rewrite Rabs_mult.
+rewrite Rabs_Rinv.
+rewrite pow_1_abs; rewrite Rinv_1; rewrite Rmult_1_l.
+rewrite Rinv_mult_distr.
+rewrite <- Rabs_Rinv.
+rewrite Rinv_involutive.
+rewrite Rabs_mult.
+do 2 rewrite Rabs_Rabsolu.
+rewrite (Rmult_comm (Rabs (r ^ (2 * S n)))).
+rewrite Rmult_assoc; apply Rmult_eq_compat_l.
+rewrite Rabs_Rinv.
+rewrite Rabs_Rabsolu.
+repeat rewrite Rabs_right.
+replace (r ^ (2 * S n)) with (r ^ (2 * n) * r * r).
+do 2 rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+unfold Rsqr in |- *; ring.
+apply pow_nonzero; assumption.
+replace (2 * S n)%nat with (S (S (2 * n))).
+simpl in |- *; ring.
+apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
+ ring.
+apply Rle_ge; apply pow_le; left; apply (cond_pos r).
+apply Rle_ge; apply pow_le; left; apply (cond_pos r).
+apply Rabs_no_R0; apply pow_nonzero; assumption.
+apply INR_fact_neq_0.
+apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+apply Rabs_no_R0; apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+apply Rabs_no_R0; apply pow_nonzero; assumption.
+apply pow_nonzero; discrR.
+apply INR_fact_neq_0.
+apply pow_nonzero; discrR.
+apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption ].
+assert (H0 := cond_pos r); red in |- *; intro; rewrite H1 in H0;
+ elim (Rlt_irrefl _ H0).
+Qed.
+
+(* (sin h)/h -> 1 when h -> 0 *)
+Lemma derivable_pt_lim_sin_0 : derivable_pt_lim sin 0 1.
+unfold derivable_pt_lim in |- *; intros.
+set
+ (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N + 1)) * x ^ (2 * N)).
+cut (CVN_R fn).
+intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)).
+intro cv.
+set (r := mkposreal _ Rlt_0_1).
+cut (CVN_r fn r).
+intro; cut (forall (n:nat) (y:R), Boule 0 r y -> continuity_pt (fn n) y).
+intro; cut (Boule 0 r 0).
+intro; assert (H2 := SFL_continuity_pt _ cv _ X0 H0 _ H1).
+unfold continuity_pt in H2; unfold continue_in in H2; unfold limit1_in in H2;
+ unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
+elim (H2 _ H); intros alp H3.
+elim H3; intros.
+exists (mkposreal _ H4).
+simpl in |- *; intros.
+rewrite sin_0; rewrite Rplus_0_l; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r.
+cut (Rabs (SFL fn cv h - SFL fn cv 0) < eps).
+intro; cut (SFL fn cv 0 = 1).
+intro; cut (SFL fn cv h = sin h / h).
+intro; rewrite H9 in H8; rewrite H10 in H8.
+apply H8.
+unfold SFL, sin in |- *.
+case (cv h); intros.
+case (exist_sin (Rsqr h)); intros.
+unfold Rdiv in |- *; rewrite (Rinv_r_simpl_m h x0 H6).
+eapply UL_sequence.
+apply u.
+unfold sin_in in s; unfold sin_n, infinit_sum in s;
+ unfold SP, fn, Un_cv in |- *; intros.
+elim (s _ H10); intros N0 H11.
+exists N0; intros.
+unfold R_dist in |- *; unfold R_dist in H11.
+replace
+ (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * h ^ (2 * k)) n)
+ with
+ (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * Rsqr h ^ i) n).
+apply H11; assumption.
+apply sum_eq; intros; apply Rmult_eq_compat_l; unfold Rsqr in |- *;
+ rewrite pow_sqr; reflexivity.
+unfold SFL, sin in |- *.
+case (cv 0); intros.
+eapply UL_sequence.
+apply u.
+unfold SP, fn in |- *; unfold Un_cv in |- *; intros; exists 1%nat; intros.
+unfold R_dist in |- *;
+ replace
+  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k)) n)
+  with 1.
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+rewrite decomp_sum.
+simpl in |- *; rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite Rinv_1;
+ rewrite Rmult_1_r; pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+ apply Rplus_eq_compat_l.
+symmetry  in |- *; apply sum_eq_R0; intros.
+rewrite Rmult_0_l; rewrite Rmult_0_r; reflexivity.
+unfold ge in H10; apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H10 ].
+apply H5.
+split.
+unfold D_x, no_cond in |- *; split.
+trivial.
+apply (sym_not_eq (A:=R)); apply H6.
+unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply H7.
+unfold Boule in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; rewrite Rabs_R0; apply (cond_pos r).
+intros; unfold fn in |- *;
+ replace (fun x:R => (-1) ^ n / INR (fact (2 * n + 1)) * x ^ (2 * n)) with
+  (fct_cte ((-1) ^ n / INR (fact (2 * n + 1))) * pow_fct (2 * n))%F;
+ [ idtac | reflexivity ].
+apply continuity_pt_mult.
+apply derivable_continuous_pt.
+apply derivable_pt_const.
+apply derivable_continuous_pt.
+apply (derivable_pt_pow (2 * n) y).
+apply (X r).
+apply (CVN_R_CVS _ X).
+apply CVN_R_sin; unfold fn in |- *; reflexivity.
+Qed.
+
+(* ((cos h)-1)/h -> 0 when h -> 0 *)
+Lemma derivable_pt_lim_cos_0 : derivable_pt_lim cos 0 0.
+unfold derivable_pt_lim in |- *; intros.
+assert (H0 := derivable_pt_lim_sin_0).
+unfold derivable_pt_lim in H0.
+cut (0 < eps / 2).
+intro; elim (H0 _ H1); intros del H2.
+cut (continuity_pt sin 0).
+intro; unfold continuity_pt in H3; unfold continue_in in H3;
+ unfold limit1_in in H3; unfold limit_in in H3; simpl in H3;
+ unfold R_dist in H3.
+cut (0 < eps / 2); [ intro | assumption ].
+elim (H3 _ H4); intros del_c H5.
+cut (0 < Rmin del del_c).
+intro; set (delta := mkposreal _ H6).
+exists delta; intros.
+rewrite Rplus_0_l; replace (cos h - cos 0) with (-2 * Rsqr (sin (h / 2))).
+unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
+unfold Rdiv in |- *; do 2 rewrite Ropp_mult_distr_l_reverse.
+rewrite Rabs_Ropp.
+replace (2 * Rsqr (sin (h * / 2)) * / h) with
+ (sin (h / 2) * (sin (h / 2) / (h / 2) - 1) + sin (h / 2)).
+apply Rle_lt_trans with
+ (Rabs (sin (h / 2) * (sin (h / 2) / (h / 2) - 1)) + Rabs (sin (h / 2))).
+apply Rabs_triang.
+rewrite (double_var eps); apply Rplus_lt_compat.
+apply Rle_lt_trans with (Rabs (sin (h / 2) / (h / 2) - 1)).
+rewrite Rabs_mult; rewrite Rmult_comm;
+ pattern (Rabs (sin (h / 2) / (h / 2) - 1)) at 2 in |- *;
+ rewrite <- Rmult_1_r; apply Rmult_le_compat_l.
+apply Rabs_pos.
+assert (H9 := SIN_bound (h / 2)).
+unfold Rabs in |- *; case (Rcase_abs (sin (h / 2))); intro.
+pattern 1 at 3 in |- *; rewrite <- (Ropp_involutive 1).
+apply Ropp_le_contravar.
+elim H9; intros; assumption.
+elim H9; intros; assumption.
+cut (Rabs (h / 2) < del).
+intro; cut (h / 2 <> 0).
+intro; assert (H11 := H2 _ H10 H9). 
+rewrite Rplus_0_l in H11; rewrite sin_0 in H11.
+rewrite Rminus_0_r in H11; apply H11.
+unfold Rdiv in |- *; apply prod_neq_R0.
+apply H7.
+apply Rinv_neq_0_compat; discrR.
+apply Rlt_trans with (del / 2).
+unfold Rdiv in |- *; rewrite Rabs_mult.
+rewrite (Rabs_right (/ 2)).
+do 2 rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
+apply Rinv_0_lt_compat; prove_sup0.
+apply Rlt_le_trans with (pos delta).
+apply H8.
+unfold delta in |- *; simpl in |- *; apply Rmin_l.
+apply Rle_ge; left; apply Rinv_0_lt_compat; prove_sup0.
+rewrite <- (Rplus_0_r (del / 2)); pattern del at 1 in |- *;
+ rewrite (double_var del); apply Rplus_lt_compat_l; 
+ unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply (cond_pos del).
+apply Rinv_0_lt_compat; prove_sup0.
+elim H5; intros; assert (H11 := H10 (h / 2)).
+rewrite sin_0 in H11; do 2 rewrite Rminus_0_r in H11.
+apply H11.
+split.
+unfold D_x, no_cond in |- *; split.
+trivial.
+apply (sym_not_eq (A:=R)); unfold Rdiv in |- *; apply prod_neq_R0.
+apply H7.
+apply Rinv_neq_0_compat; discrR.
+apply Rlt_trans with (del_c / 2).
+unfold Rdiv in |- *; rewrite Rabs_mult.
+rewrite (Rabs_right (/ 2)).
+do 2 rewrite <- (Rmult_comm (/ 2)).
+apply Rmult_lt_compat_l.
+apply Rinv_0_lt_compat; prove_sup0.
+apply Rlt_le_trans with (pos delta).
+apply H8.
+unfold delta in |- *; simpl in |- *; apply Rmin_r.
+apply Rle_ge; left; apply Rinv_0_lt_compat; prove_sup0.
+rewrite <- (Rplus_0_r (del_c / 2)); pattern del_c at 2 in |- *;
+ rewrite (double_var del_c); apply Rplus_lt_compat_l.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply H9.
+apply Rinv_0_lt_compat; prove_sup0.
+rewrite Rmult_minus_distr_l; rewrite Rmult_1_r; unfold Rminus in |- *;
+ rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
+ rewrite (Rmult_comm 2); unfold Rdiv, Rsqr in |- *.
+repeat rewrite Rmult_assoc.
+repeat apply Rmult_eq_compat_l.
+rewrite Rinv_mult_distr.
+rewrite Rinv_involutive.
+apply Rmult_comm.
+discrR.
+apply H7.
+apply Rinv_neq_0_compat; discrR.
+pattern h at 2 in |- *; replace h with (2 * (h / 2)).
+rewrite (cos_2a_sin (h / 2)).
+rewrite cos_0; unfold Rsqr in |- *; ring.
+unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
+discrR.
+unfold Rmin in |- *; case (Rle_dec del del_c); intro.
+apply (cond_pos del).
+elim H5; intros; assumption.
+apply continuity_sin.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+Qed.
+
+(**********)
+Theorem derivable_pt_lim_sin : forall x:R, derivable_pt_lim sin x (cos x).
+intro; assert (H0 := derivable_pt_lim_sin_0).
+assert (H := derivable_pt_lim_cos_0).
+unfold derivable_pt_lim in H0, H.
+unfold derivable_pt_lim in |- *; intros.
+cut (0 < eps / 2);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply H1 | apply Rinv_0_lt_compat; prove_sup0 ] ].
+elim (H0 _ H2); intros alp1 H3.
+elim (H _ H2); intros alp2 H4.
+set (alp := Rmin alp1 alp2).
+cut (0 < alp).
+intro; exists (mkposreal _ H5); intros.
+replace ((sin (x + h) - sin x) / h - cos x) with
+ (sin x * ((cos h - 1) / h) + cos x * (sin h / h - 1)).
+apply Rle_lt_trans with
+ (Rabs (sin x * ((cos h - 1) / h)) + Rabs (cos x * (sin h / h - 1))).
+apply Rabs_triang.
+rewrite (double_var eps); apply Rplus_lt_compat.
+apply Rle_lt_trans with (Rabs ((cos h - 1) / h)).
+rewrite Rabs_mult; rewrite Rmult_comm;
+ pattern (Rabs ((cos h - 1) / h)) at 2 in |- *; rewrite <- Rmult_1_r;
+ apply Rmult_le_compat_l.
+apply Rabs_pos.
+assert (H8 := SIN_bound x); elim H8; intros.
+unfold Rabs in |- *; case (Rcase_abs (sin x)); intro.
+rewrite <- (Ropp_involutive 1).
+apply Ropp_le_contravar; assumption.
+assumption.
+cut (Rabs h < alp2).
+intro; assert (H9 := H4 _ H6 H8).
+rewrite cos_0 in H9; rewrite Rplus_0_l in H9; rewrite Rminus_0_r in H9;
+ apply H9.
+apply Rlt_le_trans with alp.
+apply H7.
+unfold alp in |- *; apply Rmin_r.
+apply Rle_lt_trans with (Rabs (sin h / h - 1)).
+rewrite Rabs_mult; rewrite Rmult_comm;
+ pattern (Rabs (sin h / h - 1)) at 2 in |- *; rewrite <- Rmult_1_r;
+ apply Rmult_le_compat_l.
+apply Rabs_pos.
+assert (H8 := COS_bound x); elim H8; intros.
+unfold Rabs in |- *; case (Rcase_abs (cos x)); intro.
+rewrite <- (Ropp_involutive 1); apply Ropp_le_contravar; assumption.
+assumption.
+cut (Rabs h < alp1).
+intro; assert (H9 := H3 _ H6 H8).
+rewrite sin_0 in H9; rewrite Rplus_0_l in H9; rewrite Rminus_0_r in H9;
+ apply H9.
+apply Rlt_le_trans with alp.
+apply H7.
+unfold alp in |- *; apply Rmin_l.
+rewrite sin_plus; unfold Rminus, Rdiv in |- *;
+ repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
+ repeat rewrite Rmult_assoc; repeat rewrite Rplus_assoc;
+ apply Rplus_eq_compat_l.
+rewrite (Rplus_comm (sin x * (-1 * / h))); repeat rewrite Rplus_assoc;
+ apply Rplus_eq_compat_l.
+rewrite Ropp_mult_distr_r_reverse; rewrite Ropp_mult_distr_l_reverse;
+ rewrite Rmult_1_r; rewrite Rmult_1_l; rewrite Ropp_mult_distr_r_reverse;
+ rewrite <- Ropp_mult_distr_l_reverse; apply Rplus_comm.
+unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec alp1 alp2); intro.
+apply (cond_pos alp1).
+apply (cond_pos alp2).
+Qed.
+
+Lemma derivable_pt_lim_cos : forall x:R, derivable_pt_lim cos x (- sin x).
+intro; cut (forall h:R, sin (h + PI / 2) = cos h).
+intro; replace (- sin x) with (cos (x + PI / 2) * (1 + 0)).
+generalize (derivable_pt_lim_comp (id + fct_cte (PI / 2))%F sin); intros.
+cut (derivable_pt_lim (id + fct_cte (PI / 2)) x (1 + 0)).
+cut (derivable_pt_lim sin ((id + fct_cte (PI / 2))%F x) (cos (x + PI / 2))).
+intros; generalize (H0 _ _ _ H2 H1);
+ replace (comp sin (id + fct_cte (PI / 2))%F) with
+  (fun x:R => sin (x + PI / 2)); [ idtac | reflexivity ].
+unfold derivable_pt_lim in |- *; intros.
+elim (H3 eps H4); intros.
+exists x0.
+intros; rewrite <- (H (x + h)); rewrite <- (H x); apply H5; assumption.
+apply derivable_pt_lim_sin.
+apply derivable_pt_lim_plus.
+apply derivable_pt_lim_id.
+apply derivable_pt_lim_const.
+rewrite sin_cos; rewrite <- (Rplus_comm x); ring.
+intro; rewrite cos_sin; rewrite Rplus_comm; reflexivity.
+Qed.
+
+Lemma derivable_pt_sin : forall x:R, derivable_pt sin x.
+unfold derivable_pt in |- *; intro.
+apply existT with (cos x).
+apply derivable_pt_lim_sin.
+Qed.
+
+Lemma derivable_pt_cos : forall x:R, derivable_pt cos x.
+unfold derivable_pt in |- *; intro.
+apply existT with (- sin x).
+apply derivable_pt_lim_cos.
+Qed.
+
+Lemma derivable_sin : derivable sin.
+unfold derivable in |- *; intro; apply derivable_pt_sin.
+Qed.
+
+Lemma derivable_cos : derivable cos.
+unfold derivable in |- *; intro; apply derivable_pt_cos.
+Qed.
+
+Lemma derive_pt_sin :
+ forall x:R, derive_pt sin x (derivable_pt_sin _) = cos x.
+intros; apply derive_pt_eq_0.
+apply derivable_pt_lim_sin.
+Qed.
+
+Lemma derive_pt_cos :
+ forall x:R, derive_pt cos x (derivable_pt_cos _) = - sin x.
+intros; apply derive_pt_eq_0.
+apply derivable_pt_lim_cos.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v
new file mode 100644
index 00000000..34f9fd72
--- /dev/null
+++ b/theories/Reals/SeqProp.v
@@ -0,0 +1,1295 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: SeqProp.v,v 1.13.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import Classical.
+Require Import Max.
+Open Local Scope R_scope.
+
+Definition Un_decreasing (Un:nat -> R) : Prop :=
+  forall n:nat, Un (S n) <= Un n.
+Definition opp_seq (Un:nat -> R) (n:nat) : R := - Un n.
+Definition has_ub (Un:nat -> R) : Prop := bound (EUn Un).
+Definition has_lb (Un:nat -> R) : Prop := bound (EUn (opp_seq Un)).
+
+(**********)
+Lemma growing_cv :
+ forall Un:nat -> R,
+   Un_growing Un -> has_ub Un -> sigT (fun l:R => Un_cv Un l).
+unfold Un_growing, Un_cv in |- *; intros;
+ destruct (completeness (EUn Un) H0 (EUn_noempty Un)) as [x [H2 H3]].
+ exists x; intros eps H1.
+ unfold is_upper_bound in H2, H3.
+assert (H5 : forall n:nat, Un n <= x).
+  intro n; apply (H2 (Un n) (Un_in_EUn Un n)).
+cut (exists N : nat, x - eps < Un N).
+intro H6; destruct H6 as [N H6]; exists N.
+intros n H7; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps).
+unfold Rgt in H1.
+ apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H1).
+fold Un_growing in H; generalize (growing_prop Un n N H H7); intro H8.
+ generalize
+  (Rlt_le_trans (x - eps) (Un N) (Un n) H6 (Rge_le (Un n) (Un N) H8));
+  intro H9; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9);
+  unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps));
+  rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *;
+  rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2);
+  trivial.
+cut (~ (forall N:nat, Un N <= x - eps)).
+intro H6; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)).
+ intro H7; apply H6; intro N; apply Rnot_lt_le; apply H7.
+intro H7; generalize (Un_bound_imp Un (x - eps) H7); intro H8;
+ unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); 
+ apply Rlt_not_le; apply tech_Rgt_minus; exact H1.
+Qed.
+
+Lemma decreasing_growing :
+ forall Un:nat -> R, Un_decreasing Un -> Un_growing (opp_seq Un).
+intro.
+unfold Un_growing, opp_seq, Un_decreasing in |- *.
+intros.
+apply Ropp_le_contravar.
+apply H.
+Qed.
+
+Lemma decreasing_cv :
+ forall Un:nat -> R,
+   Un_decreasing Un -> has_lb Un -> sigT (fun l:R => Un_cv Un l).
+intros.
+cut (sigT (fun l:R => Un_cv (opp_seq Un) l) -> sigT (fun l:R => Un_cv Un l)).
+intro.
+apply X.
+apply growing_cv.
+apply decreasing_growing; assumption.
+exact H0.
+intro.
+elim X; intros.
+apply existT with (- x).
+unfold Un_cv in p.
+unfold R_dist in p.
+unfold opp_seq in p.
+unfold Un_cv in |- *.
+unfold R_dist in |- *.
+intros.
+elim (p eps H1); intros.
+exists x0; intros.
+assert (H4 := H2 n H3).
+rewrite <- Rabs_Ropp.
+replace (- (Un n - - x)) with (- Un n - x); [ assumption | ring ].
+Qed.
+
+(***********)
+Lemma maj_sup :
+ forall Un:nat -> R, has_ub Un -> sigT (fun l:R => is_lub (EUn Un) l).
+intros.
+unfold has_ub in H.
+apply completeness.
+assumption.
+exists (Un 0%nat).
+unfold EUn in |- *.
+exists 0%nat; reflexivity.
+Qed.
+
+(**********)
+Lemma min_inf :
+ forall Un:nat -> R,
+   has_lb Un -> sigT (fun l:R => is_lub (EUn (opp_seq Un)) l).
+intros; unfold has_lb in H.
+apply completeness.
+assumption.
+exists (- Un 0%nat).
+exists 0%nat.
+reflexivity.
+Qed.
+
+Definition majorant (Un:nat -> R) (pr:has_ub Un) : R :=
+  match maj_sup Un pr with
+  | existT a b => a
+  end.
+
+Definition minorant (Un:nat -> R) (pr:has_lb Un) : R :=
+  match min_inf Un pr with
+  | existT a b => - a
+  end.
+
+Lemma maj_ss :
+ forall (Un:nat -> R) (k:nat),
+   has_ub Un -> has_ub (fun i:nat => Un (k + i)%nat).
+intros.
+unfold has_ub in H.
+unfold bound in H.
+elim H; intros.
+unfold is_upper_bound in H0.
+unfold has_ub in |- *.
+exists x.
+unfold is_upper_bound in |- *.
+intros.
+apply H0.
+elim H1; intros.
+exists (k + x1)%nat; assumption.
+Qed.
+
+Lemma min_ss :
+ forall (Un:nat -> R) (k:nat),
+   has_lb Un -> has_lb (fun i:nat => Un (k + i)%nat).
+intros.
+unfold has_lb in H.
+unfold bound in H.
+elim H; intros.
+unfold is_upper_bound in H0.
+unfold has_lb in |- *.
+exists x.
+unfold is_upper_bound in |- *.
+intros.
+apply H0.
+elim H1; intros.
+exists (k + x1)%nat; assumption.
+Qed.
+
+Definition sequence_majorant (Un:nat -> R) (pr:has_ub Un) 
+  (i:nat) : R := majorant (fun k:nat => Un (i + k)%nat) (maj_ss Un i pr).
+
+Definition sequence_minorant (Un:nat -> R) (pr:has_lb Un) 
+  (i:nat) : R := minorant (fun k:nat => Un (i + k)%nat) (min_ss Un i pr).
+
+Lemma Wn_decreasing :
+ forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_majorant Un pr). 
+intros.
+unfold Un_decreasing in |- *.
+intro.
+unfold sequence_majorant in |- *.
+assert (H := maj_sup (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
+assert (H0 := maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
+elim H; intros.
+elim H0; intros.
+cut (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr) = x);
+ [ intro Maj1; rewrite Maj1 | idtac ].
+cut (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr) = x0);
+ [ intro Maj2; rewrite Maj2 | idtac ].
+unfold is_lub in p.
+unfold is_lub in p0.
+elim p; intros.
+apply H2.
+elim p0; intros.
+unfold is_upper_bound in |- *.
+intros.
+unfold is_upper_bound in H3.
+apply H3.
+elim H5; intros.
+exists (1 + x2)%nat.
+replace (n + (1 + x2))%nat with (S n + x2)%nat.
+assumption.
+replace (S n) with (1 + n)%nat; [ ring | ring ].
+cut
+ (is_lub (EUn (fun k:nat => Un (n + k)%nat))
+    (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr))).
+intro.
+unfold is_lub in p0; unfold is_lub in H1.
+elim p0; intros; elim H1; intros.
+assert (H6 := H5 x0 H2).
+assert
+ (H7 := H3 (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) H4).
+apply Rle_antisym; assumption.
+unfold majorant in |- *.
+case (maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
+trivial.
+cut
+ (is_lub (EUn (fun k:nat => Un (S n + k)%nat))
+    (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr))).
+intro.
+unfold is_lub in p; unfold is_lub in H1.
+elim p; intros; elim H1; intros.
+assert (H6 := H5 x H2).
+assert
+ (H7 :=
+  H3 (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) H4).
+apply Rle_antisym; assumption.
+unfold majorant in |- *.
+case (maj_sup (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
+trivial.
+Qed.
+
+Lemma Vn_growing :
+ forall (Un:nat -> R) (pr:has_lb Un), Un_growing (sequence_minorant Un pr).
+intros.
+unfold Un_growing in |- *.
+intro.
+unfold sequence_minorant in |- *.
+assert (H := min_inf (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)).
+assert (H0 := min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)).
+elim H; intros.
+elim H0; intros.
+cut (minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr) = - x);
+ [ intro Maj1; rewrite Maj1 | idtac ].
+cut (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr) = - x0);
+ [ intro Maj2; rewrite Maj2 | idtac ].
+unfold is_lub in p.
+unfold is_lub in p0.
+elim p; intros.
+apply Ropp_le_contravar.
+apply H2.
+elim p0; intros.
+unfold is_upper_bound in |- *.
+intros.
+unfold is_upper_bound in H3.
+apply H3.
+elim H5; intros.
+exists (1 + x2)%nat.
+unfold opp_seq in H6.
+unfold opp_seq in |- *.
+replace (n + (1 + x2))%nat with (S n + x2)%nat.
+assumption.
+replace (S n) with (1 + n)%nat; [ ring | ring ].
+cut
+ (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat)))
+    (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr))).
+intro.
+unfold is_lub in p0; unfold is_lub in H1.
+elim p0; intros; elim H1; intros.
+assert (H6 := H5 x0 H2).
+assert
+ (H7 := H3 (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)) H4).
+rewrite <-
+ (Ropp_involutive (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)))
+ .
+apply Ropp_eq_compat; apply Rle_antisym; assumption.
+unfold minorant in |- *.
+case (min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)).
+intro; rewrite Ropp_involutive.
+trivial.
+cut
+ (is_lub (EUn (opp_seq (fun k:nat => Un (S n + k)%nat)))
+    (- minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr))).
+intro.
+unfold is_lub in p; unfold is_lub in H1.
+elim p; intros; elim H1; intros.
+assert (H6 := H5 x H2).
+assert
+ (H7 :=
+  H3 (- minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)) H4).
+rewrite <-
+ (Ropp_involutive
+    (minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)))
+ .
+apply Ropp_eq_compat; apply Rle_antisym; assumption.
+unfold minorant in |- *.
+case (min_inf (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)).
+intro; rewrite Ropp_involutive.
+trivial.
+Qed.
+
+(**********)
+Lemma Vn_Un_Wn_order :
+ forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un) 
+   (n:nat), sequence_minorant Un pr2 n <= Un n <= sequence_majorant Un pr1 n. 
+intros.
+split.
+unfold sequence_minorant in |- *.
+cut
+ (sigT (fun l:R => is_lub (EUn (opp_seq (fun i:nat => Un (n + i)%nat))) l)).
+intro.
+elim X; intros.
+replace (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) with (- x).
+unfold is_lub in p.
+elim p; intros.
+unfold is_upper_bound in H.
+rewrite <- (Ropp_involutive (Un n)).
+apply Ropp_le_contravar.
+apply H.
+exists 0%nat.
+unfold opp_seq in |- *.
+replace (n + 0)%nat with n; [ reflexivity | ring ].
+cut
+ (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat)))
+    (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2))).
+intro.
+unfold is_lub in p; unfold is_lub in H.
+elim p; intros; elim H; intros.
+assert (H4 := H3 x H0).
+assert
+ (H5 := H1 (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) H2).
+rewrite <-
+ (Ropp_involutive (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)))
+ .
+apply Ropp_eq_compat; apply Rle_antisym; assumption.
+unfold minorant in |- *.
+case (min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)).
+intro; rewrite Ropp_involutive.
+trivial.
+apply min_inf.
+apply min_ss; assumption.
+unfold sequence_majorant in |- *.
+cut (sigT (fun l:R => is_lub (EUn (fun i:nat => Un (n + i)%nat)) l)).
+intro.
+elim X; intros.
+replace (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) with x.
+unfold is_lub in p.
+elim p; intros.
+unfold is_upper_bound in H.
+apply H.
+exists 0%nat.
+replace (n + 0)%nat with n; [ reflexivity | ring ].
+cut
+ (is_lub (EUn (fun k:nat => Un (n + k)%nat))
+    (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1))).
+intro.
+unfold is_lub in p; unfold is_lub in H.
+elim p; intros; elim H; intros.
+assert (H4 := H3 x H0).
+assert
+ (H5 := H1 (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) H2).
+apply Rle_antisym; assumption.
+unfold majorant in |- *.
+case (maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)).
+intro; trivial.
+apply maj_sup.
+apply maj_ss; assumption.
+Qed.
+
+Lemma min_maj :
+ forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un),
+   has_ub (sequence_minorant Un pr2).
+intros.
+assert (H := Vn_Un_Wn_order Un pr1 pr2).
+unfold has_ub in |- *.
+unfold bound in |- *.
+unfold has_ub in pr1.
+unfold bound in pr1.
+elim pr1; intros.
+exists x.
+unfold is_upper_bound in |- *.
+intros.
+unfold is_upper_bound in H0.
+elim H1; intros.
+rewrite H2.
+apply Rle_trans with (Un x1).
+assert (H3 := H x1); elim H3; intros; assumption.
+apply H0.
+exists x1; reflexivity.
+Qed.
+
+Lemma maj_min :
+ forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un),
+   has_lb (sequence_majorant Un pr1). 
+intros.
+assert (H := Vn_Un_Wn_order Un pr1 pr2).
+unfold has_lb in |- *.
+unfold bound in |- *.
+unfold has_lb in pr2.
+unfold bound in pr2.
+elim pr2; intros.
+exists x.
+unfold is_upper_bound in |- *.
+intros.
+unfold is_upper_bound in H0.
+elim H1; intros.
+rewrite H2.
+apply Rle_trans with (opp_seq Un x1).
+assert (H3 := H x1); elim H3; intros.
+unfold opp_seq in |- *; apply Ropp_le_contravar.
+assumption.
+apply H0.
+exists x1; reflexivity.
+Qed.
+
+(**********)
+Lemma cauchy_maj : forall Un:nat -> R, Cauchy_crit Un -> has_ub Un.
+intros.
+unfold has_ub in |- *.
+apply cauchy_bound.
+assumption.
+Qed.
+
+(**********)
+Lemma cauchy_opp :
+ forall Un:nat -> R, Cauchy_crit Un -> Cauchy_crit (opp_seq Un).
+intro.
+unfold Cauchy_crit in |- *.
+unfold R_dist in |- *.
+intros.
+elim (H eps H0); intros.
+exists x; intros.
+unfold opp_seq in |- *.
+rewrite <- Rabs_Ropp.
+replace (- (- Un n - - Un m)) with (Un n - Un m);
+ [ apply H1; assumption | ring ].
+Qed.
+
+(**********)
+Lemma cauchy_min : forall Un:nat -> R, Cauchy_crit Un -> has_lb Un.
+intros.
+unfold has_lb in |- *.
+assert (H0 := cauchy_opp _ H).
+apply cauchy_bound.
+assumption.
+Qed.
+
+(**********)
+Lemma maj_cv :
+ forall (Un:nat -> R) (pr:Cauchy_crit Un),
+   sigT (fun l:R => Un_cv (sequence_majorant Un (cauchy_maj Un pr)) l).
+intros.
+apply decreasing_cv.
+apply Wn_decreasing.
+apply maj_min.
+apply cauchy_min.
+assumption.
+Qed.
+
+(**********)
+Lemma min_cv :
+ forall (Un:nat -> R) (pr:Cauchy_crit Un),
+   sigT (fun l:R => Un_cv (sequence_minorant Un (cauchy_min Un pr)) l).
+intros.
+apply growing_cv.
+apply Vn_growing.
+apply min_maj.
+apply cauchy_maj.
+assumption.
+Qed.
+
+Lemma cond_eq :
+ forall x y:R, (forall eps:R, 0 < eps -> Rabs (x - y) < eps) -> x = y.
+intros.
+case (total_order_T x y); intro.
+elim s; intro.
+cut (0 < y - x).
+intro.
+assert (H1 := H (y - x) H0).
+rewrite <- Rabs_Ropp in H1.
+cut (- (x - y) = y - x); [ intro; rewrite H2 in H1 | ring ].
+rewrite Rabs_right in H1.
+elim (Rlt_irrefl _ H1).
+left; assumption.
+apply Rplus_lt_reg_r with x.
+rewrite Rplus_0_r; replace (x + (y - x)) with y; [ assumption | ring ].
+assumption.
+cut (0 < x - y).
+intro.
+assert (H1 := H (x - y) H0).
+rewrite Rabs_right in H1.
+elim (Rlt_irrefl _ H1).
+left; assumption.
+apply Rplus_lt_reg_r with y.
+rewrite Rplus_0_r; replace (y + (x - y)) with x; [ assumption | ring ].
+Qed.
+
+Lemma not_Rlt : forall r1 r2:R, ~ r1 < r2 -> r1 >= r2.
+intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rge in |- *.
+tauto.
+Qed. 
+
+(**********)
+Lemma approx_maj :
+ forall (Un:nat -> R) (pr:has_ub Un) (eps:R),
+   0 < eps ->  exists k : nat, Rabs (majorant Un pr - Un k) < eps.
+intros.
+set (P := fun k:nat => Rabs (majorant Un pr - Un k) < eps).
+unfold P in |- *.
+cut
+ ((exists k : nat, P k) ->
+   exists k : nat, Rabs (majorant Un pr - Un k) < eps).
+intros.
+apply H0.
+apply not_all_not_ex.
+red in |- *; intro.
+2: unfold P in |- *; trivial.
+unfold P in H1.
+cut (forall n:nat, Rabs (majorant Un pr - Un n) >= eps).
+intro.
+cut (is_lub (EUn Un) (majorant Un pr)).
+intro.
+unfold is_lub in H3.
+unfold is_upper_bound in H3.
+elim H3; intros.
+cut (forall n:nat, eps <= majorant Un pr - Un n).
+intro.
+cut (forall n:nat, Un n <= majorant Un pr - eps).
+intro.
+cut (forall x:R, EUn Un x -> x <= majorant Un pr - eps).
+intro.
+assert (H9 := H5 (majorant Un pr - eps) H8).
+cut (eps <= 0).
+intro.
+elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)).
+apply Rplus_le_reg_l with (majorant Un pr - eps).
+rewrite Rplus_0_r.
+replace (majorant Un pr - eps + eps) with (majorant Un pr);
+ [ assumption | ring ].
+intros.
+unfold EUn in H8.
+elim H8; intros.
+rewrite H9; apply H7.
+intro.
+assert (H7 := H6 n).
+apply Rplus_le_reg_l with (eps - Un n).
+replace (eps - Un n + Un n) with eps.
+replace (eps - Un n + (majorant Un pr - eps)) with (majorant Un pr - Un n).
+assumption.
+ring.
+ring.
+intro.
+assert (H6 := H2 n).
+rewrite Rabs_right in H6.
+apply Rge_le.
+assumption.
+apply Rle_ge.
+apply Rplus_le_reg_l with (Un n).
+rewrite Rplus_0_r;
+ replace (Un n + (majorant Un pr - Un n)) with (majorant Un pr);
+ [ apply H4 | ring ].
+exists n; reflexivity.
+unfold majorant in |- *.
+case (maj_sup Un pr).
+trivial.
+intro.
+assert (H2 := H1 n).
+apply not_Rlt; assumption.
+Qed.
+
+(**********)
+Lemma approx_min :
+ forall (Un:nat -> R) (pr:has_lb Un) (eps:R),
+   0 < eps ->  exists k : nat, Rabs (minorant Un pr - Un k) < eps.
+intros.
+set (P := fun k:nat => Rabs (minorant Un pr - Un k) < eps).
+unfold P in |- *.
+cut
+ ((exists k : nat, P k) ->
+   exists k : nat, Rabs (minorant Un pr - Un k) < eps).
+intros.
+apply H0.
+apply not_all_not_ex.
+red in |- *; intro.
+2: unfold P in |- *; trivial.
+unfold P in H1.
+cut (forall n:nat, Rabs (minorant Un pr - Un n) >= eps).
+intro.
+cut (is_lub (EUn (opp_seq Un)) (- minorant Un pr)).
+intro.
+unfold is_lub in H3.
+unfold is_upper_bound in H3.
+elim H3; intros.
+cut (forall n:nat, eps <= Un n - minorant Un pr).
+intro.
+cut (forall n:nat, opp_seq Un n <= - minorant Un pr - eps).
+intro.
+cut (forall x:R, EUn (opp_seq Un) x -> x <= - minorant Un pr - eps).
+intro.
+assert (H9 := H5 (- minorant Un pr - eps) H8).
+cut (eps <= 0).
+intro.
+elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)).
+apply Rplus_le_reg_l with (- minorant Un pr - eps).
+rewrite Rplus_0_r.
+replace (- minorant Un pr - eps + eps) with (- minorant Un pr);
+ [ assumption | ring ].
+intros.
+unfold EUn in H8.
+elim H8; intros.
+rewrite H9; apply H7.
+intro.
+assert (H7 := H6 n).
+unfold opp_seq in |- *.
+apply Rplus_le_reg_l with (eps + Un n).
+replace (eps + Un n + - Un n) with eps.
+replace (eps + Un n + (- minorant Un pr - eps)) with (Un n - minorant Un pr).
+assumption.
+ring.
+ring.
+intro.
+assert (H6 := H2 n).
+rewrite Rabs_left1 in H6.
+apply Rge_le.
+replace (Un n - minorant Un pr) with (- (minorant Un pr - Un n));
+ [ assumption | ring ].
+apply Rplus_le_reg_l with (- minorant Un pr).
+rewrite Rplus_0_r;
+ replace (- minorant Un pr + (minorant Un pr - Un n)) with (- Un n).
+apply H4.
+exists n; reflexivity.
+ring.
+unfold minorant in |- *.
+case (min_inf Un pr).
+intro.
+rewrite Ropp_involutive.
+trivial.
+intro.
+assert (H2 := H1 n).
+apply not_Rlt; assumption.
+Qed.
+
+(* Unicity of limit for convergent sequences *) 
+Lemma UL_sequence :
+ forall (Un:nat -> R) (l1 l2:R), Un_cv Un l1 -> Un_cv Un l2 -> l1 = l2. 
+intros Un l1 l2; unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
+apply cond_eq. 
+intros; cut (0 < eps / 2);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. 
+elim (H (eps / 2) H2); intros. 
+elim (H0 (eps / 2) H2); intros. 
+set (N := max x x0). 
+apply Rle_lt_trans with (Rabs (l1 - Un N) + Rabs (Un N - l2)). 
+replace (l1 - l2) with (l1 - Un N + (Un N - l2));
+ [ apply Rabs_triang | ring ]. 
+rewrite (double_var eps); apply Rplus_lt_compat. 
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H3;
+ unfold ge, N in |- *; apply le_max_l. 
+apply H4; unfold ge, N in |- *; apply le_max_r. 
+Qed.
+
+(**********) 
+Lemma CV_plus :
+ forall (An Bn:nat -> R) (l1 l2:R),
+   Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i + Bn i) (l1 + l2). 
+unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
+cut (0 < eps / 2);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. 
+elim (H (eps / 2) H2); intros. 
+elim (H0 (eps / 2) H2); intros. 
+set (N := max x x0). 
+exists N; intros. 
+replace (An n + Bn n - (l1 + l2)) with (An n - l1 + (Bn n - l2));
+ [ idtac | ring ]. 
+apply Rle_lt_trans with (Rabs (An n - l1) + Rabs (Bn n - l2)). 
+apply Rabs_triang. 
+rewrite (double_var eps); apply Rplus_lt_compat. 
+apply H3; unfold ge in |- *; apply le_trans with N;
+ [ unfold N in |- *; apply le_max_l | assumption ]. 
+apply H4; unfold ge in |- *; apply le_trans with N;
+ [ unfold N in |- *; apply le_max_r | assumption ]. 
+Qed.
+
+(**********) 
+Lemma cv_cvabs :
+ forall (Un:nat -> R) (l:R),
+   Un_cv Un l -> Un_cv (fun i:nat => Rabs (Un i)) (Rabs l). 
+unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
+elim (H eps H0); intros. 
+exists x; intros. 
+apply Rle_lt_trans with (Rabs (Un n - l)). 
+apply Rabs_triang_inv2. 
+apply H1; assumption. 
+Qed. 
+
+(**********) 
+Lemma CV_Cauchy :
+ forall Un:nat -> R, sigT (fun l:R => Un_cv Un l) -> Cauchy_crit Un. 
+intros; elim X; intros. 
+unfold Cauchy_crit in |- *; intros. 
+unfold Un_cv in p; unfold R_dist in p. 
+cut (0 < eps / 2);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. 
+elim (p (eps / 2) H0); intros. 
+exists x0; intros. 
+unfold R_dist in |- *;
+ apply Rle_lt_trans with (Rabs (Un n - x) + Rabs (x - Un m)). 
+replace (Un n - Un m) with (Un n - x + (x - Un m));
+ [ apply Rabs_triang | ring ]. 
+rewrite (double_var eps); apply Rplus_lt_compat. 
+apply H1; assumption. 
+rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H1; assumption. 
+Qed. 
+
+(**********)
+Lemma maj_by_pos :
+ forall Un:nat -> R,
+   sigT (fun l:R => Un_cv Un l) ->
+    exists l : R, 0 < l /\ (forall n:nat, Rabs (Un n) <= l). 
+intros; elim X; intros. 
+cut (sigT (fun l:R => Un_cv (fun k:nat => Rabs (Un k)) l)). 
+intro. 
+assert (H := CV_Cauchy (fun k:nat => Rabs (Un k)) X0). 
+assert (H0 := cauchy_bound (fun k:nat => Rabs (Un k)) H). 
+elim H0; intros. 
+exists (x0 + 1). 
+cut (0 <= x0). 
+intro. 
+split. 
+apply Rplus_le_lt_0_compat; [ assumption | apply Rlt_0_1 ]. 
+intros. 
+apply Rle_trans with x0. 
+unfold is_upper_bound in H1. 
+apply H1. 
+exists n; reflexivity. 
+pattern x0 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+ apply Rlt_0_1. 
+apply Rle_trans with (Rabs (Un 0%nat)). 
+apply Rabs_pos. 
+unfold is_upper_bound in H1. 
+apply H1. 
+exists 0%nat; reflexivity. 
+apply existT with (Rabs x). 
+apply cv_cvabs; assumption. 
+Qed. 
+ 
+(**********) 
+Lemma CV_mult :
+ forall (An Bn:nat -> R) (l1 l2:R),
+   Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i * Bn i) (l1 * l2). 
+intros. 
+cut (sigT (fun l:R => Un_cv An l)). 
+intro. 
+assert (H1 := maj_by_pos An X). 
+elim H1; intros M H2. 
+elim H2; intros. 
+unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
+cut (0 < eps / (2 * M)). 
+intro. 
+case (Req_dec l2 0); intro. 
+unfold Un_cv in H0; unfold R_dist in H0. 
+elim (H0 (eps / (2 * M)) H6); intros. 
+exists x; intros. 
+apply Rle_lt_trans with
+ (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)). 
+replace (An n * Bn n - l1 * l2) with
+ (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2));
+ [ apply Rabs_triang | ring ]. 
+replace (Rabs (An n * Bn n - An n * l2)) with
+ (Rabs (An n) * Rabs (Bn n - l2)). 
+replace (Rabs (An n * l2 - l1 * l2)) with 0. 
+rewrite Rplus_0_r. 
+apply Rle_lt_trans with (M * Rabs (Bn n - l2)). 
+do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))). 
+apply Rmult_le_compat_l. 
+apply Rabs_pos. 
+apply H4. 
+apply Rmult_lt_reg_l with (/ M). 
+apply Rinv_0_lt_compat; apply H3. 
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. 
+rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)). 
+apply Rlt_trans with (eps / (2 * M)). 
+apply H8; assumption. 
+unfold Rdiv in |- *; rewrite Rinv_mult_distr. 
+apply Rmult_lt_reg_l with 2. 
+prove_sup0.
+replace (2 * (eps * (/ 2 * / M))) with (2 * / 2 * (eps * / M));
+ [ idtac | ring ]. 
+rewrite <- Rinv_r_sym. 
+rewrite Rmult_1_l; rewrite double. 
+pattern (eps * / M) at 1 in |- *; rewrite <- Rplus_0_r. 
+apply Rplus_lt_compat_l; apply Rmult_lt_0_compat;
+ [ assumption | apply Rinv_0_lt_compat; assumption ]. 
+discrR. 
+discrR. 
+red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3). 
+red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3). 
+rewrite H7; do 2 rewrite Rmult_0_r; unfold Rminus in |- *;
+ rewrite Rplus_opp_r; rewrite Rabs_R0; reflexivity. 
+replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2)); [ idtac | ring ]. 
+symmetry  in |- *; apply Rabs_mult. 
+cut (0 < eps / (2 * Rabs l2)). 
+intro. 
+unfold Un_cv in H; unfold R_dist in H; unfold Un_cv in H0;
+ unfold R_dist in H0. 
+elim (H (eps / (2 * Rabs l2)) H8); intros N1 H9. 
+elim (H0 (eps / (2 * M)) H6); intros N2 H10. 
+set (N := max N1 N2). 
+exists N; intros. 
+apply Rle_lt_trans with
+ (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)). 
+replace (An n * Bn n - l1 * l2) with
+ (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2));
+ [ apply Rabs_triang | ring ]. 
+replace (Rabs (An n * Bn n - An n * l2)) with
+ (Rabs (An n) * Rabs (Bn n - l2)). 
+replace (Rabs (An n * l2 - l1 * l2)) with (Rabs l2 * Rabs (An n - l1)). 
+rewrite (double_var eps); apply Rplus_lt_compat. 
+apply Rle_lt_trans with (M * Rabs (Bn n - l2)). 
+do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))). 
+apply Rmult_le_compat_l. 
+apply Rabs_pos. 
+apply H4. 
+apply Rmult_lt_reg_l with (/ M). 
+apply Rinv_0_lt_compat; apply H3. 
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. 
+rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)). 
+apply Rlt_le_trans with (eps / (2 * M)). 
+apply H10. 
+unfold ge in |- *; apply le_trans with N. 
+unfold N in |- *; apply le_max_r. 
+assumption. 
+unfold Rdiv in |- *; rewrite Rinv_mult_distr. 
+right; ring. 
+discrR. 
+red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3). 
+red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3). 
+apply Rmult_lt_reg_l with (/ Rabs l2). 
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. 
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. 
+rewrite Rmult_1_l; apply Rlt_le_trans with (eps / (2 * Rabs l2)). 
+apply H9. 
+unfold ge in |- *; apply le_trans with N. 
+unfold N in |- *; apply le_max_l. 
+assumption. 
+unfold Rdiv in |- *; right; rewrite Rinv_mult_distr. 
+ring. 
+discrR. 
+apply Rabs_no_R0; assumption. 
+apply Rabs_no_R0; assumption. 
+replace (An n * l2 - l1 * l2) with (l2 * (An n - l1));
+ [ symmetry  in |- *; apply Rabs_mult | ring ]. 
+replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2));
+ [ symmetry  in |- *; apply Rabs_mult | ring ]. 
+unfold Rdiv in |- *; apply Rmult_lt_0_compat. 
+assumption. 
+apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
+ [ prove_sup0 | apply Rabs_pos_lt; assumption ]. 
+unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ [ assumption
+ | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
+    [ prove_sup0 | assumption ] ]. 
+apply existT with l1; assumption. 
+Qed. 
+
+Lemma tech9 :
+ forall Un:nat -> R,
+   Un_growing Un -> forall m n:nat, (m <= n)%nat -> Un m <= Un n.
+intros; unfold Un_growing in H.
+induction  n as [| n Hrecn].
+induction  m as [| m Hrecm].
+right; reflexivity.
+elim (le_Sn_O _ H0).
+cut ((m <= n)%nat \/ m = S n).
+intro; elim H1; intro.
+apply Rle_trans with (Un n).
+apply Hrecn; assumption.
+apply H.
+rewrite H2; right; reflexivity.
+inversion H0.
+right; reflexivity.
+left; assumption.
+Qed.
+
+Lemma tech10 :
+ forall (Un:nat -> R) (x:R), Un_growing Un -> is_lub (EUn Un) x -> Un_cv Un x.
+intros; cut (bound (EUn Un)).
+intro; assert (H2 := Un_cv_crit _ H H1).
+elim H2; intros.
+case (total_order_T x x0); intro.
+elim s; intro.
+cut (forall n:nat, Un n <= x).
+intro; unfold Un_cv in H3; cut (0 < x0 - x).
+intro; elim (H3 (x0 - x) H5); intros.
+cut (x1 >= x1)%nat.
+intro; assert (H8 := H6 x1 H7).
+unfold R_dist in H8; rewrite Rabs_left1 in H8.
+rewrite Ropp_minus_distr in H8; unfold Rminus in H8.
+assert (H9 := Rplus_lt_reg_r x0 _ _ H8).
+assert (H10 := Ropp_lt_cancel _ _ H9).
+assert (H11 := H4 x1).
+elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H11)).
+apply Rle_minus; apply Rle_trans with x.
+apply H4.
+left; assumption.
+unfold ge in |- *; apply le_n.
+apply Rgt_minus; assumption.
+intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros.
+apply H4; unfold EUn in |- *; exists n; reflexivity.
+rewrite b; assumption.
+cut (forall n:nat, Un n <= x0).
+intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros.
+cut (forall y:R, EUn Un y -> y <= x0).
+intro; assert (H8 := H6 _ H7). 
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H8 r)).
+unfold EUn in |- *; intros; elim H7; intros.
+rewrite H8; apply H4.
+intro; case (Rle_dec (Un n) x0); intro.
+assumption.
+cut (forall n0:nat, (n <= n0)%nat -> x0 < Un n0). 
+intro; unfold Un_cv in H3; cut (0 < Un n - x0).
+intro; elim (H3 (Un n - x0) H5); intros.
+cut (max n x1 >= x1)%nat.
+intro; assert (H8 := H6 (max n x1) H7).
+unfold R_dist in H8.
+rewrite Rabs_right in H8.
+unfold Rminus in H8; do 2 rewrite <- (Rplus_comm (- x0)) in H8.
+assert (H9 := Rplus_lt_reg_r _ _ _ H8).
+cut (Un n <= Un (max n x1)).
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H9)).
+apply tech9; [ assumption | apply le_max_l ].
+apply Rge_trans with (Un n - x0).
+unfold Rminus in |- *; apply Rle_ge; do 2 rewrite <- (Rplus_comm (- x0));
+ apply Rplus_le_compat_l.
+apply tech9; [ assumption | apply le_max_l ].
+left; assumption.
+unfold ge in |- *; apply le_max_r.
+apply Rplus_lt_reg_r with x0.
+rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm x0);
+ rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
+ apply H4; apply le_n.
+intros; apply Rlt_le_trans with (Un n).
+case (Rlt_le_dec x0 (Un n)); intro.
+assumption.
+elim n0; assumption.
+apply tech9; assumption.
+unfold bound in |- *; exists x; unfold is_lub in H0; elim H0; intros;
+ assumption.
+Qed.
+
+Lemma tech13 :
+ forall (An:nat -> R) (k:R),
+   0 <= k < 1 ->
+   Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
+    exists k0 : R,
+     k < k0 < 1 /\
+     (exists N : nat,
+        (forall n:nat, (N <= n)%nat -> Rabs (An (S n) / An n) < k0)).
+intros; exists (k + (1 - k) / 2).
+split.
+split.
+pattern k at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; replace (k + (1 - k)) with 1;
+ [ elim H; intros; assumption | ring ].
+apply Rinv_0_lt_compat; prove_sup0.
+apply Rmult_lt_reg_l with 2.
+prove_sup0.
+unfold Rdiv in |- *; rewrite Rmult_1_r; rewrite Rmult_plus_distr_l;
+ pattern 2 at 1 in |- *; rewrite Rmult_comm; rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym; [ idtac | discrR ]; rewrite Rmult_1_r;
+ replace (2 * k + (1 - k)) with (1 + k); [ idtac | ring ].
+elim H; intros.
+apply Rplus_lt_compat_l; assumption.
+unfold Un_cv in H0; cut (0 < (1 - k) / 2).
+intro; elim (H0 ((1 - k) / 2) H1); intros.
+exists x; intros.
+assert (H4 := H2 n H3).
+unfold R_dist in H4; rewrite <- Rabs_Rabsolu;
+ replace (Rabs (An (S n) / An n)) with (Rabs (An (S n) / An n) - k + k);
+ [ idtac | ring ];
+ apply Rle_lt_trans with (Rabs (Rabs (An (S n) / An n) - k) + Rabs k).
+apply Rabs_triang.
+rewrite (Rabs_right k).
+apply Rplus_lt_reg_r with (- k); rewrite <- (Rplus_comm k);
+ repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; 
+ repeat rewrite Rplus_0_l; apply H4.
+apply Rle_ge; elim H; intros; assumption.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; elim H; intros;
+ replace (k + (1 - k)) with 1; [ assumption | ring ].
+apply Rinv_0_lt_compat; prove_sup0.
+Qed.
+
+(**********)
+Lemma growing_ineq :
+ forall (Un:nat -> R) (l:R),
+   Un_growing Un -> Un_cv Un l -> forall n:nat, Un n <= l. 
+intros; case (total_order_T (Un n) l); intro.
+elim s; intro.
+left; assumption.
+right; assumption.
+cut (0 < Un n - l).
+intro; unfold Un_cv in H0; unfold R_dist in H0.
+elim (H0 (Un n - l) H1); intros N1 H2.
+set (N := max n N1).
+cut (Un n - l <= Un N - l).
+intro; cut (Un N - l < Un n - l).
+intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 H4)).
+apply Rle_lt_trans with (Rabs (Un N - l)).
+apply RRle_abs.
+apply H2.
+unfold ge, N in |- *; apply le_max_r.
+unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- l));
+ apply Rplus_le_compat_l.
+apply tech9.
+assumption.
+unfold N in |- *; apply le_max_l.
+apply Rplus_lt_reg_r with l.
+rewrite Rplus_0_r.
+replace (l + (Un n - l)) with (Un n); [ assumption | ring ].
+Qed.
+
+(* Un->l => (-Un) -> (-l) *)
+Lemma CV_opp :
+ forall (An:nat -> R) (l:R), Un_cv An l -> Un_cv (opp_seq An) (- l).
+intros An l.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+elim (H eps H0); intros.
+exists x; intros.
+unfold opp_seq in |- *; replace (- An n - - l) with (- (An n - l));
+ [ rewrite Rabs_Ropp | ring ].
+apply H1; assumption.
+Qed.
+
+(**********)
+Lemma decreasing_ineq :
+ forall (Un:nat -> R) (l:R),
+   Un_decreasing Un -> Un_cv Un l -> forall n:nat, l <= Un n.
+intros.
+assert (H1 := decreasing_growing _ H).
+assert (H2 := CV_opp _ _ H0).
+assert (H3 := growing_ineq _ _ H1 H2).
+apply Ropp_le_cancel.
+unfold opp_seq in H3; apply H3.
+Qed.
+
+(**********)
+Lemma CV_minus :
+ forall (An Bn:nat -> R) (l1 l2:R),
+   Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i - Bn i) (l1 - l2). 
+intros. 
+replace (fun i:nat => An i - Bn i) with (fun i:nat => An i + opp_seq Bn i). 
+unfold Rminus in |- *; apply CV_plus. 
+assumption. 
+apply CV_opp; assumption. 
+unfold Rminus, opp_seq in |- *; reflexivity. 
+Qed. 
+
+(* Un -> +oo *)
+Definition cv_infty (Un:nat -> R) : Prop :=
+  forall M:R,  exists N : nat, (forall n:nat, (N <= n)%nat -> M < Un n).
+
+(* Un -> +oo => /Un -> O *)
+Lemma cv_infty_cv_R0 :
+ forall Un:nat -> R,
+   (forall n:nat, Un n <> 0) -> cv_infty Un -> Un_cv (fun n:nat => / Un n) 0.
+unfold cv_infty, Un_cv in |- *; unfold R_dist in |- *; intros.
+elim (H0 (/ eps)); intros N0 H2.
+exists N0; intros.
+unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+ rewrite (Rabs_Rinv _ (H n)).
+apply Rmult_lt_reg_l with (Rabs (Un n)).
+apply Rabs_pos_lt; apply H.
+rewrite <- Rinv_r_sym.
+apply Rmult_lt_reg_l with (/ eps).
+apply Rinv_0_lt_compat; assumption.
+rewrite Rmult_1_r; rewrite (Rmult_comm (/ eps)); rewrite Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; apply Rlt_le_trans with (Un n).
+apply H2; assumption.
+apply RRle_abs.
+red in |- *; intro; rewrite H4 in H1; elim (Rlt_irrefl _ H1).
+apply Rabs_no_R0; apply H.
+Qed.
+
+(**********)
+Lemma decreasing_prop :
+ forall (Un:nat -> R) (m n:nat),
+   Un_decreasing Un -> (m <= n)%nat -> Un n <= Un m.
+unfold Un_decreasing in |- *; intros.
+induction  n as [| n Hrecn].
+induction  m as [| m Hrecm].
+right; reflexivity.
+elim (le_Sn_O _ H0).
+cut ((m <= n)%nat \/ m = S n).
+intro; elim H1; intro.
+apply Rle_trans with (Un n).
+apply H.
+apply Hrecn; assumption.
+rewrite H2; right; reflexivity.
+inversion H0; [ right; reflexivity | left; assumption ].
+Qed.
+
+(* |x|^n/n! -> 0 *)
+Lemma cv_speed_pow_fact :
+ forall x:R, Un_cv (fun n:nat => x ^ n / INR (fact n)) 0.
+intro;
+ cut
+  (Un_cv (fun n:nat => Rabs x ^ n / INR (fact n)) 0 ->
+   Un_cv (fun n:nat => x ^ n / INR (fact n)) 0).
+intro; apply H.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros; case (Req_dec x 0);
+ intro.
+exists 1%nat; intros.
+rewrite H1; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+ rewrite Rabs_R0; rewrite pow_ne_zero;
+ [ unfold Rdiv in |- *; rewrite Rmult_0_l; rewrite Rabs_R0; assumption
+ | red in |- *; intro; rewrite H3 in H2; elim (le_Sn_n _ H2) ].
+assert (H2 := Rabs_pos_lt x H1); set (M := up (Rabs x)); cut (0 <= M)%Z.
+intro; elim (IZN M H3); intros M_nat H4.
+set (Un := fun n:nat => Rabs x ^ (M_nat + n) / INR (fact (M_nat + n))).
+cut (Un_cv Un 0); unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+elim (H5 eps H0); intros N H6.
+exists (M_nat + N)%nat; intros;
+ cut (exists p : nat, (p >= N)%nat /\ n = (M_nat + p)%nat).
+intro; elim H8; intros p H9.
+elim H9; intros; rewrite H11; unfold Un in H6; apply H6; assumption.
+exists (n - M_nat)%nat.
+split.
+unfold ge in |- *; apply (fun p n m:nat => plus_le_reg_l n m p) with M_nat;
+ rewrite <- le_plus_minus.
+assumption.
+apply le_trans with (M_nat + N)%nat.
+apply le_plus_l.
+assumption.
+apply le_plus_minus; apply le_trans with (M_nat + N)%nat;
+ [ apply le_plus_l | assumption ].
+set (Vn := fun n:nat => Rabs x * (Un 0%nat / INR (S n))).
+cut (1 <= M_nat)%nat.
+intro; cut (forall n:nat, 0 < Un n).
+intro; cut (Un_decreasing Un).
+intro; cut (forall n:nat, Un (S n) <= Vn n).
+intro; cut (Un_cv Vn 0).
+unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+elim (H10 eps0 H5); intros N1 H11.
+exists (S N1); intros.
+cut (forall n:nat, 0 < Vn n).
+intro; apply Rle_lt_trans with (Rabs (Vn (pred n) - 0)).
+repeat rewrite Rabs_right.
+unfold Rminus in |- *; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
+ replace n with (S (pred n)).
+apply H9.
+inversion H12; simpl in |- *; reflexivity.
+apply Rle_ge; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; left;
+ apply H13.
+apply Rle_ge; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; left;
+ apply H7.
+apply H11; unfold ge in |- *; apply le_S_n; replace (S (pred n)) with n;
+ [ unfold ge in H12; exact H12 | inversion H12; simpl in |- *; reflexivity ].
+intro; apply Rlt_le_trans with (Un (S n0)); [ apply H7 | apply H9 ].
+cut (cv_infty (fun n:nat => INR (S n))).
+intro; cut (Un_cv (fun n:nat => / INR (S n)) 0).
+unfold Un_cv, R_dist in |- *; intros; unfold Vn in |- *.
+cut (0 < eps1 / (Rabs x * Un 0%nat)).
+intro; elim (H11 _ H13); intros N H14.
+exists N; intros;
+ replace (Rabs x * (Un 0%nat / INR (S n)) - 0) with
+  (Rabs x * Un 0%nat * (/ INR (S n) - 0));
+ [ idtac | unfold Rdiv in |- *; ring ].
+rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs (Rabs x * Un 0%nat)).
+apply Rinv_0_lt_compat; apply Rabs_pos_lt.
+apply prod_neq_R0.
+apply Rabs_no_R0; assumption.
+assert (H16 := H7 0%nat); red in |- *; intro; rewrite H17 in H16;
+ elim (Rlt_irrefl _ H16).
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+replace (/ Rabs (Rabs x * Un 0%nat) * eps1) with (eps1 / (Rabs x * Un 0%nat)).
+apply H14; assumption.
+unfold Rdiv in |- *; rewrite (Rabs_right (Rabs x * Un 0%nat)).
+apply Rmult_comm.
+apply Rle_ge; apply Rmult_le_pos.
+apply Rabs_pos.
+left; apply H7.
+apply Rabs_no_R0.
+apply prod_neq_R0;
+ [ apply Rabs_no_R0; assumption
+ | assert (H16 := H7 0%nat); red in |- *; intro; rewrite H17 in H16;
+    elim (Rlt_irrefl _ H16) ].
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+assumption.
+apply Rinv_0_lt_compat; apply Rmult_lt_0_compat.
+apply Rabs_pos_lt; assumption.
+apply H7.
+apply (cv_infty_cv_R0 (fun n:nat => INR (S n))).
+intro; apply not_O_INR; discriminate.
+assumption.
+unfold cv_infty in |- *; intro; case (total_order_T M0 0); intro.
+elim s; intro.
+exists 0%nat; intros.
+apply Rlt_trans with 0; [ assumption | apply lt_INR_0; apply lt_O_Sn ].
+exists 0%nat; intros; rewrite b; apply lt_INR_0; apply lt_O_Sn.
+set (M0_z := up M0).
+assert (H10 := archimed M0).
+cut (0 <= M0_z)%Z.
+intro; elim (IZN _ H11); intros M0_nat H12.
+exists M0_nat; intros.
+apply Rlt_le_trans with (IZR M0_z).
+elim H10; intros; assumption.
+rewrite H12; rewrite <- INR_IZR_INZ; apply le_INR.
+apply le_trans with n; [ assumption | apply le_n_Sn ].
+apply le_IZR; left; simpl in |- *; unfold M0_z in |- *;
+ apply Rlt_trans with M0; [ assumption | elim H10; intros; assumption ].
+intro; apply Rle_trans with (Rabs x * Un n * / INR (S n)).
+unfold Un in |- *; replace (M_nat + S n)%nat with (M_nat + n + 1)%nat.
+rewrite pow_add; replace (Rabs x ^ 1) with (Rabs x);
+ [ idtac | simpl in |- *; ring ].
+unfold Rdiv in |- *; rewrite <- (Rmult_comm (Rabs x));
+ repeat rewrite Rmult_assoc; repeat apply Rmult_le_compat_l.
+apply Rabs_pos.
+left; apply pow_lt; assumption.
+replace (M_nat + n + 1)%nat with (S (M_nat + n)).
+rewrite fact_simpl; rewrite mult_comm; rewrite mult_INR;
+ rewrite Rinv_mult_distr.
+apply Rmult_le_compat_l.
+left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *;
+ intro; assert (H10 := sym_eq H9); elim (fact_neq_0 _ H10).
+left; apply Rinv_lt_contravar.
+apply Rmult_lt_0_compat; apply lt_INR_0; apply lt_O_Sn.
+apply lt_INR; apply lt_n_S.
+pattern n at 1 in |- *; replace n with (0 + n)%nat; [ idtac | reflexivity ].
+apply plus_lt_compat_r.
+apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
+apply INR_fact_neq_0.
+apply not_O_INR; discriminate.
+apply INR_eq; rewrite S_INR; do 3 rewrite plus_INR; reflexivity.
+apply INR_eq; do 3 rewrite plus_INR; do 2 rewrite S_INR; ring.
+unfold Vn in |- *; rewrite Rmult_assoc; unfold Rdiv in |- *;
+ rewrite (Rmult_comm (Un 0%nat)); rewrite (Rmult_comm (Un n)).
+repeat apply Rmult_le_compat_l.
+apply Rabs_pos.
+left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+apply decreasing_prop; [ assumption | apply le_O_n ].
+unfold Un_decreasing in |- *; intro; unfold Un in |- *.
+replace (M_nat + S n)%nat with (M_nat + n + 1)%nat.
+rewrite pow_add; unfold Rdiv in |- *; rewrite Rmult_assoc;
+ apply Rmult_le_compat_l.
+left; apply pow_lt; assumption.
+replace (Rabs x ^ 1) with (Rabs x); [ idtac | simpl in |- *; ring ].
+replace (M_nat + n + 1)%nat with (S (M_nat + n)).
+apply Rmult_le_reg_l with (INR (fact (S (M_nat + n)))).
+apply lt_INR_0; apply neq_O_lt; red in |- *; intro; assert (H9 := sym_eq H8);
+ elim (fact_neq_0 _ H9).
+rewrite (Rmult_comm (Rabs x)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l.
+rewrite fact_simpl; rewrite mult_INR; rewrite Rmult_assoc;
+ rewrite <- Rinv_r_sym.
+rewrite Rmult_1_r; apply Rle_trans with (INR M_nat).
+left; rewrite INR_IZR_INZ.
+rewrite <- H4; assert (H8 := archimed (Rabs x)); elim H8; intros; assumption.
+apply le_INR; apply le_trans with (S M_nat);
+ [ apply le_n_Sn | apply le_n_S; apply le_plus_l ].
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_eq; rewrite S_INR; do 3 rewrite plus_INR; reflexivity.
+apply INR_eq; do 3 rewrite plus_INR; do 2 rewrite S_INR; ring.
+intro; unfold Un in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply pow_lt; assumption.
+apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
+ assert (H8 := sym_eq H7); elim (fact_neq_0 _ H8).
+clear Un Vn; apply INR_le; simpl in |- *.
+induction  M_nat as [| M_nat HrecM_nat].
+assert (H6 := archimed (Rabs x)); fold M in H6; elim H6; intros. 
+rewrite H4 in H7; rewrite <- INR_IZR_INZ in H7.
+simpl in H7; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H2 H7)).
+replace 1 with (INR 1); [ apply le_INR | reflexivity ]; apply le_n_S;
+ apply le_O_n.
+apply le_IZR; simpl in |- *; left; apply Rlt_trans with (Rabs x).
+assumption.
+elim (archimed (Rabs x)); intros; assumption.
+unfold Un_cv in |- *; unfold R_dist in |- *; intros; elim (H eps H0); intros.
+exists x0; intros;
+ apply Rle_lt_trans with (Rabs (Rabs x ^ n / INR (fact n) - 0)).
+unfold Rminus in |- *; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
+ rewrite (Rabs_right (Rabs x ^ n / INR (fact n))).
+unfold Rdiv in |- *; rewrite Rabs_mult; rewrite (Rabs_right (/ INR (fact n))).
+rewrite RPow_abs; right; reflexivity.
+apply Rle_ge; left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt;
+ red in |- *; intro; assert (H4 := sym_eq H3); elim (fact_neq_0 _ H4).
+apply Rle_ge; unfold Rdiv in |- *; apply Rmult_le_pos.
+case (Req_dec x 0); intro.
+rewrite H3; rewrite Rabs_R0.
+induction  n as [| n Hrecn];
+ [ simpl in |- *; left; apply Rlt_0_1
+ | simpl in |- *; rewrite Rmult_0_l; right; reflexivity ].
+left; apply pow_lt; apply Rabs_pos_lt; assumption.
+left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *;
+ intro; assert (H4 := sym_eq H3); elim (fact_neq_0 _ H4).
+apply H1; assumption.
+Qed.
diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v
new file mode 100644
index 00000000..deb98492
--- /dev/null
+++ b/theories/Reals/SeqSeries.v
@@ -0,0 +1,417 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: SeqSeries.v,v 1.14.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Max.
+Require Export Rseries.
+Require Export SeqProp.
+Require Export Rcomplete.
+Require Export PartSum.
+Require Export AltSeries.
+Require Export Binomial.
+Require Export Rsigma.
+Require Export Rprod.
+Require Export Cauchy_prod.
+Require Export Alembert.
+Open Local Scope R_scope.
+
+(**********)
+Lemma sum_maj1 :
+ forall (fn:nat -> R -> R) (An:nat -> R) (x l1 l2:R) 
+   (N:nat),
+   Un_cv (fun n:nat => SP fn n x) l1 ->
+   Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
+   (forall n:nat, Rabs (fn n x) <= An n) ->
+   Rabs (l1 - SP fn N x) <= l2 - sum_f_R0 An N.
+intros;
+ cut
+  (sigT
+     (fun l:R =>
+        Un_cv (fun n:nat => sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) l)).
+intro;
+ cut
+  (sigT
+     (fun l:R =>
+        Un_cv (fun n:nat => sum_f_R0 (fun l:nat => An (S N + l)%nat) n) l)).
+intro; elim X; intros l1N H2.
+elim X0; intros l2N H3.
+cut (l1 - SP fn N x = l1N).
+intro; cut (l2 - sum_f_R0 An N = l2N).
+intro; rewrite H4; rewrite H5.
+apply sum_cv_maj with
+ (fun l:nat => An (S N + l)%nat) (fun (l:nat) (x:R) => fn (S N + l)%nat x) x.
+unfold SP in |- *; apply H2.
+apply H3.
+intros; apply H1.
+symmetry  in |- *; eapply UL_sequence.
+apply H3.
+unfold Un_cv in H0; unfold Un_cv in |- *; intros; elim (H0 eps H5);
+ intros N0 H6.
+unfold R_dist in H6; exists N0; intros.
+unfold R_dist in |- *;
+ replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))
+  with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2);
+ [ idtac | ring ].
+replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with
+ (sum_f_R0 An (S (N + n))).
+apply H6; unfold ge in |- *; apply le_trans with n.
+apply H7.
+apply le_trans with (N + n)%nat.
+apply le_plus_r.
+apply le_n_Sn.
+cut (0 <= N)%nat.
+cut (N < S (N + n))%nat.
+intros; assert (H10 := sigma_split An H9 H8).
+unfold sigma in H10.
+do 2 rewrite <- minus_n_O in H10.
+replace (sum_f_R0 An (S (N + n))) with
+ (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
+replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
+cut ((S (N + n) - S N)%nat = n).
+intro; rewrite H11 in H10.
+apply H10.
+apply INR_eq; rewrite minus_INR.
+do 2 rewrite S_INR; rewrite plus_INR; ring.
+apply le_n_S; apply le_plus_l.
+apply sum_eq; intros.
+reflexivity.
+apply sum_eq; intros.
+reflexivity.
+apply le_lt_n_Sm; apply le_plus_l.
+apply le_O_n.
+symmetry  in |- *; eapply UL_sequence.
+apply H2.
+unfold Un_cv in H; unfold Un_cv in |- *; intros.
+elim (H eps H4); intros N0 H5.
+unfold R_dist in H5; exists N0; intros.
+unfold R_dist, SP in |- *;
+ replace
+  (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n -
+   (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
+  (sum_f_R0 (fun k:nat => fn k x) N +
+   sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); 
+ [ idtac | ring ].
+replace
+ (sum_f_R0 (fun k:nat => fn k x) N +
+  sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with
+ (sum_f_R0 (fun k:nat => fn k x) (S (N + n))).
+unfold SP in H5; apply H5; unfold ge in |- *; apply le_trans with n.
+apply H6.
+apply le_trans with (N + n)%nat.
+apply le_plus_r.
+apply le_n_Sn.
+cut (0 <= N)%nat.
+cut (N < S (N + n))%nat.
+intros; assert (H9 := sigma_split (fun k:nat => fn k x) H8 H7).
+unfold sigma in H9.
+do 2 rewrite <- minus_n_O in H9.
+replace (sum_f_R0 (fun k:nat => fn k x) (S (N + n))) with
+ (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) (S (N + n))).
+replace (sum_f_R0 (fun k:nat => fn k x) N) with
+ (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) N).
+cut ((S (N + n) - S N)%nat = n).
+intro; rewrite H10 in H9.
+apply H9.
+apply INR_eq; rewrite minus_INR.
+do 2 rewrite S_INR; rewrite plus_INR; ring.
+apply le_n_S; apply le_plus_l.
+apply sum_eq; intros.
+reflexivity.
+apply sum_eq; intros.
+reflexivity.
+apply le_lt_n_Sm.
+apply le_plus_l.
+apply le_O_n.
+apply existT with (l2 - sum_f_R0 An N).
+unfold Un_cv in H0; unfold Un_cv in |- *; intros.
+elim (H0 eps H2); intros N0 H3.
+unfold R_dist in H3; exists N0; intros.
+unfold R_dist in |- *;
+ replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))
+  with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2);
+ [ idtac | ring ].
+replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with
+ (sum_f_R0 An (S (N + n))).
+apply H3; unfold ge in |- *; apply le_trans with n.
+apply H4.
+apply le_trans with (N + n)%nat.
+apply le_plus_r.
+apply le_n_Sn.
+cut (0 <= N)%nat.
+cut (N < S (N + n))%nat.
+intros; assert (H7 := sigma_split An H6 H5).
+unfold sigma in H7.
+do 2 rewrite <- minus_n_O in H7.
+replace (sum_f_R0 An (S (N + n))) with
+ (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
+replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
+cut ((S (N + n) - S N)%nat = n).
+intro; rewrite H8 in H7.
+apply H7.
+apply INR_eq; rewrite minus_INR.
+do 2 rewrite S_INR; rewrite plus_INR; ring.
+apply le_n_S; apply le_plus_l.
+apply sum_eq; intros.
+reflexivity.
+apply sum_eq; intros.
+reflexivity.
+apply le_lt_n_Sm.
+apply le_plus_l.
+apply le_O_n.
+apply existT with (l1 - SP fn N x).
+unfold Un_cv in H; unfold Un_cv in |- *; intros.
+elim (H eps H2); intros N0 H3.
+unfold R_dist in H3; exists N0; intros.
+unfold R_dist, SP in |- *.
+replace
+ (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n -
+  (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
+ (sum_f_R0 (fun k:nat => fn k x) N +
+  sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); 
+ [ idtac | ring ].
+replace
+ (sum_f_R0 (fun k:nat => fn k x) N +
+  sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with
+ (sum_f_R0 (fun k:nat => fn k x) (S (N + n))).
+unfold SP in H3; apply H3.
+unfold ge in |- *; apply le_trans with n.
+apply H4.
+apply le_trans with (N + n)%nat.
+apply le_plus_r.
+apply le_n_Sn.
+cut (0 <= N)%nat.
+cut (N < S (N + n))%nat.
+intros; assert (H7 := sigma_split (fun k:nat => fn k x) H6 H5).
+unfold sigma in H7.
+do 2 rewrite <- minus_n_O in H7.
+replace (sum_f_R0 (fun k:nat => fn k x) (S (N + n))) with
+ (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) (S (N + n))).
+replace (sum_f_R0 (fun k:nat => fn k x) N) with
+ (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) N).
+cut ((S (N + n) - S N)%nat = n).
+intro; rewrite H8 in H7.
+apply H7.
+apply INR_eq; rewrite minus_INR.
+do 2 rewrite S_INR; rewrite plus_INR; ring.
+apply le_n_S; apply le_plus_l.
+apply sum_eq; intros.
+reflexivity.
+apply sum_eq; intros.
+reflexivity.
+apply le_lt_n_Sm.
+apply le_plus_l.
+apply le_O_n.
+Qed.
+
+(* Comparaison of convergence for series *)
+Lemma Rseries_CV_comp :
+ forall An Bn:nat -> R,
+   (forall n:nat, 0 <= An n <= Bn n) ->
+   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 Bn N) l) ->
+   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+intros; apply cv_cauchy_2.
+assert (H0 := cv_cauchy_1 _ X).
+unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
+intros; elim (H0 eps H1); intros.
+exists x; intros.
+cut
+ (R_dist (sum_f_R0 An n) (sum_f_R0 An m) <=
+  R_dist (sum_f_R0 Bn n) (sum_f_R0 Bn m)).
+intro; apply Rle_lt_trans with (R_dist (sum_f_R0 Bn n) (sum_f_R0 Bn m)).
+assumption.
+apply H2; assumption.
+assert (H5 := lt_eq_lt_dec n m).
+elim H5; intro.
+elim a; intro.
+rewrite (tech2 An n m); [ idtac | assumption ].
+rewrite (tech2 Bn n m); [ idtac | assumption ].
+unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Ropp_plus_distr;
+ do 2 rewrite <- Rplus_assoc; do 2 rewrite Rplus_opp_r;
+ do 2 rewrite Rplus_0_l; do 2 rewrite Rabs_Ropp; repeat rewrite Rabs_right.
+apply sum_Rle; intros.
+elim (H (S n + n0)%nat); intros.
+apply H8.
+apply Rle_ge; apply cond_pos_sum; intro.
+elim (H (S n + n0)%nat); intros.
+apply Rle_trans with (An (S n + n0)%nat); assumption.
+apply Rle_ge; apply cond_pos_sum; intro.
+elim (H (S n + n0)%nat); intros; assumption.
+rewrite b; unfold R_dist in |- *; unfold Rminus in |- *;
+ do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right; 
+ reflexivity.
+rewrite (tech2 An m n); [ idtac | assumption ].
+rewrite (tech2 Bn m n); [ idtac | assumption ].
+unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Rplus_assoc;
+ rewrite (Rplus_comm (sum_f_R0 An m)); rewrite (Rplus_comm (sum_f_R0 Bn m));
+ do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l; 
+ do 2 rewrite Rplus_0_r; repeat rewrite Rabs_right.
+apply sum_Rle; intros.
+elim (H (S m + n0)%nat); intros; apply H8.
+apply Rle_ge; apply cond_pos_sum; intro.
+elim (H (S m + n0)%nat); intros.
+apply Rle_trans with (An (S m + n0)%nat); assumption.
+apply Rle_ge.
+apply cond_pos_sum; intro.
+elim (H (S m + n0)%nat); intros; assumption.
+Qed.
+
+(* Cesaro's theorem *)
+Lemma Cesaro :
+ forall (An Bn:nat -> R) (l:R),
+   Un_cv Bn l ->
+   (forall n:nat, 0 < An n) ->
+   cv_infty (fun n:nat => sum_f_R0 An n) ->
+   Un_cv (fun n:nat => sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n)
+     l.
+Proof with trivial.
+unfold Un_cv in |- *; intros; assert (H3 : forall n:nat, 0 < sum_f_R0 An n)...
+intro; apply tech1...
+assert (H4 : forall n:nat, sum_f_R0 An n <> 0)...
+intro; red in |- *; intro; assert (H5 := H3 n); rewrite H4 in H5;
+ elim (Rlt_irrefl _ H5)...
+assert (H5 := cv_infty_cv_R0 _ H4 H1); assert (H6 : 0 < eps / 2)...
+unfold Rdiv in |- *; apply Rmult_lt_0_compat...
+apply Rinv_0_lt_compat; prove_sup...
+elim (H _ H6); clear H; intros N1 H;
+ set (C := Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1));
+ assert
+  (H7 :
+    exists N : nat,
+     (forall n:nat, (N <= n)%nat -> C / sum_f_R0 An n < eps / 2))...
+case (Req_dec C 0); intro...
+exists 0%nat; intros...
+rewrite H7; unfold Rdiv in |- *; rewrite Rmult_0_l; apply Rmult_lt_0_compat...
+apply Rinv_0_lt_compat; prove_sup...
+assert (H8 : 0 < eps / (2 * Rabs C))...
+unfold Rdiv in |- *; apply Rmult_lt_0_compat...
+apply Rinv_0_lt_compat; apply Rmult_lt_0_compat...
+prove_sup...
+apply Rabs_pos_lt...
+elim (H5 _ H8); intros; exists x; intros; assert (H11 := H9 _ H10);
+ unfold R_dist in H11; unfold Rminus in H11; rewrite Ropp_0 in H11;
+ rewrite Rplus_0_r in H11...
+apply Rle_lt_trans with (Rabs (C / sum_f_R0 An n))...
+apply RRle_abs...
+unfold Rdiv in |- *; rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs C)...
+apply Rinv_0_lt_compat; apply Rabs_pos_lt...
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
+rewrite Rmult_1_l; replace (/ Rabs C * (eps * / 2)) with (eps / (2 * Rabs C))...
+unfold Rdiv in |- *; rewrite Rinv_mult_distr...
+ring...
+discrR...
+apply Rabs_no_R0...
+apply Rabs_no_R0...
+elim H7; clear H7; intros N2 H7; set (N := max N1 N2); exists (S N); intros;
+ unfold R_dist in |- *;
+ replace (sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n - l) with
+  (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n / sum_f_R0 An n)...
+assert (H9 : (N1 < n)%nat)...
+apply lt_le_trans with (S N)...
+apply le_lt_n_Sm; unfold N in |- *; apply le_max_l...
+rewrite (tech2 (fun k:nat => An k * (Bn k - l)) _ _ H9); unfold Rdiv in |- *;
+ rewrite Rmult_plus_distr_r;
+ apply Rle_lt_trans with
+  (Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1 / sum_f_R0 An n) +
+   Rabs
+     (sum_f_R0 (fun i:nat => An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l))
+        (n - S N1) / sum_f_R0 An n))...
+apply Rabs_triang...
+rewrite (double_var eps); apply Rplus_lt_compat...
+unfold Rdiv in |- *; rewrite Rabs_mult; fold C in |- *; rewrite Rabs_right...
+apply (H7 n); apply le_trans with (S N)...
+apply le_trans with N; [ unfold N in |- *; apply le_max_r | apply le_n_Sn ]...
+apply Rle_ge; left; apply Rinv_0_lt_compat...
+
+unfold R_dist in H; unfold Rdiv in |- *; rewrite Rabs_mult;
+ rewrite (Rabs_right (/ sum_f_R0 An n))...
+apply Rle_lt_trans with
+ (sum_f_R0 (fun i:nat => Rabs (An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l)))
+    (n - S N1) * / sum_f_R0 An n)...
+do 2 rewrite <- (Rmult_comm (/ sum_f_R0 An n)); apply Rmult_le_compat_l...
+left; apply Rinv_0_lt_compat...
+apply
+ (Rsum_abs (fun i:nat => An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l))
+    (n - S N1))...
+apply Rle_lt_trans with
+ (sum_f_R0 (fun i:nat => An (S N1 + i)%nat * (eps / 2)) (n - S N1) *
+  / sum_f_R0 An n)...
+do 2 rewrite <- (Rmult_comm (/ sum_f_R0 An n)); apply Rmult_le_compat_l...
+left; apply Rinv_0_lt_compat...
+apply sum_Rle; intros; rewrite Rabs_mult;
+ pattern (An (S N1 + n0)%nat) at 2 in |- *;
+ rewrite <- (Rabs_right (An (S N1 + n0)%nat))...
+apply Rmult_le_compat_l...
+apply Rabs_pos...
+left; apply H; unfold ge in |- *; apply le_trans with (S N1);
+ [ apply le_n_Sn | apply le_plus_l ]...
+apply Rle_ge; left...
+rewrite <- (scal_sum (fun i:nat => An (S N1 + i)%nat) (n - S N1) (eps / 2));
+ unfold Rdiv in |- *; repeat rewrite Rmult_assoc; apply Rmult_lt_compat_l...
+pattern (/ 2) at 2 in |- *; rewrite <- Rmult_1_r; apply Rmult_lt_compat_l...
+apply Rinv_0_lt_compat; prove_sup...
+rewrite Rmult_comm; apply Rmult_lt_reg_l with (sum_f_R0 An n)...
+rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym...
+rewrite Rmult_1_l; rewrite Rmult_1_r; rewrite (tech2 An N1 n)...
+rewrite Rplus_comm;
+ pattern (sum_f_R0 (fun i:nat => An (S N1 + i)%nat) (n - S N1)) at 1 in |- *;
+ rewrite <- Rplus_0_r; apply Rplus_lt_compat_l...
+apply Rle_ge; left; apply Rinv_0_lt_compat...
+replace (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n) with
+ (sum_f_R0 (fun k:nat => An k * Bn k) n +
+  sum_f_R0 (fun k:nat => An k * - l) n)...
+rewrite <- (scal_sum An n (- l)); field...
+rewrite <- plus_sum; apply sum_eq; intros; ring...
+Qed.
+
+Lemma Cesaro_1 :
+ forall (An:nat -> R) (l:R),
+   Un_cv An l -> Un_cv (fun n:nat => sum_f_R0 An (pred n) / INR n) l.
+Proof with trivial.
+intros Bn l H; set (An := fun _:nat => 1)...
+assert (H0 : forall n:nat, 0 < An n)...
+intro; unfold An in |- *; apply Rlt_0_1...
+assert (H1 : forall n:nat, 0 < sum_f_R0 An n)...
+intro; apply tech1...
+assert (H2 : cv_infty (fun n:nat => sum_f_R0 An n))...
+unfold cv_infty in |- *; intro; case (Rle_dec M 0); intro...
+exists 0%nat; intros; apply Rle_lt_trans with 0...
+assert (H2 : 0 < M)...
+auto with real...
+clear n; set (m := up M); elim (archimed M); intros;
+ assert (H5 : (0 <= m)%Z)...
+apply le_IZR; unfold m in |- *; simpl in |- *; left; apply Rlt_trans with M...
+elim (IZN _ H5); intros; exists x; intros; unfold An in |- *; rewrite sum_cte;
+ rewrite Rmult_1_l; apply Rlt_trans with (IZR (up M))...
+apply Rle_lt_trans with (INR x)...
+rewrite INR_IZR_INZ; fold m in |- *; rewrite <- H6; right...
+apply lt_INR; apply le_lt_n_Sm...
+assert (H3 := Cesaro _ _ _ H H0 H2)...
+unfold Un_cv in |- *; unfold Un_cv in H3; intros; elim (H3 _ H4); intros;
+ exists (S x); intros; unfold R_dist in |- *; unfold R_dist in H5;
+ apply Rle_lt_trans with
+  (Rabs
+     (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l))...
+right;
+ replace (sum_f_R0 Bn (pred n) / INR n - l) with
+  (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l)...
+unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- l));
+ apply Rplus_eq_compat_l...
+unfold An in |- *;
+ replace (sum_f_R0 (fun k:nat => 1 * Bn k) (pred n)) with
+  (sum_f_R0 Bn (pred n))...
+rewrite sum_cte; rewrite Rmult_1_l; replace (S (pred n)) with n...
+apply S_pred with 0%nat; apply lt_le_trans with (S x)...
+apply lt_O_Sn...
+apply sum_eq; intros; ring...
+apply H5; unfold ge in |- *; apply le_S_n; replace (S (pred n)) with n...
+apply S_pred with 0%nat; apply lt_le_trans with (S x)...
+apply lt_O_Sn...
+Qed.
diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v
new file mode 100644
index 00000000..b4026e67
--- /dev/null
+++ b/theories/Reals/SplitAbsolu.v
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i      $Id: SplitAbsolu.v,v 1.6.2.1 2004/07/16 19:31:15 herbelin Exp $       i*)
+
+Require Import Rbasic_fun.
+
+Ltac split_case_Rabs :=
+  match goal with
+  |  |- context [(Rcase_abs ?X1)] =>
+      case (Rcase_abs X1); try split_case_Rabs
+  end.
+
+
+Ltac split_Rabs :=
+  match goal with
+  | id:context [(Rabs _)] |- _ => generalize id; clear id; try split_Rabs
+  |  |- context [(Rabs ?X1)] =>
+      unfold Rabs in |- *; try split_case_Rabs; intros
+  end.
\ No newline at end of file
diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v
new file mode 100644
index 00000000..19df2afa
--- /dev/null
+++ b/theories/Reals/SplitRmult.v
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: SplitRmult.v,v 1.7.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+(*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*)
+
+
+Require Import Rbase.
+
+Ltac split_Rmult :=
+  match goal with
+  |  |- ((?X1 * ?X2)%R <> 0%R) =>
+      apply Rmult_integral_contrapositive; split; try split_Rmult
+  end.
diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v
new file mode 100644
index 00000000..b11e51f0
--- /dev/null
+++ b/theories/Reals/Sqrt_reg.v
@@ -0,0 +1,351 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: Sqrt_reg.v,v 1.9.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Ranalysis1.
+Require Import R_sqrt. Open Local Scope R_scope.
+
+(**********)
+Lemma sqrt_var_maj :
+ forall h:R, Rabs h <= 1 -> Rabs (sqrt (1 + h) - 1) <= Rabs h.
+intros; cut (0 <= 1 + h).
+intro; apply Rle_trans with (Rabs (sqrt (Rsqr (1 + h)) - 1)).
+case (total_order_T h 0); intro.
+elim s; intro.
+repeat rewrite Rabs_left.
+unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (-1)).
+do 2 rewrite Ropp_plus_distr; rewrite Ropp_involutive;
+ apply Rplus_le_compat_l.
+apply Ropp_le_contravar; apply sqrt_le_1.
+apply Rle_0_sqr.
+apply H0.
+pattern (1 + h) at 2 in |- *; rewrite <- Rmult_1_r; unfold Rsqr in |- *;
+ apply Rmult_le_compat_l.
+apply H0.
+pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+ assumption.
+apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
+ unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+ rewrite Rplus_0_r.
+pattern 1 at 2 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
+apply Rle_0_sqr.
+left; apply Rlt_0_1.
+pattern 1 at 2 in |- *; rewrite <- Rsqr_1; apply Rsqr_incrst_1.
+pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+ assumption.
+apply H0.
+left; apply Rlt_0_1.
+apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
+ unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+ rewrite Rplus_0_r.
+pattern 1 at 2 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
+apply H0.
+left; apply Rlt_0_1.
+pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+ assumption.
+rewrite b; rewrite Rplus_0_r; rewrite Rsqr_1; rewrite sqrt_1; right;
+ reflexivity.
+repeat rewrite Rabs_right.
+unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (-1));
+ apply Rplus_le_compat_l.
+apply sqrt_le_1.
+apply H0.
+apply Rle_0_sqr.
+pattern (1 + h) at 1 in |- *; rewrite <- Rmult_1_r; unfold Rsqr in |- *;
+ apply Rmult_le_compat_l.
+apply H0.
+pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+ assumption.
+apply Rle_ge; apply Rplus_le_reg_l with 1.
+rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+ rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
+pattern 1 at 1 in |- *; rewrite <- sqrt_1; apply sqrt_le_1.
+left; apply Rlt_0_1.
+apply Rle_0_sqr.
+pattern 1 at 1 in |- *; rewrite <- Rsqr_1; apply Rsqr_incr_1.
+pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+ assumption.
+left; apply Rlt_0_1.
+apply H0.
+apply Rle_ge; left; apply Rplus_lt_reg_r with 1.
+rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+ rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
+pattern 1 at 1 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
+left; apply Rlt_0_1.
+apply H0.
+pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+ assumption.
+rewrite sqrt_Rsqr.
+replace (1 + h - 1) with h; [ right; reflexivity | ring ].
+apply H0.
+case (total_order_T h 0); intro.
+elim s; intro.
+rewrite (Rabs_left h a) in H.
+apply Rplus_le_reg_l with (- h).
+rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc;
+ rewrite Rplus_opp_r; rewrite Rplus_0_r; exact H.
+left; rewrite b; rewrite Rplus_0_r; apply Rlt_0_1.
+left; apply Rplus_lt_0_compat.
+apply Rlt_0_1.
+apply r.
+Qed.
+
+(* sqrt is continuous in 1 *)
+Lemma sqrt_continuity_pt_R1 : continuity_pt sqrt 1.
+unfold continuity_pt in |- *; unfold continue_in in |- *;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+ intros.
+set (alpha := Rmin eps 1).
+exists alpha; intros.
+split.
+unfold alpha in |- *; unfold Rmin in |- *; case (Rle_dec eps 1); intro.
+assumption.
+apply Rlt_0_1.
+intros; elim H0; intros.
+rewrite sqrt_1; replace x with (1 + (x - 1)); [ idtac | ring ];
+ apply Rle_lt_trans with (Rabs (x - 1)).
+apply sqrt_var_maj.
+apply Rle_trans with alpha.
+left; apply H2.
+unfold alpha in |- *; apply Rmin_r.
+apply Rlt_le_trans with alpha;
+ [ apply H2 | unfold alpha in |- *; apply Rmin_l ].
+Qed.
+
+(* sqrt is continuous forall x>0 *)
+Lemma sqrt_continuity_pt : forall x:R, 0 < x -> continuity_pt sqrt x.
+intros; generalize sqrt_continuity_pt_R1.
+unfold continuity_pt in |- *; unfold continue_in in |- *;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+ intros.
+cut (0 < eps / sqrt x).
+intro; elim (H0 _ H2); intros alp_1 H3.
+elim H3; intros.
+set (alpha := alp_1 * x).
+exists (Rmin alpha x); intros.
+split.
+change (0 < Rmin alpha x) in |- *; unfold Rmin in |- *;
+ case (Rle_dec alpha x); intro.
+unfold alpha in |- *; apply Rmult_lt_0_compat; assumption.
+apply H.
+intros; replace x0 with (x + (x0 - x)); [ idtac | ring ];
+ replace (sqrt (x + (x0 - x)) - sqrt x) with
+  (sqrt x * (sqrt (1 + (x0 - x) / x) - sqrt 1)).
+rewrite Rabs_mult; rewrite (Rabs_right (sqrt x)).
+apply Rmult_lt_reg_l with (/ sqrt x).
+apply Rinv_0_lt_compat; apply sqrt_lt_R0; assumption.
+rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l; rewrite Rmult_comm.
+unfold Rdiv in H5.
+case (Req_dec x x0); intro.
+rewrite H7; unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r;
+ rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r; 
+ rewrite Rabs_R0.
+apply Rmult_lt_0_compat.
+assumption.
+apply Rinv_0_lt_compat; rewrite <- H7; apply sqrt_lt_R0; assumption.
+apply H5.
+split.
+unfold D_x, no_cond in |- *.
+split.
+trivial.
+red in |- *; intro.
+cut ((x0 - x) * / x = 0).
+intro.
+elim (Rmult_integral _ _ H9); intro.
+elim H7.
+apply (Rminus_diag_uniq_sym _ _ H10).
+assert (H11 := Rmult_eq_0_compat_r _ x H10).
+rewrite <- Rinv_l_sym in H11.
+elim R1_neq_R0; exact H11.
+red in |- *; intro; rewrite H12 in H; elim (Rlt_irrefl _ H).
+symmetry  in |- *; apply Rplus_eq_reg_l with 1; rewrite Rplus_0_r;
+ unfold Rdiv in H8; exact H8.
+unfold Rminus in |- *; rewrite Rplus_comm; rewrite <- Rplus_assoc;
+ rewrite Rplus_opp_l; rewrite Rplus_0_l; elim H6; intros.
+unfold Rdiv in |- *; rewrite Rabs_mult.
+rewrite Rabs_Rinv.
+rewrite (Rabs_right x).
+rewrite Rmult_comm; apply Rmult_lt_reg_l with x.
+apply H.
+rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+rewrite Rmult_1_l; rewrite Rmult_comm; fold alpha in |- *.
+apply Rlt_le_trans with (Rmin alpha x).
+apply H9.
+apply Rmin_l.
+red in |- *; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
+apply Rle_ge; left; apply H.
+red in |- *; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
+assert (H7 := sqrt_lt_R0 x H).
+red in |- *; intro; rewrite H8 in H7; elim (Rlt_irrefl _ H7).
+apply Rle_ge; apply sqrt_positivity.
+left; apply H.
+unfold Rminus in |- *; rewrite Rmult_plus_distr_l;
+ rewrite Ropp_mult_distr_r_reverse; repeat rewrite <- sqrt_mult.
+rewrite Rmult_1_r; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
+ unfold Rdiv in |- *; rewrite Rmult_comm; rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; reflexivity.
+red in |- *; intro; rewrite H7 in H; elim (Rlt_irrefl _ H).
+left; apply H.
+left; apply Rlt_0_1.
+left; apply H.
+elim H6; intros.
+case (Rcase_abs (x0 - x)); intro.
+rewrite (Rabs_left (x0 - x) r) in H8.
+rewrite Rplus_comm.
+apply Rplus_le_reg_l with (- ((x0 - x) / x)).
+rewrite Rplus_0_r; rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
+ rewrite Rplus_0_l; unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
+apply Rmult_le_reg_l with x.
+apply H.
+rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
+ rewrite <- Rinv_l_sym.
+rewrite Rmult_1_r; left; apply Rlt_le_trans with (Rmin alpha x).
+apply H8.
+apply Rmin_r.
+red in |- *; intro; rewrite H9 in H; elim (Rlt_irrefl _ H).
+apply Rplus_le_le_0_compat.
+left; apply Rlt_0_1.
+unfold Rdiv in |- *; apply Rmult_le_pos.
+apply Rge_le; exact r.
+left; apply Rinv_0_lt_compat; apply H.
+unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+apply H1.
+apply Rinv_0_lt_compat; apply sqrt_lt_R0; apply H.
+Qed.
+
+(* sqrt is derivable for all x>0 *)
+Lemma derivable_pt_lim_sqrt :
+ forall x:R, 0 < x -> derivable_pt_lim sqrt x (/ (2 * sqrt x)).
+intros; set (g := fun h:R => sqrt x + sqrt (x + h)).
+cut (continuity_pt g 0).
+intro; cut (g 0 <> 0).
+intro; assert (H2 := continuity_pt_inv g 0 H0 H1).
+unfold derivable_pt_lim in |- *; intros; unfold continuity_pt in H2;
+ unfold continue_in in H2; unfold limit1_in in H2; 
+ unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
+elim (H2 eps H3); intros alpha H4.
+elim H4; intros.
+set (alpha1 := Rmin alpha x).
+cut (0 < alpha1).
+intro; exists (mkposreal alpha1 H7); intros.
+replace ((sqrt (x + h) - sqrt x) / h) with (/ (sqrt x + sqrt (x + h))).
+unfold inv_fct, g in H6; replace (2 * sqrt x) with (sqrt x + sqrt (x + 0)).
+apply H6.
+split.
+unfold D_x, no_cond in |- *.
+split.
+trivial.
+apply (sym_not_eq (A:=R)); exact H8.
+unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+ apply Rlt_le_trans with alpha1.
+exact H9.
+unfold alpha1 in |- *; apply Rmin_l.
+rewrite Rplus_0_r; ring.
+cut (0 <= x + h).
+intro; cut (0 < sqrt x + sqrt (x + h)).
+intro; apply Rmult_eq_reg_l with (sqrt x + sqrt (x + h)).
+rewrite <- Rinv_r_sym.
+rewrite Rplus_comm; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
+ rewrite Rsqr_plus_minus; repeat rewrite Rsqr_sqrt.
+rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
+ rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite <- Rinv_r_sym.
+reflexivity.
+apply H8.
+left; apply H.
+assumption.
+red in |- *; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
+red in |- *; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
+apply Rplus_lt_le_0_compat.
+apply sqrt_lt_R0; apply H.
+apply sqrt_positivity; apply H10.
+case (Rcase_abs h); intro.
+rewrite (Rabs_left h r) in H9.
+apply Rplus_le_reg_l with (- h).
+rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc;
+ rewrite Rplus_opp_r; rewrite Rplus_0_r; left; apply Rlt_le_trans with alpha1.
+apply H9.
+unfold alpha1 in |- *; apply Rmin_r.
+apply Rplus_le_le_0_compat.
+left; assumption.
+apply Rge_le; apply r.
+unfold alpha1 in |- *; unfold Rmin in |- *; case (Rle_dec alpha x); intro.
+apply H5.
+apply H.
+unfold g in |- *; rewrite Rplus_0_r.
+cut (0 < sqrt x + sqrt x).
+intro; red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
+apply Rplus_lt_0_compat; apply sqrt_lt_R0; apply H.
+replace g with (fct_cte (sqrt x) + comp sqrt (fct_cte x + id))%F;
+ [ idtac | reflexivity ].
+apply continuity_pt_plus.
+apply continuity_pt_const; unfold constant, fct_cte in |- *; intro;
+ reflexivity.
+apply continuity_pt_comp.
+apply continuity_pt_plus.
+apply continuity_pt_const; unfold constant, fct_cte in |- *; intro;
+ reflexivity.
+apply derivable_continuous_pt; apply derivable_pt_id.
+apply sqrt_continuity_pt.
+unfold plus_fct, fct_cte, id in |- *; rewrite Rplus_0_r; apply H.
+Qed.
+
+(**********)
+Lemma derivable_pt_sqrt : forall x:R, 0 < x -> derivable_pt sqrt x.
+unfold derivable_pt in |- *; intros.
+apply existT with (/ (2 * sqrt x)).
+apply derivable_pt_lim_sqrt; assumption.
+Qed.
+
+(**********)
+Lemma derive_pt_sqrt :
+ forall (x:R) (pr:0 < x),
+   derive_pt sqrt x (derivable_pt_sqrt _ pr) = / (2 * sqrt x).
+intros.
+apply derive_pt_eq_0.
+apply derivable_pt_lim_sqrt; assumption.
+Qed.
+
+(* We show that sqrt is continuous for all x>=0 *)
+(* Remark : by definition of sqrt (as extension of Rsqrt on |R), *)
+(*          we could also show that sqrt is continuous for all x *)
+Lemma continuity_pt_sqrt : forall x:R, 0 <= x -> continuity_pt sqrt x.
+intros; case (Rtotal_order 0 x); intro.
+apply (sqrt_continuity_pt x H0).
+elim H0; intro.
+unfold continuity_pt in |- *; unfold continue_in in |- *;
+ unfold limit1_in in |- *; unfold limit_in in |- *; 
+ simpl in |- *; unfold R_dist in |- *; intros.
+exists (Rsqr eps); intros.
+split.
+change (0 < Rsqr eps) in |- *; apply Rsqr_pos_lt.
+red in |- *; intro; rewrite H3 in H2; elim (Rlt_irrefl _ H2).
+intros; elim H3; intros.
+rewrite <- H1; rewrite sqrt_0; unfold Rminus in |- *; rewrite Ropp_0;
+ rewrite Rplus_0_r; rewrite <- H1 in H5; unfold Rminus in H5;
+ rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5.
+case (Rcase_abs x0); intro.
+unfold sqrt in |- *; case (Rcase_abs x0); intro.
+rewrite Rabs_R0; apply H2.
+assert (H6 := Rge_le _ _ r0); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 r)).
+rewrite Rabs_right.
+apply Rsqr_incrst_0.
+rewrite Rsqr_sqrt.
+rewrite (Rabs_right x0 r) in H5; apply H5.
+apply Rge_le; exact r.
+apply sqrt_positivity; apply Rge_le; exact r.
+left; exact H2.
+apply Rle_ge; apply sqrt_positivity; apply Rge_le; exact r.
+elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H1 H)).
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/intro.tex b/theories/Reals/intro.tex
new file mode 100644
index 00000000..43317258
--- /dev/null
+++ b/theories/Reals/intro.tex
@@ -0,0 +1,4 @@
+\section{Reals}\label{Reals}
+
+This library contains an axiomatization of real numbers.
+The main file is \texttt{Reals.v}.
diff --git a/theories/Relations/Newman.v b/theories/Relations/Newman.v
new file mode 100755
index 00000000..3cf604d8
--- /dev/null
+++ b/theories/Relations/Newman.v
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Newman.v,v 1.7.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+
+Require Import Rstar.
+
+Section Newman.
+
+Variable A : Type. 
+Variable R : A -> A -> Prop.
+
+Let Rstar := Rstar A R. 
+Let Rstar_reflexive := Rstar_reflexive A R.
+Let Rstar_transitive := Rstar_transitive A R.
+Let Rstar_Rstar' := Rstar_Rstar' A R.
+
+Definition coherence (x y:A) := ex2 (Rstar x) (Rstar y).
+
+Theorem coherence_intro :
+ forall x y z:A, Rstar x z -> Rstar y z -> coherence x y.
+Proof
+  fun (x y z:A) (h1:Rstar x z) (h2:Rstar y z) =>
+    ex_intro2 (Rstar x) (Rstar y) z h1 h2.
+  
+(** A very simple case of coherence : *)
+
+Lemma Rstar_coherence : forall x y:A, Rstar x y -> coherence x y.
+ Proof
+   fun (x y:A) (h:Rstar x y) => coherence_intro x y y h (Rstar_reflexive y).  
+  
+(** coherence is symmetric *)
+Lemma coherence_sym : forall x y:A, coherence x y -> coherence y x.
+ Proof
+   fun (x y:A) (h:coherence x y) =>
+     ex2_ind
+       (fun (w:A) (h1:Rstar x w) (h2:Rstar y w) =>
+          coherence_intro y x w h2 h1) h.
+
+Definition confluence (x:A) :=
+  forall y z:A, Rstar x y -> Rstar x z -> coherence y z.  
+  
+Definition local_confluence (x:A) :=
+  forall y z:A, R x y -> R x z -> coherence y z.  
+  
+Definition noetherian :=
+  forall (x:A) (P:A -> Prop),
+    (forall y:A, (forall z:A, R y z -> P z) -> P y) -> P x.  
+  
+Section Newman_section.
+
+(** The general hypotheses of the theorem *)
+
+Hypothesis Hyp1 : noetherian.
+Hypothesis Hyp2 : forall x:A, local_confluence x.  
+  
+(** The induction hypothesis *)
+
+Section Induct.
+  Variable x : A.
+  Hypothesis hyp_ind : forall u:A, R x u -> confluence u.  
+  
+(** Confluence in [x] *)
+
+  Variables y z : A.  
+  Hypothesis h1 : Rstar x y.  
+  Hypothesis h2 : Rstar x z.  
+  
+(** particular case [x->u] and [u->*y]   *)
+Section Newman_.
+  Variable u : A.  
+  Hypothesis t1 : R x u.  
+  Hypothesis t2 : Rstar u y.  
+  
+(** In the usual diagram, we assume also [x->v] and [v->*z] *)
+
+Theorem Diagram : forall (v:A) (u1:R x v) (u2:Rstar v z), coherence y z.
+
+Proof
+   (* We draw the diagram ! *)
+  fun (v:A) (u1:R x v) (u2:Rstar v z) =>
+    ex2_ind
+       (* local confluence in x for u,v *)
+       (* gives w, u->*w and v->*w *)
+      (fun (w:A) (s1:Rstar u w) (s2:Rstar v w) =>
+         ex2_ind
+            (* confluence in u => coherence(y,w) *)
+            (* gives a, y->*a and z->*a *)
+           (fun (a:A) (v1:Rstar y a) (v2:Rstar w a) =>
+              ex2_ind
+                 (* confluence in v => coherence(a,z) *)
+                 (* gives b, a->*b and z->*b *)
+                (fun (b:A) (w1:Rstar a b) (w2:Rstar z b) =>
+                   coherence_intro y z b (Rstar_transitive y a b v1 w1) w2)
+                (hyp_ind v u1 a z (Rstar_transitive v w a s2 v2) u2))
+           (hyp_ind u t1 y w t2 s1)) (Hyp2 x u v t1 u1).
+  
+Theorem caseRxy : coherence y z.
+Proof
+  Rstar_Rstar' x z h2 (fun v w:A => coherence y w)
+    (coherence_sym x y (Rstar_coherence x y h1)) (*i case x=z i*)
+    Diagram.                                     (*i case x->v->*z i*)
+End Newman_.
+
+Theorem Ind_proof : coherence y z.
+Proof
+  Rstar_Rstar' x y h1 (fun u v:A => coherence v z)
+    (Rstar_coherence x z h2) (*i case x=y i*)
+    caseRxy.                                   (*i case x->u->*z i*)
+End Induct.
+
+Theorem Newman : forall x:A, confluence x.
+Proof fun x:A => Hyp1 x confluence Ind_proof.  
+
+End Newman_section.
+
+
+End Newman.
diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v
new file mode 100755
index 00000000..5e0e9ec8
--- /dev/null
+++ b/theories/Relations/Operators_Properties.v
@@ -0,0 +1,96 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Operators_Properties.v,v 1.7.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+
+(****************************************************************************)
+(*                            Bruno Barras                                  *)
+(****************************************************************************)
+
+Require Import Relation_Definitions.
+Require Import Relation_Operators.
+
+
+Section Properties.
+
+  Variable A : Set.
+  Variable R : relation A.
+
+  Let incl (R1 R2:relation A) : Prop := forall x y:A, R1 x y -> R2 x y.
+
+Section Clos_Refl_Trans.
+
+  Lemma clos_rt_is_preorder : preorder A (clos_refl_trans A R).
+apply Build_preorder.
+exact (rt_refl A R).
+
+exact (rt_trans A R).
+Qed.
+
+
+
+Lemma clos_rt_idempotent :
+ incl (clos_refl_trans A (clos_refl_trans A R)) (clos_refl_trans A R).
+red in |- *.
+induction 1; auto with sets.
+intros.
+apply rt_trans with y; auto with sets.
+Qed.
+
+  Lemma clos_refl_trans_ind_left :
+   forall (A:Set) (R:A -> A -> Prop) (M:A) (P:A -> Prop),
+     P M ->
+     (forall P0 N:A, clos_refl_trans A R M P0 -> P P0 -> R P0 N -> P N) ->
+     forall a:A, clos_refl_trans A R M a -> P a.
+intros.
+generalize H H0.
+clear H H0.
+elim H1; intros; auto with sets.
+apply H2 with x; auto with sets.
+
+apply H3.
+apply H0; auto with sets.
+
+intros.
+apply H5 with P0; auto with sets.
+apply rt_trans with y; auto with sets.
+Qed.
+
+
+End Clos_Refl_Trans.
+
+
+Section Clos_Refl_Sym_Trans.
+
+  Lemma clos_rt_clos_rst :
+   inclusion A (clos_refl_trans A R) (clos_refl_sym_trans A R).
+red in |- *.
+induction 1; auto with sets.
+apply rst_trans with y; auto with sets.
+Qed.
+
+  Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans A R).
+apply Build_equivalence.
+exact (rst_refl A R).
+
+exact (rst_trans A R).
+
+exact (rst_sym A R).
+Qed.
+
+  Lemma clos_rst_idempotent :
+   incl (clos_refl_sym_trans A (clos_refl_sym_trans A R))
+     (clos_refl_sym_trans A R).
+red in |- *.
+induction 1; auto with sets.
+apply rst_trans with y; auto with sets.
+Qed.
+
+End Clos_Refl_Sym_Trans.
+
+End Properties.
\ No newline at end of file
diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v
new file mode 100755
index 00000000..e115b0b0
--- /dev/null
+++ b/theories/Relations/Relation_Definitions.v
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Relation_Definitions.v,v 1.6.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+
+Section Relation_Definition.
+
+   Variable A : Type.
+   
+   Definition relation := A -> A -> Prop.
+
+   Variable R : relation.
+   
+
+Section General_Properties_of_Relations.
+
+  Definition reflexive : Prop := forall x:A, R x x.
+  Definition transitive : Prop := forall x y z:A, R x y -> R y z -> R x z.
+  Definition symmetric : Prop := forall x y:A, R x y -> R y x.
+  Definition antisymmetric : Prop := forall x y:A, R x y -> R y x -> x = y.
+
+  (* for compatibility with Equivalence in  ../PROGRAMS/ALG/  *)
+  Definition equiv := reflexive /\ transitive /\ symmetric.
+
+End General_Properties_of_Relations.
+
+
+
+Section Sets_of_Relations.
+
+   Record preorder : Prop := 
+     {preord_refl : reflexive; preord_trans : transitive}.
+
+   Record order : Prop := 
+     {ord_refl : reflexive;
+      ord_trans : transitive;
+      ord_antisym : antisymmetric}.
+
+   Record equivalence : Prop := 
+     {equiv_refl : reflexive;
+      equiv_trans : transitive;
+      equiv_sym : symmetric}.
+   
+   Record PER : Prop :=  {per_sym : symmetric; per_trans : transitive}.
+
+End Sets_of_Relations.
+
+
+
+Section Relations_of_Relations.
+
+  Definition inclusion (R1 R2:relation) : Prop :=
+    forall x y:A, R1 x y -> R2 x y.
+
+  Definition same_relation (R1 R2:relation) : Prop :=
+    inclusion R1 R2 /\ inclusion R2 R1.
+   
+  Definition commut (R1 R2:relation) : Prop :=
+    forall x y:A,
+      R1 y x -> forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & R1 z y'.
+
+End Relations_of_Relations.
+
+   
+End Relation_Definition.
+
+Hint Unfold reflexive transitive antisymmetric symmetric: sets v62.
+
+Hint Resolve Build_preorder Build_order Build_equivalence Build_PER
+  preord_refl preord_trans ord_refl ord_trans ord_antisym equiv_refl
+  equiv_trans equiv_sym per_sym per_trans: sets v62.
+
+Hint Unfold inclusion same_relation commut: sets v62.
\ No newline at end of file
diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v
new file mode 100755
index 00000000..b6359ada
--- /dev/null
+++ b/theories/Relations/Relation_Operators.v
@@ -0,0 +1,167 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Relation_Operators.v,v 1.8.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+
+(****************************************************************************)
+(*                      Bruno Barras, Cristina Cornes                       *)
+(*                                                                          *)
+(*  Some of these definitons were taken from :                              *)
+(*     Constructing Recursion Operators in Type Theory                      *)
+(*     L. Paulson  JSC (1986) 2, 325-355                                    *)
+(****************************************************************************)
+
+Require Import Relation_Definitions.
+Require Import List.
+
+(** Some operators to build relations *)
+
+Section Transitive_Closure.
+  Variable A : Set.
+  Variable R : relation A.
+
+  Inductive clos_trans : A -> A -> Prop :=
+    | t_step : forall x y:A, R x y -> clos_trans x y
+    | t_trans :
+        forall x y z:A, clos_trans x y -> clos_trans y z -> clos_trans x z.
+End Transitive_Closure.
+
+
+Section Reflexive_Transitive_Closure.
+  Variable A : Set.
+  Variable R : relation A.
+
+  Inductive clos_refl_trans : relation A :=
+    | rt_step : forall x y:A, R x y -> clos_refl_trans x y
+    | rt_refl : forall x:A, clos_refl_trans x x
+    | rt_trans :
+        forall x y z:A,
+          clos_refl_trans x y -> clos_refl_trans y z -> clos_refl_trans x z.
+End Reflexive_Transitive_Closure.
+
+
+Section Reflexive_Symetric_Transitive_Closure.
+  Variable A : Set.
+  Variable R : relation A.
+
+  Inductive clos_refl_sym_trans : relation A :=
+    | rst_step : forall x y:A, R x y -> clos_refl_sym_trans x y
+    | rst_refl : forall x:A, clos_refl_sym_trans x x
+    | rst_sym :
+        forall x y:A, clos_refl_sym_trans x y -> clos_refl_sym_trans y x
+    | rst_trans :
+        forall x y z:A,
+          clos_refl_sym_trans x y ->
+          clos_refl_sym_trans y z -> clos_refl_sym_trans x z.
+End Reflexive_Symetric_Transitive_Closure.
+
+
+Section Transposee.
+  Variable A : Set.
+  Variable R : relation A.
+
+  Definition transp (x y:A) := R y x.
+End Transposee.
+
+
+Section Union.
+  Variable A : Set.
+  Variables R1 R2 : relation A.
+
+  Definition union (x y:A) := R1 x y \/ R2 x y.
+End Union.
+
+
+Section Disjoint_Union.
+Variables A B : Set.
+Variable leA : A -> A -> Prop.
+Variable leB : B -> B -> Prop.
+
+Inductive le_AsB : A + B -> A + B -> Prop :=
+  | le_aa : forall x y:A, leA x y -> le_AsB (inl B x) (inl B y)
+  | le_ab : forall (x:A) (y:B), le_AsB (inl B x) (inr A y)
+  | le_bb : forall x y:B, leB x y -> le_AsB (inr A x) (inr A y).
+
+End Disjoint_Union. 
+
+
+
+Section Lexicographic_Product.
+(* Lexicographic order on dependent pairs *)
+
+Variable A : Set.
+Variable B : A -> Set.
+Variable leA : A -> A -> Prop.
+Variable leB : forall x:A, B x -> B x -> Prop.
+
+Inductive lexprod : sigS B -> sigS B -> Prop :=
+  | left_lex :
+      forall (x x':A) (y:B x) (y':B x'),
+        leA x x' -> lexprod (existS B x y) (existS B x' y')
+  | right_lex :
+      forall (x:A) (y y':B x),
+        leB x y y' -> lexprod (existS B x y) (existS B x y').
+End Lexicographic_Product.
+
+
+Section Symmetric_Product.
+  Variable A : Set.
+  Variable B : Set.
+  Variable leA : A -> A -> Prop.
+  Variable leB : B -> B -> Prop.
+
+  Inductive symprod : A * B -> A * B -> Prop :=
+    | left_sym :
+        forall x x':A, leA x x' -> forall y:B, symprod (x, y) (x', y)
+    | right_sym :
+        forall y y':B, leB y y' -> forall x:A, symprod (x, y) (x, y').
+
+End Symmetric_Product.
+
+
+Section Swap.
+  Variable A : Set.
+  Variable R : A -> A -> Prop.
+
+  Inductive swapprod : A * A -> A * A -> Prop :=
+    | sp_noswap : forall x x':A * A, symprod A A R R x x' -> swapprod x x'
+    | sp_swap :
+        forall (x y:A) (p:A * A),
+          symprod A A R R (x, y) p -> swapprod (y, x) p.
+End Swap.
+
+
+Section Lexicographic_Exponentiation.
+
+Variable A : Set.
+Variable leA : A -> A -> Prop.
+Let Nil := nil (A:=A).
+Let List := list A.
+
+Inductive Ltl : List -> List -> Prop :=
+  | Lt_nil : forall (a:A) (x:List), Ltl Nil (a :: x)
+  | Lt_hd : forall a b:A, leA a b -> forall x y:list A, Ltl (a :: x) (b :: y)
+  | Lt_tl : forall (a:A) (x y:List), Ltl x y -> Ltl (a :: x) (a :: y).
+
+
+Inductive Desc : List -> Prop :=
+  | d_nil : Desc Nil
+  | d_one : forall x:A, Desc (x :: Nil)
+  | d_conc :
+      forall (x y:A) (l:List),
+        leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil).
+
+Definition Pow : Set := sig Desc.
+
+Definition lex_exp (a b:Pow) : Prop := Ltl (proj1_sig a) (proj1_sig b).
+
+End Lexicographic_Exponentiation.
+
+Hint Unfold transp union: sets v62.
+Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets v62.
+Hint Immediate rst_sym: sets v62.
\ No newline at end of file
diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v
new file mode 100755
index 00000000..6c96f14d
--- /dev/null
+++ b/theories/Relations/Relations.v
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Relations.v,v 1.6.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+
+Require Export Relation_Definitions.
+Require Export Relation_Operators.
+Require Export Operators_Properties.
+
+Lemma inverse_image_of_equivalence :
+ forall (A B:Set) (f:A -> B) (r:relation B),
+   equivalence B r -> equivalence A (fun x y:A => r (f x) (f y)).
+intros; split; elim H; red in |- *; auto.
+intros _ equiv_trans _ x y z H0 H1; apply equiv_trans with (f y); assumption.
+Qed.
+
+Lemma inverse_image_of_eq :
+ forall (A B:Set) (f:A -> B), equivalence A (fun x y:A => f x = f y).
+split; red in |- *;
+ [  (* reflexivity *) reflexivity
+ |  (* transitivity *) intros; transitivity (f y); assumption
+ |  (* symmetry *) intros; symmetry  in |- *; assumption ].
+Qed.
\ No newline at end of file
diff --git a/theories/Relations/Rstar.v b/theories/Relations/Rstar.v
new file mode 100755
index 00000000..7bb3ee93
--- /dev/null
+++ b/theories/Relations/Rstar.v
@@ -0,0 +1,87 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rstar.v,v 1.8.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+
+(** Properties of a binary relation [R] on type [A] *)
+
+Section Rstar.
+
+Variable A : Type.  
+Variable R : A -> A -> Prop.  
+
+(** Definition of the reflexive-transitive closure [R*] of [R] *)
+(** Smallest reflexive [P] containing [R o P] *)
+
+Definition Rstar (x y:A) :=
+  forall P:A -> A -> Prop,
+    (forall u:A, P u u) -> (forall u v w:A, R u v -> P v w -> P u w) -> P x y.  
+
+Theorem Rstar_reflexive : forall x:A, Rstar x x.
+ Proof
+   fun (x:A) (P:A -> A -> Prop) (h1:forall u:A, P u u)
+     (h2:forall u v w:A, R u v -> P v w -> P u w) => 
+     h1 x.  
+  
+Theorem Rstar_R : forall x y z:A, R x y -> Rstar y z -> Rstar x z.
+ Proof
+   fun (x y z:A) (t1:R x y) (t2:Rstar y z) (P:A -> A -> Prop)
+     (h1:forall u:A, P u u) (h2:forall u v w:A, R u v -> P v w -> P u w) =>
+     h2 x y z t1 (t2 P h1 h2).  
+  
+(** We conclude with transitivity of [Rstar] : *)
+
+Theorem Rstar_transitive :
+ forall x y z:A, Rstar x y -> Rstar y z -> Rstar x z.
+ Proof
+   fun (x y z:A) (h:Rstar x y) =>
+     h (fun u v:A => Rstar v z -> Rstar u z) (fun (u:A) (t:Rstar u z) => t)
+       (fun (u v w:A) (t1:R u v) (t2:Rstar w z -> Rstar v z)
+          (t3:Rstar w z) => Rstar_R u v z t1 (t2 t3)).  
+
+(** Another characterization of [R*] *)
+(** Smallest reflexive [P] containing [R o R*] *)
+
+Definition Rstar' (x y:A) :=
+  forall P:A -> A -> Prop,
+    P x x -> (forall u:A, R x u -> Rstar u y -> P x y) -> P x y.  
+
+Theorem Rstar'_reflexive : forall x:A, Rstar' x x.
+ Proof
+   fun (x:A) (P:A -> A -> Prop) (h:P x x)
+     (h':forall u:A, R x u -> Rstar u x -> P x x) => h.
+  
+Theorem Rstar'_R : forall x y z:A, R x z -> Rstar z y -> Rstar' x y.
+ Proof
+   fun (x y z:A) (t1:R x z) (t2:Rstar z y) (P:A -> A -> Prop) 
+     (h1:P x x) (h2:forall u:A, R x u -> Rstar u y -> P x y) => 
+     h2 z t1 t2.  
+  
+(** Equivalence of the two definitions: *)
+
+Theorem Rstar'_Rstar : forall x y:A, Rstar' x y -> Rstar x y.
+ Proof
+   fun (x y:A) (h:Rstar' x y) =>
+     h Rstar (Rstar_reflexive x) (fun u:A => Rstar_R x u y).  
+  
+Theorem Rstar_Rstar' : forall x y:A, Rstar x y -> Rstar' x y.
+ Proof
+   fun (x y:A) (h:Rstar x y) =>
+     h Rstar' (fun u:A => Rstar'_reflexive u)
+       (fun (u v w:A) (h1:R u v) (h2:Rstar' v w) =>
+          Rstar'_R u w v h1 (Rstar'_Rstar v w h2)).  
+
+
+(** Property of Commutativity of two relations *)
+
+Definition commut (A:Set) (R1 R2:A -> A -> Prop) :=
+  forall x y:A,
+    R1 y x -> forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & R1 z y'.
+
+
+End Rstar.
diff --git a/theories/Relations/intro.tex b/theories/Relations/intro.tex
new file mode 100755
index 00000000..5056f36f
--- /dev/null
+++ b/theories/Relations/intro.tex
@@ -0,0 +1,23 @@
+\section{Relations}\label{Relations}
+
+This library develops closure properties of relations.
+
+\begin{itemize}
+\item {\tt Relation\_Definitions.v} deals with the general notions
+  about binary relations (orders, equivalences, ...)
+
+\item {\tt Relation\_Operators.v} and {\tt Rstar.v} define various
+  closures of relations (by symmetry, by transitivity, ...) and
+  lexicographic orderings.
+
+\item {\tt Operators\_Properties.v} states and proves facts on the
+  various closures of a relation.
+
+\item {\tt Relations.v} puts {\tt Relation\_Definitions.v}, {\tt
+    Relation\_Operators.v} and \\
+    {\tt Operators\_Properties.v} together.
+
+\item {\tt Newman.v} proves Newman's lemma on noetherian and locally
+  confluent relations.
+
+\end{itemize}
diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v
new file mode 100644
index 00000000..63f21fed
--- /dev/null
+++ b/theories/Setoids/Setoid.v
@@ -0,0 +1,71 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Setoid.v,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $: i*)
+
+Section Setoid.
+
+Variable A : Type.
+Variable Aeq : A -> A -> Prop.
+
+Record Setoid_Theory : Prop := 
+  {Seq_refl : forall x:A, Aeq x x;
+   Seq_sym : forall x y:A, Aeq x y -> Aeq y x;
+   Seq_trans : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z}.
+
+End Setoid.
+
+Definition Prop_S : Setoid_Theory Prop iff.
+split; [ exact iff_refl | exact iff_sym | exact iff_trans ].
+Qed.
+
+Add Setoid Prop iff Prop_S.
+
+Hint Resolve (Seq_refl Prop iff Prop_S): setoid.
+Hint Resolve (Seq_sym Prop iff Prop_S): setoid.
+Hint Resolve (Seq_trans Prop iff Prop_S): setoid.
+
+Add Morphism or : or_ext.
+intros.
+inversion H1.
+left.
+inversion H.
+apply (H3 H2).
+
+right.
+inversion H0.
+apply (H3 H2).
+Qed.
+
+Add Morphism and : and_ext.
+intros.
+inversion H1.
+split.
+inversion H.
+apply (H4 H2).
+
+inversion H0.
+apply (H4 H3).
+Qed.
+
+Add Morphism not : not_ext.
+red in |- *; intros.
+apply H0.
+inversion H.
+apply (H3 H1).
+Qed.
+
+Definition fleche (A B:Prop) := A -> B.
+
+Add Morphism fleche : fleche_ext.
+unfold fleche in |- *.
+intros.
+inversion H0.
+inversion H.
+apply (H3 (H1 (H6 H2))).
+Qed.
diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v
new file mode 100755
index 00000000..98cb14e4
--- /dev/null
+++ b/theories/Sets/Classical_sets.v
@@ -0,0 +1,132 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Classical_sets.v,v 1.4.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+Require Export Ensembles.
+Require Export Constructive_sets.
+Require Export Classical_Type.
+
+(* Hints Unfold  not . *)
+
+Section Ensembles_classical.
+Variable U : Type.
+
+Lemma not_included_empty_Inhabited :
+ forall A:Ensemble U, ~ Included U A (Empty_set U) -> Inhabited U A.
+Proof.
+intros A NI.
+elim (not_all_ex_not U (fun x:U => ~ In U A x)).
+intros x H; apply Inhabited_intro with x.
+apply NNPP; auto with sets.
+red in |- *; intro.
+apply NI; red in |- *.
+intros x H'; elim (H x); trivial with sets.
+Qed.
+Hint Resolve not_included_empty_Inhabited.
+
+Lemma not_empty_Inhabited :
+ forall A:Ensemble U, A <> Empty_set U -> Inhabited U A.
+Proof.
+intros; apply not_included_empty_Inhabited.
+red in |- *; auto with sets.
+Qed.
+
+Lemma Inhabited_Setminus :
+ forall X Y:Ensemble U,
+   Included U X Y -> ~ Included U Y X -> Inhabited U (Setminus U Y X).
+Proof.
+intros X Y I NI. 
+elim (not_all_ex_not U (fun x:U => In U Y x -> In U X x) NI).
+intros x YX.
+apply Inhabited_intro with x.
+apply Setminus_intro.
+apply not_imply_elim with (In U X x); trivial with sets.
+auto with sets.
+Qed.
+Hint Resolve Inhabited_Setminus.
+
+Lemma Strict_super_set_contains_new_element :
+ forall X Y:Ensemble U,
+   Included U X Y -> X <> Y -> Inhabited U (Setminus U Y X).
+Proof.
+auto 7 with sets.
+Qed.
+Hint Resolve Strict_super_set_contains_new_element.
+
+Lemma Subtract_intro :
+ forall (A:Ensemble U) (x y:U), In U A y -> x <> y -> In U (Subtract U A x) y.
+Proof.
+unfold Subtract at 1 in |- *; auto with sets.
+Qed.
+Hint Resolve Subtract_intro.
+
+Lemma Subtract_inv :
+ forall (A:Ensemble U) (x y:U), In U (Subtract U A x) y -> In U A y /\ x <> y.
+Proof.
+intros A x y H'; elim H'; auto with sets.
+Qed.
+
+Lemma Included_Strict_Included :
+ forall X Y:Ensemble U, Included U X Y -> Strict_Included U X Y \/ X = Y.
+Proof.
+intros X Y H'; try assumption.
+elim (classic (X = Y)); auto with sets.
+Qed.
+
+Lemma Strict_Included_inv :
+ forall X Y:Ensemble U,
+   Strict_Included U X Y -> Included U X Y /\ Inhabited U (Setminus U Y X).
+Proof.
+intros X Y H'; red in H'.
+split; [ tauto | idtac ].
+elim H'; intros H'0 H'1; try exact H'1; clear H'.
+apply Strict_super_set_contains_new_element; auto with sets.
+Qed.
+
+Lemma not_SIncl_empty :
+ forall X:Ensemble U, ~ Strict_Included U X (Empty_set U).
+Proof.
+intro X; red in |- *; intro H'; try exact H'.
+lapply (Strict_Included_inv X (Empty_set U)); auto with sets.
+intro H'0; elim H'0; intros H'1 H'2; elim H'2; clear H'0.
+intros x H'0; elim H'0.
+intro H'3; elim H'3.
+Qed.
+
+Lemma Complement_Complement :
+ forall A:Ensemble U, Complement U (Complement U A) = A.
+Proof.
+unfold Complement in |- *; intros; apply Extensionality_Ensembles;
+ auto with sets.
+red in |- *; split; auto with sets.
+red in |- *; intros; apply NNPP; auto with sets.
+Qed.
+
+End Ensembles_classical.
+
+Hint Resolve Strict_super_set_contains_new_element Subtract_intro
+  not_SIncl_empty: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v
new file mode 100755
index 00000000..a2bc781d
--- /dev/null
+++ b/theories/Sets/Constructive_sets.v
@@ -0,0 +1,159 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Constructive_sets.v,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+Require Export Ensembles.
+
+Section Ensembles_facts.
+Variable U : Type.
+
+Lemma Extension : forall B C:Ensemble U, B = C -> Same_set U B C.
+Proof.
+intros B C H'; rewrite H'; auto with sets.
+Qed.
+
+Lemma Noone_in_empty : forall x:U, ~ In U (Empty_set U) x.
+Proof.
+red in |- *; destruct 1.
+Qed.
+Hint Resolve Noone_in_empty.
+
+Lemma Included_Empty : forall A:Ensemble U, Included U (Empty_set U) A.
+Proof.
+intro; red in |- *.
+intros x H; elim (Noone_in_empty x); auto with sets.
+Qed.
+Hint Resolve Included_Empty.
+
+Lemma Add_intro1 :
+ forall (A:Ensemble U) (x y:U), In U A y -> In U (Add U A x) y.
+Proof.
+unfold Add at 1 in |- *; auto with sets.
+Qed.
+Hint Resolve Add_intro1.
+
+Lemma Add_intro2 : forall (A:Ensemble U) (x:U), In U (Add U A x) x.
+Proof.
+unfold Add at 1 in |- *; auto with sets.
+Qed.
+Hint Resolve Add_intro2.
+
+Lemma Inhabited_add : forall (A:Ensemble U) (x:U), Inhabited U (Add U A x).
+Proof.
+intros A x.
+apply Inhabited_intro with (x := x); auto with sets.
+Qed.
+Hint Resolve Inhabited_add.
+
+Lemma Inhabited_not_empty :
+ forall X:Ensemble U, Inhabited U X -> X <> Empty_set U.
+Proof.
+intros X H'; elim H'.
+intros x H'0; red in |- *; intro H'1.
+absurd (In U X x); auto with sets.
+rewrite H'1; auto with sets.
+Qed.
+Hint Resolve Inhabited_not_empty.
+
+Lemma Add_not_Empty : forall (A:Ensemble U) (x:U), Add U A x <> Empty_set U.
+Proof.
+auto with sets.
+Qed.
+Hint Resolve Add_not_Empty.
+
+Lemma not_Empty_Add : forall (A:Ensemble U) (x:U), Empty_set U <> Add U A x.
+Proof.
+intros; red in |- *; intro H; generalize (Add_not_Empty A x); auto with sets.
+Qed.
+Hint Resolve not_Empty_Add.
+
+Lemma Singleton_inv : forall x y:U, In U (Singleton U x) y -> x = y.
+Proof.
+intros x y H'; elim H'; trivial with sets.
+Qed.
+Hint Resolve Singleton_inv.
+
+Lemma Singleton_intro : forall x y:U, x = y -> In U (Singleton U x) y.
+Proof.
+intros x y H'; rewrite H'; trivial with sets.
+Qed.
+Hint Resolve Singleton_intro.
+
+Lemma Union_inv :
+ forall (B C:Ensemble U) (x:U), In U (Union U B C) x -> In U B x \/ In U C x.
+Proof.
+intros B C x H'; elim H'; auto with sets.
+Qed.
+
+Lemma Add_inv :
+ forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y.
+Proof.
+intros A x y H'; elim H'; auto with sets.
+Qed.
+
+Lemma Intersection_inv :
+ forall (B C:Ensemble U) (x:U),
+   In U (Intersection U B C) x -> In U B x /\ In U C x.
+Proof.
+intros B C x H'; elim H'; auto with sets.
+Qed.
+Hint Resolve Intersection_inv.
+
+Lemma Couple_inv : forall x y z:U, In U (Couple U x y) z -> z = x \/ z = y.
+Proof.
+intros x y z H'; elim H'; auto with sets.
+Qed.
+Hint Resolve Couple_inv.
+
+Lemma Setminus_intro :
+ forall (A B:Ensemble U) (x:U),
+   In U A x -> ~ In U B x -> In U (Setminus U A B) x.
+Proof.
+unfold Setminus at 1 in |- *; red in |- *; auto with sets.
+Qed.
+Hint Resolve Setminus_intro.
+ 
+Lemma Strict_Included_intro :
+ forall X Y:Ensemble U, Included U X Y /\ X <> Y -> Strict_Included U X Y.
+Proof.
+auto with sets.
+Qed.
+Hint Resolve Strict_Included_intro.
+
+Lemma Strict_Included_strict : forall X:Ensemble U, ~ Strict_Included U X X.
+Proof.
+intro X; red in |- *; intro H'; elim H'.
+intros H'0 H'1; elim H'1; auto with sets.
+Qed.
+Hint Resolve Strict_Included_strict.
+
+End Ensembles_facts.
+
+Hint Resolve Singleton_inv Singleton_intro Add_intro1 Add_intro2
+  Intersection_inv Couple_inv Setminus_intro Strict_Included_intro
+  Strict_Included_strict Noone_in_empty Inhabited_not_empty Add_not_Empty
+  not_Empty_Add Inhabited_add Included_Empty: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v
new file mode 100755
index 00000000..9fae12f5
--- /dev/null
+++ b/theories/Sets/Cpo.v
@@ -0,0 +1,109 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Cpo.v,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+Require Export Ensembles.
+Require Export Relations_1.
+Require Export Partial_Order.
+
+Section Bounds.
+Variable U : Type.
+Variable D : PO U.
+
+Let C := Carrier_of U D.
+
+Let R := Rel_of U D.
+
+Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop :=
+    Upper_Bound_definition :
+      In U C x -> (forall y:U, In U B y -> R y x) -> Upper_Bound B x.
+
+Inductive Lower_Bound (B:Ensemble U) (x:U) : Prop :=
+    Lower_Bound_definition :
+      In U C x -> (forall y:U, In U B y -> R x y) -> Lower_Bound B x.
+
+Inductive Lub (B:Ensemble U) (x:U) : Prop :=
+    Lub_definition :
+      Upper_Bound B x -> (forall y:U, Upper_Bound B y -> R x y) -> Lub B x.
+
+Inductive Glb (B:Ensemble U) (x:U) : Prop :=
+    Glb_definition :
+      Lower_Bound B x -> (forall y:U, Lower_Bound B y -> R y x) -> Glb B x.
+
+Inductive Bottom (bot:U) : Prop :=
+    Bottom_definition :
+      In U C bot -> (forall y:U, In U C y -> R bot y) -> Bottom bot.
+
+Inductive Totally_ordered (B:Ensemble U) : Prop :=
+    Totally_ordered_definition :
+      (Included U B C ->
+       forall x y:U, Included U (Couple U x y) B -> R x y \/ R y x) ->
+      Totally_ordered B.
+
+Definition Compatible : Relation U :=
+  fun x y:U =>
+    In U C x ->
+    In U C y ->  exists z : _, In U C z /\ Upper_Bound (Couple U x y) z.
+	
+Inductive Directed (X:Ensemble U) : Prop :=
+    Definition_of_Directed :
+      Included U X C ->
+      Inhabited U X ->
+      (forall x1 x2:U,
+         Included U (Couple U x1 x2) X ->
+          exists x3 : _, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) ->
+      Directed X.
+
+Inductive Complete : Prop :=
+    Definition_of_Complete :
+      (exists bot : _, Bottom bot) ->
+      (forall X:Ensemble U, Directed X ->  exists bsup : _, Lub X bsup) ->
+      Complete.
+
+Inductive Conditionally_complete : Prop :=
+    Definition_of_Conditionally_complete :
+      (forall X:Ensemble U,
+         Included U X C ->
+         (exists maj : _, Upper_Bound X maj) ->
+          exists bsup : _, Lub X bsup) -> Conditionally_complete.
+End Bounds.
+Hint Resolve Totally_ordered_definition Upper_Bound_definition
+  Lower_Bound_definition Lub_definition Glb_definition Bottom_definition
+  Definition_of_Complete Definition_of_Complete
+  Definition_of_Conditionally_complete.
+
+Section Specific_orders.
+Variable U : Type.
+
+Record Cpo : Type := Definition_of_cpo
+  {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}.
+
+Record Chain : Type := Definition_of_chain
+  {PO_of_chain : PO U;
+   Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}.
+
+End Specific_orders.
\ No newline at end of file
diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v
new file mode 100755
index 00000000..05afc298
--- /dev/null
+++ b/theories/Sets/Ensembles.v
@@ -0,0 +1,101 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Ensembles.v,v 1.7.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+Section Ensembles.
+Variable U : Type.
+
+Definition Ensemble := U -> Prop. 
+
+Definition In (A:Ensemble) (x:U) : Prop := A x.
+
+Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x.
+
+Inductive Empty_set : Ensemble :=.
+
+Inductive Full_set : Ensemble :=
+    Full_intro : forall x:U, In Full_set x.
+
+(** NB: The following definition builds-in equality of elements in [U] as 
+   Leibniz equality. 
+
+   This may have to be changed if we replace [U] by a Setoid on [U] 
+   with its own equality [eqs], with  
+   [In_singleton: (y: U)(eqs x y) -> (In (Singleton x) y)]. *)
+
+Inductive Singleton (x:U) : Ensemble :=
+    In_singleton : In (Singleton x) x.
+
+Inductive Union (B C:Ensemble) : Ensemble :=
+  | Union_introl : forall x:U, In B x -> In (Union B C) x
+  | Union_intror : forall x:U, In C x -> In (Union B C) x.
+
+Definition Add (B:Ensemble) (x:U) : Ensemble := Union B (Singleton x).
+
+Inductive Intersection (B C:Ensemble) : Ensemble :=
+    Intersection_intro :
+      forall x:U, In B x -> In C x -> In (Intersection B C) x.
+
+Inductive Couple (x y:U) : Ensemble :=
+  | Couple_l : In (Couple x y) x
+  | Couple_r : In (Couple x y) y.
+
+Inductive Triple (x y z:U) : Ensemble :=
+  | Triple_l : In (Triple x y z) x
+  | Triple_m : In (Triple x y z) y
+  | Triple_r : In (Triple x y z) z.
+
+Definition Complement (A:Ensemble) : Ensemble := fun x:U => ~ In A x.
+
+Definition Setminus (B C:Ensemble) : Ensemble :=
+  fun x:U => In B x /\ ~ In C x.
+
+Definition Subtract (B:Ensemble) (x:U) : Ensemble := Setminus B (Singleton x).
+
+Inductive Disjoint (B C:Ensemble) : Prop :=
+    Disjoint_intro : (forall x:U, ~ In (Intersection B C) x) -> Disjoint B C.
+
+Inductive Inhabited (B:Ensemble) : Prop :=
+    Inhabited_intro : forall x:U, In B x -> Inhabited B.
+
+Definition Strict_Included (B C:Ensemble) : Prop := Included B C /\ B <> C.
+
+Definition Same_set (B C:Ensemble) : Prop := Included B C /\ Included C B.
+
+(** Extensionality Axiom *)
+
+Axiom Extensionality_Ensembles : forall A B:Ensemble, Same_set A B -> A = B.
+Hint Resolve Extensionality_Ensembles.
+
+End Ensembles.
+
+Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets
+  v62.
+
+Hint Resolve Union_introl Union_intror Intersection_intro In_singleton
+  Couple_l Couple_r Triple_l Triple_m Triple_r Disjoint_intro
+  Extensionality_Ensembles: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v
new file mode 100755
index 00000000..5a2e4397
--- /dev/null
+++ b/theories/Sets/Finite_sets.v
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Finite_sets.v,v 1.6.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+Require Import Ensembles.
+
+Section Ensembles_finis.
+Variable U : Type.
+
+Inductive Finite : Ensemble U -> Prop :=
+  | Empty_is_finite : Finite (Empty_set U)
+  | Union_is_finite :
+      forall A:Ensemble U,
+        Finite A -> forall x:U, ~ In U A x -> Finite (Add U A x).
+
+Inductive cardinal : Ensemble U -> nat -> Prop :=
+  | card_empty : cardinal (Empty_set U) 0
+  | card_add :
+      forall (A:Ensemble U) (n:nat),
+        cardinal A n -> forall x:U, ~ In U A x -> cardinal (Add U A x) (S n).
+
+End Ensembles_finis.
+
+Hint Resolve Empty_is_finite Union_is_finite: sets v62.
+Hint Resolve card_empty card_add: sets v62.
+
+Require Import Constructive_sets.
+
+Section Ensembles_finis_facts.
+Variable U : Type.
+
+Lemma cardinal_invert :
+ forall (X:Ensemble U) (p:nat),
+   cardinal U X p ->
+   match p with
+   | O => X = Empty_set U
+   | S n =>
+        exists A : _,
+         (exists x : _, X = Add U A x /\ ~ In U A x /\ cardinal U A n)
+   end.
+Proof.
+induction 1; simpl in |- *; auto.
+exists A; exists x; auto.
+Qed.
+
+Lemma cardinal_elim :
+ forall (X:Ensemble U) (p:nat),
+   cardinal U X p ->
+   match p with
+   | O => X = Empty_set U
+   | S n => Inhabited U X
+   end.
+Proof.
+intros X p C; elim C; simpl in |- *; trivial with sets.
+Qed.
+
+End Ensembles_finis_facts.
diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v
new file mode 100755
index 00000000..952965e8
--- /dev/null
+++ b/theories/Sets/Finite_sets_facts.v
@@ -0,0 +1,347 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Finite_sets_facts.v,v 1.7.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+Require Export Finite_sets.
+Require Export Constructive_sets.
+Require Export Classical_Type.
+Require Export Classical_sets.
+Require Export Powerset.
+Require Export Powerset_facts.
+Require Export Powerset_Classical_facts.
+Require Export Gt.
+Require Export Lt.
+
+Section Finite_sets_facts.
+Variable U : Type.
+
+Lemma finite_cardinal :
+ forall X:Ensemble U, Finite U X ->  exists n : nat, cardinal U X n.
+Proof.
+induction 1 as [| A _ [n H]].
+exists 0; auto with sets.
+exists (S n); auto with sets.
+Qed.
+
+Lemma cardinal_finite :
+ forall (X:Ensemble U) (n:nat), cardinal U X n -> Finite U X.
+Proof.
+induction 1; auto with sets.
+Qed.
+
+Theorem Add_preserves_Finite :
+ forall (X:Ensemble U) (x:U), Finite U X -> Finite U (Add U X x).
+Proof.
+intros X x H'.
+elim (classic (In U X x)); intro H'0; auto with sets.
+rewrite (Non_disjoint_union U X x); auto with sets.
+Qed.
+Hint Resolve Add_preserves_Finite.
+
+Theorem Singleton_is_finite : forall x:U, Finite U (Singleton U x).
+Proof.
+intro x; rewrite <- (Empty_set_zero U (Singleton U x)).
+change (Finite U (Add U (Empty_set U) x)) in |- *; auto with sets.
+Qed.
+Hint Resolve Singleton_is_finite.
+
+Theorem Union_preserves_Finite :
+ forall X Y:Ensemble U, Finite U X -> Finite U Y -> Finite U (Union U X Y).
+Proof.
+intros X Y H'; elim H'.
+rewrite (Empty_set_zero U Y); auto with sets.
+intros A H'0 H'1 x H'2 H'3.
+rewrite (Union_commutative U (Add U A x) Y).
+rewrite <- (Union_add U Y A x).
+rewrite (Union_commutative U Y A); auto with sets.
+Qed.
+
+Lemma Finite_downward_closed :
+ forall A:Ensemble U,
+   Finite U A -> forall X:Ensemble U, Included U X A -> Finite U X.
+Proof.
+intros A H'; elim H'; auto with sets.
+intros X H'0.
+rewrite (less_than_empty U X H'0); auto with sets.
+intros; elim Included_Add with U X A0 x; auto with sets.
+destruct 1 as [A' [H5 H6]].
+rewrite H5; auto with sets.
+Qed.
+
+Lemma Intersection_preserves_finite :
+ forall A:Ensemble U,
+   Finite U A -> forall X:Ensemble U, Finite U (Intersection U X A).
+Proof.
+intros A H' X; apply Finite_downward_closed with A; auto with sets.
+Qed.
+
+Lemma cardinalO_empty :
+ forall X:Ensemble U, cardinal U X 0 -> X = Empty_set U.
+Proof.
+intros X H; apply (cardinal_invert U X 0); trivial with sets.
+Qed.
+Hint Resolve cardinalO_empty.
+
+Lemma inh_card_gt_O :
+ forall X:Ensemble U, Inhabited U X -> forall n:nat, cardinal U X n -> n > 0.
+Proof.
+induction 1 as [x H'].
+intros n H'0.
+elim (gt_O_eq n); auto with sets.
+intro H'1; generalize H'; generalize H'0.
+rewrite <- H'1; intro H'2.
+rewrite (cardinalO_empty X); auto with sets.
+intro H'3; elim H'3.
+Qed.
+
+Lemma card_soustr_1 :
+ forall (X:Ensemble U) (n:nat),
+   cardinal U X n ->
+   forall x:U, In U X x -> cardinal U (Subtract U X x) (pred n).
+Proof.
+intros X n H'; elim H'.
+intros x H'0; elim H'0.
+clear H' n X.
+intros X n H' H'0 x H'1 x0 H'2.
+elim (classic (In U X x0)).
+intro H'4; rewrite (add_soustr_xy U X x x0).
+elim (classic (x = x0)).
+intro H'5.
+absurd (In U X x0); auto with sets.
+rewrite <- H'5; auto with sets.
+intro H'3; try assumption.
+cut (S (pred n) = pred (S n)).
+intro H'5; rewrite <- H'5.
+apply card_add; auto with sets.
+red in |- *; intro H'6; elim H'6.
+intros H'7 H'8; try assumption.
+elim H'1; auto with sets.
+unfold pred at 2 in |- *; symmetry  in |- *.
+apply S_pred with (m := 0).
+change (n > 0) in |- *.
+apply inh_card_gt_O with (X := X); auto with sets.
+apply Inhabited_intro with (x := x0); auto with sets.
+red in |- *; intro H'3.
+apply H'1.
+elim H'3; auto with sets.
+rewrite H'3; auto with sets.
+elim (classic (x = x0)).
+intro H'3; rewrite <- H'3.
+cut (Subtract U (Add U X x) x = X); auto with sets.
+intro H'4; rewrite H'4; auto with sets.
+intros H'3 H'4; try assumption.
+absurd (In U (Add U X x) x0); auto with sets.
+red in |- *; intro H'5; try exact H'5.
+lapply (Add_inv U X x x0); tauto.
+Qed.
+
+Lemma cardinal_is_functional :
+ forall (X:Ensemble U) (c1:nat),
+   cardinal U X c1 ->
+   forall (Y:Ensemble U) (c2:nat), cardinal U Y c2 -> X = Y -> c1 = c2.
+Proof.
+intros X c1 H'; elim H'.
+intros Y c2 H'0; elim H'0; auto with sets.
+intros A n H'1 H'2 x H'3 H'5.
+elim (not_Empty_Add U A x); auto with sets.
+clear H' c1 X.
+intros X n H' H'0 x H'1 Y c2 H'2.
+elim H'2.
+intro H'3.
+elim (not_Empty_Add U X x); auto with sets.
+clear H'2 c2 Y.
+intros X0 c2 H'2 H'3 x0 H'4 H'5.
+elim (classic (In U X0 x)).
+intro H'6; apply f_equal with nat.
+apply H'0 with (Y := Subtract U (Add U X0 x0) x).
+elimtype (pred (S c2) = c2); auto with sets.
+apply card_soustr_1; auto with sets.
+rewrite <- H'5.
+apply Sub_Add_new; auto with sets.
+elim (classic (x = x0)).
+intros H'6 H'7; apply f_equal with nat.
+apply H'0 with (Y := X0); auto with sets.
+apply Simplify_add with (x := x); auto with sets.
+pattern x at 2 in |- *; rewrite H'6; auto with sets.
+intros H'6 H'7.
+absurd (Add U X x = Add U X0 x0); auto with sets.
+clear H'0 H' H'3 n H'5 H'4 H'2 H'1 c2.
+red in |- *; intro H'.
+lapply (Extension U (Add U X x) (Add U X0 x0)); auto with sets.
+clear H'.
+intro H'; red in H'.
+elim H'; intros H'0 H'1; red in H'0; clear H' H'1.
+absurd (In U (Add U X0 x0) x); auto with sets.
+lapply (Add_inv U X0 x0 x); [ intuition | apply (H'0 x); apply Add_intro2 ].
+Qed.
+
+Lemma cardinal_Empty : forall m:nat, cardinal U (Empty_set U) m -> 0 = m.
+Proof.
+intros m Cm; generalize (cardinal_invert U (Empty_set U) m Cm).
+elim m; auto with sets.
+intros; elim H0; intros; elim H1; intros; elim H2; intros.
+elim (not_Empty_Add U x x0 H3).
+Qed.
+
+Lemma cardinal_unicity :
+ forall (X:Ensemble U) (n:nat),
+   cardinal U X n -> forall m:nat, cardinal U X m -> n = m.
+Proof.
+intros; apply cardinal_is_functional with X X; auto with sets.
+Qed.
+
+Lemma card_Add_gen :
+ forall (A:Ensemble U) (x:U) (n n':nat),
+   cardinal U A n -> cardinal U (Add U A x) n' -> n' <= S n.
+Proof.
+intros A x n n' H'.
+elim (classic (In U A x)).
+intro H'0.
+rewrite (Non_disjoint_union U A x H'0).
+intro H'1; cut (n = n').
+intro E; rewrite E; auto with sets.
+apply cardinal_unicity with A; auto with sets.
+intros H'0 H'1.
+cut (n' = S n).
+intro E; rewrite E; auto with sets.
+apply cardinal_unicity with (Add U A x); auto with sets.
+Qed.
+
+Lemma incl_st_card_lt :
+ forall (X:Ensemble U) (c1:nat),
+   cardinal U X c1 ->
+   forall (Y:Ensemble U) (c2:nat),
+     cardinal U Y c2 -> Strict_Included U X Y -> c2 > c1.
+Proof.
+intros X c1 H'; elim H'.
+intros Y c2 H'0; elim H'0; auto with sets arith.
+intro H'1.
+elim (Strict_Included_strict U (Empty_set U)); auto with sets arith.
+clear H' c1 X.
+intros X n H' H'0 x H'1 Y c2 H'2.
+elim H'2.
+intro H'3; elim (not_SIncl_empty U (Add U X x)); auto with sets arith.
+clear H'2 c2 Y.
+intros X0 c2 H'2 H'3 x0 H'4 H'5; elim (classic (In U X0 x)).
+intro H'6; apply gt_n_S.
+apply H'0 with (Y := Subtract U (Add U X0 x0) x).
+elimtype (pred (S c2) = c2); auto with sets arith.
+apply card_soustr_1; auto with sets arith.
+apply incl_st_add_soustr; auto with sets arith.
+elim (classic (x = x0)).
+intros H'6 H'7; apply gt_n_S.
+apply H'0 with (Y := X0); auto with sets arith.
+apply sincl_add_x with (x := x0).
+rewrite <- H'6; auto with sets arith.
+pattern x0 at 1 in |- *; rewrite <- H'6; trivial with sets arith.
+intros H'6 H'7; red in H'5.
+elim H'5; intros H'8 H'9; try exact H'8; clear H'5.
+red in H'8.
+generalize (H'8 x).
+intro H'5; lapply H'5; auto with sets arith.
+intro H; elim Add_inv with U X0 x0 x; auto with sets arith.
+intro; absurd (In U X0 x); auto with sets arith.
+intro; absurd (x = x0); auto with sets arith.
+Qed.
+
+Lemma incl_card_le :
+ forall (X Y:Ensemble U) (n m:nat),
+   cardinal U X n -> cardinal U Y m -> Included U X Y -> n <= m.
+Proof.
+intros; elim Included_Strict_Included with U X Y; auto with sets arith; intro.
+cut (m > n); auto with sets arith.
+apply incl_st_card_lt with (X := X) (Y := Y); auto with sets arith.
+generalize H0; rewrite <- H2; intro.
+cut (n = m).
+intro E; rewrite E; auto with sets arith.
+apply cardinal_unicity with X; auto with sets arith.
+Qed.
+
+Lemma G_aux :
+ forall P:Ensemble U -> Prop,
+   (forall X:Ensemble U,
+      Finite U X ->
+      (forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) ->
+   P (Empty_set U).
+Proof.
+intros P H'; try assumption.
+apply H'; auto with sets.
+clear H'; auto with sets.
+intros Y H'; try assumption.
+red in H'.
+elim H'; intros H'0 H'1; try exact H'1; clear H'.
+lapply (less_than_empty U Y); [ intro H'3; try exact H'3 | assumption ].
+elim H'1; auto with sets.
+Qed.
+
+Hint Unfold not.
+
+Lemma Generalized_induction_on_finite_sets :
+ forall P:Ensemble U -> Prop,
+   (forall X:Ensemble U,
+      Finite U X ->
+      (forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) ->
+   forall X:Ensemble U, Finite U X -> P X.
+Proof.
+intros P H'0 X H'1.
+generalize P H'0; clear H'0 P.
+elim H'1.
+intros P H'0.
+apply G_aux; auto with sets.
+clear H'1 X.
+intros A H' H'0 x H'1 P H'3.
+cut (forall Y:Ensemble U, Included U Y (Add U A x) -> P Y); auto with sets.
+generalize H'1.
+apply H'0.
+intros X K H'5 L Y H'6; apply H'3; auto with sets.
+apply Finite_downward_closed with (A := Add U X x); auto with sets.
+intros Y0 H'7.
+elim (Strict_inclusion_is_transitive_with_inclusion U Y0 Y (Add U X x));
+ auto with sets.
+intros H'2 H'4.
+elim (Included_Add U Y0 X x);
+ [ intro H'14
+ | intro H'14; elim H'14; intros A' E; elim E; intros H'15 H'16; clear E H'14
+ | idtac ]; auto with sets.
+elim (Included_Strict_Included U Y0 X); auto with sets.
+intro H'9; apply H'5 with (Y := Y0); auto with sets.
+intro H'9; rewrite H'9.
+apply H'3; auto with sets.
+intros Y1 H'8; elim H'8.
+intros H'10 H'11; apply H'5 with (Y := Y1); auto with sets.
+elim (Included_Strict_Included U A' X); auto with sets.
+intro H'8; apply H'5 with (Y := A'); auto with sets.
+rewrite <- H'15; auto with sets.
+intro H'8.
+elim H'7.
+intros H'9 H'10; apply H'10 || elim H'10; try assumption.
+generalize H'6.
+rewrite <- H'8.
+rewrite <- H'15; auto with sets.
+Qed.
+
+End Finite_sets_facts.
\ No newline at end of file
diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v
new file mode 100755
index 00000000..f58f2f81
--- /dev/null
+++ b/theories/Sets/Image.v
@@ -0,0 +1,205 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Image.v,v 1.6.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+Require Export Finite_sets.
+Require Export Constructive_sets.
+Require Export Classical_Type.
+Require Export Classical_sets.
+Require Export Powerset.
+Require Export Powerset_facts.
+Require Export Powerset_Classical_facts.
+Require Export Gt.
+Require Export Lt.
+Require Export Le.
+Require Export Finite_sets_facts.
+
+Section Image.
+Variables U V : Type.
+
+Inductive Im (X:Ensemble U) (f:U -> V) : Ensemble V :=
+    Im_intro : forall x:U, In _ X x -> forall y:V, y = f x -> In _ (Im X f) y.
+
+Lemma Im_def :
+ forall (X:Ensemble U) (f:U -> V) (x:U), In _ X x -> In _ (Im X f) (f x).
+Proof.
+intros X f x H'; try assumption.
+apply Im_intro with (x := x); auto with sets.
+Qed.
+Hint Resolve Im_def.
+
+Lemma Im_add :
+ forall (X:Ensemble U) (x:U) (f:U -> V),
+   Im (Add _ X x) f = Add _ (Im X f) (f x).
+Proof.
+intros X x f.
+apply Extensionality_Ensembles.
+split; red in |- *; intros x0 H'.
+elim H'; intros.
+rewrite H0.
+elim Add_inv with U X x x1; auto with sets.
+destruct 1; auto with sets.
+elim Add_inv with V (Im X f) (f x) x0; auto with sets.
+destruct 1 as [x0 H y H0].
+rewrite H0; auto with sets.
+destruct 1; auto with sets.
+Qed.
+
+Lemma image_empty : forall f:U -> V, Im (Empty_set U) f = Empty_set V.
+Proof.
+intro f; try assumption.
+apply Extensionality_Ensembles.
+split; auto with sets.
+red in |- *.
+intros x H'; elim H'.
+intros x0 H'0; elim H'0; auto with sets.
+Qed.
+Hint Resolve image_empty.
+
+Lemma finite_image :
+ forall (X:Ensemble U) (f:U -> V), Finite _ X -> Finite _ (Im X f).
+Proof.
+intros X f H'; elim H'.
+rewrite (image_empty f); auto with sets.
+intros A H'0 H'1 x H'2; clear H' X.
+rewrite (Im_add A x f); auto with sets.
+apply Add_preserves_Finite; auto with sets.
+Qed.
+Hint Resolve finite_image.
+
+Lemma Im_inv :
+ forall (X:Ensemble U) (f:U -> V) (y:V),
+   In _ (Im X f) y ->  exists x : U, In _ X x /\ f x = y.
+Proof.
+intros X f y H'; elim H'.
+intros x H'0 y0 H'1; rewrite H'1.
+exists x; auto with sets.
+Qed.
+
+Definition injective (f:U -> V) := forall x y:U, f x = f y -> x = y.
+
+Lemma not_injective_elim :
+ forall f:U -> V,
+   ~ injective f ->  exists x : _, (exists y : _, f x = f y /\ x <> y).
+Proof.
+unfold injective in |- *; intros f H.
+cut (exists x : _, ~ (forall y:U, f x = f y -> x = y)).
+2: apply not_all_ex_not with (P := fun x:U => forall y:U, f x = f y -> x = y);
+    trivial with sets.
+destruct 1 as [x C]; exists x.
+cut (exists y : _, ~ (f x = f y -> x = y)).
+2: apply not_all_ex_not with (P := fun y:U => f x = f y -> x = y);
+    trivial with sets.
+destruct 1 as [y D]; exists y.
+apply imply_to_and; trivial with sets.
+Qed.
+
+Lemma cardinal_Im_intro :
+ forall (A:Ensemble U) (f:U -> V) (n:nat),
+   cardinal _ A n ->  exists p : nat, cardinal _ (Im A f) p.
+Proof.
+intros.
+apply finite_cardinal; apply finite_image.
+apply cardinal_finite with n; trivial with sets.
+Qed.
+
+Lemma In_Image_elim :
+ forall (A:Ensemble U) (f:U -> V),
+   injective f -> forall x:U, In _ (Im A f) (f x) -> In _ A x.
+Proof.
+intros.
+elim Im_inv with A f (f x); trivial with sets.
+intros z C; elim C; intros InAz E.
+elim (H z x E); trivial with sets.
+Qed.
+
+Lemma injective_preserves_cardinal :
+ forall (A:Ensemble U) (f:U -> V) (n:nat),
+   injective f ->
+   cardinal _ A n -> forall n':nat, cardinal _ (Im A f) n' -> n' = n.
+Proof.
+induction 2 as [| A n H'0 H'1 x H'2]; auto with sets.
+rewrite (image_empty f).
+intros n' CE.
+apply cardinal_unicity with V (Empty_set V); auto with sets.
+intro n'.
+rewrite (Im_add A x f).
+intro H'3.
+elim cardinal_Im_intro with A f n; trivial with sets.
+intros i CI.
+lapply (H'1 i); trivial with sets.
+cut (~ In _ (Im A f) (f x)).
+intros H0 H1.
+apply cardinal_unicity with V (Add _ (Im A f) (f x)); trivial with sets.
+apply card_add; auto with sets.
+rewrite <- H1; trivial with sets.
+red in |- *; intro; apply H'2.
+apply In_Image_elim with f; trivial with sets.
+Qed.
+
+Lemma cardinal_decreases :
+ forall (A:Ensemble U) (f:U -> V) (n:nat),
+   cardinal U A n -> forall n':nat, cardinal V (Im A f) n' -> n' <= n.
+Proof.
+induction 1 as [| A n H'0 H'1 x H'2]; auto with sets.
+rewrite (image_empty f); intros.
+cut (n' = 0).
+intro E; rewrite E; trivial with sets.
+apply cardinal_unicity with V (Empty_set V); auto with sets.
+intro n'.
+rewrite (Im_add A x f).
+elim cardinal_Im_intro with A f n; trivial with sets.
+intros p C H'3.
+apply le_trans with (S p).
+apply card_Add_gen with V (Im A f) (f x); trivial with sets.
+apply le_n_S; auto with sets.
+Qed.
+
+Theorem Pigeonhole :
+ forall (A:Ensemble U) (f:U -> V) (n:nat),
+   cardinal U A n ->
+   forall n':nat, cardinal V (Im A f) n' -> n' < n -> ~ injective f.
+Proof.
+unfold not in |- *; intros A f n CAn n' CIfn' ltn'n I.
+cut (n' = n).
+intro E; generalize ltn'n; rewrite E; exact (lt_irrefl n).
+apply injective_preserves_cardinal with (A := A) (f := f) (n := n);
+ trivial with sets.
+Qed.
+
+Lemma Pigeonhole_principle :
+ forall (A:Ensemble U) (f:U -> V) (n:nat),
+   cardinal _ A n ->
+   forall n':nat,
+     cardinal _ (Im A f) n' ->
+     n' < n ->  exists x : _, (exists y : _, f x = f y /\ x <> y).
+Proof.
+intros; apply not_injective_elim.
+apply Pigeonhole with A n n'; trivial with sets.
+Qed.
+End Image.
+Hint Resolve Im_def image_empty finite_image: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v
new file mode 100755
index 00000000..c357e26c
--- /dev/null
+++ b/theories/Sets/Infinite_sets.v
@@ -0,0 +1,244 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Infinite_sets.v,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+Require Export Finite_sets.
+Require Export Constructive_sets.
+Require Export Classical_Type.
+Require Export Classical_sets.
+Require Export Powerset.
+Require Export Powerset_facts.
+Require Export Powerset_Classical_facts.
+Require Export Gt.
+Require Export Lt.
+Require Export Le.
+Require Export Finite_sets_facts.
+Require Export Image.
+
+Section Approx.
+Variable U : Type.
+
+Inductive Approximant (A X:Ensemble U) : Prop :=
+    Defn_of_Approximant : Finite U X -> Included U X A -> Approximant A X.
+End Approx.
+
+Hint Resolve Defn_of_Approximant.
+
+Section Infinite_sets.
+Variable U : Type.
+
+Lemma make_new_approximant :
+ forall A X:Ensemble U,
+   ~ Finite U A -> Approximant U A X -> Inhabited U (Setminus U A X).
+Proof.
+intros A X H' H'0.
+elim H'0; intros H'1 H'2.
+apply Strict_super_set_contains_new_element; auto with sets.
+red in |- *; intro H'3; apply H'.
+rewrite <- H'3; auto with sets.
+Qed.
+
+Lemma approximants_grow :
+ forall A X:Ensemble U,
+   ~ Finite U A ->
+   forall n:nat,
+     cardinal U X n ->
+     Included U X A ->  exists Y : _, cardinal U Y (S n) /\ Included U Y A.
+Proof.
+intros A X H' n H'0; elim H'0; auto with sets.
+intro H'1.
+cut (Inhabited U (Setminus U A (Empty_set U))).
+intro H'2; elim H'2.
+intros x H'3.
+exists (Add U (Empty_set U) x); auto with sets.
+split.
+apply card_add; auto with sets.
+cut (In U A x).
+intro H'4; red in |- *; auto with sets.
+intros x0 H'5; elim H'5; auto with sets.
+intros x1 H'6; elim H'6; auto with sets.
+elim H'3; auto with sets.
+apply make_new_approximant; auto with sets.
+intros A0 n0 H'1 H'2 x H'3 H'5.
+lapply H'2; [ intro H'6; elim H'6; clear H'2 | clear H'2 ]; auto with sets.
+intros x0 H'2; try assumption.
+elim H'2; intros H'7 H'8; try exact H'8; clear H'2.
+elim (make_new_approximant A x0); auto with sets.
+intros x1 H'2; try assumption.
+exists (Add U x0 x1); auto with sets.
+split.
+apply card_add; auto with sets.
+elim H'2; auto with sets.
+red in |- *.
+intros x2 H'9; elim H'9; auto with sets.
+intros x3 H'10; elim H'10; auto with sets.
+elim H'2; auto with sets.
+auto with sets.
+apply Defn_of_Approximant; auto with sets.
+apply cardinal_finite with (n := S n0); auto with sets.
+Qed.
+
+Lemma approximants_grow' :
+ forall A X:Ensemble U,
+   ~ Finite U A ->
+   forall n:nat,
+     cardinal U X n ->
+     Approximant U A X ->
+      exists Y : _, cardinal U Y (S n) /\ Approximant U A Y.
+Proof.
+intros A X H' n H'0 H'1; try assumption.
+elim H'1.
+intros H'2 H'3.
+elimtype (exists Y : _, cardinal U Y (S n) /\ Included U Y A).
+intros x H'4; elim H'4; intros H'5 H'6; try exact H'5; clear H'4.
+exists x; auto with sets.
+split; [ auto with sets | idtac ].
+apply Defn_of_Approximant; auto with sets.
+apply cardinal_finite with (n := S n); auto with sets.
+apply approximants_grow with (X := X); auto with sets.
+Qed.
+
+Lemma approximant_can_be_any_size :
+ forall A X:Ensemble U,
+   ~ Finite U A ->
+   forall n:nat,  exists Y : _, cardinal U Y n /\ Approximant U A Y.
+Proof.
+intros A H' H'0 n; elim n.
+exists (Empty_set U); auto with sets.
+intros n0 H'1; elim H'1.
+intros x H'2.
+apply approximants_grow' with (X := x); tauto.
+Qed.
+
+Variable V : Type.
+
+Theorem Image_set_continuous :
+ forall (A:Ensemble U) (f:U -> V) (X:Ensemble V),
+   Finite V X ->
+   Included V X (Im U V A f) ->
+    exists n : _,
+     (exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X).
+Proof.
+intros A f X H'; elim H'.
+intro H'0; exists 0.
+exists (Empty_set U); auto with sets.
+intros A0 H'0 H'1 x H'2 H'3; try assumption.
+lapply H'1;
+ [ intro H'4; elim H'4; intros n E; elim E; clear H'4 H'1 | clear H'1 ];
+ auto with sets.
+intros x0 H'1; try assumption.
+exists (S n); try assumption.
+elim H'1; intros H'4 H'5; elim H'4; intros H'6 H'7; try exact H'6;
+ clear H'4 H'1.
+clear E.
+generalize H'2.
+rewrite <- H'5.
+intro H'1; try assumption.
+red in H'3.
+generalize (H'3 x).
+intro H'4; lapply H'4; [ intro H'8; try exact H'8; clear H'4 | clear H'4 ];
+ auto with sets.
+specialize  5Im_inv with (U := U) (V := V) (X := A) (f := f) (y := x);
+ intro H'11; lapply H'11; [ intro H'13; elim H'11; clear H'11 | clear H'11 ];
+ auto with sets.
+intros x1 H'4; try assumption.
+apply ex_intro with (x := Add U x0 x1).
+split; [ split; [ try assumption | idtac ] | idtac ].
+apply card_add; auto with sets.
+red in |- *; intro H'9; try exact H'9.
+apply H'1.
+elim H'4; intros H'10 H'11; rewrite <- H'11; clear H'4; auto with sets.
+elim H'4; intros H'9 H'10; try exact H'9; clear H'4; auto with sets.
+red in |- *; auto with sets.
+intros x2 H'4; elim H'4; auto with sets.
+intros x3 H'11; elim H'11; auto with sets.
+elim H'4; intros H'9 H'10; rewrite <- H'10; clear H'4; auto with sets.
+apply Im_add; auto with sets.
+Qed.
+
+Theorem Image_set_continuous' :
+ forall (A:Ensemble U) (f:U -> V) (X:Ensemble V),
+   Approximant V (Im U V A f) X ->
+    exists Y : _, Approximant U A Y /\ Im U V Y f = X.
+Proof.
+intros A f X H'; try assumption.
+cut
+ (exists n : _,
+    (exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X)).
+intro H'0; elim H'0; intros n E; elim E; clear H'0.
+intros x H'0; try assumption.
+elim H'0; intros H'1 H'2; elim H'1; intros H'3 H'4; try exact H'3;
+ clear H'1 H'0; auto with sets.
+exists x.
+split; [ idtac | try assumption ].
+apply Defn_of_Approximant; auto with sets.
+apply cardinal_finite with (n := n); auto with sets.
+apply Image_set_continuous; auto with sets.
+elim H'; auto with sets.
+elim H'; auto with sets.
+Qed.
+
+Theorem Pigeonhole_bis :
+ forall (A:Ensemble U) (f:U -> V),
+   ~ Finite U A -> Finite V (Im U V A f) -> ~ injective U V f.
+Proof.
+intros A f H'0 H'1; try assumption.
+elim (Image_set_continuous' A f (Im U V A f)); auto with sets.
+intros x H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
+elim (make_new_approximant A x); auto with sets.
+intros x0 H'2; elim H'2.
+intros H'5 H'6.
+elim (finite_cardinal V (Im U V A f)); auto with sets.
+intros n E.
+elim (finite_cardinal U x); auto with sets.
+intros n0 E0.
+apply Pigeonhole with (A := Add U x x0) (n := S n0) (n' := n).
+apply card_add; auto with sets.
+rewrite (Im_add U V x x0 f); auto with sets.
+cut (In V (Im U V x f) (f x0)).
+intro H'8.
+rewrite (Non_disjoint_union V (Im U V x f) (f x0)); auto with sets.
+rewrite H'4; auto with sets.
+elim (Extension V (Im U V x f) (Im U V A f)); auto with sets.
+apply le_lt_n_Sm.
+apply cardinal_decreases with (U := U) (V := V) (A := x) (f := f);
+ auto with sets.
+rewrite H'4; auto with sets.
+elim H'3; auto with sets.
+Qed.
+
+Theorem Pigeonhole_ter :
+ forall (A:Ensemble U) (f:U -> V) (n:nat),
+   injective U V f -> Finite V (Im U V A f) -> Finite U A.
+Proof.
+intros A f H' H'0 H'1.
+apply NNPP.
+red in |- *; intro H'2.
+elim (Pigeonhole_bis A f); auto with sets.
+Qed.
+
+End Infinite_sets.
diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v
new file mode 100755
index 00000000..26f29c96
--- /dev/null
+++ b/theories/Sets/Integers.v
@@ -0,0 +1,167 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Integers.v,v 1.6.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+Require Export Finite_sets.
+Require Export Constructive_sets.
+Require Export Classical_Type.
+Require Export Classical_sets.
+Require Export Powerset.
+Require Export Powerset_facts.
+Require Export Powerset_Classical_facts.
+Require Export Gt.
+Require Export Lt.
+Require Export Le.
+Require Export Finite_sets_facts.
+Require Export Image.
+Require Export Infinite_sets.
+Require Export Compare_dec.
+Require Export Relations_1.
+Require Export Partial_Order.
+Require Export Cpo.
+
+Section Integers_sect.
+
+Inductive Integers : Ensemble nat :=
+    Integers_defn : forall x:nat, In nat Integers x.
+Hint Resolve Integers_defn.
+
+Lemma le_reflexive : Reflexive nat le.
+Proof.
+red in |- *; auto with arith.
+Qed.
+
+Lemma le_antisym : Antisymmetric nat le.
+Proof.
+red in |- *; intros x y H H'; rewrite (le_antisym x y); auto.
+Qed.
+
+Lemma le_trans : Transitive nat le.
+Proof.
+red in |- *; intros; apply le_trans with y; auto.
+Qed.
+Hint Resolve le_reflexive le_antisym le_trans.
+
+Lemma le_Order : Order nat le.
+Proof.
+auto with sets arith.
+Qed.
+Hint Resolve le_Order.
+
+Lemma triv_nat : forall n:nat, In nat Integers n.
+Proof.
+auto with sets arith.
+Qed.
+Hint Resolve triv_nat.
+
+Definition nat_po : PO nat.
+apply Definition_of_PO with (Carrier_of := Integers) (Rel_of := le);
+ auto with sets arith.
+apply Inhabited_intro with (x := 0); auto with sets arith.
+Defined.
+Hint Unfold nat_po.
+
+Lemma le_total_order : Totally_ordered nat nat_po Integers.
+Proof.
+apply Totally_ordered_definition.
+simpl in |- *.
+intros H' x y H'0.
+specialize  2le_or_lt with (n := x) (m := y); intro H'2; elim H'2.
+intro H'1; left; auto with sets arith.
+intro H'1; right.
+cut (y <= x); auto with sets arith.
+Qed.
+Hint Resolve le_total_order.
+
+Lemma Finite_subset_has_lub :
+ forall X:Ensemble nat,
+   Finite nat X ->  exists m : nat, Upper_Bound nat nat_po X m.
+Proof.
+intros X H'; elim H'.
+exists 0.
+apply Upper_Bound_definition; auto with sets arith.
+intros y H'0; elim H'0; auto with sets arith.
+intros A H'0 H'1 x H'2; try assumption.
+elim H'1; intros x0 H'3; clear H'1.
+elim le_total_order.
+simpl in |- *.
+intro H'1; try assumption.
+lapply H'1; [ intro H'4; idtac | try assumption ]; auto with sets arith.
+generalize (H'4 x0 x).
+clear H'4.
+clear H'1.
+intro H'1; lapply H'1;
+ [ intro H'4; elim H'4;
+    [ intro H'5; try exact H'5; clear H'4 H'1 | intro H'5; clear H'4 H'1 ]
+ | clear H'1 ].
+exists x.
+apply Upper_Bound_definition; auto with sets arith; simpl in |- *.
+intros y H'1; elim H'1.
+generalize le_trans.
+intro H'4; red in H'4.
+intros x1 H'6; try assumption.
+apply H'4 with (y := x0); auto with sets arith.
+elim H'3; simpl in |- *; auto with sets arith.
+intros x1 H'4; elim H'4; auto with sets arith.
+exists x0.
+apply Upper_Bound_definition; auto with sets arith; simpl in |- *.
+intros y H'1; elim H'1.
+intros x1 H'4; try assumption.
+elim H'3; simpl in |- *; auto with sets arith.
+intros x1 H'4; elim H'4; auto with sets arith.
+red in |- *.
+intros x1 H'1; elim H'1; auto with sets arith.
+Qed.
+
+Lemma Integers_has_no_ub :
+ ~ (exists m : nat, Upper_Bound nat nat_po Integers m).
+Proof.
+red in |- *; intro H'; elim H'.
+intros x H'0.
+elim H'0; intros H'1 H'2.
+cut (In nat Integers (S x)).
+intro H'3.
+specialize  1H'2 with (y := S x); intro H'4; lapply H'4;
+ [ intro H'5; clear H'4 | try assumption; clear H'4 ].
+simpl in H'5.
+absurd (S x <= x); auto with arith.
+auto with sets arith.
+Qed.
+
+Lemma Integers_infinite : ~ Finite nat Integers.
+Proof.
+generalize Integers_has_no_ub.
+intro H'; red in |- *; intro H'0; try exact H'0.
+apply H'.
+apply Finite_subset_has_lub; auto with sets arith.
+Qed.
+
+End Integers_sect.
+
+
+
+
diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v
new file mode 100755
index 00000000..a308282b
--- /dev/null
+++ b/theories/Sets/Multiset.v
@@ -0,0 +1,191 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Multiset.v,v 1.9.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+(* G. Huet 1-9-95 *)
+
+Require Import Permut.
+
+Set Implicit Arguments.
+
+Section multiset_defs.
+
+Variable A : Set.
+Variable eqA : A -> A -> Prop.
+Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+
+Inductive multiset : Set :=
+    Bag : (A -> nat) -> multiset.
+
+Definition EmptyBag := Bag (fun a:A => 0).
+Definition SingletonBag (a:A) :=
+  Bag (fun a':A => match Aeq_dec a a' with
+                   | left _ => 1
+                   | right _ => 0
+                   end).
+
+Definition multiplicity (m:multiset) (a:A) : nat := let (f) := m in f a.
+
+(** multiset equality *)
+Definition meq (m1 m2:multiset) :=
+  forall a:A, multiplicity m1 a = multiplicity m2 a.
+
+Hint Unfold meq multiplicity.
+
+Lemma meq_refl : forall x:multiset, meq x x.
+Proof.
+destruct x; auto.
+Qed.
+Hint Resolve meq_refl.
+
+Lemma meq_trans : forall x y z:multiset, meq x y -> meq y z -> meq x z.
+Proof.
+unfold meq in |- *.
+destruct x; destruct y; destruct z.
+intros; rewrite H; auto.
+Qed.
+
+Lemma meq_sym : forall x y:multiset, meq x y -> meq y x.
+Proof.
+unfold meq in |- *.
+destruct x; destruct y; auto.
+Qed.
+Hint Immediate meq_sym.
+
+(** multiset union *)
+Definition munion (m1 m2:multiset) :=
+  Bag (fun a:A => multiplicity m1 a + multiplicity m2 a).
+
+Lemma munion_empty_left : forall x:multiset, meq x (munion EmptyBag x).
+Proof.
+unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
+Qed.
+Hint Resolve munion_empty_left.
+
+Lemma munion_empty_right : forall x:multiset, meq x (munion x EmptyBag).
+Proof.
+unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
+Qed.
+
+
+Require Import Plus. (* comm. and ass. of plus *)
+
+Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x).
+Proof.
+unfold meq in |- *; unfold multiplicity in |- *; unfold munion in |- *.
+destruct x; destruct y; auto with arith.
+Qed.
+Hint Resolve munion_comm.
+
+Lemma munion_ass :
+ forall x y z:multiset, meq (munion (munion x y) z) (munion x (munion y z)).
+Proof.
+unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
+destruct x; destruct y; destruct z; auto with arith.
+Qed.
+Hint Resolve munion_ass.
+
+Lemma meq_left :
+ forall x y z:multiset, meq x y -> meq (munion x z) (munion y z).
+Proof.
+unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
+destruct x; destruct y; destruct z.
+intros; elim H; auto with arith.
+Qed.
+Hint Resolve meq_left.
+
+Lemma meq_right :
+ forall x y z:multiset, meq x y -> meq (munion z x) (munion z y).
+Proof.
+unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
+destruct x; destruct y; destruct z.
+intros; elim H; auto.
+Qed.
+Hint Resolve meq_right.
+
+
+(** Here we should make multiset an abstract datatype, by hiding [Bag],
+    [munion], [multiplicity]; all further properties are proved abstractly *)
+
+Lemma munion_rotate :
+ forall x y z:multiset, meq (munion x (munion y z)) (munion z (munion x y)).
+Proof.
+intros; apply (op_rotate multiset munion meq); auto.
+exact meq_trans.
+Qed.
+
+Lemma meq_congr :
+ forall x y z t:multiset, meq x y -> meq z t -> meq (munion x z) (munion y t).
+Proof.
+intros; apply (cong_congr multiset munion meq); auto.
+exact meq_trans.
+Qed.
+
+Lemma munion_perm_left :
+ forall x y z:multiset, meq (munion x (munion y z)) (munion y (munion x z)).
+Proof.
+intros; apply (perm_left multiset munion meq); auto.
+exact meq_trans.
+Qed.
+
+Lemma multiset_twist1 :
+ forall x y z t:multiset,
+   meq (munion x (munion (munion y z) t)) (munion (munion y (munion x t)) z).
+Proof.
+intros; apply (twist multiset munion meq); auto.
+exact meq_trans.
+Qed.
+
+Lemma multiset_twist2 :
+ forall x y z t:multiset,
+   meq (munion x (munion (munion y z) t)) (munion (munion y (munion x z)) t).
+Proof.
+intros; apply meq_trans with (munion (munion x (munion y z)) t).
+apply meq_sym; apply munion_ass.
+apply meq_left; apply munion_perm_left.
+Qed.
+
+(** specific for treesort *)
+
+Lemma treesort_twist1 :
+ forall x y z t u:multiset,
+   meq u (munion y z) ->
+   meq (munion x (munion u t)) (munion (munion y (munion x t)) z).
+Proof.
+intros; apply meq_trans with (munion x (munion (munion y z) t)).
+apply meq_right; apply meq_left; trivial.
+apply multiset_twist1.
+Qed.
+
+Lemma treesort_twist2 :
+ forall x y z t u:multiset,
+   meq u (munion y z) ->
+   meq (munion x (munion u t)) (munion (munion y (munion x z)) t).
+Proof.
+intros; apply meq_trans with (munion x (munion (munion y z) t)).
+apply meq_right; apply meq_left; trivial.
+apply multiset_twist2.
+Qed.
+
+
+(*i theory of minter to do similarly 
+Require Min.
+(* multiset intersection *)
+Definition minter := [m1,m2:multiset]
+    (Bag [a:A](min (multiplicity m1 a)(multiplicity m2 a))).
+i*)
+
+End multiset_defs.
+
+Unset Implicit Arguments.
+
+Hint Unfold meq multiplicity: v62 datatypes.
+Hint Resolve munion_empty_right munion_comm munion_ass meq_left meq_right
+  munion_empty_left: v62 datatypes.
+Hint Immediate meq_sym: v62 datatypes.
\ No newline at end of file
diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v
new file mode 100755
index 00000000..b3e59886
--- /dev/null
+++ b/theories/Sets/Partial_Order.v
@@ -0,0 +1,100 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Partial_Order.v,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Ensembles.
+Require Export Relations_1.
+
+Section Partial_orders.
+Variable U : Type.
+
+Definition Carrier := Ensemble U.
+
+Definition Rel := Relation U.
+
+Record PO : Type := Definition_of_PO
+  {Carrier_of : Ensemble U;
+   Rel_of : Relation U;
+   PO_cond1 : Inhabited U Carrier_of;
+   PO_cond2 : Order U Rel_of}.
+Variable p : PO.
+
+Definition Strict_Rel_of : Rel := fun x y:U => Rel_of p x y /\ x <> y.
+
+Inductive covers (y x:U) : Prop :=
+    Definition_of_covers :
+      Strict_Rel_of x y ->
+      ~ (exists z : _, Strict_Rel_of x z /\ Strict_Rel_of z y) ->
+      covers y x.
+
+End Partial_orders.
+
+Hint Unfold Carrier_of Rel_of Strict_Rel_of: sets v62.
+Hint Resolve Definition_of_covers: sets v62.
+
+
+Section Partial_order_facts.
+Variable U : Type.
+Variable D : PO U.
+
+Lemma Strict_Rel_Transitive_with_Rel :
+ forall x y z:U,
+   Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z.
+unfold Strict_Rel_of at 1 in |- *.
+red in |- *.
+elim D; simpl in |- *.
+intros C R H' H'0; elim H'0.
+intros H'1 H'2 H'3 x y z H'4 H'5; split.
+apply H'2 with (y := y); tauto.
+red in |- *; intro H'6.
+elim H'4; intros H'7 H'8; apply H'8; clear H'4.
+apply H'3; auto.
+rewrite H'6; tauto.
+Qed.
+
+Lemma Strict_Rel_Transitive_with_Rel_left :
+ forall x y z:U,
+   Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z.
+unfold Strict_Rel_of at 1 in |- *.
+red in |- *.
+elim D; simpl in |- *.
+intros C R H' H'0; elim H'0.
+intros H'1 H'2 H'3 x y z H'4 H'5; split.
+apply H'2 with (y := y); tauto.
+red in |- *; intro H'6.
+elim H'5; intros H'7 H'8; apply H'8; clear H'5.
+apply H'3; auto.
+rewrite <- H'6; auto.
+Qed.
+
+Lemma Strict_Rel_Transitive : Transitive U (Strict_Rel_of U D).
+red in |- *.
+intros x y z H' H'0.
+apply Strict_Rel_Transitive_with_Rel with (y := y);
+ [ intuition | unfold Strict_Rel_of in H', H'0; intuition ].
+Qed.
+End Partial_order_facts.
\ No newline at end of file
diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v
new file mode 100755
index 00000000..af6151bf
--- /dev/null
+++ b/theories/Sets/Permut.v
@@ -0,0 +1,91 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Permut.v,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+(* G. Huet 1-9-95 *)
+
+(** We consider a Set [U], given with a commutative-associative operator [op],
+    and a congruence [cong]; we show permutation lemmas *)
+
+Section Axiomatisation.
+
+Variable U : Set.
+
+Variable op : U -> U -> U.
+
+Variable cong : U -> U -> Prop.
+
+Hypothesis op_comm : forall x y:U, cong (op x y) (op y x).
+Hypothesis op_ass : forall x y z:U, cong (op (op x y) z) (op x (op y z)).
+
+Hypothesis cong_left : forall x y z:U, cong x y -> cong (op x z) (op y z).
+Hypothesis cong_right : forall x y z:U, cong x y -> cong (op z x) (op z y).
+Hypothesis cong_trans : forall x y z:U, cong x y -> cong y z -> cong x z.
+Hypothesis cong_sym : forall x y:U, cong x y -> cong y x.
+
+(** Remark. we do not need: [Hypothesis cong_refl : (x:U)(cong x x)]. *)
+
+Lemma cong_congr :
+ forall x y z t:U, cong x y -> cong z t -> cong (op x z) (op y t).
+Proof.
+intros; apply cong_trans with (op y z).
+apply cong_left; trivial.
+apply cong_right; trivial.
+Qed.
+
+Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)).
+Proof.
+intros; apply cong_right; apply op_comm.
+Qed.
+
+Lemma comm_left : forall x y z:U, cong (op (op x y) z) (op (op y x) z).
+Proof.
+intros; apply cong_left; apply op_comm.
+Qed.
+
+Lemma perm_right : forall x y z:U, cong (op (op x y) z) (op (op x z) y).
+Proof.
+intros.
+apply cong_trans with (op x (op y z)).
+apply op_ass.
+apply cong_trans with (op x (op z y)). 
+apply cong_right; apply op_comm.
+apply cong_sym; apply op_ass.
+Qed.
+
+Lemma perm_left : forall x y z:U, cong (op x (op y z)) (op y (op x z)).
+Proof.
+intros.
+apply cong_trans with (op (op x y) z).
+apply cong_sym; apply op_ass.
+apply cong_trans with (op (op y x) z).
+apply cong_left; apply op_comm.
+apply op_ass.
+Qed.
+
+Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)).
+Proof.
+intros; apply cong_trans with (op (op x y) z).
+apply cong_sym; apply op_ass.
+apply op_comm.
+Qed.
+
+(* Needed for treesort ... *)
+Lemma twist :
+ forall x y z t:U, cong (op x (op (op y z) t)) (op (op y (op x t)) z).
+Proof.
+intros.
+apply cong_trans with (op x (op (op y t) z)).
+apply cong_right; apply perm_right.
+apply cong_trans with (op (op x (op y t)) z).
+apply cong_sym; apply op_ass.
+apply cong_left; apply perm_left.
+Qed.
+
+End Axiomatisation.
\ No newline at end of file
diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v
new file mode 100755
index 00000000..a7f5e9f4
--- /dev/null
+++ b/theories/Sets/Powerset.v
@@ -0,0 +1,190 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Powerset.v,v 1.5.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Ensembles.
+Require Export Relations_1.
+Require Export Relations_1_facts.
+Require Export Partial_Order.
+Require Export Cpo.
+
+Section The_power_set_partial_order.
+Variable U : Type.
+
+Inductive Power_set (A:Ensemble U) : Ensemble (Ensemble U) :=
+    Definition_of_Power_set :
+      forall X:Ensemble U, Included U X A -> In (Ensemble U) (Power_set A) X.
+Hint Resolve Definition_of_Power_set.
+
+Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X.
+intro X; red in |- *.
+intros x H'; elim H'.
+Qed.
+Hint Resolve Empty_set_minimal.
+
+Theorem Power_set_Inhabited :
+ forall X:Ensemble U, Inhabited (Ensemble U) (Power_set X).
+intro X.
+apply Inhabited_intro with (Empty_set U); auto with sets.
+Qed.
+Hint Resolve Power_set_Inhabited.
+
+Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U).
+auto 6 with sets.
+Qed.
+Hint Resolve Inclusion_is_an_order.
+
+Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U).
+elim Inclusion_is_an_order; auto with sets.
+Qed.
+Hint Resolve Inclusion_is_transitive.
+
+Definition Power_set_PO : Ensemble U -> PO (Ensemble U).
+intro A; try assumption.
+apply Definition_of_PO with (Power_set A) (Included U); auto with sets.
+Defined.
+Hint Unfold Power_set_PO.
+
+Theorem Strict_Rel_is_Strict_Included :
+ same_relation (Ensemble U) (Strict_Included U)
+   (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))).
+auto with sets.
+Qed.
+Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included.
+
+Lemma Strict_inclusion_is_transitive_with_inclusion :
+ forall x y z:Ensemble U,
+   Strict_Included U x y -> Included U y z -> Strict_Included U x z.
+intros x y z H' H'0; try assumption.
+elim Strict_Rel_is_Strict_Included.
+unfold contains in |- *.
+intros H'1 H'2; try assumption.
+apply H'1.
+apply Strict_Rel_Transitive_with_Rel with (y := y); auto with sets.
+Qed.
+
+Lemma Strict_inclusion_is_transitive_with_inclusion_left :
+ forall x y z:Ensemble U,
+   Included U x y -> Strict_Included U y z -> Strict_Included U x z.
+intros x y z H' H'0; try assumption.
+elim Strict_Rel_is_Strict_Included.
+unfold contains in |- *.
+intros H'1 H'2; try assumption.
+apply H'1.
+apply Strict_Rel_Transitive_with_Rel_left with (y := y); auto with sets.
+Qed.
+
+Lemma Strict_inclusion_is_transitive :
+ Transitive (Ensemble U) (Strict_Included U).
+apply cong_transitive_same_relation with
+ (R := Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U)));
+ auto with sets.
+Qed.
+
+Theorem Empty_set_is_Bottom :
+ forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U).
+intro A; apply Bottom_definition; simpl in |- *; auto with sets.
+Qed.
+Hint Resolve Empty_set_is_Bottom.
+
+Theorem Union_minimal :
+ forall a b X:Ensemble U,
+   Included U a X -> Included U b X -> Included U (Union U a b) X.
+intros a b X H' H'0; red in |- *.
+intros x H'1; elim H'1; auto with sets.
+Qed.
+Hint Resolve Union_minimal.
+
+Theorem Intersection_maximal :
+ forall a b X:Ensemble U,
+   Included U X a -> Included U X b -> Included U X (Intersection U a b).
+auto with sets.
+Qed.
+
+Theorem Union_increases_l : forall a b:Ensemble U, Included U a (Union U a b).
+auto with sets.
+Qed.
+
+Theorem Union_increases_r : forall a b:Ensemble U, Included U b (Union U a b).
+auto with sets.
+Qed.
+
+Theorem Intersection_decreases_l :
+ forall a b:Ensemble U, Included U (Intersection U a b) a.
+intros a b; red in |- *.
+intros x H'; elim H'; auto with sets.
+Qed.
+
+Theorem Intersection_decreases_r :
+ forall a b:Ensemble U, Included U (Intersection U a b) b.
+intros a b; red in |- *.
+intros x H'; elim H'; auto with sets.
+Qed.
+Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l
+  Intersection_decreases_r.
+
+Theorem Union_is_Lub :
+ forall A a b:Ensemble U,
+   Included U a A ->
+   Included U b A ->
+   Lub (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Union U a b).
+intros A a b H' H'0.
+apply Lub_definition; simpl in |- *.
+apply Upper_Bound_definition; simpl in |- *; auto with sets.
+intros y H'1; elim H'1; auto with sets.
+intros y H'1; elim H'1; simpl in |- *; auto with sets.
+Qed.
+
+Theorem Intersection_is_Glb :
+ forall A a b:Ensemble U,
+   Included U a A ->
+   Included U b A ->
+   Glb (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b)
+     (Intersection U a b).
+intros A a b H' H'0.
+apply Glb_definition; simpl in |- *.
+apply Lower_Bound_definition; simpl in |- *; auto with sets.
+apply Definition_of_Power_set.
+generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a;
+ auto with sets.
+intros y H'1; elim H'1; auto with sets.
+intros y H'1; elim H'1; simpl in |- *; auto with sets.
+Qed.
+
+End The_power_set_partial_order.
+
+Hint Resolve Empty_set_minimal: sets v62.
+Hint Resolve Power_set_Inhabited: sets v62.
+Hint Resolve Inclusion_is_an_order: sets v62.
+Hint Resolve Inclusion_is_transitive: sets v62.
+Hint Resolve Union_minimal: sets v62.
+Hint Resolve Union_increases_l: sets v62.
+Hint Resolve Union_increases_r: sets v62.
+Hint Resolve Intersection_decreases_l: sets v62.
+Hint Resolve Intersection_decreases_r: sets v62.
+Hint Resolve Empty_set_is_Bottom: sets v62.
+Hint Resolve Strict_inclusion_is_transitive: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v
new file mode 100755
index 00000000..05c60def
--- /dev/null
+++ b/theories/Sets/Powerset_Classical_facts.v
@@ -0,0 +1,342 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Powerset_Classical_facts.v,v 1.5.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Ensembles.
+Require Export Constructive_sets.
+Require Export Relations_1.
+Require Export Relations_1_facts.
+Require Export Partial_Order.
+Require Export Cpo.
+Require Export Powerset.
+Require Export Powerset_facts.
+Require Export Classical_Type.
+Require Export Classical_sets.
+
+Section Sets_as_an_algebra.
+
+Variable U : Type.
+
+Lemma sincl_add_x :
+ forall (A B:Ensemble U) (x:U),
+   ~ In U A x ->
+   Strict_Included U (Add U A x) (Add U B x) -> Strict_Included U A B.
+Proof.
+intros A B x H' H'0; red in |- *.
+lapply (Strict_Included_inv U (Add U A x) (Add U B x)); auto with sets.
+clear H'0; intro H'0; split.
+apply incl_add_x with (x := x); tauto.
+elim H'0; intros H'1 H'2; elim H'2; clear H'0 H'2.
+intros x0 H'0.
+red in |- *; intro H'2.
+elim H'0; clear H'0.
+rewrite <- H'2; auto with sets.
+Qed.
+
+Lemma incl_soustr_in :
+ forall (X:Ensemble U) (x:U), In U X x -> Included U (Subtract U X x) X.
+Proof.
+intros X x H'; red in |- *.
+intros x0 H'0; elim H'0; auto with sets.
+Qed.
+Hint Resolve incl_soustr_in: sets v62.
+
+Lemma incl_soustr :
+ forall (X Y:Ensemble U) (x:U),
+   Included U X Y -> Included U (Subtract U X x) (Subtract U Y x).
+Proof.
+intros X Y x H'; red in |- *.
+intros x0 H'0; elim H'0.
+intros H'1 H'2.
+apply Subtract_intro; auto with sets.
+Qed.
+Hint Resolve incl_soustr: sets v62.
+
+
+Lemma incl_soustr_add_l :
+ forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X.
+Proof.
+intros X x; red in |- *.
+intros x0 H'; elim H'; auto with sets.
+intro H'0; elim H'0; auto with sets.
+intros t H'1 H'2; elim H'2; auto with sets.
+Qed.
+Hint Resolve incl_soustr_add_l: sets v62.
+
+Lemma incl_soustr_add_r :
+ forall (X:Ensemble U) (x:U),
+   ~ In U X x -> Included U X (Subtract U (Add U X x) x).
+Proof.
+intros X x H'; red in |- *.
+intros x0 H'0; try assumption.
+apply Subtract_intro; auto with sets.
+red in |- *; intro H'1; apply H'; rewrite H'1; auto with sets.
+Qed.
+Hint Resolve incl_soustr_add_r: sets v62.
+
+Lemma add_soustr_2 :
+ forall (X:Ensemble U) (x:U),
+   In U X x -> Included U X (Add U (Subtract U X x) x).
+Proof.
+intros X x H'; red in |- *.
+intros x0 H'0; try assumption.
+elim (classic (x = x0)); intro K; auto with sets.
+elim K; auto with sets.
+Qed.
+
+Lemma add_soustr_1 :
+ forall (X:Ensemble U) (x:U),
+   In U X x -> Included U (Add U (Subtract U X x) x) X.
+Proof.
+intros X x H'; red in |- *.
+intros x0 H'0; elim H'0; auto with sets.
+intros y H'1; elim H'1; auto with sets.
+intros t H'1; try assumption.
+rewrite <- (Singleton_inv U x t); auto with sets.
+Qed.
+Hint Resolve add_soustr_1 add_soustr_2: sets v62.
+
+Lemma add_soustr_xy :
+ forall (X:Ensemble U) (x y:U),
+   x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x.
+Proof.
+intros X x y H'; apply Extensionality_Ensembles.
+split; red in |- *.
+intros x0 H'0; elim H'0; auto with sets.
+intro H'1; elim H'1.
+intros u H'2 H'3; try assumption.
+apply Add_intro1.
+apply Subtract_intro; auto with sets.
+intros t H'2 H'3; try assumption.
+elim (Singleton_inv U x t); auto with sets.
+intros u H'2; try assumption.
+elim (Add_inv U (Subtract U X y) x u); auto with sets.
+intro H'0; elim H'0; auto with sets.
+intro H'0; rewrite <- H'0; auto with sets.
+Qed.
+Hint Resolve add_soustr_xy: sets v62.
+
+Lemma incl_st_add_soustr :
+ forall (X Y:Ensemble U) (x:U),
+   ~ In U X x ->
+   Strict_Included U (Add U X x) Y -> Strict_Included U X (Subtract U Y x).
+Proof.
+intros X Y x H' H'0; apply sincl_add_x with (x := x); auto with sets.
+split.
+elim H'0.
+intros H'1 H'2.
+generalize (Inclusion_is_transitive U).
+intro H'4; red in H'4.
+apply H'4 with (y := Y); auto with sets.
+red in H'0.
+elim H'0; intros H'1 H'2; try exact H'1; clear H'0. (* PB *)
+red in |- *; intro H'0; apply H'2.
+rewrite H'0; auto 8 with sets.
+Qed.
+
+Lemma Sub_Add_new :
+ forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x.
+Proof.
+auto with sets.
+Qed.
+
+Lemma Simplify_add :
+ forall (X X0:Ensemble U) (x:U),
+   ~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0.
+Proof.
+intros X X0 x H' H'0 H'1; try assumption.
+rewrite (Sub_Add_new X x); auto with sets.
+rewrite (Sub_Add_new X0 x); auto with sets.
+rewrite H'1; auto with sets.
+Qed.
+
+Lemma Included_Add :
+ forall (X A:Ensemble U) (x:U),
+   Included U X (Add U A x) ->
+   Included U X A \/ (exists A' : _, X = Add U A' x /\ Included U A' A).
+Proof.
+intros X A x H'0; try assumption.
+elim (classic (In U X x)).
+intro H'1; right; try assumption.
+exists (Subtract U X x).
+split; auto with sets.
+red in H'0.
+red in |- *.
+intros x0 H'2; try assumption.
+lapply (Subtract_inv U X x x0); auto with sets.
+intro H'3; elim H'3; intros K K'; clear H'3.
+lapply (H'0 x0); auto with sets.
+intro H'3; try assumption.
+lapply (Add_inv U A x x0); auto with sets.
+intro H'4; elim H'4;
+ [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
+elim K'; auto with sets.
+intro H'1; left; try assumption.
+red in H'0.
+red in |- *.
+intros x0 H'2; try assumption.
+lapply (H'0 x0); auto with sets.
+intro H'3; try assumption.
+lapply (Add_inv U A x x0); auto with sets.
+intro H'4; elim H'4;
+ [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
+absurd (In U X x0); auto with sets.
+rewrite <- H'5; auto with sets.
+Qed.
+
+Lemma setcover_inv :
+ forall A x y:Ensemble U,
+   covers (Ensemble U) (Power_set_PO U A) y x ->
+   Strict_Included U x y /\
+   (forall z:Ensemble U, Included U x z -> Included U z y -> x = z \/ z = y).
+Proof.
+intros A x y H'; elim H'.
+unfold Strict_Rel_of in |- *; simpl in |- *.
+intros H'0 H'1; split; [ auto with sets | idtac ].
+intros z H'2 H'3; try assumption.
+elim (classic (x = z)); auto with sets.
+intro H'4; right; try assumption.
+elim (classic (z = y)); auto with sets.
+intro H'5; try assumption.
+elim H'1.
+exists z; auto with sets.
+Qed.
+
+Theorem Add_covers :
+ forall A a:Ensemble U,
+   Included U a A ->
+   forall x:U,
+     In U A x ->
+     ~ In U a x -> covers (Ensemble U) (Power_set_PO U A) (Add U a x) a.
+Proof.
+intros A a H' x H'0 H'1; try assumption.
+apply setcover_intro; auto with sets.
+red in |- *.
+split; [ idtac | red in |- *; intro H'2; try exact H'2 ]; auto with sets.
+apply H'1.
+rewrite H'2; auto with sets.
+red in |- *; intro H'2; elim H'2; clear H'2.
+intros z H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
+lapply (Strict_Included_inv U a z); auto with sets; clear H'3.
+intro H'2; elim H'2; intros H'3 H'5; elim H'5; clear H'2 H'5.
+intros x0 H'2; elim H'2.
+intros H'5 H'6; try assumption.
+generalize H'4; intro K.
+red in H'4.
+elim H'4; intros H'8 H'9; red in H'8; clear H'4.
+lapply (H'8 x0); auto with sets.
+intro H'7; try assumption.
+elim (Add_inv U a x x0); auto with sets.
+intro H'15.
+cut (Included U (Add U a x) z).
+intro H'10; try assumption.
+red in K.
+elim K; intros H'11 H'12; apply H'12; clear K; auto with sets.
+rewrite H'15.
+red in |- *.
+intros x1 H'10; elim H'10; auto with sets.
+intros x2 H'11; elim H'11; auto with sets.
+Qed.
+
+Theorem covers_Add :
+ forall A a a':Ensemble U,
+   Included U a A ->
+   Included U a' A ->
+   covers (Ensemble U) (Power_set_PO U A) a' a ->
+    exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x.
+Proof.
+intros A a a' H' H'0 H'1; try assumption.
+elim (setcover_inv A a a'); auto with sets.
+intros H'6 H'7.
+clear H'1.
+elim (Strict_Included_inv U a a'); auto with sets.
+intros H'5 H'8; elim H'8.
+intros x H'1; elim H'1.
+intros H'2 H'3; try assumption.
+exists x.
+split; [ try assumption | idtac ].
+clear H'8 H'1.
+elim (H'7 (Add U a x)); auto with sets.
+intro H'1.
+absurd (a = Add U a x); auto with sets.
+red in |- *; intro H'8; try exact H'8.
+apply H'3.
+rewrite H'8; auto with sets.
+auto with sets.
+red in |- *.
+intros x0 H'1; elim H'1; auto with sets.
+intros x1 H'8; elim H'8; auto with sets.
+split; [ idtac | try assumption ].
+red in H'0; auto with sets.
+Qed.
+
+Theorem covers_is_Add :
+ forall A a a':Ensemble U,
+   Included U a A ->
+   Included U a' A ->
+   (covers (Ensemble U) (Power_set_PO U A) a' a <->
+    (exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x)).
+Proof.
+intros A a a' H' H'0; split; intro K.
+apply covers_Add with (A := A); auto with sets.
+elim K.
+intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1.
+apply Add_covers; intuition.
+Qed.
+
+Theorem Singleton_atomic :
+ forall (x:U) (A:Ensemble U),
+   In U A x ->
+   covers (Ensemble U) (Power_set_PO U A) (Singleton U x) (Empty_set U).
+intros x A H'.
+rewrite <- (Empty_set_zero' U x).
+apply Add_covers; auto with sets.
+Qed.
+
+Lemma less_than_singleton :
+ forall (X:Ensemble U) (x:U),
+   Strict_Included U X (Singleton U x) -> X = Empty_set U.
+intros X x H'; try assumption.
+red in H'.
+lapply (Singleton_atomic x (Full_set U));
+ [ intro H'2; try exact H'2 | apply Full_intro ].
+elim H'; intros H'0 H'1; try exact H'1; clear H'.
+elim (setcover_inv (Full_set U) (Empty_set U) (Singleton U x));
+ [ intros H'6 H'7; try exact H'7 | idtac ]; auto with sets.
+elim (H'7 X); [ intro H'5; try exact H'5 | intro H'5 | idtac | idtac ];
+ auto with sets.
+elim H'1; auto with sets.
+Qed.
+
+End Sets_as_an_algebra.
+
+Hint Resolve incl_soustr_in: sets v62.
+Hint Resolve incl_soustr: sets v62.
+Hint Resolve incl_soustr_add_l: sets v62.
+Hint Resolve incl_soustr_add_r: sets v62.
+Hint Resolve add_soustr_1 add_soustr_2: sets v62.
+Hint Resolve add_soustr_xy: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v
new file mode 100755
index 00000000..2c71f529
--- /dev/null
+++ b/theories/Sets/Powerset_facts.v
@@ -0,0 +1,268 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Powerset_facts.v,v 1.8.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Ensembles.
+Require Export Constructive_sets.
+Require Export Relations_1.
+Require Export Relations_1_facts.
+Require Export Partial_Order.
+Require Export Cpo.
+Require Export Powerset.
+
+Section Sets_as_an_algebra.
+Variable U : Type.
+Hint Unfold not.
+
+Theorem Empty_set_zero : forall X:Ensemble U, Union U (Empty_set U) X = X.
+Proof.
+auto 6 with sets.
+Qed.
+Hint Resolve Empty_set_zero.
+
+Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x.
+Proof.
+unfold Add at 1 in |- *; auto with sets.
+Qed.
+Hint Resolve Empty_set_zero'.
+
+Lemma less_than_empty :
+ forall X:Ensemble U, Included U X (Empty_set U) -> X = Empty_set U.
+Proof.
+auto with sets.
+Qed.
+Hint Resolve less_than_empty.
+
+Theorem Union_commutative : forall A B:Ensemble U, Union U A B = Union U B A.
+Proof.
+auto with sets.
+Qed.
+
+Theorem Union_associative :
+ forall A B C:Ensemble U, Union U (Union U A B) C = Union U A (Union U B C).
+Proof.
+auto 9 with sets.
+Qed.
+Hint Resolve Union_associative.
+
+Theorem Union_idempotent : forall A:Ensemble U, Union U A A = A.
+Proof.
+auto 7 with sets.
+Qed.
+
+Lemma Union_absorbs :
+ forall A B:Ensemble U, Included U B A -> Union U A B = A.
+Proof.
+auto 7 with sets.
+Qed.
+
+Theorem Couple_as_union :
+ forall x y:U, Union U (Singleton U x) (Singleton U y) = Couple U x y.
+Proof.
+intros x y; apply Extensionality_Ensembles; split; red in |- *.
+intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets).
+intros x0 H'; elim H'; auto with sets.
+Qed.
+
+Theorem Triple_as_union :
+ forall x y z:U,
+   Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) =
+   Triple U x y z.
+Proof.
+intros x y z; apply Extensionality_Ensembles; split; red in |- *.
+intros x0 H'; elim H'.
+intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets).
+intros x1 H'0; elim H'0; auto with sets.
+intros x0 H'; elim H'; auto with sets.
+Qed.
+
+Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y.
+Proof.
+intros x y.
+rewrite <- (Couple_as_union x y).
+rewrite <- (Union_idempotent (Singleton U x)).
+apply Triple_as_union.
+Qed.
+
+Theorem Triple_as_Couple_Singleton :
+ forall x y z:U, Triple U x y z = Union U (Couple U x y) (Singleton U z).
+Proof.
+intros x y z.
+rewrite <- (Triple_as_union x y z).
+rewrite <- (Couple_as_union x y); auto with sets.
+Qed.
+
+Theorem Intersection_commutative :
+ forall A B:Ensemble U, Intersection U A B = Intersection U B A.
+Proof.
+intros A B.
+apply Extensionality_Ensembles.
+split; red in |- *; intros x H'; elim H'; auto with sets.
+Qed.
+
+Theorem Distributivity :
+ forall A B C:Ensemble U,
+   Intersection U A (Union U B C) =
+   Union U (Intersection U A B) (Intersection U A C).
+Proof.
+intros A B C.
+apply Extensionality_Ensembles.
+split; red in |- *; intros x H'.
+elim H'.
+intros x0 H'0 H'1; generalize H'0.
+elim H'1; auto with sets.
+elim H'; intros x0 H'0; elim H'0; auto with sets.
+Qed.
+
+Theorem Distributivity' :
+ forall A B C:Ensemble U,
+   Union U A (Intersection U B C) =
+   Intersection U (Union U A B) (Union U A C).
+Proof.
+intros A B C.
+apply Extensionality_Ensembles.
+split; red in |- *; intros x H'.
+elim H'; auto with sets.
+intros x0 H'0; elim H'0; auto with sets.
+elim H'.
+intros x0 H'0; elim H'0; auto with sets.
+intros x1 H'1 H'2; try exact H'2.
+generalize H'1.
+elim H'2; auto with sets.
+Qed.
+
+Theorem Union_add :
+ forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x).
+Proof.
+unfold Add in |- *; auto with sets.
+Qed.
+Hint Resolve Union_add.
+
+Theorem Non_disjoint_union :
+ forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X.
+intros X x H'; unfold Add in |- *.
+apply Extensionality_Ensembles; red in |- *.
+split; red in |- *; auto with sets.
+intros x0 H'0; elim H'0; auto with sets.
+intros t H'1; elim H'1; auto with sets.
+Qed.
+
+Theorem Non_disjoint_union' :
+ forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X.
+Proof.
+intros X x H'; unfold Subtract in |- *.
+apply Extensionality_Ensembles.
+split; red in |- *; auto with sets.
+intros x0 H'0; elim H'0; auto with sets.
+intros x0 H'0; apply Setminus_intro; auto with sets.
+red in |- *; intro H'1; elim H'1.
+lapply (Singleton_inv U x x0); auto with sets.
+intro H'4; apply H'; rewrite H'4; auto with sets.
+Qed.
+
+Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y.
+Proof.
+intro x; rewrite (Empty_set_zero' x); auto with sets.
+Qed.
+Hint Resolve singlx.
+
+Lemma incl_add :
+ forall (A B:Ensemble U) (x:U),
+   Included U A B -> Included U (Add U A x) (Add U B x).
+Proof.
+intros A B x H'; red in |- *; auto with sets.
+intros x0 H'0.
+lapply (Add_inv U A x x0); auto with sets.
+intro H'1; elim H'1;
+ [ intro H'2; clear H'1 | intro H'2; rewrite <- H'2; clear H'1 ];
+ auto with sets.
+Qed.
+Hint Resolve incl_add.
+
+Lemma incl_add_x :
+ forall (A B:Ensemble U) (x:U),
+   ~ In U A x -> Included U (Add U A x) (Add U B x) -> Included U A B.
+Proof.
+unfold Included in |- *.
+intros A B x H' H'0 x0 H'1.
+lapply (H'0 x0); auto with sets.
+intro H'2; lapply (Add_inv U B x x0); auto with sets.
+intro H'3; elim H'3;
+ [ intro H'4; try exact H'4; clear H'3 | intro H'4; clear H'3 ].
+absurd (In U A x0); auto with sets.
+rewrite <- H'4; auto with sets.
+Qed.
+
+Lemma Add_commutative :
+ forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x.
+Proof.
+intros A x y.
+unfold Add in |- *.
+rewrite (Union_associative A (Singleton U x) (Singleton U y)).
+rewrite (Union_commutative (Singleton U x) (Singleton U y)).
+rewrite <- (Union_associative A (Singleton U y) (Singleton U x));
+ auto with sets.
+Qed.
+
+Lemma Add_commutative' :
+ forall (A:Ensemble U) (x y z:U),
+   Add U (Add U (Add U A x) y) z = Add U (Add U (Add U A z) x) y.
+Proof.
+intros A x y z.
+rewrite (Add_commutative (Add U A x) y z).
+rewrite (Add_commutative A x z); auto with sets.
+Qed.
+
+Lemma Add_distributes :
+ forall (A B:Ensemble U) (x y:U),
+   Included U B A -> Add U (Add U A x) y = Union U (Add U A x) (Add U B y).
+Proof.
+intros A B x y H'; try assumption.
+rewrite <- (Union_add (Add U A x) B y).
+unfold Add at 4 in |- *.
+rewrite (Union_commutative A (Singleton U x)).
+rewrite Union_associative.
+rewrite (Union_absorbs A B H').
+rewrite (Union_commutative (Singleton U x) A).
+auto with sets.
+Qed.
+
+Lemma setcover_intro :
+ forall (U:Type) (A x y:Ensemble U),
+   Strict_Included U x y ->
+   ~ (exists z : _, Strict_Included U x z /\ Strict_Included U z y) ->
+   covers (Ensemble U) (Power_set_PO U A) y x.
+Proof.
+intros; apply Definition_of_covers; auto with sets.
+Qed.
+Hint Resolve setcover_intro.
+
+End Sets_as_an_algebra.
+
+Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add
+  singlx incl_add: sets v62.
+
diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v
new file mode 100755
index 00000000..e33746a9
--- /dev/null
+++ b/theories/Sets/Relations_1.v
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Relations_1.v,v 1.4.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Section Relations_1.
+   Variable U : Type.
+   
+   Definition Relation := U -> U -> Prop.
+   Variable R : Relation.
+   
+   Definition Reflexive : Prop := forall x:U, R x x.
+   
+   Definition Transitive : Prop := forall x y z:U, R x y -> R y z -> R x z.
+   
+   Definition Symmetric : Prop := forall x y:U, R x y -> R y x.
+   
+   Definition Antisymmetric : Prop := forall x y:U, R x y -> R y x -> x = y.
+   
+   Definition contains (R R':Relation) : Prop :=
+     forall x y:U, R' x y -> R x y.
+   
+   Definition same_relation (R R':Relation) : Prop :=
+     contains R R' /\ contains R' R.
+   
+   Inductive Preorder : Prop :=
+       Definition_of_preorder : Reflexive -> Transitive -> Preorder.
+   
+   Inductive Order : Prop :=
+       Definition_of_order :
+         Reflexive -> Transitive -> Antisymmetric -> Order.
+   
+   Inductive Equivalence : Prop :=
+       Definition_of_equivalence :
+         Reflexive -> Transitive -> Symmetric -> Equivalence.
+   
+   Inductive PER : Prop :=
+       Definition_of_PER : Symmetric -> Transitive -> PER.
+   
+End Relations_1.
+Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains
+  same_relation: sets v62.
+Hint Resolve Definition_of_preorder Definition_of_order
+  Definition_of_equivalence Definition_of_PER: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v
new file mode 100755
index 00000000..62688895
--- /dev/null
+++ b/theories/Sets/Relations_1_facts.v
@@ -0,0 +1,112 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Relations_1_facts.v,v 1.7.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Relations_1.
+
+Definition Complement (U:Type) (R:Relation U) : Relation U :=
+  fun x y:U => ~ R x y.
+
+Theorem Rsym_imp_notRsym :
+ forall (U:Type) (R:Relation U),
+   Symmetric U R -> Symmetric U (Complement U R).
+Proof.
+unfold Symmetric, Complement in |- *.
+intros U R H' x y H'0; red in |- *; intro H'1; apply H'0; auto with sets.
+Qed.
+
+Theorem Equiv_from_preorder :
+ forall (U:Type) (R:Relation U),
+   Preorder U R -> Equivalence U (fun x y:U => R x y /\ R y x).
+Proof.
+intros U R H'; elim H'; intros H'0 H'1.
+apply Definition_of_equivalence.
+red in H'0; auto 10 with sets.
+2: red in |- *; intros x y h; elim h; intros H'3 H'4; auto 10 with sets.
+red in H'1; red in |- *; auto 10 with sets.
+intros x y z h; elim h; intros H'3 H'4; clear h.
+intro h; elim h; intros H'5 H'6; clear h.
+split; apply H'1 with y; auto 10 with sets.
+Qed.
+Hint Resolve Equiv_from_preorder.
+
+Theorem Equiv_from_order :
+ forall (U:Type) (R:Relation U),
+   Order U R -> Equivalence U (fun x y:U => R x y /\ R y x).
+Proof.
+intros U R H'; elim H'; auto 10 with sets.
+Qed.
+Hint Resolve Equiv_from_order.
+
+Theorem contains_is_preorder :
+ forall U:Type, Preorder (Relation U) (contains U).
+Proof.
+auto 10 with sets.
+Qed.
+Hint Resolve contains_is_preorder.
+
+Theorem same_relation_is_equivalence :
+ forall U:Type, Equivalence (Relation U) (same_relation U).
+Proof.
+unfold same_relation at 1 in |- *; auto 10 with sets.
+Qed.
+Hint Resolve same_relation_is_equivalence.
+
+Theorem cong_reflexive_same_relation :
+ forall (U:Type) (R R':Relation U),
+   same_relation U R R' -> Reflexive U R -> Reflexive U R'.
+Proof.
+unfold same_relation in |- *; intuition.
+Qed.
+
+Theorem cong_symmetric_same_relation :
+ forall (U:Type) (R R':Relation U),
+   same_relation U R R' -> Symmetric U R -> Symmetric U R'.
+Proof.
+  compute in |- *; intros; elim H; intros; clear H;
+   apply (H3 y x (H0 x y (H2 x y H1))).
+(*Intuition.*)
+Qed.
+
+Theorem cong_antisymmetric_same_relation :
+ forall (U:Type) (R R':Relation U),
+   same_relation U R R' -> Antisymmetric U R -> Antisymmetric U R'.
+Proof.
+  compute in |- *; intros; elim H; intros; clear H;
+   apply (H0 x y (H3 x y H1) (H3 y x H2)).
+(*Intuition.*)
+Qed.
+
+Theorem cong_transitive_same_relation :
+ forall (U:Type) (R R':Relation U),
+   same_relation U R R' -> Transitive U R -> Transitive U R'.
+Proof.
+intros U R R' H' H'0; red in |- *.
+elim H'.
+intros H'1 H'2 x y z H'3 H'4; apply H'2.
+apply H'0 with y; auto with sets.
+Qed.
\ No newline at end of file
diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v
new file mode 100755
index 00000000..15d3ee2d
--- /dev/null
+++ b/theories/Sets/Relations_2.v
@@ -0,0 +1,56 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Relations_2.v,v 1.4.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Relations_1.
+
+Section Relations_2.
+Variable U : Type.
+Variable R : Relation U.
+
+Inductive Rstar : Relation U :=
+  | Rstar_0 : forall x:U, Rstar x x
+  | Rstar_n : forall x y z:U, R x y -> Rstar y z -> Rstar x z.
+
+Inductive Rstar1 : Relation U :=
+  | Rstar1_0 : forall x:U, Rstar1 x x
+  | Rstar1_1 : forall x y:U, R x y -> Rstar1 x y
+  | Rstar1_n : forall x y z:U, Rstar1 x y -> Rstar1 y z -> Rstar1 x z.
+
+Inductive Rplus : Relation U :=
+  | Rplus_0 : forall x y:U, R x y -> Rplus x y
+  | Rplus_n : forall x y z:U, R x y -> Rplus y z -> Rplus x z.
+
+Definition Strongly_confluent : Prop :=
+  forall x a b:U, R x a -> R x b -> ex (fun z:U => R a z /\ R b z).
+
+End Relations_2.
+
+Hint Resolve Rstar_0: sets v62.
+Hint Resolve Rstar1_0: sets v62.
+Hint Resolve Rstar1_1: sets v62.
+Hint Resolve Rplus_0: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v
new file mode 100755
index 00000000..4c729fe7
--- /dev/null
+++ b/theories/Sets/Relations_2_facts.v
@@ -0,0 +1,153 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Relations_2_facts.v,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Relations_1.
+Require Export Relations_1_facts.
+Require Export Relations_2.
+
+Theorem Rstar_reflexive :
+ forall (U:Type) (R:Relation U), Reflexive U (Rstar U R).
+Proof.
+auto with sets.
+Qed.
+
+Theorem Rplus_contains_R :
+ forall (U:Type) (R:Relation U), contains U (Rplus U R) R.
+Proof.
+auto with sets.
+Qed.
+
+Theorem Rstar_contains_R :
+ forall (U:Type) (R:Relation U), contains U (Rstar U R) R.
+Proof.
+intros U R; red in |- *; intros x y H'; apply Rstar_n with y; auto with sets.
+Qed.
+
+Theorem Rstar_contains_Rplus :
+ forall (U:Type) (R:Relation U), contains U (Rstar U R) (Rplus U R).
+Proof.
+intros U R; red in |- *.
+intros x y H'; elim H'.
+generalize Rstar_contains_R; intro T; red in T; auto with sets.
+intros x0 y0 z H'0 H'1 H'2; apply Rstar_n with y0; auto with sets.
+Qed.
+
+Theorem Rstar_transitive :
+ forall (U:Type) (R:Relation U), Transitive U (Rstar U R).
+Proof.
+intros U R; red in |- *.
+intros x y z H'; elim H'; auto with sets.
+intros x0 y0 z0 H'0 H'1 H'2 H'3; apply Rstar_n with y0; auto with sets.
+Qed.
+
+Theorem Rstar_cases :
+ forall (U:Type) (R:Relation U) (x y:U),
+   Rstar U R x y -> x = y \/ (exists u : _, R x u /\ Rstar U R u y).
+Proof.
+intros U R x y H'; elim H'; auto with sets.
+intros x0 y0 z H'0 H'1 H'2; right; exists y0; auto with sets.
+Qed.
+
+Theorem Rstar_equiv_Rstar1 :
+ forall (U:Type) (R:Relation U), same_relation U (Rstar U R) (Rstar1 U R).
+Proof.
+generalize Rstar_contains_R; intro T; red in T.
+intros U R; unfold same_relation, contains in |- *.
+split; intros x y H'; elim H'; auto with sets.
+generalize Rstar_transitive; intro T1; red in T1.
+intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets.
+intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets.
+Qed.
+
+Theorem Rsym_imp_Rstarsym :
+ forall (U:Type) (R:Relation U), Symmetric U R -> Symmetric U (Rstar U R).
+Proof.
+intros U R H'; red in |- *.
+intros x y H'0; elim H'0; auto with sets.
+intros x0 y0 z H'1 H'2 H'3.
+generalize Rstar_transitive; intro T1; red in T1.
+apply T1 with y0; auto with sets.
+apply Rstar_n with x0; auto with sets.
+Qed.
+
+Theorem Sstar_contains_Rstar :
+ forall (U:Type) (R S:Relation U),
+   contains U (Rstar U S) R -> contains U (Rstar U S) (Rstar U R).
+Proof.
+unfold contains in |- *.
+intros U R S H' x y H'0; elim H'0; auto with sets.
+generalize Rstar_transitive; intro T1; red in T1.
+intros x0 y0 z H'1 H'2 H'3; apply T1 with y0; auto with sets.
+Qed.
+
+Theorem star_monotone :
+ forall (U:Type) (R S:Relation U),
+   contains U S R -> contains U (Rstar U S) (Rstar U R).
+Proof.
+intros U R S H'.
+apply Sstar_contains_Rstar; auto with sets.
+generalize (Rstar_contains_R U S); auto with sets.
+Qed.
+
+Theorem RstarRplus_RRstar :
+ forall (U:Type) (R:Relation U) (x y z:U),
+   Rstar U R x y -> Rplus U R y z ->  exists u : _, R x u /\ Rstar U R u z.
+Proof.
+generalize Rstar_contains_Rplus; intro T; red in T.
+generalize Rstar_transitive; intro T1; red in T1.
+intros U R x y z H'; elim H'.
+intros x0 H'0; elim H'0.
+intros x1 y0 H'1; exists y0; auto with sets.
+intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets.
+intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0.
+split; [ try assumption | idtac ].
+apply T1 with z0; auto with sets.
+Qed.
+
+Theorem Lemma1 :
+ forall (U:Type) (R:Relation U),
+   Strongly_confluent U R ->
+   forall x b:U,
+     Rstar U R x b ->
+     forall a:U, R x a ->  exists z : _, Rstar U R a z /\ R b z.
+Proof.
+intros U R H' x b H'0; elim H'0.
+intros x0 a H'1; exists a; auto with sets.
+intros x0 y z H'1 H'2 H'3 a H'4.
+red in H'.
+specialize  3H' with (x := x0) (a := a) (b := y); intro H'7; lapply H'7;
+ [ intro H'8; lapply H'8;
+    [ intro H'9; try exact H'9; clear H'8 H'7 | clear H'8 H'7 ]
+ | clear H'7 ]; auto with sets.
+elim H'9.
+intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5.
+elim (H'3 t); auto with sets.
+intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5.
+exists z1; split; [ idtac | assumption ].
+apply Rstar_n with t; auto with sets.
+Qed.
\ No newline at end of file
diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v
new file mode 100755
index 00000000..6a254819
--- /dev/null
+++ b/theories/Sets/Relations_3.v
@@ -0,0 +1,62 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Relations_3.v,v 1.7.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Relations_1.
+Require Export Relations_2.
+
+Section Relations_3.
+   Variable U : Type.
+   Variable R : Relation U.
+   
+   Definition coherent (x y:U) : Prop :=
+      exists z : _, Rstar U R x z /\ Rstar U R y z.
+   
+   Definition locally_confluent (x:U) : Prop :=
+     forall y z:U, R x y -> R x z -> coherent y z.
+   
+   Definition Locally_confluent : Prop := forall x:U, locally_confluent x.
+   
+   Definition confluent (x:U) : Prop :=
+     forall y z:U, Rstar U R x y -> Rstar U R x z -> coherent y z.
+   
+   Definition Confluent : Prop := forall x:U, confluent x.
+   
+   Inductive noetherian : U -> Prop :=
+       definition_of_noetherian :
+         forall x:U, (forall y:U, R x y -> noetherian y) -> noetherian x.
+   
+   Definition Noetherian : Prop := forall x:U, noetherian x.
+   
+End Relations_3.
+Hint Unfold coherent: sets v62.
+Hint Unfold locally_confluent: sets v62.
+Hint Unfold confluent: sets v62.
+Hint Unfold Confluent: sets v62.
+Hint Resolve definition_of_noetherian: sets v62.
+Hint Unfold Noetherian: sets v62.
+
diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v
new file mode 100755
index 00000000..34322dc7
--- /dev/null
+++ b/theories/Sets/Relations_3_facts.v
@@ -0,0 +1,171 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         Naive Set Theory in Coq                          *)
+(*                                                                          *)
+(*                     INRIA                        INRIA                   *)
+(*              Rocquencourt                        Sophia-Antipolis        *)
+(*                                                                          *)
+(*                                 Coq V6.1                                 *)
+(*									    *)
+(*			         Gilles Kahn 				    *)
+(*				 Gerard Huet				    *)
+(*									    *)
+(*									    *)
+(*                                                                          *)
+(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
+(* to the Newton Institute for providing an exceptional work environment    *)
+(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
+(****************************************************************************)
+
+(*i $Id: Relations_3_facts.v,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Relations_1.
+Require Export Relations_1_facts.
+Require Export Relations_2.
+Require Export Relations_2_facts.
+Require Export Relations_3.
+
+Theorem Rstar_imp_coherent :
+ forall (U:Type) (R:Relation U) (x y:U), Rstar U R x y -> coherent U R x y.
+Proof.
+intros U R x y H'; red in |- *.
+exists y; auto with sets.
+Qed.
+Hint Resolve Rstar_imp_coherent.
+
+Theorem coherent_symmetric :
+ forall (U:Type) (R:Relation U), Symmetric U (coherent U R).
+Proof.
+unfold coherent at 1 in |- *.
+intros U R; red in |- *.
+intros x y H'; elim H'.
+intros z H'0; exists z; tauto.
+Qed.
+
+Theorem Strong_confluence :
+ forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R.
+Proof.
+intros U R H'; red in |- *.
+intro x; red in |- *; intros a b H'0.
+unfold coherent at 1 in |- *.
+generalize b; clear b.
+elim H'0; clear H'0.
+intros x0 b H'1; exists b; auto with sets.
+intros x0 y z H'1 H'2 H'3 b H'4.
+generalize (Lemma1 U R); intro h; lapply h;
+ [ intro H'0; generalize (H'0 x0 b); intro h0; lapply h0;
+    [ intro H'5; generalize (H'5 y); intro h1; lapply h1;
+       [ intro h2; elim h2; intros z0 h3; elim h3; intros H'6 H'7;
+          clear h h0 h1 h2 h3
+       | clear h h0 h1 ]
+    | clear h h0 ]
+ | clear h ]; auto with sets.
+generalize (H'3 z0); intro h; lapply h;
+ [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h h0 h1
+ | clear h ]; auto with sets.
+exists z1; split; auto with sets.
+apply Rstar_n with z0; auto with sets.
+Qed.
+
+Theorem Strong_confluence_direct :
+ forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R.
+Proof.
+intros U R H'; red in |- *.
+intro x; red in |- *; intros a b H'0.
+unfold coherent at 1 in |- *.
+generalize b; clear b.
+elim H'0; clear H'0.
+intros x0 b H'1; exists b; auto with sets.
+intros x0 y z H'1 H'2 H'3 b H'4.
+cut (ex (fun t:U => Rstar U R y t /\ R b t)).
+intro h; elim h; intros t h0; elim h0; intros H'0 H'5; clear h h0.
+generalize (H'3 t); intro h; lapply h;
+ [ intro h0; elim h0; intros z0 h1; elim h1; intros H'6 H'7; clear h h0 h1
+ | clear h ]; auto with sets.
+exists z0; split; [ assumption | idtac ].
+apply Rstar_n with t; auto with sets.
+generalize H'1; generalize y; clear H'1.
+elim H'4.
+intros x1 y0 H'0; exists y0; auto with sets.
+intros x1 y0 z0 H'0 H'1 H'5 y1 H'6.
+red in H'.
+generalize (H' x1 y0 y1); intro h; lapply h;
+ [ intro H'7; lapply H'7;
+    [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9;
+       clear h H'7 h0 h1
+    | clear h ]
+ | clear h ]; auto with sets.
+generalize (H'5 z1); intro h; lapply h;
+ [ intro h0; elim h0; intros t h1; elim h1; intros H'7 H'10; clear h h0 h1
+ | clear h ]; auto with sets.
+exists t; split; auto with sets.
+apply Rstar_n with z1; auto with sets.
+Qed.
+
+Theorem Noetherian_contains_Noetherian :
+ forall (U:Type) (R R':Relation U),
+   Noetherian U R -> contains U R R' -> Noetherian U R'.
+Proof.
+unfold Noetherian at 2 in |- *.
+intros U R R' H' H'0 x.
+elim (H' x); auto with sets.
+Qed.
+
+Theorem Newman :
+ forall (U:Type) (R:Relation U),
+   Noetherian U R -> Locally_confluent U R -> Confluent U R.
+Proof.
+intros U R H' H'0; red in |- *; intro x.
+elim (H' x); unfold confluent in |- *.
+intros x0 H'1 H'2 y z H'3 H'4.
+generalize (Rstar_cases U R x0 y); intro h; lapply h;
+ [ intro h0; elim h0;
+    [ clear h h0; intro h1
+    | intro h1; elim h1; intros u h2; elim h2; intros H'5 H'6;
+       clear h h0 h1 h2 ]
+ | clear h ]; auto with sets.
+elim h1; auto with sets.
+generalize (Rstar_cases U R x0 z); intro h; lapply h;
+ [ intro h0; elim h0;
+    [ clear h h0; intro h1
+    | intro h1; elim h1; intros v h2; elim h2; intros H'7 H'8;
+       clear h h0 h1 h2 ]
+ | clear h ]; auto with sets.
+elim h1; generalize coherent_symmetric; intro t; red in t; auto with sets.
+unfold Locally_confluent, locally_confluent, coherent in H'0.
+generalize (H'0 x0 u v); intro h; lapply h;
+ [ intro H'9; lapply H'9;
+    [ intro h0; elim h0; intros t h1; elim h1; intros H'10 H'11;
+       clear h H'9 h0 h1
+    | clear h ]
+ | clear h ]; auto with sets.
+clear H'0.
+unfold coherent at 1 in H'2.
+generalize (H'2 u); intro h; lapply h;
+ [ intro H'0; generalize (H'0 y t); intro h0; lapply h0;
+    [ intro H'9; lapply H'9;
+       [ intro h1; elim h1; intros y1 h2; elim h2; intros H'12 H'13;
+          clear h h0 H'9 h1 h2
+       | clear h h0 ]
+    | clear h h0 ]
+ | clear h ]; auto with sets.
+generalize Rstar_transitive; intro T; red in T.
+generalize (H'2 v); intro h; lapply h;
+ [ intro H'9; generalize (H'9 y1 z); intro h0; lapply h0;
+    [ intro H'14; lapply H'14;
+       [ intro h1; elim h1; intros z1 h2; elim h2; intros H'15 H'16;
+          clear h h0 H'14 h1 h2
+       | clear h h0 ]
+    | clear h h0 ]
+ | clear h ]; auto with sets.
+red in |- *; (exists z1; split); auto with sets.
+apply T with y1; auto with sets.
+apply T with t; auto with sets.
+Qed.
\ No newline at end of file
diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v
new file mode 100644
index 00000000..10d26f22
--- /dev/null
+++ b/theories/Sets/Uniset.v
@@ -0,0 +1,215 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Uniset.v,v 1.9.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+(** Sets as characteristic functions *)
+
+(* G. Huet 1-9-95 *)
+(* Updated Papageno 12/98 *)
+
+Require Import Bool.
+
+Set Implicit Arguments.
+
+Section defs.
+
+Variable A : Set.
+Variable eqA : A -> A -> Prop.
+Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+
+Inductive uniset : Set :=
+    Charac : (A -> bool) -> uniset.
+
+Definition charac (s:uniset) (a:A) : bool := let (f) := s in f a.
+
+Definition Emptyset := Charac (fun a:A => false).
+
+Definition Fullset := Charac (fun a:A => true).
+
+Definition Singleton (a:A) :=
+  Charac
+    (fun a':A =>
+       match eqA_dec a a' with
+       | left h => true
+       | right h => false
+       end).
+
+Definition In (s:uniset) (a:A) : Prop := charac s a = true.
+Hint Unfold In.
+
+(** uniset inclusion *)
+Definition incl (s1 s2:uniset) := forall a:A, leb (charac s1 a) (charac s2 a).
+Hint Unfold incl.
+
+(** uniset equality *)
+Definition seq (s1 s2:uniset) := forall a:A, charac s1 a = charac s2 a.
+Hint Unfold seq.
+
+Lemma leb_refl : forall b:bool, leb b b.
+Proof.
+destruct b; simpl in |- *; auto.
+Qed.
+Hint Resolve leb_refl.
+
+Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2.
+Proof.
+unfold incl in |- *; intros s1 s2 E a; elim (E a); auto.
+Qed.
+
+Lemma incl_right : forall s1 s2:uniset, seq s1 s2 -> incl s2 s1.
+Proof.
+unfold incl in |- *; intros s1 s2 E a; elim (E a); auto.
+Qed.
+
+Lemma seq_refl : forall x:uniset, seq x x.
+Proof.
+destruct x; unfold seq in |- *; auto.
+Qed.
+Hint Resolve seq_refl.
+
+Lemma seq_trans : forall x y z:uniset, seq x y -> seq y z -> seq x z.
+Proof.
+unfold seq in |- *.
+destruct x; destruct y; destruct z; simpl in |- *; intros.
+rewrite H; auto.
+Qed.
+
+Lemma seq_sym : forall x y:uniset, seq x y -> seq y x.
+Proof.
+unfold seq in |- *.
+destruct x; destruct y; simpl in |- *; auto.
+Qed.
+
+(** uniset union *)
+Definition union (m1 m2:uniset) :=
+  Charac (fun a:A => orb (charac m1 a) (charac m2 a)).
+
+Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x).  
+Proof.  
+unfold seq in |- *; unfold union in |- *; simpl in |- *; auto.  
+Qed. 
+Hint Resolve union_empty_left.
+
+Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset).
+Proof.
+unfold seq in |- *; unfold union in |- *; simpl in |- *.
+intros x a; rewrite (orb_b_false (charac x a)); auto.
+Qed.
+Hint Resolve union_empty_right.
+
+Lemma union_comm : forall x y:uniset, seq (union x y) (union y x).
+Proof.
+unfold seq in |- *; unfold charac in |- *; unfold union in |- *.
+destruct x; destruct y; auto with bool.
+Qed.
+Hint Resolve union_comm.
+
+Lemma union_ass :
+ forall x y z:uniset, seq (union (union x y) z) (union x (union y z)).
+Proof.
+unfold seq in |- *; unfold union in |- *; unfold charac in |- *.
+destruct x; destruct y; destruct z; auto with bool.
+Qed.
+Hint Resolve union_ass.
+
+Lemma seq_left : forall x y z:uniset, seq x y -> seq (union x z) (union y z).
+Proof.
+unfold seq in |- *; unfold union in |- *; unfold charac in |- *.
+destruct x; destruct y; destruct z.
+intros; elim H; auto.
+Qed.
+Hint Resolve seq_left.
+
+Lemma seq_right : forall x y z:uniset, seq x y -> seq (union z x) (union z y).
+Proof.
+unfold seq in |- *; unfold union in |- *; unfold charac in |- *.
+destruct x; destruct y; destruct z.
+intros; elim H; auto.
+Qed.
+Hint Resolve seq_right.
+
+
+(** All the proofs that follow duplicate [Multiset_of_A] *)
+
+(** Here we should make uniset an abstract datatype, by hiding [Charac],
+    [union], [charac]; all further properties are proved abstractly *)
+
+Require Import Permut.
+
+Lemma union_rotate :
+ forall x y z:uniset, seq (union x (union y z)) (union z (union x y)).
+Proof.
+intros; apply (op_rotate uniset union seq); auto.
+exact seq_trans.
+Qed.
+
+Lemma seq_congr :
+ forall x y z t:uniset, seq x y -> seq z t -> seq (union x z) (union y t).
+Proof.
+intros; apply (cong_congr uniset union seq); auto.
+exact seq_trans.
+Qed.
+
+Lemma union_perm_left :
+ forall x y z:uniset, seq (union x (union y z)) (union y (union x z)).
+Proof.
+intros; apply (perm_left uniset union seq); auto.
+exact seq_trans.
+Qed.
+
+Lemma uniset_twist1 :
+ forall x y z t:uniset,
+   seq (union x (union (union y z) t)) (union (union y (union x t)) z).
+Proof.
+intros; apply (twist uniset union seq); auto.
+exact seq_trans.
+Qed.
+
+Lemma uniset_twist2 :
+ forall x y z t:uniset,
+   seq (union x (union (union y z) t)) (union (union y (union x z)) t).
+Proof.
+intros; apply seq_trans with (union (union x (union y z)) t).
+apply seq_sym; apply union_ass.
+apply seq_left; apply union_perm_left.
+Qed.
+
+(** specific for treesort *)
+
+Lemma treesort_twist1 :
+ forall x y z t u:uniset,
+   seq u (union y z) ->
+   seq (union x (union u t)) (union (union y (union x t)) z).
+Proof.
+intros; apply seq_trans with (union x (union (union y z) t)).
+apply seq_right; apply seq_left; trivial.
+apply uniset_twist1.
+Qed.
+
+Lemma treesort_twist2 :
+ forall x y z t u:uniset,
+   seq u (union y z) ->
+   seq (union x (union u t)) (union (union y (union x z)) t).
+Proof.
+intros; apply seq_trans with (union x (union (union y z) t)).
+apply seq_right; apply seq_left; trivial.
+apply uniset_twist2.
+Qed.
+
+
+(*i theory of minter to do similarly 
+Require Min.
+(* uniset intersection *)
+Definition minter := [m1,m2:uniset]
+    (Charac [a:A](andb (charac m1 a)(charac m2 a))).
+i*)
+
+End defs.
+
+Unset Implicit Arguments.
\ No newline at end of file
diff --git a/theories/Sets/intro.tex b/theories/Sets/intro.tex
new file mode 100755
index 00000000..83c2177f
--- /dev/null
+++ b/theories/Sets/intro.tex
@@ -0,0 +1,24 @@
+\section{Sets}\label{Sets}
+
+This is a library on sets defined by their characteristic predicate.
+It contains the following modules:
+
+\begin{itemize}
+\item {\tt Ensembles.v}
+\item {\tt Constructive\_sets.v}, {\tt Classical\_sets.v}
+\item {\tt Relations\_1.v}, {\tt Relations\_2.v}, 
+ {\tt Relations\_3.v}, {\tt Relations\_1\_facts.v},  \\
+ {\tt Relations\_2\_facts.v}, {\tt Relations\_3\_facts.v}
+\item {\tt Partial\_Order.v}, {\tt Cpo.v}
+\item {\tt Powerset.v}, {\tt Powerset\_facts.v}, 
+ {\tt Powerset\_Classical\_facts.v}
+\item {\tt Finite\_sets.v}, {\tt Finite\_sets\_facts.v}
+\item {\tt Image.v}
+\item {\tt Infinite\_sets.v}
+\item {\tt Integers.v}
+\end{itemize}
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: t
+%%% End: 
diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v
new file mode 100644
index 00000000..41594749
--- /dev/null
+++ b/theories/Sorting/Heap.v
@@ -0,0 +1,227 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Heap.v,v 1.3.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** A development of Treesort on Heap trees *)
+
+(* G. Huet 1-9-95 uses Multiset *)
+
+Require Import List.
+Require Import Multiset.
+Require Import Permutation.
+Require Import Relations.
+Require Import Sorting.
+
+
+Section defs.
+
+Variable A : Set.
+Variable leA : relation A.
+Variable eqA : relation A.
+
+Let gtA (x y:A) := ~ leA x y.
+
+Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}.
+Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
+Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z.
+Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y.
+
+Hint Resolve leA_refl.
+Hint Immediate eqA_dec leA_dec leA_antisym.
+
+Let emptyBag := EmptyBag A.
+Let singletonBag := SingletonBag _ eqA_dec.
+
+Inductive Tree : Set :=
+  | Tree_Leaf : Tree
+  | Tree_Node : A -> Tree -> Tree -> Tree.
+
+(** [a] is lower than a Tree [T] if [T] is a Leaf
+    or [T] is a Node holding [b>a] *)
+
+Definition leA_Tree (a:A) (t:Tree) :=
+  match t with
+  | Tree_Leaf => True
+  | Tree_Node b T1 T2 => leA a b
+  end.
+
+Lemma leA_Tree_Leaf : forall a:A, leA_Tree a Tree_Leaf.
+Proof.
+simpl in |- *; auto with datatypes.
+Qed.
+
+Lemma leA_Tree_Node :
+ forall (a b:A) (G D:Tree), leA a b -> leA_Tree a (Tree_Node b G D).
+Proof.
+simpl in |- *; auto with datatypes.
+Qed.
+
+Hint Resolve leA_Tree_Leaf leA_Tree_Node.
+
+
+(** The heap property *)
+
+Inductive is_heap : Tree -> Prop :=
+  | nil_is_heap : is_heap Tree_Leaf
+  | node_is_heap :
+      forall (a:A) (T1 T2:Tree),
+        leA_Tree a T1 ->
+        leA_Tree a T2 ->
+        is_heap T1 -> is_heap T2 -> is_heap (Tree_Node a T1 T2).
+
+Hint Constructors is_heap.
+
+Lemma invert_heap :
+ forall (a:A) (T1 T2:Tree),
+   is_heap (Tree_Node a T1 T2) ->
+   leA_Tree a T1 /\ leA_Tree a T2 /\ is_heap T1 /\ is_heap T2.
+Proof.
+intros; inversion H; auto with datatypes.
+Qed.
+
+(* This lemma ought to be generated automatically by the Inversion tools *)
+Lemma is_heap_rec :
+ forall P:Tree -> Set,
+   P Tree_Leaf ->
+   (forall (a:A) (T1 T2:Tree),
+      leA_Tree a T1 ->
+      leA_Tree a T2 ->
+      is_heap T1 -> P T1 -> is_heap T2 -> P T2 -> P (Tree_Node a T1 T2)) ->
+   forall T:Tree, is_heap T -> P T.
+Proof.
+simple induction T; auto with datatypes.
+intros a G PG D PD PN. 
+elim (invert_heap a G D); auto with datatypes.
+intros H1 H2; elim H2; intros H3 H4; elim H4; intros.
+apply H0; auto with datatypes.
+Qed.
+
+Lemma low_trans :
+ forall (T:Tree) (a b:A), leA a b -> leA_Tree b T -> leA_Tree a T.
+Proof.
+simple induction T; auto with datatypes.
+intros; simpl in |- *; apply leA_trans with b; auto with datatypes.
+Qed.
+
+(** contents of a tree as a multiset *)
+
+(** Nota Bene : In what follows the definition of SingletonBag
+    in not used. Actually, we could just take as postulate:
+    [Parameter SingletonBag : A->multiset].  *)
+
+Fixpoint contents (t:Tree) : multiset A :=
+  match t with
+  | Tree_Leaf => emptyBag
+  | Tree_Node a t1 t2 =>
+      munion (contents t1) (munion (contents t2) (singletonBag a))
+  end.
+
+
+(** equivalence of two trees is equality of corresponding multisets *)
+
+Definition equiv_Tree (t1 t2:Tree) := meq (contents t1) (contents t2).
+
+
+(** specification of heap insertion *)
+
+Inductive insert_spec (a:A) (T:Tree) : Set :=
+    insert_exist :
+      forall T1:Tree,
+        is_heap T1 ->
+        meq (contents T1) (munion (contents T) (singletonBag a)) ->
+        (forall b:A, leA b a -> leA_Tree b T -> leA_Tree b T1) ->
+        insert_spec a T.
+
+
+Lemma insert : forall T:Tree, is_heap T -> forall a:A, insert_spec a T.
+Proof.
+simple induction 1; intros.
+apply insert_exist with (Tree_Node a Tree_Leaf Tree_Leaf);
+ auto with datatypes.
+simpl in |- *; unfold meq, munion in |- *; auto with datatypes.
+elim (leA_dec a a0); intros.
+elim (H3 a0); intros.
+apply insert_exist with (Tree_Node a T2 T0); auto with datatypes.
+simpl in |- *; apply treesort_twist1; trivial with datatypes. 
+elim (H3 a); intros T3 HeapT3 ConT3 LeA.
+apply insert_exist with (Tree_Node a0 T2 T3); auto with datatypes.
+apply node_is_heap; auto with datatypes.
+apply low_trans with a; auto with datatypes.
+apply LeA; auto with datatypes.
+apply low_trans with a; auto with datatypes.
+simpl in |- *; apply treesort_twist2; trivial with datatypes. 
+Qed.
+
+(** building a heap from a list *)
+
+Inductive build_heap (l:list A) : Set :=
+    heap_exist :
+      forall T:Tree,
+        is_heap T ->
+        meq (list_contents _ eqA_dec l) (contents T) -> build_heap l.
+
+Lemma list_to_heap : forall l:list A, build_heap l.
+Proof.
+simple induction l.
+apply (heap_exist nil Tree_Leaf); auto with datatypes.
+simpl in |- *; unfold meq in |- *; auto with datatypes.
+simple induction 1.
+intros T i m; elim (insert T i a).
+intros; apply heap_exist with T1; simpl in |- *; auto with datatypes.
+apply meq_trans with (munion (contents T) (singletonBag a)).
+apply meq_trans with (munion (singletonBag a) (contents T)).
+apply meq_right; trivial with datatypes.
+apply munion_comm.
+apply meq_sym; trivial with datatypes.
+Qed.
+
+
+(** building the sorted list *)
+
+Inductive flat_spec (T:Tree) : Set :=
+    flat_exist :
+      forall l:list A,
+        sort leA l ->
+        (forall a:A, leA_Tree a T -> lelistA leA a l) ->
+        meq (contents T) (list_contents _ eqA_dec l) -> flat_spec T.
+
+Lemma heap_to_list : forall T:Tree, is_heap T -> flat_spec T.
+Proof.
+  intros T h; elim h; intros.
+  apply flat_exist with (nil (A:=A)); auto with datatypes.
+  elim H2; intros l1 s1 i1 m1; elim H4; intros l2 s2 i2 m2.
+  elim (merge _ leA_dec eqA_dec s1 s2); intros.
+  apply flat_exist with (a :: l); simpl in |- *; auto with datatypes.
+  apply meq_trans with
+   (munion (list_contents _ eqA_dec l1)
+      (munion (list_contents _ eqA_dec l2) (singletonBag a))).
+  apply meq_congr; auto with datatypes.
+  apply meq_trans with
+   (munion (singletonBag a)
+      (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2))).
+  apply munion_rotate.
+  apply meq_right; apply meq_sym; trivial with datatypes.
+Qed.
+
+(** specification of treesort *)
+
+Theorem treesort :
+ forall l:list A, {m : list A | sort leA m &  permutation _ eqA_dec l m}.
+Proof.
+  intro l; unfold permutation in |- *.
+  elim (list_to_heap l).
+  intros.
+  elim (heap_to_list T); auto with datatypes.
+  intros.
+  exists l0; auto with datatypes.
+  apply meq_trans with (contents T); trivial with datatypes.
+Qed.
+
+End defs.
\ No newline at end of file
diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v
new file mode 100644
index 00000000..43a0f0bc
--- /dev/null
+++ b/theories/Sorting/Permutation.v
@@ -0,0 +1,120 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Permutation.v,v 1.4.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+Require Import Relations.
+Require Import List.
+Require Import Multiset.
+
+Set Implicit Arguments.
+
+Section defs.
+
+Variable A : Set.
+Variable leA : relation A.
+Variable eqA : relation A.
+
+Let gtA (x y:A) := ~ leA x y.
+
+Hypothesis leA_dec : forall x y:A, {leA x y} + {~ leA x y}.
+Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
+Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z.
+Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y.
+
+Hint Resolve leA_refl: default.
+Hint Immediate eqA_dec leA_dec leA_antisym: default.
+
+Let emptyBag := EmptyBag A.
+Let singletonBag := SingletonBag _ eqA_dec.
+
+(** contents of a list *)
+
+Fixpoint list_contents (l:list A) : multiset A :=
+  match l with
+  | nil => emptyBag
+  | a :: l => munion (singletonBag a) (list_contents l)
+  end.
+
+Lemma list_contents_app :
+ forall l m:list A,
+   meq (list_contents (l ++ m)) (munion (list_contents l) (list_contents m)).
+Proof.
+simple induction l; simpl in |- *; auto with datatypes.
+intros.
+apply meq_trans with
+ (munion (singletonBag a) (munion (list_contents l0) (list_contents m)));
+ auto with datatypes.
+Qed.
+Hint Resolve list_contents_app.
+
+Definition permutation (l m:list A) :=
+  meq (list_contents l) (list_contents m).
+
+Lemma permut_refl : forall l:list A, permutation l l.
+Proof.
+unfold permutation in |- *; auto with datatypes.
+Qed.
+Hint Resolve permut_refl.
+
+Lemma permut_tran :
+ forall l m n:list A, permutation l m -> permutation m n -> permutation l n.
+Proof.
+unfold permutation in |- *; intros.
+apply meq_trans with (list_contents m); auto with datatypes.
+Qed.
+
+Lemma permut_right :
+ forall l m:list A,
+   permutation l m -> forall a:A, permutation (a :: l) (a :: m).
+Proof.
+unfold permutation in |- *; simpl in |- *; auto with datatypes.
+Qed.
+Hint Resolve permut_right.
+
+Lemma permut_app :
+ forall l l' m m':list A,
+   permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m').
+Proof.
+unfold permutation in |- *; intros.
+apply meq_trans with (munion (list_contents l) (list_contents m));
+ auto with datatypes.
+apply meq_trans with (munion (list_contents l') (list_contents m'));
+ auto with datatypes.
+apply meq_trans with (munion (list_contents l') (list_contents m));
+ auto with datatypes.
+Qed.
+Hint Resolve permut_app.
+
+Lemma permut_cons :
+ forall l m:list A,
+   permutation l m -> forall a:A, permutation (a :: l) (a :: m).
+Proof.
+intros l m H a.
+change (permutation ((a :: nil) ++ l) ((a :: nil) ++ m)) in |- *.
+apply permut_app; auto with datatypes.
+Qed.
+Hint Resolve permut_cons.
+
+Lemma permut_middle :
+ forall (l m:list A) (a:A), permutation (a :: l ++ m) (l ++ a :: m).
+Proof.
+unfold permutation in |- *.
+simple induction l; simpl in |- *; auto with datatypes.
+intros.
+apply meq_trans with
+ (munion (singletonBag a)
+    (munion (singletonBag a0) (list_contents (l0 ++ m))));
+ auto with datatypes.
+apply munion_perm_left; auto with datatypes.
+Qed.
+Hint Resolve permut_middle.
+
+End defs.
+Unset Implicit Arguments.
diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v
new file mode 100644
index 00000000..aa829fea
--- /dev/null
+++ b/theories/Sorting/Sorting.v
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Sorting.v,v 1.4.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+Require Import List.
+Require Import Multiset.
+Require Import Permutation.
+Require Import Relations.
+
+Set Implicit Arguments.
+
+Section defs.
+
+Variable A : Set.
+Variable leA : relation A.
+Variable eqA : relation A.
+
+Let gtA (x y:A) := ~ leA x y.
+
+Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}.
+Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
+Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z.
+Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y.
+
+Hint Resolve leA_refl.
+Hint Immediate eqA_dec leA_dec leA_antisym.
+
+Let emptyBag := EmptyBag A.
+Let singletonBag := SingletonBag _ eqA_dec.
+
+(** [lelistA] *)
+
+Inductive lelistA (a:A) : list A -> Prop :=
+  | nil_leA : lelistA a nil
+  | cons_leA : forall (b:A) (l:list A), leA a b -> lelistA a (b :: l).
+Hint Constructors lelistA.
+
+Lemma lelistA_inv : forall (a b:A) (l:list A), lelistA a (b :: l) -> leA a b.
+Proof.
+  intros; inversion H; trivial with datatypes.
+Qed.
+
+(** definition for a list to be sorted *)
+
+Inductive sort : list A -> Prop :=
+  | nil_sort : sort nil
+  | cons_sort :
+      forall (a:A) (l:list A), sort l -> lelistA a l -> sort (a :: l).
+Hint Constructors sort.
+
+Lemma sort_inv :
+ forall (a:A) (l:list A), sort (a :: l) -> sort l /\ lelistA a l.
+Proof.
+intros; inversion H; auto with datatypes.
+Qed.
+
+Lemma sort_rec :
+ forall P:list A -> Set,
+   P nil ->
+   (forall (a:A) (l:list A), sort l -> P l -> lelistA a l -> P (a :: l)) ->
+   forall y:list A, sort y -> P y.
+Proof.
+simple induction y; auto with datatypes.
+intros; elim (sort_inv (a:=a) (l:=l)); auto with datatypes.
+Qed.
+
+(** merging two sorted lists *)
+
+Inductive merge_lem (l1 l2:list A) : Set :=
+    merge_exist :
+      forall l:list A,
+        sort l ->
+        meq (list_contents _ eqA_dec l)
+          (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) ->
+        (forall a:A, lelistA a l1 -> lelistA a l2 -> lelistA a l) ->
+        merge_lem l1 l2.
+
+Lemma merge :
+ forall l1:list A, sort l1 -> forall l2:list A, sort l2 -> merge_lem l1 l2.
+Proof.
+  simple induction 1; intros.
+  apply merge_exist with l2; auto with datatypes.
+  elim H3; intros.
+  apply merge_exist with (a :: l); simpl in |- *; auto with datatypes.
+  elim (leA_dec a a0); intros.
+
+(* 1 (leA a a0) *)
+  cut (merge_lem l (a0 :: l0)); auto with datatypes.
+  intros [l3 l3sorted l3contents Hrec].
+  apply merge_exist with (a :: l3); simpl in |- *; auto with datatypes.
+  apply meq_trans with
+   (munion (singletonBag a)
+      (munion (list_contents _ eqA_dec l)
+         (list_contents _ eqA_dec (a0 :: l0)))).
+  apply meq_right; trivial with datatypes.
+  apply meq_sym; apply munion_ass.
+  intros; apply cons_leA.
+  apply lelistA_inv with l; trivial with datatypes.
+
+(* 2 (leA a0 a) *)
+  elim H5; simpl in |- *; intros.
+  apply merge_exist with (a0 :: l3); simpl in |- *; auto with datatypes.
+  apply meq_trans with
+   (munion (singletonBag a0)
+      (munion (munion (singletonBag a) (list_contents _ eqA_dec l))
+         (list_contents _ eqA_dec l0))).
+  apply meq_right; trivial with datatypes.
+  apply munion_perm_left.
+  intros; apply cons_leA; apply lelistA_inv with l0; trivial with datatypes.
+Qed.
+
+End defs.
+
+Unset Implicit Arguments.
+Hint Constructors sort: datatypes v62.
+Hint Constructors lelistA: datatypes v62.
\ No newline at end of file
diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v
new file mode 100644
index 00000000..a3f16888
--- /dev/null
+++ b/theories/Wellfounded/Disjoint_Union.v
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Disjoint_Union.v,v 1.9.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Cristina Cornes
+    From : Constructing Recursion Operators in Type Theory                 
+           L. Paulson  JSC (1986) 2, 325-355 *) 
+
+Require Import Relation_Operators.
+
+Section Wf_Disjoint_Union.
+Variables A B : Set.
+Variable leA : A -> A -> Prop.
+Variable leB : B -> B -> Prop.
+
+Notation Le_AsB := (le_AsB A B leA leB).
+
+Lemma acc_A_sum : forall x:A, Acc leA x -> Acc Le_AsB (inl B x).
+Proof.
+ induction 1.
+ apply Acc_intro; intros y H2.
+ inversion_clear H2.
+ auto with sets.
+Qed.
+
+Lemma acc_B_sum :
+ well_founded leA -> forall x:B, Acc leB x -> Acc Le_AsB (inr A x).
+Proof.
+ induction 2.
+ apply Acc_intro; intros y H3.
+ inversion_clear H3; auto with sets.
+ apply acc_A_sum; auto with sets.
+Qed.
+
+
+Lemma wf_disjoint_sum :
+ well_founded leA -> well_founded leB -> well_founded Le_AsB.
+Proof.
+ intros.
+ unfold well_founded in |- *.
+ destruct a as [a| b].
+ apply (acc_A_sum a).
+ apply (H a).
+
+ apply (acc_B_sum H b).
+ apply (H0 b).
+Qed.
+
+End Wf_Disjoint_Union.
\ No newline at end of file
diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v
new file mode 100644
index 00000000..1677659c
--- /dev/null
+++ b/theories/Wellfounded/Inclusion.v
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Inclusion.v,v 1.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Bruno Barras *)
+
+Require Import Relation_Definitions.
+
+Section WfInclusion.
+  Variable A : Set.
+  Variables R1 R2 : A -> A -> Prop.
+
+  Lemma Acc_incl : inclusion A R1 R2 -> forall z:A, Acc R2 z -> Acc R1 z.
+  Proof.
+    induction 2.
+    apply Acc_intro; auto with sets.
+  Qed.
+
+  Hint Resolve Acc_incl.
+
+  Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1.
+  Proof.
+    unfold well_founded in |- *; auto with sets.
+  Qed.
+
+End WfInclusion.
\ No newline at end of file
diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v
new file mode 100644
index 00000000..f2cf1d2e
--- /dev/null
+++ b/theories/Wellfounded/Inverse_Image.v
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Inverse_Image.v,v 1.10.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Bruno Barras *)
+
+Section Inverse_Image.
+
+  Variables A B : Set.
+  Variable R : B -> B -> Prop.
+  Variable f : A -> B.
+
+  Let Rof (x y:A) : Prop := R (f x) (f y).
+
+  Remark Acc_lemma : forall y:B, Acc R y -> forall x:A, y = f x -> Acc Rof x.
+    induction 1 as [y _ IHAcc]; intros x H.
+    apply Acc_intro; intros y0 H1.
+    apply (IHAcc (f y0)); try trivial.
+    rewrite H; trivial.
+  Qed.
+
+  Lemma Acc_inverse_image : forall x:A, Acc R (f x) -> Acc Rof x.
+    intros; apply (Acc_lemma (f x)); trivial.
+  Qed.
+
+  Theorem wf_inverse_image : well_founded R -> well_founded Rof.
+    red in |- *; intros; apply Acc_inverse_image; auto.
+  Qed.
+
+  Variable F : A -> B -> Prop.
+  Let RoF (x y:A) : Prop :=
+     exists2 b : B, F x b & (forall c:B, F y c -> R b c).
+
+Lemma Acc_inverse_rel : forall b:B, Acc R b -> forall x:A, F x b -> Acc RoF x.
+induction 1 as [x _ IHAcc]; intros x0 H2.
+constructor; intros y H3.
+destruct H3.
+apply (IHAcc x1); auto.
+Qed.
+
+
+Theorem wf_inverse_rel : well_founded R -> well_founded RoF.
+    red in |- *; constructor; intros.
+    case H0; intros.
+    apply (Acc_inverse_rel x); auto.
+Qed.
+
+End Inverse_Image.
+
diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v
new file mode 100644
index 00000000..d8a4d37c
--- /dev/null
+++ b/theories/Wellfounded/Lexicographic_Exponentiation.v
@@ -0,0 +1,374 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Lexicographic_Exponentiation.v,v 1.10.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Cristina Cornes
+
+    From : Constructing Recursion Operators in Type Theory                
+           L. Paulson  JSC (1986) 2, 325-355  *)
+
+Require Import Eqdep.
+Require Import List.
+Require Import Relation_Operators.
+Require Import Transitive_Closure.
+
+Section Wf_Lexicographic_Exponentiation.
+Variable A : Set.
+Variable leA : A -> A -> Prop.
+
+Notation Power := (Pow A leA).
+Notation Lex_Exp := (lex_exp A leA).
+Notation ltl := (Ltl A leA).
+Notation Descl := (Desc A leA).
+
+Notation List := (list A).
+Notation Nil := (nil (A:=A)).
+(* useless but symmetric *)
+Notation Cons := (cons (A:=A)).
+Notation "<< x , y >>" := (exist Descl x y) (at level 0, x, y at level 100).
+
+Hint Resolve d_one d_nil t_step.
+
+Lemma left_prefix : forall x y z:List, ltl (x ++ y) z -> ltl x z.
+Proof.
+ simple induction x.
+ simple induction z.
+ simpl in |- *; intros H.
+ inversion_clear H. 
+ simpl in |- *; intros; apply (Lt_nil A leA).
+ intros a l HInd.
+ simpl in |- *.
+ intros.
+ inversion_clear H.
+ apply (Lt_hd A leA); auto with sets.
+ apply (Lt_tl A leA).
+ apply (HInd y y0); auto with sets.
+Qed.
+
+
+Lemma right_prefix :
+ forall x y z:List,
+   ltl x (y ++ z) -> ltl x y \/ (exists y' : List, x = y ++ y' /\ ltl y' z).
+Proof.
+ intros x y; generalize x.
+ elim y; simpl in |- *.
+ right.
+ exists x0; auto with sets.
+ intros.
+ inversion H0.
+ left; apply (Lt_nil A leA).
+ left; apply (Lt_hd A leA); auto with sets.
+ generalize (H x1 z H3).
+ simple induction 1.
+ left; apply (Lt_tl A leA); auto with sets.
+ simple induction 1.
+ simple induction 1; intros.
+ rewrite H8.
+ right; exists x2; auto with sets.
+Qed.
+
+
+
+Lemma desc_prefix : forall (x:List) (a:A), Descl (x ++ Cons a Nil) -> Descl x.
+Proof.
+ intros.
+ inversion H.
+ generalize (app_cons_not_nil _ _ _ H1); simple induction 1. 
+ cut (x ++ Cons a Nil = Cons x0 Nil); auto with sets.
+ intro.
+ generalize (app_eq_unit _ _ H0).
+ simple induction 1; simple induction 1; intros.
+ rewrite H4; auto with sets.
+ discriminate H5.
+ generalize (app_inj_tail _ _ _ _ H0).
+ simple induction 1; intros.
+ rewrite <- H4; auto with sets.
+Qed.
+
+Lemma desc_tail :
+ forall (x:List) (a b:A),
+   Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b.
+Proof.
+ intro.
+ apply rev_ind with
+  (A := A)
+  (P := fun x:List =>
+          forall a b:A,
+            Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b).
+ intros.
+
+ inversion H.
+ cut (Cons b (Cons a Nil) = (Nil ++ Cons b Nil) ++ Cons a Nil);
+  auto with sets; intro.
+ generalize H0.
+ intro.
+ generalize (app_inj_tail (l ++ Cons y Nil) (Nil ++ Cons b Nil) _ _ H4);
+  simple induction 1.
+ intros.
+
+ generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
+ generalize H1.
+ rewrite <- H10; rewrite <- H7; intro.
+ apply (t_step A leA); auto with sets.
+
+
+
+ intros.
+ inversion H0.
+ generalize (app_cons_not_nil _ _ _ H3); intro.
+ elim H1.
+
+ generalize H0.
+ generalize (app_comm_cons (l ++ Cons x0 Nil) (Cons a Nil) b);
+  simple induction 1.
+ intro.
+ generalize (desc_prefix (Cons b (l ++ Cons x0 Nil)) a H5); intro.
+ generalize (H x0 b H6).
+ intro.
+ apply t_trans with (A := A) (y := x0); auto with sets.
+
+ apply t_step.
+ generalize H1.
+ rewrite H4; intro.
+
+ generalize (app_inj_tail _ _ _ _ H8); simple induction 1.
+ intros.
+ generalize H2; generalize (app_comm_cons l (Cons x0 Nil) b).
+ intro.
+ generalize H10.
+ rewrite H12; intro.
+ generalize (app_inj_tail _ _ _ _ H13); simple induction 1.
+ intros.
+ rewrite <- H11; rewrite <- H16; auto with sets.
+Qed.
+
+
+Lemma dist_aux :
+ forall z:List, Descl z -> forall x y:List, z = x ++ y -> Descl x /\ Descl y.
+Proof.
+ intros z D.
+ elim D.
+ intros.
+ cut (x ++ y = Nil); auto with sets; intro.
+ generalize (app_eq_nil _ _ H0); simple induction 1.
+ intros.
+ rewrite H2; rewrite H3; split; apply d_nil.
+
+ intros.
+ cut (x0 ++ y = Cons x Nil); auto with sets.
+ intros E.
+ generalize (app_eq_unit _ _ E); simple induction 1.
+ simple induction 1; intros.
+ rewrite H2; rewrite H3; split.
+ apply d_nil.
+
+ apply d_one.
+
+ simple induction 1; intros.
+ rewrite H2; rewrite H3; split.
+ apply d_one.
+
+ apply d_nil.
+
+ do 5 intro.
+ intros Hind.
+ do 2 intro.
+ generalize x0.
+ apply rev_ind with
+  (A := A)
+  (P := fun y0:List =>
+          forall x0:List,
+            (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ y0 ->
+            Descl x0 /\ Descl y0).
+
+ intro.
+ generalize (app_nil_end x1); simple induction 1; simple induction 1.
+ split. apply d_conc; auto with sets.
+
+ apply d_nil.
+
+ do 3 intro.
+ generalize x1.
+ apply rev_ind with
+  (A := A)
+  (P := fun l0:List =>
+          forall (x1:A) (x0:List),
+            (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ l0 ++ Cons x1 Nil ->
+            Descl x0 /\ Descl (l0 ++ Cons x1 Nil)).
+
+
+ simpl in |- *.
+ split.
+ generalize (app_inj_tail _ _ _ _ H2); simple induction 1.
+ simple induction 1; auto with sets.
+
+ apply d_one.
+ do 5 intro.
+ generalize (app_ass x4 (l1 ++ Cons x2 Nil) (Cons x3 Nil)).
+ simple induction 1.
+ generalize (app_ass x4 l1 (Cons x2 Nil)); simple induction 1.
+ intro E.
+ generalize (app_inj_tail _ _ _ _ E).
+ simple induction 1; intros.
+ generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
+ rewrite <- H7; rewrite <- H10; generalize H6.
+ generalize (app_ass x4 l1 (Cons x2 Nil)); intro E1.
+ rewrite E1.
+ intro.
+ generalize (Hind x4 (l1 ++ Cons x2 Nil) H11).
+ simple induction 1; split.
+ auto with sets.
+
+ generalize H14.
+ rewrite <- H10; intro.
+ apply d_conc; auto with sets.
+Qed.
+
+
+
+Lemma dist_Desc_concat :
+ forall x y:List, Descl (x ++ y) -> Descl x /\ Descl y.
+Proof.
+  intros.
+  apply (dist_aux (x ++ y) H x y); auto with sets.
+Qed.
+
+
+Lemma desc_end :
+ forall (a b:A) (x:List),
+   Descl (x ++ Cons a Nil) /\ ltl (x ++ Cons a Nil) (Cons b Nil) ->
+   clos_trans A leA a b. 
+
+Proof.
+ intros a b x.
+ case x.
+ simpl in |- *.
+ simple induction 1.
+ intros.
+ inversion H1; auto with sets.
+ inversion H3.
+
+ simple induction 1.
+ generalize (app_comm_cons l (Cons a Nil) a0).
+ intros E; rewrite <- E; intros.
+ generalize (desc_tail l a a0 H0); intro.
+ inversion H1.
+ apply t_trans with (y := a0); auto with sets.
+
+ inversion H4.
+Qed.
+
+
+
+
+Lemma ltl_unit :
+ forall (x:List) (a b:A),
+   Descl (x ++ Cons a Nil) ->
+   ltl (x ++ Cons a Nil) (Cons b Nil) -> ltl x (Cons b Nil).
+Proof.
+ intro.
+ case x.
+ intros; apply (Lt_nil A leA).
+
+ simpl in |- *; intros.
+ inversion_clear H0.
+ apply (Lt_hd A leA a b); auto with sets.
+ 
+ inversion_clear H1.
+Qed.
+
+
+Lemma acc_app :
+ forall (x1 x2:List) (y1:Descl (x1 ++ x2)),
+   Acc Lex_Exp << x1 ++ x2, y1 >> ->
+   forall (x:List) (y:Descl x), ltl x (x1 ++ x2) -> Acc Lex_Exp << x, y >>.
+Proof.
+ intros.
+ apply (Acc_inv (R:=Lex_Exp) (x:=<< x1 ++ x2, y1 >>)).
+ auto with sets.
+
+ unfold lex_exp in |- *; simpl in |- *; auto with sets.
+Qed.
+
+
+Theorem wf_lex_exp : well_founded leA -> well_founded Lex_Exp.
+Proof.
+ unfold well_founded at 2 in |- *.
+ simple induction a; intros x y.
+ apply Acc_intro.
+ simple induction y0.
+ unfold lex_exp at 1 in |- *; simpl in |- *.
+ apply rev_ind with
+  (A := A)
+  (P := fun x:List =>
+          forall (x0:List) (y:Descl x0), ltl x0 x -> Acc Lex_Exp << x0, y >>).
+ intros.
+ inversion_clear H0.
+
+ intro.
+ generalize (well_founded_ind (wf_clos_trans A leA H)).
+ intros GR.
+ apply GR with
+  (P := fun x0:A =>
+          forall l:List,
+            (forall (x1:List) (y:Descl x1),
+               ltl x1 l -> Acc Lex_Exp << x1, y >>) ->
+            forall (x1:List) (y:Descl x1),
+              ltl x1 (l ++ Cons x0 Nil) -> Acc Lex_Exp << x1, y >>).
+ intro; intros HInd; intros.
+ generalize (right_prefix x2 l (Cons x1 Nil) H1).
+ simple induction 1.
+ intro; apply (H0 x2 y1 H3).
+
+ simple induction 1.
+ intro; simple induction 1.
+ clear H4 H2.
+ intro; generalize y1; clear y1.
+ rewrite H2.
+ apply rev_ind with
+  (A := A)
+  (P := fun x3:List =>
+          forall y1:Descl (l ++ x3),
+            ltl x3 (Cons x1 Nil) -> Acc Lex_Exp << l ++ x3, y1 >>).
+ intros.
+ generalize (app_nil_end l); intros Heq.
+ generalize y1.
+ clear y1.
+ rewrite <- Heq.
+ intro.
+ apply Acc_intro.
+ simple induction y2.
+ unfold lex_exp at 1 in |- *.
+ simpl in |- *; intros x4 y3. intros.
+ apply (H0 x4 y3); auto with sets.
+
+ intros. 
+ generalize (dist_Desc_concat l (l0 ++ Cons x4 Nil) y1).
+ simple induction 1.
+ intros.
+ generalize (desc_end x4 x1 l0 (conj H8 H5)); intros.
+ generalize y1.
+ rewrite <- (app_ass l l0 (Cons x4 Nil)); intro.
+ generalize (HInd x4 H9 (l ++ l0)); intros HInd2.
+ generalize (ltl_unit l0 x4 x1 H8 H5); intro.
+ generalize (dist_Desc_concat (l ++ l0) (Cons x4 Nil) y2).
+ simple induction 1; intros.
+ generalize (H4 H12 H10); intro.
+ generalize (Acc_inv H14).
+ generalize (acc_app l l0 H12 H14).
+ intros f g.
+ generalize (HInd2 f); intro.
+ apply Acc_intro.
+ simple induction y3.
+ unfold lex_exp at 1 in |- *; simpl in |- *; intros.
+ apply H15; auto with sets.
+Qed.
+
+
+End Wf_Lexicographic_Exponentiation.
diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v
new file mode 100644
index 00000000..8ac178fc
--- /dev/null
+++ b/theories/Wellfounded/Lexicographic_Product.v
@@ -0,0 +1,192 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Lexicographic_Product.v,v 1.12.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Authors: Bruno Barras, Cristina Cornes *)
+
+Require Import Eqdep.
+Require Import Relation_Operators.
+Require Import Transitive_Closure.
+
+(**  From : Constructing Recursion Operators in Type Theory            
+     L. Paulson  JSC (1986) 2, 325-355 *)
+
+Section WfLexicographic_Product.
+Variable A : Set.
+Variable B : A -> Set.
+Variable leA : A -> A -> Prop.
+Variable leB : forall x:A, B x -> B x -> Prop.
+
+Notation LexProd := (lexprod A B leA leB).
+
+Hint Resolve t_step Acc_clos_trans wf_clos_trans.
+
+Lemma acc_A_B_lexprod :
+ forall x:A,
+   Acc leA x ->
+   (forall x0:A, clos_trans A leA x0 x -> well_founded (leB x0)) ->
+   forall y:B x, Acc (leB x) y -> Acc LexProd (existS B x y).
+Proof.
+ induction 1 as [x _ IHAcc]; intros H2 y.
+ induction 1 as [x0 H IHAcc0]; intros.
+ apply Acc_intro.
+ destruct y as [x2 y1]; intro H6.
+ simple inversion H6; intro.
+ cut (leA x2 x); intros.
+ apply IHAcc; auto with sets.
+ intros.
+ apply H2.
+ apply t_trans with x2; auto with sets.
+
+ red in H2.
+ apply H2.
+ auto with sets.
+
+ injection H1.
+ destruct 2.
+ injection H3.
+ destruct 2; auto with sets.
+
+ rewrite <- H1.
+ injection H3; intros _ Hx1.
+ subst x1.
+ apply IHAcc0.
+ elim inj_pair2 with A B x y' x0; assumption.
+Qed.
+
+Theorem wf_lexprod :
+ well_founded leA ->
+ (forall x:A, well_founded (leB x)) -> well_founded LexProd.
+Proof.
+ intros wfA wfB; unfold well_founded in |- *.
+ destruct a.
+ apply acc_A_B_lexprod; auto with sets; intros.
+ red in wfB.
+ auto with sets.
+Qed.
+
+
+End WfLexicographic_Product.
+
+
+Section Wf_Symmetric_Product.
+  Variable A : Set.
+  Variable B : Set.
+  Variable leA : A -> A -> Prop.
+  Variable leB : B -> B -> Prop.
+
+  Notation Symprod := (symprod A B leA leB).
+
+(*i
+  Local sig_prod:=
+         [x:A*B]<{_:A&B}>Case x of [a:A][b:B](existS A [_:A]B a b) end.
+
+Lemma incl_sym_lexprod: (included (A*B) Symprod  
+            (R_o_f (A*B) {_:A&B} sig_prod (lexprod A [_:A]B leA [_:A]leB))).
+Proof.
+ Red.
+ Induction x.
+ (Induction y1;Intros).
+ Red.
+ Unfold sig_prod .
+ Inversion_clear H.
+ (Apply left_lex;Auto with sets).
+
+ (Apply right_lex;Auto with sets).
+Qed.
+i*)
+
+  Lemma Acc_symprod :
+   forall x:A, Acc leA x -> forall y:B, Acc leB y -> Acc Symprod (x, y).
+ Proof.
+ induction 1 as [x _ IHAcc]; intros y H2.
+ induction H2 as [x1 H3 IHAcc1].
+ apply Acc_intro; intros y H5.
+ inversion_clear H5; auto with sets.
+ apply IHAcc; auto.
+ apply Acc_intro; trivial.
+Qed.
+
+
+Lemma wf_symprod :
+ well_founded leA -> well_founded leB -> well_founded Symprod.
+Proof.
+ red in |- *.
+ destruct a.
+ apply Acc_symprod; auto with sets.
+Qed.
+
+End Wf_Symmetric_Product.
+
+
+Section Swap.
+
+  Variable A : Set.
+  Variable R : A -> A -> Prop.
+
+  Notation SwapProd := (swapprod A R).
+
+
+  Lemma swap_Acc : forall x y:A, Acc SwapProd (x, y) -> Acc SwapProd (y, x).
+Proof.
+ intros.
+ inversion_clear H.
+ apply Acc_intro.
+ destruct y0; intros.
+ inversion_clear H; inversion_clear H1; apply H0.
+ apply sp_swap.
+ apply right_sym; auto with sets.
+
+ apply sp_swap.
+ apply left_sym; auto with sets.
+
+ apply sp_noswap.
+ apply right_sym; auto with sets.
+
+ apply sp_noswap.
+ apply left_sym; auto with sets.
+Qed.
+
+
+  Lemma Acc_swapprod :
+   forall x y:A, Acc R x -> Acc R y -> Acc SwapProd (x, y).
+Proof.
+ induction 1 as [x0 _ IHAcc0]; intros H2.
+ cut (forall y0:A, R y0 x0 -> Acc SwapProd (y0, y)).
+ clear IHAcc0.
+ induction H2 as [x1 _ IHAcc1]; intros H4.
+ cut (forall y:A, R y x1 -> Acc SwapProd (x0, y)).
+ clear IHAcc1.
+ intro.
+ apply Acc_intro.
+ destruct y; intro H5.
+ inversion_clear H5.
+ inversion_clear H0; auto with sets.
+
+ apply swap_Acc.
+ inversion_clear H0; auto with sets.
+
+ intros.
+ apply IHAcc1; auto with sets; intros.
+ apply Acc_inv with (y0, x1); auto with sets.
+ apply sp_noswap.
+ apply right_sym; auto with sets.
+
+ auto with sets.
+Qed.
+
+
+  Lemma wf_swapprod : well_founded R -> well_founded SwapProd.
+Proof.
+ red in |- *.
+ destruct a; intros.
+ apply Acc_swapprod; auto with sets.
+Qed.
+
+End Swap.
\ No newline at end of file
diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v
new file mode 100644
index 00000000..2e9d497b
--- /dev/null
+++ b/theories/Wellfounded/Transitive_Closure.v
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Transitive_Closure.v,v 1.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Bruno Barras *)
+
+Require Import Relation_Definitions.
+Require Import Relation_Operators.
+
+Section Wf_Transitive_Closure.
+  Variable A : Set.
+  Variable R : relation A.
+
+  Notation trans_clos := (clos_trans A R).
+ 
+  Lemma incl_clos_trans : inclusion A R trans_clos.
+    red in |- *; auto with sets.
+  Qed.
+
+  Lemma Acc_clos_trans : forall x:A, Acc R x -> Acc trans_clos x.
+    induction 1 as [x0 _ H1].
+    apply Acc_intro.
+    intros y H2.
+    induction H2; auto with sets.
+    apply Acc_inv with y; auto with sets.
+  Qed.
+
+  Hint Resolve Acc_clos_trans.
+
+  Lemma Acc_inv_trans : forall x y:A, trans_clos y x -> Acc R x -> Acc R y.
+  Proof.
+    induction 1 as [| x y]; auto with sets.
+    intro; apply Acc_inv with y; assumption.
+  Qed.
+
+  Theorem wf_clos_trans : well_founded R -> well_founded trans_clos.
+  Proof.
+    unfold well_founded in |- *; auto with sets.
+  Qed.
+
+End Wf_Transitive_Closure.
\ No newline at end of file
diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v
new file mode 100644
index 00000000..8f31ce9f
--- /dev/null
+++ b/theories/Wellfounded/Union.v
@@ -0,0 +1,77 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Union.v,v 1.9.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Bruno Barras *)
+
+Require Import Relation_Operators.
+Require Import Relation_Definitions.
+Require Import Transitive_Closure.
+
+Section WfUnion.
+  Variable A : Set.
+  Variables R1 R2 : relation A.
+  
+ Notation Union := (union A R1 R2).
+
+ Hint Resolve Acc_clos_trans wf_clos_trans.
+
+Remark strip_commut :
+ commut A R1 R2 ->
+ forall x y:A,
+   clos_trans A R1 y x ->
+   forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & clos_trans A R1 z y'.
+Proof.
+ induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros.
+ elim H with y x z; auto with sets; intros x0 H2 H3.
+ exists x0; auto with sets.
+
+ elim IH1 with z0; auto with sets; intros.
+ elim IH2 with x0; auto with sets; intros.
+ exists x1; auto with sets.
+ apply t_trans with x0; auto with sets.
+Qed.
+
+
+  Lemma Acc_union :
+   commut A R1 R2 ->
+   (forall x:A, Acc R2 x -> Acc R1 x) -> forall a:A, Acc R2 a -> Acc Union a.
+Proof.
+ induction 3 as [x H1 H2].
+ apply Acc_intro; intros.
+ elim H3; intros; auto with sets.
+ cut (clos_trans A R1 y x); auto with sets.
+ elimtype (Acc (clos_trans A R1) y); intros.
+ apply Acc_intro; intros.
+ elim H8; intros.
+ apply H6; auto with sets.
+ apply t_trans with x0; auto with sets.
+
+ elim strip_commut with x x0 y0; auto with sets; intros.
+ apply Acc_inv_trans with x1; auto with sets.
+ unfold union in |- *.
+ elim H11; auto with sets; intros.
+ apply t_trans with y1; auto with sets.
+
+ apply (Acc_clos_trans A).
+ apply Acc_inv with x; auto with sets.
+ apply H0.
+ apply Acc_intro; auto with sets.
+Qed.
+
+
+  Theorem wf_union :
+   commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union.
+Proof.
+ unfold well_founded in |- *.
+ intros.
+ apply Acc_union; auto with sets.
+Qed.
+
+End WfUnion.
\ No newline at end of file
diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v
new file mode 100644
index 00000000..4a20c518
--- /dev/null
+++ b/theories/Wellfounded/Well_Ordering.v
@@ -0,0 +1,72 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Well_Ordering.v,v 1.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Cristina Cornes.
+    From: Constructing Recursion Operators in Type Theory
+    L. Paulson  JSC (1986) 2, 325-355 *)
+
+Require Import Eqdep.
+
+Section WellOrdering.
+Variable A : Set.
+Variable B : A -> Set. 
+
+Inductive WO : Set :=
+    sup : forall (a:A) (f:B a -> WO), WO.
+
+
+Inductive le_WO : WO -> WO -> Prop :=
+    le_sup : forall (a:A) (f:B a -> WO) (v:B a), le_WO (f v) (sup a f).
+ 
+
+Theorem wf_WO : well_founded le_WO.
+Proof.
+ unfold well_founded in |- *; intro.
+ apply Acc_intro.
+ elim a.
+ intros.
+ inversion H0.
+ apply Acc_intro.
+ generalize H4; generalize H1; generalize f0; generalize v.
+ rewrite H3.
+ intros.
+ apply (H v0 y0).
+ cut (f = f1).
+ intros E; rewrite E; auto.
+ symmetry  in |- *.
+ apply (inj_pair2 A (fun a0:A => B a0 -> WO) a0 f1 f H5).
+Qed.
+
+End WellOrdering.
+
+
+Section Characterisation_wf_relations.
+
+(** Wellfounded relations are the inverse image of wellordering types *)
+(*  in course of development                                          *)
+
+
+Variable A : Set.
+Variable leA : A -> A -> Prop.
+
+Definition B (a:A) := {x : A | leA x a}.
+
+Definition wof : well_founded leA -> A -> WO A B.
+Proof.
+ intros.
+ apply (well_founded_induction H (fun a:A => WO A B)); auto.
+ intros.
+ apply (sup A B x).
+ unfold B at 1 in |- *.
+ destruct 1 as [x0].
+ apply (H1 x0); auto.
+Qed.
+
+End Characterisation_wf_relations.
\ No newline at end of file
diff --git a/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v
new file mode 100644
index 00000000..87c00b47
--- /dev/null
+++ b/theories/Wellfounded/Wellfounded.v
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Wellfounded.v,v 1.4.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+Require Export Disjoint_Union.
+Require Export Inclusion.
+Require Export Inverse_Image.
+Require Export Lexicographic_Exponentiation.
+Require Export Lexicographic_Product.
+Require Export Transitive_Closure.
+Require Export Union.
+Require Export Well_Ordering.
+
diff --git a/theories/Wellfounded/intro.tex b/theories/Wellfounded/intro.tex
new file mode 100755
index 00000000..126071e2
--- /dev/null
+++ b/theories/Wellfounded/intro.tex
@@ -0,0 +1,4 @@
+\section{Well-founded relations}\label{Wellfounded}
+
+This library gives definitions and results about well-founded relations.
+
diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v
new file mode 100644
index 00000000..11fa3872
--- /dev/null
+++ b/theories/ZArith/BinInt.v
@@ -0,0 +1,1038 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: BinInt.v,v 1.5.2.1 2004/07/16 19:31:20 herbelin Exp $ i*)
+
+(***********************************************************)
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
+(***********************************************************)
+
+Require Export BinPos.
+Require Export Pnat.
+Require Import BinNat.
+Require Import Plus.
+Require Import Mult.
+(**********************************************************************)
+(** Binary integer numbers *)
+
+Inductive Z : Set :=
+  | Z0 : Z
+  | Zpos : positive -> Z
+  | Zneg : positive -> Z.
+
+(** Declare Scope Z_scope with Key Z *)
+Delimit Scope Z_scope with Z.
+
+(** Automatically open scope positive_scope for the constructors of Z *)
+Bind Scope Z_scope with Z.
+Arguments Scope Zpos [positive_scope].
+Arguments Scope Zneg [positive_scope].
+
+(** Subtraction of positive into Z *)
+
+Definition Zdouble_plus_one (x:Z) :=
+  match x with
+  | Z0 => Zpos 1
+  | Zpos p => Zpos (xI p)
+  | Zneg p => Zneg (Pdouble_minus_one p)
+  end.
+
+Definition Zdouble_minus_one (x:Z) :=
+  match x with
+  | Z0 => Zneg 1
+  | Zneg p => Zneg (xI p)
+  | Zpos p => Zpos (Pdouble_minus_one p)
+  end.
+
+Definition Zdouble (x:Z) :=
+  match x with
+  | Z0 => Z0
+  | Zpos p => Zpos (xO p)
+  | Zneg p => Zneg (xO p)
+  end.
+
+Fixpoint ZPminus (x y:positive) {struct y} : Z :=
+  match x, y with
+  | xI x', xI y' => Zdouble (ZPminus x' y')
+  | xI x', xO y' => Zdouble_plus_one (ZPminus x' y')
+  | xI x', xH => Zpos (xO x')
+  | xO x', xI y' => Zdouble_minus_one (ZPminus x' y')
+  | xO x', xO y' => Zdouble (ZPminus x' y')
+  | xO x', xH => Zpos (Pdouble_minus_one x')
+  | xH, xI y' => Zneg (xO y')
+  | xH, xO y' => Zneg (Pdouble_minus_one y')
+  | xH, xH => Z0
+  end.
+
+(** Addition on integers *)
+
+Definition Zplus (x y:Z) :=
+  match x, y with
+  | Z0, y => y
+  | x, Z0 => x
+  | Zpos x', Zpos y' => Zpos (x' + y')
+  | Zpos x', Zneg y' =>
+      match (x' ?= y')%positive Eq with
+      | Eq => Z0
+      | Lt => Zneg (y' - x')
+      | Gt => Zpos (x' - y')
+      end
+  | Zneg x', Zpos y' =>
+      match (x' ?= y')%positive Eq with
+      | Eq => Z0
+      | Lt => Zpos (y' - x')
+      | Gt => Zneg (x' - y')
+      end
+  | Zneg x', Zneg y' => Zneg (x' + y')
+  end.
+
+Infix "+" := Zplus : Z_scope.
+
+(** Opposite *)
+
+Definition Zopp (x:Z) :=
+  match x with
+  | Z0 => Z0
+  | Zpos x => Zneg x
+  | Zneg x => Zpos x
+  end.
+
+Notation "- x" := (Zopp x) : Z_scope.
+
+(** Successor on integers *)
+
+Definition Zsucc (x:Z) := (x + Zpos 1)%Z.
+
+(** Predecessor on integers *)
+
+Definition Zpred (x:Z) := (x + Zneg 1)%Z.
+
+(** Subtraction on integers *)
+
+Definition Zminus (m n:Z) := (m + - n)%Z.
+
+Infix "-" := Zminus : Z_scope.
+
+(** Multiplication on integers *)
+
+Definition Zmult (x y:Z) :=
+  match x, y with
+  | Z0, _ => Z0
+  | _, Z0 => Z0
+  | Zpos x', Zpos y' => Zpos (x' * y')
+  | Zpos x', Zneg y' => Zneg (x' * y')
+  | Zneg x', Zpos y' => Zneg (x' * y')
+  | Zneg x', Zneg y' => Zpos (x' * y')
+  end.
+
+Infix "*" := Zmult : Z_scope.
+
+(** Comparison of integers *)
+
+Definition Zcompare (x y:Z) :=
+  match x, y with
+  | Z0, Z0 => Eq
+  | Z0, Zpos y' => Lt
+  | Z0, Zneg y' => Gt
+  | Zpos x', Z0 => Gt
+  | Zpos x', Zpos y' => (x' ?= y')%positive Eq
+  | Zpos x', Zneg y' => Gt
+  | Zneg x', Z0 => Lt
+  | Zneg x', Zpos y' => Lt
+  | Zneg x', Zneg y' => CompOpp ((x' ?= y')%positive Eq)
+  end.
+
+Infix "?=" := Zcompare (at level 70, no associativity) : Z_scope.
+
+Ltac elim_compare com1 com2 :=
+  case (Dcompare (com1 ?= com2)%Z);
+   [ idtac | let x := fresh "H" in
+             (intro x; case x; clear x) ].
+
+(** Sign function *)
+
+Definition Zsgn (z:Z) : Z :=
+  match z with
+  | Z0 => Z0
+  | Zpos p => Zpos 1
+  | Zneg p => Zneg 1
+  end.
+
+(** Direct, easier to handle variants of successor and addition *)
+
+Definition Zsucc' (x:Z) :=
+  match x with
+  | Z0 => Zpos 1
+  | Zpos x' => Zpos (Psucc x')
+  | Zneg x' => ZPminus 1 x'
+  end.
+
+Definition Zpred' (x:Z) :=
+  match x with
+  | Z0 => Zneg 1
+  | Zpos x' => ZPminus x' 1
+  | Zneg x' => Zneg (Psucc x')
+  end.
+
+Definition Zplus' (x y:Z) :=
+  match x, y with
+  | Z0, y => y
+  | x, Z0 => x
+  | Zpos x', Zpos y' => Zpos (x' + y')
+  | Zpos x', Zneg y' => ZPminus x' y'
+  | Zneg x', Zpos y' => ZPminus y' x'
+  | Zneg x', Zneg y' => Zneg (x' + y')
+  end.
+
+Open Local Scope Z_scope.
+
+(**********************************************************************)
+(** Inductive specification of Z *)
+
+Theorem Zind :
+ forall P:Z -> Prop,
+   P Z0 ->
+   (forall x:Z, P x -> P (Zsucc' x)) ->
+   (forall x:Z, P x -> P (Zpred' x)) -> forall n:Z, P n.
+Proof.
+intros P H0 Hs Hp z; destruct z.
+  assumption.
+  apply Pind with (P := fun p => P (Zpos p)).
+    change (P (Zsucc' Z0)) in |- *; apply Hs; apply H0.
+    intro n; exact (Hs (Zpos n)).
+  apply Pind with (P := fun p => P (Zneg p)).
+    change (P (Zpred' Z0)) in |- *; apply Hp; apply H0.
+    intro n; exact (Hp (Zneg n)).
+Qed.
+
+(**********************************************************************)
+(** Properties of opposite on binary integer numbers *)
+
+Theorem Zopp_neg : forall p:positive, - Zneg p = Zpos p.
+Proof.
+reflexivity.
+Qed.
+
+(** [opp] is involutive *)
+
+Theorem Zopp_involutive : forall n:Z, - - n = n.
+Proof.
+intro x; destruct x; reflexivity.
+Qed.
+
+(** Injectivity of the opposite *)
+
+Theorem Zopp_inj : forall n m:Z, - n = - m -> n = m.
+Proof.
+intros x y; case x; case y; simpl in |- *; intros;
+ [ trivial
+ | discriminate H
+ | discriminate H
+ | discriminate H
+ | simplify_eq H; intro E; rewrite E; trivial
+ | discriminate H
+ | discriminate H
+ | discriminate H
+ | simplify_eq H; intro E; rewrite E; trivial ].
+Qed.
+
+(**********************************************************************)
+(* Properties of the direct definition of successor and predecessor *)
+
+Lemma Zpred'_succ' : forall n:Z, Zpred' (Zsucc' n) = n.
+Proof.
+intro x; destruct x; simpl in |- *.
+  reflexivity.
+destruct p; simpl in |- *; try rewrite Pdouble_minus_one_o_succ_eq_xI;
+ reflexivity.
+destruct p; simpl in |- *; try rewrite Psucc_o_double_minus_one_eq_xO;
+ reflexivity.
+Qed.
+
+Lemma Zsucc'_discr : forall n:Z, n <> Zsucc' n.
+Proof.
+intro x; destruct x; simpl in |- *.
+  discriminate.
+  injection; apply Psucc_discr.
+  destruct p; simpl in |- *.
+    discriminate.
+    intro H; symmetry  in H; injection H; apply double_moins_un_xO_discr.
+    discriminate.
+Qed.
+
+(**********************************************************************)
+(** Other properties of binary integer numbers *)
+
+Lemma ZL0 : 2%nat = (1 + 1)%nat.
+Proof.
+reflexivity.
+Qed.
+
+(**********************************************************************)
+(** Properties of the addition on integers *)
+
+(** zero is left neutral for addition *)
+
+Theorem Zplus_0_l : forall n:Z, Z0 + n = n.
+Proof.
+intro x; destruct x; reflexivity.
+Qed.
+
+(** zero is right neutral for addition *)
+
+Theorem Zplus_0_r : forall n:Z, n + Z0 = n.
+Proof.
+intro x; destruct x; reflexivity.
+Qed.
+
+(** addition is commutative *)
+
+Theorem Zplus_comm : forall n m:Z, n + m = m + n.
+Proof.
+intro x; induction x as [| p| p]; intro y; destruct y as [| q| q];
+ simpl in |- *; try reflexivity.
+  rewrite Pplus_comm; reflexivity.
+  rewrite ZC4; destruct ((q ?= p)%positive Eq); reflexivity.
+  rewrite ZC4; destruct ((q ?= p)%positive Eq); reflexivity.
+  rewrite Pplus_comm; reflexivity.
+Qed.
+
+(** opposite distributes over addition *)
+
+Theorem Zopp_plus_distr : forall n m:Z, - (n + m) = - n + - m.
+Proof.
+intro x; destruct x as [| p| p]; intro y; destruct y as [| q| q];
+ simpl in |- *; reflexivity || destruct ((p ?= q)%positive Eq); 
+ reflexivity.
+Qed.
+
+(** opposite is inverse for addition *)
+
+Theorem Zplus_opp_r : forall n:Z, n + - n = Z0.
+Proof.
+intro x; destruct x as [| p| p]; simpl in |- *;
+ [ reflexivity
+ | rewrite (Pcompare_refl p); reflexivity
+ | rewrite (Pcompare_refl p); reflexivity ].
+Qed.
+
+Theorem Zplus_opp_l : forall n:Z, - n + n = Z0.
+Proof.
+intro; rewrite Zplus_comm; apply Zplus_opp_r.
+Qed.
+
+Hint Local Resolve Zplus_0_l Zplus_0_r.
+
+(** addition is associative *)
+
+Lemma weak_assoc :
+ forall (p q:positive) (n:Z), Zpos p + (Zpos q + n) = Zpos p + Zpos q + n.
+Proof.
+intros x y z'; case z';
+ [ auto with arith
+ | intros z; simpl in |- *; rewrite Pplus_assoc; auto with arith
+ | intros z; simpl in |- *; ElimPcompare y z; intros E0; rewrite E0;
+    ElimPcompare (x + y)%positive z; intros E1; rewrite E1;
+    [ absurd ((x + y ?= z)%positive Eq = Eq);
+       [  (* Case 1 *)
+          rewrite nat_of_P_gt_Gt_compare_complement_morphism;
+          [ discriminate
+          | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0);
+             elim (ZL4 x); intros k E2; rewrite E2; 
+             simpl in |- *; unfold gt, lt in |- *; 
+             apply le_n_S; apply le_plus_r ]
+       | assumption ]
+    | absurd ((x + y ?= z)%positive Eq = Lt);
+       [  (* Case 2 *)
+          rewrite nat_of_P_gt_Gt_compare_complement_morphism;
+          [ discriminate
+          | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0);
+             elim (ZL4 x); intros k E2; rewrite E2; 
+             simpl in |- *; unfold gt, lt in |- *; 
+             apply le_n_S; apply le_plus_r ]
+       | assumption ]
+    | rewrite (Pcompare_Eq_eq y z E0);
+        (* Case 3 *)
+       elim (Pminus_mask_Gt (x + z) z);
+       [ intros t H; elim H; intros H1 H2; elim H2; intros H3 H4;
+          unfold Pminus in |- *; rewrite H1; cut (x = t);
+          [ intros E; rewrite E; auto with arith
+          | apply Pplus_reg_r with (r := z); rewrite <- H3;
+             rewrite Pplus_comm; trivial with arith ]
+       | pattern z at 1 in |- *; rewrite <- (Pcompare_Eq_eq y z E0);
+          assumption ]
+    | elim (Pminus_mask_Gt z y);
+       [  (* Case 4 *)
+          intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
+          unfold Pminus at 1 in |- *; rewrite H1; cut (x = k);
+          [ intros E; rewrite E; rewrite (Pcompare_refl k);
+             trivial with arith
+          | apply Pplus_reg_r with (r := y); rewrite (Pplus_comm k y);
+             rewrite H3; apply Pcompare_Eq_eq; assumption ]
+       | apply ZC2; assumption ]
+    | elim (Pminus_mask_Gt z y);
+       [  (* Case 5 *)
+          intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
+          unfold Pminus at 1 3 5 in |- *; rewrite H1;
+          cut ((x ?= k)%positive Eq = Lt);
+          [ intros E2; rewrite E2; elim (Pminus_mask_Gt k x);
+             [ intros i H5; elim H5; intros H6 H7; elim H7; intros H8 H9;
+                elim (Pminus_mask_Gt z (x + y));
+                [ intros j H10; elim H10; intros H11 H12; elim H12;
+                   intros H13 H14; unfold Pminus in |- *; 
+                   rewrite H6; rewrite H11; cut (i = j);
+                   [ intros E; rewrite E; auto with arith
+                   | apply (Pplus_reg_l (x + y)); rewrite H13;
+                      rewrite (Pplus_comm x y); rewrite <- Pplus_assoc;
+                      rewrite H8; assumption ]
+                | apply ZC2; assumption ]
+             | apply ZC2; assumption ]
+          | apply nat_of_P_lt_Lt_compare_complement_morphism;
+             apply plus_lt_reg_l with (p := nat_of_P y);
+             do 2 rewrite <- nat_of_P_plus_morphism;
+             apply nat_of_P_lt_Lt_compare_morphism; 
+             rewrite H3; rewrite Pplus_comm; assumption ]
+       | apply ZC2; assumption ]
+    | elim (Pminus_mask_Gt z y);
+       [  (* Case 6 *)
+          intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
+          elim (Pminus_mask_Gt (x + y) z);
+          [ intros i H5; elim H5; intros H6 H7; elim H7; intros H8 H9;
+             unfold Pminus in |- *; rewrite H1; rewrite H6;
+             cut ((x ?= k)%positive Eq = Gt);
+             [ intros H10; elim (Pminus_mask_Gt x k H10); intros j H11;
+                elim H11; intros H12 H13; elim H13; 
+                intros H14 H15; rewrite H10; rewrite H12; 
+                cut (i = j);
+                [ intros H16; rewrite H16; auto with arith
+                | apply (Pplus_reg_l (z + k)); rewrite <- (Pplus_assoc z k j);
+                   rewrite H14; rewrite (Pplus_comm z k);
+                   rewrite <- Pplus_assoc; rewrite H8;
+                   rewrite (Pplus_comm x y); rewrite Pplus_assoc;
+                   rewrite (Pplus_comm k y); rewrite H3; 
+                   trivial with arith ]
+             | apply nat_of_P_gt_Gt_compare_complement_morphism;
+                unfold lt, gt in |- *;
+                apply plus_lt_reg_l with (p := nat_of_P y);
+                do 2 rewrite <- nat_of_P_plus_morphism;
+                apply nat_of_P_lt_Lt_compare_morphism; 
+                rewrite H3; rewrite Pplus_comm; apply ZC1; 
+                assumption ]
+          | assumption ]
+       | apply ZC2; assumption ]
+    | absurd ((x + y ?= z)%positive Eq = Eq);
+       [  (* Case 7 *)
+          rewrite nat_of_P_gt_Gt_compare_complement_morphism;
+          [ discriminate
+          | rewrite nat_of_P_plus_morphism; unfold gt in |- *;
+             apply lt_le_trans with (m := nat_of_P y);
+             [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
+             | apply le_plus_r ] ]
+       | assumption ]
+    | absurd ((x + y ?= z)%positive Eq = Lt);
+       [  (* Case 8 *)
+          rewrite nat_of_P_gt_Gt_compare_complement_morphism;
+          [ discriminate
+          | unfold gt in |- *; apply lt_le_trans with (m := nat_of_P y);
+             [ exact (nat_of_P_gt_Gt_compare_morphism y z E0)
+             | rewrite nat_of_P_plus_morphism; apply le_plus_r ] ]
+       | assumption ]
+    | elim Pminus_mask_Gt with (1 := E0); intros k H1;
+        (* Case 9 *)
+       elim Pminus_mask_Gt with (1 := E1); intros i H2; 
+       elim H1; intros H3 H4; elim H4; intros H5 H6; 
+       elim H2; intros H7 H8; elim H8; intros H9 H10; 
+       unfold Pminus in |- *; rewrite H3; rewrite H7;
+       cut ((x + k)%positive = i);
+       [ intros E; rewrite E; auto with arith
+       | apply (Pplus_reg_l z); rewrite (Pplus_comm x k); rewrite Pplus_assoc;
+          rewrite H5; rewrite H9; rewrite Pplus_comm; 
+          trivial with arith ] ] ].
+Qed.
+
+Hint Local Resolve weak_assoc.
+
+Theorem Zplus_assoc : forall n m p:Z, n + (m + p) = n + m + p.
+Proof.
+intros x y z; case x; case y; case z; auto with arith; intros;
+ [ rewrite (Zplus_comm (Zneg p0)); rewrite weak_assoc;
+    rewrite (Zplus_comm (Zpos p1 + Zneg p0)); rewrite weak_assoc;
+    rewrite (Zplus_comm (Zpos p1)); trivial with arith
+ | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
+    rewrite Zplus_comm; rewrite <- weak_assoc;
+    rewrite (Zplus_comm (- Zpos p1));
+    rewrite (Zplus_comm (Zpos p0 + - Zpos p1)); rewrite (weak_assoc p);
+    rewrite weak_assoc; rewrite (Zplus_comm (Zpos p0)); 
+    trivial with arith
+ | rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0) (Zpos p));
+    rewrite <- weak_assoc; rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0));
+    trivial with arith
+ | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
+    rewrite (Zplus_comm (- Zpos p0)); rewrite weak_assoc;
+    rewrite (Zplus_comm (Zpos p1 + - Zpos p0)); rewrite weak_assoc;
+    rewrite (Zplus_comm (Zpos p)); trivial with arith
+ | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
+    apply weak_assoc
+ | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
+    apply weak_assoc ].
+Qed.
+
+
+Lemma Zplus_assoc_reverse : forall n m p:Z, n + m + p = n + (m + p).
+Proof.
+intros; symmetry  in |- *; apply Zplus_assoc.
+Qed.
+
+(** Associativity mixed with commutativity *)
+
+Theorem Zplus_permute : forall n m p:Z, n + (m + p) = m + (n + p).
+Proof.
+intros n m p; rewrite Zplus_comm; rewrite <- Zplus_assoc;
+ rewrite (Zplus_comm p n); trivial with arith.
+Qed.
+
+(** addition simplifies *)
+
+Theorem Zplus_reg_l : forall n m p:Z, n + m = n + p -> m = p.
+intros n m p H; cut (- n + (n + m) = - n + (n + p));
+ [ do 2 rewrite Zplus_assoc; rewrite (Zplus_comm (- n) n);
+    rewrite Zplus_opp_r; simpl in |- *; trivial with arith
+ | rewrite H; trivial with arith ].
+Qed.
+
+(** addition and successor permutes *)
+
+Lemma Zplus_succ_l : forall n m:Z, Zsucc n + m = Zsucc (n + m).
+Proof.
+intros x y; unfold Zsucc in |- *; rewrite (Zplus_comm (x + y));
+ rewrite Zplus_assoc; rewrite (Zplus_comm (Zpos 1)); 
+ trivial with arith.
+Qed.
+
+Lemma Zplus_succ_r : forall n m:Z, Zsucc (n + m) = n + Zsucc m.
+Proof.
+intros n m; unfold Zsucc in |- *; rewrite Zplus_assoc; trivial with arith.
+Qed.
+
+Lemma Zplus_succ_comm : forall n m:Z, Zsucc n + m = n + Zsucc m.
+Proof.
+unfold Zsucc in |- *; intros n m; rewrite <- Zplus_assoc;
+ rewrite (Zplus_comm (Zpos 1)); trivial with arith.
+Qed.
+
+(** Misc properties, usually redundant or non natural *)
+
+Lemma Zplus_0_r_reverse : forall n:Z, n = n + Z0.
+Proof.
+symmetry  in |- *; apply Zplus_0_r.
+Qed.
+
+Lemma Zplus_0_simpl_l : forall n m:Z, n + Z0 = m -> n = m.
+Proof.
+intros n m; rewrite Zplus_0_r; intro; assumption.
+Qed.
+
+Lemma Zplus_0_simpl_l_reverse : forall n m:Z, n = m + Z0 -> n = m.
+Proof.
+intros n m; rewrite Zplus_0_r; intro; assumption.
+Qed.
+
+Lemma Zplus_eq_compat : forall n m p q:Z, n = m -> p = q -> n + p = m + q.
+Proof.
+intros; rewrite H; rewrite H0; reflexivity.
+Qed.
+
+Lemma Zplus_opp_expand : forall n m p:Z, n + - m = n + - p + (p + - m).
+Proof.
+intros x y z.
+rewrite <- (Zplus_assoc x).
+rewrite (Zplus_assoc (- z)).
+rewrite Zplus_opp_l.
+reflexivity.
+Qed.
+
+(**********************************************************************)
+(** Properties of successor and predecessor on binary integer numbers *)
+
+Theorem Zsucc_discr : forall n:Z, n <> Zsucc n.
+Proof.
+intros n; cut (Z0 <> Zpos 1);
+ [ unfold not in |- *; intros H1 H2; apply H1; apply (Zplus_reg_l n);
+    rewrite Zplus_0_r; exact H2
+ | discriminate ].
+Qed.
+
+Theorem Zpos_succ_morphism :
+ forall p:positive, Zpos (Psucc p) = Zsucc (Zpos p).
+Proof.
+intro; rewrite Pplus_one_succ_r; unfold Zsucc in |- *; simpl in |- *;
+ trivial with arith.
+Qed.
+
+(** successor and predecessor are inverse functions *)
+
+Theorem Zsucc_pred : forall n:Z, n = Zsucc (Zpred n).
+Proof.
+intros n; unfold Zsucc, Zpred in |- *; rewrite <- Zplus_assoc; simpl in |- *;
+ rewrite Zplus_0_r; trivial with arith.
+Qed. 
+
+Hint Immediate Zsucc_pred: zarith.
+ 
+Theorem Zpred_succ : forall n:Z, n = Zpred (Zsucc n).
+Proof.
+intros m; unfold Zpred, Zsucc in |- *; rewrite <- Zplus_assoc; simpl in |- *;
+ rewrite Zplus_comm; auto with arith.
+Qed.
+
+Theorem Zsucc_inj : forall n m:Z, Zsucc n = Zsucc m -> n = m.
+Proof.
+intros n m H.
+change (Zneg 1 + Zpos 1 + n = Zneg 1 + Zpos 1 + m) in |- *;
+ do 2 rewrite <- Zplus_assoc; do 2 rewrite (Zplus_comm (Zpos 1));
+ unfold Zsucc in H; rewrite H; trivial with arith.
+Qed.
+ 
+(** Misc properties, usually redundant or non natural *)
+
+Lemma Zsucc_eq_compat : forall n m:Z, n = m -> Zsucc n = Zsucc m.
+Proof.
+intros n m H; rewrite H; reflexivity.
+Qed.
+
+Lemma Zsucc_inj_contrapositive : forall n m:Z, n <> m -> Zsucc n <> Zsucc m.
+Proof.
+unfold not in |- *; intros n m H1 H2; apply H1; apply Zsucc_inj; assumption.
+Qed.
+
+(**********************************************************************)
+(** Properties of subtraction on binary integer numbers *)
+
+Lemma Zminus_0_r : forall n:Z, n - Z0 = n.
+Proof.
+intro; unfold Zminus in |- *; simpl in |- *; rewrite Zplus_0_r;
+ trivial with arith.
+Qed.
+
+Lemma Zminus_0_l_reverse : forall n:Z, n = n - Z0.
+Proof.
+intro; symmetry  in |- *; apply Zminus_0_r.
+Qed.
+
+Lemma Zminus_diag : forall n:Z, n - n = Z0.
+Proof.
+intro; unfold Zminus in |- *; rewrite Zplus_opp_r; trivial with arith.
+Qed.
+
+Lemma Zminus_diag_reverse : forall n:Z, Z0 = n - n.
+Proof.
+intro; symmetry  in |- *; apply Zminus_diag.
+Qed.
+
+Lemma Zplus_minus_eq : forall n m p:Z, n = m + p -> p = n - m.
+Proof.
+intros n m p H; unfold Zminus in |- *; apply (Zplus_reg_l m);
+ rewrite (Zplus_comm m (n + - m)); rewrite <- Zplus_assoc;
+ rewrite Zplus_opp_l; rewrite Zplus_0_r; rewrite H; 
+ trivial with arith.
+Qed.
+
+Lemma Zminus_plus : forall n m:Z, n + m - n = m.
+Proof.
+intros n m; unfold Zminus in |- *; rewrite (Zplus_comm n m);
+ rewrite <- Zplus_assoc; rewrite Zplus_opp_r; apply Zplus_0_r.
+Qed.
+
+Lemma Zplus_minus : forall n m:Z, n + (m - n) = m.
+Proof.
+unfold Zminus in |- *; intros n m; rewrite Zplus_permute; rewrite Zplus_opp_r;
+ apply Zplus_0_r.
+Qed.
+
+Lemma Zminus_succ_l : forall n m:Z, Zsucc (n - m) = Zsucc n - m.
+Proof.
+intros n m; unfold Zminus, Zsucc in |- *; rewrite (Zplus_comm n (- m));
+ rewrite <- Zplus_assoc; apply Zplus_comm.
+Qed.
+
+Lemma Zminus_plus_simpl_l : forall n m p:Z, p + n - (p + m) = n - m.
+Proof.
+intros n m p; unfold Zminus in |- *; rewrite Zopp_plus_distr;
+ rewrite Zplus_assoc; rewrite (Zplus_comm p); rewrite <- (Zplus_assoc n p);
+ rewrite Zplus_opp_r; rewrite Zplus_0_r; trivial with arith.
+Qed.
+
+Lemma Zminus_plus_simpl_l_reverse : forall n m p:Z, n - m = p + n - (p + m).
+Proof.
+intros; symmetry  in |- *; apply Zminus_plus_simpl_l.
+Qed.
+
+Lemma Zminus_plus_simpl_r : forall n m p:Z, n + p - (m + p) = n - m.
+intros x y n.
+unfold Zminus in |- *.
+rewrite Zopp_plus_distr.
+rewrite (Zplus_comm (- y) (- n)).
+rewrite Zplus_assoc.
+rewrite <- (Zplus_assoc x n (- n)).
+rewrite (Zplus_opp_r n).
+rewrite <- Zplus_0_r_reverse.
+reflexivity.
+Qed.
+
+(** Misc redundant properties *)
+
+
+Lemma Zeq_minus : forall n m:Z, n = m -> n - m = Z0.
+Proof.
+intros x y H; rewrite H; symmetry  in |- *; apply Zminus_diag_reverse.
+Qed.
+
+Lemma Zminus_eq : forall n m:Z, n - m = Z0 -> n = m.
+Proof.
+intros x y H; rewrite <- (Zplus_minus y x); rewrite H; apply Zplus_0_r.
+Qed.
+
+
+(**********************************************************************)
+(** Properties of multiplication on binary integer numbers *)
+
+(** One is neutral for multiplication *)
+
+Theorem Zmult_1_l : forall n:Z, Zpos 1 * n = n.
+Proof.
+intro x; destruct x; reflexivity.
+Qed.
+
+Theorem Zmult_1_r : forall n:Z, n * Zpos 1 = n.
+Proof.
+intro x; destruct x; simpl in |- *; try rewrite Pmult_1_r; reflexivity.
+Qed.
+
+(** Zero property of multiplication *)
+
+Theorem Zmult_0_l : forall n:Z, Z0 * n = Z0.
+Proof.
+intro x; destruct x; reflexivity.
+Qed.
+
+Theorem Zmult_0_r : forall n:Z, n * Z0 = Z0.
+Proof.
+intro x; destruct x; reflexivity.
+Qed.
+
+Hint Local Resolve Zmult_0_l Zmult_0_r.
+
+Lemma Zmult_0_r_reverse : forall n:Z, Z0 = n * Z0.
+Proof.
+intro x; destruct x; reflexivity.
+Qed.
+
+(** Commutativity of multiplication *)
+
+Theorem Zmult_comm : forall n m:Z, n * m = m * n.
+Proof.
+intros x y; destruct x as [| p| p]; destruct y as [| q| q]; simpl in |- *;
+ try rewrite (Pmult_comm p q); reflexivity.
+Qed.
+
+(** Associativity of multiplication *)
+
+Theorem Zmult_assoc : forall n m p:Z, n * (m * p) = n * m * p.
+Proof.
+intros x y z; destruct x; destruct y; destruct z; simpl in |- *;
+ try rewrite Pmult_assoc; reflexivity.
+Qed.
+
+Lemma Zmult_assoc_reverse : forall n m p:Z, n * m * p = n * (m * p).
+Proof.
+intros n m p; rewrite Zmult_assoc; trivial with arith.
+Qed.
+
+(** Associativity mixed with commutativity *)
+
+Theorem Zmult_permute : forall n m p:Z, n * (m * p) = m * (n * p).
+Proof.
+intros x y z; rewrite (Zmult_assoc y x z); rewrite (Zmult_comm y x).
+apply Zmult_assoc.
+Qed.
+
+(** Z is integral *)
+
+Theorem Zmult_integral_l : forall n m:Z, n <> Z0 -> m * n = Z0 -> m = Z0.
+Proof.
+intros x y; destruct x as [| p| p].
+  intro H; absurd (Z0 = Z0); trivial.
+  intros _ H; destruct y as [| q| q]; reflexivity || discriminate.
+  intros _ H; destruct y as [| q| q]; reflexivity || discriminate.
+Qed.
+
+
+Theorem Zmult_integral : forall n m:Z, n * m = Z0 -> n = Z0 \/ m = Z0.
+Proof.
+intros x y; destruct x; destruct y; auto; simpl in |- *; intro H;
+ discriminate H.
+Qed.
+
+
+Lemma Zmult_1_inversion_l :
+ forall n m:Z, n * m = Zpos 1 -> n = Zpos 1 \/ n = Zneg 1.
+Proof.
+intros x y; destruct x as [| p| p]; intro; [ discriminate | left | right ];
+ (destruct y as [| q| q]; try discriminate; simpl in H; injection H; clear H;
+   intro H; rewrite Pmult_1_inversion_l with (1 := H); 
+   reflexivity).
+Qed.
+
+(** Multiplication and Opposite *)
+
+Theorem Zopp_mult_distr_l : forall n m:Z, - (n * m) = - n * m.
+Proof.
+intros x y; destruct x; destruct y; reflexivity.
+Qed.
+
+Theorem Zopp_mult_distr_r : forall n m:Z, - (n * m) = n * - m.
+intros x y; rewrite (Zmult_comm x y); rewrite Zopp_mult_distr_l;
+ apply Zmult_comm.
+Qed.
+
+Lemma Zopp_mult_distr_l_reverse : forall n m:Z, - n * m = - (n * m).
+Proof.
+intros x y; symmetry  in |- *; apply Zopp_mult_distr_l.
+Qed.
+
+Theorem Zmult_opp_comm : forall n m:Z, - n * m = n * - m.
+intros x y; rewrite Zopp_mult_distr_l_reverse; rewrite Zopp_mult_distr_r;
+ trivial with arith.
+Qed.
+
+Theorem Zmult_opp_opp : forall n m:Z, - n * - m = n * m.
+Proof.
+intros x y; destruct x; destruct y; reflexivity.
+Qed.
+
+Theorem Zopp_eq_mult_neg_1 : forall n:Z, - n = n * Zneg 1.
+intro x; induction x; intros; rewrite Zmult_comm; auto with arith.
+Qed.
+
+(** Distributivity of multiplication over addition *)
+
+Lemma weak_Zmult_plus_distr_r :
+ forall (p:positive) (n m:Z), Zpos p * (n + m) = Zpos p * n + Zpos p * m.
+Proof.
+intros x y' z'; case y'; case z'; auto with arith; intros y z;
+ (simpl in |- *; rewrite Pmult_plus_distr_l; trivial with arith) ||
+   (simpl in |- *; ElimPcompare z y; intros E0; rewrite E0;
+     [ rewrite (Pcompare_Eq_eq z y E0); rewrite (Pcompare_refl (x * y));
+        trivial with arith
+     | cut ((x * z ?= x * y)%positive Eq = Lt);
+        [ intros E; rewrite E; rewrite Pmult_minus_distr_l;
+           [ trivial with arith | apply ZC2; assumption ]
+        | apply nat_of_P_lt_Lt_compare_complement_morphism;
+           do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); 
+           intros h H1; rewrite H1; apply mult_S_lt_compat_l;
+           exact (nat_of_P_lt_Lt_compare_morphism z y E0) ]
+     | cut ((x * z ?= x * y)%positive Eq = Gt);
+        [ intros E; rewrite E; rewrite Pmult_minus_distr_l; auto with arith
+        | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *;
+           do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); 
+           intros h H1; rewrite H1; apply mult_S_lt_compat_l;
+           exact (nat_of_P_gt_Gt_compare_morphism z y E0) ] ]).
+Qed.
+
+Theorem Zmult_plus_distr_r : forall n m p:Z, n * (m + p) = n * m + n * p.
+Proof.
+intros x y z; case x;
+ [ auto with arith
+ | intros x'; apply weak_Zmult_plus_distr_r
+ | intros p; apply Zopp_inj; rewrite Zopp_plus_distr;
+    do 3 rewrite <- Zopp_mult_distr_l_reverse; rewrite Zopp_neg;
+    apply weak_Zmult_plus_distr_r ].
+Qed.
+
+Theorem Zmult_plus_distr_l : forall n m p:Z, (n + m) * p = n * p + m * p.
+Proof.
+intros n m p; rewrite Zmult_comm; rewrite Zmult_plus_distr_r;
+ do 2 rewrite (Zmult_comm p); trivial with arith.
+Qed.
+
+(** Distributivity of multiplication over subtraction *)
+
+Lemma Zmult_minus_distr_r : forall n m p:Z, (n - m) * p = n * p - m * p.
+Proof.
+intros x y z; unfold Zminus in |- *.
+rewrite <- Zopp_mult_distr_l_reverse.
+apply Zmult_plus_distr_l.
+Qed.
+
+ 
+Lemma Zmult_minus_distr_l : forall n m p:Z, p * (n - m) = p * n - p * m.
+Proof.
+intros x y z; rewrite (Zmult_comm z (x - y)).
+rewrite (Zmult_comm z x).
+rewrite (Zmult_comm z y).
+apply Zmult_minus_distr_r.
+Qed.
+
+(** Simplification of multiplication for non-zero integers *)
+
+Lemma Zmult_reg_l : forall n m p:Z, p <> Z0 -> p * n = p * m -> n = m.
+Proof.
+intros x y z H H0.
+generalize (Zeq_minus _ _ H0).
+intro.
+apply Zminus_eq.
+rewrite <- Zmult_minus_distr_l in H1.
+clear H0; destruct (Zmult_integral _ _ H1).
+contradiction.
+trivial.
+Qed.
+
+Lemma Zmult_reg_r : forall n m p:Z, p <> Z0 -> n * p = m * p -> n = m.
+Proof.
+intros x y z Hz.
+rewrite (Zmult_comm x z).
+rewrite (Zmult_comm y z).
+intro; apply Zmult_reg_l with z; assumption.
+Qed.
+
+(** Addition and multiplication by 2 *)
+
+Lemma Zplus_diag_eq_mult_2 : forall n:Z, n + n = n * Zpos 2.
+Proof.
+intros x; pattern x at 1 2 in |- *; rewrite <- (Zmult_1_r x);
+ rewrite <- Zmult_plus_distr_r; reflexivity.
+Qed.
+
+(** Multiplication and successor *)
+
+Lemma Zmult_succ_r : forall n m:Z, n * Zsucc m = n * m + n.
+Proof.
+intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_r;
+ rewrite (Zmult_comm n (Zpos 1)); rewrite Zmult_1_l; 
+ trivial with arith.
+Qed.
+
+Lemma Zmult_succ_r_reverse : forall n m:Z, n * m + n = n * Zsucc m.
+Proof.
+intros; symmetry  in |- *; apply Zmult_succ_r.
+Qed.
+
+Lemma Zmult_succ_l : forall n m:Z, Zsucc n * m = n * m + m.
+Proof.
+intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_l;
+ rewrite Zmult_1_l; trivial with arith.
+Qed.
+
+Lemma Zmult_succ_l_reverse : forall n m:Z, n * m + m = Zsucc n * m.
+Proof.
+intros; symmetry  in |- *; apply Zmult_succ_l.
+Qed.
+
+(** Misc redundant properties *)
+
+Lemma Z_eq_mult : forall n m:Z, m = Z0 -> m * n = Z0.
+intros x y H; rewrite H; auto with arith.
+Qed.
+
+(**********************************************************************)
+(** Relating binary positive numbers and binary integers *)
+
+Lemma Zpos_xI : forall p:positive, Zpos (xI p) = Zpos 2 * Zpos p + Zpos 1.
+Proof.
+intro; apply refl_equal.
+Qed.
+
+Lemma Zpos_xO : forall p:positive, Zpos (xO p) = Zpos 2 * Zpos p.
+Proof.
+intro; apply refl_equal.
+Qed.
+
+Lemma Zneg_xI : forall p:positive, Zneg (xI p) = Zpos 2 * Zneg p - Zpos 1.
+Proof.
+intro; apply refl_equal.
+Qed.
+
+Lemma Zneg_xO : forall p:positive, Zneg (xO p) = Zpos 2 * Zneg p.
+Proof.
+reflexivity.
+Qed.
+
+Lemma Zpos_plus_distr : forall p q:positive, Zpos (p + q) = Zpos p + Zpos q.
+Proof.
+intros p p'; destruct p;
+ [ destruct p' as [p0| p0| ]
+ | destruct p' as [p0| p0| ]
+ | destruct p' as [p| p| ] ]; reflexivity.
+Qed.
+
+Lemma Zneg_plus_distr : forall p q:positive, Zneg (p + q) = Zneg p + Zneg q.
+Proof.
+intros p p'; destruct p;
+ [ destruct p' as [p0| p0| ]
+ | destruct p' as [p0| p0| ]
+ | destruct p' as [p| p| ] ]; reflexivity.
+Qed.
+
+(**********************************************************************)
+(** Order relations *)
+
+Definition Zlt (x y:Z) := (x ?= y) = Lt.
+Definition Zgt (x y:Z) := (x ?= y) = Gt.
+Definition Zle (x y:Z) := (x ?= y) <> Gt.
+Definition Zge (x y:Z) := (x ?= y) <> Lt.
+Definition Zne (x y:Z) := x <> y.
+
+Infix "<=" := Zle : Z_scope.
+Infix "<" := Zlt : Z_scope.
+Infix ">=" := Zge : Z_scope.
+Infix ">" := Zgt : Z_scope.
+
+Notation "x <= y <= z" := (x <= y /\ y <= z) : Z_scope.
+Notation "x <= y < z" := (x <= y /\ y < z) : Z_scope.
+Notation "x < y < z" := (x < y /\ y < z) : Z_scope.
+Notation "x < y <= z" := (x < y /\ y <= z) : Z_scope.
+
+(**********************************************************************)
+(** Absolute value on integers *)
+
+Definition Zabs_nat (x:Z) : nat :=
+  match x with
+  | Z0 => 0%nat
+  | Zpos p => nat_of_P p
+  | Zneg p => nat_of_P p
+  end.
+
+Definition Zabs (z:Z) : Z :=
+  match z with
+  | Z0 => Z0
+  | Zpos p => Zpos p
+  | Zneg p => Zpos p
+  end.
+
+(**********************************************************************)
+(** From [nat] to [Z] *)
+
+Definition Z_of_nat (x:nat) :=
+  match x with
+  | O => Z0
+  | S y => Zpos (P_of_succ_nat y)
+  end.
+
+Require Import BinNat.
+
+Definition Zabs_N (z:Z) :=
+  match z with
+  | Z0 => 0%N
+  | Zpos p => Npos p
+  | Zneg p => Npos p
+  end.
+
+Definition Z_of_N (x:N) := match x with
+                           | N0 => Z0
+                           | Npos p => Zpos p
+                           end.
\ No newline at end of file
diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v
new file mode 100644
index 00000000..069ddd42
--- /dev/null
+++ b/theories/ZArith/Wf_Z.v
@@ -0,0 +1,204 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Wf_Z.v,v 1.20.2.1 2004/07/16 19:31:20 herbelin Exp $ i*)
+
+Require Import BinInt.
+Require Import Zcompare.
+Require Import Zorder.
+Require Import Znat.
+Require Import Zmisc.
+Require Import Wf_nat.
+Open Local Scope Z_scope.
+
+(** Our purpose is to write an induction shema for {0,1,2,...}
+  similar to the [nat] schema (Theorem [Natlike_rec]). For that the
+  following implications will be used :
+<<
+ (n:nat)(Q n)==(n:nat)(P (inject_nat n)) ===> (x:Z)`x > 0) -> (P x)
+
+       	     /\
+             ||
+             ||
+
+  (Q O) (n:nat)(Q n)->(Q (S n)) <=== (P 0) (x:Z) (P x) -> (P (Zs x))
+
+      	       	       	       	<=== (inject_nat (S n))=(Zs (inject_nat n))
+
+      	       	       	       	<=== inject_nat_complete
+>>
+  Then the  diagram will be closed and the theorem proved. *)
+
+Lemma Z_of_nat_complete :
+ forall x:Z, 0 <= x ->  exists n : nat, x = Z_of_nat n.
+intro x; destruct x; intros;
+ [ exists 0%nat; auto with arith
+ | specialize (ZL4 p); intros Hp; elim Hp; intros; exists (S x); intros;
+    simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x); 
+    intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos);
+    apply nat_of_P_inj; auto with arith
+ | absurd (0 <= Zneg p);
+    [ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *;
+       auto with arith
+    | assumption ] ].
+Qed.
+
+Lemma ZL4_inf : forall y:positive, {h : nat | nat_of_P y = S h}.
+intro y; induction y as [p H| p H1| ];
+ [ elim H; intros x H1; exists (S x + S x)%nat; unfold nat_of_P in |- *;
+    simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism;
+    unfold nat_of_P in H1; rewrite H1; auto with arith
+ | elim H1; intros x H2; exists (x + S x)%nat; unfold nat_of_P in |- *;
+    simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism;
+    unfold nat_of_P in H2; rewrite H2; auto with arith
+ | exists 0%nat; auto with arith ].
+Qed.
+
+Lemma Z_of_nat_complete_inf :
+ forall x:Z, 0 <= x -> {n : nat | x = Z_of_nat n}.
+intro x; destruct x; intros;
+ [ exists 0%nat; auto with arith
+ | specialize (ZL4_inf p); intros Hp; elim Hp; intros x0 H0; exists (S x0);
+    intros; simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x0);
+    intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos);
+    apply nat_of_P_inj; auto with arith
+ | absurd (0 <= Zneg p);
+    [ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *;
+       auto with arith
+    | assumption ] ].
+Qed.
+
+Lemma Z_of_nat_prop :
+ forall P:Z -> Prop,
+   (forall n:nat, P (Z_of_nat n)) -> forall x:Z, 0 <= x -> P x.
+intros P H x H0.
+specialize (Z_of_nat_complete x H0).
+intros Hn; elim Hn; intros.
+rewrite H1; apply H.
+Qed.
+
+Lemma Z_of_nat_set :
+ forall P:Z -> Set,
+   (forall n:nat, P (Z_of_nat n)) -> forall x:Z, 0 <= x -> P x.
+intros P H x H0.
+specialize (Z_of_nat_complete_inf x H0).
+intros Hn; elim Hn; intros.
+rewrite p; apply H.
+Qed.
+
+Lemma natlike_ind :
+ forall P:Z -> Prop,
+   P 0 ->
+   (forall x:Z, 0 <= x -> P x -> P (Zsucc x)) -> forall x:Z, 0 <= x -> P x.
+intros P H H0 x H1; apply Z_of_nat_prop;
+ [ simple induction n;
+    [ simpl in |- *; assumption
+    | intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ]
+ | assumption ].
+Qed.
+
+Lemma natlike_rec :
+ forall P:Z -> Set,
+   P 0 ->
+   (forall x:Z, 0 <= x -> P x -> P (Zsucc x)) -> forall x:Z, 0 <= x -> P x.
+intros P H H0 x H1; apply Z_of_nat_set;
+ [ simple induction n;
+    [ simpl in |- *; assumption
+    | intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ]
+ | assumption ].
+Qed.
+
+Section Efficient_Rec. 
+
+(** [natlike_rec2] is the same as [natlike_rec], but with a different proof, designed 
+     to give a better extracted term. *)
+
+Let R (a b:Z) := 0 <= a /\ a < b.
+
+Let R_wf : well_founded R.
+Proof.
+set
+ (f :=
+  fun z =>
+    match z with
+    | Zpos p => nat_of_P p
+    | Z0 => 0%nat
+    | Zneg _ => 0%nat
+    end) in *.
+apply well_founded_lt_compat with f.
+unfold R, f in |- *; clear f R.
+intros x y; case x; intros; elim H; clear H.
+case y; intros; apply lt_O_nat_of_P || inversion H0.
+case y; intros; apply nat_of_P_lt_Lt_compare_morphism || inversion H0; auto.
+intros; elim H; auto.
+Qed.
+
+Lemma natlike_rec2 :
+ forall P:Z -> Type,
+   P 0 ->
+   (forall z:Z, 0 <= z -> P z -> P (Zsucc z)) -> forall z:Z, 0 <= z -> P z.
+Proof.
+intros P Ho Hrec z; pattern z in |- *;
+ apply (well_founded_induction_type R_wf).
+intro x; case x.
+trivial.
+intros.
+assert (0 <= Zpred (Zpos p)).
+apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial.
+rewrite Zsucc_pred.
+apply Hrec.
+auto.
+apply X; auto; unfold R in |- *; intuition; apply Zlt_pred.
+intros; elim H; simpl in |- *; trivial.
+Qed.
+
+(** A variant of the previous using [Zpred] instead of [Zs]. *)
+
+Lemma natlike_rec3 :
+ forall P:Z -> Type,
+   P 0 ->
+   (forall z:Z, 0 < z -> P (Zpred z) -> P z) -> forall z:Z, 0 <= z -> P z.
+Proof.
+intros P Ho Hrec z; pattern z in |- *;
+ apply (well_founded_induction_type R_wf).
+intro x; case x.
+trivial.
+intros; apply Hrec.
+unfold Zlt in |- *; trivial.
+assert (0 <= Zpred (Zpos p)).
+apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial.
+apply X; auto; unfold R in |- *; intuition; apply Zlt_pred.
+intros; elim H; simpl in |- *; trivial.
+Qed.
+
+(** A more general induction principal using [Zlt]. *)
+
+Lemma Z_lt_rec :
+ forall P:Z -> Type,
+   (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
+   forall x:Z, 0 <= x -> P x.
+Proof.
+intros P Hrec z; pattern z in |- *; apply (well_founded_induction_type R_wf).
+intro x; case x; intros.
+apply Hrec; intros.
+assert (H2 : 0 < 0).
+  apply Zle_lt_trans with y; intuition.
+inversion H2.
+firstorder.
+unfold Zle, Zcompare in H; elim H; auto.
+Defined.
+
+Lemma Z_lt_induction :
+ forall P:Z -> Prop,
+   (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
+   forall x:Z, 0 <= x -> P x.
+Proof.
+exact Z_lt_rec.
+Qed.
+
+End Efficient_Rec.
diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v
new file mode 100644
index 00000000..78295591
--- /dev/null
+++ b/theories/ZArith/ZArith.v
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: ZArith.v,v 1.5.2.1 2004/07/16 19:31:20 herbelin Exp $ i*)
+
+(** Library for manipulating integers based on binary encoding *)
+
+Require Export ZArith_base.
+
+(** Extra modules using [Omega] or [Ring]. *)
+
+Require Export Zcomplements.
+Require Export Zsqrt.
+Require Export Zpower.
+Require Export Zdiv.
+Require Export Zlogarithm.
+Require Export Zbool.
\ No newline at end of file
diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v
new file mode 100644
index 00000000..694e071e
--- /dev/null
+++ b/theories/ZArith/ZArith_base.v
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: ZArith_base.v,v 1.5.2.1 2004/07/16 19:31:20 herbelin Exp $ *)
+
+(** Library for manipulating integers based on binary encoding.
+    These are the basic modules, required by [Omega] and [Ring] for instance. 
+    The full library is [ZArith]. *)
+
+Require Export BinPos.
+Require Export BinNat.
+Require Export BinInt.
+Require Export Zcompare.
+Require Export Zorder.
+Require Export Zeven.
+Require Export Zmin.
+Require Export Zabs.
+Require Export Znat.
+Require Export auxiliary.
+Require Export ZArith_dec.
+Require Export Zbool.
+Require Export Zmisc.
+Require Export Wf_Z.
+
+Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l
+  Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l
+  Zmult_plus_distr_r: zarith.
+
+Require Export Zhints.
\ No newline at end of file
diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v
new file mode 100644
index 00000000..dbd0df6c
--- /dev/null
+++ b/theories/ZArith/ZArith_dec.v
@@ -0,0 +1,226 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: ZArith_dec.v,v 1.11.2.1 2004/07/16 19:31:20 herbelin Exp $ i*)
+
+Require Import Sumbool.
+
+Require Import BinInt.
+Require Import Zorder.
+Require Import Zcompare.
+Open Local Scope Z_scope.
+
+Lemma Dcompare_inf : forall r:comparison, {r = Eq} + {r = Lt} + {r = Gt}.
+Proof.
+simple induction r; auto with arith. 
+Defined.
+
+Lemma Zcompare_rec :
+ forall (P:Set) (n m:Z),
+   ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P.
+Proof.
+intros P x y H1 H2 H3.
+elim (Dcompare_inf (x ?= y)).
+intro H. elim H; auto with arith. auto with arith.
+Defined.
+
+Section decidability.
+
+Variables x y : Z.
+
+(** Decidability of equality on binary integers *)
+
+Definition Z_eq_dec : {x = y} + {x <> y}.
+Proof.
+apply Zcompare_rec with (n := x) (m := y).
+intro. left. elim (Zcompare_Eq_iff_eq x y); auto with arith.
+intro H3. right. elim (Zcompare_Eq_iff_eq x y). intros H1 H2. unfold not in |- *. intro H4.
+  rewrite (H2 H4) in H3. discriminate H3.
+intro H3. right. elim (Zcompare_Eq_iff_eq x y). intros H1 H2. unfold not in |- *. intro H4.
+  rewrite (H2 H4) in H3. discriminate H3.
+Defined. 
+
+(** Decidability of order on binary integers *)
+
+Definition Z_lt_dec : {x < y} + {~ x < y}.
+Proof.
+unfold Zlt in |- *.
+apply Zcompare_rec with (n := x) (m := y); intro H.
+right. rewrite H. discriminate.
+left; assumption.
+right. rewrite H. discriminate.
+Defined.
+
+Definition Z_le_dec : {x <= y} + {~ x <= y}.
+Proof.
+unfold Zle in |- *.
+apply Zcompare_rec with (n := x) (m := y); intro H.
+left. rewrite H. discriminate.
+left. rewrite H. discriminate.
+right. tauto.
+Defined.
+
+Definition Z_gt_dec : {x > y} + {~ x > y}.
+Proof.
+unfold Zgt in |- *.
+apply Zcompare_rec with (n := x) (m := y); intro H.
+right. rewrite H. discriminate.
+right. rewrite H. discriminate.
+left; assumption.
+Defined.
+
+Definition Z_ge_dec : {x >= y} + {~ x >= y}.
+Proof.
+unfold Zge in |- *.
+apply Zcompare_rec with (n := x) (m := y); intro H.
+left. rewrite H. discriminate.
+right. tauto.
+left. rewrite H. discriminate.
+Defined.
+
+Definition Z_lt_ge_dec : {x < y} + {x >= y}.
+Proof.
+exact Z_lt_dec.
+Defined.
+
+Lemma Z_lt_le_dec : {x < y} + {y <= x}.
+Proof.
+intros.
+elim Z_lt_ge_dec.
+intros; left; assumption.
+intros; right; apply Zge_le; assumption.
+Qed.
+
+Definition Z_le_gt_dec : {x <= y} + {x > y}.
+Proof.
+elim Z_le_dec; auto with arith.
+intro. right. apply Znot_le_gt; auto with arith.
+Defined.
+
+Definition Z_gt_le_dec : {x > y} + {x <= y}.
+Proof.
+exact Z_gt_dec.
+Defined.
+
+Definition Z_ge_lt_dec : {x >= y} + {x < y}.
+Proof.
+elim Z_ge_dec; auto with arith.
+intro. right. apply Znot_ge_lt; auto with arith.
+Defined.
+
+Definition Z_le_lt_eq_dec : x <= y -> {x < y} + {x = y}.
+Proof.
+intro H.
+apply Zcompare_rec with (n := x) (m := y).
+intro. right. elim (Zcompare_Eq_iff_eq x y); auto with arith.
+intro. left. elim (Zcompare_Eq_iff_eq x y); auto with arith.
+intro H1. absurd (x > y); auto with arith.
+Defined.
+
+End decidability.
+
+(** Cotransitivity of order on binary integers *)
+
+Lemma Zlt_cotrans : forall n m:Z, n < m -> forall p:Z, {n < p} + {p < m}.
+Proof.
+ intros x y H z.
+ case (Z_lt_ge_dec x z).
+ intro.
+ left.
+ assumption.
+ intro.
+ right.
+ apply Zle_lt_trans with (m := x).
+ apply Zge_le.
+ assumption.
+ assumption.
+Defined.
+
+Lemma Zlt_cotrans_pos : forall n m:Z, 0 < n + m -> {0 < n} + {0 < m}.
+Proof.
+ intros x y H.
+ case (Zlt_cotrans 0 (x + y) H x).
+ intro.
+ left.
+ assumption.
+ intro.
+ right.
+ apply Zplus_lt_reg_l with (p := x).
+ rewrite Zplus_0_r.
+ assumption.
+Defined.
+
+Lemma Zlt_cotrans_neg : forall n m:Z, n + m < 0 -> {n < 0} + {m < 0}.
+Proof.
+ intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy;
+  [ right; apply Zplus_lt_reg_l with (p := x); rewrite Zplus_0_r | left ];
+  assumption.
+Defined.
+
+Lemma not_Zeq_inf : forall n m:Z, n <> m -> {n < m} + {m < n}.
+Proof.
+ intros x y H.
+ case Z_lt_ge_dec with x y.
+ intro.
+ left.
+ assumption.
+ intro H0.
+ generalize (Zge_le _ _ H0).
+ intro.
+ case (Z_le_lt_eq_dec _ _ H1).
+ intro.
+ right.
+ assumption.
+ intro.
+ apply False_rec.
+ apply H.
+ symmetry  in |- *.
+ assumption.
+Defined.
+
+Lemma Z_dec : forall n m:Z, {n < m} + {n > m} + {n = m}.
+Proof.
+ intros x y.
+ case (Z_lt_ge_dec x y).
+ intro H.
+ left.
+ left.
+ assumption.
+ intro H.
+ generalize (Zge_le _ _ H).
+ intro H0.
+ case (Z_le_lt_eq_dec y x H0).
+ intro H1.
+ left.
+ right.
+ apply Zlt_gt.
+ assumption.
+ intro.
+ right.
+ symmetry  in |- *.
+ assumption.
+Defined.
+
+
+Lemma Z_dec' : forall n m:Z, {n < m} + {m < n} + {n = m}.
+Proof.
+ intros x y.
+ case (Z_eq_dec x y); intro H;
+  [ right; assumption | left; apply (not_Zeq_inf _ _ H) ].
+Defined.
+
+
+
+Definition Z_zerop : forall x:Z, {x = 0} + {x <> 0}.
+Proof.
+exact (fun x:Z => Z_eq_dec x 0).
+Defined.
+
+Definition Z_notzerop (x:Z) := sumbool_not _ _ (Z_zerop x).
+
+Definition Z_noteq_dec (x y:Z) := sumbool_not _ _ (Z_eq_dec x y).
\ No newline at end of file
diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v
new file mode 100644
index 00000000..90e4c2a4
--- /dev/null
+++ b/theories/ZArith/Zabs.v
@@ -0,0 +1,128 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i $Id: Zabs.v,v 1.4.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
+
+Require Import Arith.
+Require Import BinPos.
+Require Import BinInt.
+Require Import Zorder.
+Require Import ZArith_dec.
+
+Open Local Scope Z_scope.
+
+(**********************************************************************)
+(** Properties of absolute value *)
+
+Lemma Zabs_eq : forall n:Z, 0 <= n -> Zabs n = n.
+intro x; destruct x; auto with arith.
+compute in |- *; intros; absurd (Gt = Gt); trivial with arith.
+Qed.
+
+Lemma Zabs_non_eq : forall n:Z, n <= 0 -> Zabs n = - n.
+Proof.
+intro x; destruct x; auto with arith.
+compute in |- *; intros; absurd (Gt = Gt); trivial with arith.
+Qed.
+
+Theorem Zabs_Zopp : forall n:Z, Zabs (- n) = Zabs n.
+Proof.
+intros z; case z; simpl in |- *; auto.
+Qed.
+
+(** Proving a property of the absolute value by cases *)
+
+Lemma Zabs_ind :
+ forall (P:Z -> Prop) (n:Z),
+   (n >= 0 -> P n) -> (n <= 0 -> P (- n)) -> P (Zabs n).
+Proof.
+intros P x H H0; elim (Z_lt_ge_dec x 0); intro.
+assert (x <= 0). apply Zlt_le_weak; assumption.
+rewrite Zabs_non_eq. apply H0. assumption. assumption.
+rewrite Zabs_eq. apply H; assumption. apply Zge_le. assumption.
+Qed.
+
+Theorem Zabs_intro : forall P (n:Z), P (- n) -> P n -> P (Zabs n).
+intros P z; case z; simpl in |- *; auto.
+Qed.
+
+Definition Zabs_dec : forall x:Z, {x = Zabs x} + {x = - Zabs x}.
+Proof.
+intro x; destruct x; auto with arith.
+Defined.
+
+Lemma Zabs_pos : forall n:Z, 0 <= Zabs n.
+intro x; destruct x; auto with arith; compute in |- *; intros H; inversion H.
+Qed.
+
+Theorem Zabs_eq_case : forall n m:Z, Zabs n = Zabs m -> n = m \/ n = - m.
+Proof.
+intros z1 z2; case z1; case z2; simpl in |- *; auto;
+ try (intros; discriminate); intros p1 p2 H1; injection H1;
+ (intros H2; rewrite H2); auto.
+Qed.
+
+(** Triangular inequality *)
+
+Hint Local Resolve Zle_neg_pos: zarith.
+
+Theorem Zabs_triangle : forall n m:Z, Zabs (n + m) <= Zabs n + Zabs m.
+Proof.
+intros z1 z2; case z1; case z2; try (simpl in |- *; auto with zarith; fail).
+intros p1 p2;
+ apply Zabs_intro with (P := fun x => x <= Zabs (Zpos p2) + Zabs (Zneg p1));
+ try rewrite Zopp_plus_distr; auto with zarith.
+apply Zplus_le_compat; simpl in |- *; auto with zarith.
+apply Zplus_le_compat; simpl in |- *; auto with zarith.
+intros p1 p2;
+ apply Zabs_intro with (P := fun x => x <= Zabs (Zpos p2) + Zabs (Zneg p1));
+ try rewrite Zopp_plus_distr; auto with zarith.
+apply Zplus_le_compat; simpl in |- *; auto with zarith.
+apply Zplus_le_compat; simpl in |- *; auto with zarith.
+Qed.
+
+(** Absolute value and multiplication *)
+
+Lemma Zsgn_Zabs : forall n:Z, n * Zsgn n = Zabs n.
+Proof.
+intro x; destruct x; rewrite Zmult_comm; auto with arith.
+Qed.
+
+Lemma Zabs_Zsgn : forall n:Z, Zabs n * Zsgn n = n.
+Proof.
+intro x; destruct x; rewrite Zmult_comm; auto with arith.
+Qed.
+
+Theorem Zabs_Zmult : forall n m:Z, Zabs (n * m) = Zabs n * Zabs m.
+Proof.
+intros z1 z2; case z1; case z2; simpl in |- *; auto.
+Qed.
+
+(** absolute value in nat is compatible with order *)
+
+Lemma Zabs_nat_lt :
+ forall n m:Z, 0 <= n /\ n < m -> (Zabs_nat n < Zabs_nat m)%nat.
+Proof.
+intros x y. case x; simpl in |- *. case y; simpl in |- *.
+
+intro. absurd (0 < 0). compute in |- *. intro H0. discriminate H0. intuition.
+intros. elim (ZL4 p). intros. rewrite H0. auto with arith.
+intros. elim (ZL4 p). intros. rewrite H0. auto with arith.
+
+case y; simpl in |- *.
+intros. absurd (Zpos p < 0). compute in |- *. intro H0. discriminate H0. intuition.
+intros. change (nat_of_P p > nat_of_P p0)%nat in |- *.
+apply nat_of_P_gt_Gt_compare_morphism.
+elim H; auto with arith. intro. exact (ZC2 p0 p).
+
+intros. absurd (Zpos p0 < Zneg p).
+compute in |- *. intro H0. discriminate H0. intuition.
+
+intros. absurd (0 <= Zneg p). compute in |- *. auto with arith. intuition.
+Qed.
\ No newline at end of file
diff --git a/theories/ZArith/Zbinary.v b/theories/ZArith/Zbinary.v
new file mode 100644
index 00000000..fa5f00dc
--- /dev/null
+++ b/theories/ZArith/Zbinary.v
@@ -0,0 +1,426 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Zbinary.v,v 1.6.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+(** Bit vectors interpreted as integers. 
+    Contribution by Jean Duprat (ENS Lyon). *)
+
+Require Import Bvector.
+Require Import ZArith.
+Require Export Zpower.
+Require Import Omega.
+
+(*
+L'évaluation des vecteurs de booléens se font à la fois en binaire et
+en complément à deux. Le nombre appartient à Z. 
+On utilise donc Omega pour faire les calculs dans Z.
+De plus, on utilise les fonctions 2^n où n est un naturel, ici la longueur.
+	two_power_nat = [n:nat](POS (shift_nat n xH))
+     		: nat->Z
+	two_power_nat_S
+	     : (n:nat)`(two_power_nat (S n)) = 2*(two_power_nat n)`
+	Z_lt_ge_dec
+	     : (x,y:Z){`x < y`}+{`x >= y`}
+*)
+
+
+Section VALUE_OF_BOOLEAN_VECTORS.
+
+(*
+Les calculs sont effectués dans la convention positive usuelle.
+Les valeurs correspondent soit à l'écriture binaire (nat), 
+soit au complément à deux (int).
+On effectue le calcul suivant le schéma de Horner.
+Le complément à deux n'a de sens que sur les vecteurs de taille 
+supérieure ou égale à un, le bit de signe étant évalué négativement.
+*)
+
+Definition bit_value (b:bool) : Z :=
+  match b with
+  | true => 1%Z
+  | false => 0%Z
+  end.
+
+Lemma binary_value : forall n:nat, Bvector n -> Z.
+Proof.
+	simple induction n; intros.
+	exact 0%Z.
+
+	inversion H0.
+	exact (bit_value a + 2 * H H2)%Z.
+Defined.
+
+Lemma two_compl_value : forall n:nat, Bvector (S n) -> Z.
+Proof.
+	simple induction n; intros.
+	inversion H.
+	exact (- bit_value a)%Z.
+
+	inversion H0.
+	exact (bit_value a + 2 * H H2)%Z.
+Defined.
+
+(*
+Coq < Eval Compute in (binary_value (3) (Bcons true (2) (Bcons false (1) (Bcons true (0) Bnil)))).
+     = `5`
+     : Z
+*)
+
+(*
+Coq < Eval Compute in (two_compl_value (3) (Bcons true (3) (Bcons false (2) (Bcons true (1) (Bcons true (0) Bnil))))).
+     = `-3`
+     : Z
+*)
+
+End VALUE_OF_BOOLEAN_VECTORS.
+
+Section ENCODING_VALUE.
+
+(*
+On calcule la valeur binaire selon un schema de Horner.
+Le calcul s'arrete à la longueur du vecteur sans vérification.
+On definit une fonction Zmod2 calquee sur Zdiv2 mais donnant le quotient
+de la division z=2q+r avec 0<=r<=1.
+La valeur en complément à deux est calculée selon un schema de Horner
+avec Zmod2, le paramètre est la taille moins un.
+*)
+
+Definition Zmod2 (z:Z) :=
+  match z with
+  | Z0 => 0%Z
+  | Zpos p => match p with
+              | xI q => Zpos q
+              | xO q => Zpos q
+              | xH => 0%Z
+              end
+  | Zneg p =>
+      match p with
+      | xI q => (Zneg q - 1)%Z
+      | xO q => Zneg q
+      | xH => (-1)%Z
+      end
+  end.
+
+
+Lemma Zmod2_twice :
+ forall z:Z, z = (2 * Zmod2 z + bit_value (Zeven.Zodd_bool z))%Z.
+Proof.
+	destruct z; simpl in |- *.
+	trivial.
+
+	destruct p; simpl in |- *; trivial.
+
+	destruct p; simpl in |- *.
+	destruct p as [p| p| ]; simpl in |- *.
+	rewrite <- (Pdouble_minus_one_o_succ_eq_xI p); trivial.
+
+	trivial.
+
+	trivial.
+
+	trivial.
+
+	trivial.
+Qed.
+
+Lemma Z_to_binary : forall n:nat, Z -> Bvector n.
+Proof.
+	simple induction n; intros.
+	exact Bnil.
+
+	exact (Bcons (Zeven.Zodd_bool H0) n0 (H (Zeven.Zdiv2 H0))).
+Defined.
+
+(*
+Eval Compute in (Z_to_binary (5) `5`).
+     = (Vcons bool true (4)
+          (Vcons bool false (3)
+            (Vcons bool true (2)
+              (Vcons bool false (1) (Vcons bool false (0) (Vnil bool))))))
+     :  (Bvector (5))
+*)
+
+Lemma Z_to_two_compl : forall n:nat, Z -> Bvector (S n).
+Proof.
+	simple induction n; intros.
+	exact (Bcons (Zeven.Zodd_bool H) 0 Bnil).
+
+	exact (Bcons (Zeven.Zodd_bool H0) (S n0) (H (Zmod2 H0))).
+Defined.
+
+(*
+Eval Compute in (Z_to_two_compl (3) `0`).
+     =  (Vcons bool false (3)
+          (Vcons bool false (2)
+            (Vcons bool false (1) (Vcons bool false (0) (Vnil bool)))))
+     :  (vector bool (4))
+
+Eval Compute in (Z_to_two_compl (3) `5`).
+     = (Vcons bool true (3)
+          (Vcons bool false (2)
+            (Vcons bool true (1) (Vcons bool false (0) (Vnil bool)))))
+     :  (vector bool (4))
+
+Eval Compute in (Z_to_two_compl (3) `-5`).
+     =  (Vcons bool true (3)
+          (Vcons bool true (2)
+            (Vcons bool false (1) (Vcons bool true (0) (Vnil bool)))))
+     :  (vector bool (4))
+*)	
+
+End ENCODING_VALUE.
+
+Section Z_BRIC_A_BRAC.
+
+(*
+Bibliotheque de lemmes utiles dans la section suivante.
+Utilise largement ZArith.
+Meriterait d'etre reecrite.
+*)
+
+Lemma binary_value_Sn :
+ forall (n:nat) (b:bool) (bv:Bvector n),
+   binary_value (S n) (Vcons bool b n bv) =
+   (bit_value b + 2 * binary_value n bv)%Z.
+Proof.
+	intros; auto.
+Qed.
+
+Lemma Z_to_binary_Sn :
+ forall (n:nat) (b:bool) (z:Z),
+   (z >= 0)%Z ->
+   Z_to_binary (S n) (bit_value b + 2 * z) = Bcons b n (Z_to_binary n z).
+Proof.
+	destruct b; destruct z; simpl in |- *; auto.
+	intro H; elim H; trivial.
+Qed.
+
+Lemma binary_value_pos :
+ forall (n:nat) (bv:Bvector n), (binary_value n bv >= 0)%Z.
+Proof.
+	induction bv as [| a n v IHbv]; simpl in |- *.
+	omega.
+
+	destruct a; destruct (binary_value n v); simpl in |- *; auto.
+	auto with zarith.
+Qed.
+
+
+Lemma two_compl_value_Sn :
+ forall (n:nat) (bv:Bvector (S n)) (b:bool),
+   two_compl_value (S n) (Bcons b (S n) bv) =
+   (bit_value b + 2 * two_compl_value n bv)%Z.
+Proof.
+	intros; auto.
+Qed.
+
+Lemma Z_to_two_compl_Sn :
+ forall (n:nat) (b:bool) (z:Z),
+   Z_to_two_compl (S n) (bit_value b + 2 * z) =
+   Bcons b (S n) (Z_to_two_compl n z).
+Proof.
+	destruct b; destruct z as [| p| p]; auto.
+	destruct p as [p| p| ]; auto.
+	destruct p as [p| p| ]; simpl in |- *; auto.
+	intros; rewrite (Psucc_o_double_minus_one_eq_xO p); trivial.
+Qed.
+
+Lemma Z_to_binary_Sn_z :
+ forall (n:nat) (z:Z),
+   Z_to_binary (S n) z =
+   Bcons (Zeven.Zodd_bool z) n (Z_to_binary n (Zeven.Zdiv2 z)).
+Proof.
+	intros; auto.
+Qed.
+
+Lemma Z_div2_value :
+ forall z:Z,
+   (z >= 0)%Z -> (bit_value (Zeven.Zodd_bool z) + 2 * Zeven.Zdiv2 z)%Z = z.
+Proof.
+	destruct z as [| p| p]; auto.
+	destruct p; auto.
+  intro H; elim H; trivial.
+Qed.
+
+Lemma Pdiv2 : forall z:Z, (z >= 0)%Z -> (Zeven.Zdiv2 z >= 0)%Z.
+Proof.
+	destruct z as [| p| p].
+	auto.
+
+	destruct p; auto.
+	simpl in |- *; intros; omega.
+
+  intro H; elim H; trivial.
+
+Qed.
+
+Lemma Zdiv2_two_power_nat :
+ forall (z:Z) (n:nat),
+   (z >= 0)%Z ->
+   (z < two_power_nat (S n))%Z -> (Zeven.Zdiv2 z < two_power_nat n)%Z.
+Proof.
+	intros.
+	cut (2 * Zeven.Zdiv2 z < 2 * two_power_nat n)%Z; intros.
+	omega.
+
+	rewrite <- two_power_nat_S.
+	destruct (Zeven.Zeven_odd_dec z); intros.
+	rewrite <- Zeven.Zeven_div2; auto.
+
+	generalize (Zeven.Zodd_div2 z H z0); omega.
+Qed.
+
+(*
+
+Lemma Z_minus_one_or_zero : (z:Z)
+	`z >= -1` ->
+	`z < 1` ->
+	{`z=-1`} + {`z=0`}.
+Proof.
+	NewDestruct z; Auto.
+	NewDestruct p; Auto.
+	Tauto.
+
+	Tauto.
+
+	Intros.
+	Right; Omega.
+
+	NewDestruct p.
+	Tauto.
+
+	Tauto.
+
+	Intros; Left; Omega.
+Save.
+*)
+
+Lemma Z_to_two_compl_Sn_z :
+ forall (n:nat) (z:Z),
+   Z_to_two_compl (S n) z =
+   Bcons (Zeven.Zodd_bool z) (S n) (Z_to_two_compl n (Zmod2 z)).
+Proof.
+	intros; auto.
+Qed.
+
+Lemma Zeven_bit_value :
+ forall z:Z, Zeven.Zeven z -> bit_value (Zeven.Zodd_bool z) = 0%Z.
+Proof.
+	destruct z; unfold bit_value in |- *; auto.
+	destruct p; tauto || (intro H; elim H).
+ 	destruct p; tauto || (intro H; elim H).
+Qed.
+
+Lemma Zodd_bit_value :
+ forall z:Z, Zeven.Zodd z -> bit_value (Zeven.Zodd_bool z) = 1%Z.
+Proof.
+	destruct z; unfold bit_value in |- *; auto.
+  intros; elim H.
+  destruct p; tauto || (intros; elim H).
+  destruct p; tauto || (intros; elim H).
+Qed.
+
+Lemma Zge_minus_two_power_nat_S :
+ forall (n:nat) (z:Z),
+   (z >= - two_power_nat (S n))%Z -> (Zmod2 z >= - two_power_nat n)%Z.
+Proof.
+	intros n z; rewrite (two_power_nat_S n).
+	generalize (Zmod2_twice z).
+	destruct (Zeven.Zeven_odd_dec z) as [H| H].
+	rewrite (Zeven_bit_value z H); intros; omega.
+
+        rewrite (Zodd_bit_value z H); intros; omega.
+Qed.
+
+Lemma Zlt_two_power_nat_S :
+ forall (n:nat) (z:Z),
+   (z < two_power_nat (S n))%Z -> (Zmod2 z < two_power_nat n)%Z.
+Proof.
+	intros n z; rewrite (two_power_nat_S n).
+	generalize (Zmod2_twice z).
+	destruct (Zeven.Zeven_odd_dec z) as [H| H].
+	rewrite (Zeven_bit_value z H); intros; omega.
+
+	rewrite (Zodd_bit_value z H); intros; omega.
+Qed.
+
+End Z_BRIC_A_BRAC.
+
+Section COHERENT_VALUE.
+
+(*
+On vérifie que dans l'intervalle de définition les fonctions sont 
+réciproques l'une de l'autre.
+Elles utilisent les lemmes du bric-a-brac.
+*)
+
+Lemma binary_to_Z_to_binary :
+ forall (n:nat) (bv:Bvector n), Z_to_binary n (binary_value n bv) = bv.
+Proof.
+	induction bv as [| a n bv IHbv].
+	auto.
+
+	rewrite binary_value_Sn.
+	rewrite Z_to_binary_Sn.
+	rewrite IHbv; trivial.
+
+	apply binary_value_pos.
+Qed.
+		
+Lemma two_compl_to_Z_to_two_compl :
+ forall (n:nat) (bv:Bvector n) (b:bool),
+   Z_to_two_compl n (two_compl_value n (Bcons b n bv)) = Bcons b n bv.
+Proof.
+	induction bv as [| a n bv IHbv]; intro b.
+	destruct b; auto.
+
+	rewrite two_compl_value_Sn.
+	rewrite Z_to_two_compl_Sn.
+	rewrite IHbv; trivial.
+Qed.
+
+Lemma Z_to_binary_to_Z :
+ forall (n:nat) (z:Z),
+   (z >= 0)%Z ->
+   (z < two_power_nat n)%Z -> binary_value n (Z_to_binary n z) = z.
+Proof.
+	induction n as [| n IHn].
+	unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros; omega.
+
+	intros; rewrite Z_to_binary_Sn_z.
+	rewrite binary_value_Sn.
+	rewrite IHn.
+	apply Z_div2_value; auto.
+
+	apply Pdiv2; trivial.
+
+	apply Zdiv2_two_power_nat; trivial.
+Qed.
+
+Lemma Z_to_two_compl_to_Z :
+ forall (n:nat) (z:Z),
+   (z >= - two_power_nat n)%Z ->
+   (z < two_power_nat n)%Z -> two_compl_value n (Z_to_two_compl n z) = z.
+Proof.
+	induction n as [| n IHn].
+	unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros.
+	assert (z = (-1)%Z \/ z = 0%Z). omega.
+intuition; subst z; trivial.
+
+	intros; rewrite Z_to_two_compl_Sn_z.
+	rewrite two_compl_value_Sn.
+	rewrite IHn.
+	generalize (Zmod2_twice z); omega.
+
+	apply Zge_minus_two_power_nat_S; auto.
+
+	apply Zlt_two_power_nat_S; auto.
+Qed.
+
+End COHERENT_VALUE.
diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v
new file mode 100644
index 00000000..bb8abef4
--- /dev/null
+++ b/theories/ZArith/Zbool.v
@@ -0,0 +1,186 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: Zbool.v,v 1.4.2.1 2004/07/16 19:31:21 herbelin Exp $ *)
+
+Require Import BinInt.
+Require Import Zeven.
+Require Import Zorder.
+Require Import Zcompare.
+Require Import ZArith_dec.
+Require Import Sumbool.
+
+(** The decidability of equality and order relations over
+    type [Z] give some boolean functions with the adequate specification. *)
+
+Definition Z_lt_ge_bool (x y:Z) := bool_of_sumbool (Z_lt_ge_dec x y).
+Definition Z_ge_lt_bool (x y:Z) := bool_of_sumbool (Z_ge_lt_dec x y).
+
+Definition Z_le_gt_bool (x y:Z) := bool_of_sumbool (Z_le_gt_dec x y).
+Definition Z_gt_le_bool (x y:Z) := bool_of_sumbool (Z_gt_le_dec x y).
+
+Definition Z_eq_bool (x y:Z) := bool_of_sumbool (Z_eq_dec x y).
+Definition Z_noteq_bool (x y:Z) := bool_of_sumbool (Z_noteq_dec x y).
+
+Definition Zeven_odd_bool (x:Z) := bool_of_sumbool (Zeven_odd_dec x).
+
+(**********************************************************************)
+(** Boolean comparisons of binary integers *)
+
+Definition Zle_bool (x y:Z) :=
+  match (x ?= y)%Z with
+  | Gt => false
+  | _ => true
+  end.
+Definition Zge_bool (x y:Z) :=
+  match (x ?= y)%Z with
+  | Lt => false
+  | _ => true
+  end.
+Definition Zlt_bool (x y:Z) :=
+  match (x ?= y)%Z with
+  | Lt => true
+  | _ => false
+  end.
+Definition Zgt_bool (x y:Z) :=
+  match (x ?= y)%Z with
+  | Gt => true
+  | _ => false
+  end.
+Definition Zeq_bool (x y:Z) :=
+  match (x ?= y)%Z with
+  | Eq => true
+  | _ => false
+  end.
+Definition Zneq_bool (x y:Z) :=
+  match (x ?= y)%Z with
+  | Eq => false
+  | _ => true
+  end.
+
+Lemma Zle_cases :
+ forall n m:Z, if Zle_bool n m then (n <= m)%Z else (n > m)%Z.
+Proof.
+intros x y; unfold Zle_bool, Zle, Zgt in |- *.
+case (x ?= y)%Z; auto; discriminate.
+Qed.
+
+Lemma Zlt_cases :
+ forall n m:Z, if Zlt_bool n m then (n < m)%Z else (n >= m)%Z.
+Proof.
+intros x y; unfold Zlt_bool, Zlt, Zge in |- *.
+case (x ?= y)%Z; auto; discriminate.
+Qed.
+
+Lemma Zge_cases :
+ forall n m:Z, if Zge_bool n m then (n >= m)%Z else (n < m)%Z.
+Proof.
+intros x y; unfold Zge_bool, Zge, Zlt in |- *.
+case (x ?= y)%Z; auto; discriminate.
+Qed.
+
+Lemma Zgt_cases :
+ forall n m:Z, if Zgt_bool n m then (n > m)%Z else (n <= m)%Z.
+Proof.
+intros x y; unfold Zgt_bool, Zgt, Zle in |- *.
+case (x ?= y)%Z; auto; discriminate.
+Qed.
+
+(** Lemmas on [Zle_bool] used in contrib/graphs *)
+
+Lemma Zle_bool_imp_le : forall n m:Z, Zle_bool n m = true -> (n <= m)%Z.
+Proof.
+  unfold Zle_bool, Zle in |- *. intros x y. unfold not in |- *. 
+  case (x ?= y)%Z; intros; discriminate.
+Qed.
+
+Lemma Zle_imp_le_bool : forall n m:Z, (n <= m)%Z -> Zle_bool n m = true.
+Proof.
+  unfold Zle, Zle_bool in |- *. intros x y. case (x ?= y)%Z; trivial. intro. elim (H (refl_equal _)).
+Qed.
+
+Lemma Zle_bool_refl : forall n:Z, Zle_bool n n = true.
+Proof.
+  intro. apply Zle_imp_le_bool. apply Zeq_le. reflexivity.
+Qed.
+
+Lemma Zle_bool_antisym :
+ forall n m:Z, Zle_bool n m = true -> Zle_bool m n = true -> n = m.
+Proof.
+  intros. apply Zle_antisym. apply Zle_bool_imp_le. assumption.
+  apply Zle_bool_imp_le. assumption.
+Qed.
+
+Lemma Zle_bool_trans :
+ forall n m p:Z,
+   Zle_bool n m = true -> Zle_bool m p = true -> Zle_bool n p = true.
+Proof.
+  intros x y z; intros. apply Zle_imp_le_bool. apply Zle_trans with (m := y). apply Zle_bool_imp_le. assumption.
+  apply Zle_bool_imp_le. assumption.
+Qed.
+
+Definition Zle_bool_total :
+  forall x y:Z, {Zle_bool x y = true} + {Zle_bool y x = true}.
+Proof.
+  intros x y; intros. unfold Zle_bool in |- *. cut ((x ?= y)%Z = Gt <-> (y ?= x)%Z = Lt).
+  case (x ?= y)%Z. left. reflexivity.
+  left. reflexivity.
+  right. rewrite (proj1 H (refl_equal _)). reflexivity.
+  apply Zcompare_Gt_Lt_antisym.
+Defined.
+
+Lemma Zle_bool_plus_mono :
+ forall n m p q:Z,
+   Zle_bool n m = true ->
+   Zle_bool p q = true -> Zle_bool (n + p) (m + q) = true.
+Proof.
+  intros. apply Zle_imp_le_bool. apply Zplus_le_compat. apply Zle_bool_imp_le. assumption.
+  apply Zle_bool_imp_le. assumption.
+Qed.
+
+Lemma Zone_pos : Zle_bool 1 0 = false.
+Proof.
+  reflexivity.
+Qed.
+
+Lemma Zone_min_pos : forall n:Z, Zle_bool n 0 = false -> Zle_bool 1 n = true.
+Proof.
+  intros x; intros. apply Zle_imp_le_bool. change (Zsucc 0 <= x)%Z in |- *. apply Zgt_le_succ. generalize H.
+  unfold Zle_bool, Zgt in |- *. case (x ?= 0)%Z. intro H0. discriminate H0.
+  intro H0. discriminate H0.
+  reflexivity.
+Qed.
+
+
+ Lemma Zle_is_le_bool : forall n m:Z, (n <= m)%Z <-> Zle_bool n m = true.
+  Proof.
+    intros. split. intro. apply Zle_imp_le_bool. assumption.
+    intro. apply Zle_bool_imp_le. assumption.
+  Qed.
+
+  Lemma Zge_is_le_bool : forall n m:Z, (n >= m)%Z <-> Zle_bool m n = true.
+  Proof.
+    intros. split. intro. apply Zle_imp_le_bool. apply Zge_le. assumption.
+    intro. apply Zle_ge. apply Zle_bool_imp_le. assumption.
+  Qed.
+
+  Lemma Zlt_is_le_bool :
+   forall n m:Z, (n < m)%Z <-> Zle_bool n (m - 1) = true.
+  Proof.
+    intros x y. split. intro. apply Zle_imp_le_bool. apply Zlt_succ_le. rewrite (Zsucc_pred y) in H.
+    assumption.
+    intro. rewrite (Zsucc_pred y). apply Zle_lt_succ. apply Zle_bool_imp_le. assumption.
+  Qed.
+
+  Lemma Zgt_is_le_bool :
+   forall n m:Z, (n > m)%Z <-> Zle_bool m (n - 1) = true.
+  Proof.
+    intros x y. apply iff_trans with (y < x)%Z. split. exact (Zgt_lt x y).
+    exact (Zlt_gt y x).
+    exact (Zlt_is_le_bool y x).
+  Qed.
diff --git a/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v
new file mode 100644
index 00000000..714abfc4
--- /dev/null
+++ b/theories/ZArith/Zcompare.v
@@ -0,0 +1,501 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $$ i*)
+
+Require Export BinPos.
+Require Export BinInt.
+Require Import Lt.
+Require Import Gt.
+Require Import Plus.
+Require Import Mult.
+
+Open Local Scope Z_scope.
+
+(**********************************************************************)
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France)            *)
+(**********************************************************************)
+
+(**********************************************************************)
+(** Comparison on integers *)
+
+Lemma Zcompare_refl : forall n:Z, (n ?= n) = Eq.
+Proof.
+intro x; destruct x as [| p| p]; simpl in |- *;
+ [ reflexivity | apply Pcompare_refl | rewrite Pcompare_refl; reflexivity ].
+Qed.
+
+Lemma Zcompare_Eq_eq : forall n m:Z, (n ?= m) = Eq -> n = m.
+Proof.
+intros x y; destruct x as [| x'| x']; destruct y as [| y'| y']; simpl in |- *;
+ intro H; reflexivity || (try discriminate H);
+ [ rewrite (Pcompare_Eq_eq x' y' H); reflexivity
+ | rewrite (Pcompare_Eq_eq x' y');
+    [ reflexivity
+    | destruct ((x' ?= y')%positive Eq); reflexivity || discriminate ] ].
+Qed.
+
+Lemma Zcompare_Eq_iff_eq : forall n m:Z, (n ?= m) = Eq <-> n = m.
+Proof.
+intros x y; split; intro E;
+ [ apply Zcompare_Eq_eq; assumption | rewrite E; apply Zcompare_refl ].
+Qed.
+
+Lemma Zcompare_antisym : forall n m:Z, CompOpp (n ?= m) = (m ?= n).
+Proof.
+intros x y; destruct x; destruct y; simpl in |- *;
+ reflexivity || discriminate H || rewrite Pcompare_antisym; 
+ reflexivity.
+Qed.
+
+Lemma Zcompare_Gt_Lt_antisym : forall n m:Z, (n ?= m) = Gt <-> (m ?= n) = Lt.
+Proof.
+intros x y; split; intro H;
+ [ change Lt with (CompOpp Gt) in |- *; rewrite <- Zcompare_antisym;
+    rewrite H; reflexivity
+ | change Gt with (CompOpp Lt) in |- *; rewrite <- Zcompare_antisym;
+    rewrite H; reflexivity ].
+Qed.
+
+(** Transitivity of comparison *)
+
+Lemma Zcompare_Gt_trans :
+ forall n m p:Z, (n ?= m) = Gt -> (m ?= p) = Gt -> (n ?= p) = Gt.
+Proof.
+intros x y z; case x; case y; case z; simpl in |- *;
+ try (intros; discriminate H || discriminate H0); auto with arith;
+ [ intros p q r H H0; apply nat_of_P_gt_Gt_compare_complement_morphism;
+    unfold gt in |- *; apply lt_trans with (m := nat_of_P q);
+    apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; 
+    assumption
+ | intros p q r; do 3 rewrite <- ZC4; intros H H0;
+    apply nat_of_P_gt_Gt_compare_complement_morphism; 
+    unfold gt in |- *; apply lt_trans with (m := nat_of_P q);
+    apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; 
+    assumption ].
+Qed.
+
+(** Comparison and opposite *)
+
+Lemma Zcompare_opp : forall n m:Z, (n ?= m) = (- m ?= - n).
+Proof.
+intros x y; case x; case y; simpl in |- *; auto with arith; intros;
+ rewrite <- ZC4; trivial with arith.
+Qed.
+
+Hint Local Resolve Pcompare_refl.
+
+(** Comparison first-order specification *)
+
+Lemma Zcompare_Gt_spec :
+ forall n m:Z, (n ?= m) = Gt ->  exists h : positive, n + - m = Zpos h.
+Proof.
+intros x y; case x; case y;
+ [ simpl in |- *; intros H; discriminate H
+ | simpl in |- *; intros p H; discriminate H
+ | intros p H; exists p; simpl in |- *; auto with arith
+ | intros p H; exists p; simpl in |- *; auto with arith
+ | intros q p H; exists (p - q)%positive; unfold Zplus, Zopp in |- *;
+    unfold Zcompare in H; rewrite H; trivial with arith
+ | intros q p H; exists (p + q)%positive; simpl in |- *; trivial with arith
+ | simpl in |- *; intros p H; discriminate H
+ | simpl in |- *; intros q p H; discriminate H
+ | unfold Zcompare in |- *; intros q p; rewrite <- ZC4; intros H;
+    exists (q - p)%positive; simpl in |- *; rewrite (ZC1 q p H);
+    trivial with arith ].
+Qed.
+
+(** Comparison and addition *)
+
+Lemma weaken_Zcompare_Zplus_compatible :
+ (forall (n m:Z) (p:positive), (Zpos p + n ?= Zpos p + m) = (n ?= m)) ->
+ forall n m p:Z, (p + n ?= p + m) = (n ?= m).
+Proof.
+intros H x y z; destruct z;
+ [ reflexivity
+ | apply H
+ | rewrite (Zcompare_opp x y); rewrite Zcompare_opp;
+    do 2 rewrite Zopp_plus_distr; rewrite Zopp_neg; 
+    apply H ].
+Qed.
+
+Hint Local Resolve ZC4.
+
+Lemma weak_Zcompare_Zplus_compatible :
+ forall (n m:Z) (p:positive), (Zpos p + n ?= Zpos p + m) = (n ?= m).
+Proof.
+intros x y z; case x; case y; simpl in |- *; auto with arith;
+ [ intros p; apply nat_of_P_lt_Lt_compare_complement_morphism; apply ZL17
+ | intros p; ElimPcompare z p; intros E; rewrite E; auto with arith;
+    apply nat_of_P_gt_Gt_compare_complement_morphism;
+    rewrite nat_of_P_minus_morphism;
+    [ unfold gt in |- *; apply ZL16 | assumption ]
+ | intros p; ElimPcompare z p; intros E; auto with arith;
+    apply nat_of_P_gt_Gt_compare_complement_morphism; 
+    unfold gt in |- *; apply ZL17
+ | intros p q; ElimPcompare q p; intros E; rewrite E;
+    [ rewrite (Pcompare_Eq_eq q p E); apply Pcompare_refl
+    | apply nat_of_P_lt_Lt_compare_complement_morphism;
+       do 2 rewrite nat_of_P_plus_morphism; apply plus_lt_compat_l;
+       apply nat_of_P_lt_Lt_compare_morphism with (1 := E)
+    | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *;
+       do 2 rewrite nat_of_P_plus_morphism; apply plus_lt_compat_l;
+       exact (nat_of_P_gt_Gt_compare_morphism q p E) ]
+ | intros p q; ElimPcompare z p; intros E; rewrite E; auto with arith;
+    apply nat_of_P_gt_Gt_compare_complement_morphism;
+    rewrite nat_of_P_minus_morphism;
+    [ unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
+       [ apply ZL16 | apply ZL17 ]
+    | assumption ]
+ | intros p; ElimPcompare z p; intros E; rewrite E; auto with arith;
+    simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
+    rewrite nat_of_P_minus_morphism; [ apply ZL16 | assumption ]
+ | intros p q; ElimPcompare z q; intros E; rewrite E; auto with arith;
+    simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
+    rewrite nat_of_P_minus_morphism;
+    [ apply lt_trans with (m := nat_of_P z); [ apply ZL16 | apply ZL17 ]
+    | assumption ]
+ | intros p q; ElimPcompare z q; intros E0; rewrite E0; ElimPcompare z p;
+    intros E1; rewrite E1; ElimPcompare q p; intros E2; 
+    rewrite E2; auto with arith;
+    [ absurd ((q ?= p)%positive Eq = Lt);
+       [ rewrite <- (Pcompare_Eq_eq z q E0);
+          rewrite <- (Pcompare_Eq_eq z p E1); rewrite (Pcompare_refl z);
+          discriminate
+       | assumption ]
+    | absurd ((q ?= p)%positive Eq = Gt);
+       [ rewrite <- (Pcompare_Eq_eq z q E0);
+          rewrite <- (Pcompare_Eq_eq z p E1); rewrite (Pcompare_refl z);
+          discriminate
+       | assumption ]
+    | absurd ((z ?= p)%positive Eq = Lt);
+       [ rewrite (Pcompare_Eq_eq z q E0); rewrite <- (Pcompare_Eq_eq q p E2);
+          rewrite (Pcompare_refl q); discriminate
+       | assumption ]
+    | absurd ((z ?= p)%positive Eq = Lt);
+       [ rewrite (Pcompare_Eq_eq z q E0); rewrite E2; discriminate
+       | assumption ]
+    | absurd ((z ?= p)%positive Eq = Gt);
+       [ rewrite (Pcompare_Eq_eq z q E0); rewrite <- (Pcompare_Eq_eq q p E2);
+          rewrite (Pcompare_refl q); discriminate
+       | assumption ]
+    | absurd ((z ?= p)%positive Eq = Gt);
+       [ rewrite (Pcompare_Eq_eq z q E0); rewrite E2; discriminate
+       | assumption ]
+    | absurd ((z ?= q)%positive Eq = Lt);
+       [ rewrite (Pcompare_Eq_eq z p E1); rewrite (Pcompare_Eq_eq q p E2);
+          rewrite (Pcompare_refl p); discriminate
+       | assumption ]
+    | absurd ((p ?= q)%positive Eq = Gt);
+       [ rewrite <- (Pcompare_Eq_eq z p E1); rewrite E0; discriminate
+       | apply ZC2; assumption ]
+    | simpl in |- *; rewrite (Pcompare_Eq_eq q p E2);
+       rewrite (Pcompare_refl (p - z)); auto with arith
+    | simpl in |- *; rewrite <- ZC4;
+       apply nat_of_P_gt_Gt_compare_complement_morphism;
+       rewrite nat_of_P_minus_morphism;
+       [ rewrite nat_of_P_minus_morphism;
+          [ unfold gt in |- *; apply plus_lt_reg_l with (p := nat_of_P z);
+             rewrite le_plus_minus_r;
+             [ rewrite le_plus_minus_r;
+                [ apply nat_of_P_lt_Lt_compare_morphism; assumption
+                | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+                   assumption ]
+             | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+                assumption ]
+          | apply ZC2; assumption ]
+       | apply ZC2; assumption ]
+    | simpl in |- *; rewrite <- ZC4;
+       apply nat_of_P_lt_Lt_compare_complement_morphism;
+       rewrite nat_of_P_minus_morphism;
+       [ rewrite nat_of_P_minus_morphism;
+          [ apply plus_lt_reg_l with (p := nat_of_P z);
+             rewrite le_plus_minus_r;
+             [ rewrite le_plus_minus_r;
+                [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1;
+                   assumption
+                | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+                   assumption ]
+             | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+                assumption ]
+          | apply ZC2; assumption ]
+       | apply ZC2; assumption ]
+    | absurd ((z ?= q)%positive Eq = Lt);
+       [ rewrite (Pcompare_Eq_eq q p E2); rewrite E1; discriminate
+       | assumption ]
+    | absurd ((q ?= p)%positive Eq = Lt);
+       [ cut ((q ?= p)%positive Eq = Gt);
+          [ intros E; rewrite E; discriminate
+          | apply nat_of_P_gt_Gt_compare_complement_morphism;
+             unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
+             [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
+             | apply nat_of_P_lt_Lt_compare_morphism; assumption ] ]
+       | assumption ]
+    | absurd ((z ?= q)%positive Eq = Gt);
+       [ rewrite (Pcompare_Eq_eq z p E1); rewrite (Pcompare_Eq_eq q p E2);
+          rewrite (Pcompare_refl p); discriminate
+       | assumption ]
+    | absurd ((z ?= q)%positive Eq = Gt);
+       [ rewrite (Pcompare_Eq_eq z p E1); rewrite ZC1;
+          [ discriminate | assumption ]
+       | assumption ]
+    | absurd ((z ?= q)%positive Eq = Gt);
+       [ rewrite (Pcompare_Eq_eq q p E2); rewrite E1; discriminate
+       | assumption ]
+    | absurd ((q ?= p)%positive Eq = Gt);
+       [ rewrite ZC1;
+          [ discriminate
+          | apply nat_of_P_gt_Gt_compare_complement_morphism;
+             unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
+             [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
+             | apply nat_of_P_lt_Lt_compare_morphism; assumption ] ]
+       | assumption ]
+    | simpl in |- *; rewrite (Pcompare_Eq_eq q p E2); apply Pcompare_refl
+    | simpl in |- *; apply nat_of_P_gt_Gt_compare_complement_morphism;
+       unfold gt in |- *; rewrite nat_of_P_minus_morphism;
+       [ rewrite nat_of_P_minus_morphism;
+          [ apply plus_lt_reg_l with (p := nat_of_P p);
+             rewrite le_plus_minus_r;
+             [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P q);
+                rewrite plus_assoc; rewrite le_plus_minus_r;
+                [ rewrite (plus_comm (nat_of_P q)); apply plus_lt_compat_l;
+                   apply nat_of_P_lt_Lt_compare_morphism; 
+                   assumption
+                | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+                   apply ZC1; assumption ]
+             | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+                apply ZC1; assumption ]
+          | assumption ]
+       | assumption ]
+    | simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
+       rewrite nat_of_P_minus_morphism;
+       [ rewrite nat_of_P_minus_morphism;
+          [ apply plus_lt_reg_l with (p := nat_of_P q);
+             rewrite le_plus_minus_r;
+             [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p);
+                rewrite plus_assoc; rewrite le_plus_minus_r;
+                [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l;
+                   apply nat_of_P_lt_Lt_compare_morphism; 
+                   apply ZC1; assumption
+                | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+                   apply ZC1; assumption ]
+             | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+                apply ZC1; assumption ]
+          | assumption ]
+       | assumption ] ] ].
+Qed.
+
+Lemma Zcompare_plus_compat : forall n m p:Z, (p + n ?= p + m) = (n ?= m).
+Proof.
+exact (weaken_Zcompare_Zplus_compatible weak_Zcompare_Zplus_compatible).
+Qed.
+
+Lemma Zplus_compare_compat :
+ forall (r:comparison) (n m p q:Z),
+   (n ?= m) = r -> (p ?= q) = r -> (n + p ?= m + q) = r.
+Proof.
+intros r x y z t; case r;
+ [ intros H1 H2; elim (Zcompare_Eq_iff_eq x y); elim (Zcompare_Eq_iff_eq z t);
+    intros H3 H4 H5 H6; rewrite H3;
+    [ rewrite H5;
+       [ elim (Zcompare_Eq_iff_eq (y + t) (y + t)); auto with arith
+       | auto with arith ]
+    | auto with arith ]
+ | intros H1 H2; elim (Zcompare_Gt_Lt_antisym (y + t) (x + z)); intros H3 H4;
+    apply H3; apply Zcompare_Gt_trans with (m := y + z);
+    [ rewrite Zcompare_plus_compat; elim (Zcompare_Gt_Lt_antisym t z);
+       auto with arith
+    | do 2 rewrite <- (Zplus_comm z); rewrite Zcompare_plus_compat;
+       elim (Zcompare_Gt_Lt_antisym y x); auto with arith ]
+ | intros H1 H2; apply Zcompare_Gt_trans with (m := x + t);
+    [ rewrite Zcompare_plus_compat; assumption
+    | do 2 rewrite <- (Zplus_comm t); rewrite Zcompare_plus_compat;
+       assumption ] ].
+Qed.
+
+Lemma Zcompare_succ_Gt : forall n:Z, (Zsucc n ?= n) = Gt.
+Proof.
+intro x; unfold Zsucc in |- *; pattern x at 2 in |- *;
+ rewrite <- (Zplus_0_r x); rewrite Zcompare_plus_compat; 
+ reflexivity.
+Qed.
+
+Lemma Zcompare_Gt_not_Lt : forall n m:Z, (n ?= m) = Gt <-> (n ?= m + 1) <> Lt.
+Proof.
+intros x y; split;
+ [ intro H; elim_compare x (y + 1);
+    [ intro H1; rewrite H1; discriminate
+    | intros H1; elim Zcompare_Gt_spec with (1 := H); intros h H2;
+       absurd ((nat_of_P h > 0)%nat /\ (nat_of_P h < 1)%nat);
+       [ unfold not in |- *; intros H3; elim H3; intros H4 H5;
+          absurd (nat_of_P h > 0)%nat;
+          [ unfold gt in |- *; apply le_not_lt; apply le_S_n; exact H5
+          | assumption ]
+       | split;
+          [ elim (ZL4 h); intros i H3; rewrite H3; apply gt_Sn_O
+          | change (nat_of_P h < nat_of_P 1)%nat in |- *;
+             apply nat_of_P_lt_Lt_compare_morphism;
+             change ((Zpos h ?= 1) = Lt) in |- *; rewrite <- H2;
+             rewrite <- (fun m n:Z => Zcompare_plus_compat m n y);
+             rewrite (Zplus_comm x); rewrite Zplus_assoc; 
+             rewrite Zplus_opp_r; simpl in |- *; exact H1 ] ]
+    | intros H1; rewrite H1; discriminate ]
+ | intros H; elim_compare x (y + 1);
+    [ intros H1; elim (Zcompare_Eq_iff_eq x (y + 1)); intros H2 H3;
+       rewrite (H2 H1); exact (Zcompare_succ_Gt y)
+    | intros H1; absurd ((x ?= y + 1) = Lt); assumption
+    | intros H1; apply Zcompare_Gt_trans with (m := Zsucc y);
+       [ exact H1 | exact (Zcompare_succ_Gt y) ] ] ].
+Qed.
+
+(** Successor and comparison *)
+
+Lemma Zcompare_succ_compat : forall n m:Z, (Zsucc n ?= Zsucc m) = (n ?= m).
+Proof.
+intros n m; unfold Zsucc in |- *; do 2 rewrite (fun t:Z => Zplus_comm t 1);
+ rewrite Zcompare_plus_compat; auto with arith.
+Qed.
+ 
+(** Multiplication and comparison *)
+
+Lemma Zcompare_mult_compat :
+ forall (p:positive) (n m:Z), (Zpos p * n ?= Zpos p * m) = (n ?= m).
+Proof.
+intros x; induction x as [p H| p H| ];
+ [ intros y z; cut (Zpos (xI p) = Zpos p + Zpos p + 1);
+    [ intros E; rewrite E; do 4 rewrite Zmult_plus_distr_l;
+       do 2 rewrite Zmult_1_l; apply Zplus_compare_compat;
+       [ apply Zplus_compare_compat; apply H | trivial with arith ]
+    | simpl in |- *; rewrite (Pplus_diag p); trivial with arith ]
+ | intros y z; cut (Zpos (xO p) = Zpos p + Zpos p);
+    [ intros E; rewrite E; do 2 rewrite Zmult_plus_distr_l;
+       apply Zplus_compare_compat; apply H
+    | simpl in |- *; rewrite (Pplus_diag p); trivial with arith ]
+ | intros y z; do 2 rewrite Zmult_1_l; trivial with arith ].
+Qed.
+
+
+(** Reverting [x ?= y] to trichotomy *)
+
+Lemma rename :
+ forall (A:Set) (P:A -> Prop) (x:A), (forall y:A, x = y -> P y) -> P x.
+Proof.
+auto with arith. 
+Qed.
+
+Lemma Zcompare_elim :
+ forall (c1 c2 c3:Prop) (n m:Z),
+   (n = m -> c1) ->
+   (n < m -> c2) ->
+   (n > m -> c3) -> match n ?= m with
+                    | Eq => c1
+                    | Lt => c2
+                    | Gt => c3
+                    end.
+Proof.
+intros c1 c2 c3 x y; intros.
+apply rename with (x := x ?= y); intro r; elim r;
+ [ intro; apply H; apply (Zcompare_Eq_eq x y); assumption
+ | unfold Zlt in H0; assumption
+ | unfold Zgt in H1; assumption ].
+Qed.
+
+Lemma Zcompare_eq_case :
+ forall (c1 c2 c3:Prop) (n m:Z),
+   c1 -> n = m -> match n ?= m with
+                  | Eq => c1
+                  | Lt => c2
+                  | Gt => c3
+                  end.
+Proof.
+intros c1 c2 c3 x y; intros.
+rewrite H0; rewrite Zcompare_refl.
+assumption.
+Qed.
+
+(** Decompose an egality between two [?=] relations into 3 implications *)
+
+Lemma Zcompare_egal_dec :
+ forall n m p q:Z,
+   (n < m -> p < q) ->
+   ((n ?= m) = Eq -> (p ?= q) = Eq) ->
+   (n > m -> p > q) -> (n ?= m) = (p ?= q).
+Proof.
+intros x1 y1 x2 y2.
+unfold Zgt in |- *; unfold Zlt in |- *; case (x1 ?= y1); case (x2 ?= y2);
+ auto with arith; symmetry  in |- *; auto with arith.
+Qed.
+
+(** Relating [x ?= y] to [Zle], [Zlt], [Zge] or [Zgt] *)
+
+Lemma Zle_compare :
+ forall n m:Z,
+   n <= m -> match n ?= m with
+             | Eq => True
+             | Lt => True
+             | Gt => False
+             end.
+Proof.
+intros x y; unfold Zle in |- *; elim (x ?= y); auto with arith.
+Qed.
+
+Lemma Zlt_compare :
+ forall n m:Z,
+   n < m -> match n ?= m with
+            | Eq => False
+            | Lt => True
+            | Gt => False
+            end.
+Proof.
+intros x y; unfold Zlt in |- *; elim (x ?= y); intros;
+ discriminate || trivial with arith.
+Qed.
+
+Lemma Zge_compare :
+ forall n m:Z,
+   n >= m -> match n ?= m with
+             | Eq => True
+             | Lt => False
+             | Gt => True
+             end.
+Proof.
+intros x y; unfold Zge in |- *; elim (x ?= y); auto with arith. 
+Qed.
+
+Lemma Zgt_compare :
+ forall n m:Z,
+   n > m -> match n ?= m with
+            | Eq => False
+            | Lt => False
+            | Gt => True
+            end.
+Proof.
+intros x y; unfold Zgt in |- *; elim (x ?= y); intros;
+ discriminate || trivial with arith.
+Qed.
+
+(**********************************************************************)
+(* Other properties *)
+
+
+Lemma Zmult_compare_compat_l :
+ forall n m p:Z, p > 0 -> (n ?= m) = (p * n ?= p * m).
+Proof.
+intros x y z H; destruct z.
+  discriminate H.
+  rewrite Zcompare_mult_compat; reflexivity.
+  discriminate H.
+Qed.
+
+Lemma Zmult_compare_compat_r :
+ forall n m p:Z, p > 0 -> (n ?= m) = (n * p ?= m * p).
+Proof.
+intros x y z H; rewrite (Zmult_comm x z); rewrite (Zmult_comm y z);
+ apply Zmult_compare_compat_l; assumption.
+Qed.
+
diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v
new file mode 100644
index 00000000..b60cd37c
--- /dev/null
+++ b/theories/ZArith/Zcomplements.v
@@ -0,0 +1,212 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Zcomplements.v,v 1.26.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+Require Import ZArithRing.
+Require Import ZArith_base.
+Require Import Omega.
+Require Import Wf_nat.
+Open Local Scope Z_scope.
+
+
+(**********************************************************************)
+(** About parity *)
+
+Lemma two_or_two_plus_one :
+ forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}. 
+Proof.
+intro x; destruct x.
+left; split with 0; reflexivity.
+
+destruct p.
+right; split with (Zpos p); reflexivity.
+
+left; split with (Zpos p); reflexivity.
+
+right; split with 0; reflexivity.
+
+destruct p.
+right; split with (Zneg (1 + p)).
+rewrite BinInt.Zneg_xI.
+rewrite BinInt.Zneg_plus_distr.
+omega.
+
+left; split with (Zneg p); reflexivity.
+
+right; split with (-1); reflexivity.
+Qed.
+
+(**********************************************************************)
+(** The biggest power of 2 that is stricly less than [a]
+
+    Easy to compute: replace all "1" of the binary representation by
+    "0", except the first "1" (or the first one :-) *)
+
+Fixpoint floor_pos (a:positive) : positive :=
+  match a with
+  | xH => 1%positive
+  | xO a' => xO (floor_pos a')
+  | xI b' => xO (floor_pos b')
+  end.
+
+Definition floor (a:positive) := Zpos (floor_pos a).
+
+Lemma floor_gt0 : forall p:positive, floor p > 0.
+Proof.
+intro.
+compute in |- *.
+trivial.
+Qed.
+
+Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. 
+Proof.
+unfold floor in |- *.
+intro a; induction a as [p| p| ].
+
+simpl in |- *.
+repeat rewrite BinInt.Zpos_xI.
+rewrite (BinInt.Zpos_xO (xO (floor_pos p))). 
+rewrite (BinInt.Zpos_xO (floor_pos p)).
+omega.
+
+simpl in |- *.
+repeat rewrite BinInt.Zpos_xI.
+rewrite (BinInt.Zpos_xO (xO (floor_pos p))).
+rewrite (BinInt.Zpos_xO (floor_pos p)).
+rewrite (BinInt.Zpos_xO p).
+omega.
+
+simpl in |- *; omega.
+Qed.
+
+(**********************************************************************)
+(** Two more induction principles over [Z]. *)
+
+Theorem Z_lt_abs_rec :
+ forall P:Z -> Set,
+   (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
+   forall n:Z, P n.
+Proof.
+intros P HP p.
+set (Q := fun z => 0 <= z -> P z * P (- z)) in *.
+cut (Q (Zabs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ].
+elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
+unfold Q in |- *; clear Q; intros.
+apply pair; apply HP.
+rewrite Zabs_eq; auto; intros.
+elim (H (Zabs m)); intros; auto with zarith.
+elim (Zabs_dec m); intro eq; rewrite eq; trivial.
+rewrite Zabs_non_eq; auto with zarith.
+rewrite Zopp_involutive; intros.
+elim (H (Zabs m)); intros; auto with zarith.
+elim (Zabs_dec m); intro eq; rewrite eq; trivial.
+Qed.
+
+Theorem Z_lt_abs_induction :
+ forall P:Z -> Prop,
+   (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
+   forall n:Z, P n.
+Proof.
+intros P HP p.
+set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *.
+cut (Q (Zabs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ].
+elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
+unfold Q in |- *; clear Q; intros.
+split; apply HP.
+rewrite Zabs_eq; auto; intros.
+elim (H (Zabs m)); intros; auto with zarith.
+elim (Zabs_dec m); intro eq; rewrite eq; trivial.
+rewrite Zabs_non_eq; auto with zarith.
+rewrite Zopp_involutive; intros.
+elim (H (Zabs m)); intros; auto with zarith.
+elim (Zabs_dec m); intro eq; rewrite eq; trivial.
+Qed.
+
+(** To do case analysis over the sign of [z] *) 
+
+Lemma Zcase_sign :
+ forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P.
+Proof.
+intros x P Hzero Hpos Hneg.
+induction  x as [| p| p].
+apply Hzero; trivial.
+apply Hpos; apply Zorder.Zgt_pos_0.
+apply Hneg; apply Zorder.Zlt_neg_0.
+Qed.
+
+Lemma sqr_pos : forall n:Z, n * n >= 0.
+Proof.
+intro x.
+apply (Zcase_sign x (x * x >= 0)).
+intros H; rewrite H; omega.
+intros H; replace 0 with (0 * 0).
+apply Zmult_ge_compat; omega.
+omega.
+intros H; replace 0 with (0 * 0).
+replace (x * x) with (- x * - x).
+apply Zmult_ge_compat; omega.
+ring.
+omega.
+Qed.
+
+(**********************************************************************)
+(** A list length in Z, tail recursive.  *)
+
+Require Import List.
+
+Fixpoint Zlength_aux (acc:Z) (A:Set) (l:list A) {struct l} : Z :=
+  match l with
+  | nil => acc
+  | _ :: l => Zlength_aux (Zsucc acc) A l
+  end. 
+
+Definition Zlength := Zlength_aux 0.
+Implicit Arguments Zlength [A].
+
+Section Zlength_properties.
+
+Variable A : Set.
+
+Implicit Type l : list A.
+
+Lemma Zlength_correct : forall l, Zlength l = Z_of_nat (length l).
+Proof.
+assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)). 
+simple induction l.
+simpl in |- *; auto with zarith.
+intros; simpl (length (a :: l0)) in |- *; rewrite Znat.inj_S.
+simpl in |- *; rewrite H; auto with zarith.
+unfold Zlength in |- *; intros; rewrite H; auto.
+Qed.
+
+Lemma Zlength_nil : Zlength (A:=A) nil = 0.
+Proof.
+auto.
+Qed.
+
+Lemma Zlength_cons : forall (x:A) l, Zlength (x :: l) = Zsucc (Zlength l).
+Proof.
+intros; do 2 rewrite Zlength_correct.
+simpl (length (x :: l)) in |- *; rewrite Znat.inj_S; auto.
+Qed.
+
+Lemma Zlength_nil_inv : forall l, Zlength l = 0 -> l = nil.
+Proof.
+intro l; rewrite Zlength_correct.
+case l; auto.
+intros x l'; simpl (length (x :: l')) in |- *.
+rewrite Znat.inj_S.
+intros; elimtype False; generalize (Zle_0_nat (length l')); omega.
+Qed.
+
+End Zlength_properties.
+
+Implicit Arguments Zlength_correct [A].
+Implicit Arguments Zlength_cons [A].
+Implicit Arguments Zlength_nil_inv [A].
\ No newline at end of file
diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v
new file mode 100644
index 00000000..84eb2259
--- /dev/null
+++ b/theories/ZArith/Zdiv.v
@@ -0,0 +1,423 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Zdiv.v,v 1.21.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+(* Contribution by Claude Marché and Xavier Urbain *)
+
+(**
+
+Euclidean Division
+
+Defines first of function that allows Coq to normalize. 
+Then only after proves the main required property.
+
+*)
+
+Require Export ZArith_base.
+Require Import Zbool.
+Require Import Omega.
+Require Import ZArithRing.
+Require Import Zcomplements.
+Open Local Scope Z_scope.
+
+(**
+
+  Euclidean division of a positive by a integer 
+  (that is supposed to be positive).
+
+  total function than returns an arbitrary value when
+  divisor is not positive
+  
+*)
+
+Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} : 
+ Z * Z :=
+  match a with
+  | xH => if Zge_bool b 2 then (0, 1) else (1, 0)
+  | xO a' =>
+      let (q, r) := Zdiv_eucl_POS a' b in
+      let r' := 2 * r in
+      if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b)
+  | xI a' =>
+      let (q, r) := Zdiv_eucl_POS a' b in
+      let r' := 2 * r + 1 in
+      if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b)
+  end.
+
+
+(**
+
+  Euclidean division of integers.
+ 
+  Total function than returns (0,0) when dividing by 0. 
+
+*) 
+    
+(* 
+
+  The pseudo-code is:
+  
+  if b = 0 : (0,0)
+ 
+  if b <> 0 and a = 0 : (0,0)
+
+  if b > 0 and a < 0 : let (q,r) = div_eucl_pos (-a) b in 
+                       if r = 0 then (-q,0) else (-(q+1),b-r)
+
+  if b < 0 and a < 0 : let (q,r) = div_eucl (-a) (-b) in (q,-r)
+
+  if b < 0 and a > 0 : let (q,r) = div_eucl a (-b) in 
+                       if r = 0 then (-q,0) else (-(q+1),b+r)
+
+  In other word, when b is non-zero, q is chosen to be the greatest integer 
+  smaller or equal to a/b. And sgn(r)=sgn(b) and |r| < |b|.
+
+*)
+
+Definition Zdiv_eucl (a b:Z) : Z * Z :=
+  match a, b with
+  | Z0, _ => (0, 0)
+  | _, Z0 => (0, 0)
+  | Zpos a', Zpos _ => Zdiv_eucl_POS a' b
+  | Zneg a', Zpos _ =>
+      let (q, r) := Zdiv_eucl_POS a' b in
+      match r with
+      | Z0 => (- q, 0)
+      | _ => (- (q + 1), b - r)
+      end
+  | Zneg a', Zneg b' => let (q, r) := Zdiv_eucl_POS a' (Zpos b') in (q, - r)
+  | Zpos a', Zneg b' =>
+      let (q, r) := Zdiv_eucl_POS a' (Zpos b') in
+      match r with
+      | Z0 => (- q, 0)
+      | _ => (- (q + 1), b + r)
+      end
+  end.
+
+
+(** Division and modulo are projections of [Zdiv_eucl] *)
+     
+Definition Zdiv (a b:Z) : Z := let (q, _) := Zdiv_eucl a b in q.
+
+Definition Zmod (a b:Z) : Z := let (_, r) := Zdiv_eucl a b in r. 
+
+(* Tests:
+
+Eval Compute in `(Zdiv_eucl 7 3)`. 
+
+Eval Compute in `(Zdiv_eucl (-7) 3)`.
+
+Eval Compute in `(Zdiv_eucl 7 (-3))`.
+
+Eval Compute in `(Zdiv_eucl (-7) (-3))`.
+
+*)
+
+
+(**
+
+  Main division theorem. 
+
+  First a lemma for positive
+
+*)
+
+Lemma Z_div_mod_POS :
+ forall b:Z,
+   b > 0 ->
+   forall a:positive,
+     let (q, r) := Zdiv_eucl_POS a b in Zpos a = b * q + r /\ 0 <= r < b.
+Proof.
+simple induction a; unfold Zdiv_eucl_POS in |- *; fold Zdiv_eucl_POS in |- *.
+
+intro p; case (Zdiv_eucl_POS p b); intros q r [H0 H1].
+generalize (Zgt_cases b (2 * r + 1)).
+case (Zgt_bool b (2 * r + 1));
+ (rewrite BinInt.Zpos_xI; rewrite H0; split; [ ring | omega ]).
+
+intros p; case (Zdiv_eucl_POS p b); intros q r [H0 H1].
+generalize (Zgt_cases b (2 * r)).
+case (Zgt_bool b (2 * r)); rewrite BinInt.Zpos_xO;
+ change (Zpos (xO p)) with (2 * Zpos p) in |- *; rewrite H0;
+ (split; [ ring | omega ]).
+
+generalize (Zge_cases b 2).
+case (Zge_bool b 2); (intros; split; [ ring | omega ]).
+omega.
+Qed.
+
+
+Theorem Z_div_mod :
+ forall a b:Z,
+   b > 0 -> let (q, r) := Zdiv_eucl a b in a = b * q + r /\ 0 <= r < b.
+Proof.
+intros a b; case a; case b; try (simpl in |- *; intros; omega).
+unfold Zdiv_eucl in |- *; intros; apply Z_div_mod_POS; trivial.
+
+intros; discriminate.
+
+intros.
+generalize (Z_div_mod_POS (Zpos p) H p0).
+unfold Zdiv_eucl in |- *.
+case (Zdiv_eucl_POS p0 (Zpos p)).
+intros z z0.
+case z0.
+
+intros [H1 H2].
+split; trivial.
+replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ].
+
+intros p1 [H1 H2].
+split; trivial.
+replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ].
+generalize (Zorder.Zgt_pos_0 p1); omega.
+
+intros p1 [H1 H2].
+split; trivial.
+replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ].
+generalize (Zorder.Zlt_neg_0 p1); omega.
+
+intros; discriminate.
+Qed.
+
+(** Existence theorems *)
+
+Theorem Zdiv_eucl_exist :
+ forall b:Z,
+   b > 0 ->
+   forall a:Z, {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < b}.
+Proof.
+intros b Hb a.
+exists (Zdiv_eucl a b).
+exact (Z_div_mod a b Hb).
+Qed.
+
+Implicit Arguments Zdiv_eucl_exist.
+
+Theorem Zdiv_eucl_extended :
+ forall b:Z,
+   b <> 0 ->
+   forall a:Z,
+     {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < Zabs b}.
+Proof.
+intros b Hb a.
+elim (Z_le_gt_dec 0 b); intro Hb'.
+cut (b > 0); [ intro Hb'' | omega ].
+rewrite Zabs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ].
+cut (- b > 0); [ intro Hb'' | omega ].
+elim (Zdiv_eucl_exist Hb'' a); intros qr.
+elim qr; intros q r Hqr.
+exists (- q, r).
+elim Hqr; intros.
+split.
+rewrite <- Zmult_opp_comm; assumption.
+rewrite Zabs_non_eq; [ assumption | omega ].
+Qed.
+
+Implicit Arguments Zdiv_eucl_extended.
+
+(** Auxiliary lemmas about [Zdiv] and [Zmod] *)
+
+Lemma Z_div_mod_eq : forall a b:Z, b > 0 -> a = b * Zdiv a b + Zmod a b.
+Proof.
+unfold Zdiv, Zmod in |- *.
+intros a b Hb.
+generalize (Z_div_mod a b Hb).
+case Zdiv_eucl; tauto.
+Qed.
+
+Lemma Z_mod_lt : forall a b:Z, b > 0 -> 0 <= Zmod a b < b.
+Proof.
+unfold Zmod in |- *.
+intros a b Hb.
+generalize (Z_div_mod a b Hb).
+case (Zdiv_eucl a b); tauto.
+Qed.
+
+Lemma Z_div_POS_ge0 :
+ forall (b:Z) (a:positive), let (q, _) := Zdiv_eucl_POS a b in q >= 0.
+Proof.
+simple induction a; unfold Zdiv_eucl_POS in |- *; fold Zdiv_eucl_POS in |- *.
+intro p; case (Zdiv_eucl_POS p b).
+intros; case (Zgt_bool b (2 * z0 + 1)); intros; omega.
+intro p; case (Zdiv_eucl_POS p b).
+intros; case (Zgt_bool b (2 * z0)); intros; omega.
+case (Zge_bool b 2); simpl in |- *; omega.
+Qed.
+
+Lemma Z_div_ge0 : forall a b:Z, b > 0 -> a >= 0 -> Zdiv a b >= 0.
+Proof.
+intros a b Hb; unfold Zdiv, Zdiv_eucl in |- *; case a; simpl in |- *; intros.
+case b; simpl in |- *; trivial.
+generalize Hb; case b; try trivial.
+auto with zarith.
+intros p0 Hp0; generalize (Z_div_POS_ge0 (Zpos p0) p).
+case (Zdiv_eucl_POS p (Zpos p0)); simpl in |- *; tauto.
+intros; discriminate.
+elim H; trivial.
+Qed.
+
+Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> Zdiv a b < a.
+Proof.
+intros. cut (b > 0); [ intro Hb | omega ].
+generalize (Z_div_mod a b Hb).
+cut (a >= 0); [ intro Ha | omega ].
+generalize (Z_div_ge0 a b Hb Ha).
+unfold Zdiv in |- *; case (Zdiv_eucl a b); intros q r H1 [H2 H3].
+cut (a >= 2 * q -> q < a); [ intro h; apply h; clear h | intros; omega ].
+apply Zge_trans with (b * q).
+omega.
+auto with zarith.
+Qed.
+
+(** Syntax *)
+
+
+
+Infix "/" := Zdiv : Z_scope.
+Infix "mod" := Zmod (at level 40, no associativity) : Z_scope.
+
+(** Other lemmas (now using the syntax for [Zdiv] and [Zmod]). *)
+
+Lemma Z_div_ge : forall a b c:Z, c > 0 -> a >= b -> a / c >= b / c.
+Proof.
+intros a b c cPos aGeb.
+generalize (Z_div_mod_eq a c cPos).
+generalize (Z_mod_lt a c cPos).
+generalize (Z_div_mod_eq b c cPos).
+generalize (Z_mod_lt b c cPos).
+intros.
+elim (Z_ge_lt_dec (a / c) (b / c)); trivial.
+intro.
+absurd (b - a >= 1).
+omega.
+rewrite H0.
+rewrite H2.
+assert
+ (c * (b / c) + b mod c - (c * (a / c) + a mod c) =
+  c * (b / c - a / c) + b mod c - a mod c).
+ring.
+rewrite H3.
+assert (c * (b / c - a / c) >= c * 1).
+apply Zmult_ge_compat_l.
+omega.
+omega.
+assert (c * 1 = c).
+ring.
+omega.
+Qed.
+
+Lemma Z_mod_plus : forall a b c:Z, c > 0 -> (a + b * c) mod c = a mod c.
+Proof.
+intros a b c cPos.
+generalize (Z_div_mod_eq a c cPos).
+generalize (Z_mod_lt a c cPos).
+generalize (Z_div_mod_eq (a + b * c) c cPos).
+generalize (Z_mod_lt (a + b * c) c cPos).
+intros.
+
+assert ((a + b * c) mod c - a mod c = c * (b + a / c - (a + b * c) / c)).
+replace ((a + b * c) mod c) with (a + b * c - c * ((a + b * c) / c)).
+replace (a mod c) with (a - c * (a / c)).
+ring.
+omega.
+omega.
+set (q := b + a / c - (a + b * c) / c) in *.
+apply (Zcase_sign q); intros.
+assert (c * q = 0).
+rewrite H4; ring.
+rewrite H5 in H3.
+omega.
+
+assert (c * q >= c).
+pattern c at 2 in |- *; replace c with (c * 1).
+apply Zmult_ge_compat_l; omega.
+ring.
+omega.
+
+assert (c * q <= - c).
+replace (- c) with (c * -1).
+apply Zmult_le_compat_l; omega.
+ring.
+omega.
+Qed.
+
+Lemma Z_div_plus : forall a b c:Z, c > 0 -> (a + b * c) / c = a / c + b.
+Proof.
+intros a b c cPos.
+generalize (Z_div_mod_eq a c cPos).
+generalize (Z_mod_lt a c cPos).
+generalize (Z_div_mod_eq (a + b * c) c cPos).
+generalize (Z_mod_lt (a + b * c) c cPos).
+intros.
+apply Zmult_reg_l with c. omega.
+replace (c * ((a + b * c) / c)) with (a + b * c - (a + b * c) mod c).
+rewrite (Z_mod_plus a b c cPos).
+pattern a at 1 in |- *; rewrite H2.
+ring.
+pattern (a + b * c) at 1 in |- *; rewrite H0.
+ring.
+Qed.
+
+Lemma Z_div_mult : forall a b:Z, b > 0 -> a * b / b = a.
+intros; replace (a * b) with (0 + a * b); auto.
+rewrite Z_div_plus; auto.
+Qed.
+
+Lemma Z_mult_div_ge : forall a b:Z, b > 0 -> b * (a / b) <= a.
+Proof.
+intros a b bPos.
+generalize (Z_div_mod_eq a _ bPos); intros.
+generalize (Z_mod_lt a _ bPos); intros.
+pattern a at 2 in |- *; rewrite H.
+omega.
+Qed.
+
+Lemma Z_mod_same : forall a:Z, a > 0 -> a mod a = 0.
+Proof.
+intros a aPos.
+generalize (Z_mod_plus 0 1 a aPos).
+replace (0 + 1 * a) with a.
+intros.
+rewrite H.
+compute in |- *.
+trivial.
+ring.
+Qed.
+
+Lemma Z_div_same : forall a:Z, a > 0 -> a / a = 1.
+Proof.
+intros a aPos.
+generalize (Z_div_plus 0 1 a aPos).
+replace (0 + 1 * a) with a.
+intros.
+rewrite H.
+compute in |- *.
+trivial.
+ring.
+Qed.
+
+Lemma Z_div_exact_1 : forall a b:Z, b > 0 -> a = b * (a / b) -> a mod b = 0.
+intros a b Hb; generalize (Z_div_mod a b Hb); unfold Zmod, Zdiv in |- *.
+case (Zdiv_eucl a b); intros q r; omega.
+Qed.
+
+Lemma Z_div_exact_2 : forall a b:Z, b > 0 -> a mod b = 0 -> a = b * (a / b).
+intros a b Hb; generalize (Z_div_mod a b Hb); unfold Zmod, Zdiv in |- *.
+case (Zdiv_eucl a b); intros q r; omega.
+Qed.
+
+Lemma Z_mod_zero_opp : forall a b:Z, b > 0 -> a mod b = 0 -> - a mod b = 0.
+intros a b Hb.
+intros.
+rewrite Z_div_exact_2 with a b; auto.
+replace (- (b * (a / b))) with (0 + - (a / b) * b).
+rewrite Z_mod_plus; auto.
+ring.
+Qed.
diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v
new file mode 100644
index 00000000..a4a9abde
--- /dev/null
+++ b/theories/ZArith/Zeven.v
@@ -0,0 +1,204 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Zeven.v,v 1.3.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+Require Import BinInt.
+
+(**********************************************************************)
+(** About parity: even and odd predicates on Z, division by 2 on Z *)
+
+(**********************************************************************)
+(** [Zeven], [Zodd], [Zdiv2] and their related properties *)
+
+Definition Zeven (z:Z) :=
+  match z with
+  | Z0 => True
+  | Zpos (xO _) => True
+  | Zneg (xO _) => True
+  | _ => False
+  end.
+
+Definition Zodd (z:Z) :=
+  match z with
+  | Zpos xH => True
+  | Zneg xH => True
+  | Zpos (xI _) => True
+  | Zneg (xI _) => True
+  | _ => False
+  end.
+
+Definition Zeven_bool (z:Z) :=
+  match z with
+  | Z0 => true
+  | Zpos (xO _) => true
+  | Zneg (xO _) => true
+  | _ => false
+  end.
+
+Definition Zodd_bool (z:Z) :=
+  match z with
+  | Z0 => false
+  | Zpos (xO _) => false
+  | Zneg (xO _) => false
+  | _ => true
+  end.
+
+Definition Zeven_odd_dec : forall z:Z, {Zeven z} + {Zodd z}.
+Proof.
+  intro z. case z;
+  [ left; compute in |- *; trivial
+  | intro p; case p; intros;
+     (right; compute in |- *; exact I) || (left; compute in |- *; exact I)
+  | intro p; case p; intros;
+     (right; compute in |- *; exact I) || (left; compute in |- *; exact I) ].
+Defined.
+
+Definition Zeven_dec : forall z:Z, {Zeven z} + {~ Zeven z}.
+Proof.
+  intro z. case z;
+  [ left; compute in |- *; trivial
+  | intro p; case p; intros;
+     (left; compute in |- *; exact I) || (right; compute in |- *; trivial)
+  | intro p; case p; intros;
+     (left; compute in |- *; exact I) || (right; compute in |- *; trivial) ].
+Defined.
+
+Definition Zodd_dec : forall z:Z, {Zodd z} + {~ Zodd z}.
+Proof.
+  intro z. case z;
+  [ right; compute in |- *; trivial
+  | intro p; case p; intros;
+     (left; compute in |- *; exact I) || (right; compute in |- *; trivial)
+  | intro p; case p; intros;
+     (left; compute in |- *; exact I) || (right; compute in |- *; trivial) ].
+Defined.
+
+Lemma Zeven_not_Zodd : forall n:Z, Zeven n -> ~ Zodd n.
+Proof.
+  intro z; destruct z; [ idtac | destruct p | destruct p ]; compute in |- *;
+   trivial.
+Qed.
+
+Lemma Zodd_not_Zeven : forall n:Z, Zodd n -> ~ Zeven n.
+Proof.
+  intro z; destruct z; [ idtac | destruct p | destruct p ]; compute in |- *;
+   trivial.
+Qed.
+
+Lemma Zeven_Sn : forall n:Z, Zodd n -> Zeven (Zsucc n).
+Proof.
+ intro z; destruct z; unfold Zsucc in |- *;
+  [ idtac | destruct p | destruct p ]; simpl in |- *; 
+  trivial. 
+ unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+Qed.
+
+Lemma Zodd_Sn : forall n:Z, Zeven n -> Zodd (Zsucc n).
+Proof.
+ intro z; destruct z; unfold Zsucc in |- *;
+  [ idtac | destruct p | destruct p ]; simpl in |- *; 
+  trivial. 
+ unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+Qed.
+
+Lemma Zeven_pred : forall n:Z, Zodd n -> Zeven (Zpred n).
+Proof.
+ intro z; destruct z; unfold Zpred in |- *;
+  [ idtac | destruct p | destruct p ]; simpl in |- *; 
+  trivial. 
+ unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+Qed.
+
+Lemma Zodd_pred : forall n:Z, Zeven n -> Zodd (Zpred n).
+Proof.
+ intro z; destruct z; unfold Zpred in |- *;
+  [ idtac | destruct p | destruct p ]; simpl in |- *; 
+  trivial. 
+ unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+Qed.
+
+Hint Unfold Zeven Zodd: zarith.
+
+(**********************************************************************)
+(** [Zdiv2] is defined on all [Z], but notice that for odd negative
+    integers it is not the euclidean quotient: in that case we have [n =
+    2*(n/2)-1] *)
+
+Definition Zdiv2 (z:Z) :=
+  match z with
+  | Z0 => 0%Z
+  | Zpos xH => 0%Z
+  | Zpos p => Zpos (Pdiv2 p)
+  | Zneg xH => 0%Z
+  | Zneg p => Zneg (Pdiv2 p)
+  end.
+
+Lemma Zeven_div2 : forall n:Z, Zeven n -> n = (2 * Zdiv2 n)%Z.
+Proof.
+intro x; destruct x.
+auto with arith.
+destruct p; auto with arith.
+intros. absurd (Zeven (Zpos (xI p))); red in |- *; auto with arith.
+intros. absurd (Zeven 1); red in |- *; auto with arith.
+destruct p; auto with arith.
+intros. absurd (Zeven (Zneg (xI p))); red in |- *; auto with arith.
+intros. absurd (Zeven (-1)); red in |- *; auto with arith.
+Qed.
+
+Lemma Zodd_div2 : forall n:Z, (n >= 0)%Z -> Zodd n -> n = (2 * Zdiv2 n + 1)%Z.
+Proof.
+intro x; destruct x.
+intros. absurd (Zodd 0); red in |- *; auto with arith.
+destruct p; auto with arith.
+intros. absurd (Zodd (Zpos (xO p))); red in |- *; auto with arith.
+intros. absurd (Zneg p >= 0)%Z; red in |- *; auto with arith.
+Qed.
+
+Lemma Zodd_div2_neg :
+ forall n:Z, (n <= 0)%Z -> Zodd n -> n = (2 * Zdiv2 n - 1)%Z.
+Proof.
+intro x; destruct x.
+intros. absurd (Zodd 0); red in |- *; auto with arith.
+intros. absurd (Zneg p >= 0)%Z; red in |- *; auto with arith.
+destruct p; auto with arith.
+intros. absurd (Zodd (Zneg (xO p))); red in |- *; auto with arith.
+Qed.
+
+Lemma Z_modulo_2 :
+ forall n:Z, {y : Z | n = (2 * y)%Z} + {y : Z | n = (2 * y + 1)%Z}.
+Proof.
+intros x.
+elim (Zeven_odd_dec x); intro.
+left. split with (Zdiv2 x). exact (Zeven_div2 x a).
+right. generalize b; clear b; case x.
+intro b; inversion b.
+intro p; split with (Zdiv2 (Zpos p)). apply (Zodd_div2 (Zpos p)); trivial.
+unfold Zge, Zcompare in |- *; simpl in |- *; discriminate.
+intro p; split with (Zdiv2 (Zpred (Zneg p))).
+pattern (Zneg p) at 1 in |- *; rewrite (Zsucc_pred (Zneg p)).
+pattern (Zpred (Zneg p)) at 1 in |- *; rewrite (Zeven_div2 (Zpred (Zneg p))).
+reflexivity.
+apply Zeven_pred; assumption.
+Qed.
+
+Lemma Zsplit2 :
+ forall n:Z,
+   {p : Z * Z |
+   let (x1, x2) := p in n = (x1 + x2)%Z /\ (x1 = x2 \/ x2 = (x1 + 1)%Z)}.
+Proof.
+intros x.
+elim (Z_modulo_2 x); intros [y Hy]; rewrite Zmult_comm in Hy;
+ rewrite <- Zplus_diag_eq_mult_2 in Hy.
+exists (y, y); split. 
+assumption.
+left; reflexivity.
+exists (y, (y + 1)%Z); split.
+rewrite Zplus_assoc; assumption.
+right; reflexivity.
+Qed.
\ No newline at end of file
diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v
new file mode 100644
index 00000000..a9ee2c87
--- /dev/null
+++ b/theories/ZArith/Zhints.v
@@ -0,0 +1,386 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Zhints.v,v 1.8.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+(** This file centralizes the lemmas about [Z], classifying them
+    according to the way they can be used in automatic search  *)
+
+(*i*)
+
+(* Lemmas which clearly leads to simplification during proof search are *)
+(* declared as Hints. A definite status (Hint or not) for the other lemmas *)
+(* remains to be given *)
+
+(* Structure of the file *)
+(* - simplification lemmas (only those are declared as Hints) *)
+(* - reversible lemmas relating operators *)
+(* - useful Bottom-up lemmas              *)
+(* - irreversible lemmas with meta-variables *)
+(* - unclear or too specific lemmas       *)
+(* - lemmas to be used as rewrite rules   *)
+
+(* Lemmas involving positive and compare are not taken into account *)
+
+Require Import BinInt.
+Require Import Zorder.
+Require Import Zmin.
+Require Import Zabs.
+Require Import Zcompare.
+Require Import Znat.
+Require Import auxiliary.
+Require Import Zmisc.
+Require Import Wf_Z.
+
+(**********************************************************************)
+(*                  Simplification lemmas                             *)
+(* No subgoal or smaller subgoals                                     *)
+
+Hint Resolve 
+  (* A) Reversible simplification lemmas (no loss of information)      *)
+  (* Should clearly declared as hints                                  *)
+  
+  (* Lemmas ending by eq *)
+  Zsucc_eq_compat (* :(n,m:Z)`n = m`->`(Zs n) = (Zs m)` *)
+  
+  (* Lemmas ending by Zgt *)
+  Zsucc_gt_compat (* :(n,m:Z)`m > n`->`(Zs m) > (Zs n)` *)
+  Zgt_succ (* :(n:Z)`(Zs n) > n` *)
+  Zorder.Zgt_pos_0 (* :(p:positive)`(POS p) > 0` *)
+  Zplus_gt_compat_l (* :(n,m,p:Z)`n > m`->`p+n > p+m` *)
+  Zplus_gt_compat_r (* :(n,m,p:Z)`n > m`->`n+p > m+p` *)
+  
+  (* Lemmas ending by Zlt *)
+  Zlt_succ (* :(n:Z)`n < (Zs n)` *)
+  Zsucc_lt_compat (* :(n,m:Z)`n < m`->`(Zs n) < (Zs m)` *)
+  Zlt_pred (* :(n:Z)`(Zpred n) < n` *)
+  Zplus_lt_compat_l (* :(n,m,p:Z)`n < m`->`p+n < p+m` *)
+  Zplus_lt_compat_r (* :(n,m,p:Z)`n < m`->`n+p < m+p` *)
+  
+  (* Lemmas ending by Zle *)
+  Zle_0_nat (* :(n:nat)`0 <= (inject_nat n)` *)
+  Zorder.Zle_0_pos (* :(p:positive)`0 <= (POS p)` *)
+  Zle_refl (* :(n:Z)`n <= n` *)
+  Zle_succ (* :(n:Z)`n <= (Zs n)` *)
+  Zsucc_le_compat (* :(n,m:Z)`m <= n`->`(Zs m) <= (Zs n)` *)
+  Zle_pred (* :(n:Z)`(Zpred n) <= n` *)
+  Zle_min_l (* :(n,m:Z)`(Zmin n m) <= n` *)
+  Zle_min_r (* :(n,m:Z)`(Zmin n m) <= m` *)
+  Zplus_le_compat_l (* :(n,m,p:Z)`n <= m`->`p+n <= p+m` *)
+  Zplus_le_compat_r (* :(a,b,c:Z)`a <= b`->`a+c <= b+c` *)
+  Zabs_pos (* :(x:Z)`0 <= |x|` *)
+  
+  (* B) Irreversible simplification lemmas : Probably to be declared as *)
+  (* hints, when no other simplification is possible *)
+  
+  (* Lemmas ending by eq *)
+  BinInt.Z_eq_mult (* :(x,y:Z)`y = 0`->`y*x = 0` *)
+  Zplus_eq_compat (* :(n,m,p,q:Z)`n = m`->`p = q`->`n+p = m+q` *)
+  
+  (* Lemmas ending by Zge *)
+  Zorder.Zmult_ge_compat_r (* :(a,b,c:Z)`a >= b`->`c >= 0`->`a*c >= b*c` *)
+  Zorder.Zmult_ge_compat_l (* :(a,b,c:Z)`a >= b`->`c >= 0`->`c*a >= c*b` *)
+  Zorder.Zmult_ge_compat (* :
+      (a,b,c,d:Z)`a >= c`->`b >= d`->`c >= 0`->`d >= 0`->`a*b >= c*d` *)
+  
+  (* Lemmas ending by Zlt *)
+  Zorder.Zmult_gt_0_compat (* :(a,b:Z)`a > 0`->`b > 0`->`a*b > 0` *)
+  Zlt_lt_succ (* :(n,m:Z)`n < m`->`n < (Zs m)` *)
+  
+  (* Lemmas ending by Zle *)
+  Zorder.Zmult_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x*y` *)
+  Zorder.Zmult_le_compat_r (* :(a,b,c:Z)`a <= b`->`0 <= c`->`a*c <= b*c` *)
+  Zorder.Zmult_le_compat_l (* :(a,b,c:Z)`a <= b`->`0 <= c`->`c*a <= c*b` *)
+  Zplus_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x+y` *)
+  Zle_le_succ (* :(x,y:Z)`x <= y`->`x <= (Zs y)` *)
+  Zplus_le_compat (* :(n,m,p,q:Z)`n <= m`->`p <= q`->`n+p <= m+q` *)
+  
+  : zarith.
+  
+(**********************************************************************)
+(*         Reversible lemmas relating operators                       *)
+(* Probably to be declared as hints but need to define precedences    *)
+
+(* A) Conversion between comparisons/predicates and arithmetic operators
+
+(* Lemmas ending by eq *)
+Zegal_left: (x,y:Z)`x = y`->`x+(-y) = 0`
+Zabs_eq: (x:Z)`0 <= x`->`|x| = x`
+Zeven_div2: (x:Z)(Zeven x)->`x = 2*(Zdiv2 x)`
+Zodd_div2: (x:Z)`x >= 0`->(Zodd x)->`x = 2*(Zdiv2 x)+1`
+
+(* Lemmas ending by Zgt *)
+Zgt_left_rev: (x,y:Z)`x+(-y) > 0`->`x > y`
+Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0`
+
+(* Lemmas ending by Zlt *)
+Zlt_left_rev: (x,y:Z)`0 < y+(-x)`->`x < y`
+Zlt_left_lt: (x,y:Z)`x < y`->`0 < y+(-x)`
+Zlt_O_minus_lt: (n,m:Z)`0 < n-m`->`m < n`
+
+(* Lemmas ending by Zle *)
+Zle_left: (x,y:Z)`x <= y`->`0 <= y+(-x)`
+Zle_left_rev: (x,y:Z)`0 <= y+(-x)`->`x <= y`
+Zlt_left: (x,y:Z)`x < y`->`0 <= y+(-1)+(-x)`
+Zge_left: (x,y:Z)`x >= y`->`0 <= x+(-y)`
+Zgt_left: (x,y:Z)`x > y`->`0 <= x+(-1)+(-y)`
+
+(* B) Conversion between nat comparisons and Z comparisons *)
+
+(* Lemmas ending by eq *)
+inj_eq: (x,y:nat)x=y->`(inject_nat x) = (inject_nat y)`
+
+(* Lemmas ending by Zge *)
+inj_ge: (x,y:nat)(ge x y)->`(inject_nat x) >= (inject_nat y)`
+
+(* Lemmas ending by Zgt *)
+inj_gt: (x,y:nat)(gt x y)->`(inject_nat x) > (inject_nat y)`
+
+(* Lemmas ending by Zlt *)
+inj_lt: (x,y:nat)(lt x y)->`(inject_nat x) < (inject_nat y)`
+
+(* Lemmas ending by Zle *)
+inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)`
+
+(* C) Conversion between comparisons *)
+
+(* Lemmas ending by Zge *)
+not_Zlt: (x,y:Z)~`x < y`->`x >= y`
+Zle_ge: (m,n:Z)`m <= n`->`n >= m`
+
+(* Lemmas ending by Zgt *)
+Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n`
+not_Zle: (x,y:Z)~`x <= y`->`x > y`
+Zlt_gt: (m,n:Z)`m < n`->`n > m`
+Zle_S_gt: (n,m:Z)`(Zs n) <= m`->`m > n`
+
+(* Lemmas ending by Zlt *)
+not_Zge: (x,y:Z)~`x >= y`->`x < y`
+Zgt_lt: (m,n:Z)`m > n`->`n < m`
+Zle_lt_n_Sm: (n,m:Z)`n <= m`->`n < (Zs m)`
+
+(* Lemmas ending by Zle *)
+Zlt_ZERO_pred_le_ZERO: (x:Z)`0 < x`->`0 <= (Zpred x)`
+not_Zgt: (x,y:Z)~`x > y`->`x <= y`
+Zgt_le_S: (n,p:Z)`p > n`->`(Zs n) <= p`
+Zgt_S_le: (n,p:Z)`(Zs p) > n`->`n <= p`
+Zge_le: (m,n:Z)`m >= n`->`n <= m`
+Zlt_le_S: (n,p:Z)`n < p`->`(Zs n) <= p`
+Zlt_n_Sm_le: (n,m:Z)`n < (Zs m)`->`n <= m`
+Zlt_le_weak: (n,m:Z)`n < m`->`n <= m`
+Zle_refl: (n,m:Z)`n = m`->`n <= m`
+
+(* D) Irreversible simplification involving several comparaisons, *)
+(*    useful with clear precedences *)
+
+(* Lemmas ending by Zlt *)
+Zlt_le_reg :(a,b,c,d:Z)`a < b`->`c <= d`->`a+c < b+d`
+Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d`
+
+(* D) What is decreasing here ? *)
+
+(* Lemmas ending by eq *)
+Zplus_minus: (n,m,p:Z)`n = m+p`->`p = n-m`
+
+(* Lemmas ending by Zgt *)
+Zgt_pred: (n,p:Z)`p > (Zs n)`->`(Zpred p) > n`
+
+(* Lemmas ending by Zlt *)
+Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)`
+
+*)
+
+(**********************************************************************)
+(*                 Useful Bottom-up lemmas                            *)
+
+(* A) Bottom-up simplification: should be used 
+
+(* Lemmas ending by eq *)
+Zeq_add_S: (n,m:Z)`(Zs n) = (Zs m)`->`n = m`
+Zsimpl_plus_l: (n,m,p:Z)`n+m = n+p`->`m = p`
+Zplus_unit_left: (n,m:Z)`n+0 = m`->`n = m`
+Zplus_unit_right: (n,m:Z)`n = m+0`->`n = m`
+
+(* Lemmas ending by Zgt *)
+Zsimpl_gt_plus_l: (n,m,p:Z)`p+n > p+m`->`n > m`
+Zsimpl_gt_plus_r: (n,m,p:Z)`n+p > m+p`->`n > m`
+Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n`
+
+(* Lemmas ending by Zlt *)
+Zsimpl_lt_plus_l: (n,m,p:Z)`p+n < p+m`->`n < m`
+Zsimpl_lt_plus_r: (n,m,p:Z)`n+p < m+p`->`n < m`
+Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m`
+
+(* Lemmas ending by Zle *)
+Zsimpl_le_plus_l: (p,n,m:Z)`p+n <= p+m`->`n <= m`
+Zsimpl_le_plus_r: (p,n,m:Z)`n+p <= m+p`->`n <= m`
+Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n`
+
+(* B) Bottom-up irreversible (syntactic) simplification *)
+
+(* Lemmas ending by Zle *)
+Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m`
+
+(* C) Other unclearly simplifying lemmas *)
+
+(* Lemmas ending by Zeq *)
+Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0`
+
+(* Lemmas ending by Zgt *)
+Zmult_gt: (x,y:Z)`x > 0`->`x*y > 0`->`y > 0`
+
+(* Lemmas ending by Zlt *)
+pZmult_lt: (x,y:Z)`x > 0`->`0 < y*x`->`0 < y`
+
+(* Lemmas ending by Zle *)
+Zmult_le: (x,y:Z)`x > 0`->`0 <= y*x`->`0 <= y`
+OMEGA1: (x,y:Z)`x = y`->`0 <= x`->`0 <= y`
+*)
+
+(**********************************************************************)
+(*           Irreversible lemmas with meta-variables                  *)
+(* To be used by EAuto                                                
+
+Hints Immediate
+(* Lemmas ending by eq *)
+Zle_antisym: (n,m:Z)`n <= m`->`m <= n`->`n = m`
+
+(* Lemmas ending by Zge *)
+Zge_trans: (n,m,p:Z)`n >= m`->`m >= p`->`n >= p`
+
+(* Lemmas ending by Zgt *)
+Zgt_trans: (n,m,p:Z)`n > m`->`m > p`->`n > p`
+Zgt_trans_S: (n,m,p:Z)`(Zs n) > m`->`m > p`->`n > p`
+Zle_gt_trans: (n,m,p:Z)`m <= n`->`m > p`->`n > p`
+Zgt_le_trans: (n,m,p:Z)`n > m`->`p <= m`->`n > p`
+
+(* Lemmas ending by Zlt *)
+Zlt_trans: (n,m,p:Z)`n < m`->`m < p`->`n < p`
+Zlt_le_trans: (n,m,p:Z)`n < m`->`m <= p`->`n < p`
+Zle_lt_trans: (n,m,p:Z)`n <= m`->`m < p`->`n < p`
+
+(* Lemmas ending by Zle *)
+Zle_trans: (n,m,p:Z)`n <= m`->`m <= p`->`n <= p`
+*)
+
+(**********************************************************************)
+(*               Unclear or too specific lemmas                       *)
+(* Not to be used ??                                                  *)
+
+(* A) Irreversible and too specific (not enough regular) 
+
+(* Lemmas ending by Zle *)
+Zle_mult: (x,y:Z)`x > 0`->`0 <= y`->`0 <= y*x`
+Zle_mult_approx: (x,y,z:Z)`x > 0`->`z > 0`->`0 <= y`->`0 <= y*x+z`
+OMEGA6: (x,y,z:Z)`0 <= x`->`y = 0`->`0 <= x+y*z`
+OMEGA7: (x,y,z,t:Z)`z > 0`->`t > 0`->`0 <= x`->`0 <= y`->`0 <= x*z+y*t`
+
+
+(* B) Expansion and too specific ? *)
+
+(* Lemmas ending by Zge *)
+Zge_mult_simpl: (a,b,c:Z)`c > 0`->`a*c >= b*c`->`a >= b`
+
+(* Lemmas ending by Zgt *)
+Zgt_mult_simpl: (a,b,c:Z)`c > 0`->`a*c > b*c`->`a > b`
+Zgt_square_simpl: (x,y:Z)`x >= 0`->`y >= 0`->`x*x > y*y`->`x > y`
+
+(* Lemmas ending by Zle *)
+Zle_mult_simpl: (a,b,c:Z)`c > 0`->`a*c <= b*c`->`a <= b`
+Zmult_le_approx: (x,y,z:Z)`x > 0`->`x > z`->`0 <= y*x+z`->`0 <= y`
+
+(* C) Reversible but too specific ? *)
+
+(* Lemmas ending by Zlt *)
+Zlt_minus: (n,m:Z)`0 < m`->`n-m < n`
+*)
+
+(**********************************************************************)
+(*               Lemmas to be used as rewrite rules                   *)
+(* but can also be used as hints                                      
+
+(* Left-to-right simplification lemmas (a symbol disappears) *)
+
+Zcompare_n_S: (n,m:Z)(Zcompare (Zs n) (Zs m))=(Zcompare n m)
+Zmin_n_n: (n:Z)`(Zmin n n) = n`
+Zmult_1_n: (n:Z)`1*n = n`
+Zmult_n_1: (n:Z)`n*1 = n`
+Zminus_plus: (n,m:Z)`n+m-n = m`
+Zle_plus_minus: (n,m:Z)`n+(m-n) = m`
+Zopp_Zopp: (x:Z)`(-(-x)) = x`
+Zero_left: (x:Z)`0+x = x`
+Zero_right: (x:Z)`x+0 = x`
+Zplus_inverse_r: (x:Z)`x+(-x) = 0`
+Zplus_inverse_l: (x:Z)`(-x)+x = 0`
+Zopp_intro: (x,y:Z)`(-x) = (-y)`->`x = y`
+Zmult_one: (x:Z)`1*x = x`
+Zero_mult_left: (x:Z)`0*x = 0`
+Zero_mult_right: (x:Z)`x*0 = 0`
+Zmult_Zopp_Zopp: (x,y:Z)`(-x)*(-y) = x*y`
+
+(* Right-to-left simplification lemmas (a symbol disappears) *)
+
+Zpred_Sn: (m:Z)`m = (Zpred (Zs m))`
+Zs_pred: (n:Z)`n = (Zs (Zpred n))`
+Zplus_n_O: (n:Z)`n = n+0`
+Zmult_n_O: (n:Z)`0 = n*0`
+Zminus_n_O: (n:Z)`n = n-0`
+Zminus_n_n: (n:Z)`0 = n-n`
+Zred_factor6: (x:Z)`x = x+0`
+Zred_factor0: (x:Z)`x = x*1`
+
+(* Unclear orientation (no symbol disappears) *)
+
+Zplus_n_Sm: (n,m:Z)`(Zs (n+m)) = n+(Zs m)`
+Zmult_n_Sm: (n,m:Z)`n*m+n = n*(Zs m)`
+Zmin_SS: (n,m:Z)`(Zs (Zmin n m)) = (Zmin (Zs n) (Zs m))`
+Zplus_assoc_l: (n,m,p:Z)`n+(m+p) = n+m+p`
+Zplus_assoc_r: (n,m,p:Z)`n+m+p = n+(m+p)`
+Zplus_permute: (n,m,p:Z)`n+(m+p) = m+(n+p)`
+Zplus_Snm_nSm: (n,m:Z)`(Zs n)+m = n+(Zs m)`
+Zminus_plus_simpl: (n,m,p:Z)`n-m = p+n-(p+m)`
+Zminus_Sn_m: (n,m:Z)`(Zs (n-m)) = (Zs n)-m`
+Zmult_plus_distr_l: (n,m,p:Z)`(n+m)*p = n*p+m*p`
+Zmult_minus_distr: (n,m,p:Z)`(n-m)*p = n*p-m*p`
+Zmult_assoc_r: (n,m,p:Z)`n*m*p = n*(m*p)`
+Zmult_assoc_l: (n,m,p:Z)`n*(m*p) = n*m*p`
+Zmult_permute: (n,m,p:Z)`n*(m*p) = m*(n*p)`
+Zmult_Sm_n: (n,m:Z)`n*m+m = (Zs n)*m`
+Zmult_Zplus_distr: (x,y,z:Z)`x*(y+z) = x*y+x*z`
+Zmult_plus_distr: (n,m,p:Z)`(n+m)*p = n*p+m*p`
+Zopp_Zplus: (x,y:Z)`(-(x+y)) = (-x)+(-y)`
+Zplus_sym: (x,y:Z)`x+y = y+x`
+Zplus_assoc: (x,y,z:Z)`x+(y+z) = x+y+z`
+Zmult_sym: (x,y:Z)`x*y = y*x`
+Zmult_assoc: (x,y,z:Z)`x*(y*z) = x*y*z`
+Zopp_Zmult: (x,y:Z)`(-x)*y = (-(x*y))`
+Zplus_S_n: (x,y:Z)`(Zs x)+y = (Zs (x+y))`
+Zopp_one: (x:Z)`(-x) = x*(-1)`
+Zopp_Zmult_r: (x,y:Z)`(-(x*y)) = x*(-y)`
+Zmult_Zopp_left: (x,y:Z)`(-x)*y = x*(-y)`
+Zopp_Zmult_l: (x,y:Z)`(-(x*y)) = (-x)*y`
+Zred_factor1: (x:Z)`x+x = x*2`
+Zred_factor2: (x,y:Z)`x+x*y = x*(1+y)`
+Zred_factor3: (x,y:Z)`x*y+x = x*(1+y)`
+Zred_factor4: (x,y,z:Z)`x*y+x*z = x*(y+z)`
+Zminus_Zplus_compatible: (x,y,n:Z)`x+n-(y+n) = x-y`
+Zmin_plus: (x,y,n:Z)`(Zmin (x+n) (y+n)) = (Zmin x y)+n`
+
+(* nat <-> Z *)
+inj_S: (y:nat)`(inject_nat (S y)) = (Zs (inject_nat y))`
+inj_plus: (x,y:nat)`(inject_nat (plus x y)) = (inject_nat x)+(inject_nat y)`
+inj_mult: (x,y:nat)`(inject_nat (mult x y)) = (inject_nat x)*(inject_nat y)`
+inj_minus1:
+ (x,y:nat)(le y x)->`(inject_nat (minus x y)) = (inject_nat x)-(inject_nat y)`
+inj_minus2: (x,y:nat)(gt y x)->`(inject_nat (minus x y)) = 0`
+
+(* Too specific ? *)
+Zred_factor5: (x,y:Z)`x*0+y = y`
+*)
+
+(*i*)
\ No newline at end of file
diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v
new file mode 100644
index 00000000..b575de88
--- /dev/null
+++ b/theories/ZArith/Zlogarithm.v
@@ -0,0 +1,265 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Zlogarithm.v,v 1.14.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+(**********************************************************************)
+(** The integer logarithms with base 2. 
+
+    There are three logarithms,
+    depending on the rounding of the real 2-based logarithm:
+    - [Log_inf]: [y = (Log_inf x) iff 2^y <= x < 2^(y+1)]
+      i.e. [Log_inf x] is the biggest integer that is smaller than [Log x]
+    - [Log_sup]: [y = (Log_sup x) iff 2^(y-1) < x <= 2^y]
+      i.e. [Log_inf x] is the smallest integer that is bigger than [Log x]
+    - [Log_nearest]: [y= (Log_nearest x) iff 2^(y-1/2) < x <= 2^(y+1/2)]
+      i.e. [Log_nearest x] is the integer nearest from [Log x] *)
+
+Require Import ZArith_base.
+Require Import Omega.
+Require Import Zcomplements.
+Require Import Zpower.
+Open Local Scope Z_scope.
+
+Section Log_pos. (* Log of positive integers *)
+
+(** First we build [log_inf] and [log_sup] *)
+
+Fixpoint log_inf (p:positive) : Z :=
+  match p with
+  | xH => 0	(* 1 *)
+  | xO q => Zsucc (log_inf q)	(* 2n *)
+  | xI q => Zsucc (log_inf q)	(* 2n+1 *)
+  end.
+Fixpoint log_sup (p:positive) : Z :=
+  match p with
+  | xH => 0	(* 1 *)
+  | xO n => Zsucc (log_sup n) (* 2n *)
+  | xI n => Zsucc (Zsucc (log_inf n))	(* 2n+1 *)
+  end.
+
+Hint Unfold log_inf log_sup.
+
+(** Then we give the specifications of [log_inf] and [log_sup] 
+    and prove their validity *)
+
+(*i Hints Resolve ZERO_le_S : zarith. i*)
+Hint Resolve Zle_trans: zarith.
+
+Theorem log_inf_correct :
+ forall x:positive,
+   0 <= log_inf x /\ two_p (log_inf x) <= Zpos x < two_p (Zsucc (log_inf x)).
+simple induction x; intros; simpl in |- *;
+ [ elim H; intros Hp HR; clear H; split;
+    [ auto with zarith
+    | conditional apply Zle_le_succ; trivial rewrite
+       two_p_S with (x := Zsucc (log_inf p));
+       conditional trivial rewrite two_p_S;
+       conditional trivial rewrite two_p_S in HR; rewrite (BinInt.Zpos_xI p);
+       omega ]
+ | elim H; intros Hp HR; clear H; split;
+    [ auto with zarith
+    | conditional apply Zle_le_succ; trivial rewrite
+       two_p_S with (x := Zsucc (log_inf p));
+       conditional trivial rewrite two_p_S;
+       conditional trivial rewrite two_p_S in HR; rewrite (BinInt.Zpos_xO p);
+       omega ]
+ | unfold two_power_pos in |- *; unfold shift_pos in |- *; simpl in |- *;
+    omega ].
+Qed.
+
+Definition log_inf_correct1 (p:positive) := proj1 (log_inf_correct p).
+Definition log_inf_correct2 (p:positive) := proj2 (log_inf_correct p).
+
+Opaque log_inf_correct1 log_inf_correct2.
+
+Hint Resolve log_inf_correct1 log_inf_correct2: zarith.
+
+Lemma log_sup_correct1 : forall p:positive, 0 <= log_sup p.
+simple induction p; intros; simpl in |- *; auto with zarith.
+Qed.
+
+(** For every [p], either [p] is a power of two and [(log_inf p)=(log_sup p)]
+    either [(log_sup p)=(log_inf p)+1] *)
+
+Theorem log_sup_log_inf :
+ forall p:positive,
+    IF Zpos p = two_p (log_inf p) then Zpos p = two_p (log_sup p)
+   else log_sup p = Zsucc (log_inf p).
+
+simple induction p; intros;
+ [ elim H; right; simpl in |- *;
+    rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
+    rewrite BinInt.Zpos_xI; unfold Zsucc in |- *; omega
+ | elim H; clear H; intro Hif;
+    [ left; simpl in |- *;
+       rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
+       rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0));
+       rewrite <- (proj1 Hif); rewrite <- (proj2 Hif); 
+       auto
+    | right; simpl in |- *;
+       rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
+       rewrite BinInt.Zpos_xO; unfold Zsucc in |- *; 
+       omega ]
+ | left; auto ].
+Qed.
+
+Theorem log_sup_correct2 :
+ forall x:positive, two_p (Zpred (log_sup x)) < Zpos x <= two_p (log_sup x).
+
+intro.
+elim (log_sup_log_inf x).
+(* x is a power of two and [log_sup = log_inf] *)
+intros [E1 E2]; rewrite E2.
+split; [ apply two_p_pred; apply log_sup_correct1 | apply Zle_refl ].
+intros [E1 E2]; rewrite E2.
+rewrite <- (Zpred_succ (log_inf x)).
+generalize (log_inf_correct2 x); omega.
+Qed.
+
+Lemma log_inf_le_log_sup : forall p:positive, log_inf p <= log_sup p.
+simple induction p; simpl in |- *; intros; omega.
+Qed.
+
+Lemma log_sup_le_Slog_inf : forall p:positive, log_sup p <= Zsucc (log_inf p).
+simple induction p; simpl in |- *; intros; omega.
+Qed.
+
+(** Now it's possible to specify and build the [Log] rounded to the nearest *)
+
+Fixpoint log_near (x:positive) : Z :=
+  match x with
+  | xH => 0
+  | xO xH => 1
+  | xI xH => 2
+  | xO y => Zsucc (log_near y)
+  | xI y => Zsucc (log_near y)
+  end.    
+
+Theorem log_near_correct1 : forall p:positive, 0 <= log_near p.
+simple induction p; simpl in |- *; intros;
+ [ elim p0; auto with zarith
+ | elim p0; auto with zarith
+ | trivial with zarith ].
+intros; apply Zle_le_succ.
+generalize H0; elim p1; intros; simpl in |- *;
+ [ assumption | assumption | apply Zorder.Zle_0_pos ].
+intros; apply Zle_le_succ.
+generalize H0; elim p1; intros; simpl in |- *;
+ [ assumption | assumption | apply Zorder.Zle_0_pos ].
+Qed.
+
+Theorem log_near_correct2 :
+ forall p:positive, log_near p = log_inf p \/ log_near p = log_sup p.
+simple induction p.
+intros p0 [Einf| Esup].
+simpl in |- *. rewrite Einf.
+case p0; [ left | left | right ]; reflexivity.
+simpl in |- *; rewrite Esup.
+elim (log_sup_log_inf p0).
+generalize (log_inf_le_log_sup p0).
+generalize (log_sup_le_Slog_inf p0).
+case p0; auto with zarith.
+intros; omega.
+case p0; intros; auto with zarith.
+intros p0 [Einf| Esup].
+simpl in |- *.
+repeat rewrite Einf.
+case p0; intros; auto with zarith.
+simpl in |- *.
+repeat rewrite Esup.
+case p0; intros; auto with zarith.
+auto.
+Qed.
+
+(*i******************
+Theorem log_near_correct: (p:positive)
+  `| (two_p (log_near p)) - (POS p) | <= (POS p)-(two_p (log_inf p))`
+  /\`| (two_p (log_near p)) - (POS p) | <= (two_p (log_sup p))-(POS p)`.
+Intro.
+Induction p.
+Intros p0 [(Einf1,Einf2)|(Esup1,Esup2)].
+Unfold log_near log_inf log_sup. Fold log_near log_inf log_sup.
+Rewrite Einf1.
+Repeat Rewrite two_p_S.
+Case p0; [Left | Left | Right].
+
+Split.
+Simpl.
+Rewrite E1; Case p0; Try Reflexivity.
+Compute.
+Unfold log_near; Fold log_near.
+Unfold log_inf; Fold log_inf.
+Repeat Rewrite E1.
+Split.
+**********************************i*)
+
+End Log_pos.
+
+Section divers.
+
+(** Number of significative digits. *)
+
+Definition N_digits (x:Z) :=
+  match x with
+  | Zpos p => log_inf p
+  | Zneg p => log_inf p
+  | Z0 => 0
+  end.
+
+Lemma ZERO_le_N_digits : forall x:Z, 0 <= N_digits x.
+simple induction x; simpl in |- *;
+ [ apply Zle_refl | exact log_inf_correct1 | exact log_inf_correct1 ].
+Qed.
+
+Lemma log_inf_shift_nat : forall n:nat, log_inf (shift_nat n 1) = Z_of_nat n.
+simple induction n; intros;
+ [ try trivial | rewrite Znat.inj_S; rewrite <- H; reflexivity ].
+Qed.
+
+Lemma log_sup_shift_nat : forall n:nat, log_sup (shift_nat n 1) = Z_of_nat n.
+simple induction n; intros;
+ [ try trivial | rewrite Znat.inj_S; rewrite <- H; reflexivity ].
+Qed.
+
+(** [Is_power p] means that p is a power of two *)
+Fixpoint Is_power (p:positive) : Prop :=
+  match p with
+  | xH => True
+  | xO q => Is_power q
+  | xI q => False
+  end.
+
+Lemma Is_power_correct :
+ forall p:positive, Is_power p <-> (exists y : nat, p = shift_nat y 1).
+
+split;
+ [ elim p;
+    [ simpl in |- *; tauto
+    | simpl in |- *; intros; generalize (H H0); intro H1; elim H1;
+       intros y0 Hy0; exists (S y0); rewrite Hy0; reflexivity
+    | intro; exists 0%nat; reflexivity ]
+ | intros; elim H; intros; rewrite H0; elim x; intros; simpl in |- *; trivial ].
+Qed.
+
+Lemma Is_power_or : forall p:positive, Is_power p \/ ~ Is_power p.
+simple induction p;
+ [ intros; right; simpl in |- *; tauto
+ | intros; elim H;
+    [ intros; left; simpl in |- *; exact H0
+    | intros; right; simpl in |- *; exact H0 ]
+ | left; simpl in |- *; trivial ].
+Qed.
+
+End divers.
+
+
+
+
+
+
diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v
new file mode 100644
index 00000000..d48e62c5
--- /dev/null
+++ b/theories/ZArith/Zmin.v
@@ -0,0 +1,106 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i $Id: Zmin.v,v 1.3.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
+
+Require Import Arith.
+Require Import BinInt.
+Require Import Zcompare.
+Require Import Zorder.
+
+Open Local Scope Z_scope.
+
+(**********************************************************************)
+(** Minimum on binary integer numbers *)
+
+Definition Zmin (n m:Z) :=
+  match n ?= m return Z with
+  | Eq => n
+  | Lt => n
+  | Gt => m
+  end.
+
+(** Properties of minimum on binary integer numbers *)
+
+Lemma Zmin_SS : forall n m:Z, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m).
+Proof.
+intros n m; unfold Zmin in |- *; rewrite (Zcompare_succ_compat n m);
+ elim_compare n m; intros E; rewrite E; auto with arith.
+Qed.
+
+Lemma Zle_min_l : forall n m:Z, Zmin n m <= n.
+Proof.
+intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E;
+ [ apply Zle_refl
+ | apply Zle_refl
+ | apply Zlt_le_weak; apply Zgt_lt; exact E ].
+Qed.
+
+Lemma Zle_min_r : forall n m:Z, Zmin n m <= m.
+Proof.
+intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E;
+ [ unfold Zle in |- *; rewrite E; discriminate
+ | unfold Zle in |- *; rewrite E; discriminate
+ | apply Zle_refl ].
+Qed.
+
+Lemma Zmin_case : forall (n m:Z) (P:Z -> Set), P n -> P m -> P (Zmin n m).
+Proof.
+intros n m P H1 H2; unfold Zmin in |- *; case (n ?= m); auto with arith.
+Qed.
+
+Lemma Zmin_or : forall n m:Z, Zmin n m = n \/ Zmin n m = m.
+Proof.
+unfold Zmin in |- *; intros; elim (n ?= m); auto.
+Qed.
+
+Lemma Zmin_n_n : forall n:Z, Zmin n n = n.
+Proof.
+unfold Zmin in |- *; intros; elim (n ?= n); auto.
+Qed.
+
+Lemma Zmin_plus : forall n m p:Z, Zmin (n + p) (m + p) = Zmin n m + p.
+Proof.
+intros x y n; unfold Zmin in |- *.
+rewrite (Zplus_comm x n); rewrite (Zplus_comm y n);
+ rewrite (Zcompare_plus_compat x y n).
+case (x ?= y); apply Zplus_comm.
+Qed.
+
+(**********************************************************************)
+(** Maximum of two binary integer numbers *)
+
+Definition Zmax a b := match a ?= b with
+                       | Lt => b
+                       | _ => a
+                       end.
+
+(** Properties of maximum on binary integer numbers *)
+
+Ltac CaseEq name :=
+  generalize (refl_equal name); pattern name at -1 in |- *; case name.
+
+Theorem Zmax1 : forall a b, a <= Zmax a b.
+Proof.
+intros a b; unfold Zmax in |- *; CaseEq (a ?= b); simpl in |- *;
+ auto with zarith.
+unfold Zle in |- *; intros H; rewrite H; red in |- *; intros; discriminate.
+Qed.
+
+Theorem Zmax2 : forall a b, b <= Zmax a b.
+Proof.
+intros a b; unfold Zmax in |- *; CaseEq (a ?= b); simpl in |- *;
+ auto with zarith.
+intros H;
+ (case (Zle_or_lt b a); auto; unfold Zlt in |- *; rewrite H; intros;
+   discriminate).
+intros H;
+ (case (Zle_or_lt b a); auto; unfold Zlt in |- *; rewrite H; intros;
+   discriminate).
+Qed.
diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v
new file mode 100644
index 00000000..adcaf0ba
--- /dev/null
+++ b/theories/ZArith/Zmisc.v
@@ -0,0 +1,97 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Zmisc.v,v 1.20.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+Require Import BinInt.
+Require Import Zcompare.
+Require Import Zorder.
+Require Import Bool.
+Open Local Scope Z_scope.
+
+(**********************************************************************)
+(** Iterators *)
+
+(** [n]th iteration of the function [f] *)
+Fixpoint iter_nat (n:nat) (A:Set) (f:A -> A) (x:A) {struct n} : A :=
+  match n with
+  | O => x
+  | S n' => f (iter_nat n' A f x)
+  end.
+
+Fixpoint iter_pos (n:positive) (A:Set) (f:A -> A) (x:A) {struct n} : A :=
+  match n with
+  | xH => f x
+  | xO n' => iter_pos n' A f (iter_pos n' A f x)
+  | xI n' => f (iter_pos n' A f (iter_pos n' A f x))
+  end.
+
+Definition iter (n:Z) (A:Set) (f:A -> A) (x:A) :=
+  match n with
+  | Z0 => x
+  | Zpos p => iter_pos p A f x
+  | Zneg p => x
+  end.
+
+Theorem iter_nat_plus :
+ forall (n m:nat) (A:Set) (f:A -> A) (x:A),
+   iter_nat (n + m) A f x = iter_nat n A f (iter_nat m A f x).
+Proof.    
+simple induction n;
+ [ simpl in |- *; auto with arith
+ | intros; simpl in |- *; apply f_equal with (f := f); apply H ].  
+Qed.
+
+Theorem iter_nat_of_P :
+ forall (p:positive) (A:Set) (f:A -> A) (x:A),
+   iter_pos p A f x = iter_nat (nat_of_P p) A f x.
+Proof.    
+intro n; induction n as [p H| p H| ];
+ [ intros; simpl in |- *; rewrite (H A f x);
+    rewrite (H A f (iter_nat (nat_of_P p) A f x)); 
+    rewrite (ZL6 p); symmetry  in |- *; apply f_equal with (f := f);
+    apply iter_nat_plus
+ | intros; unfold nat_of_P in |- *; simpl in |- *; rewrite (H A f x);
+    rewrite (H A f (iter_nat (nat_of_P p) A f x)); 
+    rewrite (ZL6 p); symmetry  in |- *; apply iter_nat_plus
+ | simpl in |- *; auto with arith ].
+Qed.
+
+Theorem iter_pos_plus :
+ forall (p q:positive) (A:Set) (f:A -> A) (x:A),
+   iter_pos (p + q) A f x = iter_pos p A f (iter_pos q A f x).
+Proof.    
+intros n m; intros.
+rewrite (iter_nat_of_P m A f x).
+rewrite (iter_nat_of_P n A f (iter_nat (nat_of_P m) A f x)).
+rewrite (iter_nat_of_P (n + m) A f x).
+rewrite (nat_of_P_plus_morphism n m).
+apply iter_nat_plus.
+Qed.
+
+(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv], 
+    then the iterates of [f] also preserve it. *)
+
+Theorem iter_nat_invariant :
+ forall (n:nat) (A:Set) (f:A -> A) (Inv:A -> Prop),
+   (forall x:A, Inv x -> Inv (f x)) ->
+   forall x:A, Inv x -> Inv (iter_nat n A f x).
+Proof.    
+simple induction n; intros;
+ [ trivial with arith
+ | simpl in |- *; apply H0 with (x := iter_nat n0 A f x); apply H;
+    trivial with arith ].
+Qed.
+
+Theorem iter_pos_invariant :
+ forall (p:positive) (A:Set) (f:A -> A) (Inv:A -> Prop),
+   (forall x:A, Inv x -> Inv (f x)) ->
+   forall x:A, Inv x -> Inv (iter_pos p A f x).
+Proof.    
+intros; rewrite iter_nat_of_P; apply iter_nat_invariant; trivial with arith.
+Qed.
diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v
new file mode 100644
index 00000000..d051ed74
--- /dev/null
+++ b/theories/ZArith/Znat.v
@@ -0,0 +1,138 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Znat.v,v 1.3.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
+
+Require Export Arith.
+Require Import BinPos.
+Require Import BinInt.
+Require Import Zcompare.
+Require Import Zorder.
+Require Import Decidable.
+Require Import Peano_dec.
+Require Export Compare_dec.
+
+Open Local Scope Z_scope.
+
+Definition neq (x y:nat) := x <> y.
+
+(**********************************************************************)
+(** Properties of the injection from nat into Z *)
+
+Theorem inj_S : forall n:nat, Z_of_nat (S n) = Zsucc (Z_of_nat n).
+Proof.
+intro y; induction y as [| n H];
+ [ unfold Zsucc in |- *; simpl in |- *; trivial with arith
+ | change (Zpos (Psucc (P_of_succ_nat n)) = Zsucc (Z_of_nat (S n))) in |- *;
+    rewrite Zpos_succ_morphism; trivial with arith ].
+Qed.
+ 
+Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat m.
+Proof.
+intro x; induction x as [| n H]; intro y; destruct y as [| m];
+ [ simpl in |- *; trivial with arith
+ | simpl in |- *; trivial with arith
+ | simpl in |- *; rewrite <- plus_n_O; trivial with arith
+ | change (Z_of_nat (S (n + S m)) = Z_of_nat (S n) + Z_of_nat (S m)) in |- *;
+    rewrite inj_S; rewrite H; do 2 rewrite inj_S; rewrite Zplus_succ_l;
+    trivial with arith ].
+Qed.
+ 
+Theorem inj_mult : forall n m:nat, Z_of_nat (n * m) = Z_of_nat n * Z_of_nat m.
+Proof.
+intro x; induction x as [| n H];
+ [ simpl in |- *; trivial with arith
+ | intro y; rewrite inj_S; rewrite <- Zmult_succ_l_reverse; rewrite <- H;
+    rewrite <- inj_plus; simpl in |- *; rewrite plus_comm; 
+    trivial with arith ].
+Qed.
+
+Theorem inj_neq : forall n m:nat, neq n m -> Zne (Z_of_nat n) (Z_of_nat m).
+Proof.
+unfold neq, Zne, not in |- *; intros x y H1 H2; apply H1; generalize H2;
+ case x; case y; intros;
+ [ auto with arith
+ | discriminate H0
+ | discriminate H0
+ | simpl in H0; injection H0;
+    do 2 rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ; 
+    intros E; rewrite E; auto with arith ].
+Qed. 
+
+Theorem inj_le : forall n m:nat, (n <= m)%nat -> Z_of_nat n <= Z_of_nat m.
+Proof.
+intros x y; intros H; elim H;
+ [ unfold Zle in |- *; elim (Zcompare_Eq_iff_eq (Z_of_nat x) (Z_of_nat x));
+    intros H1 H2; rewrite H2; [ discriminate | trivial with arith ]
+ | intros m H1 H2; apply Zle_trans with (Z_of_nat m);
+    [ assumption | rewrite inj_S; apply Zle_succ ] ].
+Qed.
+
+Theorem inj_lt : forall n m:nat, (n < m)%nat -> Z_of_nat n < Z_of_nat m.
+Proof.
+intros x y H; apply Zgt_lt; apply Zlt_succ_gt; rewrite <- inj_S; apply inj_le;
+ exact H.
+Qed.
+
+Theorem inj_gt : forall n m:nat, (n > m)%nat -> Z_of_nat n > Z_of_nat m.
+Proof.
+intros x y H; apply Zlt_gt; apply inj_lt; exact H.
+Qed.
+
+Theorem inj_ge : forall n m:nat, (n >= m)%nat -> Z_of_nat n >= Z_of_nat m.
+Proof.
+intros x y H; apply Zle_ge; apply inj_le; apply H.
+Qed.
+
+Theorem inj_eq : forall n m:nat, n = m -> Z_of_nat n = Z_of_nat m.
+Proof.
+intros x y H; rewrite H; trivial with arith.
+Qed.
+
+Theorem intro_Z :
+ forall n:nat,  exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 0.
+Proof.
+intros x; exists (Z_of_nat x); split;
+ [ trivial with arith
+ | rewrite Zmult_comm; rewrite Zmult_1_l; rewrite Zplus_0_r;
+    unfold Zle in |- *; elim x; intros; simpl in |- *; 
+    discriminate ].
+Qed.
+
+Theorem inj_minus1 :
+ forall n m:nat, (m <= n)%nat -> Z_of_nat (n - m) = Z_of_nat n - Z_of_nat m.
+Proof.
+intros x y H; apply (Zplus_reg_l (Z_of_nat y)); unfold Zminus in |- *;
+ rewrite Zplus_permute; rewrite Zplus_opp_r; rewrite <- inj_plus;
+ rewrite <- (le_plus_minus y x H); rewrite Zplus_0_r; 
+ trivial with arith.
+Qed.
+ 
+Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0.
+Proof.
+intros x y H; rewrite not_le_minus_0;
+ [ trivial with arith | apply gt_not_le; assumption ].
+Qed.
+
+Theorem Zpos_eq_Z_of_nat_o_nat_of_P :
+ forall p:positive, Zpos p = Z_of_nat (nat_of_P p).
+Proof.
+intros x; elim x; simpl in |- *; auto.
+intros p H; rewrite ZL6.
+apply f_equal with (f := Zpos).
+apply nat_of_P_inj.
+rewrite nat_of_P_o_P_of_succ_nat_eq_succ; unfold nat_of_P in |- *;
+ simpl in |- *.
+rewrite ZL6; auto.
+intros p H; unfold nat_of_P in |- *; simpl in |- *.
+rewrite ZL6; simpl in |- *.
+rewrite inj_plus; repeat rewrite <- H.
+rewrite Zpos_xO; simpl in |- *; rewrite Pplus_diag; reflexivity.
+Qed.
diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v
new file mode 100644
index 00000000..715cdc7d
--- /dev/null
+++ b/theories/ZArith/Znumtheory.v
@@ -0,0 +1,640 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Znumtheory.v,v 1.5.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+Require Import ZArith_base.
+Require Import ZArithRing.
+Require Import Zcomplements.
+Require Import Zdiv.
+Open Local Scope Z_scope.
+
+(** This file contains some notions of number theory upon Z numbers: 
+     - a divisibility predicate [Zdivide]
+     - a gcd predicate [gcd]
+     - Euclid algorithm [euclid]
+     - an efficient [Zgcd] function 
+     - a relatively prime predicate [rel_prime]
+     - a prime predicate [prime]
+*)
+
+(** * Divisibility *)
+
+Inductive Zdivide (a b:Z) : Prop :=
+    Zdivide_intro : forall q:Z, b = q * a -> Zdivide a b.
+
+(** Syntax for divisibility *)
+
+Notation "( a | b )" := (Zdivide a b) (at level 0) : Z_scope.
+
+(** Results concerning divisibility*)
+
+Lemma Zdivide_refl : forall a:Z, (a | a).
+Proof.
+intros; apply Zdivide_intro with 1; ring.
+Qed.
+
+Lemma Zone_divide : forall a:Z, (1 | a).
+Proof.
+intros; apply Zdivide_intro with a; ring.
+Qed.
+
+Lemma Zdivide_0 : forall a:Z, (a | 0).
+Proof.
+intros; apply Zdivide_intro with 0; ring.
+Qed.
+
+Hint Resolve Zdivide_refl Zone_divide Zdivide_0: zarith.
+
+Lemma Zmult_divide_compat_l : forall a b c:Z, (a | b) -> (c * a | c * b).
+Proof.
+simple induction 1; intros; apply Zdivide_intro with q.
+rewrite H0; ring.
+Qed.
+
+Lemma Zmult_divide_compat_r : forall a b c:Z, (a | b) -> (a * c | b * c).
+Proof.
+intros a b c; rewrite (Zmult_comm a c); rewrite (Zmult_comm b c).
+apply Zmult_divide_compat_l; trivial.
+Qed.
+
+Hint Resolve Zmult_divide_compat_l Zmult_divide_compat_r: zarith.
+
+Lemma Zdivide_plus_r : forall a b c:Z, (a | b) -> (a | c) -> (a | b + c).
+Proof.
+simple induction 1; intros q Hq; simple induction 1; intros q' Hq'.
+apply Zdivide_intro with (q + q').
+rewrite Hq; rewrite Hq'; ring.
+Qed.
+
+Lemma Zdivide_opp_r : forall a b:Z, (a | b) -> (a | - b).
+Proof.
+simple induction 1; intros; apply Zdivide_intro with (- q).
+rewrite H0; ring.
+Qed.
+
+Lemma Zdivide_opp_r_rev : forall a b:Z, (a | - b) -> (a | b).
+Proof.
+intros; replace b with (- - b). apply Zdivide_opp_r; trivial. ring.
+Qed.
+
+Lemma Zdivide_opp_l : forall a b:Z, (a | b) -> (- a | b).
+Proof.
+simple induction 1; intros; apply Zdivide_intro with (- q).
+rewrite H0; ring.
+Qed.
+
+Lemma Zdivide_opp_l_rev : forall a b:Z, (- a | b) -> (a | b).
+Proof.
+intros; replace a with (- - a). apply Zdivide_opp_l; trivial. ring.
+Qed.
+
+Lemma Zdivide_minus_l : forall a b c:Z, (a | b) -> (a | c) -> (a | b - c).
+Proof.
+simple induction 1; intros q Hq; simple induction 1; intros q' Hq'.
+apply Zdivide_intro with (q - q').
+rewrite Hq; rewrite Hq'; ring.
+Qed.
+
+Lemma Zdivide_mult_l : forall a b c:Z, (a | b) -> (a | b * c).
+Proof.
+simple induction 1; intros q Hq; apply Zdivide_intro with (q * c).
+rewrite Hq; ring.
+Qed.
+
+Lemma Zdivide_mult_r : forall a b c:Z, (a | c) -> (a | b * c).
+Proof.
+simple induction 1; intros q Hq; apply Zdivide_intro with (q * b).
+rewrite Hq; ring.
+Qed.
+
+Lemma Zdivide_factor_r : forall a b:Z, (a | a * b).
+Proof.
+intros; apply Zdivide_intro with b; ring.
+Qed.
+
+Lemma Zdivide_factor_l : forall a b:Z, (a | b * a).
+Proof.
+intros; apply Zdivide_intro with b; ring.
+Qed.
+
+Hint Resolve Zdivide_plus_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l
+  Zdivide_opp_l_rev Zdivide_minus_l Zdivide_mult_l Zdivide_mult_r
+  Zdivide_factor_r Zdivide_factor_l: zarith.
+
+(** Auxiliary result. *)
+
+Lemma Zmult_one : forall x y:Z, x >= 0 -> x * y = 1 -> x = 1.
+Proof.
+intros x y H H0; destruct (Zmult_1_inversion_l _ _ H0) as [Hpos| Hneg].
+  assumption.
+  rewrite Hneg in H; simpl in H.
+  contradiction (Zle_not_lt 0 (-1)).
+    apply Zge_le; assumption.
+    apply Zorder.Zlt_neg_0.
+Qed.
+
+(** Only [1] and [-1] divide [1]. *)
+
+Lemma Zdivide_1 : forall x:Z, (x | 1) -> x = 1 \/ x = -1.
+Proof.
+simple induction 1; intros.
+elim (Z_lt_ge_dec 0 x); [ left | right ].
+apply Zmult_one with q; auto with zarith; rewrite H0; ring.
+assert (- x = 1); auto with zarith.
+apply Zmult_one with (- q); auto with zarith; rewrite H0; ring.
+Qed.
+
+(** If [a] divides [b] and [b] divides [a] then [a] is [b] or [-b]. *)
+
+Lemma Zdivide_antisym : forall a b:Z, (a | b) -> (b | a) -> a = b \/ a = - b.
+Proof.
+simple induction 1; intros.
+inversion H1.
+rewrite H0 in H2; clear H H1.
+case (Z_zerop a); intro.
+left; rewrite H0; rewrite e; ring.
+assert (Hqq0 : q0 * q = 1).
+apply Zmult_reg_l with a.
+assumption.
+ring.
+pattern a at 2 in |- *; rewrite H2; ring.
+assert (q | 1).
+rewrite <- Hqq0; auto with zarith.
+elim (Zdivide_1 q H); intros.
+rewrite H1 in H0; left; omega.
+rewrite H1 in H0; right; omega.
+Qed.
+
+(** If [a] divides [b] and [b<>0] then [|a| <= |b|]. *)
+
+Lemma Zdivide_bounds : forall a b:Z, (a | b) -> b <> 0 -> Zabs a <= Zabs b.
+Proof.
+simple induction 1; intros.
+assert (Zabs b = Zabs q * Zabs a).
+ subst; apply Zabs_Zmult.
+rewrite H2.
+assert (H3 := Zabs_pos q).
+assert (H4 := Zabs_pos a).
+assert (Zabs q * Zabs a >= 1 * Zabs a); auto with zarith.
+apply Zmult_ge_compat; auto with zarith.
+elim (Z_lt_ge_dec (Zabs q) 1); [ intros | auto with zarith ].
+assert (Zabs q = 0).
+ omega.
+assert (q = 0).
+ rewrite <- (Zabs_Zsgn q).
+rewrite H5; auto with zarith.
+subst q; omega.
+Qed.
+
+(** * Greatest common divisor (gcd). *)
+   
+(** There is no unicity of the gcd; hence we define the predicate [gcd a b d] 
+     expressing that [d] is a gcd of [a] and [b]. 
+     (We show later that the [gcd] is actually unique if we discard its sign.) *)
+
+Inductive Zis_gcd (a b d:Z) : Prop :=
+    Zis_gcd_intro :
+      (d | a) ->
+      (d | b) -> (forall x:Z, (x | a) -> (x | b) -> (x | d)) -> Zis_gcd a b d.
+
+(** Trivial properties of [gcd] *)
+
+Lemma Zis_gcd_sym : forall a b d:Z, Zis_gcd a b d -> Zis_gcd b a d.
+Proof.
+simple induction 1; constructor; intuition.
+Qed.
+
+Lemma Zis_gcd_0 : forall a:Z, Zis_gcd a 0 a.
+Proof.
+constructor; auto with zarith.
+Qed.
+
+Lemma Zis_gcd_minus : forall a b d:Z, Zis_gcd a (- b) d -> Zis_gcd b a d.
+Proof.
+simple induction 1; constructor; intuition.
+Qed.
+
+Lemma Zis_gcd_opp : forall a b d:Z, Zis_gcd a b d -> Zis_gcd b a (- d).
+Proof.
+simple induction 1; constructor; intuition.
+Qed.
+
+Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith.
+
+(** * Extended Euclid algorithm. *)
+
+(** Euclid's algorithm to compute the [gcd] mainly relies on
+    the following property. *)
+
+Lemma Zis_gcd_for_euclid :
+ forall a b d q:Z, Zis_gcd b (a - q * b) d -> Zis_gcd a b d.
+Proof.
+simple induction 1; constructor; intuition.
+replace a with (a - q * b + q * b). auto with zarith. ring.
+Qed.
+
+Lemma Zis_gcd_for_euclid2 :
+ forall b d q r:Z, Zis_gcd r b d -> Zis_gcd b (b * q + r) d.
+Proof.
+simple induction 1; constructor; intuition.
+apply H2; auto.
+replace r with (b * q + r - b * q). auto with zarith. ring.
+Qed.
+
+(** We implement the extended version of Euclid's algorithm,
+    i.e. the one computing Bezout's coefficients as it computes
+    the [gcd]. We follow the algorithm given in Knuth's
+    "Art of Computer Programming", vol 2, page 325. *)
+
+Section extended_euclid_algorithm.
+
+Variables a b : Z.
+
+(** The specification of Euclid's algorithm is the existence of
+    [u], [v] and [d] such that [ua+vb=d] and [(gcd a b d)]. *)
+
+Inductive Euclid : Set :=
+    Euclid_intro :
+      forall u v d:Z, u * a + v * b = d -> Zis_gcd a b d -> Euclid.
+
+(** The recursive part of Euclid's algorithm uses well-founded
+    recursion of non-negative integers. It maintains 6 integers
+    [u1,u2,u3,v1,v2,v3] such that the following invariant holds:
+    [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)]. 
+    *)
+
+Lemma euclid_rec :
+ forall v3:Z,
+   0 <= v3 ->
+   forall u1 u2 u3 v1 v2:Z,
+     u1 * a + u2 * b = u3 ->
+     v1 * a + v2 * b = v3 ->
+     (forall d:Z, Zis_gcd u3 v3 d -> Zis_gcd a b d) -> Euclid.
+Proof.
+intros v3 Hv3; generalize Hv3; pattern v3 in |- *.
+apply Z_lt_rec.
+clear v3 Hv3; intros.
+elim (Z_zerop x); intro.
+apply Euclid_intro with (u := u1) (v := u2) (d := u3).
+assumption.
+apply H2.
+rewrite a0; auto with zarith.
+set (q := u3 / x) in *.
+assert (Hq : 0 <= u3 - q * x < x).
+replace (u3 - q * x) with (u3 mod x).
+apply Z_mod_lt; omega.
+assert (xpos : x > 0). omega.
+generalize (Z_div_mod_eq u3 x xpos). 
+unfold q in |- *. 
+intro eq; pattern u3 at 2 in |- *; rewrite eq; ring.
+apply (H (u3 - q * x) Hq (proj1 Hq) v1 v2 x (u1 - q * v1) (u2 - q * v2)).
+tauto.
+replace ((u1 - q * v1) * a + (u2 - q * v2) * b) with
+ (u1 * a + u2 * b - q * (v1 * a + v2 * b)).
+rewrite H0; rewrite H1; trivial.
+ring.
+intros; apply H2.
+apply Zis_gcd_for_euclid with q; assumption.
+assumption.
+Qed.
+
+(** We get Euclid's algorithm by applying [euclid_rec] on
+    [1,0,a,0,1,b] when [b>=0] and [1,0,a,0,-1,-b] when [b<0]. *)
+
+Lemma euclid : Euclid.
+Proof.
+case (Z_le_gt_dec 0 b); intro.
+intros;
+ apply euclid_rec with
+  (u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := 1) (v3 := b);
+ auto with zarith; ring.
+intros;
+ apply euclid_rec with
+  (u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := -1) (v3 := - b);
+ auto with zarith; try ring.
+Qed.
+
+End extended_euclid_algorithm.
+
+Theorem Zis_gcd_uniqueness_apart_sign :
+ forall a b d d':Z, Zis_gcd a b d -> Zis_gcd a b d' -> d = d' \/ d = - d'.
+Proof.
+simple induction 1.
+intros H1 H2 H3; simple induction 1; intros.
+generalize (H3 d' H4 H5); intro Hd'd.
+generalize (H6 d H1 H2); intro Hdd'.
+exact (Zdivide_antisym d d' Hdd' Hd'd).
+Qed.
+
+(** * Bezout's coefficients *)
+
+Inductive Bezout (a b d:Z) : Prop :=
+    Bezout_intro : forall u v:Z, u * a + v * b = d -> Bezout a b d.
+
+(** Existence of Bezout's coefficients for the [gcd] of [a] and [b] *)
+
+Lemma Zis_gcd_bezout : forall a b d:Z, Zis_gcd a b d -> Bezout a b d.
+Proof.
+intros a b d Hgcd.
+elim (euclid a b); intros u v d0 e g.
+generalize (Zis_gcd_uniqueness_apart_sign a b d d0 Hgcd g).
+intro H; elim H; clear H; intros.
+apply Bezout_intro with u v.
+rewrite H; assumption.
+apply Bezout_intro with (- u) (- v).
+rewrite H; rewrite <- e; ring.
+Qed.
+
+(** gcd of [ca] and [cb] is [c gcd(a,b)]. *)
+
+Lemma Zis_gcd_mult :
+ forall a b c d:Z, Zis_gcd a b d -> Zis_gcd (c * a) (c * b) (c * d).
+Proof.
+intros a b c d; simple induction 1; constructor; intuition.
+elim (Zis_gcd_bezout a b d H); intros.
+elim H3; intros.
+elim H4; intros.
+apply Zdivide_intro with (u * q + v * q0).
+rewrite <- H5.
+replace (c * (u * a + v * b)) with (u * (c * a) + v * (c * b)).
+rewrite H6; rewrite H7; ring.
+ring.
+Qed.
+
+(** We could obtain a [Zgcd] function via [euclid]. But we propose 
+  here a more direct version of a [Zgcd], with better extraction 
+  (no bezout coeffs). *)
+
+Definition Zgcd_pos :
+  forall a:Z,
+    0 <= a -> forall b:Z, {g : Z | 0 <= a -> Zis_gcd a b g /\ g >= 0}.
+Proof.
+intros a Ha.
+apply
+ (Z_lt_rec
+    (fun a:Z => forall b:Z, {g : Z | 0 <= a -> Zis_gcd a b g /\ g >= 0}));
+ try assumption.
+intro x; case x.
+intros _ b; exists (Zabs b).
+  elim (Z_le_lt_eq_dec _ _ (Zabs_pos b)).
+    intros H0; split.
+    apply Zabs_ind.
+    intros; apply Zis_gcd_sym; apply Zis_gcd_0; auto.
+    intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto.
+    auto with zarith.
+    
+    intros H0; rewrite <- H0.
+    rewrite <- (Zabs_Zsgn b); rewrite <- H0; simpl in |- *.
+    split; [ apply Zis_gcd_0 | idtac ]; auto with zarith.
+  
+intros p Hrec b.
+generalize (Z_div_mod b (Zpos p)).
+case (Zdiv_eucl b (Zpos p)); intros q r Hqr.
+elim Hqr; clear Hqr; intros; auto with zarith.
+elim (Hrec r H0 (Zpos p)); intros g Hgkl.
+inversion_clear H0.
+elim (Hgkl H1); clear Hgkl; intros H3 H4.
+exists g; intros.
+split; auto.
+rewrite H.
+apply Zis_gcd_for_euclid2; auto.
+
+intros p Hrec b.
+exists 0; intros.
+elim H; auto.
+Defined.
+
+Definition Zgcd_spec : forall a b:Z, {g : Z | Zis_gcd a b g /\ g >= 0}.
+Proof.
+intros a; case (Z_gt_le_dec 0 a).
+intros; assert (0 <= - a).
+omega.
+elim (Zgcd_pos (- a) H b); intros g Hgkl.
+exists g.
+intuition.
+intros Ha b; elim (Zgcd_pos a Ha b); intros g; exists g; intuition.
+Defined.
+
+Definition Zgcd (a b:Z) := let (g, _) := Zgcd_spec a b in g.
+
+Lemma Zgcd_is_pos : forall a b:Z, Zgcd a b >= 0.
+intros a b; unfold Zgcd in |- *; case (Zgcd_spec a b); tauto.
+Qed.
+
+Lemma Zgcd_is_gcd : forall a b:Z, Zis_gcd a b (Zgcd a b).
+intros a b; unfold Zgcd in |- *; case (Zgcd_spec a b); tauto.
+Qed.
+
+(** * Relative primality *)
+
+Definition rel_prime (a b:Z) : Prop := Zis_gcd a b 1.
+
+(** Bezout's theorem: [a] and [b] are relatively prime if and
+    only if there exist [u] and [v] such that [ua+vb = 1]. *)
+
+Lemma rel_prime_bezout : forall a b:Z, rel_prime a b -> Bezout a b 1.
+Proof.
+intros a b; exact (Zis_gcd_bezout a b 1).
+Qed.
+
+Lemma bezout_rel_prime : forall a b:Z, Bezout a b 1 -> rel_prime a b.
+Proof.
+simple induction 1; constructor; auto with zarith.
+intros. rewrite <- H0; auto with zarith.
+Qed.
+
+(** Gauss's theorem: if [a] divides [bc] and if [a] and [b] are
+    relatively prime, then [a] divides [c]. *)
+
+Theorem Gauss : forall a b c:Z, (a | b * c) -> rel_prime a b -> (a | c).
+Proof.
+intros. elim (rel_prime_bezout a b H0); intros.
+replace c with (c * 1); [ idtac | ring ].
+rewrite <- H1.
+replace (c * (u * a + v * b)) with (c * u * a + v * (b * c));
+ [ eauto with zarith | ring ].
+Qed.
+
+(** If [a] is relatively prime to [b] and [c], then it is to [bc] *)
+
+Lemma rel_prime_mult :
+ forall a b c:Z, rel_prime a b -> rel_prime a c -> rel_prime a (b * c).
+Proof.
+intros a b c Hb Hc.
+elim (rel_prime_bezout a b Hb); intros.
+elim (rel_prime_bezout a c Hc); intros.
+apply bezout_rel_prime.
+apply Bezout_intro with
+ (u := u * u0 * a + v0 * c * u + u0 * v * b) (v := v * v0).
+rewrite <- H.
+replace (u * a + v * b) with ((u * a + v * b) * 1); [ idtac | ring ].
+rewrite <- H0.
+ring.
+Qed.
+
+Lemma rel_prime_cross_prod :
+ forall a b c d:Z,
+   rel_prime a b ->
+   rel_prime c d -> b > 0 -> d > 0 -> a * d = b * c -> a = c /\ b = d.
+Proof.
+intros a b c d; intros.
+elim (Zdivide_antisym b d).
+split; auto with zarith.
+rewrite H4 in H3.
+rewrite Zmult_comm in H3.
+apply Zmult_reg_l with d; auto with zarith.
+intros; omega.
+apply Gauss with a.
+rewrite H3.
+auto with zarith.
+red in |- *; auto with zarith.
+apply Gauss with c.
+rewrite Zmult_comm.
+rewrite <- H3.
+auto with zarith.
+red in |- *; auto with zarith.
+Qed.
+
+(** After factorization by a gcd, the original numbers are relatively prime. *)
+
+Lemma Zis_gcd_rel_prime :
+ forall a b g:Z,
+   b > 0 -> g >= 0 -> Zis_gcd a b g -> rel_prime (a / g) (b / g).
+intros a b g; intros.
+assert (g <> 0).
+ intro.
+ elim H1; intros. 
+ elim H4; intros.
+ rewrite H2 in H6; subst b; omega.
+unfold rel_prime in |- *.
+elim (Zgcd_spec (a / g) (b / g)); intros g' [H3 H4].
+assert (H5 := Zis_gcd_mult _ _ g _ H3).
+rewrite <- Z_div_exact_2 in H5; auto with zarith.
+rewrite <- Z_div_exact_2 in H5; auto with zarith.
+elim (Zis_gcd_uniqueness_apart_sign _ _ _ _ H1 H5).
+intros; rewrite (Zmult_reg_l 1 g' g); auto with zarith.
+intros; rewrite (Zmult_reg_l 1 (- g') g); auto with zarith.
+pattern g at 1 in |- *; rewrite H6; ring.
+
+elim H1; intros.
+elim H7; intros.
+rewrite H9.
+replace (q * g) with (0 + q * g).
+rewrite Z_mod_plus.
+compute in |- *; auto.
+omega.
+ring.
+
+elim H1; intros.
+elim H6; intros.
+rewrite H9.
+replace (q * g) with (0 + q * g).
+rewrite Z_mod_plus.
+compute in |- *; auto.
+omega.
+ring.
+Qed.
+
+(** * Primality *)
+
+Inductive prime (p:Z) : Prop :=
+    prime_intro :
+      1 < p -> (forall n:Z, 1 <= n < p -> rel_prime n p) -> prime p.
+
+(** The sole divisors of a prime number [p] are [-1], [1], [p] and [-p]. *)
+
+Lemma prime_divisors :
+ forall p:Z,
+   prime p -> forall a:Z, (a | p) -> a = -1 \/ a = 1 \/ a = p \/ a = - p.
+Proof.
+simple induction 1; intros.
+assert
+ (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p).
+assert (Zabs a <= Zabs p). apply Zdivide_bounds; [ assumption | omega ].
+generalize H3. 
+pattern (Zabs a) in |- *; apply Zabs_ind; pattern (Zabs p) in |- *;
+ apply Zabs_ind; intros; omega.
+intuition idtac.
+(* -p < a < -1 *)
+absurd (rel_prime (- a) p); intuition.
+inversion H3.
+assert (- a | - a); auto with zarith.
+assert (- a | p); auto with zarith.
+generalize (H8 (- a) H9 H10); intuition idtac.
+generalize (Zdivide_1 (- a) H11); intuition.
+(* a = 0 *)
+inversion H2. subst a; omega.
+(* 1 < a < p *)
+absurd (rel_prime a p); intuition.
+inversion H3.
+assert (a | a); auto with zarith.
+assert (a | p); auto with zarith.
+generalize (H8 a H9 H10); intuition idtac.
+generalize (Zdivide_1 a H11); intuition.
+Qed.
+
+(** A prime number is relatively prime with any number it does not divide *)
+
+Lemma prime_rel_prime :
+ forall p:Z, prime p -> forall a:Z, ~ (p | a) -> rel_prime p a.
+Proof.
+simple induction 1; intros.
+constructor; intuition.
+elim (prime_divisors p H x H3); intuition; subst; auto with zarith.
+absurd (p | a); auto with zarith.
+absurd (p | a); intuition.
+Qed.
+
+Hint Resolve prime_rel_prime: zarith.
+
+(** [Zdivide] can be expressed using [Zmod]. *)
+
+Lemma Zmod_divide : forall a b:Z, b > 0 -> a mod b = 0 -> (b | a).
+intros a b H H0.
+apply Zdivide_intro with (a / b).
+pattern a at 1 in |- *; rewrite (Z_div_mod_eq a b H).
+rewrite H0; ring.
+Qed.
+
+Lemma Zdivide_mod : forall a b:Z, b > 0 -> (b | a) -> a mod b = 0.
+intros a b; simple destruct 2; intros; subst.
+change (q * b) with (0 + q * b) in |- *.
+rewrite Z_mod_plus; auto.
+Qed.
+
+(** [Zdivide] is hence decidable *)
+
+Lemma Zdivide_dec : forall a b:Z, {(a | b)} + {~ (a | b)}.
+Proof.
+intros a b; elim (Ztrichotomy_inf a 0).
+(* a<0 *)
+intros H; elim H; intros. 
+case (Z_eq_dec (b mod - a) 0).
+left; apply Zdivide_opp_l_rev; apply Zmod_divide; auto with zarith.
+intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith.
+(* a=0 *)
+case (Z_eq_dec b 0); intro.
+left; subst; auto with zarith.
+right; subst; intro H0; inversion H0; omega.
+(* a>0 *)
+intro H; case (Z_eq_dec (b mod a) 0).
+left; apply Zmod_divide; auto with zarith.
+intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith.
+Qed.
+
+(** If a prime [p] divides [ab] then it divides either [a] or [b] *)
+
+Lemma prime_mult :
+ forall p:Z, prime p -> forall a b:Z, (p | a * b) -> (p | a) \/ (p | b).
+Proof.
+intro p; simple induction 1; intros.
+case (Zdivide_dec p a); intuition.
+right; apply Gauss with a; auto with zarith.
+Qed.
+
diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v
new file mode 100644
index 00000000..55d4d958
--- /dev/null
+++ b/theories/ZArith/Zorder.v
@@ -0,0 +1,965 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*i $Id: Zorder.v,v 1.6.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
+
+Require Import BinPos.
+Require Import BinInt.
+Require Import Arith.
+Require Import Decidable.
+Require Import Zcompare.
+
+Open Local Scope Z_scope.
+
+Implicit Types x y z : Z.
+
+(**********************************************************************)
+(** Properties of the order relations on binary integers *)
+
+(** Trichotomy *)
+
+Theorem Ztrichotomy_inf : forall n m:Z, {n < m} + {n = m} + {n > m}.
+Proof.
+unfold Zgt, Zlt in |- *; intros m n; assert (H := refl_equal (m ?= n)).
+  set (x := m ?= n) in H at 2 |- *.
+  destruct x;
+   [ left; right; rewrite Zcompare_Eq_eq with (1 := H) | left; left | right ];
+   reflexivity.
+Qed.
+
+Theorem Ztrichotomy : forall n m:Z, n < m \/ n = m \/ n > m.
+Proof.
+  intros m n; destruct (Ztrichotomy_inf m n) as [[Hlt| Heq]| Hgt];
+   [ left | right; left | right; right ]; assumption.
+Qed.
+
+(**********************************************************************)
+(** Decidability of equality and order on Z *)
+
+Theorem dec_eq : forall n m:Z, decidable (n = m).
+Proof.
+intros x y; unfold decidable in |- *; elim (Zcompare_Eq_iff_eq x y);
+ intros H1 H2; elim (Dcompare (x ?= y));
+ [ tauto
+ | intros H3; right; unfold not in |- *; intros H4; elim H3; rewrite (H2 H4);
+    intros H5; discriminate H5 ].
+Qed. 
+
+Theorem dec_Zne : forall n m:Z, decidable (Zne n m).
+Proof.
+intros x y; unfold decidable, Zne in |- *; elim (Zcompare_Eq_iff_eq x y).
+intros H1 H2; elim (Dcompare (x ?= y));
+ [ right; rewrite H1; auto
+ | left; unfold not in |- *; intro; absurd ((x ?= y) = Eq);
+    [ elim H; intros HR; rewrite HR; discriminate | auto ] ].
+Qed.
+
+Theorem dec_Zle : forall n m:Z, decidable (n <= m).
+Proof.
+intros x y; unfold decidable, Zle in |- *; elim (x ?= y);
+ [ left; discriminate
+ | left; discriminate
+ | right; unfold not in |- *; intros H; apply H; trivial with arith ].
+Qed.
+
+Theorem dec_Zgt : forall n m:Z, decidable (n > m).
+Proof.
+intros x y; unfold decidable, Zgt in |- *; elim (x ?= y);
+ [ right; discriminate | right; discriminate | auto with arith ].
+Qed.
+
+Theorem dec_Zge : forall n m:Z, decidable (n >= m).
+Proof.
+intros x y; unfold decidable, Zge in |- *; elim (x ?= y);
+ [ left; discriminate
+ | right; unfold not in |- *; intros H; apply H; trivial with arith
+ | left; discriminate ]. 
+Qed.
+
+Theorem dec_Zlt : forall n m:Z, decidable (n < m).
+Proof.
+intros x y; unfold decidable, Zlt in |- *; elim (x ?= y);
+ [ right; discriminate | auto with arith | right; discriminate ].
+Qed.
+
+Theorem not_Zeq : forall n m:Z, n <> m -> n < m \/ m < n.
+Proof.
+intros x y; elim (Dcompare (x ?= y));
+ [ intros H1 H2; absurd (x = y);
+    [ assumption | elim (Zcompare_Eq_iff_eq x y); auto with arith ]
+ | unfold Zlt in |- *; intros H; elim H; intros H1;
+    [ auto with arith
+    | right; elim (Zcompare_Gt_Lt_antisym x y); auto with arith ] ].
+Qed. 
+
+(** Relating strict and large orders *)
+
+Lemma Zgt_lt : forall n m:Z, n > m -> m < n.
+Proof.
+unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym m n);
+ auto with arith.
+Qed.
+
+Lemma Zlt_gt : forall n m:Z, n < m -> m > n.
+Proof.
+unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym n m);
+ auto with arith.
+Qed.
+
+Lemma Zge_le : forall n m:Z, n >= m -> m <= n.
+Proof.
+intros m n; change (~ m < n -> ~ n > m) in |- *; unfold not in |- *;
+ intros H1 H2; apply H1; apply Zgt_lt; assumption.
+Qed.
+
+Lemma Zle_ge : forall n m:Z, n <= m -> m >= n.
+Proof.
+intros m n; change (~ m > n -> ~ n < m) in |- *; unfold not in |- *;
+ intros H1 H2; apply H1; apply Zlt_gt; assumption.
+Qed.
+
+Lemma Zle_not_gt : forall n m:Z, n <= m -> ~ n > m.
+Proof.
+trivial.
+Qed.
+
+Lemma Zgt_not_le : forall n m:Z, n > m -> ~ n <= m.
+Proof.
+intros n m H1 H2; apply H2; assumption.
+Qed.
+
+Lemma Zle_not_lt : forall n m:Z, n <= m -> ~ m < n.
+Proof.
+intros n m H1 H2.
+assert (H3 := Zlt_gt _ _ H2).
+apply Zle_not_gt with n m; assumption.
+Qed.
+
+Lemma Zlt_not_le : forall n m:Z, n < m -> ~ m <= n.
+Proof.
+intros n m H1 H2.
+apply Zle_not_lt with m n; assumption.
+Qed.
+
+Lemma Znot_ge_lt : forall n m:Z, ~ n >= m -> n < m.
+Proof.
+unfold Zge, Zlt in |- *; intros x y H; apply dec_not_not;
+ [ exact (dec_Zlt x y) | assumption ].
+Qed.
+ 
+Lemma Znot_lt_ge : forall n m:Z, ~ n < m -> n >= m.
+Proof.
+unfold Zlt, Zge in |- *; auto with arith.
+Qed.
+
+Lemma Znot_gt_le : forall n m:Z, ~ n > m -> n <= m.
+Proof.
+trivial.
+Qed.
+
+Lemma Znot_le_gt : forall n m:Z, ~ n <= m -> n > m.
+Proof.
+unfold Zle, Zgt in |- *; intros x y H; apply dec_not_not;
+ [ exact (dec_Zgt x y) | assumption ].
+Qed.
+
+Lemma Zge_iff_le : forall n m:Z, n >= m <-> m <= n.
+Proof.
+    intros x y; intros. split. intro. apply Zge_le. assumption.
+    intro. apply Zle_ge. assumption.
+Qed.
+
+Lemma Zgt_iff_lt : forall n m:Z, n > m <-> m < n.
+Proof.
+    intros x y. split. intro. apply Zgt_lt. assumption.
+    intro. apply Zlt_gt. assumption.
+Qed.
+ 
+(** Reflexivity *)
+
+Lemma Zle_refl : forall n:Z, n <= n.
+Proof.
+intros n; unfold Zle in |- *; rewrite (Zcompare_refl n); discriminate.
+Qed. 
+
+Lemma Zeq_le : forall n m:Z, n = m -> n <= m.
+Proof.
+intros; rewrite H; apply Zle_refl.
+Qed.
+
+Hint Resolve Zle_refl: zarith.
+
+(** Antisymmetry *)
+
+Lemma Zle_antisym : forall n m:Z, n <= m -> m <= n -> n = m.
+Proof.
+intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]]. 
+  absurd (m > n); [ apply Zle_not_gt | apply Zlt_gt ]; assumption.
+  assumption.
+  absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption.
+Qed.
+
+(** Asymmetry *)
+
+Lemma Zgt_asym : forall n m:Z, n > m -> ~ m > n.
+Proof.
+unfold Zgt in |- *; intros n m H; elim (Zcompare_Gt_Lt_antisym n m);
+ intros H1 H2; rewrite H1; [ discriminate | assumption ].
+Qed.
+
+Lemma Zlt_asym : forall n m:Z, n < m -> ~ m < n.
+Proof.
+intros n m H H1; assert (H2 : m > n). apply Zlt_gt; assumption.
+assert (H3 : n > m). apply Zlt_gt; assumption.
+apply Zgt_asym with m n; assumption.
+Qed.
+
+(** Irreflexivity *)
+
+Lemma Zgt_irrefl : forall n:Z, ~ n > n.
+Proof.
+intros n H; apply (Zgt_asym n n H H).
+Qed.
+
+Lemma Zlt_irrefl : forall n:Z, ~ n < n.
+Proof.
+intros n H; apply (Zlt_asym n n H H).
+Qed.
+
+Lemma Zlt_not_eq : forall n m:Z, n < m -> n <> m.
+Proof.
+unfold not in |- *; intros x y H H0.
+rewrite H0 in H.
+apply (Zlt_irrefl _ H).
+Qed.
+
+(** Large = strict or equal *)
+
+Lemma Zlt_le_weak : forall n m:Z, n < m -> n <= m.
+Proof.
+intros n m Hlt; apply Znot_gt_le; apply Zgt_asym; apply Zlt_gt; assumption.
+Qed.
+
+Lemma Zle_lt_or_eq : forall n m:Z, n <= m -> n < m \/ n = m.
+Proof.
+intros n m H; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
+ [ left; assumption
+ | right; assumption
+ | absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption ].
+Qed.
+
+(** Dichotomy *)
+
+Lemma Zle_or_lt : forall n m:Z, n <= m \/ m < n.
+Proof.
+intros n m; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
+ [ left; apply Znot_gt_le; intro Hgt; assert (Hgt' := Zlt_gt _ _ Hlt);
+    apply Zgt_asym with m n; assumption
+ | left; rewrite Heq; apply Zle_refl
+ | right; apply Zgt_lt; assumption ].
+Qed.
+
+(** Transitivity of strict orders *)
+
+Lemma Zgt_trans : forall n m p:Z, n > m -> m > p -> n > p.
+Proof.
+exact Zcompare_Gt_trans.
+Qed.
+
+Lemma Zlt_trans : forall n m p:Z, n < m -> m < p -> n < p.
+Proof.
+intros n m p H1 H2; apply Zgt_lt; apply Zgt_trans with (m := m); apply Zlt_gt;
+ assumption.
+Qed.
+
+(** Mixed transitivity *)
+
+Lemma Zle_gt_trans : forall n m p:Z, m <= n -> m > p -> n > p.
+Proof.
+intros n m p H1 H2; destruct (Zle_lt_or_eq m n H1) as [Hlt| Heq];
+ [ apply Zgt_trans with m; [ apply Zlt_gt; assumption | assumption ]
+ | rewrite <- Heq; assumption ].
+Qed.
+
+Lemma Zgt_le_trans : forall n m p:Z, n > m -> p <= m -> n > p.
+Proof.
+intros n m p H1 H2; destruct (Zle_lt_or_eq p m H2) as [Hlt| Heq];
+ [ apply Zgt_trans with m; [ assumption | apply Zlt_gt; assumption ]
+ | rewrite Heq; assumption ].
+Qed.
+
+Lemma Zlt_le_trans : forall n m p:Z, n < m -> m <= p -> n < p.
+intros n m p H1 H2; apply Zgt_lt; apply Zle_gt_trans with (m := m);
+ [ assumption | apply Zlt_gt; assumption ].
+Qed.
+
+Lemma Zle_lt_trans : forall n m p:Z, n <= m -> m < p -> n < p.
+Proof.
+intros n m p H1 H2; apply Zgt_lt; apply Zgt_le_trans with (m := m);
+ [ apply Zlt_gt; assumption | assumption ].
+Qed.
+
+(** Transitivity of large orders *)
+
+Lemma Zle_trans : forall n m p:Z, n <= m -> m <= p -> n <= p.
+Proof.
+intros n m p H1 H2; apply Znot_gt_le.
+intro Hgt; apply Zle_not_gt with n m. assumption.
+exact (Zgt_le_trans n p m Hgt H2).
+Qed.
+
+Lemma Zge_trans : forall n m p:Z, n >= m -> m >= p -> n >= p.
+Proof.
+intros n m p H1 H2.
+apply Zle_ge.
+apply Zle_trans with m; apply Zge_le; trivial.
+Qed.
+
+Hint Resolve Zle_trans: zarith.
+
+(** Compatibility of successor wrt to order *)
+
+Lemma Zsucc_le_compat : forall n m:Z, m <= n -> Zsucc m <= Zsucc n.
+Proof.
+unfold Zle, not in |- *; intros m n H1 H2; apply H1;
+ rewrite <- (Zcompare_plus_compat n m 1); do 2 rewrite (Zplus_comm 1);
+ exact H2.
+Qed.
+
+Lemma Zsucc_gt_compat : forall n m:Z, m > n -> Zsucc m > Zsucc n.
+Proof.
+unfold Zgt in |- *; intros n m H; rewrite Zcompare_succ_compat;
+ auto with arith.
+Qed.
+
+Lemma Zsucc_lt_compat : forall n m:Z, n < m -> Zsucc n < Zsucc m.
+Proof.
+intros n m H; apply Zgt_lt; apply Zsucc_gt_compat; apply Zlt_gt; assumption.
+Qed.
+
+Hint Resolve Zsucc_le_compat: zarith.
+
+(** Simplification of successor wrt to order *)
+
+Lemma Zsucc_gt_reg : forall n m:Z, Zsucc m > Zsucc n -> m > n.
+Proof.
+unfold Zsucc, Zgt in |- *; intros n p;
+ do 2 rewrite (fun m:Z => Zplus_comm m 1);
+ rewrite (Zcompare_plus_compat p n 1); trivial with arith.
+Qed.
+
+Lemma Zsucc_le_reg : forall n m:Z, Zsucc m <= Zsucc n -> m <= n.
+Proof.
+unfold Zle, not in |- *; intros m n H1 H2; apply H1; unfold Zsucc in |- *;
+ do 2 rewrite <- (Zplus_comm 1); rewrite (Zcompare_plus_compat n m 1);
+ assumption.
+Qed.
+
+Lemma Zsucc_lt_reg : forall n m:Z, Zsucc n < Zsucc m -> n < m.
+Proof.
+intros n m H; apply Zgt_lt; apply Zsucc_gt_reg; apply Zlt_gt; assumption.
+Qed.
+
+(** Compatibility of addition wrt to order *)
+
+Lemma Zplus_gt_compat_l : forall n m p:Z, n > m -> p + n > p + m.
+Proof.
+unfold Zgt in |- *; intros n m p H; rewrite (Zcompare_plus_compat n m p);
+ assumption.
+Qed.
+
+Lemma Zplus_gt_compat_r : forall n m p:Z, n > m -> n + p > m + p.
+Proof.
+intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
+ apply Zplus_gt_compat_l; trivial.
+Qed.
+
+Lemma Zplus_le_compat_l : forall n m p:Z, n <= m -> p + n <= p + m.
+Proof.
+intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
+ rewrite <- (Zcompare_plus_compat n m p); assumption.
+Qed.
+
+Lemma Zplus_le_compat_r : forall n m p:Z, n <= m -> n + p <= m + p.
+Proof.
+intros a b c; do 2 rewrite (fun n:Z => Zplus_comm n c);
+ exact (Zplus_le_compat_l a b c).
+Qed.
+
+Lemma Zplus_lt_compat_l : forall n m p:Z, n < m -> p + n < p + m.
+Proof.
+unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
+ trivial with arith.
+Qed.
+
+Lemma Zplus_lt_compat_r : forall n m p:Z, n < m -> n + p < m + p.
+Proof.
+intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
+ apply Zplus_lt_compat_l; trivial.
+Qed.
+
+Lemma Zplus_lt_le_compat : forall n m p q:Z, n < m -> p <= q -> n + p < m + q.
+Proof.
+intros a b c d H0 H1.
+apply Zlt_le_trans with (b + c).
+apply Zplus_lt_compat_r; trivial.
+apply Zplus_le_compat_l; trivial.
+Qed.
+
+Lemma Zplus_le_lt_compat : forall n m p q:Z, n <= m -> p < q -> n + p < m + q.
+Proof.
+intros a b c d H0 H1.
+apply Zle_lt_trans with (b + c).
+apply Zplus_le_compat_r; trivial.
+apply Zplus_lt_compat_l; trivial.
+Qed.
+
+Lemma Zplus_le_compat : forall n m p q:Z, n <= m -> p <= q -> n + p <= m + q.
+Proof.
+intros n m p q; intros H1 H2; apply Zle_trans with (m := n + q);
+ [ apply Zplus_le_compat_l; assumption
+ | apply Zplus_le_compat_r; assumption ].
+Qed.
+
+
+Lemma Zplus_lt_compat : forall n m p q:Z, n < m -> p < q -> n + p < m + q.
+intros; apply Zplus_le_lt_compat. apply Zlt_le_weak; assumption. assumption.
+Qed.
+
+
+(** Compatibility of addition wrt to being positive *)
+
+Lemma Zplus_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n + m.
+Proof.
+intros x y H1 H2; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat; assumption.
+Qed.
+
+(** Simplification of addition wrt to order *)
+
+Lemma Zplus_gt_reg_l : forall n m p:Z, p + n > p + m -> n > m.
+Proof.
+unfold Zgt in |- *; intros n m p H; rewrite <- (Zcompare_plus_compat n m p);
+ assumption.
+Qed.
+
+Lemma Zplus_gt_reg_r : forall n m p:Z, n + p > m + p -> n > m.
+Proof.
+intros n m p H; apply Zplus_gt_reg_l with p.
+rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
+Qed.
+
+Lemma Zplus_le_reg_l : forall n m p:Z, p + n <= p + m -> n <= m.
+Proof.
+intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
+ rewrite (Zcompare_plus_compat n m p); assumption.
+Qed.
+ 
+Lemma Zplus_le_reg_r : forall n m p:Z, n + p <= m + p -> n <= m.
+Proof.
+intros n m p H; apply Zplus_le_reg_l with p.
+rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
+Qed.
+
+Lemma Zplus_lt_reg_l : forall n m p:Z, p + n < p + m -> n < m.
+Proof.
+unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
+ trivial with arith.
+Qed.
+ 
+Lemma Zplus_lt_reg_r : forall n m p:Z, n + p < m + p -> n < m.
+Proof.
+intros n m p H; apply Zplus_lt_reg_l with p.
+rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
+Qed.
+ 
+(** Special base instances of order *)
+
+Lemma Zgt_succ : forall n:Z, Zsucc n > n.
+Proof.
+exact Zcompare_succ_Gt.
+Qed.
+
+Lemma Znot_le_succ : forall n:Z, ~ Zsucc n <= n.
+Proof.
+intros n; apply Zgt_not_le; apply Zgt_succ.
+Qed.
+
+Lemma Zlt_succ : forall n:Z, n < Zsucc n.
+Proof.
+intro n; apply Zgt_lt; apply Zgt_succ.
+Qed.
+
+Lemma Zlt_pred : forall n:Z, Zpred n < n.
+Proof.
+intros n; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; apply Zlt_succ.
+Qed.
+
+(** Relating strict and large order using successor or predecessor *)
+
+Lemma Zgt_le_succ : forall n m:Z, m > n -> Zsucc n <= m.
+Proof.
+unfold Zgt, Zle in |- *; intros n p H; elim (Zcompare_Gt_not_Lt p n);
+ intros H1 H2; unfold not in |- *; intros H3; unfold not in H1; 
+ apply H1;
+ [ assumption
+ | elim (Zcompare_Gt_Lt_antisym (n + 1) p); intros H4 H5; apply H4; exact H3 ].
+Qed.
+
+Lemma Zlt_gt_succ : forall n m:Z, n <= m -> Zsucc m > n.
+Proof.
+intros n p H; apply Zgt_le_trans with p.
+  apply Zgt_succ.
+  assumption.
+Qed.
+
+Lemma Zle_lt_succ : forall n m:Z, n <= m -> n < Zsucc m.
+Proof.
+intros n m H; apply Zgt_lt; apply Zlt_gt_succ; assumption.
+Qed.
+
+Lemma Zlt_le_succ : forall n m:Z, n < m -> Zsucc n <= m.
+Proof.
+intros n p H; apply Zgt_le_succ; apply Zlt_gt; assumption.
+Qed.
+
+Lemma Zgt_succ_le : forall n m:Z, Zsucc m > n -> n <= m.
+Proof.
+intros n p H; apply Zsucc_le_reg; apply Zgt_le_succ; assumption.
+Qed.
+
+Lemma Zlt_succ_le : forall n m:Z, n < Zsucc m -> n <= m.
+Proof.
+intros n m H; apply Zgt_succ_le; apply Zlt_gt; assumption.
+Qed.
+
+Lemma Zlt_succ_gt : forall n m:Z, Zsucc n <= m -> m > n.
+Proof.
+intros n m H; apply Zle_gt_trans with (m := Zsucc n);
+ [ assumption | apply Zgt_succ ].
+Qed.
+
+(** Weakening order *)
+
+Lemma Zle_succ : forall n:Z, n <= Zsucc n.
+Proof.
+intros n; apply Zgt_succ_le; apply Zgt_trans with (m := Zsucc n);
+ apply Zgt_succ.
+Qed.
+
+Hint Resolve Zle_succ: zarith.
+
+Lemma Zle_pred : forall n:Z, Zpred n <= n.
+Proof.
+intros n; pattern n at 2 in |- *; rewrite Zsucc_pred; apply Zle_succ.
+Qed.
+
+Lemma Zlt_lt_succ : forall n m:Z, n < m -> n < Zsucc m.
+intros n m H; apply Zgt_lt; apply Zgt_trans with (m := m);
+ [ apply Zgt_succ | apply Zlt_gt; assumption ].
+Qed.
+
+Lemma Zle_le_succ : forall n m:Z, n <= m -> n <= Zsucc m.
+Proof.
+intros x y H.
+apply Zle_trans with y; trivial with zarith.
+Qed.
+
+Lemma Zle_succ_le : forall n m:Z, Zsucc n <= m -> n <= m.
+Proof.
+intros n m H; apply Zle_trans with (m := Zsucc n);
+ [ apply Zle_succ | assumption ].
+Qed.
+
+Hint Resolve Zle_le_succ: zarith.
+
+(** Relating order wrt successor and order wrt predecessor *)
+
+Lemma Zgt_succ_pred : forall n m:Z, m > Zsucc n -> Zpred m > n.
+Proof.
+unfold Zgt, Zsucc, Zpred in |- *; intros n p H;
+ rewrite <- (fun x y => Zcompare_plus_compat x y 1); 
+ rewrite (Zplus_comm p); rewrite Zplus_assoc;
+ rewrite (fun x => Zplus_comm x n); simpl in |- *; 
+ assumption.
+Qed.
+
+Lemma Zlt_succ_pred : forall n m:Z, Zsucc n < m -> n < Zpred m.
+Proof.
+intros n p H; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; assumption.
+Qed.
+
+(** Relating strict order and large order on positive *)
+
+Lemma Zlt_0_le_0_pred : forall n:Z, 0 < n -> 0 <= Zpred n.
+intros x H.
+rewrite (Zsucc_pred x) in H.
+apply Zgt_succ_le.
+apply Zlt_gt.
+assumption.
+Qed.
+
+
+Lemma Zgt_0_le_0_pred : forall n:Z, n > 0 -> 0 <= Zpred n.
+intros; apply Zlt_0_le_0_pred; apply Zgt_lt. assumption.
+Qed.
+
+
+(** Special cases of ordered integers *)
+
+Lemma Zlt_0_1 : 0 < 1.
+Proof.
+change (0 < Zsucc 0) in |- *. apply Zlt_succ.
+Qed.
+
+Lemma Zle_0_1 : 0 <= 1.
+Proof.
+change (0 <= Zsucc 0) in |- *. apply Zle_succ.
+Qed.
+
+Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q.
+Proof.
+intros p; red in |- *; simpl in |- *; red in |- *; intros H; discriminate.
+Qed.
+
+Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0.
+unfold Zgt in |- *; trivial.
+Qed.
+
+  (* weaker but useful (in [Zpower] for instance) *)
+Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p.
+intro; unfold Zle in |- *; discriminate.
+Qed.
+
+Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0.
+unfold Zlt in |- *; trivial.
+Qed.
+
+Lemma Zle_0_nat : forall n:nat, 0 <= Z_of_nat n.
+simple induction n; simpl in |- *; intros;
+ [ apply Zle_refl | unfold Zle in |- *; simpl in |- *; discriminate ].
+Qed.
+
+Hint Immediate Zeq_le: zarith.
+
+(** Transitivity using successor *)
+
+Lemma Zge_trans_succ : forall n m p:Z, Zsucc n > m -> m > p -> n > p.
+Proof.
+intros n m p H1 H2; apply Zle_gt_trans with (m := m);
+ [ apply Zgt_succ_le; assumption | assumption ].
+Qed.
+
+(** Derived lemma *)
+
+Lemma Zgt_succ_gt_or_eq : forall n m:Z, Zsucc n > m -> n > m \/ m = n.
+Proof.
+intros n m H.
+assert (Hle : m <= n).
+  apply Zgt_succ_le; assumption.
+destruct (Zle_lt_or_eq _ _ Hle) as [Hlt| Heq].
+  left; apply Zlt_gt; assumption.  
+  right; assumption.
+Qed.
+
+(** Compatibility of multiplication by a positive wrt to order *)
+
+
+Lemma Zmult_le_compat_r : forall n m p:Z, n <= m -> 0 <= p -> n * p <= m * p.
+Proof.
+intros a b c H H0; destruct c.
+  do 2 rewrite Zmult_0_r; assumption.
+  rewrite (Zmult_comm a); rewrite (Zmult_comm b).
+    unfold Zle in |- *; rewrite Zcompare_mult_compat; assumption.
+  unfold Zle in H0; contradiction H0; reflexivity.
+Qed.
+
+Lemma Zmult_le_compat_l : forall n m p:Z, n <= m -> 0 <= p -> p * n <= p * m.
+Proof.
+intros a b c H1 H2; rewrite (Zmult_comm c a); rewrite (Zmult_comm c b).
+apply Zmult_le_compat_r; trivial.
+Qed.
+
+Lemma Zmult_lt_compat_r : forall n m p:Z, 0 < p -> n < m -> n * p < m * p.
+Proof.
+intros x y z H H0; destruct z.
+  contradiction (Zlt_irrefl 0).
+  rewrite (Zmult_comm x); rewrite (Zmult_comm y).
+    unfold Zlt in |- *; rewrite Zcompare_mult_compat; assumption.
+  discriminate H.
+Qed.
+
+Lemma Zmult_gt_compat_r : forall n m p:Z, p > 0 -> n > m -> n * p > m * p.
+Proof.
+intros x y z; intros; apply Zlt_gt; apply Zmult_lt_compat_r; apply Zgt_lt;
+ assumption.
+Qed.
+
+Lemma Zmult_gt_0_lt_compat_r :
+ forall n m p:Z, p > 0 -> n < m -> n * p < m * p.
+Proof.
+intros x y z; intros; apply Zmult_lt_compat_r;
+ [ apply Zgt_lt; assumption | assumption ].
+Qed.
+
+Lemma Zmult_gt_0_le_compat_r :
+ forall n m p:Z, p > 0 -> n <= m -> n * p <= m * p.
+Proof.
+intros x y z Hz Hxy.
+elim (Zle_lt_or_eq x y Hxy).
+intros; apply Zlt_le_weak.
+apply Zmult_gt_0_lt_compat_r; trivial.
+intros; apply Zeq_le.
+rewrite H; trivial.
+Qed.
+
+Lemma Zmult_lt_0_le_compat_r :
+ forall n m p:Z, 0 < p -> n <= m -> n * p <= m * p.
+Proof.
+intros x y z; intros; apply Zmult_gt_0_le_compat_r; try apply Zlt_gt;
+ assumption.
+Qed.
+
+Lemma Zmult_gt_0_lt_compat_l :
+ forall n m p:Z, p > 0 -> n < m -> p * n < p * m.
+Proof.
+intros x y z; intros.
+rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
+ apply Zmult_gt_0_lt_compat_r; assumption.
+Qed.
+
+Lemma Zmult_lt_compat_l : forall n m p:Z, 0 < p -> n < m -> p * n < p * m.
+Proof.
+intros x y z; intros.
+rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
+ apply Zmult_gt_0_lt_compat_r; try apply Zlt_gt; assumption.
+Qed.
+
+Lemma Zmult_gt_compat_l : forall n m p:Z, p > 0 -> n > m -> p * n > p * m.
+Proof.
+intros x y z; intros; rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
+ apply Zmult_gt_compat_r; assumption.
+Qed.
+
+Lemma Zmult_ge_compat_r : forall n m p:Z, n >= m -> p >= 0 -> n * p >= m * p.
+Proof.
+intros a b c H1 H2; apply Zle_ge.
+apply Zmult_le_compat_r; apply Zge_le; trivial.
+Qed.
+
+Lemma Zmult_ge_compat_l : forall n m p:Z, n >= m -> p >= 0 -> p * n >= p * m.
+Proof.
+intros a b c H1 H2; apply Zle_ge.
+apply Zmult_le_compat_l; apply Zge_le; trivial.
+Qed.
+
+Lemma Zmult_ge_compat :
+ forall n m p q:Z, n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q.
+Proof.
+intros a b c d H0 H1 H2 H3.
+apply Zge_trans with (a * d).
+apply Zmult_ge_compat_l; trivial.
+apply Zge_trans with c; trivial. 
+apply Zmult_ge_compat_r; trivial.
+Qed.
+
+Lemma Zmult_le_compat :
+ forall n m p q:Z, n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q.
+Proof.
+intros a b c d H0 H1 H2 H3.
+apply Zle_trans with (c * b).
+apply Zmult_le_compat_r; assumption.
+apply Zmult_le_compat_l.
+assumption.
+apply Zle_trans with a; assumption.
+Qed.
+
+(** Simplification of multiplication by a positive wrt to being positive *)
+
+Lemma Zmult_gt_0_lt_reg_r : forall n m p:Z, p > 0 -> n * p < m * p -> n < m.
+Proof.
+intros x y z; intros; destruct z.
+  contradiction (Zgt_irrefl 0).
+  rewrite (Zmult_comm x) in H0; rewrite (Zmult_comm y) in H0.
+    unfold Zlt in H0; rewrite Zcompare_mult_compat in H0; assumption.
+  discriminate H.
+Qed.
+
+Lemma Zmult_lt_reg_r : forall n m p:Z, 0 < p -> n * p < m * p -> n < m.
+Proof.
+intros a b c H0 H1.
+apply Zmult_gt_0_lt_reg_r with c; try apply Zlt_gt; assumption.
+Qed.
+
+Lemma Zmult_le_reg_r : forall n m p:Z, p > 0 -> n * p <= m * p -> n <= m.
+Proof.
+intros x y z Hz Hxy.
+elim (Zle_lt_or_eq (x * z) (y * z) Hxy).
+intros; apply Zlt_le_weak.
+apply Zmult_gt_0_lt_reg_r with z; trivial.
+intros; apply Zeq_le.
+apply Zmult_reg_r with z.
+  intro. rewrite H0 in Hz. contradiction (Zgt_irrefl 0).
+assumption.
+Qed.
+
+Lemma Zmult_lt_0_le_reg_r : forall n m p:Z, 0 < p -> n * p <= m * p -> n <= m.
+intros x y z; intros; apply Zmult_le_reg_r with z.
+try apply Zlt_gt; assumption.
+assumption.
+Qed.
+
+
+Lemma Zmult_ge_reg_r : forall n m p:Z, p > 0 -> n * p >= m * p -> n >= m.
+intros a b c H1 H2; apply Zle_ge; apply Zmult_le_reg_r with c; trivial.
+apply Zge_le; trivial.
+Qed.
+
+Lemma Zmult_gt_reg_r : forall n m p:Z, p > 0 -> n * p > m * p -> n > m.
+intros a b c H1 H2; apply Zlt_gt; apply Zmult_gt_0_lt_reg_r with c; trivial.
+apply Zgt_lt; trivial.
+Qed.
+
+
+(** Compatibility of multiplication by a positive wrt to being positive *)
+
+Lemma Zmult_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n * m.
+Proof.
+intros x y; case x.
+intros; rewrite Zmult_0_l; trivial.
+intros p H1; unfold Zle in |- *.
+  pattern 0 at 2 in |- *; rewrite <- (Zmult_0_r (Zpos p)).
+  rewrite Zcompare_mult_compat; trivial.
+intros p H1 H2; absurd (0 > Zneg p); trivial.
+unfold Zgt in |- *; simpl in |- *; auto with zarith.
+Qed.
+
+Lemma Zmult_gt_0_compat : forall n m:Z, n > 0 -> m > 0 -> n * m > 0.
+Proof.
+intros x y; case x.
+intros H; discriminate H.
+intros p H1; unfold Zgt in |- *; pattern 0 at 2 in |- *;
+ rewrite <- (Zmult_0_r (Zpos p)).
+  rewrite Zcompare_mult_compat; trivial.
+intros p H; discriminate H.
+Qed.
+
+Lemma Zmult_lt_O_compat : forall n m:Z, 0 < n -> 0 < m -> 0 < n * m.
+intros a b apos bpos.
+apply Zgt_lt.
+apply Zmult_gt_0_compat; try apply Zlt_gt; assumption.
+Qed.
+
+Lemma Zmult_gt_0_le_0_compat : forall n m:Z, n > 0 -> 0 <= m -> 0 <= m * n.
+Proof.
+intros x y H1 H2; apply Zmult_le_0_compat; trivial.
+apply Zlt_le_weak; apply Zgt_lt; trivial.
+Qed.
+
+(** Simplification of multiplication by a positive wrt to being positive *)
+
+Lemma Zmult_le_0_reg_r : forall n m:Z, n > 0 -> 0 <= m * n -> 0 <= m.
+Proof.
+intros x y; case x;
+ [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
+ | intros p H1; unfold Zle in |- *; rewrite Zmult_comm;
+    pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
+    rewrite Zcompare_mult_compat; auto with arith
+ | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
+Qed.
+
+Lemma Zmult_gt_0_lt_0_reg_r : forall n m:Z, n > 0 -> 0 < m * n -> 0 < m.
+Proof.
+intros x y; case x;
+ [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
+ | intros p H1; unfold Zlt in |- *; rewrite Zmult_comm;
+    pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
+    rewrite Zcompare_mult_compat; auto with arith
+ | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
+Qed.
+
+Lemma Zmult_lt_0_reg_r : forall n m:Z, 0 < n -> 0 < m * n -> 0 < m.
+Proof.
+intros x y; intros; eapply Zmult_gt_0_lt_0_reg_r with x; try apply Zlt_gt;
+ assumption.
+Qed.
+
+Lemma Zmult_gt_0_reg_l : forall n m:Z, n > 0 -> n * m > 0 -> m > 0.
+Proof.
+intros x y; case x.
+ intros H; discriminate H.
+ intros p H1; unfold Zgt in |- *.
+ pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p)).
+ rewrite Zcompare_mult_compat; trivial.
+intros p H; discriminate H.
+Qed.
+
+(** Simplification of square wrt order *)
+
+Lemma Zgt_square_simpl :
+ forall n m:Z, n >= 0 -> m >= 0 -> n * n > m * m -> n > m.
+Proof.
+intros x y H0 H1 H2.
+case (dec_Zlt y x).
+intro; apply Zlt_gt; trivial.
+intros H3; cut (y >= x).
+intros H.
+elim Zgt_not_le with (1 := H2).
+apply Zge_le.
+apply Zmult_ge_compat; auto.
+apply Znot_lt_ge; trivial.
+Qed.
+
+Lemma Zlt_square_simpl :
+ forall n m:Z, 0 <= n -> 0 <= m -> m * m < n * n -> m < n.
+Proof.
+intros x y H0 H1 H2.
+apply Zgt_lt.
+apply Zgt_square_simpl; try apply Zle_ge; try apply Zlt_gt; assumption.
+Qed.
+
+(** Equivalence between inequalities *)
+
+Lemma Zle_plus_swap : forall n m p:Z, n + p <= m <-> n <= m - p.
+Proof.
+    intros x y z; intros. split. intro. rewrite <- (Zplus_0_r x). rewrite <- (Zplus_opp_r z).
+    rewrite Zplus_assoc. exact (Zplus_le_compat_r _ _ _ H).
+    intro. rewrite <- (Zplus_0_r y). rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc.
+    apply Zplus_le_compat_r. assumption.
+Qed.
+
+Lemma Zlt_plus_swap : forall n m p:Z, n + p < m <-> n < m - p.
+Proof.
+    intros x y z; intros. split. intro. unfold Zminus in |- *. rewrite Zplus_comm. rewrite <- (Zplus_0_l x).
+    rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm.
+    assumption.
+    intro. rewrite Zplus_comm. rewrite <- (Zplus_0_l y). rewrite <- (Zplus_opp_r z).
+    rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm. assumption.
+Qed.
+
+Lemma Zeq_plus_swap : forall n m p:Z, n + p = m <-> n = m - p.
+Proof.
+intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry  in |- *. rewrite Zplus_comm. 
+  assumption.
+intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse. 
+  rewrite Zplus_opp_l. apply Zplus_0_r.
+Qed.
+
+Lemma Zlt_minus_simpl_swap : forall n m:Z, 0 < m -> n - m < n.
+Proof.
+intros n m H; apply Zplus_lt_reg_l with (p := m); rewrite Zplus_minus;
+ pattern n at 1 in |- *; rewrite <- (Zplus_0_r n); 
+ rewrite (Zplus_comm m n); apply Zplus_lt_compat_l; 
+ assumption.
+Qed.
+
+Lemma Zlt_O_minus_lt : forall n m:Z, 0 < n - m -> m < n.
+Proof.
+intros n m H; apply Zplus_lt_reg_l with (p := - m); rewrite Zplus_opp_l;
+ rewrite Zplus_comm; exact H.
+Qed.
\ No newline at end of file
diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v
new file mode 100644
index 00000000..e5bf8b04
--- /dev/null
+++ b/theories/ZArith/Zpower.v
@@ -0,0 +1,372 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Zpower.v,v 1.11.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+Require Import ZArith_base.
+Require Import Omega.
+Require Import Zcomplements.
+Open Local Scope Z_scope.
+
+Section section1.
+
+(** [Zpower_nat z n] is the n-th power of [z] when [n] is an unary
+    integer (type [nat]) and [z] a signed integer (type [Z]) *) 
+
+Definition Zpower_nat (z:Z) (n:nat) := iter_nat n Z (fun x:Z => z * x) 1.
+
+(** [Zpower_nat_is_exp] says [Zpower_nat] is a morphism for
+    [plus : nat->nat] and [Zmult : Z->Z] *)
+
+Lemma Zpower_nat_is_exp :
+ forall (n m:nat) (z:Z),
+   Zpower_nat z (n + m) = Zpower_nat z n * Zpower_nat z m.
+
+intros; elim n;
+ [ simpl in |- *; elim (Zpower_nat z m); auto with zarith
+ | unfold Zpower_nat in |- *; intros; simpl in |- *; rewrite H;
+    apply Zmult_assoc ].
+Qed.
+
+(** [Zpower_pos z n] is the n-th power of [z] when [n] is an binary
+    integer (type [positive]) and [z] a signed integer (type [Z]) *) 
+
+Definition Zpower_pos (z:Z) (n:positive) := iter_pos n Z (fun x:Z => z * x) 1.
+
+(** This theorem shows that powers of unary and binary integers
+   are the same thing, modulo the function convert : [positive -> nat] *)
+
+Theorem Zpower_pos_nat :
+ forall (z:Z) (p:positive), Zpower_pos z p = Zpower_nat z (nat_of_P p).
+
+intros; unfold Zpower_pos in |- *; unfold Zpower_nat in |- *;
+ apply iter_nat_of_P.
+Qed.
+
+(** Using the theorem [Zpower_pos_nat] and the lemma [Zpower_nat_is_exp] we
+   deduce that the function [[n:positive](Zpower_pos z n)] is a morphism
+   for [add : positive->positive] and [Zmult : Z->Z] *)
+
+Theorem Zpower_pos_is_exp :
+ forall (n m:positive) (z:Z),
+   Zpower_pos z (n + m) = Zpower_pos z n * Zpower_pos z m.
+
+intros.
+rewrite (Zpower_pos_nat z n).
+rewrite (Zpower_pos_nat z m).
+rewrite (Zpower_pos_nat z (n + m)).
+rewrite (nat_of_P_plus_morphism n m).
+apply Zpower_nat_is_exp.
+Qed.
+
+Definition Zpower (x y:Z) :=
+  match y with
+  | Zpos p => Zpower_pos x p
+  | Z0 => 1
+  | Zneg p => 0
+  end.
+
+Infix "^" := Zpower : Z_scope.
+
+Hint Immediate Zpower_nat_is_exp: zarith.
+Hint Immediate Zpower_pos_is_exp: zarith.
+Hint Unfold Zpower_pos: zarith.
+Hint Unfold Zpower_nat: zarith.
+
+Lemma Zpower_exp :
+ forall x n m:Z, n >= 0 -> m >= 0 -> x ^ (n + m) = x ^ n * x ^ m.
+destruct n; destruct m; auto with zarith.
+simpl in |- *; intros; apply Zred_factor0.
+simpl in |- *; auto with zarith.
+intros; compute in H0; absurd (Datatypes.Lt = Datatypes.Lt); auto with zarith.
+intros; compute in H0; absurd (Datatypes.Lt = Datatypes.Lt); auto with zarith.
+Qed.
+
+End section1.
+
+(* Exporting notation "^" *)
+
+Infix "^" := Zpower : Z_scope.
+
+Hint Immediate Zpower_nat_is_exp: zarith.
+Hint Immediate Zpower_pos_is_exp: zarith.
+Hint Unfold Zpower_pos: zarith.
+Hint Unfold Zpower_nat: zarith.
+
+Section Powers_of_2.
+
+(** For the powers of two, that will be widely used, a more direct
+   calculus is possible. We will also prove some properties such
+   as [(x:positive) x < 2^x] that are true for all integers bigger
+   than 2 but more difficult to prove and useless. *)     
+
+(** [shift n m] computes [2^n * m], or [m] shifted by [n] positions *)
+
+Definition shift_nat (n:nat) (z:positive) := iter_nat n positive xO z. 
+Definition shift_pos (n z:positive) := iter_pos n positive xO z. 
+Definition shift (n:Z) (z:positive) :=
+  match n with
+  | Z0 => z
+  | Zpos p => iter_pos p positive xO z
+  | Zneg p => z
+  end.
+
+Definition two_power_nat (n:nat) := Zpos (shift_nat n 1).
+Definition two_power_pos (x:positive) := Zpos (shift_pos x 1).
+
+Lemma two_power_nat_S :
+ forall n:nat, two_power_nat (S n) = 2 * two_power_nat n.
+intro; simpl in |- *; apply refl_equal.
+Qed.
+
+Lemma shift_nat_plus :
+ forall (n m:nat) (x:positive),
+   shift_nat (n + m) x = shift_nat n (shift_nat m x).
+
+intros; unfold shift_nat in |- *; apply iter_nat_plus.
+Qed.
+
+Theorem shift_nat_correct :
+ forall (n:nat) (x:positive), Zpos (shift_nat n x) = Zpower_nat 2 n * Zpos x.
+
+unfold shift_nat in |- *; simple induction n;
+ [ simpl in |- *; trivial with zarith
+ | intros; replace (Zpower_nat 2 (S n0)) with (2 * Zpower_nat 2 n0);
+    [ rewrite <- Zmult_assoc; rewrite <- (H x); simpl in |- *; reflexivity
+    | auto with zarith ] ].
+Qed.
+
+Theorem two_power_nat_correct :
+ forall n:nat, two_power_nat n = Zpower_nat 2 n.
+
+intro n.
+unfold two_power_nat in |- *.
+rewrite (shift_nat_correct n).
+omega.
+Qed.
+  
+(** Second we show that [two_power_pos] and [two_power_nat] are the same *)
+Lemma shift_pos_nat :
+ forall p x:positive, shift_pos p x = shift_nat (nat_of_P p) x.
+
+unfold shift_pos in |- *.
+unfold shift_nat in |- *.
+intros; apply iter_nat_of_P.
+Qed.
+
+Lemma two_power_pos_nat :
+ forall p:positive, two_power_pos p = two_power_nat (nat_of_P p).
+
+intro; unfold two_power_pos in |- *; unfold two_power_nat in |- *.
+apply f_equal with (f := Zpos).
+apply shift_pos_nat.
+Qed.
+
+(** Then we deduce that [two_power_pos] is also correct *)
+
+Theorem shift_pos_correct :
+ forall p x:positive, Zpos (shift_pos p x) = Zpower_pos 2 p * Zpos x.
+
+intros.
+rewrite (shift_pos_nat p x).
+rewrite (Zpower_pos_nat 2 p).
+apply shift_nat_correct.
+Qed.
+
+Theorem two_power_pos_correct :
+ forall x:positive, two_power_pos x = Zpower_pos 2 x.
+
+intro.
+rewrite two_power_pos_nat.
+rewrite Zpower_pos_nat.
+apply two_power_nat_correct.
+Qed.
+
+(** Some consequences *)
+
+Theorem two_power_pos_is_exp :
+ forall x y:positive,
+   two_power_pos (x + y) = two_power_pos x * two_power_pos y.
+intros.
+rewrite (two_power_pos_correct (x + y)).
+rewrite (two_power_pos_correct x).
+rewrite (two_power_pos_correct y).
+apply Zpower_pos_is_exp.
+Qed.
+
+(** The exponentiation [z -> 2^z] for [z] a signed integer. 
+    For convenience, we assume that [2^z = 0] for all [z < 0]
+    We could also define a inductive type [Log_result] with
+    3 contructors [ Zero | Pos positive -> | minus_infty]
+    but it's more complexe and not so useful. *)
+ 
+Definition two_p (x:Z) :=
+  match x with
+  | Z0 => 1
+  | Zpos y => two_power_pos y
+  | Zneg y => 0
+  end.
+
+Theorem two_p_is_exp :
+ forall x y:Z, 0 <= x -> 0 <= y -> two_p (x + y) = two_p x * two_p y.
+simple induction x;
+ [ simple induction y; simpl in |- *; auto with zarith
+ | simple induction y;
+    [ unfold two_p in |- *; rewrite (Zmult_comm (two_power_pos p) 1);
+       rewrite (Zmult_1_l (two_power_pos p)); auto with zarith
+    | unfold Zplus in |- *; unfold two_p in |- *; intros;
+       apply two_power_pos_is_exp
+    | intros; unfold Zle in H0; unfold Zcompare in H0;
+       absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ]
+ | simple induction y;
+    [ simpl in |- *; auto with zarith
+    | intros; unfold Zle in H; unfold Zcompare in H;
+       absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith
+    | intros; unfold Zle in H; unfold Zcompare in H;
+       absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ] ].
+Qed.
+
+Lemma two_p_gt_ZERO : forall x:Z, 0 <= x -> two_p x > 0.
+simple induction x; intros;
+ [ simpl in |- *; omega
+ | simpl in |- *; unfold two_power_pos in |- *; apply Zorder.Zgt_pos_0
+ | absurd (0 <= Zneg p);
+    [ simpl in |- *; unfold Zle in |- *; unfold Zcompare in |- *;
+       do 2 unfold not in |- *; auto with zarith
+    | assumption ] ].
+Qed.
+
+Lemma two_p_S : forall x:Z, 0 <= x -> two_p (Zsucc x) = 2 * two_p x.
+intros; unfold Zsucc in |- *. 
+rewrite (two_p_is_exp x 1 H (Zorder.Zle_0_pos 1)).
+apply Zmult_comm.
+Qed.
+
+Lemma two_p_pred : forall x:Z, 0 <= x -> two_p (Zpred x) < two_p x.
+intros; apply natlike_ind with (P := fun x:Z => two_p (Zpred x) < two_p x);
+ [ simpl in |- *; unfold Zlt in |- *; auto with zarith
+ | intros; elim (Zle_lt_or_eq 0 x0 H0);
+    [ intros;
+       replace (two_p (Zpred (Zsucc x0))) with (two_p (Zsucc (Zpred x0)));
+       [ rewrite (two_p_S (Zpred x0));
+          [ rewrite (two_p_S x0); [ omega | assumption ]
+          | apply Zorder.Zlt_0_le_0_pred; assumption ]
+       | rewrite <- (Zsucc_pred x0); rewrite <- (Zpred_succ x0);
+          trivial with zarith ]
+    | intro Hx0; rewrite <- Hx0; simpl in |- *; unfold Zlt in |- *;
+       auto with zarith ]
+ | assumption ].
+Qed. 
+
+Lemma Zlt_lt_double : forall x y:Z, 0 <= x < y -> x < 2 * y.
+intros; omega. Qed. 
+
+End Powers_of_2.
+
+Hint Resolve two_p_gt_ZERO: zarith.
+Hint Immediate two_p_pred two_p_S: zarith.
+
+Section power_div_with_rest.
+
+(** Division by a power of two.
+    To [n:Z] and [p:positive], [q],[r] are associated such that
+    [n = 2^p.q + r] and [0 <= r < 2^p] *)
+
+(** Invariant: [d*q + r = d'*q + r /\ d' = 2*d /\ 0<= r < d /\ 0 <= r' < d'] *)
+Definition Zdiv_rest_aux (qrd:Z * Z * Z) :=
+  let (qr, d) := qrd in
+  let (q, r) := qr in
+  (match q with
+   | Z0 => (0, r)
+   | Zpos xH => (0, d + r)
+   | Zpos (xI n) => (Zpos n, d + r)
+   | Zpos (xO n) => (Zpos n, r)
+   | Zneg xH => (-1, d + r)
+   | Zneg (xI n) => (Zneg n - 1, d + r)
+   | Zneg (xO n) => (Zneg n, r)
+   end, 2 * d).
+
+Definition Zdiv_rest (x:Z) (p:positive) :=
+  let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in qr.
+
+Lemma Zdiv_rest_correct1 :
+ forall (x:Z) (p:positive),
+   let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in d = two_power_pos p.
+
+intros x p; rewrite (iter_nat_of_P p _ Zdiv_rest_aux (x, 0, 1));
+ rewrite (two_power_pos_nat p); elim (nat_of_P p); 
+ simpl in |- *;
+ [ trivial with zarith
+ | intro n; rewrite (two_power_nat_S n); unfold Zdiv_rest_aux at 2 in |- *;
+    elim (iter_nat n (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)); 
+    destruct a; intros; apply f_equal with (f := fun z:Z => 2 * z);
+    assumption ]. 
+Qed.
+
+Lemma Zdiv_rest_correct2 :
+ forall (x:Z) (p:positive),
+   let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in
+   let (q, r) := qr in x = q * d + r /\ 0 <= r < d.
+
+intros;
+ apply iter_pos_invariant with
+  (f := Zdiv_rest_aux)
+  (Inv := fun qrd:Z * Z * Z =>
+            let (qr, d) := qrd in
+            let (q, r) := qr in x = q * d + r /\ 0 <= r < d);
+ [ intro x0; elim x0; intro y0; elim y0; intros q r d;
+    unfold Zdiv_rest_aux in |- *; elim q;
+    [ omega
+    | destruct p0;
+       [ rewrite BinInt.Zpos_xI; intro; elim H; intros; split;
+          [ rewrite H0; rewrite Zplus_assoc; rewrite Zmult_plus_distr_l;
+             rewrite Zmult_1_l; rewrite Zmult_assoc;
+             rewrite (Zmult_comm (Zpos p0) 2); apply refl_equal
+          | omega ]
+       | rewrite BinInt.Zpos_xO; intro; elim H; intros; split;
+          [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zpos p0) 2);
+             apply refl_equal
+          | omega ]
+       | omega ]
+    | destruct p0;
+       [ rewrite BinInt.Zneg_xI; unfold Zminus in |- *; intro; elim H; intros;
+          split;
+          [ rewrite H0; rewrite Zplus_assoc;
+             apply f_equal with (f := fun z:Z => z + r);
+             do 2 rewrite Zmult_plus_distr_l; rewrite Zmult_assoc;
+             rewrite (Zmult_comm (Zneg p0) 2); rewrite <- Zplus_assoc;
+             apply f_equal with (f := fun z:Z => 2 * Zneg p0 * d + z); 
+             omega
+          | omega ]
+       | rewrite BinInt.Zneg_xO; unfold Zminus in |- *; intro; elim H; intros;
+          split;
+          [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zneg p0) 2);
+             apply refl_equal
+          | omega ]
+       | omega ] ]
+ | omega ].
+Qed.
+
+Inductive Zdiv_rest_proofs (x:Z) (p:positive) : Set :=
+    Zdiv_rest_proof :
+      forall q r:Z,
+        x = q * two_power_pos p + r ->
+        0 <= r -> r < two_power_pos p -> Zdiv_rest_proofs x p.
+
+Lemma Zdiv_rest_correct : forall (x:Z) (p:positive), Zdiv_rest_proofs x p.
+intros x p.
+generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p).
+elim (iter_pos p (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)).
+simple induction a.
+intros.
+elim H; intros H1 H2; clear H.
+rewrite H0 in H1; rewrite H0 in H2; elim H2; intros;
+ apply Zdiv_rest_proof with (q := a0) (r := b); assumption.
+Qed.
+
+End power_div_with_rest.
\ No newline at end of file
diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt.v
new file mode 100644
index 00000000..583c5828
--- /dev/null
+++ b/theories/ZArith/Zsqrt.v
@@ -0,0 +1,163 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: Zsqrt.v,v 1.11.2.1 2004/07/16 19:31:22 herbelin Exp $ *)
+
+Require Import Omega.
+Require Export ZArith_base.
+Require Export ZArithRing.
+Open Local Scope Z_scope.
+
+(**********************************************************************)
+(** Definition and properties of square root on Z *)
+
+(** The following tactic replaces all instances of (POS (xI ...)) by
+    `2*(POS ...)+1`, but only when ... is not made only with xO, XI, or xH. *)
+Ltac compute_POS :=
+  match goal with
+  |  |- context [(Zpos (xI ?X1))] =>
+      match constr:X1 with
+      | context [1%positive] => fail
+      | _ => rewrite (BinInt.Zpos_xI X1)
+      end
+  |  |- context [(Zpos (xO ?X1))] =>
+      match constr:X1 with
+      | context [1%positive] => fail
+      | _ => rewrite (BinInt.Zpos_xO X1)
+      end
+  end.
+
+Inductive sqrt_data (n:Z) : Set :=
+    c_sqrt : forall s r:Z, n = s * s + r -> 0 <= r <= 2 * s -> sqrt_data n.
+
+Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p).
+refine
+ (fix sqrtrempos (p:positive) : sqrt_data (Zpos p) :=
+    match p return sqrt_data (Zpos p) with
+    | xH => c_sqrt 1 1 0 _ _
+    | xO xH => c_sqrt 2 1 1 _ _
+    | xI xH => c_sqrt 3 1 2 _ _
+    | xO (xO p') =>
+        match sqrtrempos p' with
+        | c_sqrt s' r' Heq Hint =>
+            match Z_le_gt_dec (4 * s' + 1) (4 * r') with
+            | left Hle =>
+                c_sqrt (Zpos (xO (xO p'))) (2 * s' + 1)
+                  (4 * r' - (4 * s' + 1)) _ _
+            | right Hgt => c_sqrt (Zpos (xO (xO p'))) (2 * s') (4 * r') _ _
+            end
+        end
+    | xO (xI p') =>
+        match sqrtrempos p' with
+        | c_sqrt s' r' Heq Hint =>
+            match Z_le_gt_dec (4 * s' + 1) (4 * r' + 2) with
+            | left Hle =>
+                c_sqrt (Zpos (xO (xI p'))) (2 * s' + 1)
+                  (4 * r' + 2 - (4 * s' + 1)) _ _
+            | right Hgt =>
+                c_sqrt (Zpos (xO (xI p'))) (2 * s') (4 * r' + 2) _ _
+            end
+        end
+    | xI (xO p') =>
+        match sqrtrempos p' with
+        | c_sqrt s' r' Heq Hint =>
+            match Z_le_gt_dec (4 * s' + 1) (4 * r' + 1) with
+            | left Hle =>
+                c_sqrt (Zpos (xI (xO p'))) (2 * s' + 1)
+                  (4 * r' + 1 - (4 * s' + 1)) _ _
+            | right Hgt =>
+                c_sqrt (Zpos (xI (xO p'))) (2 * s') (4 * r' + 1) _ _
+            end
+        end
+    | xI (xI p') =>
+        match sqrtrempos p' with
+        | c_sqrt s' r' Heq Hint =>
+            match Z_le_gt_dec (4 * s' + 1) (4 * r' + 3) with
+            | left Hle =>
+                c_sqrt (Zpos (xI (xI p'))) (2 * s' + 1)
+                  (4 * r' + 3 - (4 * s' + 1)) _ _
+            | right Hgt =>
+                c_sqrt (Zpos (xI (xI p'))) (2 * s') (4 * r' + 3) _ _
+            end
+        end
+    end); clear sqrtrempos; repeat compute_POS;
+ try (try rewrite Heq; ring; fail); try omega.
+Defined.
+
+(** Define with integer input, but with a strong (readable) specification. *)
+Definition Zsqrt :
+  forall x:Z,
+    0 <= x ->
+    {s : Z &  {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}}.
+refine
+ (fun x =>
+    match
+      x
+      return
+        0 <= x ->
+        {s : Z &  {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}}
+    with
+    | Zpos p =>
+        fun h =>
+          match sqrtrempos p with
+          | c_sqrt s r Heq Hint =>
+              existS
+                (fun s:Z =>
+                   {r : Z |
+                   Zpos p = s * s + r /\ s * s <= Zpos p < (s + 1) * (s + 1)})
+                s
+                (exist
+                   (fun r:Z =>
+                      Zpos p = s * s + r /\
+                      s * s <= Zpos p < (s + 1) * (s + 1)) r _)
+          end
+    | Zneg p =>
+        fun h =>
+          False_rec
+            {s : Z & 
+            {r : Z |
+            Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}}
+            (h (refl_equal Datatypes.Gt))
+    | Z0 =>
+        fun h =>
+          existS
+            (fun s:Z =>
+               {r : Z | 0 = s * s + r /\ s * s <= 0 < (s + 1) * (s + 1)}) 0
+            (exist
+               (fun r:Z => 0 = 0 * 0 + r /\ 0 * 0 <= 0 < (0 + 1) * (0 + 1)) 0
+               _)
+    end); try omega.
+split; [ omega | rewrite Heq; ring ((s + 1) * (s + 1)); omega ].
+Defined.
+
+(** Define a function of type Z->Z that computes the integer square root,
+    but only for positive numbers, and 0 for others. *)
+Definition Zsqrt_plain (x:Z) : Z :=
+  match x with
+  | Zpos p =>
+      match Zsqrt (Zpos p) (Zorder.Zle_0_pos p) with
+      | existS s _ => s
+      end
+  | Zneg p => 0
+  | Z0 => 0
+  end.
+
+(** A basic theorem about Zsqrt_plain *)
+Theorem Zsqrt_interval :
+ forall n:Z,
+   0 <= n ->
+   Zsqrt_plain n * Zsqrt_plain n <= n <
+   (Zsqrt_plain n + 1) * (Zsqrt_plain n + 1).
+intros x; case x.
+unfold Zsqrt_plain in |- *; omega.
+intros p; unfold Zsqrt_plain in |- *;
+ case (Zsqrt (Zpos p) (Zorder.Zle_0_pos p)).
+intros s [r [Heq Hint]] Hle; assumption.
+intros p Hle; elim Hle; auto.
+Qed.
+
diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v
new file mode 100644
index 00000000..8633986b
--- /dev/null
+++ b/theories/ZArith/Zwf.v
@@ -0,0 +1,96 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: Zwf.v,v 1.7.2.1 2004/07/16 19:31:22 herbelin Exp $ *)
+
+Require Import ZArith_base.
+Require Export Wf_nat.
+Require Import Omega.
+Open Local Scope Z_scope.
+
+(** Well-founded relations on Z. *)
+
+(** We define the following family of relations on [Z x Z]: 
+
+    [x (Zwf c) y]   iff   [x < y & c <= y]
+ *)
+
+Definition Zwf (c x y:Z) := c <= y /\ x < y.
+
+(** and we prove that [(Zwf c)] is well founded *)
+
+Section wf_proof.
+
+Variable c : Z.
+
+(** The proof of well-foundness is classic: we do the proof by induction
+    on a measure in nat, which is here [|x-c|] *)
+
+Let f (z:Z) := Zabs_nat (z - c).
+
+Lemma Zwf_well_founded : well_founded (Zwf c).
+red in |- *; intros.
+assert (forall (n:nat) (a:Z), (f a < n)%nat \/ a < c -> Acc (Zwf c) a).
+clear a; simple induction n; intros.
+(** n= 0 *)
+case H; intros.
+case (lt_n_O (f a)); auto.
+apply Acc_intro; unfold Zwf in |- *; intros.
+assert False; omega || contradiction.
+(** inductive case *)
+case H0; clear H0; intro; auto.
+apply Acc_intro; intros.
+apply H.
+unfold Zwf in H1.
+case (Zle_or_lt c y); intro; auto with zarith.
+left.
+red in H0.
+apply lt_le_trans with (f a); auto with arith.
+unfold f in |- *.
+apply Zabs.Zabs_nat_lt; omega.
+apply (H (S (f a))); auto.
+Qed.
+
+End wf_proof.
+
+Hint Resolve Zwf_well_founded: datatypes v62.
+
+
+(** We also define the other family of relations:
+
+    [x (Zwf_up c) y]   iff   [y < x <= c]
+ *)
+
+Definition Zwf_up (c x y:Z) := y < x <= c.
+
+(** and we prove that [(Zwf_up c)] is well founded *)
+
+Section wf_proof_up.
+
+Variable c : Z.
+
+(** The proof of well-foundness is classic: we do the proof by induction
+    on a measure in nat, which is here [|c-x|] *)
+
+Let f (z:Z) := Zabs_nat (c - z).
+
+Lemma Zwf_up_well_founded : well_founded (Zwf_up c).
+Proof.
+apply well_founded_lt_compat with (f := f).
+unfold Zwf_up, f in |- *.
+intros.
+apply Zabs.Zabs_nat_lt.
+unfold Zminus in |- *. split.
+apply Zle_left; intuition.
+apply Zplus_lt_compat_l; unfold Zlt in |- *; rewrite <- Zcompare_opp;
+ intuition.
+Qed.
+
+End wf_proof_up.
+
+Hint Resolve Zwf_up_well_founded: datatypes v62.
\ No newline at end of file
diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v
new file mode 100644
index 00000000..ecd2daab
--- /dev/null
+++ b/theories/ZArith/auxiliary.v
@@ -0,0 +1,150 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: auxiliary.v,v 1.12.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
+
+Require Export Arith.
+Require Import BinInt.
+Require Import Zorder.
+Require Import Decidable.
+Require Import Peano_dec.
+Require Export Compare_dec.
+
+Open Local Scope Z_scope.
+
+(**********************************************************************)
+(** Moving terms from one side to the other of an inequality *)
+
+Theorem Zne_left : forall n m:Z, Zne n m -> Zne (n + - m) 0.
+Proof.
+intros x y; unfold Zne in |- *; unfold not in |- *; intros H1 H2; apply H1;
+ apply Zplus_reg_l with (- y); rewrite Zplus_opp_l; 
+ rewrite Zplus_comm; trivial with arith.
+Qed.
+
+Theorem Zegal_left : forall n m:Z, n = m -> n + - m = 0.
+Proof.
+intros x y H; apply (Zplus_reg_l y); rewrite Zplus_permute;
+ rewrite Zplus_opp_r; do 2 rewrite Zplus_0_r; assumption.
+Qed.
+
+Theorem Zle_left : forall n m:Z, n <= m -> 0 <= m + - n.
+Proof.
+intros x y H; replace 0 with (x + - x).
+apply Zplus_le_compat_r; trivial.
+apply Zplus_opp_r.
+Qed.
+
+Theorem Zle_left_rev : forall n m:Z, 0 <= m + - n -> n <= m.
+Proof.
+intros x y H; apply Zplus_le_reg_r with (- x).
+rewrite Zplus_opp_r; trivial.
+Qed.
+
+Theorem Zlt_left_rev : forall n m:Z, 0 < m + - n -> n < m.
+Proof.
+intros x y H; apply Zplus_lt_reg_r with (- x).
+rewrite Zplus_opp_r; trivial.
+Qed.
+
+Theorem Zlt_left : forall n m:Z, n < m -> 0 <= m + -1 + - n.
+Proof.
+intros x y H; apply Zle_left; apply Zsucc_le_reg;
+ change (Zsucc x <= Zsucc (Zpred y)) in |- *; rewrite <- Zsucc_pred;
+ apply Zlt_le_succ; assumption.
+Qed.
+
+Theorem Zlt_left_lt : forall n m:Z, n < m -> 0 < m + - n.
+Proof.
+intros x y H; replace 0 with (x + - x).
+apply Zplus_lt_compat_r; trivial.
+apply Zplus_opp_r.
+Qed.
+
+Theorem Zge_left : forall n m:Z, n >= m -> 0 <= n + - m.
+Proof.
+intros x y H; apply Zle_left; apply Zge_le; assumption.
+Qed.
+
+Theorem Zgt_left : forall n m:Z, n > m -> 0 <= n + -1 + - m.
+Proof.
+intros x y H; apply Zlt_left; apply Zgt_lt; assumption.
+Qed.
+
+Theorem Zgt_left_gt : forall n m:Z, n > m -> n + - m > 0.
+Proof.
+intros x y H; replace 0 with (y + - y).
+apply Zplus_gt_compat_r; trivial.
+apply Zplus_opp_r.
+Qed.
+
+Theorem Zgt_left_rev : forall n m:Z, n + - m > 0 -> n > m.
+Proof.
+intros x y H; apply Zplus_gt_reg_r with (- y).
+rewrite Zplus_opp_r; trivial.
+Qed.
+
+(**********************************************************************)
+(** Factorization lemmas *)
+
+Theorem Zred_factor0 : forall n:Z, n = n * 1.
+intro x; rewrite (Zmult_1_r x); reflexivity.
+Qed.
+
+Theorem Zred_factor1 : forall n:Z, n + n = n * 2.
+Proof.
+exact Zplus_diag_eq_mult_2.
+Qed.
+
+Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m).
+
+intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x);
+ rewrite <- Zmult_plus_distr_r; trivial with arith.
+Qed.
+
+Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m).
+
+intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x);
+ rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; 
+ trivial with arith.
+Qed.
+Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p).
+intros x y z; symmetry  in |- *; apply Zmult_plus_distr_r.
+Qed.
+
+Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m.
+
+intros x y; rewrite <- Zmult_0_r_reverse; auto with arith.
+Qed.
+
+Theorem Zred_factor6 : forall n:Z, n = n + 0.
+
+intro; rewrite Zplus_0_r; trivial with arith.
+Qed.
+
+Theorem Zle_mult_approx :
+ forall n m p:Z, n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p.
+
+intros x y z H1 H2 H3; apply Zle_trans with (m := y * x);
+ [ apply Zmult_gt_0_le_0_compat; assumption
+ | pattern (y * x) at 1 in |- *; rewrite <- Zplus_0_r;
+    apply Zplus_le_compat_l; apply Zlt_le_weak; apply Zgt_lt; 
+    assumption ].
+Qed.
+
+Theorem Zmult_le_approx :
+ forall n m p:Z, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m.
+
+intros x y z H1 H2 H3; apply Zlt_succ_le; apply Zmult_gt_0_lt_0_reg_r with x;
+ [ assumption
+ | apply Zle_lt_trans with (1 := H3); rewrite <- Zmult_succ_l_reverse;
+    apply Zplus_lt_compat_l; apply Zgt_lt; assumption ].
+
+Qed.
diff --git a/theories/ZArith/intro.tex b/theories/ZArith/intro.tex
new file mode 100755
index 00000000..21e52c19
--- /dev/null
+++ b/theories/ZArith/intro.tex
@@ -0,0 +1,6 @@
+\section{Binary integers : ZArith}
+The {\tt ZArith} library deals with binary integers (those used
+by the {\tt Omega} decision tactic).
+Here are defined various arithmetical notions and their properties,
+similar to those of {\tt Arith}.
+