Imported Upstream version 8.2~beta3+dfsgupstream/8.2.beta3+dfsg

31 files changed, 8092 insertions, 7361 deletions

diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v
index 4807ed66..8cb1236e 100644
--- a/theories/FSets/FMapAVL.v
+++ b/theories/FSets/FMapAVL.v
@@ -9,35 +9,35 @@
 
 (* Finite map library.  *)
 
-(* $Id: FMapAVL.v 9862 2007-05-25 16:57:06Z letouzey $ *)
+(* $Id: FMapAVL.v 11033 2008-06-01 22:56:50Z letouzey $ *)
 
-(** This module implements map using AVL trees.
-    It follows the implementation from Ocaml's standard library. *)
+(** * FMapAVL *)
 
-Require Import FSetInterface.
-Require Import FMapInterface.
-Require Import FMapList.
+(** This module implements maps using AVL trees.
+    It follows the implementation from Ocaml's standard library. 
+    
+    See the comments at the beginning of FSetAVL for more details.
+*)
 
-Require Import ZArith.
-Require Import Int.
+Require Import FMapInterface FMapList ZArith Int.
 
-Set Firstorder Depth 3.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
+(** Notations and helper lemma about pairs *)
 
-Module Raw (I:Int)(X: OrderedType).
-Import I.
-Module II:=MoreInt(I).
-Import II.
-Open Local Scope Int_scope.
+Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
+Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
 
-Module E := X.
-Module MX := OrderedTypeFacts X.
-Module PX := KeyOrderedType X.
-Module L := FMapList.Raw X.
-Import MX. 
-Import PX.
+(** * The Raw functor
+   
+   Functor of pure functions + separate proofs of invariant 
+   preservation *)
+
+Module Raw (Import I:Int)(X: OrderedType).
+Open Local Scope pair_scope.
+Open Local Scope lazy_bool_scope.
+Open Local Scope Int_scope.
 
 Definition key := X.t.
 
@@ -45,30 +45,391 @@ Definition key := X.t.
 
 Section Elt.
 
-Variable elt : Set.
+Variable elt : Type.
 
-(* 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').
-*)
+(** * Trees
 
-Notation eqk := (eqk (elt:= elt)).
-Notation eqke := (eqke (elt:= elt)).
-Notation ltk := (ltk (elt:= elt)).
+   The fifth field of [Node] is the height of the tree *)
 
-Inductive tree  : Set :=
+Inductive tree :=
   | Leaf : tree
   | Node : tree -> key -> elt -> tree -> int -> tree.
 
 Notation t := tree.
 
-(** The Sixth field of [Node] is the height of the tree *)
+(** * Basic functions on trees: height and cardinal *)
+
+Definition height (m : t) : int :=
+  match m with
+  | Leaf => 0
+  | Node _ _ _ _ h => h
+  end.
+
+Fixpoint cardinal (m : t) : nat :=
+  match m with
+   | Leaf => 0%nat
+   | Node l _ _ r _ => S (cardinal l + cardinal r)
+  end.
+
+(** * Empty Map *)
+
+Definition empty := Leaf.
+
+(** * Emptyness test *)
+
+Definition is_empty m := match m with Leaf => true | _ => false end.
+
+(** * Appartness *)
+
+(** The [mem] function is deciding appartness. It exploits the [bst] property
+    to achieve logarithmic complexity. *)
+
+Fixpoint mem x m : bool :=
+   match m 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.
+
+Fixpoint find x m : option elt := 
+   match m with 
+     |  Leaf => None 
+     |  Node l y d r _ => match X.compare x y with 
+             | LT _ => find x l 
+             | EQ _ => Some d
+             | GT _ => find x r
+         end
+   end.
+
+(** * Helper functions *)
 
-(** * Occurrence in a tree *)
+(** [create l x r] creates a node, assuming [l] and [r]
+    to be balanced and [|height l - height r| <= 2]. *)
 
-Inductive MapsTo (x : key)(e : elt) : tree -> Prop :=
+Definition create l x e r := 
+   Node l x e r (max (height l) (height r) + 1).
+
+(** [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 assert_false := create.
+
+Fixpoint bal l x d 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 l x d r
+     | Node ll lx ld lr _ => 
+       if ge_lt_dec (height ll) (height lr) then 
+         create ll lx ld (create lr x d r)
+       else 
+         match lr with 
+          | Leaf => assert_false l x d r
+          | Node lrl lrx lrd lrr _ => 
+              create (create ll lx ld lrl) lrx lrd (create lrr x d r)
+         end
+    end
+  else 
+    if gt_le_dec hr (hl+2) then 
+      match r with
+       | Leaf => assert_false l x d r
+       | Node rl rx rd rr _ =>
+         if ge_lt_dec (height rr) (height rl) then 
+            create (create l x d rl) rx rd rr
+         else 
+           match rl with
+            | Leaf => assert_false l x d r
+            | Node rll rlx rld rlr _ => 
+                create (create l x d rll) rlx rld (create rlr rx rd rr) 
+           end
+      end
+    else 
+      create l x d r.
+
+(** * Insertion *)
+
+Fixpoint add x d m := 
+  match m with 
+   | Leaf => Node Leaf x d Leaf 1
+   | Node l y d' r h => 
+      match X.compare x y with
+         | LT _ => bal (add x d l) y d' r
+         | EQ _ => Node l y d r h
+         | GT _ => bal l y d' (add x d r)
+      end
+  end.
+
+(** * 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]). 
+*)
+ 
+Fixpoint remove_min l x d r : t*(key*elt) := 
+  match l with
+    | Leaf => (r,(x,d))
+    | Node ll lx ld lr lh => 
+       let (l',m) := remove_min ll lx ld lr in 
+       (bal l' x d r, m)
+  end.
+
+(** * 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].
+*)
+
+Fixpoint merge s1 s2 :=  match s1,s2 with 
+  | Leaf, _ => s2 
+  | _, Leaf => s1
+  | _, Node l2 x2 d2 r2 h2 => 
+    match remove_min l2 x2 d2 r2 with 
+      (s2',(x,d)) => bal s1 x d s2'
+    end
+end.
+
+(** * Deletion *)
+
+Fixpoint remove x m := match m with 
+  | Leaf => Leaf
+  | Node l y d r h =>
+      match X.compare x y with
+         | LT _ => bal (remove x l) y d r
+         | EQ _ => merge l r
+         | GT _ => bal l y d (remove x r)
+      end
+   end.
+
+(** * join 
+    
+    Same as [bal] but does not assume anything regarding heights of [l] 
+    and [r].
+*)
+
+Fixpoint join l : key -> elt -> t -> t :=
+  match l with
+    | Leaf => add
+    | Node ll lx ld lr lh => fun x d => 
+       fix join_aux (r:t) : t := match r with 
+          | Leaf =>  add x d l
+          | Node rl rx rd rr rh =>  
+               if gt_le_dec lh (rh+2) then bal ll lx ld (join lr x d r)
+               else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr 
+               else create l x d r
+          end
+  end.
+
+(** * Splitting 
+
+    [split x m] returns a triple [(l, o, r)] where
+    - [l] is the set of elements of [m] that are [< x]
+    - [r] is the set of elements of [m] that are [> x]
+    - [o] is the result of [find x m].
+*)
+
+Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }.
+Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).
+
+Fixpoint split x m : triple := match m with 
+  | Leaf => << Leaf, None, Leaf >>
+  | Node l y d r h => 
+     match X.compare x y with 
+      | LT _ => let (ll,o,rl) := split x l in << ll, o, join rl y d r >>
+      | EQ _ => << l, Some d, r >>
+      | GT _ => let (rl,o,rr) := split x r in << join l y d rl, o, rr >>
+     end
+ end.
+
+(** * Concatenation 
+
+   Same as [merge] but does not assume anything about heights.
+*)
+
+Definition concat m1 m2 :=
+   match m1, m2 with
+      | Leaf, _ => m2
+      | _ , Leaf => m1
+      | _, Node l2 x2 d2 r2 _ =>
+            let (m2',xd) := remove_min l2 x2 d2 r2 in 
+            join m1 xd#1 xd#2 m2'
+   end.
+
+(** * 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)) m : list (key*elt) :=
+  match m with
+   | Leaf => acc
+   | Node l x d r _ => elements_aux ((x,d) :: elements_aux acc r) l
+  end.
+
+(** then [elements] is an instanciation with an empty [acc] *)
+
+Definition elements := elements_aux nil.
+
+(** * Fold *)
+
+Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A := 
+ fun a => match m with
+  | Leaf => a
+  | Node l x d r _ => fold f r (f x d (fold f l a))
+ end.
+
+(** * Comparison *)
+
+Variable cmp : elt->elt->bool.
+
+(** ** Enumeration of the elements of a tree *)
+
+Inductive enumeration :=
+ | End : enumeration
+ | More : key -> elt -> t -> enumeration -> enumeration.
+
+(** [cons m e] adds the elements of tree [m] on the head of 
+    enumeration [e]. *)
+
+Fixpoint cons m e : enumeration := 
+ match m with 
+  | Leaf => e
+  | Node l x d r h => cons l (More x d r e)
+ end.
+
+(** One step of comparison of elements *)
+
+Definition equal_more x1 d1 (cont:enumeration->bool) e2 :=
+ match e2 with
+ | End => false
+ | More x2 d2 r2 e2 =>
+     match X.compare x1 x2 with
+      | EQ _ => cmp d1 d2 &&& cont (cons r2 e2)
+      | _ => false
+     end
+ end.
+
+(** Comparison of left tree, middle element, then right tree *)
+
+Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := 
+ match m1 with
+  | Leaf => cont e2
+  | Node l1 x1 d1 r1 _ =>
+     equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2
+  end.
+
+(** Initial continuation *)
+
+Definition equal_end e2 := match e2 with End => true | _ => false end.
+
+(** The complete comparison *)
+
+Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End).
+
+End Elt.
+Notation t := tree.
+Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).
+Notation "t #l" := (t_left t) (at level 9, format "t '#l'").
+Notation "t #o" := (t_opt t) (at level 9, format "t '#o'").
+Notation "t #r" := (t_right t) (at level 9, format "t '#r'").
+
+
+(** * Map *)
+
+Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := 
+  match m with 
+   | Leaf   => Leaf _
+   | Node l x d r h => Node (map f l) x (f d) (map f r) h
+  end.
+
+(* * Mapi *)
+
+Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' :=
+  match m with 
+   | Leaf   => Leaf _
+   | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h
+  end.
+
+(** * Map with removal *)
+
+Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt)
+  : t elt' := 
+  match m with 
+   | Leaf => Leaf _
+   | Node l x d r h => 
+      match f x d with 
+       | Some d' => join (map_option f l) x d' (map_option f r)
+       | None => concat (map_option f l) (map_option f r)
+      end
+  end.
+
+(** * Optimized map2
+  
+  Suggestion by B. Gregoire: a [map2] function with specialized 
+  arguments allowing to bypass some tree traversal. Instead of one 
+  [f0] of type [key -> option elt -> option elt' -> option elt''], 
+  we ask here for: 
+  - [f] which is a specialisation of [f0] when first option isn't [None]
+  - [mapl] treats a [tree elt] with [f0] when second option is [None]
+  - [mapr] treats a [tree elt'] with [f0] when first option is [None]
+
+  The idea is that [mapl] and [mapr] can be instantaneous (e.g. 
+  the identity or some constant function). 
+*)
+
+Section Map2_opt.
+Variable elt elt' elt'' : Type.
+Variable f : key -> elt -> option elt' -> option elt''.
+Variable mapl : t elt -> t elt''.
+Variable mapr : t elt' -> t elt''.
+
+Fixpoint map2_opt m1 m2 := 
+ match m1, m2 with 
+  | Leaf, _ => mapr m2 
+  | _, Leaf => mapl m1
+  | Node l1 x1 d1 r1 h1, _ => 
+     let (l2',o2,r2') := split x1 m2 in
+     match f x1 d1 o2 with 
+      | Some e => join (map2_opt l1 l2') x1 e (map2_opt r1 r2')
+      | None => concat (map2_opt l1 l2') (map2_opt r1 r2')
+     end
+ end.
+
+End Map2_opt.
+
+(** * Map2
+    
+    The [map2] function of the Map interface can be implemented 
+    via [map2_opt] and [map_option].
+*)
+
+Section Map2.
+Variable elt elt' elt'' : Type.
+Variable f : option elt -> option elt' -> option elt''.
+
+Definition map2 : t elt -> t elt' -> t elt'' := 
+ map2_opt 
+   (fun _ d o => f (Some d) o)
+   (map_option (fun _ d => f (Some d) None))
+   (map_option (fun _ d' => f None (Some d'))).
+
+End Map2.
+
+
+
+(** * Invariants *)
+
+Section Invariants.
+Variable elt : Type.
+
+(** ** Occurrence in a tree *)
+
+Inductive MapsTo (x : key)(e : elt) : t elt -> 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', 
@@ -76,7 +437,7 @@ Inductive MapsTo (x : key)(e : elt) : tree -> Prop :=
   | 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 :=
+Inductive In (x : key) : t elt -> 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', 
@@ -84,58 +445,66 @@ Inductive In (x : key) : tree -> Prop :=
   | 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.
+Definition In0 k m := exists e:elt, MapsTo k e m.
 
-(** * Binary search trees *)
+(** ** 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.
+Definition lt_tree x m := forall y, In y m -> X.lt y x.
+Definition gt_tree x m := forall y, In y m -> 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).
+Inductive bst : t elt -> 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 *)
+End Invariants.
 
-(** [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.
+(** * Correctness proofs, isolated in a sub-module *)
 
-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).
+Module Proofs.
+ Module MX := OrderedTypeFacts X.
+ Module PX := KeyOrderedType X.
+ Module L := FMapList.Raw X.
 
-(* We should end this section before the big proofs that follows, 
-    otherwise the discharge takes a lot of time. *)
-End Elt. 
+Functional Scheme mem_ind := Induction for mem Sort Prop.
+Functional Scheme find_ind := Induction for find Sort Prop.
+Functional Scheme bal_ind := Induction for bal Sort Prop. 
+Functional Scheme add_ind := Induction for add Sort Prop.
+Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
+Functional Scheme merge_ind := Induction for merge Sort Prop. 
+Functional Scheme remove_ind := Induction for remove Sort Prop.
+Functional Scheme concat_ind := Induction for concat Sort Prop.
+Functional Scheme split_ind := Induction for split Sort Prop.
+Functional Scheme map_option_ind := Induction for map_option Sort Prop.
+Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop.
 
-(** Some helpful hints and tactics. *)
+(** * Automation and dedicated tactics. *)
 
-Notation t := tree.
-Hint Constructors tree.
-Hint Constructors MapsTo.
-Hint Constructors In.
-Hint Constructors bst.
-Hint Constructors avl.
+Hint Constructors tree MapsTo In bst.
 Hint Unfold lt_tree gt_tree.
 
+Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) 
+ "as" ident(s) :=  
+ set (s:=Node l x d r h) in *; clearbody s; clear l x d r h.
+
+(** A tactic for cleaning hypothesis after use of functional induction. *)
+
+Ltac clearf :=
+ match goal with 
+  | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf
+  | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf
+  | _ => idtac
+ end.
+
+(** 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
@@ -149,14 +518,6 @@ Ltac 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
@@ -166,55 +527,54 @@ Ltac inv_all f :=
    | _ => idtac
   end.
 
+(** Helper tactic concerning order of elements. *)
+
 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
+ | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order
+ | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; 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 *)
+(* Function/Functional Scheme can't deal with internal fix. 
+   Let's do its job by hand: *)
+
+Ltac join_tac := 
+ intros l; induction l as [| ll _ lx ld lr Hlr lh]; 
+   [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join;
+     [ | destruct (gt_le_dec lh (rh+2)); 
+       [ match goal with |- context [ bal ?u ?v ?w ?z ] =>
+           replace (bal u v w z) 
+           with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto]
+         end 
+       | destruct (gt_le_dec rh (lh+2)); 
+         [ match goal with |- context [ bal ?u ?v ?w ?z ] => 
+             replace (bal u v w z) 
+             with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] 
+           end
+         | ] ] ] ]; intros.
 
-Ltac avl_nns :=
-  match goal with 
-     | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns
-     | _ => idtac
-  end.
+Section Elt.
+Variable elt:Type.
+Implicit Types m r : t elt.
 
+(** * Basic results about [MapsTo], [In], [lt_tree], [gt_tree], [height] *)
 
 (** Facts about [MapsTo] and [In]. *)
 
-Lemma MapsTo_In : forall elt k e (m:t elt), MapsTo k e m -> In k m.
+Lemma MapsTo_In : forall k e m, 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.
+Lemma In_MapsTo : forall k m, 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.
+Lemma In_alt : forall k m, In0 k m <-> In k m.
 Proof. 
  split.
  intros (e,H); eauto.
@@ -222,64 +582,70 @@ Proof.
 Qed.
 
 Lemma MapsTo_1 :
- forall elt (m:t elt) x y e, X.eq x y -> MapsTo x e m -> MapsTo y e m.
+ forall m 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.
+ forall m x y, X.eq x y -> In x m -> In y m.
 Proof.
- intros elt m x y; induction m; simpl; intuition_in; eauto.
+ intros m x y; induction m; simpl; intuition_in; eauto.
 Qed.
 
+Lemma In_node_iff : 
+ forall l x e r h y, 
+  In y (Node l x e r h) <-> In y l \/ X.eq y x \/ In y r.
+Proof.
+ intuition_in.
+Qed.
 
 (** Results about [lt_tree] and [gt_tree] *)
 
-Lemma lt_leaf : forall elt x, lt_tree x (Leaf elt).
+Lemma lt_leaf : forall 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).
+Lemma gt_leaf : forall 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, 
+Lemma lt_tree_node : forall x y l 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.
+ unfold lt_tree in *; intuition_in; order.
 Qed.
 
-Lemma gt_tree_node : forall elt x y (l:t elt) r e h,
+Lemma gt_tree_node : forall x y l 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.
+ unfold gt_tree in *; intuition_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, 
+Lemma lt_left : forall x y l 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, 
+Lemma lt_right : forall x y l 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, 
+Lemma gt_left : forall x y l 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, 
+Lemma gt_right : forall x y l r e h, 
  gt_tree x (Node l y e r h) -> gt_tree x r.
 Proof.
  intuition_in.
@@ -288,731 +654,639 @@ 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.
+ forall x m, lt_tree x m -> ~ In x m.
 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.
+ forall x y, X.lt x y -> forall m, lt_tree x m -> lt_tree y m.
 Proof.
- firstorder eauto.
+ eauto.
 Qed.
 
 Lemma gt_tree_not_in :
- forall elt x (t : t elt), gt_tree x t -> ~ In x t.
+ forall x m, gt_tree x m -> ~ In x m.
 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.
+ forall x y, X.lt y x -> forall m, gt_tree x m -> gt_tree y m.
 Proof.
- firstorder eauto.
+ eauto.
 Qed.
 
 Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
 
-(** Results about [avl] *)
+(** * Empty map *)
 
-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)).
+Definition Empty m := forall (a:key)(e:elt) , ~ MapsTo a e m.
+
+Lemma empty_bst : bst (empty elt).
 Proof.
-  intros; auto.
+ unfold empty; 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]. *)
+Lemma empty_1 : Empty (empty elt).
+Proof.
+ unfold empty, Empty; intuition_in.
+Qed.
 
-Definition create elt (l:t elt) x e r := 
-   Node l x e r (max (height l) (height r) + 1).
+(** * Emptyness test *)
 
-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).
+Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. 
 Proof.
- unfold create; auto.
+ destruct m as [|r x e l h]; simpl; auto.
+ intro H; elim (H x e); 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.
+Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+Proof. 
+ destruct m; simpl; intros; try discriminate; red; intuition_in.
 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.
+(** * Appartness *)
+
+Lemma mem_1 : forall m x, bst m -> In x m -> mem x m = true.
+Proof. 
+ intros m x; functional induction (mem x m); auto; intros; clearf;
+  inv bst; intuition_in; order.
 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.
+Lemma mem_2 : forall m x, mem x m = true -> In x m. 
+Proof. 
+ intros m x; functional induction (mem x m); auto; intros; discriminate.
 Qed.
 
-(** trick for emulating [assert false] in Coq *)
+Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e.
+Proof. 
+ intros m x; functional induction (find x m); auto; intros; clearf;
+  inv bst; intuition_in; simpl; auto; 
+ try solve [order | absurd (X.lt x y); eauto | absurd (X.lt y x); eauto].
+Qed.
 
-Notation assert_false := Leaf.
+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; intros; clearf;
+  try discriminate.
+ constructor 2; auto.
+ inversion H; auto.
+ constructor 3; auto.
+Qed.
 
-(** [bal l x e r] acts as [create], but performs one step of
-    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
+Lemma find_iff : forall m x e, bst m -> 
+ (find x m = Some e <-> MapsTo x e m).
+Proof.
+ split; auto using find_1, find_2.
+Qed.
 
-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 find_in : forall m x, find x m <> None -> In x m.
+Proof.
+ intros.
+ case_eq (find x m); [intros|congruence].
+ apply MapsTo_In with e; apply find_2; auto. 
+Qed.
 
-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).
+Lemma in_find : forall m x, bst m -> In x m -> find x m <> None.
 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.
+ intros.
+ destruct (In_MapsTo H0) as (d,Hd).
+ rewrite (find_1 H Hd); discriminate.
 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).
+Lemma find_in_iff : forall m x, bst m -> 
+ (find x m <> None <-> In x m).
 Proof.
- bal_tac; inv avl; repeat apply create_avl; simpl in *; auto; omega_max.
+ split; auto using find_in, in_find.
 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.
+Lemma not_find_iff : forall m x, bst m ->
+ (find x m = None <-> ~In x m).
 Proof.
- bal_tac; inv avl; avl_nns; simpl in *; omega_max.
+ split; intros.
+ red; intros.
+ elim (in_find H H1 H0).
+ case_eq (find x m); [ intros | auto ].
+ elim H0; apply find_in; congruence.
 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.
+Lemma find_find : forall m m' x, 
+ find x m = find x m' <-> 
+ (forall d, find x m = Some d <-> find x m' = Some d).
 Proof.
- bal_tac; inv avl; simpl in *; omega_max.
+ intros; destruct (find x m); destruct (find x m'); split; intros; 
+  try split; try congruence.
+ rewrite H; auto.
+ symmetry; rewrite <- H; auto.
+ rewrite H; auto.
 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).
+Lemma find_mapsto_equiv : forall m m' x, bst m -> bst m' ->
+ (find x m = find x m' <-> 
+  (forall d, MapsTo x d m <-> MapsTo x d m')).
 Proof.
- bal_tac; bal_tac_imp; repeat rewrite create_in; intuition_in.
+ intros m m' x Hm Hm'.
+ rewrite find_find.
+ split; intros H d; specialize H with d.
+ rewrite <- 2 find_iff; auto.
+ rewrite 2 find_iff; auto.
 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)).
+Lemma find_in_equiv : forall m m' x, bst m -> bst m' -> 
+ find x m = find x m' -> 
+ (In x m <-> In x m').
 Proof.
- bal_tac; bal_tac_imp; unfold create; intuition_in.
+ split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ];
+  apply in_find; auto.
 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. 
+(** * Helper functions *)
 
-(** * Insertion *)
+Lemma create_bst : 
+ forall l 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.
 
-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 create_in : 
+ forall l 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.
 
-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.
+Lemma bal_bst : forall l x e r, bst l -> bst r -> 
+ lt_tree x l -> gt_tree x r -> bst (bal l x e r).
+Proof.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ inv bst; repeat apply create_bst; auto; unfold create; try constructor;
+ (apply lt_tree_node || apply gt_tree_node); auto; 
+ (eapply lt_tree_trans || eapply gt_tree_trans); eauto.
 Qed.
+Hint Resolve bal_bst.
 
-Lemma add_avl : forall elt (m:t elt) x e, avl m -> avl (add x e m).
+Lemma bal_in : forall l x e r y,
+ In y (bal l x e r) <-> X.eq y x \/ In y l \/ In y r.
 Proof.
- intros; generalize (add_avl_1 x e H); intuition.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ rewrite !create_in; intuition_in.
 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).
+Lemma bal_mapsto : forall l x e r y e',
+ MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r).
 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 H0); intuition_in.
- (* EQ *)  
- inv avl.
- firstorder_in.
- eapply In_1; eauto.
- (* GT *)
- inv avl.
- rewrite bal_in; auto.
- rewrite (IHt H1); intuition_in.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ unfold assert_false, create; 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 H0.
- intuition.
- eauto.
- (* gt_tree -> gt_tree (add ...) *)
- red; red in H4.
- intros.
- rewrite (add_in x y0 e H5) in H0.
- intuition.
- apply lt_eq with x; auto.
+Lemma bal_find : forall l x e r y, 
+ bst l -> bst r -> lt_tree x l -> gt_tree x r ->
+ find y (bal l x e r) = find y (create l x e r).
+Proof.
+ intros; rewrite find_mapsto_equiv; auto; intros; apply bal_mapsto.
 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).
+(** * Insertion *)
+
+Lemma add_in : forall m x y e,
+ In y (add x e m) <-> X.eq y x \/ In y m.
+Proof.
+ intros m x y e; functional induction (add x e m); auto; intros;
+ try (rewrite bal_in, IHt); intuition_in.
+ apply In_1 with x; auto.
+Qed.
+
+Lemma add_bst : forall m x e, bst m -> bst (add x e m).
+Proof.
+ intros m x e; functional induction (add x e m); intros;
+  inv bst; try apply bal_bst; auto;
+  intro z; rewrite add_in; intuition.
+ apply MX.eq_lt with x; auto.
+ apply MX.lt_eq with x; auto.
+Qed.
+Hint Resolve add_bst.
+
+Lemma add_1 : forall m x y e, 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. 
+ intros m x y e; functional induction (add x e m); 
+   intros; inv bst; 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 -> 
+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 elt m x y e e'; induction m; simpl; auto.
+ intros 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; 
+ intros; inv bst; 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 -> 
+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 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; 
+ intros m x y e e'; induction m; simpl; auto. 
+ intros; inv MapsTo; auto; order.
+ destruct (X.compare x k); intro; 
   try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; 
-  order. 
+  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.
+Lemma add_find : forall m x y e, bst m -> 
+ find y (add x e m) = 
+  match X.compare y x with EQ _ => Some e | _ => find y m end.
 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 e1. simpl in *.
- apply bal_avl; subst;auto; omega_max.
- rewrite_all e1;simpl in *;omega_bal.
+ intros.
+ assert (~X.eq x y -> find y (add x e m) = find y m).
+  intros; rewrite find_mapsto_equiv; auto.
+  split; eauto using add_2, add_3.
+ destruct X.compare; try (apply H0; order).
+ auto using find_1, add_1.
 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.
+(** * Extraction of minimum binding *)
 
-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))).
+Lemma remove_min_in : forall l x e r h y,
+ In y (Node l x e r h) <-> 
+  X.eq y (remove_min l x e r)#2#1 \/ In y (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.
+ intros 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 H0).
- 
- rewrite_all e1; simpl; intros.
- rewrite bal_in; auto.
- generalize (IHp lh y H0).
- intuition.
- inversion_clear H7; intuition.
+ rewrite e0 in *; simpl; intros.
+ rewrite bal_in, In_node_iff, IHp; 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)))).
+Lemma remove_min_mapsto : forall l x e r h y e',
+  MapsTo y e' (Node l x e r h) <-> 
+   ((X.eq y (remove_min l x e r)#2#1) /\ e' = (remove_min l x e r)#2#2)
+    \/ MapsTo y e' (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.
+ intros 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 H0).
- rewrite_all e1; simpl; intros.
+ rewrite e0 in *; simpl; intros.
  rewrite bal_mapsto; auto; unfold create.
- simpl in *;destruct (IHp lh y e').
- auto.
+ simpl in *;destruct (IHp _x y e').
  intuition.
- inversion_clear H2; intuition.
- inversion_clear H9; intuition.
+ inversion_clear H1; intuition.
+ inversion_clear H3; 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)).
+Lemma remove_min_bst : forall l x e r h, 
+ bst (Node l x e r h) -> bst (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.
+ intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
  inv bst; auto.
  inversion_clear H; inversion_clear H0.
  apply bal_bst; auto.
- rewrite_all e1;simpl in *;firstorder.
+ rewrite e0 in *; simpl in *; apply (IHp _x); auto.
  intro; intros.
- generalize (remove_min_in y H).
- rewrite_all e1; simpl in *.
+ generalize (remove_min_in ll lx ld lr _x y).
+ rewrite e0; simpl in *.
  destruct 1.
- apply H3; intuition.
+ apply H2; intuition.
 Qed.
+Hint Resolve remove_min_bst.
 
-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)).
+Lemma remove_min_gt_tree : forall l x e r h, 
+ bst (Node l x e r h) -> 
+ gt_tree (remove_min l x e r)#2#1 (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.
+ intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
  inv bst; auto.
- inversion_clear H; inversion_clear H0.
+ inversion_clear H.
  intro; intro.
- rewrite_all e1;simpl in *.
- generalize (IHp lh H1 H); clear H7 H6 IHp.
- generalize (remove_min_avl H).
- generalize (remove_min_in (fst m) H).
- rewrite e1; simpl; intros.
- rewrite (bal_in x e y H7 H5) in H0.
- destruct H6.
- 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 y.
- split; auto; avl_nns; simpl in *; omega_max.
- destruct s1;try contradiction;clear y.
- generalize (remove_min_avl_1 H0).
- rewrite e3; simpl;destruct 1.
- split.
- apply bal_avl; auto.
- simpl; omega_max.
- omega_bal.
+ rewrite e0 in *;simpl in *.
+ generalize (IHp _x H0).
+ generalize (remove_min_in ll lx ld lr _x m#1).
+ rewrite e0; simpl; intros.
+ rewrite (bal_in l' x d r y) in H.
+ assert (In m#1 (Node ll lx ld lr _x)) by (rewrite H4; auto); clear H4.
+ assert (X.lt m#1 x) by order.
+ decompose [or] H; order.
+Qed.
+Hint Resolve remove_min_gt_tree.
+
+Lemma remove_min_find : forall l x e r h y, 
+ bst (Node l x e r h) -> 
+ find y (Node l x e r h) = 
+   match X.compare y (remove_min l x e r)#2#1 with 
+    | LT _ => None
+    | EQ _ => Some (remove_min l x e r)#2#2
+    | GT _ => find y (remove_min l x e r)#1
+   end.
+Proof.
+ intros.
+ destruct X.compare.
+ rewrite not_find_iff; auto.
+ rewrite remove_min_in; red; destruct 1 as [H'|H']; [ order | ].
+ generalize (remove_min_gt_tree H H'); order.
+ apply find_1; auto.
+ rewrite remove_min_mapsto; auto.
+ rewrite find_mapsto_equiv; eauto; intros.
+ rewrite remove_min_mapsto; intuition; order.
 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.
+(** * Merging two trees *)
 
-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).
+Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 -> 
+ (In y (merge m1 m2) <-> In y m1 \/ In y m2).
 Proof. 
- intros elt s1 s2; functional induction (merge s1 s2);intros.
+ intros m1 m2; functional induction (merge m1 m2);intros;
+  try factornode _x _x0 _x1 _x2 _x3 as m1.
  intuition_in.
  intuition_in.
- destruct s1;try contradiction;clear y.
-(*  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 e3; auto].
- rewrite bal_in; auto.
- generalize (remove_min_avl H2); rewrite e3; simpl; auto.
- generalize (remove_min_in y0 H2); rewrite e3; simpl; intro.
- rewrite H3; intuition.
+ rewrite bal_in, remove_min_in, e1; simpl; 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).
+Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 -> 
+  (MapsTo y e (merge m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2).
 Proof.
- intros elt s1 s2; functional induction (@merge elt s1 s2); intros.
+ intros m1 m2; functional induction (merge m1 m2); intros; 
+  try factornode _x _x0 _x1 _x2 _x3 as m1.
  intuition_in.
  intuition_in.
- destruct s1;try contradiction;clear y.
- replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite e3; auto].
- rewrite bal_mapsto; auto; unfold create.
- generalize (remove_min_avl H2); rewrite e3; simpl; auto.
- generalize (remove_min_mapsto y0 e H2); rewrite e3; simpl; intro.
- rewrite H3; intuition (try subst; auto).
- inversion_clear H3; intuition.
+ rewrite bal_mapsto, remove_min_mapsto, e1; simpl; auto.
+ unfold create.
+ intuition; 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). 
+Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 -> 
+ (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> 
+ bst (merge m1 m2). 
 Proof.
- intros elt s1 s2; functional induction (@merge elt s1 s2); intros; auto.
-
+ intros m1 m2; functional induction (merge m1 m2); intros; auto;
+ try factornode _x _x0 _x1 _x2 _x3 as m1. 
  apply bal_bst; auto.
- destruct s1;try contradiction.
- generalize (remove_min_bst H1); rewrite e3; simpl in *; auto.
- destruct s1;try contradiction.
+ generalize (remove_min_bst H0); rewrite e1; simpl in *; auto.
  intro; intro.
- apply H3; auto.
- generalize (remove_min_in x H2); rewrite e3; simpl; intuition.
- destruct s1;try contradiction.
- generalize (remove_min_gt_tree H1); rewrite e3; 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 H0).
- split. 
- apply bal_avl; auto.
- omega_max.
- omega_bal.
- (* EQ *)
- inv avl. 
- generalize (merge_avl_1 H0 H1 H2).
- intuition omega_max.
- (* GT *)
- inv avl.
- destruct (IHt H1).
- split. 
- apply bal_avl; auto.
- omega_max.
- omega_bal.
+ apply H1; auto.
+ generalize (remove_min_in l2 x2 d2 r2 _x4 x); rewrite e1; simpl; intuition.
+ generalize (remove_min_gt_tree H0); rewrite e1; simpl; auto.
 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.
+(** * Deletion *)
 
-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).
+Lemma remove_in : forall m x y, bst m -> 
+ (In y (remove x m) <-> ~ X.eq y x /\ In y m).
 Proof.
- intros elt s x; functional induction (@remove elt x s); simpl; intros.
+ intros m x; functional induction (remove x m); simpl; intros.
  intuition_in.
  (* LT *)
- inv avl; inv bst; clear e1.
+ inv bst; clear e0.
  rewrite bal_in; auto.
  generalize (IHt y0 H0); intuition; [ order | order | intuition_in ].
  (* EQ *)
- inv avl; inv bst; clear e1.
+ inv bst; clear e0.
  rewrite merge_in; intuition; [ order | order | intuition_in ].
- elim H9; eauto.
+ elim H4; eauto.
  (* GT *)
- inv avl; inv bst; clear e1.
+ inv bst; clear e0.
  rewrite bal_in; auto.
- generalize (IHt y0 H5); intuition; [ order | order | intuition_in ].
+ generalize (IHt y0 H1); intuition; [ order | order | intuition_in ].
 Qed.
 
-Lemma remove_bst : forall elt (s:t elt) x, bst s -> avl s -> bst (remove x s).
+Lemma remove_bst : forall m x, bst m -> bst (remove x m).
 Proof. 
- intros elt s x; functional induction (@remove elt x s); simpl; intros.
+ intros m x; functional induction (remove x m); simpl; intros.
  auto.
  (* LT *)
- inv avl; inv bst.
+ inv bst.
  apply bal_bst; auto.
  intro; intro.
  rewrite (remove_in x y0 H0) in H; auto.
  destruct H; eauto.
  (* EQ *)
- inv avl; inv bst.
+ inv bst.
  apply merge_bst; eauto.
  (* GT *) 
- inv avl; inv bst.
+ inv bst.
  apply bal_bst; auto.
  intro; intro.
- rewrite (remove_in x y0 H5) in H; auto.
+ rewrite (remove_in x y0 H1) 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).
+Lemma remove_1 : forall m x y, bst m -> X.eq x y -> ~ In y (remove x m).
 Proof. 
  intros; rewrite remove_in; intuition.
-Qed. 
+Qed.
 
-Lemma remove_2 : forall elt (m:t elt) x y e, bst m -> avl m -> ~X.eq x y -> 
+Lemma remove_2 : forall m x y e, bst 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.
+ intros 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; 
+   intros; inv bst; 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 ->
+Lemma remove_3 : forall m x y e, bst 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; 
+ intros m x y e; induction m; simpl; auto.
+ destruct (X.compare x k); intros Bs; inv bst; 
   try rewrite bal_mapsto; auto; unfold create.
-  intros; inv MapsTo; auto. 
+  intros; inv MapsTo; auto.
   rewrite merge_mapsto; intuition.
   intros; inv MapsTo; auto.
 Qed.
 
-Section Elt2.
+(** * join *)
 
-Variable elt:Set.
+Lemma join_in : forall l x d r y, 
+ In y (join l x d 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.
+ rewrite bal_in, Hlr; clear Hlr Hrl; intuition_in.
+ rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in.
+ apply create_in.
+Qed.
 
-Notation eqk := (eqk (elt:= elt)).
-Notation eqke := (eqke (elt:= elt)).
-Notation ltk := (ltk (elt:= elt)).
+Lemma join_bst : forall l x d r, bst l -> bst r -> 
+ lt_tree x l -> gt_tree x r -> bst (join l x d r).
+Proof.
+ join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; 
+ clear Hrl Hlr z; intro; intros; rewrite join_in in *.
+ intuition; [ apply MX.lt_eq with x | ]; eauto.
+ intuition; [ apply MX.eq_lt with x | ]; eauto.
+Qed.
+Hint Resolve join_bst.
 
-(** * Empty map *)
+Lemma join_find : forall l x d r y, 
+ bst l -> bst r -> lt_tree x l -> gt_tree x r -> 
+ find y (join l x d r) = find y (create l x d r).
+Proof.
+ join_tac; auto; inv bst;
+  simpl (join (Leaf elt)); 
+  try (assert (X.lt lx x) by auto); 
+  try (assert (X.lt x rx) by auto);
+  rewrite ?add_find, ?bal_find; auto.
 
-Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
+ simpl; destruct X.compare; auto.
+ rewrite not_find_iff; auto; intro; order.
 
-Definition empty := (Leaf elt).
+ simpl; repeat (destruct X.compare; auto); try (order; fail).
+ rewrite not_find_iff by auto; intro.
+ assert (X.lt y x) by auto; order.
 
-Lemma empty_bst : bst empty.
+ simpl; rewrite Hlr; simpl; auto.
+ repeat (destruct X.compare; auto); order.
+ intros u Hu; rewrite join_in in Hu.
+  destruct Hu as [Hu|[Hu|Hu]]; try generalize (H2 _ Hu); order.
+
+ simpl; rewrite Hrl; simpl; auto.
+ repeat (destruct X.compare; auto); order.
+ intros u Hu; rewrite join_in in Hu.
+  destruct Hu as [Hu|[Hu|Hu]]; order.
+Qed.
+
+(** * split *)
+
+Lemma split_in_1 : forall m x, bst m -> forall y, 
+ (In y (split x m)#l <-> In y m /\ X.lt y x).
 Proof.
- unfold empty; auto.
+ intros m x; functional induction (split x m); simpl; intros; 
+  inv bst; try clear e0.
+ intuition_in.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
+ intuition_in; order.
+ rewrite join_in.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
 Qed.
 
-Lemma empty_avl : avl empty.
+Lemma split_in_2 : forall m x, bst m -> forall y, 
+ (In y (split x m)#r <-> In y m /\ X.lt x y).
 Proof. 
- unfold empty; auto.
+ intros m x; functional induction (split x m); subst; simpl; intros; 
+  inv bst; try clear e0.
+ intuition_in.
+ rewrite join_in.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
+ intuition_in; order.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
 Qed.
 
-Lemma empty_1 : Empty empty.
+Lemma split_in_3 : forall m x, bst m -> 
+ (split x m)#o = find x m.
 Proof.
- unfold empty, Empty; intuition_in.
+ intros m x; functional induction (split x m); subst; simpl; auto;
+  intros; inv bst; try clear e0; 
+  destruct X.compare; try (order;fail); rewrite <-IHt, e1; auto.
 Qed.
 
-(** * Emptyness test *)
-
-Definition is_empty (s:t elt) := match s with Leaf => true | _ => false end.
+Lemma split_bst : forall m x, bst m -> 
+ bst (split x m)#l /\ bst (split x m)#r.
+Proof. 
+ intros m x; functional induction (split x m); subst; simpl; intros; 
+  inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition;
+  apply join_bst; auto.
+ intros y0.
+ generalize (split_in_2 x H0 y0); rewrite e1; simpl; intuition.
+ intros y0.
+ generalize (split_in_1 x H1 y0); rewrite e1; simpl; intuition.
+Qed.
 
-Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. 
+Lemma split_lt_tree : forall m x, bst m -> lt_tree x (split x m)#l.
 Proof.
- destruct s as [|r x e l h]; simpl; auto.
- intro H; elim (H x e); auto.
+ intros m x B y Hy; rewrite split_in_1 in Hy; intuition.
 Qed.
 
-Lemma is_empty_2 : forall s, is_empty s = true -> Empty s.
-Proof. 
- destruct s; simpl; intros; try discriminate; red; intuition_in.
+Lemma split_gt_tree : forall m x, bst m -> gt_tree x (split x m)#r.
+Proof.
+ intros m x B y Hy; rewrite split_in_2 in Hy; intuition.
 Qed.
 
-(** * Appartness *)
+Lemma split_find : forall m x y, bst m -> 
+ find y m = match X.compare y x with 
+              | LT _ => find y (split x m)#l
+              | EQ _ => (split x m)#o
+              | GT _ => find y (split x m)#r
+            end.
+Proof.
+ intros m x; functional induction (split x m); subst; simpl; intros; 
+  inv bst; try clear e0; try rewrite e1 in *; simpl in *; 
+  [ destruct X.compare; auto | .. ];
+  try match goal with E:split ?x ?t = _, B:bst ?t |- _ => 
+      generalize (split_in_1 x B)(split_in_2 x B)(split_bst x B);
+       rewrite E; simpl; destruct 3 end.
 
-(** The [mem] function is deciding appartness. It exploits the [bst] property
-    to achieve logarithmic complexity. *)
+ rewrite join_find, IHt; auto; clear IHt; simpl.
+ repeat (destruct X.compare; auto); order.
+ intro y1; rewrite H4; intuition.
 
-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. 
+ repeat (destruct X.compare; auto); order.
 
-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.
+ rewrite join_find, IHt; auto; clear IHt; simpl.
+ repeat (destruct X.compare; auto); order.
+ intros y1; rewrite H; intuition.
 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.
+(** * Concatenation *)
 
-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.
+Lemma concat_in : forall m1 m2 y, 
+ In y (concat m1 m2) <-> In y m1 \/ In y m2.
+Proof.
+ intros m1 m2; functional induction (concat m1 m2); intros;
+  try factornode _x _x0 _x1 _x2 _x3 as m1.
+ intuition_in.
  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.
+ rewrite join_in, remove_min_in, e1; simpl; intuition.
 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.
+Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 -> 
+ (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> 
+ bst (concat m1 m2).
+Proof.
+ intros m1 m2; functional induction (concat m1 m2); intros; auto; 
+ try factornode _x _x0 _x1 _x2 _x3 as m1.
+ apply join_bst; auto.
+ change (bst (m2',xd)#1); rewrite <-e1; eauto.
+ intros y Hy.
+ apply H1; auto.
+ rewrite remove_min_in, e1; simpl; auto.
+ change (gt_tree (m2',xd)#2#1 (m2',xd)#1); rewrite <-e1; eauto.
 Qed.
+Hint Resolve concat_bst.
 
-(** * Elements *)
+Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> 
+ (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> 
+ find y (concat m1 m2) = 
+  match find y m2 with Some d => Some d | None => find y m1 end.
+Proof.
+ intros m1 m2; functional induction (concat m1 m2); intros; auto; 
+ try factornode _x _x0 _x1 _x2 _x3 as m1.
+ simpl; destruct (find y m2); auto.
 
-(** [elements_tree_aux acc t] catenates the elements of [t] in infix
-    order to the list [acc] *)
+ generalize (remove_min_find y H0)(remove_min_in l2 x2 d2 r2 _x4)
+  (remove_min_bst H0)(remove_min_gt_tree H0); 
+  rewrite e1; simpl fst; simpl snd; intros.
+ 
+ inv bst.
+ rewrite H2, join_find; auto; clear H2.
+ simpl; destruct X.compare; simpl; auto.
+ destruct (find y m2'); auto.
+ symmetry; rewrite not_find_iff; auto; intro.
+ apply (MX.lt_not_gt l); apply H1; auto; rewrite H3; auto.
 
-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.
+ intros z Hz; apply H1; auto; rewrite H3; auto.
+Qed.
 
-(** then [elements] is an instanciation with an empty [acc] *)
 
-Definition elements := elements_aux nil.
+(** * Elements *)
 
-Lemma elements_aux_mapsto : forall s acc x e, 
+Notation eqk := (PX.eqk (elt:= elt)).
+Notation eqke := (PX.eqke (elt:= elt)).
+Notation ltk := (PX.ltk (elt:= elt)).
+
+Lemma elements_aux_mapsto : forall (s:t elt) 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.
@@ -1025,13 +1299,13 @@ Proof.
  destruct H0; simpl in *; subst; intuition.
 Qed.
 
-Lemma elements_mapsto : forall s x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. 
+Lemma elements_mapsto : forall (s:t elt) 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.
+Lemma elements_in : forall (s:t elt) x, L.PX.In x (elements s) <-> In x s.
 Proof.
  intros.
  unfold L.PX.In.
@@ -1043,7 +1317,7 @@ Proof.
  unfold L.PX.MapsTo; rewrite elements_mapsto; auto.
 Qed.
 
-Lemma elements_aux_sort : forall s acc, bst s -> sort ltk acc ->
+Lemma elements_aux_sort : forall (s:t elt) 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.
@@ -1052,7 +1326,7 @@ Proof.
  apply Hl; auto.
  constructor. 
  apply Hr; eauto.
- apply (InA_InfA (eqke_refl (elt:=elt))); intros (y',e') H6.
+ apply (InA_InfA (PX.eqke_refl (elt:=elt))); intros (y',e') H6.
  destruct (elements_aux_mapsto r acc y' e'); intuition.
  red; simpl; eauto.
  red; simpl; eauto.
@@ -1070,20 +1344,49 @@ Proof.
 Qed.
 Hint Resolve elements_sort.
 
+Lemma elements_nodup : forall s : t elt, bst s -> NoDupA eqk (elements s).
+Proof.
+ intros; apply PX.Sort_NoDupA; auto.
+Qed.
 
-(** * Fold *)
+Lemma elements_aux_cardinal :
+ forall (m:t elt) acc, (length acc + cardinal m)%nat = length (elements_aux acc m).
+Proof.
+ simple induction m; simpl; intuition.
+ rewrite <- H; simpl.
+ rewrite <- H0; omega.
+Qed.
 
-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.
+Lemma elements_cardinal : forall (m:t elt), cardinal m = length (elements m).
+Proof.
+ exact (fun m => elements_aux_cardinal m nil).
+Qed.
 
-Definition fold' (A : Set) (f : key -> elt -> A -> A)(s : t elt) := 
+Lemma elements_app :
+ forall (s:t elt) acc, elements_aux acc s = elements s ++ acc.
+Proof.
+ induction s; simpl; intros; auto.
+ rewrite IHs1, IHs2.
+ unfold elements; simpl.
+ rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto.
+Qed.
+
+Lemma elements_node :
+ forall (t1 t2:t elt) x e z l,
+ elements t1 ++ (x,e) :: elements t2 ++ l =
+ elements (Node t1 x e t2 z) ++ l.
+Proof.
+ unfold elements; simpl; intros.
+ rewrite !elements_app, <- !app_nil_end, !app_ass; auto.
+Qed.
+
+(** * Fold *)
+
+Definition fold' (A : Type) (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,
+ forall (A : Type) (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.
@@ -1095,7 +1398,7 @@ Proof.
 Qed.
 
 Lemma fold_equiv :
- forall (A : Set) (s : t elt) (f : key -> elt -> A -> A) (a : A),
+ forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A),
  fold f s a = fold' f s a.
 Proof.
  unfold fold', elements in |- *. 
@@ -1106,8 +1409,8 @@ Proof.
 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.
+ forall (s:t elt)(Hs:bst s)(A : Type)(i:A)(f : key -> elt -> A -> A),
+ fold f s i = fold_left (fun a p => f p#1 p#2 a) (elements s) i.
 Proof.
  intros.
  rewrite fold_equiv.
@@ -1118,288 +1421,93 @@ 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 *)
+(** [flatten_e e] returns the list of elements of the enumeration [e] 
+    i.e. the list of elements actually compared *)
  
-Fixpoint flatten_e (e : enumeration) : list (key*elt) := match e with
+Fixpoint flatten_e (e : enumeration elt) : 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.
+Lemma flatten_e_elements :
+ forall (l:t elt) 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 elements_node.
 Qed.
 
-Lemma sorted_flatten_e :
- forall e : enumeration, sorted_e e -> sort ltk (flatten_e e).
+Lemma cons_1 : forall (s:t elt) e, 
+  flatten_e (cons s e) = elements s ++ 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.
+  induction s; simpl; auto; intros.
+  rewrite IHs1; apply flatten_e_elements; auto.
 Qed.
 
-Lemma elements_app :
- forall s acc, elements_aux acc s = elements s ++ acc.
+(** Proof of correction for the comparison *)
+
+Variable cmp : elt->elt->bool.
+
+Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b.
+
+Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, 
+  X.eq x1 x2 -> cmp d1 d2 = true -> 
+  IfEq b l1 l2 -> 
+    IfEq b ((x1,d1)::l1) ((x2,d2)::l2).
 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.
+ unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl; 
+  try rewrite H0; auto; order.
 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.
+Lemma equal_end_IfEq : forall e2, 
+  IfEq (equal_end e2) nil (flatten_e e2).
 Proof.
- simpl in |- *; unfold elements in |- *; simpl in |- *; intuition.
- repeat rewrite elements_app.
- repeat rewrite <- app_nil_end.
- repeat rewrite app_ass; auto.
+ destruct e2; red; 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.
+Lemma equal_more_IfEq : 
+ forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, 
+  IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> 
+    IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l)
+       (flatten_e (More x2 d2 r2 e2)).
 Proof.
- intros; simpl.
- apply compare_flatten_1.
+ unfold IfEq; simpl; intros; destruct X.compare; simpl; auto.
+ rewrite <-andb_lazy_alt; f_equal; auto.
 Qed.
 
-Open Local 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.
+Lemma equal_cont_IfEq : forall m1 cont e2 l, 
+  (forall e, IfEq (cont e) l (flatten_e e)) ->
+  IfEq (equal_cont cmp m1 cont e2) (elements m1 ++ l) (flatten_e e2).
 Proof.
- simple induction s.
- simpl in |- *; omega.
- intros.
- Measure_e_t; omega.
+ induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; simpl; intros; auto.
+ rewrite <- elements_node; simpl.
+ apply Hl1; auto.
+ clear e2; intros [|x2 d2 r2 e2].
+ simpl; red; auto.
+ apply equal_more_IfEq.
+ rewrite <- cons_1; auto.
 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.
+Lemma equal_IfEq : forall (m1 m2:t elt),
+  IfEq (equal cmp m1 m2) (elements m1) (elements m2).
 Proof.
- simple induction e.
- simpl in |- *; omega.
+ intros; unfold equal.
+ rewrite (app_nil_end (elements m1)).
+ replace (elements m2) with (flatten_e (cons m2 (End _))) 
+  by (rewrite cons_1; simpl; rewrite <-app_nil_end; auto).
+ apply equal_cont_IfEq.
  intros.
- Measure_e; Measure_e_t_0 t; omega.
+ apply equal_end_IfEq; auto.
 Qed.
 
-Ltac Measure_e_0 e := generalize (@measure_e_0 e); intro.
-
-(** Induction principle over the sum of the measures for two lists *)
+Definition Equivb 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).
 
-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'.
+Lemma Equivb_elements : forall s s', 
+ Equivb s s' <-> L.Equivb cmp (elements s) (elements s').
 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.
+unfold Equivb, L.Equivb; split; split; intros.
 do 2 rewrite elements_in; firstorder.
 destruct H.
 apply (H2 k); rewrite <- elements_mapsto; auto.
@@ -1408,95 +1516,46 @@ 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'}.
+Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' -> 
+  (equal cmp s s' = true <-> Equivb 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.
+ intros s s' B B'.
+ rewrite Equivb_elements, <- equal_IfEq.
+ split; [apply L.equal_2|apply L.equal_1]; auto.
 Qed.
 
-End Elt2.
-
-Section Elts. 
-
-Variable elt elt' elt'' : Set.
+End Elt.
 
 Section Map. 
+Variable elt elt' : Type.
 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).
+Lemma map_1 : forall (m: t elt)(x:key)(e:elt), 
+    MapsTo x e m -> MapsTo x (f e) (map f 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.
+    In x (map f m) -> In x m.
 Proof.
 induction m; simpl; inversion_clear 1; auto.
 Qed.
 
-Lemma map_bst : forall m, bst m -> bst (map m).
+Lemma map_bst : forall m, bst m -> bst (map f 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.
+inversion_clear 1; constructor; auto; 
+ red; auto using map_2.
 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.
+Section Mapi.
+Variable elt elt' : Type.
+Variable f : key -> elt -> elt'.
 
 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).
+    MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
 Proof.
 induction m; simpl; inversion_clear 1; auto.
 exists k; auto.
@@ -1507,198 +1566,242 @@ exists x0; intuition.
 Qed.
 
 Lemma mapi_2 : forall (m: t elt)(x:key), 
-    In x (mapi m) -> In x m.
+    In x (mapi f m) -> In x m.
 Proof.
 induction m; simpl; inversion_clear 1; auto.
 Qed.
 
-Lemma mapi_bst : forall m, bst m -> bst (mapi m).
+Lemma mapi_bst : forall m, bst m -> bst (mapi f 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.
+inversion_clear 1; constructor; auto; 
+ red; auto using mapi_2.
 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 _).
+Section Map_option.
+Variable elt elt' : Type.
+Variable f : key -> elt -> option elt'.
+Hypothesis f_compat : forall x x' d, X.eq x x' -> f x d = f x' d.
 
-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).
+Lemma map_option_2 : forall (m:t elt)(x:key), 
+ In x (map_option f m) -> exists d, MapsTo x d m /\ f x d <> None.
 Proof.
-unfold anti_elements; induction l.
-simpl; auto.
-simpl; destruct a; intros.
-apply IHl.
-apply add_avl; auto.
+intros m; functional induction (map_option f m); simpl; auto; intros.
+inversion H.
+rewrite join_in in H; destruct H as [H|[H|H]].
+exists d; split; auto; rewrite (f_compat d H), e0; discriminate.
+destruct (IHt _ H) as (d0 & ? & ?); exists d0; auto.
+destruct (IHt0 _ H) as (d0 & ? & ?); exists d0; auto.
+rewrite concat_in in H; destruct H as [H|H].
+destruct (IHt _ H) as (d0 & ? & ?); exists d0; auto.
+destruct (IHt0 _ H) as (d0 & ? & ?); exists d0; auto.
 Qed.
 
-Lemma anti_elements_avl : forall l, avl (anti_elements l).
+Lemma map_option_bst : forall m, bst m -> bst (map_option f m).
 Proof.
-unfold anti_elements, empty; intros; apply anti_elements_avl_aux; auto.
-Qed.
+intros m; functional induction (map_option f m); simpl; auto; intros; 
+ inv bst.
+apply join_bst; auto; intros y H; 
+ destruct (map_option_2 H) as (d0 & ? & ?); eauto using MapsTo_In.
+apply concat_bst; auto; intros y y' H H'.
+destruct (map_option_2 H) as (d0 & ? & ?).
+destruct (map_option_2 H') as (d0' & ? & ?).
+eapply X.lt_trans with x; eauto using MapsTo_In.
+Qed.
+Hint Resolve map_option_bst.
+
+Ltac nonify e := 
+ replace e with (@None elt) by 
+  (symmetry; rewrite not_find_iff; auto; intro; order).
+
+Lemma map_option_find : forall (m:t elt)(x:key), 
+ bst m -> 
+ find x (map_option f m) = 
+  match (find x m) with Some d => f x d | None => None end.
+Proof.
+intros m; functional induction (map_option f m); simpl; auto; intros;
+ inv bst; rewrite join_find || rewrite concat_find; auto; simpl; 
+ try destruct X.compare; simpl; auto.
+rewrite (f_compat d e); auto.
+intros y H;
+ destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In.
+intros y H; 
+ destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In.
+
+rewrite <- IHt, IHt0; auto; nonify (find x0 r); auto.
+rewrite IHt, IHt0; auto; nonify (find x0 r); nonify (find x0 l); auto.
+rewrite (f_compat d e); auto.
+rewrite <- IHt0, IHt; auto; nonify (find x0 l); auto.
+ destruct (find x0 (map_option f r)); auto.
+
+intros y y' H H'.
+destruct (map_option_2 H) as (? & ? & ?).
+destruct (map_option_2 H') as (? & ? & ?).
+eapply X.lt_trans with x; eauto using MapsTo_In.
+Qed.
+
+End Map_option.
+
+Section Map2_opt.
+Variable elt elt' elt'' : Type.
+Variable f0 : key -> option elt -> option elt' -> option elt''.
+Variable f : key -> elt -> option elt' -> option elt''.
+Variable mapl : t elt -> t elt''.
+Variable mapr : t elt' -> t elt''.
+Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o.
+Hypothesis mapl_bst : forall m, bst m -> bst (mapl m).
+Hypothesis mapr_bst : forall m', bst m' -> bst (mapr m').
+Hypothesis mapl_f0 : forall x m, bst m -> 
+ find x (mapl m) = 
+  match find x m with Some d => f0 x (Some d) None | None => None end.
+Hypothesis mapr_f0 : forall x m', bst m' -> 
+ find x (mapr m') = 
+  match find x m' with Some d' => f0 x None (Some d') | None => None end.
+Hypothesis f0_compat : forall x x' o o', X.eq x x' -> f0 x o o' = f0 x' o o'.
+
+Notation map2_opt := (map2_opt f mapl mapr).
+
+Lemma map2_opt_2 : forall m m' y, bst m -> bst m' -> 
+  In y (map2_opt m m') -> In y m \/ In y m'.
+Proof.
+intros m m'; functional induction (map2_opt m m'); intros;
+ auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; 
+ try (generalize (split_in_1 x1 H0 y)(split_in_2 x1 H0 y)
+      (split_bst x1 H0); rewrite e1; simpl; destruct 3; inv bst).
+
+right; apply find_in.
+generalize (in_find (mapr_bst H0) H1); rewrite mapr_f0; auto.
+destruct (find y m2); auto; intros; discriminate.
+
+factornode l1 x1 d1 r1 _x as m1.
+left; apply find_in.
+generalize (in_find (mapl_bst H) H1); rewrite mapl_f0; auto.
+destruct (find y m1); auto; intros; discriminate.
+
+rewrite join_in in H1; destruct H1 as [H'|[H'|H']]; auto.
+destruct (IHt1 y H6 H4 H'); intuition.
+destruct (IHt0 y H7 H5 H'); intuition.
+
+rewrite concat_in in H1; destruct H1 as [H'|H']; auto.
+destruct (IHt1 y H6 H4 H'); intuition.
+destruct (IHt0 y H7 H5 H'); intuition.
+Qed.
+
+Lemma map2_opt_bst : forall m m', bst m -> bst m' -> 
+ bst (map2_opt m m').
+Proof.
+intros m m'; functional induction (map2_opt m m'); intros;
+ auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst; 
+ generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0); 
+  rewrite e1; simpl in *; destruct 3.
+
+apply join_bst; auto.
+intros y Hy; specialize H with y.
+destruct (map2_opt_2 H1 H6 Hy); intuition.
+intros y Hy; specialize H5 with y.
+destruct (map2_opt_2 H2 H7 Hy); intuition.
+
+apply concat_bst; auto.
+intros y y' Hy Hy'; specialize H with y; specialize H5 with y'.
+apply X.lt_trans with x1.
+destruct (map2_opt_2 H1 H6 Hy); intuition.
+destruct (map2_opt_2 H2 H7 Hy'); intuition.
+Qed.
+Hint Resolve map2_opt_bst.
+
+Ltac map2_aux := 
+ match goal with
+  | H : In ?x _ \/ In ?x ?m, 
+    H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ => 
+    destruct H; [ intuition_in; order | 
+                  rewrite <-(find_in_equiv B B' H'); auto ]
+ end.
 
-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.
+Ltac nonify t := 
+ match t with (find ?y (map2_opt ?m ?m')) => 
+ replace t with (@None elt'');
+ [ | symmetry; rewrite not_find_iff; auto; intro;
+     destruct (@map2_opt_2 m m' y); auto; order ]
+ end.
 
-Lemma anti_elements_bst : forall l, bst (anti_elements l).
-Proof.
-unfold anti_elements, empty; intros; apply anti_elements_bst_aux; auto.
-Qed.
+Lemma map2_opt_1 : forall m m' y, bst m -> bst m' -> 
+ In y m \/ In y m' ->
+ find y (map2_opt m m') = f0 y (find y m) (find y m').
+Proof.
+intros m m'; functional induction (map2_opt m m'); intros;
+ auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; 
+ try (generalize (split_in_1 x1 H0)(split_in_2 x1 H0)
+       (split_in_3 x1 H0)(split_bst x1 H0)(split_find x1 y H0)
+       (split_lt_tree (x:=x1) H0)(split_gt_tree (x:=x1) H0);
+       rewrite e1; simpl in *; destruct 4; intros; inv bst; 
+      subst o2; rewrite H7, ?join_find, ?concat_find; auto).
+
+simpl; destruct H1; [ inversion_clear H1 | ].
+rewrite mapr_f0; auto.
+generalize (in_find H0 H1); destruct (find y m2); intuition.
+
+factornode l1 x1 d1 r1 _x as m1.
+destruct H1; [ | inversion_clear H1 ].
+rewrite mapl_f0; auto.
+generalize (in_find H H1); destruct (find y m1); intuition.
+
+simpl; destruct X.compare; auto.
+apply IHt1; auto; map2_aux.
+rewrite (@f0_compat y x1), <- f0_f; auto.
+apply IHt0; auto; map2_aux.
+intros z Hz; destruct (@map2_opt_2 l1 l2' z); auto.
+intros z Hz; destruct (@map2_opt_2 r1 r2' z); auto.
+
+destruct X.compare.
+nonify (find y (map2_opt r1 r2')).
+apply IHt1; auto; map2_aux.
+nonify (find y (map2_opt r1 r2')).
+nonify (find y (map2_opt l1 l2')).
+rewrite (@f0_compat y x1), <- f0_f; auto.
+nonify (find y (map2_opt l1 l2')).
+rewrite IHt0; auto; [ | map2_aux ].
+destruct (f0 y (find y r1) (find y r2')); auto.
+intros y1 y2 Hy1 Hy2; apply X.lt_trans with x1.
+ destruct (@map2_opt_2 l1 l2' y1); auto.
+ destruct (@map2_opt_2 r1 r2' y2); auto.
+Qed.
+
+End Map2_opt.
 
-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.
+Section Map2.
+Variable elt elt' elt'' : Type.
+Variable f : option elt -> option elt' -> option elt''.
 
-Lemma map2_avl : forall (m: t elt)(m': t elt'), avl (map2 m m').
+Lemma map2_bst : forall m m', bst m -> bst m' -> bst (map2 f m m').
 Proof.
-unfold map2; intros; apply anti_elements_avl; auto.
+unfold map2; intros.
+apply map2_opt_bst with (fun _ => f); auto using map_option_bst; 
+ intros; rewrite map_option_find; auto.
 Qed.
 
-Lemma map2_bst : forall (m: t elt)(m': t elt'), bst (map2 m m').
+Lemma map2_1 : forall m m' y, bst m -> bst m' -> 
+  In y m \/ In y m' -> find y (map2 f m m') = f (find y m) (find y 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.
+rewrite (map2_opt_1 (f0:=fun _ => f)); 
+ auto using map_option_bst; intros; rewrite map_option_find; 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'.
+Lemma map2_2 : forall m m' y, bst m -> bst m' -> 
+  In y (map2 f m m') -> In y m \/ In y 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.
+eapply map2_opt_2 with (f0:=fun _ => f); eauto; intros.
+ apply map_option_bst; auto.
+ apply map_option_bst; auto.
+ rewrite map_option_find; auto.
+ rewrite map_option_find; auto.
 Qed.
 
 End Map2.
-End Elts.
+End Proofs.
 End Raw.
 
 (** * Encapsulation
@@ -1710,178 +1813,184 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
 
  Module E := X.
  Module Raw := Raw I X. 
+ Import Raw.Proofs.
 
- Record bbst (elt:Set) : Set := 
-  Bbst {this :> Raw.tree elt; is_bst : Raw.bst this; is_avl: Raw.avl this}.
+ Record bst (elt:Type) := 
+  Bst {this :> Raw.tree elt; is_bst : Raw.bst this}.
  
- Definition t := bbst. 
+ Definition t := bst. 
  Definition key := E.t.
  
  Section Elt. 
- Variable elt elt' elt'': Set.
+ Variable elt elt' elt'': Type.
 
  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 empty : t elt := Bst (empty_bst 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 add x e m : t elt := Bst (add_bst x e m.(is_bst)).
+ Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)). 
  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 map f m : t elt' := Bst (map_bst f m.(is_bst)).
  Definition mapi (f:key->elt->elt') m : t elt' := 
-  Bbst (Raw.mapi_bst f m.(is_bst)) (Raw.mapi_avl f m.(is_avl)).
+  Bst (mapi_bst f m.(is_bst)).
  Definition map2 f m (m':t elt') : t elt'' := 
-  Bbst (Raw.map2_bst f m m') (Raw.map2_avl f m m').
+  Bst (map2_bst f m.(is_bst) m'.(is_bst)).
  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 cardinal m := Raw.cardinal m.(this).
+ Definition fold (A:Type) (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i.
+ Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this).
 
  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 Empty m : Prop := 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.
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt.
+ Definition lt_key : (key*elt) -> (key*elt) -> Prop := @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.
+ Proof. intros m; exact (@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.
+ unfold In, mem; intros m x; rewrite In_alt; simpl; apply 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.
+ unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto.
  Qed.
 
  Lemma empty_1 : Empty empty.
- Proof. exact (@Raw.empty_1 elt). Qed.
+ Proof. exact (@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.
+ Proof. intros m; exact (@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.
+ Proof. intros m; exact (@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.
+ Proof. intros m x y e; exact (@add_1 elt _ x y e). 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.
+ Proof. intros m x y e e'; exact (@add_2 elt _ x y e e'). 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.
+ Proof. intros m x y e e'; exact (@add_3 elt _ x y e e'). 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.
+ unfold In, remove; intros m x y; rewrite In_alt; simpl; apply 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.
+ Proof. intros m x y e; exact (@remove_2 elt _ x y e m.(is_bst)). 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.
+ Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). 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.
+ Proof. intros m x e; exact (@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.
+ Proof. intros m; exact (@find_2 elt m.(this)). Qed.
 
- Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A),
+ Lemma fold_1 : forall m (A : Type) (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.
+ Proof. intros m; exact (@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.
+ intros; unfold elements, MapsTo, eq_key_elt; rewrite 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.
+ intros; unfold elements, MapsTo, eq_key_elt; rewrite <- 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.
+ Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed.
 
- Definition Equal cmp m m' := 
+ Lemma elements_3w : forall m, NoDupA eq_key (elements m).  
+ Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed.
+
+ Lemma cardinal_1 : forall m, cardinal m = length (elements m).
+ Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed.
+
+ Definition Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) 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).  
+   (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb cmp := Equiv (Cmp cmp).
 
- Lemma Equal_Equal : forall cmp m m', Equal cmp m m' <-> Raw.Equal cmp m m'.
+ Lemma Equivb_Equivb : forall cmp m m', 
+  Equivb cmp m m' <-> Raw.Proofs.Equivb 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. 
+ intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition.
+ generalize (H0 k); do 2 rewrite In_alt; intuition.
+ generalize (H0 k); do 2 rewrite In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- In_alt; intuition.
+ Qed.
 
  Lemma equal_1 : forall m m' cmp, 
-   Equal cmp m m' -> equal cmp m m' = true. 
+   Equivb 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.
+ unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; 
+  intros; simpl in *; rewrite equal_Equivb; auto.
  Qed. 
 
  Lemma equal_2 : forall m m' cmp, 
-   equal cmp m m' = true -> Equal cmp m m'.
+   equal cmp m m' = true -> Equivb cmp m m'.
  Proof. 
- unfold equal; intros; rewrite Equal_Equal.
- destruct (@Raw.equal _ cmp m m'); auto; try discriminate.
- Qed.  
+ unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; 
+  intros; simpl in *; rewrite <-equal_Equivb; auto.
+ Qed.
 
  End Elt.
 
- Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+ Lemma map_1 : forall (elt elt':Type)(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.
+ Proof. intros elt elt' m x e f; exact (@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.
+ Lemma map_2 : forall (elt elt':Type)(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.
+ intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl.
+ apply map_2; auto.
  Qed. 
 
- Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+ Lemma mapi_1 : forall (elt elt':Type)(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)
+ Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed.
+ Lemma mapi_2 : forall (elt elt':Type)(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. 
+ intros elt elt' m x f; unfold In in *; do 2 rewrite In_alt; simpl; apply mapi_2; auto.
+ Qed.
 
- Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+ Lemma map2_1 : forall (elt elt' elt'':Type)(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.
+ do 2 rewrite In_alt; intros; simpl; apply 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')
+ Lemma map2_2 : forall (elt elt' elt'':Type)(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.
+ do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto.
  apply m.(is_bst).
  apply m'.(is_bst).
  Qed.
@@ -1891,158 +2000,185 @@ End IntMake.
 
 Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: 
     Sord with Module Data := D 
-            with Module MapS.E := X.
+         with Module MapS.E := X.
 
   Module Data := D.
-  Module MapS := IntMake(I)(X). 
-  Import MapS.
+  Module Import MapS := IntMake(I)(X). 
+  Module LO := FMapList.Make_ord(X)(D).
+  Module R := Raw.
+  Module P := Raw.Proofs.
+
+  Definition t := MapS.t D.t.
+
+  Definition cmp e e' := 
+   match D.compare e e' with EQ _ => true | _ => false end.
+
+  (** One step of comparison of elements *)
+
+  Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 :=
+   match e2 with
+    | R.End => Gt
+    | R.More x2 d2 r2 e2 =>
+       match X.compare x1 x2 with
+        | EQ _ => match D.compare d1 d2 with 
+                   | EQ _ => cont (R.cons r2 e2)
+                   | LT _ => Lt 
+                   | GT _ => Gt
+                  end
+        | LT _ => Lt
+        | GT _ => Gt
+       end
+   end.
 
-  Module MD := OrderedTypeFacts(D).
-  Import MD.
+  (** Comparison of left tree, middle element, then right tree *)
 
-  Module LO := FMapList.Make_ord(X)(D).
+  Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 :=
+   match s1 with
+    | R.Leaf => cont e2
+    | R.Node l1 x1 d1 r1 _ =>
+       compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2
+   end.
+
+  (** Initial continuation *)
+
+  Definition compare_end (e2:R.enumeration D.t) :=
+   match e2 with R.End => Eq | _ => Lt end.
+
+  (** The complete comparison *)
 
-  Definition t := MapS.t D.t. 
+  Definition compare_pure s1 s2 := 
+   compare_cont s1 compare_end (R.cons s2 (Raw.End _)).
 
-  Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end.	
+  (** Correctness of this comparison *)
 
-  Definition elements (m:t) := 
-    LO.MapS.Build_slist (Raw.elements_sort m.(is_bst)).
+  Definition Cmp c :=
+   match c with
+    | Eq => LO.eq_list
+    | Lt => LO.lt_list
+    | Gt => (fun l1 l2 => LO.lt_list l2 l1)
+   end.
+
+  Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, 
+   X.eq x1 x2 -> D.eq d1 d2 ->
+   Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2).
+  Proof.
+   destruct c; simpl; intros; P.MX.elim_comp; auto.
+  Qed.
+  Hint Resolve cons_Cmp.
+
+  Lemma compare_end_Cmp :
+   forall e2, Cmp (compare_end e2) nil (P.flatten_e e2).
+  Proof.
+   destruct e2; simpl; auto.
+  Qed.
+
+  Lemma compare_more_Cmp : forall x1 d1 cont x2 d2 r2 e2 l,
+    Cmp (cont (R.cons r2 e2)) l (R.elements r2 ++ P.flatten_e e2) ->
+     Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l)
+       (P.flatten_e (R.More x2 d2 r2 e2)).
+  Proof.
+   simpl; intros; destruct X.compare; simpl; 
+    try destruct D.compare; simpl; auto; P.MX.elim_comp; auto.
+  Qed.
+  
+  Lemma compare_cont_Cmp : forall s1 cont e2 l,
+   (forall e, Cmp (cont e) l (P.flatten_e e)) ->
+   Cmp (compare_cont s1 cont e2) (R.elements s1 ++ l) (P.flatten_e e2).
+  Proof.
+   induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; simpl; intros; auto.
+   rewrite <- P.elements_node; simpl.
+   apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2].
+   simpl; auto.
+   apply compare_more_Cmp.
+   rewrite <- P.cons_1; auto.
+  Qed.
+
+  Lemma compare_Cmp : forall s1 s2,
+   Cmp (compare_pure s1 s2) (R.elements s1) (R.elements s2).
+  Proof.
+   intros; unfold compare_pure.
+   rewrite (app_nil_end (R.elements s1)).
+   replace (R.elements s2) with (P.flatten_e (R.cons s2 (R.End _))) by
+    (rewrite P.cons_1; simpl; rewrite <- app_nil_end; auto).
+   auto using compare_cont_Cmp, compare_end_Cmp.
+  Qed.
 
-  Definition eq : t -> t -> Prop := 
-    fun m1 m2 => LO.eq (elements m1) (elements m2).
+  (** The dependent-style [compare] *)
 
-  Definition lt : t -> t -> Prop := 
-    fun m1 m2 => LO.lt (elements m1) (elements m2).
+  Definition eq (m1 m2 : t) := LO.eq_list (elements m1) (elements m2).
+  Definition lt (m1 m2 : t) := LO.lt_list (elements m1) (elements m2).
 
-  Lemma eq_1 : forall m m', Equal cmp m m' -> eq m m'.
+  Definition compare (s s':t) : Compare lt eq s s'.
+  Proof.
+   intros (s,b) (s',b').
+   generalize (compare_Cmp s s').
+   destruct compare_pure; intros; [apply EQ|apply LT|apply GT]; red; auto.
+  Defined.
+  
+  (* Proofs about [eq] and [lt] *)
+
+  Definition selements (m1 : t) := 
+   LO.MapS.Build_slist (P.elements_sort m1.(is_bst)).
+
+  Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2).
+  Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2).
+
+  Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2.
+  Proof.
+   unfold eq, seq, selements, elements, LO.eq; intuition.
+  Qed.
+
+  Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2.
+  Proof.
+   unfold lt, slt, selements, elements, LO.lt; intuition.
+  Qed.
+
+  Lemma eq_1 : forall (m m' : t), Equivb 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.
+  rewrite eq_seq; unfold seq.
+  rewrite Equivb_Equivb.
+  rewrite P.Equivb_elements.
+  auto using LO.eq_1.
   Qed.
 
-  Lemma eq_2 : forall m m', eq m m' -> Equal cmp m m'.
+  Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'.
   Proof.
   intros m m'.
-  unfold eq.
-  rewrite Equal_Equal.
-  rewrite Raw.Equal_elements.
+  rewrite eq_seq; unfold seq.
+  rewrite Equivb_Equivb.
+  rewrite P.Equivb_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.
+  intros; rewrite eq_seq; unfold seq; 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.
+  intros m1 m2; rewrite 2 eq_seq; unfold seq; 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.
+  intros m1 m2 M3; rewrite 3 eq_seq; unfold seq.
+   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.
+  intros m1 m2 m3; rewrite 3 lt_slt; unfold slt;  
+   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 Local 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.
+  intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; 
+   intros; apply LO.lt_not_eq; auto.
   Qed.
 
 End IntMake_ord.
@@ -2056,3 +2192,4 @@ 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
index 0105095a..b307efe3 100644
--- a/theories/FSets/FMapFacts.v
+++ b/theories/FSets/FMapFacts.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *)
+(* $Id: FMapFacts.v 10782 2008-04-12 16:08:04Z msozeau $ *)
 
 (** * Finite maps library *)
 
@@ -15,20 +15,24 @@
   different styles: equivalence and boolean equalities. 
 *)
 
-Require Import Bool.
-Require Import OrderedType.
+Require Import Bool DecidableType DecidableTypeEx 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] *)
+(** * Facts about weak maps *)
 
-Lemma MapsTo_fun : forall (elt:Set) m x (e e':elt), 
+Module WFacts (E:DecidableType)(Import M:WSfun E).
+
+Notation eq_dec := E.eq_dec.
+Definition eqb x y := if eq_dec x y then true else false.
+
+Lemma eq_bool_alt : forall b b', b=b' <-> (b=true <-> b'=true).
+Proof.
+ destruct b; destruct b'; intuition.
+Qed.
+
+Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), 
   MapsTo x e m -> MapsTo x e' m -> e=e'.
 Proof.
 intros.
@@ -36,19 +40,14 @@ generalize (find_1 H) (find_1 H0); clear H H0.
 intros; rewrite H in H0; injection H0; auto.
 Qed.
 
-(** * Specifications written using equivalences *)
+(** ** Specifications written using equivalences *)
 
 Section IffSpec. 
-Variable elt elt' elt'': Set.
+Variable elt elt' elt'': Type.
 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.
@@ -57,12 +56,34 @@ apply (MapsTo_1 H H0); auto.
 apply (MapsTo_1 (E.eq_sym H) H0); auto.
 Qed.
 
+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 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 In_dec : forall m x, { In x m } + { ~ In x m }.
+Proof.
+ intros.
+ generalize (mem_in_iff m x).
+ destruct (mem x m); [left|right]; intuition.
+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.
+Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None.
 Proof.
 intros.
 generalize (find_mapsto_iff m x); destruct (find x m).
@@ -74,17 +95,13 @@ 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.
+Lemma in_find_iff : forall m x, In x m <-> find x m <> None.
 Proof.
-intros; rewrite mem_in_iff; destruct (mem x m); intuition.
+intros; rewrite <- not_find_in_iff, mem_in_iff.
+destruct mem; intuition.
 Qed.
 
-Lemma equal_iff : forall m m' cmp, Equal cmp m m' <-> equal cmp m m' = true.
+Lemma equal_iff : forall m m' cmp, Equivb cmp m m' <-> equal cmp m m' = true.
 Proof. 
 split; [apply equal_1|apply equal_2].
 Qed.
@@ -114,9 +131,9 @@ intros.
 intuition.
 destruct (eq_dec x y); [left|right].
 split; auto.
-symmetry; apply (MapsTo_fun (e':=e) H); auto.
+symmetry; apply (MapsTo_fun (e':=e) H); auto with map.
 split; auto; apply add_3 with x e; auto.
-subst; auto.
+subst; auto with map.
 Qed.
 
 Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m.
@@ -204,33 +221,33 @@ split.
 case_eq (find x m); intros.
 exists e.
 split.
-apply (MapsTo_fun (m:=map f m) (x:=x)); auto.
-apply find_2; auto.
+apply (MapsTo_fun (m:=map f m) (x:=x)); auto with map.
+apply find_2; auto with map.
 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.
+subst b; auto with map.
 Qed.
 
 Lemma map_in_iff : forall m x (f : elt -> elt'), 
  In x (map f m) <-> In x m.
 Proof.
-split; intros; eauto.
+split; intros; eauto with map.
 destruct H as (a,H).
-exists (f a); auto.
+exists (f a); auto with map.
 Qed.
 
 Lemma mapi_in_iff : forall m x (f:key->elt->elt'),
  In x (mapi f m) <-> In x m.
 Proof.
-split; intros; eauto.
+split; intros; eauto with map.
 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] 
+(** 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'), 
@@ -240,9 +257,9 @@ 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.
+apply find_2; auto with map.
+exists y; repeat split; auto with map.
+apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto with map.
 assert (In x (mapi f m)) by (exists b; auto).
 destruct (mapi_2 H1) as (a,H2).
 rewrite (find_1 H2) in H0; discriminate.
@@ -287,11 +304,11 @@ Ltac map_iff :=
   rewrite map_mapsto_iff || rewrite map_in_iff ||
   rewrite mapi_in_iff)).
 
-(**  * Specifications written using boolean predicates *)
+(** ** 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. 
+Lemma mem_find_b : forall (elt:Type)(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.
@@ -303,7 +320,7 @@ destruct H0 as (e,H0).
 destruct (H e); intuition discriminate.
 Qed.
 
-Variable elt elt' elt'' : Set.
+Variable elt elt' elt'' : Type.
 Implicit Types m : t elt.
 Implicit Types x y z : key.
 Implicit Types e : elt.
@@ -345,24 +362,24 @@ Qed.
 Lemma add_eq_o : forall m x y e, 
  E.eq x y -> find y (add x e m) = Some e.
 Proof.
-auto.
+auto with map.
 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.
+case_eq (find y m); intros; auto with map.
+case_eq (find y (add x e m)); intros; auto with map.
 rewrite <- H0; symmetry.
-apply find_1; apply add_3 with x e; auto.
+apply find_1; apply add_3 with x e; auto with map.
 Qed.
-Hint Resolve add_neq_o.
+Hint Resolve add_neq_o : map.
 
 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.
+intros; destruct (eq_dec x y); auto with map.
 Qed.
 
 Lemma add_eq_b : forall m x y e, 
@@ -394,23 +411,23 @@ destruct (find y (remove x m)); auto.
 destruct 2.
 exists e; rewrite H0; auto.
 Qed.
-Hint Resolve remove_eq_o.
+Hint Resolve remove_eq_o : map.
 
 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.
+case_eq (find y m); intros; auto with map.
+case_eq (find y (remove x m)); intros; auto with map.
 rewrite <- H0; symmetry.
-apply find_1; apply remove_3 with x; auto.
+apply find_1; apply remove_3 with x; auto with map.
 Qed.
-Hint Resolve remove_neq_o.
+Hint Resolve remove_neq_o : map.
 
 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.
+intros; destruct (eq_dec x y); auto with map.
 Qed.
 
 Lemma remove_eq_b : forall m x y, 
@@ -432,7 +449,7 @@ 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 := 
+Definition option_map (A B:Type)(f:A->B)(o:option A) : option B := 
  match o with 
   | Some a => Some (f a)
   | None => None
@@ -494,15 +511,15 @@ Proof.
 intros.
 case_eq (find x m); intros.
 rewrite <- H0.
-apply map2_1; auto.
-left; exists e; auto.
+apply map2_1; auto with map.
+left; exists e; auto with map.
 case_eq (find x m'); intros.
 rewrite <- H0; rewrite <- H1.
 apply map2_1; auto.
-right; exists e; auto.
+right; exists e; auto with map.
 rewrite H.
-case_eq (find x (map2 f m m')); intros; auto.
-assert (In x (map2 f m m')) by (exists e; auto).
+case_eq (find x (map2 f m m')); intros; auto with map.
+assert (In x (map2 f m m')) by (exists e; auto with map).
 destruct (map2_2 H3) as [(e0,H4)|(e0,H4)].
 rewrite (find_1 H4) in H0; discriminate.
 rewrite (find_1 H4) in H1; discriminate.
@@ -514,21 +531,18 @@ 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).
+assert (H0:=elements_3w 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)); 
+fold (eqb x).
+destruct (find x m); destruct (findA (eqb x) (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).
+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)
@@ -554,4 +568,1026 @@ Qed.
 
 End BoolSpec.
 
+Section Equalities. 
+
+Variable elt:Type.
+
+(** * Relations between [Equal], [Equiv] and [Equivb]. *)
+
+(** First, [Equal] is [Equiv] with Leibniz on elements. *)
+
+Lemma Equal_Equiv : forall (m m' : t elt), 
+  Equal m m' <-> Equiv (@Logic.eq elt) m m'.
+Proof.
+ unfold Equal, Equiv; split; intros.
+ split; intros.
+ rewrite in_find_iff, in_find_iff, H; intuition.
+ rewrite find_mapsto_iff in H0,H1; congruence.
+ destruct H.
+ specialize (H y).
+ specialize (H0 y).
+ do 2 rewrite in_find_iff in H.
+ generalize (find_mapsto_iff m y)(find_mapsto_iff m' y).
+ do 2 destruct find; auto; intros.
+ f_equal; apply H0; [rewrite H1|rewrite H2]; auto.
+ destruct H as [H _]; now elim H.
+ destruct H as [_ H]; now elim H.
+Qed.
+
+(** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp]
+    are related. *)
+
+Section Cmp.
+Variable eq_elt : elt->elt->Prop.
+Variable cmp : elt->elt->bool.
+
+Definition compat_cmp := 
+ forall e e', cmp e e' = true <-> eq_elt e e'.
+
+Lemma Equiv_Equivb : compat_cmp ->
+ forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'.
+Proof.
+ unfold Equivb, Equiv, Cmp; intuition.
+ red in H; rewrite H; eauto.
+ red in H; rewrite <-H; eauto.
+Qed.
+End Cmp.
+
+(** Composition of the two last results: relation between [Equal]
+    and [Equivb]. *)
+
+Lemma Equal_Equivb : forall cmp, 
+ (forall e e', cmp e e' = true <-> e = e') -> 
+ forall (m m':t elt), Equal m m' <-> Equivb cmp m m'.
+Proof.
+ intros; rewrite Equal_Equiv.
+ apply Equiv_Equivb; auto.
+Qed.
+
+Lemma Equal_Equivb_eqdec : 
+ forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }),
+ let cmp := fun e e' => if eq_elt_dec e e' then true else false in 
+ forall (m m':t elt), Equal m m' <-> Equivb cmp m m'.
+Proof.
+intros; apply Equal_Equivb.
+unfold cmp; clear cmp; intros.
+destruct eq_elt_dec; now intuition.
+Qed.
+
+End Equalities.
+
+(** * [Equal] is a setoid equality. *)
+
+Lemma Equal_refl : forall (elt:Type)(m : t elt), Equal m m.
+Proof. red; reflexivity. Qed.
+
+Lemma Equal_sym : forall (elt:Type)(m m' : t elt), 
+ Equal m m' -> Equal m' m.
+Proof. unfold Equal; auto. Qed.
+
+Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), 
+ Equal m m' -> Equal m' m'' -> Equal m m''.
+Proof. unfold Equal; congruence. Qed.
+
+Definition Equal_ST : forall elt:Type, Setoid_Theory (t elt) (@Equal _).
+Proof. 
+constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans].
+Qed.
+
+Add Relation key E.eq 
+ reflexivity proved by E.eq_refl 
+ symmetry proved by E.eq_sym
+ transitivity proved by E.eq_trans 
+ as KeySetoid.
+
+Implicit Arguments Equal [[elt]].
+
+Add Parametric Relation (elt : Type) : (t elt) Equal  
+ reflexivity proved by (@Equal_refl elt)
+ symmetry proved by (@Equal_sym elt)
+ transitivity proved by (@Equal_trans elt)
+ as EqualSetoid.
+
+Add Parametric Morphism elt : (@In elt) with signature E.eq ==> Equal ==> iff as In_m.
+Proof.
+unfold Equal; intros k k' Hk m m' Hm.
+rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition.
+Qed.
+
+Add Parametric Morphism elt : (@MapsTo elt)
+ with signature E.eq ==> @Logic.eq _ ==> Equal ==> iff as MapsTo_m.
+Proof.
+unfold Equal; intros k k' Hk e m m' Hm.
+rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; 
+ intuition.
+Qed.
+
+Add Parametric Morphism elt : (@Empty elt) with signature Equal ==> iff as Empty_m.
+Proof.
+unfold Empty; intros m m' Hm; intuition.
+rewrite <-Hm in H0; eauto.
+rewrite Hm in H0; eauto.
+Qed.
+
+Add Parametric Morphism elt : (@is_empty elt) with signature Equal ==> @Logic.eq _ as is_empty_m.
+Proof.
+intros m m' Hm.
+rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition.
+Qed.
+
+Add Parametric Morphism elt : (@mem elt) with signature E.eq ==> Equal ==> @Logic.eq _ as mem_m.
+Proof.
+intros k k' Hk m m' Hm.
+rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition.
+Qed.
+
+Add Parametric Morphism elt : (@find elt) with signature E.eq ==> Equal ==> @Logic.eq _ as find_m.
+Proof.
+intros k k' Hk m m' Hm.
+generalize (find_mapsto_iff m k)(find_mapsto_iff m' k')
+ (not_find_in_iff m k)(not_find_in_iff m' k'); 
+do 2 destruct find; auto; intros.
+rewrite <- H, Hk, Hm, H0; auto.
+rewrite <- H1, Hk, Hm, H2; auto.
+symmetry; rewrite <- H2, <-Hk, <-Hm, H1; auto.
+Qed.
+
+Add Parametric Morphism elt : (@add elt) with signature 
+ E.eq ==> @Logic.eq _ ==> Equal ==> Equal as add_m.
+Proof.
+intros k k' Hk e m m' Hm y.
+rewrite add_o, add_o; do 2 destruct eq_dec; auto.
+elim n; rewrite <-Hk; auto.
+elim n; rewrite Hk; auto.
+Qed.
+
+Add Parametric Morphism elt : (@remove elt) with signature
+ E.eq ==> Equal ==> Equal as remove_m.
+Proof.
+intros k k' Hk m m' Hm y.
+rewrite remove_o, remove_o; do 2 destruct eq_dec; auto.
+elim n; rewrite <-Hk; auto.
+elim n; rewrite Hk; auto.
+Qed.
+
+Add Parametric Morphism elt elt' : (@map elt elt') with signature @Logic.eq _ ==> Equal ==> Equal as map_m.
+Proof.
+intros f m m' Hm y.
+rewrite map_o, map_o, Hm; auto.
+Qed.
+
+(* Later: Add Morphism cardinal *)
+
+(* old name: *)
+Notation not_find_mapsto_iff := not_find_in_iff.
+
+End WFacts.
+
+(** * Same facts for full maps *)
+
+Module Facts (M:S). 
+ Module D := OT_as_DT M.E.
+ Include WFacts D M.
 End Facts.
+
+(** * Additional Properties for weak maps 
+ 
+    Results about [fold], [elements], induction principles...
+*)
+
+Module WProperties (E:DecidableType)(M:WSfun E).
+ Module Import F:=WFacts E M. 
+ Import M.
+
+ Section Elt. 
+  Variable elt:Type.
+
+  Definition Add x (e:elt) m m' := forall y, find y m' = find y (add x e m).
+
+  Notation eqke := (@eq_key_elt elt).
+  Notation eqk := (@eq_key elt).
+
+  Lemma elements_Empty : forall m:t elt, Empty m <-> elements m = nil.
+  Proof.
+  intros.
+  unfold Empty.
+  split; intros.
+  assert (forall a, ~ List.In a (elements m)).
+   red; intros.
+   apply (H (fst a) (snd a)).
+   rewrite elements_mapsto_iff.
+   rewrite InA_alt; exists a; auto.
+   split; auto; split; auto.
+  destruct (elements m); auto.
+  elim (H0 p); simpl; auto.
+  red; intros.
+  rewrite elements_mapsto_iff in H0.
+  rewrite InA_alt in H0; destruct H0.
+  rewrite H in H0; destruct H0 as (_,H0); inversion H0.
+  Qed.
+
+  Lemma elements_empty : elements (@empty elt) = nil.
+  Proof.
+  rewrite <-elements_Empty; apply empty_1.
+  Qed.
+
+  Lemma fold_Empty : forall m (A:Type)(f:key->elt->A->A)(i:A),
+   Empty m -> fold f m i = i.
+  Proof.
+  intros.
+  rewrite fold_1.
+  rewrite elements_Empty in H; rewrite H; simpl; auto.
+  Qed.
+
+  Lemma NoDupA_eqk_eqke : forall l, NoDupA eqk l -> NoDupA eqke l.
+  Proof.
+  induction 1; auto.
+  constructor; auto.
+  contradict H.
+  destruct x as (x,y).
+  rewrite InA_alt in *; destruct H as ((a,b),((H1,H2),H3)); simpl in *.
+  exists (a,b); auto.
+  Qed.
+
+  Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA)
+   (f:key->elt->A->A)(i:A), 
+   compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> 
+   transpose eqA (fun y => f (fst y) (snd y)) -> 
+   Equal m1 m2 -> 
+   eqA (fold f m1 i) (fold f m2 i).
+  Proof.
+  assert (eqke_refl : forall p, eqke p p).
+   red; auto.
+  assert (eqke_sym : forall p p', eqke p p' -> eqke p' p).
+   intros (x1,x2) (y1,y2); unfold eq_key_elt; simpl; intuition.
+  assert (eqke_trans : forall p p' p'', eqke p p' -> eqke p' p'' -> eqke p p'').
+   intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl.
+   intuition; eauto; congruence.
+  intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right.
+  apply fold_right_equivlistA with (eqA:=eqke) (eqB:=eqA); auto.
+  apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w.
+  apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w.
+  red; intros.
+  do 2 rewrite InA_rev.
+  destruct x; do 2 rewrite <- elements_mapsto_iff.
+  do 2 rewrite find_mapsto_iff.
+  rewrite H1; split; auto.
+  Qed.
+
+  Lemma fold_Add : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA)
+   (f:key->elt->A->A)(i:A), 
+   compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> 
+   transpose eqA (fun y =>f (fst y) (snd y)) -> 
+   ~In x m1 -> Add x e m1 m2 -> 
+   eqA (fold f m2 i) (f x e (fold f m1 i)).
+  Proof.
+  assert (eqke_refl : forall p, eqke p p).
+   red; auto.
+  assert (eqke_sym : forall p p', eqke p p' -> eqke p' p).
+   intros (x1,x2) (y1,y2); unfold eq_key_elt; simpl; intuition.
+  assert (eqke_trans : forall p p' p'', eqke p p' -> eqke p' p'' -> eqke p p'').
+   intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl.
+   intuition; eauto; congruence.
+  intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right.
+  set (f':=fun y x0 => f (fst y) (snd y) x0) in *.
+  change (f x e (fold_right f' i (rev (elements m1))))
+   with (f' (x,e) (fold_right f' i (rev (elements m1)))).
+  apply fold_right_add with (eqA:=eqke)(eqB:=eqA); auto.
+  apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w.
+  apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w.
+  rewrite InA_rev.
+  contradict H1.
+  exists e.
+  rewrite elements_mapsto_iff; auto.
+  intros a.
+  rewrite InA_cons; do 2 rewrite InA_rev; 
+  destruct a as (a,b); do 2 rewrite <- elements_mapsto_iff.
+  do 2 rewrite find_mapsto_iff; unfold eq_key_elt; simpl.
+  rewrite H2.
+  rewrite add_o.
+  destruct (eq_dec x a); intuition.
+  inversion H3; auto.
+  f_equal; auto.
+  elim H1.
+  exists b; apply MapsTo_1 with a; auto with map.
+  elim n; auto.
+  Qed.
+
+  Lemma cardinal_fold : forall m : t elt, 
+   cardinal m = fold (fun _ _ => S) m 0.
+  Proof.
+  intros; rewrite cardinal_1, fold_1.
+  symmetry; apply fold_left_length; auto.
+  Qed.
+
+  Lemma cardinal_Empty : forall m : t elt, 
+   Empty m <-> cardinal m = 0.
+  Proof.
+  intros.
+  rewrite cardinal_1, elements_Empty.
+  destruct (elements m); intuition; discriminate.
+  Qed.
+ 
+  Lemma Equal_cardinal : forall m m' : t elt, 
+    Equal m m' -> cardinal m = cardinal m'.
+  Proof.
+  intros; do 2 rewrite cardinal_fold.
+  apply fold_Equal with (eqA:=@eq _); auto.
+  constructor; auto; congruence.
+  red; auto.
+  red; auto.
+  Qed.
+
+  Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0.
+  Proof.
+  intros; rewrite <- cardinal_Empty; auto.
+  Qed.
+
+  Lemma cardinal_2 :
+    forall m m' x e, ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m).
+  Proof.
+  intros; do 2 rewrite cardinal_fold.
+  change S with ((fun _ _ => S) x e).
+  apply fold_Add; auto.
+  constructor; intros; auto; congruence.
+  red; simpl; auto.
+  red; simpl; auto.
+  Qed.
+
+  Lemma cardinal_inv_1 : forall m : t elt, 
+   cardinal m = 0 -> Empty m.
+  Proof.
+  intros; rewrite cardinal_Empty; auto. 
+  Qed.
+  Hint Resolve cardinal_inv_1 : map.
+
+  Lemma cardinal_inv_2 :
+   forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }.
+  Proof. 
+  intros; rewrite M.cardinal_1 in *.
+  generalize (elements_mapsto_iff m).
+  destruct (elements m); try discriminate. 
+  exists p; auto.
+  rewrite H0; destruct p; simpl; auto.
+  constructor; red; auto.
+  Qed.
+
+  Lemma cardinal_inv_2b :
+   forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }.
+  Proof.
+  intros.
+  generalize (@cardinal_inv_2 m); destruct cardinal.
+  elim H;auto.
+  eauto.
+  Qed.
+
+  Lemma map_induction :
+   forall P : t elt -> Type,
+   (forall m, Empty m -> P m) ->
+   (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') ->
+   forall m, P m.
+  Proof.
+  intros; remember (cardinal m) as n; revert m Heqn; induction n; intros.
+  apply X; apply cardinal_inv_1; auto.
+
+  destruct (cardinal_inv_2 (sym_eq Heqn)) as ((x,e),H0); simpl in *.
+  assert (Add x e (remove x m) m).
+   red; intros.
+   rewrite add_o; rewrite remove_o; destruct (eq_dec x y); eauto with map.
+  apply X0 with (remove x m) x e; auto with map.
+  apply IHn; auto with map.
+  assert (S n = S (cardinal (remove x m))).
+   rewrite Heqn; eapply cardinal_2; eauto with map.
+  inversion H1; auto with map.
+  Qed.
+
+  (** * Let's emulate some functions not present in the interface *)
+
+  Definition filter (f : key -> elt -> bool)(m : t elt) := 
+   fold (fun k e m => if f k e then add k e m else m) m (empty _).
+
+  Definition for_all (f : key -> elt -> bool)(m : t elt) := 
+   fold (fun k e b => if f k e then b else false) m true.
+
+  Definition exists_ (f : key -> elt -> bool)(m : t elt) := 
+   fold (fun k e b => if f k e then true else b) m false.
+
+  Definition partition (f : key -> elt -> bool)(m : t elt) := 
+   (filter f m, filter (fun k e => negb (f k e))).
+
+  Section Specs.
+  Variable f : key -> elt -> bool.
+  Hypothesis Hf : forall e, compat_bool E.eq (fun k => f k e).
+
+  Lemma filter_iff : forall m k e, 
+   MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true.
+  Proof.
+  unfold filter; intros.
+  rewrite fold_1.
+  rewrite <- fold_left_rev_right.
+  rewrite (elements_mapsto_iff m).
+  rewrite <- (InA_rev eqke (k,e) (elements m)).
+  assert (NoDupA eqk (rev (elements m))).
+   apply NoDupA_rev; auto; try apply elements_3w; auto.
+   intros (k1,e1); compute; auto.
+   intros (k1,e1)(k2,e2); compute; auto.
+   intros (k1,e1)(k2,e2)(k3,e3); compute; eauto.
+  induction (rev (elements m)); simpl; auto.
+  
+  rewrite empty_mapsto_iff.
+  intuition.
+  inversion H1.
+
+  destruct a as (k',e'); simpl.
+  inversion_clear H.
+  case_eq (f k' e'); intros; simpl;
+   try rewrite add_mapsto_iff; rewrite IHl; clear IHl; intuition.
+  constructor; red; auto.
+  rewrite (Hf e' H2),H4 in H; auto.
+  inversion_clear H3.
+  compute in H2; destruct H2; auto.
+  destruct (E.eq_dec k' k); auto.
+  elim H0.
+  rewrite InA_alt in *; destruct H2 as (w,Hw); exists w; intuition.
+  red in H2; red; simpl in *; intuition.
+  rewrite e0; auto.
+  inversion_clear H3; auto.
+  compute in H2; destruct H2.
+  rewrite (Hf e H2),H3,H in H4; discriminate.
+  Qed.
+  
+  Lemma for_all_iff : forall m,
+   for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true).
+  Proof.
+  cut (forall m : t elt,
+       for_all f m = true <->
+       (forall k e, InA eqke (k,e) (rev (elements m)) -> f k e = true)).
+  intros; rewrite H; split; intros.
+  apply H0; rewrite InA_rev, <- elements_mapsto_iff; auto.
+  apply H0; rewrite InA_rev, <- elements_mapsto_iff in H1; auto.
+
+  unfold for_all; intros.
+  rewrite fold_1.
+  rewrite <- fold_left_rev_right.
+  assert (NoDupA eqk (rev (elements m))).
+   apply NoDupA_rev; auto; try apply elements_3w; auto.
+   intros (k1,e1); compute; auto.
+   intros (k1,e1)(k2,e2); compute; auto.
+   intros (k1,e1)(k2,e2)(k3,e3); compute; eauto.
+  induction (rev (elements m)); simpl; auto.
+  
+  intuition.
+  inversion H1.
+
+  destruct a as (k,e); simpl.
+  inversion_clear H.
+  case_eq (f k e); intros; simpl;
+   try rewrite IHl; clear IHl; intuition.
+  inversion_clear H3; auto.
+  compute in H4; destruct H4.
+  rewrite (Hf e0 H3), H4; auto.
+  rewrite <-H, <-(H2 k e); auto.
+  constructor; red; auto.
+  Qed.
+  
+  Lemma exists_iff : forall m,
+   exists_ f m = true <-> 
+   (exists p, MapsTo (fst p) (snd p) m /\ f (fst p) (snd p) = true).
+  Proof.
+  cut (forall m : t elt,
+       exists_ f m = true <->
+       (exists p, InA eqke p (rev (elements m)) 
+         /\ f (fst p) (snd p) = true)).
+  intros; rewrite H; split; intros.
+  destruct H0 as ((k,e),Hke); exists (k,e).
+  rewrite InA_rev, <-elements_mapsto_iff in Hke; auto.
+  destruct H0 as ((k,e),Hke); exists (k,e).
+  rewrite InA_rev, <-elements_mapsto_iff; auto.
+  unfold exists_; intros.
+  rewrite fold_1.
+  rewrite <- fold_left_rev_right.
+  assert (NoDupA eqk (rev (elements m))).
+   apply NoDupA_rev; auto; try apply elements_3w; auto.
+   intros (k1,e1); compute; auto.
+   intros (k1,e1)(k2,e2); compute; auto.
+   intros (k1,e1)(k2,e2)(k3,e3); compute; eauto.
+  induction (rev (elements m)); simpl; auto.
+  
+  intuition; try discriminate.
+  destruct H0 as ((k,e),(Hke,_)); inversion Hke.
+
+  destruct a as (k,e); simpl.
+  inversion_clear H.
+  case_eq (f k e); intros; simpl;
+   try rewrite IHl; clear IHl; intuition.
+  exists (k,e); simpl; split; auto.
+  constructor; red; auto.
+  destruct H2 as ((k',e'),(Hke',Hf')); exists (k',e'); simpl; auto.
+  destruct H2 as ((k',e'),(Hke',Hf')); simpl in *.
+  inversion_clear Hke'.
+  compute in H2; destruct H2.
+  rewrite (Hf e' H2), H3,H in Hf'; discriminate.
+  exists (k',e'); auto.
+  Qed.
+  End Specs.
+
+  (** specialized versions analyzing only keys (resp. elements) *)
+
+  Definition filter_dom (f : key -> bool) := filter (fun k _ => f k).
+  Definition filter_range (f : elt -> bool) := filter (fun _ => f).
+  Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k).
+  Definition for_all_range (f : elt -> bool) := for_all (fun _ => f).
+  Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k).
+  Definition exists_range (f : elt -> bool) := exists_ (fun _ => f).
+  Definition partition_dom (f : key -> bool) := partition (fun k _ => f k).
+  Definition partition_range (f : elt -> bool) := partition (fun _ => f).
+
+ End Elt.
+
+ Add Parametric Morphism elt : (@cardinal elt) with signature Equal ==> @Logic.eq _ as cardinal_m.
+ Proof. intros; apply Equal_cardinal; auto. Qed.
+
+End WProperties.
+
+(** * Same Properties for full maps *)
+
+Module Properties (M:S). 
+ Module D := OT_as_DT M.E.
+ Include WProperties D M.
+End Properties.
+
+(** * Properties specific to maps with ordered keys *)
+
+Module OrdProperties (M:S).
+ Module Import ME := OrderedTypeFacts M.E.
+ Module Import O:=KeyOrderedType M.E.
+ Module Import P:=Properties M.
+ Import F.
+ Import M.
+
+ Section Elt. 
+  Variable elt:Type.
+
+  Notation eqke := (@eqke elt).
+  Notation eqk := (@eqk elt).
+  Notation ltk := (@ltk elt).
+  Notation cardinal := (@cardinal elt).
+  Notation Equal := (@Equal elt).
+  Notation Add := (@Add elt).
+
+  Definition Above x (m:t elt) := forall y, In y m -> E.lt y x.
+  Definition Below x (m:t elt) := forall y, In y m -> E.lt x y.
+
+  Section Elements.
+
+  Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt),
+   sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'.
+  Proof.
+  apply SortA_equivlistA_eqlistA; eauto; 
+  unfold O.eqke, O.ltk; simpl; intuition; eauto.
+  Qed.
+
+  Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto.
+
+  Definition gtb (p p':key*elt) := match E.compare (fst p) (fst p') with GT _ => true | _ => false end.
+  Definition leb p := fun p' => negb (gtb p p'). 
+
+  Definition elements_lt p m := List.filter (gtb p) (elements m).
+  Definition elements_ge p m := List.filter (leb p) (elements m).
+
+  Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p.
+  Proof.
+   intros (x,e) (y,e'); unfold gtb, O.ltk; simpl.
+   destruct (E.compare x y); intuition; try discriminate; ME.order.
+  Qed.
+
+  Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p.
+  Proof.
+   intros (x,e) (y,e'); unfold leb, gtb, O.ltk; simpl.
+   destruct (E.compare x y); intuition; try discriminate; ME.order.
+  Qed.
+
+  Lemma gtb_compat : forall p, compat_bool eqke (gtb p).
+  Proof.
+   red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H.
+   generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); 
+    destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto.
+   unfold O.ltk in *; simpl in *; intros.
+   symmetry; rewrite H2.
+   apply ME.eq_lt with a; auto.
+   rewrite <- H1; auto.
+   unfold O.ltk in *; simpl in *; intros.
+   rewrite H1.
+   apply ME.eq_lt with b; auto.
+   rewrite <- H2; auto.
+  Qed.
+
+  Lemma leb_compat : forall p, compat_bool eqke (leb p).
+  Proof.
+   red; intros x a b H.
+   unfold leb; f_equal; apply gtb_compat; auto.
+  Qed.
+
+  Hint Resolve gtb_compat leb_compat elements_3 : map.
+
+  Lemma elements_split : forall p m, 
+    elements m = elements_lt p m ++ elements_ge p m.
+  Proof.
+  unfold elements_lt, elements_ge, leb; intros.
+  apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with map.
+  intros; destruct x; destruct y; destruct p.
+  rewrite gtb_1 in H; unfold O.ltk in H; simpl in *.
+  assert (~ltk (t1,e0) (k,e1)).
+   unfold gtb, O.ltk in *; simpl in *.
+   destruct (E.compare k t1); intuition; try discriminate; ME.order.
+  unfold O.ltk in *; simpl in *; ME.order.
+  Qed.
+
+  Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> 
+    eqlistA eqke (elements m') 
+                 (elements_lt (x,e) m ++ (x,e):: elements_ge (x,e) m).
+  Proof.
+  intros; unfold elements_lt, elements_ge.
+  apply sort_equivlistA_eqlistA; auto with map.
+  apply (@SortA_app _ eqke); auto with map.
+  apply (@filter_sort _ eqke); auto with map; clean_eauto.
+  constructor; auto with map.
+  apply (@filter_sort _ eqke); auto with map; clean_eauto.
+  rewrite (@InfA_alt _ eqke); auto with map; try (clean_eauto; fail).
+  intros.
+  rewrite filter_InA in H1; auto with map; destruct H1.
+  rewrite leb_1 in H2.
+  destruct y; unfold O.ltk in *; simpl in *.
+  rewrite <- elements_mapsto_iff in H1.
+  assert (~E.eq x t0).
+   contradict H.
+   exists e0; apply MapsTo_1 with t0; auto.
+  ME.order.
+  apply (@filter_sort _ eqke); auto with map; clean_eauto.
+  intros.
+  rewrite filter_InA in H1; auto with map; destruct H1.
+  rewrite gtb_1 in H3.
+  destruct y; destruct x0; unfold O.ltk in *; simpl in *.
+  inversion_clear H2.
+  red in H4; simpl in *; destruct H4.
+  ME.order.
+  rewrite filter_InA in H4; auto with map; destruct H4.
+  rewrite leb_1 in H4.
+  unfold O.ltk in *; simpl in *; ME.order.
+  red; intros a; destruct a.
+  rewrite InA_app_iff; rewrite InA_cons.
+  do 2 (rewrite filter_InA; auto with map).
+  do 2 rewrite <- elements_mapsto_iff.
+  rewrite leb_1; rewrite gtb_1.
+  rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff.
+  rewrite add_mapsto_iff.
+  unfold O.eqke, O.ltk; simpl.
+  destruct (E.compare t0 x); intuition.
+  right; split; auto; ME.order.
+  ME.order.
+  elim H.
+  exists e0; apply MapsTo_1 with t0; auto.
+  right; right; split; auto; ME.order.
+  ME.order.
+  right; split; auto; ME.order.
+  Qed.
+
+  Lemma elements_Add_Above : forall m m' x e, 
+   Above x m -> Add x e m m' -> 
+     eqlistA eqke (elements m') (elements m ++ (x,e)::nil).
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with map.
+  apply (@SortA_app _ eqke); auto with map.
+  intros.
+  inversion_clear H2.
+  destruct x0; destruct y.
+  rewrite <- elements_mapsto_iff in H1.
+  unfold O.eqke, O.ltk in *; simpl in *; destruct H3.
+  apply ME.lt_eq with x; auto.
+  apply H; firstorder.
+  inversion H3.
+  red; intros a; destruct a.
+  rewrite InA_app_iff; rewrite InA_cons; rewrite InA_nil.
+  do 2 rewrite <- elements_mapsto_iff.
+  rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff.
+  rewrite add_mapsto_iff; unfold O.eqke; simpl.
+  intuition.
+  destruct (ME.eq_dec x t0); auto.
+  elimtype False.
+  assert (In t0 m).
+   exists e0; auto.
+  generalize (H t0 H1).
+  ME.order.
+  Qed.
+
+  Lemma elements_Add_Below : forall m m' x e, 
+   Below x m -> Add x e m m' -> 
+     eqlistA eqke (elements m') ((x,e)::elements m).
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with map.
+  change (sort ltk (((x,e)::nil) ++ elements m)).
+  apply (@SortA_app _ eqke); auto with map.
+  intros.
+  inversion_clear H1.
+  destruct y; destruct x0.
+  rewrite <- elements_mapsto_iff in H2.
+  unfold O.eqke, O.ltk in *; simpl in *; destruct H3.
+  apply ME.eq_lt with x; auto.
+  apply H; firstorder.
+  inversion H3.
+  red; intros a; destruct a.
+  rewrite InA_cons.
+  do 2 rewrite <- elements_mapsto_iff.
+  rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff.
+  rewrite add_mapsto_iff; unfold O.eqke; simpl.
+  intuition.
+  destruct (ME.eq_dec x t0); auto.
+  elimtype False.
+  assert (In t0 m).
+   exists e0; auto.
+  generalize (H t0 H1).
+  ME.order.
+  Qed.
+
+  Lemma elements_Equal_eqlistA : forall (m m': t elt), 
+   Equal m m' -> eqlistA eqke (elements m) (elements m').
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with map.
+  red; intros.
+  destruct x; do 2 rewrite <- elements_mapsto_iff.
+  do 2 rewrite find_mapsto_iff; rewrite H; split; auto.
+  Qed.
+
+  End Elements.
+
+  Section Min_Max_Elt.
+
+  (** We emulate two [max_elt] and [min_elt] functions. *)
+  
+  Fixpoint max_elt_aux (l:list (key*elt)) := match l with 
+    | nil => None 
+    | (x,e)::nil => Some (x,e)
+    | (x,e)::l => max_elt_aux l
+    end.
+  Definition max_elt m := max_elt_aux (elements m).
+
+  Lemma max_elt_Above : 
+   forall m x e, max_elt m = Some (x,e) -> Above x (remove x m).
+  Proof.
+  red; intros.
+  rewrite remove_in_iff in H0.
+  destruct H0.
+  rewrite elements_in_iff in H1.
+  destruct H1.
+  unfold max_elt in *.
+  generalize (elements_3 m).
+  revert x e H y x0 H0 H1.
+  induction (elements m).
+  simpl; intros; try discriminate.
+  intros.
+  destruct a; destruct l; simpl in *.
+  injection H; clear H; intros; subst.
+  inversion_clear H1.
+  red in H; simpl in *; intuition.
+  elim H0; eauto.
+  inversion H.
+  change (max_elt_aux (p::l) = Some (x,e)) in H.
+  generalize (IHl x e H); clear IHl; intros IHl.
+  inversion_clear H1; [ | inversion_clear H2; eauto ].
+  red in H3; simpl in H3; destruct H3.
+  destruct p as (p1,p2).
+  destruct (ME.eq_dec p1 x).
+  apply ME.lt_eq with p1; auto.
+   inversion_clear H2.
+   inversion_clear H5.
+   red in H2; simpl in H2; ME.order.
+  apply E.lt_trans with p1; auto.
+   inversion_clear H2.
+   inversion_clear H5.
+   red in H2; simpl in H2; ME.order.
+  eapply IHl; eauto.
+  econstructor; eauto.
+  red; eauto.
+  inversion H2; auto.
+  Qed.
+  
+  Lemma max_elt_MapsTo : 
+   forall m x e, max_elt m = Some (x,e) -> MapsTo x e m.
+  Proof.
+  intros.
+  unfold max_elt in *.
+  rewrite elements_mapsto_iff.
+  induction (elements m).
+  simpl; try discriminate.
+  destruct a; destruct l; simpl in *.
+  injection H; intros; subst; constructor; red; auto.
+  constructor 2; auto.
+  Qed.
+
+  Lemma max_elt_Empty : 
+   forall m, max_elt m = None -> Empty m.
+  Proof.
+  intros.
+  unfold max_elt in *.
+  rewrite elements_Empty.
+  induction (elements m); auto.
+  destruct a; destruct l; simpl in *; try discriminate.
+  assert (H':=IHl H); discriminate.
+  Qed.
+
+  Definition min_elt m : option (key*elt) := match elements m with 
+   | nil => None
+   | (x,e)::_ => Some (x,e)
+  end.
+
+  Lemma min_elt_Below : 
+   forall m x e, min_elt m = Some (x,e) -> Below x (remove x m).
+  Proof.
+  unfold min_elt, Below; intros.
+  rewrite remove_in_iff in H0; destruct H0.
+  rewrite elements_in_iff in H1.
+  destruct H1.
+  generalize (elements_3 m).
+  destruct (elements m).
+  try discriminate.
+  destruct p; injection H; intros; subst.
+  inversion_clear H1.
+  red in H2; destruct H2; simpl in *; ME.order.
+  inversion_clear H4.
+  rewrite (@InfA_alt _ eqke) in H3; eauto.
+  apply (H3 (y,x0)); auto.
+  unfold lt_key; simpl; intuition; eauto.
+  intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto.
+  intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto.
+  Qed.
+  
+  Lemma min_elt_MapsTo : 
+   forall m x e, min_elt m = Some (x,e) -> MapsTo x e m.
+  Proof.
+  intros.
+  unfold min_elt in *.
+  rewrite elements_mapsto_iff.
+  destruct (elements m).
+  simpl; try discriminate.
+  destruct p; simpl in *.
+  injection H; intros; subst; constructor; red; auto.
+  Qed.
+
+  Lemma min_elt_Empty : 
+   forall m, min_elt m = None -> Empty m.
+  Proof.
+  intros.
+  unfold min_elt in *.
+  rewrite elements_Empty.
+  destruct (elements m); auto.
+  destruct p; simpl in *; discriminate.
+  Qed.
+
+  End Min_Max_Elt.
+
+  Section Induction_Principles.
+
+  Lemma map_induction_max :
+   forall P : t elt -> Type,
+   (forall m, Empty m -> P m) ->
+   (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') ->
+   forall m, P m.
+  Proof.
+  intros; remember (cardinal m) as n; revert m Heqn; induction n; intros.
+  apply X; apply cardinal_inv_1; auto.
+
+  case_eq (max_elt m); intros.
+  destruct p.
+  assert (Add k e (remove k m) m).
+   red; intros.
+   rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto.
+   apply find_1; apply MapsTo_1 with k; auto.
+   apply max_elt_MapsTo; auto.
+  apply X0 with (remove k m) k e; auto with map.
+  apply IHn.
+  assert (S n = S (cardinal (remove k m))).
+   rewrite Heqn.
+   eapply cardinal_2; eauto with map.
+  inversion H1; auto. 
+  eapply max_elt_Above; eauto.
+
+  apply X; apply max_elt_Empty; auto.
+  Qed.
+
+  Lemma map_induction_min :
+   forall P : t elt -> Type,
+   (forall m, Empty m -> P m) ->
+   (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') ->
+   forall m, P m.
+  Proof.
+  intros; remember (cardinal m) as n; revert m Heqn; induction n; intros.
+  apply X; apply cardinal_inv_1; auto.
+
+  case_eq (min_elt m); intros.
+  destruct p.
+  assert (Add k e (remove k m) m).
+   red; intros.
+   rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto.
+   apply find_1; apply MapsTo_1 with k; auto.
+   apply min_elt_MapsTo; auto.
+  apply X0 with (remove k m) k e; auto.
+  apply IHn.
+  assert (S n = S (cardinal (remove k m))).
+   rewrite Heqn.
+   eapply cardinal_2; eauto with map.
+  inversion H1; auto. 
+  eapply min_elt_Below; eauto.
+
+  apply X; apply min_elt_Empty; auto.
+  Qed.
+
+  End Induction_Principles.
+
+  Section Fold_properties.
+
+  (** The following lemma has already been proved on Weak Maps,
+      but with one additionnal hypothesis (some [transpose] fact). *)
+
+  Lemma fold_Equal : forall s1 s2 (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA)
+   (f:key->elt->A->A)(i:A), 
+   compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> 
+   Equal s1 s2 -> 
+   eqA (fold f s1 i) (fold f s2 i).
+  Proof.
+  intros.
+  do 2 rewrite fold_1.
+  do 2 rewrite <- fold_left_rev_right.
+  apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
+  apply eqlistA_rev.
+  apply elements_Equal_eqlistA; auto.
+  Qed.
+
+  Lemma fold_Add : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA)
+   (f:key->elt->A->A)(i:A), 
+   compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> 
+   transpose eqA (fun y =>f (fst y) (snd y)) -> 
+   ~In x s1 -> Add x e s1 s2 -> 
+   eqA (fold f s2 i) (f x e (fold f s1 i)).
+  Proof.
+  intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right.
+  set (f':=fun y x0 => f (fst y) (snd y) x0) in *.
+  change (f x e (fold_right f' i (rev (elements s1))))
+   with (f' (x,e) (fold_right f' i (rev (elements s1)))).
+  trans_st (fold_right f' i 
+              (rev (elements_lt (x, e) s1 ++ (x,e) :: elements_ge (x, e) s1))).
+  apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
+  apply eqlistA_rev.
+  apply elements_Add; auto.
+  rewrite distr_rev; simpl.
+  rewrite app_ass; simpl.
+  rewrite (elements_split (x,e) s1).
+  rewrite distr_rev; simpl.
+  apply fold_right_commutes with (eqA:=eqke) (eqB:=eqA); auto.
+  Qed.
+
+  Lemma fold_Add_Above : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA)
+   (f:key->elt->A->A)(i:A), 
+   compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> 
+   Above x s1 -> Add x e s1 s2 -> 
+   eqA (fold f s2 i) (f x e (fold f s1 i)).
+  Proof.
+  intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right.
+  set (f':=fun y x0 => f (fst y) (snd y) x0) in *.
+  trans_st (fold_right f' i (rev (elements s1 ++ (x,e)::nil))).
+  apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
+  apply eqlistA_rev.
+  apply elements_Add_Above; auto.
+  rewrite distr_rev; simpl.
+  refl_st.
+  Qed.
+
+  Lemma fold_Add_Below : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA)
+   (f:key->elt->A->A)(i:A), 
+   compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> 
+   Below x s1 -> Add x e s1 s2 -> 
+   eqA (fold f s2 i) (fold f s1 (f x e i)).
+  Proof.
+  intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right.
+  set (f':=fun y x0 => f (fst y) (snd y) x0) in *.
+  trans_st (fold_right f' i (rev (((x,e)::nil)++elements s1))).
+  apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
+  apply eqlistA_rev.
+  simpl; apply elements_Add_Below; auto.
+  rewrite distr_rev; simpl.
+  rewrite fold_right_app.
+  refl_st.
+  Qed.
+
+  End Fold_properties.
+
+ End Elt.
+
+End OrdProperties.
+
+
+
+
+
diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v
new file mode 100644
index 00000000..57cbbcc4
--- /dev/null
+++ b/theories/FSets/FMapFullAVL.v
@@ -0,0 +1,823 @@
+
+(***********************************************************************)
+(*  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: FMapFullAVL.v 10748 2008-04-03 18:28:26Z letouzey $ *)
+
+(** * FMapFullAVL
+   
+   This file contains some complements to [FMapAVL].
+
+   - Functor [AvlProofs] proves that trees of [FMapAVL] are not only 
+   binary search trees, but moreover well-balanced ones. This is done
+   by proving that all operations preserve the balancing.
+  
+   - We then pack the previous elements in a [IntMake] functor 
+   similar to the one of [FMapAVL], but richer.
+
+   - In final [IntMake_ord] functor, the [compare] function is 
+   different from the one in [FMapAVL]: this non-structural 
+   version is closer to the original Ocaml code.
+
+*)
+
+Require Import Recdef FMapInterface FMapList ZArith Int FMapAVL.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module AvlProofs (Import I:Int)(X: OrderedType).
+Module Import Raw := Raw I X.
+Module Import II:=MoreInt(I).
+Import Raw.Proofs.
+Open Local Scope pair_scope.
+Open Local Scope Int_scope.
+
+Section Elt.
+Variable elt : Type.
+Implicit Types m r : t elt.
+
+(** * 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 *)
+
+Inductive avl : t elt -> 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).
+
+
+(** * Automation and dedicated tactics about [avl]. *)
+
+Hint Constructors avl.
+
+Lemma height_non_negative : forall (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.
+
+
+(** * Basic results about [avl], [height] *)
+
+Lemma avl_node : forall x e l 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.
+
+(** Results about [height] *)
+
+Lemma height_0 : forall l, avl l -> height l = 0 -> 
+ l = Leaf _.
+Proof.
+ destruct 1; intuition; simpl in *.
+ avl_nns; simpl in *; elimtype False; omega_max.
+Qed.
+
+
+(** * Empty map *)
+
+Lemma empty_avl : avl (empty elt).
+Proof. 
+ unfold empty; auto.
+Qed.
+
+
+(** * Helper functions *)
+
+Lemma create_avl : 
+ forall l 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 l 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 bal_avl : forall l x e r, avl l -> avl r -> 
+ -(3) <= height l - height r <= 3 -> avl (bal l x e r).
+Proof.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ inv avl; simpl in *; 
+ match goal with |- avl (assert_false _ _ _ _) => avl_nns
+  | _ => repeat apply create_avl; simpl in *; auto
+ end; omega_max.
+Qed.
+
+Lemma bal_height_1 : forall l 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.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ inv avl; avl_nns; simpl in *; omega_max.
+Qed.
+
+Lemma bal_height_2 : 
+ forall l 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.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ inv avl; avl_nns; simpl in *; omega_max.
+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 *)
+
+Lemma add_avl_1 :  forall m x e, avl m -> 
+ avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1.
+Proof. 
+ intros 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 m x e, avl m -> avl (add x e m).
+Proof.
+ intros; generalize (add_avl_1 x e H); intuition.
+Qed.
+Hint Resolve add_avl.
+
+(** * Extraction of minimum binding *)
+
+Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) -> 
+ avl (remove_min l x e r)#1 /\ 
+ 0 <= height (Node l x e r h) - height (remove_min l x e r)#1 <= 1.
+Proof.
+ intros 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.
+ inversion_clear H.
+ rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); auto.
+ split; simpl in *.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+Qed.
+
+Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) -> 
+    avl (remove_min l x e r)#1. 
+Proof.
+ intros; generalize (remove_min_avl_1 H); intuition.
+Qed.
+
+(** * Merging two trees *)
+
+Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 -> 
+ -(2) <= height m1 - height m2 <= 2 -> 
+ avl (merge m1 m2) /\ 
+ 0<= height (merge m1 m2) - max (height m1) (height m2) <=1.
+Proof.
+ intros m1 m2; functional induction (merge m1 m2); intros; 
+ try factornode _x _x0 _x1 _x2 _x3 as m1.
+ simpl; split; auto; avl_nns; omega_max.
+ simpl; split; auto; avl_nns; omega_max.
+ generalize (remove_min_avl_1 H0).
+ rewrite e1; destruct 1.
+ split.
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+Qed.
+
+Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 -> 
+  -(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2).
+Proof. 
+ intros; generalize (merge_avl_1 H H0 H1); intuition.
+Qed.
+
+
+(** * Deletion *)
+
+Lemma remove_avl_1 : forall m x, avl m -> 
+ avl (remove x m) /\ 0 <= height m - height (remove x m) <= 1.
+Proof.
+ intros m x; functional induction (remove x m); intros.
+ split; auto; omega_max.
+ (* LT *)
+ inv avl.
+ destruct (IHt H0).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+ (* EQ *)
+ inv avl. 
+ generalize (merge_avl_1 H0 H1 H2).
+ intuition omega_max.
+ (* GT *)
+ inv avl.
+ destruct (IHt H1).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+Qed.
+
+Lemma remove_avl : forall m x, avl m -> avl (remove x m).
+Proof. 
+ intros; generalize (remove_avl_1 x H); intuition.
+Qed.
+Hint Resolve remove_avl.
+
+
+(** * Join *)
+
+Lemma join_avl_1 : forall l x d r, avl l -> avl r -> 
+ avl (join l x d r) /\
+ 0<= height (join l x d r) - max (height l) (height r) <= 1.
+Proof.
+ join_tac.
+
+ split; simpl; auto.
+ destruct (add_avl_1 x d H0).
+ avl_nns; omega_max.
+ set (l:=Node ll lx ld lr lh) in *.
+ split; auto.
+ destruct (add_avl_1 x d H).
+ simpl (height (Leaf elt)).
+ avl_nns; omega_max.
+
+ inversion_clear H.
+ assert (height (Node rl rx rd rr rh) = rh); auto.
+ set (r := Node rl rx rd rr rh) in *; clearbody r.
+ destruct (Hlr x d r H2 H0); clear Hrl Hlr.
+ set (j := join lr x d 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 ld lr lh) = lh); auto.
+ set (l := Node ll lx ld lr lh) in *; clearbody l.
+ destruct (Hrl H H1); clear Hrl Hlr.
+ set (j := join l x d 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 ld lr lh) = lh); auto.
+ assert (height (Node rl rx rd rr rh) = rh); auto.
+ set (l := Node ll lx ld lr lh) in *; clearbody l.
+ set (r := Node rl rx rd 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 d r, avl l -> avl r -> avl (join l x d r).
+Proof.
+ intros; destruct (join_avl_1 x d H H0); auto.
+Qed.
+Hint Resolve join_avl.
+
+(** concat *)
+
+Lemma concat_avl : forall m1 m2, avl m1 -> avl m2 -> avl (concat m1 m2).
+Proof.
+ intros m1 m2; functional induction (concat m1 m2); auto.
+ intros; apply join_avl; auto.
+ generalize (remove_min_avl H0); rewrite e1; simpl; auto.
+Qed.
+Hint Resolve concat_avl.
+
+(** split *)
+
+Lemma split_avl : forall m x, avl m -> 
+  avl (split x m)#l /\ avl (split x m)#r.
+Proof. 
+ intros m x; functional induction (split x m); simpl; auto.
+ rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
+ simpl; inversion_clear 1; auto.
+ rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
+Qed.
+
+End Elt.
+Hint Constructors avl.
+
+Section Map. 
+Variable elt elt' : Type.
+Variable f : elt -> elt'. 
+
+Lemma map_height : forall m, height (map f m) = height m.
+Proof. 
+destruct m; simpl; auto.
+Qed.
+
+Lemma map_avl : forall m, avl m -> avl (map f m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto; do 2 rewrite map_height; auto.
+Qed.
+
+End Map.
+
+Section Mapi.
+Variable elt elt' : Type.
+Variable f : key -> elt -> elt'. 
+
+Lemma mapi_height : forall m, height (mapi f m) = height m.
+Proof. 
+destruct m; simpl; auto.
+Qed.
+
+Lemma mapi_avl : forall m, avl m -> avl (mapi f m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto; do 2 rewrite mapi_height; auto.
+Qed.
+
+End Mapi.
+
+Section Map_option. 
+Variable elt elt' : Type.
+Variable f : key -> elt -> option elt'.
+
+Lemma map_option_avl : forall m, avl m -> avl (map_option f m).
+Proof.
+induction m; simpl; auto; intros.
+inv avl; destruct (f k e); auto using join_avl, concat_avl.
+Qed.
+
+End Map_option.
+
+Section Map2_opt.
+Variable elt elt' elt'' : Type.
+Variable f : key -> elt -> option elt' -> option elt''.
+Variable mapl : t elt -> t elt''.
+Variable mapr : t elt' -> t elt''.
+Hypothesis mapl_avl : forall m, avl m -> avl (mapl m).
+Hypothesis mapr_avl : forall m', avl m' -> avl (mapr m').
+
+Notation map2_opt := (map2_opt f mapl mapr).
+
+Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 -> 
+ avl (map2_opt m1 m2).
+Proof.
+intros m1 m2; functional induction (map2_opt m1 m2); auto; 
+factornode _x0 _x1 _x2 _x3 _x4 as r2; intros; 
+destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl; 
+auto using join_avl, concat_avl.
+Qed.
+
+End Map2_opt.
+
+Section Map2.
+Variable elt elt' elt'' : Type.
+Variable f : option elt -> option elt' -> option elt''.
+
+Lemma map2_avl : forall m1 m2, avl m1 -> avl m2 -> avl (map2 f m1 m2).
+Proof.
+unfold map2; auto using map2_opt_avl, map_option_avl.
+Qed.
+
+End Map2.
+End AvlProofs.
+
+(** * Encapsulation
+
+   We can implement [S] with balanced binary search trees. 
+   When compared to [FMapAVL], we maintain here two invariants
+   (bst and avl) instead of only bst, which is enough for fulfilling
+   the FMap interface.
+*) 
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+
+ Module E := X.
+ Module Import AvlProofs := AvlProofs I X.
+ Import Raw.
+ Import Raw.Proofs.
+
+ Record bbst (elt:Type) := 
+  Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}.
+ 
+ Definition t := bbst.
+ Definition key := E.t.
+ 
+ Section Elt.
+ Variable elt elt' elt'': Type.
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key. 
+ Implicit Types e : elt. 
+
+ Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt).
+ Definition is_empty m : bool := is_empty m.(this).
+ Definition add x e m : t elt := 
+  Bbst (add_bst x e m.(is_bst)) (add_avl x e m.(is_avl)).
+ Definition remove x m : t elt := 
+  Bbst (remove_bst x m.(is_bst)) (remove_avl x m.(is_avl)).
+ Definition mem x m : bool := mem x m.(this).
+ Definition find x m : option elt := find x m.(this).
+ Definition map f m : t elt' := 
+  Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)).
+ Definition mapi (f:key->elt->elt') m : t elt' := 
+  Bbst (mapi_bst f m.(is_bst)) (mapi_avl f m.(is_avl)).
+ Definition map2 f m (m':t elt') : t elt'' := 
+  Bbst (map2_bst f m.(is_bst) m'.(is_bst)) (map2_avl f m.(is_avl) m'.(is_avl)).
+ Definition elements m : list (key*elt) := elements m.(this).
+ Definition cardinal m := cardinal m.(this).
+ Definition fold (A:Type) (f:key->elt->A->A) m i := fold (A:=A) f m.(this) i.
+ Definition equal cmp m m' : bool := equal cmp m.(this) m'.(this).
+
+ Definition MapsTo x e m : Prop := MapsTo x e m.(this).
+ Definition In x m : Prop := In0 x m.(this).
+ Definition Empty m : Prop := Empty m.(this).
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt.
+ Definition lt_key : (key*elt) -> (key*elt) -> Prop := @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 (@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 In_alt; simpl; apply 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 In_alt; simpl; apply mem_2; auto.
+ Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact (@empty_1 elt). Qed.
+
+ Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+ Proof. intros m; exact (@is_empty_1 _ m.(this)). Qed.
+ Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+ Proof. intros m; exact (@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 (@add_1 elt _ x y e). 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 (@add_2 elt _ x y e e'). 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 (@add_3 elt _ x y e e'). 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 In_alt; simpl; apply remove_1; auto.
+ apply m.(is_bst).
+ 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 (@remove_2 elt _ x y e m.(is_bst)). 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 (@remove_3 elt _ x y e m.(is_bst)). Qed.
+
+
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. 
+ Proof. intros m x e; exact (@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 (@find_2 elt m.(this)). Qed.
+
+ Lemma fold_1 : forall m (A : Type) (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 (@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 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 <- elements_mapsto; auto.
+ Qed.
+
+ Lemma elements_3 : forall m, sort lt_key (elements m).  
+ Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed.
+
+ Lemma elements_3w : forall m, NoDupA eq_key (elements m).  
+ Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed.
+
+ Lemma cardinal_1 : forall m, cardinal m = length (elements m).
+ Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed.
+
+ Definition Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' := 
+   (forall k, In k m <-> In k m') /\ 
+   (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb cmp := Equiv (Cmp cmp).
+
+ Lemma Equivb_Equivb : forall cmp m m', 
+  Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'.
+ Proof. 
+ intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition.
+ generalize (H0 k); do 2 rewrite In_alt; intuition.
+ generalize (H0 k); do 2 rewrite In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- In_alt; intuition.
+ Qed.
+
+ Lemma equal_1 : forall m m' cmp, 
+   Equivb cmp m m' -> equal cmp m m' = true. 
+ Proof. 
+ unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; 
+  intros; simpl in *; rewrite equal_Equivb; auto.
+ Qed. 
+
+ Lemma equal_2 : forall m m' cmp, 
+   equal cmp m m' = true -> Equivb cmp m m'.
+ Proof. 
+ unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; 
+  intros; simpl in *; rewrite <-equal_Equivb; auto.
+ Qed.
+
+ End Elt.
+
+ Lemma map_1 : forall (elt elt':Type)(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 (@map_1 elt elt' f m.(this) x e). Qed.
+
+ Lemma map_2 : forall (elt elt':Type)(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 In_alt; simpl.
+ apply map_2; auto.
+ Qed. 
+
+ Lemma mapi_1 : forall (elt elt':Type)(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 (@mapi_1 elt elt' f m.(this) x e). Qed.
+ Lemma mapi_2 : forall (elt elt':Type)(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 In_alt; simpl; apply mapi_2; auto.
+ Qed.
+
+ Lemma map2_1 : forall (elt elt' elt'':Type)(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 In_alt; intros; simpl; apply map2_1; auto.
+ apply m.(is_bst).
+ apply m'.(is_bst).
+ Qed.
+
+ Lemma map2_2 : forall (elt elt' elt'':Type)(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 In_alt; intros; simpl in *; eapply 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 Import MapS := IntMake(I)(X). 
+  Import AvlProofs.
+  Import Raw.Proofs.
+  Module Import MD := OrderedTypeFacts(D).
+  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.Proofs.elements_sort m.(is_bst)).
+
+  (** * As comparison function, we propose here a non-structural 
+    version faithful to the code of Ocaml's Map library, instead of 
+    the structural version of FMapAVL *)
+
+  Fixpoint cardinal_e (e:Raw.enumeration D.t) := 
+    match e with 
+     | Raw.End => 0%nat
+     | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e)
+    end.
+
+  Lemma cons_cardinal_e : forall m e, 
+   cardinal_e (Raw.cons m e) = (Raw.cardinal m + cardinal_e e)%nat.
+  Proof.
+   induction m; simpl; intros; auto.
+   rewrite IHm1; simpl; rewrite <- plus_n_Sm; auto with arith.
+  Qed.
+
+  Definition cardinal_e_2 ee := 
+   (cardinal_e (fst ee) + cardinal_e (snd ee))%nat.
+
+  Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t) 
+   { measure cardinal_e_2 ee } : comparison := 
+  match ee with 
+  | (Raw.End, Raw.End) => Eq
+  | (Raw.End, Raw.More _ _ _ _) => Lt
+  | (Raw.More _ _ _ _, Raw.End) => Gt
+  | (Raw.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) =>
+      match X.compare x1 x2 with
+      | EQ _ => match D.compare d1 d2 with 
+                | EQ _ => compare_aux (Raw.cons r1 e1, Raw.cons r2 e2)
+                | LT _ => Lt
+                | GT _ => Gt
+                end
+      | LT _ => Lt
+      | GT _ => Gt
+      end
+  end.
+  Proof.
+  intros; unfold cardinal_e_2; simpl; 
+  abstract (do 2 rewrite cons_cardinal_e; romega with * ).
+  Defined.
+  
+  Definition Cmp c :=
+   match c with
+    | Eq => LO.eq_list
+    | Lt => LO.lt_list
+    | Gt => (fun l1 l2 => LO.lt_list l2 l1)
+   end.
+
+  Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, 
+   X.eq x1 x2 -> D.eq d1 d2 ->
+   Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2).
+  Proof.
+   destruct c; simpl; intros; MX.elim_comp; auto.
+  Qed.
+  Hint Resolve cons_Cmp.
+
+  Lemma compare_aux_Cmp : forall e, 
+   Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)).
+  Proof.
+  intros e; functional induction (compare_aux e); simpl in *; 
+   auto; intros; try clear e0; try clear e3; try MX.elim_comp; auto.
+  rewrite 2 cons_1 in IHc; auto.
+  Qed.
+
+  Lemma compare_Cmp : forall m1 m2, 
+    Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))) 
+     (Raw.elements m1) (Raw.elements m2).
+  Proof.
+  intros. 
+  assert (H1:=cons_1 m1 (Raw.End _)).
+  assert (H2:=cons_1 m2 (Raw.End _)).
+  simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2.
+  apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _), 
+                           Raw.cons m2 (Raw.End _))).
+  Qed.
+
+  Definition eq (m1 m2 : t) := LO.eq_list (Raw.elements m1) (Raw.elements m2).
+  Definition lt (m1 m2 : t) := LO.lt_list (Raw.elements m1) (Raw.elements m2).
+
+  Definition compare (s s':t) : Compare lt eq s s'.
+  Proof.
+   intros (s,b,a) (s',b',a').
+   generalize (compare_Cmp s s').
+   destruct compare_aux; intros; [apply EQ|apply LT|apply GT]; red; auto.
+  Defined.
+
+    
+  (* Proofs about [eq] and [lt] *)
+
+  Definition selements (m1 : t) := 
+   LO.MapS.Build_slist (elements_sort m1.(is_bst)).
+
+  Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2).
+  Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2).
+
+  Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2.
+  Proof.
+   unfold eq, seq, selements, elements, LO.eq; intuition.
+  Qed.
+
+  Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2.
+  Proof.
+   unfold lt, slt, selements, elements, LO.lt; intuition.
+  Qed.
+
+  Lemma eq_1 : forall (m m' : t), MapS.Equivb cmp m m' -> eq m m'.
+  Proof.
+  intros m m'.
+  rewrite eq_seq; unfold seq.
+  rewrite Equivb_Equivb.
+  rewrite Equivb_elements.
+  auto using LO.eq_1.
+  Qed.
+
+  Lemma eq_2 : forall m m', eq m m' -> MapS.Equivb cmp m m'.
+  Proof.
+  intros m m'.
+  rewrite eq_seq; unfold seq.
+  rewrite Equivb_Equivb.
+  rewrite Equivb_elements.
+  intros.
+  generalize (LO.eq_2 H).
+  auto.
+  Qed.
+
+  Lemma eq_refl : forall m : t, eq m m.
+  Proof. 
+  intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl.
+  Qed.
+
+  Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+  Proof.
+  intros m1 m2; rewrite 2 eq_seq; unfold seq; 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.
+  intros m1 m2 M3; rewrite 3 eq_seq; unfold seq.
+   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.
+  intros m1 m2 m3; rewrite 3 lt_slt; unfold slt;  
+   intros; eapply LO.lt_trans; eauto.
+  Qed.
+
+  Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
+  Proof.
+  intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; 
+   intros; apply LO.lt_not_eq; 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/FMapIntMap.v b/theories/FSets/FMapIntMap.v
deleted file mode 100644
index c7681bd4..00000000
--- a/theories/FSets/FMapIntMap.v
+++ /dev/null
@@ -1,622 +0,0 @@
-(***********************************************************************)
-(*  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/FMapInterface.v b/theories/FSets/FMapInterface.v
index dde74a0a..1e475887 100644
--- a/theories/FSets/FMapInterface.v
+++ b/theories/FSets/FMapInterface.v
@@ -6,42 +6,72 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapInterface.v 8671 2006-03-29 08:31:28Z letouzey $ *)
+(* $Id: FMapInterface.v 10616 2008-03-04 17:33:35Z letouzey $ *)
 
 (** * Finite map library *)  
 
-(** This file proposes an interface for finite maps *)
+(** This file proposes interfaces for finite maps *)
 
-(* begin hide *)
+Require Export Bool DecidableType OrderedType.
 Set Implicit Arguments.
 Unset Strict Implicit.
-Require Import FSetInterface. 
-(* end hide *)
-
-(** When compared with Ocaml Map, this signature has been split in two: 
-   - The first part [S] contains the usual operators (add, find, ...)
-     It only requires a ordered key type, the data type can be arbitrary. 
-     The only function that asks more is [equal], whose first argument should 
-     be an equality on data. 
-   - Then, [Sord] extends [S] with a complete comparison function. For 
-     that, the data type should have a decidable total ordering. 
+
+(** When compared with Ocaml Map, this signature has been split in 
+    several parts : 
+
+   - The first parts [WSfun] and [WS] propose signatures for weak
+     maps, which are maps with no ordering on the key type nor the
+     data type.  [WSfun] and [WS] are almost identical, apart from the
+     fact that [WSfun] is expressed in a functorial way whereas [WS]
+     is self-contained. For obtaining an instance of such signatures,
+     a decidable equality on keys in enough (see for example
+     [FMapWeakList]). These signatures contain the usual operators
+     (add, find, ...). The only function that asks for more is
+     [equal], whose first argument should be a comparison on data.
+
+   - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the 
+     case where the key type is ordered. The main novelty is that 
+     [elements] is required to produce sorted lists.
+
+   - Finally, [Sord] extends [S] with a complete comparison function. For 
+     that, the data type should have a decidable total ordering as well. 
+
+   If unsure, what you're looking for is probably [S]: apart from [Sord],
+   all other signatures are subsets of [S]. 
+
+   Some additional differences with Ocaml: 
+    
+    - no [iter] function, useless since Coq is purely functional
+    - [option] types are used instead of [Not_found] exceptions
+    - more functions are provided: [elements] and [cardinal] and [map2]
+
 *)
 
 
-Module Type S.
+Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true.
 
-  Declare Module E : OrderedType.
+(** ** Weak signature for maps
+   
+    No requirements for an ordering on keys nor elements, only decidability
+    of equality on keys. First, a functorial signature: *)
+
+Module Type WSfun (E : EqualityType).
+
+  (** The module E of base objects is meant to be a [DecidableType]
+     (and used to be so). But requiring only an [EqualityType] here
+     allows subtyping between weak and ordered maps. *)
 
   Definition key := E.t.
 
-  Parameter t : Set -> Set. (** the abstract type of maps *)
+  Parameter t : Type -> Type.
+  (** the abstract type of maps *)
  
   Section Types. 
 
-    Variable elt:Set.
+    Variable elt:Type.
 
     Parameter empty : t elt.
-      (** The empty map. *)
+    (** The empty map. *)
 
     Parameter is_empty : t elt -> bool.
     (** Test whether a map is empty or not. *)
@@ -53,8 +83,7 @@ Module Type S.
 
     Parameter find : key -> t elt -> option elt. 
     (** [find x m] returns the current binding of [x] in [m], 
-	or raises [Not_found] if no such binding exists.
-	NB: in Coq, the exception mechanism becomes a option type. *)
+	or [None] if no such binding exists. *)
 
     Parameter remove : key -> t elt -> t elt.
     (** [remove x m] returns a map containing the same bindings as [m], 
@@ -64,45 +93,36 @@ Module Type S.
     (** [mem x m] returns [true] if [m] contains a binding for [x], 
 	and [false] otherwise. *)
 
-    (** Coq comment: [iter] is useless in a purely functional world *)
-    (** val iter : (key -> 'a -> unit) -> 'a t -> unit *)
-    (** iter f m applies f to all bindings in map m. f receives the key as 
-	first argument, and the associated value as second argument. 
-	The bindings are passed to f in increasing order with respect to the 
-	ordering over the type of the keys. Only current bindings are 
-	presented to f: bindings hidden by more recent bindings are not 
-	passed to f. *)
-
-    Variable elt' : Set. 
-    Variable elt'': Set.
+    Variable elt' elt'' : Type.
 
     Parameter map : (elt -> elt') -> t elt -> t elt'.
     (** [map f m] returns a map with same domain as [m], where the associated 
 	value a of all bindings of [m] has been replaced by the result of the
-	application of [f] to [a]. The bindings are passed to [f] in 
-	increasing order with respect to the ordering over the type of the 
-	keys. *)
+	application of [f] to [a]. Since Coq is purely functional, the order
+        in which the bindings are passed to [f] is irrelevant. *)
 
     Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'.
-    (** Same as [S.map], but the function receives as arguments both the 
+    (** Same as [map], but the function receives as arguments both the 
 	key and the associated value for each binding of the map. *)
 
-    Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' ->  t elt''.
-    (** Not present in Ocaml. 
-         [map f m m'] creates a new map whose bindings belong to the ones of either 
-         [m] or [m']. The presence and value for a key [k] is determined by [f e e'] 
-         where [e] and [e'] are the (optional) bindings of [k] in [m] and [m']. *)
+    Parameter map2 : 
+     (option elt -> option elt' -> option elt'') -> t elt -> t elt' ->  t elt''.
+    (** [map2 f m m'] creates a new map whose bindings belong to the ones 
+        of either [m] or [m']. The presence and value for a key [k] is 
+        determined by [f e e'] where [e] and [e'] are the (optional) bindings 
+        of [k] in [m] and [m']. *)
 
     Parameter elements : t elt -> list (key*elt).
-    (** Not present in Ocaml. 
-         [elements m] returns an assoc list corresponding to the bindings of [m].
-         Elements of this list are sorted with respect to their first components. 
-         Useful to specify [fold] ... *)
+    (** [elements m] returns an assoc list corresponding to the bindings 
+        of [m], in any order. *)
 
-    Parameter fold : forall A: Set, (key -> elt -> A -> A) -> t elt -> A -> A.
+    Parameter cardinal : t elt -> nat. 
+    (** [cardinal m] returns the number of bindings in [m]. *)
+
+    Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A.
     (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], 
 	where [k1] ... [kN] are the keys of all bindings in [m] 
-	(in increasing order), and [d1] ... [dN] are the associated data. *)
+	(in any order), and [d1] ... [dN] are the associated data. *)
 
     Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool.
     (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, 
@@ -127,8 +147,6 @@ Module Type S.
       Definition eq_key_elt (p p':key*elt) := 
           E.eq (fst p) (fst p') /\ (snd p) = (snd p').
 
-      Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p').
-
     (** Specification of [MapsTo] *)
       Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
       
@@ -162,61 +180,123 @@ Module Type S.
         MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
       Parameter elements_2 : 
         InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
-      Parameter elements_3 : sort lt_key (elements m).  
+      (** When compared with ordered maps, here comes the only 
+         property that is really weaker: *)
+      Parameter elements_3w : NoDupA eq_key (elements m).  
+
+    (** Specification of [cardinal] *)
+      Parameter cardinal_1 : cardinal m = length (elements m).
 
     (** Specification of [fold] *)  
       Parameter fold_1 :
-	forall (A : Set) (i : A) (f : key -> elt -> A -> A),
+	forall (A : Type) (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.
+
+    (** Equality of maps *)
  
-   Definition Equal cmp m m' := 
+    (** Caveat: there are at least three distinct equality predicates on maps.
+      - The simpliest (and maybe most natural) way is to consider keys up to 
+        their equivalence [E.eq], but elements up to Leibniz equality, in 
+        the spirit of [eq_key_elt] above. This leads to predicate [Equal].
+      - Unfortunately, this [Equal] predicate can't be used to describe
+        the [equal] function, since this function (for compatibility with 
+        ocaml) expects a boolean comparison [cmp] that may identify more 
+        elements than Leibniz. So logical specification of [equal] is done 
+        via another predicate [Equivb]
+      - This predicate [Equivb] is quite ad-hoc with its boolean [cmp],
+        it can be generalized in a [Equiv] expecting a more general
+        (possibly non-decidable) equality predicate on elements *)
+
+     Definition Equal m m' := forall y, find y m = find y m'.
+     Definition Equiv (eq_elt:elt->elt->Prop) 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).  
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').  
+     Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp).
 
-   Variable cmp : elt -> elt -> bool. 
+     (** Specification of [equal] *)
 
-   (** Specification of [equal] *)
-     Parameter equal_1 : Equal cmp m m' -> equal cmp m m' = true. 
-     Parameter equal_2 : equal cmp m m' = true -> Equal cmp m m'.
+     Variable cmp : elt -> elt -> bool. 
 
-    End Spec. 
-   End Types. 
+     Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true.
+     Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'.
+
+    End Spec.
+   End Types.
 
     (** Specification of [map] *)
-      Parameter map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+      Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
         MapsTo x e m -> MapsTo x (f e) (map f m).
-      Parameter map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
+      Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), 
         In x (map f m) -> In x m.
  
     (** Specification of [mapi] *)
-      Parameter mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+      Parameter mapi_1 : forall (elt elt':Type)(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).
-      Parameter mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
+      Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
         (f:key->elt->elt'), In x (mapi f m) -> In x m.
 
     (** Specification of [map2] *)
-      Parameter map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+      Parameter map2_1 : forall (elt elt' elt'':Type)(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').       
 
-     Parameter map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+     Parameter map2_2 : forall (elt elt' elt'':Type)(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'.
 
-  (* begin hide *)
-  Hint Immediate MapsTo_1 mem_2 is_empty_2.
-  
-  Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 add_3 remove_1
-    remove_2 remove_3 find_1 find_2 fold_1 map_1 map_2 mapi_1 mapi_2. 
-  (* end hide *)
+  Hint Immediate MapsTo_1 mem_2 is_empty_2
+    map_2 mapi_2 add_3 remove_3 find_2
+    : map.
+  Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1
+    remove_2 find_1 fold_1 map_1 mapi_1 mapi_2
+    : map.
 
+End WSfun.
+
+
+(** ** Static signature for Weak Maps 
+
+    Similar to [WSfun] but expressed in a self-contained way. *)
+
+Module Type WS. 
+  Declare Module E : EqualityType.
+  Include Type WSfun E.
+End WS.
+
+
+
+(** ** Maps on ordered keys, functorial signature *)
+
+Module Type Sfun (E : OrderedType).
+  Include Type WSfun E.
+  Section elt.
+  Variable elt:Type.
+   Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p').
+   (* Additional specification of [elements] *)
+   Parameter elements_3 : forall m, sort lt_key (elements m).
+   (** Remark: since [fold] is specified via [elements], this stronger
+   specification of [elements] has an indirect impact on [fold],
+   which can now be proved to receive elements in increasing order. *) 
+  End elt.
+End Sfun.
+
+
+
+(** ** Maps on ordered keys, self-contained signature *)
+
+Module Type S. 
+  Declare Module E : OrderedType.
+  Include Type Sfun E.
 End S.
 
 
+
+(** ** Maps with ordering both on keys and datas *)
+
 Module Type Sord.
- 
+
   Declare Module Data : OrderedType.   
   Declare Module MapS : S. 
   Import MapS.
@@ -234,12 +314,11 @@ Module Type Sord.
 
   Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end.	
 
-  Parameter eq_1 : forall m m', Equal cmp m m' -> eq m m'.
-  Parameter eq_2 : forall m m', eq m m' -> Equal cmp m m'.
+  Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
+  Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'.
 
   Parameter compare : forall m1 m2, Compare lt eq m1 m2.
-  (** Total ordering between maps. The first argument (in Coq: Data.compare) 
-      is a total ordering used to compare data associated with equal keys 
-      in the two maps. *)
+  (** Total ordering between maps. [Data.compare] is a total ordering 
+      used to compare data associated with equal keys in the two maps. *)
 
-End Sord.
\ No newline at end of file
+End Sord.
diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v
index 067f5a3e..23bf8196 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 9035 2006-07-09 15:42:09Z herbelin $ *)
+(* $Id: FMapList.v 10616 2008-03-04 17:33:35Z letouzey $ *)
 
 (** * Finite map library *)
 
@@ -14,7 +14,6 @@
  [FMapInterface.S] using lists of pairs ordered (increasing) with respect to
  left projection. *)
 
-Require Import FSetInterface. 
 Require Import FMapInterface.
 
 Set Implicit Arguments.
@@ -22,26 +21,14 @@ Unset Strict Implicit.
 
 Module Raw (X:OrderedType).
 
-Module E := X.
-Module MX := OrderedTypeFacts X.
-Module PX := KeyOrderedType X.
-Import MX. 
-Import PX. 
+Module Import MX := OrderedTypeFacts X.
+Module Import PX := KeyOrderedType X.
 
 Definition key := X.t.
-Definition t (elt:Set) := list (X.t * elt).
+Definition t (elt:Type) := list (X.t * elt).
 
 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').
-Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
-Definition In k m := exists e:elt, MapsTo k e m.
-*)
+Variable elt : Type.
 
 Notation eqk := (eqk (elt:=elt)).   
 Notation eqke := (eqke (elt:=elt)).
@@ -347,15 +334,22 @@ Proof.
  auto.
 Qed.
 
+Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). 
+Proof. 
+ intros.
+ apply Sort_NoDupA.
+ apply elements_3; auto.
+Qed.
+
 (** * [fold] *)
 
-Function fold (A:Set)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} :  A :=
+Function fold (A:Type)(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)
   end.
 
-Lemma fold_1 : forall m (A:Set)(i:A)(f:key->elt->A->A),
+Lemma fold_1 : forall m (A:Type)(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 f m i); auto.
@@ -374,29 +368,24 @@ Function equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool :=
    | _, _ => false 
   end.
 
-Definition Equal cmp m m' := 
+Definition Equivb 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_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, 
-  Equal cmp m m' -> equal cmp m m' = true. 
+  Equivb 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; subst;auto; unfold Equal;
- intuition; subst;   match goal with 
-     | [H: X.compare _ _ = _ |- _ ] => clear H
-     | _ => idtac
-   end.
-
-
-
+ functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
+ intuition; subst.
+ match goal with H: X.compare _ _ = _ |- _ => clear H end.
  assert (cmp_e_e':cmp e e' = true).
   apply H1 with x; auto.
  rewrite cmp_e_e'; simpl.
  apply IHb; auto.
  inversion_clear Hm; auto.
  inversion_clear Hm'; auto.
- unfold Equal; intuition.
+ unfold Equivb; intuition.
  destruct (H0 k).
  assert (In k ((x,e) ::l)).
   destruct H as (e'', hyp); exists e''; auto.
@@ -459,14 +448,12 @@ Qed.
 
 
 Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, 
-  equal cmp m m' = true -> Equal cmp m m'.
+  equal cmp m m' = true -> Equivb cmp m m'.
 Proof.
  intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
- 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. 
+ functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; 
+  intuition; try discriminate; subst; 
+  try match goal with H: X.compare _ _ = _ |- _ => clear H end.
 
  inversion H0.
 
@@ -502,13 +489,13 @@ Proof.
  elim (Sort_Inf_NotIn H2 H3).
  exists e0; apply MapsTo_eq with k; auto; order.
  apply H8 with k; auto.
-Qed. 
+Qed.
 
-(** This lemma isn't part of the spec of [Equal], but is used in [FMapAVL] *)
+(** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *)
 
 Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) ->
   eqk x y -> cmp (snd x) (snd y) = true -> 
-  (Equal cmp l1 l2 <-> Equal cmp (x :: l1) (y :: l2)).
+  (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)).
 Proof.
  intros.
  inversion H; subst.
@@ -527,7 +514,7 @@ Proof.
  rewrite H2; simpl; auto.
 Qed.
 
-Variable elt':Set.
+Variable elt':Type.
 
 (** * [map] and [mapi] *)
   
@@ -548,7 +535,7 @@ Section Elt2.
 (* A new section is necessary for previous definitions to work 
    with different [elt], especially [MapsTo]... *)
   
-Variable elt elt' : Set.
+Variable elt elt' : Type.
 
 (** Specification of [map] *)
 
@@ -684,10 +671,10 @@ Section Elt3.
 
 (** * [map2] *)
 
-Variable elt elt' elt'' : Set.
+Variable elt elt' elt'' : Type.
 Variable f : option elt -> option elt' -> option elt''.
 
-Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := 
+Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := 
   match o with 
    | Some e => (k,e)::l
    | None => l
@@ -739,7 +726,7 @@ Fixpoint combine (m : t elt) : t elt' -> t oee' :=
         end
   end. 
 
-Definition fold_right_pair (A B C:Set)(f: A->B->C->C)(l:list (A*B))(i:C) := 
+Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := 
   List.fold_right (fun p => f (fst p) (snd p)) i l.
 
 Definition map2_alt m m' := 
@@ -1038,12 +1025,12 @@ Module E := X.
 
 Definition key := E.t.
 
-Record slist (elt:Set) : Set :=  
+Record slist (elt:Type) :=  
   {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}.
-Definition t (elt:Set) : Set := slist elt. 
+Definition t (elt:Type) : Type := slist elt. 
 
 Section Elt. 
- Variable elt elt' elt'':Set. 
+ Variable elt elt' elt'':Type. 
 
  Implicit Types m : t elt.
  Implicit Types x y : key. 
@@ -1060,13 +1047,19 @@ Section Elt.
  Definition map2 f m (m':t elt') : t elt'' := 
    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 cardinal m := length m.(this).
+ Definition fold (A:Type)(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 Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' := 
+         (forall k, In k m <-> In k m') /\ 
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').  
+ Definition Equivb cmp m m' : Prop := @Raw.Equivb 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.
@@ -1113,34 +1106,39 @@ Section Elt.
  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 elements_3w : forall m, NoDupA eq_key (elements m).  
+ Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(sorted)). Qed.
+
+ Lemma cardinal_1 : forall m, cardinal m = length (elements m).
+ Proof. intros; reflexivity. Qed.
 
- Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A),
+ Lemma fold_1 : forall m (A : Type) (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. 
+ Lemma equal_1 : forall m m' cmp, Equivb 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'.
+ Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb 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'), 
+ Lemma map_1 : forall (elt elt':Type)(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'), 
+ Lemma map_2 : forall (elt elt':Type)(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)
+ Lemma mapi_1 : forall (elt elt':Type)(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)
+ Lemma mapi_2 : forall (elt elt':Type)(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')
+ Lemma map2_1 : forall (elt elt' elt'':Type)(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').       
@@ -1148,7 +1146,7 @@ Section Elt.
  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')
+ Lemma map2_2 : forall (elt elt' elt'':Type)(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. 
@@ -1229,7 +1227,7 @@ Proof.
  unfold equal, eq in H6; simpl in H6; auto.
 Qed.
 
-Lemma eq_1 : forall m m', Equal cmp m m' -> eq m m'.
+Lemma eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
 Proof.
  intros.
  generalize (@equal_1 D.t m m' cmp).
@@ -1237,7 +1235,7 @@ Proof.
  intuition.
 Qed.
 
-Lemma eq_2 : forall m m', eq m m' -> Equal cmp m m'.
+Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'.
 Proof.
  intros.
  generalize (@equal_2 D.t m m' cmp).
diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v
index 44724767..9bc2a599 100644
--- a/theories/FSets/FMapPositive.v
+++ b/theories/FSets/FMapPositive.v
@@ -11,11 +11,12 @@
  * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
  *              91405 Orsay, France *)
 
-(* $Id: FMapPositive.v 9862 2007-05-25 16:57:06Z letouzey $ *)
+(* $Id: FMapPositive.v 10739 2008-04-01 14:45:20Z herbelin $ *)
 
 Require Import Bool.
 Require Import ZArith.
 Require Import OrderedType.
+Require Import OrderedTypeEx.
 Require Import FMapInterface.
 
 Set Implicit Arguments.
@@ -36,9 +37,12 @@ Open Local Scope positive_scope.
   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.
+Module PositiveOrderedTypeBits <: 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.
 
   Fixpoint bits_lt (p q:positive) { struct p } : Prop := 
    match p, q with 
@@ -52,15 +56,6 @@ Module PositiveOrderedTypeBits <: OrderedType.
 
   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.
@@ -171,17 +166,18 @@ Qed.
 Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
 
   Module E:=PositiveOrderedTypeBits.
+  Module ME:=KeyOrderedType E.
 
   Definition key := positive.
 
-  Inductive tree (A : Set) : Set :=
+  Inductive tree (A : Type) :=
     | Leaf : tree A
     | Node : tree A -> option A -> tree A -> tree A.
 
   Definition t := tree.
 
   Section A.
-  Variable A:Set.
+  Variable A:Type.
 
   Implicit Arguments Leaf [A].
 
@@ -280,6 +276,15 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
 
   Definition elements (m : t A) := xelements m xH.
 
+  (** [cardinal] *)
+
+  Fixpoint cardinal (m : t A) : nat :=
+    match m with 
+      | Leaf => 0%nat 
+      | Node l None r => (cardinal l + cardinal r)%nat
+      | Node l (Some _) r => S (cardinal l + cardinal r)
+    end.
+
   Section CompcertSpec.
 
   Theorem gempty:
@@ -560,6 +565,16 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     exact (xelements_complete i xH m v H).
   Qed.
 
+  Lemma cardinal_1 : 
+   forall (m: t A), cardinal m = length (elements m).
+  Proof.
+   unfold elements.
+   intros m; set (p:=1); clearbody p; revert m p.
+   induction m; simpl; auto; intros.
+   rewrite (IHm1 (append p 2)), (IHm2 (append p 3)); auto.
+   destruct o; rewrite app_length; simpl; omega.
+  Qed.
+
   End CompcertSpec.
 
   Definition MapsTo (i:positive)(v:A)(m:t A) := find i m = Some v.
@@ -793,11 +808,17 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   apply xelements_sort; auto.
   Qed.
 
+  Lemma elements_3w : NoDupA eq_key (elements m).
+  Proof.
+  change eq_key with (@ME.eqk A).
+  apply ME.Sort_NoDupA; apply elements_3; auto.
+  Qed.
+
   End FMapSpec.
 
   (** [map] and [mapi] *)
  
-  Variable B : Set.
+  Variable B : Type.
 
   Fixpoint xmapi (f : positive -> A -> B) (m : t A) (i : positive)
              {struct m} : t B :=
@@ -815,7 +836,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   End A.
 
   Lemma xgmapi:
-      forall (A B: Set) (f: positive -> A -> B) (i j : positive) (m: t A),
+      forall (A B: Type) (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.
@@ -825,7 +846,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Qed.
 
   Theorem gmapi:
-    forall (A B: Set) (f: positive -> A -> B) (i: positive) (m: t A),
+    forall (A B: Type) (f: positive -> A -> B) (i: positive) (m: t A),
     find i (mapi f m) = option_map (f i) (find i m).
   Proof.
   intros.
@@ -836,7 +857,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Qed.
 
   Lemma mapi_1 : 
-    forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), 
+    forall (elt elt':Type)(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.
@@ -851,7 +872,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Qed.
 
   Lemma mapi_2 : 
-    forall (elt elt':Set)(m: t elt)(x:key)(f:key->elt->elt'), 
+    forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), 
     In x (mapi f m) -> In x m.
   Proof.
   intros.
@@ -864,21 +885,21 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   simpl in *; discriminate.
   Qed.
 
-  Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+  Lemma map_1 : forall (elt elt':Type)(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'), 
+  Lemma map_2 : forall (elt elt':Type)(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 A B C : Type.
   Variable f : option A -> option B -> option C.
   
   Implicit Arguments Leaf [A].
@@ -927,10 +948,10 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
 
   End map2.
 
-  Definition map2 (elt elt' elt'':Set)(f:option elt->option elt'->option elt'') := 
+  Definition map2 (elt elt' elt'':Type)(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')
+  Lemma map2_1 : forall (elt elt' elt'':Type)(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'). 
@@ -946,7 +967,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   destruct H; intuition; try discriminate.
   Qed.
 
-  Lemma  map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+  Lemma  map2_2 : forall (elt elt' elt'':Type)(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.
@@ -962,17 +983,17 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Qed.
 
 
-  Definition fold (A B : Set) (f: positive -> A -> B -> B) (tr: t A) (v: B) :=
+  Definition fold (A : Type)(B : Type) (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),
+    forall (A:Type)(m:t A)(B:Type)(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 := 
+  Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := 
     match m1, m2 with 
       | Leaf, _ => is_empty m2
       | _, Leaf => is_empty m1
@@ -985,12 +1006,15 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
            && equal cmp l1 l2 && equal cmp r1 r2
      end.
 
-  Definition Equal (A:Set)(cmp:A->A->bool)(m m':t A) := 
+  Definition Equal (A:Type)(m m':t A) := 
+    forall y, find y m = find y m'.
+  Definition Equiv (A:Type)(eq_elt:A->A->Prop) 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).  
+    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').  
+  Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp).
 
-  Lemma equal_1 : forall (A:Set)(m m':t A)(cmp:A->A->bool), 
-    Equal cmp m m' -> equal cmp m m' = true. 
+  Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), 
+    Equivb cmp m m' -> equal cmp m m' = true. 
   Proof. 
   induction m.
   (* m = Leaf *)
@@ -1024,11 +1048,11 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   destruct H2; red in H2; simpl in H2; discriminate.
   (* m' = Node *)
   destruct 1.
-  assert (Equal cmp m1 m'1).
+  assert (Equivb 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).
+  assert (Equivb 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.
@@ -1043,8 +1067,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   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'. 
+  Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), 
+    equal cmp m m' = true -> Equivb cmp m m'. 
   Proof. 
   induction m.
   (* m = Leaf *)
@@ -1103,7 +1127,7 @@ Module PositiveMapAdditionalFacts.
 
   (* Derivable from the Map interface *)
   Theorem gsspec:
-    forall (A:Set)(i j: positive) (x: A) (m: t A),
+    forall (A:Type)(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.
@@ -1112,7 +1136,7 @@ Module PositiveMapAdditionalFacts.
 
    (* Not derivable from the Map interface *)
   Theorem gsident:
-    forall (A:Set)(i: positive) (m: t A) (v: A),
+    forall (A:Type)(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.
@@ -1121,7 +1145,7 @@ Module PositiveMapAdditionalFacts.
   Qed.
   
   Lemma xmap2_lr :
-      forall (A B : Set)(f g: option A -> option A -> option B)(m : t A),
+      forall (A B : Type)(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.
@@ -1132,7 +1156,7 @@ Module PositiveMapAdditionalFacts.
     Qed.
 
   Theorem map2_commut:
-    forall (A B: Set) (f g: option A -> option A -> option B),
+    forall (A B: Type) (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.
diff --git a/theories/FSets/FMapWeak.v b/theories/FSets/FMapWeak.v
deleted file mode 100644
index 1ad190a4..00000000
--- a/theories/FSets/FMapWeak.v
+++ /dev/null
@@ -1,15 +0,0 @@
-(***********************************************************************)
-(*  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: 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
deleted file mode 100644
index 18f73a3f..00000000
--- a/theories/FSets/FMapWeakFacts.v
+++ /dev/null
@@ -1,599 +0,0 @@
-(***********************************************************************)
-(*  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/FMapWeakInterface.v b/theories/FSets/FMapWeakInterface.v
deleted file mode 100644
index b6df4da5..00000000
--- a/theories/FSets/FMapWeakInterface.v
+++ /dev/null
@@ -1,201 +0,0 @@
-(***********************************************************************)
-(*  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: FMapWeakInterface.v 8639 2006-03-16 19:21:55Z letouzey $ *)
-
-(** * Finite map library *) 
-
-(** This file proposes an interface for finite maps over keys with decidable 
-     equality, but no decidable order. *)
-
-Set Implicit Arguments.
-Unset Strict Implicit.
-Require Import FSetInterface. 
-Require Import FSetWeakInterface. 
-
-Module Type S.
-
-  Declare Module E : DecidableType.
-
-  Definition key := E.t.
-
-  Parameter t : Set -> Set. (** the abstract type of maps *)
- 
-  Section Types. 
-
-    Variable elt:Set.
-
-    Parameter empty : t elt.
-      (** The empty map. *)
-
-    Parameter is_empty : t elt -> bool.
-    (** Test whether a map is empty or not. *)
-
-    Parameter add : key -> elt -> t elt -> t elt.
-    (** [add x y m] returns a map containing the same bindings as [m], 
-	plus a binding of [x] to [y]. If [x] was already bound in [m], 
-	its previous binding disappears. *)
-
-    Parameter find : key -> t elt -> option elt. 
-    (** [find x m] returns the current binding of [x] in [m], 
-	or raises [Not_found] if no such binding exists.
-	NB: in Coq, the exception mechanism becomes a option type. *)
-
-    Parameter remove : key -> t elt -> t elt.
-    (** [remove x m] returns a map containing the same bindings as [m], 
-	except for [x] which is unbound in the returned map. *)
-
-    Parameter mem : key -> t elt -> bool.
-    (** [mem x m] returns [true] if [m] contains a binding for [x], 
-	and [false] otherwise. *)
-
-    (** Coq comment: [iter] is useless in a purely functional world *)
-    (** val iter : (key -> 'a -> unit) -> 'a t -> unit *)
-    (** iter f m applies f to all bindings in map m. f receives the key as 
-	first argument, and the associated value as second argument. 
-	The bindings are passed to f in increasing order with respect to the 
-	ordering over the type of the keys. Only current bindings are 
-	presented to f: bindings hidden by more recent bindings are not 
-	passed to f. *)
-
-    Variable elt' : Set. 
-    Variable elt'': Set.
-
-    Parameter map : (elt -> elt') -> t elt -> t elt'.
-    (** [map f m] returns a map with same domain as [m], where the associated 
-	value a of all bindings of [m] has been replaced by the result of the
-	application of [f] to [a]. The bindings are passed to [f] in 
-	increasing order with respect to the ordering over the type of the 
-	keys. *)
-
-    Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'.
-    (** Same as [S.map], but the function receives as arguments both the 
-	key and the associated value for each binding of the map. *)
-
-    Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' ->  t elt''.
-    (** Not present in Ocaml. 
-         [map f m m'] creates a new map whose bindings belong to the ones of either 
-         [m] or [m']. The presence and value for a key [k] is determined by [f e e'] 
-         where [e] and [e'] are the (optional) bindings of [k] in [m] and [m']. *)
-
-    Parameter elements : t elt -> list (key*elt).
-    (** Not present in Ocaml. 
-         [elements m] returns an assoc list corresponding to the bindings of [m].
-         Elements of this list are sorted with respect to their first components. 
-         Useful to specify [fold] ... *)
-
-    Parameter fold : forall A: Set, (key -> elt -> A -> A) -> t elt -> A -> A.
-    (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], 
-	where [k1] ... [kN] are the keys of all bindings in [m] 
-	(in increasing order), and [d1] ... [dN] are the associated data. *)
-
-    Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool.
-    (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, 
-      that is, contain equal keys and associate them with equal data. 
-      [cmp] is the equality predicate used to compare the data associated 
-      with the keys. *)
-
-    Section Spec. 
-      
-      Variable m m' m'' : t elt.
-      Variable x y z : key.
-      Variable e e' : elt.
-
-      Parameter MapsTo : key -> elt -> t elt -> Prop.
-
-      Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m.
-
-      Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
-
-      Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p').
-      
-      Definition eq_key_elt (p p':key*elt) := 
-          E.eq (fst p) (fst p') /\ (snd p) = (snd p').
-
-    (** Specification of [MapsTo] *)
-      Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
-      
-    (** Specification of [mem] *)
-      Parameter mem_1 : In x m -> mem x m = true.
-      Parameter mem_2 : mem x m = true -> In x m. 
-      
-    (** Specification of [empty] *)
-      Parameter empty_1 : Empty empty.
-
-    (** Specification of [is_empty] *)
-      Parameter is_empty_1 : Empty m -> is_empty m = true. 
-      Parameter is_empty_2 : is_empty m = true -> Empty m.
-      
-    (** Specification of [add] *)
-      Parameter add_1 : E.eq x y -> MapsTo y e (add x e m).
-      Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
-      Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
-
-    (** Specification of [remove] *)
-      Parameter remove_1 : E.eq x y -> ~ In y (remove x m).
-      Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
-      Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
-
-    (** Specification of [find] *)
-      Parameter find_1 : MapsTo x e m -> find x m = Some e. 
-      Parameter find_2 : find x m = Some e -> MapsTo x e m.
-
-    (** Specification of [elements] *)
-      Parameter elements_1 : 
-        MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
-      Parameter elements_2 : 
-        InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
-      Parameter elements_3 : NoDupA eq_key (elements m).  
-
-    (** Specification of [fold] *)  
-      Parameter fold_1 :
-	forall (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.
- 
-   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).  
-
-   Variable cmp : elt -> elt -> bool. 
-
-   (** Specification of [equal] *)
-     Parameter equal_1 : Equal cmp m m' -> equal cmp m m' = true. 
-     Parameter equal_2 : equal cmp m m' = true -> Equal cmp m m'.
-
-    End Spec. 
-   End Types. 
-
-    (** Specification of [map] *)
-      Parameter 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).
-      Parameter map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
-        In x (map f m) -> In x m.
- 
-    (** Specification of [mapi] *)
-      Parameter 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).
-      Parameter mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
-        (f:key->elt->elt'), In x (mapi f m) -> In x m.
-
-    (** Specification of [map2] *)
-      Parameter 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').       
-
-     Parameter 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'.
-
-  Hint Immediate MapsTo_1 mem_2 is_empty_2.
-  
-  Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 add_3 remove_1
-    remove_2 remove_3 find_1 find_2 fold_1 map_1 map_2 mapi_1 mapi_2. 
-
-End S.
diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v
index 890485a8..be09e41a 100644
--- a/theories/FSets/FMapWeakList.v
+++ b/theories/FSets/FMapWeakList.v
@@ -6,39 +6,28 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMapWeakList.v 8985 2006-06-23 16:12:45Z jforest $ *)
+(* $Id: FMapWeakList.v 10616 2008-03-04 17:33:35Z letouzey $ *)
 
 (** * Finite map library *)  
 
 (** This file proposes an implementation of the non-dependant interface
- [FMapInterface.S] using lists of pairs,  unordered but without redundancy. *)
+ [FMapInterface.WS] using lists of pairs, unordered but without redundancy. *)
 
-Require Import FSetInterface. 
-Require Import FSetWeakInterface.
-Require Import FMapWeakInterface.
+Require Import FMapInterface.
 
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-Arguments Scope list [type_scope].
-
 Module Raw (X:DecidableType).
 
-Module PX := KeyDecidableType X.
-Import PX.
+Module Import PX := KeyDecidableType X.
 
 Definition key := X.t.
-Definition t (elt:Set) := list (X.t * elt).
+Definition t (elt:Type) := list (X.t * elt).
 
 Section Elt.
 
-Variable elt : Set.
-
-(* 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').
-*)
+Variable elt : Type.
 
 Notation eqk := (eqk (elt:=elt)).   
 Notation eqke := (eqke (elt:=elt)).
@@ -221,10 +210,10 @@ Proof.
  destruct a as (x',e').
  simpl; case (X.eq_dec x x'); inversion_clear Hm; auto.
  constructor; auto.
- swap H.
+ contradict H.
  apply InA_eqk with (x,e); auto.
  constructor; auto.
- swap H; apply add_3' with x e; auto.
+ contradict H; apply add_3' with x e; auto.
 Qed.
 
 (* Not part of the exported specifications, used later for [combine]. *)
@@ -272,8 +261,8 @@ Proof.
 
  inversion_clear Hm.
  subst.
- swap H0.
- destruct H2 as (e,H2); unfold PX.MapsTo in H2.
+ contradict H0.
+ destruct H0 as (e,H2); unfold PX.MapsTo in H2.
  apply InA_eqk with (y,e); auto.
  compute; apply X.eq_trans with x; auto.
   
@@ -323,7 +312,7 @@ Proof.
  destruct a as (x',e').
  simpl; case (X.eq_dec x x'); auto.
  constructor; auto.
- swap H; apply remove_3' with x; auto.
+ contradict H; apply remove_3' with x; auto.
 Qed.  
 
 (** * [elements] *)
@@ -340,20 +329,20 @@ Proof.
 auto.
 Qed.
 
-Lemma elements_3 : forall m (Hm:NoDupA m), NoDupA (elements m). 
+Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). 
 Proof. 
  auto.
 Qed.
 
 (** * [fold] *)
 
-Function fold (A:Set)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} :  A :=
+Function fold (A:Type)(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)
   end.
 
-Lemma fold_1 : forall m (A:Set)(i:A)(f:key->elt->A->A),
+Lemma fold_1 : forall m (A:Type)(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.
@@ -377,7 +366,7 @@ Definition Submap 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).  
 
-Definition Equal cmp m m' := 
+Definition Equivb 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).  
 
@@ -444,17 +433,17 @@ Qed.
 (** Specification of [equal] *)
 
 Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, 
-  Equal cmp m m' -> equal cmp m m' = true. 
+  Equivb cmp m m' -> equal cmp m m' = true. 
 Proof. 
- unfold Equal, equal.
+ unfold Equivb, equal.
  intuition.
  apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder.
 Qed.
 
 Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, 
-  equal cmp m m' = true -> Equal cmp m m'.
+  equal cmp m m' = true -> Equivb cmp m m'.
 Proof.
- unfold Equal, equal.
+ unfold Equivb, equal.
  intros.
  destruct (andb_prop _ _ H); clear H.
  generalize (submap_2 Hm Hm' H0).
@@ -462,7 +451,7 @@ Proof.
  firstorder.
 Qed. 
 
-Variable elt':Set.
+Variable elt':Type.
 
 (** * [map] and [mapi] *)
   
@@ -483,7 +472,7 @@ Section Elt2.
 (* A new section is necessary for previous definitions to work 
    with different [elt], especially [MapsTo]... *)
   
-Variable elt elt' : Set.
+Variable elt elt' : Type.
 
 (** Specification of [map] *)
 
@@ -533,12 +522,12 @@ Proof.
  destruct a as (x',e').
  inversion_clear Hm.
  constructor; auto.
- swap H.
+ contradict H.
  (* il faut un map_1 avec eqk au lieu de eqke *)
  clear IHm H0. 
  induction m; simpl in *; auto.
- inversion H1.
- destruct a; inversion H1; auto.
+ inversion H.
+ destruct a; inversion H; auto.
 Qed.      
  
 (** Specification of [mapi] *)
@@ -593,17 +582,17 @@ Proof.
  destruct a as (x',e').
  inversion_clear Hm; auto.
  constructor; auto.
- swap H.
+ contradict H.
  clear IHm H0.
  induction m; simpl in *; auto.
- inversion_clear H1.
- destruct a; inversion_clear H1; auto.
+ inversion_clear H.
+ destruct a; inversion_clear H; auto.
 Qed.
 
 End Elt2. 
 Section Elt3.
 
-Variable elt elt' elt'' : Set.
+Variable elt elt' elt'' : Type.
 
 Notation oee' := (option elt * option elt')%type.
 	
@@ -613,7 +602,7 @@ Definition combine_l (m:t elt)(m':t elt') : t oee' :=
 Definition combine_r (m:t elt)(m':t elt') : t oee' :=
   mapi (fun k e' => (find k m, Some e')) m'.	
 
-Definition fold_right_pair (A B C:Set)(f:A->B->C->C)(l:list (A*B))(i:C) := 
+Definition fold_right_pair (A B C:Type)(f:A->B->C->C)(l:list (A*B))(i:C) := 
   List.fold_right (fun p => f (fst p) (snd p)) i l.
 
 Definition combine (m:t elt)(m':t elt') : t oee' := 
@@ -737,7 +726,7 @@ Qed.
 
 Variable f : option elt -> option elt' -> option elt''.
 
-Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := 
+Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := 
   match o with
    | Some e => (k,e)::l
    | None => l
@@ -765,13 +754,13 @@ Proof.
  inversion_clear H1.
  destruct a; destruct o; simpl; auto.
  constructor; auto.
- swap H.
+ contradict H.
  clear IHl1.
  induction l1.
- inversion H1.
+ inversion H.
  inversion_clear H0.
  destruct a; destruct o; simpl in *; auto.
- inversion_clear  H1; auto.
+ inversion_clear H; auto.
 Qed.
 
 Definition at_least_one_then_f (o:option elt)(o':option elt') := 
@@ -807,7 +796,7 @@ Proof.
  rewrite H2.
  unfold f'; simpl.
  destruct (f oo oo'); simpl. 
- destruct (X.eq_dec x k); try absurd_hyp n; auto.
+ destruct (X.eq_dec x k); try contradict n; auto.
  destruct (IHm0 H1) as (_,H4); apply H4; auto.
  case_eq (find x m0); intros; auto.
  elim H0.
@@ -817,7 +806,7 @@ Proof.
  (* k < x *)
  unfold f'; simpl.
  destruct (f oo oo'); simpl.
- destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto].
+ destruct (X.eq_dec x k); [ contradict n; auto | auto].
  destruct (IHm0 H1) as (H3,_); apply H3; auto.
  destruct (IHm0 H1) as (H3,_); apply H3; auto.
 
@@ -831,7 +820,7 @@ Proof.
  (* k < x *)
  unfold f'; simpl.
  destruct (f oo oo'); simpl.
- destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto].
+ destruct (X.eq_dec x k); [ contradict n; auto | auto].
  destruct (IHm0 H1) as (_,H4); apply H4; auto.
  destruct (IHm0 H1) as (_,H4); apply H4; auto.
 Qed.
@@ -873,18 +862,18 @@ End Elt3.
 End Raw.
 
 
-Module Make (X: DecidableType) <: S with Module E:=X.
+Module Make (X: DecidableType) <: WS with Module E:=X.
  Module Raw := Raw X. 
 
  Module E := X.
  Definition key := E.t. 
 
- Record slist (elt:Set) : Set :=  
+ Record slist (elt:Type) :=  
   {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}.
- Definition t (elt:Set) := slist elt. 
+ Definition t (elt:Type) := slist elt. 
 
 Section Elt. 
- Variable elt elt' elt'':Set. 
+ Variable elt elt' elt'':Type. 
 
  Implicit Types m : t elt.
  Implicit Types x y : key. 
@@ -901,13 +890,18 @@ Section Elt.
  Definition map2 f m (m':t elt') : t elt'' := 
    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 cardinal m := length m.(this).
+ Definition fold (A:Type)(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 Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' := 
+         (forall k, In k m <-> In k m') /\ 
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').  
+ Definition Equivb cmp m m' : Prop := @Raw.Equivb 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.
@@ -951,36 +945,39 @@ Section Elt.
  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 elements_3w : forall m, NoDupA eq_key (elements m).  
+ Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(NoDup)). Qed.
+ 
+ Lemma cardinal_1 : forall m, cardinal m = length (elements m). 
+ Proof. intros; reflexivity. Qed.
 
- Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A),
+ Lemma fold_1 : forall m (A : Type) (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. 
+ Lemma equal_1 : forall m m' cmp, Equivb 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'.
+ Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'.
  Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed.
 
  End Elt.
  
- Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+ Lemma map_1 : forall (elt elt':Type)(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'), 
+ Lemma map_2 : forall (elt elt':Type)(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)
+ Lemma mapi_1 : forall (elt elt':Type)(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)
+ Lemma mapi_2 : forall (elt elt':Type)(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')
+ Lemma map2_1 : forall (elt elt' elt'':Type)(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').       
@@ -988,7 +985,7 @@ Section Elt.
  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')
+ Lemma map2_2 : forall (elt elt' elt'':Type)(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. 
diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v
index 72ccad3f..75904202 100644
--- a/theories/FSets/FMaps.v
+++ b/theories/FSets/FMaps.v
@@ -6,13 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FMaps.v 8844 2006-05-22 17:22:36Z letouzey $ *)
+(* $Id: FMaps.v 10699 2008-03-19 20:56:43Z letouzey $ *)
 
-Require Export OrderedType.
-Require Export OrderedTypeEx.
-Require Export OrderedTypeAlt.
+
+Require Export OrderedType OrderedTypeEx OrderedTypeAlt.
+Require Export DecidableType DecidableTypeEx.
 Require Export FMapInterface.
-Require Export FMapList.
 Require Export FMapPositive.
-Require Export FMapIntMap.
-Require Export FMapFacts.
\ No newline at end of file
+Require Export FMapFacts.
+Require Export FMapWeakList.
+Require Export FMapList.
diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v
index d5ce54d9..faa705f6 100644
--- a/theories/FSets/FSetAVL.v
+++ b/theories/FSets/FSetAVL.v
@@ -1,4 +1,3 @@
-
 (***********************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
 (* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
@@ -12,41 +11,555 @@
  * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
  *              91405 Orsay, France *)
 
-(* $Id: FSetAVL.v 9862 2007-05-25 16:57:06Z letouzey $ *)
+(* $Id: FSetAVL.v 10811 2008-04-17 16:29:49Z letouzey $ *)
+
+(** * FSetAVL *)
 
 (** This module implements sets using AVL trees.
-    It follows the implementation from Ocaml's standard library. *)
+    It follows the implementation from Ocaml's standard library,
+    
+    All operations given here expect and produce well-balanced trees
+    (in the ocaml sense: heigths of subtrees shouldn't differ by more
+    than 2), and hence has low complexities (e.g. add is logarithmic
+    in the size of the set). But proving these balancing preservations
+    is in fact not necessary for ensuring correct operational behavior
+    and hence fulfilling the FSet interface. As a consequence,
+    balancing results are not part of this file anymore, they can 
+    now be found in [FSetFullAVL].
+
+    Four operations ([union], [subset], [compare] and [equal]) have
+    been slightly adapted in order to have only structural recursive
+    calls. The precise ocaml versions of these operations have also
+    been formalized (thanks to Function+measure), see [ocaml_union],
+    [ocaml_subset], [ocaml_compare] and [ocaml_equal] in
+    [FSetFullAVL]. The structural variants compute faster in Coq,
+    whereas the other variants produce nicer and/or (slightly) faster
+    code after extraction.
+*)
 
-Require Import FSetInterface.
-Require Import FSetList.
-Require Import ZArith.
-Require Import Int.
+Require Import FSetInterface FSetList ZArith 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 Local Scope Int_scope.
+(** Notations and helper lemma about pairs *)
+
+Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
+Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
 
-Module E := X.
-Module MX := OrderedTypeFacts X.
+(** * Raw 
+   
+   Functor of pure functions + a posteriori proofs of invariant 
+   preservation *)
+
+Module Raw (Import I:Int)(X:OrderedType).
+Open Local Scope pair_scope.
+Open Local Scope lazy_bool_scope.
+Open Local Scope Int_scope.
 
 Definition elt := X.t.
 
-(** * Trees *)
+(** * Trees
 
-Inductive tree : Set :=
+   The fourth field of [Node] is the height of the tree *)
+
+Inductive tree :=
   | Leaf : tree
   | Node : tree -> X.t -> tree -> int -> tree.
 
 Notation t := tree.
 
-(** The fourth field of [Node] is the height of the tree *)
+(** * Basic functions on trees: height and cardinal *)
+
+Definition height (s : tree) : int :=
+  match s with
+  | Leaf => 0
+  | Node _ _ _ h => h
+  end.
+
+Fixpoint cardinal (s : tree) : nat :=
+  match s with
+   | Leaf => 0%nat
+   | Node l _ r _ => S (cardinal l + cardinal r)
+  end.
+
+(** * Empty Set *)
+
+Definition empty := Leaf.
+
+(** * Emptyness test *)
+
+Definition is_empty s := 
+  match s with Leaf => true | _ => false end.
+
+(** * Appartness *)
+
+(** The [mem] function is deciding appartness. It exploits the 
+    binary search tree invariant to achieve logarithmic complexity. *)
+
+Fixpoint mem x s := 
+   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.
+
+(** * Singleton set *)
+
+Definition singleton x := Node Leaf x Leaf 1.
+
+(** * 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).
+
+(** [bal l x r] acts as [create], but performs one step of
+    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
+
+Definition assert_false := create.
+
+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 l x r
+     | 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 l x r
+          | 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 l x r
+       | 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 l x r
+            | Node rll rlx rlr _ => 
+                create (create l x rll) rlx (create rlr rx rr) 
+           end
+      end
+    else 
+      create l x r.
+
+(** * Insertion *)
+
+Fixpoint add x s := 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.
+
+(** * Join
+
+    Same as [bal] but does not assume anything regarding heights 
+    of [l] and [r]. 
+*)
+
+Fixpoint join l : 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.
+
+(** * 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]).
+*)
+ 
+Fixpoint remove_min l x r : t*elt := 
+  match l with 
+    | Leaf => (r,x)
+    | Node ll lx lr lh => 
+       let (l',m) := remove_min ll lx lr in (bal l' x r, m)
+  end.
+
+(** * 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].
+*)
+
+Definition merge s1 s2 :=  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.
+
+(** * Deletion *)
+
+Fixpoint remove x s := 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.
+
+(** * Minimum element *)
+
+Fixpoint min_elt s := match s with 
+   | Leaf => None
+   | Node Leaf y _  _ => Some y
+   | Node l _ _ _ => min_elt l
+end.
+
+(** * Maximum element *)
+
+Fixpoint max_elt s := match s with 
+   | Leaf => None
+   | Node _ y Leaf  _ => Some y
+   | Node _ _ r _ => max_elt r
+end.
+
+(** * Any element *)
+
+Definition choose := min_elt.
+
+(** * Concatenation
+
+    Same as [merge] but does not assume anything about heights.
+*)
+
+Definition concat s1 s2 := 
+   match s1, s2 with 
+      | Leaf, _ => s2 
+      | _, Leaf => s1
+      | _, Node l2 x2 r2 _ => 
+            let (s2',m) := remove_min l2 x2 r2 in 
+            join s1 m s2'
+   end.
+
+(** * 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].
+*)
+
+Record triple := mktriple { t_left:t; t_in:bool; t_right:t }.
+Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).
+Notation "t #l" := (t_left t) (at level 9, format "t '#l'").
+Notation "t #b" := (t_in t) (at level 9, format "t '#b'").
+Notation "t #r" := (t_right t) (at level 9, format "t '#r'").
+
+Fixpoint split x s : triple := match s with
+  | Leaf => << Leaf, false, Leaf >>
+  | Node l y r h => 
+     match X.compare x y with 
+      | LT _ => let (ll,b,rl) := split x l in << ll, b, join rl y r >>
+      | EQ _ => << l, true, r >>
+      | GT _ => let (rl,b,rr) := split x r in << join l y rl, b, rr >>
+     end
+ end.
+
+(** * Intersection *)
+
+Fixpoint inter s1 s2 := match s1, s2 with 
+    | Leaf, _ => Leaf
+    | _, Leaf => Leaf
+    | Node l1 x1 r1 h1, _ => 
+            let (l2',pres,r2') := split x1 s2 in 
+            if pres then join (inter l1 l2') x1 (inter r1 r2')
+            else concat (inter l1 l2') (inter r1 r2')
+    end.
+
+(** * Difference *)
+
+Fixpoint diff s1 s2 := match s1, s2 with 
+ | Leaf, _ => Leaf
+ | _, Leaf => s1
+ | Node l1 x1 r1 h1, _ => 
+    let (l2',pres,r2') := split x1 s2 in 
+    if pres then concat (diff l1 l2') (diff r1 r2')
+    else join (diff l1 l2') x1 (diff r1 r2')
+end.
+
+(** * Union *)
+
+(** In ocaml, heights of [s1] and [s2] are compared each time in order
+   to recursively perform the split on the smaller set.
+   Unfortunately, this leads to a non-structural algorithm. The
+   following code is a simplification of the ocaml version: no
+   comparison of heights. It might be slightly slower, but
+   experimentally all the tests I've made in ocaml have shown this
+   potential slowdown to be non-significant. Anyway, the exact code
+   of ocaml has also been formalized thanks to Function+measure, see
+   [ocaml_union] in [FSetFullAVL].  
+*)
+
+Fixpoint union s1 s2 := 
+ match s1, s2 with 
+  | Leaf, _ => s2
+  | _, Leaf => s1
+  | Node l1 x1 r1 h1, _ => 
+     let (l2',_,r2') := split x1 s2 in 
+     join (union l1 l2') x1 (union r1 r2')
+ end.
+
+(** * 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) : 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.
+
+(** * Filter *)
+
+Fixpoint filter_acc (f:elt->bool) acc s := match s with 
+  | Leaf => acc
+  | Node l x r h => 
+     filter_acc f (filter_acc f (if f x then add x acc else acc) l) r 
+ end.
+
+Definition filter f := filter_acc f Leaf.
+
+
+(** * Partition *)
+
+Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t := 
+  match s with 
+   | Leaf => acc
+   | Node l x r _ => 
+      let (acct,accf) := acc in 
+      partition_acc f
+        (partition_acc f
+           (if f x then (add x acct, accf) else (acct, add x accf)) l) r
+  end.
+
+Definition partition f := partition_acc f (Leaf,Leaf).
+
+(** * [for_all] and [exists] *)
+
+Fixpoint for_all (f:elt->bool) s := match s with 
+  | Leaf => true
+  | Node l x r _ => f x &&& for_all f l &&& for_all f r
+end.
+
+Fixpoint exists_ (f:elt->bool) s := match s with 
+  | Leaf => false
+  | Node l x r _ => f x ||| exists_ f l ||| exists_ f r
+end.
+
+(** * Fold *)
+
+Fixpoint fold (A : Type) (f : elt -> A -> A)(s : tree) : A -> A := 
+ fun a => match s with
+  | Leaf => a
+  | Node l x r _ => fold f r (f x (fold f l a))
+ end.
+Implicit Arguments fold [A].
+
+
+(** * Subset *)
+
+(** In ocaml, recursive calls are made on "half-trees" such as 
+   (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these
+   non-structural calls, we propose here two specialized functions for
+   these situations. This version should be almost as efficient as 
+   the one of ocaml (closures as arguments may slow things a bit),  
+   it is simply less compact. The exact ocaml version has also been
+   formalized (thanks to Function+measure), see [ocaml_subset] in 
+   [FSetFullAVL].
+ *)
+
+Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool := 
+ match s2 with 
+  | Leaf => false
+  | Node l2 x2 r2 h2 => 
+     match X.compare x1 x2 with 
+      | EQ _ => subset_l1 l2 
+      | LT _ => subsetl subset_l1 x1 l2
+      | GT _ => mem x1 r2 &&& subset_l1 s2
+     end
+ end.
+
+Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool := 
+ match s2 with 
+  | Leaf => false
+  | Node l2 x2 r2 h2 => 
+     match X.compare x1 x2 with 
+      | EQ _ => subset_r1 r2 
+      | LT _ => mem x1 l2 &&& subset_r1 s2
+      | GT _ => subsetr subset_r1 x1 r2
+     end
+ end.
+
+Fixpoint subset s1 s2 : bool := match s1, s2 with 
+  | Leaf, _ => true
+  | Node _ _ _ _, Leaf => false
+  | Node l1 x1 r1 h1, Node l2 x2 r2 h2 => 
+     match X.compare x1 x2 with 
+      | EQ _ => subset l1 l2 &&& subset r1 r2
+      | LT _ => subsetl (subset l1) x1 l2 &&& subset r1 s2
+      | GT _ => subsetr (subset r1) x1 r2 &&& subset l1 s2
+     end
+ end.
+
+(** * A new comparison algorithm suggested by Xavier Leroy
+
+    Transformation in C.P.S. suggested by Benjamin Grégoire.
+    The original ocaml code (with non-structural recursive calls)
+    has also been formalized (thanks to Function+measure), see
+    [ocaml_compare] in [FSetFullAVL]. The following code with 
+    continuations computes dramatically faster in Coq, and 
+    should be almost as efficient after extraction.
+*)
+
+(** Enumeration of the elements of a tree *)
+
+Inductive enumeration :=
+ | End : enumeration
+ | More : elt -> tree -> enumeration -> enumeration.
+
+
+(** [cons t e] adds the elements of tree [t] on the head of 
+    enumeration [e]. *)
+
+Fixpoint cons s e : enumeration := 
+ match s with 
+  | Leaf => e
+  | Node l x r h => cons l (More x r e)
+ end.
+
+(** One step of comparison of elements *)
+
+Definition compare_more x1 (cont:enumeration->comparison) e2 :=
+ match e2 with
+ | End => Gt
+ | More x2 r2 e2 =>
+     match X.compare x1 x2 with
+      | EQ _ => cont (cons r2 e2)
+      | LT _ => Lt
+      | GT _ => Gt
+     end
+ end.
+
+(** Comparison of left tree, middle element, then right tree *)
+
+Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := 
+ match s1 with
+  | Leaf => cont e2
+  | Node l1 x1 r1 _ =>
+     compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2
+  end.
+
+(** Initial continuation *)
+
+Definition compare_end e2 := 
+ match e2 with End => Eq | _ => Lt end.
+
+(** The complete comparison *)
+
+Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End).
+
+(** * Equality test *)
+
+Definition equal s1 s2 : bool := 
+ match compare s1 s2 with 
+  | Eq => true
+  | _ => false 
+ end.
+
+
+
+
+(** * Invariants *)
+
+(** ** Occurrence in a tree *)
+
+Inductive In (x : elt) : tree -> Prop :=
+  | IsRoot : forall l r h y, X.eq x y -> In x (Node l y r h)
+  | InLeft : forall l r h y, In x l -> In x (Node l y r h)
+  | InRight : forall l r h y, In x r -> In x (Node l y r h).
+
+(** ** 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, In y s -> X.lt y x.
+Definition gt_tree x s := forall y, 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 l r h, bst l -> bst r -> 
+     lt_tree x l -> gt_tree x r -> bst (Node l x r h).
+
+
+
+
+(** * 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.
+
+
+
+(** * Correctness proofs, isolated in a sub-module *)
+
+Module Proofs.
+ Module MX := OrderedTypeFacts X.
+ Module L := FSetList.Raw X.
+
+(** * Automation and dedicated tactics *)
+
+Hint Constructors In bst.
+Hint Unfold lt_tree gt_tree.
+
+Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h) 
+ "as" ident(s) :=  
+ set (s:=Node l x r h) in *; clearbody s; clear l x r h.
 
 (** 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
@@ -56,30 +569,18 @@ Ltac inv f :=
      | _ => idtac
   end.
 
-(** Same, but with a backup of the original hypothesis. *)
+Ltac intuition_in := repeat progress (intuition; inv In).
 
-Ltac safe_inv f := match goal with 
-  | H:f (Node _ _ _ _) |- _ => 
-        generalize H; inversion_clear H; safe_inv f
-  | _ => intros 
- end.
+(** Helper tactic concerning order of elements. *)
 
-(** * Occurrence in a tree *)
+Ltac order := match goal with 
+ | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order
+ | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order
+ | _ => MX.order
+end.
 
-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).
+(** * Basic results about [In], [lt_tree], [gt_tree], [height] *)
 
 (** [In] is compatible with [X.eq] *)
 
@@ -90,48 +591,37 @@ Proof.
 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.
+Lemma In_node_iff : 
+ forall l x r h y, 
+  In y (Node l x r h) <-> In y l \/ X.eq y x \/ In y r.
+Proof.
+ intuition_in.
+Qed.
 
 (** 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.
+ red; inversion 1.
 Qed.
 
 Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
 Proof.
-  unfold gt_tree in |- *; intros; inversion H.
+ red; inversion 1.
 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.
+ unfold lt_tree; 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.
+ unfold gt_tree; intuition_in; order.
 Qed.
 
 Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
@@ -145,7 +635,7 @@ 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.
+ eauto.
 Qed.
 
 Lemma gt_tree_not_in :
@@ -157,120 +647,43 @@ 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.
+ 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).
+(** * Inductions principles *)
 
-Hint Constructors bst.
+Functional Scheme mem_ind := Induction for mem Sort Prop.
+Functional Scheme bal_ind := Induction for bal Sort Prop. 
+Functional Scheme add_ind := Induction for add Sort Prop.
+Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
+Functional Scheme merge_ind := Induction for merge Sort Prop. 
+Functional Scheme remove_ind := Induction for remove Sort Prop.
+Functional Scheme min_elt_ind := Induction for min_elt Sort Prop.
+Functional Scheme max_elt_ind := Induction for max_elt Sort Prop.
+Functional Scheme concat_ind := Induction for concat Sort Prop.
+Functional Scheme split_ind := Induction for split Sort Prop.
+Functional Scheme inter_ind := Induction for inter Sort Prop.
+Functional Scheme diff_ind := Induction for diff Sort Prop.
+Functional Scheme union_ind := Induction for union Sort Prop.
 
-(** * 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 *)
+(** * Empty set *)
 
-Lemma height_non_negative : forall s : tree, avl s -> height s >= 0.
+Lemma empty_1 : Empty empty.
 Proof.
- induction s; simpl; intros; auto with zarith.
- inv avl; intuition; omega_max.
+ intro; intro.
+ inversion H.
 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.
@@ -282,54 +695,28 @@ 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.
+(** * Appartness *)
 
 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.
+Proof.
+ intros s x; functional induction mem x s; auto; intros; try clear e0; 
+  inv bst; intuition_in; order.
 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.
+ intros s x; functional induction mem x s; auto; intros; 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.
+(** * Singleton set *)
 
 Lemma singleton_1 : forall x y, In y (singleton x) -> X.eq x y. 
 Proof. 
- unfold singleton; inversion_clear 1; auto; inversion_clear H0.
+ unfold singleton; intros; inv In; order.
 Qed.
 
 Lemma singleton_2 : forall x y, X.eq x y -> In y (singleton x). 
@@ -337,35 +724,14 @@ 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).
+Lemma singleton_bst : forall x : elt, bst (singleton x).
 Proof.
- unfold create; auto.
+ unfold singleton; 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.
+
+(** * Helper functions *)
 
 Lemma create_in : 
  forall l x r y,  In y (create l x r) <-> X.eq y x \/ In y l \/ In y r.
@@ -373,196 +739,69 @@ 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).
+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.
- bal_tac; inv avl; repeat apply create_avl; simpl in *; auto; omega_max.
+ unfold create; auto.
 Qed.
+Hint Resolve create_bst.
 
-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.
+Lemma bal_in : forall l x r y, 
+ In y (bal l x r) <-> X.eq y x \/ In y l \/ In y r.
 Proof.
- bal_tac; inv avl; avl_nns; simpl in *; omega_max.
+ intros l x r; functional induction bal l x r; intros; try clear e0; 
+ rewrite !create_in; intuition_in.
 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.
+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.
- bal_tac; inv avl; simpl in *; omega_max.
+ intros l x r; functional induction bal l x r; intros;
+ 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.
 Qed.
+Hint Resolve bal_bst.
 
-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).
+Lemma add_in : forall s x y,
+ 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 H0); intuition_in.
- (* EQ *)  
- inv avl.
- intuition.
+ intros s x; functional induction (add x s); auto; intros; 
+ try rewrite bal_in, IHt; intuition_in.
  eapply In_1; eauto.
- (* GT *)
- inv avl.
- rewrite bal_in; auto.
- rewrite (IHt y0 H1); intuition_in.
 Qed.
 
-Lemma add_bst : forall s x, bst s -> avl s -> bst (add x s).
+Lemma add_bst : forall s x, bst s -> bst (add x s).
 Proof. 
- intros s x; functional induction (add x s); auto; intros.
- inv bst; inv avl; apply bal_bst; auto.
+ intros s x; functional induction (add x s); auto; intros; 
+ inv bst; apply bal_bst; auto.
  (* lt_tree -> lt_tree (add ...) *)
- red; red in H4.
+ red; red in H3.
  intros.
- rewrite (add_in l x y0 H) in H0.
+ rewrite add_in in H.
  intuition.
  eauto.
- inv bst; inv avl; apply bal_bst; auto.
+ inv bst; auto using bal_bst.
  (* gt_tree -> gt_tree (add ...) *)
- red; red in H4.
+ red; red in H3.
  intros.
- rewrite (add_in r x y0 H5) in H0.
+ rewrite add_in in H.
  intuition.
  apply MX.lt_eq with x; auto.
 Qed.
+Hint Resolve add_bst.
 
-(** * 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.
+(** * Join *)
+
+(* Function/Functional Scheme can't deal with internal fix. 
+   Let's do its job by hand: *)
 
 Ltac join_tac := 
  intro l; induction l as [| ll _ lx lr Hlr lh]; 
@@ -579,437 +818,200 @@ Ltac join_tac :=
            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).
+Lemma join_in : forall l x r y, 
+ 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.
-
+ rewrite bal_in, Hlr; clear Hlr Hrl; intuition_in.
+ rewrite bal_in, 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 -> 
+Lemma join_bst : forall l x r, bst l -> bst 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.
+ join_tac; auto; inv bst; apply bal_bst; auto; 
+ clear Hrl Hlr z; intro; intros; rewrite join_in in *.
+ intuition; [ apply MX.lt_eq with x | ]; eauto.
+ intuition; [ apply MX.eq_lt with x | ]; eauto.
 Qed.
+Hint Resolve join_bst.
 
-(** * 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 e0 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.
+(** * Extraction of minimum element *)
 
-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))).
+Lemma remove_min_in : forall l x r h y, 
+ In y (Node l x r h) <-> 
+  X.eq y (remove_min l x r)#2 \/ In y (remove_min l x r)#1.
 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 H0).
- rewrite e0; simpl; intros.
- rewrite bal_in; auto.
- rewrite e0 in IHp;generalize (IHp lh y H0).
- intuition.
- inversion_clear H7; intuition.
+ rewrite bal_in, In_node_iff, IHp, e0; simpl; 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)).
+ bst (Node l x r h) -> bst (remove_min l x r)#1.
 Proof.
- intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros.
+ intros l x r; functional induction (remove_min l x r); simpl; intros.
  inv bst; auto.
- inversion_clear H; inversion_clear H0.
- rewrite_all e0;simpl in *.
+ inversion_clear H.
+ specialize IHp with (1:=H0); rewrite e0 in IHp; auto.
  apply bal_bst; auto.
- firstorder.
- intro; intros.
- generalize (remove_min_in ll lx lr lh y H).
- rewrite e0; simpl.
- destruct 1.
- apply H3; intuition.
+ intro y; specialize (H2 y).
+ rewrite remove_min_in, e0 in H2; simpl in H2; 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)).
+ bst (Node l x r h) ->
+ gt_tree (remove_min l x r)#2 (remove_min l x r)#1.
 Proof.
- intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros.
+ intros l x r; functional induction (remove_min l x r); simpl; intros.
  inv bst; auto.
- inversion_clear H; inversion_clear H0.
- intro; intro.
- generalize (IHp lh H1 H); clear H6 H7 IHp.
- generalize (remove_min_avl ll lx lr lh H).
- generalize (remove_min_in ll lx lr lh m H).
- rewrite e0; simpl; intros.
- rewrite (bal_in l' x r y H7 H5) in H0.
- destruct H6.
- firstorder.
- apply MX.lt_eq with x; auto.
- apply X.lt_trans with x; auto.
+ inversion_clear H.
+ specialize IHp with (1:=H0); rewrite e0 in IHp; simpl in IHp.
+ intro y; rewrite bal_in; intuition; 
+  specialize (H2 m); rewrite remove_min_in, e0 in H2; simpl in H2; 
+  [ apply MX.lt_eq with x | ]; eauto.
 Qed.
+Hint Resolve remove_min_bst remove_min_gt_tree.
 
-(** * 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 y.
- generalize (remove_min_avl_1 l2 x2 r2 h2 H0).
- rewrite e1; 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.
+(** * Merging two trees *)
 
-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.
+Lemma merge_in : forall s1 s2 y,
+ In y (merge s1 s2) <-> In y s1 \/ In y s2.
+Proof.
+ intros s1 s2; functional induction (merge s1 s2); intros; 
+ try factornode _x _x0 _x1 _x2 as s1.
  intuition_in.
  intuition_in.
- destruct s1;try contradiction;clear y.
- replace s2' with (fst (remove_min l2 x2 r2)); [|rewrite e1; auto].
- rewrite bal_in; auto.
- generalize (remove_min_avl l2 x2 r2 h2); rewrite e1; simpl; auto.
- generalize (remove_min_in l2 x2 r2 h2 y0); rewrite e1; simpl; intro.
- rewrite H3 ; intuition.
+ rewrite bal_in, remove_min_in, e1; simpl; intuition.
 Qed.
 
-Lemma merge_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+Lemma merge_bst : forall s1 s2, bst s1 -> bst s2 -> 
  (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> 
- bst (merge s1 s2). 
+ bst (merge s1 s2).
 Proof.
- intros s1 s2; functional induction (merge s1 s2); subst;simpl in *; intros; auto.
- destruct s1;try contradiction;clear y.
+ intros s1 s2; functional induction (merge s1 s2); intros; auto; 
+ try factornode _x _x0 _x1 _x2 as s1.
  apply bal_bst; auto.
- generalize (remove_min_bst l2 x2 r2 h2); rewrite e1; simpl in *; auto.
- intro; intro.
- apply H3; auto.
- generalize (remove_min_in l2 x2 r2 h2 m); rewrite e1; simpl; intuition.
- generalize (remove_min_gt_tree l2 x2 r2 h2); rewrite e1; simpl; auto.
-Qed. 
+ change s2' with ((s2',m)#1); rewrite <-e1; eauto.
+ intros y Hy.
+ apply H1; auto.
+ rewrite remove_min_in, e1; simpl; auto.
+ change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
+Qed.
+Hint Resolve merge_bst.
 
-(** * 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 H0).
- split. 
- apply bal_avl; auto.
- omega_max.
- omega_bal.
- (* EQ *)
- inv avl. 
- generalize (merge_avl_1 l r H0 H1 H2).
- intuition omega_max.
- (* GT *)
- inv avl.
- destruct (IHt H1).
- 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.
+(** * Deletion *)
 
-Lemma remove_in : forall s x y, bst s -> avl s -> 
+Lemma remove_in : forall s x y, bst 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.
+ intros s x; functional induction (remove x s); intros; inv bst.
  intuition_in.
- (* LT *)
- inv avl; inv bst; clear e0.
- rewrite bal_in; auto.
- generalize (IHt y0 H0); intuition; [ order | order | intuition_in ].
- (* EQ *)
- inv avl; inv bst; clear e0.
- rewrite merge_in; intuition; [ order | order | intuition_in ].
- elim H9; eauto.
- (* GT *)
- inv avl; inv bst; clear e0.
- rewrite bal_in; auto.
- generalize (IHt y0 H5); intuition; [ order | order | intuition_in ].
+ rewrite bal_in, IHt; clear e0 IHt; intuition; [order|order|intuition_in].
+ rewrite merge_in; clear e0; intuition; [order|order|intuition_in].
+ elim H4; eauto.
+ rewrite bal_in, IHt; clear e0 IHt; intuition; [order|order|intuition_in].
 Qed.
 
-Lemma remove_bst : forall s x, bst s -> avl s -> bst (remove x s).
+Lemma remove_bst : forall s x, bst s -> bst (remove x s).
 Proof. 
- intros s x; functional induction (remove x s); simpl; intros.
+ intros s x; functional induction (remove x s); intros; inv bst.
  auto.
  (* LT *)
- inv avl; inv bst.
  apply bal_bst; auto.
- intro; intro.
- rewrite (remove_in l x y0) in H; auto.
- destruct H; eauto.
+ intro z; rewrite remove_in; auto; destruct 1; eauto.
  (* EQ *)
- inv avl; inv bst.
- apply merge_bst; eauto.
+ eauto.
  (* GT *) 
- inv avl; inv bst.
  apply bal_bst; auto.
- intro; intro.
- rewrite (remove_in r x y0) in H; auto.
- destruct H; eauto.
+ intro z; rewrite remove_in; auto; destruct 1; eauto.
 Qed.
+Hint Resolve remove_bst.
 
- (** * 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.
+(** * Minimum element *)
 
 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.
+ intro s; functional induction (min_elt s); auto; inversion 1; auto.
 Qed.
 
-Lemma min_elt_2 : forall s x y, bst s -> 
+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.
+ intro s; functional induction (min_elt s); 
+ try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
  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 H2; auto).
+ assert (X.lt x y) by (apply H2; auto).
  inversion_clear 1; auto; order.
- assert (X.lt t _x) by auto.
+ assert (X.lt x1 y) by auto.
  inversion_clear 2; auto; 
-   (assert (~ X.lt t x) by auto); order.
+   (assert (~ X.lt x1 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.
+ intro s; functional induction (min_elt s).
+ red; red; inversion 2.
  inversion 1.
- destruct l;try contradiction. 
- clear y;intro H0.
- destruct (IHo H0 t);  auto.
+ intro H0.
+ destruct (IHo H0 _x2); 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.
+(** * Maximum element *)
 
 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.
+ intro s; functional induction (max_elt s); auto; inversion 1; 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.
+ intro s; functional induction (max_elt s);
+ try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
  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.
+ assert (X.lt y x1) by auto.
  inversion_clear 2; auto; 
-  (assert (~ X.lt x t) by auto); order.
+  (assert (~ X.lt x x1) 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.
+ intro s; functional induction (max_elt s).
  red; auto.
  inversion 1.
- destruct r;try contradiction.
- intros H0; destruct (IHo H0 t); auto.
+ intros H0; destruct (IHo H0 _x2); auto.
 Qed.
 
-(** * Any element *)
 
-Definition choose := min_elt.
+
+(** * Any element *)
 
 Lemma choose_1 : forall s x, choose s = Some x -> In x s.
 Proof. 
@@ -1021,353 +1023,215 @@ Proof.
  exact min_elt_3.
 Qed.
 
-(** * Concatenation
+Lemma choose_3 : forall s s', bst s -> bst s' -> 
+ forall x x', choose s = Some x -> choose s' = Some x' -> 
+  Equal s s' -> X.eq x x'.
+Proof.
+ unfold choose, Equal; intros s s' Hb Hb' x x' Hx Hx' H.
+ assert (~X.lt x x').
+  apply min_elt_2 with s'; auto.
+  rewrite <-H; auto using min_elt_1.
+ assert (~X.lt x' x).
+  apply min_elt_2 with s; auto.
+  rewrite H; auto using min_elt_1.
+ destruct (X.compare x x'); intuition.
+Qed.
 
-    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.
+(** * Concatenation *)
 
-Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2).
+Lemma concat_in : forall s1 s2 y, 
+ In y (concat s1 s2) <-> In y s1 \/ In y s2.
 Proof.
- intros s1 s2; functional induction (concat s1 s2); subst;auto.
- destruct s1;try contradiction;clear y.
- intros; apply join_avl; auto.
- generalize (remove_min_avl l2 x2 r2 h2 H0); rewrite e1; simpl; auto.
+ intros s1 s2; functional induction (concat s1 s2); intros;
+ try factornode _x _x0 _x1 _x2 as s1.
+ intuition_in.
+ intuition_in.
+ rewrite join_in, remove_min_in, e1; simpl; intuition.
 Qed.
  
-Lemma concat_bst :   forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+Lemma concat_bst : forall s1 s2, bst s1 -> bst 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 y. 
- intros;  apply join_bst; auto.
- generalize (remove_min_bst l2 x2 r2 h2 H1 H2); rewrite e1; simpl; auto.
- generalize (remove_min_avl l2 x2 r2 h2 H2); rewrite e1; simpl; auto.
- generalize (remove_min_in l2 x2 r2 h2 m H2); rewrite e1; simpl; auto.
- destruct 1; intuition.
- generalize (remove_min_gt_tree l2 x2 r2 h2 H1 H2); rewrite e1; 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 y;intuition.
- inversion_clear H5.
- destruct s1;try contradiction;clear y; intros. 
- rewrite (join_in  (Node s1_1 t s1_2 i) m s2' y H0).
- generalize (remove_min_avl l2 x2 r2 h2 H2); rewrite e1; simpl; auto.
- generalize (remove_min_in l2 x2 r2 h2 y H2); rewrite e1; simpl.
- intro EQ; rewrite EQ; intuition.
+ intros s1 s2; functional induction (concat s1 s2); intros; auto; 
+ try factornode _x _x0 _x1 _x2 as s1.
+ apply join_bst; auto.
+ change (bst (s2',m)#1); rewrite <-e1; eauto.
+ intros y Hy.
+ apply H1; auto.
+ rewrite remove_min_in, e1; simpl; auto.
+ change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
 Qed.
+Hint Resolve concat_bst.
 
-(** * 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].
-*)
+(** * Splitting *)
 
-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 e1 in IHp;simpl in IHp;inversion_clear 1; intuition.
- simpl; inversion_clear 1; auto.
- rewrite e1 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 e1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear  H7 H6.
- rewrite (IHp y0 H0 H4); clear IHp e0.
- intuition.
- inversion_clear H6; auto; order.
- (* EQ *)
- simpl in *; inversion_clear 1; inversion_clear 1; clear H6 H5 e0.
- intuition.
- order.
+Lemma split_in_1 : forall s x y, bst s -> 
+ (In y (split x s)#l <-> In y s /\ X.lt y x).
+Proof.
+ intros s x; functional induction (split x s); simpl; intros; 
+  inv bst; try clear e0.
+ intuition_in.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
  intuition_in; order.
- (* GT *)
- rewrite e1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
- rewrite join_in; auto.
- generalize (split_avl r x H5); rewrite e1; simpl; intuition.
- rewrite (IHp y0 H1 H5); clear e1.
- intuition; [ eauto | eauto | intuition_in ].
+ rewrite join_in.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
 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).
+Lemma split_in_2 : forall s x y, bst s -> 
+ (In y (split x s)#r <-> 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 e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
-  rewrite join_in; auto.
- generalize (split_avl l x H4); rewrite e1; simpl; intuition.
- rewrite (IHp y0 H0 H4); clear IHp e0.
- intuition; [ order | order | intuition_in ].
- (* EQ *)
- simpl in *; inversion_clear 1; inversion_clear 1; clear H6 H5 e0.
- intuition; [ order | intuition_in; order ]. 
- (* GT *)
- rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
- rewrite (IHp y0 H1 H5); clear IHp e0.
- intuition; intuition_in; order. 
+ intros s x; functional induction (split x s); subst; simpl; intros; 
+  inv bst; try clear e0.
+ intuition_in.
+ rewrite join_in.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
+ intuition_in; order.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
 Qed.
 
-Lemma split_in_3 : forall s x, bst s -> avl s -> 
- (fst (snd (split x s)) = true <-> In x s).
+Lemma split_in_3 : forall s x, bst s -> 
+ ((split x s)#b = true <-> In x s).
 Proof. 
- intros s x; functional induction (split x s);subst;simpl in *.
- intuition; try inversion_clear H1.
- (* LT *)
- rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
- rewrite IHp; auto.
- intuition_in; absurd (X.lt x y); eauto.
- (* EQ *)
- simpl in *; inversion_clear 1; inversion_clear 1; intuition.
- (* GT *)
- rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
- rewrite IHp; auto.
- intuition_in; absurd (X.lt y x); eauto.
+ intros s x; functional induction (split x s); subst; simpl; intros; 
+  inv bst; try clear e0.
+ intuition_in; try discriminate.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
+ intuition.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
 Qed.
 
-Lemma split_bst : forall s x, bst s -> avl s -> 
- bst (fst (split x s)) /\ bst (snd (snd (split x s))).
+Lemma split_bst : forall s x, bst s -> 
+ bst (split x s)#l /\ bst (split x s)#r.
 Proof. 
- intros s x; functional induction (split x s);subst;simpl in *.  
- intuition.
- (* LT *)
- rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1.
- intuition.
- apply join_bst; auto.
- generalize (split_avl l x H4); rewrite e1; simpl; intuition.
- intro; intro.
- generalize (split_in_2 l x y0 H0 H4); rewrite e1; simpl; intuition.
- (* EQ *)
- simpl in *; inversion_clear 1; inversion_clear 1; intuition.
- (* GT *)
- rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1.
- intuition.
- apply join_bst; auto.
- generalize (split_avl r x H5); rewrite e1; simpl; intuition.
- intro; intro.
- generalize (split_in_1 r x y0 H1 H5); rewrite e1; simpl; intuition.
+ intros s x; functional induction (split x s); subst; simpl; intros; 
+  inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition;
+  apply join_bst; auto.
+ intros y0.
+ generalize (split_in_2 x y0 H0); rewrite e1; simpl; intuition.
+ intros y0.
+ generalize (split_in_1 x y0 H1); rewrite e1; 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.
+(** * Intersection *)
 
-Lemma inter_bst_in : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+Lemma inter_bst_in : forall s1 s2, bst s1 -> bst 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.
+Proof.
+ intros s1 s2; functional induction inter s1 s2; intros B1 B2; 
+ [intuition_in|intuition_in | | ]; 
+ factornode _x0 _x1 _x2 _x3 as s2; 
+ generalize (split_bst x1 B2); 
+  rewrite e1; simpl; destruct 1; inv bst;
+ destruct IHt as (IHb1,IHi1); auto; 
+ destruct IHt0 as (IHb2,IHi2); auto;
+ generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1)
+  (split_in_3 x1 B2)(split_bst x1 B2);
+ rewrite e1; simpl; split; intros.
  (* 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 join_bst; auto; intro y; [rewrite IHi1|rewrite IHi2]; intuition. (* In join *)
+ rewrite join_in, IHi1, IHi2, H5, H6; 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.
+ (* bst concat *)
+ apply concat_bst; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
+ (* In concat *)
+ rewrite concat_in, IHi1, IHi2, H5, H6; auto.
+ assert (~In x1 s2) by (rewrite <- H7; auto).
  intuition_in.
- generalize (H26 (In_1 _ _ _ H22 H35)); intro; discriminate.
+ elim H9.
+ apply In_1 with y; auto.
 Qed.
 
-Lemma inter_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
- bst (inter s1 s2). 
+Lemma inter_in : forall s1 s2 y, bst s1 -> bst s2 -> 
+ (In y (inter s1 s2) <-> In y s1 /\ In y s2).
 Proof. 
- intros; generalize (inter_bst_in s1 s2); intuition.
+ intros s1 s2 y B1 B2; destruct (inter_bst_in B1 B2); auto.
 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).
+Lemma inter_bst : forall s1 s2, bst s1 -> bst s2 -> bst (inter s1 s2).
 Proof. 
- intros; generalize (inter_bst_in s1 s2); firstorder.
+ intros s1 s2 B1 B2; destruct (inter_bst_in B1 B2); auto.
 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.
+(** * Difference *)
 
-Lemma diff_bst_in : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+Lemma diff_bst_in : forall s1 s2, bst s1 -> bst 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.
+Proof.
+ intros s1 s2; functional induction diff s1 s2; intros B1 B2; 
+ [intuition_in|intuition_in | | ]; 
+ factornode _x0 _x1 _x2 _x3 as s2; 
+ generalize (split_bst x1 B2); 
+  rewrite e1; simpl; destruct 1; 
+ inv avl; inv bst; 
+ destruct IHt as (IHb1,IHi1); auto; 
+ destruct IHt0 as (IHb2,IHi2); auto; 
+ generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1)
+  (split_in_3 x1 B2)(split_bst x1 B2);
+ rewrite e1; simpl; split; intros.
  (* bst concat *)
- apply concat_bst; try apply diff_avl; auto.
- intros; generalize (H22 y1) (H24 y2); intuition eauto.
+ apply concat_bst; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
+ (* In concat *)
+ rewrite concat_in, IHi1, IHi2, H5, H6; intuition_in.
+ elim H13.
+ apply In_1 with x1; auto.
  (* 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.
+ apply join_bst; auto; intro y; [rewrite IHi1|rewrite IHi2]; intuition. (* In join *)
+ rewrite join_in, IHi1, IHi2, H5, H6; auto.
+ assert (~In x1 s2) by (rewrite <- H7; auto).
  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.
+ elim H9.
+ apply In_1 with y; auto.
 Qed.
 
-Lemma diff_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
- bst (diff s1 s2). 
+Lemma diff_in : forall s1 s2 y, bst s1 -> bst s2 -> 
+ (In y (diff s1 s2) <-> In y s1 /\ ~In y s2).
 Proof. 
- intros; generalize (diff_bst_in s1 s2); intuition.
+ intros s1 s2 y B1 B2; destruct (diff_bst_in B1 B2); auto.
 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).
+Lemma diff_bst : forall s1 s2, bst s1 -> bst s2 -> bst (diff s1 s2). 
 Proof. 
- intros; generalize (diff_bst_in s1 s2); firstorder.
+ intros s1 s2 B1 B2; destruct (diff_bst_in B1 B2); auto.
 Qed.
 
-(** * Elements *)
 
-(** [elements_tree_aux acc t] catenates the elements of [t] in infix
-    order to the list [acc] *)
+(** * Union *)
 
-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.
+Lemma union_in : forall s1 s2 y, bst s1 -> bst s2 -> 
+ (In y (union s1 s2) <-> In y s1 \/ In y s2).
+Proof.
+ intros s1 s2; functional induction union s1 s2; intros y B1 B2.
+ intuition_in.
+ intuition_in.
+ factornode _x0 _x1 _x2 _x3 as s2.
+ generalize (split_in_1 x1 y B2)(split_in_2 x1 y B2)(split_bst x1 B2).
+ rewrite e1; simpl.
+ destruct 3; inv bst.
+ rewrite join_in, IHt, IHt0, H, H0; auto.
+ case (X.compare y x1); intuition_in.
+Qed.
 
-(** then [elements] is an instanciation with an empty [acc] *)
+Lemma union_bst : forall s1 s2, bst s1 -> bst s2 -> 
+ bst (union s1 s2).
+Proof.
+ intros s1 s2; functional induction union s1 s2; intros B1 B2; auto.
+ factornode _x0 _x1 _x2 _x3 as s2.
+ generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1)(split_bst x1 B2).
+ rewrite e1; simpl; destruct 3.
+ inv bst.
+ apply join_bst; auto.
+ intro y; rewrite union_in, H; intuition_in.
+ intro y; rewrite union_in, H0; intuition_in.
+Qed.
 
-Definition elements := elements_aux nil.
+
+(** * Elements *)
 
 Lemma elements_aux_in : forall s acc x, 
  InA X.eq x (elements_aux acc s) <-> In x s \/ InA X.eq x acc.
@@ -1411,246 +1275,190 @@ Proof.
 Qed.
 Hint Resolve elements_sort.
 
-(** * Filter *)
-
-Section F.
-Variable f : elt -> bool.
+Lemma elements_nodup : forall s : tree, bst s -> NoDupA X.eq (elements s).
+Proof.
+ auto.
+Qed.
 
-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.
+Lemma elements_aux_cardinal :
+ 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.
 
-Definition filter := filter_acc Leaf. 
+Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s).
+Proof.
+ exact (fun s => elements_aux_cardinal s nil).
+Qed.
 
-Lemma filter_acc_avl : forall s acc, avl s -> avl acc -> 
- avl (filter_acc acc s).
+Lemma elements_app :
+ forall s acc, elements_aux acc s = elements s ++ acc.
 Proof.
- induction s; simpl; auto.
- intros.
- inv avl.
- apply IHs2; auto.
- apply IHs1; auto.
- destruct (f t); auto.
-Qed. 
-Hint Resolve filter_acc_avl.
+ induction s; simpl; intros; auto.
+ rewrite IHs1, IHs2.
+ unfold elements; simpl.
+ rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto.
+Qed.
 
-Lemma filter_acc_bst : forall s acc, bst s -> avl s -> bst acc -> avl acc -> 
- bst (filter_acc acc s).
+Lemma elements_node :
+ forall l x r h acc,
+ elements l ++ x :: elements r ++ acc =
+ elements (Node l x r h) ++ acc.
 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. 
+ unfold elements; simpl; intros; auto.
+ rewrite !elements_app, <- !app_nil_end, !app_ass; auto.
+Qed.
+
 
-Lemma filter_acc_in : forall s acc, avl s -> avl acc -> 
+(** * Filter *)
+
+Section F.
+Variable f : elt -> bool.
+
+Lemma filter_acc_in : forall s acc, 
  compat_bool X.eq f -> forall x : elt, 
- In x (filter_acc acc s) <-> In x acc \/ In x s /\ f x = true.
+ In x (filter_acc f 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.
+ rewrite IHs2, IHs1 by (destruct (f t); auto).
  case_eq (f t); intros.
  rewrite (add_in); auto.
  intuition_in.
- rewrite (H1 _ _ H8).
+ rewrite (H _ _ H2).
  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.
+ rewrite (H _ _ H2) in H3.
+ rewrite H0 in H3; discriminate.
 Qed.
 
-Lemma filter_bst : forall s, bst s -> avl s -> bst (filter s). 
+Lemma filter_acc_bst : forall s acc, bst s -> bst acc -> 
+ bst (filter_acc f acc s).
 Proof.
- unfold filter; intros; apply filter_acc_bst; auto.
+ induction s; simpl; auto.
+ intros.
+ inv bst.
+ destruct (f t); auto.
 Qed.
 
-Lemma filter_in : forall s, avl s -> 
+Lemma filter_in : forall s,
  compat_bool X.eq f -> forall x : elt, 
- In x (filter s) <-> In x s /\ f x = true.
+ In x (filter f 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).
+Qed.
 
-Lemma partition_acc_avl_1 : forall s acc, avl s -> 
- avl (fst acc) -> avl (fst (partition_acc acc s)).
+Lemma filter_bst : forall s, bst s -> bst (filter f 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. 
+ unfold filter; intros; apply filter_acc_bst; 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. 
+(** * Partition *)
 
-Lemma partition_acc_in_1 : forall s acc, avl s -> avl (fst acc) -> 
+Lemma partition_acc_in_1 : forall s 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.
+ In x (partition_acc f acc s)#1 <-> 
+ In x acc#1 \/ 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.
+ rewrite IHs2 by 
+  (destruct (f t); auto; apply partition_acc_avl_1; simpl; auto).
+ rewrite IHs1 by (destruct (f t); simpl; auto).
  case_eq (f t); simpl; intros.
  rewrite (add_in); auto.
  intuition_in.
- rewrite (H1 _ _ H8).
+ rewrite (H _ _ H2).
  intuition.
  intuition_in.
- rewrite (H1 _ _ H8) in H9.
- rewrite H in H9; discriminate.
-Qed. 
+ rewrite (H _ _ H2) in H3.
+ rewrite H0 in H3; discriminate.
+Qed.
 
-Lemma partition_acc_in_2 : forall s acc, avl s -> avl (snd acc) -> 
+Lemma partition_acc_in_2 : forall s 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.
+ In x (partition_acc f acc s)#2 <-> 
+ In x acc#2 \/ 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.
+ rewrite IHs2 by 
+  (destruct (f t); auto; apply partition_acc_avl_2; simpl; auto).
+ rewrite IHs1 by (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 (H _ _ H2) in H3.
+ rewrite H0 in H3; discriminate.
  rewrite (add_in); auto.
  intuition_in.
- rewrite (H1 _ _ H8).
+ rewrite (H _ _ H2).
  intuition.
+Qed.
+
+Lemma partition_in_1 : forall s, 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (partition f s)#1 <-> In x s /\ f x = true.
+Proof.
+ unfold partition; intros; rewrite partition_acc_in_1; 
+ simpl in *; intuition_in.
 Qed. 
 
-Lemma partition_avl_1 : forall s, avl s -> avl (fst (partition s)). 
+Lemma partition_in_2 : forall s,
+ compat_bool X.eq f -> forall x : elt, 
+ In x (partition f s)#2 <-> In x s /\ f x = false.
 Proof.
- unfold partition; intros; apply partition_acc_avl_1; auto.
+ unfold partition; intros; rewrite partition_acc_in_2; 
+ simpl in *; intuition_in.
+Qed. 
+
+Lemma partition_acc_bst_1 : forall s acc, bst s -> bst acc#1 -> 
+ bst (partition_acc f acc s)#1.
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros.
+ inv bst.
+ destruct (f t); auto.
+ apply IHs2; simpl; auto.
+ apply IHs1; simpl; auto.
 Qed.
 
-Lemma partition_avl_2 : forall s, avl s -> avl (snd (partition s)). 
+Lemma partition_acc_bst_2 : forall s acc, bst s -> bst acc#2 -> 
+ bst (partition_acc f acc s)#2.
 Proof.
- unfold partition; intros; apply partition_acc_avl_2; auto.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros.
+ inv bst.
+ destruct (f t); auto.
+ apply IHs2; simpl; auto.
+ apply IHs1; simpl; auto.
 Qed.
 
-Lemma partition_bst_1 : forall s, bst s -> avl s -> 
- bst (fst (partition s)). 
+Lemma partition_bst_1 : forall s, bst s -> bst (partition f s)#1. 
 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)). 
+Lemma partition_bst_2 : forall s, bst s -> bst (partition f s)#2. 
 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.
+(** * [for_all] and [exists] *)
 
-Lemma for_all_1 : forall s, compat_bool E.eq f ->
- For_all (fun x => f x = true) s -> for_all s = true.
+Lemma for_all_1 : forall s, compat_bool X.eq f ->
+ For_all (fun x => f x = true) s -> for_all f s = true.
 Proof.
  induction s; simpl; auto.
  intros.
@@ -1660,8 +1468,8 @@ Proof.
  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.
+Lemma for_all_2 : forall s, compat_bool X.eq f ->
+ for_all f 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.
@@ -1673,52 +1481,40 @@ Proof.
  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.
+Lemma exists_1 : forall s, compat_bool X.eq f ->
+ Exists (fun x => f x = true) s -> exists_ f s = true.
 Proof.
- induction s; simpl; destruct 2 as (x,(U,V)); inv In.
+ induction s; simpl; destruct 2 as (x,(U,V)); inv In; rewrite <- ?orb_lazy_alt.
  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.
+ apply orb_true_intro; right; apply IHs1; auto; exists x; auto.
+ apply orb_true_intro; right; apply IHs2; auto; exists x; auto.
 Qed.
 
-Lemma exists_2 : forall s, compat_bool E.eq f ->
- exists_ s = true -> Exists (fun x => f x = true) s.
+Lemma exists_2 : forall s, compat_bool X.eq f ->
+ exists_ f s = true -> Exists (fun x => f x = true) s.
 Proof. 
- induction s; simpl; intros.
+ induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *.
  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. 
+ destruct (IHs1 H H2); auto; exists x; intuition.
+ destruct (IHs2 H H1); auto; exists x; intuition.
+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].
+(** * Fold *)
 
-Definition fold' (A : Set) (f : elt -> A -> A)(s : tree) := 
+Definition fold' (A : Type) (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),
+ forall (A : Type) (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.
@@ -1730,7 +1526,7 @@ Proof.
 Qed.
 
 Lemma fold_equiv :
- forall (A : Set) (s : tree) (f : elt -> A -> A) (a : A),
+ forall (A : Type) (s : tree) (f : elt -> A -> A) (a : A),
  fold f s a = fold' f s a.
 Proof.
  unfold fold', elements in |- *. 
@@ -1741,7 +1537,7 @@ Proof.
 Qed.
 
 Lemma fold_1 : 
- forall (s:t)(Hs:bst s)(A : Set)(f : elt -> A -> A)(i : A),
+ forall (s:t)(Hs:bst s)(A : Type)(f : elt -> A -> A)(i : A),
  fold f s i = fold_left (fun a e => f e a) (elements s) i.
 Proof.
  intros.
@@ -1752,416 +1548,168 @@ Proof.
  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.
+(** * Subset *)
 
-Lemma cardinal_elements_aux_1 :
- forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
+Lemma subsetl_12 : forall subset_l1 l1 x1 h1 s2,
+ bst (Node l1 x1 Leaf h1) -> bst s2 ->
+ (forall s, bst s -> (subset_l1 s = true <-> Subset l1 s)) -> 
+ (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ).
 Proof.
- simple induction s; simpl in |- *; intuition.
- rewrite <- H.
- simpl in |- *.
- rewrite <- H0; omega.
-Qed.
+ induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
+ unfold Subset; intuition; try discriminate.
+ assert (H': In x1 Leaf) by auto; inversion H'.
+ inversion_clear H0.
+ specialize (IHl2 H H2 H1).
+ specialize (IHr2 H H3 H1).
+ inv bst. clear H8.
+ destruct X.compare.
+ 
+ rewrite IHl2; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
 
-Lemma cardinal_elements_1 : forall s : tree, cardinal s = length (elements s).
-Proof.
- exact (fun s => cardinal_elements_aux_1 s nil).
-Qed.
+ rewrite H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
 
-(** NB: the remaining functions (union, subset, compare) are still defined
-  in a dependent style, due to the use of well-founded induction. *)
+ rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (H':=mem_2 H6); apply In_1 with x1; auto.
+ apply mem_1; auto.
+ assert (In x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+Qed.
 
-(** 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.
+Lemma subsetr_12 : forall subset_r1 r1 x1 h1 s2,
+ bst (Node Leaf x1 r1 h1) -> bst s2 ->
+ (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> 
+ (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2).
 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.
+ induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
+ unfold Subset; intuition; try discriminate.
+ assert (H': In x1 Leaf) by auto; inversion H'.
  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.
+ specialize (IHl2 H H2 H1).
+ specialize (IHr2 H H3 H1).
+ inv bst. clear H7.
+ destruct X.compare.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto;  clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (H':=mem_2 H1); apply In_1 with x1; auto.
+ apply mem_1; auto.
+ assert (In x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ 
+ rewrite IHr2; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
 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.
+Lemma subset_12 : forall s1 s2, bst s1 -> bst s2 -> 
+ (subset s1 s2 = true <-> Subset s1 s2).
 Proof.
- simpl in |- *; intuition.
-Qed. 
+ induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros.
+ unfold Subset; intuition_in.
+ destruct s2 as [|l2 x2 r2 h2]; simpl; intros.
+ unfold Subset; intuition_in; try discriminate.
+ assert (H': In x1 Leaf) by auto; inversion H'.
+ inv bst.
+ destruct X.compare.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto.
+ rewrite (@subsetl_12 (subset l1) l1 x1 h1) by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ 
+ rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto.
+ rewrite (@subsetr_12 (subset r1) r1 x1 h1) by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+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.
+Definition eq := Equal.
+Definition lt (s1 s2 : t) : Prop := L.lt (elements s1) (elements s2).
 
-Lemma eq_refl : forall s : t, eq s s. 
+Lemma eq_refl : forall s : t, Equal s s. 
 Proof.
- unfold eq, Equal in |- *; intuition.
+ unfold Equal; intuition.
 Qed.
 
-Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s.
+Lemma eq_sym : forall s s' : t, Equal s s' -> Equal s' s.
 Proof.
- unfold eq, Equal in |- *; firstorder.
+ unfold Equal; intros s s' H x; destruct (H x); split; auto.
 Qed.
 
-Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
+Lemma eq_trans : forall s s' s'' : t, 
+ Equal s s' -> Equal s' s'' -> Equal s s''.
 Proof.
- unfold eq, Equal in |- *; firstorder.
+ unfold Equal; intros s s' s'' H1 H2 x; 
+ destruct (H1 x); destruct (H2 x); split; auto.
 Qed.
 
 Lemma eq_L_eq :
- forall s s' : t, eq s s' -> L.eq (elements s) (elements s').
+ forall s s' : t, Equal 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.
+ unfold Equal, L.eq, L.Equal; intros; do 2 rewrite elements_in; auto.
 Qed.
 
 Lemma L_eq_eq :
- forall s s' : t, L.eq (elements s) (elements s') -> eq s s'.
+ forall s s' : t, L.eq (elements s) (elements s') -> Equal s s'.
 Proof.
- unfold eq, Equal, L.eq, L.Equal in |- *; intros.
- generalize (elements_in s a) (elements_in s' a).
- firstorder.
+ unfold Equal, L.eq, L.Equal; intros; do 2 rewrite <-elements_in; auto.
 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'.
+Lemma lt_not_eq : forall s s' : t, 
+ bst s -> bst s' -> lt s s' -> ~ Equal 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)
-*)
+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.
+Hint Resolve L_eq_cons.
 
-(** ** Enumeration of the elements of a tree *)
 
-Inductive enumeration : Set :=
- | End : enumeration
- | More : elt -> tree -> enumeration -> enumeration.
+(** * A new comparison algorithm suggested by Xavier Leroy *)
 
 (** [flatten_e e] returns the list of elements of [e] i.e. the list
     of elements actually compared *)
@@ -2171,462 +1719,166 @@ Fixpoint flatten_e (e : enumeration) : list elt := match e with
   | 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.
+Lemma flatten_e_elements :
+ forall l x r h e,
+ elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e.
 Proof.
- simpl in |- *; unfold elements in |- *; simpl in |- *; intuition.
- repeat rewrite elements_app.
- repeat rewrite <- app_nil_end.
- repeat rewrite app_ass; auto.
+ intros; simpl; apply elements_node.
 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.
+Lemma cons_1 : forall s e, 
+  flatten_e (cons s e) = elements s ++ flatten_e e.
 Proof.
- intros; simpl.
- apply compare_flatten_1.
+ induction s; simpl; auto; intros.
+ rewrite IHs1; apply flatten_e_elements.
 Qed.
 
-(** termination of [compare_aux] *)
+(** Correctness of this comparison *)
 
-Open Local 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
+Definition Cmp c := 
+ match c with 
+  | Eq => L.eq
+  | Lt => L.lt
+  | Gt => (fun l1 l2 => L.lt l2 l1)
  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.
+Lemma cons_Cmp : forall c x1 x2 l1 l2, X.eq x1 x2 ->
+ Cmp c l1 l2 -> Cmp c (x1::l1) (x2::l2). 
 Proof.
- simple induction s.
- simpl in |- *; omega.
- intros.
- Measure_e_t; omega. (* BUG Simpl! *)
+ destruct c; simpl; auto.
 Qed.
+Hint Resolve cons_Cmp.
 
-Ltac Measure_e_t_0 s := generalize (measure_e_t_0 s); intro.
-
-Lemma measure_e_0 : forall e : enumeration, measure_e e >= 0.
+Lemma compare_end_Cmp : 
+ forall e2, Cmp (compare_end e2) nil (flatten_e e2).
 Proof.
- simple induction e.
- simpl in |- *; omega.
- intros.
- Measure_e; Measure_e_t_0 t; omega.
+ destruct e2; simpl; auto.
+ apply L.eq_refl.
 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'.
+Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, 
+  Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> 
+   Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) 
+      (flatten_e (More x2 r2 e2)).
 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.
+ simpl; intros; destruct X.compare; simpl; auto.
 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).
+Lemma compare_cont_Cmp : forall s1 cont e2 l,
+ (forall e, Cmp (cont e) l (flatten_e e)) -> 
+ Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2).
 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.
+ induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto.
+ rewrite <- elements_node; simpl.
+ apply Hl1; auto. clear e2. intros [|x2 r2 e2].
+ simpl; auto.
+ apply compare_more_Cmp.
+ rewrite <- cons_1; auto.
 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.
+Lemma compare_Cmp : forall s1 s2,
+ Cmp (compare s1 s2) (elements s1) (elements s2).
+Proof.
+ intros; unfold compare.
+ rewrite (app_nil_end (elements s1)).
+ replace (elements s2) with (flatten_e (cons s2 End)) by 
+  (rewrite cons_1; simpl; rewrite <- app_nil_end; auto).
+ apply compare_cont_Cmp; auto.
+ intros.
+ apply compare_end_Cmp; auto.
 Qed.
 
 (** * Equality test *)
 
-Definition equal : forall s s' : t, bst s -> bst s' -> {Equal s s'} + {~ Equal s s'}.
+Lemma equal_1 : forall s1 s2, bst s1 -> bst s2 ->  
+ Equal s1 s2 -> equal s1 s2 = true.
 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.
+unfold equal; intros s1 s2 B1 B2 E.
+generalize (compare_Cmp s1 s2). 
+destruct (compare s1 s2); simpl in *; auto; intros.
+elim (lt_not_eq B1 B2 H E); auto.
+elim (lt_not_eq B2 B1 H (eq_sym E)); 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').
+Lemma equal_2 : forall s1 s2,  
+ equal s1 s2 = true -> Equal s1 s2.
 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.
+unfold equal; intros s1 s2 E.
+generalize (compare_Cmp s1 s2); 
+ destruct compare; auto; discriminate.
 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.
+End Proofs.
 
-(** Alternative equal based on subset *)
+End Raw.
 
-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. *)
+   need to encapsulate everything into a type of binary search trees. 
+   They also happen to be well-balanced, but this has no influence 
+   on the correctness of operations, so we won't state this here, 
+   see [FSetFullAVL] if you need more than just the FSet interface.
+*)
 
 Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
 
  Module E := X.
- Module Raw := Raw I X. 
+ Module Raw := Raw I X.
+ Import Raw.Proofs.
 
- Record bbst : Set := Bbst {this :> Raw.t; is_bst : Raw.bst this; is_avl: Raw.avl this}.
- Definition t := bbst. 
+ Record bst := Bst {this :> Raw.t; is_bst : Raw.bst this}.
+ Definition t := bst.
  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.
-  
+ Definition In (x : elt) (s : t) := Raw.In x s.
+ Definition Equal (s s':t) := forall a : elt, In a s <-> In a s'.
+ Definition Subset (s s':t) := forall a : elt, In a s -> In a s'.
+ Definition Empty (s:t) := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop) (s:t) := forall x, In x s -> P x.
+ Definition Exists (P : elt -> Prop) (s:t) := 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.
+ Proof. intro s; exact (@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 empty : t := Bst empty_bst.
  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 singleton (x:elt) : t := Bst (singleton_bst x).
+ Definition add (x:elt)(s:t) : t := Bst (add_bst x (is_bst s)). 
+ Definition remove (x:elt)(s:t) : t := Bst (remove_bst x (is_bst s)).
+ Definition inter (s s':t) : t := Bst (inter_bst (is_bst s) (is_bst s')).
+ Definition union (s s':t) : t := Bst (union_bst (is_bst s) (is_bst s')).
+ Definition diff (s s':t) : t := Bst (diff_bst (is_bst s) (is_bst 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 fold (B : Type) (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)). 
+   Bst (filter_bst f (is_bst 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'.
+   (@Bst (fst p) (partition_bst_1 f (is_bst s)), 
+    @Bst (snd p) (partition_bst_2 f (is_bst 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 equal (s s':t) : bool := Raw.equal s s'.
+ 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 eq (s s':t) : Prop := Raw.Equal s s'.
+ Definition lt (s s':t) : Prop := Raw.Proofs.lt s s'.
 
- Definition compare  (s s':t) : Compare lt eq 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. 
+  intros (s,b) (s',b').
+  generalize (compare_Cmp s s').
+  destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto.
  Defined.
 
  (* specs *)
@@ -2634,260 +1886,164 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  Variable s s' s'': t. 
  Variable x y : elt.
 
- Hint Resolve is_bst is_avl.
+ Hint Resolve is_bst.
  
  Lemma mem_1 : In x s -> mem x s = true. 
- Proof. exact (Raw.mem_1 s x (is_bst s)). Qed.
+ Proof. exact (mem_1 (is_bst s)). Qed.
  Lemma mem_2 : mem x s = true -> In x s.
- Proof. exact (Raw.mem_2 s x). Qed.
+ Proof. exact (@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.
-
+ Proof. exact (equal_1 (is_bst s) (is_bst s')). Qed.
  Lemma equal_2 : equal s s' = true -> Equal s s'.
- Proof. 
- unfold equal; destruct (Raw.equal s s'); simpl; intuition; discriminate.
- Qed.
+ Proof. exact (@equal_2 s s'). 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.
+ Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition.
 
  Lemma subset_1 : Subset s s' -> subset s s' = true.
- Proof. 
- unfold subset; destruct (Raw.subset s s'); simpl; intuition.
- Qed.
-
+ Proof. wrap subset subset_12. 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.
+ Proof. wrap subset subset_12. Qed.
 
  Lemma empty_1 : Empty empty.
- Proof. exact Raw.empty_1. Qed.
+ Proof. exact empty_1. Qed.
 
  Lemma is_empty_1 : Empty s -> is_empty s = true.
- Proof. exact (Raw.is_empty_1 s). Qed.
+ Proof. exact (@is_empty_1 s). Qed.
  Lemma is_empty_2 : is_empty s = true -> Empty s. 
- Proof. exact (Raw.is_empty_2 s). Qed.
+ Proof. exact (@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.
-
+ Proof. wrap add add_in. Qed.
  Lemma add_2 : In y s -> In y (add x s).
- Proof.
- unfold add, In; simpl; rewrite Raw.add_in; auto.
- Qed.
-
+ Proof. wrap add add_in. 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.
+ Proof. wrap add add_in. 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.
-
+ Proof. wrap remove remove_in. 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.
-
+ Proof. wrap remove remove_in. Qed.
  Lemma remove_3 : In y (remove x s) -> In y s.
- Proof. 
- unfold remove, In; simpl; rewrite Raw.remove_in; intuition.
- Qed.
+ Proof. wrap remove remove_in. Qed.
 
  Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
- Proof. exact (Raw.singleton_1 x y). Qed.
+ Proof. exact (@singleton_1 x y). Qed.
  Lemma singleton_2 : E.eq x y -> In y (singleton x). 
- Proof. exact (Raw.singleton_2 x y). Qed.
+ Proof. exact (@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.
-
+ Proof. wrap union union_in. 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.
-
+ Proof. wrap union union_in. 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.
+ Proof. wrap union union_in. Qed.
 
  Lemma inter_1 : In x (inter s s') -> In x s.
- Proof.
- unfold inter, In; simpl; rewrite Raw.inter_in; intuition.
- Qed.
-
+ Proof. wrap inter inter_in. Qed.
  Lemma inter_2 : In x (inter s s') -> In x s'.
- Proof. 
- unfold inter, In; simpl; rewrite Raw.inter_in; intuition.
- Qed.
-
+ Proof. wrap inter inter_in. 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.
+ Proof. wrap inter inter_in. Qed.
  
  Lemma diff_1 : In x (diff s s') -> In x s. 
- Proof. 
- unfold diff, In; simpl; rewrite Raw.diff_in; intuition.
- Qed.
-
+ Proof. wrap diff diff_in. Qed.
  Lemma diff_2 : In x (diff s s') -> ~ In x s'.
- Proof. 
- unfold diff, In; simpl; rewrite Raw.diff_in; intuition.
- Qed.
-
+ Proof. wrap diff diff_in. 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.
+ Proof. wrap diff diff_in. 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 fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+ Proof. unfold fold, elements; intros; apply fold_1; auto. Qed.
 
  Lemma cardinal_1 : cardinal s = length (elements s).
  Proof. 
- unfold cardinal, elements; intros; apply Raw.cardinal_elements_1; auto.
+ unfold cardinal, elements; intros; apply elements_cardinal; 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.
-
+ Proof. intro. wrap filter filter_in. 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.
-
+ Proof. intro. wrap filter filter_in. 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.
+ Proof. intro. wrap filter filter_in. 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.
+ Proof. exact (@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.
+ Proof. exact (@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.
+ Proof. exact (@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.
+ Proof. exact (@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.
+ rewrite partition_in_1, 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.
+ rewrite partition_in_2, filter_in; intuition.
+ rewrite H2; auto.
  destruct (f a); auto.
+ red; intros; f_equal.
+ rewrite (H _ _ H0); 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.
-
+ Proof. wrap elements elements_in. Qed.
  Lemma elements_2 : InA E.eq x (elements s) -> In x s.
- Proof. 
- unfold elements, In; rewrite Raw.elements_in; auto.
- Qed.
-
+ Proof. wrap elements elements_in. Qed.
  Lemma elements_3 : sort E.lt (elements s).
- Proof. exact (Raw.elements_sort _ (is_bst s)). Qed.
+ Proof. exact (elements_sort (is_bst s)). Qed.
+ Lemma elements_3w : NoDupA E.eq (elements s).
+ Proof. exact (elements_nodup (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.
+ Proof. exact (@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.
+ Proof. exact (@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.
+ Proof. exact (@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.
+ Proof. exact (@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.
+ Proof. exact (@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.
+ Proof. exact (@max_elt_3 s). Qed.
 
  Lemma choose_1 : choose s = Some x -> In x s.
- Proof. exact (Raw.choose_1 s x). Qed.
+ Proof. exact (@choose_1 s x). Qed.
  Lemma choose_2 : choose s = None -> Empty s.
- Proof. exact (Raw.choose_2 s). Qed.
+ Proof. exact (@choose_2 s). Qed.
+ Lemma choose_3 : choose s = Some x -> choose s' = Some y -> 
+  Equal s s' -> E.eq x y.
+ Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed.
 
  Lemma eq_refl : eq s s. 
- Proof. exact (Raw.eq_refl s). Qed.
+ Proof. exact (eq_refl s). Qed.
  Lemma eq_sym : eq s s' -> eq s' s.
- Proof. exact (Raw.eq_sym s s'). Qed.
+ Proof. exact (@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.
+ Proof. exact (@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.
+ Proof. exact (@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.
+ Proof. exact (@lt_not_eq _ _ (is_bst s) (is_bst s')). Qed.
 
  End Specs.
 End IntMake.
@@ -2897,4 +2053,3 @@ End IntMake.
 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 08985cfc..0622451f 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 8834 2006-05-20 00:41:35Z letouzey $ *)
+(* $Id: FSetBridge.v 10601 2008-02-28 00:20:33Z letouzey $ *)
 
 (** * Finite sets library *)
 
@@ -27,7 +27,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E.
    
   Definition empty : {s : t | Empty s}.
   Proof. 
-    exists empty; auto.
+    exists empty; auto with set.
   Qed.
 
   Definition is_empty : forall s : t, {Empty s} + {~ Empty s}.
@@ -66,12 +66,12 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E.
     {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}.
   Proof.
     intros; exists (remove x s); intuition.
-    absurd (In x (remove x s)); auto.
+    absurd (In x (remove x s)); auto with set.
     apply In_1 with y; auto. 
     elim (ME.eq_dec x y); intros; auto.
-    absurd (In x (remove x s)); auto.
+    absurd (In x (remove x s)); auto with set.
     apply In_1 with y; auto. 
-    eauto.
+    eauto with set.
   Qed.
 
   Definition union :
@@ -83,14 +83,14 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E.
   Definition inter :
     forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}.
   Proof. 
-    intros; exists (inter s s'); intuition; eauto.
+    intros; exists (inter s s'); intuition; eauto with set.
   Qed.
 
   Definition diff :
     forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}.
   Proof. 
-    intros; exists (diff s s'); intuition; eauto. 
-    absurd (In x s'); eauto. 
+    intros; exists (diff s s'); intuition; eauto with set. 
+    absurd (In x s'); eauto with set. 
   Qed. 
  
   Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}.
@@ -115,7 +115,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E.
    Defined. 
 
   Definition fold :
-    forall (A : Set) (f : elt -> A -> A) (s : t) (i : A),
+    forall (A : Type) (f : elt -> A -> A) (s : t) (i : A),
     {r : A |   let (l,_) := elements s in 
                   r = fold_left (fun a e => f e a) l i}.
   Proof. 
@@ -150,7 +150,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E.
     exists (filter (fdec Pdec) s).
     intro H; assert (compat_bool E.eq (fdec Pdec)); auto.
     intuition.
-    eauto.
+    eauto with set.
     generalize (filter_2 H0 H1).
     unfold fdec in |- *.
     case (Pdec x); intuition.
@@ -226,7 +226,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E.
     generalize H4; unfold For_all, Equal in |- *; intuition.
     elim (H0 x); intros.
     assert (fdec Pdec x = true).
-     eauto.      
+     eapply filter_2; eauto with set.
     generalize H8; unfold fdec in |- *; case (Pdec x); intuition.
     inversion H9.
     generalize H; unfold For_all, Equal in |- *; intuition.
@@ -238,8 +238,8 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E.
     set (b := fdec Pdec x) in *; generalize (refl_equal b);
      pattern b at -1 in |- *; case b; unfold b in |- *; 
      [ left | right ].
-    elim (H4 x); intros _ B; apply B; auto.
-    elim (H x); intros _ B; apply B; auto.
+    elim (H4 x); intros _ B; apply B; auto with set.
+    elim (H x); intros _ B; apply B; auto with set.
     apply filter_3; auto.
     rewrite H5; auto.
     eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B;
@@ -247,12 +247,63 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E.
     eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto.
   Qed. 
 
+  Definition choose_aux: forall s : t, 
+    { x : elt | M.choose s = Some x } + { M.choose s = None }.
+  Proof.
+   intros.
+   destruct (M.choose s); [left | right]; auto.
+   exists e; auto.
+  Qed.
+ 
   Definition choose : forall s : t, {x : elt | In x s} + {Empty s}.
-  Proof.  
-    intros.
-    generalize (choose_1 (s:=s)) (choose_2 (s:=s)).
-    case (choose s); [ left | right ]; auto.
-    exists e; auto.    
+  Proof.
+   intros; destruct (choose_aux s) as [(x,Hx)|H].
+   left; exists x; apply choose_1; auto.
+   right; apply choose_2; auto.
+  Defined.
+
+  Lemma choose_ok1 : 
+   forall s x, M.choose s = Some x <-> exists H:In x s, 
+      choose s = inleft _ (exist (fun x => In x s) x H).
+  Proof.
+    intros s x.
+    unfold choose; split; intros. 
+    destruct (choose_aux s) as [(y,Hy)|H']; try congruence.
+    replace x with y in * by congruence.
+    exists (choose_1 Hy); auto.
+    destruct H.
+    destruct (choose_aux s) as [(y,Hy)|H']; congruence.
+  Qed.
+
+  Lemma choose_ok2 : 
+   forall s, M.choose s = None <-> exists H:Empty s, 
+      choose s = inright _ H.
+  Proof. 
+    intros s.
+    unfold choose; split; intros.
+    destruct (choose_aux s) as [(y,Hy)|H']; try congruence.
+    exists (choose_2 H'); auto.
+    destruct H.
+    destruct (choose_aux s) as [(y,Hy)|H']; congruence.
+  Qed.
+
+  Lemma choose_equal : forall s s', Equal s s' -> 
+     match choose s, choose s' with 
+       | inleft (exist x _), inleft (exist x' _) => E.eq x x'
+       | inright _, inright _  => True
+       | _, _                        => False
+     end.
+  Proof.
+   intros.
+   generalize (@M.choose_1 s)(@M.choose_2 s)
+              (@M.choose_1 s')(@M.choose_2 s')(@M.choose_3 s s')
+              (choose_ok1 s)(choose_ok2 s)(choose_ok1 s')(choose_ok2 s').
+   destruct (choose s) as [(x,Hx)|Hx]; destruct (choose s') as [(x',Hx')|Hx']; auto; intros.
+   apply H4; auto.
+   rewrite H5; exists Hx; auto.
+   rewrite H7; exists Hx'; auto.
+   apply Hx' with x; unfold Equal in H; rewrite <-H; auto.
+   apply Hx with x'; unfold Equal in H; rewrite H; auto.
   Qed.
 
   Definition min_elt :
@@ -391,6 +442,15 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
     intro s; unfold choose in |- *; case (M.choose s); auto.
     simple destruct s0; intros; discriminate H.
   Qed.
+ 
+  Lemma choose_3 : forall s s' x x', 
+   choose s = Some x -> choose s' = Some x' -> Equal s s' -> E.eq x x'.
+  Proof.
+  unfold choose; intros.
+  generalize (M.choose_equal H1); clear H1.
+  destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; 
+   simpl; auto; congruence.
+  Qed.
 
   Definition elements (s : t) : list elt := let (l, _) := elements s in l. 
  
@@ -408,6 +468,10 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
   Proof. 
     intros; unfold elements in |- *; case (M.elements s); firstorder.
   Qed.
+  Hint Resolve elements_3.
+ 
+  Lemma elements_3w : forall s : t, NoDupA E.eq (elements s).
+  Proof. auto. Qed.
 
   Definition min_elt (s : t) : option elt :=
     match min_elt s with
@@ -578,11 +642,11 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
     destruct (M.elements s); auto.
   Qed.
 
-  Definition fold (B : Set) (f : elt -> B -> B) (i : t) 
+  Definition fold (B : Type) (f : elt -> B -> B) (i : t) 
     (s : B) : B := let (fold, _) := fold f i s in fold.
 
   Lemma fold_1 :
-   forall (s : t) (A : Set) (i : A) (f : elt -> A -> A),
+   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
    fold f s i = fold_left (fun a e => f e a) (elements s) i.
   Proof.
     intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *; 
diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v
new file mode 100644
index 00000000..0639c1f1
--- /dev/null
+++ b/theories/FSets/FSetDecide.v
@@ -0,0 +1,841 @@
+(***********************************************************************)
+(*  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: FSetDecide.v 11064 2008-06-06 17:00:52Z letouzey $ *)
+
+(**************************************************************)
+(* FSetDecide.v                                               *)
+(*                                                            *)
+(* Author: Aaron Bohannon                                     *)
+(**************************************************************)
+
+(** This file implements a decision procedure for a certain
+    class of propositions involving finite sets.  *)
+
+Require Import Decidable DecidableTypeEx FSetFacts.
+
+(** First, a version for Weak Sets *)
+
+Module WDecide (E : DecidableType)(Import M : WSfun E).
+ Module F := FSetFacts.WFacts E M.
+
+(** * Overview
+    This functor defines the tactic [fsetdec], which will
+    solve any valid goal of the form
+<<
+    forall s1 ... sn,
+    forall x1 ... xm,
+    P1 -> ... -> Pk -> P
+>>
+    where [P]'s are defined by the grammar:
+<<
+
+P ::=
+| Q
+| Empty F
+| Subset F F'
+| Equal F F'
+
+Q ::=
+| E.eq X X'
+| In X F
+| Q /\ Q'
+| Q \/ Q'
+| Q -> Q'
+| Q <-> Q'
+| ~ Q
+| True
+| False
+
+F ::=
+| S
+| empty
+| singleton X
+| add X F
+| remove X F
+| union F F'
+| inter F F'
+| diff F F'
+
+X ::= x1 | ... | xm
+S ::= s1 | ... | sn
+
+>>
+
+The tactic will also work on some goals that vary slightly from
+the above form:
+- The variables and hypotheses may be mixed in any order and may
+  have already been introduced into the context.  Moreover,
+  there may be additional, unrelated hypotheses mixed in (these
+  will be ignored).
+- A conjunction of hypotheses will be handled as easily as
+  separate hypotheses, i.e., [P1 /\ P2 -> P] can be solved iff
+  [P1 -> P2 -> P] can be solved.
+- [fsetdec] should solve any goal if the FSet-related hypotheses
+  are contradictory.
+- [fsetdec] will first perform any necessary zeta and beta
+  reductions and will invoke [subst] to eliminate any Coq
+  equalities between finite sets or their elements.
+- If [E.eq] is convertible with Coq's equality, it will not
+  matter which one is used in the hypotheses or conclusion.
+- The tactic can solve goals where the finite sets or set
+  elements are expressed by Coq terms that are more complicated
+  than variables.  However, non-local definitions are not
+  expanded, and Coq equalities between non-variable terms are
+  not used.  For example, this goal will be solved:
+<<
+    forall (f : t -> t),
+    forall (g : elt -> elt),
+    forall (s1 s2 : t),
+    forall (x1 x2 : elt),
+    Equal s1 (f s2) ->
+    E.eq x1 (g (g x2)) ->
+    In x1 s1 ->
+    In (g (g x2)) (f s2)
+>>
+  This one will not be solved:
+<<
+    forall (f : t -> t),
+    forall (g : elt -> elt),
+    forall (s1 s2 : t),
+    forall (x1 x2 : elt),
+    Equal s1 (f s2) ->
+    E.eq x1 (g x2) ->
+    In x1 s1 ->
+    g x2 = g (g x2) ->
+    In (g (g x2)) (f s2)
+>>
+*)
+
+  (** * Facts and Tactics for Propositional Logic
+      These lemmas and tactics are in a module so that they do
+      not affect the namespace if you import the enclosing
+      module [Decide]. *)
+  Module FSetLogicalFacts.
+    Require Export Decidable.
+    Require Export Setoid.
+
+    (** ** Lemmas and Tactics About Decidable Propositions *)
+
+    (** ** Propositional Equivalences Involving Negation
+        These are all written with the unfolded form of
+        negation, since I am not sure if setoid rewriting will
+        always perform conversion. *)
+
+    (** ** Tactics for Negations *)
+
+    Tactic Notation "fold" "any" "not" :=
+      repeat (
+        match goal with
+        | H: context [?P -> False] |- _ =>
+          fold (~ P) in H
+        | |- context [?P -> False] =>
+          fold (~ P)
+        end).
+
+    (** [push not using db] will pushes all negations to the
+        leaves of propositions in the goal, using the lemmas in
+        [db] to assist in checking the decidability of the
+        propositions involved.  If [using db] is omitted, then
+        [core] will be used.  Additional versions are provided
+        to manipulate the hypotheses or the hypotheses and goal
+        together.
+
+        XXX: This tactic and the similar subsequent ones should
+        have been defined using [autorewrite]. However, dealing
+        with multiples rewrite sites and side-conditions is 
+        done more cleverly with the following explicit 
+        analysis of goals. *)
+
+    Ltac or_not_l_iff P Q tac := 
+      (rewrite (or_not_l_iff_1 P Q) by tac) || 
+      (rewrite (or_not_l_iff_2 P Q) by tac).
+
+    Ltac or_not_r_iff P Q tac := 
+      (rewrite (or_not_r_iff_1 P Q) by tac) || 
+      (rewrite (or_not_r_iff_2 P Q) by tac).
+
+    Ltac or_not_l_iff_in P Q H tac := 
+      (rewrite (or_not_l_iff_1 P Q) in H by tac) || 
+      (rewrite (or_not_l_iff_2 P Q) in H by tac).
+
+    Ltac or_not_r_iff_in P Q H tac := 
+      (rewrite (or_not_r_iff_1 P Q) in H by tac) || 
+      (rewrite (or_not_r_iff_2 P Q) in H by tac).
+
+    Tactic Notation "push" "not" "using" ident(db) :=
+      let dec := solve_decidable using db in 
+      unfold not, iff;
+      repeat (
+        match goal with
+        | |- context [True -> False] => rewrite not_true_iff
+        | |- context [False -> False] => rewrite not_false_iff
+        | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec
+        | |- context [(?P -> False) -> (?Q -> False)] => 
+            rewrite (contrapositive P Q) by dec
+        | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec
+        | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec
+        | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec
+        | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q)
+        | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q)
+        | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec
+        end);
+      fold any not.
+
+    Tactic Notation "push" "not" :=
+      push not using core.
+
+    Tactic Notation
+      "push" "not" "in" "*" "|-" "using" ident(db) :=
+      let dec := solve_decidable using db in 
+      unfold not, iff in * |-;
+      repeat (
+        match goal with
+        | H: context [True -> False] |- _ => rewrite not_true_iff in H
+        | H: context [False -> False] |- _ => rewrite not_false_iff in H
+        | H: context [(?P -> False) -> False] |- _ => 
+          rewrite (not_not_iff P) in H by dec
+        | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
+          rewrite (contrapositive P Q) in H by dec
+        | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec
+        | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec
+        | H: context [(?P -> False) -> ?Q] |- _ => 
+          rewrite (imp_not_l P Q) in H by dec
+        | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H
+        | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H
+        | H: context [(?P -> ?Q) -> False] |- _ => 
+          rewrite (not_imp_iff P Q) in H by dec
+        end);
+      fold any not.
+
+    Tactic Notation "push" "not" "in" "*" "|-"  :=
+      push not in * |- using core.
+
+    Tactic Notation "push" "not" "in" "*" "using" ident(db) :=
+      push not using db; push not in * |- using db.
+    Tactic Notation "push" "not" "in" "*" :=
+      push not in * using core.
+
+    (** A simple test case to see how this works.  *)
+    Lemma test_push : forall P Q R : Prop,
+      decidable P ->
+      decidable Q ->
+      (~ True) ->
+      (~ False) ->
+      (~ ~ P) ->
+      (~ (P /\ Q) -> ~ R) ->
+      ((P /\ Q) \/ ~ R) ->
+      (~ (P /\ Q) \/ R) ->
+      (R \/ ~ (P /\ Q)) ->
+      (~ R \/ (P /\ Q)) ->
+      (~ P -> R) ->
+      (~ ((R -> P) \/ (Q -> R))) ->
+      (~ (P /\ R)) ->
+      (~ (P -> R)) ->
+      True.
+    Proof.
+      intros. push not in *.
+       (* note that ~(R->P) remains (since R isnt decidable) *)
+      tauto.
+    Qed.
+
+    (** [pull not using db] will pull as many negations as
+        possible toward the top of the propositions in the goal,
+        using the lemmas in [db] to assist in checking the
+        decidability of the propositions involved.  If [using
+        db] is omitted, then [core] will be used.  Additional
+        versions are provided to manipulate the hypotheses or
+        the hypotheses and goal together. *)
+
+    Tactic Notation "pull" "not" "using" ident(db) :=
+      let dec := solve_decidable using db in 
+      unfold not, iff;
+      repeat (
+        match goal with
+        | |- context [True -> False] => rewrite not_true_iff
+        | |- context [False -> False] => rewrite not_false_iff
+        | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec
+        | |- context [(?P -> False) -> (?Q -> False)] =>
+          rewrite (contrapositive P Q) by dec
+        | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec
+        | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec
+        | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec
+        | |- context [(?P -> False) /\ (?Q -> False)] =>
+          rewrite <- (not_or_iff P Q)
+        | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q)
+        | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec
+        | |- context [(?Q -> False) /\ ?P] => 
+          rewrite <- (not_imp_rev_iff P Q) by dec
+        end);
+      fold any not.
+
+    Tactic Notation "pull" "not" :=
+      pull not using core.
+
+    Tactic Notation
+      "pull" "not" "in" "*" "|-" "using" ident(db) :=
+      let dec := solve_decidable using db in 
+      unfold not, iff in * |-;
+      repeat (
+        match goal with
+        | H: context [True -> False] |- _ => rewrite not_true_iff in H
+        | H: context [False -> False] |- _ => rewrite not_false_iff in H
+        | H: context [(?P -> False) -> False] |- _ =>
+          rewrite (not_not_iff P) in H by dec
+        | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
+          rewrite (contrapositive P Q) in H by dec
+        | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec
+        | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec
+        | H: context [(?P -> False) -> ?Q] |- _ =>
+          rewrite (imp_not_l P Q) in H by dec
+        | H: context [(?P -> False) /\ (?Q -> False)] |- _ =>
+          rewrite <- (not_or_iff P Q) in H 
+        | H: context [?P -> ?Q -> False] |- _ => 
+          rewrite <- (not_and_iff P Q) in H
+        | H: context [?P /\ (?Q -> False)] |- _ =>
+          rewrite <- (not_imp_iff P Q) in H by dec
+        | H: context [(?Q -> False) /\ ?P] |- _ =>
+          rewrite <- (not_imp_rev_iff P Q) in H by dec
+        end);
+      fold any not.
+
+    Tactic Notation "pull" "not" "in" "*" "|-"  :=
+      pull not in * |- using core.
+
+    Tactic Notation "pull" "not" "in" "*" "using" ident(db) :=
+      pull not using db; pull not in * |- using db.
+    Tactic Notation "pull" "not" "in" "*" :=
+      pull not in * using core.
+
+    (** A simple test case to see how this works.  *)
+    Lemma test_pull : forall P Q R : Prop,
+      decidable P ->
+      decidable Q ->
+      (~ True) ->
+      (~ False) ->
+      (~ ~ P) ->
+      (~ (P /\ Q) -> ~ R) ->
+      ((P /\ Q) \/ ~ R) ->
+      (~ (P /\ Q) \/ R) ->
+      (R \/ ~ (P /\ Q)) ->
+      (~ R \/ (P /\ Q)) ->
+      (~ P -> R) ->
+      (~ (R -> P) /\ ~ (Q -> R)) ->
+      (~ P \/ ~ R) ->
+      (P /\ ~ R) ->
+      (~ R /\ P) ->
+      True.
+    Proof.
+      intros. pull not in *. tauto.
+    Qed.
+
+  End FSetLogicalFacts.
+  Import FSetLogicalFacts.
+
+  (** * Auxiliary Tactics
+      Again, these lemmas and tactics are in a module so that
+      they do not affect the namespace if you import the
+      enclosing module [Decide].  *)
+  Module FSetDecideAuxiliary.
+
+    (** ** Generic Tactics
+        We begin by defining a few generic, useful tactics. *)
+
+    (** [if t then t1 else t2] executes [t] and, if it does not
+        fail, then [t1] will be applied to all subgoals
+        produced.  If [t] fails, then [t2] is executed. *)
+    Tactic Notation
+      "if" tactic(t)
+      "then" tactic(t1)
+      "else" tactic(t2) :=
+      first [ t; first [ t1 | fail 2 ] | t2 ].
+
+    (** [prop P holds by t] succeeds (but does not modify the
+        goal or context) if the proposition [P] can be proved by
+        [t] in the current context.  Otherwise, the tactic
+        fails. *)
+    Tactic Notation "prop" constr(P) "holds" "by" tactic(t) :=
+      let H := fresh in
+      assert P as H by t;
+      clear H.
+
+    (** This tactic acts just like [assert ... by ...] but will
+        fail if the context already contains the proposition. *)
+    Tactic Notation "assert" "new" constr(e) "by" tactic(t) :=
+      match goal with
+      | H: e |- _ => fail 1
+      | _ => assert e by t
+      end.
+
+    (** [subst++] is similar to [subst] except that
+        - it never fails (as [subst] does on recursive
+          equations),
+        - it substitutes locally defined variable for their
+          definitions,
+        - it performs beta reductions everywhere, which may
+          arise after substituting a locally defined function
+          for its definition.
+        *)
+    Tactic Notation "subst" "++" :=
+      repeat (
+        match goal with
+        | x : _ |- _ => subst x
+        end);
+      cbv zeta beta in *.
+
+    (** [decompose records] calls [decompose record H] on every
+        relevant hypothesis [H]. *)
+    Tactic Notation "decompose" "records" :=
+      repeat (
+        match goal with
+        | H: _ |- _ => progress (decompose record H); clear H
+        end).
+
+    (** ** Discarding Irrelevant Hypotheses
+        We will want to clear the context of any
+        non-FSet-related hypotheses in order to increase the
+        speed of the tactic.  To do this, we will need to be
+        able to decide which are relevant.  We do this by making
+        a simple inductive definition classifying the
+        propositions of interest. *)
+
+    Inductive FSet_elt_Prop : Prop -> Prop :=
+    | eq_Prop : forall (S : Set) (x y : S),
+        FSet_elt_Prop (x = y)
+    | eq_elt_prop : forall x y,
+        FSet_elt_Prop (E.eq x y)
+    | In_elt_prop : forall x s,
+        FSet_elt_Prop (In x s)
+    | True_elt_prop :
+        FSet_elt_Prop True
+    | False_elt_prop :
+        FSet_elt_Prop False
+    | conj_elt_prop : forall P Q,
+        FSet_elt_Prop P ->
+        FSet_elt_Prop Q ->
+        FSet_elt_Prop (P /\ Q)
+    | disj_elt_prop : forall P Q,
+        FSet_elt_Prop P ->
+        FSet_elt_Prop Q ->
+        FSet_elt_Prop (P \/ Q)
+    | impl_elt_prop : forall P Q,
+        FSet_elt_Prop P ->
+        FSet_elt_Prop Q ->
+        FSet_elt_Prop (P -> Q)
+    | not_elt_prop : forall P,
+        FSet_elt_Prop P ->
+        FSet_elt_Prop (~ P).
+
+    Inductive FSet_Prop : Prop -> Prop :=
+    | elt_FSet_Prop : forall P,
+        FSet_elt_Prop P ->
+        FSet_Prop P
+    | Empty_FSet_Prop : forall s,
+        FSet_Prop (Empty s)
+    | Subset_FSet_Prop : forall s1 s2,
+        FSet_Prop (Subset s1 s2)
+    | Equal_FSet_Prop : forall s1 s2,
+        FSet_Prop (Equal s1 s2).
+
+    (** Here is the tactic that will throw away hypotheses that
+        are not useful (for the intended scope of the [fsetdec]
+        tactic). *)
+    Hint Constructors FSet_elt_Prop FSet_Prop : FSet_Prop.
+    Ltac discard_nonFSet :=
+      decompose records;
+      repeat (
+        match goal with
+        | H : ?P |- _ =>
+          if prop (FSet_Prop P) holds by
+            (auto 100 with FSet_Prop)
+          then fail
+          else clear H
+        end).
+
+    (** ** Turning Set Operators into Propositional Connectives
+        The lemmas from [FSetFacts] will be used to break down
+        set operations into propositional formulas built over
+        the predicates [In] and [E.eq] applied only to
+        variables.  We are going to use them with [autorewrite].
+        *)
+
+    Hint Rewrite
+      F.empty_iff F.singleton_iff F.add_iff F.remove_iff
+      F.union_iff F.inter_iff F.diff_iff
+    : set_simpl.
+
+    (** ** Decidability of FSet Propositions *)
+
+    (** [In] is decidable. *)
+    Lemma dec_In : forall x s,
+      decidable (In x s).
+    Proof.
+      red; intros; generalize (F.mem_iff s x); case (mem x s); intuition.
+    Qed.
+
+    (** [E.eq] is decidable. *)
+    Lemma dec_eq : forall (x y : E.t),
+      decidable (E.eq x y).
+    Proof.
+      red; intros x y; destruct (E.eq_dec x y); auto.
+    Qed.
+
+    (** The hint database [FSet_decidability] will be given to
+        the [push_neg] tactic from the module [Negation]. *)
+    Hint Resolve dec_In dec_eq : FSet_decidability.
+
+    (** ** Normalizing Propositions About Equality
+        We have to deal with the fact that [E.eq] may be
+        convertible with Coq's equality.  Thus, we will find the
+        following tactics useful to replace one form with the
+        other everywhere. *)
+
+    (** The next tactic, [Logic_eq_to_E_eq], mentions the term
+        [E.t]; thus, we must ensure that [E.t] is used in favor
+        of any other convertible but syntactically distinct
+        term. *)
+    Ltac change_to_E_t :=
+      repeat (
+        match goal with
+        | H : ?T |- _ =>
+          progress (change T with E.t in H);
+          repeat (
+            match goal with
+            | J : _ |- _ => progress (change T with E.t in J)
+            | |- _ => progress (change T with E.t)
+            end )
+        end).
+
+    (** These two tactics take us from Coq's built-in equality
+        to [E.eq] (and vice versa) when possible. *)
+
+    Ltac Logic_eq_to_E_eq :=
+      repeat (
+        match goal with
+        | H: _ |- _ =>
+          progress (change (@Logic.eq E.t) with E.eq in H)
+        | |- _ =>
+          progress (change (@Logic.eq E.t) with E.eq)
+        end).
+
+    Ltac E_eq_to_Logic_eq :=
+      repeat (
+        match goal with
+        | H: _ |- _ =>
+          progress (change E.eq with (@Logic.eq E.t) in H)
+        | |- _ =>
+          progress (change E.eq with (@Logic.eq E.t))
+        end).
+
+    (** This tactic works like the built-in tactic [subst], but
+        at the level of set element equality (which may not be
+        the convertible with Coq's equality). *)
+    Ltac substFSet :=
+      repeat (
+        match goal with
+        | H: E.eq ?x ?y |- _ => rewrite H in *; clear H
+        end).
+
+    (** ** Considering Decidability of Base Propositions
+        This tactic adds assertions about the decidability of
+        [E.eq] and [In] to the context.  This is necessary for
+        the completeness of the [fsetdec] tactic.  However, in
+        order to minimize the cost of proof search, we should be
+        careful to not add more than we need.  Once negations
+        have been pushed to the leaves of the propositions, we
+        only need to worry about decidability for those base
+        propositions that appear in a negated form. *)
+    Ltac assert_decidability :=
+      (** We actually don't want these rules to fire if the
+          syntactic context in the patterns below is trivially
+          empty, but we'll just do some clean-up at the
+          afterward.  *)
+      repeat (
+        match goal with
+        | H: context [~ E.eq ?x ?y] |- _ =>
+          assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq)
+        | H: context [~ In ?x ?s] |- _ =>
+          assert new (In x s \/ ~ In x s) by (apply dec_In)
+        | |- context [~ E.eq ?x ?y] =>
+          assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq)
+        | |- context [~ In ?x ?s] =>
+          assert new (In x s \/ ~ In x s) by (apply dec_In)
+        end);
+      (** Now we eliminate the useless facts we added (because
+          they would likely be very harmful to performance). *)
+      repeat (
+        match goal with
+        | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H
+        end).
+
+    (** ** Handling [Empty], [Subset], and [Equal]
+        This tactic instantiates universally quantified
+        hypotheses (which arise from the unfolding of [Empty],
+        [Subset], and [Equal]) for each of the set element
+        expressions that is involved in some membership or
+        equality fact.  Then it throws away those hypotheses,
+        which should no longer be needed. *)
+    Ltac inst_FSet_hypotheses :=
+      repeat (
+        match goal with
+        | H : forall a : E.t, _,
+          _ : context [ In ?x _ ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ In ?x _ ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _,
+          _ : context [ E.eq ?x _ ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ E.eq ?x _ ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _,
+          _ : context [ E.eq _ ?x ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ E.eq _ ?x ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        end);
+      repeat (
+        match goal with
+        | H : forall a : E.t, _ |- _ =>
+          clear H
+        end).
+
+    (** ** The Core [fsetdec] Auxiliary Tactics *)
+
+    (** Here is the crux of the proof search.  Recursion through
+        [intuition]!  (This will terminate if I correctly
+        understand the behavior of [intuition].) *)
+    Ltac fsetdec_rec :=
+      try (match goal with
+      | H: E.eq ?x ?x -> False |- _ => destruct H
+      end);
+      (reflexivity ||
+      contradiction ||
+      (progress substFSet; intuition fsetdec_rec)).
+
+    (** If we add [unfold Empty, Subset, Equal in *; intros;] to
+        the beginning of this tactic, it will satisfy the same
+        specification as the [fsetdec] tactic; however, it will
+        be much slower than necessary without the pre-processing
+        done by the wrapper tactic [fsetdec]. *)
+    Ltac fsetdec_body :=
+      inst_FSet_hypotheses;
+      autorewrite with set_simpl in *;
+      push not in * using FSet_decidability;
+      substFSet;
+      assert_decidability;
+      auto using E.eq_refl;
+      (intuition fsetdec_rec) ||
+      fail 1
+        "because the goal is beyond the scope of this tactic".
+
+  End FSetDecideAuxiliary.
+  Import FSetDecideAuxiliary.
+
+  (** * The [fsetdec] Tactic
+      Here is the top-level tactic (the only one intended for
+      clients of this library).  It's specification is given at
+      the top of the file. *)
+  Ltac fsetdec :=
+    (** We first unfold any occurrences of [iff]. *)
+    unfold iff in *;
+    (** We fold occurrences of [not] because it is better for
+        [intros] to leave us with a goal of [~ P] than a goal of
+        [False]. *)
+    fold any not; intros;
+    (** Now we decompose conjunctions, which will allow the
+        [discard_nonFSet] and [assert_decidability] tactics to
+        do a much better job. *)
+    decompose records;
+    discard_nonFSet;
+    (** We unfold these defined propositions on finite sets.  If
+        our goal was one of them, then have one more item to
+        introduce now. *)
+    unfold Empty, Subset, Equal in *; intros;
+    (** We now want to get rid of all uses of [=] in favor of
+        [E.eq].  However, the best way to eliminate a [=] is in
+        the context is with [subst], so we will try that first.
+        In fact, we may as well convert uses of [E.eq] into [=]
+        when possible before we do [subst] so that we can even
+        more mileage out of it.  Then we will convert all
+        remaining uses of [=] back to [E.eq] when possible.  We
+        use [change_to_E_t] to ensure that we have a canonical
+        name for set elements, so that [Logic_eq_to_E_eq] will
+        work properly.  *)
+    change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq;
+    (** The next optimization is to swap a negated goal with a
+        negated hypothesis when possible.  Any swap will improve
+        performance by eliminating the total number of
+        negations, but we will get the maximum benefit if we
+        swap the goal with a hypotheses mentioning the same set
+        element, so we try that first.  If we reach the fourth
+        branch below, we attempt any swap.  However, to maintain
+        completeness of this tactic, we can only perform such a
+        swap with a decidable proposition; hence, we first test
+        whether the hypothesis is an [FSet_elt_Prop], noting
+        that any [FSet_elt_Prop] is decidable. *)
+    pull not using FSet_decidability;
+    unfold not in *;
+    match goal with
+    | H: (In ?x ?r) -> False |- (In ?x ?s) -> False =>
+      contradict H; fsetdec_body
+    | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False =>
+      contradict H; fsetdec_body
+    | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False =>
+      contradict H; fsetdec_body
+    | H: ?P -> False |- ?Q -> False =>
+      if prop (FSet_elt_Prop P) holds by
+        (auto 100 with FSet_Prop)
+      then (contradict H; fsetdec_body)
+      else fsetdec_body
+    | |- _ =>
+      fsetdec_body
+    end.
+
+  (** * Examples *)
+
+  Module FSetDecideTestCases.
+
+    Lemma test_eq_trans_1 : forall x y z s,
+      E.eq x y ->
+      ~ ~ E.eq z y ->
+      In x s ->
+      In z s.
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_trans_2 : forall x y z r s,
+      In x (singleton y) ->
+      ~ In z r ->
+      ~ ~ In z (add y r) ->
+      In x s ->
+      In z s.
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_neq_trans_1 : forall w x y z s,
+      E.eq x w ->
+      ~ ~ E.eq x y ->
+      ~ E.eq y z ->
+      In w s ->
+      In w (remove z s).
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s,
+      In x (singleton w) ->
+      ~ In x r1 ->
+      In x (add y r1) ->
+      In y r2 ->
+      In y (remove z r2) ->
+      In w s ->
+      In w (remove z s).
+    Proof. fsetdec. Qed.
+
+    Lemma test_In_singleton : forall x,
+      In x (singleton x).
+    Proof. fsetdec. Qed.
+
+    Lemma test_Subset_add_remove : forall x s,
+      s [<=] (add x (remove x s)).
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_disjunction : forall w x y z,
+      In w (add x (add y (singleton z))) ->
+      E.eq w x \/ E.eq w y \/ E.eq w z.
+    Proof. fsetdec. Qed.
+
+    Lemma test_not_In_disj : forall x y s1 s2 s3 s4,
+      ~ In x (union s1 (union s2 (union s3 (add y s4)))) ->
+      ~ (In x s1 \/ In x s4 \/ E.eq y x).
+    Proof. fsetdec. Qed.
+
+    Lemma test_not_In_conj : forall x y s1 s2 s3 s4,
+      ~ In x (union s1 (union s2 (union s3 (add y s4)))) ->
+      ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x.
+    Proof. fsetdec. Qed.
+
+    Lemma test_iff_conj : forall a x s s',
+    (In a s' <-> E.eq x a \/ In a s) ->
+    (In a s' <-> In a (add x s)).
+    Proof. fsetdec. Qed.
+
+    Lemma test_set_ops_1 : forall x q r s,
+      (singleton x) [<=] s ->
+      Empty (union q r) ->
+      Empty (inter (diff s q) (diff s r)) ->
+      ~ In x s.
+    Proof. fsetdec. Qed.
+
+    Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4,
+      Empty s1 ->
+      In x2 (add x1 s1) ->
+      In x3 s2 ->
+      ~ In x3 (remove x2 s2) ->
+      ~ In x4 s3 ->
+      In x4 (add x3 s3) ->
+      In x1 s4 ->
+      Subset (add x4 s4) s4.
+    Proof. fsetdec. Qed.
+
+    Lemma test_too_complex : forall x y z r s,
+      E.eq x y ->
+      (In x (singleton y) -> r [<=] s) ->
+      In z r ->
+      In z s.
+    Proof.
+      (** [fsetdec] is not intended to solve this directly. *)
+      intros until s; intros Heq H Hr; lapply H; fsetdec.
+    Qed.
+
+    Lemma function_test_1 :
+      forall (f : t -> t),
+      forall (g : elt -> elt),
+      forall (s1 s2 : t),
+      forall (x1 x2 : elt),
+      Equal s1 (f s2) ->
+      E.eq x1 (g (g x2)) ->
+      In x1 s1 ->
+      In (g (g x2)) (f s2).
+    Proof. fsetdec. Qed.
+
+    Lemma function_test_2 :
+      forall (f : t -> t),
+      forall (g : elt -> elt),
+      forall (s1 s2 : t),
+      forall (x1 x2 : elt),
+      Equal s1 (f s2) ->
+      E.eq x1 (g x2) ->
+      In x1 s1 ->
+      g x2 = g (g x2) ->
+      In (g (g x2)) (f s2).
+    Proof.
+      (** [fsetdec] is not intended to solve this directly. *)
+      intros until 3. intros g_eq. rewrite <- g_eq. fsetdec.
+    Qed.
+
+  End FSetDecideTestCases.
+
+End WDecide.
+
+Require Import FSetInterface.
+
+(** Now comes a special version dedicated to full sets. For this 
+    one, only one argument [(M:S)] is necessary. *)
+
+Module Decide (M : S).
+  Module D:=OT_as_DT M.E.
+  Module WD := WDecide D M.
+  Ltac fsetdec := WD.fsetdec.
+End Decide.
\ No newline at end of file
diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v
index d7062d5a..a397cc28 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 8853 2006-05-23 18:17:38Z herbelin $ *)
+(* $Id: FSetEqProperties.v 11064 2008-06-06 17:00:52Z letouzey $ *)
 
 (** * Finite sets library *)
 
@@ -17,21 +17,12 @@
     [mem x s=true] instead of [In x s], 
     [equal s s'=true] instead of [Equal s s'], etc. *)
 
+Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx.
 
-Require Import FSetProperties.
-Require Import Zerob.
-Require Import Sumbool.
-Require Import Omega.
-
-Module EqProperties (M:S).
+Module WEqProperties (Import E:DecidableType)(M:WSfun E). 
+Module Import MP := WProperties E M.
+Import FM Dec.F.
 Import M.
-Import Logic. (* to unmask [eq] *)  
-Import Peano. (* to unmask [lt] *)
-  
-Module ME := OrderedTypeFacts E.  
-Module MP := Properties M.
-Import MP.
-Import MP.FM.
 
 Definition Add := MP.Add.
 
@@ -76,7 +67,7 @@ Qed.
   
 Lemma empty_mem: mem x empty=false.
 Proof. 
-rewrite <- not_mem_iff; auto.
+rewrite <- not_mem_iff; auto with set.
 Qed.
 
 Lemma is_empty_equal_empty: is_empty s = equal s empty.
@@ -88,17 +79,17 @@ Qed.
   
 Lemma choose_mem_1: choose s=Some x -> mem x s=true.
 Proof.  
-auto.
+auto with set.
 Qed.
 
 Lemma choose_mem_2: choose s=None -> is_empty s=true.
 Proof.
-auto.
+auto with set.
 Qed.
 
 Lemma add_mem_1: mem x (add x s)=true.
 Proof.
-auto.
+auto with set.
 Qed.  
  
 Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s.
@@ -108,7 +99,7 @@ Qed.
 
 Lemma remove_mem_1: mem x (remove x s)=false.
 Proof. 
-rewrite <- not_mem_iff; auto.
+rewrite <- not_mem_iff; auto with set.
 Qed. 
  
 Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s.
@@ -216,7 +207,7 @@ Proof.
 intros.
 generalize (@choose_1 s) (@choose_2 s).
 destruct (choose s);intros.
-exists e;auto.
+exists e;auto with set.
 generalize (H1 (refl_equal None)); clear H1.
 intros; rewrite (is_empty_1 H1) in H; discriminate.
 Qed.
@@ -233,7 +224,7 @@ Qed.
 Lemma add_mem_3: 
  mem y s=true -> mem y (add x s)=true.
 Proof.
-auto.
+auto with set.
 Qed.
 
 Lemma add_equal: 
@@ -260,7 +251,7 @@ Qed.
 Lemma add_remove: 
  mem x s=true -> equal (add x (remove x s)) s=true.
 Proof.
-intros; apply equal_1; apply add_remove; auto.
+intros; apply equal_1; apply add_remove; auto with set.
 Qed.
 
 Lemma remove_add: 
@@ -275,9 +266,9 @@ Qed.
 Lemma is_empty_cardinal: is_empty s = zerob (cardinal s).
 Proof.
 intros; apply bool_1; split; intros.
-rewrite cardinal_1; simpl; auto.
+rewrite MP.cardinal_1; simpl; auto with set.
 assert (cardinal s = 0) by (apply zerob_true_elim; auto).
-auto.
+auto with set.
 Qed.
 
 (** Properties of [singleton] *)
@@ -290,12 +281,12 @@ Qed.
 Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false.
 Proof.
 intros; rewrite singleton_b.
-unfold ME.eqb; destruct (ME.eq_dec x y); intuition.
+unfold eqb; destruct (eq_dec x y); intuition.
 Qed.
 
 Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y.
 Proof.
-auto.
+intros; apply singleton_1; auto with set.
 Qed.
 
 (** Properties of [union] *)
@@ -358,7 +349,7 @@ Lemma union_subset_3:
  subset s s''=true -> subset s' s''=true -> 
   subset (union s s') s''=true.
 Proof.
-intros; apply subset_1; apply union_subset_3; auto.
+intros; apply subset_1; apply union_subset_3; auto with set.
 Qed.
 
 (** Properties of [inter] *) 
@@ -433,7 +424,7 @@ Lemma inter_subset_3:
  subset s'' s=true -> subset s'' s'=true -> 
   subset s'' (inter s s')=true.
 Proof.
-intros; apply subset_1; apply inter_subset_3; auto.
+intros; apply subset_1; apply inter_subset_3; auto with set.
 Qed.
 
 (** Properties of [diff] *)
@@ -478,45 +469,37 @@ Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1
    add_mem_3 add_equal remove_mem_3 remove_equal : set.
 
 
-(** General recursion principes based on [cardinal] *)
+(** General recursion principle *)
 
-Lemma cardinal_set_rec:  forall (P:t->Type),
+Lemma set_rec:  forall (P:t->Type),
  (forall s s', equal s s'=true -> P s -> P s') -> 
  (forall s x, mem x s=false -> P s -> P (add x s)) -> 
- P empty -> forall n s, cardinal s=n -> P s.
+ P empty -> forall s, P s.
 Proof.
 intros.
-apply cardinal_induction with n; auto; intros.
+apply set_induction; auto; intros.
 apply X with empty; auto with set.
 apply X with (add x s0); auto with set.
-apply equal_1; intro a; rewrite add_iff; rewrite (H1 a); tauto.
+apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto.
 apply X0; auto with set; apply mem_3; auto.
 Qed.
 
-Lemma set_rec:  forall (P:t->Type),
- (forall s s', equal s s'=true -> P s -> P s') ->
- (forall s x, mem x s=false -> P s -> P (add x s)) -> 
- P empty -> forall s, P s.
-Proof.
-intros;apply cardinal_set_rec with (cardinal s);auto.
-Qed.
-
 (** Properties of [fold] *)
 
 Lemma exclusive_set : forall s s' x,
- ~In x s\/~In x s' <-> mem x s && mem x s'=false.
+ ~(In x s/\In x s') <-> mem x s && mem x s'=false.
 Proof.
-intros; do 2 rewrite not_mem_iff.
+intros; do 2 rewrite mem_iff.
 destruct (mem x s); destruct (mem x s'); intuition.
 Qed.
 
 Section Fold. 
-Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA).
+Variables (A:Type)(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).
 Variables (s s':t)(x:elt).
  
-Lemma fold_empty: eqA (fold f empty i) i.
+Lemma fold_empty: (fold f empty i) = i.
 Proof. 
 apply fold_empty; auto.
 Qed.
@@ -524,7 +507,7 @@ Qed.
 Lemma fold_equal: 
  equal s s'=true -> eqA (fold f s i) (fold f s' i).
 Proof. 
-intros; apply fold_equal with (eqA:=eqA); auto.
+intros; apply fold_equal with (eqA:=eqA); auto with set.
 Qed.
    
 Lemma fold_add: 
@@ -537,13 +520,13 @@ Qed.
 Lemma add_fold: 
   mem x s=true -> eqA (fold f (add x s) i) (fold f s i).
 Proof.
-intros; apply add_fold with (eqA:=eqA); auto.
+intros; apply add_fold with (eqA:=eqA); auto with set.
 Qed.
 
 Lemma remove_fold_1: 
  mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i).
 Proof.
-intros; apply remove_fold_1 with (eqA:=eqA); auto.
+intros; apply remove_fold_1 with (eqA:=eqA); auto with set.
 Qed.
 
 Lemma remove_fold_2: 
@@ -581,13 +564,13 @@ Qed.
 Lemma remove_cardinal_1: 
  forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s.
 Proof.
-intros; apply remove_cardinal_1; auto.
+intros; apply remove_cardinal_1; auto with set.
 Qed.
 
 Lemma remove_cardinal_2: 
  forall s x, mem x s=false -> cardinal (remove x s)=cardinal s.
 Proof.
-auto with set.
+intros; apply Equal_cardinal; apply equal_2; auto with set.
 Qed.
 
 Lemma union_cardinal: 
@@ -601,7 +584,7 @@ Qed.
 Lemma subset_cardinal: 
  forall s s', subset s s'=true -> cardinal s<=cardinal s'.
 Proof.
-intros; apply subset_cardinal; auto.
+intros; apply subset_cardinal; auto with set.
 Qed.
 
 Section Bool.
@@ -644,7 +627,7 @@ Proof.
 intros; apply bool_1; split; intros. 
 destruct (exists_2 Comp H) as (a,(Ha1,Ha2)).
 apply bool_6.
-red; intros; apply (@is_empty_2 _ H0 a); auto.
+red; intros; apply (@is_empty_2 _ H0 a); auto with set.
 generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)).
 destruct (choose (filter f s)).
 intros H0 _; apply exists_1; auto.
@@ -656,13 +639,30 @@ Qed.
 Lemma partition_filter_1: 
  forall s, equal (fst (partition f s)) (filter f s)=true.
 Proof. 
-auto.
+auto with set.
 Qed.
 
 Lemma partition_filter_2: 
  forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true.
 Proof. 
-auto.
+auto with set.
+Qed.
+
+Lemma filter_add_1 : forall s x, f x = true -> 
+ filter f (add x s) [=] add x (filter f s). 
+Proof.
+red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff.
+intuition.
+rewrite <- H; apply Comp; auto.
+Qed.
+
+Lemma filter_add_2 : forall s x, f x = false -> 
+ filter f (add x s) [=] filter f s. 
+Proof.
+red; intros; do 2 (rewrite filter_iff; auto); set_iff.
+intuition.
+assert (f x = f a) by (apply Comp; auto).
+rewrite H in H1; rewrite H2 in H1; discriminate.
 Qed.
 
 Lemma add_filter_1 : forall s s' x, 
@@ -837,6 +837,8 @@ Section Sum.
 (** Adding a valuation function on all elements of a set. *)
 
 Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. 
+Notation compat_opL := (compat_op E.eq (@Logic.eq _)).
+Notation transposeL := (transpose (@Logic.eq _)).
 
 Lemma sum_plus : 
   forall f g, compat_nat E.eq f -> compat_nat E.eq g -> 
@@ -844,12 +846,12 @@ Lemma sum_plus :
 Proof.
 unfold sum.
 intros f g Hf Hg.
-assert (fc : compat_op E.eq (@eq _) (fun x:elt =>plus (f x))).  auto.
-assert (ft : transpose (@eq _) (fun x:elt =>plus (f x))). red; intros; omega.
-assert (gc : compat_op E.eq (@eq _) (fun x:elt => plus (g x))). auto.
-assert (gt : transpose (@eq _) (fun x:elt =>plus (g x))). red; intros; omega.
-assert (fgc : compat_op E.eq (@eq _) (fun x:elt =>plus ((f x)+(g x)))). auto.
-assert (fgt : transpose (@eq _) (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega.
+assert (fc : compat_opL (fun x:elt =>plus (f x))).  auto.
+assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega.
+assert (gc : compat_opL (fun x:elt => plus (g x))). auto.
+assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega.
+assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). auto.
+assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega.
 assert (st := gen_st nat).
 intros s;pattern s; apply set_rec.
 intros.
@@ -858,7 +860,7 @@ rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H).
 rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto.
 intros; do 3 (rewrite (fold_add _ _ st);auto).
 rewrite H0;simpl;omega.
-intros; do 3 rewrite (fold_empty _ _ st);auto.
+do 3 rewrite fold_empty;auto.
 Qed.
 
 Lemma sum_filter : forall f, (compat_bool E.eq f) -> 
@@ -866,11 +868,11 @@ Lemma sum_filter : forall f, (compat_bool E.eq f) ->
 Proof.
 unfold sum; intros f Hf.
 assert (st := gen_st nat).
-assert (cc : compat_op E.eq (@eq _) (fun x => plus (if f x then 1 else 0))). 
- unfold compat_op; intros.
+assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). 
+ red; intros.
  rewrite (Hf x x' H); auto.
-assert (ct : transpose (@eq _) (fun x => plus (if f x then 1 else 0))).
- unfold transpose; intros; omega.
+assert (ct : transposeL (fun x => plus (if f x then 1 else 0))).
+ red; intros; omega.
 intros s;pattern s; apply set_rec.
 intros.
 change elt with E.t.
@@ -883,14 +885,14 @@ assert (~ In x (filter f s0)).
 case (f x); simpl; intros.
 rewrite (MP.cardinal_2 H1 (H2 (refl_equal true) (MP.Add_add s0 x))); auto.
 rewrite <- (MP.Equal_cardinal (H3 (refl_equal false) (MP.Add_add s0 x))); auto.
-intros; rewrite (fold_empty _ _ st);auto.
+intros; rewrite fold_empty;auto.
 rewrite MP.cardinal_1; auto.
 unfold Empty; intros.
 rewrite filter_iff; auto; set_iff; tauto.
 Qed.
 
 Lemma fold_compat : 
-  forall (A:Set)(eqA:A->A->Prop)(st:(Setoid_Theory _ eqA))
+  forall (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA)
   (f g:elt->A->A),
   (compat_op E.eq eqA f) -> (transpose eqA f) -> 
   (compat_op E.eq eqA g) -> (transpose eqA g) -> 
@@ -903,26 +905,35 @@ trans_st (fold f s0 i).
 apply fold_equal with (eqA:=eqA); auto.
 rewrite equal_sym; auto.
 trans_st (fold g s0 i).
-apply H0; intros; apply H1; auto.
-elim  (equal_2 H x); auto; intros.
-apply fold_equal with (eqA:=eqA); auto.
+apply H0; intros; apply H1; auto with set.
+elim  (equal_2 H x); auto with set; intros.
+apply fold_equal with (eqA:=eqA); auto with set.
 trans_st (f x (fold f s0 i)).
-apply fold_add with (eqA:=eqA); auto.
-trans_st (g x (fold f s0 i)).
-trans_st (g x (fold g s0 i)).
+apply fold_add with (eqA:=eqA); auto with set.
+trans_st (g x (fold f s0 i)); auto with set.
+trans_st (g x (fold g s0 i)); auto with set.
 sym_st; apply fold_add with (eqA:=eqA); auto.
-trans_st i; [idtac | sym_st ]; apply fold_empty; auto.
+do 2 rewrite fold_empty; refl_st.
 Qed.
 
 Lemma sum_compat : 
   forall f g, compat_nat E.eq f -> compat_nat E.eq g -> 
   forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s.
 intros.
-unfold sum; apply (fold_compat _ (@eq nat)); auto.
-unfold transpose; intros; omega.
-unfold transpose; intros; omega.
+unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto.
+red; intros; omega.
+red; intros; omega.
 Qed.
 
 End Sum.
 
-End EqProperties. 
+End WEqProperties.
+
+
+(** Now comes a special version dedicated to full sets. For this
+    one, only one argument [(M:S)] is necessary. *)
+
+Module EqProperties (M:S).
+  Module D := OT_as_DT M.E.
+  Include WEqProperties D M.
+End EqProperties.
diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v
index aa57f066..b4b834b1 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 8882 2006-05-31 21:55:30Z letouzey $ *)
+(* $Id: FSetFacts.v 10765 2008-04-08 16:15:23Z msozeau $ *)
 
 (** * Finite sets library *)
 
@@ -16,16 +16,19 @@
   Moreover, we prove that [E.Eq] and [Equal] are setoid equalities.
 *)
 
+Require Import DecidableTypeEx.
 Require Export FSetInterface. 
 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] *)
+(** First, a functor for Weak Sets. Since the signature [WS] includes
+    an EqualityType and not a stronger DecidableType, this functor 
+    should take two arguments in order to compensate this. *)
+
+Module WFacts (Import E : DecidableType)(Import M : WSfun E).
+
+Notation eq_dec := E.eq_dec.
+Definition eqb x y := if eq_dec x y then true else false.
 
 (** * Specifications written using equivalences *)
 
@@ -259,6 +262,8 @@ symmetry.
 rewrite H0; intros.
 destruct H1 as (_,H1).
 apply H1; auto.
+rewrite H2.
+rewrite InA_alt; eauto.
 Qed.
 
 Lemma exists_b : compat_bool E.eq f -> 
@@ -271,7 +276,8 @@ destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros.
 rewrite <- H1; intros.
 destruct H0 as (H0,_).
 destruct H0 as (a,(Ha1,Ha2)); auto.
-exists a; auto.
+exists a; split; auto.
+rewrite H2; rewrite InA_alt; eauto.
 symmetry.
 rewrite H0.
 destruct H1 as (_,H1).
@@ -289,17 +295,25 @@ End BoolSpec.
 
 Definition E_ST : Setoid_Theory elt E.eq.
 Proof.
-constructor; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans].
+constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans].
 Qed.
 
-Add Setoid elt E.eq E_ST as EltSetoid.
-
 Definition Equal_ST : Setoid_Theory t Equal.
 Proof. 
-constructor; [apply eq_refl | apply eq_sym | apply eq_trans].
+constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans].
 Qed.
 
-Add Setoid t Equal Equal_ST as EqualSetoid.
+Add Relation elt E.eq 
+ reflexivity proved by E.eq_refl 
+ symmetry proved by E.eq_sym
+ transitivity proved by E.eq_trans 
+ as EltSetoid.
+
+Add Relation t Equal 
+ reflexivity proved by eq_refl 
+ symmetry proved by eq_sym
+ transitivity proved by eq_trans 
+ as EqualSetoid.
 
 Add Morphism In with signature E.eq ==> Equal ==> iff as In_m.
 Proof.
@@ -325,7 +339,7 @@ exact (H1 (refl_equal true) _ Ha).
 Qed.
 
 Add Morphism Empty with signature Equal ==> iff as Empty_m.
-Proof. 
+Proof.
 intros; do 2 rewrite is_empty_iff; rewrite H; intuition.
 Qed.
 
@@ -340,7 +354,9 @@ Qed.
 Add Morphism singleton : singleton_m.
 Proof.
 unfold Equal; intros x y H a.
-do 2 rewrite singleton_iff; split; order.
+do 2 rewrite singleton_iff; split; intros.
+apply E.eq_trans with x; auto.
+apply E.eq_trans with y; auto.
 Qed.
 
 Add Morphism add : add_m.
@@ -396,6 +412,63 @@ rewrite H in H1; rewrite H0 in H1; intuition.
 rewrite H in H1; rewrite H0 in H1; intuition.
 Qed.
 
+
+(* [Subset] is a setoid order *)
+
+Lemma Subset_refl : forall s, s[<=]s.
+Proof. red; auto. Defined.
+
+Lemma Subset_trans : forall s s' s'', s[<=]s'->s'[<=]s''->s[<=]s''.
+Proof. unfold Subset; eauto. Defined.
+
+Add Relation t Subset 
+ reflexivity proved by Subset_refl
+ transitivity proved by Subset_trans
+ as SubsetSetoid.
+(* NB: for the moment, it is important to use Defined and not Qed in 
+   the two previous lemmas, in order to allow conversion of 
+   SubsetSetoid coming from separate Facts modules. See bug #1738. *)
+
+Instance In_s_m : Morphism (E.eq ==> Subset ++> impl) In | 1.
+Proof.
+  simpl_relation. eauto with set.
+Qed.
+
+Add Morphism Empty with signature Subset --> impl as Empty_s_m.
+Proof.
+unfold Subset, Empty, impl; firstorder.
+Qed.
+
+Add Morphism add with signature E.eq ==> Subset ++> Subset as add_s_m.
+Proof.
+unfold Subset; intros x y H s s' H0 a.
+do 2 rewrite add_iff; rewrite H; intuition.
+Qed.
+
+Add Morphism remove with signature E.eq ==> Subset ++> Subset as remove_s_m.
+Proof.
+unfold Subset; intros x y H s s' H0 a.
+do 2 rewrite remove_iff; rewrite H; intuition.
+Qed.
+
+Add Morphism union with signature Subset ++> Subset ++> Subset as union_s_m.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite union_iff; intuition.
+Qed.
+
+Add Morphism inter with signature Subset ++> Subset ++> Subset as inter_s_m.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite inter_iff; intuition.
+Qed.
+
+Add Morphism diff with signature Subset ++> Subset --> Subset as diff_s_m.
+Proof.
+unfold Subset; intros s s' H s'' s''' H0 a.
+do 2 rewrite diff_iff; intuition.
+Qed.
+
 (* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism
    without additional hypothesis on [f]. For instance: *)
 
@@ -405,6 +478,12 @@ Proof.
 unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto.
 Qed.
 
+Lemma filter_subset : forall f, compat_bool E.eq f -> 
+  forall s s', s[<=]s' -> filter f s [<=] filter f s'.
+Proof.
+unfold Subset; intros; rewrite filter_iff in *; intuition.
+Qed.
+
 (* For [elements], [min_elt], [max_elt] and [choose], we would need setoid 
    structures on [list elt] and [option elt]. *)
 
@@ -412,4 +491,15 @@ Qed.
 Add Morphism cardinal ; cardinal_m.
 *)
 
+End WFacts.
+
+
+(** Now comes a special version dedicated to full sets. For this 
+    one, only one argument [(M:S)] is necessary. *)
+
+Module Facts (Import M:S).
+  Module D:=OT_as_DT M.E.
+  Include WFacts D M.
+
 End Facts.
+
diff --git a/theories/FSets/FSetFullAVL.v b/theories/FSets/FSetFullAVL.v
new file mode 100644
index 00000000..1fc109f3
--- /dev/null
+++ b/theories/FSets/FSetFullAVL.v
@@ -0,0 +1,1125 @@
+(***********************************************************************)
+(*  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: FSetFullAVL.v 10739 2008-04-01 14:45:20Z herbelin $ *)
+
+(** * FSetFullAVL
+   
+   This file contains some complements to [FSetAVL].
+
+   - Functor [AvlProofs] proves that trees of [FSetAVL] are not only 
+   binary search trees, but moreover well-balanced ones. This is done
+   by proving that all operations preserve the balancing.
+
+   - Functor [OcamlOps] contains variants of [union], [subset], 
+   [compare] and [equal] that are faithful to the original ocaml codes,
+   while the versions in FSetAVL have been adapted to perform only
+   structural recursive code. 
+  
+   - Finally, we pack the previous elements in a [Make] functor 
+   similar to the one of [FSetAVL], but richer.
+*)
+
+Require Import Recdef FSetInterface FSetList ZArith Int FSetAVL.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module AvlProofs (Import I:Int)(X:OrderedType).
+Module Import Raw := Raw I X.
+Import Raw.Proofs.
+Module Import II := MoreInt I.
+Open Local Scope pair_scope.
+Open Local Scope Int_scope.
+
+(** * 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 *)
+
+Inductive avl : tree -> Prop :=
+  | RBLeaf : avl Leaf
+  | RBNode : forall x l r h, avl l -> avl r ->
+      -(2) <= height l - height r <= 2 ->
+      h = max (height l) (height r) + 1 -> 
+      avl (Node l x r h).
+
+(** * Automation and dedicated tactics *)
+
+Hint Constructors avl.
+
+(** A tactic for cleaning hypothesis after use of functional induction. *)
+
+Ltac clearf :=
+ match goal with 
+  | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf
+  | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf
+  | _ => idtac
+ end.
+
+(** Tactics about [avl] *)
+
+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.
+
+(** Results about [height] *)
+
+Lemma height_0 : forall s, avl s -> height s = 0 -> s = Leaf.
+Proof.
+ destruct 1; intuition; simpl in *.
+ avl_nns; simpl in *; elimtype False; omega_max.
+Qed.
+
+(** * Results about [avl] *)
+
+Lemma avl_node : 
+ forall x l r, 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.
+
+
+(** empty *)
+
+Lemma empty_avl : avl empty.
+Proof. 
+ auto.
+Qed.
+
+(** singleton *)
+
+Lemma singleton_avl : forall x : elt, avl (singleton x).
+Proof.
+ unfold singleton; intro.
+ constructor; auto; try red; simpl; omega_max.
+Qed.
+
+(** create *)
+
+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; auto.
+Qed.
+
+(** bal *)
+
+Lemma bal_avl : forall l x r, avl l -> avl r -> 
+ -(3) <= height l - height r <= 3 -> avl (bal l x r).
+Proof.
+ intros l x r; functional induction bal l x r; intros; clearf;
+ inv avl; simpl in *; 
+ match goal with |- avl (assert_false _ _ _) => avl_nns
+  | _ => repeat apply create_avl; simpl in *; auto
+ end; 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.
+ intros l x r; functional induction bal l x r; intros; clearf;
+ 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.
+ intros l x r; functional induction bal l x r; intros; clearf;
+ inv avl; simpl in *; omega_max.
+Qed.
+
+Ltac omega_bal := match goal with 
+  | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?r ] => 
+     generalize (bal_height_1 x H H') (bal_height_2 x H H'); 
+     omega_max
+  end.
+
+(** add *)
+
+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; destruct (add_avl_1 x H); auto.
+Qed.
+Hint Resolve add_avl.
+
+(** join *)
+
+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. 
+ join_tac.
+
+ split; simpl; auto. 
+ destruct (add_avl_1 x H0).
+ avl_nns; omega_max.
+ set (l:=Node ll lx lr lh) in *.
+ split; auto.
+ destruct (add_avl_1 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; destruct (join_avl_1 x H H0); auto.
+Qed.
+Hint Resolve join_avl.
+
+(** remove_min *)
+
+Lemma remove_min_avl_1 : forall l x r h, avl (Node l x r h) -> 
+ avl (remove_min l x r)#1 /\ 
+ 0 <= height (Node l x r h) - height (remove_min l x r)#1 <= 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.
+ inversion_clear H.
+ rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); 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 (remove_min l x r)#1. 
+Proof.
+ intros; destruct (remove_min_avl_1 H); auto.
+Qed.
+
+(** merge *)
+
+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); intros; 
+ try factornode _x _x0 _x1 _x2 as s1.
+ simpl; split; auto; avl_nns; omega_max.
+ simpl; split; auto; avl_nns; simpl in *; omega_max.
+ generalize (remove_min_avl_1 H0).
+ rewrite e1; destruct 1.
+ split.
+ apply bal_avl; auto.
+ simpl; omega_max.
+ simpl in *; 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; destruct (merge_avl_1 H H0 H1); auto.
+Qed.
+
+
+(** remove *)
+
+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); intros.
+ intuition; omega_max.
+ (* LT *)
+ inv avl.
+ destruct (IHt H0).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+ (* EQ *)
+ inv avl. 
+ generalize (merge_avl_1 H0 H1 H2).
+ intuition omega_max.
+ (* GT *)
+ inv avl.
+ destruct (IHt H1).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+Qed.
+
+Lemma remove_avl : forall s x, avl s -> avl (remove x s).
+Proof. 
+ intros; destruct (remove_avl_1 x H); auto.
+Qed.
+Hint Resolve remove_avl.
+
+(** concat *)
+
+Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2).
+Proof.
+ intros s1 s2; functional induction (concat s1 s2); auto.
+ intros; apply join_avl; auto.
+ generalize (remove_min_avl H0); rewrite e1; simpl; auto.
+Qed.
+Hint Resolve concat_avl.
+
+(** split *)
+
+Lemma split_avl : forall s x, avl s -> 
+  avl (split x s)#l /\ avl (split x s)#r.
+Proof. 
+ intros s x; functional induction (split x s); simpl; auto.
+ rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
+ simpl; inversion_clear 1; auto.
+ rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
+Qed.
+
+(** inter *)
+
+Lemma inter_avl : forall s1 s2, avl s1 -> avl s2 -> avl (inter s1 s2). 
+Proof.
+ intros s1 s2; functional induction inter s1 s2; auto; intros A1 A2;
+ generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; 
+ inv avl; auto.
+Qed.
+
+(** diff *)
+
+Lemma diff_avl : forall s1 s2, avl s1 -> avl s2 -> avl (diff s1 s2). 
+Proof. 
+ intros s1 s2; functional induction diff s1 s2; auto; intros A1 A2;
+ generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; 
+ inv avl; auto.
+Qed.
+
+(** union *)
+
+Lemma union_avl : forall s1 s2, avl s1 -> avl s2 -> avl (union s1 s2).
+Proof.
+ intros s1 s2; functional induction union s1 s2; auto; intros A1 A2;
+ generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; 
+ inv avl; auto.
+Qed.
+
+(** filter *)
+
+Lemma filter_acc_avl : forall f s acc, avl s -> avl acc -> 
+ avl (filter_acc f acc s).
+Proof.
+ induction s; simpl; auto.
+ intros.
+ inv avl.
+ destruct (f t); auto.
+Qed. 
+Hint Resolve filter_acc_avl.
+
+Lemma filter_avl : forall f s, avl s -> avl (filter f s). 
+Proof.
+ unfold filter; intros; apply filter_acc_avl; auto.
+Qed.
+
+(** partition *)
+
+Lemma partition_acc_avl_1 : forall f s acc, avl s -> 
+ avl acc#1 -> avl (partition_acc f acc s)#1.
+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 f s acc, avl s -> 
+ avl acc#2 -> avl (partition_acc f acc s)#2.
+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_avl_1 : forall f s, avl s -> avl (partition f s)#1. 
+Proof.
+ unfold partition; intros; apply partition_acc_avl_1; auto.
+Qed.
+
+Lemma partition_avl_2 : forall f s, avl s -> avl (partition f s)#2. 
+Proof.
+ unfold partition; intros; apply partition_acc_avl_2; auto.
+Qed.
+
+End AvlProofs.
+
+
+Module OcamlOps (Import I:Int)(X:OrderedType).
+Module Import AvlProofs := AvlProofs I X.
+Import Raw.
+Import Raw.Proofs.
+Import II.
+Open Local Scope pair_scope.
+Open Local Scope nat_scope.
+
+(** Properties of cardinal *)
+
+Lemma bal_cardinal : forall l x r, 
+ cardinal (bal l x r) = S (cardinal l + cardinal r).
+Proof.
+ intros l x r; functional induction bal l x r; intros; clearf;
+ simpl; auto with arith; romega with *.
+Qed.
+
+Lemma add_cardinal : forall x s, 
+ cardinal (add x s) <= S (cardinal s).
+Proof.
+ intros; functional induction add x s; simpl; auto with arith; 
+ rewrite bal_cardinal; romega with *.
+Qed.
+
+Lemma join_cardinal : forall l x r, 
+ cardinal (join l x r) <= S (cardinal l + cardinal r).
+Proof.
+ join_tac; auto with arith.
+ simpl; apply add_cardinal.
+ simpl; destruct X.compare; simpl; auto with arith.
+ generalize (bal_cardinal (add x ll) lx lr) (add_cardinal x ll); 
+  romega with *.
+ generalize (bal_cardinal ll lx (add x lr)) (add_cardinal x lr); 
+  romega with *.
+ generalize (bal_cardinal ll lx (join lr x (Node rl rx rr rh)))
+  (Hlr x (Node rl rx rr rh)); simpl; romega with *.
+ simpl S in *; generalize (bal_cardinal (join (Node ll lx lr lh) x rl) rx rr).
+ romega with *.
+Qed.
+
+Lemma split_cardinal_1 : forall x s, 
+ (cardinal (split x s)#l <= cardinal s)%nat.
+Proof.
+ intros x s; functional induction split x s; simpl; auto.
+ rewrite e1 in IHt; simpl in *.
+ romega with *.
+ romega with *.
+ rewrite e1 in IHt; simpl in *.
+ generalize (@join_cardinal l y rl); romega with *.
+Qed.
+
+Lemma split_cardinal_2 : forall x s, 
+ (cardinal (split x s)#r <= cardinal s)%nat.
+Proof.
+ intros x s; functional induction split x s; simpl; auto.
+ rewrite e1 in IHt; simpl in *.
+ generalize (@join_cardinal rl y r); romega with *.
+ romega with *.
+ rewrite e1 in IHt; simpl in *; romega with *.
+Qed.
+
+(** * [ocaml_union], an union faithful to the original ocaml code *)
+
+Definition cardinal2 (s:t*t) := (cardinal s#1 + cardinal s#2)%nat.
+
+Ltac ocaml_union_tac := 
+ intros; unfold cardinal2; simpl fst in *; simpl snd in *;
+ match goal with H: split ?x ?s = _ |- _ => 
+  generalize (split_cardinal_1 x s) (split_cardinal_2 x s); 
+  rewrite H; simpl; romega with *
+ end.
+
+Import Logic. (* Unhide eq, otherwise Function complains. *)
+
+Function ocaml_union (s : t * t) { measure cardinal2 s } : t  :=
+ match s with 
+  | (Leaf, Leaf) => s#2
+  | (Leaf, Node _ _ _ _) => s#2
+  | (Node _ _ _ _, Leaf) => s#1
+  | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) => 
+        if ge_lt_dec h1 h2 then
+          if eq_dec h2 1%I then add x2 s#1 else
+          let (l2',_,r2') := split x1 s#2 in 
+             join (ocaml_union (l1,l2')) x1 (ocaml_union (r1,r2'))
+        else
+          if eq_dec h1 1%I then add x1 s#2 else
+          let (l1',_,r1') := split x2 s#1 in 
+             join (ocaml_union (l1',l2)) x2 (ocaml_union (r1',r2))
+ end.
+Proof.
+abstract ocaml_union_tac.
+abstract ocaml_union_tac.
+abstract ocaml_union_tac.
+abstract ocaml_union_tac.
+Defined.
+
+Lemma ocaml_union_in : forall s y, 
+ bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 ->
+ (In y (ocaml_union s) <-> In y s#1 \/ In y s#2).
+Proof.
+ intros s; functional induction ocaml_union s; intros y B1 A1 B2 A2; 
+  simpl fst in *; simpl snd in *; try clear e0 e1.
+ intuition_in.
+ intuition_in.
+ intuition_in.
+ (* add x2 s#1 *)
+ inv avl.
+ rewrite (height_0 H); [ | avl_nn l2; omega_max].
+ rewrite (height_0 H0); [ | avl_nn r2; omega_max].
+ rewrite add_in; intuition_in.
+ (* join (union (l1,l2')) x1 (union (r1,r2')) *)
+ generalize
+  (split_avl x1 A2) (split_bst x1 B2)
+  (split_in_1 x1 y B2) (split_in_2 x1 y B2).
+ rewrite e2; simpl.
+ destruct 1; destruct 1; inv avl; inv bst.
+ rewrite join_in, IHt, IHt0; auto.
+ do 2 (intro Eq; rewrite Eq; clear Eq).
+ case (X.compare y x1); intuition_in.
+ (* add x1 s#2 *)
+ inv avl.
+ rewrite (height_0 H3); [ | avl_nn l1; omega_max].
+ rewrite (height_0 H4); [ | avl_nn r1; omega_max].
+ rewrite add_in; auto; intuition_in.
+ (* join (union (l1',l2)) x1 (union (r1',r2)) *)
+ generalize 
+  (split_avl x2 A1) (split_bst x2 B1)
+  (split_in_1 x2 y B1) (split_in_2 x2 y B1).
+ rewrite e2; simpl.
+ destruct 1; destruct 1; inv avl; inv bst.
+ rewrite join_in, IHt, IHt0; auto.
+ do 2 (intro Eq; rewrite Eq; clear Eq).
+ case (X.compare y x2); intuition_in.
+Qed.
+
+Lemma ocaml_union_bst : forall s,
+ bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> bst (ocaml_union s).
+Proof.
+ intros s; functional induction ocaml_union s; intros B1 A1 B2 A2;
+  simpl fst in *; simpl snd in *; try clear e0 e1; 
+  try apply add_bst; auto.
+ (* join (union (l1,l2')) x1 (union (r1,r2')) *)
+ clear _x _x0; factornode l2 x2 r2 h2 as s2.
+ generalize (split_avl x1 A2) (split_bst x1 B2)
+  (@split_in_1 s2 x1)(@split_in_2 s2 x1).
+ rewrite e2; simpl.
+ destruct 1; destruct 1; intros.
+ inv bst; inv avl.
+ apply join_bst; auto.
+ intro y; rewrite ocaml_union_in, H3; intuition_in.
+ intro y; rewrite ocaml_union_in, H4; intuition_in.
+ (* join (union (l1',l2)) x1 (union (r1',r2)) *)
+ clear _x _x0; factornode l1 x1 r1 h1 as s1.
+ generalize (split_avl x2 A1) (split_bst x2 B1)
+  (@split_in_1 s1 x2)(@split_in_2 s1 x2).
+ rewrite e2; simpl.
+ destruct 1; destruct 1; intros.
+ inv bst; inv avl.
+ apply join_bst; auto.
+ intro y; rewrite ocaml_union_in, H3; intuition_in.
+ intro y; rewrite ocaml_union_in, H4; intuition_in.
+Qed.
+
+Lemma ocaml_union_avl : forall s, 
+ avl s#1 -> avl s#2 -> avl (ocaml_union s).
+Proof.
+ intros s; functional induction ocaml_union s; 
+  simpl fst in *; simpl snd in *; auto.
+ intros A1 A2; generalize (split_avl x1 A2); rewrite e2; simpl.
+ inv avl; destruct 1; auto.
+ intros A1 A2; generalize (split_avl x2 A1); rewrite e2; simpl.
+ inv avl; destruct 1; auto.
+Qed.
+
+Lemma ocaml_union_alt : forall s, bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 ->
+ Equal (ocaml_union s) (union s#1 s#2).
+Proof.
+ red; intros; rewrite ocaml_union_in, union_in; simpl; intuition.
+Qed.
+
+
+(** * [ocaml_subset], a subset faithful to the original ocaml code *)
+
+Function ocaml_subset (s:t*t) { measure cardinal2 s } : bool :=
+ match s with
+  | (Leaf, _) => true
+  | (Node _ _ _ _, Leaf) => false
+  | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) =>
+     match X.compare x1 x2 with
+      | EQ _ => ocaml_subset (l1,l2) && ocaml_subset (r1,r2)
+      | LT _ => ocaml_subset (Node l1 x1 Leaf 0%I, l2) && ocaml_subset (r1,s#2)
+      | GT _ => ocaml_subset (Node Leaf x1 r1 0%I, r2) && ocaml_subset (l1,s#2)
+     end
+ end.
+
+Proof.
+ intros; unfold cardinal2; simpl; abstract romega with *.
+ intros; unfold cardinal2; simpl; abstract romega with *.
+ intros; unfold cardinal2; simpl; abstract romega with *.
+ intros; unfold cardinal2; simpl; abstract romega with *.
+ intros; unfold cardinal2; simpl; abstract romega with *.
+ intros; unfold cardinal2; simpl; abstract romega with *.
+Defined.
+
+Lemma ocaml_subset_12 : forall s, 
+ bst s#1 -> bst s#2 ->
+ (ocaml_subset s = true <-> Subset s#1 s#2).
+Proof.
+ intros s; functional induction ocaml_subset s; simpl;
+  intros B1 B2; try clear e0.
+ intuition.
+ red; auto; inversion 1.
+ split; intros; try discriminate.
+ assert (H': In _x0 Leaf) by auto; inversion H'.
+ (**)
+ simpl in *; inv bst.
+ rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0.
+ unfold Subset; intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ (**)
+ simpl in *; inv bst.
+ rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0.
+ unfold Subset; intuition_in.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ (**)
+ simpl in *; inv bst.
+ rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0.
+ unfold Subset; intuition_in.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+Qed.
+
+Lemma ocaml_subset_alt : forall s, bst s#1 -> bst s#2 -> 
+ ocaml_subset s = subset s#1 s#2.
+Proof.
+ intros.
+ generalize (ocaml_subset_12 H H0); rewrite <-subset_12 by auto.
+ destruct ocaml_subset; destruct subset; intuition.
+Qed.
+
+
+
+(** [ocaml_compare], a compare faithful to the original ocaml code *)
+
+(** termination of [compare_aux] *)
+
+Fixpoint cardinal_e e := match e with
+  | End => 0
+  | More _ s r => S (cardinal s + cardinal_e r)
+ end.
+
+Lemma cons_cardinal_e : forall s e, 
+ cardinal_e (cons s e) = cardinal s + cardinal_e e.
+Proof.
+ induction s; simpl; intros; auto.
+ rewrite IHs1; simpl; rewrite <- plus_n_Sm; auto with arith.
+Qed.
+
+Definition cardinal_e_2 e := cardinal_e e#1 + cardinal_e e#2.
+
+Function ocaml_compare_aux 
+ (e:enumeration*enumeration) { measure cardinal_e_2 e } : comparison := 
+ match e with 
+ | (End,End) => Eq
+ | (End,More _ _ _) => Lt 
+ | (More _ _ _, End) => Gt 
+ | (More x1 r1 e1, More x2 r2 e2) => 
+       match X.compare x1 x2 with 
+        | EQ _ => ocaml_compare_aux (cons r1 e1, cons r2 e2)
+        | LT _ => Lt 
+        | GT _ => Gt 
+       end
+ end.
+
+Proof.
+intros; unfold cardinal_e_2; simpl; 
+abstract (do 2 rewrite cons_cardinal_e; romega with *).
+Defined.
+
+Definition ocaml_compare s1 s2 := 
+ ocaml_compare_aux (cons s1 End, cons s2 End).
+
+Lemma ocaml_compare_aux_Cmp : forall e, 
+ Cmp (ocaml_compare_aux e) (flatten_e e#1) (flatten_e e#2).
+Proof.
+ intros e; functional induction ocaml_compare_aux e; simpl; intros; 
+  auto; try discriminate.
+ apply L.eq_refl.
+ simpl in *.
+ apply cons_Cmp; auto.
+ rewrite <- 2 cons_1; auto.
+Qed.
+
+Lemma ocaml_compare_Cmp : forall s1 s2,
+ Cmp (ocaml_compare s1 s2) (elements s1) (elements s2).
+Proof.
+ unfold ocaml_compare; intros.
+ assert (H1:=cons_1 s1 End).
+ assert (H2:=cons_1 s2 End).
+ simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2.
+ apply (@ocaml_compare_aux_Cmp (cons s1 End, cons s2 End)).
+Qed.
+
+Lemma ocaml_compare_alt : forall s1 s2, bst s1 -> bst s2 -> 
+ ocaml_compare s1 s2 = compare s1 s2.
+Proof.
+ intros s1 s2 B1 B2.
+ generalize (ocaml_compare_Cmp s1 s2)(compare_Cmp s1 s2). 
+ unfold Cmp.
+ destruct ocaml_compare; destruct compare; auto; intros; elimtype False.
+ elim (lt_not_eq B1 B2 H0); auto.
+ elim (lt_not_eq B2 B1 H0); auto.
+  apply eq_sym; auto.
+ elim (lt_not_eq B1 B2 H); auto.
+  elim (lt_not_eq B1 B1).
+  red; eapply L.lt_trans; eauto.
+  apply eq_refl.
+ elim (lt_not_eq B2 B1 H); auto.
+  apply eq_sym; auto.
+ elim (lt_not_eq B1 B2 H0); auto.
+  elim (lt_not_eq B1 B1).
+  red; eapply L.lt_trans; eauto.
+  apply eq_refl.
+Qed.
+
+
+(** * Equality test *)
+
+Definition ocaml_equal s1 s2 : bool := 
+ match ocaml_compare s1 s2 with 
+  | Eq => true
+  | _ => false 
+ end.
+
+Lemma ocaml_equal_1 : forall s1 s2, bst s1 -> bst s2 ->  
+ Equal s1 s2 -> ocaml_equal s1 s2 = true.
+Proof.
+unfold ocaml_equal; intros s1 s2 B1 B2 E.
+generalize (ocaml_compare_Cmp s1 s2).
+destruct (ocaml_compare s1 s2); auto; intros.
+elim (lt_not_eq B1 B2 H E); auto.
+elim (lt_not_eq B2 B1 H (eq_sym E)); auto.
+Qed.
+
+Lemma ocaml_equal_2 : forall s1 s2,
+ ocaml_equal s1 s2 = true -> Equal s1 s2.
+Proof.
+unfold ocaml_equal; intros s1 s2 E.
+generalize (ocaml_compare_Cmp s1 s2); 
+ destruct ocaml_compare; auto; discriminate.
+Qed.
+
+Lemma ocaml_equal_alt : forall s1 s2, bst s1 -> bst s2 -> 
+ ocaml_equal s1 s2 = equal s1 s2.
+Proof.
+intros; unfold ocaml_equal, equal; rewrite ocaml_compare_alt; auto.
+Qed.
+
+End OcamlOps.
+
+
+
+(** * Encapsulation
+
+   We can implement [S] with balanced binary search trees. 
+   When compared to [FSetAVL], we maintain here two invariants
+   (bst and avl) instead of only bst, which is enough for fulfilling
+   the FSet interface.
+
+   This encapsulation propose the non-structural variants 
+   [ocaml_union], [ocaml_subset], [ocaml_compare], [ocaml_equal].
+*) 
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+
+ Module E := X.
+ Module Import OcamlOps := OcamlOps I X.
+ Import AvlProofs.
+ Import Raw.
+ Import Raw.Proofs.
+
+ Record bbst := Bbst {this :> Raw.t; is_bst : bst this; is_avl : avl this}.
+ Definition t := bbst.
+ Definition elt := E.t.
+ 
+ Definition In (x : elt) (s : t) : Prop := 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 (@In_1 s). Qed.
+ 
+ Definition mem (x:elt)(s:t) : bool := mem x s.
+
+ Definition empty : t := Bbst empty_bst empty_avl.
+ Definition is_empty (s:t) : bool := is_empty s.
+ Definition singleton (x:elt) : t := 
+   Bbst (singleton_bst x) (singleton_avl x).
+ Definition add (x:elt)(s:t) : t := 
+   Bbst (add_bst x (is_bst s)) (add_avl x (is_avl s)). 
+ Definition remove (x:elt)(s:t) : t := 
+   Bbst (remove_bst x (is_bst s)) (remove_avl x (is_avl s)).
+ Definition inter (s s':t) : t := 
+   Bbst (inter_bst (is_bst s) (is_bst s'))
+        (inter_avl (is_avl s) (is_avl s')).
+ Definition union (s s':t) : t :=
+   Bbst (union_bst (is_bst s) (is_bst s'))
+        (union_avl (is_avl s) (is_avl s')).
+ Definition ocaml_union (s s':t) : t :=
+   Bbst (@ocaml_union_bst (s.(this),s'.(this)) 
+          (is_bst s) (is_avl s) (is_bst s') (is_avl s'))
+        (@ocaml_union_avl (s.(this),s'.(this)) (is_avl s) (is_avl s')).
+ Definition diff (s s':t) : t := 
+   Bbst (diff_bst (is_bst s) (is_bst s'))
+        (diff_avl (is_avl s) (is_avl s')).
+ Definition elements (s:t) : list elt := elements s.
+ Definition min_elt (s:t) : option elt := min_elt s.
+ Definition max_elt (s:t) : option elt := max_elt s.
+ Definition choose (s:t) : option elt := choose s.
+ Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := fold f s. 
+ Definition cardinal (s:t) : nat := cardinal s.
+ Definition filter (f : elt -> bool) (s:t) : t := 
+   Bbst (filter_bst f (is_bst s)) (filter_avl f (is_avl s)).
+ Definition for_all (f : elt -> bool) (s:t) : bool := for_all f s.
+ Definition exists_ (f : elt -> bool) (s:t) : bool := exists_ f s.
+ Definition partition (f : elt -> bool) (s:t) : t * t :=
+   let p := partition f s in
+   (@Bbst (fst p) (partition_bst_1 f (is_bst s)) 
+                 (partition_avl_1 f (is_avl s)), 
+    @Bbst (snd p) (partition_bst_2 f (is_bst s))
+                 (partition_avl_2 f (is_avl s))).
+
+ Definition equal (s s':t) : bool := equal s s'.
+ Definition ocaml_equal (s s':t) : bool := ocaml_equal s s'.
+ Definition subset (s s':t) : bool := subset s s'.
+ Definition ocaml_subset (s s':t) : bool := 
+  ocaml_subset (s.(this),s'.(this)).
+
+ Definition eq (s s':t) : Prop := Equal s s'.
+ Definition lt (s s':t) : Prop := lt s s'.
+
+ Definition compare (s s':t) : Compare lt eq s s'.
+ Proof.
+  intros (s,b,a) (s',b',a').
+  generalize (compare_Cmp s s').
+  destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto.
+  change (Raw.Equal s s'); auto.
+ Defined.
+
+ Definition ocaml_compare (s s':t) : Compare lt eq s s'.
+ Proof.
+  intros (s,b,a) (s',b',a').
+  generalize (ocaml_compare_Cmp s s').
+  destruct ocaml_compare; intros; [apply EQ|apply LT|apply GT]; red; auto.
+  change (Raw.Equal s s'); 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 (mem_1 (is_bst s)). Qed.
+ Lemma mem_2 : mem x s = true -> In x s.
+ Proof. exact (@mem_2 s x). Qed.
+
+ Lemma equal_1 : Equal s s' -> equal s s' = true.
+ Proof. exact (equal_1 (is_bst s) (is_bst s')). Qed.
+ Lemma equal_2 : equal s s' = true -> Equal s s'.
+ Proof. exact (@equal_2 s s'). Qed.
+
+ Lemma ocaml_equal_alt : ocaml_equal s s' = equal s s'.
+ Proof. 
+  destruct s; destruct s'; unfold ocaml_equal, equal; simpl.
+  apply ocaml_equal_alt; auto.
+ Qed.
+ 
+ Lemma ocaml_equal_1 : Equal s s' -> ocaml_equal s s' = true.
+ Proof. exact (ocaml_equal_1 (is_bst s) (is_bst s')). Qed.
+ Lemma ocaml_equal_2 : ocaml_equal s s' = true -> Equal s s'.
+ Proof. exact (@ocaml_equal_2 s s'). Qed. 
+
+ Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition.
+
+ Lemma subset_1 : Subset s s' -> subset s s' = true.
+ Proof. wrap subset subset_12. Qed.
+ Lemma subset_2 : subset s s' = true -> Subset s s'.
+ Proof. wrap subset subset_12. Qed.
+
+ Lemma ocaml_subset_alt : ocaml_subset s s' = subset s s'.
+ Proof. 
+  destruct s; destruct s'; unfold ocaml_subset, subset; simpl.
+  rewrite ocaml_subset_alt; auto.
+ Qed.
+
+ Lemma ocaml_subset_1 : Subset s s' -> ocaml_subset s s' = true.
+ Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed.
+ Lemma ocaml_subset_2 : ocaml_subset s s' = true -> Subset s s'.
+ Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact empty_1. Qed.
+
+ Lemma is_empty_1 : Empty s -> is_empty s = true.
+ Proof. exact (@is_empty_1 s). Qed.
+ Lemma is_empty_2 : is_empty s = true -> Empty s. 
+ Proof. exact (@is_empty_2 s). Qed.
+ 
+ Lemma add_1 : E.eq x y -> In y (add x s).
+ Proof. wrap add add_in. Qed.
+ Lemma add_2 : In y s -> In y (add x s).
+ Proof. wrap add add_in. Qed.
+ Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
+ Proof. wrap add add_in. elim H; auto. Qed.
+
+ Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
+ Proof. wrap remove remove_in. Qed.
+ Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+ Proof. wrap remove remove_in. Qed.
+ Lemma remove_3 : In y (remove x s) -> In y s.
+ Proof. wrap remove remove_in. Qed.
+
+ Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
+ Proof. exact (@singleton_1 x y). Qed.
+ Lemma singleton_2 : E.eq x y -> In y (singleton x). 
+ Proof. exact (@singleton_2 x y). Qed.
+
+ Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
+ Proof. wrap union union_in. Qed.
+ Lemma union_2 : In x s -> In x (union s s'). 
+ Proof. wrap union union_in. Qed.
+ Lemma union_3 : In x s' -> In x (union s s').
+ Proof. wrap union union_in. Qed.
+
+ Lemma ocaml_union_alt : Equal (ocaml_union s s') (union s s').
+ Proof. 
+  unfold ocaml_union, union, Equal, In.
+  destruct s as (s0,b,a); destruct s' as (s0',b',a'); simpl.
+  exact (@ocaml_union_alt (s0,s0') b a b' a').
+ Qed.
+
+ Lemma ocaml_union_1 : In x (ocaml_union s s') -> In x s \/ In x s'.
+ Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed.
+ Lemma ocaml_union_2 : In x s -> In x (ocaml_union s s').
+ Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed.
+ Lemma ocaml_union_3 : In x s' -> In x (ocaml_union s s').
+ Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed.
+
+ Lemma inter_1 : In x (inter s s') -> In x s.
+ Proof. wrap inter inter_in. Qed.
+ Lemma inter_2 : In x (inter s s') -> In x s'.
+ Proof. wrap inter inter_in. Qed.
+ Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
+ Proof. wrap inter inter_in. Qed.
+ 
+ Lemma diff_1 : In x (diff s s') -> In x s. 
+ Proof. wrap diff diff_in. Qed.
+ Lemma diff_2 : In x (diff s s') -> ~ In x s'.
+ Proof. wrap diff diff_in. Qed.
+ Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+ Proof. wrap diff diff_in. Qed.
+ 
+ Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+ Proof. 
+ unfold fold, elements; intros; apply fold_1; auto.
+ Qed.
+
+ Lemma cardinal_1 : cardinal s = length (elements s).
+ Proof. 
+ unfold cardinal, elements; intros; apply elements_cardinal; 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. wrap filter filter_in. Qed.
+ Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+ Proof. intro. wrap filter filter_in. Qed. 
+ Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
+ Proof. intro. wrap filter filter_in. 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 (@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 (@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 (@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 (@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 partition_in_1, 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 partition_in_2, filter_in; intuition.
+ rewrite H2; auto.
+ destruct (f a); auto.
+ red; intros; f_equal.
+ rewrite (H _ _ H0); auto.
+ Qed.
+
+ End Filter.
+
+ Lemma elements_1 : In x s -> InA E.eq x (elements s).
+ Proof. wrap elements elements_in. Qed.
+ Lemma elements_2 : InA E.eq x (elements s) -> In x s.
+ Proof. wrap elements elements_in. Qed.
+ Lemma elements_3 : sort E.lt (elements s).
+ Proof. exact (elements_sort (is_bst s)). Qed.
+ Lemma elements_3w : NoDupA E.eq (elements s).
+ Proof. exact (elements_nodup (is_bst s)). Qed.
+
+ Lemma min_elt_1 : min_elt s = Some x -> In x s. 
+ Proof. exact (@min_elt_1 s x). Qed.
+ Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
+ Proof. exact (@min_elt_2 s x y (is_bst s)). Qed.
+ Lemma min_elt_3 : min_elt s = None -> Empty s.
+ Proof. exact (@min_elt_3 s). Qed.
+
+ Lemma max_elt_1 : max_elt s = Some x -> In x s. 
+ Proof. exact (@max_elt_1 s x). Qed.
+ Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
+ Proof. exact (@max_elt_2 s x y (is_bst s)). Qed.
+ Lemma max_elt_3 : max_elt s = None -> Empty s.
+ Proof. exact (@max_elt_3 s). Qed.
+
+ Lemma choose_1 : choose s = Some x -> In x s.
+ Proof. exact (@choose_1 s x). Qed.
+ Lemma choose_2 : choose s = None -> Empty s.
+ Proof. exact (@choose_2 s). Qed.
+ Lemma choose_3 : choose s = Some x -> choose s' = Some y -> 
+  Equal s s' -> E.eq x y.
+ Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed.
+
+ Lemma eq_refl : eq s s. 
+ Proof. exact (eq_refl s). Qed.
+ Lemma eq_sym : eq s s' -> eq s' s.
+ Proof. exact (@eq_sym s s'). Qed.
+ Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''.
+ Proof. exact (@eq_trans s s' s''). Qed.
+  
+ Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''.
+ Proof. exact (@lt_trans s s' s''). Qed.
+ Lemma lt_not_eq : lt s s' -> ~eq s s'.
+ Proof. exact (@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/FSetInterface.v b/theories/FSets/FSetInterface.v
index 64ad234b..1255fcc8 100644
--- a/theories/FSets/FSetInterface.v
+++ b/theories/FSets/FSetInterface.v
@@ -6,40 +6,53 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetInterface.v 8820 2006-05-15 11:44:05Z letouzey $ *)
+(* $Id: FSetInterface.v 10616 2008-03-04 17:33:35Z letouzey $ *)
 
 (** * Finite set library *)
 
-(** Set interfaces *)
-
-(* begin hide *)
-Require Export Bool.
-Require Export OrderedType.
+(** Set interfaces, inspired by the one of Ocaml. When compared with 
+    Ocaml, the main differences are: 
+    - the lack of [iter] function, useless since Coq is purely functional
+    - the use of [option] types instead of [Not_found] exceptions
+    - the use of [nat] instead of [int] for the [cardinal] function 
+
+    Several variants of the set interfaces are available: 
+    - [WSfun] : functorial signature for weak sets, non-dependent style
+    - [WS]    : self-contained version of [WSfun]
+    - [Sfun]  : functorial signature for ordered sets, non-dependent style
+    - [S]     : self-contained version of [Sfun]
+    - [Sdep]  : analog of [S] written using dependent style
+
+    If unsure, [S] is probably what you're looking for: other signatures
+    are subsets of it, apart from [Sdep] which is isomorphic to [S] (see 
+    [FSetBridge]).
+*)
+
+Require Export Bool OrderedType DecidableType.
 Set Implicit Arguments.
 Unset Strict Implicit.
-(* end hide *)
 
-(** Compatibility of a  boolean function with respect to an equality. *)
-Definition compat_bool (A:Set)(eqA: A->A->Prop)(f: A-> bool) :=
-  forall x y : A, eqA x y -> f x = f y.
+(** * Non-dependent signatures
 
-(** Compatibility of a predicate with respect to an equality. *)
-Definition compat_P (A:Set)(eqA: A->A->Prop)(P : A -> Prop) :=
-  forall x y : A, eqA x y -> P x -> P y.
+    The following signatures presents sets as purely informative 
+    programs together with axioms *)
 
-Hint Unfold compat_bool compat_P.
 
-(** * Non-dependent signature
 
-    Signature [S] presents sets as purely informative programs 
-    together with axioms *)
+(** ** Functorial signature for weak sets
 
-Module Type S.
+    Weak sets are sets without ordering on base elements, only 
+    a decidable equality. *)
+
+Module Type WSfun (E : EqualityType).
+
+  (** The module E of base objects is meant to be a [DecidableType]
+     (and used to be so). But requiring only an [EqualityType] here
+     allows subtyping between weak and ordered sets *)
 
-  Declare Module E : OrderedType.
   Definition elt := E.t.
 
-  Parameter t : Set. (** the abstract type of sets *)
+  Parameter t : Type. (** the abstract type of sets *)
 
   (** Logical predicates *)
   Parameter In : elt -> t -> Prop.
@@ -82,10 +95,12 @@ Module Type S.
   (** Set difference. *)
 
   Definition eq : t -> t -> Prop := Equal.
-  Parameter lt : t -> t -> Prop.
-  Parameter compare : forall s s' : t, Compare lt eq s s'.
-  (** Total ordering between sets. Can be used as the ordering function
-  for doing sets of sets. *)
+  (** In order to have the subtyping WS < S between weak and ordered 
+   sets, we do not require here an [eq_dec]. This interface is hence 
+   not compatible with [DecidableType], but only with [EqualityType],
+   so in general it may not possible to form weak sets of weak sets.
+   Some particular implementations may allow this nonetheless, in 
+   particular [FSetWeakList.Make]. *)
 
   Parameter equal : t -> t -> bool.
   (** [equal s1 s2] tests whether the sets [s1] and [s2] are
@@ -95,15 +110,11 @@ Module Type S.
   (** [subset s1 s2] tests whether the set [s1] is a subset of
   the set [s2]. *)
 
-  (** Coq comment: [iter] is useless in a purely functional world *)
-  (**  iter: (elt -> unit) -> set -> unit. i*)
-  (** [iter f s] applies [f] in turn to all elements of [s].
-  The order in which the elements of [s] are presented to [f]
-  is unspecified. *)
-
-  Parameter fold : forall A : Set, (elt -> A -> A) -> t -> A -> A.
+  Parameter fold : forall A : Type, (elt -> A -> A) -> t -> A -> A.
   (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
-  where [x1 ... xN] are the elements of [s], in increasing order. *)
+  where [x1 ... xN] are the elements of [s].
+  The order in which elements of [s] are presented to [f] is
+  unspecified. *)
 
   Parameter for_all : (elt -> bool) -> t -> bool.
   (** [for_all p s] checks if all elements of the set
@@ -125,59 +136,39 @@ Module Type S.
 
   Parameter cardinal : t -> nat.
   (** Return the number of elements of a set. *)
-  (** Coq comment: nat instead of int ... *)
 
   Parameter elements : t -> list elt.
-  (** Return the list of all elements of the given set.
-  The returned list is sorted in increasing order with respect
-  to the ordering [Ord.compare], where [Ord] is the argument
-  given to {!Set.Make}. *)
-
-  Parameter min_elt : t -> option elt.
-  (** Return the smallest element of the given set
-  (with respect to the [Ord.compare] ordering), or raise
-  [Not_found] if the set is empty. *)
-  (** Coq comment: [Not_found] is represented by the option type *)
-
-  Parameter max_elt : t -> option elt.
-  (** Same as {!Set.S.min_elt}, but returns the largest element of the
-  given set. *)
-  (** Coq comment: [Not_found] is represented by the option type *)
+  (** Return the list of all elements of the given set, in any order. *)
 
   Parameter choose : t -> option elt.
-  (** Return one element of the given set, or raise [Not_found] if
-  the set is empty. Which element is chosen is unspecified,
-  but equal elements will be chosen for equal sets. *)
-  (** Coq comment: [Not_found] is represented by the option type *)
+  (** Return one element of the given set, or [None] if
+  the set is empty. Which element is chosen is unspecified.
+  Equal sets could return different elements. *)
 
   Section Spec. 
 
-  Variable s s' s'' : t.
+  Variable s s' s'': t.
   Variable x y : elt.
 
   (** Specification of [In] *)
   Parameter In_1 : E.eq x y -> In x s -> In y s.
- 
+
   (** Specification of [eq] *)
   Parameter eq_refl : eq s s. 
   Parameter eq_sym : eq s s' -> eq s' s.
   Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''.
- 
-  (** Specification of [lt] *)
-  Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''.
-  Parameter lt_not_eq : lt s s' -> ~ eq s s'.
 
   (** Specification of [mem] *)
   Parameter mem_1 : In x s -> mem x s = true.
   Parameter mem_2 : mem x s = true -> In x s. 
  
   (** Specification of [equal] *) 
-  Parameter equal_1 : s[=]s' -> equal s s' = true.
-  Parameter equal_2 : equal s s' = true ->s[=]s'.
+  Parameter equal_1 : Equal s s' -> equal s s' = true.
+  Parameter equal_2 : equal s s' = true -> Equal s s'.
 
   (** Specification of [subset] *)
-  Parameter subset_1 : s[<=]s' -> subset s s' = true.
-  Parameter subset_2 : subset s s' = true -> s[<=]s'.
+  Parameter subset_1 : Subset s s' -> subset s s' = true.
+  Parameter subset_2 : subset s s' = true -> Subset s s'.
 
   (** Specification of [empty] *)
   Parameter empty_1 : Empty empty.
@@ -216,7 +207,7 @@ Module Type S.
   Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s').
  
   (** Specification of [fold] *)  
-  Parameter fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A),
+  Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
       fold f s i = fold_left (fun a e => f e a) (elements s) i.
 
   (** Specification of [cardinal] *)  
@@ -249,18 +240,93 @@ Module Type S.
       exists_ f s = true -> Exists (fun x => f x = true) s.
 
   (** Specification of [partition] *)
-  Parameter partition_1 : compat_bool E.eq f -> 
-      fst (partition f s) [=] filter f s.
-  Parameter partition_2 : compat_bool E.eq f -> 
-      snd (partition f s) [=] filter (fun x => negb (f x)) s.
+  Parameter partition_1 :
+      compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
+  Parameter partition_2 :
+      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.
+  (** When compared with ordered sets, here comes the only 
+      property that is really weaker: *)
+  Parameter elements_3w : 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 Spec.
+
+  Hint Resolve mem_1 equal_1 subset_1 empty_1
+    is_empty_1 choose_1 choose_2 add_1 add_2 remove_1
+    remove_2 singleton_2 union_1 union_2 union_3
+    inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1
+    partition_1 partition_2 elements_1 elements_3w 
+    : set.
+  Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3
+    remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2
+    filter_1 filter_2 for_all_2 exists_2 elements_2 
+    : set.
+
+End WSfun.
+
+
+
+(** ** Static signature for weak sets
+
+    Similar to the functorial signature [SW], except that the 
+    module [E] of base elements is incorporated in the signature. *)
+
+Module Type WS.
+  Declare Module E : EqualityType.
+  Include Type WSfun E.
+End WS.
+
+
+
+(** ** Functorial signature for sets on ordered elements
+
+    Based on [WSfun], plus ordering on sets and [min_elt] and [max_elt]
+    and some stronger specifications for other functions. *)
+
+Module Type Sfun (E : OrderedType).
+  Include Type WSfun E.
+
+  Parameter lt : t -> t -> Prop.
+  Parameter compare : forall s s' : t, Compare lt eq s s'.
+  (** Total ordering between sets. Can be used as the ordering function
+  for doing sets of sets. *)
+
+  Parameter min_elt : t -> option elt.
+  (** Return the smallest element of the given set
+  (with respect to the [E.compare] ordering), 
+  or [None] if the set is empty. *)
+
+  Parameter max_elt : t -> option elt.
+  (** Same as [min_elt], but returns the largest element of the
+  given set. *)
+
+  Section Spec. 
+
+  Variable s s' s'' : t.
+  Variable x y : elt.
+ 
+  (** Specification of [lt] *)
+  Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''.
+  Parameter lt_not_eq : lt s s' -> ~ eq s s'.
+
+  (** Additional specification of [elements] *)
   Parameter elements_3 : sort E.lt (elements s).  
 
+  (** Remark: since [fold] is specified via [elements], this stronger
+   specification of [elements] has an indirect impact on [fold], 
+   which can now be proved to receive elements in increasing order.
+  *)
+
   (** Specification of [min_elt] *)
   Parameter min_elt_1 : min_elt s = Some x -> In x s. 
   Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. 
@@ -271,37 +337,56 @@ Module Type S.
   Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. 
   Parameter max_elt_3 : max_elt s = None -> Empty s.
 
-  (** Specification of [choose] *)
-  Parameter choose_1 : choose s = Some x -> In x s.
-  Parameter choose_2 : choose s = None -> Empty s.
-(*  Parameter choose_equal: 
-      (equal s s')=true -> E.eq (choose s) (choose s'). *)
+  (** Additional specification of [choose] *)
+  Parameter choose_3 : choose s = Some x -> choose s' = Some y -> 
+    Equal s s' -> E.eq x y.
 
   End Spec.
 
-  (* begin hide *)
-  Hint Immediate In_1.
-  
-  Hint Resolve mem_1 mem_2 equal_1 equal_2 subset_1 subset_2 empty_1
-    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
-    elements_3 min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3.
-  (* end hide *)
+  Hint Resolve elements_3 : set.
+  Hint Immediate 
+    min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3 : set.
+
+End Sfun.
+
 
+(** ** Static signature for sets on ordered elements
+
+    Similar to the functorial signature [Sfun], except that the 
+    module [E] of base elements is incorporated in the signature. *)
+
+Module Type S.
+  Declare Module E : OrderedType.
+  Include Type Sfun E.
 End S.
 
+
+(** ** Some subtyping tests
+<<
+WSfun ---> WS
+ |         |
+ |         |
+ V         V
+Sfun  ---> S 
+
+
+Module S_WS (M : S) <: SW := M.
+Module Sfun_WSfun (E:OrderedType)(M : Sfun E) <: WSfun E := M.
+Module S_Sfun (E:OrderedType)(M : S with Module E:=E) <: Sfun E := M.
+Module WS_WSfun (E:EqualityType)(M : WS with Module E:=E) <: WSfun E := M.
+>>
+*)
+
 (** * Dependent signature 
 
-    Signature [Sdep] presents sets using dependent types *)
+    Signature [Sdep] presents ordered sets using dependent types *)
 
 Module Type Sdep.
 
   Declare Module E : OrderedType.
   Definition elt := E.t.
 
-  Parameter t : Set.
+  Parameter t : Type.
 
   Parameter In : elt -> t -> Prop.
   Definition Equal s s' := forall a : elt, In a s <-> In a s'.
@@ -397,7 +482,7 @@ Module Type Sdep.
 
   Parameter
     fold :
-      forall (A : Set) (f : elt -> A -> A) (s : t) (i : A),
+      forall (A : Type) (f : elt -> A -> A) (s : t) (i : A),
       {r : A | let (l,_) := elements s in 
                   r = fold_left (fun a e => f e a) l i}.
 
@@ -418,4 +503,14 @@ Module Type Sdep.
 
   Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}.
 
+  (** The [choose_3] specification of [S] cannot be packed 
+        in the dependent version of [choose], so we leave it separate. *)
+  Parameter choose_equal : forall s s', Equal s s' -> 
+     match choose s, choose s' with 
+       | inleft (exist x _), inleft (exist x' _) => E.eq x x'
+       | inright _, inright _  => True
+       | _, _  => False
+     end.
+
 End Sdep.
+
diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v
index f6205542..a205d5b0 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 8834 2006-05-20 00:41:35Z letouzey $ *)
+(* $Id: FSetList.v 10616 2008-03-04 17:33:35Z letouzey $ *)
 
 (** * Finite sets library *)
 
@@ -25,7 +25,6 @@ Unset Strict Implicit.
 
 Module Raw (X: OrderedType).
  
-  Module E := X.
   Module MX := OrderedTypeFacts X.
   Import MX.
 
@@ -145,7 +144,7 @@ Module Raw (X: OrderedType).
     | _, _ => false
     end.
 
-  Fixpoint fold (B : Set) (f : elt -> B -> B) (s : t) {struct s} : 
+  Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : 
    B -> B := fun i => match s with
                       | nil => i
                       | x :: l => fold f l (f x i)
@@ -649,6 +648,11 @@ Module Raw (X: OrderedType).
   unfold elements; auto.
   Qed.
 
+  Lemma elements_3w : forall (s : t) (Hs : Sort s), NoDupA X.eq (elements s).  
+  Proof. 
+  unfold elements; auto.
+  Qed.
+
   Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. 
   Proof.
   intro s; case s; simpl; intros; inversion H; auto.
@@ -718,8 +722,21 @@ Module Raw (X: OrderedType).
 
   Definition choose_2 : forall s : t, choose s = None -> Empty s := min_elt_3.
 
+  Lemma choose_3: forall s s', Sort s -> Sort s' -> forall x x',
+   choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'.
+  Proof.
+   unfold choose, Equal; intros s s' Hs Hs' x x' Hx Hx' H.
+   assert (~X.lt x x').
+    apply min_elt_2 with s'; auto.
+    rewrite <-H; auto using min_elt_1.
+   assert (~X.lt x' x).
+    apply min_elt_2 with s; auto.
+    rewrite H; auto using min_elt_1.
+   destruct (X.compare x x'); intuition.
+  Qed.
+   
   Lemma fold_1 :
-   forall (s : t) (Hs : Sort s) (A : Set) (i : A) (f : elt -> A -> A),
+   forall (s : t) (Hs : Sort s) (A : Type) (i : A) (f : elt -> A -> A),
    fold f s i = fold_left (fun a e => f e a) (elements s) i.
   Proof.
   induction s.
@@ -1037,7 +1054,7 @@ Module Make (X: OrderedType) <: S with Module E := X.
  Module Raw := Raw X. 
  Module E := X.
 
- Record slist : Set :=  {this :> Raw.t; sorted : sort E.lt this}.
+ Record slist := {this :> Raw.t; sorted : sort E.lt this}.
  Definition t := slist. 
  Definition elt := E.t.
  
@@ -1066,7 +1083,7 @@ Module Make (X: OrderedType) <: S with Module E := X.
  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 fold (B : Type) (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).
@@ -1149,7 +1166,7 @@ Module Make (X: OrderedType) <: S with Module E := X.
   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.
  
-  Lemma fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A),
+  Lemma fold_1 : forall (A : Type) (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.
 
@@ -1202,6 +1219,8 @@ Module Make (X: OrderedType) <: S with Module E := X.
   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 elements_3w : NoDupA E.eq (elements s).
+  Proof. exact (Raw.elements_3w 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.
@@ -1221,6 +1240,9 @@ Module Make (X: OrderedType) <: S with Module E := X.
   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 choose_3 : choose s = Some x -> choose s' = Some y -> 
+   Equal s s' -> E.eq x y.
+  Proof. exact (@Raw.choose_3 _ _ s.(sorted) s'.(sorted) x y). Qed.
 
   Lemma eq_refl : eq s s.
   Proof. exact (Raw.eq_refl s). Qed.
diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v
index 6e93a546..7413b06b 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 8853 2006-05-23 18:17:38Z herbelin $ *)
+(* $Id: FSetProperties.v 11064 2008-06-06 17:00:52Z letouzey $ *)
 
 (** * Finite sets library *)
 
@@ -16,414 +16,259 @@
     [In x s] instead of [mem x s=true], 
     [Equal s s'] instead of [equal s s'=true], etc. *)
 
-Require Export FSetInterface. 
-Require Import FSetFacts.
+Require Export FSetInterface.
+Require Import DecidableTypeEx FSetFacts FSetDecide.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-Hint Unfold transpose compat_op compat_nat.
+Hint Unfold transpose compat_op.
 Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence.
 
-Module Properties (M: S).
-  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] *)
-  
-   (** Results about lists without duplicates *)
+(** First, a functor for Weak Sets. Since the signature [WS] includes
+    an EqualityType and not a stronger DecidableType, this functor
+    should take two arguments in order to compensate this. *)
 
-  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.
+Module WProperties (Import E : DecidableType)(M : WSfun E).
+  Module Import Dec := WDecide E M.
+  Module Import FM := Dec.F (* FSetFacts.WFacts E M *).
+  Import M.
 
   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] *)
+  Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s.
 
-  Lemma equal_refl : forall s, s[=]s.
+  Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s.
   Proof.
-  unfold Equal; intuition.
-  Qed.
-
-  Lemma equal_sym : forall s s', s[=]s' -> s'[=]s.
-  Proof.
-  unfold Equal; intros.
-  rewrite H; intuition.
+  unfold Add.
+  split; intros.
+  red; intros.
+  rewrite H; clear H.
+  fsetdec.
+  fsetdec.
   Qed.
+  
+  Ltac expAdd := repeat rewrite Add_Equal.
 
-  Lemma equal_trans : forall s1 s2 s3, s1[=]s2 -> s2[=]s3 -> s1[=]s3.
-  Proof.
-  unfold Equal; intros.
-  rewrite H; exact (H0 a).
-  Qed.
+  Section BasicProperties.
 
   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 equal_refl : s[=]s.
+  Proof. fsetdec. Qed.
 
-  Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'.
-  Proof.
-  unfold Subset, Equal; intuition.
-  Qed.
+  Lemma equal_sym : s[=]s' -> s'[=]s.
+  Proof. fsetdec. Qed.
+
+  Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_refl : s[<=]s. 
+  Proof. fsetdec. Qed.
 
   Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3.
-  Proof.
-  unfold Subset; intuition.
-  Qed.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'.
+  Proof. fsetdec. Qed.
 
   Lemma subset_equal : s[=]s' -> s[<=]s'.
-  Proof.
-  unfold Subset, Equal; firstorder.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma subset_empty : empty[<=]s.
-  Proof.
-  unfold Subset; intros a; set_iff; intuition.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2.
-  Proof.
-  unfold Subset; intros H a; set_iff; intuition.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3.
-  Proof.
-  unfold Subset; intros H a; set_iff; intuition.
-  Qed.
-
+  Proof. fsetdec. 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.
+  Proof. fsetdec. Qed.
 
   Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2.
-  Proof.
-  unfold Subset; intuition.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2.
-  Proof.
-  unfold Subset; intuition.
-  Qed.
+  Proof. fsetdec. 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] *)
+  Proof. intuition fsetdec. Qed.
 
   Lemma empty_is_empty_1 : Empty s -> s[=]empty.
-  Proof.
-  unfold Empty, Equal; intros; generalize (H a); set_iff; tauto.
-  Qed.
+  Proof. fsetdec. 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] *)
+  Proof. fsetdec. Qed.
 
   Lemma add_equal : In x s -> add x s [=] s.
-  Proof.
-  unfold Equal; intros; set_iff; intuition.
-  rewrite <- H1; auto.
-  Qed.
+  Proof. fsetdec. 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] *)
+  Proof. fsetdec. Qed.
 
   Lemma remove_equal : ~ In x s -> remove x s [=] s.
-  Proof.
-  unfold Equal; intros; set_iff; intuition.
-  rewrite H1 in H; auto.
-  Qed.
+  Proof. fsetdec. 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] *)
+  Proof. fsetdec. Qed.
 
   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.
+  Proof. fsetdec. 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] *)
+  Proof. fsetdec. Qed.
 
   Lemma singleton_equal_add : singleton x [=] add x empty.
-  Proof.
-  unfold Equal; intros; set_iff; intuition.
-  Qed.
-
-  (** properties of [union] *)
+  Proof. fsetdec. Qed.
 
   Lemma union_sym : union s s' [=] union s' s.
-  Proof.
-  unfold Equal; intros; set_iff; tauto.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'.
-  Proof.
-  unfold Subset, Equal; intros; set_iff; intuition.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''.
-  Proof.
-  intros; rewrite H; apply equal_refl.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
-  Proof.
-  intros; rewrite H; apply equal_refl.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma union_assoc : union (union s s') s'' [=] union s (union s' s'').
-  Proof.
-  unfold Equal; intros; set_iff; tauto.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma add_union_singleton : add x s [=] union (singleton x) s.
-  Proof.
-  unfold Equal; intros; set_iff; tauto.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma union_add : union (add x s) s' [=] add x (union s s').
-  Proof.
-  unfold Equal; intros; set_iff; tauto.
-  Qed.
+  Proof. fsetdec. Qed.
+
+  Lemma union_remove_add_1 : 
+   union (remove x s) (add x s') [=] union (add x s) (remove x s').
+  Proof. fsetdec. Qed.
+
+  Lemma union_remove_add_2 : In x s -> 
+   union (remove x s) (add x s') [=] union s s'.
+  Proof. fsetdec. Qed.
 
   Lemma union_subset_1 : s [<=] union s s'.
-  Proof.
-  unfold Subset; intuition.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma union_subset_2 : s' [<=] union s s'.
-  Proof.
-  unfold Subset; intuition.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''.
-  Proof.
-  unfold Subset; intros H H0 a; set_iff; intuition.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
-  Proof. 
-  unfold Subset; intros H a; set_iff; intuition.
-  Qed.
+  Proof. fsetdec. Qed. 
 
   Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
-  Proof. 
-  unfold Subset; intros H a; set_iff; intuition.
-  Qed.
+  Proof. fsetdec. Qed. 
 
   Lemma empty_union_1 : Empty s -> union s s' [=] s'.
-  Proof.
-  unfold Equal, Empty; intros; set_iff; firstorder.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma empty_union_2 : Empty s -> union s' s [=] s'.
-  Proof.
-  unfold Equal, Empty; intros; set_iff; firstorder.
-  Qed.
+  Proof. fsetdec. 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] *)
+  Proof. fsetdec. Qed.
 
   Lemma inter_sym : inter s s' [=] inter s' s.
-  Proof.
-  unfold Equal; intros; set_iff; tauto.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s.
-  Proof.
-  unfold Equal; intros; set_iff; intuition.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''.
-  Proof.
-  intros; rewrite H; apply equal_refl.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
-  Proof.
-  intros; rewrite H; apply equal_refl.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s'').
-  Proof.
-  unfold Equal; intros; set_iff; tauto.
-  Qed.
+  Proof. fsetdec. 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.
+  Proof. fsetdec. 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.
+  Proof. fsetdec. 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.
+  Proof. fsetdec. 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.
+  Proof. fsetdec. Qed.
 
   Lemma empty_inter_1 : Empty s -> Empty (inter s s').
-  Proof.
-  unfold Empty; intros; set_iff; firstorder.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma empty_inter_2 : Empty s' -> Empty (inter s s').
-  Proof.
-  unfold Empty; intros; set_iff; firstorder.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma inter_subset_1 : inter s s' [<=] s.
-  Proof.
-  unfold Subset; intro a; set_iff; tauto.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma inter_subset_2 : inter s s' [<=] s'.
-  Proof.
-  unfold Subset; intro a; set_iff; tauto.
-  Qed.
+  Proof. fsetdec. 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] *)
+  Proof. fsetdec. Qed.
 
   Lemma empty_diff_1 : Empty s -> Empty (diff s s'). 
-  Proof.
-  unfold Empty, Equal; intros; set_iff; firstorder.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma empty_diff_2 : Empty s -> diff s' s [=] s'.
-  Proof.
-  unfold Empty, Equal; intros; set_iff; firstorder.
-  Qed.
+  Proof. fsetdec. Qed.
 
   Lemma diff_subset : diff s s' [<=] s.
-  Proof.
-  unfold Subset; intros a; set_iff; tauto.
-  Qed.
+  Proof. fsetdec. 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.
+  Proof. fsetdec. Qed.
 
   Lemma remove_diff_singleton :
    remove x s [=] diff s (singleton x).
-  Proof.
-  unfold Equal; intros; set_iff; intuition.
-  Qed.
+  Proof. fsetdec. 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.
+  Proof. fsetdec. 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] *)
+  Proof. fsetdec. Qed.
 
   Lemma Add_add : Add x s (add x s).
-  Proof.
-   unfold Add; intros; set_iff; intuition.
-  Qed.
+  Proof. expAdd; fsetdec. 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.
+  Proof. expAdd; fsetdec. 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.
+  Proof. expAdd; fsetdec. 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.  
+  Proof. expAdd; fsetdec. 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.  
+  Proof. expAdd; fsetdec. 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.
+  Proof. expAdd; fsetdec. 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 
+  Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set.
+  Hint Resolve equal_refl equal_trans 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 
@@ -436,6 +281,31 @@ Module Properties (M: S).
     remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove
     Equal_remove add_add : set.
 
+  (** * Properties of elements *)
+
+  Lemma elements_Empty : forall s, Empty s <-> elements s = nil.
+  Proof.
+  intros.
+  unfold Empty.
+  split; intros.
+  assert (forall a, ~ List.In a (elements s)).
+   red; intros.
+   apply (H a).
+   rewrite elements_iff.
+   rewrite InA_alt; exists a; auto.
+  destruct (elements s); auto.
+  elim (H0 e); simpl; auto.
+  red; intros.
+  rewrite elements_iff in H0.
+  rewrite InA_alt in H0; destruct H0.
+  rewrite H in H0; destruct H0 as (_,H0); inversion H0.
+  Qed.
+
+  Lemma elements_empty : elements empty = nil.
+  Proof.
+  rewrite <-elements_Empty; auto with set.
+  Qed.
+
   (** * Alternative (weaker) specifications for [fold] *)
 
   Section Old_Spec_Now_Properties. 
@@ -447,14 +317,14 @@ Module Properties (M: S).
   *)
 
   Lemma fold_0 : 
-      forall s (A : Set) (i : A) (f : elt -> A -> A),
+      forall s (A : Type) (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.
+  apply NoDupA_rev; auto with set.
   exact E.eq_trans.
   split; intros.
   rewrite elements_iff; do 2 rewrite InA_alt.
@@ -468,7 +338,7 @@ Module Properties (M: S).
       [fold_2]. *)
 
   Lemma fold_1 :
-   forall s (A : Set) (eqA : A -> A -> Prop) 
+   forall s (A : Type) (eqA : A -> A -> Prop) 
      (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A),
    Empty s -> eqA (fold f s i) i.
   Proof.
@@ -481,7 +351,7 @@ Module Properties (M: S).
   Qed.
 
   Lemma fold_2 :
-   forall s s' x (A : Set) (eqA : A -> A -> Prop)
+   forall s s' x (A : Type) (eqA : A -> A -> Prop)
      (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A),
    compat_op E.eq eqA f ->
    transpose eqA f ->
@@ -492,9 +362,21 @@ Module Properties (M: S).
   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.
+  intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; 
+   rewrite (H2 a); intuition.
+  Qed.
+
+  (** In fact, [fold] on empty sets is more than equivalent to 
+      the initial element, it is Leibniz-equal to it. *)
+
+  Lemma fold_1b :
+   forall s (A : Type)(i : A) (f : elt -> A -> A),
+   Empty s -> (fold f s i) = i.
+  Proof.
+  intros.
+  rewrite M.fold_1.
+  rewrite elements_Empty in H; rewrite H; simpl; auto.
   Qed.
 
   (** Similar specifications for [cardinal]. *)
@@ -531,41 +413,46 @@ Module Properties (M: S).
 
   (** * Induction principle over sets *)
 
+  Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0.
+  Proof.
+  intros.
+  rewrite elements_Empty, M.cardinal_1.
+  destruct (elements s); intuition; discriminate.
+  Qed.
+
   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.
+  Proof.
+  intros; rewrite cardinal_Empty; auto. 
   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.
+  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'.
+  Lemma cardinal_inv_2b :
+   forall s, cardinal s <> 0 -> { x : elt | In x 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.
+  intro; generalize (@cardinal_inv_2 s); destruct cardinal; 
+   [intuition|eauto].
   Qed.
 
   Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'.
   Proof. 
-    intros; apply Equal_cardinal_aux with (cardinal s); auto.
-  Qed.
+  symmetry.
+  remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H.
+  induction n; intros.
+  apply cardinal_1; rewrite <- H; auto.
+  destruct (cardinal_inv_2 Heqn) as (x,H2).
+  revert Heqn.
+  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)); eauto with set.
+  Qed.    
 
   Add Morphism cardinal : cardinal_m.
   Proof.
@@ -574,40 +461,33 @@ Module Properties (M: S).
 
   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.  
+  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
+  destruct (cardinal_inv_2 (sym_eq Heqn)) as (x,H0). 
+  apply X0 with (remove x s) x; auto with set.
+  apply IHn; auto.
+  assert (S n = S (cardinal (remove x s))).
+    rewrite Heqn; apply cardinal_2 with x; auto with set.
+  inversion H; auto.
+  Qed.
 
   (** Other properties of [fold]. *)
 
   Section Fold. 
-  Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA).
+  Variables (A:Type)(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.
+  Lemma fold_empty : (fold f empty i) = i.
   Proof. 
-  apply fold_1; auto.
+  apply fold_1b; auto with set.
   Qed.
 
   Lemma fold_equal : 
@@ -642,7 +522,7 @@ Module Properties (M: S).
   Proof.
   intros.
   sym_st.
-  apply fold_2 with (eqA:=eqA); auto.
+  apply fold_2 with (eqA:=eqA); auto with set.
   Qed.
 
   Lemma remove_fold_2: forall s x, ~In x s -> 
@@ -742,7 +622,8 @@ Module Properties (M: S).
   apply fold_1; auto with set.
   Qed.
 
-  Lemma fold_union: forall s s', (forall x, ~In x s\/~In x s') ->
+  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.
@@ -760,8 +641,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 (@Logic.eq _) (fun _ => S)) by (unfold compat_op; auto). 
+  assert (fp : transpose (@Logic.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.
@@ -774,11 +655,11 @@ Module Properties (M: S).
   simpl; auto.
   Qed.
 
-  (** properties of [cardinal] *)
+  (** more properties of [cardinal] *)
 
   Lemma empty_cardinal : cardinal empty = 0.
   Proof.
-  rewrite cardinal_fold; apply fold_1; auto.
+  rewrite cardinal_fold; apply fold_1; auto with set.
   Qed.
 
   Hint Immediate empty_cardinal cardinal_1 : set.
@@ -798,11 +679,11 @@ Module Properties (M: S).
   Proof.
   intros; do 3 rewrite cardinal_fold.
   rewrite <- fold_plus.
-  apply fold_diff_inter with (eqA:=@eq nat); auto.
+  apply fold_diff_inter with (eqA:=@Logic.eq nat); auto.
   Qed.
 
   Lemma union_cardinal: 
-   forall s s', (forall x, ~In x s\/~In x s') -> 
+   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.
@@ -841,7 +722,7 @@ Module Properties (M: S).
   intros.
   do 4 rewrite cardinal_fold.
   do 2 rewrite <- fold_plus.
-  apply fold_union_inter with (eqA:=@eq nat); auto.
+  apply fold_union_inter with (eqA:=@Logic.eq nat); auto.
   Qed.
 
   Lemma union_cardinal_inter : 
@@ -872,7 +753,7 @@ Module Properties (M: S).
   intros.
   do 2 rewrite cardinal_fold.
   change S with ((fun _ => S) x);
-   apply fold_add with (eqA:=@eq nat); auto.
+   apply fold_add with (eqA:=@Logic.eq nat); auto.
   Qed.
 
   Lemma remove_cardinal_1 :
@@ -881,7 +762,7 @@ Module Properties (M: S).
   intros.
   do 2 rewrite cardinal_fold.
   change S with ((fun _ =>S) x).
-  apply remove_fold_1 with (eqA:=@eq nat); auto.
+  apply remove_fold_1 with (eqA:=@Logic.eq nat); auto.
   Qed.
 
   Lemma remove_cardinal_2 : 
@@ -892,4 +773,295 @@ Module Properties (M: S).
 
   Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2.
 
+End WProperties.
+
+
+(** A clone of [WProperties] working on full sets. *)
+
+Module Properties (M:S).
+  Module D := OT_as_DT M.E.
+  Include WProperties D M.
 End Properties.
+
+
+(** Now comes some properties specific to the element ordering, 
+    invalid for Weak Sets. *)
+
+Module OrdProperties (M:S).
+  Module ME:=OrderedTypeFacts(M.E).
+  Module Import P := Properties M.
+  Import FM.
+  Import M.E.
+  Import M.
+
+  (** First, a specialized version of SortA_equivlistA_eqlistA: *)
+  Lemma sort_equivlistA_eqlistA : forall l l' : list elt,
+   sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'.
+  Proof.
+  apply SortA_equivlistA_eqlistA; eauto.
+  Qed.
+
+  Definition gtb x y := match E.compare x y with GT _ => true | _ => false end.
+  Definition leb x := fun y => negb (gtb x y).
+
+  Definition elements_lt x s := List.filter (gtb x) (elements s).
+  Definition elements_ge x s := List.filter (leb x) (elements s).
+
+  Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x.
+  Proof.
+   intros; unfold gtb; destruct (E.compare x y); intuition; try discriminate; ME.order.
+  Qed.
+
+  Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x.
+  Proof.
+   intros; unfold leb, gtb; destruct (E.compare x y); intuition; try discriminate; ME.order.
+  Qed.
+
+  Lemma gtb_compat : forall x, compat_bool E.eq (gtb x).
+  Proof.
+   red; intros x a b H.
+   generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto.
+   intros.
+   symmetry; rewrite H1.
+   apply ME.eq_lt with a; auto.
+   rewrite <- H0; auto.
+   intros.
+   rewrite H0.
+   apply ME.eq_lt with b; auto.
+   rewrite <- H1; auto.
+  Qed.
+
+  Lemma leb_compat : forall x, compat_bool E.eq (leb x).
+  Proof.
+   red; intros x a b H; unfold leb.
+   f_equal; apply gtb_compat; auto.
+  Qed.
+  Hint Resolve gtb_compat leb_compat.
+
+  Lemma elements_split : forall x s, 
+   elements s = elements_lt x s ++ elements_ge x s.
+  Proof.
+  unfold elements_lt, elements_ge, leb; intros.
+  eapply (@filter_split _ E.eq); eauto with set. ME.order. ME.order. ME.order.
+  intros.
+  rewrite gtb_1 in H.
+  assert (~E.lt y x).
+   unfold gtb in *; destruct (E.compare x y); intuition; try discriminate; ME.order.
+  ME.order.
+  Qed.
+
+  Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> 
+    eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). 
+  Proof.
+  intros; unfold elements_ge, elements_lt.
+  apply sort_equivlistA_eqlistA; auto with set.
+  apply (@SortA_app _ E.eq); auto.
+  apply (@filter_sort _ E.eq); auto with set; eauto with set.
+  constructor; auto.
+  apply (@filter_sort _ E.eq); auto with set; eauto with set.
+  rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with set).
+  intros.
+  rewrite filter_InA in H1; auto; destruct H1.
+  rewrite leb_1 in H2.
+  rewrite <- elements_iff in H1.
+  assert (~E.eq x y).
+   contradict H; rewrite H; auto.
+  ME.order.
+  intros.
+  rewrite filter_InA in H1; auto; destruct H1.
+  rewrite gtb_1 in H3.
+  inversion_clear H2.
+  ME.order.
+  rewrite filter_InA in H4; auto; destruct H4.
+  rewrite leb_1 in H4.
+  ME.order.
+  red; intros a.
+  rewrite InA_app_iff; rewrite InA_cons.
+  do 2 (rewrite filter_InA; auto).
+  do 2 rewrite <- elements_iff.
+  rewrite leb_1; rewrite gtb_1.
+  rewrite (H0 a); intuition.
+  destruct (E.compare a x); intuition.
+  right; right; split; auto.
+  ME.order.
+  Qed.
+
+  Definition Above x s := forall y, In y s -> E.lt y x.
+  Definition Below x s := forall y, In y s -> E.lt x y.
+
+  Lemma elements_Add_Above : forall s s' x, 
+   Above x s -> Add x s s' -> 
+     eqlistA E.eq (elements s') (elements s ++ x::nil).
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with set.
+  apply (@SortA_app _ E.eq); auto with set.
+  intros.
+  inversion_clear H2.
+  rewrite <- elements_iff in H1.
+  apply ME.lt_eq with x; auto.
+  inversion H3.
+  red; intros a.
+  rewrite InA_app_iff; rewrite InA_cons; rewrite InA_nil.
+  do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
+  Qed.
+
+  Lemma elements_Add_Below : forall s s' x, 
+   Below x s -> Add x s s' -> 
+     eqlistA E.eq (elements s') (x::elements s).
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with set.
+  change (sort E.lt ((x::nil) ++ elements s)).
+  apply (@SortA_app _ E.eq); auto with set.
+  intros.
+  inversion_clear H1.
+  rewrite <- elements_iff in H2.
+  apply ME.eq_lt with x; auto.
+  inversion H3.
+  red; intros a.
+  rewrite InA_cons.
+  do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
+  Qed.
+
+  (** Two other induction principles on sets: we can be more restrictive 
+      on the element we add at each step.  *)
+
+  Lemma set_induction_max :
+   forall P : t -> Type,
+   (forall s : t, Empty s -> P s) ->
+   (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') ->
+   forall s : t, P s.
+  Proof.
+  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
+  case_eq (max_elt s); intros.
+  apply X0 with (remove e s) e; auto with set.
+  apply IHn.
+  assert (S n = S (cardinal (remove e s))).
+   rewrite Heqn; apply cardinal_2 with e; auto with set.
+  inversion H0; auto.
+  red; intros.
+  rewrite remove_iff in H0; destruct H0.
+  generalize (@max_elt_2 s e y H H0); ME.order.
+
+  assert (H0:=max_elt_3 H).
+  rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn.
+  Qed.
+
+  Lemma set_induction_min :
+   forall P : t -> Type,
+   (forall s : t, Empty s -> P s) ->
+   (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') ->
+   forall s : t, P s.
+  Proof.
+  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
+  case_eq (min_elt s); intros.
+  apply X0 with (remove e s) e; auto with set.
+  apply IHn.
+  assert (S n = S (cardinal (remove e s))).
+   rewrite Heqn; apply cardinal_2 with e; auto with set.
+  inversion H0; auto.
+  red; intros.
+  rewrite remove_iff in H0; destruct H0.
+  generalize (@min_elt_2 s e y H H0); ME.order.
+
+  assert (H0:=min_elt_3 H).
+  rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn.
+  Qed.
+
+  (** More properties of [fold] : behavior with respect to Above/Below *)
+
+  Lemma fold_3 :
+   forall s s' x (A : Type) (eqA : A -> A -> Prop)
+     (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A),
+   compat_op E.eq eqA f ->
+   Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
+  Proof.
+  intros.
+  do 2 rewrite M.fold_1.
+  do 2 rewrite <- fold_left_rev_right.
+  change (f x (fold_right f i (rev (elements s)))) with
+    (fold_right f i (rev (x::nil)++rev (elements s))).
+  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
+  rewrite <- distr_rev.
+  apply eqlistA_rev.
+  apply elements_Add_Above; auto.
+  Qed.
+
+  Lemma fold_4 :
+   forall s s' x (A : Type) (eqA : A -> A -> Prop)
+     (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A),
+   compat_op E.eq eqA f ->
+   Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)).
+  Proof.
+  intros.
+  do 2 rewrite M.fold_1.
+  set (g:=fun (a : A) (e : elt) => f e a).
+  change (eqA (fold_left g (elements s') i) (fold_left g (x::elements s) i)).
+  unfold g.
+  do 2 rewrite <- fold_left_rev_right.
+  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
+  apply eqlistA_rev.
+  apply elements_Add_Below; auto.
+  Qed.
+
+  (** The following results have already been proved earlier, 
+    but we can now prove them with one hypothesis less:
+    no need for [(transpose eqA f)]. *)
+
+  Section FoldOpt. 
+  Variables (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA).
+  Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f).
+
+  Lemma fold_equal : 
+   forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
+  Proof.
+  intros; do 2 rewrite M.fold_1.
+  do 2 rewrite <- fold_left_rev_right.
+  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
+  apply eqlistA_rev.
+  apply sort_equivlistA_eqlistA; auto with set.
+  red; intro a; do 2 rewrite <- elements_iff; auto.
+  Qed.
+
+  Lemma fold_init : forall i i' s, eqA i i' -> 
+   eqA (fold f s i) (fold f s i').
+  Proof. 
+  intros; do 2 rewrite M.fold_1.
+  do 2 rewrite <- fold_left_rev_right.
+  induction (rev (elements s)); simpl; auto.
+  Qed.
+
+  Lemma add_fold : forall i 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_2: forall i 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.
+
+  End FoldOpt.
+
+  (** An alternative version of [choose_3] *)
+
+  Lemma choose_equal : forall s s', Equal s s' -> 
+    match choose s, choose s' with  
+      | Some x, Some x' => E.eq x x'
+      | None, None => True
+      | _, _ => False
+     end.
+  Proof.
+  intros s s' H; 
+  generalize (@choose_1 s)(@choose_2 s)
+             (@choose_1 s')(@choose_2 s')(@choose_3 s s'); 
+  destruct (choose s); destruct (choose s'); simpl; intuition.
+  apply H5 with e; rewrite <-H; auto.
+  apply H5 with e; rewrite H; auto.
+  Qed.
+
+End OrdProperties.
diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v
index 8cf85efe..ae51d905 100644
--- a/theories/FSets/FSetToFiniteSet.v
+++ b/theories/FSets/FSetToFiniteSet.v
@@ -11,16 +11,16 @@
  * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
  *              91405 Orsay, France *)
 
-(* $Id: FSetToFiniteSet.v 8876 2006-05-30 13:43:15Z letouzey $ *)
+(* $Id: FSetToFiniteSet.v 10739 2008-04-01 14:45:20Z herbelin $ *)
 
 Require Import Ensembles Finite_sets.
-Require Import FSetInterface FSetProperties OrderedTypeEx.
+Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx.
 
-(** * Going from [FSets] with usual equality 
-    to the old [Ensembles] and [Finite_sets] theory. *)
+(** * Going from [FSets] with usual Leibniz equality 
+    to the good old [Ensembles] and [Finite_sets] theory. *)
 
-Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U).
- Module MP:= Properties(M).
+Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U).
+ Module MP:= WProperties U M.
  Import M MP FM Ensembles Finite_sets.
 
  Definition mkEns : M.t -> Ensemble M.elt := 
@@ -82,7 +82,7 @@ Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U).
  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.
+ split; intro; set_iff; inversion 1; auto with sets.
  inversion H0.
  constructor 2; constructor.
  constructor 1; auto.
@@ -97,7 +97,7 @@ Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U).
  inversion H0.
  constructor 2; constructor.
  constructor 1; auto.
- red in H; rewrite H; unfold E.eq in *.
+ red in H; rewrite H.
  inversion H0; auto.
  inversion H1; auto.
  Qed.
@@ -105,10 +105,10 @@ Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U).
  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; intro; set_iff; inversion 1; auto with sets.
  split; auto.
- swap H1.
- inversion H2; auto.
+ contradict H1.
+ inversion H1; auto.
  Qed.
 
  Lemma mkEns_Finite : forall s, Finite _ (!!s).
@@ -136,4 +136,28 @@ Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U).
  apply Add_Add; auto.
  Qed.
 
+ (** we can even build a function from Finite Ensemble to FSet 
+     ... at least in Prop. *)
+
+ Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> 
+   exists s:M.t, !!s === e.
+ Proof.
+ induction 1.
+ exists M.empty.
+ apply empty_Empty_Set.
+ destruct IHFinite as (s,Hs).
+ exists (M.add x s).
+ apply Extensionality_Ensembles in Hs. 
+ rewrite <- Hs.
+ apply add_Add.
+ Qed.
+
+End WS_to_Finite_set.
+
+
+Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U).
+  Module D := OT_as_DT U.
+  Include WS_to_Finite_set D M.
 End S_to_Finite_set.
+
+
diff --git a/theories/FSets/FSetWeak.v b/theories/FSets/FSetWeak.v
deleted file mode 100644
index c88a7869..00000000
--- a/theories/FSets/FSetWeak.v
+++ /dev/null
@@ -1,16 +0,0 @@
-(***********************************************************************)
-(*  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: FSetWeak.v 9278 2006-10-25 13:43:17Z letouzey $ *)
-
-Require Export DecidableType.
-Require Export DecidableTypeEx.
-Require Export FSetWeakInterface.
-Require Export FSetWeakFacts.
-Require Export FSetWeakProperties.
-Require Export FSetWeakList.
diff --git a/theories/FSets/FSetWeakFacts.v b/theories/FSets/FSetWeakFacts.v
deleted file mode 100644
index 61797a95..00000000
--- a/theories/FSets/FSetWeakFacts.v
+++ /dev/null
@@ -1,421 +0,0 @@
-(***********************************************************************)
-(*  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: FSetWeakFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *)
-
-(** * Finite sets library *)
-
-(** This functor derives additional facts from [FSetInterface.S]. These
-  facts are mainly the specifications of [FSetInterface.S] written using 
-  different styles: equivalence and boolean equalities. 
-  Moreover, we prove that [E.Eq] and [Equal] are setoid equalities.
-*)
-
-Require Export FSetWeakInterface. 
-Set Implicit Arguments.
-Unset Strict Implicit.
-
-Module Facts (M: S).
-Import M.E.
-Import M.
-Import Logic. (* to unmask [eq] *)  
-
-(** * Specifications written using equivalences *)
-
-Section IffSpec. 
-Variable s s' s'' : t.
-Variable x y z : elt.
-
-Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s).
-Proof.
-split; apply In_1; auto.
-Qed.
-
-Lemma mem_iff : In x s <-> mem x s = true.
-Proof.
-split; [apply mem_1|apply mem_2].
-Qed.
-
-Lemma not_mem_iff : ~In x s <-> mem x s = false.
-Proof.
-rewrite mem_iff; destruct (mem x s); intuition.
-Qed.
-
-Lemma equal_iff : s[=]s' <-> equal s s' = true.
-Proof. 
-split; [apply equal_1|apply equal_2].
-Qed.
-
-Lemma subset_iff : s[<=]s' <-> subset s s' = true.
-Proof. 
-split; [apply subset_1|apply subset_2].
-Qed.
-
-Lemma empty_iff : In x empty <-> False.
-Proof.
-intuition; apply (empty_1 H).
-Qed.
-
-Lemma is_empty_iff : Empty s <-> is_empty s = true. 
-Proof. 
-split; [apply is_empty_1|apply is_empty_2].
-Qed.
-
-Lemma singleton_iff : In y (singleton x) <-> E.eq x y.
-Proof.
-split; [apply singleton_1|apply singleton_2].
-Qed.
-
-Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s.
-Proof. 
-split; [ | destruct 1; [apply add_1|apply add_2]]; auto.
-destruct (eq_dec x y) as [E|E]; auto.
-intro H; right; exact (add_3 E H).
-Qed.
-
-Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s)  <-> In y s).
-Proof.
-split; [apply add_3|apply add_2]; auto.
-Qed.
-
-Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y.
-Proof.
-split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto.
-intro.
-apply (remove_1 H0 H).
-Qed.
-
-Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s).
-Proof.
-split; [apply remove_3|apply remove_2]; auto.
-Qed.
-
-Lemma union_iff : In x (union s s') <-> In x s \/ In x s'.
-Proof.
-split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto.
-Qed.
-
-Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'.
-Proof.
-split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto.
-Qed.
-
-Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'.
-Proof.
-split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto.
-Qed.
-
-Variable f : elt->bool.
-
-Lemma filter_iff :  compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true).
-Proof. 
-split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. 
-Qed.
-
-Lemma for_all_iff : compat_bool E.eq f ->
-  (For_all (fun x => f x = true) s <-> for_all f s = true).
-Proof.
-split; [apply for_all_1 | apply for_all_2]; auto.
-Qed.
- 
-Lemma exists_iff : compat_bool E.eq f ->
-  (Exists (fun x => f x = true) s <-> exists_ f s = true).
-Proof.
-split; [apply exists_1 | apply exists_2]; auto.
-Qed.
-
-Lemma elements_iff : In x s <-> InA E.eq x (elements s).
-Proof. 
-split; [apply elements_1 | apply elements_2].
-Qed.
-
-End IffSpec.
-
-(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *)
-  
-Ltac set_iff := 
- repeat (progress (
-  rewrite add_iff || rewrite remove_iff || rewrite singleton_iff 
-  || rewrite union_iff || rewrite inter_iff || rewrite diff_iff
-  || rewrite empty_iff)).
-
-(**  * Specifications written using boolean predicates *)
-
-Definition eqb x y := if eq_dec x y then true else false.
-
-Section BoolSpec.
-Variable s s' s'' : t.
-Variable x y z : elt.
-
-Lemma mem_b : E.eq x y -> mem x s = mem y s.
-Proof. 
-intros.
-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.
-destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition.
-Qed.
-
-Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s.
-Proof.
-intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H).
-destruct (mem y s); destruct (mem y (add x s)); intuition.
-Qed.
-
-Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y).
-Proof.
-generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb.
-destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition.
-Qed.
-
-Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s.
-Proof.
-intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H).
-destruct (mem y s); destruct (mem y (remove x s)); intuition.
-Qed.
-
-Lemma singleton_b : mem y (singleton x) = eqb x y.
-Proof. 
-generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb.
-destruct (eq_dec x y); destruct (mem y (singleton x)); intuition.
-Qed.
-
-Lemma union_b : mem x (union s s') = mem x s || mem x s'.
-Proof.
-generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x).
-destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition.
-Qed.
-
-Lemma inter_b : mem x (inter s s') = mem x s && mem x s'.
-Proof.
-generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x).
-destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition.
-Qed.
-
-Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s').
-Proof.
-generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x).
-destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition.
-Qed.
-
-Lemma elements_b : mem x s = existsb (eqb x) (elements s).
-Proof.
-generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)).
-rewrite InA_alt.
-destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros.
-symmetry.
-rewrite H1.
-destruct H0 as (H0,_).
-destruct H0 as (a,(Ha1,Ha2)); [ intuition |].
-exists a; intuition.
-unfold eqb; destruct (eq_dec x a); auto.
-rewrite <- H.
-rewrite H0.
-destruct H1 as (H1,_).
-destruct H1 as (a,(Ha1,Ha2)); [intuition|].
-exists a; intuition.
-unfold eqb in *; destruct (eq_dec x a); auto; discriminate.
-Qed.
-
-Variable f : elt->bool.
-
-Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x.
-Proof. 
-intros.
-generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H).
-destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition.
-Qed.
-
-Lemma for_all_b : compat_bool E.eq f ->
-  for_all f s = forallb f (elements s).
-Proof.
-intros.
-generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s).
-unfold For_all.
-destruct (forallb f (elements s)); destruct (for_all f s); auto; intros.
-rewrite <- H1; intros.
-destruct H0 as (H0,_).
-rewrite (H2 x0) in H3.
-rewrite (InA_alt E.eq x0 (elements s)) in H3.
-destruct H3 as (a,(Ha1,Ha2)).
-rewrite (H _ _ Ha1).
-apply H0; auto.
-symmetry.
-rewrite H0; intros.
-destruct H1 as (_,H1).
-apply H1; auto.
-rewrite H2.
-rewrite InA_alt; eauto.
-Qed.
-
-Lemma exists_b : compat_bool E.eq f -> 
-  exists_ f s = existsb f (elements s).
-Proof.
-intros.
-generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s).
-unfold Exists.
-destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros.
-rewrite <- H1; intros.
-destruct H0 as (H0,_).
-destruct H0 as (a,(Ha1,Ha2)); auto.
-exists a; auto.
-split; auto.
-rewrite H2; rewrite InA_alt; eauto.
-symmetry.
-rewrite H0.
-destruct H1 as (_,H1).
-destruct H1 as (a,(Ha1,Ha2)); auto.
-rewrite (H2 a) in Ha1.
-rewrite (InA_alt E.eq a (elements s)) in Ha1.
-destruct Ha1 as (b,(Hb1,Hb2)).
-exists b; auto.
-rewrite <- (H _ _ Hb1); auto.
-Qed.
-
-End BoolSpec.
-
-(** * [E.eq] and [Equal] are setoid equalities *)
-
-Definition E_ST : Setoid_Theory elt E.eq.
-Proof.
-constructor; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans].
-Qed.
-
-Add Setoid elt E.eq E_ST as EltSetoid.
-
-Definition Equal_ST : Setoid_Theory t Equal.
-Proof. 
-constructor; unfold Equal; firstorder.
-Qed.
-
-Add Setoid t Equal Equal_ST as EqualSetoid.
-
-Add Morphism In with signature E.eq ==> Equal ==> iff as In_m.
-Proof.
-unfold Equal; intros x y H s s' H0.
-rewrite (In_eq_iff s H); auto.
-Qed.
-
-Add Morphism is_empty : is_empty_m.
-Proof.
-unfold Equal; intros s s' H.
-generalize (is_empty_iff s)(is_empty_iff s').
-destruct (is_empty s); destruct (is_empty s'); 
- unfold Empty; auto; intros.
-symmetry.
-rewrite <- H1; intros a Ha.
-rewrite <- (H a) in Ha.
-destruct H0 as (_,H0).
-exact (H0 (refl_equal true) _ Ha).
-rewrite <- H0; intros a Ha.
-rewrite (H a) in Ha.
-destruct H1 as (_,H1).
-exact (H1 (refl_equal true) _ Ha).
-Qed.
-
-Add Morphism Empty with signature Equal ==> iff as Empty_m.
-Proof. 
-intros; do 2 rewrite is_empty_iff; rewrite H; intuition.
-Qed.
-
-Add Morphism mem : mem_m.
-Proof.
-unfold Equal; intros x y H s s' H0.
-generalize (H0 x); clear H0; rewrite (In_eq_iff s' H).
-generalize (mem_iff s x)(mem_iff s' y).
-destruct (mem x s); destruct (mem y s'); intuition.
-Qed.
-
-Add Morphism singleton : singleton_m.
-Proof.
-unfold Equal; intros x y H a.
-do 2 rewrite singleton_iff; split.
-intros; apply E.eq_trans with x; auto.
-intros; apply E.eq_trans with y; auto.
-Qed.
-
-Add Morphism add : add_m.
-Proof.
-unfold Equal; intros x y H s s' H0 a.
-do 2 rewrite add_iff; rewrite H; rewrite H0; intuition.
-Qed.
-
-Add Morphism remove : remove_m.
-Proof.
-unfold Equal; intros x y H s s' H0 a.
-do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition.
-Qed.
-
-Add Morphism union : union_m.
-Proof.
-unfold Equal; intros s s' H s'' s''' H0 a.
-do 2 rewrite union_iff; rewrite H; rewrite H0; intuition.
-Qed.
-
-Add Morphism inter : inter_m.
-Proof.
-unfold Equal; intros s s' H s'' s''' H0 a.
-do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition.
-Qed.
-
-Add Morphism diff : diff_m.
-Proof.
-unfold Equal; intros s s' H s'' s''' H0 a.
-do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition.
-Qed.
-
-Add Morphism Subset with signature Equal ==> Equal ==> iff as  Subset_m.
-Proof. 
-unfold Equal, Subset; firstorder.
-Qed.
-
-Add Morphism subset : subset_m.
-Proof.
-intros s s' H s'' s''' H0.
-generalize (subset_iff s s'') (subset_iff s' s'''). 
-destruct (subset s s''); destruct (subset s' s'''); auto; intros.
-rewrite H in H1; rewrite H0 in H1; intuition.
-rewrite H in H1; rewrite H0 in H1; intuition.
-Qed.
-
-Add Morphism equal : equal_m.
-Proof.
-intros s s' H s'' s''' H0.
-generalize (equal_iff s s'') (equal_iff s' s''').
-destruct (equal s s''); destruct (equal s' s'''); auto; intros.
-rewrite H in H1; rewrite H0 in H1; intuition.
-rewrite H in H1; rewrite H0 in H1; intuition.
-Qed.
-
-(* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism
-   without additional hypothesis on [f]. For instance: *)
-
-Lemma filter_equal : forall f, compat_bool E.eq f -> 
-  forall s s', s[=]s' -> filter f s [=] filter f s'.
-Proof.
-unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto.
-Qed.
-
-(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid 
-   structures on [list elt] and [option elt]. *)
-
-(* Later:
-Add Morphism cardinal ; cardinal_m.
-*)
-
-End Facts.
diff --git a/theories/FSets/FSetWeakInterface.v b/theories/FSets/FSetWeakInterface.v
deleted file mode 100644
index a281ce22..00000000
--- a/theories/FSets/FSetWeakInterface.v
+++ /dev/null
@@ -1,251 +0,0 @@
-(***********************************************************************)
-(*  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: FSetWeakInterface.v 8820 2006-05-15 11:44:05Z letouzey $ *)
-
-(** * Finite sets library *)
-
-(** Set interfaces for types with only a decidable equality, but no ordering *)
-
-Require Export Bool.
-Require Export DecidableType.
-Set Implicit Arguments.
-Unset Strict Implicit.
-
-(** Compatibility of a  boolean function with respect to an equality. *)
-Definition compat_bool (A:Set)(eqA: A->A->Prop)(f: A-> bool) :=
-  forall x y : A, eqA x y -> f x = f y.
-
-(** Compatibility of a predicate with respect to an equality. *)
-Definition compat_P (A:Set)(eqA: A->A->Prop)(P : A -> Prop) :=
-  forall x y : A, eqA x y -> P x -> P y.
-
-Hint Unfold compat_bool compat_P.
-
-(** * Non-dependent signature
-
-    Signature [S] presents sets as purely informative programs 
-    together with axioms *)
-
-Module Type S.
-
-  Declare Module E : DecidableType.
-  Definition elt := E.t.
-
-  Parameter t : Set. (** the abstract type of sets *)
-
-  (** Logical predicates *)
-  Parameter In : elt -> t -> Prop.
-  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.
-  
-  Notation "s [=] t" := (Equal s t) (at level 70, no associativity).
-  Notation "s [<=] t" := (Subset s t) (at level 70, no associativity).
-
-  Parameter empty : t.
-  (** The empty set. *)
-
-  Parameter is_empty : t -> bool.
-  (** Test whether a set is empty or not. *)
-
-  Parameter mem : elt -> t -> bool.
-  (** [mem x s] tests whether [x] belongs to the set [s]. *)
-
-  Parameter add : elt -> t -> t.
-  (** [add x s] returns a set containing all elements of [s],
-  plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
-
-  Parameter singleton : elt -> t.
-  (** [singleton x] returns the one-element set containing only [x]. *)
-
-  Parameter remove : elt -> t -> t.
-  (** [remove x s] returns a set containing all elements of [s],
-  except [x]. If [x] was not in [s], [s] is returned unchanged. *)
-
-  Parameter union : t -> t -> t.
-  (** Set union. *)
-
-  Parameter inter : t -> t -> t.
-  (** Set intersection. *)
-
-  Parameter diff : t -> t -> t.
-  (** Set difference. *)
-
-  Parameter equal : t -> t -> bool.
-  (** [equal s1 s2] tests whether the sets [s1] and [s2] are
-  equal, that is, contain equal elements. *)
-
-  Parameter subset : t -> t -> bool.
-  (** [subset s1 s2] tests whether the set [s1] is a subset of
-  the set [s2]. *)
-
-  (** Coq comment: [iter] is useless in a purely functional world *)
-  (**  iter: (elt -> unit) -> set -> unit. i*)
-  (** [iter f s] applies [f] in turn to all elements of [s].
-  The order in which the elements of [s] are presented to [f]
-  is unspecified. *)
-
-  Parameter fold : forall A : Set, (elt -> A -> A) -> t -> A -> A.
-  (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
-  where [x1 ... xN] are the elements of [s].
-  The order in which elements of [s] are presented to [f] is
-  unspecified. *)
-
-  Parameter for_all : (elt -> bool) -> t -> bool.
-  (** [for_all p s] checks if all elements of the set
-  satisfy the predicate [p]. *)
-
-  Parameter exists_ : (elt -> bool) -> t -> bool.
-  (** [exists p s] checks if at least one element of
-  the set satisfies the predicate [p]. *)
-
-  Parameter filter : (elt -> bool) -> t -> t.
-  (** [filter p s] returns the set of all elements in [s]
-  that satisfy predicate [p]. *)
-
-  Parameter partition : (elt -> bool) -> t -> t * t.
-  (** [partition p s] returns a pair of sets [(s1, s2)], where
-  [s1] is the set of all the elements of [s] that satisfy the
-  predicate [p], and [s2] is the set of all the elements of
-  [s] that do not satisfy [p]. *)
-
-  Parameter cardinal : t -> nat.
-  (** Return the number of elements of a set. *)
-  (** Coq comment: nat instead of int ... *)
-
-  Parameter elements : t -> list elt.
-  (** Return the list of all elements of the given set, in any order. *)
-
-  Parameter choose : t -> option elt.
-  (** Return one element of the given set, or raise [Not_found] if
-  the set is empty. Which element is chosen is unspecified.
-  Equal sets could return different elements. *)
-  (** Coq comment: [Not_found] is represented by the option type *)
-
-  Section Spec. 
-
-  Variable s s' : t.
-  Variable x y : elt.
-
-  (** Specification of [In] *)
-  Parameter In_1 : E.eq x y -> In x s -> In y s.
- 
-  (** Specification of [mem] *)
-  Parameter mem_1 : In x s -> mem x s = true.
-  Parameter mem_2 : mem x s = true -> In x s. 
- 
-  (** Specification of [equal] *) 
-  Parameter equal_1 : Equal s s' -> equal s s' = true.
-  Parameter equal_2 : equal s s' = true -> Equal s s'.
-
-  (** Specification of [subset] *)
-  Parameter subset_1 : Subset s s' -> subset s s' = true.
-  Parameter subset_2 : subset s s' = true -> Subset s s'.
-
-  (** Specification of [empty] *)
-  Parameter empty_1 : Empty empty.
-
-  (** Specification of [is_empty] *)
-  Parameter is_empty_1 : Empty s -> is_empty s = true. 
-  Parameter is_empty_2 : is_empty s = true -> Empty s.
- 
-  (** Specification of [add] *)
-  Parameter add_1 : E.eq x y -> In y (add x s).
-  Parameter add_2 : In y s -> In y (add x s).
-  Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
-
-  (** Specification of [remove] *)
-  Parameter remove_1 : E.eq x y -> ~ In y (remove x s).
-  Parameter remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
-  Parameter remove_3 : In y (remove x s) -> In y s.
-
-  (** Specification of [singleton] *)
-  Parameter singleton_1 : In y (singleton x) -> E.eq x y. 
-  Parameter singleton_2 : E.eq x y -> In y (singleton x). 
-
-  (** Specification of [union] *)
-  Parameter union_1 : In x (union s s') -> In x s \/ In x s'.
-  Parameter union_2 : In x s -> In x (union s s'). 
-  Parameter union_3 : In x s' -> In x (union s s').
-
-  (** Specification of [inter] *)
-  Parameter inter_1 : In x (inter s s') -> In x s.
-  Parameter inter_2 : In x (inter s s') -> In x s'.
-  Parameter inter_3 : In x s -> In x s' -> In x (inter s s').
-
-  (** Specification of [diff] *)
-  Parameter diff_1 : In x (diff s s') -> In x s. 
-  Parameter diff_2 : In x (diff s s') -> ~ In x s'.
-  Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s').
- 
-  (** Specification of [fold] *)  
-  Parameter 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.
-
-  (** Specification of [cardinal] *)  
-  Parameter cardinal_1 : cardinal s = length (elements s).
-
-  Section Filter.
-  
-  Variable f : elt -> bool.
-
-  (** Specification of [filter] *)
-  Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
-  Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
-  Parameter filter_3 :
-      compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
-
-  (** Specification of [for_all] *)
-  Parameter for_all_1 :
-      compat_bool E.eq f ->
-      For_all (fun x => f x = true) s -> for_all f s = true.
-  Parameter for_all_2 :
-      compat_bool E.eq f ->
-      for_all f s = true -> For_all (fun x => f x = true) s.
-
-  (** Specification of [exists] *)
-  Parameter exists_1 :
-      compat_bool E.eq f ->
-      Exists (fun x => f x = true) s -> exists_ f s = true.
-  Parameter exists_2 :
-      compat_bool E.eq f ->
-      exists_ f s = true -> Exists (fun x => f x = true) s.
-
-  (** Specification of [partition] *)
-  Parameter partition_1 :
-      compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
-  Parameter partition_2 :
-      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 Spec.
-
-  Hint Immediate In_1.
-  
-  Hint Resolve mem_1 mem_2 equal_1 equal_2 subset_1 subset_2 empty_1
-    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
-    elements_3.
-
-End S.
diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v
index 97080b7a..71a0d584 100644
--- a/theories/FSets/FSetWeakList.v
+++ b/theories/FSets/FSetWeakList.v
@@ -6,14 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSetWeakList.v 8834 2006-05-20 00:41:35Z letouzey $ *)
+(* $Id: FSetWeakList.v 10631 2008-03-06 18:17:24Z msozeau $ *)
 
 (** * Finite sets library *)
 
 (** This file proposes an implementation of the non-dependant 
     interface [FSetWeakInterface.S] using lists without redundancy. *)
 
-Require Import FSetWeakInterface.
+Require Import FSetInterface.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
@@ -24,8 +24,6 @@ Unset Strict Implicit.
    And the functions returning sets are proved to preserve this invariant. *)
 
 Module Raw (X: DecidableType).
- 
-  Module E := X.
 
   Definition elt := X.t.
   Definition t := list elt.
@@ -59,7 +57,7 @@ Module Raw (X: DecidableType).
         if X.eq_dec x y then l else y :: remove x l
     end.
 
-  Fixpoint fold (B : Set) (f : elt -> B -> B) (s : t) {struct s} : 
+  Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : 
    B -> B := fun i => match s with
                       | nil => i
                       | x :: l => fold f l (f x i)
@@ -127,7 +125,7 @@ Module Raw (X: DecidableType).
   Lemma In_eq :
     forall (s : t) (x y : elt), X.eq x y -> In x s -> In y s.
   Proof.
-  intros s x y; do 2 setoid_rewrite InA_alt; firstorder eauto.
+  intros s x y; setoid_rewrite InA_alt; firstorder eauto.
   Qed.
   Hint Immediate In_eq.
 
@@ -287,13 +285,13 @@ Module Raw (X: DecidableType).
   unfold elements; auto.
   Qed.
  
-  Lemma elements_3 : forall (s : t) (Hs : NoDup s), NoDup (elements s).  
+  Lemma elements_3w : forall (s : t) (Hs : NoDup s), NoDup (elements s).  
   Proof. 
   unfold elements; auto.
   Qed.
 
   Lemma fold_1 :
-   forall (s : t) (Hs : NoDup s) (A : Set) (i : A) (f : elt -> A -> A),
+   forall (s : t) (Hs : NoDup s) (A : Type) (i : A) (f : elt -> A -> A),
    fold f s i = fold_left (fun a e => f e a) (elements s) i.
   Proof.
   induction s; simpl; auto; intros.
@@ -732,22 +730,68 @@ Module Raw (X: DecidableType).
   generalize (Hrec H0 f).
   case (f x); case (partition f l); simpl; auto.
   Qed.
- 
+
   Definition eq : t -> t -> Prop := Equal.
 
-  Lemma eq_refl : forall s : t, eq s s. 
-  Proof. 
-  unfold eq, Equal; intuition.
-  Qed.
+  Lemma eq_refl : forall s, eq s s. 
+  Proof. firstorder. Qed.
 
-  Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s.
-  Proof. 
-  unfold eq, Equal; firstorder.
-  Qed.
+  Lemma eq_sym : forall s s', eq s s' -> eq s' s.
+  Proof. firstorder. Qed.
 
-  Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
-  Proof. 
-  unfold eq, Equal; firstorder.
+  Lemma eq_trans : 
+   forall s s' s'', eq s s' -> eq s' s'' -> eq s s''.
+  Proof. firstorder. Qed.
+
+  Definition eq_dec : forall (s s':t)(Hs:NoDup s)(Hs':NoDup s'), 
+   { eq s s' }+{ ~eq s s' }.
+  Proof.
+  unfold eq.
+  induction s; intros s'.
+  (* nil *)
+   destruct s'; [left|right].
+   firstorder.
+   unfold not, Equal.
+   intros H; generalize (H e); clear H.
+   rewrite InA_nil, InA_cons; intuition.
+  (* cons *)
+   intros.
+   case_eq (mem a s'); intros H; 
+    [ destruct (IHs (remove a s')) as [H'|H']; 
+      [ | | left|right]|right]; 
+    clear IHs.
+   inversion_clear Hs; auto.
+   apply remove_unique; auto.
+   (* In a s' /\ s [=] remove a s' *)
+   generalize (mem_2 H); clear H; intro H.
+   unfold Equal in *; intros b.
+   rewrite InA_cons; split.
+   destruct 1.
+   apply In_eq with a; auto.
+   rewrite H' in H0.
+   apply remove_3 with a; auto.
+   destruct (X.eq_dec b a); [left|right]; auto.
+   rewrite H'.
+   apply remove_2; auto.
+   (* In a s' /\ ~ s [=] remove a s' *)
+   generalize (mem_2 H); clear H; intro H.
+   contradict H'.
+   unfold Equal in *; intros b.
+   split; intros.
+   apply remove_2; auto.
+   inversion_clear Hs.
+   contradict H1; apply In_eq with b; auto.
+   rewrite <- H'; rewrite InA_cons; auto.
+   assert (In b s') by (apply remove_3 with a; auto).
+   rewrite <- H', InA_cons in H1; destruct H1; auto.
+   elim (remove_1 Hs' (X.eq_sym H1) H0).
+   (* ~ In a s' *)
+   assert (~In a s').
+    red; intro H'; rewrite (mem_1 H') in H; discriminate.
+   contradict H0.
+   unfold Equal in *.
+   rewrite <- H0.
+   rewrite InA_cons; auto.
   Qed.
 
   End ForNotations.
@@ -758,12 +802,12 @@ End Raw.
    Now, in order to really provide a functor implementing [S], we 
    need to encapsulate everything into a type of lists without redundancy. *)
 
-Module Make (X: DecidableType) <: S with Module E := X.
+Module Make (X: DecidableType) <: WS with Module E := X.
 
  Module Raw := Raw X. 
  Module E := X.
 
- Record slist : Set :=  {this :> Raw.t; unique : NoDupA E.eq this}.
+ Record slist := {this :> Raw.t; unique : NoDupA E.eq this}.
  Definition t := slist. 
  Definition elt := E.t.
  
@@ -791,7 +835,7 @@ Module Make (X: DecidableType) <: S with Module E := X.
  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 fold (B : Type) (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).
@@ -872,7 +916,7 @@ Module Make (X: DecidableType) <: S with Module E := X.
   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.
  
-  Lemma fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A),
+  Lemma fold_1 : forall (A : Type) (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.
 
@@ -923,8 +967,8 @@ Module Make (X: DecidableType) <: S with Module E := X.
   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 elements_3w : NoDupA E.eq (elements s).
+  Proof. exact (Raw.elements_3w s.(unique)). Qed.
 
   Lemma choose_1 : choose s = Some x -> In x s.
   Proof. exact (fun H => Raw.choose_1 H). Qed.
@@ -933,4 +977,22 @@ Module Make (X: DecidableType) <: S with Module E := X.
 
  End Spec.
 
+ Definition eq : t -> t -> Prop := Equal.
+
+ Lemma eq_refl : forall s, eq s s. 
+ Proof. firstorder. Qed.
+
+ Lemma eq_sym : forall s s', eq s s' -> eq s' s.
+ Proof. firstorder. Qed.
+
+ Lemma eq_trans : 
+  forall s s' s'', eq s s' -> eq s' s'' -> eq s s''.
+ Proof. firstorder. Qed.
+
+ Definition eq_dec : forall (s s':t), 
+  { eq s s' }+{ ~eq s s' }.
+ Proof. 
+  intros s s'; exact (Raw.eq_dec s.(unique) s'.(unique)). 
+ Qed.
+
 End Make.
diff --git a/theories/FSets/FSetWeakProperties.v b/theories/FSets/FSetWeakProperties.v
deleted file mode 100644
index a0054d36..00000000
--- a/theories/FSets/FSetWeakProperties.v
+++ /dev/null
@@ -1,896 +0,0 @@
-(***********************************************************************)
-(*  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 b0402db6..a73c1da7 100644
--- a/theories/FSets/FSets.v
+++ b/theories/FSets/FSets.v
@@ -6,13 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: FSets.v 8897 2006-06-05 21:04:10Z letouzey $ *)
+(* $Id: FSets.v 10699 2008-03-19 20:56:43Z letouzey $ *)
 
 Require Export OrderedType.
 Require Export OrderedTypeEx.
 Require Export OrderedTypeAlt.
+Require Export DecidableType.
+Require Export DecidableTypeEx.
 Require Export FSetInterface.
 Require Export FSetBridge.
+Require Export FSetFacts.
+Require Export FSetDecide.
 Require Export FSetProperties.
 Require Export FSetEqProperties.
+Require Export FSetWeakList.
 Require Export FSetList.
+Require Export FSetAVL.
\ No newline at end of file
diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v
index f966cd4d..c56a24cf 100644
--- a/theories/FSets/OrderedType.v
+++ b/theories/FSets/OrderedType.v
@@ -6,32 +6,25 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: OrderedType.v 8834 2006-05-20 00:41:35Z letouzey $ *)
+(* $Id: OrderedType.v 10616 2008-03-04 17:33:35Z letouzey $ *)
 
 Require Export SetoidList.
 Set Implicit Arguments.
 Unset Strict Implicit.
 
-(* TODO concernant la tactique order: 
-   * propagate_lt n'est sans doute pas complet
-   * un propagate_le
-   * exploiter les hypotheses negatives restant a la fin
-   * faire que ca marche meme quand une hypothese depend d'un eq ou lt.
-*) 
-
 (** * Ordered types *)
 
-Inductive Compare (X : Set) (lt eq : X -> X -> Prop) (x y : X) : Set :=
+Inductive Compare (X : Type) (lt eq : X -> X -> Prop) (x y : X) : Type :=
   | LT : lt x y -> Compare lt eq x y
   | EQ : eq x y -> Compare lt eq x y
   | GT : lt y x -> Compare lt eq x y.
 
 Module Type OrderedType.
 
-  Parameter t : Set.
+  Parameter Inline t : Type.
 
-  Parameter eq : t -> t -> Prop.
-  Parameter lt : t -> t -> Prop.
+  Parameter Inline eq : t -> t -> Prop.
+  Parameter Inline lt : t -> t -> Prop.
 
   Axiom eq_refl : forall x : t, eq x x.
   Axiom eq_sym : forall x y : t, eq x y -> eq y x.
@@ -122,6 +115,13 @@ Module OrderedTypeFacts (O: OrderedType).
    intuition.
   Qed.
 
+(* TODO concernant la tactique order: 
+   * propagate_lt n'est sans doute pas complet
+   * un propagate_le
+   * exploiter les hypotheses negatives restant a la fin
+   * faire que ca marche meme quand une hypothese depend d'un eq ou lt.
+*) 
+
 Ltac abstraction := match goal with 
  (* First, some obvious simplifications *)
  | H : False |- _ => elim H
@@ -137,9 +137,9 @@ Ltac abstraction := match goal with
  | H1: ~lt ?x ?y, H2: ~eq ?y ?x |- _ => 
      generalize (le_neq H1 (neq_sym H2)); clear H1 H2; intro; abstraction
  (* Then, we generalize all interesting facts *)
- | H : lt ?x ?y |- _ => revert H; abstraction
- | H : ~lt ?x ?y |- _ => revert H; abstraction  
  | H : ~eq ?x ?y |- _ =>  revert H; abstraction
+ | H : ~lt ?x ?y |- _ => revert H; abstraction  
+ | H : lt ?x ?y |- _ => revert H; abstraction
  | H : eq ?x ?y |- _ =>  revert H; abstraction
  | _ => idtac
 end.
@@ -192,7 +192,7 @@ Ltac do_lt x y LT := match goal with
  | |- lt ?z x -> _ => let H := fresh "H" in 
      (intro H; generalize (lt_trans H LT); intro); do_lt x y LT
  | |- lt _ _ -> _ => intro; do_lt x y LT
- (* Ge *)
+ (* GE *)
  | |- ~lt y x -> _ => intros _; do_lt x y LT
  | |- ~lt x ?z -> _ => let H := fresh "H" in 
      (intro H; generalize (le_lt_trans H LT); intro); do_lt x y LT
@@ -296,12 +296,12 @@ Ltac false_order := elimtype False; order.
   Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
   Proof.
    intros; elim (compare x y); [ right | left | right ]; auto.
-  Qed.
+  Defined.
  
   Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}.
   Proof.
    intros; elim (compare x y); [ left | right | right ]; auto.
-  Qed.
+  Defined.
 
   Definition eqb x y : bool := if eq_dec x y then true else false.
 
@@ -361,7 +361,7 @@ Module KeyOrderedType(O:OrderedType).
  Import MO.
 
  Section Elt.
- Variable elt : Set.
+ Variable elt : Type.
  Notation key:=t.
 
   Definition eqk (p p':key*elt) := eq (fst p) (fst p').
diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/FSets/OrderedTypeAlt.v
index 9bcfbfc7..516df0f0 100644
--- a/theories/FSets/OrderedTypeAlt.v
+++ b/theories/FSets/OrderedTypeAlt.v
@@ -11,19 +11,19 @@
  * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
  *              91405 Orsay, France *)
 
-(* $Id: OrderedTypeAlt.v 8773 2006-04-29 14:31:32Z letouzey $ *)
+(* $Id: OrderedTypeAlt.v 10739 2008-04-01 14:45:20Z herbelin $ *)
 
 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 _ ] 
+(** NB: [comparison], defined in [Datatypes.v] is [Eq|Lt|Gt]
+whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ] 
 *)
 
 Module Type OrderedTypeAlt.
 
- Parameter t : Set.
+ Parameter t : Type.
  
  Parameter compare : t -> t -> comparison.
 
@@ -103,24 +103,16 @@ Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt.
  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.
+ intros x y; unfold compare.
+ destruct O.compare; 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.
+ destruct c; unfold compare; 
+ do 2 (destruct O.compare; intros; try discriminate); 
  elim_comp; auto.
  Qed.
 
diff --git a/theories/FSets/OrderedTypeEx.v b/theories/FSets/OrderedTypeEx.v
index 28a5705d..03171396 100644
--- a/theories/FSets/OrderedTypeEx.v
+++ b/theories/FSets/OrderedTypeEx.v
@@ -11,7 +11,7 @@
  * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
  *              91405 Orsay, France *)
 
-(* $Id: OrderedTypeEx.v 9940 2007-07-05 12:32:47Z letouzey $ *)
+(* $Id: OrderedTypeEx.v 10739 2008-04-01 14:45:20Z herbelin $ *)
 
 Require Import OrderedType.
 Require Import ZArith.
@@ -25,9 +25,9 @@ Require Import Compare_dec.
     the equality is the usual one of Coq. *)
 
 Module Type UsualOrderedType.
- Parameter t : Set.
+ Parameter Inline t : Type.
  Definition eq := @eq t.
- Parameter lt : t -> t -> Prop.
+ Parameter Inline lt : t -> t -> Prop.
  Definition eq_refl := @refl_equal t.
  Definition eq_sym := @sym_eq t.
  Definition eq_trans := @trans_eq t.
@@ -154,16 +154,16 @@ Module N_as_OT <: UsualOrderedType.
   Definition eq_sym := @sym_eq t.
   Definition eq_trans := @trans_eq t.
 
-  Definition lt p q:= Nle q p = false.
+  Definition lt p q:= Nleb q p = false.
  
-  Definition lt_trans := Nlt_trans.
+  Definition lt_trans := Nltb_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.
+  rewrite Nleb_refl in H; discriminate.
   Qed.
 
   Definition compare : forall x y : t, Compare lt eq x y.
@@ -172,16 +172,15 @@ Module N_as_OT <: UsualOrderedType.
   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.
+   generalize (Nleb_Nle y x).
+   unfold Nle; rewrite <- Ncompare_antisym.
    destruct (x ?= y)%N; simpl; try discriminate.
-   intros (H0,_); elim H0; auto.
+   clear H; intros H.
+   destruct (Nleb y x); intuition.
   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.
+   generalize (Nleb_Nle x y).
+   unfold Nle; destruct (x ?= y)%N; simpl; try discriminate.
+   destruct (Nleb x y); intuition.
   Defined.
 
 End N_as_OT.