Imported Upstream version 8.0pl3+8.1betaupstream/8.0pl3+8.1beta

84 files changed, 18681 insertions, 4480 deletions

diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v
index 3a87ee1a..d2eead86 100644
--- a/theories/Arith/Compare_dec.v
+++ b/theories/Arith/Compare_dec.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Compare_dec.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id: Compare_dec.v 8733 2006-04-25 22:52:18Z letouzey $ i*)
 
 Require Import Le.
 Require Import Lt.
@@ -105,3 +105,139 @@ Qed.
 Theorem not_lt : forall n m, ~ n < m -> n >= m.
 intros x y H; exact (not_gt y x H). 
 Qed.
+
+
+(** A ternary comparison function in the spirit of [Zcompare]. *)
+
+Definition nat_compare (n m:nat) :=
+ match lt_eq_lt_dec n m with 
+  | inleft (left _) => Lt
+  | inleft (right _) => Eq
+  | inright _ => Gt
+ end.
+
+Lemma nat_compare_S : forall n m, nat_compare (S n) (S m) = nat_compare n m.
+Proof.
+ unfold nat_compare; intros.
+ simpl; destruct (lt_eq_lt_dec n m) as [[H|H]|H]; simpl; auto.
+Qed.
+
+Lemma nat_compare_eq : forall n m, nat_compare n m = Eq -> n = m.
+Proof.
+  induction n; destruct m; simpl; auto.
+  unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; 
+    auto; intros; try discriminate.
+  unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; 
+    auto; intros; try discriminate.
+  rewrite nat_compare_S; auto.
+Qed.
+
+Lemma nat_compare_lt : forall n m, n<m <-> nat_compare n m = Lt.
+Proof.
+  induction n; destruct m; simpl.
+  unfold nat_compare; simpl; intuition; [inversion H | discriminate H].
+  split; auto with arith.
+  split; [inversion 1 |].
+  unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; 
+    auto; intros; try discriminate.
+  rewrite nat_compare_S.
+  generalize (IHn m); clear IHn; intuition.
+Qed.
+
+Lemma nat_compare_gt : forall n m, n>m <-> nat_compare n m = Gt.
+Proof.
+  induction n; destruct m; simpl.
+  unfold nat_compare; simpl; intuition; [inversion H | discriminate H].
+  split; [inversion 1 |].
+  unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; 
+    auto; intros; try discriminate.
+  split; auto with arith.
+  rewrite nat_compare_S.
+  generalize (IHn m); clear IHn; intuition.
+Qed.
+
+Lemma nat_compare_le : forall n m, n<=m <-> nat_compare n m <> Gt.
+Proof.
+  split.
+  intros.
+  intro.
+  destruct (nat_compare_gt n m).
+  generalize (le_lt_trans _ _ _ H (H2 H0)).
+  exact (lt_irrefl n).
+  intros.
+  apply not_gt.
+  swap H.
+  destruct (nat_compare_gt n m); auto.
+Qed.  
+
+Lemma nat_compare_ge : forall n m, n>=m <-> nat_compare n m <> Lt.
+Proof.
+  split.
+  intros.
+  intro.
+  destruct (nat_compare_lt n m).
+  generalize (le_lt_trans _ _ _ H (H2 H0)).
+  exact (lt_irrefl m).
+  intros.
+  apply not_lt.
+  swap H.
+  destruct (nat_compare_lt n m); auto.
+Qed.  
+
+(** A boolean version of [le] over [nat]. *)
+
+Fixpoint leb (m:nat) : nat -> bool :=
+  match m with
+  | O => fun _:nat => true
+  | S m' =>
+      fun n:nat => match n with
+                   | O => false
+                   | S n' => leb m' n'
+                   end
+  end.
+
+Lemma leb_correct : forall m n:nat, m <= n -> leb 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 leb_complete : forall m n:nat, leb m n = true -> m <= n.
+Proof.
+  induction m. trivial with arith.
+  destruct n. intro H. discriminate H.
+  auto with arith.
+Qed.
+
+Lemma leb_correct_conv : forall m n:nat, m < n -> leb n m = false.
+Proof.
+  intros. 
+  generalize (leb_complete n m).
+  destruct (leb n m); auto.
+  intros.
+  elim (lt_irrefl _ (lt_le_trans _ _ _ H (H0 (refl_equal true)))).
+Qed.
+
+Lemma leb_complete_conv : forall m n:nat, leb n m = false -> m < n.
+Proof.
+  intros. elim (le_or_lt n m). intro. conditional trivial rewrite leb_correct in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma leb_compare : forall n m, leb n m = true <-> nat_compare n m <> Gt.
+Proof.
+ induction n; destruct m; simpl.
+ unfold nat_compare; simpl.
+ intuition; discriminate.
+ split; auto with arith.
+ unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; 
+  intuition; try discriminate.
+ inversion H.
+ split; try (intros; discriminate).
+ unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; 
+  intuition; try discriminate.
+ inversion H.
+ rewrite nat_compare_S; auto.
+Qed. 
+
diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v
index 6e5d292f..ca1f39af 100644
--- a/theories/Arith/Div2.v
+++ b/theories/Arith/Div2.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Div2.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id: Div2.v 8733 2006-04-25 22:52:18Z letouzey $ i*)
 
 Require Import Lt.
 Require Import Plus.
@@ -173,3 +173,25 @@ Lemma odd_S2n : forall n, odd n -> {p : nat | n = S (double p)}.
 Proof.
 intros n H. exists (div2 n). auto with arith.
 Qed.
+
+(** Doubling before dividing by two brings back to the initial number. *)
+
+Lemma div2_double : forall n:nat, div2 (2*n) = n.
+Proof.
+ induction n.
+ simpl; auto.
+ simpl.
+ replace (n+S(n+0)) with (S (2*n)).
+ f_equal; auto.
+ simpl; auto with arith.
+Qed.
+
+Lemma div2_double_plus_one : forall n:nat, div2 (S (2*n)) = n.
+Proof.
+ induction n.
+ simpl; auto.
+ simpl.
+ replace (n+S(n+0)) with (S (2*n)).
+ f_equal; auto.
+ simpl; auto with arith.
+Qed.
diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v
index b58ed280..576993c9 100644
--- a/theories/Bool/Bvector.v
+++ b/theories/Bool/Bvector.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Bvector.v 6844 2005-03-16 13:09:55Z herbelin $ i*)
+(*i $Id: Bvector.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
 (** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *)
 
@@ -18,37 +18,37 @@ Open Local Scope nat_scope.
 
 (*  
 On s'inspire de List.v pour fabriquer les vecteurs de bits.
-La dimension du vecteur est un paramètre trop important pour
+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.
+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, car le
-mécanisme d'inférence du type du filtrage n'est pas aussi puissant que
-celui implanté par les tactiques d'élimination.
+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, car le
+mécanisme d'inférence du type du filtrage n'est pas aussi puissant que
+celui implanté par les tactiques d'élimination.
 *)
 
 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.
+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.
+Variable A : Type.
 
-Inductive vector : nat -> Set :=
+Inductive vector : nat -> Type :=
   | Vnil : vector 0
   | Vcons : forall (a:A) (n:nat), vector n -> vector (S n).
 
@@ -59,7 +59,7 @@ Defined.
 
 Definition Vtail : forall n:nat, vector (S n) -> vector n.
 Proof.
-	intros n v; inversion v; exact H0.
+	intros n v; inversion v as [|_ n0 H0 H1]; exact H0.
 Defined.
 
 Definition Vlast : forall n:nat, vector (S n) -> A.
@@ -68,7 +68,7 @@ Proof.
 	inversion v.
 	exact a.
 
-	inversion v.
+	inversion v as [| n0 a H0 H1].
 	exact (f H0).
 Defined.
 
@@ -85,7 +85,7 @@ Proof.
 	induction n as [| n f]; intro v.
 	exact Vnil.
 
-	inversion v.
+	inversion v as [| a n0 H0 H1].
 	exact (Vcons a n (f H0)).
 Defined.
 
@@ -94,7 +94,7 @@ Proof.
 	induction n as [| n f]; intros a v.
 	exact (Vcons a 0 v).
 
-	inversion v.
+	inversion v as [| a0 n0 H0 H1 ].
 	exact (Vcons a (S n) (f a H0)).
 Defined.
 
@@ -104,7 +104,7 @@ Proof.
 	inversion v.
 	exact (Vcons a 1 v).
 
-	inversion v.
+	inversion v as [| a n0 H0 H1 ].
 	exact (Vcons a (S (S n)) (f H0)).
 Defined.
 
@@ -128,7 +128,7 @@ Proof.
 	induction n as [| n f]; intros p v v0.
 	simpl in |- *; exact v0.
 
-	inversion v.
+	inversion v as [| a n0 H0 H1].
 	simpl in |- *; exact (Vcons a (n + p) (f p H0 v0)).
 Defined.
 
@@ -139,7 +139,7 @@ Proof.
 	induction n as [| n g]; intro v.
 	exact Vnil.
 
-	inversion v.
+	inversion v as [| a n0 H0 H1].
 	exact (Vcons (f a) n (g H0)).
 Defined.
 
@@ -150,10 +150,35 @@ Proof.
 	induction n as [| n h]; intros v v0.
 	exact Vnil.
 
-	inversion v; inversion v0.
+	inversion v as [| a n0 H0 H1]; inversion v0 as [| a0 n1 H2 H3].
 	exact (Vcons (g a a0) n (h H0 H2)).
 Defined.
 
+Definition Vid : forall n:nat, vector n -> vector n.
+Proof.
+destruct n; intro X.
+exact Vnil.
+exact (Vcons (Vhead _ X) _ (Vtail _ X)).
+Defined.
+
+Lemma Vid_eq : forall (n:nat) (v:vector n), v=(Vid n v).
+Proof.
+destruct v; auto.
+Qed.
+
+Lemma VSn_eq :
+  forall (n : nat) (v : vector (S n)), v = Vcons (Vhead _ v) _ (Vtail _ v).
+Proof.
+intros.
+exact (Vid_eq _ v).
+Qed.
+
+Lemma V0_eq : forall (v : vector 0), v = Vnil.
+Proof.
+intros.
+exact (Vid_eq _ v).
+Qed.
+
 End VECTORS.
 
 (* suppressed: incompatible with Coq-Art book 
@@ -164,14 +189,14 @@ 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.
+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
+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
+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).
 *)
 
diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v
index b95b25fd..31ff029c 100644
--- a/theories/Bool/DecBool.v
+++ b/theories/Bool/DecBool.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: DecBool.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id: DecBool.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
 Set Implicit Arguments.
 
-Definition ifdec (A B:Prop) (C:Set) (H:{A} + {B}) (x y:C) : C :=
+Definition ifdec (A B:Prop) (C:Type) (H:{A} + {B}) (x y:C) : C :=
   if H then x else y.
 
 
@@ -28,4 +28,4 @@ intros; case H; auto.
 intro; absurd A; trivial.
 Qed.
 
-Unset Implicit Arguments.
\ No newline at end of file
+Unset Implicit Arguments.
diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v
new file mode 100644
index 00000000..425528ee
--- /dev/null
+++ b/theories/FSets/FMapAVL.v
@@ -0,0 +1,2058 @@
+
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite map library.  *)
+
+(* $Id: FMapAVL.v 8899 2006-06-06 11:09:43Z jforest $ *)
+
+(** This module implements map using AVL trees.
+    It follows the implementation from Ocaml's standard library. *)
+
+Require Import FSetInterface.
+Require Import FMapInterface.
+Require Import FMapList.
+
+Require Import ZArith.
+Require Import Int.
+
+Set Firstorder Depth 3.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+
+Module Raw (I:Int)(X: OrderedType).
+Import I.
+Module II:=MoreInt(I).
+Import II.
+Open Scope Int_scope.
+
+Module E := X.
+Module MX := OrderedTypeFacts X.
+Module PX := KeyOrderedType X.
+Module L := FMapList.Raw X.
+Import MX. 
+Import PX.
+
+Definition key := X.t.
+
+(** * Trees *)
+
+Section Elt.
+
+Variable elt : Set.
+
+(* Now in KeyOrderedType:
+Definition eqk (p p':key*elt) := X.eq (fst p) (fst p').
+Definition eqke (p p':key*elt) := 
+         X.eq (fst p) (fst p') /\ (snd p) = (snd p').
+Definition ltk (p p':key*elt) := X.lt (fst p) (fst p').
+*)
+
+Notation eqk := (eqk (elt:= elt)).
+Notation eqke := (eqke (elt:= elt)).
+Notation ltk := (ltk (elt:= elt)).
+
+Inductive tree  : Set :=
+  | Leaf : tree
+  | Node : tree -> key -> elt -> tree -> int -> tree.
+
+Notation t := tree.
+
+(** The Sixth field of [Node] is the height of the tree *)
+
+(** * Occurrence in a tree *)
+
+Inductive MapsTo (x : key)(e : elt) : tree -> Prop :=
+  | MapsRoot : forall l r h y,
+      X.eq x y -> MapsTo x e (Node l y e r h)
+  | MapsLeft : forall l r h y e', 
+      MapsTo x e l -> MapsTo x e (Node l y e' r h)
+  | MapsRight : forall l r h y e', 
+      MapsTo x e r -> MapsTo x e (Node l y e' r h).
+
+Inductive In (x : key) : tree -> Prop :=
+  | InRoot : forall l r h y e,
+      X.eq x y -> In x (Node l y e r h)
+  | InLeft : forall l r h y e', 
+      In x l -> In x (Node l y e' r h)
+  | InRight : forall l r h y e', 
+      In x r -> In x (Node l y e' r h).
+
+Definition In0 (k:key)(m:t) : Prop := exists e:elt, MapsTo k e m.
+
+(** * Binary search trees *)
+
+(** [lt_tree x s]: all elements in [s] are smaller than [x] 
+   (resp. greater for [gt_tree]) *)
+
+Definition lt_tree x s := forall y:key, In y s -> X.lt y x.
+Definition gt_tree x s := forall y:key, In y s -> X.lt x y.
+
+(** [bst t] : [t] is a binary search tree *)
+
+Inductive bst : tree -> Prop :=
+  | BSLeaf : bst Leaf
+  | BSNode : forall x e l r h, 
+      bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (Node l x e r h).
+
+(** * AVL trees *)
+
+(** [avl s] : [s] is a properly balanced AVL tree,
+    i.e. for any node the heights of the two children
+    differ by at most 2 *)
+
+Definition height (s : tree) : int :=
+  match s with
+  | Leaf => 0
+  | Node _ _ _ _ h => h
+  end.
+
+Inductive avl : tree -> Prop :=
+  | RBLeaf : avl Leaf
+  | RBNode : forall x e l r h, 
+      avl l ->
+      avl r ->
+      -(2) <= height l - height r <= 2 ->
+      h = max (height l) (height r) + 1 -> 
+      avl (Node l x e r h).
+
+(* We should end this section before the big proofs that follows, 
+    otherwise the discharge takes a lot of time. *)
+End Elt. 
+
+(** Some helpful hints and tactics. *)
+
+Notation t := tree.
+Hint Constructors tree.
+Hint Constructors MapsTo.
+Hint Constructors In.
+Hint Constructors bst.
+Hint Constructors avl.
+Hint Unfold lt_tree gt_tree.
+
+Ltac inv f :=
+  match goal with 
+     | H:f (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f _ (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | _ => idtac
+  end.
+
+Ltac safe_inv f := match goal with 
+  | H:f (Node _ _ _ _ _) |- _ => 
+        generalize H; inversion_clear H; safe_inv f
+  | H:f _ (Node _ _ _ _ _) |- _ => 
+        generalize H; inversion_clear H; safe_inv f
+  | _ => intros 
+ end.
+
+Ltac inv_all f := 
+  match goal with 
+   | H: f _ |- _ => inversion_clear H; inv f
+   | H: f _ _ |- _ => inversion_clear H; inv f
+   | H: f _ _ _ |- _ => inversion_clear H; inv f
+   | H: f _ _ _ _ |- _ => inversion_clear H; inv f
+   | _ => idtac
+  end.
+
+Ltac order := match goal with 
+ | H: lt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order
+ | H: gt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order
+ | _ => MX.order
+end.
+
+Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo).
+Ltac firstorder_in := repeat progress (firstorder; inv In; inv MapsTo).
+
+Lemma height_non_negative : forall elt (s : t elt), avl s -> height s >= 0.
+Proof.
+ induction s; simpl; intros; auto with zarith.
+ inv avl; intuition; omega_max.
+Qed.
+
+Ltac avl_nn_hyp H := 
+     let nz := fresh "nz" in assert (nz := height_non_negative H).
+
+Ltac avl_nn h := 
+  let t := type of h in 
+  match type of t with 
+   | Prop => avl_nn_hyp h
+   | _ => match goal with H : avl h |- _ => avl_nn_hyp H end
+  end.
+
+(* Repeat the previous tactic. 
+   Drawback: need to clear the [avl _] hyps ... Thank you Ltac *)
+
+Ltac avl_nns :=
+  match goal with 
+     | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns
+     | _ => idtac
+  end.
+
+
+(** Facts about [MapsTo] and [In]. *)
+
+Lemma MapsTo_In : forall elt k e (m:t elt), MapsTo k e m -> In k m.
+Proof.
+ induction 1; auto.
+Qed.
+Hint Resolve MapsTo_In.
+
+Lemma In_MapsTo : forall elt k (m:t elt), In k m -> exists e, MapsTo k e m.
+Proof.
+ induction 1; try destruct IHIn as (e,He); exists e; auto.
+Qed.
+
+Lemma In_alt : forall elt k (m:t elt), In0 k m <-> In k m.
+Proof. 
+ split.
+ intros (e,H); eauto.
+ unfold In0; apply In_MapsTo; auto.
+Qed.
+
+Lemma MapsTo_1 :
+ forall elt (m:t elt) x y e, X.eq x y -> MapsTo x e m -> MapsTo y e m.
+Proof.
+ induction m; simpl; intuition_in; eauto.
+Qed.
+Hint Immediate MapsTo_1.
+
+Lemma In_1 : 
+ forall elt (m:t elt) x y, X.eq x y -> In x m -> In y m.
+Proof.
+ intros elt m x y; induction m; simpl; intuition_in; eauto.
+Qed.
+
+
+(** Results about [lt_tree] and [gt_tree] *)
+
+Lemma lt_leaf : forall elt x, lt_tree x (Leaf elt).
+Proof.
+ unfold lt_tree in |- *; intros; intuition_in.
+Qed.
+
+Lemma gt_leaf : forall elt x, gt_tree x (Leaf elt).
+Proof.
+  unfold gt_tree in |- *; intros; intuition_in.
+Qed.
+
+Lemma lt_tree_node : forall elt x y (l:t elt) r e h, 
+ lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y e r h).
+Proof.
+ unfold lt_tree in *; firstorder_in; order.
+Qed.
+
+Lemma gt_tree_node : forall elt x y (l:t elt) r e h,
+ gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y e r h).
+Proof.
+ unfold gt_tree in *; firstorder_in; order.
+Qed.
+
+Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
+
+Lemma lt_left : forall elt x y (l: t elt) r e h, 
+ lt_tree x (Node l y e r h) -> lt_tree x l.
+Proof.
+ intuition_in.
+Qed.
+
+Lemma lt_right : forall elt x y (l:t elt) r e h, 
+ lt_tree x (Node l y e r h) -> lt_tree x r.
+Proof.
+ intuition_in.
+Qed.
+
+Lemma gt_left : forall elt x y (l:t elt) r e h, 
+ gt_tree x (Node l y e r h) -> gt_tree x l.
+Proof.
+ intuition_in.
+Qed.
+
+Lemma gt_right : forall elt x y (l:t elt) r e h, 
+ gt_tree x (Node l y e r h) -> gt_tree x r.
+Proof.
+ intuition_in.
+Qed.
+
+Hint Resolve lt_left lt_right gt_left gt_right.
+
+Lemma lt_tree_not_in :
+ forall elt x (t : t elt), lt_tree x t -> ~ In x t.
+Proof.
+ intros; intro; generalize (H _ H0); order.
+Qed.
+
+Lemma lt_tree_trans :
+ forall elt x y, X.lt x y -> forall (t:t elt), lt_tree x t -> lt_tree y t.
+Proof.
+ firstorder eauto.
+Qed.
+
+Lemma gt_tree_not_in :
+ forall elt x (t : t elt), gt_tree x t -> ~ In x t.
+Proof.
+ intros; intro; generalize (H _ H0); order.
+Qed.
+
+Lemma gt_tree_trans :
+ forall elt x y, X.lt y x -> forall (t:t elt), gt_tree x t -> gt_tree y t.
+Proof.
+ firstorder eauto.
+Qed.
+
+Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
+
+(** Results about [avl] *)
+
+Lemma avl_node : forall elt x e (l:t elt) r, 
+ avl l ->
+ avl r ->
+ -(2) <= height l - height r <= 2 ->
+ avl (Node l x e r (max (height l) (height r) + 1)).
+Proof.
+  intros; auto.
+Qed.
+Hint Resolve avl_node.
+
+(** * Helper functions *)
+
+(** [create l x r] creates a node, assuming [l] and [r]
+    to be balanced and [|height l - height r| <= 2]. *)
+
+Definition create elt (l:t elt) x e r := 
+   Node l x e r (max (height l) (height r) + 1).
+
+Lemma create_bst : 
+ forall elt (l:t elt) x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> 
+ bst (create l x e r).
+Proof.
+ unfold create; auto.
+Qed.
+Hint Resolve create_bst.
+
+Lemma create_avl : 
+ forall elt (l:t elt) x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
+ avl (create l x e r).
+Proof.
+ unfold create; auto.
+Qed.
+
+Lemma create_height : 
+ forall elt (l:t elt) x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
+ height (create l x e r) = max (height l) (height r) + 1.
+Proof.
+ unfold create; intros; auto.
+Qed.
+
+Lemma create_in : 
+ forall elt (l:t elt) x e r y,  In y (create l x e r) <-> X.eq y x \/ In y l \/ In y r.
+Proof.
+ unfold create; split; [ inversion_clear 1 | ]; intuition.
+Qed.
+
+(** trick for emulating [assert false] in Coq *)
+
+Notation assert_false := Leaf.
+
+(** [bal l x e r] acts as [create], but performs one step of
+    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
+
+Definition bal elt (l: tree elt) x e r := 
+  let hl := height l in 
+  let hr := height r in
+  if gt_le_dec hl (hr+2) then 
+    match l with 
+     | Leaf => assert_false _
+     | Node ll lx le lr _ => 
+       if ge_lt_dec (height ll) (height lr) then 
+         create ll lx le (create lr x e r)
+       else 
+         match lr with 
+          | Leaf => assert_false _
+          | Node lrl lrx lre lrr _ => 
+              create (create ll lx le lrl) lrx lre (create lrr x e r)
+         end
+    end
+  else 
+    if gt_le_dec hr (hl+2) then 
+      match r with
+       | Leaf => assert_false _
+       | Node rl rx re rr _ =>
+         if ge_lt_dec (height rr) (height rl) then 
+            create (create l x e rl) rx re rr
+         else 
+           match rl with
+            | Leaf => assert_false _
+            | Node rll rlx rle rlr _ => 
+                create (create l x e rll) rlx rle (create rlr rx re rr) 
+           end
+      end
+    else 
+      create l x e r. 
+
+Ltac bal_tac := 
+ intros elt l x e r;
+ unfold bal; 
+ destruct (gt_le_dec (height l) (height r + 2)); 
+   [ destruct l as [ |ll lx le lr lh]; 
+     [ | destruct (ge_lt_dec (height ll) (height lr)); 
+          [ | destruct lr ] ]
+   | destruct (gt_le_dec (height r) (height l + 2)); 
+     [ destruct r as [ |rl rx re rr rh];
+          [ | destruct (ge_lt_dec (height rr) (height rl)); 
+               [ | destruct rl ] ]
+     | ] ]; intros.
+
+Ltac bal_tac_imp := match goal with 
+  | |- context [ assert_false ] => 
+      inv avl; avl_nns; simpl in *; false_omega
+  | _ => idtac
+end.
+
+Lemma bal_bst : forall elt (l:t elt) x e r, bst l -> bst r -> 
+ lt_tree x l -> gt_tree x r -> bst (bal l x e r).
+Proof.
+ bal_tac;
+ inv bst; repeat apply create_bst; auto; unfold create; 
+ apply lt_tree_node || apply gt_tree_node; auto; 
+ eapply lt_tree_trans || eapply gt_tree_trans || eauto; eauto.
+Qed.
+
+Lemma bal_avl : forall elt (l:t elt) x e r, avl l -> avl r -> 
+ -(3) <= height l - height r <= 3 -> avl (bal l x e r).
+Proof.
+ bal_tac; inv avl; repeat apply create_avl; simpl in *; auto; omega_max.
+Qed.
+
+Lemma bal_height_1 : forall elt (l:t elt) x e r, avl l -> avl r -> 
+ -(3) <= height l - height r <= 3 ->
+ 0 <= height (bal l x e r) - max (height l) (height r) <= 1.
+Proof.
+ bal_tac; inv avl; avl_nns; simpl in *; omega_max.
+Qed.
+
+Lemma bal_height_2 : 
+ forall elt (l:t elt) x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> 
+ height (bal l x e r) == max (height l) (height r) +1.
+Proof.
+ bal_tac; inv avl; simpl in *; omega_max.
+Qed.
+
+Lemma bal_in : forall elt (l:t elt) x e r y, avl l -> avl r -> 
+ (In y (bal l x e r) <-> X.eq y x \/ In y l \/ In y r).
+Proof.
+ bal_tac; bal_tac_imp; repeat rewrite create_in; intuition_in.
+Qed.
+
+Lemma bal_mapsto : forall elt (l:t elt) x e r y e', avl l -> avl r -> 
+ (MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r)).
+Proof.
+ bal_tac; bal_tac_imp; unfold create; intuition_in.
+Qed.
+
+Ltac omega_bal := match goal with 
+  | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => 
+     generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); 
+     omega_max
+  end. 
+
+(** * Insertion *)
+
+Function add (elt:Set)(x:key)(e:elt)(s:t elt) { struct s } : t elt := match s with 
+   | Leaf => Node (Leaf _) x e (Leaf _) 1
+   | Node l y e' r h => 
+      match X.compare x y with
+         | LT _ => bal (add x e l) y e' r
+         | EQ _ => Node l y e r h
+         | GT _ => bal l y e' (add x e r)
+      end
+  end.
+
+Lemma add_avl_1 :  forall elt (m:t elt) x e, avl m -> 
+ avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1.
+Proof. 
+ intros elt m x e; functional induction (add x e m); intros; inv avl; simpl in *.
+ intuition; try constructor; simpl; auto; try omega_max.
+ (* LT *)
+ destruct IHt; auto.
+ split.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+ (* EQ *)
+ intuition; omega_max.
+ (* GT *)
+ destruct IHt; auto.
+ split.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+Qed.
+
+Lemma add_avl : forall elt (m:t elt) x e, avl m -> avl (add x e m).
+Proof.
+ intros; generalize (add_avl_1 x e H); intuition.
+Qed.
+Hint Resolve add_avl.
+
+Lemma add_in : forall elt (m:t elt) x y e, avl m -> 
+ (In y (add x e m) <-> X.eq y x \/ In y m).
+Proof.
+ intros elt m x y e; functional induction (add x e m); auto; intros.
+ intuition_in.
+ (* LT *)
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite (IHt H1); intuition_in.
+ (* EQ *)  
+ inv avl.
+ firstorder_in.
+ eapply In_1; eauto.
+ (* GT *)
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite (IHt H2); intuition_in.
+Qed.
+
+Lemma add_bst : forall elt (m:t elt) x e, bst m -> avl m -> bst (add x e m).
+Proof. 
+ intros elt m x e; functional induction (add x e m); 
+   intros; inv bst; inv avl; auto; apply bal_bst; auto.
+ (* lt_tree -> lt_tree (add ...) *)
+ red; red in H4.
+ intros.
+ rewrite (add_in x y0 e H) in H1.
+ intuition.
+ eauto.
+ (* gt_tree -> gt_tree (add ...) *)
+ red; red in H5.
+ intros.
+ rewrite (add_in x y0 e H6) in H1.
+ intuition.
+ apply lt_eq with x; auto.
+Qed.
+
+Lemma add_1 : forall elt (m:t elt) x y e, avl m -> X.eq x y -> MapsTo y e (add x e m).
+Proof. 
+ intros elt m x y e; functional induction (add x e m); 
+   intros; inv bst; inv avl; try rewrite bal_mapsto; unfold create; eauto.
+Qed. 
+
+Lemma add_2 : forall elt (m:t elt) x y e e', avl m -> ~X.eq x y -> 
+ MapsTo y e m -> MapsTo y e (add x e' m).
+Proof.
+ intros elt m x y e e'; induction m; simpl; auto.
+ destruct (X.compare x k);
+ intros; inv bst; inv avl; try rewrite bal_mapsto; unfold create; auto; 
+   inv MapsTo; auto; order.
+Qed.
+
+Lemma add_3 : forall elt (m:t elt) x y e e', avl m -> ~X.eq x y -> 
+ MapsTo y e (add x e' m) -> MapsTo y e m.
+Proof.
+ intros elt m x y e e'; induction m; simpl; auto. 
+ intros; inv avl; inv MapsTo; auto; order.
+ destruct (X.compare x k); intro; inv avl; 
+  try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; 
+  order. 
+Qed.
+
+
+(** * Extraction of minimum binding
+
+  morally, [remove_min] is to be applied to a non-empty tree 
+  [t = Node l x e r h]. Since we can't deal here with [assert false] 
+  for [t=Leaf], we pre-unpack [t] (and forget about [h]). 
+*)
+ 
+Function remove_min (elt:Set)(l:t elt)(x:key)(e:elt)(r:t elt) { struct l } : t elt*(key*elt) := 
+  match l with 
+    | Leaf => (r,(x,e))
+    | Node ll lx le lr lh => let (l',m) := (remove_min ll lx le lr : t elt*(key*elt)) in (bal l' x e r, m)
+  end.
+
+Lemma remove_min_avl_1 : forall elt (l:t elt) x e r h, avl (Node l x e r h) -> 
+ avl (fst (remove_min l x e r)) /\ 
+ 0 <= height (Node l x e r h) - height (fst (remove_min l x e r)) <= 1.
+Proof.
+ intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ inv avl; simpl in *; split; auto.
+ avl_nns; omega_max.
+ (* l = Node *)
+ inversion_clear H.
+ destruct (IHp lh); auto.
+ split; simpl in *. 
+ rewrite_all H0. simpl in *.
+ apply bal_avl; subst;auto; omega_max.
+ rewrite_all H0;simpl in *;omega_bal.
+Qed.
+
+Lemma remove_min_avl : forall elt (l:t elt) x e r h, avl (Node l x e r h) -> 
+    avl (fst (remove_min l x e r)). 
+Proof.
+ intros; generalize (remove_min_avl_1 H); intuition.
+Qed.
+
+Lemma remove_min_in : forall elt (l:t elt) x e r h y, avl (Node l x e r h) -> 
+ (In y (Node l x e r h) <-> 
+  X.eq y (fst (snd (remove_min l x e r))) \/ In y (fst (remove_min l x e r))).
+Proof.
+ intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ intuition_in.
+ (* l = Node *)
+ inversion_clear H.
+ generalize (remove_min_avl H1).
+ 
+ rewrite_all H0; simpl; intros.
+ rewrite bal_in; auto.
+ generalize (IHp lh y H1).
+ intuition.
+ inversion_clear H8; intuition.
+Qed.
+
+Lemma remove_min_mapsto : forall elt (l:t elt) x e r h y e', avl (Node l x e r h) -> 
+ (MapsTo y e' (Node l x e r h) <-> 
+   ((X.eq y (fst (snd (remove_min l x e r))) /\ e' = (snd (snd (remove_min l x e r))))
+    \/ MapsTo y e' (fst (remove_min l x e r)))).
+Proof.
+ intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ intuition_in; subst; auto.
+ (* l = Node *)
+ inversion_clear H.
+ generalize (remove_min_avl H1).
+ rewrite_all H0; simpl; intros.
+ rewrite bal_mapsto; auto; unfold create.
+ simpl in *;destruct (IHp lh y e').
+ auto.
+ intuition.
+ inversion_clear H3; intuition.
+ inversion_clear H10; intuition.
+Qed.
+
+Lemma remove_min_bst : forall elt (l:t elt) x e r h, 
+ bst (Node l x e r h) -> avl (Node l x e r h) -> bst (fst (remove_min l x e r)).
+Proof.
+ intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ inv bst; auto.
+ inversion_clear H; inversion_clear H1.
+ apply bal_bst; auto.
+ rewrite_all H0;simpl in *;firstorder.
+ intro; intros.
+ generalize (remove_min_in y H).
+ rewrite_all H0; simpl in *.
+ destruct 1.
+ apply H4; intuition.
+Qed.
+
+Lemma remove_min_gt_tree : forall elt (l:t elt) x e r h, 
+ bst (Node l x e r h) -> avl (Node l x e r h) -> 
+ gt_tree (fst (snd (remove_min l x e r))) (fst (remove_min l x e r)).
+Proof.
+ intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ inv bst; auto.
+ inversion_clear H; inversion_clear H1.
+ intro; intro.
+ rewrite_all H0;simpl in *.
+ generalize (IHp lh H2 H); clear H7 H8 IHp.
+ generalize (remove_min_avl H).
+ generalize (remove_min_in (fst m) H).
+ rewrite H0; simpl; intros.
+ rewrite (bal_in x e y H8 H6) in H1.
+ destruct H7.
+ firstorder.
+ apply lt_eq with x; auto.
+ apply X.lt_trans with x; auto.
+Qed.
+
+(** * Merging two trees
+
+  [merge t1 t2] builds the union of [t1] and [t2] assuming all elements
+  of [t1] to be smaller than all elements of [t2], and
+  [|height t1 - height t2| <= 2].
+*)
+
+Function merge (elt:Set) (s1 s2 : t elt) : tree elt :=  match s1,s2 with 
+  | Leaf, _ => s2 
+  | _, Leaf => s1
+  | _, Node l2 x2 e2 r2 h2 => 
+    match remove_min l2 x2 e2 r2 with 
+      (s2',(x,e)) => bal s1 x e s2'
+    end
+end.
+
+Lemma merge_avl_1 : forall elt (s1 s2:t elt), avl s1 -> avl s2 -> 
+ -(2) <= height s1 - height s2 <= 2 -> 
+ avl (merge s1 s2) /\ 
+ 0<= height (merge s1 s2) - max (height s1) (height s2) <=1.
+Proof.
+ intros elt s1 s2; functional induction (merge s1 s2); simpl in *; intros.
+ split; auto; avl_nns; omega_max.
+ destruct s1;try contradiction;clear H1.
+ split; auto; avl_nns; simpl in *; omega_max.
+ destruct s1;try contradiction;clear H1.
+ generalize (remove_min_avl_1 H0).
+ rewrite H2; simpl;destruct 1.
+ split.
+ apply bal_avl; auto.
+ simpl; omega_max.
+ omega_bal.
+Qed.
+
+Lemma merge_avl : forall elt (s1 s2:t elt), avl s1 -> avl s2 -> 
+  -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2).
+Proof. 
+ intros; generalize (merge_avl_1 H H0 H1); intuition.
+Qed.
+
+Lemma merge_in : forall elt (s1 s2:t elt) y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (In y (merge s1 s2) <-> In y s1 \/ In y s2).
+Proof. 
+ intros elt s1 s2; functional induction (merge s1 s2);intros.
+ intuition_in.
+ intuition_in.
+ destruct s1;try contradiction;clear H1.
+(*  rewrite H_eq_2; rewrite H_eq_2 in H_eq_1; clear H_eq_2. *)
+ replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite H2; auto].
+ rewrite bal_in; auto.
+ generalize (remove_min_avl H4); rewrite H2; simpl; auto.
+ generalize (remove_min_in y H4); rewrite H2; simpl; intro.
+ rewrite H1; intuition.
+Qed.
+
+Lemma merge_mapsto : forall elt (s1 s2:t elt) y e, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+  (MapsTo y e (merge s1 s2) <-> MapsTo y e s1 \/ MapsTo y e s2).
+Proof.
+ intros elt s1 s2; functional induction (@merge elt s1 s2); intros.
+ intuition_in.
+ intuition_in.
+ destruct s1;try contradiction;clear H1.
+ replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite H2; auto].
+ rewrite bal_mapsto; auto; unfold create.
+ generalize (remove_min_avl H4); rewrite H2; simpl; auto.
+ generalize (remove_min_mapsto y e0 H4); rewrite H2; simpl; intro.
+ rewrite H1; intuition (try subst; auto).
+ inversion_clear H1; intuition.
+Qed.
+
+Lemma merge_bst : forall elt (s1 s2:t elt), bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (forall y1 y2 : key, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> 
+ bst (merge s1 s2). 
+Proof.
+ intros elt s1 s2; functional induction (@merge elt s1 s2); intros; auto.
+
+ apply bal_bst; auto.
+ destruct s1;try contradiction.
+ generalize (remove_min_bst H3); rewrite H2; simpl in *; auto.
+ destruct s1;try contradiction.
+ intro; intro.
+ apply H5; auto.
+ generalize (remove_min_in x H4); rewrite H2; simpl; intuition.
+ destruct s1;try contradiction.
+ generalize (remove_min_gt_tree H3); rewrite H2; simpl; auto.
+Qed. 
+
+(** * Deletion *)
+
+Function remove (elt:Set)(x:key)(s:t elt) { struct s } : t elt := match s with 
+  | Leaf => Leaf _
+  | Node l y e r h =>
+      match X.compare x y with
+         | LT _ => bal (remove x l) y e r
+         | EQ _ => merge l r
+         | GT _ => bal l y e (remove x r)
+      end
+   end.
+
+Lemma remove_avl_1 : forall elt (s:t elt) x, avl s -> 
+ avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1.
+Proof.
+ intros elt s x; functional induction (@remove elt x s); intros.
+ split; auto; omega_max.
+ (* LT *)
+ inv avl.
+ destruct (IHt H1).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+ (* EQ *)
+ inv avl. 
+ generalize (merge_avl_1 H1 H2 H3).
+ intuition omega_max.
+ (* GT *)
+ inv avl.
+ destruct (IHt H2).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+Qed.
+
+Lemma remove_avl : forall elt (s:t elt) x, avl s -> avl (remove x s).
+Proof. 
+ intros; generalize (remove_avl_1 x H); intuition.
+Qed.
+Hint Resolve remove_avl.
+
+Lemma remove_in : forall elt (s:t elt) x y, bst s -> avl s -> 
+ (In y (remove x s) <-> ~ X.eq y x /\ In y s).
+Proof.
+ intros elt s x; functional induction (@remove elt x s); simpl; intros.
+ intuition_in.
+ (* LT *)
+ inv avl; inv bst; clear H0.
+ rewrite bal_in; auto.
+ generalize (IHt y0 H1); intuition; [ order | order | intuition_in ].
+ (* EQ *)
+ inv avl; inv bst; clear H0.
+ rewrite merge_in; intuition; [ order | order | intuition_in ].
+ elim H9; eauto.
+ (* GT *)
+ inv avl; inv bst; clear H0.
+ rewrite bal_in; auto.
+ generalize (IHt y0 H6); intuition; [ order | order | intuition_in ].
+Qed.
+
+Lemma remove_bst : forall elt (s:t elt) x, bst s -> avl s -> bst (remove x s).
+Proof. 
+ intros elt s x; functional induction (@remove elt x s); simpl; intros.
+ auto.
+ (* LT *)
+ inv avl; inv bst.
+ apply bal_bst; auto.
+ intro; intro.
+ rewrite (remove_in x y0 H1) in H; auto.
+ destruct H; eauto.
+ (* EQ *)
+ inv avl; inv bst.
+ apply merge_bst; eauto.
+ (* GT *) 
+ inv avl; inv bst.
+ apply bal_bst; auto.
+ intro; intro.
+ rewrite (remove_in x y0 H6) in H; auto.
+ destruct H; eauto.
+Qed.
+
+Lemma remove_1 : forall elt (m:t elt) x y, bst m -> avl m -> X.eq x y -> ~ In y (remove x m).
+Proof. 
+ intros; rewrite remove_in; intuition.
+Qed. 
+
+Lemma remove_2 : forall elt (m:t elt) x y e, bst m -> avl m -> ~X.eq x y -> 
+ MapsTo y e m -> MapsTo y e (remove x m).
+Proof.
+ intros elt m x y e; induction m; simpl; auto.
+ destruct (X.compare x k); 
+   intros; inv bst; inv avl; try rewrite bal_mapsto; unfold create; auto; 
+   try solve [inv MapsTo; auto].
+ rewrite merge_mapsto; auto.
+ inv MapsTo; auto; order.
+Qed.
+
+Lemma remove_3 : forall elt (m:t elt) x y e, bst m -> avl m ->
+ MapsTo y e (remove x m) -> MapsTo y e m.
+Proof.
+ intros elt m x y e; induction m; simpl; auto.
+ destruct (X.compare x k); intros Bs Av; inv avl; inv bst; 
+  try rewrite bal_mapsto; auto; unfold create.
+  intros; inv MapsTo; auto. 
+  rewrite merge_mapsto; intuition.
+  intros; inv MapsTo; auto.
+Qed.
+
+Section Elt2.
+
+Variable elt:Set.
+
+Notation eqk := (eqk (elt:= elt)).
+Notation eqke := (eqke (elt:= elt)).
+Notation ltk := (ltk (elt:= elt)).
+
+(** * Empty map *)
+
+Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
+
+Definition empty := (Leaf elt).
+
+Lemma empty_bst : bst empty.
+Proof.
+ unfold empty; auto.
+Qed.
+
+Lemma empty_avl : avl empty.
+Proof. 
+ unfold empty; auto.
+Qed.
+
+Lemma empty_1 : Empty empty.
+Proof.
+ unfold empty, Empty; intuition_in.
+Qed.
+
+(** * Emptyness test *)
+
+Definition is_empty (s:t elt) := match s with Leaf => true | _ => false end.
+
+Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. 
+Proof.
+ destruct s as [|r x e l h]; simpl; auto.
+ intro H; elim (H x e); auto.
+Qed.
+
+Lemma is_empty_2 : forall s, is_empty s = true -> Empty s.
+Proof. 
+ destruct s; simpl; intros; try discriminate; red; intuition_in.
+Qed.
+
+(** * Appartness *)
+
+(** The [mem] function is deciding appartness. It exploits the [bst] property
+    to achieve logarithmic complexity. *)
+
+Function mem (x:key)(m:t elt) { struct m } : bool := 
+   match m with 
+     |  Leaf => false 
+     |  Node l y e r _ => match X.compare x y with 
+             | LT _ => mem x l 
+             | EQ _ => true
+             | GT _ => mem x r
+         end
+   end.
+Implicit Arguments mem. 
+
+Lemma mem_1 : forall s x, bst s -> In x s -> mem x s = true.
+Proof. 
+ intros s x.
+ functional induction (mem x s); inversion_clear 1; auto.
+ intuition_in.
+ intuition_in; firstorder; absurd (X.lt x y); eauto.
+ intuition_in; firstorder; absurd (X.lt y x); eauto.
+Qed.
+
+Lemma mem_2 : forall s x, mem x s = true -> In x s. 
+Proof. 
+ intros s x. 
+ functional induction (mem x s); firstorder; intros; try discriminate.
+Qed.
+
+Function find (x:key)(m:t elt) { struct m } : option elt := 
+   match m with 
+     |  Leaf => None 
+     |  Node l y e r _ => match X.compare x y with 
+             | LT _ => find x l 
+             | EQ _ => Some e
+             | GT _ => find x r
+         end
+   end.
+
+Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e.
+Proof. 
+ intros m x e.
+ functional induction (find x m); inversion_clear 1; auto.
+ intuition_in.
+ intuition_in; firstorder; absurd (X.lt x y); eauto.
+ intuition_in; auto.
+  absurd (X.lt x y); eauto.
+  absurd (X.lt y x); eauto.
+ intuition_in; firstorder; absurd (X.lt y x); eauto.
+Qed.
+
+Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+Proof. 
+ intros m x.
+ functional induction (find x m); subst;firstorder; intros; try discriminate.
+ inversion H; subst; auto.
+Qed.
+
+(** An all-in-one spec for [add] used later in the naive [map2] *)
+
+Lemma add_spec : forall m x y e , bst m -> avl m -> 
+  find x (add y e m) = if eq_dec x y then Some e else find x m.
+Proof.
+intros.
+destruct (eq_dec x y).
+apply find_1.
+apply add_bst; auto.
+eapply MapsTo_1 with y; eauto.
+apply add_1; auto.
+case_eq (find x m); intros.
+apply find_1.
+apply add_bst; auto.
+apply add_2; auto.
+apply find_2; auto.
+case_eq (find x (add y e m)); auto; intros.
+rewrite <- H1; symmetry.
+apply find_1; auto.
+eapply add_3; eauto.
+apply find_2; eauto.
+Qed.
+
+(** * Elements *)
+
+(** [elements_tree_aux acc t] catenates the elements of [t] in infix
+    order to the list [acc] *)
+
+Fixpoint elements_aux (acc : list (key*elt)) (t : t elt) {struct t} : list (key*elt) :=
+  match t with
+   | Leaf => acc
+   | Node l x e r _ => elements_aux ((x,e) :: elements_aux acc r) l
+  end.
+
+(** then [elements] is an instanciation with an empty [acc] *)
+
+Definition elements := elements_aux nil.
+
+Lemma elements_aux_mapsto : forall s acc x e, 
+ InA eqke (x,e) (elements_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc.
+Proof.
+ induction s as [ | l Hl x e r Hr h ]; simpl; auto.
+ intuition.
+ inversion H0.
+ intros.
+ rewrite Hl.
+ destruct (Hr acc x0 e0); clear Hl Hr.
+ intuition; inversion_clear H3; intuition.
+ destruct H0; simpl in *; subst; intuition.
+Qed.
+
+Lemma elements_mapsto : forall s x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. 
+Proof. 
+ intros; generalize (elements_aux_mapsto s nil x e); intuition.
+ inversion_clear H0.
+Qed.
+
+Lemma elements_in : forall s x, L.PX.In x (elements s) <-> In x s.
+Proof.
+ intros.
+ unfold L.PX.In.
+ rewrite <- In_alt; unfold In0.
+ firstorder.
+ exists x0.
+ rewrite <- elements_mapsto; auto.
+ exists x0.
+ unfold L.PX.MapsTo; rewrite elements_mapsto; auto.
+Qed.
+
+Lemma elements_aux_sort : forall s acc, bst s -> sort ltk acc ->
+ (forall x e y, InA eqke (x,e) acc -> In y s -> X.lt y x) ->
+ sort ltk (elements_aux acc s).
+Proof.
+ induction s as [ | l Hl y e r Hr h]; simpl; intuition.
+ inv bst.
+ apply Hl; auto.
+ constructor. 
+ apply Hr; eauto.
+ apply (InA_InfA (eqke_refl (elt:=elt))); intros (y',e') H6.
+ destruct (elements_aux_mapsto r acc y' e'); intuition.
+ red; simpl; eauto.
+ red; simpl; eauto.
+ intros.
+ inversion_clear H.
+ destruct H7; simpl in *.
+ order.
+ destruct (elements_aux_mapsto r acc x e0); intuition eauto.
+Qed.
+
+Lemma elements_sort : forall s : t elt, bst s -> sort ltk (elements s).
+Proof.
+ intros; unfold elements; apply elements_aux_sort; auto.
+ intros; inversion H0.
+Qed.
+Hint Resolve elements_sort.
+
+
+(** * Fold *)
+
+Fixpoint fold (A : Set) (f : key -> elt -> A -> A)(s : t elt) {struct s} : A -> A := 
+ fun a => match s with
+  | Leaf => a
+  | Node l x e r _ => fold f r (f x e (fold f l a))
+ end.
+
+Definition fold' (A : Set) (f : key -> elt -> A -> A)(s : t elt) := 
+  L.fold f (elements s).
+
+Lemma fold_equiv_aux :
+ forall (A : Set) (s : t elt) (f : key -> elt -> A -> A) (a : A) acc,
+ L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a).
+Proof.
+ simple induction s.
+ simpl in |- *; intuition.
+ simpl in |- *; intros.
+ rewrite H.
+ simpl.
+ apply H0.
+Qed.
+
+Lemma fold_equiv :
+ forall (A : Set) (s : t elt) (f : key -> elt -> A -> A) (a : A),
+ fold f s a = fold' f s a.
+Proof.
+ unfold fold', elements in |- *. 
+ simple induction s; simpl in |- *; auto; intros.
+ rewrite fold_equiv_aux.
+ rewrite H0.
+ simpl in |- *; auto.
+Qed.
+
+Lemma fold_1 : 
+ forall (s:t elt)(Hs:bst s)(A : Set)(i:A)(f : key -> elt -> A -> A),
+ fold f s i = fold_left (fun a p => f (fst p) (snd p) a) (elements s) i.
+Proof.
+ intros.
+ rewrite fold_equiv.
+ unfold fold'.
+ rewrite L.fold_1.
+ unfold L.elements; auto.
+Qed.
+
+(** * Comparison *)
+
+Definition Equal (cmp:elt->elt->bool) m m' := 
+  (forall k, In k m <-> In k m') /\ 
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+(** ** Enumeration of the elements of a tree *)
+
+Inductive enumeration : Set :=
+ | End : enumeration
+ | More : key -> elt -> t elt -> enumeration -> enumeration.
+
+(** [flatten_e e] returns the list of elements of [e] i.e. the list
+    of elements actually compared *)
+ 
+Fixpoint flatten_e (e : enumeration) : list (key*elt) := match e with
+  | End => nil
+  | More x e t r => (x,e) :: elements t ++ flatten_e r
+ end.
+
+(** [sorted_e e] expresses that elements in the enumeration [e] are
+    sorted, and that all trees in [e] are binary search trees. *)
+
+Inductive In_e (p:key*elt) : enumeration -> Prop :=
+  | InEHd1 :
+      forall (y : key)(d:elt) (s : t elt) (e : enumeration),
+      eqke p (y,d) -> In_e p (More y d s e)
+  | InEHd2 :
+      forall (y : key) (d:elt) (s : t elt) (e : enumeration),
+      MapsTo (fst p) (snd p) s -> In_e p (More y d s e)
+  | InETl :
+      forall (y : key) (d:elt) (s : t elt) (e : enumeration),
+      In_e p e -> In_e p (More y d s e).
+
+Hint Constructors In_e.
+
+Inductive sorted_e : enumeration -> Prop :=
+  | SortedEEnd : sorted_e End
+  | SortedEMore :
+      forall (x : key) (d:elt) (s : t elt) (e : enumeration),
+      bst s ->
+      (gt_tree x s) ->
+      sorted_e e ->
+      (forall p, In_e p e -> ltk (x,d) p) ->
+      (forall p,
+       MapsTo (fst p) (snd p) s -> forall q, In_e q e -> ltk p q) ->
+      sorted_e (More x d s e).
+
+Hint Constructors sorted_e.
+
+Lemma in_flatten_e :
+ forall p e, InA eqke p (flatten_e e) -> In_e p e.
+Proof.
+ simple induction e; simpl in |- *; intuition.
+ inversion_clear H.
+ inversion_clear H0; auto.
+ elim (InA_app H1); auto.
+ destruct (elements_mapsto t a b); auto.
+Qed.
+
+Lemma sorted_flatten_e :
+ forall e : enumeration, sorted_e e -> sort ltk (flatten_e e).
+Proof.
+ simple induction e; simpl in |- *; intuition.
+ apply cons_sort.
+ apply (SortA_app (eqke_refl (elt:=elt))); inversion_clear H0; auto.
+ intros; apply H5; auto.
+ rewrite <- elements_mapsto; auto; destruct x; auto.
+ apply in_flatten_e; auto.
+ inversion_clear H0.
+ apply In_InfA; intros.
+ intros; elim (in_app_or _ _ _ H0); intuition.
+ generalize (In_InA (eqke_refl (elt:=elt)) H6).
+ destruct y; rewrite elements_mapsto; eauto.
+ apply H4; apply in_flatten_e; auto.
+ apply In_InA; auto.
+Qed.
+
+Lemma elements_app :
+ forall s acc, elements_aux acc s = elements s ++ acc.
+Proof.
+ simple induction s; simpl in |- *; intuition.
+ rewrite H0.
+ rewrite H.
+ unfold elements; simpl.
+ do 2 rewrite H.
+ rewrite H0.
+ repeat rewrite <- app_nil_end.
+ repeat rewrite app_ass; auto.
+Qed.
+
+Lemma compare_flatten_1 :
+ forall t1 t2 x e z l,
+ elements t1 ++ (x,e) :: elements t2 ++ l =
+ elements (Node t1 x e t2 z) ++ l.
+Proof.
+ simpl in |- *; unfold elements in |- *; simpl in |- *; intuition.
+ repeat rewrite elements_app.
+ repeat rewrite <- app_nil_end.
+ repeat rewrite app_ass; auto.
+Qed.
+
+(** key lemma for correctness *)
+
+Lemma flatten_e_elements :
+ forall l r x d z e,
+ elements l ++ flatten_e (More x d r e) = 
+ elements (Node l x d r z) ++ flatten_e e.
+Proof.
+ intros; simpl.
+ apply compare_flatten_1.
+Qed.
+
+Open Scope Z_scope.
+
+(** termination of [compare_aux] *)
+ 
+Fixpoint measure_e_t (s : t elt) : Z := match s with
+  | Leaf => 0
+  | Node l _ _ r _ => 1 + measure_e_t l + measure_e_t r
+ end.
+
+Fixpoint measure_e (e : enumeration) : Z := match e with
+  | End => 0
+  | More _ _ s r => 1 + measure_e_t s + measure_e r
+ end.
+
+Ltac Measure_e_t := unfold measure_e_t in |- *; fold measure_e_t in |- *.
+Ltac Measure_e := unfold measure_e in |- *; fold measure_e in |- *.
+
+Lemma measure_e_t_0 : forall s : t elt, measure_e_t s >= 0.
+Proof.
+ simple induction s.
+ simpl in |- *; omega.
+ intros.
+ Measure_e_t; omega.
+Qed.
+
+Ltac Measure_e_t_0 s := generalize (@measure_e_t_0 s); intro.
+
+Lemma measure_e_0 : forall e : enumeration, measure_e e >= 0.
+Proof.
+ simple induction e.
+ simpl in |- *; omega.
+ intros.
+ Measure_e; Measure_e_t_0 t; omega.
+Qed.
+
+Ltac Measure_e_0 e := generalize (@measure_e_0 e); intro.
+
+(** Induction principle over the sum of the measures for two lists *)
+
+Definition compare_rec2 :
+ forall P : enumeration -> enumeration -> Set,
+  (forall x x' : enumeration,
+   (forall y y' : enumeration,
+    measure_e y + measure_e y' < measure_e x + measure_e x' -> P y y') ->
+   P x x') -> 
+ forall x x' : enumeration, P x x'.
+Proof.
+ intros P H x x'.
+ apply well_founded_induction_type_2
+ with (R := fun yy' xx' : enumeration * enumeration =>
+            measure_e (fst yy') + measure_e (snd yy') <
+            measure_e (fst xx') + measure_e (snd xx')); auto.    
+ apply Wf_nat.well_founded_lt_compat
+ with (f := fun xx' : enumeration * enumeration =>
+            Zabs_nat (measure_e (fst xx') + measure_e (snd xx'))).
+ intros; apply Zabs.Zabs_nat_lt.
+ Measure_e_0 (fst x0); Measure_e_0 (snd x0); Measure_e_0 (fst y);
+ Measure_e_0 (snd y); intros; omega.
+Qed.
+
+(** [cons t e] adds the elements of tree [t] on the head of 
+    enumeration [e]. Code:
+ 
+let rec cons s e = match s with
+ | Empty -> e
+ | Node(l, k, d, r, _) -> cons l (More(k, d, r, e))
+*)
+
+Definition cons : forall s e, bst s -> sorted_e e ->
+  (forall x y, MapsTo (fst x) (snd x) s -> In_e y e -> ltk x y) ->
+  { r : enumeration 
+  | sorted_e r /\ 
+    measure_e r = measure_e_t s + measure_e e /\
+    flatten_e r = elements s ++ flatten_e e
+  }.
+Proof.
+ simple induction s; intuition.
+ (* s = Leaf *)
+ exists e; intuition.
+ (* s = Node t k e t0 z *)
+ clear H0.
+ case (H (More k e t0 e0)); clear H; intuition.
+ inv bst; auto.
+ constructor; inversion_clear H1; auto.
+ inversion_clear H0; inv bst; intuition.
+ destruct y; red; red in H4; simpl in *; intuition.
+ apply lt_eq with k; eauto.
+ destruct y; red; simpl in *; intuition.
+ apply X.lt_trans with k; eauto.
+ exists x; intuition.
+ generalize H4; Measure_e; intros; Measure_e_t; omega.
+ rewrite H5.
+ apply flatten_e_elements.
+Qed.
+
+Definition equal_aux : 
+ forall (cmp: elt -> elt -> bool)(e1 e2:enumeration), 
+ sorted_e e1 -> sorted_e e2 -> 
+ { L.Equal cmp (flatten_e e1) (flatten_e e2) } +
+ { ~ L.Equal cmp (flatten_e e1) (flatten_e e2) }.
+Proof.
+ intros cmp e1 e2; pattern e1, e2 in |- *; apply compare_rec2.
+ simple destruct x; simple destruct x'; intuition.
+ (* x = x' = End *)
+ left; unfold L.Equal in |- *; intuition.
+ inversion H2.
+ (* x = End x' = More *)
+ right; simpl in |- *; auto.
+ destruct 1.
+ destruct (H2 k).
+ destruct H5; auto.
+ exists e; auto.
+ inversion H5.
+ (* x = More x' = End *)
+ right; simpl in |- *; auto.
+ destruct 1.
+ destruct (H2 k).
+ destruct H4; auto.
+ exists e; auto.
+ inversion H4.
+ (* x = More k e t e0, x' = More k0 e3 t0 e4 *)
+ case (X.compare k k0); intro.
+ (* k < k0 *)
+ right.
+ destruct 1. 
+ clear H3 H.
+ assert (L.PX.In k (flatten_e (More k0 e3 t0 e4))).
+  destruct (H2 k).
+  apply H; simpl; exists e; auto.
+ destruct H. 
+ generalize (Sort_In_cons_2 (sorted_flatten_e H1) (InA_eqke_eqk H)).
+ compute.
+ intuition order. 
+ (* k = k0 *)
+ case_eq (cmp e e3).
+ intros EQ.
+ destruct (@cons t e0) as [c1 (H2,(H3,H4))]; try inversion_clear H0; auto.
+ destruct (@cons t0 e4) as [c2 (H5,(H6,H7))]; try inversion_clear H1; auto.
+ destruct (H c1 c2); clear H; intuition.
+ Measure_e; omega.
+ left.
+ rewrite H4 in e6; rewrite H7 in e6.
+ simpl; rewrite <- L.equal_cons; auto.
+ apply (sorted_flatten_e H0).
+ apply (sorted_flatten_e H1).
+ right.
+ simpl; rewrite <- L.equal_cons; auto.
+ apply (sorted_flatten_e H0).
+ apply (sorted_flatten_e H1).
+ swap f.
+ rewrite H4; rewrite H7; auto.
+ right.
+ destruct 1.
+ rewrite (H4 k) in H2; try discriminate; simpl; auto.
+ (* k > k0 *)
+ right.
+ destruct 1. 
+ clear H3 H.
+ assert (L.PX.In k0 (flatten_e (More k e t e0))).
+  destruct (H2 k0).
+  apply H3; simpl; exists e3; auto.
+ destruct H. 
+ generalize (Sort_In_cons_2 (sorted_flatten_e H0) (InA_eqke_eqk H)).
+ compute.
+ intuition order. 
+Qed.
+
+Lemma Equal_elements : forall cmp s s', 
+ Equal cmp s s' <-> L.Equal cmp (elements s) (elements s').
+Proof.
+unfold Equal, L.Equal; split; split; intros.
+do 2 rewrite elements_in; firstorder.
+destruct H.
+apply (H2 k); rewrite <- elements_mapsto; auto.
+do 2 rewrite <- elements_in; firstorder.
+destruct H.
+apply (H2 k); unfold L.PX.MapsTo; rewrite elements_mapsto; auto.
+Qed.
+
+Definition equal : forall cmp s s', bst s -> bst s' -> 
+  {Equal cmp s s'} + {~ Equal cmp s s'}.
+Proof.
+ intros cmp s1 s2 s1_bst s2_bst; simpl.
+ destruct (@cons s1 End); auto.
+ inversion_clear 2.
+ destruct (@cons s2 End); auto.
+ inversion_clear 2.
+ simpl in a; rewrite <- app_nil_end in a.
+ simpl in a0; rewrite <- app_nil_end in a0.
+ destruct (@equal_aux cmp x x0); intuition.
+ left.
+ rewrite H4 in e; rewrite H5 in e.
+ rewrite Equal_elements; auto.
+ right.
+ swap n.
+ rewrite H4; rewrite H5.
+ rewrite <- Equal_elements; auto.
+Qed.
+
+End Elt2.
+
+Section Elts. 
+
+Variable elt elt' elt'' : Set.
+
+Section Map. 
+Variable f : elt -> elt'. 
+
+Fixpoint map (m:t elt) {struct m} : t elt' := 
+  match m with 
+   | Leaf   => Leaf _
+   | Node l v d r h => Node (map l) v  (f d) (map r) h
+  end.
+
+Lemma map_height : forall m, height (map m) = height m.
+Proof. 
+destruct m; simpl; auto.
+Qed.
+
+Lemma map_avl : forall m, avl m -> avl (map m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto; do 2 rewrite map_height; auto.
+Qed.
+
+Lemma map_1 : forall (m: tree elt)(x:key)(e:elt), 
+    MapsTo x e m -> MapsTo x (f e) (map m).
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+Qed.
+
+Lemma map_2 : forall (m: t elt)(x:key), 
+    In x (map m) -> In x m.
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+Qed.
+
+Lemma map_bst : forall m, bst m -> bst (map m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto.
+red; intros; apply H2; apply map_2; auto.
+red; intros; apply H3; apply map_2; auto.
+Qed.
+
+End Map.
+Section Mapi. 
+Variable f : key -> elt -> elt'. 
+
+Fixpoint mapi (m:t elt) {struct m} : t elt' := 
+  match m with 
+   | Leaf   => Leaf _
+   | Node l v d r h => Node (mapi l) v  (f v d) (mapi r) h
+  end.
+
+Lemma mapi_height : forall m, height (mapi m) = height m.
+Proof. 
+destruct m; simpl; auto.
+Qed.
+
+Lemma mapi_avl : forall m, avl m -> avl (mapi m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto; do 2 rewrite mapi_height; auto.
+Qed.
+
+Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), 
+    MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi m).
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+exists k; auto.
+destruct (IHm1 _ _ H0).
+exists x0; intuition.
+destruct (IHm2 _ _ H0).
+exists x0; intuition.
+Qed.
+
+Lemma mapi_2 : forall (m: t elt)(x:key), 
+    In x (mapi m) -> In x m.
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+Qed.
+
+Lemma mapi_bst : forall m, bst m -> bst (mapi m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto.
+red; intros; apply H2; apply mapi_2; auto.
+red; intros; apply H3; apply mapi_2; auto.
+Qed.
+
+End Mapi.
+
+Section Map2.
+Variable f : option elt -> option elt' -> option elt''.
+
+(* Not exactly pretty nor perfect, but should suffice as a first naive implem. 
+    Anyway, map2 isn't in Ocaml...
+*)
+
+Definition anti_elements (l:list (key*elt'')) := L.fold (@add _) l (empty _).
+
+Definition map2 (m:t elt)(m':t elt') : t elt'' := 
+  anti_elements (L.map2 f (elements m) (elements m')).
+
+Lemma anti_elements_avl_aux : forall (l:list (key*elt''))(m:t elt''), 
+  avl m -> avl (L.fold (@add _) l m).
+Proof.
+unfold anti_elements; induction l.
+simpl; auto.
+simpl; destruct a; intros.
+apply IHl.
+apply add_avl; auto.
+Qed.
+
+Lemma anti_elements_avl : forall l, avl (anti_elements l).
+Proof.
+unfold anti_elements, empty; intros; apply anti_elements_avl_aux; auto.
+Qed.
+
+Lemma anti_elements_bst_aux : forall (l:list (key*elt''))(m:t elt''), 
+  bst m -> avl m -> bst (L.fold (@add _) l m).
+Proof.
+induction l.
+simpl; auto.
+simpl; destruct a; intros.
+apply IHl.
+apply add_bst; auto.
+apply add_avl; auto.
+Qed.
+
+Lemma anti_elements_bst : forall l, bst (anti_elements l).
+Proof.
+unfold anti_elements, empty; intros; apply anti_elements_bst_aux; auto.
+Qed.
+
+Lemma anti_elements_mapsto_aux : forall (l:list (key*elt'')) m k e,
+  bst m -> avl m -> NoDupA (eqk (elt:=elt'')) l -> 
+  (forall x, L.PX.In x l -> In x m -> False) -> 
+  (MapsTo k e (L.fold (@add _) l m) <-> L.PX.MapsTo k e l \/ MapsTo k e m).
+Proof.
+induction l. 
+simpl; auto.
+intuition.
+inversion H4.
+simpl; destruct a; intros.
+rewrite IHl; clear IHl.
+apply add_bst; auto.
+apply add_avl; auto.
+inversion H1; auto.
+intros.
+inversion_clear H1.
+assert (~X.eq x k).
+ swap H5.
+ destruct H3.
+ apply InA_eqA with (x,x0); eauto.
+apply (H2 x).
+destruct H3; exists x0; auto.
+revert H4; do 2 rewrite <- In_alt; destruct 1; exists x0; auto.
+eapply add_3; eauto.
+intuition.
+assert (find k0 (add k e m) = Some e0).
+ apply find_1; auto.
+ apply add_bst; auto.
+clear H4. 
+rewrite add_spec in H3; auto.
+destruct (eq_dec k0 k).
+inversion_clear H3; subst; auto.
+right; apply find_2; auto.
+inversion_clear H4; auto.
+compute in H3; destruct H3.
+subst; right; apply add_1; auto.
+inversion_clear H1.
+destruct (eq_dec k0 k).
+destruct (H2 k); eauto.
+right; apply add_2; auto.
+Qed.
+
+Lemma anti_elements_mapsto : forall l k e, NoDupA (eqk (elt:=elt'')) l ->
+  (MapsTo k e (anti_elements l) <-> L.PX.MapsTo k e l).
+Proof. 
+intros. 
+unfold anti_elements.
+rewrite anti_elements_mapsto_aux; auto; unfold empty; auto.
+inversion 2.
+intuition.
+inversion H1.
+Qed.
+
+Lemma map2_avl : forall (m: t elt)(m': t elt'), avl (map2 m m').
+Proof.
+unfold map2; intros; apply anti_elements_avl; auto.
+Qed.
+
+Lemma map2_bst : forall (m: t elt)(m': t elt'), bst (map2 m m').
+Proof.
+unfold map2; intros; apply anti_elements_bst; auto.
+Qed.
+
+Lemma find_elements : forall (elt:Set)(m: t elt) x, bst m -> 
+  L.find x (elements m) = find x m.
+Proof. 
+intros.
+case_eq (find x m); intros.
+apply L.find_1.
+apply elements_sort; auto.
+red; rewrite elements_mapsto.
+apply find_2; auto.
+case_eq (L.find x (elements m)); auto; intros.
+rewrite <- H0; symmetry.
+apply find_1; auto.
+rewrite <- elements_mapsto.
+apply L.find_2; auto.
+Qed.
+
+Lemma find_anti_elements : forall (l: list (key*elt'')) x, sort (@ltk _) l -> 
+  find x (anti_elements l) = L.find x l.
+Proof.
+intros.
+case_eq (L.find x l); intros.
+apply find_1.
+apply anti_elements_bst; auto.
+rewrite anti_elements_mapsto.
+apply L.PX.Sort_NoDupA; auto.
+apply L.find_2; auto.
+case_eq (find x (anti_elements l)); auto; intros.
+rewrite <- H0; symmetry.
+apply L.find_1; auto.
+rewrite <- anti_elements_mapsto.
+apply L.PX.Sort_NoDupA; auto.
+apply find_2; auto.
+Qed.
+
+Lemma map2_1 : forall (m: t elt)(m': t elt')(x:key), bst m -> bst m' -> 
+  In x m \/ In x m' -> find x (map2 m m') = f (find x m) (find x m').       
+Proof. 
+unfold map2; intros.
+rewrite find_anti_elements; auto.
+rewrite <- find_elements; auto.
+rewrite <- find_elements; auto.
+apply L.map2_1; auto.
+apply elements_sort; auto.
+apply elements_sort; auto.
+do 2 rewrite elements_in; auto.
+apply L.map2_sorted; auto.
+apply elements_sort; auto.
+apply elements_sort; auto.
+Qed.
+
+Lemma map2_2 : forall (m: t elt)(m': t elt')(x:key), bst m -> bst m' -> 
+  In x (map2 m m') -> In x m \/ In x m'.
+Proof.
+unfold map2; intros.
+do 2 rewrite <- elements_in.
+apply L.map2_2 with (f:=f); auto.
+apply elements_sort; auto.
+apply elements_sort; auto.
+revert H1.
+rewrite <- In_alt.
+destruct 1.
+exists x0.
+rewrite <- anti_elements_mapsto; auto.
+apply L.PX.Sort_NoDupA; auto.
+apply L.map2_sorted; auto.
+apply elements_sort; auto.
+apply elements_sort; auto.
+Qed.
+
+End Map2.
+End Elts.
+End Raw.
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we 
+   need to encapsulate everything into a type of balanced binary search trees. *)
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+
+ Module E := X.
+ Module Raw := Raw I X. 
+
+ Record bbst (elt:Set) : Set := 
+  Bbst {this :> Raw.tree elt; is_bst : Raw.bst this; is_avl: Raw.avl this}.
+ 
+ Definition t := bbst. 
+ Definition key := E.t.
+ 
+ Section Elt. 
+ Variable elt elt' elt'': Set.
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key. 
+ Implicit Types e : elt. 
+
+ Definition empty : t elt := Bbst (Raw.empty_bst elt) (Raw.empty_avl elt).
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := 
+  Bbst (Raw.add_bst x e m.(is_bst) m.(is_avl)) (Raw.add_avl x e m.(is_avl)).
+ Definition remove x m : t elt := 
+  Bbst (Raw.remove_bst x m.(is_bst) m.(is_avl)) (Raw.remove_avl x m.(is_avl)). 
+ Definition mem x m : bool := Raw.mem x m.(this).
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition map f m : t elt' := 
+  Bbst (Raw.map_bst f m.(is_bst)) (Raw.map_avl f m.(is_avl)).
+ Definition mapi (f:key->elt->elt') m : t elt' := 
+  Bbst (Raw.mapi_bst f m.(is_bst)) (Raw.mapi_avl f m.(is_avl)).
+ Definition map2 f m (m':t elt') : t elt'' := 
+  Bbst (Raw.map2_bst f m m') (Raw.map2_avl f m m').
+ Definition elements m : list (key*elt) := Raw.elements m.(this).
+ Definition fold (A:Set) (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i.
+ Definition equal cmp m m' : bool := 
+   if (Raw.equal cmp m.(is_bst) m'.(is_bst)) then true else false.
+
+ Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.In0 x m.(this).
+ Definition Empty m : Prop := Raw.Empty m.(this).
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqke elt.
+ Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt.
+
+ Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.MapsTo_1 _ m.(this)). Qed.
+ 
+ Lemma mem_1 : forall m x, In x m -> mem x m = true.
+ Proof.
+ unfold In, mem; intros m x; rewrite Raw.In_alt; simpl; apply Raw.mem_1; auto.
+ apply m.(is_bst).
+ Qed.
+ 
+ Lemma mem_2 : forall m x, mem x m = true -> In x m. 
+ Proof.
+ unfold In, mem; intros m x; rewrite Raw.In_alt; simpl; apply Raw.mem_2; auto.
+ Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact (@Raw.empty_1 elt). Qed.
+
+ Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+ Proof. intros m; exact (@Raw.is_empty_1 _ m.(this)). Qed.
+ Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+ Proof. intros m; exact (@Raw.is_empty_2 _ m.(this)). Qed.
+
+ Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
+ Proof. intros m x y e; exact (@Raw.add_1 elt _ x y e m.(is_avl)). Qed.
+ Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+ Proof. intros m x y e e'; exact (@Raw.add_2 elt _ x y e e' m.(is_avl)). Qed.
+ Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+ Proof. intros m x y e e'; exact (@Raw.add_3 elt _ x y e e' m.(is_avl)). Qed.
+
+ Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
+ Proof.
+ unfold In, remove; intros m x y; rewrite Raw.In_alt; simpl; apply Raw.remove_1; auto.
+ apply m.(is_bst).
+ apply m.(is_avl).
+ Qed.
+ Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+ Proof. intros m x y e; exact (@Raw.remove_2 elt _ x y e m.(is_bst) m.(is_avl)). Qed.
+ Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
+ Proof. intros m x y e; exact (@Raw.remove_3 elt _ x y e m.(is_bst) m.(is_avl)). Qed.
+
+
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. 
+ Proof. intros m x e; exact (@Raw.find_1 elt _ x e m.(is_bst)). Qed.
+ Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed.
+
+ Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ Proof. intros m; exact (@Raw.fold_1 elt m.(this) m.(is_bst)). Qed.
+
+ Lemma elements_1 : forall m x e,       
+   MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+ Proof.
+ intros; unfold elements, MapsTo, eq_key_elt; rewrite Raw.elements_mapsto; auto.
+ Qed.
+
+ Lemma elements_2 : forall m x e,   
+   InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+ Proof.
+ intros; unfold elements, MapsTo, eq_key_elt; rewrite <- Raw.elements_mapsto; auto.
+ Qed.
+
+ Lemma elements_3 : forall m, sort lt_key (elements m).  
+ Proof. intros m; exact (@Raw.elements_sort elt m.(this) m.(is_bst)). Qed.
+
+ Definition Equal cmp m m' := 
+   (forall k, In k m <-> In k m') /\ 
+   (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+ Lemma Equal_Equal : forall cmp m m', Equal cmp m m' <-> Raw.Equal cmp m m'.
+ Proof. 
+ intros; unfold Equal, Raw.Equal, In; intuition.
+ generalize (H0 k); do 2 rewrite Raw.In_alt; intuition.
+ generalize (H0 k); do 2 rewrite Raw.In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- Raw.In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- Raw.In_alt; intuition.
+ Qed. 
+
+ Lemma equal_1 : forall m m' cmp, 
+   Equal cmp m m' -> equal cmp m m' = true. 
+ Proof. 
+ unfold equal; intros m m' cmp; rewrite Equal_Equal.
+ destruct (@Raw.equal _ cmp m m'); auto.
+ Qed. 
+
+ Lemma equal_2 : forall m m' cmp, 
+   equal cmp m m' = true -> Equal cmp m m'.
+ Proof. 
+ unfold equal; intros; rewrite Equal_Equal.
+ destruct (@Raw.equal _ cmp m m'); auto; try discriminate.
+ Qed.  
+
+ End Elt.
+
+ Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+ Proof. intros elt elt' m x e f; exact (@Raw.map_1 elt elt' f m.(this) x e). Qed.
+
+ Lemma map_2 : forall (elt elt':Set)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m.
+ Proof.
+ intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite Raw.In_alt; simpl.
+ apply Raw.map_2; auto.
+ Qed. 
+
+ Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+ Proof. intros elt elt' m x e f; exact (@Raw.mapi_1 elt elt' f m.(this) x e). Qed.
+ Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+ Proof.
+ intros elt elt' m x f; unfold In in *; do 2 rewrite Raw.In_alt; simpl; apply Raw.mapi_2; auto.
+ Qed. 
+
+ Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+    (x:key)(f:option elt->option elt'->option elt''), 
+    In x m \/ In x m' -> 
+    find x (map2 f m m') = f (find x m) (find x m'). 
+ Proof. 
+ unfold find, map2, In; intros elt elt' elt'' m m' x f.
+ do 2 rewrite Raw.In_alt; intros; simpl; apply Raw.map2_1; auto.
+ apply m.(is_bst).
+ apply m'.(is_bst).
+ Qed.
+
+ Lemma map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+     (x:key)(f:option elt->option elt'->option elt''), 
+     In x (map2 f m m') -> In x m \/ In x m'.
+ Proof. 
+ unfold In, map2; intros elt elt' elt'' m m' x f.
+ do 3 rewrite Raw.In_alt; intros; simpl in *; eapply Raw.map2_2; eauto.
+ apply m.(is_bst).
+ apply m'.(is_bst).
+ Qed.
+
+End IntMake.
+
+
+Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: 
+    Sord with Module Data := D 
+            with Module MapS.E := X.
+
+  Module Data := D.
+  Module MapS := IntMake(I)(X). 
+  Import MapS.
+
+  Module MD := OrderedTypeFacts(D).
+  Import MD.
+
+  Module LO := FMapList.Make_ord(X)(D).
+
+  Definition t := MapS.t D.t. 
+
+  Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end.	
+
+  Definition elements (m:t) := 
+    LO.MapS.Build_slist (Raw.elements_sort m.(is_bst)).
+
+  Definition eq : t -> t -> Prop := 
+    fun m1 m2 => LO.eq (elements m1) (elements m2).
+
+  Definition lt : t -> t -> Prop := 
+    fun m1 m2 => LO.lt (elements m1) (elements m2).
+
+  Lemma eq_1 : forall m m', Equal cmp m m' -> eq m m'.
+  Proof.
+  intros m m'.
+  unfold eq.
+  rewrite Equal_Equal.
+  rewrite Raw.Equal_elements.
+  intros.
+  apply LO.eq_1.
+  auto.
+  Qed.
+
+  Lemma eq_2 : forall m m', eq m m' -> Equal cmp m m'.
+  Proof.
+  intros m m'.
+  unfold eq.
+  rewrite Equal_Equal.
+  rewrite Raw.Equal_elements.
+  intros.
+  generalize (LO.eq_2 H).
+  auto.
+  Qed.
+ 
+  Lemma eq_refl : forall m : t, eq m m.
+  Proof. 
+  unfold eq; intros; apply LO.eq_refl.
+  Qed.
+
+  Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+  Proof.
+  unfold eq; intros; apply LO.eq_sym; auto.
+  Qed.
+
+  Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
+  Proof.
+  unfold eq; intros; eapply LO.eq_trans; eauto.
+  Qed.
+
+  Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
+  Proof.
+  unfold lt; intros; eapply LO.lt_trans; eauto.
+  Qed.
+
+  Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
+  Proof.
+  unfold lt, eq; intros; apply LO.lt_not_eq; auto.
+  Qed.
+
+  Import Raw.
+
+  Definition flatten_slist (e:enumeration D.t)(He:sorted_e e) := 
+   LO.MapS.Build_slist (sorted_flatten_e He). 
+
+  Open Scope Z_scope.
+
+  Definition compare_aux : 
+   forall (e1 e2:enumeration D.t)(He1:sorted_e e1)(He2: sorted_e e2), 
+   Compare LO.lt LO.eq (flatten_slist He1) (flatten_slist He2).
+  Proof.
+  intros e1 e2; pattern e1, e2 in |- *; apply compare_rec2.
+  simple destruct x; simple destruct x'; intuition.
+  (* x = x' = End *)
+  constructor 2.
+  compute; auto.
+  (* x = End x' = More *)
+  constructor 1.
+  compute; auto.
+  (* x = More x' = End *)
+  constructor 3.
+  compute; auto.
+  (* x = More k t0 t1 e, x' = More k0 t2 t3 e0 *)
+  case (X.compare k k0); intro.
+  (* k < k0 *)
+  constructor 1.
+  compute; MX.elim_comp; auto.
+  (* k = k0 *)
+  destruct (D.compare t t1).
+  constructor 1.
+  compute; MX.elim_comp; auto.
+  destruct (@cons _ t0 e) as [c1 (H2,(H3,H4))]; try inversion_clear He1; auto.
+  destruct (@cons _ t2 e0) as [c2 (H5,(H6,H7))]; try inversion_clear He2; auto.
+  assert (measure_e c1 + measure_e c2 <
+              measure_e (More k t t0 e) + 
+              measure_e (More k0 t1 t2 e0)).
+  unfold measure_e in *; fold measure_e in *; omega.           
+  destruct (H c1 c2 H0 H2 H5); clear H.
+  constructor 1.
+  unfold flatten_slist, LO.lt in *; simpl; simpl in l.
+  MX.elim_comp.
+  right; split; auto.
+  rewrite <- H7; rewrite <- H4; auto.
+  constructor 2.
+  unfold flatten_slist, LO.eq in *; simpl; simpl in e5.
+  MX.elim_comp.
+  split; auto.
+  rewrite <- H7; rewrite <- H4; auto.
+  constructor 3.
+  unfold flatten_slist, LO.lt in *; simpl; simpl in l.
+  MX.elim_comp.
+  right; split; auto.
+  rewrite <- H7; rewrite <- H4; auto.
+  constructor 3.
+  compute; MX.elim_comp; auto.
+  (* k > k0 *)
+  constructor 3.
+  compute; MX.elim_comp; auto.
+  Qed.
+
+  Definition compare : forall m1 m2, Compare lt eq m1 m2.
+  Proof.
+  intros (m1,m1_bst,m1_avl) (m2,m2_bst,m2_avl); simpl.
+  destruct (@cons _ m1 (End _)) as [x1 (H1,H11)]; auto.
+  apply SortedEEnd.
+  inversion_clear 2.
+  destruct (@cons _ m2 (End _)) as [x2 (H2,H22)]; auto.
+  apply SortedEEnd.
+  inversion_clear 2.
+  simpl in H11; rewrite <- app_nil_end in H11.
+  simpl in H22; rewrite <- app_nil_end in H22.
+  destruct (compare_aux H1 H2); intuition.
+  constructor 1.
+  unfold lt, LO.lt, IntMake_ord.elements, flatten_slist in *; simpl in *.
+  rewrite <- H0; rewrite <- H4; auto.
+  constructor 2.
+  unfold eq, LO.eq, IntMake_ord.elements, flatten_slist in *; simpl in *.
+  rewrite <- H0; rewrite <- H4; auto.
+  constructor 3.
+  unfold lt, LO.lt, IntMake_ord.elements, flatten_slist in *; simpl in *.
+  rewrite <- H0; rewrite <- H4; auto.
+  Qed.
+
+End IntMake_ord.
+
+(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
+
+Module Make (X: OrderedType) <: S with Module E := X
+ :=IntMake(Z_as_Int)(X).
+
+Module Make_ord (X: OrderedType)(D: OrderedType) 
+ <: Sord with Module Data := D 
+            with Module MapS.E := X
+ :=IntMake_ord(Z_as_Int)(X)(D).
diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v
new file mode 100644
index 00000000..0105095a
--- /dev/null
+++ b/theories/FSets/FMapFacts.v
@@ -0,0 +1,557 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FMapFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *)
+
+(** * Finite maps library *)
+
+(** This functor derives additional facts from [FMapInterface.S]. These
+  facts are mainly the specifications of [FMapInterface.S] written using 
+  different styles: equivalence and boolean equalities. 
+*)
+
+Require Import Bool.
+Require Import OrderedType.
+Require Export FMapInterface. 
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module Facts (M: S).
+Module ME := OrderedTypeFacts M.E.
+Import ME.
+Import M.
+Import Logic. (* to unmask [eq] *)  
+Import Peano. (* to unmask [lt] *)
+
+Lemma MapsTo_fun : forall (elt:Set) m x (e e':elt), 
+  MapsTo x e m -> MapsTo x e' m -> e=e'.
+Proof.
+intros.
+generalize (find_1 H) (find_1 H0); clear H H0.
+intros; rewrite H in H0; injection H0; auto.
+Qed.
+
+(** * Specifications written using equivalences *)
+
+Section IffSpec. 
+Variable elt elt' elt'': Set.
+Implicit Type m: t elt.
+Implicit Type x y z: key.
+Implicit Type e: elt.
+
+Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m).
+Proof.
+split; apply MapsTo_1; auto.
+Qed.
+
+Lemma In_iff : forall m x y, E.eq x y -> (In x m <-> In y m).
+Proof.
+unfold In.
+split; intros (e0,H0); exists e0.
+apply (MapsTo_1 H H0); auto.
+apply (MapsTo_1 (E.eq_sym H) H0); auto.
+Qed.
+
+Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e.
+Proof.
+split; [apply find_1|apply find_2].
+Qed.
+
+Lemma not_find_mapsto_iff : forall m x, ~In x m <-> find x m = None.
+Proof.
+intros.
+generalize (find_mapsto_iff m x); destruct (find x m).
+split; intros; try discriminate.
+destruct H0.
+exists e; rewrite H; auto.
+split; auto.
+intros; intros (e,H1).
+rewrite H in H1; discriminate.
+Qed.
+
+Lemma mem_in_iff : forall m x, In x m <-> mem x m = true.
+Proof.
+split; [apply mem_1|apply mem_2].
+Qed.
+
+Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false.
+Proof.
+intros; rewrite mem_in_iff; destruct (mem x m); intuition.
+Qed.
+
+Lemma equal_iff : forall m m' cmp, Equal cmp m m' <-> equal cmp m m' = true.
+Proof. 
+split; [apply equal_1|apply equal_2].
+Qed.
+
+Lemma empty_mapsto_iff : forall x e, MapsTo x e (empty elt) <-> False.
+Proof.
+intuition; apply (empty_1 H).
+Qed.
+
+Lemma empty_in_iff : forall x, In x (empty elt) <-> False.
+Proof.
+unfold In.
+split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition.
+Qed.
+
+Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. 
+Proof. 
+split; [apply is_empty_1|apply is_empty_2].
+Qed.
+
+Lemma add_mapsto_iff : forall m x y e e', 
+  MapsTo y e' (add x e m) <-> 
+     (E.eq x y /\ e=e') \/ 
+     (~E.eq x y /\ MapsTo y e' m).
+Proof. 
+intros.
+intuition.
+destruct (eq_dec x y); [left|right].
+split; auto.
+symmetry; apply (MapsTo_fun (e':=e) H); auto.
+split; auto; apply add_3 with x e; auto.
+subst; auto.
+Qed.
+
+Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m.
+Proof. 
+unfold In; split.
+intros (e',H).
+destruct (eq_dec x y) as [E|E]; auto.
+right; exists e'; auto.
+apply (add_3 E H).
+destruct (eq_dec x y) as [E|E]; auto.
+intros.
+exists e; apply add_1; auto.
+intros [H|(e',H)].
+destruct E; auto.
+exists e'; apply add_2; auto.
+Qed.
+
+Lemma add_neq_mapsto_iff : forall m x y e e', 
+ ~ E.eq x y -> (MapsTo y e' (add x e m)  <-> MapsTo y e' m).
+Proof.
+split; [apply add_3|apply add_2]; auto.
+Qed.
+
+Lemma add_neq_in_iff : forall m x y e, 
+ ~ E.eq x y -> (In y (add x e m)  <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+apply (add_3 H H0).
+apply add_2; auto.
+Qed.
+
+Lemma remove_mapsto_iff : forall m x y e, 
+  MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m.
+Proof. 
+intros.
+split; intros.
+split.
+assert (In y (remove x m)) by (exists e; auto).
+intro H1; apply (remove_1 H1 H0).
+apply remove_3 with x; auto.
+apply remove_2; intuition.
+Qed.
+
+Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m.
+Proof. 
+unfold In; split.
+intros (e,H).
+split.
+assert (In y (remove x m)) by (exists e; auto).
+intro H1; apply (remove_1 H1 H0).
+exists e; apply remove_3 with x; auto.
+intros (H,(e,H0)); exists e; apply remove_2; auto.
+Qed.
+
+Lemma remove_neq_mapsto_iff : forall m x y e, 
+ ~ E.eq x y -> (MapsTo y e (remove x m)  <-> MapsTo y e m).
+Proof.
+split; [apply remove_3|apply remove_2]; auto.
+Qed.
+
+Lemma remove_neq_in_iff : forall m x y, 
+ ~ E.eq x y -> (In y (remove x m)  <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+apply (remove_3 H0).
+apply remove_2; auto.
+Qed.
+
+Lemma elements_mapsto_iff : forall m x e, 
+ MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m).
+Proof. 
+split; [apply elements_1 | apply elements_2].
+Qed.
+
+Lemma elements_in_iff : forall m x, 
+ In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m).
+Proof. 
+unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto.
+Qed.
+
+Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), 
+ MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m.
+Proof.
+split.
+case_eq (find x m); intros.
+exists e.
+split.
+apply (MapsTo_fun (m:=map f m) (x:=x)); auto.
+apply find_2; auto.
+assert (In x (map f m)) by (exists b; auto).
+destruct (map_2 H1) as (a,H2).
+rewrite (find_1 H2) in H; discriminate.
+intros (a,(H,H0)).
+subst b; auto.
+Qed.
+
+Lemma map_in_iff : forall m x (f : elt -> elt'), 
+ In x (map f m) <-> In x m.
+Proof.
+split; intros; eauto.
+destruct H as (a,H).
+exists (f a); auto.
+Qed.
+
+Lemma mapi_in_iff : forall m x (f:key->elt->elt'),
+ In x (mapi f m) <-> In x m.
+Proof.
+split; intros; eauto.
+destruct H as (a,H).
+destruct (mapi_1 f H) as (y,(H0,H1)).
+exists (f y a); auto.
+Qed.
+
+(* Unfortunately, we don't have simple equivalences for [mapi] 
+  and [MapsTo]. The only correct one needs compatibility of [f]. *) 
+
+Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), 
+ MapsTo x b (mapi f m) -> 
+ exists a, exists y, E.eq y x /\ b = f y a /\ MapsTo x a m.
+Proof.
+intros; case_eq (find x m); intros.
+exists e.
+destruct (@mapi_1 _ _ m x e f) as (y,(H1,H2)).
+apply find_2; auto.
+exists y; repeat split; auto.
+apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto.
+assert (In x (mapi f m)) by (exists b; auto).
+destruct (mapi_2 H1) as (a,H2).
+rewrite (find_1 H2) in H0; discriminate.
+Qed.
+
+Lemma mapi_1bis : forall m x e (f:key->elt->elt'), 
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ MapsTo x e m -> MapsTo x (f x e) (mapi f m).
+Proof.
+intros.
+destruct (mapi_1 f H0) as (y,(H1,H2)).
+replace (f x e) with (f y e) by auto.
+auto.
+Qed.
+
+Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'),
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m).
+Proof.
+split.
+intros.
+destruct (mapi_inv H0) as (a,(y,(H1,(H2,H3)))).
+exists a; split; auto.
+subst b; auto.
+intros (a,(H0,H1)).
+subst b.
+apply mapi_1bis; auto.
+Qed.
+
+(** Things are even worse for [map2] : we don't try to state any 
+ equivalence, see instead boolean results below. *)
+
+End IffSpec.
+
+(** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *)
+  
+Ltac map_iff := 
+ repeat (progress (
+  rewrite add_mapsto_iff || rewrite add_in_iff ||
+  rewrite remove_mapsto_iff || rewrite remove_in_iff ||
+  rewrite empty_mapsto_iff || rewrite empty_in_iff ||
+  rewrite map_mapsto_iff || rewrite map_in_iff ||
+  rewrite mapi_in_iff)).
+
+(**  * Specifications written using boolean predicates *)
+
+Section BoolSpec.
+
+Lemma mem_find_b : forall (elt:Set)(m:t elt)(x:key), mem x m = if find x m then true else false. 
+Proof.
+intros.
+generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In.
+destruct (find x m); destruct (mem x m); auto.
+intros.
+rewrite <- H0; exists e; rewrite H; auto.
+intuition.
+destruct H0 as (e,H0).
+destruct (H e); intuition discriminate.
+Qed.
+
+Variable elt elt' elt'' : Set.
+Implicit Types m : t elt.
+Implicit Types x y z : key.
+Implicit Types e : elt.
+
+Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m.
+Proof. 
+intros.
+generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H).
+destruct (mem x m); destruct (mem y m); intuition.
+Qed.
+
+Lemma find_o : forall m x y, E.eq x y -> find x m = find y m.
+Proof.
+intros.
+generalize (find_mapsto_iff m x) (find_mapsto_iff m y) (fun e => MapsTo_iff m e H).
+destruct (find x m); destruct (find y m); intros.
+rewrite <- H0; rewrite H2; rewrite H1; auto.
+symmetry; rewrite <- H1; rewrite <- H2; rewrite H0; auto.
+rewrite <- H0; rewrite H2; rewrite H1; auto.
+auto.
+Qed.
+
+Lemma empty_o : forall x, find x (empty elt) = None.
+Proof.
+intros.
+case_eq (find x (empty elt)); intros; auto.
+generalize (find_2 H).
+rewrite empty_mapsto_iff; intuition.
+Qed.
+
+Lemma empty_a : forall x, mem x (empty elt) = false.
+Proof.
+intros.
+case_eq (mem x (empty elt)); intros; auto.
+generalize (mem_2 H).
+rewrite empty_in_iff; intuition.
+Qed.
+
+Lemma add_eq_o : forall m x y e, 
+ E.eq x y -> find y (add x e m) = Some e.
+Proof.
+auto.
+Qed.
+
+Lemma add_neq_o : forall m x y e, 
+ ~ E.eq x y -> find y (add x e m) = find y m. 
+Proof.
+intros.
+case_eq (find y m); intros; auto.
+case_eq (find y (add x e m)); intros; auto.
+rewrite <- H0; symmetry.
+apply find_1; apply add_3 with x e; auto.
+Qed.
+Hint Resolve add_neq_o.
+
+Lemma add_o : forall m x y e, 
+ find y (add x e m) = if eq_dec x y then Some e else find y m.
+Proof.
+intros; destruct (eq_dec x y); auto.
+Qed.
+
+Lemma add_eq_b : forall m x y e, 
+ E.eq x y -> mem y (add x e m) = true.
+Proof.
+intros; rewrite mem_find_b; rewrite add_eq_o; auto.
+Qed.
+
+Lemma add_neq_b : forall m x y e, 
+ ~E.eq x y -> mem y (add x e m) = mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto.
+Qed.
+
+Lemma add_b : forall m x y e, 
+ mem y (add x e m) = eqb x y || mem y m. 
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb.
+destruct (eq_dec x y); simpl; auto.
+Qed.
+
+Lemma remove_eq_o : forall m x y, 
+ E.eq x y -> find y (remove x m) = None.
+Proof.
+intros.
+generalize (remove_1 (m:=m) H).
+generalize (find_mapsto_iff (remove x m) y).
+destruct (find y (remove x m)); auto.
+destruct 2.
+exists e; rewrite H0; auto.
+Qed.
+Hint Resolve remove_eq_o.
+
+Lemma remove_neq_o : forall m x y, 
+ ~ E.eq x y -> find y (remove x m) = find y m. 
+Proof.
+intros.
+case_eq (find y m); intros; auto.
+case_eq (find y (remove x m)); intros; auto.
+rewrite <- H0; symmetry.
+apply find_1; apply remove_3 with x; auto.
+Qed.
+Hint Resolve remove_neq_o.
+
+Lemma remove_o : forall m x y, 
+ find y (remove x m) = if eq_dec x y then None else find y m.
+Proof.
+intros; destruct (eq_dec x y); auto.
+Qed.
+
+Lemma remove_eq_b : forall m x y, 
+ E.eq x y -> mem y (remove x m) = false.
+Proof.
+intros; rewrite mem_find_b; rewrite remove_eq_o; auto.
+Qed.
+
+Lemma remove_neq_b : forall m x y, 
+ ~ E.eq x y -> mem y (remove x m) = mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto.
+Qed.
+
+Lemma remove_b : forall m x y, 
+ mem y (remove x m) = negb (eqb x y) && mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb.
+destruct (eq_dec x y); auto.
+Qed.
+
+Definition option_map (A:Set)(B:Set)(f:A->B)(o:option A) : option B := 
+ match o with 
+  | Some a => Some (f a)
+  | None => None
+ end.
+
+Lemma map_o : forall m x (f:elt->elt'), 
+ find x (map f m) = option_map f (find x m). 
+Proof.
+intros.
+generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x)
+  (fun b => map_mapsto_iff m x b f).
+destruct (find x (map f m)); destruct (find x m); simpl; auto; intros.
+rewrite <- H; rewrite H1; exists e0; rewrite H0; auto.
+destruct (H e) as [_ H2].
+rewrite H1 in H2.
+destruct H2 as (a,(_,H2)); auto.
+rewrite H0 in H2; discriminate.
+rewrite <- H; rewrite H1; exists e; rewrite H0; auto.
+Qed.
+
+Lemma map_b : forall m x (f:elt->elt'), 
+ mem x (map f m) = mem x m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite map_o.
+destruct (find x m); simpl; auto.
+Qed.
+
+Lemma mapi_b : forall m x (f:key->elt->elt'), 
+ mem x (mapi f m) = mem x m.
+Proof.
+intros.
+generalize (mem_in_iff (mapi f m) x) (mem_in_iff m x) (mapi_in_iff m x f).
+destruct (mem x (mapi f m)); destruct (mem x m); simpl; auto; intros.
+symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto.
+rewrite <- H; rewrite H1; rewrite H0; auto.
+Qed.
+
+Lemma mapi_o : forall m x (f:key->elt->elt'), 
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ find x (mapi f m) = option_map (f x) (find x m).
+Proof.
+intros.
+generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) 
+  (fun b => mapi_mapsto_iff m x b H).
+destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros.
+rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto.
+destruct (H0 e) as [_ H3].
+rewrite H2 in H3.
+destruct H3 as (a,(_,H3)); auto.
+rewrite H1 in H3; discriminate.
+rewrite <- H0; rewrite H2; exists e; rewrite H1; auto.
+Qed.
+
+Lemma map2_1bis : forall (m: t elt)(m': t elt') x 
+ (f:option elt->option elt'->option elt''), 
+ f None None = None -> 
+ find x (map2 f m m') = f (find x m) (find x m').       
+Proof.
+intros.
+case_eq (find x m); intros.
+rewrite <- H0.
+apply map2_1; auto.
+left; exists e; auto.
+case_eq (find x m'); intros.
+rewrite <- H0; rewrite <- H1.
+apply map2_1; auto.
+right; exists e; auto.
+rewrite H.
+case_eq (find x (map2 f m m')); intros; auto.
+assert (In x (map2 f m m')) by (exists e; auto).
+destruct (map2_2 H3) as [(e0,H4)|(e0,H4)].
+rewrite (find_1 H4) in H0; discriminate.
+rewrite (find_1 H4) in H1; discriminate.
+Qed.
+
+Lemma elements_o : forall m x, 
+ find x m = findA (eqb x) (elements m).
+Proof.
+intros.
+assert (forall e, find x m = Some e <-> InA (eq_key_elt (elt:=elt)) (x,e) (elements m)).
+ intros; rewrite <- find_mapsto_iff; apply elements_mapsto_iff.
+assert (NoDupA (eq_key (elt:=elt)) (elements m)). 
+ apply SortA_NoDupA with (lt_key (elt:=elt)); unfold eq_key, lt_key; intuition eauto.
+ destruct y; simpl in *.
+ apply (E.lt_not_eq H0 H1).
+ exact (elements_3 m).
+generalize (fun e => @findA_NoDupA _ _ _ E.eq_sym E.eq_trans eq_dec (elements m) x e H0).
+unfold eqb.
+destruct (find x m); destruct (findA (fun y : E.t => if eq_dec x y then true else false) (elements m)); 
+ simpl; auto; intros.
+symmetry; rewrite <- H1; rewrite <- H; auto.
+symmetry; rewrite <- H1; rewrite <- H; auto.
+rewrite H; rewrite H1; auto.
+Qed.
+
+Lemma elements_b : forall m x, mem x m = existsb (fun p => eqb x (fst p)) (elements m).
+Proof.
+intros.
+generalize (mem_in_iff m x)(elements_in_iff m x)
+ (existsb_exists (fun p => eqb x (fst p)) (elements m)).
+destruct (mem x m); destruct (existsb (fun p => eqb x (fst p)) (elements m)); auto; intros.
+symmetry; rewrite H1.
+destruct H0 as (H0,_).
+destruct H0 as (e,He); [ intuition |].
+rewrite InA_alt in He.
+destruct He as ((y,e'),(Ha1,Ha2)).
+compute in Ha1; destruct Ha1; subst e'.
+exists (y,e); split; simpl; auto.
+unfold eqb; destruct (eq_dec x y); intuition.
+rewrite <- H; rewrite H0.
+destruct H1 as (H1,_).
+destruct H1 as ((y,e),(Ha1,Ha2)); [intuition|].
+simpl in Ha2.
+unfold eqb in *; destruct (eq_dec x y); auto; try discriminate.
+exists e; rewrite InA_alt.
+exists (y,e); intuition.
+compute; auto.
+Qed.
+
+End BoolSpec.
+
+End Facts.
diff --git a/theories/FSets/FMapIntMap.v b/theories/FSets/FMapIntMap.v
new file mode 100644
index 00000000..c7681bd4
--- /dev/null
+++ b/theories/FSets/FMapIntMap.v
@@ -0,0 +1,622 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: FMapIntMap.v 8876 2006-05-30 13:43:15Z letouzey $ *)
+
+Require Import Bool.
+Require Import NArith Ndigits Ndec Nnat. 
+Require Import Allmaps.
+Require Import OrderedType.
+Require Import OrderedTypeEx.
+Require Import FMapInterface FMapList.
+
+
+Set Implicit Arguments.
+
+(** * An implementation of [FMapInterface.S] based on [IntMap] *)
+
+(** Keys are of type [N]. The main functions are directly taken from 
+  [IntMap]. Since they have no exact counterpart in [IntMap], functions 
+  [fold], [map2] and [equal] are for now obtained by translation 
+  to sorted lists. *)
+
+(** [N] is an ordered type, using not the usual order on numbers, 
+   but lexicographic ordering on bits (lower bit considered first). *) 
+
+Module NUsualOrderedType <: UsualOrderedType.
+  Definition t:=N.
+  Definition eq:=@eq N.
+  Definition eq_refl := @refl_equal t.
+  Definition eq_sym := @sym_eq t.
+  Definition eq_trans := @trans_eq t.
+
+  Definition lt p q:= Nless p q = true.
+ 
+  Definition lt_trans := Nless_trans.
+
+  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+  Proof.
+  intros; intro.
+  rewrite H0 in H.
+  red in H.
+  rewrite Nless_not_refl in H; discriminate.
+  Qed.
+
+  Definition compare : forall x y : t, Compare lt eq x y.
+  Proof.
+  intros x y.
+  destruct (Nless_total x y) as [[H|H]|H].
+  apply LT; unfold lt; auto.
+  apply GT; unfold lt; auto.
+  apply EQ; auto.
+  Qed.
+
+End NUsualOrderedType.
+ 
+
+(** The module of maps over [N] keys based on [IntMap] *)
+
+Module MapIntMap <: S with Module E:=NUsualOrderedType.
+
+  Module E:=NUsualOrderedType.
+  Module ME:=OrderedTypeFacts(E).
+  Module PE:=KeyOrderedType(E).
+
+  Definition key := N.
+
+  Definition t := Map.
+
+  Section A.
+  Variable A:Set.
+
+  Definition empty : t A := M0 A.
+ 
+  Definition is_empty (m : t A) : bool := 
+    MapEmptyp _ (MapCanonicalize _ m).
+
+  Definition find (x:key)(m: t A) : option A := MapGet _ m x.
+
+  Definition mem (x:key)(m: t A) : bool := 
+    match find x m with 
+     | Some _ => true
+     | None => false
+    end.
+
+  Definition add (x:key)(v:A)(m:t A) : t A := MapPut _ m x v.
+  
+  Definition remove (x:key)(m:t A) : t A := MapRemove _ m x.
+
+  Definition elements (m : t A) : list (N*A) := alist_of_Map _ m.
+
+  Definition MapsTo (x:key)(v:A)(m:t A) := find x m = Some v.
+
+  Definition In (x:key)(m:t A) := exists e:A, MapsTo x e m.
+
+  Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m.
+
+  Definition eq_key (p p':key*A) := E.eq (fst p) (fst p').
+      
+  Definition eq_key_elt (p p':key*A) := 
+          E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+  Definition lt_key (p p':key*A) := E.lt (fst p) (fst p').
+
+  Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None.
+  Proof.
+  unfold Empty, MapsTo.
+  intuition.
+  generalize (H a).
+  destruct (find a m); intuition.
+  elim (H0 a0); auto.
+  rewrite H in H0; discriminate.
+  Qed.
+
+  Section Spec. 
+  Variable  m m' m'' : t A.
+  Variable x y z : key.
+  Variable e e' : A.
+
+  Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
+  Proof. intros; rewrite <- H; auto. Qed.
+
+  Lemma find_1 : MapsTo x e m -> find x m = Some e.
+  Proof. unfold MapsTo; auto. Qed.
+
+  Lemma find_2 : find x m = Some e -> MapsTo x e m.
+  Proof. red; auto. Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+  rewrite Empty_alt; intros; unfold empty, find; simpl; auto.
+  Qed.
+
+  Lemma is_empty_1 : Empty m -> is_empty m = true. 
+  Proof.
+  unfold Empty, is_empty, find; intros.
+  cut (MapCanonicalize _ m = M0 _).
+  intros; rewrite H0; simpl; auto.
+  apply mapcanon_unique.
+  apply mapcanon_exists_2.
+  constructor.
+  red; red; simpl; intros.
+  rewrite <- (mapcanon_exists_1 _ m).
+  unfold MapsTo, find in *.
+  generalize (H a).
+  destruct (MapGet _ m a); auto.
+  intros; generalize (H0 a0); destruct 1; auto.
+  Qed.  
+
+  Lemma is_empty_2 : is_empty m = true -> Empty m.
+  Proof.
+  unfold Empty, is_empty, MapsTo, find; intros.
+  generalize (MapEmptyp_complete _ _ H); clear H; intros.
+  rewrite (mapcanon_exists_1 _ m).
+  rewrite H; simpl; auto.
+  discriminate.
+  Qed.
+
+  Lemma mem_1 : In x m -> mem x m = true.
+  Proof.
+  unfold In, MapsTo, mem.
+  destruct (find x m); auto.
+  destruct 1; discriminate.
+  Qed.
+
+  Lemma mem_2 : forall m x, mem x m = true -> In x m. 
+  Proof.
+  unfold In, MapsTo, mem.
+  intros.
+  destruct (find x0 m0); auto; try discriminate.
+  exists a; auto.
+  Qed.
+
+  Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
+  Proof.
+  unfold MapsTo, find, add.
+  intro H; rewrite H; clear H.
+  rewrite MapPut_semantics.
+  rewrite Neqb_correct; auto.
+  Qed.
+
+  Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+  Proof.
+  unfold MapsTo, find, add.
+  intros.
+  rewrite MapPut_semantics.
+  rewrite H0.
+  generalize (Neqb_complete x y).
+  destruct (Neqb x y); auto.
+  intros.
+  elim H; auto.
+  apply H1; auto.
+  Qed.
+
+  Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+  Proof.
+  unfold MapsTo, find, add.
+  rewrite MapPut_semantics.
+  intro H.
+  generalize (Neqb_complete x y).
+  destruct (Neqb x y); auto.
+  intros; elim H; auto.
+  apply H0; auto.
+  Qed.
+
+  Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
+  Proof. 
+  unfold In, MapsTo, find, remove.
+  rewrite MapRemove_semantics.
+  intro H.
+  rewrite H; rewrite Neqb_correct.
+  red; destruct 1; discriminate.
+  Qed.
+
+  Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+  Proof.
+  unfold MapsTo, find, remove.
+  rewrite MapRemove_semantics.
+  intros.
+  rewrite H0.
+  generalize (Neqb_complete x y).
+  destruct (Neqb x y); auto.
+  intros; elim H; apply H1; auto.
+  Qed.
+
+  Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
+  Proof. 
+  unfold MapsTo, find, remove.
+  rewrite MapRemove_semantics.
+  destruct (Neqb x y); intros; auto.
+  discriminate.
+  Qed.
+
+  Lemma alist_sorted_sort : forall l, alist_sorted A l=true -> sort lt_key l.
+  Proof.
+  induction l.
+  auto.
+  simpl.
+  destruct a.
+  destruct l.
+  auto.
+  destruct p.
+  intros; destruct (andb_prop _ _ H); auto.
+  Qed.
+
+  Lemma elements_3 : sort lt_key (elements m). 
+  Proof.
+  unfold elements.
+  apply alist_sorted_sort.
+  apply alist_of_Map_sorts.
+  Qed.
+  
+  Lemma elements_1 : 
+     MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+  Proof.
+  unfold MapsTo, find, elements.
+  rewrite InA_alt.
+  intro H.
+  exists (x,e).
+  split.
+  red; simpl; unfold E.eq; auto.
+  rewrite alist_of_Map_semantics in H.
+  generalize H.
+  set (l:=alist_of_Map A m); clearbody l; clear.
+  induction l; simpl; auto.
+  intro; discriminate.
+  destruct a; simpl; auto.
+  generalize (Neqb_complete a x).
+  destruct (Neqb a x); auto.
+  left.
+  injection H0; auto.
+  intros; f_equal; auto.
+  Qed.
+
+  Lemma elements_2 : 
+     InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+  Proof.
+  generalize elements_3.
+  unfold MapsTo, find, elements.
+  rewrite InA_alt.
+  intros H ((e0,a),(H0,H1)).
+  red in H0; simpl in H0; unfold E.eq in H0; destruct H0; subst.
+  rewrite alist_of_Map_semantics.
+  generalize H H1; clear H H1.
+  set (l:=alist_of_Map A m); clearbody l; clear.
+  induction l; simpl; auto.
+  intro; contradiction.
+  intros.
+  destruct a0; simpl.
+  inversion H1. 
+  injection H0; intros; subst.
+  rewrite Neqb_correct; auto.
+  assert (InA eq_key (e0,a) l).
+  rewrite InA_alt.
+  exists (e0,a); split; auto.
+  red; simpl; auto; red; auto.
+  generalize (PE.Sort_In_cons_1 H H2).
+  unfold PE.ltk; simpl.
+  intros H3; generalize (E.lt_not_eq H3).
+  generalize (Neqb_complete a0 e0).
+  destruct (Neqb a0 e0); auto.
+  destruct 2.
+  apply H4; auto.
+  inversion H; auto.
+  Qed.
+
+  Definition Equal cmp m m' := 
+         (forall k, In k m <-> In k m') /\ 
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+  (** unfortunately, the [MapFold] of [IntMap] isn't compatible with 
+   the FMap interface. We use a naive version for now : *)
+
+  Definition fold (B:Set)(f:key -> A -> B -> B)(m:t A)(i:B) : B := 
+    fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+
+  Lemma fold_1 :
+	forall (B:Set) (i : B) (f : key -> A -> B -> B),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+  Proof. auto. Qed.
+
+  End Spec.
+
+  Variable B : Set.
+
+  Fixpoint mapi_aux (pf:N->N)(f : N -> A -> B)(m:t A) { struct m }: t B := 
+    match m with 
+      | M0 => M0 _ 
+      | M1 x y => M1 _ x (f (pf x) y)
+      | M2 m0 m1 =>  M2 _ (mapi_aux (fun n => pf (Ndouble n)) f m0)
+                                         (mapi_aux (fun n => pf (Ndouble_plus_one n)) f m1)
+    end.
+    
+  Definition mapi := mapi_aux (fun n => n).
+
+  Definition map (f:A->B) := mapi (fun _ => f).
+ 
+  End A.
+
+  Lemma mapi_aux_1 : forall (elt elt':Set)(m: t elt)(pf:N->N)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f (pf y) e) (mapi_aux pf f m).
+  Proof.
+  unfold MapsTo; induction m; simpl; auto.
+  inversion 1.
+
+  intros.
+  exists x; split; [red; auto|].
+  generalize (Neqb_complete a x).
+  destruct (Neqb a x); try discriminate.
+  injection H; intros; subst; auto.
+  rewrite H1; auto.
+
+  intros.
+  exists x; split; [red;auto|].
+  destruct x; simpl in *.
+  destruct (IHm1 (fun n : N => pf (Ndouble n)) _ _ f H) as (y,(Hy,Hy')).
+  rewrite Hy in Hy'; simpl in Hy'; auto.
+  destruct p; simpl in *.
+  destruct (IHm2 (fun n : N => pf (Ndouble_plus_one n)) _ _ f H) as (y,(Hy,Hy')).
+  rewrite Hy in Hy'; simpl in Hy'; auto.
+  destruct (IHm1 (fun n : N => pf (Ndouble n)) _ _ f H) as (y,(Hy,Hy')).
+  rewrite Hy in Hy'; simpl in Hy'; auto.
+  destruct (IHm2 (fun n : N => pf (Ndouble_plus_one n)) _ _ f H) as (y,(Hy,Hy')).
+  rewrite Hy in Hy'; simpl in Hy'; auto.
+  Qed.
+
+  Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+  Proof.
+  intros elt elt' m; exact (mapi_aux_1 (fun n => n)).
+  Qed.
+
+  Lemma mapi_aux_2 : forall (elt elt':Set)(m: t elt)(pf:N->N)(x:key)
+        (f:key->elt->elt'), In x (mapi_aux pf f m) -> In x m.
+  Proof.
+  unfold In, MapsTo.
+  induction m; simpl in *.
+  intros pf x f (e,He); inversion He.
+  intros pf x f (e,He).
+  exists a0.
+  destruct (Neqb a x); try discriminate; auto.
+  intros pf x f (e,He).
+  destruct x; [|destruct p]; eauto.
+  Qed.
+
+  Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+  Proof.
+  intros elt elt' m; exact (mapi_aux_2 m (fun n => n)).
+  Qed.
+
+  Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+  Proof.
+  unfold map; intros.
+  destruct (@mapi_1 _ _ m x e (fun _ => f)) as (e',(_,H0)); auto.
+  Qed.
+
+  Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
+        In x (map f m) -> In x m.
+  Proof.
+  unfold map; intros.
+  eapply mapi_2; eauto.
+  Qed.
+
+  Module L := FMapList.Raw E.
+
+  (** Not exactly pretty nor perfect, but should suffice as a first naive implem. 
+    Anyway, map2 isn't in Ocaml...
+  *)
+
+  Definition anti_elements (A:Set)(l:list (key*A)) := L.fold (@add _) l (empty _).
+
+  Definition map2 (A B C:Set)(f:option A->option B -> option C)(m:t A)(m':t B) : t C := 
+    anti_elements (L.map2 f (elements m) (elements m')).
+
+  Lemma add_spec : forall (A:Set)(m:t A) x y e, 
+    find x (add y e m) = if ME.eq_dec x y then Some e else find x m.
+  Proof.
+  intros.
+  destruct (ME.eq_dec x y).
+  apply find_1.
+  eapply MapsTo_1 with y; eauto.
+  red; auto.
+  apply add_1; auto.
+  red; auto.
+  case_eq (find x m); intros.
+  apply find_1.
+  apply add_2; unfold E.eq in *; auto.
+  case_eq (find x (add y e m)); auto; intros.
+  rewrite <- H; symmetry.
+  apply find_1; auto.
+  apply (@add_3 _ m y x a e); unfold E.eq in *; auto.
+  Qed.
+  
+  Lemma anti_elements_mapsto_aux : forall (A:Set)(l:list (key*A)) m k e,
+    NoDupA (eq_key (A:=A)) l -> 
+    (forall x, L.PX.In x l -> In x m -> False) -> 
+    (MapsTo k e (L.fold (@add _) l m) <-> L.PX.MapsTo k e l \/ MapsTo k e m).
+  Proof.
+  induction l. 
+  simpl; auto.
+  intuition.
+  inversion H2.
+  simpl; destruct a; intros.
+  rewrite IHl; clear IHl.
+  inversion H; auto.
+  intros.
+  inversion_clear H.
+  assert (~E.eq x k).
+   swap H3.
+   destruct H1.
+   apply InA_eqA with (x,x0); eauto.
+   unfold eq_key, E.eq; eauto.
+   unfold eq_key, E.eq; congruence.
+  apply (H0 x).
+  destruct H1; exists x0; auto.
+  revert H2.
+  unfold In.
+  intros (e',He').
+  exists e'; apply (@add_3 _ m k x e' a); unfold E.eq; auto.
+  intuition.
+  red in H2.
+  rewrite add_spec in H2; auto.
+  destruct (ME.eq_dec k0 k).
+  inversion_clear H2; subst; auto.
+  right; apply find_2; auto.
+  inversion_clear H2; auto.
+  compute in H1; destruct H1.
+  subst; right; apply add_1; auto.
+  red; auto.
+  inversion_clear H.
+  destruct (ME.eq_dec k0 k).
+  unfold E.eq in *; subst.
+  destruct (H0 k); eauto.
+  red; eauto.
+  right; apply add_2; unfold E.eq in *; auto.
+  Qed.
+  
+  Lemma anti_elements_mapsto : forall (A:Set) l k e, NoDupA (eq_key (A:=A)) l ->
+    (MapsTo k e (anti_elements l) <-> L.PX.MapsTo k e l).
+  Proof. 
+  intros. 
+  unfold anti_elements.
+  rewrite anti_elements_mapsto_aux; auto; unfold empty; auto.
+  inversion 2.
+  inversion H2.
+  intuition.
+  inversion H1.
+  Qed.
+  
+  Lemma find_anti_elements : forall (A:Set)(l: list (key*A)) x, sort (@lt_key _) l -> 
+    find x (anti_elements l) = L.find x l.
+  Proof.
+  intros.
+  case_eq (L.find x l); intros.
+  apply find_1.
+  rewrite anti_elements_mapsto.
+  apply L.PX.Sort_NoDupA; auto.
+  apply L.find_2; auto.
+  case_eq (find x (anti_elements l)); auto; intros.
+  rewrite <- H0; symmetry.
+  apply L.find_1; auto.
+  rewrite <- anti_elements_mapsto.
+  apply L.PX.Sort_NoDupA; auto.
+  apply find_2; auto.
+  Qed.
+
+  Lemma find_elements : forall (A:Set)(m: t A) x,  
+    L.find x (elements m) = find x m.
+  Proof. 
+  intros.
+  case_eq (find x m); intros.
+  apply L.find_1.
+  apply elements_3; auto.
+  red; apply elements_1.
+  apply find_2; auto.
+  case_eq (L.find x (elements m)); auto; intros.
+  rewrite <- H; symmetry.
+  apply find_1; auto.
+  apply elements_2.
+  apply L.find_2; auto.
+  Qed.
+  
+  Lemma elements_in : forall (A:Set)(s:t A) x, L.PX.In x (elements s) <-> In x s.
+  Proof.
+   intros.
+   unfold L.PX.In, In.
+   firstorder.
+   exists x0.
+   red; rewrite <- find_elements; auto.
+   apply L.find_1; auto.
+   apply elements_3.
+   exists x0.
+   apply L.find_2.
+   rewrite find_elements; auto.
+  Qed.
+  
+  Lemma map2_1 : forall (A B C:Set)(m: t A)(m': t B)(x:key)
+    (f:option A->option B ->option C), 
+    In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m').       
+  Proof. 
+  unfold map2; intros.
+  rewrite find_anti_elements; auto.
+  rewrite <- find_elements; auto.
+  rewrite <- find_elements; auto.
+  apply L.map2_1; auto.
+  apply elements_3; auto.
+  apply elements_3; auto.
+  do 2 rewrite elements_in; auto.
+  apply L.map2_sorted; auto.
+  apply elements_3; auto.
+  apply elements_3; auto.
+  Qed.
+  
+  Lemma map2_2 : forall (A B C: Set)(m: t A)(m': t B)(x:key)
+      (f:option A->option B ->option C), 
+    In x (map2 f m m') -> In x m \/ In x m'.
+  Proof.
+  unfold map2; intros.
+  do 2 rewrite <- elements_in.
+  apply L.map2_2 with (f:=f); auto.
+  apply elements_3; auto.
+  apply elements_3; auto.
+  destruct H.
+  exists x0.
+  rewrite <- anti_elements_mapsto; auto.
+  apply L.PX.Sort_NoDupA; auto.
+  apply L.map2_sorted; auto.
+  apply elements_3; auto.
+  apply elements_3; auto.
+  Qed.
+
+  (** same trick for [equal] *)
+
+  Definition equal (A:Set)(cmp:A -> A -> bool)(m m' : t A) : bool := 
+    L.equal cmp (elements m) (elements m').
+  
+  Lemma equal_1 : 
+    forall (A:Set)(m: t A)(m': t A)(cmp: A -> A -> bool), 
+    Equal cmp m m' -> equal cmp m m' = true. 
+  Proof.
+  unfold equal, Equal.
+  intros.
+  apply L.equal_1.
+  apply elements_3.
+  apply elements_3.
+  unfold L.Equal.
+  destruct H.
+  split; intros.
+  do 2 rewrite elements_in; auto.
+  apply (H0 k); 
+    red; rewrite <- find_elements; apply L.find_1; auto; 
+    apply elements_3.
+  Qed.  
+
+  Lemma equal_2 : 
+    forall (A:Set)(m: t A)(m': t A)(cmp: A -> A -> bool), 
+    equal cmp m m' = true -> Equal cmp m m'.
+  Proof.
+  unfold equal, Equal.
+  intros.
+  destruct (L.equal_2 (elements_3 m) (elements_3 m') H); clear H.
+  split.
+  intros; do 2 rewrite <- elements_in; auto.
+  intros; apply (H1 k); 
+    apply L.find_2; rewrite find_elements;auto.
+  Qed.
+
+End MapIntMap.
+
diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v
index 2d083d5b..c671ba82 100644
--- a/theories/FSets/FMapList.v
+++ b/theories/FSets/FMapList.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapList.v 8667 2006-03-28 11:59:44Z letouzey $ *)
+(* $Id: FMapList.v 8899 2006-06-06 11:09:43Z jforest $ *)
 
 (** * Finite map library *)
 
@@ -26,7 +26,7 @@ Module Raw (X:OrderedType).
 
 Module E := X.
 Module MX := OrderedTypeFacts X.
-Module PX := PairOrderedType X.
+Module PX := KeyOrderedType X.
 Import MX. 
 Import PX. 
 
@@ -36,7 +36,7 @@ Definition t (elt:Set) := list (X.t * elt).
 Section Elt.
 Variable elt : Set.
 
-(* Now in PairOrderedtype: 
+(* Now in KeyOrderedType: 
 Definition eqk (p p':key*elt) := X.eq (fst p) (fst p').
 Definition eqke (p p':key*elt) := 
         X.eq (fst p) (fst p') /\ (snd p) = (snd p').
@@ -96,7 +96,7 @@ Qed.
 
 (** * [mem] *)
 
-Fixpoint mem (k : key) (s : t elt) {struct s} : bool :=
+Function mem (k : key) (s : t elt) {struct s} : bool :=
  match s with
   | nil => false
   | (k',_) :: l =>
@@ -110,33 +110,33 @@ Fixpoint mem (k : key) (s : t elt) {struct s} : bool :=
 Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true.
 Proof.  
  intros m Hm x; generalize Hm; clear Hm.      
- functional induction mem x m;intros sorted belong1;trivial.
+ functional induction (mem x m);intros sorted belong1;trivial.
  
  inversion belong1. inversion H.
  
- absurd (In k ((k', e) :: l));try assumption.
- apply Sort_Inf_NotIn with e;auto.
+ absurd (In x ((k', _x) :: l));try assumption.
+ apply Sort_Inf_NotIn with _x;auto.
 
- apply H.
+ apply IHb.
  elim (sort_inv sorted);auto.
  elim (In_inv belong1);auto.
  intro abs.
- absurd (X.eq k k');auto.
+ absurd (X.eq x k');auto.
 Qed. 
 
 Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. 
 Proof.
  intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
- functional induction mem x m; intros sorted hyp;try ((inversion hyp);fail).
- exists e; auto. 
- induction H; auto.
- exists x; auto.
+ functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail).
+ exists _x; auto. 
+ induction IHb; auto.
+ exists x0; auto.
  inversion_clear sorted; auto.
 Qed.
 
 (** * [find] *)
 
-Fixpoint find (k:key) (s: t elt) {struct s} : option elt :=
+Function find (k:key) (s: t elt) {struct s} : option elt :=
  match s with
   | nil => None
   | (k',x)::s' => 
@@ -150,31 +150,31 @@ Fixpoint find (k:key) (s: t elt) {struct s} : option elt :=
 Lemma find_2 :  forall m x e, find x m = Some e -> MapsTo x e m.
 Proof.
  intros m x. unfold PX.MapsTo.
- functional induction find x m;simpl;intros e' eqfind; inversion eqfind; auto.
+ functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto.
 Qed.
 
 Lemma find_1 :  forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. 
 Proof.
  intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
- functional induction find x m;simpl; subst; try clear H_eq_1.
+ functional induction (find x m);simpl; subst; try clear H_eq_1.
 
  inversion 2.
 
  inversion_clear 2.
- compute in H0; destruct H0; order.
- generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
+ clear H0;compute in H1; destruct H1;order.
+ clear H0;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H1)); compute; order.
 
- inversion_clear 2.
+ clear H0;inversion_clear 2.
  compute in H0; destruct H0; intuition congruence. 
  generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
  
- do 2 inversion_clear 1; auto.
- compute in H3; destruct H3; order.
+ clear H0; do 2 inversion_clear 1; auto.
+ compute in H2; destruct H2; order.
 Qed.
 
 (** * [add] *)
 
-Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
+Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
  match s with
   | nil => (k,x) :: nil
   | (k',y) :: l =>
@@ -189,7 +189,7 @@ Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
 Proof.
  intros m x y e; generalize y; clear y.
  unfold PX.MapsTo.
- functional induction add x e m;simpl;auto.
+ functional induction (add x e m);simpl;auto.
 Qed.
 
 Lemma add_2 : forall m x y e e', 
@@ -197,25 +197,29 @@ Lemma add_2 : forall m x y e e',
 Proof.
  intros m x  y e e'. 
  generalize y e; clear y e; unfold PX.MapsTo.
- functional induction add x e' m;simpl;auto; clear H_eq_1.
- intros y' e' eqky';  inversion_clear 1; destruct H0; simpl in *.
+ functional induction (add x e' m) ;simpl;auto;  clear H0.
+ subst;auto.
+
+ intros y' e'' eqky';  inversion_clear 1;  destruct H0; simpl in *.
  order.
  auto.
  auto.
- intros y' e' eqky'; inversion_clear 1; intuition.
+ intros y' e'' eqky'; inversion_clear 1; intuition.
 Qed.
   
+
 Lemma add_3 : forall m x y e e',
   ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
 Proof.
  intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
- functional induction add x e' m;simpl; intros.
- apply (In_inv_3 H0); compute; auto.
+ functional induction (add x e' m);simpl; intros.
  apply (In_inv_3 H0); compute; auto.
- constructor 2; apply (In_inv_3 H0); compute; auto. 
+ apply (In_inv_3 H1); compute; auto.
+ constructor 2; apply (In_inv_3 H1); compute; auto. 
  inversion_clear H1; auto.
 Qed.
 
+
 Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), 
   Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m).
 Proof.
@@ -242,7 +246,7 @@ Qed.
 
 (** * [remove] *)
 
-Fixpoint remove (k : key) (s : t elt) {struct s} : t elt :=
+Function remove (k : key) (s : t elt) {struct s} : t elt :=
  match s with
   | nil => nil
   | (k',x) :: l =>
@@ -256,30 +260,36 @@ Fixpoint remove (k : key) (s : t elt) {struct s} : t elt :=
 Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m).
 Proof.
  intros m Hm x y; generalize Hm; clear Hm.
- functional induction remove x m;simpl;intros;subst;try clear H_eq_1.
+ functional induction (remove x m);simpl;intros;subst.
  
  red; inversion 1; inversion H1.
 
- apply Sort_Inf_NotIn with x; auto.
- constructor; compute; order.
+ apply Sort_Inf_NotIn with x0; auto.
+ clear H0;constructor; compute; order.
  
- inversion_clear Hm.
- apply Sort_Inf_NotIn with x; auto. 
- apply Inf_eq with (k',x);auto; compute; apply X.eq_trans with k; auto.
+ clear H0;inversion_clear Hm.
+ apply Sort_Inf_NotIn with x0; auto. 
+ apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto.
 
- inversion_clear Hm.
- assert (notin:~ In y (remove k l)) by auto.
- intros (x0,abs).
+ clear H0;inversion_clear Hm.
+ assert (notin:~ In y (remove x l)) by auto.
+ intros (x1,abs).
  inversion_clear abs. 
- compute in H3; destruct H3; order.
- apply notin; exists x0; auto.
+ compute in H2; destruct H2; order.
+ apply notin; exists x1; auto.
 Qed.
 
+
 Lemma remove_2 : forall m (Hm:Sort m) x y e, 
   ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
 Proof.
  intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
- functional induction remove x m;auto; try clear H_eq_1.
+ functional induction (remove x m);subst;auto; 
+   match goal with 
+     | [H: X.compare _ _ = _ |- _ ] => clear H
+     | _ => idtac
+   end.
+
  inversion_clear 3; auto.
  compute in H1; destruct H1; order.
  
@@ -290,7 +300,7 @@ Lemma remove_3 : forall m (Hm:Sort m) x y e,
   MapsTo y e (remove x m) -> MapsTo y e m.
 Proof.
  intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
- functional induction remove x m;auto.
+ functional induction (remove x m);subst;auto.
  inversion_clear 1; inversion_clear 1; auto.
 Qed.
 
@@ -341,8 +351,7 @@ Qed.
 
 (** * [fold] *)
 
-Fixpoint fold (A:Set)(f:key->elt->A->A)(m:t elt) {struct m} : A -> A :=
-  fun acc => 
+Function fold (A:Set)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} :  A :=
   match m with
    | nil => acc
    | (k,e)::m' => fold f m' (f k e acc)
@@ -351,12 +360,12 @@ Fixpoint fold (A:Set)(f:key->elt->A->A)(m:t elt) {struct m} : A -> A :=
 Lemma fold_1 : forall m (A:Set)(i:A)(f:key->elt->A->A),
   fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
 Proof. 
- intros; functional induction fold A f m i; auto.
+ intros; functional induction (fold f m i); auto.
 Qed.
 
 (** * [equal] *)
 
-Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := 
+Function equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := 
   match m, m' with 
    | nil, nil => true
    | (x,e)::l, (x',e')::l' => 
@@ -375,56 +384,52 @@ Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp,
   Equal cmp m m' -> equal cmp m m' = true. 
 Proof. 
  intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
- functional induction equal cmp m m'; simpl; auto; unfold Equal;
- intuition; subst; try clear H_eq_3.
+ functional induction (equal cmp m m'); simpl; subst;auto; unfold Equal;
+ intuition; subst;   match goal with 
+     | [H: X.compare _ _ = _ |- _ ] => clear H
+     | _ => idtac
+   end.
 
- destruct p as (k,e).
- destruct (H0 k).
- destruct H2.
- exists e; auto.
- inversion H2.
 
- destruct (H0 x).
- destruct H.
- exists e; auto.
- inversion H.
 
- destruct (H0 x).
- assert (In x ((x',e')::l')). 
-  apply H; auto.
-  exists e; auto.
- destruct (In_inv H3).
- order.
- inversion_clear Hm'.
- assert (Inf (x,e) l').
- apply Inf_lt with (x',e'); auto.
- elim (Sort_Inf_NotIn H5 H7 H4).
- 
- assert (cmp e e' = true).
+ assert (cmp_e_e':cmp e e' = true).
   apply H2 with x; auto.
- rewrite H0; simpl.
- apply H; auto.
+ rewrite cmp_e_e'; simpl.
+ apply IHb; auto.
  inversion_clear Hm; auto.
  inversion_clear Hm'; auto.
  unfold Equal; intuition.
- destruct (H1 k).
+ destruct (H0 k).
  assert (In k ((x,e) ::l)).
-  destruct H3 as (e'', hyp); exists e''; auto.
- destruct (In_inv (H4 H6)); auto.
+  destruct H as (e'', hyp); exists e''; auto.
+ destruct (In_inv (H1 H4)); auto.
  inversion_clear Hm.
- elim (Sort_Inf_NotIn H8 H9).
- destruct H3 as (e'', hyp); exists e''; auto.
+ elim (Sort_Inf_NotIn H6 H7).
+ destruct H as (e'', hyp); exists e''; auto.
  apply MapsTo_eq with k; auto; order.
- destruct (H1 k).
+ destruct (H0 k).
  assert (In k ((x',e') ::l')).
-  destruct H3 as (e'', hyp); exists e''; auto.
- destruct (In_inv (H5 H6)); auto.
+  destruct H as (e'', hyp); exists e''; auto.
+ destruct (In_inv (H3 H4)); auto.
  inversion_clear Hm'.
- elim (Sort_Inf_NotIn H8 H9).
- destruct H3 as (e'', hyp); exists e''; auto.
+ elim (Sort_Inf_NotIn H6 H7).
+ destruct H as (e'', hyp); exists e''; auto.
  apply MapsTo_eq with k; auto; order.
  apply H2 with k; destruct (eq_dec x k); auto.
 
+
+ destruct (X.compare x x'); try contradiction;clear H2.
+ destruct (H0 x).
+ assert (In x ((x',e')::l')). 
+  apply H; auto.
+  exists e; auto.
+ destruct (In_inv H3).
+ order.
+ inversion_clear Hm'.
+ assert (Inf (x,e) l').
+ apply Inf_lt with (x',e'); auto.
+ elim (Sort_Inf_NotIn H5 H7 H4).
+
  destruct (H0 x').
  assert (In x' ((x,e)::l)). 
   apply H2; auto.
@@ -435,43 +440,70 @@ Proof.
  assert (Inf (x',e') l).
   apply Inf_lt with (x,e); auto.
  elim (Sort_Inf_NotIn H5 H7 H4).
+
+ destruct m;
+ destruct m';try contradiction.
+ 
+ clear H1;destruct p as (k,e).
+ destruct (H0 k).
+ destruct H1.
+ exists e; auto.
+ inversion H1.
+
+ destruct p as (x,e).
+ destruct (H0 x).
+ destruct H.
+ exists e; auto.
+ inversion H.
+
+ destruct p;destruct p0;contradiction.
 Qed.
 
+
 Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, 
   equal cmp m m' = true -> Equal cmp m m'.
 Proof.
  intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
- functional induction equal cmp m m'; simpl; auto; unfold Equal; 
-  intuition; try discriminate; subst; try clear H_eq_3; 
-  try solve [inversion H0]; destruct (andb_prop _ _ H0); clear H0; 
-  inversion_clear Hm; inversion_clear Hm'.
-
- destruct (H H0 H5 H3).
- destruct (In_inv H1).
+ functional induction (equal cmp m m'); simpl; subst;auto; unfold Equal; 
+  intuition; try discriminate; subst; match goal with 
+     | [H: X.compare _ _ = _ |- _ ] => clear H
+     | _ => idtac
+   end. 
+
+ inversion H0.
+
+ inversion_clear Hm;inversion_clear Hm'.
+ destruct (andb_prop _ _ H); clear H. 
+ destruct (IHb H1 H3 H6).
+ destruct (In_inv H0).
  exists e'; constructor; split; trivial; apply X.eq_trans with x; auto.
- destruct (H7 k).
- destruct (H10 H9) as (e'',hyp).
+ destruct (H k).
+ destruct (H9 H8) as (e'',hyp).
  exists e''; auto.
 
- destruct (H H0 H5 H3).
- destruct (In_inv H1).
+ inversion_clear Hm;inversion_clear Hm'.
+ destruct (andb_prop _ _ H); clear H. 
+ destruct (IHb H1 H3 H6).
+ destruct (In_inv H0).
  exists e; constructor; split; trivial; apply X.eq_trans with x'; auto.
- destruct (H7 k).
- destruct (H11 H9) as (e'',hyp).
+ destruct (H k).
+ destruct (H10 H8) as (e'',hyp).
  exists e''; auto.
 
- destruct (H H0 H6 H4).
- inversion_clear H1.
- destruct H10; simpl in *; subst.
+ inversion_clear Hm;inversion_clear Hm'.
+ destruct (andb_prop _ _ H); clear H. 
+ destruct (IHb H1 H4 H7).
+ inversion_clear H0.
+ destruct H9; simpl in *; subst.
  inversion_clear H2. 
- destruct H10; simpl in *; subst; auto.
- elim (Sort_Inf_NotIn H6 H7).
+ destruct H9; simpl in *; subst; auto.
+ elim (Sort_Inf_NotIn H4 H5).
  exists e'0; apply MapsTo_eq with k; auto; order.
  inversion_clear H2. 
- destruct H1; simpl in *; subst; auto.
- elim (Sort_Inf_NotIn H0 H5).
- exists e1; apply MapsTo_eq with k; auto; order.
- apply H9 with k; auto.
+ destruct H0; simpl in *; subst; auto.
+ elim (Sort_Inf_NotIn H1 H3).
+ exists e0; apply MapsTo_eq with k; auto; order.
+ apply H8 with k; auto.
 Qed. 
 
 (** This lemma isn't part of the spec of [Equal], but is used in [FMapAVL] *)
@@ -791,7 +823,7 @@ Proof.
  exact (combine_lelistA _ H0 H1). 
  inversion_clear Hm; inversion_clear Hm'.
  constructor; auto.
- assert (lelistA (ltk (elt:=elt')) (k, e') m') by apply Inf_eq with (k',e'); auto.
+ assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto).
  exact (combine_lelistA _ H0 H3). 
  inversion_clear Hm; inversion_clear Hm'.
  constructor; auto.
@@ -1006,84 +1038,126 @@ Module Make (X: OrderedType) <: S with Module E := X.
 Module Raw := Raw X. 
 Module E := X.
 
-Definition key := X.t.
+Definition key := E.t.
 
 Record slist (elt:Set) : Set :=  
   {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}.
-Definition t (elt:Set) := slist elt. 
+Definition t (elt:Set) : Set := slist elt. 
 
 Section Elt. 
  Variable elt elt' elt'':Set. 
 
  Implicit Types m : t elt.
-
- Definition empty := Build_slist (Raw.empty_sorted elt).
- Definition is_empty m := Raw.is_empty m.(this).
- Definition add x e m := Build_slist (Raw.add_sorted m.(sorted) x e).
- Definition find x m := Raw.find x m.(this).
- Definition remove x m := Build_slist (Raw.remove_sorted m.(sorted) x). 
- Definition mem x m := Raw.mem x m.(this).
+ Implicit Types x y : key. 
+ Implicit Types e : elt.
+
+ Definition empty : t elt := Build_slist (Raw.empty_sorted elt).
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := Build_slist (Raw.add_sorted m.(sorted) x e).
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). 
+ Definition mem x m : bool := Raw.mem x m.(this).
  Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f).
- Definition mapi f m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f).
+ Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f).
  Definition map2 f m (m':t elt') : t elt'' := 
- Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)).
- Definition elements m := @Raw.elements elt m.(this).
- Definition fold A f m i := @Raw.fold elt A f m.(this) i.
- Definition equal cmp m m' := @Raw.equal elt cmp m.(this) m'.(this).
-
- Definition MapsTo x e m := Raw.PX.MapsTo x e m.(this).
- Definition In x m := Raw.PX.In x m.(this).
- Definition Empty m := Raw.Empty m.(this).
- Definition Equal cmp m m' := @Raw.Equal elt cmp m.(this) m'.(this).
-
- Definition eq_key := Raw.PX.eqk.
- Definition eq_key_elt := Raw.PX.eqke.
- Definition lt_key := Raw.PX.ltk.
-
- Definition MapsTo_1 m := @Raw.PX.MapsTo_eq elt m.(this).
-
- Definition mem_1 m := @Raw.mem_1 elt m.(this) m.(sorted).
- Definition mem_2 m := @Raw.mem_2 elt m.(this) m.(sorted).
-
- Definition empty_1 := @Raw.empty_1.
-
- Definition is_empty_1 m := @Raw.is_empty_1 elt m.(this).
- Definition is_empty_2 m := @Raw.is_empty_2 elt m.(this).
-
- Definition add_1 m := @Raw.add_1 elt m.(this).
- Definition add_2 m := @Raw.add_2 elt m.(this).
- Definition add_3 m := @Raw.add_3 elt m.(this).
-
- Definition remove_1 m := @Raw.remove_1 elt m.(this) m.(sorted).
- Definition remove_2 m := @Raw.remove_2 elt m.(this) m.(sorted).
- Definition remove_3 m := @Raw.remove_3 elt m.(this) m.(sorted).
-
- Definition find_1 m := @Raw.find_1 elt m.(this) m.(sorted).
- Definition find_2 m := @Raw.find_2 elt m.(this).
-
- Definition elements_1 m := @Raw.elements_1 elt m.(this). 
- Definition elements_2 m := @Raw.elements_2 elt m.(this). 
- Definition elements_3 m := @Raw.elements_3 elt m.(this) m.(sorted). 
-
- Definition fold_1 m := @Raw.fold_1 elt m.(this).
-
- Definition map_1 m := @Raw.map_1 elt elt' m.(this).
- Definition map_2 m := @Raw.map_2 elt elt' m.(this).
-
- Definition mapi_1 m := @Raw.mapi_1 elt elt' m.(this).
- Definition mapi_2 m := @Raw.mapi_2 elt elt' m.(this).
-
- Definition map2_1 m (m':t elt') x f := 
-  @Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x.
- Definition map2_2 m (m':t elt') x f := 
-  @Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x.
-
- Definition equal_1 m m' := 
-  @Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted).
- Definition equal_2 m m' := 
-  @Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted).
+   Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)).
+ Definition elements m : list (key*elt) := @Raw.elements elt m.(this).
+ Definition fold (A:Set)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i.
+ Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this).
+
+ Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.PX.In x m.(this).
+ Definition Empty m : Prop := Raw.Empty m.(this).
+ Definition Equal cmp m m' : Prop := @Raw.Equal elt cmp m.(this) m'.(this).
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt.
+ Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt.
+
+ Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed.
+
+ Lemma mem_1 : forall m x, In x m -> mem x m = true.
+ Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(sorted)). Qed.
+ Lemma mem_2 : forall m x, mem x m = true -> In x m.
+ Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(sorted)). Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact (@Raw.empty_1 elt). Qed.
+
+ Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+ Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed.
+ Lemma is_empty_2 :  forall m, is_empty m = true -> Empty m.
+ Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed.
+
+ Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
+ Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed.
+ Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+ Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed.
+ Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed.
+
+ Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
+ Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(sorted)). Qed.
+ Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+ Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(sorted)). Qed.
+ Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(sorted)). Qed.
+
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. 
+ Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(sorted)). Qed.
+ Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed.
+
+ Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+ Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed.
+ Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed.
+ Lemma elements_3 : forall m, sort lt_key (elements m).  
+ Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed.
+
+ Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed.
+
+ Lemma equal_1 : forall m m' cmp, Equal cmp m m' -> equal cmp m m' = true. 
+ Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed.
+ Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equal cmp m m'.
+ Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed.
 
  End Elt.
+ 
+ Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+ Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed.
+ Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
+        In x (map f m) -> In x m. 
+ Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed.
+
+ Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+ Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed.
+ Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+ Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed.
+
+ Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+	In x m \/ In x m' -> 
+        find x (map2 f m m') = f (find x m) (find x m').       
+ Proof. 
+ intros elt elt' elt'' m m' x f; 
+ exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
+ Qed.
+ Lemma map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+        In x (map2 f m m') -> In x m \/ In x m'.
+ Proof. 
+ intros elt elt' elt'' m m' x f;  
+ exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
+ Qed.
+
 End Make.
 
 Module Make_ord (X: OrderedType)(D : OrderedType) <: 
diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v
new file mode 100644
index 00000000..dcb7fb49
--- /dev/null
+++ b/theories/FSets/FMapPositive.v
@@ -0,0 +1,1153 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: FMapPositive.v 8773 2006-04-29 14:31:32Z letouzey $ *)
+
+Require Import ZArith.
+Require Import OrderedType.
+Require Import FMapInterface.
+
+Set Implicit Arguments.
+
+Open Scope positive_scope.
+
+(** * An implementation of [FMapInterface.S] for positive keys. *)
+
+(** This file is an adaptation to the [FMap] framework of a work by 
+  Xavier Leroy and Sandrine Blazy (used for building certified compilers).
+  Keys are of type [positive], and maps are binary trees: the sequence 
+  of binary digits of a positive number corresponds to a path in such a tree.
+  This is quite similar to the [IntMap] library, except that no path compression 
+  is implemented, and that the current file is simple enough to be 
+  self-contained. *)
+
+(** Even if [positive] can be seen as an ordered type with respect to the 
+  usual order (see [OrderedTypeEx]), we use here a lexicographic order 
+  over bits, which is more natural here (lower bits are considered first). *)
+
+Module PositiveOrderedTypeBits <: OrderedType.
+  Definition t:=positive.
+  Definition eq:=@eq positive.
+
+  Fixpoint bits_lt (p q:positive) { struct p } : Prop := 
+   match p, q with 
+   | xH, xI _ => True
+   | xH, _ => False
+   | xO p, xO q => bits_lt p q
+   | xO _, _ => True
+   | xI p, xI q => bits_lt p q
+   | xI _, _ => False
+   end.
+
+  Definition lt:=bits_lt.
+
+  Lemma eq_refl : forall x : t, eq x x.
+  Proof. red; auto. Qed.
+
+  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
+  Proof. red; auto. Qed.
+
+  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
+  Proof. red; intros; transitivity y; auto. Qed.
+
+  Lemma bits_lt_trans : forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
+  Proof.
+  induction x.
+  induction y; destruct z; simpl; eauto; intuition.
+  induction y; destruct z; simpl; eauto; intuition.
+  induction y; destruct z; simpl; eauto; intuition.
+  Qed.
+ 
+  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
+  Proof. 
+  exact bits_lt_trans.
+  Qed.
+
+  Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
+  Proof.
+  induction x; simpl; auto.
+  Qed.
+
+  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+  Proof.
+  intros; intro.
+  rewrite <- H0 in H; clear H0 y.
+  unfold lt in H.
+  exact (bits_lt_antirefl x H).
+  Qed.
+
+  Definition compare : forall x y : t, Compare lt eq x y.
+  Proof.
+  induction x; destruct y.
+  (* I I *)
+  destruct (IHx y).
+  apply LT; auto.
+  apply EQ; rewrite e; red; auto.
+  apply GT; auto.
+  (* I O *)
+  apply GT; simpl; auto.
+  (* I H *)
+  apply GT; simpl; auto.
+  (* O I *)
+  apply LT; simpl; auto.
+  (* O O *)
+  destruct (IHx y).
+  apply LT; auto.
+  apply EQ; rewrite e; red; auto.
+  apply GT; auto.
+  (* O H *) 
+  apply LT; simpl; auto.
+  (* H I *)
+  apply LT; simpl; auto.
+  (* H O *)
+  apply GT; simpl; auto.
+  (* H H *)
+  apply EQ; red; auto.
+  Qed.
+
+End PositiveOrderedTypeBits.
+
+(** Other positive stuff *)
+
+Lemma peq_dec (x y: positive): {x = y} + {x <> y}.
+Proof.
+  intros. case_eq ((x ?= y) Eq); intros.
+  left. apply Pcompare_Eq_eq; auto.
+  right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate.
+  right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate.
+Qed.
+ 
+Fixpoint append (i j : positive) {struct i} : positive :=
+    match i with
+      | xH => j
+      | xI ii => xI (append ii j)
+      | xO ii => xO (append ii j)
+    end.
+
+Lemma append_assoc_0 : 
+  forall (i j : positive), append i (xO j) = append (append i (xO xH)) j.
+Proof.
+ induction i; intros; destruct j; simpl;
+ try rewrite (IHi (xI j));
+ try rewrite (IHi (xO j));
+ try rewrite <- (IHi xH);
+ auto.
+Qed.
+
+Lemma append_assoc_1 : 
+  forall (i j : positive), append i (xI j) = append (append i (xI xH)) j.
+Proof.
+ induction i; intros; destruct j; simpl;
+ try rewrite (IHi (xI j));
+ try rewrite (IHi (xO j));
+ try rewrite <- (IHi xH);
+ auto.
+Qed.
+
+Lemma append_neutral_r : forall (i : positive), append i xH = i.
+Proof.
+ induction i; simpl; congruence.
+Qed.
+
+Lemma append_neutral_l : forall (i : positive), append xH i = i.
+Proof.
+ simpl; auto.
+Qed.
+ 
+
+(** The module of maps over positive keys *)
+
+Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
+
+  Module E:=PositiveOrderedTypeBits.
+
+  Definition key := positive.
+
+  Inductive tree (A : Set) : Set :=
+    | Leaf : tree A
+    | Node : tree A -> option A -> tree A -> tree A.
+
+  Definition t := tree.
+
+  Section A.
+  Variable A:Set.
+
+  Implicit Arguments Leaf [A].
+
+  Definition empty : t A := Leaf.
+ 
+  Fixpoint is_empty (m : t A) {struct m} : bool := 
+   match m with 
+    | Leaf => true
+    | Node l None r => (is_empty l) && (is_empty r)
+    | _ => false
+   end.
+
+  Fixpoint find (i : positive) (m : t A) {struct i} : option A :=
+    match m with
+    | Leaf => None
+    | Node l o r =>
+        match i with
+        | xH => o
+        | xO ii => find ii l
+        | xI ii => find ii r
+        end
+    end.
+
+  Fixpoint mem (i : positive) (m : t A) {struct i} : bool :=
+    match m with
+    | Leaf => false
+    | Node l o r =>
+        match i with
+        | xH => match o with None => false | _ => true end
+        | xO ii => mem ii l
+        | xI ii => mem ii r
+        end
+    end.
+
+  Fixpoint add (i : positive) (v : A) (m : t A) {struct i} : t A :=
+    match m with
+    | Leaf =>
+        match i with
+        | xH => Node Leaf (Some v) Leaf
+        | xO ii => Node (add ii v Leaf) None Leaf
+        | xI ii => Node Leaf None (add ii v Leaf)
+        end
+    | Node l o r =>
+        match i with
+        | xH => Node l (Some v) r
+        | xO ii => Node (add ii v l) o r
+        | xI ii => Node l o (add ii v r)
+        end
+    end.
+
+  Fixpoint remove (i : positive) (m : t A) {struct i} : t A :=
+    match i with
+    | xH =>
+        match m with
+        | Leaf => Leaf
+        | Node Leaf o Leaf => Leaf
+        | Node l o r => Node l None r
+        end
+    | xO ii =>
+        match m with
+        | Leaf => Leaf
+        | Node l None Leaf =>
+            match remove ii l with
+            | Leaf => Leaf
+            | mm => Node mm None Leaf
+            end
+        | Node l o r => Node (remove ii l) o r
+        end
+    | xI ii =>
+        match m with
+        | Leaf => Leaf
+        | Node Leaf None r =>
+            match remove ii r with
+            | Leaf => Leaf
+            | mm => Node Leaf None mm
+            end
+        | Node l o r => Node l o (remove ii r)
+        end
+    end.
+
+  (** [elements] *)
+
+    Fixpoint xelements (m : t A) (i : positive) {struct m}
+             : list (positive * A) :=
+      match m with
+      | Leaf => nil
+      | Node l None r =>
+          (xelements l (append i (xO xH))) ++ (xelements r (append i (xI xH)))
+      | Node l (Some x) r =>
+          (xelements l (append i (xO xH)))
+          ++ ((i, x) :: xelements r (append i (xI xH)))
+      end.
+
+  (* Note: function [xelements] above is inefficient.  We should apply
+     deforestation to it, but that makes the proofs even harder. *)
+
+  Definition elements (m : t A) := xelements m xH.
+
+  Section CompcertSpec.
+
+  Theorem gempty:
+    forall (i: positive), find i empty = None.
+  Proof.
+    destruct i; simpl; auto.
+  Qed.
+
+  Theorem gss:
+    forall (i: positive) (x: A) (m: t A), find i (add i x m) = Some x.
+  Proof.
+    induction i; destruct m; simpl; auto.
+  Qed.
+
+  Lemma gleaf : forall (i : positive), find i (Leaf : t A) = None.
+  Proof. exact gempty. Qed.
+
+  Theorem gso:
+    forall (i j: positive) (x: A) (m: t A),
+    i <> j -> find i (add j x m) = find i m.
+  Proof.
+    induction i; intros; destruct j; destruct m; simpl;
+       try rewrite <- (gleaf i); auto; try apply IHi; congruence.
+  Qed.
+
+  Lemma rleaf : forall (i : positive), remove i (Leaf : t A) = Leaf.
+  Proof. destruct i; simpl; auto. Qed.
+
+  Theorem grs:
+    forall (i: positive) (m: t A), find i (remove i m) = None.
+  Proof.
+    induction i; destruct m.
+     simpl; auto.
+     destruct m1; destruct o; destruct m2 as [ | ll oo rr]; simpl; auto.
+      rewrite (rleaf i); auto.
+      cut (find i (remove i (Node ll oo rr)) = None).
+        destruct (remove i (Node ll oo rr)); auto; apply IHi.
+        apply IHi.
+     simpl; auto.
+     destruct m1 as [ | ll oo rr]; destruct o; destruct m2; simpl; auto.
+      rewrite (rleaf i); auto.
+      cut (find i (remove i (Node ll oo rr)) = None).
+        destruct (remove i (Node ll oo rr)); auto; apply IHi.
+        apply IHi.
+     simpl; auto.
+     destruct m1; destruct m2; simpl; auto.
+  Qed.
+
+  Theorem gro:
+    forall (i j: positive) (m: t A),
+    i <> j -> find i (remove j m) = find i m.
+  Proof.
+    induction i; intros; destruct j; destruct m;
+        try rewrite (rleaf (xI j));
+        try rewrite (rleaf (xO j));
+        try rewrite (rleaf 1); auto;
+        destruct m1; destruct o; destruct m2;
+        simpl;
+        try apply IHi; try congruence;
+        try rewrite (rleaf j); auto;
+        try rewrite (gleaf i); auto.
+     cut (find i (remove j (Node m2_1 o m2_2)) = find i (Node m2_1 o m2_2));
+        [ destruct (remove j (Node m2_1 o m2_2)); try rewrite (gleaf i); auto
+        | apply IHi; congruence ].
+     destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
+        auto.
+     destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
+        auto.
+     cut (find i (remove j (Node m1_1 o0 m1_2)) = find i (Node m1_1 o0 m1_2));
+        [ destruct (remove j (Node m1_1 o0 m1_2)); try rewrite (gleaf i); auto
+        | apply IHi; congruence ].
+     destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
+        auto.
+     destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
+        auto.
+  Qed.
+
+  Lemma xelements_correct:
+      forall (m: t A) (i j : positive) (v: A),
+      find i m = Some v -> List.In (append j i, v) (xelements m j).
+    Proof.
+      induction m; intros.
+       rewrite (gleaf i) in H; congruence.
+       destruct o; destruct i; simpl; simpl in H.
+        rewrite append_assoc_1; apply in_or_app; right; apply in_cons;
+          apply IHm2; auto.
+        rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
+        rewrite append_neutral_r; apply in_or_app; injection H;
+          intro EQ; rewrite EQ; right; apply in_eq.
+        rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto.
+        rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
+        congruence.
+    Qed.
+
+  Theorem elements_correct:
+    forall (m: t A) (i: positive) (v: A),
+    find i m = Some v -> List.In (i, v) (elements m).
+  Proof.
+    intros m i v H.
+    exact (xelements_correct m i xH H).
+  Qed.
+
+  Fixpoint xfind (i j : positive) (m : t A) {struct j} : option A :=
+      match i, j with
+      | _, xH => find i m
+      | xO ii, xO jj => xfind ii jj m
+      | xI ii, xI jj => xfind ii jj m
+      | _, _ => None
+      end.
+
+   Lemma xfind_left :
+      forall (j i : positive) (m1 m2 : t A) (o : option A) (v : A),
+      xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v.
+    Proof.
+      induction j; intros; destruct i; simpl; simpl in H; auto; try congruence.
+      destruct i; congruence.
+    Qed.
+
+    Lemma xelements_ii :
+      forall (m: t A) (i j : positive) (v: A),
+      List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
+         apply in_or_app.
+        left; apply IHm1; auto.
+        right; destruct (in_inv H0).
+         injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq.
+         apply in_cons; apply IHm2; auto.
+        left; apply IHm1; auto.
+        right; apply IHm2; auto.
+    Qed.
+
+    Lemma xelements_io :
+      forall (m: t A) (i j : positive) (v: A),
+      ~List.In (xI i, v) (xelements m (xO j)).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        apply (IHm1 _ _ _ H0).
+        destruct (in_inv H0).
+         congruence.
+         apply (IHm2 _ _ _ H1).
+        apply (IHm1 _ _ _ H0).
+        apply (IHm2 _ _ _ H0).
+    Qed.
+
+    Lemma xelements_oo :
+      forall (m: t A) (i j : positive) (v: A),
+      List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
+         apply in_or_app.
+        left; apply IHm1; auto.
+        right; destruct (in_inv H0).
+         injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq.
+         apply in_cons; apply IHm2; auto.
+        left; apply IHm1; auto.
+        right; apply IHm2; auto.
+    Qed.
+
+    Lemma xelements_oi :
+      forall (m: t A) (i j : positive) (v: A),
+      ~List.In (xO i, v) (xelements m (xI j)).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        apply (IHm1 _ _ _ H0).
+        destruct (in_inv H0).
+         congruence.
+         apply (IHm2 _ _ _ H1).
+        apply (IHm1 _ _ _ H0).
+        apply (IHm2 _ _ _ H0).
+    Qed.
+
+    Lemma xelements_ih :
+      forall (m1 m2: t A) (o: option A) (i : positive) (v: A),
+      List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH).
+    Proof.
+      destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
+        absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
+        destruct (in_inv H0).
+         congruence.
+         apply xelements_ii; auto.
+        absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
+        apply xelements_ii; auto.
+    Qed.
+
+    Lemma xelements_oh :
+      forall (m1 m2: t A) (o: option A) (i : positive) (v: A),
+      List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH).
+    Proof.
+      destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
+        apply xelements_oo; auto.
+        destruct (in_inv H0).
+         congruence.
+         absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
+        apply xelements_oo; auto.
+        absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
+    Qed.
+
+    Lemma xelements_hi :
+      forall (m: t A) (i : positive) (v: A),
+      ~List.In (xH, v) (xelements m (xI i)).
+    Proof.
+      induction m; intros.
+       simpl; auto.
+       destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        generalize H0; apply IHm1; auto.
+        destruct (in_inv H0).
+         congruence.
+         generalize H1; apply IHm2; auto.
+        generalize H0; apply IHm1; auto.
+        generalize H0; apply IHm2; auto.
+    Qed.
+
+    Lemma xelements_ho :
+      forall (m: t A) (i : positive) (v: A),
+      ~List.In (xH, v) (xelements m (xO i)).
+    Proof.
+      induction m; intros.
+       simpl; auto.
+       destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        generalize H0; apply IHm1; auto.
+        destruct (in_inv H0).
+         congruence.
+         generalize H1; apply IHm2; auto.
+        generalize H0; apply IHm1; auto.
+        generalize H0; apply IHm2; auto.
+    Qed.
+
+    Lemma find_xfind_h :
+      forall (m: t A) (i: positive), find i m = xfind i xH m.
+    Proof.
+      destruct i; simpl; auto.
+    Qed.
+
+    Lemma xelements_complete:
+      forall (i j : positive) (m: t A) (v: A),
+      List.In (i, v) (xelements m j) -> xfind i j m = Some v.
+    Proof.
+      induction i; simpl; intros; destruct j; simpl.
+       apply IHi; apply xelements_ii; auto.
+       absurd (List.In (xI i, v) (xelements m (xO j))); auto; apply xelements_io.
+       destruct m.
+        simpl in H; tauto.
+        rewrite find_xfind_h. apply IHi. apply (xelements_ih _ _ _ _ _ H).
+       absurd (List.In (xO i, v) (xelements m (xI j))); auto; apply xelements_oi.
+       apply IHi; apply xelements_oo; auto.
+       destruct m.
+        simpl in H; tauto.
+        rewrite find_xfind_h. apply IHi. apply (xelements_oh _ _ _ _ _ H).
+       absurd (List.In (xH, v) (xelements m (xI j))); auto; apply xelements_hi.
+       absurd (List.In (xH, v) (xelements m (xO j))); auto; apply xelements_ho.
+       destruct m.
+        simpl in H; tauto.
+        destruct o; simpl in H; destruct (in_app_or _ _ _ H).
+         absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
+         destruct (in_inv H0).
+          congruence.
+          absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
+         absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
+         absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
+    Qed.
+
+  Theorem elements_complete:
+    forall (m: t A) (i: positive) (v: A),
+    List.In (i, v) (elements m) -> find i m = Some v.
+  Proof.
+    intros m i v H.
+    unfold elements in H.
+    rewrite find_xfind_h.
+    exact (xelements_complete i xH m v H).
+  Qed.
+
+  End CompcertSpec.
+
+  Definition MapsTo (i:positive)(v:A)(m:t A) := find i m = Some v.
+
+  Definition In (i:positive)(m:t A) := exists e:A, MapsTo i e m.
+
+  Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m.
+
+  Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p').
+      
+  Definition eq_key_elt (p p':positive*A) := 
+          E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+  Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p').
+
+  Lemma mem_find : 
+    forall m x, mem x m = match find x m with None => false | _ => true end.
+  Proof.
+  induction m; destruct x; simpl; auto.
+  Qed.
+
+  Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None.
+  Proof.
+  unfold Empty, MapsTo.
+  intuition.
+  generalize (H a).
+  destruct (find a m); intuition.
+  elim (H0 a0); auto.
+  rewrite H in H0; discriminate.
+  Qed.
+
+  Lemma Empty_Node : forall l o r, Empty (Node l o r) <-> o=None /\ Empty l /\ Empty r.
+  Proof.
+  intros l o r.
+  split.
+  rewrite Empty_alt.
+  split.
+  destruct o; auto.
+  generalize (H 1); simpl; auto.
+  split; rewrite Empty_alt; intros.
+  generalize (H (xO a)); auto.
+  generalize (H (xI a)); auto.
+  intros (H,(H0,H1)).
+  subst.
+  rewrite Empty_alt; intros.
+  destruct a; auto.
+  simpl; generalize H1; rewrite Empty_alt; auto.
+  simpl; generalize H0; rewrite Empty_alt; auto.
+  Qed.
+
+  Section FMapSpec. 
+
+  Lemma mem_1 : forall m x, In x m -> mem x m = true.
+  Proof.
+  unfold In, MapsTo; intros m x; rewrite mem_find.
+  destruct 1 as (e0,H0); rewrite H0; auto.
+  Qed.
+
+  Lemma mem_2 : forall m x, mem x m = true -> In x m. 
+  Proof.
+  unfold In, MapsTo; intros m x; rewrite mem_find.
+  destruct (find x m).
+  exists a; auto.
+  intros; discriminate.
+  Qed.
+
+  Variable  m m' m'' : t A.
+  Variable x y z : key.
+  Variable e e' : A.
+
+  Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
+  Proof. intros; rewrite <- H; auto. Qed.
+
+  Lemma find_1 : MapsTo x e m -> find x m = Some e.
+  Proof. unfold MapsTo; auto. Qed.
+
+  Lemma find_2 : find x m = Some e -> MapsTo x e m.
+  Proof. red; auto. Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+  rewrite Empty_alt; apply gempty.
+  Qed.
+
+  Lemma is_empty_1 : Empty m -> is_empty m = true. 
+  Proof.
+  induction m; simpl; auto.
+  rewrite Empty_Node.
+  intros (H,(H0,H1)).
+  subst; simpl.
+  rewrite IHt0_1; simpl; auto.
+  Qed.
+
+  Lemma is_empty_2 : is_empty m = true -> Empty m.
+  Proof.
+  induction m; simpl; auto.
+  rewrite Empty_alt.
+  intros _; exact gempty.
+  rewrite Empty_Node.
+  destruct o.
+  intros; discriminate.
+  intro H; destruct (andb_prop _ _ H); intuition.
+  Qed.
+
+  Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
+  Proof.
+  unfold MapsTo.
+  intro H; rewrite H; clear H.
+  apply gss.
+  Qed.
+
+  Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+  Proof.
+  unfold MapsTo.
+  intros; rewrite gso; auto.
+  Qed.
+
+  Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+  Proof.
+  unfold MapsTo.
+  intro H; rewrite gso; auto.
+  Qed.
+
+  Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
+  Proof. 
+  intros; intro.
+  generalize (mem_1 H0).
+  rewrite mem_find.
+  rewrite H.
+  rewrite grs.
+  intros; discriminate.
+  Qed.
+
+  Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+  Proof.
+  unfold MapsTo.
+  intro H; rewrite gro; auto.
+  Qed.
+
+  Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
+  Proof. 
+  unfold MapsTo.
+  destruct (peq_dec x y).
+  subst.
+  rewrite grs; intros; discriminate.
+  rewrite gro; auto.
+  Qed.
+  
+  Lemma elements_1 : 
+     MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+  Proof.
+  unfold MapsTo.
+  rewrite InA_alt.
+  intro H.
+  exists (x,e).
+  split.
+  red; simpl; unfold E.eq; auto.
+  apply elements_correct; auto.
+  Qed.
+
+  Lemma elements_2 : 
+     InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+  Proof.
+  unfold MapsTo.
+  rewrite InA_alt.
+  intros ((e0,a),(H,H0)).
+  red in H; simpl in H; unfold E.eq in H; destruct H; subst.
+  apply elements_complete; auto.
+  Qed.
+
+  Lemma xelements_bits_lt_1 : forall p p0 q m v, 
+     List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p.
+  Proof.
+  intros.
+  generalize (xelements_complete _ _ _ _ H); clear H; intros.
+  revert H; revert v; revert m; revert q; revert p0.
+  induction p; destruct p0; simpl; intros; eauto; try discriminate.
+  Qed.
+
+  Lemma xelements_bits_lt_2 : forall p p0 q m v, 
+     List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0.
+  Proof.
+  intros.
+  generalize (xelements_complete _ _ _ _ H); clear H; intros.
+  revert H; revert v; revert m; revert q; revert p0.
+  induction p; destruct p0; simpl; intros; eauto; try discriminate.
+  Qed.
+
+  Lemma xelements_sort : forall p, sort lt_key (xelements m p).
+  Proof.
+  induction m.
+  simpl; auto.
+  destruct o; simpl; intros.
+  (* Some *)
+  apply (SortA_app (eqA:=eq_key_elt)); auto.
+  compute; intuition.
+  constructor; auto.
+  apply In_InfA; intros.
+  destruct y0.
+  red; red; simpl.
+  eapply xelements_bits_lt_2; eauto.
+  intros x0 y0.
+  do 2 rewrite InA_alt.
+  intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
+  destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
+  destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
+  red; red; simpl.
+  destruct H0.
+  injection H0; clear H0; intros _ H0; subst.
+  eapply xelements_bits_lt_1; eauto.
+  apply E.bits_lt_trans with p.
+  eapply xelements_bits_lt_1; eauto.
+  eapply xelements_bits_lt_2; eauto.
+  (* None *)
+  apply (SortA_app (eqA:=eq_key_elt)); auto.
+  compute; intuition.
+  intros x0 y0.
+  do 2 rewrite InA_alt.
+  intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
+  destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
+  destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
+  red; red; simpl.
+  apply E.bits_lt_trans with p.
+  eapply xelements_bits_lt_1; eauto.
+  eapply xelements_bits_lt_2; eauto.
+  Qed.
+
+  Lemma elements_3 : sort lt_key (elements m). 
+  Proof.
+  unfold elements.
+  apply xelements_sort; auto.
+  Qed.
+
+  End FMapSpec.
+
+  (** [map] and [mapi] *)
+ 
+  Variable B : Set.
+
+  Fixpoint xmapi (f : positive -> A -> B) (m : t A) (i : positive)
+             {struct m} : t B :=
+     match m with
+      | Leaf => @Leaf B
+      | Node l o r => Node (xmapi f l (append i (xO xH)))
+                           (option_map (f i) o)
+                           (xmapi f r (append i (xI xH)))
+     end.
+
+  Definition mapi (f : positive -> A -> B) m := xmapi f m xH.
+
+  Definition map (f : A -> B) m := mapi (fun _ => f) m.
+
+  End A.
+
+  Lemma xgmapi:
+      forall (A B: Set) (f: positive -> A -> B) (i j : positive) (m: t A),
+      find i (xmapi f m j) = option_map (f (append j i)) (find i m).
+  Proof.
+  induction i; intros; destruct m; simpl; auto.
+  rewrite (append_assoc_1 j i); apply IHi.
+  rewrite (append_assoc_0 j i); apply IHi.
+  rewrite (append_neutral_r j); auto.
+  Qed.
+
+  Theorem gmapi:
+    forall (A B: Set) (f: positive -> A -> B) (i: positive) (m: t A),
+    find i (mapi f m) = option_map (f i) (find i m).
+  Proof.
+  intros.
+  unfold mapi.
+  replace (f i) with (f (append xH i)).
+  apply xgmapi.
+  rewrite append_neutral_l; auto.
+  Qed.
+
+  Lemma mapi_1 : 
+    forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), 
+    MapsTo x e m -> 
+    exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+  Proof.
+  intros.
+  exists x.
+  split; [red; auto|].
+  apply find_2.
+  generalize (find_1 H); clear H; intros.
+  rewrite gmapi.
+  rewrite H.
+  simpl; auto.
+  Qed.
+
+  Lemma mapi_2 : 
+    forall (elt elt':Set)(m: t elt)(x:key)(f:key->elt->elt'), 
+    In x (mapi f m) -> In x m.
+  Proof.
+  intros.
+  apply mem_2.
+  rewrite mem_find.
+  destruct H as (v,H).
+  generalize (find_1 H); clear H; intros.
+  rewrite gmapi in H.
+  destruct (find x m); auto.
+  simpl in *; discriminate.
+  Qed.
+
+  Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+    MapsTo x e m -> MapsTo x (f e) (map f m).
+  Proof.
+  intros; unfold map.
+  destruct (mapi_1 (fun _ => f) H); intuition.
+  Qed.
+  
+  Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
+    In x (map f m) -> In x m.
+  Proof.
+  intros; unfold map in *; eapply mapi_2; eauto.
+  Qed.
+
+  Section map2.
+  Variable A B C : Set.
+  Variable f : option A -> option B -> option C.
+  
+  Implicit Arguments Leaf [A].
+
+  Fixpoint xmap2_l (m : t A) {struct m} : t C :=
+      match m with
+      | Leaf => Leaf
+      | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r)
+      end.
+
+  Lemma xgmap2_l : forall (i : positive) (m : t A),
+          f None None = None -> find i (xmap2_l m) = f (find i m) None.
+    Proof.
+      induction i; intros; destruct m; simpl; auto.
+    Qed.
+
+  Fixpoint xmap2_r (m : t B) {struct m} : t C :=
+      match m with
+      | Leaf => Leaf
+      | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r)
+      end.
+
+  Lemma xgmap2_r : forall (i : positive) (m : t B),
+          f None None = None -> find i (xmap2_r m) = f None (find i m).
+    Proof.
+      induction i; intros; destruct m; simpl; auto.
+    Qed.
+
+  Fixpoint _map2 (m1 : t A)(m2 : t B) {struct m1} : t C :=
+    match m1 with
+    | Leaf => xmap2_r m2
+    | Node l1 o1 r1 =>
+        match m2 with
+        | Leaf => xmap2_l m1
+        | Node l2 o2 r2 => Node (_map2 l1 l2) (f o1 o2) (_map2 r1 r2)
+        end
+    end.
+
+    Lemma gmap2: forall (i: positive)(m1:t A)(m2: t B),
+      f None None = None ->
+      find i (_map2 m1 m2) = f (find i m1) (find i m2).
+    Proof.
+      induction i; intros; destruct m1; destruct m2; simpl; auto;
+      try apply xgmap2_r; try apply xgmap2_l; auto.
+    Qed.
+
+  End map2.
+
+  Definition map2 (elt elt' elt'':Set)(f:option elt->option elt'->option elt'') := 
+   _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end).
+
+  Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+    (x:key)(f:option elt->option elt'->option elt''), 
+    In x m \/ In x m' -> 
+    find x (map2 f m m') = f (find x m) (find x m'). 
+  Proof. 
+  intros.
+  unfold map2.
+  rewrite gmap2; auto.
+  generalize (@mem_1 _ m x) (@mem_1 _ m' x).
+  do 2 rewrite mem_find.
+  destruct (find x m); simpl; auto.
+  destruct (find x m'); simpl; auto.
+  intros.
+  destruct H; intuition; try discriminate.
+  Qed.
+
+  Lemma  map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+    (x:key)(f:option elt->option elt'->option elt''), 
+    In x (map2 f m m') -> In x m \/ In x m'.
+  Proof.
+  intros.
+  generalize (mem_1 H); clear H; intros.
+  rewrite mem_find in H.
+  unfold map2 in H.
+  rewrite gmap2 in H; auto.
+  generalize (@mem_2 _ m x) (@mem_2 _ m' x).
+  do 2 rewrite mem_find.
+  destruct (find x m); simpl in *; auto.
+  destruct (find x m'); simpl in *; auto.
+  Qed.
+
+
+  Definition fold (A B : Set) (f: positive -> A -> B -> B) (tr: t A) (v: B) :=
+     List.fold_left (fun a p => f (fst p) (snd p) a) (elements tr) v.
+  
+  Lemma fold_1 :
+    forall (A:Set)(m:t A)(B:Set)(i : B) (f : key -> A -> B -> B),
+    fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+  Proof.
+  intros; unfold fold; auto.
+  Qed.
+
+  Fixpoint equal (A:Set)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := 
+    match m1, m2 with 
+      | Leaf, _ => is_empty m2
+      | _, Leaf => is_empty m1
+      | Node l1 o1 r1, Node l2 o2 r2 => 
+           (match o1, o2 with 
+             | None, None => true
+             | Some v1, Some v2 => cmp v1 v2
+             | _, _ => false
+            end)
+           && equal cmp l1 l2 && equal cmp r1 r2
+     end.
+
+  Definition Equal (A:Set)(cmp:A->A->bool)(m m':t A) := 
+    (forall k, In k m <-> In k m') /\ 
+    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+  Lemma equal_1 : forall (A:Set)(m m':t A)(cmp:A->A->bool), 
+    Equal cmp m m' -> equal cmp m m' = true. 
+  Proof. 
+  induction m.
+  (* m = Leaf *)
+  destruct 1. 
+  simpl.
+  apply is_empty_1.
+  red; red; intros.
+  assert (In a (Leaf A)).
+  rewrite H.
+  exists e; auto.
+  destruct H2; red in H2.
+  destruct a; simpl in *; discriminate.
+  (* m = Node *)
+  destruct m'.
+  (* m' = Leaf *)
+  destruct 1. 
+  simpl.
+  destruct o.
+  assert (In xH (Leaf A)).
+  rewrite <- H.
+  exists a; red; auto.
+  destruct H1; red in H1; simpl in H1; discriminate.
+  apply andb_true_intro; split; apply is_empty_1; red; red; intros.
+  assert (In (xO a) (Leaf A)).
+  rewrite <- H.
+  exists e; auto.
+  destruct H2; red in H2; simpl in H2; discriminate.
+  assert (In (xI a) (Leaf A)).
+  rewrite <- H.
+  exists e; auto.
+  destruct H2; red in H2; simpl in H2; discriminate.
+  (* m' = Node *)
+  destruct 1.
+  assert (Equal cmp m1 m'1).
+    split.
+    intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto.
+    intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto.
+  assert (Equal cmp m2 m'2).
+    split.
+    intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto.
+    intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto.
+  simpl.
+  destruct o; destruct o0; simpl.
+  repeat (apply andb_true_intro; split); auto.
+  apply (H0 xH); red; auto.
+  generalize (H xH); unfold In, MapsTo; simpl; intuition.
+  destruct H4; try discriminate; eauto.
+  generalize (H xH); unfold In, MapsTo; simpl; intuition.
+  destruct H5; try discriminate; eauto.
+  apply andb_true_intro; split; auto.
+  Qed.
+
+  Lemma equal_2 : forall (A:Set)(m m':t A)(cmp:A->A->bool), 
+    equal cmp m m' = true -> Equal cmp m m'. 
+  Proof. 
+  induction m.
+  (* m = Leaf *)
+  simpl.
+  split; intros.
+  split.
+  destruct 1; red in H0; destruct k; discriminate.
+  destruct 1; elim (is_empty_2 H H0).
+  red in H0; destruct k; discriminate.
+  (* m = Node *)
+  destruct m'.
+  (* m' = Leaf *)
+  simpl.
+  destruct o; intros; try discriminate.
+  destruct (andb_prop _ _ H); clear H.
+  split; intros.
+  split; unfold In, MapsTo; destruct 1.
+  destruct k; simpl in *; try discriminate.
+  destruct (is_empty_2 H1 (find_2 _ _ H)).
+  destruct (is_empty_2 H0 (find_2 _ _ H)).
+  destruct k; simpl in *; discriminate.
+  unfold In, MapsTo; destruct k; simpl in *; discriminate.
+  (* m' = Node *)
+  destruct o; destruct o0; simpl; intros; try discriminate.
+  destruct (andb_prop _ _ H); clear H.
+  destruct (andb_prop _ _ H0); clear H0.
+  destruct (IHm1 _ _ H2); clear H2 IHm1.
+  destruct (IHm2 _ _ H1); clear H1 IHm2.
+  split; intros.
+  destruct k; unfold In, MapsTo in *; simpl; auto.
+  split; eauto.
+  destruct k; unfold In, MapsTo in *; simpl in *.
+  eapply H4; eauto.
+  eapply H3; eauto.
+  congruence.
+  destruct (andb_prop _ _ H); clear H.
+  destruct (IHm1 _ _ H0); clear H0 IHm1.
+  destruct (IHm2 _ _ H1); clear H1 IHm2.
+  split; intros.
+  destruct k; unfold In, MapsTo in *; simpl; auto.
+  split; eauto.
+  destruct k; unfold In, MapsTo in *; simpl in *.
+  eapply H3; eauto.
+  eapply H2; eauto.
+  try discriminate.
+  Qed.
+
+End PositiveMap.
+
+(** Here come some additionnal facts about this implementation.
+  Most are facts that cannot be derivable from the general interface. *)
+
+
+Module PositiveMapAdditionalFacts.
+  Import PositiveMap.
+
+  (* Derivable from the Map interface *)
+  Theorem gsspec:
+    forall (A:Set)(i j: positive) (x: A) (m: t A),
+    find i (add j x m) = if peq_dec i j then Some x else find i m.
+  Proof.
+    intros.
+    destruct (peq_dec i j); [ rewrite e; apply gss | apply gso; auto ].
+  Qed.
+
+   (* Not derivable from the Map interface *)
+  Theorem gsident:
+    forall (A:Set)(i: positive) (m: t A) (v: A),
+    find i m = Some v -> add i v m = m.
+  Proof.
+    induction i; intros; destruct m; simpl; simpl in H; try congruence.
+     rewrite (IHi m2 v H); congruence.
+     rewrite (IHi m1 v H); congruence.
+  Qed.
+  
+  Lemma xmap2_lr :
+      forall (A B : Set)(f g: option A -> option A -> option B)(m : t A),
+      (forall (i j : option A), f i j = g j i) ->
+      xmap2_l f m = xmap2_r g m.
+    Proof.
+      induction m; intros; simpl; auto.
+      rewrite IHm1; auto.
+      rewrite IHm2; auto.
+      rewrite H; auto.
+    Qed.
+
+  Theorem map2_commut:
+    forall (A B: Set) (f g: option A -> option A -> option B),
+    (forall (i j: option A), f i j = g j i) ->
+    forall (m1 m2: t A),
+    _map2 f m1 m2 = _map2 g m2 m1.
+  Proof.
+    intros A B f g Eq1.
+    assert (Eq2: forall (i j: option A), g i j = f j i).
+      intros; auto.
+    induction m1; intros; destruct m2; simpl;
+      try rewrite Eq1;
+      repeat rewrite (xmap2_lr f g);
+      repeat rewrite (xmap2_lr g f);
+      auto.
+     rewrite IHm1_1.
+     rewrite IHm1_2.
+     auto. 
+  Qed.
+
+End PositiveMapAdditionalFacts.
+
diff --git a/theories/FSets/FMapWeak.v b/theories/FSets/FMapWeak.v
index 90ebeffc..1ad190a4 100644
--- a/theories/FSets/FMapWeak.v
+++ b/theories/FSets/FMapWeak.v
@@ -6,7 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapWeak.v 8639 2006-03-16 19:21:55Z letouzey $ *)
+(* $Id: FMapWeak.v 8844 2006-05-22 17:22:36Z letouzey $ *)
 
+Require Export DecidableType.
+Require Export DecidableTypeEx.
 Require Export FMapWeakInterface.
 Require Export FMapWeakList.
+Require Export FMapWeakFacts.
\ No newline at end of file
diff --git a/theories/FSets/FMapWeakFacts.v b/theories/FSets/FMapWeakFacts.v
new file mode 100644
index 00000000..18f73a3f
--- /dev/null
+++ b/theories/FSets/FMapWeakFacts.v
@@ -0,0 +1,599 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FMapWeakFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *)
+
+(** * Finite maps library *)
+
+(** This functor derives additional facts from [FMapWeakInterface.S]. These
+  facts are mainly the specifications of [FMapWeakInterface.S] written using 
+  different styles: equivalence and boolean equalities. 
+*)
+
+Require Import Bool.
+Require Import OrderedType.
+Require Export FMapWeakInterface. 
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module Facts (M: S).
+Import M.
+Import Logic. (* to unmask [eq] *)  
+Import Peano. (* to unmask [lt] *)
+
+Lemma MapsTo_fun : forall (elt:Set) m x (e e':elt), 
+  MapsTo x e m -> MapsTo x e' m -> e=e'.
+Proof.
+intros.
+generalize (find_1 H) (find_1 H0); clear H H0.
+intros; rewrite H in H0; injection H0; auto.
+Qed.
+
+(** * Specifications written using equivalences *)
+
+Section IffSpec. 
+Variable elt elt' elt'': Set.
+Implicit Type m: t elt.
+Implicit Type x y z: key.
+Implicit Type e: elt.
+
+Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m).
+Proof.
+split; apply MapsTo_1; auto.
+Qed.
+
+Lemma In_iff : forall m x y, E.eq x y -> (In x m <-> In y m).
+Proof.
+unfold In.
+split; intros (e0,H0); exists e0.
+apply (MapsTo_1 H H0); auto.
+apply (MapsTo_1 (E.eq_sym H) H0); auto.
+Qed.
+
+Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e.
+Proof.
+split; [apply find_1|apply find_2].
+Qed.
+
+Lemma not_find_mapsto_iff : forall m x, ~In x m <-> find x m = None.
+Proof.
+intros.
+generalize (find_mapsto_iff m x); destruct (find x m).
+split; intros; try discriminate.
+destruct H0.
+exists e; rewrite H; auto.
+split; auto.
+intros; intros (e,H1).
+rewrite H in H1; discriminate.
+Qed.
+
+Lemma mem_in_iff : forall m x, In x m <-> mem x m = true.
+Proof.
+split; [apply mem_1|apply mem_2].
+Qed.
+
+Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false.
+Proof.
+intros; rewrite mem_in_iff; destruct (mem x m); intuition.
+Qed.
+
+Lemma equal_iff : forall m m' cmp, Equal cmp m m' <-> equal cmp m m' = true.
+Proof. 
+split; [apply equal_1|apply equal_2].
+Qed.
+
+Lemma empty_mapsto_iff : forall x e, MapsTo x e (empty elt) <-> False.
+Proof.
+intuition; apply (empty_1 H).
+Qed.
+
+Lemma empty_in_iff : forall x, In x (empty elt) <-> False.
+Proof.
+unfold In.
+split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition.
+Qed.
+
+Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. 
+Proof. 
+split; [apply is_empty_1|apply is_empty_2].
+Qed.
+
+Lemma add_mapsto_iff : forall m x y e e', 
+  MapsTo y e' (add x e m) <-> 
+     (E.eq x y /\ e=e') \/ 
+     (~E.eq x y /\ MapsTo y e' m).
+Proof. 
+intros.
+intuition.
+destruct (E.eq_dec x y); [left|right].
+split; auto.
+symmetry; apply (MapsTo_fun (e':=e) H); auto.
+split; auto; apply add_3 with x e; auto.
+subst; auto.
+Qed.
+
+Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m.
+Proof. 
+unfold In; split.
+intros (e',H).
+destruct (E.eq_dec x y) as [E|E]; auto.
+right; exists e'; auto.
+apply (add_3 E H).
+destruct (E.eq_dec x y) as [E|E]; auto.
+intros.
+exists e; apply add_1; auto.
+intros [H|(e',H)].
+destruct E; auto.
+exists e'; apply add_2; auto.
+Qed.
+
+Lemma add_neq_mapsto_iff : forall m x y e e', 
+ ~ E.eq x y -> (MapsTo y e' (add x e m)  <-> MapsTo y e' m).
+Proof.
+split; [apply add_3|apply add_2]; auto.
+Qed.
+
+Lemma add_neq_in_iff : forall m x y e, 
+ ~ E.eq x y -> (In y (add x e m)  <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+apply (add_3 H H0).
+apply add_2; auto.
+Qed.
+
+Lemma remove_mapsto_iff : forall m x y e, 
+  MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m.
+Proof. 
+intros.
+split; intros.
+split.
+assert (In y (remove x m)) by (exists e; auto).
+intro H1; apply (remove_1 H1 H0).
+apply remove_3 with x; auto.
+apply remove_2; intuition.
+Qed.
+
+Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m.
+Proof. 
+unfold In; split.
+intros (e,H).
+split.
+assert (In y (remove x m)) by (exists e; auto).
+intro H1; apply (remove_1 H1 H0).
+exists e; apply remove_3 with x; auto.
+intros (H,(e,H0)); exists e; apply remove_2; auto.
+Qed.
+
+Lemma remove_neq_mapsto_iff : forall m x y e, 
+ ~ E.eq x y -> (MapsTo y e (remove x m)  <-> MapsTo y e m).
+Proof.
+split; [apply remove_3|apply remove_2]; auto.
+Qed.
+
+Lemma remove_neq_in_iff : forall m x y, 
+ ~ E.eq x y -> (In y (remove x m)  <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+apply (remove_3 H0).
+apply remove_2; auto.
+Qed.
+
+Lemma elements_mapsto_iff : forall m x e, 
+ MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m).
+Proof. 
+split; [apply elements_1 | apply elements_2].
+Qed.
+
+Lemma elements_in_iff : forall m x, 
+ In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m).
+Proof. 
+unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto.
+Qed.
+
+Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), 
+ MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m.
+Proof.
+split.
+case_eq (find x m); intros.
+exists e.
+split.
+apply (MapsTo_fun (m:=map f m) (x:=x)); auto.
+apply find_2; auto.
+assert (In x (map f m)) by (exists b; auto).
+destruct (map_2 H1) as (a,H2).
+rewrite (find_1 H2) in H; discriminate.
+intros (a,(H,H0)).
+subst b; auto.
+Qed.
+
+Lemma map_in_iff : forall m x (f : elt -> elt'), 
+ In x (map f m) <-> In x m.
+Proof.
+split; intros; eauto.
+destruct H as (a,H).
+exists (f a); auto.
+Qed.
+
+Lemma mapi_in_iff : forall m x (f:key->elt->elt'),
+ In x (mapi f m) <-> In x m.
+Proof.
+split; intros; eauto.
+destruct H as (a,H).
+destruct (mapi_1 f H) as (y,(H0,H1)).
+exists (f y a); auto.
+Qed.
+
+(* Unfortunately, we don't have simple equivalences for [mapi] 
+  and [MapsTo]. The only correct one needs compatibility of [f]. *) 
+
+Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), 
+ MapsTo x b (mapi f m) -> 
+ exists a, exists y, E.eq y x /\ b = f y a /\ MapsTo x a m.
+Proof.
+intros; case_eq (find x m); intros.
+exists e.
+destruct (@mapi_1 _ _ m x e f) as (y,(H1,H2)).
+apply find_2; auto.
+exists y; repeat split; auto.
+apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto.
+assert (In x (mapi f m)) by (exists b; auto).
+destruct (mapi_2 H1) as (a,H2).
+rewrite (find_1 H2) in H0; discriminate.
+Qed.
+
+Lemma mapi_1bis : forall m x e (f:key->elt->elt'), 
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ MapsTo x e m -> MapsTo x (f x e) (mapi f m).
+Proof.
+intros.
+destruct (mapi_1 f H0) as (y,(H1,H2)).
+replace (f x e) with (f y e) by auto.
+auto.
+Qed.
+
+Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'),
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m).
+Proof.
+split.
+intros.
+destruct (mapi_inv H0) as (a,(y,(H1,(H2,H3)))).
+exists a; split; auto.
+subst b; auto.
+intros (a,(H0,H1)).
+subst b.
+apply mapi_1bis; auto.
+Qed.
+
+(** Things are even worse for [map2] : we don't try to state any 
+ equivalence, see instead boolean results below. *)
+
+End IffSpec.
+
+(** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *)
+  
+Ltac map_iff := 
+ repeat (progress (
+  rewrite add_mapsto_iff || rewrite add_in_iff ||
+  rewrite remove_mapsto_iff || rewrite remove_in_iff ||
+  rewrite empty_mapsto_iff || rewrite empty_in_iff ||
+  rewrite map_mapsto_iff || rewrite map_in_iff ||
+  rewrite mapi_in_iff)).
+
+(**  * Specifications written using boolean predicates *)
+
+Section BoolSpec.
+
+Definition eqb x y := if E.eq_dec x y then true else false.
+
+Lemma mem_find_b : forall (elt:Set)(m:t elt)(x:key), mem x m = if find x m then true else false. 
+Proof.
+intros.
+generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In.
+destruct (find x m); destruct (mem x m); auto.
+intros.
+rewrite <- H0; exists e; rewrite H; auto.
+intuition.
+destruct H0 as (e,H0).
+destruct (H e); intuition discriminate.
+Qed.
+
+Variable elt elt' elt'' : Set.
+Implicit Types m : t elt.
+Implicit Types x y z : key.
+Implicit Types e : elt.
+
+Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m.
+Proof. 
+intros.
+generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H).
+destruct (mem x m); destruct (mem y m); intuition.
+Qed.
+
+Lemma find_o : forall m x y, E.eq x y -> find x m = find y m.
+Proof.
+intros.
+generalize (find_mapsto_iff m x) (find_mapsto_iff m y) (fun e => MapsTo_iff m e H).
+destruct (find x m); destruct (find y m); intros.
+rewrite <- H0; rewrite H2; rewrite H1; auto.
+symmetry; rewrite <- H1; rewrite <- H2; rewrite H0; auto.
+rewrite <- H0; rewrite H2; rewrite H1; auto.
+auto.
+Qed.
+
+Lemma empty_o : forall x, find x (empty elt) = None.
+Proof.
+intros.
+case_eq (find x (empty elt)); intros; auto.
+generalize (find_2 H).
+rewrite empty_mapsto_iff; intuition.
+Qed.
+
+Lemma empty_a : forall x, mem x (empty elt) = false.
+Proof.
+intros.
+case_eq (mem x (empty elt)); intros; auto.
+generalize (mem_2 H).
+rewrite empty_in_iff; intuition.
+Qed.
+
+Lemma add_eq_o : forall m x y e, 
+ E.eq x y -> find y (add x e m) = Some e.
+Proof.
+auto.
+Qed.
+
+Lemma add_neq_o : forall m x y e, 
+ ~ E.eq x y -> find y (add x e m) = find y m. 
+Proof.
+intros.
+case_eq (find y m); intros; auto.
+case_eq (find y (add x e m)); intros; auto.
+rewrite <- H0; symmetry.
+apply find_1; apply add_3 with x e; auto.
+Qed.
+Hint Resolve add_neq_o.
+
+Lemma add_o : forall m x y e, 
+ find y (add x e m) = if E.eq_dec x y then Some e else find y m.
+Proof.
+intros; destruct (E.eq_dec x y); auto.
+Qed.
+
+Lemma add_eq_b : forall m x y e, 
+ E.eq x y -> mem y (add x e m) = true.
+Proof.
+intros; rewrite mem_find_b; rewrite add_eq_o; auto.
+Qed.
+
+Lemma add_neq_b : forall m x y e, 
+ ~E.eq x y -> mem y (add x e m) = mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto.
+Qed.
+
+Lemma add_b : forall m x y e, 
+ mem y (add x e m) = eqb x y || mem y m. 
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb.
+destruct (E.eq_dec x y); simpl; auto.
+Qed.
+
+Lemma remove_eq_o : forall m x y, 
+ E.eq x y -> find y (remove x m) = None.
+Proof.
+intros.
+generalize (remove_1 (m:=m) H).
+generalize (find_mapsto_iff (remove x m) y).
+destruct (find y (remove x m)); auto.
+destruct 2.
+exists e; rewrite H0; auto.
+Qed.
+Hint Resolve remove_eq_o.
+
+Lemma remove_neq_o : forall m x y, 
+ ~ E.eq x y -> find y (remove x m) = find y m. 
+Proof.
+intros.
+case_eq (find y m); intros; auto.
+case_eq (find y (remove x m)); intros; auto.
+rewrite <- H0; symmetry.
+apply find_1; apply remove_3 with x; auto.
+Qed.
+Hint Resolve remove_neq_o.
+
+Lemma remove_o : forall m x y, 
+ find y (remove x m) = if E.eq_dec x y then None else find y m.
+Proof.
+intros; destruct (E.eq_dec x y); auto.
+Qed.
+
+Lemma remove_eq_b : forall m x y, 
+ E.eq x y -> mem y (remove x m) = false.
+Proof.
+intros; rewrite mem_find_b; rewrite remove_eq_o; auto.
+Qed.
+
+Lemma remove_neq_b : forall m x y, 
+ ~ E.eq x y -> mem y (remove x m) = mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto.
+Qed.
+
+Lemma remove_b : forall m x y, 
+ mem y (remove x m) = negb (eqb x y) && mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb.
+destruct (E.eq_dec x y); auto.
+Qed.
+
+Definition option_map (A:Set)(B:Set)(f:A->B)(o:option A) : option B := 
+ match o with 
+  | Some a => Some (f a)
+  | None => None
+ end.
+
+Lemma map_o : forall m x (f:elt->elt'), 
+ find x (map f m) = option_map f (find x m). 
+Proof.
+intros.
+generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x)
+  (fun b => map_mapsto_iff m x b f).
+destruct (find x (map f m)); destruct (find x m); simpl; auto; intros.
+rewrite <- H; rewrite H1; exists e0; rewrite H0; auto.
+destruct (H e) as [_ H2].
+rewrite H1 in H2.
+destruct H2 as (a,(_,H2)); auto.
+rewrite H0 in H2; discriminate.
+rewrite <- H; rewrite H1; exists e; rewrite H0; auto.
+Qed.
+
+Lemma map_b : forall m x (f:elt->elt'), 
+ mem x (map f m) = mem x m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite map_o.
+destruct (find x m); simpl; auto.
+Qed.
+
+Lemma mapi_b : forall m x (f:key->elt->elt'), 
+ mem x (mapi f m) = mem x m.
+Proof.
+intros.
+generalize (mem_in_iff (mapi f m) x) (mem_in_iff m x) (mapi_in_iff m x f).
+destruct (mem x (mapi f m)); destruct (mem x m); simpl; auto; intros.
+symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto.
+rewrite <- H; rewrite H1; rewrite H0; auto.
+Qed.
+
+Lemma mapi_o : forall m x (f:key->elt->elt'), 
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ find x (mapi f m) = option_map (f x) (find x m).
+Proof.
+intros.
+generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) 
+  (fun b => mapi_mapsto_iff m x b H).
+destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros.
+rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto.
+destruct (H0 e) as [_ H3].
+rewrite H2 in H3.
+destruct H3 as (a,(_,H3)); auto.
+rewrite H1 in H3; discriminate.
+rewrite <- H0; rewrite H2; exists e; rewrite H1; auto.
+Qed.
+
+Lemma map2_1bis : forall (m: t elt)(m': t elt') x 
+ (f:option elt->option elt'->option elt''), 
+ f None None = None -> 
+ find x (map2 f m m') = f (find x m) (find x m').       
+Proof.
+intros.
+case_eq (find x m); intros.
+rewrite <- H0.
+apply map2_1; auto.
+left; exists e; auto.
+case_eq (find x m'); intros.
+rewrite <- H0; rewrite <- H1.
+apply map2_1; auto.
+right; exists e; auto.
+rewrite H.
+case_eq (find x (map2 f m m')); intros; auto.
+assert (In x (map2 f m m')) by (exists e; auto).
+destruct (map2_2 H3) as [(e0,H4)|(e0,H4)].
+rewrite (find_1 H4) in H0; discriminate.
+rewrite (find_1 H4) in H1; discriminate.
+Qed.
+
+Fixpoint findA (A B:Set)(f : A -> bool) (l:list (A*B)) : option B := 
+ match l with  
+  | nil => None 
+  | (a,b)::l => if f a then Some b else findA f l
+ end.
+
+Lemma findA_NoDupA : 
+ forall (A B:Set)
+ (eqA:A->A->Prop)
+ (eqA_sym: forall a b, eqA a b -> eqA b a)
+ (eqA_trans: forall a b c, eqA a b -> eqA b c -> eqA a c)
+ (eqA_dec : forall a a', { eqA a a' }+{~eqA a a' }) 
+ (l:list (A*B))(x:A)(e:B),  
+ NoDupA (fun p p' => eqA (fst p) (fst p')) l -> 
+ (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (x,e) l <->
+  findA (fun y:A => if eqA_dec x y then true else false) l = Some e).
+Proof.
+induction l; simpl; intros.
+split; intros; try discriminate.
+inversion H0.
+destruct a as (y,e').
+inversion_clear H.
+split; intros.
+inversion_clear H.
+simpl in *; destruct H2; subst e'.
+destruct (eqA_dec x y); intuition.
+destruct (eqA_dec x y); simpl.
+destruct H0.
+generalize e0 H2 eqA_trans eqA_sym; clear.
+induction l.
+inversion 2.
+inversion_clear 2; intros; auto.
+destruct a.
+compute in H; destruct H.
+subst b.
+constructor 1; auto.
+simpl.
+apply eqA_trans with x; auto.
+rewrite <- IHl; auto.
+destruct (eqA_dec x y); simpl in *.
+inversion H; clear H; intros; subst e'; auto.
+constructor 2.
+rewrite IHl; auto.
+Qed.
+
+Lemma elements_o : forall m x, 
+ find x m = findA (eqb x) (elements m).
+Proof.
+intros.
+assert (forall e, find x m = Some e <-> InA (eq_key_elt (elt:=elt)) (x,e) (elements m)).
+ intros; rewrite <- find_mapsto_iff; apply elements_mapsto_iff.
+assert (NoDupA (eq_key (elt:=elt)) (elements m)). 
+ exact (elements_3 m).
+generalize (fun e => @findA_NoDupA _ _ _ E.eq_sym E.eq_trans E.eq_dec (elements m) x e H0).
+unfold eqb.
+destruct (find x m); destruct (findA (fun y : E.t => if E.eq_dec x y then true else false) (elements m)); 
+ simpl; auto; intros.
+symmetry; rewrite <- H1; rewrite <- H; auto.
+symmetry; rewrite <- H1; rewrite <- H; auto.
+rewrite H; rewrite H1; auto.
+Qed.
+
+Lemma elements_b : forall m x, mem x m = existsb (fun p => eqb x (fst p)) (elements m).
+Proof.
+intros.
+generalize (mem_in_iff m x)(elements_in_iff m x)
+ (existsb_exists (fun p => eqb x (fst p)) (elements m)).
+destruct (mem x m); destruct (existsb (fun p => eqb x (fst p)) (elements m)); auto; intros.
+symmetry; rewrite H1.
+destruct H0 as (H0,_).
+destruct H0 as (e,He); [ intuition |].
+rewrite InA_alt in He.
+destruct He as ((y,e'),(Ha1,Ha2)).
+compute in Ha1; destruct Ha1; subst e'.
+exists (y,e); split; simpl; auto.
+unfold eqb; destruct (E.eq_dec x y); intuition.
+rewrite <- H; rewrite H0.
+destruct H1 as (H1,_).
+destruct H1 as ((y,e),(Ha1,Ha2)); [intuition|].
+simpl in Ha2.
+unfold eqb in *; destruct (E.eq_dec x y); auto; try discriminate.
+exists e; rewrite InA_alt.
+exists (y,e); intuition.
+compute; auto.
+Qed.
+
+End BoolSpec.
+
+End Facts.
diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v
index ce3893e0..3a91b868 100644
--- a/theories/FSets/FMapWeakList.v
+++ b/theories/FSets/FMapWeakList.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapWeakList.v 8639 2006-03-16 19:21:55Z letouzey $ *)
+(* $Id: FMapWeakList.v 8899 2006-06-06 11:09:43Z jforest $ *)
 
 (** * Finite map library *)  
 
@@ -24,7 +24,7 @@ Arguments Scope list [type_scope].
 
 Module Raw (X:DecidableType).
 
-Module PX := PairDecidableType X.
+Module PX := KeyDecidableType X.
 Import PX.
 
 Definition key := X.t.
@@ -34,7 +34,7 @@ Section Elt.
 
 Variable elt : Set.
 
-(* now in PairDecidableType:
+(* now in KeyDecidableType:
 Definition eqk (p p':key*elt) := X.eq (fst p) (fst p').
 Definition eqke (p p':key*elt) := 
           X.eq (fst p) (fst p') /\ (snd p) = (snd p').
@@ -91,7 +91,7 @@ Qed.
 
 (** * [mem] *)
 
-Fixpoint mem (k : key) (s : t elt) {struct s} : bool :=
+Function mem (k : key) (s : t elt) {struct s} : bool :=
   match s with
    | nil => false
    | (k',_) :: l => if X.eq_dec k k' then true else mem k l
@@ -100,30 +100,30 @@ Fixpoint mem (k : key) (s : t elt) {struct s} : bool :=
 Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true.
 Proof.
  intros m Hm x; generalize Hm; clear Hm.      
- functional induction mem x m;intros NoDup belong1;trivial.
+ functional induction (mem x m);intros NoDup belong1;trivial.
  inversion belong1. inversion H.
  inversion_clear NoDup.
  inversion_clear belong1.
- inversion_clear H3.
- compute in H4; destruct H4.
- elim H; auto.
- apply H0; auto.
- exists x; auto.
+ inversion_clear H2.
+ compute in H3; destruct H3.
+ contradiction.
+ apply IHb; auto.
+ exists x0; auto.
 Qed. 
 
 Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. 
 Proof.
  intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
- functional induction mem x m; intros NoDup hyp; try discriminate.
- exists e; auto. 
+ functional induction (mem x m); intros NoDup hyp; try discriminate.
+ exists _x; auto. 
  inversion_clear NoDup.
- destruct H0; auto.
- exists x; auto.
+ destruct IHb; auto.
+ exists x0; auto.
 Qed.
 
 (** * [find] *)
 
-Fixpoint find (k:key) (s: t elt) {struct s} : option elt :=
+Function find (k:key) (s: t elt) {struct s} : option elt :=
   match s with
    | nil => None
    | (k',x)::s' => if X.eq_dec k k' then Some x else find k s'
@@ -132,23 +132,23 @@ Fixpoint find (k:key) (s: t elt) {struct s} : option elt :=
 Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
 Proof.
  intros m x. unfold PX.MapsTo.
- functional induction find x m;simpl;intros e' eqfind; inversion eqfind; auto.
+ functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto.
 Qed.
 
 Lemma find_1 : forall m (Hm:NoDupA m) x e, 
   MapsTo x e m -> find x m = Some e. 
 Proof.
  intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
- functional induction find x m;simpl; subst; try clear H_eq_1.
+ functional induction (find x m);simpl; subst; try clear H_eq_1.
 
  inversion 2.
 
  do 2 inversion_clear 1.
  compute in H3; destruct H3; subst; trivial.
- elim H0; apply InA_eqk with (k,e); auto.
+ elim H; apply InA_eqk with (x,e); auto.
 
  do 2 inversion_clear 1; auto.
- compute in H4; destruct H4; elim H; auto.
+ compute in H3; destruct H3; elim _x; auto.
 Qed.
 
 (* Not part of the exported specifications, used later for [combine]. *)
@@ -166,7 +166,7 @@ Qed.
 
 (** * [add] *)
 
-Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
+Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
   match s with
    | nil => (k,x) :: nil
    | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l
@@ -175,26 +175,26 @@ Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
 Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
 Proof.
  intros m x y e; generalize y; clear y; unfold PX.MapsTo.
- functional induction add x e m;simpl;auto.
+ functional induction (add x e m);simpl;auto.
 Qed.
 
 Lemma add_2 : forall m x y e e', 
   ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
 Proof.
  intros m x  y e e'; generalize y e; clear y e; unfold PX.MapsTo.
- functional induction add x e' m;simpl;auto.
- intros y' e' eqky';  inversion_clear 1.
+ functional induction (add x e' m);simpl;auto.
+ intros y' e'' eqky';  inversion_clear 1.
  destruct H1; simpl in *.
  elim eqky'; apply X.eq_trans with k'; auto.
  auto.
- intros y' e' eqky'; inversion_clear 1; intuition.
+ intros y' e'' eqky'; inversion_clear 1; intuition.
 Qed.
   
 Lemma add_3 : forall m x y e e',
   ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
 Proof.
  intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
- functional induction add x e' m;simpl;auto.
+ functional induction (add x e' m);simpl;auto.
  intros; apply (In_inv_3 H0); auto.
  constructor 2; apply (In_inv_3 H1); auto.
  inversion_clear 2; auto.
@@ -204,12 +204,12 @@ Lemma add_3' : forall m x y e e',
   ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. 
 Proof.
  intros m x y e e'. generalize y e; clear y e.
- functional induction add x e' m;simpl;auto.
+ functional induction (add x e' m);simpl;auto.
  inversion_clear 2.
  compute in H1; elim H; auto.
  inversion H1. 
  constructor 2; inversion_clear H1; auto.
- compute in H2; elim H0; auto.
+ compute in H2; elim H; auto.
  inversion_clear 2; auto.
 Qed.
 
@@ -257,7 +257,7 @@ Qed.
 
 (** * [remove] *)
 
-Fixpoint remove (k : key) (s : t elt) {struct s} : t elt :=
+Function remove (k : key) (s : t elt) {struct s} : t elt :=
   match s with
    | nil => nil
    | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l
@@ -266,7 +266,7 @@ Fixpoint remove (k : key) (s : t elt) {struct s} : t elt :=
 Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m).
 Proof.
  intros m Hm x y; generalize Hm; clear Hm.
- functional induction remove x m;simpl;intros;auto.
+ functional induction (remove x m);simpl;intros;auto.
 
  red; inversion 1; inversion H1.
 
@@ -275,14 +275,14 @@ Proof.
  swap H1.
  destruct H3 as (e,H3); unfold PX.MapsTo in H3.
  apply InA_eqk with (y,e); auto.
- compute; apply X.eq_trans with k; auto.
+ compute; apply X.eq_trans with x; auto.
   
  intro H2.
  destruct H2 as (e,H2); inversion_clear H2.
- compute in H3; destruct H3.
- elim H; apply X.eq_trans with y; auto.
+ compute in H1; destruct H1.
+ elim _x; apply X.eq_trans with y; auto.
  inversion_clear Hm.
- elim (H0 H4 H1).
+ elim (IHt0 H3 H).
  exists e; auto.
 Qed.
   
@@ -290,10 +290,10 @@ Lemma remove_2 : forall m (Hm:NoDupA m) x y e,
   ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
 Proof.
  intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
- functional induction remove x m;auto.
+ functional induction (remove x m);auto.
  inversion_clear 3; auto.
  compute in H2; destruct H2.
- elim H0; apply X.eq_trans with k'; auto.
+ elim H; apply X.eq_trans with k'; auto.
   
  inversion_clear 1; inversion_clear 2; auto.
 Qed.
@@ -302,7 +302,7 @@ Lemma remove_3 : forall m (Hm:NoDupA m) x y e,
   MapsTo y e (remove x m) -> MapsTo y e m.
 Proof.
  intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
- functional induction remove x m;auto.
+ functional induction (remove x m);auto.
  do 2 inversion_clear 1; auto.
 Qed.
 
@@ -310,7 +310,7 @@ Lemma remove_3' : forall m (Hm:NoDupA m) x y e,
   InA eqk (y,e) (remove x m) -> InA eqk (y,e) m.
 Proof.
  intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
- functional induction remove x m;auto.
+ functional induction (remove x m);auto.
  do 2 inversion_clear 1; auto.
 Qed.
 
@@ -347,8 +347,7 @@ Qed.
 
 (** * [fold] *)
 
-Fixpoint fold (A:Set)(f:key->elt->A->A)(m:t elt) {struct m} : A -> A :=
-  fun acc => 
+Function fold (A:Set)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} :  A :=
   match m with
    | nil => acc
    | (k,e)::m' => fold f m' (f k e acc)
@@ -357,7 +356,7 @@ Fixpoint fold (A:Set)(f:key->elt->A->A)(m:t elt) {struct m} : A -> A :=
 Lemma fold_1 : forall m (A:Set)(i:A)(f:key->elt->A->A),
   fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
 Proof. 
- intros; functional induction fold A f m i; auto.
+ intros; functional induction (@fold A f m i); auto.
 Qed.
 
 (** * [equal] *)
@@ -878,83 +877,124 @@ Module Make (X: DecidableType) <: S with Module E:=X.
  Module Raw := Raw X. 
 
  Module E := X.
- Definition key := X.t. 
+ Definition key := E.t. 
 
  Record slist (elt:Set) : Set :=  
   {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}.
  Definition t (elt:Set) := slist elt. 
 
- Section Elt. 
+Section Elt. 
  Variable elt elt' elt'':Set. 
 
  Implicit Types m : t elt.
-
- Definition empty := Build_slist (Raw.empty_NoDup elt).
- Definition is_empty m := Raw.is_empty m.(this).
- Definition add x e m := Build_slist (Raw.add_NoDup m.(NoDup) x e).
- Definition find x m := Raw.find x m.(this).
- Definition remove x m := Build_slist (Raw.remove_NoDup m.(NoDup) x). 
- Definition mem x m := Raw.mem x m.(this).
+ Implicit Types x y : key. 
+ Implicit Types e : elt.
+
+ Definition empty : t elt := Build_slist (Raw.empty_NoDup elt).
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := Build_slist (Raw.add_NoDup m.(NoDup) x e).
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). 
+ Definition mem x m : bool := Raw.mem x m.(this).
  Definition map f m : t elt' := Build_slist (Raw.map_NoDup m.(NoDup) f).
- Definition mapi f m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f).
+ Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f).
  Definition map2 f m (m':t elt') : t elt'' := 
- Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)).
- Definition elements m := @Raw.elements elt m.(this).
- Definition fold A f m i := @Raw.fold elt A f m.(this) i.
- Definition equal cmp m m' := @Raw.equal elt cmp m.(this) m'.(this).
-
- Definition MapsTo x e m := Raw.PX.MapsTo x e m.(this).
- Definition In x m := Raw.PX.In x m.(this).
- Definition Empty m := Raw.Empty m.(this).
- Definition Equal cmp m m' := @Raw.Equal elt cmp m.(this) m'.(this).
+   Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)).
+ Definition elements m : list (key*elt) := @Raw.elements elt m.(this).
+ Definition fold (A:Set)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i.
+ Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this).
+
+ Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.PX.In x m.(this).
+ Definition Empty m : Prop := Raw.Empty m.(this).
+ Definition Equal cmp m m' : Prop := @Raw.Equal elt cmp m.(this) m'.(this).
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt.
+
+ Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed.
+
+ Lemma mem_1 : forall m x, In x m -> mem x m = true.
+ Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(NoDup)). Qed.
+ Lemma mem_2 : forall m x, mem x m = true -> In x m.
+ Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(NoDup)). Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact (@Raw.empty_1 elt). Qed.
+
+ Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+ Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed.
+ Lemma is_empty_2 :  forall m, is_empty m = true -> Empty m.
+ Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed.
+
+ Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
+ Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed.
+ Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+ Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed.
+ Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed.
+
+ Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
+ Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(NoDup)). Qed.
+ Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+ Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(NoDup)). Qed.
+ Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(NoDup)). Qed.
+
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. 
+ Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(NoDup)). Qed.
+ Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed.
+
+ Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+ Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed.
+ Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed.
+ Lemma elements_3 : forall m, NoDupA eq_key (elements m).  
+ Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(NoDup)). Qed.
+
+ Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed.
+
+ Lemma equal_1 : forall m m' cmp, Equal cmp m m' -> equal cmp m m' = true. 
+ Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed.
+ Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equal cmp m m'.
+ Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed.
 
- Definition eq_key (p p':key*elt) := X.eq (fst p) (fst p').
+ End Elt.
  
- Definition eq_key_elt (p p':key*elt) := 
-      X.eq (fst p) (fst p') /\ (snd p) = (snd p').
-
- Definition MapsTo_1 m := @Raw.PX.MapsTo_eq elt m.(this).
-
- Definition mem_1 m := @Raw.mem_1 elt m.(this) m.(NoDup).
- Definition mem_2 m := @Raw.mem_2 elt m.(this) m.(NoDup).
-
- Definition empty_1 := @Raw.empty_1.
-
- Definition is_empty_1 m := @Raw.is_empty_1 elt m.(this).
- Definition is_empty_2 m := @Raw.is_empty_2 elt m.(this).
-
- Definition add_1 m := @Raw.add_1 elt m.(this).
- Definition add_2 m := @Raw.add_2 elt m.(this).
- Definition add_3 m := @Raw.add_3 elt m.(this).
+ Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+ Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed.
+ Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
+        In x (map f m) -> In x m. 
+ Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed.
+
+ Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+ Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed.
+ Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+ Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed.
+
+ Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+	In x m \/ In x m' -> 
+        find x (map2 f m m') = f (find x m) (find x m').       
+ Proof. 
+ intros elt elt' elt'' m m' x f; 
+ exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x).
+ Qed.
+ Lemma map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+        In x (map2 f m m') -> In x m \/ In x m'.
+ Proof. 
+ intros elt elt' elt'' m m' x f;  
+ exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x).
+ Qed.
 
- Definition remove_1 m := @Raw.remove_1 elt m.(this) m.(NoDup).
- Definition remove_2 m := @Raw.remove_2 elt m.(this) m.(NoDup).
- Definition remove_3 m := @Raw.remove_3 elt m.(this) m.(NoDup).
-
- Definition find_1 m := @Raw.find_1 elt m.(this) m.(NoDup).
- Definition find_2 m := @Raw.find_2 elt m.(this).
-
- Definition elements_1 m := @Raw.elements_1 elt m.(this).
- Definition elements_2 m := @Raw.elements_2 elt m.(this).
- Definition elements_3 m := @Raw.elements_3 elt m.(this) m.(NoDup).
-
- Definition fold_1 m := @Raw.fold_1 elt m.(this).
-
- Definition map_1 m := @Raw.map_1 elt elt' m.(this).
- Definition map_2 m := @Raw.map_2 elt elt' m.(this).
-
- Definition mapi_1 m := @Raw.mapi_1 elt elt' m.(this).
- Definition mapi_2 m := @Raw.mapi_2 elt elt' m.(this).
-
- Definition map2_1 m (m':t elt') x f := 
-  @Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x.
- Definition map2_2 m (m':t elt') x f := 
-  @Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x.
-
- Definition equal_1 m m' := @Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup).
- Definition equal_2 m m' := @Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup).
-
- End Elt.
 End Make.
 
-
diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v
index ae5b86c9..72ccad3f 100644
--- a/theories/FSets/FMaps.v
+++ b/theories/FSets/FMaps.v
@@ -6,7 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMaps.v 8667 2006-03-28 11:59:44Z letouzey $ *)
+(* $Id: FMaps.v 8844 2006-05-22 17:22:36Z letouzey $ *)
 
+Require Export OrderedType.
+Require Export OrderedTypeEx.
+Require Export OrderedTypeAlt.
 Require Export FMapInterface.
 Require Export FMapList.
+Require Export FMapPositive.
+Require Export FMapIntMap.
+Require Export FMapFacts.
\ No newline at end of file
diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v
new file mode 100644
index 00000000..b385f50e
--- /dev/null
+++ b/theories/FSets/FSetAVL.v
@@ -0,0 +1,2900 @@
+
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: FSetAVL.v 8899 2006-06-06 11:09:43Z jforest $ *)
+
+(** This module implements sets using AVL trees.
+    It follows the implementation from Ocaml's standard library. *)
+
+Require Import FSetInterface.
+Require Import FSetList.
+Require Import ZArith.
+Require Import Int.
+
+Set Firstorder Depth 3.
+
+Module Raw (I:Int)(X:OrderedType).
+Import I.
+Module II:=MoreInt(I).
+Import II.
+Open Scope Int_scope.
+
+Module E := X.
+Module MX := OrderedTypeFacts X.
+
+Definition elt := X.t.
+
+(** * Trees *)
+
+Inductive tree : Set :=
+  | Leaf : tree
+  | Node : tree -> X.t -> tree -> int -> tree.
+
+Notation t := tree.
+
+(** The fourth field of [Node] is the height of the tree *)
+
+(** A tactic to repeat [inversion_clear] on all hyps of the 
+    form [(f (Node _ _ _ _))] *)
+Ltac inv f :=
+  match goal with 
+     | H:f Leaf |- _ => inversion_clear H; inv f
+     | H:f _ Leaf |- _ => inversion_clear H; inv f
+     | H:f (Node _ _ _ _) |- _ => inversion_clear H; inv f
+     | H:f _ (Node _ _ _ _) |- _ => inversion_clear H; inv f
+     | _ => idtac
+  end.
+
+(** Same, but with a backup of the original hypothesis. *)
+
+Ltac safe_inv f := match goal with 
+  | H:f (Node _ _ _ _) |- _ => 
+        generalize H; inversion_clear H; safe_inv f
+  | _ => intros 
+ end.
+
+(** * Occurrence in a tree *)
+
+Inductive In (x : elt) : tree -> Prop :=
+  | IsRoot :
+      forall (l r : tree) (h : int) (y : elt),
+      X.eq x y -> In x (Node l y r h)
+  | InLeft :
+      forall (l r : tree) (h : int) (y : elt),
+      In x l -> In x (Node l y r h)
+  | InRight :
+      forall (l r : tree) (h : int) (y : elt),
+      In x r -> In x (Node l y r h).
+
+Hint Constructors In.
+
+Ltac intuition_in := repeat progress (intuition; inv In).
+
+(** [In] is compatible with [X.eq] *)
+
+Lemma In_1 :
+ forall s x y, X.eq x y -> In x s -> In y s.
+Proof.
+ induction s; simpl; intuition_in; eauto.
+Qed.
+Hint Immediate In_1.
+
+(** * Binary search trees *)
+
+(** [lt_tree x s]: all elements in [s] are smaller than [x] 
+   (resp. greater for [gt_tree]) *)
+
+Definition lt_tree (x : elt) (s : tree) := 
+ forall y:elt, In y s -> X.lt y x.
+Definition gt_tree (x : elt) (s : tree) := 
+ forall y:elt, In y s -> X.lt x y.
+
+Hint Unfold lt_tree gt_tree.
+
+Ltac order := match goal with 
+ | H: lt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order
+ | H: gt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order
+ | _ => MX.order
+end.
+
+(** Results about [lt_tree] and [gt_tree] *)
+
+Lemma lt_leaf : forall x : elt, lt_tree x Leaf.
+Proof.
+ unfold lt_tree in |- *; intros; inversion H.
+Qed.
+
+Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
+Proof.
+  unfold gt_tree in |- *; intros; inversion H.
+Qed.
+
+Lemma lt_tree_node :
+ forall (x y : elt) (l r : tree) (h : int),
+ lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h).
+Proof.
+ unfold lt_tree in *; intuition_in; order.
+Qed.
+
+Lemma gt_tree_node :
+ forall (x y : elt) (l r : tree) (h : int),
+ gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h).
+Proof.
+ unfold gt_tree in *; intuition_in; order.
+Qed.
+
+Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
+
+Lemma lt_tree_not_in :
+ forall (x : elt) (t : tree), lt_tree x t -> ~ In x t.
+Proof.
+ intros; intro; order.
+Qed.
+
+Lemma lt_tree_trans :
+ forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t.
+Proof.
+ firstorder eauto.
+Qed.
+
+Lemma gt_tree_not_in :
+ forall (x : elt) (t : tree), gt_tree x t -> ~ In x t.
+Proof.
+ intros; intro; order.
+Qed.
+
+Lemma gt_tree_trans :
+ forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t.
+Proof.
+ firstorder eauto.
+Qed.
+
+Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
+
+(** [bst t] : [t] is a binary search tree *)
+
+Inductive bst : tree -> Prop :=
+  | BSLeaf : bst Leaf
+  | BSNode :
+      forall (x : elt) (l r : tree) (h : int),
+      bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (Node l x r h).
+
+Hint Constructors bst.
+
+(** * AVL trees *)
+
+(** [avl s] : [s] is a properly balanced AVL tree,
+    i.e. for any node the heights of the two children
+    differ by at most 2 *)
+
+Definition height (s : tree) : int :=
+  match s with
+  | Leaf => 0
+  | Node _ _ _ h => h
+  end.
+
+Inductive avl : tree -> Prop :=
+  | RBLeaf : avl Leaf
+  | RBNode :
+      forall (x : elt) (l r : tree) (h : int),
+      avl l ->
+      avl r ->
+      -(2) <= height l - height r <= 2 ->
+      h = max (height l) (height r) + 1 -> 
+      avl (Node l x r h).
+
+Hint Constructors avl.
+
+(** Results about [avl] *)
+
+Lemma avl_node :
+ forall (x : elt) (l r : tree),
+ avl l ->
+ avl r ->
+ -(2) <= height l - height r <= 2 ->
+ avl (Node l x r (max (height l) (height r) + 1)).
+Proof.
+  intros; auto.
+Qed.
+Hint Resolve avl_node.
+
+(** The tactics *)
+
+Lemma height_non_negative : forall s : tree, avl s -> height s >= 0.
+Proof.
+ induction s; simpl; intros; auto with zarith.
+ inv avl; intuition; omega_max.
+Qed.
+Implicit Arguments height_non_negative. 
+
+(** When [H:avl r], typing [avl_nn H] or [avl_nn r] adds [height r>=0] *)
+
+Ltac avl_nn_hyp H := 
+     let nz := fresh "nz" in assert (nz := height_non_negative H).
+
+Ltac avl_nn h := 
+  let t := type of h in 
+  match type of t with 
+   | Prop => avl_nn_hyp h
+   | _ => match goal with H : avl h |- _ => avl_nn_hyp H end
+  end.
+
+(* Repeat the previous tactic. 
+   Drawback: need to clear the [avl _] hyps ... Thank you Ltac *)
+
+Ltac avl_nns :=
+  match goal with 
+     | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns
+     | _ => idtac
+  end.
+
+(** * Some shortcuts. *)
+
+Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+Definition Subset s s' := forall a : elt, In a s -> In a s'.
+Definition Empty s := forall a : elt, ~ In a s.
+Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+
+(** * Empty set *)
+
+Definition empty := Leaf.
+
+Lemma empty_bst : bst empty.
+Proof.
+ auto.
+Qed.
+
+Lemma empty_avl : avl empty.
+Proof. 
+ auto.
+Qed.
+
+Lemma empty_1 : Empty empty.
+Proof.
+ intro; intro.
+ inversion H.
+Qed.
+
+(** * Emptyness test *)
+
+Definition is_empty (s:t) := match s with Leaf => true | _ => false end.
+
+Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. 
+Proof.
+ destruct s as [|r x l h]; simpl; auto.
+ intro H; elim (H x); auto.
+Qed.
+
+Lemma is_empty_2 : forall s, is_empty s = true -> Empty s.
+Proof. 
+ destruct s; simpl; intros; try discriminate; red; auto.
+Qed.
+
+(** * Appartness *)
+
+(** The [mem] function is deciding appartness. It exploits the [bst] property
+    to achieve logarithmic complexity. *)
+
+Function mem (x:elt)(s:t) { struct s } : bool := 
+   match s with 
+     |  Leaf => false 
+     |  Node l y r _ => match X.compare x y with 
+             | LT _ => mem x l 
+             | EQ _ => true
+             | GT _ => mem x r
+         end
+   end.
+
+Lemma mem_1 : forall s x, bst s -> In x s -> mem x s = true.
+Proof. 
+ intros s x.
+ functional induction (mem x s); inversion_clear 1; auto.
+ inversion_clear 1.
+ inversion_clear 1; auto; absurd (X.lt x y); eauto.
+ inversion_clear 1; auto; absurd (X.lt y x); eauto.
+Qed.
+
+Lemma mem_2 : forall s x, mem x s = true -> In x s. 
+Proof. 
+ intros s x. 
+ functional induction (mem x s); auto; intros; try discriminate.
+Qed.
+
+(** * Singleton set *)
+
+Definition singleton (x : elt) := Node Leaf x Leaf 1.
+
+Lemma singleton_bst : forall x : elt, bst (singleton x).
+Proof.
+ unfold singleton;  auto.
+Qed.
+
+Lemma singleton_avl : forall x : elt, avl (singleton x).
+Proof.
+ unfold singleton; intro.
+ constructor; auto; try red; simpl; omega_max.
+Qed.
+
+Lemma singleton_1 : forall x y, In y (singleton x) -> X.eq x y. 
+Proof. 
+ unfold singleton; inversion_clear 1; auto; inversion_clear H0.
+Qed.
+
+Lemma singleton_2 : forall x y, X.eq x y -> In y (singleton x). 
+Proof. 
+ unfold singleton; auto.
+Qed.
+
+(** * Helper functions *)
+
+(** [create l x r] creates a node, assuming [l] and [r]
+    to be balanced and [|height l - height r| <= 2]. *)
+
+Definition create l x r := 
+   Node l x r (max (height l) (height r) + 1).
+
+Lemma create_bst : 
+ forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> 
+ bst (create l x r).
+Proof.
+ unfold create; auto.
+Qed.
+Hint Resolve create_bst.
+
+Lemma create_avl : 
+ forall l x r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
+ avl (create l x r).
+Proof.
+ unfold create; auto.
+Qed.
+
+Lemma create_height : 
+ forall l x r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
+ height (create l x r) = max (height l) (height r) + 1.
+Proof.
+ unfold create; intros; auto.
+Qed.
+
+Lemma create_in : 
+ forall l x r y,  In y (create l x r) <-> X.eq y x \/ In y l \/ In y r.
+Proof.
+ unfold create; split; [ inversion_clear 1 | ]; intuition.
+Qed.
+
+(** trick for emulating [assert false] in Coq *)
+
+Definition assert_false := Leaf.
+
+(** [bal l x r] acts as [create], but performs one step of
+    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
+
+Definition bal l x r := 
+  let hl := height l in 
+  let hr := height r in
+  if gt_le_dec hl (hr+2) then 
+    match l with 
+     | Leaf => assert_false
+     | Node ll lx lr _ => 
+       if ge_lt_dec (height ll) (height lr) then 
+         create ll lx (create lr x r)
+       else 
+         match lr with 
+          | Leaf => assert_false 
+          | Node lrl lrx lrr _ => 
+              create (create ll lx lrl) lrx (create lrr x r)
+         end
+    end
+  else 
+    if gt_le_dec hr (hl+2) then 
+      match r with
+       | Leaf => assert_false
+       | Node rl rx rr _ =>
+         if ge_lt_dec (height rr) (height rl) then 
+            create (create l x rl) rx rr
+         else 
+           match rl with
+            | Leaf => assert_false
+            | Node rll rlx rlr _ => 
+                create (create l x rll) rlx (create rlr rx rr) 
+           end
+      end
+    else 
+      create l x r. 
+
+Ltac bal_tac := 
+ intros l x r;
+ unfold bal; 
+ destruct (gt_le_dec (height l) (height r + 2)); 
+   [ destruct l as [ |ll lx lr lh]; 
+     [ | destruct (ge_lt_dec (height ll) (height lr)); 
+          [ | destruct lr ] ]
+   | destruct (gt_le_dec (height r) (height l + 2)); 
+     [ destruct r as [ |rl rx rr rh];
+          [ | destruct (ge_lt_dec (height rr) (height rl)); 
+               [ | destruct rl ] ]
+     | ] ]; intros.
+
+Lemma bal_bst : forall l x r, bst l -> bst r -> 
+ lt_tree x l -> gt_tree x r -> bst (bal l x r).
+Proof.
+ (* intros l x r; functional induction bal l x r. MARCHE PAS !*) 
+ bal_tac; 
+ inv bst; repeat apply create_bst; auto; unfold create; 
+ apply lt_tree_node || apply gt_tree_node; auto; 
+ eapply lt_tree_trans || eapply gt_tree_trans || eauto; eauto.
+Qed.
+
+Lemma bal_avl : forall l x r, avl l -> avl r -> 
+ -(3) <= height l - height r <= 3 -> avl (bal l x r).
+Proof.
+ bal_tac; inv avl; repeat apply create_avl; simpl in *; auto; omega_max.
+Qed.
+
+Lemma bal_height_1 : forall l x r, avl l -> avl r -> 
+ -(3) <= height l - height r <= 3 ->
+ 0 <= height (bal l x r) - max (height l) (height r) <= 1.
+Proof.
+ bal_tac; inv avl; avl_nns; simpl in *; omega_max.
+Qed.
+
+Lemma bal_height_2 : 
+ forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> 
+ height (bal l x r) == max (height l) (height r) +1.
+Proof.
+ bal_tac; inv avl; simpl in *; omega_max.
+Qed.
+
+Lemma bal_in : forall l x r y, avl l -> avl r -> 
+ (In y (bal l x r) <-> X.eq y x \/ In y l \/ In y r).
+Proof.
+ bal_tac; 
+ solve [repeat rewrite create_in; intuition_in
+       |inv avl; avl_nns; simpl in *; false_omega].
+Qed.
+
+Ltac omega_bal := match goal with 
+  | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?r ] => 
+     generalize (bal_height_1 l x r H H') (bal_height_2 l x r H H'); 
+     omega_max
+  end. 
+
+(** * Insertion *)
+
+Function add (x:elt)(s:t) { struct s } : t := match s with 
+   | Leaf => Node Leaf x Leaf 1
+   | Node l y r h => 
+      match X.compare x y with
+         | LT _ => bal (add x l) y r
+         | EQ _ => Node l y r h
+         | GT _ => bal l y (add x r)
+      end
+  end.
+
+Lemma add_avl_1 :  forall s x, avl s -> 
+ avl (add x s) /\ 0 <= height (add x s) - height s <= 1.
+Proof. 
+ intros s x; functional induction (add x s); subst;intros; inv avl; simpl in *.
+ intuition; try constructor; simpl; auto; try omega_max.
+ (* LT *)
+ destruct IHt; auto.
+ split.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+ (* EQ *)
+ intuition; omega_max.
+ (* GT *)
+ destruct IHt; auto.
+ split.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+Qed.
+
+Lemma add_avl : forall s x, avl s -> avl (add x s).
+Proof.
+ intros; generalize (add_avl_1 s x H); intuition.
+Qed.
+Hint Resolve add_avl.
+
+Lemma add_in : forall s x y, avl s -> 
+ (In y (add x s) <-> X.eq y x \/ In y s).
+Proof.
+ intros s x; functional induction (add x s); auto; intros.
+ intuition_in.
+ (* LT *)
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite (IHt y0 H1); intuition_in.
+ (* EQ *)  
+ inv avl.
+ intuition.
+ eapply In_1; eauto.
+ (* GT *)
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite (IHt y0 H2); intuition_in.
+Qed.
+
+Lemma add_bst : forall s x, bst s -> avl s -> bst (add x s).
+Proof. 
+ intros s x; functional induction (add x s); auto; intros.
+ inv bst; inv avl; apply bal_bst; auto.
+ (* lt_tree -> lt_tree (add ...) *)
+ red; red in H5.
+ intros.
+ rewrite (add_in l x y0 H) in H1.
+ intuition.
+ eauto.
+ inv bst; inv avl; apply bal_bst; auto.
+ (* gt_tree -> gt_tree (add ...) *)
+ red; red in H5.
+ intros.
+ rewrite (add_in r x y0 H6) in H1.
+ intuition.
+ apply MX.lt_eq with x; auto.
+Qed.
+
+(** * Join
+
+    Same as [bal] but does not assume anything regarding heights
+    of [l] and [r].
+*)
+
+Fixpoint join (l:t) : elt -> t -> t :=
+  match l with
+    | Leaf => add
+    | Node ll lx lr lh => fun x => 
+       fix join_aux (r:t) : t := match r with 
+          | Leaf =>  add x l
+          | Node rl rx rr rh =>  
+               if gt_le_dec lh (rh+2) then bal ll lx (join lr x r)
+               else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr 
+               else create l x r
+          end
+  end.
+
+Ltac join_tac := 
+ intro l; induction l as [| ll _ lx lr Hlr lh]; 
+   [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join;
+     [ | destruct (gt_le_dec lh (rh+2)); 
+       [ match goal with |- context b [ bal ?a ?b ?c] => 
+           replace (bal a b c) 
+           with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto] 
+         end 
+       | destruct (gt_le_dec rh (lh+2)); 
+         [ match goal with |- context b [ bal ?a ?b ?c] => 
+             replace (bal a b c) 
+             with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto] 
+           end
+         | ] ] ] ]; intros.
+
+Lemma join_avl_1 : forall l x r, avl l -> avl r -> avl (join l x r) /\
+ 0<= height (join l x r) - max (height l) (height r) <= 1.
+Proof. 
+ (* intros l x r; functional induction join l x r. AUTRE PROBLEME! *)
+ join_tac.
+
+ split; simpl; auto. 
+ destruct (add_avl_1 r x H0).
+ avl_nns; omega_max.
+ split; auto.
+ set (l:=Node ll lx lr lh) in *.
+ destruct (add_avl_1 l x H).
+ simpl (height Leaf).
+ avl_nns; omega_max.
+
+ inversion_clear H.
+ assert (height (Node rl rx rr rh) = rh); auto.
+ set (r := Node rl rx rr rh) in *; clearbody r.
+ destruct (Hlr x r H2 H0); clear Hrl Hlr.
+ set (j := join lr x r) in *; clearbody j.
+ simpl.
+ assert (-(3) <= height ll - height j <= 3) by omega_max.
+ split.
+ apply bal_avl; auto.
+ omega_bal.
+
+ inversion_clear H0.
+ assert (height (Node ll lx lr lh) = lh); auto.
+ set (l := Node ll lx lr lh) in *; clearbody l.
+ destruct (Hrl H H1); clear Hrl Hlr.
+ set (j := join l x rl) in *; clearbody j.
+ simpl.
+ assert (-(3) <= height j - height rr <= 3) by omega_max.
+ split.
+ apply bal_avl; auto.
+ omega_bal.
+
+ clear Hrl Hlr.
+ assert (height (Node ll lx lr lh) = lh); auto.
+ assert (height (Node rl rx rr rh) = rh); auto.
+ set (l := Node ll lx lr lh) in *; clearbody l.
+ set (r := Node rl rx rr rh) in *; clearbody r.
+ assert (-(2) <= height l - height r <= 2) by omega_max.
+ split.
+ apply create_avl; auto.
+ rewrite create_height; auto; omega_max.
+Qed.
+
+Lemma join_avl : forall l x r, avl l -> avl r -> avl (join l x r).
+Proof.
+ intros; generalize (join_avl_1 l x r H H0); intuition.
+Qed.
+Hint Resolve join_avl.
+
+Lemma join_in : forall l x r y, avl l -> avl r -> 
+     (In y (join l x r) <-> X.eq y x \/ In y l \/ In y r).
+Proof.
+ join_tac.
+ simpl.
+ rewrite add_in; intuition_in.
+
+ rewrite add_in; intuition_in.
+
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite Hlr; clear Hlr Hrl; intuition_in.
+
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite Hrl; clear Hlr Hrl; intuition_in.
+
+ apply create_in.
+Qed.
+
+Lemma join_bst : forall l x r, bst l -> avl l -> bst r -> avl r -> 
+ lt_tree x l -> gt_tree x r -> bst (join l x r).
+Proof.
+ join_tac.
+ apply add_bst; auto.
+ apply add_bst; auto.
+
+ inv bst; safe_inv avl.
+ apply bal_bst; auto.
+ clear Hrl Hlr H13 H14 H16 H17 z; intro; intros.
+ set (r:=Node rl rx rr rh) in *; clearbody r.
+ rewrite (join_in lr x r y) in H13; auto.
+ intuition.
+ apply MX.lt_eq with x; eauto.
+ eauto.
+
+ inv bst; safe_inv avl.
+ apply bal_bst; auto.
+ clear Hrl Hlr H13 H14 H16 H17 z; intro; intros.
+ set (l:=Node ll lx lr lh) in *; clearbody l.
+ rewrite (join_in l x rl y) in H13; auto.
+ intuition.
+ apply MX.eq_lt with x; eauto.
+ eauto.
+
+ apply create_bst; auto.
+Qed.
+
+(** * Extraction of minimum element
+
+  morally, [remove_min] is to be applied to a non-empty tree 
+  [t = Node l x r h]. Since we can't deal here with [assert false] 
+  for [t=Leaf], we pre-unpack [t] (and forget about [h]). 
+*)
+ 
+Function remove_min (l:t)(x:elt)(r:t) { struct l } : t*elt := 
+  match l with 
+    | Leaf => (r,x)
+    | Node ll lx lr lh => let (l',m) := (remove_min ll lx lr : t*elt) in (bal l' x r, m)
+  end.
+
+Lemma remove_min_avl_1 : forall l x r h, avl (Node l x r h) -> 
+ avl (fst (remove_min l x r)) /\ 
+ 0 <= height (Node l x r h) - height (fst (remove_min l x r)) <= 1.
+Proof.
+ intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros.
+ inv avl; simpl in *; split; auto.
+ avl_nns; omega_max.
+ (* l = Node *)
+ inversion_clear H.
+ rewrite H0 in IHp;simpl in IHp;destruct (IHp lh); auto.
+ split; simpl in *. 
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+Qed.
+
+Lemma remove_min_avl : forall l x r h, avl (Node l x r h) -> 
+    avl (fst (remove_min l x r)). 
+Proof.
+ intros; generalize (remove_min_avl_1 l x r h H); intuition.
+Qed.
+
+Lemma remove_min_in : forall l x r h y, avl (Node l x r h) -> 
+ (In y (Node l x r h) <-> 
+  X.eq y (snd (remove_min l x r)) \/ In y (fst (remove_min l x r))).
+Proof.
+ intros l x r; functional induction (remove_min l x r); simpl in *; intros.
+ intuition_in.
+ (* l = Node *)
+ inversion_clear H.
+ generalize (remove_min_avl ll lx lr lh H1).
+ rewrite H0; simpl; intros.
+ rewrite bal_in; auto.
+ rewrite H0 in IHp;generalize (IHp lh y H1).
+ intuition.
+ inversion_clear H8; intuition.
+Qed.
+
+Lemma remove_min_bst : forall l x r h, 
+ bst (Node l x r h) -> avl (Node l x r h) -> bst (fst (remove_min l x r)).
+Proof.
+ intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros.
+ inv bst; auto.
+ inversion_clear H; inversion_clear H1.
+ rewrite_all H0;simpl in *.
+ apply bal_bst; auto.
+ firstorder.
+ intro; intros.
+ generalize (remove_min_in ll lx lr lh y H).
+ rewrite H0; simpl.
+ destruct 1.
+ apply H4; intuition.
+Qed.
+
+Lemma remove_min_gt_tree : forall l x r h, 
+ bst (Node l x r h) -> avl (Node l x r h) -> 
+ gt_tree (snd (remove_min l x r)) (fst (remove_min l x r)).
+Proof.
+ intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros.
+ inv bst; auto.
+ inversion_clear H; inversion_clear H1.
+ intro; intro.
+ generalize (IHp lh H2 H); clear H8 H7 IHp.
+ generalize (remove_min_avl ll lx lr lh H).
+ generalize (remove_min_in ll lx lr lh m H).
+ rewrite H0; simpl; intros.
+ rewrite (bal_in l' x r y H8 H6) in H1.
+ destruct H7.
+ firstorder.
+ apply MX.lt_eq with x; auto.
+ apply X.lt_trans with x; auto.
+Qed.
+
+(** * Merging two trees
+
+  [merge t1 t2] builds the union of [t1] and [t2] assuming all elements
+  of [t1] to be smaller than all elements of [t2], and
+  [|height t1 - height t2| <= 2].
+*)
+
+Function merge (s1 s2 :t) : t:=  match s1,s2 with 
+  | Leaf, _ => s2 
+  | _, Leaf => s1
+  | _, Node l2 x2 r2 h2 => 
+        let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2'
+end.
+
+Lemma merge_avl_1 : forall s1 s2, avl s1 -> avl s2 -> 
+ -(2) <= height s1 - height s2 <= 2 -> 
+ avl (merge s1 s2) /\ 
+ 0<= height (merge s1 s2) - max (height s1) (height s2) <=1.
+Proof.
+ intros s1 s2; functional induction (merge s1 s2); subst;simpl in *; intros.
+ split; auto; avl_nns; omega_max.
+ split; auto; avl_nns; simpl in *; omega_max.
+ destruct s1;try contradiction;clear H1.
+ generalize (remove_min_avl_1 l2 x2 r2 h2 H0).
+ rewrite H2; simpl; destruct 1.
+ split.
+ apply bal_avl; auto.
+ simpl; omega_max.
+ omega_bal.
+Qed.
+
+Lemma merge_avl : forall s1 s2, avl s1 -> avl s2 -> 
+  -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2).
+Proof. 
+ intros; generalize (merge_avl_1 s1 s2 H H0 H1); intuition.
+Qed.
+
+Lemma merge_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (In y (merge s1 s2) <-> In y s1 \/ In y s2).
+Proof. 
+ intros s1 s2; functional induction (merge s1 s2); subst; simpl in *; intros.
+ intuition_in.
+ intuition_in.
+ destruct s1;try contradiction;clear H1.
+ replace s2' with (fst (remove_min l2 x2 r2)); [|rewrite H2; auto].
+ rewrite bal_in; auto.
+ generalize (remove_min_avl l2 x2 r2 h2); rewrite H2; simpl; auto.
+ generalize (remove_min_in l2 x2 r2 h2 y); rewrite H2; simpl; intro.
+ rewrite H1; intuition.
+Qed.
+
+Lemma merge_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> 
+ bst (merge s1 s2). 
+Proof.
+ intros s1 s2; functional induction (merge s1 s2); subst;simpl in *; intros; auto.
+ destruct s1;try contradiction;clear H1.
+ apply bal_bst; auto.
+ generalize (remove_min_bst l2 x2 r2 h2); rewrite H2; simpl in *; auto.
+ intro; intro.
+ apply H5; auto.
+ generalize (remove_min_in l2 x2 r2 h2 m); rewrite H2; simpl; intuition.
+ generalize (remove_min_gt_tree l2 x2 r2 h2); rewrite H2; simpl; auto.
+Qed. 
+
+(** * Deletion *)
+
+Function remove (x:elt)(s:tree) { struct s } : t := match s with 
+  | Leaf => Leaf
+  | Node l y r h =>
+      match X.compare x y with
+         | LT _ => bal (remove x l) y r
+         | EQ _ => merge l r
+         | GT _ => bal l  y (remove x r)
+      end
+   end.
+
+Lemma remove_avl_1 : forall s x, avl s -> 
+ avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1.
+Proof.
+ intros s x; functional induction (remove x s); subst;simpl; intros.
+ intuition; omega_max.
+ (* LT *)
+ inv avl.
+ destruct (IHt H1).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+ (* EQ *)
+ inv avl. 
+ generalize (merge_avl_1 l r H1 H2 H3).
+ intuition omega_max.
+ (* GT *)
+ inv avl.
+ destruct (IHt H2).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+Qed.
+
+Lemma remove_avl : forall s x, avl s -> avl (remove x s).
+Proof. 
+ intros; generalize (remove_avl_1 s x H); intuition.
+Qed.
+Hint Resolve remove_avl.
+
+Lemma remove_in : forall s x y, bst s -> avl s -> 
+ (In y (remove x s) <-> ~ X.eq y x /\ In y s).
+Proof.
+ intros s x; functional induction (remove x s); subst;simpl; intros.
+ intuition_in.
+ (* LT *)
+ inv avl; inv bst; clear H0.
+ rewrite bal_in; auto.
+ generalize (IHt y0 H1); intuition; [ order | order | intuition_in ].
+ (* EQ *)
+ inv avl; inv bst; clear H0.
+ rewrite merge_in; intuition; [ order | order | intuition_in ].
+ elim H9; eauto.
+ (* GT *)
+ inv avl; inv bst; clear H0.
+ rewrite bal_in; auto.
+ generalize (IHt y0 H6); intuition; [ order | order | intuition_in ].
+Qed.
+
+Lemma remove_bst : forall s x, bst s -> avl s -> bst (remove x s).
+Proof. 
+ intros s x; functional induction (remove x s); simpl; intros.
+ auto.
+ (* LT *)
+ inv avl; inv bst.
+ apply bal_bst; auto.
+ intro; intro.
+ rewrite (remove_in l x y0) in H; auto.
+ destruct H; eauto.
+ (* EQ *)
+ inv avl; inv bst.
+ apply merge_bst; eauto.
+ (* GT *) 
+ inv avl; inv bst.
+ apply bal_bst; auto.
+ intro; intro.
+ rewrite (remove_in r x y0) in H; auto.
+ destruct H; eauto.
+Qed.
+
+ (** * Minimum element *)
+
+Function min_elt (s:t) : option elt := match s with 
+   | Leaf => None
+   | Node Leaf y _  _ => Some y
+   | Node l _ _ _ => min_elt l
+end.
+
+Lemma min_elt_1 : forall s x, min_elt s = Some x -> In x s. 
+Proof. 
+ intro s; functional induction (min_elt s); subst; simpl.
+ inversion 1.
+ inversion 1; auto.
+ intros.
+ destruct l; auto.
+Qed.
+
+Lemma min_elt_2 : forall s x y, bst s -> 
+ min_elt s = Some x -> In y s -> ~ X.lt y x. 
+Proof.
+ intro s; functional induction (min_elt s); subst;simpl.
+ inversion_clear 2.
+ inversion_clear 1.
+ inversion 1; subst.
+ inversion_clear 1; auto.
+ inversion_clear H5.
+ destruct l;try contradiction.
+ inversion_clear 1.
+ simpl.
+ destruct l1.
+ inversion 1; subst.
+ assert (X.lt x _x) by (apply H3; auto).
+ inversion_clear 1; auto; order.
+ assert (X.lt t _x) by auto.
+ inversion_clear 2; auto; 
+   (assert (~ X.lt t x) by auto); order.
+Qed.
+
+Lemma min_elt_3 : forall s, min_elt s = None -> Empty s.
+Proof.
+ intro s; functional induction (min_elt s); subst;simpl.
+ red; auto.
+ inversion 1.
+ destruct l;try contradiction. 
+ clear H0;intro H0.
+ destruct (IHo H0 t);  auto.
+Qed.
+
+
+(** * Maximum element *)
+
+Function max_elt (s:t) : option elt := match s with 
+   | Leaf => None
+   | Node _ y Leaf  _ => Some y
+   | Node _ _ r _ => max_elt r
+end.
+
+Lemma max_elt_1 : forall s x, max_elt s = Some x -> In x s. 
+Proof. 
+ intro s; functional induction (max_elt s); subst;simpl.
+ inversion 1.
+ inversion 1; auto.
+ destruct r;try contradiction; auto.
+Qed.
+
+Lemma max_elt_2 : forall s x y, bst s -> 
+ max_elt s = Some x -> In y s -> ~ X.lt x y. 
+Proof.
+ intro s; functional induction (max_elt s); subst;simpl.
+ inversion_clear 2.
+ inversion_clear 1.
+ inversion 1; subst.
+ inversion_clear 1; auto.
+ inversion_clear H5.
+ destruct r;try contradiction.
+ inversion_clear 1.
+(*  inversion 1; subst. *)
+(*  assert (X.lt y x) by (apply H4; auto). *)
+(*  inversion_clear 1; auto; order. *)
+ assert (X.lt _x0 t) by auto.
+ inversion_clear 2; auto; 
+  (assert (~ X.lt x t) by auto); order.
+Qed.
+
+Lemma max_elt_3 : forall s, max_elt s = None -> Empty s.
+Proof.
+ intro s; functional induction (max_elt s); subst;simpl.
+ red; auto.
+ inversion 1.
+ destruct r;try contradiction.
+ clear H0;intros H0; destruct (IHo H0 t); auto.
+Qed.
+
+(** * Any element *)
+
+Definition choose := min_elt.
+
+Lemma choose_1 : forall s x, choose s = Some x -> In x s.
+Proof. 
+ exact min_elt_1.
+Qed.
+
+Lemma choose_2 : forall s, choose s = None -> Empty s.
+Proof. 
+ exact min_elt_3.
+Qed.
+
+(** * Concatenation
+
+    Same as [merge] but does not assume anything about heights.
+*)
+
+Function concat (s1 s2 : t) : t  := 
+   match s1, s2 with 
+      | Leaf, _ => s2 
+      | _, Leaf => s1
+      | _, Node l2 x2 r2 h2 => 
+            let (s2',m) := remove_min l2 x2 r2 in 
+            join s1 m s2'
+   end.
+
+Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2).
+Proof.
+ intros s1 s2; functional induction (concat s1 s2); subst;auto.
+ destruct s1;try contradiction;clear H1.
+ intros; apply join_avl; auto.
+ generalize (remove_min_avl l2 x2 r2 h2 H0); rewrite H2; simpl; auto.
+Qed.
+ 
+Lemma concat_bst :   forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> 
+ bst (concat s1 s2).
+Proof. 
+ intros s1 s2; functional induction (concat s1 s2); subst ;auto.
+ destruct s1;try contradiction;clear H1. 
+ intros;  apply join_bst; auto.
+ generalize (remove_min_bst l2 x2 r2 h2 H1 H3); rewrite H2; simpl; auto.
+ generalize (remove_min_avl l2 x2 r2 h2 H3); rewrite H2; simpl; auto.
+ generalize (remove_min_in l2 x2 r2 h2 m H3); rewrite H2; simpl; auto.
+ destruct 1; intuition.
+ generalize (remove_min_gt_tree l2 x2 r2 h2 H1 H3); rewrite H2; simpl; auto.
+Qed.
+
+Lemma concat_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> 
+ (In y (concat s1 s2) <-> In y s1 \/ In y s2).
+Proof.
+ intros s1 s2; functional induction (concat s1 s2);subst;simpl.
+ intuition.
+ inversion_clear H5.
+ destruct s1;try contradiction;clear H1;intuition.
+ inversion_clear H5.
+ destruct s1;try contradiction;clear H1; intros. 
+ rewrite (join_in  (Node s1_1 t s1_2 i) m s2' y H0).
+ generalize (remove_min_avl l2 x2 r2 h2 H3); rewrite H2; simpl; auto.
+ generalize (remove_min_in l2 x2 r2 h2 y H3); rewrite H2; simpl.
+ intro EQ; rewrite EQ; intuition.
+Qed.
+
+(** * Splitting 
+
+    [split x s] returns a triple [(l, present, r)] where
+    - [l] is the set of elements of [s] that are [< x]
+    - [r] is the set of elements of [s] that are [> x]
+    - [present] is [true] if and only if [s] contains  [x].
+*)
+
+Function split (x:elt)(s:t) {struct s} : t * (bool * t) := match s with 
+  | Leaf => (Leaf, (false, Leaf))
+  | Node l y r h => 
+     match X.compare x y with 
+      | LT _ => match split x l with 
+                 | (ll,(pres,rl)) => (ll, (pres, join rl y r))
+                end
+      | EQ _ => (l, (true, r))
+      | GT _ => match split x r with 
+                 | (rl,(pres,rr)) => (join l y rl, (pres, rr))
+                end
+     end
+ end.
+
+Lemma split_avl : forall s x, avl s -> 
+  avl (fst (split x s)) /\ avl (snd (snd (split x s))).
+Proof. 
+ intros s x; functional induction (split x s);subst;simpl in *.
+ auto.
+ rewrite H1 in IHp;simpl in IHp;inversion_clear 1; intuition.
+ simpl; inversion_clear 1; auto.
+ rewrite H1 in IHp;simpl in IHp;inversion_clear 1; intuition.
+Qed.
+
+Lemma split_in_1 : forall s x y, bst s -> avl s -> 
+ (In y (fst (split x s)) <-> In y s /\ X.lt y x).
+Proof. 
+ intros s x; functional induction (split x s);subst;simpl in *.
+ intuition; try inversion_clear H1.
+ (* LT *)
+ rewrite H1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear  H8 H9.
+ rewrite (IHp y0 H2 H6); clear IHp H0.
+ intuition.
+ inversion_clear H0; auto; order.
+ (* EQ *)
+ simpl in *; inversion_clear 1; inversion_clear 1; clear H8 H7 H0.
+ intuition.
+ order.
+ intuition_in; order.
+ (* GT *)
+ rewrite H1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8.
+ rewrite join_in; auto.
+ generalize (split_avl r x H7); rewrite H1; simpl; intuition.
+ rewrite (IHp y0 H3 H7); clear H1.
+ intuition; [ eauto | eauto | intuition_in ].
+Qed.
+
+Lemma split_in_2 : forall s x y, bst s -> avl s -> 
+ (In y (snd (snd (split x s))) <-> In y s /\ X.lt x y).
+Proof. 
+ intros s x; functional induction (split x s);subst;simpl in *.
+ intuition; try inversion_clear H1.
+ (* LT *)
+ rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8.
+  rewrite join_in; auto.
+ generalize (split_avl l x H6); rewrite H1; simpl; intuition.
+ rewrite (IHp y0 H2 H6); clear IHp H0.
+ intuition; [ order | order | intuition_in ].
+ (* EQ *)
+ simpl in *; inversion_clear 1; inversion_clear 1; clear H8 H7 H0.
+ intuition; [ order | intuition_in; order ]. 
+ (* GT *)
+ rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8.
+ rewrite (IHp y0 H3 H7); clear IHp H0.
+ intuition; intuition_in; order. 
+Qed.
+
+Lemma split_in_3 : forall s x, bst s -> avl s -> 
+ (fst (snd (split x s)) = true <-> In x s).
+Proof. 
+ intros s x; functional induction (split x s);subst;simpl in *.
+ intuition; try inversion_clear H1.
+ (* LT *)
+ rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8.
+ rewrite IHp; auto.
+ intuition_in; absurd (X.lt x y); eauto.
+ (* EQ *)
+ simpl in *; inversion_clear 1; inversion_clear 1; intuition.
+ (* GT *)
+ rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8.
+ rewrite IHp; auto.
+ intuition_in; absurd (X.lt y x); eauto.
+Qed.
+
+Lemma split_bst : forall s x, bst s -> avl s -> 
+ bst (fst (split x s)) /\ bst (snd (snd (split x s))).
+Proof. 
+ intros s x; functional induction (split x s);subst;simpl in *.  
+ intuition.
+ (* LT *)
+ rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1.
+ intuition.
+ apply join_bst; auto.
+ generalize (split_avl l x H6); rewrite H1; simpl; intuition.
+ intro; intro.
+ generalize (split_in_2 l x y0 H2 H6); rewrite H1; simpl; intuition.
+ (* EQ *)
+ simpl in *; inversion_clear 1; inversion_clear 1; intuition.
+ (* GT *)
+ rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1.
+ intuition.
+ apply join_bst; auto.
+ generalize (split_avl r x H7); rewrite H1; simpl; intuition.
+ intro; intro.
+ generalize (split_in_1 r x y0 H3 H7); rewrite H1; simpl; intuition.
+Qed.
+
+(** * Intersection *)
+
+Fixpoint inter (s1 s2 : t) {struct s1} : t := match s1, s2 with 
+    | Leaf,_ => Leaf
+    | _,Leaf => Leaf
+    | Node l1 x1 r1 h1, _ => 
+            match split x1 s2 with
+               | (l2',(true,r2')) => join (inter l1 l2') x1 (inter r1 r2')
+               | (l2',(false,r2')) => concat (inter l1 l2') (inter r1 r2')
+            end
+    end.
+
+Lemma inter_avl : forall s1 s2, avl s1 -> avl s2 -> avl (inter s1 s2). 
+Proof. 
+ (* intros s1 s2; functional induction inter s1 s2; auto. BOF BOF *)
+ induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto.
+ destruct s2 as [ | l2 x2 r2 h2]; intros; auto.
+ generalize H0; inv avl.
+ set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros. 
+ destruct (split_avl r x1 H8).
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct b; [ apply join_avl | apply concat_avl ]; auto.
+Qed.
+
+Lemma inter_bst_in : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ bst (inter s1 s2) /\ (forall y, In y (inter s1 s2) <-> In y s1 /\ In y s2).
+Proof. 
+ induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto.
+ intuition; inversion_clear H3.
+ destruct s2 as [ | l2 x2 r2 h2]; intros.
+ simpl; intuition; inversion_clear H3.
+ generalize H1 H2; inv avl; inv bst.
+ set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros.
+ destruct (split_avl r x1 H17).
+ destruct (split_bst r x1 H16 H17).
+ split.
+ (* bst *)
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct (Hl1 l2'); auto.
+ destruct (Hr1 r2'); auto.
+ destruct b.
+ (* bst join *)
+ apply join_bst; try apply inter_avl; firstorder.
+ (* bst concat *)
+ apply concat_bst; try apply inter_avl; auto.
+ intros; generalize (H22 y1) (H24 y2); intuition eauto.
+ (* in *)
+ intros.
+ destruct (split_in_1 r x1 y H16 H17). 
+ destruct (split_in_2 r x1 y H16 H17).
+ destruct (split_in_3 r x1 H16 H17).
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct (Hl1 l2'); auto.
+ destruct (Hr1 r2'); auto.
+ destruct b.
+ (* in join *)
+ rewrite join_in; try apply inter_avl; auto.
+ rewrite H30.
+ rewrite H28.
+ intuition_in.
+ apply In_1 with x1; auto.
+ (* in concat *)
+ rewrite concat_in; try apply inter_avl; auto.
+ intros.
+ intros; generalize (H28 y1) (H30 y2); intuition eauto.
+ rewrite H30.
+ rewrite H28.
+ intuition_in.
+ generalize (H26 (In_1 _ _ _ H22 H35)); intro; discriminate.
+Qed.
+
+Lemma inter_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ bst (inter s1 s2). 
+Proof. 
+ intros; generalize (inter_bst_in s1 s2); intuition.
+Qed.
+
+Lemma inter_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (In y (inter s1 s2) <-> In y s1 /\ In y s2).
+Proof. 
+ intros; generalize (inter_bst_in s1 s2); firstorder.
+Qed.
+
+(** * Difference *)
+
+Fixpoint diff (s1 s2 : t) { struct s1 } : t := match s1, s2 with 
+ | Leaf, _ => Leaf
+ | _, Leaf => s1
+ | Node l1 x1 r1 h1, _ => 
+    match split x1 s2 with 
+      | (l2',(true,r2')) => concat (diff l1 l2') (diff r1 r2')
+      | (l2',(false,r2')) => join (diff l1 l2') x1 (diff r1 r2')
+    end
+end. 
+
+Lemma diff_avl : forall s1 s2, avl s1 -> avl s2 -> avl (diff s1 s2). 
+Proof. 
+ (* intros s1 s2; functional induction diff s1 s2; auto. BOF BOF *)
+ induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto.
+ destruct s2 as [ | l2 x2 r2 h2]; intros; auto.
+ generalize H0; inv avl.
+ set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros. 
+ destruct (split_avl r x1 H8).
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct b; [ apply concat_avl | apply join_avl ]; auto.
+Qed.
+
+Lemma diff_bst_in : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ bst (diff s1 s2) /\ (forall y, In y (diff s1 s2) <-> In y s1 /\ ~In y s2).
+Proof. 
+ induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto.
+ intuition; inversion_clear H3.
+ destruct s2 as [ | l2 x2 r2 h2]; intros; auto.
+ intuition; inversion_clear H4.
+ generalize H1 H2; inv avl; inv bst.
+ set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros.
+ destruct (split_avl r x1 H17).
+ destruct (split_bst r x1 H16 H17).
+ split.
+ (* bst *)
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct (Hl1 l2'); auto.
+ destruct (Hr1 r2'); auto.
+ destruct b.
+ (* bst concat *)
+ apply concat_bst; try apply diff_avl; auto.
+ intros; generalize (H22 y1) (H24 y2); intuition eauto.
+ (* bst join *)
+ apply join_bst; try apply diff_avl; firstorder.
+ (* in *)
+ intros.
+ destruct (split_in_1 r x1 y H16 H17). 
+ destruct (split_in_2 r x1 y H16 H17).
+ destruct (split_in_3 r x1 H16 H17).
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct (Hl1 l2'); auto.
+ destruct (Hr1 r2'); auto.
+ destruct b.
+ (* in concat *)
+ rewrite concat_in; try apply diff_avl; auto.
+ intros.
+ intros; generalize (H28 y1) (H30 y2); intuition eauto.
+ rewrite H30.
+ rewrite H28.
+ intuition_in.
+ elim H35; apply In_1 with x1; auto.
+ (* in join *)
+ rewrite join_in; try apply diff_avl; auto.
+ rewrite H30.
+ rewrite H28.
+ intuition_in.
+ generalize (H26 (In_1 _ _ _ H34 H24)); intro; discriminate.
+Qed.
+
+Lemma diff_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ bst (diff s1 s2). 
+Proof. 
+ intros; generalize (diff_bst_in s1 s2); intuition.
+Qed.
+
+Lemma diff_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (In y (diff s1 s2) <-> In y s1 /\ ~In y s2).
+Proof. 
+ intros; generalize (diff_bst_in s1 s2); firstorder.
+Qed.
+
+(** * Elements *)
+
+(** [elements_tree_aux acc t] catenates the elements of [t] in infix
+    order to the list [acc] *)
+
+Fixpoint elements_aux (acc : list X.t) (t : tree) {struct t} : list X.t :=
+  match t with
+   | Leaf => acc
+   | Node l x r _ => elements_aux (x :: elements_aux acc r) l
+  end.
+
+(** then [elements] is an instanciation with an empty [acc] *)
+
+Definition elements := elements_aux nil.
+
+Lemma elements_aux_in : forall s acc x, 
+ InA X.eq x (elements_aux acc s) <-> In x s \/ InA X.eq x acc.
+Proof.
+ induction s as [ | l Hl x r Hr h ]; simpl; auto.
+ intuition.
+ inversion H0.
+ intros.
+ rewrite Hl.
+ destruct (Hr acc x0); clear Hl Hr.
+ intuition; inversion_clear H3; intuition.
+Qed.
+
+Lemma elements_in : forall s x, InA X.eq x (elements s) <-> In x s. 
+Proof. 
+ intros; generalize (elements_aux_in s nil x); intuition.
+ inversion_clear H0.
+Qed.
+
+Lemma elements_aux_sort : forall s acc, bst s -> sort X.lt acc ->
+ (forall x y : elt, InA X.eq x acc -> In y s -> X.lt y x) ->
+ sort X.lt (elements_aux acc s).
+Proof.
+ induction s as [ | l Hl y r Hr h]; simpl; intuition.
+ inv bst.
+ apply Hl; auto.
+ constructor. 
+ apply Hr; auto.
+ apply MX.In_Inf; intros.
+ destruct (elements_aux_in r acc y0); intuition.
+ intros.
+ inversion_clear H.
+ order.
+ destruct (elements_aux_in r acc x); intuition eauto.
+Qed.
+
+Lemma elements_sort : forall s : tree, bst s -> sort X.lt (elements s).
+Proof.
+ intros; unfold elements; apply elements_aux_sort; auto.
+ intros; inversion H0.
+Qed.
+Hint Resolve elements_sort.
+
+(** * Filter *)
+
+Section F.
+Variable f : elt -> bool.
+
+Fixpoint filter_acc (acc:t)(s:t) { struct s } : t := match s with 
+  | Leaf => acc
+  | Node l x r h => 
+     filter_acc (filter_acc (if f x then add x acc else acc) l) r 
+ end.
+
+Definition filter := filter_acc Leaf. 
+
+Lemma filter_acc_avl : forall s acc, avl s -> avl acc -> 
+ avl (filter_acc acc s).
+Proof.
+ induction s; simpl; auto.
+ intros.
+ inv avl.
+ apply IHs2; auto.
+ apply IHs1; auto.
+ destruct (f t); auto.
+Qed. 
+Hint Resolve filter_acc_avl.
+
+Lemma filter_acc_bst : forall s acc, bst s -> avl s -> bst acc -> avl acc -> 
+ bst (filter_acc acc s).
+Proof.
+ induction s; simpl; auto.
+ intros.
+ inv avl; inv bst.
+ destruct (f t); auto.
+ apply IHs2; auto.
+ apply IHs1; auto.
+ apply add_bst; auto.
+Qed. 
+
+Lemma filter_acc_in : forall s acc, avl s -> avl acc -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (filter_acc acc s) <-> In x acc \/ In x s /\ f x = true.
+Proof.  
+ induction s; simpl; intros.
+ intuition_in.
+ inv bst; inv avl.
+ rewrite IHs2; auto.
+ destruct (f t); auto.
+ rewrite IHs1; auto.
+ destruct (f t); auto.
+ case_eq (f t); intros.
+ rewrite (add_in); auto.
+ intuition_in.
+ rewrite (H1 _ _ H8).
+ intuition.
+ intuition_in.
+ rewrite (H1 _ _ H8) in H9.
+ rewrite H in H9; discriminate.
+Qed. 
+
+Lemma filter_avl : forall s, avl s -> avl (filter s). 
+Proof.
+ unfold filter; intros; apply filter_acc_avl; auto.
+Qed.
+
+Lemma filter_bst : forall s, bst s -> avl s -> bst (filter s). 
+Proof.
+ unfold filter; intros; apply filter_acc_bst; auto.
+Qed.
+
+Lemma filter_in : forall s, avl s -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (filter s) <-> In x s /\ f x = true.
+Proof.
+ unfold filter; intros; rewrite filter_acc_in; intuition_in.
+Qed. 
+
+(** * Partition *)
+
+Fixpoint partition_acc (acc : t*t)(s : t) { struct s } : t*t := 
+  match s with 
+   | Leaf => acc
+   | Node l x r _ => 
+      let (acct,accf) := acc in 
+      partition_acc 
+        (partition_acc 
+           (if f x then (add x acct, accf) else (acct, add x accf)) l) r
+  end. 
+
+Definition partition := partition_acc (Leaf,Leaf).
+
+Lemma partition_acc_avl_1 : forall s acc, avl s -> 
+ avl (fst acc) -> avl (fst (partition_acc acc s)).
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros.
+ inv avl.
+ apply IHs2; auto.
+ apply IHs1; auto.
+ destruct (f t); simpl; auto.
+Qed. 
+
+Lemma partition_acc_avl_2 : forall s acc, avl s -> 
+ avl (snd acc) -> avl (snd (partition_acc acc s)).
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros.
+ inv avl.
+ apply IHs2; auto.
+ apply IHs1; auto.
+ destruct (f t); simpl; auto.
+Qed. 
+Hint Resolve partition_acc_avl_1 partition_acc_avl_2.
+
+Lemma partition_acc_bst_1 : forall s acc, bst s -> avl s -> 
+ bst (fst acc) -> avl (fst acc) -> 
+ bst (fst (partition_acc acc s)).
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros.
+ inv avl; inv bst.
+ destruct (f t); auto.
+ apply IHs2; simpl; auto.
+ apply IHs1; simpl; auto.
+ apply add_bst; auto.
+ apply partition_acc_avl_1; simpl; auto.
+Qed. 
+
+Lemma partition_acc_bst_2 : forall s acc, bst s -> avl s -> 
+ bst (snd acc) -> avl (snd acc) -> 
+ bst (snd (partition_acc acc s)).
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros.
+ inv avl; inv bst.
+ destruct (f t); auto.
+ apply IHs2; simpl; auto.
+ apply IHs1; simpl; auto.
+ apply add_bst; auto.
+ apply partition_acc_avl_2; simpl; auto.
+Qed. 
+
+Lemma partition_acc_in_1 : forall s acc, avl s -> avl (fst acc) -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (fst (partition_acc acc s)) <-> 
+ In x (fst acc) \/ In x s /\ f x = true.
+Proof.  
+ induction s; simpl; intros.
+ intuition_in.
+ destruct acc as [acct accf]; simpl in *.
+ inv bst; inv avl.
+ rewrite IHs2; auto.
+ destruct (f t); auto.
+ apply partition_acc_avl_1; simpl; auto.
+ rewrite IHs1; auto.
+ destruct (f t); simpl; auto.
+ case_eq (f t); simpl; intros.
+ rewrite (add_in); auto.
+ intuition_in.
+ rewrite (H1 _ _ H8).
+ intuition.
+ intuition_in.
+ rewrite (H1 _ _ H8) in H9.
+ rewrite H in H9; discriminate.
+Qed. 
+
+Lemma partition_acc_in_2 : forall s acc, avl s -> avl (snd acc) -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (snd (partition_acc acc s)) <-> 
+ In x (snd acc) \/ In x s /\ f x = false.
+Proof.  
+ induction s; simpl; intros.
+ intuition_in.
+ destruct acc as [acct accf]; simpl in *.
+ inv bst; inv avl.
+ rewrite IHs2; auto.
+ destruct (f t); auto.
+ apply partition_acc_avl_2; simpl; auto.
+ rewrite IHs1; auto.
+ destruct (f t); simpl; auto.
+ case_eq (f t); simpl; intros.
+ intuition.
+ intuition_in.
+ rewrite (H1 _ _ H8) in H9.
+ rewrite H in H9; discriminate.
+ rewrite (add_in); auto.
+ intuition_in.
+ rewrite (H1 _ _ H8).
+ intuition.
+Qed. 
+
+Lemma partition_avl_1 : forall s, avl s -> avl (fst (partition s)). 
+Proof.
+ unfold partition; intros; apply partition_acc_avl_1; auto.
+Qed.
+
+Lemma partition_avl_2 : forall s, avl s -> avl (snd (partition s)). 
+Proof.
+ unfold partition; intros; apply partition_acc_avl_2; auto.
+Qed.
+
+Lemma partition_bst_1 : forall s, bst s -> avl s -> 
+ bst (fst (partition s)). 
+Proof.
+ unfold partition; intros; apply partition_acc_bst_1; auto.
+Qed.
+
+Lemma partition_bst_2 : forall s, bst s -> avl s -> 
+ bst (snd (partition s)). 
+Proof.
+ unfold partition; intros; apply partition_acc_bst_2; auto.
+Qed.
+
+Lemma partition_in_1 : forall s, avl s -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (fst (partition s)) <-> In x s /\ f x = true.
+Proof.
+ unfold partition; intros; rewrite partition_acc_in_1; 
+ simpl in *; intuition_in.
+Qed. 
+
+Lemma partition_in_2 : forall s, avl s -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (snd (partition s)) <-> In x s /\ f x = false.
+Proof.
+ unfold partition; intros; rewrite partition_acc_in_2; 
+ simpl in *; intuition_in.
+Qed. 
+
+(** [for_all] and [exists] *)
+
+Fixpoint for_all (s:t) : bool := match s with 
+  | Leaf => true
+  | Node l x r _ => f x && for_all l && for_all r
+end.
+
+Lemma for_all_1 : forall s, compat_bool E.eq f ->
+ For_all (fun x => f x = true) s -> for_all s = true.
+Proof.
+ induction s; simpl; auto.
+ intros.
+ rewrite IHs1; try red; auto.
+ rewrite IHs2; try red; auto.
+ generalize (H0 t).
+ destruct (f t); simpl; auto.
+Qed.
+
+Lemma for_all_2 : forall s, compat_bool E.eq f ->
+ for_all s = true -> For_all (fun x => f x = true) s.
+Proof.
+ induction s; simpl; auto; intros; red; intros; inv In.
+ destruct (andb_prop _ _ H0); auto.
+ destruct (andb_prop _ _ H1); eauto.
+ apply IHs1; auto.
+ destruct (andb_prop _ _ H0); auto.
+ destruct (andb_prop _ _ H1); auto.
+ apply IHs2; auto.
+ destruct (andb_prop _ _ H0); auto.
+Qed.
+
+Fixpoint exists_ (s:t) : bool := match s with 
+  | Leaf => false
+  | Node l x r _ => f x || exists_ l || exists_ r
+end.  
+
+Lemma exists_1 : forall s, compat_bool E.eq f ->
+ Exists (fun x => f x = true) s -> exists_ s = true.
+Proof.
+ induction s; simpl; destruct 2 as (x,(U,V)); inv In.
+ rewrite (H _ _ (X.eq_sym H0)); rewrite V; auto.
+ apply orb_true_intro; left.
+ apply orb_true_intro; right; apply IHs1; firstorder.
+ apply orb_true_intro; right; apply IHs2; firstorder.
+Qed.
+
+Lemma exists_2 : forall s, compat_bool E.eq f ->
+ exists_ s = true -> Exists (fun x => f x = true) s.
+Proof. 
+ induction s; simpl; intros.
+ discriminate.
+ destruct (orb_true_elim _ _ H0) as [H1|H1]. 
+ destruct (orb_true_elim _ _ H1) as [H2|H2].
+ exists t; auto.
+ destruct (IHs1 H H2); firstorder.
+ destruct (IHs2 H H1); firstorder.
+Qed. 
+
+End F.
+
+(** * Fold *)
+
+Module L := FSetList.Raw X.
+
+Fixpoint fold (A : Set) (f : elt -> A -> A)(s : tree) {struct s} : A -> A := 
+ fun a => match s with
+  | Leaf => a
+  | Node l x r _ => fold A f r (f x (fold A f l a))
+ end.
+Implicit Arguments fold [A].
+
+Definition fold' (A : Set) (f : elt -> A -> A)(s : tree) := 
+  L.fold f (elements s).
+Implicit Arguments fold' [A].
+
+Lemma fold_equiv_aux :
+ forall (A : Set) (s : tree) (f : elt -> A -> A) (a : A) (acc : list elt),
+ L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a).
+Proof.
+ simple induction s.
+ simpl in |- *; intuition.
+ simpl in |- *; intros.
+ rewrite H.
+ simpl.
+ apply H0.
+Qed.
+
+Lemma fold_equiv :
+ forall (A : Set) (s : tree) (f : elt -> A -> A) (a : A),
+ fold f s a = fold' f s a.
+Proof.
+ unfold fold', elements in |- *. 
+ simple induction s; simpl in |- *; auto; intros.
+ rewrite fold_equiv_aux.
+ rewrite H0.
+ simpl in |- *; auto.
+Qed.
+
+Lemma fold_1 : 
+ forall (s:t)(Hs:bst s)(A : Set)(f : elt -> A -> A)(i : A),
+ fold f s i = fold_left (fun a e => f e a) (elements s) i.
+Proof.
+ intros.
+ rewrite fold_equiv.
+ unfold fold'.
+ rewrite L.fold_1.
+ unfold L.elements; auto.
+ apply elements_sort; auto.
+Qed.
+
+(** * Cardinal *)
+
+Fixpoint cardinal (s : tree) : nat :=
+  match s with
+   | Leaf => 0%nat
+   | Node l _ r _ => S (cardinal l + cardinal r)
+  end.
+
+Lemma cardinal_elements_aux_1 :
+ forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
+Proof.
+ simple induction s; simpl in |- *; intuition.
+ rewrite <- H.
+ simpl in |- *.
+ rewrite <- H0; omega.
+Qed.
+
+Lemma cardinal_elements_1 : forall s : tree, cardinal s = length (elements s).
+Proof.
+ exact (fun s => cardinal_elements_aux_1 s nil).
+Qed.
+
+(** NB: the remaining functions (union, subset, compare) are still defined
+  in a dependent style, due to the use of well-founded induction. *)
+
+(** Induction over cardinals *)
+
+Lemma sorted_subset_cardinal : forall l' l : list X.t,
+ sort X.lt l -> sort X.lt l' ->
+ (forall x : elt, InA X.eq x l -> InA X.eq x l') -> (length l <= length l')%nat.
+Proof.
+ simple induction l'; simpl in |- *; intuition.
+ destruct l; trivial; intros.
+ absurd (InA X.eq t nil); intuition.
+ inversion_clear H2.
+ inversion_clear H1.
+ destruct l0; simpl in |- *; intuition.
+ inversion_clear H0.
+ apply le_n_S.
+ case (X.compare t a); intro.
+ absurd (InA X.eq t (a :: l)).
+ intro.
+ inversion_clear H0.
+ order.
+ assert (X.lt a t).
+ apply MX.Sort_Inf_In with l; auto.
+ order.
+ firstorder.
+ apply H; auto.
+ intros.
+ assert (InA X.eq x (a :: l)).
+ apply H2; auto.
+ inversion_clear H6; auto.
+ assert (X.lt t x).
+ apply MX.Sort_Inf_In with l0; auto.
+ order.
+ apply le_trans with (length (t :: l0)).
+ simpl in |- *; omega.
+ apply (H (t :: l0)); auto.
+ intros.
+ assert (InA X.eq x (a :: l)); firstorder.
+ inversion_clear H6; auto.
+ assert (X.lt a x).
+ apply MX.Sort_Inf_In with (t :: l0); auto.
+ elim (X.lt_not_eq (x:=a) (y:=x)); auto.
+Qed.
+
+Lemma cardinal_subset : forall a b : tree, bst a -> bst b ->
+ (forall y : elt, In y a -> In y b) ->
+ (cardinal a <= cardinal b)%nat.
+Proof.
+ intros.
+ do 2 rewrite cardinal_elements_1.
+ apply sorted_subset_cardinal; auto.
+ intros.
+ generalize (elements_in a x) (elements_in b x).
+ intuition.
+Qed.
+
+Lemma cardinal_left : forall (l r : tree) (x : elt) (h : int),
+ (cardinal l < cardinal (Node l x r h))%nat.
+Proof.
+ simpl in |- *; intuition.
+Qed. 
+
+Lemma cardinal_right :
+ forall (l r : tree) (x : elt) (h : int),
+ (cardinal r < cardinal (Node l x r h))%nat.
+Proof.
+ simpl in |- *; intuition.
+Qed. 
+
+Lemma cardinal_rec2 : forall P : tree -> tree -> Set,
+ (forall s1 s2 : tree,
+  (forall t1 t2 : tree,
+   (cardinal t1 + cardinal t2 < cardinal s1 + cardinal s2)%nat -> P t1 t2) 
+   -> P s1 s2) -> 
+ forall s1 s2 : tree, P s1 s2.
+Proof.
+ intros P H s1 s2.
+ apply well_founded_induction_type_2
+ with (R := fun yy' xx' : tree * tree =>
+            (cardinal (fst yy') + cardinal (snd yy') <
+             cardinal (fst xx') + cardinal (snd xx'))%nat); auto.    
+ apply (Wf_nat.well_founded_ltof _
+   (fun xx' : tree * tree => (cardinal (fst xx') + cardinal (snd xx'))%nat)).
+Qed.
+
+Lemma height_0 : forall s, avl s -> height s = 0 -> s = Leaf.
+Proof.
+ destruct 1; intuition; simpl in *.
+ avl_nns; simpl in *; false_omega_max.
+Qed.   
+
+(** * Union
+
+    [union s1 s2] does an induction over the sum of the cardinals of
+    [s1] and [s2]. Code is
+<<
+  let rec union s1 s2 =
+    match (s1, s2) with
+      (Empty, t2) -> t2
+    | (t1, Empty) -> t1
+    | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+        if h1 >= h2 then
+          if h2 = 1 then add v2 s1 else begin
+            let (l2', _, r2') = split v1 s2 in
+            join (union l1 l2') v1 (union r1 r2')
+          end
+        else
+          if h1 = 1 then add v1 s2 else begin
+            let (l1', _, r1') = split v2 s1 in
+            join (union l1' l2) v2 (union r1' r2)
+          end
+>>
+*)
+
+Definition union :
+ forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ {s' : t | bst s' /\ avl s' /\ forall x : elt, In x s' <-> In x s1 \/ In x s2}.
+Proof.
+ intros s1 s2; pattern s1, s2; apply cardinal_rec2; clear s1 s2.
+ destruct s1 as [| l1 x1 r1 h1]; intros.
+ (* s = Leaf *)
+ clear H.
+ exists s2; intuition_in.
+ (* s1 = Node l1 x1 r1 *)
+ destruct s2 as [| l2 x2 r2 h2]; simpl in |- *.
+ (* s2 = Leaf *)
+ clear H.
+ exists (Node l1 x1 r1 h1); simpl; intuition_in.
+ (* x' = Node l2 x2 r2 *)
+ case (ge_lt_dec h1 h2); intro.
+ (* h1 >= h2 *)
+ case (eq_dec h2 1); intro.
+ (* h2 = 1 *)
+ clear H.
+ exists (add x2 (Node l1 x1 r1 h1)); auto.
+ inv avl; inv bst.
+ avl_nn l2; avl_nn r2.
+ rewrite (height_0 _ H); [ | omega_max].
+ rewrite (height_0 _ H4); [ | omega_max].
+ split; [apply add_bst; auto|].
+ split; [apply add_avl; auto|].
+ intros.
+ rewrite (add_in (Node l1 x1 r1 h1) x2 x); intuition_in.
+ (* h2 <> 1 *)
+   (* split x1 s2 = l2',_,r2' *)
+ case_eq (split x1 (Node l2 x2 r2 h2)); intros l2' (b,r2') EqSplit.
+ set (s2 := Node l2 x2 r2 h2) in *; clearbody s2.
+ generalize (split_avl s2 x1 H3); rewrite EqSplit; simpl in *; intros (A,B).
+ generalize (split_bst s2 x1 H2 H3); rewrite EqSplit; simpl in *; intros (C,D).
+ generalize (split_in_1 s2 x1); rewrite EqSplit; simpl in *; intros.
+ generalize (split_in_2 s2 x1); rewrite EqSplit; simpl in *; intros.
+   (* union l1 l2' = l0 *)
+ destruct (H l1 l2') as [l0 (H7,(H8,H9))]; inv avl; inv bst; auto.
+ assert (cardinal l2' <= cardinal s2)%nat.
+ apply cardinal_subset; trivial.
+ intros y; rewrite (H4 y); intuition.
+ omega.
+   (* union r1 r2' = r0 *)
+ destruct (H r1 r2') as [r0 (H10,(H11,H12))]; inv avl; inv bst; auto.
+ assert (cardinal r2' <= cardinal s2)%nat.
+ apply cardinal_subset; trivial.
+ intros y; rewrite (H5 y); intuition.
+ omega.
+ exists (join l0 x1 r0).
+ inv avl; inv bst; clear H.
+ split.
+ apply join_bst; auto.
+ red; intros.
+ rewrite (H9 y) in H.
+ destruct H; auto.
+ rewrite (H4 y) in H; intuition.
+ red; intros.
+ rewrite (H12 y) in H.
+ destruct H; auto.
+ rewrite (H5 y) in H; intuition.
+ split.
+ apply join_avl; auto.
+ intros.
+ rewrite join_in; auto.
+ rewrite H9.
+ rewrite H12.
+ rewrite H4; auto.
+ rewrite H5; auto.
+ intuition_in.
+ case (X.compare x x1); intuition.
+ (* h1 < h2 *)
+ case (eq_dec h1 1); intro.
+ (* h1 = 1 *)
+ exists (add x1 (Node l2 x2 r2 h2)); auto.
+ inv avl; inv bst.
+ avl_nn l1; avl_nn r1.
+ rewrite (height_0 _ H3); [ | omega_max].
+ rewrite (height_0 _ H8); [ | omega_max].
+ split; [apply add_bst; auto|].
+ split; [apply add_avl; auto|].
+ intros.
+ rewrite (add_in (Node l2 x2 r2 h2) x1 x); intuition_in.
+ (* h1 <> 1 *)
+   (* split x2 s1 = l1',_,r1' *)
+ case_eq (split x2 (Node l1 x1 r1 h1)); intros l1' (b,r1') EqSplit.
+ set (s1 := Node l1 x1 r1 h1) in *; clearbody s1.
+ generalize (split_avl s1 x2 H1); rewrite EqSplit; simpl in *; intros (A,B).
+ generalize (split_bst s1 x2 H0 H1); rewrite EqSplit; simpl in *; intros (C,D).
+ generalize (split_in_1 s1 x2); rewrite EqSplit; simpl in *; intros.
+ generalize (split_in_2 s1 x2); rewrite EqSplit; simpl in *; intros.
+   (* union l1' l2 = l0 *)
+ destruct (H l1' l2) as [l0 (H7,(H8,H9))]; inv avl; inv bst; auto.
+ assert (cardinal l1' <= cardinal s1)%nat.
+ apply cardinal_subset; trivial.
+ intros y; rewrite (H4 y); intuition.
+ omega.
+   (* union r1' r2 = r0 *)
+ destruct (H r1' r2) as [r0 (H10,(H11,H12))]; inv avl; inv bst; auto.
+ assert (cardinal r1' <= cardinal s1)%nat.
+ apply cardinal_subset; trivial.
+ intros y; rewrite (H5 y); intuition.
+ omega.
+ exists (join l0 x2 r0).
+ inv avl; inv bst; clear H.
+ split.
+ apply join_bst; auto.
+ red; intros.
+ rewrite (H9 y) in H.
+ destruct H; auto.
+ rewrite (H4 y) in H; intuition.
+ red; intros.
+ rewrite (H12 y) in H.
+ destruct H; auto.
+ rewrite (H5 y) in H; intuition.
+ split.
+ apply join_avl; auto.
+ intros.
+ rewrite join_in; auto.
+ rewrite H9.
+ rewrite H12.
+ rewrite H4; auto.
+ rewrite H5; auto.
+ intuition_in.
+ case (X.compare x x2); intuition.
+Qed.
+
+
+(** * Subset
+<<
+  let rec subset s1 s2 =
+    match (s1, s2) with
+      Empty, _ -> true
+    | _, Empty -> false
+    | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
+        let c = Ord.compare v1 v2 in
+        if c = 0 then 
+          subset l1 l2 && subset r1 r2
+        else if c < 0 then 
+          subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
+        else
+          subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
+>>
+*)
+
+Definition subset : forall s1 s2 : t, bst s1 -> bst s2 ->
+ {Subset s1 s2} + {~ Subset s1 s2}.
+Proof.
+ intros s1 s2; pattern s1, s2; apply cardinal_rec2; clear s1 s2.
+ destruct s1 as [| l1 x1 r1 h1]; intros.
+ (* s1 = Leaf *)
+ left; red; intros; inv In.
+ (* s1 = Node l1 x1 r1 h1 *)
+ destruct s2 as [| l2 x2 r2 h2].
+ (* s2 = Leaf *)
+ right; intros; intro.
+ assert (In x1 Leaf); auto.
+ inversion_clear H3.
+ (* s2 = Node l2 x2 r2 h2 *)
+ case (X.compare x1 x2); intro.
+ (* x1 < x2 *)
+ case (H (Node l1 x1 Leaf 0) l2); inv bst; auto; intros.
+ simpl in |- *; omega.
+ case (H r1 (Node l2 x2 r2 h2)); inv bst; auto; intros.
+ simpl in |- *; omega.
+ clear H; left; red; intuition.
+ generalize (s a) (s0 a); clear s s0; intuition_in.
+ clear H; right; red; firstorder.
+ clear H; right; red; inv bst; intuition.
+ apply n; red; intros.
+ assert (In a (Node l2 x2 r2 h2)) by (inv In; auto).
+ intuition_in; order.
+ (* x1 = x2 *)
+ case (H l1 l2); inv bst; auto; intros.
+ simpl in |- *; omega.
+ case (H r1 r2); inv bst; auto; intros.
+ simpl in |- *; omega.
+ clear H; left; red; intuition_in; eauto.
+ clear H; right; red; inv bst; intuition.
+ apply n; red; intros.
+ assert (In a (Node l2 x2 r2 h2)) by auto.
+ intuition_in; order.
+ clear H; right; red; inv bst; intuition.
+ apply n; red; intros.
+ assert (In a (Node l2 x2 r2 h2)) by auto.
+ intuition_in; order.
+ (*  x1 > x2 *)
+ case (H (Node Leaf x1 r1 0) r2); inv bst; auto; intros.
+ simpl in |- *; omega.
+ intros; case (H l1 (Node l2 x2 r2 h2)); inv bst; auto; intros.
+ simpl in |- *; omega.
+ clear H; left; red; intuition.
+ generalize (s a) (s0 a); clear s s0; intuition_in.
+ clear H; right; red; firstorder.
+ clear H; right; red; inv bst; intuition.
+ apply n; red; intros.
+ assert (In a (Node l2 x2 r2 h2)) by (inv In; auto).
+ intuition_in; order.
+Qed.
+
+(** * Comparison *)
+
+(** ** Relations [eq] and [lt] over trees *)
+
+Definition eq : t -> t -> Prop := Equal.
+
+Lemma eq_refl : forall s : t, eq s s. 
+Proof.
+ unfold eq, Equal in |- *; intuition.
+Qed.
+
+Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s.
+Proof.
+ unfold eq, Equal in |- *; firstorder.
+Qed.
+
+Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
+Proof.
+ unfold eq, Equal in |- *; firstorder.
+Qed.
+
+Lemma eq_L_eq :
+ forall s s' : t, eq s s' -> L.eq (elements s) (elements s').
+Proof.
+ unfold eq, Equal, L.eq, L.Equal in |- *; intros.
+ generalize (elements_in s a) (elements_in s' a).
+ firstorder.
+Qed.
+
+Lemma L_eq_eq :
+ forall s s' : t, L.eq (elements s) (elements s') -> eq s s'.
+Proof.
+ unfold eq, Equal, L.eq, L.Equal in |- *; intros.
+ generalize (elements_in s a) (elements_in s' a).
+ firstorder.
+Qed.
+Hint Resolve eq_L_eq L_eq_eq.
+
+Definition lt (s1 s2 : t) : Prop := L.lt (elements s1) (elements s2).
+
+Definition lt_trans (s s' s'' : t) (h : lt s s') 
+  (h' : lt s' s'') : lt s s'' := L.lt_trans h h'.
+
+Lemma lt_not_eq : forall s s' : t, bst s -> bst s' -> lt s s' -> ~ eq s s'.
+Proof.
+ unfold lt in |- *; intros; intro.
+ apply L.lt_not_eq with (s := elements s) (s' := elements s'); auto.
+Qed.
+
+(** A new comparison algorithm suggested by Xavier Leroy:
+
+type enumeration = End | More of elt * t * enumeration
+
+let rec cons s e = match s with
+ | Empty -> e
+ | Node(l, v, r, _) -> cons l (More(v, r, e))
+
+let rec compare_aux e1 e2 = match (e1, e2) with
+ | (End, End) -> 0
+ | (End, More _) -> -1
+ | (More _, End) -> 1
+ | (More(v1, r1, k1), More(v2, r2, k2)) ->
+    let c = Ord.compare v1 v2 in
+    if c <> 0 then c else compare_aux (cons r1 k1) (cons r2 k2)
+
+let compare s1 s2 = compare_aux (cons s1 End) (cons s2 End)
+*)
+
+(** ** Enumeration of the elements of a tree *)
+
+Inductive enumeration : Set :=
+ | End : enumeration
+ | More : elt -> tree -> enumeration -> enumeration.
+
+(** [flatten_e e] returns the list of elements of [e] i.e. the list
+    of elements actually compared *)
+ 
+Fixpoint flatten_e (e : enumeration) : list elt := match e with
+  | End => nil
+  | More x t r => x :: elements t ++ flatten_e r
+ end.
+
+(** [sorted_e e] expresses that elements in the enumeration [e] are
+    sorted, and that all trees in [e] are binary search trees. *)
+
+Inductive In_e (x:elt) : enumeration -> Prop :=
+  | InEHd1 :
+      forall (y : elt) (s : tree) (e : enumeration),
+      X.eq x y -> In_e x (More y s e)
+  | InEHd2 :
+      forall (y : elt) (s : tree) (e : enumeration),
+      In x s -> In_e x (More y s e)
+  | InETl :
+      forall (y : elt) (s : tree) (e : enumeration),
+      In_e x e -> In_e x (More y s e).
+
+Hint Constructors In_e.
+
+Inductive sorted_e : enumeration -> Prop :=
+  | SortedEEnd : sorted_e End
+  | SortedEMore :
+      forall (x : elt) (s : tree) (e : enumeration),
+      bst s ->
+      (gt_tree x s) ->
+      sorted_e e ->
+      (forall y : elt, In_e y e -> X.lt x y) ->
+      (forall y : elt,
+       In y s -> forall z : elt, In_e z e -> X.lt y z) ->
+      sorted_e (More x s e).
+
+Hint Constructors sorted_e.
+
+Lemma in_app :
+ forall (x : elt) (l1 l2 : list elt),
+ InA X.eq x (l1 ++ l2) -> InA X.eq x l1 \/ InA X.eq x l2.
+Proof.
+ simple induction l1; simpl in |- *; intuition.
+ inversion_clear H0; auto.
+ elim (H l2 H1); auto.
+Qed.
+
+Lemma in_flatten_e :
+ forall (x : elt) (e : enumeration), InA X.eq x (flatten_e e) -> In_e x e.
+Proof.
+ simple induction e; simpl in |- *; intuition.
+ inversion_clear H.
+ inversion_clear H0; auto.
+ elim (in_app x _ _ H1); auto.
+ destruct (elements_in t x); auto.
+Qed.
+
+Lemma sort_app :
+ forall l1 l2 : list elt, sort X.lt l1 -> sort X.lt l2 ->
+ (forall x y : elt, InA X.eq x l1 -> InA X.eq y l2 -> X.lt x y) ->
+ sort X.lt (l1 ++ l2).
+Proof.
+ simple induction l1; simpl in |- *; intuition.
+ apply cons_sort; auto.
+ apply H; auto.
+ inversion_clear H0; trivial.
+ induction  l as [| a0 l Hrecl]; simpl in |- *; intuition.
+ induction  l2 as [| a0 l2 Hrecl2]; simpl in |- *; intuition. 
+ inversion_clear H0; inversion_clear H4; auto.
+Qed.
+
+Lemma sorted_flatten_e :
+ forall e : enumeration, sorted_e e -> sort X.lt (flatten_e e).
+Proof.
+ simple induction e; simpl in |- *; intuition.
+ apply cons_sort.
+ apply sort_app; inversion H0; auto.
+ intros; apply H8; auto.
+ destruct (elements_in t x0); auto.
+ apply in_flatten_e; auto.
+ apply L.MX.ListIn_Inf.
+ inversion_clear H0.
+ intros; elim (in_app_or _ _ _ H0); intuition.
+ destruct (elements_in t y); auto.
+ apply H4; apply in_flatten_e; auto.
+Qed.
+
+Lemma elements_app :
+ forall (s : tree) (acc : list elt), elements_aux acc s = elements s ++ acc.
+Proof.
+ simple induction s; simpl in |- *; intuition.
+ rewrite H0.
+ rewrite H.
+ unfold elements; simpl.
+ do 2 rewrite H.
+ rewrite H0.
+ repeat rewrite <- app_nil_end.
+ repeat rewrite app_ass; auto.
+Qed.
+
+Lemma compare_flatten_1 :
+ forall (t0 t2 : tree) (t1 : elt) (z : int) (l : list elt),
+ elements t0 ++ t1 :: elements t2 ++ l =
+ elements (Node t0 t1 t2 z) ++ l.
+Proof.
+ simpl in |- *; unfold elements in |- *; simpl in |- *; intuition.
+ repeat rewrite elements_app.
+ repeat rewrite <- app_nil_end.
+ repeat rewrite app_ass; auto.
+Qed.
+
+(** key lemma for correctness *)
+
+Lemma flatten_e_elements :
+ forall (x : elt) (l r : tree) (z : int) (e : enumeration),
+ elements l ++ flatten_e (More x r e) = elements (Node l x r z) ++ flatten_e e.
+Proof.
+ intros; simpl.
+ apply compare_flatten_1.
+Qed.
+
+(** termination of [compare_aux] *)
+
+Open Scope Z_scope.
+ 
+Fixpoint measure_e_t (s : tree) : Z := match s with
+  | Leaf => 0
+  | Node l _ r _ => 1 + measure_e_t l + measure_e_t r
+ end.
+
+Fixpoint measure_e (e : enumeration) : Z := match e with
+  | End => 0
+  | More _ s r => 1 + measure_e_t s + measure_e r
+ end.
+
+Ltac Measure_e_t := unfold measure_e_t in |- *; fold measure_e_t in |- *.
+Ltac Measure_e := unfold measure_e in |- *; fold measure_e in |- *.
+
+Lemma measure_e_t_0 : forall s : tree, measure_e_t s >= 0.
+Proof.
+ simple induction s.
+ simpl in |- *; omega.
+ intros.
+ Measure_e_t; omega. (* BUG Simpl! *)
+Qed.
+
+Ltac Measure_e_t_0 s := generalize (measure_e_t_0 s); intro.
+
+Lemma measure_e_0 : forall e : enumeration, measure_e e >= 0.
+Proof.
+ simple induction e.
+ simpl in |- *; omega.
+ intros.
+ Measure_e; Measure_e_t_0 t; omega.
+Qed.
+
+Ltac Measure_e_0 e := generalize (measure_e_0 e); intro.
+
+(** Induction principle over the sum of the measures for two lists *)
+
+Definition compare_rec2 :
+ forall P : enumeration -> enumeration -> Set,
+  (forall x x' : enumeration,
+   (forall y y' : enumeration,
+    measure_e y + measure_e y' < measure_e x + measure_e x' -> P y y') ->
+   P x x') -> 
+ forall x x' : enumeration, P x x'.
+Proof.
+ intros P H x x'.
+ apply well_founded_induction_type_2
+ with (R := fun yy' xx' : enumeration * enumeration =>
+            measure_e (fst yy') + measure_e (snd yy') <
+            measure_e (fst xx') + measure_e (snd xx')); auto.    
+ apply Wf_nat.well_founded_lt_compat
+ with (f := fun xx' : enumeration * enumeration =>
+            Zabs_nat (measure_e (fst xx') + measure_e (snd xx'))).
+ intros; apply Zabs.Zabs_nat_lt.
+ Measure_e_0 (fst x0); Measure_e_0 (snd x0); Measure_e_0 (fst y);
+ Measure_e_0 (snd y); intros; omega.
+Qed.
+
+(** [cons t e] adds the elements of tree [t] on the head of 
+    enumeration [e]. Code:
+ 
+let rec cons s e = match s with
+ | Empty -> e
+ | Node(l, v, r, _) -> cons l (More(v, r, e))
+*)
+
+Definition cons : forall (s : tree) (e : enumeration), bst s -> sorted_e e ->
+  (forall (x y : elt), In x s -> In_e y e -> X.lt x y) ->
+  { r : enumeration 
+  | sorted_e r /\ 
+    measure_e r = measure_e_t s + measure_e e /\
+    flatten_e r = elements s ++ flatten_e e
+  }.
+Proof.
+ simple induction s; intuition.
+ (* s = Leaf *)
+ exists e; intuition.
+ (* s = Node t t0 t1 z *)
+ clear H0.
+ case (H (More t0 t1 e)); clear H; intuition.
+ inv bst; auto.
+ constructor; inversion_clear H1; auto.
+ inversion_clear H0; inv bst; intuition; order.
+ exists x; intuition.
+ generalize H4; Measure_e; intros; Measure_e_t; omega.
+ rewrite H5.
+ apply flatten_e_elements.
+Qed.
+
+Lemma l_eq_cons :
+ forall (l1 l2 : list elt) (x y : elt),
+ X.eq x y -> L.eq l1 l2 -> L.eq (x :: l1) (y :: l2).
+Proof.
+ unfold L.eq, L.Equal in |- *; intuition.
+ inversion_clear H1; generalize (H0 a); clear H0; intuition.
+ apply InA_eqA with x; eauto.
+ inversion_clear H1; generalize (H0 a); clear H0; intuition.
+ apply InA_eqA with y; eauto.
+Qed.
+
+Definition compare_aux :
+ forall e1 e2 : enumeration, sorted_e e1 -> sorted_e e2 ->
+ Compare L.lt L.eq (flatten_e e1) (flatten_e e2).
+Proof.
+ intros e1 e2; pattern e1, e2 in |- *; apply compare_rec2.
+ simple destruct x; simple destruct x'; intuition.
+ (* x = x' = End *)
+ constructor 2; unfold L.eq, L.Equal in |- *; intuition.
+ (* x = End x' = More *)
+ constructor 1; simpl in |- *; auto.
+ (* x = More x' = End *)
+ constructor 3; simpl in |- *; auto.
+ (* x = More e t e0, x' = More e3 t0 e4 *)
+ case (X.compare e e3); intro.
+ (* e < e3 *)
+ constructor 1; simpl; auto.
+ (* e = e3 *)
+ destruct (cons t e0) as [c1 (H2,(H3,H4))]; try inversion_clear H0; auto.
+ destruct (cons t0 e4) as [c2 (H5,(H6,H7))]; try inversion_clear H1; auto.
+ destruct (H c1 c2); clear H; intuition.
+ Measure_e; omega.
+ constructor 1; simpl.
+ apply L.lt_cons_eq; auto.
+ rewrite H4 in l; rewrite H7 in l; auto.
+ constructor 2; simpl.
+ apply l_eq_cons; auto.
+ rewrite H4 in e6; rewrite H7 in e6; auto.
+ constructor 3; simpl.
+ apply L.lt_cons_eq; auto.
+ rewrite H4 in l; rewrite H7 in l; auto.
+ (* e > e3 *)
+ constructor 3; simpl; auto.
+Qed.
+
+Definition compare : forall s1 s2, bst s1 -> bst s2 -> Compare lt eq s1 s2.
+Proof.
+ intros s1 s2 s1_bst s2_bst; unfold lt, eq; simpl.
+ destruct (cons s1 End); intuition.
+ inversion_clear H0.
+ destruct (cons s2 End); intuition.
+ inversion_clear H3.
+ simpl in H2; rewrite <- app_nil_end in H2.
+ simpl in H5; rewrite <- app_nil_end in H5.
+ destruct (compare_aux x x0); intuition.
+ constructor 1; simpl in |- *.
+ rewrite H2 in l; rewrite H5 in l; auto.
+ constructor 2; apply L_eq_eq; simpl in |- *.
+ rewrite H2 in e; rewrite H5 in e; auto.
+ constructor 3; simpl in |- *.
+ rewrite H2 in l; rewrite H5 in l; auto.
+Qed.
+
+(** * Equality test *)
+
+Definition equal : forall s s' : t, bst s -> bst s' -> {Equal s s'} + {~ Equal s s'}.
+Proof.
+ intros s s' Hs Hs'; case (compare s s'); auto; intros.
+ right; apply lt_not_eq; auto.
+ right; intro; apply (lt_not_eq s' s); auto; apply eq_sym; auto.
+Qed.
+
+(**  We provide additionally a different implementation for union, subset and 
+  equal, which is less efficient, but uses structural induction, hence  computes 
+  within Coq. *)
+
+(** Alternative union based on fold. 
+  Complexity : [min(|s|,|s'|)*log(max(|s|,|s'|))] *)
+
+Definition union' s s' := 
+  if ge_lt_dec (height s) (height s') then fold add s' s else fold add s s'.
+
+Lemma fold_add_avl : forall s s', avl s -> avl s' -> avl (fold add s s').
+Proof. 
+ induction s; simpl; intros; inv avl; auto.
+Qed.
+Hint Resolve fold_add_avl.
+
+Lemma union'_avl : forall s s', avl s -> avl s' -> avl (union' s s').
+Proof. 
+ unfold union'; intros; destruct (ge_lt_dec (height s) (height s')); auto.
+Qed.
+
+Lemma fold_add_bst : forall s s', bst s -> avl s -> bst s' -> avl s' -> 
+ bst (fold add s s').
+Proof. 
+ induction s; simpl; intros; inv avl; inv bst; auto.
+ apply IHs2; auto.
+ apply add_bst; auto.
+Qed.
+
+Lemma union'_bst : forall s s', bst s -> avl s -> bst s' -> avl s' -> 
+ bst (union' s s').
+Proof. 
+ unfold union'; intros; destruct (ge_lt_dec (height s) (height s')); 
+  apply fold_add_bst; auto.
+Qed.
+
+Lemma fold_add_in : forall s s' y, bst s -> avl s -> bst s' -> avl s' -> 
+ (In y (fold add s s') <-> In y s \/ In y s').
+Proof. 
+ induction s; simpl; intros; inv avl; inv bst; auto.
+ intuition_in.
+ rewrite IHs2; auto.
+ apply add_bst; auto.
+ apply fold_add_bst; auto.
+ rewrite add_in; auto.
+ rewrite IHs1; auto.
+ intuition_in.
+Qed.
+
+Lemma union'_in : forall s s' y, bst s -> avl s -> bst s' -> avl s' -> 
+ (In y (union' s s') <-> In y s \/ In y s').
+Proof.
+ unfold union'; intros; destruct (ge_lt_dec (height s) (height s')).
+ rewrite fold_add_in; intuition.
+ apply fold_add_in; auto.
+Qed.
+
+(** Alternative subset based on diff. *)
+
+Definition subset' s s' := is_empty (diff s s').
+
+Lemma subset'_1 : forall s s', bst s -> avl s -> bst s' -> avl s' -> 
+ Subset s s' -> subset' s s' = true.
+Proof. 
+ unfold subset', Subset; intros; apply is_empty_1; red; intros.
+ rewrite (diff_in); intuition.
+Qed.
+
+Lemma subset'_2 : forall s s', bst s -> avl s -> bst s' -> avl s' ->
+ subset' s s' = true -> Subset s s'.
+Proof. 
+ unfold subset', Subset; intros; generalize (is_empty_2 _ H3 a); unfold Empty.
+ rewrite (diff_in); intuition.
+ generalize (mem_2 s' a) (mem_1 s' a); destruct (mem a s'); intuition.
+Qed.
+
+(** Alternative equal based on subset *)
+
+Definition equal' s s' := subset' s s' && subset' s' s.
+
+Lemma equal'_1 : forall s s', bst s -> avl s -> bst s' -> avl s' ->
+ Equal s s' -> equal' s s' = true.
+Proof. 
+ unfold equal', Equal; intros.
+ rewrite subset'_1; firstorder; simpl.
+ apply subset'_1; firstorder.
+Qed.
+
+Lemma equal'_2 : forall s s', bst s -> avl s -> bst s' -> avl s' ->
+ equal' s s' = true -> Equal s s'.
+Proof. 
+ unfold equal', Equal; intros; destruct (andb_prop _ _ H3); split; 
+  apply subset'_2; auto.
+Qed. 
+
+End Raw.
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we 
+   need to encapsulate everything into a type of balanced binary search trees. *)
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+
+ Module E := X.
+ Module Raw := Raw I X. 
+
+ Record bbst : Set := Bbst {this :> Raw.t; is_bst : Raw.bst this; is_avl: Raw.avl this}.
+ Definition t := bbst. 
+ Definition elt := E.t.
+ 
+ Definition In (x : elt) (s : t) : Prop := Raw.In x s.
+ Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
+ Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
+ Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop) (s:t) : Prop := forall x, In x s -> P x.
+ Definition Exists (P : elt -> Prop) (s:t) : Prop := exists x, In x s /\ P x.
+  
+ Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. 
+ Proof. intro s; exact (Raw.In_1 s). Qed.
+ 
+ Definition mem (x:elt)(s:t) : bool := Raw.mem x s.
+
+ Definition empty : t := Bbst _ Raw.empty_bst Raw.empty_avl.
+ Definition is_empty (s:t) : bool := Raw.is_empty s.
+ Definition singleton (x:elt) : t := Bbst _ (Raw.singleton_bst x) (Raw.singleton_avl x).
+ Definition add (x:elt)(s:t) : t := 
+   Bbst _ (Raw.add_bst s x (is_bst s) (is_avl s)) 
+          (Raw.add_avl s x (is_avl s)). 
+ Definition remove (x:elt)(s:t) : t := 
+   Bbst _ (Raw.remove_bst s x (is_bst s) (is_avl s)) 
+          (Raw.remove_avl s x (is_avl s)). 
+ Definition inter (s s':t) : t := 
+   Bbst _ (Raw.inter_bst _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s'))  
+          (Raw.inter_avl _ _ (is_avl s) (is_avl s')).
+ Definition diff (s s':t) : t := 
+   Bbst _ (Raw.diff_bst _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s'))  
+          (Raw.diff_avl _ _ (is_avl s) (is_avl s')).
+ Definition elements (s:t) : list elt := Raw.elements s.
+ Definition min_elt (s:t) : option elt := Raw.min_elt s.
+ Definition max_elt (s:t) : option elt := Raw.max_elt s.
+ Definition choose (s:t) : option elt := Raw.choose s.
+ Definition fold (B : Set) (f : elt -> B -> B) (s:t) : B -> B := Raw.fold f s. 
+ Definition cardinal (s:t) : nat := Raw.cardinal s.
+ Definition filter (f : elt -> bool) (s:t) : t := 
+   Bbst _ (Raw.filter_bst f _ (is_bst s) (is_avl s))
+          (Raw.filter_avl f _ (is_avl s)). 
+ Definition for_all (f : elt -> bool) (s:t) : bool := Raw.for_all f s.
+ Definition exists_ (f : elt -> bool) (s:t) : bool := Raw.exists_ f s.
+ Definition partition (f : elt -> bool) (s:t) : t * t :=
+   let p := Raw.partition f s in
+   (Bbst (fst p) (Raw.partition_bst_1 f _ (is_bst s) (is_avl s)) 
+                 (Raw.partition_avl_1 f _ (is_avl s)),
+    Bbst (snd p) (Raw.partition_bst_2 f _ (is_bst s) (is_avl s)) 
+                 (Raw.partition_avl_2 f _ (is_avl s))).
+
+ Definition union (s s':t) : t :=
+   let (u,p) := Raw.union _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s') in 
+   let (b,p) := p in 
+   let (a,_) := p in 
+   Bbst u b a.
+
+ Definition union' (s s' : t) : t := 
+   Bbst _ (Raw.union'_bst _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s'))  
+          (Raw.union'_avl _ _ (is_avl s) (is_avl s')).
+
+ Definition equal (s s': t) : bool := if Raw.equal _ _ (is_bst s) (is_bst s') then true else false. 
+ Definition equal' (s s':t) : bool := Raw.equal' s s'.
+
+ Definition subset (s s':t) : bool := if Raw.subset _ _ (is_bst s) (is_bst s') then true else false.
+ Definition subset' (s s':t) : bool := Raw.subset' s s'.
+
+ Definition eq (s s':t) : Prop := Raw.eq s s'.
+ Definition lt (s s':t) : Prop := Raw.lt s s'.
+
+ Definition compare  (s s':t) : Compare lt eq s s'.
+ Proof.
+ intros; elim (Raw.compare _ _ (is_bst s) (is_bst s'));
+  [ constructor 1 | constructor 2 | constructor 3 ]; 
+  auto. 
+ Defined.
+
+ (* specs *)
+ Section Specs. 
+ Variable s s' s'': t. 
+ Variable x y : elt.
+
+ Hint Resolve is_bst is_avl.
+ 
+ Lemma mem_1 : In x s -> mem x s = true. 
+ Proof. exact (Raw.mem_1 s x (is_bst s)). Qed.
+ Lemma mem_2 : mem x s = true -> In x s.
+ Proof. exact (Raw.mem_2 s x). Qed.
+
+ Lemma equal_1 : Equal s s' -> equal s s' = true.
+ Proof. 
+ unfold equal; destruct (Raw.equal s s'); simpl; auto.
+ Qed.
+
+ Lemma equal_2 : equal s s' = true -> Equal s s'.
+ Proof. 
+ unfold equal; destruct (Raw.equal s s'); simpl; intuition; discriminate.
+ Qed.
+
+ Lemma equal'_1 : Equal s s' -> equal' s s' = true.
+ Proof. exact (Raw.equal'_1 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed.
+ Lemma equal'_2 : equal' s s' = true -> Equal s s'.
+ Proof. exact (Raw.equal'_2 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed.
+
+ Lemma subset_1 : Subset s s' -> subset s s' = true.
+ Proof. 
+ unfold subset; destruct (Raw.subset s s'); simpl; intuition.
+ Qed.
+
+ Lemma subset_2 : subset s s' = true -> Subset s s'.
+ Proof. 
+ unfold subset; destruct (Raw.subset s s'); simpl; intuition discriminate.
+ Qed.
+
+ Lemma subset'_1 : Subset s s' -> subset' s s' = true. 
+ Proof. exact (Raw.subset'_1 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed.
+ Lemma subset'_2 : subset' s s' = true -> Subset s s'.
+ Proof. exact (Raw.subset'_2 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact Raw.empty_1. Qed.
+
+ Lemma is_empty_1 : Empty s -> is_empty s = true.
+ Proof. exact (Raw.is_empty_1 s). Qed.
+ Lemma is_empty_2 : is_empty s = true -> Empty s. 
+ Proof. exact (Raw.is_empty_2 s). Qed.
+ 
+ Lemma add_1 : E.eq x y -> In y (add x s).
+ Proof. 
+ unfold add, In; simpl; rewrite Raw.add_in; auto.
+ Qed.
+
+ Lemma add_2 : In y s -> In y (add x s).
+ Proof.
+ unfold add, In; simpl; rewrite Raw.add_in; auto.
+ Qed.
+
+ Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
+ Proof. 
+ unfold add, In; simpl; rewrite Raw.add_in; intuition.
+ elim H; auto.
+ Qed.
+
+ Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
+ Proof. 
+ unfold remove, In; simpl; rewrite Raw.remove_in; intuition.
+ Qed.
+
+ Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+ Proof. 
+ unfold remove, In; simpl; rewrite Raw.remove_in; intuition.
+ Qed.
+
+ Lemma remove_3 : In y (remove x s) -> In y s.
+ Proof. 
+ unfold remove, In; simpl; rewrite Raw.remove_in; intuition.
+ Qed.
+
+ Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
+ Proof. exact (Raw.singleton_1 x y). Qed.
+ Lemma singleton_2 : E.eq x y -> In y (singleton x). 
+ Proof. exact (Raw.singleton_2 x y). Qed.
+
+ Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
+ Proof.
+ unfold union, In; simpl.
+ destruct (Raw.union s s' (is_bst s) (is_avl s) (is_bst s') (is_avl s')) 
+  as (u,(b,(a,i))).
+ simpl in *; rewrite i; auto.
+ Qed.
+
+ Lemma union_2 : In x s -> In x (union s s'). 
+ Proof.
+ unfold union, In; simpl.
+ destruct (Raw.union s s' (is_bst s) (is_avl s) (is_bst s') (is_avl s')) 
+  as (u,(b,(a,i))).
+ simpl in *; rewrite i; auto.
+ Qed.
+
+ Lemma union_3 : In x s' -> In x (union s s').
+ Proof.
+ unfold union, In; simpl.
+ destruct (Raw.union s s' (is_bst s) (is_avl s) (is_bst s') (is_avl s')) 
+  as (u,(b,(a,i))).
+ simpl in *; rewrite i; auto.
+ Qed.
+
+ Lemma union'_1 : In x (union' s s') -> In x s \/ In x s'.
+ Proof.
+ unfold union', In; simpl; rewrite Raw.union'_in; intuition.
+ Qed.
+
+ Lemma union'_2 : In x s -> In x (union' s s'). 
+ Proof.
+ unfold union', In; simpl; rewrite Raw.union'_in; intuition.
+ Qed.
+
+ Lemma union'_3 : In x s' -> In x (union' s s').
+ Proof.
+ unfold union', In; simpl; rewrite Raw.union'_in; intuition.
+ Qed.
+
+ Lemma inter_1 : In x (inter s s') -> In x s.
+ Proof.
+ unfold inter, In; simpl; rewrite Raw.inter_in; intuition.
+ Qed.
+
+ Lemma inter_2 : In x (inter s s') -> In x s'.
+ Proof. 
+ unfold inter, In; simpl; rewrite Raw.inter_in; intuition.
+ Qed.
+
+ Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
+ Proof. 
+ unfold inter, In; simpl; rewrite Raw.inter_in; intuition.
+ Qed.
+ 
+ Lemma diff_1 : In x (diff s s') -> In x s. 
+ Proof. 
+ unfold diff, In; simpl; rewrite Raw.diff_in; intuition.
+ Qed.
+
+ Lemma diff_2 : In x (diff s s') -> ~ In x s'.
+ Proof. 
+ unfold diff, In; simpl; rewrite Raw.diff_in; intuition.
+ Qed.
+
+ Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+ Proof. 
+ unfold diff, In; simpl; rewrite Raw.diff_in; intuition.
+ Qed.
+ 
+ Lemma fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A),
+      fold A f s i = fold_left (fun a e => f e a) (elements s) i.
+ Proof. 
+ unfold fold, elements; intros; apply Raw.fold_1; auto.
+ Qed.
+
+ Lemma cardinal_1 : cardinal s = length (elements s).
+ Proof. 
+ unfold cardinal, elements; intros; apply Raw.cardinal_elements_1; auto.
+ Qed.
+
+ Section Filter.
+ Variable f : elt -> bool.
+
+ Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
+ Proof. 
+ intro; unfold filter, In; simpl; rewrite Raw.filter_in; intuition.
+ Qed.
+
+ Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+ Proof. 
+ intro; unfold filter, In; simpl; rewrite Raw.filter_in; intuition.
+ Qed.
+
+ Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
+ Proof. 
+ intro; unfold filter, In; simpl; rewrite Raw.filter_in; intuition.
+ Qed.
+
+ Lemma for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true.
+ Proof. exact (Raw.for_all_1 f s). Qed.
+ Lemma for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s.
+ Proof. exact (Raw.for_all_2 f s). Qed.
+
+ Lemma exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
+ Proof. exact (Raw.exists_1 f s). Qed.
+ Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
+ Proof. exact (Raw.exists_2 f s). Qed.
+
+ Lemma partition_1 : compat_bool E.eq f -> 
+  Equal (fst (partition f s)) (filter f s).
+ Proof.
+ unfold partition, filter, Equal, In; simpl ;intros H a.
+ rewrite Raw.partition_in_1; auto.
+ rewrite Raw.filter_in; intuition.
+ Qed.
+
+ Lemma partition_2 : compat_bool E.eq f -> 
+  Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+ Proof.
+ unfold partition, filter, Equal, In; simpl ;intros H a.
+ rewrite Raw.partition_in_2; auto.
+ rewrite Raw.filter_in; intuition.
+ red; intros.
+ f_equal; auto.
+ destruct (f a); auto.
+ destruct (f a); auto.
+ Qed.
+
+ End Filter.
+
+ Lemma elements_1 : In x s -> InA E.eq x (elements s).
+ Proof. 
+ unfold elements, In; rewrite Raw.elements_in; auto.
+ Qed.
+
+ Lemma elements_2 : InA E.eq x (elements s) -> In x s.
+ Proof. 
+ unfold elements, In; rewrite Raw.elements_in; auto.
+ Qed.
+
+ Lemma elements_3 : sort E.lt (elements s).
+ Proof. exact (Raw.elements_sort _ (is_bst s)). Qed.
+
+ Lemma min_elt_1 : min_elt s = Some x -> In x s. 
+ Proof. exact (Raw.min_elt_1 s x). Qed.
+ Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
+ Proof. exact (Raw.min_elt_2 s x y (is_bst s)). Qed.
+ Lemma min_elt_3 : min_elt s = None -> Empty s.
+ Proof. exact (Raw.min_elt_3 s). Qed.
+
+ Lemma max_elt_1 : max_elt s = Some x -> In x s. 
+ Proof. exact (Raw.max_elt_1 s x). Qed.
+ Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
+ Proof. exact (Raw.max_elt_2 s x y (is_bst s)). Qed.
+ Lemma max_elt_3 : max_elt s = None -> Empty s.
+ Proof. exact (Raw.max_elt_3 s). Qed.
+
+ Lemma choose_1 : choose s = Some x -> In x s.
+ Proof. exact (Raw.choose_1 s x). Qed.
+ Lemma choose_2 : choose s = None -> Empty s.
+ Proof. exact (Raw.choose_2 s). Qed.
+
+ Lemma eq_refl : eq s s. 
+ Proof. exact (Raw.eq_refl s). Qed.
+ Lemma eq_sym : eq s s' -> eq s' s.
+ Proof. exact (Raw.eq_sym s s'). Qed.
+ Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''.
+ Proof. exact (Raw.eq_trans s s' s''). Qed.
+  
+ Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''.
+ Proof. exact (Raw.lt_trans s s' s''). Qed.
+ Lemma lt_not_eq : lt s s' -> ~eq s s'.
+ Proof. exact (Raw.lt_not_eq _ _ (is_bst s) (is_bst s')). Qed.
+
+ End Specs.
+End IntMake.
+
+(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
+
+Module Make (X: OrderedType) <: S with Module E := X
+ :=IntMake(Z_as_Int)(X).
+
+
diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v
index 3ea50df8..08985cfc 100644
--- a/theories/FSets/FSetBridge.v
+++ b/theories/FSets/FSetBridge.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetBridge.v 8639 2006-03-16 19:21:55Z letouzey $ *)
+(* $Id: FSetBridge.v 8834 2006-05-20 00:41:35Z letouzey $ *)
 
 (** * Finite sets library *)
 
@@ -109,7 +109,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E.
 
   Definition elements :
     forall s : t,
-    {l : list elt | ME.Sort l /\ (forall x : elt, In x s <-> ME.In x l)}.
+    {l : list elt | sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}.
    Proof.
      intros; exists (elements s); intuition.   
    Defined. 
@@ -394,17 +394,17 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Definition elements (s : t) : list elt := let (l, _) := elements s in l. 
  
-  Lemma elements_1 : forall (s : t) (x : elt), In x s -> ME.In x (elements s).
+  Lemma elements_1 : forall (s : t) (x : elt), In x s -> InA E.eq x (elements s).
   Proof. 
     intros; unfold elements in |- *; case (M.elements s); firstorder.
   Qed.
 
-  Lemma elements_2 : forall (s : t) (x : elt), ME.In x (elements s) -> In x s.
+  Lemma elements_2 : forall (s : t) (x : elt), InA E.eq x (elements s) -> In x s.
   Proof. 
     intros s x; unfold elements in |- *; case (M.elements s); firstorder.
   Qed.
 
-  Lemma elements_3 : forall s : t, ME.Sort (elements s).  
+  Lemma elements_3 : forall s : t, sort E.lt (elements s).  
   Proof. 
     intros; unfold elements in |- *; case (M.elements s); firstorder.
   Qed.
diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v
index 006d78c7..d7062d5a 100644
--- a/theories/FSets/FSetEqProperties.v
+++ b/theories/FSets/FSetEqProperties.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetEqProperties.v 8639 2006-03-16 19:21:55Z letouzey $ *)
+(* $Id: FSetEqProperties.v 8853 2006-05-23 18:17:38Z herbelin $ *)
 
 (** * Finite sets library *)
 
@@ -276,7 +276,7 @@ Lemma is_empty_cardinal: is_empty s = zerob (cardinal s).
 Proof.
 intros; apply bool_1; split; intros.
 rewrite cardinal_1; simpl; auto.
-assert (cardinal s = 0) by apply zerob_true_elim; auto.
+assert (cardinal s = 0) by (apply zerob_true_elim; auto).
 auto.
 Qed.
 
@@ -672,7 +672,7 @@ unfold Add, MP.Add; intros.
 repeat rewrite filter_iff; auto.
 rewrite H0; clear H0.
 assert (E.eq x y -> f y = true) by 
- intro H0; rewrite <- (Comp _ _ H0); auto.
+ (intro H0; rewrite <- (Comp _ _ H0); auto).
 tauto.
 Qed.
 
@@ -704,6 +704,11 @@ assert (f a || g a = true <-> f a = true \/ g a = true).
 tauto.
 Qed.
 
+Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s').
+Proof.
+unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto.
+Qed.
+
 (** Properties of [for_all] *)
 
 Lemma for_all_mem_1: forall s, 
diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v
index d8c0b802..aa57f066 100644
--- a/theories/FSets/FSetFacts.v
+++ b/theories/FSets/FSetFacts.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetFacts.v 8681 2006-04-05 11:56:14Z letouzey $ *)
+(* $Id: FSetFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *)
 
 (** * Finite sets library *)
 
@@ -131,7 +131,7 @@ Proof.
 split; [apply exists_1 | apply exists_2]; auto.
 Qed.
 
-Lemma elements_iff : In x s <-> ME.In x (elements s).
+Lemma elements_iff : In x s <-> InA E.eq x (elements s).
 Proof. 
 split; [apply elements_1 | apply elements_2].
 Qed.
@@ -159,6 +159,12 @@ generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H).
 destruct (mem x s); destruct (mem y s); intuition.
 Qed.
 
+Lemma empty_b : mem y empty = false.
+Proof.
+generalize (empty_iff y)(mem_iff empty y).
+destruct (mem y empty); intuition.
+Qed.
+
 Lemma add_b : mem y (add x s) = eqb x y || mem y s.
 Proof.
 generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb.
diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v
index c177abfe..64ad234b 100644
--- a/theories/FSets/FSetInterface.v
+++ b/theories/FSets/FSetInterface.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetInterface.v 8671 2006-03-29 08:31:28Z letouzey $ *)
+(* $Id: FSetInterface.v 8820 2006-05-15 11:44:05Z letouzey $ *)
 
 (** * Finite set library *)
 
@@ -153,7 +153,7 @@ Module Type S.
   Section Spec. 
 
   Variable s s' s'' : t.
-  Variable x y z : elt.
+  Variable x y : elt.
 
   (** Specification of [In] *)
   Parameter In_1 : E.eq x y -> In x s -> In y s.
@@ -254,6 +254,8 @@ Module Type S.
   Parameter partition_2 : compat_bool E.eq f -> 
       snd (partition f s) [=] filter (fun x => negb (f x)) s.
 
+  End Filter.
+
   (** Specification of [elements] *)
   Parameter elements_1 : In x s -> InA E.eq x (elements s).
   Parameter elements_2 : InA E.eq x (elements s) -> In x s.
@@ -275,7 +277,6 @@ Module Type S.
 (*  Parameter choose_equal: 
       (equal s s')=true -> E.eq (choose s) (choose s'). *)
 
-  End Filter.
   End Spec.
 
   (* begin hide *)
diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v
index ca86ffcc..f6205542 100644
--- a/theories/FSets/FSetList.v
+++ b/theories/FSets/FSetList.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetList.v 8667 2006-03-28 11:59:44Z letouzey $ *)
+(* $Id: FSetList.v 8834 2006-05-20 00:41:35Z letouzey $ *)
 
 (** * Finite sets library *)
 
@@ -199,6 +199,8 @@ Module Raw (X: OrderedType).
 
   (** ** Proofs of set operation specifications. *)
 
+  Section ForNotations.
+
   Notation Sort := (sort X.lt).
   Notation Inf := (lelistA X.lt).
   Notation In := (InA X.eq).
@@ -1020,6 +1022,9 @@ Module Raw (X: OrderedType).
   destruct (e1 a0); auto.
   Defined.
 
+  End ForNotations. 
+  Hint Constructors lt.
+
 End Raw.
 
 (** * Encapsulation
@@ -1029,135 +1034,213 @@ End Raw.
 
 Module Make (X: OrderedType) <: S with Module E := X.
 
- Module E := X.
  Module Raw := Raw X. 
+ Module E := X.
 
- Record slist : Set :=  {this :> Raw.t; sorted : sort X.lt this}.
+ Record slist : Set :=  {this :> Raw.t; sorted : sort E.lt this}.
  Definition t := slist. 
- Definition elt := X.t.
+ Definition elt := E.t.
  
- Definition In (x : elt) (s : t) := InA X.eq x s.(this).
- Definition Equal s s' := forall a : elt, In a s <-> In a s'.
- Definition Subset s s' := forall a : elt, In a s -> In a s'.
- Definition Empty s := forall a : elt, ~ In a s.
- Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
- Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
-  
- Definition In_1 (s : t) := Raw.MX.In_eq (l:=s.(this)).
- 
- Definition mem (x : elt) (s : t) := Raw.mem x s.
- Definition mem_1 (s : t) := Raw.mem_1 (sorted s). 
- Definition mem_2 (s : t) := Raw.mem_2 (s:=s).
-
- Definition add x s := Build_slist (Raw.add_sort (sorted s) x).
- Definition add_1 (s : t) := Raw.add_1 (sorted s).
- Definition add_2 (s : t) := Raw.add_2 (sorted s).
- Definition add_3 (s : t) := Raw.add_3 (sorted s).
-
- Definition remove x s := Build_slist (Raw.remove_sort (sorted s) x).
- Definition remove_1 (s : t) := Raw.remove_1 (sorted s).
- Definition remove_2 (s : t) := Raw.remove_2 (sorted s).
- Definition remove_3 (s : t) := Raw.remove_3 (sorted s).
- 
- Definition singleton x := Build_slist (Raw.singleton_sort x).
- Definition singleton_1 := Raw.singleton_1.
- Definition singleton_2 := Raw.singleton_2.
-  
- Definition union (s s' : t) :=
+ Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this).
+ Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
+ Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
+ Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop)(s:t) : Prop := forall x, In x s -> P x.
+ Definition Exists (P : elt -> Prop)(s:t) : Prop := exists x, In x s /\ P x.
+
+ Definition mem (x : elt) (s : t) : bool := Raw.mem x s.
+ Definition add (x : elt)(s : t) : t := Build_slist (Raw.add_sort (sorted s) x).
+ Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_sort (sorted s) x).
+ Definition singleton (x : elt) : t  := Build_slist (Raw.singleton_sort x).
+ Definition union (s s' : t) : t :=
    Build_slist (Raw.union_sort (sorted s) (sorted s')). 
- Definition union_1 (s s' : t) := Raw.union_1 (sorted s) (sorted s').
- Definition union_2 (s s' : t) := Raw.union_2 (sorted s) (sorted s').
- Definition union_3 (s s' : t) := Raw.union_3 (sorted s) (sorted s').
-
- Definition inter (s s' : t) :=
+ Definition inter (s s' : t) : t :=
    Build_slist (Raw.inter_sort (sorted s) (sorted s')). 
- Definition inter_1 (s s' : t) := Raw.inter_1 (sorted s) (sorted s').
- Definition inter_2 (s s' : t) := Raw.inter_2 (sorted s) (sorted s').
- Definition inter_3 (s s' : t) := Raw.inter_3 (sorted s) (sorted s').
- 
- Definition diff (s s' : t) :=
+ Definition diff (s s' : t) : t :=
    Build_slist (Raw.diff_sort (sorted s) (sorted s')). 
- Definition diff_1 (s s' : t) := Raw.diff_1 (sorted s) (sorted s').
- Definition diff_2 (s s' : t) := Raw.diff_2 (sorted s) (sorted s').
- Definition diff_3 (s s' : t) := Raw.diff_3 (sorted s) (sorted s').
- 
- Definition equal (s s' : t) := Raw.equal s s'. 
- Definition equal_1 (s s' : t) := Raw.equal_1 (sorted s) (sorted s').  
- Definition equal_2 (s s' : t) := Raw.equal_2 (s:=s) (s':=s').
- 
- Definition subset (s s' : t) := Raw.subset s s'.
- Definition subset_1 (s s' : t) := Raw.subset_1 (sorted s) (sorted s').  
- Definition subset_2 (s s' : t) := Raw.subset_2 (s:=s) (s':=s').
+ Definition equal (s s' : t) : bool := Raw.equal s s'. 
+ Definition subset (s s' : t) : bool := Raw.subset s s'.
+ Definition empty : t := Build_slist Raw.empty_sort.
+ Definition is_empty (s : t) : bool := Raw.is_empty s.
+ Definition elements (s : t) : list elt := Raw.elements s.
+ Definition min_elt (s : t) : option elt := Raw.min_elt s.
+ Definition max_elt (s : t) : option elt := Raw.max_elt s.
+ Definition choose (s : t) : option elt  := Raw.choose s.
+ Definition fold (B : Set) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. 
+ Definition cardinal (s : t) : nat := Raw.cardinal s.
+ Definition filter (f : elt -> bool) (s : t) : t :=
+   Build_slist (Raw.filter_sort (sorted s) f).
+ Definition for_all (f : elt -> bool) (s : t) : bool := Raw.for_all f s.
+ Definition exists_ (f : elt -> bool) (s : t) : bool := Raw.exists_ f s.
+ Definition partition (f : elt -> bool) (s : t) : t * t :=
+   let p := Raw.partition f s in
+   (Build_slist (this:=fst p) (Raw.partition_sort_1 (sorted s) f),
+   Build_slist (this:=snd p) (Raw.partition_sort_2 (sorted s) f)).
+ Definition eq (s s' : t) : Prop := Raw.eq s s'.
+ Definition lt (s s' : t) : Prop := Raw.lt s s'.
 
- Definition empty := Build_slist Raw.empty_sort.
- Definition empty_1 := Raw.empty_1.
- 
- Definition is_empty (s : t) := Raw.is_empty s.
- Definition is_empty_1 (s : t) := Raw.is_empty_1 (s:=s).
- Definition is_empty_2 (s : t) := Raw.is_empty_2 (s:=s).
-
- Definition elements (s : t) := Raw.elements s.
- Definition elements_1 (s : t) := Raw.elements_1 (s:=s).
- Definition elements_2 (s : t) := Raw.elements_2 (s:=s).
- Definition elements_3 (s : t) := Raw.elements_3 (sorted s).
- 
- Definition min_elt (s : t) := Raw.min_elt s.
- Definition min_elt_1 (s : t) := Raw.min_elt_1 (s:=s).
- Definition min_elt_2 (s : t) := Raw.min_elt_2 (sorted s).
- Definition min_elt_3 (s : t) := Raw.min_elt_3 (s:=s).
-
- Definition max_elt (s : t) := Raw.max_elt s.
- Definition max_elt_1 (s : t) := Raw.max_elt_1 (s:=s).
- Definition max_elt_2 (s : t) := Raw.max_elt_2 (sorted s).
- Definition max_elt_3 (s : t) := Raw.max_elt_3 (s:=s).
-  
- Definition choose := min_elt.
- Definition choose_1 := min_elt_1.
- Definition choose_2 := min_elt_3.
+ Section Spec. 
+  Variable s s' s'': t.
+  Variable x y : elt.
+
+  Lemma In_1 : E.eq x y -> In x s -> In y s. 
+  Proof. exact (fun H H' => Raw.MX.In_eq H H'). Qed.
  
- Definition fold (B : Set) (f : elt -> B -> B) (s : t) := Raw.fold (B:=B) f s. 
- Definition fold_1 (s : t) := Raw.fold_1 (sorted s). 
+  Lemma mem_1 : In x s -> mem x s = true.
+  Proof. exact (fun H => Raw.mem_1 s.(sorted) H). Qed.
+  Lemma mem_2 : mem x s = true -> In x s. 
+  Proof. exact (fun H => Raw.mem_2 H). Qed.
  
- Definition cardinal (s : t) := Raw.cardinal s.
- Definition cardinal_1 (s : t) := Raw.cardinal_1 (sorted s). 
+  Lemma equal_1 : Equal s s' -> equal s s' = true.
+  Proof. exact (Raw.equal_1 s.(sorted) s'.(sorted)). Qed.
+  Lemma equal_2 : equal s s' = true -> Equal s s'.
+  Proof. exact (fun H => Raw.equal_2 H). Qed.
+
+  Lemma subset_1 : Subset s s' -> subset s s' = true.
+  Proof. exact (Raw.subset_1 s.(sorted) s'.(sorted)). Qed.
+  Lemma subset_2 : subset s s' = true -> Subset s s'.
+  Proof. exact (fun H => Raw.subset_2 H). Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof. exact Raw.empty_1. Qed.
+
+  Lemma is_empty_1 : Empty s -> is_empty s = true. 
+  Proof. exact (fun H => Raw.is_empty_1 H). Qed.
+  Lemma is_empty_2 : is_empty s = true -> Empty s.
+  Proof. exact (fun H => Raw.is_empty_2 H). Qed.
  
- Definition filter (f : elt -> bool) (s : t) :=
-   Build_slist (Raw.filter_sort (sorted s) f).
- Definition filter_1 (s : t) := Raw.filter_1 (s:=s).
- Definition filter_2 (s : t) := Raw.filter_2 (s:=s).
- Definition filter_3 (s : t) := Raw.filter_3 (s:=s).
+  Lemma add_1 : E.eq x y -> In y (add x s).
+  Proof. exact (fun H => Raw.add_1 s.(sorted) H). Qed.
+  Lemma add_2 : In y s -> In y (add x s).
+  Proof. exact (fun H => Raw.add_2 s.(sorted) x H). Qed.
+  Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
+  Proof. exact (fun H => Raw.add_3 s.(sorted) H). Qed.
+
+  Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
+  Proof. exact (fun H => Raw.remove_1 s.(sorted) H). Qed.
+  Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+  Proof. exact (fun H H' => Raw.remove_2 s.(sorted) H H'). Qed.
+  Lemma remove_3 : In y (remove x s) -> In y s.
+  Proof. exact (fun H => Raw.remove_3 s.(sorted) H). Qed.
+
+  Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
+  Proof. exact (fun H => Raw.singleton_1 H). Qed.
+  Lemma singleton_2 : E.eq x y -> In y (singleton x). 
+  Proof. exact (fun H => Raw.singleton_2 H). Qed.
+
+  Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
+  Proof. exact (fun H => Raw.union_1 s.(sorted) s'.(sorted) H). Qed.
+  Lemma union_2 : In x s -> In x (union s s'). 
+  Proof. exact (fun H => Raw.union_2 s.(sorted) s'.(sorted) H). Qed.
+  Lemma union_3 : In x s' -> In x (union s s').
+  Proof. exact (fun H => Raw.union_3 s.(sorted) s'.(sorted) H). Qed.
+
+  Lemma inter_1 : In x (inter s s') -> In x s.
+  Proof. exact (fun H => Raw.inter_1 s.(sorted) s'.(sorted) H). Qed.
+  Lemma inter_2 : In x (inter s s') -> In x s'.
+  Proof. exact (fun H => Raw.inter_2 s.(sorted) s'.(sorted) H). Qed.
+  Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
+  Proof. exact (fun H => Raw.inter_3 s.(sorted) s'.(sorted) H). Qed.
+
+  Lemma diff_1 : In x (diff s s') -> In x s. 
+  Proof. exact (fun H => Raw.diff_1 s.(sorted) s'.(sorted) H). Qed.
+  Lemma diff_2 : In x (diff s s') -> ~ In x s'.
+  Proof. exact (fun H => Raw.diff_2 s.(sorted) s'.(sorted) H). Qed.
+  Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+  Proof. exact (fun H => Raw.diff_3 s.(sorted) s'.(sorted) H). Qed.
  
- Definition for_all (f : elt -> bool) (s : t) := Raw.for_all f s.
- Definition for_all_1 (s : t) := Raw.for_all_1 (s:=s). 
- Definition for_all_2 (s : t) := Raw.for_all_2 (s:=s). 
+  Lemma fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof. exact (Raw.fold_1 s.(sorted)). Qed.
 
- Definition exists_ (f : elt -> bool) (s : t) := Raw.exists_ f s.
- Definition exists_1 (s : t) := Raw.exists_1 (s:=s). 
- Definition exists_2 (s : t) := Raw.exists_2 (s:=s). 
+  Lemma cardinal_1 : cardinal s = length (elements s).
+  Proof. exact (Raw.cardinal_1 s.(sorted)). Qed.
 
- Definition partition (f : elt -> bool) (s : t) :=
-   let p := Raw.partition f s in
-   (Build_slist (this:=fst p) (Raw.partition_sort_1 (sorted s) f),
-   Build_slist (this:=snd p) (Raw.partition_sort_2 (sorted s) f)).
- Definition partition_1 (s : t) := Raw.partition_1 s.
- Definition partition_2 (s : t) := Raw.partition_2 s. 
-
- Definition eq (s s' : t) := Raw.eq s s'.
- Definition eq_refl (s : t) := Raw.eq_refl s.
- Definition eq_sym (s s' : t) := Raw.eq_sym (s:=s) (s':=s').
- Definition eq_trans (s s' s'' : t) :=
-   Raw.eq_trans (s:=s) (s':=s') (s'':=s'').
+  Section Filter.
   
- Definition lt (s s' : t) := Raw.lt s s'.
- Definition lt_trans (s s' s'' : t) :=
-   Raw.lt_trans (s:=s) (s':=s') (s'':=s'').
- Definition lt_not_eq (s s' : t) := Raw.lt_not_eq (sorted s) (sorted s').
-
- Definition compare : forall s s' : t, Compare lt eq s s'.
- Proof.
- intros; elim (Raw.compare (sorted s) (sorted s'));
-  [ constructor 1 | constructor 2 | constructor 3 ]; 
-  auto. 
- Defined.
+  Variable f : elt -> bool.
+
+  Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
+  Proof. exact (@Raw.filter_1 s x f). Qed.
+  Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+  Proof. exact (@Raw.filter_2 s x f). Qed.
+  Lemma filter_3 :
+      compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
+  Proof. exact (@Raw.filter_3 s x f). Qed.
+
+  Lemma for_all_1 :
+      compat_bool E.eq f ->
+      For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. exact (@Raw.for_all_1 s f). Qed.
+  Lemma for_all_2 :
+      compat_bool E.eq f ->
+      for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. exact (@Raw.for_all_2 s f). Qed.
+
+  Lemma exists_1 :
+      compat_bool E.eq f ->
+      Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof. exact (@Raw.exists_1 s f). Qed.
+  Lemma exists_2 :
+      compat_bool E.eq f ->
+      exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. exact (@Raw.exists_2 s f). Qed.
+
+  Lemma partition_1 :
+      compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
+  Proof. exact (@Raw.partition_1 s f). Qed.
+  Lemma partition_2 :
+      compat_bool E.eq f ->
+      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof. exact (@Raw.partition_2 s f). Qed.
+
+  End Filter.
+
+  Lemma elements_1 : In x s -> InA E.eq x (elements s).
+  Proof. exact (fun H => Raw.elements_1 H). Qed.
+  Lemma elements_2 : InA E.eq x (elements s) -> In x s.
+  Proof. exact (fun H => Raw.elements_2 H). Qed.
+  Lemma elements_3 : sort E.lt (elements s).
+  Proof. exact (Raw.elements_3 s.(sorted)). Qed.
+
+  Lemma min_elt_1 : min_elt s = Some x -> In x s. 
+  Proof. exact (fun H => Raw.min_elt_1 H). Qed.
+  Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. 
+  Proof. exact (fun H => Raw.min_elt_2 s.(sorted) H). Qed.
+  Lemma min_elt_3 : min_elt s = None -> Empty s.
+  Proof. exact (fun H => Raw.min_elt_3 H). Qed.
+
+  Lemma max_elt_1 : max_elt s = Some x -> In x s. 
+  Proof. exact (fun H => Raw.max_elt_1 H). Qed.
+  Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. 
+  Proof. exact (fun H => Raw.max_elt_2 s.(sorted) H). Qed.
+  Lemma max_elt_3 : max_elt s = None -> Empty s.
+  Proof. exact (fun H => Raw.max_elt_3 H). Qed.
+
+  Lemma choose_1 : choose s = Some x -> In x s.
+  Proof. exact (fun H => Raw.choose_1 H). Qed.
+  Lemma choose_2 : choose s = None -> Empty s.
+  Proof. exact (fun H => Raw.choose_2 H). Qed.
+
+  Lemma eq_refl : eq s s.
+  Proof. exact (Raw.eq_refl s). Qed.
+  Lemma eq_sym : eq s s' -> eq s' s.
+  Proof. exact (@Raw.eq_sym s s'). Qed.
+  Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''.
+  Proof. exact (@Raw.eq_trans s s' s''). Qed.
+
+  Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''.
+  Proof. exact (@Raw.lt_trans s s' s''). Qed.
+  Lemma lt_not_eq : lt s s' -> ~ eq s s'.
+  Proof. exact (Raw.lt_not_eq s.(sorted) s'.(sorted)). Qed.
+
+  Definition compare : Compare lt eq s s'.
+  Proof.
+  elim (Raw.compare s.(sorted) s'.(sorted));
+   [ constructor 1 | constructor 2 | constructor 3 ]; 
+   auto. 
+  Defined.
+
+ End Spec.
 
 End Make.
diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v
index 23843084..6e93a546 100644
--- a/theories/FSets/FSetProperties.v
+++ b/theories/FSets/FSetProperties.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetProperties.v 8639 2006-03-16 19:21:55Z letouzey $ *)
+(* $Id: FSetProperties.v 8853 2006-05-23 18:17:38Z herbelin $ *)
 
 (** * Finite sets library *)
 
@@ -21,49 +21,13 @@ Require Import FSetFacts.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-Section Misc.
-Variable A B : Set.
-Variable eqA : A -> A -> Prop. 
-Variable eqB : B -> B -> Prop.
-
-(** Two-argument functions that allow to reorder its arguments. *)
-Definition transpose (f : A -> B -> B) :=
-  forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). 
-
-(** Compatibility of a two-argument function with respect to two equalities. *)
-Definition compat_op (f : A -> B -> B) :=
-  forall (x x' : A) (y y' : B), eqA x x' -> eqB y y' -> eqB (f x y) (f x' y').
-
-(** Compatibility of a function upon natural numbers. *)
-Definition compat_nat (f : A -> nat) :=
-  forall x x' : A, eqA x x' -> f x = f x'.
-
-End Misc.
 Hint Unfold transpose compat_op compat_nat.
-
 Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence.
 
-Ltac trans_st x := match goal with 
-  | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
-     apply (Seq_trans _ _ H) with x; auto
- end.
-
-Ltac sym_st := match goal with 
-  | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
-     apply (Seq_sym _ _ H); auto
- end.
-
-Ltac refl_st := match goal with 
-  | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
-     apply (Seq_refl _ _ H); auto
- end.
-
-Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A).
-Proof. auto. Qed.
-
 Module Properties (M: S).
-  Module ME := OrderedTypeFacts M.E.  
-  Import ME.
+  Module ME:=OrderedTypeFacts(M.E).
+  Import ME. (* for ME.eq_dec *)
+  Import M.E.
   Import M.
   Import Logic. (* to unmask [eq] *)  
   Import Peano. (* to unmask [lt] *)
@@ -82,26 +46,29 @@ Module Properties (M: S).
   Qed.
 
   Section BasicProperties.
-  Variable s s' s'' s1 s2 s3 : t.
-  Variable x : elt.
 
   (** properties of [Equal] *)
 
-  Lemma equal_refl : s[=]s.
+  Lemma equal_refl : forall s, s[=]s.
   Proof.
-  apply eq_refl.
+  unfold Equal; intuition.
   Qed.
 
-  Lemma equal_sym : s[=]s' -> s'[=]s.
+  Lemma equal_sym : forall s s', s[=]s' -> s'[=]s.
   Proof.
-  apply eq_sym. 
+  unfold Equal; intros.
+  rewrite H; intuition.
   Qed.
 
-  Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3.
+  Lemma equal_trans : forall s1 s2 s3, s1[=]s2 -> s2[=]s3 -> s1[=]s3.
   Proof.
-  intros; apply eq_trans with s2; auto.
+  unfold Equal; intros.
+  rewrite H; exact (H0 a).
   Qed.
 
+  Variable s s' s'' s1 s2 s3 : t.
+  Variable x x' : elt.
+
   (** properties of [Subset] *)
   
   Lemma subset_refl : s[<=]s. 
@@ -154,6 +121,11 @@ Module Properties (M: S).
   Proof.
   unfold Subset; intuition.
   Qed.
+ 
+  Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1.
+  Proof.
+  unfold Subset, Equal; split; intros; intuition; generalize (H a); intuition.
+  Qed.
 
   (** properties of [empty] *)
 
@@ -174,6 +146,11 @@ Module Properties (M: S).
   unfold Equal; intros; set_iff; intuition.
   rewrite <- H1; auto.
   Qed.
+ 
+  Lemma add_add : add x (add x' s) [=] add x' (add x s).
+  Proof. 
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
 
   (** properties of [remove] *)
 
@@ -185,7 +162,7 @@ Module Properties (M: S).
 
   Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'.
   Proof.
-  intros; rewrite H; apply eq_refl.
+  intros; rewrite H; apply equal_refl.
   Qed.
 
   (** properties of [add] and [remove] *)
@@ -223,12 +200,12 @@ Module Properties (M: S).
 
   Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''.
   Proof.
-  intros; rewrite H; apply eq_refl.
+  intros; rewrite H; apply equal_refl.
   Qed.
 
   Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
   Proof.
-  intros; rewrite H; apply eq_refl.
+  intros; rewrite H; apply equal_refl.
   Qed.
 
   Lemma union_assoc : union (union s s') s'' [=] union s (union s' s'').
@@ -261,6 +238,16 @@ Module Properties (M: S).
   unfold Subset; intros H H0 a; set_iff; intuition.
   Qed.
 
+  Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
+  Proof. 
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
+  Proof. 
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
   Lemma empty_union_1 : Empty s -> union s s' [=] s'.
   Proof.
   unfold Equal, Empty; intros; set_iff; firstorder.
@@ -290,12 +277,12 @@ Module Properties (M: S).
 
   Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''.
   Proof.
-  intros; rewrite H; apply eq_refl.
+  intros; rewrite H; apply equal_refl.
   Qed.
 
   Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
   Proof.
-  intros; rewrite H; apply eq_refl.
+  intros; rewrite H; apply equal_refl.
   Qed.
 
   Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s'').
@@ -447,140 +434,14 @@ Module Properties (M: S).
     empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union 
     inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal 
     remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove
-    Equal_remove : set.
-
-  Notation NoDup := (NoDupA E.eq).
-  Notation EqList := (eqlistA E.eq).
-
-  Section NoDupA_Remove.
-
-  Let ListAdd x l l' := forall y : elt, ME.In y l' <-> E.eq x y \/ ME.In y l.
-
-  Lemma removeA_add :
-    forall s s' x x', NoDup s -> NoDup (x' :: s') ->
-    ~ E.eq x x' -> ~ ME.In x s -> 
-    ListAdd x s (x' :: s') -> ListAdd x (removeA eq_dec x' s) s'.
-  Proof.
-   unfold ListAdd; intros.
-   inversion_clear H0.
-   rewrite removeA_InA; auto; [apply E.eq_trans|].
-   split; intros.
-   destruct (eq_dec x y); auto; intros.
-   right; split; auto.
-   destruct (H3 y); clear H3.
-   destruct H6; intuition.
-   swap H4; apply In_eq with y; auto.
-   destruct H0.
-   assert (ME.In y (x' :: s')) by rewrite H3; auto.
-   inversion_clear H6; auto.
-   elim H1; apply E.eq_trans with y; auto.
-   destruct H0.
-   assert (ME.In y (x' :: s')) by rewrite H3; auto.
-   inversion_clear H7; auto.
-   elim H6; auto.
-  Qed.
-
-  Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA).
-  Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f).
-  Variables (i:A).
-
-  Lemma removeA_fold_right_0 :
-    forall s x, NoDup s -> ~ME.In x s ->
-    eqA (fold_right f i s) (fold_right f i (removeA eq_dec x s)).
-  Proof.
-   simple induction s; simpl; intros.
-   refl_st.
-   inversion_clear H0.
-   destruct (eq_dec x a); simpl; intros.
-   absurd_hyp e; auto.
-   apply Comp; auto. 
-  Qed.   
-
-  Lemma removeA_fold_right :
-    forall s x, NoDup s -> ME.In x s ->
-    eqA (fold_right f i s) (f x (fold_right f i (removeA eq_dec x s))).
-  Proof.
-   simple induction s; simpl.  
-   inversion_clear 2.
-   intros.
-   inversion_clear H0.
-   destruct (eq_dec x a); simpl; intros.
-   apply Comp; auto. 
-   apply removeA_fold_right_0; auto.
-   swap H2; apply ME.In_eq with x; auto.
-   inversion_clear H1. 
-   destruct n; auto.
-   trans_st (f a (f x (fold_right f i (removeA eq_dec x l)))).
-  Qed.   
-
-  Lemma fold_right_equal :
-    forall s s', NoDup s -> NoDup s' ->
-    EqList s s' -> eqA (fold_right f i s) (fold_right f i s').
-  Proof.
-   simple induction s.
-   destruct s'; simpl.
-   intros; refl_st; auto.
-   unfold eqlistA; intros.
-   destruct (H1 t0).
-   assert (X : ME.In t0 nil); auto; inversion X.
-   intros x l Hrec s' N N' E; simpl in *.
-   trans_st (f x (fold_right f i (removeA eq_dec x s'))).
-   apply Comp; auto.
-   apply Hrec; auto.
-   inversion N; auto.
-   apply removeA_NoDupA; auto; apply E.eq_trans.
-   apply removeA_eqlistA; auto; [apply E.eq_trans|].
-   inversion_clear N; auto.
-   sym_st.
-   apply removeA_fold_right; auto.
-   unfold eqlistA in E.
-   rewrite <- E; auto.
-  Qed.
-
-  Lemma fold_right_add :
-    forall s' s x, NoDup s -> NoDup s' -> ~ ME.In x s ->
-    ListAdd x s s' -> eqA (fold_right f i s') (f x (fold_right f i s)).
-  Proof.   
-   simple induction s'.
-   unfold ListAdd; intros.
-   destruct (H2 x); clear H2.
-   assert (X : ME.In x nil); auto; inversion X.
-   intros x' l' Hrec s x N N' IN EQ; simpl.
-   (* if x=x' *)
-   destruct (eq_dec x x').
-   apply Comp; auto.
-   apply fold_right_equal; auto.
-   inversion_clear N'; trivial.
-   unfold eqlistA; unfold ListAdd in EQ; intros.
-   destruct (EQ x0); clear EQ.
-   split; intros.
-   destruct H; auto.
-   inversion_clear N'.
-   destruct H2; apply In_eq with x0; auto; order.
-   assert (X:ME.In x0 (x' :: l')); auto; inversion_clear X; auto.
-   destruct IN; apply In_eq with x0; auto; order.
-   (* else x<>x' *)   
-   trans_st (f x' (f x (fold_right f i (removeA eq_dec x' s)))).
-   apply Comp; auto.
-   apply Hrec; auto.
-   apply removeA_NoDupA; auto; apply E.eq_trans.
-   inversion_clear N'; auto.
-   rewrite removeA_InA; auto; [apply E.eq_trans|intuition].
-   apply removeA_add; auto.
-   trans_st (f x (f x' (fold_right f i (removeA eq_dec x' s)))).
-   apply Comp; auto.
-   sym_st.
-   apply removeA_fold_right; auto.
-   destruct (EQ x'). 
-   destruct H; auto; destruct n; auto.
-  Qed.
-
-  End NoDupA_Remove.
+    Equal_remove add_add : set.
 
   (** * Alternative (weaker) specifications for [fold] *)
 
   Section Old_Spec_Now_Properties. 
 
+  Notation NoDup := (NoDupA E.eq).
+
   (** When [FSets] was first designed, the order in which Ocaml's [Set.fold]
         takes the set elements was unspecified. This specification reflects this fact: 
   *)
@@ -629,7 +490,9 @@ Module Properties (M: S).
   intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); 
     destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
   rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
-  apply fold_right_add with (eqA := eqA); auto.
+  apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto.
+  eauto.
+  exact eq_dec.
   rewrite <- Hl1; auto.
   intros; rewrite <- Hl1; rewrite <- Hl'1; auto.
   Qed.
@@ -897,8 +760,8 @@ Module Properties (M: S).
    forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p.
   Proof.
   assert (st := gen_st nat).
-  assert (fe : compat_op E.eq (@eq _) (fun _ => S)) by unfold compat_op; auto. 
-  assert (fp : transpose (@eq _) (fun _:elt => S)) by unfold transpose; auto.
+  assert (fe : compat_op E.eq (@eq _) (fun _ => S)) by (unfold compat_op; auto). 
+  assert (fp : transpose (@eq _) (fun _:elt => S)) by (unfold transpose; auto).
   intros s p; pattern s; apply set_induction; clear s; intros.
   rewrite (fold_1 st p (fun _ => S) H).
   rewrite (fold_1 st 0 (fun _ => S) H); trivial.
@@ -956,7 +819,23 @@ Module Properties (M: S).
   rewrite (inter_subset_equal H); auto with arith.
   Qed.
 
-  Lemma union_inter_cardinal :
+  Lemma subset_cardinal_lt : 
+   forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'.
+  Proof. 
+  intros.
+  rewrite <- (diff_inter_cardinal s' s).
+  rewrite (inter_sym s' s).
+  rewrite (inter_subset_equal H).
+  generalize (@cardinal_inv_1 (diff s' s)).
+  destruct (cardinal (diff s' s)).
+  intro H2; destruct (H2 (refl_equal _) x).
+  set_iff; auto.
+  intros _.
+  change (0 + cardinal s < S n + cardinal s).
+  apply Plus.plus_lt_le_compat; auto with arith.
+  Qed. 
+
+  Theorem union_inter_cardinal :
    forall s s', cardinal (union s s') + cardinal (inter s s')  = cardinal s  + cardinal s' .
   Proof.
   intros.
@@ -965,6 +844,15 @@ Module Properties (M: S).
   apply fold_union_inter with (eqA:=@eq nat); auto.
   Qed.
 
+  Lemma union_cardinal_inter : 
+   forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s').
+  Proof.
+  intros.
+  rewrite <- union_inter_cardinal.
+  rewrite Plus.plus_comm.
+  auto with arith.
+  Qed.
+
   Lemma union_cardinal_le : 
    forall s s', cardinal (union s s') <= cardinal s  + cardinal s'.
   Proof.
diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v
new file mode 100644
index 00000000..8cf85efe
--- /dev/null
+++ b/theories/FSets/FSetToFiniteSet.v
@@ -0,0 +1,139 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: FSetToFiniteSet.v 8876 2006-05-30 13:43:15Z letouzey $ *)
+
+Require Import Ensembles Finite_sets.
+Require Import FSetInterface FSetProperties OrderedTypeEx.
+
+(** * Going from [FSets] with usual equality 
+    to the old [Ensembles] and [Finite_sets] theory. *)
+
+Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U).
+ Module MP:= Properties(M).
+ Import M MP FM Ensembles Finite_sets.
+
+ Definition mkEns : M.t -> Ensemble M.elt := 
+   fun s x => M.In x s.
+
+ Notation " !! " := mkEns.
+
+ Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x.
+ Proof.
+ unfold In; compute; auto.
+ Qed.
+
+ Lemma Subset_Included : forall s s',  s[<=]s'  <-> Included _ (!!s) (!!s').
+ Proof.
+ unfold Subset, Included, In, mkEns; intuition.
+ Qed.
+
+ Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity).
+
+ Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'.
+ Proof.
+ intros.
+ rewrite double_inclusion.
+ unfold Subset, Included, Same_set, In, mkEns; intuition.
+ Qed.
+
+ Lemma empty_Empty_Set : !!M.empty === Empty_set _.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1.
+ Qed.
+
+ Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intros.
+ destruct(H x H0).
+ inversion H0.
+ Qed.
+
+ Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x .
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; try constructor; auto.
+ Qed.
+
+ Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s').
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto.
+ Qed.
+
+ Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s').
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; try constructor; auto.
+ Qed.
+
+ Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; unfold E.eq; auto with sets.
+ inversion H0.
+ constructor 2; constructor.
+ constructor 1; auto.
+ Qed.
+
+ Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intros.
+ red in H; rewrite H in H0.
+ destruct H0.
+ inversion H0.
+ constructor 2; constructor.
+ constructor 1; auto.
+ red in H; rewrite H; unfold E.eq in *.
+ inversion H0; auto.
+ inversion H1; auto.
+ Qed.
+
+ Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; unfold E.eq in *; auto with sets.
+ split; auto.
+ swap H1.
+ inversion H2; auto.
+ Qed.
+
+ Lemma mkEns_Finite : forall s, Finite _ (!!s).
+ Proof.
+ intro s; pattern s; apply set_induction; clear s; intros.
+ intros; replace (!!s) with (Empty_set elt); auto with sets.
+ symmetry; apply Extensionality_Ensembles. 
+ apply Empty_Empty_set; auto.
+ replace (!!s') with (Add _ (!!s) x).
+ constructor 2; auto.
+ symmetry; apply Extensionality_Ensembles. 
+ apply Add_Add; auto.
+ Qed.
+
+ Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s).
+ Proof.
+ intro s; pattern s; apply set_induction; clear s; intros.
+ intros; replace (!!s) with (Empty_set elt); auto with sets.
+ rewrite cardinal_1; auto with sets.
+ symmetry; apply Extensionality_Ensembles. 
+ apply Empty_Empty_set; auto.
+ replace (!!s') with (Add _ (!!s) x).
+ rewrite (cardinal_2 H0 H1); auto with sets. 
+ symmetry; apply Extensionality_Ensembles. 
+ apply Add_Add; auto.
+ Qed.
+
+End S_to_Finite_set.
diff --git a/theories/FSets/FSetWeak.v b/theories/FSets/FSetWeak.v
index 7ed61c9f..bfe34cd7 100644
--- a/theories/FSets/FSetWeak.v
+++ b/theories/FSets/FSetWeak.v
@@ -6,9 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetWeak.v 8641 2006-03-17 09:56:54Z letouzey $ *)
+(* $Id: FSetWeak.v 8819 2006-05-15 09:52:36Z letouzey $ *)
 
 Require Export DecidableType.
+Require Export DecidableTypeEx.
 Require Export FSetWeakInterface.
 Require Export FSetFacts.
+Require Export FSetProperties.
 Require Export FSetWeakList.
diff --git a/theories/FSets/FSetWeakFacts.v b/theories/FSets/FSetWeakFacts.v
index 46a73cc9..61797a95 100644
--- a/theories/FSets/FSetWeakFacts.v
+++ b/theories/FSets/FSetWeakFacts.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetWeakFacts.v 8681 2006-04-05 11:56:14Z letouzey $ *)
+(* $Id: FSetWeakFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *)
 
 (** * Finite sets library *)
 
@@ -159,6 +159,12 @@ generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H).
 destruct (mem x s); destruct (mem y s); intuition.
 Qed.
 
+Lemma empty_b : mem y empty = false.
+Proof.
+generalize (empty_iff y)(mem_iff empty y).
+destruct (mem y empty); intuition.
+Qed.
+
 Lemma add_b : mem y (add x s) = eqb x y || mem y s.
 Proof.
 generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb.
diff --git a/theories/FSets/FSetWeakInterface.v b/theories/FSets/FSetWeakInterface.v
index c1845494..a281ce22 100644
--- a/theories/FSets/FSetWeakInterface.v
+++ b/theories/FSets/FSetWeakInterface.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetWeakInterface.v 8641 2006-03-17 09:56:54Z letouzey $ *)
+(* $Id: FSetWeakInterface.v 8820 2006-05-15 11:44:05Z letouzey $ *)
 
 (** * Finite sets library *)
 
@@ -132,8 +132,8 @@ Module Type S.
 
   Section Spec. 
 
-  Variable s s' s'' : t.
-  Variable x y z : elt.
+  Variable s s' : t.
+  Variable x y : elt.
 
   (** Specification of [In] *)
   Parameter In_1 : E.eq x y -> In x s -> In y s.
@@ -226,15 +226,17 @@ Module Type S.
       compat_bool E.eq f ->
       Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
 
+  End Filter.
+
   (** Specification of [elements] *)
   Parameter elements_1 : In x s -> InA E.eq x (elements s).
   Parameter elements_2 : InA E.eq x (elements s) -> In x s.
+  Parameter elements_3 : NoDupA E.eq (elements s).
 
   (** Specification of [choose] *)
   Parameter choose_1 : choose s = Some x -> In x s.
   Parameter choose_2 : choose s = None -> Empty s.
 
-  End Filter.
   End Spec.
 
   Hint Immediate In_1.
@@ -243,6 +245,7 @@ Module Type S.
     is_empty_1 is_empty_2 choose_1 choose_2 add_1 add_2 add_3 remove_1
     remove_2 remove_3 singleton_1 singleton_2 union_1 union_2 union_3 inter_1
     inter_2 inter_3 diff_1 diff_2 diff_3 filter_1 filter_2 filter_3 for_all_1
-    for_all_2 exists_1 exists_2 partition_1 partition_2 elements_1 elements_2.
+    for_all_2 exists_1 exists_2 partition_1 partition_2 elements_1 elements_2
+    elements_3.
 
 End S.
diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v
index 74c81f37..97080b7a 100644
--- a/theories/FSets/FSetWeakList.v
+++ b/theories/FSets/FSetWeakList.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetWeakList.v 8639 2006-03-16 19:21:55Z letouzey $ *)
+(* $Id: FSetWeakList.v 8834 2006-05-20 00:41:35Z letouzey $ *)
 
 (** * Finite sets library *)
 
@@ -114,7 +114,7 @@ Module Raw (X: DecidableType).
      end.
 
   (** ** Proofs of set operation specifications. *)
-
+  Section ForNotations. 
   Notation NoDup := (NoDupA X.eq).
   Notation In := (InA X.eq).
 
@@ -750,6 +750,7 @@ Module Raw (X: DecidableType).
   unfold eq, Equal; firstorder.
   Qed.
 
+  End ForNotations.
 End Raw.
 
 (** * Encapsulation
@@ -759,115 +760,177 @@ End Raw.
 
 Module Make (X: DecidableType) <: S with Module E := X.
 
- Module E := X.
  Module Raw := Raw X. 
+ Module E := X.
 
- Record slist : Set :=  {this :> Raw.t; unique : NoDupA X.eq this}.
+ Record slist : Set :=  {this :> Raw.t; unique : NoDupA E.eq this}.
  Definition t := slist. 
- Definition elt := X.t.
+ Definition elt := E.t.
  
- Definition In (x : elt) (s : t) := InA X.eq x s.(this).
- Definition Equal s s' := forall a : elt, In a s <-> In a s'.
- Definition Subset s s' := forall a : elt, In a s -> In a s'.
- Definition Empty s := forall a : elt, ~ In a s.
- Definition For_all (P : elt -> Prop) (s : t) :=
+ Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this).
+ Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
+ Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
+ Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop) (s : t) : Prop :=
    forall x : elt, In x s -> P x.
- Definition Exists (P : elt -> Prop) (s : t) := exists x : elt, In x s /\ P x.
-  
- Definition In_1 (s : t) := Raw.In_eq (s:=s).
- 
- Definition mem (x : elt) (s : t) := Raw.mem x s.
- Definition mem_1 (s : t) := Raw.mem_1 (s:=s). 
- Definition mem_2 (s : t) := Raw.mem_2 (s:=s).
-
- Definition add x s := Build_slist (Raw.add_unique (unique s) x).
- Definition add_1 (s : t) := Raw.add_1 (unique s).
- Definition add_2 (s : t) := Raw.add_2 (unique s).
- Definition add_3 (s : t) := Raw.add_3 (unique s).
-
- Definition remove x s := Build_slist (Raw.remove_unique (unique s) x).
- Definition remove_1 (s : t) := Raw.remove_1 (unique s).
- Definition remove_2 (s : t) := Raw.remove_2 (unique s).
- Definition remove_3 (s : t) := Raw.remove_3 (unique s).
- 
- Definition singleton x := Build_slist (Raw.singleton_unique x).
- Definition singleton_1 := Raw.singleton_1.
- Definition singleton_2 := Raw.singleton_2.
-  
- Definition union (s s' : t) :=
-   Build_slist (Raw.union_unique (unique s) (unique s')). 
- Definition union_1 (s s' : t) := Raw.union_1 (unique s) (unique s').
- Definition union_2 (s s' : t) := Raw.union_2 (unique s) (unique s').
- Definition union_3 (s s' : t) := Raw.union_3 (unique s) (unique s').
+ Definition Exists (P : elt -> Prop) (s : t) : Prop := exists x : elt, In x s /\ P x.
 
- Definition inter (s s' : t) :=
+ Definition mem (x : elt) (s : t) : bool := Raw.mem x s.
+ Definition add (x : elt)(s : t) : t  := Build_slist (Raw.add_unique (unique s) x).
+ Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_unique (unique s) x).
+ Definition singleton (x : elt) : t := Build_slist (Raw.singleton_unique x).
+ Definition union (s s' : t) : t :=
+   Build_slist (Raw.union_unique (unique s) (unique s')). 
+ Definition inter (s s' : t) : t :=
    Build_slist (Raw.inter_unique (unique s) (unique s')). 
- Definition inter_1 (s s' : t) := Raw.inter_1 (unique s) (unique s').
- Definition inter_2 (s s' : t) := Raw.inter_2 (unique s) (unique s').
- Definition inter_3 (s s' : t) := Raw.inter_3 (unique s) (unique s').
- 
- Definition diff (s s' : t) :=
+ Definition diff (s s' : t) : t :=
    Build_slist (Raw.diff_unique (unique s) (unique s')). 
- Definition diff_1 (s s' : t) := Raw.diff_1 (unique s) (unique s').
- Definition diff_2 (s s' : t) := Raw.diff_2 (unique s) (unique s').
- Definition diff_3 (s s' : t) := Raw.diff_3 (unique s) (unique s').
- 
- Definition equal (s s' : t) := Raw.equal s s'. 
- Definition equal_1 (s s' : t) := Raw.equal_1 (unique s) (unique s').  
- Definition equal_2 (s s' : t) := Raw.equal_2 (unique s) (unique s').
- 
- Definition subset (s s' : t) := Raw.subset s s'.
- Definition subset_1 (s s' : t) := Raw.subset_1 (unique s) (unique s').  
- Definition subset_2 (s s' : t) := Raw.subset_2 (unique s) (unique s').
+ Definition equal (s s' : t) : bool := Raw.equal s s'. 
+ Definition subset (s s' : t) : bool := Raw.subset s s'.
+ Definition empty : t := Build_slist Raw.empty_unique.
+ Definition is_empty (s : t) : bool := Raw.is_empty s.
+ Definition elements (s : t) : list elt := Raw.elements s.
+ Definition choose (s:t) : option elt := Raw.choose s.
+ Definition fold (B : Set) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. 
+ Definition cardinal (s : t) : nat := Raw.cardinal s.
+ Definition filter (f : elt -> bool) (s : t) : t :=
+   Build_slist (Raw.filter_unique (unique s) f).
+ Definition for_all (f : elt -> bool) (s : t) : bool := Raw.for_all f s.
+ Definition exists_ (f : elt -> bool) (s : t) : bool := Raw.exists_ f s.
+ Definition partition (f : elt -> bool) (s : t) : t * t :=
+   let p := Raw.partition f s in
+   (Build_slist (this:=fst p) (Raw.partition_unique_1 (unique s) f),
+   Build_slist (this:=snd p) (Raw.partition_unique_2 (unique s) f)).
+
+ Section Spec. 
+  Variable s s' : t.
+  Variable x y : elt.
 
- Definition empty := Build_slist Raw.empty_unique.
- Definition empty_1 := Raw.empty_1.
+  Lemma In_1 : E.eq x y -> In x s -> In y s. 
+  Proof. exact (fun H H' => Raw.In_eq H H'). Qed.
  
- Definition is_empty (s : t) := Raw.is_empty s.
- Definition is_empty_1 (s : t) := Raw.is_empty_1 (s:=s).
- Definition is_empty_2 (s : t) := Raw.is_empty_2 (s:=s).
-
- Definition elements (s : t) := Raw.elements s.
- Definition elements_1 (s : t) := Raw.elements_1 (s:=s).
- Definition elements_2 (s : t) := Raw.elements_2 (s:=s).
- Definition elements_3 (s : t) := Raw.elements_3 (unique s).
-  
- Definition choose (s:t) := Raw.choose s.
- Definition choose_1 (s : t) := Raw.choose_1 (s:=s).
- Definition choose_2 (s : t) := Raw.choose_2 (s:=s).
-  
- Definition fold (B : Set) (f : elt -> B -> B) (s : t) := Raw.fold (B:=B) f s. 
- Definition fold_1 (s : t) := Raw.fold_1 (unique s). 
+  Lemma mem_1 : In x s -> mem x s = true.
+  Proof. exact (fun H => Raw.mem_1 H). Qed.
+  Lemma mem_2 : mem x s = true -> In x s. 
+  Proof. exact (fun H => Raw.mem_2 H). Qed.
  
- Definition cardinal (s : t) := Raw.cardinal s.
- Definition cardinal_1 (s : t) := Raw.cardinal_1 (unique s). 
+  Lemma equal_1 : Equal s s' -> equal s s' = true.
+  Proof. exact (Raw.equal_1 s.(unique) s'.(unique)). Qed.
+  Lemma equal_2 : equal s s' = true -> Equal s s'.
+  Proof. exact (Raw.equal_2 s.(unique) s'.(unique)). Qed.
+
+  Lemma subset_1 : Subset s s' -> subset s s' = true.
+  Proof. exact (Raw.subset_1 s.(unique) s'.(unique)). Qed.
+  Lemma subset_2 : subset s s' = true -> Subset s s'.
+  Proof. exact (Raw.subset_2 s.(unique) s'.(unique)). Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof. exact Raw.empty_1. Qed.
+
+  Lemma is_empty_1 : Empty s -> is_empty s = true. 
+  Proof. exact (fun H => Raw.is_empty_1 H). Qed.
+  Lemma is_empty_2 : is_empty s = true -> Empty s.
+  Proof. exact (fun H => Raw.is_empty_2 H). Qed.
  
- Definition filter (f : elt -> bool) (s : t) :=
-   Build_slist (Raw.filter_unique (unique s) f).
- Definition filter_1 (s : t)(x:elt)(f: elt -> bool)(H:compat_bool X.eq f) := 
-    @Raw.filter_1 s x f.
- Definition filter_2 (s : t) := Raw.filter_2 (s:=s).
- Definition filter_3 (s : t) := Raw.filter_3 (s:=s).
+  Lemma add_1 : E.eq x y -> In y (add x s).
+  Proof. exact (fun H => Raw.add_1 s.(unique) H). Qed.
+  Lemma add_2 : In y s -> In y (add x s).
+  Proof. exact (fun H => Raw.add_2 s.(unique) x H). Qed.
+  Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
+  Proof. exact (fun H => Raw.add_3 s.(unique) H). Qed.
+
+  Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
+  Proof. exact (fun H => Raw.remove_1 s.(unique) H). Qed.
+  Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+  Proof. exact (fun H H' => Raw.remove_2 s.(unique) H H'). Qed.
+  Lemma remove_3 : In y (remove x s) -> In y s.
+  Proof. exact (fun H => Raw.remove_3 s.(unique) H). Qed.
+
+  Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
+  Proof. exact (fun H => Raw.singleton_1 H). Qed.
+  Lemma singleton_2 : E.eq x y -> In y (singleton x). 
+  Proof. exact (fun H => Raw.singleton_2 H). Qed.
+
+  Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
+  Proof. exact (fun H => Raw.union_1 s.(unique) s'.(unique) H). Qed.
+  Lemma union_2 : In x s -> In x (union s s'). 
+  Proof. exact (fun H => Raw.union_2 s.(unique) s'.(unique) H). Qed.
+  Lemma union_3 : In x s' -> In x (union s s').
+  Proof. exact (fun H => Raw.union_3 s.(unique) s'.(unique) H). Qed.
+
+  Lemma inter_1 : In x (inter s s') -> In x s.
+  Proof. exact (fun H => Raw.inter_1 s.(unique) s'.(unique) H). Qed.
+  Lemma inter_2 : In x (inter s s') -> In x s'.
+  Proof. exact (fun H => Raw.inter_2 s.(unique) s'.(unique) H). Qed.
+  Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
+  Proof. exact (fun H => Raw.inter_3 s.(unique) s'.(unique) H). Qed.
+
+  Lemma diff_1 : In x (diff s s') -> In x s. 
+  Proof. exact (fun H => Raw.diff_1 s.(unique) s'.(unique) H). Qed.
+  Lemma diff_2 : In x (diff s s') -> ~ In x s'.
+  Proof. exact (fun H => Raw.diff_2 s.(unique) s'.(unique) H). Qed.
+  Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+  Proof. exact (fun H => Raw.diff_3 s.(unique) s'.(unique) H). Qed.
  
- Definition for_all (f : elt -> bool) (s : t) := Raw.for_all f s.
- Definition for_all_1 (s : t) := Raw.for_all_1 (s:=s). 
- Definition for_all_2 (s : t) := Raw.for_all_2 (s:=s). 
+  Lemma fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof. exact (Raw.fold_1 s.(unique)). Qed.
 
- Definition exists_ (f : elt -> bool) (s : t) := Raw.exists_ f s.
- Definition exists_1 (s : t) := Raw.exists_1 (s:=s). 
- Definition exists_2 (s : t) := Raw.exists_2 (s:=s). 
+  Lemma cardinal_1 : cardinal s = length (elements s).
+  Proof. exact (Raw.cardinal_1 s.(unique)). Qed.
 
- Definition partition (f : elt -> bool) (s : t) :=
-   let p := Raw.partition f s in
-   (Build_slist (this:=fst p) (Raw.partition_unique_1 (unique s) f),
-   Build_slist (this:=snd p) (Raw.partition_unique_2 (unique s) f)).
- Definition partition_1 (s : t) := Raw.partition_1 s.
- Definition partition_2 (s : t) := Raw.partition_2 s. 
-
- Definition eq (s s' : t) := Raw.eq s s'.
- Definition eq_refl (s : t) := Raw.eq_refl s.
- Definition eq_sym (s s' : t) := Raw.eq_sym (s:=s) (s':=s').
- Definition eq_trans (s s' s'' : t) :=
-   Raw.eq_trans (s:=s) (s':=s') (s'':=s'').
+  Section Filter.
+  
+  Variable f : elt -> bool.
+
+  Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
+  Proof. exact (fun H => @Raw.filter_1 s x f). Qed.
+  Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+  Proof. exact (@Raw.filter_2 s x f). Qed.
+  Lemma filter_3 :
+      compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
+  Proof. exact (@Raw.filter_3 s x f). Qed.
+
+  Lemma for_all_1 :
+      compat_bool E.eq f ->
+      For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. exact (@Raw.for_all_1 s f). Qed.
+  Lemma for_all_2 :
+      compat_bool E.eq f ->
+      for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. exact (@Raw.for_all_2 s f). Qed.
+
+  Lemma exists_1 :
+      compat_bool E.eq f ->
+      Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof. exact (@Raw.exists_1 s f). Qed.
+  Lemma exists_2 :
+      compat_bool E.eq f ->
+      exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. exact (@Raw.exists_2 s f). Qed.
+
+  Lemma partition_1 :
+      compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
+  Proof. exact (@Raw.partition_1 s f). Qed.
+  Lemma partition_2 :
+      compat_bool E.eq f ->
+      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof. exact (@Raw.partition_2 s f). Qed.
+
+  End Filter.
+
+  Lemma elements_1 : In x s -> InA E.eq x (elements s).
+  Proof. exact (fun H => Raw.elements_1 H). Qed.
+  Lemma elements_2 : InA E.eq x (elements s) -> In x s.
+  Proof. exact (fun H => Raw.elements_2 H). Qed.
+  Lemma elements_3 : NoDupA E.eq (elements s).
+  Proof. exact (Raw.elements_3 s.(unique)). Qed.
+
+  Lemma choose_1 : choose s = Some x -> In x s.
+  Proof. exact (fun H => Raw.choose_1 H). Qed.
+  Lemma choose_2 : choose s = None -> Empty s.
+  Proof. exact (fun H => Raw.choose_2 H). Qed.
+
+ End Spec.
 
 End Make.
diff --git a/theories/FSets/FSetWeakProperties.v b/theories/FSets/FSetWeakProperties.v
new file mode 100644
index 00000000..a0054d36
--- /dev/null
+++ b/theories/FSets/FSetWeakProperties.v
@@ -0,0 +1,896 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetWeakProperties.v 8853 2006-05-23 18:17:38Z herbelin $ *)
+
+(** * Finite sets library *)
+
+(** NB: this file is a clone of [FSetProperties] for weak sets
+     and should remain so until we find a way to share the two. *)
+
+(** This functor derives additional properties from [FSetWeakInterface.S].
+    Contrary to the functor in [FSetWeakEqProperties] it uses 
+    predicates over sets instead of sets operations, i.e.
+    [In x s] instead of [mem x s=true], 
+    [Equal s s'] instead of [equal s s'=true], etc. *)
+
+Require Export FSetWeakInterface. 
+Require Import FSetWeakFacts.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Hint Unfold transpose compat_op.
+Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence.
+
+Module Properties (M: S).
+  Import M.E.
+  Import M.
+  Import Logic. (* to unmask [eq] *)  
+  Import Peano. (* to unmask [lt] *)
+  
+   (** Results about lists without duplicates *)
+
+  Module FM := Facts M.
+  Import FM.
+
+  Definition Add (x : elt) (s s' : t) :=
+    forall y : elt, In y s' <-> E.eq x y \/ In y s.
+
+  Lemma In_dec : forall x s, {In x s} + {~ In x s}.
+  Proof.
+  intros; generalize (mem_iff s x); case (mem x s); intuition.
+  Qed.
+
+  Section BasicProperties.
+
+  (** properties of [Equal] *)
+
+  Lemma equal_refl : forall s, s[=]s.
+  Proof.
+  unfold Equal; intuition.
+  Qed.
+
+  Lemma equal_sym : forall s s', s[=]s' -> s'[=]s.
+  Proof.
+  unfold Equal; intros.
+  rewrite H; intuition.
+  Qed.
+
+  Lemma equal_trans : forall s1 s2 s3, s1[=]s2 -> s2[=]s3 -> s1[=]s3.
+  Proof.
+  unfold Equal; intros.
+  rewrite H; exact (H0 a).
+  Qed.
+
+  Variable s s' s'' s1 s2 s3 : t.
+  Variable x x' : elt.
+
+  (** properties of [Subset] *)
+  
+  Lemma subset_refl : s[<=]s. 
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'.
+  Proof.
+  unfold Subset, Equal; intuition.
+  Qed.
+
+  Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma subset_equal : s[=]s' -> s[<=]s'.
+  Proof.
+  unfold Subset, Equal; firstorder.
+  Qed.
+
+  Lemma subset_empty : empty[<=]s.
+  Proof.
+  unfold Subset; intros a; set_iff; intuition.
+  Qed.
+
+  Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2.
+  Proof.
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3.
+  Proof.
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2.
+  Proof.
+  unfold Subset; intros H H0 a; set_iff; intuition.
+  rewrite <- H2; auto.
+  Qed.
+
+  Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+ 
+  Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1.
+  Proof.
+  unfold Subset, Equal; split; intros; intuition; generalize (H a); intuition.
+  Qed.
+
+  (** properties of [empty] *)
+
+  Lemma empty_is_empty_1 : Empty s -> s[=]empty.
+  Proof.
+  unfold Empty, Equal; intros; generalize (H a); set_iff; tauto.
+  Qed.
+
+  Lemma empty_is_empty_2 : s[=]empty -> Empty s.
+  Proof.
+  unfold Empty, Equal; intros; generalize (H a); set_iff; tauto.
+  Qed.
+
+  (** properties of [add] *)
+
+  Lemma add_equal : In x s -> add x s [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  rewrite <- H1; auto.
+  Qed.
+ 
+  Lemma add_add : add x (add x' s) [=] add x' (add x s).
+  Proof. 
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  (** properties of [remove] *)
+
+  Lemma remove_equal : ~ In x s -> remove x s [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  rewrite H1 in H; auto.
+  Qed.
+
+  Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  (** properties of [add] and [remove] *)
+
+  Lemma add_remove : In x s -> add x (remove x s) [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; elim (eq_dec x a); intuition.
+  rewrite <- H1; auto.
+  Qed.
+
+  Lemma remove_add : ~In x s -> remove x (add x s) [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; elim (eq_dec x a); intuition.
+  rewrite H1 in H; auto.
+  Qed.
+
+  (** properties of [singleton] *)
+
+  Lemma singleton_equal_add : singleton x [=] add x empty.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  Qed.
+
+  (** properties of [union] *)
+
+  Lemma union_sym : union s s' [=] union s' s.
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'.
+  Proof.
+  unfold Subset, Equal; intros; set_iff; intuition.
+  Qed.
+
+  Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma union_assoc : union (union s s') s'' [=] union s (union s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma add_union_singleton : add x s [=] union (singleton x) s.
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_add : union (add x s) s' [=] add x (union s s').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_subset_1 : s [<=] union s s'.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma union_subset_2 : s' [<=] union s s'.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''.
+  Proof.
+  unfold Subset; intros H H0 a; set_iff; intuition.
+  Qed.
+
+  Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
+  Proof. 
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
+  Proof. 
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma empty_union_1 : Empty s -> union s s' [=] s'.
+  Proof.
+  unfold Equal, Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma empty_union_2 : Empty s -> union s' s [=] s'.
+  Proof.
+  unfold Equal, Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). 
+  Proof.
+  intros; set_iff; intuition. 
+  Qed.  
+
+  (** properties of [inter] *)
+
+  Lemma inter_sym : inter s s' [=] inter s' s.
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  Qed.
+
+  Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s').
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  rewrite <- H1; auto.
+  Qed.
+
+  Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  destruct H; rewrite H0; auto.
+  Qed.
+
+  Lemma empty_inter_1 : Empty s -> Empty (inter s s').
+  Proof.
+  unfold Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma empty_inter_2 : Empty s' -> Empty (inter s s').
+  Proof.
+  unfold Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma inter_subset_1 : inter s s' [<=] s.
+  Proof.
+  unfold Subset; intro a; set_iff; tauto.
+  Qed.
+
+  Lemma inter_subset_2 : inter s s' [<=] s'.
+  Proof.
+  unfold Subset; intro a; set_iff; tauto.
+  Qed.
+
+  Lemma inter_subset_3 :
+   s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'.
+  Proof.
+  unfold Subset; intros H H' a; set_iff; intuition.
+  Qed.
+
+  (** properties of [diff] *)
+
+  Lemma empty_diff_1 : Empty s -> Empty (diff s s'). 
+  Proof.
+  unfold Empty, Equal; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma empty_diff_2 : Empty s -> diff s' s [=] s'.
+  Proof.
+  unfold Empty, Equal; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma diff_subset : diff s s' [<=] s.
+  Proof.
+  unfold Subset; intros a; set_iff; tauto.
+  Qed.
+
+  Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty.
+  Proof.
+  unfold Subset, Equal; intros; set_iff; intuition; absurd (In a empty); auto.
+  Qed.
+
+  Lemma remove_diff_singleton :
+   remove x s [=] diff s (singleton x).
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  Qed.
+
+  Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. 
+  Proof.
+  unfold Equal; intros; set_iff; intuition; absurd (In a empty); auto.
+  Qed.
+
+  Lemma diff_inter_all : union (diff s s') (inter s s') [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  elim (In_dec a s'); auto.
+  Qed.
+
+  (** properties of [Add] *)
+
+  Lemma Add_add : Add x s (add x s).
+  Proof.
+   unfold Add; intros; set_iff; intuition.
+  Qed.
+
+  Lemma Add_remove : In x s -> Add x (remove x s) s. 
+  Proof. 
+    unfold Add; intros; set_iff; intuition.
+    elim (eq_dec x y); auto.
+    rewrite <- H1; auto.
+  Qed.
+
+  Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s'').
+  Proof. 
+  unfold Add; intros; set_iff; rewrite H; tauto.
+  Qed.
+
+  Lemma inter_Add :
+   In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s'').
+  Proof. 
+  unfold Add; intros; set_iff; rewrite H0; intuition.
+  rewrite <- H2; auto.
+  Qed.  
+
+  Lemma union_Equal :
+   In x s'' -> Add x s s' -> union s s'' [=] union s' s''.
+  Proof. 
+  unfold Add, Equal; intros; set_iff; rewrite H0; intuition. 
+  rewrite <- H1; auto.
+  Qed.  
+
+  Lemma inter_Add_2 :
+   ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''.
+  Proof.
+  unfold Add, Equal; intros; set_iff; rewrite H0; intuition.
+  destruct H; rewrite H1; auto.
+  Qed.
+
+  End BasicProperties.
+
+  Hint Immediate equal_sym: set.
+  Hint Resolve equal_refl equal_trans : set.
+
+  Hint Immediate add_remove remove_add union_sym inter_sym: set.
+  Hint Resolve subset_refl subset_equal subset_antisym 
+    subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 
+    subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal
+    remove_equal singleton_equal_add union_subset_equal union_equal_1 
+    union_equal_2 union_assoc add_union_singleton union_add union_subset_1 
+    union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2
+    inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2
+    empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 
+    empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union 
+    inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal 
+    remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove
+    Equal_remove add_add : set.
+
+  (** * Alternative (weaker) specifications for [fold] *)
+
+  Section Old_Spec_Now_Properties. 
+
+  Notation NoDup := (NoDupA E.eq).
+
+  (** When [FSets] was first designed, the order in which Ocaml's [Set.fold]
+        takes the set elements was unspecified. This specification reflects this fact: 
+  *)
+
+  Lemma fold_0 : 
+      forall s (A : Set) (i : A) (f : elt -> A -> A),
+      exists l : list elt,
+        NoDup l /\
+        (forall x : elt, In x s <-> InA E.eq x l) /\
+        fold f s i = fold_right f i l.
+  Proof.
+  intros; exists (rev (elements s)); split.
+  apply NoDupA_rev; auto.
+  exact E.eq_trans.
+  split; intros.
+  rewrite elements_iff; do 2 rewrite InA_alt.
+  split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition.
+  rewrite fold_left_rev_right.
+  apply fold_1.
+  Qed.
+
+  (** An alternate (and previous) specification for [fold] was based on 
+      the recursive structure of a set. It is now lemmas [fold_1] and 
+      [fold_2]. *)
+
+  Lemma fold_1 :
+   forall s (A : Set) (eqA : A -> A -> Prop) 
+     (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A),
+   Empty s -> eqA (fold f s i) i.
+  Proof.
+  unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))).
+  rewrite H3; clear H3.
+  generalize H H2; clear H H2; case l; simpl; intros.
+  refl_st.
+  elim (H e).
+  elim (H2 e); intuition. 
+  Qed.
+
+  Lemma fold_2 :
+   forall s s' x (A : Set) (eqA : A -> A -> Prop)
+     (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A),
+   compat_op E.eq eqA f ->
+   transpose eqA f ->
+   ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
+  Proof.
+  intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); 
+    destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
+  rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
+  apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto.
+  eauto.
+  exact eq_dec.
+  rewrite <- Hl1; auto.
+  intros; rewrite <- Hl1; rewrite <- Hl'1; auto.
+  Qed.
+
+  (** Similar specifications for [cardinal]. *)
+
+  Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0.
+  Proof.
+  intros; rewrite cardinal_1; rewrite M.fold_1.
+  symmetry; apply fold_left_length; auto.
+  Qed.
+
+  Lemma cardinal_0 :
+     forall s, exists l : list elt,
+        NoDupA E.eq l /\
+        (forall x : elt, In x s <-> InA E.eq x l) /\ 
+        cardinal s = length l.
+  Proof. 
+  intros; exists (elements s); intuition; apply cardinal_1.
+  Qed.
+
+  Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0.
+  Proof.
+  intros; rewrite cardinal_fold; apply fold_1; auto.
+  Qed.
+
+  Lemma cardinal_2 :
+    forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s).
+  Proof.
+  intros; do 2 rewrite cardinal_fold.
+  change S with ((fun _ => S) x).
+  apply fold_2; auto.
+  Qed.
+
+  End Old_Spec_Now_Properties.
+
+  (** * Induction principle over sets *)
+
+  Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. 
+  Proof. 
+    intros s; rewrite M.cardinal_1; intros H a; red.
+    rewrite elements_iff.
+    destruct (elements s); simpl in *; discriminate || inversion 1.
+  Qed.
+  Hint Resolve cardinal_inv_1.
+ 
+  Lemma cardinal_inv_2 :
+   forall s n, cardinal s = S n -> { x : elt | In x s }.
+  Proof. 
+    intros; rewrite M.cardinal_1 in H.
+    generalize (elements_2 (s:=s)).
+    destruct (elements s); try discriminate. 
+    exists e; auto.
+  Qed.
+
+  Lemma Equal_cardinal_aux :
+   forall n s s', cardinal s = n -> s[=]s' -> cardinal s = cardinal s'.
+  Proof.
+     simple induction n; intros.
+     rewrite H; symmetry .
+     apply cardinal_1.
+     rewrite <- H0; auto.
+     destruct (cardinal_inv_2 H0) as (x,H2).
+     revert H0.
+     rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set.
+     rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); auto with set.
+     rewrite H1 in H2; auto with set.
+  Qed.
+
+  Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'.
+  Proof. 
+    intros; apply Equal_cardinal_aux with (cardinal s); auto.
+  Qed.
+
+  Add Morphism cardinal : cardinal_m.
+  Proof.
+  exact Equal_cardinal.
+  Qed.
+
+  Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal.
+
+  Lemma cardinal_induction :
+   forall P : t -> Type,
+   (forall s, Empty s -> P s) ->
+   (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') ->
+   forall n s, cardinal s = n -> P s.
+  Proof.
+  simple induction n; intros; auto.
+  destruct (cardinal_inv_2 H) as (x,H0). 
+  apply X0 with (remove x s) x; auto.
+  apply X1; auto.
+  rewrite (cardinal_2 (x:=x)(s:=remove x s)(s':=s)) in H; auto.
+  Qed.
+
+  Lemma set_induction :
+   forall P : t -> Type,
+   (forall s : t, Empty s -> P s) ->
+   (forall s s' : t, P s -> forall x : elt, ~In x s -> Add x s s' -> P s') ->
+   forall s : t, P s.
+  Proof.
+  intros; apply cardinal_induction with (cardinal s); auto.
+  Qed.  
+
+  (** Other properties of [fold]. *)
+
+  Section Fold. 
+  Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA).
+  Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f).
+
+  Section Fold_1. 
+  Variable i i':A.
+
+  Lemma fold_empty : eqA (fold f empty i) i.
+  Proof. 
+  apply fold_1; auto.
+  Qed.
+
+  Lemma fold_equal : 
+   forall s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
+  Proof. 
+  intros s; pattern s; apply set_induction; clear s; intros.
+  trans_st i.
+  apply fold_1; auto.
+  sym_st; apply fold_1; auto.
+  rewrite <- H0; auto.
+  trans_st (f x (fold f s i)).
+  apply fold_2 with (eqA := eqA); auto.
+  sym_st; apply fold_2 with (eqA := eqA); auto.
+  unfold Add in *; intros.
+  rewrite <- H2; auto.
+  Qed.
+   
+  Lemma fold_add : forall s x, ~In x s -> 
+   eqA (fold f (add x s) i) (f x (fold f s i)).
+  Proof. 
+  intros; apply fold_2 with (eqA := eqA); auto.
+  Qed.
+
+  Lemma add_fold : forall s x, In x s -> 
+   eqA (fold f (add x s) i) (fold f s i).
+  Proof.
+  intros; apply fold_equal; auto with set.
+  Qed.
+
+  Lemma remove_fold_1: forall s x, In x s -> 
+   eqA (f x (fold f (remove x s) i)) (fold f s i).
+  Proof.
+  intros.
+  sym_st.
+  apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  Lemma remove_fold_2: forall s x, ~In x s -> 
+   eqA (fold f (remove x s) i) (fold f s i).
+  Proof.
+  intros.
+  apply fold_equal; auto with set.
+  Qed.
+
+  Lemma fold_commutes : forall s x, 
+   eqA (fold f s (f x i)) (f x (fold f s i)).
+  Proof.
+  intros; pattern s; apply set_induction; clear s; intros.
+  trans_st (f x i).
+  apply fold_1; auto.
+  sym_st.
+  apply Comp; auto.
+  apply fold_1; auto.
+  trans_st (f x0 (fold f s (f x i))).
+  apply fold_2 with (eqA:=eqA); auto.
+  trans_st (f x0 (f x (fold f s i))).
+  trans_st (f x (f x0 (fold f s i))).
+  apply Comp; auto.
+  sym_st.
+  apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  Lemma fold_init : forall s, eqA i i' -> 
+   eqA (fold f s i) (fold f s i').
+  Proof. 
+  intros; pattern s; apply set_induction; clear s; intros.
+  trans_st i.
+  apply fold_1; auto.
+  trans_st i'.
+  sym_st; apply fold_1; auto.
+  trans_st (f x (fold f s i)).
+  apply fold_2 with (eqA:=eqA); auto.
+  trans_st (f x (fold f s i')).
+  sym_st; apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  End Fold_1.
+  Section Fold_2.
+  Variable i:A.
+
+  Lemma fold_union_inter : forall s s',
+   eqA (fold f (union s s') (fold f (inter s s') i))
+       (fold f s (fold f s' i)).
+  Proof.
+  intros; pattern s; apply set_induction; clear s; intros.
+  trans_st (fold f s' (fold f (inter s s') i)).
+  apply fold_equal; auto with set.
+  trans_st (fold f s' i).
+  apply fold_init; auto.
+  apply fold_1; auto with set.
+  sym_st; apply fold_1; auto.
+  rename s'0 into s''.
+  destruct (In_dec x s').
+  (* In x s' *)   
+  trans_st (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set.
+  apply fold_init; auto.
+  apply fold_2 with (eqA:=eqA); auto with set.
+  rewrite inter_iff; intuition.
+  trans_st (f x (fold f s (fold f s' i))).
+  trans_st (fold f (union s s') (f x (fold f (inter s s') i))).
+  apply fold_equal; auto.
+  apply equal_sym; apply union_Equal with x; auto with set.
+  trans_st (f x (fold f (union s s') (fold f (inter s s') i))).
+  apply fold_commutes; auto.
+  sym_st; apply fold_2 with (eqA:=eqA); auto.
+  (* ~(In x s') *)
+  trans_st (f x (fold f (union s s') (fold f (inter s'' s') i))).
+  apply fold_2 with (eqA:=eqA); auto with set.
+  trans_st (f x (fold f (union s s') (fold f (inter s s') i))).
+  apply Comp;auto.
+  apply fold_init;auto.
+  apply fold_equal;auto.
+  apply equal_sym; apply inter_Add_2 with x; auto with set.
+  trans_st (f x (fold f s (fold f s' i))).
+  sym_st; apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  End Fold_2.
+  Section Fold_3.
+  Variable i:A.
+
+  Lemma fold_diff_inter : forall s s', 
+   eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i).
+  Proof.
+  intros.
+  trans_st (fold f (union (diff s s') (inter s s')) 
+              (fold f (inter (diff s s') (inter s s')) i)).
+  sym_st; apply fold_union_inter; auto.
+  trans_st (fold f s (fold f (inter (diff s s') (inter s s')) i)).
+  apply fold_equal; auto with set.
+  apply fold_init; auto.
+  apply fold_1; auto with set.
+  Qed.
+
+  Lemma fold_union: forall s s', (forall x, ~In x s\/~In x s') ->
+   eqA (fold f (union s s') i) (fold f s (fold f s' i)).
+  Proof.
+  intros.
+  trans_st (fold f (union s s') (fold f (inter s s') i)).
+  apply fold_init; auto.
+  sym_st; apply fold_1; auto with set.
+  unfold Empty; intro a; generalize (H a); set_iff; tauto.
+  apply fold_union_inter; auto.
+  Qed.
+
+  End Fold_3.
+  End Fold.
+
+  Lemma fold_plus :
+   forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p.
+  Proof.
+  assert (st := gen_st nat).
+  assert (fe : compat_op E.eq (@eq _) (fun _ => S)) by (unfold compat_op; auto). 
+  assert (fp : transpose (@eq _) (fun _:elt => S)) by (unfold transpose; auto).
+  intros s p; pattern s; apply set_induction; clear s; intros.
+  rewrite (fold_1 st p (fun _ => S) H).
+  rewrite (fold_1 st 0 (fun _ => S) H); trivial.
+  assert (forall p s', Add x s s' -> fold (fun _ => S) s' p = S (fold (fun _ => S) s p)).
+   change S with ((fun _ => S) x).  
+   intros; apply fold_2; auto.
+  rewrite H2; auto.
+  rewrite (H2 0); auto.
+  rewrite H.
+  simpl; auto.
+  Qed.
+
+  (** properties of [cardinal] *)
+
+  Lemma empty_cardinal : cardinal empty = 0.
+  Proof.
+  rewrite cardinal_fold; apply fold_1; auto.
+  Qed.
+
+  Hint Immediate empty_cardinal cardinal_1 : set.
+
+  Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1.
+  Proof.
+  intros.
+  rewrite (singleton_equal_add x).
+  replace 0 with (cardinal empty); auto with set.
+  apply cardinal_2 with x; auto with set.
+  Qed.
+
+  Hint Resolve singleton_cardinal: set.
+
+  Lemma diff_inter_cardinal :
+   forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s .
+  Proof.
+  intros; do 3 rewrite cardinal_fold.
+  rewrite <- fold_plus.
+  apply fold_diff_inter with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma union_cardinal: 
+   forall s s', (forall x, ~In x s\/~In x s') -> 
+   cardinal (union s s')=cardinal s+cardinal s'.
+  Proof.
+  intros; do 3 rewrite cardinal_fold.
+  rewrite <- fold_plus.
+  apply fold_union; auto.
+  Qed.
+
+  Lemma subset_cardinal : 
+   forall s s', s[<=]s' -> cardinal s <= cardinal s' .
+  Proof.
+  intros.
+  rewrite <- (diff_inter_cardinal s' s).
+  rewrite (inter_sym s' s).
+  rewrite (inter_subset_equal H); auto with arith.
+  Qed.
+
+  Lemma subset_cardinal_lt : 
+   forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'.
+  Proof. 
+  intros.
+  rewrite <- (diff_inter_cardinal s' s).
+  rewrite (inter_sym s' s).
+  rewrite (inter_subset_equal H).
+  generalize (@cardinal_inv_1 (diff s' s)).
+  destruct (cardinal (diff s' s)).
+  intro H2; destruct (H2 (refl_equal _) x).
+  set_iff; auto.
+  intros _.
+  change (0 + cardinal s < S n + cardinal s).
+  apply Plus.plus_lt_le_compat; auto with arith.
+  Qed. 
+
+  Theorem union_inter_cardinal :
+   forall s s', cardinal (union s s') + cardinal (inter s s')  = cardinal s  + cardinal s' .
+  Proof.
+  intros.
+  do 4 rewrite cardinal_fold.
+  do 2 rewrite <- fold_plus.
+  apply fold_union_inter with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma union_cardinal_inter : 
+   forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s').
+  Proof.
+  intros.
+  rewrite <- union_inter_cardinal.
+  rewrite Plus.plus_comm.
+  auto with arith.
+  Qed.
+
+  Lemma union_cardinal_le : 
+   forall s s', cardinal (union s s') <= cardinal s  + cardinal s'.
+  Proof.
+   intros; generalize (union_inter_cardinal s s').
+   intros; rewrite <- H; auto with arith.
+  Qed.
+
+  Lemma add_cardinal_1 : 
+   forall s x, In x s -> cardinal (add x s) = cardinal s.
+  Proof.
+  auto with set.  
+  Qed.
+
+  Lemma add_cardinal_2 :
+   forall s x, ~In x s -> cardinal (add x s) = S (cardinal s).
+  Proof.
+  intros.
+  do 2 rewrite cardinal_fold.
+  change S with ((fun _ => S) x);
+   apply fold_add with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma remove_cardinal_1 :
+   forall s x, In x s -> S (cardinal (remove x s)) = cardinal s.
+  Proof.
+  intros.
+  do 2 rewrite cardinal_fold.
+  change S with ((fun _ =>S) x).
+  apply remove_fold_1 with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma remove_cardinal_2 : 
+   forall s x, ~In x s -> cardinal (remove x s) = cardinal s.
+  Proof. 
+  auto with set.
+  Qed.
+
+  Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2.
+
+End Properties.
diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v
index 9dfcd51f..b0402db6 100644
--- a/theories/FSets/FSets.v
+++ b/theories/FSets/FSets.v
@@ -6,9 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSets.v 8667 2006-03-28 11:59:44Z letouzey $ *)
+(* $Id: FSets.v 8897 2006-06-05 21:04:10Z letouzey $ *)
 
 Require Export OrderedType.
+Require Export OrderedTypeEx.
+Require Export OrderedTypeAlt.
 Require Export FSetInterface.
 Require Export FSetBridge.
 Require Export FSetProperties.
diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v
index 2bf08dc7..f966cd4d 100644
--- a/theories/FSets/OrderedType.v
+++ b/theories/FSets/OrderedType.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: OrderedType.v 8667 2006-03-28 11:59:44Z letouzey $ *)
+(* $Id: OrderedType.v 8834 2006-05-20 00:41:35Z letouzey $ *)
 
 Require Export SetoidList.
 Set Implicit Arguments.
@@ -313,6 +313,8 @@ Ltac false_order := elimtype False; order.
 
 (* Specialization of resuts about lists modulo. *)
 
+Section ForNotations.
+
 Notation In:=(InA eq).
 Notation Inf:=(lelistA lt).
 Notation Sort:=(sort lt).
@@ -346,12 +348,14 @@ Proof. exact (InfA_alt eq_refl eq_sym lt_trans lt_eq eq_lt). Qed.
 Lemma Sort_NoDup : forall l, Sort l -> NoDup l.
 Proof. exact (SortA_NoDupA eq_refl eq_sym lt_trans lt_not_eq lt_eq eq_lt) . Qed.
 
+End ForNotations.
+
 Hint Resolve ListIn_In Sort_NoDup Inf_lt. 
 Hint Immediate In_eq Inf_lt. 
 
 End OrderedTypeFacts.
 
-Module PairOrderedType(O:OrderedType).
+Module KeyOrderedType(O:OrderedType).
  Import O.
  Module MO:=OrderedTypeFacts(O).
  Import MO.
@@ -561,6 +565,6 @@ Module PairOrderedType(O:OrderedType).
  Hint Resolve Sort_Inf_NotIn.
  Hint Resolve In_inv_2 In_inv_3.
 
-End PairOrderedType.
+End KeyOrderedType.
 
 
diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/FSets/OrderedTypeAlt.v
new file mode 100644
index 00000000..9bcfbfc7
--- /dev/null
+++ b/theories/FSets/OrderedTypeAlt.v
@@ -0,0 +1,129 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: OrderedTypeAlt.v 8773 2006-04-29 14:31:32Z letouzey $ *)
+
+Require Import OrderedType.
+
+(** * An alternative (but equivalent) presentation for an Ordered Type inferface. *)
+
+(** NB: [comparison], defined in [theories/Init/datatypes.v] is [Eq|Lt|Gt]
+whereas [compare], defined in [theories/FSets/OrderedType.v] is [EQ _ | LT _ | GT _ ] 
+*)
+
+Module Type OrderedTypeAlt.
+
+ Parameter t : Set.
+ 
+ Parameter compare : t -> t -> comparison.
+
+ Infix "?=" := compare (at level 70, no associativity).
+
+ Parameter compare_sym : 
+   forall x y, (y?=x) = CompOpp (x?=y).
+ Parameter compare_trans : 
+   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
+
+End OrderedTypeAlt. 
+
+(** From this new presentation to the original one. *)
+
+Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType.
+ Import O.
+
+ Definition t := t.
+
+ Definition eq x y := (x?=y) = Eq.
+ Definition lt x y := (x?=y) = Lt.
+
+ Lemma eq_refl : forall x, eq x x.
+ Proof.
+ intro x.
+ unfold eq.
+ assert (H:=compare_sym x x).
+ destruct (x ?= x); simpl in *; try discriminate; auto.
+ Qed.
+
+ Lemma eq_sym : forall x y, eq x y -> eq y x.
+ Proof. 
+ unfold eq; intros.
+ rewrite compare_sym.
+ rewrite H; simpl; auto.
+ Qed.
+
+ Definition eq_trans := (compare_trans Eq).
+
+ Definition lt_trans := (compare_trans Lt).
+
+ Lemma lt_not_eq : forall x y, lt x y -> ~eq x y.
+ Proof.
+ unfold eq, lt; intros.
+ rewrite H; discriminate.
+ Qed.
+
+ Definition compare : forall x y, Compare lt eq x y.
+ Proof.
+ intros.
+ case_eq (x ?= y); intros.
+ apply EQ; auto.
+ apply LT; auto.
+ apply GT; red.
+ rewrite compare_sym; rewrite H; auto.
+ Defined.
+
+End OrderedType_from_Alt. 
+
+(** From the original presentation to this alternative one. *)
+
+Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt.
+ Import O.
+ Module MO:=OrderedTypeFacts(O).
+ Import MO.
+
+ Definition t := t.
+
+ Definition compare x y := match compare x y with 
+   | LT _ => Lt
+   | EQ _ => Eq
+   | GT _ => Gt
+  end. 
+
+ Infix "?=" := compare (at level 70, no associativity).
+
+ Lemma compare_sym : 
+   forall x y, (y?=x) = CompOpp (x?=y).
+ Proof.
+ intros x y.
+ unfold compare.
+ destruct (O.compare y x); elim_comp; simpl; auto.
+ Qed.
+ 
+ Lemma compare_trans : 
+   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
+ Proof.
+ intros c x y z.
+ destruct c; unfold compare.
+ destruct (O.compare x y); intros; try discriminate.
+ destruct (O.compare y z); intros; try discriminate.
+ elim_comp; auto.
+ destruct (O.compare x y); intros; try discriminate.
+ destruct (O.compare y z); intros; try discriminate.
+ elim_comp; auto.
+ destruct (O.compare x y); intros; try discriminate.
+ destruct (O.compare y z); intros; try discriminate.
+ elim_comp; auto.
+ Qed.
+
+End OrderedType_to_Alt.
+
+ 
diff --git a/theories/FSets/OrderedTypeEx.v b/theories/FSets/OrderedTypeEx.v
new file mode 100644
index 00000000..1c5a4054
--- /dev/null
+++ b/theories/FSets/OrderedTypeEx.v
@@ -0,0 +1,248 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: OrderedTypeEx.v 8836 2006-05-20 21:34:27Z letouzey $ *)
+
+Require Import OrderedType.
+Require Import ZArith.
+Require Import Omega.
+Require Import NArith Ndec.
+Require Import Compare_dec.
+
+(** * Examples of Ordered Type structures. *)
+
+(** First, a particular case of [OrderedType] where 
+    the equality is the usual one of Coq. *)
+
+Module Type UsualOrderedType.
+ Parameter t : Set.
+ Definition eq := @eq t.
+ Parameter lt : t -> t -> Prop.
+ Definition eq_refl := @refl_equal t.
+ Definition eq_sym := @sym_eq t.
+ Definition eq_trans := @trans_eq t.
+ Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
+ Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+ Parameter compare : forall x y : t, Compare lt eq x y.
+End UsualOrderedType.
+
+(** a [UsualOrderedType] is in particular an [OrderedType]. *)
+
+Module UOT_to_OT (U:UsualOrderedType) <: OrderedType := U.
+
+(** [nat] is an ordered type with respect to the usual order on natural numbers. *)
+
+Module Nat_as_OT <: UsualOrderedType.
+
+  Definition t := nat.
+
+  Definition eq := @eq nat.
+  Definition eq_refl := @refl_equal t.
+  Definition eq_sym := @sym_eq t.
+  Definition eq_trans := @trans_eq t.
+
+  Definition lt := lt.
+
+  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
+  Proof. unfold lt in |- *; intros; apply lt_trans with y; auto. Qed.
+
+  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+  Proof. unfold lt, eq in |- *; intros; omega. Qed.
+
+  Definition compare : forall x y : t, Compare lt eq x y.
+  Proof.
+    intros; case (lt_eq_lt_dec x y).
+    simple destruct 1; intro.
+    constructor 1; auto.
+    constructor 2; auto.
+    intro; constructor 3; auto.
+  Qed.
+
+End Nat_as_OT.
+
+
+(** [Z] is an ordered type with respect to the usual order on integers. *)
+
+Open Scope Z_scope.
+
+Module Z_as_OT <: UsualOrderedType.
+
+  Definition t := Z.
+  Definition eq := @eq Z. 
+  Definition eq_refl := @refl_equal t.
+  Definition eq_sym := @sym_eq t.
+  Definition eq_trans := @trans_eq t.
+
+  Definition lt (x y:Z) := (x<y).
+
+  Lemma lt_trans : forall x y z, x<y -> y<z -> x<z.
+  Proof. intros; omega. Qed.
+
+  Lemma lt_not_eq : forall x y, x<y -> ~ x=y.
+  Proof. intros; omega. Qed.
+
+  Definition compare : forall x y, Compare lt eq x y.
+  Proof.
+    intros x y; case_eq (x ?= y); intros.
+    apply EQ; unfold eq; apply Zcompare_Eq_eq; auto.
+    apply LT; unfold lt, Zlt; auto.
+    apply GT; unfold lt, Zlt; rewrite <- Zcompare_Gt_Lt_antisym; auto.
+  Defined.
+
+End Z_as_OT.
+
+(** [positive] is an ordered type with respect to the usual order on natural numbers. *) 
+
+Open Scope positive_scope.
+
+Module Positive_as_OT <: UsualOrderedType.
+  Definition t:=positive.
+  Definition eq:=@eq positive.
+  Definition eq_refl := @refl_equal t.
+  Definition eq_sym := @sym_eq t.
+  Definition eq_trans := @trans_eq t.
+
+  Definition lt p q:= (p ?= q) Eq = Lt.
+ 
+  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
+  Proof. 
+  unfold lt; intros x y z.
+  change ((Zpos x < Zpos y)%Z -> (Zpos y < Zpos z)%Z -> (Zpos x < Zpos z)%Z).
+  omega.
+  Qed.
+
+  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+  Proof.
+  intros; intro.
+  rewrite H0 in H.
+  unfold lt in H.
+  rewrite Pcompare_refl in H; discriminate.
+  Qed.
+
+  Definition compare : forall x y : t, Compare lt eq x y.
+  Proof.
+  intros x y.
+  case_eq ((x ?= y) Eq); intros.
+  apply EQ; apply Pcompare_Eq_eq; auto.
+  apply LT; unfold lt; auto.
+  apply GT; unfold lt.
+  replace Eq with (CompOpp Eq); auto.
+  rewrite <- Pcompare_antisym; rewrite H; auto.
+  Qed.
+
+End Positive_as_OT.
+
+
+(** [N] is an ordered type with respect to the usual order on natural numbers. *) 
+
+Open Scope positive_scope.
+
+Module N_as_OT <: UsualOrderedType.
+  Definition t:=N.
+  Definition eq:=@eq N.
+  Definition eq_refl := @refl_equal t.
+  Definition eq_sym := @sym_eq t.
+  Definition eq_trans := @trans_eq t.
+
+  Definition lt p q:= Nle q p = false.
+ 
+  Definition lt_trans := Nlt_trans.
+
+  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+  Proof.
+  intros; intro.
+  rewrite H0 in H.
+  unfold lt in H.
+  rewrite Nle_refl in H; discriminate.
+  Qed.
+
+  Definition compare : forall x y : t, Compare lt eq x y.
+  Proof.
+  intros x y.
+  case_eq ((x ?= y)%N); intros.
+  apply EQ; apply Ncompare_Eq_eq; auto.
+  apply LT; unfold lt; auto.
+   generalize (Nle_Ncompare y x).
+   destruct (Nle y x); auto.
+   rewrite <- Ncompare_antisym.
+   destruct (x ?= y)%N; simpl; try discriminate.
+   intros (H0,_); elim H0; auto.
+  apply GT; unfold lt.
+   generalize (Nle_Ncompare x y).
+   destruct (Nle x y); auto.
+   destruct (x ?= y)%N; simpl; try discriminate.
+   intros (H0,_); elim H0; auto.
+  Qed.
+
+End N_as_OT.
+
+
+(** From two ordered types, we can build a new OrderedType 
+   over their cartesian product, using the lexicographic order. *)
+
+Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
+ Module MO1:=OrderedTypeFacts(O1).
+ Module MO2:=OrderedTypeFacts(O2).
+
+ Definition t := prod O1.t O2.t.
+  
+ Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y).
+
+ Definition lt x y := 
+    O1.lt (fst x) (fst y) \/ 
+    (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)).
+
+ Lemma eq_refl : forall x : t, eq x x.
+ Proof. 
+ intros (x1,x2); red; simpl; auto.
+ Qed.
+
+ Lemma eq_sym : forall x y : t, eq x y -> eq y x.
+ Proof. 
+ intros (x1,x2) (y1,y2); unfold eq; simpl; intuition.
+ Qed.
+
+ Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
+ Proof. 
+ intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto.
+ Qed.
+ 
+ Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. 
+ Proof.
+ intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition.
+ left; eauto.
+ left; eapply MO1.lt_eq; eauto.
+ left; eapply MO1.eq_lt; eauto.
+ right; split; eauto.
+ Qed.
+
+ Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+ Proof.
+ intros (x1,x2) (y1,y2); unfold eq, lt; simpl; intuition.
+ apply (O1.lt_not_eq H0 H1).
+ apply (O2.lt_not_eq H3 H2).
+ Qed.
+
+ Definition compare : forall x y : t, Compare lt eq x y.
+ intros (x1,x2) (y1,y2).
+ destruct (O1.compare x1 y1).
+ apply LT; unfold lt; auto.
+ destruct (O2.compare x2 y2).
+ apply LT; unfold lt; auto.
+ apply EQ; unfold eq; auto.
+ apply GT; unfold lt; auto.
+ apply GT; unfold lt; auto.
+ Qed.
+
+End PairOrderedType.
+
diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v
index f71f58c6..fdd7ba35 100644
--- a/theories/Init/Datatypes.v
+++ b/theories/Init/Datatypes.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Datatypes.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id: Datatypes.v 8872 2006-05-29 07:36:28Z herbelin $ i*)
 
 Set Implicit Arguments.
 
@@ -47,7 +47,7 @@ Inductive Empty_set : Set :=.
     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 :=
+Inductive identity (A:Type) (a:A) : A -> Type :=
     refl_identity : identity (A:=A) a a.
 Hint Resolve refl_identity: core v62.
 
@@ -57,13 +57,13 @@ Implicit Arguments identity_rect [A].
 
 (** [option A] is the extension of [A] with an extra element [None] *)
 
-Inductive option (A:Set) : Set :=
+Inductive option (A:Type) : Type :=
   | Some : A -> option A
   | None : option A.
 
 Implicit Arguments None [A].
 
-Definition option_map (A B:Set) (f:A->B) o :=
+Definition option_map (A B:Type) (f:A->B) o :=
   match o with
   | Some a => Some (f a)
   | None => None
@@ -71,7 +71,7 @@ Definition option_map (A B:Set) (f:A->B) o :=
 
 (** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *)
 (* Syntax defined in Specif.v *)
-Inductive sum (A B:Set) : Set :=
+Inductive sum (A B:Type) : Type :=
   | inl : A -> sum A B
   | inr : B -> sum A B.
 
@@ -80,7 +80,7 @@ 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 :=
+Inductive prod (A B:Type) : Type :=
     pair : A -> B -> prod A B.
 Add Printing Let prod.
 
@@ -88,31 +88,38 @@ 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.
+  Variables A B : Type.
+  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).
+ forall (A B:Type) (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),
+ forall (A B:Type) (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.
 
+Definition prod_uncurry (A B C:Type) (f:prod A B -> C) 
+  (x:A) (y:B) : C := f (pair x y).
+
+Definition prod_curry (A B C:Type) (f:A -> B -> C) 
+  (p:prod A B) : C := match p with
+                       | pair x y => f x y
+                       end.
 
 (** Comparison *)
 
@@ -127,3 +134,15 @@ Definition CompOpp (r:comparison) :=
   | Lt => Gt
   | Gt => Lt
   end.
+
+(* Compatibility *)
+
+Notation prodT := prod (only parsing).
+Notation pairT := pair (only parsing).
+Notation prodT_rect := prod_rect (only parsing).
+Notation prodT_rec := prod_rec (only parsing).
+Notation prodT_ind := prod_ind (only parsing).
+Notation fstT := fst (only parsing).
+Notation sndT := snd (only parsing).
+Notation prodT_uncurry := prod_uncurry (only parsing).
+Notation prodT_curry := prod_curry (only parsing).
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
index cbf8d7a7..71583718 100644
--- a/theories/Init/Logic.v
+++ b/theories/Init/Logic.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Logic.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id: Logic.v 8936 2006-06-09 15:43:33Z herbelin $ i*)
 
 Set Implicit Arguments.
 
@@ -280,13 +280,36 @@ Qed.
 
 Hint Immediate sym_eq sym_not_eq: core v62.
 
-(** Other notations *)
+(** Basic definitions about relations and properties *)
 
-Notation "'exists' ! x , P" := 
-  (exists x',  (fun x => P) x' /\ forall x'', (fun x => P) x'' -> x' = x'')
+Definition subrelation (A B : Type) (R R' : A->B->Prop) :=
+  forall x y, R x y -> R' x y.
+
+Definition unique (A : Type) (P : A->Prop) (x:A) :=
+  P x /\ forall (x':A), P x' -> x=x'.
+
+Definition uniqueness (A:Type) (P:A->Prop) := forall x y, P x -> P y -> x = y.
+
+(** Unique existence *)
+
+Notation "'exists' ! x , P" := (ex (unique (fun x => P)))
   (at level 200, x ident, right associativity,
    format "'[' 'exists' !  '/  ' x ,  '/  ' P ']'") : type_scope.
 Notation "'exists' ! x : A , P" := 
-  (exists x' : A,  (fun x => P) x' /\ forall x'':A, (fun x => P) x'' -> x' = x'')
+  (ex (unique (fun x:A => P)))
   (at level 200, x ident, right associativity,
    format "'[' 'exists' !  '/  ' x  :  A ,  '/  ' P ']'") : type_scope.
+
+Lemma unique_existence : forall (A:Type) (P:A->Prop),
+  ((exists x, P x) /\ uniqueness P) <-> (exists! x, P x).
+Proof.
+intros A P; split.
+  intros ((x,Hx),Huni); exists x; red; auto.
+  intros (x,(Hx,Huni)); split. 
+    exists x; assumption.
+    intros x' x'' Hx' Hx''; transitivity x.
+      symmetry; auto.
+      auto.
+Qed.
+
+
diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v
index 857ffe94..dbe944b0 100644
--- a/theories/Init/Logic_Type.v
+++ b/theories/Init/Logic_Type.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Logic_Type.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id: Logic_Type.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
 (** This module defines type constructors for types in [Type]
     ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *)
@@ -20,32 +20,6 @@ Require Export Logic.
 
 Definition notT (A:Type) := A -> False.
 
-(** Conjunction of types in [Type] *)
-
-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.
-
 (** Properties of [identity] *)
 
 Section identity_is_a_congruence.
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index 3ca93067..416647b4 100644
--- a/theories/Init/Notations.v
+++ b/theories/Init/Notations.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Notations.v 6410 2004-12-06 11:34:35Z herbelin $ i*)
+(*i $Id: Notations.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
 (** These are the notations whose level and associativity are imposed by Coq *)
 
@@ -62,6 +62,9 @@ Reserved Notation "{ x }" (at level 0, x at level 99).
 
 (** Notations for sigma-types or subsets *)
 
+Reserved Notation "{ x  |  P }" (at level 0, x at level 99).
+Reserved Notation "{ x  |  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).
 
diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v
index e7fc1ac4..dd2f7697 100644
--- a/theories/Init/Specif.v
+++ b/theories/Init/Specif.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Specif.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id: Specif.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
 (** Basic specifications : sets that may contain logical information *)
 
@@ -19,42 +19,45 @@ Require Import Logic.
 (** Subsets and Sigma-types *)
 
 (** [(sig A P)], or more suggestively [{x:A | P x}], denotes the subset 
-    of elements of the Set [A] which satisfy the predicate [P].
+    of elements of the type [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]. *)
+    of elements of the type [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 sig (A:Type) (P:A -> Prop) : Type :=
+    exist : forall x:A, P x -> sig P.
 
-Inductive sig2 (A:Set) (P Q:A -> Prop) : Set :=
-    exist2 : forall x:A, P x -> Q x -> sig2 (A:=A) P Q.
+Inductive sig2 (A:Type) (P Q:A -> Prop) : Type :=
+    exist2 : forall x:A, P x -> Q x -> sig2 P Q.
 
-(** [(sigS A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. 
-    It is a 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.
+(** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. 
+    Similarly for [(sigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *)
 
-Inductive sigS2 (A:Set) (P Q:A -> Set) : Set :=
-    existS2 : forall x:A, P x -> Q x -> sigS2 (A:=A) P Q.
+Inductive sigT (A:Type) (P:A -> Type) : Type :=
+    existT : forall x:A, P x -> sigT P.
+
+Inductive sigT2 (A:Type) (P Q:A -> Type) : Type :=
+    existT2 : forall x:A, P x -> Q x -> sigT2 P Q.
+
+(* Notations *)
 
 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].
+Arguments Scope sigT [type_scope type_scope].
+Arguments Scope sigT2 [type_scope type_scope type_scope].
 
+Notation "{ x  |  P }" := (sig (fun x => P)) : type_scope.
+Notation "{ x  |  P  &  Q }" := (sig2 (fun x => P) (fun x => Q)) : 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)) :
+Notation "{ x : A  &  P }" := (sigT (fun x:A => P)) : type_scope.
+Notation "{ x : A  &  P  &  Q }" := (sigT2 (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.
+Add Printing Let sigT.
+Add Printing Let sigT2.
 
 
 (** Projections of [sig]
@@ -67,7 +70,7 @@ Add Printing Let sigS2.
 
 Section Subset_projections.
 
-  Variable A : Set.
+  Variable A : Type.
   Variable P : A -> Prop.
 
   Definition proj1_sig (e:sig P) := match e with
@@ -82,24 +85,24 @@ Section Subset_projections.
 End Subset_projections.
 
 
-(** Projections of [sigS]
+(** Projections of [sigT]
 
     An element [x] of a sigma-type [{y:A & P y}] is a dependent pair
     made of an [a] of type [A] and an [h] of type [P a].  Then,
-    [(projS1 x)] is the first projection and [(projS2 x)] is the
-    second projection, the type of which depends on the [projS1]. *)
+    [(projT1 x)] is the first projection and [(projT2 x)] is the
+    second projection, the type of which depends on the [projT1]. *)
 
 Section Projections.
 
-  Variable A : Set.
-  Variable P : A -> Set.
+  Variable A : Type.
+  Variable P : A -> Type.
 
-  Definition projS1 (x:sigS P) : A := match x with
-                                      | existS a _ => a
+  Definition projT1 (x:sigT P) : A := match x with
+                                      | existT a _ => a
                                       end.
-  Definition projS2 (x:sigS P) : P (projS1 x) :=
-    match x return P (projS1 x) with
-    | existS _ h => h
+  Definition projT2 (x:sigT P) : P (projT1 x) :=
+    match x return P (projT1 x) with
+    | existT _ h => h
     end.
 
 End Projections.
@@ -118,7 +121,7 @@ Add Printing If sumbool.
 (** [sumor] is an option type equipped with the justification of why
     it may not be a regular value *)
 
-Inductive sumor (A:Set) (B:Prop) : Set :=
+Inductive sumor (A:Type) (B:Prop) : Type :=
   | inleft : A -> A + {B}
   | inright : B -> A + {B} 
  where "A + { B }" := (sumor A B) : type_scope.
@@ -146,12 +149,12 @@ Section Choice_lemmas.
   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)).
+   (forall x:S, sigT (fun y:S' => R' x y)) ->
+   sigT (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
+                       | existT y _ => y
                        end).
     intro z; destruct (H z); trivial.
   Qed.
@@ -176,7 +179,7 @@ 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)].
+     [Inductive Exc [A:Type] : Type := value : A->(Exc A) | error : (Exc A)].
 
      It is implemented using the option type. *) 
 
@@ -199,24 +202,18 @@ Qed.
 
 Hint Resolve left right inleft inright: core v62.
 
-(** Sigma-type for types in [Type] *)
-
-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.
-
+(* Compatibility *)
+
+Notation sigS := sigT (only parsing).
+Notation existS := existT (only parsing).
+Notation sigS_rect := sigT_rect (only parsing).
+Notation sigS_rec := sigT_rec (only parsing).
+Notation sigS_ind := sigT_ind (only parsing).
+Notation projS1 := projT1 (only parsing).
+Notation projS2 := projT2 (only parsing).
+
+Notation sigS2 := sigT2 (only parsing).
+Notation existS2 := existT2 (only parsing).
+Notation sigS2_rect := sigT2_rect (only parsing).
+Notation sigS2_rec := sigT2_rec (only parsing).
+Notation sigS2_ind := sigT2_ind (only parsing).
diff --git a/theories/IntMap/Adalloc.v b/theories/IntMap/Adalloc.v
index 2136bfb5..ca8e7eeb 100644
--- a/theories/IntMap/Adalloc.v
+++ b/theories/IntMap/Adalloc.v
@@ -5,15 +5,15 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Adalloc.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Adalloc.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
-Require Import ZArith.
 Require Import Arith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
+Require Import Nnat.
 Require Import Map.
 Require Import Fset.
 
@@ -21,215 +21,36 @@ 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
+    | M0 => N0
+    | M1 a _ => if Neqb a N0 then Npos 1 else N0
     | M2 m1 m2 =>
-        ad_min (ad_double (ad_alloc_opt m1))
-          (ad_double_plus_un (ad_alloc_opt m2))
+        Nmin (Ndouble (ad_alloc_opt m1))
+          (Ndouble_plus_one (ad_alloc_opt m2))
     end.
 
   Lemma ad_alloc_opt_allocates_1 :
-   forall m:Map A, MapGet A m (ad_alloc_opt m) = NONE A.
+   forall m:Map A, MapGet A m (ad_alloc_opt m) = None.
   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.
+    simpl in |- *. elim (sumbool_of_bool (Neqb a N0)). intro H. rewrite H.
+    rewrite (Neqb_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)))
+   (ad_alloc_opt (M2 A m0 m1)) with (Nmin (Ndouble (ad_alloc_opt m0))
+                                       (Ndouble_plus_one (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.
+     (Nmin_choice (Ndouble (ad_alloc_opt m0))
+        (Ndouble_plus_one (ad_alloc_opt m1))).
+    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_0. rewrite Ndouble_div2. assumption.
+    apply Ndouble_bit0.
+    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_1. rewrite Ndouble_plus_one_div2. assumption.
+    apply Ndouble_plus_one_bit0.
   Qed.
 
   Lemma ad_alloc_opt_allocates :
@@ -241,122 +62,30 @@ Section AdAlloc.
   (** 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}.
+     Nle (ad_alloc_opt m) a = false -> {y : A | MapGet A m a = Some 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.
+    induction m as [| a y| m0 H m1 H0]. simpl in |- *. unfold Nle in |- *. simpl in |- *. intros. discriminate H.
+    simpl in |- *. intros b H. elim (sumbool_of_bool (Neqb a N0)). intro H0. rewrite H0 in H.
+    unfold Nle in H. cut (N0 = b). intro. split with y. rewrite <- H1. rewrite H0. reflexivity.
+    rewrite <- (N_of_nat_of_N b).
+    rewrite <- (le_n_O_eq _ (le_S_n _ _ (leb_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.
+    intros. simpl in H1. elim (Ndouble_or_double_plus_un a). intro H2. elim H2. intros a0 H3.
+    rewrite H3 in H1. elim (H _ (Nlt_double_mono_conv _ _ (Nmin_lt_3 _ _ _ H1))). intros y H4.
+    split with y. rewrite H3. rewrite MapGet_M2_bit_0_0. rewrite Ndouble_div2. assumption.
+    apply Ndouble_bit0.
     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.
+    elim (H0 _ (Nlt_double_plus_one_mono_conv _ _ (Nmin_lt_4 _ _ _ H1))). intros y H4.
+    split with y. rewrite H3. rewrite MapGet_M2_bit_0_1. rewrite Ndouble_plus_one_div2.
     assumption.
-    apply ad_double_plus_un_bit_0.
+    apply Ndouble_plus_one_bit0.
   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.
+     Nle (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.
diff --git a/theories/IntMap/Addec.v b/theories/IntMap/Addec.v
deleted file mode 100644
index f1a937a3..00000000
--- a/theories/IntMap/Addec.v
+++ /dev/null
@@ -1,193 +0,0 @@
-(************************************************************************)
-(*  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 5920 2004-07-16 20:01:26Z herbelin $	 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
deleted file mode 100644
index 727117b3..00000000
--- a/theories/IntMap/Addr.v
+++ /dev/null
@@ -1,491 +0,0 @@
-(************************************************************************)
-(*  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 5920 2004-07-16 20:01:26Z herbelin $	 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/Allmaps.v b/theories/IntMap/Allmaps.v
index f9a0feac..d5af8f80 100644
--- a/theories/IntMap/Allmaps.v
+++ b/theories/IntMap/Allmaps.v
@@ -5,17 +5,12 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Allmaps.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Allmaps.v 8733 2006-04-25 22:52:18Z letouzey $	 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.
diff --git a/theories/IntMap/Fset.v b/theories/IntMap/Fset.v
index 27f739c1..5b46c969 100644
--- a/theories/IntMap/Fset.v
+++ b/theories/IntMap/Fset.v
@@ -5,16 +5,15 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Fset.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Fset.v 8733 2006-04-25 22:52:18Z letouzey $	 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 NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 
 Section Dom.
@@ -26,7 +25,7 @@ Section Dom.
     | M0 => fun _:Map B => M0 A
     | M1 a y =>
         fun m':Map B => match MapGet B m' a with
-                        | NONE => M0 A
+                        | None => M0 A
                         | _ => m
                         end
     | M2 m1 m2 =>
@@ -35,8 +34,8 @@ Section Dom.
           | M0 => M0 A
           | M1 a' y' =>
               match MapGet A m a' with
-              | NONE => M0 A
-              | SOME y => M1 A a' y
+              | 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)
@@ -48,35 +47,35 @@ Section Dom.
      eqm A (MapGet A (MapDomRestrTo m m'))
        (fun a0:ad =>
           match MapGet B m' a0 with
-          | NONE => NONE A
+          | None => None
           | _ => 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.
+    intros. simpl in |- *. elim (sumbool_of_bool (Neqb a a1)). intro H. rewrite H.
+    rewrite <- (Neqb_complete _ _ H). case (MapGet B m' a); try 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).
+    case (MapGet B m' a1); reflexivity.
     simple induction m'. trivial.
-    unfold MapDomRestrTo in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)).
+    unfold MapDomRestrTo in |- *. intros. elim (sumbool_of_bool (Neqb 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.
+    rewrite (Neqb_complete _ _ H1). rewrite (M1_semantics_1 B a1 a0).
+    case (MapGet A (M2 A m0 m1) a1); try 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 H1. rewrite (M1_semantics_2 B a a1 a0 H1). case (MapGet A (M2 A m0 m1) a); try 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
+    | None => None
+    | 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. rewrite (H0 m3 (Ndiv2 a)). rewrite (H m2 (Ndiv2 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.
+    case (Nbit0 a); reflexivity.
   Qed.
 
   Fixpoint MapDomRestrBy (m:Map A) : Map B -> Map A :=
@@ -84,7 +83,7 @@ Section Dom.
     | M0 => fun _:Map B => M0 A
     | M1 a y =>
         fun m':Map B => match MapGet B m' a with
-                        | NONE => m
+                        | None => m
                         | _ => M0 A
                         end
     | M2 m1 m2 =>
@@ -102,37 +101,38 @@ Section Dom.
      eqm A (MapGet A (MapDomRestrBy m m'))
        (fun a0:ad =>
           match MapGet B m' a0 with
-          | NONE => MapGet A m a0
-          | _ => NONE A
+          | None => MapGet A m a0
+          | _ => None
           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).
+    intros. simpl in |- *. elim (sumbool_of_bool (Neqb a a1)). intro H. rewrite H.
+    rewrite (Neqb_complete _ _ H). case (MapGet B m' a1). trivial.
+    apply M1_semantics_1.
+    intro H. rewrite H. case (MapGet B m' a). 
     case (MapGet B m' a1); trivial.
+    rewrite (M1_semantics_2 A a a1 a0 H).
     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).
+    elim (sumbool_of_bool (Neqb a a1)). intro H1. rewrite H1. rewrite (Neqb_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
+    | None => MapGet A (M2 A m0 m1) a
+    | Some _ => None
     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. rewrite (H0 m3 (Ndiv2 a)). rewrite (H m2 (Ndiv2 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.
+    case (Nbit0 a); reflexivity.
   Qed.
 
   Definition in_dom (a:ad) (m:Map A) :=
     match MapGet A m a with
-    | NONE => false
+    | None => false
     | _ => true
     end.
 
@@ -141,32 +141,32 @@ Section Dom.
     trivial.
   Qed.
 
-  Lemma in_dom_M1 : forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = ad_eq a a0.
+  Lemma in_dom_M1 : forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = Neqb a a0.
   Proof.
-    unfold in_dom in |- *. intros. simpl in |- *. case (ad_eq a a0); reflexivity.
+    unfold in_dom in |- *. intros. simpl in |- *. case (Neqb 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.
+    intros. rewrite in_dom_M1. apply Neqb_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.
+    intros. apply (Neqb_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}.
+     in_dom a m = true -> {y : A | MapGet A m a = Some 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.
+   forall (m:Map A) (a:ad), in_dom a m = false -> MapGet A m a = None.
   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.
@@ -175,33 +175,33 @@ Section Dom.
 
   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).
+     in_dom a (MapPut A m a0 y0) = orb (Neqb 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.
+    elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_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.
+    intro H. rewrite H. rewrite (Neqb_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).
+     in_dom a (MapPut_behind A m a0 y0) = orb (Neqb 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.
+    elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_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.
+    intro H. rewrite H. rewrite (Neqb_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).
+     in_dom a (MapRemove A m a0) = andb (negb (Neqb 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.
+    elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H.
     rewrite H. reflexivity.
-    intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. rewrite H.
+    intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H.
     case (MapGet A m a); reflexivity.
   Qed.
 
@@ -272,35 +272,35 @@ Section FSetDefs.
 
   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.
+     MapGet A m a = Some 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.
+    case (Neqb 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.
+    case (Nbit0 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}.
+     in_FSet a (MapDom m) = true -> {y : A | MapGet A m a = Some 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).
+    unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0. case (Neqb 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.
+    case (Nbit0 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.
+     MapGet A m a = None -> 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.
@@ -309,7 +309,7 @@ Section FSetDefs.
 
   Lemma MapDom_semantics_4 :
    forall (m:Map A) (a:ad),
-     in_FSet a (MapDom m) = false -> MapGet A m a = NONE A.
+     in_FSet a (MapDom m) = false -> MapGet A m a = None.
   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.
diff --git a/theories/IntMap/Lsort.v b/theories/IntMap/Lsort.v
index d31d8133..c8d793a1 100644
--- a/theories/IntMap/Lsort.v
+++ b/theories/IntMap/Lsort.v
@@ -5,15 +5,14 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Lsort.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Lsort.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
 Require Import Arith.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import List.
 Require Import Mapiter.
@@ -22,199 +21,19 @@ 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')
+        | (a', y') :: l'' => andb (Nless 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 *)
+    | nil => N0 (* dummy *)
     | (a, y) :: l' => match n with
                       | O => a
                       | S n' => alist_nth_ad n' l'
@@ -224,7 +43,7 @@ Section LSort.
   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.
+      Nless (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.
@@ -235,7 +54,7 @@ Section LSort.
     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))
+   (Nless (alist_nth_ad n0 ((a0, y0) :: l1))
       (alist_nth_ad (S n0) ((a0, y0) :: l1)) = true) 
   in |- *.
     apply H0. exact (proj2 (andb_prop _ _ H1)).
@@ -245,13 +64,13 @@ Section LSort.
   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.
+      S n <= length l -> Nless (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.
+    intros. apply Nless_trans with (a' := alist_nth_ad m0 l). apply H2. apply le_Sn_le.
     assumption.
     apply H. assumption.
   Qed.
@@ -262,7 +81,7 @@ Section LSort.
     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)
+    change (andb (Nless 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.
@@ -319,7 +138,7 @@ Section LSort.
      (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) ->
+        Nless (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.
@@ -348,14 +167,14 @@ Section LSort.
   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}.
+     {y : A | alist_semantics A l (alist_nth_ad n l) = Some 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.
+    rewrite (Neqb_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)).
+    elim (sumbool_of_bool (Neqb a (alist_nth_ad n0 l0))). intro H3. split with y.
+    rewrite (Neqb_complete _ _ H3). simpl in |- *. rewrite (Neqb_correct (alist_nth_ad n0 l0)).
     reflexivity.
     intro H3. split with y0. simpl in |- *. rewrite H3. assumption.
   Qed.
@@ -373,16 +192,16 @@ Section LSort.
   Qed.
 
   Definition ad_monotonic (pf:ad -> ad) :=
-    forall a a':ad, ad_less a a' = true -> ad_less (pf a) (pf a') = true.
+    forall a a':ad, Nless a a' = true -> Nless (pf a) (pf a') = true.
 
-  Lemma ad_double_monotonic : ad_monotonic ad_double.
+  Lemma Ndouble_monotonic : ad_monotonic Ndouble.
   Proof.
-    unfold ad_monotonic in |- *. intros. rewrite ad_less_def_1. assumption.
+    unfold ad_monotonic in |- *. intros. rewrite Nless_def_1. assumption.
   Qed.
 
-  Lemma ad_double_plus_un_monotonic : ad_monotonic ad_double_plus_un.
+  Lemma Ndouble_plus_one_monotonic : ad_monotonic Ndouble_plus_one.
   Proof.
-    unfold ad_monotonic in |- *. intros. rewrite ad_less_def_2. assumption.
+    unfold ad_monotonic in |- *. intros. rewrite Nless_def_2. assumption.
   Qed.
 
   Lemma ad_comp_monotonic :
@@ -395,18 +214,18 @@ Section LSort.
 
   Lemma ad_comp_double_monotonic :
    forall pf:ad -> ad,
-     ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (ad_double a0)).
+     ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (Ndouble a0)).
   Proof.
     intros. apply ad_comp_monotonic. assumption.
-    exact ad_double_monotonic.
+    exact Ndouble_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)).
+     ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (Ndouble_plus_one a0)).
   Proof.
     intros. apply ad_comp_monotonic. assumption.
-    exact ad_double_plus_un_monotonic.
+    exact Ndouble_plus_one_monotonic.
   Qed.
 
   Lemma alist_of_Map_sorts_1 :
@@ -420,22 +239,22 @@ Section LSort.
     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)).
+     (H (fun a0:ad => pf (Ndouble a0)) (ad_comp_double_monotonic pf H1)).
     exact
-     (H0 (fun a0:ad => pf (ad_double_plus_un a0))
+     (H0 (fun a0:ad => pf (Ndouble_plus_one a0))
         (ad_comp_double_plus_un_monotonic pf H1)).
     intros. elim
-  (alist_of_Map_nth_ad m0 (fun a0:ad => pf (ad_double a0))
+  (alist_of_Map_nth_ad m0 (fun a0:ad => pf (Ndouble 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).
+        (fun a0:ad => pf (Ndouble 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))
+  (alist_of_Map_nth_ad m1 (fun a0:ad => pf (Ndouble_plus_one 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) (
+        (fun a0:ad => pf (Ndouble_plus_one a0)) m1) (
      refl_equal _) n' H3).
-    intros a' H5. rewrite H5. unfold ad_monotonic in H1. apply H1. apply ad_less_def_3.
+    intros a' H5. rewrite H5. unfold ad_monotonic in H1. apply H1. apply Nless_def_3.
   Qed.
 
   Lemma alist_of_Map_sorts :
@@ -444,7 +263,7 @@ Section LSort.
     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)).
+        (fun (a a':ad) (p:Nless a a' = true) => p)).
   Qed.
 
   Lemma alist_of_Map_sorts1 :
@@ -458,59 +277,25 @@ Section LSort.
   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 ->
+     Nless a a' = true ->
      alist_sorted_2 ((a', y) :: l) ->
-     alist_semantics A ((a', y) :: l) a = NONE A.
+     alist_semantics A ((a', y) :: l) a = None.
   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.
+    simple induction l. intros. simpl in |- *. elim (sumbool_of_bool (Neqb a' a)). intro H1.
+    rewrite (Neqb_complete _ _ H1) in H. rewrite (Nless_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
+      (match Neqb a1 a0 with
+       | true => Some 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.
+       end = None) in |- *.
+    elim (sumbool_of_bool (Neqb a1 a0)). intro H2. rewrite (Neqb_complete _ _ H2) in H0.
+    rewrite (Nless_not_refl a0) in H0. discriminate H0.
+    intro H2. rewrite H2. apply H. apply Nless_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.
@@ -521,13 +306,13 @@ Section LSort.
 
   Lemma alist_semantics_nth_ad :
    forall (l:alist A) (a:ad) (y:A),
-     alist_semantics A l a = SOME A y ->
+     alist_semantics A l a = Some 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 r. elim r. intros a y l0 H a0 y0 H0. simpl in H0. elim (sumbool_of_bool (Neqb 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).
+    simpl in |- *. exact (Neqb_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).
@@ -538,16 +323,16 @@ Section LSort.
      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).
+          if Neqb a a0 then None 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.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0.
+    rewrite <- (Neqb_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))
+     (Nless (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.
+    intro. simpl in H6. rewrite H5 in H6. rewrite (Nless_not_refl a) in H6. discriminate H6.
     apply H. apply lt_O_Sn.
     simpl in |- *. apply le_n_S. assumption.
     trivial.
@@ -563,7 +348,7 @@ Section LSort.
      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.
+    rewrite (alist_semantics_tail _ _ _ H0 a0). case (Neqb a a0). reflexivity.
     exact (H1 a0).
   Qed.
 
@@ -583,40 +368,40 @@ Section LSort.
     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
+     (None =
+      match Neqb a a with
+      | true => Some y
       | false => alist_semantics A l0 a
       end).
-    rewrite (ad_eq_correct a). intro. discriminate H3.
+    rewrite (Neqb_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
+     (match Neqb a a with
+      | true => Some y
       | false => alist_semantics A l0 a
-      end = NONE A).
-    rewrite (ad_eq_correct a). intro. discriminate H3.
+      end = None).
+    rewrite (Neqb_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.
+    intro r'. elim r'. intros a' y' l'0 H0 H1 H2 H3. elim (Nless_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.
+    rewrite (Neqb_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.
+    rewrite (Neqb_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.
+    intro. simpl in H5. rewrite H4 in H5. rewrite (Neqb_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).
diff --git a/theories/IntMap/Map.v b/theories/IntMap/Map.v
index 5345f81b..2be6de04 100644
--- a/theories/IntMap/Map.v
+++ b/theories/IntMap/Map.v
@@ -5,21 +5,26 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Map.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Map.v 8733 2006-04-25 22:52:18Z letouzey $	 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.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 
+(* The type [ad] of addresses is now [N] in [BinNat]. *)
+
+Definition ad := N. 
+
+(* a Notation or complete replacement would be nice, 
+   but that would changes hyps names *)
 
 Section MapDefs.
 
-(** We define maps from ad to A. *)
+(** We now define maps from ad to A. *)
   Variable A : Set.  
 
   Inductive Map : Set :=
@@ -27,31 +32,28 @@ Section MapDefs.
     | 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}.
+  Lemma option_sum : forall o:option A, {y : A | o = Some y} + {o = None}.
   Proof.
-    simple induction o. right. reflexivity.
+    simple induction o. 
     left. split with a. reflexivity.
+    right. 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 :=
+  Fixpoint MapGet (m:Map) : ad -> option A :=
     match m with
-    | M0 => fun a:ad => NONE
-    | M1 x y => fun a:ad => if ad_eq x a then SOME y else NONE
+    | M0 => fun a:ad => None
+    | M1 x y => fun a:ad => if Neqb 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)
+          | N0 => MapGet m1 N0
+          | Npos xH => MapGet m2 N0
+          | Npos (xO p) => MapGet m1 (Npos p)
+          | Npos (xI p) => MapGet m2 (Npos p)
           end
     end.
 
@@ -59,9 +61,9 @@ Section MapDefs.
 
   Definition MapSingleton := M1.
 
-  Definition eqm (g g':ad -> option) := forall a:ad, g a = g' a.
+  Definition eqm (g g':ad -> option A) := forall a:ad, g a = g' a.
 
-  Lemma newMap_semantics : eqm (MapGet newMap) (fun a:ad => NONE).
+  Lemma newMap_semantics : eqm (MapGet newMap) (fun a:ad => None).
   Proof.
     simpl in |- *. unfold eqm in |- *. trivial.
   Qed.
@@ -69,61 +71,61 @@ Section MapDefs.
   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).
+       (fun a':ad => if Neqb 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.
+  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.
+    unfold MapGet in |- *. intros. rewrite (Neqb_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.
+   forall (a a':ad) (y:A), Neqb 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)).
+     eqm (MapGet m) (fun a:ad => MapGet (M2 m m') (Ndouble 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)).
+   forall (m m':Map) (f:ad -> option A),
+     eqm (MapGet (M2 m m')) f -> eqm (MapGet m) (fun a:ad => f (Ndouble a)).
   Proof.
     unfold eqm in |- *.
     intros.
-    rewrite <- (H (ad_double a)).
+    rewrite <- (H (Ndouble 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)).
+     eqm (MapGet m') (fun a:ad => MapGet (M2 m m') (Ndouble_plus_one a)).
   Proof.
     unfold eqm in |- *. simple induction a; trivial.
   Qed.
 
   Lemma Map2_semantics_2_eq :
-   forall (m m':Map) (f:ad -> option),
+   forall (m m':Map) (f:ad -> option A),
      eqm (MapGet (M2 m m')) f ->
-     eqm (MapGet m') (fun a:ad => f (ad_double_plus_un a)).
+     eqm (MapGet m') (fun a:ad => f (Ndouble_plus_one a)).
   Proof.
     unfold eqm in |- *.
     intros.
-    rewrite <- (H (ad_double_plus_un a)).
+    rewrite <- (H (Ndouble_plus_one 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).
+     Nbit0 a = false ->
+     forall m m':Map, MapGet (M2 m m') a = MapGet m (Ndiv2 a).
   Proof.
     simple induction a; trivial. simple induction p. intros. discriminate H0.
     trivial.
@@ -132,8 +134,8 @@ Section MapDefs.
 
   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).
+     Nbit0 a = true ->
+     forall m m':Map, MapGet (M2 m m') a = MapGet m' (Ndiv2 a).
   Proof.
     simple induction a. intros. discriminate H.
     simple induction p. trivial.
@@ -144,19 +146,19 @@ Section MapDefs.
   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)).
+     (if Nbit0 a then MapGet m' (Ndiv2 a) else MapGet m (Ndiv2 a)).
   Proof.
-    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H. rewrite H.
+    intros. elim (sumbool_of_bool (Nbit0 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).
+     (if Nbit0 a then MapGet (M2 m' m) a else MapGet (M2 m m'') a) =
+     MapGet m (Ndiv2 a).
   Proof.
-    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H. rewrite H.
+    intros. elim (sumbool_of_bool (Nbit0 a)). intro H. rewrite H.
     apply MapGet_M2_bit_0_1; assumption.
     intro H. rewrite H. apply MapGet_M2_bit_0_0; assumption.
   Qed.
@@ -165,9 +167,9 @@ Section MapDefs.
    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)
+          match Nbit0 a with
+          | false => MapGet m (Ndiv2 a)
+          | true => MapGet m' (Ndiv2 a)
           end).
   Proof.
     unfold eqm in |- *.
@@ -176,20 +178,20 @@ Section MapDefs.
   Qed.
 
   Lemma Map2_semantics_3_eq :
-   forall (m m':Map) (f f':ad -> option),
+   forall (m m':Map) (f f':ad -> option A),
      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)
+          match Nbit0 a with
+          | false => f (Ndiv2 a)
+          | true => f' (Ndiv2 a)
           end).
   Proof.
     unfold eqm in |- *.
     intros.
-    rewrite <- (H (ad_div_2 a)).
-    rewrite <- (H0 (ad_div_2 a)).
+    rewrite <- (H (Ndiv2 a)).
+    rewrite <- (H0 (Ndiv2 a)).
     exact (Map2_semantics_3 m m' a).
   Qed.
 
@@ -197,15 +199,15 @@ Section MapDefs.
    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
+        let m := MapPut1 (Ndiv2 a) y (Ndiv2 a') y' p' in
+        match Nbit0 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)
+        match Nbit0 a with
+        | false => M2 (M1 (Ndiv2 a) y) (M1 (Ndiv2 a') y')
+        | true => M2 (M1 (Ndiv2 a') y') (M1 (Ndiv2 a) y)
         end
     end.
 
@@ -218,14 +220,14 @@ Section MapDefs.
 
   (*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)).
+      (a:ad) (MapGet (if (Nbit0 a) then (M2 m m') else (M2 m'' m''')) a)=
+             (MapGet (if (Nbit0 a) then m' else m'') (Ndiv2 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.
+    Intros. Rewrite (MapGet_if_commute (Nbit0 a)). Rewrite (MapGet_if_commute (Nbit0 a)).
+    Cut (Nbit0 a)=false\/(Nbit0 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.
+    Case (Nbit0 a); Auto.
   Qed.
   i*)
 
@@ -237,107 +239,107 @@ Section MapDefs.
 
   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).
+     MapGet (if Nbit0 a then M2 m m' else M2 m' m'') a =
+     MapGet m' (Ndiv2 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.
+     Nxor a a' = Npos 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.
+    intros. simpl in |- *. rewrite MapGet_M2_bit_0_2. apply H. rewrite <- Nxor_div2. 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'.
+     Nxor a a' = Npos 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).
+    simple induction p. intros. unfold MapPut1 in |- *. rewrite (Nneg_bit0_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.
+    intros. simpl in |- *. rewrite (Nsame_bit0 a a' p0 H0). rewrite MapGet_M2_bit_0_2.
+    apply H. rewrite <- Nxor_div2. rewrite H0. reflexivity.
+    intros. unfold MapPut1 in |- *. rewrite (Nneg_bit0_1 a a' H). rewrite if_negb.
     rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
   Qed.
 
-  Lemma MapGet_M2_both_NONE :
+  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.
+     MapGet m (Ndiv2 a) = None ->
+     MapGet m' (Ndiv2 a) = None -> MapGet (M2 m m') a = None.
   Proof.
     intros. rewrite (Map2_semantics_3 m m' a). 
-    case (ad_bit_0 a); assumption.
+    case (Nbit0 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.
+     Nxor a a' = Npos p ->
+     Neqb a a0 = false ->
+     Neqb a' a0 = false -> MapGet (MapPut1 a y a' y' p) a0 = None.
+  Proof.
+    simple induction p. intros. unfold MapPut1 in |- *. elim (Nneq_elim a a0 H1). intro. rewrite H3. rewrite if_negb.
+    rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply Ndiv2_bit_neq. assumption.
+    rewrite (Nneg_bit0_2 a a' p0 H0) in H3. rewrite (negb_intro (Nbit0 a')).
+    rewrite (negb_intro (Nbit0 a0)). rewrite H3. reflexivity.
+    intro. elim (Nneq_elim a' a0 H2). intro. rewrite (Nneg_bit0_2 a a' p0 H0). rewrite H4.
+    rewrite (negb_elim (Nbit0 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;
+    intro; case (Nbit0 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.
+    intros. simpl in |- *. elim (Nneq_elim 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.
+    intro. elim (Nneq_elim a' a0 H2). intro. rewrite (Nsame_bit0 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;
+    intro. cut (Nxor (Ndiv2 a) (Ndiv2 a') = Npos p0). intro.
+    case (Nbit0 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.
+    rewrite <- Nxor_div2. rewrite H0. reflexivity.
+    intros. simpl in |- *. elim (Nneq_elim a a0 H0). intro. rewrite H2. rewrite if_negb.
+    rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply Ndiv2_bit_neq. assumption.
+    rewrite (Nneg_bit0_1 a a' H) in H2. rewrite (negb_intro (Nbit0 a')).
+    rewrite (negb_intro (Nbit0 a0)). rewrite H2. reflexivity.
+    intro. elim (Nneq_elim a' a0 H1). intro. rewrite (Nneg_bit0_1 a a' H). rewrite H3.
+    rewrite (negb_elim (Nbit0 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;
+    intro. case (Nbit0 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 ->
+     Nxor a a' = Npos 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').
+          if Neqb a a0
+          then Some y
+          else if Neqb a' a0 then Some y' else None).
+  Proof.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0.
+    rewrite <- (Neqb_complete _ _ H0). exact (MapPut1_semantics_1 p a a' y y' H).
+    intro H0. rewrite H0. elim (sumbool_of_bool (Neqb a' a0)). intro H1.
+    rewrite <- (Neqb_complete _ _ H1). rewrite (Neqb_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 ->
+     Nxor a a' = Npos 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).
+          if Neqb a' a0
+          then Some y'
+          else if Neqb 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.
+    elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0.
+    rewrite <- (Neqb_complete a a0 H0). rewrite (Neqb_comm a' a).
+    rewrite (Nxor_eq_false a a' p H). reflexivity.
     intro H0. rewrite H0. reflexivity.
   Qed.
 
@@ -346,17 +348,17 @@ Section MapDefs.
     | 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
+          match Nxor a a' with
+          | N0 => M1 a' y'
+          | Npos 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)
+          | N0 => M2 (MapPut m1 N0 y) m2
+          | Npos xH => M2 m1 (MapPut m2 N0 y)
+          | Npos (xO p) => M2 (MapPut m1 (Npos p) y) m2
+          | Npos (xI p) => M2 m1 (MapPut m2 (Npos p) y)
           end
     end.
 
@@ -370,39 +372,39 @@ Section MapDefs.
   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).
+     (if Neqb a a0 then Some y' else None).
   Proof.
-    simpl in |- *. intros. rewrite (ad_xor_nilpotent a). trivial.
+    simpl in |- *. intros. rewrite (Nxor_nilpotent a). trivial.
   Qed.
 
   Lemma MapPut_semantics_2_2 :
    forall (a a':ad) (y y':A) (a0 a'':ad),
-     ad_xor a a' = a'' ->
+     Nxor 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).
+     (if Neqb a' a0 then Some y' else if Neqb 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.
+    simple induction a''. intro. rewrite (Nxor_eq _ _ H). rewrite MapPut_semantics_2_1.
+    case (Neqb 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.
+    elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0. rewrite <- (Neqb_complete _ _ H0).
+    rewrite (Neqb_comm a' a). rewrite (Nxor_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).
+     (if Neqb a' a0 then Some y' else if Neqb a a0 then Some y else None).
   Proof.
-    intros. apply MapPut_semantics_2_2 with (a'' := ad_xor a a'); trivial.
+    intros. apply MapPut_semantics_2_2 with (a'' := Nxor 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').
+     (if Nbit0 a
+      then M2 m (MapPut m' (Ndiv2 a) y)
+      else M2 (MapPut m (Ndiv2 a) y) m').
   Proof.
     simple induction a. trivial.
     simple induction p; trivial.
@@ -411,24 +413,24 @@ Section MapDefs.
   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').
+       (fun a':ad => if Neqb 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).
+    elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if.
+    elim (sumbool_of_bool (Nbit0 a0)). intro H2. rewrite H2.
+    rewrite (H0 (Ndiv2 a) y (Ndiv2 a0)). elim (sumbool_of_bool (Neqb a a0)).
+    intro H3. rewrite H3. rewrite (Ndiv2_eq _ _ H3). reflexivity.
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq _ _ H3 H1). reflexivity.
+    intro H2. rewrite H2. rewrite (Neqb_comm a a0). rewrite (Nbit0_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.
+    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a0)).
+    intro H2. rewrite H2. rewrite (Nbit0_neq a a0 H1 H2). reflexivity.
+    intro H2. rewrite H2. rewrite (H (Ndiv2 a) y (Ndiv2 a0)).
+    elim (sumbool_of_bool (Neqb a a0)). intro H3. rewrite H3.
+    rewrite (Ndiv2_eq a a0 H3). reflexivity.
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq a a0 H3 H1). reflexivity.
   Qed.
 
   Fixpoint MapPut_behind (m:Map) : ad -> A -> Map :=
@@ -436,26 +438,26 @@ Section MapDefs.
     | 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
+          match Nxor a a' with
+          | N0 => m
+          | Npos 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)
+          | N0 => M2 (MapPut_behind m1 N0 y) m2
+          | Npos xH => M2 m1 (MapPut_behind m2 N0 y)
+          | Npos (xO p) => M2 (MapPut_behind m1 (Npos p) y) m2
+          | Npos (xI p) => M2 m1 (MapPut_behind m2 (Npos 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').
+     (if Nbit0 a
+      then M2 m (MapPut_behind m' (Ndiv2 a) y)
+      else M2 (MapPut_behind m (Ndiv2 a) y) m').
   Proof.
     simple induction a. trivial.
     simple induction p; trivial.
@@ -463,52 +465,52 @@ Section MapDefs.
 
   Lemma MapPut_behind_as_before_1 :
    forall a a' a0:ad,
-     ad_eq a' a0 = false ->
+     Neqb 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 a a' a0. simpl in |- *. intros H y y'. elim (Ndiscr (Nxor 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).
+    intro H0. rewrite H0. rewrite (Nxor_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 ->
+     Neqb 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).
+    elim (sumbool_of_bool (Nbit0 a)). intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if.
+    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a0)). intro H3.
+    rewrite H3. apply H0. rewrite <- H3 in H2. exact (Ndiv2_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).
+    elim (sumbool_of_bool (Nbit0 a0)). intro H3. rewrite H3. reflexivity.
+    intro H3. rewrite H3. apply H. rewrite <- H3 in H2. exact (Ndiv2_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
+     | 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).
+    simple induction m. simpl in |- *. intros. rewrite (Neqb_correct a). reflexivity.
+    intros. elim (Ndiscr (Nxor a a1)). intro H. elim H. intros p H0. simpl in |- *.
+    rewrite H0. rewrite (Nxor_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).
+    intro H. simpl in |- *. rewrite H. rewrite <- (Nxor_eq _ _ H). rewrite (Neqb_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).
+    elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_1 a H1).
+    exact (H0 (Ndiv2 a) y).
+    intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_0 a H1). exact (H (Ndiv2 a) y).
   Qed.
 
   Lemma MapPut_behind_semantics :
@@ -516,12 +518,12 @@ Section MapDefs.
      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
+          | Some y' => Some y'
+          | _ => if Neqb 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.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H.
+    rewrite (Neqb_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.
@@ -529,41 +531,41 @@ Section MapDefs.
   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
+    | M0, M1 a y => M1 (Ndouble_plus_one a) y
+    | M1 a y, M0 => M1 (Ndouble 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.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (Nbit0 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 a0 y. simpl in |- *. rewrite (Nodd_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.
+    case m. intros a0 y. simpl in |- *. elim (sumbool_of_bool (Neqb a0 (Ndiv2 a))).
+    intro H0. rewrite H0. rewrite (Neqb_complete _ _ H0). rewrite (Ndiv2_double_plus_one a H).
+    rewrite (Neqb_correct a). reflexivity.
+    intro H0. rewrite H0. rewrite (Neqb_comm a0 (Ndiv2 a)) in H0.
+    rewrite (Nnot_div2_not_double_plus_one 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)). 
+    cut (MapGet (M2 m (M2 m1 m2)) a = MapGet (M2 m1 m2) (Ndiv2 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 a0 y. simpl in |- *. rewrite (Neven_not_double_plus_one 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).
+    case m'. intros a0 y. simpl in |- *. elim (sumbool_of_bool (Neqb a0 (Ndiv2 a))). intro H0.
+    rewrite H0. rewrite (Neqb_complete _ _ H0). rewrite (Ndiv2_double a H).
+    rewrite (Neqb_correct a). reflexivity.
+    intro H0. rewrite H0. rewrite (Neqb_comm (Ndouble a0) a).
+    rewrite (Neqb_comm a0 (Ndiv2 a)) in H0. rewrite (Nnot_div2_not_double a a0 H0).
     reflexivity.
     intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity.
     assumption.
@@ -576,55 +578,55 @@ Section MapDefs.
     match m with
     | M0 => fun _:ad => M0
     | M1 a y =>
-        fun a':ad => match ad_eq a a' with
+        fun a':ad => match Neqb 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
+          if Nbit0 a
+          then makeM2 m1 (MapRemove m2 (Ndiv2 a))
+          else makeM2 (MapRemove m1 (Ndiv2 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.
+       (fun a':ad => if Neqb a a' then None else MapGet m a').
+  Proof.
+    unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (Neqb a a0); trivial.
+    intros. simpl in |- *. elim (sumbool_of_bool (Neqb a1 a2)). intro H. rewrite H.
+    elim (sumbool_of_bool (Neqb a a1)). intro H0. rewrite H0. reflexivity.
+    intro H0. rewrite H0. rewrite (Neqb_complete _ _ H) in H0. exact (M1_semantics_2 a a2 a0 H0).
+    intro H. elim (sumbool_of_bool (Neqb a a1)). intro H0. rewrite H0. rewrite H.
+    rewrite <- (Neqb_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)) 
+      (if Nbit0 a
+       then makeM2 m0 (MapRemove m1 (Ndiv2 a))
+       else makeM2 (MapRemove m0 (Ndiv2 a)) m1) a0 =
+    (if Neqb 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).
+    elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1.
+    rewrite (makeM2_M2 m0 (MapRemove m1 (Ndiv2 a)) a0). elim (sumbool_of_bool (Nbit0 a0)).
+    intro H2. rewrite MapGet_M2_bit_0_1. rewrite (H0 (Ndiv2 a) (Ndiv2 a0)).
+    elim (sumbool_of_bool (Neqb a a0)). intro H3. rewrite H3. rewrite (Ndiv2_eq _ _ H3).
     reflexivity.
-    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq _ _ H3 H1).
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_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).
+    intro H2. rewrite (MapGet_M2_bit_0_0 a0 H2 m0 (MapRemove m1 (Ndiv2 a))).
+    rewrite (Neqb_comm a a0). rewrite (Nbit0_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.
+    intro H1. rewrite H1. rewrite (makeM2_M2 (MapRemove m0 (Ndiv2 a)) m1 a0).
+    elim (sumbool_of_bool (Nbit0 a0)). intro H2. rewrite MapGet_M2_bit_0_1.
+    rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). rewrite (Nbit0_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.
+    intro H2. rewrite MapGet_M2_bit_0_0. rewrite (H (Ndiv2 a) (Ndiv2 a0)).
+    rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). elim (sumbool_of_bool (Neqb a a0)). intro H3.
+    rewrite H3. rewrite (Ndiv2_eq _ _ H3). reflexivity.
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq _ _ H3 H1). reflexivity.
     assumption.
   Qed.
 
@@ -653,21 +655,21 @@ Section MapDefs.
      eqm (MapGet (MapMerge m m'))
        (fun a0:ad =>
           match MapGet m' a0 with
-          | SOME y' => SOME y'
-          | NONE => MapGet m a0
+          | 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).
+    elim (sumbool_of_bool (Neqb a a1)). intro H1. rewrite H1. rewrite (Neqb_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.
+    intro. rewrite H3. rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (Ndiv2 a)).
+    rewrite (H m2 (Ndiv2 a)). rewrite (MapGet_M2_bit_0_if m2 m3 a).
+    rewrite (MapGet_M2_bit_0_if m0 m1 a). case (Nbit0 a); trivial.
     reflexivity.
   Qed.
 
@@ -680,7 +682,7 @@ Section MapDefs.
     | M1 a y =>
         fun m':Map =>
           match MapGet m' a with
-          | NONE => MapPut m' a y
+          | None => MapPut m' a y
           | _ => MapRemove m' a
           end
     | M2 m1 m2 =>
@@ -689,7 +691,7 @@ Section MapDefs.
           | M0 => m
           | M1 a' y' =>
               match MapGet m a' with
-              | NONE => MapPut m a' y'
+              | None => MapPut m a' y'
               | _ => MapRemove m a'
               end
           | M2 m'1 m'2 => makeM2 (MapDelta m1 m'1) (MapDelta m2 m'2)
@@ -701,17 +703,17 @@ Section MapDefs.
   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.
+    unfold MapDelta in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). intro H.
+    rewrite <- (Neqb_complete _ _ H). rewrite (M1_semantics_1 a a2).
+    rewrite (M1_semantics_1 a a0). simpl in |- *. rewrite (Neqb_correct a). reflexivity.
+    intro H. rewrite (M1_semantics_2 a a1 a0 H). rewrite (Neqb_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.
+    rewrite (MapPut_semantics (M1 a1 a2) a a0 a3). elim (sumbool_of_bool (Neqb a a3)).
+    intro H0. rewrite H0. rewrite (Neqb_complete _ _ H0) in H. rewrite H.
+    rewrite (Neqb_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).
+    elim (sumbool_of_bool (Neqb a1 a3)). intro H1. rewrite H1.
+    rewrite (Neqb_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.
@@ -720,24 +722,25 @@ Section MapDefs.
     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.
+    rewrite (H0 m3 (Ndiv2 a)). rewrite (H m2 (Ndiv2 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.
+     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.
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a a0)). intro H1.
+    rewrite (Neqb_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H.
+    intro H1. case (MapGet m' a).  
     rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial.
+    rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption.
   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.
+     MapGet m a = None ->
+     MapGet m' a = None -> MapGet (MapDelta m m') a = None.
   Proof.
     simple induction m. trivial.
     exact MapDelta_semantics_1_1.
@@ -745,7 +748,7 @@ Section MapDefs.
     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.
+    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 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.
@@ -754,31 +757,32 @@ Section MapDefs.
 
   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.
+     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.
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a a0)). intro H1.
+    rewrite (Neqb_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H.
+    intro H1. case (MapGet m' a).
     rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial.
+    rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption.
   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.
+     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).
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a a0)). intro H1.
+    rewrite (Neqb_complete _ _ H1) in H. rewrite (Neqb_complete _ _ H1).
+    rewrite H0. rewrite (MapPut_semantics m' a0 y a0). rewrite (Neqb_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.
+     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.
@@ -786,7 +790,7 @@ Section MapDefs.
     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.
+    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 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.
@@ -795,19 +799,19 @@ Section MapDefs.
 
   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.
+     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.
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a0 a)). intro H1.
+    rewrite (Neqb_complete a0 a H1). rewrite H0. rewrite (MapRemove_semantics m' a a).
+    rewrite (Neqb_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.
+     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.
@@ -815,10 +819,10 @@ Section MapDefs.
     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_if. elim (sumbool_of_bool (Nbit0 a)). intro H5. rewrite H5.
+    apply (H0 m3 (Ndiv2 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').
+    intro H5. rewrite H5. apply (H m2 (Ndiv2 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.
@@ -828,9 +832,9 @@ Section MapDefs.
      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
+          | 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.
diff --git a/theories/IntMap/Mapaxioms.v b/theories/IntMap/Mapaxioms.v
index b6a2b134..0722bcfa 100644
--- a/theories/IntMap/Mapaxioms.v
+++ b/theories/IntMap/Mapaxioms.v
@@ -5,14 +5,13 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapaxioms.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Mapaxioms.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Fset.
 
@@ -59,8 +58,8 @@ Section MapAxioms.
      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.
+    rewrite (MapMerge_semantics A m (M1 A a y) a0). unfold MapGet at 2.
+    elim (sumbool_of_bool (Neqb a a0)); intro H; rewrite H; reflexivity.
   Qed.
 
   Lemma MapPut_ext :
@@ -70,7 +69,7 @@ Section MapAxioms.
   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 ].
+    case (Neqb a a0); [ reflexivity | apply H ].
   Qed.
 
   Lemma MapPut_behind_as_Merge :
@@ -115,7 +114,7 @@ Section MapAxioms.
    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.
+    rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a); trivial.
     intros. discriminate H0.
     exact (H a).
   Qed.
@@ -124,8 +123,7 @@ Section MapAxioms.
    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.
+    rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a); trivial.
     exact (H a).
   Qed.
 
@@ -190,8 +188,8 @@ Section MapAxioms.
      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).
+    rewrite (MapDomRestrBy_semantics A B m (M1 B a y) a0). elim (sumbool_of_bool (Neqb a a0)).
+    intro H. rewrite H. rewrite (Neqb_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.
@@ -202,7 +200,7 @@ Section MapAxioms.
   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 ].
+    case (Neqb a a0); [ reflexivity | apply H ].
   Qed.
 
   Lemma MapDomRestrTo_empty_m_1 :
@@ -259,7 +257,7 @@ Section MapAxioms.
     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.
+    generalize H. case (MapGet unit (MapDom B m') a); trivial.
     intros H0 H1. discriminate H1.
   Qed.
 
@@ -298,7 +296,7 @@ Section MapAxioms.
     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.
+    generalize H. case (MapGet unit (MapDom B m') a); trivial.
     intros H0 H1. discriminate H1.
   Qed.
 
diff --git a/theories/IntMap/Mapc.v b/theories/IntMap/Mapc.v
index d7a779ff..163373bf 100644
--- a/theories/IntMap/Mapc.v
+++ b/theories/IntMap/Mapc.v
@@ -5,15 +5,12 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapc.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Mapc.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
 Require Import Arith.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
 Require Import Map.
 Require Import Mapaxioms.
 Require Import Fset.
diff --git a/theories/IntMap/Mapcanon.v b/theories/IntMap/Mapcanon.v
index 23e0669e..33741b98 100644
--- a/theories/IntMap/Mapcanon.v
+++ b/theories/IntMap/Mapcanon.v
@@ -5,15 +5,14 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapcanon.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Mapcanon.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
 Require Import Arith.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Mapaxioms.
 Require Import Mapiter.
@@ -57,37 +56,37 @@ Section MapCanon.
    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)).
+    unfold eqmap, eqm in |- *. intros. rewrite <- (Ndouble_div2 a).
+    rewrite <- (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m0 m1).
+    rewrite <- (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m2 m3).
+    exact (H (Ndouble 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)).
+    unfold eqmap, eqm in |- *. intros. rewrite <- (Ndouble_plus_one_div2 a).
+    rewrite <- (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m0 m1).
+    rewrite <- (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m2 m3).
+    exact (H (Ndouble_plus_one 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).
+    intros a y H H0 H1. cut (None = MapGet A (M1 A a y) a). simpl in |- *. rewrite (Neqb_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.
+    intros a y. simple induction m'. intros. cut (MapGet A (M1 A a y) a = None). simpl in |- *.
+    rewrite (Neqb_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.
+    rewrite (Neqb_correct a). intro. elim (sumbool_of_bool (Neqb a0 a)). intro H3.
+    rewrite H3 in H2. inversion H2. rewrite (Neqb_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)).
@@ -109,19 +108,19 @@ Section MapCanon.
   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.
+    simple induction p. simpl in |- *. intros. case (Nbit0 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.
+    simpl in |- *. intros. case (Nbit0 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.
+    simpl in |- *. simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M1_canon.
     apply M1_canon.
     simpl in |- *. apply le_n.
     apply M2_canon. apply M1_canon.
@@ -134,28 +133,28 @@ Section MapCanon.
      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.
+    intros a0 y0 H a y. simpl in |- *. case (Nxor 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 plus_le_compat. exact (MapCard_Put_lb A m0 N0 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).
+    apply plus_le_compat_l. exact (MapCard_Put_lb A m1 (Npos 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 plus_le_compat_r. exact (MapCard_Put_lb A m0 (Npos 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).
+    apply plus_le_compat_l. exact (MapCard_Put_lb A m1 N0 y).
   Qed.
 
   Lemma MapPut_behind_canon :
@@ -163,37 +162,37 @@ Section MapCanon.
      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.
+    intros a0 y0 H a y. simpl in |- *. case (Nxor 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 plus_le_compat. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 N0 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).
+    apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 (Npos 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 plus_le_compat_r. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 (Npos 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).
+    apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 N0 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 a y H H0. exact (M1_canon (Ndouble_plus_one 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 a y m'. case m'. intros. exact (M1_canon (Ndouble 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).
@@ -216,7 +215,7 @@ Section MapCanon.
     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.
+    rewrite <- (H (Ndiv2 a)). rewrite <- (H0 (Ndiv2 a)). reflexivity.
   Qed.
 
   Lemma mapcanon_exists_2 : forall m:Map A, mapcanon (MapCanonicalize m).
@@ -237,9 +236,9 @@ Section MapCanon.
    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.
+    intros a y H a0. simpl in |- *. case (Neqb a a0). exact M0_canon.
     assumption.
-    intros. simpl in |- *. case (ad_bit_0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1).
+    intros. simpl in |- *. case (Nbit0 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).
@@ -265,12 +264,13 @@ Section MapCanon.
    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).
+    simpl in |- *. intros a y m' H H0. case (MapGet A m' a).
     intro. exact (MapRemove_canon m' H0 a).
+    exact (MapPut_canon m' H0 a y).
     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).
+    unfold MapDelta in |- *. intros a y H1 H2. case (MapGet A (M2 A m0 m1) a). 
     intro. exact (MapRemove_canon _ H1 a).
+    exact (MapPut_canon _ H1 a y).
     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).
@@ -284,11 +284,13 @@ Section MapCanon.
      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.
+    simpl in |- *. intros a y H m'. case (MapGet B m' a). 
     intro. apply M1_canon.
+    exact M0_canon.
     simple induction m'. exact M0_canon.
-    unfold MapDomRestrTo in |- *. intros a y. case (MapGet A (M2 A m0 m1) a). exact M0_canon.
+    unfold MapDomRestrTo in |- *. intros a y. case (MapGet A (M2 A m0 m1) a). 
     intro. apply M1_canon.
+    exact M0_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.
@@ -298,10 +300,10 @@ Section MapCanon.
      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.
+    simpl in |- *. intros a y H m'. case (MapGet B m' a); try 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).
+    intros a y. simpl in |- *. case (Nbit0 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).
diff --git a/theories/IntMap/Mapcard.v b/theories/IntMap/Mapcard.v
index 35efac47..36be9bf9 100644
--- a/theories/IntMap/Mapcard.v
+++ b/theories/IntMap/Mapcard.v
@@ -5,15 +5,14 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapcard.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Mapcard.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
 Require Import Arith.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Mapaxioms.
 Require Import Mapiter.
@@ -38,80 +37,80 @@ Section MapCard.
   Qed.
 
   Lemma MapCard_is_O :
-   forall m:Map A, MapCard A m = 0 -> forall a:ad, MapGet A m a = NONE A.
+   forall m:Map A, MapCard A m = 0 -> forall a:ad, MapGet A m a = None.
   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.
+    case (Nbit0 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}.
+     MapGet A m a = Some 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.
+    intros a y a0 y0 H. simpl in H. elim (sumbool_of_bool (Neqb 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.
+    intros. elim (sumbool_of_bool (Nbit0 a)). intro H2.
+    rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. elim (H0 (Ndiv2 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).
+    intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. elim (H (Ndiv2 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}}.
+     MapCard A m = 1 -> {a : ad &  {y : A | MapGet A m a = Some 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.
+    intro H2. elim H2. intros. elim (H0 H4). intros a H5. split with (Ndouble_plus_one a).
+    rewrite (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m0 m1).
+    rewrite Ndouble_plus_one_div2. exact H5.
+    intro H2. elim H2. intros. elim (H H3). intros a H5. split with (Ndouble a).
+    rewrite (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m0 m1).
+    rewrite Ndouble_div2. 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'.
+       MapGet A m a = Some y ->
+       MapGet A m a' = Some 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).
+    intros. elim (sumbool_of_bool (Neqb a a1)). intro H2. rewrite (Neqb_complete _ _ H2) in H0.
+    rewrite (M1_semantics_1 A a1 a0) in H0. inversion H0. elim (sumbool_of_bool (Neqb a a')).
+    intro H5. rewrite (Neqb_complete _ _ H5) in H1. rewrite (M1_semantics_1 A a' a0) in H1.
+    inversion H1. rewrite <- (Neqb_complete _ _ H2). rewrite <- (Neqb_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)).
+    rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2. elim (sumbool_of_bool (Nbit0 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.
+    elim (sumbool_of_bool (Nbit0 a')). intro H8. rewrite H8 in H3. elim (H0 H6 _ _ _ _ H2 H3).
+    intros. split. rewrite <- (Ndiv2_double_plus_one a H7).
+    rewrite <- (Ndiv2_double_plus_one a' H8). rewrite H9. reflexivity.
     assumption.
-    intro H8. rewrite H8 in H3. rewrite (MapCard_is_O m0 H5 (ad_div_2 a')) in H3.
+    intro H8. rewrite H8 in H3. rewrite (MapCard_is_O m0 H5 (Ndiv2 a')) in H3.
     discriminate H3.
-    intro H7. rewrite H7 in H2. rewrite (MapCard_is_O m0 H5 (ad_div_2 a)) in H2.
+    intro H7. rewrite H7 in H2. rewrite (MapCard_is_O m0 H5 (Ndiv2 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.
+    elim (sumbool_of_bool (Nbit0 a)). intro H7. rewrite H7 in H2.
+    rewrite (MapCard_is_O m1 H6 (Ndiv2 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.
+    elim (sumbool_of_bool (Nbit0 a')). intro H8. rewrite H8 in H3.
+    rewrite (MapCard_is_O m1 H6 (Ndiv2 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 <- (Ndiv2_double a H7). rewrite <- (Ndiv2_double a' H8).
     rewrite H9. reflexivity.
     assumption.
   Qed.
@@ -139,8 +138,8 @@ Section MapCard.
   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.
+    intros. simpl in |- *. rewrite <- (H (fun a0:ad => pf (Ndouble a0))).
+    rewrite <- (H0 (fun a0:ad => pf (Ndouble_plus_one a0))). reflexivity.
   Qed.
 
   Lemma MapCard_as_Fold :
@@ -164,10 +163,10 @@ Section MapCard.
    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.
+    simple induction p. intros. simpl in |- *. case (Nbit0 a); reflexivity.
+    intros. simpl in |- *. case (Nbit0 a). exact (H (Ndiv2 a) (Ndiv2 a') y y').
+    simpl in |- *. rewrite <- plus_n_O. exact (H (Ndiv2 a) (Ndiv2 a') y y').
+    intros. simpl in |- *. case (Nbit0 a); reflexivity.
   Qed.
 
   Lemma MapCard_Put_sum :
@@ -177,17 +176,17 @@ Section MapCard.
   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.
+    intros a y m' a0 y0 n n' H H0 H1. simpl in H. elim (Ndiscr (Nxor 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 (sumbool_of_bool (Nbit0 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)) (
+     (H0 (MapPut A m1 (Ndiv2 a) y) (Ndiv2 a) y (
+        MapCard A m1) (MapCard A (MapPut A m1 (Ndiv2 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.
@@ -196,8 +195,8 @@ Section MapCard.
     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)) (
+     (H (MapPut A m0 (Ndiv2 a) y) (Ndiv2 a) y (
+        MapCard A m0) (MapCard A (MapPut A m0 (Ndiv2 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.
@@ -233,35 +232,35 @@ Section MapCard.
   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}.
+     {y : A | MapGet A m a = Some 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 a y a0 y0 H. simpl in H. elim (Ndiscr (Nxor 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)).
+    intro H0. rewrite H0 in H. rewrite (Nxor_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 (Nbit0 a)).
+    intro H2. rewrite H2 in H1. simpl in H1. elim (H0 (Ndiv2 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))
+     (plus_comm (MapCard A (MapPut A m0 (Ndiv2 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.
+    elim (H (Ndiv2 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.
+     MapCard A (MapPut A m a y) = S (MapCard A m) -> MapGet A m a = None.
   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.
+    intros. simpl in H. elim (sumbool_of_bool (Neqb a a1)). intro H0.
+    rewrite (Neqb_complete _ _ H0) in H. rewrite (Nxor_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).
+    intros. elim (sumbool_of_bool (Nbit0 a)). intro H2.
+    rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply (H0 (Ndiv2 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.
@@ -269,11 +268,11 @@ Section MapCard.
     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).
+    intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply (H (Ndiv2 a) y).
     cut
-     (MapCard A (MapPut A m0 (ad_div_2 a) y) + MapCard A m1 =
+     (MapCard A (MapPut A m0 (Ndiv2 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))
+    intro. rewrite (plus_comm (MapCard A (MapPut A m0 (Ndiv2 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.
@@ -284,7 +283,7 @@ Section MapCard.
 
   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.
+     MapGet A m a = Some y -> MapCard A (MapPut A m a y') = MapCard A m.
   Proof.
     intros.
     elim
@@ -297,7 +296,7 @@ Section MapCard.
 
   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).
+     MapGet A m a = None -> MapCard A (MapPut A m a y) = S (MapCard A m).
   Proof.
     intros.
     elim
@@ -331,10 +330,10 @@ Section MapCard.
      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 a y a0 y0. simpl in |- *. elim (Ndiscr (Nxor 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 H. rewrite H. rewrite (Nxor_eq _ _ H). reflexivity.
+    intros. simpl in |- *. elim (Ndiscr 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.
@@ -370,27 +369,27 @@ Section MapCard.
      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.
+    simpl in |- *. intros. elim (sumbool_of_bool (Neqb 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.
+    intros. simpl in H1. simpl in H2. elim (sumbool_of_bool (Nbit0 a)). intro H4.
     rewrite H4 in H1. rewrite H1 in H3.
-    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H3.
+    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (Ndiv2 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)))
+     (H0 (MapRemove A m1 (Ndiv2 a)) (Ndiv2 a) (
+        MapCard A m1) (MapCard A (MapRemove A m1 (Ndiv2 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))))
+     (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (Ndiv2 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.
+    rewrite (MapCard_makeM2 (MapRemove A m0 (Ndiv2 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)))
+     (H (MapRemove A m0 (Ndiv2 a)) (Ndiv2 a) (
+        MapCard A m0) (MapCard A (MapRemove A m0 (Ndiv2 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.
@@ -422,20 +421,20 @@ Section MapCard.
 
   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.
+     MapCard A (MapRemove A m a) = MapCard A m -> MapGet A m a = None.
   Proof.
     simple induction m. trivial.
-    simpl in |- *. intros a y a0 H. elim (sumbool_of_bool (ad_eq a a0)). intro H0.
+    simpl in |- *. intros a y a0 H. elim (sumbool_of_bool (Neqb 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.
+    intros. simpl in H1. elim (sumbool_of_bool (Nbit0 a)). intro H2. rewrite H2 in H1.
+    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (Ndiv2 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 (MapCard_makeM2 (MapRemove A m0 (Ndiv2 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))
+     (plus_comm (MapCard A (MapRemove A m0 (Ndiv2 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.
@@ -443,36 +442,36 @@ Section MapCard.
   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}.
+     {y : A | MapGet A m a = Some 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).
+    intros a y a0 H. simpl in H. elim (sumbool_of_bool (Neqb a a0)). intro H0.
+    rewrite (Neqb_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.
+    intros. simpl in H1. elim (sumbool_of_bool (Nbit0 a)). intro H2. rewrite H2 in H1.
+    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (Ndiv2 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)) =
+      (S (MapCard A m0) + MapCard A (MapRemove A m1 (Ndiv2 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))))
+     (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (Ndiv2 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.
+    rewrite (MapCard_makeM2 (MapRemove A m0 (Ndiv2 a)) m1) in H1.
     change
-      (S (MapCard A (MapRemove A m0 (ad_div_2 a))) + MapCard A m1 =
+      (S (MapCard A (MapRemove A m0 (Ndiv2 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))
+     (plus_comm (S (MapCard A (MapRemove A m0 (Ndiv2 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.
+     MapGet A m a = None -> MapCard A (MapRemove A m a) = MapCard A m.
   Proof.
     intros.
     elim
@@ -486,7 +485,7 @@ Section MapCard.
 
   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.
+     MapGet A m a = Some y -> S (MapCard A (MapRemove A m a)) = MapCard A m.
   Proof.
     intros.
     elim
@@ -577,20 +576,20 @@ Section MapCard.
   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.
+    simpl in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). intro H2.
+    rewrite (Neqb_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.
+    unfold MapGet at 2 in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H4.
+    rewrite <- (Neqb_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.
+    intros. unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (Nbit0 a)). intro H6.
+    unfold MapDisjoint in H0. apply H0 with (m' := m3) (a := Ndiv2 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).
@@ -606,7 +605,7 @@ Section MapCard.
     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.
+    intro H6. unfold MapDisjoint in H. apply H with (m' := m2) (a := Ndiv2 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).
@@ -637,15 +636,15 @@ Section MapCard.
     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.
+    elim (H _ (sym_eq H3)). intros a H4. split with (Ndouble a). unfold in_dom in |- *.
+    rewrite (MapGet_M2_bit_0_0 A (Ndouble a) (Ndouble_bit0 a) m0 m1).
+    rewrite (Ndouble_div2 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 |- *.
+    split with (Ndouble_plus_one a). unfold in_dom in |- *.
     rewrite
-     (MapGet_M2_bit_0_1 A (ad_double_plus_un a) (ad_double_plus_un_bit_0 a)
+     (MapGet_M2_bit_0_1 A (Ndouble_plus_one a) (Ndouble_plus_one_bit0 a)
         m0 m1).
-    rewrite (ad_double_plus_un_div_2 a). elim (in_dom_some _ _ _ H3). intros y H4. rewrite H4.
+    rewrite (Ndouble_plus_one_div2 a). elim (in_dom_some _ _ _ H3). intros y H4. rewrite H4.
     reflexivity.
   Qed.
 
@@ -675,11 +674,11 @@ Section MapCard2.
     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).
+    elim (sumbool_of_bool (Neqb a a0)). intro H7. rewrite H7. rewrite <- (Neqb_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).
+    elim (sumbool_of_bool (Neqb a a0)). intro H7. rewrite H7. rewrite <- (Neqb_complete _ _ H7).
     apply sym_eq. assumption.
     intro H7. rewrite H7. rewrite (MapRemove_semantics A m a a0). rewrite H7. reflexivity.
   Qed.
@@ -695,8 +694,9 @@ Section MapCard2.
     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.
+    intros a y. unfold MapDomRestrTo in |- *. case (MapGet A (M2 A m0 m1) a). simpl in |- *. 
     intro. simpl in |- *. apply le_n.
+    apply le_O_n.
     intros. simpl in |- *. rewrite
   (MapCard_makeM2 A (MapDomRestrTo A B m0 m2) (MapDomRestrTo A B m1 m3))
   .
diff --git a/theories/IntMap/Mapfold.v b/theories/IntMap/Mapfold.v
index 335a1384..eb58cb64 100644
--- a/theories/IntMap/Mapfold.v
+++ b/theories/IntMap/Mapfold.v
@@ -5,14 +5,13 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i   	  $Id: Mapfold.v 5920 2004-07-16 20:01:26Z herbelin $      i*)
+(*i   	  $Id: Mapfold.v 8733 2006-04-25 22:52:18Z letouzey $      i*)
 
 Require Import Bool.
 Require Import Sumbool.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Fset.
 Require Import Mapaxioms.
@@ -50,22 +49,22 @@ Section MapFoldResults.
 
   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) ->
+     (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.
+    simpl in |- *. intros. apply H. rewrite (Neqb_correct a). reflexivity.
+    intros. simpl in |- *. rewrite (H f g (fun a0:ad => pf (Ndouble a0))).
+    rewrite (H0 f g (fun a0:ad => pf (Ndouble_plus_one a0))). reflexivity.
+    intros. apply H1. rewrite MapGet_M2_bit_0_1. rewrite Ndouble_plus_one_div2. assumption.
+    apply Ndouble_plus_one_bit0.
+    intros. apply H1. rewrite MapGet_M2_bit_0_0. rewrite Ndouble_div2. assumption.
+    apply Ndouble_bit0.
   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) ->
+     (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).
@@ -80,11 +79,11 @@ Section MapFoldResults.
     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))).
+     (H f f' (fun a0:ad => pf (Ndouble a0))
+        (fun a0:ad => pf' (Ndouble a0))).
     rewrite
-     (H0 f f' (fun a0:ad => pf (ad_double_plus_un a0))
-        (fun a0:ad => pf' (ad_double_plus_un a0))).
+     (H0 f f' (fun a0:ad => pf (Ndouble_plus_one a0))
+        (fun a0:ad => pf' (Ndouble_plus_one a0))).
     reflexivity.
     intros. apply H1.
     intros. apply H1.
@@ -112,81 +111,83 @@ Section MapFoldResults.
   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 ->
+     Nxor a1 a2 = Npos 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).
+    simple induction p. intros. simpl in |- *. elim (sumbool_of_bool (Nbit0 a1)). intro H1. rewrite H1.
+    simpl in |- *. rewrite Ndiv2_double_plus_one. rewrite Ndiv2_double. apply comm.
+    change (Nbit0 a2 = negb true) in |- *. rewrite <- H1. rewrite (Nneg_bit0_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.
+    intro H1. rewrite H1. simpl in |- *. rewrite Ndiv2_double. rewrite Ndiv2_double_plus_one.
     reflexivity.
-    change (ad_bit_0 a2 = negb false) in |- *. rewrite <- H1. rewrite (ad_neg_bit_0_2 _ _ _ H0).
+    change (Nbit0 a2 = negb false) in |- *. rewrite <- H1. rewrite (Nneg_bit0_2 _ _ _ H0).
     rewrite negb_elim. reflexivity.
     assumption.
-    simpl in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a1)). intro H1. rewrite H1. simpl in |- *.
+    simpl in |- *. intros. elim (sumbool_of_bool (Nbit0 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.
+     (H f (fun a0:ad => pf (Ndouble_plus_one a0)) (
+        Ndiv2 a1) (Ndiv2 a2) y1 y2).
+    rewrite Ndiv2_double_plus_one. rewrite Ndiv2_double_plus_one. reflexivity.
+    unfold Nodd.
+    rewrite <- (Nsame_bit0 _ _ _ H0). assumption.
     assumption.
-    rewrite <- ad_xor_div_2. rewrite H0. reflexivity.
+    rewrite <- Nxor_div2. 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)
+     (H f (fun a0:ad => pf (Ndouble a0)) (Ndiv2 a1) (Ndiv2 a2) y1 y2)
      .
-    rewrite ad_div_2_double. rewrite ad_div_2_double. reflexivity.
-    rewrite <- (ad_same_bit_0 _ _ _ H0). assumption.
+    rewrite Ndiv2_double. rewrite Ndiv2_double. reflexivity.
+    unfold Neven.
+    rewrite <- (Nsame_bit0 _ _ _ 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.
+    rewrite <- Nxor_div2. rewrite H0. reflexivity.
+    intros. simpl in |- *. elim (sumbool_of_bool (Nbit0 a1)). intro H0. rewrite H0. simpl in |- *.
+    rewrite Ndiv2_double. rewrite Ndiv2_double_plus_one. apply comm.
     assumption.
-    change (ad_bit_0 a2 = negb true) in |- *. rewrite <- H0. rewrite (ad_neg_bit_0_1 _ _ H).
+    change (Nbit0 a2 = negb true) in |- *. rewrite <- H0. rewrite (Nneg_bit0_1 _ _ H).
     rewrite negb_elim. reflexivity.
-    intro H0. rewrite H0. simpl in |- *. rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un.
+    intro H0. rewrite H0. simpl in |- *. rewrite Ndiv2_double. rewrite Ndiv2_double_plus_one.
     reflexivity.
-    change (ad_bit_0 a2 = negb false) in |- *. rewrite <- H0. rewrite (ad_neg_bit_0_1 _ _ H).
+    change (Nbit0 a2 = negb false) in |- *. rewrite <- H0. rewrite (Nneg_bit0_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 ->
+     MapGet A m a = None ->
      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 a1 y1 a2 y2 pf H. simpl in |- *. elim (Ndiscr (Nxor 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.
+    intro H0. rewrite (Neqb_complete _ _ (Nxor_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.
+    intros. elim (sumbool_of_bool (Nbit0 a)). intro H2.
+    cut (MapPut A (M2 A m0 m1) a y = M2 A m0 (MapPut A m1 (Ndiv2 a) y)). intro.
+    rewrite H3. simpl in |- *. rewrite (H0 (Ndiv2 a) y (fun a0:ad => pf (Ndouble_plus_one a0))).
+    rewrite Ndiv2_double_plus_one. rewrite <- assoc.
     rewrite
-     (comm (MapFold1 A M neutral op f (fun a0:ad => pf (ad_double a0)) m0)
+     (comm (MapFold1 A M neutral op f (fun a0:ad => pf (Ndouble 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.
+    simpl in |- *. elim (Ndiscr 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.
+    intro H2. cut (MapPut A (M2 A m0 m1) a y = M2 A (MapPut A m0 (Ndiv2 a) y) m1).
+    intro. rewrite H3. simpl in |- *. rewrite (H (Ndiv2 a) y (fun a0:ad => pf (Ndouble a0))).
+    rewrite Ndiv2_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.
+    simpl in |- *. elim (Ndiscr 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.
@@ -195,7 +196,7 @@ Section MapFoldResults.
 
   Lemma MapFold_Put_disjoint :
    forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A),
-     MapGet A m a = NONE A ->
+     MapGet A m a = None ->
      MapFold A M neutral op f (MapPut A m a y) =
      op (f a y) (MapFold A M neutral op f m).
   Proof.
@@ -204,7 +205,7 @@ Section MapFoldResults.
 
   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 ->
+     MapGet A m a = None ->
      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.
@@ -213,12 +214,12 @@ Section MapFoldResults.
     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.
+    unfold MapDisjoint in |- *. unfold in_dom in |- *. simpl in |- *. intros. elim (sumbool_of_bool (Neqb a a0)).
+    intro H2. rewrite (Neqb_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.
+    elim (sumbool_of_bool (Neqb a a0)). intro H2. rewrite (Neqb_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.
@@ -226,7 +227,7 @@ Section MapFoldResults.
 
   Lemma MapFold_Put_behind_disjoint :
    forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A),
-     MapGet A m a = NONE A ->
+     MapGet A m a = None ->
      MapFold A M neutral op f (MapPut_behind A m a y) =
      op (f a y) (MapFold A M neutral op f m).
   Proof.
@@ -245,8 +246,8 @@ Section MapFoldResults.
     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))).
+    intros. simpl in |- *. rewrite (H m3 (fun a0:ad => pf (Ndouble a0))).
+    rewrite (H0 m4 (fun a0:ad => pf (Ndouble_plus_one 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.
@@ -346,22 +347,22 @@ Section MapFoldExists.
    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
+     | 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.
+    intros. simpl in |- *. rewrite (H (fun a0:ad => pf (Ndouble a0))).
+    rewrite (H0 (fun a0:ad => pf (Ndouble_plus_one a0))).
+    case (MapSweep1 A f (fun a0:ad => pf (Ndouble 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
+     | Some _ => true
      | _ => false
      end.
   Proof.
@@ -381,7 +382,7 @@ Section DMergeDef.
    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
+     | Some _ => true
      | _ => false
      end.
   Proof.
@@ -397,7 +398,7 @@ Section DMergeDef.
    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}}.
+     {m0 : Map A | MapGet _ m b = Some m0 /\ in_dom A a m0 = true}}.
   Proof.
     intros m a. rewrite in_dom_DMerge_1.
     elim
@@ -411,7 +412,7 @@ Section DMergeDef.
 
   Lemma in_dom_DMerge_3 :
    forall (m:Map (Map A)) (a b:ad) (m0:Map A),
-     MapGet _ m a = SOME _ m0 ->
+     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.
diff --git a/theories/IntMap/Mapiter.v b/theories/IntMap/Mapiter.v
index 31e98c49..a8ba7e39 100644
--- a/theories/IntMap/Mapiter.v
+++ b/theories/IntMap/Mapiter.v
@@ -5,14 +5,13 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapiter.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Mapiter.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Mapaxioms.
 Require Import Fset.
@@ -27,17 +26,17 @@ Section MapIter.
   Variable f : ad -> A -> bool.
 
   Definition MapSweep2 (a0:ad) (y:A) :=
-    if f a0 y then SOME _ (a0, y) else NONE _.
+    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 _
+    | 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'
+        match MapSweep1 (fun a:ad => pf (Ndouble a)) m with
+        | Some r => Some r
+        | None => MapSweep1 (fun a:ad => pf (Ndouble_plus_one a)) m'
         end
     end.
 
@@ -45,27 +44,27 @@ Section MapIter.
 
   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.
+     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)).
+    simpl in |- *. intros. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble 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).
+    exact (H (fun a0:ad => pf (Ndouble a0)) a y H3).
+    intro H2. rewrite H2 in H1. exact (H0 (fun a0:ad => pf (Ndouble_plus_one 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.
+   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'}.
+     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.
@@ -73,63 +72,63 @@ Section MapIter.
     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.
+     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble 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).
+    elim (H (fun a0:ad => pf (Ndouble a0)) a y H2). intros a0 H6. split with (Ndouble 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.
+    intro H1. rewrite H1. intro H2. elim (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) a y H2).
+    intros a0 H3. split with (Ndouble_plus_one 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.
+       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).
+    intro H0. rewrite H0. intro H1. inversion H1. rewrite (H a). rewrite (Neqb_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)).
+    intros. rewrite (MapGet_M2_bit_0_if A m0 m1 (fp a)). elim (sumbool_of_bool (Nbit0 (fp a))).
+    intro H3. rewrite H3. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble 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.
+  (H0 (fun a0:ad => pf (Ndouble_plus_one a0))
+     (fun a0:ad => Ndiv2 (fp a0))).
+    intro. rewrite H1. apply Ndouble_plus_one_div2.
     elim
-     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). intro H5. elim H5.
+     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble 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.
+    elim (MapSweep_semantics_2_1 m0 (fun a0:ad => pf (Ndouble a0)) a y H6). intros a0 H9.
+    rewrite H9 in H3. rewrite (H1 (Ndouble a0)) in H3. rewrite (Ndouble_bit0 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.
+     (H0 (fun a0:ad => pf (Ndouble_plus_one a0))
+        (fun a0:ad => Ndiv2 (fp a0))). intro.
+    rewrite H1. apply Ndouble_plus_one_div2.
     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.
+     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble 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.
+     (H (fun a0:ad => pf (Ndouble a0)) (fun a0:ad => Ndiv2 (fp a0))). intro. rewrite H1.
+    apply Ndouble_div2.
     assumption.
     intro H4. rewrite H4 in H2.
     elim
-     (MapSweep_semantics_2_1 m1 (fun a0:ad => pf (ad_double_plus_un a0)) a y
+     (MapSweep_semantics_2_1 m1 (fun a0:ad => pf (Ndouble_plus_one 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.
+    intros a0 H5. rewrite H5 in H3. rewrite (H1 (Ndouble_plus_one a0)) in H3.
+    rewrite (Ndouble_plus_one_bit0 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.
+     MapSweep m = Some (a, y) -> MapGet A m a = Some y.
   Proof.
     intros.
     exact
@@ -139,28 +138,28 @@ Section MapIter.
 
   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.
+     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 H. rewrite H. intros H0 a0 y0. elim (sumbool_of_bool (Neqb a a0)). intro H1. rewrite H1.
+    intro H2. inversion H2. rewrite <- H4. rewrite <- (Neqb_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)).
+    intros. simpl in H1. elim (option_sum (ad * A) (MapSweep1 (fun a:ad => pf (Ndouble 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).
+    intro H3. rewrite H3 in H1. elim (sumbool_of_bool (Nbit0 a)). intro H4.
+    rewrite (MapGet_M2_bit_0_1 A a H4 m0 m1) in H2. rewrite <- (Ndiv2_double_plus_one a H4).
+    exact (H0 (fun a:ad => pf (Ndouble_plus_one a)) H1 (Ndiv2 a) y H2).
+    intro H4. rewrite (MapGet_M2_bit_0_0 A a H4 m0 m1) in H2. rewrite <- (Ndiv2_double a H4).
+    exact (H (fun a:ad => pf (Ndouble a)) H3 (Ndiv2 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.
+     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).
@@ -168,36 +167,36 @@ Section MapIter.
 
   Lemma MapSweep_semantics_4_1 :
    forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A),
-     MapGet A m a = SOME A y ->
+     MapGet A m a = Some y ->
      f (pf a) y = true ->
-     {a' : ad &  {y' : A | MapSweep1 pf m = SOME _ (a', y')}}.
+     {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.
+    intros. elim (sumbool_of_bool (Neqb a a1)). intro H1. split with (pf a1). split with y.
+    rewrite (Neqb_complete _ _ H1). unfold MapSweep1, MapSweep2 in |- *.
+    rewrite (Neqb_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.
+    intros. elim (sumbool_of_bool (Nbit0 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)).
+    rewrite <- (Ndiv2_double_plus_one a H3) in H2.
+    elim (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) (Ndiv2 a) y H1 H2). intros a'' H4. elim H4.
+    intros y'' H5. simpl in |- *. elim (option_sum _ (MapSweep1 (fun a:ad => pf (Ndouble 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.
+    rewrite <- (Ndiv2_double a H3) in H2.
+    elim (H (fun a0:ad => pf (Ndouble a0)) (Ndiv2 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')}}.
+     MapGet A m a = Some 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.
@@ -212,8 +211,8 @@ Section MapIter.
     | 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)
+        MapMerge B (MapCollect1 f (fun a0:ad => pf (Ndouble a0)) m1)
+          (MapCollect1 f (fun a0:ad => pf (Ndouble_plus_one a0)) m2)
     end.
 
   Definition MapCollect (f:ad -> A -> Map B) (m:Map A) :=
@@ -231,8 +230,8 @@ Section MapIter.
       | 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)
+          op (MapFold1 f (fun a0:ad => pf (Ndouble a0)) m1)
+            (MapFold1 f (fun a0:ad => pf (Ndouble_plus_one a0)) m2)
       end.
 
     Definition MapFold (f:ad -> A -> M) (m:Map A) :=
@@ -258,11 +257,11 @@ Section MapIter.
       | 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
+          match MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m1 with
           | (state1, x1) =>
               match
                 MapFold1_state state1
-                  (fun a0:ad => pf (ad_double_plus_un a0)) m2
+                  (fun a0:ad => pf (Ndouble_plus_one a0)) m2
               with
               | (state2, x2) => (state2, op x1 x2)
               end
@@ -285,19 +284,19 @@ Section MapIter.
       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))
+  (pair_sp _ _ (MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m0))
   .
-      rewrite (H g (fun a0:ad => pf (ad_double a0)) H1 state).
+      rewrite (H g (fun a0:ad => pf (Ndouble 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))
+             (fst (MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m0))
+             (fun a0:ad => pf (Ndouble_plus_one 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)))
+       (H0 g (fun a0:ad => pf (Ndouble_plus_one a0)) H1
+          (fst (MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m0)))
        .
       reflexivity.
     Qed.
@@ -330,21 +329,21 @@ Section MapIter.
 
   Fixpoint alist_semantics (l:alist) : ad -> option A :=
     match l with
-    | nil => fun _:ad => NONE A
+    | nil => fun _:ad => None
     | (a, y) :: l' =>
-        fun a0:ad => if ad_eq a a0 then SOME A y else alist_semantics l' a0
+        fun a0:ad => if Neqb a a0 then Some 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
+     | None => alist_semantics l' a
+     | Some y => Some y
      end.
   Proof.
     unfold aapp in |- *. simple induction l. trivial.
-    intros. elim a. intros a1 y1. simpl in |- *. case (ad_eq a1 a0). reflexivity.
+    intros. elim a. intros a1 y1. simpl in |- *. case (Neqb a1 a0). reflexivity.
     apply H.
   Qed.
 
@@ -352,53 +351,53 @@ Section MapIter.
    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'}.
+          m) a = Some 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.
+    simpl in |- *. intros a y pf a0 y0. elim (sumbool_of_bool (Neqb (pf a) a0)). intro H. rewrite H.
+    intro H0. split with a. rewrite (Neqb_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)
+            (fun a0:ad => pf (Ndouble 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.
+            (fun a0:ad => pf (Ndouble_plus_one a0)) m1)) a = 
+    Some 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)
+           (fun a0:ad => pf (Ndouble 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)
+           (fun a0:ad => pf (Ndouble_plus_one 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.
+              (fun a0:ad => pf (Ndouble a0)) m0) a)).
+    intro H2. elim H2. intros y0 H3. elim (H (fun a0:ad => pf (Ndouble a0)) a y0 H3). intros a0 H4.
+    split with (Ndouble a0). assumption.
+    intro H2. rewrite H2 in H1. elim (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) a y H1).
+    intros a0 H3. split with (Ndouble_plus_one 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)).
+   forall pf:ad -> ad, ad_inj pf -> ad_inj (fun a0:ad => pf (Ndouble a0)).
   Proof.
-    unfold ad_inj in |- *. intros. apply ad_double_inj. exact (H _ _ H0).
+    unfold ad_inj in |- *. intros. apply Ndouble_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)).
+     ad_inj pf -> ad_inj (fun a0:ad => pf (Ndouble_plus_one a0)).
   Proof.
-    unfold ad_inj in |- *. intros. apply ad_double_plus_un_inj. exact (H _ _ H0).
+    unfold ad_inj in |- *. intros. apply Ndouble_plus_one_inj. exact (H _ _ H0).
   Qed.
 
   Lemma alist_of_Map_semantics_1 :
@@ -411,10 +410,10 @@ Section MapIter.
             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.
+    simpl in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). intro H0. rewrite H0.
+    rewrite (Neqb_complete _ _ H0). rewrite (Neqb_correct (pf a1)). reflexivity.
+    intro H0. rewrite H0. elim (sumbool_of_bool (Neqb (pf a) (pf a1))). intro H1.
+    rewrite (H a a1 (Neqb_complete _ _ H1)) in H0. rewrite (Neqb_correct a1) in H0.
     discriminate H0.
     intro H1. rewrite H1. reflexivity.
     intros. change
@@ -422,54 +421,53 @@ Section MapIter.
     alist_semantics
       (aapp
          (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
-            (fun a0:ad => pf (ad_double a0)) m0)
+            (fun a0:ad => pf (Ndouble 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)) (
+            (fun a0:ad => pf (Ndouble_plus_one 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).
+    elim (Ndouble_or_double_plus_un a). intro H2. elim H2. intros a0 H3. rewrite H3.
+    rewrite (Ndouble_bit0 a0).
     rewrite <-
-     (H (fun a1:ad => pf (ad_double a1)) (ad_comp_double_inj pf H1) a0)
+     (H (fun a1:ad => pf (Ndouble a1)) (ad_comp_double_inj pf H1) a0)
      .
-    rewrite ad_double_div_2. case (MapGet A m0 a0).
+    rewrite Ndouble_div2. case (MapGet A m0 a0); trivial.
     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)))).
+              (fun a1:ad => pf (Ndouble_plus_one a1)) m1)
+           (pf (Ndouble 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.
+     (alist_of_Map_semantics_1_1 m1 (fun a1:ad => pf (Ndouble_plus_one a1))
+        (pf (Ndouble a0)) y H5).
+    intros a1 H6. cut (Nbit0 (Ndouble a0) = Nbit0 (Ndouble_plus_one a1)).
+    intro. rewrite (Ndouble_bit0 a0) in H7. rewrite (Ndouble_plus_one_bit0 a1) in H7.
     discriminate H7.
-    rewrite (H1 (ad_double a0) (ad_double_plus_un a1) H6). reflexivity.
+    rewrite (H1 (Ndouble a0) (Ndouble_plus_one 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).
+    intro H2. elim H2. intros a0 H3. rewrite H3. rewrite (Ndouble_plus_one_bit0 a0).
     rewrite <-
-     (H0 (fun a1:ad => pf (ad_double_plus_un a1))
+     (H0 (fun a1:ad => pf (Ndouble_plus_one a1))
         (ad_comp_double_plus_un_inj pf H1) a0).
-    rewrite ad_double_plus_un_div_2.
+    rewrite Ndouble_plus_one_div2.
     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)))).
+              (fun a1:ad => pf (Ndouble a1)) m0)
+           (pf (Ndouble_plus_one 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.
+     (alist_of_Map_semantics_1_1 m0 (fun a1:ad => pf (Ndouble a1))
+        (pf (Ndouble_plus_one a0)) y H5).
+    intros a1 H6. cut (Nbit0 (Ndouble_plus_one a0) = Nbit0 (Ndouble a1)).
+    intro H7. rewrite (Ndouble_plus_one_bit0 a0) in H7. rewrite (Ndouble_bit0 a1) in H7.
     discriminate H7.
-    rewrite (H1 (ad_double_plus_un a0) (ad_double a1) H6). reflexivity.
+    rewrite (H1 (Ndouble_plus_one a0) (Ndouble a1) H6). reflexivity.
     intro H4. rewrite H4. reflexivity.
   Qed.
 
@@ -491,9 +489,9 @@ Section MapIter.
    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).
+    intros r l0 H a. elim r. intros a0 y0. simpl in |- *. elim (sumbool_of_bool (Neqb a0 a)).
+    intro H0. rewrite H0. rewrite (Neqb_complete _ _ H0).
+    rewrite (MapPut_semantics A (Map_of_alist l0) a y0 a). rewrite (Neqb_correct a).
     reflexivity.
     intro H0. rewrite H0. rewrite (MapPut_semantics A (Map_of_alist l0) a0 y0 a).
     rewrite H0. apply H.
@@ -551,7 +549,7 @@ Section MapIter.
     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))).
+    rewrite (H2 (fun a0:ad => pf (Ndouble a0))). rewrite (H3 (fun a0:ad => pf (Ndouble_plus_one a0))).
     reflexivity.
   Qed.
 
@@ -590,7 +588,7 @@ Section MapIter.
     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).
+    cut (MapGet A (MapDomRestrTo A A m m') a = None).
     rewrite (MapDomRestrTo_semantics A A m m' a). rewrite H3. rewrite H1. intro. discriminate H4.
     exact (H a).
     intro H2. rewrite H2. reflexivity.
diff --git a/theories/IntMap/Maplists.v b/theories/IntMap/Maplists.v
index 1d53e6e5..56a3c160 100644
--- a/theories/IntMap/Maplists.v
+++ b/theories/IntMap/Maplists.v
@@ -5,10 +5,11 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Maplists.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Maplists.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
-Require Import Addr.
-Require Import Addec.
+Require Import BinNat.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Fset.
 Require Import Mapaxioms.
@@ -28,7 +29,7 @@ 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')
+    | a' :: l' => orb (Neqb a a') (ad_in_list a l')
     end.
 
   Fixpoint ad_list_stutters (l:list ad) : bool :=
@@ -43,8 +44,8 @@ Section MapLists.
      {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.
+    intros. elim (sumbool_of_bool (Neqb x a)). intro H1. simpl in H0. split with (nil (A:=ad)).
+    split with l0. rewrite (Neqb_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.
@@ -223,7 +224,7 @@ Section MapLists.
   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.
+    simple induction l. simpl in |- *. intros. rewrite (Neqb_correct x). reflexivity.
     intros. simpl in |- *. rewrite (H l' x). apply orb_b_true.
   Qed.
 
@@ -353,18 +354,18 @@ Section MapLists.
         (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).
+    simpl in |- *. rewrite (MapFold_orb A (fun (a0:ad) (_:A) => orb (Neqb a a0) false) m).
     elim
      (option_sum _
-        (MapSweep A (fun (a0:ad) (_:A) => orb (ad_eq a a0) false) m)). intro H. elim H.
+        (MapSweep A (fun (a0:ad) (_:A) => orb (Neqb 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.
+    rewrite (Neqb_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.
+    rewrite (Neqb_correct a) in H2. discriminate H2.
     exact (sym_eq (y:=_)).
   Qed.
 
@@ -397,7 +398,7 @@ Section MapLists.
           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))).
+    rewrite (H (fun a0:ad => pf (Ndouble a0))). rewrite (H0 (fun a0:ad => pf (Ndouble_plus_one a0))).
     reflexivity.
   Qed.
 
@@ -423,8 +424,8 @@ Section MapLists.
      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.
+    simple induction m; try trivial. simpl in |- *. intros. rewrite (H (fun a0:ad => pf (Ndouble a0))).
+    rewrite (H0 (fun a0:ad => pf (Ndouble_plus_one a0))). reflexivity.
   Qed.
 
   Lemma ad_list_of_dom_Dom :
diff --git a/theories/IntMap/Mapsubset.v b/theories/IntMap/Mapsubset.v
index e27943fb..6771c03e 100644
--- a/theories/IntMap/Mapsubset.v
+++ b/theories/IntMap/Mapsubset.v
@@ -5,15 +5,14 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapsubset.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
+(*i 	$Id: Mapsubset.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
 Require Import Arith.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Fset.
 Require Import Mapaxioms.
@@ -28,7 +27,7 @@ Section MapSubsetDef.
 
   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
+    | None => true
     | _ => false
     end.
 
@@ -76,10 +75,10 @@ Section MapSubsetDef.
     unfold eqmap, eqm, in_dom in |- *. intros.
     cut
      (match MapGet A m a with
-      | NONE => false
-      | SOME _ => true
+      | None => false
+      | Some _ => true
       end = false).
-    case (MapGet A m a). trivial.
+    case (MapGet A m a); trivial.
     intros. discriminate H0.
     exact (H a).
   Qed.
@@ -346,7 +345,7 @@ Section MapDisjointDef.
 
   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
+    | None => true
     | _ => false
     end.
 
@@ -395,7 +394,7 @@ Section MapDisjointDef.
   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.
+    cut (MapGet A (MapDomRestrTo A B m m') a = None). intro.
     rewrite (MapDomRestrTo_semantics _ _ m m' a) in H4. rewrite H3 in H4. rewrite H2 in H4.
     discriminate H4.
     exact (H a).
@@ -449,11 +448,11 @@ Section MapDisjointExtra.
   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.
+    intros y' H5. apply (H (Ndouble a)).
+    rewrite (MapGet_M2_bit_0_0 _ (Ndouble a) (Ndouble_bit0 a) m0 m1).
+    rewrite (Ndouble_div2 a). rewrite H3. reflexivity.
+    rewrite (MapGet_M2_bit_0_0 _ (Ndouble a) (Ndouble_bit0 a) m2 m3).
+    rewrite (Ndouble_div2 a). rewrite H5. reflexivity.
     intro H4. rewrite H4 in H1. discriminate H1.
     intro H2. rewrite H2 in H0. discriminate H0.
   Qed.
@@ -464,15 +463,15 @@ Section MapDisjointExtra.
   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)).
+    intros y' H5. apply (H (Ndouble_plus_one a)).
     rewrite
-     (MapGet_M2_bit_0_1 _ (ad_double_plus_un a) (ad_double_plus_un_bit_0 a)
+     (MapGet_M2_bit_0_1 _ (Ndouble_plus_one a) (Ndouble_plus_one_bit0 a)
         m0 m1).
-    rewrite (ad_double_plus_un_div_2 a). rewrite H3. reflexivity.
+    rewrite (Ndouble_plus_one_div2 a). rewrite H3. reflexivity.
     rewrite
-     (MapGet_M2_bit_0_1 _ (ad_double_plus_un a) (ad_double_plus_un_bit_0 a)
+     (MapGet_M2_bit_0_1 _ (Ndouble_plus_one a) (Ndouble_plus_one_bit0 a)
         m2 m3).
-    rewrite (ad_double_plus_un_div_2 a). rewrite H5. reflexivity.
+    rewrite (Ndouble_plus_one_div2 a). rewrite H5. reflexivity.
     intro H4. rewrite H4 in H1. discriminate H1.
     intro H2. rewrite H2 in H0. discriminate H0.
   Qed.
@@ -482,11 +481,11 @@ Section MapDisjointExtra.
      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.
+    unfold MapDisjoint, in_dom in |- *. intros. elim (sumbool_of_bool (Nbit0 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).
+    rewrite (MapGet_M2_bit_0_1 B a H3 m2 m3) in H2. exact (H0 (Ndiv2 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).
+    rewrite (MapGet_M2_bit_0_0 B a H3 m2 m3) in H2. exact (H (Ndiv2 a) H1 H2).
   Qed.
 
   Lemma MapDisjoint_M1_l :
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index ad91a350..751bc3da 100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -1,730 +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        *)
-(************************************************************************)
+  (************************************************************************)
+  (*  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 8686 2006-04-06 13:25:10Z letouzey $ i*)
+  (*i $Id: List.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
-Require Import Le Minus Min Bool.
-
-Section Lists.
-
-Variable A : Set.
+Require Import Le Gt Minus Min Bool.
+Require Import Setoid.
 
 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.
-
-Ltac now_show c := change c in |- *.
-
-(*************************)
-(** Discrimination       *)
-(*************************)
-
-Lemma nil_cons : forall (a:A) (m:list), nil <> a :: m.
-Proof. 
-  intros; discriminate.
-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}.
+(******************************************************************)
+(** * Basics: definition of polymorphic lists and some operations *)
+(******************************************************************)
 
-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.
-Defined.
-
-(**************************)
-(** 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.
+(** ** Definitions *)
 
-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.
-
-Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d.
-Proof.
-induction l; destruct n; simpl; intros; auto.
-inversion H.
-apply IHl; auto with arith.
-Qed.
-
-Lemma nth_indep : 
- forall l n d d', n < length l -> nth n l d = nth n l d'.
-Proof.
-induction l; simpl; intros; auto.
-inversion H.
-destruct n; simpl; auto with arith.
-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.
-
-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.
-
-Lemma app_length : forall l l', length (l++l') = length l + length l'.
-Proof.
-induction l; simpl; 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.
-
-Lemma app_nth1 : 
- forall l l' d n, n < length l -> nth n (l++l') d = nth n l d.
-Proof.
-induction l.
-intros.
-inversion H.
-intros l' d n.
-case n; simpl; auto.
-intros; rewrite IHl; auto with arith.
-Qed.
-
-Lemma app_nth2 : 
- forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d.
-Proof.
-induction l.
-intros.
-simpl.
-destruct n; auto.
-intros l' d n.
-case n; simpl; auto.
-intros.
-inversion H.
-intros.
-rewrite IHl; auto with arith.
-Qed.
-
-
-(***************************)
-(** 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.
-
-
-
-(********************************)
-(** 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.
-
-Lemma In_rev : forall l x, In x l <-> In x (rev l).
-Proof.
-induction l.
-simpl; intuition.
-intros.
-simpl.
-intuition.
-subst.
-apply in_or_app; right; simpl; auto.
-apply in_or_app; left; firstorder.
-destruct (in_app_or _ _ _ H); firstorder.
-Qed.
-
-Lemma rev_length : forall l, length (rev l) = length l.
-Proof.
-induction l;simpl; auto.
-rewrite app_length.
-rewrite IHl.
-simpl.
-elim (length l); simpl; auto.
-Qed.
-
-Lemma rev_nth : forall l d n,  n < length l ->  
- nth n (rev l) d = nth (length l - S n) l d.
-Proof.
-induction l.
-intros; inversion H.
-intros.
-simpl in H.
-simpl (rev (a :: l)).
-simpl (length (a :: l) - S n).
-inversion H.
-rewrite <- minus_n_n; simpl.
-rewrite <- rev_length.
-rewrite app_nth2; auto.
-rewrite <- minus_n_n; auto.
-rewrite app_nth1; auto.
-rewrite (minus_plus_simpl_l_reverse (length l) n 1).
-replace (1 + length l) with (S (length l)); auto with arith.
-rewrite <- minus_Sn_m; auto with arith; simpl.
-apply IHl; auto.
-rewrite rev_length; auto.
-Qed.
-
-(****************************************************)
-(**  An alternative tail-recursive definition for reverse *) 
-(****************************************************)
-
-Fixpoint rev_acc (l l': list) {struct l} : list := 
- match l with 
-  | nil => l' 
-  | a::l => rev_acc l (a::l')
- end.
-
-Lemma rev_acc_rev : forall l l', rev_acc l l' = rev l ++ l'.
-Proof.
-induction l; simpl; auto; intros.
-rewrite <- ass_app; firstorder.
-Qed.
-
-Lemma rev_alt : forall l, rev l = rev_acc l nil.
-Proof.
-intros; rewrite rev_acc_rev.
-apply app_nil_end.
-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.
-
-(***************************)
-(** Last elements of a list *)
-(***************************)
-
-(** [last l d] returns the last elements of the list [l], 
-    or the default value [d] if [l] is empty. *)
-
-Fixpoint last (l:list)(d:A)  {struct l} : A := 
- match l with 
-  | nil => d 
-  | a :: nil => a 
-  | a :: l => last l d
- end.
-
-(** [removelast l] remove the last element of [l] *)
-
-Fixpoint removelast (l:list) {struct l} : list := 
- match l with 
-  | nil =>  nil 
-  | a :: nil => nil 
-  | a :: l => a :: removelast l
- end.
-
-Lemma app_removelast_last : 
- forall l d, l<>nil -> l = removelast l ++ (last l d :: nil).
-Proof.
-induction l.
-destruct 1; auto.
-intros d _.
-destruct l; auto.
-pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate.
-Qed.
-
-Lemma exists_last : 
- forall l, l<>nil -> { l' : list & { a : A | l = l'++a::nil}}. 
-Proof. 
-induction l.
-destruct 1; auto.
-intros _.
-destruct l.
-exists nil; exists a; auto.
-destruct IHl as [l' (a',H)]; try discriminate.
-rewrite H.
-exists (a::l'); exists a'; auto.
-Qed.
-
-(********************************)
-(* Cutting a list at some position *)
-(********************************)
-
-Fixpoint firstn (n:nat)(l:list) {struct n} : list := 
- match n with 
-  | 0 => nil 
-  | S n => match l with  
-       | nil => nil 
-       | a::l => a::(firstn n l)
-   end
-  end.
-
-Fixpoint skipn (n:nat)(l:list) { struct n } : list := 
-  match n with 
-   | 0 => l 
-   | S n => match l with 
-        | nil => nil 
-        | a::l => skipn n l
-    end
-  end.
-
-Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l.
-Proof.
-induction n.
-simpl; auto.
-destruct l; simpl; auto.
-f_equal; auto.
-Qed.
-
-(**************)
-(** Remove *)
-(**************)
-
-Section Remove.
-
-Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}.
-
-Fixpoint remove (x : A) (l : list){struct l} : list :=
-  match l with
-    | nil => nil
-    | y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl)
-  end.
-
-End Remove.
-
-(***************************)
-(** List without redundancy *)
-(***************************)
-
-Inductive NoDup : list -> Prop := 
- | NoDup_nil : NoDup nil 
- | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l). 
+Section Lists.
 
+  Variable A : Type.
+
+  Inductive list : Type :=
+    | nil : list
+    | cons : A -> list -> list.
+
+  Infix "::" := cons (at level 60, right associativity) : list_scope.
+
+  Open Scope list_scope.
+
+  (** 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.
+
+  (** 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.
+
+
+  (** Concatenation of two lists *)
+  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.
+  
 End Lists.
 
-(** Exporting list notations and hints *)
+(** Exporting list notations and tactics *)
 
 Implicit Arguments nil [A].
 Infix "::" := cons (at level 60, right associativity) : list_scope.
 Infix "++" := app (right associativity, at level 60) : list_scope.
+ 
+Ltac now_show c := change c in |- *.
 
 Open Scope list_scope.
 
@@ -732,349 +85,1043 @@ Delimit Scope list_scope with list.
 
 Bind Scope list_scope with list.
 
-Hint Resolve nil_cons app_nil_end ass_app app_ass: datatypes v62.
+
+(** ** Facts about lists *)
+
+Section Facts.
+
+  Variable A : Type.
+
+
+  (** *** Genereric facts *)
+
+  (** Discrimination *)
+  Theorem nil_cons : forall (x:A) (l:list A), nil <> x :: l.
+  Proof. 
+    intros; discriminate.
+  Qed.
+
+
+  (** Destruction *)
+
+  Theorem destruct_list : forall l : list A, {x:A & {tl:list A | l = x::tl}}+{l = nil}.
+  Proof.
+    induction l as [|a tl].
+    right; reflexivity.
+    left; exists a; exists tl; reflexivity.
+  Qed.
+    
+  (** *** Head and tail *)
+  
+  Theorem head_nil : head (@nil A) = None.
+  Proof.
+    simpl; reflexivity.
+  Qed.
+
+  Theorem head_cons : forall (l : list A) (x : A), head (x::l) = Some x.
+  Proof.
+    intros; simpl; reflexivity.
+  Qed.
+
+
+  (************************)
+  (** *** Facts about [In] *) 
+  (************************)
+
+
+  (** Characterization of [In] *)
+  
+  Theorem in_eq : forall (a:A) (l:list A), In a (a :: l).
+  Proof. 
+    simpl in |- *; auto.
+  Qed.
+  Hint Resolve in_eq.
+  
+  Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l).
+  Proof. 
+    simpl in |- *; auto.
+  Qed.
+  Hint Resolve in_cons.
+
+  Theorem in_nil : forall a:A, ~ In a nil.
+  Proof.
+    unfold not in |- *; intros a H; inversion_clear H.
+  Qed.
+
+  Lemma In_split : forall x (l:list A), In x l -> exists l1, exists l2, l = l1++x::l2.
+  Proof.
+  induction l; simpl; destruct 1.
+  subst a; auto.
+  exists (@nil A); exists l; auto.
+  destruct (IHl H) as (l1,(l2,H0)).
+  exists (a::l1); exists l2; simpl; f_equal; auto.
+  Qed.
+
+  (** Inversion *)
+  Theorem in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l.
+  Proof.
+    intros a b l H; inversion_clear H; auto.
+  Qed.
+
+  (** Decidability of [In] *)
+  Theorem In_dec :
+    (forall x y:A, {x = y} + {x <> y}) ->
+    forall (a:A) (l:list A), {In a l} + {~ In a l}.
+  Proof.
+    intro H; 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.
+  Defined.
+
+
+  (*************************)
+  (** *** Facts about [app] *)
+  (*************************)
+
+  (** Discrimination *)
+  Theorem app_cons_not_nil : forall (x y:list A) (a:A), nil <> x ++ a :: y.
+  Proof.
+    unfold not in |- *.
+    destruct x as [| a l]; simpl in |- *; intros.
+    discriminate H.
+    discriminate H.
+  Qed.
+
+
+  (** Concat with [nil] *)
+
+  Theorem app_nil_end : forall l:list A, l = l ++ nil.
+  Proof. 
+    induction l; simpl in |- *; auto.
+    rewrite <- IHl; auto.
+  Qed.
+  Hint Resolve app_nil_end.
+  
+
+  (** [app] is associative *)
+  Theorem app_ass : forall l m n:list A, (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.
+
+  Theorem ass_app : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n.
+  Proof. 
+    auto.
+  Qed.
+  Hint Resolve ass_app.
+
+  (** [app] commutes with [cons] *) 
+  Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y.
+  Proof.
+    auto.
+  Qed.
+
+
+
+  (** Facts deduced from the result of a concatenation *)  
+
+  Theorem app_eq_nil : forall l l':list A, l ++ l' = nil -> l = nil /\ l' = nil.
+  Proof.
+    destruct l as [| x l]; destruct l' as [| y l']; simpl in |- *; auto.
+    intro; discriminate.
+    intros H; discriminate H.
+  Qed.
+
+  Theorem app_eq_unit :
+    forall (x y:list A) (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) (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.
+
+
+  (** Compatibility wtih other operations *)
+
+  Lemma app_length : forall l l' : list A, length (l++l') = length l + length l'.
+  Proof.
+    induction l; simpl; auto.
+  Qed.
+
+  Lemma in_app_or : forall (l m:list A) (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: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.
+
+
+End Facts.
+
+Hint Resolve 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 *)
-(****************************************************************)
 
-(*********)
-(** Map *)
-(*********)
+(*******************************************)
+(** * Operations on the elements of a list *)
+(*******************************************)
+
+Section Elts.
+
+  Variable A : Type.
+
+  (*****************************)
+  (** ** Nth element of a list *)
+  (*****************************)
+
+  Fixpoint nth (n:nat) (l:list A) (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 A) (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 A) (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 A) (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 A) (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 A) (n:nat) : A :=
+    match nth_error l n with
+      | Some x => x
+      | None => default
+    end.
+
+  Lemma nth_In :
+    forall (n:nat) (l:list A) (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.
+
+  Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d.
+  Proof.
+    induction l; destruct n; simpl; intros; auto.
+    inversion H.
+    apply IHl; auto with arith.
+  Qed.
+
+  Lemma nth_indep : 
+    forall l n d d', n < length l -> nth n l d = nth n l d'.
+  Proof.
+    induction l; simpl; intros; auto.
+    inversion H.
+    destruct n; simpl; auto with arith.
+  Qed.
+
+  Lemma app_nth1 : 
+    forall l l' d n, n < length l -> nth n (l++l') d = nth n l d.
+  Proof.
+    induction l.
+    intros.
+    inversion H.
+    intros l' d n.
+    case n; simpl; auto.
+    intros; rewrite IHl; auto with arith.
+  Qed.
+
+  Lemma app_nth2 : 
+    forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d.
+  Proof.
+    induction l.
+    intros.
+    simpl.
+    destruct n; auto.
+    intros l' d n.
+    case n; simpl; auto.
+    intros.
+    inversion H.
+    intros.
+    rewrite IHl; auto with arith.
+  Qed.
+
+
+
+
+  (*****************)
+  (** ** Remove    *)
+  (*****************)
+
+  Section Remove.
+
+    Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}.
+    
+    Fixpoint remove (x : A) (l : list A){struct l} : list A :=
+      match l with
+	| nil => nil
+	| y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl)
+      end.
+    
+    Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l).
+    Proof.
+      induction l as [|x l]; auto.
+      intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. 
+      apply IHl.
+      unfold not; intro HF; simpl in HF; destruct HF; auto.
+      apply (IHl y); assumption. 
+    Qed.
+  
+  End Remove.
 
-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.
+(******************************)
+(** ** Last element of a list *)
+(******************************)
 
-Lemma in_map :
- forall (l:list A) (x:A), In x l -> In (f x) (map l).
-Proof. 
-  induction l as [| a l IHl]; simpl in |- *;
-   [ auto
-   | destruct 1; [ left; apply f_equal with (f := f); assumption | auto ] ].
-Qed.
+  (** [last l d] returns the last element of the list [l], 
+    or the default value [d] if [l] is empty. *)
 
-Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l.
-Proof.
-induction l; firstorder (subst; auto).
-Qed.
+  Fixpoint last (l:list A) (d:A)  {struct l} : A := 
+  match l with 
+    | nil => d 
+    | a :: nil => a 
+    | a :: l => last l d
+  end.
 
-Lemma map_length : forall l, length (map l) = length l.
-Proof.
-induction l; simpl; auto.
-Qed.
+  (** [removelast l] remove the last element of [l] *)
+
+  Fixpoint removelast (l:list A) {struct l} : list A := 
+    match l with 
+      | nil =>  nil 
+      | a :: nil => nil 
+      | a :: l => a :: removelast l
+    end.
+  
+  Lemma app_removelast_last : 
+    forall l d, l<>nil -> l = removelast l ++ (last l d :: nil).
+  Proof.
+    induction l.
+    destruct 1; auto.
+    intros d _.
+    destruct l; auto.
+    pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate.
+  Qed.
+  
+  Lemma exists_last : 
+    forall l, l<>nil -> { l' : (list A) & { a : A | l = l'++a::nil}}. 
+  Proof. 
+    induction l.
+    destruct 1; auto.
+    intros _.
+    destruct l.
+    exists (@nil A); exists a; auto.
+    destruct IHl as [l' (a',H)]; try discriminate.
+    rewrite H.
+    exists (a::l'); exists a'; auto.
+  Qed.
+
+  
+  (****************************************)
+  (** ** Counting occurences of a element *)
+  (****************************************)
+
+  Hypotheses eqA_dec : forall x y : A, {x = y}+{x <> y}.
+  
+  Fixpoint count_occ (l : list A) (x : A){struct l} : nat :=
+    match l with 
+      | nil => 0
+      | y :: tl => 
+	let n := count_occ tl x in 
+	  if eqA_dec y x then S n else n
+    end.
+  
+  (** Compatibility of count_occ with operations on list *)
+  Theorem count_occ_In : forall (l : list A) (x : A), In x l <-> count_occ l x > 0.
+  Proof.
+    induction l as [|y l].
+    simpl; intros; split; [destruct 1 | apply gt_irrefl].
+    simpl. intro x; destruct (eqA_dec y x) as [Heq|Hneq].
+    rewrite Heq; intuition. 
+    rewrite <- (IHl x).
+    tauto.
+  Qed.
+  
+  Theorem count_occ_inv_nil : forall (l : list A), (forall x:A, count_occ l x = 0) <-> l = nil.
+  Proof.
+    split.
+    (* Case -> *)
+    induction l as [|x l].
+    trivial.
+    intro H.
+    elim (O_S (count_occ l x)).
+    apply sym_eq.
+    generalize (H x).
+    simpl. destruct (eqA_dec x x) as [|HF].
+    trivial.
+    elim HF; reflexivity.
+    (* Case <- *)
+    intro H; rewrite H; simpl; reflexivity.
+  Qed.
+  
+  Lemma count_occ_nil : forall (x : A), count_occ nil x = 0.
+  Proof.
+    intro x; simpl; reflexivity.
+  Qed.
+
+  Lemma count_occ_cons_eq : forall (l : list A) (x y : A), x = y -> count_occ (x::l) y = S (count_occ l y).
+  Proof.
+    intros l x y H; simpl.
+    destruct (eqA_dec x y); [reflexivity | contradiction].
+  Qed.
+  
+  Lemma count_occ_cons_neq : forall (l : list A) (x y : A), x <> y -> count_occ (x::l) y = count_occ l y.
+  Proof.
+    intros l x y H; simpl.
+    destruct (eqA_dec x y); [contradiction | reflexivity]. 
+  Qed.
+
+End Elts.
+
+
+
+(*******************************)
+(** * Manipulating whole lists *)
+(*******************************)
+
+Section ListOps.
+
+  Variable A : Type.
+
+  (*************************)
+  (** ** Reverse           *)
+  (*************************)
+
+  Fixpoint rev (l:list A) : list A :=
+    match l with
+      | nil => nil
+      | x :: l' => rev l' ++ x :: nil
+    end.
+
+  Lemma distr_rev : forall x y:list A, 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: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 A, 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.
+
+
+  (** Compatibility with other operations *)
+
+  Lemma In_rev : forall l x, In x l <-> In x (rev l).
+  Proof.
+    induction l.
+    simpl; intuition.
+    intros.
+    simpl.
+    intuition.
+    subst.
+    apply in_or_app; right; simpl; auto.
+    apply in_or_app; left; firstorder.
+    destruct (in_app_or _ _ _ H); firstorder.
+  Qed.
+
+  Lemma rev_length : forall l, length (rev l) = length l.
+  Proof.
+    induction l;simpl; auto.
+    rewrite app_length.
+    rewrite IHl.
+    simpl.
+    elim (length l); simpl; auto.
+  Qed.
+
+  Lemma rev_nth : forall l d n,  n < length l ->  
+    nth n (rev l) d = nth (length l - S n) l d.
+  Proof.
+    induction l.
+    intros; inversion H.
+    intros.
+    simpl in H.
+    simpl (rev (a :: l)).
+    simpl (length (a :: l) - S n).
+    inversion H.
+    rewrite <- minus_n_n; simpl.
+    rewrite <- rev_length.
+    rewrite app_nth2; auto.
+    rewrite <- minus_n_n; auto.
+    rewrite app_nth1; auto.
+    rewrite (minus_plus_simpl_l_reverse (length l) n 1).
+    replace (1 + length l) with (S (length l)); auto with arith.
+    rewrite <- minus_Sn_m; auto with arith; simpl.
+    apply IHl; auto.
+    rewrite rev_length; auto.
+  Qed.
+
+
+  (**  An alternative tail-recursive definition for reverse *) 
+
+  Fixpoint rev_acc (l l': list A) {struct l} : list A := 
+    match l with 
+      | nil => l' 
+      | a::l => rev_acc l (a::l')
+    end.
+
+  Lemma rev_acc_rev : forall l l', rev_acc l l' = rev l ++ l'.
+  Proof.
+    induction l; simpl; auto; intros.
+    rewrite <- ass_app; firstorder.
+  Qed.
+
+  Lemma rev_alt : forall l, rev l = rev_acc l nil.
+  Proof.
+    intros; rewrite rev_acc_rev.
+    apply app_nil_end.
+  Qed.
 
-Lemma map_nth : forall l d n, 
- nth n (map l) (f d) = f (nth n l d).
-Proof.
-induction l; simpl map; destruct n; firstorder.
-Qed.
 
-Lemma map_app : forall l l',  
- map (l++l') = (map l)++(map l').
-Proof. 
-induction l; simpl; auto.
-intros; rewrite IHl; auto.
-Qed.
+(*********************************************)
+(** Reverse Induction Principle on Lists  *)
+(*********************************************)
+  
+  Section Reverse_Induction.
+    
+    Unset Implicit Arguments.
+    
+    Lemma rev_list_ind :
+      forall P:list A-> Prop,
+	P nil ->
+	(forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) ->
+	forall l:list A, P (rev l).
+    Proof.
+      induction l; auto.
+    Qed.
+    Set Implicit Arguments.
+    
+    Theorem rev_ind :
+      forall P:list A -> Prop,
+	P nil ->
+	(forall (x:A) (l:list A), P l -> P (l ++ x :: nil)) -> forall l:list A, 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.
+
+
+
+  (***********************************)
+  (** ** Lists modulo permutation    *)
+  (***********************************)
+  
+  Section Permutation.
+
+    Inductive Permutation : list A -> list A -> Prop :=
+      | perm_nil: Permutation nil nil
+      | perm_skip: forall (x:A) (l l':list A), Permutation l l' -> Permutation (cons x l) (cons x l')
+      | perm_swap: forall (x y:A) (l:list A), Permutation (cons y (cons x l)) (cons x (cons y l))
+      | perm_trans: forall (l l' l'':list A), Permutation l l' -> Permutation l' l'' -> Permutation l l''.
+
+    Hint Constructors Permutation.
+
+  (** Some facts about [Permutation] *)
+
+    Theorem Permutation_nil : forall (l : list A), Permutation nil l -> l = nil.
+    Proof.
+      intros l HF.
+      set (m:=@nil A) in HF; assert (m = nil); [reflexivity|idtac]; clearbody m.
+      induction HF; try elim (nil_cons (sym_eq H)); auto.
+    Qed.
+
+    Theorem Permutation_nil_cons : forall (l : list A) (x : A), ~ Permutation nil (x::l).
+    Proof.
+      unfold not; intros l x HF.
+      elim (@nil_cons A x l). apply sym_eq. exact (Permutation_nil HF).
+    Qed.
+
+  (** Permutation over lists is a equivalence relation *)
+
+    Theorem Permutation_refl : forall l : list A, Permutation l l.
+    Proof.
+      induction l; constructor. exact IHl. 
+    Qed.
+
+    Theorem Permutation_sym : forall l l' : list A, Permutation l l' -> Permutation l' l.
+    Proof.
+      intros l l' Hperm; induction Hperm; auto.
+      apply perm_trans with (l':=l'); assumption.
+    Qed.
+
+    Theorem Permutation_trans : forall l l' l'' : list A, Permutation l l' -> Permutation l' l'' -> Permutation l l''.
+    Proof.
+      exact perm_trans.
+    Qed.
+
+    Hint Resolve Permutation_refl Permutation_sym Permutation_trans.
+
+  (** Compatibility with others operations on lists *)
+
+    Theorem Permutation_in : forall (l l' : list A) (x : A), Permutation l l' -> In x l -> In x l'.
+    Proof.
+      intros l l' x Hperm; induction Hperm; simpl; tauto. 
+    Qed.
+
+    Lemma Permutation_app_tail : forall (l l' tl : list A), Permutation l l' -> Permutation (l++tl) (l'++tl).
+    Proof.
+      intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto.
+      eapply Permutation_trans with (l':=l'++tl); trivial.
+    Qed.
+
+    Lemma Permutation_app_head : forall (l tl tl' : list A), Permutation tl tl' -> Permutation (l++tl) (l++tl').
+    Proof.
+      intros l tl tl' Hperm; induction l; [trivial | repeat rewrite <- app_comm_cons; constructor; assumption].
+    Qed.
+
+    Theorem Permutation_app : forall (l m l' m' : list A), Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m').
+    Proof.
+      intros l m l' m' Hpermll' Hpermmm'; induction Hpermll' as [|x l l'|x y l|l l' l'']; repeat rewrite <- app_comm_cons; auto.
+      apply Permutation_trans with (l' := (x :: y :: l ++ m));
+	[idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial.
+      apply Permutation_trans with (l' := (l' ++ m')); try assumption.
+      apply Permutation_app_tail; assumption.
+    Qed.
+
+    Theorem Permutation_app_swap : forall (l l' : list A), Permutation (l++l') (l'++l).
+    Proof.
+      induction l as [|x l]. 
+      simpl; intro l'; rewrite <- app_nil_end; trivial.
+      induction l' as [|y l'].
+      simpl; rewrite <- app_nil_end; trivial.
+      simpl; apply Permutation_trans with (l' := x :: y :: l' ++ l).
+      constructor; rewrite app_comm_cons; apply IHl.
+      apply Permutation_trans with (l' := y :: x :: l' ++ l); constructor.
+      apply Permutation_trans with (l' := x :: l ++ l'); auto.
+    Qed.
+  
+    Theorem Permutation_cons_app : forall (l l1 l2:list A) a,
+      Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2).
+    Proof.
+    intros l l1; revert l.
+    induction l1.
+    simpl.
+    intros; apply perm_skip; auto.
+    simpl; intros.
+    apply perm_trans with (a0::a::l1++l2).
+    apply perm_skip; auto.
+    apply perm_trans with (a::a0::l1++l2).
+    apply perm_swap; auto.
+    apply perm_skip; auto.
+    Qed.
+    Hint Resolve Permutation_cons_app.
+
+    Theorem Permutation_length : forall (l l' : list A), Permutation l l' -> length l = length l'.
+    Proof.
+      intros l l' Hperm; induction Hperm; simpl; auto.
+      apply trans_eq with (y:= (length l')); trivial.
+    Qed.
+
+    Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). 
+    Proof.
+      induction l as [| x l]; simpl; trivial.
+      apply Permutation_trans with (l' := (x::nil)++rev l).
+      simpl; auto.
+      apply Permutation_app_swap.
+    Qed.
+
+    Theorem Permutation_ind_bis : 
+     forall P : list A -> list A -> Prop,
+       P (@nil A) (@nil A) ->
+       (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) ->
+       (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
+       (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') ->
+       forall l l', Permutation l l' -> P l l'.
+    Proof.
+    intros P Hnil Hskip Hswap Htrans.
+    induction 1; auto.
+    apply Htrans with (x::y::l); auto.
+    apply Hswap; auto.
+    induction l; auto.
+    apply Hskip; auto.
+    apply Hskip; auto.
+    induction l; auto.
+    eauto.
+    Qed.
+
+    Ltac break_list l x l' H := 
+     destruct l as [|x l']; simpl in *; 
+     injection H; intros; subst; clear H.
+
+    Theorem Permutation_app_inv : forall (l1 l2 l3 l4:list A) a,
+      Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4).
+    Proof.
+    set (P:=fun l l' =>  
+             forall a l1 l2 l3 l4, l=l1++a::l2 -> l'=l3++a::l4 -> Permutation (l1++l2) (l3++l4)).
+    cut (forall l l', Permutation l l' -> P l l').
+    intros; apply (H _ _ H0 a); auto.
+    intros; apply (Permutation_ind_bis P); unfold P; clear P; try clear H l l'; simpl; auto.
+    (* nil *)
+    intros; destruct l1; simpl in *; discriminate.
+    (* skip *)
+    intros x l l' H IH; intros.
+    break_list l1 b l1' H0; break_list l3 c l3' H1.
+    auto.
+    apply perm_trans with (l3'++c::l4); auto.
+    apply perm_trans with (l1'++a::l2); auto.
+    apply perm_skip.
+    apply (IH a l1' l2 l3' l4); auto.
+    (* swap *)
+    intros x y l l' Hp IH; intros.
+    break_list l1 b l1' H; break_list l3 c l3' H0.
+    auto.
+    break_list l3' b l3'' H.
+    auto.
+    apply perm_trans with (c::l3''++b::l4); auto.
+    break_list l1' c l1'' H1. 
+    auto.
+    apply perm_trans with (b::l1''++c::l2); auto.
+    break_list l3' d l3'' H; break_list l1' e l1'' H1. 
+    auto.
+    apply perm_trans with (e::a::l1''++l2); auto.
+    apply perm_trans with (e::l1''++a::l2); auto.
+    apply perm_trans with (d::a::l3''++l4); auto.
+    apply perm_trans with (d::l3''++a::l4); auto.
+    apply perm_trans with (e::d::l1''++l2); auto.
+    apply perm_skip; apply perm_skip.
+    apply (IH a l1'' l2 l3'' l4); auto.
+    (*trans*)
+    intros.
+    destruct (In_split a l') as (l'1,(l'2,H6)).
+    apply (Permutation_in a H).
+    subst l.
+    apply in_or_app; right; red; auto.
+    apply perm_trans with (l'1++l'2).
+    apply (H0 _ _ _ _ _ H3 H6).
+    apply (H2 _ _ _ _ _ H6 H4).
+    Qed.
+
+    Theorem Permutation_cons_inv : 
+       forall l l' a, Permutation (a::l) (a::l') -> Permutation l l'.
+    Proof.
+    intros; exact (Permutation_app_inv (@nil _) l (@nil _) l' a H). 
+    Qed.
+
+    Theorem Permutation_cons_app_inv :
+       forall l l1 l2 a, Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2).
+    Proof.
+    intros; exact (Permutation_app_inv (@nil _) l l1 l2 a H). 
+    Qed.
+    
+    Theorem Permutation_app_inv_l : 
+        forall l l1 l2, Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2.
+    Proof.    
+    induction l; simpl; auto.
+    intros.
+    apply IHl.
+    apply Permutation_cons_inv with a; auto.
+    Qed.
+
+    Theorem Permutation_app_inv_r : 
+       forall l l1 l2, Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2.
+    Proof.
+    induction l.
+    intros l1 l2; do 2 rewrite <- app_nil_end; auto.
+    intros.
+    apply IHl.
+    apply Permutation_app_inv with a; auto.
+    Qed.
+
+  End Permutation.
+
+
+  (***********************************)
+  (** ** Decidable equality on lists *)
+  (***********************************)
+
+  Hypotheses eqA_dec : forall (x y : A), {x = y}+{x <> y}.
+
+  Lemma list_eq_dec :
+    forall l l':list A, {l = l'} + {l <> l'}.
+  Proof.
+    induction l as [| x l IHl]; destruct l' as [| y l'].
+    left; trivial.
+    right; apply nil_cons. 
+    right; unfold not; intro HF; apply (nil_cons (sym_eq HF)).
+    destruct (eqA_dec x y) as [xeqy|xneqy]; destruct (IHl l') as [leql'|lneql']; 
+      try (right; unfold not; intro HF; injection HF; intros; contradiction).
+    rewrite xeqy; rewrite leql'; left; trivial.
+  Qed.
+
+
+End ListOps.
+
+
+(***************************************************)
+(** * Applying functions to the elements of a list *)
+(***************************************************)
+
+(************)
+(** ** Map  *)
+(************)
 
-Lemma map_rev : forall l, map (rev l) = rev (map l).
-Proof. 
-induction l; simpl; auto.
-rewrite map_app.
-rewrite IHl; auto.
-Qed.
+Section Map.
+  Variables A B : Type.
+  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.
+  
+  Lemma in_map :
+    forall (l:list A) (x:A), In x l -> In (f x) (map l).
+  Proof. 
+    induction l as [| a l IHl]; simpl in |- *;
+      [ auto
+	| destruct 1; [ left; apply f_equal with (f := f); assumption | auto ] ].
+  Qed.
+  
+  Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l.
+  Proof.
+    induction l; firstorder (subst; auto).
+  Qed.
+
+  Lemma map_length : forall l, length (map l) = length l.
+  Proof.
+    induction l; simpl; auto.
+  Qed.
+
+  Lemma map_nth : forall l d n, 
+    nth n (map l) (f d) = f (nth n l d).
+  Proof.
+    induction l; simpl map; destruct n; firstorder.
+  Qed.
+  
+  Lemma map_app : forall l l',  
+    map (l++l') = (map l)++(map l').
+  Proof. 
+    induction l; simpl; auto.
+    intros; rewrite IHl; auto.
+  Qed.
+  
+  Lemma map_rev : forall l, map (rev l) = rev (map l).
+  Proof. 
+    induction l; simpl; auto.
+    rewrite map_app.
+    rewrite IHl; auto.
+  Qed.
+
+  Hint Constructors Permutation.
+
+  Lemma Permutation_map : 
+    forall l l', Permutation l l' -> Permutation (map l) (map l').
+  Proof. 
+  induction 1; simpl; auto; eauto.
+  Qed.
+
+  (** [flat_map] *)
+
+  Fixpoint flat_map (f:A -> list B) (l:list A) {struct l} : 
+    list B :=
+    match l with
+      | nil => nil
+      | cons x t => (f x)++(flat_map f t)
+    end.
+  
+  Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B),
+    In y (flat_map f l) <-> exists x, In x l /\ In y (f x). 
+  Proof.
+    induction l; simpl; split; intros.
+    contradiction.
+    destruct H as (x,(H,_)); contradiction.
+    destruct (in_app_or _ _ _ H).
+    exists a; auto.
+    destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)).
+    exists x; auto.
+    apply in_or_app.
+    destruct H as (x,(H0,H1)); destruct H0.
+    subst; auto.
+    right; destruct (IHl y) as (_,H2); apply H2.
+    exists x; auto.
+  Qed.
 
 End Map. 
 
-Lemma map_map : forall (A B C:Set)(f:A->B)(g:B->C) l, 
+Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l, 
   map g (map f l) = map (fun x => g (f x)) l.
 Proof.
-induction l; simpl; auto.
-rewrite IHl; auto.
+  induction l; simpl; auto.
+  rewrite IHl; auto.
 Qed.
 
 Lemma map_ext : 
- forall (A B : Set)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l.
-Proof.
-induction l; simpl; auto.
-rewrite H; rewrite IHl; auto.
-Qed.
-
-(********************************************)
-(** Operations on lists of pairs or lists of lists *)
-(********************************************)
-
-Section ListPairs.
-Variable A B : Set.
-
-(** [split] derives two lists from a list of pairs *)
-
-Fixpoint split  (l:list (A*B)) { struct l }: list A * list B :=
-  match l with
-    | nil => (nil, nil)
-    | (x,y) :: tl => let (g,d) := split tl in (x::g, y::d)
-  end.
-
-Lemma in_split_l : forall (l:list (A*B))(p:A*B), 
-  In p l -> In (fst p) (fst (split l)). 
-Proof.
-induction l; simpl; intros; auto.
-destruct p; destruct a; destruct (split l); simpl in *.
-destruct H.
-injection H; auto.
-right; apply (IHl (a0,b) H).
-Qed.
-
-Lemma in_split_r : forall (l:list (A*B))(p:A*B), 
-  In p l -> In (snd p) (snd (split l)). 
-Proof.
-induction l; simpl; intros; auto.
-destruct p; destruct a; destruct (split l); simpl in *.
-destruct H.
-injection H; auto.
-right; apply (IHl (a0,b) H).
-Qed.
-
-Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), 
- nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)).
-Proof.
-induction l.
-destruct n; destruct d; simpl; auto.
-destruct n; destruct d; simpl; auto.
-destruct a; destruct (split l); simpl; auto.
-destruct a; destruct (split l); simpl in *; auto.
-rewrite IHl; simpl; auto.
-Qed.
-
-Lemma split_lenght_l : forall (l:list (A*B)),
-  length (fst (split l)) = length l. 
-Proof.
-induction l; simpl; auto.
-destruct a; destruct (split l); simpl; auto.
-Qed.
-
-Lemma split_lenght_r : forall (l:list (A*B)),
-  length (snd (split l)) = length l. 
-Proof.
-induction l; simpl; auto.
-destruct a; destruct (split l); simpl; auto.
-Qed.
-
-(** [combine] is the opposite of [split]. 
-    Lists given to [combine] are meant to be of same length. 
-    If not, [combine] stops on the shorter list *)
-
-Fixpoint combine (l : list A) (l' : list B){struct l} : list (A*B) :=
-  match l,l' with
-    | x::tl, y::tl' => (x,y)::(combine tl tl')
-    | _, _ => nil
-  end.
-
-Lemma split_combine : forall (l: list (A*B)), 
-  let (l1,l2) := split l in combine l1 l2 = l.
-Proof.
-induction l.
-simpl; auto.
-destruct a; simpl. 
-destruct (split l); simpl in *.
-f_equal; auto.
-Qed.
-
-Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> 
- split (combine l l') = (l,l').
-Proof.
-induction l; destruct l'; simpl; intros; auto; try discriminate.
-injection H; clear H; intros.
-rewrite IHl; auto.
-Qed.
-
-Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), 
- In (x,y) (combine l l') -> In x l.
-Proof.
-induction l.
-simpl; auto.
-destruct l'; simpl; auto; intros.
-contradiction. 
-destruct H.
-injection H; auto.
-right; apply IHl with l' y; auto.
-Qed.
-
-Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), 
- In (x,y) (combine l l') -> In y l'.
-Proof.
-induction l.
-simpl; intros; contradiction.
-destruct l'; simpl; auto; intros.
-destruct H.
-injection H; auto.
-right; apply IHl with x; auto.
-Qed.
-
-Lemma combine_length : forall (l:list A)(l':list B), 
-  length (combine l l') = min (length l) (length l').
-Proof.
-induction l.
-simpl; auto.
-destruct l'; simpl; auto.
-Qed.
-
-Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), 
- length l = length l' -> 
- nth n (combine l l') (x,y) = (nth n l x, nth n l' y).
+  forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l.
 Proof.
-induction l; destruct l'; intros; try discriminate.
-destruct n; simpl; auto.
-destruct n; simpl in *; auto.
+  induction l; simpl; auto.
+  rewrite H; rewrite IHl; auto.
 Qed.
 
-(** [flat_map] *)
-
-Fixpoint flat_map (f:A -> list B) (l:list A) {struct l} : 
- list B :=
-  match l with
-  | nil => nil
-  | cons x t => (f x)++(flat_map f t)
-  end.
-
-Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B),
- In y (flat_map f l) <-> exists x, In x l /\ In y (f x). 
-Proof.
-induction l; simpl; split; intros.
-contradiction.
-destruct H as (x,(H,_)); contradiction.
-destruct (in_app_or _ _ _ H).
-exists a; auto.
-destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)).
-exists x; auto.
-apply in_or_app.
-destruct H as (x,(H0,H1)); destruct H0.
-subst; auto.
-right; destruct (IHl y) as (_,H2); apply H2.
-exists x; auto.
-Qed.
-
-(** [list_prod] has the same signature as [combine], but unlike
-   [combine], it adds every possible pairs, not only those at the 
-   same position. *)
-
-Fixpoint list_prod (l:list A) (l':list B) {struct l} :
- list (A * B) :=
-  match l with
-  | nil => nil
-  | cons x t => (map (fun y:B => (x, y)) l')++(list_prod t l')
-  end.
-
-Lemma in_prod_aux :
- forall (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 (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.
-
-Lemma in_prod_iff : 
- forall (l:list A)(l':list B)(x:A)(y:B), 
-  In (x,y) (list_prod l l') <-> In x l /\ In y l'.
-Proof.
-split; [ | intros; apply in_prod; intuition ].
-induction l; simpl; intros.
-intuition.
-destruct (in_app_or _ _ _ H); clear H.
-destruct (in_map_iff (fun y : B => (a, y)) l' (x,y)) as (H1,_).
-destruct (H1 H0) as (z,(H2,H3)); clear H0 H1.
-injection H2; clear H2; intros; subst; intuition.
-intuition.
-Qed. 
-
-Lemma prod_length : forall (l:list A)(l':list B), 
-  length (list_prod l l') = (length l) * (length l').
-Proof.
-induction l; simpl; auto.
-intros.
-rewrite app_length.
-rewrite map_length.
-auto.
-Qed.
-
-End ListPairs.
-
-(** [(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.
-
-Lemma fold_left_app : forall (l l':list B)(i:A), 
- fold_left (l++l') i = fold_left l' (fold_left l i).
-Proof.
-induction l. 
-simpl; auto.
-intros.
-simpl.
-auto.
-Qed.
+  Variables A B : Type.
+  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.
+  
+  Lemma fold_left_app : forall (l l':list B)(i:A), 
+    fold_left (l++l') i = fold_left l' (fold_left l i).
+  Proof.
+    induction l. 
+    simpl; auto.
+    intros.
+    simpl.
+    auto.
+  Qed.
 
 End Fold_Left_Recursor.
 
 Lemma fold_left_length : 
- forall (A:Set)(l:list A), fold_left (fun x _ => S x) l 0 = length l.
+  forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l.
 Proof.
-intro A.
-cut (forall (l:list A) n, fold_left (fun x _ => S x) l n = n + length l).
-intros.
-exact (H l 0).
-induction l; simpl; auto.
-intros; rewrite IHl.
-simpl; auto with arith.
+  intro A.
+  cut (forall (l:list A) n, fold_left (fun x _ => S x) l n = n + length l).
+  intros.
+  exact (H l 0).
+  induction l; simpl; auto.
+  intros; rewrite IHl.
+  simpl; auto with arith.
 Qed.
 
 (************************************)
@@ -1082,210 +1129,651 @@ Qed.
 (************************************)
 
 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.
+  Variables A B : Type.
+  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.
 
-Lemma fold_right_app : forall (A B:Set)(f:A->B->B) l l' i, 
-  fold_right f i (l++l') = fold_right f (fold_right f i l') l.
-Proof.
-induction l.
-simpl; auto.
-simpl; intros.
-f_equal; auto.
-Qed.
-
-Lemma fold_left_rev_right : forall (A B:Set)(f:A->B->B) l i, 
-  fold_right f i (rev l) = fold_left (fun x y => f y x) l i.
-Proof.
-induction l.
-simpl; auto.
-intros.
-simpl.
-rewrite fold_right_app; simpl; auto.
-Qed.
-
-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.
-
-(********************************)
-(** Boolean operations over lists *)
-(********************************)
-
-Section Bool. 
-Variable A : Set.
-Variable f : A -> bool.
-
-(** find whether a boolean function can be satisfied by an 
-     elements of the list. *)
-
-Fixpoint existsb (l:list A) {struct l}: bool := 
- match l with 
-    | nil => false
-    | a::l => f a || existsb l
- end.
-
-Lemma existsb_exists : 
- forall l, existsb l = true <-> exists x, In x l /\ f x = true.
-Proof.
-induction l; simpl; intuition.
-inversion H.
-firstorder.
-destruct (orb_prop _ _ H1); firstorder.
-firstorder.
-subst.
-rewrite H2; auto.
-Qed.
-
-Lemma existsb_nth : forall l n d, n < length l ->
-  existsb l = false -> f (nth n l d) = false.
-Proof.
-induction l.
-inversion 1.
-simpl; intros.
-destruct (orb_false_elim _ _ H0); clear H0; auto.
-destruct n ; auto. 
-rewrite IHl; auto with arith.
-Qed.
-
-(** find whether a boolean function is satisfied by 
-  all the elements of a list. *)
-
-Fixpoint forallb (l:list A) {struct l} : bool := 
- match l with 
-    | nil => true
-    | a::l => f a && forallb l
- end.
-
-Lemma forallb_forall : 
- forall l, forallb l = true <-> (forall x, In x l -> f x = true).
-Proof.
-induction l; simpl; intuition.
-destruct (andb_prop _ _ H1).
-congruence.
-destruct (andb_prop _ _ H1); auto.
-assert (forallb l = true).
-apply H0; intuition.
-rewrite H1; auto. 
-Qed.
-
-(** [filter] *)
-
-Fixpoint filter (l:list A) : list A := 
- match l with 
-  | nil => nil
-  | x :: l => if f x then x::(filter l) else filter l
- end.
+  Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i, 
+    fold_right f i (l++l') = fold_right f (fold_right f i l') l.
+  Proof.
+    induction l.
+    simpl; auto.
+    simpl; intros.
+    f_equal; auto.
+  Qed.
+
+  Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i, 
+    fold_right f i (rev l) = fold_left (fun x y => f y x) l i.
+  Proof.
+    induction l.
+    simpl; auto.
+    intros.
+    simpl.
+    rewrite fold_right_app; simpl; auto.
+  Qed.
+
+  Theorem fold_symmetric :
+    forall (A:Type) (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.
+
+
+
+  (** [(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:Type)(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.
+
+
+  (*************************************)
+  (** ** Boolean operations over lists *)
+  (*************************************)
+
+  Section Bool. 
+    Variable A : Type.
+    Variable f : A -> bool.
+
+  (** find whether a boolean function can be satisfied by an 
+       elements of the list. *)
+
+    Fixpoint existsb (l:list A) {struct l}: bool := 
+      match l with 
+	| nil => false
+	| a::l => f a || existsb l
+      end.
+
+    Lemma existsb_exists : 
+      forall l, existsb l = true <-> exists x, In x l /\ f x = true.
+    Proof.
+      induction l; simpl; intuition.
+      inversion H.
+      firstorder.
+      destruct (orb_prop _ _ H1); firstorder.
+      firstorder.
+      subst.
+      rewrite H2; auto.
+    Qed.
+
+    Lemma existsb_nth : forall l n d, n < length l ->
+      existsb l = false -> f (nth n l d) = false.
+    Proof.
+      induction l.
+      inversion 1.
+      simpl; intros.
+      destruct (orb_false_elim _ _ H0); clear H0; auto.
+      destruct n ; auto. 
+      rewrite IHl; auto with arith.
+    Qed.
+
+  (** find whether a boolean function is satisfied by 
+    all the elements of a list. *)
+
+    Fixpoint forallb (l:list A) {struct l} : bool := 
+      match l with 
+	| nil => true
+	| a::l => f a && forallb l
+      end.
+
+    Lemma forallb_forall : 
+      forall l, forallb l = true <-> (forall x, In x l -> f x = true).
+    Proof.
+      induction l; simpl; intuition.
+      destruct (andb_prop _ _ H1).
+      congruence.
+      destruct (andb_prop _ _ H1); auto.
+      assert (forallb l = true).
+      apply H0; intuition.
+      rewrite H1; auto. 
+    Qed.
+
+  (** [filter] *)
+
+    Fixpoint filter (l:list A) : list A := 
+      match l with 
+	| nil => nil
+	| x :: l => if f x then x::(filter l) else filter l
+      end.
+
+    Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true.
+    Proof.
+      induction l; simpl.
+      intuition.
+      intros.
+      case_eq (f a); intros; simpl; intuition congruence.
+    Qed.
+
+  (** [find] *)
+
+    Fixpoint find (l:list A) : option A :=
+      match l with
+	| nil => None
+	| x :: tl => if f x then Some x else find tl
+      end.
+
+  (** [partition] *)
+
+    Fixpoint partition (l:list A) {struct l} : list A * list A := 
+      match l with
+	| nil => (nil, nil)
+	| x :: tl => let (g,d) := partition tl in 
+	  if f x then (x::g,d) else (g,x::d)
+      end.
+
+  End Bool.
+
+
+
+
+  (******************************************************)
+  (** ** Operations on lists of pairs or lists of lists *)
+  (******************************************************)
+
+  Section ListPairs.
+    Variables A B : Type.
+    
+  (** [split] derives two lists from a list of pairs *)
+
+    Fixpoint split  (l:list (A*B)) { struct l }: list A * list B :=
+      match l with
+	| nil => (nil, nil)
+	| (x,y) :: tl => let (g,d) := split tl in (x::g, y::d)
+      end.
+
+    Lemma in_split_l : forall (l:list (A*B))(p:A*B), 
+      In p l -> In (fst p) (fst (split l)). 
+    Proof.
+      induction l; simpl; intros; auto.
+      destruct p; destruct a; destruct (split l); simpl in *.
+      destruct H.
+      injection H; auto.
+      right; apply (IHl (a0,b) H).
+    Qed.
+
+    Lemma in_split_r : forall (l:list (A*B))(p:A*B), 
+      In p l -> In (snd p) (snd (split l)). 
+    Proof.
+      induction l; simpl; intros; auto.
+      destruct p; destruct a; destruct (split l); simpl in *.
+      destruct H.
+      injection H; auto.
+      right; apply (IHl (a0,b) H).
+    Qed.
+
+    Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), 
+      nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)).
+    Proof.
+      induction l.
+      destruct n; destruct d; simpl; auto.
+      destruct n; destruct d; simpl; auto.
+      destruct a; destruct (split l); simpl; auto.
+      destruct a; destruct (split l); simpl in *; auto.
+      rewrite IHl; simpl; auto.
+    Qed.
+
+    Lemma split_lenght_l : forall (l:list (A*B)),
+      length (fst (split l)) = length l. 
+    Proof.
+      induction l; simpl; auto.
+      destruct a; destruct (split l); simpl; auto.
+    Qed.
+
+    Lemma split_lenght_r : forall (l:list (A*B)),
+      length (snd (split l)) = length l. 
+    Proof.
+      induction l; simpl; auto.
+      destruct a; destruct (split l); simpl; auto.
+    Qed.
+
+  (** [combine] is the opposite of [split]. 
+      Lists given to [combine] are meant to be of same length. 
+      If not, [combine] stops on the shorter list *)
+
+    Fixpoint combine (l : list A) (l' : list B){struct l} : list (A*B) :=
+      match l,l' with
+	| x::tl, y::tl' => (x,y)::(combine tl tl')
+	| _, _ => nil
+      end.
+
+    Lemma split_combine : forall (l: list (A*B)), 
+      let (l1,l2) := split l in combine l1 l2 = l.
+    Proof.
+      induction l.
+      simpl; auto.
+      destruct a; simpl. 
+      destruct (split l); simpl in *.
+      f_equal; auto.
+    Qed.
+
+    Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> 
+      split (combine l l') = (l,l').
+    Proof.
+      induction l; destruct l'; simpl; intros; auto; try discriminate.
+      injection H; clear H; intros.
+      rewrite IHl; auto.
+    Qed.
+
+    Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), 
+      In (x,y) (combine l l') -> In x l.
+    Proof.
+      induction l.
+      simpl; auto.
+      destruct l'; simpl; auto; intros.
+      contradiction. 
+      destruct H.
+      injection H; auto.
+      right; apply IHl with l' y; auto.
+    Qed.
+
+    Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), 
+      In (x,y) (combine l l') -> In y l'.
+    Proof.
+      induction l.
+      simpl; intros; contradiction.
+      destruct l'; simpl; auto; intros.
+      destruct H.
+      injection H; auto.
+      right; apply IHl with x; auto.
+    Qed.
+
+    Lemma combine_length : forall (l:list A)(l':list B), 
+      length (combine l l') = min (length l) (length l').
+    Proof.
+      induction l.
+      simpl; auto.
+      destruct l'; simpl; auto.
+    Qed.
+
+    Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), 
+      length l = length l' -> 
+      nth n (combine l l') (x,y) = (nth n l x, nth n l' y).
+    Proof.
+      induction l; destruct l'; intros; try discriminate.
+      destruct n; simpl; auto.
+      destruct n; simpl in *; auto.
+    Qed.
+
+  (** [list_prod] has the same signature as [combine], but unlike
+     [combine], it adds every possible pairs, not only those at the 
+     same position. *)
+
+    Fixpoint list_prod (l:list A) (l':list B) {struct l} :
+      list (A * B) :=
+      match l with
+	| nil => nil
+	| cons x t => (map (fun y:B => (x, y)) l')++(list_prod t l')
+      end.
+
+    Lemma in_prod_aux :
+      forall (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 (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.
+
+    Lemma in_prod_iff : 
+      forall (l:list A)(l':list B)(x:A)(y:B), 
+	In (x,y) (list_prod l l') <-> In x l /\ In y l'.
+    Proof.
+      split; [ | intros; apply in_prod; intuition ].
+      induction l; simpl; intros.
+      intuition.
+      destruct (in_app_or _ _ _ H); clear H.
+      destruct (in_map_iff (fun y : B => (a, y)) l' (x,y)) as (H1,_).
+      destruct (H1 H0) as (z,(H2,H3)); clear H0 H1.
+      injection H2; clear H2; intros; subst; intuition.
+      intuition.
+    Qed. 
+
+    Lemma prod_length : forall (l:list A)(l':list B), 
+      length (list_prod l l') = (length l) * (length l').
+    Proof.
+      induction l; simpl; auto.
+      intros.
+      rewrite app_length.
+      rewrite map_length.
+      auto.
+    Qed.
+
+  End ListPairs.
+
+
+
+
+(***************************************)
+(** * Miscelenous operations on lists  *)
+(***************************************)
 
-Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true.
-Proof.
-induction l; simpl.
-intuition.
-intros.
-case_eq (f a); intros; simpl; intuition congruence.
-Qed.
 
-(** [find] *)
 
-Fixpoint find (l:list A) : option A :=
-  match l with
-    | nil => None
-    | x :: tl => if f x then Some x else find tl
-  end.
+(******************************)
+(** ** Length order of lists  *)
+(******************************)
 
-(** [partition] *)
+Section length_order.
+  Variable A : Type.
+
+  Definition lel (l m:list A) := length l <= length m.
+
+  Variables a b : A.
+  Variables l m n : list A.
+
+  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 A, 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.
 
-Fixpoint partition (l:list A) {struct l} : list A * list A := 
-  match l with
-    | nil => (nil, nil)
-    | x :: tl => let (g,d) := partition tl in 
-      if f x then (x::g,d) else (g,x::d)
-  end.
+Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons:
+  datatypes v62.
 
-End Bool.
 
+(******************************)
+(** ** Set inclusion on list  *)
+(******************************)
 
-(*********************************)
-(** Sequence of natural numbers *)
-(*********************************)
+Section SetIncl.
+
+  Variable A : Type.
+
+  Definition incl (l m:list A) := forall a:A, In a l -> In a m.
+  Hint Unfold incl.
+  
+  Lemma incl_refl : forall l:list A, incl l l.
+  Proof. 
+    auto.
+  Qed.
+  Hint Resolve incl_refl.
+  
+  Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m).
+  Proof. 
+    auto with datatypes.
+  Qed.
+  Hint Immediate incl_tl.
+
+  Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n.
+  Proof. 
+    auto.
+  Qed.
+  
+  Lemma incl_appl : forall l m n:list A, incl l n -> incl l (n ++ m).
+  Proof. 
+    auto with datatypes.
+  Qed.
+  Hint Immediate incl_appl.
+  
+  Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n).
+  Proof. 
+    auto with datatypes.
+  Qed.
+  Hint Immediate incl_appr.
+  
+  Lemma incl_cons :
+    forall (a:A) (l m:list A), 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 A, 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.
+  
+End SetIncl.
 
-(** [seq] computes the sequence of [len] contiguous integers 
-    that starts at [start]. For instance, [seq 2 3] is [2::3::4::nil]. *)
+Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons
+  incl_app: datatypes v62.
 
-Fixpoint seq (start len:nat) {struct len} : list nat := 
- match len with 
-  | 0 => nil
-  | S len => start :: seq (S start) len
- end. 
 
-Lemma seq_length : forall len start, length (seq start len) = len.
-Proof.
-induction len; simpl; auto.
-Qed.
+(**************************************)
+(* ** Cutting a list at some position *)
+(**************************************)
+
+Section Cutting.
+
+  Variable A : Type.
+
+  Fixpoint firstn (n:nat)(l:list A) {struct n} : list A := 
+    match n with 
+      | 0 => nil 
+      | S n => match l with  
+		 | nil => nil 
+		 | a::l => a::(firstn n l)
+	       end
+    end.
+  
+  Fixpoint skipn (n:nat)(l:list A) { struct n } : list A := 
+    match n with 
+      | 0 => l 
+      | S n => match l with 
+		 | nil => nil 
+		 | a::l => skipn n l
+	       end
+    end.
+  
+  Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l.
+  Proof.
+    induction n.
+    simpl; auto.
+    destruct l; simpl; auto.
+    f_equal; auto.
+  Qed.
+
+End Cutting.
 
-Lemma seq_nth : forall len start n d, 
-  n < len -> nth n (seq start len) d = start+n.
-Proof.
-induction len; intros.
-inversion H.
-simpl seq.
-destruct n; simpl.
-auto with arith.
-rewrite IHlen;simpl; auto with arith.
-Qed.
 
-Lemma seq_shift : forall len start,
- map S (seq start len) = seq (S start) len.
-Proof. 
-induction len; simpl; auto.
-intros.
-rewrite IHlen.
-auto with arith.
-Qed.
+(********************************)
+(** ** Lists without redundancy *)
+(********************************)
 
-End Functions_on_lists.
+Section ReDun.
+
+  Variable A : Type.
+  
+  Inductive NoDup : list A -> Prop := 
+    | NoDup_nil : NoDup nil 
+    | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l). 
+
+  Lemma NoDup_remove_1 : forall l l' a, NoDup (l++a::l') -> NoDup (l++l').
+  Proof.
+  induction l; simpl.
+  inversion_clear 1; auto.
+  inversion_clear 1.
+  constructor.
+  swap H0.
+  apply in_or_app; destruct (in_app_or _ _ _ H); simpl; tauto.
+  apply IHl with a0; auto.
+  Qed.
+
+  Lemma NoDup_remove_2 : forall l l' a, NoDup (l++a::l') -> ~In a (l++l').
+  Proof.
+  induction l; simpl.
+  inversion_clear 1; auto.
+  inversion_clear 1.
+  swap H0.
+  destruct H.
+  subst a0.
+  apply in_or_app; right; red; auto.
+  destruct (IHl _ _ H1); auto.
+  Qed.
+
+  Lemma NoDup_Permutation : forall l l', 
+    NoDup l -> NoDup l' -> (forall x, In x l <-> In x l') -> Permutation l l'.
+  Proof.
+  induction l. 
+  destruct l'; simpl; intros.
+  apply perm_nil.
+  destruct (H1 a) as (_,H2); destruct H2; auto.
+  intros.
+  destruct (In_split a l') as (l'1,(l'2,H2)).
+  destruct (H1 a) as (H2,H3); simpl in *; auto.
+  subst l'.
+  apply Permutation_cons_app.
+  inversion_clear H.
+  apply IHl; auto.
+  apply NoDup_remove_1 with a; auto.
+  intro x; split; intros.
+  assert (In x (l'1++a::l'2)).
+   destruct (H1 x); simpl in *; auto.
+  apply in_or_app; destruct (in_app_or _ _ _ H4); auto.
+  destruct H5; auto.
+  subst x; destruct H2; auto.
+  assert (In x (l'1++a::l'2)).
+    apply in_or_app; destruct (in_app_or _ _ _ H); simpl; auto.
+  destruct (H1 x) as (_,H5); destruct H5; auto. 
+  subst x.
+  destruct (NoDup_remove_2 _ _ _ H0 H).
+  Qed.
+
+End ReDun.
+
+
+(***********************************)
+(** ** Sequence of natural numbers *)
+(***********************************)
+
+Section NatSeq.
+
+  (** [seq] computes the sequence of [len] contiguous integers 
+      that starts at [start]. For instance, [seq 2 3] is [2::3::4::nil]. *)
+  
+  Fixpoint seq (start len:nat) {struct len} : list nat := 
+    match len with 
+      | 0 => nil
+      | S len => start :: seq (S start) len
+    end. 
+  
+  Lemma seq_length : forall len start, length (seq start len) = len.
+  Proof.
+    induction len; simpl; auto.
+  Qed.
+  
+  Lemma seq_nth : forall len start n d, 
+    n < len -> nth n (seq start len) d = start+n.
+  Proof.
+    induction len; intros.
+    inversion H.
+    simpl seq.
+    destruct n; simpl.
+    auto with arith.
+    rewrite IHlen;simpl; auto with arith.
+  Qed.
+
+  Lemma seq_shift : forall len start,
+    map S (seq start len) = seq (S start) len.
+  Proof. 
+    induction len; simpl; auto.
+    intros.
+    rewrite IHlen.
+    auto with arith.
+  Qed.
+
+End NatSeq.
+
+
+
+  (** * Exporting hints and tactics *)
 
 
 Hint Rewrite 
- rev_involutive (* rev (rev l) = l *)
- rev_unit (* rev (l ++ a :: nil) = a :: rev l *)
- map_nth (* nth n (map f l) (f d) = f (nth n l d) *)
- map_length (* length (map f l) = length l *)
- seq_length (* length (seq start len) = len *)
- app_length (* length (l ++ l') = length l + length l' *)
- rev_length (* length (rev l) = length l *)
- : list.
+  rev_involutive (* rev (rev l) = l *)
+  rev_unit (* rev (l ++ a :: nil) = a :: rev l *)
+  map_nth (* nth n (map f l) (f d) = f (nth n l d) *)
+  map_length (* length (map f l) = length l *)
+  seq_length (* length (seq start len) = len *)
+  app_length (* length (l ++ l') = length l + length l' *)
+  rev_length (* length (rev l) = length l *)
+  : list.
 
 Hint Rewrite <- 
- app_nil_end (* l = l ++ nil *)
- : list.
+  app_nil_end (* l = l ++ nil *)
+  : list.
 
 Ltac simpl_list := autorewrite with list.
 Ltac ssimpl_list := autorewrite with list using simpl.
diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v
index 811dcab4..eb40594b 100644
--- a/theories/Lists/SetoidList.v
+++ b/theories/Lists/SetoidList.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: SetoidList.v 8686 2006-04-06 13:25:10Z letouzey $ *)
+(* $Id: SetoidList.v 8853 2006-05-23 18:17:38Z herbelin $ *)
 
 Require Export List.
 Require Export Sorting.
@@ -80,6 +80,17 @@ Proof.
 Qed.
 Hint Resolve In_InA.
 
+Lemma InA_split : forall l x, InA x l -> 
+ exists l1, exists y, exists l2, 
+ eqA x y /\ l = l1++y::l2.
+Proof.
+induction l; inversion_clear 1.
+exists (@nil A); exists a; exists l; auto.
+destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))).
+exists (a::l1); exists y; exists l2; auto.
+split; simpl; f_equal; auto.
+Qed.
+
 (** Results concerning lists modulo [eqA] and [ltA] *)
 
 Variable ltA : A -> A -> Prop.
@@ -149,7 +160,7 @@ Proof.
  inversion_clear H0.
  constructor; auto.  
  intro.
- assert (ltA x x) by eapply SortA_InfA_InA; eauto.
+ assert (ltA x x) by (eapply SortA_InfA_InA; eauto).
  elim (ltA_not_eqA H3); auto.
 Qed.
 
@@ -228,6 +239,18 @@ Section Remove.
 
 Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.
 
+Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }.
+Proof.
+induction l.
+right; auto.
+red; inversion 1.
+destruct (eqA_dec x a).
+left; auto.
+destruct IHl.
+left; auto.
+right; red; inversion_clear 1; tauto.
+Qed.
+
 Fixpoint removeA (x : A) (l : list A){struct l} : list A :=
   match l with
     | nil => nil
@@ -290,6 +313,149 @@ inversion_clear H1; auto.
 elim H2; auto.
 Qed.
 
+Let addlistA x l l' := forall y, InA y l' <-> eqA x y \/ InA y l.
+
+Lemma removeA_add :
+  forall s s' x x', NoDupA s -> NoDupA (x' :: s') ->
+  ~ eqA x x' -> ~ InA x s -> 
+  addlistA x s (x' :: s') -> addlistA x (removeA x' s) s'.
+Proof.
+unfold addlistA; intros.
+inversion_clear H0.
+rewrite removeA_InA; auto.
+split; intros.
+destruct (eqA_dec x y); auto; intros.
+right; split; auto.
+destruct (H3 y); clear H3.
+destruct H6; intuition.
+swap H4; apply InA_eqA with y; auto.
+destruct H0.
+assert (InA y (x' :: s')) by (rewrite H3; auto).
+inversion_clear H6; auto.
+elim H1; apply eqA_trans with y; auto.
+destruct H0.
+assert (InA y (x' :: s')) by (rewrite H3; auto).
+inversion_clear H7; auto.
+elim H6; auto.
+Qed.
+
+Section Fold.
+
+Variable B:Set.
+Variable eqB:B->B->Prop.
+
+(** Two-argument functions that allow to reorder its arguments. *)
+Definition transpose (f : A -> B -> B) :=
+  forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). 
+
+(** Compatibility of a two-argument function with respect to two equalities. *)
+Definition compat_op (f : A -> B -> B) :=
+  forall (x x' : A) (y y' : B), eqA x x' -> eqB y y' -> eqB (f x y) (f x' y').
+
+(** Compatibility of a function upon natural numbers. *)
+Definition compat_nat (f : A -> nat) :=
+  forall x x' : A, eqA x x' -> f x = f x'.
+
+Variable st:Setoid_Theory _ eqB.
+Variable f:A->B->B.
+Variable Comp:compat_op f.
+Variable Ass:transpose f.
+Variable i:B.
+
+Lemma removeA_fold_right_0 :
+  forall s x, ~InA x s ->
+  eqB (fold_right f i s) (fold_right f i (removeA x s)).
+Proof.
+ simple induction s; simpl; intros.
+ refl_st.
+ destruct (eqA_dec x a); simpl; intros.
+ absurd_hyp e; auto.
+ apply Comp; auto. 
+Qed.   
+
+Lemma removeA_fold_right :
+  forall s x, NoDupA s -> InA x s ->
+  eqB (fold_right f i s) (f x (fold_right f i (removeA x s))).
+Proof.
+ simple induction s; simpl.  
+ inversion_clear 2.
+ intros.
+ inversion_clear H0.
+ destruct (eqA_dec x a); simpl; intros.
+ apply Comp; auto. 
+ apply removeA_fold_right_0; auto.
+ swap H2; apply InA_eqA with x; auto.
+ inversion_clear H1. 
+ destruct n; auto.
+ trans_st (f a (f x (fold_right f i (removeA x l)))).
+Qed.   
+
+Lemma fold_right_equal :
+  forall s s', NoDupA s -> NoDupA s' ->
+  eqlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
+Proof.
+ simple induction s.
+ destruct s'; simpl.
+ intros; refl_st; auto.
+ unfold eqlistA; intros.
+ destruct (H1 a).
+ assert (X : InA a nil); auto; inversion X.
+ intros x l Hrec s' N N' E; simpl in *.
+ trans_st (f x (fold_right f i (removeA x s'))).
+ apply Comp; auto.
+ apply Hrec; auto.
+ inversion N; auto.
+ apply removeA_NoDupA; auto; apply eqA_trans.
+ apply removeA_eqlistA; auto.
+ inversion_clear N; auto.
+ sym_st.
+ apply removeA_fold_right; auto.
+ unfold eqlistA in E.
+ rewrite <- E; auto.
+Qed.
+
+Lemma fold_right_add :
+  forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s ->
+  addlistA x s s' -> eqB (fold_right f i s') (f x (fold_right f i s)).
+Proof.   
+ simple induction s'.
+ unfold addlistA; intros.
+ destruct (H2 x); clear H2.
+ assert (X : InA x nil); auto; inversion X.
+ intros x' l' Hrec s x N N' IN EQ; simpl.
+ (* if x=x' *)
+ destruct (eqA_dec x x').
+ apply Comp; auto.
+ apply fold_right_equal; auto.
+ inversion_clear N'; trivial.
+ unfold eqlistA; unfold addlistA in EQ; intros.
+ destruct (EQ x0); clear EQ.
+ split; intros.
+ destruct H; auto.
+ inversion_clear N'.
+ destruct H2; apply InA_eqA with x0; auto.
+ apply eqA_trans with x; auto.
+ assert (X:InA x0 (x' :: l')); auto; inversion_clear X; auto.
+ destruct IN; apply InA_eqA with x0; auto.
+ apply eqA_trans with x'; auto.
+ (* else x<>x' *)   
+ trans_st (f x' (f x (fold_right f i (removeA x' s)))).
+ apply Comp; auto.
+ apply Hrec; auto.
+ apply removeA_NoDupA; auto; apply eqA_trans.
+ inversion_clear N'; auto.
+ rewrite removeA_InA; intuition.
+ apply removeA_add; auto.
+ trans_st (f x (f x' (fold_right f i (removeA x' s)))).
+ apply Comp; auto.
+ sym_st.
+ apply removeA_fold_right; auto.
+ destruct (EQ x'). 
+ destruct H; auto; destruct n; auto.
+Qed.
+
+End Fold.
+
 End Remove.
 
 End Type_with_equality.
@@ -298,3 +464,52 @@ Hint Constructors InA.
 Hint Constructors NoDupA. 
 Hint Constructors sort.
 Hint Constructors lelistA.
+
+Section Find. 
+Variable A B : Set. 
+Variable eqA : A -> A -> Prop. 
+Hypothesis eqA_sym : forall x y, eqA x y -> eqA y x.
+Hypothesis eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z.
+Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.
+
+Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B := 
+ match l with  
+  | nil => None 
+  | (a,b)::l => if f a then Some b else findA f l
+ end.
+
+Lemma findA_NoDupA : 
+ forall l a b, 
+ NoDupA (fun p p' => eqA (fst p) (fst p')) l -> 
+ (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <->
+  findA (fun a' => if eqA_dec a a' then true else false) l = Some b).
+Proof.
+induction l; simpl; intros.
+split; intros; try discriminate.
+inversion H0.
+destruct a as (a',b'); rename a0 into a.
+inversion_clear H.
+split; intros.
+inversion_clear H.
+simpl in *; destruct H2; subst b'.
+destruct (eqA_dec a a'); intuition.
+destruct (eqA_dec a a'); simpl.
+destruct H0.
+generalize e H2 eqA_trans eqA_sym; clear.
+induction l.
+inversion 2.
+inversion_clear 2; intros; auto.
+destruct a0.
+compute in H; destruct H.
+subst b.
+constructor 1; auto.
+simpl.
+apply eqA_trans with a; auto.
+rewrite <- IHl; auto.
+destruct (eqA_dec a a'); simpl in *.
+inversion H; clear H; intros; subst b'; auto.
+constructor 2.
+rewrite IHl; auto.
+Qed.
+
+End Find. 
diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v
index 19f97aec..2bfb70fe 100644
--- a/theories/Lists/TheoryList.v
+++ b/theories/Lists/TheoryList.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: TheoryList.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id: TheoryList.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
 (** Some programs and results about lists following CAML Manual *)
 
@@ -14,7 +14,7 @@ Require Export List.
 Set Implicit Arguments.
 Section Lists.
 
-Variable A : Set.
+Variable A : Type.
 
 (**********************)
 (** The null function *)
@@ -325,7 +325,7 @@ Realizer find.
 *)
 Qed.
 
-Variable B : Set.
+Variable B : Type.
 Variable T : A -> B -> Prop.
 
 Variable TS_dec : forall a:A, {c : B | T a c} + {P a}.
@@ -358,7 +358,7 @@ End Find_sec.
 
 Section Assoc_sec.
 
-Variable B : Set.
+Variable B : Type.
 Fixpoint assoc (a:A) (l:list (A * B)) {struct l} : 
  Exc B :=
   match l with
diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v
index bc892ca9..e0be9ed3 100644
--- a/theories/Logic/ChoiceFacts.v
+++ b/theories/Logic/ChoiceFacts.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,155 +7,453 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ChoiceFacts.v 8132 2006-03-05 10:59:47Z herbelin $ i*)
+(*i $Id: ChoiceFacts.v 8892 2006-06-04 17:59:53Z herbelin $ 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) *)
+(** ** Some facts and definitions concerning choice and description in
+       intuitionistic logic.
 
-(** 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 *)
+We investigate the relations between the following choice and
+description principles
+
+- AC_rel  = relational form of the (non extensional) axiom of choice
+            (a "set-theoretic" axiom of choice)
+- AC_fun  = functional form of the (non extensional) axiom of choice
+            (a "type-theoretic" axiom of choice)
+- AC!     = functional relation reification
+            (known as axiom of unique choice in topos theory,
+             sometimes called principle of definite description in 
+             the context of constructive type theory)
+
+- GAC_rel = guarded relational form of the (non extensional) axiom of choice
+- GAC_fun = guarded functional form of the (non extensional) axiom of choice
+- GAC!    = guarded functional relation reification
+
+- OAC_rel = "omniscient" relational form of the (non extensional) axiom of choice
+- OAC_fun = "omniscient" functional form of the (non extensional) axiom of choice
+            (called AC* in Bell [Bell])
+- OAC!
+
+- ID_iota    = intuitionistic definite description
+- ID_epsilon = intuitionistic indefinite description
+
+- D_iota     = (weakly classical) definite description principle
+- D_epsilon  = (weakly classical) indefinite description principle
+
+- PI      = proof irrelevance
+- IGP     = independence of general premises
+            (an unconstrained generalisation of the constructive principle of
+             independence of premises)
+- Drinker = drinker's paradox (small form)
+            (called Ex in Bell [Bell])  
+
+We let also
+
+IPL_2^2 = 2nd-order impredicative, 2nd-order functional minimal predicate logic
+IPL_2   = 2nd-order impredicative minimal predicate logic
+IPL^2   = 2nd-order functional minimal predicate logic (with ex. quant.)
+
+Table of contents
+
+A. Definitions
+
+B. IPL_2^2 |- AC_rel + AC! = AC_fun
+
+C. 1. AC_rel + PI -> GAC_rel  and  PL_2 |- AC_rel + IGP -> GAC_rel and GAC_rel = OAC_rel
+
+C. 2. IPL^2 |- AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker
+
+D. Derivability of choice for decidable relations with well-ordered codomain
+
+E. Equivalence of choices on dependent or non dependent functional types
+
+F. Non contradiction of constructive descriptions wrt functional choices
+
+G. Definite description transports classical logic to the computational world
 
-Section ChoiceEquivalences.
+References:
+
+[Bell] John L. Bell, Choice principles in intuitionistic set theory,
+unpublished.
+
+[Bell93] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic
+Type Theories, Mathematical Logic Quarterly, volume 39, 1993.
+
+[Carlstrøm05] Jesper Carlstrøm, Interpreting descriptions in
+intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005.
+*)
+
+Set Implicit Arguments.
+
+Notation Local "'inhabited' A" := A (at level 10, only parsing).
+
+(**********************************************************************)
+(** *** A. Definitions *)
+
+(** Choice, reification and description schemes *)
+
+Section ChoiceSchemes.
 
 Variables A B :Type.
 
-Definition RelationalChoice :=
-  forall (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')).
+Variables P:A->Prop.
+
+Variables R:A->B->Prop.
+
+(** **** Constructive choice and description *)
+
+(** AC_rel *)
+
+Definition RelationalChoice_on :=
+  forall R:A->B->Prop,
+  (forall x : A, exists y : B, R x y) ->
+  (exists R' : A->B->Prop, subrelation R' R /\ forall x, exists! y, R' x y).
+
+(** AC_fun *)
+
+Definition FunctionalChoice_on :=
+  forall R:A->B->Prop,
+  (forall x : A, exists y : B, R x y) ->
+  (exists f : A->B, forall x : A, R x (f x)).
+
+(** AC! or Functional Relation Reification (known as Axiom of Unique Choice
+    in topos theory; also called principle of definite description *)
+
+Definition FunctionalRelReification_on :=
+  forall R:A->B->Prop,
+  (forall x : A, exists! y : B, R x y) ->
+  (exists f : A->B, forall x : A, R x (f x)).
+
+(** ID_epsilon (constructive version of indefinite description;
+    combined with proof-irrelevance, it may be connected to
+    Carlstrøm's type theory with a constructive indefinite description
+    operator) *)
+
+Definition ConstructiveIndefiniteDescription_on :=
+  forall P:A->Prop,
+  (exists x, P x) -> { x:A | P x }.
+
+(** ID_iota (constructive version of definite description; combined
+    with proof-irrelevance, it may be connected to Carlstrøm's and
+    Stenlund's type theory with a constructive definite description
+    operator) *)
+
+Definition ConstructiveDefiniteDescription_on :=
+  forall P:A->Prop,
+  (exists! x, P x) -> { x:A | P x }.
+
+(** **** Weakly classical choice and description *)
 
-Definition FunctionalChoice :=
-  forall (R:A -> B -> Prop),
-    (forall x:A, exists y : B, R x y) ->
-     exists f : A -> B, (forall x:A, R x (f x)).
+(** GAC_rel *)
 
-Definition ParamDefiniteDescription :=
-  forall (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)).
+Definition GuardedRelationalChoice_on := 
+  forall P : A->Prop, forall R : A->B->Prop,
+  (forall x : A, P x -> exists y : B, R x y) ->
+  (exists R' : A->B->Prop, 
+     subrelation R' R /\ forall x, P x -> exists! y, R' x y).
+
+(** GAC_fun *)
+
+Definition GuardedFunctionalChoice_on := 
+  forall P : A->Prop, forall R : A->B->Prop, 
+  inhabited B ->
+  (forall x : A, P x -> exists y : B, R x y) ->
+  (exists f : A->B, forall x, P x -> R x (f x)).
+
+(** GFR_fun *)
+
+Definition GuardedFunctionalRelReification_on :=
+  forall P : A->Prop, forall R : A->B->Prop, 
+  inhabited B ->
+  (forall x : A, P x -> exists! y : B, R x y) ->
+  (exists f : A->B, forall x : A, P x -> R x (f x)).
+
+(** OAC_rel *)
+
+Definition OmniscientRelationalChoice_on := 
+  forall R : A->B->Prop,
+  exists R' : A->B->Prop, 
+    subrelation R' R /\ forall x : A, (exists y : B, R x y) -> exists! y, R' x y.
+
+(** OAC_fun *)
+
+Definition OmniscientFunctionalChoice_on := 
+  forall R : A->B->Prop, 
+  inhabited B ->
+  exists f : A->B, forall x : A, (exists y : B, R x y) -> R x (f x).
+
+(** D_epsilon *)
+
+Definition ClassicalIndefiniteDescription := 
+  forall P:A->Prop,
+  A -> { x:A | (exists x, P x) -> P x }.
+
+(** D_iota *)
+
+Definition ClassicalDefiniteDescription := 
+  forall P:A->Prop,
+  A -> { x:A | (exists! x, P x) -> P x }.
+
+End ChoiceSchemes.
+
+(** Generalized schemes *)
+
+Notation RelationalChoice :=
+  (forall A B, RelationalChoice_on A B).
+Notation FunctionalChoice :=
+  (forall A B, FunctionalChoice_on A B).
+Notation FunctionalChoiceOnInhabitedSet :=
+  (forall A B, inhabited B -> FunctionalChoice_on A B).
+Notation FunctionalRelReification :=
+  (forall A B, FunctionalRelReification_on A B).
+
+Notation GuardedRelationalChoice := 
+  (forall A B, GuardedRelationalChoice_on A B).
+Notation GuardedFunctionalChoice :=
+  (forall A B, GuardedFunctionalChoice_on A B).
+Notation GuardedFunctionalRelReification :=
+  (forall A B, GuardedFunctionalRelReification_on A B).
+
+Notation OmniscientRelationalChoice :=
+  (forall A B, OmniscientRelationalChoice_on A B).
+Notation OmniscientFunctionalChoice :=
+  (forall A B, OmniscientFunctionalChoice_on A B).
+
+Notation ConstructiveDefiniteDescription := 
+  (forall A, ConstructiveDefiniteDescription_on A).
+Notation ConstructiveIndefiniteDescription := 
+  (forall A, ConstructiveIndefiniteDescription_on A).
+
+(** Subclassical schemes *)
+
+Definition ProofIrrelevance :=
+  forall (A:Prop) (a1 a2:A), a1 = a2.
+
+Definition IndependenceOfGeneralPremises :=
+  forall (A:Type) (P:A -> Prop) (Q:Prop), 
+    inhabited A ->
+    (Q -> exists x, P x) -> exists x, Q -> P x.
+
+Definition SmallDrinker'sParadox :=
+  forall (A:Type) (P:A -> Prop), inhabited A ->
+  exists x, (exists x, P x) -> P x.
+
+(**********************************************************************)
+(** *** B. AC_rel + PDP = AC_fun
+
+   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 *)
 
 Lemma description_rel_choice_imp_funct_choice :
- ParamDefiniteDescription -> RelationalChoice -> FunctionalChoice.
-intros Descr RelCh.
-red in |- *; intros R H.
-destruct (RelCh R H) as [R' H0].
-destruct (Descr R') as [f H1].
-intro x.
-elim (H0 x); intros y [H2 [H3 H4]]; exists y; split; [ exact H3 | exact H4 ].
+  forall A B : Type,
+  FunctionalRelReification_on A B -> RelationalChoice_on A B -> FunctionalChoice_on A B.
+Proof.
+intros A B Descr RelCh R H.
+destruct (RelCh R H) as (R',(HR'R,H0)).
+destruct (Descr R') as (f,Hf).
+firstorder.
 exists f; intro x.
-elim (H0 x); intros y [H2 [H3 H4]].
-rewrite <- (H4 (f x) (H1 x)).
-exact H2.
+destruct (H0 x) as (y,(HR'xy,Huniq)).
+rewrite <- (Huniq (f x) (Hf x)).
+apply HR'R; assumption.
 Qed.
 
-Lemma funct_choice_imp_rel_choice : FunctionalChoice -> RelationalChoice.
-intros FunCh.
-red in |- *; intros R H.
-destruct (FunCh 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 ] ].
+Lemma funct_choice_imp_rel_choice : 
+  forall A B, FunctionalChoice_on A B -> RelationalChoice_on A B.
+Proof.
+intros A B FunCh R H.
+destruct (FunCh R H) as (f,H0).
+exists (fun x y => f x = y).
+split.
+  intros x y Heq; rewrite <- Heq; trivial.
+  intro x; exists (f x); split.
+    reflexivity.
+    trivial.
 Qed.
 
-Lemma funct_choice_imp_description :
- FunctionalChoice -> ParamDefiniteDescription.
-intros FunCh.
-red in |- *; intros R H.
+Lemma funct_choice_imp_description : 
+  forall A B, FunctionalChoice_on A B -> FunctionalRelReification_on A B.
+Proof.
+intros A B FunCh R H.
 destruct (FunCh R) as [f H0].
 (* 1 *)
 intro x.
-elim (H x); intros y [H0 H1].
-exists y; exact H0.
+destruct (H x) as (y,(HRxy,_)).
+exists y; exact HRxy.
 (* 2 *)
 exists f; exact H0.
 Qed.
 
 Theorem FunChoice_Equiv_RelChoice_and_ParamDefinDescr :
- FunctionalChoice <-> RelationalChoice /\ ParamDefiniteDescription.
-split.
+  forall A B, FunctionalChoice_on A B <-> 
+    RelationalChoice_on A B /\ FunctionalRelReification_on A B.
+Proof.
+intros A B; 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.
 
-End ChoiceEquivalences.
+(**********************************************************************)
+(** *** C. Connection between the guarded, non guarded and descriptive choices and *)
 
 (** 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 (A B:Type) :=
-  forall (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.
+(**********************************************************************)
+(** **** C. 1. AC_rel + PI -> GAC_rel and AC_rel + IGP -> GAC_rel and GAC_rel = OAC_rel *)
 
 Lemma rel_choice_and_proof_irrel_imp_guarded_rel_choice :
-  (forall A B, RelationalChoice A B)
-    -> ProofIrrelevance -> (forall A B, GuardedRelationalChoice A B).
+  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].
+destruct (rel_choice _ _ (fun (x:sigT P) (y:B) => R (projT1 x) y)) as (R',(HR'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'.
+exists R''; split.
+  intros x y (HPx,HR'xy).
+    change x with (projT1 (existT P x HPx)); apply HR'R; exact HR'xy.
+  intros x HPx.
+  destruct (H0 (existT P x HPx)) as (y,(HR'xy,Huniq)).
+    exists y; split. exists HPx; exact HR'xy.
+    intros y' (H'Px,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'.
+      rewrite proof_irrel with (a1 := HPx) (a2 := H'Px); exact HR'xy'.
 Qed.
 
-Definition IndependenceOfGeneralPremises :=
-  forall (A:Type) (P:A -> Prop) (Q:Prop),
-    (Q -> exists x, P x) -> exists x, Q -> P x.
-
 Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice :
- forall A B, RelationalChoice A B -> 
-   IndependenceOfGeneralPremises -> GuardedRelationalChoice A B.
-Proof.
-intros A B RelCh IndPrem.
-red in |- *; intros P R H.
-destruct (RelCh (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.
+ forall A B, inhabited B -> RelationalChoice_on A B -> 
+  IndependenceOfGeneralPremises -> GuardedRelationalChoice_on A B.
+Proof.
+intros A B Inh AC_rel IndPrem P R H.
+destruct (AC_rel (fun x y => P x -> R x y)) as (R',(HR'R,H0)).
+  intro x. apply IndPrem. exact Inh. intro Hx. 
+    apply H; assumption.
+  exists (fun x y => P x /\ R' x y).
+  firstorder.
+Qed.
+
+Lemma guarded_rel_choice_imp_rel_choice :
+ forall A B, GuardedRelationalChoice_on A B -> RelationalChoice_on A B.
+Proof.
+intros A B GAC_rel R H.
+destruct (GAC_rel (fun _ => True) R) as (R',(HR'R,H0)).
+  firstorder.
+exists R'; firstorder.
 Qed.
 
+(** OAC_rel = GAC_rel *)
+
+Lemma guarded_iff_omniscient_rel_choice :
+  GuardedRelationalChoice <-> OmniscientRelationalChoice.
+Proof.
+split.
+  intros GAC_rel A B R.
+    apply (GAC_rel A B (fun x => exists y, R x y) R); auto.
+  intros OAC_rel A B P R H.
+    destruct (OAC_rel A B R) as (f,Hf); exists f; firstorder.
+Qed.
+
+(**********************************************************************)
+(** **** C. 2. AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker *)
+
+(** AC_fun + IGP = GAC_fun *)
+ 
+Lemma guarded_fun_choice_imp_indep_of_general_premises :
+ GuardedFunctionalChoice -> IndependenceOfGeneralPremises.
+Proof.
+intros GAC_fun A P Q Inh H.
+destruct (GAC_fun unit A (fun _ => Q) (fun _ => P) Inh) as (f,Hf).
+tauto.
+exists (f tt); auto.
+Qed.
+
+Lemma guarded_fun_choice_imp_fun_choice :
+ GuardedFunctionalChoice -> FunctionalChoiceOnInhabitedSet.
+Proof.
+intros GAC_fun A B Inh R H.
+destruct (GAC_fun A B (fun _ => True) R Inh) as (f,Hf).
+firstorder.
+exists f; auto.
+Qed.
+
+Lemma fun_choice_and_indep_general_prem_imp_guarded_fun_choice :
+  FunctionalChoiceOnInhabitedSet -> IndependenceOfGeneralPremises
+  -> GuardedFunctionalChoice.
+Proof.
+intros AC_fun IndPrem A B P R Inh H.
+apply (AC_fun A B Inh (fun x y => P x -> R x y)).
+intro x; apply IndPrem; eauto.
+Qed.
+
+(** AC_fun + Drinker = OAC_fun *)
+
+(** This was already observed by Bell [Bell] *)
+
+Lemma omniscient_fun_choice_imp_small_drinker :
+  OmniscientFunctionalChoice -> SmallDrinker'sParadox.
+Proof.
+intros OAC_fun A P Inh.
+destruct (OAC_fun unit A (fun _ => P)) as (f,Hf).
+auto.
+exists (f tt); firstorder.
+Qed.
+
+Lemma omniscient_fun_choice_imp_fun_choice :
+  OmniscientFunctionalChoice -> FunctionalChoiceOnInhabitedSet.
+Proof.
+intros OAC_fun A B Inh R H.
+destruct (OAC_fun A B R Inh) as (f,Hf).
+exists f; firstorder.
+Qed.
+
+Lemma fun_choice_and_small_drinker_imp_omniscient_fun_choice :
+  FunctionalChoiceOnInhabitedSet -> SmallDrinker'sParadox 
+  -> OmniscientFunctionalChoice.
+Proof.
+intros AC_fun Drinker A B R Inh.
+destruct (AC_fun A B Inh (fun x y => (exists y, R x y) -> R x y)) as (f,Hf).
+  intro x; apply (Drinker B (R x) Inh).
+  exists f; assumption.
+Qed.
+
+(** OAC_fun = GAC_fun *)
+
+(** This is derivable from the intuitionistic equivalence between IGP and Drinker
+but we give a direct proof *)
+
+Lemma guarded_iff_omniscient_fun_choice :
+  GuardedFunctionalChoice <-> OmniscientFunctionalChoice.
+Proof.
+split.
+  intros GAC_fun A B R Inh.
+    apply (GAC_fun A B (fun x => exists y, R x y) R); auto.
+  intros OAC_fun A B P R Inh H.
+    destruct (OAC_fun A B R Inh) as (f,Hf).
+ exists f; firstorder.
+Qed.
+
+(**********************************************************************)
+(** *** D. Derivability of choice for decidable relations with well-ordered codomain *)
 
 (** Countable codomains, such as [nat], can be equipped with a
     well-order, which implies the existence of a least element on
     inhabited decidable subsets. As a consequence, the relational form of
     the axiom of choice is derivable on [nat] for decidable relations.
 
-    We show instead that definite description and the functional form
-    of the axiom of choice are equivalent on decidable relation with [nat]
-    as codomain 
+    We show instead that functional relation reification and the
+    functional form of the axiom of choice are equivalent on decidable
+    relation with [nat] as codomain 
 *)
 
 Require Import Wf_nat.
@@ -163,12 +462,11 @@ Require Import Decidable.
 Require Import Arith.
 
 Definition has_unique_least_element (A:Type) (R:A->A->Prop) (P:A->Prop) :=
-  (exists x, (P x /\ forall x', P x' -> R x x')
-      /\ forall x', P x' /\ (forall x'', P x'' -> R x' x'') -> x=x').
+  exists! x, P x /\ forall x', P x' -> R x x'.
 
 Lemma dec_inh_nat_subset_has_unique_least_element :
   forall P:nat->Prop, (forall n, P n \/ ~ P n) ->
-    (exists n, P n) -> has_unique_least_element nat le P.
+    (exists n, P n) -> has_unique_least_element le P.
 Proof.
 intros P Pdec (n0,HPn0).
 assert
@@ -194,30 +492,228 @@ assert
   assumption.
   destruct H0.
   rewrite Heqn; assumption.
-destruct (H n0) as [(n,(Hltn,(Hmin,Huniqn)))|]; [exists n | exists n0];
-  repeat split; 
+  destruct (H n0) as [(n,(Hltn,(Hmin,Huniqn)))|]; [exists n | exists n0];
+  repeat split;
   assumption || intros n' (HPn',Hminn'); apply le_antisym; auto.
 Qed.
 
-Definition FunctionalChoice_on (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 FunctionalChoice_on_rel (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)).
 
 Lemma classical_denumerable_description_imp_fun_choice : 
   forall A:Type, 
-  ParamDefiniteDescription A nat -> 
-  forall R, (forall x y, decidable (R x y)) -> FunctionalChoice_on A nat R.
+  FunctionalRelReification_on A nat -> 
+  forall R:A->nat->Prop, 
+    (forall x y, decidable (R x y)) -> FunctionalChoice_on_rel R.
 Proof.
 intros A Descr.
 red in |- *; intros R Rdec H.
 set (R':= fun x y => R x y /\ forall y', R x y' -> y <= y').
-destruct (Descr R') as [f Hf].
+destruct (Descr R') as (f,Hf).
   intro x.
   apply (dec_inh_nat_subset_has_unique_least_element (R x)). 
     apply Rdec.
     apply (H x).
 exists f.
 intros x.
-destruct (Hf x) as [Hfx _].
+destruct (Hf x) as (Hfx,_).
+assumption.
+Qed.
+
+(**********************************************************************)
+(** *** E. Choice on dependent and non dependent function types are equivalent *)
+
+(** **** E. 1. Choice on dependent and non dependent function types are equivalent *)
+
+Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) :=
+  forall R:forall x:A, B x -> Prop,
+  (forall x:A, exists y : B x, R x y) ->
+  (exists f : (forall x:A, B x), forall x:A, R x (f x)).
+
+Notation DependentFunctionalChoice := 
+  (forall A (B:A->Type), DependentFunctionalChoice_on B).
+
+(** The easy part *)
+
+Theorem dep_non_dep_functional_choice : 
+  DependentFunctionalChoice -> FunctionalChoice.
+Proof.
+intros AC_depfun A B R H.
+  destruct (AC_depfun A (fun _ => B) R H) as (f,Hf).
+  exists f; trivial.
+Qed.
+
+(** Deriving choice on product types requires some computation on
+    singleton propositional types, so we need computational
+    conjunction projections and dependent elimination of conjunction
+    and equality *)
+
+Scheme and_indd := Induction for and Sort Prop.
+Scheme eq_indd := Induction for eq Sort Prop.
+
+Definition proj1_inf (A B:Prop) (p : A/\B) :=
+  let (a,b) := p in a.
+
+Theorem non_dep_dep_functional_choice : 
+  FunctionalChoice -> DependentFunctionalChoice.
+Proof.
+intros AC_fun A B R H.
+pose (B' := { x:A & B x }). 
+pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). 
+destruct (AC_fun A B' R') as (f,Hf).
+intros x. destruct (H x) as (y,Hy).
+exists (existT (fun x => B x) x y). split; trivial.
+exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_inf (Hf x))).
+intro x; destruct (Hf x) as (Heq,HR) using and_indd.
+destruct (f x); simpl in *.
+destruct Heq using eq_indd; trivial.
+Qed.
+
+(** **** E. 2. Reification of dependent and non dependent functional relation  are equivalent *)
+
+Definition DependentFunctionalRelReification_on (A:Type) (B:A -> Type) :=
+  forall (R:forall x:A, B x -> Prop),
+  (forall x:A, exists! y : B x, R x y) ->
+  (exists f : (forall x:A, B x), forall x:A, R x (f x)).
+
+Notation DependentFunctionalRelReification :=
+  (forall A (B:A->Type), DependentFunctionalRelReification_on B).
+
+(** The easy part *)
+
+Theorem dep_non_dep_functional_rel_reification : 
+  DependentFunctionalRelReification -> FunctionalRelReification.
+Proof.
+intros DepFunReify A B R H.
+  destruct (DepFunReify A (fun _ => B) R H) as (f,Hf).
+  exists f; trivial.
+Qed.
+
+(** Deriving choice on product types requires some computation on
+    singleton propositional types, so we need computational
+    conjunction projections and dependent elimination of conjunction
+    and equality *)
+
+Theorem non_dep_dep_functional_rel_reification : 
+  FunctionalRelReification -> DependentFunctionalRelReification.
+Proof.
+intros AC_fun A B R H.
+pose (B' := { x:A & B x }). 
+pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). 
+destruct (AC_fun A B' R') as (f,Hf).
+intros x. destruct (H x) as (y,(Hy,Huni)).
+  exists (existT (fun x => B x) x y). repeat split; trivial.
+  intros (x',y') (Heqx',Hy').
+  simpl in *.
+  destruct Heqx'.
+  rewrite (Huni y'); trivial.
+exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_inf (Hf x))).
+intro x; destruct (Hf x) as (Heq,HR) using and_indd.
+destruct (f x); simpl in *.
+destruct Heq using eq_indd; trivial.
+Qed.
+
+(**********************************************************************)
+(** *** F. Non contradiction of constructive descriptions wrt functional axioms of choice *)
+
+(** **** F. 1. Non contradiction of indefinite description *)
+
+Lemma relative_non_contradiction_of_indefinite_desc :
+      (ConstructiveIndefiniteDescription -> False)
+   -> (FunctionalChoice -> False).
+Proof.
+intros H AC_fun.
+assert (AC_depfun := non_dep_dep_functional_choice AC_fun).
+pose (A0 := { A:Type & { P:A->Prop & exists x, P x }}).
+pose (B0 := fun x:A0 => projT1 x).
+pose (R0 := fun x:A0 => fun y:B0 x => projT1 (projT2 x) y).
+pose (H0 := fun x:A0 => projT2 (projT2 x)).
+destruct (AC_depfun A0 B0 R0 H0) as (f, Hf).
+apply H.
+intros A P H'.
+exists (f (existT (fun _ => sigT _) A
+            (existT (fun P => exists x, P x) P H'))).
+pose (Hf' := 
+          Hf (existT (fun _ => sigT _) A
+            (existT (fun P => exists x, P x) P H'))).
 assumption.
 Qed.
+
+Lemma constructive_indefinite_descr_fun_choice :
+   ConstructiveIndefiniteDescription -> FunctionalChoice.
+Proof.
+intros IndefDescr A B R H.
+exists (fun x => proj1_sig (IndefDescr B (R x) (H x))).
+intro x.
+apply (proj2_sig (IndefDescr B (R x) (H x))).
+Qed.
+
+(** **** F. 2. Non contradiction of definite description *)
+
+Lemma relative_non_contradiction_of_definite_descr :
+      (ConstructiveDefiniteDescription -> False)
+   -> (FunctionalRelReification -> False).
+Proof.
+intros H FunReify.
+assert (DepFunReify := non_dep_dep_functional_rel_reification FunReify).
+pose (A0 := { A:Type & { P:A->Prop & exists! x, P x }}).
+pose (B0 := fun x:A0 => projT1 x).
+pose (R0 := fun x:A0 => fun y:B0 x => projT1 (projT2 x) y).
+pose (H0 := fun x:A0 => projT2 (projT2 x)).
+destruct (DepFunReify A0 B0 R0 H0) as (f, Hf).
+apply H.
+intros A P H'.
+exists (f (existT (fun _ => sigT _) A
+            (existT (fun P => exists! x, P x) P H'))).
+pose (Hf' := 
+          Hf (existT (fun _ => sigT _) A
+            (existT (fun P => exists! x, P x) P H'))).
+assumption.
+Qed.
+
+Lemma constructive_definite_descr_fun_reification :
+   ConstructiveDefiniteDescription -> FunctionalRelReification.
+Proof.
+intros DefDescr A B R H.
+exists (fun x => proj1_sig (DefDescr B (R x) (H x))).
+intro x.
+apply (proj2_sig (DefDescr B (R x) (H x))).
+Qed.
+
+(**********************************************************************)
+(** *** G. Excluded-middle + definite description => computational excluded-middle *)
+
+(** The idea for the following proof comes from [ChicliPottierSimpson02] *)
+
+(** Classical logic and axiom of unique choice (i.e. functional
+    relation reification), as shown in [ChicliPottierSimpson02],
+    implies the double-negation of excluded-middle in [Set] (which is
+    incompatible with the impredicativity of [Set]).
+
+    We adapt the proof to show that constructive definite description
+    transports excluded-middle from [Prop] to [Set].
+
+    [ChicliPottierSimpson02] 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 Import Setoid.
+
+Theorem constructive_definite_descr_excluded_middle :
+  ConstructiveDefiniteDescription ->
+  (forall P:Prop, P \/ ~ P) -> (forall P:Prop, {P} + {~ P}).
+Proof.
+intros Descr EM P.
+pose (select := fun b:bool => if b then P else ~P).
+assert { b:bool | select b } as ([|],HP).
+  apply Descr.
+  rewrite <- unique_existence; split.
+  destruct (EM P).
+      exists true; trivial.
+      exists false; trivial.
+    intros [|] [|] H1 H2; simpl in *; reflexivity || contradiction.
+left; trivial.
+right; trivial.
+Qed.  
diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v
index 5a633f84..bb8186ae 100644
--- a/theories/Logic/ClassicalChoice.v
+++ b/theories/Logic/ClassicalChoice.v
@@ -6,28 +6,40 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalChoice.v 6401 2004-12-05 16:44:57Z herbelin $ i*)
+(*i $Id: ClassicalChoice.v 8892 2006-06-04 17:59:53Z herbelin $ i*)
 
-(** This file provides classical logic and functional choice *)
+(** 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.
-*)
+(** This file extends ClassicalUniqueChoice.v with the axiom of choice.
+    As ClassicalUniqueChoice.v, it implies the double-negation of
+    excluded-middle in [Set] and leads to a classical world populated
+    with non computable functions. Especially it conflicts with the
+    impredicativity of [Set], knowing that [true<>false] in [Set].  *)
 
-Require Export ClassicalDescription.
+Require Export ClassicalUniqueChoice.
 Require Export RelationalChoice.
 Require Import ChoiceFacts.
 
+Set Implicit Arguments.
+
+Definition subset (U:Type) (P Q:U->Prop) : Prop := forall x, P x -> Q x.
+
+Theorem singleton_choice :
+  forall (A : Type) (P : A->Prop),
+  (exists x : A, P x) -> exists P' : A->Prop, subset P' P /\ exists! x, P' x.
+Proof.
+intros A P H.
+destruct (relational_choice unit A (fun _ => P) (fun _ => H)) as (R',(Hsub,HR')).
+exists (R' tt); firstorder.
+Qed.
+
 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)).
+ 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.
 intros A B.
 apply description_rel_choice_imp_funct_choice.
-exact (description A B).
+exact (unique_choice A B).
 exact (relational_choice A B).
 Qed.
diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v
index ce3e279c..7053266a 100644
--- a/theories/Logic/ClassicalDescription.v
+++ b/theories/Logic/ClassicalDescription.v
@@ -6,73 +6,95 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalDescription.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id: ClassicalDescription.v 8892 2006-06-04 17:59:53Z herbelin $ 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.
+(** Classical definite description operator (i.e. iota) implies
+    excluded-middle in [Set] and leads to a classical world populated
+    with non computable functions. It conflicts with the
+    impredicativity of [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.
-*)
+Set Implicit Arguments.
 
 Require Export Classical.
+Require Import ChoiceFacts.
 
-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)).
+Notation Local "'inhabited' A" := A (at level 200, only parsing).
+
+Axiom constructive_definite_description :
+  forall (A : Type) (P : A->Prop), (exists! x : A, P x) -> { x : A | P x }.
+
+(** The idea for the following proof comes from [ChicliPottierSimpson02] *)
+
+Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
+Proof.
+apply 
+  (constructive_definite_descr_excluded_middle 
+   constructive_definite_description classic).
+Qed.
+
+Theorem classical_definite_description : 
+  forall (A : Type) (P : A->Prop), inhabited A ->
+  { x : A | (exists! x : A, P x) -> P x }.
+Proof.
+intros A P i.
+destruct (excluded_middle_informative (exists! x, P x)) as [Hex|HnonP].
+  apply constructive_definite_description with (P:= fun x => (exists! x : A, P x) -> P x).
+  destruct Hex as (x,(Hx,Huni)).
+  exists x; split.
+    intros _; exact Hx.
+    firstorder.
+exists i; tauto.
+Qed.
+
+(** Church's iota operator *)
 
-(** Principle of definite descriptions (aka axiom of unique choice) *)
+Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A
+  := proj1_sig (classical_definite_description P i).
+
+Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : 
+  (exists! x:A, P x) -> P (iota i P)
+  := proj2_sig (classical_definite_description P i).
+
+(** Weaker lemmas (compatibility lemmas) *)
+
+Unset Implicit Arguments.
+
+Lemma 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) ->
+      (exists f : (forall x:A, B x), forall x:A, R x (f x)).
+Proof.
+intros A B R H.
+assert (Hexuni:forall x, exists! y, R x y).
+  intro x. apply H.
+exists (fun x => proj1_sig (constructive_definite_description (R x) (Hexuni x))).
+intro x.
+apply (proj2_sig (constructive_definite_description (R x) (Hexuni x))).
+Qed.
 
 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)).
+   (forall x : A,  exists! y : B, R x 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] *)
+(** Axiom of unique "choice" (functional reification of functional relations) *)
+
+Set Implicit Arguments.
 
-Theorem classic_set : ((forall P:Prop, {P} + {~ P}) -> False) -> False.
+Require Import Setoid.
+
+Theorem unique_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.
-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.
+intros A B R H.
+apply (description A B).
+intro x. apply H.
 Qed.
- 
diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v
new file mode 100644
index 00000000..b7293bec
--- /dev/null
+++ b/theories/Logic/ClassicalEpsilon.v
@@ -0,0 +1,90 @@
+(************************************************************************)
+(*  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: ClassicalEpsilon.v 8933 2006-06-09 14:08:38Z herbelin $ i*)
+
+(** *** This file provides classical logic and indefinite description
+    (Hilbert's epsilon operator) *)
+
+(** Classical epsilon's operator (i.e. indefinite description) implies
+    excluded-middle in [Set] and leads to a classical world populated
+    with non computable functions. It conflicts with the
+    impredicativity of [Set] *)
+
+Require Export Classical.
+Require Import ChoiceFacts.
+
+Set Implicit Arguments.
+
+Notation Local "'inhabited' A" := A (at level 200, only parsing).
+
+Axiom constructive_indefinite_description :
+  forall (A : Type) (P : A->Prop), 
+  (ex P) -> { x : A | P x }.
+
+Lemma constructive_definite_description :
+  forall (A : Type) (P : A->Prop), 
+  (exists! x : A, P x) -> { x : A | P x }.
+Proof.
+intros; apply constructive_indefinite_description; firstorder.
+Qed.
+
+Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
+Proof.
+apply 
+  (constructive_definite_descr_excluded_middle 
+   constructive_definite_description classic).
+Qed.
+
+Theorem classical_indefinite_description : 
+  forall (A : Type) (P : A->Prop), inhabited A ->
+  { x : A | ex P -> P x }.
+Proof.
+intros A P i.
+destruct (excluded_middle_informative (exists x, P x)) as [Hex|HnonP].
+  apply constructive_indefinite_description with (P:= fun x => ex P -> P x).
+  destruct Hex as (x,Hx).
+    exists x; intros _; exact Hx.
+    firstorder.
+Qed.
+
+(** Hilbert's epsilon operator *)
+
+Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A
+  := proj1_sig (classical_indefinite_description P i).
+
+Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : 
+  (ex P) -> P (epsilon i P)
+  := proj2_sig (classical_indefinite_description P i).
+
+Opaque epsilon.
+
+(** Open question: is classical_indefinite_description constructively
+    provable from [relational_choice] and
+    [constructive_definite_description] (at least, using the fact that
+    [functional_choice] is provable from [relational_choice] and
+    [unique_choice], we know that the double negation of
+    [classical_indefinite_description] is provable (see
+    [relative_non_contradiction_of_indefinite_desc]). *)
+
+(** Remark: we use [ex P] rather than [exists x, P x] (which is [ex
+    (fun x => P x)] to ease unification *)
+
+(** *** Weaker lemmas (compatibility lemmas) *)
+
+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.
+intros A B R H.
+exists (fun x => proj1_sig (constructive_indefinite_description (H x))).
+intro x.
+apply (proj2_sig (constructive_indefinite_description  (H x))).
+Qed.
+
diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v
index 91056250..70da74d3 100644
--- a/theories/Logic/ClassicalFacts.v
+++ b/theories/Logic/ClassicalFacts.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalFacts.v 8136 2006-03-05 21:57:47Z herbelin $ i*)
+(*i $Id: ClassicalFacts.v 8892 2006-06-04 17:59:53Z herbelin $ i*)
 
 (** ** Some facts and definitions about classical logic
 
diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v
new file mode 100644
index 00000000..79bef2af
--- /dev/null
+++ b/theories/Logic/ClassicalUniqueChoice.v
@@ -0,0 +1,79 @@
+(************************************************************************)
+(*  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: ClassicalUniqueChoice.v 8893 2006-06-04 18:04:53Z herbelin $ i*)
+
+(** This file provides classical logic and unique choice *)
+
+(** Classical logic and unique choice, as shown in
+    [ChicliPottierSimpson02], implies the double-negation of
+    excluded-middle in [Set], hence it implies a strongly classical
+    world. Especially it conflicts with the impredicativity of [Set].
+
+    [ChicliPottierSimpson02] 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_unique_choice :
+    forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop),
+      (forall x : A, exists! y : B x, R x y) ->
+      (exists f : (forall x:A, B x), forall x:A, R x (f x)).
+
+(** Unique choice reifies functional relations into functions *)
+
+Theorem unique_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.
+intros A B.
+apply (dependent_unique_choice A (fun _ => B)).
+Qed.
+
+(** The followig proof comes from [ChicliPottierSimpson02] *)
+
+Require Import Setoid.
+
+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 unique_choice.
+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/Classical_Prop.v b/theories/Logic/Classical_Prop.v
index f8b0e65b..ce3e84a7 100644
--- a/theories/Logic/Classical_Prop.v
+++ b/theories/Logic/Classical_Prop.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Prop.v 8642 2006-03-17 10:09:02Z notin $ i*)
+(*i $Id: Classical_Prop.v 8892 2006-06-04 17:59:53Z herbelin $ i*)
 
 (** Classical Propositional Logic *)
 
@@ -22,6 +22,15 @@ unfold not in |- *; intros; elim (classic p); auto.
 intro NP; elim (H NP).
 Qed.
 
+(** Peirce's law states [forall P Q:Prop, ((P -> Q) -> P) -> P]. 
+    Thanks to [forall P, False -> P], it is equivalent to the
+    following form *)
+
+Lemma Peirce : forall P:Prop, ((P -> False) -> P) -> P.
+Proof.
+intros P H; destruct (classic P); auto.
+Qed.
+
 Lemma not_imply_elim : forall P Q:Prop, ~ (P -> Q) -> P.
 Proof.
 intros; apply NNPP; red in |- *.
diff --git a/theories/FSets/DecidableType.v b/theories/Logic/DecidableType.v
index 635f6bdb..a38b111f 100644
--- a/theories/FSets/DecidableType.v
+++ b/theories/Logic/DecidableType.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: DecidableType.v 8639 2006-03-16 19:21:55Z letouzey $ *)
+(* $Id: DecidableType.v 8933 2006-06-09 14:08:38Z herbelin $ *)
 
 Require Export SetoidList.
 Set Implicit Arguments.
@@ -31,8 +31,9 @@ Module Type DecidableType.
 
 End DecidableType. 
 
+(** * Additional notions about keys and datas used in FMap *)
 
-Module PairDecidableType(D:DecidableType).
+Module KeyDecidableType(D:DecidableType).
  Import D.
 
  Section Elt.
@@ -147,5 +148,9 @@ Module PairDecidableType(D:DecidableType).
  Hint Unfold MapsTo In.
  Hint Resolve In_inv_2 In_inv_3.
 
+End KeyDecidableType.
+
+
+
+
 
-End PairDecidableType.
diff --git a/theories/Logic/DecidableTypeEx.v b/theories/Logic/DecidableTypeEx.v
new file mode 100644
index 00000000..a4f99de2
--- /dev/null
+++ b/theories/Logic/DecidableTypeEx.v
@@ -0,0 +1,50 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: DecidableTypeEx.v 8933 2006-06-09 14:08:38Z herbelin $ *)
+
+Require Import DecidableType OrderedType OrderedTypeEx.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Examples of Decidable Type structures. *)
+
+(** A particular case of [DecidableType] where 
+    the equality is the usual one of Coq. *)
+
+Module Type UsualDecidableType.
+ Parameter t : Set.
+ Definition eq := @eq t.
+ Definition eq_refl := @refl_equal t.
+ Definition eq_sym := @sym_eq t.
+ Definition eq_trans := @trans_eq t.
+ Parameter eq_dec : forall x y, { eq x y }+{~eq x y }.
+End UsualDecidableType.
+
+(** a [UsualDecidableType] is in particular an [DecidableType]. *)
+
+Module UDT_to_DT (U:UsualDecidableType) <: DecidableType := U.
+
+(** An OrderedType can be seen as a DecidableType *)
+
+Module OT_as_DT (O:OrderedType) <: DecidableType. 
+ Module OF := OrderedTypeFacts O.
+ Definition t := O.t.
+ Definition eq := O.eq. 
+ Definition eq_refl := O.eq_refl. 
+ Definition eq_sym := O.eq_sym. 
+ Definition eq_trans := O.eq_trans. 
+ Definition eq_dec := OF.eq_dec. 
+End OT_as_DT.
+
+(** (Usual) Decidable Type for [nat], [positive], [N], [Z] *)
+
+Module Nat_as_DT <: UsualDecidableType := OT_as_DT (Nat_as_OT).
+Module Positive_as_DT <: UsualDecidableType := OT_as_DT (Positive_as_OT).
+Module N_as_DT <: UsualDecidableType := OT_as_DT (N_as_OT).
+Module Z_as_DT <: UsualDecidableType := OT_as_DT (Z_as_OT).
diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v
index 3e94deda..19d5d7ec 100644
--- a/theories/Logic/Diaconescu.v
+++ b/theories/Logic/Diaconescu.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,26 +7,46 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Diaconescu.v 6401 2004-12-05 16:44:57Z herbelin $ i*)
+(*i $Id: Diaconescu.v 8892 2006-06-04 17:59:53Z herbelin $ 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.
+(** Diaconescu showed that the Axiom of Choice entails Excluded-Middle
+   in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show
+   that the axiom of choice in equivalence classes entails
+   Excluded-Middle in Type Theory [LacasWerner99].
 
-   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
+   Three variants of Diaconescu's result in type theory are shown below.
 
-   [Diaconescu] R. Diaconescu, Axiom of Choice and Complementation, in
-   Proceedings of AMS, vol 51, pp 176-178, 1975.
+   A. A proof that the relational form of the Axiom of Choice +
+      Extensionality for Predicates entails Excluded-Middle (by Hugo
+      Herbelin)
 
-   [LacasWerner] S. Lacas, B Werner, Which Choices imply the excluded middle?,
-   preprint, 1999.
+   B. A proof that the relational form of the Axiom of Choice + Proof
+      Irrelevance entails Excluded-Middle for Equality Statements (by
+      Benjamin Werner)
 
+   C. A proof that extensional Hilbert epsilon's description operator
+      entails excluded-middle (taken from Bell [Bell93])
+
+   See also [Carlström] for a discussion of the connection between the
+   Extensional Axiom of Choice and Excluded-Middle
+
+   [Diaconescu75] Radu Diaconescu, Axiom of Choice and Complementation,
+   in Proceedings of AMS, vol 51, pp 176-178, 1975.
+
+   [LacasWerner99] Samuel Lacas, Benjamin Werner, Which Choices imply
+   the excluded middle?, preprint, 1999.
+
+   [Bell93] John L. Bell, Hilbert's epsilon operator and classical
+   logic, Journal of Philosophical Logic, 22: 1-18, 1993
+
+   [Carlström04] Jesper Carlström, EM + Ext_ + AC_int <-> AC_ext,
+   Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.
 *)
 
-Section PredExt_GuardRelChoice_imp_EM.
+(**********************************************************************)
+(** *** A. Pred. Ext. + Rel. Axiom of Choice -> Excluded-Middle       *)
+
+Section PredExt_RelChoice_imp_EM.
 
 (** The axiom of extensionality for predicates *)
 
@@ -59,15 +80,9 @@ Qed.
 
 Require Import ChoiceFacts.
 
-Variable rel_choice : forall A B:Type, RelationalChoice A B.
+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')).
+Lemma guarded_rel_choice : GuardedRelationalChoice.
 Proof.
  apply
   (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel).
@@ -78,16 +93,19 @@ Qed.
 
 Require Import Bool.
 
-Lemma AC :
+Lemma AC_bool_subset_to_bool :
   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).
+  destruct (guarded_rel_choice _ _ 
+   (fun Q:bool -> Prop =>  exists y : _, Q y)
+   (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)).
+    exact (fun _ H => H).
+  exists R; intros P HP. 
+  destruct (HR P HP) as (y,(Hy,Huni)).
+  exists y; firstorder.
 Qed.
 
 (** The proof of the excluded middle *)
@@ -98,7 +116,7 @@ Proof.
 intro P.
 
 (** first we exhibit the choice functional relation R *)
-destruct AC as [R H].
+destruct AC_bool_subset_to_bool as [R H].
 
 set (class_of_true := fun b => b = true \/ P).
 set (class_of_false := fun b => b = false \/ P).
@@ -135,4 +153,152 @@ left; assumption.
 
 Qed.
 
-End PredExt_GuardRelChoice_imp_EM.
+End PredExt_RelChoice_imp_EM.
+
+(**********************************************************************)
+(** *** B. Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *)
+
+(** This is an adaptation of Diaconescu's paradox exploiting that
+    proof-irrelevance is some form of extensionality *)
+
+Section ProofIrrel_RelChoice_imp_EqEM.
+
+Variable rel_choice : RelationalChoice.
+
+Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y.
+
+(** Let [a1] and [a2] be two elements in some type [A] *)
+
+Variable A :Type.
+Variables a1 a2 : A.
+
+(** We build the subset [A'] of [A] made of [a1] and [a2] *)
+
+Definition A' := sigT (fun x => x=a1 \/ x=a2).
+
+Definition a1':A'.
+exists a1 ; auto.
+Defined.
+
+Definition a2':A'.
+exists a2 ; auto.
+Defined.
+
+(** By proof-irrelevance, projection is a retraction *)
+
+Lemma projT1_injective : a1=a2 -> a1'=a2'.
+Proof.
+  intro Heq ; unfold a1', a2', A'.
+  rewrite Heq.
+  replace (or_introl (a2=a2) (refl_equal a2)) 
+     with (or_intror (a2=a2) (refl_equal a2)).
+  reflexivity.
+  apply proof_irrelevance.
+Qed.
+
+(** But from the actual proofs of being in [A'], we can assert in the
+    proof-irrelevant world the existence of relevant boolean witnesses *)
+
+Lemma decide : forall x:A', exists y:bool ,
+  (projT1 x = a1 /\ y = true ) \/ (projT1 x = a2 /\ y = false).
+Proof.
+  intros [a [Ha1|Ha2]]; [exists true | exists false]; auto.
+Qed.
+
+(** Thanks to the axiom of choice, the boolean witnesses move from the
+    propositional world to the relevant world *)
+
+Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2.
+Proof.
+  destruct 
+    (rel_choice A' bool 
+       (fun x y =>  projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false))
+    as (R,(HRsub,HR)). 
+    apply decide.
+  destruct (HR a1') as (b1,(Ha1'b1,_Huni1)).
+  destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
+  destruct (HR a2') as (b2,(Ha2'b2,Huni2)).
+  destruct (HRsub a2' b2 Ha2'b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
+    left; symmetry; assumption.
+    right; intro H.
+    subst b1; subst b2.
+    rewrite (projT1_injective H) in Ha1'b1.
+    assert (false = true) by auto using Huni2.
+    discriminate.
+  left; assumption.
+Qed.
+
+(** An alternative more concise proof can be done by directly using
+    the guarded relational choice *)
+
+Declare Implicit Tactic auto.
+
+Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2.
+Proof.
+  assert (decide: forall x:A, x=a1 \/ x=a2 -> 
+                exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false).
+    intros a [Ha1|Ha2]; [exists true | exists false]; auto.
+  assert (guarded_rel_choice := 
+          rel_choice_and_proof_irrel_imp_guarded_rel_choice 
+	  rel_choice 
+	  proof_irrelevance).
+  destruct 
+    (guarded_rel_choice A bool 
+      (fun x => x=a1 \/ x=a2)
+      (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false))
+      as (R,(HRsub,HR)). 
+      apply decide.
+  destruct (HR a1) as (b1,(Ha1b1,_Huni1)). left; reflexivity.
+  destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
+  destruct (HR a2) as (b2,(Ha2b2,Huni2)). right; reflexivity.
+  destruct (HRsub a2 b2 Ha2b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
+    left; symmetry; assumption.
+    right; intro H.
+    subst b1; subst b2; subst a1.
+    assert (false = true) by auto using Huni2, Ha1b1.
+    discriminate.
+  left; assumption.
+Qed.
+
+End ProofIrrel_RelChoice_imp_EqEM.
+
+(**********************************************************************)
+(** *** B. Extensional Hilbert's epsilon description operator -> Excluded-Middle *)
+
+(** Proof sketch from Bell [Bell93] (with thanks to P. Castéran) *)
+
+Notation Local "'inhabited' A" := A (at level 10, only parsing).
+
+Section ExtensionalEpsilon_imp_EM.
+
+Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A.
+
+Hypothesis epsilon_spec : 
+  forall (A:Type) (i:inhabited A) (P:A->Prop), 
+  (exists x, P x) -> P (epsilon A i P).
+
+Hypothesis epsilon_extensionality :
+  forall (A:Type) (i:inhabited A) (P Q:A->Prop),
+  (forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q.
+
+Notation Local eps := (epsilon bool true) (only parsing).
+
+Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P.
+Proof.
+intro P.
+pose (B := fun y => y=false \/ P).
+pose (C := fun y => y=true  \/ P).
+assert (B (eps B)) as [Hfalse|HP] 
+  by (apply epsilon_spec; exists false; left; reflexivity).
+assert (C (eps C)) as [Htrue|HP] 
+  by (apply epsilon_spec; exists true; left; reflexivity).
+  right; intro HP.
+  assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption).
+  rewrite epsilon_extensionality with (1:=H) in Hfalse.
+  rewrite Htrue in Hfalse.
+  discriminate.
+auto.
+auto.
+Qed.
+
+End ExtensionalEpsilon_imp_EM.
diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v
index 11979057..ec168f09 100644
--- a/theories/Logic/RelationalChoice.v
+++ b/theories/Logic/RelationalChoice.v
@@ -6,15 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RelationalChoice.v 6001 2004-08-01 09:27:26Z herbelin $ i*)
+(*i $Id: RelationalChoice.v 8892 2006-06-04 17:59:53Z herbelin $ 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')).
+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, 
+       subrelation R' R /\ forall x : A, exists! y : B, R' x y.
diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v
index b4582d51..78353145 100644
--- a/theories/NArith/BinNat.v
+++ b/theories/NArith/BinNat.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BinNat.v 8685 2006-04-06 13:22:02Z letouzey $ i*)
+(*i $Id: BinNat.v 8771 2006-04-29 11:55:57Z letouzey $ i*)
 
 Require Import BinPos.
 Unset Boxed Definitions.
@@ -29,6 +29,12 @@ Arguments Scope Npos [positive_scope].
 
 Open Local Scope N_scope.
 
+Definition Ndiscr : forall n:N, { p:positive | n = Npos p } + { n = N0 }.
+Proof.
+ destruct n; auto.
+ left; exists p; auto.
+Defined.
+
 (** Operation x -> 2*x+1 *)
 
 Definition Ndouble_plus_one x :=
@@ -39,10 +45,11 @@ Definition Ndouble_plus_one x :=
 
 (** Operation x -> 2*x *)
 
-Definition Ndouble n := match n with
-                        | N0 => N0
-                        | Npos p => Npos (xO p)
-                        end.
+Definition Ndouble n := 
+  match n with
+  | N0 => N0
+  | Npos p => Npos (xO p)
+  end.
 
 (** Successor *)
 
@@ -86,6 +93,34 @@ Definition Ncompare n m :=
 
 Infix "?=" := Ncompare (at level 70, no associativity) : N_scope.
 
+(** convenient induction principles *)
+
+Lemma N_ind_double :
+ forall (a:N) (P:N -> Prop),
+   P N0 ->
+   (forall a, P a -> P (Ndouble a)) ->
+   (forall a, P a -> P (Ndouble_plus_one a)) -> P a.
+Proof.
+  intros; elim a. trivial.
+  simple induction p. intros. 
+  apply (H1 (Npos p0)); trivial.
+  intros; apply (H0 (Npos p0)); trivial.
+  intros; apply (H1 N0); assumption.
+Qed.
+
+Lemma N_rec_double :
+ forall (a:N) (P:N -> Set),
+   P N0 ->
+   (forall a, P a -> P (Ndouble a)) ->
+   (forall a, P a -> P (Ndouble_plus_one a)) -> P a.
+Proof.
+  intros; elim a. trivial.
+  simple induction p. intros. 
+  apply (H1 (Npos p0)); trivial.
+  intros; apply (H0 (Npos p0)); trivial.
+  intros; apply (H1 N0); assumption.
+Qed.
+
 (** Peano induction on binary natural numbers *)
 
 Theorem Nind :
@@ -211,3 +246,47 @@ 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.
+
+Lemma Ncompare_refl : forall n, (n ?= n) = Eq.
+Proof.
+destruct n; simpl; auto.
+apply Pcompare_refl.
+Qed.
+
+Lemma Ncompare_antisym : forall n m, CompOpp (n ?= m) = (m ?= n).
+Proof.
+destruct n; destruct m; simpl; auto.
+exact (Pcompare_antisym p p0 Eq).
+Qed.
+
+(** Dividing by 2 *)
+
+Definition Ndiv2 (n:N) :=
+  match n with
+  | N0 => N0
+  | Npos 1 => N0
+  | Npos (xO p) => Npos p
+  | Npos (xI p) => Npos p
+  end.
+
+Lemma Ndouble_div2 : forall n:N, Ndiv2 (Ndouble n) = n.
+Proof.
+  destruct n; trivial.
+Qed.
+
+Lemma Ndouble_plus_one_div2 :
+ forall n:N, Ndiv2 (Ndouble_plus_one n) = n.
+Proof.
+  destruct n; trivial.
+Qed.
+
+Lemma Ndouble_inj : forall n m, Ndouble n = Ndouble m -> n = m.
+Proof.
+  intros. rewrite <- (Ndouble_div2 n). rewrite H. apply Ndouble_div2.
+Qed.
+
+Lemma Ndouble_plus_one_inj :
+ forall n m, Ndouble_plus_one n = Ndouble_plus_one m -> n = m.
+Proof.
+  intros. rewrite <- (Ndouble_plus_one_div2 n). rewrite H. apply Ndouble_plus_one_div2.
+Qed.
diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v
new file mode 100644
index 00000000..df2da25b
--- /dev/null
+++ b/theories/NArith/Ndec.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: Ndec.v 8733 2006-04-25 22:52:18Z letouzey $ i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import BinPos.
+Require Import BinNat.
+Require Import Pnat.
+Require Import Nnat.
+Require Import Ndigits.
+
+(** A boolean equality over [N] *)
+
+Fixpoint Peqb (p1 p2:positive) {struct p2} : bool :=
+  match p1, p2 with
+  | xH, xH => true
+  | xO p'1, xO p'2 => Peqb p'1 p'2
+  | xI p'1, xI p'2 => Peqb p'1 p'2
+  | _, _ => false
+  end.
+
+Lemma Peqb_correct : forall p, Peqb p p = true.
+Proof.
+induction p; auto.
+Qed.
+
+Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pcompare p p' Eq = Eq.
+Proof.
+ induction p; destruct p'; simpl; intros; try discriminate; auto.
+Qed.
+
+Lemma Pcompare_Peqb : forall p p', Pcompare p p' Eq = Eq -> Peqb p p' = true.
+Proof. 
+intros; rewrite <- (Pcompare_Eq_eq _ _ H).
+apply Peqb_correct.
+Qed.
+
+Definition Neqb (a a':N) :=
+  match a, a' with
+  | N0, N0 => true
+  | Npos p, Npos p' => Peqb p p'
+  | _, _ => false
+  end.
+
+Lemma Neqb_correct : forall n, Neqb n n = true.
+Proof.
+  destruct n; trivial.
+  simpl; apply Peqb_correct.
+Qed.
+
+Lemma Neqb_Ncompare : forall n n', Neqb n n' = true -> Ncompare n n' = Eq.
+Proof.
+ destruct n; destruct n'; simpl; intros; try discriminate; auto; apply Peqb_Pcompare; auto.
+Qed.
+
+Lemma Ncompare_Neqb : forall n n', Ncompare n n' = Eq -> Neqb n n' = true.
+Proof. 
+intros; rewrite <- (Ncompare_Eq_eq _ _ H).
+apply Neqb_correct.
+Qed.
+
+Lemma Neqb_complete : forall a a', Neqb a a' = true -> a = a'.
+Proof.
+  intros.
+  apply Ncompare_Eq_eq.
+  apply Neqb_Ncompare; auto.
+Qed.
+
+Lemma Neqb_comm : forall a a', Neqb a a' = Neqb a' a.
+Proof.
+  intros; apply bool_1; split; intros.
+  rewrite (Neqb_complete _ _ H); apply Neqb_correct.
+  rewrite (Neqb_complete _ _ H); apply Neqb_correct.
+Qed.
+
+Lemma Nxor_eq_true :
+ forall a a', Nxor a a' = N0 -> Neqb a a' = true.
+Proof.
+  intros. rewrite (Nxor_eq a a' H). apply Neqb_correct.
+Qed.
+
+Lemma Nxor_eq_false :
+ forall a a' p, Nxor a a' = Npos p -> Neqb a a' = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb a a')). intro H0.
+  rewrite (Neqb_complete a a' H0) in H. rewrite (Nxor_nilpotent a') in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Nodd_not_double :
+ forall a,
+   Nodd a -> forall a0, Neqb (Ndouble a0) a = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb (Ndouble a0) a)). intro H0.
+  rewrite <- (Neqb_complete _ _ H0) in H. 
+  unfold Nodd in H.
+  rewrite (Ndouble_bit0 a0) in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Nnot_div2_not_double :
+ forall a a0,
+   Neqb (Ndiv2 a) a0 = false -> Neqb a (Ndouble a0) = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb (Ndouble a0) a)). intro H0.
+  rewrite <- (Neqb_complete _ _ H0) in H. rewrite (Ndouble_div2 a0) in H.
+  rewrite (Neqb_correct a0) in H. discriminate H.
+  intro. rewrite Neqb_comm. assumption.
+Qed.
+
+Lemma Neven_not_double_plus_one :
+ forall a,
+   Neven a -> forall a0, Neqb (Ndouble_plus_one a0) a = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb (Ndouble_plus_one a0) a)). intro H0.
+  rewrite <- (Neqb_complete _ _ H0) in H. 
+  unfold Neven in H.
+  rewrite (Ndouble_plus_one_bit0 a0) in H.
+  discriminate H.
+  trivial.
+Qed.
+
+Lemma Nnot_div2_not_double_plus_one :
+ forall a a0,
+   Neqb (Ndiv2 a) a0 = false -> Neqb (Ndouble_plus_one a0) a = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb a (Ndouble_plus_one a0))). intro H0.
+  rewrite (Neqb_complete _ _ H0) in H. rewrite (Ndouble_plus_one_div2 a0) in H.
+  rewrite (Neqb_correct a0) in H. discriminate H.
+  intro H0. rewrite Neqb_comm. assumption.
+Qed.
+
+Lemma Nbit0_neq :
+ forall a a',
+   Nbit0 a = false -> Nbit0 a' = true -> Neqb a a' = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb a a')). intro H1. rewrite (Neqb_complete _ _ H1) in H.
+  rewrite H in H0. discriminate H0.
+  trivial.
+Qed.
+
+Lemma Ndiv2_eq :
+ forall a a', Neqb a a' = true -> Neqb (Ndiv2 a) (Ndiv2 a') = true.
+Proof.
+  intros. cut (a = a'). intros. rewrite H0. apply Neqb_correct.
+  apply Neqb_complete. exact H.
+Qed.
+
+Lemma Ndiv2_neq :
+ forall a a',
+   Neqb (Ndiv2 a) (Ndiv2 a') = false -> Neqb a a' = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb a a')). intro H0.
+  rewrite (Neqb_complete _ _ H0) in H. rewrite (Neqb_correct (Ndiv2 a')) in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Ndiv2_bit_eq :
+ forall a a',
+   Nbit0 a = Nbit0 a' -> Ndiv2 a = Ndiv2 a' -> a = a'.
+Proof.
+  intros. apply Nbit_faithful. unfold eqf in |- *. destruct n.
+  rewrite Nbit0_correct. rewrite Nbit0_correct. assumption.
+  rewrite <- Ndiv2_correct. rewrite <- Ndiv2_correct.
+  rewrite H0. reflexivity.
+Qed.
+
+Lemma Ndiv2_bit_neq :
+ forall a a',
+   Neqb a a' = false ->
+   Nbit0 a = Nbit0 a' -> Neqb (Ndiv2 a) (Ndiv2 a') = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb (Ndiv2 a) (Ndiv2 a'))). intro H1.
+  rewrite (Ndiv2_bit_eq _ _ H0 (Neqb_complete _ _ H1)) in H.
+  rewrite (Neqb_correct a') in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Nneq_elim :
+ forall a a',
+   Neqb a a' = false ->
+   Nbit0 a = negb (Nbit0 a') \/
+   Neqb (Ndiv2 a) (Ndiv2 a') = false.
+Proof.
+  intros. cut (Nbit0 a = Nbit0 a' \/ Nbit0 a = negb (Nbit0 a')).
+  intros. elim H0. intro. right. apply Ndiv2_bit_neq. assumption.
+  assumption.
+  intro. left. assumption.
+  case (Nbit0 a); case (Nbit0 a'); auto.
+Qed.
+
+Lemma Ndouble_or_double_plus_un :
+ forall a,
+   {a0 : N | a = Ndouble a0} + {a1 : N | a = Ndouble_plus_one a1}.
+Proof.
+  intro. elim (sumbool_of_bool (Nbit0 a)). intro H. right. split with (Ndiv2 a).
+  rewrite (Ndiv2_double_plus_one a H). reflexivity.
+  intro H. left. split with (Ndiv2 a). rewrite (Ndiv2_double a H). reflexivity.
+Qed.
+
+(** A boolean order on [N] *)
+
+Definition Nle (a b:N) := leb (nat_of_N a) (nat_of_N b).
+
+Lemma Nle_Ncompare : forall a b, Nle a b = true <-> Ncompare a b <> Gt.
+Proof.
+ intros; rewrite nat_of_Ncompare.
+ unfold Nle; apply leb_compare.
+Qed.
+
+Lemma Nle_refl : forall a, Nle a a = true.
+Proof.
+  intro. unfold Nle in |- *. apply leb_correct. apply le_n.
+Qed.
+
+Lemma Nle_antisym :
+ forall a b, Nle a b = true -> Nle b a = true -> a = b.
+Proof.
+  unfold Nle in |- *. intros. rewrite <- (N_of_nat_of_N a). rewrite <- (N_of_nat_of_N b).
+  rewrite (le_antisym _ _ (leb_complete _ _ H) (leb_complete _ _ H0)). reflexivity.
+Qed.
+
+Lemma Nle_trans :
+ forall a b c, Nle a b = true -> Nle b c = true -> Nle a c = true.
+Proof.
+  unfold Nle in |- *. intros. apply leb_correct. apply le_trans with (m := nat_of_N b).
+  apply leb_complete. assumption.
+  apply leb_complete. assumption.
+Qed.
+
+Lemma Nle_lt_trans :
+ forall a b c,
+   Nle a b = true -> Nle c b = false -> Nle c a = false.
+Proof.
+  unfold Nle in |- *. intros. apply leb_correct_conv. apply le_lt_trans with (m := nat_of_N b).
+  apply leb_complete. assumption.
+  apply leb_complete_conv. assumption.
+Qed.
+
+Lemma Nlt_le_trans :
+ forall a b c,
+   Nle b a = false -> Nle b c = true -> Nle c a = false.
+Proof.
+  unfold Nle in |- *. intros. apply leb_correct_conv. apply lt_le_trans with (m := nat_of_N b).
+  apply leb_complete_conv. assumption.
+  apply leb_complete. assumption.
+Qed.
+
+Lemma Nlt_trans :
+ forall a b c,
+   Nle b a = false -> Nle c b = false -> Nle c a = false.
+Proof.
+  unfold Nle in |- *. intros. apply leb_correct_conv. apply lt_trans with (m := nat_of_N b).
+  apply leb_complete_conv. assumption.
+  apply leb_complete_conv. assumption.
+Qed.
+
+Lemma Nlt_le_weak : forall a b:N, Nle b a = false -> Nle a b = true.
+Proof.
+  unfold Nle in |- *. intros. apply leb_correct. apply lt_le_weak.
+  apply leb_complete_conv. assumption.
+Qed.
+
+Lemma Nle_double_mono :
+ forall a b,
+   Nle a b = true -> Nle (Ndouble a) (Ndouble b) = true.
+Proof.
+  unfold Nle in |- *. intros. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. apply leb_correct.
+  simpl in |- *. apply plus_le_compat. apply leb_complete. assumption.
+  apply plus_le_compat. apply leb_complete. assumption.
+  apply le_n.
+Qed.
+
+Lemma Nle_double_plus_one_mono :
+ forall a b,
+   Nle a b = true ->
+   Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = true.
+Proof.
+  unfold Nle in |- *. intros. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one.
+  apply leb_correct. apply le_n_S. simpl in |- *. apply plus_le_compat. apply leb_complete.
+  assumption.
+  apply plus_le_compat. apply leb_complete. assumption.
+  apply le_n.
+Qed.
+
+Lemma Nle_double_mono_conv :
+ forall a b,
+   Nle (Ndouble a) (Ndouble b) = true -> Nle a b = true.
+Proof.
+  unfold Nle in |- *. intros a b. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. intro.
+  apply leb_correct. apply (mult_S_le_reg_l 1). apply leb_complete. assumption.
+Qed.
+
+Lemma Nle_double_plus_one_mono_conv :
+ forall a b,
+   Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = true ->
+   Nle a b = true.
+Proof.
+  unfold Nle in |- *. intros a b. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one.
+  intro. apply leb_correct. apply (mult_S_le_reg_l 1). apply le_S_n. apply leb_complete.
+  assumption.
+Qed.
+
+Lemma Nlt_double_mono :
+ forall a b,
+   Nle a b = false -> Nle (Ndouble a) (Ndouble b) = false.
+Proof.
+  intros. elim (sumbool_of_bool (Nle (Ndouble a) (Ndouble b))). intro H0.
+  rewrite (Nle_double_mono_conv _ _ H0) in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Nlt_double_plus_one_mono :
+ forall a b,
+   Nle a b = false ->
+   Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = false.
+Proof.
+  intros. elim (sumbool_of_bool (Nle (Ndouble_plus_one a) (Ndouble_plus_one b))). intro H0.
+  rewrite (Nle_double_plus_one_mono_conv _ _ H0) in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Nlt_double_mono_conv :
+ forall a b,
+   Nle (Ndouble a) (Ndouble b) = false -> Nle a b = false.
+Proof.
+  intros. elim (sumbool_of_bool (Nle a b)). intro H0. rewrite (Nle_double_mono _ _ H0) in H.
+  discriminate H.
+  trivial.
+Qed.
+
+Lemma Nlt_double_plus_one_mono_conv :
+ forall a b,
+   Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = false ->
+   Nle a b = false.
+Proof.
+  intros. elim (sumbool_of_bool (Nle a b)). intro H0.
+  rewrite (Nle_double_plus_one_mono _ _ H0) in H. discriminate H.
+  trivial.
+Qed.
+
+(* A [min] function over [N] *)
+
+Definition Nmin (a b:N) := if Nle a b then a else b.
+
+Lemma Nmin_choice : forall a b, {Nmin a b = a} + {Nmin a b = b}.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle a b)). intro H. left. rewrite H.
+  reflexivity.
+  intro H. right. rewrite H. reflexivity.
+Qed.
+
+Lemma Nmin_le_1 : forall a b, Nle (Nmin a b) a = true.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle a b)). intro H. rewrite H.
+  apply Nle_refl.
+  intro H. rewrite H. apply Nlt_le_weak. assumption.
+Qed.
+
+Lemma Nmin_le_2 : forall a b, Nle (Nmin a b) b = true.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle a b)). intro H. rewrite H. assumption.
+  intro H. rewrite H. apply Nle_refl.
+Qed.
+
+Lemma Nmin_le_3 :
+ forall a b c, Nle a (Nmin b c) = true -> Nle a b = true.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H.
+  assumption.
+  intro H0. rewrite H0 in H. apply Nlt_le_weak. apply Nle_lt_trans with (b := c); assumption.
+Qed.
+
+Lemma Nmin_le_4 :
+ forall a b c, Nle a (Nmin b c) = true -> Nle a c = true.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H.
+  apply Nle_trans with (b := b); assumption.
+  intro H0. rewrite H0 in H. assumption.
+Qed.
+
+Lemma Nmin_le_5 :
+ forall a b c,
+   Nle a b = true -> Nle a c = true -> Nle a (Nmin b c) = true.
+Proof.
+  intros. elim (Nmin_choice b c). intro H1. rewrite H1. assumption.
+  intro H1. rewrite H1. assumption.
+Qed.
+
+Lemma Nmin_lt_3 :
+ forall a b c, Nle (Nmin b c) a = false -> Nle b a = false.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H.
+  assumption.
+  intro H0. rewrite H0 in H. apply Nlt_trans with (b := c); assumption.
+Qed.
+
+Lemma Nmin_lt_4 :
+ forall a b c, Nle (Nmin b c) a = false -> Nle c a = false.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H.
+  apply Nlt_le_trans with (b := b); assumption.
+  intro H0. rewrite H0 in H. assumption.
+Qed.
diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v
new file mode 100644
index 00000000..ed8ced5b
--- /dev/null
+++ b/theories/NArith/Ndigits.v
@@ -0,0 +1,767 @@
+(************************************************************************)
+(*  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: Ndigits.v 8736 2006-04-26 21:18:44Z letouzey $ i*)
+
+Require Import Bool.
+Require Import Bvector.
+Require Import BinPos.
+Require Import BinNat.
+
+(** Operation over bits of a [N] number. *)
+
+(** [xor] *)
+
+Fixpoint Pxor (p1 p2:positive) {struct p1} : N :=
+  match p1, p2 with
+  | xH, xH => N0
+  | xH, xO p2 => Npos (xI p2)
+  | xH, xI p2 => Npos (xO p2)
+  | xO p1, xH => Npos (xI p1)
+  | xO p1, xO p2 => Ndouble (Pxor p1 p2)
+  | xO p1, xI p2 => Ndouble_plus_one (Pxor p1 p2)
+  | xI p1, xH => Npos (xO p1)
+  | xI p1, xO p2 => Ndouble_plus_one (Pxor p1 p2)
+  | xI p1, xI p2 => Ndouble (Pxor p1 p2) 
+  end.
+
+Definition Nxor (n n':N) :=
+  match n, n' with
+  | N0, _ => n'
+  | _, N0 => n
+  | Npos p, Npos p' => Pxor p p'
+  end.
+
+Lemma Nxor_neutral_left : forall n:N, Nxor N0 n = n.
+Proof.
+  trivial.
+Qed.
+
+Lemma Nxor_neutral_right : forall n:N, Nxor n N0 = n.
+Proof.
+  destruct n; trivial.
+Qed.
+
+Lemma Nxor_comm : forall n n':N, Nxor n n' = Nxor n' n.
+Proof.
+  destruct n; destruct n'; simpl; auto.
+  generalize p0; clear p0; induction p as [p Hrecp| p Hrecp| ]; simpl;
+   auto.
+  destruct p0; simpl; trivial; intros; rewrite Hrecp; trivial.
+  destruct p0; simpl; trivial; intros; rewrite Hrecp; trivial.
+  destruct p0 as [p| p| ]; simpl; auto.
+Qed.
+
+Lemma Nxor_nilpotent : forall n:N, Nxor n n = N0.
+Proof.
+  destruct n; trivial.
+  simpl. induction p as [p IHp| p IHp| ]; trivial.
+  simpl. rewrite IHp; reflexivity.
+  simpl. rewrite IHp; reflexivity.
+Qed.
+
+(** Checking whether a particular bit is set on not *) 
+
+Fixpoint Pbit (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' => Pbit p n'
+                   end
+  | xI p => fun n:nat => match n with
+                         | O => true
+                         | S n' => Pbit p n'
+                         end
+  end.
+
+Definition Nbit (a:N) :=
+  match a with
+  | N0 => fun _ => false
+  | Npos p => Pbit p
+  end.
+
+(** Auxiliary results about streams of bits *)
+
+Definition eqf (f g:nat -> bool) := forall n:nat, f n = g n.
+
+Lemma eqf_sym : forall f f':nat -> bool, eqf f f' -> eqf f' f.
+Proof.
+  unfold eqf. intros. rewrite H. reflexivity.
+Qed.
+
+Lemma eqf_refl : forall f:nat -> bool, eqf f f.
+Proof.
+  unfold eqf. trivial.
+Qed.
+
+Lemma eqf_trans :
+ forall f f' f'':nat -> bool, eqf f f' -> eqf f' f'' -> eqf f f''.
+Proof.
+  unfold eqf. intros. rewrite H. exact (H0 n).
+Qed.
+
+Definition xorf (f g:nat -> bool) (n:nat) := xorb (f n) (g n).
+
+Lemma xorf_eq :
+ forall f f', eqf (xorf f f') (fun n => false) -> eqf f f'.
+Proof.
+  unfold eqf, xorf. intros. apply xorb_eq. apply H.
+Qed.
+
+Lemma xorf_assoc :
+ forall f f' f'',
+   eqf (xorf (xorf f f') f'') (xorf f (xorf f' f'')).
+Proof.
+  unfold eqf, xorf. intros. apply xorb_assoc.
+Qed.
+
+Lemma eqf_xorf :
+ forall f f' f'' f''',
+   eqf f f' -> eqf f'' f''' -> eqf (xorf f f'') (xorf f' f''').
+Proof.
+  unfold eqf, xorf. intros. rewrite H. rewrite H0. reflexivity.
+Qed.
+
+(** End of auxilliary results *)
+
+(** This part is aimed at proving that if two numbers produce 
+  the same stream of bits, then they are equal. *)
+
+Lemma Nbit_faithful_1 : forall a:N, eqf (Nbit N0) (Nbit a) -> N0 = a.
+Proof.
+  destruct a. trivial.
+  induction p as [p IHp| p IHp| ]; intro H. 
+  absurd (N0 = Npos p). discriminate.
+  exact (IHp (fun n => H (S n))).
+  absurd (N0 = Npos p). discriminate.
+  exact (IHp (fun n => H (S n))).
+  absurd (false = true). discriminate.
+  exact (H 0).
+Qed.
+
+Lemma Nbit_faithful_2 :
+ forall a:N, eqf (Nbit (Npos 1)) (Nbit a) -> Npos 1 = a.
+Proof.
+  destruct a. intros. absurd (true = false). discriminate.
+  exact (H 0).
+  destruct p. intro H. absurd (N0 = Npos p). discriminate.
+  exact (Nbit_faithful_1 (Npos p) (fun n:nat => H (S n))).
+  intros. absurd (true = false). discriminate.
+  exact (H 0).
+  trivial.
+Qed.
+
+Lemma Nbit_faithful_3 :
+ forall (a:N) (p:positive),
+   (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') ->
+   eqf (Nbit (Npos (xO p))) (Nbit a) -> Npos (xO p) = a.
+Proof.
+  destruct a. intros. cut (eqf (Nbit N0) (Nbit (Npos (xO p)))).
+  intro. rewrite (Nbit_faithful_1 (Npos (xO p)) H1). reflexivity.
+  unfold eqf. intro. unfold eqf in H0. rewrite H0. reflexivity.
+  case p. intros. absurd (false = true). discriminate.
+  exact (H0 0).
+  intros. rewrite (H p0 (fun n => H0 (S n))). reflexivity.
+  intros. absurd (false = true). discriminate.
+  exact (H0 0).
+Qed.
+
+Lemma Nbit_faithful_4 :
+ forall (a:N) (p:positive),
+   (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') ->
+   eqf (Nbit (Npos (xI p))) (Nbit a) -> Npos (xI p) = a.
+Proof.
+  destruct a. intros. cut (eqf (Nbit N0) (Nbit (Npos (xI p)))).
+  intro. rewrite (Nbit_faithful_1 (Npos (xI p)) H1). reflexivity.
+  unfold eqf. 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 (N0 = Npos p0). discriminate.
+  cut (eqf (Nbit (Npos 1)) (Nbit (Npos (xI p0)))).
+  intro. exact (Nbit_faithful_1 (Npos p0) (fun n:nat => H1 (S n))).
+  unfold eqf in *. intro. rewrite H0. reflexivity.
+Qed.
+
+Lemma Nbit_faithful : forall a a':N, eqf (Nbit a) (Nbit a') -> a = a'.
+Proof.
+  destruct a. exact Nbit_faithful_1.
+  induction p. intros a' H. apply Nbit_faithful_4. intros. cut (Npos p = Npos p').
+  intro. inversion H1. reflexivity.
+  exact (IHp (Npos p') H0).
+  assumption.
+  intros. apply Nbit_faithful_3. intros. cut (Npos p = Npos p'). intro. inversion H1. reflexivity.
+  exact (IHp (Npos p') H0).
+  assumption.
+  exact Nbit_faithful_2.
+Qed.
+
+(** We now describe the semantics of [Nxor] in terms of bit streams. *)
+
+Lemma Nxor_sem_1 : forall a':N, Nbit (Nxor N0 a') 0 = Nbit a' 0.
+Proof.
+  trivial.
+Qed.
+
+Lemma Nxor_sem_2 :
+ forall a':N, Nbit (Nxor (Npos 1) a') 0 = negb (Nbit a' 0).
+Proof.
+  intro. case a'. trivial.
+  simpl. intro. 
+  case p; trivial.
+Qed.
+
+Lemma Nxor_sem_3 :
+ forall (p:positive) (a':N),
+   Nbit (Nxor (Npos (xO p)) a') 0 = Nbit a' 0.
+Proof.
+  intros. case a'. trivial.
+  simpl. intro. 
+  case p0; trivial. intro. 
+  case (Pxor p p1); trivial.
+  intro. case (Pxor p p1); trivial.
+Qed.
+
+Lemma Nxor_sem_4 :
+ forall (p:positive) (a':N),
+   Nbit (Nxor (Npos (xI p)) a') 0 = negb (Nbit a' 0).
+Proof.
+  intros. case a'. trivial.
+  simpl. intro. case p0; trivial. intro. 
+  case (Pxor p p1); trivial.
+  intro. 
+  case (Pxor p p1); trivial.
+Qed.
+
+Lemma Nxor_sem_5 :
+ forall a a':N, Nbit (Nxor a a') 0 = xorf (Nbit a) (Nbit a') 0.
+Proof.
+  destruct a. intro. change (Nbit a' 0 = xorb false (Nbit a' 0)). rewrite false_xorb. trivial.
+  case p. exact Nxor_sem_4.
+  intros. change (Nbit (Nxor (Npos (xO p0)) a') 0 = xorb false (Nbit a' 0)).
+  rewrite false_xorb. apply Nxor_sem_3. exact Nxor_sem_2.
+Qed.
+
+Lemma Nxor_sem_6 :
+ forall n:nat,
+   (forall a a':N, Nbit (Nxor a a') n = xorf (Nbit a) (Nbit a') n) ->
+   forall a a':N,
+     Nbit (Nxor a a') (S n) = xorf (Nbit a) (Nbit a') (S n).
+Proof.
+  intros. 
+  generalize (fun p1 p2 => H (Npos p1) (Npos p2)); clear H; intro H.
+  unfold xorf in *.
+  case a. simpl Nbit; rewrite false_xorb. reflexivity.
+  case a'; intros. 
+  simpl Nbit; rewrite xorb_false. reflexivity.
+  case p0. case p; intros; simpl Nbit in *.
+  rewrite <- H; simpl; case (Pxor p2 p1); trivial.
+  rewrite <- H; simpl; case (Pxor p2 p1); trivial.
+  rewrite xorb_false. reflexivity.
+  case p; intros; simpl Nbit in *.
+  rewrite <- H; simpl; case (Pxor p2 p1); trivial.
+  rewrite <- H; simpl; case (Pxor p2 p1); trivial.
+  rewrite xorb_false. reflexivity.
+  simpl Nbit. rewrite false_xorb. simpl. case p; trivial.
+Qed.
+
+Lemma Nxor_semantics :
+ forall a a':N, eqf (Nbit (Nxor a a')) (xorf (Nbit a) (Nbit a')).
+Proof.
+  unfold eqf. intros. generalize a a'. elim n. exact Nxor_sem_5.
+  exact Nxor_sem_6.
+Qed.
+
+(** Consequences: 
+       - only equal numbers lead to a null xor
+       - xor is associative 
+*)
+
+Lemma Nxor_eq : forall a a':N, Nxor a a' = N0 -> a = a'.
+Proof.
+  intros. apply Nbit_faithful. apply xorf_eq. apply eqf_trans with (f' := Nbit (Nxor a a')).
+  apply eqf_sym. apply Nxor_semantics.
+  rewrite H. unfold eqf. trivial.
+Qed.
+
+Lemma Nxor_assoc :
+ forall a a' a'':N, Nxor (Nxor a a') a'' = Nxor a (Nxor a' a'').
+Proof.
+  intros. apply Nbit_faithful.
+  apply eqf_trans with
+   (f' := xorf (xorf (Nbit a) (Nbit a')) (Nbit a'')).
+  apply eqf_trans with (f' := xorf (Nbit (Nxor a a')) (Nbit a'')).
+  apply Nxor_semantics.
+  apply eqf_xorf. apply Nxor_semantics.
+  apply eqf_refl.
+  apply eqf_trans with
+   (f' := xorf (Nbit a) (xorf (Nbit a') (Nbit a''))).
+  apply xorf_assoc.
+  apply eqf_trans with (f' := xorf (Nbit a) (Nbit (Nxor a' a''))).
+  apply eqf_xorf. apply eqf_refl.
+  apply eqf_sym. apply Nxor_semantics.
+  apply eqf_sym. apply Nxor_semantics.
+Qed.
+
+(** Checking whether a number is odd, i.e. 
+   if its lower bit is set. *)
+
+Definition Nbit0 (n:N) :=
+  match n with
+  | N0 => false
+  | Npos (xO _) => false
+  | _ => true
+  end.
+
+Definition Nodd (n:N) := Nbit0 n = true.
+Definition Neven (n:N) := Nbit0 n = false.
+
+Lemma Nbit0_correct : forall n:N, Nbit n 0 = Nbit0 n.
+Proof.
+  destruct n; trivial.
+  destruct p; trivial.
+Qed.
+
+Lemma Ndouble_bit0 : forall n:N, Nbit0 (Ndouble n) = false.
+Proof.
+  destruct n; trivial.
+Qed.
+
+Lemma Ndouble_plus_one_bit0 :
+ forall n:N, Nbit0 (Ndouble_plus_one n) = true.
+Proof.
+  destruct n; trivial.
+Qed.
+
+Lemma Ndiv2_double :
+ forall n:N, Neven n -> Ndouble (Ndiv2 n) = n.
+Proof.
+  destruct n. trivial. destruct p. intro H. discriminate H.
+  intros. reflexivity.
+  intro H. discriminate H.
+Qed.
+
+Lemma Ndiv2_double_plus_one :
+ forall n:N, Nodd n -> Ndouble_plus_one (Ndiv2 n) = n.
+Proof.
+  destruct n. intro. discriminate H.
+  destruct p. intros. reflexivity.
+  intro H. discriminate H.
+  intro. reflexivity.
+Qed.
+
+Lemma Ndiv2_correct :
+ forall (a:N) (n:nat), Nbit (Ndiv2 a) n = Nbit a (S n).
+Proof.
+  destruct a; trivial.
+  destruct p; trivial.
+Qed.
+
+Lemma Nxor_bit0 :
+ forall a a':N, Nbit0 (Nxor a a') = xorb (Nbit0 a) (Nbit0 a').
+Proof.
+  intros. rewrite <- Nbit0_correct. rewrite (Nxor_semantics a a' 0).
+  unfold xorf. rewrite Nbit0_correct. rewrite Nbit0_correct. reflexivity.
+Qed.
+
+Lemma Nxor_div2 :
+ forall a a':N, Ndiv2 (Nxor a a') = Nxor (Ndiv2 a) (Ndiv2 a').
+Proof.
+  intros. apply Nbit_faithful. unfold eqf. intro.
+  rewrite (Nxor_semantics (Ndiv2 a) (Ndiv2 a') n).
+  rewrite Ndiv2_correct.
+  rewrite (Nxor_semantics a a' (S n)).
+  unfold xorf. rewrite Ndiv2_correct. rewrite Ndiv2_correct.
+  reflexivity.
+Qed.
+
+Lemma Nneg_bit0 :
+ forall a a':N,
+   Nbit0 (Nxor a a') = true -> Nbit0 a = negb (Nbit0 a').
+Proof.
+  intros. rewrite <- true_xorb. rewrite <- H. rewrite Nxor_bit0.
+  rewrite xorb_assoc. rewrite xorb_nilpotent. rewrite xorb_false. reflexivity.
+Qed.
+
+Lemma Nneg_bit0_1 :
+ forall a a':N, Nxor a a' = Npos 1 -> Nbit0 a = negb (Nbit0 a').
+Proof.
+  intros. apply Nneg_bit0. rewrite H. reflexivity.
+Qed.
+
+Lemma Nneg_bit0_2 :
+ forall (a a':N) (p:positive),
+   Nxor a a' = Npos (xI p) -> Nbit0 a = negb (Nbit0 a').
+Proof.
+  intros. apply Nneg_bit0. rewrite H. reflexivity.
+Qed.
+
+Lemma Nsame_bit0 :
+ forall (a a':N) (p:positive),
+   Nxor a a' = Npos (xO p) -> Nbit0 a = Nbit0 a'.
+Proof.
+  intros. rewrite <- (xorb_false (Nbit0 a)). cut (Nbit0 (Npos (xO p)) = false).
+  intro. rewrite <- H0. rewrite <- H. rewrite Nxor_bit0. rewrite <- xorb_assoc.
+  rewrite xorb_nilpotent. rewrite false_xorb. reflexivity.
+  reflexivity.
+Qed.
+
+(** a lexicographic order on bits, starting from the lowest bit *)
+
+Fixpoint Nless_aux (a a':N) (p:positive) {struct p} : bool :=
+  match p with
+  | xO p' => Nless_aux (Ndiv2 a) (Ndiv2 a') p'
+  | _ => andb (negb (Nbit0 a)) (Nbit0 a')
+  end.
+
+Definition Nless (a a':N) :=
+  match Nxor a a' with
+  | N0 => false
+  | Npos p => Nless_aux a a' p
+  end.
+
+Lemma Nbit0_less :
+ forall a a',
+   Nbit0 a = false -> Nbit0 a' = true -> Nless a a' = true.
+Proof.
+  intros. elim (Ndiscr (Nxor a a')). intro H1. elim H1. intros p H2. unfold Nless in |- *.
+  rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+  intros. cut (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 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 (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 a a') in H2.
+  rewrite H in H2. rewrite H0 in H2. discriminate H2.
+  rewrite H1. reflexivity.
+Qed.
+
+Lemma Nbit0_gt :
+ forall a a',
+   Nbit0 a = true -> Nbit0 a' = false -> Nless a a' = false.
+Proof.
+  intros. elim (Ndiscr (Nxor a a')). intro H1. elim H1. intros p H2. unfold Nless in |- *.
+  rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+  intros. cut (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 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 Nless in |- *. rewrite H1. reflexivity.
+Qed.
+
+Lemma Nless_not_refl : forall a, Nless a a = false.
+Proof.
+  intro. unfold Nless in |- *. rewrite (Nxor_nilpotent a). reflexivity.
+Qed.
+
+Lemma Nless_def_1 :
+ forall a a', Nless (Ndouble a) (Ndouble a') = Nless a a'.
+Proof.
+  simple induction a. simple induction a'. reflexivity.
+  trivial.
+  simple induction a'. unfold Nless in |- *. simpl in |- *. elim p; trivial.
+  unfold Nless in |- *. simpl in |- *. intro. case (Pxor p p0). reflexivity.
+  trivial.
+Qed.
+
+Lemma Nless_def_2 :
+ forall a a',
+   Nless (Ndouble_plus_one a) (Ndouble_plus_one a') = Nless a a'.
+Proof.
+  simple induction a. simple induction a'. reflexivity.
+  trivial.
+  simple induction a'. unfold Nless in |- *. simpl in |- *. elim p; trivial.
+  unfold Nless in |- *. simpl in |- *. intro. case (Pxor p p0). reflexivity.
+  trivial.
+Qed.
+
+Lemma Nless_def_3 :
+ forall a a', Nless (Ndouble a) (Ndouble_plus_one a') = true.
+Proof.
+  intros. apply Nbit0_less. apply Ndouble_bit0.
+  apply Ndouble_plus_one_bit0.
+Qed.
+
+Lemma Nless_def_4 :
+ forall a a', Nless (Ndouble_plus_one a) (Ndouble a') = false.
+Proof.
+  intros. apply Nbit0_gt. apply Ndouble_plus_one_bit0.
+  apply Ndouble_bit0.
+Qed.
+
+Lemma Nless_z : forall a, Nless a N0 = false.
+Proof.
+  simple induction a. reflexivity.
+  unfold Nless in |- *. intro. rewrite (Nxor_neutral_right (Npos p)). elim p; trivial.
+Qed.
+
+Lemma N0_less_1 :
+ forall a, Nless N0 a = true -> {p : positive | a = Npos p}.
+Proof.
+  simple induction a. intro. discriminate H.
+  intros. split with p. reflexivity.
+Qed.
+
+Lemma N0_less_2 : forall a, Nless N0 a = false -> a = N0.
+Proof.
+  simple induction a. trivial.
+  unfold Nless in |- *. simpl in |- *. 
+  cut (forall p:positive, Nless_aux N0 (Npos p) p = false -> False).
+  intros. elim (H p H0).
+  simple induction p. intros. discriminate H0.
+  intros. exact (H H0).
+  intro. discriminate H.
+Qed.
+
+Lemma Nless_trans :
+ forall a a' a'',
+   Nless a a' = true -> Nless a' a'' = true -> Nless a a'' = true.
+Proof.
+  intro a. pattern a; apply N_ind_double.
+  intros. case_eq (Nless N0 a''). trivial.
+  intro H1. rewrite (N0_less_2 a'' H1) in H0. rewrite (Nless_z a') in H0. discriminate H0.
+  intros a0 H a'. pattern a'; apply N_ind_double.
+  intros. rewrite (Nless_z (Ndouble a0)) in H0. discriminate H0.
+  intros a1 H0 a'' H1. rewrite (Nless_def_1 a0 a1) in H1.
+  pattern a''; apply N_ind_double; clear a''.
+  intro. rewrite (Nless_z (Ndouble a1)) in H2. discriminate H2.
+  intros. rewrite (Nless_def_1 a1 a2) in H3. rewrite (Nless_def_1 a0 a2).
+  exact (H a1 a2 H1 H3).
+  intros. apply Nless_def_3.
+  intros a1 H0 a'' H1. pattern a''; apply N_ind_double.
+  intro. rewrite (Nless_z (Ndouble_plus_one a1)) in H2. discriminate H2.
+  intros. rewrite (Nless_def_4 a1 a2) in H3. discriminate H3.
+  intros. apply Nless_def_3.
+  intros a0 H a'. pattern a'; apply N_ind_double.
+  intros. rewrite (Nless_z (Ndouble_plus_one a0)) in H0. discriminate H0.
+  intros. rewrite (Nless_def_4 a0 a1) in H1. discriminate H1.
+  intros a1 H0 a'' H1. pattern a''; apply N_ind_double.
+  intro. rewrite (Nless_z (Ndouble_plus_one a1)) in H2. discriminate H2.
+  intros. rewrite (Nless_def_4 a1 a2) in H3. discriminate H3.
+  rewrite (Nless_def_2 a0 a1) in H1. intros. rewrite (Nless_def_2 a1 a2) in H3.
+  rewrite (Nless_def_2 a0 a2). exact (H a1 a2 H1 H3).
+Qed.
+ 
+Lemma Nless_total :
+ forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}.
+Proof.
+  intro a. 
+  pattern a; apply N_rec_double; clear a.
+  intro. case_eq (Nless N0 a'). intro H. left. left. auto.
+  intro H. right. rewrite (N0_less_2 a' H). reflexivity.
+  intros a0 H a'. 
+  pattern a'; apply N_rec_double; clear a'.
+  case_eq (Nless N0 (Ndouble a0)). intro H0. left. right. auto.
+  intro H0. right. exact (N0_less_2 _ H0).
+  intros a1 H0. rewrite Nless_def_1. rewrite Nless_def_1. elim (H a1). intro H1.
+  left. assumption.
+  intro H1. right. rewrite H1. reflexivity.
+  intros a1 H0. left. left. apply Nless_def_3.
+  intros a0 H a'. 
+  pattern a'; apply N_rec_double; clear a'.
+  left. right. case a0; reflexivity.
+  intros a1 H0. left. right. apply Nless_def_3.
+  intros a1 H0. rewrite Nless_def_2. rewrite Nless_def_2. elim (H a1). intro H1.
+  left. assumption.
+  intro H1. right. rewrite H1. reflexivity.
+Qed.
+
+(** Number of digits in a number *)
+
+Fixpoint Psize (p:positive) : nat := 
+  match p with 
+    | xH => 1%nat
+    | xI p => S (Psize p) 
+    | xO p => S (Psize p)
+  end.
+
+Definition Nsize (n:N) : nat := match n with 
+  | N0 => 0%nat
+  | Npos p => Psize p
+ end.
+
+
+(** conversions between N and bit vectors. *)
+
+Fixpoint P2Bv (p:positive) : Bvector (Psize p) := 
+ match p return Bvector (Psize p) with 
+   | xH => Bvect_true 1%nat
+   | xO p => Bcons false (Psize p) (P2Bv p)
+   | xI p => Bcons true (Psize p) (P2Bv p)
+ end.
+
+Definition N2Bv (n:N) : Bvector (Nsize n) :=
+  match n as n0 return Bvector (Nsize n0) with 
+    | N0 => Bnil
+    | Npos p => P2Bv p
+  end.
+
+Fixpoint Bv2N (n:nat)(bv:Bvector n) {struct bv} : N := 
+  match bv with 
+    | Vnil => N0
+    | Vcons false n bv => Ndouble (Bv2N n bv)
+    | Vcons true n bv => Ndouble_plus_one (Bv2N n bv) 
+  end.
+
+Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n.
+Proof. 
+destruct n.
+simpl; auto.
+induction p; simpl in *; auto; rewrite IHp; simpl; auto.
+Qed.
+
+(** The opposite composition is not so simple: if the considered 
+  bit vector has some zeros on its right, they will disappear during 
+  the return [Bv2N] translation: *)
+
+Lemma Bv2N_Nsize : forall n (bv:Bvector n), Nsize (Bv2N n bv) <= n.
+Proof.
+induction n; intros.
+rewrite (V0_eq _ bv); simpl; auto.
+rewrite (VSn_eq _ _ bv); simpl.
+generalize (IHn (Vtail _ _ bv)); clear IHn.
+destruct (Vhead _ _ bv); 
+ destruct (Bv2N n (Vtail bool n bv)); 
+  simpl; auto with arith.
+Qed.
+
+(** In the previous lemma, we can only replace the inequality by
+  an equality whenever the highest bit is non-null. *)
+
+Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)), 
+  Bsign _ bv = true <-> 
+  Nsize (Bv2N _ bv) = (S n).
+Proof.
+induction n; intro.
+rewrite (VSn_eq _ _ bv); simpl.
+rewrite (V0_eq _ (Vtail _ _ bv)); simpl.
+destruct (Vhead _ _ bv); simpl; intuition; try discriminate.
+rewrite (VSn_eq _ _ bv); simpl.
+generalize (IHn (Vtail _ _ bv)); clear IHn.
+destruct (Vhead _ _ bv); 
+ destruct (Bv2N (S n) (Vtail bool (S n) bv)); 
+  simpl; intuition; try discriminate.
+Qed.
+
+(** To state nonetheless a second result about composition of 
+ conversions, we define a conversion on a given number of bits : *) 
+
+Fixpoint N2Bv_gen (n:nat)(a:N) { struct n } : Bvector n := 
+ match n return Bvector n with 
+   | 0 => Bnil
+   | S n => match a with 
+       | N0 => Bvect_false (S n)
+       | Npos xH => Bcons true _ (Bvect_false n)
+       | Npos (xO p) => Bcons false _ (N2Bv_gen n (Npos p))
+       | Npos (xI p) => Bcons true _ (N2Bv_gen n (Npos p))
+      end
+  end.
+
+(** The first [N2Bv] is then a special case of [N2Bv_gen] *)
+
+Lemma N2Bv_N2Bv_gen : forall (a:N), N2Bv a = N2Bv_gen (Nsize a) a.
+Proof.
+destruct a; simpl.
+auto.
+induction p; simpl; intros; auto; congruence.
+Qed.
+
+(** In fact, if [k] is large enough, [N2Bv_gen k a] contains all digits of 
+   [a] plus some zeros. *)
+
+Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat), 
+ N2Bv_gen (Nsize a + k) a = Vextend _ _ _ (N2Bv a) (Bvect_false k).
+Proof.
+destruct a; simpl.
+destruct k; simpl; auto.
+induction p; simpl; intros;unfold Bcons; f_equal; auto.
+Qed.
+
+(** Here comes now the second composition result. *)
+
+Lemma N2Bv_Bv2N : forall n (bv:Bvector n), 
+   N2Bv_gen n (Bv2N n bv) = bv.
+Proof.
+induction n; intros.
+rewrite (V0_eq _ bv); simpl; auto.
+rewrite (VSn_eq _ _ bv); simpl.
+generalize (IHn (Vtail _ _ bv)); clear IHn.
+unfold Bcons.
+destruct (Bv2N _ (Vtail _ _ bv)); 
+ destruct (Vhead _ _ bv); intro H; rewrite <- H; simpl; trivial; 
+  induction n; simpl; auto.
+Qed.
+
+(** accessing some precise bits. *)
+
+Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)), 
+  Nbit0 (Bv2N _ bv) = Blow _ bv.
+Proof.
+intros.
+unfold Blow.
+pattern bv at 1; rewrite (VSn_eq _ _ bv).
+simpl.
+destruct (Bv2N n (Vtail bool n bv)); simpl; 
+ destruct (Vhead bool n bv); auto.
+Qed.
+
+Definition Bnth (n:nat)(bv:Bvector n)(p:nat) : p<n -> bool.
+Proof.
+ induction 1.
+ intros.
+ elimtype False; inversion H.
+ intros.
+ destruct p.
+ exact a.
+ apply (IHbv p); auto with arith.
+Defined.
+
+Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p<n), 
+  Bnth _ bv p H = Nbit (Bv2N _ bv) p.
+Proof.
+induction bv; intros.
+inversion H.
+destruct p; simpl; destruct (Bv2N n bv); destruct a; simpl in *; auto.
+Qed.
+
+Lemma Nbit_Nsize : forall n p, Nsize n <= p -> Nbit n p = false.
+Proof.
+destruct n as [|n].
+simpl; auto.
+induction n; simpl in *; intros; destruct p; auto with arith.
+inversion H.
+inversion H.
+Qed.
+
+Lemma Nbit_Bth: forall n p (H:p < Nsize n), Nbit n p = Bnth _ (N2Bv n) p H.
+Proof.
+destruct n as [|n].
+inversion H.
+induction n; simpl in *; intros; destruct p; auto with arith.
+inversion H; inversion H1.
+Qed.
+
+(** Xor is the same in the two worlds. *)
+
+Lemma Nxor_BVxor : forall n (bv bv' : Bvector n), 
+  Bv2N _ (BVxor _ bv bv') = Nxor (Bv2N _ bv) (Bv2N _ bv').
+Proof.
+induction n.
+intros.
+rewrite (V0_eq _ bv); rewrite (V0_eq _ bv'); simpl; auto.
+intros.
+rewrite (VSn_eq _ _ bv); rewrite (VSn_eq _ _ bv'); simpl; auto.
+rewrite IHn.
+destruct (Vhead bool n bv); destruct (Vhead bool n bv'); 
+ destruct (Bv2N n (Vtail bool n bv)); destruct (Bv2N n (Vtail bool n bv')); simpl; auto.
+Qed.
+
diff --git a/theories/IntMap/Adist.v b/theories/NArith/Ndist.v
index 790218ce..d5bfc15c 100644
--- a/theories/IntMap/Adist.v
+++ b/theories/NArith/Ndist.v
@@ -5,40 +5,42 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	     $Id: Adist.v 5920 2004-07-16 20:01:26Z herbelin $	      i*)
+(*i 	     $Id: Ndist.v 8733 2006-04-25 22:52:18Z letouzey $	      i*)
 
-Require Import Bool.
-Require Import ZArith.
 Require Import Arith.
 Require Import Min.
-Require Import Addr.
+Require Import BinPos.
+Require Import BinNat.
+Require Import Ndigits.
 
-Fixpoint ad_plength_1 (p:positive) : nat :=
-  match p with
-  | xH => 0
-  | xI _ => 0
-  | xO p' => S (ad_plength_1 p')
-  end.
+(** An ultrametric distance over [N] numbers *)
 
 Inductive natinf : Set :=
   | infty : natinf
   | ni : nat -> natinf.
 
-Definition ad_plength (a:ad) :=
+Fixpoint Pplength (p:positive) : nat :=
+  match p with
+  | xH => 0
+  | xI _ => 0
+  | xO p' => S (Pplength p')
+  end.
+
+Definition Nplength (a:N) :=
   match a with
-  | ad_z => infty
-  | ad_x p => ni (ad_plength_1 p)
+  | N0 => infty
+  | Npos p => ni (Pplength p)
   end.
 
-Lemma ad_plength_infty : forall a:ad, ad_plength a = infty -> a = ad_z.
+Lemma Nplength_infty : forall a:N, Nplength a = infty -> a = N0.
 Proof.
   simple induction a; trivial. 
-  unfold ad_plength in |- *; intros; discriminate H.
+  unfold Nplength 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.
+Lemma Nplength_zeros :
+ forall (a:N) (n:nat),
+   Nplength a = ni n -> forall k:nat, k < n -> Nbit a k = false.
 Proof.
   simple induction a; trivial. 
   simple induction p. simple induction n. intros. inversion H1.
@@ -46,33 +48,33 @@ Proof.
   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.
+  intros. simpl in |- *. unfold Nbit 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.
+Lemma Nplength_one :
+ forall (a:N) (n:nat), Nplength a = ni n -> Nbit 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 H0. inversion H0. simpl in |- *. unfold Nbit 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.
+Lemma Nplength_first_one :
+ forall (a:N) (n:nat),
+   (forall k:nat, k < n -> Nbit a k = false) ->
+   Nbit a n = true -> Nplength 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.
+  intros. absurd (Nbit (Npos (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.
+  intros. simpl in |- *. unfold Nplength in H.
+  cut (ni (Pplength p0) = ni n0). intro. inversion H4. reflexivity.
+  apply H. intros. change (Nbit (Npos (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.
@@ -220,117 +222,117 @@ 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).
+Lemma Nplength_lb :
+ forall (a:N) (n:nat),
+   (forall k:nat, k < n -> Nbit a k = false) -> ni_le (ni n) (Nplength 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).
+  intros. unfold Nplength in |- *. apply le_ni_le. case (le_or_lt n (Pplength p)). trivial.
+  intro. absurd (Nbit (Npos p) (Pplength p) = false).
   rewrite
-   (ad_plength_one (ad_x p) (ad_plength_1 p)
-      (refl_equal (ad_plength (ad_x p)))).
+   (Nplength_one (Npos p) (Pplength p)
+      (refl_equal (Nplength (Npos 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).
+Lemma Nplength_ub :
+ forall (a:N) (n:nat), Nbit a n = true -> ni_le (Nplength 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).
+  intros. unfold Nplength in |- *. apply le_ni_le. case (le_or_lt (Pplength p) n). trivial.
+  intro. absurd (Nbit (Npos p) n = true).
   rewrite
-   (ad_plength_zeros (ad_x p) (ad_plength_1 p)
-      (refl_equal (ad_plength (ad_x p))) n H0).
+   (Nplength_zeros (Npos p) (Pplength p)
+      (refl_equal (Nplength (Npos p))) n H0).
   discriminate.
   exact H.
 Qed.
 
 
-(** We define an ultrametric distance between addresses: 
+(** We define an ultrametric distance between [N] numbers: 
     $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]: *)
+    [Npdist]: *)
 
-Definition ad_pdist (a a':ad) := ad_plength (ad_xor a a').
+Definition Npdist (a a':N) := Nplength (Nxor 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.
+Lemma Npdist_eq_1 : forall a:N, Npdist a a = infty.
 Proof.
-  intros. unfold ad_pdist in |- *. rewrite ad_xor_nilpotent. reflexivity.
+  intros. unfold Npdist in |- *. rewrite Nxor_nilpotent. reflexivity.
 Qed.
 
-Lemma ad_pdist_eq_2 : forall a a':ad, ad_pdist a a' = infty -> a = a'.
+Lemma Npdist_eq_2 : forall a a':N, Npdist a a' = infty -> a = a'.
 Proof.
-  intros. apply ad_xor_eq. apply ad_plength_infty. exact H.
+  intros. apply Nxor_eq. apply Nplength_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.
+Lemma Npdist_comm : forall a a':N, Npdist a a' = Npdist a' a.
 Proof.
-  unfold ad_pdist in |- *. intros. rewrite ad_xor_comm. reflexivity.
+  unfold Npdist in |- *. intros. rewrite Nxor_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))$
+  This means that $min(pd(a,a''),pd(a'',a'))<=pd(a,a')$ (lemma [Npdist_ultra] below).
+  This follows from the fact that $a ~Ra~|a| = 1/2^{\texttt{Nplength}}(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]).
+  min $(\texttt{Nplength}(a), \texttt{Nplength}(b)) \leq 
+  \texttt{Nplength} (a~\texttt{xor}~ b)$
+  (lemma [Nplength_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')).
+Lemma Nplength_ultra_1 :
+ forall a a':N,
+   ni_le (Nplength a) (Nplength a') ->
+   ni_le (Nplength a) (Nplength (Nxor 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).
+  simple induction a. intros. unfold ni_le in H. unfold Nplength at 1 3 in H.
+  rewrite (ni_min_inf_l (Nplength a')) in H.
+  rewrite (Nplength_infty a' H). simpl in |- *. apply ni_le_refl.
+  intros. unfold Nplength at 1 in |- *. apply Nplength_lb. intros.
+  cut (forall a'':N, Nxor (Npos p) a' = a'' -> Nbit 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 |- *.
+  intros. rewrite <- H1. rewrite (Nxor_semantics (Npos p) a' k). unfold xorf in |- *.
   rewrite
-   (ad_plength_zeros (ad_x p) (ad_plength_1 p)
-      (refl_equal (ad_plength (ad_x p))) k H0).
+   (Nplength_zeros (Npos p) (Pplength p)
+      (refl_equal (Nplength (Npos 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.
+  intros. cut (Nbit (Npos p1) k = false). intros. rewrite H3. reflexivity.
+  apply Nplength_zeros with (n := Pplength p1). reflexivity.
+  apply (lt_le_trans k (Pplength p) (Pplength 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')).
+Lemma Nplength_ultra :
+ forall a a':N,
+   ni_le (ni_min (Nplength a) (Nplength a')) (Nplength (Nxor 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.
+  intros. case (ni_le_total (Nplength a) (Nplength a')). intro.
+  cut (ni_min (Nplength a) (Nplength a') = Nplength a).
+  intro. rewrite H0. apply Nplength_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.
+  intro. cut (ni_min (Nplength a) (Nplength a') = Nplength a').
+  intro. rewrite H0. rewrite Nxor_comm. apply Nplength_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').
+Lemma Npdist_ultra :
+ forall a a' a'':N,
+   ni_le (ni_min (Npdist a a'') (Npdist a'' a')) (Npdist 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.
+  intros. unfold Npdist in |- *. cut (Nxor (Nxor a a'') (Nxor a'' a') = Nxor a a').
+  intro. rewrite <- H. apply Nplength_ultra.
+  rewrite Nxor_assoc. rewrite <- (Nxor_assoc a'' a'' a'). rewrite Nxor_nilpotent.
+  rewrite Nxor_neutral_left. reflexivity.
 Qed.
\ No newline at end of file
diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v
new file mode 100644
index 00000000..6ba6ca3d
--- /dev/null
+++ b/theories/NArith/Nnat.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: Nnat.v 8733 2006-04-25 22:52:18Z letouzey $ i*)
+
+Require Import Arith.
+Require Import Compare_dec.
+Require Import Sumbool.
+Require Import Div2.
+Require Import BinPos.
+Require Import BinNat.
+Require Import Pnat.
+
+(** Translation from [N] to [nat] and back. *)
+
+Definition nat_of_N (a:N) :=
+  match a with
+  | N0 => 0%nat
+  | Npos p => nat_of_P p
+  end.
+
+Definition N_of_nat (n:nat) :=
+  match n with
+  | O => N0
+  | S n' => Npos (P_of_succ_nat n')
+  end.
+
+Lemma N_of_nat_of_N : forall a:N, N_of_nat (nat_of_N 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_N_of_nat : forall n:nat, nat_of_N (N_of_nat n) = n.
+Proof.
+  induction n. trivial.
+  intros. simpl in |- *. apply nat_of_P_o_P_of_succ_nat_eq_succ.
+Qed.
+
+(** Interaction of this translation and usual operations. *)
+
+Lemma nat_of_Ndouble : forall a, nat_of_N (Ndouble a) = 2*(nat_of_N a).
+Proof.
+  destruct a; simpl nat_of_N; auto.
+  apply nat_of_P_xO.
+Qed.
+
+Lemma N_of_double : forall n, N_of_nat (2*n) = Ndouble (N_of_nat n).
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  rewrite <- nat_of_Ndouble.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Ndouble_plus_one : 
+  forall a, nat_of_N (Ndouble_plus_one a) = S (2*(nat_of_N a)).
+Proof.
+  destruct a; simpl nat_of_N; auto.
+  apply nat_of_P_xI.
+Qed.
+
+Lemma N_of_double_plus_one : 
+  forall n, N_of_nat (S (2*n)) = Ndouble_plus_one (N_of_nat n).
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  rewrite <- nat_of_Ndouble_plus_one.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Nsucc : forall a, nat_of_N (Nsucc a) = S (nat_of_N a).
+Proof.
+  destruct a; simpl.
+  apply nat_of_P_xH.
+  apply nat_of_P_succ_morphism.
+Qed.
+
+Lemma N_of_S : forall n, N_of_nat (S n) = Nsucc (N_of_nat n).
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  rewrite <- nat_of_Nsucc.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Nplus : 
+  forall a a', nat_of_N (Nplus a a') = (nat_of_N a)+(nat_of_N a').
+Proof.
+  destruct a; destruct a'; simpl; auto.
+  apply nat_of_P_plus_morphism.
+Qed.
+
+Lemma N_of_plus : 
+  forall n n', N_of_nat (n+n') = Nplus (N_of_nat n) (N_of_nat n').
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
+  rewrite <- nat_of_Nplus.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Nmult : 
+  forall a a', nat_of_N (Nmult a a') = (nat_of_N a)*(nat_of_N a').
+Proof.
+  destruct a; destruct a'; simpl; auto.
+  apply nat_of_P_mult_morphism.
+Qed.
+
+Lemma N_of_mult : 
+  forall n n', N_of_nat (n*n') = Nmult (N_of_nat n) (N_of_nat n').
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
+  rewrite <- nat_of_Nmult.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Ndiv2 : 
+  forall a, nat_of_N (Ndiv2 a) = div2 (nat_of_N a).
+Proof.
+  destruct a; simpl in *; auto.
+  destruct p; auto.
+  rewrite nat_of_P_xI.
+  rewrite div2_double_plus_one; auto.
+  rewrite nat_of_P_xO.
+  rewrite div2_double; auto.
+Qed.  
+
+Lemma N_of_div2 : 
+  forall n, N_of_nat (div2 n) = Ndiv2 (N_of_nat n).
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  rewrite <- nat_of_Ndiv2.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Ncompare : 
+ forall a a', Ncompare a a' = nat_compare (nat_of_N a) (nat_of_N a').
+Proof.
+  destruct a; destruct a'; simpl.
+  compute; auto.
+  generalize (lt_O_nat_of_P p).
+  unfold nat_compare.
+  destruct (lt_eq_lt_dec 0 (nat_of_P p)) as [[H|H]|H]; auto.
+  rewrite <- H; inversion 1.
+  intros; generalize (lt_trans _ _ _ H0 H); inversion 1.
+  generalize (lt_O_nat_of_P p).
+  unfold nat_compare.
+  destruct (lt_eq_lt_dec (nat_of_P p) 0) as [[H|H]|H]; auto.
+  intros; generalize (lt_trans _ _ _ H0 H); inversion 1.
+  rewrite H; inversion 1.
+  unfold nat_compare.
+  destruct (lt_eq_lt_dec (nat_of_P p) (nat_of_P p0)) as [[H|H]|H]; auto.
+  apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
+  rewrite (nat_of_P_inj _ _ H); apply Pcompare_refl.
+  apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
+Qed.
+
+Lemma N_of_nat_compare : 
+ forall n n', nat_compare n n' = Ncompare (N_of_nat n) (N_of_nat n').
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
+  symmetry; apply nat_of_Ncompare.
+Qed.
\ No newline at end of file
diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v
new file mode 100644
index 00000000..03935e2b
--- /dev/null
+++ b/theories/QArith/QArith.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: QArith.v 8883 2006-05-31 21:56:37Z letouzey $ i*)
+
+Require Export QArith_base.
+Require Export Qring.
+Require Export Qreduction.
diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v
new file mode 100644
index 00000000..1d56b747
--- /dev/null
+++ b/theories/QArith/QArith_base.v
@@ -0,0 +1,621 @@
+(************************************************************************)
+(*  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: QArith_base.v 8883 2006-05-31 21:56:37Z letouzey $ i*)
+
+Require Export ZArith.
+Require Export ZArithRing.
+Require Export Setoid.
+
+(** * Definition of [Q] and basic properties *)
+
+(** Rationals are pairs of [Z] and [positive] numbers. *)
+
+Record Q : Set := Qmake {Qnum : Z; Qden : positive}.
+
+Delimit Scope Q_scope with Q.
+Bind Scope Q_scope with Q.
+Arguments Scope Qmake [Z_scope positive_scope].
+Open Scope Q_scope.
+Ltac simpl_mult := repeat rewrite Zpos_mult_morphism.
+
+(** [a#b] denotes the fraction [a] over [b]. *)
+
+Notation "a # b" := (Qmake a b) (at level 55, no associativity) : Q_scope.
+
+Definition inject_Z (x : Z) := Qmake x 1. 
+Arguments Scope inject_Z [Z_scope].
+
+Notation " 'QDen'  p " := (Zpos (Qden p)) (at level 20, no associativity) : Q_scope.
+Notation " 0 " := (0#1) : Q_scope.
+Notation " 1 " := (1#1) : Q_scope.
+
+Definition Qeq (p q : Q) := (Qnum p * QDen q)%Z = (Qnum q * QDen p)%Z.
+Definition Qle (x y : Q) := (Qnum x * QDen y <= Qnum y * QDen x)%Z.
+Definition Qlt (x y : Q) := (Qnum x * QDen y < Qnum y * QDen x)%Z.
+Notation Qgt := (fun x y : Q => Qlt y x).
+Notation Qge := (fun x y : Q => Qle y x).
+
+Infix "==" := Qeq (at level 70, no associativity) : Q_scope. 
+Infix "<" := Qlt : Q_scope.
+Infix "<=" := Qle : Q_scope.
+Infix ">" := Qgt : Q_scope. 
+Infix ">=" := Qge : Q_scope. 
+Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope.
+
+Hint Unfold Qeq Qle Qlt: qarith.
+Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith.
+
+(** Properties of equality. *)
+
+Theorem Qeq_refl : forall x, x == x.
+Proof.
+ auto with qarith.
+Qed.
+
+Theorem Qeq_sym : forall x y, x == y -> y == x. 
+Proof.
+ auto with qarith.
+Qed.
+
+Theorem Qeq_trans : forall x y z, x == y -> y == z -> x == z.
+Proof.
+unfold Qeq in |- *; intros.
+apply Zmult_reg_l with (QDen y). 
+auto with qarith.
+ring; rewrite H; ring.
+rewrite Zmult_assoc; rewrite H0; ring.
+Qed.
+
+(** Furthermore, this equality is decidable: *)
+
+Theorem Qeq_dec : forall x y, {x==y} + {~ x==y}.
+Proof.
+ intros; case (Z_eq_dec (Qnum x * QDen y) (Qnum y * QDen x)); auto.
+Defined.
+
+(** We now consider [Q] seen as a setoid. *)
+
+Definition Q_Setoid : Setoid_Theory Q Qeq.
+Proof.
+ split; unfold Qeq in |- *; auto; apply Qeq_trans.
+Qed.
+
+Add Setoid Q Qeq Q_Setoid as Qsetoid.
+
+Hint Resolve (Seq_refl Q Qeq Q_Setoid): qarith.
+Hint Resolve (Seq_sym Q Qeq Q_Setoid): qarith.
+Hint Resolve (Seq_trans Q Qeq Q_Setoid): qarith.
+
+(** The addition, multiplication and opposite are defined 
+   in the straightforward way: *)
+
+Definition Qplus (x y : Q) :=
+  (Qnum x * QDen y + Qnum y * QDen x) # (Qden x * Qden y).
+
+Definition Qmult (x y : Q) := (Qnum x * Qnum y) # (Qden x * Qden y). 
+
+Definition Qopp (x : Q) := (- Qnum x) # (Qden x).
+
+Definition Qminus (x y : Q) := Qplus x (Qopp y).
+
+Definition Qinv (x : Q) :=
+  match Qnum x with
+  | Z0 => 0
+  | Zpos p => (QDen x)#p
+  | Zneg p => (Zneg (Qden x))#p
+  end.
+
+Definition Qdiv (x y : Q) := Qmult x (Qinv y).
+
+Infix "+" := Qplus : Q_scope.
+Notation "- x" := (Qopp x) : Q_scope.
+Infix "-" := Qminus : Q_scope.
+Infix "*" := Qmult : Q_scope.
+Notation "/ x" := (Qinv x) : Q_scope. 
+Infix "/" := Qdiv : Q_scope. 
+
+(** A light notation for [Zpos] *)
+
+Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope.
+
+(** Setoid compatibility results *)
+
+Add Morphism Qplus : Qplus_comp. 
+Proof.
+unfold Qeq, Qplus; simpl.
+Open Scope Z_scope.
+intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
+simpl_mult; ring.
+replace (p1 * ('s2 * 'q2)) with (p1 * 'q2 * 's2) by ring.
+rewrite H.
+replace ('s2 * ('q2 * r1)) with (r1 * 's2 * 'q2) by ring.
+rewrite H0.
+ring.
+Open Scope Q_scope.
+Qed.
+
+Add Morphism Qopp : Qopp_comp.
+Proof.
+unfold Qeq, Qopp; simpl.
+intros; ring; rewrite H; ring.
+Qed.
+
+Add Morphism Qminus : Qminus_comp.
+Proof.
+intros.
+unfold Qminus. 
+rewrite H; rewrite H0; auto with qarith.
+Qed.
+
+Add Morphism Qmult : Qmult_comp.
+Proof.
+unfold Qeq; simpl.
+Open Scope Z_scope.
+intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
+intros; simpl_mult; ring.
+replace ('p2 * (q1 * s1)) with (q1 * 'p2 * s1) by ring.
+rewrite <- H.
+replace ('s2 * ('q2 * r1)) with (r1 * 's2 * 'q2) by ring.
+rewrite H0.
+ring.
+Open Scope Q_scope.
+Qed.
+
+Add Morphism Qinv : Qinv_comp.
+Proof.
+unfold Qeq, Qinv; simpl.
+Open Scope Z_scope.
+intros (p1, p2) (q1, q2); simpl.
+case p1; simpl.
+intros. 
+assert (q1 = 0).
+ elim (Zmult_integral q1 ('p2)); auto with zarith.
+ intros; discriminate.
+subst; auto. 
+case q1; simpl; intros; try discriminate.
+rewrite (Pmult_comm p2 p); rewrite (Pmult_comm q2 p0); auto.
+case q1; simpl; intros; try discriminate.
+rewrite (Pmult_comm p2 p); rewrite (Pmult_comm q2 p0); auto.
+Open Scope Q_scope.
+Qed.
+
+Add Morphism Qdiv : Qdiv_comp.
+Proof.
+intros; unfold Qdiv.
+rewrite H; rewrite H0; auto with qarith.
+Qed.
+
+Add Morphism Qle with signature Qeq ==> Qeq ==> iff as Qle_comp.
+Proof.
+cut (forall x1 x2, x1==x2 -> forall x3 x4, x3==x4 -> x1<=x3 -> x2<=x4).
+split; apply H; assumption || (apply Qeq_sym ; assumption).
+
+unfold Qeq, Qle; simpl.
+Open Scope Z_scope.
+intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0 H1; simpl in *.
+apply Zmult_le_reg_r with ('p2).
+unfold Zgt; auto.
+replace (q1 * 's2 * 'p2) with (q1 * 'p2 * 's2) by ring.
+rewrite <- H.
+apply Zmult_le_reg_r with ('r2).
+unfold Zgt; auto.
+replace (s1 * 'q2 * 'p2 * 'r2) with (s1 * 'r2 * 'q2 * 'p2) by ring.
+rewrite <- H0.
+replace (p1 * 'q2 * 's2 * 'r2) with ('q2 * 's2 * (p1 * 'r2)) by ring.
+replace (r1 * 's2 * 'q2 * 'p2) with ('q2 * 's2 * (r1 * 'p2)) by ring.
+auto with zarith.
+Open Scope Q_scope.
+Qed.
+
+Add Morphism Qlt with signature Qeq ==> Qeq ==> iff as  Qlt_comp.
+Proof.
+cut (forall x1 x2, x1==x2 -> forall x3 x4, x3==x4 -> x1<x3 -> x2<x4).
+split; apply H; assumption || (apply Qeq_sym ; assumption).
+
+unfold Qeq, Qlt; simpl.
+Open Scope Z_scope.
+intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0 H1; simpl in *.
+apply Zgt_lt.
+generalize (Zlt_gt _ _ H1); clear H1; intro H1.
+apply Zmult_gt_reg_r with ('p2); auto with zarith.
+replace (q1 * 's2 * 'p2) with (q1 * 'p2 * 's2) by ring.
+rewrite <- H.
+apply Zmult_gt_reg_r with ('r2); auto with zarith.
+replace (s1 * 'q2 * 'p2 * 'r2) with (s1 * 'r2 * 'q2 * 'p2) by ring.
+rewrite <- H0.
+replace (p1 * 'q2 * 's2 * 'r2) with ('q2 * 's2 * (p1 * 'r2)) by ring.
+replace (r1 * 's2 * 'q2 * 'p2) with ('q2 * 's2 * (r1 * 'p2)) by ring. 
+apply Zlt_gt.
+apply Zmult_gt_0_lt_compat_l; auto with zarith.
+Open Scope Q_scope.
+Qed.
+
+(** [0] and [1] are apart *)
+
+Lemma Q_apart_0_1 : ~ 1 == 0.
+Proof.
+ unfold Qeq; auto with qarith.
+Qed.
+
+(** Addition is associative: *)
+
+Theorem Qplus_assoc : forall x y z, x+(y+z)==(x+y)+z.
+Proof.
+ intros (x1, x2) (y1, y2) (z1, z2).
+ unfold Qeq, Qplus; simpl; simpl_mult; ring.
+Qed.
+
+(** [0] is a neutral element for addition: *)
+
+Lemma Qplus_0_l : forall x, 0+x == x.
+Proof.
+ intros (x1, x2); unfold Qeq, Qplus; simpl; ring.
+Qed.
+
+Lemma Qplus_0_r : forall x, x+0 == x.
+Proof.
+ intros (x1, x2); unfold Qeq, Qplus; simpl.
+ rewrite Pmult_comm; simpl; ring.
+Qed. 
+
+(** Commutativity of addition: *)
+
+Theorem Qplus_comm : forall x y, x+y == y+x.
+Proof.
+ intros (x1, x2); unfold Qeq, Qplus; simpl.
+ intros; rewrite Pmult_comm; ring.
+Qed.
+
+(** Properties of [Qopp] *)
+
+Lemma Qopp_involutive : forall q, - -q == q.
+Proof.
+ red; simpl; intros; ring.
+Qed.
+
+Theorem Qplus_opp_r : forall q, q+(-q) == 0.
+Proof.
+ red; simpl; intro; ring.
+Qed.
+
+(** Multiplication is associative: *)
+
+Theorem Qmult_assoc : forall n m p, n*(m*p)==(n*m)*p.
+Proof.
+ intros; red; simpl; rewrite Pmult_assoc; ring.
+Qed.
+
+(** [1] is a neutral element for multiplication: *)
+
+Lemma Qmult_1_l : forall n, 1*n == n.
+Proof.
+ intro; red; simpl; destruct (Qnum n); auto.
+Qed.
+
+Theorem Qmult_1_r : forall n, n*1==n.
+Proof.
+ intro; red; simpl.
+ rewrite Zmult_1_r with (n := Qnum n).
+ rewrite Pmult_comm; simpl; trivial. 
+Qed.
+
+(** Commutativity of multiplication *)
+
+Theorem Qmult_comm : forall x y, x*y==y*x.
+Proof.
+ intros; red; simpl; rewrite Pmult_comm; ring.
+Qed.
+
+(** Distributivity *)
+
+Theorem Qmult_plus_distr_r : forall x y z, x*(y+z)==(x*y)+(x*z).
+Proof.
+intros (x1, x2) (y1, y2) (z1, z2).
+unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring.
+Qed.
+
+Theorem Qmult_plus_distr_l : forall x y z, (x+y)*z==(x*z)+(y*z).
+Proof.
+intros (x1, x2) (y1, y2) (z1, z2).
+unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring.
+Qed.
+
+(** Integrality *)
+
+Theorem Qmult_integral : forall x y, x*y==0 -> x==0 \/ y==0.
+Proof.
+ intros (x1,x2) (y1,y2).
+ unfold Qeq, Qmult; simpl; intros.
+ destruct (Zmult_integral (x1*1)%Z (y1*1)%Z); auto.
+ rewrite <- H; ring.
+Qed.
+
+Theorem Qmult_integral_l : forall x y, ~ x == 0 -> x*y == 0 -> y == 0.
+Proof.
+ intros (x1, x2) (y1, y2).
+ unfold Qeq, Qmult; simpl; intros.
+ apply Zmult_integral_l with x1; auto with zarith.
+ rewrite <- H0; ring.
+Qed.
+
+(** Inverse and division. *) 
+
+Theorem Qmult_inv_r : forall x, ~ x == 0 -> x*(/x) == 1.
+Proof.
+ intros (x1, x2); unfold Qeq, Qdiv, Qmult; case x1; simpl;
+  intros; simpl_mult; try ring.
+ elim H; auto. 
+Qed.
+
+Lemma Qinv_mult_distr : forall p q, / (p * q) == /p * /q.
+Proof.
+intros (x1,x2) (y1,y2); unfold Qeq, Qinv, Qmult; simpl.
+destruct x1; simpl; auto; 
+ destruct y1; simpl; auto.
+Qed.
+
+Theorem Qdiv_mult_l : forall x y, ~ y == 0 -> (x*y)/y == x.
+Proof.
+ intros; unfold Qdiv.
+ rewrite <- (Qmult_assoc x y (Qinv y)).
+ rewrite (Qmult_inv_r y H).
+ apply Qmult_1_r.
+Qed.
+
+Theorem Qmult_div_r : forall x y, ~ y == 0 -> y*(x/y) == x.
+Proof.
+ intros; unfold Qdiv.
+ rewrite (Qmult_assoc y x (Qinv y)).
+ rewrite (Qmult_comm y x).
+ fold (Qdiv (Qmult x y) y).
+ apply Qdiv_mult_l; auto.
+Qed.
+
+(** Properties of order upon Q. *)
+
+Lemma Qle_refl : forall x, x<=x.
+Proof.
+unfold Qle; auto with zarith.
+Qed.
+
+Lemma Qle_antisym : forall x y, x<=y -> y<=x -> x==y.
+Proof.
+unfold Qle, Qeq; auto with zarith.
+Qed.
+
+Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z.
+Proof.
+unfold Qle; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
+Open Scope Z_scope.
+apply Zmult_le_reg_r with ('y2).
+red; trivial.
+apply Zle_trans with (y1 * 'x2 * 'z2).
+replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
+apply Zmult_le_compat_r; auto with zarith. 
+replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
+replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
+apply Zmult_le_compat_r; auto with zarith. 
+Open Scope Q_scope.
+Qed.
+
+Lemma Qlt_not_eq : forall x y, x<y -> ~ x==y.
+Proof.
+unfold Qlt, Qeq; auto with zarith.
+Qed.
+
+(** Large = strict or equal *)
+
+Lemma Qlt_le_weak : forall x y, x<y -> x<=y.
+Proof.
+unfold Qle, Qlt; auto with zarith.
+Qed.
+
+Lemma Qle_lt_trans : forall x y z, x<=y -> y<z -> x<z.
+Proof.
+unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
+Open Scope Z_scope.
+apply Zgt_lt.
+apply Zmult_gt_reg_r with ('y2).
+red; trivial.
+apply Zgt_le_trans with (y1 * 'x2 * 'z2).
+replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
+replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
+apply Zmult_gt_compat_r; auto with zarith. 
+replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
+apply Zmult_le_compat_r; auto with zarith. 
+Open Scope Q_scope.
+Qed.
+
+Lemma Qlt_le_trans : forall x y z, x<y -> y<=z -> x<z.
+Proof.
+unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
+Open Scope Z_scope.
+apply Zgt_lt.
+apply Zmult_gt_reg_r with ('y2).
+red; trivial.
+apply Zle_gt_trans with (y1 * 'x2 * 'z2).
+replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
+replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
+apply Zmult_le_compat_r; auto with zarith. 
+replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
+apply Zmult_gt_compat_r; auto with zarith. 
+Open Scope Q_scope.
+Qed.
+
+Lemma Qlt_trans : forall x y z, x<y -> y<z -> x<z.
+Proof.
+intros.
+apply Qle_lt_trans with y; auto.
+apply Qlt_le_weak; auto.
+Qed.
+
+(** [x<y] iff [~(y<=x)] *)
+
+Lemma Qnot_lt_le : forall x y, ~ x<y -> y<=x.
+Proof.
+unfold Qle, Qlt; auto with zarith.
+Qed.
+
+Lemma Qnot_le_lt : forall x y, ~ x<=y -> y<x.
+Proof.
+unfold Qle, Qlt; auto with zarith.
+Qed.
+
+Lemma Qlt_not_le : forall x y, x<y -> ~ y<=x.
+Proof.
+unfold Qle, Qlt; auto with zarith.
+Qed.
+
+Lemma Qle_not_lt : forall x y, x<=y -> ~ y<x.
+Proof.
+unfold Qle, Qlt; auto with zarith.
+Qed.
+
+Lemma Qle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y.
+Proof.
+unfold Qle, Qlt, Qeq; intros; apply Zle_lt_or_eq; auto.
+Qed.
+
+(** Some decidability results about orders. *)
+
+Lemma Q_dec : forall x y, {x<y} + {y<x} + {x==y}.
+Proof.
+unfold Qlt, Qle, Qeq; intros.
+exact (Z_dec' (Qnum x * QDen y) (Qnum y * QDen x)).
+Defined.
+
+Lemma Qlt_le_dec : forall x y, {x<y} + {y<=x}.
+Proof.
+unfold Qlt, Qle; intros.
+exact (Z_lt_le_dec (Qnum x * QDen y) (Qnum y * QDen x)).
+Defined.
+
+(** Compatibility of operations with respect to order. *)
+
+Lemma Qopp_le_compat : forall p q, p<=q -> -q <= -p.
+Proof.
+intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl.
+do 2 rewrite <- Zopp_mult_distr_l; omega.
+Qed.
+
+Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p.
+Proof.
+intros (x1,x2) (y1,y2); unfold Qle; simpl.
+rewrite <- Zopp_mult_distr_l.
+split; omega.
+Qed.
+
+Lemma Qlt_minus_iff : forall p q, p < q <-> 0 < q+-p.
+Proof.
+intros (x1,x2) (y1,y2); unfold Qlt; simpl.
+rewrite <- Zopp_mult_distr_l.
+split; omega.
+Qed.
+
+Lemma Qplus_le_compat :
+ forall x y z t, x<=y -> z<=t -> x+z <= y+t.
+Proof.
+unfold Qplus, Qle; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2);
+ simpl; simpl_mult.
+Open Scope Z_scope.
+intros.
+match goal with |- ?a <= ?b => ring a; ring b end.
+apply Zplus_le_compat.
+replace ('t2 * ('y2 * (z1 * 'x2))) with (z1 * 't2 * ('y2 * 'x2)) by ring.
+replace ('z2 * ('x2 * (t1 * 'y2))) with (t1 * 'z2 * ('y2 * 'x2)) by ring.
+apply Zmult_le_compat_r; auto with zarith.
+replace ('t2 * ('y2 * ('z2 * x1))) with (x1 * 'y2 * ('z2 * 't2)) by ring.
+replace ('z2 * ('x2 * ('t2 * y1))) with (y1 * 'x2 * ('z2 * 't2)) by ring.
+apply Zmult_le_compat_r; auto with zarith.
+Open Scope Q_scope.
+Qed.
+
+Lemma Qmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z.
+Proof.
+intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
+Open Scope Z_scope.
+intros; simpl_mult.
+replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring.
+replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring.
+apply Zmult_le_compat_r; auto with zarith.
+Open Scope Q_scope.
+Qed.
+
+Lemma Qmult_lt_0_le_reg_r : forall x y z, 0 <  z  -> x*z <= y*z -> x <= y.
+Proof.
+intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
+Open Scope Z_scope.
+simpl_mult.
+replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring.
+replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring.
+intros; apply Zmult_le_reg_r with (c1*'c2); auto with zarith.
+Open Scope Q_scope.
+Qed.
+
+Lemma Qmult_lt_compat_r : forall x y z, 0 < z  -> x < y -> x*z < y*z.
+Proof.
+intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
+Open Scope Z_scope.
+intros; simpl_mult.
+replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring.
+replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring.
+apply Zmult_lt_compat_r; auto with zarith.
+apply Zmult_lt_0_compat.
+omega.
+compute; auto.
+Open Scope Q_scope.
+Qed.
+
+(** Rational to the n-th power *)
+
+Fixpoint Qpower (q:Q)(n:nat) { struct n } : Q := 
+ match n with 
+  | O => 1
+  | S n => q * (Qpower q n)
+ end. 
+
+Notation " q ^ n " := (Qpower q n) : Q_scope.
+
+Lemma Qpower_1 : forall n, 1^n == 1.
+Proof.
+induction n; simpl; auto with qarith.
+rewrite IHn; auto with qarith.
+Qed.
+
+Lemma Qpower_0 : forall n, n<>O -> 0^n == 0.
+Proof.
+destruct n; simpl.
+destruct 1; auto.
+intros. 
+compute; auto.
+Qed.
+
+Lemma Qpower_pos : forall p n, 0 <= p -> 0 <= p^n.
+Proof.
+induction n; simpl; auto with qarith.
+intros; compute; intro; discriminate.
+intros.
+apply Qle_trans with (0*(p^n)).
+compute; intro; discriminate.
+apply Qmult_le_compat_r; auto.
+Qed.
+
+Lemma Qinv_power_n : forall n p, (1#p)^n == /(inject_Z ('p))^n.
+Proof.
+induction n.
+compute; auto.
+simpl.
+intros; rewrite IHn; clear IHn.
+unfold Qdiv; rewrite Qinv_mult_distr.
+setoid_replace (1#p) with (/ inject_Z ('p)).
+apply Qeq_refl.
+compute; auto.
+Qed.
+
+
diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v
new file mode 100644
index 00000000..5b7480c1
--- /dev/null
+++ b/theories/QArith/Qreals.v
@@ -0,0 +1,213 @@
+(************************************************************************)
+(*  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: Qreals.v 8883 2006-05-31 21:56:37Z letouzey $ i*)
+
+Require Export Rbase.
+Require Export QArith_base.
+
+(** * A field tactic for rational numbers. *)
+
+(** Since field cannot operate on setoid datatypes (yet?), 
+  we translate Q goals into reals before applying field. *)
+
+Lemma IZR_nz : forall p : positive, IZR (Zpos p) <> 0%R.
+intros; apply not_O_IZR; auto with qarith.
+Qed.
+
+Hint Immediate IZR_nz.
+Hint Resolve Rmult_integral_contrapositive.
+
+Definition Q2R (x : Q) : R := (IZR (Qnum x) * / IZR (QDen x))%R.
+
+Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y.
+Proof.
+unfold Qeq, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+apply eq_IZR.
+do 2 rewrite mult_IZR.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+assert ((X2 * X1 * / X2)%R = (X2 * (Y1 * / Y2))%R).
+rewrite <- H; field; auto.
+rewrite Rinv_r_simpl_m in H0; auto; rewrite H0; field; auto.
+Qed.
+
+Lemma Qeq_eqR : forall x y : Q, x==y -> Q2R x = Q2R y.
+Proof.
+unfold Qeq, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+assert ((X1 * Y2)%R = (Y1 * X2)%R).
+ unfold X1, X2, Y1, Y2 in |- *; do 2 rewrite <- mult_IZR.
+ apply IZR_eq; auto.
+clear H.
+field; auto.
+rewrite <- H0; field; auto.
+Qed.
+
+Lemma Rle_Qle : forall x y : Q, (Q2R x <= Q2R y)%R -> x<=y.
+Proof.
+unfold Qle, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+apply le_IZR.
+do 2 rewrite mult_IZR.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto).
+replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto).
+apply Rmult_le_compat_r; auto.
+apply Rmult_le_pos.
+unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_le;
+ auto with zarith.
+unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_le;
+ auto with zarith.
+Qed.
+
+Lemma Qle_Rle : forall x y : Q, x<=y -> (Q2R x <= Q2R y)%R.
+Proof.
+unfold Qle, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+assert (X1 * Y2 <= Y1 * X2)%R.
+ unfold X1, X2, Y1, Y2 in |- *; do 2 rewrite <- mult_IZR.
+ apply IZR_le; auto.
+clear H.
+replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto).
+replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto).
+apply Rmult_le_compat_r; auto.
+apply Rmult_le_pos; apply Rlt_le; apply Rinv_0_lt_compat.
+unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+Qed.
+
+Lemma Rlt_Qlt : forall x y : Q, (Q2R x < Q2R y)%R -> x<y.
+Proof.
+unfold Qlt, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+apply lt_IZR.
+do 2 rewrite mult_IZR.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto).
+replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto).
+apply Rmult_lt_compat_r; auto.
+apply Rmult_lt_0_compat.
+unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+Qed.
+
+Lemma Qlt_Rlt : forall x y : Q, x<y -> (Q2R x < Q2R y)%R.
+Proof.
+unfold Qlt, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+assert (X1 * Y2 < Y1 * X2)%R.
+ unfold X1, X2, Y1, Y2 in |- *; do 2 rewrite <- mult_IZR.
+ apply IZR_lt; auto.
+clear H.
+replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto).
+replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto).
+apply Rmult_lt_compat_r; auto.
+apply Rmult_lt_0_compat; apply Rinv_0_lt_compat.
+unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+Qed.
+
+Lemma Q2R_plus : forall x y : Q, Q2R (x+y) = (Q2R x + Q2R y)%R.
+Proof.
+unfold Qplus, Qeq, Q2R in |- *; intros (x1, x2) (y1, y2);
+ unfold Qden, Qnum in |- *.
+simpl_mult.
+rewrite plus_IZR.
+do 3 rewrite mult_IZR.
+field; auto.
+Qed.
+
+Lemma Q2R_mult : forall x y : Q, Q2R (x*y) = (Q2R x * Q2R y)%R.
+Proof.
+unfold Qmult, Qeq, Q2R in |- *; intros (x1, x2) (y1, y2);
+ unfold Qden, Qnum in |- *.
+simpl_mult.
+do 2 rewrite mult_IZR.
+field; auto.
+Qed.
+
+Lemma Q2R_opp : forall x : Q, Q2R (- x) = (- Q2R x)%R.
+Proof.
+unfold Qopp, Qeq, Q2R in |- *; intros (x1, x2); unfold Qden, Qnum in |- *.
+rewrite Ropp_Ropp_IZR.
+field; auto.
+Qed.
+
+Lemma Q2R_minus : forall x y : Q, Q2R (x-y) = (Q2R x - Q2R y)%R.
+unfold Qminus in |- *; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto.
+Qed.
+
+Lemma Q2R_inv : forall x : Q, ~ x==0#1 -> Q2R (/x) = (/ Q2R x)%R.
+Proof.
+unfold Qinv, Q2R, Qeq in |- *; intros (x1, x2); unfold Qden, Qnum in |- *.
+case x1.
+simpl in |- *; intros; elim H; trivial.
+intros; field; auto.
+apply Rmult_integral_contrapositive; split; auto.
+apply Rmult_integral_contrapositive; split; auto.
+apply Rinv_neq_0_compat; auto.
+intros; field; auto.
+do 2 rewrite <- mult_IZR.
+simpl in |- *; rewrite Pmult_comm; auto.
+apply Rmult_integral_contrapositive; split; auto.
+apply Rmult_integral_contrapositive; split; auto.
+apply not_O_IZR; auto with qarith.
+apply Rinv_neq_0_compat; auto.
+Qed.
+
+Lemma Q2R_div :
+ forall x y : Q, ~ y==0#1 -> Q2R (x/y) = (Q2R x / Q2R y)%R.
+Proof.
+unfold Qdiv, Rdiv in |- *.
+intros; rewrite Q2R_mult.
+rewrite Q2R_inv; auto.
+Qed.
+
+Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl.
+
+Ltac QField := apply eqR_Qeq; autorewrite with q2r_simpl; try field; auto.
+
+(** Examples of use: *)
+
+Goal forall x y z : Q, (x+y)*z == (x*z)+(y*z).
+intros; QField.
+Abort.
+
+Goal forall x y : Q, ~ y==0#1 -> (x/y)*y == x.
+intros; QField.
+intro; apply H; apply eqR_Qeq.
+rewrite H0; unfold Q2R in |- *; simpl in |- *; field; auto with real.
+Abort.
\ No newline at end of file
diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v
new file mode 100644
index 00000000..049c195a
--- /dev/null
+++ b/theories/QArith/Qreduction.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: Qreduction.v 8883 2006-05-31 21:56:37Z letouzey $ i*)
+
+(** * Normalisation functions for rational numbers. *)
+
+Require Export QArith_base.
+Require Export Znumtheory.
+
+(** First, a function that (tries to) build a positive back from a Z. *)
+
+Definition Z2P (z : Z) :=
+  match z with
+  | Z0 => 1%positive
+  | Zpos p => p
+  | Zneg p => p
+  end.
+
+Lemma Z2P_correct : forall z : Z, (0 < z)%Z -> Zpos (Z2P z) = z.
+Proof.
+ simple destruct z; simpl in |- *; auto; intros; discriminate.
+Qed.
+
+Lemma Z2P_correct2 : forall z : Z, 0%Z <> z -> Zpos (Z2P z) = Zabs z.
+Proof.
+ simple destruct z; simpl in |- *; auto; intros; elim H; auto.
+Qed.
+
+(** A simple cancelation by powers of two *)
+
+Fixpoint Pfactor_twos (p p':positive) {struct p} : (positive*positive) := 
+ match p, p' with 
+  | xO p, xO p' => Pfactor_twos p p'
+  | _, _ => (p,p')
+ end.
+
+Definition Qfactor_twos (q:Q) := 
+ let (p,q) := q in 
+ match p with 
+   | Z0 => 0
+   | Zpos p => let (p,q) := Pfactor_twos p q in (Zpos p)#q
+   | Zneg p => let (p,q) := Pfactor_twos p q in (Zneg p)#q
+ end.
+
+Lemma Pfactor_twos_correct : forall p p', 
+   (p*(snd (Pfactor_twos p p')))%positive = 
+   (p'*(fst (Pfactor_twos p p')))%positive.
+Proof.
+induction p; intros.
+simpl snd; simpl fst; rewrite Pmult_comm; auto.
+destruct p'.
+simpl snd; simpl fst; rewrite Pmult_comm; auto.
+simpl; f_equal; auto.
+simpl snd; simpl fst; rewrite Pmult_comm; auto.
+simpl snd; simpl fst; rewrite Pmult_comm; auto.
+Qed.
+
+Lemma Qfactor_twos_correct : forall q, Qfactor_twos q == q.
+Proof.
+intros (p,q).
+destruct p.
+red; simpl; auto.
+simpl.
+generalize (Pfactor_twos_correct p q); destruct (Pfactor_twos p q).
+red; simpl.
+intros; f_equal.
+rewrite H; apply Pmult_comm.
+simpl.
+generalize (Pfactor_twos_correct p q); destruct (Pfactor_twos p q).
+red; simpl.
+intros; f_equal.
+rewrite H; apply Pmult_comm.
+Qed.
+Hint Resolve Qfactor_twos_correct.
+
+(** Simplification of fractions using [Zgcd].
+  This version can compute within Coq. *)
+
+Definition Qred (q:Q) := 
+  let (q1,q2) := Qfactor_twos q in 
+  let (r1,r2) := snd (Zggcd q1 (Zpos q2)) in r1#(Z2P r2).
+
+Lemma Qred_correct : forall q, (Qred q) == q.
+Proof.
+intros; apply Qeq_trans with (Qfactor_twos q); auto.
+unfold Qred.
+destruct (Qfactor_twos q) as (n,d); red; simpl.
+generalize (Zggcd_gcd n ('d)) (Zgcd_is_pos n ('d)) 
+  (Zgcd_is_gcd n ('d)) (Zggcd_correct_divisors n ('d)).
+destruct (Zggcd n (Zpos d)) as (g,(nn,dd)); simpl.
+Open Scope Z_scope.
+intuition.
+rewrite <- H in H0,H1; clear H.
+rewrite H3; rewrite H4.
+assert (0 <> g).
+  intro; subst g; discriminate.
+
+assert (0 < dd).
+  apply Zmult_gt_0_lt_0_reg_r with g.
+  omega.
+  rewrite Zmult_comm.
+  rewrite <- H4; compute; auto.
+rewrite Z2P_correct; auto.
+ring.
+Qed.
+
+Lemma Qred_complete : forall p q,  p==q -> Qred p = Qred q.
+Proof.
+intros.
+assert (Qfactor_twos p == Qfactor_twos q).
+ apply Qeq_trans with p; auto.
+ apply Qeq_trans with q; auto.
+ symmetry; auto.
+clear H.
+unfold Qred.
+destruct (Qfactor_twos p) as (a,b); 
+destruct (Qfactor_twos q) as (c,d); clear p q.
+unfold Qeq in *; simpl in *.
+Open Scope Z_scope.
+generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b)) 
+ (Zgcd_is_pos a ('b)) (Zggcd_correct_divisors a ('b)).
+destruct (Zggcd a (Zpos b)) as (g,(aa,bb)).
+generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d)) 
+ (Zgcd_is_pos c ('d)) (Zggcd_correct_divisors c ('d)).
+destruct (Zggcd c (Zpos d)) as (g',(cc,dd)).
+simpl.
+intro H; rewrite <- H; clear H.
+intros Hg'1 Hg'2 (Hg'3,Hg'4).
+intro H; rewrite <- H; clear H.
+intros Hg1 Hg2 (Hg3,Hg4).
+intros.
+assert (g <> 0).
+  intro; subst g; discriminate.
+assert (g' <> 0).
+  intro; subst g'; discriminate.
+elim (rel_prime_cross_prod aa bb cc dd).
+congruence.
+unfold rel_prime in |- *.
+(*rel_prime*)
+constructor.
+exists aa; auto with zarith.
+exists bb; auto with zarith.
+intros.
+inversion Hg1.
+destruct (H6 (g*x)).
+rewrite Hg3.
+destruct H2 as (xa,Hxa); exists xa; rewrite Hxa; ring.
+rewrite Hg4.
+destruct H3 as (xb,Hxb); exists xb; rewrite Hxb; ring.
+exists q.
+apply Zmult_reg_l with g; auto.
+pattern g at 1; rewrite H7; ring.
+(* /rel_prime *)
+unfold rel_prime in |- *.
+(* rel_prime *)
+constructor.
+exists cc; auto with zarith.
+exists dd; auto with zarith.
+intros.
+inversion Hg'1.
+destruct (H6 (g'*x)).
+rewrite Hg'3.
+destruct H2 as (xc,Hxc); exists xc; rewrite Hxc; ring.
+rewrite Hg'4.
+destruct H3 as (xd,Hxd); exists xd; rewrite Hxd; ring.
+exists q.
+apply Zmult_reg_l with g'; auto.
+pattern g' at 1; rewrite H7; ring.
+(* /rel_prime *)
+assert (0<bb); [|auto with zarith].
+  apply Zmult_gt_0_lt_0_reg_r with g.
+  omega.
+  rewrite Zmult_comm.
+  rewrite <- Hg4; compute; auto.
+assert (0<dd); [|auto with zarith].
+  apply Zmult_gt_0_lt_0_reg_r with g'.
+  omega.
+  rewrite Zmult_comm.
+  rewrite <- Hg'4; compute; auto.
+apply Zmult_reg_l with (g'*g).
+intro H2; elim (Zmult_integral _ _ H2); auto.
+replace (g'*g*(aa*dd)) with ((g*aa)*(g'*dd)); [|ring].
+replace (g'*g*(bb*cc)) with ((g'*cc)*(g*bb)); [|ring].
+rewrite <- Hg3; rewrite <- Hg4; rewrite <- Hg'3; rewrite <- Hg'4; auto.
+Open Scope Q_scope.
+Qed.
+
+Add Morphism Qred : Qred_comp. 
+Proof.
+intros q q' H.
+rewrite (Qred_correct q); auto.
+rewrite (Qred_correct q'); auto.
+Qed.
+
+(** Another version, dedicated to extraction *)
+
+Definition Qred_extr (q : Q) :=
+  let (q1, q2) := Qfactor_twos q in
+  let (p,_) := Zggcd_spec_pos (Zpos q2) (Zle_0_pos q2) q1 in  
+  let (r2,r1) := snd p in r1#(Z2P r2).
+
+Lemma Qred_extr_Qred : forall q, Qred_extr q = Qred q.
+Proof.
+unfold Qred, Qred_extr.
+intro q; destruct (Qfactor_twos q) as (n,p); clear q.
+Open Scope Z_scope.
+destruct (Zggcd_spec_pos (' p) (Zle_0_pos p) n) as ((g,(pp,nn)),H).
+generalize (H (Zle_0_pos p)); clear H; intros (Hg1,(Hg2,(Hg4,Hg3))).
+simpl.
+generalize (Zggcd_gcd n ('p)) (Zgcd_is_gcd n ('p)) 
+ (Zgcd_is_pos n ('p)) (Zggcd_correct_divisors n ('p)).
+destruct (Zggcd n (Zpos p)) as (g',(nn',pp')); simpl.
+intro H; rewrite <- H; clear H.
+intros Hg'1 Hg'2 (Hg'3,Hg'4).
+assert (g<>0).
+ intro; subst g; discriminate.
+destruct (Zis_gcd_uniqueness_apart_sign n ('p) g g'); auto.
+apply Zis_gcd_sym; auto.
+subst g'.
+f_equal.
+apply Zmult_reg_l with g; auto; congruence.
+f_equal.
+apply Zmult_reg_l with g; auto; congruence.
+elimtype False; omega.
+Open Scope Q_scope.
+Qed.
+
+Add Morphism Qred_extr : Qred_extr_comp. 
+Proof.
+intros q q' H.
+do 2 rewrite Qred_extr_Qred.
+rewrite (Qred_correct q); auto.
+rewrite (Qred_correct q'); auto.
+Qed.
+
+Definition Qplus' (p q : Q) := Qred (Qplus p q).
+Definition Qmult' (p q : Q) := Qred (Qmult p q). 
+
+Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q).
+Proof.
+intros; unfold Qplus' in |- *; apply Qred_correct; auto.
+Qed.
+
+Lemma Qmult'_correct : forall p q : Q, (Qmult' p q)==(Qmult p q).
+Proof.
+intros; unfold Qmult' in |- *; apply Qred_correct; auto.
+Qed.
+
+Add Morphism Qplus' : Qplus'_comp.
+Proof.
+intros; unfold Qplus' in |- *.
+rewrite H; rewrite H0; auto with qarith.
+Qed.
+
+Add Morphism Qmult' : Qmult'_comp.
+intros; unfold Qmult' in |- *.
+rewrite H; rewrite H0; auto with qarith.
+Qed.
+
diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v
new file mode 100644
index 00000000..774b20f4
--- /dev/null
+++ b/theories/QArith/Qring.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: Qring.v 8883 2006-05-31 21:56:37Z letouzey $ i*)
+
+Require Import Ring.
+Require Export Setoid_ring.
+Require Export QArith_base.
+
+(** * A ring tactic for rational numbers *)
+
+Definition Qeq_bool (x y : Q) :=
+  if Qeq_dec x y then true else false.
+
+Lemma Qeq_bool_correct : forall x y : Q, Qeq_bool x y = true -> x==y.
+intros x y; unfold Qeq_bool in |- *; case (Qeq_dec x y); simpl in |- *; auto.
+intros _ H; inversion H.
+Qed.
+
+Definition Qsrt : Setoid_Ring_Theory Qeq Qplus Qmult 1 0 Qopp Qeq_bool.
+Proof.
+constructor.
+exact Qplus_comm.
+exact Qplus_assoc.
+exact Qmult_comm.
+exact Qmult_assoc.
+exact Qplus_0_l.
+exact Qmult_1_l.
+exact Qplus_opp_r.
+exact Qmult_plus_distr_l.
+unfold Is_true; intros x y; generalize (Qeq_bool_correct x y);
+ case (Qeq_bool x y); auto.
+Qed.
+
+Add Setoid Ring Q Qeq Q_Setoid Qplus Qmult 1 0 Qopp Qeq_bool
+ Qplus_comp Qmult_comp Qopp_comp Qsrt
+ [ Qmake (*inject_Z*)  Zpos 0%Z Zneg xI xO 1%positive ].
+
+(** Exemple of use: *)
+
+Section Examples. 
+
+Let ex1 : forall x y z : Q, (x+y)*z ==  (x*z)+(y*z).
+intros.
+ring.
+Qed.
+
+Let ex2 : forall x y : Q, x+y == y+x.
+intros. 
+ring.
+Qed.
+
+Let ex3 : forall x y z : Q, (x+y)+z == x+(y+z).
+intros.
+ring.
+Qed.
+
+Let ex4 : (inject_Z 1)+(inject_Z 1)==(inject_Z 2).
+ring.
+Qed.
+
+Let ex5 : 1+1 == 2#1.
+ring.
+Qed.
+
+Let ex6 : (1#1)+(1#1) == 2#1.
+ring.
+Qed.
+
+Let ex7 : forall x : Q, x-x== 0#1.
+intro.
+ring.
+Qed.
+
+End Examples.
+
+Lemma Qopp_plus : forall a b,  -(a+b) == -a + -b.
+Proof.
+intros; ring.
+Qed.
+
+Lemma Qopp_opp : forall q, - -q==q.
+Proof.
+intros; ring.
+Qed.
+
diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v
index 436a8011..0d1b06e2 100644
--- a/theories/Reals/Rbasic_fun.v
+++ b/theories/Reals/Rbasic_fun.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rbasic_fun.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id: Rbasic_fun.v 8838 2006-05-22 09:26:36Z herbelin $ i*)
 
 (*********************************************************)
 (**          Complements for the real numbers            *)
@@ -107,11 +107,13 @@ 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.
+Lemma Rmax_comm : 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.
 
+Notation RmaxSym := Rmax_comm (only parsing).
+
 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 |- *.
@@ -467,4 +469,4 @@ 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/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v
index 71ab0b4c..b628de73 100644
--- a/theories/Reals/RiemannInt_SF.v
+++ b/theories/Reals/RiemannInt_SF.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
  
-(*i $Id: RiemannInt_SF.v 6338 2004-11-22 09:10:51Z gregoire $ i*)
+(*i $Id: RiemannInt_SF.v 8837 2006-05-22 08:41:18Z herbelin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -218,17 +218,10 @@ 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.
+destruct 1 as (x,(H0,(H1,(H2,(H3,H4))))); exists x;
+  repeat split; try assumption.
+rewrite H1; apply Rmin_comm.
+rewrite H2; apply Rmax_comm.
 Qed.
 
 Lemma StepFun_P6 :
@@ -1483,19 +1476,16 @@ Lemma StepFun_P26 :
    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;
+Proof.
+intros a b l f g l1 (x0,(H0,(H1,(H2,(H3,H4))))) 
+                    (x,(_,(_,(_,(_,H9))))).
+ exists (FF l1 (fun x:R => f x + l * g x)); repeat split; try assumption.
+apply StepFun_P20; rewrite H3; auto with arith.
+intros i H8 x1 H10; unfold open_interval in H10, H9, H4; 
  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];
+red in |- *; intro H11; rewrite H11 in H8; elim (lt_n_O _ H8).
+destruct (RList_P19 _ H11) as (r,(r0,H12));
  rewrite H12; unfold FF in |- *;
  change
    (pos_Rl x0 i + l * pos_Rl x i =
@@ -2142,18 +2132,16 @@ 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);
+Proof.
+intros f a b c H H0 (l1,(lf1,H1)) (l2,(lf2,H2));
+ destruct (total_order_T a b) as [[Hltab|Hab]|Hgtab].
+ destruct (total_order_T b c) as [[Hltbc|Hbc]|Hgtbc].
+exists (cons_Rlist l1 l2); exists (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)).
+exists l1; exists lf1; rewrite Hbc in H1; assumption.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgtbc)).
+exists l2; exists lf2; rewrite <- Hab in H2; assumption.
+elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgtab)).
 Qed.
 
 Lemma StepFun_P42 :
@@ -2431,14 +2419,14 @@ elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X;
      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.
+intro X; 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).
+intros X lf1 a b c f H H0; 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.
@@ -2452,7 +2440,7 @@ unfold Rmin in |- *; case (Rle_dec a b); intro;
 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].
+intros r1 r2 _ X0 lf1 a b c f H H0; 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}).
@@ -2546,13 +2534,13 @@ elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X;
      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;
+intro X; 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).
+intros X lf1 a b c f H H0; 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.
@@ -2566,7 +2554,7 @@ unfold Rmin in |- *; case (Rle_dec a b); intro;
 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].
+intros r1 r2 _ X0 lf1 a b c f H H0; 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}).
diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v
index 6ff73438..b670fc19 100644
--- a/theories/Setoids/Setoid.v
+++ b/theories/Setoids/Setoid.v
@@ -7,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Setoid.v 6306 2004-11-16 16:11:10Z sacerdot $: i*)
+(*i $Id: Setoid.v 8866 2006-05-28 16:21:04Z herbelin $: i*)
 
 Require Export Relation_Definitions.
 
@@ -339,7 +339,7 @@ with Morphism_Context_List_rect2 := Induction for Morphism_Context_List Sort Typ
 Definition product_of_arguments : Arguments -> Type.
  induction 1.
    exact (carrier_of_relation_class a).
-   exact (prodT (carrier_of_relation_class a) IHX).
+   exact (prod (carrier_of_relation_class a) IHX).
 Defined.
 
 Definition get_rewrite_direction: rewrite_direction -> Argument_Class -> rewrite_direction.
@@ -662,3 +662,26 @@ Implicit Arguments Setoid_Theory [].
 Implicit Arguments Seq_refl [].
 Implicit Arguments Seq_sym [].
 Implicit Arguments Seq_trans [].
+
+
+(* Some tactics for manipulating Setoid Theory not officially 
+   declared as Setoid. *)
+
+Ltac trans_st x := match goal with 
+  | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+     apply (Seq_trans _ _ H) with x; auto
+ end.
+
+Ltac sym_st := match goal with 
+  | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+     apply (Seq_sym _ _ H); auto
+ end.
+
+Ltac refl_st := match goal with 
+  | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+     apply (Seq_refl _ _ H); auto
+ end.
+
+Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A).
+Proof. constructor; congruence. Qed.
+
diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v
new file mode 100644
index 00000000..e56ff27d
--- /dev/null
+++ b/theories/Sorting/PermutEq.v
@@ -0,0 +1,241 @@
+(************************************************************************)
+(*  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: PermutEq.v 8853 2006-05-23 18:17:38Z herbelin $ i*)
+
+Require Import Omega.
+Require Import Relations.
+Require Import Setoid.
+Require Import List.
+Require Import Multiset.
+Require Import Permutation. 
+
+Set Implicit Arguments.
+
+(** This file is similar to [PermutSetoid], except that the equality used here
+      is Coq usual one instead of a setoid equality. In particular, we can then 
+      prove the equivalence between [List.Permutation] and 
+      [Permutation.permutation].
+*)
+
+Section Perm.
+
+Variable A : Set.
+Hypothesis eq_dec : forall x y:A, {x=y} + {~ x=y}.
+
+Notation permutation := (permutation _ eq_dec).
+Notation list_contents := (list_contents _ eq_dec).
+
+(** we can use [multiplicity] to define [In] and [NoDup]. *)
+
+Lemma multiplicity_In : 
+  forall l a, In a l <-> 0 < multiplicity (list_contents l) a.
+Proof.
+induction l.
+simpl.
+split; inversion 1.
+simpl.
+split; intros.
+inversion_clear H.
+subst a0.
+destruct (eq_dec a a) as [_|H]; auto with arith; destruct H; auto.
+destruct (eq_dec a a0) as [H1|H1]; auto with arith; simpl.
+rewrite <- IHl; auto.
+destruct (eq_dec a a0); auto.
+simpl in H.
+right; rewrite IHl; auto.
+Qed.
+
+Lemma multiplicity_In_O :
+  forall l a, ~ In a l -> multiplicity (list_contents l) a = 0.
+Proof.
+intros l a; rewrite multiplicity_In; 
+ destruct (multiplicity (list_contents l) a); auto.
+destruct 1; auto with arith.
+Qed.
+
+Lemma multiplicity_In_S :
+ forall l a, In a l -> multiplicity (list_contents l) a >= 1.
+Proof.
+intros l a; rewrite multiplicity_In; auto.
+Qed.
+
+Lemma multiplicity_NoDup : 
+  forall l, NoDup l <-> (forall a, multiplicity (list_contents l) a <= 1).
+Proof.
+induction l.
+simpl.
+split; auto with arith.
+intros; apply NoDup_nil.
+split; simpl.
+inversion_clear 1.
+rewrite IHl in H1.
+intros; destruct (eq_dec a a0) as [H2|H2]; simpl; auto.
+subst a0.
+rewrite multiplicity_In_O; auto.
+intros; constructor.
+rewrite multiplicity_In.
+generalize (H a).
+destruct (eq_dec a a) as [H0|H0].
+destruct (multiplicity (list_contents l) a); auto with arith.
+simpl; inversion 1. 
+inversion H3.
+destruct H0; auto.
+rewrite IHl; intros.
+generalize (H a0); auto with arith.
+destruct (eq_dec a a0); simpl; auto with arith.
+Qed.
+
+Lemma NoDup_permut : 
+  forall l l', NoDup l -> NoDup l' -> 
+     (forall x, In x l <-> In x l') -> permutation l l'.
+Proof.
+intros.
+red; unfold meq; intros.
+rewrite multiplicity_NoDup in H, H0. 
+generalize (H a) (H0 a) (H1 a); clear H H0 H1.
+do 2 rewrite multiplicity_In.
+destruct 3; omega.
+Qed.
+
+(** Permutation is compatible with In. *)
+Lemma permut_In_In :
+  forall l1 l2 e, permutation l1 l2 -> In e l1 -> In e l2.
+Proof.
+unfold Permutation.permutation, meq; intros l1 l2 e P IN.
+generalize (P e); clear P.
+destruct (In_dec eq_dec e l2) as [H|H]; auto.
+rewrite (multiplicity_In_O _ _ H).
+intros.
+generalize (multiplicity_In_S _ _ IN).
+rewrite H0.
+inversion 1.
+Qed.
+
+Lemma permut_cons_In :
+  forall l1 l2 e, permutation (e :: l1) l2 -> In e l2.
+Proof.
+intros; eapply permut_In_In; eauto.
+red; auto.
+Qed.
+
+(** Permutation of an empty list. *)
+Lemma permut_nil :
+ forall l, permutation l nil -> l = nil.
+Proof.
+intro l; destruct l as [ | e l ]; trivial.
+assert (In e (e::l)) by (red; auto).
+intro Abs; generalize (permut_In_In _ Abs H).
+inversion 1.
+Qed.
+
+(** When used with [eq], this permutation notion is equivalent to 
+  the one defined in [List.v]. *)
+
+Lemma permutation_Permutation : 
+ forall l l', Permutation l l' <-> permutation l l'.
+Proof.
+split.
+induction 1.
+apply permut_refl.
+apply permut_cons; auto.
+change (permutation (y::x::l) ((x::nil)++y::l)).
+apply permut_add_cons_inside; simpl; apply permut_refl.
+apply permut_tran with l'; auto.
+revert l'.
+induction l.
+intros.
+rewrite (permut_nil (permut_sym H)).
+apply Permutation_refl.
+intros.
+destruct (In_split _ _ (permut_cons_In H)) as (h2,(t2,H1)).
+subst l'.
+apply Permutation_cons_app.
+apply IHl.
+apply permut_remove_hd with a; auto.
+Qed.
+
+(** Permutation for short lists. *)
+
+Lemma permut_length_1:
+ forall a b, permutation (a :: nil) (b :: nil)  -> a=b.
+Proof.
+intros a b; unfold Permutation.permutation, meq; intro P;
+generalize (P b); clear P; simpl.
+destruct (eq_dec b b) as [H|H]; [ | destruct H; auto].
+destruct (eq_dec a b); simpl; auto; intros; discriminate.
+Qed.
+
+Lemma permut_length_2 :
+ forall a1 b1 a2 b2, permutation (a1 :: b1 :: nil) (a2 :: b2 :: nil) ->
+ (a1=a2) /\ (b1=b2) \/ (a1=b2) /\ (a2=b1).
+Proof.
+intros a1 b1 a2 b2 P.
+assert (H:=permut_cons_In P).
+inversion_clear H.
+left; split; auto.
+apply permut_length_1.
+red; red; intros.
+generalize (P a); clear P; simpl.
+destruct (eq_dec a1 a) as [H2|H2]; 
+ destruct (eq_dec a2 a) as [H3|H3]; auto.
+destruct H3; transitivity a1; auto.
+destruct H2; transitivity a2; auto.
+right.
+inversion_clear H0; [|inversion H].
+split; auto.
+apply permut_length_1.
+red; red; intros.
+generalize (P a); clear P; simpl.
+destruct (eq_dec a1 a) as [H2|H2]; 
+ destruct (eq_dec b2 a) as [H3|H3]; auto.
+simpl; rewrite <- plus_n_Sm; inversion 1; auto.
+destruct H3; transitivity a1; auto.
+destruct H2; transitivity b2; auto.
+Qed.
+
+(** Permutation is compatible with length. *)
+Lemma permut_length :
+ forall l1 l2, permutation l1 l2 -> length l1 = length l2.
+Proof.
+induction l1; intros l2 H.
+rewrite (permut_nil (permut_sym H)); auto.
+destruct (In_split _ _ (permut_cons_In H)) as (h2,(t2,H1)).
+subst l2.
+rewrite app_length.
+simpl; rewrite <- plus_n_Sm; f_equal.
+rewrite <- app_length.
+apply IHl1.
+apply permut_remove_hd with a; auto.
+Qed.
+
+Variable B : Set.
+Variable eqB_dec : forall x y:B, { x=y }+{ ~x=y }. 
+
+(** Permutation is compatible with map. *)
+
+Lemma permutation_map :
+  forall f l1 l2, permutation l1 l2 -> 
+   Permutation.permutation _ eqB_dec (map f l1) (map f l2).
+Proof.
+intros f; induction l1.
+intros l2 P; rewrite (permut_nil (permut_sym P)); apply permut_refl.
+intros l2 P.
+simpl.
+destruct (In_split _ _ (permut_cons_In P)) as (h2,(t2,H1)).
+subst l2.
+rewrite map_app.
+simpl.
+apply permut_add_cons_inside.
+rewrite <- map_app.
+apply IHl1; auto.
+apply permut_remove_hd with a; auto.
+Qed.
+
+End Perm.
+
diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v
new file mode 100644
index 00000000..46ea088f
--- /dev/null
+++ b/theories/Sorting/PermutSetoid.v
@@ -0,0 +1,243 @@
+(************************************************************************)
+(*  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: PermutSetoid.v 8823 2006-05-16 16:17:43Z letouzey $ i*)
+
+Require Import Omega.
+Require Import Relations.
+Require Import List.
+Require Import Multiset.
+Require Import Permutation. 
+Require Import SetoidList.
+
+Set Implicit Arguments.
+
+(** This file contains additional results about permutations 
+     with respect to an setoid equality (i.e. an equivalence relation). 
+*)
+
+Section Perm.
+
+Variable A : Set.
+Variable eqA : relation A.
+Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+
+Notation permutation := (permutation _ eqA_dec).
+Notation list_contents := (list_contents _ eqA_dec).
+
+(** The following lemmas need some knowledge on [eqA] *)
+
+Variable eqA_refl : forall x, eqA x x.
+Variable eqA_sym : forall x y, eqA x y -> eqA y x.
+Variable eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z.
+
+(** we can use [multiplicity] to define [InA] and [NoDupA]. *)
+
+Lemma multiplicity_InA : 
+  forall l a, InA eqA a l <-> 0 < multiplicity (list_contents l) a.
+Proof.
+induction l.
+simpl.
+split; inversion 1.
+simpl.
+split; intros.
+inversion_clear H.
+destruct (eqA_dec a a0) as [_|H1]; auto with arith.
+destruct H1; auto.
+destruct (eqA_dec a a0); auto with arith.
+simpl; rewrite <- IHl; auto.
+destruct (eqA_dec a a0) as [H0|H0]; auto.
+simpl in H.
+constructor 2; rewrite IHl; auto.
+Qed.
+
+Lemma multiplicity_InA_O :
+  forall l a, ~ InA eqA a l -> multiplicity (list_contents l) a = 0.
+Proof.
+intros l a; rewrite multiplicity_InA; 
+destruct (multiplicity (list_contents l) a); auto with arith.
+destruct 1; auto with arith.
+Qed.
+
+Lemma multiplicity_InA_S :
+ forall l a, InA eqA a l -> multiplicity (list_contents l) a >= 1.
+Proof.
+intros l a; rewrite multiplicity_InA; auto with arith.
+Qed.
+
+Lemma multiplicity_NoDupA : forall l, 
+  NoDupA eqA l <-> (forall a, multiplicity (list_contents l) a <= 1).
+Proof.
+induction l.
+simpl.
+split; auto with arith.
+split; simpl.
+inversion_clear 1.
+rewrite IHl in H1.
+intros; destruct (eqA_dec a a0) as [H2|H2]; simpl; auto.
+rewrite multiplicity_InA_O; auto.
+swap H0.
+apply InA_eqA with a0; auto.
+intros; constructor.
+rewrite multiplicity_InA.
+generalize (H a).
+destruct (eqA_dec a a) as [H0|H0].
+destruct (multiplicity (list_contents l) a); auto with arith.
+simpl; inversion 1. 
+inversion H3.
+destruct H0; auto.
+rewrite IHl; intros.
+generalize (H a0); auto with arith.
+destruct (eqA_dec a a0); simpl; auto with arith.
+Qed.
+
+
+(** Permutation is compatible with InA. *)
+Lemma permut_InA_InA :
+  forall l1 l2 e, permutation l1 l2 -> InA eqA e l1 -> InA eqA e l2.
+Proof.
+intros l1 l2 e.
+do 2 rewrite multiplicity_InA.
+unfold Permutation.permutation, meq.
+intros H;rewrite H; auto.
+Qed.
+
+Lemma permut_cons_InA :
+  forall l1 l2 e, permutation (e :: l1) l2 -> InA eqA e l2.
+Proof.
+intros; apply (permut_InA_InA (e:=e) H); auto.
+Qed.
+
+(** Permutation of an empty list. *)
+Lemma permut_nil :
+ forall l, permutation l nil -> l = nil.
+Proof.
+intro l; destruct l as [ | e l ]; trivial.
+assert (InA eqA e (e::l)) by auto.
+intro Abs; generalize (permut_InA_InA Abs H).
+inversion 1.
+Qed.
+
+(** Permutation for short lists. *)
+
+Lemma permut_length_1:
+ forall a b, permutation (a :: nil) (b :: nil)  -> eqA a b.
+Proof.
+intros a b; unfold Permutation.permutation, meq; intro P;
+generalize (P b); clear P; simpl.
+destruct (eqA_dec b b) as [H|H]; [ | destruct H; auto].
+destruct (eqA_dec a b); simpl; auto; intros; discriminate.
+Qed.
+
+Lemma permut_length_2 :
+ forall a1 b1 a2 b2, permutation (a1 :: b1 :: nil) (a2 :: b2 :: nil) ->
+ (eqA a1 a2) /\ (eqA b1 b2) \/ (eqA a1 b2) /\ (eqA a2 b1).
+Proof.
+intros a1 b1 a2 b2 P.
+assert (H:=permut_cons_InA P).
+inversion_clear H.
+left; split; auto.
+apply permut_length_1.
+red; red; intros.
+generalize (P a); clear P; simpl.
+destruct (eqA_dec a1 a) as [H2|H2]; 
+ destruct (eqA_dec a2 a) as [H3|H3]; auto.
+destruct H3; apply eqA_trans with a1; auto.
+destruct H2; apply eqA_trans with a2; auto.
+right.
+inversion_clear H0; [|inversion H].
+split; auto.
+apply permut_length_1.
+red; red; intros.
+generalize (P a); clear P; simpl.
+destruct (eqA_dec a1 a) as [H2|H2]; 
+ destruct (eqA_dec b2 a) as [H3|H3]; auto.
+simpl; rewrite <- plus_n_Sm; inversion 1; auto.
+destruct H3; apply eqA_trans with a1; auto.
+destruct H2; apply eqA_trans with b2; auto.
+Qed.
+
+(** Permutation is compatible with length. *)
+Lemma permut_length :
+ forall l1 l2, permutation l1 l2 -> length l1 = length l2.
+Proof.
+induction l1; intros l2 H.
+rewrite (permut_nil (permut_sym H)); auto.
+assert (H0:=permut_cons_InA H).
+destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))).
+subst l2.
+rewrite app_length.
+simpl; rewrite <- plus_n_Sm; f_equal.
+rewrite <- app_length.
+apply IHl1.
+apply permut_remove_hd with b.
+apply permut_tran with (a::l1); auto.
+revert H1; unfold Permutation.permutation, meq; simpl.
+intros; f_equal; auto.
+destruct (eqA_dec b a0) as [H2|H2]; 
+ destruct (eqA_dec a a0) as [H3|H3]; auto.
+destruct H3; apply eqA_trans with b; auto.
+destruct H2; apply eqA_trans with a; auto.
+Qed.
+
+Lemma NoDupA_eqlistA_permut : 
+  forall l l', NoDupA eqA l -> NoDupA eqA l' -> 
+     eqlistA eqA l l' -> permutation l l'.
+Proof.
+intros.
+red; unfold meq; intros.
+rewrite multiplicity_NoDupA in H, H0. 
+generalize (H a) (H0 a) (H1 a); clear H H0 H1.
+do 2 rewrite multiplicity_InA.
+destruct 3; omega.
+Qed.
+
+
+Variable B : Set.
+Variable eqB : B->B->Prop.
+Variable eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }. 
+Variable eqB_trans : forall x y z, eqB x y -> eqB y z -> eqB x z.
+
+(** Permutation is compatible with map. *)
+
+Lemma permut_map :
+  forall f, 
+  (forall x y, eqA x y -> eqB (f x) (f y)) ->
+  forall l1 l2, permutation l1 l2 -> 
+   Permutation.permutation _ eqB_dec (map f l1) (map f l2).
+Proof.
+intros f; induction l1.
+intros l2 P; rewrite (permut_nil (permut_sym P)); apply permut_refl.
+intros l2 P.
+simpl.
+assert (H0:=permut_cons_InA P).
+destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))).
+subst l2.
+rewrite map_app.
+simpl.
+apply permut_tran with (f b :: map f l1).
+revert H1; unfold Permutation.permutation, meq; simpl.
+intros; f_equal; auto.
+destruct (eqB_dec (f b) a0) as [H2|H2]; 
+ destruct (eqB_dec (f a) a0) as [H3|H3]; auto.
+destruct H3; apply eqB_trans with (f b); auto.
+destruct H2; apply eqB_trans with (f a); auto.
+apply permut_add_cons_inside.
+rewrite <- map_app.
+apply IHl1; auto.
+apply permut_remove_hd with b.
+apply permut_tran with (a::l1); auto.
+revert H1; unfold Permutation.permutation, meq; simpl.
+intros; f_equal; auto.
+destruct (eqA_dec b a0) as [H2|H2]; 
+ destruct (eqA_dec a a0) as [H3|H3]; auto.
+destruct H3; apply eqA_trans with b; auto.
+destruct H2; apply eqA_trans with a; auto.
+Qed.
+
+End Perm.
diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v
index b3287cd1..0f2e02b5 100644
--- a/theories/Sorting/Permutation.v
+++ b/theories/Sorting/Permutation.v
@@ -6,30 +6,39 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Permutation.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id: Permutation.v 8823 2006-05-16 16:17:43Z letouzey $ i*)
 
 Require Import Relations.
 Require Import List.
 Require Import Multiset.
+Require Import Arith.
+
+(** This file define a notion of permutation for lists, based on multisets: 
+     there exists a permutation between two lists iff every elements have 
+     the same multiplicities in the two lists. 
+
+     Unlike [List.Permutation], the present notion of permutation requires
+     a decidable equality. At the same time, this definition can be used 
+     with a non-standard equality, whereas [List.Permutation] cannot.
+      
+     The present file contains basic results, obtained without any particular
+     assumption on the decidable equality used.
+	
+     File [PermutSetoid] contains additional results about permutations 
+     with respect to an setoid equality (i.e. an equivalence relation). 
+
+     Finally, file [PermutEq] concerns Coq equality : this file is similar 
+     to the previous one, but proves in addition that [List.Permutation]
+     and [permutation] are equivalent in this context.
+*)
 
 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.
@@ -63,6 +72,12 @@ unfold permutation in |- *; auto with datatypes.
 Qed.
 Hint Resolve permut_refl.
 
+Lemma permut_sym :
+ forall l1 l2 : list A, permutation l1 l2 -> permutation l2 l1.
+Proof.
+unfold permutation, meq; intros; apply sym_eq; trivial.
+Qed.
+
 Lemma permut_tran :
  forall l m n:list A, permutation l m -> permutation m n -> permutation l n.
 Proof.
@@ -70,51 +85,122 @@ unfold permutation in |- *; intros.
 apply meq_trans with (list_contents m); auto with datatypes.
 Qed.
 
-Lemma permut_right :
+Lemma permut_cons :
  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.
+Hint Resolve permut_cons.
 
 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));
+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'));
+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).
+Lemma permut_add_inside :
+ forall a l1 l2 l3 l4, 
+  permutation (l1 ++ l2) (l3 ++ l4) ->
+  permutation (l1 ++ a :: l2) (l3 ++ a :: l4).
 Proof.
-intros l m H a.
-change (permutation ((a :: nil) ++ l) ((a :: nil) ++ m)) in |- *.
-apply permut_app; auto with datatypes.
+unfold permutation, meq in *; intros.
+generalize (H a0); clear H.
+do 4 rewrite list_contents_app.
+simpl.
+destruct (eqA_dec a a0); simpl; auto with arith.
+do 2 rewrite <- plus_n_Sm; f_equal; auto.
+Qed.
+
+Lemma permut_add_cons_inside :
+ forall a l l1 l2, 
+  permutation l (l1 ++ l2) ->
+  permutation (a :: l) (l1 ++ a :: l2).
+Proof.
+intros;
+replace (a :: l) with (nil ++ a :: l); trivial;
+apply permut_add_inside; trivial.
 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.
+intros; apply permut_add_cons_inside; auto.
 Qed.
 Hint Resolve permut_middle.
 
+Lemma permut_sym_app :
+ forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1).
+Proof.
+intros l1 l2;
+unfold permutation, meq; 
+intro a; do 2 rewrite list_contents_app; simpl; 
+auto with arith.
+Qed.
+
+Lemma permut_rev : 
+ forall l, permutation l (rev l).
+Proof.
+induction l.
+simpl; auto.
+simpl.
+apply permut_add_cons_inside.
+rewrite <- app_nil_end; auto.
+Qed.
+
+(** Some inversion results. *)
+Lemma permut_conv_inv :
+  forall e l1 l2, permutation (e :: l1) (e :: l2) -> permutation l1 l2.
+Proof.
+intros e l1 l2; unfold permutation, meq; simpl; intros H a;
+generalize (H a); apply plus_reg_l.
+Qed.
+
+Lemma permut_app_inv1 : 
+  forall l l1 l2, permutation (l1 ++ l) (l2 ++ l) -> permutation l1 l2.
+Proof.
+intros l l1 l2; unfold permutation, meq; simpl;
+intros H a; generalize (H a); clear H.
+do 2 rewrite list_contents_app.
+simpl.
+intros; apply plus_reg_l with (multiplicity (list_contents l) a).
+rewrite plus_comm; rewrite H; rewrite plus_comm.
+trivial.
+Qed.
+
+Lemma permut_app_inv2 : 
+  forall l l1 l2, permutation (l ++ l1) (l ++ l2) -> permutation l1 l2.
+Proof.
+intros l l1 l2; unfold permutation, meq; simpl;
+intros H a; generalize (H a); clear H.
+do 2 rewrite list_contents_app.
+simpl.
+intros; apply plus_reg_l with (multiplicity (list_contents l) a).
+trivial.
+Qed.
+
+Lemma permut_remove_hd :
+  forall l l1 l2 a,   
+  permutation (a :: l) (l1 ++ a :: l2) -> permutation l (l1 ++ l2).
+Proof.
+intros l l1 l2 a; unfold permutation, meq; simpl; intros H a0; generalize (H a0); clear H.
+do 2 rewrite list_contents_app; simpl; intro H.
+apply plus_reg_l with (if eqA_dec a a0 then 1 else 0).
+rewrite H; clear H.
+symmetry; rewrite plus_comm.
+repeat rewrite <- plus_assoc; f_equal.
+apply plus_comm.
+Qed.
+
 End defs.
+(* For compatibilty *) 
+Notation permut_right := permut_cons.
 Unset Implicit Arguments.
diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v
index 02cf5f2d..fda521de 100644
--- a/theories/ZArith/BinInt.v
+++ b/theories/ZArith/BinInt.v
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BinInt.v 6295 2004-11-12 16:40:39Z gregoire $ i*)
+(*i $Id: BinInt.v 8883 2006-05-31 21:56:37Z letouzey $ i*)
 
 (***********************************************************)
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
 (***********************************************************)
 
 Require Export BinPos.
@@ -703,6 +703,12 @@ Qed.
 (**********************************************************************)
 (** Properties of multiplication on binary integer numbers *)
 
+Theorem Zpos_mult_morphism : 
+ forall p q:positive, Zpos (p*q) = Zpos p * Zpos q.
+Proof.
+auto.
+Qed.
+
 (** One is neutral for multiplication *)
 
 Theorem Zmult_1_l : forall n:Z, Zpos 1 * n = n.
@@ -935,6 +941,8 @@ 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.
diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v
new file mode 100644
index 00000000..cb51b9d2
--- /dev/null
+++ b/theories/ZArith/Int.v
@@ -0,0 +1,421 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: Int.v 8933 2006-06-09 14:08:38Z herbelin $ *)
+
+(** * An axiomatization of integers. *) 
+
+(** We define a signature for an integer datatype based on [Z]. 
+   The goal is to allow a switch after extraction to ocaml's 
+   [big_int] or even [int] when finiteness isn't a problem 
+   (typically : when mesuring the height of an AVL tree). 
+*)
+
+Require Import ZArith. 
+Require Import ROmega. 
+Delimit Scope Int_scope with I.
+
+Module Type Int.
+
+ Open Scope Int_scope.
+
+ Parameter int : Set. 
+
+ Parameter i2z : int -> Z.
+ Arguments Scope i2z [ Int_scope ].
+
+ Parameter _0 : int. 
+ Parameter _1 : int. 
+ Parameter _2 : int. 
+ Parameter _3 : int.
+ Parameter plus : int -> int -> int. 
+ Parameter opp : int -> int.
+ Parameter minus : int -> int -> int. 
+ Parameter mult : int -> int -> int.
+ Parameter max : int -> int -> int. 
+
+ Notation "0" := _0 : Int_scope.
+ Notation "1" := _1 : Int_scope. 
+ Notation "2" := _2 : Int_scope. 
+ Notation "3" := _3 : Int_scope.
+ Infix "+" := plus : Int_scope.
+ Infix "-" := minus : Int_scope.
+ Infix "*" := mult : Int_scope.
+ Notation "- x" := (opp x) : Int_scope.
+
+(** For logical relations, we can rely on their counterparts in Z, 
+   since they don't appear after extraction. Moreover, using tactics 
+   like omega is easier this way. *)
+
+ Notation "x == y" := (i2z x = i2z y)
+   (at level 70, y at next level, no associativity) : Int_scope.
+ Notation "x <= y" := (Zle (i2z x) (i2z y)): Int_scope.
+ Notation "x < y" := (Zlt (i2z x) (i2z y)) : Int_scope.
+ Notation "x >= y" := (Zge (i2z x) (i2z y)) : Int_scope.
+ Notation "x > y" := (Zgt (i2z x) (i2z y)): Int_scope.
+ Notation "x <= y <= z" := (x <= y /\ y <= z) : Int_scope.
+ Notation "x <= y < z" := (x <= y /\ y < z) : Int_scope.
+ Notation "x < y < z" := (x < y /\ y < z) : Int_scope.
+ Notation "x < y <= z" := (x < y /\ y <= z) : Int_scope.
+
+ (** Some decidability fonctions (informative). *)
+
+ Axiom gt_le_dec : forall x y: int, {x > y} + {x <= y}.
+ Axiom ge_lt_dec :  forall x y : int, {x >= y} + {x < y}.
+ Axiom eq_dec : forall x y : int, { x == y } + {~ x==y }.
+
+ (** Specifications *)
+
+ (** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality 
+    [==] and the generic [=] are in fact equivalent. We define [==] 
+    nonetheless since the translation to [Z] for using automatic tactic is easier. *)
+
+ Axiom i2z_eq : forall n p : int, n == p -> n = p. 
+
+ (** Then, we express the specifications of the above parameters using their 
+    Z counterparts. *)
+
+ Open Scope Z_scope.
+ Axiom i2z_0 : i2z _0 = 0.
+ Axiom i2z_1 : i2z _1 = 1.
+ Axiom i2z_2 : i2z _2 = 2.
+ Axiom i2z_3 : i2z _3 = 3.
+ Axiom i2z_plus : forall n p, i2z (n + p) = i2z n + i2z p.
+ Axiom i2z_opp : forall n, i2z (-n) = -i2z n.
+ Axiom i2z_minus : forall n p, i2z (n - p) = i2z n - i2z p.
+ Axiom i2z_mult : forall n p, i2z (n * p) = i2z n * i2z p.
+ Axiom i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p).
+
+End Int. 
+
+Module MoreInt (I:Int).
+ Import I.
+
+ Open Scope Int_scope.
+
+ (** A magic (but costly) tactic that goes from [int] back to the [Z] 
+     friendly world ... *)
+
+ Hint Rewrite -> 
+   i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z.
+
+ Ltac i2z := match goal with 
+  | H : (eq (A:=int) ?a ?b) |- _ => 
+       generalize (f_equal i2z H); 
+       try autorewrite with i2z; clear H; intro H; i2z
+  | |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); try autorewrite with i2z; i2z
+  | H : _ |- _ => progress autorewrite with i2z in H; i2z
+  | _ => try autorewrite with i2z
+ end.
+
+ (** A reflexive version of the [i2z] tactic *)
+
+ (** this [i2z_refl] is actually weaker than [i2z]. For instance, if a 
+      [i2z] is buried deep inside a subterm, [i2z_refl] may miss it. 
+      See also the limitation about [Set] or [Type] part below. 
+      Anyhow, [i2z_refl] is enough for applying [romega]. *)
+ 
+  Ltac i2z_gen := match goal with 
+    | |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); i2z_gen
+    | H : (eq (A:=int) ?a ?b) |- _ => 
+       generalize (f_equal i2z H); clear H; i2z_gen
+    | H : (eq (A:=Z) ?a ?b) |- _ => generalize H; clear H; i2z_gen
+    | H : (Zlt ?a ?b) |- _ => generalize H; clear H; i2z_gen
+    | H : (Zle ?a ?b) |- _ => generalize H; clear H; i2z_gen
+    | H : (Zgt ?a ?b) |- _ => generalize H; clear H; i2z_gen
+    | H : (Zge ?a ?b) |- _ => generalize H; clear H; i2z_gen
+    | H : _ -> ?X |- _ => 
+      (* A [Set] or [Type] part cannot be dealt with easily
+         using the [ExprP] datatype. So we forget it, leaving 
+         a goal that can be weaker than the original. *)
+      match type of X with 
+       | Type => clear H; i2z_gen
+       | Prop => generalize H; clear H; i2z_gen
+      end
+    | H : _ <-> _ |- _ => generalize H; clear H; i2z_gen
+    | H : _ /\ _ |- _ => generalize H; clear H; i2z_gen
+    | H : _ \/ _ |- _ => generalize H; clear H; i2z_gen
+    | H : ~ _ |- _ => generalize H; clear H; i2z_gen
+    | _ => idtac
+   end.
+
+  Inductive ExprI : Set := 
+   | EI0 : ExprI
+   | EI1 : ExprI
+   | EI2 : ExprI 
+   | EI3 : ExprI
+   | EIplus : ExprI -> ExprI -> ExprI
+   | EIopp : ExprI -> ExprI
+   | EIminus : ExprI -> ExprI -> ExprI
+   | EImult : ExprI -> ExprI -> ExprI
+   | EImax : ExprI -> ExprI -> ExprI
+   | EIraw : int -> ExprI.
+
+  Inductive ExprZ : Set :=  
+   | EZplus : ExprZ -> ExprZ -> ExprZ
+   | EZopp : ExprZ -> ExprZ
+   | EZminus : ExprZ -> ExprZ -> ExprZ
+   | EZmult : ExprZ -> ExprZ -> ExprZ
+   | EZmax : ExprZ -> ExprZ -> ExprZ
+   | EZofI : ExprI -> ExprZ
+   | EZraw : Z -> ExprZ.
+
+  Inductive ExprP : Type := 
+   | EPeq : ExprZ -> ExprZ -> ExprP 
+   | EPlt : ExprZ -> ExprZ -> ExprP 
+   | EPle : ExprZ -> ExprZ -> ExprP 
+   | EPgt : ExprZ -> ExprZ -> ExprP 
+   | EPge : ExprZ -> ExprZ -> ExprP 
+   | EPimpl : ExprP -> ExprP -> ExprP
+   | EPequiv : ExprP -> ExprP -> ExprP
+   | EPand : ExprP -> ExprP -> ExprP
+   | EPor : ExprP -> ExprP -> ExprP
+   | EPneg : ExprP -> ExprP
+   | EPraw : Prop -> ExprP.
+
+ (** [int] to [ExprI] *)
+
+ Ltac i2ei trm := 
+  match constr:trm with 
+    | 0 => constr:EI0
+    | 1 => constr:EI1
+    | 2 => constr:EI2
+    | 3 => constr:EI3
+    | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIplus ex ey)
+    | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIminus ex ey)
+    | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImult ex ey)
+    | max ?x ?y => let ex := i2ei x with ey := i2ei y in constr:(EImax ex ey)
+    | - ?x => let ex := i2ei x in constr:(EIopp ex)
+    | ?x => constr:(EIraw x)
+   end
+
+ (** [Z] to [ExprZ] *)
+
+ with z2ez trm := 
+   match constr:trm with 
+    | (?x+?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey)
+    | (?x-?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey)
+    | (?x*?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey)
+    | (Zmax ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey)
+    | (-?x)%Z =>  let ex := z2ez x in constr:(EZopp ex)
+    | i2z ?x => let ex := i2ei x in constr:(EZofI ex)
+    | ?x => constr:(EZraw x)
+   end.
+
+ (** [Prop] to [ExprP] *)
+
+ Ltac p2ep trm :=
+  match constr:trm with
+    | (?x <-> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPequiv ex ey)
+    | (?x -> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPimpl ex ey)
+    | (?x /\ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPand ex ey)
+    | (?x \/ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPor ex ey)
+    | (~ ?x) => let ex := p2ep x in constr:(EPneg ex)
+    | (eq (A:=Z) ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EPeq ex ey)
+    | (?x<?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPlt ex ey)
+    | (?x<=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey)   
+    | (?x>?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey)   
+    | (?x>=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPge ex ey)
+    | ?x =>  constr:(EPraw x)
+   end.   
+
+ (** [ExprI] to [int] *)
+
+ Fixpoint ei2i (e:ExprI) : int :=
+  match e with
+  | EI0 => 0
+  | EI1 => 1
+  | EI2 => 2
+  | EI3 => 3 
+  | EIplus e1 e2 => (ei2i e1)+(ei2i e2)
+  | EIminus e1 e2 => (ei2i e1)-(ei2i e2)
+  | EImult e1 e2 => (ei2i e1)*(ei2i e2)
+  | EImax e1 e2 => max (ei2i e1) (ei2i e2)
+  | EIopp e => -(ei2i e)
+  | EIraw i => i 
+  end. 
+ 
+ (** [ExprZ] to [Z] *)
+
+ Fixpoint ez2z (e:ExprZ) : Z := 
+  match e with 
+  | EZplus e1 e2 => ((ez2z e1)+(ez2z e2))%Z
+  | EZminus e1 e2 => ((ez2z e1)-(ez2z e2))%Z
+  | EZmult e1 e2 => ((ez2z e1)*(ez2z e2))%Z
+  | EZmax e1 e2 => Zmax (ez2z e1) (ez2z e2)
+  | EZopp e => (-(ez2z e))%Z
+  | EZofI e => i2z (ei2i e)
+  | EZraw z => z
+  end.
+
+ (** [ExprP] to [Prop] *)
+
+ Fixpoint ep2p (e:ExprP) : Prop := 
+  match e with 
+   | EPeq e1 e2 => (ez2z e1) = (ez2z e2)
+   | EPlt e1 e2 => ((ez2z e1)<(ez2z e2))%Z
+   | EPle e1 e2 => ((ez2z e1)<=(ez2z e2))%Z
+   | EPgt e1 e2 => ((ez2z e1)>(ez2z e2))%Z
+   | EPge e1 e2 => ((ez2z e1)>=(ez2z e2))%Z
+   | EPimpl e1 e2 => (ep2p e1) -> (ep2p e2)
+   | EPequiv e1 e2 => (ep2p e1) <-> (ep2p e2)
+   | EPand e1 e2 => (ep2p e1) /\ (ep2p e2)
+   | EPor e1 e2 => (ep2p e1) \/ (ep2p e2)
+   | EPneg e => ~ (ep2p e)
+   | EPraw p => p
+ end.
+
+ (** [ExprI] (supposed under a [i2z]) to a simplified [ExprZ] *)
+   
+ Fixpoint norm_ei (e:ExprI) : ExprZ := 
+ match e with 
+  | EI0 => EZraw (0%Z)
+  | EI1 => EZraw (1%Z)
+  | EI2 => EZraw (2%Z)
+  | EI3 => EZraw (3%Z) 
+  | EIplus e1 e2 => EZplus (norm_ei e1) (norm_ei e2)
+  | EIminus e1 e2 => EZminus (norm_ei e1) (norm_ei e2)
+  | EImult e1 e2 => EZmult (norm_ei e1) (norm_ei e2)
+  | EImax e1 e2 => EZmax (norm_ei e1) (norm_ei e2)
+  | EIopp e => EZopp (norm_ei e)
+  | EIraw i => EZofI (EIraw i) 
+ end.
+
+ (** [ExprZ] to a simplified [ExprZ] *)
+
+ Fixpoint norm_ez (e:ExprZ) : ExprZ := 
+  match e with 
+  | EZplus e1 e2 => EZplus (norm_ez e1) (norm_ez e2)
+  | EZminus e1 e2 => EZminus (norm_ez e1) (norm_ez e2)
+  | EZmult e1 e2 => EZmult (norm_ez e1) (norm_ez e2)
+  | EZmax e1 e2 => EZmax (norm_ez e1) (norm_ez e2)
+  | EZopp e => EZopp (norm_ez e)
+  | EZofI e =>  norm_ei e
+  | EZraw z => EZraw z
+ end.
+
+ (** [ExprP] to a simplified [ExprP] *)
+
+ Fixpoint norm_ep (e:ExprP) : ExprP := 
+  match e with 
+   | EPeq e1 e2 => EPeq (norm_ez e1) (norm_ez e2)
+   | EPlt e1 e2 => EPlt (norm_ez e1) (norm_ez e2)
+   | EPle e1 e2 => EPle (norm_ez e1) (norm_ez e2)
+   | EPgt e1 e2 => EPgt (norm_ez e1) (norm_ez e2)
+   | EPge e1 e2 => EPge (norm_ez e1) (norm_ez e2)
+   | EPimpl e1 e2 => EPimpl (norm_ep e1) (norm_ep e2)
+   | EPequiv e1 e2 => EPequiv (norm_ep e1) (norm_ep e2)
+   | EPand e1 e2 => EPand (norm_ep e1) (norm_ep e2)
+   | EPor e1 e2 => EPor (norm_ep e1) (norm_ep e2)
+   | EPneg e => EPneg (norm_ep e)
+   | EPraw p => EPraw p
+ end.
+
+ Lemma norm_ei_correct : forall e:ExprI, ez2z (norm_ei e) = i2z (ei2i e).
+ Proof. 
+ induction e; simpl; intros; i2z; auto; try congruence.
+ Qed.
+
+ Lemma norm_ez_correct : forall e:ExprZ, ez2z (norm_ez e) = ez2z e.
+ Proof.
+ induction e; simpl; intros; i2z; auto; try congruence; apply norm_ei_correct.
+ Qed. 
+
+ Lemma norm_ep_correct : 
+  forall e:ExprP, ep2p (norm_ep e) <-> ep2p e.
+ Proof.
+  induction e; simpl; repeat (rewrite norm_ez_correct); intuition.
+ Qed.
+
+ Lemma norm_ep_correct2 : 
+  forall e:ExprP, ep2p (norm_ep e) -> ep2p e.
+ Proof.
+  intros; destruct (norm_ep_correct e); auto.
+ Qed.
+
+ Ltac i2z_refl := 
+  i2z_gen;
+  match goal with |- ?t => 
+     let e := p2ep t 
+     in 
+     (change (ep2p e); 
+      apply norm_ep_correct2; 
+      simpl)
+   end.
+
+ Ltac iauto := i2z_refl; auto.
+ Ltac iomega := i2z_refl; intros; romega.
+
+ Open Scope Z_scope.
+
+ Lemma max_spec : forall (x y:Z), 
+  x >= y /\ Zmax x y = x  \/
+  x < y /\ Zmax x y = y.
+ Proof.
+  intros; unfold Zmax, Zlt, Zge.
+  destruct (Zcompare x y); [ left | right | left ]; split; auto; discriminate.
+ Qed.
+
+ Ltac omega_max_genspec x y := 
+    generalize (max_spec x y); 
+    let z := fresh "z" in let Hz := fresh "Hz" in 
+    (set (z:=Zmax x y); clearbody z).
+
+ Ltac omega_max_loop := 
+    match goal with 
+      (* hack: we don't want [i2z (height ...)] to be reduced by romega later... *)
+      | |- context [ i2z (?f ?x) ] => 
+          let i := fresh "i2z" in (set (i:=i2z (f x)); clearbody i); omega_max_loop
+      | |- context [ Zmax ?x ?y ] => omega_max_genspec x y; omega_max_loop
+      | _ => intros
+    end.
+
+ Ltac omega_max := i2z_refl; omega_max_loop; try romega.
+
+ Ltac false_omega := i2z_refl; intros; romega.
+ Ltac false_omega_max := elimtype False; omega_max.
+
+ Open Scope Int_scope.
+End MoreInt.
+
+
+(** It's always nice to know that our [Int] interface is realizable :-) *)
+
+Module Z_as_Int <: Int.
+ Open Scope Z_scope.
+ Definition int := Z.
+ Definition _0 := 0.
+ Definition _1 := 1.
+ Definition _2 := 2.
+ Definition _3 := 3.
+ Definition plus := Zplus.
+ Definition opp := Zopp.
+ Definition minus := Zminus.
+ Definition mult := Zmult.
+ Definition max := Zmax.
+ Definition gt_le_dec := Z_gt_le_dec. 
+ Definition ge_lt_dec := Z_ge_lt_dec.
+ Definition eq_dec := Z_eq_dec.
+ Definition i2z : int -> Z := fun n => n.
+ Lemma i2z_eq : forall n p, i2z n=i2z p -> n = p. Proof. auto. Qed.
+ Lemma i2z_0 : i2z _0 = 0.  Proof. auto. Qed.
+ Lemma i2z_1 : i2z _1 = 1.  Proof. auto. Qed.
+ Lemma i2z_2 : i2z _2 = 2.  Proof. auto. Qed.
+ Lemma i2z_3 : i2z _3 = 3.  Proof. auto. Qed.
+ Lemma i2z_plus : forall n p, i2z (n + p) = i2z n + i2z p.  Proof. auto. Qed.
+ Lemma i2z_opp : forall n, i2z (- n)  = - i2z n.  Proof. auto. Qed.
+ Lemma i2z_minus : forall n p, i2z (n - p)  = i2z n - i2z p.  Proof. auto. Qed.
+ Lemma i2z_mult : forall n p, i2z (n * p)  = i2z n * i2z p.  Proof. auto. Qed.
+ Lemma i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p). Proof. auto. Qed.
+End Z_as_Int.
+
diff --git a/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v
index 714abfc4..4003c338 100644
--- a/theories/ZArith/Zcompare.v
+++ b/theories/ZArith/Zcompare.v
@@ -383,7 +383,7 @@ 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.
+ forall (A:Type) (P:A -> Prop) (x:A), (forall y:A, x = y -> P y) -> P x.
 Proof.
 auto with arith. 
 Qed.
diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v
index a1963446..b74f7585 100644
--- a/theories/ZArith/Znumtheory.v
+++ b/theories/ZArith/Znumtheory.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Znumtheory.v 6984 2005-05-02 10:50:15Z herbelin $ i*)
+(*i $Id: Znumtheory.v 8853 2006-05-23 18:17:38Z herbelin $ i*)
 
 Require Import ZArith_base.
 Require Import ZArithRing.
@@ -367,11 +367,391 @@ rewrite H6; rewrite H7; ring.
 ring.
 Qed.
 
+Lemma Zis_gcd_0_abs : forall b, 
+ Zis_gcd 0 b (Zabs b) /\ Zabs b >= 0 /\ 0 = Zabs b * 0 /\ b = Zabs b * Zsgn b.
+Proof.
+intro 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.
+repeat split; auto with zarith.
+symmetry; apply Zabs_Zsgn.
+
+intros H0; rewrite <- H0.
+rewrite <- (Zabs_Zsgn b); rewrite <- H0; simpl in |- *.
+split; [ apply Zis_gcd_0 | idtac ]; auto with zarith.
+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). *)
+  here a more direct version of a [Zgcd], that can compute within Coq.
+  For that, we use an explicit measure in [nat], and we proved later
+  that using [2(d+1)] is enough, where  [d] is the number of binary digits 
+  of the first argument. *)
+
+Fixpoint Zgcdn (n:nat) : Z -> Z -> Z := fun a b => 
+ match n with 
+  | O => 1 (* arbitrary, since n should be big enough *)
+  | S n => match a with 
+     | Z0 => Zabs b
+     | Zpos _ => Zgcdn n (Zmod b a) a
+     | Zneg a => Zgcdn n (Zmod b (Zpos a)) (Zpos a)
+     end
+   end.
+
+(* For technical reason, we don't use [Ndigit.Psize] but this 
+   ad-hoc version: [Psize p = S (Psiz p)]. *)
+
+Fixpoint Psiz (p:positive) : nat := 
+  match p with 
+    | xH => O
+    | xI p => S (Psiz p) 
+    | xO p => S (Psiz p)
+  end.
+
+Definition Zgcd_bound (a:Z) := match a with 
+ | Z0 => S O
+ | Zpos p => let n := Psiz p in S (S (n+n))
+ | Zneg p => let n := Psiz p in S (S (n+n))
+end.
+
+Definition Zgcd a b := Zgcdn (Zgcd_bound a) a b.
+
+(** A first obvious fact : [Zgcd a b] is positive. *)
+
+Lemma Zgcdn_is_pos : forall n a b, 
+  0 <= Zgcdn n a b.
+Proof.
+induction n.
+simpl; auto with zarith.
+destruct a; simpl; intros; auto with zarith; auto.
+Qed.
+
+Lemma Zgcd_is_pos : forall a b, 0 <= Zgcd a b.
+Proof.
+intros; unfold Zgcd; apply Zgcdn_is_pos; auto.
+Qed.
+
+(** We now prove that Zgcd is indeed a gcd. *)
+
+(** 1) We prove a weaker & easier bound. *)
+
+Lemma Zgcdn_linear_bound : forall n a b, 
+ Zabs a < Z_of_nat n -> Zis_gcd a b (Zgcdn n a b).
+Proof.
+induction n.
+simpl; intros.
+elimtype False; generalize (Zabs_pos a); omega.
+destruct a; intros; simpl; 
+ [ generalize (Zis_gcd_0_abs b); intuition | | ]; 
+ unfold Zmod; 
+ generalize (Z_div_mod b (Zpos p) (refl_equal Gt));
+ destruct (Zdiv_eucl b (Zpos p)) as (q,r);
+ intros (H0,H1); 
+ rewrite inj_S in H; simpl Zabs in H; 
+ assert (H2: Zabs r < Z_of_nat n) by (rewrite Zabs_eq; auto with zarith);  
+ assert (IH:=IHn r (Zpos p) H2); clear IHn; 
+ simpl in IH |- *; 
+ rewrite H0.
+ apply Zis_gcd_for_euclid2; auto.
+ apply Zis_gcd_minus; apply Zis_gcd_sym.
+ apply Zis_gcd_for_euclid2; auto.
+Qed.
+
+(** 2) For Euclid's algorithm, the worst-case situation corresponds 
+     to Fibonacci numbers. Let's define them: *)
+
+Fixpoint fibonacci (n:nat) : Z := 
+ match n with 
+   | O => 1
+   | S O => 1
+   | S (S n as p) => fibonacci p + fibonacci n 
+ end.
+
+Lemma fibonacci_pos : forall n, 0 <= fibonacci n.
+Proof.
+cut (forall N n, (n<N)%nat -> 0<=fibonacci n).
+eauto.
+induction N.
+inversion 1.
+intros.
+destruct n.
+simpl; auto with zarith.
+destruct n.
+simpl; auto with zarith.
+change (0 <= fibonacci (S n) + fibonacci n).
+generalize (IHN n) (IHN (S n)); omega.
+Qed.
+
+Lemma fibonacci_incr : 
+ forall n m, (n<=m)%nat -> fibonacci n <= fibonacci m.
+Proof.
+induction 1.
+auto with zarith.
+apply Zle_trans with (fibonacci m); auto.
+clear.
+destruct m.
+simpl; auto with zarith.
+change (fibonacci (S m) <= fibonacci (S m)+fibonacci m).
+generalize (fibonacci_pos m); omega.
+Qed.
+
+(** 3) We prove that fibonacci numbers are indeed worst-case: 
+   for a given number [n], if we reach a conclusion about [gcd(a,b)] in 
+   exactly [n+1] loops, then [fibonacci (n+1)<=a /\ fibonacci(n+2)<=b] *)
+
+Lemma Zgcdn_worst_is_fibonacci : forall n a b, 
+ 0 < a < b -> 
+ Zis_gcd a b (Zgcdn (S n) a b) -> 
+ Zgcdn n a b <> Zgcdn (S n) a b -> 
+ fibonacci (S n) <= a /\ 
+ fibonacci (S (S n)) <= b.
+Proof.
+induction n.
+simpl; intros.
+destruct a; omega.
+intros.
+destruct a; [simpl in *; omega| | destruct H; discriminate].
+revert H1; revert H0.
+set (m:=S n) in *; (assert (m=S n) by auto); clearbody m.
+pattern m at 2; rewrite H0.
+simpl Zgcdn.
+unfold Zmod; generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
+destruct (Zdiv_eucl b (Zpos p)) as (q,r).
+intros (H1,H2).
+destruct H2.
+destruct (Zle_lt_or_eq _ _ H2).
+generalize (IHn _ _ (conj H4 H3)).
+intros H5 H6 H7. 
+replace (fibonacci (S (S m))) with (fibonacci (S m) + fibonacci m) by auto.
+assert (r = Zpos p * (-q) + b) by (rewrite H1; ring).
+destruct H5; auto.
+pattern r at 1; rewrite H8.
+apply Zis_gcd_sym.
+apply Zis_gcd_for_euclid2; auto.
+apply Zis_gcd_sym; auto.
+split; auto.
+rewrite H1.
+apply Zplus_le_compat; auto.
+apply Zle_trans with (Zpos p * 1); auto.
+ring (Zpos p * 1); auto.
+apply Zmult_le_compat_l.
+destruct q.
+omega.
+assert (0 < Zpos p0) by (compute; auto).
+omega.
+assert (Zpos p * Zneg p0 < 0) by (compute; auto).
+omega. 
+compute; intros; discriminate.
+(* r=0 *)
+subst r.
+simpl; rewrite H0.
+intros.
+simpl in H4.
+simpl in H5.
+destruct n.
+simpl in H5.
+simpl.
+omega.
+simpl in H5.
+elim H5; auto.
+Qed.
+
+(** 3b) We reformulate the previous result in a more positive way. *)
+
+Lemma Zgcdn_ok_before_fibonacci : forall n a b, 
+ 0 < a < b -> a < fibonacci (S n) ->
+ Zis_gcd a b (Zgcdn n a b).
+Proof.
+destruct a; [ destruct 1; elimtype False; omega | | destruct 1; discriminate].
+cut (forall k n b, 
+         k = (S (nat_of_P p) - n)%nat -> 
+         0 < Zpos p < b -> Zpos p < fibonacci (S n) -> 
+         Zis_gcd (Zpos p) b (Zgcdn n (Zpos p) b)).
+destruct 2; eauto.
+clear n; induction k. 
+intros.
+assert (nat_of_P p < n)%nat by omega.
+apply Zgcdn_linear_bound. 
+simpl.
+generalize (inj_le _ _ H2).
+rewrite inj_S.
+rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto.
+omega.
+intros.
+generalize (Zgcdn_worst_is_fibonacci n (Zpos p) b H0); intros.
+assert (Zis_gcd (Zpos p) b (Zgcdn (S n) (Zpos p) b)).
+ apply IHk; auto.
+ omega.
+ replace (fibonacci (S (S n))) with (fibonacci (S n)+fibonacci n) by auto.
+ generalize (fibonacci_pos n); omega.
+replace (Zgcdn n (Zpos p) b) with (Zgcdn (S n) (Zpos p) b); auto.
+generalize (H2 H3); clear H2 H3; omega.
+Qed.
+
+(** 4) The proposed bound leads to a fibonacci number that is big enough. *)
+
+Lemma Zgcd_bound_fibonacci : 
+  forall a, 0 < a -> a < fibonacci (Zgcd_bound a).
+Proof.
+destruct a; [omega| | intro H; discriminate].
+intros _.
+induction p.
+simpl Zgcd_bound in *.
+rewrite Zpos_xI.
+rewrite plus_comm; simpl plus.
+set (n:=S (Psiz p+Psiz p)) in *.
+change (2*Zpos p+1 < 
+ fibonacci (S n) + fibonacci n + fibonacci (S n)).
+generalize (fibonacci_pos n).
+omega.
+simpl Zgcd_bound in *.
+rewrite Zpos_xO.
+rewrite plus_comm; simpl plus.
+set (n:= S (Psiz p +Psiz p)) in *.
+change (2*Zpos p < 
+ fibonacci (S n) + fibonacci n + fibonacci (S n)).
+generalize (fibonacci_pos n).
+omega.
+simpl; auto with zarith.
+Qed.
 
-Definition Zgcd_pos :
+(* 5) the end: we glue everything together and take care of 
+   situations not corresponding to [0<a<b]. *)
+
+Lemma Zgcd_is_gcd : 
+  forall a b, Zis_gcd a b (Zgcd a b).
+Proof.
+unfold Zgcd; destruct a; intros.
+simpl; generalize (Zis_gcd_0_abs b); intuition.
+(*Zpos*)
+generalize (Zgcd_bound_fibonacci (Zpos p)).
+simpl Zgcd_bound.
+set (n:=S (Psiz p+Psiz p)); (assert (n=S (Psiz p+Psiz p)) by auto); clearbody n.
+simpl Zgcdn.
+unfold Zmod.
+generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
+destruct (Zdiv_eucl b (Zpos p)) as (q,r).
+intros (H1,H2) H3.
+rewrite H1.
+apply Zis_gcd_for_euclid2.
+destruct H2.
+destruct (Zle_lt_or_eq _ _ H0).
+apply Zgcdn_ok_before_fibonacci; auto; omega.
+subst r n; simpl.
+apply Zis_gcd_sym; apply Zis_gcd_0.
+(*Zneg*)
+generalize (Zgcd_bound_fibonacci (Zpos p)).
+simpl Zgcd_bound.
+set (n:=S (Psiz p+Psiz p)); (assert (n=S (Psiz p+Psiz p)) by auto); clearbody n.
+simpl Zgcdn.
+unfold Zmod.
+generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
+destruct (Zdiv_eucl b (Zpos p)) as (q,r).
+intros (H1,H2) H3.
+rewrite H1.
+apply Zis_gcd_minus.
+apply Zis_gcd_sym.
+apply Zis_gcd_for_euclid2.
+destruct H2.
+destruct (Zle_lt_or_eq _ _ H0).
+apply Zgcdn_ok_before_fibonacci; auto; omega.
+subst r n; simpl.
+apply Zis_gcd_sym; apply Zis_gcd_0.
+Qed.
+
+(** A generalized gcd: it additionnally keeps track of the divisors. *)
+
+Fixpoint Zggcdn (n:nat) : Z -> Z -> (Z*(Z*Z)) := fun a b => 
+ match n with 
+  | O => (1,(a,b))   (*(Zabs b,(0,Zsgn b))*)
+  | S n => match a with 
+     | Z0 => (Zabs b,(0,Zsgn b))
+     | Zpos _ => 
+               let (q,r) := Zdiv_eucl b a in   (* b = q*a+r *)
+               let (g,p) := Zggcdn n r a in 
+               let (rr,aa) := p in        (* r = g *rr /\ a = g * aa *)
+               (g,(aa,q*aa+rr))
+     | Zneg a => 
+               let (q,r) := Zdiv_eucl b (Zpos a) in  (* b = q*(-a)+r *)
+               let (g,p) := Zggcdn n r (Zpos a) in 
+               let (rr,aa) := p in         (* r = g*rr /\ (-a) = g * aa *)  
+               (g,(-aa,q*aa+rr))
+     end
+   end.
+
+Definition Zggcd a b : Z * (Z * Z) := Zggcdn (Zgcd_bound a) a b.
+
+(** The first component of [Zggcd] is [Zgcd] *) 
+
+Lemma Zggcdn_gcdn : forall n a b, 
+ fst (Zggcdn n a b) = Zgcdn n a b.
+Proof.
+induction n; simpl; auto.
+destruct a; unfold Zmod; simpl; intros; auto; 
+ destruct (Zdiv_eucl b (Zpos p)) as (q,r); 
+ rewrite <- IHn; 
+ destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)); simpl; auto.
+Qed.
+
+Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b.
+Proof.
+intros; unfold Zggcd, Zgcd; apply Zggcdn_gcdn; auto.
+Qed.
+
+(** [Zggcd] always returns divisors that are coherent with its 
+ first output. *)
+
+Lemma Zggcdn_correct_divisors : forall n a b, 
+  let (g,p) := Zggcdn n a b in 
+  let (aa,bb):=p in 
+  a=g*aa /\ b=g*bb.
+Proof.
+induction n.
+simpl.
+split; [destruct a|destruct b]; auto.
+intros.
+simpl.
+destruct a.
+rewrite Zmult_comm; simpl.
+split; auto.
+symmetry; apply Zabs_Zsgn.
+generalize (Z_div_mod b (Zpos p)); 
+destruct (Zdiv_eucl b (Zpos p)) as (q,r).
+generalize (IHn r (Zpos p)); 
+destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)).
+intuition.
+destruct H0.
+compute; auto.
+rewrite H; rewrite H1; rewrite H2; ring.
+generalize (Z_div_mod b (Zpos p)); 
+destruct (Zdiv_eucl b (Zpos p)) as (q,r).
+destruct 1.
+compute; auto.
+generalize (IHn r (Zpos p)); 
+destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)).
+intuition.
+destruct H0.
+replace (Zneg p) with (-Zpos p) by compute; auto.
+rewrite H4; ring.
+rewrite H; rewrite H4; rewrite H0; ring.
+Qed.
+
+Lemma Zggcd_correct_divisors : forall a b, 
+  let (g,p) := Zggcd a b in 
+  let (aa,bb):=p in 
+  a=g*aa /\ b=g*bb.
+Proof.
+unfold Zggcd; intros; apply Zggcdn_correct_divisors; auto.
+Qed.
+ 
+(** Due to the use of an explicit measure, the extraction of [Zgcd] 
+  isn't optimal. We propose here another version [Zgcd_spec] that 
+  doesn't suffer from this problem (but doesn't compute in Coq). *)
+
+Definition Zgcd_spec_pos :
   forall a:Z,
     0 <= a -> forall b:Z, {g : Z | 0 <= a -> Zis_gcd a b g /\ g >= 0}.
 Proof.
@@ -382,16 +762,7 @@ apply
  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.
+generalize (Zis_gcd_0_abs b); intuition.
   
 intros p Hrec _ b.
 generalize (Z_div_mod b (Zpos p)).
@@ -414,21 +785,58 @@ Proof.
 intros a; case (Z_gt_le_dec 0 a).
 intros; assert (0 <= - a).
 omega.
-elim (Zgcd_pos (- a) H b); intros g Hgkl.
+elim (Zgcd_spec_pos (- a) H b); intros g Hgkl.
 exists g.
 intuition.
-intros Ha b; elim (Zgcd_pos a Ha b); intros g; exists g; intuition.
+intros Ha b; elim (Zgcd_spec_pos a Ha b); intros g; exists g; intuition.
 Defined.
 
-Definition Zgcd (a b:Z) := let (g, _) := Zgcd_spec a b in g.
+(** A last version aimed at extraction that also returns the divisors. *)
 
-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.
+Definition Zggcd_spec_pos :
+  forall a:Z,
+    0 <= a -> forall b:Z, {p : Z*(Z*Z) | let (g,p):=p in let (aa,bb):=p in 
+                                       0 <= a -> Zis_gcd a b g /\ g >= 0 /\ a=g*aa /\ b=g*bb}.
+Proof.
+intros a Ha.
+pattern a; apply Zlt_0_rec; try assumption.
+intro x; case x.
+intros _ _ b; exists (Zabs b,(0,Zsgn b)).
+intros _; apply Zis_gcd_0_abs.
+  
+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.
+destruct (Hrec r H0 (Zpos p)) as ((g,(rr,pp)),Hgkl).
+destruct H0.
+destruct (Hgkl H0) as (H3,(H4,(H5,H6))).
+exists (g,(pp,pp*q+rr)); intros.
+split; auto.
+rewrite H.
+apply Zis_gcd_for_euclid2; auto.
+repeat split; auto.
+rewrite H; rewrite H6; rewrite H5; ring.
 
-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.
+intros p _ H b.
+elim H; auto.
+Defined.
+
+Definition Zggcd_spec : 
+ forall a b:Z, {p : Z*(Z*Z) |  let (g,p):=p in let (aa,bb):=p in 
+                                          Zis_gcd a b g /\ g >= 0 /\ a=g*aa /\ b=g*bb}.
+Proof.
+intros a; case (Z_gt_le_dec 0 a).
+intros; assert (0 <= - a).
+omega.
+destruct (Zggcd_spec_pos (- a) H b) as ((g,(aa,bb)),Hgkl).
+exists (g,(-aa,bb)).
+intuition.
+rewrite <- Zopp_mult_distr_r.
+rewrite <- H2; auto with zarith.
+intros Ha b; elim (Zggcd_spec_pos a Ha b); intros p; exists p.
+ repeat destruct p; intuition.
+Defined.
 
 (** * Relative primality *)